mirror of
https://github.com/carp-lang/Carp.git
synced 2024-09-11 05:25:28 +03:00
fix: fix nested polymorphic types (#1294)
* 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. * refactor: ensure findType returns a type Adds an additional check to findType that ensures the retrieved binder is in fact a type and not another object. This is necessary for certain contexts like type concretization since modules may also be designated by symbols that refer to types. * fix: ensure nested polymorphic types are emitted This commit fixes an issue whereby nested polymorphic types would not be emitted by the compiler, even though their member functions were emitted. In order to support this, we need to update a couple of functions to take the global environment (to find nested types, which live in modules) in addition to the top level type environment. Additionally, we had to update scoring to account for nested names. fixes #1293 * test: add tests for nested polymorphic types Adds regression tests to ensure nested polymorphic types are concretized and emitted correctly.
This commit is contained in:
parent
b74e674bb1
commit
0c9c475e6c
@ -30,7 +30,7 @@ import Data.Either (fromRight)
|
||||
import Data.List (foldl')
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Debug.Trace
|
||||
import Env (EnvironmentError, empty, envIsExternal, getTypeBinder, insert, insertX, searchValue)
|
||||
import Env (EnvironmentError, empty, envIsExternal, findTypeBinder, getTypeBinder, insert, insertX, searchValue)
|
||||
import Forms
|
||||
import Info
|
||||
import InitialTypes
|
||||
@ -96,12 +96,12 @@ visit visited allowAmbig level tenv env xobj@(ListPat _) =
|
||||
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
|
||||
c <- concretizeTypeOfXObj tenv env 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
|
||||
c <- concretizeTypeOfXObj tenv env xobj
|
||||
pure (c >> vArr >>= \ok -> pure (setObj xobj (StaticArr ok)))
|
||||
visit _ _ _ _ _ x = pure (Right x)
|
||||
|
||||
@ -136,10 +136,10 @@ 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
|
||||
mapM_ (concretizeTypeOfXObj tenv env) arr
|
||||
let envWithArgs = fromRight Env.empty (envWithFunctionArgs env arr)
|
||||
allowAmbig = maybe True isTypeGeneric (xobjTy x)
|
||||
c <- concretizeTypeOfXObj tenv body
|
||||
c <- concretizeTypeOfXObj tenv env body
|
||||
vBody <- visit (getPath x : visited) allowAmbig Inside tenv (incrementEnvNestLevel envWithArgs) body
|
||||
pure (c >> vBody >>= go)
|
||||
where
|
||||
@ -152,7 +152,7 @@ visitDefn _ _ _ _ _ x = pure (Left (CannotConcretize x))
|
||||
visitMain :: Visitor
|
||||
visitMain visited _ Toplevel tenv env (ListPat (DefnPat defn name@(SymPat (SymPath [] "main") _) args@(ArrPat []) body)) =
|
||||
do
|
||||
c <- concretizeTypeOfXObj tenv body
|
||||
c <- concretizeTypeOfXObj tenv env body
|
||||
vBody <- visit visited False Inside tenv env body
|
||||
pure (c >> vBody >>= typeCheck)
|
||||
where
|
||||
@ -184,7 +184,7 @@ visitLet visited allowAmbig level tenv env (ListPat (LetPat letExpr arr@(ArrPat
|
||||
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)
|
||||
c <- mapM (concretizeTypeOfXObj tenv env . fst) (pairwise bindings)
|
||||
pure (sequence c >> go bindings' body')
|
||||
where
|
||||
go x' y = do
|
||||
@ -205,9 +205,9 @@ visitThe _ _ _ _ _ x = pure (Left (CannotConcretize x))
|
||||
visitMatch :: Visitor
|
||||
visitMatch visited allowAmbig level tenv env (ListPat (MatchPat match expr rest)) =
|
||||
do
|
||||
c <- concretizeTypeOfXObj tenv expr
|
||||
c <- concretizeTypeOfXObj tenv env expr
|
||||
vExpr <- visit visited allowAmbig level tenv env expr
|
||||
mapM_ (concretizeTypeOfXObj tenv . snd) (pairwise rest)
|
||||
mapM_ (concretizeTypeOfXObj tenv env . snd) (pairwise rest)
|
||||
vCases <- fmap sequence (mapM (visitMatchCase visited allowAmbig level tenv env) (pairwise rest))
|
||||
pure (c >> go vExpr vCases)
|
||||
where
|
||||
@ -238,8 +238,8 @@ visitSetBang _ _ _ _ _ x = pure (Left (CannotConcretize x))
|
||||
visitApp :: Visitor
|
||||
visitApp visited allowAmbig level tenv env (ListPat (AppPat func args)) =
|
||||
do
|
||||
c <- concretizeTypeOfXObj tenv func
|
||||
cs <- fmap sequence $ mapM (concretizeTypeOfXObj tenv) args
|
||||
c <- concretizeTypeOfXObj tenv env func
|
||||
cs <- fmap sequence $ mapM (concretizeTypeOfXObj tenv env) 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)
|
||||
@ -267,7 +267,7 @@ mkLambda visited allowAmbig _ tenv env root@(ListPat (FnPat fn arr@(ArrPat args)
|
||||
extendedArgs =
|
||||
if null capturedVars
|
||||
then arr
|
||||
else-- If the lambda captures anything it need an extra arg for its env:
|
||||
else -- If the lambda captures anything it need an extra arg for its env:
|
||||
|
||||
( setObj
|
||||
arr
|
||||
@ -275,8 +275,8 @@ mkLambda visited allowAmbig _ tenv env root@(ListPat (FnPat fn arr@(ArrPat args)
|
||||
( XObj
|
||||
(Sym (SymPath [] "_env") Symbol)
|
||||
(Just dummyInfo)
|
||||
(Just (PointerTy (StructTy (ConcreteNameTy tyPath) [])))
|
||||
: args
|
||||
(Just (PointerTy (StructTy (ConcreteNameTy tyPath) []))) :
|
||||
args
|
||||
)
|
||||
)
|
||||
)
|
||||
@ -338,7 +338,7 @@ mkLambda _ _ _ _ _ root = pure (Left (CannotConcretize root))
|
||||
visitFn :: Visitor
|
||||
visitFn visited allowAmbig level tenv env x@(ListPat (FnPat fn args@(ArrPat arr) body)) =
|
||||
do
|
||||
mapM_ (concretizeTypeOfXObj tenv) arr
|
||||
mapM_ (concretizeTypeOfXObj tenv env) arr
|
||||
let envWithArgs = fromRight Env.empty (envWithFunctionArgs env arr)
|
||||
vBody <- visit visited allowAmbig Inside tenv (incrementEnvNestLevel envWithArgs) body
|
||||
either (pure . Left) (\b -> mkLambda visited allowAmbig level tenv envWithArgs (setObj x (Lst [fn, args, b]))) vBody
|
||||
@ -516,56 +516,54 @@ matchingSignature3 tA (tB, _, _) = areUnifiable tA tB
|
||||
|
||||
-- | 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.
|
||||
concretizeTypeOfXObj :: TypeEnv -> XObj -> State [XObj] (Either TypeError ())
|
||||
concretizeTypeOfXObj typeEnv (XObj _ _ (Just ty)) =
|
||||
either (pure . Left) success (concretizeType typeEnv ty)
|
||||
concretizeTypeOfXObj :: TypeEnv -> Env -> XObj -> State [XObj] (Either TypeError ())
|
||||
concretizeTypeOfXObj typeEnv env (XObj _ _ (Just ty)) =
|
||||
either (pure . Left) success (concretizeType typeEnv env ty)
|
||||
where
|
||||
success :: [XObj] -> State [XObj] (Either TypeError ())
|
||||
success xs = modify (xs ++) >> pure (Right ())
|
||||
concretizeTypeOfXObj _ _ = pure (Right ())
|
||||
concretizeTypeOfXObj _ _ _ = pure (Right ())
|
||||
|
||||
-- | Find all the concrete deps of a type.
|
||||
concretizeType :: TypeEnv -> Ty -> Either TypeError [XObj]
|
||||
concretizeType _ ft@FuncTy {} =
|
||||
concretizeType :: TypeEnv -> Env -> Ty -> Either TypeError [XObj]
|
||||
concretizeType _ _ ft@FuncTy {} =
|
||||
if isTypeGeneric ft
|
||||
then Right []
|
||||
else Right [defineFunctionTypeAlias ft]
|
||||
concretizeType typeEnv arrayTy@(StructTy (ConcreteNameTy (SymPath [] "Array")) varTys) =
|
||||
concretizeType typeEnv env arrayTy@(StructTy (ConcreteNameTy (SymPath [] "Array")) varTys) =
|
||||
if isTypeGeneric arrayTy
|
||||
then Right []
|
||||
else do
|
||||
deps <- mapM (concretizeType typeEnv) varTys
|
||||
deps <- mapM (concretizeType typeEnv env) varTys
|
||||
Right (defineArrayTypeAlias arrayTy : concat deps)
|
||||
-- TODO: Remove ugly duplication of code here:
|
||||
concretizeType typeEnv arrayTy@(StructTy (ConcreteNameTy (SymPath [] "StaticArray")) varTys) =
|
||||
concretizeType typeEnv env arrayTy@(StructTy (ConcreteNameTy (SymPath [] "StaticArray")) varTys) =
|
||||
if isTypeGeneric arrayTy
|
||||
then Right []
|
||||
else do
|
||||
deps <- mapM (concretizeType typeEnv) varTys
|
||||
deps <- mapM (concretizeType typeEnv env) varTys
|
||||
Right (defineStaticArrayTypeAlias arrayTy : concat deps)
|
||||
concretizeType typeEnv genericStructTy@(StructTy (ConcreteNameTy (SymPath _ name)) _) =
|
||||
-- TODO: This function only looks up direct children of the type environment.
|
||||
-- However, spath can point to types that belong to a module. Pass the global env here.
|
||||
case (getTypeBinder typeEnv name) of
|
||||
concretizeType typeEnv env genericStructTy@(StructTy (ConcreteNameTy path@(SymPath _ name)) _) =
|
||||
case (getTypeBinder typeEnv name) <> (findTypeBinder env path) of
|
||||
Right (Binder _ x) -> go x
|
||||
_ -> Right []
|
||||
where
|
||||
go :: XObj -> Either TypeError [XObj]
|
||||
go (XObj (Lst (XObj (Deftype originalStructTy) _ _ : _ : rest)) _ _) =
|
||||
if isTypeGeneric originalStructTy
|
||||
then instantiateGenericStructType typeEnv originalStructTy genericStructTy rest
|
||||
then instantiateGenericStructType typeEnv env originalStructTy genericStructTy rest
|
||||
else Right []
|
||||
go (XObj (Lst (XObj (DefSumtype originalStructTy) _ _ : _ : rest)) _ _) =
|
||||
if isTypeGeneric originalStructTy
|
||||
then instantiateGenericSumtype typeEnv originalStructTy genericStructTy rest
|
||||
then instantiateGenericSumtype typeEnv env originalStructTy genericStructTy rest
|
||||
else Right []
|
||||
go (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _) = Right []
|
||||
go x = error ("Non-deftype found in type env: " ++ pretty x)
|
||||
concretizeType t (RefTy rt _) =
|
||||
concretizeType t rt
|
||||
concretizeType t (PointerTy pt) =
|
||||
concretizeType t pt
|
||||
concretizeType _ _ =
|
||||
concretizeType t e (RefTy rt _) =
|
||||
concretizeType t e rt
|
||||
concretizeType t e (PointerTy pt) =
|
||||
concretizeType t e pt
|
||||
concretizeType _ _ _ =
|
||||
Right [] -- ignore all other types
|
||||
|
||||
-- | Renames the type variable literals in a sum type for temporary validation.
|
||||
@ -600,8 +598,8 @@ renameGenericTypeSymbolsOnProduct vars members =
|
||||
-- | Given an generic struct type and a concrete version of it, generate all dependencies needed to use the concrete one.
|
||||
--
|
||||
-- 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 originalStructTy@(StructTy _ _) genericStructTy membersXObjs =
|
||||
instantiateGenericStructType :: TypeEnv -> Env -> Ty -> Ty -> [XObj] -> Either TypeError [XObj]
|
||||
instantiateGenericStructType typeEnv env originalStructTy@(StructTy _ _) genericStructTy membersXObjs =
|
||||
(replaceLeft (FailedToInstantiateGenericType originalStructTy) solution >>= go)
|
||||
where
|
||||
fake1 = XObj (Sym (SymPath [] "a") Symbol) Nothing Nothing
|
||||
@ -615,30 +613,30 @@ instantiateGenericStructType typeEnv originalStructTy@(StructTy _ _) genericStru
|
||||
validMembers = replaceGenericTypeSymbolsOnMembers mappings' nameFixedMembers
|
||||
concretelyTypedMembers = replaceGenericTypeSymbolsOnMembers mappings memberXObjs
|
||||
validateMembers AllowAnyTypeVariableNames typeEnv renamedOrig validMembers
|
||||
deps <- mapM (depsForStructMemberPair typeEnv) (pairwise concretelyTypedMembers)
|
||||
deps <- mapM (depsForStructMemberPair typeEnv env) (pairwise concretelyTypedMembers)
|
||||
let xobj =
|
||||
XObj
|
||||
( Lst
|
||||
( XObj (Deftype genericStructTy) Nothing Nothing
|
||||
: XObj (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing
|
||||
: [XObj (Arr concretelyTypedMembers) Nothing Nothing]
|
||||
( XObj (Deftype genericStructTy) Nothing Nothing :
|
||||
XObj (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing :
|
||||
[XObj (Arr concretelyTypedMembers) Nothing Nothing]
|
||||
)
|
||||
)
|
||||
(Just dummyInfo)
|
||||
(Just TypeTy)
|
||||
: concat deps
|
||||
(Just TypeTy) :
|
||||
concat deps
|
||||
pure xobj
|
||||
instantiateGenericStructType _ t _ _ = Left (FailedToInstantiateGenericType t)
|
||||
instantiateGenericStructType _ _ t _ _ = Left (FailedToInstantiateGenericType t)
|
||||
|
||||
depsForStructMemberPair :: TypeEnv -> (XObj, XObj) -> Either TypeError [XObj]
|
||||
depsForStructMemberPair typeEnv (_, tyXObj) =
|
||||
maybe (Left (NotAType tyXObj)) (concretizeType typeEnv) (xobjToTy tyXObj)
|
||||
depsForStructMemberPair :: TypeEnv -> Env -> (XObj, XObj) -> Either TypeError [XObj]
|
||||
depsForStructMemberPair typeEnv env (_, tyXObj) =
|
||||
maybe (Left (NotAType tyXObj)) (concretizeType typeEnv env) (xobjToTy tyXObj)
|
||||
|
||||
-- | 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 originalStructTy@(StructTy _ originalTyVars) genericStructTy cases =
|
||||
instantiateGenericSumtype :: TypeEnv -> Env -> Ty -> Ty -> [XObj] -> Either TypeError [XObj]
|
||||
instantiateGenericSumtype typeEnv env originalStructTy@(StructTy _ originalTyVars) genericStructTy cases =
|
||||
let fake1 = XObj (Sym (SymPath [] "a") Symbol) Nothing Nothing
|
||||
fake2 = XObj (Sym (SymPath [] "b") Symbol) Nothing Nothing
|
||||
rename@(StructTy _ renamedOrig) = evalState (renameVarTys originalStructTy) 0
|
||||
@ -647,7 +645,7 @@ instantiateGenericSumtype typeEnv originalStructTy@(StructTy _ originalTyVars) g
|
||||
Right mappings ->
|
||||
let nameFixedCases = map (renameGenericTypeSymbolsOnSum (zip originalTyVars renamedOrig)) cases
|
||||
concretelyTypedCases = map (replaceGenericTypeSymbolsOnCase mappings) nameFixedCases
|
||||
deps = mapM (depsForCase typeEnv) concretelyTypedCases
|
||||
deps = mapM (depsForCase typeEnv env) concretelyTypedCases
|
||||
in case toCases typeEnv AllowAnyTypeVariableNames renamedOrig concretelyTypedCases of -- Don't care about the cases, this is done just for validation.
|
||||
Left err -> Left err
|
||||
Right _ ->
|
||||
@ -656,28 +654,28 @@ instantiateGenericSumtype typeEnv originalStructTy@(StructTy _ originalTyVars) g
|
||||
Right $
|
||||
XObj
|
||||
( Lst
|
||||
( XObj (DefSumtype genericStructTy) Nothing Nothing
|
||||
: XObj (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing
|
||||
: concretelyTypedCases
|
||||
( XObj (DefSumtype genericStructTy) Nothing Nothing :
|
||||
XObj (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing :
|
||||
concretelyTypedCases
|
||||
)
|
||||
)
|
||||
(Just dummyInfo)
|
||||
(Just TypeTy)
|
||||
: concat okDeps
|
||||
(Just TypeTy) :
|
||||
concat okDeps
|
||||
Left err -> Left err
|
||||
instantiateGenericSumtype _ _ _ _ = error "instantiategenericsumtype"
|
||||
instantiateGenericSumtype _ _ _ _ _ = error "instantiategenericsumtype"
|
||||
|
||||
-- Resolves dependencies for sumtype cases.
|
||||
-- NOTE: This function only accepts cases that are in "canonical form"
|
||||
-- (Just [x]) aka XObj (Lst (Sym...) (Arr members))
|
||||
-- On other cases it will return an error.
|
||||
depsForCase :: TypeEnv -> XObj -> Either TypeError [XObj]
|
||||
depsForCase typeEnv (XObj (Lst [_, XObj (Arr members) _ _]) _ _) =
|
||||
depsForCase :: TypeEnv -> Env -> XObj -> Either TypeError [XObj]
|
||||
depsForCase typeEnv env (XObj (Lst [_, XObj (Arr members) _ _]) _ _) =
|
||||
concat
|
||||
<$> mapM
|
||||
(\t -> maybe (Left (NotAType t)) (concretizeType typeEnv) (xobjToTy t))
|
||||
(\t -> maybe (Left (NotAType t)) (concretizeType typeEnv env) (xobjToTy t))
|
||||
members
|
||||
depsForCase _ x = Left (InvalidSumtypeCase x)
|
||||
depsForCase _ _ x = Left (InvalidSumtypeCase x)
|
||||
|
||||
replaceGenericTypeSymbolsOnMembers :: Map.Map String Ty -> [XObj] -> [XObj]
|
||||
replaceGenericTypeSymbolsOnMembers mappings memberXObjs =
|
||||
|
@ -382,7 +382,7 @@ genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameT
|
||||
t = FuncTy (map snd (memberXObjsToPairs membersXObjs)) originalStructTy StaticLifetimeTy
|
||||
docs = "creates a `" ++ show originalStructTy ++ "`."
|
||||
templateCreator = TemplateCreator $
|
||||
\typeEnv _ ->
|
||||
\typeEnv env ->
|
||||
Template
|
||||
(FuncTy (map snd (memberXObjsToPairs membersXObjs)) (VarTy "p") StaticLifetimeTy)
|
||||
( \(FuncTy _ concreteStructTy _) ->
|
||||
@ -397,7 +397,7 @@ genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameT
|
||||
in tokensForInit allocationMode (show originalStructTy) correctedMembers
|
||||
)
|
||||
( \(FuncTy _ concreteStructTy _) ->
|
||||
case concretizeType typeEnv concreteStructTy of
|
||||
case concretizeType typeEnv env concreteStructTy of
|
||||
Left _ -> []
|
||||
Right ok -> ok
|
||||
)
|
||||
|
11
src/Emit.hs
11
src/Emit.hs
@ -926,6 +926,7 @@ toDeclaration (Binder meta xobj@(XObj (Lst xobjs) _ ty)) =
|
||||
XObj (Primitive _) _ _ : _ ->
|
||||
""
|
||||
_ -> error ("Internal compiler error: Can't emit other kinds of definitions: " ++ show xobj)
|
||||
toDeclaration (Binder _ (XObj (Sym (SymPath [] "dummy") Symbol) Nothing (Just IntTy))) = ""
|
||||
toDeclaration _ = error "Missing case."
|
||||
|
||||
paramListToC :: [XObj] -> String
|
||||
@ -1006,7 +1007,7 @@ globalsToC globalEnv =
|
||||
typeEnvToDeclarations :: TypeEnv -> Env -> Either ToCError String
|
||||
typeEnvToDeclarations typeEnv global =
|
||||
let -- We need to carry the type environment to pass the correct environment on the binderToDeclaration call.
|
||||
addEnvToScore tyE = (sortDeclarationBinders tyE (map snd (Map.toList (binders tyE))))
|
||||
addEnvToScore tyE = (sortDeclarationBinders tyE global (map snd (Map.toList (binders tyE))))
|
||||
bindersWithScore = (addEnvToScore typeEnv)
|
||||
mods = (findModules global)
|
||||
folder =
|
||||
@ -1027,7 +1028,7 @@ typeEnvToDeclarations typeEnv global =
|
||||
|
||||
envToDeclarations :: TypeEnv -> Env -> Either ToCError String
|
||||
envToDeclarations typeEnv env =
|
||||
let bindersWithScore = sortDeclarationBinders typeEnv (map snd (Map.toList (envBindings env)))
|
||||
let bindersWithScore = sortDeclarationBinders typeEnv env (map snd (Map.toList (envBindings env)))
|
||||
in do
|
||||
okDecls <-
|
||||
mapM
|
||||
@ -1042,10 +1043,10 @@ envToDeclarations typeEnv env =
|
||||
-- debugScorePair :: (Int, Binder) -> (Int, Binder)
|
||||
-- debugScorePair (s,b) = trace ("Scored binder: " ++ show b ++ ", score: " ++ show s) (s,b)
|
||||
|
||||
sortDeclarationBinders :: TypeEnv -> [Binder] -> [(Int, Binder)]
|
||||
sortDeclarationBinders typeEnv binders' =
|
||||
sortDeclarationBinders :: TypeEnv -> Env -> [Binder] -> [(Int, Binder)]
|
||||
sortDeclarationBinders typeEnv env binders' =
|
||||
--trace ("\nSORTED: " ++ (show (sortOn fst (map (scoreBinder typeEnv) binders))))
|
||||
sortOn fst (map (scoreTypeBinder typeEnv) binders')
|
||||
sortOn fst (map (scoreTypeBinder typeEnv env) binders')
|
||||
|
||||
sortGlobalVariableBinders :: Env -> [Binder] -> [(Int, Binder)]
|
||||
sortGlobalVariableBinders globalEnv binders' =
|
||||
|
@ -292,7 +292,13 @@ getTypeBinder = getBinder
|
||||
--
|
||||
-- Restricts the final step of a search to binders in a module's *type* environment.
|
||||
findType :: Environment e => e -> SymPath -> Either EnvironmentError (TypeEnv, Binder)
|
||||
findType e path = find' (inj (prj e)) path
|
||||
findType e path = go $ find' (inj (prj e)) path
|
||||
-- Make sure the binder is actually a type.
|
||||
where go :: Either EnvironmentError (TypeEnv, Binder) -> Either EnvironmentError (TypeEnv, Binder)
|
||||
go (Right (t, b)) = if isType (binderXObj b)
|
||||
then Right (t, b)
|
||||
else Left (BindingNotFound (show path) (prj e))
|
||||
go x = x
|
||||
|
||||
findTypeBinder :: Environment e => e -> SymPath -> Either EnvironmentError Binder
|
||||
findTypeBinder e path = fmap snd (findType e path)
|
||||
|
@ -228,6 +228,10 @@ isTypeDef (XObj (Lst (XObj (Deftype _) _ _ : _)) _ _) = True
|
||||
isTypeDef (XObj (Lst (XObj (DefSumtype _) _ _ : _)) _ _) = True
|
||||
isTypeDef _ = False
|
||||
|
||||
isType :: XObj -> Bool
|
||||
isType (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _) = True
|
||||
isType x = isTypeDef x
|
||||
|
||||
isMod :: XObj -> Bool
|
||||
isMod (XObj (Mod _ _) _ _) = True
|
||||
isMod _ = False
|
||||
|
@ -10,8 +10,8 @@ import TypesToC
|
||||
-- | Scoring of types.
|
||||
-- | The score is used for sorting the bindings before emitting them.
|
||||
-- | A lower score means appearing earlier in the emitted file.
|
||||
scoreTypeBinder :: TypeEnv -> Binder -> (Int, Binder)
|
||||
scoreTypeBinder typeEnv b@(Binder _ (XObj (Lst (XObj x _ _ : XObj (Sym _ _) _ _ : _)) _ _)) =
|
||||
scoreTypeBinder :: TypeEnv -> Env -> Binder -> (Int, Binder)
|
||||
scoreTypeBinder typeEnv env b@(Binder _ (XObj (Lst (XObj x _ _ : XObj (Sym _ _) _ _ : _)) _ _)) =
|
||||
case x of
|
||||
Defalias aliasedType ->
|
||||
let selfName = ""
|
||||
@ -24,14 +24,16 @@ scoreTypeBinder typeEnv b@(Binder _ (XObj (Lst (XObj x _ _ : XObj (Sym _ _) _ _
|
||||
ExternalType _ -> (0, b)
|
||||
_ -> (500, b)
|
||||
where
|
||||
depthOfStruct (StructTy (ConcreteNameTy (SymPath _ name)) varTys) =
|
||||
case E.getTypeBinder typeEnv name of
|
||||
depthOfStruct (StructTy (ConcreteNameTy path@(SymPath _ name)) varTys) =
|
||||
case E.getTypeBinder typeEnv name <> findTypeBinder env path of
|
||||
Right (Binder _ typedef) -> (depthOfDeftype typeEnv Set.empty typedef varTys + 1, b)
|
||||
-- TODO: This function should return (Either ScoringError (Int,
|
||||
-- Binder)) instead of calling error.
|
||||
Left e -> error (show e)
|
||||
depthOfStruct _ = error "depthofstruct"
|
||||
scoreTypeBinder _ b@(Binder _ (XObj (Mod _ _) _ _)) =
|
||||
scoreTypeBinder _ _ b@(Binder _ (XObj (Mod _ _) _ _)) =
|
||||
(1000, b)
|
||||
scoreTypeBinder _ x = error ("Can't score: " ++ show x)
|
||||
scoreTypeBinder _ _ x = error ("Can't score: " ++ show x)
|
||||
|
||||
depthOfDeftype :: TypeEnv -> Set.Set Ty -> XObj -> [Ty] -> Int
|
||||
depthOfDeftype typeEnv visited (XObj (Lst (_ : XObj (Sym (SymPath path selfName) _) _ _ : rest)) _ _) varTys =
|
||||
|
@ -61,13 +61,13 @@ moduleForSumtype innerEnv typeEnv env pathStrings typeName typeVariables rest i
|
||||
(okPrn, _) <- binderForStrOrPrn typeEnv env insidePath structTy cases "prn"
|
||||
okDelete <- binderForDelete typeEnv env insidePath structTy cases
|
||||
(okCopy, okCopyDeps) <- binderForCopy typeEnv env insidePath structTy cases
|
||||
okMemberDeps <- memberDeps typeEnv cases
|
||||
okMemberDeps <- memberDeps typeEnv env cases
|
||||
let moduleEnvWithBindings = addListOfBindings moduleValueEnv (okIniters ++ [okStr, okPrn, okDelete, okCopy, okTag])
|
||||
typeModuleXObj = XObj (Mod moduleEnvWithBindings moduleTypeEnv) i (Just ModuleTy)
|
||||
pure (typeName, typeModuleXObj, okMemberDeps ++ okCopyDeps ++ okStrDeps)
|
||||
|
||||
memberDeps :: TypeEnv -> [SumtypeCase] -> Either TypeError [XObj]
|
||||
memberDeps typeEnv cases = fmap concat (mapM (concretizeType typeEnv) (concatMap caseTys cases))
|
||||
memberDeps :: TypeEnv -> Env -> [SumtypeCase] -> Either TypeError [XObj]
|
||||
memberDeps typeEnv env cases = fmap concat (mapM (concretizeType typeEnv env) (concatMap caseTys cases))
|
||||
|
||||
replaceGenericTypesOnCases :: TypeMappings -> [SumtypeCase] -> [SumtypeCase]
|
||||
replaceGenericTypesOnCases mappings = map replaceOnCase
|
||||
@ -110,7 +110,7 @@ genericCaseInit allocationMode pathStrings originalStructTy sumtypeCase =
|
||||
t = FuncTy (caseTys sumtypeCase) originalStructTy StaticLifetimeTy
|
||||
docs = "creates a `" ++ caseName sumtypeCase ++ "`."
|
||||
templateCreator = TemplateCreator $
|
||||
\typeEnv _ ->
|
||||
\typeEnv env ->
|
||||
Template
|
||||
(FuncTy (caseTys sumtypeCase) (VarTy "p") StaticLifetimeTy)
|
||||
( \(FuncTy _ concreteStructTy _) ->
|
||||
@ -124,7 +124,7 @@ genericCaseInit allocationMode pathStrings originalStructTy sumtypeCase =
|
||||
in tokensForCaseInit allocationMode concreteStructTy (sumtypeCase {caseTys = correctedTys})
|
||||
)
|
||||
( \(FuncTy _ concreteStructTy _) ->
|
||||
case concretizeType typeEnv concreteStructTy of
|
||||
case concretizeType typeEnv env concreteStructTy of
|
||||
Left _ -> []
|
||||
Right ok -> ok
|
||||
)
|
||||
|
@ -80,6 +80,18 @@
|
||||
(deftype (HitRecord a) [t a])
|
||||
(deftype (CurrentHit a) [hr (Maybe (HitRecord a))])
|
||||
|
||||
;; nested polymorphic types are resolved and emitted (#1293)
|
||||
(defmodule Bar
|
||||
(deftype (Baz a) [it a])
|
||||
(deftype (Qux a) [it (Bar.Baz a)])
|
||||
)
|
||||
|
||||
(deftype (PolyNest a) [it (Bar.Baz a)])
|
||||
|
||||
(defn poly-nest-one [x] (Bar.Baz x))
|
||||
(defn poly-nest-two [x] (Bar.Qux.init (Bar.Baz x)))
|
||||
(defn poly-nest-three [x] (PolyNest (Bar.Baz x)))
|
||||
|
||||
(deftest test
|
||||
(assert-equal test
|
||||
1
|
||||
@ -126,4 +138,18 @@
|
||||
1
|
||||
(dynamic-closure-referring-to-itself-test)
|
||||
"test that dynamic closure can refer to itself")
|
||||
(assert-equal test
|
||||
2
|
||||
@(Bar.Baz.it &(poly-nest-one 2))
|
||||
"test that polymorphic types in modules are emitted")
|
||||
(assert-equal test
|
||||
2
|
||||
@(Bar.Baz.it (Bar.Qux.it &(poly-nest-two 2)))
|
||||
"test that polymorphic types in modules are emitted and can
|
||||
refer to each other")
|
||||
(assert-equal test
|
||||
2
|
||||
@(Bar.Baz.it (PolyNest.it &(poly-nest-three 2)))
|
||||
"test that polymorphic types in modules can be referred to using
|
||||
other types outside the module")
|
||||
)
|
||||
|
Loading…
Reference in New Issue
Block a user