carp-lang/Carp
1
1
Fork 0
mirror of https://github.com/carp-lang/Carp.git synced 2024-09-11 05:25:28 +03:00
Code Issues Projects Releases Wiki Activity

refactor: Context and Qualify (#1170)

Browse Source 
* 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:
Scott Olsen 2021-02-14 15:53:42 -05:00 committed by GitHub
parent dacc13560b
commit 8263a0da64
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
10 changed files with 671 additions and 363 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/Macros.carp
View File

@ -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]

8
src/Commands.hs
View File

@ -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
View File

@ -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
View File

@ -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)

7
src/Infer.hs
View File

@ -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

18
src/Lookup.hs
View File

@ -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]

5
src/Meta.hs
View File

@ -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
View File

@ -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

222
src/Primitives.hs
View File

@ -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
View File

@ -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