mirror of
https://github.com/carp-lang/Carp.git
synced 2024-09-17 08:27:45 +03:00
Various submodule fixes (#1078)
* fix: don't set the inner env to globals in type mods
Previously, we set the inner environment of a type generated module to
the global env in cases where the overarching context didn't have an
inner env. This leads to problems where by the recognition of modules is
inconsistent, and one can't use the names of types as submodules in
certain circumstances.
This commit fixes that issue.
* refactor: refactor primitiveDefmodule
This refactor fixes a issues with meta information on submodules, for
instance, sigs on submodule functions used to result in a compiler error
about ambiguous identifiers. This fixes that.
Unfortunately, I don't have a precise idea about what exactly was wrong
with the original definition of this function. My suspicion is that the
recursion originally altered submodule paths in the wrong way, but I'm
not certain. In any case it's fixed.
* fix: ensure macros are expanded in the correct module
Previously, macro expansions folded over all forms after the top level
form, without performing any context updates on encountered
`defmodules`. This created an issue in which macro calls that produced
new bindings, "meta stubs", were *hoisted* out of submodules and into
the top-level module, creating duplicate definitions.
This commit fixes that issue by adding a special case for defmodule in
macroExpand.
* fix: ensure submodules and globals don't conflict
Previously, our module lookups during new module definition always
eventually fell back to the global environment, which caused submodules
that happen to share a name with a global module to be confused with the
global module. This change fixes that, so now one can define both
`Dynamic` (global) and `Foo.Dynamic` without issue.
* fix: remove old prefixes from vector tests
Commit 7b7cb5d1e
replaced /= with a generic function. However, the
vector tests still called the specific Vector variants of this function,
which were removed when the generic was introduced. After recent
changes, these calls are now (correctly) identified as erroneous. My
guess is that they only worked in the past because of problems with our
lookups.
* chore: format code
This commit is contained in:
parent
b45b52b568
commit
5f0ae6819e
@ -29,10 +29,10 @@ import Validate
|
||||
-- | This function creates a "Type Module" with the same name as the type being defined.
|
||||
-- A type module provides a namespace for all the functions that area automatically
|
||||
-- generated by a deftype.
|
||||
moduleForDeftype :: Env -> TypeEnv -> Env -> [String] -> String -> [Ty] -> [XObj] -> Maybe Info -> Maybe Env -> Either TypeError (String, XObj, [XObj])
|
||||
moduleForDeftype :: Maybe Env -> TypeEnv -> Env -> [String] -> String -> [Ty] -> [XObj] -> Maybe Info -> Maybe Env -> Either TypeError (String, XObj, [XObj])
|
||||
moduleForDeftype innerEnv typeEnv env pathStrings typeName typeVariables rest i existingEnv =
|
||||
let typeModuleName = typeName
|
||||
typeModuleEnv = fromMaybe (Env (Map.fromList []) (Just innerEnv) (Just typeModuleName) [] ExternalEnv 0) existingEnv
|
||||
typeModuleEnv = fromMaybe (Env (Map.fromList []) innerEnv (Just typeModuleName) [] ExternalEnv 0) existingEnv
|
||||
-- The variable 'insidePath' is the path used for all member functions inside the 'typeModule'.
|
||||
-- For example (module Vec2 [x Float]) creates bindings like Vec2.create, Vec2.x, etc.
|
||||
insidePath = pathStrings ++ [typeModuleName]
|
||||
|
91
src/Eval.hs
91
src/Eval.hs
@ -455,11 +455,14 @@ macroExpand ctx xobj =
|
||||
)
|
||||
XObj (Lst [XObj (Lst (XObj Macro _ _ : _)) _ _]) _ _ -> evalDynamic ctx xobj
|
||||
XObj (Lst (x@(XObj (Sym _ _) _ _) : args)) i t -> do
|
||||
(_, f) <- evalDynamic ctx x
|
||||
(next, f) <- evalDynamic ctx x
|
||||
case f of
|
||||
Right m@(XObj (Lst (XObj Macro _ _ : _)) _ _) -> do
|
||||
(newCtx', res) <- evalDynamic 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 prim) _ _), (XObj (Sym (SymPath _ "defmodule") _) _ _), _]) _ _) ->
|
||||
getPrimitive prim p next args
|
||||
_ -> do
|
||||
(newCtx, expanded) <- foldlM successiveExpand (ctx, Right []) args
|
||||
pure
|
||||
@ -763,44 +766,54 @@ annotateWithinContext qualifyDefn ctx xobj = do
|
||||
Right ok -> pure (ctx, Right ok)
|
||||
|
||||
primitiveDefmodule :: Primitive
|
||||
primitiveDefmodule xobj ctx@(Context env i typeEnv pathStrings proj lastInput execMode history) (XObj (Sym (SymPath [] moduleName) _) _ _ : innerExpressions) = do
|
||||
let defineIt :: MetaData -> IO (Context, Either EvalError XObj)
|
||||
defineIt meta = do
|
||||
let parentEnv = getEnv env pathStrings
|
||||
innerEnv = Env (Map.fromList []) (Just parentEnv) (Just moduleName) [] ExternalEnv 0
|
||||
newModule = XObj (Mod innerEnv) (xobjInfo xobj) (Just ModuleTy)
|
||||
globalEnvWithModuleAdded = envInsertAt env (SymPath pathStrings moduleName) (Binder meta newModule)
|
||||
ctx' = Context globalEnvWithModuleAdded (Just (innerEnv {envParent = i})) typeEnv (pathStrings ++ [moduleName]) proj lastInput execMode history
|
||||
(ctxAfterModuleDef, res) <- liftIO $ foldM step (ctx', dynamicNil) innerExpressions
|
||||
pure (popModulePath ctxAfterModuleDef {contextInternalEnv = i}, res)
|
||||
(newCtx, result) <-
|
||||
case lookupBinder (SymPath pathStrings moduleName) env of
|
||||
Just (Binder _ (XObj (Mod innerEnv) _ _)) -> do
|
||||
let ctx' = Context env (Just innerEnv {envParent = i}) typeEnv (pathStrings ++ [moduleName]) proj lastInput execMode history -- TODO: use { = } syntax instead
|
||||
(ctxAfterModuleAdditions, res) <- liftIO $ foldM step (ctx', dynamicNil) innerExpressions
|
||||
pure (popModulePath ctxAfterModuleAdditions {contextInternalEnv = i}, res) -- TODO: propagate errors...
|
||||
Just (Binder meta (XObj (Lst [XObj MetaStub _ _, _]) _ _)) ->
|
||||
defineIt meta
|
||||
Just (Binder _ _) ->
|
||||
pure (evalError ctx ("Can't redefine '" ++ moduleName ++ "' as module") (xobjInfo xobj))
|
||||
Nothing ->
|
||||
defineIt emptyMeta
|
||||
pure $ case result of
|
||||
Left err -> (newCtx, Left err)
|
||||
Right _ -> (newCtx, dynamicNil)
|
||||
where
|
||||
step (ctx', r) x =
|
||||
case r of
|
||||
Left _ -> pure (ctx', r)
|
||||
Right _ -> do
|
||||
(newCtx, res) <- macroExpand ctx' x
|
||||
case res of
|
||||
primitiveDefmodule xobj ctx@(Context env i _ pathStrings _ _ _ _) (XObj (Sym (SymPath [] moduleName) _) _ _ : innerExpressions) =
|
||||
do
|
||||
-- N.B. The `envParent` rewrite at the end of this line is important!
|
||||
-- lookups delve into parent envs by default, which is normally what we want, but in this case it leads to problems
|
||||
-- when submodules happen to share a name with an existing module or type at the global level.
|
||||
maybe (defineNewModule emptyMeta) updateExistingModule (lookupBinder (SymPath [] moduleName) ((getEnv env pathStrings) {envParent = Nothing}))
|
||||
>>= defineModuleBindings
|
||||
>>= \(newCtx, result) ->
|
||||
case result of
|
||||
Left err -> pure (newCtx, Left err)
|
||||
Right e -> do
|
||||
(newCtx', res') <- evalDynamic newCtx e
|
||||
case res' of
|
||||
Left err -> pure (newCtx', Left err)
|
||||
Right _ -> pure (newCtx', r)
|
||||
Right _ -> pure (popModulePath (newCtx {contextInternalEnv = (join (fmap envParent (contextInternalEnv newCtx)))}), dynamicNil)
|
||||
where
|
||||
updateExistingModule :: Binder -> IO (Context, Either EvalError XObj)
|
||||
updateExistingModule (Binder _ (XObj (Mod innerEnv) _ _)) =
|
||||
let ctx' =
|
||||
ctx
|
||||
{ contextInternalEnv = Just innerEnv {envParent = i},
|
||||
contextPath = ((contextPath ctx) ++ [moduleName])
|
||||
}
|
||||
in (pure (ctx', dynamicNil))
|
||||
updateExistingModule (Binder meta (XObj (Lst [XObj MetaStub _ _, _]) _ _)) =
|
||||
defineNewModule meta
|
||||
updateExistingModule _ =
|
||||
pure (evalError ctx ("Can't redefine '" ++ moduleName ++ "' as module") (xobjInfo xobj))
|
||||
|
||||
defineNewModule :: MetaData -> IO (Context, Either EvalError XObj)
|
||||
defineNewModule meta =
|
||||
pure (ctx', dynamicNil)
|
||||
where
|
||||
moduleEnv = Env (Map.fromList []) (Just (getEnv env pathStrings)) (Just moduleName) [] ExternalEnv 0
|
||||
newModule = XObj (Mod moduleEnv) (xobjInfo xobj) (Just ModuleTy)
|
||||
updatedGlobalEnv = envInsertAt env (SymPath pathStrings moduleName) (Binder meta newModule)
|
||||
-- The parent of the internal env needs to be set to i here for contextual `use` calls to work.
|
||||
-- In theory this shouldn't be necessary; but for now it is.
|
||||
ctx' = ctx {contextGlobalEnv = updatedGlobalEnv, contextInternalEnv = Just moduleEnv {envParent = i}, contextPath = ((contextPath ctx) ++ [moduleName])}
|
||||
|
||||
defineModuleBindings :: (Context, Either EvalError XObj) -> IO (Context, Either EvalError XObj)
|
||||
defineModuleBindings (context, Left e) = pure (context, Left e)
|
||||
defineModuleBindings (context, _) =
|
||||
foldM step (context, dynamicNil) innerExpressions
|
||||
|
||||
step :: (Context, Either EvalError XObj) -> XObj -> IO (Context, Either EvalError XObj)
|
||||
step (ctx', Left e) _ = pure (ctx', Left e)
|
||||
step (ctx', Right _) expressions =
|
||||
(macroExpand ctx' expressions)
|
||||
>>= \(ctx'', res) -> case res of
|
||||
Left _ -> pure (ctx'', res)
|
||||
Right r -> evalDynamic ctx'' r
|
||||
primitiveDefmodule _ ctx (x : _) =
|
||||
pure (evalError ctx ("`defmodule` expects a symbol, got '" ++ pretty x ++ "' instead.") (xobjInfo x))
|
||||
primitiveDefmodule _ ctx [] =
|
||||
@ -1206,7 +1219,7 @@ primitiveEval _ ctx [val] = do
|
||||
case arg of
|
||||
Left err -> pure (newCtx, Left err)
|
||||
Right evald -> do
|
||||
(newCtx', expanded) <- macroExpand ctx evald
|
||||
(newCtx', expanded) <- macroExpand newCtx evald
|
||||
case expanded of
|
||||
Left err -> pure (newCtx', Left err)
|
||||
Right ok -> do
|
||||
|
@ -612,7 +612,7 @@ primitiveDeftype xobj ctx (name : rest) =
|
||||
deftype' nameXObj typeName typeVariableXObjs = do
|
||||
let pathStrings = contextPath ctx
|
||||
env = contextGlobalEnv ctx
|
||||
innerEnv = fromMaybe env (contextInternalEnv ctx)
|
||||
innerEnv = (contextInternalEnv ctx)
|
||||
typeEnv = contextTypeEnv ctx
|
||||
typeVariables = mapM xobjToTy typeVariableXObjs
|
||||
(preExistingModule, preExistingMeta) =
|
||||
@ -629,6 +629,7 @@ primitiveDeftype xobj ctx (name : rest) =
|
||||
case creatorFunction innerEnv typeEnv env pathStrings tyName okTypeVariables rest i preExistingModule of
|
||||
Right (typeModuleName, typeModuleXObj, deps) ->
|
||||
let structTy = StructTy (ConcreteNameTy tyName) okTypeVariables
|
||||
updatedGlobal = envInsertAt env (SymPath pathStrings 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
|
||||
@ -642,7 +643,7 @@ primitiveDeftype xobj ctx (name : rest) =
|
||||
(Just TypeTy)
|
||||
ctx' =
|
||||
( ctx
|
||||
{ contextGlobalEnv = envInsertAt env (SymPath pathStrings typeModuleName) (Binder preExistingMeta typeModuleXObj),
|
||||
{ contextGlobalEnv = updatedGlobal,
|
||||
contextTypeEnv = TypeEnv (extendEnv (getTypeEnv typeEnv) tyName typeDefinition)
|
||||
}
|
||||
)
|
||||
|
@ -24,10 +24,10 @@ getCase cases caseNameToFind =
|
||||
found : _ -> Just found
|
||||
[] -> Nothing
|
||||
|
||||
moduleForSumtype :: Env -> TypeEnv -> Env -> [String] -> String -> [Ty] -> [XObj] -> Maybe Info -> Maybe Env -> Either TypeError (String, XObj, [XObj])
|
||||
moduleForSumtype :: Maybe Env -> TypeEnv -> Env -> [String] -> String -> [Ty] -> [XObj] -> Maybe Info -> Maybe Env -> Either TypeError (String, XObj, [XObj])
|
||||
moduleForSumtype innerEnv typeEnv env pathStrings typeName typeVariables rest i existingEnv =
|
||||
let typeModuleName = typeName
|
||||
typeModuleEnv = fromMaybe (Env (Map.fromList []) (Just innerEnv) (Just typeModuleName) [] ExternalEnv 0) existingEnv
|
||||
typeModuleEnv = fromMaybe (Env (Map.fromList []) innerEnv (Just typeModuleName) [] ExternalEnv 0) existingEnv
|
||||
insidePath = pathStrings ++ [typeModuleName]
|
||||
in do
|
||||
let structTy = StructTy (ConcreteNameTy typeName) typeVariables
|
||||
|
@ -14,7 +14,7 @@
|
||||
(assert-op test
|
||||
&(init 1.0 2.0) &(init 1.0 1.0)
|
||||
"/= operator works"
|
||||
Vector2./=)
|
||||
/=)
|
||||
(assert-equal test
|
||||
&(init 3.0 3.0)
|
||||
&(add &(init 2.0 1.0) &(init 1.0 2.0))
|
||||
|
@ -14,7 +14,7 @@
|
||||
(assert-op test
|
||||
&(init 1.0 2.0 3.0) &(init 1.0 1.0 3.0)
|
||||
"/= operator works"
|
||||
Vector3./=)
|
||||
/=)
|
||||
(assert-op test
|
||||
&(init 1.0 2.0 3.0) &(init 1.000001 2.000001 3.000001)
|
||||
"approx works"
|
||||
|
@ -16,7 +16,7 @@
|
||||
(assert-op test
|
||||
&(init 4 [1.0 2.0 3.0 4.0]) &(init 4 [1.0 1.0 3.0 4.0])
|
||||
"/= operator works"
|
||||
VectorN./=)
|
||||
/=)
|
||||
(assert-equal test
|
||||
&(init 3 [3.0 3.0 4.5])
|
||||
&(Maybe.unsafe-from
|
||||
|
Loading…
Reference in New Issue
Block a user