carp-lang/Carp
1
1
Fork 0
mirror of https://github.com/carp-lang/Carp.git synced 2024-09-11 05:25:28 +03:00
Code Issues Projects Releases Wiki Activity

refactor: Make Lookup module more focused and DRY (#1054)

Browse Source 
* refactor: Move constraints test to own module, create TestLookup module

* refactor: Extracted 'Env' module

* refactor: Extracted 'TypePredicates' module

* test: First, very simple test

* refactor: Extracted 'Managed' module

* refactor: Add 'lookupBinder' function that doesn't return an Env (often what we want)

* refactor: Move out more stuff from Lookup

* refactor: Use new 'lookupBinder' in tons of places (avoids tuple)

* refactor: Got rid of monolithic 'recursiveLookupInternal'

* refactor: Avoid boolean blindness

* refactor: Better names for some lookup functions

* refactor: More logical order in Lookup.hs

* style: Use correct version of ormolu (0.1.4.1)

* refactor: Slightly more consistent naming

* refactor: Address @scolsen:s feedback
This commit is contained in:
Erik Svedäng 2020-12-07 07:06:32 +01:00 committed by GitHub
parent 09fdd80f94
commit b1aaa83b6a
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
29 changed files with 638 additions and 604 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
CarpHask.cabal
View File

@ -57,7 +57,10 @@ library
Interfaces,
Primitives,
Validate,
Reify
Reify,
Env,
TypePredicates,
Managed
build-depends: base >= 4.7 && < 5
, parsec == 3.1.*
@ -112,6 +115,8 @@ test-suite CarpHask-test
, CarpHask
, HUnit
, containers
other-modules: TestConstraints
, TestLookup
ghc-options: -threaded -rtsopts -with-rtsopts=-N
default-language: Haskell2010

2
src/ArrayTemplates.hs
View File

@ -3,7 +3,7 @@
module ArrayTemplates where
import Concretize
import Lookup
import Managed
import Obj
import Template
import ToTemplate

12
src/Commands.hs
View File

@ -726,10 +726,10 @@ commandSaveDocsInternal ctx [modulePath] = do
where
getEnvironmentBinderForDocumentation :: Context -> Env -> SymPath -> Either String Binder
getEnvironmentBinderForDocumentation _ env path =
case lookupInEnv path env of
Just (_, foundBinder@(Binder _ (XObj (Mod _) _ _))) ->
case lookupBinder path env of
Just foundBinder@(Binder _ (XObj (Mod _) _ _)) ->
Right foundBinder
Just (_, Binder _ x) ->
Just (Binder _ x) ->
Left ("I can’t generate documentation for `" ++ pretty x ++ "` because it isn’t a module")
Nothing ->
Left ("I can’t find the module `" ++ show path ++ "`")
@ -758,10 +758,10 @@ commandSexpressionInternal ctx [xobj] bol =
mdl@(XObj (Mod e) _ _) ->
if bol
then getMod
else case lookupInEnv (SymPath [] (fromMaybe "" (envModuleName e))) tyEnv of
Just (_, Binder _ (XObj (Lst forms) i t)) ->
else case lookupBinder (SymPath [] (fromMaybe "" (envModuleName e))) tyEnv of
Just (Binder _ (XObj (Lst forms) i t)) ->
pure (ctx, Right (XObj (Lst (map toSymbols forms)) i t))
Just (_, Binder _ xobj') ->
Just (Binder _ xobj') ->
pure (ctx, Right (toSymbols xobj'))
Nothing ->
getMod

9
src/Concretize.hs
View File

@ -11,14 +11,17 @@ import Data.Maybe (fromMaybe)
import Data.Set ((\\))
import qualified Data.Set as Set
import Debug.Trace
import Env
import Info
import Lookup
import Managed
import Obj
import Polymorphism
import Reify
import SumtypeCase
import ToTemplate
import TypeError
import TypePredicates
import Types
import TypesToC
import Util
@ -313,8 +316,8 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
visitMultiSym _ _ _ = error "Not a multi symbol."
visitInterfaceSym :: Bool -> Env -> XObj -> State [XObj] (Either TypeError XObj)
visitInterfaceSym allowAmbig env xobj@(XObj (InterfaceSym name) i t) =
case lookupInEnv (SymPath [] name) (getTypeEnv typeEnv) of
Just (_, Binder _ (XObj (Lst [XObj (Interface _ interfacePaths) _ _, _]) _ _)) ->
case lookupBinder (SymPath [] name) (getTypeEnv typeEnv) of
Just (Binder _ (XObj (Lst [XObj (Interface _ interfacePaths) _ _, _]) _ _)) ->
let Just actualType = t
tys = map (typeFromPath env) interfacePaths
tysToPathsDict = zip tys interfacePaths
@ -662,7 +665,7 @@ concretizeDefinition allowAmbiguity typeEnv globalEnv visitedDefinitions definit
-- | Find ALL functions with a certain name, matching a type signature.
allFunctionsWithNameAndSignature :: Env -> String -> Ty -> [(Env, Binder)]
allFunctionsWithNameAndSignature env functionName functionType =
filter (predicate . xobjTy . binderXObj . snd) (multiLookupALL functionName env)
filter (predicate . xobjTy . binderXObj . snd) (multiLookupEverywhere functionName env)
where
predicate (Just t) =
--trace ("areUnifiable? " ++ show functionType ++ " == " ++ show t ++ " " ++ show (areUnifiable functionType t)) $

14
src/Constraints.hs
View File

@ -3,7 +3,7 @@ module Constraints
Constraint (..),
ConstraintOrder (..),
UnificationFailure (..),
recursiveLookup,
recursiveNameLookup,
debugSolveOne, -- exported to avoid warning about unused function (should be another way...)
debugResolveFully, -- exported to avoid warning about unused function
)
@ -68,8 +68,8 @@ instance Show Constraint where
show (Constraint a b _ _ _ ord) = "{" ++ show a ++ " == " ++ show b ++ " (ord " ++ show ord ++ ")} " -- ++ show (fmap infoLine (info xa)) ++ ", " ++ show (fmap infoLine (info xb)) ++ " in " ++ show ctx
-- Finds the symbol with the "lowest name" (first in alphabetical order)
recursiveLookup :: TypeMappings -> String -> Maybe Ty
recursiveLookup mappings name = innerLookup name []
recursiveNameLookup :: TypeMappings -> String -> Maybe Ty
recursiveNameLookup mappings name = innerLookup name []
where
innerLookup :: String -> [Ty] -> Maybe Ty
innerLookup k visited =
@ -200,7 +200,7 @@ checkForConflict mappings constraint name otherTy =
checkConflictInternal :: TypeMappings -> Constraint -> String -> Ty -> Either UnificationFailure TypeMappings
checkConflictInternal mappings constraint name otherTy =
let (Constraint _ _ xobj1 xobj2 ctx _) = constraint
found = recursiveLookup mappings name
found = recursiveNameLookup mappings name
in case found of --trace ("CHECK CONFLICT " ++ show constraint ++ " with name " ++ name ++ ", otherTy: " ++ show otherTy ++ ", found: " ++ show found) found of
Just (VarTy _) -> ok
Just (StructTy (VarTy _) structTyVars) ->
@ -239,7 +239,7 @@ checkConflictInternal mappings constraint name otherTy =
VarTy _ -> Right mappings
_ -> Left (UnificationFailure constraint mappings)
Just foundNonVar -> case otherTy of
(VarTy v) -> case recursiveLookup mappings v of
(VarTy v) -> case recursiveNameLookup mappings v of
Just (VarTy _) -> Right mappings
Just otherNonVar ->
if foundNonVar == otherNonVar
@ -263,7 +263,7 @@ resolveFully mappings varName = Right (Map.insert varName (fullResolve (VarTy va
where
fullResolve :: Ty -> Ty
fullResolve x@(VarTy var) =
case recursiveLookup mappings var of
case recursiveNameLookup mappings var of
Just (StructTy name varTys) -> StructTy name (map (fullLookup Set.empty) varTys)
Just (FuncTy argTys retTy ltTy) -> FuncTy (map (fullLookup Set.empty) argTys) (fullLookup Set.empty retTy) (fullLookup Set.empty ltTy)
Just found -> found
@ -271,7 +271,7 @@ resolveFully mappings varName = Right (Map.insert varName (fullResolve (VarTy va
fullResolve x = x
fullLookup :: Set.Set Ty -> Ty -> Ty
fullLookup visited vv@(VarTy v) =
case recursiveLookup mappings v of
case recursiveNameLookup mappings v of
Just found ->
if found == vv || Set.member found visited
then found

2
src/Context.hs
View File

@ -4,7 +4,7 @@ module Context
)
where
import Lookup
import Env
import Obj
import SymPath

5
src/Deftype.hs
View File

@ -10,14 +10,15 @@ where
import Concretize
import qualified Data.Map as Map
import Data.Maybe
import Infer
import Env
import Info
import Lookup
import Managed
import Obj
import StructUtils
import Template
import ToTemplate
import TypeError
import TypePredicates
import Types
import TypesToC
import Util

3
src/Emit.hs
View File

@ -16,13 +16,14 @@ import Data.List (intercalate, sortOn)
import qualified Data.Map as Map
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.Set as Set
import Env
import Info
import Lookup
import qualified Meta
import Obj
import Project
import Scoring
import Template
import TypePredicates
import Types
import TypesToC
import Util

93
src/Env.hs Normal file
View File

@ -0,0 +1,93 @@
module Env where
import Data.List (foldl')
import qualified Data.Map as Map
import Obj
import Types
-- | Add an XObj to a specific environment. TODO: rename to envInsert
extendEnv :: Env -> String -> XObj -> Env
extendEnv env name xobj = envAddBinding env name (Binder emptyMeta xobj)
-- | Add a Binder to an environment at a specific path location.
envInsertAt :: Env -> SymPath -> Binder -> Env
envInsertAt env (SymPath [] name) binder =
envAddBinding env name binder
envInsertAt env (SymPath (p : ps) name) xobj =
case Map.lookup p (envBindings env) of
Just (Binder meta (XObj (Mod innerEnv) i t)) ->
let newInnerEnv = Binder meta (XObj (Mod (envInsertAt innerEnv (SymPath ps name) xobj)) i t)
in env {envBindings = Map.insert p newInnerEnv (envBindings env)}
Just _ -> error ("Can't insert into non-module: " ++ p)
Nothing -> error ("Can't insert into non-existing module: " ++ p)
envReplaceEnvAt :: Env -> [String] -> Env -> Env
envReplaceEnvAt _ [] replacement = replacement
envReplaceEnvAt env (p : ps) replacement =
case Map.lookup p (envBindings env) of
Just (Binder _ (XObj (Mod innerEnv) i t)) ->
let newInnerEnv = Binder emptyMeta (XObj (Mod (envReplaceEnvAt innerEnv ps replacement)) i t)
in env {envBindings = Map.insert p newInnerEnv (envBindings env)}
Just _ -> error ("Can't replace non-module: " ++ p)
Nothing -> error ("Can't replace non-existing module: " ++ p)
-- | Add a Binder to a specific environment.
envAddBinding :: Env -> String -> Binder -> Env
envAddBinding env name binder = env {envBindings = Map.insert name binder (envBindings env)}
{-# ANN addListOfBindings "HLint: ignore Eta reduce" #-}
-- | Add a list of bindings to an environment
addListOfBindings :: Env -> [(String, Binder)] -> Env
addListOfBindings env bindingsToAdd = foldl' (\e (n, b) -> envAddBinding e n b) env bindingsToAdd
-- | Get an inner environment.
getEnv :: Env -> [String] -> Env
getEnv env [] = env
getEnv env (p : ps) = case Map.lookup p (envBindings env) of
Just (Binder _ (XObj (Mod innerEnv) _ _)) -> getEnv innerEnv ps
Just _ -> error "Can't get non-env."
Nothing -> error "Can't get env."
contextEnv :: Context -> Env
contextEnv Context {contextInternalEnv = Just e} = e
contextEnv Context {contextGlobalEnv = e, contextPath = p} = getEnv e p
-- | Checks if an environment is "external", meaning it's either the global scope or a module scope.
envIsExternal :: Env -> Bool
envIsExternal env =
case envMode env of
ExternalEnv -> True
InternalEnv -> False
RecursionEnv -> True
envReplaceBinding :: SymPath -> Binder -> Env -> Env
envReplaceBinding s@(SymPath [] name) binder env =
case Map.lookup name (envBindings env) of
Just _ ->
envAddBinding env name binder
Nothing ->
case envParent env of
Just parent -> env {envParent = Just (envReplaceBinding s binder parent)}
Nothing -> env
envReplaceBinding (SymPath _ _) _ _ = error "TODO: cannot replace qualified bindings"
envBindingNames :: Env -> [String]
envBindingNames = concatMap select . envBindings
where
select :: Binder -> [String]
select (Binder _ (XObj (Mod m) _ _)) = envBindingNames m
select (Binder _ obj) = [getName obj]
-- | Recursively look through all environments for (def ...) forms.
findAllGlobalVariables :: Env -> [Binder]
findAllGlobalVariables env =
concatMap finder (envBindings env)
where
finder :: Binder -> [Binder]
finder def@(Binder _ (XObj (Lst (XObj Def _ _ : _)) _ _)) =
[def]
finder (Binder _ (XObj (Mod innerEnv) _ _)) =
findAllGlobalVariables innerEnv
finder _ =
[]

37
src/Eval.hs
View File

@ -13,6 +13,7 @@ import Data.List.Split (splitOn, splitWhen)
import qualified Data.Map as Map
import Data.Maybe (fromJust, fromMaybe, isJust)
import Emit
import Env
import Expand
import Infer
import Info
@ -76,21 +77,21 @@ eval ctx xobj@(XObj o info ty) preference =
)
where
tryDynamicLookup =
( lookupInEnv (SymPath ("Dynamic" : p) n) (contextGlobalEnv ctx)
>>= \(_, Binder _ found) -> pure (ctx, Right (resolveDef found))
( lookupBinder (SymPath ("Dynamic" : p) n) (contextGlobalEnv ctx)
>>= \(Binder _ found) -> pure (ctx, Right (resolveDef found))
)
tryInternalLookup path =
( contextInternalEnv ctx
>>= lookupInEnv path
>>= \(_, Binder _ found) -> pure (ctx, Right (resolveDef found))
>>= lookupBinder path
>>= \(Binder _ found) -> pure (ctx, Right (resolveDef found))
)
<|> tryLookup path -- fallback
tryLookup path =
( lookupInEnv path (contextGlobalEnv ctx)
>>= \(_, Binder meta found) -> checkPrivate meta found
( lookupBinder path (contextGlobalEnv ctx)
>>= \(Binder meta found) -> checkPrivate meta found
)
<|> ( lookupInEnv path (getTypeEnv (contextTypeEnv ctx))
>>= \(_, Binder _ found) -> pure (ctx, Right (resolveDef found))
<|> ( lookupBinder path (getTypeEnv (contextTypeEnv ctx))
>>= \(Binder _ found) -> pure (ctx, Right (resolveDef found))
)
checkPrivate meta found =
pure $
@ -678,14 +679,14 @@ specialCommandWhile ctx cond body = do
)
Left e -> pure (newCtx, Left e)
getSigFromDefnOrDef :: Context -> Env -> FilePathPrintLength -> XObj -> (Either EvalError (Maybe (Ty, XObj)))
getSigFromDefnOrDef ctx globalEnv fppl xobj@(XObj _ i ty) =
getSigFromDefnOrDef :: Context -> Env -> FilePathPrintLength -> XObj -> Either EvalError (Maybe (Ty, XObj))
getSigFromDefnOrDef ctx globalEnv fppl xobj =
let pathStrings = contextPath ctx
path = (getPath xobj)
path = getPath xobj
fullPath = case path of
(SymPath [] _) -> consPath pathStrings path
(SymPath _ _) -> path
metaData = existingMeta globalEnv (XObj (Sym fullPath Symbol) i ty)
metaData = lookupMeta fullPath globalEnv
in case Meta.get "sig" metaData of
Just foundSignature ->
case xobjToTy foundSignature of
@ -735,14 +736,14 @@ primitiveDefmodule xobj ctx@(Context env i typeEnv pathStrings proj lastInput ex
(ctxAfterModuleDef, res) <- liftIO $ foldM step (ctx', dynamicNil) innerExpressions
pure (popModulePath ctxAfterModuleDef {contextInternalEnv = i}, res)
(newCtx, result) <-
case lookupInEnv (SymPath pathStrings moduleName) env of
Just (_, Binder _ (XObj (Mod innerEnv) _ _)) -> do
case lookupBinder (SymPath pathStrings moduleName) env of
Just (Binder _ (XObj (Mod innerEnv) _ _)) -> do
let ctx' = Context env (Just innerEnv {envParent = i}) typeEnv (pathStrings ++ [moduleName]) proj lastInput execMode history -- TODO: use { = } syntax instead
(ctxAfterModuleAdditions, res) <- liftIO $ foldM step (ctx', dynamicNil) innerExpressions
pure (popModulePath ctxAfterModuleAdditions {contextInternalEnv = i}, res) -- TODO: propagate errors...
Just (_, Binder meta (XObj (Lst [XObj MetaStub _ _, _]) _ _)) ->
Just (Binder meta (XObj (Lst [XObj MetaStub _ _, _]) _ _)) ->
defineIt meta
Just (_, Binder _ _) ->
Just (Binder _ _) ->
pure (evalError ctx ("Can't redefine '" ++ moduleName ++ "' as module") (xobjInfo xobj))
Nothing ->
defineIt emptyMeta
@ -1075,8 +1076,8 @@ specialCommandSet ctx [(XObj (Sym path@(SymPath mod n) _) _ _), val] = do
Just env -> setInternal newCtx env evald
where
setGlobal ctx' env value =
case lookupInEnv path env of
Just (_, binder) -> do
case lookupBinder path env of
Just binder -> do
(ctx'', typedVal) <- typeCheckValueAgainstBinder ctx' value binder
pure $ either (failure ctx'') (success ctx'') typedVal
where

17
src/Expand.hs
View File

@ -2,6 +2,7 @@ module Expand (expandAll, replaceSourceInfoOnXObj) where
import Control.Monad.State (State, evalState, get, put)
import Data.Foldable (foldlM)
import Env
import Info
import Lookup
import Obj
@ -225,14 +226,14 @@ expand eval ctx xobj =
expandArray _ = error "Can't expand non-array in expandArray."
expandSymbol :: XObj -> IO (Context, Either EvalError XObj)
expandSymbol sym@(XObj (Sym path _) _ _) =
case lookupInEnv path (contextEnv ctx) of
Just (_, Binder meta (XObj (Lst (XObj (External _) _ _ : _)) _ _)) -> isPrivate meta xobj
Just (_, Binder meta (XObj (Lst (XObj (Instantiate _) _ _ : _)) _ _)) -> isPrivate meta xobj
Just (_, Binder meta (XObj (Lst (XObj (Deftemplate _) _ _ : _)) _ _)) -> isPrivate meta xobj
Just (_, Binder meta (XObj (Lst (XObj (Defn _) _ _ : _)) _ _)) -> isPrivate meta xobj
Just (_, Binder meta (XObj (Lst (XObj Def _ _ : _)) _ _)) -> isPrivate meta xobj
Just (_, Binder meta (XObj (Lst (XObj (Defalias _) _ _ : _)) _ _)) -> isPrivate meta xobj
Just (_, Binder meta found) -> isPrivate meta found -- use the found value
case lookupBinder path (contextEnv ctx) of
Just (Binder meta (XObj (Lst (XObj (External _) _ _ : _)) _ _)) -> isPrivate meta xobj
Just (Binder meta (XObj (Lst (XObj (Instantiate _) _ _ : _)) _ _)) -> isPrivate meta xobj
Just (Binder meta (XObj (Lst (XObj (Deftemplate _) _ _ : _)) _ _)) -> isPrivate meta xobj
Just (Binder meta (XObj (Lst (XObj (Defn _) _ _ : _)) _ _)) -> isPrivate meta xobj
Just (Binder meta (XObj (Lst (XObj Def _ _ : _)) _ _)) -> isPrivate meta xobj
Just (Binder meta (XObj (Lst (XObj (Defalias _) _ _ : _)) _ _)) -> isPrivate meta xobj
Just (Binder meta found) -> isPrivate meta found -- use the found value
Nothing -> pure (ctx, Right xobj) -- symbols that are not found are left as-is
where
isPrivate m x =

7
src/InitialTypes.hs
View File

@ -2,6 +2,7 @@ module InitialTypes where
import Control.Monad.State
import qualified Data.Map as Map
import Env
import Info
import Lookup
import Obj
@ -144,9 +145,9 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
visitInterfaceSym :: Env -> XObj -> State Integer (Either TypeError XObj)
visitInterfaceSym _ xobj@(XObj (InterfaceSym name) _ _) =
do
freshTy <- case lookupInEnv (SymPath [] name) (getTypeEnv typeEnv) of
Just (_, Binder _ (XObj (Lst [XObj (Interface interfaceSignature _) _ _, _]) _ _)) -> renameVarTys interfaceSignature
Just (_, Binder _ x) -> error ("A non-interface named '" ++ name ++ "' was found in the type environment: " ++ pretty x)
freshTy <- case lookupBinder (SymPath [] name) (getTypeEnv typeEnv) of
Just (Binder _ (XObj (Lst [XObj (Interface interfaceSignature _) _ _, _]) _ _)) -> renameVarTys interfaceSignature
Just (Binder _ x) -> error ("A non-interface named '" ++ name ++ "' was found in the type environment: " ++ pretty x)
Nothing -> genVarTy
pure (Right xobj {xobjTy = Just freshTy})
visitArray :: Env -> XObj -> State Integer (Either TypeError XObj)

3
src/Interfaces.hs
View File

@ -12,6 +12,7 @@ where
import ColorText
import Constraints
import Control.Monad (foldM)
import Env
import Lookup
import Obj
import Types
@ -95,5 +96,5 @@ retroactivelyRegisterInInterface ctx interface =
either (\e -> error e) id resultCtx
where
env = contextGlobalEnv ctx
impls = recursiveLookupAll (getPath (binderXObj interface)) lookupImplementations env
impls = lookupMany Everywhere lookupImplementations (getPath (binderXObj interface)) env
resultCtx = foldM (\context binder -> registerInInterface context binder interface) ctx impls

256
src/Lookup.hs
View File

@ -1,15 +1,13 @@
module Lookup where
import Data.List (foldl')
import qualified Data.Map as Map
import Data.Maybe (mapMaybe)
import Data.Maybe (catMaybes, mapMaybe)
import qualified Meta
import Obj
import Text.EditDistance (defaultEditCosts, levenshteinDistance)
import Types
-- | The type of generic lookup functions.
type LookupFunc a = a -> Env -> [Binder]
type LookupFunc a b = a -> Env -> [b]
-- | Find the Binder at a specified path.
lookupInEnv :: SymPath -> Env -> Maybe (Env, Binder)
@ -30,90 +28,54 @@ lookupInEnv path@(SymPath (p : ps) name) env =
Just parent -> lookupInEnv path parent
Nothing -> Nothing
-- |
findAllGlobalVariables :: Env -> [Binder]
findAllGlobalVariables env =
concatMap finder (envBindings env)
where
finder :: Binder -> [Binder]
finder def@(Binder _ (XObj (Lst (XObj Def _ _ : _)) _ _)) =
[def]
finder (Binder _ (XObj (Mod innerEnv) _ _)) =
findAllGlobalVariables innerEnv
finder _ =
[]
-- | Like 'lookupInEnv' but only returns the Binder (no Env)
lookupBinder :: SymPath -> Env -> Maybe Binder
lookupBinder path env = snd <$> lookupInEnv path env
-- | Find all the possible (imported) symbols that could be referred to
multiLookup :: String -> Env -> [(Env, Binder)]
multiLookup = multiLookupInternal False
-- | Like 'lookupBinder' but return the Meta for the binder, or a default empty meta.
lookupMeta :: SymPath -> Env -> MetaData
lookupMeta path globalEnv =
maybe emptyMeta Meta.fromBinder (lookupBinder path globalEnv)
multiLookupALL :: String -> Env -> [(Env, Binder)]
multiLookupALL = multiLookupInternal True
-- TODO: Many of the local functions defined in the body of multiLookupInternal have been extracted.
-- Remove the duplication and define this in terms of the more generic/extracted functions.
{-# ANN multiLookupInternal "HLint: ignore Eta reduce" #-}
-- | The advanced version of multiLookup that allows for looking into modules that are NOT imported.
-- | Perhaps this function will become unnecessary when all functions can be found through Interfaces? (even 'delete', etc.)
multiLookupInternal :: Bool -> String -> Env -> [(Env, Binder)]
multiLookupInternal allowLookupInAllModules name rootEnv = recursiveLookup rootEnv
where
lookupInLocalEnv :: String -> Env -> Maybe (Env, Binder)
lookupInLocalEnv n localEnv = case Map.lookup n (envBindings localEnv) of -- No recurse!
Just b -> Just (localEnv, b)
Nothing -> Nothing
importsAll :: Env -> [Env]
importsAll env =
let envs = mapMaybe (binderToEnv . snd) (Map.toList (envBindings env))
in envs ++ concatMap importsAll envs
-- Only lookup in imported modules (nonrecursively!)
importsNormal :: Env -> [Env]
importsNormal env =
mapMaybe (\path -> fmap getEnvFromBinder (lookupInEnv path env)) (envUseModules env)
importsLookup :: Env -> [(Env, Binder)]
importsLookup env =
let envs = (if allowLookupInAllModules then importsAll else importsNormal) env
in mapMaybe (lookupInLocalEnv name) envs
recursiveLookup :: Env -> [(Env, Binder)]
recursiveLookup env =
let spine = case Map.lookup name (envBindings env) of
Just found -> [(env, found)]
Nothing -> []
leaves = importsLookup env
above = case envParent env of
Just parent -> recursiveLookup parent
Nothing -> []
in --(trace $ "multiLookupInternal '" ++ name ++ "' " ++ show (envModuleName env) ++ ", spine: " ++ show (fmap snd spine) ++ ", leaves: " ++ show (fmap snd leaves) ++ ", above: " ++ show (fmap snd above))
spine ++ leaves ++ above
binderToEnv :: Binder -> Maybe Env
binderToEnv (Binder _ (XObj (Mod e) _ _)) = Just e
binderToEnv _ = Nothing
-- | Get the Env stored in a binder, if any.
envFromBinder :: Binder -> Maybe Env
envFromBinder (Binder _ (XObj (Mod e) _ _)) = Just e
envFromBinder _ = Nothing
-- | Given an environment, returns the list of all environments of binders from
-- imported modules `(load "module-file.carp")`
-- imported modules.
importedEnvs :: Env -> [Env]
importedEnvs env =
let envs = mapMaybe (binderToEnv . snd) (Map.toList (envBindings env))
in envs ++ concatMap importedEnvs envs
catMaybes $ mapMaybe (\path -> fmap envFromBinder (lookupBinder path env)) (envUseModules env)
-- | Given an environment, returns the list of all environments of its binders.
allEnvs :: Env -> [Env]
allEnvs env =
let envs = mapMaybe (envFromBinder . snd) (Map.toList (envBindings env))
in envs ++ concatMap allEnvs envs
data LookWhere = Everywhere | OnlyImports
getEnvs :: LookWhere -> Env -> [Env]
getEnvs Everywhere = allEnvs
getEnvs OnlyImports = importedEnvs
-- | Given an environment, use a lookup function to recursively find all binders
-- in the environment that satisfy the lookup.
recursiveLookupAll :: a -> LookupFunc a -> Env -> [Binder]
recursiveLookupAll input lookf env =
lookupMany :: LookWhere -> LookupFunc a b -> a -> Env -> [b]
lookupMany lookWhere lookf input env =
let spine = lookf input env
leaves = concatMap (lookf input) (importedEnvs env)
leaves = concatMap (lookf input) (getEnvs lookWhere env)
above = case envParent env of
Just parent -> recursiveLookupAll input lookf parent
Just parent -> lookupMany lookWhere lookf input parent
Nothing -> []
in spine ++ leaves ++ above
-- | Lookup binders by name.
lookupByName :: String -> Env -> [Binder]
-- | Lookup binders by name in a single Env (no recursion),
lookupByName :: String -> Env -> [(Env, Binder)]
lookupByName name env =
let filtered = Map.filterWithKey (\k _ -> k == name) (envBindings env)
in map snd $ Map.toList filtered
in map ((,) env . snd) (Map.toList filtered)
-- | Lookup binders that have specified metadata.
lookupByMeta :: String -> Env -> [Binder]
@ -131,12 +93,16 @@ lookupImplementations interface env =
where
isImpl (Binder meta _) =
case Meta.get "implements" meta of
Just (XObj (Lst interfaces) _ _) -> interface `elem` (map getPath interfaces)
Just (XObj (Lst interfaces) _ _) -> interface `elem` map getPath interfaces
_ -> False
getEnvFromBinder :: (a, Binder) -> Env
getEnvFromBinder (_, Binder _ (XObj (Mod foundEnv) _ _)) = foundEnv
getEnvFromBinder (_, Binder _ err) = error ("Can't handle imports of non modules yet: " ++ show err)
-- | Find the possible (imported) symbols that could be referred to by a name.
multiLookupImports :: String -> Env -> [(Env, Binder)]
multiLookupImports = lookupMany OnlyImports lookupByName
-- | Find all symbols with a certain name, in *all* environments.
multiLookupEverywhere :: String -> Env -> [(Env, Binder)]
multiLookupEverywhere = lookupMany Everywhere lookupByName
-- | Enables look up "semi qualified" (and fully qualified) symbols.
-- | i.e. if there are nested environments with a function A.B.f
@ -144,7 +110,7 @@ getEnvFromBinder (_, Binder _ err) = error ("Can't handle imports of non modules
multiLookupQualified :: SymPath -> Env -> [(Env, Binder)]
multiLookupQualified (SymPath [] name) rootEnv =
-- This case is just like normal multiLookup, we have a name but no qualifyers:
multiLookup name rootEnv
multiLookupImports name rootEnv
multiLookupQualified path@(SymPath (p : _) _) rootEnv =
case lookupInEnv (SymPath [] p) rootEnv of
Just (_, Binder _ (XObj (Mod _) _ _)) ->
@ -162,140 +128,6 @@ multiLookupQualified path@(SymPath (p : _) _) rootEnv =
Nothing -> []
fromUsedModules =
let usedModules = envUseModules rootEnv
envs = mapMaybe (\path' -> fmap getEnvFromBinder (lookupInEnv path' rootEnv)) usedModules
envs = catMaybes $ mapMaybe (\path' -> fmap envFromBinder (lookupBinder path' rootEnv)) usedModules
in concatMap (multiLookupQualified path) envs
in fromParent ++ fromUsedModules
-- | Add an XObj to a specific environment. TODO: rename to envInsert
extendEnv :: Env -> String -> XObj -> Env
extendEnv env name xobj = envAddBinding env name (Binder emptyMeta xobj)
-- | Add a Binder to an environment at a specific path location.
envInsertAt :: Env -> SymPath -> Binder -> Env
envInsertAt env (SymPath [] name) binder =
envAddBinding env name binder
envInsertAt env (SymPath (p : ps) name) xobj =
case Map.lookup p (envBindings env) of
Just (Binder meta (XObj (Mod innerEnv) i t)) ->
let newInnerEnv = Binder meta (XObj (Mod (envInsertAt innerEnv (SymPath ps name) xobj)) i t)
in env {envBindings = Map.insert p newInnerEnv (envBindings env)}
Just _ -> error ("Can't insert into non-module: " ++ p)
Nothing -> error ("Can't insert into non-existing module: " ++ p)
envReplaceEnvAt :: Env -> [String] -> Env -> Env
envReplaceEnvAt _ [] replacement = replacement
envReplaceEnvAt env (p : ps) replacement =
case Map.lookup p (envBindings env) of
Just (Binder _ (XObj (Mod innerEnv) i t)) ->
let newInnerEnv = Binder emptyMeta (XObj (Mod (envReplaceEnvAt innerEnv ps replacement)) i t)
in env {envBindings = Map.insert p newInnerEnv (envBindings env)}
Just _ -> error ("Can't replace non-module: " ++ p)
Nothing -> error ("Can't replace non-existing module: " ++ p)
-- | Add a Binder to a specific environment.
envAddBinding :: Env -> String -> Binder -> Env
envAddBinding env name binder = env {envBindings = Map.insert name binder (envBindings env)}
{-# ANN addListOfBindings "HLint: ignore Eta reduce" #-}
-- | Add a list of bindings to an environment
addListOfBindings :: Env -> [(String, Binder)] -> Env
addListOfBindings env bindingsToAdd = foldl' (\e (n, b) -> envAddBinding e n b) env bindingsToAdd
-- | Get an inner environment.
getEnv :: Env -> [String] -> Env
getEnv env [] = env
getEnv env (p : ps) = case Map.lookup p (envBindings env) of
Just (Binder _ (XObj (Mod innerEnv) _ _)) -> getEnv innerEnv ps
Just _ -> error "Can't get non-env."
Nothing -> error "Can't get env."
contextEnv :: Context -> Env
contextEnv Context {contextInternalEnv = Just e} = e
contextEnv Context {contextGlobalEnv = e, contextPath = p} = getEnv e p
-- | Checks if an environment is "external", meaning it's either the global scope or a module scope.
envIsExternal :: Env -> Bool
envIsExternal env =
case envMode env of
ExternalEnv -> True
InternalEnv -> False
RecursionEnv -> True
-- | Find out if a type is "external", meaning it is not defined by the user
-- in this program but instead imported from another C library or similar.
isExternalType :: TypeEnv -> Ty -> Bool
isExternalType typeEnv (PointerTy p) =
isExternalType typeEnv p
isExternalType typeEnv (StructTy (ConcreteNameTy name) _) =
case lookupInEnv (SymPath [] name) (getTypeEnv typeEnv) of
Just (_, Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) -> True
Just _ -> False
Nothing -> False
isExternalType _ _ =
False
-- | Is this type managed - does it need to be freed?
isManaged :: TypeEnv -> Ty -> Bool
isManaged typeEnv (StructTy (ConcreteNameTy name) _) =
(name == "Array") || (name == "StaticArray") || (name == "Dictionary")
|| ( case lookupInEnv (SymPath [] name) (getTypeEnv typeEnv) of
Just (_, Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) -> False
Just (_, Binder _ (XObj (Lst (XObj (Deftype _) _ _ : _)) _ _)) -> True
Just (_, Binder _ (XObj (Lst (XObj (DefSumtype _) _ _ : _)) _ _)) -> True
Just (_, Binder _ (XObj wrong _ _)) -> error ("Invalid XObj in type env: " ++ show wrong)
Nothing -> error ("Can't find " ++ name ++ " in type env.") -- TODO: Please don't crash here!
)
isManaged _ StringTy = True
isManaged _ PatternTy = True
isManaged _ FuncTy {} = True
isManaged _ _ = False
-- | Is this type a function type?
isFunctionType :: Ty -> Bool
isFunctionType FuncTy {} = True
isFunctionType _ = False
-- | Is this type a struct type?
isStructType :: Ty -> Bool
isStructType (StructTy _ _) = True
isStructType _ = False
keysInEnvEditDistance :: SymPath -> Env -> Int -> [String]
keysInEnvEditDistance (SymPath [] name) env distance =
let candidates = Map.filterWithKey (\k _ -> levenshteinDistance defaultEditCosts k name < distance) (envBindings env)
in Map.keys candidates
keysInEnvEditDistance path@(SymPath (p : ps) name) env distance =
case Map.lookup p (envBindings env) of
Just (Binder _ xobj) ->
case xobj of
(XObj (Mod modEnv) _ _) -> keysInEnvEditDistance (SymPath ps name) modEnv distance
_ -> []
Nothing ->
case envParent env of
Just parent -> keysInEnvEditDistance path parent distance
Nothing -> []
envReplaceBinding :: SymPath -> Binder -> Env -> Env
envReplaceBinding s@(SymPath [] name) binder env =
case Map.lookup name (envBindings env) of
Just _ ->
envAddBinding env name binder
Nothing ->
case envParent env of
Just parent -> env {envParent = Just (envReplaceBinding s binder parent)}
Nothing -> env
envReplaceBinding (SymPath _ _) _ _ = error "TODO: cannot replace qualified bindings"
bindingNames :: Env -> [String]
bindingNames = concatMap select . envBindings
where
select :: Binder -> [String]
select (Binder _ (XObj (Mod i) _ _)) = bindingNames i
select (Binder _ obj) = [getName obj]
existingMeta :: Env -> XObj -> MetaData
existingMeta globalEnv xobj =
case lookupInEnv (getPath xobj) globalEnv of
Just (_, Binder meta _) -> meta
Nothing -> emptyMeta

34
src/Managed.hs Normal file
View File

@ -0,0 +1,34 @@
module Managed where
import Lookup
import Obj
import Types
-- | Find out if a type is "external", meaning it is not defined by the user
-- in this program but instead imported from another C library or similar.
-- NOTE: Quite possibly this function should be removed and we should rely on 'isManaged' instead?
isExternalType :: TypeEnv -> Ty -> Bool
isExternalType typeEnv (PointerTy p) =
isExternalType typeEnv p
isExternalType typeEnv (StructTy (ConcreteNameTy name) _) =
case lookupBinder (SymPath [] name) (getTypeEnv typeEnv) of
Just (Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) -> True
_ -> False
isExternalType _ _ =
False
-- | Is this type managed - does it need to be freed?
isManaged :: TypeEnv -> Ty -> Bool
isManaged typeEnv (StructTy (ConcreteNameTy name) _) =
(name == "Array") || (name == "StaticArray") || (name == "Dictionary")
|| ( case lookupBinder (SymPath [] name) (getTypeEnv typeEnv) of
Just (Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) -> False
Just (Binder _ (XObj (Lst (XObj (Deftype _) _ _ : _)) _ _)) -> True
Just (Binder _ (XObj (Lst (XObj (DefSumtype _) _ _ : _)) _ _)) -> True
Just (Binder _ (XObj wrong _ _)) -> error ("Invalid XObj in type env: " ++ show wrong)
Nothing -> error ("Can't find " ++ name ++ " in type env.") -- TODO: Please don't crash here!
)
isManaged _ StringTy = True
isManaged _ PatternTy = True
isManaged _ FuncTy {} = True
isManaged _ _ = False

2
src/Polymorphism.hs
View File

@ -13,7 +13,7 @@ import Types
-- | TODO: Environments are passed in different order here!!!
nameOfPolymorphicFunction :: TypeEnv -> Env -> Ty -> String -> Maybe SymPath
nameOfPolymorphicFunction _ env functionType functionName =
let foundBinders = multiLookupALL functionName env
let foundBinders = multiLookupEverywhere functionName env
in case filter ((\(Just t') -> areUnifiable functionType t') . xobjTy . binderXObj . snd) foundBinders of
[] -> Nothing
[(_, Binder _ (XObj (Lst (XObj (External (Just name)) _ _ : _)) _ _))] ->

93
src/Primitives.hs
View File

@ -8,9 +8,10 @@ import Control.Monad (foldM, unless, when)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Either (rights)
import Data.List (union)
import Data.Maybe (catMaybes, fromJust, fromMaybe)
import Data.Maybe (fromJust, fromMaybe, mapMaybe)
import Deftype
import Emit
import Env
import Infer
import Info
import Interfaces
@ -24,6 +25,7 @@ import Sumtypes
import Template
import ToTemplate
import TypeError
import TypePredicates
import Types
import Util
import Web.Browser (openBrowser)
@ -154,15 +156,15 @@ primitiveColumn x@(XObj _ i t) ctx args =
primitiveImplements :: Primitive
primitiveImplements _ ctx [x@(XObj (Sym interface@(SymPath _ _) _) _ _), (XObj (Sym (SymPath prefixes name) _) info _)] =
do
(maybeInterface, maybeImpl) <- pure ((lookupInEnv interface tyEnv), (lookupInEnv (SymPath modules name) global))
(maybeInterface, maybeImpl) <- pure ((lookupBinder interface tyEnv), (lookupBinder (SymPath modules name) global))
case (maybeInterface, maybeImpl) of
(_, Nothing) ->
if null modules
then pure (evalError ctx "Can't set the `implements` meta on a global definition before it is declared." info)
else updateMeta (Meta.stub (SymPath modules name)) ctx
(Nothing, Just (_, implBinder)) ->
(Nothing, Just implBinder) ->
(warn >> updateMeta implBinder ctx)
(Just (_, interfaceBinder), Just (_, implBinder)) ->
(Just interfaceBinder, Just implBinder) ->
(addToInterface interfaceBinder implBinder)
where
global = contextGlobalEnv ctx
@ -175,7 +177,6 @@ primitiveImplements _ ctx [x@(XObj (Sym interface@(SymPath _ _) _) _ _), (XObj (
++ " is not defined."
++ " Did you define it using `definterface`?"
)
addToInterface :: Binder -> Binder -> IO (Context, Either EvalError XObj)
addToInterface inter impl =
either
@ -202,7 +203,6 @@ primitiveImplements _ ctx [x@(XObj (Sym interface@(SymPath _ _) _) _ _), (XObj (
<|> Just (updateImplementations binder (XObj (Lst []) (Just dummyInfo) (Just DynamicTy)))
)
>>= \newBinder -> pure (context {contextGlobalEnv = envInsertAt global (getBinderPath binder) newBinder})
updateImplementations :: Binder -> XObj -> Binder
updateImplementations implBinder (XObj (Lst impls) inf ty) =
if x `elem` impls
@ -228,17 +228,16 @@ define hidden ctx@(Context globalEnv _ typeEnv _ proj _ _ _) annXObj =
else defineInGlobalEnv newBinder
where
freshBinder = (Binder emptyMeta annXObj)
defineInTypeEnv :: Binder -> IO Context
defineInTypeEnv binder = pure (insertInTypeEnv ctx (getPath annXObj) binder)
defineInGlobalEnv :: Binder -> IO Context
defineInGlobalEnv fallbackBinder =
do
maybeExistingBinder <- pure (lookupInEnv (getPath annXObj) globalEnv)
maybeExistingBinder <- pure (lookupBinder (getPath annXObj) globalEnv)
when (projectEchoC proj) (putStrLn (toC All (Binder emptyMeta annXObj)))
case maybeExistingBinder of
Nothing -> pure (insertInGlobalEnv ctx (getPath annXObj) fallbackBinder)
Just (_, binder) -> redefineExistingBinder binder
Just binder -> redefineExistingBinder binder
redefineExistingBinder :: Binder -> IO Context
redefineExistingBinder old@(Binder meta _) =
do
@ -271,7 +270,7 @@ define hidden ctx@(Context globalEnv _ typeEnv _ proj _ _ _) annXObj =
>>= \(XObj (Lst interfaces) _ _) -> pure (map getPath interfaces)
)
>>= \maybeinterfaces ->
pure (map snd (catMaybes (map ((flip lookupInEnv) (getTypeEnv typeEnv)) (fromMaybe [] maybeinterfaces))))
pure (mapMaybe ((flip lookupBinder) (getTypeEnv typeEnv)) (fromMaybe [] maybeinterfaces))
>>= \interfaceBinders ->
pure (foldM (\ctx' interface -> registerInInterface ctx' binder interface) ctx interfaceBinders)
>>= \result -> case result of
@ -339,8 +338,8 @@ primitiveRegisterTypeWithFields ctx x t override members =
globalEnv = contextGlobalEnv ctx
typeEnv = contextTypeEnv ctx
path = SymPath pathStrings t
preExistingModule = case lookupInEnv (SymPath pathStrings t) globalEnv of
Just (_, Binder _ (XObj (Mod found) _ _)) -> Just found
preExistingModule = case lookupBinder (SymPath pathStrings t) globalEnv of
Just (Binder _ (XObj (Mod found) _ _)) -> Just found
_ -> Nothing
notFound :: Context -> XObj -> SymPath -> IO (Context, Either EvalError XObj)
@ -354,30 +353,30 @@ primitiveInfo _ ctx [target@(XObj (Sym path@(SymPath _ name) _) _ _)] = do
case path of
SymPath [] _ ->
-- First look in the type env, then in the global env:
case lookupInEnv path (getTypeEnv typeEnv) of
Nothing -> printer env True True (lookupInEnv path env)
case lookupBinder path (getTypeEnv typeEnv) of
Nothing -> printer env True True (lookupBinder path env)
found -> do
_ <- printer env True True found -- this will print the interface itself
printer env True False (lookupInEnv path env) -- this will print the locations of the implementers of the interface
printer env True False (lookupBinder path env) -- this will print the locations of the implementers of the interface
_ ->
case lookupInEnv path env of
case lookupBinder path env of
Nothing -> notFound ctx target path
found -> printer env False True found
where
printer env allowLookupInALL errNotFound binderPair = do
printer env allowLookupEverywhere errNotFound binderPair = do
let proj = contextProj ctx
case binderPair of
Just (_, binder@(Binder metaData x@(XObj _ (Just i) _))) ->
Just (binder@(Binder metaData x@(XObj _ (Just i) _))) ->
do
liftIO $ putStrLn (show binder ++ "\nDefined at " ++ prettyInfo i)
printDoc metaData proj x
Just (_, binder@(Binder metaData x)) ->
Just (binder@(Binder metaData x)) ->
do
liftIO $ print binder
printDoc metaData proj x
Nothing
| allowLookupInALL ->
case multiLookupALL name env of
| allowLookupEverywhere ->
case multiLookupEverywhere name env of
[] ->
if errNotFound
then notFound ctx target path
@ -420,7 +419,7 @@ dynamicOrMacroWith ctx producer ty name body = do
globalEnv = contextGlobalEnv ctx
path = SymPath pathStrings name
elt = XObj (Lst (producer path)) (xobjInfo body) (Just ty)
meta = existingMeta globalEnv elt
meta = lookupMeta (getPath elt) globalEnv
pure (ctx {contextGlobalEnv = envInsertAt globalEnv path (Binder meta elt)}, dynamicNil)
primitiveMembers :: Primitive
@ -428,10 +427,9 @@ primitiveMembers _ ctx [target] = do
let typeEnv = contextTypeEnv ctx
case bottomedTarget of
XObj (Sym path@(SymPath _ name) _) _ _ ->
case lookupInEnv path (getTypeEnv typeEnv) of
case lookupBinder path (getTypeEnv typeEnv) of
Just
( _,
Binder
( Binder
_
( XObj
( Lst
@ -446,8 +444,7 @@ primitiveMembers _ ctx [target] = do
) ->
pure (ctx, Right (XObj (Arr (map (\(a, b) -> XObj (Lst [a, b]) Nothing Nothing) (pairwise members))) Nothing Nothing))
Just
( _,
Binder
( Binder
_
( XObj
( Lst
@ -477,13 +474,13 @@ primitiveMembers _ ctx [target] = do
bottomedTarget =
case target of
XObj (Sym targetPath _) _ _ ->
case lookupInEnv targetPath env of
case lookupBinder targetPath env of
-- this is a trick: every type generates a module in the env;
-- we’re special-casing here because we need the parent of the
-- module
Just (_, Binder _ (XObj (Mod _) _ _)) -> target
Just (Binder _ (XObj (Mod _) _ _)) -> target
-- if we’re recursing into a non-sym, we’ll stop one level down
Just (_, Binder _ _) -> bottomedTarget
Just (Binder _ _) -> bottomedTarget
_ -> target
_ -> target
@ -498,15 +495,15 @@ primitiveMetaSet _ ctx [target@(XObj (Sym (SymPath prefixes name) _) _ _), XObj
types = (getTypeEnv (contextTypeEnv ctx))
lookupAndUpdate :: Maybe Context
lookupAndUpdate =
( (lookupInEnv dynamicPath global)
>>= \(_, binder) ->
( (lookupBinder dynamicPath global)
>>= \binder ->
(pure (Meta.updateBinderMeta binder key value))
>>= \b ->
(pure (envInsertAt global dynamicPath b))
>>= \env -> pure (ctx {contextGlobalEnv = env})
)
<|> ( (lookupInEnv fullPath global)
>>= \(_, binder) ->
<|> ( (lookupBinder fullPath global)
>>= \binder ->
(pure (Meta.updateBinderMeta binder key value))
>>= \b ->
(pure (envInsertAt global fullPath b))
@ -516,8 +513,8 @@ primitiveMetaSet _ ctx [target@(XObj (Sym (SymPath prefixes name) _) _ _), XObj
-- Before creating a new binder, check that it doesn't denote an existing type or interface.
<|> ( if (null modules)
then
( (lookupInEnv fullPath types)
>>= \(_, binder) ->
( (lookupBinder fullPath types)
>>= \binder ->
(pure (Meta.updateBinderMeta binder key value))
>>= \b ->
(pure (envInsertAt types fullPath b))
@ -544,7 +541,7 @@ primitiveDefinterface xobj ctx [nameXObj@(XObj (Sym path@(SymPath [] name) _) _
where
typeEnv = getTypeEnv (contextTypeEnv ctx)
invalidType = evalError ctx ("Invalid type for interface `" ++ name ++ "`: " ++ pretty ty) (xobjInfo ty)
validType t = maybe defInterface (updateInterface . snd) (lookupInEnv path typeEnv)
validType t = maybe defInterface updateInterface (lookupBinder path typeEnv)
where
defInterface =
let interface = defineInterface name t [] (xobjInfo nameXObj)
@ -596,7 +593,7 @@ registerInternal ctx name ty override =
)
(xobjInfo ty)
(Just t)
meta = existingMeta globalEnv registration
meta = lookupMeta (getPath registration) globalEnv
env' = envInsertAt globalEnv path (Binder meta registration)
in (ctx {contextGlobalEnv = env'}, dynamicNil)
@ -694,9 +691,9 @@ primitiveDeftype xobj ctx (name : rest) =
typeEnv = contextTypeEnv ctx
typeVariables = mapM xobjToTy typeVariableXObjs
(preExistingModule, preExistingMeta) =
case lookupInEnv (SymPath pathStrings typeName) env of
Just (_, Binder meta (XObj (Mod found) _ _)) -> (Just found, meta)
Just (_, Binder meta _) -> (Nothing, meta)
case lookupBinder (SymPath pathStrings typeName) env of
Just (Binder meta (XObj (Mod found) _ _)) -> (Just found, meta)
Just (Binder meta _) -> (Nothing, meta)
_ -> (Nothing, emptyMeta)
(creatorFunction, typeConstructor) =
if length rest == 1 && isArray (head rest)
@ -729,8 +726,8 @@ primitiveDeftype xobj ctx (name : rest) =
let fakeImplBinder sympath t = (Binder emptyMeta (XObj (Sym sympath Symbol) (Just dummyInfo) (Just t)))
strSig = FuncTy [RefTy structTy (VarTy "q")] StringTy StaticLifetimeTy
copySig = FuncTy [RefTy structTy (VarTy "q")] structTy StaticLifetimeTy
Just (_, strInterface) = lookupInEnv (SymPath [] "str") (getTypeEnv typeEnv)
Just (_, copyInterface) = lookupInEnv (SymPath [] "copy") (getTypeEnv typeEnv)
Just strInterface = lookupBinder (SymPath [] "str") (getTypeEnv typeEnv)
Just copyInterface = lookupBinder (SymPath [] "copy") (getTypeEnv typeEnv)
ctxWithInterfaceRegistrations =
-- Since these functions are autogenerated, we treat them as a special case and automatically implement the interfaces.
foldM
@ -774,7 +771,7 @@ primitiveMeta (XObj _ i _) ctx [XObj (Sym (SymPath prefixes name) _) _ _, XObj (
types = getTypeEnv (contextTypeEnv ctx)
fullPath = consPath (union (contextPath ctx) prefixes) (SymPath [] name)
lookup' :: Maybe Binder
lookup' = (lookupInEnv fullPath global <|> lookupInEnv fullPath types) >>= pure . snd
lookup' = (lookupBinder fullPath global <|> lookupBinder fullPath types) >>= pure
foundBinder :: Binder -> (Context, Either EvalError XObj)
foundBinder binder = (ctx, maybe dynamicNil Right (Meta.getBinderMetaValue key binder))
errNotFound :: (Context, Either EvalError XObj)
@ -806,13 +803,13 @@ primitiveDeftemplate _ ctx [XObj (Sym (SymPath [] name) _) _ _, ty, XObj (Str de
if isTypeGeneric t
then
let (Binder _ registration) = b
meta = existingMeta globalEnv registration
meta = lookupMeta (getPath registration) globalEnv
env' = envInsertAt globalEnv p (Binder meta registration)
in (ctx {contextGlobalEnv = env'}, dynamicNil)
else
let templateCreator = getTemplateCreator template
(registration, _) = instantiateTemplate p t (templateCreator typeEnv globalEnv)
meta = existingMeta globalEnv registration
meta = lookupMeta (getPath registration) globalEnv
env' = envInsertAt globalEnv p (Binder meta registration)
in (ctx {contextGlobalEnv = env'}, dynamicNil)
primitiveDeftemplate _ ctx [XObj (Sym (SymPath [] _) _) _ _, _, XObj (Str _) _ _, x] =
@ -833,10 +830,10 @@ primitiveType _ ctx [(XObj _ _ (Just Universe))] =
pure (ctx, Right (XObj (Lst []) Nothing Nothing))
primitiveType _ ctx [(XObj _ _ (Just TypeTy))] = liftIO $ pure (ctx, Right $ reify TypeTy)
primitiveType _ ctx [x@(XObj (Sym path@(SymPath [] name) _) _ _)] =
(maybe otherDefs (go . snd) (lookupInEnv path env))
(maybe otherDefs go (lookupBinder path env))
where
env = contextGlobalEnv ctx
otherDefs = case multiLookupALL name env of
otherDefs = case multiLookupEverywhere name env of
[] ->
notFound ctx x path
binders ->

5
src/Qualify.hs
View File

@ -3,6 +3,7 @@ module Qualify where
import Data.List (foldl')
import qualified Data.Map as Map
import Debug.Trace
import Env
import Info
import Lookup
import Obj
@ -133,8 +134,8 @@ setFullyQualifiedSymbols typeEnv globalEnv localEnv xobj@(XObj (Sym path _) i t)
case path of
-- Unqualified:
SymPath [] name ->
case lookupInEnv path (getTypeEnv typeEnv) of
Just (_, Binder _ (XObj (Lst (XObj (Interface _ _) _ _ : _)) _ _)) ->
case lookupBinder path (getTypeEnv typeEnv) of
Just (Binder _ (XObj (Lst (XObj (Interface _ _) _ _ : _)) _ _)) ->
-- Found an interface with the same path!
-- Have to ensure it's not a local variable with the same name as the interface
case lookupInEnv path localEnv of

4
src/Repl.hs
View File

@ -8,8 +8,8 @@ import ColorText
import Control.Monad.State.Strict
import Data.List (isPrefixOf)
import qualified Data.Map as Map
import Env
import Eval
import Lookup
import Obj
import Parsing (balance)
import Path
@ -27,7 +27,7 @@ import System.Exit (exitSuccess)
completeKeywordsAnd :: Context -> String -> [Completion]
completeKeywordsAnd context word =
findKeywords word (bindingNames (contextGlobalEnv context) ++ keywords) []
findKeywords word (envBindingNames (contextGlobalEnv context) ++ keywords) []
where
findKeywords _ [] res = res
findKeywords match (x : xs) res =

12
src/Scoring.hs
View File

@ -25,8 +25,8 @@ scoreTypeBinder typeEnv b@(Binder _ (XObj (Lst (XObj x _ _ : XObj (Sym _ _) _ _
_ -> (500, b)
where
depthOfStruct (StructTy (ConcreteNameTy structName) varTys) =
case lookupInEnv (SymPath [] structName) (getTypeEnv typeEnv) of
Just (_, Binder _ typedef) -> (depthOfDeftype typeEnv Set.empty typedef varTys + 1, b)
case lookupBinder (SymPath [] structName) (getTypeEnv typeEnv) of
Just (Binder _ typedef) -> (depthOfDeftype typeEnv Set.empty typedef varTys + 1, b)
Nothing -> error ("Can't find user defined type '" ++ structName ++ "' in type env.")
scoreTypeBinder _ b@(Binder _ (XObj (Mod _) _ _)) =
(1000, b)
@ -75,8 +75,8 @@ depthOfType typeEnv visited selfName theType =
_
| name == selfName -> 1
| otherwise ->
case lookupInEnv (SymPath [] name) (getTypeEnv typeEnv) of
Just (_, Binder _ typedef) -> depthOfDeftype typeEnv (Set.insert theType visited) typedef varTys
case lookupBinder (SymPath [] name) (getTypeEnv typeEnv) of
Just (Binder _ typedef) -> depthOfDeftype typeEnv (Set.insert theType visited) typedef varTys
Nothing ->
--trace ("Unknown type: " ++ name) $
depthOfVarTys -- The problem here is that generic types don't generate
@ -113,8 +113,8 @@ scoreBody globalEnv visited root = visit root
(Sym path (LookupGlobal _ _)) ->
if Set.member path visited
then 0
else case lookupInEnv path globalEnv of
Just (_, foundBinder) ->
else case lookupBinder path globalEnv of
Just foundBinder ->
let (score, _) = scoreValueBinder globalEnv (Set.insert path visited) foundBinder
in score + 1
Nothing ->

2
src/StructUtils.hs
View File

@ -1,6 +1,6 @@
module StructUtils where
import Lookup
import Managed
import Obj
import Polymorphism
import Types

4
src/Sumtypes.hs
View File

@ -4,14 +4,16 @@ import Concretize
import qualified Data.Map as Map
import Data.Maybe
import Deftype
import Env
import Info
import Lookup
import Managed
import Obj
import StructUtils
import SumtypeCase
import Template
import ToTemplate
import TypeError
import TypePredicates
import Types
import TypesToC
import Util

20
src/TypeError.hs
View File

@ -1,11 +1,12 @@
module TypeError where
import Constraints
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Info
import Lookup
import Obj
import Project
import Text.EditDistance (defaultEditCosts, levenshteinDistance)
import Types
import Util
@ -435,7 +436,7 @@ joinedMachineReadableErrorStrings fppl err = joinWith "\n\n" (machineReadableErr
recursiveLookupTy :: TypeMappings -> Ty -> Ty
recursiveLookupTy mappings t = case t of
(VarTy v) -> fromMaybe t (recursiveLookup mappings v)
(VarTy v) -> fromMaybe t (recursiveNameLookup mappings v)
(RefTy r lt) -> RefTy (recursiveLookupTy mappings r) (recursiveLookupTy mappings lt)
(PointerTy p) -> PointerTy (recursiveLookupTy mappings p)
(StructTy n innerTys) -> StructTy n (map (recursiveLookupTy mappings) innerTys)
@ -470,3 +471,18 @@ makeEvalError ctx err msg info =
Nothing -> msg
in (ctx, Left (EvalError messageWhenChecking [] fppl Nothing)) -- Passing no history to avoid appending it at the end in 'show' instance for EvalError
_ -> (ctx, Left (EvalError msg history fppl info))
keysInEnvEditDistance :: SymPath -> Env -> Int -> [String]
keysInEnvEditDistance (SymPath [] name) env distance =
let candidates = Map.filterWithKey (\k _ -> levenshteinDistance defaultEditCosts k name < distance) (envBindings env)
in Map.keys candidates
keysInEnvEditDistance path@(SymPath (p : ps) name) env distance =
case Map.lookup p (envBindings env) of
Just (Binder _ xobj) ->
case xobj of
(XObj (Mod modEnv) _ _) -> keysInEnvEditDistance (SymPath ps name) modEnv distance
_ -> []
Nothing ->
case envParent env of
Just parent -> keysInEnvEditDistance path parent distance
Nothing -> []

31
src/TypePredicates.hs Normal file
View File

@ -0,0 +1,31 @@
module TypePredicates where
import Types
isTypeGeneric :: Ty -> Bool
isTypeGeneric (VarTy _) = True
isTypeGeneric (FuncTy argTys retTy _) = any isTypeGeneric argTys || isTypeGeneric retTy
isTypeGeneric (StructTy n tyArgs) = isTypeGeneric n || any isTypeGeneric tyArgs
isTypeGeneric (PointerTy p) = isTypeGeneric p
isTypeGeneric (RefTy r _) = isTypeGeneric r
isTypeGeneric _ = False
isFullyGenericType :: Ty -> Bool
isFullyGenericType (VarTy _) = True
isFullyGenericType (StructTy name members) = isFullyGenericType name && all isFullyGenericType members
isFullyGenericType _ = False
isUnit :: Ty -> Bool
isUnit UnitTy = True
isUnit (RefTy UnitTy _) = True
isUnit _ = False
-- | Is this type a function type?
isFunctionType :: Ty -> Bool
isFunctionType FuncTy {} = True
isFunctionType _ = False
-- | Is this type a struct type?
isStructType :: Ty -> Bool
isStructType (StructTy _ _) = True
isStructType _ = False

20
src/Types.hs
View File

@ -2,13 +2,11 @@ module Types
( TypeMappings,
Ty (..),
showMaybeTy,
isTypeGeneric,
unifySignatures,
replaceTyVars,
areUnifiable,
typesDeleterFunctionType,
typesCopyFunctionType,
isFullyGenericType,
doesTypeContainTyVarWithName,
replaceConflicted,
lambdaEnvTy,
@ -21,7 +19,6 @@ module Types
consPath,
Kind,
tyToKind,
isUnit,
)
where
@ -135,14 +132,6 @@ showMaybeTy :: Maybe Ty -> String
showMaybeTy (Just t) = show t
showMaybeTy Nothing = "(missing-type)"
isTypeGeneric :: Ty -> Bool
isTypeGeneric (VarTy _) = True
isTypeGeneric (FuncTy argTys retTy _) = any isTypeGeneric argTys || isTypeGeneric retTy
isTypeGeneric (StructTy n tyArgs) = isTypeGeneric n || any isTypeGeneric tyArgs
isTypeGeneric (PointerTy p) = isTypeGeneric p
isTypeGeneric (RefTy r _) = isTypeGeneric r
isTypeGeneric _ = False
doesTypeContainTyVarWithName :: String -> Ty -> Bool
doesTypeContainTyVarWithName name (VarTy n) = name == n
doesTypeContainTyVarWithName name (FuncTy argTys retTy lt) =
@ -278,15 +267,6 @@ typesCopyFunctionType memberType = FuncTy [RefTy memberType (VarTy "q")] memberT
typesDeleterFunctionType :: Ty -> Ty
typesDeleterFunctionType memberType = FuncTy [memberType] UnitTy StaticLifetimeTy
isFullyGenericType :: Ty -> Bool
isFullyGenericType (VarTy _) = True
isFullyGenericType _ = False
-- | The type of environments sent to Lambdas (used in emitted C code)
lambdaEnvTy :: Ty
lambdaEnvTy = StructTy (ConcreteNameTy "LambdaEnv") []
isUnit :: Ty -> Bool
isUnit UnitTy = True
isUnit (RefTy UnitTy _) = True
isUnit _ = False

9
src/Validate.hs
View File

@ -3,6 +3,7 @@ module Validate where
import Data.Function (on)
import Data.List (nubBy, (\\))
import Lookup
import Managed
import Obj
import TypeError
import Types
@ -78,7 +79,7 @@ canBeUsedAsMemberType typeEnv typeVariables ty xobj =
-- Prevents deftypes such as (deftype Player [pos Vector3])
do
_ <- canBeUsedAsMemberType typeEnv typeVariables tyVars xobj
case lookupInEnv (SymPath [] name') (getTypeEnv typeEnv) of
case lookupBinder (SymPath [] name') (getTypeEnv typeEnv) of
Just _ -> pure ()
Nothing -> Left (NotAmongRegisteredTypes ty xobj)
-- e.g. (deftype (Higher (f a)) (Of [(f a)]))
@ -88,10 +89,10 @@ canBeUsedAsMemberType typeEnv typeVariables ty xobj =
then pure ()
else case name of
(ConcreteNameTy n) ->
case lookupInEnv (SymPath [] n) (getTypeEnv typeEnv) of
Just (_, (Binder _ (XObj (Lst (XObj (Deftype t) _ _ : _)) _ _))) ->
case lookupBinder (SymPath [] n) (getTypeEnv typeEnv) of
Just (Binder _ (XObj (Lst (XObj (Deftype t) _ _ : _)) _ _)) ->
checkInhabitants t
Just (_, (Binder _ (XObj (Lst (XObj (DefSumtype t) _ _ : _)) _ _))) ->
Just (Binder _ (XObj (Lst (XObj (DefSumtype t) _ _ : _)) _ _)) ->
checkInhabitants t
_ -> Left (InvalidMemberType ty xobj)
where

258
test/Spec.hs
View File

@ -1,263 +1,15 @@
import Constraints
import qualified Data.Map as Map
import qualified Data.Set as Set
import Eval
import Infer
import Obj
import Parsing
module Main where
import Test.HUnit
import Types
import TestConstraints
import TestLookup
main :: IO ()
main = do
_ <- runTestTT (groupTests "Constraints" testConstraints)
_ <- runTestTT (groupTests "Lookup" testLookup)
return ()
groupTests :: String -> [Test] -> Test
groupTests label testCases =
TestList (zipWith TestLabel (map ((\s -> label ++ " Test " ++ s) . show) [1 ..]) testCases)
-- | Helper functions for testing unification of Constraints
isUnificationFailure :: Either UnificationFailure TypeMappings -> Bool
isUnificationFailure (Left _) = True
isUnificationFailure (Right _) = False
assertUnificationFailure :: [Constraint] -> Test
assertUnificationFailure constraints =
TestCase $
assertBool "Failure" (isUnificationFailure (solve constraints))
assertSolution :: [Constraint] -> [(String, Ty)] -> Test
assertSolution constraints solution =
TestCase $
assertEqual "Solution" (Right (Map.fromList solution)) (solve constraints)
-- | A dummy XObj
x = XObj (External Nothing) Nothing Nothing
-- | Some type variables
t0 = VarTy "t0"
t1 = VarTy "t1"
t2 = VarTy "t2"
t3 = VarTy "t3"
-- | Test constraints
testConstraints =
[ testConstr1,
testConstr2,
testConstr3,
testConstr4,
testConstr5,
testConstr6,
testConstr7,
testConstr8,
testConstr9,
testConstr10,
testConstr11,
testConstr12,
testConstr13,
testConstr20,
testConstr21,
testConstr22,
testConstr23,
testConstr24,
-- ,testConstr30 DISABLED FOR NOW, started failing when lifetimes were added to function types TODO: Fix!
testConstr31,
testConstr32,
testConstr33,
testConstr34,
testConstr35
]
testConstr1 =
assertUnificationFailure
[Constraint FloatTy IntTy x x x OrdNo]
testConstr2 =
assertSolution
[Constraint IntTy t0 x x x OrdNo]
[("t0", IntTy)]
testConstr3 =
assertSolution
[Constraint t0 IntTy x x x OrdNo]
[("t0", IntTy)]
testConstr4 =
assertSolution
[Constraint t0 t1 x x x OrdNo, Constraint t0 IntTy x x x OrdNo]
[("t0", IntTy), ("t1", IntTy)]
testConstr5 =
assertSolution
[Constraint t0 t1 x x x OrdNo, Constraint t1 IntTy x x x OrdNo]
[("t0", IntTy), ("t1", IntTy)]
testConstr6 =
assertSolution
[Constraint t0 t1 x x x OrdNo, Constraint t1 t3 x x x OrdNo, Constraint t2 IntTy x x x OrdNo, Constraint t3 IntTy x x x OrdNo]
[("t0", IntTy), ("t1", IntTy), ("t2", IntTy), ("t3", IntTy)]
testConstr7 =
assertUnificationFailure
[Constraint t0 IntTy x x x OrdNo, Constraint t0 FloatTy x x x OrdNo]
testConstr8 =
assertSolution
[Constraint t0 IntTy x x x OrdNo, Constraint t0 t0 x x x OrdNo]
[("t0", IntTy)]
testConstr9 =
assertSolution
[Constraint t0 IntTy x x x OrdNo, Constraint t0 t1 x x x OrdNo]
[("t0", IntTy), ("t1", IntTy)]
testConstr10 =
assertSolution
[Constraint (PointerTy (VarTy "a")) (PointerTy (VarTy "b")) x x x OrdNo]
[("a", (VarTy "a")), ("b", (VarTy "a"))]
testConstr11 =
assertSolution
[Constraint (PointerTy (VarTy "a")) (PointerTy (StructTy (ConcreteNameTy "Monkey") [])) x x x OrdNo]
[("a", (StructTy (ConcreteNameTy "Monkey") []))]
testConstr12 =
assertSolution
[ Constraint t1 (PointerTy (StructTy (ConcreteNameTy "Array") [IntTy])) x x x OrdNo,
Constraint t1 (PointerTy t2) x x x OrdNo
]
[ ("t1", (PointerTy (StructTy (ConcreteNameTy "Array") [IntTy]))),
("t2", (StructTy (ConcreteNameTy "Array") [IntTy]))
]
testConstr13 =
assertSolution
[ Constraint t1 CharTy x x x OrdNo,
Constraint t1 CharTy x x x OrdNo
]
[("t1", CharTy)]
-- -- Should collapse type variables into minimal set:
-- testConstr10 = assertSolution
-- [Constraint t0 t1 x x x, Constraint t1 t2 x x x, Constraint t2 t3 x x x OrdNo]
-- [("t0", VarTy "t0"), ("t1", VarTy "t0"), ("t2", VarTy "t0")]
-- m7 = solve ([Constraint t1 t2 x x x, Constraint t0 t1 x x x OrdNo])
-- Struct types
testConstr20 =
assertSolution
[ Constraint t0 (StructTy (ConcreteNameTy "Vector") [t1]) x x x OrdNo,
Constraint t0 (StructTy (ConcreteNameTy "Vector") [IntTy]) x x x OrdNo
]
[("t0", (StructTy (ConcreteNameTy "Vector") [IntTy])), ("t1", IntTy)]
testConstr21 =
assertSolution
[ Constraint t1 (StructTy (ConcreteNameTy "Array") [t2]) x x x OrdNo,
Constraint t1 (StructTy (ConcreteNameTy "Array") [t3]) x x x OrdNo,
Constraint t3 BoolTy x x x OrdNo
]
[ ("t1", (StructTy (ConcreteNameTy "Array") [BoolTy])),
("t2", BoolTy),
("t3", BoolTy)
]
testConstr22 =
assertSolution
[ Constraint t1 (StructTy (ConcreteNameTy "Array") [t2]) x x x OrdNo,
Constraint t2 (StructTy (ConcreteNameTy "Array") [t3]) x x x OrdNo,
Constraint t3 FloatTy x x x OrdNo
]
[ ("t1", (StructTy (ConcreteNameTy "Array") [(StructTy (ConcreteNameTy "Array") [FloatTy])])),
("t2", (StructTy (ConcreteNameTy "Array") [FloatTy])),
("t3", FloatTy)
]
testConstr23 =
assertUnificationFailure
[ Constraint (StructTy (ConcreteNameTy "Array") [t1]) (StructTy (ConcreteNameTy "Array") [t2]) x x x OrdNo,
Constraint t1 IntTy x x x OrdNo,
Constraint t2 FloatTy x x x OrdNo
]
testConstr24 =
assertUnificationFailure
[ Constraint t2 FloatTy x x x OrdNo,
Constraint t1 IntTy x x x OrdNo,
Constraint (StructTy (ConcreteNameTy "Array") [t1]) (StructTy (ConcreteNameTy "Array") [t2]) x x x OrdNo
]
-- m9 = solve [Constraint (StructTy "Vector" [IntTy]) (StructTy "Vector" [t1]) x x x OrdNo]
-- m10 = solve [Constraint (StructTy "Vector" [t1]) (StructTy "Vector" [t2]) x x x OrdNo]
-- Func types
testConstr30 =
assertSolution
[ Constraint t2 (FuncTy [t0] t1 StaticLifetimeTy) x x x OrdNo,
Constraint t2 (FuncTy [IntTy] BoolTy StaticLifetimeTy) x x x OrdNo
]
[("t0", IntTy), ("t1", BoolTy), ("t2", (FuncTy [IntTy] BoolTy StaticLifetimeTy))]
testConstr31 =
assertSolution
[Constraint (FuncTy [t0] t1 StaticLifetimeTy) (FuncTy [IntTy] BoolTy StaticLifetimeTy) x x x OrdNo]
[("t0", IntTy), ("t1", BoolTy)]
testConstr32 =
assertSolution
[Constraint t0 (FuncTy [IntTy] BoolTy StaticLifetimeTy) x x x OrdNo]
[("t0", (FuncTy [IntTy] BoolTy StaticLifetimeTy))]
testConstr33 =
assertSolution
[ Constraint t1 (FuncTy [t2] IntTy StaticLifetimeTy) x x x OrdNo,
Constraint t1 (FuncTy [t3] IntTy StaticLifetimeTy) x x x OrdNo,
Constraint t3 BoolTy x x x OrdNo
]
[ ("t1", (FuncTy [BoolTy] IntTy StaticLifetimeTy)),
("t2", BoolTy),
("t3", BoolTy)
]
testConstr34 =
assertSolution
[ Constraint (VarTy "a") (StructTy (ConcreteNameTy "Pair") [(VarTy "x0"), (VarTy "y0")]) x x x OrdNo,
Constraint (StructTy (ConcreteNameTy "Array") [(VarTy "a")]) (StructTy (ConcreteNameTy "Array") [(StructTy (ConcreteNameTy "Pair") [(VarTy "x1"), (VarTy "y1")])]) x x x OrdNo
]
[ ("a", (StructTy (ConcreteNameTy "Pair") [(VarTy "x0"), (VarTy "y0")])),
("x0", (VarTy "x0")),
("y0", (VarTy "y0")),
("x1", (VarTy "x0")),
("y1", (VarTy "y0"))
]
-- Same as testConstr34, except everything is wrapped in refs
testConstr35 =
assertSolution
[ Constraint (RefTy (VarTy "a") (VarTy "lt0")) (RefTy (StructTy (ConcreteNameTy "Pair") [(VarTy "x0"), (VarTy "y0")]) (VarTy "lt1")) x x x OrdNo,
Constraint (RefTy (StructTy (ConcreteNameTy "Array") [(VarTy "a")]) (VarTy "lt2")) (RefTy (StructTy (ConcreteNameTy "Array") [(StructTy (ConcreteNameTy "Pair") [(VarTy "x1"), (VarTy "y1")])]) (VarTy "lt3")) x x x OrdNo
]
[ ("a", (StructTy (ConcreteNameTy "Pair") [(VarTy "x0"), (VarTy "y0")])),
("x0", (VarTy "x0")),
("y0", (VarTy "y0")),
("x1", (VarTy "x0")),
("y1", (VarTy "y0")),
("lt0", (VarTy "lt0")),
("lt1", (VarTy "lt0")),
("lt2", (VarTy "lt2")),
("lt3", (VarTy "lt2"))
]
-- Ref types with lifetimes
-- testConstr36 = assertSolution
-- [Constraint (RefTy (VarTy "a")) (RefTy (StructTy "Pair" [(VarTy "x0"), (VarTy "y0")])) x x x OrdNo
-- ,Constraint (RefTy (StructTy "Array" [(VarTy "a")])) (RefTy (StructTy "Array" [(StructTy "Pair" [(VarTy "x1"), (VarTy "y1")])])) x x x OrdNo]
-- [("a", (StructTy "Pair" [(VarTy "x0"), (VarTy "y0")]))
-- ,("x0", (VarTy "x0"))
-- ,("y0", (VarTy "y0"))
-- ,("x1", (VarTy "x0"))
-- ,("y1", (VarTy "y0"))
-- ]

258
test/TestConstraints.hs Normal file
View File

@ -0,0 +1,258 @@
module TestConstraints where
import Constraints
import qualified Data.Map as Map
import qualified Data.Set as Set
import Eval
import Infer
import Obj
import Parsing
import Test.HUnit
import TestLookup
import Types
-- | Helper functions for testing unification of Constraints
isUnificationFailure :: Either UnificationFailure TypeMappings -> Bool
isUnificationFailure (Left _) = True
isUnificationFailure (Right _) = False
assertUnificationFailure :: [Constraint] -> Test
assertUnificationFailure constraints =
TestCase $
assertBool "Failure" (isUnificationFailure (solve constraints))
assertSolution :: [Constraint] -> [(String, Ty)] -> Test
assertSolution constraints solution =
TestCase $
assertEqual "Solution" (Right (Map.fromList solution)) (solve constraints)
-- | A dummy XObj
x = XObj (External Nothing) Nothing Nothing
-- | Some type variables
t0 = VarTy "t0"
t1 = VarTy "t1"
t2 = VarTy "t2"
t3 = VarTy "t3"
-- | Test constraints
testConstraints =
[ testConstr1,
testConstr2,
testConstr3,
testConstr4,
testConstr5,
testConstr6,
testConstr7,
testConstr8,
testConstr9,
testConstr10,
testConstr11,
testConstr12,
testConstr13,
testConstr20,
testConstr21,
testConstr22,
testConstr23,
testConstr24,
-- ,testConstr30 DISABLED FOR NOW, started failing when lifetimes were added to function types TODO: Fix!
testConstr31,
testConstr32,
testConstr33,
testConstr34,
testConstr35
]
testConstr1 =
assertUnificationFailure
[Constraint FloatTy IntTy x x x OrdNo]
testConstr2 =
assertSolution
[Constraint IntTy t0 x x x OrdNo]
[("t0", IntTy)]
testConstr3 =
assertSolution
[Constraint t0 IntTy x x x OrdNo]
[("t0", IntTy)]
testConstr4 =
assertSolution
[Constraint t0 t1 x x x OrdNo, Constraint t0 IntTy x x x OrdNo]
[("t0", IntTy), ("t1", IntTy)]
testConstr5 =
assertSolution
[Constraint t0 t1 x x x OrdNo, Constraint t1 IntTy x x x OrdNo]
[("t0", IntTy), ("t1", IntTy)]
testConstr6 =
assertSolution
[Constraint t0 t1 x x x OrdNo, Constraint t1 t3 x x x OrdNo, Constraint t2 IntTy x x x OrdNo, Constraint t3 IntTy x x x OrdNo]
[("t0", IntTy), ("t1", IntTy), ("t2", IntTy), ("t3", IntTy)]
testConstr7 =
assertUnificationFailure
[Constraint t0 IntTy x x x OrdNo, Constraint t0 FloatTy x x x OrdNo]
testConstr8 =
assertSolution
[Constraint t0 IntTy x x x OrdNo, Constraint t0 t0 x x x OrdNo]
[("t0", IntTy)]
testConstr9 =
assertSolution
[Constraint t0 IntTy x x x OrdNo, Constraint t0 t1 x x x OrdNo]
[("t0", IntTy), ("t1", IntTy)]
testConstr10 =
assertSolution
[Constraint (PointerTy (VarTy "a")) (PointerTy (VarTy "b")) x x x OrdNo]
[("a", (VarTy "a")), ("b", (VarTy "a"))]
testConstr11 =
assertSolution
[Constraint (PointerTy (VarTy "a")) (PointerTy (StructTy (ConcreteNameTy "Monkey") [])) x x x OrdNo]
[("a", (StructTy (ConcreteNameTy "Monkey") []))]
testConstr12 =
assertSolution
[ Constraint t1 (PointerTy (StructTy (ConcreteNameTy "Array") [IntTy])) x x x OrdNo,
Constraint t1 (PointerTy t2) x x x OrdNo
]
[ ("t1", (PointerTy (StructTy (ConcreteNameTy "Array") [IntTy]))),
("t2", (StructTy (ConcreteNameTy "Array") [IntTy]))
]
testConstr13 =
assertSolution
[ Constraint t1 CharTy x x x OrdNo,
Constraint t1 CharTy x x x OrdNo
]
[("t1", CharTy)]
-- -- Should collapse type variables into minimal set:
-- testConstr10 = assertSolution
-- [Constraint t0 t1 x x x, Constraint t1 t2 x x x, Constraint t2 t3 x x x OrdNo]
-- [("t0", VarTy "t0"), ("t1", VarTy "t0"), ("t2", VarTy "t0")]
-- m7 = solve ([Constraint t1 t2 x x x, Constraint t0 t1 x x x OrdNo])
-- Struct types
testConstr20 =
assertSolution
[ Constraint t0 (StructTy (ConcreteNameTy "Vector") [t1]) x x x OrdNo,
Constraint t0 (StructTy (ConcreteNameTy "Vector") [IntTy]) x x x OrdNo
]
[("t0", (StructTy (ConcreteNameTy "Vector") [IntTy])), ("t1", IntTy)]
testConstr21 =
assertSolution
[ Constraint t1 (StructTy (ConcreteNameTy "Array") [t2]) x x x OrdNo,
Constraint t1 (StructTy (ConcreteNameTy "Array") [t3]) x x x OrdNo,
Constraint t3 BoolTy x x x OrdNo
]
[ ("t1", (StructTy (ConcreteNameTy "Array") [BoolTy])),
("t2", BoolTy),
("t3", BoolTy)
]
testConstr22 =
assertSolution
[ Constraint t1 (StructTy (ConcreteNameTy "Array") [t2]) x x x OrdNo,
Constraint t2 (StructTy (ConcreteNameTy "Array") [t3]) x x x OrdNo,
Constraint t3 FloatTy x x x OrdNo
]
[ ("t1", (StructTy (ConcreteNameTy "Array") [(StructTy (ConcreteNameTy "Array") [FloatTy])])),
("t2", (StructTy (ConcreteNameTy "Array") [FloatTy])),
("t3", FloatTy)
]
testConstr23 =
assertUnificationFailure
[ Constraint (StructTy (ConcreteNameTy "Array") [t1]) (StructTy (ConcreteNameTy "Array") [t2]) x x x OrdNo,
Constraint t1 IntTy x x x OrdNo,
Constraint t2 FloatTy x x x OrdNo
]
testConstr24 =
assertUnificationFailure
[ Constraint t2 FloatTy x x x OrdNo,
Constraint t1 IntTy x x x OrdNo,
Constraint (StructTy (ConcreteNameTy "Array") [t1]) (StructTy (ConcreteNameTy "Array") [t2]) x x x OrdNo
]
-- m9 = solve [Constraint (StructTy "Vector" [IntTy]) (StructTy "Vector" [t1]) x x x OrdNo]
-- m10 = solve [Constraint (StructTy "Vector" [t1]) (StructTy "Vector" [t2]) x x x OrdNo]
-- Func types
testConstr30 =
assertSolution
[ Constraint t2 (FuncTy [t0] t1 StaticLifetimeTy) x x x OrdNo,
Constraint t2 (FuncTy [IntTy] BoolTy StaticLifetimeTy) x x x OrdNo
]
[("t0", IntTy), ("t1", BoolTy), ("t2", (FuncTy [IntTy] BoolTy StaticLifetimeTy))]
testConstr31 =
assertSolution
[Constraint (FuncTy [t0] t1 StaticLifetimeTy) (FuncTy [IntTy] BoolTy StaticLifetimeTy) x x x OrdNo]
[("t0", IntTy), ("t1", BoolTy)]
testConstr32 =
assertSolution
[Constraint t0 (FuncTy [IntTy] BoolTy StaticLifetimeTy) x x x OrdNo]
[("t0", (FuncTy [IntTy] BoolTy StaticLifetimeTy))]
testConstr33 =
assertSolution
[ Constraint t1 (FuncTy [t2] IntTy StaticLifetimeTy) x x x OrdNo,
Constraint t1 (FuncTy [t3] IntTy StaticLifetimeTy) x x x OrdNo,
Constraint t3 BoolTy x x x OrdNo
]
[ ("t1", (FuncTy [BoolTy] IntTy StaticLifetimeTy)),
("t2", BoolTy),
("t3", BoolTy)
]
testConstr34 =
assertSolution
[ Constraint (VarTy "a") (StructTy (ConcreteNameTy "Pair") [(VarTy "x0"), (VarTy "y0")]) x x x OrdNo,
Constraint (StructTy (ConcreteNameTy "Array") [(VarTy "a")]) (StructTy (ConcreteNameTy "Array") [(StructTy (ConcreteNameTy "Pair") [(VarTy "x1"), (VarTy "y1")])]) x x x OrdNo
]
[ ("a", (StructTy (ConcreteNameTy "Pair") [(VarTy "x0"), (VarTy "y0")])),
("x0", (VarTy "x0")),
("y0", (VarTy "y0")),
("x1", (VarTy "x0")),
("y1", (VarTy "y0"))
]
-- Same as testConstr34, except everything is wrapped in refs
testConstr35 =
assertSolution
[ Constraint (RefTy (VarTy "a") (VarTy "lt0")) (RefTy (StructTy (ConcreteNameTy "Pair") [(VarTy "x0"), (VarTy "y0")]) (VarTy "lt1")) x x x OrdNo,
Constraint (RefTy (StructTy (ConcreteNameTy "Array") [(VarTy "a")]) (VarTy "lt2")) (RefTy (StructTy (ConcreteNameTy "Array") [(StructTy (ConcreteNameTy "Pair") [(VarTy "x1"), (VarTy "y1")])]) (VarTy "lt3")) x x x OrdNo
]
[ ("a", (StructTy (ConcreteNameTy "Pair") [(VarTy "x0"), (VarTy "y0")])),
("x0", (VarTy "x0")),
("y0", (VarTy "y0")),
("x1", (VarTy "x0")),
("y1", (VarTy "y0")),
("lt0", (VarTy "lt0")),
("lt1", (VarTy "lt0")),
("lt2", (VarTy "lt2")),
("lt3", (VarTy "lt2"))
]
-- Ref types with lifetimes
-- testConstr36 = assertSolution
-- [Constraint (RefTy (VarTy "a")) (RefTy (StructTy "Pair" [(VarTy "x0"), (VarTy "y0")])) x x x OrdNo
-- ,Constraint (RefTy (StructTy "Array" [(VarTy "a")])) (RefTy (StructTy "Array" [(StructTy "Pair" [(VarTy "x1"), (VarTy "y1")])])) x x x OrdNo]
-- [("a", (StructTy "Pair" [(VarTy "x0"), (VarTy "y0")]))
-- ,("x0", (VarTy "x0"))
-- ,("y0", (VarTy "y0"))
-- ,("x1", (VarTy "x0"))
-- ,("y1", (VarTy "y0"))
-- ]

23
test/TestLookup.hs Normal file
View File

@ -0,0 +1,23 @@
module TestLookup where
import qualified Data.Map as Map
import qualified Lookup as Lookup
import Obj
import Test.HUnit
import Types
testLookup :: [Test]
testLookup =
[ basicLookup
]
b1 = Binder emptyMeta (XObj (Str "b1") Nothing (Just StringTy))
emptyRootEnv = Env (Map.fromList []) Nothing Nothing [] ExternalEnv 0
assertNotFound :: Maybe Binder -> Test
assertNotFound Nothing = TestCase (assertBool "assertNotFound" True) -- Better way?
assertNotFound _ = TestCase (assertBool "assertNotFound" False)
basicLookup :: Test
basicLookup = assertNotFound (fmap snd (Lookup.lookupInEnv (SymPath [] "nonexisting") emptyRootEnv))