refactor: Clean up memory management functions (#1240)

* refactor: Mid-refactor save point.

* feat: Code compiles

* refactor: Remove unused imports

* refactor: Move functions out of massive `manageMemory` block

* refactor: Move out even more functions from `manageMemory`

* refactor: Made most patterns match on "head form" of each s-expression

e.g. (if a b c) matches on 'if', 'a', 'b' and 'c'

* refactor: Use the pattern synonyms in Memory

* refactor: Remove a little cruft

* refactor: whenOK function

* refactor: Use 'whenRight' functions to avoid directly matching on Either

* docs: Comment the 'getConcretizedPath' function

* refactor: Move functionFinding-functions into Polymorphism module

CarpHask.cabal

@@ -37,6 +37,7 @@ library
                        Interfaces,
                        Managed,
                        Map,
+                       Memory,
                        Meta,
                        Obj,
                        Parsing,

app/Main.hs

@@ -125,9 +125,9 @@ main = do
           []
       coreModulesToLoad = if core then coreModules (projectCarpDir project) else []
       execStr :: String -> String -> Context -> IO Context
-      execStr info str ctx = executeString True False ctx str info
+      execStr i s ctx = executeString True False ctx s i
       execStrs :: String -> [String] -> Context -> IO Context
-      execStrs info strs ctx = foldM (\ctx str -> execStr info str ctx) ctx strs
+      execStrs i strs ctx = foldM (\ctx' str' -> execStr i str' ctx') ctx strs
       preloads = optPreload fullOpts
       postloads = optPostload fullOpts
       load = flip loadFiles

src/ArrayTemplates.hs

@@ -4,6 +4,7 @@ module ArrayTemplates where
 
 import Concretize
 import Obj
+import Polymorphism
 import StructUtils
 import Template
 import ToTemplate

src/Concretize.hs

@@ -5,19 +5,18 @@ 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 (envIsExternal, findPoly, getTypeBinder, getValue, insert, insertX, lookupEverywhere, searchValue)
+import Env (envIsExternal, getTypeBinder, insert, insertX, searchValue)
 import Info
 import InitialTypes
 import Managed
 import qualified Map
+import Memory (manageMemory)
 import Obj
 import Polymorphism
 import Reify
-import Set ((\\))
 import qualified Set
 import SumtypeCase
 import ToTemplate
@@ -700,7 +699,8 @@ concretizeDefinition allowAmbiguity typeEnv globalEnv visitedDefinitions definit
                     then pure (withNewPath, [])
                     else do
                       (concrete, deps) <- concretizeXObj allowAmbiguity typeEnv globalEnv (newPath : visitedDefinitions) typed
-                      (managed, memDeps) <- manageMemory typeEnv globalEnv concrete
+                      (managed, memDepsTys) <- manageMemory typeEnv globalEnv concrete
+                      let memDeps = depsForDeleteFuncs typeEnv globalEnv memDepsTys
                       pure (managed, deps ++ memDeps)
                 Left e -> Left e
         XObj (Lst (XObj (Defn _) _ _ : _)) _ _ ->
@@ -712,7 +712,8 @@ concretizeDefinition allowAmbiguity typeEnv globalEnv visitedDefinitions definit
                     then pure (withNewPath, [])
                     else do
                       (concrete, deps) <- concretizeXObj allowAmbiguity typeEnv globalEnv (newPath : visitedDefinitions) typed
-                      (managed, memDeps) <- manageMemory typeEnv globalEnv concrete
+                      (managed, memDepsTys) <- manageMemory typeEnv globalEnv concrete
+                      let memDeps = depsForDeleteFuncs typeEnv globalEnv memDepsTys
                       pure (managed, deps ++ memDeps)
                 Left e -> Left e
         XObj (Lst (XObj (Deftemplate (TemplateCreator templateCreator)) _ _ : _)) _ _ ->
@@ -738,31 +739,6 @@ concretizeDefinition allowAmbiguity typeEnv globalEnv visitedDefinitions definit
         _ ->
           Left $ CannotConcretize definition
 
--- | Find ALL functions with a certain name, matching a type signature.
--- When the functionName argument denotes an interface, the name will match iff either:
---   1. The name of the binding matches functionName exactly OR
---   2. The name of the binding matches one of the names in the interface's implementation paths
--- 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)
-  where
-    predicate (Just t) =
-      --trace ("areUnifiable? " ++ show functionType ++ " == " ++ show t ++ " " ++ show (areUnifiable functionType t)) $
-      areUnifiable functionType t
-    predicate Nothing = error "allfunctionswithnameandsignature"
-    foundBindings = case getTypeBinder typeEnv functionName of
-      -- this function is an interface; lookup implementations
-      Right (Binder _ (XObj (Lst (XObj (Interface _ paths) _ _ : _)) _ _)) ->
-        case sequence $ map (\p -> searchValue env p) (paths ++ [(SymPath [] functionName)]) of
-          Right found -> found
-          Left _ ->
-            case findPoly env functionName functionType of
-              Right r -> [r]
-              Left _ -> (lookupEverywhere env functionName)
-      -- just a regular function; look for it
-      _ -> 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]
 depsOfPolymorphicFunction typeEnv env visitedDefinitions functionName functionType =
@@ -788,6 +764,10 @@ depsForDeleteFunc typeEnv env t =
     then depsOfPolymorphicFunction typeEnv env [] "delete" (FuncTy [t] UnitTy StaticLifetimeTy)
     else []
 
+-- | Helper for finding the 'delete' functions for several types.
+depsForDeleteFuncs :: TypeEnv -> Env -> Set.Set Ty -> [XObj]
+depsForDeleteFuncs typeEnv env tys = concatMap (depsForDeleteFunc typeEnv env) (Set.toList tys)
+
 -- | Helper for finding the 'copy' function for a type.
 depsForCopyFunc :: TypeEnv -> Env -> Ty -> [XObj]
 depsForCopyFunc typeEnv env t =
@@ -809,788 +789,6 @@ typesStrFunctionType typeEnv env memberType =
     then FuncTy [RefTy memberType (VarTy "q")] StringTy StaticLifetimeTy
     else FuncTy [memberType] StringTy StaticLifetimeTy
 
--- | The various results when trying to find a function using 'findFunctionForMember'.
-data FunctionFinderResult
-  = FunctionFound String
-  | FunctionNotFound String
-  | FunctionIgnored
-  deriving (Show)
-
--- | TODO: COMMENT THIS
-getConcretizedPath :: XObj -> Ty -> SymPath
-getConcretizedPath single functionType =
-  let Just t' = xobjTy single
-      (SymPath pathStrings name) = getPath single
-      suffix = polymorphicSuffix t' functionType
-   in SymPath pathStrings (name ++ suffix)
-
--- | Used for finding functions like 'delete' or 'copy' for members of a Deftype (or Array).
-findFunctionForMember :: TypeEnv -> Env -> String -> Ty -> (String, Ty) -> FunctionFinderResult
-findFunctionForMember typeEnv env functionName functionType (memberName, memberType)
-  | isManaged typeEnv env memberType =
-    case allImplementations typeEnv env functionName functionType of
-      [] ->
-        FunctionNotFound
-          ( "Can't find any '" ++ functionName ++ "' function for member '"
-              ++ memberName
-              ++ "' of type "
-              ++ show functionType
-          )
-      [(_, Binder _ single)] ->
-        let concretizedPath = getConcretizedPath single functionType
-         in FunctionFound (pathToC concretizedPath)
-      _ ->
-        FunctionNotFound
-          ( "Can't find a single '" ++ functionName ++ "' function for member '"
-              ++ memberName
-              ++ "' of type "
-              ++ show functionType
-          )
-  | otherwise = FunctionIgnored
-
--- | TODO: should this be the default and 'findFunctionForMember' be the specific one
-findFunctionForMemberIncludePrimitives :: TypeEnv -> Env -> String -> Ty -> (String, Ty) -> FunctionFinderResult
-findFunctionForMemberIncludePrimitives typeEnv env functionName functionType (memberName, _) =
-  case allImplementations typeEnv env functionName functionType of
-    [] ->
-      FunctionNotFound
-        ( "Can't find any '" ++ functionName ++ "' function for member '"
-            ++ memberName
-            ++ "' of type "
-            ++ show functionType
-        )
-    [(_, Binder _ single)] ->
-      let concretizedPath = getConcretizedPath single functionType
-       in FunctionFound (pathToC concretizedPath)
-    _ ->
-      FunctionNotFound
-        ( "Can't find a single '" ++ functionName ++ "' function for member '"
-            ++ memberName
-            ++ "' of type "
-            ++ show functionType
-        )
-
--- | Manage memory needs access to the concretizer
--- | (and the concretizer needs to manage memory)
--- | so they are put into the same module.
-
--- | Assign a set of Deleters to the 'infoDelete' field on Info.
-setDeletersOnInfo :: Maybe Info -> Set.Set Deleter -> Maybe Info
-setDeletersOnInfo i deleters = fmap (\i' -> i' {infoDelete = deleters}) i
-
-addDeletersToInfo :: Maybe Info -> Set.Set Deleter -> Maybe Info
-addDeletersToInfo i deleters =
-  fmap (\i' -> i' {infoDelete = Set.union (infoDelete i') deleters}) i
-
--- | Helper function for setting the deleters for an XObj.
-del :: XObj -> Set.Set Deleter -> XObj
-del xobj deleters = xobj {xobjInfo = setDeletersOnInfo (xobjInfo xobj) deleters}
-
--- | Differentiate between lifetimes depending on variables in a lexical scope and depending on something outside the function
-data LifetimeMode
-  = LifetimeInsideFunction String
-  | LifetimeOutsideFunction
-  deriving (Show)
-
--- | To keep track of the deleters when recursively walking the form.
-data MemState = MemState
-  { memStateDeleters :: Set.Set Deleter,
-    memStateDeps :: [XObj],
-    memStateLifetimes :: Map.Map String LifetimeMode
-  }
-  deriving (Show)
-
-prettyLifetimeMappings :: Map.Map String LifetimeMode -> String
-prettyLifetimeMappings mappings =
-  joinLines (map prettyMapping (Map.toList mappings))
-  where
-    prettyMapping (key, value) = "  " ++ key ++ " => " ++ show value
-
--- | Find out what deleters are needed and where in an XObj.
--- | Deleters will be added to the info field on XObj so that
--- | the code emitter can access them and insert calls to destructors.
-manageMemory :: TypeEnv -> Env -> XObj -> Either TypeError (XObj, [XObj])
-manageMemory typeEnv globalEnv root =
-  let (finalObj, finalState) = runState (visit root) (MemState (Set.fromList []) [] Map.empty)
-      deleteThese = memStateDeleters finalState
-      deps = memStateDeps finalState
-   in -- (trace ("Delete these: " ++ joinWithComma (map show (Set.toList deleteThese)))) $
-      case finalObj of
-        Left err -> Left err
-        Right ok ->
-          let newInfo = fmap (\i -> i {infoDelete = deleteThese}) (xobjInfo ok)
-           in -- This final check of lifetimes works on the lifetimes mappings after analyzing the function form, and
-              --  after all the local variables in it have been deleted. This is needed for values that are created
-              --  directly in body position, e.g. (defn f [] &[1 2 3])
-              case evalState (checkThatRefTargetIsAlive ok) (MemState (Set.fromList []) [] (memStateLifetimes finalState)) of
-                Left err -> Left err
-                Right _ -> Right (ok {xobjInfo = newInfo}, deps)
-  where
-    visit :: XObj -> State MemState (Either TypeError XObj)
-    visit xobj =
-      do
-        r <- case xobjObj xobj of
-          Lst _ -> visitList xobj
-          Arr _ -> visitArray xobj
-          StaticArr _ -> visitStaticArray xobj
-          Str _ -> do
-            manage xobj
-            addToLifetimesMappingsIfRef False xobj -- TODO: Should "internal = True" here? TODO: Possible to remove this one?
-            pure (Right xobj)
-          Pattern _ -> do
-            manage xobj
-            addToLifetimesMappingsIfRef False xobj -- TODO: Also possible to remove, *should* be superseeded by (***) below?
-            pure (Right xobj)
-          _ ->
-            pure (Right xobj)
-        case r of
-          Right ok -> do
-            MemState {} <- get
-            r' <- checkThatRefTargetIsAlive ok -- trace ("CHECKING " ++ pretty ok ++ " : " ++ showMaybeTy (ty xobj) ++ ", mappings: " ++ prettyLifetimeMappings m) $
-            addToLifetimesMappingsIfRef True ok -- (***)
-            pure r'
-          Left err -> pure (Left err)
-    visitArray :: XObj -> State MemState (Either TypeError XObj)
-    visitArray xobj@(XObj (Arr arr) _ _) =
-      do
-        mapM_ visit arr
-        results <- mapM unmanage arr
-        case sequence results of
-          Left e -> pure (Left e)
-          Right _ ->
-            do
-              _ <- manage xobj -- TODO: result is discarded here, is that OK?
-              pure (Right xobj)
-    visitArray _ = error "Must visit array."
-    visitStaticArray :: XObj -> State MemState (Either TypeError XObj)
-    visitStaticArray xobj@(XObj (StaticArr arr) _ _) =
-      do
-        mapM_ visit arr
-        results <- mapM unmanage arr
-        case sequence results of
-          Left e -> pure (Left e)
-          Right _ ->
-            -- We know that we want to add a deleter for the static array here
-            do
-              let var = varOfXObj 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
-                    Nothing ->
-                      error ("No deleter found for Static Array : " ++ show t) --Just (FakeDeleter var)
-              MemState deleters deps lifetimes <- get
-              let newDeleters = Set.insert deleter deleters
-                  newDeps = deps ++ depsForDeleteFunc typeEnv globalEnv t
-                  newState = MemState newDeleters newDeps lifetimes
-              put newState --(trace (show newState) newState)
-              pure (Right xobj)
-    visitStaticArray _ = error "Must visit static array."
-    visitList :: XObj -> State MemState (Either TypeError XObj)
-    visitList xobj@(XObj (Lst lst) i t) =
-      case lst of
-        [defn@(XObj (Defn maybeCaptures) _ _), nameSymbol@(XObj (Sym _ _) _ _), args@(XObj (Arr argList) _ _), body] ->
-          let captures = maybe [] Set.toList maybeCaptures
-           in --case defnReturnType of
-              -- RefTy _ _ ->
-              --   pure (Left (FunctionsCantReturnRefTy xobj funcTy))
-              --  _ ->
-              do
-                mapM_ manage argList
-                -- Add the captured variables (if any, only happens in lifted lambdas) as fake deleters
-                -- TODO: Use another kind of Deleter for this case since it's pretty special?
-                mapM_
-                  ( ( \cap ->
-                        modify
-                          ( \memState ->
-                              memState {memStateDeleters = Set.insert (FakeDeleter cap) (memStateDeleters memState)}
-                          )
-                    )
-                      . getName
-                  )
-                  captures
-                mapM_ (addToLifetimesMappingsIfRef False) argList
-                mapM_ (addToLifetimesMappingsIfRef False) captures -- For captured variables inside of lifted lambdas
-                visitedBody <- visit body
-                result <- unmanage body
-                pure $
-                  case result of
-                    Left e -> Left e
-                    Right _ ->
-                      do
-                        okBody <- visitedBody
-                        pure (XObj (Lst [defn, nameSymbol, args, okBody]) i t)
-        -- Fn / λ (Lambda)
-        [fn@(XObj (Fn _ captures) _ _), args@(XObj (Arr _) _ _), body] ->
-          do
-            manage xobj -- manage inner lambdas but leave their bodies unvisited, they will be visited in the lifted version...
-            mapM_ unmanage captures
-            pure (Right (XObj (Lst [fn, args, body]) i t))
-        -- Def
-        [def@(XObj Def _ _), nameSymbol@(XObj (Sym _ _) _ _), expr] ->
-          do
-            visitedExpr <- visit expr
-            result <- unmanage expr
-            pure $
-              case result of
-                Left e -> Left e
-                Right () ->
-                  do
-                    okExpr <- visitedExpr
-                    pure (XObj (Lst [def, nameSymbol, okExpr]) i t)
-        -- Let
-        [letExpr@(XObj Let _ _), XObj (Arr bindings) bindi bindt, body] ->
-          do
-            MemState preDeleters _ _ <- get
-            visitedBindings <- mapM visitLetBinding (pairwise bindings)
-            visitedBody <- visit body
-            result <- unmanage body
-            case result of
-              Left e -> pure (Left e)
-              Right _ ->
-                do
-                  MemState postDeleters deps postLifetimes <- get
-                  let diff = postDeleters Set.\\ preDeleters
-                      newInfo = setDeletersOnInfo i diff
-                      survivors = postDeleters Set.\\ diff -- Same as just pre deleters, right?!
-                  put (MemState survivors deps postLifetimes)
-                  --trace ("LET Pre: " ++ show preDeleters ++ "\nPost: " ++ show postDeleters ++ "\nDiff: " ++ show diff ++ "\nSurvivors: " ++ show survivors)
-                  manage xobj
-                  pure $ do
-                    okBody <- visitedBody
-                    let finalBody = searchForInnerBreak diff okBody
-                    okBindings <- fmap (concatMap (\(n, x) -> [n, x])) (sequence visitedBindings)
-                    pure (XObj (Lst [letExpr, XObj (Arr okBindings) bindi bindt, finalBody]) newInfo t)
-        -- Set!
-        [setbangExpr@(XObj SetBang _ _), variable, value] ->
-          let varInfo = xobjInfo variable
-              correctVariableAndMode =
-                case variable of
-                  -- DISABLE FOR NOW: (XObj (Lst (XObj (Sym (SymPath _ "copy") _) _ _ : symObj@(XObj (Sym _ _) _ _) : _)) _ _) -> Right symObj
-                  symObj@(XObj (Sym _ mode) _ _) -> Right (symObj, mode)
-                  anythingElse -> Left (CannotSet anythingElse)
-           in case correctVariableAndMode of
-                Left err ->
-                  pure (Left err)
-                Right (okCorrectVariable, okMode) ->
-                  do
-                    MemState preDeleters _ _ <- get
-                    let ownsTheVarBefore = case createDeleter okCorrectVariable of
-                          Nothing -> Right ()
-                          Just d ->
-                            if Set.member d preDeleters || isLookupGlobal okMode
-                              then Right ()
-                              else Left (UsingUnownedValue variable)
-                    visitedValue <- visit value
-                    _ <- unmanage value -- The assigned value can't be used anymore
-                    MemState managed _ _ <- get
-                    -- Delete the value previously stored in the variable, if it's still alive
-                    let deleters = case createDeleter okCorrectVariable of
-                          Just d -> Set.fromList [d]
-                          Nothing -> Set.empty
-                        newVariable =
-                          case okMode of
-                            Symbol -> error "How to handle this?"
-                            LookupLocal _ ->
-                              if Set.size (Set.intersection managed deleters) == 1 -- The variable is still alive
-                                then variable {xobjInfo = setDeletersOnInfo varInfo deleters}
-                                else variable -- don't add the new info = no deleter
-                            LookupGlobal _ _ ->
-                              variable {xobjInfo = setDeletersOnInfo varInfo deleters}
-                            _ -> error "managememory set! 1"
-                    -- traceDeps = trace ("SET!-deleters for " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj ++ ":\n" ++
-                    --                    "unmanaged " ++ pretty value ++ "\n" ++
-                    --                    "managed: " ++ show managed ++ "\n" ++
-                    --                    "deleters: " ++ show deleters ++ "\n")
-
-                    case okMode of
-                      Symbol -> error "Should only be be a global/local lookup symbol."
-                      LookupLocal _ -> manage okCorrectVariable
-                      LookupGlobal _ _ -> pure ()
-                      _ -> error "managememory set! 2"
-                    pure $ case okMode of
-                      LookupLocal (Capture _) ->
-                        Left (CannotSetVariableFromLambda variable setbangExpr)
-                      _ ->
-                        do
-                          okValue <- visitedValue
-                          _ <- ownsTheVarBefore -- Force Either to fail
-                          pure (XObj (Lst [setbangExpr, newVariable, okValue]) i t)
-        [theExpr@(XObj The _ _), typeXObj, value] ->
-          do
-            visitedValue <- visit value
-            result <- transferOwnership value xobj
-            pure $ case result of
-              Left e -> Left e
-              Right _ -> do
-                okValue <- visitedValue
-                pure (XObj (Lst [theExpr, typeXObj, okValue]) i t)
-        [refExpr@(XObj Ref _ _), value] ->
-          do
-            visited <- visit value
-            case visited of
-              Left e -> pure (Left e)
-              Right visitedValue ->
-                do
-                  checkResult <- refCheck visitedValue
-                  case checkResult of
-                    Left e -> pure (Left e)
-                    Right () -> do
-                      let reffed = XObj (Lst [refExpr, visitedValue]) i t
-                      pure $ Right reffed
-        (XObj Deref _ _ : _) ->
-          error "Shouldn't end up here, deref only works when calling a function, i.e. ((deref f) 1 2 3)."
-        doExpr@(XObj Do _ _) : expressions ->
-          do
-            visitedExpressions <- mapM visit expressions
-            result <- transferOwnership (last expressions) xobj
-            pure $ case result of
-              Left e -> Left e
-              Right _ -> do
-                okExpressions <- sequence visitedExpressions
-                pure (XObj (Lst (doExpr : okExpressions)) i t)
-        [whileExpr@(XObj While _ _), expr, body] ->
-          do
-            MemState preDeleters _ _ <- get
-            visitedExpr <- visit expr
-            MemState afterExprDeleters _ _ <- get
-            visitedBody <- visit body
-            manage body
-            MemState postDeleters deps postLifetimes <- get
-            -- Visit an extra time to simulate repeated use
-            visitedExpr2 <- visit expr
-            visitedBody2 <- visit body
-            let diff = postDeleters \\ preDeleters
-            put (MemState (postDeleters \\ diff) deps postLifetimes) -- Same as just pre deleters, right?!
-            pure $ do
-              okExpr <- visitedExpr
-              okBody <- visitedBody
-              _ <- visitedExpr2 -- This evaluates the second visit so that it actually produces the error
-              _ <- visitedBody2 -- And this one too. Laziness FTW.
-              let newInfo = setDeletersOnInfo i diff
-                  -- Also need to set deleters ON the expression (for first run through the loop)
-                  XObj objExpr objInfo objTy = okExpr
-                  newExprInfo = setDeletersOnInfo objInfo (afterExprDeleters \\ preDeleters)
-                  newExpr = XObj objExpr newExprInfo objTy
-                  finalBody = searchForInnerBreak diff okBody
-              pure (XObj (Lst [whileExpr, newExpr, finalBody]) newInfo t)
-        [ifExpr@(XObj If _ _), expr, ifTrue, ifFalse] ->
-          do
-            visitedExpr <- visit expr
-            MemState preDeleters deps lifetimes <- get
-            let (visitedTrue, stillAliveTrue) =
-                  runState
-                    ( do
-                        v <- visit ifTrue
-                        result <- transferOwnership ifTrue xobj
-                        pure $ case result of
-                          Left e -> error (show e)
-                          Right () -> v
-                    )
-                    (MemState preDeleters deps lifetimes)
-                (visitedFalse, stillAliveFalse) =
-                  runState
-                    ( do
-                        v <- visit ifFalse
-                        result <- transferOwnership ifFalse xobj
-                        pure $ case result of
-                          Left e -> error (show e)
-                          Right () -> v
-                    )
-                    (MemState preDeleters deps lifetimes)
-            let deletedInTrue = preDeleters \\ memStateDeleters stillAliveTrue
-                deletedInFalse = preDeleters \\ memStateDeleters stillAliveFalse
-                deletedInBoth = Set.intersection deletedInTrue deletedInFalse
-                createdInTrue = memStateDeleters stillAliveTrue \\ preDeleters
-                createdInFalse = memStateDeleters stillAliveFalse \\ preDeleters
-                selfDeleter = case createDeleter xobj of
-                  Just ok -> Set.fromList [ok]
-                  Nothing -> Set.empty
-                createdAndDeletedInTrue = createdInTrue \\ selfDeleter
-                createdAndDeletedInFalse = createdInFalse \\ selfDeleter
-                delsTrue = Set.union (deletedInFalse \\ deletedInBoth) createdAndDeletedInTrue
-                delsFalse = Set.union (deletedInTrue \\ deletedInBoth) createdAndDeletedInFalse
-                stillAliveAfter = preDeleters \\ Set.union deletedInTrue deletedInFalse
-                depsAfter = memStateDeps stillAliveTrue ++ memStateDeps stillAliveFalse ++ deps -- Note: This merges all previous deps and the new ones, could be optimized..?!
-
-            -- traceDeps = trace ("IF-deleters for " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj ++ " " ++ identifierStr xobj ++ ":\n" ++
-            --                    "preDeleters: " ++ show preDeleters ++ "\n" ++
-            --                    "stillAliveTrue: " ++ show (memStateDeleters stillAliveTrue) ++ "\n" ++
-            --                    "stillAliveFalse: " ++ show (memStateDeleters stillAliveFalse) ++ "\n" ++
-            --                    "createdInTrue: " ++ show createdInTrue ++ "\n" ++
-            --                    "createdInFalse: " ++ show createdInFalse ++ "\n" ++
-            --                    "createdAndDeletedInTrue: " ++ show createdAndDeletedInTrue ++ "\n" ++
-            --                    "createdAndDeletedInFalse: " ++ show createdAndDeletedInFalse ++ "\n" ++
-            --                    "deletedInTrue: " ++ show deletedInTrue ++ "\n" ++
-            --                    "deletedInFalse: " ++ show deletedInFalse ++ "\n" ++
-            --                    "deletedInBoth: " ++ show deletedInBoth ++ "\n" ++
-            --                    "delsTrue: " ++ show delsTrue ++ "\n" ++
-            --                    "delsFalse: " ++ show delsFalse ++ "\n" ++
-            --                    "stillAlive: " ++ show stillAliveAfter ++ "\n" ++
-            --                    "depsAfter: " ++ show depsAfter ++ "\n"
-            --                   )
-
-            put (MemState stillAliveAfter depsAfter lifetimes)
-            manage xobj
-            pure $ do
-              okExpr <- visitedExpr
-              okTrue <- visitedTrue
-              okFalse <- visitedFalse
-              pure (XObj (Lst [ifExpr, okExpr, del okTrue delsTrue, del okFalse delsFalse]) i t)
-        matchExpr@(XObj (Match _) _ _) : expr : cases ->
-          -- General idea of how to figure out what to delete in a 'match' statement:
-          -- 1. Visit each case and investigate which variables are deleted in each one of the cases
-          -- 2. Variables deleted in at least one case has to be deleted in all, so make a union U of all such vars
-          --    but remove the ones that were not present before the 'match'
-          -- 3. In each case - take the intersection of U and the vars deleted in that case and add this result to its deleters
-          do
-            visitedExpr <- visit expr
-            case visitedExpr of
-              Left e -> pure (Left e)
-              Right okVisitedExpr ->
-                do
-                  _ <- unmanage okVisitedExpr
-                  MemState preDeleters deps lifetimes <- get
-                  vistedCasesAndDeps <- mapM visitMatchCase (pairwise cases)
-                  case sequence vistedCasesAndDeps of
-                    Left e -> pure (Left e)
-                    Right okCasesAndDeps ->
-                      let visitedCases = map fst okCasesAndDeps
-                          depsFromCases = concatMap snd okCasesAndDeps
-                          (finalXObj, postDeleters) = figureOutStuff okVisitedExpr visitedCases preDeleters
-                       in do
-                            put (MemState postDeleters (deps ++ depsFromCases) lifetimes)
-                            manage xobj
-                            pure (Right finalXObj)
-          where
-            figureOutStuff ::
-              XObj ->
-              [(Set.Set Deleter, (XObj, XObj))] ->
-              Set.Set Deleter ->
-              (XObj, Set.Set Deleter)
-            figureOutStuff okVisitedExpr visitedCasesWithDeleters preDeleters =
-              let postDeleters = map fst visitedCasesWithDeleters
-                  -- postDeletersUnion = unionOfSetsInList postDeleters
-                  postDeletersIntersection = intersectionOfSetsInList postDeleters
-                  deletersAfterTheMatch = Set.intersection preDeleters postDeletersIntersection
-                  -- The "postDeletersUnionPreExisting" are the vars that existed before the match but needs to
-                  -- be deleted after it has executed (because some branches delete them)
-                  -- postDeletersUnionPreExisting = Set.intersection postDeletersUnion preDeleters
-                  deletersForEachCase = map (\\ deletersAfterTheMatch) postDeleters
-                  -- These are the surviving vars after the 'match' expression:
-
-                  okVisitedCases = map snd visitedCasesWithDeleters
-                  okVisitedCasesWithAllDeleters =
-                    zipWith
-                      ( \(lhs, rhs) finalSetOfDeleters ->
-                          -- Putting the deleter info on the lhs,
-                          -- because the right one can collide with
-                          -- the other expressions, e.g. a 'let'
-                          let newLhsInfo = setDeletersOnInfo (xobjInfo lhs) finalSetOfDeleters
-                           in [lhs {xobjInfo = newLhsInfo}, rhs]
-                      )
-                      okVisitedCases
-                      deletersForEachCase
-               in -- trace ("post deleters: " ++ show postDeleters)
-                  -- trace ("\npost deleters union: " ++ show postDeletersUnion)
-                  -- trace ("\npost deleters intersection: " ++ show postDeletersIntersection)
-                  -- trace ("Post deleters union pre-existing: " ++ show postDeletersUnionPreExisting)
-                  -- trace ("Post deleters for each case: " ++ show postDeleters)
-                  ( XObj (Lst ([matchExpr, okVisitedExpr] ++ concat okVisitedCasesWithAllDeleters)) i t,
-                    deletersAfterTheMatch
-                  )
-        XObj (Lst [deref@(XObj Deref _ _), f]) xi xt : uargs ->
-          do
-            -- Do not visit f in this case, we don't want to manage it's memory since it is a ref!
-            visitedArgs <- sequence <$> mapM visitArg uargs
-            case visitedArgs of
-              Left err -> pure (Left err)
-              Right args ->
-                do
-                  unmanagedArgs <- sequence <$> mapM unmanageArg args
-                  manage xobj
-                  pure $ do
-                    okArgs <- unmanagedArgs
-                    Right (XObj (Lst (XObj (Lst [deref, f]) xi xt : okArgs)) i t)
-        f : uargs ->
-          do
-            visitedF <- visit f
-            visitedArgs <- sequence <$> mapM visitArg uargs
-            case visitedArgs of
-              Left err -> pure (Left err)
-              Right args -> do
-                unmanagedArgs <- sequence <$> mapM unmanageArg args
-                manage xobj
-                pure $ do
-                  okF <- visitedF
-                  okArgs <- unmanagedArgs
-                  Right (XObj (Lst (okF : okArgs)) i t)
-        [] -> pure (Right xobj)
-    visitList _ = error "Must visit list."
-    searchForInnerBreak :: Set.Set Deleter -> XObj -> XObj
-    searchForInnerBreak diff (XObj (Lst [(XObj Break i' t')]) xi xt) =
-      let ni = addDeletersToInfo i' diff
-       in XObj (Lst [(XObj Break ni t')]) xi xt
-    searchForInnerBreak _ x@(XObj (Lst ((XObj While _ _) : _)) _ _) = x
-    searchForInnerBreak diff (XObj (Lst elems) i' t') =
-      let newElems = map (searchForInnerBreak diff) elems
-       in XObj (Lst newElems) i' t'
-    searchForInnerBreak _ e = e
-    visitMatchCase :: (XObj, XObj) -> State MemState (Either TypeError ((Set.Set Deleter, (XObj, XObj)), [XObj]))
-    visitMatchCase (lhs@XObj {}, rhs@XObj {}) =
-      do
-        MemState preDeleters _ _ <- get
-        _ <- visitCaseLhs lhs
-        visitedRhs <- visit rhs
-        _ <- unmanage rhs
-        MemState postDeleters postDeps postLifetimes <- get
-        -- let diff = postDeleters \\ preDeleters
-        put (MemState preDeleters postDeps postLifetimes) -- Restore managed variables, TODO: Use a "local" state monad instead?
-        pure $ do
-          okVisitedRhs <- visitedRhs
-          -- trace ("\npre: " ++ show preDeleters ++
-          --        "\npost: " ++ show postDeleters ++
-          --        "\ndiff: " ++ show diff)
-          --   $
-          pure ((postDeleters, (lhs, okVisitedRhs)), postDeps)
-    visitCaseLhs :: XObj -> State MemState (Either TypeError [()])
-    visitCaseLhs (XObj (Lst vars) _ _) =
-      do
-        result <- mapM visitCaseLhs vars
-        let result' = sequence result
-        pure (fmap concat result')
-    visitCaseLhs xobj@(XObj (Sym (SymPath _ name) _) _ _)
-      | isVarName name = do
-        manage xobj
-        pure (Right [])
-      | otherwise = pure (Right [])
-    visitCaseLhs (XObj Ref _ _) =
-      pure (Right [])
-    visitCaseLhs x =
-      error ("Unhandled: " ++ show x)
-    addToLifetimesMappingsIfRef :: Bool -> XObj -> State MemState ()
-    addToLifetimesMappingsIfRef internal xobj =
-      case xobjTy xobj of
-        Just (RefTy _ (VarTy lt)) ->
-          do
-            m@(MemState _ _ lifetimes) <- get
-            case Map.lookup lt lifetimes of
-              Just _ ->
-                --trace ("\nThere is already a mapping for '" ++ pretty xobj ++ "' from the lifetime '" ++ lt ++ "' to " ++ show existing ++ ", won't add " ++ show (makeLifetimeMode xobj)) $
-                pure ()
-              Nothing ->
-                do
-                  let lifetimes' = Map.insert lt makeLifetimeMode lifetimes
-                  put $ --(trace $ "\nExtended lifetimes mappings for '" ++ pretty xobj ++ "' with " ++ show lt ++ " => " ++ show (makeLifetimeMode xobj) ++ " at " ++ prettyInfoFromXObj xobj ++ ":\n" ++ prettyLifetimeMappings lifetimes') $
-                    m {memStateLifetimes = lifetimes'}
-                  pure ()
-        Just _ ->
-          --trace ("Won't add to mappings! " ++ pretty xobj ++ " : " ++ show notThisType ++ " at " ++ prettyInfoFromXObj xobj) $
-          pure ()
-        _ ->
-          --trace ("No type on " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj) $
-          pure ()
-      where
-        makeLifetimeMode =
-          if internal
-            then LifetimeInsideFunction $
-              case xobj of
-                XObj (Lst [XObj Ref _ _, target]) _ _ -> varOfXObj target
-                _ -> varOfXObj xobj
-            else LifetimeOutsideFunction
-    checkThatRefTargetIsAlive :: XObj -> State MemState (Either TypeError XObj)
-    checkThatRefTargetIsAlive xobj =
-      -- TODO: Replace this whole thing with a function that collects all lifetime variables in a type.
-      case xobjTy xobj of
-        Just (RefTy _ (VarTy lt)) ->
-          performCheck lt
-        Just (FuncTy _ _ (VarTy lt)) ->
-          performCheck lt
-        -- HACK (not exhaustive):
-        Just (FuncTy _ (RefTy _ (VarTy lt)) _) ->
-          performCheck lt
-        _ ->
-          pure -- trace ("Won't check " ++ pretty xobj ++ " : " ++ show (ty xobj))
-            (Right xobj)
-      where
-        performCheck :: String -> State MemState (Either TypeError XObj)
-        performCheck lt =
-          do
-            MemState deleters _ lifetimeMappings <- get
-            case Map.lookup lt lifetimeMappings of
-              Just (LifetimeInsideFunction deleterName) ->
-                let matchingDeleters =
-                      Set.toList $
-                        Set.filter
-                          ( \case
-                              ProperDeleter {deleterVariable = dv} -> dv == deleterName
-                              FakeDeleter {deleterVariable = dv} -> dv == deleterName
-                              PrimDeleter {aliveVariable = dv} -> dv == deleterName
-                              RefDeleter {refVariable = dv} -> dv == deleterName
-                          )
-                          deleters
-                 in case matchingDeleters of
-                      [] ->
-                        --trace ("Can't use reference " ++ pretty xobj ++ " (with lifetime '" ++ lt ++ "', depending on " ++ show deleterName ++ ") at " ++ prettyInfoFromXObj xobj ++ ", it's not alive here:\n" ++ show xobj ++ "\nMappings: " ++ prettyLifetimeMappings lifetimeMappings ++ "\nAlive: " ++ show deleters ++ "\n") $
-                        --pure (Right xobj)
-                        pure (Left (UsingDeadReference xobj deleterName))
-                      _ ->
-                        --trace ("CAN use reference " ++ pretty xobj ++ " (with lifetime '" ++ lt ++ "', depending on " ++ show deleterName ++ ") at " ++ prettyInfoFromXObj xobj ++ ", it's not alive here:\n" ++ show xobj ++ "\nMappings: " ++ prettyLifetimeMappings lifetimeMappings ++ "\nAlive: " ++ show deleters ++ "\n") $
-                        pure (Right xobj)
-              Just LifetimeOutsideFunction ->
-                --trace ("Lifetime OUTSIDE function: " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj) $
-                pure (Right xobj)
-              Nothing ->
-                pure (Right xobj)
-    -- case xobj of
-    --   XObj (Sym _ (LookupLocal Capture)) _ _ ->
-    --     -- Ignore these for the moment! TODO: FIX!!!
-    --     pure (Right xobj)
-    --   _ ->
-    --     trace ("Failed to find lifetime key (when checking) '" ++ lt ++ "' for " ++ pretty xobj ++ " in mappings at " ++ prettyInfoFromXObj xobj) $
-    --     pure (Right xobj)
-
-    visitLetBinding :: (XObj, XObj) -> State MemState (Either TypeError (XObj, XObj))
-    visitLetBinding (name, expr) =
-      do
-        visitedExpr <- visit expr
-        addToLifetimesMappingsIfRef True expr
-        result <- transferOwnership expr name
-        pure $ case result of
-          Left e -> Left e
-          Right _ -> do
-            okExpr <- visitedExpr
-            pure (name, okExpr)
-    visitArg :: XObj -> State MemState (Either TypeError XObj)
-    visitArg xobj@(XObj _ _ (Just _)) =
-      do
-        afterVisit <- visit xobj
-        case afterVisit of
-          Right okAfterVisit -> do
-            addToLifetimesMappingsIfRef True okAfterVisit
-            pure (Right okAfterVisit)
-          Left err -> pure (Left err)
-    visitArg xobj@XObj {} =
-      visit xobj
-    unmanageArg :: XObj -> State MemState (Either TypeError XObj)
-    unmanageArg xobj@(XObj _ _ (Just t)) =
-      if isManaged typeEnv globalEnv t
-        then do
-          r <- unmanage xobj
-          pure $ case r of
-            Left err -> Left err
-            Right () -> Right xobj
-        else pure (Right xobj)
-    unmanageArg xobj@XObj {} =
-      pure (Right xobj)
-    getDropFunc i t = nameOfPolymorphicFunction typeEnv globalEnv (FuncTy [RefTy t (VarTy (makeTypeVariableNameFromInfo i))] UnitTy StaticLifetimeTy) "drop"
-    createDeleter xobj =
-      case xobjTy xobj of
-        Just (RefTy _ _) -> Just (RefDeleter (varOfXObj xobj))
-        Just t ->
-          let var = varOfXObj xobj
-           in if isManaged typeEnv globalEnv t
-                then case nameOfPolymorphicFunction typeEnv globalEnv (FuncTy [t] UnitTy StaticLifetimeTy) "delete" of
-                  Just pathOfDeleteFunc ->
-                    Just (ProperDeleter pathOfDeleteFunc (getDropFunc (xobjInfo xobj) t) var)
-                  Nothing ->
-                    --trace ("Found no delete function for " ++ var ++ " : " ++ (showMaybeTy (ty xobj)))
-                    Just (FakeDeleter var)
-                else Just (PrimDeleter var)
-        Nothing -> error ("No type, can't manage " ++ show xobj)
-    manage :: XObj -> State MemState ()
-    manage xobj =
-      if isSymbolThatCaptures xobj -- When visiting lifted lambdas, don't manage symbols that capture (they are owned by the environment).
-        then pure ()
-        else case createDeleter xobj of
-          Just deleter -> do
-            MemState deleters deps lifetimes <- get
-            let newDeleters = Set.insert deleter deleters
-                Just t = xobjTy xobj
-                newDeps = deps ++ depsForDeleteFunc typeEnv globalEnv t
-            put (MemState newDeleters newDeps lifetimes)
-          Nothing -> pure ()
-    deletersMatchingXObj :: XObj -> Set.Set Deleter -> [Deleter]
-    deletersMatchingXObj xobj deleters =
-      let var = varOfXObj xobj
-       in Set.toList $
-            Set.filter
-              ( \case
-                  ProperDeleter {deleterVariable = dv} -> dv == var
-                  FakeDeleter {deleterVariable = dv} -> dv == var
-                  PrimDeleter {aliveVariable = dv} -> dv == var
-                  RefDeleter {refVariable = dv} -> dv == var
-              )
-              deleters
-    isSymbolThatCaptures :: XObj -> Bool
-    isSymbolThatCaptures xobj =
-      case xobj of
-        XObj (Sym _ (LookupLocal (Capture _))) _ _ -> True
-        _ -> False
-    unmanage :: XObj -> State MemState (Either TypeError ())
-    unmanage xobj =
-      let Just t = xobjTy xobj
-       in if isManaged typeEnv globalEnv t && not (isGlobalFunc xobj)
-            then do
-              MemState deleters deps lifetimes <- get
-              case deletersMatchingXObj xobj deleters of
-                [] ->
-                  pure $
-                    if isSymbolThatCaptures xobj
-                      then Left (UsingCapturedValue xobj)
-                      else Left (UsingUnownedValue xobj)
-                [one] ->
-                  let newDeleters = Set.delete one deleters
-                   in do
-                        put (MemState newDeleters deps lifetimes)
-                        pure (Right ())
-                tooMany -> error ("Too many variables with the same name in set: " ++ show tooMany)
-            else pure (Right ())
-    refCheck :: XObj -> State MemState (Either TypeError ())
-    refCheck xobj =
-      let Just t = xobjTy xobj
-          isGlobalVariable = case xobj of
-            XObj (Sym _ (LookupGlobal _ _)) _ _ -> True
-            _ -> False
-       in if not isGlobalVariable && not (isGlobalFunc xobj) && isManaged typeEnv globalEnv t && not (isSymbolThatCaptures xobj) -- TODO: The 'isManaged typeEnv t' boolean check should be removed!
-            then do
-              MemState deleters _ _ <- get
-              pure $ case deletersMatchingXObj xobj deleters of
-                [] -> Left (GettingReferenceToUnownedValue xobj)
-                [_] -> pure ()
-                _ -> error $ "Too many variables with the same name in set (was looking for " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj ++ ")"
-            else pure (pure ())
-    transferOwnership :: XObj -> XObj -> State MemState (Either TypeError ())
-    transferOwnership from to =
-      do
-        result <- unmanage from
-        case result of
-          Left e -> pure (Left e)
-          Right _ -> do
-            manage to --(trace ("Transfered from " ++ getName from ++ " '" ++ varOfXObj from ++ "' to " ++ getName to ++ " '" ++ varOfXObj to ++ "'") to)
-            pure (Right ())
-
-varOfXObj :: XObj -> String
-varOfXObj xobj =
-  case xobj of
-    XObj (Sym path _) _ _ -> pathToC path
-    _ -> case xobjInfo xobj of
-      Just i -> freshVar i
-      Nothing -> error ("Missing info on " ++ show xobj)
-
-suffixTyVars :: String -> Ty -> Ty
-suffixTyVars suffix t =
-  case t of
-    VarTy key -> VarTy (key ++ suffix)
-    FuncTy argTys retTy ltTy -> FuncTy (map (suffixTyVars suffix) argTys) (suffixTyVars suffix retTy) (suffixTyVars suffix ltTy)
-    StructTy name tyArgs -> StructTy name (fmap (suffixTyVars suffix) tyArgs)
-    PointerTy x -> PointerTy (suffixTyVars suffix x)
-    RefTy x lt -> RefTy (suffixTyVars suffix x) (suffixTyVars suffix lt)
-    _ -> t
-
--- | The following functions will generate deleters and copy:ing methods for structs, they are shared with the Deftype module
-data AllocationMode = StackAlloc | HeapAlloc
-
 -- | The template for the 'delete' function of a concrete deftype.
 concreteDelete :: TypeEnv -> Env -> [(String, Ty)] -> Template
 concreteDelete typeEnv env members =
@@ -1661,6 +859,18 @@ concreteCopy typeEnv env memberPairs =
           (filter (isManaged typeEnv env) (map snd memberPairs))
     )
 
+concreteCopyPtr :: TypeEnv -> Env -> [(String, Ty)] -> Template
+concreteCopyPtr typeEnv env memberPairs =
+  Template
+    (FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy)
+    (const (toTemplate "$p* $NAME($p* pRef)"))
+    (const (tokensForCopyPtr typeEnv env memberPairs))
+    ( \_ ->
+        concatMap
+          (depsOfPolymorphicFunction typeEnv env [] "copy" . typesCopyFunctionType)
+          (filter (isManaged typeEnv env) (map snd memberPairs))
+    )
+
 tokensForCopy :: TypeEnv -> Env -> [(String, Ty)] -> [Token]
 tokensForCopy typeEnv env memberPairs =
   toTemplate $
@@ -1682,18 +892,6 @@ memberCopy typeEnv env (memberName, memberType) =
     FunctionNotFound msg -> error msg
     FunctionIgnored -> "    /* Ignore non-managed member '" ++ memberName ++ "' : " ++ show memberType ++ " */"
 
-concreteCopyPtr :: TypeEnv -> Env -> [(String, Ty)] -> Template
-concreteCopyPtr typeEnv env memberPairs =
-  Template
-    (FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy)
-    (const (toTemplate "$p* $NAME($p* pRef)"))
-    (const (tokensForCopyPtr typeEnv env memberPairs))
-    ( \_ ->
-        concatMap
-          (depsOfPolymorphicFunction typeEnv env [] "copy" . typesCopyFunctionType)
-          (filter (isManaged typeEnv env) (map snd memberPairs))
-    )
-
 tokensForCopyPtr :: TypeEnv -> Env -> [(String, Ty)] -> [Token]
 tokensForCopyPtr typeEnv env memberPairs =
   toTemplate $
@@ -1713,3 +911,13 @@ memberCopyPtr typeEnv env (memberName, memberType) =
       "    copy->" ++ memberName ++ " = " ++ functionFullName ++ "(&(pRef->" ++ memberName ++ "));"
     FunctionNotFound msg -> error msg
     FunctionIgnored -> "    /* Ignore non-managed member '" ++ memberName ++ "' : " ++ show memberType ++ " */"
+
+suffixTyVars :: String -> Ty -> Ty
+suffixTyVars suffix t =
+  case t of
+    VarTy key -> VarTy (key ++ suffix)
+    FuncTy argTys retTy ltTy -> FuncTy (map (suffixTyVars suffix) argTys) (suffixTyVars suffix retTy) (suffixTyVars suffix ltTy)
+    StructTy name tyArgs -> StructTy name (fmap (suffixTyVars suffix) tyArgs)
+    PointerTy x -> PointerTy (suffixTyVars suffix x)
+    RefTy x lt -> RefTy (suffixTyVars suffix x) (suffixTyVars suffix lt)
+    _ -> t

src/Eval.hs

@@ -17,6 +17,7 @@ import Emit
 import qualified Env as E
 import EvalError
 import Expand
+import Forms
 import Infer
 import Info
 import qualified Map
@@ -35,7 +36,6 @@ import TypeError
 import Types
 import Util
 import Prelude hiding (exp, mod)
-import Forms
 
 -- TODO: Formalize "lookup order preference" a bit better and move into
 -- the Context module.
@@ -190,21 +190,21 @@ eval ctx xobj@(XObj o info ty) preference resolver =
         Left e -> pure (evalError ctx (format e) (xobjInfo xobj))
         Right form' ->
           case form' of
-            (IfPat _ _ _) -> evaluateIf form'
-            (DefnPat _ _ _) -> specialCommandDefine ctx xobj
-            (DefPat _ _) -> specialCommandDefine ctx xobj
+            (IfPat _ _ _ _) -> evaluateIf form'
+            (DefnPat _ _ _ _) -> specialCommandDefine ctx xobj
+            (DefPat _ _ _) -> specialCommandDefine ctx xobj
             (ThePat _ _ _) -> evaluateThe form'
-            (LetPat _ _) -> evaluateLet form'
+            (LetPat _ _ _) -> evaluateLet form'
             (FnPat _ _ _) -> evaluateFn form'
             (AppPat (ClosurePat _ _ _) _) -> evaluateClosure form'
             (AppPat (DynamicFnPat _ _ _) _) -> evaluateDynamicFn form'
             (AppPat (MacroPat _ _ _) _) -> evaluateMacro form'
             (AppPat (CommandPat _ _ _) _) -> evaluateCommand form'
             (AppPat (PrimitivePat _ _ _) _) -> evaluatePrimitive form'
-            (WithPat (SymPat sym path) forms) -> specialCommandWith ctx sym path forms
-            (DoPat forms) -> evaluateSideEffects forms
-            (WhilePat cond body) -> specialCommandWhile ctx cond body
-            (SetPat iden value) -> specialCommandSet ctx (iden:[value])
+            (WithPat _ sym@(SymPat path) forms) -> specialCommandWith ctx sym path forms
+            (DoPat _ forms) -> evaluateSideEffects forms
+            (WhilePat _ cond body) -> specialCommandWhile ctx cond body
+            (SetPat _ iden value) -> specialCommandSet ctx (iden : [value])
             -- This next match is a bit redundant looking at first glance, but
             -- it is necessary to prevent hangs on input such as: `((def foo 2)
             -- 4)`. Ideally, we could perform only *one* static check (the one
@@ -218,15 +218,16 @@ eval ctx xobj@(XObj o info ty) preference resolver =
             -- Importantly, the loop *is only broken on literal nested lists*.
             -- That is, passing a *symbol* that, e.g. resolves to a defn list, won't
             -- break our normal loop.
-            (AppPat (ListPat self ((SymPat x _):_)) args) ->
-              do (_, evald) <- eval ctx x preference ResolveGlobal
-                 case evald of
-                   Left err -> pure (evalError ctx (show err) (xobjInfo xobj))
-                   Right x' -> case checkStatic' x' of
-                                 Right _ -> evaluateApp (self:args)
-                                 Left er -> pure (evalError ctx (show er) (xobjInfo xobj))
-            (AppPat (ListPat _ _) _)  -> evaluateApp form'
-            (AppPat (SymPat _ _) _)  -> evaluateApp form'
+            (AppPat self@(ListPat (x@(SymPat _) : _)) args) ->
+              do
+                (_, evald) <- eval ctx x preference ResolveGlobal
+                case evald of
+                  Left err -> pure (evalError ctx (show err) (xobjInfo xobj))
+                  Right x' -> case checkStatic' x' of
+                    Right _ -> evaluateApp (self : args)
+                    Left er -> pure (evalError ctx (show er) (xobjInfo xobj))
+            (AppPat (ListPat _) _) -> evaluateApp form'
+            (AppPat (SymPat _) _) -> evaluateApp form'
             [] -> pure (ctx, dynamicNil)
             _ -> pure (throwErr (UnknownForm xobj) ctx (xobjInfo xobj))
     checkStatic' (XObj Def _ _) = Left (HasStaticCall xobj info)
@@ -248,7 +249,7 @@ eval ctx xobj@(XObj o info ty) preference resolver =
             Left err -> (newCtx, Left err)
 
     evaluateIf :: Evaluator
-    evaluateIf (IfPat cond true false) = do
+    evaluateIf (IfPat _ cond true false) = do
       (newCtx, evd) <- eval ctx cond preference ResolveLocal
       case evd of
         Right cond' ->
@@ -263,15 +264,15 @@ eval ctx xobj@(XObj o info ty) preference resolver =
     evaluateThe (ThePat the t value) = do
       (newCtx, evaledValue) <- expandAll (evalDynamic ResolveLocal) ctx value -- TODO: Why expand all here?
       pure
-       ( newCtx,
-         do
-           okValue <- evaledValue
-           Right (XObj (Lst [the, t, okValue]) info ty)
-       )
+        ( newCtx,
+          do
+            okValue <- evaledValue
+            Right (XObj (Lst [the, t, okValue]) info ty)
+        )
     evaluateThe _ = pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj))
 
     evaluateLet :: Evaluator
-    evaluateLet (LetPat (ArrPat _ bindings) body) = do
+    evaluateLet (LetPat _ (ArrPat bindings) body) = do
       let binds = unwrapVar (pairwise bindings) []
           ni = Env Map.empty (contextInternalEnv ctx) Nothing Set.empty InternalEnv 0
       eitherCtx <- foldrM successiveEval' (Right (replaceInternalEnv ctx ni)) binds
@@ -398,16 +399,18 @@ eval ctx xobj@(XObj o info ty) preference resolver =
     evaluateApp :: Evaluator
     evaluateApp (AppPat f' args) =
       case f' of
-        (ListPat l _) -> go l ResolveLocal
-        (SymPat sym _) -> go sym resolver
+        l@(ListPat _) -> go l ResolveLocal
+        sym@(SymPat _) -> go sym resolver
         _ -> pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj))
-      where go x resolve =
-              do (newCtx, f) <- eval ctx x preference resolve
-                 case f of
-                   Right fun -> do
-                     (newCtx', res) <- eval (pushFrame newCtx xobj) (XObj (Lst (fun : args)) (xobjInfo x) (xobjTy x)) preference ResolveLocal
-                     pure (popFrame newCtx', res)
-                   x' -> pure (newCtx, x')
+      where
+        go x resolve =
+          do
+            (newCtx, f) <- eval ctx x preference resolve
+            case f of
+              Right fun -> do
+                (newCtx', res) <- eval (pushFrame newCtx xobj) (XObj (Lst (fun : args)) (xobjInfo x) (xobjTy x)) preference ResolveLocal
+                pure (popFrame newCtx', res)
+              x' -> pure (newCtx, x')
     evaluateApp _ = pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj))
 
     evaluateSideEffects :: Evaluator

src/Forms.hs

@@ -4,36 +4,39 @@
 -- unchecked forms (xobjs).
 --
 -- It defines a number of pattern synonyms for ease of pattern matching.
-module Forms (
-  validate,
-  format,
-  Malformed(GenericMalformed),
-  pattern ArrPat,
-  pattern ListPat,
-  pattern SymPat,
-  pattern UnqualifiedSymPat,
-  pattern DefPat,
-  pattern DefnPat,
-  pattern IfPat,
-  pattern ThePat,
-  pattern LetPat,
-  pattern FnPat,
-  pattern ClosurePat,
-  pattern DynamicFnPat,
-  pattern MacroPat,
-  pattern CommandPat,
-  pattern PrimitivePat,
-  pattern AppPat,
-  pattern WithPat,
-  pattern DoPat,
-  pattern WhilePat,
-  pattern SetPat,
-  ) where
+module Forms
+  ( validate,
+    format,
+    Malformed (GenericMalformed),
+    pattern ArrPat,
+    pattern StaticArrPat,
+    pattern ListPat,
+    pattern SymPat,
+    pattern UnqualifiedSymPat,
+    pattern DefPat,
+    pattern DefnPat,
+    pattern IfPat,
+    pattern ThePat,
+    pattern RefPat,
+    pattern LetPat,
+    pattern FnPat,
+    pattern ClosurePat,
+    pattern DynamicFnPat,
+    pattern MacroPat,
+    pattern CommandPat,
+    pattern PrimitivePat,
+    pattern AppPat,
+    pattern WithPat,
+    pattern DoPat,
+    pattern WhilePat,
+    pattern SetPat,
+  )
+where
 
+import Data.List (intercalate)
 import Obj
 import SymPath
 import Util
-import Data.List (intercalate)
 
 --------------------------------------------------------------------------------
 -- Data
@@ -41,19 +44,20 @@ import Data.List (intercalate)
 -- Specialized constructors for each built-in language form.
 
 -- | Error type representing a generic malformed expression.
-data Malformed = InvalidIdentifier XObj Modifier
-               | QualifiedIdentifier XObj Modifier
-               | GenericMalformed XObj
-               | InvalidArguments XObj Modifier
-               | InvalidBody XObj Modifier
-               | InvalidCondition XObj Modifier
-               | InvalidType XObj Modifier
-               | InvalidBindings XObj Modifier
-               | UnevenForms XObj Int Modifier
-               | InsufficientArguments XObj Int Int [XObj]
-               | TooManyArguments XObj Int Int [XObj]
-               | InvalidApplication XObj
-               | DoMissingForms
+data Malformed
+  = InvalidIdentifier XObj Modifier
+  | QualifiedIdentifier XObj Modifier
+  | GenericMalformed XObj
+  | InvalidArguments XObj Modifier
+  | InvalidBody XObj Modifier
+  | InvalidCondition XObj Modifier
+  | InvalidType XObj Modifier
+  | InvalidBindings XObj Modifier
+  | UnevenForms XObj Int Modifier
+  | InsufficientArguments XObj Int Int [XObj]
+  | TooManyArguments XObj Int Int [XObj]
+  | InvalidApplication XObj
+  | DoMissingForms
 
 instance Show Malformed where
   show (QualifiedIdentifier x modifier) =
@@ -79,15 +83,18 @@ instance Show Malformed where
       ++ formatModifier modifier
   show (UnevenForms forms len modifier) =
     "Expected an even number of forms, but got: " ++ pretty forms
-      ++ "of length " ++ show len ++ " " ++ formatModifier modifier
+      ++ "of length "
+      ++ show len
+      ++ " "
+      ++ formatModifier modifier
   show (InsufficientArguments form lenExpected lenRecieved params) =
     let name = case form of
-                 (DynamicFnPat sym _ _) -> getName sym
-                 (MacroPat sym _ _) -> getName sym
-                 (CommandPat _ sym _) -> getName sym
-                 (PrimitivePat _ sym _) -> getName sym
-                 XObj Ref _ _ -> "ref"
-                 _ -> pretty form
+          (DynamicFnPat sym _ _) -> getName sym
+          (MacroPat sym _ _) -> getName sym
+          (CommandPat _ sym _) -> getName sym
+          (PrimitivePat _ sym _) -> getName sym
+          XObj Ref _ _ -> "ref"
+          _ -> pretty form
      in name ++ " expected "
           ++ show lenExpected
           ++ " arguments but received only "
@@ -97,12 +104,12 @@ instance Show Malformed where
           ++ " as well."
   show (TooManyArguments form lenExpected lenRecieved args) =
     let name = case form of
-                 (DynamicFnPat sym _ _) -> getName sym
-                 (MacroPat sym _ _) -> getName sym
-                 (CommandPat _ sym _) -> getName sym
-                 (PrimitivePat _ sym _) -> getName sym
-                 XObj Ref _ _ -> "ref"
-                 _ -> pretty form
+          (DynamicFnPat sym _ _) -> getName sym
+          (MacroPat sym _ _) -> getName sym
+          (CommandPat _ sym _) -> getName sym
+          (PrimitivePat _ sym _) -> getName sym
+          XObj Ref _ _ -> "ref"
+          _ -> pretty form
      in name ++ " expected "
           ++ show lenExpected
           ++ " arguments but received "
@@ -118,40 +125,46 @@ instance Show Malformed where
     "The form: " ++ pretty x ++ " is malformed"
 
 -- | Specific errors for particular types of malformed expressions.
-data Modifier = DefnQualifiedSyms XObj
-              | DefnNonArrayArgs XObj
-              | DefnNonSymArgs XObj
-              | IfInvalidCondition XObj
-              | WhileInvalidCondition XObj
-              | TheInvalidType XObj
-              | LetMalformedBinding XObj
-              | LetUnevenForms XObj
-              | LetNonArrayBindings XObj
-              | FnQualifiedSyms XObj
-              | FnNonArrayArgs XObj
-              | FnNonSymArgs XObj
-              | InvalidWith XObj
-              | None
+data Modifier
+  = DefnQualifiedSyms XObj
+  | DefnNonArrayArgs XObj
+  | DefnNonSymArgs XObj
+  | IfInvalidCondition XObj
+  | WhileInvalidCondition XObj
+  | TheInvalidType XObj
+  | LetMalformedBinding XObj
+  | LetUnevenForms XObj
+  | LetNonArrayBindings XObj
+  | FnQualifiedSyms XObj
+  | FnNonArrayArgs XObj
+  | FnNonSymArgs XObj
+  | InvalidWith XObj
+  | None
 
 instance Show Modifier where
   show None = ""
   show (DefnQualifiedSyms arg) =
     "`defn` requires all of its arguments to be unqualified symbols, but the arugment: "
-      ++ pretty arg ++ " is qualified"
+      ++ pretty arg
+      ++ " is qualified"
   show (DefnNonArrayArgs args) =
     "`defn` requires an array of arugments, but it got: " ++ pretty args
   show (DefnNonSymArgs arg) =
     "`defn` requires an array of symbols as arguments, but the argument: "
-      ++ pretty arg ++ " is not a symbol"
+      ++ pretty arg
+      ++ " is not a symbol"
   show (IfInvalidCondition cond) =
     "`if` requires a condition that can be evaluated to a boolean, but it got: "
-      ++ pretty cond ++ " which cannot resolve to a boolean value."
+      ++ pretty cond
+      ++ " which cannot resolve to a boolean value."
   show (WhileInvalidCondition cond) =
     "`while` requires a condition that can be evaluated to a boolean, but it got: "
-      ++ pretty cond ++ " which cannot resolve to a boolean value."
+      ++ pretty cond
+      ++ " which cannot resolve to a boolean value."
   show (TheInvalidType t) =
     "`the` requires a valid type name, but it got: "
-      ++ pretty t ++ " which is not a valid type name"
+      ++ pretty t
+      ++ " which is not a valid type name"
   show (LetMalformedBinding bind) =
     "`let` requires name-value binding pairs, but it got: " ++ pretty bind
       ++ " as a binding name, which is invalid. Binding names must be symbols"
@@ -161,12 +174,14 @@ instance Show Modifier where
     "`let` requires an array of bindings, but it got: " ++ pretty invalid
   show (FnQualifiedSyms arg) =
     "`fn` requires all of its arguments to be unqualified symbols, but the arugment: "
-      ++ pretty arg ++ " is qualified"
+      ++ pretty arg
+      ++ " is qualified"
   show (FnNonArrayArgs args) =
     "`fn` requires an array of arugments, but it got: " ++ pretty args
   show (FnNonSymArgs arg) =
     "`fn` requires an array of symbols as arguments, but the argument: "
-      ++ pretty arg ++ " is not a symbol"
+      ++ pretty arg
+      ++ " is not a symbol"
   show (InvalidWith x) =
     "`with` requires a symbol as an arugment, but got: " ++ pretty x
 
@@ -185,15 +200,15 @@ format e = "[ERROR] " ++ show e
 validate :: [XObj] -> Either Malformed [XObj]
 validate xs =
   case xs of
-    DefPat _ _ -> validateDef xs
-    DefnPat _ _ _ -> validateDefn xs
-    IfPat _ _ _ -> validateIf xs
+    DefPat _ _ _ -> validateDef xs
+    DefnPat _ _ _ _ -> validateDefn xs
+    IfPat _ _ _ _ -> validateIf xs
     ThePat _ _ _ -> validateThe xs
-    LetPat _ _ -> validateLet xs
+    LetPat _ _ _ -> validateLet xs
     FnPat _ _ _ -> validateFn xs
-    WithPat _ _ -> validateWith xs
-    DoPat _ -> validateDo xs
-    WhilePat _ _ -> validateWhile xs
+    WithPat _ _ _ -> validateWith xs
+    DoPat _ _ -> validateDo xs
+    WhilePat _ _ _ -> validateWhile xs
     -- There are a number of application patterns (the "has static call patterns")
     -- that are formally caught at evaluation time.
     AppPat (ClosurePat _ _ _) _ -> validateApp xs
@@ -208,9 +223,9 @@ validate xs =
 -- for truthiness But there is a class of list forms we can rule out purely
 -- symbolically, e.g. `def`, etc..
 validateIf :: [XObj] -> Either Malformed [XObj]
-validateIf x@(IfPat (ListPat _ _) _ _) = Right x -- needs further evaluation
-validateIf (IfPat (ArrPat invalid _) _ _)  = Left (InvalidCondition invalid (IfInvalidCondition invalid))
-validateIf x@(IfPat cond _ _)
+validateIf x@(IfPat _ (ListPat _) _ _) = Right x -- needs further evaluation
+validateIf (IfPat _ invalid@(ArrPat _) _ _) = Left (InvalidCondition invalid (IfInvalidCondition invalid))
+validateIf x@(IfPat _ cond _ _)
   | isSym cond = Right x -- needs further evaluation
   | isBool cond = Right x
   | otherwise = Left (InvalidCondition cond (IfInvalidCondition cond))
@@ -218,9 +233,9 @@ validateIf invalid = Left (GenericMalformed (XObj (Lst invalid) Nothing Nothing)
 
 -- | Validation of (while cond body) expressions.
 validateWhile :: [XObj] -> Either Malformed [XObj]
-validateWhile x@(WhilePat (ListPat _ _) _) = Right x -- needs further evaluation
-validateWhile (WhilePat (ArrPat invalid _) _)  = Left (InvalidCondition invalid (WhileInvalidCondition invalid))
-validateWhile x@(WhilePat cond _)
+validateWhile x@(WhilePat _ (ListPat _) _) = Right x -- needs further evaluation
+validateWhile (WhilePat _ invalid@(ArrPat _) _) = Left (InvalidCondition invalid (WhileInvalidCondition invalid))
+validateWhile x@(WhilePat _ cond _)
   | isSym cond = Right x -- needs further evaluation
   | isBool cond = Right x
   | otherwise = Left (InvalidCondition cond (WhileInvalidCondition cond))
@@ -228,22 +243,22 @@ validateWhile invalid = Left (GenericMalformed (XObj (Lst invalid) Nothing Nothi
 
 -- | Validation of (def name value) expressions.
 validateDef :: [XObj] -> Either Malformed [XObj]
-validateDef x@(DefPat (UnqualifiedSymPat _ _) _) = Right x
-validateDef (DefPat (SymPat invalid _) _) = Left (QualifiedIdentifier invalid None)
-validateDef (DefPat invalid _) = Left (InvalidIdentifier invalid None)
+validateDef x@(DefPat _ (UnqualifiedSymPat _) _) = Right x
+validateDef (DefPat _ invalid@(SymPat _) _) = Left (QualifiedIdentifier invalid None)
+validateDef (DefPat _ invalid _) = Left (InvalidIdentifier invalid None)
 validateDef def = Left (GenericMalformed (XObj (Lst def) Nothing Nothing))
 
 -- | Validation of (defn name [args] body) expressions.
 validateDefn :: [XObj] -> Either Malformed [XObj]
-validateDefn x@(DefnPat (UnqualifiedSymPat _ _) (ArrPat arr args) _)
+validateDefn x@(DefnPat _ (UnqualifiedSymPat _) arr@(ArrPat args) _)
   | not (all isSym args) = Left (InvalidArguments arr (DefnNonSymArgs (head (remove isSym args))))
   | not (all isUnqualifiedSym args) =
-      Left (InvalidArguments arr (DefnQualifiedSyms (head (remove isUnqualifiedSym args))))
+    Left (InvalidArguments arr (DefnQualifiedSyms (head (remove isUnqualifiedSym args))))
   | otherwise = pure x
-validateDefn (DefnPat (UnqualifiedSymPat _ _) invalid _) =
+validateDefn (DefnPat _ (UnqualifiedSymPat _) invalid _) =
   Left (InvalidArguments invalid (DefnNonArrayArgs invalid))
-validateDefn (DefnPat (SymPat invalid _) _ _) = Left (QualifiedIdentifier invalid None)
-validateDefn (DefnPat invalid _ _) = Left (InvalidIdentifier invalid None)
+validateDefn (DefnPat _ invalid@(SymPat _) _ _) = Left (QualifiedIdentifier invalid None)
+validateDefn (DefnPat _ invalid _ _) = Left (InvalidIdentifier invalid None)
 validateDefn defn = Left (GenericMalformed (XObj (Lst defn) Nothing Nothing))
 
 -- | Validation of (the type body) expressions
@@ -251,33 +266,33 @@ validateThe :: [XObj] -> Either Malformed [XObj]
 validateThe x@(ThePat _ t _) =
   case xobjToTy t of
     Nothing -> Left (InvalidType t (TheInvalidType t))
-    Just _  -> Right x
+    Just _ -> Right x
 validateThe the = Left (GenericMalformed (XObj (Lst the) Nothing Nothing))
 
 -- | Validation of (let [bindings] body) expressions.
 validateLet :: [XObj] -> Either Malformed [XObj]
-validateLet x@(LetPat (ArrPat arr binds) _)
+validateLet x@(LetPat _ arr@(ArrPat binds) _)
   | odd (length binds) =
-      Left (UnevenForms arr (length binds) (LetUnevenForms arr))
+    Left (UnevenForms arr (length binds) (LetUnevenForms arr))
   | not (all isSym (evenIndices binds)) =
-      Left (InvalidBindings arr (LetMalformedBinding (head (remove isSym (evenIndices binds)))))
+    Left (InvalidBindings arr (LetMalformedBinding (head (remove isSym (evenIndices binds)))))
   | otherwise = Right x
-validateLet (LetPat invalid _) = Left (InvalidBindings invalid (LetNonArrayBindings invalid))
+validateLet (LetPat _ invalid _) = Left (InvalidBindings invalid (LetNonArrayBindings invalid))
 validateLet lett = Left (GenericMalformed (XObj (Lst lett) Nothing Nothing))
 
 -- | Validation of (fn [args] body) expressions.
 validateFn :: [XObj] -> Either Malformed [XObj]
-validateFn x@(FnPat _ (ArrPat arr args) _)
+validateFn x@(FnPat _ arr@(ArrPat args) _)
   | not (all isSym args) = Left (InvalidArguments arr (FnNonSymArgs (head (remove isSym args))))
   | not (all isUnqualifiedSym args) =
-      Left (InvalidArguments arr (FnQualifiedSyms (head (remove isUnqualifiedSym args))))
+    Left (InvalidArguments arr (FnQualifiedSyms (head (remove isUnqualifiedSym args))))
   | otherwise = pure x
 validateFn (FnPat _ invalid _) = Left (InvalidArguments invalid (FnNonArrayArgs invalid))
 validateFn fn = Left (GenericMalformed (XObj (Lst fn) Nothing Nothing))
 
 -- | Validation of (do body) expressions.
 validateDo :: [XObj] -> Either Malformed [XObj]
-validateDo x@(DoPat forms) =
+validateDo x@(DoPat _ forms) =
   case forms of
     [] -> Left DoMissingForms
     _ -> Right x
@@ -301,14 +316,15 @@ validateApp x@(AppPat f@(CommandPat arity _ _) args) =
     (BinaryCommandFunction _) -> checkAppArity f p args >> Right x
     (TernaryCommandFunction _) -> checkAppArity f p args >> Right x
     (VariadicCommandFunction _) -> Right x
-  where p = (\y -> XObj (Sym (SymPath [] y) Symbol) Nothing Nothing) <$> argnames
-        argnames =
-          case arity of
-            NullaryCommandFunction _ -> []
-            UnaryCommandFunction _ -> ["x"]
-            BinaryCommandFunction _ -> ["x", "y"]
-            TernaryCommandFunction _ -> ["x", "y", "z"]
-            VariadicCommandFunction _ -> []
+  where
+    p = (\y -> XObj (Sym (SymPath [] y) Symbol) Nothing Nothing) <$> argnames
+    argnames =
+      case arity of
+        NullaryCommandFunction _ -> []
+        UnaryCommandFunction _ -> ["x"]
+        BinaryCommandFunction _ -> ["x", "y"]
+        TernaryCommandFunction _ -> ["x", "y", "z"]
+        VariadicCommandFunction _ -> []
 validateApp x@(AppPat f@(PrimitivePat arity _ _) args) =
   case arity of
     (NullaryPrimitive _) -> checkAppArity f p args >> Right x
@@ -317,22 +333,23 @@ validateApp x@(AppPat f@(PrimitivePat arity _ _) args) =
     (TernaryPrimitive _) -> checkAppArity f p args >> Right x
     (QuaternaryPrimitive _) -> checkAppArity f p args >> Right x
     (VariadicPrimitive _) -> Right x
-  where p = (\y -> XObj (Sym (SymPath [] y) Symbol) Nothing Nothing) <$> argnames
-        argnames =
-          case arity of
-            NullaryPrimitive _ -> []
-            UnaryPrimitive _ -> ["x"]
-            BinaryPrimitive _ -> ["x", "y"]
-            TernaryPrimitive _ -> ["x", "y", "z"]
-            QuaternaryPrimitive _ -> ["x", "y", "z", "w"]
-            VariadicPrimitive _ -> []
+  where
+    p = (\y -> XObj (Sym (SymPath [] y) Symbol) Nothing Nothing) <$> argnames
+    argnames =
+      case arity of
+        NullaryPrimitive _ -> []
+        UnaryPrimitive _ -> ["x"]
+        BinaryPrimitive _ -> ["x", "y"]
+        TernaryPrimitive _ -> ["x", "y", "z"]
+        QuaternaryPrimitive _ -> ["x", "y", "z", "w"]
+        VariadicPrimitive _ -> []
 validateApp (AppPat invalid _) = Left (InvalidApplication invalid)
 validateApp app = Left (GenericMalformed (XObj (Lst app) Nothing Nothing))
 
 -- | Validation of (with module body) expressions
 validateWith :: [XObj] -> Either Malformed [XObj]
-validateWith x@(WithPat (SymPat _ _) _) = Right x
-validateWith (WithPat invalid _) = Left (InvalidIdentifier invalid (InvalidWith invalid))
+validateWith x@(WithPat _ (SymPat _) _) = Right x
+validateWith (WithPat _ invalid _) = Left (InvalidIdentifier invalid (InvalidWith invalid))
 validateWith with = Left (GenericMalformed (XObj (Lst with) Nothing Nothing))
 
 -- | Checks that the number of arguments passed to a function are correct.
@@ -351,62 +368,68 @@ checkAppArity xobj params args =
 --------------------------------------------------------------------------------
 -- Pattern Synonyms
 
-pattern ArrPat :: XObj -> [XObj] -> XObj
-pattern ArrPat self members <- self@(XObj (Arr members) _ _)
+pattern ArrPat :: [XObj] -> XObj
+pattern ArrPat members <- XObj (Arr members) _ _
 
-pattern ListPat :: XObj -> [XObj] -> XObj
-pattern ListPat self members <- self@(XObj (Lst members) _ _)
+pattern StaticArrPat :: [XObj] -> XObj
+pattern StaticArrPat members <- XObj (StaticArr members) _ _
 
-pattern SymPat :: XObj -> SymPath -> XObj
-pattern SymPat self path <- self@(XObj (Sym path _) _ _)
+pattern ListPat :: [XObj] -> XObj
+pattern ListPat members <- XObj (Lst members) _ _
 
-pattern UnqualifiedSymPat :: XObj -> SymPath -> XObj
-pattern UnqualifiedSymPat self path <- self@(XObj (Sym path@(SymPath [] _) _) _ _)
+pattern SymPat :: SymPath -> XObj
+pattern SymPat path <- XObj (Sym path _) _ _
 
-pattern DefPat :: XObj -> XObj -> [XObj]
-pattern DefPat name value <- [XObj Def _ _, name, value]
+pattern UnqualifiedSymPat :: SymPath -> XObj
+pattern UnqualifiedSymPat path <- XObj (Sym path@(SymPath [] _) _) _ _
 
-pattern DefnPat :: XObj -> XObj -> XObj -> [XObj]
-pattern DefnPat name args body <- [XObj (Defn _) _ _, name, args, body]
+pattern DefPat :: XObj -> XObj -> XObj -> [XObj]
+pattern DefPat def name value <- [def@(XObj Def _ _), name, value]
 
-pattern IfPat :: XObj -> XObj -> XObj -> [XObj]
-pattern IfPat cond true false <- [XObj If _ _, cond, true, false]
+pattern DefnPat :: XObj -> XObj -> XObj -> XObj -> [XObj]
+pattern DefnPat defn name args body <- [defn@(XObj (Defn _) _ _), name, args, body]
+
+pattern IfPat :: XObj -> XObj -> XObj -> XObj -> [XObj]
+pattern IfPat ifHead cond true false <- [ifHead@(XObj If _ _), cond, true, false]
 
 pattern ThePat :: XObj -> XObj -> XObj -> [XObj]
-pattern ThePat self t value <- [self@(XObj The _ _), t, value]
+pattern ThePat theHead t value <- [theHead@(XObj The _ _), t, value]
 
-pattern LetPat :: XObj -> XObj -> [XObj]
-pattern LetPat bindings body <- [XObj Let _ _, bindings, body]
+pattern RefPat :: XObj -> XObj -> [XObj]
+pattern RefPat refHead value <- [refHead@(XObj Ref _ _), value]
+
+pattern LetPat :: XObj -> XObj -> XObj -> [XObj]
+pattern LetPat letHead bindings body <- [letHead@(XObj Let _ _), bindings, body]
 
 pattern FnPat :: XObj -> XObj -> XObj -> [XObj]
-pattern FnPat self args body <- [self@(XObj (Fn _ _) _ _), args, body]
+pattern FnPat fnHead args body <- [fnHead@(XObj (Fn _ _) _ _), args, body]
+
+pattern WithPat :: XObj -> XObj -> [XObj] -> [XObj]
+pattern WithPat withHead sym forms <- (withHead@(XObj With _ _) : sym : forms)
+
+pattern DoPat :: XObj -> [XObj] -> [XObj]
+pattern DoPat doHead forms <- (doHead@(XObj Do _ _) : forms)
+
+pattern WhilePat :: XObj -> XObj -> XObj -> [XObj]
+pattern WhilePat whileHead cond body <- [whileHead@(XObj While _ _), cond, body]
+
+pattern SetPat :: XObj -> XObj -> XObj -> [XObj]
+pattern SetPat setBangHead iden value <- [setBangHead@(XObj SetBang _ _), iden, value]
 
 pattern ClosurePat :: [XObj] -> XObj -> Context -> XObj
-pattern ClosurePat params body ctx <- XObj (Closure (XObj (Lst [_, (ArrPat _ params), body]) _ _) (CCtx ctx)) _ _
+pattern ClosurePat params body ctx <- XObj (Closure (XObj (Lst [_, (ArrPat params), body]) _ _) (CCtx ctx)) _ _
 
 pattern DynamicFnPat :: XObj -> [XObj] -> XObj -> XObj
-pattern DynamicFnPat sym params body <- XObj (Lst [XObj Dynamic _ _, sym, (ArrPat _ params), body]) _ _
+pattern DynamicFnPat sym params body <- XObj (Lst [XObj Dynamic _ _, sym, (ArrPat params), body]) _ _
 
 pattern MacroPat :: XObj -> [XObj] -> XObj -> XObj
-pattern MacroPat sym params body <- XObj (Lst [XObj Macro _ _, sym, (ArrPat _ params), body]) _ _
+pattern MacroPat sym params body <- XObj (Lst [XObj Macro _ _, sym, (ArrPat params), body]) _ _
 
 pattern CommandPat :: CommandFunctionType -> XObj -> [XObj] -> XObj
-pattern CommandPat arity sym params <- XObj (Lst [XObj (Command arity) _ _, sym, (ArrPat _ params)]) _ _
+pattern CommandPat arity sym params <- XObj (Lst [XObj (Command arity) _ _, sym, (ArrPat params)]) _ _
 
 pattern PrimitivePat :: PrimitiveFunctionType -> XObj -> [XObj] -> XObj
-pattern PrimitivePat arity sym params <- XObj (Lst [XObj (Primitive arity) _ _, sym, (ArrPat _ params)]) _ _
+pattern PrimitivePat arity sym params <- XObj (Lst [XObj (Primitive arity) _ _, sym, (ArrPat params)]) _ _
 
 pattern AppPat :: XObj -> [XObj] -> [XObj]
-pattern AppPat f args <- (f:args)
-
-pattern WithPat :: XObj -> [XObj] -> [XObj]
-pattern WithPat sym forms <- (XObj With _ _: sym: forms)
-
-pattern DoPat :: [XObj] -> [XObj]
-pattern DoPat forms <- (XObj Do _ _ : forms)
-
-pattern WhilePat :: XObj -> XObj -> [XObj]
-pattern WhilePat cond body <- [XObj While _ _, cond, body]
-
-pattern SetPat :: XObj -> XObj -> [XObj]
-pattern SetPat iden value <- [XObj SetBang _ _, iden, value]
+pattern AppPat f args <- (f : args)

src/Infer.hs

@@ -14,6 +14,7 @@ import Concretize
 import Constraints
 import GenerateConstraints
 import InitialTypes
+import Memory
 import Obj
 import Qualify
 import TypeError
@@ -28,7 +29,8 @@ annotate typeEnv globalEnv qualifiedXObj rootSig =
   do
     initiated <- initialTypes typeEnv globalEnv (unQualified qualifiedXObj)
     (annotated, dependencies) <- annotateUntilDone typeEnv globalEnv initiated rootSig [] 100
-    (final, deleteDeps) <- manageMemory typeEnv globalEnv annotated
+    (final, deleteDepsTys) <- manageMemory typeEnv globalEnv annotated
+    let deleteDeps = depsForDeleteFuncs typeEnv globalEnv deleteDepsTys
     finalWithNiceTypes <- beautifyTypeVariables final
     pure (finalWithNiceTypes, dependencies ++ deleteDeps)
 

src/Info.hs

@@ -10,6 +10,8 @@ module Info
     freshVar,
     machineReadableInfo,
     makeTypeVariableNameFromInfo,
+    setDeletersOnInfo,
+    addDeletersToInfo,
   )
 where
 
@@ -105,3 +107,12 @@ makeTypeVariableNameFromInfo :: Maybe Info -> String
 makeTypeVariableNameFromInfo (Just i) =
   "tyvar-from-info-" ++ show (infoIdentifier i) ++ "_" ++ show (infoLine i) ++ "_" ++ show (infoColumn i)
 makeTypeVariableNameFromInfo Nothing = error "unnamed-typevariable"
+
+-- | Assign a set of Deleters to the 'infoDelete' field on Info.
+setDeletersOnInfo :: Maybe Info -> Set.Set Deleter -> Maybe Info
+setDeletersOnInfo i deleters = fmap (\i' -> i' {infoDelete = deleters}) i
+
+-- | Add to the set of Deleters in the 'infoDelete' field on Info.
+addDeletersToInfo :: Maybe Info -> Set.Set Deleter -> Maybe Info
+addDeletersToInfo i deleters =
+  fmap (\i' -> i' {infoDelete = Set.union (infoDelete i') deleters}) i

src/Memory.hs

@@ -0,0 +1,694 @@
+{-# LANGUAGE LambdaCase #-}
+
+module Memory (manageMemory) where
+
+import Control.Monad.State
+import Forms
+import Info
+import Managed
+import qualified Map
+import Obj
+import Polymorphism
+import Set ((\\))
+import qualified Set
+import TypeError
+import Types
+import Util
+import Prelude hiding (lookup)
+
+-- | To keep track of the deleters when recursively walking the form.
+-- | To avoid having to concretize the deleters here, they are just stored as their Ty in `memStateDeps`.
+data MemState = MemState
+  { memStateDeleters :: Set.Set Deleter,
+    memStateDeps :: Set.Set Ty,
+    memStateLifetimes :: Map.Map String LifetimeMode
+  }
+  deriving (Show)
+
+-- | Differentiate between lifetimes depending on variables in a lexical scope and depending on something outside the function.
+data LifetimeMode
+  = LifetimeInsideFunction String
+  | LifetimeOutsideFunction
+  deriving (Show)
+
+-- | Find out what deleters are needed and where in an XObj.
+-- | Deleters will be added to the info field on XObj so that
+-- | the code emitter can access them and insert calls to destructors.
+manageMemory :: TypeEnv -> Env -> XObj -> Either TypeError (XObj, Set.Set Ty)
+manageMemory typeEnv globalEnv root =
+  let (finalObj, finalState) = runState (visit root) (MemState Set.empty Set.empty Map.empty)
+      deleteThese = memStateDeleters finalState
+      deps = memStateDeps finalState
+   in -- (trace ("Delete these: " ++ joinWithComma (map show (Set.toList deleteThese)))) $
+      case finalObj of
+        Left err -> Left err
+        Right ok ->
+          let newInfo = fmap (\i -> i {infoDelete = deleteThese}) (xobjInfo ok)
+           in -- This final check of lifetimes works on the lifetimes mappings after analyzing the function form, and
+              --  after all the local variables in it have been deleted. This is needed for values that are created
+              --  directly in body position, e.g. (defn f [] &[1 2 3])
+              case evalState (refTargetIsAlive ok) (MemState Set.empty Set.empty (memStateLifetimes finalState)) of
+                Left err -> Left err
+                Right _ -> Right (ok {xobjInfo = newInfo}, deps)
+  where
+    visit :: XObj -> State MemState (Either TypeError XObj)
+    visit xobj =
+      do
+        r <- case xobjObj xobj of
+          Lst _ -> visitList xobj
+          Arr _ -> visitArray xobj
+          StaticArr _ -> visitStaticArray xobj
+          Str _ -> do
+            manage typeEnv globalEnv xobj
+            addToLifetimesMappingsIfRef False xobj -- TODO: Should "internal = True" here? TODO: Possible to remove this one?
+            pure (Right xobj)
+          Pattern _ -> do
+            manage typeEnv globalEnv xobj
+            addToLifetimesMappingsIfRef False xobj -- TODO: Also possible to remove, *should* be superseeded by (***) below?
+            pure (Right xobj)
+          _ ->
+            pure (Right xobj)
+        case r of
+          Right ok -> do
+            MemState {} <- get
+            r' <- refTargetIsAlive ok -- trace ("CHECKING " ++ pretty ok ++ " : " ++ showMaybeTy (ty xobj) ++ ", mappings: " ++ prettyLifetimeMappings m) $
+            addToLifetimesMappingsIfRef True ok -- (***)
+            pure r'
+          Left err -> pure (Left err)
+
+    visitArray :: XObj -> State MemState (Either TypeError XObj)
+    visitArray xobj@(ArrPat arr) =
+      do
+        mapM_ visit arr
+        results <- mapM (unmanage typeEnv globalEnv) arr
+        whenRight (sequence results) $
+          do
+            _ <- manage typeEnv globalEnv xobj -- TODO: result is discarded here, is that OK?
+            pure (Right xobj)
+    visitArray _ = error "Must visit array."
+
+    visitStaticArray :: XObj -> State MemState (Either TypeError XObj)
+    visitStaticArray xobj@(StaticArrPat arr) =
+      do
+        mapM_ visit arr
+        results <- mapM (unmanage typeEnv globalEnv) arr
+        whenRight (sequence results) $ do
+          -- We know that we want to add a deleter for the static array here
+          let var = varOfXObj 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 typeEnv globalEnv (xobjInfo xobj) t) var
+                Nothing ->
+                  error ("No deleter found for Static Array : " ++ show t) --Just (FakeDeleter var)
+          MemState deleters deps lifetimes <- get
+          let newDeleters = Set.insert deleter deleters
+              newDeps = Set.insert t deps
+              newState = MemState newDeleters newDeps lifetimes
+          put newState --(trace (show newState) newState)
+          pure (Right xobj)
+    visitStaticArray _ = error "Must visit static array."
+
+    visitList :: XObj -> State MemState (Either TypeError XObj)
+    visitList xobj@(XObj (Lst lst) i t) =
+      case lst of
+        [defn@(XObj (Defn maybeCaptures) _ _), nameSymbol@(XObj (Sym _ _) _ _), args@(XObj (Arr argList) _ _), body] ->
+          let captures = maybe [] Set.toList maybeCaptures
+           in do
+                mapM_ (manage typeEnv globalEnv) argList
+                -- Add the captured variables (if any, only happens in lifted lambdas) as fake deleters
+                -- TODO: Use another kind of Deleter for this case since it's pretty special?
+                mapM_
+                  ( ( \cap ->
+                        modify
+                          ( \memState ->
+                              memState {memStateDeleters = Set.insert (FakeDeleter cap) (memStateDeleters memState)}
+                          )
+                    )
+                      . getName
+                  )
+                  captures
+                mapM_ (addToLifetimesMappingsIfRef False) argList
+                mapM_ (addToLifetimesMappingsIfRef False) captures -- For captured variables inside of lifted lambdas
+                visitedBody <- visit body
+                result <- unmanage typeEnv globalEnv body
+                whenRightReturn result $
+                  do
+                    okBody <- visitedBody
+                    Right (XObj (Lst [defn, nameSymbol, args, okBody]) i t)
+
+        -- Fn / λ (Lambda)
+        [fn@(XObj (Fn _ captures) _ _), args@(XObj (Arr _) _ _), body] ->
+          do
+            manage typeEnv globalEnv xobj -- manage inner lambdas but leave their bodies unvisited, they will be visited in the lifted version...
+            mapM_ (unmanage typeEnv globalEnv) captures
+            pure (Right (XObj (Lst [fn, args, body]) i t))
+
+        -- Def
+        DefPat def nameSymbol expr ->
+          do
+            visitedExpr <- visit expr
+            result <- unmanage typeEnv globalEnv expr
+            whenRightReturn result $
+              do
+                okExpr <- visitedExpr
+                Right (XObj (Lst [def, nameSymbol, okExpr]) i t)
+        -- Let
+        LetPat letExpr (XObj (Arr bindings) bindi bindt) body ->
+          do
+            MemState preDeleters _ _ <- get
+            visitedBindings <- mapM visitLetBinding (pairwise bindings)
+            visitedBody <- visit body
+            result <- unmanage typeEnv globalEnv body
+            whenRight result $
+              do
+                MemState postDeleters deps postLifetimes <- get
+                let diff = postDeleters Set.\\ preDeleters
+                    newInfo = setDeletersOnInfo i diff
+                    survivors = postDeleters Set.\\ diff -- Same as just pre deleters, right?!
+                put (MemState survivors deps postLifetimes)
+                --trace ("LET Pre: " ++ show preDeleters ++ "\nPost: " ++ show postDeleters ++ "\nDiff: " ++ show diff ++ "\nSurvivors: " ++ show survivors)
+                manage typeEnv globalEnv xobj
+                pure $ do
+                  okBody <- visitedBody
+                  let finalBody = searchForInnerBreak diff okBody
+                  okBindings <- fmap (concatMap (\(n, x) -> [n, x])) (sequence visitedBindings)
+                  pure (XObj (Lst [letExpr, XObj (Arr okBindings) bindi bindt, finalBody]) newInfo t)
+
+        -- Set!
+        SetPat setbangExpr variable value ->
+          let varInfo = xobjInfo variable
+              correctVariableAndMode =
+                case variable of
+                  symObj@(XObj (Sym _ mode) _ _) -> Right (symObj, mode)
+                  anythingElse -> Left (CannotSet anythingElse)
+           in case correctVariableAndMode of
+                Left err ->
+                  pure (Left err)
+                Right (okCorrectVariable, okMode) ->
+                  do
+                    MemState preDeleters _ _ <- get
+                    let ownsTheVarBefore = case createDeleter typeEnv globalEnv okCorrectVariable of
+                          Nothing -> Right ()
+                          Just d ->
+                            if Set.member d preDeleters || isLookupGlobal okMode
+                              then Right ()
+                              else Left (UsingUnownedValue variable)
+                    visitedValue <- visit value
+                    _ <- unmanage typeEnv globalEnv value -- The assigned value can't be used anymore
+                    MemState managed _ _ <- get
+                    -- Delete the value previously stored in the variable, if it's still alive
+                    let deleters = case createDeleter typeEnv globalEnv okCorrectVariable of
+                          Just d -> Set.fromList [d]
+                          Nothing -> Set.empty
+                        newVariable =
+                          case okMode of
+                            Symbol -> error "How to handle this?"
+                            LookupLocal _ ->
+                              if Set.size (Set.intersection managed deleters) == 1 -- The variable is still alive
+                                then variable {xobjInfo = setDeletersOnInfo varInfo deleters}
+                                else variable -- don't add the new info = no deleter
+                            LookupGlobal _ _ ->
+                              variable {xobjInfo = setDeletersOnInfo varInfo deleters}
+                            _ -> error "managememory set! 1"
+                    case okMode of
+                      Symbol -> error "Should only be be a global/local lookup symbol."
+                      LookupLocal _ -> manage typeEnv globalEnv okCorrectVariable
+                      LookupGlobal _ _ -> pure ()
+                      _ -> error "managememory set! 2"
+                    pure $ case okMode of
+                      LookupLocal (Capture _) ->
+                        Left (CannotSetVariableFromLambda variable setbangExpr)
+                      _ ->
+                        do
+                          okValue <- visitedValue
+                          _ <- ownsTheVarBefore -- Force Either to fail
+                          pure (XObj (Lst [setbangExpr, newVariable, okValue]) i t)
+
+        -- The
+        ThePat theExpr typeXObj value ->
+          do
+            visitedValue <- visit value
+            result <- transferOwnership typeEnv globalEnv value xobj
+            whenRightReturn result $
+              do
+                okValue <- visitedValue
+                Right (XObj (Lst [theExpr, typeXObj, okValue]) i t)
+
+        -- Ref
+        RefPat refExpr value ->
+          do
+            visited <- visit value
+            case visited of
+              Left e -> pure (Left e)
+              Right visitedValue ->
+                do
+                  result <- canBeReferenced typeEnv globalEnv visitedValue
+                  whenRightReturn result $ do
+                    Right (XObj (Lst [refExpr, visitedValue]) i t)
+
+        -- Deref
+        (XObj Deref _ _ : _) ->
+          error "Shouldn't end up here, deref only works when calling a function, i.e. ((deref f) 1 2 3)."
+        -- Do
+        DoPat doExpr expressions ->
+          do
+            visitedExpressions <- mapM visit expressions
+            result <- transferOwnership typeEnv globalEnv (last expressions) xobj
+            whenRightReturn result $ do
+              okExpressions <- sequence visitedExpressions
+              Right (XObj (Lst (doExpr : okExpressions)) i t)
+
+        -- While
+        WhilePat whileExpr expr body ->
+          do
+            MemState preDeleters _ _ <- get
+            visitedExpr <- visit expr
+            MemState afterExprDeleters _ _ <- get
+            visitedBody <- visit body
+            manage typeEnv globalEnv body
+            MemState postDeleters deps postLifetimes <- get
+            -- Visit an extra time to simulate repeated use
+            visitedExpr2 <- visit expr
+            visitedBody2 <- visit body
+            let diff = postDeleters \\ preDeleters
+            put (MemState (postDeleters \\ diff) deps postLifetimes) -- Same as just pre deleters, right?!
+            pure $ do
+              okExpr <- visitedExpr
+              okBody <- visitedBody
+              _ <- visitedExpr2 -- This evaluates the second visit so that it actually produces the error
+              _ <- visitedBody2 -- And this one too. Laziness FTW.
+              let newInfo = setDeletersOnInfo i diff
+                  -- Also need to set deleters ON the expression (for first run through the loop)
+                  XObj objExpr objInfo objTy = okExpr
+                  newExprInfo = setDeletersOnInfo objInfo (afterExprDeleters \\ preDeleters)
+                  newExpr = XObj objExpr newExprInfo objTy
+                  finalBody = searchForInnerBreak diff okBody
+              pure (XObj (Lst [whileExpr, newExpr, finalBody]) newInfo t)
+
+        -- If
+        IfPat ifExpr expr ifTrue ifFalse ->
+          do
+            visitedExpr <- visit expr
+            MemState preDeleters deps lifetimes <- get
+            let (visitedTrue, stillAliveTrue) =
+                  runState
+                    ( do
+                        v <- visit ifTrue
+                        result <- transferOwnership typeEnv globalEnv ifTrue xobj
+                        pure $ case result of
+                          Left e -> error (show e)
+                          Right () -> v
+                    )
+                    (MemState preDeleters deps lifetimes)
+                (visitedFalse, stillAliveFalse) =
+                  runState
+                    ( do
+                        v <- visit ifFalse
+                        result <- transferOwnership typeEnv globalEnv ifFalse xobj
+                        pure $ case result of
+                          Left e -> error (show e)
+                          Right () -> v
+                    )
+                    (MemState preDeleters deps lifetimes)
+            let deletedInTrue = preDeleters \\ memStateDeleters stillAliveTrue
+                deletedInFalse = preDeleters \\ memStateDeleters stillAliveFalse
+                deletedInBoth = Set.intersection deletedInTrue deletedInFalse
+                createdInTrue = memStateDeleters stillAliveTrue \\ preDeleters
+                createdInFalse = memStateDeleters stillAliveFalse \\ preDeleters
+                selfDeleter = case createDeleter typeEnv globalEnv xobj of
+                  Just ok -> Set.fromList [ok]
+                  Nothing -> Set.empty
+                createdAndDeletedInTrue = createdInTrue \\ selfDeleter
+                createdAndDeletedInFalse = createdInFalse \\ selfDeleter
+                delsTrue = Set.union (deletedInFalse \\ deletedInBoth) createdAndDeletedInTrue
+                delsFalse = Set.union (deletedInTrue \\ deletedInBoth) createdAndDeletedInFalse
+                stillAliveAfter = preDeleters \\ Set.union deletedInTrue deletedInFalse
+                -- Note: The following line merges all previous deps and the new ones, could be optimized?
+                depsAfter = Set.unions [memStateDeps stillAliveTrue, memStateDeps stillAliveFalse, deps]
+            put (MemState stillAliveAfter depsAfter lifetimes)
+            manage typeEnv globalEnv xobj
+            pure $ do
+              okExpr <- visitedExpr
+              okTrue <- visitedTrue
+              okFalse <- visitedFalse
+              pure (XObj (Lst [ifExpr, okExpr, setDeletersOnXObj okTrue delsTrue, setDeletersOnXObj okFalse delsFalse]) i t)
+
+        -- Match
+        -- The general idea of how to figure out what to delete in a 'match' statement:
+        -- 1. Visit each case and investigate which variables are deleted in each one of the cases
+        -- 2. Variables deleted in at least one case has to be deleted in all, so make a union U of all such vars
+        --    but remove the ones that were not present before the 'match'
+        -- 3. In each case - take the intersection of U and the vars deleted in that case and add this result to its deleters
+        matchExpr@(XObj (Match _) _ _) : expr : cases ->
+          do
+            visitedExpr <- visit expr
+            case visitedExpr of
+              Left e -> pure (Left e)
+              Right okVisitedExpr ->
+                do
+                  _ <- unmanage typeEnv globalEnv okVisitedExpr
+                  MemState preDeleters deps lifetimes <- get
+                  vistedCasesAndDeps <- mapM visitMatchCase (pairwise cases)
+                  case sequence vistedCasesAndDeps of
+                    Left e -> pure (Left e)
+                    Right okCasesAndDeps ->
+                      let visitedCases = map fst okCasesAndDeps
+                          depsFromCases = Set.unions (map snd okCasesAndDeps)
+                          (finalXObj, postDeleters) = analyzeFinal okVisitedExpr visitedCases preDeleters
+                       in do
+                            put (MemState postDeleters (Set.union deps depsFromCases) lifetimes)
+                            manage typeEnv globalEnv xobj
+                            pure (Right finalXObj)
+          where
+            analyzeFinal :: XObj -> [(Set.Set Deleter, (XObj, XObj))] -> Set.Set Deleter -> (XObj, Set.Set Deleter)
+            analyzeFinal okVisitedExpr visitedCasesWithDeleters preDeleters =
+              let postDeleters = map fst visitedCasesWithDeleters
+                  -- postDeletersUnion = unionOfSetsInList postDeleters
+                  postDeletersIntersection = intersectionOfSetsInList postDeleters
+                  deletersAfterTheMatch = Set.intersection preDeleters postDeletersIntersection
+                  -- The "postDeletersUnionPreExisting" are the vars that existed before the match but needs to
+                  -- be deleted after it has executed (because some branches delete them)
+                  -- postDeletersUnionPreExisting = Set.intersection postDeletersUnion preDeleters
+                  deletersForEachCase = map (\\ deletersAfterTheMatch) postDeleters
+                  -- These are the surviving vars after the 'match' expression:
+                  okVisitedCases = map snd visitedCasesWithDeleters
+                  okVisitedCasesWithAllDeleters =
+                    zipWith
+                      ( \(lhs, rhs) finalSetOfDeleters ->
+                          -- Putting the deleter info on the lhs,
+                          -- because the right one can collide with
+                          -- the other expressions, e.g. a 'let'
+                          let newLhsInfo = setDeletersOnInfo (xobjInfo lhs) finalSetOfDeleters
+                           in [lhs {xobjInfo = newLhsInfo}, rhs]
+                      )
+                      okVisitedCases
+                      deletersForEachCase
+               in ( XObj (Lst ([matchExpr, okVisitedExpr] ++ concat okVisitedCasesWithAllDeleters)) i t,
+                    deletersAfterTheMatch
+                  )
+
+        -- Deref (only works in function application)
+        XObj (Lst [deref@(XObj Deref _ _), f]) xi xt : uargs ->
+          do
+            -- Do not visit f in this case, we don't want to manage it's memory since it is a ref!
+            visitedArgs <- sequence <$> mapM visitArg uargs
+            case visitedArgs of
+              Left err -> pure (Left err)
+              Right args ->
+                do
+                  unmanagedArgs <- sequence <$> mapM unmanageArg args
+                  manage typeEnv globalEnv xobj
+                  pure $ do
+                    okArgs <- unmanagedArgs
+                    Right (XObj (Lst (XObj (Lst [deref, f]) xi xt : okArgs)) i t)
+
+        -- Function application
+        f : uargs ->
+          do
+            visitedF <- visit f
+            visitedArgs <- sequence <$> mapM visitArg uargs
+            case visitedArgs of
+              Left err -> pure (Left err)
+              Right args -> do
+                unmanagedArgs <- sequence <$> mapM unmanageArg args
+                manage typeEnv globalEnv xobj
+                pure $ do
+                  okF <- visitedF
+                  okArgs <- unmanagedArgs
+                  Right (XObj (Lst (okF : okArgs)) i t)
+        [] -> pure (Right xobj)
+    visitList _ = error "Must visit list."
+
+    visitMatchCase :: (XObj, XObj) -> State MemState (Either TypeError ((Set.Set Deleter, (XObj, XObj)), Set.Set Ty))
+    visitMatchCase (lhs@XObj {}, rhs@XObj {}) =
+      do
+        MemState preDeleters _ _ <- get
+        _ <- visitCaseLhs lhs
+        visitedRhs <- visit rhs
+        _ <- unmanage typeEnv globalEnv rhs
+        MemState postDeleters postDeps postLifetimes <- get
+        put (MemState preDeleters postDeps postLifetimes) -- Restore managed variables, TODO: Use a "local" state monad instead?
+        pure $ do
+          okVisitedRhs <- visitedRhs
+          pure ((postDeleters, (lhs, okVisitedRhs)), postDeps)
+
+    visitCaseLhs :: XObj -> State MemState (Either TypeError [()])
+    visitCaseLhs (XObj (Lst vars) _ _) =
+      do
+        result <- mapM visitCaseLhs vars
+        let result' = sequence result
+        pure (fmap concat result')
+    visitCaseLhs xobj@(XObj (Sym (SymPath _ name) _) _ _)
+      | isVarName name = do
+        manage typeEnv globalEnv xobj
+        pure (Right [])
+      | otherwise = pure (Right [])
+    visitCaseLhs (XObj Ref _ _) =
+      pure (Right [])
+    visitCaseLhs x =
+      error ("Unhandled: " ++ show x)
+
+    visitLetBinding :: (XObj, XObj) -> State MemState (Either TypeError (XObj, XObj))
+    visitLetBinding (name, expr) =
+      do
+        visitedExpr <- visit expr
+        addToLifetimesMappingsIfRef True expr
+        result <- transferOwnership typeEnv globalEnv expr name
+        whenRightReturn result $ do
+          okExpr <- visitedExpr
+          pure (name, okExpr)
+
+    visitArg :: XObj -> State MemState (Either TypeError XObj)
+    visitArg xobj@(XObj _ _ (Just _)) =
+      do
+        afterVisit <- visit xobj
+        case afterVisit of
+          Right okAfterVisit -> do
+            addToLifetimesMappingsIfRef True okAfterVisit
+            pure (Right okAfterVisit)
+          Left err -> pure (Left err)
+    visitArg xobj@XObj {} =
+      visit xobj
+
+    unmanageArg :: XObj -> State MemState (Either TypeError XObj)
+    unmanageArg xobj@(XObj _ _ (Just t)) =
+      if isManaged typeEnv globalEnv t
+        then do
+          r <- unmanage typeEnv globalEnv xobj
+          pure $ case r of
+            Left err -> Left err
+            Right () -> Right xobj
+        else pure (Right xobj)
+    unmanageArg xobj@XObj {} =
+      pure (Right xobj)
+
+--------------------------------------------------------------------------------
+-- The basic primitives of memory management
+
+-- | Add `xobj` to the set of alive variables, in need of deletion at end of scope.
+manage :: TypeEnv -> Env -> XObj -> State MemState ()
+manage typeEnv globalEnv xobj =
+  if isSymbolThatCaptures xobj -- When visiting lifted lambdas, don't manage symbols that capture (they are owned by the environment).
+    then pure ()
+    else case createDeleter typeEnv globalEnv xobj of
+      Just deleter -> do
+        MemState deleters deps lifetimes <- get
+        let newDeleters = Set.insert deleter deleters
+            Just t = xobjTy xobj
+            newDeps = Set.insert t deps
+        put (MemState newDeleters newDeps lifetimes)
+      Nothing -> pure ()
+
+-- | Remove `xobj` from the set of alive variables, in need of deletion at end of scope.
+unmanage :: TypeEnv -> Env -> XObj -> State MemState (Either TypeError ())
+unmanage typeEnv globalEnv xobj =
+  let Just t = xobjTy xobj
+   in if isManaged typeEnv globalEnv t && not (isGlobalFunc xobj)
+        then do
+          MemState deleters deps lifetimes <- get
+          case deletersMatchingXObj xobj deleters of
+            [] ->
+              pure $
+                if isSymbolThatCaptures xobj
+                  then Left (UsingCapturedValue xobj)
+                  else Left (UsingUnownedValue xobj)
+            [one] ->
+              let newDeleters = Set.delete one deleters
+               in do
+                    put (MemState newDeleters deps lifetimes)
+                    pure (Right ())
+            tooMany -> error ("Too many variables with the same name in set: " ++ show tooMany)
+        else pure (Right ())
+
+-- | A combination of `manage` and `unmanage`.
+transferOwnership :: TypeEnv -> Env -> XObj -> XObj -> State MemState (Either TypeError ())
+transferOwnership typeEnv globalEnv from to =
+  do
+    result <- unmanage typeEnv globalEnv from
+    whenRight result $ do
+      manage typeEnv globalEnv to --(trace ("Transfered from " ++ getName from ++ " '" ++ varOfXObj from ++ "' to " ++ getName to ++ " '" ++ varOfXObj to ++ "'") to)
+      pure (Right ())
+
+-- | Control that an `xobj` is OK to reference
+canBeReferenced :: TypeEnv -> Env -> XObj -> State MemState (Either TypeError ())
+canBeReferenced typeEnv globalEnv xobj =
+  let Just t = xobjTy xobj
+      isGlobalVariable = case xobj of
+        XObj (Sym _ (LookupGlobal _ _)) _ _ -> True
+        _ -> False
+   in -- TODO: The 'isManaged typeEnv t' boolean check should be removed
+      if not isGlobalVariable && not (isGlobalFunc xobj) && isManaged typeEnv globalEnv t && not (isSymbolThatCaptures xobj)
+        then do
+          MemState deleters _ _ <- get
+          pure $ case deletersMatchingXObj xobj deleters of
+            [] -> Left (GettingReferenceToUnownedValue xobj)
+            [_] -> pure ()
+            _ -> error $ "Too many variables with the same name in set (was looking for " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj ++ ")"
+        else pure (Right ())
+
+-- | Makes sure that whatever a reference is refering too, is still alive (i.e. in the set of live Deleters)
+refTargetIsAlive :: XObj -> State MemState (Either TypeError XObj)
+refTargetIsAlive xobj =
+  -- TODO: Replace this whole thing with a function that collects all lifetime variables in a type.
+  case xobjTy xobj of
+    Just (RefTy _ (VarTy lt)) ->
+      performCheck lt
+    Just (FuncTy _ _ (VarTy lt)) ->
+      performCheck lt
+    -- HACK (not exhaustive):
+    Just (FuncTy _ (RefTy _ (VarTy lt)) _) ->
+      performCheck lt
+    _ ->
+      pure -- trace ("Won't check " ++ pretty xobj ++ " : " ++ show (ty xobj))
+        (Right xobj)
+  where
+    performCheck :: String -> State MemState (Either TypeError XObj)
+    performCheck lt =
+      do
+        MemState deleters _ lifetimeMappings <- get
+        case Map.lookup lt lifetimeMappings of
+          Just (LifetimeInsideFunction deleterName) ->
+            let matchingDeleters =
+                  Set.toList $
+                    Set.filter
+                      ( \case
+                          ProperDeleter {deleterVariable = dv} -> dv == deleterName
+                          FakeDeleter {deleterVariable = dv} -> dv == deleterName
+                          PrimDeleter {aliveVariable = dv} -> dv == deleterName
+                          RefDeleter {refVariable = dv} -> dv == deleterName
+                      )
+                      deleters
+             in case matchingDeleters of
+                  [] ->
+                    --trace ("Can't use reference " ++ pretty xobj ++ " (with lifetime '" ++ lt ++ "', depending on " ++ show deleterName ++ ") at " ++ prettyInfoFromXObj xobj ++ ", it's not alive here:\n" ++ show xobj ++ "\nMappings: " ++ prettyLifetimeMappings lifetimeMappings ++ "\nAlive: " ++ show deleters ++ "\n") $
+                    --pure (Right xobj)
+                    pure (Left (UsingDeadReference xobj deleterName))
+                  _ ->
+                    --trace ("CAN use reference " ++ pretty xobj ++ " (with lifetime '" ++ lt ++ "', depending on " ++ show deleterName ++ ") at " ++ prettyInfoFromXObj xobj ++ ", it's not alive here:\n" ++ show xobj ++ "\nMappings: " ++ prettyLifetimeMappings lifetimeMappings ++ "\nAlive: " ++ show deleters ++ "\n") $
+                    pure (Right xobj)
+          Just LifetimeOutsideFunction ->
+            --trace ("Lifetime OUTSIDE function: " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj) $
+            pure (Right xobj)
+          Nothing ->
+            pure (Right xobj)
+
+-- | Map from lifetime variables (of refs) to a `LifetimeMode`
+-- | (usually containing the name of the XObj that the lifetime is tied to).
+addToLifetimesMappingsIfRef :: Bool -> XObj -> State MemState ()
+addToLifetimesMappingsIfRef internal xobj =
+  case xobjTy xobj of
+    Just (RefTy _ (VarTy lt)) ->
+      do
+        m@(MemState _ _ lifetimes) <- get
+        case Map.lookup lt lifetimes of
+          Just _ ->
+            --trace ("\nThere is already a mapping for '" ++ pretty xobj ++ "' from the lifetime '" ++ lt ++ "' to " ++ show existing ++ ", won't add " ++ show (makeLifetimeMode xobj)) $
+            pure ()
+          Nothing ->
+            do
+              let lifetimes' = Map.insert lt makeLifetimeMode lifetimes
+              put $ --(trace $ "\nExtended lifetimes mappings for '" ++ pretty xobj ++ "' with " ++ show lt ++ " => " ++ show (makeLifetimeMode xobj) ++ " at " ++ prettyInfoFromXObj xobj ++ ":\n" ++ prettyLifetimeMappings lifetimes') $
+                m {memStateLifetimes = lifetimes'}
+              pure ()
+    Just _ ->
+      --trace ("Won't add to mappings! " ++ pretty xobj ++ " : " ++ show notThisType ++ " at " ++ prettyInfoFromXObj xobj) $
+      pure ()
+    _ ->
+      --trace ("No type on " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj) $
+      pure ()
+  where
+    makeLifetimeMode =
+      if internal
+        then LifetimeInsideFunction $
+          case xobj of
+            XObj (Lst [XObj Ref _ _, target]) _ _ -> varOfXObj target
+            _ -> varOfXObj xobj
+        else LifetimeOutsideFunction
+
+--------------------------------------------------------------------------------
+-- Deleters
+
+deletersMatchingXObj :: XObj -> Set.Set Deleter -> [Deleter]
+deletersMatchingXObj xobj deleters =
+  let var = varOfXObj xobj
+   in Set.toList $
+        Set.filter
+          ( \case
+              ProperDeleter {deleterVariable = dv} -> dv == var
+              FakeDeleter {deleterVariable = dv} -> dv == var
+              PrimDeleter {aliveVariable = dv} -> dv == var
+              RefDeleter {refVariable = dv} -> dv == var
+          )
+          deleters
+
+-- | Helper function for setting the deleters for an XObj.
+setDeletersOnXObj :: XObj -> Set.Set Deleter -> XObj
+setDeletersOnXObj xobj deleters = xobj {xobjInfo = setDeletersOnInfo (xobjInfo xobj) deleters}
+
+createDeleter :: TypeEnv -> Env -> XObj -> Maybe Deleter
+createDeleter typeEnv globalEnv xobj =
+  case xobjTy xobj of
+    Just (RefTy _ _) -> Just (RefDeleter (varOfXObj xobj))
+    Just t ->
+      let var = varOfXObj xobj
+       in if isManaged typeEnv globalEnv t
+            then case nameOfPolymorphicFunction typeEnv globalEnv (FuncTy [t] UnitTy StaticLifetimeTy) "delete" of
+              Just pathOfDeleteFunc ->
+                Just (ProperDeleter pathOfDeleteFunc (getDropFunc typeEnv globalEnv (xobjInfo xobj) t) var)
+              Nothing ->
+                --trace ("Found no delete function for " ++ var ++ " : " ++ (showMaybeTy (ty xobj)))
+                Just (FakeDeleter var)
+            else Just (PrimDeleter var)
+    Nothing -> error ("No type, can't manage " ++ show xobj)
+
+getDropFunc :: TypeEnv -> Env -> Maybe Info -> Ty -> Maybe SymPath
+getDropFunc typeEnv globalEnv i t =
+  nameOfPolymorphicFunction typeEnv globalEnv (FuncTy [RefTy t (VarTy (makeTypeVariableNameFromInfo i))] UnitTy StaticLifetimeTy) "drop"
+
+-- | To make the `while` form behave correctly with memory management rules
+searchForInnerBreak :: Set.Set Deleter -> XObj -> XObj
+searchForInnerBreak diff (XObj (Lst [(XObj Break i' t')]) xi xt) =
+  let ni = addDeletersToInfo i' diff
+   in XObj (Lst [(XObj Break ni t')]) xi xt
+searchForInnerBreak _ x@(XObj (Lst ((XObj While _ _) : _)) _ _) = x
+searchForInnerBreak diff (XObj (Lst elems) i' t') =
+  let newElems = map (searchForInnerBreak diff) elems
+   in XObj (Lst newElems) i' t'
+searchForInnerBreak _ e = e
+
+--------------------------------------------------------------------------------
+-- Helpers
+
+isSymbolThatCaptures :: XObj -> Bool
+isSymbolThatCaptures xobj =
+  case xobj of
+    XObj (Sym _ (LookupLocal (Capture _))) _ _ -> True
+    _ -> False
+
+-- | Show lifetime mappings in a more readable way.
+-- prettyLifetimeMappings :: Map.Map String LifetimeMode -> String
+-- prettyLifetimeMappings mappings =
+--   joinLines (map prettyMapping (Map.toList mappings))
+--   where
+--     prettyMapping (key, value) = "  " ++ key ++ " => " ++ show value

src/Obj.hs

@@ -1027,6 +1027,15 @@ unwrapSymPathXObj :: XObj -> Either String SymPath
 unwrapSymPathXObj (XObj (Sym p _) _ _) = Right p
 unwrapSymPathXObj x = Left ("The value '" ++ pretty x ++ "' at " ++ prettyInfoFromXObj x ++ " is not a Symbol.")
 
+-- | Gives the name used to refer to a specific XObj (in emitted code)
+varOfXObj :: XObj -> String
+varOfXObj xobj =
+  case xobj of
+    XObj (Sym path _) _ _ -> pathToC path
+    _ -> case xobjInfo xobj of
+      Just i -> freshVar i
+      Nothing -> error ("Missing info on " ++ show xobj)
+
 -- | Given a form, what definition mode will it generate?
 definitionMode :: XObj -> DefinitionMode
 definitionMode (XObj (Lst (XObj Def _ _ : _)) _ _) = AVariable

src/Polymorphism.hs

@@ -1,9 +1,15 @@
 module Polymorphism
   ( nameOfPolymorphicFunction,
+    allImplementations,
+    FunctionFinderResult (..),
+    findFunctionForMember,
+    findFunctionForMemberIncludePrimitives,
   )
 where
 
-import Env as E
+import Data.Either (fromRight)
+import Env
+import Managed
 import Obj
 import Types
 
@@ -19,8 +25,8 @@ import Types
 nameOfPolymorphicFunction :: TypeEnv -> Env -> Ty -> String -> Maybe SymPath
 nameOfPolymorphicFunction _ env functionType functionName =
   let foundBinder =
-        (E.findPoly env functionName functionType)
-          <> (E.findPoly (progenitor env) functionName functionType)
+        (findPoly env functionName functionType)
+          <> (findPoly (progenitor env) functionName functionType)
    in case foundBinder of
         Right (_, (Binder _ (XObj (Lst (XObj (External (Just name)) _ _ : _)) _ _))) ->
           Just (SymPath [] name)
@@ -31,3 +37,91 @@ nameOfPolymorphicFunction _ env functionType functionName =
               concretizedPath = SymPath pathStrings (name ++ suffix)
            in Just concretizedPath
         _ -> Nothing
+
+-- | Find ALL functions with a certain name, matching a type signature.
+-- When the functionName argument denotes an interface, the name will match iff either:
+--   1. The name of the binding matches functionName exactly OR
+--   2. The name of the binding matches one of the names in the interface's implementation paths
+-- 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)
+  where
+    predicate (Just t) =
+      --trace ("areUnifiable? " ++ show functionType ++ " == " ++ show t ++ " " ++ show (areUnifiable functionType t)) $
+      areUnifiable functionType t
+    predicate Nothing = error "allfunctionswithnameandsignature"
+    foundBindings = case getTypeBinder typeEnv functionName of
+      -- this function is an interface; lookup implementations
+      Right (Binder _ (XObj (Lst (XObj (Interface _ paths) _ _ : _)) _ _)) ->
+        case sequence $ map (\p -> searchValue env p) (paths ++ [(SymPath [] functionName)]) of
+          Right found -> found
+          Left _ ->
+            case findPoly env functionName functionType of
+              Right r -> [r]
+              Left _ -> (lookupEverywhere env functionName)
+      -- just a regular function; look for it
+      _ -> fromRight [] ((fmap (: []) (Env.getValue env functionName)) <> pure (lookupEverywhere env functionName))
+
+-- | The various results when trying to find a function using 'findFunctionForMember'.
+data FunctionFinderResult
+  = FunctionFound String
+  | FunctionNotFound String
+  | FunctionIgnored
+  deriving (Show)
+
+-- | Used for finding functions like 'delete' or 'copy' for members of a Deftype (or Array).
+findFunctionForMember :: TypeEnv -> Env -> String -> Ty -> (String, Ty) -> FunctionFinderResult
+findFunctionForMember typeEnv env functionName functionType (memberName, memberType)
+  | isManaged typeEnv env memberType =
+    case allImplementations typeEnv env functionName functionType of
+      [] ->
+        FunctionNotFound
+          ( "Can't find any '" ++ functionName ++ "' function for member '"
+              ++ memberName
+              ++ "' of type "
+              ++ show functionType
+          )
+      [(_, Binder _ single)] ->
+        let concretizedPath = getConcretizedPath single functionType
+         in FunctionFound (pathToC concretizedPath)
+      _ ->
+        FunctionNotFound
+          ( "Can't find a single '" ++ functionName ++ "' function for member '"
+              ++ memberName
+              ++ "' of type "
+              ++ show functionType
+          )
+  | otherwise = FunctionIgnored
+
+-- | TODO: should this be the default and 'findFunctionForMember' be the specific one
+findFunctionForMemberIncludePrimitives :: TypeEnv -> Env -> String -> Ty -> (String, Ty) -> FunctionFinderResult
+findFunctionForMemberIncludePrimitives typeEnv env functionName functionType (memberName, _) =
+  case allImplementations typeEnv env functionName functionType of
+    [] ->
+      FunctionNotFound
+        ( "Can't find any '" ++ functionName ++ "' function for member '"
+            ++ memberName
+            ++ "' of type "
+            ++ show functionType
+        )
+    [(_, Binder _ single)] ->
+      let concretizedPath = getConcretizedPath single functionType
+       in FunctionFound (pathToC concretizedPath)
+    _ ->
+      FunctionNotFound
+        ( "Can't find a single '" ++ functionName ++ "' function for member '"
+            ++ memberName
+            ++ "' of type "
+            ++ show functionType
+        )
+
+-- | Creates a new SymPath with a suffix added to the name,
+-- for differentiating the concrete version of the function from
+-- its generic ancestor.
+getConcretizedPath :: XObj -> Ty -> SymPath
+getConcretizedPath defn functionType =
+  let Just t' = xobjTy defn
+      SymPath pathStrings name = getPath defn
+      suffix = polymorphicSuffix t' functionType
+   in SymPath pathStrings (name ++ suffix)

src/Set.hs

@@ -28,6 +28,9 @@ intersection (Set a) (Set b) = Set (S.intersection a b)
 union :: Ord v => Set v -> Set v -> Set v
 union (Set a) (Set b) = Set (S.union a b)
 
+unions :: (Functor f, Foldable f, Ord a) => f (Set a) -> Set a
+unions sets = Set $ S.unions (fmap unSet sets)
+
 member :: Ord v => v -> Set v -> Bool
 member k (Set s) = S.member k s
 

src/StructUtils.hs

@@ -5,6 +5,8 @@ import Obj
 import Polymorphism
 import Types
 
+data AllocationMode = StackAlloc | HeapAlloc
+
 -- | The 'str'/'prn' functions for primitive types don't take refs, while other types do
 -- so we need to adjust for that when finding and calling them in compound types.
 -- The returned tuple contains ("" || "&", `str function type`).

src/Util.hs

@@ -130,6 +130,10 @@ toMaybe f e = either (const Nothing) (Just . f) e
 maybeId :: Either a b -> Maybe b
 maybeId = toMaybe id
 
-whenRight :: Monad m => Either a b -> m (Either a c) -> m (Either a c)
+whenRight :: Applicative f => Either a b -> f (Either a c) -> f (Either a c)
 whenRight (Right _) cont = cont
 whenRight (Left err) _ = pure (Left err)
+
+whenRightReturn :: Applicative f => Either a b -> Either a c -> f (Either a c)
+whenRightReturn (Right _) cont = pure cont
+whenRightReturn (Left err) _ = pure (Left err)