diff --git a/src/BoxTemplates.hs b/src/BoxTemplates.hs index 2065df37e..2ef6803b0 100644 --- a/src/BoxTemplates.hs +++ b/src/BoxTemplates.hs @@ -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 _ _ _ = "" - diff --git a/src/Concretize.hs b/src/Concretize.hs index 4d224c099..0fdb21707 100644 --- a/src/Concretize.hs +++ b/src/Concretize.hs @@ -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 = diff --git a/src/Deftype.hs b/src/Deftype.hs index 47d784348..ecb5e67d2 100644 --- a/src/Deftype.hs +++ b/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) - - 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! */" - - 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 _ = [] + 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)" + + 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 _ = [] -- | 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) - - 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! */" - - 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 _ = [] + 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)" + + 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 _ = [] -- | 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) - - 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! */" - - 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 _ = [] + 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) + 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 _ = [] -- | 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) - - 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! */" - - 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;", - "}" - ] - - 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 + 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! */" + + 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 _ = [] + + 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 + + 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 - - 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! */" - - 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) + 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! */" + + 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 _ = [] + + 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 - - 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! */" - - 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 _ = [] + where + genT :: TG.TypeGenerator TC.TypeCandidate + genT _ = FuncTy [VarTy "p"] UnitTy StaticLifetimeTy + + 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! */" + + 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 - - 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! */" - - 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 _ = [] + 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)" + + 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 _ = [] -------------------------------------------------------------------------------- -- 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. diff --git a/src/Emit.hs b/src/Emit.hs index 508733814..9487b5cb4 100644 --- a/src/Emit.hs +++ b/src/Emit.hs @@ -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 diff --git a/src/Env.hs b/src/Env.hs index 866c7244c..cc5fa03d2 100644 --- a/src/Env.hs +++ b/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 diff --git a/src/Primitives.hs b/src/Primitives.hs index 72bc9e9af..e555b56e1 100644 --- a/src/Primitives.hs +++ b/src/Primitives.hs @@ -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] diff --git a/src/StartingEnv.hs b/src/StartingEnv.hs index fc890a526..7770cac38 100644 --- a/src/StartingEnv.hs +++ b/src/StartingEnv.hs @@ -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 diff --git a/src/Sumtypes.hs b/src/Sumtypes.hs index 60252cbc0..634ca4b96 100644 --- a/src/Sumtypes.hs +++ b/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 ++ "));" - - assign :: AllocationMode -> String -> String -> String - assign alloc' name member = - " instance" ++ (accessor alloc') ++ "u." ++ name ++ "." ++ member ++ " = " ++ member ++ ";" + [ "$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 ++ ";" 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, \")\");", - " }" - ] - - -- | 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, - " }" - ] + 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 + + 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 diff --git a/src/TemplateGenerator.hs b/src/TemplateGenerator.hs index 5a68bc20f..2d722fc1c 100644 --- a/src/TemplateGenerator.hs +++ b/src/TemplateGenerator.hs @@ -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 -> diff --git a/src/TypeCandidate.hs b/src/TypeCandidate.hs index c00e4192d..7c41e9652 100644 --- a/src/TypeCandidate.hs +++ b/src/TypeCandidate.hs @@ -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 diff --git a/src/Validate.hs b/src/Validate.hs index 75e41fd9e..b98c4ec1f 100644 --- a/src/Validate.hs +++ b/src/Validate.hs @@ -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 ()