diff --git a/core/Macros.carp b/core/Macros.carp index 0276d1bd..d6a432bb 100644 --- a/core/Macros.carp +++ b/core/Macros.carp @@ -87,7 +87,7 @@ (Dynamic.String.concat [x newline]))) strings ())] - (eval (list 'meta-set! name "doc" (Dynamic.String.concat (list-to-array-internal separated [])))))) + (list 'meta-set! name "doc" (Dynamic.String.concat (list-to-array-internal separated []))))) (doc print-doc "Print the documentation for a binding.") (defmacro print-doc [name] diff --git a/src/Commands.hs b/src/Commands.hs index cb5dbb4e..461f2774 100644 --- a/src/Commands.hs +++ b/src/Commands.hs @@ -43,14 +43,6 @@ instance Exception CarpException dynamicNil :: Either a XObj dynamicNil = Right (XObj (Lst []) (Just dummyInfo) (Just UnitTy)) -- TODO: Remove/unwrap (Right ...) to a XObj --- | Dynamic 'true'. -trueXObj :: XObj -trueXObj = XObj (Bol True) Nothing Nothing - --- | Dynamic 'false'. -falseXObj :: XObj -falseXObj = XObj (Bol False) Nothing Nothing - boolToXObj :: Bool -> XObj boolToXObj b = if b then trueXObj else falseXObj diff --git a/src/Context.hs b/src/Context.hs index a2f7bba8..e68b2bd7 100644 --- a/src/Context.hs +++ b/src/Context.hs @@ -1,19 +1,222 @@ module Context - ( insertInGlobalEnv, + ( replaceGlobalEnv, + replaceInternalEnv, + replaceTypeEnv, + replaceHistory, + replaceProject, + replacePath, + replaceGlobalEnv', + replaceInternalEnv', + replaceTypeEnv', + replaceHistory', + insertInGlobalEnv, + insertInGlobalEnv', insertInTypeEnv, + insertInTypeEnv', + insertInInternalEnv, + innermostModuleEnv, + bindLetDeclaration, + lookupInterface, + lookupBinderInGlobalEnv, + lookupBinderInTypeEnv, + lookupBinderInContextEnv, + contextualize, ) where import Env +import Lookup import Obj +import Project +import Qualify (QualifiedPath, qualifyPath, unqualify) import SymPath -insertInGlobalEnv :: Context -> SymPath -> Binder -> Context -insertInGlobalEnv ctx path binder = - let globalEnv = contextGlobalEnv ctx - in ctx {contextGlobalEnv = envInsertAt globalEnv path binder} +-------------------------------------------------------------------------------- +-- Contextual Class -insertInTypeEnv :: Context -> SymPath -> Binder -> Context -insertInTypeEnv ctx path binder = +-- | Class of symbol paths (identifiers) that can be made relative to a +-- context. +-- +-- This class factors heavily in performing lookups in a given context +-- flexibly; certain portions of the codebase deliver fully qualified symbols +-- for lookup while others deliver an unqualified symbol that must be +-- contextualized before lookups are performed. +class Contextual a where + contextualize :: a -> Context -> SymPath + +-- | Unqualified paths are contextualized according to the current context. +instance Contextual SymPath where + contextualize spath ctx = unqualify (qualifyPath ctx spath) + +-- | Fully qualified paths require no further contextualization. +instance Contextual QualifiedPath where + contextualize qpath _ = unqualify qpath + +-------------------------------------------------------------------------------- +-- Environment Replacement Functions + +-- | Replace a context's internal environment with a new environment. +-- +-- The previous environment is completely replaced and will not be recoverable. +replaceInternalEnv :: Context -> Env -> Context +replaceInternalEnv ctx env = + ctx {contextInternalEnv = Just env} + +-- | Replace a context's global environment with a new environment. +-- +-- The previous environment is completely replaced and will not be recoverable. +replaceGlobalEnv :: Context -> Env -> Context +replaceGlobalEnv ctx env = + ctx {contextGlobalEnv = env} + +-- | Replace a context's type environment with a new environment. +-- +-- The previous environment is completely replaced and will not be recoverable. +replaceTypeEnv :: Context -> TypeEnv -> Context +replaceTypeEnv ctx env = + ctx {contextTypeEnv = env} + +-- | Replace a context's history with a new history. +-- +-- The previous history is completely replaced and will not be recoverable. +replaceHistory :: Context -> [XObj] -> Context +replaceHistory ctx hist = + ctx {contextHistory = hist} + +-- | Replace a context's project with a new project. +-- +-- The previous project is completely replaced and will not be recoverable. +replaceProject :: Context -> Project -> Context +replaceProject ctx proj = + ctx {contextProj = proj} + +-- | Replace a context's path with a new path. +-- +-- The previous path is completely replaced and will not be recoverable. +replacePath :: Context -> [String] -> Context +replacePath ctx paths = + ctx {contextPath = paths} + +-- | replaceInternalEnv with arguments flipped. +replaceInternalEnv' :: Env -> Context -> Context +replaceInternalEnv' = flip replaceInternalEnv + +-- | replaceGlobalEnv with arguments flipped. +replaceGlobalEnv' :: Env -> Context -> Context +replaceGlobalEnv' = flip replaceGlobalEnv + +-- | replaceTypeEnv with arguments flipped. +replaceTypeEnv' :: TypeEnv -> Context -> Context +replaceTypeEnv' = flip replaceTypeEnv + +-- | replaceHistory with arguments flipped. +replaceHistory' :: [XObj] -> Context -> Context +replaceHistory' = flip replaceHistory + +-------------------------------------------------------------------------------- +-- Binding Insertion Functions + +-- | Adds a binder to a context's global 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. +insertInGlobalEnv :: Context -> QualifiedPath -> Binder -> Context +insertInGlobalEnv ctx qpath binder = + let globalEnv = contextGlobalEnv ctx + in ctx {contextGlobalEnv = envInsertAt globalEnv (unqualify qpath) binder} + +-- | 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 path binder)} + in ctx {contextTypeEnv = TypeEnv (envInsertAt typeEnv (unqualify 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 ctx path@(SymPath [] _) binder = + ctx {contextInternalEnv = fmap 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" + +-- | insertInGlobalEnv with arguments flipped. +insertInGlobalEnv' :: QualifiedPath -> Binder -> Context -> 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 + +-- | Inserts a let binding into the appropriate environment in a context. +bindLetDeclaration :: Context -> String -> XObj -> Context +bindLetDeclaration ctx name xobj = + let binder = Binder emptyMeta (toLocalDef name xobj) + in insertInInternalEnv ctx (SymPath [] name) binder + +-------------------------------------------------------------------------------- +-- 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 +innermostModuleEnv ctx = go (contextPath ctx) + where + go :: [String] -> Maybe Env + go [] = Nothing + go xs = Just $ getEnv (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 f ctx path = + f (replacePath ctx []) path + +lookupInterface :: Context -> SymPath -> Maybe Binder +lookupInterface ctx path = + decontextualizedLookup lookupBinderInTypeEnv ctx path + +-- | Lookup a binder in a context's type environment. +-- +-- 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 ctx path = + let typeEnv = getTypeEnv (contextTypeEnv ctx) + fullPath = contextualize path ctx + in lookupBinder fullPath typeEnv + +-- | 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 ctx path = + let global = contextGlobalEnv ctx + fullPath = contextualize path ctx + in lookupBinder fullPath global + +-- | 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 ctx path = + let ctxEnv = contextEnv ctx + fullPath = contextualize path ctx + in lookupBinder fullPath ctxEnv diff --git a/src/Eval.hs b/src/Eval.hs index a85de08f..67854ae8 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -4,6 +4,7 @@ module Eval where import ColorText import Commands +import Context import Control.Applicative import Control.Exception import Control.Monad.State @@ -137,7 +138,7 @@ eval ctx xobj@(XObj o info ty) preference resolver = Right (XObj (StaticArr ok) info ty) ) _ -> do - (nctx, res) <- annotateWithinContext False ctx xobj + (nctx, res) <- annotateWithinContext ctx xobj pure $ case res of Left e -> (nctx, Left e) Right (val, _) -> (nctx, Right val) @@ -274,14 +275,15 @@ eval ctx xobj@(XObj o info ty) preference resolver = do let binds = unwrapVar (pairwise bindings) [] ni = Env Map.empty (contextInternalEnv ctx) Nothing Set.empty InternalEnv 0 - eitherCtx <- foldrM successiveEval' (Right ctx {contextInternalEnv = Just ni}) binds + eitherCtx <- foldrM successiveEval' (Right (replaceInternalEnv ctx ni)) binds case eitherCtx of Left err -> pure (ctx, Left err) Right newCtx -> do (finalCtx, evaledBody) <- eval newCtx body preference ResolveLocal let Just e = contextInternalEnv finalCtx + Just parentEnv = envParent e pure - ( finalCtx {contextInternalEnv = envParent e}, + ( replaceInternalEnv finalCtx parentEnv, do okBody <- evaledBody Right okBody @@ -296,10 +298,8 @@ eval ctx xobj@(XObj o info ty) preference resolver = Right ctx' -> do (newCtx, res) <- eval ctx' x preference resolver case res of - Right okX -> do - let binder = Binder emptyMeta (toLocalDef n okX) - Just e = contextInternalEnv newCtx - pure $ Right (newCtx {contextInternalEnv = Just (envInsertAt e (SymPath [] n) binder)}) + Right okX -> + pure $ Right (bindLetDeclaration newCtx n okX) Left err -> pure $ Left err [f@(XObj Fn {} _ _), args@(XObj (Arr a) _ _), body] -> do (newCtx, expanded) <- macroExpand ctx body @@ -320,7 +320,8 @@ eval ctx xobj@(XObj o info ty) preference resolver = Right okArgs -> do let newGlobals = (contextGlobalEnv newCtx) <> (contextGlobalEnv c) newTypes = TypeEnv $ (getTypeEnv (contextTypeEnv newCtx)) <> (getTypeEnv (contextTypeEnv c)) - (_, res) <- apply (c {contextHistory = contextHistory ctx, contextGlobalEnv = newGlobals, contextTypeEnv = newTypes}) body params okArgs + updater = replaceHistory' (contextHistory ctx) . replaceGlobalEnv' newGlobals . replaceTypeEnv' newTypes + (_, res) <- apply (updater c) body params okArgs pure (newCtx, res) Left err -> pure (newCtx, Left err) XObj (Lst [XObj Dynamic _ _, sym, XObj (Arr params) _ _, body]) i _ : args -> @@ -490,14 +491,11 @@ macroExpand ctx xobj = pure (ctx, Right xobj) XObj (Lst [XObj (Lst (XObj Macro _ _ : _)) _ _]) _ _ -> evalDynamic ResolveLocal ctx xobj XObj (Lst (x@(XObj (Sym _ _) _ _) : args)) i t -> do - (next, f) <- evalDynamic ResolveLocal ctx x + (_, f) <- evalDynamic ResolveLocal ctx x case f of Right m@(XObj (Lst (XObj Macro _ _ : _)) _ _) -> do (newCtx', res) <- evalDynamic ResolveLocal ctx (XObj (Lst (m : args)) i t) pure (newCtx', res) - -- TODO: Determine a way to eval primitives generally and remove this special case. - Right p@(XObj (Lst [XObj (Primitive (VariadicPrimitive variadic)) _ _, XObj (Sym (SymPath _ "defmodule") _) _ _, _]) _ _) -> - variadic p next args _ -> do (newCtx, expanded) <- foldlM successiveExpand (ctx, Right []) args pure @@ -527,7 +525,7 @@ macroExpand ctx xobj = apply :: Context -> XObj -> [XObj] -> [XObj] -> IO (Context, Either EvalError XObj) apply ctx@Context {contextInternalEnv = internal} body params args = - let env = contextEnv ctx + let Just env = contextInternalEnv ctx <|> innermostModuleEnv ctx <|> Just (contextGlobalEnv ctx) allParams = map getName params in case splitWhen (":rest" ==) allParams of [a, b] -> callWith env a b @@ -559,7 +557,7 @@ apply ctx@Context {contextInternalEnv = internal} body params args = insideEnv' (head rest) (XObj (Lst (drop n args)) Nothing Nothing) - (c, r) <- evalDynamic ResolveLocal (ctx {contextInternalEnv = Just insideEnv''}) body + (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. @@ -630,10 +628,10 @@ executeCommand ctx@(Context env _ _ _ _ _ _ _) xobj = Right res -> pure (res, newCtx) where callFromRepl newCtx xobj' = do - (nc, r) <- annotateWithinContext False newCtx xobj' + (nc, r) <- annotateWithinContext newCtx xobj' case r of Right (ann, deps) -> do - ctxWithDeps <- liftIO $ foldM (define True) nc deps + ctxWithDeps <- liftIO $ foldM (define True) nc (map Qualified deps) executeCommand ctxWithDeps (withBuildAndRun (buildMainFunction ann)) Left err -> do reportExecutionError nc (show err) @@ -686,24 +684,25 @@ catcher ctx exception = specialCommandWith :: Context -> XObj -> SymPath -> [XObj] -> IO (Context, Either EvalError XObj) specialCommandWith ctx _ path forms = do - let env = contextEnv ctx + let Just env = contextInternalEnv ctx <|> innermostModuleEnv ctx <|> Just (contextGlobalEnv ctx) useThese = envUseModules env env' = env {envUseModules = Set.insert path useThese} - ctx' = ctx {contextGlobalEnv = env'} + ctx' = replaceGlobalEnv ctx env' ctxAfter <- liftIO $ foldM folder ctx' forms - let envAfter = contextEnv ctxAfter - ctxAfter' = ctx {contextGlobalEnv = envAfter {envUseModules = useThese}} -- This will undo ALL use:s made inside the 'with'. + let Just envAfter = contextInternalEnv ctxAfter <|> innermostModuleEnv ctxAfter <|> Just (contextGlobalEnv ctxAfter) + -- undo ALL use:s made inside the 'with'. + ctxAfter' = replaceGlobalEnv ctx (envAfter {envUseModules = useThese}) pure (ctxAfter', dynamicNil) specialCommandDefine :: Context -> XObj -> IO (Context, Either EvalError XObj) specialCommandDefine ctx xobj = do - (newCtx, result) <- annotateWithinContext True ctx xobj + (newCtx, result) <- annotateWithinContext ctx xobj case result of Right (annXObj, annDeps) -> do - ctxWithDeps <- liftIO $ foldM (define True) newCtx annDeps - ctxWithDef <- liftIO $ define False ctxWithDeps annXObj + ctxWithDeps <- liftIO $ foldM (define True) newCtx (map Qualified annDeps) + ctxWithDef <- liftIO $ define False ctxWithDeps (Qualified annXObj) pure (ctxWithDef, dynamicNil) Left err -> pure (ctx, Left err) @@ -732,9 +731,11 @@ specialCommandWhile ctx cond body = do ) Left e -> pure (newCtx, Left e) -getSigFromDefnOrDef :: Context -> Env -> FilePathPrintLength -> XObj -> Either EvalError (Maybe (Ty, XObj)) -getSigFromDefnOrDef ctx globalEnv fppl xobj = +getSigFromDefnOrDef :: Context -> XObj -> Either EvalError (Maybe (Ty, XObj)) +getSigFromDefnOrDef ctx xobj = let pathStrings = contextPath ctx + globalEnv = contextGlobalEnv ctx + fppl = projectFilePathPrintLength (contextProj ctx) path = getPath xobj fullPath = case path of (SymPath [] _) -> consPath pathStrings path @@ -751,14 +752,12 @@ getSigFromDefnOrDef ctx globalEnv fppl xobj = Nothing -> Left (EvalError ("Can't use '" ++ pretty foundSignature ++ "' as a type signature") (contextHistory ctx) fppl (xobjInfo xobj)) Nothing -> Right Nothing -annotateWithinContext :: Bool -> Context -> XObj -> IO (Context, Either EvalError (XObj, [XObj])) -annotateWithinContext qualifyDefn ctx xobj = do - let pathStrings = contextPath ctx - fppl = projectFilePathPrintLength (contextProj ctx) - globalEnv = contextGlobalEnv ctx +annotateWithinContext :: Context -> XObj -> IO (Context, Either EvalError (XObj, [XObj])) +annotateWithinContext ctx xobj = do + let globalEnv = contextGlobalEnv ctx typeEnv = contextTypeEnv ctx - innerEnv = getEnv globalEnv pathStrings - let sig = getSigFromDefnOrDef ctx globalEnv fppl xobj + sig = getSigFromDefnOrDef ctx xobj + fppl = projectFilePathPrintLength (contextProj ctx) case sig of Left err -> pure (ctx, Left err) Right okSig -> do @@ -766,16 +765,17 @@ annotateWithinContext qualifyDefn ctx xobj = do case expansionResult of Left err -> pure (evalError ctx (show err) Nothing) Right expanded -> - let xobjFullPath = if qualifyDefn then setFullyQualifiedDefn expanded (SymPath pathStrings (getName xobj)) else expanded - xobjFullSymbols = setFullyQualifiedSymbols typeEnv globalEnv innerEnv xobjFullPath - in case annotate typeEnv globalEnv xobjFullSymbols okSig of - Left err -> - case contextExecMode ctx of - Check -> - pure (evalError ctx (joinLines (machineReadableErrorStrings fppl err)) Nothing) - _ -> - pure (evalError ctx (show err) (xobjInfo xobj)) - Right ok -> pure (ctx, Right ok) + let xobjFullSymbols = qualify ctx expanded + in case xobjFullSymbols of + Left err -> pure (evalError ctx (show err) (xobjInfo xobj)) + Right xs -> + case annotate typeEnv globalEnv xs okSig of + Left err -> + -- TODO: Replace this with a single call to evalError (which already checks the execution mode) + case contextExecMode ctx of + Check -> pure (evalError ctx (joinLines (machineReadableErrorStrings fppl err)) Nothing) + _ -> pure (evalError ctx (show err) (xobjInfo xobj)) + Right ok -> pure (ctx, Right ok) primitiveDefmodule :: VariadicPrimitiveCallback primitiveDefmodule xobj ctx@(Context env i _ pathStrings _ _ _ _) (XObj (Sym (SymPath [] moduleName) _) _ _ : innerExpressions) = @@ -911,8 +911,8 @@ loadInternal ctx xobj path i fileToLoad reloadMode = do projectAlreadyLoaded = canonicalPath : alreadyLoaded, projectLoadStack = canonicalPath : prevStack } - newCtx <- liftIO $ executeString True False (ctx {contextProj = proj'}) contents canonicalPath - pure (newCtx {contextProj = (contextProj newCtx) {projectLoadStack = prevStack}}, dynamicNil) + newCtx <- liftIO $ executeString True False (replaceProject ctx proj') contents canonicalPath + pure (replaceProject newCtx (contextProj newCtx) {projectLoadStack = prevStack}, dynamicNil) where frozenPaths proj = if projectForceReload proj @@ -1048,7 +1048,7 @@ commandReload ctx = do else do contents <- slurp filepath let proj' = proj {projectAlreadyLoaded = filepath : alreadyLoaded} - executeString False False (context {contextProj = proj'}) contents filepath + executeString False False (replaceProject context proj') contents filepath newCtx <- liftIO (foldM f ctx paths) pure (newCtx, dynamicNil) @@ -1060,13 +1060,12 @@ commandExpand = macroExpand -- | i.e. (Int.+ 2 3) => "_0 = 2 + 3" commandC :: UnaryCommandCallback commandC ctx xobj = do - let globalEnv = contextGlobalEnv ctx - typeEnv = contextTypeEnv ctx (newCtx, result) <- expandAll (evalDynamic ResolveLocal) ctx xobj case result of Left err -> pure (newCtx, Left err) - Right expanded -> - case annotate typeEnv globalEnv (setFullyQualifiedSymbols typeEnv globalEnv globalEnv expanded) Nothing of + Right expanded -> do + (_, annotated) <- annotateWithinContext newCtx expanded + case annotated of Left err -> pure $ evalError newCtx (show err) (xobjInfo xobj) Right (annXObj, annDeps) -> do @@ -1171,12 +1170,12 @@ specialCommandSet ctx [orig@(XObj (Sym path@(SymPath _ n) _) _ _), val] = setGlobal ctx' env value binder = pure $ either (failure ctx' orig) (success ctx') value where - success c xo = (c {contextGlobalEnv = setStaticOrDynamicVar path env binder xo}, dynamicNil) + success c xo = (replaceGlobalEnv c (setStaticOrDynamicVar path env binder xo), dynamicNil) setInternal :: Context -> Env -> Either EvalError XObj -> Binder -> IO (Context, Either EvalError XObj) setInternal ctx' env value binder = pure $ either (failure ctx' orig) (success ctx') value where - success c xo = (c {contextInternalEnv = Just (setStaticOrDynamicVar (SymPath [] n) env binder xo)}, dynamicNil) + success c xo = (replaceInternalEnv c (setStaticOrDynamicVar (SymPath [] n) env binder xo), dynamicNil) specialCommandSet ctx [notName, _] = pure (evalError ctx ("`set!` expected a name as first argument, but got " ++ pretty notName) (xobjInfo notName)) specialCommandSet ctx args = @@ -1190,7 +1189,7 @@ failure ctx orig err = evalError ctx (show err) (xobjInfo orig) -- the given value has a type matching the binder's in the given context. typeCheckValueAgainstBinder :: Context -> XObj -> Binder -> IO (Context, Either EvalError XObj) typeCheckValueAgainstBinder ctx val binder = do - (ctx', typedValue) <- annotateWithinContext False ctx val + (ctx', typedValue) <- annotateWithinContext ctx val pure $ case typedValue of Right (val', _) -> go ctx' binderTy val' Left err -> (ctx', Left err) diff --git a/src/Infer.hs b/src/Infer.hs index 44cd0951..752651e0 100644 --- a/src/Infer.hs +++ b/src/Infer.hs @@ -15,6 +15,7 @@ import Constraints import GenerateConstraints import InitialTypes import Obj +import Qualify import TypeError import Types @@ -22,10 +23,10 @@ import Types -- | Returns a list of all the bindings that need to be added for the new form to work. -- | The concretization of MultiSym:s (= ambiguous use of symbols, resolved by type usage) -- | makes it possible to solve more types so let's do it several times. -annotate :: TypeEnv -> Env -> XObj -> Maybe (Ty, XObj) -> Either TypeError (XObj, [XObj]) -annotate typeEnv globalEnv xobj rootSig = +annotate :: TypeEnv -> Env -> Qualified -> Maybe (Ty, XObj) -> Either TypeError (XObj, [XObj]) +annotate typeEnv globalEnv qualifiedXObj rootSig = do - initiated <- initialTypes typeEnv globalEnv xobj + initiated <- initialTypes typeEnv globalEnv (unQualified qualifiedXObj) (annotated, dependencies) <- annotateUntilDone typeEnv globalEnv initiated rootSig [] 100 (final, deleteDeps) <- manageMemory typeEnv globalEnv annotated finalWithNiceTypes <- beautifyTypeVariables final diff --git a/src/Lookup.hs b/src/Lookup.hs index a8c264b1..92e29756 100644 --- a/src/Lookup.hs +++ b/src/Lookup.hs @@ -30,24 +30,6 @@ lookupInEnv path@(SymPath (p : ps) name) env = Just parent -> lookupInEnv path parent Nothing -> Nothing --- | Lookup a binder in a context's typeEnv. -lookupBinderInTypeEnv :: Context -> SymPath -> Maybe Binder -lookupBinderInTypeEnv ctx path = - let typeEnv = getTypeEnv (contextTypeEnv ctx) - in lookupBinder path typeEnv - --- | Lookup a binder in a context's globalEnv. -lookupBinderInGlobalEnv :: Context -> SymPath -> Maybe Binder -lookupBinderInGlobalEnv ctx path = - let global = contextGlobalEnv ctx - in lookupBinder path global - --- | Lookup a binder in a context's contextEnv. -lookupBinderInContextEnv :: Context -> SymPath -> Maybe Binder -lookupBinderInContextEnv ctx path = - let ctxEnv = contextEnv ctx - in lookupBinder path ctxEnv - -- | Performs a multiLookupEverywhere but drops envs from the result and wraps -- the results in a Maybe. multiLookupBinderEverywhere :: Context -> SymPath -> Maybe [Binder] diff --git a/src/Meta.hs b/src/Meta.hs index a52333f1..8f88a8b8 100644 --- a/src/Meta.hs +++ b/src/Meta.hs @@ -7,6 +7,7 @@ module Meta updateBinderMeta, Meta.member, binderMember, + hide, ) where @@ -56,3 +57,7 @@ member key meta = Map.member key $ getMeta meta binderMember :: String -> Binder -> Bool binderMember key binder = Meta.member key $ fromBinder binder + +hide :: Binder -> Binder +hide binder = + updateBinderMeta binder "hidden" trueXObj diff --git a/src/Obj.hs b/src/Obj.hs index 66e16481..16034005 100644 --- a/src/Obj.hs +++ b/src/Obj.hs @@ -1099,3 +1099,15 @@ instance Semigroup Context where toLocalDef :: String -> XObj -> XObj toLocalDef var value = (XObj (Lst [XObj LocalDef Nothing Nothing, XObj (Sym (SymPath [] var) Symbol) Nothing Nothing, value]) (xobjInfo value) (xobjTy value)) + +-- | Create a fresh binder for an XObj (a binder with empty Metadata). +toBinder :: XObj -> Binder +toBinder xobj = Binder emptyMeta xobj + +-- | Dynamic 'true'. +trueXObj :: XObj +trueXObj = XObj (Bol True) Nothing Nothing + +-- | Dynamic 'false'. +falseXObj :: XObj +falseXObj = XObj (Bol False) Nothing Nothing diff --git a/src/Primitives.hs b/src/Primitives.hs index e68c443c..216bdbdc 100644 --- a/src/Primitives.hs +++ b/src/Primitives.hs @@ -10,7 +10,7 @@ import Control.Monad (foldM, unless, when) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Either (rights) import Data.Functor ((<&>)) -import Data.List (foldl', union) +import Data.List (foldl') import Data.Maybe (fromJust, fromMaybe, mapMaybe) import Deftype import Emit @@ -25,6 +25,7 @@ import qualified Meta import Obj import PrimitiveError import Project +import Qualify (Qualified (..), getQualifiedPath, markQualified, qualify, qualifyNull, qualifyPath, unqualify) import Reify import qualified Set import Sumtypes @@ -36,11 +37,6 @@ import Types import Util import Web.Browser (openBrowser) --- found :: (MonadIO m, Show a1) => a2 -> a1 -> m (a2, Either a3 XObj) --- found ctx binder = --- liftIO $ do putStrLnWithColor White (show binder) --- pure (ctx, dynamicNil) - makeNullaryPrim :: SymPath -> NullaryPrimitiveCallback -> String -> String -> (String, Binder) makeNullaryPrim p = makePrim p . NullaryPrimitive @@ -122,22 +118,18 @@ primitiveColumn x@(XObj _ i _) ctx args = err = toEvalError ctx x (MissingInfo x) primitiveImplements :: BinaryPrimitiveCallback -primitiveImplements call ctx x@(XObj (Sym interface@(SymPath _ _) _) _ _) (XObj (Sym (SymPath prefixes name) _) _ _) = +primitiveImplements _ ctx x@(XObj (Sym interface@(SymPath _ _) _) _ _) (XObj (Sym path _) _ _) = do - (maybeInterface, maybeImpl) <- pure (lookupBinder interface tyEnv, lookupBinder (SymPath modules name) global) + (maybeInterface, maybeImpl) <- pure (lookupInterface ctx interface, lookupBinderInGlobalEnv ctx qpath) case (maybeInterface, maybeImpl) of - (_, Nothing) -> - if null modules - then pure (toEvalError ctx call ForewardImplementsMeta) - else updateMeta (Meta.stub (SymPath modules name)) ctx + (_, Nothing) -> updateMeta (Meta.stub (contextualize path ctx)) ctx (Nothing, Just implBinder) -> warn >> updateMeta implBinder ctx (Just interfaceBinder, Just implBinder) -> + -- N.B. The found binding will be fully qualified! addToInterface interfaceBinder implBinder where - global = contextGlobalEnv ctx - tyEnv = getTypeEnv . contextTypeEnv $ ctx - SymPath modules _ = consPath (contextPath ctx `union` prefixes) (SymPath [] name) + qpath = qualifyNull ctx path warn :: IO () warn = emitWarning (show (NonExistentInterfaceWarning x)) addToInterface :: Binder -> Binder -> IO (Context, Either EvalError XObj) @@ -159,7 +151,7 @@ primitiveImplements call ctx x@(XObj (Sym interface@(SymPath _ _) _) _ _) (XObj ) <|> Just (updateImplementations binder (XObj (Lst []) (Just dummyInfo) (Just DynamicTy))) ) - >>= \newBinder -> pure (context {contextGlobalEnv = envInsertAt (contextGlobalEnv context) (getBinderPath binder) newBinder}) + >>= pure . (insertInGlobalEnv context qpath) updateImplementations :: Binder -> XObj -> Binder updateImplementations implBinder (XObj (Lst impls) inf ty) = if x `elem` impls @@ -172,37 +164,34 @@ primitiveImplements x ctx (XObj (Sym _ _) _ _) y = primitiveImplements _ ctx x _ = pure $ toEvalError ctx x (ArgumentTypeError "implements" "a symbol" "first" x) -define :: Bool -> Context -> XObj -> IO Context -define hidden ctx@(Context globalEnv _ typeEnv _ proj _ _ _) annXObj = - pure (hideIt freshBinder) +-- N.B. Symbols come into this function FULLY QUALIFIED! +-- see Eval.hs annotateWithinContext +define :: Bool -> Context -> Qualified -> IO Context +define hidden ctx qualifiedXObj = + pure (if hidden then (Meta.hide freshBinder) else freshBinder) >>= \newBinder -> if isTypeDef annXObj then defineInTypeEnv newBinder else defineInGlobalEnv newBinder where - freshBinder = Binder emptyMeta annXObj + annXObj = unQualified qualifiedXObj + freshBinder = toBinder annXObj + qpath = getQualifiedPath qualifiedXObj defineInTypeEnv :: Binder -> IO Context - defineInTypeEnv binder = pure (insertInTypeEnv ctx (getPath annXObj) binder) + defineInTypeEnv = pure . (insertInTypeEnv ctx qpath) defineInGlobalEnv :: Binder -> IO Context - defineInGlobalEnv fallbackBinder = + 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 + redefineExistingBinder :: Binder -> Binder -> IO Context + redefineExistingBinder old@(Binder meta _) (Binder _ x) = do - let maybeExistingBinder = lookupBinder (getPath annXObj) globalEnv - when (projectEchoC proj) (putStrLn (toC All (Binder emptyMeta annXObj))) - case maybeExistingBinder of - Nothing -> pure (insertInGlobalEnv ctx (getPath annXObj) fallbackBinder) - Just binder -> redefineExistingBinder binder - redefineExistingBinder :: Binder -> IO Context - redefineExistingBinder old@(Binder meta _) = - do - let updatedBinder = hideIt (Binder meta annXObj) warnTypeChange old - updatedContext <- implementInterfaces updatedBinder - pure (insertInGlobalEnv updatedContext (getPath annXObj) updatedBinder) - hideIt :: Binder -> Binder - hideIt binder = - if hidden - then Meta.updateBinderMeta binder "hidden" trueXObj - else binder + -- TODO: Merge meta more elegantly. + updatedContext <- (implementInterfaces (Binder meta x)) + pure (insertInGlobalEnv updatedContext qpath (Binder meta x)) warnTypeChange :: Binder -> IO () warnTypeChange binder = unless (areUnifiable (forceTy annXObj) previousType) warn @@ -215,10 +204,11 @@ define hidden ctx@(Context globalEnv _ typeEnv _ proj _ _ _) annXObj = implementInterfaces binder = pure ( Meta.getBinderMetaValue "implements" binder - >>= \(XObj (Lst interfaces) _ _) -> pure (map getPath interfaces) + -- TODO: Direct qualification! + >>= \(XObj (Lst interfaces) _ _) -> pure (map Qualified interfaces) ) >>= \maybeinterfaces -> - pure (mapMaybe (`lookupBinder` getTypeEnv typeEnv) (fromMaybe [] maybeinterfaces)) + pure (mapMaybe (lookupBinderInTypeEnv ctx . getQualifiedPath) (fromMaybe [] maybeinterfaces)) >>= \interfaceBinders -> pure (foldl' (\(ctx', _) interface -> registerInInterface ctx' binder interface) (ctx, Nothing) interfaceBinders) >>= \(newCtx, err) -> case err of @@ -245,36 +235,29 @@ primitiveRegisterType x ctx _ = pure (toEvalError ctx x RegisterTypeError) primitiveRegisterTypeWithoutFields :: Context -> String -> Maybe String -> IO (Context, Either EvalError XObj) primitiveRegisterTypeWithoutFields ctx t override = do - let pathStrings = contextPath ctx - typeEnv = contextTypeEnv ctx - path = SymPath pathStrings t + let path = SymPath [] t typeDefinition = XObj (Lst [XObj (ExternalType override) Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing]) Nothing (Just TypeTy) - pure (ctx {contextTypeEnv = TypeEnv (extendEnv (getTypeEnv typeEnv) t typeDefinition)}, dynamicNil) + pure (insertInTypeEnv ctx (qualifyPath ctx path) (toBinder typeDefinition), dynamicNil) primitiveRegisterTypeWithFields :: Context -> XObj -> String -> Maybe String -> XObj -> IO (Context, Either EvalError XObj) primitiveRegisterTypeWithFields ctx x t override members = either handleErr updateContext - (bindingsForRegisteredType typeEnv globalEnv pathStrings t [members] Nothing preExistingModule) + (bindingsForRegisteredType (contextTypeEnv ctx) (contextGlobalEnv ctx) (contextPath ctx) t [members] Nothing preExistingModule) where handleErr e = pure $ makeEvalError ctx (Just e) (show e) (xobjInfo x) updateContext (typeModuleName, typeModuleXObj, deps) = do let typeDefinition = XObj (Lst [XObj (ExternalType override) Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing]) Nothing (Just TypeTy) - ctx' = - ( ctx - { contextGlobalEnv = envInsertAt globalEnv (SymPath pathStrings typeModuleName) (Binder emptyMeta typeModuleXObj), - contextTypeEnv = TypeEnv (extendEnv (getTypeEnv typeEnv) t typeDefinition) - } - ) - contextWithDefs <- liftIO $ foldM (define True) ctx' deps + path' = (qualifyPath ctx (SymPath [] typeModuleName)) + update = insertInTypeEnv' path' (toBinder typeDefinition) . insertInGlobalEnv' path' (toBinder typeModuleXObj) + 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) - pathStrings = contextPath ctx - globalEnv = contextGlobalEnv ctx - typeEnv = contextTypeEnv ctx - path = SymPath pathStrings t - preExistingModule = case lookupBinder (SymPath pathStrings t) globalEnv of + path = SymPath [] t + preExistingModule = case lookupBinderInGlobalEnv ctx path of Just (Binder _ (XObj (Mod found) _ _)) -> Just found _ -> Nothing @@ -359,19 +342,16 @@ primitiveInfo _ ctx notName = dynamicOrMacroWith :: Context -> (SymPath -> [XObj]) -> Ty -> String -> XObj -> IO (Context, Either EvalError XObj) dynamicOrMacroWith ctx producer ty name body = do - let pathStrings = contextPath ctx - globalEnv = contextGlobalEnv ctx - path = SymPath pathStrings name - elt = XObj (Lst (producer path)) (xobjInfo body) (Just ty) - meta = lookupMeta (getPath elt) globalEnv - pure (ctx {contextGlobalEnv = envInsertAt globalEnv path (Binder meta elt)}, dynamicNil) + 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) primitiveMembers :: UnaryPrimitiveCallback primitiveMembers _ ctx target = do - let typeEnv = contextTypeEnv ctx case bottomedTarget target of XObj (Sym path@(SymPath _ name) _) _ _ -> - case lookupBinder path (getTypeEnv typeEnv) of + case lookupBinderInTypeEnv ctx path of Just ( Binder _ @@ -414,11 +394,10 @@ primitiveMembers _ ctx target = do 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)) where - env = contextEnv ctx bottomedTarget t = case t of XObj (Sym targetPath _) _ _ -> - case lookupBinder targetPath env of + 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 @@ -430,47 +409,35 @@ primitiveMembers _ ctx target = do -- | Set meta data for a Binder primitiveMetaSet :: TernaryPrimitiveCallback -primitiveMetaSet _ ctx target@(XObj (Sym (SymPath prefixes name) _) _ _) (XObj (Str key) _ _) value = +primitiveMetaSet _ ctx target@(XObj (Sym path@(SymPath prefixes _) _) _ _) (XObj (Str key) _ _) value = pure $ maybe create (,dynamicNil) lookupAndUpdate where - fullPath@(SymPath modules _) = consPath (contextPath ctx `union` prefixes) (SymPath [] name) - dynamicPath = consPath ["Dynamic"] fullPath - global = contextGlobalEnv ctx - types = getTypeEnv (contextTypeEnv ctx) + qpath = qualifyPath ctx path + fullPath@(SymPath modules _) = unqualify qpath lookupAndUpdate :: Maybe Context lookupAndUpdate = - ( lookupBinder dynamicPath global + ( lookupBinderInGlobalEnv ctx path >>= \binder -> pure (Meta.updateBinderMeta binder key value) - >>= \b -> - pure (envInsertAt global dynamicPath b) - >>= \env -> pure (ctx {contextGlobalEnv = env}) + >>= pure . (insertInGlobalEnv ctx qpath) ) - <|> ( lookupBinder fullPath global - >>= \binder -> - pure (Meta.updateBinderMeta binder key value) - >>= \b -> - pure (envInsertAt global fullPath b) - >>= \env -> pure (ctx {contextGlobalEnv = env}) - ) -- 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 - lookupBinder fullPath types + lookupBinderInTypeEnv ctx qpath >>= \binder -> pure (Meta.updateBinderMeta binder key value) - >>= \b -> - pure (envInsertAt types fullPath b) - >>= \env -> pure (ctx {contextTypeEnv = TypeEnv env}) + >>= pure . (insertInTypeEnv ctx qpath) else Nothing 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 - newEnv = envInsertAt global fullPath updated - in (ctx {contextGlobalEnv = newEnv}, dynamicNil) + in (insertInGlobalEnv ctx qpath updated, dynamicNil) else evalError ctx ("`meta-set!` failed, I can't find the symbol `" ++ pretty target ++ "`") (xobjInfo target) primitiveMetaSet _ ctx (XObj (Sym (SymPath _ _) _) _ _) key _ = argumentErr ctx "meta-set!" "a string" "second" key @@ -481,14 +448,14 @@ primitiveDefinterface :: BinaryPrimitiveCallback primitiveDefinterface xobj ctx nameXObj@(XObj (Sym path@(SymPath [] name) _) _ _) ty = pure $ maybe invalidType validType (xobjToTy ty) where - typeEnv = getTypeEnv (contextTypeEnv ctx) invalidType = evalError ctx ("Invalid type for interface `" ++ name ++ "`: " ++ pretty ty) (xobjInfo ty) - validType t = maybe defInterface updateInterface (lookupBinder path typeEnv) + validType t = maybe defInterface updateInterface (lookupBinderInTypeEnv ctx path) where defInterface = let interface = defineInterface name t [] (xobjInfo nameXObj) - typeEnv' = TypeEnv (envInsertAt typeEnv (SymPath [] name) (Binder emptyMeta interface)) - newCtx = retroactivelyRegisterInInterface (ctx {contextTypeEnv = typeEnv'}) (Binder emptyMeta interface) + binder = toBinder interface + ctx' = insertInTypeEnv ctx (markQualified (SymPath [] name)) binder + newCtx = retroactivelyRegisterInInterface ctx' binder in (newCtx, dynamicNil) updateInterface binder = case binder of Binder _ (XObj (Lst (XObj (Interface foundType _) _ _ : _)) _ _) -> @@ -514,8 +481,6 @@ registerInternal :: Context -> String -> XObj -> Maybe String -> IO (Context, Ei registerInternal ctx name ty override = pure $ maybe invalidType validType (xobjToTy ty) where - pathStrings = contextPath ctx - globalEnv = contextGlobalEnv ctx invalidType = evalError ctx @@ -525,20 +490,19 @@ registerInternal ctx name ty override = (xobjInfo ty) -- TODO: Retroactively register in interface if implements metadata is present. validType t = - let path = SymPath pathStrings name + let qpath = qualifyPath ctx (SymPath [] name) registration = XObj ( Lst [ XObj (External override) Nothing Nothing, - XObj (Sym path Symbol) Nothing Nothing, + XObj (Sym (unqualify qpath) Symbol) Nothing Nothing, ty ] ) (xobjInfo ty) (Just t) - meta = lookupMeta (getPath registration) globalEnv - env' = envInsertAt globalEnv path (Binder meta registration) - in (ctx {contextGlobalEnv = env'}, dynamicNil) + meta = lookupMeta (getPath registration) (contextGlobalEnv ctx) + in (insertInGlobalEnv ctx qpath (Binder meta registration), dynamicNil) primitiveRegister :: VariadicPrimitiveCallback primitiveRegister _ ctx [XObj (Sym (SymPath [] name) _) _ _, ty] = @@ -654,7 +618,7 @@ primitiveDeftype xobj ctx (name : rest) = 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 = envInsertAt env (SymPath pathStrings typeModuleName) (Binder preExistingMeta typeModuleXObj) + 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 @@ -672,23 +636,20 @@ primitiveDeftype xobj ctx (name : rest) = Just existing@(Binder _ (XObj (Mod _) _ _)) -> existing _ -> Binder emptyMeta (XObj (Mod (holderEnv name'' prevEnv)) (Just dummyInfo) (Just ModuleTy)) folder (contx, prev, priorPaths) pathstring = - (contx {contextTypeEnv = TypeEnv $ envInsertAt (getTypeEnv (contextTypeEnv contx)) (SymPath priorPaths pathstring) (holderModule pathstring prev priorPaths (getTypeEnv (contextTypeEnv contx)))}, holderEnv pathstring 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) - ctx' = - ( wHolders - { contextGlobalEnv = updatedGlobal, - contextTypeEnv = TypeEnv (envInsertAt (getTypeEnv (contextTypeEnv wHolders)) (SymPath pathStrings tyName) (Binder emptyMeta typeDefinition)) - } - ) + update = insertInTypeEnv' (markQualified (SymPath pathStrings tyName)) (toBinder typeDefinition) . replaceGlobalEnv' (contextGlobalEnv updatedGlobal) + ctx' = update wHolders in do - ctxWithDeps <- liftIO (foldM (define True) ctx' deps) + -- 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 = lookupBinder (SymPath [] "delete") (getTypeEnv typeEnv) - Just strInterface = lookupBinder (SymPath [] "str") (getTypeEnv typeEnv) - Just copyInterface = lookupBinder (SymPath [] "copy") (getTypeEnv typeEnv) + 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 @@ -727,24 +688,21 @@ primitiveUse xobj ctx (XObj (Sym path _) _ _) = lookupInGlobal = maybe missing useModule (lookupInEnv path env) where missing = evalError ctx ("Can't find a module named '" ++ show path ++ "'") (xobjInfo xobj) - useModule _ = (ctx {contextGlobalEnv = envReplaceEnvAt env pathStrings e'}, dynamicNil) + useModule _ = (replaceGlobalEnv ctx (envReplaceEnvAt env pathStrings e'), dynamicNil) primitiveUse _ ctx x = argumentErr ctx "use" "a symbol" "first" x -- | Get meta data for a Binder primitiveMeta :: BinaryPrimitiveCallback -primitiveMeta (XObj _ i _) ctx (XObj (Sym (SymPath prefixes name) _) _ _) (XObj (Str key) _ _) = +primitiveMeta (XObj _ i _) ctx (XObj (Sym path _) _ _) (XObj (Str key) _ _) = pure $ maybe errNotFound foundBinder lookup' where - global = contextGlobalEnv ctx - types = getTypeEnv (contextTypeEnv ctx) - fullPath = consPath (contextPath ctx `union` prefixes) (SymPath [] name) lookup' :: Maybe Binder - lookup' = (lookupBinder fullPath global <|> lookupBinder fullPath types) >>= pure + lookup' = (lookupBinderInGlobalEnv ctx path <|> lookupBinderInTypeEnv ctx path) >>= pure foundBinder :: Binder -> (Context, Either EvalError XObj) foundBinder binder = (ctx, maybe dynamicNil Right (Meta.getBinderMetaValue key binder)) errNotFound :: (Context, Either EvalError XObj) - errNotFound = evalError ctx ("`meta` failed, I can’t find `" ++ show fullPath ++ "`") i + errNotFound = evalError ctx ("`meta` failed, I can’t find `" ++ show path ++ "`") i primitiveMeta _ ctx (XObj (Sym _ _) _ _) key = argumentErr ctx "meta" "a string" "second" key primitiveMeta _ ctx path _ = @@ -752,35 +710,30 @@ primitiveMeta _ ctx path _ = primitiveDefined :: UnaryPrimitiveCallback primitiveDefined _ ctx (XObj (Sym path _) _ _) = - let env = contextEnv ctx - in pure $ maybe (ctx, Right falseXObj) (const (ctx, Right trueXObj)) (lookupInEnv path env) + pure $ maybe (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 (SymPath [] name) _) _ _) ty (XObj (Str declTempl) _ _) (XObj (Str defTempl) _ _) = +primitiveDeftemplate _ ctx (XObj (Sym p@(SymPath [] _) _) _ _) ty (XObj (Str declTempl) _ _) (XObj (Str defTempl) _ _) = pure $ maybe invalidType validType (xobjToTy ty) where - pathStrings = contextPath ctx typeEnv = contextTypeEnv ctx globalEnv = contextGlobalEnv ctx - p = SymPath pathStrings name invalidType = evalError ctx ("I do not understand the type form in " ++ pretty ty) (xobjInfo ty) - validType t = case defineTemplate p t "" (toTemplate declTempl) (toTemplate defTempl) (const []) of + validType t = case defineTemplate (contextualize p ctx) t "" (toTemplate declTempl) (toTemplate defTempl) (const []) of (_, b@(Binder _ (XObj (Lst (XObj (Deftemplate template) _ _ : _)) _ _))) -> if isTypeGeneric t then let (Binder _ registration) = b meta = lookupMeta (getPath registration) globalEnv - env' = envInsertAt globalEnv p (Binder meta registration) - in (ctx {contextGlobalEnv = env'}, dynamicNil) + in (insertInGlobalEnv ctx (qualifyPath ctx p) (Binder meta registration), dynamicNil) else let templateCreator = getTemplateCreator template - (registration, _) = instantiateTemplate p t (templateCreator typeEnv globalEnv) + (registration, _) = instantiateTemplate (contextualize p ctx) t (templateCreator typeEnv globalEnv) meta = lookupMeta (getPath registration) globalEnv - env' = envInsertAt globalEnv p (Binder meta registration) - in (ctx {contextGlobalEnv = env'}, dynamicNil) + in (insertInGlobalEnv ctx (qualifyPath ctx p) (Binder meta registration), dynamicNil) _ -> error "primitivedeftemplate1" primitiveDeftemplate _ ctx (XObj (Sym (SymPath [] _) _) _ _) _ (XObj (Str _) _ _) x = argumentErr ctx "deftemplate" "a string" "fourth" x @@ -800,7 +753,7 @@ 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 (lookupBinder path env) + maybe otherDefs go (lookupBinderInGlobalEnv ctx path) where env = contextGlobalEnv ctx otherDefs = case multiLookupEverywhere name env of @@ -817,9 +770,8 @@ 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 . snd) (lookupInEnv qualifiedPath env) + maybe (notFound ctx x qualifiedPath) go (lookupBinderInGlobalEnv ctx qualifiedPath) where - env = contextGlobalEnv ctx go binder = case xobjTy (binderXObj binder) of Nothing -> noTypeError ctx x @@ -841,7 +793,7 @@ primitiveType any' ctx (XObj (Lst [XObj (Sym (SymPath [] "type") _) _ _, rest]) Left e -> pure (ctx, Left e) primitiveType _ ctx x@XObj {} = let tenv = contextTypeEnv ctx - typed = annotate tenv (contextGlobalEnv ctx) x Nothing + typed = either (\_ -> annotate tenv (contextGlobalEnv ctx) (Qualified x) Nothing) (\q -> annotate tenv (contextGlobalEnv ctx) q Nothing) $ qualify ctx x in liftIO $ either fail' ok typed where fail' _ = pure (evalError ctx ("Can't get the type of: " ++ pretty x) (xobjInfo x)) @@ -851,7 +803,7 @@ primitiveType _ ctx x@XObj {} = primitiveKind :: UnaryPrimitiveCallback primitiveKind _ ctx x@XObj {} = let tenv = contextTypeEnv ctx - typed = annotate tenv (contextGlobalEnv ctx) x Nothing + typed = either (\_ -> annotate tenv (contextGlobalEnv ctx) (Qualified x) Nothing) (\q -> annotate tenv (contextGlobalEnv ctx) q Nothing) $ qualify ctx x in pure (either fail' ok typed) where fail' _ = evalError ctx ("Can't get the kind of: " ++ pretty x) (xobjInfo x) diff --git a/src/Qualify.hs b/src/Qualify.hs index 88e99335..1bfd582f 100644 --- a/src/Qualify.hs +++ b/src/Qualify.hs @@ -1,5 +1,21 @@ -module Qualify where +-------------------------------------------------------------------------------- +-- | Defines data, errors, and functions for qualifying symbols in a given +-- context. +module Qualify + ( QualificationError, + QualifiedPath, + Qualified (..), + qualify, + qualifyPath, + unqualify, + markQualified, + qualifyNull, + getQualifiedPath, + ) +where + +import Control.Monad (foldM, liftM) import Data.List (foldl') import Debug.Trace import Env @@ -11,147 +27,285 @@ import qualified Set import Types import Util --- | Changes the symbol part of a defn (the name) to a new symbol path --- | Example: (defn foo () 123) => (defn GreatModule.foo () 123) -setFullyQualifiedDefn :: XObj -> SymPath -> XObj -setFullyQualifiedDefn (XObj (Lst [defn, XObj _ symi symt, args, body]) i t) newPath = - XObj (Lst [defn, XObj (Sym newPath Symbol) symi symt, args, body]) i t -setFullyQualifiedDefn (XObj (Lst [def, XObj _ symi symt, expr]) i t) newPath = - XObj (Lst [def, XObj (Sym newPath Symbol) symi symt, expr]) i t -setFullyQualifiedDefn xobj _ = error ("Can't set new path on " ++ show xobj) +-------------------------------------------------------------------------------- +-- Errors + +-- | Error qualifying a symbol. +data QualificationError + = FailedToQualifyDeclarationName XObj + | FailedToQualifySymbols XObj + | FailedToQualifyPath SymPath + +instance Show QualificationError where + show (FailedToQualifyDeclarationName xobj) = + "Couldn't fully qualify the definition: " ++ pretty xobj + show (FailedToQualifySymbols xobj) = + "Couldn't fully qualify the symbols in the form: " ++ pretty xobj + show (FailedToQualifyPath spath) = + "Couldn't fully qualify the symbol: " ++ show spath + ++ "in the given context." + +-------------------------------------------------------------------------------- +-- Data + +-- | Denotes an XObj containing only symbols that *have been fully qualified*. +-- +-- A fully qualified xobj **must not** be qualified further (e.g. using context +-- paths). +newtype Qualified = Qualified {unQualified :: XObj} + +-- | Denotes a symbol that has been fully qualified. +newtype QualifiedPath = QualifiedPath SymPath + deriving (Ord, Eq) + +instance Show QualifiedPath where + show (QualifiedPath spath) = show spath + +-------------------------------------------------------------------------------- +-- Path Qualification Functions + +-- | Qualifies a symbol in a given Context. +qualifyPath :: Context -> SymPath -> QualifiedPath +qualifyPath ctx spath = + let qpath = consPath (contextPath ctx) spath + in (QualifiedPath qpath) + +-- | Transforms a qualified path into an equivalent SymPath. +-- +-- Used to cross the qualified/unqualified symbol boundary. +-- This is predominantly used for compatibility with other parts of the +-- codebase once qualification checks have been performed. +unqualify :: QualifiedPath -> SymPath +unqualify (QualifiedPath spath) = spath + +-- | Marks a path as fully qualified without performing any transformations. +-- +-- Used to indicate a "naked", unprocessed path should be treated qualified as +-- given. For example, `inc` in `(implements inc Module.inc)` should be +-- interpreted as fully qualified as typed and should not be qualified using +-- the overarching context. +markQualified :: SymPath -> QualifiedPath +markQualified = QualifiedPath + +-- | Qualify a symbol contextually if it is not qualified, otherwise, mark it +-- qualified. +-- +-- This should be used whenever a path entered with *any* initial +-- qualifications should be treated as an absolute reference while symbols +-- without qualifications should be treated as a relative reference. +-- +-- For example, `Foo.inc` in `(implements inc Foo.inc)` will be treated as an +-- absolute reference to `Foo.inc`, even in the context of `Foo` and will not +-- be qualified further. Contrarily, the second `inc` in `(implements inc inc)` +-- in the context of `Foo` would be further qualified to `Foo.inc`. +qualifyNull :: Context -> SymPath -> QualifiedPath +qualifyNull ctx spath@(SymPath [] _) = qualifyPath ctx spath +qualifyNull _ spath = markQualified spath + +-------------------------------------------------------------------------------- +-- XObj Qualification Functions + +-- | Gets the qualified path of a fully qualified XObj. +getQualifiedPath :: Qualified -> QualifiedPath +getQualifiedPath = QualifiedPath . getPath . unQualified + +-- | Qualifies all symbols in an XObj in the given context. +qualify :: Context -> XObj -> Either QualificationError Qualified +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) + 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 + where + pathStrings :: [String] + pathStrings = contextPath ctx + t :: TypeEnv + t = contextTypeEnv ctx + g :: Env + g = contextGlobalEnv ctx + i :: Env + i = getEnv 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. -- | This function does NOT go into function-body scope environments and the like. -setFullyQualifiedSymbols :: TypeEnv -> Env -> Env -> XObj -> XObj -setFullyQualifiedSymbols - typeEnv - globalEnv - env - ( 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. - 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 - in XObj (Lst [defn, sym, args, setFullyQualifiedSymbols typeEnv globalEnv envWithArgs body]) i t -setFullyQualifiedSymbols - typeEnv - globalEnv - env - ( 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) - envWithArgs = foldl' (\e arg@(XObj (Sym (SymPath _ argSymName) _) _ _) -> extendEnv e argSymName arg) functionEnv argsArr - in XObj (Lst [fn, args, setFullyQualifiedSymbols typeEnv globalEnv envWithArgs body]) i t -setFullyQualifiedSymbols typeEnv globalEnv env (XObj (Lst [the@(XObj The _ _), typeXObj, value]) i t) = - let value' = setFullyQualifiedSymbols typeEnv globalEnv env value - in XObj (Lst [the, typeXObj, value']) i t -setFullyQualifiedSymbols typeEnv globalEnv env (XObj (Lst [def@(XObj Def _ _), sym, expr]) i t) = - let expr' = setFullyQualifiedSymbols typeEnv globalEnv env expr - in XObj (Lst [def, sym, expr']) i t -setFullyQualifiedSymbols typeEnv globalEnv env (XObj (Lst [letExpr@(XObj Let _ _), bind@(XObj (Arr bindings) bindi bindt), body]) i t) - | odd (length bindings) = XObj (Lst [letExpr, bind, body]) i t -- Leave it untouched for the compiler to find the error. - | not (all isSym (evenIndices bindings)) = XObj (Lst [letExpr, bind, body]) i t -- Leave it untouched for the compiler to find the error. +setFullyQualifiedSymbols :: TypeEnv -> Env -> Env -> XObj -> Either QualificationError Qualified +setFullyQualifiedSymbols t g e xobj = + case qualified of + Right qualifiedXObj -> Right $ Qualified $ qualifiedXObj + err -> fmap Qualified err + where + qualified :: Either QualificationError XObj + qualified = + fmap unQualified $ + case xobjObj xobj of + Lst ((XObj (Defn _) _ _) : _) -> + qualifyFunctionDefinition t g e xobj + Lst ((XObj (Fn _ _) _ _) : _) -> + qualifyLambda t g e xobj + Lst ((XObj The _ _) : _) -> + qualifyThe t g e xobj + Lst ((XObj Def _ _) : _) -> + qualifyDef t g e xobj + Lst ((XObj Let _ _) : _) -> + qualifyLet t g e xobj + Lst ((XObj (Match _) _ _) : _) -> + qualifyMatch t g e xobj + Lst ((XObj With _ _) : _) -> + qualifyWith t g e xobj + Lst _ -> + qualifyLst t g e xobj + Sym _ _ -> + qualifySym t g e xobj + Arr _ -> + qualifyArr t g e xobj + StaticArr _ -> + qualifyStaticArr t g e xobj + _ -> Right $ Qualified $ xobj + +-- | The type of functions that qualify XObjs (forms/s-expressions). +type Qualifier = TypeEnv -> Env -> Env -> XObj -> Either QualificationError Qualified + +-- Note to maintainers: liftM unQualified is used extensively throughout to +-- turn a Qualified XObj back into an XObj for further nesting. Recall that: +-- +-- foo <- liftM unQualified x === foo <- pure . unQualified =<< x + +-- | 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) = + -- 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 + qualifiedBody <- liftM unQualified (setFullyQualifiedSymbols typeEnv globalEnv envWithArgs body) + pure (Qualified (XObj (Lst [defn, sym, args, qualifiedBody]) i t)) +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 _ _ _ xobj = Left $ FailedToQualifySymbols xobj + +-- | Qualify the symbols in a The form's body. +qualifyThe :: Qualifier +qualifyThe typeEnv globalEnv env (XObj (Lst [the@(XObj The _ _), typeX, value]) i t) = + do qualifiedValue <- liftM unQualified (setFullyQualifiedSymbols typeEnv globalEnv env value) + pure (Qualified (XObj (Lst [the, typeX, qualifiedValue]) i t)) +qualifyThe _ _ _ xobj = Left $ FailedToQualifySymbols xobj + +-- | Qualify the symbols in a Def form's body. +qualifyDef :: Qualifier +qualifyDef typeEnv globalEnv env (XObj (Lst [def@(XObj Def _ _), sym, expr]) i t) = + do qualifiedExpr <- liftM unQualified (setFullyQualifiedSymbols typeEnv globalEnv env expr) + pure (Qualified (XObj (Lst [def, sym, qualifiedExpr]) i t)) +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) + | 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 = - let Just ii = i - lvl = envFunctionNestingLevel env - innerEnv = Env Map.empty (Just env) (Just ("let-env-" ++ show (infoIdentifier ii))) Set.empty InternalEnv lvl - (innerEnv', bindings') = - foldl' - ( \(e, bs) (s@(XObj (Sym (SymPath _ binderName) _) _ _), o) -> - let qualified = setFullyQualifiedSymbols typeEnv globalEnv e o - in (extendEnv e binderName s, bs ++ [s, qualified]) - ) - (innerEnv, []) - (pairwise bindings) - newBody = setFullyQualifiedSymbols typeEnv globalEnv innerEnv' body - in XObj (Lst [letExpr, XObj (Arr bindings') bindi bindt, newBody]) i t -setFullyQualifiedSymbols typeEnv globalEnv env (XObj (Lst (matchExpr@(XObj (Match _) _ _) : expr : casesXObjs)) i t) = - if even (length casesXObjs) - then - let newExpr = setFullyQualifiedSymbols typeEnv globalEnv env expr - Just ii = i - lvl = envFunctionNestingLevel env - innerEnv = Env Map.empty (Just env) (Just ("case-env-" ++ show (infoIdentifier ii))) Set.empty InternalEnv lvl - newCasesXObjs = - map - ( \(l, r) -> - case l of - XObj (Lst (_ : xs)) _ _ -> - let l' = setFullyQualifiedSymbols typeEnv globalEnv env l - innerEnv' = foldl' folder innerEnv xs - where - folder e v = case v of - XObj (Sym (SymPath _ binderName) _) _ _ -> - extendEnv e binderName v - -- Nested sumtypes - -- fold recursively -- is there a more efficient way? - XObj (Lst (_ : ys)) _ _ -> - foldl' folder innerEnv ys - x -> - error ("Can't match variable with " ++ show x) - r' = setFullyQualifiedSymbols typeEnv globalEnv innerEnv' r - in [l', r'] - XObj {} -> - let l' = setFullyQualifiedSymbols typeEnv globalEnv env l - r' = setFullyQualifiedSymbols typeEnv globalEnv env r - in [l', r'] - ) - (pairwise casesXObjs) - in XObj (Lst (matchExpr : newExpr : concat newCasesXObjs)) i t - else XObj (Lst (matchExpr : expr : casesXObjs)) i t -- Leave it untouched for the compiler to find the error. -setFullyQualifiedSymbols typeEnv globalEnv env (XObj (Lst [XObj With _ _, XObj (Sym path _) _ _, expression]) _ _) = + do let Just ii = i + lvl = envFunctionNestingLevel env + innerEnv = Env Map.empty (Just env) (Just ("let-env-" ++ show (infoIdentifier ii))) Set.empty InternalEnv lvl + (innerEnv', qualifiedBindings) <- foldM qualifyBinding (innerEnv, []) (pairwise bindings) + qualifiedBody <- liftM unQualified (setFullyQualifiedSymbols typeEnv globalEnv innerEnv' body) + 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) = + do qualified <- liftM unQualified (setFullyQualifiedSymbols typeEnv globalEnv e o) + (pure (extendEnv e binderName s, 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. + | otherwise = + do qualifiedExpr <- pure . unQualified =<< setFullyQualifiedSymbols typeEnv globalEnv env expr + qualifiedCases <- pure . map (map unQualified) =<< mapM qualifyCases (pairwise casesXObjs) + pure (Qualified (XObj (Lst (matchExpr : qualifiedExpr : concat qualifiedCases)) i t)) + where + Just ii = i + lvl = envFunctionNestingLevel env + innerEnv :: Env + innerEnv = Env Map.empty (Just env) (Just ("case-env-" ++ show (infoIdentifier ii))) Set.empty InternalEnv lvl + 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 + qualifiedRHS <- setFullyQualifiedSymbols typeEnv globalEnv innerEnv' 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) +qualifyMatch _ _ _ xobj = Left $ FailedToQualifySymbols xobj + +-- | Qualify symbols in a With form. +qualifyWith :: Qualifier +qualifyWith typeEnv globalEnv env (XObj (Lst [XObj With _ _, XObj (Sym path _) _ _, expression]) _ _) = let useThese = envUseModules env env' = env {envUseModules = Set.insert path useThese} in setFullyQualifiedSymbols typeEnv globalEnv env' expression -setFullyQualifiedSymbols typeEnv globalEnv env (XObj (Lst xobjs) i t) = +qualifyWith _ _ _ xobj = Left $ FailedToQualifySymbols xobj + +-- | Qualify symbols in a generic Lst form. +qualifyLst :: Qualifier +qualifyLst typeEnv globalEnv env (XObj (Lst xobjs) i t) = -- TODO: Perhaps this general case can be sufficient? No need with all the cases above..? - let xobjs' = map (setFullyQualifiedSymbols typeEnv globalEnv env) xobjs - in XObj (Lst xobjs') i t -setFullyQualifiedSymbols typeEnv globalEnv localEnv xobj@(XObj (Sym path _) i t) = - 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 + do qualifiedXObjs <- liftM (map unQualified) (mapM (setFullyQualifiedSymbols typeEnv globalEnv env) xobjs) + pure (Qualified (XObj (Lst qualifiedXObjs) 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 - -- Qualified: - _ -> - doesNotBelongToAnInterface False localEnv where createInterfaceSym name = XObj (InterfaceSym name) i t @@ -223,10 +377,18 @@ setFullyQualifiedSymbols typeEnv globalEnv localEnv xobj@(XObj (Sym path _) i t) ) res bs -setFullyQualifiedSymbols typeEnv globalEnv env (XObj (Arr array) i t) = - let array' = map (setFullyQualifiedSymbols typeEnv globalEnv env) array - in XObj (Arr array') i t -setFullyQualifiedSymbols typeEnv globalEnv env (XObj (StaticArr array) i t) = - let array' = map (setFullyQualifiedSymbols typeEnv globalEnv env) array - in XObj (StaticArr array') i t -setFullyQualifiedSymbols _ _ _ xobj = xobj +qualifySym _ _ _ xobj = Left $ FailedToQualifySymbols xobj + +-- | Qualify an Arr form. +qualifyArr :: Qualifier +qualifyArr typeEnv globalEnv env (XObj (Arr array) i t) = + do qualifiedArr <- liftM (map unQualified) (mapM (setFullyQualifiedSymbols typeEnv globalEnv env) array) + pure (Qualified (XObj (Arr qualifiedArr) i t)) +qualifyArr _ _ _ xobj = Left $ FailedToQualifySymbols xobj + +-- | Qualify a StaticArr form. +qualifyStaticArr :: Qualifier +qualifyStaticArr typeEnv globalEnv env (XObj (StaticArr array) i t) = + do qualifiedArr <- liftM (map unQualified) (mapM (setFullyQualifiedSymbols typeEnv globalEnv env) array) + pure (Qualified (XObj (StaticArr qualifiedArr) i t)) +qualifyStaticArr _ _ _ xobj = Left $ FailedToQualifySymbols xobj