mirror of
https://github.com/carp-lang/Carp.git
synced 2024-09-11 05:25:28 +03:00
refactor: Context and Qualify (#1170)
* refactor: move Context updates into functions Previously, we had a lot of instances of updating Context records directly, replacing environments where needed. This commit replaces those hand-written record setting instances with functions, which should allow us to more gracefully abstract over any preprocessing we should have to do and help ensure we're updating contexts in the right way. * refactor: replace inline context manipulation in primitives Like the commit that altered Eval before it, this commit leverages Context functions to remove a bunch of inline record field setting code and direct env manipulation. * refactor: replace generic binder lookups with contextual ones * refactor: move true and false XObjs into Obj.hs Previously, trueXObj and falseXObj were defined in Commands.hs, but since they're just literal constructed XObj values, I feel Obj.hs is a more appropriate home for them and makes them more widely accessible to other modules without needing to import Commands. * refactor: model symbol qualification requirements at typelevel This commit refactors the Qualify module to express symbol qualification at type level. In the past, all functions operated on SymPaths. In some cases, the functions operated on paths that *were not yet qualified* and so the functions would perform qualification inline. Contrarily, other functions like define received XObjs (from another part of the codebase entirely!) that were already fully qualified, and so it would be a grave mistake to re-qualify them. In the general case, it's difficult or impossible to tell across modules whether or not a given SymPath is coming in qualified or unqualified, which can easily lead to mistakes of double-qualification, e.g. transforming `Foo.bar` into `Foo.Foo.bar`. Modelling qualification in the type system enables us to avoid the problem by distinguishing between unqualified and qualified paths. A function receiving an SymPath can safely qualify it, whereas a function receiving a QualifiedPath should not further qualify the path. This helps better express and ensure constraints across modules. In addition, this commit also refactors a few functions where there was opportunity to do so. * refactor: remove eval call from `doc` This can lead to problems where a doc call intended to be evaluated later (in a macro body) is evaluated *immediately* resulting in a binding being added to the wrong scope (see the function reverse in core). The reason this behavior crops up now is that a special case for evaluating module contexts was removed last commit--this special case caused problems of its own, and the real root of things stems from the unnecessary eval call. Generally, evaling a doc call provides no benefit other than making evaluation of the meta set immediate in the repl, which is easy enough for one to do on one's own by calling eval where needed. * refactor: use do notation to clarify case qualification * refactor: rename runQualified to unQualified @eriksvedang pointed out the `run` prefix typically denotes a monad. As `Qualified` is not monadic (no monad instance defined) we drop the `r` to ensure we don't mislead readers. * refactor: convert a few more binds to do notation Do notation is generally clearer in cases where we use mapM, etc. We can also leverage liftM frequently in the qualification functions to transform a Qualified xobj back into an xobj for further use. * refactor: temporarily restore special case in meta set Meta set disallows setting the meta of a prefixed, absolute path such as `Foo.bar`. It only allows relative, unqualified paths `bar` and uses the current context to determine the appropriate module. If we eventually throw and error from envInsertAt, we can remove this special case. I intend to do that later, but for now we'll keep the special case to make for a more pleasant user experience.
This commit is contained in:
parent
dacc13560b
commit
8263a0da64
@ -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]
|
||||
|
@ -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
|
||||
|
||||
|
219
src/Context.hs
219
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
|
||||
|
103
src/Eval.hs
103
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)
|
||||
|
@ -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
|
||||
|
@ -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]
|
||||
|
@ -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
|
||||
|
12
src/Obj.hs
12
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
|
||||
|
@ -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)
|
||||
|
438
src/Qualify.hs
438
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
|
||||
|
Loading…
Reference in New Issue
Block a user