Refactor: clean up Env module, store type environments in modules (#1207)

* refactor: major environment mgmt refactor

This big refactor primarily changes two things in terms of behavior:

1. Stores a SymPath on concretely named (non-generic) struct types;
   before we stored a string.
2. The SymPath mentioned in (1.) designates where the struct is stored
   in the current environment chain. Modules now carry a local type
   environment in addition to their local value environments. Any types
   defined in the module are added to this environment rather than the
   global type environment.

To resolve a type such as `Foo.Bar` we now do the following:

- Search the *global value environment* for the Foo module.
- Get the type environment stored in the Foo module.
- Search for Bar in the Foo module's type environment.

Additionally, this commit eliminates the Lookup module entirely and
refactors the Env module to handle all aspects of environment management
in hopefully a more reusable fashion.

I also took the opportunity to refactor primitiveDeftype in Primitives
and qualifySym in Qualify, both of which were hefty functions that I
found difficult to grok and needed refactoring anyway as a result of
lookup changes (lookups now return an Either instead of a Maybe).

Subsequent commits will clean up and clarify this work further.

This does include one minor regression. Namely, an implementation of
`hash` in core/Color that was maximally generic now needs type casting.

* refactor: clean up recent Env changes

This commit removes some redundant functions, unifies some logic, and
renames some routines across the Env module in efforts to make it
cleaner. Call sites have been updated accordingly.

* chore: format code with ormolu

* fix: update lookup tests

Changes references to renamed functions in the Env module.

* refactor: style + additional improvements from eriksvedang@

- Rename arrayTy -> arrayTyA in ArrayTemplates.hs to disambiguate.
- Add maybeId util function.
- Remove commented code.
- Refactor a few functions for readability.

* fix: fix type inference regression

Recent commits introduced one minor regression whereby an instance of
type inference in core/Color.carp no longer worked and required
explicit type annotation. The problem ultimately had to do with
qualification:

- Prior to the recent changes, type inference worked because the call in
  question was qualified to Color.Id.get-tag, fixing the type.
- Failing to copy over a local envs Use modules to function envs
  resulted in finding more than just Color.Id.get-tag for this instance.

We now copy use modules over to function envs generated during
qualification to ensure we resolve to Use'd definitions before more
general cases.

Similarly, I made a small change to primitiveUse to support contextual
use calls (e.g. the `(use Id)` in Color.carp, which really means `(use
Color.Id)`)

* chore: Update some clarificatory comments

* chore: fix inline comment

CarpHask.cabal

@@ -34,7 +34,6 @@ library
                        Info,
                        InitialTypes,
                        Interfaces,
-                       Lookup,
                        Managed,
                        Map,
                        Meta,

headerparse/Main.hs

@@ -209,7 +209,7 @@ cTypeToCarpType ("long", 0) = LongTy
 cTypeToCarpType ("double", 0) = DoubleTy
 cTypeToCarpType ("float", 0) = FloatTy
 cTypeToCarpType ("void", 0) = UnitTy
-cTypeToCarpType (s, 0) = (StructTy (ConcreteNameTy s) [])
+cTypeToCarpType (s, 0) = (StructTy (ConcreteNameTy (SymPath [] s)) [])
 cTypeToCarpType (x, stars) = (PointerTy (cTypeToCarpType (x, stars - 1)))
 
 identifierChar :: Parsec.Parsec String () Char

src/ArrayTemplates.hs

@@ -10,6 +10,12 @@ import ToTemplate
 import Types
 import TypesToC
 
+arrayTyA :: Ty
+arrayTyA = StructTy (ConcreteNameTy (SymPath [] "Array")) [(VarTy "a")]
+
+arrayRef :: Ty
+arrayRef = RefTy arrayTyA (VarTy "q")
+
 -- | "Endofunctor Map"
 templateEMap :: (String, Binder)
 templateEMap =
@@ -20,9 +26,8 @@ templateEMap =
     documentation
   where
     templateType =
-      FuncTy [RefTy endomorphism (VarTy "q"), arrayTy] arrayTy StaticLifetimeTy
+      FuncTy [RefTy endomorphism (VarTy "q"), arrayTyA] arrayTyA StaticLifetimeTy
     endomorphism = FuncTy [VarTy "a"] (VarTy "a") (VarTy "fq")
-    arrayTy = StructTy (ConcreteNameTy "Array") [VarTy "a"]
     documentation =
       "applies a function `f` to an array `a`. The type of the elements cannot change."
     creatorFunc :: TypeEnv -> Env -> Template
@@ -30,7 +35,7 @@ templateEMap =
       Template
         templateType
         (templateLiteral "Array $NAME(Lambda *f, Array a)")
-        ( \(FuncTy [_, StructTy (ConcreteNameTy "Array") [memberTy]] _ _) ->
+        ( \(FuncTy [_, StructTy (ConcreteNameTy (SymPath [] "Array")) [memberTy]] _ _) ->
             handleUnits memberTy
         )
         ( \(FuncTy [RefTy t@(FuncTy fArgTys fRetTy _) _, _] _ _) ->
@@ -64,9 +69,8 @@ templateEFilter :: (String, Binder)
 templateEFilter = defineTypeParameterizedTemplate templateCreator path t docs
   where
     fTy = FuncTy [RefTy (VarTy "a") (VarTy "q")] BoolTy (VarTy "fq")
-    aTy = StructTy (ConcreteNameTy "Array") [VarTy "a"]
     path = SymPath ["Array"] "endo-filter"
-    t = FuncTy [RefTy fTy (VarTy "w"), aTy] aTy StaticLifetimeTy
+    t = FuncTy [RefTy fTy (VarTy "w"), arrayTyA] arrayTyA StaticLifetimeTy
     docs = "filters array members using a function. This function takes ownership."
     elt = "&((($a*)a.data)[i])"
     declaration :: String -> (String -> String) -> [Token]
@@ -108,9 +112,8 @@ templatePushBack =
   defineTypeParameterizedTemplate creator path t docs
   where
     path = SymPath ["Array"] "push-back"
-    aTy = StructTy (ConcreteNameTy "Array") [VarTy "a"]
     valTy = VarTy "a"
-    t = FuncTy [aTy, valTy] aTy StaticLifetimeTy
+    t = FuncTy [arrayTyA, valTy] arrayTyA StaticLifetimeTy
     docs = "adds an element `value` to the end of an array `a`."
     declaration :: String -> [Token]
     declaration setter =
@@ -146,9 +149,8 @@ templatePushBackBang =
   defineTypeParameterizedTemplate creator path t docs
   where
     path = SymPath ["Array"] "push-back!"
-    aTy = RefTy (StructTy (ConcreteNameTy "Array") [VarTy "a"]) (VarTy "q")
     valTy = VarTy "a"
-    t = FuncTy [aTy, valTy] UnitTy StaticLifetimeTy
+    t = FuncTy [arrayRef, valTy] UnitTy StaticLifetimeTy
     docs = "adds an element `value` to the end of an array `a` in-place."
     declaration :: String -> [Token]
     declaration setter =
@@ -182,8 +184,7 @@ templatePopBack :: (String, Binder)
 templatePopBack = defineTypeParameterizedTemplate templateCreator path t docs
   where
     path = SymPath ["Array"] "pop-back"
-    aTy = StructTy (ConcreteNameTy "Array") [VarTy "a"]
+    t = FuncTy [arrayTyA] arrayTyA StaticLifetimeTy
-    t = FuncTy [aTy] aTy StaticLifetimeTy
     docs = "removes the last element of an array and returns the new array."
     templateCreator = TemplateCreator $
       \typeEnv env ->
@@ -214,8 +215,7 @@ templatePopBackBang =
   defineTypeParameterizedTemplate creator path t docs
   where
     path = SymPath ["Array"] "pop-back!"
-    aTy = RefTy (StructTy (ConcreteNameTy "Array") [VarTy "a"]) (VarTy "q")
+    t = FuncTy [arrayRef] (VarTy "a") StaticLifetimeTy
-    t = FuncTy [aTy] (VarTy "a") StaticLifetimeTy
     docs = "removes an element `value` from the end of an array `a` in-place and returns it."
     creator =
       TemplateCreator $
@@ -250,7 +250,7 @@ templateNth =
   let t = VarTy "t"
    in defineTemplate
         (SymPath ["Array"] "unsafe-nth")
-        (FuncTy [RefTy (StructTy (ConcreteNameTy "Array") [t]) (VarTy "q"), IntTy] (RefTy t (VarTy "q")) StaticLifetimeTy)
+        (FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [t]) (VarTy "q"), IntTy] (RefTy t (VarTy "q")) StaticLifetimeTy)
         "gets a reference to the `n`th element from an array `a`."
         (toTemplate "$t* $NAME (Array *aRef, int n)")
         ( toTemplate $
@@ -271,7 +271,7 @@ templateRaw :: (String, Binder)
 templateRaw =
   defineTemplate
     (SymPath ["Array"] "raw")
-    (FuncTy [StructTy (ConcreteNameTy "Array") [VarTy "t"]] (PointerTy (VarTy "t")) StaticLifetimeTy)
+    (FuncTy [StructTy (ConcreteNameTy (SymPath [] "Array")) [VarTy "t"]] (PointerTy (VarTy "t")) StaticLifetimeTy)
     "returns an array `a` as a raw pointer—useful for interacting with C."
     (toTemplate "$t* $NAME (Array a)")
     (toTemplate "$DECL { return a.data; }")
@@ -281,7 +281,8 @@ templateUnsafeRaw :: (String, Binder)
 templateUnsafeRaw =
   defineTemplate
     (SymPath ["Array"] "unsafe-raw")
-    (FuncTy [RefTy (VarTy "q") (StructTy (ConcreteNameTy "Array") [VarTy "t"])] (PointerTy (VarTy "t")) StaticLifetimeTy)
+    -- TODO: Fix me! Order of members of Ref is incorrect.
+    (FuncTy [RefTy (VarTy "q") (StructTy (ConcreteNameTy (SymPath [] "Array")) [VarTy "t"])] (PointerTy (VarTy "t")) StaticLifetimeTy)
     "returns an array `a` as a raw pointer—useful for interacting with C."
     (toTemplate "$t* $NAME (Array* a)")
     (toTemplate "$DECL { return a->data; }")
@@ -301,7 +302,7 @@ templateAset :: (String, Binder)
 templateAset = defineTypeParameterizedTemplate templateCreator path t docs
   where
     path = SymPath ["Array"] "aset"
-    t = FuncTy [StructTy (ConcreteNameTy "Array") [VarTy "t"], IntTy, VarTy "t"] (StructTy (ConcreteNameTy "Array") [VarTy "t"]) StaticLifetimeTy
+    t = FuncTy [StructTy (ConcreteNameTy (SymPath [] "Array")) [VarTy "t"], IntTy, VarTy "t"] (StructTy (ConcreteNameTy (SymPath [] "Array")) [VarTy "t"]) StaticLifetimeTy
     docs = "sets an array element at the index `n` to a new value."
     templateCreator = TemplateCreator $
       \typeEnv env ->
@@ -336,7 +337,7 @@ templateAsetBang :: (String, Binder)
 templateAsetBang = defineTypeParameterizedTemplate templateCreator path t docs
   where
     path = SymPath ["Array"] "aset!"
-    t = FuncTy [RefTy (StructTy (ConcreteNameTy "Array") [VarTy "t"]) (VarTy "q"), IntTy, VarTy "t"] UnitTy StaticLifetimeTy
+    t = FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [VarTy "t"]) (VarTy "q"), IntTy, VarTy "t"] UnitTy StaticLifetimeTy
     docs = "sets an array element at the index `n` to a new value in place."
     templateCreator = TemplateCreator $
       \typeEnv env ->
@@ -372,7 +373,7 @@ templateAsetUninitializedBang :: (String, Binder)
 templateAsetUninitializedBang = defineTypeParameterizedTemplate templateCreator path t docs
   where
     path = SymPath ["Array"] "aset-uninitialized!"
-    t = FuncTy [RefTy (StructTy (ConcreteNameTy "Array") [VarTy "t"]) (VarTy "q"), IntTy, VarTy "t"] UnitTy StaticLifetimeTy
+    t = FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [VarTy "t"]) (VarTy "q"), IntTy, VarTy "t"] UnitTy StaticLifetimeTy
     docs = "sets an uninitialized array member. The old member will not be deleted."
     templateCreator = TemplateCreator $
       \_ _ ->
@@ -402,7 +403,7 @@ templateLength :: (String, Binder)
 templateLength = defineTypeParameterizedTemplate templateCreator path t docs
   where
     path = SymPath ["Array"] "length"
-    t = FuncTy [RefTy (StructTy (ConcreteNameTy "Array") [VarTy "t"]) (VarTy "q")] IntTy StaticLifetimeTy
+    t = FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [VarTy "t"]) (VarTy "q")] IntTy StaticLifetimeTy
     docs = "gets the length of the array."
     templateCreator = TemplateCreator $
       \typeEnv env ->
@@ -418,7 +419,7 @@ templateAllocate :: (String, Binder)
 templateAllocate = defineTypeParameterizedTemplate templateCreator path t docs
   where
     path = SymPath ["Array"] "allocate"
-    t = FuncTy [IntTy] (StructTy (ConcreteNameTy "Array") [VarTy "t"]) StaticLifetimeTy
+    t = FuncTy [IntTy] (StructTy (ConcreteNameTy (SymPath [] "Array")) [VarTy "t"]) StaticLifetimeTy
     docs = "allocates an uninitialized array. You can initialize members using [`aset-uninitialized`](#aset-uninitialized)."
     templateCreator = TemplateCreator $
       \typeEnv env ->
@@ -448,7 +449,7 @@ templateDeleteArray :: (String, Binder)
 templateDeleteArray = defineTypeParameterizedTemplate templateCreator path t docs
   where
     path = SymPath ["Array"] "delete"
-    t = FuncTy [StructTy (ConcreteNameTy "Array") [VarTy "a"]] UnitTy StaticLifetimeTy
+    t = FuncTy [arrayTyA] UnitTy StaticLifetimeTy
     docs = "deletes an array. This function should usually not be called manually."
     templateCreator = TemplateCreator $
       \typeEnv env ->
@@ -460,7 +461,7 @@ templateDeleteArray = defineTypeParameterizedTemplate templateCreator path t doc
                 ++ deleteTy typeEnv env arrayType
                 ++ [TokC "}\n"]
           )
-          ( \(FuncTy [StructTy (ConcreteNameTy "Array") [insideType]] UnitTy _) ->
+          ( \(FuncTy [StructTy (ConcreteNameTy (SymPath [] "Array")) [insideType]] UnitTy _) ->
               depsForDeleteFunc typeEnv env insideType
           )
 
@@ -474,7 +475,7 @@ deleteTy typeEnv env (StructTy _ [innerType]) =
 deleteTy _ _ _ = []
 
 initTy :: Ty -> [String]
-initTy (StructTy (ConcreteNameTy "Array") [innerType@FuncTy {}]) =
+initTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [innerType@FuncTy {}]) =
   [ "    // initialize each Lambda struct ",
     "    for(int i = 0; i < a.len; i++) {",
     "    " ++ insideArrayInitLambda innerType "i",
@@ -510,7 +511,7 @@ templateCopyArray :: (String, Binder)
 templateCopyArray = defineTypeParameterizedTemplate templateCreator path t docs
   where
     path = SymPath ["Array"] "copy"
-    t = FuncTy [RefTy (StructTy (ConcreteNameTy "Array") [VarTy "a"]) (VarTy "q")] (StructTy (ConcreteNameTy "Array") [VarTy "a"]) StaticLifetimeTy
+    t = FuncTy [arrayRef] arrayTyA StaticLifetimeTy
     docs = "copies an array."
     templateCreator = TemplateCreator $
       \typeEnv env ->
@@ -528,7 +529,7 @@ templateCopyArray = defineTypeParameterizedTemplate templateCreator path t docs
                 ++ [TokC "}\n"]
           )
           ( \case
-              (FuncTy [RefTy arrayType@(StructTy (ConcreteNameTy "Array") [insideType]) _] _ _) ->
+              (FuncTy [RefTy arrayType@(StructTy (ConcreteNameTy (SymPath [] "Array")) [insideType]) _] _ _) ->
                 depsForCopyFunc typeEnv env insideType
                   ++ depsForDeleteFunc typeEnv env arrayType
               err ->
@@ -536,7 +537,7 @@ templateCopyArray = defineTypeParameterizedTemplate templateCreator path t docs
           )
 
 copyTy :: TypeEnv -> Env -> Ty -> [Token]
-copyTy typeEnv env (StructTy (ConcreteNameTy "Array") [innerType]) =
+copyTy typeEnv env (StructTy (ConcreteNameTy (SymPath [] "Array")) [innerType]) =
   if managed
     then
       [ TokC "    for(int i = 0; i < a->len; i++) {\n",
@@ -580,11 +581,11 @@ templateStrArray = defineTypeParameterizedTemplate templateCreator path t docs
                 ++ strTy typeEnv env arrayType
                 ++ [TokC "}\n"]
           )
-          ( \(FuncTy [RefTy (StructTy (ConcreteNameTy "Array") [insideType]) _] StringTy _) ->
+          ( \(FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [insideType]) _] StringTy _) ->
               depsForPrnFunc typeEnv env insideType
           )
     path = SymPath ["Array"] "str"
-    t = FuncTy [RefTy (StructTy (ConcreteNameTy "Array") [VarTy "a"]) (VarTy "q")] StringTy StaticLifetimeTy
+    t = FuncTy [arrayRef] StringTy StaticLifetimeTy
     docs = "converts an array to a string."
 
 -- | TODO: move this into the templateStrArray function?

src/AssignTypes.hs

@@ -49,7 +49,7 @@ assignTypes mappings root = visit root
       Nothing -> pure xobj
 
 isArrayTypeOK :: Ty -> Bool
-isArrayTypeOK (StructTy (ConcreteNameTy "Array") [RefTy _ _]) = False -- An array containing refs!
+isArrayTypeOK (StructTy (ConcreteNameTy (SymPath [] "Array")) [RefTy _ _]) = False -- An array containing refs!
 isArrayTypeOK _ = True
 
 -- | Change auto generated type names (i.e. 't0') to letters (i.e. 'a', 'b', 'c', etc...)

src/Commands.hs

@@ -12,8 +12,8 @@ import Data.List (elemIndex, foldl')
 import Data.List.Split (splitOn)
 import Data.Maybe (fromMaybe)
 import Emit
+import qualified Env as E
 import Info
-import Lookup
 import qualified Map
 import qualified Meta
 import Obj
@@ -283,8 +283,8 @@ commandBuild ctx [XObj (Bol shutUp) _ _] = do
       proj = contextProj ctx
       execMode = contextExecMode ctx
       src = do
+        typeDecl <- typeEnvToDeclarations typeEnv env
         decl <- envToDeclarations typeEnv env
-        typeDecl <- envToDeclarations typeEnv (getTypeEnv typeEnv)
         c <- envToC env Functions
         initGlobals <- fmap (wrapInInitFunction (projectCore proj)) (globalsToC env)
         pure
@@ -726,12 +726,12 @@ commandSaveDocsInternal ctx modulePath = do
   where
     getEnvironmentBinderForDocumentation :: Context -> Env -> SymPath -> Either String Binder
     getEnvironmentBinderForDocumentation _ env path =
-      case lookupBinder path env of
+      case E.searchValueBinder env path of
-        Just foundBinder@(Binder _ (XObj (Mod _) _ _)) ->
+        Right foundBinder@(Binder _ (XObj (Mod _ _) _ _)) ->
           Right foundBinder
-        Just (Binder _ x) ->
+        Right (Binder _ x) ->
           Left ("I can’t generate documentation for `" ++ pretty x ++ "` because it isn’t a module")
-        Nothing ->
+        Left _ ->
           Left ("I can’t find the module `" ++ show path ++ "`")
 
 -- | Command for emitting literal C code from Carp.
@@ -760,21 +760,21 @@ commandSexpression ctx xobj =
 
 commandSexpressionInternal :: Context -> XObj -> Bool -> IO (Context, Either EvalError XObj)
 commandSexpressionInternal ctx xobj bol =
-  let tyEnv = getTypeEnv $ contextTypeEnv ctx
+  let tyEnv = contextTypeEnv ctx
    in case xobj of
         (XObj (Lst [inter@(XObj (Interface ty _) _ _), path]) i t) ->
           pure (ctx, Right (XObj (Lst [toSymbols inter, path, reify ty]) i t))
         (XObj (Lst forms) i t) ->
           pure (ctx, Right (XObj (Lst (map toSymbols forms)) i t))
-        mdl@(XObj (Mod e) _ _) ->
+        mdl@(XObj (Mod e _) _ _) ->
           if bol
             then getMod
-            else case lookupBinder (SymPath [] (fromMaybe "" (envModuleName e))) tyEnv of
+            else case E.getTypeBinder tyEnv (fromMaybe "" (envModuleName e)) of
-              Just (Binder _ (XObj (Lst forms) i t)) ->
+              Right (Binder _ (XObj (Lst forms) i t)) ->
                 pure (ctx, Right (XObj (Lst (map toSymbols forms)) i t))
-              Just (Binder _ xobj') ->
+              Right (Binder _ xobj') ->
                 pure (ctx, Right (toSymbols xobj'))
-              Nothing ->
+              Left _ ->
                 getMod
           where
             getMod =
@@ -800,7 +800,7 @@ commandSexpressionInternal ctx xobj bol =
           pure $ evalError ctx ("can't get an s-expression for: " ++ pretty xobj ++ " is it a bound symbol or literal s-expression?") (Just dummyInfo)
 
 toSymbols :: XObj -> XObj
-toSymbols (XObj (Mod e) i t) =
+toSymbols (XObj (Mod e _) i t) =
   XObj
     ( Lst
         [ XObj (Sym (SymPath [] "defmodule") Symbol) i t,
@@ -866,7 +866,7 @@ commandType ctx (XObj x _ _) =
     typeOf Break = "dreak"
     typeOf If = "if"
     typeOf (Match _) = "matxch"
-    typeOf (Mod _) = "module"
+    typeOf (Mod _ _) = "module"
     typeOf (Deftype _) = "deftype"
     typeOf (DefSumtype _) = "def-sum-type"
     typeOf With = "with"

src/Concretize.hs

@@ -5,12 +5,12 @@ module Concretize where
 import AssignTypes
 import Constraints
 import Control.Monad.State
+import Data.Either (fromRight)
 import Data.List (foldl')
 import Data.Maybe (fromMaybe)
 import Debug.Trace
-import Env
+import Env (envIsExternal, findPoly, getTypeBinder, getValue, insert, insertX, lookupEverywhere, searchValue)
 import Info
-import Lookup
 import Managed
 import qualified Map
 import Obj
@@ -87,8 +87,10 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
         let functionEnv = Env Map.empty (Just env) Nothing Set.empty InternalEnv 0
             envWithArgs =
               foldl'
-                ( \e arg@(XObj (Sym (SymPath _ argSymName) _) _ _) ->
+                ( \e arg@(XObj (Sym path _) _ _) ->
-                    extendEnv e argSymName arg
+                -- n.b. this won't fail since we're inserting unqualified args into a fresh env
+                -- TODO: Still, it'd be nicer and more flexible to catch failures here.
+                    let Right v = insertX e path arg in v
                 )
                 functionEnv
                 argsArr
@@ -115,8 +117,8 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
             functionEnv = Env Map.empty (Just env) Nothing Set.empty InternalEnv (envFunctionNestingLevel env)
             envWithArgs =
               foldl'
-                ( \e arg@(XObj (Sym (SymPath _ argSymName) _) _ _) ->
+                ( \e arg@(XObj (Sym path _) _ _) ->
-                    extendEnv e argSymName arg
+                    let Right v = insertX e path arg in v
                 )
                 functionEnv
                 argsArr
@@ -131,8 +133,10 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
                 -- Its name will contain the name of the (normal, non-lambda) function it's contained within,
                 -- plus the identifier of the particular s-expression that defines the lambda.
                 SymPath spath name = rootDefinitionPath
-                lambdaPath = SymPath spath ("_Lambda_" ++ lambdaToCName name (envFunctionNestingLevel envWithArgs) ++ "_" ++ show (infoIdentifier ii))
+                lambdaPath = SymPath spath ("_Lambda_" ++ lambdaToCName name (envFunctionNestingLevel envWithArgs) ++ "_" ++ show (infoIdentifier ii) ++ "_env")
                 lambdaNameSymbol = XObj (Sym lambdaPath Symbol) (Just dummyInfo) Nothing
+                environmentTypeName = pathToC lambdaPath ++ "_ty"
+                tyPath = (SymPath [] environmentTypeName)
                 extendedArgs =
                   if null capturedVars
                     then args
@@ -143,7 +147,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
                             ( XObj
                                 (Sym (SymPath [] "_env") Symbol)
                                 (Just dummyInfo)
-                                (Just (PointerTy (StructTy (ConcreteNameTy environmentTypeName) []))) :
+                                (Just (PointerTy (StructTy (ConcreteNameTy tyPath) []))) :
                               argsArr
                             )
                         )
@@ -158,13 +162,12 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
                         [XObj (Sym path Symbol) Nothing Nothing, reify symTy]
                     )
                     capturedVars
-                environmentTypeName = pathToC lambdaPath ++ "_env"
+                environmentStructTy = StructTy (ConcreteNameTy tyPath) []
-                environmentStructTy = StructTy (ConcreteNameTy environmentTypeName) []
                 environmentStruct =
                   XObj
                     ( Lst
                         [ XObj (Deftype environmentStructTy) Nothing Nothing,
-                          XObj (Sym (SymPath [] environmentTypeName) Symbol) Nothing Nothing,
+                          XObj (Sym tyPath Symbol) Nothing Nothing,
                           XObj (Arr structMemberPairs) Nothing Nothing
                         ]
                     )
@@ -178,8 +181,9 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
                 copyFnTemplate = concreteCopyPtr typeEnv env pairs
                 (copyFn, copyDeps) = instantiateTemplate (SymPath [] (environmentTypeName ++ "_copy")) copyFnTy copyFnTemplate
                 -- The type env has to contain the lambdas environment struct for 'concretizeDefinition' to work:
-                extendedTypeEnv = TypeEnv (extendEnv (getTypeEnv typeEnv) environmentTypeName environmentStruct)
+                -- TODO: Fixup: Support modules in type envs.
-             in case concretizeDefinition allowAmbig extendedTypeEnv env visitedDefinitions lambdaCallback funcTy of
+                extendedTypeEnv = replaceLeft (FailedToAddLambdaStructToTyEnv tyPath environmentStruct) (insert typeEnv tyPath (toBinder environmentStruct))
+             in case (extendedTypeEnv >>= \ext -> concretizeDefinition allowAmbig ext env visitedDefinitions lambdaCallback funcTy) of
                   Left err -> pure (Left err)
                   Right (concreteLiftedLambda, deps) ->
                     do
@@ -260,14 +264,14 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
           pure [okVisitedLhs, okVisitedRhs]
     visitSymbol :: Bool -> Env -> XObj -> State [XObj] (Either TypeError XObj)
     visitSymbol allowAmbig env xobj@(XObj (Sym path lookupMode) i t) =
-      case lookupInEnv path env of
+      case searchValue env path of
-        Just (foundEnv, binder)
+        Right (foundEnv, binder)
           | envIsExternal foundEnv ->
             let theXObj = binderXObj binder
                 Just theType = xobjTy theXObj
                 typeOfVisited = fromMaybe (error ("Missing type on " ++ show xobj ++ " at " ++ prettyInfoFromXObj xobj ++ " when looking up path " ++ show path)) t
              in if --(trace $ "CHECKING " ++ getName xobj ++ " : " ++ show theType ++ " with visited type " ++ show typeOfVisited ++ " and visited definitions: " ++ show visitedDefinitions) $
-                isTypeGeneric theType && not (isTypeGeneric typeOfVisited)
+                (isTypeGeneric theType && not (isTypeGeneric typeOfVisited))
                   then case concretizeDefinition allowAmbig typeEnv env visitedDefinitions theXObj typeOfVisited of
                     Left err -> pure (Left err)
                     Right (concrete, deps) ->
@@ -277,7 +281,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
                         pure (Right (XObj (Sym (getPath concrete) lookupMode) i t))
                   else pure (Right xobj)
           | otherwise -> pure (Right xobj)
-        Nothing -> pure (Right xobj)
+        _ -> pure (Right xobj)
     visitSymbol _ _ _ = error "Not a symbol."
     visitMultiSym :: Bool -> Env -> XObj -> State [XObj] (Either TypeError XObj)
     visitMultiSym allowAmbig env xobj@(XObj (MultiSym originalSymbolName paths) i t) =
@@ -296,12 +300,13 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
                   Just i' = i
                in case solve [Constraint theType t' fake1 fake2 fake1 OrdMultiSym] of
                     Right mappings ->
-                      let replaced = replaceTyVars mappings t'
+                      let replaced = (replaceTyVars mappings t')
                           suffixed = suffixTyVars ("_x" ++ show (infoIdentifier i')) replaced -- Make sure it gets unique type variables. TODO: Is there a better way?
                           normalSymbol = XObj (Sym singlePath mode) i (Just suffixed)
                        in visitSymbol
                             allowAmbig
-                            env --(trace ("Disambiguated " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj ++ " to " ++ show singlePath ++ " : " ++ show suffixed ++ ", used to be " ++ show t' ++ ", theType = " ++ show theType ++ ", mappings = " ++ show mappings))
+                            env
+                            --(trace ("Disambiguated " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj ++ " to " ++ show singlePath ++ " : " ++ show suffixed ++ ", used to be " ++ show t' ++ ", theType = " ++ show theType ++ ", mappings = " ++ show mappings) normalSymbol) normalSymbol
                             normalSymbol
                     Left failure@(UnificationFailure _ _) ->
                       pure $
@@ -317,8 +322,8 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
     visitMultiSym _ _ _ = error "Not a multi symbol."
     visitInterfaceSym :: Bool -> Env -> XObj -> State [XObj] (Either TypeError XObj)
     visitInterfaceSym allowAmbig env xobj@(XObj (InterfaceSym name) i t) =
-      case lookupBinder (SymPath [] name) (getTypeEnv typeEnv) of
+      case getTypeBinder typeEnv name of
-        Just (Binder _ (XObj (Lst [XObj (Interface _ interfacePaths) _ _, _]) _ _)) ->
+        Right (Binder _ (XObj (Lst [XObj (Interface _ interfacePaths) _ _, _]) _ _)) ->
           let Just actualType = t
               tys = map (typeFromPath env) interfacePaths
               tysToPathsDict = zip tys interfacePaths
@@ -347,8 +352,8 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
                     allowAmbig
                     env -- trace ("Replacing symbol " ++ pretty xobj ++ " with type " ++ show theType ++ " to single path " ++ show singlePath)
                     normalSymbol
-        Just _ -> error "visitinterfacesym1"
+        Right _ -> error "visitinterfacesym1"
-        Nothing ->
+        Left _ ->
           error ("No interface named '" ++ name ++ "' found.")
     visitInterfaceSym _ _ _ = error "visitinterfacesym"
 
@@ -363,11 +368,11 @@ collectCapturedVars root = removeDuplicates (map decreaseCaptureLevel (visit roo
     removeDuplicates :: Ord a => [a] -> [a]
     removeDuplicates = Set.toList . Set.fromList
     decreaseCaptureLevel :: XObj -> XObj
-    decreaseCaptureLevel (XObj (Sym path lookup) _ ty) =
+    decreaseCaptureLevel (XObj (Sym path lookup') _ ty) =
       XObj
         ( Sym
             path
-            ( case lookup of
+            ( case lookup' of
                 Symbol -> Symbol
                 LookupLocal NoCapture -> Symbol
                 LookupLocal (Capture n) ->
@@ -436,43 +441,41 @@ concretizeType _ ft@FuncTy {} =
   if isTypeGeneric ft
     then Right []
     else Right [defineFunctionTypeAlias ft]
-concretizeType typeEnv arrayTy@(StructTy (ConcreteNameTy "Array") varTys) =
+concretizeType typeEnv arrayTy@(StructTy (ConcreteNameTy (SymPath [] "Array")) varTys) =
   if isTypeGeneric arrayTy
     then Right []
     else do
       deps <- mapM (concretizeType typeEnv) varTys
       Right (defineArrayTypeAlias arrayTy : concat deps)
 -- TODO: Remove ugly duplication of code here:
-concretizeType typeEnv arrayTy@(StructTy (ConcreteNameTy "StaticArray") varTys) =
+concretizeType typeEnv arrayTy@(StructTy (ConcreteNameTy (SymPath [] "StaticArray")) varTys) =
   if isTypeGeneric arrayTy
     then Right []
     else do
       deps <- mapM (concretizeType typeEnv) varTys
       Right (defineStaticArrayTypeAlias arrayTy : concat deps)
--- TODO: handle polymorphic constructors (a b)
+concretizeType typeEnv genericStructTy@(StructTy (ConcreteNameTy (SymPath _ name)) _) =
-concretizeType typeEnv genericStructTy@(StructTy (ConcreteNameTy name) _) =
+  -- TODO: This function only looks up direct children of the type environment.
-  case lookupInEnv (SymPath lookupPath structName) (getTypeEnv typeEnv) of
+  -- However, spath can point to types that belong to a module. Pass the global env here.
-    Just (_, Binder _ (XObj (Lst (XObj (Deftype originalStructTy) _ _ : _ : rest)) _ _)) ->
+  case (getTypeBinder typeEnv name) of
+    Right (Binder _ x) -> go x
+    _ -> Right []
+  where
+    go :: XObj -> Either TypeError [XObj]
+    go (XObj (Lst (XObj (Deftype originalStructTy) _ _ : _ : rest)) _ _) =
       if isTypeGeneric originalStructTy
         then instantiateGenericStructType typeEnv originalStructTy genericStructTy rest
         else Right []
-    Just (_, Binder _ (XObj (Lst (XObj (DefSumtype originalStructTy) _ _ : _ : rest)) _ _)) ->
+    go (XObj (Lst (XObj (DefSumtype originalStructTy) _ _ : _ : rest)) _ _) =
       if isTypeGeneric originalStructTy
         then instantiateGenericSumtype typeEnv originalStructTy genericStructTy rest
         else Right []
-    Just (_, Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) ->
+    go (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _) = Right []
-      Right []
+    go x = error ("Non-deftype found in type env: " ++ pretty x)
-    Just (_, Binder _ x) ->
+concretizeType t (RefTy rt _) =
-      error ("Non-deftype found in type env: " ++ show x)
+  concretizeType t rt
-    Nothing ->
+concretizeType t (PointerTy pt) =
-      Right []
+  concretizeType t pt
-  where
-    lookupPath = getPathFromStructName name
-    structName = getNameFromStructName name
-concretizeType env (RefTy rt _) =
-  concretizeType env rt
-concretizeType env (PointerTy pt) =
-  concretizeType env pt
 concretizeType _ _ =
   Right [] -- ignore all other types
 
@@ -592,11 +595,11 @@ replaceGenericTypeSymbolsOnCase _ unknownCase = unknownCase -- TODO: error out?
 -- | Get the type of a symbol at a given path.
 typeFromPath :: Env -> SymPath -> Ty
 typeFromPath env p =
-  case lookupInEnv p env of
+  case searchValue env p of
-    Just (e, Binder _ found)
+    Right (e, Binder _ found)
       | envIsExternal e -> forceTy found
       | otherwise -> error "Local bindings shouldn't be ambiguous."
-    Nothing -> error ("Couldn't find " ++ show p ++ " in env:\n" ++ prettyEnvironmentChain env)
+    _ -> error ("Couldn't find " ++ show p ++ " in env:\n" ++ prettyEnvironmentChain env)
 
 -- | Get the mode of a symbol at a given path.
 -- |
@@ -604,14 +607,14 @@ typeFromPath env p =
 -- | parts of doesNotBelongToAnInterface.
 modeFromPath :: Env -> SymPath -> SymbolMode
 modeFromPath env p =
-  case lookupInEnv p env of
+  case searchValue env p of
-    Just (_, Binder _ (XObj (Lst (XObj (External (Just overrideWithName)) _ _ : _)) _ _)) ->
+    Right (_, Binder _ (XObj (Lst (XObj (External (Just overrideWithName)) _ _ : _)) _ _)) ->
       LookupGlobalOverride overrideWithName
-    Just (_, Binder _ (XObj (Lst (XObj (ExternalType (Just overrideWithName)) _ _ : _)) _ _)) ->
+    Right (_, Binder _ (XObj (Lst (XObj (ExternalType (Just overrideWithName)) _ _ : _)) _ _)) ->
       LookupGlobalOverride overrideWithName
-    Just (_, Binder _ found@(XObj (Lst (XObj (External _) _ _ : _)) _ _)) ->
+    Right (_, Binder _ found@(XObj (Lst (XObj (External _) _ _ : _)) _ _)) ->
       LookupGlobal ExternalCode (definitionMode found)
-    Just (e, Binder _ found) ->
+    Right (e, Binder _ found) ->
       case envMode e of
         ExternalEnv ->
           LookupGlobal CarpLand (definitionMode found)
@@ -622,7 +625,7 @@ modeFromPath env p =
                 then Capture (envFunctionNestingLevel e - envFunctionNestingLevel env)
                 else NoCapture
             )
-    Nothing -> error ("Couldn't find " ++ show p ++ " in env:\n" ++ prettyEnvironmentChain env)
+    _ -> error ("Couldn't find " ++ show p ++ " in env:\n" ++ prettyEnvironmentChain env)
 
 -- | Given a definition (def, defn, template, external) and
 --   a concrete type (a type without any type variables)
@@ -677,26 +680,23 @@ concretizeDefinition allowAmbiguity typeEnv globalEnv visitedDefinitions definit
 -- For all other functions, the name must match exactly, and in all cases, the signature must match.
 allImplementations :: TypeEnv -> Env -> String -> Ty -> [(Env, Binder)]
 allImplementations typeEnv env functionName functionType =
-  filter (predicate . xobjTy . binderXObj . snd) foundBindings
+  (filter (predicate . xobjTy . binderXObj . snd) foundBindings)
   where
     predicate (Just t) =
       --trace ("areUnifiable? " ++ show functionType ++ " == " ++ show t ++ " " ++ show (areUnifiable functionType t)) $
       areUnifiable functionType t
     predicate Nothing = error "allfunctionswithnameandsignature"
-    foundBindings = case lookupBinder (SymPath [] functionName) (getTypeEnv typeEnv) of
+    foundBindings = case getTypeBinder typeEnv functionName of
       -- this function is an interface; lookup implementations
-      Just (Binder _ (XObj (Lst (XObj (Interface _ paths) _ _ : _)) _ _)) ->
+      Right (Binder _ (XObj (Lst (XObj (Interface _ paths) _ _ : _)) _ _)) ->
-        -- N.B./TODO: There are functions designed for this
+        case sequence $ map (\p -> searchValue env p) (paths ++ [(SymPath [] functionName)]) of
-        -- scenario--e.g. lookupImplementations, but they cause
+          Right found -> found
-        -- either entirely unacceptable behavior (not finding
+          Left _ ->
-        -- implementations, or hangs). We should be able to use
+            case findPoly env functionName functionType of
-        -- those here instead of looking up all interface paths
+              Right r -> [r]
-        -- directly, but for now we are stuck with this.
+              Left _ -> (lookupEverywhere env functionName)
-        case sequence $ map (\p -> lookupInEnv p env) (paths ++ [(SymPath [] functionName)]) of
-          Just found -> found
-          Nothing -> (multiLookupEverywhere functionName env)
       -- just a regular function; look for it
-      _ -> (multiLookupEverywhere functionName env)
+      _ -> fromRight [] ((fmap (: []) (Env.getValue env functionName)) <> pure (lookupEverywhere env functionName))
 
 -- | Find all the dependencies of a polymorphic function with a name and a desired concrete type.
 depsOfPolymorphicFunction :: TypeEnv -> Env -> [SymPath] -> String -> Ty -> [XObj]
@@ -908,7 +908,7 @@ manageMemory typeEnv globalEnv root =
             -- We know that we want to add a deleter for the static array here
             do
               let var = varOfXObj xobj
-                  Just (RefTy t@(StructTy (ConcreteNameTy "StaticArray") [_]) _) = xobjTy xobj
+                  Just (RefTy t@(StructTy (ConcreteNameTy (SymPath [] "StaticArray")) [_]) _) = xobjTy xobj
                   deleter = case nameOfPolymorphicFunction typeEnv globalEnv (FuncTy [t] UnitTy StaticLifetimeTy) "delete" of
                     Just pathOfDeleteFunc ->
                       ProperDeleter pathOfDeleteFunc (getDropFunc (xobjInfo xobj) t) var

src/Context.hs

@@ -1,5 +1,6 @@
 module Context
-  ( replaceGlobalEnv,
+  ( ContextError (..),
+    replaceGlobalEnv,
     replaceInternalEnv,
     replaceTypeEnv,
     replaceHistory,
@@ -9,27 +10,82 @@ module Context
     replaceInternalEnv',
     replaceTypeEnv',
     replaceHistory',
+    replacePath',
     insertInGlobalEnv,
     insertInGlobalEnv',
-    insertInTypeEnv,
+    insertTypeBinder,
-    insertInTypeEnv',
+    insertTypeBinder',
     insertInInternalEnv,
+    insertType,
+    replaceTypeBinder,
     innermostModuleEnv,
     bindLetDeclaration,
     lookupInterface,
     lookupBinderInGlobalEnv,
+    lookupBinderInInternalEnv,
     lookupBinderInTypeEnv,
     lookupBinderInContextEnv,
     contextualize,
   )
 where
 
-import Env
+import Data.Bifunctor
-import Lookup
+import Debug.Trace
+import qualified Env as E
 import Obj
 import Project
 import Qualify (QualifiedPath, qualifyPath, unqualify)
 import SymPath
+import Util (joinWithPeriod, replaceLeft)
+
+--------------------------------------------------------------------------------
+-- Errors
+
+data ContextError
+  = FailedToInsertInGlobalEnv SymPath Binder
+  | FailedToInsertInTypeEnv SymPath Binder
+  | FailedToInsertInInternalEnv SymPath Binder
+  | AttemptedToInsertQualifiedInternalBinder SymPath
+  | NoModuleEnvs String
+  | NotFoundGlobal SymPath
+  | NotFoundType SymPath
+  | NotFoundContext SymPath
+  | NotFoundInternal SymPath
+
+insertFailure :: SymPath -> Binder -> String
+insertFailure path binder =
+  "Failed to insert the binder: " ++ show binder
+    ++ " at path: "
+    ++ show path
+
+instance Show ContextError where
+  show (FailedToInsertInGlobalEnv path binder) =
+    insertFailure path binder
+      ++ "in the context's global environment."
+  show (FailedToInsertInTypeEnv path binder) =
+    insertFailure path binder
+      ++ "in the context's type environment."
+  show (FailedToInsertInInternalEnv path binder) =
+    insertFailure path binder
+      ++ "in the context's internal environment."
+  show (AttemptedToInsertQualifiedInternalBinder path) =
+    "Attempted to insert a qualified binder: " ++ show path
+      ++ " into a context's internal environment."
+  show (NoModuleEnvs pathstring) =
+    "Couldn't find any modules in the given context at path: "
+      ++ pathstring
+  show (NotFoundGlobal path) =
+    "Couldn't find the symbol: " ++ show path
+      ++ "in the context's global environment."
+  show (NotFoundType path) =
+    "Couldn't find the symbol: " ++ show path
+      ++ "in the context's type environment."
+  show (NotFoundContext path) =
+    "Couldn't find the symbol: " ++ show path
+      ++ "in the context's context environment."
+  show (NotFoundInternal path) =
+    "Couldn't find the symbol: " ++ show path
+      ++ "in the context's internal environment."
 
 --------------------------------------------------------------------------------
 -- Contextual Class
@@ -113,6 +169,10 @@ replaceTypeEnv' = flip replaceTypeEnv
 replaceHistory' :: [XObj] -> Context -> Context
 replaceHistory' = flip replaceHistory
 
+-- | replacePath with arguments flipped.
+replacePath' :: [String] -> Context -> Context
+replacePath' = flip replacePath
+
 --------------------------------------------------------------------------------
 -- Binding Insertion Functions
 
@@ -121,70 +181,110 @@ replaceHistory' = flip replaceHistory
 -- 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 :: Context -> QualifiedPath -> Binder -> Either ContextError Context
 insertInGlobalEnv ctx qpath binder =
-  let globalEnv = contextGlobalEnv ctx
+  replaceLeft
-   in ctx {contextGlobalEnv = envInsertAt globalEnv (unqualify qpath) binder}
+    (FailedToInsertInGlobalEnv (unqualify qpath) binder)
+    ( E.insert (contextGlobalEnv ctx) (unqualify qpath) binder
+        >>= \e -> pure $! (ctx {contextGlobalEnv = e})
+    )
 
 -- | 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
+insertTypeBinder :: Context -> QualifiedPath -> Binder -> Either ContextError Context
-insertInTypeEnv ctx qpath binder =
+insertTypeBinder ctx qpath binder =
-  let typeEnv = getTypeEnv (contextTypeEnv ctx)
+  let (SymPath path name) = unqualify qpath
-   in ctx {contextTypeEnv = TypeEnv (envInsertAt typeEnv (unqualify qpath) binder)}
+   in first
+        (\_ -> trace (show path) (FailedToInsertInTypeEnv (unqualify qpath) binder))
+        ( case path of
+            [] ->
+              (E.insert (contextTypeEnv ctx) (SymPath [] name) binder)
+                >>= pure . (replaceTypeEnv ctx)
+            -- TODO: We need to 'view' the global environment as a type
+            -- environment here to ensure types are added to a module's type
+            -- environment and not its value environment (the modality is
+            -- correct)
+            -- Find a more elegant API here.
+            _ ->
+              (E.insert (TypeEnv (contextGlobalEnv ctx)) (SymPath path name) binder)
+                >>= pure . (replaceGlobalEnv ctx) . getTypeEnv
+        )
+
+-- TODO: This function currently only handles top-level types. (fine for now,
+-- as it's only called to update interfaces) Update this to handle qualified
+-- types A.B
+replaceTypeBinder :: Context -> QualifiedPath -> Binder -> Either ContextError Context
+replaceTypeBinder ctx qpath binder =
+  let (SymPath _ name) = unqualify qpath
+      err = (FailedToInsertInTypeEnv (unqualify qpath) binder)
+      replacement = (E.replaceInPlace (contextTypeEnv ctx) name binder) >>= pure . (replaceTypeEnv ctx)
+   in replaceLeft err replacement <> insertTypeBinder ctx 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 :: Context -> SymPath -> Binder -> Either ContextError Context
 insertInInternalEnv ctx path@(SymPath [] _) binder =
-  ctx {contextInternalEnv = fmap insert (contextInternalEnv ctx)}
+  maybe
+    (Left (FailedToInsertInInternalEnv path binder))
+    insert'
+    (contextInternalEnv ctx)
   where
-    insert :: Env -> Env
+    insert' :: Env -> Either ContextError Context
-    insert e = envInsertAt e path binder
+    insert' e =
-insertInInternalEnv _ _ _ =
+      replaceLeft
-  error "attempted to insert a qualified symbol into an internal environment"
+        (FailedToInsertInInternalEnv path binder)
+        (E.insert e path binder >>= \e' -> pure (ctx {contextInternalEnv = pure e'}))
+insertInInternalEnv _ path _ = Left (AttemptedToInsertQualifiedInternalBinder path)
 
 -- | insertInGlobalEnv with arguments flipped.
-insertInGlobalEnv' :: QualifiedPath -> Binder -> Context -> Context
+insertInGlobalEnv' :: QualifiedPath -> Binder -> Context -> Either ContextError Context
 insertInGlobalEnv' path binder ctx = insertInGlobalEnv ctx path binder
 
--- | insertInTypeEnv with arguments flipped.
+-- | insertTypeBinder with arguments flipped.
-insertInTypeEnv' :: QualifiedPath -> Binder -> Context -> Context
+insertTypeBinder' :: QualifiedPath -> Binder -> Context -> Either ContextError Context
-insertInTypeEnv' path binder ctx = insertInTypeEnv ctx path binder
+insertTypeBinder' path binder ctx = insertTypeBinder ctx path binder
 
 -- | Inserts a let binding into the appropriate environment in a context.
-bindLetDeclaration :: Context -> String -> XObj -> Context
+bindLetDeclaration :: Context -> String -> XObj -> Either ContextError Context
 bindLetDeclaration ctx name xobj =
   let binder = Binder emptyMeta (toLocalDef name xobj)
    in insertInInternalEnv ctx (SymPath [] name) binder
 
+-- | Inserts a new type into a given context, adding a binding to the type
+-- environment and a module to to value environment.
+insertType :: Context -> QualifiedPath -> Binder -> Binder -> Either ContextError Context
+insertType ctx qpath typeBinder modBinder =
+  (insertInGlobalEnv ctx qpath modBinder)
+    >>= \c -> (insertTypeBinder c qpath typeBinder)
+
 --------------------------------------------------------------------------------
 -- 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.
+-- Returns an error if the Context path is empty.
-innermostModuleEnv :: Context -> Maybe Env
+innermostModuleEnv :: Context -> Either ContextError Env
 innermostModuleEnv ctx = go (contextPath ctx)
   where
-    go :: [String] -> Maybe Env
+    go :: [String] -> Either ContextError Env
-    go [] = Nothing
+    go [] = Left (NoModuleEnvs "")
-    go xs = Just $ getEnv (contextGlobalEnv ctx) xs
+    go xs = replaceLeft (NoModuleEnvs (joinWithPeriod xs)) (E.getInnerEnv (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 :: (Context -> SymPath -> Either ContextError Binder) -> Context -> SymPath -> Either ContextError Binder
 decontextualizedLookup f ctx path =
   f (replacePath ctx []) path
 
-lookupInterface :: Context -> SymPath -> Maybe Binder
+-- | Lookup an interface in the given context.
+lookupInterface :: Context -> SymPath -> Either ContextError Binder
 lookupInterface ctx path =
   decontextualizedLookup lookupBinderInTypeEnv ctx path
 
@@ -193,30 +293,46 @@ lookupInterface ctx path =
 -- 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 :: Contextual a => Context -> a -> Either ContextError Binder
 lookupBinderInTypeEnv ctx path =
-  let typeEnv = getTypeEnv (contextTypeEnv ctx)
+  let typeEnv = contextTypeEnv ctx
-      fullPath = contextualize path ctx
+      global = contextGlobalEnv ctx
-   in lookupBinder fullPath typeEnv
+      fullPath@(SymPath qualification name) = contextualize path ctx
+      theType =
+        ( case qualification of
+            [] -> E.getTypeBinder typeEnv name
+            _ -> E.searchTypeBinder global fullPath
+        )
+   in replaceLeft (NotFoundType fullPath) theType
 
 -- | 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 :: Contextual a => Context -> a -> Either ContextError Binder
 lookupBinderInGlobalEnv ctx path =
   let global = contextGlobalEnv ctx
       fullPath = contextualize path ctx
-   in lookupBinder fullPath global
+   in replaceLeft (NotFoundGlobal fullPath) (E.searchValueBinder global fullPath)
+
+-- | Lookup a binder in a context's internal environment.
+lookupBinderInInternalEnv :: Contextual a => Context -> a -> Either ContextError Binder
+lookupBinderInInternalEnv ctx path =
+  let internal = contextInternalEnv ctx
+      fullPath = contextualize path ctx
+   in maybe
+        (Left (NotFoundInternal fullPath))
+        (\e -> replaceLeft (NotFoundInternal fullPath) (E.searchValueBinder e fullPath))
+        internal
 
 -- | 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 :: Context -> SymPath -> Either ContextError Binder
 lookupBinderInContextEnv ctx path =
-  let ctxEnv = contextEnv ctx
+  let ctxEnv = (E.contextEnv ctx)
       fullPath = contextualize path ctx
-   in lookupBinder fullPath ctxEnv
+   in replaceLeft (NotFoundContext fullPath) (E.searchValueBinder ctxEnv fullPath)

src/Deftype.hs

@@ -2,19 +2,19 @@
 
 module Deftype
   ( moduleForDeftype,
+    moduleForDeftypeInContext,
     bindingsForRegisteredType,
     memberArg,
   )
 where
 
 import Concretize
+import Context
 import Data.Maybe
-import Env
+import Env (addListOfBindings, new)
 import Info
 import Managed
-import qualified Map
 import Obj
-import qualified Set
 import StructUtils
 import Template
 import ToTemplate
@@ -27,19 +27,41 @@ import Validate
 
 {-# ANN module "HLint: ignore Reduce duplication" #-}
 
+moduleForDeftypeInContext :: Context -> String -> [Ty] -> [XObj] -> Maybe Info -> Either TypeError (String, XObj, [XObj])
+moduleForDeftypeInContext ctx name vars members info =
+  let global = contextGlobalEnv ctx
+      types = contextTypeEnv ctx
+      path = contextPath ctx
+      inner = either (const Nothing) Just (innermostModuleEnv ctx)
+      previous =
+        either
+          (const Nothing)
+          Just
+          ( (lookupBinderInInternalEnv ctx (SymPath path name))
+              <> (lookupBinderInGlobalEnv ctx (SymPath path name))
+                >>= \b ->
+                  replaceLeft
+                    (NotFoundGlobal (SymPath path name))
+                    ( case binderXObj b of
+                        XObj (Mod ev et) _ _ -> Right (ev, et)
+                        _ -> Left "Non module"
+                    )
+          )
+   in moduleForDeftype inner types global path name vars members info previous
+
 -- | 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 :: Maybe 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, TypeEnv) -> Either TypeError (String, XObj, [XObj])
 moduleForDeftype innerEnv typeEnv env pathStrings typeName typeVariables rest i existingEnv =
-  let typeModuleName = typeName
+  let moduleValueEnv = fromMaybe (new innerEnv (Just typeName)) (fmap fst existingEnv)
-      typeModuleEnv = fromMaybe (Env (Map.fromList []) innerEnv (Just typeModuleName) Set.empty ExternalEnv 0) existingEnv
+      moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd 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]
+      insidePath = pathStrings ++ [typeName]
    in do
         validateMemberCases typeEnv typeVariables rest
-        let structTy = StructTy (ConcreteNameTy (createStructName pathStrings typeName)) typeVariables
+        let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables
         (okMembers, membersDeps) <- templatesForMembers typeEnv env insidePath structTy rest
         okInit <- binderForInit insidePath structTy rest
         (okStr, strDeps) <- binderForStrOrPrn typeEnv env insidePath structTy rest "str"
@@ -47,29 +69,29 @@ moduleForDeftype innerEnv typeEnv env pathStrings typeName typeVariables rest i
         (okDelete, deleteDeps) <- binderForDelete typeEnv env insidePath structTy rest
         (okCopy, copyDeps) <- binderForCopy typeEnv env insidePath structTy rest
         let funcs = okInit : okStr : okPrn : okDelete : okCopy : okMembers
-            moduleEnvWithBindings = addListOfBindings typeModuleEnv funcs
+            moduleEnvWithBindings = addListOfBindings moduleValueEnv funcs
-            typeModuleXObj = XObj (Mod moduleEnvWithBindings) i (Just ModuleTy)
+            typeModuleXObj = XObj (Mod moduleEnvWithBindings moduleTypeEnv) i (Just ModuleTy)
             deps = deleteDeps ++ membersDeps ++ copyDeps ++ strDeps
-        pure (typeModuleName, typeModuleXObj, deps)
+        pure (typeName, typeModuleXObj, deps)
 
 -- | Will generate getters/setters/updaters when registering EXTERNAL types.
 -- | i.e. (register-type VRUnicornData [hp Int, magic Float])
 -- | TODO: Remove duplication shared by moduleForDeftype-function.
-bindingsForRegisteredType :: TypeEnv -> Env -> [String] -> String -> [XObj] -> Maybe Info -> Maybe Env -> Either TypeError (String, XObj, [XObj])
+bindingsForRegisteredType :: TypeEnv -> Env -> [String] -> String -> [XObj] -> Maybe Info -> Maybe (Env, TypeEnv) -> Either TypeError (String, XObj, [XObj])
 bindingsForRegisteredType typeEnv env pathStrings typeName rest i existingEnv =
-  let typeModuleName = typeName
+  let moduleValueEnv = fromMaybe (new (Just env) (Just typeName)) (fmap fst existingEnv)
-      typeModuleEnv = fromMaybe (Env (Map.fromList []) (Just env) (Just typeModuleName) Set.empty ExternalEnv 0) existingEnv
+      moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv)
-      insidePath = pathStrings ++ [typeModuleName]
+      insidePath = pathStrings ++ [typeName]
    in do
         validateMemberCases typeEnv [] rest
-        let structTy = StructTy (ConcreteNameTy typeName) []
+        let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) []
         (binders, deps) <- templatesForMembers typeEnv env insidePath structTy rest
         okInit <- binderForInit insidePath structTy rest
         (okStr, strDeps) <- binderForStrOrPrn typeEnv env insidePath structTy rest "str"
         (okPrn, _) <- binderForStrOrPrn typeEnv env insidePath structTy rest "prn"
-        let moduleEnvWithBindings = addListOfBindings typeModuleEnv (okInit : okStr : okPrn : binders)
+        let moduleEnvWithBindings = addListOfBindings moduleValueEnv (okInit : okStr : okPrn : binders)
-            typeModuleXObj = XObj (Mod moduleEnvWithBindings) i (Just ModuleTy)
+            typeModuleXObj = XObj (Mod moduleEnvWithBindings moduleTypeEnv) i (Just ModuleTy)
-        pure (typeModuleName, typeModuleXObj, deps ++ strDeps)
+        pure (typeName, typeModuleXObj, deps ++ strDeps)
 
 -- | Generate all the templates for ALL the member variables in a deftype declaration.
 templatesForMembers :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> Either TypeError ([(String, Binder)], [XObj])
@@ -80,7 +102,7 @@ templatesForMembers _ _ _ _ _ = error "Shouldn't reach this case (invalid type d
 
 -- | Generate the templates for a single member in a deftype declaration.
 templatesForSingleMember :: TypeEnv -> Env -> [String] -> Ty -> (XObj, XObj) -> [((String, Binder), [XObj])]
-templatesForSingleMember typeEnv env insidePath p@(StructTy (ConcreteNameTy typeName) _) (nameXObj, typeXObj) =
+templatesForSingleMember typeEnv env insidePath p@(StructTy (ConcreteNameTy _) _) (nameXObj, typeXObj) =
   case t of
     -- Unit member types are special since we do not represent them in emitted c.
     -- Instead, members of type Unit are executed for their side effects and silently omitted
@@ -101,18 +123,18 @@ templatesForSingleMember typeEnv env insidePath p@(StructTy (ConcreteNameTy type
     Just t = xobjToTy typeXObj
     memberName = getName nameXObj
     binders getterSig setterSig mutatorSig updaterSig =
-      [ instanceBinderWithDeps (SymPath insidePath memberName) getterSig (templateGetter (mangle memberName) t) ("gets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "`."),
+      [ instanceBinderWithDeps (SymPath insidePath memberName) getterSig (templateGetter (mangle memberName) t) ("gets the `" ++ memberName ++ "` property of a `" ++ show p ++ "`."),
         if isTypeGeneric t
           then (templateGenericSetter insidePath p t memberName, [])
-          else instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName)) setterSig (templateSetter typeEnv env (mangle memberName) t) ("sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "`."),
+          else instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName)) setterSig (templateSetter typeEnv env (mangle memberName) t) ("sets the `" ++ memberName ++ "` property of a `" ++ show p ++ "`."),
         if isTypeGeneric t
           then (templateGenericMutatingSetter insidePath p t memberName, [])
-          else instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName ++ "!")) mutatorSig (templateMutatingSetter typeEnv env (mangle memberName) t) ("sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "` in place."),
+          else instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName ++ "!")) mutatorSig (templateMutatingSetter typeEnv env (mangle memberName) t) ("sets the `" ++ memberName ++ "` property of a `" ++ show p ++ "` in place."),
         instanceBinderWithDeps
           (SymPath insidePath ("update-" ++ memberName))
           updaterSig
           (templateUpdater (mangle memberName) t)
-          ("updates the `" ++ memberName ++ "` property of a `" ++ typeName ++ "` using a function `f`.")
+          ("updates the `" ++ memberName ++ "` property of a `" ++ show p ++ "` using a function `f`.")
       ]
 templatesForSingleMember _ _ _ _ _ = error "templatesforsinglemember"
 
@@ -176,12 +198,12 @@ templateSetter typeEnv env memberName memberTy =
 
 -- | The template for setters of a generic deftype.
 templateGenericSetter :: [String] -> Ty -> Ty -> String -> (String, Binder)
-templateGenericSetter pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membTy memberName =
+templateGenericSetter pathStrings originalStructTy@(StructTy (ConcreteNameTy _) _) membTy memberName =
   defineTypeParameterizedTemplate templateCreator path (FuncTy [originalStructTy, membTy] originalStructTy StaticLifetimeTy) docs
   where
     path = SymPath pathStrings ("set-" ++ memberName)
     t = FuncTy [VarTy "p", VarTy "t"] (VarTy "p") StaticLifetimeTy
-    docs = "sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "`."
+    docs = "sets the `" ++ memberName ++ "` property of a `" ++ show originalStructTy ++ "`."
     templateCreator = TemplateCreator $
       \typeEnv env ->
         Template
@@ -242,12 +264,12 @@ templateMutatingSetter typeEnv env memberName memberTy =
 
 -- | The template for mutating setters of a generic deftype.
 templateGenericMutatingSetter :: [String] -> Ty -> Ty -> String -> (String, Binder)
-templateGenericMutatingSetter pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membTy memberName =
+templateGenericMutatingSetter pathStrings originalStructTy@(StructTy (ConcreteNameTy _) _) membTy memberName =
   defineTypeParameterizedTemplate templateCreator path (FuncTy [RefTy originalStructTy (VarTy "q"), membTy] UnitTy StaticLifetimeTy) docs
   where
     path = SymPath pathStrings ("set-" ++ memberName ++ "!")
     t = FuncTy [RefTy (VarTy "p") (VarTy "q"), VarTy "t"] UnitTy StaticLifetimeTy
-    docs = "sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "` in place."
+    docs = "sets the `" ++ memberName ++ "` property of a `" ++ show originalStructTy ++ "` in place."
     templateCreator = TemplateCreator $
       \typeEnv env ->
         Template
@@ -313,7 +335,7 @@ templateUpdater member _ =
 
 -- | Helper function to create the binder for the 'init' template.
 binderForInit :: [String] -> Ty -> [XObj] -> Either TypeError (String, Binder)
-binderForInit insidePath structTy@(StructTy (ConcreteNameTy typeName) _) [XObj (Arr membersXObjs) _ _] =
+binderForInit insidePath structTy@(StructTy (ConcreteNameTy _) _) [XObj (Arr membersXObjs) _ _] =
   if isTypeGeneric structTy
     then Right (genericInit StackAlloc insidePath structTy membersXObjs)
     else
@@ -322,7 +344,7 @@ binderForInit insidePath structTy@(StructTy (ConcreteNameTy typeName) _) [XObj (
           (SymPath insidePath "init")
           (FuncTy (initArgListTypes membersXObjs) structTy StaticLifetimeTy)
           (concreteInit StackAlloc structTy membersXObjs)
-          ("creates a `" ++ typeName ++ "`.")
+          ("creates a `" ++ show structTy ++ "`.")
 binderForInit _ _ _ = error "binderforinit"
 
 -- | Generate a list of types from a deftype declaration.
@@ -332,7 +354,7 @@ initArgListTypes xobjs =
 
 -- | The template for the 'init' and 'new' functions for a concrete deftype.
 concreteInit :: AllocationMode -> Ty -> [XObj] -> Template
-concreteInit allocationMode originalStructTy@(StructTy (ConcreteNameTy typeName) _) membersXObjs =
+concreteInit allocationMode originalStructTy@(StructTy (ConcreteNameTy _) _) membersXObjs =
   Template
     (FuncTy (map snd (memberXObjsToPairs membersXObjs)) (VarTy "p") StaticLifetimeTy)
     ( \(FuncTy _ concreteStructTy _) ->
@@ -344,7 +366,7 @@ concreteInit allocationMode originalStructTy@(StructTy (ConcreteNameTy typeName)
     ( \(FuncTy _ concreteStructTy _) ->
         let mappings = unifySignatures originalStructTy concreteStructTy
             correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
-         in tokensForInit allocationMode typeName correctedMembers
+         in tokensForInit allocationMode (show originalStructTy) correctedMembers
     )
     (\FuncTy {} -> [])
   where
@@ -353,12 +375,12 @@ concreteInit _ _ _ = error "concreteinit"
 
 -- | The template for the 'init' and 'new' functions for a generic deftype.
 genericInit :: AllocationMode -> [String] -> Ty -> [XObj] -> (String, Binder)
-genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membersXObjs =
+genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameTy _) _) membersXObjs =
   defineTypeParameterizedTemplate templateCreator path t docs
   where
     path = SymPath pathStrings "init"
     t = FuncTy (map snd (memberXObjsToPairs membersXObjs)) originalStructTy StaticLifetimeTy
-    docs = "creates a `" ++ typeName ++ "`."
+    docs = "creates a `" ++ show originalStructTy ++ "`."
     templateCreator = TemplateCreator $
       \typeEnv _ ->
         Template
@@ -372,7 +394,7 @@ genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameT
           ( \(FuncTy _ concreteStructTy _) ->
               let mappings = unifySignatures originalStructTy concreteStructTy
                   correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
-               in tokensForInit allocationMode typeName correctedMembers
+               in tokensForInit allocationMode (show originalStructTy) correctedMembers
           )
           ( \(FuncTy _ concreteStructTy _) ->
               case concretizeType typeEnv concreteStructTy of
@@ -424,7 +446,7 @@ templatizeTy t = t
 
 -- | Helper function to create the binder for the 'str' template.
 binderForStrOrPrn :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> String -> Either TypeError ((String, Binder), [XObj])
-binderForStrOrPrn typeEnv env insidePath structTy@(StructTy (ConcreteNameTy typeName) _) [XObj (Arr membersXObjs) _ _] strOrPrn =
+binderForStrOrPrn typeEnv env insidePath structTy@(StructTy (ConcreteNameTy _) _) [XObj (Arr membersXObjs) _ _] strOrPrn =
   if isTypeGeneric structTy
     then Right (genericStr insidePath structTy membersXObjs strOrPrn, [])
     else
@@ -433,18 +455,18 @@ binderForStrOrPrn typeEnv env insidePath structTy@(StructTy (ConcreteNameTy type
             (SymPath insidePath strOrPrn)
             (FuncTy [RefTy structTy (VarTy "q")] StringTy StaticLifetimeTy)
             (concreteStr typeEnv env structTy (memberXObjsToPairs membersXObjs) strOrPrn)
-            ("converts a `" ++ typeName ++ "` to a string.")
+            ("converts a `" ++ show structTy ++ "` to a string.")
         )
 binderForStrOrPrn _ _ _ _ _ _ = error "binderforstrorprn"
 
 -- | The template for the 'str' function for a concrete deftype.
 concreteStr :: TypeEnv -> Env -> Ty -> [(String, Ty)] -> String -> Template
-concreteStr typeEnv env concreteStructTy@(StructTy (ConcreteNameTy typeName) _) memberPairs _ =
+concreteStr typeEnv env concreteStructTy@(StructTy (ConcreteNameTy name) _) memberPairs _ =
   Template
     (FuncTy [RefTy concreteStructTy (VarTy "q")] StringTy StaticLifetimeTy)
     (\(FuncTy [RefTy structTy _] StringTy _) -> toTemplate $ "String $NAME(" ++ tyToCLambdaFix structTy ++ " *p)")
     ( \(FuncTy [RefTy (StructTy _ _) _] StringTy _) ->
-        tokensForStr typeEnv env typeName memberPairs concreteStructTy
+        tokensForStr typeEnv env (show name) memberPairs concreteStructTy
     )
     ( \(FuncTy [RefTy (StructTy _ _) (VarTy "q")] StringTy _) ->
         concatMap
@@ -455,12 +477,12 @@ concreteStr _ _ _ _ _ = error "concretestr"
 
 -- | The template for the 'str' function for a generic deftype.
 genericStr :: [String] -> Ty -> [XObj] -> String -> (String, Binder)
-genericStr pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membersXObjs strOrPrn =
+genericStr pathStrings originalStructTy@(StructTy (ConcreteNameTy name) _) membersXObjs strOrPrn =
   defineTypeParameterizedTemplate templateCreator path t docs
   where
     path = SymPath pathStrings strOrPrn
     t = FuncTy [RefTy originalStructTy (VarTy "q")] StringTy StaticLifetimeTy
-    docs = "converts a `" ++ typeName ++ "` to a string."
+    docs = "converts a `" ++ show originalStructTy ++ "` to a string."
     templateCreator = TemplateCreator $
       \typeEnv env ->
         Template
@@ -472,7 +494,7 @@ genericStr pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) m
               let mappings = unifySignatures originalStructTy concreteStructTy
                   correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
                   memberPairs = memberXObjsToPairs correctedMembers
-               in tokensForStr typeEnv env typeName memberPairs concreteStructTy
+               in tokensForStr typeEnv env (show name) memberPairs concreteStructTy
           )
           ( \ft@(FuncTy [RefTy concreteStructTy@(StructTy _ _) _] StringTy _) ->
               let mappings = unifySignatures originalStructTy concreteStructTy
@@ -509,8 +531,8 @@ tokensForStr typeEnv env typeName memberPairs concreteStructTy =
 
 -- | Figure out how big the string needed for the string representation of the struct has to be.
 calculateStructStrSize :: TypeEnv -> Env -> [(String, Ty)] -> Ty -> String
-calculateStructStrSize typeEnv env members (StructTy (ConcreteNameTy name) _) =
+calculateStructStrSize typeEnv env members s@(StructTy (ConcreteNameTy _) _) =
-  "  int size = snprintf(NULL, 0, \"(%s )\", \"" ++ name ++ "\");\n"
+  "  int size = snprintf(NULL, 0, \"(%s )\", \"" ++ show s ++ "\");\n"
     ++ unlines (map (memberPrnSize typeEnv env) members)
 calculateStructStrSize _ _ _ _ = error "calculatestructstrsize"
 
@@ -525,7 +547,7 @@ memberAssignment allocationMode memberName = "    instance" ++ sep ++ memberName
 
 -- | Helper function to create the binder for the 'delete' template.
 binderForDelete :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> Either TypeError ((String, Binder), [XObj])
-binderForDelete typeEnv env insidePath structTy@(StructTy (ConcreteNameTy typeName) _) [XObj (Arr membersXObjs) _ _] =
+binderForDelete typeEnv env insidePath structTy@(StructTy (ConcreteNameTy _) _) [XObj (Arr membersXObjs) _ _] =
   if isTypeGeneric structTy
     then Right (genericDelete insidePath structTy membersXObjs, [])
     else
@@ -534,18 +556,18 @@ binderForDelete typeEnv env insidePath structTy@(StructTy (ConcreteNameTy typeNa
             (SymPath insidePath "delete")
             (FuncTy [structTy] UnitTy StaticLifetimeTy)
             (concreteDelete typeEnv env (memberXObjsToPairs membersXObjs))
-            ("deletes a `" ++ typeName ++ "`.")
+            ("deletes a `" ++ show structTy ++ "`.")
         )
 binderForDelete _ _ _ _ _ = error "binderfordelete"
 
 -- | The template for the 'delete' function of a generic deftype.
 genericDelete :: [String] -> Ty -> [XObj] -> (String, Binder)
-genericDelete pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membersXObjs =
+genericDelete pathStrings originalStructTy@(StructTy (ConcreteNameTy _) _) membersXObjs =
   defineTypeParameterizedTemplate templateCreator path (FuncTy [originalStructTy] UnitTy StaticLifetimeTy) docs
   where
     path = SymPath pathStrings "delete"
     t = FuncTy [VarTy "p"] UnitTy StaticLifetimeTy
-    docs = "deletes a `" ++ typeName ++ "`. Should usually not be called manually."
+    docs = "deletes a `" ++ show originalStructTy ++ "`. Should usually not be called manually."
     templateCreator = TemplateCreator $
       \typeEnv env ->
         Template
@@ -578,7 +600,7 @@ genericDelete _ _ _ = error "genericdelete"
 
 -- | Helper function to create the binder for the 'copy' template.
 binderForCopy :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> Either TypeError ((String, Binder), [XObj])
-binderForCopy typeEnv env insidePath structTy@(StructTy (ConcreteNameTy typeName) _) [XObj (Arr membersXObjs) _ _] =
+binderForCopy typeEnv env insidePath structTy@(StructTy (ConcreteNameTy _) _) [XObj (Arr membersXObjs) _ _] =
   if isTypeGeneric structTy
     then Right (genericCopy insidePath structTy membersXObjs, [])
     else
@@ -587,18 +609,18 @@ binderForCopy typeEnv env insidePath structTy@(StructTy (ConcreteNameTy typeName
             (SymPath insidePath "copy")
             (FuncTy [RefTy structTy (VarTy "q")] structTy StaticLifetimeTy)
             (concreteCopy typeEnv env (memberXObjsToPairs membersXObjs))
-            ("copies a `" ++ typeName ++ "`.")
+            ("copies a `" ++ show structTy ++ "`.")
         )
 binderForCopy _ _ _ _ _ = error "binderforcopy"
 
 -- | The template for the 'copy' function of a generic deftype.
 genericCopy :: [String] -> Ty -> [XObj] -> (String, Binder)
-genericCopy pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membersXObjs =
+genericCopy pathStrings originalStructTy@(StructTy (ConcreteNameTy _) _) membersXObjs =
   defineTypeParameterizedTemplate templateCreator path (FuncTy [RefTy originalStructTy (VarTy "q")] originalStructTy StaticLifetimeTy) docs
   where
     path = SymPath pathStrings "copy"
     t = FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy
-    docs = "copies the `" ++ typeName ++ "`."
+    docs = "copies the `" ++ show originalStructTy ++ "`."
     templateCreator = TemplateCreator $
       \typeEnv env ->
         Template

src/Emit.hs

@@ -8,6 +8,7 @@ module Emit
     checkForUnresolvedSymbols,
     ToCMode (..),
     wrapInInitFunction,
+    typeEnvToDeclarations,
   )
 where
 
@@ -139,7 +140,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
               x -> show (ord x) ++ "/*" ++ show x ++ "*/" -- ['U', '\'', x, '\'']
             Closure elt _ -> visit indent elt
             Sym _ _ -> visitSymbol indent xobj
-            Mod _ -> error (show (CannotEmitModKeyword xobj))
+            Mod _ _ -> error (show (CannotEmitModKeyword xobj))
             External _ -> error (show (CannotEmitExternal xobj))
             (Defn _) -> dontVisit
             Def -> dontVisit
@@ -258,7 +259,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
                 Just callback = name
                 callbackMangled = pathToC callback
                 needEnv = not (null capturedVars)
-                lambdaEnvTypeName = callbackMangled ++ "_env" -- The name of the struct is the callback name with suffix '_env'.
+                lambdaEnvTypeName = (SymPath [] (callbackMangled ++ "_ty")) -- The name of the struct is the callback name with suffix '_ty'.
                 lambdaEnvType = StructTy (ConcreteNameTy lambdaEnvTypeName) []
                 lambdaEnvName = freshVar info ++ "_env"
             appendToSrc
@@ -293,8 +294,8 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
             appendToSrc (addIndent indent ++ "Lambda " ++ retVar ++ " = {\n")
             appendToSrc (addIndent indent ++ "  .callback = (void*)" ++ callbackMangled ++ ",\n")
             appendToSrc (addIndent indent ++ "  .env = " ++ (if needEnv then lambdaEnvName else "NULL") ++ ",\n")
-            appendToSrc (addIndent indent ++ "  .delete = (void*)" ++ (if needEnv then "" ++ lambdaEnvTypeName ++ "_delete" else "NULL") ++ ",\n")
+            appendToSrc (addIndent indent ++ "  .delete = (void*)" ++ (if needEnv then "" ++ show lambdaEnvTypeName ++ "_delete" else "NULL") ++ ",\n")
-            appendToSrc (addIndent indent ++ "  .copy = (void*)" ++ (if needEnv then "" ++ lambdaEnvTypeName ++ "_copy" else "NULL") ++ "\n")
+            appendToSrc (addIndent indent ++ "  .copy = (void*)" ++ (if needEnv then "" ++ show lambdaEnvTypeName ++ "_copy" else "NULL") ++ "\n")
             appendToSrc (addIndent indent ++ "};\n")
             pure retVar
         -- Def
@@ -661,8 +662,8 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
                     else tyToCLambdaFix retTy ++ "(*)(" ++ joinWithComma (map tyToCLambdaFix voidless) ++ ")"
                 castToFnWithEnv =
                   if unwrapLambdas
-                    then tyToCLambdaFix retTy ++ "(*)(" ++ joinWithComma (map tyToCRawFunctionPtrFix (StructTy (ConcreteNameTy "LambdaEnv") [] : voidless)) ++ ")"
+                    then tyToCLambdaFix retTy ++ "(*)(" ++ joinWithComma (map tyToCRawFunctionPtrFix (StructTy (ConcreteNameTy (SymPath [] "LambdaEnv")) [] : voidless)) ++ ")"
-                    else tyToCLambdaFix retTy ++ "(*)(" ++ joinWithComma (map tyToCLambdaFix (StructTy (ConcreteNameTy "LambdaEnv") [] : voidless)) ++ ")"
+                    else tyToCLambdaFix retTy ++ "(*)(" ++ joinWithComma (map tyToCLambdaFix (StructTy (ConcreteNameTy (SymPath [] "LambdaEnv")) [] : voidless)) ++ ")"
                 callLambda = funcToCall ++ ".env ? ((" ++ castToFnWithEnv ++ ")" ++ funcToCall ++ ".callback)" ++ "(" ++ funcToCall ++ ".env" ++ (if null argListAsC then "" else ", ") ++ argListAsC ++ ") : ((" ++ castToFn ++ ")" ++ funcToCall ++ ".callback)(" ++ argListAsC ++ ");\n"
             if isUnit retTy
               then do
@@ -703,7 +704,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
       do
         let arrayVar = freshVar i
             len = length xobjs
-            Just (StructTy (ConcreteNameTy "Array") [innerTy]) = t
+            Just (StructTy (ConcreteNameTy (SymPath [] "Array")) [innerTy]) = t
         appendToSrc
           ( addIndent indent ++ "Array " ++ arrayVar
               ++ " = { .len = "
@@ -744,7 +745,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
             retVar = arrayVar ++ "_retref"
             arrayDataVar = arrayVar ++ "_data"
             len = length xobjs
-            Just tt@(RefTy (StructTy (ConcreteNameTy "StaticArray") [innerTy]) _) = t
+            Just tt@(RefTy (StructTy (ConcreteNameTy (SymPath [] "StaticArray")) [innerTy]) _) = t
         appendToSrc (addIndent indent ++ tyToCLambdaFix innerTy ++ " " ++ arrayDataVar ++ "[" ++ show len ++ "];\n")
         appendToSrc
           ( addIndent indent ++ "Array " ++ arrayVar
@@ -960,7 +961,7 @@ binderToC toCMode binder =
         XObj (External _) _ _ -> Right ""
         XObj (ExternalType _) _ _ -> Right ""
         XObj (Command _) _ _ -> Right ""
-        XObj (Mod env) _ _ -> envToC env toCMode
+        XObj (Mod env _) _ _ -> envToC env toCMode
         _ -> case xobjTy xobj of
           Just t ->
             if isTypeGeneric t
@@ -974,16 +975,16 @@ binderToDeclaration :: TypeEnv -> Binder -> Either ToCError String
 binderToDeclaration typeEnv binder =
   let xobj = binderXObj binder
    in case xobj of
-        XObj (Mod env) _ _ -> envToDeclarations typeEnv env
+        XObj (Mod env _) _ _ -> envToDeclarations typeEnv env
         _ -> case xobjTy xobj of
           Just t -> if isTypeGeneric t then Right "" else Right (toDeclaration binder ++ "")
           Nothing -> Left (BinderIsMissingType binder)
 
 envToC :: Env -> ToCMode -> Either ToCError String
 envToC env toCMode =
-  let binders = Map.toList (envBindings env)
+  let binders' = Map.toList (envBindings env)
    in do
-        okCodes <- mapM (binderToC toCMode . snd) binders
+        okCodes <- mapM (binderToC toCMode . snd) binders'
         pure (concat okCodes)
 
 globalsToC :: Env -> Either ToCError String
@@ -1000,6 +1001,34 @@ globalsToC globalEnv =
             (sortGlobalVariableBinders globalEnv allGlobalBinders)
         pure (concat okCodes)
 
+-- | Similar to envToDeclarations, however, to get types, we need to traverse
+-- the global environment, pull out local type envs from modules, then emit
+-- binders for these types.
+--
+-- TODO: It should be possible to define a general function that works for both
+-- value/type envs, then we can merge this and envToDeclarations
+typeEnvToDeclarations :: TypeEnv -> Env -> Either ToCError String
+typeEnvToDeclarations typeEnv global =
+  let -- We need to carry the type environment to pass the correct environment on the binderToDeclaration call.
+      addEnvToScore tyE = (sortDeclarationBinders tyE (map snd (Map.toList (binders tyE))))
+      bindersWithScore = (addEnvToScore typeEnv)
+      mods = (findModules global)
+      folder =
+        ( \sorted (XObj (Mod e t) _ _) ->
+            sorted ++ (foldl folder (addEnvToScore t) (findModules e))
+        )
+      allScoredBinders = sortOn fst (foldl folder bindersWithScore mods)
+   in do
+        okDecls <-
+          mapM
+            ( \(score, binder) ->
+                fmap
+                  (\s -> if s == "" then "" else ("\n// Depth " ++ show score ++ "\n") ++ s)
+                  (binderToDeclaration typeEnv binder)
+            )
+            allScoredBinders
+        pure (concat okDecls)
+
 envToDeclarations :: TypeEnv -> Env -> Either ToCError String
 envToDeclarations typeEnv env =
   let bindersWithScore = sortDeclarationBinders typeEnv (map snd (Map.toList (envBindings env)))
@@ -1018,13 +1047,13 @@ envToDeclarations typeEnv env =
 -- debugScorePair (s,b) = trace ("Scored binder: " ++ show b ++ ", score: " ++ show s) (s,b)
 
 sortDeclarationBinders :: TypeEnv -> [Binder] -> [(Int, Binder)]
-sortDeclarationBinders typeEnv binders =
+sortDeclarationBinders typeEnv binders' =
   --trace ("\nSORTED: " ++ (show (sortOn fst (map (scoreBinder typeEnv) binders))))
-  sortOn fst (map (scoreTypeBinder typeEnv) binders)
+  sortOn fst (map (scoreTypeBinder typeEnv) binders')
 
 sortGlobalVariableBinders :: Env -> [Binder] -> [(Int, Binder)]
-sortGlobalVariableBinders globalEnv binders =
+sortGlobalVariableBinders globalEnv binders' =
-  sortOn fst (map (scoreValueBinder globalEnv Set.empty) binders)
+  sortOn fst (map (scoreValueBinder globalEnv Set.empty) binders')
 
 checkForUnresolvedSymbols :: XObj -> Either ToCError ()
 checkForUnresolvedSymbols = visit

src/Env.hs

@@ -1,109 +1,659 @@
-module Env where
+{-# LANGUAGE TupleSections #-}
 
-import Data.List (foldl')
+module Env
+  ( EnvironmentError,
+    Environment (..),
+    Mode (..),
+    -- utils
+    empty,
+    new,
+    parent,
+    setParent,
+    nested,
+    recursive,
+    binders,
+    ------------------------
+    -- lookups
+    getType,
+    getTypeBinder,
+    findType,
+    findTypeBinder,
+    searchType,
+    searchTypeBinder,
+    getValue,
+    getValueBinder,
+    findValue,
+    findValueBinder,
+    searchValue,
+    searchValueBinder,
+    -------------------------
+    -- Environment getters
+    getInnerEnv,
+    contextEnv,
+    envIsExternal,
+    envPublicBindingNames,
+    -------------------------
+    -- mutation
+    insert,
+    insertX,
+    replace,
+    addBinding,
+    deleteBinding,
+    addListOfBindings,
+    addUsePath,
+    -------------------------
+    -- finds
+    findPoly,
+    findAllByMeta,
+    findChildren,
+    findImplementations,
+    findAllGlobalVariables,
+    findModules,
+    allImportedEnvs,
+    -------------------------
+    -- lookups
+    lookupContextually,
+    lookupMeta,
+    lookupChildren,
+    lookupInUsed,
+    lookupEverywhere,
+    lookupBinderEverywhere,
+    progenitor,
+    replaceInPlace,
+  )
+where
+
+import Data.Either (fromRight, rights)
+import Data.List (foldl', unfoldr)
 import Data.Maybe (fromMaybe)
 import qualified Map
+import qualified Meta
 import Obj
+import qualified Set
 import Types
 
--- | Add an XObj to a specific environment. TODO: rename to envInsert
+--------------------------------------------------------------------------------
-extendEnv :: Env -> String -> XObj -> Env
+-- Data
-extendEnv env name xobj = envAddBinding env name (Binder emptyMeta xobj)
 
--- | Add a Binder to an environment at a specific path location.
+data EnvironmentError
-envInsertAt :: Env -> SymPath -> Binder -> Env
+  = NoEnvInNonModule
-envInsertAt env (SymPath [] name) binder =
+  | NoReplaceInNonModule
-  envAddBinding env name binder
+  | BindingNotFound String Env
-envInsertAt env (SymPath (p : ps) name) xobj =
+  | NoMatchingBindingFound String
-  case Map.lookup p (envBindings env) of
+  | NestedTypeError String
-    Just (Binder meta (XObj (Mod innerEnv) i t)) ->
-      let newInnerEnv = Binder meta (XObj (Mod (envInsertAt innerEnv (SymPath ps name) xobj)) i t)
-       in env {envBindings = Map.insert p newInnerEnv (envBindings env)}
-    Just _ -> error ("Can't insert into non-module: " ++ p)
-    Nothing -> error ("Can't insert into non-existing module: " ++ p)
 
-envReplaceEnvAt :: Env -> [String] -> Env -> Env
+instance Show EnvironmentError where
-envReplaceEnvAt _ [] replacement = replacement
+  show NoEnvInNonModule = "Can't get an environment from a non-module."
-envReplaceEnvAt env (p : ps) replacement =
+  show NoReplaceInNonModule = "Can't replace an environment in a non-module."
-  case Map.lookup p (envBindings env) of
+  show (BindingNotFound name e) = "Failed to find " ++ name ++ "in the given environment: " ++ show e
-    Just (Binder _ (XObj (Mod innerEnv) i t)) ->
+  show (NoMatchingBindingFound predicate) = "Couldn't find any bindings with " ++ predicate ++ "in the given environment."
-      let newInnerEnv = Binder emptyMeta (XObj (Mod (envReplaceEnvAt innerEnv ps replacement)) i t)
+  show (NestedTypeError name) =
-       in env {envBindings = Map.insert p newInnerEnv (envBindings env)}
+    "Couldn't insert the top-level type " ++ name
-    Just _ -> error ("Can't replace non-module: " ++ p)
+      ++ " in a module environment."
-    Nothing -> error ("Can't replace non-existing module: " ++ p)
 
--- | Add a Binder to a specific environment.
+data Mode = Types | Values
-envAddBinding :: Env -> String -> Binder -> Env
-envAddBinding env name binder = env {envBindings = Map.insert name binder (envBindings env)}
 
-{-# ANN addListOfBindings "HLint: ignore Eta reduce" #-}
+--------------------------------------------------------------------------------
+-- The Environment class and implementations
 
--- | Add a list of bindings to an environment
+-- | Class for generically handling type and value environments.
-addListOfBindings :: Env -> [(String, Binder)] -> Env
+class Environment e where
-addListOfBindings env bindingsToAdd = foldl' (\e (n, b) -> envAddBinding e n b) env bindingsToAdd
+  inj :: Env -> e
+  prj :: e -> Env
+  update :: e -> Binder -> Either EnvironmentError Binder
+  modality :: e -> Mode
 
--- | Get an inner environment.
+-- | The value environment
-getEnv :: Env -> [String] -> Env
+instance Environment Env where
-getEnv env [] = env
+  inj = id
-getEnv env (p : ps) = case Map.lookup p (envBindings env) of
+  prj = id
-  Just (Binder _ (XObj (Mod innerEnv) _ _)) -> getEnv innerEnv ps
+  update e (Binder meta (XObj (Mod _ et) i t)) = Right (Binder meta (XObj (Mod e et) i t))
-  Just _ -> error "Can't get non-env."
+  update _ _ = Left NoReplaceInNonModule
-  Nothing -> error "Can't get env."
+  modality _ = Values
 
-contextEnv :: Context -> Env
+-- | The type environment
-contextEnv Context {contextInternalEnv = Just e} = e
+instance Environment TypeEnv where
-contextEnv Context {contextGlobalEnv = e, contextPath = p} = getEnv e p
+  inj = TypeEnv
+  prj = getTypeEnv
+  update e (Binder meta (XObj (Mod ev _) i t)) = Right (Binder meta (XObj (Mod ev e) i t))
+  update _ _ = Left NoReplaceInNonModule
+  modality _ = Types
 
--- | Checks if an environment is "external", meaning it's either the global scope or a module scope.
+--------------------------------------------------------------------------------
-envIsExternal :: Env -> Bool
+-- Misc. Environment utilities
-envIsExternal env =
+
-  case envMode env of
+-- | Returns an unnamed empty environment with no parent.
+empty :: Environment e => e
+empty = inj $ Env (Map.fromList []) Nothing Nothing Set.empty ExternalEnv 0
+
+-- | Returns a new environment with a given parent and name.
+new :: Environment e => Maybe e -> Maybe String -> e
+new p name =
+  let e' = Env (Map.fromList []) (fmap prj p) name Set.empty ExternalEnv 0
+   in inj e'
+
+-- | Returns a new environment with a designated nesting level.
+nested :: Environment e => Maybe e -> Maybe String -> Int -> e
+nested p name lvl = inj ((prj (new p name)) {envMode = InternalEnv, envFunctionNestingLevel = lvl})
+
+-- | Returns a new recursive environment with a designated nesting level.
+recursive :: Environment e => Maybe e -> Maybe String -> Int -> e
+recursive p name lvl = inj ((prj (new p name)) {envMode = RecursionEnv, envFunctionNestingLevel = lvl})
+
+-- | Returns the binders stored in an environment.
+binders :: Environment e => e -> Map.Map String Binder
+binders = envBindings . prj
+
+-- | Get the parent of an environment.
+parent :: Environment e => e -> Maybe e
+parent = fmap inj . envParent . prj
+
+-- | Set the parent of an environment.
+setParent :: Environment e => e -> e -> e
+setParent e p = inj ((prj e) {envParent = Just (prj p)})
+
+-- | Get an environment stored in a module binder.
+nextEnv :: Mode -> Binder -> Either EnvironmentError Env
+nextEnv Types (Binder _ (XObj (Mod _ et) _ _)) = Right $ prj et
+nextEnv Values (Binder _ (XObj (Mod ev _) _ _)) = Right $ prj ev
+nextEnv _ _ = Left NoEnvInNonModule
+
+-- | Replace an environment stored in a module binder.
+updateEnv :: Mode -> Env -> Binder -> Either EnvironmentError Binder
+updateEnv Values e (Binder meta (XObj (Mod _ et) i t)) = Right (Binder meta (XObj (Mod e et) i t))
+updateEnv Types e (Binder meta (XObj (Mod ev _) i t)) = Right (Binder meta (XObj (Mod ev (TypeEnv e)) i t))
+updateEnv _ _ _ = Left NoEnvInNonModule
+
+--------------------------------------------------------------------------------
+-- Environment traversal
+--
+-- Naming conventions:
+--
+--   get: Direct lookup. Try to get the designated binder directly from an
+--   environment, without traversing into parents or children. If not found,
+--   fail.
+--
+--   find: Preorder lookup. Try to get the designated binder by proceeding from
+--   the root environment down to its children. If not found in a child, fail.
+--
+--   search: pre and post order lookup: Try to get the designated binder by
+--   proceeding from the root to children. If not found, try to find the binder
+--   by proceeding from the root's parent, if it exists, to its children. If
+--   not found, fail.
+
+-- | Walk down an environment chain.
+walk' :: Mode -> Env -> SymPath -> Either EnvironmentError Env
+walk' _ e (SymPath [] _) = pure e
+walk' mode' e (SymPath (p : ps) name) =
+  do
+    (_, binder) <- get e p
+    go (SymPath ps name) binder
+  where
+    go :: SymPath -> Binder -> Either EnvironmentError Env
+    go (SymPath [] _) binder = nextEnv mode' binder
+    go path binder =
+      do
+        env <- nextEnv Values binder
+        walk' mode' env path
+
+-- | Generic *unidirectional* retrieval of binders (does not check parents).
+walkAndGet :: Environment e => e -> SymPath -> (Either EnvironmentError e, Either EnvironmentError Binder)
+walkAndGet e path@(SymPath _ name) =
+  let target = walk' (modality e) (prj e) path
+      binder = target >>= \t -> get t name
+   in (fmap inj target, fmap snd binder)
+
+-- | Direct lookup for a binder in environment `e`.
+-- The environment returned in the output will be the same as that given as input.
+--
+-- Returns an error if not found.
+get :: Environment e => e -> String -> Either EnvironmentError (e, Binder)
+get e name =
+  case Map.lookup name (binders e) of
+    Nothing -> Left $ BindingNotFound name (prj e)
+    Just b -> Right (e, b)
+
+-- | Same as `get` but only returns a binder.
+getBinder :: Environment e => e -> String -> Either EnvironmentError Binder
+getBinder e name = fmap snd (get e name)
+
+-- | Generic unidirectional retrieval of binders.
+-- Searches the children of `e` using a given path, stopping at the terminus.
+--
+-- Returns an error if not found.
+find' :: Environment e => e -> SymPath -> Either EnvironmentError (e, Binder)
+find' e path =
+  case walkAndGet e path of
+    (Right e', Right b) -> Right (e', b)
+    (Left err, _) -> Left err
+    (_, Left err) -> Left err
+
+-- | Same as `find` but only returns a binder.
+findBinder :: Environment e => e -> SymPath -> Either EnvironmentError Binder
+findBinder e path = fmap snd (find' e path)
+
+-- | Generic *multidirectional* retrieval of binders.
+-- Searches the children and parents of `e` (or the parent of a sub-environment
+-- found in `e` and given by `path`).
+--
+-- Returns an error if not found.
+search :: Environment e => e -> SymPath -> Either EnvironmentError (e, Binder)
+search e path =
+  case walkAndGet e path of
+    (Right e', Right b) -> Right (e', b)
+    (Right e', Left err) -> (checkParent e' err)
+    (Left err, Left _) -> (checkParent e err) <> Left err
+    -- impossible case. Included to keep `walk` honest.
+    (Left _, Right _) -> error "impossible"
+  where
+    checkParent env err = maybe (Left err) (`search` path) (parent env)
+
+-- | Same as `search` but only returns a binder.
+searchBinder :: Environment e => e -> SymPath -> Either EnvironmentError Binder
+searchBinder e path = fmap snd (search e path)
+
+--------------------------------------------------------------------------------
+-- Specialized retrievals
+--
+-- These functions are all equivalent to the generic retrieval functions
+-- defined above but they enforce further restrictions at type level. Thus,
+-- they can be used to help enforce constraints at call sites.
+--
+-- For example, suppose we want to search for a binder that may name a type
+
+-- * or* module, preferring types. One could cast to enforce a type search
+
+-- starting from the global env:
+--
+--   search typeEnv path
+--   <> search (TypeEnv global) path
+--   <> search global path
+--
+--   But:
+--
+--   searchType typeEnv path
+--   searchType global path
+--   <> searchValue global path
+--
+--   Is arguably much clearer.
+
+--------------------------------------------------------------------------------
+-- Type retrievals
+
+-- | Get a type from a type environment.
+getType :: TypeEnv -> String -> Either EnvironmentError (TypeEnv, Binder)
+getType = get
+
+-- | Get a type binder from a type environment.
+getTypeBinder :: TypeEnv -> String -> Either EnvironmentError Binder
+getTypeBinder = getBinder
+
+-- | Unidirectional binder retrieval specialized to types.
+--
+-- Restricts the final step of a search to binders in a module's *type* environment.
+findType :: Environment e => e -> SymPath -> Either EnvironmentError (TypeEnv, Binder)
+findType e path = find' (inj (prj e)) path
+
+findTypeBinder :: Environment e => e -> SymPath -> Either EnvironmentError Binder
+findTypeBinder e path = fmap snd (findType e path)
+
+-- | Multidirectional binder retrieval specialized to types.
+--
+-- Restricts the final step of a search to binders in a module's *type* environment.
+searchType :: Environment e => e -> SymPath -> Either EnvironmentError (TypeEnv, Binder)
+searchType e path = search (inj (prj e)) path
+
+searchTypeBinder :: Environment e => e -> SymPath -> Either EnvironmentError Binder
+searchTypeBinder e path = fmap snd (searchType e path)
+
+--------------------------------------------------------------------------------
+-- Value retrievals
+
+-- | Get a value from a value environment.
+getValue :: Env -> String -> Either EnvironmentError (Env, Binder)
+getValue = get
+
+getValueBinder :: Env -> String -> Either EnvironmentError Binder
+getValueBinder = getBinder
+
+-- | Unidirectional binder retrieval specialized to values.
+findValue :: Env -> SymPath -> Either EnvironmentError (Env, Binder)
+findValue = find'
+
+findValueBinder :: Env -> SymPath -> Either EnvironmentError Binder
+findValueBinder = findBinder
+
+-- | Multidirectional binder retrieval specialized to values.
+searchValue :: Env -> SymPath -> Either EnvironmentError (Env, Binder)
+searchValue = search
+
+searchValueBinder :: Env -> SymPath -> Either EnvironmentError Binder
+searchValueBinder = searchBinder
+
+--------------------------------------------------------------------------------
+-- Environment mutation
+
+--------------------------------------------------------------------------------
+-- Mutation primitives
+
+-- N.B. The following functions returns an Either for compatibility with other
+-- functions in this module. It is a constant function in the co-domain of
+-- Either, as they always returns Right.
+
+-- | Add a new binding to an environment.
+addBinding :: Environment e => e -> String -> Binder -> Either EnvironmentError e
+addBinding e name b = pure (inj ((prj e) {envBindings = Map.insert name b (binders e)}))
+
+-- | Replace the value of a binding in an environment, but only if it already
+-- exists.
+replaceBinding :: Environment e => e -> String -> Binder -> Either EnvironmentError e
+replaceBinding e name b =
+  pure (inj ((prj e) {envBindings = Map.adjust (const b) name (binders e)}))
+
+-- | Delete a binding in an environment.
+deleteBinding :: Environment e => e -> String -> Either EnvironmentError e
+deleteBinding e name = pure (inj ((prj e) {envBindings = Map.delete name (binders e)}))
+
+--------------------------------------------------------------------------------
+-- Generic environment mutation
+
+type EnvironmentProducer e = (e -> String -> Binder -> Either EnvironmentError e)
+
+-- | Given an environment and a complete identifier path, traverse a chain of
+-- environments until the path is exhausted, if requested, mutating the
+-- environments along the way:
+mutate :: Environment e => (EnvironmentProducer e) -> e -> SymPath -> Binder -> Either EnvironmentError e
+mutate f e path binder = go path
+  where
+    go (SymPath [] name) = f e name binder
+    go (SymPath (p : ps) name) =
+      getBinder e p
+        >>= \modu ->
+          nextEnv (modality e) modu
+            >>= \oldEnv ->
+              mutate f (inj oldEnv) (SymPath ps name) binder
+                >>= \result ->
+                  updateEnv (modality e) (prj result) modu
+                    >>= addBinding e p
+
+-- | Insert a binding into an environment at the given path.
+insert :: Environment e => e -> SymPath -> Binder -> Either EnvironmentError e
+insert = mutate addBinding
+
+-- | Insert an XObj into an environment at the specified path.
+-- This function does not perform insertions into parents.
+insertX :: Environment e => e -> SymPath -> XObj -> Either EnvironmentError e
+insertX e path x = insert e path (toBinder x)
+
+-- | Replace a binding at the given path in an environment.
+replace :: Environment e => e -> SymPath -> Binder -> Either EnvironmentError e
+replace = mutate replaceBinding
+
+-- | Replaces a binding "in-place" in an environment chain.
+--
+-- This function *only* considers members of an environment chain, that is,
+-- it's limited to the given input environment and all of its ancestors (it's
+-- parent and the parent of its parent all the way up).
+--
+-- It does not look in any "external" environments (used environments or
+-- "children" (environments stored in module bindings)).
+replaceInPlace :: Environment e => e -> String -> Binder -> Either EnvironmentError e
+replaceInPlace e name b =
+  (get e name >>= \_ -> addBinding e name b)
+    <> case parent e of
+      Just p -> replaceInPlace p name b >>= \p' -> pure (inj ((prj e) {envParent = Just (prj p')}))
+      Nothing -> Left (BindingNotFound name (prj e))
+
+-- | Add a list of bindings to an environment.
+addListOfBindings :: Environment e => e -> [(String, Binder)] -> e
+addListOfBindings e bindings =
+  foldl' (\e' (n, b) -> fromRight e (addBinding e' n b)) e bindings
+
+-- | Add a module path to an environment's list of used modules.
+addUsePath :: Environment e => e -> SymPath -> e
+addUsePath e path = inj ((prj e) {envUseModules = Set.insert path (envUseModules (prj e))})
+
+--------------------------------------------------------------------------------
+-- Additional binding lookup functions
+--
+-- find* functions perform lookup in a single environment, without recursion.
+-- lookup* functions perform lookups in an environment chain, with recursion.
+
+-- | Get the metadata associated with the binder at the specified path in an environment.
+lookupMeta :: Environment e => e -> SymPath -> Either EnvironmentError MetaData
+lookupMeta e path = searchBinder e path >>= pure . Meta.fromBinder
+
+-- | Find all binders in an environment that have a specified meta key.
+findAllByMeta :: Environment e => e -> String -> Either EnvironmentError [Binder]
+findAllByMeta e metaKey =
+  let candidates = Map.elems (Map.filter (Meta.binderMember metaKey) (binders e))
+   in case candidates of
+        [] -> Left (NoMatchingBindingFound ("metadata " ++ metaKey))
+        _ -> Right $ candidates
+
+-- | Find all modules directly stored in environment `e`.
+findModules :: Environment e => e -> [XObj]
+findModules e =
+  map binderXObj (filter modsOnly (Map.elems (binders e)))
+  where
+    modsOnly :: Binder -> Bool
+    modsOnly binder =
+      case binderXObj binder of
+        XObj (Mod _ _) _ _ -> True
+        _ -> False
+
+-- | It's more efficient to specialize this function as it can take advantage
+-- of laziness; once we found the candidate function for a polymorphic
+-- function, there's no need to consume the rest of the environment.
+findPoly :: Environment e => e -> String -> Ty -> Either EnvironmentError (e, Binder)
+findPoly env name ty =
+  case getBinder env name of
+    Right b ->
+      if unify b
+        then Right (env, b)
+        else (foldl' go (Left (BindingNotFound name (prj env))) (findChildren env))
+    Left _ -> foldl' go (Left (BindingNotFound name (prj env))) (findChildren env)
+  where
+    go x e = x <> (findPoly e name ty)
+    unify = areUnifiable ty . fromMaybe Universe . xobjTy . binderXObj
+
+-- | Find all environments that are *direct* children of an environment (one
+-- level down).
+--
+-- The modality of the children is determined by the modality of the root.
+--
+-- N.B. Don't use find here. We access binders directly, so there's no need to
+-- perform additional O(n) lookup calls.
+findChildren :: Environment e => e -> [e]
+findChildren e =
+  foldl' getEnv [] (binders e)
+  where
+    getEnv acc binder =
+      case (nextEnv (modality e) binder) of
+        Left _ -> acc
+        Right e' -> ((inj e') : acc)
+
+-- | Find all the environments contained in the modules initial environment,
+-- plus any module environments contained in *those* modules.
+lookupChildren :: Environment e => e -> [e]
+lookupChildren e =
+  foldl' go [] (findChildren e)
+  where
+    go acc e' = case findChildren e' of
+      [] -> (e' : acc)
+      xs -> (foldl' go [] xs ++ acc)
+
+-- | Find all the environments designated by the use paths in an environment.
+findImportedEnvs :: Environment e => e -> [e]
+findImportedEnvs e =
+  let eMode = modality e
+      usePaths = Set.toList (envUseModules (prj e))
+      getter path =
+        walk' eMode (prj e) path
+          >>= \e' ->
+            get e' (getName' path)
+              >>= nextEnv eMode . snd
+              >>= pure . inj
+      used = fmap getter usePaths
+   in (rights used)
+  where
+    getName' (SymPath _ name) = name
+
+-- | Given an environment, get its topmost parent up the environment chain.
+--
+-- For nearly all environments, this should be the global environment.
+progenitor :: Environment e => e -> e
+progenitor e = fromMaybe e (parent e >>= \p -> pure (progenitor p))
+
+-- | Find all possible environments imported at some point *upwards* from e in a chain of environments.
+allImportedEnvs :: Environment e => e -> Env -> [e]
+allImportedEnvs e global =
+  let env = prj e
+      paths = (Set.toList (foldl' og (envUseModules env) (unfoldr go env)))
+   in (rights (map get' paths))
+  where
+    go e' = parent e' >>= \p -> pure (p, p)
+    og acc e' = (envUseModules e') <> acc
+    get' path =
+      findBinder global path
+        >>= nextEnv (modality e)
+        >>= pure . inj
+
+-- | Find all binders the implement a given interface, designated by its path.
+findImplementations :: Environment e => e -> SymPath -> Either EnvironmentError [Binder]
+findImplementations e interface =
+  ( (findAllByMeta e "implements")
+      >>= \is -> (pure (filter (isImpl . Meta.fromBinder) is))
+  )
+    <> Left (NoMatchingBindingFound ("implementation meta for " ++ show interface))
+  where
+    isImpl :: MetaData -> Bool
+    isImpl meta =
+      case Meta.get "implements" meta of
+        Just (XObj (Lst interfaces) _ _) -> interface `elem` map getPath interfaces
+        _ -> False
+
+-- | Searches for binders exhaustively in the given environment, a list of
+-- child environments it contains derived using a function and its parent, if
+-- it has one.
+--
+-- The parent environment, when it exists, is also searched exhaustively
+-- (derived children of the parent are searched, as well as the parent of the
+-- parent, should it exist).
+lookupExhuastive :: Environment e => (e -> [e]) -> e -> String -> [(e, Binder)]
+lookupExhuastive f e name =
+  let envs = [e] ++ (f e)
+   in (go (parent e) envs)
+  where
+    go _ [] = []
+    go Nothing xs = foldl' accum [] xs
+    go (Just p) xs = go (parent p) (xs ++ [p] ++ (f p))
+    accum acc e' = case getBinder e' name of
+      Right b -> ((e', b) : acc)
+      _ -> acc
+
+lookupBinderExhuastive :: Environment e => (e -> [e]) -> e -> String -> [Binder]
+lookupBinderExhuastive f e name = fmap snd (lookupExhuastive f e name)
+
+lookupEverywhere :: Environment e => e -> String -> [(e, Binder)]
+lookupEverywhere = lookupExhuastive lookupChildren
+
+lookupInImports :: Environment e => e -> String -> [(e, Binder)]
+lookupInImports = lookupExhuastive findImportedEnvs
+
+lookupInUsed :: Environment e => e -> Env -> SymPath -> [(e, Binder)]
+lookupInUsed e global spath =
+  foldl' go [] (allImportedEnvs e global)
+  where
+    go :: Environment e => [(e, Binder)] -> e -> [(e, Binder)]
+    go acc e' = case (search e' spath) of
+      Right (e'', b) -> ((e'', b) : acc)
+      _ -> acc
+
+-- | Lookup a binder in *all* possible environments in the chain of an initial
+-- environment (parents and children, including Use modules).
+lookupBinderEverywhere :: Environment e => e -> String -> [Binder]
+lookupBinderEverywhere = lookupBinderExhuastive lookupChildren
+
+lookupContextually :: Environment e => e -> SymPath -> Either EnvironmentError [(e, Binder)]
+lookupContextually e (SymPath [] name) =
+  case lookupInImports e name of
+    [] -> Left (BindingNotFound name (prj e))
+    xs -> Right xs
+lookupContextually e path@(SymPath (p : ps) name) =
+  lookupDirectly <> lookupInUsedAndParent
+  where
+    lookupDirectly =
+      (getBinder e p)
+        >>= nextEnv (modality e)
+        >>= \e' ->
+          search (inj e') (SymPath ps name)
+            >>= pure . (: [])
+    lookupInUsedAndParent = case rights (fmap ((flip search) path) (findImportedEnvs e)) of
+      [] -> Left (BindingNotFound name (prj e))
+      xs ->
+        case parent e of
+          Nothing -> Right xs
+          Just e' -> (Env.search e' path >>= \found -> Right $ xs ++ [found]) <> Right xs
+
+--------------------------------------------------------------------------------
+-- Environment retrieval functions
+
+-- | Get the environment at a given path that corresponds to the type of an
+-- initial environment.
+--
+-- Returns the initial environment when given an empty path.
+getInnerEnv :: Environment e => e -> [String] -> Either EnvironmentError e
+getInnerEnv e [] = Right e
+getInnerEnv e (p : ps) =
+  (getBinder e p)
+    >>= nextEnv (modality e)
+    >>= \moduleEnv -> getInnerEnv (inj moduleEnv) ps
+
+-- | Get a context's internal environment if it exists, otherwise get the
+-- innermost module's value environment based on the context path.
+contextEnv :: Environment e => Context -> e
+contextEnv Context {contextInternalEnv = Just e} = inj e
+contextEnv Context {contextGlobalEnv = e, contextPath = p} = inj (fromRight e (getInnerEnv e p))
+
+--------------------------------------------------------------------------------
+-- Utility functions
+
+-- | Checks if an environment is "external", meaning it's either the global
+-- scope or a module scope.
+envIsExternal :: Environment e => e -> Bool
+envIsExternal e =
+  case envMode (prj e) of
     ExternalEnv -> True
     InternalEnv -> False
     RecursionEnv -> True
 
-envReplaceBinding :: SymPath -> Binder -> Env -> Env
+--------------------------------------------------------------------------------
-envReplaceBinding s@(SymPath [] name) binder env =
+-- Binding Utilities
-  case Map.lookup name (envBindings env) of
-    Just _ ->
-      envAddBinding env name binder
-    Nothing ->
-      case envParent env of
-        Just parent -> env {envParent = Just (envReplaceBinding s binder parent)}
-        Nothing -> env
-envReplaceBinding s@(SymPath (p : ps) name) binder env =
-  case Map.lookup p (envBindings env) of
-    Just b@(Binder _ (XObj (Mod innerEnv) i t)) ->
-      envReplaceBinding (SymPath [] p) b {binderXObj = (XObj (Mod (envReplaceBinding (SymPath ps name) binder innerEnv)) i t)} env
-    _ ->
-      fromMaybe env (envParent env >>= \parent -> Just (env {envParent = Just (envReplaceBinding s binder parent)}))
 
-envBindingNames :: Env -> [String]
+-- | Get a list of all the names of bindings in an environment that aren't
-envBindingNames = concatMap select . envBindings
+-- hidden or private.
+envPublicBindingNames :: Environment e => e -> [String]
+envPublicBindingNames e = concatMap select (Map.toList (binders e))
   where
-    select :: Binder -> [String]
+    select :: (String, Binder) -> [String]
-    select (Binder _ (XObj (Mod m) _ _)) = envBindingNames m
+    select (name, binder) =
-    select (Binder _ obj) = [getName obj]
+      case (nextEnv (modality e) binder) of
-
+        Left _ ->
-envPublicBindingNames :: Env -> [String]
+          if metaIsTrue (binderMeta binder) "private" || metaIsTrue (binderMeta binder) "hidden"
-envPublicBindingNames = concatMap select . envBindings
+            then []
-  where
+            else [name]
-    select :: Binder -> [String]
+        Right e' -> envPublicBindingNames e'
-    select (Binder _ (XObj (Mod m) _ _)) = envPublicBindingNames m
-    select (Binder meta obj) =
-      if metaIsTrue meta "private" || metaIsTrue meta "hidden"
-        then []
-        else [getName obj]
 
 -- | Recursively look through all environments for (def ...) forms.
+--
+-- N.B. Don't use find here. We access binders directly, so there's no need to
+-- perform additional O(n) lookup calls.
 findAllGlobalVariables :: Env -> [Binder]
-findAllGlobalVariables env =
+findAllGlobalVariables e =
-  concatMap finder (envBindings env)
+  foldl' finder [] (Map.elems (binders e))
   where
-    finder :: Binder -> [Binder]
+    finder :: [Binder] -> Binder -> [Binder]
-    finder def@(Binder _ (XObj (Lst (XObj Def _ _ : _)) _ _)) =
+    finder acc (Binder _ (XObj (Mod ev _) _ _)) = acc ++ (findAllGlobalVariables (inj ev))
-      [def]
+    finder acc def@(Binder _ (XObj (Lst (XObj Def _ _ : _)) _ _)) = (def : acc)
-    finder (Binder _ (XObj (Mod innerEnv) _ _)) =
+    finder acc _ = acc
-      findAllGlobalVariables innerEnv
-    finder _ =
-      []

src/Eval.hs

@@ -8,17 +8,17 @@ import Context
 import Control.Applicative
 import Control.Exception
 import Control.Monad.State
+import Data.Either (fromRight)
 import Data.Foldable (foldlM, foldrM)
 import Data.List (foldl', intercalate, isSuffixOf)
 import Data.List.Split (splitOn, splitWhen)
 import Data.Maybe (fromJust, fromMaybe, isJust)
 import Emit
-import Env
+import qualified Env as E
 import EvalError
 import Expand
 import Infer
 import Info
-import Lookup
 import qualified Map
 import qualified Meta
 import Obj
@@ -81,9 +81,10 @@ eval ctx xobj@(XObj o info ty) preference resolver =
             then pure (ctx, Left (HasStaticCall xobj info))
             else pure v
         checkStatic v = pure v
+        -- all else failed, error.
         unwrapLookup =
           fromMaybe
-            (throwErr (SymbolNotFound spath) ctx info) -- all else failed, error.
+            (throwErr (SymbolNotFound spath) ctx info)
         tryAllLookups =
           ( case preference of
               PreferDynamic -> tryDynamicLookup
@@ -91,19 +92,25 @@ eval ctx xobj@(XObj o info ty) preference resolver =
           )
             <|> (if null p then tryInternalLookup spath else tryLookup spath)
         tryDynamicLookup =
-          lookupBinder (SymPath ("Dynamic" : p) n) (contextGlobalEnv ctx)
+          ( maybeId (E.searchValueBinder (contextGlobalEnv ctx) (SymPath ("Dynamic" : p) n))
-            >>= \(Binder _ found) -> pure (ctx, Right (resolveDef found))
-        tryInternalLookup path =
-          ( contextInternalEnv ctx
-              >>= lookupBinder path
               >>= \(Binder _ found) -> pure (ctx, Right (resolveDef found))
           )
+        tryInternalLookup path =
+          --trace ("Looking for internally " ++ show path) -- ++ show (fmap (fmap E.binders . E.parent) (contextInternalEnv ctx)))
+          ( contextInternalEnv ctx
+              >>= \e ->
+                maybeId (E.searchValueBinder e path)
+                  >>= \(Binder _ found) -> pure (ctx, Right (resolveDef found))
+          )
             <|> tryLookup path -- fallback
         tryLookup path =
-          ( lookupBinder path (contextGlobalEnv ctx)
+          ( maybeId (E.searchValueBinder (contextGlobalEnv ctx) path)
               >>= \(Binder meta found) -> checkPrivate meta found
           )
-            <|> ( lookupBinder path (getTypeEnv (contextTypeEnv ctx))
+            <|> ( maybeId (E.searchValueBinder (contextGlobalEnv ctx) (SymPath ((contextPath ctx) ++ p) n))
+                    >>= \(Binder meta found) -> checkPrivate meta found
+                )
+            <|> ( maybeId (lookupBinderInTypeEnv ctx path)
                     >>= \(Binder _ found) -> pure (ctx, Right (resolveDef found))
                 )
             <|> ( foldl
@@ -111,7 +118,7 @@ eval ctx xobj@(XObj o info ty) preference resolver =
                     Nothing
                     ( map
                         ( \(SymPath p' n') ->
-                            lookupBinder (SymPath (p' ++ (n' : p)) n) (contextGlobalEnv ctx)
+                            maybeId (E.searchValueBinder (contextGlobalEnv ctx) (SymPath (p' ++ (n' : p)) n))
                               >>= \(Binder meta found) -> checkPrivate meta found
                         )
                         (Set.toList (envUseModules (contextGlobalEnv ctx)))
@@ -220,7 +227,7 @@ eval ctx xobj@(XObj o info ty) preference resolver =
                   (newCtx, res) <- eval ctx' x preference resolver
                   case res of
                     Right okX ->
-                      pure $ Right (bindLetDeclaration newCtx n okX)
+                      pure $ Right (fromRight (error "Failed to eval let binding!!") (bindLetDeclaration newCtx n okX))
                     Left err -> pure $ Left err
         [f@(XObj Fn {} _ _), args@(XObj (Arr a) _ _), body] -> do
           (newCtx, expanded) <- macroExpand ctx body
@@ -446,7 +453,7 @@ macroExpand ctx xobj =
 
 apply :: Context -> XObj -> [XObj] -> [XObj] -> IO (Context, Either EvalError XObj)
 apply ctx@Context {contextInternalEnv = internal} body params args =
-  let Just env = contextInternalEnv ctx <|> innermostModuleEnv ctx <|> Just (contextGlobalEnv ctx)
+  let Just env = contextInternalEnv ctx <|> maybeId (innermostModuleEnv ctx) <|> Just (contextGlobalEnv ctx)
       allParams = map getName params
    in case splitWhen (":rest" ==) allParams of
         [a, b] -> callWith env a b
@@ -459,18 +466,21 @@ apply ctx@Context {contextInternalEnv = internal} body params args =
           insideEnv = Env Map.empty internal Nothing Set.empty InternalEnv 0
           insideEnv' =
             foldl'
-              (\e (p, x) -> extendEnv e p (toLocalDef p x))
+              (\e (p, x) -> fromRight (error "Couldn't add local def ") (E.insertX e (SymPath [] p) (toLocalDef p x)))
               insideEnv
               (zip proper (take n args))
           insideEnv'' =
             if null rest
               then insideEnv'
               else
-                extendEnv
+                fromRight
-                  insideEnv'
+                  (error "couldn't insert into inside env")
-                  (head rest)
+                  ( E.insertX
-                  (XObj (Lst (drop n args)) Nothing Nothing)
+                      insideEnv'
-      (c, r) <- evalDynamic ResolveLocal (replaceInternalEnv ctx insideEnv'') body
+                      (SymPath [] (head rest))
+                      (XObj (Lst (drop n args)) Nothing Nothing)
+                  )
+      (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.
@@ -597,12 +607,12 @@ catcher ctx exception =
 
 specialCommandWith :: Context -> XObj -> SymPath -> [XObj] -> IO (Context, Either EvalError XObj)
 specialCommandWith ctx _ path forms = do
-  let Just env = contextInternalEnv ctx <|> innermostModuleEnv ctx <|> Just (contextGlobalEnv ctx)
+  let Just env = contextInternalEnv ctx <|> maybeId (innermostModuleEnv ctx) <|> Just (contextGlobalEnv ctx)
       useThese = envUseModules env
       env' = env {envUseModules = Set.insert path useThese}
       ctx' = replaceGlobalEnv ctx env'
   ctxAfter <- liftIO $ foldM folder ctx' forms
-  let Just envAfter = contextInternalEnv ctxAfter <|> innermostModuleEnv ctxAfter <|> Just (contextGlobalEnv ctxAfter)
+  let Just envAfter = contextInternalEnv ctxAfter <|> maybeId (innermostModuleEnv ctxAfter) <|> Just (contextGlobalEnv ctxAfter)
       -- undo ALL use:s made inside the 'with'.
       ctxAfter' = replaceGlobalEnv ctx (envAfter {envUseModules = useThese})
   pure (ctxAfter', dynamicNil)
@@ -645,7 +655,7 @@ getSigFromDefnOrDef ctx xobj =
       fullPath = case path of
         (SymPath [] _) -> consPath pathStrings path
         (SymPath _ _) -> path
-      metaData = lookupMeta fullPath globalEnv
+      metaData = either (const emptyMeta) id (E.lookupMeta globalEnv fullPath)
    in case Meta.get "sig" metaData of
         Just foundSignature ->
           case xobjToTy foundSignature of
@@ -683,39 +693,45 @@ annotateWithinContext ctx xobj = do
                     Right ok -> pure (ctx, Right ok)
 
 primitiveDefmodule :: VariadicPrimitiveCallback
-primitiveDefmodule xobj ctx@(Context env i _ pathStrings _ _ _ _) (XObj (Sym (SymPath [] moduleName) _) _ _ : innerExpressions) =
+primitiveDefmodule xobj ctx@(Context env i tenv pathStrings _ _ _ _) (XObj (Sym (SymPath [] moduleName) _) _ _ : innerExpressions) =
   -- 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}))
+  either (const (defineNewModule emptyMeta)) updateExistingModule (E.searchValueBinder ((fromRight env (E.getInnerEnv env pathStrings)) {envParent = Nothing}) (SymPath [] moduleName))
     >>= defineModuleBindings
     >>= \(newCtx, result) ->
-      case result of
+      let updater c = (c {contextInternalEnv = (E.parent =<< contextInternalEnv c)})
-        Left err -> pure (newCtx, Left err)
+       in case result of
-        Right _ -> pure (popModulePath (newCtx {contextInternalEnv = envParent =<< contextInternalEnv newCtx}), dynamicNil)
+            Left err -> pure (newCtx, Left err)
+            Right _ -> pure (updater (popModulePath newCtx), dynamicNil)
   where
+    --------------------------------------------------------------------------------
+    -- Update an existing module by modifying its environment parents and updating the current context path.
     updateExistingModule :: Binder -> IO (Context, Either EvalError XObj)
-    updateExistingModule (Binder _ (XObj (Mod innerEnv) _ _)) =
+    updateExistingModule (Binder _ (XObj (Mod innerEnv _) _ _)) =
-      let ctx' =
+      let updateContext =
-            ctx
+            replacePath' (contextPath ctx ++ [moduleName])
-              { contextInternalEnv = Just innerEnv {envParent = i},
+              . replaceInternalEnv' (innerEnv {envParent = i})
-                contextPath = contextPath ctx ++ [moduleName]
+       in pure (updateContext ctx, dynamicNil)
-              }
-       in pure (ctx', dynamicNil)
     updateExistingModule (Binder meta (XObj (Lst [XObj MetaStub _ _, _]) _ _)) =
       defineNewModule meta
     updateExistingModule _ =
       pure (throwErr (ModuleRedefinition moduleName) ctx (xobjInfo xobj))
+    --------------------------------------------------------------------------------
+    -- Define a brand new module with a context's current environments as its parents.
     defineNewModule :: MetaData -> IO (Context, Either EvalError XObj)
     defineNewModule meta =
-      pure (ctx', dynamicNil)
+      pure (fromRight ctx (updater ctx), dynamicNil)
       where
-        moduleEnv = Env (Map.fromList []) (Just (getEnv env pathStrings)) (Just moduleName) Set.empty ExternalEnv 0
+        moduleDefs = E.new (Just (fromRight env (E.getInnerEnv env pathStrings))) (Just moduleName)
-        newModule = XObj (Mod moduleEnv) (xobjInfo xobj) (Just ModuleTy)
+        moduleTypes = E.new (Just tenv) (Just moduleName)
-        updatedGlobalEnv = envInsertAt env (SymPath pathStrings moduleName) (Binder meta newModule)
+        newModule = XObj (Mod moduleDefs moduleTypes) (xobjInfo xobj) (Just ModuleTy)
-        -- The parent of the internal env needs to be set to i here for contextual `use` calls to work.
+        updater = \c ->
-        -- In theory this shouldn't be necessary; but for now it is.
+          insertInGlobalEnv' (markQualified (SymPath pathStrings moduleName)) (Binder meta newModule) c
-        ctx' = ctx {contextGlobalEnv = updatedGlobalEnv, contextInternalEnv = Just moduleEnv {envParent = i}, contextPath = contextPath ctx ++ [moduleName]}
+            >>= pure . replaceInternalEnv' (moduleDefs {envParent = i})
+            >>= pure . replacePath' (contextPath ctx ++ [moduleName])
+    --------------------------------------------------------------------------------
+    -- Define bindings for the module.
     defineModuleBindings :: (Context, Either EvalError XObj) -> IO (Context, Either EvalError XObj)
     defineModuleBindings (context, Left e) = pure (context, Left e)
     defineModuleBindings (context, _) =
@@ -725,7 +741,7 @@ primitiveDefmodule xobj ctx@(Context env i _ pathStrings _ _ _ _) (XObj (Sym (Sy
     step (ctx', Right _) expressions =
       macroExpand ctx' expressions
         >>= \(ctx'', res) -> case res of
-          Left _ -> pure (ctx'', res)
+          Left err -> pure (ctx'', Left err)
           Right r -> evalDynamic ResolveLocal ctx'' r
 primitiveDefmodule _ ctx (x : _) =
   pure (throwErr (DefmoduleContainsNonSymbol x) ctx (xobjInfo x))
@@ -1013,21 +1029,21 @@ primitiveDefdynamic _ ctx notName _ =
   pure (throwErr (DefnDynamicInvalidName notName) ctx (xobjInfo notName))
 
 specialCommandSet :: Context -> [XObj] -> IO (Context, Either EvalError XObj)
-specialCommandSet ctx [orig@(XObj (Sym path@(SymPath _ n) _) _ _), val] =
+specialCommandSet ctx [orig@(XObj (Sym path@(SymPath _ _) _) _ _), val] =
   let lookupInternal =
-        contextInternalEnv ctx
+        maybe (Left "") Right (contextInternalEnv ctx)
           >>= \e ->
-            lookupBinder path e
+            unwrapErr (E.searchValueBinder e path)
               >>= \binder -> pure (binder, setInternal, e)
       lookupGlobal =
-        Just (contextGlobalEnv ctx)
+        Right (contextGlobalEnv ctx)
           >>= \e ->
-            lookupBinder path e
+            unwrapErr (E.searchValueBinder e path)
               >>= \binder -> pure (binder, setGlobal, e)
-   in maybe
+   in either
-        (pure $ (throwErr (SetVarNotFound orig) ctx (xobjInfo orig)))
+        ((const (pure $ (throwErr (SetVarNotFound orig) ctx (xobjInfo orig)))))
         (\(binder', setter', env') -> evalAndSet binder' setter' env')
-        (lookupInternal <|> lookupGlobal)
+        (lookupInternal <> lookupGlobal)
   where
     evalAndSet :: Binder -> (Context -> Env -> Either EvalError XObj -> Binder -> IO (Context, Either EvalError XObj)) -> Env -> IO (Context, Either EvalError XObj)
     evalAndSet binder setter env =
@@ -1051,7 +1067,7 @@ specialCommandSet ctx [orig@(XObj (Sym path@(SymPath _ n) _) _ _), val] =
     setInternal ctx' env value binder =
       pure $ either (failure ctx' orig) (success ctx') value
       where
-        success c xo = (replaceInternalEnv c (setStaticOrDynamicVar (SymPath [] n) env binder xo), dynamicNil)
+        success c xo = (replaceInternalEnv c (setStaticOrDynamicVar path env binder xo), dynamicNil)
 specialCommandSet ctx [notName, _] =
   pure (throwErr (SetInvalidVarName notName) ctx (xobjInfo notName))
 specialCommandSet ctx args =
@@ -1080,14 +1096,14 @@ typeCheckValueAgainstBinder ctx val binder = do
 -- assigns an appropriate type to the variable.
 -- Returns a new environment containing the assignment.
 setStaticOrDynamicVar :: SymPath -> Env -> Binder -> XObj -> Env
-setStaticOrDynamicVar path env binder value =
+setStaticOrDynamicVar path@(SymPath _ name) env binder value =
   case binder of
     (Binder meta (XObj (Lst (def@(XObj Def _ _) : sym : _)) _ t)) ->
-      envReplaceBinding path (Binder meta (XObj (Lst [def, sym, value]) (xobjInfo value) t)) env
+      fromRight env (E.insert env path (Binder meta (XObj (Lst [def, sym, value]) (xobjInfo value) t)))
     (Binder meta (XObj (Lst (defdy@(XObj DefDynamic _ _) : sym : _)) _ _)) ->
-      envReplaceBinding path (Binder meta (XObj (Lst [defdy, sym, value]) (xobjInfo value) (Just DynamicTy))) env
+      fromRight env (E.insert env path (Binder meta (XObj (Lst [defdy, sym, value]) (xobjInfo value) (Just DynamicTy))))
     (Binder meta (XObj (Lst (lett@(XObj LocalDef _ _) : sym : _)) _ t)) ->
-      envReplaceBinding path (Binder meta (XObj (Lst [lett, sym, value]) (xobjInfo value) t)) env
+      fromRight (error "FAILED!") (E.replaceInPlace env name (Binder meta (XObj (Lst [lett, sym, value]) (xobjInfo value) t)))
     -- shouldn't happen, errors are thrown at call sites.
     -- TODO: Return an either here to propagate error.
     _ -> env

src/Expand.hs

@@ -4,7 +4,6 @@ import Control.Monad.State (State, evalState, get, put)
 import Data.Foldable (foldlM)
 import Env
 import Info
-import Lookup
 import Obj
 import TypeError
 import Types
@@ -219,7 +218,7 @@ expand eval ctx xobj =
                 ("`ref` takes a single argument, but I got `" ++ pretty xobj ++ "`.")
                 (xobjInfo xobj)
             )
-        XObj (Mod modEnv) _ _ : args ->
+        XObj (Mod modEnv _) _ _ : args ->
           let pathToModule = pathToEnv modEnv
               implicitInit = XObj (Sym (SymPath pathToModule "init") Symbol) i t
            in expand eval ctx (XObj (Lst (implicitInit : args)) (xobjInfo xobj) (xobjTy xobj))
@@ -280,15 +279,15 @@ expand eval ctx xobj =
     expandArray _ = error "Can't expand non-array in expandArray."
     expandSymbol :: XObj -> IO (Context, Either EvalError XObj)
     expandSymbol sym@(XObj (Sym path _) _ _) =
-      case lookupBinder path (contextEnv ctx) of
+      case searchValueBinder (contextEnv ctx) path of
-        Just (Binder meta (XObj (Lst (XObj (External _) _ _ : _)) _ _)) -> isPrivate meta xobj
+        Right (Binder meta (XObj (Lst (XObj (External _) _ _ : _)) _ _)) -> isPrivate meta xobj
-        Just (Binder meta (XObj (Lst (XObj (Instantiate _) _ _ : _)) _ _)) -> isPrivate meta xobj
+        Right (Binder meta (XObj (Lst (XObj (Instantiate _) _ _ : _)) _ _)) -> isPrivate meta xobj
-        Just (Binder meta (XObj (Lst (XObj (Deftemplate _) _ _ : _)) _ _)) -> isPrivate meta xobj
+        Right (Binder meta (XObj (Lst (XObj (Deftemplate _) _ _ : _)) _ _)) -> isPrivate meta xobj
-        Just (Binder meta (XObj (Lst (XObj (Defn _) _ _ : _)) _ _)) -> isPrivate meta xobj
+        Right (Binder meta (XObj (Lst (XObj (Defn _) _ _ : _)) _ _)) -> isPrivate meta xobj
-        Just (Binder meta (XObj (Lst (XObj Def _ _ : _)) _ _)) -> isPrivate meta xobj
+        Right (Binder meta (XObj (Lst (XObj Def _ _ : _)) _ _)) -> isPrivate meta xobj
-        Just (Binder meta (XObj (Lst (XObj (Defalias _) _ _ : _)) _ _)) -> isPrivate meta xobj
+        Right (Binder meta (XObj (Lst (XObj (Defalias _) _ _ : _)) _ _)) -> isPrivate meta xobj
-        Just (Binder meta found) -> isPrivate meta found -- use the found value
+        Right (Binder meta found) -> isPrivate meta found -- use the found value
-        Nothing -> pure (ctx, Right xobj) -- symbols that are not found are left as-is
+        Left _ -> pure (ctx, Right xobj) -- symbols that are not found are left as-is
       where
         isPrivate m x =
           pure $

src/GenerateConstraints.hs

@@ -272,7 +272,7 @@ genConstraints _ root rootSig = fmap sort (gen root)
                       (Sym (SymPath [] ("I inferred the type of the array from its first element " ++ show (getPath x))) Symbol)
                       (xobjInfo x)
                       (Just headTy)
-                  Just (StructTy (ConcreteNameTy "Array") [t]) = xobjTy xobj
+                  Just (StructTy (ConcreteNameTy (SymPath [] "Array")) [t]) = xobjTy xobj
                   betweenExprConstraints = zipWith (\o n -> Constraint headTy (forceTy o) headObj (genObj o n) xobj OrdArrBetween) xs [1 ..]
                   headConstraint = Constraint headTy t headObj (genObj x 1) xobj OrdArrHead
               pure (headConstraint : insideExprConstraints ++ betweenExprConstraints)
@@ -293,7 +293,7 @@ genConstraints _ root rootSig = fmap sort (gen root)
                       (Sym (SymPath [] ("I inferred the type of the static array from its first element " ++ show (getPath x))) Symbol)
                       (xobjInfo x)
                       (Just headTy)
-                  Just (RefTy (StructTy (ConcreteNameTy "StaticArray") [t]) _) = xobjTy xobj
+                  Just (RefTy (StructTy (ConcreteNameTy (SymPath [] "StaticArray")) [t]) _) = xobjTy xobj
                   betweenExprConstraints = zipWith (\o n -> Constraint headTy (forceTy o) headObj (genObj o n) xobj OrdArrBetween) xs [1 ..]
                   headConstraint = Constraint headTy t headObj (genObj x 1) xobj OrdArrHead
               pure (headConstraint : insideExprConstraints ++ betweenExprConstraints)

src/InitialTypes.hs

@@ -1,9 +1,8 @@
 module InitialTypes where
 
 import Control.Monad.State
-import Env
+import Env as E
 import Info
-import Lookup
 import qualified Map
 import Obj
 import qualified Set
@@ -99,7 +98,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
       If -> pure (Left (InvalidObj If xobj))
       While -> pure (Left (InvalidObj While xobj))
       Do -> pure (Left (InvalidObj Do xobj))
-      (Mod _) -> pure (Left (InvalidObj If xobj))
+      (Mod _ _) -> pure (Left (InvalidObj If xobj))
       e@(Deftype _) -> pure (Left (InvalidObj e xobj))
       e@(External _) -> pure (Left (InvalidObj e xobj))
       e@(ExternalType _) -> pure (Left (InvalidObj e xobj))
@@ -128,8 +127,8 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
         SymPath _ name@('?' : _) -> pure (Right (xobj {xobjTy = Just (VarTy name)}))
         SymPath _ (':' : _) -> pure (Left (LeadingColon xobj))
         _ ->
-          case lookupInEnv symPath env of
+          case E.searchValue env symPath of
-            Just (foundEnv, binder) ->
+            Right (foundEnv, binder) ->
               case xobjTy (binderXObj binder) of
                 -- Don't rename internal symbols like parameters etc!
                 Just theType
@@ -138,7 +137,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
                     pure (Right (xobj {xobjTy = Just renamed}))
                   | otherwise -> pure (Right (xobj {xobjTy = Just theType}))
                 Nothing -> pure (Left (SymbolMissingType xobj foundEnv))
-            Nothing -> pure (Left (SymbolNotDefined symPath xobj env)) -- Gives the error message "Trying to refer to an undefined symbol ..."
+            Left _ -> pure (Left (SymbolNotDefined symPath xobj env)) -- Gives the error message "Trying to refer to an undefined symbol ..."
     visitMultiSym :: Env -> XObj -> [SymPath] -> State Integer (Either TypeError XObj)
     visitMultiSym _ xobj@(XObj (MultiSym _ _) _ _) _ =
       do
@@ -148,10 +147,10 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
     visitInterfaceSym :: Env -> XObj -> State Integer (Either TypeError XObj)
     visitInterfaceSym _ xobj@(XObj (InterfaceSym name) _ _) =
       do
-        freshTy <- case lookupBinder (SymPath [] name) (getTypeEnv typeEnv) of
+        freshTy <- case getTypeBinder typeEnv name of
-          Just (Binder _ (XObj (Lst [XObj (Interface interfaceSignature _) _ _, _]) _ _)) -> renameVarTys interfaceSignature
+          Right (Binder _ (XObj (Lst [XObj (Interface interfaceSignature _) _ _, _]) _ _)) -> renameVarTys interfaceSignature
-          Just (Binder _ x) -> error ("A non-interface named '" ++ name ++ "' was found in the type environment: " ++ pretty x)
+          Right (Binder _ x) -> error ("A non-interface named '" ++ name ++ "' was found in the type environment: " ++ pretty x)
-          Nothing -> genVarTy
+          Left _ -> genVarTy
         pure (Right xobj {xobjTy = Just freshTy})
     visitInterfaceSym _ _ = error "visitinterfacesym"
     visitArray :: Env -> XObj -> State Integer (Either TypeError XObj)
@@ -161,7 +160,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
         arrayVarTy <- genVarTy
         pure $ do
           okVisited <- sequence visited
-          Right (XObj (Arr okVisited) i (Just (StructTy (ConcreteNameTy "Array") [arrayVarTy])))
+          Right (XObj (Arr okVisited) i (Just (StructTy (ConcreteNameTy (SymPath [] "Array")) [arrayVarTy])))
     visitArray _ _ = error "The function 'visitArray' only accepts XObj:s with arrays in them."
     visitStaticArray :: Env -> XObj -> State Integer (Either TypeError XObj)
     visitStaticArray env (XObj (StaticArr xobjs) i _) =
@@ -171,7 +170,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
         lt <- genVarTy
         pure $ do
           okVisited <- sequence visited
-          Right (XObj (StaticArr okVisited) i (Just (RefTy (StructTy (ConcreteNameTy "StaticArray") [arrayVarTy]) lt)))
+          Right (XObj (StaticArr okVisited) i (Just (RefTy (StructTy (ConcreteNameTy (SymPath [] "StaticArray")) [arrayVarTy]) lt)))
     visitStaticArray _ _ = error "The function 'visitStaticArray' only accepts XObj:s with arrays in them."
     visitDictionary :: Env -> XObj -> State Integer (Either TypeError XObj)
     visitDictionary env (XObj (Dict xobjs) i _) =
@@ -180,7 +179,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
         arrayVarTy <- genVarTy
         pure $ do
           okVisited <- sequence visited
-          Right (XObj (Dict okVisited) i (Just (StructTy (ConcreteNameTy "Dictionary") [arrayVarTy])))
+          Right (XObj (Dict okVisited) i (Just (StructTy (ConcreteNameTy (SymPath [] "Dictionary")) [arrayVarTy])))
     visitDictionary _ _ = error "The function 'visitArray' only accepts XObj:s with dictionaries in them."
     getTys env argList =
       do
@@ -198,7 +197,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
             let funcTy = Just (FuncTy argTypes returnType StaticLifetimeTy)
                 typedNameSymbol = nameSymbol {xobjTy = funcTy}
                 -- TODO! After the introduction of 'LookupRecursive' this env shouldn't be needed anymore? (but it is for some reason...)
-                envWithSelf = extendEnv funcScopeEnv name typedNameSymbol
+                Right envWithSelf = E.insertX funcScopeEnv (SymPath [] name) typedNameSymbol
             visitedBody <- visit envWithSelf body
             visitedArgs <- mapM (visit envWithSelf) argList
             pure $ do
@@ -440,15 +439,18 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
                 (Sym (SymPath _ name) _) ->
                   do
                     visited <- visit env' expr
-                    pure (envAddBinding env' name . Binder emptyMeta <$> visited)
+                    pure
+                      ( join
+                          (replaceLeft (InvalidLetBinding xobjs (sym, expr)) . E.insert env' (SymPath [] name) . Binder emptyMeta <$> visited)
+                      )
                 _ -> pure (Left (InvalidLetBinding xobjs (sym, expr)))
     extendEnvWithParamList :: Env -> [XObj] -> State Integer Env
     extendEnvWithParamList env xobjs =
       do
-        binders <- mapM createBinderForParam xobjs
+        binders' <- mapM createBinderForParam xobjs
         pure
           Env
-            { envBindings = Map.fromList binders,
+            { envBindings = Map.fromList binders',
               envParent = Just env,
               envModuleName = Nothing,
               envUseModules = Set.empty,
@@ -468,10 +470,10 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
     extendEnvWithCaseMatch :: Env -> XObj -> State Integer Env
     extendEnvWithCaseMatch env caseRoot =
       do
-        binders <- createBindersForCaseVariable caseRoot
+        binders' <- createBindersForCaseVariable caseRoot
         pure
           Env
-            { envBindings = Map.fromList binders,
+            { envBindings = Map.fromList binders',
               envParent = Just env,
               envModuleName = Nothing,
               envUseModules = Set.empty,
@@ -484,8 +486,8 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
         createBindersForCaseVariable xobj@(XObj (MultiSym name _) _ _) = createBinderInternal xobj name
         createBindersForCaseVariable xobj@(XObj (InterfaceSym name) _ _) = createBinderInternal xobj name
         createBindersForCaseVariable (XObj (Lst lst) _ _) = do
-          binders <- mapM createBindersForCaseVariable lst
+          binders' <- mapM createBindersForCaseVariable lst
-          pure (concat binders)
+          pure (concat binders')
         createBindersForCaseVariable (XObj Ref _ _) = pure []
         createBindersForCaseVariable x = error ("Can't create binder for non-symbol in 'case' variable match:" ++ show x) -- TODO: Should use proper error mechanism
         createBinderInternal :: XObj -> String -> State Integer [(String, Binder)]

src/Interfaces.hs

@@ -14,12 +14,13 @@ where
 
 import ColorText
 import Constraints
+import Context
+import Data.Either (fromRight, rights)
 import Data.List (delete, deleteBy, foldl')
-import Data.Maybe (fromMaybe, mapMaybe)
+import qualified Env
-import Env
-import Lookup
 import qualified Meta
 import Obj
+import qualified Qualify
 import Types
 import Util
 
@@ -67,7 +68,7 @@ instance Show InterfaceError where
 -- | Get the first path of an interface implementation that matches a given type signature
 getFirstMatchingImplementation :: Context -> [SymPath] -> Ty -> Maybe SymPath
 getFirstMatchingImplementation ctx paths ty =
-  case filter predicate (mapMaybe (`lookupBinder` global) paths) of
+  case filter predicate (rights (map (global `Env.searchValueBinder`) paths)) of
     [] -> Nothing
     (x : _) -> Just ((getPath . binderXObj) x)
   where
@@ -77,53 +78,51 @@ getFirstMatchingImplementation ctx paths ty =
 -- | Remove an interface from a binder's list of implemented interfaces
 removeInterfaceFromImplements :: SymPath -> XObj -> Context -> Context
 removeInterfaceFromImplements oldImplPath interface ctx =
-  fromMaybe
+  fromRight
     ctx
-    ( lookupBinder oldImplPath (contextGlobalEnv ctx)
+    ( lookupBinderInGlobalEnv ctx (Qualify.markQualified oldImplPath)
         >>= \binder ->
-          Meta.getBinderMetaValue "implements" binder
+          pure
-            >>= ( \x ->
+            ( case Meta.getBinderMetaValue "implements" binder of
-                    case x of
+                Just (XObj (Lst impls) i t) -> Meta.updateBinderMeta binder "implements" (XObj (Lst (deleteBy matchPath interface impls)) i t)
-                      (XObj (Lst impls) i t) ->
+                _ -> binder
-                        pure $ Meta.updateBinderMeta binder "implements" (XObj (Lst (deleteBy matchPath interface impls)) i t)
+            )
-                      _ -> Nothing
+            >>= insertInGlobalEnv ctx (Qualify.markQualified oldImplPath)
-                )
-            >>= (\b -> pure $ ctx {contextGlobalEnv = envInsertAt (contextGlobalEnv ctx) oldImplPath b})
     )
   where
     matchPath xobj xobj' = getPath xobj == getPath xobj'
 
 -- TODO: This is currently called once outside of this module--try to remove that call and make this internal.
 -- Checks whether a given form's type matches an interface, and if so, registers the form with the interface.
-registerInInterfaceIfNeeded :: Context -> Binder -> Binder -> Ty -> (Context, Maybe InterfaceError)
+registerInInterfaceIfNeeded :: Context -> Binder -> Binder -> Ty -> (Either ContextError Context, Maybe InterfaceError)
 registerInInterfaceIfNeeded ctx implementation interface definitionSignature =
   case interface of
     Binder _ (XObj (Lst [inter@(XObj (Interface interfaceSignature paths) ii it), isym]) i t) ->
       if checkKinds interfaceSignature definitionSignature
         then case solve [Constraint interfaceSignature definitionSignature inter inter inter OrdInterfaceImpl] of
-          Left _ -> (ctx, Just (TypeMismatch implPath definitionSignature interfaceSignature))
+          Left _ -> (Right ctx, Just (TypeMismatch implPath definitionSignature interfaceSignature))
           Right _ -> case getFirstMatchingImplementation ctx paths definitionSignature of
             Nothing -> (updatedCtx, Nothing)
             Just x ->
               if x == implPath
                 then (updatedCtx, Nothing)
                 else (implReplacedCtx x, Just (AlreadyImplemented ipath x implPath definitionSignature))
-        else (ctx, Just (KindMismatch implPath definitionSignature interfaceSignature))
+        else (Right ctx, Just (KindMismatch implPath definitionSignature interfaceSignature))
       where
+        qpath = (Qualify.markQualified (SymPath [] name))
         updatedInterface = XObj (Lst [XObj (Interface interfaceSignature (addIfNotPresent implPath paths)) ii it, isym]) i t
-        updatedCtx = ctx {contextTypeEnv = TypeEnv (extendEnv typeEnv name updatedInterface)}
+        updatedCtx = replaceTypeBinder ctx qpath (toBinder updatedInterface)
         implReplacedInterface x = XObj (Lst [XObj (Interface interfaceSignature (addIfNotPresent implPath (delete x paths))) ii it, isym]) i t
-        implReplacedCtx x = ctx {contextTypeEnv = TypeEnv (extendEnv typeEnv name (implReplacedInterface x))}
+        implReplacedCtx x = replaceTypeBinder ctx qpath (toBinder (implReplacedInterface x))
     _ ->
-      (ctx, Just (NonInterface (getBinderPath interface)))
+      (Right ctx, Just (NonInterface (getBinderPath interface)))
   where
     implPath = getBinderPath implementation
-    typeEnv = getTypeEnv (contextTypeEnv ctx)
     ipath@(SymPath _ name) = getBinderPath interface
 
 -- | Given a binder and an interface path, ensure that the form is
 -- registered with the interface.
-registerInInterface :: Context -> Binder -> Binder -> (Context, Maybe InterfaceError)
+registerInInterface :: Context -> Binder -> Binder -> (Either ContextError Context, Maybe InterfaceError)
 registerInInterface ctx implementation interface =
   case binderXObj implementation of
     XObj (Lst [XObj (Defn _) _ _, _, _, _]) _ (Just t) ->
@@ -141,26 +140,26 @@ registerInInterface ctx implementation interface =
     -- And instantiated/auto-derived type functions! (e.g. Pair.a)
     XObj (Lst [XObj (Instantiate _) _ _, _]) _ (Just t) ->
       registerInInterfaceIfNeeded ctx implementation interface t
-    _ -> (ctx, Nothing)
+    _ -> (Right ctx, Nothing)
 
 -- | For forms that were declared as implementations of interfaces that didn't exist,
 -- retroactively register those forms with the interface once its defined.
-retroactivelyRegisterInInterface :: Context -> Binder -> Context
+retroactivelyRegisterInInterface :: Context -> Binder -> Either ContextError Context
 retroactivelyRegisterInInterface ctx interface =
   -- TODO: Propagate error
   maybe resultCtx (error . show) err
   where
     env = contextGlobalEnv ctx
-    impls = lookupMany Everywhere lookupImplementations (getPath (binderXObj interface)) env
+    impls = concat (rights (fmap ((flip Env.findImplementations) (getPath (binderXObj interface))) (env : (Env.lookupChildren env))))
-    (resultCtx, err) = foldl' (\(context, _) binder -> registerInInterface context binder interface) (ctx, Nothing) impls
+    (resultCtx, err) = foldl' (\(Right context, _) binder -> registerInInterface context binder interface) (Right ctx, Nothing) impls
 
 -- | Checks whether an interface is implemented for a certain type signature,
 -- | e.g. Is "delete" implemented for `(Fn [String] ())` ?
 interfaceImplementedForTy :: TypeEnv -> Env -> String -> Ty -> Bool
-interfaceImplementedForTy (TypeEnv typeEnv) globalEnv interfaceName matchingTy =
+interfaceImplementedForTy typeEnv globalEnv interfaceName matchingTy =
-  case lookupBinder (SymPath [] interfaceName) typeEnv of
+  case Env.getTypeBinder typeEnv interfaceName of
-    Just (Binder _ (XObj (Lst (XObj (Interface _ paths) _ _ : _)) _ _)) ->
+    Right (Binder _ (XObj (Lst (XObj (Interface _ paths) _ _ : _)) _ _)) ->
-      let lookupType path = forceTy . binderXObj <$> lookupBinder path globalEnv
+      let lookupType' path = forceTy . binderXObj <$> (Env.searchValueBinder globalEnv path)
-          matches = filter (areUnifiable matchingTy) (mapMaybe lookupType paths)
+          matches = filter (areUnifiable matchingTy) (rights (map lookupType' paths))
        in not . null $ matches
     _ -> False

src/Lookup.hs

@@ -1,143 +0,0 @@
-module Lookup where
-
-import Data.Maybe (catMaybes, mapMaybe)
-import Env
-import qualified Map
-import qualified Meta
-import Obj
-import qualified Set
-import Types
-
--- | The type of generic lookup functions.
-type LookupFunc a b = a -> Env -> [b]
-
--- | Find the Binder at a specified path.
-lookupInEnv :: SymPath -> Env -> Maybe (Env, Binder)
-lookupInEnv (SymPath [] name) env =
-  case Map.lookup name (envBindings env) of
-    Just found -> Just (env, found)
-    Nothing -> case envParent env of
-      Just parent -> lookupInEnv (SymPath [] name) parent
-      Nothing -> Nothing
-lookupInEnv path@(SymPath (p : ps) name) env =
-  case Map.lookup p (envBindings env) of
-    Just (Binder _ xobj) ->
-      case xobj of
-        (XObj (Mod modEnv) _ _) -> lookupInEnv (SymPath ps name) modEnv
-        _ -> Nothing
-    Nothing ->
-      case envParent env of
-        Just parent -> lookupInEnv path parent
-        Nothing -> Nothing
-
--- | Performs a multiLookupEverywhere but drops envs from the result and wraps
--- the results in a Maybe.
-multiLookupBinderEverywhere :: Context -> SymPath -> Maybe [Binder]
-multiLookupBinderEverywhere ctx (SymPath _ name) =
-  case map snd (multiLookupEverywhere name (contextEnv ctx)) of
-    [] -> Nothing
-    xs -> Just xs
-
--- | Like 'lookupInEnv' but only returns the Binder (no Env)
-lookupBinder :: SymPath -> Env -> Maybe Binder
-lookupBinder path env = snd <$> lookupInEnv path env
-
--- | Like 'lookupBinder' but return the Meta for the binder, or a default empty meta.
-lookupMeta :: SymPath -> Env -> MetaData
-lookupMeta path globalEnv =
-  maybe emptyMeta Meta.fromBinder (lookupBinder path globalEnv)
-
--- | Get the Env stored in a binder, if any.
-envFromBinder :: Binder -> Maybe Env
-envFromBinder (Binder _ (XObj (Mod e) _ _)) = Just e
-envFromBinder _ = Nothing
-
--- | Given an environment, returns the list of all environments of binders from
--- imported modules.
-importedEnvs :: Env -> [Env]
-importedEnvs env =
-  catMaybes $ mapMaybe (\path -> fmap envFromBinder (lookupBinder path env)) (Set.toList (envUseModules env))
-
--- | Given an environment, returns the list of all environments of its binders.
-allEnvs :: Env -> [Env]
-allEnvs env =
-  let envs = mapMaybe (envFromBinder . snd) (Map.toList (envBindings env))
-   in envs ++ concatMap allEnvs envs
-
-data LookWhere = Everywhere | OnlyImports
-
-getEnvs :: LookWhere -> Env -> [Env]
-getEnvs Everywhere = allEnvs
-getEnvs OnlyImports = importedEnvs
-
--- | Given an environment, use a lookup function to recursively find all binders
--- in the environment that satisfy the lookup.
-lookupMany :: LookWhere -> LookupFunc a b -> a -> Env -> [b]
-lookupMany lookWhere lookf input env =
-  let spine = lookf input env
-      leaves = concatMap (lookf input) (getEnvs lookWhere env)
-      above = case envParent env of
-        Just parent -> lookupMany lookWhere lookf input parent
-        Nothing -> []
-   in spine ++ leaves ++ above
-
--- | Lookup binders by name in a single Env (no recursion),
-lookupByName :: String -> Env -> [(Env, Binder)]
-lookupByName name env =
-  let filtered = Map.filterWithKey (\k _ -> k == name) (envBindings env)
-   in map ((,) env . snd) (Map.toList filtered)
-
--- | Lookup binders that have specified metadata.
-lookupByMeta :: String -> Env -> [Binder]
-lookupByMeta key env =
-  let filtered = Map.filter hasMeta (envBindings env)
-   in map snd $ Map.toList filtered
-  where
-    hasMeta b = Meta.binderMember key b
-
--- | Given an interface, lookup all binders that implement the interface.
-lookupImplementations :: SymPath -> Env -> [Binder]
-lookupImplementations interface env =
-  let binders = lookupByMeta "implements" env
-   in filter isImpl binders
-  where
-    isImpl (Binder meta _) =
-      case Meta.get "implements" meta of
-        Just (XObj (Lst interfaces) _ _) -> interface `elem` map getPath interfaces
-        _ -> False
-
--- | Find the possible (imported) symbols that could be referred to by a name.
-multiLookupImports :: String -> Env -> [(Env, Binder)]
-multiLookupImports = lookupMany OnlyImports lookupByName
-
--- | Find all symbols with a certain name, in *all* environments.
-multiLookupEverywhere :: String -> Env -> [(Env, Binder)]
-multiLookupEverywhere = lookupMany Everywhere lookupByName
-
--- | Enables look up "semi qualified" (and fully qualified) symbols.
--- | i.e. if there are nested environments with a function A.B.f
--- | you can find it by doing "(use A)" and then "(B.f)".
-multiLookupQualified :: SymPath -> Env -> [(Env, Binder)]
-multiLookupQualified (SymPath [] name) rootEnv =
-  -- This case is just like normal multiLookup, we have a name but no qualifyers:
-  multiLookupImports name rootEnv
-multiLookupQualified path@(SymPath (p : _) _) rootEnv =
-  case lookupInEnv (SymPath [] p) rootEnv of
-    Just (_, Binder _ (XObj (Mod _) _ _)) ->
-      -- Found a module with the correct name, that means we should not look at anything else:
-      case lookupInEnv path rootEnv of
-        Just found -> [found]
-        Nothing -> []
-    Just _ -> inexactMatch
-    Nothing -> inexactMatch
-  where
-    inexactMatch =
-      -- No exact match on the first qualifier, will look in various places for a match:
-      let fromParent = case envParent rootEnv of
-            Just parent -> multiLookupQualified path parent
-            Nothing -> []
-          fromUsedModules =
-            let usedModules = envUseModules rootEnv
-                envs = catMaybes $ mapMaybe (\path' -> fmap envFromBinder (lookupBinder path' rootEnv)) (Set.toList usedModules)
-             in concatMap (multiLookupQualified path) envs
-       in fromParent ++ fromUsedModules

src/Map.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
@@ -18,7 +19,7 @@ fromList :: Ord k => [(k, v)] -> Map k v
 fromList = Map . M.fromList
 
 lookup :: Ord k => k -> Map k v -> Maybe v
-lookup k (Map m) = M.lookup k m
+lookup !k (Map !m) = M.lookup k m
 
 member :: Ord k => k -> Map k v -> Bool
 member k (Map m) = M.member k m
@@ -46,3 +47,12 @@ union (Map m) (Map m') = (Map (M.union m m'))
 
 assocs :: Map k a -> [(k, a)]
 assocs (Map m) = M.assocs m
+
+elems :: Map k a -> [a]
+elems (Map m) = M.elems m
+
+adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a
+adjust f k (Map m) = (Map (M.adjust f k m))
+
+delete :: Ord k => k -> Map k a -> Map k a
+delete k (Map m) = (Map (M.delete k m))

src/Obj.hs

@@ -149,7 +149,7 @@ data Obj
   | Break
   | If
   | Match MatchMode
-  | Mod Env
+  | Mod Env TypeEnv
   | Deftype Ty
   | DefSumtype Ty
   | With
@@ -342,7 +342,7 @@ getBinderDescription (XObj (Lst (XObj MetaStub _ _ : XObj (Sym _ _) _ _ : _)) _
 getBinderDescription (XObj (Lst (XObj (Deftype _) _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "deftype"
 getBinderDescription (XObj (Lst (XObj (DefSumtype _) _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "deftype"
 getBinderDescription (XObj (Lst (XObj (Interface _ _) _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "interface"
-getBinderDescription (XObj (Mod _) _ _) = "module"
+getBinderDescription (XObj (Mod _ _) _ _) = "module"
 getBinderDescription b = error ("Unhandled binder: " ++ show b)
 
 getName :: XObj -> String
@@ -384,7 +384,7 @@ getPath (XObj (Lst (XObj (External _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = p
 getPath (XObj (Lst (XObj (ExternalType _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
 getPath (XObj (Lst (XObj MetaStub _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
 getPath (XObj (Lst (XObj (Deftype _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
-getPath (XObj (Lst (XObj (Mod _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
+getPath (XObj (Lst (XObj (Mod _ _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
 getPath (XObj (Lst (XObj (Interface _ _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
 getPath (XObj (Lst (XObj (Command _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
 getPath (XObj (Lst (XObj (Primitive _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
@@ -449,7 +449,7 @@ pretty = visit 0
         Do -> "do"
         Let -> "let"
         LocalDef -> "local-binding"
-        Mod env -> fromMaybe "module" (envModuleName env)
+        Mod env _ -> fromMaybe "module" (envModuleName env)
         Deftype _ -> "deftype"
         DefSumtype _ -> "deftype"
         Deftemplate _ -> "deftemplate"
@@ -515,7 +515,7 @@ prettyUpTo lim xobj =
         Do -> ""
         Let -> ""
         LocalDef -> ""
-        Mod _ -> ""
+        Mod _ _ -> ""
         Deftype _ -> ""
         DefSumtype _ -> ""
         Deftemplate _ -> ""
@@ -643,10 +643,12 @@ forceShowBinder :: Binder -> String
 forceShowBinder binder = showBinderIndented 0 True (getName (binderXObj binder), binder)
 
 showBinderIndented :: Int -> Bool -> (String, Binder) -> String
-showBinderIndented indent _ (name, Binder _ (XObj (Mod env) _ _)) =
+showBinderIndented indent _ (name, Binder _ (XObj (Mod env tenv) _ _)) =
   replicate indent ' ' ++ name ++ " : Module = {\n"
     ++ prettyEnvironmentIndented (indent + 4) env
     ++ "\n"
+    ++ prettyEnvironmentIndented (indent + 4) (getTypeEnv tenv)
+    ++ "\n"
     ++ replicate indent ' '
     ++ "}"
 showBinderIndented indent _ (name, Binder _ (XObj (Lst [XObj (Interface t paths) _ _, _]) _ _)) =
@@ -717,7 +719,7 @@ instance Hashable ClosureContext
 instance Eq ClosureContext where
   _ == _ = True
 
-newtype TypeEnv = TypeEnv {getTypeEnv :: Env} deriving (Generic)
+newtype TypeEnv = TypeEnv {getTypeEnv :: Env} deriving (Generic, Eq)
 
 instance Hashable TypeEnv
 
@@ -798,9 +800,9 @@ xobjToTy (XObj (Sym (SymPath _ "Pattern") _) _ _) = Just PatternTy
 xobjToTy (XObj (Sym (SymPath _ "Char") _) _ _) = Just CharTy
 xobjToTy (XObj (Sym (SymPath _ "Bool") _) _ _) = Just BoolTy
 xobjToTy (XObj (Sym (SymPath _ "Static") _) _ _) = Just StaticLifetimeTy
-xobjToTy (XObj (Sym (SymPath prefixes s@(firstLetter : _)) _) _ _)
+xobjToTy (XObj (Sym spath@(SymPath _ s@(firstLetter : _)) _) _ _)
   | isLower firstLetter = Just (VarTy s)
-  | otherwise = Just (StructTy (ConcreteNameTy (createStructName prefixes s)) [])
+  | otherwise = Just (StructTy (ConcreteNameTy spath) [])
 xobjToTy (XObj (Lst [XObj (Sym (SymPath _ "Ptr") _) _ _, innerTy]) _ _) =
   do
     okInnerTy <- xobjToTy innerTy
@@ -945,10 +947,10 @@ defineFunctionTypeAlias :: Ty -> XObj
 defineFunctionTypeAlias aliasTy = defineTypeAlias (tyToC aliasTy) aliasTy
 
 defineArrayTypeAlias :: Ty -> XObj
-defineArrayTypeAlias t = defineTypeAlias (tyToC t) (StructTy (ConcreteNameTy "Array") [])
+defineArrayTypeAlias t = defineTypeAlias (tyToC t) (StructTy (ConcreteNameTy (SymPath [] "Array")) [])
 
 defineStaticArrayTypeAlias :: Ty -> XObj
-defineStaticArrayTypeAlias t = defineTypeAlias (tyToC t) (StructTy (ConcreteNameTy "Array") [])
+defineStaticArrayTypeAlias t = defineTypeAlias (tyToC t) (StructTy (ConcreteNameTy (SymPath [] "Array")) [])
 
 -- |
 defineInterface :: String -> Ty -> [SymPath] -> Maybe Info -> XObj

src/Polymorphism.hs

@@ -1,24 +1,30 @@
-module Polymorphism where
+module Polymorphism
+  ( nameOfPolymorphicFunction,
+  )
+where
 
-import Lookup
+import Env as E
 import Obj
 import Types
 
 -- | Calculate the full, mangled name of a concretized polymorphic function.
--- | For example, The 'id' in "(id 3)" will become 'id__int'.
+-- For example, The 'id' in "(id 3)" will become 'id__int'.
--- | This function uses the 'multiLookupALL' function which gives it acces to
+--
--- | modules that are not imported. This allows it to access 'delete' functions
+-- This function uses findPoly, which gives it access to *all* possible
--- | and similar for internal use.
+-- environments in the given input environment (children, (modules) parents,
-
+-- and use modules). This allows it to derive the correct name for functions
--- | TODO: Environments are passed in different order here!!!
+-- that may be defined in a different environment.
+--
+-- TODO: Environments are passed in different order here!!!
 nameOfPolymorphicFunction :: TypeEnv -> Env -> Ty -> String -> Maybe SymPath
 nameOfPolymorphicFunction _ env functionType functionName =
-  let foundBinders = multiLookupEverywhere functionName env
+  let foundBinder =
-   in case filter ((\(Just t') -> areUnifiable functionType t') . xobjTy . binderXObj . snd) foundBinders of
+        (E.findPoly env functionName functionType)
-        [] -> Nothing
+          <> (E.findPoly (progenitor env) functionName functionType)
-        [(_, Binder _ (XObj (Lst (XObj (External (Just name)) _ _ : _)) _ _))] ->
+   in case foundBinder of
+        Right (_, (Binder _ (XObj (Lst (XObj (External (Just name)) _ _ : _)) _ _))) ->
           Just (SymPath [] name)
-        [(_, Binder _ single)] ->
+        Right (_, (Binder _ single)) ->
           let Just t' = xobjTy single
               (SymPath pathStrings name) = getPath single
               suffix = polymorphicSuffix t' functionType

src/PrimitiveError.hs

@@ -11,6 +11,14 @@ data PrimitiveError
   | ForewardImplementsMeta
   | RegisterTypeError
   | SymbolNotFoundError SymPath
+  | BadDeftypeMembers
+  | QualifiedTypeMember [XObj]
+  | InvalidTypeName XObj
+  | InvalidTypeVariables XObj
+  | MetaSetFailed XObj String
+  | StructNotFound XObj
+  | NonTypeInTypeEnv SymPath XObj
+  | InvalidSumtypeCase XObj
 
 data PrimitiveWarning
   = NonExistentInterfaceWarning XObj
@@ -40,6 +48,32 @@ instance Show PrimitiveError where
       ++ "  (register-type Name c-name [field0 Type, ...]"
   show (SymbolNotFoundError path) =
     "I can’t find the symbol `" ++ show path ++ "`"
+  show (BadDeftypeMembers) =
+    "All fields must have a name and a type."
+      ++ "Example:\n"
+      ++ "```(deftype Name [field1 Type1, field2 Type2, field3 Type3])```\n"
+  show (QualifiedTypeMember xobjs) =
+    "Type members must be unqualified symbols, but got `"
+      ++ concatMap pretty xobjs
+      ++ "`"
+  show (InvalidTypeName xobj) =
+    ("Invalid name for type definition: " ++ pretty xobj)
+  show (InvalidTypeVariables xobj) =
+    ("Invalid type variables for type definition: " ++ pretty xobj)
+  show (MetaSetFailed xobj e) =
+    "`meta-set!` failed on `" ++ pretty xobj
+      ++ "` "
+      ++ show e
+  show (StructNotFound xobj) =
+    "Couldn't find a type named '" ++ (show (getPath xobj))
+      ++ "' in the type environment."
+  show (NonTypeInTypeEnv path xobj) =
+    "Can't get members for: " ++ show path
+      ++ " found a non-type in the type environment: "
+      ++ (pretty xobj)
+  show (PrimitiveError.InvalidSumtypeCase xobj) =
+    "Can't get members for an invalid sumtype case: "
+      ++ pretty xobj
 
 instance Show PrimitiveWarning where
   show (NonExistentInterfaceWarning x) =

src/Primitives.hs

@@ -8,27 +8,26 @@ import Context
 import Control.Applicative
 import Control.Monad (foldM, unless, when)
 import Control.Monad.IO.Class (MonadIO, liftIO)
-import Data.Either (rights)
+import Data.Bifunctor
+import Data.Either (fromRight, rights)
 import Data.Functor ((<&>))
 import Data.List (foldl')
-import Data.Maybe (fromJust, fromMaybe, mapMaybe)
+import Data.Maybe (fromJust, fromMaybe)
 import Deftype
 import Emit
-import Env
+import Env (addUsePath, contextEnv, insert, lookupBinderEverywhere, lookupEverywhere, lookupMeta, searchValueBinder)
 import Infer
 import Info
 import Interfaces
-import Lookup
 import Managed
-import qualified Map
 import qualified Meta
 import Obj
 import PrimitiveError
 import Project
-import Qualify (Qualified (..), getQualifiedPath, markQualified, qualify, qualifyNull, qualifyPath, unqualify)
+import Qualify (Qualified (..), QualifiedPath, getQualifiedPath, markQualified, qualify, qualifyNull, qualifyPath, unqualify)
 import Reify
-import qualified Set
 import Sumtypes
+import SymPath
 import Template
 import ToTemplate
 import TypeError
@@ -122,10 +121,10 @@ primitiveImplements _ ctx x@(XObj (Sym interface@(SymPath _ _) _) _ _) (XObj (Sy
   do
     (maybeInterface, maybeImpl) <- pure (lookupInterface ctx interface, lookupBinderInGlobalEnv ctx qpath)
     case (maybeInterface, maybeImpl) of
-      (_, Nothing) -> updateMeta (Meta.stub (contextualize path ctx)) ctx
+      (_, Left _) -> updateMeta (Meta.stub (contextualize path ctx)) ctx
-      (Nothing, Just implBinder) ->
+      (Left _, Right implBinder) ->
         warn >> updateMeta implBinder ctx
-      (Just interfaceBinder, Just implBinder) ->
+      (Right interfaceBinder, Right implBinder) ->
         -- N.B. The found binding will be fully qualified!
         addToInterface interfaceBinder implBinder
   where
@@ -134,7 +133,7 @@ primitiveImplements _ ctx x@(XObj (Sym interface@(SymPath _ _) _) _ _) (XObj (Sy
     warn = emitWarning (show (NonExistentInterfaceWarning x))
     addToInterface :: Binder -> Binder -> IO (Context, Either EvalError XObj)
     addToInterface inter impl =
-      let (newCtx, maybeErr) = registerInInterface ctx impl inter
+      let (Right newCtx, maybeErr) = registerInInterface ctx impl inter
        in maybe (updateMeta impl newCtx) (handleError newCtx impl) maybeErr
     handleError :: Context -> Binder -> InterfaceError -> IO (Context, Either EvalError XObj)
     handleError context impl e@(AlreadyImplemented _ oldImplPath _ _) =
@@ -143,9 +142,9 @@ primitiveImplements _ ctx x@(XObj (Sym interface@(SymPath _ _) _) _ _) (XObj (Sy
       emitError (show e) >> pure (evalError context (show e) (xobjInfo x))
     updateMeta :: Binder -> Context -> IO (Context, Either EvalError XObj)
     updateMeta binder context =
-      pure (fromJust update, dynamicNil)
+      pure (fromRight (error "Couldn't insert updated meta!!") (fromJust updater), dynamicNil)
       where
-        update =
+        updater =
           ( ( Meta.getBinderMetaValue "implements" binder
                 <&> updateImplementations binder
             )
@@ -178,20 +177,22 @@ define hidden ctx qualifiedXObj =
     freshBinder = toBinder annXObj
     qpath = getQualifiedPath qualifiedXObj
     defineInTypeEnv :: Binder -> IO Context
-    defineInTypeEnv = pure . (insertInTypeEnv ctx qpath)
+    defineInTypeEnv = pure . fromRight ctx . (insertTypeBinder ctx qpath)
     defineInGlobalEnv :: Binder -> IO Context
     defineInGlobalEnv newBinder =
       when (projectEchoC (contextProj ctx)) (putStrLn (toC All (Binder emptyMeta annXObj)))
         >> case (lookupBinderInGlobalEnv ctx qpath) of
-          Nothing -> pure (insertInGlobalEnv ctx qpath newBinder)
+          Left _ -> pure (fromRight ctx (insertInGlobalEnv ctx qpath newBinder))
-          Just oldBinder -> redefineExistingBinder oldBinder newBinder
+          Right oldBinder -> redefineExistingBinder oldBinder newBinder
     redefineExistingBinder :: Binder -> Binder -> IO Context
     redefineExistingBinder old@(Binder meta _) (Binder _ x) =
       do
-        warnTypeChange old
+        unless (isInstantiation (binderXObj old)) (warnTypeChange old)
         -- TODO: Merge meta more elegantly.
         updatedContext <- (implementInterfaces (Binder meta x))
-        pure (insertInGlobalEnv updatedContext qpath (Binder meta x))
+        pure (fromRight (error ("Failed to insert " ++ show qpath)) (insertInGlobalEnv updatedContext qpath (Binder meta x)))
+    isInstantiation (XObj (Lst (XObj (Instantiate _) _ _ : _)) _ _) = True
+    isInstantiation _ = False
     warnTypeChange :: Binder -> IO ()
     warnTypeChange binder =
       unless (areUnifiable (forceTy annXObj) previousType) warn
@@ -208,9 +209,9 @@ define hidden ctx qualifiedXObj =
             >>= \(XObj (Lst interfaces) _ _) -> pure (map Qualified interfaces)
         )
         >>= \maybeinterfaces ->
-          pure (mapMaybe (lookupBinderInTypeEnv ctx . getQualifiedPath) (fromMaybe [] maybeinterfaces))
+          pure (rights (fmap (lookupBinderInTypeEnv ctx . getQualifiedPath) (fromMaybe [] maybeinterfaces)))
             >>= \interfaceBinders ->
-              pure (foldl' (\(ctx', _) interface -> registerInInterface ctx' binder interface) (ctx, Nothing) interfaceBinders)
+              pure (foldl' (\(ctx', _) interface -> first (fromRight ctx') (registerInInterface ctx' binder interface)) (ctx, Nothing) interfaceBinders)
                 >>= \(newCtx, err) -> case err of
                   Just e -> printError (contextExecMode ctx) (show e) >> pure ctx
                   Nothing -> pure newCtx
@@ -233,13 +234,17 @@ primitiveRegisterType _ ctx [x@(XObj (Sym (SymPath [] t) _) _ _), members] =
   primitiveRegisterTypeWithFields ctx x t Nothing members
 primitiveRegisterType x ctx _ = pure (toEvalError ctx x RegisterTypeError)
 
+-- | Register an external type that has no fields.
 primitiveRegisterTypeWithoutFields :: Context -> String -> Maybe String -> IO (Context, Either EvalError XObj)
 primitiveRegisterTypeWithoutFields ctx t override = do
   let path = SymPath [] t
       typeDefinition = XObj (Lst [XObj (ExternalType override) Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing]) Nothing (Just TypeTy)
   -- TODO: Support registering types in modules
-  pure (insertInTypeEnv ctx (markQualified path) (toBinder typeDefinition), dynamicNil)
+  case insertTypeBinder ctx (markQualified path) (toBinder typeDefinition) of
+    Left e -> pure (evalError ctx (show e) Nothing)
+    Right c -> pure (c, dynamicNil)
 
+-- | Register an external type that has fields.
 primitiveRegisterTypeWithFields :: Context -> XObj -> String -> Maybe String -> XObj -> IO (Context, Either EvalError XObj)
 primitiveRegisterTypeWithFields ctx x t override members =
   either
@@ -252,46 +257,47 @@ primitiveRegisterTypeWithFields ctx x t override members =
       do
         let typeDefinition = XObj (Lst [XObj (ExternalType override) Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing]) Nothing (Just TypeTy)
             path' = (qualifyPath ctx (SymPath [] typeModuleName))
-            update = insertInTypeEnv' path' (toBinder typeDefinition) . insertInGlobalEnv' path' (toBinder typeModuleXObj)
+            update = \c -> insertInGlobalEnv' path' (toBinder typeModuleXObj) c >>= insertTypeBinder' path' (toBinder typeDefinition)
-            ctx' = update ctx
+            Right 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)
     path = SymPath [] t
     preExistingModule = case lookupBinderInGlobalEnv ctx path of
-      Just (Binder _ (XObj (Mod found) _ _)) -> Just found
+      Right (Binder _ (XObj (Mod found et) _ _)) -> Just (found, et)
       _ -> Nothing
 
 notFound :: Context -> XObj -> SymPath -> IO (Context, Either EvalError XObj)
 notFound ctx x path = pure (toEvalError ctx x (SymbolNotFoundError path))
 
+-- | Get information about a binding.
 primitiveInfo :: UnaryPrimitiveCallback
-primitiveInfo _ ctx target@(XObj (Sym path@(SymPath _ _) _) _ _) =
+primitiveInfo _ ctx target@(XObj (Sym path@(SymPath _ name) _) _ _) =
   case path of
     SymPath [] _ ->
       do
         let found = lookupBinderInTypeEnv ctx path
         _ <- printIfFound found
         _ <- printInterfaceImplementationsOrAll found otherBindings
-        maybe (notFound ctx target path) (const ok) (found <|> fmap head otherBindings)
+        either (const (notFound ctx target path)) (const ok) (found <> fmap head otherBindings)
       where
         otherBindings =
           fmap (: []) (lookupBinderInContextEnv ctx path)
-            <|> multiLookupBinderEverywhere ctx path
+            <> (Right (lookupBinderEverywhere (contextGlobalEnv ctx) name))
     _ ->
       do
         let found = lookupBinderInTypeEnv ctx path
         let others = lookupBinderInContextEnv ctx path
         _ <- printIfFound found
-        _ <- maybe (pure ()) printer others
+        _ <- either (const (pure ())) printer others
-        maybe (notFound ctx target path) (const ok) (found <|> others)
+        either (const (notFound ctx target path)) (const ok) (found <> others)
   where
     ok :: IO (Context, Either EvalError XObj)
     ok = pure (ctx, dynamicNil)
-    printInterfaceImplementationsOrAll :: Maybe Binder -> Maybe [Binder] -> IO ()
+    printInterfaceImplementationsOrAll :: Either ContextError Binder -> Either ContextError [Binder] -> IO ()
     printInterfaceImplementationsOrAll interface impls =
-      maybe
+      either
-        (pure ())
+        (const (pure ()))
         (foldM (\_ binder -> printer binder) ())
         ( ( interface
               >>= \binder ->
@@ -302,7 +308,7 @@ primitiveInfo _ ctx target@(XObj (Sym path@(SymPath _ _) _) _ _) =
                         fmap (filter (implementsInterface binder)) impls
                       _ -> impls
           )
-            <|> impls
+            <> impls
         )
     implementsInterface :: Binder -> Binder -> Bool
     implementsInterface binder binder' =
@@ -310,8 +316,8 @@ primitiveInfo _ ctx target@(XObj (Sym path@(SymPath _ _) _) _ _) =
         False
         (\(XObj (Lst impls) _ _) -> getBinderPath binder `elem` map getPath impls)
         (Meta.getBinderMetaValue "implements" binder')
-    printIfFound :: Maybe Binder -> IO ()
+    printIfFound :: Either ContextError Binder -> IO ()
-    printIfFound = maybe (pure ()) printer
+    printIfFound = either (const (pure ())) printer
     printer :: Binder -> IO ()
     printer binder@(Binder metaData x@(XObj _ (Just i) _)) =
       putStrLnWithColor Blue (forceShowBinder binder)
@@ -345,101 +351,63 @@ dynamicOrMacroWith :: Context -> (SymPath -> [XObj]) -> Ty -> String -> XObj ->
 dynamicOrMacroWith ctx producer ty name body = do
   let qpath = qualifyPath ctx (SymPath [] name)
       elt = XObj (Lst (producer (unqualify qpath))) (xobjInfo body) (Just ty)
-      meta = lookupMeta (getPath elt) (contextGlobalEnv ctx)
+      meta = fromRight emptyMeta (lookupMeta (contextGlobalEnv ctx) (getPath elt))
-  pure (insertInGlobalEnv ctx qpath (Binder meta elt), dynamicNil)
+  pure
+    ( case (insertInGlobalEnv ctx qpath (Binder meta elt)) of
+        Left e -> evalError ctx (show e) (xobjInfo body)
+        Right c -> (c, dynamicNil)
+    )
 
+-- | Get the members of a type declaration.
 primitiveMembers :: UnaryPrimitiveCallback
-primitiveMembers _ ctx target = do
+primitiveMembers _ ctx xobj@(XObj (Sym path _) _ _) =
-  case bottomedTarget target of
+  case (lookupBinderInTypeEnv ctx path) of
-    XObj (Sym path@(SymPath _ name) _) _ _ ->
+    Left _ -> pure $ toEvalError ctx xobj (StructNotFound xobj)
-      case lookupBinderInTypeEnv ctx path of
+    Right b -> go (binderXObj b)
-        Just
-          ( Binder
-              _
-              ( XObj
-                  ( Lst
-                      [ XObj (Deftype _) Nothing Nothing,
-                        XObj (Sym (SymPath _ _) Symbol) Nothing Nothing,
-                        XObj (Arr members) _ _
-                        ]
-                    )
-                  _
-                  _
-                )
-            ) ->
-            pure (ctx, Right (XObj (Arr (map (\(a, b) -> XObj (Lst [a, b]) Nothing Nothing) (pairwise members))) Nothing Nothing))
-        Just
-          ( Binder
-              _
-              ( XObj
-                  ( Lst
-                      ( XObj (DefSumtype _) Nothing Nothing
-                          : XObj (Sym (SymPath _ _) Symbol) Nothing Nothing
-                          : sumtypeCases
-                        )
-                    )
-                  _
-                  _
-                )
-            ) ->
-            pure (ctx, Right (XObj (Arr (concatMap getMembersFromCase sumtypeCases)) Nothing Nothing))
-            where
-              getMembersFromCase :: XObj -> [XObj]
-              getMembersFromCase (XObj (Lst members) _ _) =
-                map (\(a, b) -> XObj (Lst [a, b]) Nothing Nothing) (pairwise members)
-              getMembersFromCase x@(XObj (Sym _ _) _ _) =
-                [XObj (Lst [x, XObj (Arr []) Nothing Nothing]) Nothing Nothing]
-              getMembersFromCase (XObj x _ _) =
-                error ("Can't handle case " ++ show x)
-        _ ->
-          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
-    bottomedTarget t =
+    go :: XObj -> IO (Context, Either EvalError XObj)
-      case t of
+    go (XObj (Lst [(XObj (Deftype _) _ _), _, (XObj (Arr members) _ _)]) _ _) =
-        XObj (Sym targetPath _) _ _ ->
+      pure (ctx, Right (XObj (Arr (map (\(a, b) -> XObj (Lst [a, b]) Nothing Nothing) (pairwise members))) Nothing Nothing))
-          case lookupBinderInContextEnv ctx targetPath of
+    go (XObj (Lst ((XObj (DefSumtype _) _ _) : _ : cases)) _ _) =
-            -- this is a trick: every type generates a module in the env;
+      pure $ (ctx, (either Left (\a -> Right (XObj (Arr (concat a)) Nothing Nothing)) (mapM getMembersFromCase cases)))
-            -- we’re special-casing here because we need the parent of the
+    go x = pure (toEvalError ctx x (NonTypeInTypeEnv path x))
-            -- module
+
-            Just (Binder _ (XObj (Mod _) _ _)) -> t
+    getMembersFromCase :: XObj -> Either EvalError [XObj]
-            -- if we’re recursing into a non-sym, we’ll stop one level down
+    getMembersFromCase (XObj (Lst members) _ _) =
-            Just (Binder _ x) -> bottomedTarget x
+      Right (map (\(a, b) -> XObj (Lst [a, b]) Nothing Nothing) (pairwise members))
-            _ -> target
+    getMembersFromCase x@(XObj (Sym _ _) _ _) =
-        _ -> target
+      Right [XObj (Lst [x, XObj (Arr []) Nothing Nothing]) Nothing Nothing]
+    getMembersFromCase x =
+      second (: []) (snd (toEvalError ctx x (PrimitiveError.InvalidSumtypeCase x)))
+primitiveMembers _ ctx x = argumentErr ctx "members" "a symbol" "first" x
 
 -- | Set meta data for a Binder
+--
+-- Permits "forward-declaration": if the binder doesn't exist, it creates a
+-- "meta stub" for the binder with the meta information.
 primitiveMetaSet :: TernaryPrimitiveCallback
-primitiveMetaSet _ ctx target@(XObj (Sym path@(SymPath prefixes _) _) _ _) (XObj (Str key) _ _) value =
+primitiveMetaSet _ ctx target@(XObj (Sym path@(SymPath _ _) _) _ _) (XObj (Str key) _ _) value =
-  pure $ maybe create (,dynamicNil) lookupAndUpdate
+  pure $ either (const create) (,dynamicNil) (lookupGlobal <> lookupType)
   where
     qpath = qualifyPath ctx path
-    fullPath@(SymPath modules _) = unqualify qpath
+    lookupGlobal :: Either ContextError Context
-    lookupAndUpdate :: Maybe Context
+    lookupGlobal =
-    lookupAndUpdate =
+      lookupBinderInGlobalEnv ctx path
-      ( lookupBinderInGlobalEnv ctx path
+        >>= \binder ->
-          >>= \binder ->
+          pure (Meta.updateBinderMeta binder key value)
-            pure (Meta.updateBinderMeta binder key value)
+            >>= insertInGlobalEnv ctx qpath
-              >>= pure . (insertInGlobalEnv ctx qpath)
+    lookupType :: Either ContextError Context
-      )
+    lookupType =
-        -- This is a global name but it doesn't exist in the global env
+      lookupBinderInTypeEnv ctx qpath
-        -- Before creating a new binder, check that it doesn't denote an existing type or interface.
+        >>= \binder ->
-        <|> if null modules
+          pure (Meta.updateBinderMeta binder key value)
-          then
+            >>= insertTypeBinder ctx qpath
-            lookupBinderInTypeEnv ctx qpath
-              >>= \binder ->
-                pure (Meta.updateBinderMeta binder key value)
-                  >>= pure . (insertInTypeEnv ctx qpath)
-          else Nothing
     create :: (Context, Either EvalError XObj)
     create =
-      -- TODO: Remove the special casing here (null check) and throw a general
+      let updated = Meta.updateBinderMeta (Meta.stub (unqualify qpath)) key value
-      -- error when modules don't exist
+       in case (insertInGlobalEnv ctx qpath updated) of
-      if null prefixes
+            Left e -> toEvalError ctx target (MetaSetFailed target (show e))
-        then
+            Right c -> (c, dynamicNil)
-          let updated = Meta.updateBinderMeta (Meta.stub fullPath) key value
-           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
 primitiveMetaSet _ ctx target _ _ =
@@ -450,13 +418,13 @@ primitiveDefinterface xobj ctx nameXObj@(XObj (Sym path@(SymPath [] name) _) _ _
   pure $ maybe invalidType validType (xobjToTy ty)
   where
     invalidType = evalError ctx ("Invalid type for interface `" ++ name ++ "`: " ++ pretty ty) (xobjInfo ty)
-    validType t = maybe defInterface updateInterface (lookupBinderInTypeEnv ctx path)
+    validType t = either (const defInterface) updateInterface (lookupBinderInTypeEnv ctx path)
       where
         defInterface =
           let interface = defineInterface name t [] (xobjInfo nameXObj)
               binder = toBinder interface
-              ctx' = insertInTypeEnv ctx (markQualified (SymPath [] name)) binder
+              Right ctx' = insertTypeBinder ctx (markQualified (SymPath [] name)) binder
-              newCtx = retroactivelyRegisterInInterface ctx' binder
+              Right newCtx = retroactivelyRegisterInInterface ctx' binder
            in (newCtx, dynamicNil)
         updateInterface binder = case binder of
           Binder _ (XObj (Lst (XObj (Interface foundType _) _ _ : _)) _ _) ->
@@ -502,8 +470,10 @@ registerInternal ctx name ty override =
               )
               (xobjInfo ty)
               (Just t)
-          meta = lookupMeta (getPath registration) (contextGlobalEnv ctx)
+          meta = fromRight emptyMeta (lookupMeta (contextGlobalEnv ctx) (getPath registration))
-       in (insertInGlobalEnv ctx qpath (Binder meta registration), dynamicNil)
+       in case (insertInGlobalEnv ctx qpath (Binder meta registration)) of
+            Left err -> evalError ctx (show err) (xobjInfo ty)
+            Right c -> (c, dynamicNil)
 
 primitiveRegister :: VariadicPrimitiveCallback
 primitiveRegister _ ctx [XObj (Sym (SymPath [] name) _) _ _, ty] =
@@ -549,147 +519,158 @@ primitiveRegister x ctx _ =
     )
 
 primitiveDeftype :: VariadicPrimitiveCallback
-primitiveDeftype xobj ctx (name : rest) =
+primitiveDeftype xobj ctx (name : rest@(XObj (Arr a) _ _ : _)) =
-  case rest of
+  case members a of
-    (XObj (Arr a) _ _ : _) ->
+    Nothing -> pure (toEvalError ctx xobj BadDeftypeMembers)
-      case members a of
+    Just ms -> ensureUnqualified (map fst ms)
-        Nothing ->
-          pure $
-            makeEvalError
-              ctx
-              Nothing
-              ( "All fields must have a name and a type."
-                  ++ "Example:\n"
-                  ++ "```(deftype Name [field1 Type1, field2 Type2, field3 Type3])```\n"
-              )
-              (xobjInfo xobj)
-        Just ms ->
-          ensureUnqualified $ map fst ms
-      where
-        members :: [XObj] -> Maybe [(XObj, XObj)]
-        members (binding : val : xs) = do
-          xs' <- members xs
-          Just $ (binding, val) : xs'
-        members [_] = Nothing
-        members [] = Just []
-        ensureUnqualified :: [XObj] -> IO (Context, Either EvalError XObj)
-        ensureUnqualified objs =
-          if all isUnqualifiedSym objs
-            then deftype name
-            else
-              pure $
-                makeEvalError
-                  ctx
-                  Nothing
-                  ( "Type members must be unqualified symbols, but got `"
-                      ++ concatMap pretty rest
-                      ++ "`"
-                  )
-                  (xobjInfo xobj)
-    _ -> deftype name
   where
-    deftype nm@(XObj (Sym (SymPath _ ty) _) _ _) = deftype' nm ty []
+    members :: [XObj] -> Maybe [(XObj, XObj)]
-    deftype (XObj (Lst (nm@(XObj (Sym (SymPath _ ty) _) _ _) : tyvars)) _ _) =
+    members [] = Just []
-      deftype' nm ty tyvars
+    members [_] = Nothing
-    deftype nm =
+    members (binding : val : xs) = members xs >>= \xs' -> pure $ (binding, val) : xs'
-      pure
+    ensureUnqualified :: [XObj] -> IO (Context, Either EvalError XObj)
-        ( evalError
+    ensureUnqualified objs =
-            ctx
+      if all isUnqualifiedSym objs
-            ("Invalid name for type definition: " ++ pretty nm)
+        then deftype ctx name (selectConstructor rest)
-            (xobjInfo nm)
+        else pure (toEvalError ctx xobj (QualifiedTypeMember rest))
-        )
+primitiveDeftype _ ctx (name : rest) =
-    deftype' :: XObj -> String -> [XObj] -> IO (Context, Either EvalError XObj)
+  deftype ctx name (selectConstructor rest)
-    deftype' nameXObj typeName typeVariableXObjs = do
-      let pathStrings = contextPath ctx
-          env = contextGlobalEnv ctx
-          innerEnv = contextInternalEnv ctx
-          typeEnv = contextTypeEnv ctx
-          typeVariables = mapM xobjToTy typeVariableXObjs
-          (preExistingModule, preExistingMeta) =
-            case lookupBinder (SymPath pathStrings typeName) (fromMaybe env innerEnv) {envParent = Nothing} of
-              Just (Binder meta (XObj (Mod found) _ _)) -> (Just found, meta)
-              Just (Binder meta _) -> (Nothing, meta)
-              _ -> (Nothing, emptyMeta)
-          (creatorFunction, typeConstructor) =
-            if length rest == 1 && isArray (head rest)
-              then (moduleForDeftype, Deftype)
-              else (moduleForSumtype, DefSumtype)
-      case (nameXObj, typeVariables) of
-        (XObj (Sym (SymPath _ tyName) _) i _, Just okTypeVariables) ->
-          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 = 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
-                      ( Lst
-                          ( XObj (typeConstructor structTy) Nothing Nothing :
-                            XObj (Sym (SymPath pathStrings tyName) Symbol) Nothing Nothing :
-                            rest
-                          )
-                      )
-                      i
-                      (Just TypeTy)
-                  holderEnv name' prev = Env (Map.fromList []) (Just prev) (Just name') Set.empty ExternalEnv 0
-                  holderModule name'' prevEnv priorPaths tyenv =
-                    case lookupBinder (SymPath priorPaths name'') tyenv of
-                      Just existing@(Binder _ (XObj (Mod _) _ _)) -> existing
-                      _ -> Binder emptyMeta (XObj (Mod (holderEnv name'' prevEnv)) (Just dummyInfo) (Just ModuleTy))
-                  folder (contx, 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)
-                  update = insertInTypeEnv' (markQualified (SymPath pathStrings tyName)) (toBinder typeDefinition) . replaceGlobalEnv' (contextGlobalEnv updatedGlobal)
-                  ctx' = update wHolders
-               in do
-                    -- 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 = 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
-                          -- and automatically implement the interfaces.
-                          foldl'
-                            (\(context, _) (path, sig, interface) -> registerInInterfaceIfNeeded context path interface sig)
-                            (ctxWithDeps, Nothing)
-                            [ (fakeImplBinder (modulePath "delete") deleteSig, deleteSig, deleteInterface),
-                              (fakeImplBinder (modulePath "str") strSig, strSig, strInterface),
-                              (fakeImplBinder (modulePath "copy") copySig, copySig, copyInterface)
-                            ]
-                    case err of
-                      Just e@AlreadyImplemented {} ->
-                        emitWarning (show e)
-                          >> pure (ctxWithInterfaceRegistrations, dynamicNil)
-                      Just e ->
-                        putStrLnWithColor Red (show e)
-                          >> pure (ctx, dynamicNil)
-                      Nothing -> pure (ctxWithInterfaceRegistrations, dynamicNil)
-            Left err ->
-              pure (makeEvalError ctx (Just err) ("Invalid type definition for '" ++ pretty nameXObj ++ "':\n\n" ++ show err) Nothing)
-        (_, Nothing) ->
-          pure (makeEvalError ctx Nothing ("Invalid type variables for type definition: " ++ pretty nameXObj) (xobjInfo nameXObj))
-        _ -> error "primitiveDeftype1"
 primitiveDeftype _ _ _ = error "primitivedeftype"
 
+type ModuleCreator = Context -> String -> [Ty] -> [XObj] -> Maybe Info -> Either TypeError (String, XObj, [XObj])
+
+-- | Build an XObj representing the constructor of a type in Carp.
+selectConstructor :: [XObj] -> (Ty -> (XObj, [XObj], ModuleCreator))
+selectConstructor xs =
+  let (constructor, creator, mems) =
+        if length xs == 1 && isArray (head xs)
+          then (Deftype, moduleForDeftypeInContext, xs)
+          else (DefSumtype, moduleForSumtypeInContext, xs)
+   in \t ->
+        ( XObj
+            ( Lst
+                ( XObj (constructor t) Nothing Nothing :
+                  XObj (Sym (getStructPath t) Symbol) Nothing Nothing :
+                  mems
+                )
+            )
+            Nothing
+            (Just TypeTy),
+          mems,
+          creator
+        )
+
+deftype :: Context -> XObj -> (Ty -> (XObj, [XObj], ModuleCreator)) -> IO (Context, Either EvalError XObj)
+deftype ctx x@(XObj (Sym (SymPath [] name) _) _ _) constructor =
+  do
+    (ctxWithType, e) <- (makeType ctx name [] constructor)
+    case e of
+      Left err -> pure (evalError ctx (show err) (xobjInfo x))
+      Right t -> autoDerive ctxWithType t
+deftype ctx x@(XObj (Lst ((XObj (Sym (SymPath [] name) _) _ _) : tyvars)) _ _) constructor =
+  do
+    (ctxWithType, e) <-
+      ( either
+          (\s -> pure (evalError ctx s Nothing))
+          (\vars -> makeType ctx name vars constructor)
+          (maybe (Left (show (InvalidTypeVariables x))) Right (checkVariables tyvars))
+        )
+    case e of
+      Left err -> pure (evalError ctx (show err) (xobjInfo x))
+      Right t -> autoDerive ctxWithType t
+deftype ctx name _ = pure $ toEvalError ctx name (InvalidTypeName name)
+
+checkVariables :: [XObj] -> Maybe [Ty]
+checkVariables vars = mapM xobjToTy vars
+
+makeType :: Context -> String -> [Ty] -> (Ty -> (XObj, [XObj], ModuleCreator)) -> IO (Context, Either EvalError Ty)
+makeType ctx name vars constructor =
+  let qpath = (qualifyPath ctx (SymPath [] name))
+      ty = StructTy (ConcreteNameTy (unqualify qpath)) vars
+      (typeX, members, creator) = constructor ty
+   in case ( unwrapErr (creator ctx name vars members Nothing)
+               >>= \(_, modx, deps) ->
+                 pure (existingOr ctx qpath modx)
+                   >>= \mod' ->
+                     unwrapErr (insertType ctx qpath (toBinder typeX) mod')
+                       >>= \c -> pure (foldM (define True) c (map Qualified deps))
+           ) of
+        Left e -> pure (evalError ctx e (xobjInfo typeX))
+        Right result -> (result >>= \ctx' -> pure (ctx', pure ty))
+  where
+    existingOr :: Context -> QualifiedPath -> XObj -> Binder
+    existingOr c q x@(XObj (Mod e _) _ _) =
+      case ((lookupBinderInInternalEnv c q) <> (lookupBinderInGlobalEnv c q)) of
+        Right (Binder meta (XObj (Mod ve te) ii tt)) ->
+          (Binder meta (XObj (Mod (e <> ve) te) ii tt))
+        _ -> (toBinder x)
+    existingOr _ _ x = (toBinder x)
+
+-- | Automatically derive implementations of interfaces.
+autoDerive :: Context -> Ty -> IO (Context, Either EvalError XObj)
+autoDerive c ty =
+  let (SymPath mods tyname) = (getStructPath ty)
+      implBinder :: String -> Ty -> Binder
+      implBinder name t = Binder emptyMeta (XObj (Sym (SymPath (mods ++ [tyname]) name) Symbol) (Just dummyInfo) (Just t))
+      getSig :: String -> Ty
+      getSig "delete" = FuncTy [ty] UnitTy StaticLifetimeTy
+      getSig "str" = FuncTy [RefTy ty (VarTy "q")] StringTy StaticLifetimeTy
+      getSig "copy" = FuncTy [RefTy ty (VarTy "q")] ty StaticLifetimeTy
+      getSig _ = VarTy "z"
+      interfaces =
+        [ lookupBinderInTypeEnv c (markQualified (SymPath [] "delete")),
+          lookupBinderInTypeEnv c (markQualified (SymPath [] "str")),
+          lookupBinderInTypeEnv c (markQualified (SymPath [] "copy"))
+        ]
+      registration interface =
+        let name = getSimpleName (binderXObj interface)
+            sig = getSig name
+         in (implBinder name sig, sig, interface)
+      derives =
+        (sequence interfaces)
+          >>= \binders -> pure (fmap registration binders)
+   in case derives of
+        Left _ -> pure (evalError c "Couldn't derive interfaces." Nothing)
+        Right regs ->
+          case foldl' (\(context, _) (path, sig, interface) -> first (fromRight (error "COULDNT DERIVE!")) (registerInInterfaceIfNeeded context path interface sig)) (c, Nothing) regs of
+            (ci, Just err@AlreadyImplemented {}) -> emitWarning (show err) >> pure (ci, dynamicNil :: Either EvalError XObj)
+            (_, Just err) -> pure $ evalError c (show err) Nothing
+            (ci, Nothing) -> pure (ci, dynamicNil :: Either EvalError XObj)
+
+-- | Add a module to the list of implicitly imported modules.
 primitiveUse :: UnaryPrimitiveCallback
 primitiveUse xobj ctx (XObj (Sym path _) _ _) =
-  pure $ maybe lookupInGlobal useModule (lookupInEnv path e)
+  let modulePath = fromStrings (contextPath ctx)
+      contextualized = (consPath (contextPath ctx) path)
+      global = (contextGlobalEnv ctx)
+      -- Look up the module to see if we can actually use it.
+      -- The reference might be contextual, if so, append the current context path strings.
+      path' = case (searchValueBinder global path) of
+              Right _ -> path
+              _ -> contextualized
+   in pure
+        ( case modulePath of
+            (SymPath [] "") -> updateGlobalUsePaths global path'
+            _ -> case searchValueBinder global modulePath of
+              Left err -> (evalError ctx (show err) (xobjInfo xobj))
+              Right binder ->
+                updateModuleUsePaths global modulePath binder path'
+        )
   where
-    pathStrings = contextPath ctx
+    updateGlobalUsePaths :: Env -> SymPath -> (Context, Either EvalError XObj)
-    env = contextGlobalEnv ctx
+    updateGlobalUsePaths e spath =
-    e = getEnv env pathStrings
+      ((replaceGlobalEnv ctx (addUsePath e spath)), dynamicNil)
-    useThese = envUseModules e
+
-    e' = e {envUseModules = Set.insert path useThese}
+    updateModuleUsePaths :: Env -> SymPath -> Binder -> SymPath -> (Context, Either EvalError XObj)
-    lookupInGlobal = maybe missing useModule (lookupInEnv path env)
+    updateModuleUsePaths e p (Binder meta (XObj (Mod ev et) i t)) spath =
-      where
+      either
-        missing = evalError ctx ("Can't find a module named '" ++ show path ++ "'") (xobjInfo xobj)
+        (\err -> (evalError ctx err (xobjInfo xobj)))
-    useModule _ = (replaceGlobalEnv ctx (envReplaceEnvAt env pathStrings e'), dynamicNil)
+        (\newCtx -> (newCtx, dynamicNil))
+        ( (unwrapErr (insert e p (Binder meta (XObj (Mod (addUsePath ev spath) et) i t))))
+            >>= pure . replaceGlobalEnv ctx
+        )
+    updateModuleUsePaths _ _ _ _ =
+      (evalError ctx "Context path pointed to non-module!" (xobjInfo xobj))
 primitiveUse _ ctx x =
   argumentErr ctx "use" "a symbol" "first" x
 
@@ -699,7 +680,7 @@ primitiveMeta (XObj _ i _) ctx (XObj (Sym path _) _ _) (XObj (Str key) _ _) =
   pure $ maybe errNotFound foundBinder lookup'
   where
     lookup' :: Maybe Binder
-    lookup' = (lookupBinderInGlobalEnv ctx path <|> lookupBinderInTypeEnv ctx path) >>= pure
+    lookup' = either (const Nothing) Just (lookupBinderInGlobalEnv ctx path <> lookupBinderInTypeEnv ctx path)
     foundBinder :: Binder -> (Context, Either EvalError XObj)
     foundBinder binder = (ctx, maybe dynamicNil Right (Meta.getBinderMetaValue key binder))
     errNotFound :: (Context, Either EvalError XObj)
@@ -711,14 +692,14 @@ primitiveMeta _ ctx path _ =
 
 primitiveDefined :: UnaryPrimitiveCallback
 primitiveDefined _ ctx (XObj (Sym path _) _ _) =
-  pure $ maybe (ctx, Right falseXObj) (const (ctx, Right trueXObj)) (lookupBinderInContextEnv ctx path)
+  pure $ either (const (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 p@(SymPath [] _) _) _ _) ty (XObj (Str declTempl) _ _) (XObj (Str defTempl) _ _) =
-  pure $ maybe invalidType validType (xobjToTy ty)
+  pure $ maybe invalidType (fromRight invalidType . fmap (\x -> (x, dynamicNil)) . validType) (xobjToTy ty)
   where
     typeEnv = contextTypeEnv ctx
     globalEnv = contextGlobalEnv ctx
@@ -728,13 +709,13 @@ primitiveDeftemplate _ ctx (XObj (Sym p@(SymPath [] _) _) _ _) ty (XObj (Str dec
         if isTypeGeneric t
           then
             let (Binder _ registration) = b
-                meta = lookupMeta (getPath registration) globalEnv
+                meta = fromRight emptyMeta (lookupMeta globalEnv (getPath registration))
-             in (insertInGlobalEnv ctx (qualifyPath ctx p) (Binder meta registration), dynamicNil)
+             in insertInGlobalEnv ctx (qualifyPath ctx p) (Binder meta registration)
           else
             let templateCreator = getTemplateCreator template
                 (registration, _) = instantiateTemplate (contextualize p ctx) t (templateCreator typeEnv globalEnv)
-                meta = lookupMeta (getPath registration) globalEnv
+                meta = fromRight emptyMeta (lookupMeta globalEnv (getPath registration))
-             in (insertInGlobalEnv ctx (qualifyPath ctx p) (Binder meta registration), dynamicNil)
+             in insertInGlobalEnv ctx (qualifyPath ctx p) (Binder meta registration)
       _ -> error "primitivedeftemplate1"
 primitiveDeftemplate _ ctx (XObj (Sym (SymPath [] _) _) _ _) _ (XObj (Str _) _ _) x =
   argumentErr ctx "deftemplate" "a string" "fourth" x
@@ -754,10 +735,10 @@ 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 (lookupBinderInGlobalEnv ctx path)
+  fromRight otherDefs (second go (lookupBinderInGlobalEnv ctx path))
   where
     env = contextGlobalEnv ctx
-    otherDefs = case multiLookupEverywhere name env of
+    otherDefs = case lookupEverywhere env name of
       [] ->
         notFound ctx x path
       binders ->
@@ -771,7 +752,7 @@ 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 (lookupBinderInGlobalEnv ctx qualifiedPath)
+  fromRight (notFound ctx x qualifiedPath) (second go (lookupBinderInGlobalEnv ctx qualifiedPath))
   where
     go binder =
       case xobjTy (binderXObj binder) of

src/Qualify.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE TupleSections #-}
+
 --------------------------------------------------------------------------------
 
 -- | Defines data, errors, and functions for qualifying symbols in a given
@@ -16,15 +18,14 @@ module Qualify
 where
 
 import Control.Monad (foldM, liftM)
-import Data.List (foldl')
+import Data.Bifunctor
-import Debug.Trace
+import Data.Either (fromRight)
-import Env
+import qualified Env as E
 import Info
-import Lookup
 import qualified Map
 import Obj
 import qualified Set
-import Types
+import SymPath
 import Util
 
 --------------------------------------------------------------------------------
@@ -35,6 +36,11 @@ data QualificationError
   = FailedToQualifyDeclarationName XObj
   | FailedToQualifySymbols XObj
   | FailedToQualifyPath SymPath
+  | NonVariableInMatch XObj
+  | NakedInitForUnnamedModule [String]
+  | QualifiedMulti SymPath
+  | LocalMulti SymPath [(Env, Binder)]
+  | FailedToFindSymbol XObj
 
 instance Show QualificationError where
   show (FailedToQualifyDeclarationName xobj) =
@@ -44,6 +50,18 @@ instance Show QualificationError where
   show (FailedToQualifyPath spath) =
     "Couldn't fully qualify the symbol: " ++ show spath
       ++ "in the given context."
+  show (NonVariableInMatch xobj) =
+    "Couldn't qualify the xobj: " ++ pretty xobj
+      ++ "in a match expression."
+  show (NakedInitForUnnamedModule s) =
+    "Tried to emit a naked init for an unnamed module: " ++ (show s)
+  show (QualifiedMulti spath) =
+    "Tried to use a qualified symbol as a multi sym: " ++ (show spath)
+  show (LocalMulti spath binders) =
+    "Tried to use a symbol that has local bindings as a multi sym: " ++ show spath
+      ++ show binders
+  show (FailedToFindSymbol xobj) =
+    "Couldn't find the xobj: " ++ pretty xobj
 
 --------------------------------------------------------------------------------
 -- Data
@@ -52,7 +70,7 @@ instance Show QualificationError where
 --
 -- A fully qualified xobj **must not** be qualified further (e.g. using context
 -- paths).
-newtype Qualified = Qualified {unQualified :: XObj}
+newtype Qualified = Qualified {unQualified :: XObj} deriving (Show)
 
 -- | Denotes a symbol that has been fully qualified.
 newtype QualifiedPath = QualifiedPath SymPath
@@ -115,10 +133,10 @@ 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)
+      inner >>= \i -> 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)
+      inner >>= \i -> setFullyQualifiedSymbols t g i (XObj (Lst [def, (XObj (Sym (SymPath pathStrings name) mode) symi symt), expr]) info ty)
-    _ -> setFullyQualifiedSymbols t g i xobj
+    _ -> inner >>= \i -> setFullyQualifiedSymbols t g i xobj
   where
     pathStrings :: [String]
     pathStrings = contextPath ctx
@@ -126,8 +144,8 @@ qualify ctx xobj@(XObj obj info ty) =
     t = contextTypeEnv ctx
     g :: Env
     g = contextGlobalEnv ctx
-    i :: Env
+    inner :: Either QualificationError Env
-    i = getEnv g pathStrings
+    inner = replaceLeft (FailedToQualifySymbols xobj) (E.getInnerEnv 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.
@@ -176,29 +194,32 @@ type Qualifier = TypeEnv -> Env -> Env -> XObj -> Either QualificationError Qual
 
 -- | 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) =
+qualifyFunctionDefinition typeEnv globalEnv env x@(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
+    recursionEnv <- fixLeft (pure (E.recursive (Just env) (Just (functionName ++ "-recurse-env")) 0))
-        envWithSelf = extendEnv recursionEnv functionName sym
+    envWithSelf <- fixLeft (E.insertX recursionEnv (SymPath [] functionName) sym)
-        functionEnv = Env Map.empty (Just envWithSelf) Nothing Set.empty InternalEnv 0
+    -- Copy the use modules from the local env to ensure they are available from the function env.
-        envWithArgs = foldl' (\e arg@(XObj (Sym (SymPath _ argSymName) _) _ _) -> extendEnv e argSymName arg) functionEnv argsArr
+    functionEnv <- fixLeft (pure ((E.nested (Just envWithSelf) (Just (functionName ++ "-function-env")) 0) {envUseModules = (envUseModules env)}))
+    envWithArgs <- fixLeft (foldM (\e arg@(XObj (Sym path _) _ _) -> E.insertX e path arg) functionEnv argsArr)
     qualifiedBody <- liftM unQualified (setFullyQualifiedSymbols typeEnv globalEnv envWithArgs body)
     pure (Qualified (XObj (Lst [defn, sym, args, qualifiedBody]) i t))
+  where
+    fixLeft = replaceLeft (FailedToQualifyDeclarationName x)
 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) =
+qualifyLambda typeEnv globalEnv env x@(XObj (Lst [fn@(XObj (Fn _ _) _ _), args@(XObj (Arr argsArr) _ _), body]) i t) =
-  do
+  let lvl = envFunctionNestingLevel env
-    let lvl = envFunctionNestingLevel env
+      functionEnv = Env Map.empty (Just env) Nothing Set.empty InternalEnv (lvl + 1)
-        functionEnv = Env Map.empty (Just env) Nothing Set.empty InternalEnv (lvl + 1)
+   in (replaceLeft (FailedToQualifySymbols x) (foldM (\e arg@(XObj (Sym path _) _ _) -> E.insertX e path arg) functionEnv argsArr))
-        envWithArgs = foldl' (\e arg@(XObj (Sym (SymPath _ argSymName) _) _ _) -> extendEnv e argSymName arg) functionEnv argsArr
+        >>= \envWithArgs ->
-    qualifiedBody <- liftM unQualified (setFullyQualifiedSymbols typeEnv globalEnv envWithArgs body)
+          liftM unQualified (setFullyQualifiedSymbols typeEnv globalEnv envWithArgs body)
-    pure (Qualified (XObj (Lst [fn, args, qualifiedBody]) i t))
+            >>= \qualifiedBody -> pure (Qualified (XObj (Lst [fn, args, qualifiedBody]) i t))
 qualifyLambda _ _ _ xobj = Left $ FailedToQualifySymbols xobj
 
 -- | Qualify the symbols in a The form's body.
@@ -219,7 +240,7 @@ 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)
+qualifyLet typeEnv globalEnv env x@(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 =
@@ -232,17 +253,19 @@ qualifyLet typeEnv globalEnv env (XObj (Lst [letExpr@(XObj Let _ _), bind@(XObj
       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) =
+    qualifyBinding (e, bs) (s@(XObj (Sym path _) _ _), o) =
       do
         qualified <- liftM unQualified (setFullyQualifiedSymbols typeEnv globalEnv e o)
-        (pure (extendEnv e binderName s, bs ++ [s, qualified]))
+        updated <- (replaceLeft (FailedToQualifySymbols x) (E.insertX e path s))
+        (pure (updated, 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.
+  -- Leave it untouched for the compiler to find the error.
+  | odd (length casesXObjs) = pure $ Qualified $ XObj (Lst (matchExpr : expr : casesXObjs)) i t
   | otherwise =
     do
       qualifiedExpr <- pure . unQualified =<< setFullyQualifiedSymbols typeEnv globalEnv env expr
@@ -251,26 +274,33 @@ qualifyMatch typeEnv globalEnv env (XObj (Lst (matchExpr@(XObj (Match _) _ _) :
   where
     Just ii = i
     lvl = envFunctionNestingLevel env
+    -- Create an inner environment for each case.
     innerEnv :: Env
-    innerEnv = Env Map.empty (Just env) (Just ("case-env-" ++ show (infoIdentifier ii))) Set.empty InternalEnv lvl
+    innerEnv = E.nested (Just env) (Just ("case-env-" ++ show (infoIdentifier ii))) lvl
+    -- Qualify each case in the match form.
     qualifyCases :: (XObj, XObj) -> Either QualificationError [Qualified]
     qualifyCases (l@(XObj (Lst (_ : xs)) _ _), r) =
       do
-        let innerEnv' = foldl' foldVars innerEnv xs
+        innerEnv' <- foldM foldVars innerEnv xs
-        qualifiedLHS <- setFullyQualifiedSymbols typeEnv globalEnv env l
+        qualifiedLHS <- setFullyQualifiedSymbols typeEnv globalEnv innerEnv' l
         qualifiedRHS <- setFullyQualifiedSymbols typeEnv globalEnv innerEnv' r
         Right [qualifiedLHS, qualifiedRHS]
+    qualifyCases (wild@(XObj (Sym (SymPath _ "_") _) _ _), r) =
+      do
+        qualifiedLHS <- foldVars env wild >>= \e -> setFullyQualifiedSymbols typeEnv globalEnv e wild
+        qualifiedRHS <- setFullyQualifiedSymbols typeEnv globalEnv env 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
+    -- Add variables in a case to its environment
-    foldVars env' v@(XObj (Sym (SymPath _ binderName) _) _ _) = extendEnv env' binderName v
+    foldVars :: Env -> XObj -> Either QualificationError Env
-    -- Nested sumtypes
+    foldVars env' v@(XObj (Sym path _) _ _) = (replaceLeft (FailedToQualifySymbols v) (E.insertX env' path v))
-    -- fold recursively -- is there a more efficient way?
+    -- Nested sumtypes; fold recursively -- is there a more efficient way?
-    foldVars _ (XObj (Lst (_ : ys)) _ _) = foldl' foldVars innerEnv ys
+    foldVars _ (XObj (Lst (_ : ys)) _ _) = foldM foldVars innerEnv ys
-    foldVars _ v = error ("Can't match variable with " ++ show v)
+    foldVars _ v = Left $ NonVariableInMatch v
 qualifyMatch _ _ _ xobj = Left $ FailedToQualifySymbols xobj
 
 -- | Qualify symbols in a With form.
@@ -291,104 +321,93 @@ qualifyLst typeEnv globalEnv env (XObj (Lst xobjs) 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) =
+-- Unqualified path.
-  Right $
+qualifySym typeEnv globalEnv localEnv xobj@(XObj (Sym path@(SymPath _ name) _) i t) =
-    Qualified $
+  ( ( ( replaceLeft
-      case path of
+          (FailedToFindSymbol xobj)
-        -- Unqualified:
+          -- TODO: Why do we need getValue here? We should be able to restrict this
-        SymPath [] name ->
+          -- search only to direct children of the type environment, but this causes
-          case lookupBinder path (getTypeEnv typeEnv) of
+          -- errors.
-            Just (Binder _ (XObj (Lst (XObj (Interface _ _) _ _ : _)) _ _)) ->
+          ( fmap (\(e, b) -> ((E.prj typeEnv), (E.prj e, b))) (E.searchType typeEnv path)
-              -- Found an interface with the same path!
+              <> fmap (localEnv,) (E.searchValue localEnv path)
-              -- Have to ensure it's not a local variable with the same name as the interface
+              <> fmap (globalEnv,) (E.searchValue globalEnv path)
-              case lookupInEnv path localEnv of
+          )
-                Just (foundEnv, _) ->
+      )
-                  if envIsExternal foundEnv
+        >>= \(origin, (e, binder)) ->
-                    then createInterfaceSym name
+          resolve (E.prj origin) (E.prj e) (binderXObj binder)
-                    else doesNotBelongToAnInterface False localEnv
+            >>= pure . Qualified
-                Nothing ->
+    )
-                  --trace ("Will turn '" ++ show path ++ "' " ++ prettyInfoFromXObj xobj ++ " into an interface symbol.")
+      <> ((resolveMulti path (E.lookupInUsed localEnv globalEnv path)) >>= pure . Qualified)
-                  createInterfaceSym name
+      <> ((replaceLeft (FailedToFindSymbol xobj) (E.lookupContextually globalEnv path)) >>= (resolveMulti path) >>= pure . Qualified)
-            _ ->
+      <> ((resolveMulti path (E.lookupEverywhere globalEnv name)) >>= pure . Qualified)
-              doesNotBelongToAnInterface False localEnv
+      <> pure (Qualified xobj)
-        -- Qualified:
+  )
-        _ ->
-          doesNotBelongToAnInterface False localEnv
   where
-    createInterfaceSym name =
+    resolve :: Env -> Env -> XObj -> Either QualificationError XObj
-      XObj (InterfaceSym name) i t
+    resolve _ _ (XObj (Lst (XObj (Interface _ _) _ _ : _)) _ _) =
-    captureOrNot foundEnv =
+      -- Before we return an interface, double check that it isn't shadowed by a local let-binding.
-      if envFunctionNestingLevel foundEnv < envFunctionNestingLevel localEnv
+      case (E.searchValue localEnv path) of
-        then Capture (envFunctionNestingLevel localEnv - envFunctionNestingLevel foundEnv)
+        Right (e, Binder _ _) ->
-        else NoCapture
+          case envMode e of
-    doesNotBelongToAnInterface :: Bool -> Env -> XObj
+            InternalEnv -> pure (XObj (Sym (getPath xobj) (LookupLocal (captureOrNot e localEnv))) i t)
-    doesNotBelongToAnInterface finalRecurse theEnv =
+            _ -> pure (XObj (InterfaceSym name) i t)
-      let results = multiLookupQualified path theEnv
+        _ -> pure (XObj (InterfaceSym name) i t)
-          results' = removeThoseShadowedByRecursiveSymbol results
+    resolve _ _ x@(XObj (Lst (XObj (External (Just overrideName)) _ _ : _)) _ _) =
-       in case results' of
+      pure (XObj (Sym (getPath x) (LookupGlobalOverride overrideName)) i t)
-            [] -> case envParent theEnv of
+    resolve _ _ (XObj (Mod modenv _) _ _) =
-              Just p ->
+      nakedInit modenv
-                doesNotBelongToAnInterface False p
+    resolve origin found xobj' =
-              Nothing ->
+      if (isTypeDef xobj')
-                -- OBS! The environment with no parent is the global env but it's an old one without the latest bindings!
+        then
-                if finalRecurse
+          ( (replaceLeft (FailedToFindSymbol xobj') (fmap (globalEnv,) (E.searchValue globalEnv path)))
-                  then xobj -- This was the TRUE global env, stop here and leave 'xobj' as is.
+              >>= \(origin', (e', binder)) -> resolve (E.prj origin') (E.prj e') (binderXObj binder)
-                  else doesNotBelongToAnInterface True globalEnv
+          )
-            [(_, Binder _ foundOne@(XObj (Lst (XObj (External (Just overrideWithName)) _ _ : _)) _ _))] ->
+        else case envMode (E.prj found) of
-              XObj (Sym (getPath foundOne) (LookupGlobalOverride overrideWithName)) i t
+          RecursionEnv -> pure (XObj (Sym (getPath xobj') LookupRecursive) i t)
-            [(e, Binder _ (XObj (Mod modEnv) _ _))] ->
+          InternalEnv -> pure (XObj (Sym (getPath xobj') (LookupLocal (captureOrNot found origin))) i t)
-              -- Lookup of a "naked" module name means that the Carp code is trying to
+          ExternalEnv -> pure (XObj (Sym (getPath xobj') (LookupGlobal (if isExternalFunction xobj' then ExternalCode else CarpLand) (definitionMode xobj'))) i t)
-              -- instantiate a (nested) module with an implicit .init, e.g. (Pair 1 2)
+    resolveMulti :: (Show e, E.Environment e) => SymPath -> [(e, Binder)] -> Either QualificationError XObj
-              case envModuleName modEnv of
+    resolveMulti _ [] =
-                Nothing -> error ("Can't get name from unqualified module path: " ++ show path)
+      Left (FailedToFindSymbol xobj)
-                Just name ->
+    resolveMulti _ [(e, b)] =
-                  let pathHere = pathToEnv e
+      resolve (E.prj e) (E.prj e) (binderXObj b)
-                   in XObj (Sym (SymPath (pathHere ++ [name]) "init") (LookupGlobal CarpLand AFunction)) i t
+    resolveMulti spath xs =
-            [(e, Binder _ foundOne)] ->
+      let localOnly = remove (E.envIsExternal . fst) xs
-              case envMode e of
+          paths = map (getModuleSym . (second binderXObj)) xs
-                ExternalEnv ->
+       in case localOnly of
-                  XObj
+            [] -> case spath of
-                    ( Sym
+              (SymPath [] _) ->
-                        (getPath foundOne)
+                Right $ XObj (MultiSym name paths) i t
-                        (LookupGlobal (if isExternalFunction foundOne then ExternalCode else CarpLand) (definitionMode foundOne))
+              _ -> Left (QualifiedMulti spath)
-                    )
+            ys -> Left (LocalMulti spath (map (first E.prj) ys))
-                    i
+    nakedInit :: Env -> Either QualificationError XObj
-                    t
+    nakedInit e =
-                RecursionEnv -> XObj (Sym (getPath foundOne) LookupRecursive) i t
+      maybe
-                _ ->
+        (Left (NakedInitForUnnamedModule (pathToEnv e)))
-                  --trace ("\nLOCAL variable " ++ show (getPath foundOne) ++ ":\n" ++ prettyEnvironmentChain e) $
+        (Right . id)
-                  XObj (Sym (getPath foundOne) (LookupLocal (captureOrNot e))) i t
+        ( envModuleName e
-            multiple ->
+            >>= \name' ->
-              case filter (not . envIsExternal . fst) multiple of
+              pure (XObj (Sym (SymPath ((init (pathToEnv e)) ++ [name']) "init") (LookupGlobal CarpLand AFunction)) i t)
-                -- There is at least one local binding, use the path of that one:
+        )
-                (e, Binder _ local) : _ -> XObj (Sym (getPath local) (LookupLocal (captureOrNot e))) i t
+    getModuleSym (_, x) =
-                -- There are no local bindings, this is allowed to become a multi lookup symbol:
+      case x of
-                [] ->
+        XObj (Mod ev _) _ _ ->
-                  -- (trace $ "Turned " ++ show path ++ " into multisym: " ++ joinWithComma (map (show . (\(e, b) -> (getPath (binderXObj b), safeEnvModuleName e, envMode e))) multiple)) $
+          fromRight
-                  case path of
+            (SymPath (init (pathToEnv ev)) name)
-                    (SymPath [] name) ->
+            ( (replaceLeft (FailedToFindSymbol x) (E.searchType globalEnv (SymPath (init (pathToEnv ev)) name)))
-                      -- Create a MultiSym!
+                >> (fmap getPath (nakedInit ev))
-                      XObj (MultiSym name (map (getPath . binderXObj . snd) multiple)) i t
-                    pathWithQualifiers ->
-                      -- The symbol IS qualified but can't be found, should produce an error later during compilation.
-                      trace ("PROBLEMATIC: " ++ show path) (XObj (Sym pathWithQualifiers (LookupGlobal CarpLand AFunction)) i t)
-    removeThoseShadowedByRecursiveSymbol :: [(Env, Binder)] -> [(Env, Binder)]
-    removeThoseShadowedByRecursiveSymbol allBinders = visit allBinders allBinders
-      where
-        visit bs res =
-          foldl'
-            ( \result b ->
-                case b of
-                  (Env {envMode = RecursionEnv}, Binder _ xobj') ->
-                    remove (\(_, Binder _ x) -> xobj' /= x && getName xobj' == getName x) result
-                  _ -> result
             )
-            res
+        _ -> (getPath x)
-            bs
 qualifySym _ _ _ xobj = Left $ FailedToQualifySymbols xobj
 
+-- | Determine whether or not this symbol is captured in a local environment (closures).
+captureOrNot :: Env -> Env -> CaptureMode
+captureOrNot foundEnv localEnv =
+  if envFunctionNestingLevel foundEnv < envFunctionNestingLevel localEnv
+    then Capture (envFunctionNestingLevel localEnv - envFunctionNestingLevel foundEnv)
+    else NoCapture
+
 -- | Qualify an Arr form.
 qualifyArr :: Qualifier
 qualifyArr typeEnv globalEnv env (XObj (Arr array) i t) =

src/Reify.hs

@@ -40,6 +40,7 @@ instance Reifiable Ty where
   reify (FuncTy ats rt lt) = XObj (Lst [literal "Fn", array ats, reify rt, lifetime lt]) Nothing (Just TypeTy)
   reify TypeTy = XObj (Sym (SymPath [] (show TypeTy)) Symbol) Nothing (Just Universe)
   reify UnitTy = XObj (Sym (SymPath [] "Unit") Symbol) Nothing (Just TypeTy)
+  reify (ConcreteNameTy path) = XObj (Sym path Symbol) Nothing (Just TypeTy)
   reify t = XObj (Sym (SymPath [] (show t)) Symbol) Nothing (Just TypeTy)
 
 instance Reifiable String where

src/RenderDocs.hs

@@ -52,7 +52,7 @@ saveDocsForEnvs ctx pathsAndEnvBinders =
 getEnvAndMetaFromBinder :: Binder -> (Env, MetaData)
 getEnvAndMetaFromBinder envBinder =
   case envBinder of
-    Binder meta (XObj (Mod env) _ _) -> (env, meta)
+    Binder meta (XObj (Mod env _) _ _) -> (env, meta)
     _ -> error "Binder's not a module. This should be detected in 'commandSaveDocsInternal'."
 
 projectIndexPage :: Project -> [String] -> String

src/Scoring.hs

@@ -1,7 +1,7 @@
 module Scoring (scoreTypeBinder, scoreValueBinder) where
 
 import Data.Maybe (fromJust)
-import Lookup
+import Env as E
 import Obj
 import qualified Set
 import Types
@@ -24,15 +24,12 @@ scoreTypeBinder typeEnv b@(Binder _ (XObj (Lst (XObj x _ _ : XObj (Sym _ _) _ _
     ExternalType _ -> (0, b)
     _ -> (500, b)
   where
-    depthOfStruct (StructTy (ConcreteNameTy structName) varTys) =
+    depthOfStruct (StructTy (ConcreteNameTy (SymPath _ name)) varTys) =
-      case lookupBinder (SymPath lookupPath name) (getTypeEnv typeEnv) of
+      case E.getTypeBinder typeEnv name of
-        Just (Binder _ typedef) -> (depthOfDeftype typeEnv Set.empty typedef varTys + 1, b)
+        Right (Binder _ typedef) -> (depthOfDeftype typeEnv Set.empty typedef varTys + 1, b)
-        Nothing -> error ("Can't find user defined type '" ++ structName ++ "' in type env.")
+        Left e -> error (show e)
-      where
-        lookupPath = getPathFromStructName structName
-        name = getNameFromStructName structName
     depthOfStruct _ = error "depthofstruct"
-scoreTypeBinder _ b@(Binder _ (XObj (Mod _) _ _)) =
+scoreTypeBinder _ b@(Binder _ (XObj (Mod _ _) _ _)) =
   (1000, b)
 scoreTypeBinder _ x = error ("Can't score: " ++ show x)
 
@@ -79,17 +76,19 @@ depthOfType typeEnv visited selfName theType =
           _
             | tyToC struct == selfName -> 1
             | otherwise ->
-              case lookupBinder (SymPath lookupPath s) (getTypeEnv typeEnv) of
+              case E.getTypeBinder typeEnv s of
-                Just (Binder _ typedef) -> moduleDepth + depthOfDeftype typeEnv (Set.insert theType visited) typedef varTys
+                Right (Binder _ typedef) -> depthOfDeftype typeEnv (Set.insert theType visited) typedef varTys
-                  where
+                Left _ ->
-                    moduleDepth = length lookupPath * 1000 -- modules have score 1000
-                Nothing ->
                   --trace ("Unknown type: " ++ name) $
-                  depthOfVarTys -- The problem here is that generic types don't generate
+                  -- Two problems here:
-                  -- their definition in time so we get nothing for those.
+                  --
-                  -- Instead, let's try the type vars.
+                  -- 1. generic types don't generate their definition in time
+                  -- so we get nothing for those. Instead, let's try the type
+                  -- vars.
+                  -- 2. If a type wasn't found type may also refer to a type defined in another
+                  -- module that's not yet been scored. To be safe, add 500
+                  500 + depthOfVarTys
       where
-        lookupPath = getPathFromStructName (getStructName struct)
         s = getNameFromStructName (getStructName struct)
         depthOfVarTys =
           case fmap (depthOfType typeEnv visited (getStructName struct)) varTys of
@@ -121,12 +120,12 @@ scoreBody globalEnv visited = visit
         (Sym path (LookupGlobal _ _)) ->
           if Set.member path visited
             then 0
-            else case lookupBinder path globalEnv of
+            else case E.searchValueBinder globalEnv path of
-              Just foundBinder ->
+              Right foundBinder ->
                 let (score, _) = scoreValueBinder globalEnv (Set.insert path visited) foundBinder
                  in score + 1
-              Nothing ->
+              Left e ->
-                error ("Failed to lookup '" ++ show path ++ "'.")
+                error (show e)
         _ -> 0
     visitList (XObj (Lst []) _ _) =
       0

src/StartingEnv.hs

@@ -2,6 +2,7 @@ module StartingEnv where
 
 import qualified ArrayTemplates
 import Commands
+import qualified Env as E
 import Eval
 import Info
 import qualified Map
@@ -123,7 +124,7 @@ functionModule =
   where
     bindEnv env =
       let Just name = envModuleName env
-       in (name, Binder emptyMeta (XObj (Mod env) Nothing Nothing))
+       in (name, Binder emptyMeta (XObj (Mod env E.empty) Nothing Nothing))
     bindings = Map.fromList (map (bindEnv . generateInnerFunctionModule) [0 .. maxArity])
 
 -- | Each arity of functions need their own module to enable copying and string representation
@@ -329,10 +330,10 @@ dynamicModule =
             f "help" primitiveHelp "prints help." "(help)"
           ]
     mods =
-      [ ("String", Binder emptyMeta (XObj (Mod dynamicStringModule) Nothing Nothing)),
+      [ ("String", Binder emptyMeta (XObj (Mod dynamicStringModule E.empty) Nothing Nothing)),
-        ("Symbol", Binder emptyMeta (XObj (Mod dynamicSymModule) Nothing Nothing)),
+        ("Symbol", Binder emptyMeta (XObj (Mod dynamicSymModule E.empty) Nothing Nothing)),
-        ("Project", Binder emptyMeta (XObj (Mod dynamicProjectModule) Nothing Nothing)),
+        ("Project", Binder emptyMeta (XObj (Mod dynamicProjectModule E.empty) Nothing Nothing)),
-        ("Path", Binder emptyMeta (XObj (Mod dynamicPathModule) Nothing Nothing))
+        ("Path", Binder emptyMeta (XObj (Mod dynamicPathModule E.empty) Nothing Nothing))
       ]
 
 -- | A submodule of the Dynamic module. Contains functions for working with strings in the repl or during compilation.
@@ -494,12 +495,12 @@ startingGlobalEnv noArray =
           makeSymbol "deref" "" "" Deref,
           makeSymbol "with" "" "" With
         ]
-          ++ [("Array", Binder emptyMeta (XObj (Mod arrayModule) Nothing Nothing)) | not noArray]
+          ++ [("Array", Binder emptyMeta (XObj (Mod arrayModule E.empty) Nothing Nothing)) | not noArray]
-          ++ [("StaticArray", Binder emptyMeta (XObj (Mod staticArrayModule) Nothing Nothing))]
+          ++ [("StaticArray", Binder emptyMeta (XObj (Mod staticArrayModule E.empty) Nothing Nothing))]
-          ++ [("Pointer", Binder emptyMeta (XObj (Mod pointerModule) Nothing Nothing))]
+          ++ [("Pointer", Binder emptyMeta (XObj (Mod pointerModule E.empty) Nothing Nothing))]
-          ++ [("Dynamic", Binder emptyMeta (XObj (Mod dynamicModule) Nothing Nothing))]
+          ++ [("Dynamic", Binder emptyMeta (XObj (Mod dynamicModule E.empty) Nothing Nothing))]
-          ++ [("Function", Binder emptyMeta (XObj (Mod functionModule) Nothing Nothing))]
+          ++ [("Function", Binder emptyMeta (XObj (Mod functionModule E.empty) Nothing Nothing))]
-          ++ [("Unsafe", Binder emptyMeta (XObj (Mod unsafeModule) Nothing Nothing))]
+          ++ [("Unsafe", Binder emptyMeta (XObj (Mod unsafeModule E.empty) Nothing Nothing))]
 
 -- | The type environment (containing deftypes and interfaces) before any code is run.
 startingTypeEnv :: Env

src/StaticArrayTemplates.hs

@@ -11,7 +11,7 @@ import Types
 -- since there are some small differences here and there I'v decided to not
 -- try to abstract over them and just duplicate the templates instead.
 concreteArray :: Ty
-concreteArray = ConcreteNameTy "StaticArray"
+concreteArray = ConcreteNameTy (SymPath [] "StaticArray")
 
 templateUnsafeNth :: (String, Binder)
 templateUnsafeNth =

src/Sumtypes.hs

@@ -1,14 +1,13 @@
 module Sumtypes where
 
 import Concretize
+import Context
 import Data.Maybe
 import Deftype
-import Env
+import Env (addListOfBindings, new)
 import Info
 import Managed
-import qualified Map
 import Obj
-import qualified Set
 import StructUtils
 import SumtypeCase
 import Template
@@ -25,13 +24,35 @@ getCase cases caseNameToFind =
     found : _ -> Just found
     [] -> Nothing
 
-moduleForSumtype :: Maybe Env -> TypeEnv -> Env -> [String] -> String -> [Ty] -> [XObj] -> Maybe Info -> Maybe Env -> Either TypeError (String, XObj, [XObj])
+moduleForSumtypeInContext :: Context -> String -> [Ty] -> [XObj] -> Maybe Info -> Either TypeError (String, XObj, [XObj])
+moduleForSumtypeInContext ctx name vars members info =
+  let global = contextGlobalEnv ctx
+      types = contextTypeEnv ctx
+      path = contextPath ctx
+      inner = either (const Nothing) Just (innermostModuleEnv ctx)
+      previous =
+        either
+          (const Nothing)
+          Just
+          ( (lookupBinderInInternalEnv ctx (SymPath path name))
+              <> (lookupBinderInGlobalEnv ctx (SymPath path name))
+                >>= \b ->
+                  replaceLeft
+                    (NotFoundGlobal (SymPath path name))
+                    ( case binderXObj b of
+                        XObj (Mod ev et) _ _ -> Right (ev, et)
+                        _ -> Left "Non module"
+                    )
+          )
+   in moduleForSumtype inner types global path name vars members info previous
+
+moduleForSumtype :: Maybe Env -> TypeEnv -> Env -> [String] -> String -> [Ty] -> [XObj] -> Maybe Info -> Maybe (Env, TypeEnv) -> Either TypeError (String, XObj, [XObj])
 moduleForSumtype innerEnv typeEnv env pathStrings typeName typeVariables rest i existingEnv =
-  let typeModuleName = typeName
+  let moduleValueEnv = fromMaybe (new innerEnv (Just typeName)) (fmap fst existingEnv)
-      typeModuleEnv = fromMaybe (Env (Map.fromList []) innerEnv (Just typeModuleName) Set.empty ExternalEnv 0) existingEnv
+      moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv)
-      insidePath = pathStrings ++ [typeModuleName]
+      insidePath = pathStrings ++ [typeName]
    in do
-        let structTy = StructTy (ConcreteNameTy (createStructName pathStrings typeName)) typeVariables
+        let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables
         cases <- toCases typeEnv typeVariables rest
         okIniters <- initers insidePath structTy cases
         okTag <- binderForTag insidePath structTy
@@ -40,9 +61,9 @@ moduleForSumtype innerEnv typeEnv env pathStrings typeName typeVariables rest i
         okDelete <- binderForDelete typeEnv env insidePath structTy cases
         (okCopy, okCopyDeps) <- binderForCopy typeEnv env insidePath structTy cases
         okMemberDeps <- memberDeps typeEnv cases
-        let moduleEnvWithBindings = addListOfBindings typeModuleEnv (okIniters ++ [okStr, okPrn, okDelete, okCopy, okTag])
+        let moduleEnvWithBindings = addListOfBindings moduleValueEnv (okIniters ++ [okStr, okPrn, okDelete, okCopy, okTag])
-            typeModuleXObj = XObj (Mod moduleEnvWithBindings) i (Just ModuleTy)
+            typeModuleXObj = XObj (Mod moduleEnvWithBindings moduleTypeEnv) i (Just ModuleTy)
-        pure (typeModuleName, typeModuleXObj, okMemberDeps ++ okCopyDeps ++ okStrDeps)
+        pure (typeName, typeModuleXObj, okMemberDeps ++ okCopyDeps ++ okStrDeps)
 
 memberDeps :: TypeEnv -> [SumtypeCase] -> Either TypeError [XObj]
 memberDeps typeEnv cases = fmap concat (mapM (concretizeType typeEnv) (concatMap caseTys cases))
@@ -108,13 +129,13 @@ genericCaseInit allocationMode pathStrings originalStructTy sumtypeCase =
           )
 
 tokensForCaseInit :: AllocationMode -> Ty -> SumtypeCase -> [Token]
-tokensForCaseInit allocationMode sumTy@(StructTy (ConcreteNameTy typeName) _) sumtypeCase =
+tokensForCaseInit allocationMode sumTy@(StructTy (ConcreteNameTy _) _) sumtypeCase =
   toTemplate $
     unlines
       [ "$DECL {",
         case allocationMode of
           StackAlloc -> "    $p instance;"
-          HeapAlloc -> "    $p instance = CARP_MALLOC(sizeof(" ++ typeName ++ "));",
+          HeapAlloc -> "    $p instance = CARP_MALLOC(sizeof(" ++ show sumTy ++ "));",
         joinLines $ caseMemberAssignment allocationMode correctedName . fst <$> unitless,
         "    instance._tag = " ++ tagName sumTy correctedName ++ ";",
         "    return instance;",
@@ -134,7 +155,7 @@ caseMemberAssignment allocationMode caseNm memberName =
       HeapAlloc -> "->u."
 
 binderForTag :: [String] -> Ty -> Either TypeError (String, Binder)
-binderForTag insidePath originalStructTy@(StructTy (ConcreteNameTy typeName) _) =
+binderForTag insidePath originalStructTy@(StructTy (ConcreteNameTy _) _) =
   Right $ instanceBinder path (FuncTy [RefTy originalStructTy (VarTy "q")] IntTy StaticLifetimeTy) template doc
   where
     path = SymPath insidePath "get-tag"
@@ -145,7 +166,7 @@ binderForTag insidePath originalStructTy@(StructTy (ConcreteNameTy typeName) _)
         (\(FuncTy [RefTy structTy _] IntTy _) -> toTemplate $ proto structTy ++ " { return p->_tag; }")
         (const [])
     proto structTy = "int $NAME(" ++ tyToCLambdaFix structTy ++ " *p)"
-    doc = "Gets the tag from a `" ++ typeName ++ "`."
+    doc = "Gets the tag from a `" ++ show originalStructTy ++ "`."
 binderForTag _ _ = error "binderfortag"
 
 -- | Helper function to create the binder for the 'str' template.
@@ -159,16 +180,16 @@ binderForStrOrPrn _ _ _ _ _ _ = error "binderforstrorprn"
 
 -- | The template for the 'str' function for a concrete deftype.
 concreteStr :: TypeEnv -> Env -> [String] -> Ty -> [SumtypeCase] -> String -> ((String, Binder), [XObj])
-concreteStr typeEnv env insidePath concreteStructTy@(StructTy (ConcreteNameTy typeName) _) cases strOrPrn =
+concreteStr typeEnv env insidePath concreteStructTy@(StructTy (ConcreteNameTy name) _) cases strOrPrn =
   instanceBinderWithDeps (SymPath insidePath strOrPrn) (FuncTy [RefTy concreteStructTy (VarTy "q")] StringTy StaticLifetimeTy) template doc
   where
-    doc = "converts a `" ++ typeName ++ "` to a string."
+    doc = "converts a `" ++ (show concreteStructTy) ++ "` to a string."
     template =
       Template
         (FuncTy [RefTy concreteStructTy (VarTy "q")] StringTy StaticLifetimeTy)
         (\(FuncTy [RefTy structTy _] StringTy _) -> toTemplate $ "String $NAME(" ++ tyToCLambdaFix structTy ++ " *p)")
         ( \(FuncTy [RefTy (StructTy _ _) _] StringTy _) ->
-            tokensForStr typeEnv env typeName cases concreteStructTy
+            tokensForStr typeEnv env (show name) cases concreteStructTy
         )
         ( \(FuncTy [RefTy (StructTy _ _) _] StringTy _) ->
             concatMap
@@ -179,12 +200,12 @@ concreteStr _ _ _ _ _ _ = error "concretestr"
 
 -- | The template for the 'str' function for a generic deftype.
 genericStr :: [String] -> Ty -> [SumtypeCase] -> String -> (String, Binder)
-genericStr insidePath originalStructTy@(StructTy (ConcreteNameTy typeName) _) cases strOrPrn =
+genericStr insidePath originalStructTy@(StructTy (ConcreteNameTy name) _) cases strOrPrn =
   defineTypeParameterizedTemplate templateCreator path t docs
   where
     path = SymPath insidePath strOrPrn
     t = FuncTy [RefTy originalStructTy (VarTy "q")] StringTy StaticLifetimeTy
-    docs = "stringifies a `" ++ show typeName ++ "`."
+    docs = "stringifies a `" ++ show originalStructTy ++ "`."
     templateCreator = TemplateCreator $
       \typeEnv env ->
         Template
@@ -195,7 +216,7 @@ genericStr insidePath originalStructTy@(StructTy (ConcreteNameTy typeName) _) ca
           ( \(FuncTy [RefTy concreteStructTy@(StructTy _ _) _] StringTy _) ->
               let mappings = unifySignatures originalStructTy concreteStructTy
                   correctedCases = replaceGenericTypesOnCases mappings cases
-               in tokensForStr typeEnv env typeName correctedCases concreteStructTy
+               in tokensForStr typeEnv env (show name) correctedCases concreteStructTy
           )
           ( \ft@(FuncTy [RefTy concreteStructTy@(StructTy _ _) _] StringTy _) ->
               let mappings = unifySignatures originalStructTy concreteStructTy
@@ -307,10 +328,10 @@ genericSumtypeDelete pathStrings originalStructTy cases =
 
 -- | The template for the 'delete' function of a concrete sumtype
 concreteSumtypeDelete :: [String] -> TypeEnv -> Env -> Ty -> [SumtypeCase] -> (String, Binder)
-concreteSumtypeDelete insidePath typeEnv env structTy@(StructTy (ConcreteNameTy typeName) _) cases =
+concreteSumtypeDelete insidePath typeEnv env structTy@(StructTy (ConcreteNameTy _) _) cases =
   instanceBinder (SymPath insidePath "delete") (FuncTy [structTy] UnitTy StaticLifetimeTy) template doc
   where
-    doc = "deletes a `" ++ typeName ++ "`. This should usually not be called manually."
+    doc = "deletes a `" ++ (show structTy) ++ "`. This should usually not be called manually."
     template =
       Template
         (FuncTy [VarTy "p"] UnitTy StaticLifetimeTy)
@@ -381,10 +402,10 @@ genericSumtypeCopy pathStrings originalStructTy cases =
 
 -- | The template for the 'copy' function of a concrete sumtype
 concreteSumtypeCopy :: [String] -> TypeEnv -> Env -> Ty -> [SumtypeCase] -> ((String, Binder), [XObj])
-concreteSumtypeCopy insidePath typeEnv env structTy@(StructTy (ConcreteNameTy typeName) _) cases =
+concreteSumtypeCopy insidePath typeEnv env structTy@(StructTy (ConcreteNameTy _) _) cases =
   instanceBinderWithDeps (SymPath insidePath "copy") (FuncTy [RefTy structTy (VarTy "q")] structTy StaticLifetimeTy) template doc
   where
-    doc = "copies a `" ++ typeName ++ "`."
+    doc = "copies a `" ++ (show structTy) ++ "`."
     template =
       Template
         (FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy)

src/SymPath.hs

@@ -5,6 +5,7 @@ module SymPath
     mangle,
     pathToC,
     consPath,
+    fromStrings,
   )
 where
 
@@ -89,3 +90,9 @@ pathToC (SymPath modulePath name) =
 consPath :: [String] -> SymPath -> SymPath
 consPath qualifyers (SymPath stringPaths name) =
   SymPath (qualifyers ++ stringPaths) name
+
+-- | Convert a list of strings into a path.
+fromStrings :: [String] -> SymPath
+fromStrings [] = SymPath [] ""
+fromStrings (s : []) = SymPath [] s
+fromStrings ss = SymPath (init ss) (last ss)

src/TypeError.hs

@@ -60,6 +60,7 @@ data TypeError
   | UsingDeadReference XObj String
   | UninhabitedConstructor Ty XObj Int Int
   | InconsistentKinds String [XObj]
+  | FailedToAddLambdaStructToTyEnv SymPath XObj
 
 instance Show TypeError where
   show (SymbolMissingType xobj env) =
@@ -305,6 +306,10 @@ instance Show TypeError where
     "Can't use a struct or sumtype constructor without arguments as a member type at " ++ prettyInfoFromXObj xobj ++ ". The type constructor " ++ show ty ++ " expects " ++ show wanted ++ " arguments but got " ++ show got
   show (InconsistentKinds varName xobjs) =
     " The type variable `" ++ varName ++ "` is used inconsistently: " ++ joinWithComma (map pretty (filter (doesTypeContainTyVarWithName varName . fromMaybe Universe . xobjToTy) xobjs)) ++ " Type variables must be applied to the same number of arguments."
+  show (FailedToAddLambdaStructToTyEnv path xobj) =
+    "Failed to add the lambda: " ++ show path ++ " represented by struct: "
+      ++ pretty xobj
+      ++ " to the type environment."
 
 machineReadableErrorStrings :: FilePathPrintLength -> TypeError -> [String]
 machineReadableErrorStrings fppl err =
@@ -421,6 +426,11 @@ machineReadableErrorStrings fppl err =
       [machineReadableInfoFromXObj fppl xobj ++ "Can't use a struct or sumtype constructor without arguments as a member type at " ++ prettyInfoFromXObj xobj ++ ". The type constructor " ++ show ty ++ " expects " ++ show wanted ++ " arguments but got " ++ show got]
     (InconsistentKinds varName xobjs) ->
       [machineReadableInfoFromXObj fppl (head xobjs) ++ " The type variable `" ++ varName ++ "` is used inconsistently: " ++ joinWithComma (map pretty (filter (doesTypeContainTyVarWithName varName . fromMaybe Universe . xobjToTy) xobjs)) ++ " Type variables must be applied to the same number of arguments."]
+    (FailedToAddLambdaStructToTyEnv path xobj) ->
+      [ machineReadableInfoFromXObj fppl xobj ++ "Failed to add the lambda: " ++ show path ++ " represented by struct: "
+          ++ pretty xobj
+          ++ " to the type environment."
+      ]
     _ ->
       [show err]
 
@@ -473,7 +483,7 @@ keysInEnvEditDistance path@(SymPath (p : ps) name) env distance =
   case Map.lookup p (envBindings env) of
     Just (Binder _ xobj) ->
       case xobj of
-        (XObj (Mod modEnv) _ _) -> keysInEnvEditDistance (SymPath ps name) modEnv distance
+        (XObj (Mod modEnv _) _ _) -> keysInEnvEditDistance (SymPath ps name) modEnv distance
         _ -> []
     Nothing ->
       case envParent env of

src/Types.hs

@@ -26,6 +26,7 @@ module Types
     getStructName,
     getPathFromStructName,
     getNameFromStructName,
+    getStructPath,
     promoteNumber,
   )
 where
@@ -60,7 +61,7 @@ data Ty
   | RefTy Ty Ty -- second Ty is the lifetime
   | StaticLifetimeTy
   | StructTy Ty [Ty] -- the name (possibly a var) of the struct, and it's type parameters
-  | ConcreteNameTy String -- the name of a struct
+  | ConcreteNameTy SymPath -- the name of a struct
   | TypeTy -- the type of types
   | MacroTy
   | DynamicTy -- the type of dynamic functions (used in REPL and macros)
@@ -179,7 +180,7 @@ instance Show Ty where
   show InterfaceTy = "Interface"
   show (StructTy s []) = show s
   show (StructTy s typeArgs) = "(" ++ show s ++ " " ++ joinWithSpace (map show typeArgs) ++ ")"
-  show (ConcreteNameTy name) = name
+  show (ConcreteNameTy spath) = show spath
   show (PointerTy p) = "(Ptr " ++ show p ++ ")"
   show (RefTy r lt) =
     -- case r of
@@ -336,13 +337,13 @@ typesDeleterFunctionType memberType = FuncTy [memberType] UnitTy StaticLifetimeT
 
 -- | The type of environments sent to Lambdas (used in emitted C code)
 lambdaEnvTy :: Ty
-lambdaEnvTy = StructTy (ConcreteNameTy "LambdaEnv") []
+lambdaEnvTy = StructTy (ConcreteNameTy (SymPath [] "LambdaEnv")) []
 
 createStructName :: [String] -> String -> String
 createStructName path name = intercalate "." (path ++ [name])
 
 getStructName :: Ty -> String
-getStructName (StructTy (ConcreteNameTy name) _) = name
+getStructName (StructTy (ConcreteNameTy spath) _) = show spath
 getStructName (StructTy (VarTy name) _) = name
 getStructName _ = ""
 
@@ -354,6 +355,11 @@ getPathFromStructName structName =
 getNameFromStructName :: String -> String
 getNameFromStructName structName = last (map unpack (splitOn (pack ".") (pack structName)))
 
+getStructPath :: Ty -> SymPath
+getStructPath (StructTy (ConcreteNameTy spath) _) = spath
+getStructPath (StructTy (VarTy name) _) = (SymPath [] name)
+getStructPath _ = (SymPath [] "")
+
 -- N.B.: promoteNumber is only safe for numeric types!
 promoteNumber :: Ty -> Ty -> Ty
 promoteNumber a b | a == b = a

src/TypesToC.hs

@@ -44,7 +44,7 @@ tyToCManglePtr _ ty = f ty
     f (FuncTy argTys retTy _) = "Fn__" ++ joinWithUnderscore (map (tyToCManglePtr True) argTys) ++ "_" ++ tyToCManglePtr True retTy
     f (StructTy s []) = tyToCManglePtr False s
     f (StructTy s typeArgs) = tyToCManglePtr False s ++ "__" ++ joinWithUnderscore (map (tyToCManglePtr True) typeArgs)
-    f (ConcreteNameTy name) = mangle (intercalate "" (map unpack (splitOn (pack ".") (pack name))))
+    f (ConcreteNameTy spath) = mangle (intercalate "" (map unpack (splitOn (pack ".") (pack (show spath)))))
     f ModuleTy = err "modules"
     f TypeTy = err "types"
     f MacroTy = err "macros"

src/Util.hs

@@ -1,5 +1,6 @@
 module Util where
 
+import Data.Bifunctor
 import Data.List
 import Data.Maybe (fromMaybe)
 import qualified Map
@@ -116,3 +117,15 @@ intToArgName 7 = "t"
 intToArgName 8 = "s"
 intToArgName 9 = "r"
 intToArgName n = intToArgName 1 ++ intToArgName (n `div` 10)
+
+replaceLeft :: b -> Either a c -> Either b c
+replaceLeft x e = first (const x) e
+
+unwrapErr :: Show e => Either e a -> Either String a
+unwrapErr = first show
+
+toMaybe :: (b -> c) -> Either a b -> Maybe c
+toMaybe f e = either (const Nothing) (Just . f) e
+
+maybeId :: Either a b -> Maybe b
+maybeId = toMaybe id

src/Validate.hs

@@ -4,7 +4,7 @@ import Control.Monad (foldM)
 import Data.Function (on)
 import Data.List (nubBy, (\\))
 import Data.Maybe (fromJust)
-import Lookup
+import qualified Env as E
 import Obj
 import TypeError
 import TypePredicates
@@ -104,21 +104,19 @@ canBeUsedAsMemberType typeEnv typeVariables ty xobj =
     _ -> Left (InvalidMemberType ty xobj)
   where
     checkStruct :: Ty -> [Ty] -> Either TypeError ()
-    checkStruct (ConcreteNameTy "Array") [innerType] =
+    checkStruct (ConcreteNameTy (SymPath [] "Array")) [innerType] =
       canBeUsedAsMemberType typeEnv typeVariables innerType xobj
         >> pure ()
-    checkStruct (ConcreteNameTy n) vars =
+    checkStruct (ConcreteNameTy (SymPath _ name)) vars =
-      case lookupBinder (SymPath lookupPath name) (getTypeEnv typeEnv) of
+      case E.getTypeBinder typeEnv name of
-        Just (Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) ->
+        Right (Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) ->
           pure ()
-        Just (Binder _ (XObj (Lst (XObj (Deftype t) _ _ : _)) _ _)) ->
+        Right (Binder _ (XObj (Lst (XObj (Deftype t) _ _ : _)) _ _)) ->
           checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType typeEnv typeVariables typ xobj) () vars
-        Just (Binder _ (XObj (Lst (XObj (DefSumtype t) _ _ : _)) _ _)) ->
+        Right (Binder _ (XObj (Lst (XObj (DefSumtype t) _ _ : _)) _ _)) ->
           checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType typeEnv typeVariables typ xobj) () vars
         _ -> Left (NotAmongRegisteredTypes ty xobj)
       where
-        lookupPath = getPathFromStructName n
-        name = getNameFromStructName n
         checkInhabitants :: Ty -> Either TypeError ()
         checkInhabitants (StructTy _ vs) =
           if length vs == length vars

test/TestConstraints.hs

@@ -116,16 +116,16 @@ testConstr10 =
 
 testConstr11 =
   assertSolution
-    [Constraint (PointerTy (VarTy "a")) (PointerTy (StructTy (ConcreteNameTy "Monkey") [])) x x x OrdNo]
+    [Constraint (PointerTy (VarTy "a")) (PointerTy (StructTy (ConcreteNameTy (SymPath [] "Monkey")) [])) x x x OrdNo]
-    [("a", (StructTy (ConcreteNameTy "Monkey") []))]
+    [("a", (StructTy (ConcreteNameTy (SymPath [] "Monkey")) []))]
 
 testConstr12 =
   assertSolution
-    [ Constraint t1 (PointerTy (StructTy (ConcreteNameTy "Array") [IntTy])) x x x OrdNo,
+    [ Constraint t1 (PointerTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [IntTy])) x x x OrdNo,
       Constraint t1 (PointerTy t2) x x x OrdNo
     ]
-    [ ("t1", (PointerTy (StructTy (ConcreteNameTy "Array") [IntTy]))),
+    [ ("t1", (PointerTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [IntTy]))),
-      ("t2", (StructTy (ConcreteNameTy "Array") [IntTy]))
+      ("t2", (StructTy (ConcreteNameTy (SymPath [] "Array")) [IntTy]))
     ]
 
 testConstr13 =
@@ -144,36 +144,36 @@ testConstr13 =
 -- Struct types
 testConstr20 =
   assertSolution
-    [ Constraint t0 (StructTy (ConcreteNameTy "Vector") [t1]) x x x OrdNo,
+    [ Constraint t0 (StructTy (ConcreteNameTy (SymPath [] "Vector")) [t1]) x x x OrdNo,
-      Constraint t0 (StructTy (ConcreteNameTy "Vector") [IntTy]) x x x OrdNo
+      Constraint t0 (StructTy (ConcreteNameTy (SymPath [] "Vector")) [IntTy]) x x x OrdNo
     ]
-    [("t0", (StructTy (ConcreteNameTy "Vector") [IntTy])), ("t1", IntTy)]
+    [("t0", (StructTy (ConcreteNameTy (SymPath [] "Vector")) [IntTy])), ("t1", IntTy)]
 
 testConstr21 =
   assertSolution
-    [ Constraint t1 (StructTy (ConcreteNameTy "Array") [t2]) x x x OrdNo,
+    [ Constraint t1 (StructTy (ConcreteNameTy (SymPath [] "Array")) [t2]) x x x OrdNo,
-      Constraint t1 (StructTy (ConcreteNameTy "Array") [t3]) x x x OrdNo,
+      Constraint t1 (StructTy (ConcreteNameTy (SymPath [] "Array")) [t3]) x x x OrdNo,
       Constraint t3 BoolTy x x x OrdNo
     ]
-    [ ("t1", (StructTy (ConcreteNameTy "Array") [BoolTy])),
+    [ ("t1", (StructTy (ConcreteNameTy (SymPath [] "Array")) [BoolTy])),
       ("t2", BoolTy),
       ("t3", BoolTy)
     ]
 
 testConstr22 =
   assertSolution
-    [ Constraint t1 (StructTy (ConcreteNameTy "Array") [t2]) x x x OrdNo,
+    [ Constraint t1 (StructTy (ConcreteNameTy (SymPath [] "Array")) [t2]) x x x OrdNo,
-      Constraint t2 (StructTy (ConcreteNameTy "Array") [t3]) x x x OrdNo,
+      Constraint t2 (StructTy (ConcreteNameTy (SymPath [] "Array")) [t3]) x x x OrdNo,
       Constraint t3 FloatTy x x x OrdNo
     ]
-    [ ("t1", (StructTy (ConcreteNameTy "Array") [(StructTy (ConcreteNameTy "Array") [FloatTy])])),
+    [ ("t1", (StructTy (ConcreteNameTy (SymPath [] "Array")) [(StructTy (ConcreteNameTy (SymPath [] "Array")) [FloatTy])])),
-      ("t2", (StructTy (ConcreteNameTy "Array") [FloatTy])),
+      ("t2", (StructTy (ConcreteNameTy (SymPath [] "Array")) [FloatTy])),
       ("t3", FloatTy)
     ]
 
 testConstr23 =
   assertUnificationFailure
-    [ Constraint (StructTy (ConcreteNameTy "Array") [t1]) (StructTy (ConcreteNameTy "Array") [t2]) x x x OrdNo,
+    [ Constraint (StructTy (ConcreteNameTy (SymPath [] "Array")) [t1]) (StructTy (ConcreteNameTy (SymPath [] "Array")) [t2]) x x x OrdNo,
       Constraint t1 IntTy x x x OrdNo,
       Constraint t2 FloatTy x x x OrdNo
     ]
@@ -182,7 +182,7 @@ testConstr24 =
   assertUnificationFailure
     [ Constraint t2 FloatTy x x x OrdNo,
       Constraint t1 IntTy x x x OrdNo,
-      Constraint (StructTy (ConcreteNameTy "Array") [t1]) (StructTy (ConcreteNameTy "Array") [t2]) x x x OrdNo
+      Constraint (StructTy (ConcreteNameTy (SymPath [] "Array")) [t1]) (StructTy (ConcreteNameTy (SymPath [] "Array")) [t2]) x x x OrdNo
     ]
 
 -- m9 = solve [Constraint (StructTy "Vector" [IntTy]) (StructTy "Vector" [t1]) x x x OrdNo]
@@ -219,10 +219,10 @@ testConstr33 =
 
 testConstr34 =
   assertSolution
-    [ Constraint (VarTy "a") (StructTy (ConcreteNameTy "Pair") [(VarTy "x0"), (VarTy "y0")]) x x x OrdNo,
+    [ Constraint (VarTy "a") (StructTy (ConcreteNameTy (SymPath [] "Pair")) [(VarTy "x0"), (VarTy "y0")]) x x x OrdNo,
-      Constraint (StructTy (ConcreteNameTy "Array") [(VarTy "a")]) (StructTy (ConcreteNameTy "Array") [(StructTy (ConcreteNameTy "Pair") [(VarTy "x1"), (VarTy "y1")])]) x x x OrdNo
+      Constraint (StructTy (ConcreteNameTy (SymPath [] "Array")) [(VarTy "a")]) (StructTy (ConcreteNameTy (SymPath [] "Array")) [(StructTy (ConcreteNameTy (SymPath [] "Pair")) [(VarTy "x1"), (VarTy "y1")])]) x x x OrdNo
     ]
-    [ ("a", (StructTy (ConcreteNameTy "Pair") [(VarTy "x0"), (VarTy "y0")])),
+    [ ("a", (StructTy (ConcreteNameTy (SymPath [] "Pair")) [(VarTy "x0"), (VarTy "y0")])),
       ("x0", (VarTy "x0")),
       ("y0", (VarTy "y0")),
       ("x1", (VarTy "x0")),
@@ -232,10 +232,10 @@ testConstr34 =
 -- Same as testConstr34, except everything is wrapped in refs
 testConstr35 =
   assertSolution
-    [ Constraint (RefTy (VarTy "a") (VarTy "lt0")) (RefTy (StructTy (ConcreteNameTy "Pair") [(VarTy "x0"), (VarTy "y0")]) (VarTy "lt1")) x x x OrdNo,
+    [ Constraint (RefTy (VarTy "a") (VarTy "lt0")) (RefTy (StructTy (ConcreteNameTy (SymPath [] "Pair")) [(VarTy "x0"), (VarTy "y0")]) (VarTy "lt1")) x x x OrdNo,
-      Constraint (RefTy (StructTy (ConcreteNameTy "Array") [(VarTy "a")]) (VarTy "lt2")) (RefTy (StructTy (ConcreteNameTy "Array") [(StructTy (ConcreteNameTy "Pair") [(VarTy "x1"), (VarTy "y1")])]) (VarTy "lt3")) x x x OrdNo
+      Constraint (RefTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [(VarTy "a")]) (VarTy "lt2")) (RefTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [(StructTy (ConcreteNameTy (SymPath [] "Pair")) [(VarTy "x1"), (VarTy "y1")])]) (VarTy "lt3")) x x x OrdNo
     ]
-    [ ("a", (StructTy (ConcreteNameTy "Pair") [(VarTy "x0"), (VarTy "y0")])),
+    [ ("a", (StructTy (ConcreteNameTy (SymPath [] "Pair")) [(VarTy "x0"), (VarTy "y0")])),
       ("x0", (VarTy "x0")),
       ("y0", (VarTy "y0")),
       ("x1", (VarTy "x0")),

test/TestLookup.hs

@@ -1,6 +1,6 @@
 module TestLookup where
 
-import qualified Lookup as Lookup
+import Env as E
 import qualified Map
 import Obj
 import qualified Set
@@ -16,9 +16,9 @@ b1 = Binder emptyMeta (XObj (Str "b1") Nothing (Just StringTy))
 
 emptyRootEnv = Env (Map.fromList []) Nothing Nothing Set.empty ExternalEnv 0
 
-assertNotFound :: Maybe Binder -> Test
+assertNotFound :: Either EnvironmentError Binder -> Test
-assertNotFound Nothing = TestCase (assertBool "assertNotFound" True) -- Better way?
+assertNotFound (Left _) = TestCase (assertBool "assertNotFound" True) -- Better way?
 assertNotFound _ = TestCase (assertBool "assertNotFound" False)
 
 basicLookup :: Test
-basicLookup = assertNotFound (fmap snd (Lookup.lookupInEnv (SymPath [] "nonexisting") emptyRootEnv))
+basicLookup = assertNotFound (fmap snd (E.searchValue emptyRootEnv (SymPath [] "nonexisting")))

test/deftype.carp

@@ -9,6 +9,9 @@
 (defmodule Wrap2
   (deftype C []))
 (use Wrap2)
+(use Wrap)
+
+(deftype B [])
 
 (deftest test
   (assert-equal test
@@ -23,4 +26,8 @@
     "(Wrap2.C)"
     (ref (str (ref (C))))
     "implicit .init for 'use':d type defined inside module works")
+  (assert-equal test
+    "(B)"
+    (ref (str (ref (B))))
+    "when module and global types compete, global types are preffered.")
   )