From e1943b29a9a47f4da38136d2c4434adf85f22a95 Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Wed, 19 May 2021 13:20:48 -0400 Subject: [PATCH] Refactor: clean up Env module, store type environments in modules (#1207) * refactor: major environment mgmt refactor This big refactor primarily changes two things in terms of behavior: 1. Stores a SymPath on concretely named (non-generic) struct types; before we stored a string. 2. The SymPath mentioned in (1.) designates where the struct is stored in the current environment chain. Modules now carry a local type environment in addition to their local value environments. Any types defined in the module are added to this environment rather than the global type environment. To resolve a type such as `Foo.Bar` we now do the following: - Search the *global value environment* for the Foo module. - Get the type environment stored in the Foo module. - Search for Bar in the Foo module's type environment. Additionally, this commit eliminates the Lookup module entirely and refactors the Env module to handle all aspects of environment management in hopefully a more reusable fashion. I also took the opportunity to refactor primitiveDeftype in Primitives and qualifySym in Qualify, both of which were hefty functions that I found difficult to grok and needed refactoring anyway as a result of lookup changes (lookups now return an Either instead of a Maybe). Subsequent commits will clean up and clarify this work further. This does include one minor regression. Namely, an implementation of `hash` in core/Color that was maximally generic now needs type casting. * refactor: clean up recent Env changes This commit removes some redundant functions, unifies some logic, and renames some routines across the Env module in efforts to make it cleaner. Call sites have been updated accordingly. * chore: format code with ormolu * fix: update lookup tests Changes references to renamed functions in the Env module. * refactor: style + additional improvements from eriksvedang@ - Rename arrayTy -> arrayTyA in ArrayTemplates.hs to disambiguate. - Add maybeId util function. - Remove commented code. - Refactor a few functions for readability. * fix: fix type inference regression Recent commits introduced one minor regression whereby an instance of type inference in core/Color.carp no longer worked and required explicit type annotation. The problem ultimately had to do with qualification: - Prior to the recent changes, type inference worked because the call in question was qualified to Color.Id.get-tag, fixing the type. - Failing to copy over a local envs Use modules to function envs resulted in finding more than just Color.Id.get-tag for this instance. We now copy use modules over to function envs generated during qualification to ensure we resolve to Use'd definitions before more general cases. Similarly, I made a small change to primitiveUse to support contextual use calls (e.g. the `(use Id)` in Color.carp, which really means `(use Color.Id)`) * chore: Update some clarificatory comments * chore: fix inline comment --- CarpHask.cabal | 1 - headerparse/Main.hs | 2 +- src/ArrayTemplates.hs | 59 +-- src/AssignTypes.hs | 2 +- src/Commands.hs | 28 +- src/Concretize.hs | 136 +++---- src/Context.hs | 194 ++++++++-- src/Deftype.hs | 126 ++++--- src/Emit.hs | 61 ++- src/Env.hs | 720 +++++++++++++++++++++++++++++++----- src/Eval.hs | 126 ++++--- src/Expand.hs | 21 +- src/GenerateConstraints.hs | 4 +- src/InitialTypes.hs | 44 +-- src/Interfaces.hs | 61 ++- src/Lookup.hs | 143 ------- src/Map.hs | 12 +- src/Obj.hs | 24 +- src/Polymorphism.hs | 32 +- src/PrimitiveError.hs | 34 ++ src/Primitives.hs | 521 +++++++++++++------------- src/Qualify.hs | 277 +++++++------- src/Reify.hs | 1 + src/RenderDocs.hs | 2 +- src/Scoring.hs | 43 ++- src/StartingEnv.hs | 23 +- src/StaticArrayTemplates.hs | 2 +- src/Sumtypes.hs | 71 ++-- src/SymPath.hs | 7 + src/TypeError.hs | 12 +- src/Types.hs | 14 +- src/TypesToC.hs | 2 +- src/Util.hs | 13 + src/Validate.hs | 16 +- test/TestConstraints.hs | 46 +-- test/TestLookup.hs | 8 +- test/deftype.carp | 7 + 37 files changed, 1800 insertions(+), 1095 deletions(-) delete mode 100644 src/Lookup.hs 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.") )