carp-lang/Carp
1
1
Fork 0
mirror of https://github.com/carp-lang/Carp.git synced 2024-09-11 05:25:28 +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.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 =

4
src/Deftype.hs
View File

@ -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
View File

@ -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' =

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.
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)

4
src/Obj.hs
View File

@ -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

14
src/Scoring.hs
View File

@ -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 =

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"
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
)

26
test/regression.carp
View File

@ -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")
)