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

Various submodule fixes (#1078)

Browse Source 
* 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:
Scott Olsen 2020-12-18 15:45:28 -05:00 committed by GitHub
parent b45b52b568
commit 5f0ae6819e
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
7 changed files with 62 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/Deftype.hs
View File

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

@ -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)
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 _ -> pure (popModulePath (newCtx {contextInternalEnv = (join (fmap envParent (contextInternalEnv newCtx)))}), dynamicNil)
where
step (ctx', r) x =
case r of
Left _ -> pure (ctx', r)
Right _ -> do
(newCtx, res) <- macroExpand ctx' x
case res 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)
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

5
src/Primitives.hs
View File

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

4
src/Sumtypes.hs
View File

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

2
test/vector2.carp
View File

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

2
test/vector3.carp
View File

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

2
test/vectorn.carp
View File

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