From d82e8a5a3f446da59aef917cb7e26fb8b466b4bb Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Mon, 20 Dec 2021 09:41:14 -0500 Subject: [PATCH] refactor: add type candidates and template generators (#1361) * refactor: add type candidates for validation This commit adds a new module and type, the TypeCandidate, which represents a potentially valid or invalid type. We use it as the input for both type validation routines and type binding generation. The type also allows us to unify the structure of sum types and product types in an xobj agnostic way, paving the way for future simplification of binding generation for type definitions. This commit also removes SumtypeCase.hs, since it's no longer needed. * refactor: add template generators; update type templates This commit builds on the TypeCandidate data structure further by providing "template generators" that work on candidates. Using generators, templates for type functions ("methods") can be written almost completely declaratively. Generators also remove some of the typical boilerplate involved in creating templates from lists of tokens and enable us to unify several of the generic and concrete templates for types. Generators can act on type candidates or their fields (for field-specific functions). In general, this approach makes the generation of type templates more structured. A type candidate now contains all the information a generator needs to create appropriate templates, thus it is a single and well-defined input for validation and generation of user defined types. This commit also updates the Deftype templates to use template generators. * refactor: use template generators for sumtype templates --- CarpHask.cabal | 3 +- src/Concretize.hs | 54 +- src/Deftype.hs | 968 ++++++++---------- src/SumtypeCase.hs | 41 - src/Sumtypes.hs | 732 ++++++------- src/TemplateGenerator.hs | 97 ++ src/TypeCandidate.hs | 174 ++++ src/TypeError.hs | 5 + src/Validate.hs | 124 +-- ...type_var_not_in_scope.carp.output.expected | 2 +- ...type_var_not_in_scope.carp.output.expected | 2 +- 11 files changed, 1168 insertions(+), 1034 deletions(-) delete mode 100644 src/SumtypeCase.hs create mode 100644 src/TemplateGenerator.hs create mode 100644 src/TypeCandidate.hs diff --git a/CarpHask.cabal b/CarpHask.cabal index 5ca26b43..061af81b 100644 --- a/CarpHask.cabal +++ b/CarpHask.cabal @@ -56,11 +56,12 @@ library StartingEnv, StaticArrayTemplates, StructUtils, - SumtypeCase, Sumtypes, SymPath, Template, + TemplateGenerator, ToTemplate, + TypeCandidate, TypeError, TypePredicates, Types, diff --git a/src/Concretize.hs b/src/Concretize.hs index 7b4a5462..4d224c09 100644 --- a/src/Concretize.hs +++ b/src/Concretize.hs @@ -19,6 +19,7 @@ module Concretize tokensForCopy, memberCopy, replaceGenericTypeSymbolsOnMembers, + replaceGenericTypeSymbolsOnFields, ) where @@ -41,7 +42,6 @@ import Obj import Polymorphism import Reify import qualified Set -import SumtypeCase import ToTemplate import TypeError import TypePredicates @@ -50,6 +50,7 @@ import TypesToC import Util import Validate import Prelude hiding (lookup) +import qualified TypeCandidate as TC data Level = Toplevel | Inside @@ -612,7 +613,9 @@ instantiateGenericStructType typeEnv env originalStructTy@(StructTy _ _) generic let nameFixedMembers = renameGenericTypeSymbolsOnProduct renamedOrig memberXObjs validMembers = replaceGenericTypeSymbolsOnMembers mappings' nameFixedMembers concretelyTypedMembers = replaceGenericTypeSymbolsOnMembers mappings memberXObjs - validateMembers AllowAnyTypeVariableNames typeEnv env renamedOrig validMembers + sname = getStructName originalStructTy + candidate <- TC.mkStructCandidate sname renamedOrig typeEnv env validMembers (getPathFromStructName sname) + validateType (TC.setRestriction candidate TC.AllowAny) deps <- mapM (depsForStructMemberPair typeEnv env) (pairwise concretelyTypedMembers) let xobj = XObj @@ -640,29 +643,24 @@ instantiateGenericSumtype typeEnv env originalStructTy@(StructTy _ originalTyVar let fake1 = XObj (Sym (SymPath [] "a") Symbol) Nothing Nothing fake2 = XObj (Sym (SymPath [] "b") Symbol) Nothing Nothing rename@(StructTy _ renamedOrig) = evalState (renameVarTys originalStructTy) 0 - in case solve [Constraint rename genericStructTy fake1 fake2 fake1 OrdMultiSym] of - Left e -> error (show e) - Right mappings -> - let nameFixedCases = map (renameGenericTypeSymbolsOnSum (zip originalTyVars renamedOrig)) cases - concretelyTypedCases = map (replaceGenericTypeSymbolsOnCase mappings) nameFixedCases - deps = mapM (depsForCase typeEnv env) concretelyTypedCases - in case toCases typeEnv env AllowAnyTypeVariableNames renamedOrig concretelyTypedCases of -- Don't care about the cases, this is done just for validation. - Left err -> Left err - Right _ -> - case deps of - Right okDeps -> - Right $ - XObj - ( Lst - ( XObj (DefSumtype genericStructTy) Nothing Nothing : - XObj (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing : - concretelyTypedCases - ) - ) - (Just dummyInfo) - (Just TypeTy) : - concat okDeps - Left err -> Left err + 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) instantiateGenericSumtype _ _ _ _ _ = error "instantiategenericsumtype" -- Resolves dependencies for sumtype cases. @@ -677,6 +675,12 @@ depsForCase typeEnv env (XObj (Lst [_, XObj (Arr members) _ _]) _ _) = members 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)) + replaceGenericTypeSymbolsOnMembers :: Map.Map String Ty -> [XObj] -> [XObj] replaceGenericTypeSymbolsOnMembers mappings memberXObjs = concatMap (\(v, t) -> [v, replaceGenericTypeSymbols mappings t]) (pairwise memberXObjs) diff --git a/src/Deftype.hs b/src/Deftype.hs index 1ab08b36..47d78434 100644 --- a/src/Deftype.hs +++ b/src/Deftype.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} module Deftype ( moduleForDeftype, moduleForDeftypeInContext, bindingsForRegisteredType, + fieldArg, memberArg, ) where @@ -24,6 +25,8 @@ import Types import TypesToC import Util import Validate +import qualified TypeCandidate as TC +import TemplateGenerator as TG {-# ANN module "HLint: ignore Reduce duplication" #-} @@ -56,9 +59,6 @@ moduleForDeftype :: Maybe Env -> TypeEnv -> Env -> [String] -> String -> [Ty] -> moduleForDeftype innerEnv typeEnv env pathStrings typeName typeVariables rest i existingEnv = let moduleValueEnv = fromMaybe (new innerEnv (Just typeName)) (fmap fst existingEnv) moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv) - -- The variable 'insidePath' is the path used for all member functions inside the 'typeModule'. - -- For example (module Vec2 [x Float]) creates bindings like Vec2.create, Vec2.x, etc. - insidePath = pathStrings ++ [typeName] 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. @@ -66,18 +66,17 @@ moduleForDeftype innerEnv typeEnv env pathStrings typeName typeVariables rest i [(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 - validateMemberCases typeEnv env typeVariables rest - let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables - (okMembers, membersDeps) <- templatesForMembers typeEnv env insidePath structTy rest - okInit <- binderForInit insidePath structTy initmembers - (okStr, strDeps) <- binderForStrOrPrn typeEnv env insidePath structTy rest "str" - (okPrn, _) <- binderForStrOrPrn typeEnv env insidePath structTy rest "prn" - (okDelete, deleteDeps) <- binderForDelete typeEnv env insidePath structTy rest - (okCopy, copyDeps) <- binderForCopy typeEnv env insidePath structTy rest - let funcs = okInit : okStr : okPrn : okDelete : okCopy : okMembers - moduleEnvWithBindings = addListOfBindings moduleValueEnv funcs + let mems = case initmembers of + [(XObj (Arr ms)_ _)] -> ms + _ -> [] + -- Check that this is a valid type definition. + candidate <- TC.mkStructCandidate typeName typeVariables typeEnv env mems pathStrings + validateType candidate + -- Generate standard function bindings for the type. + (funcs, deps) <- generateTypeBindings candidate + -- Add the type and bindings to the environment. + let moduleEnvWithBindings = addListOfBindings moduleValueEnv funcs typeModuleXObj = XObj (Mod moduleEnvWithBindings moduleTypeEnv) i (Just ModuleTy) - deps = deleteDeps ++ membersDeps ++ copyDeps ++ strDeps pure (typeName, typeModuleXObj, deps) -- | Will generate getters/setters/updaters when registering EXTERNAL types. @@ -87,28 +86,48 @@ bindingsForRegisteredType :: TypeEnv -> Env -> [String] -> String -> [XObj] -> M bindingsForRegisteredType typeEnv env pathStrings typeName rest i existingEnv = let moduleValueEnv = fromMaybe (new (Just env) (Just typeName)) (fmap fst existingEnv) moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv) - insidePath = pathStrings ++ [typeName] in do - validateMemberCases typeEnv env [] rest - let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) [] - (binders, deps) <- templatesForMembers typeEnv env insidePath structTy rest - okInit <- binderForInit insidePath structTy rest - (okStr, strDeps) <- binderForStrOrPrn typeEnv env insidePath structTy rest "str" - (okPrn, _) <- binderForStrOrPrn typeEnv env insidePath structTy rest "prn" + let mems = case rest of + [(XObj (Arr ms)_ _)] -> ms + _ -> [] + -- Check that this is a valid type definition. + candidate <- TC.mkStructCandidate typeName [] typeEnv env mems pathStrings + validateType candidate + -- Generate function bindings for the registered type. + (binders, deps) <- templatesForMembers candidate + okInit <- binderForInit candidate + (okStr, strDeps) <- binderForStrOrPrn "str" candidate + (okPrn, _) <- binderForStrOrPrn "prn" candidate + -- Add the type and bindings to the environment. let moduleEnvWithBindings = addListOfBindings moduleValueEnv (okInit : okStr : okPrn : binders) typeModuleXObj = XObj (Mod moduleEnvWithBindings moduleTypeEnv) i (Just ModuleTy) pure (typeName, typeModuleXObj, deps ++ strDeps) +-------------------------------------------------------------------------------- +-- Binding creators + +-- | 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)) + -- | Generate all the templates for ALL the member variables in a deftype declaration. -templatesForMembers :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> Either TypeError ([(String, Binder)], [XObj]) -templatesForMembers typeEnv env insidePath structTy [XObj (Arr membersXobjs) _ _] = - let bindersAndDeps = concatMap (templatesForSingleMember typeEnv env insidePath structTy) (pairwise membersXobjs) +templatesForMembers :: TC.TypeCandidate -> Either TypeError ([(String, Binder)], [XObj]) +templatesForMembers candidate = + let bindersAndDeps = concatMap (templatesForSingleMember candidate) (TC.getFields candidate) in Right (map fst bindersAndDeps, concatMap snd bindersAndDeps) -templatesForMembers _ _ _ _ _ = error "Shouldn't reach this case (invalid type definition)." -- | Generate the templates for a single member in a deftype declaration. -templatesForSingleMember :: TypeEnv -> Env -> [String] -> Ty -> (XObj, XObj) -> [((String, Binder), [XObj])] -templatesForSingleMember typeEnv env insidePath p@(StructTy (ConcreteNameTy _) _) (nameXObj, typeXObj) = +templatesForSingleMember :: TC.TypeCandidate -> TC.TypeField -> [((String, Binder), [XObj])] +templatesForSingleMember _ (TC.StructField "__dummy" _) = [] +templatesForSingleMember candidate field@(TC.StructField _ t) = case t of -- Unit member types are special since we do not represent them in emitted c. -- Instead, members of type Unit are executed for their side effects and silently omitted @@ -126,329 +145,303 @@ templatesForSingleMember typeEnv env insidePath p@(StructTy (ConcreteNameTy _) _ (FuncTy [RefTy p (VarTy "q"), t] UnitTy StaticLifetimeTy) (FuncTy [p, RefTy (FuncTy [t] t (VarTy "fq")) (VarTy "q")] p StaticLifetimeTy) where - Just t = xobjToTy typeXObj - memberName = getName nameXObj + p = TC.toType candidate + memberName = TC.fieldName field binders getterSig setterSig mutatorSig updaterSig = - [ instanceBinderWithDeps (SymPath insidePath memberName) getterSig (templateGetter (mangle memberName) t) ("gets the `" ++ memberName ++ "` property of a `" ++ show p ++ "`."), - if isTypeGeneric t - then (templateGenericSetter insidePath p t memberName, []) - else instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName)) setterSig (templateSetter typeEnv env (mangle memberName) t) ("sets the `" ++ memberName ++ "` property of a `" ++ show p ++ "`."), - if isTypeGeneric t - then (templateGenericMutatingSetter insidePath p t memberName, []) - else instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName ++ "!")) mutatorSig (templateMutatingSetter typeEnv env (mangle memberName) t) ("sets the `" ++ memberName ++ "` property of a `" ++ show p ++ "` in place."), - instanceBinderWithDeps - (SymPath insidePath ("update-" ++ memberName)) - updaterSig - (templateUpdater (mangle memberName) t) - ("updates the `" ++ memberName ++ "` property of a `" ++ show p ++ "` using a function `f`.") + [ getter getterSig, + setter setterSig, + mutator mutatorSig, + updater updaterSig ] -templatesForSingleMember _ _ _ _ _ = error "templatesforsinglemember" --- | The template for getters of a deftype. -templateGetter :: String -> Ty -> Template -templateGetter _ UnitTy = - Template - (FuncTy [RefTy (VarTy "p") (VarTy "q")] UnitTy StaticLifetimeTy) - (const (toTemplate "void $NAME($(Ref p) p)")) - -- Execution of the action passed as an argument is handled in Emit.hs. - (const $ toTemplate "$DECL { return; }\n") - (const []) -templateGetter member memberTy = - Template - (FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "t") StaticLifetimeTy) - (const (toTemplate "$t $NAME($(Ref p) p)")) - ( \(FuncTy [_] retTy _) -> - case retTy of - (RefTy UnitTy _) -> toTemplate " $DECL { void* ptr = NULL; return ptr; }\n" - _ -> - let fixForVoidStarMembers = - if isFunctionType memberTy && not (isTypeGeneric memberTy) - then "(" ++ tyToCLambdaFix (RefTy memberTy (VarTy "q")) ++ ")" - else "" - in toTemplate ("$DECL { return " ++ fixForVoidStarMembers ++ "(&(p->" ++ member ++ ")); }\n") - ) - (const []) + 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 --- | The template for setters of a concrete deftype. -templateSetter :: TypeEnv -> Env -> String -> Ty -> Template -templateSetter _ _ _ UnitTy = - Template - (FuncTy [VarTy "p", VarTy "t"] (VarTy "p") StaticLifetimeTy) - (const (toTemplate "$p $NAME($p p)")) - -- Execution of the action passed as an argument is handled in Emit.hs. - (const (toTemplate "$DECL { return p; }\n")) - (const []) -templateSetter typeEnv env memberName memberTy = - let callToDelete = memberDeletion typeEnv env (memberName, memberTy) - in Template - (FuncTy [VarTy "p", VarTy "t"] (VarTy "p") StaticLifetimeTy) - (const (toTemplate "$p $NAME($p p, $t newValue)")) - ( const - ( toTemplate - ( unlines - [ "$DECL {", - callToDelete, - " p." ++ memberName ++ " = newValue;", - " return p;", - "}\n" - ] - ) - ) - ) - ( \_ -> - if - | isManaged typeEnv env memberTy -> depsOfPolymorphicFunction typeEnv env [] "delete" (typesDeleterFunctionType memberTy) - | isFunctionType memberTy -> [defineFunctionTypeAlias memberTy] - | otherwise -> [] - ) + 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 --- | The template for setters of a generic deftype. -templateGenericSetter :: [String] -> Ty -> Ty -> String -> (String, Binder) -templateGenericSetter pathStrings originalStructTy@(StructTy (ConcreteNameTy _) _) membTy memberName = - defineTypeParameterizedTemplate templateCreator path (FuncTy [originalStructTy, membTy] originalStructTy StaticLifetimeTy) docs - where - path = SymPath pathStrings ("set-" ++ memberName) - t = FuncTy [VarTy "p", VarTy "t"] (VarTy "p") StaticLifetimeTy - docs = "sets the `" ++ memberName ++ "` property of a `" ++ show originalStructTy ++ "`." - templateCreator = TemplateCreator $ - \typeEnv env -> - Template - t - ( \(FuncTy [_, memberTy] _ _) -> - case memberTy of - UnitTy -> toTemplate "$p $NAME($p p)" - _ -> toTemplate "$p $NAME($p p, $t newValue)" - ) - ( \(FuncTy [_, memberTy] _ _) -> - let callToDelete = memberDeletion typeEnv env (memberName, memberTy) - in case memberTy of - UnitTy -> toTemplate "$DECL { return p; }\n" - _ -> - toTemplate - ( unlines - [ "$DECL {", - callToDelete, - " p." ++ memberName ++ " = newValue;", - " return p;", - "}\n" - ] - ) - ) - ( \(FuncTy [_, memberTy] _ _) -> - if isManaged typeEnv env memberTy - then depsOfPolymorphicFunction typeEnv env [] "delete" (typesDeleterFunctionType memberTy) - else [] - ) -templateGenericSetter _ _ _ _ = error "templategenericsetter" + 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 --- | The template for mutating setters of a deftype. -templateMutatingSetter :: TypeEnv -> Env -> String -> Ty -> Template -templateMutatingSetter _ _ _ UnitTy = - Template - (FuncTy [RefTy (VarTy "p") (VarTy "q"), VarTy "t"] UnitTy StaticLifetimeTy) - (const (toTemplate "void $NAME($p* pRef)")) - -- Execution of the action passed as an argument is handled in Emit.hs. - (const (toTemplate "$DECL { return; }\n")) - (const []) -templateMutatingSetter typeEnv env memberName memberTy = - let callToDelete = memberRefDeletion typeEnv env (memberName, memberTy) - in Template - (FuncTy [RefTy (VarTy "p") (VarTy "q"), VarTy "t"] UnitTy StaticLifetimeTy) - (const (toTemplate "void $NAME($p* pRef, $t newValue)")) - ( const - ( toTemplate - ( unlines - [ "$DECL {", - callToDelete, - " pRef->" ++ memberName ++ " = newValue;", - "}\n" - ] - ) - ) - ) - (const []) - --- | The template for mutating setters of a generic deftype. -templateGenericMutatingSetter :: [String] -> Ty -> Ty -> String -> (String, Binder) -templateGenericMutatingSetter pathStrings originalStructTy@(StructTy (ConcreteNameTy _) _) membTy memberName = - defineTypeParameterizedTemplate templateCreator path (FuncTy [RefTy originalStructTy (VarTy "q"), membTy] UnitTy StaticLifetimeTy) docs - where - path = SymPath pathStrings ("set-" ++ memberName ++ "!") - t = FuncTy [RefTy (VarTy "p") (VarTy "q"), VarTy "t"] UnitTy StaticLifetimeTy - docs = "sets the `" ++ memberName ++ "` property of a `" ++ show originalStructTy ++ "` in place." - templateCreator = TemplateCreator $ - \typeEnv env -> - Template - t - ( \(FuncTy [_, memberTy] _ _) -> - case memberTy of - UnitTy -> toTemplate "void $NAME($p* pRef)" - _ -> toTemplate "void $NAME($p* pRef, $t newValue)" - ) - ( \(FuncTy [_, memberTy] _ _) -> - let callToDelete = memberRefDeletion typeEnv env (memberName, memberTy) - in case memberTy of - UnitTy -> toTemplate "$DECL { return; }\n" - _ -> - toTemplate - ( unlines - [ "$DECL {", - callToDelete, - " pRef->" ++ memberName ++ " = newValue;", - "}\n" - ] - ) - ) - ( \(FuncTy [_, memberTy] _ _) -> - if isManaged typeEnv env memberTy - then depsOfPolymorphicFunction typeEnv env [] "delete" (typesDeleterFunctionType memberTy) - else [] - ) -templateGenericMutatingSetter _ _ _ _ = error "templategenericmutatingsetter" - --- | The template for updater functions of a deftype. --- | (allows changing a variable by passing an transformation function). -templateUpdater :: String -> Ty -> Template -templateUpdater _ UnitTy = - Template - (FuncTy [VarTy "p", RefTy (FuncTy [] UnitTy (VarTy "fq")) (VarTy "q")] (VarTy "p") StaticLifetimeTy) - (const (toTemplate "$p $NAME($p p, Lambda *updater)")) -- "Lambda" used to be: $(Fn [t] t) - -- Execution of the action passed as an argument is handled in Emit.hs. - (const (toTemplate ("$DECL { " ++ templateCodeForCallingLambda "(*updater)" (FuncTy [] UnitTy (VarTy "fq")) [] ++ "; return p;}\n"))) - ( \(FuncTy [_, RefTy t@(FuncTy fArgTys fRetTy _) _] _ _) -> - [defineFunctionTypeAlias t, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) fRetTy StaticLifetimeTy)] - ) -templateUpdater member _ = - Template - (FuncTy [VarTy "p", RefTy (FuncTy [VarTy "t"] (VarTy "t") (VarTy "fq")) (VarTy "q")] (VarTy "p") StaticLifetimeTy) - (const (toTemplate "$p $NAME($p p, Lambda *updater)")) -- "Lambda" used to be: $(Fn [t] t) - ( const - ( toTemplate - ( unlines - [ "$DECL {", - " p." ++ member ++ " = " ++ templateCodeForCallingLambda "(*updater)" (FuncTy [VarTy "t"] (VarTy "t") (VarTy "fq")) ["p." ++ member] ++ ";", - " return p;", - "}\n" - ] - ) - ) - ) - ( \(FuncTy [_, RefTy t@(FuncTy fArgTys fRetTy _) _] _ _) -> - if isTypeGeneric fRetTy - then [] - else [defineFunctionTypeAlias t, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) fRetTy StaticLifetimeTy)] - ) + 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 +templatesForSingleMember _ _ = error "templatesforsinglemember" -- | Helper function to create the binder for the 'init' template. -binderForInit :: [String] -> Ty -> [XObj] -> Either TypeError (String, Binder) -binderForInit insidePath structTy@(StructTy (ConcreteNameTy _) _) [XObj (Arr membersXObjs) _ _] = +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 = case membersXObjs of - [(XObj (Sym (SymPath [] "__dummy") Symbol) Nothing Nothing), (XObj (Sym (SymPath [] "Char") Symbol) Nothing Nothing)] -> [] - _ -> membersXObjs - in if isTypeGeneric structTy - then Right (genericInit StackAlloc insidePath structTy membersXObjs) - else - Right $ - instanceBinder - (SymPath insidePath "init") - -- don't include the dummy field in arg lists - (FuncTy (initArgListTypes nodummy) structTy StaticLifetimeTy) - (concreteInit StackAlloc structTy membersXObjs) - ("creates a `" ++ show structTy ++ "`.") -binderForInit _ _ _ = error "binderforinit" + 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) + gen = (initGenerator StackAlloc) + in if isTypeGeneric (TC.toType candidate) + then Right (defineTypeParameterizedTemplate (generateGenericTypeTemplate candidate gen) binderP binderT doc) + else Right (instanceBinder binderP binderT (generateConcreteTypeTemplate candidate gen) doc) --- | Generate a list of types from a deftype declaration. -initArgListTypes :: [XObj] -> [Ty] -initArgListTypes xobjs = - map (fromJust . xobjToTy . snd) (pairwise xobjs) +-- | Helper function to create the binder for the 'str' template. +binderForStrOrPrn :: String -> TC.TypeCandidate -> Either TypeError ((String, Binder), [XObj]) +binderForStrOrPrn strOrPrn candidate = + let binderP = SymPath (TC.getFullPath candidate) strOrPrn + binderT = (FuncTy [RefTy (TC.toType candidate) (VarTy "q")] StringTy StaticLifetimeTy) + doc = "converts a `" ++ TC.getName candidate ++ "` to a string." + in if isTypeGeneric (TC.toType candidate) + then Right $ (defineTypeParameterizedTemplate (TG.generateGenericTypeTemplate candidate strGenerator) binderP binderT doc, []) + else Right $ instanceBinderWithDeps binderP binderT (TG.generateConcreteTypeTemplate candidate strGenerator) doc --- | The template for the 'init' and 'new' functions for a concrete deftype. -concreteInit :: AllocationMode -> Ty -> [XObj] -> Template -concreteInit allocationMode originalStructTy@(StructTy (ConcreteNameTy _) _) membersXObjs = - Template - (FuncTy (map snd (memberXObjsToPairs membersXObjs)) (VarTy "p") StaticLifetimeTy) - ( \(FuncTy _ concreteStructTy _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs - memberPairs = memberXObjsToPairs correctedMembers - in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg (nodummy (unitless memberPairs))) ++ ")") - ) - ( \(FuncTy _ concreteStructTy _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs - in tokensForInit allocationMode (show originalStructTy) correctedMembers - ) - (\FuncTy {} -> []) +-- | Helper function to create the binder for the 'delete' template. +binderForDelete :: TC.TypeCandidate -> Either TypeError ((String, Binder), [XObj]) +binderForDelete candidate = + let doc = "deletes a `" ++ TC.getName candidate ++ "`. Should usually not be called manually." + binderP = SymPath (TC.getFullPath candidate) "delete" + binderT = FuncTy [(TC.toType candidate)] UnitTy StaticLifetimeTy + in if isTypeGeneric (TC.toType candidate) + then Right $ (defineTypeParameterizedTemplate (TG.generateGenericTypeTemplate candidate deleteGenerator) binderP binderT doc, []) + else Right $ instanceBinderWithDeps binderP binderT (TG.generateConcreteTypeTemplate candidate deleteGenerator) doc + +-- | Helper function to create the binder for the 'copy' template. +binderForCopy :: TC.TypeCandidate -> Either TypeError ((String, Binder), [XObj]) +binderForCopy candidate = + let doc = "copies a `" ++ TC.getName candidate ++ "`." + binderP = SymPath (TC.getFullPath candidate) "copy" + binderT = FuncTy [RefTy (TC.toType candidate) (VarTy "q")] (TC.toType candidate) StaticLifetimeTy + in if isTypeGeneric (TC.toType candidate) + then Right $ (defineTypeParameterizedTemplate (TG.generateGenericTypeTemplate candidate copyGenerator) binderP binderT doc, []) + else Right $ instanceBinderWithDeps binderP binderT (TG.generateConcreteTypeTemplate candidate copyGenerator) doc + +-------------------------------------------------------------------------------- +-- Template generators +-- +-- These functions declaratively specify how C code should be emitted for a +-- type. Binder helpers use these to generate an appropriate template for a +-- bound function name for the type. + +-- | getterGenerator returns a template generator for struct property getters. +getterGenerator :: TG.TemplateGenerator TC.TypeField +getterGenerator = TG.mkTemplateGenerator tgen decl body deps where - unitless = remove (isUnit . snd) - nodummy = remove (isDummy . fst) - isDummy "__dummy" = True - isDummy _ = False -concreteInit _ _ _ = error "concreteinit" + tgen :: TG.TypeGenerator TC.TypeField + tgen _ = (FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "t") StaticLifetimeTy) --- | The template for the 'init' and 'new' functions for a generic deftype. -genericInit :: AllocationMode -> [String] -> Ty -> [XObj] -> (String, Binder) -genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameTy _) _) membersXObjs = - defineTypeParameterizedTemplate templateCreator path t docs - where - path = SymPath pathStrings "init" - t = FuncTy (map snd (nodummy (memberXObjsToPairs membersXObjs))) originalStructTy StaticLifetimeTy - docs = "creates a `" ++ show originalStructTy ++ "`." - templateCreator = TemplateCreator $ - \typeEnv env -> - Template - (FuncTy (map snd (memberXObjsToPairs membersXObjs)) (VarTy "p") StaticLifetimeTy) - ( \(FuncTy _ concreteStructTy _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs - memberPairs = memberXObjsToPairs correctedMembers - in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg (nodummy (remove (isUnit . snd) memberPairs))) ++ ")") - ) - ( \(FuncTy _ concreteStructTy _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs - in tokensForInit allocationMode (show originalStructTy) correctedMembers - ) - ( \(FuncTy _ concreteStructTy _) -> - case concretizeType typeEnv env concreteStructTy of - Left _ -> [] - Right ok -> ok - ) - nodummy = remove (isDummy . fst) - isDummy "__dummy" = True - isDummy _ = False -genericInit _ _ _ _ = error "genericinit" + decl :: TG.TokenGenerator TC.TypeField + decl TG.GeneratorArg{instanceT=UnitTy} = toTemplate "void $NAME($(Ref p) p)" + decl _ = toTemplate "$t $NAME($(Ref p) p)" -tokensForInit :: AllocationMode -> String -> [XObj] -> [Token] -tokensForInit allocationMode typeName membersXObjs = - toTemplate $ - unlines - [ "$DECL {", - case allocationMode of - StackAlloc -> case unitless of - -- if this is truly a memberless struct, init it to 0; - -- This can happen, e.g. in cases where *all* members of the struct are of type Unit. - -- Since we do not generate members for Unit types. - [] -> " $p instance = {};" - _ -> " $p instance;" - HeapAlloc -> " $p instance = CARP_MALLOC(sizeof(" ++ typeName ++ "));", - assignments membersXObjs, - " return instance;", - "}" - ] + 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)} = + 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! */" + + deps :: TG.DepenGenerator TC.TypeField + deps = const [] + +-- | 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 _ = [] + +-- | 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 _ = [] + +-- | 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 _ = [] + +-- | 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 + +-- | Generate C code for assigning to a member variable. +-- Needs to know if the instance is a pointer or stack variable. +-- Also handles the special dummy member we add for empty structs to be ANSI C compatible. +memberAssignment :: AllocationMode -> TC.TypeField -> String +memberAssignment allocationMode field = + case (TC.fieldName field) of + "__dummy" -> " instance" ++ sep ++ mangle name ++ " = " ++ "0" ++ ";" + _ -> " instance" ++ sep ++ mangle name ++ " = " ++ mangle name ++ ";" where - assignments [] = "" - assignments _ = go unitless - where - go [] = "" - go xobjs = joinLines $ memberAssignment allocationMode . fst <$> xobjs - unitless = remove (isUnit . snd) (memberXObjsToPairs membersXObjs) + name = (TC.fieldName field) + sep = case allocationMode of + StackAlloc -> "." + HeapAlloc -> "->" -- | Creates the C code for an arg to the init function. -- | i.e. "(deftype A [x Int])" will generate "int x" which -- | will be used in the init function like this: "A_init(int x)" +fieldArg :: TC.TypeField -> String +fieldArg (TC.StructField name ty) = + tyToCLambdaFix (templatizeTy ty) ++ " " ++ mangle name +fieldArg _ = "" + +---- | Creates the C code for an arg to the init function. +---- | i.e. "(deftype A [x Int])" will generate "int x" which +---- | will be used in the init function like this: "A_init(int x)" memberArg :: (String, Ty) -> String memberArg (memberName, memberTy) = tyToCLambdaFix (templatizeTy memberTy) ++ " " ++ memberName @@ -462,207 +455,130 @@ templatizeTy (RefTy t lt) = RefTy (templatizeTy t) (templatizeTy lt) templatizeTy (PointerTy t) = PointerTy (templatizeTy t) templatizeTy t = t --- | Helper function to create the binder for the 'str' template. -binderForStrOrPrn :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> String -> Either TypeError ((String, Binder), [XObj]) -binderForStrOrPrn typeEnv env insidePath structTy@(StructTy (ConcreteNameTy _) _) [XObj (Arr membersXObjs) _ _] strOrPrn = - if isTypeGeneric structTy - then Right (genericStr insidePath structTy membersXObjs strOrPrn, []) - else - Right - ( instanceBinderWithDeps - (SymPath insidePath strOrPrn) - (FuncTy [RefTy structTy (VarTy "q")] StringTy StaticLifetimeTy) - (concreteStr typeEnv env structTy (memberXObjsToPairs membersXObjs) strOrPrn) - ("converts a `" ++ show structTy ++ "` to a string.") - ) -binderForStrOrPrn _ _ _ _ _ _ = error "binderforstrorprn" +-- | 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 --- | The template for the 'str' function for a concrete deftype. -concreteStr :: TypeEnv -> Env -> Ty -> [(String, Ty)] -> String -> Template -concreteStr typeEnv env concreteStructTy@(StructTy (ConcreteNameTy name) _) memberPairs _ = - Template - (FuncTy [RefTy concreteStructTy (VarTy "q")] StringTy StaticLifetimeTy) - (\(FuncTy [RefTy structTy _] StringTy _) -> toTemplate $ "String $NAME(" ++ tyToCLambdaFix structTy ++ " *p)") - ( \(FuncTy [RefTy (StructTy _ _) _] StringTy _) -> - tokensForStr typeEnv env (show name) memberPairs concreteStructTy - ) - ( \(FuncTy [RefTy (StructTy _ _) (VarTy "q")] StringTy _) -> - concatMap - (depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv env) - (remove isFullyGenericType (map snd memberPairs)) - ) -concreteStr _ _ _ _ _ = error "concretestr" + decl :: TG.TokenGenerator TC.TypeCandidate + decl GeneratorArg{instanceT=(FuncTy [RefTy structT _] _ _)} = + toTemplate $ "String $NAME(" ++ tyToCLambdaFix structT ++ " *p)" + decl _ = toTemplate "/* template error! */" --- | The template for the 'str' function for a generic deftype. -genericStr :: [String] -> Ty -> [XObj] -> String -> (String, Binder) -genericStr pathStrings originalStructTy@(StructTy (ConcreteNameTy name) _) membersXObjs strOrPrn = - defineTypeParameterizedTemplate templateCreator path t docs - where - path = SymPath pathStrings strOrPrn - t = FuncTy [RefTy originalStructTy (VarTy "q")] StringTy StaticLifetimeTy - docs = "converts a `" ++ show originalStructTy ++ "` to a string." - templateCreator = TemplateCreator $ - \typeEnv env -> - Template - t - ( \(FuncTy [RefTy concreteStructTy _] StringTy _) -> - toTemplate $ "String $NAME(" ++ tyToCLambdaFix concreteStructTy ++ " *p)" - ) - ( \(FuncTy [RefTy concreteStructTy@(StructTy _ _) _] StringTy _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs - memberPairs = memberXObjsToPairs correctedMembers - in tokensForStr typeEnv env (show name) memberPairs concreteStructTy - ) - ( \ft@(FuncTy [RefTy concreteStructTy@(StructTy _ _) _] StringTy _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs - memberPairs = memberXObjsToPairs correctedMembers - in concatMap - (depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv env) - (remove isFullyGenericType (map snd memberPairs)) - ++ [defineFunctionTypeAlias ft | not (isTypeGeneric concreteStructTy)] - ) -genericStr _ _ _ _ = error "genericstr" + 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! */" -tokensForStr :: TypeEnv -> Env -> String -> [(String, Ty)] -> Ty -> [Token] -tokensForStr typeEnv env typeName memberPairs concreteStructTy = - toTemplate $ - unlines - [ "$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 memberPairs concreteStructTy, - " String buffer = CARP_MALLOC(size);", - " String bufferPtr = buffer;", - "", - " sprintf(bufferPtr, \"(%s \", \"" ++ typeName ++ "\");", - " bufferPtr += strlen(\"" ++ typeName ++ "\") + 2;\n", - joinLines (map (memberPrn typeEnv env) memberPairs), - " bufferPtr--;", - " sprintf(bufferPtr, \")\");", - " return buffer;", - "}" - ] + 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 _ = [] --- | 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 members s@(StructTy (ConcreteNameTy _) _) = - " int size = snprintf(NULL, 0, \"(%s )\", \"" ++ show s ++ "\");\n" - ++ unlines (map (memberPrnSize typeEnv env) members) -calculateStructStrSize _ _ _ _ = error "calculatestructstrsize" + 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;", + "}" + ] --- | Generate C code for assigning to a member variable. --- Needs to know if the instance is a pointer or stack variable. --- Also handles the special dummy member we add for empty structs to be ANSI C compatible. -memberAssignment :: AllocationMode -> String -> String -memberAssignment allocationMode memberName = - case memberName of - "__dummy" -> " instance" ++ sep ++ memberName ++ " = " ++ "0" ++ ";" - _ -> " instance" ++ sep ++ memberName ++ " = " ++ memberName ++ ";" - where - sep = case allocationMode of - StackAlloc -> "." - HeapAlloc -> "->" + -- | 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) --- | Helper function to create the binder for the 'delete' template. -binderForDelete :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> Either TypeError ((String, Binder), [XObj]) -binderForDelete typeEnv env insidePath structTy@(StructTy (ConcreteNameTy _) _) [XObj (Arr membersXObjs) _ _] = - if isTypeGeneric structTy - then Right (genericDelete insidePath structTy membersXObjs, []) - else - Right - ( instanceBinderWithDeps - (SymPath insidePath "delete") - (FuncTy [structTy] UnitTy StaticLifetimeTy) - (concreteDelete typeEnv env (memberXObjsToPairs membersXObjs)) - ("deletes a `" ++ show structTy ++ "`.") - ) -binderForDelete _ _ _ _ _ = error "binderfordelete" +-- | 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 --- | The template for the 'delete' function of a generic deftype. -genericDelete :: [String] -> Ty -> [XObj] -> (String, Binder) -genericDelete pathStrings originalStructTy@(StructTy (ConcreteNameTy _) _) membersXObjs = - defineTypeParameterizedTemplate templateCreator path (FuncTy [originalStructTy] UnitTy StaticLifetimeTy) docs - where - path = SymPath pathStrings "delete" - t = FuncTy [VarTy "p"] UnitTy StaticLifetimeTy - docs = "deletes a `" ++ show originalStructTy ++ "`. Should usually not be called manually." - templateCreator = TemplateCreator $ - \typeEnv env -> - Template - t - (const (toTemplate "void $NAME($p p)")) - ( \(FuncTy [concreteStructTy] UnitTy _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs - memberPairs = memberXObjsToPairs correctedMembers - in ( toTemplate $ - unlines - [ "$DECL {", - joinLines (map (memberDeletion typeEnv env) memberPairs), - "}" - ] - ) - ) - ( \(FuncTy [concreteStructTy] UnitTy _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs - memberPairs = memberXObjsToPairs correctedMembers - in if isTypeGeneric concreteStructTy - then [] - else - concatMap - (depsOfPolymorphicFunction typeEnv env [] "delete" . typesDeleterFunctionType) - (filter (isManaged typeEnv env) (map snd memberPairs)) - ) -genericDelete _ _ _ = error "genericdelete" + decl :: TG.TokenGenerator TC.TypeCandidate + decl _ = toTemplate "void $NAME($p p)" --- | Helper function to create the binder for the 'copy' template. -binderForCopy :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> Either TypeError ((String, Binder), [XObj]) -binderForCopy typeEnv env insidePath structTy@(StructTy (ConcreteNameTy _) _) [XObj (Arr membersXObjs) _ _] = - if isTypeGeneric structTy - then Right (genericCopy insidePath structTy membersXObjs, []) - else - Right - ( instanceBinderWithDeps - (SymPath insidePath "copy") - (FuncTy [RefTy structTy (VarTy "q")] structTy StaticLifetimeTy) - (concreteCopy typeEnv env (memberXObjsToPairs membersXObjs)) - ("copies a `" ++ show structTy ++ "`.") - ) -binderForCopy _ _ _ _ _ = error "binderforcopy" + 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! */" --- | The template for the 'copy' function of a generic deftype. -genericCopy :: [String] -> Ty -> [XObj] -> (String, Binder) -genericCopy pathStrings originalStructTy@(StructTy (ConcreteNameTy _) _) membersXObjs = - defineTypeParameterizedTemplate templateCreator path (FuncTy [RefTy originalStructTy (VarTy "q")] originalStructTy StaticLifetimeTy) docs - where - path = SymPath pathStrings "copy" - t = FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy - docs = "copies the `" ++ show originalStructTy ++ "`." - templateCreator = TemplateCreator $ - \typeEnv env -> - Template - t - (const (toTemplate "$p $NAME($p* pRef)")) - ( \(FuncTy [RefTy concreteStructTy _] _ _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs - memberPairs = memberXObjsToPairs correctedMembers - in tokensForCopy typeEnv env memberPairs - ) - ( \(FuncTy [RefTy concreteStructTy _] _ _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs - memberPairs = memberXObjsToPairs correctedMembers - in if isTypeGeneric concreteStructTy - then [] - else - concatMap - (depsOfPolymorphicFunction typeEnv env [] "copy" . typesCopyFunctionType) - (filter (isManaged typeEnv env) (map snd memberPairs)) - ) -genericCopy _ _ _ = error "genericcopy" + 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 _ = [] + +-------------------------------------------------------------------------------- +-- Utilities + +-- | Converts a type field to a tuple of its name and primary type. +-- This is a convenience function for interop with the old tuple based +-- 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.SumField name []) = (mangle name, TypeTy) -- note: not actually used. diff --git a/src/SumtypeCase.hs b/src/SumtypeCase.hs deleted file mode 100644 index 43cf45c8..00000000 --- a/src/SumtypeCase.hs +++ /dev/null @@ -1,41 +0,0 @@ -module SumtypeCase where - -import Obj -import TypeError -import Types -import Validate - -data SumtypeCase = SumtypeCase - { caseName :: String, - caseTys :: [Ty] - } - deriving (Show, Eq) - -toCases :: TypeEnv -> Env -> TypeVarRestriction -> [Ty] -> [XObj] -> Either TypeError [SumtypeCase] -toCases typeEnv globalEnv restriction typeVars = mapM (toCase typeEnv globalEnv restriction typeVars) - -toCase :: TypeEnv -> Env -> TypeVarRestriction -> [Ty] -> XObj -> Either TypeError SumtypeCase -toCase typeEnv globalEnv restriction typeVars x@(XObj (Lst [XObj (Sym (SymPath [] name) Symbol) _ _, XObj (Arr tyXObjs) _ _]) _ _) = - let tys = map xobjToTy tyXObjs - in case sequence tys of - Nothing -> - Left (InvalidSumtypeCase x) - Just okTys -> - let validated = map (\t -> canBeUsedAsMemberType restriction typeEnv globalEnv typeVars t x) okTys - in case sequence validated of - Left e -> - Left e - Right _ -> - Right $ - SumtypeCase - { caseName = name, - caseTys = okTys - } -toCase _ _ _ _ (XObj (Sym (SymPath [] name) Symbol) _ _) = - Right $ - SumtypeCase - { caseName = name, - caseTys = [] - } -toCase _ _ _ _ x = - Left (InvalidSumtypeCase x) diff --git a/src/Sumtypes.hs b/src/Sumtypes.hs index 113b0097..60252cbc 100644 --- a/src/Sumtypes.hs +++ b/src/Sumtypes.hs @@ -1,4 +1,11 @@ -module Sumtypes where +{-# LANGUAGE NamedFieldPuns #-} + +module Sumtypes + ( + moduleForSumtypeInContext, + moduleForSumtype + ) +where import Concretize import Context @@ -9,7 +16,6 @@ import Info import Managed import Obj import StructUtils -import SumtypeCase import Template import ToTemplate import TypeError @@ -17,14 +23,14 @@ import TypePredicates import Types import TypesToC import Util -import Validate (TypeVarRestriction (..)) +import Validate +import qualified TypeCandidate as TC +import TemplateGenerator as TG -getCase :: [SumtypeCase] -> String -> Maybe SumtypeCase -getCase cases caseNameToFind = - case filter (\c -> caseName c == caseNameToFind) cases of - found : _ -> Just found - [] -> Nothing +-------------------------------------------------------------------------------- +-- Public +-- | Creates a module and generates standard functions for a user defined sum type in the given context. moduleForSumtypeInContext :: Context -> String -> [Ty] -> [XObj] -> Maybe Info -> Either TypeError (String, XObj, [XObj]) moduleForSumtypeInContext ctx name vars members info = let global = contextGlobalEnv ctx @@ -47,402 +53,396 @@ moduleForSumtypeInContext ctx name vars members info = ) in moduleForSumtype inner types global path name vars members info previous +-- | Creates a module and generates standard functions for a user defined sum type. moduleForSumtype :: Maybe Env -> TypeEnv -> Env -> [String] -> String -> [Ty] -> [XObj] -> Maybe Info -> Maybe (Env, TypeEnv) -> Either TypeError (String, XObj, [XObj]) moduleForSumtype innerEnv typeEnv env pathStrings typeName typeVariables rest i existingEnv = let moduleValueEnv = fromMaybe (new innerEnv (Just typeName)) (fmap fst existingEnv) moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv) - insidePath = pathStrings ++ [typeName] in do - let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables - cases <- toCases typeEnv env AllowOnlyNamesInScope typeVariables rest - okIniters <- initers insidePath structTy cases - okTag <- binderForTag insidePath structTy - (okStr, okStrDeps) <- binderForStrOrPrn typeEnv env insidePath structTy cases "str" - (okPrn, _) <- binderForStrOrPrn typeEnv env insidePath structTy cases "prn" - okDelete <- binderForDelete typeEnv env insidePath structTy cases - (okCopy, okCopyDeps) <- binderForCopy typeEnv env insidePath structTy cases - okMemberDeps <- memberDeps typeEnv env cases - let moduleEnvWithBindings = addListOfBindings moduleValueEnv (okIniters ++ [okStr, okPrn, okDelete, okCopy, okTag]) + -- validate the definition + candidate <- TC.mkSumtypeCandidate typeName typeVariables typeEnv env rest pathStrings + validateType candidate + -- produce standard function bindings + (binders, deps) <- generateBinders candidate + -- insert the module into the environment + let moduleEnvWithBindings = addListOfBindings moduleValueEnv binders typeModuleXObj = XObj (Mod moduleEnvWithBindings moduleTypeEnv) i (Just ModuleTy) - pure (typeName, typeModuleXObj, okMemberDeps ++ okCopyDeps ++ okStrDeps) + pure (typeName, typeModuleXObj, deps) -memberDeps :: TypeEnv -> Env -> [SumtypeCase] -> Either TypeError [XObj] -memberDeps typeEnv env cases = fmap concat (mapM (concretizeType typeEnv env) (concatMap caseTys cases)) +-------------------------------------------------------------------------------- +-- Private -replaceGenericTypesOnCases :: TypeMappings -> [SumtypeCase] -> [SumtypeCase] +-- | 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) + +-- | Gets concrete dependencies for sum type fields. +memberDeps :: TypeEnv -> Env -> [TC.TypeField] -> Either TypeError [XObj] +memberDeps typeEnv env cases = fmap concat (mapM (concretizeType typeEnv env) (concatMap TC.fieldTypes cases)) + +-- | Replace type variables in a sum type case +replaceGenericTypesOnCases :: TypeMappings -> [TC.TypeField] -> [TC.TypeField] replaceGenericTypesOnCases mappings = map replaceOnCase where - replaceOnCase theCase = - let newTys = map (replaceTyVars mappings) (caseTys theCase) - in theCase {caseTys = newTys} + replaceOnCase :: TC.TypeField -> TC.TypeField + replaceOnCase (TC.SumField name tys) = + let newTys = map (replaceTyVars mappings) tys + in (TC.SumField name newTys) + replaceOnCase field = field -initers :: [String] -> Ty -> [SumtypeCase] -> Either TypeError [(String, Binder)] -initers insidePath structTy = mapM (binderForCaseInit insidePath structTy) +-------------------------------------------------------------------------------- +-- Binding generators -binderForCaseInit :: [String] -> Ty -> SumtypeCase -> Either TypeError (String, Binder) -binderForCaseInit insidePath structTy@(StructTy (ConcreteNameTy _) _) sumtypeCase = - if isTypeGeneric structTy - then Right (genericCaseInit StackAlloc insidePath structTy sumtypeCase) - else Right (concreteCaseInit StackAlloc insidePath structTy sumtypeCase) -binderForCaseInit _ _ _ = error "binderforcaseinit" +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)] -concreteCaseInit :: AllocationMode -> [String] -> Ty -> SumtypeCase -> (String, Binder) -concreteCaseInit allocationMode insidePath structTy sumtypeCase = - instanceBinder (SymPath insidePath (caseName sumtypeCase)) (FuncTy (caseTys sumtypeCase) structTy StaticLifetimeTy) template doc +-- | Generate initializer bindings for each sum type case. +initers :: MultiBinderGen +initers candidate = mapM binderForCaseInit (TC.getFields candidate) where - doc = "creates a `" ++ caseName sumtypeCase ++ "`." - template = - Template - (FuncTy (caseTys sumtypeCase) (VarTy "p") StaticLifetimeTy) - ( \(FuncTy _ concreteStructTy _) -> - let mappings = unifySignatures structTy concreteStructTy - correctedTys = map (replaceTyVars mappings) (caseTys sumtypeCase) - in (toTemplate $ "$p $NAME(" ++ joinWithComma (zipWith (curry memberArg) anonMemberNames (remove isUnit correctedTys)) ++ ")") - ) - (const (tokensForCaseInit allocationMode structTy sumtypeCase)) - (\FuncTy {} -> []) + -- | 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) -genericCaseInit :: AllocationMode -> [String] -> Ty -> SumtypeCase -> (String, Binder) -genericCaseInit allocationMode pathStrings originalStructTy sumtypeCase = - defineTypeParameterizedTemplate templateCreator path t docs - where - path = SymPath pathStrings (caseName sumtypeCase) - t = FuncTy (caseTys sumtypeCase) originalStructTy StaticLifetimeTy - docs = "creates a `" ++ caseName sumtypeCase ++ "`." - templateCreator = TemplateCreator $ - \typeEnv env -> - Template - (FuncTy (caseTys sumtypeCase) (VarTy "p") StaticLifetimeTy) - ( \(FuncTy _ concreteStructTy _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedTys = map (replaceTyVars mappings) (caseTys sumtypeCase) - in toTemplate $ "$p $NAME(" ++ joinWithComma (zipWith (curry memberArg) anonMemberNames (remove isUnit correctedTys)) ++ ")" - ) - ( \(FuncTy _ concreteStructTy _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedTys = map (replaceTyVars mappings) (caseTys sumtypeCase) - in tokensForCaseInit allocationMode concreteStructTy (sumtypeCase {caseTys = correctedTys}) - ) - ( \(FuncTy _ concreteStructTy _) -> - case concretizeType typeEnv env concreteStructTy of - Left _ -> [] - Right ok -> ok - ) + -- | 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 + binderPath = SymPath (TC.getFullPath candidate) fieldname + in instanceBinder binderPath (FuncTy tys concrete StaticLifetimeTy) temp doc + concreteCaseInit _ _ = error "concreteCaseInit" -tokensForCaseInit :: AllocationMode -> Ty -> SumtypeCase -> [Token] -tokensForCaseInit allocationMode sumTy@(StructTy (ConcreteNameTy _) _) sumtypeCase = - toTemplate $ - unlines - [ "$DECL {", - case allocationMode of - StackAlloc -> " $p instance;" - HeapAlloc -> " $p instance = CARP_MALLOC(sizeof(" ++ show sumTy ++ "));", - joinLines $ caseMemberAssignment allocationMode correctedName . fst <$> unitless, - " instance._tag = " ++ tagName sumTy correctedName ++ ";", - " return instance;", - "}" - ] - where - correctedName = caseName sumtypeCase - unitless = zip anonMemberNames $ remove isUnit (caseTys sumtypeCase) -tokensForCaseInit _ _ _ = error "tokensforcaseinit" + -- | 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 + 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 + 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 + genericCaseInit _ _ = error "genericCaseInit" -caseMemberAssignment :: AllocationMode -> String -> String -> String -caseMemberAssignment allocationMode caseNm memberName = - " instance" ++ sep ++ caseNm ++ "." ++ memberName ++ " = " ++ memberName ++ ";" +-- | Generates a binder for retrieving the tag of a sum type. +binderForTag :: BinderGen +binderForTag candidate = + let t = FuncTy [RefTy (TC.toType candidate) (VarTy "q")] IntTy StaticLifetimeTy + decl = \(FuncTy [RefTy struct _] _ _) -> toTemplate $ proto struct + body = \(FuncTy [RefTy struct _] _ _) -> toTemplate $ proto struct ++ " { return p->_tag; }" + deps = const [] + path' = SymPath (TC.getFullPath candidate) "get-tag" + temp = Template t decl body deps + doc = "Gets the tag from a `" ++ (TC.getName candidate) ++ "`." + in Right (instanceBinder path' t temp doc) where - sep = case allocationMode of - StackAlloc -> ".u." - HeapAlloc -> "->u." - -binderForTag :: [String] -> Ty -> Either TypeError (String, Binder) -binderForTag insidePath originalStructTy@(StructTy (ConcreteNameTy _) _) = - Right $ instanceBinder path (FuncTy [RefTy originalStructTy (VarTy "q")] IntTy StaticLifetimeTy) template doc - where - path = SymPath insidePath "get-tag" - template = - Template - (FuncTy [RefTy originalStructTy (VarTy "q")] IntTy StaticLifetimeTy) - (\(FuncTy [RefTy structTy _] IntTy _) -> toTemplate $ proto structTy) - (\(FuncTy [RefTy structTy _] IntTy _) -> toTemplate $ proto structTy ++ " { return p->_tag; }") - (const []) + proto :: Ty -> String proto structTy = "int $NAME(" ++ tyToCLambdaFix structTy ++ " *p)" - doc = "Gets the tag from a `" ++ show originalStructTy ++ "`." -binderForTag _ _ = error "binderfortag" -- | Helper function to create the binder for the 'str' template. -binderForStrOrPrn :: TypeEnv -> Env -> [String] -> Ty -> [SumtypeCase] -> String -> Either TypeError ((String, Binder), [XObj]) -binderForStrOrPrn typeEnv env insidePath structTy@(StructTy (ConcreteNameTy _) _) cases strOrPrn = - Right $ - if isTypeGeneric structTy - then (genericStr insidePath structTy cases strOrPrn, []) - else concreteStr typeEnv env insidePath structTy cases strOrPrn -binderForStrOrPrn _ _ _ _ _ _ = error "binderforstrorprn" - --- | The template for the 'str' function for a concrete deftype. -concreteStr :: TypeEnv -> Env -> [String] -> Ty -> [SumtypeCase] -> String -> ((String, Binder), [XObj]) -concreteStr typeEnv env insidePath concreteStructTy@(StructTy (ConcreteNameTy name) _) cases strOrPrn = - instanceBinderWithDeps (SymPath insidePath strOrPrn) (FuncTy [RefTy concreteStructTy (VarTy "q")] StringTy StaticLifetimeTy) template doc +binderForStrOrPrn :: TC.TypeCandidate -> String -> Either TypeError ((String, Binder), [XObj]) +binderForStrOrPrn candidate strOrPrn = + let doc = "converts a `" ++ (getStructName (TC.toType candidate)) ++ "` to a string." + 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 where - doc = "converts a `" ++ (show concreteStructTy) ++ "` to a string." - template = - Template - (FuncTy [RefTy concreteStructTy (VarTy "q")] StringTy StaticLifetimeTy) - (\(FuncTy [RefTy structTy _] StringTy _) -> toTemplate $ "String $NAME(" ++ tyToCLambdaFix structTy ++ " *p)") - ( \(FuncTy [RefTy (StructTy _ _) _] StringTy _) -> - tokensForStr typeEnv env (show name) cases concreteStructTy - ) - ( \(FuncTy [RefTy (StructTy _ _) _] StringTy _) -> - concatMap - (depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv env) - (remove isFullyGenericType (concatMap caseTys cases)) - ) -concreteStr _ _ _ _ _ _ = error "concretestr" + strGenerator :: TG.TemplateGenerator TC.TypeCandidate + strGenerator = TG.mkTemplateGenerator genT decl body deps --- | The template for the 'str' function for a generic deftype. -genericStr :: [String] -> Ty -> [SumtypeCase] -> String -> (String, Binder) -genericStr insidePath originalStructTy@(StructTy (ConcreteNameTy name) _) cases strOrPrn = - defineTypeParameterizedTemplate templateCreator path t docs - where - path = SymPath insidePath strOrPrn - t = FuncTy [RefTy originalStructTy (VarTy "q")] StringTy StaticLifetimeTy - docs = "stringifies a `" ++ show originalStructTy ++ "`." - templateCreator = TemplateCreator $ - \typeEnv env -> - Template - t - ( \(FuncTy [RefTy concreteStructTy _] StringTy _) -> - toTemplate $ "String $NAME(" ++ tyToCLambdaFix concreteStructTy ++ " *p)" - ) - ( \(FuncTy [RefTy concreteStructTy@(StructTy _ _) _] StringTy _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedCases = replaceGenericTypesOnCases mappings cases - in tokensForStr typeEnv env (show name) correctedCases concreteStructTy - ) - ( \ft@(FuncTy [RefTy concreteStructTy@(StructTy _ _) _] StringTy _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedCases = replaceGenericTypesOnCases mappings cases - tys = remove isFullyGenericType (concatMap caseTys correctedCases) - in concatMap (depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv env) tys - ++ [defineFunctionTypeAlias ft | not (isTypeGeneric concreteStructTy)] - ) -genericStr _ _ _ _ = error "genericstr" + genT :: TG.TypeGenerator TC.TypeCandidate + genT GeneratorArg{value} = + FuncTy [RefTy (TC.toType value) (VarTy "q")] StringTy StaticLifetimeTy -tokensForStr :: TypeEnv -> Env -> String -> [SumtypeCase] -> Ty -> [Token] -tokensForStr typeEnv env _ cases concreteStructTy = - toTemplate $ - unlines - [ "$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 cases concreteStructTy, - " String buffer = CARP_MALLOC(size);", - " String bufferPtr = buffer;", - "", - concatMap (strCase typeEnv env concreteStructTy) cases, - " return buffer;", - "}" - ] + decl :: TG.TokenGenerator TC.TypeCandidate + decl GeneratorArg{instanceT=(FuncTy [RefTy ty _] _ _)} = + toTemplate $ "String $NAME(" ++ tyToCLambdaFix ty ++ " *p)" + decl _ = toTemplate "/* template error! */" -namesFromCase :: SumtypeCase -> Ty -> (String, [Ty], String) -namesFromCase theCase concreteStructTy = - let name = caseName theCase - in (name, caseTys theCase {caseTys = remove isUnit (caseTys theCase)}, tagName concreteStructTy name) + body :: TG.TokenGenerator TC.TypeCandidate + body GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [RefTy ty _] _ _), value} = + tokensForStr tenv env originalT ty (TC.getFields value) + body _ = toTemplate "/* template error! */" -strCase :: TypeEnv -> Env -> Ty -> SumtypeCase -> String -strCase typeEnv env concreteStructTy@(StructTy _ _) theCase = - let (name, tys, correctedTagName) = namesFromCase theCase concreteStructTy - 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, \")\");", - " }" - ] -strCase _ _ _ _ = error "strcase" - --- | Figure out how big the string needed for the string representation of the struct has to be. -calculateStructStrSize :: TypeEnv -> Env -> [SumtypeCase] -> Ty -> String -calculateStructStrSize typeEnv env cases structTy@(StructTy (ConcreteNameTy _) _) = - " int size = 1;\n" - ++ concatMap (strSizeCase typeEnv env structTy) cases -calculateStructStrSize _ _ _ _ = error "calculatestructstrsize" - -strSizeCase :: TypeEnv -> Env -> Ty -> SumtypeCase -> String -strSizeCase typeEnv env concreteStructTy@(StructTy _ _) theCase = - let (name, tys, correctedTagName) = namesFromCase theCase concreteStructTy - in unlines - [ " if(p->_tag == " ++ correctedTagName ++ ") {", - " size += snprintf(NULL, 0, \"(%s \", \"" ++ name ++ "\");", - joinLines $ memberPrnSize typeEnv env <$> unionMembers name tys, - " }" - ] -strSizeCase _ _ _ _ = error "strsizecase" + deps :: TG.DepenGenerator TC.TypeCandidate + deps GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [RefTy ty _] _ _), value} = + depsForStr tenv env originalT ty (TC.getFields value) + deps _ = [] -- | Helper function to create the binder for the 'delete' template. -binderForDelete :: TypeEnv -> Env -> [String] -> Ty -> [SumtypeCase] -> Either TypeError (String, Binder) -binderForDelete typeEnv env insidePath structTy@(StructTy (ConcreteNameTy _) _) cases = - Right $ - if isTypeGeneric structTy - then genericSumtypeDelete insidePath structTy cases - else concreteSumtypeDelete insidePath typeEnv env structTy cases -binderForDelete _ _ _ _ _ = error "binderfordelete" - --- | The template for the 'delete' function of a generic sumtype. -genericSumtypeDelete :: [String] -> Ty -> [SumtypeCase] -> (String, Binder) -genericSumtypeDelete pathStrings originalStructTy cases = - defineTypeParameterizedTemplate templateCreator path (FuncTy [originalStructTy] UnitTy StaticLifetimeTy) docs +binderForDelete :: BinderGen +binderForDelete candidate = + let t = (TC.toType candidate) + doc = "deletes a `" ++ (getStructName t) ++ "`. This should usually not be called manually." + binderT = FuncTy [t] UnitTy StaticLifetimeTy + binderP = SymPath (TC.getFullPath candidate) "delete" + in Right $ + if isTypeGeneric t + then defineTypeParameterizedTemplate (TG.generateGenericTypeTemplate candidate generator) binderP binderT doc + else instanceBinder binderP binderT (TG.generateConcreteTypeTemplate candidate generator) doc where - path = SymPath pathStrings "delete" - t = FuncTy [VarTy "p"] UnitTy StaticLifetimeTy - docs = "deletes a `" ++ show originalStructTy ++ "`. Should usually not be called manually." - templateCreator = TemplateCreator $ - \typeEnv env -> - Template - t - (const (toTemplate "void $NAME($p p)")) - ( \(FuncTy [concreteStructTy] UnitTy _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedCases = replaceGenericTypesOnCases mappings cases - in ( toTemplate $ - unlines - [ "$DECL {", - concatMap (deleteCase typeEnv env concreteStructTy) (zip correctedCases (True : repeat False)), - "}" - ] - ) - ) - ( \(FuncTy [concreteStructTy] UnitTy _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedCases = replaceGenericTypesOnCases mappings cases - in if isTypeGeneric concreteStructTy - then [] - else - concatMap - (depsOfPolymorphicFunction typeEnv env [] "delete" . typesDeleterFunctionType) - (filter (isManaged typeEnv env) (concatMap caseTys correctedCases)) - ) + generator :: TG.TemplateGenerator TC.TypeCandidate + generator = TG.mkTemplateGenerator genT decl body deps --- | The template for the 'delete' function of a concrete sumtype -concreteSumtypeDelete :: [String] -> TypeEnv -> Env -> Ty -> [SumtypeCase] -> (String, Binder) -concreteSumtypeDelete insidePath typeEnv env structTy@(StructTy (ConcreteNameTy _) _) cases = - instanceBinder (SymPath insidePath "delete") (FuncTy [structTy] UnitTy StaticLifetimeTy) template doc - where - doc = "deletes a `" ++ (show structTy) ++ "`. This should usually not be called manually." - template = - Template - (FuncTy [VarTy "p"] UnitTy StaticLifetimeTy) - (const (toTemplate "void $NAME($p p)")) - ( const - ( toTemplate $ - unlines - [ "$DECL {", - concatMap (deleteCase typeEnv env structTy) (zip cases (True : repeat False)), - "}" - ] - ) - ) - ( \_ -> - concatMap - (depsOfPolymorphicFunction typeEnv env [] "delete" . typesDeleterFunctionType) - (filter (isManaged typeEnv env) (concatMap caseTys cases)) - ) -concreteSumtypeDelete _ _ _ _ _ = error "concretesumtypedelete" + genT :: TG.TypeGenerator TC.TypeCandidate + genT _ = (FuncTy [VarTy "p"] UnitTy StaticLifetimeTy) -deleteCase :: TypeEnv -> Env -> Ty -> (SumtypeCase, Bool) -> String -deleteCase typeEnv env concreteStructTy@(StructTy _ _) (theCase, isFirstCase) = - let (name, tys, correctedTagName) = namesFromCase theCase concreteStructTy - in unlines - [ " " ++ (if isFirstCase then "" else "else ") ++ "if(p._tag == " ++ correctedTagName ++ ") {", - joinLines $ memberDeletion typeEnv env <$> unionMembers name tys, - " }" - ] -deleteCase _ _ _ _ = error "deletecase" + decl :: TG.TokenGenerator TC.TypeCandidate + decl _ = toTemplate "void $NAME($p p)" + + body :: TG.TokenGenerator TC.TypeCandidate + 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} = + depsForDelete tenv env originalT ty (TC.getFields value) + deps _ = [] -- | Helper function to create the binder for the 'copy' template. -binderForCopy :: TypeEnv -> Env -> [String] -> Ty -> [SumtypeCase] -> Either TypeError ((String, Binder), [XObj]) -binderForCopy typeEnv env insidePath structTy@(StructTy (ConcreteNameTy _) _) cases = - Right $ - if isTypeGeneric structTy - then (genericSumtypeCopy insidePath structTy cases, []) - else concreteSumtypeCopy insidePath typeEnv env structTy cases -binderForCopy _ _ _ _ _ = error "binderforcopy" - --- | The template for the 'copy' function of a generic sumtype. -genericSumtypeCopy :: [String] -> Ty -> [SumtypeCase] -> (String, Binder) -genericSumtypeCopy pathStrings originalStructTy cases = - defineTypeParameterizedTemplate templateCreator path (FuncTy [RefTy originalStructTy (VarTy "q")] originalStructTy StaticLifetimeTy) docs +binderForCopy :: BinderGenDeps +binderForCopy candidate = + let t = TC.toType candidate + doc = "copies a `" ++ (TC.getName candidate) ++ "`." + binderT = FuncTy [RefTy t (VarTy "q")] t StaticLifetimeTy + binderP = SymPath (TC.getFullPath candidate) "copy" + in Right $ + if isTypeGeneric (TC.toType candidate) + then (defineTypeParameterizedTemplate (TG.generateGenericTypeTemplate candidate generator) binderP binderT doc, []) + else instanceBinderWithDeps binderP binderT (TG.generateConcreteTypeTemplate candidate generator) doc where - path = SymPath pathStrings "copy" - t = FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy - docs = "copies a `" ++ show originalStructTy ++ "`." - templateCreator = TemplateCreator $ - \typeEnv env -> - Template - t - (const (toTemplate "$p $NAME($p* pRef)")) - ( \(FuncTy [RefTy concreteStructTy _] _ _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedCases = replaceGenericTypesOnCases mappings cases - in tokensForSumtypeCopy typeEnv env concreteStructTy correctedCases - ) - ( \(FuncTy [RefTy concreteStructTy _] _ _) -> - let mappings = unifySignatures originalStructTy concreteStructTy - correctedCases = replaceGenericTypesOnCases mappings cases - in if isTypeGeneric concreteStructTy - then [] - else - concatMap - (depsOfPolymorphicFunction typeEnv env [] "copy" . typesCopyFunctionType) - (filter (isManaged typeEnv env) (concatMap caseTys correctedCases)) - ) + generator :: TG.TemplateGenerator TC.TypeCandidate + generator = TG.mkTemplateGenerator genT decl body deps --- | The template for the 'copy' function of a concrete sumtype -concreteSumtypeCopy :: [String] -> TypeEnv -> Env -> Ty -> [SumtypeCase] -> ((String, Binder), [XObj]) -concreteSumtypeCopy insidePath typeEnv env structTy@(StructTy (ConcreteNameTy _) _) cases = - instanceBinderWithDeps (SymPath insidePath "copy") (FuncTy [RefTy structTy (VarTy "q")] structTy StaticLifetimeTy) template doc - where - doc = "copies a `" ++ (show structTy) ++ "`." - template = - Template - (FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy) - (const (toTemplate "$p $NAME($p* pRef)")) - (const (tokensForSumtypeCopy typeEnv env structTy cases)) - ( \_ -> - concatMap - (depsOfPolymorphicFunction typeEnv env [] "copy" . typesCopyFunctionType) - (filter (isManaged typeEnv env) (concatMap caseTys cases)) - ) -concreteSumtypeCopy _ _ _ _ _ = error "concretesumtypecopy" + genT :: TG.TypeGenerator TC.TypeCandidate + genT _ = FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy -tokensForSumtypeCopy :: TypeEnv -> Env -> Ty -> [SumtypeCase] -> [Token] -tokensForSumtypeCopy typeEnv env concreteStructTy cases = - toTemplate $ - unlines - [ "$DECL {", - " $p copy = *pRef;", - joinLines $ - zipWith - (curry (copyCase typeEnv env concreteStructTy)) - cases - (True : repeat False), - " return copy;", - "}" - ] + decl :: TG.TokenGenerator TC.TypeCandidate + decl _ = toTemplate "$p $NAME($p* pRef)" -copyCase :: TypeEnv -> Env -> Ty -> (SumtypeCase, Bool) -> String -copyCase typeEnv env concreteStructTy@(StructTy _ _) (theCase, isFirstCase) = - let (name, tys, correctedTagName) = namesFromCase theCase concreteStructTy - in unlines - [ " " ++ (if isFirstCase then "" else "else ") ++ "if(pRef->_tag == " ++ correctedTagName ++ ") {", - joinLines $ memberCopy typeEnv env <$> unionMembers name tys, - " }" + body :: TG.TokenGenerator TC.TypeCandidate + 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} = + depsForCopy tenv env originalT ty (TC.getFields value) + deps _ = [] + +------------------------------------------------------------------------------- +-- Token and dep generators + +type TokenGen = TypeEnv -> Env -> Ty -> Ty -> [TC.TypeField] -> [Token] +type DepGen = TypeEnv -> Env -> Ty -> Ty -> [TC.TypeField] -> [XObj] + +-------------------------------------------------------------------------------- +-- Initializers + +-- | Generate an init function declaration. +tokensForCaseInitDecl :: Ty -> Ty -> TC.TypeField -> [Token] +tokensForCaseInitDecl orig concrete@(StructTy (ConcreteNameTy _) _) (TC.SumField _ tys) = + let mappings = unifySignatures orig concrete + concreteTys = map (replaceTyVars mappings) tys + in toTemplate ("$p $NAME(" ++ joinWithComma (zipWith (curry memberArg) anonMemberNames (remove isUnit concreteTys)) ++ ")") +tokensForCaseInitDecl _ _ _ = + error "tokensForCaseInitDecl" + +-- | Given an allocation mode, an original, possibly polymorphic type, a +-- 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 + 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 ++ ";" +tokensForCaseInit _ _ _ _ = error "tokenForCaseInit" + +accessor :: AllocationMode -> String +accessor StackAlloc = "." +accessor HeapAlloc = "->" + +-------------------------------------------------------------------------------- +-- Copy + +-- | Generates dependencies for sum type copy functions. +depsForCopy :: DepGen +depsForCopy tenv env generic concrete fields = + let mappings = unifySignatures generic concrete + concreteFields = replaceGenericTypesOnCases mappings fields + in if isTypeGeneric concrete + then [] + else + concatMap + (depsOfPolymorphicFunction tenv env [] "copy" . typesCopyFunctionType) + (filter (isManaged tenv env) (concatMap TC.fieldTypes concreteFields)) + +-- | Generates C function bodies for sum type copy functions. +tokensForSumtypeCopy :: TypeEnv -> Env -> Ty -> Ty -> [TC.TypeField] -> [Token] +tokensForSumtypeCopy typeEnv env generic concrete fields = + let mappings = unifySignatures generic concrete + concreteFields = replaceGenericTypesOnCases mappings fields + in multilineTemplate + [ "$DECL {", + " $p copy = *pRef;", + joinLines $ + zipWith + (curry copyCase) + concreteFields + (True : repeat False), + " return copy;", + "}" ] -copyCase _ _ _ _ = error "copycase" + where + copyCase :: (TC.TypeField, Bool) -> String + copyCase (theCase, isFirstCase) = + let (name, tys, correctedTagName) = namesFromCase theCase concrete + in unlines + [ " " ++ (if isFirstCase then "" else "else ") ++ "if(pRef->_tag == " ++ correctedTagName ++ ") {", + joinLines $ memberCopy typeEnv env <$> unionMembers name tys, + " }" + ] + +-------------------------------------------------------------------------------- +-- Delete + +-- | Generates tokens for the C function body of sum type copy functions. +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, + " }" + ] + +-- | 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 + concreteFields = replaceGenericTypesOnCases mappings fields + in if isTypeGeneric concrete + then [] + else concatMap + (depsOfPolymorphicFunction tenv env [] "delete" . typesDeleterFunctionType) + (filter (isManaged tenv env) (concatMap (TC.fieldTypes) concreteFields)) + +-------------------------------------------------------------------------------- +-- Str and prn + +-- | Fetches dependencies for str and prn functions. +depsForStr :: TypeEnv -> Env -> Ty -> Ty -> [TC.TypeField] -> [XObj] +depsForStr tenv env generic concrete fields = + let ft = FuncTy [RefTy concrete (VarTy "q")] StringTy StaticLifetimeTy + mappings = unifySignatures generic concrete + concreteFields = replaceGenericTypesOnCases mappings fields + tys = remove isFullyGenericType (concatMap TC.fieldTypes concreteFields) + in (concatMap (depsOfPolymorphicFunction tenv env [] "prn" . typesStrFunctionType tenv env) tys) + ++ [defineFunctionTypeAlias ft | not (isTypeGeneric concrete)] + +-- | Generates C function body tokens for sum type str and prn functions. +tokensForStr :: TypeEnv -> Env -> Ty -> Ty -> [TC.TypeField] -> [Token] +tokensForStr typeEnv env generic concrete fields = + let mappings = unifySignatures generic concrete + concreteFields = replaceGenericTypesOnCases mappings 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 concreteFields, + " String buffer = CARP_MALLOC(size);", + " String bufferPtr = buffer;", + "", + concatMap strCase concreteFields, + " 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, + " }" + ] + +-------------------------------------------------------------------------------- +-- Additional utilities + +namesFromCase :: TC.TypeField -> Ty -> (String, [Ty], String) +namesFromCase theCase concreteStructTy = + let name = TC.fieldName theCase + in (name, TC.fieldTypes (TC.SumField (TC.fieldName theCase) (remove isUnit (TC.fieldTypes theCase))), tagName concreteStructTy name) anonMemberName :: String -> String -> String anonMemberName name anon = "u." ++ name ++ "." ++ anon diff --git a/src/TemplateGenerator.hs b/src/TemplateGenerator.hs new file mode 100644 index 00000000..5a68bc20 --- /dev/null +++ b/src/TemplateGenerator.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module TemplateGenerator where + +import Obj +import Types +import qualified TypeCandidate as TC + +-------------------------------------------------------------------------------- +-- Template Generators +-- +-- 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 +} + +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 +} + +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 + t = (genT gen) $ arg + d = (\tt -> (decl gen) $ (arg {instanceT = tt})) + b = (\tt -> (body gen) $ (arg {instanceT = tt})) + p = (\tt -> (deps gen) $ (arg {instanceT = tt})) + in Template t d b p + +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 + t = (genT gen) $ arg + d = (\tt -> (decl gen) $ (arg {instanceT = tt})) + b = (\tt -> (body gen) $ (arg {instanceT = tt})) + p = (\tt -> (deps gen) $ (arg {instanceT = tt})) + in Template t d b p + +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 + t = (genT gen) arg + in TemplateCreator $ + \tenv env -> + Template + t + (\tt -> (decl gen) $ (arg {instanceT = tt, tenv = tenv, env = env})) + (\tt -> (body gen) $ (arg {instanceT = tt, tenv = tenv, env = env})) + (\tt -> (deps gen) $ (arg {instanceT = tt, tenv = tenv, env = env})) + +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 + t = (genT gen) arg + in TemplateCreator $ + \tenv env -> + Template + t + (\tt -> (decl gen) $ (arg {instanceT = tt, tenv = tenv, env = env})) + (\tt -> (body gen) $ (arg {instanceT = tt, tenv = tenv, env = env})) + (\tt -> (deps gen) $ (arg {instanceT = tt, tenv = tenv, env = env})) diff --git a/src/TypeCandidate.hs b/src/TypeCandidate.hs new file mode 100644 index 00000000..c00e4192 --- /dev/null +++ b/src/TypeCandidate.hs @@ -0,0 +1,174 @@ +-- | Module type candidate defines a structure for type definitions that have not been validated. +-- +-- 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, + ) +where + +import Types +import TypeError +import Obj +import Util + +-------------------------------------------------------------------------------- +-- Data + +data TypeVarRestriction + = AllowAny + | OnlyNamesInScope + deriving Eq + +data InterfaceConstraint = InterfaceConstraint { + name :: String, + types :: Ty +} deriving Show + +data TypeField + = StructField String Ty + | SumField String [Ty] + deriving (Eq, Show) + +data TypeMode + = Struct + | 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] +} + +-------------------------------------------------------------------------------- +-- Private + +-- | Set the member fields of a type candidate. +setMembers :: TypeCandidate -> [TypeField] -> TypeCandidate +setMembers candidate fields = candidate {members = fields} + +-- | Given a pair of XObjs, construct a struct (product type) field. +mkStructField :: (XObj, XObj) -> Either TypeError TypeField +mkStructField ((XObj (Sym (SymPath [] fname) _) _ _), tx) = + maybe (Left (NotAType tx)) (Right . StructField fname) (xobjToTy tx) +mkStructField (x, _) = Left (InvalidStructField x) + +-- | Given an XObj, construct a sum type field. +mkSumField :: XObj -> Either TypeError TypeField +mkSumField x@(XObj (Lst [XObj (Sym (SymPath [] fname) Symbol) _ _, XObj (Arr txs) _ _]) _ _) = + maybe (Left (InvalidSumtypeCase x)) (Right . SumField fname) (mapM xobjToTy txs) +mkSumField (XObj (Sym (SymPath [] fname) Symbol) _ _) = Right (SumField fname []) +mkSumField x = Left (InvalidSumtypeCase x) + +-------------------------------------------------------------------------------- +-- Public + +-- | Returns the fields of a type candidate +getFields :: TypeCandidate -> [TypeField] +getFields = members + +getName :: TypeCandidate -> String +getName = typeName + +getVariables :: TypeCandidate -> [Ty] +getVariables = variables + +getRestriction :: TypeCandidate -> TypeVarRestriction +getRestriction = restriction + +setRestriction :: TypeCandidate -> TypeVarRestriction -> TypeCandidate +setRestriction candidate restrict = candidate {restriction = restrict} + +getTypeEnv :: TypeCandidate -> TypeEnv +getTypeEnv = typeEnv + +getValueEnv :: TypeCandidate -> Env +getValueEnv = valueEnv + +getConstraints :: TypeCandidate -> [InterfaceConstraint] +getConstraints = constraints + +getMode :: TypeCandidate -> TypeMode +getMode = mode + +getPath :: TypeCandidate -> [String] +getPath = path + +getFullPath :: TypeCandidate -> [String] +getFullPath candidate = TypeCandidate.getPath candidate ++ [TypeCandidate.getName candidate] + +-- | Returns the name of a type field. +fieldName :: TypeField -> String +fieldName (StructField n _) = n +fieldName (SumField n _) = n + +-- | Returns the types of a type field. +fieldTypes :: TypeField -> [Ty] +fieldTypes (StructField _ ty) = [ty] +fieldTypes (SumField _ ts) = ts + +-- | Creates a struct type candidate. +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 + } + in if even (length memberxs) + then fmap (setMembers candidate) typedMembers + else Left (UnevenMembers memberxs) + +-- | Creates a sum type candidate. +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 + } + in fmap (setMembers candidate) typedMembers + +toType :: TypeCandidate -> Ty +toType candidate = + StructTy (ConcreteNameTy (SymPath (TypeCandidate.getPath candidate) (TypeCandidate.getName candidate))) (getVariables candidate) diff --git a/src/TypeError.hs b/src/TypeError.hs index 1dd46aa6..f3470a06 100644 --- a/src/TypeError.hs +++ b/src/TypeError.hs @@ -62,6 +62,7 @@ data TypeError | InconsistentKinds String [XObj] | FailedToAddLambdaStructToTyEnv SymPath XObj | FailedToInstantiateGenericType Ty + | InvalidStructField XObj instance Show TypeError where show (SymbolMissingType xobj env) = @@ -279,6 +280,10 @@ instance Show TypeError where "I failed to read `" ++ pretty xobj ++ "` as a sumtype case at " ++ prettyInfoFromXObj xobj ++ ".\n\nSumtype cases look like this: `(Foo [Int typevar])`" + show (InvalidStructField xobj) = + "I can't use " ++ pretty xobj ++ "as a struct field at " + ++ prettyInfoFromXObj xobj + ++ ".\n\nStruct fields look like this: x Int, e.g. (deftype Point [x Int y Int])" show (InvalidMemberType t xobj) = "I can’t use the type `" ++ show t ++ "` as a member type at " ++ prettyInfoFromXObj xobj diff --git a/src/Validate.hs b/src/Validate.hs index 7b810a8a..75e41fd9 100644 --- a/src/Validate.hs +++ b/src/Validate.hs @@ -1,77 +1,58 @@ module Validate where import Control.Monad (foldM) -import Data.Function (on) import Data.List (nubBy, (\\)) -import Data.Maybe (fromJust) import qualified Env as E import Obj import TypeError import TypePredicates import Types -import Util +import qualified TypeCandidate as TC +import qualified Reify as R -{-# ANN validateMemberCases "HLint: ignore Eta reduce" #-} +-------------------------------------------------------------------------------- +-- Public -data TypeVarRestriction - = AllowAnyTypeVariableNames -- Used when checking a type found in the code, e.g. (Foo a), any name is OK for 'a' - | AllowOnlyNamesInScope -- Used when checking a type definition, e.g. (deftype (Foo a) [x a]), requires a to be in scope - deriving (Eq) +-- | Determine whether a given type candidate is a valid type. +validateType :: TC.TypeCandidate -> Either TypeError () +validateType candidate = + do checkDuplicateMembers candidate + checkMembers candidate + checkKindConsistency candidate --- | Make sure that the member declarations in a type definition --- | Follow the pattern [ , , ...] --- | TODO: This function is only called by the deftype parts of the codebase, which is more specific than the following check implies. -validateMemberCases :: TypeEnv -> Env -> [Ty] -> [XObj] -> Either TypeError () -validateMemberCases typeEnv globalEnv typeVariables rest = mapM_ visit rest - where - visit (XObj (Arr membersXObjs) _ _) = - validateMembers AllowOnlyNamesInScope typeEnv globalEnv typeVariables membersXObjs - visit xobj = - Left (InvalidSumtypeCase xobj) +-------------------------------------------------------------------------------- +-- Private -validateMembers :: TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> [XObj] -> Either TypeError () -validateMembers typeVarRestriction typeEnv globalEnv typeVariables membersXObjs = - checkUnevenMembers >> checkDuplicateMembers >> checkMembers >> checkKindConsistency - where - pairs = pairwise membersXObjs - -- Are the number of members even? - checkUnevenMembers :: Either TypeError () - checkUnevenMembers = - if even (length membersXObjs) +-- | Checks whether any field names in the type are used more than once. +checkDuplicateMembers :: TC.TypeCandidate -> Either TypeError () +checkDuplicateMembers candidate = + let allFields = fmap TC.fieldName (TC.getFields candidate) + uniqueFields = nubBy (==) allFields + duplicates = allFields \\ uniqueFields + in if null duplicates then Right () - else Left (UnevenMembers membersXObjs) - -- Are any members duplicated? - checkDuplicateMembers :: Either TypeError () - checkDuplicateMembers = - if length fields == length uniqueFields - then Right () - else Left (DuplicatedMembers dups) - where - fields = fst <$> pairs - uniqueFields = nubBy ((==) `on` xobjObj) fields - dups = fields \\ uniqueFields - -- Do all type variables have consistent kinds? - checkKindConsistency :: Either TypeError () - checkKindConsistency = - case areKindsConsistent varsOnly of - Left var -> Left (InconsistentKinds var membersXObjs) + else Left (DuplicatedMembers (map R.symbol duplicates)) + +-- | 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 + +-- | 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 + in case areKindsConsistent allGenerics of + Left var -> Left (InconsistentKinds var (map R.reify allFieldTypes)) _ -> pure () - where - -- fromJust is safe here; invalid types will be caught in the prior check. - -- todo? be safer anyway? - varsOnly = filter isTypeGeneric (map (fromJust . xobjToTy . snd) pairs) - checkMembers :: Either TypeError () - checkMembers = mapM_ (okXObjForType typeVarRestriction typeEnv globalEnv typeVariables . snd) pairs - -okXObjForType :: TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> XObj -> Either TypeError () -okXObjForType typeVarRestriction typeEnv globalEnv typeVariables xobj = - case xobjToTy xobj of - Just t -> canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables t xobj - Nothing -> Left (NotAType xobj) -- | Can this type be used as a member for a deftype? -canBeUsedAsMemberType :: TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> Ty -> XObj -> Either TypeError () -canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables ty xobj = +canBeUsedAsMemberType :: String -> TC.TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> Ty -> Either TypeError () +canBeUsedAsMemberType tname typeVarRestriction typeEnv globalEnv typeVariables ty = case ty of UnitTy -> pure () IntTy -> pure () @@ -86,8 +67,7 @@ canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables ty xobj FuncTy {} -> pure () PointerTy UnitTy -> pure () PointerTy inner -> - canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables inner xobj - >> pure () + canBeUsedAsMemberType tname typeVarRestriction typeEnv globalEnv typeVariables inner -- Struct variables may appear as complete applications or individual -- components in the head of a definition; that is the forms: -- ((Foo (f a b)) [x (f a b)]) @@ -108,41 +88,39 @@ canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables ty xobj struct@(StructTy name tyVars) -> checkVar struct <> checkStruct name tyVars v@(VarTy _) -> checkVar v - _ -> Left (InvalidMemberType ty xobj) + _ -> Left (InvalidMemberType ty (R.reify ty)) where checkStruct :: Ty -> [Ty] -> Either TypeError () checkStruct (ConcreteNameTy (SymPath [] "Array")) [innerType] = - canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables innerType xobj - >> pure () + canBeUsedAsMemberType tname typeVarRestriction typeEnv globalEnv typeVariables innerType checkStruct (ConcreteNameTy path@(SymPath _ name)) vars = case E.getTypeBinder typeEnv name <> E.findTypeBinder globalEnv path of Right (Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) -> pure () Right (Binder _ (XObj (Lst (XObj (Deftype t) _ _ : _)) _ _)) -> - checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars + checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType tname typeVarRestriction typeEnv globalEnv typeVariables typ) () vars Right (Binder _ (XObj (Lst (XObj (DefSumtype t) _ _ : _)) _ _)) -> - checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars - _ -> Left (NotAmongRegisteredTypes ty xobj) + checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType tname typeVarRestriction typeEnv globalEnv typeVariables typ) () vars + _ -> Left (NotAmongRegisteredTypes ty (R.reify ty)) where checkInhabitants :: Ty -> Either TypeError () checkInhabitants (StructTy _ vs) = if length vs == length vars then pure () - else Left (UninhabitedConstructor ty xobj (length vs) (length vars)) - checkInhabitants _ = Left (InvalidMemberType ty xobj) + else Left (UninhabitedConstructor ty (R.reify ty) (length vs) (length vars)) + checkInhabitants _ = Left (InvalidMemberType ty (R.reify ty)) checkStruct v@(VarTy _) vars = - canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables v xobj - >> foldM (\_ typ -> canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars + canBeUsedAsMemberType tname typeVarRestriction typeEnv globalEnv typeVariables v + >> foldM (\_ typ -> canBeUsedAsMemberType tname typeVarRestriction typeEnv globalEnv typeVariables typ) () vars checkStruct _ _ = error "checkstruct" checkVar :: Ty -> Either TypeError () checkVar variable = case typeVarRestriction of - AllowAnyTypeVariableNames -> - pure () - AllowOnlyNamesInScope -> + TC.AllowAny -> pure () + TC.OnlyNamesInScope -> if any (isCaptured variable) typeVariables then pure () - else Left (InvalidMemberType ty xobj) + else Left (InvalidMemberType ty (R.reify ty)) where -- If a variable `a` appears in a higher-order polymorphic form, such as `(f a)` -- `a` may be used as a member, sans `f`, but `f` may not appear diff --git a/test/output/test/test-for-errors/deftype_type_var_not_in_scope.carp.output.expected b/test/output/test/test-for-errors/deftype_type_var_not_in_scope.carp.output.expected index f096c2a6..d813d338 100644 --- a/test/output/test/test-for-errors/deftype_type_var_not_in_scope.carp.output.expected +++ b/test/output/test/test-for-errors/deftype_type_var_not_in_scope.carp.output.expected @@ -1 +1 @@ -deftype_type_var_not_in_scope.carp:3:10 deftype_type_var_not_in_scope.carp:3:21 Can't use 'b' as a type for a member variable. +deftype_type_var_not_in_scope.carp:3:10 Can't use 'b' as a type for a member variable. diff --git a/test/output/test/test-for-errors/sumtype_type_var_not_in_scope.carp.output.expected b/test/output/test/test-for-errors/sumtype_type_var_not_in_scope.carp.output.expected index ab7dab17..c0cf9817 100644 --- a/test/output/test/test-for-errors/sumtype_type_var_not_in_scope.carp.output.expected +++ b/test/output/test/test-for-errors/sumtype_type_var_not_in_scope.carp.output.expected @@ -1 +1 @@ -sumtype_type_var_not_in_scope.carp:3:10 sumtype_type_var_not_in_scope.carp:4:3 Can't use 'x' as a type for a member variable. +sumtype_type_var_not_in_scope.carp:3:10 Can't use 'x' as a type for a member variable.