mirror of
https://github.com/carp-lang/Carp.git
synced 2024-09-17 08:27:45 +03:00
refactor: Make Lookup module more focused and DRY (#1054)
* 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:
parent
09fdd80f94
commit
b1aaa83b6a
@ -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
|
||||
|
||||
|
@ -3,7 +3,7 @@
|
||||
module ArrayTemplates where
|
||||
|
||||
import Concretize
|
||||
import Lookup
|
||||
import Managed
|
||||
import Obj
|
||||
import Template
|
||||
import ToTemplate
|
||||
|
@ -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
|
||||
|
@ -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)) $
|
||||
|
@ -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
|
||||
|
@ -4,7 +4,7 @@ module Context
|
||||
)
|
||||
where
|
||||
|
||||
import Lookup
|
||||
import Env
|
||||
import Obj
|
||||
import SymPath
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
93
src/Env.hs
Normal 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
37
src/Eval.hs
@ -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
|
||||
|
@ -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 =
|
||||
|
@ -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)
|
||||
|
@ -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
256
src/Lookup.hs
@ -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
34
src/Managed.hs
Normal 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
|
@ -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)) _ _ : _)) _ _))] ->
|
||||
|
@ -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 ->
|
||||
|
@ -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
|
||||
|
@ -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 =
|
||||
|
@ -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 ->
|
||||
|
@ -1,6 +1,6 @@
|
||||
module StructUtils where
|
||||
|
||||
import Lookup
|
||||
import Managed
|
||||
import Obj
|
||||
import Polymorphism
|
||||
import Types
|
||||
|
@ -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
|
||||
|
@ -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
31
src/TypePredicates.hs
Normal 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
20
src/Types.hs
@ -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
|
||||
|
@ -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
258
test/Spec.hs
@ -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
258
test/TestConstraints.hs
Normal 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
23
test/TestLookup.hs
Normal 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))
|
Loading…
Reference in New Issue
Block a user