mirror of
https://github.com/carp-lang/Carp.git
synced 2024-10-05 17:47:30 +03:00
chore: apply code formatting
This commit is contained in:
Erik Svedäng
parent
d82e8a5a3f
commit
11239f1c8b
@ -23,54 +23,66 @@ boxTy = StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")]
|
||||
|
||||
-- | Defines a template for initializing Boxes.
|
||||
init :: (String, Binder)
|
||||
init = let path = SymPath ["Box"] "init"
|
||||
t = FuncTy [(VarTy "t")] boxTy StaticLifetimeTy
|
||||
docs = "Initializes a box pointing to value t."
|
||||
decl = templateLiteral "$t* $NAME ($t t)"
|
||||
body = const (multilineTemplate
|
||||
[ "$DECL {",
|
||||
" $t* instance;",
|
||||
" instance = CARP_MALLOC(sizeof($t));",
|
||||
" *instance = t;",
|
||||
" return instance;",
|
||||
"}"
|
||||
])
|
||||
deps = const []
|
||||
template = TemplateCreator $ \_ _ -> Template t decl body deps
|
||||
in defineTypeParameterizedTemplate template path t docs
|
||||
init =
|
||||
let path = SymPath ["Box"] "init"
|
||||
t = FuncTy [(VarTy "t")] boxTy StaticLifetimeTy
|
||||
docs = "Initializes a box pointing to value t."
|
||||
decl = templateLiteral "$t* $NAME ($t t)"
|
||||
body =
|
||||
const
|
||||
( multilineTemplate
|
||||
[ "$DECL {",
|
||||
" $t* instance;",
|
||||
" instance = CARP_MALLOC(sizeof($t));",
|
||||
" *instance = t;",
|
||||
" return instance;",
|
||||
"}"
|
||||
]
|
||||
)
|
||||
deps = const []
|
||||
template = TemplateCreator $ \_ _ -> Template t decl body deps
|
||||
in defineTypeParameterizedTemplate template path t docs
|
||||
|
||||
-- | Defines a template for converting a boxed value to a local value.
|
||||
unbox :: (String, Binder)
|
||||
unbox = let path = SymPath ["Box"] "unbox"
|
||||
t = FuncTy [(StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")])] (VarTy "t") StaticLifetimeTy
|
||||
docs = "Converts a boxed value to a reference to the value and delete the box."
|
||||
decl = templateLiteral "$t $NAME($t* box)"
|
||||
body = const (multilineTemplate
|
||||
[ "$DECL {",
|
||||
" $t local;",
|
||||
" local = *box;",
|
||||
" CARP_FREE(box);",
|
||||
" return local;",
|
||||
"}"
|
||||
])
|
||||
deps = const []
|
||||
template = TemplateCreator $ \_ _ -> Template t decl body deps
|
||||
in defineTypeParameterizedTemplate template path t docs
|
||||
unbox =
|
||||
let path = SymPath ["Box"] "unbox"
|
||||
t = FuncTy [(StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")])] (VarTy "t") StaticLifetimeTy
|
||||
docs = "Converts a boxed value to a reference to the value and delete the box."
|
||||
decl = templateLiteral "$t $NAME($t* box)"
|
||||
body =
|
||||
const
|
||||
( multilineTemplate
|
||||
[ "$DECL {",
|
||||
" $t local;",
|
||||
" local = *box;",
|
||||
" CARP_FREE(box);",
|
||||
" return local;",
|
||||
"}"
|
||||
]
|
||||
)
|
||||
deps = const []
|
||||
template = TemplateCreator $ \_ _ -> Template t decl body deps
|
||||
in defineTypeParameterizedTemplate template path t docs
|
||||
|
||||
-- | Defines a template for getting a reference to the value stored in a box without performing an additional allocation.
|
||||
peek :: (String, Binder)
|
||||
peek = let path = SymPath ["Box"] "peek"
|
||||
t = FuncTy [(RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")]) (VarTy "q"))] (RefTy (VarTy "t") (VarTy "q")) StaticLifetimeTy
|
||||
docs = "Returns a reference to the value stored in a box without performing an additional allocation."
|
||||
decl = templateLiteral "$t* $NAME($t** box_ref)"
|
||||
body = const (multilineTemplate
|
||||
[ "$DECL {",
|
||||
" return *box_ref;",
|
||||
"}"
|
||||
])
|
||||
deps = const []
|
||||
template = TemplateCreator $ \_ _ -> Template t decl body deps
|
||||
in defineTypeParameterizedTemplate template path t docs
|
||||
peek =
|
||||
let path = SymPath ["Box"] "peek"
|
||||
t = FuncTy [(RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")]) (VarTy "q"))] (RefTy (VarTy "t") (VarTy "q")) StaticLifetimeTy
|
||||
docs = "Returns a reference to the value stored in a box without performing an additional allocation."
|
||||
decl = templateLiteral "$t* $NAME($t** box_ref)"
|
||||
body =
|
||||
const
|
||||
( multilineTemplate
|
||||
[ "$DECL {",
|
||||
" return *box_ref;",
|
||||
"}"
|
||||
]
|
||||
)
|
||||
deps = const []
|
||||
template = TemplateCreator $ \_ _ -> Template t decl body deps
|
||||
in defineTypeParameterizedTemplate template path t docs
|
||||
|
||||
-- | Defines a template for copying a box. The copy will also be heap allocated.
|
||||
copy :: (String, Binder)
|
||||
@ -142,7 +154,7 @@ delete =
|
||||
innerDelete tenv env (StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) =
|
||||
case findFunctionForMember tenv env "delete" (typesDeleterFunctionType inner) ("Inside box.", inner) of
|
||||
FunctionFound functionFullName ->
|
||||
" " ++ functionFullName ++ "(*box);\n"
|
||||
" " ++ functionFullName ++ "(*box);\n"
|
||||
++ " CARP_FREE(box);"
|
||||
FunctionNotFound msg -> error msg
|
||||
FunctionIgnored ->
|
||||
@ -234,4 +246,3 @@ innerStr tenv env (StructTy _ [t]) =
|
||||
]
|
||||
FunctionIgnored -> " /* Ignore type inside Box: '" ++ show t ++ "' ??? */\n"
|
||||
innerStr _ _ _ = ""
|
||||
|
||||
|
||||
@ -43,6 +43,7 @@ import Polymorphism
|
||||
import Reify
|
||||
import qualified Set
|
||||
import ToTemplate
|
||||
import qualified TypeCandidate as TC
|
||||
import TypeError
|
||||
import TypePredicates
|
||||
import Types
|
||||
@ -50,7 +51,6 @@ import TypesToC
|
||||
import Util
|
||||
import Validate
|
||||
import Prelude hiding (lookup)
|
||||
import qualified TypeCandidate as TC
|
||||
|
||||
data Level = Toplevel | Inside
|
||||
|
||||
@ -645,22 +645,25 @@ instantiateGenericSumtype typeEnv env originalStructTy@(StructTy _ originalTyVar
|
||||
rename@(StructTy _ renamedOrig) = evalState (renameVarTys originalStructTy) 0
|
||||
nameFixedCases = map (renameGenericTypeSymbolsOnSum (zip originalTyVars renamedOrig)) cases
|
||||
fixLeft l = replaceLeft (FailedToInstantiateGenericType originalStructTy) l
|
||||
in do mappings <- fixLeft $ solve [Constraint rename genericStructTy fake1 fake2 fake1 OrdMultiSym]
|
||||
let concretelyTypedCases = map (replaceGenericTypeSymbolsOnCase mappings) nameFixedCases
|
||||
sname = (getStructName originalStructTy)
|
||||
deps <- mapM (depsForCase typeEnv env) concretelyTypedCases
|
||||
candidate <- TC.mkSumtypeCandidate sname renamedOrig typeEnv env concretelyTypedCases (getPathFromStructName sname)
|
||||
validateType (TC.setRestriction candidate TC.AllowAny)
|
||||
pure (XObj
|
||||
( Lst
|
||||
( XObj (DefSumtype genericStructTy) Nothing Nothing :
|
||||
XObj (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing :
|
||||
concretelyTypedCases
|
||||
)
|
||||
)
|
||||
(Just dummyInfo)
|
||||
(Just TypeTy) :
|
||||
concat deps)
|
||||
in do
|
||||
mappings <- fixLeft $ solve [Constraint rename genericStructTy fake1 fake2 fake1 OrdMultiSym]
|
||||
let concretelyTypedCases = map (replaceGenericTypeSymbolsOnCase mappings) nameFixedCases
|
||||
sname = (getStructName originalStructTy)
|
||||
deps <- mapM (depsForCase typeEnv env) concretelyTypedCases
|
||||
candidate <- TC.mkSumtypeCandidate sname renamedOrig typeEnv env concretelyTypedCases (getPathFromStructName sname)
|
||||
validateType (TC.setRestriction candidate TC.AllowAny)
|
||||
pure
|
||||
( XObj
|
||||
( Lst
|
||||
( XObj (DefSumtype genericStructTy) Nothing Nothing :
|
||||
XObj (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing :
|
||||
concretelyTypedCases
|
||||
)
|
||||
)
|
||||
(Just dummyInfo)
|
||||
(Just TypeTy) :
|
||||
concat deps
|
||||
)
|
||||
instantiateGenericSumtype _ _ _ _ _ = error "instantiategenericsumtype"
|
||||
|
||||
-- Resolves dependencies for sumtype cases.
|
||||
@ -678,8 +681,9 @@ depsForCase _ _ x = Left (InvalidSumtypeCase x)
|
||||
-- | Replace instances of generic types in type candidate field definitions.
|
||||
replaceGenericTypeSymbolsOnFields :: Map.Map String Ty -> [TC.TypeField] -> [TC.TypeField]
|
||||
replaceGenericTypeSymbolsOnFields ms fields = map go fields
|
||||
where go (TC.StructField name t) = (TC.StructField name (replaceTyVars ms t))
|
||||
go (TC.SumField name ts) = (TC.SumField name (map (replaceTyVars ms) ts))
|
||||
where
|
||||
go (TC.StructField name t) = (TC.StructField name (replaceTyVars ms t))
|
||||
go (TC.SumField name ts) = (TC.SumField name (map (replaceTyVars ms) ts))
|
||||
|
||||
replaceGenericTypeSymbolsOnMembers :: Map.Map String Ty -> [XObj] -> [XObj]
|
||||
replaceGenericTypeSymbolsOnMembers mappings memberXObjs =
|
||||
|
||||
552
src/Deftype.hs
552
src/Deftype.hs
@ -18,15 +18,15 @@ import Managed
|
||||
import Obj
|
||||
import StructUtils
|
||||
import Template
|
||||
import TemplateGenerator as TG
|
||||
import ToTemplate
|
||||
import qualified TypeCandidate as TC
|
||||
import TypeError
|
||||
import TypePredicates
|
||||
import Types
|
||||
import TypesToC
|
||||
import Util
|
||||
import Validate
|
||||
import qualified TypeCandidate as TC
|
||||
import TemplateGenerator as TG
|
||||
|
||||
{-# ANN module "HLint: ignore Reduce duplication" #-}
|
||||
|
||||
@ -60,15 +60,15 @@ moduleForDeftype innerEnv typeEnv env pathStrings typeName typeVariables rest i
|
||||
let moduleValueEnv = fromMaybe (new innerEnv (Just typeName)) (fmap fst existingEnv)
|
||||
moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv)
|
||||
initmembers = case rest of
|
||||
-- ANSI C does not allow empty structs. We add a dummy member here to account for this.
|
||||
-- Note that we *don't* add this member for external types--we leave those definitions up to the user.
|
||||
-- The corresponding field is emitted for the struct definition in Emit.hs
|
||||
[(XObj (Arr []) ii t)] -> [(XObj (Arr [(XObj (Sym (SymPath [] "__dummy") Symbol) Nothing Nothing), (XObj (Sym (SymPath [] "Char") Symbol) Nothing Nothing)]) ii t)]
|
||||
_ -> rest
|
||||
-- ANSI C does not allow empty structs. We add a dummy member here to account for this.
|
||||
-- Note that we *don't* add this member for external types--we leave those definitions up to the user.
|
||||
-- The corresponding field is emitted for the struct definition in Emit.hs
|
||||
[(XObj (Arr []) ii t)] -> [(XObj (Arr [(XObj (Sym (SymPath [] "__dummy") Symbol) Nothing Nothing), (XObj (Sym (SymPath [] "Char") Symbol) Nothing Nothing)]) ii t)]
|
||||
_ -> rest
|
||||
in do
|
||||
let mems = case initmembers of
|
||||
[(XObj (Arr ms)_ _)] -> ms
|
||||
_ -> []
|
||||
[(XObj (Arr ms) _ _)] -> ms
|
||||
_ -> []
|
||||
-- Check that this is a valid type definition.
|
||||
candidate <- TC.mkStructCandidate typeName typeVariables typeEnv env mems pathStrings
|
||||
validateType candidate
|
||||
@ -88,8 +88,8 @@ bindingsForRegisteredType typeEnv env pathStrings typeName rest i existingEnv =
|
||||
moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv)
|
||||
in do
|
||||
let mems = case rest of
|
||||
[(XObj (Arr ms)_ _)] -> ms
|
||||
_ -> []
|
||||
[(XObj (Arr ms) _ _)] -> ms
|
||||
_ -> []
|
||||
-- Check that this is a valid type definition.
|
||||
candidate <- TC.mkStructCandidate typeName [] typeEnv env mems pathStrings
|
||||
validateType candidate
|
||||
@ -109,14 +109,17 @@ bindingsForRegisteredType typeEnv env pathStrings typeName rest i existingEnv =
|
||||
-- | Generate the standard set of functions for a new type.
|
||||
generateTypeBindings :: TC.TypeCandidate -> Either TypeError ([(String, Binder)], [XObj])
|
||||
generateTypeBindings candidate =
|
||||
do (okMembers, membersDeps) <- templatesForMembers candidate
|
||||
okInit <- binderForInit candidate
|
||||
(okStr, strDeps) <- binderForStrOrPrn "str" candidate
|
||||
(okPrn, _) <- binderForStrOrPrn "prn" candidate
|
||||
(okDelete, deleteDeps) <- binderForDelete candidate
|
||||
(okCopy, copyDeps) <- binderForCopy candidate
|
||||
pure ((okInit : okStr : okPrn : okDelete : okCopy : okMembers),
|
||||
(deleteDeps ++ membersDeps ++ copyDeps ++ strDeps))
|
||||
do
|
||||
(okMembers, membersDeps) <- templatesForMembers candidate
|
||||
okInit <- binderForInit candidate
|
||||
(okStr, strDeps) <- binderForStrOrPrn "str" candidate
|
||||
(okPrn, _) <- binderForStrOrPrn "prn" candidate
|
||||
(okDelete, deleteDeps) <- binderForDelete candidate
|
||||
(okCopy, copyDeps) <- binderForCopy candidate
|
||||
pure
|
||||
( (okInit : okStr : okPrn : okDelete : okCopy : okMembers),
|
||||
(deleteDeps ++ membersDeps ++ copyDeps ++ strDeps)
|
||||
)
|
||||
|
||||
-- | Generate all the templates for ALL the member variables in a deftype declaration.
|
||||
templatesForMembers :: TC.TypeCandidate -> Either TypeError ([(String, Binder)], [XObj])
|
||||
@ -155,38 +158,42 @@ templatesForSingleMember candidate field@(TC.StructField _ t) =
|
||||
]
|
||||
|
||||
getter :: Ty -> ((String, Binder), [XObj])
|
||||
getter sig = let doc = "gets the `" ++ (TC.fieldName field) ++ "` property of a `" ++ (TC.getName candidate) ++ "`."
|
||||
binderT = sig
|
||||
binderP = SymPath (TC.getFullPath candidate) (TC.fieldName field)
|
||||
temp = TG.generateConcreteFieldTemplate candidate field getterGenerator
|
||||
in instanceBinderWithDeps binderP binderT temp doc
|
||||
getter sig =
|
||||
let doc = "gets the `" ++ (TC.fieldName field) ++ "` property of a `" ++ (TC.getName candidate) ++ "`."
|
||||
binderT = sig
|
||||
binderP = SymPath (TC.getFullPath candidate) (TC.fieldName field)
|
||||
temp = TG.generateConcreteFieldTemplate candidate field getterGenerator
|
||||
in instanceBinderWithDeps binderP binderT temp doc
|
||||
|
||||
setter :: Ty -> ((String, Binder), [XObj])
|
||||
setter sig = let doc = "sets the `" ++ (TC.fieldName field) ++ "` property of a `" ++ (TC.getName candidate) ++ "`."
|
||||
binderT = sig
|
||||
binderP = SymPath (TC.getFullPath candidate) ("set-" ++ (TC.fieldName field))
|
||||
concrete = (TG.generateConcreteFieldTemplate candidate field setterGenerator)
|
||||
generic = (TG.generateGenericFieldTemplate candidate field setterGenerator)
|
||||
in if isTypeGeneric t
|
||||
then (defineTypeParameterizedTemplate generic binderP binderT doc, [])
|
||||
else instanceBinderWithDeps binderP binderT concrete doc
|
||||
setter sig =
|
||||
let doc = "sets the `" ++ (TC.fieldName field) ++ "` property of a `" ++ (TC.getName candidate) ++ "`."
|
||||
binderT = sig
|
||||
binderP = SymPath (TC.getFullPath candidate) ("set-" ++ (TC.fieldName field))
|
||||
concrete = (TG.generateConcreteFieldTemplate candidate field setterGenerator)
|
||||
generic = (TG.generateGenericFieldTemplate candidate field setterGenerator)
|
||||
in if isTypeGeneric t
|
||||
then (defineTypeParameterizedTemplate generic binderP binderT doc, [])
|
||||
else instanceBinderWithDeps binderP binderT concrete doc
|
||||
|
||||
mutator :: Ty -> ((String, Binder), [XObj])
|
||||
mutator sig = let doc = "sets the `" ++ (TC.fieldName field) ++ "` property of a `" ++ (TC.getName candidate) ++ "` in place."
|
||||
binderT = sig
|
||||
binderP = SymPath (TC.getFullPath candidate) ("set-" ++ (TC.fieldName field) ++ "!")
|
||||
concrete = (TG.generateConcreteFieldTemplate candidate field mutatorGenerator)
|
||||
generic = (TG.generateGenericFieldTemplate candidate field mutatorGenerator)
|
||||
in if isTypeGeneric t
|
||||
then (defineTypeParameterizedTemplate generic binderP binderT doc, [])
|
||||
else instanceBinderWithDeps binderP binderT concrete doc
|
||||
mutator sig =
|
||||
let doc = "sets the `" ++ (TC.fieldName field) ++ "` property of a `" ++ (TC.getName candidate) ++ "` in place."
|
||||
binderT = sig
|
||||
binderP = SymPath (TC.getFullPath candidate) ("set-" ++ (TC.fieldName field) ++ "!")
|
||||
concrete = (TG.generateConcreteFieldTemplate candidate field mutatorGenerator)
|
||||
generic = (TG.generateGenericFieldTemplate candidate field mutatorGenerator)
|
||||
in if isTypeGeneric t
|
||||
then (defineTypeParameterizedTemplate generic binderP binderT doc, [])
|
||||
else instanceBinderWithDeps binderP binderT concrete doc
|
||||
|
||||
updater :: Ty -> ((String, Binder), [XObj])
|
||||
updater sig = let doc = "updates the `" ++ memberName ++ "` property of a `" ++ show p ++ "` using a function `f`."
|
||||
binderT = sig
|
||||
binderP = SymPath (TC.getFullPath candidate) ("update-" ++ (TC.fieldName field))
|
||||
temp = TG.generateConcreteFieldTemplate candidate field updateGenerator
|
||||
in instanceBinderWithDeps binderP binderT temp doc
|
||||
updater sig =
|
||||
let doc = "updates the `" ++ memberName ++ "` property of a `" ++ show p ++ "` using a function `f`."
|
||||
binderT = sig
|
||||
binderP = SymPath (TC.getFullPath candidate) ("update-" ++ (TC.fieldName field))
|
||||
temp = TG.generateConcreteFieldTemplate candidate field updateGenerator
|
||||
in instanceBinderWithDeps binderP binderT temp doc
|
||||
templatesForSingleMember _ _ = error "templatesforsinglemember"
|
||||
|
||||
-- | Helper function to create the binder for the 'init' template.
|
||||
@ -194,7 +201,7 @@ binderForInit :: TC.TypeCandidate -> Either TypeError (String, Binder)
|
||||
binderForInit candidate =
|
||||
-- Remove the __dummy field from the members array to ensure we can call the initializer with no arguments.
|
||||
-- See the implementation of moduleForDeftype for more details.
|
||||
let nodummy = remove ((=="__dummy") . TC.fieldName) (TC.getFields candidate)
|
||||
let nodummy = remove ((== "__dummy") . TC.fieldName) (TC.getFields candidate)
|
||||
doc = "creates a `" ++ (TC.getName candidate) ++ "`."
|
||||
binderP = (SymPath (TC.getFullPath candidate) "init")
|
||||
binderT = (FuncTy (concatMap TC.fieldTypes nodummy) (TC.toType candidate) StaticLifetimeTy)
|
||||
@ -248,19 +255,19 @@ getterGenerator = TG.mkTemplateGenerator tgen decl body deps
|
||||
tgen _ = (FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "t") StaticLifetimeTy)
|
||||
|
||||
decl :: TG.TokenGenerator TC.TypeField
|
||||
decl TG.GeneratorArg{instanceT=UnitTy} = toTemplate "void $NAME($(Ref p) p)"
|
||||
decl TG.GeneratorArg {instanceT = UnitTy} = toTemplate "void $NAME($(Ref p) p)"
|
||||
decl _ = toTemplate "$t $NAME($(Ref p) p)"
|
||||
|
||||
body :: TG.TokenGenerator TC.TypeField
|
||||
body TG.GeneratorArg{value=(TC.StructField _ UnitTy)} = toTemplate "$DECL { return; }\n"
|
||||
body TG.GeneratorArg{instanceT=(FuncTy _ (RefTy UnitTy _) _)} = toTemplate " $DECL { void* ptr = NULL; return ptr; }\n"
|
||||
body TG.GeneratorArg{value=(TC.StructField name ty)} =
|
||||
body TG.GeneratorArg {value = (TC.StructField _ UnitTy)} = toTemplate "$DECL { return; }\n"
|
||||
body TG.GeneratorArg {instanceT = (FuncTy _ (RefTy UnitTy _) _)} = toTemplate " $DECL { void* ptr = NULL; return ptr; }\n"
|
||||
body TG.GeneratorArg {value = (TC.StructField name ty)} =
|
||||
let fixForVoidStarMembers =
|
||||
if isFunctionType ty && not (isTypeGeneric ty)
|
||||
then "(" ++ tyToCLambdaFix (RefTy ty (VarTy "q")) ++ ")"
|
||||
else ""
|
||||
in toTemplate ("$DECL { return " ++ fixForVoidStarMembers ++ "(&(p->" ++ (mangle name) ++ ")); }\n")
|
||||
body TG.GeneratorArg{} = toTemplate "/* template error! */"
|
||||
body TG.GeneratorArg {} = toTemplate "/* template error! */"
|
||||
|
||||
deps :: TG.DepenGenerator TC.TypeField
|
||||
deps = const []
|
||||
@ -268,154 +275,158 @@ getterGenerator = TG.mkTemplateGenerator tgen decl body deps
|
||||
-- | setterGenerator returns a template generator for struct property setters.
|
||||
setterGenerator :: TG.TemplateGenerator TC.TypeField
|
||||
setterGenerator = TG.mkTemplateGenerator tgen decl body deps
|
||||
where tgen :: TG.TypeGenerator TC.TypeField
|
||||
tgen _ = (FuncTy [VarTy "p", VarTy "t"] (VarTy "p") StaticLifetimeTy)
|
||||
where
|
||||
tgen :: TG.TypeGenerator TC.TypeField
|
||||
tgen _ = (FuncTy [VarTy "p", VarTy "t"] (VarTy "p") StaticLifetimeTy)
|
||||
|
||||
decl :: TG.TokenGenerator TC.TypeField
|
||||
decl GeneratorArg{instanceT=(FuncTy [_, UnitTy] _ _)} = toTemplate "$p $NAME($p p)"
|
||||
decl _ = toTemplate "$p $NAME($p p, $t newValue)"
|
||||
decl :: TG.TokenGenerator TC.TypeField
|
||||
decl GeneratorArg {instanceT = (FuncTy [_, UnitTy] _ _)} = toTemplate "$p $NAME($p p)"
|
||||
decl _ = toTemplate "$p $NAME($p p, $t newValue)"
|
||||
|
||||
body :: TG.TokenGenerator TC.TypeField
|
||||
body GeneratorArg{instanceT=(FuncTy [_, UnitTy] _ _)} = toTemplate "$DECL { return p; }\n"
|
||||
body GeneratorArg{tenv,env,instanceT= (FuncTy [_, ty] _ _),value=(TC.StructField name _)} =
|
||||
multilineTemplate [
|
||||
"$DECL {",
|
||||
memberDeletion tenv env (name, ty),
|
||||
" p." ++ (mangle name) ++ " = newValue;",
|
||||
" return p;",
|
||||
"}\n"
|
||||
]
|
||||
body _ = toTemplate "/* template error! */"
|
||||
body :: TG.TokenGenerator TC.TypeField
|
||||
body GeneratorArg {instanceT = (FuncTy [_, UnitTy] _ _)} = toTemplate "$DECL { return p; }\n"
|
||||
body GeneratorArg {tenv, env, instanceT = (FuncTy [_, ty] _ _), value = (TC.StructField name _)} =
|
||||
multilineTemplate
|
||||
[ "$DECL {",
|
||||
memberDeletion tenv env (name, ty),
|
||||
" p." ++ (mangle name) ++ " = newValue;",
|
||||
" return p;",
|
||||
"}\n"
|
||||
]
|
||||
body _ = toTemplate "/* template error! */"
|
||||
|
||||
deps :: TG.DepenGenerator TC.TypeField
|
||||
deps GeneratorArg{tenv, env, TG.instanceT=(FuncTy [_, ty] _ _)}
|
||||
| isManaged tenv env ty = depsOfPolymorphicFunction tenv env [] "delete" (typesDeleterFunctionType ty)
|
||||
| isFunctionType ty = [defineFunctionTypeAlias ty]
|
||||
| otherwise = []
|
||||
deps _ = []
|
||||
deps :: TG.DepenGenerator TC.TypeField
|
||||
deps GeneratorArg {tenv, env, TG.instanceT = (FuncTy [_, ty] _ _)}
|
||||
| isManaged tenv env ty = depsOfPolymorphicFunction tenv env [] "delete" (typesDeleterFunctionType ty)
|
||||
| isFunctionType ty = [defineFunctionTypeAlias ty]
|
||||
| otherwise = []
|
||||
deps _ = []
|
||||
|
||||
-- | mutatorGenerator returns a template generator for struct property setters (in-place).
|
||||
mutatorGenerator :: TG.TemplateGenerator TC.TypeField
|
||||
mutatorGenerator = TG.mkTemplateGenerator tgen decl body deps
|
||||
where tgen :: TG.TypeGenerator TC.TypeField
|
||||
tgen _ = (FuncTy [RefTy (VarTy "p") (VarTy "q"), VarTy "t"] UnitTy StaticLifetimeTy)
|
||||
where
|
||||
tgen :: TG.TypeGenerator TC.TypeField
|
||||
tgen _ = (FuncTy [RefTy (VarTy "p") (VarTy "q"), VarTy "t"] UnitTy StaticLifetimeTy)
|
||||
|
||||
decl :: TG.TokenGenerator TC.TypeField
|
||||
decl GeneratorArg{instanceT=(FuncTy [_, UnitTy] _ _)} = toTemplate "void $NAME($p* pRef)"
|
||||
decl _ = toTemplate "void $NAME($p* pRef, $t newValue)"
|
||||
decl :: TG.TokenGenerator TC.TypeField
|
||||
decl GeneratorArg {instanceT = (FuncTy [_, UnitTy] _ _)} = toTemplate "void $NAME($p* pRef)"
|
||||
decl _ = toTemplate "void $NAME($p* pRef, $t newValue)"
|
||||
|
||||
body :: TG.TokenGenerator TC.TypeField
|
||||
-- Execution of the action passed as an argument is handled in Emit.hs.
|
||||
body GeneratorArg{instanceT=(FuncTy [_, UnitTy] _ _)} = toTemplate "$DECL { return; }\n"
|
||||
body GeneratorArg{tenv, env, instanceT=(FuncTy [_, ty] _ _), value=(TC.StructField name _)} =
|
||||
multilineTemplate [
|
||||
"$DECL {",
|
||||
memberRefDeletion tenv env (name, ty),
|
||||
" pRef->" ++ mangle name ++ " = newValue;",
|
||||
"}\n"
|
||||
]
|
||||
body _ = toTemplate "/* template error! */"
|
||||
body :: TG.TokenGenerator TC.TypeField
|
||||
-- Execution of the action passed as an argument is handled in Emit.hs.
|
||||
body GeneratorArg {instanceT = (FuncTy [_, UnitTy] _ _)} = toTemplate "$DECL { return; }\n"
|
||||
body GeneratorArg {tenv, env, instanceT = (FuncTy [_, ty] _ _), value = (TC.StructField name _)} =
|
||||
multilineTemplate
|
||||
[ "$DECL {",
|
||||
memberRefDeletion tenv env (name, ty),
|
||||
" pRef->" ++ mangle name ++ " = newValue;",
|
||||
"}\n"
|
||||
]
|
||||
body _ = toTemplate "/* template error! */"
|
||||
|
||||
deps :: TG.DepenGenerator TC.TypeField
|
||||
deps GeneratorArg{tenv, env, instanceT=(FuncTy [_, ty] _ _)} =
|
||||
if isManaged tenv env ty
|
||||
then depsOfPolymorphicFunction tenv env [] "delete" (typesDeleterFunctionType ty)
|
||||
else []
|
||||
deps _ = []
|
||||
deps :: TG.DepenGenerator TC.TypeField
|
||||
deps GeneratorArg {tenv, env, instanceT = (FuncTy [_, ty] _ _)} =
|
||||
if isManaged tenv env ty
|
||||
then depsOfPolymorphicFunction tenv env [] "delete" (typesDeleterFunctionType ty)
|
||||
else []
|
||||
deps _ = []
|
||||
|
||||
-- | Returns a template generator for updating struct properties with a function.
|
||||
updateGenerator :: TG.TemplateGenerator TC.TypeField
|
||||
updateGenerator = TG.mkTemplateGenerator tgen decl body deps
|
||||
where tgen :: TG.TypeGenerator TC.TypeField
|
||||
tgen GeneratorArg{value=(TC.StructField _ UnitTy)} =
|
||||
(FuncTy [VarTy "p", RefTy (FuncTy [] UnitTy (VarTy "fq")) (VarTy "q")] (VarTy "p") StaticLifetimeTy)
|
||||
tgen _ = (FuncTy [VarTy "p", RefTy (FuncTy [VarTy "t"] (VarTy "t") (VarTy "fq")) (VarTy "q")] (VarTy "p") StaticLifetimeTy)
|
||||
where
|
||||
tgen :: TG.TypeGenerator TC.TypeField
|
||||
tgen GeneratorArg {value = (TC.StructField _ UnitTy)} =
|
||||
(FuncTy [VarTy "p", RefTy (FuncTy [] UnitTy (VarTy "fq")) (VarTy "q")] (VarTy "p") StaticLifetimeTy)
|
||||
tgen _ = (FuncTy [VarTy "p", RefTy (FuncTy [VarTy "t"] (VarTy "t") (VarTy "fq")) (VarTy "q")] (VarTy "p") StaticLifetimeTy)
|
||||
|
||||
decl :: TG.TokenGenerator TC.TypeField
|
||||
decl _ = toTemplate "$p $NAME($p p, Lambda *updater)" -- Lambda used to be (Fn [t] t)
|
||||
decl :: TG.TokenGenerator TC.TypeField
|
||||
decl _ = toTemplate "$p $NAME($p p, Lambda *updater)" -- Lambda used to be (Fn [t] t)
|
||||
body :: TG.TokenGenerator TC.TypeField
|
||||
body GeneratorArg {value = (TC.StructField _ UnitTy)} =
|
||||
toTemplate ("$DECL { " ++ templateCodeForCallingLambda "(*updater)" (FuncTy [] UnitTy (VarTy "fq")) [] ++ "; return p;}\n")
|
||||
body GeneratorArg {value = (TC.StructField name _)} =
|
||||
multilineTemplate
|
||||
[ "$DECL {",
|
||||
" p." ++ mangle name ++ " = " ++ templateCodeForCallingLambda "(*updater)" (FuncTy [VarTy "t"] (VarTy "t") (VarTy "fq")) ["p." ++ mangle name] ++ ";",
|
||||
" return p;",
|
||||
"}\n"
|
||||
]
|
||||
body _ = toTemplate "/* template error! */"
|
||||
|
||||
body :: TG.TokenGenerator TC.TypeField
|
||||
body GeneratorArg{value=(TC.StructField _ UnitTy)} =
|
||||
toTemplate ("$DECL { " ++ templateCodeForCallingLambda "(*updater)" (FuncTy [] UnitTy (VarTy "fq")) [] ++ "; return p;}\n")
|
||||
body GeneratorArg{value=(TC.StructField name _)} = multilineTemplate [
|
||||
"$DECL {",
|
||||
" p." ++ mangle name ++ " = " ++ templateCodeForCallingLambda "(*updater)" (FuncTy [VarTy "t"] (VarTy "t") (VarTy "fq")) ["p." ++ mangle name] ++ ";",
|
||||
" return p;",
|
||||
"}\n"
|
||||
]
|
||||
body _ = toTemplate "/* template error! */"
|
||||
|
||||
deps :: TG.DepenGenerator TC.TypeField
|
||||
deps GeneratorArg{instanceT=(FuncTy [_, RefTy t@(FuncTy fArgTys fRetTy _) _] _ _)} =
|
||||
if isTypeGeneric fRetTy
|
||||
then []
|
||||
else [defineFunctionTypeAlias t, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) fRetTy StaticLifetimeTy)]
|
||||
deps _ = []
|
||||
deps :: TG.DepenGenerator TC.TypeField
|
||||
deps GeneratorArg {instanceT = (FuncTy [_, RefTy t@(FuncTy fArgTys fRetTy _) _] _ _)} =
|
||||
if isTypeGeneric fRetTy
|
||||
then []
|
||||
else [defineFunctionTypeAlias t, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) fRetTy StaticLifetimeTy)]
|
||||
deps _ = []
|
||||
|
||||
-- | Returns a template generator for a types initializer function.
|
||||
initGenerator :: AllocationMode -> TG.TemplateGenerator TC.TypeCandidate
|
||||
initGenerator alloc = TG.mkTemplateGenerator genT decl body deps
|
||||
where genT :: TG.TypeGenerator TC.TypeCandidate
|
||||
genT GeneratorArg{value} =
|
||||
(FuncTy (concatMap TC.fieldTypes (TC.getFields value)) (VarTy "p") StaticLifetimeTy)
|
||||
where
|
||||
genT :: TG.TypeGenerator TC.TypeCandidate
|
||||
genT GeneratorArg {value} =
|
||||
(FuncTy (concatMap TC.fieldTypes (TC.getFields value)) (VarTy "p") StaticLifetimeTy)
|
||||
|
||||
decl :: TG.TokenGenerator TC.TypeCandidate
|
||||
decl GeneratorArg{originalT, instanceT=(FuncTy _ concreteT _), value} =
|
||||
let mappings = unifySignatures originalT concreteT
|
||||
concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value)
|
||||
cFields = remove isUnitT (remove isDummy concreteFields)
|
||||
in toTemplate ("$p $NAME(" ++ joinWithComma (map fieldArg cFields) ++ ")")
|
||||
decl _ = toTemplate "/* template error! */"
|
||||
decl :: TG.TokenGenerator TC.TypeCandidate
|
||||
decl GeneratorArg {originalT, instanceT = (FuncTy _ concreteT _), value} =
|
||||
let mappings = unifySignatures originalT concreteT
|
||||
concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value)
|
||||
cFields = remove isUnitT (remove isDummy concreteFields)
|
||||
in toTemplate ("$p $NAME(" ++ joinWithComma (map fieldArg cFields) ++ ")")
|
||||
decl _ = toTemplate "/* template error! */"
|
||||
|
||||
body :: TG.TokenGenerator TC.TypeCandidate
|
||||
body GeneratorArg{originalT, instanceT=(FuncTy _ concreteT _), value} =
|
||||
let mappings = unifySignatures originalT concreteT
|
||||
concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value)
|
||||
in tokensForInit alloc (show originalT) (remove isUnitT concreteFields)
|
||||
body _ = toTemplate "/* template error! */"
|
||||
body :: TG.TokenGenerator TC.TypeCandidate
|
||||
body GeneratorArg {originalT, instanceT = (FuncTy _ concreteT _), value} =
|
||||
let mappings = unifySignatures originalT concreteT
|
||||
concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value)
|
||||
in tokensForInit alloc (show originalT) (remove isUnitT concreteFields)
|
||||
body _ = toTemplate "/* template error! */"
|
||||
|
||||
deps :: TG.DepenGenerator TC.TypeCandidate
|
||||
deps GeneratorArg{tenv, env, instanceT=(FuncTy _ concreteT _)} =
|
||||
case concretizeType tenv env concreteT of
|
||||
Left _ -> []
|
||||
Right ok -> ok
|
||||
deps _ = []
|
||||
deps :: TG.DepenGenerator TC.TypeCandidate
|
||||
deps GeneratorArg {tenv, env, instanceT = (FuncTy _ concreteT _)} =
|
||||
case concretizeType tenv env concreteT of
|
||||
Left _ -> []
|
||||
Right ok -> ok
|
||||
deps _ = []
|
||||
|
||||
tokensForInit :: AllocationMode -> String -> [TC.TypeField] -> [Token]
|
||||
-- if this is truly a memberless struct, init it to 0;
|
||||
-- This can happen in cases where *all* members of the struct are of type Unit.
|
||||
-- Since we do not generate members for Unit types.
|
||||
tokensForInit StackAlloc _ [] =
|
||||
multilineTemplate [
|
||||
"$DECL {",
|
||||
" $p instance = {};",
|
||||
" return instance;",
|
||||
"}"
|
||||
]
|
||||
tokensForInit StackAlloc _ fields =
|
||||
multilineTemplate [
|
||||
"$DECL {",
|
||||
" $p instance;",
|
||||
assignments fields,
|
||||
" return instance;",
|
||||
"}"
|
||||
]
|
||||
tokensForInit HeapAlloc typeName fields =
|
||||
multilineTemplate [
|
||||
"$DECL {",
|
||||
" $p instance = CARP_MALLOC(sizeof(" ++ typeName ++ "));",
|
||||
assignments fields,
|
||||
" return instance;",
|
||||
"}"
|
||||
]
|
||||
tokensForInit :: AllocationMode -> String -> [TC.TypeField] -> [Token]
|
||||
-- if this is truly a memberless struct, init it to 0;
|
||||
-- This can happen in cases where *all* members of the struct are of type Unit.
|
||||
-- Since we do not generate members for Unit types.
|
||||
tokensForInit StackAlloc _ [] =
|
||||
multilineTemplate
|
||||
[ "$DECL {",
|
||||
" $p instance = {};",
|
||||
" return instance;",
|
||||
"}"
|
||||
]
|
||||
tokensForInit StackAlloc _ fields =
|
||||
multilineTemplate
|
||||
[ "$DECL {",
|
||||
" $p instance;",
|
||||
assignments fields,
|
||||
" return instance;",
|
||||
"}"
|
||||
]
|
||||
tokensForInit HeapAlloc typeName fields =
|
||||
multilineTemplate
|
||||
[ "$DECL {",
|
||||
" $p instance = CARP_MALLOC(sizeof(" ++ typeName ++ "));",
|
||||
assignments fields,
|
||||
" return instance;",
|
||||
"}"
|
||||
]
|
||||
|
||||
assignments :: [TC.TypeField] -> String
|
||||
assignments [] = ""
|
||||
assignments fields = joinLines $ fmap (memberAssignment alloc) fields
|
||||
assignments :: [TC.TypeField] -> String
|
||||
assignments [] = ""
|
||||
assignments fields = joinLines $ fmap (memberAssignment alloc) fields
|
||||
|
||||
isDummy field = TC.fieldName field == "__dummy"
|
||||
isUnitT (TC.StructField _ UnitTy) = True
|
||||
isUnitT _ = False
|
||||
isDummy field = TC.fieldName field == "__dummy"
|
||||
isUnitT (TC.StructField _ UnitTy) = True
|
||||
isUnitT _ = False
|
||||
|
||||
-- | Generate C code for assigning to a member variable.
|
||||
-- Needs to know if the instance is a pointer or stack variable.
|
||||
@ -458,118 +469,121 @@ templatizeTy t = t
|
||||
-- | Returns a template generator for a type's str and prn functions.
|
||||
strGenerator :: TG.TemplateGenerator TC.TypeCandidate
|
||||
strGenerator = TG.mkTemplateGenerator genT decl body deps
|
||||
where genT :: TG.TypeGenerator TC.TypeCandidate
|
||||
genT GeneratorArg{originalT} =
|
||||
FuncTy [RefTy originalT (VarTy "q")] StringTy StaticLifetimeTy
|
||||
where
|
||||
genT :: TG.TypeGenerator TC.TypeCandidate
|
||||
genT GeneratorArg {originalT} =
|
||||
FuncTy [RefTy originalT (VarTy "q")] StringTy StaticLifetimeTy
|
||||
|
||||
decl :: TG.TokenGenerator TC.TypeCandidate
|
||||
decl GeneratorArg{instanceT=(FuncTy [RefTy structT _] _ _)} =
|
||||
toTemplate $ "String $NAME(" ++ tyToCLambdaFix structT ++ " *p)"
|
||||
decl _ = toTemplate "/* template error! */"
|
||||
decl :: TG.TokenGenerator TC.TypeCandidate
|
||||
decl GeneratorArg {instanceT = (FuncTy [RefTy structT _] _ _)} =
|
||||
toTemplate $ "String $NAME(" ++ tyToCLambdaFix structT ++ " *p)"
|
||||
decl _ = toTemplate "/* template error! */"
|
||||
|
||||
body :: TG.TokenGenerator TC.TypeCandidate
|
||||
body GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [RefTy structT _] _ _), value} =
|
||||
let mappings = unifySignatures originalT structT
|
||||
concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value)
|
||||
in tokensForStr tenv env (getStructName structT) concreteFields structT
|
||||
body _ = toTemplate "/* template error! */"
|
||||
body :: TG.TokenGenerator TC.TypeCandidate
|
||||
body GeneratorArg {tenv, env, originalT, instanceT = (FuncTy [RefTy structT _] _ _), value} =
|
||||
let mappings = unifySignatures originalT structT
|
||||
concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value)
|
||||
in tokensForStr tenv env (getStructName structT) concreteFields structT
|
||||
body _ = toTemplate "/* template error! */"
|
||||
|
||||
deps :: TG.DepenGenerator TC.TypeCandidate
|
||||
deps arg@GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [RefTy structT _] _ _), value} =
|
||||
let mappings = unifySignatures originalT structT
|
||||
concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value)
|
||||
in concatMap
|
||||
(depsOfPolymorphicFunction tenv env [] "prn" . typesStrFunctionType tenv env)
|
||||
(remove isFullyGenericType (concatMap TC.fieldTypes concreteFields))
|
||||
++ [defineFunctionTypeAlias (instanceT arg) | not (isTypeGeneric structT)]
|
||||
deps _ = []
|
||||
deps :: TG.DepenGenerator TC.TypeCandidate
|
||||
deps arg@GeneratorArg {tenv, env, originalT, instanceT = (FuncTy [RefTy structT _] _ _), value} =
|
||||
let mappings = unifySignatures originalT structT
|
||||
concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value)
|
||||
in concatMap
|
||||
(depsOfPolymorphicFunction tenv env [] "prn" . typesStrFunctionType tenv env)
|
||||
(remove isFullyGenericType (concatMap TC.fieldTypes concreteFields))
|
||||
++ [defineFunctionTypeAlias (instanceT arg) | not (isTypeGeneric structT)]
|
||||
deps _ = []
|
||||
|
||||
tokensForStr :: TypeEnv -> Env -> String -> [TC.TypeField] -> Ty -> [Token]
|
||||
tokensForStr typeEnv env typeName fields concreteStructTy =
|
||||
let members = remove ((=="__dummy"). fst) (map fieldToTuple fields)
|
||||
in multilineTemplate
|
||||
[ "$DECL {",
|
||||
" // convert members to String here:",
|
||||
" String temp = NULL;",
|
||||
" int tempsize = 0;",
|
||||
" (void)tempsize; // that way we remove the occasional unused warning ",
|
||||
calculateStructStrSize typeEnv env members concreteStructTy,
|
||||
" String buffer = CARP_MALLOC(size);",
|
||||
" String bufferPtr = buffer;",
|
||||
"",
|
||||
" sprintf(bufferPtr, \"(%s \", \"" ++ typeName ++ "\");",
|
||||
" bufferPtr += strlen(\"" ++ typeName ++ "\") + 2;\n",
|
||||
joinLines (map (memberPrn typeEnv env) members),
|
||||
" bufferPtr--;",
|
||||
" sprintf(bufferPtr, \")\");",
|
||||
" return buffer;",
|
||||
"}"
|
||||
]
|
||||
|
||||
-- | Figure out how big the string needed for the string representation of the struct has to be.
|
||||
calculateStructStrSize :: TypeEnv -> Env -> [(String, Ty)] -> Ty -> String
|
||||
calculateStructStrSize typeEnv env fields s =
|
||||
" int size = snprintf(NULL, 0, \"(%s )\", \"" ++ show s ++ "\");\n"
|
||||
++ unlines (map (memberPrnSize typeEnv env) fields)
|
||||
tokensForStr :: TypeEnv -> Env -> String -> [TC.TypeField] -> Ty -> [Token]
|
||||
tokensForStr typeEnv env typeName fields concreteStructTy =
|
||||
let members = remove ((== "__dummy") . fst) (map fieldToTuple fields)
|
||||
in multilineTemplate
|
||||
[ "$DECL {",
|
||||
" // convert members to String here:",
|
||||
" String temp = NULL;",
|
||||
" int tempsize = 0;",
|
||||
" (void)tempsize; // that way we remove the occasional unused warning ",
|
||||
calculateStructStrSize typeEnv env members concreteStructTy,
|
||||
" String buffer = CARP_MALLOC(size);",
|
||||
" String bufferPtr = buffer;",
|
||||
"",
|
||||
" sprintf(bufferPtr, \"(%s \", \"" ++ typeName ++ "\");",
|
||||
" bufferPtr += strlen(\"" ++ typeName ++ "\") + 2;\n",
|
||||
joinLines (map (memberPrn typeEnv env) members),
|
||||
" bufferPtr--;",
|
||||
" sprintf(bufferPtr, \")\");",
|
||||
" return buffer;",
|
||||
"}"
|
||||
]
|
||||
calculateStructStrSize :: TypeEnv -> Env -> [(String, Ty)] -> Ty -> String
|
||||
calculateStructStrSize typeEnv env fields s =
|
||||
" int size = snprintf(NULL, 0, \"(%s )\", \"" ++ show s ++ "\");\n"
|
||||
++ unlines (map (memberPrnSize typeEnv env) fields)
|
||||
|
||||
-- | Returns a template generator for a type's delete function.
|
||||
deleteGenerator :: TG.TemplateGenerator TC.TypeCandidate
|
||||
deleteGenerator = TG.mkTemplateGenerator genT decl body deps
|
||||
where genT :: TG.TypeGenerator TC.TypeCandidate
|
||||
genT _ = FuncTy [VarTy "p"] UnitTy StaticLifetimeTy
|
||||
where
|
||||
genT :: TG.TypeGenerator TC.TypeCandidate
|
||||
genT _ = FuncTy [VarTy "p"] UnitTy StaticLifetimeTy
|
||||
|
||||
decl :: TG.TokenGenerator TC.TypeCandidate
|
||||
decl _ = toTemplate "void $NAME($p p)"
|
||||
decl :: TG.TokenGenerator TC.TypeCandidate
|
||||
decl _ = toTemplate "void $NAME($p p)"
|
||||
|
||||
body :: TG.TokenGenerator TC.TypeCandidate
|
||||
body GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [structT] _ _), value} =
|
||||
let mappings = unifySignatures originalT structT
|
||||
concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value)
|
||||
members = map fieldToTuple concreteFields
|
||||
in multilineTemplate [
|
||||
"$DECL {",
|
||||
joinLines (map (memberDeletion tenv env) members),
|
||||
"}"
|
||||
]
|
||||
body _ = toTemplate "/* template error! */"
|
||||
body :: TG.TokenGenerator TC.TypeCandidate
|
||||
body GeneratorArg {tenv, env, originalT, instanceT = (FuncTy [structT] _ _), value} =
|
||||
let mappings = unifySignatures originalT structT
|
||||
concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value)
|
||||
members = map fieldToTuple concreteFields
|
||||
in multilineTemplate
|
||||
[ "$DECL {",
|
||||
joinLines (map (memberDeletion tenv env) members),
|
||||
"}"
|
||||
]
|
||||
body _ = toTemplate "/* template error! */"
|
||||
|
||||
deps :: TG.DepenGenerator TC.TypeCandidate
|
||||
deps GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [structT] _ _), value}
|
||||
| isTypeGeneric structT = []
|
||||
| otherwise = let mappings = unifySignatures originalT structT
|
||||
concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value)
|
||||
in concatMap
|
||||
(depsOfPolymorphicFunction tenv env [] "delete" . typesDeleterFunctionType)
|
||||
(filter (isManaged tenv env) (concatMap TC.fieldTypes concreteFields))
|
||||
deps _ = []
|
||||
deps :: TG.DepenGenerator TC.TypeCandidate
|
||||
deps GeneratorArg {tenv, env, originalT, instanceT = (FuncTy [structT] _ _), value}
|
||||
| isTypeGeneric structT = []
|
||||
| otherwise =
|
||||
let mappings = unifySignatures originalT structT
|
||||
concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value)
|
||||
in concatMap
|
||||
(depsOfPolymorphicFunction tenv env [] "delete" . typesDeleterFunctionType)
|
||||
(filter (isManaged tenv env) (concatMap TC.fieldTypes concreteFields))
|
||||
deps _ = []
|
||||
|
||||
-- | Returns a template generator for a type's copy function.
|
||||
copyGenerator :: TG.TemplateGenerator TC.TypeCandidate
|
||||
copyGenerator = TG.mkTemplateGenerator genT decl body deps
|
||||
where genT :: TG.TypeGenerator TC.TypeCandidate
|
||||
genT _ = FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy
|
||||
where
|
||||
genT :: TG.TypeGenerator TC.TypeCandidate
|
||||
genT _ = FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy
|
||||
|
||||
decl :: TG.TokenGenerator TC.TypeCandidate
|
||||
decl _ = toTemplate "$p $NAME($p* pRef)"
|
||||
decl :: TG.TokenGenerator TC.TypeCandidate
|
||||
decl _ = toTemplate "$p $NAME($p* pRef)"
|
||||
|
||||
body :: TG.TokenGenerator TC.TypeCandidate
|
||||
body GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [RefTy structT _] _ _), value} =
|
||||
let mappings = unifySignatures originalT structT
|
||||
concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value)
|
||||
members = map fieldToTuple concreteFields
|
||||
in tokensForCopy tenv env members
|
||||
body _ = toTemplate "/* template error! */"
|
||||
body :: TG.TokenGenerator TC.TypeCandidate
|
||||
body GeneratorArg {tenv, env, originalT, instanceT = (FuncTy [RefTy structT _] _ _), value} =
|
||||
let mappings = unifySignatures originalT structT
|
||||
concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value)
|
||||
members = map fieldToTuple concreteFields
|
||||
in tokensForCopy tenv env members
|
||||
body _ = toTemplate "/* template error! */"
|
||||
|
||||
deps :: TG.DepenGenerator TC.TypeCandidate
|
||||
deps GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [RefTy structT _] _ _), value}
|
||||
| isTypeGeneric structT = []
|
||||
| otherwise = let mappings = unifySignatures originalT structT
|
||||
concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value)
|
||||
members = map fieldToTuple concreteFields
|
||||
in concatMap
|
||||
(depsOfPolymorphicFunction tenv env [] "copy" . typesCopyFunctionType)
|
||||
(filter (isManaged tenv env) (map snd members))
|
||||
deps _ = []
|
||||
deps :: TG.DepenGenerator TC.TypeCandidate
|
||||
deps GeneratorArg {tenv, env, originalT, instanceT = (FuncTy [RefTy structT _] _ _), value}
|
||||
| isTypeGeneric structT = []
|
||||
| otherwise =
|
||||
let mappings = unifySignatures originalT structT
|
||||
concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value)
|
||||
members = map fieldToTuple concreteFields
|
||||
in concatMap
|
||||
(depsOfPolymorphicFunction tenv env [] "copy" . typesCopyFunctionType)
|
||||
(filter (isManaged tenv env) (map snd members))
|
||||
deps _ = []
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Utilities
|
||||
@ -579,6 +593,6 @@ copyGenerator = TG.mkTemplateGenerator genT decl body deps
|
||||
-- functions for handling type members and it should eventually be deprecated
|
||||
-- once these functions work on type fields directly.
|
||||
fieldToTuple :: TC.TypeField -> (String, Ty)
|
||||
fieldToTuple (TC.StructField name t) = (mangle name, t)
|
||||
fieldToTuple (TC.SumField name (t:_)) = (mangle name, t) -- note: not actually used.
|
||||
fieldToTuple (TC.StructField name t) = (mangle name, t)
|
||||
fieldToTuple (TC.SumField name (t : _)) = (mangle name, t) -- note: not actually used.
|
||||
fieldToTuple (TC.SumField name []) = (mangle name, TypeTy) -- note: not actually used.
|
||||
|
||||
@ -530,7 +530,8 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
|
||||
var <- visit indent value
|
||||
let Just t = ty
|
||||
fresh = mangle (freshVar info)
|
||||
unless (isUnit t)
|
||||
unless
|
||||
(isUnit t)
|
||||
(appendToSrc (addIndent indent ++ tyToCLambdaFix t ++ " " ++ fresh ++ " = " ++ var ++ "; // From the 'the' function.\n"))
|
||||
pure fresh
|
||||
-- Ref
|
||||
|
||||
22
src/Env.hs
22
src/Env.hs
@ -375,17 +375,19 @@ mutate f e path binder = go path
|
||||
where
|
||||
go (SymPath [] name) = f e name binder
|
||||
go (SymPath (p : []) name) =
|
||||
do mod' <- getBinder e p
|
||||
env' <- nextEnv (modality e) mod'
|
||||
res <- mutate f (inj env') (SymPath [] name) binder
|
||||
new' <- updateEnv (modality e) (prj res) mod'
|
||||
addBinding e p new'
|
||||
do
|
||||
mod' <- getBinder e p
|
||||
env' <- nextEnv (modality e) mod'
|
||||
res <- mutate f (inj env') (SymPath [] name) binder
|
||||
new' <- updateEnv (modality e) (prj res) mod'
|
||||
addBinding e p new'
|
||||
go (SymPath (p : ps) name) =
|
||||
do mod' <- getBinder e p
|
||||
old <- nextEnv Values mod'
|
||||
result <- mutate f (inj old) (SymPath ps name) binder
|
||||
new' <- updateEnv Values (prj result) mod'
|
||||
addBinding e p new'
|
||||
do
|
||||
mod' <- getBinder e p
|
||||
old <- nextEnv Values mod'
|
||||
result <- mutate f (inj old) (SymPath ps name) binder
|
||||
new' <- updateEnv Values (prj result) mod'
|
||||
addBinding e p new'
|
||||
|
||||
-- | Insert a binding into an environment at the given path.
|
||||
insert :: Environment e => e -> SymPath -> Binder -> Either EnvironmentError e
|
||||
|
||||
@ -265,7 +265,9 @@ primitiveRegisterTypeWithFields ctx x t override members =
|
||||
Right ctx' = update ctx
|
||||
-- TODO: Another case where define does not get formally qualified deps!
|
||||
contextWithDefs <- liftIO $ foldM (define True) ctx' (map Qualified deps)
|
||||
autoDerive contextWithDefs (StructTy (ConcreteNameTy (unqualify path')) [])
|
||||
autoDerive
|
||||
contextWithDefs
|
||||
(StructTy (ConcreteNameTy (unqualify path')) [])
|
||||
[ lookupBinderInTypeEnv contextWithDefs (markQualified (SymPath [] "str")),
|
||||
lookupBinderInTypeEnv contextWithDefs (markQualified (SymPath [] "prn"))
|
||||
]
|
||||
@ -616,11 +618,14 @@ deftype ctx x@(XObj (Sym (SymPath [] name) _) _ _) constructor =
|
||||
(ctxWithType, e) <- makeType ctx name [] constructor
|
||||
case e of
|
||||
Left err -> pure (evalError ctx (show err) (xobjInfo x))
|
||||
Right t -> autoDerive ctxWithType t
|
||||
[ lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "delete")),
|
||||
lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "str")),
|
||||
lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "copy"))
|
||||
]
|
||||
Right t ->
|
||||
autoDerive
|
||||
ctxWithType
|
||||
t
|
||||
[ lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "delete")),
|
||||
lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "str")),
|
||||
lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "copy"))
|
||||
]
|
||||
deftype ctx x@(XObj (Lst ((XObj (Sym (SymPath [] name) _) _ _) : tyvars)) _ _) constructor =
|
||||
do
|
||||
(ctxWithType, e) <-
|
||||
@ -631,11 +636,14 @@ deftype ctx x@(XObj (Lst ((XObj (Sym (SymPath [] name) _) _ _) : tyvars)) _ _) c
|
||||
)
|
||||
case e of
|
||||
Left err -> pure (evalError ctx (show err) (xobjInfo x))
|
||||
Right t -> autoDerive ctxWithType t
|
||||
[ lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "delete")),
|
||||
lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "str")),
|
||||
lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "copy"))
|
||||
]
|
||||
Right t ->
|
||||
autoDerive
|
||||
ctxWithType
|
||||
t
|
||||
[ lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "delete")),
|
||||
lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "str")),
|
||||
lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "copy"))
|
||||
]
|
||||
deftype ctx name _ = pure $ toEvalError ctx name (InvalidTypeName name)
|
||||
|
||||
checkVariables :: [XObj] -> Maybe [Ty]
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
module StartingEnv where
|
||||
|
||||
import qualified ArrayTemplates
|
||||
import qualified BoxTemplates
|
||||
import Commands
|
||||
import qualified Env as E
|
||||
import Eval
|
||||
@ -14,7 +15,6 @@ import qualified StaticArrayTemplates
|
||||
import Template
|
||||
import ToTemplate
|
||||
import Types
|
||||
import qualified BoxTemplates
|
||||
|
||||
-- | These modules will be loaded in order before any other code is evaluated.
|
||||
coreModules :: String -> [String]
|
||||
@ -121,15 +121,16 @@ boxModule =
|
||||
envFunctionNestingLevel = 0
|
||||
}
|
||||
where
|
||||
bindings = Map.fromList
|
||||
[ BoxTemplates.init,
|
||||
BoxTemplates.unbox,
|
||||
BoxTemplates.peek,
|
||||
BoxTemplates.delete,
|
||||
BoxTemplates.copy,
|
||||
BoxTemplates.prn,
|
||||
BoxTemplates.str
|
||||
]
|
||||
bindings =
|
||||
Map.fromList
|
||||
[ BoxTemplates.init,
|
||||
BoxTemplates.unbox,
|
||||
BoxTemplates.peek,
|
||||
BoxTemplates.delete,
|
||||
BoxTemplates.copy,
|
||||
BoxTemplates.prn,
|
||||
BoxTemplates.str
|
||||
]
|
||||
|
||||
maxArity :: Int
|
||||
maxArity = 9
|
||||
|
||||
202
src/Sumtypes.hs
202
src/Sumtypes.hs
@ -1,9 +1,8 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
||||
module Sumtypes
|
||||
(
|
||||
moduleForSumtypeInContext,
|
||||
moduleForSumtype
|
||||
( moduleForSumtypeInContext,
|
||||
moduleForSumtype,
|
||||
)
|
||||
where
|
||||
|
||||
@ -17,15 +16,15 @@ import Managed
|
||||
import Obj
|
||||
import StructUtils
|
||||
import Template
|
||||
import TemplateGenerator as TG
|
||||
import ToTemplate
|
||||
import qualified TypeCandidate as TC
|
||||
import TypeError
|
||||
import TypePredicates
|
||||
import Types
|
||||
import TypesToC
|
||||
import Util
|
||||
import Validate
|
||||
import qualified TypeCandidate as TC
|
||||
import TemplateGenerator as TG
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Public
|
||||
@ -75,16 +74,17 @@ moduleForSumtype innerEnv typeEnv env pathStrings typeName typeVariables rest i
|
||||
-- | Generate standard binders for the sumtype
|
||||
generateBinders :: TC.TypeCandidate -> Either TypeError ([(String, Binder)], [XObj])
|
||||
generateBinders candidate =
|
||||
do okIniters <- initers candidate
|
||||
okTag <- binderForTag candidate
|
||||
(okStr, okStrDeps) <- binderForStrOrPrn candidate "str"
|
||||
(okPrn, _) <- binderForStrOrPrn candidate "prn"
|
||||
okDelete <- binderForDelete candidate
|
||||
(okCopy, okCopyDeps) <- binderForCopy candidate
|
||||
okMemberDeps <- memberDeps (TC.getTypeEnv candidate) (TC.getValueEnv candidate) (TC.getFields candidate)
|
||||
let binders = okIniters ++ [okStr, okPrn, okDelete, okCopy, okTag]
|
||||
deps = okMemberDeps ++ okCopyDeps ++ okStrDeps
|
||||
pure (binders, deps)
|
||||
do
|
||||
okIniters <- initers candidate
|
||||
okTag <- binderForTag candidate
|
||||
(okStr, okStrDeps) <- binderForStrOrPrn candidate "str"
|
||||
(okPrn, _) <- binderForStrOrPrn candidate "prn"
|
||||
okDelete <- binderForDelete candidate
|
||||
(okCopy, okCopyDeps) <- binderForCopy candidate
|
||||
okMemberDeps <- memberDeps (TC.getTypeEnv candidate) (TC.getValueEnv candidate) (TC.getFields candidate)
|
||||
let binders = okIniters ++ [okStr, okPrn, okDelete, okCopy, okTag]
|
||||
deps = okMemberDeps ++ okCopyDeps ++ okStrDeps
|
||||
pure (binders, deps)
|
||||
|
||||
-- | Gets concrete dependencies for sum type fields.
|
||||
memberDeps :: TypeEnv -> Env -> [TC.TypeField] -> Either TypeError [XObj]
|
||||
@ -104,44 +104,41 @@ replaceGenericTypesOnCases mappings = map replaceOnCase
|
||||
-- Binding generators
|
||||
|
||||
type BinderGen = TC.TypeCandidate -> Either TypeError (String, Binder)
|
||||
|
||||
type BinderGenDeps = TC.TypeCandidate -> Either TypeError ((String, Binder), [XObj])
|
||||
|
||||
type MultiBinderGen = TC.TypeCandidate -> Either TypeError [(String, Binder)]
|
||||
|
||||
-- | Generate initializer bindings for each sum type case.
|
||||
initers :: MultiBinderGen
|
||||
initers candidate = mapM binderForCaseInit (TC.getFields candidate)
|
||||
where
|
||||
-- | Generate an initializer binding for a single sum type case, using the given candidate.
|
||||
binderForCaseInit :: TC.TypeField -> Either TypeError (String, Binder)
|
||||
binderForCaseInit sumtypeCase =
|
||||
if isTypeGeneric (TC.toType candidate)
|
||||
then Right (genericCaseInit StackAlloc sumtypeCase)
|
||||
else Right (concreteCaseInit StackAlloc sumtypeCase)
|
||||
|
||||
-- | Generates a template for a concrete (no type variables) sum type case.
|
||||
concreteCaseInit :: AllocationMode -> TC.TypeField -> (String, Binder)
|
||||
concreteCaseInit alloc field@(TC.SumField fieldname tys) =
|
||||
let concrete = (TC.toType candidate)
|
||||
doc = "creates a `" ++ fieldname ++ "`."
|
||||
t = (FuncTy tys (VarTy "p") StaticLifetimeTy)
|
||||
decl = (const (tokensForCaseInitDecl concrete concrete field))
|
||||
body = (const (tokensForCaseInit alloc concrete concrete field))
|
||||
deps = (const [])
|
||||
temp = Template t decl body deps
|
||||
doc = "creates a `" ++ fieldname ++ "`."
|
||||
t = (FuncTy tys (VarTy "p") StaticLifetimeTy)
|
||||
decl = (const (tokensForCaseInitDecl concrete concrete field))
|
||||
body = (const (tokensForCaseInit alloc concrete concrete field))
|
||||
deps = (const [])
|
||||
temp = Template t decl body deps
|
||||
binderPath = SymPath (TC.getFullPath candidate) fieldname
|
||||
in instanceBinder binderPath (FuncTy tys concrete StaticLifetimeTy) temp doc
|
||||
concreteCaseInit _ _ = error "concreteCaseInit"
|
||||
|
||||
-- | Generates a template for a generic (has type variables) sum type case.
|
||||
genericCaseInit :: AllocationMode -> TC.TypeField -> (String, Binder)
|
||||
genericCaseInit alloc field@(TC.SumField fieldname tys) =
|
||||
let generic = (TC.toType candidate)
|
||||
docs = "creates a `" ++ fieldname ++ "`."
|
||||
ft = FuncTy tys generic StaticLifetimeTy
|
||||
docs = "creates a `" ++ fieldname ++ "`."
|
||||
ft = FuncTy tys generic StaticLifetimeTy
|
||||
binderPath = SymPath (TC.getFullPath candidate) fieldname
|
||||
t = (FuncTy tys (VarTy "p") StaticLifetimeTy)
|
||||
decl = \(FuncTy _ concrete _) -> tokensForCaseInitDecl generic concrete field
|
||||
body = \(FuncTy _ concrete _) -> tokensForCaseInit alloc generic concrete field
|
||||
t = (FuncTy tys (VarTy "p") StaticLifetimeTy)
|
||||
decl = \(FuncTy _ concrete _) -> tokensForCaseInitDecl generic concrete field
|
||||
body = \(FuncTy _ concrete _) -> tokensForCaseInit alloc generic concrete field
|
||||
deps tenv env = \(FuncTy _ concrete _) -> either (const []) id (concretizeType tenv env concrete)
|
||||
temp = TemplateCreator $ \tenv env -> Template t decl body (deps tenv env)
|
||||
in defineTypeParameterizedTemplate temp binderPath ft docs
|
||||
@ -169,29 +166,29 @@ binderForStrOrPrn candidate strOrPrn =
|
||||
binderP = SymPath (TC.getFullPath candidate) strOrPrn
|
||||
binderT = FuncTy [RefTy (TC.toType candidate) (VarTy "q")] StringTy StaticLifetimeTy
|
||||
in Right $
|
||||
if isTypeGeneric (TC.toType candidate)
|
||||
then (defineTypeParameterizedTemplate (TG.generateGenericTypeTemplate candidate strGenerator) binderP binderT doc, [])
|
||||
else instanceBinderWithDeps binderP binderT (TG.generateConcreteTypeTemplate candidate strGenerator) doc
|
||||
if isTypeGeneric (TC.toType candidate)
|
||||
then (defineTypeParameterizedTemplate (TG.generateGenericTypeTemplate candidate strGenerator) binderP binderT doc, [])
|
||||
else instanceBinderWithDeps binderP binderT (TG.generateConcreteTypeTemplate candidate strGenerator) doc
|
||||
where
|
||||
strGenerator :: TG.TemplateGenerator TC.TypeCandidate
|
||||
strGenerator = TG.mkTemplateGenerator genT decl body deps
|
||||
|
||||
genT :: TG.TypeGenerator TC.TypeCandidate
|
||||
genT GeneratorArg{value} =
|
||||
genT GeneratorArg {value} =
|
||||
FuncTy [RefTy (TC.toType value) (VarTy "q")] StringTy StaticLifetimeTy
|
||||
|
||||
decl :: TG.TokenGenerator TC.TypeCandidate
|
||||
decl GeneratorArg{instanceT=(FuncTy [RefTy ty _] _ _)} =
|
||||
decl GeneratorArg {instanceT = (FuncTy [RefTy ty _] _ _)} =
|
||||
toTemplate $ "String $NAME(" ++ tyToCLambdaFix ty ++ " *p)"
|
||||
decl _ = toTemplate "/* template error! */"
|
||||
|
||||
body :: TG.TokenGenerator TC.TypeCandidate
|
||||
body GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [RefTy ty _] _ _), value} =
|
||||
body GeneratorArg {tenv, env, originalT, instanceT = (FuncTy [RefTy ty _] _ _), value} =
|
||||
tokensForStr tenv env originalT ty (TC.getFields value)
|
||||
body _ = toTemplate "/* template error! */"
|
||||
|
||||
deps :: TG.DepenGenerator TC.TypeCandidate
|
||||
deps GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [RefTy ty _] _ _), value} =
|
||||
deps GeneratorArg {tenv, env, originalT, instanceT = (FuncTy [RefTy ty _] _ _), value} =
|
||||
depsForStr tenv env originalT ty (TC.getFields value)
|
||||
deps _ = []
|
||||
|
||||
@ -217,12 +214,12 @@ binderForDelete candidate =
|
||||
decl _ = toTemplate "void $NAME($p p)"
|
||||
|
||||
body :: TG.TokenGenerator TC.TypeCandidate
|
||||
body GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [ty] _ _), value} =
|
||||
body GeneratorArg {tenv, env, originalT, instanceT = (FuncTy [ty] _ _), value} =
|
||||
tokensForDeleteBody tenv env originalT ty (TC.getFields value)
|
||||
body _ = toTemplate "/* template error! */"
|
||||
|
||||
deps :: TG.DepenGenerator TC.TypeCandidate
|
||||
deps GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [ty] _ _), value} =
|
||||
deps GeneratorArg {tenv, env, originalT, instanceT = (FuncTy [ty] _ _), value} =
|
||||
depsForDelete tenv env originalT ty (TC.getFields value)
|
||||
deps _ = []
|
||||
|
||||
@ -230,7 +227,7 @@ binderForDelete candidate =
|
||||
binderForCopy :: BinderGenDeps
|
||||
binderForCopy candidate =
|
||||
let t = TC.toType candidate
|
||||
doc = "copies a `" ++ (TC.getName candidate) ++ "`."
|
||||
doc = "copies a `" ++ (TC.getName candidate) ++ "`."
|
||||
binderT = FuncTy [RefTy t (VarTy "q")] t StaticLifetimeTy
|
||||
binderP = SymPath (TC.getFullPath candidate) "copy"
|
||||
in Right $
|
||||
@ -248,12 +245,12 @@ binderForCopy candidate =
|
||||
decl _ = toTemplate "$p $NAME($p* pRef)"
|
||||
|
||||
body :: TG.TokenGenerator TC.TypeCandidate
|
||||
body GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [RefTy ty _] _ _), value} =
|
||||
body GeneratorArg {tenv, env, originalT, instanceT = (FuncTy [RefTy ty _] _ _), value} =
|
||||
tokensForSumtypeCopy tenv env originalT ty (TC.getFields value)
|
||||
body _ = toTemplate "/* template error! */"
|
||||
|
||||
deps :: TG.DepenGenerator TC.TypeCandidate
|
||||
deps GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [RefTy ty _] _ _), value} =
|
||||
deps GeneratorArg {tenv, env, originalT, instanceT = (FuncTy [RefTy ty _] _ _), value} =
|
||||
depsForCopy tenv env originalT ty (TC.getFields value)
|
||||
deps _ = []
|
||||
|
||||
@ -261,7 +258,8 @@ binderForCopy candidate =
|
||||
-- Token and dep generators
|
||||
|
||||
type TokenGen = TypeEnv -> Env -> Ty -> Ty -> [TC.TypeField] -> [Token]
|
||||
type DepGen = TypeEnv -> Env -> Ty -> Ty -> [TC.TypeField] -> [XObj]
|
||||
|
||||
type DepGen = TypeEnv -> Env -> Ty -> Ty -> [TC.TypeField] -> [XObj]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Initializers
|
||||
@ -269,7 +267,7 @@ type DepGen = TypeEnv -> Env -> Ty -> Ty -> [TC.TypeField] -> [XObj]
|
||||
-- | Generate an init function declaration.
|
||||
tokensForCaseInitDecl :: Ty -> Ty -> TC.TypeField -> [Token]
|
||||
tokensForCaseInitDecl orig concrete@(StructTy (ConcreteNameTy _) _) (TC.SumField _ tys) =
|
||||
let mappings = unifySignatures orig concrete
|
||||
let mappings = unifySignatures orig concrete
|
||||
concreteTys = map (replaceTyVars mappings) tys
|
||||
in toTemplate ("$p $NAME(" ++ joinWithComma (zipWith (curry memberArg) anonMemberNames (remove isUnit concreteTys)) ++ ")")
|
||||
tokensForCaseInitDecl _ _ _ =
|
||||
@ -279,24 +277,25 @@ tokensForCaseInitDecl _ _ _ =
|
||||
-- concrete type and a sum type field, generate an init function body.
|
||||
tokensForCaseInit :: AllocationMode -> Ty -> Ty -> TC.TypeField -> [Token]
|
||||
tokensForCaseInit alloc orig concrete (TC.SumField fieldname tys) =
|
||||
let mappings = unifySignatures orig concrete
|
||||
let mappings = unifySignatures orig concrete
|
||||
concreteTys = map (replaceTyVars mappings) tys
|
||||
unitless = zip anonMemberNames $ remove isUnit concreteTys
|
||||
in multilineTemplate
|
||||
[ "$DECL {",
|
||||
allocate alloc,
|
||||
joinLines (assign alloc fieldname . fst <$> unitless),
|
||||
" instance._tag = " ++ tagName concrete fieldname ++ ";",
|
||||
" return instance;",
|
||||
"}"
|
||||
]
|
||||
where allocate :: AllocationMode -> String
|
||||
allocate StackAlloc = " $p instance;"
|
||||
allocate HeapAlloc = " $p instance = CARP_MALLOC(sizeof(" ++ show concrete ++ "));"
|
||||
[ "$DECL {",
|
||||
allocate alloc,
|
||||
joinLines (assign alloc fieldname . fst <$> unitless),
|
||||
" instance._tag = " ++ tagName concrete fieldname ++ ";",
|
||||
" return instance;",
|
||||
"}"
|
||||
]
|
||||
where
|
||||
allocate :: AllocationMode -> String
|
||||
allocate StackAlloc = " $p instance;"
|
||||
allocate HeapAlloc = " $p instance = CARP_MALLOC(sizeof(" ++ show concrete ++ "));"
|
||||
|
||||
assign :: AllocationMode -> String -> String -> String
|
||||
assign alloc' name member =
|
||||
" instance" ++ (accessor alloc') ++ "u." ++ name ++ "." ++ member ++ " = " ++ member ++ ";"
|
||||
assign :: AllocationMode -> String -> String -> String
|
||||
assign alloc' name member =
|
||||
" instance" ++ (accessor alloc') ++ "u." ++ name ++ "." ++ member ++ " = " ++ member ++ ";"
|
||||
tokensForCaseInit _ _ _ _ = error "tokenForCaseInit"
|
||||
|
||||
accessor :: AllocationMode -> String
|
||||
@ -352,30 +351,32 @@ tokensForDeleteBody :: TokenGen
|
||||
tokensForDeleteBody tenv env generic concrete fields =
|
||||
let mappings = unifySignatures generic concrete
|
||||
concreteFields = replaceGenericTypesOnCases mappings fields
|
||||
in multilineTemplate [
|
||||
"$DECL {",
|
||||
concatMap deleteCase (zip concreteFields (True : repeat False)),
|
||||
"}"
|
||||
]
|
||||
where deleteCase :: (TC.TypeField, Bool) -> String
|
||||
deleteCase (theCase, isFirstCase) =
|
||||
let (name, tys, correctedTagName) = namesFromCase theCase concrete
|
||||
in unlines
|
||||
[ " " ++ (if isFirstCase then "" else "else ") ++ "if(p._tag == " ++ correctedTagName ++ ") {",
|
||||
joinLines $ memberDeletion tenv env <$> unionMembers name tys,
|
||||
" }"
|
||||
]
|
||||
in multilineTemplate
|
||||
[ "$DECL {",
|
||||
concatMap deleteCase (zip concreteFields (True : repeat False)),
|
||||
"}"
|
||||
]
|
||||
where
|
||||
deleteCase :: (TC.TypeField, Bool) -> String
|
||||
deleteCase (theCase, isFirstCase) =
|
||||
let (name, tys, correctedTagName) = namesFromCase theCase concrete
|
||||
in unlines
|
||||
[ " " ++ (if isFirstCase then "" else "else ") ++ "if(p._tag == " ++ correctedTagName ++ ") {",
|
||||
joinLines $ memberDeletion tenv env <$> unionMembers name tys,
|
||||
" }"
|
||||
]
|
||||
|
||||
-- | Generates deps for the body of a delete function.
|
||||
depsForDelete :: TypeEnv -> Env -> Ty -> Ty -> [TC.TypeField] -> [XObj]
|
||||
depsForDelete tenv env generic concrete fields =
|
||||
let mappings = unifySignatures generic concrete
|
||||
let mappings = unifySignatures generic concrete
|
||||
concreteFields = replaceGenericTypesOnCases mappings fields
|
||||
in if isTypeGeneric concrete
|
||||
then []
|
||||
else concatMap
|
||||
(depsOfPolymorphicFunction tenv env [] "delete" . typesDeleterFunctionType)
|
||||
(filter (isManaged tenv env) (concatMap (TC.fieldTypes) concreteFields))
|
||||
else
|
||||
concatMap
|
||||
(depsOfPolymorphicFunction tenv env [] "delete" . typesDeleterFunctionType)
|
||||
(filter (isManaged tenv env) (concatMap (TC.fieldTypes) concreteFields))
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Str and prn
|
||||
@ -409,32 +410,31 @@ tokensForStr typeEnv env generic concrete fields =
|
||||
" return buffer;",
|
||||
"}"
|
||||
]
|
||||
where strCase :: TC.TypeField -> String
|
||||
strCase theCase =
|
||||
let (name, tys, correctedTagName) = namesFromCase theCase concrete
|
||||
in unlines
|
||||
[ " if(p->_tag == " ++ correctedTagName ++ ") {",
|
||||
" sprintf(bufferPtr, \"(%s \", \"" ++ name ++ "\");",
|
||||
" bufferPtr += strlen(\"" ++ name ++ "\") + 2;\n",
|
||||
joinLines $ memberPrn typeEnv env <$> unionMembers name tys,
|
||||
" bufferPtr--;",
|
||||
" sprintf(bufferPtr, \")\");",
|
||||
" }"
|
||||
]
|
||||
where
|
||||
strCase :: TC.TypeField -> String
|
||||
strCase theCase =
|
||||
let (name, tys, correctedTagName) = namesFromCase theCase concrete
|
||||
in unlines
|
||||
[ " if(p->_tag == " ++ correctedTagName ++ ") {",
|
||||
" sprintf(bufferPtr, \"(%s \", \"" ++ name ++ "\");",
|
||||
" bufferPtr += strlen(\"" ++ name ++ "\") + 2;\n",
|
||||
joinLines $ memberPrn typeEnv env <$> unionMembers name tys,
|
||||
" bufferPtr--;",
|
||||
" sprintf(bufferPtr, \")\");",
|
||||
" }"
|
||||
]
|
||||
calculateStructStrSize :: [TC.TypeField] -> String
|
||||
calculateStructStrSize cases = " int size = 1;\n" ++ concatMap strSizeCase cases
|
||||
|
||||
-- | Figure out how big the string needed for the string representation of the struct has to be.
|
||||
calculateStructStrSize :: [TC.TypeField] -> String
|
||||
calculateStructStrSize cases = " int size = 1;\n" ++ concatMap strSizeCase cases
|
||||
|
||||
strSizeCase :: TC.TypeField -> String
|
||||
strSizeCase theCase =
|
||||
let (name, tys, correctedTagName) = namesFromCase theCase concrete
|
||||
in unlines
|
||||
[ " if(p->_tag == " ++ correctedTagName ++ ") {",
|
||||
" size += snprintf(NULL, 0, \"(%s \", \"" ++ name ++ "\");",
|
||||
joinLines $ memberPrnSize typeEnv env <$> unionMembers name tys,
|
||||
" }"
|
||||
]
|
||||
strSizeCase :: TC.TypeField -> String
|
||||
strSizeCase theCase =
|
||||
let (name, tys, correctedTagName) = namesFromCase theCase concrete
|
||||
in unlines
|
||||
[ " if(p->_tag == " ++ correctedTagName ++ ") {",
|
||||
" size += snprintf(NULL, 0, \"(%s \", \"" ++ name ++ "\");",
|
||||
joinLines $ memberPrnSize typeEnv env <$> unionMembers name tys,
|
||||
" }"
|
||||
]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Additional utilities
|
||||
|
||||
@ -3,8 +3,8 @@
|
||||
module TemplateGenerator where
|
||||
|
||||
import Obj
|
||||
import Types
|
||||
import qualified TypeCandidate as TC
|
||||
import Types
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Template Generators
|
||||
@ -12,36 +12,39 @@ import qualified TypeCandidate as TC
|
||||
-- Template generators define a standardized way to construct templates given a fixed set of arguments.
|
||||
|
||||
-- | GeneratorArg is an argument to a template generator.
|
||||
data GeneratorArg a = GeneratorArg {
|
||||
tenv :: TypeEnv,
|
||||
env :: Env,
|
||||
originalT :: Ty,
|
||||
instanceT :: Ty,
|
||||
value :: a
|
||||
}
|
||||
data GeneratorArg a = GeneratorArg
|
||||
{ tenv :: TypeEnv,
|
||||
env :: Env,
|
||||
originalT :: Ty,
|
||||
instanceT :: Ty,
|
||||
value :: a
|
||||
}
|
||||
|
||||
type TypeGenerator a = GeneratorArg a -> Ty
|
||||
|
||||
type TypeGenerator a = GeneratorArg a -> Ty
|
||||
type TokenGenerator a = GeneratorArg a -> [Token]
|
||||
|
||||
type DepenGenerator a = GeneratorArg a -> [XObj]
|
||||
|
||||
data TemplateGenerator a = TemplateGenerator {
|
||||
genT :: TypeGenerator a,
|
||||
decl :: TokenGenerator a,
|
||||
body :: TokenGenerator a,
|
||||
deps :: DepenGenerator a
|
||||
}
|
||||
data TemplateGenerator a = TemplateGenerator
|
||||
{ genT :: TypeGenerator a,
|
||||
decl :: TokenGenerator a,
|
||||
body :: TokenGenerator a,
|
||||
deps :: DepenGenerator a
|
||||
}
|
||||
|
||||
mkTemplateGenerator :: TypeGenerator a -> TokenGenerator a -> TokenGenerator a -> DepenGenerator a -> TemplateGenerator a
|
||||
mkTemplateGenerator f g h j = TemplateGenerator f g h j
|
||||
|
||||
generateConcreteTypeTemplate :: TC.TypeCandidate -> TemplateGenerator TC.TypeCandidate -> Template
|
||||
generateConcreteTypeTemplate candidate gen =
|
||||
let arg = GeneratorArg
|
||||
(TC.getTypeEnv candidate)
|
||||
(TC.getValueEnv candidate)
|
||||
(TC.toType candidate)
|
||||
(TC.toType candidate)
|
||||
candidate
|
||||
let arg =
|
||||
GeneratorArg
|
||||
(TC.getTypeEnv candidate)
|
||||
(TC.getValueEnv candidate)
|
||||
(TC.toType candidate)
|
||||
(TC.toType candidate)
|
||||
candidate
|
||||
t = (genT gen) $ arg
|
||||
d = (\tt -> (decl gen) $ (arg {instanceT = tt}))
|
||||
b = (\tt -> (body gen) $ (arg {instanceT = tt}))
|
||||
@ -50,12 +53,13 @@ generateConcreteTypeTemplate candidate gen =
|
||||
|
||||
generateConcreteFieldTemplate :: TC.TypeCandidate -> TC.TypeField -> TemplateGenerator TC.TypeField -> Template
|
||||
generateConcreteFieldTemplate candidate field gen =
|
||||
let arg = GeneratorArg
|
||||
(TC.getTypeEnv candidate)
|
||||
(TC.getValueEnv candidate)
|
||||
(TC.toType candidate)
|
||||
(TC.toType candidate)
|
||||
field
|
||||
let arg =
|
||||
GeneratorArg
|
||||
(TC.getTypeEnv candidate)
|
||||
(TC.getValueEnv candidate)
|
||||
(TC.toType candidate)
|
||||
(TC.toType candidate)
|
||||
field
|
||||
t = (genT gen) $ arg
|
||||
d = (\tt -> (decl gen) $ (arg {instanceT = tt}))
|
||||
b = (\tt -> (body gen) $ (arg {instanceT = tt}))
|
||||
@ -64,12 +68,13 @@ generateConcreteFieldTemplate candidate field gen =
|
||||
|
||||
generateGenericFieldTemplate :: TC.TypeCandidate -> TC.TypeField -> TemplateGenerator TC.TypeField -> TemplateCreator
|
||||
generateGenericFieldTemplate candidate field gen =
|
||||
let arg = GeneratorArg
|
||||
(TC.getTypeEnv candidate)
|
||||
(TC.getValueEnv candidate)
|
||||
(TC.toType candidate)
|
||||
(TC.toType candidate)
|
||||
field
|
||||
let arg =
|
||||
GeneratorArg
|
||||
(TC.getTypeEnv candidate)
|
||||
(TC.getValueEnv candidate)
|
||||
(TC.toType candidate)
|
||||
(TC.toType candidate)
|
||||
field
|
||||
t = (genT gen) arg
|
||||
in TemplateCreator $
|
||||
\tenv env ->
|
||||
@ -81,12 +86,13 @@ generateGenericFieldTemplate candidate field gen =
|
||||
|
||||
generateGenericTypeTemplate :: TC.TypeCandidate -> TemplateGenerator TC.TypeCandidate -> TemplateCreator
|
||||
generateGenericTypeTemplate candidate gen =
|
||||
let arg = GeneratorArg
|
||||
(TC.getTypeEnv candidate)
|
||||
(TC.getValueEnv candidate)
|
||||
(TC.toType candidate)
|
||||
(TC.toType candidate)
|
||||
candidate
|
||||
let arg =
|
||||
GeneratorArg
|
||||
(TC.getTypeEnv candidate)
|
||||
(TC.getValueEnv candidate)
|
||||
(TC.toType candidate)
|
||||
(TC.toType candidate)
|
||||
candidate
|
||||
t = (genT gen) arg
|
||||
in TemplateCreator $
|
||||
\tenv env ->
|
||||
|
||||
@ -2,33 +2,33 @@
|
||||
--
|
||||
-- Type candidates can either be valid or invalid. Invalid type candidates will be rejected by the type system.
|
||||
module TypeCandidate
|
||||
(mkStructCandidate,
|
||||
mkSumtypeCandidate,
|
||||
TypeVarRestriction(..),
|
||||
InterfaceConstraint(..),
|
||||
TypeField(..),
|
||||
TypeMode(..),
|
||||
getFields,
|
||||
TypeCandidate.getName,
|
||||
getRestriction,
|
||||
getVariables,
|
||||
TypeCandidate.getTypeEnv,
|
||||
getConstraints,
|
||||
getValueEnv,
|
||||
getMode,
|
||||
TypeCandidate.getPath,
|
||||
getFullPath,
|
||||
fieldName,
|
||||
fieldTypes,
|
||||
setRestriction,
|
||||
toType,
|
||||
TypeCandidate,
|
||||
( mkStructCandidate,
|
||||
mkSumtypeCandidate,
|
||||
TypeVarRestriction (..),
|
||||
InterfaceConstraint (..),
|
||||
TypeField (..),
|
||||
TypeMode (..),
|
||||
getFields,
|
||||
TypeCandidate.getName,
|
||||
getRestriction,
|
||||
getVariables,
|
||||
TypeCandidate.getTypeEnv,
|
||||
getConstraints,
|
||||
getValueEnv,
|
||||
getMode,
|
||||
TypeCandidate.getPath,
|
||||
getFullPath,
|
||||
fieldName,
|
||||
fieldTypes,
|
||||
setRestriction,
|
||||
toType,
|
||||
TypeCandidate,
|
||||
)
|
||||
where
|
||||
|
||||
import Types
|
||||
import TypeError
|
||||
import Obj
|
||||
import TypeError
|
||||
import Types
|
||||
import Util
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
@ -37,12 +37,13 @@ import Util
|
||||
data TypeVarRestriction
|
||||
= AllowAny
|
||||
| OnlyNamesInScope
|
||||
deriving Eq
|
||||
deriving (Eq)
|
||||
|
||||
data InterfaceConstraint = InterfaceConstraint {
|
||||
name :: String,
|
||||
types :: Ty
|
||||
} deriving Show
|
||||
data InterfaceConstraint = InterfaceConstraint
|
||||
{ name :: String,
|
||||
types :: Ty
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data TypeField
|
||||
= StructField String Ty
|
||||
@ -54,17 +55,17 @@ data TypeMode
|
||||
| Sum
|
||||
deriving (Eq, Show)
|
||||
|
||||
data TypeCandidate = TypeCandidate {
|
||||
typeName :: String,
|
||||
variables :: [Ty],
|
||||
members :: [TypeField],
|
||||
restriction :: TypeVarRestriction,
|
||||
constraints :: [InterfaceConstraint],
|
||||
typeEnv :: TypeEnv,
|
||||
valueEnv :: Env,
|
||||
mode :: TypeMode,
|
||||
path :: [String]
|
||||
}
|
||||
data TypeCandidate = TypeCandidate
|
||||
{ typeName :: String,
|
||||
variables :: [Ty],
|
||||
members :: [TypeField],
|
||||
restriction :: TypeVarRestriction,
|
||||
constraints :: [InterfaceConstraint],
|
||||
typeEnv :: TypeEnv,
|
||||
valueEnv :: Env,
|
||||
mode :: TypeMode,
|
||||
path :: [String]
|
||||
}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Private
|
||||
@ -137,17 +138,18 @@ fieldTypes (SumField _ ts) = ts
|
||||
mkStructCandidate :: String -> [Ty] -> TypeEnv -> Env -> [XObj] -> [String] -> Either TypeError TypeCandidate
|
||||
mkStructCandidate tname vars tenv env memberxs ps =
|
||||
let typedMembers = mapM mkStructField (pairwise memberxs)
|
||||
candidate = TypeCandidate {
|
||||
typeName = tname,
|
||||
variables = vars,
|
||||
members = [],
|
||||
restriction = OnlyNamesInScope,
|
||||
constraints = [],
|
||||
typeEnv = tenv,
|
||||
valueEnv = env,
|
||||
mode = Struct,
|
||||
path = ps
|
||||
}
|
||||
candidate =
|
||||
TypeCandidate
|
||||
{ typeName = tname,
|
||||
variables = vars,
|
||||
members = [],
|
||||
restriction = OnlyNamesInScope,
|
||||
constraints = [],
|
||||
typeEnv = tenv,
|
||||
valueEnv = env,
|
||||
mode = Struct,
|
||||
path = ps
|
||||
}
|
||||
in if even (length memberxs)
|
||||
then fmap (setMembers candidate) typedMembers
|
||||
else Left (UnevenMembers memberxs)
|
||||
@ -156,17 +158,18 @@ mkStructCandidate tname vars tenv env memberxs ps =
|
||||
mkSumtypeCandidate :: String -> [Ty] -> TypeEnv -> Env -> [XObj] -> [String] -> Either TypeError TypeCandidate
|
||||
mkSumtypeCandidate tname vars tenv env memberxs ps =
|
||||
let typedMembers = mapM mkSumField memberxs
|
||||
candidate = TypeCandidate {
|
||||
typeName = tname,
|
||||
variables = vars,
|
||||
members = [],
|
||||
restriction = OnlyNamesInScope,
|
||||
constraints = [],
|
||||
typeEnv = tenv,
|
||||
valueEnv = env,
|
||||
mode = Sum,
|
||||
path = ps
|
||||
}
|
||||
candidate =
|
||||
TypeCandidate
|
||||
{ typeName = tname,
|
||||
variables = vars,
|
||||
members = [],
|
||||
restriction = OnlyNamesInScope,
|
||||
constraints = [],
|
||||
typeEnv = tenv,
|
||||
valueEnv = env,
|
||||
mode = Sum,
|
||||
path = ps
|
||||
}
|
||||
in fmap (setMembers candidate) typedMembers
|
||||
|
||||
toType :: TypeCandidate -> Ty
|
||||
|
||||
@ -4,11 +4,11 @@ import Control.Monad (foldM)
|
||||
import Data.List (nubBy, (\\))
|
||||
import qualified Env as E
|
||||
import Obj
|
||||
import qualified Reify as R
|
||||
import qualified TypeCandidate as TC
|
||||
import TypeError
|
||||
import TypePredicates
|
||||
import Types
|
||||
import qualified TypeCandidate as TC
|
||||
import qualified Reify as R
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Public
|
||||
@ -16,9 +16,10 @@ import qualified Reify as R
|
||||
-- | Determine whether a given type candidate is a valid type.
|
||||
validateType :: TC.TypeCandidate -> Either TypeError ()
|
||||
validateType candidate =
|
||||
do checkDuplicateMembers candidate
|
||||
checkMembers candidate
|
||||
checkKindConsistency candidate
|
||||
do
|
||||
checkDuplicateMembers candidate
|
||||
checkMembers candidate
|
||||
checkKindConsistency candidate
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Private
|
||||
@ -36,16 +37,16 @@ checkDuplicateMembers candidate =
|
||||
-- | Returns an error if one of the types fields can't be used as a member type.
|
||||
checkMembers :: TC.TypeCandidate -> Either TypeError ()
|
||||
checkMembers candidate =
|
||||
let tenv = TC.getTypeEnv candidate
|
||||
env = TC.getValueEnv candidate
|
||||
tys = concat (map TC.fieldTypes (TC.getFields candidate))
|
||||
in mapM_ (canBeUsedAsMemberType (TC.getName candidate) (TC.getRestriction candidate) tenv env (TC.getVariables candidate)) tys
|
||||
let tenv = TC.getTypeEnv candidate
|
||||
env = TC.getValueEnv candidate
|
||||
tys = concat (map TC.fieldTypes (TC.getFields candidate))
|
||||
in mapM_ (canBeUsedAsMemberType (TC.getName candidate) (TC.getRestriction candidate) tenv env (TC.getVariables candidate)) tys
|
||||
|
||||
-- | Returns an error if the type variables in the body of the type and variables in the head of the type are of incompatible kinds.
|
||||
checkKindConsistency :: TC.TypeCandidate -> Either TypeError ()
|
||||
checkKindConsistency candidate =
|
||||
let allFieldTypes = concat (map TC.fieldTypes (TC.getFields candidate))
|
||||
allGenerics = filter isTypeGeneric $ allFieldTypes
|
||||
allGenerics = filter isTypeGeneric $ allFieldTypes
|
||||
in case areKindsConsistent allGenerics of
|
||||
Left var -> Left (InconsistentKinds var (map R.reify allFieldTypes))
|
||||
_ -> pure ()
|
||||
|
||||
Loading…
Reference in New Issue
Block a user