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

refactor: Cleanup Concretize module (#1283)

Browse Source 
* refactor: refactor concretize module

This commit primarily refactors the concretize module, breaking out the
local definitions for visit functions into top level functions that are
hopefully easier to change. I've also modified some monadic code in the
interest of terseness.

This commit adds some additional patterns for XObj forms as well.

* refactor: Only export called functions in Concretize

Adds an export list to Concretize so that the module encapsulates those
functions that are only used internally within the module.

* refactor: better names in concretize functions

Clarify the names of variables in visitor type functions.
This commit is contained in:
Scott Olsen 2021-08-05 01:36:29 -04:00 committed by GitHub
parent 50680e921a
commit b74e674bb1
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
5 changed files with 500 additions and 411 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

870
src/Concretize.hs
View File

@ -1,14 +1,37 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
module Concretize where -- | Module Concretize determines the dependencies of polymorphic objects and
-- resolves the object into a "concrete" version, where its types are no longer
-- variables.
module Concretize
( concretizeXObj,
concretizeType,
depsForCopyFunc,
depsForPrnFunc,
depsForDeleteFunc,
depsForDeleteFuncs,
depsOfPolymorphicFunction,
typesStrFunctionType,
concreteDelete,
memberDeletion,
memberRefDeletion,
concreteCopy,
tokensForCopy,
memberCopy,
replaceGenericTypeSymbolsOnMembers,
)
where
import AssignTypes import AssignTypes
import Constraints import Constraints
import Control.Applicative
import Control.Monad.State import Control.Monad.State
import Data.Either (fromRight)
import Data.List (foldl') import Data.List (foldl')
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Debug.Trace import Debug.Trace
import Env (envIsExternal, getTypeBinder, insert, insertX, searchValue) import Env (EnvironmentError, empty, envIsExternal, getTypeBinder, insert, insertX, searchValue)
import Forms
import Info import Info
import InitialTypes import InitialTypes
import Managed import Managed
@ -36,339 +59,388 @@ data Level = Toplevel | Inside
-- | Both of these results are returned in a tuple: (<new xobj>, <dependencies>) -- | Both of these results are returned in a tuple: (<new xobj>, <dependencies>)
concretizeXObj :: Bool -> TypeEnv -> Env -> [SymPath] -> XObj -> Either TypeError (XObj, [XObj]) concretizeXObj :: Bool -> TypeEnv -> Env -> [SymPath] -> XObj -> Either TypeError (XObj, [XObj])
concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root = concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
case runState (visit allowAmbiguityRoot Toplevel rootEnv root) [] of case runState (visit (visitedDefinitions ++ [getPath root]) allowAmbiguityRoot Toplevel typeEnv rootEnv root) [] of
(Left err, _) -> Left err (Left err, _) -> Left err
(Right xobj, deps) -> Right (xobj, deps) (Right xobj, deps) -> Right (xobj, deps)
where
rootDefinitionPath :: SymPath
rootDefinitionPath = getPath root
visit :: Bool -> Level -> Env -> XObj -> State [XObj] (Either TypeError XObj)
visit allowAmbig _ env xobj@(XObj (Sym _ _) _ _) = visitSymbol allowAmbig env xobj
visit allowAmbig _ env xobj@(XObj (MultiSym _ _) _ _) = visitMultiSym allowAmbig env xobj
visit allowAmbig _ env xobj@(XObj (InterfaceSym _) _ _) = visitInterfaceSym allowAmbig env xobj
visit allowAmbig level env xobj@(XObj (Lst _) i t) =
do
visited <- visitList allowAmbig level env xobj
pure $ do
okVisited <- visited
Right (XObj (Lst okVisited) i t)
visit allowAmbig level env xobj@(XObj (Arr arr) i (Just t)) =
do
visited <- fmap sequence (mapM (visit allowAmbig level env) arr)
concretizeResult <- concretizeTypeOfXObj typeEnv xobj
whenRight concretizeResult $
pure $ do
okVisited <- visited
Right (XObj (Arr okVisited) i (Just t))
visit allowAmbig level env xobj@(XObj (StaticArr arr) i (Just t)) =
do
visited <- fmap sequence (mapM (visit allowAmbig level env) arr)
concretizeResult <- concretizeTypeOfXObj typeEnv xobj
whenRight concretizeResult $
pure $ do
okVisited <- visited
Right (XObj (StaticArr okVisited) i (Just t))
visit _ _ _ x = pure (Right x)
visitList :: Bool -> Level -> Env -> XObj -> State [XObj] (Either TypeError [XObj])
visitList _ _ _ (XObj (Lst []) _ _) = pure (Right [])
visitList _ Toplevel env (XObj (Lst [defn@(XObj (Defn _) _ _), nameSymbol@(XObj (Sym (SymPath [] "main") _) _ _), args@(XObj (Arr argsArr) _ _), body]) _ _) =
if not (null argsArr)
then pure $ Left (MainCannotHaveArguments nameSymbol (length argsArr))
else do
concretizeResult <- concretizeTypeOfXObj typeEnv body
whenRight concretizeResult $ do
visitedBody <- visit False Inside env body
pure $ do
okBody <- visitedBody
let t = fromMaybe UnitTy (xobjTy okBody)
if not (isTypeGeneric t) && t /= UnitTy && t /= IntTy
then Left (MainCanOnlyReturnUnitOrInt nameSymbol t)
else return [defn, nameSymbol, args, okBody]
visitList _ Toplevel env (XObj (Lst [defn@(XObj (Defn _) _ _), nameSymbol, args@(XObj (Arr argsArr) _ _), body]) _ t) =
do
mapM_ (concretizeTypeOfXObj typeEnv) argsArr
let functionEnv = Env Map.empty (Just env) Nothing Set.empty InternalEnv 0
envWithArgs =
foldl'
( \e arg@(XObj (Sym path _) _ _) ->
-- n.b. this won't fail since we're inserting unqualified args into a fresh env
-- TODO: Still, it'd be nicer and more flexible to catch failures here.
let Right v = insertX e path arg in v
)
functionEnv
argsArr
Just funcTy = t
allowAmbig = isTypeGeneric funcTy
concretizeResult <- concretizeTypeOfXObj typeEnv body
whenRight concretizeResult $ do
visitedBody <- visit allowAmbig Inside (incrementEnvNestLevel envWithArgs) body
pure $ do
okBody <- visitedBody
pure [defn, nameSymbol, args, okBody]
visitList _ Inside _ xobj@(XObj (Lst [XObj (Defn _) _ _, _, XObj (Arr _) _ _, _]) _ _) =
pure (Left (DefinitionsMustBeAtToplevel xobj))
visitList allowAmbig _ env (XObj (Lst [XObj (Fn _ _) fni fnt, args@(XObj (Arr argsArr) ai at), body]) i t) =
-- The basic idea of this function is to first visit the body of the lambda ("in place"),
-- then take the resulting body and put into a separate function 'defn' with a new name
-- in the global scope. That function definition will be set as the lambdas '.callback' in
-- the C code.
do
mapM_ (concretizeTypeOfXObj typeEnv) argsArr
let Just ii = i
Just funcTy = t
argObjs = map xobjObj argsArr
-- TODO: This code is a copy of the one above in Defn, remove duplication:
functionEnv = Env Map.empty (Just env) Nothing Set.empty InternalEnv (envFunctionNestingLevel env)
envWithArgs =
foldl'
( \e arg@(XObj (Sym path _) _ _) ->
let Right v = insertX e path arg in v
)
functionEnv
argsArr
visitedBody <- visit allowAmbig Inside (incrementEnvNestLevel envWithArgs) body
case visitedBody of
Right okBody ->
let -- Analyse the body of the lambda to find what variables it captures
capturedVarsRaw = collectCapturedVars okBody
-- and then remove the captures that are actually our arguments
capturedVars = filter (\xobj -> xobjObj (toGeneralSymbol xobj) `notElem` argObjs) capturedVarsRaw
-- Create a new (top-level) function that will be used when the lambda is called.
-- Its name will contain the name of the (normal, non-lambda) function it's contained within,
-- plus the identifier of the particular s-expression that defines the lambda.
SymPath spath name = rootDefinitionPath
lambdaPath = SymPath spath ("_Lambda_" ++ lambdaToCName name (envFunctionNestingLevel envWithArgs) ++ "_" ++ show (infoIdentifier ii) ++ "_env")
lambdaNameSymbol = XObj (Sym lambdaPath Symbol) (Just dummyInfo) Nothing
-- Anonymous functions bound to a let name might call themselves. These recursive instances will have already been qualified as LookupRecursive symbols.
-- Rename the recursive calls according to the generated lambda name so that we can call these correctly from C.
renameRecursives (XObj (Sym _ LookupRecursive) si st) = (XObj (Sym lambdaPath LookupRecursive) si st)
renameRecursives x = x
recBody = walk renameRecursives okBody
environmentTypeName = pathToC lambdaPath ++ "_ty"
tyPath = (SymPath [] environmentTypeName)
extendedArgs =
if null capturedVars
then args
else -- If the lambda captures anything it need an extra arg for its env:
XObj --------------------------------------------------------------------------------
( Arr -- Visit functions
( XObj --
(Sym (SymPath [] "_env") Symbol) -- These functions take a state and supporting information and gradually
(Just dummyInfo) -- convert generically typed xobjs into concretely typed xobjs.
(Just (PointerTy (StructTy (ConcreteNameTy tyPath) []))) : --
argsArr -- The functions prefixed "visit" primarily just recur into the component parts
) -- of different Carp forms while the "concretizeType..." functions perform the
) -- actual type conversion work.
ai
at -- | The type of visit functions. These functions convert the types of the
lambdaCallback = XObj (Lst [XObj (Defn (Just (Set.fromList capturedVars))) (Just dummyInfo) Nothing, lambdaNameSymbol, extendedArgs, recBody]) i t -- components of a form into concrete types and take the following arguments:
-- The lambda will also carry with it a special made struct containing the variables it captures -- - A List of paths that have already been visited.
-- (if it captures at least one variable) -- - A bool indicating whether or not type variables are allowed
structMemberPairs = -- - A level indicating if we are in an inner component of a form or the top level
concatMap -- - A type environment
( \(XObj (Sym path _) _ (Just symTy)) -> -- - A value environment
[XObj (Sym path Symbol) Nothing Nothing, reify symTy] -- - The xobj to concretize
type Visitor = [SymPath] -> Bool -> Level -> TypeEnv -> Env -> XObj -> State [XObj] (Either TypeError [XObj])
-- | Process the components of a form, yielding a concretely typed (no
-- generics) version of the form.
visit :: [SymPath] -> Bool -> Level -> TypeEnv -> Env -> XObj -> State [XObj] (Either TypeError XObj)
visit visited ambig _ tenv env xobj@(SymPat _ _) = visitSymbol visited ambig tenv env xobj
visit visited ambig _ tenv env xobj@(MultiSymPat _ _) = visitMultiSym visited ambig tenv env xobj
visit visited ambig _ tenv env xobj@(InterfaceSymPat _) = visitInterfaceSym visited ambig tenv env xobj
visit visited allowAmbig level tenv env xobj@(ListPat _) =
do
vLst <- visitList visited allowAmbig level tenv env xobj
pure (vLst >>= \ok -> pure (setObj xobj (Lst ok)))
visit visited allowAmbig level tenv env xobj@(ArrPat arr) =
do
vArr <- fmap sequence (mapM (visit visited allowAmbig level tenv env) arr)
c <- concretizeTypeOfXObj tenv xobj
pure (c >> vArr >>= \ok -> pure (setObj xobj (Arr ok)))
visit visited allowAmbig level tenv env xobj@(StaticArrPat arr) =
do
vArr <- fmap sequence (mapM (visit visited allowAmbig level tenv env) arr)
c <- concretizeTypeOfXObj tenv xobj
pure (c >> vArr >>= \ok -> pure (setObj xobj (StaticArr ok)))
visit _ _ _ _ _ x = pure (Right x)
-- | Entry point for concretely typing the components of a list form.
visitList :: Visitor
visitList _ _ _ _ _ (ListPat []) = pure (Right [])
visitList p a l t e x@(ListPat (DefPat _ _ _)) = visitDef p a l t e x
visitList p a l t e x@(ListPat (DefnPat _ _ _ _)) = visitDefn p a l t e x
visitList p a l t e x@(ListPat (LetPat _ _ _)) = visitLet p a l t e x
visitList p a l t e x@(ListPat (ThePat _ _ _)) = visitThe p a l t e x
visitList p a l t e x@(ListPat (MatchPat _ _ _)) = visitMatch p a l t e x
visitList p a l t e x@(ListPat (SetPat _ _ _)) = visitSetBang p a l t e x
visitList p a l t e x@(ListPat (FnPat _ _ _)) = visitFn p a l t e x
visitList p a l t e x@(ListPat (AppPat _ _)) = visitApp p a l t e x
visitList _ _ _ _ _ x = pure (Left (CannotConcretize x))
-- | Helper for producing a new environment with all a functions argument symbols.
--
-- Used to concretize defn and fn forms.
envWithFunctionArgs :: Env -> [XObj] -> Either EnvironmentError Env
envWithFunctionArgs env arr =
let functionEnv = Env Map.empty (Just env) Nothing Set.empty InternalEnv (envFunctionNestingLevel env)
in foldM
(\e arg@(XObj (Sym path _) _ _) -> insertX e path arg)
functionEnv
arr
-- | Concretely type a function definition.
--
-- "main" is treated as a special case.
visitDefn :: Visitor
visitDefn p a l t e x@(ListPat (DefnPat _ (SymPat (SymPath [] "main") _) _ _)) = visitMain p a l t e x
visitDefn visited _ Toplevel tenv env x@(ListPat (DefnPat defn name args@(ArrPat arr) body)) =
do
mapM_ (concretizeTypeOfXObj tenv) arr
let envWithArgs = fromRight Env.empty (envWithFunctionArgs env arr)
allowAmbig = maybe True isTypeGeneric (xobjTy x)
c <- concretizeTypeOfXObj tenv body
vBody <- visit (getPath x : visited) allowAmbig Inside tenv (incrementEnvNestLevel envWithArgs) body
pure (c >> vBody >>= go)
where
go b = pure [defn, name, args, b]
visitDefn _ _ Inside _ _ x@(ListPat (DefnPat _ _ _ _)) =
pure (Left (DefinitionsMustBeAtToplevel x))
visitDefn _ _ _ _ _ x = pure (Left (CannotConcretize x))
-- | Concretely type a program entry point. Can only return Int or Unit.
visitMain :: Visitor
visitMain visited _ Toplevel tenv env (ListPat (DefnPat defn name@(SymPat (SymPath [] "main") _) args@(ArrPat []) body)) =
do
c <- concretizeTypeOfXObj tenv body
vBody <- visit visited False Inside tenv env body
pure (c >> vBody >>= typeCheck)
where
typeCheck b =
let t = fromMaybe UnitTy (xobjTy b)
in if (t `elem` validMainTypes) || isTypeGeneric t
then pure [defn, name, args, b]
else Left (MainCanOnlyReturnUnitOrInt name t)
validMainTypes = [UnitTy, IntTy]
visitMain _ _ _ _ _ (ListPat (DefnPat _ name@(SymPat (SymPath [] "main") _) (ArrPat arr) _)) =
pure (Left (MainCannotHaveArguments name (length arr)))
visitMain _ _ _ _ _ x = pure (Left (CannotConcretize x))
-- | Concretely type a Def form.
visitDef :: Visitor
visitDef visited _ Toplevel tenv env x@(ListPat (DefPat def name body)) =
do
vBody <- visit visited allowAmbig Inside tenv env body
pure (vBody >>= \ok -> pure [def, name, ok])
where
allowAmbig = isTypeGeneric (fromMaybe (VarTy "a") (xobjTy x))
visitDef _ _ Inside _ _ x@(ListPat (DefPat _ _ _)) =
pure (Left (DefinitionsMustBeAtToplevel x))
visitDef _ _ _ _ _ x = pure (Left (CannotConcretize x))
-- | Concretely type a Let (let [bindings...] <body>) form.
visitLet :: Visitor
visitLet visited allowAmbig level tenv env (ListPat (LetPat letExpr arr@(ArrPat bindings) body)) =
do
bindings' <- fmap sequence (mapM (visit visited allowAmbig level tenv env) bindings)
body' <- visit visited allowAmbig level tenv env body
c <- mapM (concretizeTypeOfXObj tenv . fst) (pairwise bindings)
pure (sequence c >> go bindings' body')
where
go x' y = do
okBindings <- x'
okBody <- y
pure [letExpr, (setObj arr (Arr okBindings)), okBody]
visitLet _ _ _ _ _ x = pure (Left (CannotConcretize x))
-- | Concretely type a The (the <type> <value>) form.
visitThe :: Visitor
visitThe visited allowAmbig level tenv env (ListPat (ThePat the ty value)) =
do
vVal <- visit visited allowAmbig level tenv env value
pure (vVal >>= \ok -> pure [the, ty, ok])
visitThe _ _ _ _ _ x = pure (Left (CannotConcretize x))
-- | Concretely type a Match (match <expr> <clauses...>) form.
visitMatch :: Visitor
visitMatch visited allowAmbig level tenv env (ListPat (MatchPat match expr rest)) =
do
c <- concretizeTypeOfXObj tenv expr
vExpr <- visit visited allowAmbig level tenv env expr
mapM_ (concretizeTypeOfXObj tenv . snd) (pairwise rest)
vCases <- fmap sequence (mapM (visitMatchCase visited allowAmbig level tenv env) (pairwise rest))
pure (c >> go vExpr vCases)
where
go x y = do
okExpr <- x
okRest <- fmap concat y
pure ([match, okExpr] ++ okRest)
visitMatch _ _ _ _ _ x = pure (Left (CannotConcretize x))
-- | Concretely type a Match form case.
visitMatchCase :: [SymPath] -> Bool -> Level -> TypeEnv -> Env -> (XObj, XObj) -> State [XObj] (Either TypeError [XObj])
visitMatchCase visited allowAmbig level tenv env (lhs, rhs) =
-- TODO! This changes the names of some tags (which is corrected in Emit) but perhaps there is a better way where they can be identified as tags and not changed?
do
vl <- visit visited allowAmbig level tenv env lhs
vr <- visit visited allowAmbig level tenv env rhs
pure (liftA2 (\x y -> [x, y]) vl vr)
-- | Concretely type a Set (set! <var> <value>) form.
visitSetBang :: Visitor
visitSetBang visited allowAmbig _ tenv env (ListPat (SetPat set var value)) =
do
vVal <- visit visited allowAmbig Inside tenv env value
pure (vVal >>= \ok -> pure [set, var, ok])
visitSetBang _ _ _ _ _ x = pure (Left (CannotConcretize x))
-- | Concretely type a function application (<function> <args...>) form.
visitApp :: Visitor
visitApp visited allowAmbig level tenv env (ListPat (AppPat func args)) =
do
c <- concretizeTypeOfXObj tenv func
cs <- fmap sequence $ mapM (concretizeTypeOfXObj tenv) args
vFunc <- visit visited allowAmbig level tenv env func
vArgs <- fmap sequence (mapM (visit visited allowAmbig level tenv env) args)
pure (c >> cs >> liftA2 (:) vFunc vArgs)
visitApp _ _ _ _ _ x = pure (Left (CannotConcretize x))
-- | Concretely type an anonymous function and convert it into a
-- resolvable/retrievable lambda.
mkLambda :: Visitor
mkLambda visited allowAmbig _ tenv env root@(ListPat (FnPat fn arr@(ArrPat args) body)) =
let capturedVars = filter (\xobj -> xobjObj (toGeneralSymbol xobj) `notElem` (map xobjObj args)) (collectCapturedVars body)
-- Create a new (top-level) function that will be used when the lambda is called.
-- Its name will contain the name of the (normal, non-lambda) function it's contained within,
-- plus the identifier of the particular s-expression that defines the lambda.
SymPath spath name = (last visited)
Just funcTy = xobjTy root
lambdaPath = SymPath spath ("_Lambda_" ++ lambdaToCName name (envFunctionNestingLevel env) ++ "_" ++ show (maybe 0 infoIdentifier (xobjInfo root)) ++ "_env")
lambdaNameSymbol = XObj (Sym lambdaPath Symbol) (Just dummyInfo) Nothing
-- Anonymous functions bound to a let name might call themselves. These recursive instances will have already been qualified as LookupRecursive symbols.
-- Rename the recursive calls according to the generated lambda name so that we can call these correctly from C.
renameRecursives (XObj (Sym _ LookupRecursive) si st) = (XObj (Sym lambdaPath LookupRecursive) si st)
renameRecursives x = x
recBody = walk renameRecursives body
environmentTypeName = pathToC lambdaPath ++ "_ty"
tyPath = (SymPath [] environmentTypeName)
extendedArgs =
if null capturedVars
then arr
else-- If the lambda captures anything it need an extra arg for its env:
( setObj
arr
( Arr
( XObj
(Sym (SymPath [] "_env") Symbol)
(Just dummyInfo)
(Just (PointerTy (StructTy (ConcreteNameTy tyPath) [])))
: args
) )
capturedVars )
environmentStructTy = StructTy (ConcreteNameTy tyPath) [] )
environmentStruct = lambdaCallback = XObj (Lst [XObj (Defn (Just (Set.fromList capturedVars))) (Just dummyInfo) Nothing, lambdaNameSymbol, extendedArgs, recBody]) (xobjInfo root) (xobjTy root)
XObj -- The lambda will also carry with it a special made struct containing the variables it captures
( Lst -- (if it captures at least one variable)
[ XObj (Deftype environmentStructTy) Nothing Nothing, structMemberPairs =
XObj (Sym tyPath Symbol) Nothing Nothing, concatMap
XObj (Arr structMemberPairs) Nothing Nothing ( \(XObj (Sym path _) _ (Just symTy)) ->
] [XObj (Sym path Symbol) Nothing Nothing, reify symTy]
) )
i capturedVars
(Just TypeTy) environmentStructTy = StructTy (ConcreteNameTy tyPath) []
pairs = memberXObjsToPairs structMemberPairs environmentStruct =
deleteFnTy = typesDeleterFunctionType (PointerTy environmentStructTy) XObj
deleteFnTemplate = concreteDeleteTakePtr typeEnv env pairs ( Lst
(deleteFn, deleterDeps) = instantiateTemplate (SymPath [] (environmentTypeName ++ "_delete")) deleteFnTy deleteFnTemplate [ XObj (Deftype environmentStructTy) Nothing Nothing,
copyFnTy = typesCopyFunctionType environmentStructTy XObj (Sym tyPath Symbol) Nothing Nothing,
copyFnTemplate = concreteCopyPtr typeEnv env pairs XObj (Arr structMemberPairs) Nothing Nothing
(copyFn, copyDeps) = instantiateTemplate (SymPath [] (environmentTypeName ++ "_copy")) copyFnTy copyFnTemplate ]
-- The type env has to contain the lambdas environment struct for 'concretizeDefinition' to work: )
-- TODO: Fixup: Support modules in type envs. (xobjInfo root)
extendedTypeEnv = replaceLeft (FailedToAddLambdaStructToTyEnv tyPath environmentStruct) (insert typeEnv tyPath (toBinder environmentStruct)) (Just TypeTy)
in case (extendedTypeEnv >>= \ext -> concretizeDefinition allowAmbig ext env visitedDefinitions lambdaCallback funcTy) of pairs = memberXObjsToPairs structMemberPairs
Left err -> pure (Left err) deleteFnTy = typesDeleterFunctionType (PointerTy environmentStructTy)
Right (concreteLiftedLambda, deps) -> deleteFnTemplate = concreteDeleteTakePtr tenv env pairs
do (deleteFn, deleterDeps) = instantiateTemplate (SymPath [] (environmentTypeName ++ "_delete")) deleteFnTy deleteFnTemplate
unless (any (isTypeGeneric . snd) pairs) $ copyFnTy = typesCopyFunctionType environmentStructTy
do copyFnTemplate = concreteCopyPtr tenv env pairs
modify (concreteLiftedLambda :) (copyFn, copyDeps) = instantiateTemplate (SymPath [] (environmentTypeName ++ "_copy")) copyFnTy copyFnTemplate
modify (deps ++) -- The type env has to contain the lambdas environment struct for 'concretizeDefinition' to work:
unless (null capturedVars) $ -- TODO: Support modules in type envs.
do extendedTypeEnv = replaceLeft (FailedToAddLambdaStructToTyEnv tyPath environmentStruct) (insert tenv tyPath (toBinder environmentStruct))
modify (environmentStruct :) in --(fromMaybe UnitTy (xobjTy root))
modify (deleteFn :) case (extendedTypeEnv >>= \ext -> concretizeDefinition allowAmbig ext env visited lambdaCallback funcTy) of
modify (deleterDeps ++) Left e -> pure (Left e)
modify (copyFn :) Right (concreteLiftedLambda, deps) ->
modify (copyDeps ++) do
pure (Right [XObj (Fn (Just lambdaPath) (Set.fromList capturedVars)) fni fnt, args, recBody]) unless (any (isTypeGeneric . snd) pairs) $
Left err -> do
pure (Left err) modify (concreteLiftedLambda :)
visitList _ Toplevel env (XObj (Lst [def@(XObj Def _ _), nameSymbol, body]) _ t) = modify (deps ++)
do unless (null capturedVars) $
let Just defTy = t do
allowAmbig = isTypeGeneric defTy modify (environmentStruct :)
visitedBody <- visit allowAmbig Inside env body modify (deleteFn :)
pure $ do modify (deleterDeps ++)
okBody <- visitedBody modify (copyFn :)
pure [def, nameSymbol, okBody] modify (copyDeps ++)
visitList _ Inside _ xobj@(XObj (Lst [XObj Def _ _, _, _]) _ _) = pure (Right [XObj (Fn (Just lambdaPath) (Set.fromList capturedVars)) (xobjInfo fn) (xobjTy fn), arr, recBody])
pure (Left (DefinitionsMustBeAtToplevel xobj)) mkLambda _ _ _ _ _ root = pure (Left (CannotConcretize root))
visitList allowAmbig level env (XObj (Lst [letExpr@(XObj Let _ _), XObj (Arr bindings) bindi bindt, body]) _ _) =
do -- | Concretize an anonymous function (fn [args...] <body>)
visitedBindings <- fmap sequence (mapM (visit allowAmbig level env) bindings) --
visitedBody <- visit allowAmbig level env body -- The basic idea of this function is to first visit the body of the lambda ("in place"),
concretizeResults <- mapM (concretizeTypeOfXObj typeEnv . fst) (pairwise bindings) -- then take the resulting body and put into a separate function 'defn' with a new name
whenRight (sequence concretizeResults) $ -- in the global scope. That function definition will be set as the lambdas '.callback' in
pure $ do -- the C code.
okVisitedBindings <- visitedBindings visitFn :: Visitor
okVisitedBody <- visitedBody visitFn visited allowAmbig level tenv env x@(ListPat (FnPat fn args@(ArrPat arr) body)) =
pure [letExpr, XObj (Arr okVisitedBindings) bindi bindt, okVisitedBody] do
visitList allowAmbig level env (XObj (Lst [theExpr@(XObj The _ _), typeXObj, value]) _ _) = mapM_ (concretizeTypeOfXObj tenv) arr
do let envWithArgs = fromRight Env.empty (envWithFunctionArgs env arr)
visitedValue <- visit allowAmbig level env value vBody <- visit visited allowAmbig Inside tenv (incrementEnvNestLevel envWithArgs) body
pure $ do either (pure . Left) (\b -> mkLambda visited allowAmbig level tenv envWithArgs (setObj x (Lst [fn, args, b]))) vBody
okVisitedValue <- visitedValue visitFn _ _ _ _ _ x = pure (Left (CannotConcretize x))
pure [theExpr, typeXObj, okVisitedValue]
visitList allowAmbig level env (XObj (Lst (matchExpr@(XObj (Match _) _ _) : expr : rest)) _ _) = --------------------------------------------------------------------------------
do -- Symbol concretization functions
concretizeResult <- concretizeTypeOfXObj typeEnv expr --
whenRight concretizeResult $ do -- Functions that concretely type arbitrary symbols, like `foo`
visitedExpr <- visit allowAmbig level env expr -- This differ slightly from the functions that concretely type carp forms.
mapM_ (concretizeTypeOfXObj typeEnv . snd) (pairwise rest) --
visitedRest <- fmap sequence (mapM (visitMatchCase allowAmbig level env) (pairwise rest)) -- Symbols can designate:
pure $ do -- - A unique, and thus uniquely typed symbol.
okVisitedExpr <- visitedExpr -- - An ambiguous "multi" symbol, the correct type of which is context-dependent
okVisitedRest <- fmap concat visitedRest -- - An interface symbol, which may be implemented by several concrete
pure ([matchExpr, okVisitedExpr] ++ okVisitedRest) -- symbols of potentially different concrete types. Like the multi-symbol
visitList allowAmbig _ env (XObj (Lst [setbangExpr@(XObj SetBang _ _), variable, value]) _ _) = -- case, depends on context and type checking.
do
visitedValue <- visit allowAmbig Inside env value -- | Concretely type a unique symbol.
pure $ do visitSymbol :: [SymPath] -> Bool -> TypeEnv -> Env -> XObj -> State [XObj] (Either TypeError XObj)
okVisitedValue <- visitedValue visitSymbol visited allowAmbig tenv env xobj@(SymPat path mode) =
pure [setbangExpr, variable, okVisitedValue] case searchValue env path of
visitList allowAmbig level env (XObj (Lst (func : args)) _ _) = Right (foundEnv, binder)
do | envIsExternal foundEnv ->
concretizeResult <- concretizeTypeOfXObj typeEnv func let theXObj = binderXObj binder
whenRight concretizeResult $ do Just theType = xobjTy theXObj
concretizeResults <- mapM (concretizeTypeOfXObj typeEnv) args typeOfVisited = fromMaybe (error ("Missing type on " ++ show xobj ++ " at " ++ prettyInfoFromXObj xobj ++ " when looking up path " ++ show path)) (xobjTy xobj)
whenRight (sequence concretizeResults) $ do in if --(trace $ "CHECKING " ++ getName xobj ++ " : " ++ show theType ++ " with visited type " ++ show typeOfVisited ++ " and visited definitions: " ++ show visitedDefinitions) $
f <- visit allowAmbig level env func (isTypeGeneric theType && not (isTypeGeneric typeOfVisited))
a <- fmap sequence (mapM (visit allowAmbig level env) args) then case concretizeDefinition allowAmbig tenv env visited theXObj typeOfVisited of
pure $ do Left err -> pure (Left err)
okF <- f Right (concrete, deps) ->
okA <- a do
pure (okF : okA) modify (concrete :)
visitList _ _ _ _ = error "visitlist" modify (deps ++)
visitMatchCase :: Bool -> Level -> Env -> (XObj, XObj) -> State [XObj] (Either TypeError [XObj]) pure (Right (XObj (Sym (getPath concrete) mode) (xobjInfo xobj) (xobjTy xobj)))
visitMatchCase allowAmbig level env (lhs, rhs) = else pure (Right xobj)
do | otherwise -> pure (Right xobj)
visitedLhs <- visit allowAmbig level env lhs -- TODO! This changes the names of some tags (which is corrected in Emit) but perhaps there is a better way where they can be identified as tags and not changed? _ -> pure (Right xobj)
visitedRhs <- visit allowAmbig level env rhs visitSymbol _ _ _ _ x = pure (Left (CannotConcretize x))
pure $ do
okVisitedLhs <- visitedLhs -- | Concretely type a context-dependent multi-symbol.
okVisitedRhs <- visitedRhs visitMultiSym :: [SymPath] -> Bool -> TypeEnv -> Env -> XObj -> State [XObj] (Either TypeError XObj)
pure [okVisitedLhs, okVisitedRhs] visitMultiSym visited allowAmbig tenv env xobj@(MultiSymPat name paths) =
visitSymbol :: Bool -> Env -> XObj -> State [XObj] (Either TypeError XObj) case (filter (matchingSignature3 actualType) tysPathsModes) of
visitSymbol allowAmbig env xobj@(XObj (Sym path lookupMode) i t) = [] -> pure (Left (NoMatchingSignature xobj name actualType tysToPathsDict))
case searchValue env path of [x] -> go x
Right (foundEnv, binder) _ -> pure (Right xobj)
| envIsExternal foundEnv -> where
let theXObj = binderXObj binder Just actualType = xobjTy xobj
Just theType = xobjTy theXObj tys = map (typeFromPath env) paths
typeOfVisited = fromMaybe (error ("Missing type on " ++ show xobj ++ " at " ++ prettyInfoFromXObj xobj ++ " when looking up path " ++ show path)) t modes = map (modeFromPath env) paths
in if --(trace $ "CHECKING " ++ getName xobj ++ " : " ++ show theType ++ " with visited type " ++ show typeOfVisited ++ " and visited definitions: " ++ show visitedDefinitions) $ tysToPathsDict = zip tys paths
(isTypeGeneric theType && not (isTypeGeneric typeOfVisited)) tysPathsModes = zip3 tys paths modes
then case concretizeDefinition allowAmbig typeEnv env visitedDefinitions theXObj typeOfVisited of fake1 = XObj (Sym (SymPath [] "theType") Symbol) Nothing Nothing
Left err -> pure (Left err) fake2 = XObj (Sym (SymPath [] "xobjType") Symbol) Nothing Nothing
Right (concrete, deps) -> go :: (Ty, SymPath, SymbolMode) -> State [XObj] (Either TypeError XObj)
do go (ty, path, mode) =
modify (concrete :) either
modify (deps ++) (pure . convertError)
pure (Right (XObj (Sym (getPath concrete) lookupMode) i t)) (visitSymbol visited allowAmbig tenv env)
else pure (Right xobj) ( solve [Constraint ty actualType fake1 fake2 fake1 OrdMultiSym]
| otherwise -> pure (Right xobj) >>= pure . (flip replaceTyVars) actualType
_ -> pure (Right xobj) >>= pure . suffixTyVars ("_x" ++ show (infoIdentifier (fromMaybe dummyInfo (xobjInfo xobj))))
visitSymbol _ _ _ = error "Not a symbol." >>= \t' -> pure (XObj (Sym path mode) (xobjInfo xobj) (Just t'))
visitMultiSym :: Bool -> Env -> XObj -> State [XObj] (Either TypeError XObj) )
visitMultiSym allowAmbig env xobj@(XObj (MultiSym originalSymbolName paths) i t) = convertError :: UnificationFailure -> Either TypeError XObj
let Just actualType = t convertError failure@(UnificationFailure _ _) =
tys = map (typeFromPath env) paths Left (UnificationFailed (unificationFailure failure) (unificationMappings failure) [])
modes = map (modeFromPath env) paths convertError (Holes holes) = Left (HolesFound holes)
visitMultiSym _ _ _ _ x = pure (Left (CannotConcretize x))
-- | Concretely type an interface symbol.
visitInterfaceSym :: [SymPath] -> Bool -> TypeEnv -> Env -> XObj -> State [XObj] (Either TypeError XObj)
visitInterfaceSym visited allowAmbig tenv env xobj@(InterfaceSymPat name) =
either (pure . const (Left (CannotConcretize xobj))) go (getTypeBinder tenv name)
where
Just actualType = (xobjTy xobj)
go :: Binder -> State [XObj] (Either TypeError XObj)
go (Binder _ (ListPat (InterfacePat _ paths))) =
let tys = map (typeFromPath env) paths
tysToPathsDict = zip tys paths tysToPathsDict = zip tys paths
tysPathsModes = zip3 tys paths modes in case filter (matchingSignature actualType) tysToPathsDict of
in case filter (matchingSignature3 actualType) tysPathsModes of [] -> pure $ if allowAmbig then Right xobj else Left (NoMatchingSignature xobj name actualType tysToPathsDict)
[] -> [x] -> updateSym x
pure (Left (NoMatchingSignature xobj originalSymbolName actualType tysToPathsDict)) xs -> case filter (typeEqIgnoreLifetimes actualType . fst) xs of
[(theType, singlePath, mode)] -> [] -> pure (Right xobj) -- No exact match of types
let Just t' = t [y] -> updateSym y
fake1 = XObj (Sym (SymPath [] "theType") Symbol) Nothing Nothing ps -> pure (Left (SeveralExactMatches xobj name actualType ps))
fake2 = XObj (Sym (SymPath [] "xobjType") Symbol) Nothing Nothing go _ = pure (Left (CannotConcretize xobj))
Just i' = i -- TODO: Should we also check for allowAmbig here?
in case solve [Constraint theType t' fake1 fake2 fake1 OrdMultiSym] of updateSym (_, path) = if isTypeGeneric actualType then pure (Right xobj) else replace path
Right mappings -> replace path =
let replaced = (replaceTyVars mappings t') -- We pass the original xobj ty here, should we be passing the type found via matching signature?
suffixed = suffixTyVars ("_x" ++ show (infoIdentifier i')) replaced -- Make sure it gets unique type variables. TODO: Is there a better way? let normalSymbol = XObj (Sym path (LookupGlobal CarpLand AFunction)) (xobjInfo xobj) (xobjTy xobj) -- TODO: Is it surely AFunction here? Could be AVariable as well...!?
normalSymbol = XObj (Sym singlePath mode) i (Just suffixed) in visitSymbol
in visitSymbol visited
allowAmbig allowAmbig
env tenv
--(trace ("Disambiguated " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj ++ " to " ++ show singlePath ++ " : " ++ show suffixed ++ ", used to be " ++ show t' ++ ", theType = " ++ show theType ++ ", mappings = " ++ show mappings) normalSymbol) normalSymbol env -- trace ("Replacing symbol " ++ pretty xobj ++ " with type " ++ show theType ++ " to single path " ++ show singlePath)
normalSymbol normalSymbol
Left failure@(UnificationFailure _ _) -> visitInterfaceSym _ _ _ _ x = pure (Left (CannotConcretize x))
pure $
Left
( UnificationFailed
(unificationFailure failure)
(unificationMappings failure)
[]
)
Left (Holes holes) ->
pure $ Left (HolesFound holes)
_ -> pure (Right xobj)
visitMultiSym _ _ _ = error "Not a multi symbol."
visitInterfaceSym :: Bool -> Env -> XObj -> State [XObj] (Either TypeError XObj)
visitInterfaceSym allowAmbig env xobj@(XObj (InterfaceSym name) i t) =
case getTypeBinder typeEnv name of
Right (Binder _ (XObj (Lst [XObj (Interface _ interfacePaths) _ _, _]) _ _)) ->
let Just actualType = t
tys = map (typeFromPath env) interfacePaths
tysToPathsDict = zip tys interfacePaths
in case filter (matchingSignature actualType) tysToPathsDict of
[] ->
pure $ --(trace ("No matching signatures for interface lookup of " ++ name ++ " of type " ++ show actualType ++ " " ++ prettyInfoFromXObj xobj ++ ", options are:\n" ++ joinLines (map show tysToPathsDict))) $
if allowAmbig
then Right xobj -- No exact match of types
else Left (NoMatchingSignature xobj name actualType tysToPathsDict)
[(theType, singlePath)] ->
--(trace ("One matching signature for interface lookup of '" ++ name ++ "' with single path " ++ show singlePath ++ " of type " ++ show theType ++ " at " ++ prettyInfoFromXObj xobj ++ ", original symbol: " ++ show xobj)) $
let Just tt = t
in if isTypeGeneric tt then pure (Right xobj) else replace theType singlePath
severalPaths ->
--(trace ("Several matching signatures for interface lookup of '" ++ name ++ "' of type " ++ show actualType ++ " " ++ prettyInfoFromXObj xobj ++ ", options are:\n" ++ joinLines (map show tysToPathsDict) ++ "\n Filtered paths are:\n" ++ (joinLines (map show severalPaths)))) $
case filter (\(tt, _) -> typeEqIgnoreLifetimes actualType tt) severalPaths of
[] ->
--trace ("No exact matches for '" ++ show actualType ++ "'") $
pure (Right xobj) -- No exact match of types
[(theType, singlePath)] -> replace theType singlePath -- Found an exact match, will ignore any "half matched" functions that might have slipped in.
_ -> pure (Left (SeveralExactMatches xobj name actualType severalPaths))
where
replace _ singlePath =
let normalSymbol = XObj (Sym singlePath (LookupGlobal CarpLand AFunction)) i t -- TODO: Is it surely AFunction here? Could be AVariable as well...!?
in visitSymbol
allowAmbig
env -- trace ("Replacing symbol " ++ pretty xobj ++ " with type " ++ show theType ++ " to single path " ++ show singlePath)
normalSymbol
Right _ -> error "visitinterfacesym1"
Left _ ->
error ("No interface named '" ++ name ++ "' found.")
visitInterfaceSym _ _ _ = error "visitinterfacesym"
toGeneralSymbol :: XObj -> XObj toGeneralSymbol :: XObj -> XObj
toGeneralSymbol (XObj (Sym path _) _ t) = XObj (Sym path Symbol) (Just dummyInfo) t toGeneralSymbol (XObj (Sym path _) _ t) = XObj (Sym path Symbol) (Just dummyInfo) t
@ -376,7 +448,7 @@ toGeneralSymbol x = error ("Can't convert this to a general symbol: " ++ show x)
-- | Find all lookups in a lambda body that should be captured by its environment -- | Find all lookups in a lambda body that should be captured by its environment
collectCapturedVars :: XObj -> [XObj] collectCapturedVars :: XObj -> [XObj]
collectCapturedVars root = removeDuplicates (map decreaseCaptureLevel (visit root)) collectCapturedVars root = removeDuplicates (map decreaseCaptureLevel (visit' root))
where where
removeDuplicates :: Ord a => [a] -> [a] removeDuplicates :: Ord a => [a] -> [a]
removeDuplicates = Set.toList . Set.fromList removeDuplicates = Set.toList . Set.fromList
@ -398,7 +470,7 @@ collectCapturedVars root = removeDuplicates (map decreaseCaptureLevel (visit roo
(Just dummyInfo) (Just dummyInfo)
ty ty
decreaseCaptureLevel _ = error "decreasecapturelevel" decreaseCaptureLevel _ = error "decreasecapturelevel"
visit xobj = visit' xobj =
case xobjObj xobj of case xobjObj xobj of
-- don't peek inside lambdas, trust their capture lists: -- don't peek inside lambdas, trust their capture lists:
(Lst [XObj (Fn _ captures) _ _, _, _]) -> Set.toList captures (Lst [XObj (Fn _ captures) _ _, _, _]) -> Set.toList captures
@ -408,26 +480,26 @@ collectCapturedVars root = removeDuplicates (map decreaseCaptureLevel (visit roo
let (bound, bindingsCaptured) = let (bound, bindingsCaptured) =
foldl' foldl'
( \(bound', captured) (XObj sym _ ty, expr) -> ( \(bound', captured) (XObj sym _ ty, expr) ->
let capt = filter (`Set.notMember` bound') (visit expr) let capt = filter (`Set.notMember` bound') (visit' expr)
in (Set.insert (XObj sym (Just dummyInfo) ty) bound', capt ++ captured) in (Set.insert (XObj sym (Just dummyInfo) ty) bound', capt ++ captured)
) )
(Set.empty, []) (Set.empty, [])
(pairwise bindings) (pairwise bindings)
in let bodyCaptured = filter (`Set.notMember` bound) (visit body) in let bodyCaptured = filter (`Set.notMember` bound) (visit' body)
in bindingsCaptured ++ bodyCaptured in bindingsCaptured ++ bodyCaptured
(Lst _) -> visitList xobj (Lst _) -> visitList' xobj
(Arr _) -> visitArray xobj (Arr _) -> visitArray' xobj
-- TODO: Static Arrays! -- TODO: Static Arrays!
sym@(Sym _ (LookupLocal (Capture _))) -> [XObj sym (Just dummyInfo) (xobjTy xobj)] sym@(Sym _ (LookupLocal (Capture _))) -> [XObj sym (Just dummyInfo) (xobjTy xobj)]
_ -> [] _ -> []
visitList :: XObj -> [XObj] visitList' :: XObj -> [XObj]
visitList (XObj (Lst xobjs) _ _) = visitList' (XObj (Lst xobjs) _ _) =
concatMap visit xobjs concatMap visit' xobjs
visitList _ = error "The function 'visitList' only accepts XObjs with lists in them." visitList' _ = error "The function 'visitList' only accepts XObjs with lists in them."
visitArray :: XObj -> [XObj] visitArray' :: XObj -> [XObj]
visitArray (XObj (Arr xobjs) _ _) = visitArray' (XObj (Arr xobjs) _ _) =
concatMap visit xobjs concatMap visit' xobjs
visitArray _ = error "The function 'visitArray' only accepts XObjs with arrays in them." visitArray' _ = error "The function 'visitArray' only accepts XObjs with arrays in them."
-- | Do the signatures match? -- | Do the signatures match?
matchingSignature :: Ty -> (Ty, SymPath) -> Bool matchingSignature :: Ty -> (Ty, SymPath) -> Bool
@ -437,15 +509,19 @@ matchingSignature tA (tB, _) = areUnifiable tA tB
matchingSignature3 :: Ty -> (Ty, SymPath, SymbolMode) -> Bool matchingSignature3 :: Ty -> (Ty, SymPath, SymbolMode) -> Bool
matchingSignature3 tA (tB, _, _) = areUnifiable tA tB matchingSignature3 tA (tB, _, _) = areUnifiable tA tB
--------------------------------------------------------------------------------
-- Type concretization
--
-- These functions perform the actual work of converting generic types to concrete types.
-- | Does the type of an XObj require additional concretization of generic types or some typedefs for function types, etc? -- | Does the type of an XObj require additional concretization of generic types or some typedefs for function types, etc?
-- | If so, perform the concretization and append the results to the list of dependencies. -- | If so, perform the concretization and append the results to the list of dependencies.
concretizeTypeOfXObj :: TypeEnv -> XObj -> State [XObj] (Either TypeError ()) concretizeTypeOfXObj :: TypeEnv -> XObj -> State [XObj] (Either TypeError ())
concretizeTypeOfXObj typeEnv (XObj _ _ (Just ty)) = concretizeTypeOfXObj typeEnv (XObj _ _ (Just ty)) =
case concretizeType typeEnv ty of either (pure . Left) success (concretizeType typeEnv ty)
Right t -> do where
modify (t ++) success :: [XObj] -> State [XObj] (Either TypeError ())
pure (Right ()) success xs = modify (xs ++) >> pure (Right ())
Left err -> pure (Left err)
concretizeTypeOfXObj _ _ = pure (Right ()) concretizeTypeOfXObj _ _ = pure (Right ())
-- | Find all the concrete deps of a type. -- | Find all the concrete deps of a type.
@ -494,12 +570,11 @@ concretizeType _ _ =
-- | Renames the type variable literals in a sum type for temporary validation. -- | Renames the type variable literals in a sum type for temporary validation.
renameGenericTypeSymbolsOnSum :: [(Ty, Ty)] -> XObj -> XObj renameGenericTypeSymbolsOnSum :: [(Ty, Ty)] -> XObj -> XObj
renameGenericTypeSymbolsOnSum varpairs x@(XObj (Lst (caseNm : caseMembers)) i t) = renameGenericTypeSymbolsOnSum varpairs x@(XObj (Lst (caseNm : [a@(XObj (Arr arr) _ _)])) _ _) =
case caseMembers of setObj x (Lst [caseNm, setObj a (Arr (map replacer arr))])
[XObj (Arr arr) ii tt] ->
XObj (Lst (caseNm : [XObj (Arr (map replacer arr)) ii tt])) i t
_ -> x
where where
--XObj (Lst (caseNm : [XObj (Arr (map replacer arr)) ii tt])) i t
mapp = Map.fromList varpairs mapp = Map.fromList varpairs
replacer mem@(XObj (Sym (SymPath [] name) _) _ _) = replacer mem@(XObj (Sym (SymPath [] name) _) _ _) =
let Just perhapsTyVar = xobjToTy mem let Just perhapsTyVar = xobjToTy mem
@ -523,53 +598,47 @@ renameGenericTypeSymbolsOnProduct vars members =
else mem else mem
-- | Given an generic struct type and a concrete version of it, generate all dependencies needed to use the concrete one. -- | Given an generic struct type and a concrete version of it, generate all dependencies needed to use the concrete one.
-- TODO: Handle polymorphic constructors (a b). --
-- Turns (deftype (A a) [x a, y a]) into (deftype (A Int) [x Int, y Int])
instantiateGenericStructType :: TypeEnv -> Ty -> Ty -> [XObj] -> Either TypeError [XObj] instantiateGenericStructType :: TypeEnv -> Ty -> Ty -> [XObj] -> Either TypeError [XObj]
instantiateGenericStructType typeEnv originalStructTy@(StructTy _ _) genericStructTy membersXObjs = instantiateGenericStructType typeEnv originalStructTy@(StructTy _ _) genericStructTy membersXObjs =
-- Turn (deftype (A a) [x a, y a]) into (deftype (A Int) [x Int, y Int]) (replaceLeft (FailedToInstantiateGenericType originalStructTy) solution >>= go)
let fake1 = XObj (Sym (SymPath [] "a") Symbol) Nothing Nothing where
fake2 = XObj (Sym (SymPath [] "b") Symbol) Nothing Nothing fake1 = XObj (Sym (SymPath [] "a") Symbol) Nothing Nothing
XObj (Arr memberXObjs) _ _ = head membersXObjs fake2 = XObj (Sym (SymPath [] "b") Symbol) Nothing Nothing
rename@(StructTy _ renamedOrig) = evalState (renameVarTys originalStructTy) 0 XObj (Arr memberXObjs) _ _ = head membersXObjs
in case solve [Constraint originalStructTy genericStructTy fake1 fake2 fake1 OrdMultiSym] of rename@(StructTy _ renamedOrig) = evalState (renameVarTys originalStructTy) 0
Left e -> error (show e) solution = solve [Constraint originalStructTy genericStructTy fake1 fake2 fake1 OrdMultiSym]
Right mappings -> go mappings = do
let Right mapp = solve [Constraint rename genericStructTy fake1 fake2 fake1 OrdMultiSym] mappings' <- replaceLeft (FailedToInstantiateGenericType originalStructTy) (solve [Constraint rename genericStructTy fake1 fake2 fake1 OrdMultiSym])
nameFixedMembers = renameGenericTypeSymbolsOnProduct renamedOrig memberXObjs let nameFixedMembers = renameGenericTypeSymbolsOnProduct renamedOrig memberXObjs
validMembers = replaceGenericTypeSymbolsOnMembers mapp nameFixedMembers validMembers = replaceGenericTypeSymbolsOnMembers mappings' nameFixedMembers
concretelyTypedMembers = replaceGenericTypeSymbolsOnMembers mappings memberXObjs concretelyTypedMembers = replaceGenericTypeSymbolsOnMembers mappings memberXObjs
in -- We only used the renamed types for validation--passing the validateMembers AllowAnyTypeVariableNames typeEnv renamedOrig validMembers
-- renamed xobjs further down leads to syntactical issues. deps <- mapM (depsForStructMemberPair typeEnv) (pairwise concretelyTypedMembers)
case validateMembers AllowAnyTypeVariableNames typeEnv renamedOrig validMembers of let xobj =
Left err -> Left err XObj
Right () -> ( Lst
let deps = mapM (depsForStructMemberPair typeEnv) (pairwise concretelyTypedMembers) ( XObj (Deftype genericStructTy) Nothing Nothing
in case deps of : XObj (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing
Left err -> Left err : [XObj (Arr concretelyTypedMembers) Nothing Nothing]
Right okDeps -> )
Right $ )
XObj (Just dummyInfo)
( Lst (Just TypeTy)
( XObj (Deftype genericStructTy) Nothing Nothing : : concat deps
XObj (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing : pure xobj
[XObj (Arr concretelyTypedMembers) Nothing Nothing] instantiateGenericStructType _ t _ _ = Left (FailedToInstantiateGenericType t)
)
)
(Just dummyInfo)
(Just TypeTy) :
concat okDeps
instantiateGenericStructType _ _ _ _ = error "instantiategenericstructtype"
depsForStructMemberPair :: TypeEnv -> (XObj, XObj) -> Either TypeError [XObj] depsForStructMemberPair :: TypeEnv -> (XObj, XObj) -> Either TypeError [XObj]
depsForStructMemberPair typeEnv (_, tyXObj) = depsForStructMemberPair typeEnv (_, tyXObj) =
case xobjToTy tyXObj of maybe (Left (NotAType tyXObj)) (concretizeType typeEnv) (xobjToTy tyXObj)
Just okTy -> concretizeType typeEnv okTy
Nothing -> error ("Failed to convert " ++ pretty tyXObj ++ " to a type.")
-- | Given an generic sumtype and a concrete version of it, generate all dependencies needed to use the concrete one. -- | Given an generic sumtype and a concrete version of it, generate all dependencies needed to use the concrete one.
--
-- Turn (deftype (Maybe a) (Just a) (Nothing)) into (deftype (Maybe Int) (Just Int) (Nothing))
instantiateGenericSumtype :: TypeEnv -> Ty -> Ty -> [XObj] -> Either TypeError [XObj] instantiateGenericSumtype :: TypeEnv -> Ty -> Ty -> [XObj] -> Either TypeError [XObj]
instantiateGenericSumtype typeEnv originalStructTy@(StructTy _ originalTyVars) genericStructTy cases = instantiateGenericSumtype typeEnv originalStructTy@(StructTy _ originalTyVars) genericStructTy cases =
-- Turn (deftype (Maybe a) (Just a) (Nothing)) into (deftype (Maybe Int) (Just Int) (Nothing))
let fake1 = XObj (Sym (SymPath [] "a") Symbol) Nothing Nothing let fake1 = XObj (Sym (SymPath [] "a") Symbol) Nothing Nothing
fake2 = XObj (Sym (SymPath [] "b") Symbol) Nothing Nothing fake2 = XObj (Sym (SymPath [] "b") Symbol) Nothing Nothing
rename@(StructTy _ renamedOrig) = evalState (renameVarTys originalStructTy) 0 rename@(StructTy _ renamedOrig) = evalState (renameVarTys originalStructTy) 0
@ -587,14 +656,14 @@ instantiateGenericSumtype typeEnv originalStructTy@(StructTy _ originalTyVars) g
Right $ Right $
XObj XObj
( Lst ( Lst
( XObj (DefSumtype genericStructTy) Nothing Nothing : ( XObj (DefSumtype genericStructTy) Nothing Nothing
XObj (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing : : XObj (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing
concretelyTypedCases : concretelyTypedCases
) )
) )
(Just dummyInfo) (Just dummyInfo)
(Just TypeTy) : (Just TypeTy)
concat okDeps : concat okDeps
Left err -> Left err Left err -> Left err
instantiateGenericSumtype _ _ _ _ = error "instantiategenericsumtype" instantiateGenericSumtype _ _ _ _ = error "instantiategenericsumtype"
@ -603,13 +672,10 @@ instantiateGenericSumtype _ _ _ _ = error "instantiategenericsumtype"
-- (Just [x]) aka XObj (Lst (Sym...) (Arr members)) -- (Just [x]) aka XObj (Lst (Sym...) (Arr members))
-- On other cases it will return an error. -- On other cases it will return an error.
depsForCase :: TypeEnv -> XObj -> Either TypeError [XObj] depsForCase :: TypeEnv -> XObj -> Either TypeError [XObj]
depsForCase typeEnv x@(XObj (Lst [_, XObj (Arr members) _ _]) _ _) = depsForCase typeEnv (XObj (Lst [_, XObj (Arr members) _ _]) _ _) =
concat concat
<$> mapM <$> mapM
( \m -> case xobjToTy m of (\t -> maybe (Left (NotAType t)) (concretizeType typeEnv) (xobjToTy t))
Just okTy -> concretizeType typeEnv okTy
Nothing -> error ("Failed to convert " ++ pretty m ++ " to a type: " ++ pretty x)
)
members members
depsForCase _ x = Left (InvalidSumtypeCase x) depsForCase _ x = Left (InvalidSumtypeCase x)

8
src/Eval.hs
View File

@ -200,7 +200,7 @@ eval ctx xobj@(XObj o info ty) preference resolver =
(AppPat (MacroPat _ _ _) _) -> evaluateMacro form' (AppPat (MacroPat _ _ _) _) -> evaluateMacro form'
(AppPat (CommandPat _ _ _) _) -> evaluateCommand form' (AppPat (CommandPat _ _ _) _) -> evaluateCommand form'
(AppPat (PrimitivePat _ _ _) _) -> evaluatePrimitive form' (AppPat (PrimitivePat _ _ _) _) -> evaluatePrimitive form'
(WithPat _ sym@(SymPat path) forms) -> specialCommandWith ctx sym path forms (WithPat _ sym@(SymPat path _) forms) -> specialCommandWith ctx sym path forms
(DoPat _ forms) -> evaluateSideEffects forms (DoPat _ forms) -> evaluateSideEffects forms
(WhilePat _ cond body) -> specialCommandWhile ctx cond body (WhilePat _ cond body) -> specialCommandWhile ctx cond body
(SetPat _ iden value) -> specialCommandSet ctx (iden : [value]) (SetPat _ iden value) -> specialCommandSet ctx (iden : [value])
@ -217,7 +217,7 @@ eval ctx xobj@(XObj o info ty) preference resolver =
-- Importantly, the loop *is only broken on literal nested lists*. -- 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 -- That is, passing a *symbol* that, e.g. resolves to a defn list, won't
-- break our normal loop. -- break our normal loop.
(AppPat self@(ListPat (x@(SymPat _) : _)) args) -> (AppPat self@(ListPat (x@(SymPat _ _) : _)) args) ->
do do
(_, evald) <- eval ctx x preference ResolveGlobal (_, evald) <- eval ctx x preference ResolveGlobal
case evald of case evald of
@ -226,7 +226,7 @@ eval ctx xobj@(XObj o info ty) preference resolver =
Right _ -> evaluateApp (self : args) Right _ -> evaluateApp (self : args)
Left er -> pure (evalError ctx (show er) (xobjInfo xobj)) Left er -> pure (evalError ctx (show er) (xobjInfo xobj))
(AppPat (ListPat _) _) -> evaluateApp form' (AppPat (ListPat _) _) -> evaluateApp form'
(AppPat (SymPat _) _) -> evaluateApp form' (AppPat (SymPat _ _) _) -> evaluateApp form'
[] -> pure (ctx, dynamicNil) [] -> pure (ctx, dynamicNil)
_ -> pure (throwErr (UnknownForm xobj) ctx (xobjInfo xobj)) _ -> pure (throwErr (UnknownForm xobj) ctx (xobjInfo xobj))
checkStatic' (XObj Def _ _) = Left (HasStaticCall xobj info) checkStatic' (XObj Def _ _) = Left (HasStaticCall xobj info)
@ -389,7 +389,7 @@ eval ctx xobj@(XObj o info ty) preference resolver =
evaluateApp (AppPat f' args) = evaluateApp (AppPat f' args) =
case f' of case f' of
l@(ListPat _) -> go l ResolveLocal l@(ListPat _) -> go l ResolveLocal
sym@(SymPat _) -> go sym resolver sym@(SymPat _ _) -> go sym resolver
_ -> pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj)) _ -> pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj))
where where
go x resolve = go x resolve =

27
src/Forms.hs
View File

@ -30,12 +30,17 @@ module Forms
pattern DoPat, pattern DoPat,
pattern WhilePat, pattern WhilePat,
pattern SetPat, pattern SetPat,
pattern MultiSymPat,
pattern InterfaceSymPat,
pattern MatchPat,
pattern InterfacePat,
) )
where where
import Data.List (intercalate) import Data.List (intercalate)
import Obj import Obj
import SymPath import SymPath
import Types
import Util import Util
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -244,7 +249,7 @@ validateWhile invalid = Left (GenericMalformed (XObj (Lst invalid) Nothing Nothi
-- | Validation of (def name value) expressions. -- | Validation of (def name value) expressions.
validateDef :: [XObj] -> Either Malformed [XObj] validateDef :: [XObj] -> Either Malformed [XObj]
validateDef x@(DefPat _ (UnqualifiedSymPat _) _) = Right x validateDef x@(DefPat _ (UnqualifiedSymPat _) _) = Right x
validateDef (DefPat _ invalid@(SymPat _) _) = Left (QualifiedIdentifier invalid None) validateDef (DefPat _ invalid@(SymPat _ _) _) = Left (QualifiedIdentifier invalid None)
validateDef (DefPat _ invalid _) = Left (InvalidIdentifier invalid None) validateDef (DefPat _ invalid _) = Left (InvalidIdentifier invalid None)
validateDef def = Left (GenericMalformed (XObj (Lst def) Nothing Nothing)) validateDef def = Left (GenericMalformed (XObj (Lst def) Nothing Nothing))
@ -257,7 +262,7 @@ validateDefn x@(DefnPat _ (UnqualifiedSymPat _) arr@(ArrPat args) _)
| otherwise = pure x | otherwise = pure x
validateDefn (DefnPat _ (UnqualifiedSymPat _) invalid _) = validateDefn (DefnPat _ (UnqualifiedSymPat _) invalid _) =
Left (InvalidArguments invalid (DefnNonArrayArgs invalid)) Left (InvalidArguments invalid (DefnNonArrayArgs invalid))
validateDefn (DefnPat _ invalid@(SymPat _) _ _) = Left (QualifiedIdentifier invalid None) validateDefn (DefnPat _ invalid@(SymPat _ _) _ _) = Left (QualifiedIdentifier invalid None)
validateDefn (DefnPat _ invalid _ _) = Left (InvalidIdentifier invalid None) validateDefn (DefnPat _ invalid _ _) = Left (InvalidIdentifier invalid None)
validateDefn defn = Left (GenericMalformed (XObj (Lst defn) Nothing Nothing)) validateDefn defn = Left (GenericMalformed (XObj (Lst defn) Nothing Nothing))
@ -348,7 +353,7 @@ validateApp app = Left (GenericMalformed (XObj (Lst app) Nothing Nothing))
-- | Validation of (with module body) expressions -- | Validation of (with module body) expressions
validateWith :: [XObj] -> Either Malformed [XObj] validateWith :: [XObj] -> Either Malformed [XObj]
validateWith x@(WithPat _ (SymPat _) _) = Right x validateWith x@(WithPat _ (SymPat _ _) _) = Right x
validateWith (WithPat _ invalid _) = Left (InvalidIdentifier invalid (InvalidWith invalid)) validateWith (WithPat _ invalid _) = Left (InvalidIdentifier invalid (InvalidWith invalid))
validateWith with = Left (GenericMalformed (XObj (Lst with) Nothing Nothing)) validateWith with = Left (GenericMalformed (XObj (Lst with) Nothing Nothing))
@ -377,8 +382,8 @@ pattern StaticArrPat members <- XObj (StaticArr members) _ _
pattern ListPat :: [XObj] -> XObj pattern ListPat :: [XObj] -> XObj
pattern ListPat members <- XObj (Lst members) _ _ pattern ListPat members <- XObj (Lst members) _ _
pattern SymPat :: SymPath -> XObj pattern SymPat :: SymPath -> SymbolMode -> XObj
pattern SymPat path <- XObj (Sym path _) _ _ pattern SymPat path mode <- XObj (Sym path mode) _ _
pattern UnqualifiedSymPat :: SymPath -> XObj pattern UnqualifiedSymPat :: SymPath -> XObj
pattern UnqualifiedSymPat path <- XObj (Sym path@(SymPath [] _) _) _ _ pattern UnqualifiedSymPat path <- XObj (Sym path@(SymPath [] _) _) _ _
@ -433,3 +438,15 @@ pattern PrimitivePat arity sym params <- XObj (Lst [XObj (Primitive arity) _ _,
pattern AppPat :: XObj -> [XObj] -> [XObj] pattern AppPat :: XObj -> [XObj] -> [XObj]
pattern AppPat f args <- (f : args) pattern AppPat f args <- (f : args)
pattern InterfaceSymPat :: String -> XObj
pattern InterfaceSymPat name <- XObj (InterfaceSym name) _ _
pattern MultiSymPat :: String -> [SymPath] -> XObj
pattern MultiSymPat name candidates <- XObj (MultiSym name candidates) _ _
pattern MatchPat :: XObj -> XObj -> [XObj] -> [XObj]
pattern MatchPat match value stanzas <- (match@(XObj (Match _) _ _) : value : stanzas)
pattern InterfacePat :: Ty -> [SymPath] -> [XObj]
pattern InterfacePat ty paths <- [XObj (Interface ty paths) _ _, _]

3
src/Obj.hs
View File

@ -335,6 +335,9 @@ data XObj = XObj
} }
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
setObj :: XObj -> Obj -> XObj
setObj x o = x {xobjObj = o}
instance Hashable XObj where instance Hashable XObj where
hashWithSalt s XObj {..} = s `hashWithSalt` xobjObj hashWithSalt s XObj {..} = s `hashWithSalt` xobjObj

3
src/TypeError.hs
View File

@ -61,6 +61,7 @@ data TypeError
| UninhabitedConstructor Ty XObj Int Int | UninhabitedConstructor Ty XObj Int Int
| InconsistentKinds String [XObj] | InconsistentKinds String [XObj]
| FailedToAddLambdaStructToTyEnv SymPath XObj | FailedToAddLambdaStructToTyEnv SymPath XObj
| FailedToInstantiateGenericType Ty
instance Show TypeError where instance Show TypeError where
show (SymbolMissingType xobj env) = show (SymbolMissingType xobj env) =
@ -310,6 +311,8 @@ instance Show TypeError where
"Failed to add the lambda: " ++ show path ++ " represented by struct: " "Failed to add the lambda: " ++ show path ++ " represented by struct: "
++ pretty xobj ++ pretty xobj
++ " to the type environment." ++ " to the type environment."
show (FailedToInstantiateGenericType ty) =
"I couldn't instantiate the generic type " ++ show ty
machineReadableErrorStrings :: FilePathPrintLength -> TypeError -> [String] machineReadableErrorStrings :: FilePathPrintLength -> TypeError -> [String]
machineReadableErrorStrings fppl err = machineReadableErrorStrings fppl err =