diff --git a/CarpHask.cabal b/CarpHask.cabal index 43a3a197..7a19bdae 100644 --- a/CarpHask.cabal +++ b/CarpHask.cabal @@ -34,7 +34,6 @@ library Info, InitialTypes, Interfaces, - Lookup, Managed, Map, Meta, diff --git a/headerparse/Main.hs b/headerparse/Main.hs index 0b8e6b45..d9211d7c 100644 --- a/headerparse/Main.hs +++ b/headerparse/Main.hs @@ -209,7 +209,7 @@ cTypeToCarpType ("long", 0) = LongTy cTypeToCarpType ("double", 0) = DoubleTy cTypeToCarpType ("float", 0) = FloatTy cTypeToCarpType ("void", 0) = UnitTy -cTypeToCarpType (s, 0) = (StructTy (ConcreteNameTy s) []) +cTypeToCarpType (s, 0) = (StructTy (ConcreteNameTy (SymPath [] s)) []) cTypeToCarpType (x, stars) = (PointerTy (cTypeToCarpType (x, stars - 1))) identifierChar :: Parsec.Parsec String () Char diff --git a/src/ArrayTemplates.hs b/src/ArrayTemplates.hs index 23e5b661..ae7962db 100644 --- a/src/ArrayTemplates.hs +++ b/src/ArrayTemplates.hs @@ -10,6 +10,12 @@ import ToTemplate import Types import TypesToC +arrayTyA :: Ty +arrayTyA = StructTy (ConcreteNameTy (SymPath [] "Array")) [(VarTy "a")] + +arrayRef :: Ty +arrayRef = RefTy arrayTyA (VarTy "q") + -- | "Endofunctor Map" templateEMap :: (String, Binder) templateEMap = @@ -20,9 +26,8 @@ templateEMap = documentation where templateType = - FuncTy [RefTy endomorphism (VarTy "q"), arrayTy] arrayTy StaticLifetimeTy + FuncTy [RefTy endomorphism (VarTy "q"), arrayTyA] arrayTyA StaticLifetimeTy endomorphism = FuncTy [VarTy "a"] (VarTy "a") (VarTy "fq") - arrayTy = StructTy (ConcreteNameTy "Array") [VarTy "a"] documentation = "applies a function `f` to an array `a`. The type of the elements cannot change." creatorFunc :: TypeEnv -> Env -> Template @@ -30,7 +35,7 @@ templateEMap = Template templateType (templateLiteral "Array $NAME(Lambda *f, Array a)") - ( \(FuncTy [_, StructTy (ConcreteNameTy "Array") [memberTy]] _ _) -> + ( \(FuncTy [_, StructTy (ConcreteNameTy (SymPath [] "Array")) [memberTy]] _ _) -> handleUnits memberTy ) ( \(FuncTy [RefTy t@(FuncTy fArgTys fRetTy _) _, _] _ _) -> @@ -64,9 +69,8 @@ templateEFilter :: (String, Binder) templateEFilter = defineTypeParameterizedTemplate templateCreator path t docs where fTy = FuncTy [RefTy (VarTy "a") (VarTy "q")] BoolTy (VarTy "fq") - aTy = StructTy (ConcreteNameTy "Array") [VarTy "a"] path = SymPath ["Array"] "endo-filter" - t = FuncTy [RefTy fTy (VarTy "w"), aTy] aTy StaticLifetimeTy + t = FuncTy [RefTy fTy (VarTy "w"), arrayTyA] arrayTyA StaticLifetimeTy docs = "filters array members using a function. This function takes ownership." elt = "&((($a*)a.data)[i])" declaration :: String -> (String -> String) -> [Token] @@ -108,9 +112,8 @@ templatePushBack = defineTypeParameterizedTemplate creator path t docs where path = SymPath ["Array"] "push-back" - aTy = StructTy (ConcreteNameTy "Array") [VarTy "a"] valTy = VarTy "a" - t = FuncTy [aTy, valTy] aTy StaticLifetimeTy + t = FuncTy [arrayTyA, valTy] arrayTyA StaticLifetimeTy docs = "adds an element `value` to the end of an array `a`." declaration :: String -> [Token] declaration setter = @@ -146,9 +149,8 @@ templatePushBackBang = defineTypeParameterizedTemplate creator path t docs where path = SymPath ["Array"] "push-back!" - aTy = RefTy (StructTy (ConcreteNameTy "Array") [VarTy "a"]) (VarTy "q") valTy = VarTy "a" - t = FuncTy [aTy, valTy] UnitTy StaticLifetimeTy + t = FuncTy [arrayRef, valTy] UnitTy StaticLifetimeTy docs = "adds an element `value` to the end of an array `a` in-place." declaration :: String -> [Token] declaration setter = @@ -182,8 +184,7 @@ templatePopBack :: (String, Binder) templatePopBack = defineTypeParameterizedTemplate templateCreator path t docs where path = SymPath ["Array"] "pop-back" - aTy = StructTy (ConcreteNameTy "Array") [VarTy "a"] - t = FuncTy [aTy] aTy StaticLifetimeTy + t = FuncTy [arrayTyA] arrayTyA StaticLifetimeTy docs = "removes the last element of an array and returns the new array." templateCreator = TemplateCreator $ \typeEnv env -> @@ -214,8 +215,7 @@ templatePopBackBang = defineTypeParameterizedTemplate creator path t docs where path = SymPath ["Array"] "pop-back!" - aTy = RefTy (StructTy (ConcreteNameTy "Array") [VarTy "a"]) (VarTy "q") - t = FuncTy [aTy] (VarTy "a") StaticLifetimeTy + t = FuncTy [arrayRef] (VarTy "a") StaticLifetimeTy docs = "removes an element `value` from the end of an array `a` in-place and returns it." creator = TemplateCreator $ @@ -250,7 +250,7 @@ templateNth = let t = VarTy "t" in defineTemplate (SymPath ["Array"] "unsafe-nth") - (FuncTy [RefTy (StructTy (ConcreteNameTy "Array") [t]) (VarTy "q"), IntTy] (RefTy t (VarTy "q")) StaticLifetimeTy) + (FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [t]) (VarTy "q"), IntTy] (RefTy t (VarTy "q")) StaticLifetimeTy) "gets a reference to the `n`th element from an array `a`." (toTemplate "$t* $NAME (Array *aRef, int n)") ( toTemplate $ @@ -271,7 +271,7 @@ templateRaw :: (String, Binder) templateRaw = defineTemplate (SymPath ["Array"] "raw") - (FuncTy [StructTy (ConcreteNameTy "Array") [VarTy "t"]] (PointerTy (VarTy "t")) StaticLifetimeTy) + (FuncTy [StructTy (ConcreteNameTy (SymPath [] "Array")) [VarTy "t"]] (PointerTy (VarTy "t")) StaticLifetimeTy) "returns an array `a` as a raw pointer—useful for interacting with C." (toTemplate "$t* $NAME (Array a)") (toTemplate "$DECL { return a.data; }") @@ -281,7 +281,8 @@ templateUnsafeRaw :: (String, Binder) templateUnsafeRaw = defineTemplate (SymPath ["Array"] "unsafe-raw") - (FuncTy [RefTy (VarTy "q") (StructTy (ConcreteNameTy "Array") [VarTy "t"])] (PointerTy (VarTy "t")) StaticLifetimeTy) + -- TODO: Fix me! Order of members of Ref is incorrect. + (FuncTy [RefTy (VarTy "q") (StructTy (ConcreteNameTy (SymPath [] "Array")) [VarTy "t"])] (PointerTy (VarTy "t")) StaticLifetimeTy) "returns an array `a` as a raw pointer—useful for interacting with C." (toTemplate "$t* $NAME (Array* a)") (toTemplate "$DECL { return a->data; }") @@ -301,7 +302,7 @@ templateAset :: (String, Binder) templateAset = defineTypeParameterizedTemplate templateCreator path t docs where path = SymPath ["Array"] "aset" - t = FuncTy [StructTy (ConcreteNameTy "Array") [VarTy "t"], IntTy, VarTy "t"] (StructTy (ConcreteNameTy "Array") [VarTy "t"]) StaticLifetimeTy + t = FuncTy [StructTy (ConcreteNameTy (SymPath [] "Array")) [VarTy "t"], IntTy, VarTy "t"] (StructTy (ConcreteNameTy (SymPath [] "Array")) [VarTy "t"]) StaticLifetimeTy docs = "sets an array element at the index `n` to a new value." templateCreator = TemplateCreator $ \typeEnv env -> @@ -336,7 +337,7 @@ templateAsetBang :: (String, Binder) templateAsetBang = defineTypeParameterizedTemplate templateCreator path t docs where path = SymPath ["Array"] "aset!" - t = FuncTy [RefTy (StructTy (ConcreteNameTy "Array") [VarTy "t"]) (VarTy "q"), IntTy, VarTy "t"] UnitTy StaticLifetimeTy + t = FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [VarTy "t"]) (VarTy "q"), IntTy, VarTy "t"] UnitTy StaticLifetimeTy docs = "sets an array element at the index `n` to a new value in place." templateCreator = TemplateCreator $ \typeEnv env -> @@ -372,7 +373,7 @@ templateAsetUninitializedBang :: (String, Binder) templateAsetUninitializedBang = defineTypeParameterizedTemplate templateCreator path t docs where path = SymPath ["Array"] "aset-uninitialized!" - t = FuncTy [RefTy (StructTy (ConcreteNameTy "Array") [VarTy "t"]) (VarTy "q"), IntTy, VarTy "t"] UnitTy StaticLifetimeTy + t = FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [VarTy "t"]) (VarTy "q"), IntTy, VarTy "t"] UnitTy StaticLifetimeTy docs = "sets an uninitialized array member. The old member will not be deleted." templateCreator = TemplateCreator $ \_ _ -> @@ -402,7 +403,7 @@ templateLength :: (String, Binder) templateLength = defineTypeParameterizedTemplate templateCreator path t docs where path = SymPath ["Array"] "length" - t = FuncTy [RefTy (StructTy (ConcreteNameTy "Array") [VarTy "t"]) (VarTy "q")] IntTy StaticLifetimeTy + t = FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [VarTy "t"]) (VarTy "q")] IntTy StaticLifetimeTy docs = "gets the length of the array." templateCreator = TemplateCreator $ \typeEnv env -> @@ -418,7 +419,7 @@ templateAllocate :: (String, Binder) templateAllocate = defineTypeParameterizedTemplate templateCreator path t docs where path = SymPath ["Array"] "allocate" - t = FuncTy [IntTy] (StructTy (ConcreteNameTy "Array") [VarTy "t"]) StaticLifetimeTy + t = FuncTy [IntTy] (StructTy (ConcreteNameTy (SymPath [] "Array")) [VarTy "t"]) StaticLifetimeTy docs = "allocates an uninitialized array. You can initialize members using [`aset-uninitialized`](#aset-uninitialized)." templateCreator = TemplateCreator $ \typeEnv env -> @@ -448,7 +449,7 @@ templateDeleteArray :: (String, Binder) templateDeleteArray = defineTypeParameterizedTemplate templateCreator path t docs where path = SymPath ["Array"] "delete" - t = FuncTy [StructTy (ConcreteNameTy "Array") [VarTy "a"]] UnitTy StaticLifetimeTy + t = FuncTy [arrayTyA] UnitTy StaticLifetimeTy docs = "deletes an array. This function should usually not be called manually." templateCreator = TemplateCreator $ \typeEnv env -> @@ -460,7 +461,7 @@ templateDeleteArray = defineTypeParameterizedTemplate templateCreator path t doc ++ deleteTy typeEnv env arrayType ++ [TokC "}\n"] ) - ( \(FuncTy [StructTy (ConcreteNameTy "Array") [insideType]] UnitTy _) -> + ( \(FuncTy [StructTy (ConcreteNameTy (SymPath [] "Array")) [insideType]] UnitTy _) -> depsForDeleteFunc typeEnv env insideType ) @@ -474,7 +475,7 @@ deleteTy typeEnv env (StructTy _ [innerType]) = deleteTy _ _ _ = [] initTy :: Ty -> [String] -initTy (StructTy (ConcreteNameTy "Array") [innerType@FuncTy {}]) = +initTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [innerType@FuncTy {}]) = [ " // initialize each Lambda struct ", " for(int i = 0; i < a.len; i++) {", " " ++ insideArrayInitLambda innerType "i", @@ -510,7 +511,7 @@ templateCopyArray :: (String, Binder) templateCopyArray = defineTypeParameterizedTemplate templateCreator path t docs where path = SymPath ["Array"] "copy" - t = FuncTy [RefTy (StructTy (ConcreteNameTy "Array") [VarTy "a"]) (VarTy "q")] (StructTy (ConcreteNameTy "Array") [VarTy "a"]) StaticLifetimeTy + t = FuncTy [arrayRef] arrayTyA StaticLifetimeTy docs = "copies an array." templateCreator = TemplateCreator $ \typeEnv env -> @@ -528,7 +529,7 @@ templateCopyArray = defineTypeParameterizedTemplate templateCreator path t docs ++ [TokC "}\n"] ) ( \case - (FuncTy [RefTy arrayType@(StructTy (ConcreteNameTy "Array") [insideType]) _] _ _) -> + (FuncTy [RefTy arrayType@(StructTy (ConcreteNameTy (SymPath [] "Array")) [insideType]) _] _ _) -> depsForCopyFunc typeEnv env insideType ++ depsForDeleteFunc typeEnv env arrayType err -> @@ -536,7 +537,7 @@ templateCopyArray = defineTypeParameterizedTemplate templateCreator path t docs ) copyTy :: TypeEnv -> Env -> Ty -> [Token] -copyTy typeEnv env (StructTy (ConcreteNameTy "Array") [innerType]) = +copyTy typeEnv env (StructTy (ConcreteNameTy (SymPath [] "Array")) [innerType]) = if managed then [ TokC " for(int i = 0; i < a->len; i++) {\n", @@ -580,11 +581,11 @@ templateStrArray = defineTypeParameterizedTemplate templateCreator path t docs ++ strTy typeEnv env arrayType ++ [TokC "}\n"] ) - ( \(FuncTy [RefTy (StructTy (ConcreteNameTy "Array") [insideType]) _] StringTy _) -> + ( \(FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [insideType]) _] StringTy _) -> depsForPrnFunc typeEnv env insideType ) path = SymPath ["Array"] "str" - t = FuncTy [RefTy (StructTy (ConcreteNameTy "Array") [VarTy "a"]) (VarTy "q")] StringTy StaticLifetimeTy + t = FuncTy [arrayRef] StringTy StaticLifetimeTy docs = "converts an array to a string." -- | TODO: move this into the templateStrArray function? diff --git a/src/AssignTypes.hs b/src/AssignTypes.hs index 16aaaa3d..44b0ea5a 100644 --- a/src/AssignTypes.hs +++ b/src/AssignTypes.hs @@ -49,7 +49,7 @@ assignTypes mappings root = visit root Nothing -> pure xobj isArrayTypeOK :: Ty -> Bool -isArrayTypeOK (StructTy (ConcreteNameTy "Array") [RefTy _ _]) = False -- An array containing refs! +isArrayTypeOK (StructTy (ConcreteNameTy (SymPath [] "Array")) [RefTy _ _]) = False -- An array containing refs! isArrayTypeOK _ = True -- | Change auto generated type names (i.e. 't0') to letters (i.e. 'a', 'b', 'c', etc...) diff --git a/src/Commands.hs b/src/Commands.hs index ce92db8a..037cd119 100644 --- a/src/Commands.hs +++ b/src/Commands.hs @@ -12,8 +12,8 @@ import Data.List (elemIndex, foldl') import Data.List.Split (splitOn) import Data.Maybe (fromMaybe) import Emit +import qualified Env as E import Info -import Lookup import qualified Map import qualified Meta import Obj @@ -283,8 +283,8 @@ commandBuild ctx [XObj (Bol shutUp) _ _] = do proj = contextProj ctx execMode = contextExecMode ctx src = do + typeDecl <- typeEnvToDeclarations typeEnv env decl <- envToDeclarations typeEnv env - typeDecl <- envToDeclarations typeEnv (getTypeEnv typeEnv) c <- envToC env Functions initGlobals <- fmap (wrapInInitFunction (projectCore proj)) (globalsToC env) pure @@ -726,12 +726,12 @@ commandSaveDocsInternal ctx modulePath = do where getEnvironmentBinderForDocumentation :: Context -> Env -> SymPath -> Either String Binder getEnvironmentBinderForDocumentation _ env path = - case lookupBinder path env of - Just foundBinder@(Binder _ (XObj (Mod _) _ _)) -> + case E.searchValueBinder env path of + Right foundBinder@(Binder _ (XObj (Mod _ _) _ _)) -> Right foundBinder - Just (Binder _ x) -> + Right (Binder _ x) -> Left ("I can’t generate documentation for `" ++ pretty x ++ "` because it isn’t a module") - Nothing -> + Left _ -> Left ("I can’t find the module `" ++ show path ++ "`") -- | Command for emitting literal C code from Carp. @@ -760,21 +760,21 @@ commandSexpression ctx xobj = commandSexpressionInternal :: Context -> XObj -> Bool -> IO (Context, Either EvalError XObj) commandSexpressionInternal ctx xobj bol = - let tyEnv = getTypeEnv $ contextTypeEnv ctx + let tyEnv = contextTypeEnv ctx in case xobj of (XObj (Lst [inter@(XObj (Interface ty _) _ _), path]) i t) -> pure (ctx, Right (XObj (Lst [toSymbols inter, path, reify ty]) i t)) (XObj (Lst forms) i t) -> pure (ctx, Right (XObj (Lst (map toSymbols forms)) i t)) - mdl@(XObj (Mod e) _ _) -> + mdl@(XObj (Mod e _) _ _) -> if bol then getMod - else case lookupBinder (SymPath [] (fromMaybe "" (envModuleName e))) tyEnv of - Just (Binder _ (XObj (Lst forms) i t)) -> + else case E.getTypeBinder tyEnv (fromMaybe "" (envModuleName e)) of + Right (Binder _ (XObj (Lst forms) i t)) -> pure (ctx, Right (XObj (Lst (map toSymbols forms)) i t)) - Just (Binder _ xobj') -> + Right (Binder _ xobj') -> pure (ctx, Right (toSymbols xobj')) - Nothing -> + Left _ -> getMod where getMod = @@ -800,7 +800,7 @@ commandSexpressionInternal ctx xobj bol = pure $ evalError ctx ("can't get an s-expression for: " ++ pretty xobj ++ " is it a bound symbol or literal s-expression?") (Just dummyInfo) toSymbols :: XObj -> XObj -toSymbols (XObj (Mod e) i t) = +toSymbols (XObj (Mod e _) i t) = XObj ( Lst [ XObj (Sym (SymPath [] "defmodule") Symbol) i t, @@ -866,7 +866,7 @@ commandType ctx (XObj x _ _) = typeOf Break = "dreak" typeOf If = "if" typeOf (Match _) = "matxch" - typeOf (Mod _) = "module" + typeOf (Mod _ _) = "module" typeOf (Deftype _) = "deftype" typeOf (DefSumtype _) = "def-sum-type" typeOf With = "with" diff --git a/src/Concretize.hs b/src/Concretize.hs index 1fa8b406..3fd9e909 100644 --- a/src/Concretize.hs +++ b/src/Concretize.hs @@ -5,12 +5,12 @@ module Concretize where import AssignTypes import Constraints import Control.Monad.State +import Data.Either (fromRight) import Data.List (foldl') import Data.Maybe (fromMaybe) import Debug.Trace -import Env +import Env (envIsExternal, findPoly, getTypeBinder, getValue, insert, insertX, lookupEverywhere, searchValue) import Info -import Lookup import Managed import qualified Map import Obj @@ -87,8 +87,10 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root = let functionEnv = Env Map.empty (Just env) Nothing Set.empty InternalEnv 0 envWithArgs = foldl' - ( \e arg@(XObj (Sym (SymPath _ argSymName) _) _ _) -> - extendEnv e argSymName arg + ( \e arg@(XObj (Sym path _) _ _) -> + -- n.b. this won't fail since we're inserting unqualified args into a fresh env + -- TODO: Still, it'd be nicer and more flexible to catch failures here. + let Right v = insertX e path arg in v ) functionEnv argsArr @@ -115,8 +117,8 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root = functionEnv = Env Map.empty (Just env) Nothing Set.empty InternalEnv (envFunctionNestingLevel env) envWithArgs = foldl' - ( \e arg@(XObj (Sym (SymPath _ argSymName) _) _ _) -> - extendEnv e argSymName arg + ( \e arg@(XObj (Sym path _) _ _) -> + let Right v = insertX e path arg in v ) functionEnv argsArr @@ -131,8 +133,10 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root = -- Its name will contain the name of the (normal, non-lambda) function it's contained within, -- plus the identifier of the particular s-expression that defines the lambda. SymPath spath name = rootDefinitionPath - lambdaPath = SymPath spath ("_Lambda_" ++ lambdaToCName name (envFunctionNestingLevel envWithArgs) ++ "_" ++ show (infoIdentifier ii)) + lambdaPath = SymPath spath ("_Lambda_" ++ lambdaToCName name (envFunctionNestingLevel envWithArgs) ++ "_" ++ show (infoIdentifier ii) ++ "_env") lambdaNameSymbol = XObj (Sym lambdaPath Symbol) (Just dummyInfo) Nothing + environmentTypeName = pathToC lambdaPath ++ "_ty" + tyPath = (SymPath [] environmentTypeName) extendedArgs = if null capturedVars then args @@ -143,7 +147,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root = ( XObj (Sym (SymPath [] "_env") Symbol) (Just dummyInfo) - (Just (PointerTy (StructTy (ConcreteNameTy environmentTypeName) []))) : + (Just (PointerTy (StructTy (ConcreteNameTy tyPath) []))) : argsArr ) ) @@ -158,13 +162,12 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root = [XObj (Sym path Symbol) Nothing Nothing, reify symTy] ) capturedVars - environmentTypeName = pathToC lambdaPath ++ "_env" - environmentStructTy = StructTy (ConcreteNameTy environmentTypeName) [] + environmentStructTy = StructTy (ConcreteNameTy tyPath) [] environmentStruct = XObj ( Lst [ XObj (Deftype environmentStructTy) Nothing Nothing, - XObj (Sym (SymPath [] environmentTypeName) Symbol) Nothing Nothing, + XObj (Sym tyPath Symbol) Nothing Nothing, XObj (Arr structMemberPairs) Nothing Nothing ] ) @@ -178,8 +181,9 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root = copyFnTemplate = concreteCopyPtr typeEnv env pairs (copyFn, copyDeps) = instantiateTemplate (SymPath [] (environmentTypeName ++ "_copy")) copyFnTy copyFnTemplate -- The type env has to contain the lambdas environment struct for 'concretizeDefinition' to work: - extendedTypeEnv = TypeEnv (extendEnv (getTypeEnv typeEnv) environmentTypeName environmentStruct) - in case concretizeDefinition allowAmbig extendedTypeEnv env visitedDefinitions lambdaCallback funcTy of + -- TODO: Fixup: Support modules in type envs. + extendedTypeEnv = replaceLeft (FailedToAddLambdaStructToTyEnv tyPath environmentStruct) (insert typeEnv tyPath (toBinder environmentStruct)) + in case (extendedTypeEnv >>= \ext -> concretizeDefinition allowAmbig ext env visitedDefinitions lambdaCallback funcTy) of Left err -> pure (Left err) Right (concreteLiftedLambda, deps) -> do @@ -260,14 +264,14 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root = pure [okVisitedLhs, okVisitedRhs] visitSymbol :: Bool -> Env -> XObj -> State [XObj] (Either TypeError XObj) visitSymbol allowAmbig env xobj@(XObj (Sym path lookupMode) i t) = - case lookupInEnv path env of - Just (foundEnv, binder) + case searchValue env path of + Right (foundEnv, binder) | envIsExternal foundEnv -> let theXObj = binderXObj binder Just theType = xobjTy theXObj typeOfVisited = fromMaybe (error ("Missing type on " ++ show xobj ++ " at " ++ prettyInfoFromXObj xobj ++ " when looking up path " ++ show path)) t in if --(trace $ "CHECKING " ++ getName xobj ++ " : " ++ show theType ++ " with visited type " ++ show typeOfVisited ++ " and visited definitions: " ++ show visitedDefinitions) $ - isTypeGeneric theType && not (isTypeGeneric typeOfVisited) + (isTypeGeneric theType && not (isTypeGeneric typeOfVisited)) then case concretizeDefinition allowAmbig typeEnv env visitedDefinitions theXObj typeOfVisited of Left err -> pure (Left err) Right (concrete, deps) -> @@ -277,7 +281,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root = pure (Right (XObj (Sym (getPath concrete) lookupMode) i t)) else pure (Right xobj) | otherwise -> pure (Right xobj) - Nothing -> pure (Right xobj) + _ -> pure (Right xobj) visitSymbol _ _ _ = error "Not a symbol." visitMultiSym :: Bool -> Env -> XObj -> State [XObj] (Either TypeError XObj) visitMultiSym allowAmbig env xobj@(XObj (MultiSym originalSymbolName paths) i t) = @@ -296,12 +300,13 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root = Just i' = i in case solve [Constraint theType t' fake1 fake2 fake1 OrdMultiSym] of Right mappings -> - let replaced = replaceTyVars mappings t' + let replaced = (replaceTyVars mappings t') suffixed = suffixTyVars ("_x" ++ show (infoIdentifier i')) replaced -- Make sure it gets unique type variables. TODO: Is there a better way? normalSymbol = XObj (Sym singlePath mode) i (Just suffixed) in visitSymbol allowAmbig - env --(trace ("Disambiguated " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj ++ " to " ++ show singlePath ++ " : " ++ show suffixed ++ ", used to be " ++ show t' ++ ", theType = " ++ show theType ++ ", mappings = " ++ show mappings)) + env + --(trace ("Disambiguated " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj ++ " to " ++ show singlePath ++ " : " ++ show suffixed ++ ", used to be " ++ show t' ++ ", theType = " ++ show theType ++ ", mappings = " ++ show mappings) normalSymbol) normalSymbol normalSymbol Left failure@(UnificationFailure _ _) -> pure $ @@ -317,8 +322,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 lookupBinder (SymPath [] name) (getTypeEnv typeEnv) of - Just (Binder _ (XObj (Lst [XObj (Interface _ interfacePaths) _ _, _]) _ _)) -> + case getTypeBinder typeEnv name of + Right (Binder _ (XObj (Lst [XObj (Interface _ interfacePaths) _ _, _]) _ _)) -> let Just actualType = t tys = map (typeFromPath env) interfacePaths tysToPathsDict = zip tys interfacePaths @@ -347,8 +352,8 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root = allowAmbig env -- trace ("Replacing symbol " ++ pretty xobj ++ " with type " ++ show theType ++ " to single path " ++ show singlePath) normalSymbol - Just _ -> error "visitinterfacesym1" - Nothing -> + Right _ -> error "visitinterfacesym1" + Left _ -> error ("No interface named '" ++ name ++ "' found.") visitInterfaceSym _ _ _ = error "visitinterfacesym" @@ -363,11 +368,11 @@ collectCapturedVars root = removeDuplicates (map decreaseCaptureLevel (visit roo removeDuplicates :: Ord a => [a] -> [a] removeDuplicates = Set.toList . Set.fromList decreaseCaptureLevel :: XObj -> XObj - decreaseCaptureLevel (XObj (Sym path lookup) _ ty) = + decreaseCaptureLevel (XObj (Sym path lookup') _ ty) = XObj ( Sym path - ( case lookup of + ( case lookup' of Symbol -> Symbol LookupLocal NoCapture -> Symbol LookupLocal (Capture n) -> @@ -436,43 +441,41 @@ concretizeType _ ft@FuncTy {} = if isTypeGeneric ft then Right [] else Right [defineFunctionTypeAlias ft] -concretizeType typeEnv arrayTy@(StructTy (ConcreteNameTy "Array") varTys) = +concretizeType typeEnv arrayTy@(StructTy (ConcreteNameTy (SymPath [] "Array")) varTys) = if isTypeGeneric arrayTy then Right [] else do deps <- mapM (concretizeType typeEnv) varTys Right (defineArrayTypeAlias arrayTy : concat deps) -- TODO: Remove ugly duplication of code here: -concretizeType typeEnv arrayTy@(StructTy (ConcreteNameTy "StaticArray") varTys) = +concretizeType typeEnv arrayTy@(StructTy (ConcreteNameTy (SymPath [] "StaticArray")) varTys) = if isTypeGeneric arrayTy then Right [] else do deps <- mapM (concretizeType typeEnv) varTys Right (defineStaticArrayTypeAlias arrayTy : concat deps) --- TODO: handle polymorphic constructors (a b) -concretizeType typeEnv genericStructTy@(StructTy (ConcreteNameTy name) _) = - case lookupInEnv (SymPath lookupPath structName) (getTypeEnv typeEnv) of - Just (_, Binder _ (XObj (Lst (XObj (Deftype originalStructTy) _ _ : _ : rest)) _ _)) -> +concretizeType typeEnv genericStructTy@(StructTy (ConcreteNameTy (SymPath _ name)) _) = + -- TODO: This function only looks up direct children of the type environment. + -- However, spath can point to types that belong to a module. Pass the global env here. + case (getTypeBinder typeEnv name) of + Right (Binder _ x) -> go x + _ -> Right [] + where + go :: XObj -> Either TypeError [XObj] + go (XObj (Lst (XObj (Deftype originalStructTy) _ _ : _ : rest)) _ _) = if isTypeGeneric originalStructTy then instantiateGenericStructType typeEnv originalStructTy genericStructTy rest else Right [] - Just (_, Binder _ (XObj (Lst (XObj (DefSumtype originalStructTy) _ _ : _ : rest)) _ _)) -> + go (XObj (Lst (XObj (DefSumtype originalStructTy) _ _ : _ : rest)) _ _) = if isTypeGeneric originalStructTy then instantiateGenericSumtype typeEnv originalStructTy genericStructTy rest else Right [] - Just (_, Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) -> - Right [] - Just (_, Binder _ x) -> - error ("Non-deftype found in type env: " ++ show x) - Nothing -> - Right [] - where - lookupPath = getPathFromStructName name - structName = getNameFromStructName name -concretizeType env (RefTy rt _) = - concretizeType env rt -concretizeType env (PointerTy pt) = - concretizeType env pt + go (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _) = Right [] + go x = error ("Non-deftype found in type env: " ++ pretty x) +concretizeType t (RefTy rt _) = + concretizeType t rt +concretizeType t (PointerTy pt) = + concretizeType t pt concretizeType _ _ = Right [] -- ignore all other types @@ -592,11 +595,11 @@ replaceGenericTypeSymbolsOnCase _ unknownCase = unknownCase -- TODO: error out? -- | Get the type of a symbol at a given path. typeFromPath :: Env -> SymPath -> Ty typeFromPath env p = - case lookupInEnv p env of - Just (e, Binder _ found) + case searchValue env p of + Right (e, Binder _ found) | envIsExternal e -> forceTy found | otherwise -> error "Local bindings shouldn't be ambiguous." - Nothing -> error ("Couldn't find " ++ show p ++ " in env:\n" ++ prettyEnvironmentChain env) + _ -> error ("Couldn't find " ++ show p ++ " in env:\n" ++ prettyEnvironmentChain env) -- | Get the mode of a symbol at a given path. -- | @@ -604,14 +607,14 @@ typeFromPath env p = -- | parts of doesNotBelongToAnInterface. modeFromPath :: Env -> SymPath -> SymbolMode modeFromPath env p = - case lookupInEnv p env of - Just (_, Binder _ (XObj (Lst (XObj (External (Just overrideWithName)) _ _ : _)) _ _)) -> + case searchValue env p of + Right (_, Binder _ (XObj (Lst (XObj (External (Just overrideWithName)) _ _ : _)) _ _)) -> LookupGlobalOverride overrideWithName - Just (_, Binder _ (XObj (Lst (XObj (ExternalType (Just overrideWithName)) _ _ : _)) _ _)) -> + Right (_, Binder _ (XObj (Lst (XObj (ExternalType (Just overrideWithName)) _ _ : _)) _ _)) -> LookupGlobalOverride overrideWithName - Just (_, Binder _ found@(XObj (Lst (XObj (External _) _ _ : _)) _ _)) -> + Right (_, Binder _ found@(XObj (Lst (XObj (External _) _ _ : _)) _ _)) -> LookupGlobal ExternalCode (definitionMode found) - Just (e, Binder _ found) -> + Right (e, Binder _ found) -> case envMode e of ExternalEnv -> LookupGlobal CarpLand (definitionMode found) @@ -622,7 +625,7 @@ modeFromPath env p = then Capture (envFunctionNestingLevel e - envFunctionNestingLevel env) else NoCapture ) - Nothing -> error ("Couldn't find " ++ show p ++ " in env:\n" ++ prettyEnvironmentChain env) + _ -> error ("Couldn't find " ++ show p ++ " in env:\n" ++ prettyEnvironmentChain env) -- | Given a definition (def, defn, template, external) and -- a concrete type (a type without any type variables) @@ -677,26 +680,23 @@ concretizeDefinition allowAmbiguity typeEnv globalEnv visitedDefinitions definit -- For all other functions, the name must match exactly, and in all cases, the signature must match. allImplementations :: TypeEnv -> Env -> String -> Ty -> [(Env, Binder)] allImplementations typeEnv env functionName functionType = - filter (predicate . xobjTy . binderXObj . snd) foundBindings + (filter (predicate . xobjTy . binderXObj . snd) foundBindings) where predicate (Just t) = --trace ("areUnifiable? " ++ show functionType ++ " == " ++ show t ++ " " ++ show (areUnifiable functionType t)) $ areUnifiable functionType t predicate Nothing = error "allfunctionswithnameandsignature" - foundBindings = case lookupBinder (SymPath [] functionName) (getTypeEnv typeEnv) of + foundBindings = case getTypeBinder typeEnv functionName of -- this function is an interface; lookup implementations - Just (Binder _ (XObj (Lst (XObj (Interface _ paths) _ _ : _)) _ _)) -> - -- N.B./TODO: There are functions designed for this - -- scenario--e.g. lookupImplementations, but they cause - -- either entirely unacceptable behavior (not finding - -- implementations, or hangs). We should be able to use - -- those here instead of looking up all interface paths - -- directly, but for now we are stuck with this. - case sequence $ map (\p -> lookupInEnv p env) (paths ++ [(SymPath [] functionName)]) of - Just found -> found - Nothing -> (multiLookupEverywhere functionName env) + Right (Binder _ (XObj (Lst (XObj (Interface _ paths) _ _ : _)) _ _)) -> + case sequence $ map (\p -> searchValue env p) (paths ++ [(SymPath [] functionName)]) of + Right found -> found + Left _ -> + case findPoly env functionName functionType of + Right r -> [r] + Left _ -> (lookupEverywhere env functionName) -- just a regular function; look for it - _ -> (multiLookupEverywhere functionName env) + _ -> fromRight [] ((fmap (: []) (Env.getValue env functionName)) <> pure (lookupEverywhere env functionName)) -- | Find all the dependencies of a polymorphic function with a name and a desired concrete type. depsOfPolymorphicFunction :: TypeEnv -> Env -> [SymPath] -> String -> Ty -> [XObj] @@ -908,7 +908,7 @@ manageMemory typeEnv globalEnv root = -- We know that we want to add a deleter for the static array here do let var = varOfXObj xobj - Just (RefTy t@(StructTy (ConcreteNameTy "StaticArray") [_]) _) = xobjTy xobj + Just (RefTy t@(StructTy (ConcreteNameTy (SymPath [] "StaticArray")) [_]) _) = xobjTy xobj deleter = case nameOfPolymorphicFunction typeEnv globalEnv (FuncTy [t] UnitTy StaticLifetimeTy) "delete" of Just pathOfDeleteFunc -> ProperDeleter pathOfDeleteFunc (getDropFunc (xobjInfo xobj) t) var diff --git a/src/Context.hs b/src/Context.hs index e68b2bd7..2d6fa3d5 100644 --- a/src/Context.hs +++ b/src/Context.hs @@ -1,5 +1,6 @@ module Context - ( replaceGlobalEnv, + ( ContextError (..), + replaceGlobalEnv, replaceInternalEnv, replaceTypeEnv, replaceHistory, @@ -9,27 +10,82 @@ module Context replaceInternalEnv', replaceTypeEnv', replaceHistory', + replacePath', insertInGlobalEnv, insertInGlobalEnv', - insertInTypeEnv, - insertInTypeEnv', + insertTypeBinder, + insertTypeBinder', insertInInternalEnv, + insertType, + replaceTypeBinder, innermostModuleEnv, bindLetDeclaration, lookupInterface, lookupBinderInGlobalEnv, + lookupBinderInInternalEnv, lookupBinderInTypeEnv, lookupBinderInContextEnv, contextualize, ) where -import Env -import Lookup +import Data.Bifunctor +import Debug.Trace +import qualified Env as E import Obj import Project import Qualify (QualifiedPath, qualifyPath, unqualify) import SymPath +import Util (joinWithPeriod, replaceLeft) + +-------------------------------------------------------------------------------- +-- Errors + +data ContextError + = FailedToInsertInGlobalEnv SymPath Binder + | FailedToInsertInTypeEnv SymPath Binder + | FailedToInsertInInternalEnv SymPath Binder + | AttemptedToInsertQualifiedInternalBinder SymPath + | NoModuleEnvs String + | NotFoundGlobal SymPath + | NotFoundType SymPath + | NotFoundContext SymPath + | NotFoundInternal SymPath + +insertFailure :: SymPath -> Binder -> String +insertFailure path binder = + "Failed to insert the binder: " ++ show binder + ++ " at path: " + ++ show path + +instance Show ContextError where + show (FailedToInsertInGlobalEnv path binder) = + insertFailure path binder + ++ "in the context's global environment." + show (FailedToInsertInTypeEnv path binder) = + insertFailure path binder + ++ "in the context's type environment." + show (FailedToInsertInInternalEnv path binder) = + insertFailure path binder + ++ "in the context's internal environment." + show (AttemptedToInsertQualifiedInternalBinder path) = + "Attempted to insert a qualified binder: " ++ show path + ++ " into a context's internal environment." + show (NoModuleEnvs pathstring) = + "Couldn't find any modules in the given context at path: " + ++ pathstring + show (NotFoundGlobal path) = + "Couldn't find the symbol: " ++ show path + ++ "in the context's global environment." + show (NotFoundType path) = + "Couldn't find the symbol: " ++ show path + ++ "in the context's type environment." + show (NotFoundContext path) = + "Couldn't find the symbol: " ++ show path + ++ "in the context's context environment." + show (NotFoundInternal path) = + "Couldn't find the symbol: " ++ show path + ++ "in the context's internal environment." -------------------------------------------------------------------------------- -- Contextual Class @@ -113,6 +169,10 @@ replaceTypeEnv' = flip replaceTypeEnv replaceHistory' :: [XObj] -> Context -> Context replaceHistory' = flip replaceHistory +-- | replacePath with arguments flipped. +replacePath' :: [String] -> Context -> Context +replacePath' = flip replacePath + -------------------------------------------------------------------------------- -- Binding Insertion Functions @@ -121,70 +181,110 @@ replaceHistory' = flip replaceHistory -- In most cases the qualified path will have been qualified under the same -- context, but this constraint is *not* enforced by the definition of this -- function. -insertInGlobalEnv :: Context -> QualifiedPath -> Binder -> Context +insertInGlobalEnv :: Context -> QualifiedPath -> Binder -> Either ContextError Context insertInGlobalEnv ctx qpath binder = - let globalEnv = contextGlobalEnv ctx - in ctx {contextGlobalEnv = envInsertAt globalEnv (unqualify qpath) binder} + replaceLeft + (FailedToInsertInGlobalEnv (unqualify qpath) binder) + ( E.insert (contextGlobalEnv ctx) (unqualify qpath) binder + >>= \e -> pure $! (ctx {contextGlobalEnv = e}) + ) -- | Adds a binder to a context's type environment at a qualified path. -- -- In most cases the qualified path will have been qualified under the same -- context, but this constraint is *not* enforced by the definition of this -- function. -insertInTypeEnv :: Context -> QualifiedPath -> Binder -> Context -insertInTypeEnv ctx qpath binder = - let typeEnv = getTypeEnv (contextTypeEnv ctx) - in ctx {contextTypeEnv = TypeEnv (envInsertAt typeEnv (unqualify qpath) binder)} +insertTypeBinder :: Context -> QualifiedPath -> Binder -> Either ContextError Context +insertTypeBinder ctx qpath binder = + let (SymPath path name) = unqualify qpath + in first + (\_ -> trace (show path) (FailedToInsertInTypeEnv (unqualify qpath) binder)) + ( case path of + [] -> + (E.insert (contextTypeEnv ctx) (SymPath [] name) binder) + >>= pure . (replaceTypeEnv ctx) + -- TODO: We need to 'view' the global environment as a type + -- environment here to ensure types are added to a module's type + -- environment and not its value environment (the modality is + -- correct) + -- Find a more elegant API here. + _ -> + (E.insert (TypeEnv (contextGlobalEnv ctx)) (SymPath path name) binder) + >>= pure . (replaceGlobalEnv ctx) . getTypeEnv + ) + +-- TODO: This function currently only handles top-level types. (fine for now, +-- as it's only called to update interfaces) Update this to handle qualified +-- types A.B +replaceTypeBinder :: Context -> QualifiedPath -> Binder -> Either ContextError Context +replaceTypeBinder ctx qpath binder = + let (SymPath _ name) = unqualify qpath + err = (FailedToInsertInTypeEnv (unqualify qpath) binder) + replacement = (E.replaceInPlace (contextTypeEnv ctx) name binder) >>= pure . (replaceTypeEnv ctx) + in replaceLeft err replacement <> insertTypeBinder ctx qpath binder -- | Adds a binder to a context's internal environment at an unqualified path. -- -- If the context does not have an internal environment, this function does nothing. -insertInInternalEnv :: Context -> SymPath -> Binder -> Context +insertInInternalEnv :: Context -> SymPath -> Binder -> Either ContextError Context insertInInternalEnv ctx path@(SymPath [] _) binder = - ctx {contextInternalEnv = fmap insert (contextInternalEnv ctx)} + maybe + (Left (FailedToInsertInInternalEnv path binder)) + insert' + (contextInternalEnv ctx) where - insert :: Env -> Env - insert e = envInsertAt e path binder -insertInInternalEnv _ _ _ = - error "attempted to insert a qualified symbol into an internal environment" + insert' :: Env -> Either ContextError Context + insert' e = + replaceLeft + (FailedToInsertInInternalEnv path binder) + (E.insert e path binder >>= \e' -> pure (ctx {contextInternalEnv = pure e'})) +insertInInternalEnv _ path _ = Left (AttemptedToInsertQualifiedInternalBinder path) -- | insertInGlobalEnv with arguments flipped. -insertInGlobalEnv' :: QualifiedPath -> Binder -> Context -> Context +insertInGlobalEnv' :: QualifiedPath -> Binder -> Context -> Either ContextError Context insertInGlobalEnv' path binder ctx = insertInGlobalEnv ctx path binder --- | insertInTypeEnv with arguments flipped. -insertInTypeEnv' :: QualifiedPath -> Binder -> Context -> Context -insertInTypeEnv' path binder ctx = insertInTypeEnv ctx path binder +-- | insertTypeBinder with arguments flipped. +insertTypeBinder' :: QualifiedPath -> Binder -> Context -> Either ContextError Context +insertTypeBinder' path binder ctx = insertTypeBinder ctx path binder -- | Inserts a let binding into the appropriate environment in a context. -bindLetDeclaration :: Context -> String -> XObj -> Context +bindLetDeclaration :: Context -> String -> XObj -> Either ContextError Context bindLetDeclaration ctx name xobj = let binder = Binder emptyMeta (toLocalDef name xobj) in insertInInternalEnv ctx (SymPath [] name) binder +-- | Inserts a new type into a given context, adding a binding to the type +-- environment and a module to to value environment. +insertType :: Context -> QualifiedPath -> Binder -> Binder -> Either ContextError Context +insertType ctx qpath typeBinder modBinder = + (insertInGlobalEnv ctx qpath modBinder) + >>= \c -> (insertTypeBinder c qpath typeBinder) + -------------------------------------------------------------------------------- -- Environment Retrieval Functions -- | Retrieves the innermost (deepest) module environment in a context -- according to the context's contextPath. -- --- Returns Nothing if the Context path is empty. -innermostModuleEnv :: Context -> Maybe Env +-- Returns an error if the Context path is empty. +innermostModuleEnv :: Context -> Either ContextError Env innermostModuleEnv ctx = go (contextPath ctx) where - go :: [String] -> Maybe Env - go [] = Nothing - go xs = Just $ getEnv (contextGlobalEnv ctx) xs + go :: [String] -> Either ContextError Env + go [] = Left (NoModuleEnvs "") + go xs = replaceLeft (NoModuleEnvs (joinWithPeriod xs)) (E.getInnerEnv (contextGlobalEnv ctx) xs) -------------------------------------------------------------------------------- -- Binder Lookup Functions -- | Lookup a binder with a fully determined location in a context. -decontextualizedLookup :: (Context -> SymPath -> Maybe Binder) -> Context -> SymPath -> Maybe Binder +decontextualizedLookup :: (Context -> SymPath -> Either ContextError Binder) -> Context -> SymPath -> Either ContextError Binder decontextualizedLookup f ctx path = f (replacePath ctx []) path -lookupInterface :: Context -> SymPath -> Maybe Binder +-- | Lookup an interface in the given context. +lookupInterface :: Context -> SymPath -> Either ContextError Binder lookupInterface ctx path = decontextualizedLookup lookupBinderInTypeEnv ctx path @@ -193,30 +293,46 @@ lookupInterface ctx path = -- Depending on the type of path passed to this function, further -- contextualization of the path may be performed before the lookup is -- performed. -lookupBinderInTypeEnv :: Contextual a => Context -> a -> Maybe Binder +lookupBinderInTypeEnv :: Contextual a => Context -> a -> Either ContextError Binder lookupBinderInTypeEnv ctx path = - let typeEnv = getTypeEnv (contextTypeEnv ctx) - fullPath = contextualize path ctx - in lookupBinder fullPath typeEnv + let typeEnv = contextTypeEnv ctx + global = contextGlobalEnv ctx + fullPath@(SymPath qualification name) = contextualize path ctx + theType = + ( case qualification of + [] -> E.getTypeBinder typeEnv name + _ -> E.searchTypeBinder global fullPath + ) + in replaceLeft (NotFoundType fullPath) theType -- | Lookup a binder in a context's global environment. -- -- Depending on the type of path passed to this function, further -- contextualization of the path may be performed before the lookup is -- performed. -lookupBinderInGlobalEnv :: Contextual a => Context -> a -> Maybe Binder +lookupBinderInGlobalEnv :: Contextual a => Context -> a -> Either ContextError Binder lookupBinderInGlobalEnv ctx path = let global = contextGlobalEnv ctx fullPath = contextualize path ctx - in lookupBinder fullPath global + in replaceLeft (NotFoundGlobal fullPath) (E.searchValueBinder global fullPath) + +-- | Lookup a binder in a context's internal environment. +lookupBinderInInternalEnv :: Contextual a => Context -> a -> Either ContextError Binder +lookupBinderInInternalEnv ctx path = + let internal = contextInternalEnv ctx + fullPath = contextualize path ctx + in maybe + (Left (NotFoundInternal fullPath)) + (\e -> replaceLeft (NotFoundInternal fullPath) (E.searchValueBinder e fullPath)) + internal -- | Lookup a binder in a context's context environment. -- -- Depending on the type of path passed to this function, further -- contextualization of the path may be performed before the lookup is -- performed. -lookupBinderInContextEnv :: Context -> SymPath -> Maybe Binder +lookupBinderInContextEnv :: Context -> SymPath -> Either ContextError Binder lookupBinderInContextEnv ctx path = - let ctxEnv = contextEnv ctx + let ctxEnv = (E.contextEnv ctx) fullPath = contextualize path ctx - in lookupBinder fullPath ctxEnv + in replaceLeft (NotFoundContext fullPath) (E.searchValueBinder ctxEnv fullPath) diff --git a/src/Deftype.hs b/src/Deftype.hs index df5ceafd..afeacb2b 100644 --- a/src/Deftype.hs +++ b/src/Deftype.hs @@ -2,19 +2,19 @@ module Deftype ( moduleForDeftype, + moduleForDeftypeInContext, bindingsForRegisteredType, memberArg, ) where import Concretize +import Context import Data.Maybe -import Env +import Env (addListOfBindings, new) import Info import Managed -import qualified Map import Obj -import qualified Set import StructUtils import Template import ToTemplate @@ -27,19 +27,41 @@ import Validate {-# ANN module "HLint: ignore Reduce duplication" #-} +moduleForDeftypeInContext :: Context -> String -> [Ty] -> [XObj] -> Maybe Info -> Either TypeError (String, XObj, [XObj]) +moduleForDeftypeInContext ctx name vars members info = + let global = contextGlobalEnv ctx + types = contextTypeEnv ctx + path = contextPath ctx + inner = either (const Nothing) Just (innermostModuleEnv ctx) + previous = + either + (const Nothing) + Just + ( (lookupBinderInInternalEnv ctx (SymPath path name)) + <> (lookupBinderInGlobalEnv ctx (SymPath path name)) + >>= \b -> + replaceLeft + (NotFoundGlobal (SymPath path name)) + ( case binderXObj b of + XObj (Mod ev et) _ _ -> Right (ev, et) + _ -> Left "Non module" + ) + ) + in moduleForDeftype inner types global path name vars members info previous + -- | This function creates a "Type Module" with the same name as the type being defined. -- A type module provides a namespace for all the functions that area automatically -- generated by a deftype. -moduleForDeftype :: Maybe Env -> TypeEnv -> Env -> [String] -> String -> [Ty] -> [XObj] -> Maybe Info -> Maybe Env -> Either TypeError (String, XObj, [XObj]) +moduleForDeftype :: Maybe Env -> TypeEnv -> Env -> [String] -> String -> [Ty] -> [XObj] -> Maybe Info -> Maybe (Env, TypeEnv) -> Either TypeError (String, XObj, [XObj]) moduleForDeftype innerEnv typeEnv env pathStrings typeName typeVariables rest i existingEnv = - let typeModuleName = typeName - typeModuleEnv = fromMaybe (Env (Map.fromList []) innerEnv (Just typeModuleName) Set.empty ExternalEnv 0) existingEnv + let moduleValueEnv = fromMaybe (new innerEnv (Just typeName)) (fmap fst existingEnv) + moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv) -- The variable 'insidePath' is the path used for all member functions inside the 'typeModule'. -- For example (module Vec2 [x Float]) creates bindings like Vec2.create, Vec2.x, etc. - insidePath = pathStrings ++ [typeModuleName] + insidePath = pathStrings ++ [typeName] in do validateMemberCases typeEnv typeVariables rest - let structTy = StructTy (ConcreteNameTy (createStructName pathStrings typeName)) typeVariables + let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables (okMembers, membersDeps) <- templatesForMembers typeEnv env insidePath structTy rest okInit <- binderForInit insidePath structTy rest (okStr, strDeps) <- binderForStrOrPrn typeEnv env insidePath structTy rest "str" @@ -47,29 +69,29 @@ moduleForDeftype innerEnv typeEnv env pathStrings typeName typeVariables rest i (okDelete, deleteDeps) <- binderForDelete typeEnv env insidePath structTy rest (okCopy, copyDeps) <- binderForCopy typeEnv env insidePath structTy rest let funcs = okInit : okStr : okPrn : okDelete : okCopy : okMembers - moduleEnvWithBindings = addListOfBindings typeModuleEnv funcs - typeModuleXObj = XObj (Mod moduleEnvWithBindings) i (Just ModuleTy) + moduleEnvWithBindings = addListOfBindings moduleValueEnv funcs + typeModuleXObj = XObj (Mod moduleEnvWithBindings moduleTypeEnv) i (Just ModuleTy) deps = deleteDeps ++ membersDeps ++ copyDeps ++ strDeps - pure (typeModuleName, typeModuleXObj, deps) + pure (typeName, typeModuleXObj, deps) -- | Will generate getters/setters/updaters when registering EXTERNAL types. -- | i.e. (register-type VRUnicornData [hp Int, magic Float]) -- | TODO: Remove duplication shared by moduleForDeftype-function. -bindingsForRegisteredType :: TypeEnv -> Env -> [String] -> String -> [XObj] -> Maybe Info -> Maybe Env -> Either TypeError (String, XObj, [XObj]) +bindingsForRegisteredType :: TypeEnv -> Env -> [String] -> String -> [XObj] -> Maybe Info -> Maybe (Env, TypeEnv) -> Either TypeError (String, XObj, [XObj]) bindingsForRegisteredType typeEnv env pathStrings typeName rest i existingEnv = - let typeModuleName = typeName - typeModuleEnv = fromMaybe (Env (Map.fromList []) (Just env) (Just typeModuleName) Set.empty ExternalEnv 0) existingEnv - insidePath = pathStrings ++ [typeModuleName] + let moduleValueEnv = fromMaybe (new (Just env) (Just typeName)) (fmap fst existingEnv) + moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv) + insidePath = pathStrings ++ [typeName] in do validateMemberCases typeEnv [] rest - let structTy = StructTy (ConcreteNameTy typeName) [] + let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) [] (binders, deps) <- templatesForMembers typeEnv env insidePath structTy rest okInit <- binderForInit insidePath structTy rest (okStr, strDeps) <- binderForStrOrPrn typeEnv env insidePath structTy rest "str" (okPrn, _) <- binderForStrOrPrn typeEnv env insidePath structTy rest "prn" - let moduleEnvWithBindings = addListOfBindings typeModuleEnv (okInit : okStr : okPrn : binders) - typeModuleXObj = XObj (Mod moduleEnvWithBindings) i (Just ModuleTy) - pure (typeModuleName, typeModuleXObj, deps ++ strDeps) + let moduleEnvWithBindings = addListOfBindings moduleValueEnv (okInit : okStr : okPrn : binders) + typeModuleXObj = XObj (Mod moduleEnvWithBindings moduleTypeEnv) i (Just ModuleTy) + pure (typeName, typeModuleXObj, deps ++ strDeps) -- | Generate all the templates for ALL the member variables in a deftype declaration. templatesForMembers :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> Either TypeError ([(String, Binder)], [XObj]) @@ -80,7 +102,7 @@ templatesForMembers _ _ _ _ _ = error "Shouldn't reach this case (invalid type d -- | Generate the templates for a single member in a deftype declaration. templatesForSingleMember :: TypeEnv -> Env -> [String] -> Ty -> (XObj, XObj) -> [((String, Binder), [XObj])] -templatesForSingleMember typeEnv env insidePath p@(StructTy (ConcreteNameTy typeName) _) (nameXObj, typeXObj) = +templatesForSingleMember typeEnv env insidePath p@(StructTy (ConcreteNameTy _) _) (nameXObj, typeXObj) = case t of -- Unit member types are special since we do not represent them in emitted c. -- Instead, members of type Unit are executed for their side effects and silently omitted @@ -101,18 +123,18 @@ templatesForSingleMember typeEnv env insidePath p@(StructTy (ConcreteNameTy type Just t = xobjToTy typeXObj memberName = getName nameXObj binders getterSig setterSig mutatorSig updaterSig = - [ instanceBinderWithDeps (SymPath insidePath memberName) getterSig (templateGetter (mangle memberName) t) ("gets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "`."), + [ instanceBinderWithDeps (SymPath insidePath memberName) getterSig (templateGetter (mangle memberName) t) ("gets the `" ++ memberName ++ "` property of a `" ++ show p ++ "`."), if isTypeGeneric t then (templateGenericSetter insidePath p t memberName, []) - else instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName)) setterSig (templateSetter typeEnv env (mangle memberName) t) ("sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "`."), + else instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName)) setterSig (templateSetter typeEnv env (mangle memberName) t) ("sets the `" ++ memberName ++ "` property of a `" ++ show p ++ "`."), if isTypeGeneric t then (templateGenericMutatingSetter insidePath p t memberName, []) - else instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName ++ "!")) mutatorSig (templateMutatingSetter typeEnv env (mangle memberName) t) ("sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "` in place."), + else instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName ++ "!")) mutatorSig (templateMutatingSetter typeEnv env (mangle memberName) t) ("sets the `" ++ memberName ++ "` property of a `" ++ show p ++ "` in place."), instanceBinderWithDeps (SymPath insidePath ("update-" ++ memberName)) updaterSig (templateUpdater (mangle memberName) t) - ("updates the `" ++ memberName ++ "` property of a `" ++ typeName ++ "` using a function `f`.") + ("updates the `" ++ memberName ++ "` property of a `" ++ show p ++ "` using a function `f`.") ] templatesForSingleMember _ _ _ _ _ = error "templatesforsinglemember" @@ -176,12 +198,12 @@ templateSetter typeEnv env memberName memberTy = -- | The template for setters of a generic deftype. templateGenericSetter :: [String] -> Ty -> Ty -> String -> (String, Binder) -templateGenericSetter pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membTy memberName = +templateGenericSetter pathStrings originalStructTy@(StructTy (ConcreteNameTy _) _) membTy memberName = defineTypeParameterizedTemplate templateCreator path (FuncTy [originalStructTy, membTy] originalStructTy StaticLifetimeTy) docs where path = SymPath pathStrings ("set-" ++ memberName) t = FuncTy [VarTy "p", VarTy "t"] (VarTy "p") StaticLifetimeTy - docs = "sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "`." + docs = "sets the `" ++ memberName ++ "` property of a `" ++ show originalStructTy ++ "`." templateCreator = TemplateCreator $ \typeEnv env -> Template @@ -242,12 +264,12 @@ templateMutatingSetter typeEnv env memberName memberTy = -- | The template for mutating setters of a generic deftype. templateGenericMutatingSetter :: [String] -> Ty -> Ty -> String -> (String, Binder) -templateGenericMutatingSetter pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membTy memberName = +templateGenericMutatingSetter pathStrings originalStructTy@(StructTy (ConcreteNameTy _) _) membTy memberName = defineTypeParameterizedTemplate templateCreator path (FuncTy [RefTy originalStructTy (VarTy "q"), membTy] UnitTy StaticLifetimeTy) docs where path = SymPath pathStrings ("set-" ++ memberName ++ "!") t = FuncTy [RefTy (VarTy "p") (VarTy "q"), VarTy "t"] UnitTy StaticLifetimeTy - docs = "sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "` in place." + docs = "sets the `" ++ memberName ++ "` property of a `" ++ show originalStructTy ++ "` in place." templateCreator = TemplateCreator $ \typeEnv env -> Template @@ -313,7 +335,7 @@ templateUpdater member _ = -- | Helper function to create the binder for the 'init' template. binderForInit :: [String] -> Ty -> [XObj] -> Either TypeError (String, Binder) -binderForInit insidePath structTy@(StructTy (ConcreteNameTy typeName) _) [XObj (Arr membersXObjs) _ _] = +binderForInit insidePath structTy@(StructTy (ConcreteNameTy _) _) [XObj (Arr membersXObjs) _ _] = if isTypeGeneric structTy then Right (genericInit StackAlloc insidePath structTy membersXObjs) else @@ -322,7 +344,7 @@ binderForInit insidePath structTy@(StructTy (ConcreteNameTy typeName) _) [XObj ( (SymPath insidePath "init") (FuncTy (initArgListTypes membersXObjs) structTy StaticLifetimeTy) (concreteInit StackAlloc structTy membersXObjs) - ("creates a `" ++ typeName ++ "`.") + ("creates a `" ++ show structTy ++ "`.") binderForInit _ _ _ = error "binderforinit" -- | Generate a list of types from a deftype declaration. @@ -332,7 +354,7 @@ initArgListTypes xobjs = -- | The template for the 'init' and 'new' functions for a concrete deftype. concreteInit :: AllocationMode -> Ty -> [XObj] -> Template -concreteInit allocationMode originalStructTy@(StructTy (ConcreteNameTy typeName) _) membersXObjs = +concreteInit allocationMode originalStructTy@(StructTy (ConcreteNameTy _) _) membersXObjs = Template (FuncTy (map snd (memberXObjsToPairs membersXObjs)) (VarTy "p") StaticLifetimeTy) ( \(FuncTy _ concreteStructTy _) -> @@ -344,7 +366,7 @@ concreteInit allocationMode originalStructTy@(StructTy (ConcreteNameTy typeName) ( \(FuncTy _ concreteStructTy _) -> let mappings = unifySignatures originalStructTy concreteStructTy correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs - in tokensForInit allocationMode typeName correctedMembers + in tokensForInit allocationMode (show originalStructTy) correctedMembers ) (\FuncTy {} -> []) where @@ -353,12 +375,12 @@ concreteInit _ _ _ = error "concreteinit" -- | The template for the 'init' and 'new' functions for a generic deftype. genericInit :: AllocationMode -> [String] -> Ty -> [XObj] -> (String, Binder) -genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membersXObjs = +genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameTy _) _) membersXObjs = defineTypeParameterizedTemplate templateCreator path t docs where path = SymPath pathStrings "init" t = FuncTy (map snd (memberXObjsToPairs membersXObjs)) originalStructTy StaticLifetimeTy - docs = "creates a `" ++ typeName ++ "`." + docs = "creates a `" ++ show originalStructTy ++ "`." templateCreator = TemplateCreator $ \typeEnv _ -> Template @@ -372,7 +394,7 @@ genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameT ( \(FuncTy _ concreteStructTy _) -> let mappings = unifySignatures originalStructTy concreteStructTy correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs - in tokensForInit allocationMode typeName correctedMembers + in tokensForInit allocationMode (show originalStructTy) correctedMembers ) ( \(FuncTy _ concreteStructTy _) -> case concretizeType typeEnv concreteStructTy of @@ -424,7 +446,7 @@ templatizeTy t = t -- | Helper function to create the binder for the 'str' template. binderForStrOrPrn :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> String -> Either TypeError ((String, Binder), [XObj]) -binderForStrOrPrn typeEnv env insidePath structTy@(StructTy (ConcreteNameTy typeName) _) [XObj (Arr membersXObjs) _ _] strOrPrn = +binderForStrOrPrn typeEnv env insidePath structTy@(StructTy (ConcreteNameTy _) _) [XObj (Arr membersXObjs) _ _] strOrPrn = if isTypeGeneric structTy then Right (genericStr insidePath structTy membersXObjs strOrPrn, []) else @@ -433,18 +455,18 @@ binderForStrOrPrn typeEnv env insidePath structTy@(StructTy (ConcreteNameTy type (SymPath insidePath strOrPrn) (FuncTy [RefTy structTy (VarTy "q")] StringTy StaticLifetimeTy) (concreteStr typeEnv env structTy (memberXObjsToPairs membersXObjs) strOrPrn) - ("converts a `" ++ typeName ++ "` to a string.") + ("converts a `" ++ show structTy ++ "` to a string.") ) binderForStrOrPrn _ _ _ _ _ _ = error "binderforstrorprn" -- | The template for the 'str' function for a concrete deftype. concreteStr :: TypeEnv -> Env -> Ty -> [(String, Ty)] -> String -> Template -concreteStr typeEnv env concreteStructTy@(StructTy (ConcreteNameTy typeName) _) memberPairs _ = +concreteStr typeEnv env concreteStructTy@(StructTy (ConcreteNameTy name) _) memberPairs _ = Template (FuncTy [RefTy concreteStructTy (VarTy "q")] StringTy StaticLifetimeTy) (\(FuncTy [RefTy structTy _] StringTy _) -> toTemplate $ "String $NAME(" ++ tyToCLambdaFix structTy ++ " *p)") ( \(FuncTy [RefTy (StructTy _ _) _] StringTy _) -> - tokensForStr typeEnv env typeName memberPairs concreteStructTy + tokensForStr typeEnv env (show name) memberPairs concreteStructTy ) ( \(FuncTy [RefTy (StructTy _ _) (VarTy "q")] StringTy _) -> concatMap @@ -455,12 +477,12 @@ concreteStr _ _ _ _ _ = error "concretestr" -- | The template for the 'str' function for a generic deftype. genericStr :: [String] -> Ty -> [XObj] -> String -> (String, Binder) -genericStr pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membersXObjs strOrPrn = +genericStr pathStrings originalStructTy@(StructTy (ConcreteNameTy name) _) membersXObjs strOrPrn = defineTypeParameterizedTemplate templateCreator path t docs where path = SymPath pathStrings strOrPrn t = FuncTy [RefTy originalStructTy (VarTy "q")] StringTy StaticLifetimeTy - docs = "converts a `" ++ typeName ++ "` to a string." + docs = "converts a `" ++ show originalStructTy ++ "` to a string." templateCreator = TemplateCreator $ \typeEnv env -> Template @@ -472,7 +494,7 @@ genericStr pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) m let mappings = unifySignatures originalStructTy concreteStructTy correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs memberPairs = memberXObjsToPairs correctedMembers - in tokensForStr typeEnv env typeName memberPairs concreteStructTy + in tokensForStr typeEnv env (show name) memberPairs concreteStructTy ) ( \ft@(FuncTy [RefTy concreteStructTy@(StructTy _ _) _] StringTy _) -> let mappings = unifySignatures originalStructTy concreteStructTy @@ -509,8 +531,8 @@ tokensForStr typeEnv env typeName memberPairs concreteStructTy = -- | Figure out how big the string needed for the string representation of the struct has to be. calculateStructStrSize :: TypeEnv -> Env -> [(String, Ty)] -> Ty -> String -calculateStructStrSize typeEnv env members (StructTy (ConcreteNameTy name) _) = - " int size = snprintf(NULL, 0, \"(%s )\", \"" ++ name ++ "\");\n" +calculateStructStrSize typeEnv env members s@(StructTy (ConcreteNameTy _) _) = + " int size = snprintf(NULL, 0, \"(%s )\", \"" ++ show s ++ "\");\n" ++ unlines (map (memberPrnSize typeEnv env) members) calculateStructStrSize _ _ _ _ = error "calculatestructstrsize" @@ -525,7 +547,7 @@ memberAssignment allocationMode memberName = " instance" ++ sep ++ memberName -- | Helper function to create the binder for the 'delete' template. binderForDelete :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> Either TypeError ((String, Binder), [XObj]) -binderForDelete typeEnv env insidePath structTy@(StructTy (ConcreteNameTy typeName) _) [XObj (Arr membersXObjs) _ _] = +binderForDelete typeEnv env insidePath structTy@(StructTy (ConcreteNameTy _) _) [XObj (Arr membersXObjs) _ _] = if isTypeGeneric structTy then Right (genericDelete insidePath structTy membersXObjs, []) else @@ -534,18 +556,18 @@ binderForDelete typeEnv env insidePath structTy@(StructTy (ConcreteNameTy typeNa (SymPath insidePath "delete") (FuncTy [structTy] UnitTy StaticLifetimeTy) (concreteDelete typeEnv env (memberXObjsToPairs membersXObjs)) - ("deletes a `" ++ typeName ++ "`.") + ("deletes a `" ++ show structTy ++ "`.") ) binderForDelete _ _ _ _ _ = error "binderfordelete" -- | The template for the 'delete' function of a generic deftype. genericDelete :: [String] -> Ty -> [XObj] -> (String, Binder) -genericDelete pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membersXObjs = +genericDelete pathStrings originalStructTy@(StructTy (ConcreteNameTy _) _) membersXObjs = defineTypeParameterizedTemplate templateCreator path (FuncTy [originalStructTy] UnitTy StaticLifetimeTy) docs where path = SymPath pathStrings "delete" t = FuncTy [VarTy "p"] UnitTy StaticLifetimeTy - docs = "deletes a `" ++ typeName ++ "`. Should usually not be called manually." + docs = "deletes a `" ++ show originalStructTy ++ "`. Should usually not be called manually." templateCreator = TemplateCreator $ \typeEnv env -> Template @@ -578,7 +600,7 @@ genericDelete _ _ _ = error "genericdelete" -- | Helper function to create the binder for the 'copy' template. binderForCopy :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> Either TypeError ((String, Binder), [XObj]) -binderForCopy typeEnv env insidePath structTy@(StructTy (ConcreteNameTy typeName) _) [XObj (Arr membersXObjs) _ _] = +binderForCopy typeEnv env insidePath structTy@(StructTy (ConcreteNameTy _) _) [XObj (Arr membersXObjs) _ _] = if isTypeGeneric structTy then Right (genericCopy insidePath structTy membersXObjs, []) else @@ -587,18 +609,18 @@ binderForCopy typeEnv env insidePath structTy@(StructTy (ConcreteNameTy typeName (SymPath insidePath "copy") (FuncTy [RefTy structTy (VarTy "q")] structTy StaticLifetimeTy) (concreteCopy typeEnv env (memberXObjsToPairs membersXObjs)) - ("copies a `" ++ typeName ++ "`.") + ("copies a `" ++ show structTy ++ "`.") ) binderForCopy _ _ _ _ _ = error "binderforcopy" -- | The template for the 'copy' function of a generic deftype. genericCopy :: [String] -> Ty -> [XObj] -> (String, Binder) -genericCopy pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membersXObjs = +genericCopy pathStrings originalStructTy@(StructTy (ConcreteNameTy _) _) membersXObjs = defineTypeParameterizedTemplate templateCreator path (FuncTy [RefTy originalStructTy (VarTy "q")] originalStructTy StaticLifetimeTy) docs where path = SymPath pathStrings "copy" t = FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy - docs = "copies the `" ++ typeName ++ "`." + docs = "copies the `" ++ show originalStructTy ++ "`." templateCreator = TemplateCreator $ \typeEnv env -> Template diff --git a/src/Emit.hs b/src/Emit.hs index b18c71ac..618eb8fe 100644 --- a/src/Emit.hs +++ b/src/Emit.hs @@ -8,6 +8,7 @@ module Emit checkForUnresolvedSymbols, ToCMode (..), wrapInInitFunction, + typeEnvToDeclarations, ) where @@ -139,7 +140,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo x -> show (ord x) ++ "/*" ++ show x ++ "*/" -- ['U', '\'', x, '\''] Closure elt _ -> visit indent elt Sym _ _ -> visitSymbol indent xobj - Mod _ -> error (show (CannotEmitModKeyword xobj)) + Mod _ _ -> error (show (CannotEmitModKeyword xobj)) External _ -> error (show (CannotEmitExternal xobj)) (Defn _) -> dontVisit Def -> dontVisit @@ -258,7 +259,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo Just callback = name callbackMangled = pathToC callback needEnv = not (null capturedVars) - lambdaEnvTypeName = callbackMangled ++ "_env" -- The name of the struct is the callback name with suffix '_env'. + lambdaEnvTypeName = (SymPath [] (callbackMangled ++ "_ty")) -- The name of the struct is the callback name with suffix '_ty'. lambdaEnvType = StructTy (ConcreteNameTy lambdaEnvTypeName) [] lambdaEnvName = freshVar info ++ "_env" appendToSrc @@ -293,8 +294,8 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo appendToSrc (addIndent indent ++ "Lambda " ++ retVar ++ " = {\n") appendToSrc (addIndent indent ++ " .callback = (void*)" ++ callbackMangled ++ ",\n") appendToSrc (addIndent indent ++ " .env = " ++ (if needEnv then lambdaEnvName else "NULL") ++ ",\n") - appendToSrc (addIndent indent ++ " .delete = (void*)" ++ (if needEnv then "" ++ lambdaEnvTypeName ++ "_delete" else "NULL") ++ ",\n") - appendToSrc (addIndent indent ++ " .copy = (void*)" ++ (if needEnv then "" ++ lambdaEnvTypeName ++ "_copy" else "NULL") ++ "\n") + appendToSrc (addIndent indent ++ " .delete = (void*)" ++ (if needEnv then "" ++ show lambdaEnvTypeName ++ "_delete" else "NULL") ++ ",\n") + appendToSrc (addIndent indent ++ " .copy = (void*)" ++ (if needEnv then "" ++ show lambdaEnvTypeName ++ "_copy" else "NULL") ++ "\n") appendToSrc (addIndent indent ++ "};\n") pure retVar -- Def @@ -661,8 +662,8 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo else tyToCLambdaFix retTy ++ "(*)(" ++ joinWithComma (map tyToCLambdaFix voidless) ++ ")" castToFnWithEnv = if unwrapLambdas - then tyToCLambdaFix retTy ++ "(*)(" ++ joinWithComma (map tyToCRawFunctionPtrFix (StructTy (ConcreteNameTy "LambdaEnv") [] : voidless)) ++ ")" - else tyToCLambdaFix retTy ++ "(*)(" ++ joinWithComma (map tyToCLambdaFix (StructTy (ConcreteNameTy "LambdaEnv") [] : voidless)) ++ ")" + then tyToCLambdaFix retTy ++ "(*)(" ++ joinWithComma (map tyToCRawFunctionPtrFix (StructTy (ConcreteNameTy (SymPath [] "LambdaEnv")) [] : voidless)) ++ ")" + else tyToCLambdaFix retTy ++ "(*)(" ++ joinWithComma (map tyToCLambdaFix (StructTy (ConcreteNameTy (SymPath [] "LambdaEnv")) [] : voidless)) ++ ")" callLambda = funcToCall ++ ".env ? ((" ++ castToFnWithEnv ++ ")" ++ funcToCall ++ ".callback)" ++ "(" ++ funcToCall ++ ".env" ++ (if null argListAsC then "" else ", ") ++ argListAsC ++ ") : ((" ++ castToFn ++ ")" ++ funcToCall ++ ".callback)(" ++ argListAsC ++ ");\n" if isUnit retTy then do @@ -703,7 +704,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo do let arrayVar = freshVar i len = length xobjs - Just (StructTy (ConcreteNameTy "Array") [innerTy]) = t + Just (StructTy (ConcreteNameTy (SymPath [] "Array")) [innerTy]) = t appendToSrc ( addIndent indent ++ "Array " ++ arrayVar ++ " = { .len = " @@ -744,7 +745,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo retVar = arrayVar ++ "_retref" arrayDataVar = arrayVar ++ "_data" len = length xobjs - Just tt@(RefTy (StructTy (ConcreteNameTy "StaticArray") [innerTy]) _) = t + Just tt@(RefTy (StructTy (ConcreteNameTy (SymPath [] "StaticArray")) [innerTy]) _) = t appendToSrc (addIndent indent ++ tyToCLambdaFix innerTy ++ " " ++ arrayDataVar ++ "[" ++ show len ++ "];\n") appendToSrc ( addIndent indent ++ "Array " ++ arrayVar @@ -960,7 +961,7 @@ binderToC toCMode binder = XObj (External _) _ _ -> Right "" XObj (ExternalType _) _ _ -> Right "" XObj (Command _) _ _ -> Right "" - XObj (Mod env) _ _ -> envToC env toCMode + XObj (Mod env _) _ _ -> envToC env toCMode _ -> case xobjTy xobj of Just t -> if isTypeGeneric t @@ -974,16 +975,16 @@ binderToDeclaration :: TypeEnv -> Binder -> Either ToCError String binderToDeclaration typeEnv binder = let xobj = binderXObj binder in case xobj of - XObj (Mod env) _ _ -> envToDeclarations typeEnv env + XObj (Mod env _) _ _ -> envToDeclarations typeEnv env _ -> case xobjTy xobj of Just t -> if isTypeGeneric t then Right "" else Right (toDeclaration binder ++ "") Nothing -> Left (BinderIsMissingType binder) envToC :: Env -> ToCMode -> Either ToCError String envToC env toCMode = - let binders = Map.toList (envBindings env) + let binders' = Map.toList (envBindings env) in do - okCodes <- mapM (binderToC toCMode . snd) binders + okCodes <- mapM (binderToC toCMode . snd) binders' pure (concat okCodes) globalsToC :: Env -> Either ToCError String @@ -1000,6 +1001,34 @@ globalsToC globalEnv = (sortGlobalVariableBinders globalEnv allGlobalBinders) pure (concat okCodes) +-- | Similar to envToDeclarations, however, to get types, we need to traverse +-- the global environment, pull out local type envs from modules, then emit +-- binders for these types. +-- +-- TODO: It should be possible to define a general function that works for both +-- value/type envs, then we can merge this and envToDeclarations +typeEnvToDeclarations :: TypeEnv -> Env -> Either ToCError String +typeEnvToDeclarations typeEnv global = + let -- We need to carry the type environment to pass the correct environment on the binderToDeclaration call. + addEnvToScore tyE = (sortDeclarationBinders tyE (map snd (Map.toList (binders tyE)))) + bindersWithScore = (addEnvToScore typeEnv) + mods = (findModules global) + folder = + ( \sorted (XObj (Mod e t) _ _) -> + sorted ++ (foldl folder (addEnvToScore t) (findModules e)) + ) + allScoredBinders = sortOn fst (foldl folder bindersWithScore mods) + in do + okDecls <- + mapM + ( \(score, binder) -> + fmap + (\s -> if s == "" then "" else ("\n// Depth " ++ show score ++ "\n") ++ s) + (binderToDeclaration typeEnv binder) + ) + allScoredBinders + pure (concat okDecls) + envToDeclarations :: TypeEnv -> Env -> Either ToCError String envToDeclarations typeEnv env = let bindersWithScore = sortDeclarationBinders typeEnv (map snd (Map.toList (envBindings env))) @@ -1018,13 +1047,13 @@ envToDeclarations typeEnv env = -- debugScorePair (s,b) = trace ("Scored binder: " ++ show b ++ ", score: " ++ show s) (s,b) sortDeclarationBinders :: TypeEnv -> [Binder] -> [(Int, Binder)] -sortDeclarationBinders typeEnv binders = +sortDeclarationBinders typeEnv binders' = --trace ("\nSORTED: " ++ (show (sortOn fst (map (scoreBinder typeEnv) binders)))) - sortOn fst (map (scoreTypeBinder typeEnv) binders) + sortOn fst (map (scoreTypeBinder typeEnv) binders') sortGlobalVariableBinders :: Env -> [Binder] -> [(Int, Binder)] -sortGlobalVariableBinders globalEnv binders = - sortOn fst (map (scoreValueBinder globalEnv Set.empty) binders) +sortGlobalVariableBinders globalEnv binders' = + sortOn fst (map (scoreValueBinder globalEnv Set.empty) binders') checkForUnresolvedSymbols :: XObj -> Either ToCError () checkForUnresolvedSymbols = visit diff --git a/src/Env.hs b/src/Env.hs index cb62ce00..8ce7f201 100644 --- a/src/Env.hs +++ b/src/Env.hs @@ -1,109 +1,659 @@ -module Env where +{-# LANGUAGE TupleSections #-} -import Data.List (foldl') +module Env + ( EnvironmentError, + Environment (..), + Mode (..), + -- utils + empty, + new, + parent, + setParent, + nested, + recursive, + binders, + ------------------------ + -- lookups + getType, + getTypeBinder, + findType, + findTypeBinder, + searchType, + searchTypeBinder, + getValue, + getValueBinder, + findValue, + findValueBinder, + searchValue, + searchValueBinder, + ------------------------- + -- Environment getters + getInnerEnv, + contextEnv, + envIsExternal, + envPublicBindingNames, + ------------------------- + -- mutation + insert, + insertX, + replace, + addBinding, + deleteBinding, + addListOfBindings, + addUsePath, + ------------------------- + -- finds + findPoly, + findAllByMeta, + findChildren, + findImplementations, + findAllGlobalVariables, + findModules, + allImportedEnvs, + ------------------------- + -- lookups + lookupContextually, + lookupMeta, + lookupChildren, + lookupInUsed, + lookupEverywhere, + lookupBinderEverywhere, + progenitor, + replaceInPlace, + ) +where + +import Data.Either (fromRight, rights) +import Data.List (foldl', unfoldr) import Data.Maybe (fromMaybe) import qualified Map +import qualified Meta import Obj +import qualified Set 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) +-------------------------------------------------------------------------------- +-- Data --- | 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) +data EnvironmentError + = NoEnvInNonModule + | NoReplaceInNonModule + | BindingNotFound String Env + | NoMatchingBindingFound String + | NestedTypeError String -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) +instance Show EnvironmentError where + show NoEnvInNonModule = "Can't get an environment from a non-module." + show NoReplaceInNonModule = "Can't replace an environment in a non-module." + show (BindingNotFound name e) = "Failed to find " ++ name ++ "in the given environment: " ++ show e + show (NoMatchingBindingFound predicate) = "Couldn't find any bindings with " ++ predicate ++ "in the given environment." + show (NestedTypeError name) = + "Couldn't insert the top-level type " ++ name + ++ " in a module environment." --- | Add a Binder to a specific environment. -envAddBinding :: Env -> String -> Binder -> Env -envAddBinding env name binder = env {envBindings = Map.insert name binder (envBindings env)} +data Mode = Types | Values -{-# ANN addListOfBindings "HLint: ignore Eta reduce" #-} +-------------------------------------------------------------------------------- +-- The Environment class and implementations --- | 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 +-- | Class for generically handling type and value environments. +class Environment e where + inj :: Env -> e + prj :: e -> Env + update :: e -> Binder -> Either EnvironmentError Binder + modality :: e -> Mode --- | 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." +-- | The value environment +instance Environment Env where + inj = id + prj = id + update e (Binder meta (XObj (Mod _ et) i t)) = Right (Binder meta (XObj (Mod e et) i t)) + update _ _ = Left NoReplaceInNonModule + modality _ = Values -contextEnv :: Context -> Env -contextEnv Context {contextInternalEnv = Just e} = e -contextEnv Context {contextGlobalEnv = e, contextPath = p} = getEnv e p +-- | The type environment +instance Environment TypeEnv where + inj = TypeEnv + prj = getTypeEnv + update e (Binder meta (XObj (Mod ev _) i t)) = Right (Binder meta (XObj (Mod ev e) i t)) + update _ _ = Left NoReplaceInNonModule + modality _ = Types --- | 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 +-------------------------------------------------------------------------------- +-- Misc. Environment utilities + +-- | Returns an unnamed empty environment with no parent. +empty :: Environment e => e +empty = inj $ Env (Map.fromList []) Nothing Nothing Set.empty ExternalEnv 0 + +-- | Returns a new environment with a given parent and name. +new :: Environment e => Maybe e -> Maybe String -> e +new p name = + let e' = Env (Map.fromList []) (fmap prj p) name Set.empty ExternalEnv 0 + in inj e' + +-- | Returns a new environment with a designated nesting level. +nested :: Environment e => Maybe e -> Maybe String -> Int -> e +nested p name lvl = inj ((prj (new p name)) {envMode = InternalEnv, envFunctionNestingLevel = lvl}) + +-- | Returns a new recursive environment with a designated nesting level. +recursive :: Environment e => Maybe e -> Maybe String -> Int -> e +recursive p name lvl = inj ((prj (new p name)) {envMode = RecursionEnv, envFunctionNestingLevel = lvl}) + +-- | Returns the binders stored in an environment. +binders :: Environment e => e -> Map.Map String Binder +binders = envBindings . prj + +-- | Get the parent of an environment. +parent :: Environment e => e -> Maybe e +parent = fmap inj . envParent . prj + +-- | Set the parent of an environment. +setParent :: Environment e => e -> e -> e +setParent e p = inj ((prj e) {envParent = Just (prj p)}) + +-- | Get an environment stored in a module binder. +nextEnv :: Mode -> Binder -> Either EnvironmentError Env +nextEnv Types (Binder _ (XObj (Mod _ et) _ _)) = Right $ prj et +nextEnv Values (Binder _ (XObj (Mod ev _) _ _)) = Right $ prj ev +nextEnv _ _ = Left NoEnvInNonModule + +-- | Replace an environment stored in a module binder. +updateEnv :: Mode -> Env -> Binder -> Either EnvironmentError Binder +updateEnv Values e (Binder meta (XObj (Mod _ et) i t)) = Right (Binder meta (XObj (Mod e et) i t)) +updateEnv Types e (Binder meta (XObj (Mod ev _) i t)) = Right (Binder meta (XObj (Mod ev (TypeEnv e)) i t)) +updateEnv _ _ _ = Left NoEnvInNonModule + +-------------------------------------------------------------------------------- +-- Environment traversal +-- +-- Naming conventions: +-- +-- get: Direct lookup. Try to get the designated binder directly from an +-- environment, without traversing into parents or children. If not found, +-- fail. +-- +-- find: Preorder lookup. Try to get the designated binder by proceeding from +-- the root environment down to its children. If not found in a child, fail. +-- +-- search: pre and post order lookup: Try to get the designated binder by +-- proceeding from the root to children. If not found, try to find the binder +-- by proceeding from the root's parent, if it exists, to its children. If +-- not found, fail. + +-- | Walk down an environment chain. +walk' :: Mode -> Env -> SymPath -> Either EnvironmentError Env +walk' _ e (SymPath [] _) = pure e +walk' mode' e (SymPath (p : ps) name) = + do + (_, binder) <- get e p + go (SymPath ps name) binder + where + go :: SymPath -> Binder -> Either EnvironmentError Env + go (SymPath [] _) binder = nextEnv mode' binder + go path binder = + do + env <- nextEnv Values binder + walk' mode' env path + +-- | Generic *unidirectional* retrieval of binders (does not check parents). +walkAndGet :: Environment e => e -> SymPath -> (Either EnvironmentError e, Either EnvironmentError Binder) +walkAndGet e path@(SymPath _ name) = + let target = walk' (modality e) (prj e) path + binder = target >>= \t -> get t name + in (fmap inj target, fmap snd binder) + +-- | Direct lookup for a binder in environment `e`. +-- The environment returned in the output will be the same as that given as input. +-- +-- Returns an error if not found. +get :: Environment e => e -> String -> Either EnvironmentError (e, Binder) +get e name = + case Map.lookup name (binders e) of + Nothing -> Left $ BindingNotFound name (prj e) + Just b -> Right (e, b) + +-- | Same as `get` but only returns a binder. +getBinder :: Environment e => e -> String -> Either EnvironmentError Binder +getBinder e name = fmap snd (get e name) + +-- | Generic unidirectional retrieval of binders. +-- Searches the children of `e` using a given path, stopping at the terminus. +-- +-- Returns an error if not found. +find' :: Environment e => e -> SymPath -> Either EnvironmentError (e, Binder) +find' e path = + case walkAndGet e path of + (Right e', Right b) -> Right (e', b) + (Left err, _) -> Left err + (_, Left err) -> Left err + +-- | Same as `find` but only returns a binder. +findBinder :: Environment e => e -> SymPath -> Either EnvironmentError Binder +findBinder e path = fmap snd (find' e path) + +-- | Generic *multidirectional* retrieval of binders. +-- Searches the children and parents of `e` (or the parent of a sub-environment +-- found in `e` and given by `path`). +-- +-- Returns an error if not found. +search :: Environment e => e -> SymPath -> Either EnvironmentError (e, Binder) +search e path = + case walkAndGet e path of + (Right e', Right b) -> Right (e', b) + (Right e', Left err) -> (checkParent e' err) + (Left err, Left _) -> (checkParent e err) <> Left err + -- impossible case. Included to keep `walk` honest. + (Left _, Right _) -> error "impossible" + where + checkParent env err = maybe (Left err) (`search` path) (parent env) + +-- | Same as `search` but only returns a binder. +searchBinder :: Environment e => e -> SymPath -> Either EnvironmentError Binder +searchBinder e path = fmap snd (search e path) + +-------------------------------------------------------------------------------- +-- Specialized retrievals +-- +-- These functions are all equivalent to the generic retrieval functions +-- defined above but they enforce further restrictions at type level. Thus, +-- they can be used to help enforce constraints at call sites. +-- +-- For example, suppose we want to search for a binder that may name a type + +-- * or* module, preferring types. One could cast to enforce a type search + +-- starting from the global env: +-- +-- search typeEnv path +-- <> search (TypeEnv global) path +-- <> search global path +-- +-- But: +-- +-- searchType typeEnv path +-- searchType global path +-- <> searchValue global path +-- +-- Is arguably much clearer. + +-------------------------------------------------------------------------------- +-- Type retrievals + +-- | Get a type from a type environment. +getType :: TypeEnv -> String -> Either EnvironmentError (TypeEnv, Binder) +getType = get + +-- | Get a type binder from a type environment. +getTypeBinder :: TypeEnv -> String -> Either EnvironmentError Binder +getTypeBinder = getBinder + +-- | Unidirectional binder retrieval specialized to types. +-- +-- Restricts the final step of a search to binders in a module's *type* environment. +findType :: Environment e => e -> SymPath -> Either EnvironmentError (TypeEnv, Binder) +findType e path = find' (inj (prj e)) path + +findTypeBinder :: Environment e => e -> SymPath -> Either EnvironmentError Binder +findTypeBinder e path = fmap snd (findType e path) + +-- | Multidirectional binder retrieval specialized to types. +-- +-- Restricts the final step of a search to binders in a module's *type* environment. +searchType :: Environment e => e -> SymPath -> Either EnvironmentError (TypeEnv, Binder) +searchType e path = search (inj (prj e)) path + +searchTypeBinder :: Environment e => e -> SymPath -> Either EnvironmentError Binder +searchTypeBinder e path = fmap snd (searchType e path) + +-------------------------------------------------------------------------------- +-- Value retrievals + +-- | Get a value from a value environment. +getValue :: Env -> String -> Either EnvironmentError (Env, Binder) +getValue = get + +getValueBinder :: Env -> String -> Either EnvironmentError Binder +getValueBinder = getBinder + +-- | Unidirectional binder retrieval specialized to values. +findValue :: Env -> SymPath -> Either EnvironmentError (Env, Binder) +findValue = find' + +findValueBinder :: Env -> SymPath -> Either EnvironmentError Binder +findValueBinder = findBinder + +-- | Multidirectional binder retrieval specialized to values. +searchValue :: Env -> SymPath -> Either EnvironmentError (Env, Binder) +searchValue = search + +searchValueBinder :: Env -> SymPath -> Either EnvironmentError Binder +searchValueBinder = searchBinder + +-------------------------------------------------------------------------------- +-- Environment mutation + +-------------------------------------------------------------------------------- +-- Mutation primitives + +-- N.B. The following functions returns an Either for compatibility with other +-- functions in this module. It is a constant function in the co-domain of +-- Either, as they always returns Right. + +-- | Add a new binding to an environment. +addBinding :: Environment e => e -> String -> Binder -> Either EnvironmentError e +addBinding e name b = pure (inj ((prj e) {envBindings = Map.insert name b (binders e)})) + +-- | Replace the value of a binding in an environment, but only if it already +-- exists. +replaceBinding :: Environment e => e -> String -> Binder -> Either EnvironmentError e +replaceBinding e name b = + pure (inj ((prj e) {envBindings = Map.adjust (const b) name (binders e)})) + +-- | Delete a binding in an environment. +deleteBinding :: Environment e => e -> String -> Either EnvironmentError e +deleteBinding e name = pure (inj ((prj e) {envBindings = Map.delete name (binders e)})) + +-------------------------------------------------------------------------------- +-- Generic environment mutation + +type EnvironmentProducer e = (e -> String -> Binder -> Either EnvironmentError e) + +-- | Given an environment and a complete identifier path, traverse a chain of +-- environments until the path is exhausted, if requested, mutating the +-- environments along the way: +mutate :: Environment e => (EnvironmentProducer e) -> e -> SymPath -> Binder -> Either EnvironmentError e +mutate f e path binder = go path + where + go (SymPath [] name) = f e name binder + go (SymPath (p : ps) name) = + getBinder e p + >>= \modu -> + nextEnv (modality e) modu + >>= \oldEnv -> + mutate f (inj oldEnv) (SymPath ps name) binder + >>= \result -> + updateEnv (modality e) (prj result) modu + >>= addBinding e p + +-- | Insert a binding into an environment at the given path. +insert :: Environment e => e -> SymPath -> Binder -> Either EnvironmentError e +insert = mutate addBinding + +-- | Insert an XObj into an environment at the specified path. +-- This function does not perform insertions into parents. +insertX :: Environment e => e -> SymPath -> XObj -> Either EnvironmentError e +insertX e path x = insert e path (toBinder x) + +-- | Replace a binding at the given path in an environment. +replace :: Environment e => e -> SymPath -> Binder -> Either EnvironmentError e +replace = mutate replaceBinding + +-- | Replaces a binding "in-place" in an environment chain. +-- +-- This function *only* considers members of an environment chain, that is, +-- it's limited to the given input environment and all of its ancestors (it's +-- parent and the parent of its parent all the way up). +-- +-- It does not look in any "external" environments (used environments or +-- "children" (environments stored in module bindings)). +replaceInPlace :: Environment e => e -> String -> Binder -> Either EnvironmentError e +replaceInPlace e name b = + (get e name >>= \_ -> addBinding e name b) + <> case parent e of + Just p -> replaceInPlace p name b >>= \p' -> pure (inj ((prj e) {envParent = Just (prj p')})) + Nothing -> Left (BindingNotFound name (prj e)) + +-- | Add a list of bindings to an environment. +addListOfBindings :: Environment e => e -> [(String, Binder)] -> e +addListOfBindings e bindings = + foldl' (\e' (n, b) -> fromRight e (addBinding e' n b)) e bindings + +-- | Add a module path to an environment's list of used modules. +addUsePath :: Environment e => e -> SymPath -> e +addUsePath e path = inj ((prj e) {envUseModules = Set.insert path (envUseModules (prj e))}) + +-------------------------------------------------------------------------------- +-- Additional binding lookup functions +-- +-- find* functions perform lookup in a single environment, without recursion. +-- lookup* functions perform lookups in an environment chain, with recursion. + +-- | Get the metadata associated with the binder at the specified path in an environment. +lookupMeta :: Environment e => e -> SymPath -> Either EnvironmentError MetaData +lookupMeta e path = searchBinder e path >>= pure . Meta.fromBinder + +-- | Find all binders in an environment that have a specified meta key. +findAllByMeta :: Environment e => e -> String -> Either EnvironmentError [Binder] +findAllByMeta e metaKey = + let candidates = Map.elems (Map.filter (Meta.binderMember metaKey) (binders e)) + in case candidates of + [] -> Left (NoMatchingBindingFound ("metadata " ++ metaKey)) + _ -> Right $ candidates + +-- | Find all modules directly stored in environment `e`. +findModules :: Environment e => e -> [XObj] +findModules e = + map binderXObj (filter modsOnly (Map.elems (binders e))) + where + modsOnly :: Binder -> Bool + modsOnly binder = + case binderXObj binder of + XObj (Mod _ _) _ _ -> True + _ -> False + +-- | It's more efficient to specialize this function as it can take advantage +-- of laziness; once we found the candidate function for a polymorphic +-- function, there's no need to consume the rest of the environment. +findPoly :: Environment e => e -> String -> Ty -> Either EnvironmentError (e, Binder) +findPoly env name ty = + case getBinder env name of + Right b -> + if unify b + then Right (env, b) + else (foldl' go (Left (BindingNotFound name (prj env))) (findChildren env)) + Left _ -> foldl' go (Left (BindingNotFound name (prj env))) (findChildren env) + where + go x e = x <> (findPoly e name ty) + unify = areUnifiable ty . fromMaybe Universe . xobjTy . binderXObj + +-- | Find all environments that are *direct* children of an environment (one +-- level down). +-- +-- The modality of the children is determined by the modality of the root. +-- +-- N.B. Don't use find here. We access binders directly, so there's no need to +-- perform additional O(n) lookup calls. +findChildren :: Environment e => e -> [e] +findChildren e = + foldl' getEnv [] (binders e) + where + getEnv acc binder = + case (nextEnv (modality e) binder) of + Left _ -> acc + Right e' -> ((inj e') : acc) + +-- | Find all the environments contained in the modules initial environment, +-- plus any module environments contained in *those* modules. +lookupChildren :: Environment e => e -> [e] +lookupChildren e = + foldl' go [] (findChildren e) + where + go acc e' = case findChildren e' of + [] -> (e' : acc) + xs -> (foldl' go [] xs ++ acc) + +-- | Find all the environments designated by the use paths in an environment. +findImportedEnvs :: Environment e => e -> [e] +findImportedEnvs e = + let eMode = modality e + usePaths = Set.toList (envUseModules (prj e)) + getter path = + walk' eMode (prj e) path + >>= \e' -> + get e' (getName' path) + >>= nextEnv eMode . snd + >>= pure . inj + used = fmap getter usePaths + in (rights used) + where + getName' (SymPath _ name) = name + +-- | Given an environment, get its topmost parent up the environment chain. +-- +-- For nearly all environments, this should be the global environment. +progenitor :: Environment e => e -> e +progenitor e = fromMaybe e (parent e >>= \p -> pure (progenitor p)) + +-- | Find all possible environments imported at some point *upwards* from e in a chain of environments. +allImportedEnvs :: Environment e => e -> Env -> [e] +allImportedEnvs e global = + let env = prj e + paths = (Set.toList (foldl' og (envUseModules env) (unfoldr go env))) + in (rights (map get' paths)) + where + go e' = parent e' >>= \p -> pure (p, p) + og acc e' = (envUseModules e') <> acc + get' path = + findBinder global path + >>= nextEnv (modality e) + >>= pure . inj + +-- | Find all binders the implement a given interface, designated by its path. +findImplementations :: Environment e => e -> SymPath -> Either EnvironmentError [Binder] +findImplementations e interface = + ( (findAllByMeta e "implements") + >>= \is -> (pure (filter (isImpl . Meta.fromBinder) is)) + ) + <> Left (NoMatchingBindingFound ("implementation meta for " ++ show interface)) + where + isImpl :: MetaData -> Bool + isImpl meta = + case Meta.get "implements" meta of + Just (XObj (Lst interfaces) _ _) -> interface `elem` map getPath interfaces + _ -> False + +-- | Searches for binders exhaustively in the given environment, a list of +-- child environments it contains derived using a function and its parent, if +-- it has one. +-- +-- The parent environment, when it exists, is also searched exhaustively +-- (derived children of the parent are searched, as well as the parent of the +-- parent, should it exist). +lookupExhuastive :: Environment e => (e -> [e]) -> e -> String -> [(e, Binder)] +lookupExhuastive f e name = + let envs = [e] ++ (f e) + in (go (parent e) envs) + where + go _ [] = [] + go Nothing xs = foldl' accum [] xs + go (Just p) xs = go (parent p) (xs ++ [p] ++ (f p)) + accum acc e' = case getBinder e' name of + Right b -> ((e', b) : acc) + _ -> acc + +lookupBinderExhuastive :: Environment e => (e -> [e]) -> e -> String -> [Binder] +lookupBinderExhuastive f e name = fmap snd (lookupExhuastive f e name) + +lookupEverywhere :: Environment e => e -> String -> [(e, Binder)] +lookupEverywhere = lookupExhuastive lookupChildren + +lookupInImports :: Environment e => e -> String -> [(e, Binder)] +lookupInImports = lookupExhuastive findImportedEnvs + +lookupInUsed :: Environment e => e -> Env -> SymPath -> [(e, Binder)] +lookupInUsed e global spath = + foldl' go [] (allImportedEnvs e global) + where + go :: Environment e => [(e, Binder)] -> e -> [(e, Binder)] + go acc e' = case (search e' spath) of + Right (e'', b) -> ((e'', b) : acc) + _ -> acc + +-- | Lookup a binder in *all* possible environments in the chain of an initial +-- environment (parents and children, including Use modules). +lookupBinderEverywhere :: Environment e => e -> String -> [Binder] +lookupBinderEverywhere = lookupBinderExhuastive lookupChildren + +lookupContextually :: Environment e => e -> SymPath -> Either EnvironmentError [(e, Binder)] +lookupContextually e (SymPath [] name) = + case lookupInImports e name of + [] -> Left (BindingNotFound name (prj e)) + xs -> Right xs +lookupContextually e path@(SymPath (p : ps) name) = + lookupDirectly <> lookupInUsedAndParent + where + lookupDirectly = + (getBinder e p) + >>= nextEnv (modality e) + >>= \e' -> + search (inj e') (SymPath ps name) + >>= pure . (: []) + lookupInUsedAndParent = case rights (fmap ((flip search) path) (findImportedEnvs e)) of + [] -> Left (BindingNotFound name (prj e)) + xs -> + case parent e of + Nothing -> Right xs + Just e' -> (Env.search e' path >>= \found -> Right $ xs ++ [found]) <> Right xs + +-------------------------------------------------------------------------------- +-- Environment retrieval functions + +-- | Get the environment at a given path that corresponds to the type of an +-- initial environment. +-- +-- Returns the initial environment when given an empty path. +getInnerEnv :: Environment e => e -> [String] -> Either EnvironmentError e +getInnerEnv e [] = Right e +getInnerEnv e (p : ps) = + (getBinder e p) + >>= nextEnv (modality e) + >>= \moduleEnv -> getInnerEnv (inj moduleEnv) ps + +-- | Get a context's internal environment if it exists, otherwise get the +-- innermost module's value environment based on the context path. +contextEnv :: Environment e => Context -> e +contextEnv Context {contextInternalEnv = Just e} = inj e +contextEnv Context {contextGlobalEnv = e, contextPath = p} = inj (fromRight e (getInnerEnv e p)) + +-------------------------------------------------------------------------------- +-- Utility functions + +-- | Checks if an environment is "external", meaning it's either the global +-- scope or a module scope. +envIsExternal :: Environment e => e -> Bool +envIsExternal e = + case envMode (prj e) 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 s@(SymPath (p : ps) name) binder env = - case Map.lookup p (envBindings env) of - Just b@(Binder _ (XObj (Mod innerEnv) i t)) -> - envReplaceBinding (SymPath [] p) b {binderXObj = (XObj (Mod (envReplaceBinding (SymPath ps name) binder innerEnv)) i t)} env - _ -> - fromMaybe env (envParent env >>= \parent -> Just (env {envParent = Just (envReplaceBinding s binder parent)})) +-------------------------------------------------------------------------------- +-- Binding Utilities -envBindingNames :: Env -> [String] -envBindingNames = concatMap select . envBindings +-- | Get a list of all the names of bindings in an environment that aren't +-- hidden or private. +envPublicBindingNames :: Environment e => e -> [String] +envPublicBindingNames e = concatMap select (Map.toList (binders e)) where - select :: Binder -> [String] - select (Binder _ (XObj (Mod m) _ _)) = envBindingNames m - select (Binder _ obj) = [getName obj] - -envPublicBindingNames :: Env -> [String] -envPublicBindingNames = concatMap select . envBindings - where - select :: Binder -> [String] - select (Binder _ (XObj (Mod m) _ _)) = envPublicBindingNames m - select (Binder meta obj) = - if metaIsTrue meta "private" || metaIsTrue meta "hidden" - then [] - else [getName obj] + select :: (String, Binder) -> [String] + select (name, binder) = + case (nextEnv (modality e) binder) of + Left _ -> + if metaIsTrue (binderMeta binder) "private" || metaIsTrue (binderMeta binder) "hidden" + then [] + else [name] + Right e' -> envPublicBindingNames e' -- | Recursively look through all environments for (def ...) forms. +-- +-- N.B. Don't use find here. We access binders directly, so there's no need to +-- perform additional O(n) lookup calls. findAllGlobalVariables :: Env -> [Binder] -findAllGlobalVariables env = - concatMap finder (envBindings env) +findAllGlobalVariables e = + foldl' finder [] (Map.elems (binders e)) where - finder :: Binder -> [Binder] - finder def@(Binder _ (XObj (Lst (XObj Def _ _ : _)) _ _)) = - [def] - finder (Binder _ (XObj (Mod innerEnv) _ _)) = - findAllGlobalVariables innerEnv - finder _ = - [] + finder :: [Binder] -> Binder -> [Binder] + finder acc (Binder _ (XObj (Mod ev _) _ _)) = acc ++ (findAllGlobalVariables (inj ev)) + finder acc def@(Binder _ (XObj (Lst (XObj Def _ _ : _)) _ _)) = (def : acc) + finder acc _ = acc diff --git a/src/Eval.hs b/src/Eval.hs index 7f4140d2..a5c11e97 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -8,17 +8,17 @@ import Context import Control.Applicative import Control.Exception import Control.Monad.State +import Data.Either (fromRight) import Data.Foldable (foldlM, foldrM) import Data.List (foldl', intercalate, isSuffixOf) import Data.List.Split (splitOn, splitWhen) import Data.Maybe (fromJust, fromMaybe, isJust) import Emit -import Env +import qualified Env as E import EvalError import Expand import Infer import Info -import Lookup import qualified Map import qualified Meta import Obj @@ -81,9 +81,10 @@ eval ctx xobj@(XObj o info ty) preference resolver = then pure (ctx, Left (HasStaticCall xobj info)) else pure v checkStatic v = pure v + -- all else failed, error. unwrapLookup = fromMaybe - (throwErr (SymbolNotFound spath) ctx info) -- all else failed, error. + (throwErr (SymbolNotFound spath) ctx info) tryAllLookups = ( case preference of PreferDynamic -> tryDynamicLookup @@ -91,19 +92,25 @@ eval ctx xobj@(XObj o info ty) preference resolver = ) <|> (if null p then tryInternalLookup spath else tryLookup spath) tryDynamicLookup = - lookupBinder (SymPath ("Dynamic" : p) n) (contextGlobalEnv ctx) - >>= \(Binder _ found) -> pure (ctx, Right (resolveDef found)) - tryInternalLookup path = - ( contextInternalEnv ctx - >>= lookupBinder path + ( maybeId (E.searchValueBinder (contextGlobalEnv ctx) (SymPath ("Dynamic" : p) n)) >>= \(Binder _ found) -> pure (ctx, Right (resolveDef found)) ) + tryInternalLookup path = + --trace ("Looking for internally " ++ show path) -- ++ show (fmap (fmap E.binders . E.parent) (contextInternalEnv ctx))) + ( contextInternalEnv ctx + >>= \e -> + maybeId (E.searchValueBinder e path) + >>= \(Binder _ found) -> pure (ctx, Right (resolveDef found)) + ) <|> tryLookup path -- fallback tryLookup path = - ( lookupBinder path (contextGlobalEnv ctx) + ( maybeId (E.searchValueBinder (contextGlobalEnv ctx) path) >>= \(Binder meta found) -> checkPrivate meta found ) - <|> ( lookupBinder path (getTypeEnv (contextTypeEnv ctx)) + <|> ( maybeId (E.searchValueBinder (contextGlobalEnv ctx) (SymPath ((contextPath ctx) ++ p) n)) + >>= \(Binder meta found) -> checkPrivate meta found + ) + <|> ( maybeId (lookupBinderInTypeEnv ctx path) >>= \(Binder _ found) -> pure (ctx, Right (resolveDef found)) ) <|> ( foldl @@ -111,7 +118,7 @@ eval ctx xobj@(XObj o info ty) preference resolver = Nothing ( map ( \(SymPath p' n') -> - lookupBinder (SymPath (p' ++ (n' : p)) n) (contextGlobalEnv ctx) + maybeId (E.searchValueBinder (contextGlobalEnv ctx) (SymPath (p' ++ (n' : p)) n)) >>= \(Binder meta found) -> checkPrivate meta found ) (Set.toList (envUseModules (contextGlobalEnv ctx))) @@ -220,7 +227,7 @@ eval ctx xobj@(XObj o info ty) preference resolver = (newCtx, res) <- eval ctx' x preference resolver case res of Right okX -> - pure $ Right (bindLetDeclaration newCtx n okX) + pure $ Right (fromRight (error "Failed to eval let binding!!") (bindLetDeclaration newCtx n okX)) Left err -> pure $ Left err [f@(XObj Fn {} _ _), args@(XObj (Arr a) _ _), body] -> do (newCtx, expanded) <- macroExpand ctx body @@ -446,7 +453,7 @@ macroExpand ctx xobj = apply :: Context -> XObj -> [XObj] -> [XObj] -> IO (Context, Either EvalError XObj) apply ctx@Context {contextInternalEnv = internal} body params args = - let Just env = contextInternalEnv ctx <|> innermostModuleEnv ctx <|> Just (contextGlobalEnv ctx) + let Just env = contextInternalEnv ctx <|> maybeId (innermostModuleEnv ctx) <|> Just (contextGlobalEnv ctx) allParams = map getName params in case splitWhen (":rest" ==) allParams of [a, b] -> callWith env a b @@ -459,18 +466,21 @@ apply ctx@Context {contextInternalEnv = internal} body params args = insideEnv = Env Map.empty internal Nothing Set.empty InternalEnv 0 insideEnv' = foldl' - (\e (p, x) -> extendEnv e p (toLocalDef p x)) + (\e (p, x) -> fromRight (error "Couldn't add local def ") (E.insertX e (SymPath [] p) (toLocalDef p x))) insideEnv (zip proper (take n args)) insideEnv'' = if null rest then insideEnv' else - extendEnv - insideEnv' - (head rest) - (XObj (Lst (drop n args)) Nothing Nothing) - (c, r) <- evalDynamic ResolveLocal (replaceInternalEnv ctx insideEnv'') body + fromRight + (error "couldn't insert into inside env") + ( E.insertX + insideEnv' + (SymPath [] (head rest)) + (XObj (Lst (drop n args)) Nothing Nothing) + ) + (c, r) <- (evalDynamic ResolveLocal (replaceInternalEnv ctx insideEnv'') body) pure (c {contextInternalEnv = internal}, r) -- | Parses a string and then converts the resulting forms to commands, which are evaluated in order. @@ -597,12 +607,12 @@ catcher ctx exception = specialCommandWith :: Context -> XObj -> SymPath -> [XObj] -> IO (Context, Either EvalError XObj) specialCommandWith ctx _ path forms = do - let Just env = contextInternalEnv ctx <|> innermostModuleEnv ctx <|> Just (contextGlobalEnv ctx) + let Just env = contextInternalEnv ctx <|> maybeId (innermostModuleEnv ctx) <|> Just (contextGlobalEnv ctx) useThese = envUseModules env env' = env {envUseModules = Set.insert path useThese} ctx' = replaceGlobalEnv ctx env' ctxAfter <- liftIO $ foldM folder ctx' forms - let Just envAfter = contextInternalEnv ctxAfter <|> innermostModuleEnv ctxAfter <|> Just (contextGlobalEnv ctxAfter) + let Just envAfter = contextInternalEnv ctxAfter <|> maybeId (innermostModuleEnv ctxAfter) <|> Just (contextGlobalEnv ctxAfter) -- undo ALL use:s made inside the 'with'. ctxAfter' = replaceGlobalEnv ctx (envAfter {envUseModules = useThese}) pure (ctxAfter', dynamicNil) @@ -645,7 +655,7 @@ getSigFromDefnOrDef ctx xobj = fullPath = case path of (SymPath [] _) -> consPath pathStrings path (SymPath _ _) -> path - metaData = lookupMeta fullPath globalEnv + metaData = either (const emptyMeta) id (E.lookupMeta globalEnv fullPath) in case Meta.get "sig" metaData of Just foundSignature -> case xobjToTy foundSignature of @@ -683,39 +693,45 @@ annotateWithinContext ctx xobj = do Right ok -> pure (ctx, Right ok) primitiveDefmodule :: VariadicPrimitiveCallback -primitiveDefmodule xobj ctx@(Context env i _ pathStrings _ _ _ _) (XObj (Sym (SymPath [] moduleName) _) _ _ : innerExpressions) = +primitiveDefmodule xobj ctx@(Context env i tenv pathStrings _ _ _ _) (XObj (Sym (SymPath [] moduleName) _) _ _ : innerExpressions) = -- N.B. The `envParent` rewrite at the end of this line is important! -- lookups delve into parent envs by default, which is normally what we want, but in this case it leads to problems -- when submodules happen to share a name with an existing module or type at the global level. - maybe (defineNewModule emptyMeta) updateExistingModule (lookupBinder (SymPath [] moduleName) ((getEnv env pathStrings) {envParent = Nothing})) + either (const (defineNewModule emptyMeta)) updateExistingModule (E.searchValueBinder ((fromRight env (E.getInnerEnv env pathStrings)) {envParent = Nothing}) (SymPath [] moduleName)) >>= defineModuleBindings >>= \(newCtx, result) -> - case result of - Left err -> pure (newCtx, Left err) - Right _ -> pure (popModulePath (newCtx {contextInternalEnv = envParent =<< contextInternalEnv newCtx}), dynamicNil) + let updater c = (c {contextInternalEnv = (E.parent =<< contextInternalEnv c)}) + in case result of + Left err -> pure (newCtx, Left err) + Right _ -> pure (updater (popModulePath newCtx), dynamicNil) where + -------------------------------------------------------------------------------- + -- Update an existing module by modifying its environment parents and updating the current context path. updateExistingModule :: Binder -> IO (Context, Either EvalError XObj) - updateExistingModule (Binder _ (XObj (Mod innerEnv) _ _)) = - let ctx' = - ctx - { contextInternalEnv = Just innerEnv {envParent = i}, - contextPath = contextPath ctx ++ [moduleName] - } - in pure (ctx', dynamicNil) + updateExistingModule (Binder _ (XObj (Mod innerEnv _) _ _)) = + let updateContext = + replacePath' (contextPath ctx ++ [moduleName]) + . replaceInternalEnv' (innerEnv {envParent = i}) + in pure (updateContext ctx, dynamicNil) updateExistingModule (Binder meta (XObj (Lst [XObj MetaStub _ _, _]) _ _)) = defineNewModule meta updateExistingModule _ = pure (throwErr (ModuleRedefinition moduleName) ctx (xobjInfo xobj)) + -------------------------------------------------------------------------------- + -- Define a brand new module with a context's current environments as its parents. defineNewModule :: MetaData -> IO (Context, Either EvalError XObj) defineNewModule meta = - pure (ctx', dynamicNil) + pure (fromRight ctx (updater ctx), dynamicNil) where - moduleEnv = Env (Map.fromList []) (Just (getEnv env pathStrings)) (Just moduleName) Set.empty ExternalEnv 0 - newModule = XObj (Mod moduleEnv) (xobjInfo xobj) (Just ModuleTy) - updatedGlobalEnv = envInsertAt env (SymPath pathStrings moduleName) (Binder meta newModule) - -- The parent of the internal env needs to be set to i here for contextual `use` calls to work. - -- In theory this shouldn't be necessary; but for now it is. - ctx' = ctx {contextGlobalEnv = updatedGlobalEnv, contextInternalEnv = Just moduleEnv {envParent = i}, contextPath = contextPath ctx ++ [moduleName]} + moduleDefs = E.new (Just (fromRight env (E.getInnerEnv env pathStrings))) (Just moduleName) + moduleTypes = E.new (Just tenv) (Just moduleName) + newModule = XObj (Mod moduleDefs moduleTypes) (xobjInfo xobj) (Just ModuleTy) + updater = \c -> + insertInGlobalEnv' (markQualified (SymPath pathStrings moduleName)) (Binder meta newModule) c + >>= pure . replaceInternalEnv' (moduleDefs {envParent = i}) + >>= pure . replacePath' (contextPath ctx ++ [moduleName]) + -------------------------------------------------------------------------------- + -- Define bindings for the module. defineModuleBindings :: (Context, Either EvalError XObj) -> IO (Context, Either EvalError XObj) defineModuleBindings (context, Left e) = pure (context, Left e) defineModuleBindings (context, _) = @@ -725,7 +741,7 @@ primitiveDefmodule xobj ctx@(Context env i _ pathStrings _ _ _ _) (XObj (Sym (Sy step (ctx', Right _) expressions = macroExpand ctx' expressions >>= \(ctx'', res) -> case res of - Left _ -> pure (ctx'', res) + Left err -> pure (ctx'', Left err) Right r -> evalDynamic ResolveLocal ctx'' r primitiveDefmodule _ ctx (x : _) = pure (throwErr (DefmoduleContainsNonSymbol x) ctx (xobjInfo x)) @@ -1013,21 +1029,21 @@ primitiveDefdynamic _ ctx notName _ = pure (throwErr (DefnDynamicInvalidName notName) ctx (xobjInfo notName)) specialCommandSet :: Context -> [XObj] -> IO (Context, Either EvalError XObj) -specialCommandSet ctx [orig@(XObj (Sym path@(SymPath _ n) _) _ _), val] = +specialCommandSet ctx [orig@(XObj (Sym path@(SymPath _ _) _) _ _), val] = let lookupInternal = - contextInternalEnv ctx + maybe (Left "") Right (contextInternalEnv ctx) >>= \e -> - lookupBinder path e + unwrapErr (E.searchValueBinder e path) >>= \binder -> pure (binder, setInternal, e) lookupGlobal = - Just (contextGlobalEnv ctx) + Right (contextGlobalEnv ctx) >>= \e -> - lookupBinder path e + unwrapErr (E.searchValueBinder e path) >>= \binder -> pure (binder, setGlobal, e) - in maybe - (pure $ (throwErr (SetVarNotFound orig) ctx (xobjInfo orig))) + in either + ((const (pure $ (throwErr (SetVarNotFound orig) ctx (xobjInfo orig))))) (\(binder', setter', env') -> evalAndSet binder' setter' env') - (lookupInternal <|> lookupGlobal) + (lookupInternal <> lookupGlobal) where evalAndSet :: Binder -> (Context -> Env -> Either EvalError XObj -> Binder -> IO (Context, Either EvalError XObj)) -> Env -> IO (Context, Either EvalError XObj) evalAndSet binder setter env = @@ -1051,7 +1067,7 @@ specialCommandSet ctx [orig@(XObj (Sym path@(SymPath _ n) _) _ _), val] = setInternal ctx' env value binder = pure $ either (failure ctx' orig) (success ctx') value where - success c xo = (replaceInternalEnv c (setStaticOrDynamicVar (SymPath [] n) env binder xo), dynamicNil) + success c xo = (replaceInternalEnv c (setStaticOrDynamicVar path env binder xo), dynamicNil) specialCommandSet ctx [notName, _] = pure (throwErr (SetInvalidVarName notName) ctx (xobjInfo notName)) specialCommandSet ctx args = @@ -1080,14 +1096,14 @@ typeCheckValueAgainstBinder ctx val binder = do -- assigns an appropriate type to the variable. -- Returns a new environment containing the assignment. setStaticOrDynamicVar :: SymPath -> Env -> Binder -> XObj -> Env -setStaticOrDynamicVar path env binder value = +setStaticOrDynamicVar path@(SymPath _ name) env binder value = case binder of (Binder meta (XObj (Lst (def@(XObj Def _ _) : sym : _)) _ t)) -> - envReplaceBinding path (Binder meta (XObj (Lst [def, sym, value]) (xobjInfo value) t)) env + fromRight env (E.insert env path (Binder meta (XObj (Lst [def, sym, value]) (xobjInfo value) t))) (Binder meta (XObj (Lst (defdy@(XObj DefDynamic _ _) : sym : _)) _ _)) -> - envReplaceBinding path (Binder meta (XObj (Lst [defdy, sym, value]) (xobjInfo value) (Just DynamicTy))) env + fromRight env (E.insert env path (Binder meta (XObj (Lst [defdy, sym, value]) (xobjInfo value) (Just DynamicTy)))) (Binder meta (XObj (Lst (lett@(XObj LocalDef _ _) : sym : _)) _ t)) -> - envReplaceBinding path (Binder meta (XObj (Lst [lett, sym, value]) (xobjInfo value) t)) env + fromRight (error "FAILED!") (E.replaceInPlace env name (Binder meta (XObj (Lst [lett, sym, value]) (xobjInfo value) t))) -- shouldn't happen, errors are thrown at call sites. -- TODO: Return an either here to propagate error. _ -> env diff --git a/src/Expand.hs b/src/Expand.hs index 17d46304..cf801362 100644 --- a/src/Expand.hs +++ b/src/Expand.hs @@ -4,7 +4,6 @@ import Control.Monad.State (State, evalState, get, put) import Data.Foldable (foldlM) import Env import Info -import Lookup import Obj import TypeError import Types @@ -219,7 +218,7 @@ expand eval ctx xobj = ("`ref` takes a single argument, but I got `" ++ pretty xobj ++ "`.") (xobjInfo xobj) ) - XObj (Mod modEnv) _ _ : args -> + XObj (Mod modEnv _) _ _ : args -> let pathToModule = pathToEnv modEnv implicitInit = XObj (Sym (SymPath pathToModule "init") Symbol) i t in expand eval ctx (XObj (Lst (implicitInit : args)) (xobjInfo xobj) (xobjTy xobj)) @@ -280,15 +279,15 @@ 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 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 + case searchValueBinder (contextEnv ctx) path of + Right (Binder meta (XObj (Lst (XObj (External _) _ _ : _)) _ _)) -> isPrivate meta xobj + Right (Binder meta (XObj (Lst (XObj (Instantiate _) _ _ : _)) _ _)) -> isPrivate meta xobj + Right (Binder meta (XObj (Lst (XObj (Deftemplate _) _ _ : _)) _ _)) -> isPrivate meta xobj + Right (Binder meta (XObj (Lst (XObj (Defn _) _ _ : _)) _ _)) -> isPrivate meta xobj + Right (Binder meta (XObj (Lst (XObj Def _ _ : _)) _ _)) -> isPrivate meta xobj + Right (Binder meta (XObj (Lst (XObj (Defalias _) _ _ : _)) _ _)) -> isPrivate meta xobj + Right (Binder meta found) -> isPrivate meta found -- use the found value + Left _ -> pure (ctx, Right xobj) -- symbols that are not found are left as-is where isPrivate m x = pure $ diff --git a/src/GenerateConstraints.hs b/src/GenerateConstraints.hs index e30f5f99..9097b64a 100644 --- a/src/GenerateConstraints.hs +++ b/src/GenerateConstraints.hs @@ -272,7 +272,7 @@ genConstraints _ root rootSig = fmap sort (gen root) (Sym (SymPath [] ("I inferred the type of the array from its first element " ++ show (getPath x))) Symbol) (xobjInfo x) (Just headTy) - Just (StructTy (ConcreteNameTy "Array") [t]) = xobjTy xobj + Just (StructTy (ConcreteNameTy (SymPath [] "Array")) [t]) = xobjTy xobj betweenExprConstraints = zipWith (\o n -> Constraint headTy (forceTy o) headObj (genObj o n) xobj OrdArrBetween) xs [1 ..] headConstraint = Constraint headTy t headObj (genObj x 1) xobj OrdArrHead pure (headConstraint : insideExprConstraints ++ betweenExprConstraints) @@ -293,7 +293,7 @@ genConstraints _ root rootSig = fmap sort (gen root) (Sym (SymPath [] ("I inferred the type of the static array from its first element " ++ show (getPath x))) Symbol) (xobjInfo x) (Just headTy) - Just (RefTy (StructTy (ConcreteNameTy "StaticArray") [t]) _) = xobjTy xobj + Just (RefTy (StructTy (ConcreteNameTy (SymPath [] "StaticArray")) [t]) _) = xobjTy xobj betweenExprConstraints = zipWith (\o n -> Constraint headTy (forceTy o) headObj (genObj o n) xobj OrdArrBetween) xs [1 ..] headConstraint = Constraint headTy t headObj (genObj x 1) xobj OrdArrHead pure (headConstraint : insideExprConstraints ++ betweenExprConstraints) diff --git a/src/InitialTypes.hs b/src/InitialTypes.hs index 1748038b..c398833b 100644 --- a/src/InitialTypes.hs +++ b/src/InitialTypes.hs @@ -1,9 +1,8 @@ module InitialTypes where import Control.Monad.State -import Env +import Env as E import Info -import Lookup import qualified Map import Obj import qualified Set @@ -99,7 +98,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0 If -> pure (Left (InvalidObj If xobj)) While -> pure (Left (InvalidObj While xobj)) Do -> pure (Left (InvalidObj Do xobj)) - (Mod _) -> pure (Left (InvalidObj If xobj)) + (Mod _ _) -> pure (Left (InvalidObj If xobj)) e@(Deftype _) -> pure (Left (InvalidObj e xobj)) e@(External _) -> pure (Left (InvalidObj e xobj)) e@(ExternalType _) -> pure (Left (InvalidObj e xobj)) @@ -128,8 +127,8 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0 SymPath _ name@('?' : _) -> pure (Right (xobj {xobjTy = Just (VarTy name)})) SymPath _ (':' : _) -> pure (Left (LeadingColon xobj)) _ -> - case lookupInEnv symPath env of - Just (foundEnv, binder) -> + case E.searchValue env symPath of + Right (foundEnv, binder) -> case xobjTy (binderXObj binder) of -- Don't rename internal symbols like parameters etc! Just theType @@ -138,7 +137,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0 pure (Right (xobj {xobjTy = Just renamed})) | otherwise -> pure (Right (xobj {xobjTy = Just theType})) Nothing -> pure (Left (SymbolMissingType xobj foundEnv)) - Nothing -> pure (Left (SymbolNotDefined symPath xobj env)) -- Gives the error message "Trying to refer to an undefined symbol ..." + Left _ -> pure (Left (SymbolNotDefined symPath xobj env)) -- Gives the error message "Trying to refer to an undefined symbol ..." visitMultiSym :: Env -> XObj -> [SymPath] -> State Integer (Either TypeError XObj) visitMultiSym _ xobj@(XObj (MultiSym _ _) _ _) _ = do @@ -148,10 +147,10 @@ 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 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 + freshTy <- case getTypeBinder typeEnv name of + Right (Binder _ (XObj (Lst [XObj (Interface interfaceSignature _) _ _, _]) _ _)) -> renameVarTys interfaceSignature + Right (Binder _ x) -> error ("A non-interface named '" ++ name ++ "' was found in the type environment: " ++ pretty x) + Left _ -> genVarTy pure (Right xobj {xobjTy = Just freshTy}) visitInterfaceSym _ _ = error "visitinterfacesym" visitArray :: Env -> XObj -> State Integer (Either TypeError XObj) @@ -161,7 +160,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0 arrayVarTy <- genVarTy pure $ do okVisited <- sequence visited - Right (XObj (Arr okVisited) i (Just (StructTy (ConcreteNameTy "Array") [arrayVarTy]))) + Right (XObj (Arr okVisited) i (Just (StructTy (ConcreteNameTy (SymPath [] "Array")) [arrayVarTy]))) visitArray _ _ = error "The function 'visitArray' only accepts XObj:s with arrays in them." visitStaticArray :: Env -> XObj -> State Integer (Either TypeError XObj) visitStaticArray env (XObj (StaticArr xobjs) i _) = @@ -171,7 +170,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0 lt <- genVarTy pure $ do okVisited <- sequence visited - Right (XObj (StaticArr okVisited) i (Just (RefTy (StructTy (ConcreteNameTy "StaticArray") [arrayVarTy]) lt))) + Right (XObj (StaticArr okVisited) i (Just (RefTy (StructTy (ConcreteNameTy (SymPath [] "StaticArray")) [arrayVarTy]) lt))) visitStaticArray _ _ = error "The function 'visitStaticArray' only accepts XObj:s with arrays in them." visitDictionary :: Env -> XObj -> State Integer (Either TypeError XObj) visitDictionary env (XObj (Dict xobjs) i _) = @@ -180,7 +179,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0 arrayVarTy <- genVarTy pure $ do okVisited <- sequence visited - Right (XObj (Dict okVisited) i (Just (StructTy (ConcreteNameTy "Dictionary") [arrayVarTy]))) + Right (XObj (Dict okVisited) i (Just (StructTy (ConcreteNameTy (SymPath [] "Dictionary")) [arrayVarTy]))) visitDictionary _ _ = error "The function 'visitArray' only accepts XObj:s with dictionaries in them." getTys env argList = do @@ -198,7 +197,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0 let funcTy = Just (FuncTy argTypes returnType StaticLifetimeTy) typedNameSymbol = nameSymbol {xobjTy = funcTy} -- TODO! After the introduction of 'LookupRecursive' this env shouldn't be needed anymore? (but it is for some reason...) - envWithSelf = extendEnv funcScopeEnv name typedNameSymbol + Right envWithSelf = E.insertX funcScopeEnv (SymPath [] name) typedNameSymbol visitedBody <- visit envWithSelf body visitedArgs <- mapM (visit envWithSelf) argList pure $ do @@ -440,15 +439,18 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0 (Sym (SymPath _ name) _) -> do visited <- visit env' expr - pure (envAddBinding env' name . Binder emptyMeta <$> visited) + pure + ( join + (replaceLeft (InvalidLetBinding xobjs (sym, expr)) . E.insert env' (SymPath [] name) . Binder emptyMeta <$> visited) + ) _ -> pure (Left (InvalidLetBinding xobjs (sym, expr))) extendEnvWithParamList :: Env -> [XObj] -> State Integer Env extendEnvWithParamList env xobjs = do - binders <- mapM createBinderForParam xobjs + binders' <- mapM createBinderForParam xobjs pure Env - { envBindings = Map.fromList binders, + { envBindings = Map.fromList binders', envParent = Just env, envModuleName = Nothing, envUseModules = Set.empty, @@ -468,10 +470,10 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0 extendEnvWithCaseMatch :: Env -> XObj -> State Integer Env extendEnvWithCaseMatch env caseRoot = do - binders <- createBindersForCaseVariable caseRoot + binders' <- createBindersForCaseVariable caseRoot pure Env - { envBindings = Map.fromList binders, + { envBindings = Map.fromList binders', envParent = Just env, envModuleName = Nothing, envUseModules = Set.empty, @@ -484,8 +486,8 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0 createBindersForCaseVariable xobj@(XObj (MultiSym name _) _ _) = createBinderInternal xobj name createBindersForCaseVariable xobj@(XObj (InterfaceSym name) _ _) = createBinderInternal xobj name createBindersForCaseVariable (XObj (Lst lst) _ _) = do - binders <- mapM createBindersForCaseVariable lst - pure (concat binders) + binders' <- mapM createBindersForCaseVariable lst + pure (concat binders') createBindersForCaseVariable (XObj Ref _ _) = pure [] createBindersForCaseVariable x = error ("Can't create binder for non-symbol in 'case' variable match:" ++ show x) -- TODO: Should use proper error mechanism createBinderInternal :: XObj -> String -> State Integer [(String, Binder)] diff --git a/src/Interfaces.hs b/src/Interfaces.hs index a6eec343..05395e96 100644 --- a/src/Interfaces.hs +++ b/src/Interfaces.hs @@ -14,12 +14,13 @@ where import ColorText import Constraints +import Context +import Data.Either (fromRight, rights) import Data.List (delete, deleteBy, foldl') -import Data.Maybe (fromMaybe, mapMaybe) -import Env -import Lookup +import qualified Env import qualified Meta import Obj +import qualified Qualify import Types import Util @@ -67,7 +68,7 @@ instance Show InterfaceError where -- | Get the first path of an interface implementation that matches a given type signature getFirstMatchingImplementation :: Context -> [SymPath] -> Ty -> Maybe SymPath getFirstMatchingImplementation ctx paths ty = - case filter predicate (mapMaybe (`lookupBinder` global) paths) of + case filter predicate (rights (map (global `Env.searchValueBinder`) paths)) of [] -> Nothing (x : _) -> Just ((getPath . binderXObj) x) where @@ -77,53 +78,51 @@ getFirstMatchingImplementation ctx paths ty = -- | Remove an interface from a binder's list of implemented interfaces removeInterfaceFromImplements :: SymPath -> XObj -> Context -> Context removeInterfaceFromImplements oldImplPath interface ctx = - fromMaybe + fromRight ctx - ( lookupBinder oldImplPath (contextGlobalEnv ctx) + ( lookupBinderInGlobalEnv ctx (Qualify.markQualified oldImplPath) >>= \binder -> - Meta.getBinderMetaValue "implements" binder - >>= ( \x -> - case x of - (XObj (Lst impls) i t) -> - pure $ Meta.updateBinderMeta binder "implements" (XObj (Lst (deleteBy matchPath interface impls)) i t) - _ -> Nothing - ) - >>= (\b -> pure $ ctx {contextGlobalEnv = envInsertAt (contextGlobalEnv ctx) oldImplPath b}) + pure + ( case Meta.getBinderMetaValue "implements" binder of + Just (XObj (Lst impls) i t) -> Meta.updateBinderMeta binder "implements" (XObj (Lst (deleteBy matchPath interface impls)) i t) + _ -> binder + ) + >>= insertInGlobalEnv ctx (Qualify.markQualified oldImplPath) ) where matchPath xobj xobj' = getPath xobj == getPath xobj' -- TODO: This is currently called once outside of this module--try to remove that call and make this internal. -- Checks whether a given form's type matches an interface, and if so, registers the form with the interface. -registerInInterfaceIfNeeded :: Context -> Binder -> Binder -> Ty -> (Context, Maybe InterfaceError) +registerInInterfaceIfNeeded :: Context -> Binder -> Binder -> Ty -> (Either ContextError Context, Maybe InterfaceError) registerInInterfaceIfNeeded ctx implementation interface definitionSignature = case interface of Binder _ (XObj (Lst [inter@(XObj (Interface interfaceSignature paths) ii it), isym]) i t) -> if checkKinds interfaceSignature definitionSignature then case solve [Constraint interfaceSignature definitionSignature inter inter inter OrdInterfaceImpl] of - Left _ -> (ctx, Just (TypeMismatch implPath definitionSignature interfaceSignature)) + Left _ -> (Right ctx, Just (TypeMismatch implPath definitionSignature interfaceSignature)) Right _ -> case getFirstMatchingImplementation ctx paths definitionSignature of Nothing -> (updatedCtx, Nothing) Just x -> if x == implPath then (updatedCtx, Nothing) else (implReplacedCtx x, Just (AlreadyImplemented ipath x implPath definitionSignature)) - else (ctx, Just (KindMismatch implPath definitionSignature interfaceSignature)) + else (Right ctx, Just (KindMismatch implPath definitionSignature interfaceSignature)) where + qpath = (Qualify.markQualified (SymPath [] name)) updatedInterface = XObj (Lst [XObj (Interface interfaceSignature (addIfNotPresent implPath paths)) ii it, isym]) i t - updatedCtx = ctx {contextTypeEnv = TypeEnv (extendEnv typeEnv name updatedInterface)} + updatedCtx = replaceTypeBinder ctx qpath (toBinder updatedInterface) implReplacedInterface x = XObj (Lst [XObj (Interface interfaceSignature (addIfNotPresent implPath (delete x paths))) ii it, isym]) i t - implReplacedCtx x = ctx {contextTypeEnv = TypeEnv (extendEnv typeEnv name (implReplacedInterface x))} + implReplacedCtx x = replaceTypeBinder ctx qpath (toBinder (implReplacedInterface x)) _ -> - (ctx, Just (NonInterface (getBinderPath interface))) + (Right ctx, Just (NonInterface (getBinderPath interface))) where implPath = getBinderPath implementation - typeEnv = getTypeEnv (contextTypeEnv ctx) ipath@(SymPath _ name) = getBinderPath interface -- | Given a binder and an interface path, ensure that the form is -- registered with the interface. -registerInInterface :: Context -> Binder -> Binder -> (Context, Maybe InterfaceError) +registerInInterface :: Context -> Binder -> Binder -> (Either ContextError Context, Maybe InterfaceError) registerInInterface ctx implementation interface = case binderXObj implementation of XObj (Lst [XObj (Defn _) _ _, _, _, _]) _ (Just t) -> @@ -141,26 +140,26 @@ registerInInterface ctx implementation interface = -- And instantiated/auto-derived type functions! (e.g. Pair.a) XObj (Lst [XObj (Instantiate _) _ _, _]) _ (Just t) -> registerInInterfaceIfNeeded ctx implementation interface t - _ -> (ctx, Nothing) + _ -> (Right ctx, Nothing) -- | For forms that were declared as implementations of interfaces that didn't exist, -- retroactively register those forms with the interface once its defined. -retroactivelyRegisterInInterface :: Context -> Binder -> Context +retroactivelyRegisterInInterface :: Context -> Binder -> Either ContextError Context retroactivelyRegisterInInterface ctx interface = -- TODO: Propagate error maybe resultCtx (error . show) err where env = contextGlobalEnv ctx - impls = lookupMany Everywhere lookupImplementations (getPath (binderXObj interface)) env - (resultCtx, err) = foldl' (\(context, _) binder -> registerInInterface context binder interface) (ctx, Nothing) impls + impls = concat (rights (fmap ((flip Env.findImplementations) (getPath (binderXObj interface))) (env : (Env.lookupChildren env)))) + (resultCtx, err) = foldl' (\(Right context, _) binder -> registerInInterface context binder interface) (Right ctx, Nothing) impls -- | Checks whether an interface is implemented for a certain type signature, -- | e.g. Is "delete" implemented for `(Fn [String] ())` ? interfaceImplementedForTy :: TypeEnv -> Env -> String -> Ty -> Bool -interfaceImplementedForTy (TypeEnv typeEnv) globalEnv interfaceName matchingTy = - case lookupBinder (SymPath [] interfaceName) typeEnv of - Just (Binder _ (XObj (Lst (XObj (Interface _ paths) _ _ : _)) _ _)) -> - let lookupType path = forceTy . binderXObj <$> lookupBinder path globalEnv - matches = filter (areUnifiable matchingTy) (mapMaybe lookupType paths) +interfaceImplementedForTy typeEnv globalEnv interfaceName matchingTy = + case Env.getTypeBinder typeEnv interfaceName of + Right (Binder _ (XObj (Lst (XObj (Interface _ paths) _ _ : _)) _ _)) -> + let lookupType' path = forceTy . binderXObj <$> (Env.searchValueBinder globalEnv path) + matches = filter (areUnifiable matchingTy) (rights (map lookupType' paths)) in not . null $ matches _ -> False diff --git a/src/Lookup.hs b/src/Lookup.hs deleted file mode 100644 index 92e29756..00000000 --- a/src/Lookup.hs +++ /dev/null @@ -1,143 +0,0 @@ -module Lookup where - -import Data.Maybe (catMaybes, mapMaybe) -import Env -import qualified Map -import qualified Meta -import Obj -import qualified Set -import Types - --- | The type of generic lookup functions. -type LookupFunc a b = a -> Env -> [b] - --- | Find the Binder at a specified path. -lookupInEnv :: SymPath -> Env -> Maybe (Env, Binder) -lookupInEnv (SymPath [] name) env = - case Map.lookup name (envBindings env) of - Just found -> Just (env, found) - Nothing -> case envParent env of - Just parent -> lookupInEnv (SymPath [] name) parent - Nothing -> Nothing -lookupInEnv path@(SymPath (p : ps) name) env = - case Map.lookup p (envBindings env) of - Just (Binder _ xobj) -> - case xobj of - (XObj (Mod modEnv) _ _) -> lookupInEnv (SymPath ps name) modEnv - _ -> Nothing - Nothing -> - case envParent env of - Just parent -> lookupInEnv path parent - Nothing -> Nothing - --- | Performs a multiLookupEverywhere but drops envs from the result and wraps --- the results in a Maybe. -multiLookupBinderEverywhere :: Context -> SymPath -> Maybe [Binder] -multiLookupBinderEverywhere ctx (SymPath _ name) = - case map snd (multiLookupEverywhere name (contextEnv ctx)) of - [] -> Nothing - xs -> Just xs - --- | Like 'lookupInEnv' but only returns the Binder (no Env) -lookupBinder :: SymPath -> Env -> Maybe Binder -lookupBinder path env = snd <$> lookupInEnv path env - --- | 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) - --- | 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. -importedEnvs :: Env -> [Env] -importedEnvs env = - catMaybes $ mapMaybe (\path -> fmap envFromBinder (lookupBinder path env)) (Set.toList (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. -lookupMany :: LookWhere -> LookupFunc a b -> a -> Env -> [b] -lookupMany lookWhere lookf input env = - let spine = lookf input env - leaves = concatMap (lookf input) (getEnvs lookWhere env) - above = case envParent env of - Just parent -> lookupMany lookWhere lookf input parent - Nothing -> [] - in spine ++ leaves ++ above - --- | 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 ((,) env . snd) (Map.toList filtered) - --- | Lookup binders that have specified metadata. -lookupByMeta :: String -> Env -> [Binder] -lookupByMeta key env = - let filtered = Map.filter hasMeta (envBindings env) - in map snd $ Map.toList filtered - where - hasMeta b = Meta.binderMember key b - --- | Given an interface, lookup all binders that implement the interface. -lookupImplementations :: SymPath -> Env -> [Binder] -lookupImplementations interface env = - let binders = lookupByMeta "implements" env - in filter isImpl binders - where - isImpl (Binder meta _) = - case Meta.get "implements" meta of - Just (XObj (Lst interfaces) _ _) -> interface `elem` map getPath interfaces - _ -> False - --- | 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 --- | you can find it by doing "(use A)" and then "(B.f)". -multiLookupQualified :: SymPath -> Env -> [(Env, Binder)] -multiLookupQualified (SymPath [] name) rootEnv = - -- This case is just like normal multiLookup, we have a name but no qualifyers: - multiLookupImports name rootEnv -multiLookupQualified path@(SymPath (p : _) _) rootEnv = - case lookupInEnv (SymPath [] p) rootEnv of - Just (_, Binder _ (XObj (Mod _) _ _)) -> - -- Found a module with the correct name, that means we should not look at anything else: - case lookupInEnv path rootEnv of - Just found -> [found] - Nothing -> [] - Just _ -> inexactMatch - Nothing -> inexactMatch - where - inexactMatch = - -- No exact match on the first qualifier, will look in various places for a match: - let fromParent = case envParent rootEnv of - Just parent -> multiLookupQualified path parent - Nothing -> [] - fromUsedModules = - let usedModules = envUseModules rootEnv - envs = catMaybes $ mapMaybe (\path' -> fmap envFromBinder (lookupBinder path' rootEnv)) (Set.toList usedModules) - in concatMap (multiLookupQualified path) envs - in fromParent ++ fromUsedModules diff --git a/src/Map.hs b/src/Map.hs index 57eb34f3..8deb6f03 100644 --- a/src/Map.hs +++ b/src/Map.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -18,7 +19,7 @@ fromList :: Ord k => [(k, v)] -> Map k v fromList = Map . M.fromList lookup :: Ord k => k -> Map k v -> Maybe v -lookup k (Map m) = M.lookup k m +lookup !k (Map !m) = M.lookup k m member :: Ord k => k -> Map k v -> Bool member k (Map m) = M.member k m @@ -46,3 +47,12 @@ union (Map m) (Map m') = (Map (M.union m m')) assocs :: Map k a -> [(k, a)] assocs (Map m) = M.assocs m + +elems :: Map k a -> [a] +elems (Map m) = M.elems m + +adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a +adjust f k (Map m) = (Map (M.adjust f k m)) + +delete :: Ord k => k -> Map k a -> Map k a +delete k (Map m) = (Map (M.delete k m)) diff --git a/src/Obj.hs b/src/Obj.hs index 3dae5a52..ef94a5b2 100644 --- a/src/Obj.hs +++ b/src/Obj.hs @@ -149,7 +149,7 @@ data Obj | Break | If | Match MatchMode - | Mod Env + | Mod Env TypeEnv | Deftype Ty | DefSumtype Ty | With @@ -342,7 +342,7 @@ getBinderDescription (XObj (Lst (XObj MetaStub _ _ : XObj (Sym _ _) _ _ : _)) _ getBinderDescription (XObj (Lst (XObj (Deftype _) _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "deftype" getBinderDescription (XObj (Lst (XObj (DefSumtype _) _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "deftype" getBinderDescription (XObj (Lst (XObj (Interface _ _) _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "interface" -getBinderDescription (XObj (Mod _) _ _) = "module" +getBinderDescription (XObj (Mod _ _) _ _) = "module" getBinderDescription b = error ("Unhandled binder: " ++ show b) getName :: XObj -> String @@ -384,7 +384,7 @@ getPath (XObj (Lst (XObj (External _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = p getPath (XObj (Lst (XObj (ExternalType _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path getPath (XObj (Lst (XObj MetaStub _ _ : XObj (Sym path _) _ _ : _)) _ _) = path getPath (XObj (Lst (XObj (Deftype _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path -getPath (XObj (Lst (XObj (Mod _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path +getPath (XObj (Lst (XObj (Mod _ _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path getPath (XObj (Lst (XObj (Interface _ _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path getPath (XObj (Lst (XObj (Command _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path getPath (XObj (Lst (XObj (Primitive _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path @@ -449,7 +449,7 @@ pretty = visit 0 Do -> "do" Let -> "let" LocalDef -> "local-binding" - Mod env -> fromMaybe "module" (envModuleName env) + Mod env _ -> fromMaybe "module" (envModuleName env) Deftype _ -> "deftype" DefSumtype _ -> "deftype" Deftemplate _ -> "deftemplate" @@ -515,7 +515,7 @@ prettyUpTo lim xobj = Do -> "" Let -> "" LocalDef -> "" - Mod _ -> "" + Mod _ _ -> "" Deftype _ -> "" DefSumtype _ -> "" Deftemplate _ -> "" @@ -643,10 +643,12 @@ forceShowBinder :: Binder -> String forceShowBinder binder = showBinderIndented 0 True (getName (binderXObj binder), binder) showBinderIndented :: Int -> Bool -> (String, Binder) -> String -showBinderIndented indent _ (name, Binder _ (XObj (Mod env) _ _)) = +showBinderIndented indent _ (name, Binder _ (XObj (Mod env tenv) _ _)) = replicate indent ' ' ++ name ++ " : Module = {\n" ++ prettyEnvironmentIndented (indent + 4) env ++ "\n" + ++ prettyEnvironmentIndented (indent + 4) (getTypeEnv tenv) + ++ "\n" ++ replicate indent ' ' ++ "}" showBinderIndented indent _ (name, Binder _ (XObj (Lst [XObj (Interface t paths) _ _, _]) _ _)) = @@ -717,7 +719,7 @@ instance Hashable ClosureContext instance Eq ClosureContext where _ == _ = True -newtype TypeEnv = TypeEnv {getTypeEnv :: Env} deriving (Generic) +newtype TypeEnv = TypeEnv {getTypeEnv :: Env} deriving (Generic, Eq) instance Hashable TypeEnv @@ -798,9 +800,9 @@ xobjToTy (XObj (Sym (SymPath _ "Pattern") _) _ _) = Just PatternTy xobjToTy (XObj (Sym (SymPath _ "Char") _) _ _) = Just CharTy xobjToTy (XObj (Sym (SymPath _ "Bool") _) _ _) = Just BoolTy xobjToTy (XObj (Sym (SymPath _ "Static") _) _ _) = Just StaticLifetimeTy -xobjToTy (XObj (Sym (SymPath prefixes s@(firstLetter : _)) _) _ _) +xobjToTy (XObj (Sym spath@(SymPath _ s@(firstLetter : _)) _) _ _) | isLower firstLetter = Just (VarTy s) - | otherwise = Just (StructTy (ConcreteNameTy (createStructName prefixes s)) []) + | otherwise = Just (StructTy (ConcreteNameTy spath) []) xobjToTy (XObj (Lst [XObj (Sym (SymPath _ "Ptr") _) _ _, innerTy]) _ _) = do okInnerTy <- xobjToTy innerTy @@ -945,10 +947,10 @@ defineFunctionTypeAlias :: Ty -> XObj defineFunctionTypeAlias aliasTy = defineTypeAlias (tyToC aliasTy) aliasTy defineArrayTypeAlias :: Ty -> XObj -defineArrayTypeAlias t = defineTypeAlias (tyToC t) (StructTy (ConcreteNameTy "Array") []) +defineArrayTypeAlias t = defineTypeAlias (tyToC t) (StructTy (ConcreteNameTy (SymPath [] "Array")) []) defineStaticArrayTypeAlias :: Ty -> XObj -defineStaticArrayTypeAlias t = defineTypeAlias (tyToC t) (StructTy (ConcreteNameTy "Array") []) +defineStaticArrayTypeAlias t = defineTypeAlias (tyToC t) (StructTy (ConcreteNameTy (SymPath [] "Array")) []) -- | defineInterface :: String -> Ty -> [SymPath] -> Maybe Info -> XObj diff --git a/src/Polymorphism.hs b/src/Polymorphism.hs index c0fb50d3..1aa930e4 100644 --- a/src/Polymorphism.hs +++ b/src/Polymorphism.hs @@ -1,24 +1,30 @@ -module Polymorphism where +module Polymorphism + ( nameOfPolymorphicFunction, + ) +where -import Lookup +import Env as E import Obj import Types -- | Calculate the full, mangled name of a concretized polymorphic function. --- | For example, The 'id' in "(id 3)" will become 'id__int'. --- | This function uses the 'multiLookupALL' function which gives it acces to --- | modules that are not imported. This allows it to access 'delete' functions --- | and similar for internal use. - --- | TODO: Environments are passed in different order here!!! +-- For example, The 'id' in "(id 3)" will become 'id__int'. +-- +-- This function uses findPoly, which gives it access to *all* possible +-- environments in the given input environment (children, (modules) parents, +-- and use modules). This allows it to derive the correct name for functions +-- that may be defined in a different environment. +-- +-- TODO: Environments are passed in different order here!!! nameOfPolymorphicFunction :: TypeEnv -> Env -> Ty -> String -> Maybe SymPath nameOfPolymorphicFunction _ env functionType functionName = - 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)) _ _ : _)) _ _))] -> + let foundBinder = + (E.findPoly env functionName functionType) + <> (E.findPoly (progenitor env) functionName functionType) + in case foundBinder of + Right (_, (Binder _ (XObj (Lst (XObj (External (Just name)) _ _ : _)) _ _))) -> Just (SymPath [] name) - [(_, Binder _ single)] -> + Right (_, (Binder _ single)) -> let Just t' = xobjTy single (SymPath pathStrings name) = getPath single suffix = polymorphicSuffix t' functionType diff --git a/src/PrimitiveError.hs b/src/PrimitiveError.hs index 29872e90..4c992d78 100644 --- a/src/PrimitiveError.hs +++ b/src/PrimitiveError.hs @@ -11,6 +11,14 @@ data PrimitiveError | ForewardImplementsMeta | RegisterTypeError | SymbolNotFoundError SymPath + | BadDeftypeMembers + | QualifiedTypeMember [XObj] + | InvalidTypeName XObj + | InvalidTypeVariables XObj + | MetaSetFailed XObj String + | StructNotFound XObj + | NonTypeInTypeEnv SymPath XObj + | InvalidSumtypeCase XObj data PrimitiveWarning = NonExistentInterfaceWarning XObj @@ -40,6 +48,32 @@ instance Show PrimitiveError where ++ " (register-type Name c-name [field0 Type, ...]" show (SymbolNotFoundError path) = "I can’t find the symbol `" ++ show path ++ "`" + show (BadDeftypeMembers) = + "All fields must have a name and a type." + ++ "Example:\n" + ++ "```(deftype Name [field1 Type1, field2 Type2, field3 Type3])```\n" + show (QualifiedTypeMember xobjs) = + "Type members must be unqualified symbols, but got `" + ++ concatMap pretty xobjs + ++ "`" + show (InvalidTypeName xobj) = + ("Invalid name for type definition: " ++ pretty xobj) + show (InvalidTypeVariables xobj) = + ("Invalid type variables for type definition: " ++ pretty xobj) + show (MetaSetFailed xobj e) = + "`meta-set!` failed on `" ++ pretty xobj + ++ "` " + ++ show e + show (StructNotFound xobj) = + "Couldn't find a type named '" ++ (show (getPath xobj)) + ++ "' in the type environment." + show (NonTypeInTypeEnv path xobj) = + "Can't get members for: " ++ show path + ++ " found a non-type in the type environment: " + ++ (pretty xobj) + show (PrimitiveError.InvalidSumtypeCase xobj) = + "Can't get members for an invalid sumtype case: " + ++ pretty xobj instance Show PrimitiveWarning where show (NonExistentInterfaceWarning x) = diff --git a/src/Primitives.hs b/src/Primitives.hs index 9f70d274..82d2f154 100644 --- a/src/Primitives.hs +++ b/src/Primitives.hs @@ -8,27 +8,26 @@ import Context import Control.Applicative import Control.Monad (foldM, unless, when) import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Either (rights) +import Data.Bifunctor +import Data.Either (fromRight, rights) import Data.Functor ((<&>)) import Data.List (foldl') -import Data.Maybe (fromJust, fromMaybe, mapMaybe) +import Data.Maybe (fromJust, fromMaybe) import Deftype import Emit -import Env +import Env (addUsePath, contextEnv, insert, lookupBinderEverywhere, lookupEverywhere, lookupMeta, searchValueBinder) import Infer import Info import Interfaces -import Lookup import Managed -import qualified Map import qualified Meta import Obj import PrimitiveError import Project -import Qualify (Qualified (..), getQualifiedPath, markQualified, qualify, qualifyNull, qualifyPath, unqualify) +import Qualify (Qualified (..), QualifiedPath, getQualifiedPath, markQualified, qualify, qualifyNull, qualifyPath, unqualify) import Reify -import qualified Set import Sumtypes +import SymPath import Template import ToTemplate import TypeError @@ -122,10 +121,10 @@ primitiveImplements _ ctx x@(XObj (Sym interface@(SymPath _ _) _) _ _) (XObj (Sy do (maybeInterface, maybeImpl) <- pure (lookupInterface ctx interface, lookupBinderInGlobalEnv ctx qpath) case (maybeInterface, maybeImpl) of - (_, Nothing) -> updateMeta (Meta.stub (contextualize path ctx)) ctx - (Nothing, Just implBinder) -> + (_, Left _) -> updateMeta (Meta.stub (contextualize path ctx)) ctx + (Left _, Right implBinder) -> warn >> updateMeta implBinder ctx - (Just interfaceBinder, Just implBinder) -> + (Right interfaceBinder, Right implBinder) -> -- N.B. The found binding will be fully qualified! addToInterface interfaceBinder implBinder where @@ -134,7 +133,7 @@ primitiveImplements _ ctx x@(XObj (Sym interface@(SymPath _ _) _) _ _) (XObj (Sy warn = emitWarning (show (NonExistentInterfaceWarning x)) addToInterface :: Binder -> Binder -> IO (Context, Either EvalError XObj) addToInterface inter impl = - let (newCtx, maybeErr) = registerInInterface ctx impl inter + let (Right newCtx, maybeErr) = registerInInterface ctx impl inter in maybe (updateMeta impl newCtx) (handleError newCtx impl) maybeErr handleError :: Context -> Binder -> InterfaceError -> IO (Context, Either EvalError XObj) handleError context impl e@(AlreadyImplemented _ oldImplPath _ _) = @@ -143,9 +142,9 @@ primitiveImplements _ ctx x@(XObj (Sym interface@(SymPath _ _) _) _ _) (XObj (Sy emitError (show e) >> pure (evalError context (show e) (xobjInfo x)) updateMeta :: Binder -> Context -> IO (Context, Either EvalError XObj) updateMeta binder context = - pure (fromJust update, dynamicNil) + pure (fromRight (error "Couldn't insert updated meta!!") (fromJust updater), dynamicNil) where - update = + updater = ( ( Meta.getBinderMetaValue "implements" binder <&> updateImplementations binder ) @@ -178,20 +177,22 @@ define hidden ctx qualifiedXObj = freshBinder = toBinder annXObj qpath = getQualifiedPath qualifiedXObj defineInTypeEnv :: Binder -> IO Context - defineInTypeEnv = pure . (insertInTypeEnv ctx qpath) + defineInTypeEnv = pure . fromRight ctx . (insertTypeBinder ctx qpath) defineInGlobalEnv :: Binder -> IO Context defineInGlobalEnv newBinder = when (projectEchoC (contextProj ctx)) (putStrLn (toC All (Binder emptyMeta annXObj))) >> case (lookupBinderInGlobalEnv ctx qpath) of - Nothing -> pure (insertInGlobalEnv ctx qpath newBinder) - Just oldBinder -> redefineExistingBinder oldBinder newBinder + Left _ -> pure (fromRight ctx (insertInGlobalEnv ctx qpath newBinder)) + Right oldBinder -> redefineExistingBinder oldBinder newBinder redefineExistingBinder :: Binder -> Binder -> IO Context redefineExistingBinder old@(Binder meta _) (Binder _ x) = do - warnTypeChange old + unless (isInstantiation (binderXObj old)) (warnTypeChange old) -- TODO: Merge meta more elegantly. updatedContext <- (implementInterfaces (Binder meta x)) - pure (insertInGlobalEnv updatedContext qpath (Binder meta x)) + pure (fromRight (error ("Failed to insert " ++ show qpath)) (insertInGlobalEnv updatedContext qpath (Binder meta x))) + isInstantiation (XObj (Lst (XObj (Instantiate _) _ _ : _)) _ _) = True + isInstantiation _ = False warnTypeChange :: Binder -> IO () warnTypeChange binder = unless (areUnifiable (forceTy annXObj) previousType) warn @@ -208,9 +209,9 @@ define hidden ctx qualifiedXObj = >>= \(XObj (Lst interfaces) _ _) -> pure (map Qualified interfaces) ) >>= \maybeinterfaces -> - pure (mapMaybe (lookupBinderInTypeEnv ctx . getQualifiedPath) (fromMaybe [] maybeinterfaces)) + pure (rights (fmap (lookupBinderInTypeEnv ctx . getQualifiedPath) (fromMaybe [] maybeinterfaces))) >>= \interfaceBinders -> - pure (foldl' (\(ctx', _) interface -> registerInInterface ctx' binder interface) (ctx, Nothing) interfaceBinders) + pure (foldl' (\(ctx', _) interface -> first (fromRight ctx') (registerInInterface ctx' binder interface)) (ctx, Nothing) interfaceBinders) >>= \(newCtx, err) -> case err of Just e -> printError (contextExecMode ctx) (show e) >> pure ctx Nothing -> pure newCtx @@ -233,13 +234,17 @@ primitiveRegisterType _ ctx [x@(XObj (Sym (SymPath [] t) _) _ _), members] = primitiveRegisterTypeWithFields ctx x t Nothing members primitiveRegisterType x ctx _ = pure (toEvalError ctx x RegisterTypeError) +-- | Register an external type that has no fields. primitiveRegisterTypeWithoutFields :: Context -> String -> Maybe String -> IO (Context, Either EvalError XObj) primitiveRegisterTypeWithoutFields ctx t override = do let path = SymPath [] t typeDefinition = XObj (Lst [XObj (ExternalType override) Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing]) Nothing (Just TypeTy) -- TODO: Support registering types in modules - pure (insertInTypeEnv ctx (markQualified path) (toBinder typeDefinition), dynamicNil) + case insertTypeBinder ctx (markQualified path) (toBinder typeDefinition) of + Left e -> pure (evalError ctx (show e) Nothing) + Right c -> pure (c, dynamicNil) +-- | Register an external type that has fields. primitiveRegisterTypeWithFields :: Context -> XObj -> String -> Maybe String -> XObj -> IO (Context, Either EvalError XObj) primitiveRegisterTypeWithFields ctx x t override members = either @@ -252,46 +257,47 @@ primitiveRegisterTypeWithFields ctx x t override members = do let typeDefinition = XObj (Lst [XObj (ExternalType override) Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing]) Nothing (Just TypeTy) path' = (qualifyPath ctx (SymPath [] typeModuleName)) - update = insertInTypeEnv' path' (toBinder typeDefinition) . insertInGlobalEnv' path' (toBinder typeModuleXObj) - ctx' = update ctx + update = \c -> insertInGlobalEnv' path' (toBinder typeModuleXObj) c >>= insertTypeBinder' path' (toBinder typeDefinition) + Right ctx' = update ctx -- TODO: Another case where define does not get formally qualified deps! contextWithDefs <- liftIO $ foldM (define True) ctx' (map Qualified deps) pure (contextWithDefs, dynamicNil) path = SymPath [] t preExistingModule = case lookupBinderInGlobalEnv ctx path of - Just (Binder _ (XObj (Mod found) _ _)) -> Just found + Right (Binder _ (XObj (Mod found et) _ _)) -> Just (found, et) _ -> Nothing notFound :: Context -> XObj -> SymPath -> IO (Context, Either EvalError XObj) notFound ctx x path = pure (toEvalError ctx x (SymbolNotFoundError path)) +-- | Get information about a binding. primitiveInfo :: UnaryPrimitiveCallback -primitiveInfo _ ctx target@(XObj (Sym path@(SymPath _ _) _) _ _) = +primitiveInfo _ ctx target@(XObj (Sym path@(SymPath _ name) _) _ _) = case path of SymPath [] _ -> do let found = lookupBinderInTypeEnv ctx path _ <- printIfFound found _ <- printInterfaceImplementationsOrAll found otherBindings - maybe (notFound ctx target path) (const ok) (found <|> fmap head otherBindings) + either (const (notFound ctx target path)) (const ok) (found <> fmap head otherBindings) where otherBindings = fmap (: []) (lookupBinderInContextEnv ctx path) - <|> multiLookupBinderEverywhere ctx path + <> (Right (lookupBinderEverywhere (contextGlobalEnv ctx) name)) _ -> do let found = lookupBinderInTypeEnv ctx path let others = lookupBinderInContextEnv ctx path _ <- printIfFound found - _ <- maybe (pure ()) printer others - maybe (notFound ctx target path) (const ok) (found <|> others) + _ <- either (const (pure ())) printer others + either (const (notFound ctx target path)) (const ok) (found <> others) where ok :: IO (Context, Either EvalError XObj) ok = pure (ctx, dynamicNil) - printInterfaceImplementationsOrAll :: Maybe Binder -> Maybe [Binder] -> IO () + printInterfaceImplementationsOrAll :: Either ContextError Binder -> Either ContextError [Binder] -> IO () printInterfaceImplementationsOrAll interface impls = - maybe - (pure ()) + either + (const (pure ())) (foldM (\_ binder -> printer binder) ()) ( ( interface >>= \binder -> @@ -302,7 +308,7 @@ primitiveInfo _ ctx target@(XObj (Sym path@(SymPath _ _) _) _ _) = fmap (filter (implementsInterface binder)) impls _ -> impls ) - <|> impls + <> impls ) implementsInterface :: Binder -> Binder -> Bool implementsInterface binder binder' = @@ -310,8 +316,8 @@ primitiveInfo _ ctx target@(XObj (Sym path@(SymPath _ _) _) _ _) = False (\(XObj (Lst impls) _ _) -> getBinderPath binder `elem` map getPath impls) (Meta.getBinderMetaValue "implements" binder') - printIfFound :: Maybe Binder -> IO () - printIfFound = maybe (pure ()) printer + printIfFound :: Either ContextError Binder -> IO () + printIfFound = either (const (pure ())) printer printer :: Binder -> IO () printer binder@(Binder metaData x@(XObj _ (Just i) _)) = putStrLnWithColor Blue (forceShowBinder binder) @@ -345,101 +351,63 @@ dynamicOrMacroWith :: Context -> (SymPath -> [XObj]) -> Ty -> String -> XObj -> dynamicOrMacroWith ctx producer ty name body = do let qpath = qualifyPath ctx (SymPath [] name) elt = XObj (Lst (producer (unqualify qpath))) (xobjInfo body) (Just ty) - meta = lookupMeta (getPath elt) (contextGlobalEnv ctx) - pure (insertInGlobalEnv ctx qpath (Binder meta elt), dynamicNil) + meta = fromRight emptyMeta (lookupMeta (contextGlobalEnv ctx) (getPath elt)) + pure + ( case (insertInGlobalEnv ctx qpath (Binder meta elt)) of + Left e -> evalError ctx (show e) (xobjInfo body) + Right c -> (c, dynamicNil) + ) +-- | Get the members of a type declaration. primitiveMembers :: UnaryPrimitiveCallback -primitiveMembers _ ctx target = do - case bottomedTarget target of - XObj (Sym path@(SymPath _ name) _) _ _ -> - case lookupBinderInTypeEnv ctx path of - Just - ( Binder - _ - ( XObj - ( Lst - [ XObj (Deftype _) Nothing Nothing, - XObj (Sym (SymPath _ _) Symbol) Nothing Nothing, - XObj (Arr members) _ _ - ] - ) - _ - _ - ) - ) -> - pure (ctx, Right (XObj (Arr (map (\(a, b) -> XObj (Lst [a, b]) Nothing Nothing) (pairwise members))) Nothing Nothing)) - Just - ( Binder - _ - ( XObj - ( Lst - ( XObj (DefSumtype _) Nothing Nothing - : XObj (Sym (SymPath _ _) Symbol) Nothing Nothing - : sumtypeCases - ) - ) - _ - _ - ) - ) -> - pure (ctx, Right (XObj (Arr (concatMap getMembersFromCase sumtypeCases)) Nothing Nothing)) - where - getMembersFromCase :: XObj -> [XObj] - getMembersFromCase (XObj (Lst members) _ _) = - map (\(a, b) -> XObj (Lst [a, b]) Nothing Nothing) (pairwise members) - getMembersFromCase x@(XObj (Sym _ _) _ _) = - [XObj (Lst [x, XObj (Arr []) Nothing Nothing]) Nothing Nothing] - getMembersFromCase (XObj x _ _) = - error ("Can't handle case " ++ show x) - _ -> - pure (evalError ctx ("Can't find a struct type named '" ++ name ++ "' in type environment") (xobjInfo target)) - _ -> pure (evalError ctx ("Can't get the members of non-symbol: " ++ pretty target) (xobjInfo target)) +primitiveMembers _ ctx xobj@(XObj (Sym path _) _ _) = + case (lookupBinderInTypeEnv ctx path) of + Left _ -> pure $ toEvalError ctx xobj (StructNotFound xobj) + Right b -> go (binderXObj b) where - bottomedTarget t = - case t of - XObj (Sym targetPath _) _ _ -> - case lookupBinderInContextEnv ctx targetPath 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 _) _ _)) -> t - -- if we’re recursing into a non-sym, we’ll stop one level down - Just (Binder _ x) -> bottomedTarget x - _ -> target - _ -> target + go :: XObj -> IO (Context, Either EvalError XObj) + go (XObj (Lst [(XObj (Deftype _) _ _), _, (XObj (Arr members) _ _)]) _ _) = + pure (ctx, Right (XObj (Arr (map (\(a, b) -> XObj (Lst [a, b]) Nothing Nothing) (pairwise members))) Nothing Nothing)) + go (XObj (Lst ((XObj (DefSumtype _) _ _) : _ : cases)) _ _) = + pure $ (ctx, (either Left (\a -> Right (XObj (Arr (concat a)) Nothing Nothing)) (mapM getMembersFromCase cases))) + go x = pure (toEvalError ctx x (NonTypeInTypeEnv path x)) + + getMembersFromCase :: XObj -> Either EvalError [XObj] + getMembersFromCase (XObj (Lst members) _ _) = + Right (map (\(a, b) -> XObj (Lst [a, b]) Nothing Nothing) (pairwise members)) + getMembersFromCase x@(XObj (Sym _ _) _ _) = + Right [XObj (Lst [x, XObj (Arr []) Nothing Nothing]) Nothing Nothing] + getMembersFromCase x = + second (: []) (snd (toEvalError ctx x (PrimitiveError.InvalidSumtypeCase x))) +primitiveMembers _ ctx x = argumentErr ctx "members" "a symbol" "first" x -- | Set meta data for a Binder +-- +-- Permits "forward-declaration": if the binder doesn't exist, it creates a +-- "meta stub" for the binder with the meta information. primitiveMetaSet :: TernaryPrimitiveCallback -primitiveMetaSet _ ctx target@(XObj (Sym path@(SymPath prefixes _) _) _ _) (XObj (Str key) _ _) value = - pure $ maybe create (,dynamicNil) lookupAndUpdate +primitiveMetaSet _ ctx target@(XObj (Sym path@(SymPath _ _) _) _ _) (XObj (Str key) _ _) value = + pure $ either (const create) (,dynamicNil) (lookupGlobal <> lookupType) where qpath = qualifyPath ctx path - fullPath@(SymPath modules _) = unqualify qpath - lookupAndUpdate :: Maybe Context - lookupAndUpdate = - ( lookupBinderInGlobalEnv ctx path - >>= \binder -> - pure (Meta.updateBinderMeta binder key value) - >>= pure . (insertInGlobalEnv ctx qpath) - ) - -- This is a global name but it doesn't exist in the global env - -- Before creating a new binder, check that it doesn't denote an existing type or interface. - <|> if null modules - then - lookupBinderInTypeEnv ctx qpath - >>= \binder -> - pure (Meta.updateBinderMeta binder key value) - >>= pure . (insertInTypeEnv ctx qpath) - else Nothing + lookupGlobal :: Either ContextError Context + lookupGlobal = + lookupBinderInGlobalEnv ctx path + >>= \binder -> + pure (Meta.updateBinderMeta binder key value) + >>= insertInGlobalEnv ctx qpath + lookupType :: Either ContextError Context + lookupType = + lookupBinderInTypeEnv ctx qpath + >>= \binder -> + pure (Meta.updateBinderMeta binder key value) + >>= insertTypeBinder ctx qpath create :: (Context, Either EvalError XObj) create = - -- TODO: Remove the special casing here (null check) and throw a general - -- error when modules don't exist - if null prefixes - then - let updated = Meta.updateBinderMeta (Meta.stub fullPath) key value - in (insertInGlobalEnv ctx qpath updated, dynamicNil) - else evalError ctx ("`meta-set!` failed, I can't find the symbol `" ++ pretty target ++ "`") (xobjInfo target) + let updated = Meta.updateBinderMeta (Meta.stub (unqualify qpath)) key value + in case (insertInGlobalEnv ctx qpath updated) of + Left e -> toEvalError ctx target (MetaSetFailed target (show e)) + Right c -> (c, dynamicNil) primitiveMetaSet _ ctx (XObj (Sym (SymPath _ _) _) _ _) key _ = argumentErr ctx "meta-set!" "a string" "second" key primitiveMetaSet _ ctx target _ _ = @@ -450,13 +418,13 @@ primitiveDefinterface xobj ctx nameXObj@(XObj (Sym path@(SymPath [] name) _) _ _ pure $ maybe invalidType validType (xobjToTy ty) where invalidType = evalError ctx ("Invalid type for interface `" ++ name ++ "`: " ++ pretty ty) (xobjInfo ty) - validType t = maybe defInterface updateInterface (lookupBinderInTypeEnv ctx path) + validType t = either (const defInterface) updateInterface (lookupBinderInTypeEnv ctx path) where defInterface = let interface = defineInterface name t [] (xobjInfo nameXObj) binder = toBinder interface - ctx' = insertInTypeEnv ctx (markQualified (SymPath [] name)) binder - newCtx = retroactivelyRegisterInInterface ctx' binder + Right ctx' = insertTypeBinder ctx (markQualified (SymPath [] name)) binder + Right newCtx = retroactivelyRegisterInInterface ctx' binder in (newCtx, dynamicNil) updateInterface binder = case binder of Binder _ (XObj (Lst (XObj (Interface foundType _) _ _ : _)) _ _) -> @@ -502,8 +470,10 @@ registerInternal ctx name ty override = ) (xobjInfo ty) (Just t) - meta = lookupMeta (getPath registration) (contextGlobalEnv ctx) - in (insertInGlobalEnv ctx qpath (Binder meta registration), dynamicNil) + meta = fromRight emptyMeta (lookupMeta (contextGlobalEnv ctx) (getPath registration)) + in case (insertInGlobalEnv ctx qpath (Binder meta registration)) of + Left err -> evalError ctx (show err) (xobjInfo ty) + Right c -> (c, dynamicNil) primitiveRegister :: VariadicPrimitiveCallback primitiveRegister _ ctx [XObj (Sym (SymPath [] name) _) _ _, ty] = @@ -549,147 +519,158 @@ primitiveRegister x ctx _ = ) primitiveDeftype :: VariadicPrimitiveCallback -primitiveDeftype xobj ctx (name : rest) = - case rest of - (XObj (Arr a) _ _ : _) -> - case members a of - Nothing -> - pure $ - makeEvalError - ctx - Nothing - ( "All fields must have a name and a type." - ++ "Example:\n" - ++ "```(deftype Name [field1 Type1, field2 Type2, field3 Type3])```\n" - ) - (xobjInfo xobj) - Just ms -> - ensureUnqualified $ map fst ms - where - members :: [XObj] -> Maybe [(XObj, XObj)] - members (binding : val : xs) = do - xs' <- members xs - Just $ (binding, val) : xs' - members [_] = Nothing - members [] = Just [] - ensureUnqualified :: [XObj] -> IO (Context, Either EvalError XObj) - ensureUnqualified objs = - if all isUnqualifiedSym objs - then deftype name - else - pure $ - makeEvalError - ctx - Nothing - ( "Type members must be unqualified symbols, but got `" - ++ concatMap pretty rest - ++ "`" - ) - (xobjInfo xobj) - _ -> deftype name +primitiveDeftype xobj ctx (name : rest@(XObj (Arr a) _ _ : _)) = + case members a of + Nothing -> pure (toEvalError ctx xobj BadDeftypeMembers) + Just ms -> ensureUnqualified (map fst ms) where - deftype nm@(XObj (Sym (SymPath _ ty) _) _ _) = deftype' nm ty [] - deftype (XObj (Lst (nm@(XObj (Sym (SymPath _ ty) _) _ _) : tyvars)) _ _) = - deftype' nm ty tyvars - deftype nm = - pure - ( evalError - ctx - ("Invalid name for type definition: " ++ pretty nm) - (xobjInfo nm) - ) - deftype' :: XObj -> String -> [XObj] -> IO (Context, Either EvalError XObj) - deftype' nameXObj typeName typeVariableXObjs = do - let pathStrings = contextPath ctx - env = contextGlobalEnv ctx - innerEnv = contextInternalEnv ctx - typeEnv = contextTypeEnv ctx - typeVariables = mapM xobjToTy typeVariableXObjs - (preExistingModule, preExistingMeta) = - case lookupBinder (SymPath pathStrings typeName) (fromMaybe env innerEnv) {envParent = Nothing} 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) - then (moduleForDeftype, Deftype) - else (moduleForSumtype, DefSumtype) - case (nameXObj, typeVariables) of - (XObj (Sym (SymPath _ tyName) _) i _, Just okTypeVariables) -> - case creatorFunction (Just (getEnv env pathStrings)) typeEnv env pathStrings tyName okTypeVariables rest i preExistingModule of - Right (typeModuleName, typeModuleXObj, deps) -> - let structTy = StructTy (ConcreteNameTy (createStructName pathStrings tyName)) okTypeVariables - updatedGlobal = insertInGlobalEnv ctx (qualifyPath ctx (SymPath [] typeModuleName)) (Binder preExistingMeta typeModuleXObj) - typeDefinition = - -- NOTE: The type binding is needed to emit the type definition and all the member functions of the type. - XObj - ( Lst - ( XObj (typeConstructor structTy) Nothing Nothing : - XObj (Sym (SymPath pathStrings tyName) Symbol) Nothing Nothing : - rest - ) - ) - i - (Just TypeTy) - holderEnv name' prev = Env (Map.fromList []) (Just prev) (Just name') Set.empty ExternalEnv 0 - holderModule name'' prevEnv priorPaths tyenv = - case lookupBinder (SymPath priorPaths name'') tyenv of - Just existing@(Binder _ (XObj (Mod _) _ _)) -> existing - _ -> Binder emptyMeta (XObj (Mod (holderEnv name'' prevEnv)) (Just dummyInfo) (Just ModuleTy)) - folder (contx, prev, priorPaths) pathstring = - (insertInTypeEnv contx (markQualified (SymPath priorPaths pathstring)) (holderModule pathstring prev priorPaths (getTypeEnv (contextTypeEnv contx))), holderEnv pathstring prev, priorPaths ++ [pathstring]) - (wHolders, _, _) = (foldl' folder (ctx, getTypeEnv typeEnv, []) pathStrings) - update = insertInTypeEnv' (markQualified (SymPath pathStrings tyName)) (toBinder typeDefinition) . replaceGlobalEnv' (contextGlobalEnv updatedGlobal) - ctx' = update wHolders - in do - -- TODO: !This is a case where `define` doesn't actually receive fully qualified xobjs. - ctxWithDeps <- liftIO (foldM (define True) ctx' (map Qualified deps)) - let fakeImplBinder sympath t = Binder emptyMeta (XObj (Sym sympath Symbol) (Just dummyInfo) (Just t)) - deleteSig = FuncTy [structTy] UnitTy StaticLifetimeTy - strSig = FuncTy [RefTy structTy (VarTy "q")] StringTy StaticLifetimeTy - copySig = FuncTy [RefTy structTy (VarTy "q")] structTy StaticLifetimeTy - Just deleteInterface = lookupBinderInTypeEnv ctx (markQualified (SymPath [] "delete")) - Just strInterface = lookupBinderInTypeEnv ctx (markQualified (SymPath [] "str")) - Just copyInterface = lookupBinderInTypeEnv ctx (markQualified (SymPath [] "copy")) - modulePath = SymPath (pathStrings ++ [typeModuleName]) - (ctxWithInterfaceRegistrations, err) = - -- Since these functions are autogenerated, we treat them as a special case - -- and automatically implement the interfaces. - foldl' - (\(context, _) (path, sig, interface) -> registerInInterfaceIfNeeded context path interface sig) - (ctxWithDeps, Nothing) - [ (fakeImplBinder (modulePath "delete") deleteSig, deleteSig, deleteInterface), - (fakeImplBinder (modulePath "str") strSig, strSig, strInterface), - (fakeImplBinder (modulePath "copy") copySig, copySig, copyInterface) - ] - case err of - Just e@AlreadyImplemented {} -> - emitWarning (show e) - >> pure (ctxWithInterfaceRegistrations, dynamicNil) - Just e -> - putStrLnWithColor Red (show e) - >> pure (ctx, dynamicNil) - Nothing -> pure (ctxWithInterfaceRegistrations, dynamicNil) - Left err -> - pure (makeEvalError ctx (Just err) ("Invalid type definition for '" ++ pretty nameXObj ++ "':\n\n" ++ show err) Nothing) - (_, Nothing) -> - pure (makeEvalError ctx Nothing ("Invalid type variables for type definition: " ++ pretty nameXObj) (xobjInfo nameXObj)) - _ -> error "primitiveDeftype1" + members :: [XObj] -> Maybe [(XObj, XObj)] + members [] = Just [] + members [_] = Nothing + members (binding : val : xs) = members xs >>= \xs' -> pure $ (binding, val) : xs' + ensureUnqualified :: [XObj] -> IO (Context, Either EvalError XObj) + ensureUnqualified objs = + if all isUnqualifiedSym objs + then deftype ctx name (selectConstructor rest) + else pure (toEvalError ctx xobj (QualifiedTypeMember rest)) +primitiveDeftype _ ctx (name : rest) = + deftype ctx name (selectConstructor rest) primitiveDeftype _ _ _ = error "primitivedeftype" +type ModuleCreator = Context -> String -> [Ty] -> [XObj] -> Maybe Info -> Either TypeError (String, XObj, [XObj]) + +-- | Build an XObj representing the constructor of a type in Carp. +selectConstructor :: [XObj] -> (Ty -> (XObj, [XObj], ModuleCreator)) +selectConstructor xs = + let (constructor, creator, mems) = + if length xs == 1 && isArray (head xs) + then (Deftype, moduleForDeftypeInContext, xs) + else (DefSumtype, moduleForSumtypeInContext, xs) + in \t -> + ( XObj + ( Lst + ( XObj (constructor t) Nothing Nothing : + XObj (Sym (getStructPath t) Symbol) Nothing Nothing : + mems + ) + ) + Nothing + (Just TypeTy), + mems, + creator + ) + +deftype :: Context -> XObj -> (Ty -> (XObj, [XObj], ModuleCreator)) -> IO (Context, Either EvalError XObj) +deftype ctx x@(XObj (Sym (SymPath [] name) _) _ _) constructor = + do + (ctxWithType, e) <- (makeType ctx name [] constructor) + case e of + Left err -> pure (evalError ctx (show err) (xobjInfo x)) + Right t -> autoDerive ctxWithType t +deftype ctx x@(XObj (Lst ((XObj (Sym (SymPath [] name) _) _ _) : tyvars)) _ _) constructor = + do + (ctxWithType, e) <- + ( either + (\s -> pure (evalError ctx s Nothing)) + (\vars -> makeType ctx name vars constructor) + (maybe (Left (show (InvalidTypeVariables x))) Right (checkVariables tyvars)) + ) + case e of + Left err -> pure (evalError ctx (show err) (xobjInfo x)) + Right t -> autoDerive ctxWithType t +deftype ctx name _ = pure $ toEvalError ctx name (InvalidTypeName name) + +checkVariables :: [XObj] -> Maybe [Ty] +checkVariables vars = mapM xobjToTy vars + +makeType :: Context -> String -> [Ty] -> (Ty -> (XObj, [XObj], ModuleCreator)) -> IO (Context, Either EvalError Ty) +makeType ctx name vars constructor = + let qpath = (qualifyPath ctx (SymPath [] name)) + ty = StructTy (ConcreteNameTy (unqualify qpath)) vars + (typeX, members, creator) = constructor ty + in case ( unwrapErr (creator ctx name vars members Nothing) + >>= \(_, modx, deps) -> + pure (existingOr ctx qpath modx) + >>= \mod' -> + unwrapErr (insertType ctx qpath (toBinder typeX) mod') + >>= \c -> pure (foldM (define True) c (map Qualified deps)) + ) of + Left e -> pure (evalError ctx e (xobjInfo typeX)) + Right result -> (result >>= \ctx' -> pure (ctx', pure ty)) + where + existingOr :: Context -> QualifiedPath -> XObj -> Binder + existingOr c q x@(XObj (Mod e _) _ _) = + case ((lookupBinderInInternalEnv c q) <> (lookupBinderInGlobalEnv c q)) of + Right (Binder meta (XObj (Mod ve te) ii tt)) -> + (Binder meta (XObj (Mod (e <> ve) te) ii tt)) + _ -> (toBinder x) + existingOr _ _ x = (toBinder x) + +-- | Automatically derive implementations of interfaces. +autoDerive :: Context -> Ty -> IO (Context, Either EvalError XObj) +autoDerive c ty = + let (SymPath mods tyname) = (getStructPath ty) + implBinder :: String -> Ty -> Binder + implBinder name t = Binder emptyMeta (XObj (Sym (SymPath (mods ++ [tyname]) name) Symbol) (Just dummyInfo) (Just t)) + getSig :: String -> Ty + getSig "delete" = FuncTy [ty] UnitTy StaticLifetimeTy + getSig "str" = FuncTy [RefTy ty (VarTy "q")] StringTy StaticLifetimeTy + getSig "copy" = FuncTy [RefTy ty (VarTy "q")] ty StaticLifetimeTy + getSig _ = VarTy "z" + interfaces = + [ lookupBinderInTypeEnv c (markQualified (SymPath [] "delete")), + lookupBinderInTypeEnv c (markQualified (SymPath [] "str")), + lookupBinderInTypeEnv c (markQualified (SymPath [] "copy")) + ] + registration interface = + let name = getSimpleName (binderXObj interface) + sig = getSig name + in (implBinder name sig, sig, interface) + derives = + (sequence interfaces) + >>= \binders -> pure (fmap registration binders) + in case derives of + Left _ -> pure (evalError c "Couldn't derive interfaces." Nothing) + Right regs -> + case foldl' (\(context, _) (path, sig, interface) -> first (fromRight (error "COULDNT DERIVE!")) (registerInInterfaceIfNeeded context path interface sig)) (c, Nothing) regs of + (ci, Just err@AlreadyImplemented {}) -> emitWarning (show err) >> pure (ci, dynamicNil :: Either EvalError XObj) + (_, Just err) -> pure $ evalError c (show err) Nothing + (ci, Nothing) -> pure (ci, dynamicNil :: Either EvalError XObj) + +-- | Add a module to the list of implicitly imported modules. primitiveUse :: UnaryPrimitiveCallback primitiveUse xobj ctx (XObj (Sym path _) _ _) = - pure $ maybe lookupInGlobal useModule (lookupInEnv path e) + let modulePath = fromStrings (contextPath ctx) + contextualized = (consPath (contextPath ctx) path) + global = (contextGlobalEnv ctx) + -- Look up the module to see if we can actually use it. + -- The reference might be contextual, if so, append the current context path strings. + path' = case (searchValueBinder global path) of + Right _ -> path + _ -> contextualized + in pure + ( case modulePath of + (SymPath [] "") -> updateGlobalUsePaths global path' + _ -> case searchValueBinder global modulePath of + Left err -> (evalError ctx (show err) (xobjInfo xobj)) + Right binder -> + updateModuleUsePaths global modulePath binder path' + ) where - pathStrings = contextPath ctx - env = contextGlobalEnv ctx - e = getEnv env pathStrings - useThese = envUseModules e - e' = e {envUseModules = Set.insert path useThese} - lookupInGlobal = maybe missing useModule (lookupInEnv path env) - where - missing = evalError ctx ("Can't find a module named '" ++ show path ++ "'") (xobjInfo xobj) - useModule _ = (replaceGlobalEnv ctx (envReplaceEnvAt env pathStrings e'), dynamicNil) + updateGlobalUsePaths :: Env -> SymPath -> (Context, Either EvalError XObj) + updateGlobalUsePaths e spath = + ((replaceGlobalEnv ctx (addUsePath e spath)), dynamicNil) + + updateModuleUsePaths :: Env -> SymPath -> Binder -> SymPath -> (Context, Either EvalError XObj) + updateModuleUsePaths e p (Binder meta (XObj (Mod ev et) i t)) spath = + either + (\err -> (evalError ctx err (xobjInfo xobj))) + (\newCtx -> (newCtx, dynamicNil)) + ( (unwrapErr (insert e p (Binder meta (XObj (Mod (addUsePath ev spath) et) i t)))) + >>= pure . replaceGlobalEnv ctx + ) + updateModuleUsePaths _ _ _ _ = + (evalError ctx "Context path pointed to non-module!" (xobjInfo xobj)) primitiveUse _ ctx x = argumentErr ctx "use" "a symbol" "first" x @@ -699,7 +680,7 @@ primitiveMeta (XObj _ i _) ctx (XObj (Sym path _) _ _) (XObj (Str key) _ _) = pure $ maybe errNotFound foundBinder lookup' where lookup' :: Maybe Binder - lookup' = (lookupBinderInGlobalEnv ctx path <|> lookupBinderInTypeEnv ctx path) >>= pure + lookup' = either (const Nothing) Just (lookupBinderInGlobalEnv ctx path <> lookupBinderInTypeEnv ctx path) foundBinder :: Binder -> (Context, Either EvalError XObj) foundBinder binder = (ctx, maybe dynamicNil Right (Meta.getBinderMetaValue key binder)) errNotFound :: (Context, Either EvalError XObj) @@ -711,14 +692,14 @@ primitiveMeta _ ctx path _ = primitiveDefined :: UnaryPrimitiveCallback primitiveDefined _ ctx (XObj (Sym path _) _ _) = - pure $ maybe (ctx, Right falseXObj) (const (ctx, Right trueXObj)) (lookupBinderInContextEnv ctx path) + pure $ either (const (ctx, Right falseXObj)) (const (ctx, Right trueXObj)) (lookupBinderInContextEnv ctx path) primitiveDefined _ ctx arg = argumentErr ctx "defined" "a symbol" "first" arg primitiveDeftemplate :: QuaternaryPrimitiveCallback -- deftemplate can't receive a dependency function, as Ty aren't exposed in Carp primitiveDeftemplate _ ctx (XObj (Sym p@(SymPath [] _) _) _ _) ty (XObj (Str declTempl) _ _) (XObj (Str defTempl) _ _) = - pure $ maybe invalidType validType (xobjToTy ty) + pure $ maybe invalidType (fromRight invalidType . fmap (\x -> (x, dynamicNil)) . validType) (xobjToTy ty) where typeEnv = contextTypeEnv ctx globalEnv = contextGlobalEnv ctx @@ -728,13 +709,13 @@ primitiveDeftemplate _ ctx (XObj (Sym p@(SymPath [] _) _) _ _) ty (XObj (Str dec if isTypeGeneric t then let (Binder _ registration) = b - meta = lookupMeta (getPath registration) globalEnv - in (insertInGlobalEnv ctx (qualifyPath ctx p) (Binder meta registration), dynamicNil) + meta = fromRight emptyMeta (lookupMeta globalEnv (getPath registration)) + in insertInGlobalEnv ctx (qualifyPath ctx p) (Binder meta registration) else let templateCreator = getTemplateCreator template (registration, _) = instantiateTemplate (contextualize p ctx) t (templateCreator typeEnv globalEnv) - meta = lookupMeta (getPath registration) globalEnv - in (insertInGlobalEnv ctx (qualifyPath ctx p) (Binder meta registration), dynamicNil) + meta = fromRight emptyMeta (lookupMeta globalEnv (getPath registration)) + in insertInGlobalEnv ctx (qualifyPath ctx p) (Binder meta registration) _ -> error "primitivedeftemplate1" primitiveDeftemplate _ ctx (XObj (Sym (SymPath [] _) _) _ _) _ (XObj (Str _) _ _) x = argumentErr ctx "deftemplate" "a string" "fourth" x @@ -754,10 +735,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 (lookupBinderInGlobalEnv ctx path) + fromRight otherDefs (second go (lookupBinderInGlobalEnv ctx path)) where env = contextGlobalEnv ctx - otherDefs = case multiLookupEverywhere name env of + otherDefs = case lookupEverywhere env name of [] -> notFound ctx x path binders -> @@ -771,7 +752,7 @@ primitiveType _ ctx x@(XObj (Sym path@(SymPath [] name) _) _ _) = Nothing -> noTypeError ctx x Just t -> pure (ctx, Right (reify t)) primitiveType _ ctx x@(XObj (Sym qualifiedPath _) _ _) = - maybe (notFound ctx x qualifiedPath) go (lookupBinderInGlobalEnv ctx qualifiedPath) + fromRight (notFound ctx x qualifiedPath) (second go (lookupBinderInGlobalEnv ctx qualifiedPath)) where go binder = case xobjTy (binderXObj binder) of diff --git a/src/Qualify.hs b/src/Qualify.hs index 51d0c349..5f44e866 100644 --- a/src/Qualify.hs +++ b/src/Qualify.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TupleSections #-} + -------------------------------------------------------------------------------- -- | Defines data, errors, and functions for qualifying symbols in a given @@ -16,15 +18,14 @@ module Qualify where import Control.Monad (foldM, liftM) -import Data.List (foldl') -import Debug.Trace -import Env +import Data.Bifunctor +import Data.Either (fromRight) +import qualified Env as E import Info -import Lookup import qualified Map import Obj import qualified Set -import Types +import SymPath import Util -------------------------------------------------------------------------------- @@ -35,6 +36,11 @@ data QualificationError = FailedToQualifyDeclarationName XObj | FailedToQualifySymbols XObj | FailedToQualifyPath SymPath + | NonVariableInMatch XObj + | NakedInitForUnnamedModule [String] + | QualifiedMulti SymPath + | LocalMulti SymPath [(Env, Binder)] + | FailedToFindSymbol XObj instance Show QualificationError where show (FailedToQualifyDeclarationName xobj) = @@ -44,6 +50,18 @@ instance Show QualificationError where show (FailedToQualifyPath spath) = "Couldn't fully qualify the symbol: " ++ show spath ++ "in the given context." + show (NonVariableInMatch xobj) = + "Couldn't qualify the xobj: " ++ pretty xobj + ++ "in a match expression." + show (NakedInitForUnnamedModule s) = + "Tried to emit a naked init for an unnamed module: " ++ (show s) + show (QualifiedMulti spath) = + "Tried to use a qualified symbol as a multi sym: " ++ (show spath) + show (LocalMulti spath binders) = + "Tried to use a symbol that has local bindings as a multi sym: " ++ show spath + ++ show binders + show (FailedToFindSymbol xobj) = + "Couldn't find the xobj: " ++ pretty xobj -------------------------------------------------------------------------------- -- Data @@ -52,7 +70,7 @@ instance Show QualificationError where -- -- A fully qualified xobj **must not** be qualified further (e.g. using context -- paths). -newtype Qualified = Qualified {unQualified :: XObj} +newtype Qualified = Qualified {unQualified :: XObj} deriving (Show) -- | Denotes a symbol that has been fully qualified. newtype QualifiedPath = QualifiedPath SymPath @@ -115,10 +133,10 @@ qualify ctx xobj@(XObj obj info ty) = -- TODO: Merge this with setFullyQualifiedSymbols case obj of Lst [defn, (XObj (Sym (SymPath _ name) mode) symi symt), args, body] -> - setFullyQualifiedSymbols t g i (XObj (Lst [defn, (XObj (Sym (SymPath pathStrings name) mode) symi symt), args, body]) info ty) + inner >>= \i -> setFullyQualifiedSymbols t g i (XObj (Lst [defn, (XObj (Sym (SymPath pathStrings name) mode) symi symt), args, body]) info ty) Lst [def, XObj (Sym (SymPath _ name) mode) symi symt, expr] -> - setFullyQualifiedSymbols t g i (XObj (Lst [def, (XObj (Sym (SymPath pathStrings name) mode) symi symt), expr]) info ty) - _ -> setFullyQualifiedSymbols t g i xobj + inner >>= \i -> setFullyQualifiedSymbols t g i (XObj (Lst [def, (XObj (Sym (SymPath pathStrings name) mode) symi symt), expr]) info ty) + _ -> inner >>= \i -> setFullyQualifiedSymbols t g i xobj where pathStrings :: [String] pathStrings = contextPath ctx @@ -126,8 +144,8 @@ qualify ctx xobj@(XObj obj info ty) = t = contextTypeEnv ctx g :: Env g = contextGlobalEnv ctx - i :: Env - i = getEnv g pathStrings + inner :: Either QualificationError Env + inner = replaceLeft (FailedToQualifySymbols xobj) (E.getInnerEnv g pathStrings) -- | Changes all symbols EXCEPT bound vars (defn names, variable names, etc) to their fully qualified paths. -- | This must run after the 'setFullyQualifiedDefn' function has fixed the paths of all bindings in the environment. @@ -176,29 +194,32 @@ type Qualifier = TypeEnv -> Env -> Env -> XObj -> Either QualificationError Qual -- | Qualify the symbols in a Defn form's body. qualifyFunctionDefinition :: Qualifier -qualifyFunctionDefinition typeEnv globalEnv env (XObj (Lst [defn@(XObj (Defn _) _ _), sym@(XObj (Sym (SymPath _ functionName) _) _ _), args@(XObj (Arr argsArr) _ _), body]) i t) = +qualifyFunctionDefinition typeEnv globalEnv env x@(XObj (Lst [defn@(XObj (Defn _) _ _), sym@(XObj (Sym (SymPath _ functionName) _) _ _), args@(XObj (Arr argsArr) _ _), body]) i t) = -- For self-recursion, there must be a binding to the function in the inner env. -- It is marked as RecursionEnv basically is the same thing as external to not mess up lookup. -- Inside the recursion env is the function env that contains bindings for the arguments of the function. -- Note: These inner envs is ephemeral since they are not stored in a module or global scope. do - let recursionEnv = Env Map.empty (Just env) (Just (functionName ++ "-recurse-env")) Set.empty RecursionEnv 0 - envWithSelf = extendEnv recursionEnv functionName sym - functionEnv = Env Map.empty (Just envWithSelf) Nothing Set.empty InternalEnv 0 - envWithArgs = foldl' (\e arg@(XObj (Sym (SymPath _ argSymName) _) _ _) -> extendEnv e argSymName arg) functionEnv argsArr + recursionEnv <- fixLeft (pure (E.recursive (Just env) (Just (functionName ++ "-recurse-env")) 0)) + envWithSelf <- fixLeft (E.insertX recursionEnv (SymPath [] functionName) sym) + -- Copy the use modules from the local env to ensure they are available from the function env. + functionEnv <- fixLeft (pure ((E.nested (Just envWithSelf) (Just (functionName ++ "-function-env")) 0) {envUseModules = (envUseModules env)})) + envWithArgs <- fixLeft (foldM (\e arg@(XObj (Sym path _) _ _) -> E.insertX e path arg) functionEnv argsArr) qualifiedBody <- liftM unQualified (setFullyQualifiedSymbols typeEnv globalEnv envWithArgs body) pure (Qualified (XObj (Lst [defn, sym, args, qualifiedBody]) i t)) + where + fixLeft = replaceLeft (FailedToQualifyDeclarationName x) qualifyFunctionDefinition _ _ _ xobj = Left $ FailedToQualifyDeclarationName xobj -- | Qualify the symbols in a lambda body. qualifyLambda :: Qualifier -qualifyLambda typeEnv globalEnv env (XObj (Lst [fn@(XObj (Fn _ _) _ _), args@(XObj (Arr argsArr) _ _), body]) i t) = - do - let lvl = envFunctionNestingLevel env - functionEnv = Env Map.empty (Just env) Nothing Set.empty InternalEnv (lvl + 1) - envWithArgs = foldl' (\e arg@(XObj (Sym (SymPath _ argSymName) _) _ _) -> extendEnv e argSymName arg) functionEnv argsArr - qualifiedBody <- liftM unQualified (setFullyQualifiedSymbols typeEnv globalEnv envWithArgs body) - pure (Qualified (XObj (Lst [fn, args, qualifiedBody]) i t)) +qualifyLambda typeEnv globalEnv env x@(XObj (Lst [fn@(XObj (Fn _ _) _ _), args@(XObj (Arr argsArr) _ _), body]) i t) = + let lvl = envFunctionNestingLevel env + functionEnv = Env Map.empty (Just env) Nothing Set.empty InternalEnv (lvl + 1) + in (replaceLeft (FailedToQualifySymbols x) (foldM (\e arg@(XObj (Sym path _) _ _) -> E.insertX e path arg) functionEnv argsArr)) + >>= \envWithArgs -> + liftM unQualified (setFullyQualifiedSymbols typeEnv globalEnv envWithArgs body) + >>= \qualifiedBody -> pure (Qualified (XObj (Lst [fn, args, qualifiedBody]) i t)) qualifyLambda _ _ _ xobj = Left $ FailedToQualifySymbols xobj -- | Qualify the symbols in a The form's body. @@ -219,7 +240,7 @@ qualifyDef _ _ _ xobj = Left $ FailedToQualifySymbols xobj -- | Qualify the symbols in a Let form's bindings and body. qualifyLet :: Qualifier -qualifyLet typeEnv globalEnv env (XObj (Lst [letExpr@(XObj Let _ _), bind@(XObj (Arr bindings) bindi bindt), body]) i t) +qualifyLet typeEnv globalEnv env x@(XObj (Lst [letExpr@(XObj Let _ _), bind@(XObj (Arr bindings) bindi bindt), body]) i t) | odd (length bindings) = Right $ Qualified $ XObj (Lst [letExpr, bind, body]) i t -- Leave it untouched for the compiler to find the error. | not (all isSym (evenIndices bindings)) = Right $ Qualified $ XObj (Lst [letExpr, bind, body]) i t -- Leave it untouched for the compiler to find the error. | otherwise = @@ -232,17 +253,19 @@ qualifyLet typeEnv globalEnv env (XObj (Lst [letExpr@(XObj Let _ _), bind@(XObj pure (Qualified (XObj (Lst [letExpr, XObj (Arr qualifiedBindings) bindi bindt, qualifiedBody]) i t)) where qualifyBinding :: (Env, [XObj]) -> (XObj, XObj) -> Either QualificationError (Env, [XObj]) - qualifyBinding (e, bs) (s@(XObj (Sym (SymPath _ binderName) _) _ _), o) = + qualifyBinding (e, bs) (s@(XObj (Sym path _) _ _), o) = do qualified <- liftM unQualified (setFullyQualifiedSymbols typeEnv globalEnv e o) - (pure (extendEnv e binderName s, bs ++ [s, qualified])) + updated <- (replaceLeft (FailedToQualifySymbols x) (E.insertX e path s)) + (pure (updated, bs ++ [s, qualified])) qualifyBinding _ _ = error "bad let binding" qualifyLet _ _ _ xobj = Left $ FailedToQualifySymbols xobj -- | Qualify symbols in a Match form. qualifyMatch :: Qualifier qualifyMatch typeEnv globalEnv env (XObj (Lst (matchExpr@(XObj (Match _) _ _) : expr : casesXObjs)) i t) - | odd (length casesXObjs) = pure $ Qualified $ XObj (Lst (matchExpr : expr : casesXObjs)) i t -- Leave it untouched for the compiler to find the error. + -- Leave it untouched for the compiler to find the error. + | odd (length casesXObjs) = pure $ Qualified $ XObj (Lst (matchExpr : expr : casesXObjs)) i t | otherwise = do qualifiedExpr <- pure . unQualified =<< setFullyQualifiedSymbols typeEnv globalEnv env expr @@ -251,26 +274,33 @@ qualifyMatch typeEnv globalEnv env (XObj (Lst (matchExpr@(XObj (Match _) _ _) : where Just ii = i lvl = envFunctionNestingLevel env + -- Create an inner environment for each case. innerEnv :: Env - innerEnv = Env Map.empty (Just env) (Just ("case-env-" ++ show (infoIdentifier ii))) Set.empty InternalEnv lvl + innerEnv = E.nested (Just env) (Just ("case-env-" ++ show (infoIdentifier ii))) lvl + -- Qualify each case in the match form. qualifyCases :: (XObj, XObj) -> Either QualificationError [Qualified] qualifyCases (l@(XObj (Lst (_ : xs)) _ _), r) = do - let innerEnv' = foldl' foldVars innerEnv xs - qualifiedLHS <- setFullyQualifiedSymbols typeEnv globalEnv env l + innerEnv' <- foldM foldVars innerEnv xs + qualifiedLHS <- setFullyQualifiedSymbols typeEnv globalEnv innerEnv' l qualifiedRHS <- setFullyQualifiedSymbols typeEnv globalEnv innerEnv' r Right [qualifiedLHS, qualifiedRHS] + qualifyCases (wild@(XObj (Sym (SymPath _ "_") _) _ _), r) = + do + qualifiedLHS <- foldVars env wild >>= \e -> setFullyQualifiedSymbols typeEnv globalEnv e wild + qualifiedRHS <- setFullyQualifiedSymbols typeEnv globalEnv env r + Right [qualifiedLHS, qualifiedRHS] qualifyCases (l, r) = do qualifiedLHS <- setFullyQualifiedSymbols typeEnv globalEnv env l qualifiedRHS <- setFullyQualifiedSymbols typeEnv globalEnv env r Right [qualifiedLHS, qualifiedRHS] - foldVars :: Env -> XObj -> Env - foldVars env' v@(XObj (Sym (SymPath _ binderName) _) _ _) = extendEnv env' binderName v - -- Nested sumtypes - -- fold recursively -- is there a more efficient way? - foldVars _ (XObj (Lst (_ : ys)) _ _) = foldl' foldVars innerEnv ys - foldVars _ v = error ("Can't match variable with " ++ show v) + -- Add variables in a case to its environment + foldVars :: Env -> XObj -> Either QualificationError Env + foldVars env' v@(XObj (Sym path _) _ _) = (replaceLeft (FailedToQualifySymbols v) (E.insertX env' path v)) + -- Nested sumtypes; fold recursively -- is there a more efficient way? + foldVars _ (XObj (Lst (_ : ys)) _ _) = foldM foldVars innerEnv ys + foldVars _ v = Left $ NonVariableInMatch v qualifyMatch _ _ _ xobj = Left $ FailedToQualifySymbols xobj -- | Qualify symbols in a With form. @@ -291,104 +321,93 @@ qualifyLst typeEnv globalEnv env (XObj (Lst xobjs) i t) = qualifyLst _ _ _ xobj = Left $ FailedToQualifySymbols xobj -- | Qualify a single symbol. --- TODO: Clean this up qualifySym :: Qualifier -qualifySym typeEnv globalEnv localEnv xobj@(XObj (Sym path _) i t) = - Right $ - Qualified $ - case path of - -- Unqualified: - SymPath [] name -> - 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 - Just (foundEnv, _) -> - if envIsExternal foundEnv - then createInterfaceSym name - else doesNotBelongToAnInterface False localEnv - Nothing -> - --trace ("Will turn '" ++ show path ++ "' " ++ prettyInfoFromXObj xobj ++ " into an interface symbol.") - createInterfaceSym name - _ -> - doesNotBelongToAnInterface False localEnv - -- Qualified: - _ -> - doesNotBelongToAnInterface False localEnv +-- Unqualified path. +qualifySym typeEnv globalEnv localEnv xobj@(XObj (Sym path@(SymPath _ name) _) i t) = + ( ( ( replaceLeft + (FailedToFindSymbol xobj) + -- TODO: Why do we need getValue here? We should be able to restrict this + -- search only to direct children of the type environment, but this causes + -- errors. + ( fmap (\(e, b) -> ((E.prj typeEnv), (E.prj e, b))) (E.searchType typeEnv path) + <> fmap (localEnv,) (E.searchValue localEnv path) + <> fmap (globalEnv,) (E.searchValue globalEnv path) + ) + ) + >>= \(origin, (e, binder)) -> + resolve (E.prj origin) (E.prj e) (binderXObj binder) + >>= pure . Qualified + ) + <> ((resolveMulti path (E.lookupInUsed localEnv globalEnv path)) >>= pure . Qualified) + <> ((replaceLeft (FailedToFindSymbol xobj) (E.lookupContextually globalEnv path)) >>= (resolveMulti path) >>= pure . Qualified) + <> ((resolveMulti path (E.lookupEverywhere globalEnv name)) >>= pure . Qualified) + <> pure (Qualified xobj) + ) where - createInterfaceSym name = - XObj (InterfaceSym name) i t - captureOrNot foundEnv = - if envFunctionNestingLevel foundEnv < envFunctionNestingLevel localEnv - then Capture (envFunctionNestingLevel localEnv - envFunctionNestingLevel foundEnv) - else NoCapture - doesNotBelongToAnInterface :: Bool -> Env -> XObj - doesNotBelongToAnInterface finalRecurse theEnv = - let results = multiLookupQualified path theEnv - results' = removeThoseShadowedByRecursiveSymbol results - in case results' of - [] -> case envParent theEnv of - Just p -> - doesNotBelongToAnInterface False p - Nothing -> - -- OBS! The environment with no parent is the global env but it's an old one without the latest bindings! - if finalRecurse - then xobj -- This was the TRUE global env, stop here and leave 'xobj' as is. - else doesNotBelongToAnInterface True globalEnv - [(_, Binder _ foundOne@(XObj (Lst (XObj (External (Just overrideWithName)) _ _ : _)) _ _))] -> - XObj (Sym (getPath foundOne) (LookupGlobalOverride overrideWithName)) i t - [(e, Binder _ (XObj (Mod modEnv) _ _))] -> - -- Lookup of a "naked" module name means that the Carp code is trying to - -- instantiate a (nested) module with an implicit .init, e.g. (Pair 1 2) - case envModuleName modEnv of - Nothing -> error ("Can't get name from unqualified module path: " ++ show path) - Just name -> - let pathHere = pathToEnv e - in XObj (Sym (SymPath (pathHere ++ [name]) "init") (LookupGlobal CarpLand AFunction)) i t - [(e, Binder _ foundOne)] -> - case envMode e of - ExternalEnv -> - XObj - ( Sym - (getPath foundOne) - (LookupGlobal (if isExternalFunction foundOne then ExternalCode else CarpLand) (definitionMode foundOne)) - ) - i - t - RecursionEnv -> XObj (Sym (getPath foundOne) LookupRecursive) i t - _ -> - --trace ("\nLOCAL variable " ++ show (getPath foundOne) ++ ":\n" ++ prettyEnvironmentChain e) $ - XObj (Sym (getPath foundOne) (LookupLocal (captureOrNot e))) i t - multiple -> - case filter (not . envIsExternal . fst) multiple of - -- There is at least one local binding, use the path of that one: - (e, Binder _ local) : _ -> XObj (Sym (getPath local) (LookupLocal (captureOrNot e))) i t - -- There are no local bindings, this is allowed to become a multi lookup symbol: - [] -> - -- (trace $ "Turned " ++ show path ++ " into multisym: " ++ joinWithComma (map (show . (\(e, b) -> (getPath (binderXObj b), safeEnvModuleName e, envMode e))) multiple)) $ - case path of - (SymPath [] name) -> - -- Create a MultiSym! - XObj (MultiSym name (map (getPath . binderXObj . snd) multiple)) i t - pathWithQualifiers -> - -- The symbol IS qualified but can't be found, should produce an error later during compilation. - trace ("PROBLEMATIC: " ++ show path) (XObj (Sym pathWithQualifiers (LookupGlobal CarpLand AFunction)) i t) - removeThoseShadowedByRecursiveSymbol :: [(Env, Binder)] -> [(Env, Binder)] - removeThoseShadowedByRecursiveSymbol allBinders = visit allBinders allBinders - where - visit bs res = - foldl' - ( \result b -> - case b of - (Env {envMode = RecursionEnv}, Binder _ xobj') -> - remove (\(_, Binder _ x) -> xobj' /= x && getName xobj' == getName x) result - _ -> result + resolve :: Env -> Env -> XObj -> Either QualificationError XObj + resolve _ _ (XObj (Lst (XObj (Interface _ _) _ _ : _)) _ _) = + -- Before we return an interface, double check that it isn't shadowed by a local let-binding. + case (E.searchValue localEnv path) of + Right (e, Binder _ _) -> + case envMode e of + InternalEnv -> pure (XObj (Sym (getPath xobj) (LookupLocal (captureOrNot e localEnv))) i t) + _ -> pure (XObj (InterfaceSym name) i t) + _ -> pure (XObj (InterfaceSym name) i t) + resolve _ _ x@(XObj (Lst (XObj (External (Just overrideName)) _ _ : _)) _ _) = + pure (XObj (Sym (getPath x) (LookupGlobalOverride overrideName)) i t) + resolve _ _ (XObj (Mod modenv _) _ _) = + nakedInit modenv + resolve origin found xobj' = + if (isTypeDef xobj') + then + ( (replaceLeft (FailedToFindSymbol xobj') (fmap (globalEnv,) (E.searchValue globalEnv path))) + >>= \(origin', (e', binder)) -> resolve (E.prj origin') (E.prj e') (binderXObj binder) + ) + else case envMode (E.prj found) of + RecursionEnv -> pure (XObj (Sym (getPath xobj') LookupRecursive) i t) + InternalEnv -> pure (XObj (Sym (getPath xobj') (LookupLocal (captureOrNot found origin))) i t) + ExternalEnv -> pure (XObj (Sym (getPath xobj') (LookupGlobal (if isExternalFunction xobj' then ExternalCode else CarpLand) (definitionMode xobj'))) i t) + resolveMulti :: (Show e, E.Environment e) => SymPath -> [(e, Binder)] -> Either QualificationError XObj + resolveMulti _ [] = + Left (FailedToFindSymbol xobj) + resolveMulti _ [(e, b)] = + resolve (E.prj e) (E.prj e) (binderXObj b) + resolveMulti spath xs = + let localOnly = remove (E.envIsExternal . fst) xs + paths = map (getModuleSym . (second binderXObj)) xs + in case localOnly of + [] -> case spath of + (SymPath [] _) -> + Right $ XObj (MultiSym name paths) i t + _ -> Left (QualifiedMulti spath) + ys -> Left (LocalMulti spath (map (first E.prj) ys)) + nakedInit :: Env -> Either QualificationError XObj + nakedInit e = + maybe + (Left (NakedInitForUnnamedModule (pathToEnv e))) + (Right . id) + ( envModuleName e + >>= \name' -> + pure (XObj (Sym (SymPath ((init (pathToEnv e)) ++ [name']) "init") (LookupGlobal CarpLand AFunction)) i t) + ) + getModuleSym (_, x) = + case x of + XObj (Mod ev _) _ _ -> + fromRight + (SymPath (init (pathToEnv ev)) name) + ( (replaceLeft (FailedToFindSymbol x) (E.searchType globalEnv (SymPath (init (pathToEnv ev)) name))) + >> (fmap getPath (nakedInit ev)) ) - res - bs + _ -> (getPath x) qualifySym _ _ _ xobj = Left $ FailedToQualifySymbols xobj +-- | Determine whether or not this symbol is captured in a local environment (closures). +captureOrNot :: Env -> Env -> CaptureMode +captureOrNot foundEnv localEnv = + if envFunctionNestingLevel foundEnv < envFunctionNestingLevel localEnv + then Capture (envFunctionNestingLevel localEnv - envFunctionNestingLevel foundEnv) + else NoCapture + -- | Qualify an Arr form. qualifyArr :: Qualifier qualifyArr typeEnv globalEnv env (XObj (Arr array) i t) = diff --git a/src/Reify.hs b/src/Reify.hs index 9b91eb54..703125e9 100644 --- a/src/Reify.hs +++ b/src/Reify.hs @@ -40,6 +40,7 @@ instance Reifiable Ty where reify (FuncTy ats rt lt) = XObj (Lst [literal "Fn", array ats, reify rt, lifetime lt]) Nothing (Just TypeTy) reify TypeTy = XObj (Sym (SymPath [] (show TypeTy)) Symbol) Nothing (Just Universe) reify UnitTy = XObj (Sym (SymPath [] "Unit") Symbol) Nothing (Just TypeTy) + reify (ConcreteNameTy path) = XObj (Sym path Symbol) Nothing (Just TypeTy) reify t = XObj (Sym (SymPath [] (show t)) Symbol) Nothing (Just TypeTy) instance Reifiable String where diff --git a/src/RenderDocs.hs b/src/RenderDocs.hs index 922b1508..640fcd3a 100644 --- a/src/RenderDocs.hs +++ b/src/RenderDocs.hs @@ -52,7 +52,7 @@ saveDocsForEnvs ctx pathsAndEnvBinders = getEnvAndMetaFromBinder :: Binder -> (Env, MetaData) getEnvAndMetaFromBinder envBinder = case envBinder of - Binder meta (XObj (Mod env) _ _) -> (env, meta) + Binder meta (XObj (Mod env _) _ _) -> (env, meta) _ -> error "Binder's not a module. This should be detected in 'commandSaveDocsInternal'." projectIndexPage :: Project -> [String] -> String diff --git a/src/Scoring.hs b/src/Scoring.hs index db07a75a..9efa256c 100644 --- a/src/Scoring.hs +++ b/src/Scoring.hs @@ -1,7 +1,7 @@ module Scoring (scoreTypeBinder, scoreValueBinder) where import Data.Maybe (fromJust) -import Lookup +import Env as E import Obj import qualified Set import Types @@ -24,15 +24,12 @@ scoreTypeBinder typeEnv b@(Binder _ (XObj (Lst (XObj x _ _ : XObj (Sym _ _) _ _ ExternalType _ -> (0, b) _ -> (500, b) where - depthOfStruct (StructTy (ConcreteNameTy structName) varTys) = - case lookupBinder (SymPath lookupPath name) (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.") - where - lookupPath = getPathFromStructName structName - name = getNameFromStructName structName + depthOfStruct (StructTy (ConcreteNameTy (SymPath _ name)) varTys) = + case E.getTypeBinder typeEnv name of + Right (Binder _ typedef) -> (depthOfDeftype typeEnv Set.empty typedef varTys + 1, b) + Left e -> error (show e) depthOfStruct _ = error "depthofstruct" -scoreTypeBinder _ b@(Binder _ (XObj (Mod _) _ _)) = +scoreTypeBinder _ b@(Binder _ (XObj (Mod _ _) _ _)) = (1000, b) scoreTypeBinder _ x = error ("Can't score: " ++ show x) @@ -79,17 +76,19 @@ depthOfType typeEnv visited selfName theType = _ | tyToC struct == selfName -> 1 | otherwise -> - case lookupBinder (SymPath lookupPath s) (getTypeEnv typeEnv) of - Just (Binder _ typedef) -> moduleDepth + depthOfDeftype typeEnv (Set.insert theType visited) typedef varTys - where - moduleDepth = length lookupPath * 1000 -- modules have score 1000 - Nothing -> + case E.getTypeBinder typeEnv s of + Right (Binder _ typedef) -> depthOfDeftype typeEnv (Set.insert theType visited) typedef varTys + Left _ -> --trace ("Unknown type: " ++ name) $ - depthOfVarTys -- The problem here is that generic types don't generate - -- their definition in time so we get nothing for those. - -- Instead, let's try the type vars. + -- Two problems here: + -- + -- 1. generic types don't generate their definition in time + -- so we get nothing for those. Instead, let's try the type + -- vars. + -- 2. If a type wasn't found type may also refer to a type defined in another + -- module that's not yet been scored. To be safe, add 500 + 500 + depthOfVarTys where - lookupPath = getPathFromStructName (getStructName struct) s = getNameFromStructName (getStructName struct) depthOfVarTys = case fmap (depthOfType typeEnv visited (getStructName struct)) varTys of @@ -121,12 +120,12 @@ scoreBody globalEnv visited = visit (Sym path (LookupGlobal _ _)) -> if Set.member path visited then 0 - else case lookupBinder path globalEnv of - Just foundBinder -> + else case E.searchValueBinder globalEnv path of + Right foundBinder -> let (score, _) = scoreValueBinder globalEnv (Set.insert path visited) foundBinder in score + 1 - Nothing -> - error ("Failed to lookup '" ++ show path ++ "'.") + Left e -> + error (show e) _ -> 0 visitList (XObj (Lst []) _ _) = 0 diff --git a/src/StartingEnv.hs b/src/StartingEnv.hs index a5e2a7c9..36a8ab0e 100644 --- a/src/StartingEnv.hs +++ b/src/StartingEnv.hs @@ -2,6 +2,7 @@ module StartingEnv where import qualified ArrayTemplates import Commands +import qualified Env as E import Eval import Info import qualified Map @@ -123,7 +124,7 @@ functionModule = where bindEnv env = let Just name = envModuleName env - in (name, Binder emptyMeta (XObj (Mod env) Nothing Nothing)) + in (name, Binder emptyMeta (XObj (Mod env E.empty) Nothing Nothing)) bindings = Map.fromList (map (bindEnv . generateInnerFunctionModule) [0 .. maxArity]) -- | Each arity of functions need their own module to enable copying and string representation @@ -329,10 +330,10 @@ dynamicModule = f "help" primitiveHelp "prints help." "(help)" ] mods = - [ ("String", Binder emptyMeta (XObj (Mod dynamicStringModule) Nothing Nothing)), - ("Symbol", Binder emptyMeta (XObj (Mod dynamicSymModule) Nothing Nothing)), - ("Project", Binder emptyMeta (XObj (Mod dynamicProjectModule) Nothing Nothing)), - ("Path", Binder emptyMeta (XObj (Mod dynamicPathModule) Nothing Nothing)) + [ ("String", Binder emptyMeta (XObj (Mod dynamicStringModule E.empty) Nothing Nothing)), + ("Symbol", Binder emptyMeta (XObj (Mod dynamicSymModule E.empty) Nothing Nothing)), + ("Project", Binder emptyMeta (XObj (Mod dynamicProjectModule E.empty) Nothing Nothing)), + ("Path", Binder emptyMeta (XObj (Mod dynamicPathModule E.empty) Nothing Nothing)) ] -- | A submodule of the Dynamic module. Contains functions for working with strings in the repl or during compilation. @@ -494,12 +495,12 @@ startingGlobalEnv noArray = makeSymbol "deref" "" "" Deref, makeSymbol "with" "" "" With ] - ++ [("Array", Binder emptyMeta (XObj (Mod arrayModule) Nothing Nothing)) | not noArray] - ++ [("StaticArray", Binder emptyMeta (XObj (Mod staticArrayModule) Nothing Nothing))] - ++ [("Pointer", Binder emptyMeta (XObj (Mod pointerModule) Nothing Nothing))] - ++ [("Dynamic", Binder emptyMeta (XObj (Mod dynamicModule) Nothing Nothing))] - ++ [("Function", Binder emptyMeta (XObj (Mod functionModule) Nothing Nothing))] - ++ [("Unsafe", Binder emptyMeta (XObj (Mod unsafeModule) Nothing Nothing))] + ++ [("Array", Binder emptyMeta (XObj (Mod arrayModule E.empty) Nothing Nothing)) | not noArray] + ++ [("StaticArray", Binder emptyMeta (XObj (Mod staticArrayModule E.empty) Nothing Nothing))] + ++ [("Pointer", Binder emptyMeta (XObj (Mod pointerModule E.empty) Nothing Nothing))] + ++ [("Dynamic", Binder emptyMeta (XObj (Mod dynamicModule E.empty) Nothing Nothing))] + ++ [("Function", Binder emptyMeta (XObj (Mod functionModule E.empty) Nothing Nothing))] + ++ [("Unsafe", Binder emptyMeta (XObj (Mod unsafeModule E.empty) Nothing Nothing))] -- | The type environment (containing deftypes and interfaces) before any code is run. startingTypeEnv :: Env diff --git a/src/StaticArrayTemplates.hs b/src/StaticArrayTemplates.hs index c6285554..e1d12340 100644 --- a/src/StaticArrayTemplates.hs +++ b/src/StaticArrayTemplates.hs @@ -11,7 +11,7 @@ import Types -- since there are some small differences here and there I'v decided to not -- try to abstract over them and just duplicate the templates instead. concreteArray :: Ty -concreteArray = ConcreteNameTy "StaticArray" +concreteArray = ConcreteNameTy (SymPath [] "StaticArray") templateUnsafeNth :: (String, Binder) templateUnsafeNth = diff --git a/src/Sumtypes.hs b/src/Sumtypes.hs index 3f95397e..a3e0feff 100644 --- a/src/Sumtypes.hs +++ b/src/Sumtypes.hs @@ -1,14 +1,13 @@ module Sumtypes where import Concretize +import Context import Data.Maybe import Deftype -import Env +import Env (addListOfBindings, new) import Info import Managed -import qualified Map import Obj -import qualified Set import StructUtils import SumtypeCase import Template @@ -25,13 +24,35 @@ getCase cases caseNameToFind = found : _ -> Just found [] -> Nothing -moduleForSumtype :: Maybe Env -> TypeEnv -> Env -> [String] -> String -> [Ty] -> [XObj] -> Maybe Info -> Maybe Env -> Either TypeError (String, XObj, [XObj]) +moduleForSumtypeInContext :: Context -> String -> [Ty] -> [XObj] -> Maybe Info -> Either TypeError (String, XObj, [XObj]) +moduleForSumtypeInContext ctx name vars members info = + let global = contextGlobalEnv ctx + types = contextTypeEnv ctx + path = contextPath ctx + inner = either (const Nothing) Just (innermostModuleEnv ctx) + previous = + either + (const Nothing) + Just + ( (lookupBinderInInternalEnv ctx (SymPath path name)) + <> (lookupBinderInGlobalEnv ctx (SymPath path name)) + >>= \b -> + replaceLeft + (NotFoundGlobal (SymPath path name)) + ( case binderXObj b of + XObj (Mod ev et) _ _ -> Right (ev, et) + _ -> Left "Non module" + ) + ) + in moduleForSumtype inner types global path name vars members info previous + +moduleForSumtype :: Maybe Env -> TypeEnv -> Env -> [String] -> String -> [Ty] -> [XObj] -> Maybe Info -> Maybe (Env, TypeEnv) -> Either TypeError (String, XObj, [XObj]) moduleForSumtype innerEnv typeEnv env pathStrings typeName typeVariables rest i existingEnv = - let typeModuleName = typeName - typeModuleEnv = fromMaybe (Env (Map.fromList []) innerEnv (Just typeModuleName) Set.empty ExternalEnv 0) existingEnv - insidePath = pathStrings ++ [typeModuleName] + let moduleValueEnv = fromMaybe (new innerEnv (Just typeName)) (fmap fst existingEnv) + moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv) + insidePath = pathStrings ++ [typeName] in do - let structTy = StructTy (ConcreteNameTy (createStructName pathStrings typeName)) typeVariables + let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables cases <- toCases typeEnv typeVariables rest okIniters <- initers insidePath structTy cases okTag <- binderForTag insidePath structTy @@ -40,9 +61,9 @@ moduleForSumtype innerEnv typeEnv env pathStrings typeName typeVariables rest i okDelete <- binderForDelete typeEnv env insidePath structTy cases (okCopy, okCopyDeps) <- binderForCopy typeEnv env insidePath structTy cases okMemberDeps <- memberDeps typeEnv cases - let moduleEnvWithBindings = addListOfBindings typeModuleEnv (okIniters ++ [okStr, okPrn, okDelete, okCopy, okTag]) - typeModuleXObj = XObj (Mod moduleEnvWithBindings) i (Just ModuleTy) - pure (typeModuleName, typeModuleXObj, okMemberDeps ++ okCopyDeps ++ okStrDeps) + let moduleEnvWithBindings = addListOfBindings moduleValueEnv (okIniters ++ [okStr, okPrn, okDelete, okCopy, okTag]) + typeModuleXObj = XObj (Mod moduleEnvWithBindings moduleTypeEnv) i (Just ModuleTy) + pure (typeName, typeModuleXObj, okMemberDeps ++ okCopyDeps ++ okStrDeps) memberDeps :: TypeEnv -> [SumtypeCase] -> Either TypeError [XObj] memberDeps typeEnv cases = fmap concat (mapM (concretizeType typeEnv) (concatMap caseTys cases)) @@ -108,13 +129,13 @@ genericCaseInit allocationMode pathStrings originalStructTy sumtypeCase = ) tokensForCaseInit :: AllocationMode -> Ty -> SumtypeCase -> [Token] -tokensForCaseInit allocationMode sumTy@(StructTy (ConcreteNameTy typeName) _) sumtypeCase = +tokensForCaseInit allocationMode sumTy@(StructTy (ConcreteNameTy _) _) sumtypeCase = toTemplate $ unlines [ "$DECL {", case allocationMode of StackAlloc -> " $p instance;" - HeapAlloc -> " $p instance = CARP_MALLOC(sizeof(" ++ typeName ++ "));", + HeapAlloc -> " $p instance = CARP_MALLOC(sizeof(" ++ show sumTy ++ "));", joinLines $ caseMemberAssignment allocationMode correctedName . fst <$> unitless, " instance._tag = " ++ tagName sumTy correctedName ++ ";", " return instance;", @@ -134,7 +155,7 @@ caseMemberAssignment allocationMode caseNm memberName = HeapAlloc -> "->u." binderForTag :: [String] -> Ty -> Either TypeError (String, Binder) -binderForTag insidePath originalStructTy@(StructTy (ConcreteNameTy typeName) _) = +binderForTag insidePath originalStructTy@(StructTy (ConcreteNameTy _) _) = Right $ instanceBinder path (FuncTy [RefTy originalStructTy (VarTy "q")] IntTy StaticLifetimeTy) template doc where path = SymPath insidePath "get-tag" @@ -145,7 +166,7 @@ binderForTag insidePath originalStructTy@(StructTy (ConcreteNameTy typeName) _) (\(FuncTy [RefTy structTy _] IntTy _) -> toTemplate $ proto structTy ++ " { return p->_tag; }") (const []) proto structTy = "int $NAME(" ++ tyToCLambdaFix structTy ++ " *p)" - doc = "Gets the tag from a `" ++ typeName ++ "`." + doc = "Gets the tag from a `" ++ show originalStructTy ++ "`." binderForTag _ _ = error "binderfortag" -- | Helper function to create the binder for the 'str' template. @@ -159,16 +180,16 @@ binderForStrOrPrn _ _ _ _ _ _ = error "binderforstrorprn" -- | The template for the 'str' function for a concrete deftype. concreteStr :: TypeEnv -> Env -> [String] -> Ty -> [SumtypeCase] -> String -> ((String, Binder), [XObj]) -concreteStr typeEnv env insidePath concreteStructTy@(StructTy (ConcreteNameTy typeName) _) cases strOrPrn = +concreteStr typeEnv env insidePath concreteStructTy@(StructTy (ConcreteNameTy name) _) cases strOrPrn = instanceBinderWithDeps (SymPath insidePath strOrPrn) (FuncTy [RefTy concreteStructTy (VarTy "q")] StringTy StaticLifetimeTy) template doc where - doc = "converts a `" ++ typeName ++ "` to a string." + doc = "converts a `" ++ (show concreteStructTy) ++ "` to a string." template = Template (FuncTy [RefTy concreteStructTy (VarTy "q")] StringTy StaticLifetimeTy) (\(FuncTy [RefTy structTy _] StringTy _) -> toTemplate $ "String $NAME(" ++ tyToCLambdaFix structTy ++ " *p)") ( \(FuncTy [RefTy (StructTy _ _) _] StringTy _) -> - tokensForStr typeEnv env typeName cases concreteStructTy + tokensForStr typeEnv env (show name) cases concreteStructTy ) ( \(FuncTy [RefTy (StructTy _ _) _] StringTy _) -> concatMap @@ -179,12 +200,12 @@ concreteStr _ _ _ _ _ _ = error "concretestr" -- | The template for the 'str' function for a generic deftype. genericStr :: [String] -> Ty -> [SumtypeCase] -> String -> (String, Binder) -genericStr insidePath originalStructTy@(StructTy (ConcreteNameTy typeName) _) cases strOrPrn = +genericStr insidePath originalStructTy@(StructTy (ConcreteNameTy name) _) cases strOrPrn = defineTypeParameterizedTemplate templateCreator path t docs where path = SymPath insidePath strOrPrn t = FuncTy [RefTy originalStructTy (VarTy "q")] StringTy StaticLifetimeTy - docs = "stringifies a `" ++ show typeName ++ "`." + docs = "stringifies a `" ++ show originalStructTy ++ "`." templateCreator = TemplateCreator $ \typeEnv env -> Template @@ -195,7 +216,7 @@ genericStr insidePath originalStructTy@(StructTy (ConcreteNameTy typeName) _) ca ( \(FuncTy [RefTy concreteStructTy@(StructTy _ _) _] StringTy _) -> let mappings = unifySignatures originalStructTy concreteStructTy correctedCases = replaceGenericTypesOnCases mappings cases - in tokensForStr typeEnv env typeName correctedCases concreteStructTy + in tokensForStr typeEnv env (show name) correctedCases concreteStructTy ) ( \ft@(FuncTy [RefTy concreteStructTy@(StructTy _ _) _] StringTy _) -> let mappings = unifySignatures originalStructTy concreteStructTy @@ -307,10 +328,10 @@ genericSumtypeDelete pathStrings originalStructTy cases = -- | The template for the 'delete' function of a concrete sumtype concreteSumtypeDelete :: [String] -> TypeEnv -> Env -> Ty -> [SumtypeCase] -> (String, Binder) -concreteSumtypeDelete insidePath typeEnv env structTy@(StructTy (ConcreteNameTy typeName) _) cases = +concreteSumtypeDelete insidePath typeEnv env structTy@(StructTy (ConcreteNameTy _) _) cases = instanceBinder (SymPath insidePath "delete") (FuncTy [structTy] UnitTy StaticLifetimeTy) template doc where - doc = "deletes a `" ++ typeName ++ "`. This should usually not be called manually." + doc = "deletes a `" ++ (show structTy) ++ "`. This should usually not be called manually." template = Template (FuncTy [VarTy "p"] UnitTy StaticLifetimeTy) @@ -381,10 +402,10 @@ genericSumtypeCopy pathStrings originalStructTy cases = -- | The template for the 'copy' function of a concrete sumtype concreteSumtypeCopy :: [String] -> TypeEnv -> Env -> Ty -> [SumtypeCase] -> ((String, Binder), [XObj]) -concreteSumtypeCopy insidePath typeEnv env structTy@(StructTy (ConcreteNameTy typeName) _) cases = +concreteSumtypeCopy insidePath typeEnv env structTy@(StructTy (ConcreteNameTy _) _) cases = instanceBinderWithDeps (SymPath insidePath "copy") (FuncTy [RefTy structTy (VarTy "q")] structTy StaticLifetimeTy) template doc where - doc = "copies a `" ++ typeName ++ "`." + doc = "copies a `" ++ (show structTy) ++ "`." template = Template (FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy) diff --git a/src/SymPath.hs b/src/SymPath.hs index 711f074d..626b4ec5 100644 --- a/src/SymPath.hs +++ b/src/SymPath.hs @@ -5,6 +5,7 @@ module SymPath mangle, pathToC, consPath, + fromStrings, ) where @@ -89,3 +90,9 @@ pathToC (SymPath modulePath name) = consPath :: [String] -> SymPath -> SymPath consPath qualifyers (SymPath stringPaths name) = SymPath (qualifyers ++ stringPaths) name + +-- | Convert a list of strings into a path. +fromStrings :: [String] -> SymPath +fromStrings [] = SymPath [] "" +fromStrings (s : []) = SymPath [] s +fromStrings ss = SymPath (init ss) (last ss) diff --git a/src/TypeError.hs b/src/TypeError.hs index 1f904b0a..3c659e25 100644 --- a/src/TypeError.hs +++ b/src/TypeError.hs @@ -60,6 +60,7 @@ data TypeError | UsingDeadReference XObj String | UninhabitedConstructor Ty XObj Int Int | InconsistentKinds String [XObj] + | FailedToAddLambdaStructToTyEnv SymPath XObj instance Show TypeError where show (SymbolMissingType xobj env) = @@ -305,6 +306,10 @@ instance Show TypeError where "Can't use a struct or sumtype constructor without arguments as a member type at " ++ prettyInfoFromXObj xobj ++ ". The type constructor " ++ show ty ++ " expects " ++ show wanted ++ " arguments but got " ++ show got show (InconsistentKinds varName xobjs) = " The type variable `" ++ varName ++ "` is used inconsistently: " ++ joinWithComma (map pretty (filter (doesTypeContainTyVarWithName varName . fromMaybe Universe . xobjToTy) xobjs)) ++ " Type variables must be applied to the same number of arguments." + show (FailedToAddLambdaStructToTyEnv path xobj) = + "Failed to add the lambda: " ++ show path ++ " represented by struct: " + ++ pretty xobj + ++ " to the type environment." machineReadableErrorStrings :: FilePathPrintLength -> TypeError -> [String] machineReadableErrorStrings fppl err = @@ -421,6 +426,11 @@ machineReadableErrorStrings fppl err = [machineReadableInfoFromXObj fppl xobj ++ "Can't use a struct or sumtype constructor without arguments as a member type at " ++ prettyInfoFromXObj xobj ++ ". The type constructor " ++ show ty ++ " expects " ++ show wanted ++ " arguments but got " ++ show got] (InconsistentKinds varName xobjs) -> [machineReadableInfoFromXObj fppl (head xobjs) ++ " The type variable `" ++ varName ++ "` is used inconsistently: " ++ joinWithComma (map pretty (filter (doesTypeContainTyVarWithName varName . fromMaybe Universe . xobjToTy) xobjs)) ++ " Type variables must be applied to the same number of arguments."] + (FailedToAddLambdaStructToTyEnv path xobj) -> + [ machineReadableInfoFromXObj fppl xobj ++ "Failed to add the lambda: " ++ show path ++ " represented by struct: " + ++ pretty xobj + ++ " to the type environment." + ] _ -> [show err] @@ -473,7 +483,7 @@ 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 + (XObj (Mod modEnv _) _ _) -> keysInEnvEditDistance (SymPath ps name) modEnv distance _ -> [] Nothing -> case envParent env of diff --git a/src/Types.hs b/src/Types.hs index 54a027d1..8c82322f 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -26,6 +26,7 @@ module Types getStructName, getPathFromStructName, getNameFromStructName, + getStructPath, promoteNumber, ) where @@ -60,7 +61,7 @@ data Ty | RefTy Ty Ty -- second Ty is the lifetime | StaticLifetimeTy | StructTy Ty [Ty] -- the name (possibly a var) of the struct, and it's type parameters - | ConcreteNameTy String -- the name of a struct + | ConcreteNameTy SymPath -- the name of a struct | TypeTy -- the type of types | MacroTy | DynamicTy -- the type of dynamic functions (used in REPL and macros) @@ -179,7 +180,7 @@ instance Show Ty where show InterfaceTy = "Interface" show (StructTy s []) = show s show (StructTy s typeArgs) = "(" ++ show s ++ " " ++ joinWithSpace (map show typeArgs) ++ ")" - show (ConcreteNameTy name) = name + show (ConcreteNameTy spath) = show spath show (PointerTy p) = "(Ptr " ++ show p ++ ")" show (RefTy r lt) = -- case r of @@ -336,13 +337,13 @@ typesDeleterFunctionType memberType = FuncTy [memberType] UnitTy StaticLifetimeT -- | The type of environments sent to Lambdas (used in emitted C code) lambdaEnvTy :: Ty -lambdaEnvTy = StructTy (ConcreteNameTy "LambdaEnv") [] +lambdaEnvTy = StructTy (ConcreteNameTy (SymPath [] "LambdaEnv")) [] createStructName :: [String] -> String -> String createStructName path name = intercalate "." (path ++ [name]) getStructName :: Ty -> String -getStructName (StructTy (ConcreteNameTy name) _) = name +getStructName (StructTy (ConcreteNameTy spath) _) = show spath getStructName (StructTy (VarTy name) _) = name getStructName _ = "" @@ -354,6 +355,11 @@ getPathFromStructName structName = getNameFromStructName :: String -> String getNameFromStructName structName = last (map unpack (splitOn (pack ".") (pack structName))) +getStructPath :: Ty -> SymPath +getStructPath (StructTy (ConcreteNameTy spath) _) = spath +getStructPath (StructTy (VarTy name) _) = (SymPath [] name) +getStructPath _ = (SymPath [] "") + -- N.B.: promoteNumber is only safe for numeric types! promoteNumber :: Ty -> Ty -> Ty promoteNumber a b | a == b = a diff --git a/src/TypesToC.hs b/src/TypesToC.hs index 029cca34..6fc4778a 100644 --- a/src/TypesToC.hs +++ b/src/TypesToC.hs @@ -44,7 +44,7 @@ tyToCManglePtr _ ty = f ty f (FuncTy argTys retTy _) = "Fn__" ++ joinWithUnderscore (map (tyToCManglePtr True) argTys) ++ "_" ++ tyToCManglePtr True retTy f (StructTy s []) = tyToCManglePtr False s f (StructTy s typeArgs) = tyToCManglePtr False s ++ "__" ++ joinWithUnderscore (map (tyToCManglePtr True) typeArgs) - f (ConcreteNameTy name) = mangle (intercalate "" (map unpack (splitOn (pack ".") (pack name)))) + f (ConcreteNameTy spath) = mangle (intercalate "" (map unpack (splitOn (pack ".") (pack (show spath))))) f ModuleTy = err "modules" f TypeTy = err "types" f MacroTy = err "macros" diff --git a/src/Util.hs b/src/Util.hs index f3488551..9537385e 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -1,5 +1,6 @@ module Util where +import Data.Bifunctor import Data.List import Data.Maybe (fromMaybe) import qualified Map @@ -116,3 +117,15 @@ intToArgName 7 = "t" intToArgName 8 = "s" intToArgName 9 = "r" intToArgName n = intToArgName 1 ++ intToArgName (n `div` 10) + +replaceLeft :: b -> Either a c -> Either b c +replaceLeft x e = first (const x) e + +unwrapErr :: Show e => Either e a -> Either String a +unwrapErr = first show + +toMaybe :: (b -> c) -> Either a b -> Maybe c +toMaybe f e = either (const Nothing) (Just . f) e + +maybeId :: Either a b -> Maybe b +maybeId = toMaybe id diff --git a/src/Validate.hs b/src/Validate.hs index aafd22f2..43948afb 100644 --- a/src/Validate.hs +++ b/src/Validate.hs @@ -4,7 +4,7 @@ import Control.Monad (foldM) import Data.Function (on) import Data.List (nubBy, (\\)) import Data.Maybe (fromJust) -import Lookup +import qualified Env as E import Obj import TypeError import TypePredicates @@ -104,21 +104,19 @@ canBeUsedAsMemberType typeEnv typeVariables ty xobj = _ -> Left (InvalidMemberType ty xobj) where checkStruct :: Ty -> [Ty] -> Either TypeError () - checkStruct (ConcreteNameTy "Array") [innerType] = + checkStruct (ConcreteNameTy (SymPath [] "Array")) [innerType] = canBeUsedAsMemberType typeEnv typeVariables innerType xobj >> pure () - checkStruct (ConcreteNameTy n) vars = - case lookupBinder (SymPath lookupPath name) (getTypeEnv typeEnv) of - Just (Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) -> + checkStruct (ConcreteNameTy (SymPath _ name)) vars = + case E.getTypeBinder typeEnv name of + Right (Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) -> pure () - Just (Binder _ (XObj (Lst (XObj (Deftype t) _ _ : _)) _ _)) -> + Right (Binder _ (XObj (Lst (XObj (Deftype t) _ _ : _)) _ _)) -> checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType typeEnv typeVariables typ xobj) () vars - Just (Binder _ (XObj (Lst (XObj (DefSumtype t) _ _ : _)) _ _)) -> + Right (Binder _ (XObj (Lst (XObj (DefSumtype t) _ _ : _)) _ _)) -> checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType typeEnv typeVariables typ xobj) () vars _ -> Left (NotAmongRegisteredTypes ty xobj) where - lookupPath = getPathFromStructName n - name = getNameFromStructName n checkInhabitants :: Ty -> Either TypeError () checkInhabitants (StructTy _ vs) = if length vs == length vars diff --git a/test/TestConstraints.hs b/test/TestConstraints.hs index d111ad93..7c321750 100644 --- a/test/TestConstraints.hs +++ b/test/TestConstraints.hs @@ -116,16 +116,16 @@ testConstr10 = testConstr11 = assertSolution - [Constraint (PointerTy (VarTy "a")) (PointerTy (StructTy (ConcreteNameTy "Monkey") [])) x x x OrdNo] - [("a", (StructTy (ConcreteNameTy "Monkey") []))] + [Constraint (PointerTy (VarTy "a")) (PointerTy (StructTy (ConcreteNameTy (SymPath [] "Monkey")) [])) x x x OrdNo] + [("a", (StructTy (ConcreteNameTy (SymPath [] "Monkey")) []))] testConstr12 = assertSolution - [ Constraint t1 (PointerTy (StructTy (ConcreteNameTy "Array") [IntTy])) x x x OrdNo, + [ Constraint t1 (PointerTy (StructTy (ConcreteNameTy (SymPath [] "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])) + [ ("t1", (PointerTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [IntTy]))), + ("t2", (StructTy (ConcreteNameTy (SymPath [] "Array")) [IntTy])) ] testConstr13 = @@ -144,36 +144,36 @@ testConstr13 = -- Struct types testConstr20 = assertSolution - [ Constraint t0 (StructTy (ConcreteNameTy "Vector") [t1]) x x x OrdNo, - Constraint t0 (StructTy (ConcreteNameTy "Vector") [IntTy]) x x x OrdNo + [ Constraint t0 (StructTy (ConcreteNameTy (SymPath [] "Vector")) [t1]) x x x OrdNo, + Constraint t0 (StructTy (ConcreteNameTy (SymPath [] "Vector")) [IntTy]) x x x OrdNo ] - [("t0", (StructTy (ConcreteNameTy "Vector") [IntTy])), ("t1", IntTy)] + [("t0", (StructTy (ConcreteNameTy (SymPath [] "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 t1 (StructTy (ConcreteNameTy (SymPath [] "Array")) [t2]) x x x OrdNo, + Constraint t1 (StructTy (ConcreteNameTy (SymPath [] "Array")) [t3]) x x x OrdNo, Constraint t3 BoolTy x x x OrdNo ] - [ ("t1", (StructTy (ConcreteNameTy "Array") [BoolTy])), + [ ("t1", (StructTy (ConcreteNameTy (SymPath [] "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 t1 (StructTy (ConcreteNameTy (SymPath [] "Array")) [t2]) x x x OrdNo, + Constraint t2 (StructTy (ConcreteNameTy (SymPath [] "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])), + [ ("t1", (StructTy (ConcreteNameTy (SymPath [] "Array")) [(StructTy (ConcreteNameTy (SymPath [] "Array")) [FloatTy])])), + ("t2", (StructTy (ConcreteNameTy (SymPath [] "Array")) [FloatTy])), ("t3", FloatTy) ] testConstr23 = assertUnificationFailure - [ Constraint (StructTy (ConcreteNameTy "Array") [t1]) (StructTy (ConcreteNameTy "Array") [t2]) x x x OrdNo, + [ Constraint (StructTy (ConcreteNameTy (SymPath [] "Array")) [t1]) (StructTy (ConcreteNameTy (SymPath [] "Array")) [t2]) x x x OrdNo, Constraint t1 IntTy x x x OrdNo, Constraint t2 FloatTy x x x OrdNo ] @@ -182,7 +182,7 @@ 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 + Constraint (StructTy (ConcreteNameTy (SymPath [] "Array")) [t1]) (StructTy (ConcreteNameTy (SymPath [] "Array")) [t2]) x x x OrdNo ] -- m9 = solve [Constraint (StructTy "Vector" [IntTy]) (StructTy "Vector" [t1]) x x x OrdNo] @@ -219,10 +219,10 @@ testConstr33 = 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 + [ Constraint (VarTy "a") (StructTy (ConcreteNameTy (SymPath [] "Pair")) [(VarTy "x0"), (VarTy "y0")]) x x x OrdNo, + Constraint (StructTy (ConcreteNameTy (SymPath [] "Array")) [(VarTy "a")]) (StructTy (ConcreteNameTy (SymPath [] "Array")) [(StructTy (ConcreteNameTy (SymPath [] "Pair")) [(VarTy "x1"), (VarTy "y1")])]) x x x OrdNo ] - [ ("a", (StructTy (ConcreteNameTy "Pair") [(VarTy "x0"), (VarTy "y0")])), + [ ("a", (StructTy (ConcreteNameTy (SymPath [] "Pair")) [(VarTy "x0"), (VarTy "y0")])), ("x0", (VarTy "x0")), ("y0", (VarTy "y0")), ("x1", (VarTy "x0")), @@ -232,10 +232,10 @@ testConstr34 = -- 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 + [ Constraint (RefTy (VarTy "a") (VarTy "lt0")) (RefTy (StructTy (ConcreteNameTy (SymPath [] "Pair")) [(VarTy "x0"), (VarTy "y0")]) (VarTy "lt1")) x x x OrdNo, + Constraint (RefTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [(VarTy "a")]) (VarTy "lt2")) (RefTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [(StructTy (ConcreteNameTy (SymPath [] "Pair")) [(VarTy "x1"), (VarTy "y1")])]) (VarTy "lt3")) x x x OrdNo ] - [ ("a", (StructTy (ConcreteNameTy "Pair") [(VarTy "x0"), (VarTy "y0")])), + [ ("a", (StructTy (ConcreteNameTy (SymPath [] "Pair")) [(VarTy "x0"), (VarTy "y0")])), ("x0", (VarTy "x0")), ("y0", (VarTy "y0")), ("x1", (VarTy "x0")), diff --git a/test/TestLookup.hs b/test/TestLookup.hs index 9df50eb6..d6a2e75a 100644 --- a/test/TestLookup.hs +++ b/test/TestLookup.hs @@ -1,6 +1,6 @@ module TestLookup where -import qualified Lookup as Lookup +import Env as E import qualified Map import Obj import qualified Set @@ -16,9 +16,9 @@ b1 = Binder emptyMeta (XObj (Str "b1") Nothing (Just StringTy)) emptyRootEnv = Env (Map.fromList []) Nothing Nothing Set.empty ExternalEnv 0 -assertNotFound :: Maybe Binder -> Test -assertNotFound Nothing = TestCase (assertBool "assertNotFound" True) -- Better way? +assertNotFound :: Either EnvironmentError Binder -> Test +assertNotFound (Left _) = TestCase (assertBool "assertNotFound" True) -- Better way? assertNotFound _ = TestCase (assertBool "assertNotFound" False) basicLookup :: Test -basicLookup = assertNotFound (fmap snd (Lookup.lookupInEnv (SymPath [] "nonexisting") emptyRootEnv)) +basicLookup = assertNotFound (fmap snd (E.searchValue emptyRootEnv (SymPath [] "nonexisting"))) diff --git a/test/deftype.carp b/test/deftype.carp index 1d867635..e48c7af9 100644 --- a/test/deftype.carp +++ b/test/deftype.carp @@ -9,6 +9,9 @@ (defmodule Wrap2 (deftype C [])) (use Wrap2) +(use Wrap) + +(deftype B []) (deftest test (assert-equal test @@ -23,4 +26,8 @@ "(Wrap2.C)" (ref (str (ref (C)))) "implicit .init for 'use':d type defined inside module works") + (assert-equal test + "(B)" + (ref (str (ref (B)))) + "when module and global types compete, global types are preffered.") )