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.