carp-lang/Carp
1
1
Fork 0
mirror of https://github.com/carp-lang/Carp.git synced 2024-09-17 16:38:14 +03:00
Code Issues Projects Releases Wiki Activity

fix: fix nested polymorphic types (#1294)

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.

* 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:
Scott Olsen 2021-08-10 02:41:20 -04:00 committed by GitHub
parent b74e674bb1
commit 0c9c475e6c
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
8 changed files with 117 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

120
src/Concretize.hs
View File

@ -30,7 +30,7 @@ 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 (EnvironmentError, empty, envIsExternal, getTypeBinder, insert, insertX, searchValue) import Env (EnvironmentError, empty, envIsExternal, findTypeBinder, getTypeBinder, insert, insertX, searchValue)
import Forms import Forms
import Info import Info
import InitialTypes import InitialTypes
@ -96,12 +96,12 @@ visit visited allowAmbig level tenv env xobj@(ListPat _) =
visit visited allowAmbig level tenv env xobj@(ArrPat arr) = visit visited allowAmbig level tenv env xobj@(ArrPat arr) =
do do
vArr <- fmap sequence (mapM (visit visited allowAmbig level tenv env) arr) 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))) pure (c >> vArr >>= \ok -> pure (setObj xobj (Arr ok)))
visit visited allowAmbig level tenv env xobj@(StaticArrPat arr) = visit visited allowAmbig level tenv env xobj@(StaticArrPat arr) =
do do
vArr <- fmap sequence (mapM (visit visited allowAmbig level tenv env) arr) 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))) pure (c >> vArr >>= \ok -> pure (setObj xobj (StaticArr ok)))
visit _ _ _ _ _ x = pure (Right x) 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 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)) = visitDefn visited _ Toplevel tenv env x@(ListPat (DefnPat defn name args@(ArrPat arr) body)) =
do do
mapM_ (concretizeTypeOfXObj tenv) arr mapM_ (concretizeTypeOfXObj tenv env) arr
let envWithArgs = fromRight Env.empty (envWithFunctionArgs env arr) let envWithArgs = fromRight Env.empty (envWithFunctionArgs env arr)
allowAmbig = maybe True isTypeGeneric (xobjTy x) 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 vBody <- visit (getPath x : visited) allowAmbig Inside tenv (incrementEnvNestLevel envWithArgs) body
pure (c >> vBody >>= go) pure (c >> vBody >>= go)
where where
@ -152,7 +152,7 @@ visitDefn _ _ _ _ _ x = pure (Left (CannotConcretize x))
visitMain :: Visitor visitMain :: Visitor
visitMain visited _ Toplevel tenv env (ListPat (DefnPat defn name@(SymPat (SymPath [] "main") _) args@(ArrPat []) body)) = visitMain visited _ Toplevel tenv env (ListPat (DefnPat defn name@(SymPat (SymPath [] "main") _) args@(ArrPat []) body)) =
do do
c <- concretizeTypeOfXObj tenv body c <- concretizeTypeOfXObj tenv env body
vBody <- visit visited False Inside tenv env body vBody <- visit visited False Inside tenv env body
pure (c >> vBody >>= typeCheck) pure (c >> vBody >>= typeCheck)
where where
@ -184,7 +184,7 @@ visitLet visited allowAmbig level tenv env (ListPat (LetPat letExpr arr@(ArrPat
do do
bindings' <- fmap sequence (mapM (visit visited allowAmbig level tenv env) bindings) bindings' <- fmap sequence (mapM (visit visited allowAmbig level tenv env) bindings)
body' <- visit visited allowAmbig level tenv env body 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') pure (sequence c >> go bindings' body')
where where
go x' y = do go x' y = do
@ -205,9 +205,9 @@ visitThe _ _ _ _ _ x = pure (Left (CannotConcretize x))
visitMatch :: Visitor visitMatch :: Visitor
visitMatch visited allowAmbig level tenv env (ListPat (MatchPat match expr rest)) = visitMatch visited allowAmbig level tenv env (ListPat (MatchPat match expr rest)) =
do do
c <- concretizeTypeOfXObj tenv expr c <- concretizeTypeOfXObj tenv env expr
vExpr <- visit visited allowAmbig level 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)) vCases <- fmap sequence (mapM (visitMatchCase visited allowAmbig level tenv env) (pairwise rest))
pure (c >> go vExpr vCases) pure (c >> go vExpr vCases)
where where
@ -238,8 +238,8 @@ visitSetBang _ _ _ _ _ x = pure (Left (CannotConcretize x))
visitApp :: Visitor visitApp :: Visitor
visitApp visited allowAmbig level tenv env (ListPat (AppPat func args)) = visitApp visited allowAmbig level tenv env (ListPat (AppPat func args)) =
do do
c <- concretizeTypeOfXObj tenv func c <- concretizeTypeOfXObj tenv env func
cs <- fmap sequence $ mapM (concretizeTypeOfXObj tenv) args cs <- fmap sequence $ mapM (concretizeTypeOfXObj tenv env) args
vFunc <- visit visited allowAmbig level tenv env func vFunc <- visit visited allowAmbig level tenv env func
vArgs <- fmap sequence (mapM (visit visited allowAmbig level tenv env) args) vArgs <- fmap sequence (mapM (visit visited allowAmbig level tenv env) args)
pure (c >> cs >> liftA2 (:) vFunc vArgs) pure (c >> cs >> liftA2 (:) vFunc vArgs)
@ -267,7 +267,7 @@ mkLambda visited allowAmbig _ tenv env root@(ListPat (FnPat fn arr@(ArrPat args)
extendedArgs = extendedArgs =
if null capturedVars if null capturedVars
then arr 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 ( setObj
arr arr
@ -275,8 +275,8 @@ mkLambda visited allowAmbig _ tenv env root@(ListPat (FnPat fn arr@(ArrPat args)
( XObj ( XObj
(Sym (SymPath [] "_env") Symbol) (Sym (SymPath [] "_env") Symbol)
(Just dummyInfo) (Just dummyInfo)
(Just (PointerTy (StructTy (ConcreteNameTy tyPath) []))) (Just (PointerTy (StructTy (ConcreteNameTy tyPath) []))) :
: args args
) )
) )
) )
@ -338,7 +338,7 @@ mkLambda _ _ _ _ _ root = pure (Left (CannotConcretize root))
visitFn :: Visitor visitFn :: Visitor
visitFn visited allowAmbig level tenv env x@(ListPat (FnPat fn args@(ArrPat arr) body)) = visitFn visited allowAmbig level tenv env x@(ListPat (FnPat fn args@(ArrPat arr) body)) =
do do
mapM_ (concretizeTypeOfXObj tenv) arr mapM_ (concretizeTypeOfXObj tenv env) arr
let envWithArgs = fromRight Env.empty (envWithFunctionArgs env arr) let envWithArgs = fromRight Env.empty (envWithFunctionArgs env arr)
vBody <- visit visited allowAmbig Inside tenv (incrementEnvNestLevel envWithArgs) body 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 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? -- | 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 -> Env -> XObj -> State [XObj] (Either TypeError ())
concretizeTypeOfXObj typeEnv (XObj _ _ (Just ty)) = concretizeTypeOfXObj typeEnv env (XObj _ _ (Just ty)) =
either (pure . Left) success (concretizeType typeEnv ty) either (pure . Left) success (concretizeType typeEnv env ty)
where where
success :: [XObj] -> State [XObj] (Either TypeError ()) success :: [XObj] -> State [XObj] (Either TypeError ())
success xs = modify (xs ++) >> pure (Right ()) success xs = modify (xs ++) >> pure (Right ())
concretizeTypeOfXObj _ _ = pure (Right ()) concretizeTypeOfXObj _ _ _ = pure (Right ())
-- | Find all the concrete deps of a type. -- | Find all the concrete deps of a type.
concretizeType :: TypeEnv -> Ty -> Either TypeError [XObj] concretizeType :: TypeEnv -> Env -> Ty -> Either TypeError [XObj]
concretizeType _ ft@FuncTy {} = concretizeType _ _ ft@FuncTy {} =
if isTypeGeneric ft if isTypeGeneric ft
then Right [] then Right []
else Right [defineFunctionTypeAlias ft] else Right [defineFunctionTypeAlias ft]
concretizeType typeEnv arrayTy@(StructTy (ConcreteNameTy (SymPath [] "Array")) varTys) = concretizeType typeEnv env arrayTy@(StructTy (ConcreteNameTy (SymPath [] "Array")) varTys) =
if isTypeGeneric arrayTy if isTypeGeneric arrayTy
then Right [] then Right []
else do else do
deps <- mapM (concretizeType typeEnv) varTys deps <- mapM (concretizeType typeEnv env) varTys
Right (defineArrayTypeAlias arrayTy : concat deps) Right (defineArrayTypeAlias arrayTy : concat deps)
-- TODO: Remove ugly duplication of code here: -- 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 if isTypeGeneric arrayTy
then Right [] then Right []
else do else do
deps <- mapM (concretizeType typeEnv) varTys deps <- mapM (concretizeType typeEnv env) varTys
Right (defineStaticArrayTypeAlias arrayTy : concat deps) Right (defineStaticArrayTypeAlias arrayTy : concat deps)
concretizeType typeEnv genericStructTy@(StructTy (ConcreteNameTy (SymPath _ name)) _) = concretizeType typeEnv env genericStructTy@(StructTy (ConcreteNameTy path@(SymPath _ name)) _) =
-- TODO: This function only looks up direct children of the type environment. case (getTypeBinder typeEnv name) <> (findTypeBinder env path) of
-- However, spath can point to types that belong to a module. Pass the global env here.
case (getTypeBinder typeEnv name) of
Right (Binder _ x) -> go x Right (Binder _ x) -> go x
_ -> Right [] _ -> Right []
where where
go :: XObj -> Either TypeError [XObj] go :: XObj -> Either TypeError [XObj]
go (XObj (Lst (XObj (Deftype originalStructTy) _ _ : _ : rest)) _ _) = go (XObj (Lst (XObj (Deftype originalStructTy) _ _ : _ : rest)) _ _) =
if isTypeGeneric originalStructTy if isTypeGeneric originalStructTy
then instantiateGenericStructType typeEnv originalStructTy genericStructTy rest then instantiateGenericStructType typeEnv env originalStructTy genericStructTy rest
else Right [] else Right []
go (XObj (Lst (XObj (DefSumtype originalStructTy) _ _ : _ : rest)) _ _) = go (XObj (Lst (XObj (DefSumtype originalStructTy) _ _ : _ : rest)) _ _) =
if isTypeGeneric originalStructTy if isTypeGeneric originalStructTy
then instantiateGenericSumtype typeEnv originalStructTy genericStructTy rest then instantiateGenericSumtype typeEnv env originalStructTy genericStructTy rest
else Right [] else Right []
go (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _) = Right [] go (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _) = Right []
go x = error ("Non-deftype found in type env: " ++ pretty x) go x = error ("Non-deftype found in type env: " ++ pretty x)
concretizeType t (RefTy rt _) = concretizeType t e (RefTy rt _) =
concretizeType t rt concretizeType t e rt
concretizeType t (PointerTy pt) = concretizeType t e (PointerTy pt) =
concretizeType t pt concretizeType t e pt
concretizeType _ _ = concretizeType _ _ _ =
Right [] -- ignore all other types Right [] -- ignore all other types
-- | Renames the type variable literals in a sum type for temporary validation. -- | 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. -- | 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]) -- 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 -> Env -> Ty -> Ty -> [XObj] -> Either TypeError [XObj]
instantiateGenericStructType typeEnv originalStructTy@(StructTy _ _) genericStructTy membersXObjs = instantiateGenericStructType typeEnv env originalStructTy@(StructTy _ _) genericStructTy membersXObjs =
(replaceLeft (FailedToInstantiateGenericType originalStructTy) solution >>= go) (replaceLeft (FailedToInstantiateGenericType originalStructTy) solution >>= go)
where where
fake1 = XObj (Sym (SymPath [] "a") Symbol) Nothing Nothing fake1 = XObj (Sym (SymPath [] "a") Symbol) Nothing Nothing
@ -615,30 +613,30 @@ instantiateGenericStructType typeEnv originalStructTy@(StructTy _ _) genericStru
validMembers = replaceGenericTypeSymbolsOnMembers mappings' nameFixedMembers validMembers = replaceGenericTypeSymbolsOnMembers mappings' nameFixedMembers
concretelyTypedMembers = replaceGenericTypeSymbolsOnMembers mappings memberXObjs concretelyTypedMembers = replaceGenericTypeSymbolsOnMembers mappings memberXObjs
validateMembers AllowAnyTypeVariableNames typeEnv renamedOrig validMembers validateMembers AllowAnyTypeVariableNames typeEnv renamedOrig validMembers
deps <- mapM (depsForStructMemberPair typeEnv) (pairwise concretelyTypedMembers) deps <- mapM (depsForStructMemberPair typeEnv env) (pairwise concretelyTypedMembers)
let xobj = let xobj =
XObj XObj
( Lst ( Lst
( XObj (Deftype genericStructTy) Nothing Nothing ( XObj (Deftype genericStructTy) Nothing Nothing :
: XObj (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing XObj (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing :
: [XObj (Arr concretelyTypedMembers) Nothing Nothing] [XObj (Arr concretelyTypedMembers) Nothing Nothing]
) )
) )
(Just dummyInfo) (Just dummyInfo)
(Just TypeTy) (Just TypeTy) :
: concat deps concat deps
pure xobj pure xobj
instantiateGenericStructType _ t _ _ = Left (FailedToInstantiateGenericType t) instantiateGenericStructType _ _ t _ _ = Left (FailedToInstantiateGenericType t)
depsForStructMemberPair :: TypeEnv -> (XObj, XObj) -> Either TypeError [XObj] depsForStructMemberPair :: TypeEnv -> Env -> (XObj, XObj) -> Either TypeError [XObj]
depsForStructMemberPair typeEnv (_, tyXObj) = depsForStructMemberPair typeEnv env (_, tyXObj) =
maybe (Left (NotAType tyXObj)) (concretizeType typeEnv) (xobjToTy 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. -- | 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)) -- Turn (deftype (Maybe a) (Just a) (Nothing)) into (deftype (Maybe Int) (Just Int) (Nothing))
instantiateGenericSumtype :: TypeEnv -> Ty -> Ty -> [XObj] -> Either TypeError [XObj] instantiateGenericSumtype :: TypeEnv -> Env -> Ty -> Ty -> [XObj] -> Either TypeError [XObj]
instantiateGenericSumtype typeEnv originalStructTy@(StructTy _ originalTyVars) genericStructTy cases = instantiateGenericSumtype typeEnv env originalStructTy@(StructTy _ originalTyVars) genericStructTy cases =
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
@ -647,7 +645,7 @@ instantiateGenericSumtype typeEnv originalStructTy@(StructTy _ originalTyVars) g
Right mappings -> Right mappings ->
let nameFixedCases = map (renameGenericTypeSymbolsOnSum (zip originalTyVars renamedOrig)) cases let nameFixedCases = map (renameGenericTypeSymbolsOnSum (zip originalTyVars renamedOrig)) cases
concretelyTypedCases = map (replaceGenericTypeSymbolsOnCase mappings) nameFixedCases 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. in case toCases typeEnv AllowAnyTypeVariableNames renamedOrig concretelyTypedCases of -- Don't care about the cases, this is done just for validation.
Left err -> Left err Left err -> Left err
Right _ -> Right _ ->
@ -656,28 +654,28 @@ 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"
-- Resolves dependencies for sumtype cases. -- Resolves dependencies for sumtype cases.
-- NOTE: This function only accepts cases that are in "canonical form" -- NOTE: This function only accepts cases that are in "canonical form"
-- (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 -> Env -> XObj -> Either TypeError [XObj]
depsForCase typeEnv (XObj (Lst [_, XObj (Arr members) _ _]) _ _) = depsForCase typeEnv env (XObj (Lst [_, XObj (Arr members) _ _]) _ _) =
concat concat
<$> mapM <$> mapM
(\t -> maybe (Left (NotAType t)) (concretizeType typeEnv) (xobjToTy t)) (\t -> maybe (Left (NotAType t)) (concretizeType typeEnv env) (xobjToTy t))
members members
depsForCase _ x = Left (InvalidSumtypeCase x) depsForCase _ _ x = Left (InvalidSumtypeCase x)
replaceGenericTypeSymbolsOnMembers :: Map.Map String Ty -> [XObj] -> [XObj] replaceGenericTypeSymbolsOnMembers :: Map.Map String Ty -> [XObj] -> [XObj]
replaceGenericTypeSymbolsOnMembers mappings memberXObjs = replaceGenericTypeSymbolsOnMembers mappings memberXObjs =

4
src/Deftype.hs
View File

@ -382,7 +382,7 @@ genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameT
t = FuncTy (map snd (memberXObjsToPairs membersXObjs)) originalStructTy StaticLifetimeTy t = FuncTy (map snd (memberXObjsToPairs membersXObjs)) originalStructTy StaticLifetimeTy
docs = "creates a `" ++ show originalStructTy ++ "`." docs = "creates a `" ++ show originalStructTy ++ "`."
templateCreator = TemplateCreator $ templateCreator = TemplateCreator $
\typeEnv _ -> \typeEnv env ->
Template Template
(FuncTy (map snd (memberXObjsToPairs membersXObjs)) (VarTy "p") StaticLifetimeTy) (FuncTy (map snd (memberXObjsToPairs membersXObjs)) (VarTy "p") StaticLifetimeTy)
( \(FuncTy _ concreteStructTy _) -> ( \(FuncTy _ concreteStructTy _) ->
@ -397,7 +397,7 @@ genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameT
in tokensForInit allocationMode (show originalStructTy) correctedMembers in tokensForInit allocationMode (show originalStructTy) correctedMembers
) )
( \(FuncTy _ concreteStructTy _) -> ( \(FuncTy _ concreteStructTy _) ->
case concretizeType typeEnv concreteStructTy of case concretizeType typeEnv env concreteStructTy of
Left _ -> [] Left _ -> []
Right ok -> ok Right ok -> ok
) )

11
src/Emit.hs
View File

@ -926,6 +926,7 @@ toDeclaration (Binder meta xobj@(XObj (Lst xobjs) _ ty)) =
XObj (Primitive _) _ _ : _ -> XObj (Primitive _) _ _ : _ ->
"" ""
_ -> error ("Internal compiler error: Can't emit other kinds of definitions: " ++ show xobj) _ -> 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." toDeclaration _ = error "Missing case."
paramListToC :: [XObj] -> String paramListToC :: [XObj] -> String
@ -1006,7 +1007,7 @@ globalsToC globalEnv =
typeEnvToDeclarations :: TypeEnv -> Env -> Either ToCError String typeEnvToDeclarations :: TypeEnv -> Env -> Either ToCError String
typeEnvToDeclarations typeEnv global = typeEnvToDeclarations typeEnv global =
let -- We need to carry the type environment to pass the correct environment on the binderToDeclaration call. 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) bindersWithScore = (addEnvToScore typeEnv)
mods = (findModules global) mods = (findModules global)
folder = folder =
@ -1027,7 +1028,7 @@ typeEnvToDeclarations typeEnv global =
envToDeclarations :: TypeEnv -> Env -> Either ToCError String envToDeclarations :: TypeEnv -> Env -> Either ToCError String
envToDeclarations typeEnv env = 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 in do
okDecls <- okDecls <-
mapM mapM
@ -1042,10 +1043,10 @@ envToDeclarations typeEnv env =
-- debugScorePair :: (Int, Binder) -> (Int, Binder) -- debugScorePair :: (Int, Binder) -> (Int, Binder)
-- debugScorePair (s,b) = trace ("Scored binder: " ++ show b ++ ", score: " ++ show s) (s,b) -- debugScorePair (s,b) = trace ("Scored binder: " ++ show b ++ ", score: " ++ show s) (s,b)
sortDeclarationBinders :: TypeEnv -> [Binder] -> [(Int, Binder)] sortDeclarationBinders :: TypeEnv -> Env -> [Binder] -> [(Int, Binder)]
sortDeclarationBinders typeEnv binders' = sortDeclarationBinders typeEnv env binders' =
--trace ("\nSORTED: " ++ (show (sortOn fst (map (scoreBinder typeEnv) 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 :: Env -> [Binder] -> [(Int, Binder)]
sortGlobalVariableBinders globalEnv binders' = sortGlobalVariableBinders globalEnv binders' =

8
src/Env.hs
View File

@ -292,7 +292,13 @@ getTypeBinder = getBinder
-- --
-- Restricts the final step of a search to binders in a module's *type* environment. -- 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 :: 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 :: Environment e => e -> SymPath -> Either EnvironmentError Binder
findTypeBinder e path = fmap snd (findType e path) findTypeBinder e path = fmap snd (findType e path)

4
src/Obj.hs
View File

@ -228,6 +228,10 @@ isTypeDef (XObj (Lst (XObj (Deftype _) _ _ : _)) _ _) = True
isTypeDef (XObj (Lst (XObj (DefSumtype _) _ _ : _)) _ _) = True isTypeDef (XObj (Lst (XObj (DefSumtype _) _ _ : _)) _ _) = True
isTypeDef _ = False isTypeDef _ = False
isType :: XObj -> Bool
isType (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _) = True
isType x = isTypeDef x
isMod :: XObj -> Bool isMod :: XObj -> Bool
isMod (XObj (Mod _ _) _ _) = True isMod (XObj (Mod _ _) _ _) = True
isMod _ = False isMod _ = False

14
src/Scoring.hs
View File

@ -10,8 +10,8 @@ import TypesToC
-- | Scoring of types. -- | Scoring of types.
-- | The score is used for sorting the bindings before emitting them. -- | The score is used for sorting the bindings before emitting them.
-- | A lower score means appearing earlier in the emitted file. -- | A lower score means appearing earlier in the emitted file.
scoreTypeBinder :: TypeEnv -> Binder -> (Int, Binder) scoreTypeBinder :: TypeEnv -> Env -> Binder -> (Int, Binder)
scoreTypeBinder typeEnv b@(Binder _ (XObj (Lst (XObj x _ _ : XObj (Sym _ _) _ _ : _)) _ _)) = scoreTypeBinder typeEnv env b@(Binder _ (XObj (Lst (XObj x _ _ : XObj (Sym _ _) _ _ : _)) _ _)) =
case x of case x of
Defalias aliasedType -> Defalias aliasedType ->
let selfName = "" let selfName = ""
@ -24,14 +24,16 @@ scoreTypeBinder typeEnv b@(Binder _ (XObj (Lst (XObj x _ _ : XObj (Sym _ _) _ _
ExternalType _ -> (0, b) ExternalType _ -> (0, b)
_ -> (500, b) _ -> (500, b)
where where
depthOfStruct (StructTy (ConcreteNameTy (SymPath _ name)) varTys) = depthOfStruct (StructTy (ConcreteNameTy path@(SymPath _ name)) varTys) =
case E.getTypeBinder typeEnv name of case E.getTypeBinder typeEnv name <> findTypeBinder env path of
Right (Binder _ typedef) -> (depthOfDeftype typeEnv Set.empty typedef varTys + 1, b) 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) Left e -> error (show e)
depthOfStruct _ = error "depthofstruct" depthOfStruct _ = error "depthofstruct"
scoreTypeBinder _ b@(Binder _ (XObj (Mod _ _) _ _)) = scoreTypeBinder _ _ b@(Binder _ (XObj (Mod _ _) _ _)) =
(1000, b) (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 -> Set.Set Ty -> XObj -> [Ty] -> Int
depthOfDeftype typeEnv visited (XObj (Lst (_ : XObj (Sym (SymPath path selfName) _) _ _ : rest)) _ _) varTys = depthOfDeftype typeEnv visited (XObj (Lst (_ : XObj (Sym (SymPath path selfName) _) _ _ : rest)) _ _) varTys =

10
src/Sumtypes.hs
View File

@ -61,13 +61,13 @@ moduleForSumtype innerEnv typeEnv env pathStrings typeName typeVariables rest i
(okPrn, _) <- binderForStrOrPrn typeEnv env insidePath structTy cases "prn" (okPrn, _) <- binderForStrOrPrn typeEnv env insidePath structTy cases "prn"
okDelete <- binderForDelete typeEnv env insidePath structTy cases okDelete <- binderForDelete typeEnv env insidePath structTy cases
(okCopy, okCopyDeps) <- binderForCopy 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]) let moduleEnvWithBindings = addListOfBindings moduleValueEnv (okIniters ++ [okStr, okPrn, okDelete, okCopy, okTag])
typeModuleXObj = XObj (Mod moduleEnvWithBindings moduleTypeEnv) i (Just ModuleTy) typeModuleXObj = XObj (Mod moduleEnvWithBindings moduleTypeEnv) i (Just ModuleTy)
pure (typeName, typeModuleXObj, okMemberDeps ++ okCopyDeps ++ okStrDeps) pure (typeName, typeModuleXObj, okMemberDeps ++ okCopyDeps ++ okStrDeps)
memberDeps :: TypeEnv -> [SumtypeCase] -> Either TypeError [XObj] memberDeps :: TypeEnv -> Env -> [SumtypeCase] -> Either TypeError [XObj]
memberDeps typeEnv cases = fmap concat (mapM (concretizeType typeEnv) (concatMap caseTys cases)) memberDeps typeEnv env cases = fmap concat (mapM (concretizeType typeEnv env) (concatMap caseTys cases))
replaceGenericTypesOnCases :: TypeMappings -> [SumtypeCase] -> [SumtypeCase] replaceGenericTypesOnCases :: TypeMappings -> [SumtypeCase] -> [SumtypeCase]
replaceGenericTypesOnCases mappings = map replaceOnCase replaceGenericTypesOnCases mappings = map replaceOnCase
@ -110,7 +110,7 @@ genericCaseInit allocationMode pathStrings originalStructTy sumtypeCase =
t = FuncTy (caseTys sumtypeCase) originalStructTy StaticLifetimeTy t = FuncTy (caseTys sumtypeCase) originalStructTy StaticLifetimeTy
docs = "creates a `" ++ caseName sumtypeCase ++ "`." docs = "creates a `" ++ caseName sumtypeCase ++ "`."
templateCreator = TemplateCreator $ templateCreator = TemplateCreator $
\typeEnv _ -> \typeEnv env ->
Template Template
(FuncTy (caseTys sumtypeCase) (VarTy "p") StaticLifetimeTy) (FuncTy (caseTys sumtypeCase) (VarTy "p") StaticLifetimeTy)
( \(FuncTy _ concreteStructTy _) -> ( \(FuncTy _ concreteStructTy _) ->
@ -124,7 +124,7 @@ genericCaseInit allocationMode pathStrings originalStructTy sumtypeCase =
in tokensForCaseInit allocationMode concreteStructTy (sumtypeCase {caseTys = correctedTys}) in tokensForCaseInit allocationMode concreteStructTy (sumtypeCase {caseTys = correctedTys})
) )
( \(FuncTy _ concreteStructTy _) -> ( \(FuncTy _ concreteStructTy _) ->
case concretizeType typeEnv concreteStructTy of case concretizeType typeEnv env concreteStructTy of
Left _ -> [] Left _ -> []
Right ok -> ok Right ok -> ok
) )

26
test/regression.carp
View File

@ -80,6 +80,18 @@
(deftype (HitRecord a) [t a]) (deftype (HitRecord a) [t a])
(deftype (CurrentHit a) [hr (Maybe (HitRecord 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 (deftest test
(assert-equal test (assert-equal test
1 1
@ -126,4 +138,18 @@
1 1
(dynamic-closure-referring-to-itself-test) (dynamic-closure-referring-to-itself-test)
"test that dynamic closure can refer to itself") "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")
) )