carp-lang/Carp
1
1
Fork 0
mirror of https://github.com/carp-lang/Carp.git synced 2024-09-17 08:27:45 +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, Interfaces,
Primitives, Primitives,
Validate, Validate,
Reify Reify,
Env,
TypePredicates,
Managed
build-depends: base >= 4.7 && < 5 build-depends: base >= 4.7 && < 5
, parsec == 3.1.* , parsec == 3.1.*
@ -112,6 +115,8 @@ test-suite CarpHask-test
, CarpHask , CarpHask
, HUnit , HUnit
, containers , containers
other-modules: TestConstraints
, TestLookup
ghc-options: -threaded -rtsopts -with-rtsopts=-N ghc-options: -threaded -rtsopts -with-rtsopts=-N
default-language: Haskell2010 default-language: Haskell2010

2
src/ArrayTemplates.hs
View File

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

12
src/Commands.hs
View File

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

9
src/Concretize.hs
View File

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

14
src/Constraints.hs
View File

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

2
src/Context.hs
View File

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

5
src/Deftype.hs
View File

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

3
src/Emit.hs
View File

@ -16,13 +16,14 @@ import Data.List (intercalate, sortOn)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Maybe (fromJust, fromMaybe) import Data.Maybe (fromJust, fromMaybe)
import qualified Data.Set as Set import qualified Data.Set as Set
import Env
import Info import Info
import Lookup
import qualified Meta import qualified Meta
import Obj import Obj
import Project import Project
import Scoring import Scoring
import Template import Template
import TypePredicates
import Types import Types
import TypesToC import TypesToC
import Util 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 qualified Data.Map as Map
import Data.Maybe (fromJust, fromMaybe, isJust) import Data.Maybe (fromJust, fromMaybe, isJust)
import Emit import Emit
import Env
import Expand import Expand
import Infer import Infer
import Info import Info
@ -76,21 +77,21 @@ eval ctx xobj@(XObj o info ty) preference =
) )
where where
tryDynamicLookup = tryDynamicLookup =
( lookupInEnv (SymPath ("Dynamic" : p) n) (contextGlobalEnv ctx) ( lookupBinder (SymPath ("Dynamic" : p) n) (contextGlobalEnv ctx)
>>= \(_, Binder _ found) -> pure (ctx, Right (resolveDef found)) >>= \(Binder _ found) -> pure (ctx, Right (resolveDef found))
) )
tryInternalLookup path = tryInternalLookup path =
( contextInternalEnv ctx ( contextInternalEnv ctx
>>= lookupInEnv path >>= lookupBinder path
>>= \(_, Binder _ found) -> pure (ctx, Right (resolveDef found)) >>= \(Binder _ found) -> pure (ctx, Right (resolveDef found))
) )
<|> tryLookup path -- fallback <|> tryLookup path -- fallback
tryLookup path = tryLookup path =
( lookupInEnv path (contextGlobalEnv ctx) ( lookupBinder path (contextGlobalEnv ctx)
>>= \(_, Binder meta found) -> checkPrivate meta found >>= \(Binder meta found) -> checkPrivate meta found
) )
<|> ( lookupInEnv path (getTypeEnv (contextTypeEnv ctx)) <|> ( lookupBinder path (getTypeEnv (contextTypeEnv ctx))
>>= \(_, Binder _ found) -> pure (ctx, Right (resolveDef found)) >>= \(Binder _ found) -> pure (ctx, Right (resolveDef found))
) )
checkPrivate meta found = checkPrivate meta found =
pure $ pure $
@ -678,14 +679,14 @@ specialCommandWhile ctx cond body = do
) )
Left e -> pure (newCtx, Left e) Left e -> pure (newCtx, Left e)
getSigFromDefnOrDef :: Context -> Env -> FilePathPrintLength -> XObj -> (Either EvalError (Maybe (Ty, XObj))) getSigFromDefnOrDef :: Context -> Env -> FilePathPrintLength -> XObj -> Either EvalError (Maybe (Ty, XObj))
getSigFromDefnOrDef ctx globalEnv fppl xobj@(XObj _ i ty) = getSigFromDefnOrDef ctx globalEnv fppl xobj =
let pathStrings = contextPath ctx let pathStrings = contextPath ctx
path = (getPath xobj) path = getPath xobj
fullPath = case path of fullPath = case path of
(SymPath [] _) -> consPath pathStrings path (SymPath [] _) -> consPath pathStrings path
(SymPath _ _) -> path (SymPath _ _) -> path
metaData = existingMeta globalEnv (XObj (Sym fullPath Symbol) i ty) metaData = lookupMeta fullPath globalEnv
in case Meta.get "sig" metaData of in case Meta.get "sig" metaData of
Just foundSignature -> Just foundSignature ->
case xobjToTy foundSignature of 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 (ctxAfterModuleDef, res) <- liftIO $ foldM step (ctx', dynamicNil) innerExpressions
pure (popModulePath ctxAfterModuleDef {contextInternalEnv = i}, res) pure (popModulePath ctxAfterModuleDef {contextInternalEnv = i}, res)
(newCtx, result) <- (newCtx, result) <-
case lookupInEnv (SymPath pathStrings moduleName) env of case lookupBinder (SymPath pathStrings moduleName) env of
Just (_, Binder _ (XObj (Mod innerEnv) _ _)) -> do 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 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 (ctxAfterModuleAdditions, res) <- liftIO $ foldM step (ctx', dynamicNil) innerExpressions
pure (popModulePath ctxAfterModuleAdditions {contextInternalEnv = i}, res) -- TODO: propagate errors... 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 defineIt meta
Just (_, Binder _ _) -> Just (Binder _ _) ->
pure (evalError ctx ("Can't redefine '" ++ moduleName ++ "' as module") (xobjInfo xobj)) pure (evalError ctx ("Can't redefine '" ++ moduleName ++ "' as module") (xobjInfo xobj))
Nothing -> Nothing ->
defineIt emptyMeta defineIt emptyMeta
@ -1075,8 +1076,8 @@ specialCommandSet ctx [(XObj (Sym path@(SymPath mod n) _) _ _), val] = do
Just env -> setInternal newCtx env evald Just env -> setInternal newCtx env evald
where where
setGlobal ctx' env value = setGlobal ctx' env value =
case lookupInEnv path env of case lookupBinder path env of
Just (_, binder) -> do Just binder -> do
(ctx'', typedVal) <- typeCheckValueAgainstBinder ctx' value binder (ctx'', typedVal) <- typeCheckValueAgainstBinder ctx' value binder
pure $ either (failure ctx'') (success ctx'') typedVal pure $ either (failure ctx'') (success ctx'') typedVal
where 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 Control.Monad.State (State, evalState, get, put)
import Data.Foldable (foldlM) import Data.Foldable (foldlM)
import Env
import Info import Info
import Lookup import Lookup
import Obj import Obj
@ -225,14 +226,14 @@ expand eval ctx xobj =
expandArray _ = error "Can't expand non-array in expandArray." expandArray _ = error "Can't expand non-array in expandArray."
expandSymbol :: XObj -> IO (Context, Either EvalError XObj) expandSymbol :: XObj -> IO (Context, Either EvalError XObj)
expandSymbol sym@(XObj (Sym path _) _ _) = expandSymbol sym@(XObj (Sym path _) _ _) =
case lookupInEnv path (contextEnv ctx) of case lookupBinder path (contextEnv ctx) of
Just (_, Binder meta (XObj (Lst (XObj (External _) _ _ : _)) _ _)) -> isPrivate meta xobj 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 (Instantiate _) _ _ : _)) _ _)) -> isPrivate meta xobj
Just (_, Binder meta (XObj (Lst (XObj (Deftemplate _) _ _ : _)) _ _)) -> 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 (Defn _) _ _ : _)) _ _)) -> isPrivate meta xobj
Just (_, Binder meta (XObj (Lst (XObj Def _ _ : _)) _ _)) -> 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 (XObj (Lst (XObj (Defalias _) _ _ : _)) _ _)) -> isPrivate meta xobj
Just (_, Binder meta found) -> isPrivate meta found -- use the found value 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 Nothing -> pure (ctx, Right xobj) -- symbols that are not found are left as-is
where where
isPrivate m x = isPrivate m x =

7
src/InitialTypes.hs
View File

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

3
src/Interfaces.hs
View File

@ -12,6 +12,7 @@ where
import ColorText import ColorText
import Constraints import Constraints
import Control.Monad (foldM) import Control.Monad (foldM)
import Env
import Lookup import Lookup
import Obj import Obj
import Types import Types
@ -95,5 +96,5 @@ retroactivelyRegisterInInterface ctx interface =
either (\e -> error e) id resultCtx either (\e -> error e) id resultCtx
where where
env = contextGlobalEnv ctx 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 resultCtx = foldM (\context binder -> registerInInterface context binder interface) ctx impls

256
src/Lookup.hs
View File

@ -1,15 +1,13 @@
module Lookup where module Lookup where
import Data.List (foldl')
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Maybe (mapMaybe) import Data.Maybe (catMaybes, mapMaybe)
import qualified Meta import qualified Meta
import Obj import Obj
import Text.EditDistance (defaultEditCosts, levenshteinDistance)
import Types import Types
-- | The type of generic lookup functions. -- | 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. -- | Find the Binder at a specified path.
lookupInEnv :: SymPath -> Env -> Maybe (Env, Binder) lookupInEnv :: SymPath -> Env -> Maybe (Env, Binder)
@ -30,90 +28,54 @@ lookupInEnv path@(SymPath (p : ps) name) env =
Just parent -> lookupInEnv path parent Just parent -> lookupInEnv path parent
Nothing -> Nothing Nothing -> Nothing
-- | -- | Like 'lookupInEnv' but only returns the Binder (no Env)
findAllGlobalVariables :: Env -> [Binder] lookupBinder :: SymPath -> Env -> Maybe Binder
findAllGlobalVariables env = lookupBinder path env = snd <$> lookupInEnv path 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 _ =
[]
-- | Find all the possible (imported) symbols that could be referred to -- | Like 'lookupBinder' but return the Meta for the binder, or a default empty meta.
multiLookup :: String -> Env -> [(Env, Binder)] lookupMeta :: SymPath -> Env -> MetaData
multiLookup = multiLookupInternal False lookupMeta path globalEnv =
maybe emptyMeta Meta.fromBinder (lookupBinder path globalEnv)
multiLookupALL :: String -> Env -> [(Env, Binder)] -- | Get the Env stored in a binder, if any.
multiLookupALL = multiLookupInternal True envFromBinder :: Binder -> Maybe Env
envFromBinder (Binder _ (XObj (Mod e) _ _)) = Just e
-- TODO: Many of the local functions defined in the body of multiLookupInternal have been extracted. envFromBinder _ = Nothing
-- 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
-- | Given an environment, returns the list of all environments of binders from -- | 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 -> [Env]
importedEnvs env = importedEnvs env =
let envs = mapMaybe (binderToEnv . snd) (Map.toList (envBindings env)) catMaybes $ mapMaybe (\path -> fmap envFromBinder (lookupBinder path env)) (envUseModules env)
in envs ++ concatMap importedEnvs envs
-- | 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 -- | Given an environment, use a lookup function to recursively find all binders
-- in the environment that satisfy the lookup. -- in the environment that satisfy the lookup.
recursiveLookupAll :: a -> LookupFunc a -> Env -> [Binder] lookupMany :: LookWhere -> LookupFunc a b -> a -> Env -> [b]
recursiveLookupAll input lookf env = lookupMany lookWhere lookf input env =
let spine = 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 above = case envParent env of
Just parent -> recursiveLookupAll input lookf parent Just parent -> lookupMany lookWhere lookf input parent
Nothing -> [] Nothing -> []
in spine ++ leaves ++ above in spine ++ leaves ++ above
-- | Lookup binders by name. -- | Lookup binders by name in a single Env (no recursion),
lookupByName :: String -> Env -> [Binder] lookupByName :: String -> Env -> [(Env, Binder)]
lookupByName name env = lookupByName name env =
let filtered = Map.filterWithKey (\k _ -> k == name) (envBindings 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. -- | Lookup binders that have specified metadata.
lookupByMeta :: String -> Env -> [Binder] lookupByMeta :: String -> Env -> [Binder]
@ -131,12 +93,16 @@ lookupImplementations interface env =
where where
isImpl (Binder meta _) = isImpl (Binder meta _) =
case Meta.get "implements" meta of 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 _ -> False
getEnvFromBinder :: (a, Binder) -> Env -- | Find the possible (imported) symbols that could be referred to by a name.
getEnvFromBinder (_, Binder _ (XObj (Mod foundEnv) _ _)) = foundEnv multiLookupImports :: String -> Env -> [(Env, Binder)]
getEnvFromBinder (_, Binder _ err) = error ("Can't handle imports of non modules yet: " ++ show err) 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. -- | Enables look up "semi qualified" (and fully qualified) symbols.
-- | i.e. if there are nested environments with a function A.B.f -- | 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 -> Env -> [(Env, Binder)]
multiLookupQualified (SymPath [] name) rootEnv = multiLookupQualified (SymPath [] name) rootEnv =
-- This case is just like normal multiLookup, we have a name but no qualifyers: -- 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 = multiLookupQualified path@(SymPath (p : _) _) rootEnv =
case lookupInEnv (SymPath [] p) rootEnv of case lookupInEnv (SymPath [] p) rootEnv of
Just (_, Binder _ (XObj (Mod _) _ _)) -> Just (_, Binder _ (XObj (Mod _) _ _)) ->
@ -162,140 +128,6 @@ multiLookupQualified path@(SymPath (p : _) _) rootEnv =
Nothing -> [] Nothing -> []
fromUsedModules = fromUsedModules =
let usedModules = envUseModules rootEnv 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 concatMap (multiLookupQualified path) envs
in fromParent ++ fromUsedModules 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!!! -- | TODO: Environments are passed in different order here!!!
nameOfPolymorphicFunction :: TypeEnv -> Env -> Ty -> String -> Maybe SymPath nameOfPolymorphicFunction :: TypeEnv -> Env -> Ty -> String -> Maybe SymPath
nameOfPolymorphicFunction _ env functionType functionName = 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 in case filter ((\(Just t') -> areUnifiable functionType t') . xobjTy . binderXObj . snd) foundBinders of
[] -> Nothing [] -> Nothing
[(_, Binder _ (XObj (Lst (XObj (External (Just name)) _ _ : _)) _ _))] -> [(_, 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 Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Either (rights) import Data.Either (rights)
import Data.List (union) import Data.List (union)
import Data.Maybe (catMaybes, fromJust, fromMaybe) import Data.Maybe (fromJust, fromMaybe, mapMaybe)
import Deftype import Deftype
import Emit import Emit
import Env
import Infer import Infer
import Info import Info
import Interfaces import Interfaces
@ -24,6 +25,7 @@ import Sumtypes
import Template import Template
import ToTemplate import ToTemplate
import TypeError import TypeError
import TypePredicates
import Types import Types
import Util import Util
import Web.Browser (openBrowser) import Web.Browser (openBrowser)
@ -154,15 +156,15 @@ primitiveColumn x@(XObj _ i t) ctx args =
primitiveImplements :: Primitive primitiveImplements :: Primitive
primitiveImplements _ ctx [x@(XObj (Sym interface@(SymPath _ _) _) _ _), (XObj (Sym (SymPath prefixes name) _) info _)] = primitiveImplements _ ctx [x@(XObj (Sym interface@(SymPath _ _) _) _ _), (XObj (Sym (SymPath prefixes name) _) info _)] =
do 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 case (maybeInterface, maybeImpl) of
(_, Nothing) -> (_, Nothing) ->
if null modules if null modules
then pure (evalError ctx "Can't set the `implements` meta on a global definition before it is declared." info) 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 else updateMeta (Meta.stub (SymPath modules name)) ctx
(Nothing, Just (_, implBinder)) -> (Nothing, Just implBinder) ->
(warn >> updateMeta implBinder ctx) (warn >> updateMeta implBinder ctx)
(Just (_, interfaceBinder), Just (_, implBinder)) -> (Just interfaceBinder, Just implBinder) ->
(addToInterface interfaceBinder implBinder) (addToInterface interfaceBinder implBinder)
where where
global = contextGlobalEnv ctx global = contextGlobalEnv ctx
@ -175,7 +177,6 @@ primitiveImplements _ ctx [x@(XObj (Sym interface@(SymPath _ _) _) _ _), (XObj (
++ " is not defined." ++ " is not defined."
++ " Did you define it using `definterface`?" ++ " Did you define it using `definterface`?"
) )
addToInterface :: Binder -> Binder -> IO (Context, Either EvalError XObj) addToInterface :: Binder -> Binder -> IO (Context, Either EvalError XObj)
addToInterface inter impl = addToInterface inter impl =
either either
@ -202,7 +203,6 @@ primitiveImplements _ ctx [x@(XObj (Sym interface@(SymPath _ _) _) _ _), (XObj (
<|> Just (updateImplementations binder (XObj (Lst []) (Just dummyInfo) (Just DynamicTy))) <|> Just (updateImplementations binder (XObj (Lst []) (Just dummyInfo) (Just DynamicTy)))
) )
>>= \newBinder -> pure (context {contextGlobalEnv = envInsertAt global (getBinderPath binder) newBinder}) >>= \newBinder -> pure (context {contextGlobalEnv = envInsertAt global (getBinderPath binder) newBinder})
updateImplementations :: Binder -> XObj -> Binder updateImplementations :: Binder -> XObj -> Binder
updateImplementations implBinder (XObj (Lst impls) inf ty) = updateImplementations implBinder (XObj (Lst impls) inf ty) =
if x `elem` impls if x `elem` impls
@ -228,17 +228,16 @@ define hidden ctx@(Context globalEnv _ typeEnv _ proj _ _ _) annXObj =
else defineInGlobalEnv newBinder else defineInGlobalEnv newBinder
where where
freshBinder = (Binder emptyMeta annXObj) freshBinder = (Binder emptyMeta annXObj)
defineInTypeEnv :: Binder -> IO Context defineInTypeEnv :: Binder -> IO Context
defineInTypeEnv binder = pure (insertInTypeEnv ctx (getPath annXObj) binder) defineInTypeEnv binder = pure (insertInTypeEnv ctx (getPath annXObj) binder)
defineInGlobalEnv :: Binder -> IO Context defineInGlobalEnv :: Binder -> IO Context
defineInGlobalEnv fallbackBinder = defineInGlobalEnv fallbackBinder =
do do
maybeExistingBinder <- pure (lookupInEnv (getPath annXObj) globalEnv) maybeExistingBinder <- pure (lookupBinder (getPath annXObj) globalEnv)
when (projectEchoC proj) (putStrLn (toC All (Binder emptyMeta annXObj))) when (projectEchoC proj) (putStrLn (toC All (Binder emptyMeta annXObj)))
case maybeExistingBinder of case maybeExistingBinder of
Nothing -> pure (insertInGlobalEnv ctx (getPath annXObj) fallbackBinder) Nothing -> pure (insertInGlobalEnv ctx (getPath annXObj) fallbackBinder)
Just (_, binder) -> redefineExistingBinder binder Just binder -> redefineExistingBinder binder
redefineExistingBinder :: Binder -> IO Context redefineExistingBinder :: Binder -> IO Context
redefineExistingBinder old@(Binder meta _) = redefineExistingBinder old@(Binder meta _) =
do do
@ -271,7 +270,7 @@ define hidden ctx@(Context globalEnv _ typeEnv _ proj _ _ _) annXObj =
>>= \(XObj (Lst interfaces) _ _) -> pure (map getPath interfaces) >>= \(XObj (Lst interfaces) _ _) -> pure (map getPath interfaces)
) )
>>= \maybeinterfaces -> >>= \maybeinterfaces ->
pure (map snd (catMaybes (map ((flip lookupInEnv) (getTypeEnv typeEnv)) (fromMaybe [] maybeinterfaces)))) pure (mapMaybe ((flip lookupBinder) (getTypeEnv typeEnv)) (fromMaybe [] maybeinterfaces))
>>= \interfaceBinders -> >>= \interfaceBinders ->
pure (foldM (\ctx' interface -> registerInInterface ctx' binder interface) ctx interfaceBinders) pure (foldM (\ctx' interface -> registerInInterface ctx' binder interface) ctx interfaceBinders)
>>= \result -> case result of >>= \result -> case result of
@ -339,8 +338,8 @@ primitiveRegisterTypeWithFields ctx x t override members =
globalEnv = contextGlobalEnv ctx globalEnv = contextGlobalEnv ctx
typeEnv = contextTypeEnv ctx typeEnv = contextTypeEnv ctx
path = SymPath pathStrings t path = SymPath pathStrings t
preExistingModule = case lookupInEnv (SymPath pathStrings t) globalEnv of preExistingModule = case lookupBinder (SymPath pathStrings t) globalEnv of
Just (_, Binder _ (XObj (Mod found) _ _)) -> Just found Just (Binder _ (XObj (Mod found) _ _)) -> Just found
_ -> Nothing _ -> Nothing
notFound :: Context -> XObj -> SymPath -> IO (Context, Either EvalError XObj) 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 case path of
SymPath [] _ -> SymPath [] _ ->
-- First look in the type env, then in the global env: -- First look in the type env, then in the global env:
case lookupInEnv path (getTypeEnv typeEnv) of case lookupBinder path (getTypeEnv typeEnv) of
Nothing -> printer env True True (lookupInEnv path env) Nothing -> printer env True True (lookupBinder path env)
found -> do found -> do
_ <- printer env True True found -- this will print the interface itself _ <- 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 Nothing -> notFound ctx target path
found -> printer env False True found found -> printer env False True found
where where
printer env allowLookupInALL errNotFound binderPair = do printer env allowLookupEverywhere errNotFound binderPair = do
let proj = contextProj ctx let proj = contextProj ctx
case binderPair of case binderPair of
Just (_, binder@(Binder metaData x@(XObj _ (Just i) _))) -> Just (binder@(Binder metaData x@(XObj _ (Just i) _))) ->
do do
liftIO $ putStrLn (show binder ++ "\nDefined at " ++ prettyInfo i) liftIO $ putStrLn (show binder ++ "\nDefined at " ++ prettyInfo i)
printDoc metaData proj x printDoc metaData proj x
Just (_, binder@(Binder metaData x)) -> Just (binder@(Binder metaData x)) ->
do do
liftIO $ print binder liftIO $ print binder
printDoc metaData proj x printDoc metaData proj x
Nothing Nothing
| allowLookupInALL -> | allowLookupEverywhere ->
case multiLookupALL name env of case multiLookupEverywhere name env of
[] -> [] ->
if errNotFound if errNotFound
then notFound ctx target path then notFound ctx target path
@ -420,7 +419,7 @@ dynamicOrMacroWith ctx producer ty name body = do
globalEnv = contextGlobalEnv ctx globalEnv = contextGlobalEnv ctx
path = SymPath pathStrings name path = SymPath pathStrings name
elt = XObj (Lst (producer path)) (xobjInfo body) (Just ty) 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) pure (ctx {contextGlobalEnv = envInsertAt globalEnv path (Binder meta elt)}, dynamicNil)
primitiveMembers :: Primitive primitiveMembers :: Primitive
@ -428,10 +427,9 @@ primitiveMembers _ ctx [target] = do
let typeEnv = contextTypeEnv ctx let typeEnv = contextTypeEnv ctx
case bottomedTarget of case bottomedTarget of
XObj (Sym path@(SymPath _ name) _) _ _ -> XObj (Sym path@(SymPath _ name) _) _ _ ->
case lookupInEnv path (getTypeEnv typeEnv) of case lookupBinder path (getTypeEnv typeEnv) of
Just Just
( _, ( Binder
Binder
_ _
( XObj ( XObj
( Lst ( 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)) pure (ctx, Right (XObj (Arr (map (\(a, b) -> XObj (Lst [a, b]) Nothing Nothing) (pairwise members))) Nothing Nothing))
Just Just
( _, ( Binder
Binder
_ _
( XObj ( XObj
( Lst ( Lst
@ -477,13 +474,13 @@ primitiveMembers _ ctx [target] = do
bottomedTarget = bottomedTarget =
case target of case target of
XObj (Sym targetPath _) _ _ -> 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; -- this is a trick: every type generates a module in the env;
-- we’re special-casing here because we need the parent of the -- we’re special-casing here because we need the parent of the
-- module -- 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 -- if we’re recursing into a non-sym, we’ll stop one level down
Just (_, Binder _ _) -> bottomedTarget Just (Binder _ _) -> bottomedTarget
_ -> target _ -> target
_ -> target _ -> target
@ -498,15 +495,15 @@ primitiveMetaSet _ ctx [target@(XObj (Sym (SymPath prefixes name) _) _ _), XObj
types = (getTypeEnv (contextTypeEnv ctx)) types = (getTypeEnv (contextTypeEnv ctx))
lookupAndUpdate :: Maybe Context lookupAndUpdate :: Maybe Context
lookupAndUpdate = lookupAndUpdate =
( (lookupInEnv dynamicPath global) ( (lookupBinder dynamicPath global)
>>= \(_, binder) -> >>= \binder ->
(pure (Meta.updateBinderMeta binder key value)) (pure (Meta.updateBinderMeta binder key value))
>>= \b -> >>= \b ->
(pure (envInsertAt global dynamicPath b)) (pure (envInsertAt global dynamicPath b))
>>= \env -> pure (ctx {contextGlobalEnv = env}) >>= \env -> pure (ctx {contextGlobalEnv = env})
) )
<|> ( (lookupInEnv fullPath global) <|> ( (lookupBinder fullPath global)
>>= \(_, binder) -> >>= \binder ->
(pure (Meta.updateBinderMeta binder key value)) (pure (Meta.updateBinderMeta binder key value))
>>= \b -> >>= \b ->
(pure (envInsertAt global fullPath 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. -- Before creating a new binder, check that it doesn't denote an existing type or interface.
<|> ( if (null modules) <|> ( if (null modules)
then then
( (lookupInEnv fullPath types) ( (lookupBinder fullPath types)
>>= \(_, binder) -> >>= \binder ->
(pure (Meta.updateBinderMeta binder key value)) (pure (Meta.updateBinderMeta binder key value))
>>= \b -> >>= \b ->
(pure (envInsertAt types fullPath b)) (pure (envInsertAt types fullPath b))
@ -544,7 +541,7 @@ primitiveDefinterface xobj ctx [nameXObj@(XObj (Sym path@(SymPath [] name) _) _
where where
typeEnv = getTypeEnv (contextTypeEnv ctx) typeEnv = getTypeEnv (contextTypeEnv ctx)
invalidType = evalError ctx ("Invalid type for interface `" ++ name ++ "`: " ++ pretty ty) (xobjInfo ty) 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 where
defInterface = defInterface =
let interface = defineInterface name t [] (xobjInfo nameXObj) let interface = defineInterface name t [] (xobjInfo nameXObj)
@ -596,7 +593,7 @@ registerInternal ctx name ty override =
) )
(xobjInfo ty) (xobjInfo ty)
(Just t) (Just t)
meta = existingMeta globalEnv registration meta = lookupMeta (getPath registration) globalEnv
env' = envInsertAt globalEnv path (Binder meta registration) env' = envInsertAt globalEnv path (Binder meta registration)
in (ctx {contextGlobalEnv = env'}, dynamicNil) in (ctx {contextGlobalEnv = env'}, dynamicNil)
@ -694,9 +691,9 @@ primitiveDeftype xobj ctx (name : rest) =
typeEnv = contextTypeEnv ctx typeEnv = contextTypeEnv ctx
typeVariables = mapM xobjToTy typeVariableXObjs typeVariables = mapM xobjToTy typeVariableXObjs
(preExistingModule, preExistingMeta) = (preExistingModule, preExistingMeta) =
case lookupInEnv (SymPath pathStrings typeName) env of case lookupBinder (SymPath pathStrings typeName) env of
Just (_, Binder meta (XObj (Mod found) _ _)) -> (Just found, meta) Just (Binder meta (XObj (Mod found) _ _)) -> (Just found, meta)
Just (_, Binder meta _) -> (Nothing, meta) Just (Binder meta _) -> (Nothing, meta)
_ -> (Nothing, emptyMeta) _ -> (Nothing, emptyMeta)
(creatorFunction, typeConstructor) = (creatorFunction, typeConstructor) =
if length rest == 1 && isArray (head rest) 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))) let fakeImplBinder sympath t = (Binder emptyMeta (XObj (Sym sympath Symbol) (Just dummyInfo) (Just t)))
strSig = FuncTy [RefTy structTy (VarTy "q")] StringTy StaticLifetimeTy strSig = FuncTy [RefTy structTy (VarTy "q")] StringTy StaticLifetimeTy
copySig = FuncTy [RefTy structTy (VarTy "q")] structTy StaticLifetimeTy copySig = FuncTy [RefTy structTy (VarTy "q")] structTy StaticLifetimeTy
Just (_, strInterface) = lookupInEnv (SymPath [] "str") (getTypeEnv typeEnv) Just strInterface = lookupBinder (SymPath [] "str") (getTypeEnv typeEnv)
Just (_, copyInterface) = lookupInEnv (SymPath [] "copy") (getTypeEnv typeEnv) Just copyInterface = lookupBinder (SymPath [] "copy") (getTypeEnv typeEnv)
ctxWithInterfaceRegistrations = ctxWithInterfaceRegistrations =
-- Since these functions are autogenerated, we treat them as a special case and automatically implement the interfaces. -- Since these functions are autogenerated, we treat them as a special case and automatically implement the interfaces.
foldM foldM
@ -774,7 +771,7 @@ primitiveMeta (XObj _ i _) ctx [XObj (Sym (SymPath prefixes name) _) _ _, XObj (
types = getTypeEnv (contextTypeEnv ctx) types = getTypeEnv (contextTypeEnv ctx)
fullPath = consPath (union (contextPath ctx) prefixes) (SymPath [] name) fullPath = consPath (union (contextPath ctx) prefixes) (SymPath [] name)
lookup' :: Maybe Binder 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 -> (Context, Either EvalError XObj)
foundBinder binder = (ctx, maybe dynamicNil Right (Meta.getBinderMetaValue key binder)) foundBinder binder = (ctx, maybe dynamicNil Right (Meta.getBinderMetaValue key binder))
errNotFound :: (Context, Either EvalError XObj) errNotFound :: (Context, Either EvalError XObj)
@ -806,13 +803,13 @@ primitiveDeftemplate _ ctx [XObj (Sym (SymPath [] name) _) _ _, ty, XObj (Str de
if isTypeGeneric t if isTypeGeneric t
then then
let (Binder _ registration) = b let (Binder _ registration) = b
meta = existingMeta globalEnv registration meta = lookupMeta (getPath registration) globalEnv
env' = envInsertAt globalEnv p (Binder meta registration) env' = envInsertAt globalEnv p (Binder meta registration)
in (ctx {contextGlobalEnv = env'}, dynamicNil) in (ctx {contextGlobalEnv = env'}, dynamicNil)
else else
let templateCreator = getTemplateCreator template let templateCreator = getTemplateCreator template
(registration, _) = instantiateTemplate p t (templateCreator typeEnv globalEnv) (registration, _) = instantiateTemplate p t (templateCreator typeEnv globalEnv)
meta = existingMeta globalEnv registration meta = lookupMeta (getPath registration) globalEnv
env' = envInsertAt globalEnv p (Binder meta registration) env' = envInsertAt globalEnv p (Binder meta registration)
in (ctx {contextGlobalEnv = env'}, dynamicNil) in (ctx {contextGlobalEnv = env'}, dynamicNil)
primitiveDeftemplate _ ctx [XObj (Sym (SymPath [] _) _) _ _, _, XObj (Str _) _ _, x] = primitiveDeftemplate _ ctx [XObj (Sym (SymPath [] _) _) _ _, _, XObj (Str _) _ _, x] =
@ -833,10 +830,10 @@ primitiveType _ ctx [(XObj _ _ (Just Universe))] =
pure (ctx, Right (XObj (Lst []) Nothing Nothing)) pure (ctx, Right (XObj (Lst []) Nothing Nothing))
primitiveType _ ctx [(XObj _ _ (Just TypeTy))] = liftIO $ pure (ctx, Right $ reify TypeTy) primitiveType _ ctx [(XObj _ _ (Just TypeTy))] = liftIO $ pure (ctx, Right $ reify TypeTy)
primitiveType _ ctx [x@(XObj (Sym path@(SymPath [] name) _) _ _)] = primitiveType _ ctx [x@(XObj (Sym path@(SymPath [] name) _) _ _)] =
(maybe otherDefs (go . snd) (lookupInEnv path env)) (maybe otherDefs go (lookupBinder path env))
where where
env = contextGlobalEnv ctx env = contextGlobalEnv ctx
otherDefs = case multiLookupALL name env of otherDefs = case multiLookupEverywhere name env of
[] -> [] ->
notFound ctx x path notFound ctx x path
binders -> binders ->

5
src/Qualify.hs
View File

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

4
src/Repl.hs
View File

@ -8,8 +8,8 @@ import ColorText
import Control.Monad.State.Strict import Control.Monad.State.Strict
import Data.List (isPrefixOf) import Data.List (isPrefixOf)
import qualified Data.Map as Map import qualified Data.Map as Map
import Env
import Eval import Eval
import Lookup
import Obj import Obj
import Parsing (balance) import Parsing (balance)
import Path import Path
@ -27,7 +27,7 @@ import System.Exit (exitSuccess)
completeKeywordsAnd :: Context -> String -> [Completion] completeKeywordsAnd :: Context -> String -> [Completion]
completeKeywordsAnd context word = completeKeywordsAnd context word =
findKeywords word (bindingNames (contextGlobalEnv context) ++ keywords) [] findKeywords word (envBindingNames (contextGlobalEnv context) ++ keywords) []
where where
findKeywords _ [] res = res findKeywords _ [] res = res
findKeywords match (x : xs) 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) _ -> (500, b)
where where
depthOfStruct (StructTy (ConcreteNameTy structName) varTys) = depthOfStruct (StructTy (ConcreteNameTy structName) varTys) =
case lookupInEnv (SymPath [] structName) (getTypeEnv typeEnv) of case lookupBinder (SymPath [] structName) (getTypeEnv typeEnv) of
Just (_, Binder _ typedef) -> (depthOfDeftype typeEnv Set.empty typedef varTys + 1, b) Just (Binder _ typedef) -> (depthOfDeftype typeEnv Set.empty typedef varTys + 1, b)
Nothing -> error ("Can't find user defined type '" ++ structName ++ "' in type env.") Nothing -> error ("Can't find user defined type '" ++ structName ++ "' in type env.")
scoreTypeBinder _ b@(Binder _ (XObj (Mod _) _ _)) = scoreTypeBinder _ b@(Binder _ (XObj (Mod _) _ _)) =
(1000, b) (1000, b)
@ -75,8 +75,8 @@ depthOfType typeEnv visited selfName theType =
_ _
| name == selfName -> 1 | name == selfName -> 1
| otherwise -> | otherwise ->
case lookupInEnv (SymPath [] name) (getTypeEnv typeEnv) of case lookupBinder (SymPath [] name) (getTypeEnv typeEnv) of
Just (_, Binder _ typedef) -> depthOfDeftype typeEnv (Set.insert theType visited) typedef varTys Just (Binder _ typedef) -> depthOfDeftype typeEnv (Set.insert theType visited) typedef varTys
Nothing -> Nothing ->
--trace ("Unknown type: " ++ name) $ --trace ("Unknown type: " ++ name) $
depthOfVarTys -- The problem here is that generic types don't generate depthOfVarTys -- The problem here is that generic types don't generate
@ -113,8 +113,8 @@ scoreBody globalEnv visited root = visit root
(Sym path (LookupGlobal _ _)) -> (Sym path (LookupGlobal _ _)) ->
if Set.member path visited if Set.member path visited
then 0 then 0
else case lookupInEnv path globalEnv of else case lookupBinder path globalEnv of
Just (_, foundBinder) -> Just foundBinder ->
let (score, _) = scoreValueBinder globalEnv (Set.insert path visited) foundBinder let (score, _) = scoreValueBinder globalEnv (Set.insert path visited) foundBinder
in score + 1 in score + 1
Nothing -> Nothing ->

2
src/StructUtils.hs
View File

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

4
src/Sumtypes.hs
View File

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

20
src/TypeError.hs
View File

@ -1,11 +1,12 @@
module TypeError where module TypeError where
import Constraints import Constraints
import qualified Data.Map as Map
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Info import Info
import Lookup
import Obj import Obj
import Project import Project
import Text.EditDistance (defaultEditCosts, levenshteinDistance)
import Types import Types
import Util import Util
@ -435,7 +436,7 @@ joinedMachineReadableErrorStrings fppl err = joinWith "\n\n" (machineReadableErr
recursiveLookupTy :: TypeMappings -> Ty -> Ty recursiveLookupTy :: TypeMappings -> Ty -> Ty
recursiveLookupTy mappings t = case t of 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) (RefTy r lt) -> RefTy (recursiveLookupTy mappings r) (recursiveLookupTy mappings lt)
(PointerTy p) -> PointerTy (recursiveLookupTy mappings p) (PointerTy p) -> PointerTy (recursiveLookupTy mappings p)
(StructTy n innerTys) -> StructTy n (map (recursiveLookupTy mappings) innerTys) (StructTy n innerTys) -> StructTy n (map (recursiveLookupTy mappings) innerTys)
@ -470,3 +471,18 @@ makeEvalError ctx err msg info =
Nothing -> msg Nothing -> msg
in (ctx, Left (EvalError messageWhenChecking [] fppl Nothing)) -- Passing no history to avoid appending it at the end in 'show' instance for EvalError 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)) _ -> (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, ( TypeMappings,
Ty (..), Ty (..),
showMaybeTy, showMaybeTy,
isTypeGeneric,
unifySignatures, unifySignatures,
replaceTyVars, replaceTyVars,
areUnifiable, areUnifiable,
typesDeleterFunctionType, typesDeleterFunctionType,
typesCopyFunctionType, typesCopyFunctionType,
isFullyGenericType,
doesTypeContainTyVarWithName, doesTypeContainTyVarWithName,
replaceConflicted, replaceConflicted,
lambdaEnvTy, lambdaEnvTy,
@ -21,7 +19,6 @@ module Types
consPath, consPath,
Kind, Kind,
tyToKind, tyToKind,
isUnit,
) )
where where
@ -135,14 +132,6 @@ showMaybeTy :: Maybe Ty -> String
showMaybeTy (Just t) = show t showMaybeTy (Just t) = show t
showMaybeTy Nothing = "(missing-type)" 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 :: String -> Ty -> Bool
doesTypeContainTyVarWithName name (VarTy n) = name == n doesTypeContainTyVarWithName name (VarTy n) = name == n
doesTypeContainTyVarWithName name (FuncTy argTys retTy lt) = doesTypeContainTyVarWithName name (FuncTy argTys retTy lt) =
@ -278,15 +267,6 @@ typesCopyFunctionType memberType = FuncTy [RefTy memberType (VarTy "q")] memberT
typesDeleterFunctionType :: Ty -> Ty typesDeleterFunctionType :: Ty -> Ty
typesDeleterFunctionType memberType = FuncTy [memberType] UnitTy StaticLifetimeTy 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) -- | The type of environments sent to Lambdas (used in emitted C code)
lambdaEnvTy :: Ty lambdaEnvTy :: Ty
lambdaEnvTy = StructTy (ConcreteNameTy "LambdaEnv") [] 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.Function (on)
import Data.List (nubBy, (\\)) import Data.List (nubBy, (\\))
import Lookup import Lookup
import Managed
import Obj import Obj
import TypeError import TypeError
import Types import Types
@ -78,7 +79,7 @@ canBeUsedAsMemberType typeEnv typeVariables ty xobj =
-- Prevents deftypes such as (deftype Player [pos Vector3]) -- Prevents deftypes such as (deftype Player [pos Vector3])
do do
_ <- canBeUsedAsMemberType typeEnv typeVariables tyVars xobj _ <- canBeUsedAsMemberType typeEnv typeVariables tyVars xobj
case lookupInEnv (SymPath [] name') (getTypeEnv typeEnv) of case lookupBinder (SymPath [] name') (getTypeEnv typeEnv) of
Just _ -> pure () Just _ -> pure ()
Nothing -> Left (NotAmongRegisteredTypes ty xobj) Nothing -> Left (NotAmongRegisteredTypes ty xobj)
-- e.g. (deftype (Higher (f a)) (Of [(f a)])) -- e.g. (deftype (Higher (f a)) (Of [(f a)]))
@ -88,10 +89,10 @@ canBeUsedAsMemberType typeEnv typeVariables ty xobj =
then pure () then pure ()
else case name of else case name of
(ConcreteNameTy n) -> (ConcreteNameTy n) ->
case lookupInEnv (SymPath [] n) (getTypeEnv typeEnv) of case lookupBinder (SymPath [] n) (getTypeEnv typeEnv) of
Just (_, (Binder _ (XObj (Lst (XObj (Deftype t) _ _ : _)) _ _))) -> Just (Binder _ (XObj (Lst (XObj (Deftype t) _ _ : _)) _ _)) ->
checkInhabitants t checkInhabitants t
Just (_, (Binder _ (XObj (Lst (XObj (DefSumtype t) _ _ : _)) _ _))) -> Just (Binder _ (XObj (Lst (XObj (DefSumtype t) _ _ : _)) _ _)) ->
checkInhabitants t checkInhabitants t
_ -> Left (InvalidMemberType ty xobj) _ -> Left (InvalidMemberType ty xobj)
where where

258
test/Spec.hs
View File

@ -1,263 +1,15 @@
import Constraints module Main where
import qualified Data.Map as Map
import qualified Data.Set as Set
import Eval
import Infer
import Obj
import Parsing
import Test.HUnit import Test.HUnit
import Types import TestConstraints
import TestLookup
main :: IO () main :: IO ()
main = do main = do
_ <- runTestTT (groupTests "Constraints" testConstraints) _ <- runTestTT (groupTests "Constraints" testConstraints)
_ <- runTestTT (groupTests "Lookup" testLookup)
return () return ()
groupTests :: String -> [Test] -> Test groupTests :: String -> [Test] -> Test
groupTests label testCases = groupTests label testCases =
TestList (zipWith TestLabel (map ((\s -> label ++ " Test " ++ s) . show) [1 ..]) 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))