mirror of
https://github.com/carp-lang/Carp.git
synced 2024-09-17 16:38:14 +03:00
refactor: add type candidates and template generators (#1361)
* refactor: add type candidates for validation This commit adds a new module and type, the TypeCandidate, which represents a potentially valid or invalid type. We use it as the input for both type validation routines and type binding generation. The type also allows us to unify the structure of sum types and product types in an xobj agnostic way, paving the way for future simplification of binding generation for type definitions. This commit also removes SumtypeCase.hs, since it's no longer needed. * refactor: add template generators; update type templates This commit builds on the TypeCandidate data structure further by providing "template generators" that work on candidates. Using generators, templates for type functions ("methods") can be written almost completely declaratively. Generators also remove some of the typical boilerplate involved in creating templates from lists of tokens and enable us to unify several of the generic and concrete templates for types. Generators can act on type candidates or their fields (for field-specific functions). In general, this approach makes the generation of type templates more structured. A type candidate now contains all the information a generator needs to create appropriate templates, thus it is a single and well-defined input for validation and generation of user defined types. This commit also updates the Deftype templates to use template generators. * refactor: use template generators for sumtype templates
This commit is contained in:
parent
b3ae93bfc4
commit
d82e8a5a3f
@ -56,11 +56,12 @@ library
|
|||||||
StartingEnv,
|
StartingEnv,
|
||||||
StaticArrayTemplates,
|
StaticArrayTemplates,
|
||||||
StructUtils,
|
StructUtils,
|
||||||
SumtypeCase,
|
|
||||||
Sumtypes,
|
Sumtypes,
|
||||||
SymPath,
|
SymPath,
|
||||||
Template,
|
Template,
|
||||||
|
TemplateGenerator,
|
||||||
ToTemplate,
|
ToTemplate,
|
||||||
|
TypeCandidate,
|
||||||
TypeError,
|
TypeError,
|
||||||
TypePredicates,
|
TypePredicates,
|
||||||
Types,
|
Types,
|
||||||
|
@ -19,6 +19,7 @@ module Concretize
|
|||||||
tokensForCopy,
|
tokensForCopy,
|
||||||
memberCopy,
|
memberCopy,
|
||||||
replaceGenericTypeSymbolsOnMembers,
|
replaceGenericTypeSymbolsOnMembers,
|
||||||
|
replaceGenericTypeSymbolsOnFields,
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
@ -41,7 +42,6 @@ import Obj
|
|||||||
import Polymorphism
|
import Polymorphism
|
||||||
import Reify
|
import Reify
|
||||||
import qualified Set
|
import qualified Set
|
||||||
import SumtypeCase
|
|
||||||
import ToTemplate
|
import ToTemplate
|
||||||
import TypeError
|
import TypeError
|
||||||
import TypePredicates
|
import TypePredicates
|
||||||
@ -50,6 +50,7 @@ import TypesToC
|
|||||||
import Util
|
import Util
|
||||||
import Validate
|
import Validate
|
||||||
import Prelude hiding (lookup)
|
import Prelude hiding (lookup)
|
||||||
|
import qualified TypeCandidate as TC
|
||||||
|
|
||||||
data Level = Toplevel | Inside
|
data Level = Toplevel | Inside
|
||||||
|
|
||||||
@ -612,7 +613,9 @@ instantiateGenericStructType typeEnv env originalStructTy@(StructTy _ _) generic
|
|||||||
let nameFixedMembers = renameGenericTypeSymbolsOnProduct renamedOrig memberXObjs
|
let nameFixedMembers = renameGenericTypeSymbolsOnProduct renamedOrig memberXObjs
|
||||||
validMembers = replaceGenericTypeSymbolsOnMembers mappings' nameFixedMembers
|
validMembers = replaceGenericTypeSymbolsOnMembers mappings' nameFixedMembers
|
||||||
concretelyTypedMembers = replaceGenericTypeSymbolsOnMembers mappings memberXObjs
|
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)
|
deps <- mapM (depsForStructMemberPair typeEnv env) (pairwise concretelyTypedMembers)
|
||||||
let xobj =
|
let xobj =
|
||||||
XObj
|
XObj
|
||||||
@ -640,19 +643,15 @@ instantiateGenericSumtype typeEnv env originalStructTy@(StructTy _ originalTyVar
|
|||||||
let fake1 = XObj (Sym (SymPath [] "a") Symbol) Nothing Nothing
|
let fake1 = XObj (Sym (SymPath [] "a") Symbol) Nothing Nothing
|
||||||
fake2 = XObj (Sym (SymPath [] "b") Symbol) Nothing Nothing
|
fake2 = XObj (Sym (SymPath [] "b") Symbol) Nothing Nothing
|
||||||
rename@(StructTy _ renamedOrig) = evalState (renameVarTys originalStructTy) 0
|
rename@(StructTy _ renamedOrig) = evalState (renameVarTys originalStructTy) 0
|
||||||
in case solve [Constraint rename genericStructTy fake1 fake2 fake1 OrdMultiSym] of
|
nameFixedCases = map (renameGenericTypeSymbolsOnSum (zip originalTyVars renamedOrig)) cases
|
||||||
Left e -> error (show e)
|
fixLeft l = replaceLeft (FailedToInstantiateGenericType originalStructTy) l
|
||||||
Right mappings ->
|
in do mappings <- fixLeft $ solve [Constraint rename genericStructTy fake1 fake2 fake1 OrdMultiSym]
|
||||||
let nameFixedCases = map (renameGenericTypeSymbolsOnSum (zip originalTyVars renamedOrig)) cases
|
let concretelyTypedCases = map (replaceGenericTypeSymbolsOnCase mappings) nameFixedCases
|
||||||
concretelyTypedCases = map (replaceGenericTypeSymbolsOnCase mappings) nameFixedCases
|
sname = (getStructName originalStructTy)
|
||||||
deps = mapM (depsForCase typeEnv env) concretelyTypedCases
|
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.
|
candidate <- TC.mkSumtypeCandidate sname renamedOrig typeEnv env concretelyTypedCases (getPathFromStructName sname)
|
||||||
Left err -> Left err
|
validateType (TC.setRestriction candidate TC.AllowAny)
|
||||||
Right _ ->
|
pure (XObj
|
||||||
case deps of
|
|
||||||
Right okDeps ->
|
|
||||||
Right $
|
|
||||||
XObj
|
|
||||||
( Lst
|
( Lst
|
||||||
( XObj (DefSumtype genericStructTy) Nothing Nothing :
|
( XObj (DefSumtype genericStructTy) Nothing Nothing :
|
||||||
XObj (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing :
|
XObj (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing :
|
||||||
@ -661,8 +660,7 @@ instantiateGenericSumtype typeEnv env originalStructTy@(StructTy _ originalTyVar
|
|||||||
)
|
)
|
||||||
(Just dummyInfo)
|
(Just dummyInfo)
|
||||||
(Just TypeTy) :
|
(Just TypeTy) :
|
||||||
concat okDeps
|
concat deps)
|
||||||
Left err -> Left err
|
|
||||||
instantiateGenericSumtype _ _ _ _ _ = error "instantiategenericsumtype"
|
instantiateGenericSumtype _ _ _ _ _ = error "instantiategenericsumtype"
|
||||||
|
|
||||||
-- Resolves dependencies for sumtype cases.
|
-- Resolves dependencies for sumtype cases.
|
||||||
@ -677,6 +675,12 @@ depsForCase typeEnv env (XObj (Lst [_, XObj (Arr members) _ _]) _ _) =
|
|||||||
members
|
members
|
||||||
depsForCase _ _ x = Left (InvalidSumtypeCase x)
|
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 :: Map.Map String Ty -> [XObj] -> [XObj]
|
||||||
replaceGenericTypeSymbolsOnMembers mappings memberXObjs =
|
replaceGenericTypeSymbolsOnMembers mappings memberXObjs =
|
||||||
concatMap (\(v, t) -> [v, replaceGenericTypeSymbols mappings t]) (pairwise memberXObjs)
|
concatMap (\(v, t) -> [v, replaceGenericTypeSymbols mappings t]) (pairwise memberXObjs)
|
||||||
|
886
src/Deftype.hs
886
src/Deftype.hs
File diff suppressed because it is too large
Load Diff
@ -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)
|
|
690
src/Sumtypes.hs
690
src/Sumtypes.hs
@ -1,4 +1,11 @@
|
|||||||
module Sumtypes where
|
{-# LANGUAGE NamedFieldPuns #-}
|
||||||
|
|
||||||
|
module Sumtypes
|
||||||
|
(
|
||||||
|
moduleForSumtypeInContext,
|
||||||
|
moduleForSumtype
|
||||||
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Concretize
|
import Concretize
|
||||||
import Context
|
import Context
|
||||||
@ -9,7 +16,6 @@ import Info
|
|||||||
import Managed
|
import Managed
|
||||||
import Obj
|
import Obj
|
||||||
import StructUtils
|
import StructUtils
|
||||||
import SumtypeCase
|
|
||||||
import Template
|
import Template
|
||||||
import ToTemplate
|
import ToTemplate
|
||||||
import TypeError
|
import TypeError
|
||||||
@ -17,14 +23,14 @@ import TypePredicates
|
|||||||
import Types
|
import Types
|
||||||
import TypesToC
|
import TypesToC
|
||||||
import Util
|
import Util
|
||||||
import Validate (TypeVarRestriction (..))
|
import Validate
|
||||||
|
import qualified TypeCandidate as TC
|
||||||
|
import TemplateGenerator as TG
|
||||||
|
|
||||||
getCase :: [SumtypeCase] -> String -> Maybe SumtypeCase
|
--------------------------------------------------------------------------------
|
||||||
getCase cases caseNameToFind =
|
-- Public
|
||||||
case filter (\c -> caseName c == caseNameToFind) cases of
|
|
||||||
found : _ -> Just found
|
|
||||||
[] -> Nothing
|
|
||||||
|
|
||||||
|
-- | 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 :: Context -> String -> [Ty] -> [XObj] -> Maybe Info -> Either TypeError (String, XObj, [XObj])
|
||||||
moduleForSumtypeInContext ctx name vars members info =
|
moduleForSumtypeInContext ctx name vars members info =
|
||||||
let global = contextGlobalEnv ctx
|
let global = contextGlobalEnv ctx
|
||||||
@ -47,213 +53,365 @@ moduleForSumtypeInContext ctx name vars members info =
|
|||||||
)
|
)
|
||||||
in moduleForSumtype inner types global path name vars members info previous
|
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 :: 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 =
|
moduleForSumtype innerEnv typeEnv env pathStrings typeName typeVariables rest i existingEnv =
|
||||||
let moduleValueEnv = fromMaybe (new innerEnv (Just typeName)) (fmap fst existingEnv)
|
let moduleValueEnv = fromMaybe (new innerEnv (Just typeName)) (fmap fst existingEnv)
|
||||||
moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv)
|
moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv)
|
||||||
insidePath = pathStrings ++ [typeName]
|
|
||||||
in do
|
in do
|
||||||
let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables
|
-- validate the definition
|
||||||
cases <- toCases typeEnv env AllowOnlyNamesInScope typeVariables rest
|
candidate <- TC.mkSumtypeCandidate typeName typeVariables typeEnv env rest pathStrings
|
||||||
okIniters <- initers insidePath structTy cases
|
validateType candidate
|
||||||
okTag <- binderForTag insidePath structTy
|
-- produce standard function bindings
|
||||||
(okStr, okStrDeps) <- binderForStrOrPrn typeEnv env insidePath structTy cases "str"
|
(binders, deps) <- generateBinders candidate
|
||||||
(okPrn, _) <- binderForStrOrPrn typeEnv env insidePath structTy cases "prn"
|
-- insert the module into the environment
|
||||||
okDelete <- binderForDelete typeEnv env insidePath structTy cases
|
let moduleEnvWithBindings = addListOfBindings moduleValueEnv binders
|
||||||
(okCopy, okCopyDeps) <- binderForCopy typeEnv env insidePath structTy cases
|
|
||||||
okMemberDeps <- memberDeps typeEnv env cases
|
|
||||||
let moduleEnvWithBindings = addListOfBindings moduleValueEnv (okIniters ++ [okStr, okPrn, okDelete, okCopy, okTag])
|
|
||||||
typeModuleXObj = XObj (Mod moduleEnvWithBindings moduleTypeEnv) i (Just ModuleTy)
|
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
|
replaceGenericTypesOnCases mappings = map replaceOnCase
|
||||||
where
|
where
|
||||||
replaceOnCase theCase =
|
replaceOnCase :: TC.TypeField -> TC.TypeField
|
||||||
let newTys = map (replaceTyVars mappings) (caseTys theCase)
|
replaceOnCase (TC.SumField name tys) =
|
||||||
in theCase {caseTys = newTys}
|
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)
|
type BinderGen = TC.TypeCandidate -> Either TypeError (String, Binder)
|
||||||
binderForCaseInit insidePath structTy@(StructTy (ConcreteNameTy _) _) sumtypeCase =
|
type BinderGenDeps = TC.TypeCandidate -> Either TypeError ((String, Binder), [XObj])
|
||||||
if isTypeGeneric structTy
|
type MultiBinderGen = TC.TypeCandidate -> Either TypeError [(String, Binder)]
|
||||||
then Right (genericCaseInit StackAlloc insidePath structTy sumtypeCase)
|
|
||||||
else Right (concreteCaseInit StackAlloc insidePath structTy sumtypeCase)
|
|
||||||
binderForCaseInit _ _ _ = error "binderforcaseinit"
|
|
||||||
|
|
||||||
concreteCaseInit :: AllocationMode -> [String] -> Ty -> SumtypeCase -> (String, Binder)
|
-- | Generate initializer bindings for each sum type case.
|
||||||
concreteCaseInit allocationMode insidePath structTy sumtypeCase =
|
initers :: MultiBinderGen
|
||||||
instanceBinder (SymPath insidePath (caseName sumtypeCase)) (FuncTy (caseTys sumtypeCase) structTy StaticLifetimeTy) template doc
|
initers candidate = mapM binderForCaseInit (TC.getFields candidate)
|
||||||
where
|
where
|
||||||
doc = "creates a `" ++ caseName sumtypeCase ++ "`."
|
-- | Generate an initializer binding for a single sum type case, using the given candidate.
|
||||||
template =
|
binderForCaseInit :: TC.TypeField -> Either TypeError (String, Binder)
|
||||||
Template
|
binderForCaseInit sumtypeCase =
|
||||||
(FuncTy (caseTys sumtypeCase) (VarTy "p") StaticLifetimeTy)
|
if isTypeGeneric (TC.toType candidate)
|
||||||
( \(FuncTy _ concreteStructTy _) ->
|
then Right (genericCaseInit StackAlloc sumtypeCase)
|
||||||
let mappings = unifySignatures structTy concreteStructTy
|
else Right (concreteCaseInit StackAlloc sumtypeCase)
|
||||||
correctedTys = map (replaceTyVars mappings) (caseTys sumtypeCase)
|
|
||||||
in (toTemplate $ "$p $NAME(" ++ joinWithComma (zipWith (curry memberArg) anonMemberNames (remove isUnit correctedTys)) ++ ")")
|
|
||||||
)
|
|
||||||
(const (tokensForCaseInit allocationMode structTy sumtypeCase))
|
|
||||||
(\FuncTy {} -> [])
|
|
||||||
|
|
||||||
genericCaseInit :: AllocationMode -> [String] -> Ty -> SumtypeCase -> (String, Binder)
|
-- | Generates a template for a concrete (no type variables) sum type case.
|
||||||
genericCaseInit allocationMode pathStrings originalStructTy sumtypeCase =
|
concreteCaseInit :: AllocationMode -> TC.TypeField -> (String, Binder)
|
||||||
defineTypeParameterizedTemplate templateCreator path t docs
|
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"
|
||||||
|
|
||||||
|
-- | 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"
|
||||||
|
|
||||||
|
-- | 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
|
where
|
||||||
path = SymPath pathStrings (caseName sumtypeCase)
|
proto :: Ty -> String
|
||||||
t = FuncTy (caseTys sumtypeCase) originalStructTy StaticLifetimeTy
|
proto structTy = "int $NAME(" ++ tyToCLambdaFix structTy ++ " *p)"
|
||||||
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
|
|
||||||
)
|
|
||||||
|
|
||||||
tokensForCaseInit :: AllocationMode -> Ty -> SumtypeCase -> [Token]
|
-- | Helper function to create the binder for the 'str' template.
|
||||||
tokensForCaseInit allocationMode sumTy@(StructTy (ConcreteNameTy _) _) sumtypeCase =
|
binderForStrOrPrn :: TC.TypeCandidate -> String -> Either TypeError ((String, Binder), [XObj])
|
||||||
toTemplate $
|
binderForStrOrPrn candidate strOrPrn =
|
||||||
unlines
|
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
|
||||||
|
strGenerator :: TG.TemplateGenerator TC.TypeCandidate
|
||||||
|
strGenerator = TG.mkTemplateGenerator genT decl body deps
|
||||||
|
|
||||||
|
genT :: TG.TypeGenerator TC.TypeCandidate
|
||||||
|
genT GeneratorArg{value} =
|
||||||
|
FuncTy [RefTy (TC.toType value) (VarTy "q")] StringTy StaticLifetimeTy
|
||||||
|
|
||||||
|
decl :: TG.TokenGenerator TC.TypeCandidate
|
||||||
|
decl GeneratorArg{instanceT=(FuncTy [RefTy ty _] _ _)} =
|
||||||
|
toTemplate $ "String $NAME(" ++ tyToCLambdaFix ty ++ " *p)"
|
||||||
|
decl _ = toTemplate "/* template error! */"
|
||||||
|
|
||||||
|
body :: TG.TokenGenerator TC.TypeCandidate
|
||||||
|
body GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [RefTy ty _] _ _), value} =
|
||||||
|
tokensForStr tenv env originalT ty (TC.getFields value)
|
||||||
|
body _ = toTemplate "/* template error! */"
|
||||||
|
|
||||||
|
deps :: TG.DepenGenerator TC.TypeCandidate
|
||||||
|
deps GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [RefTy ty _] _ _), value} =
|
||||||
|
depsForStr tenv env originalT ty (TC.getFields value)
|
||||||
|
deps _ = []
|
||||||
|
|
||||||
|
-- | Helper function to create the binder for the 'delete' template.
|
||||||
|
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
|
||||||
|
generator :: TG.TemplateGenerator TC.TypeCandidate
|
||||||
|
generator = TG.mkTemplateGenerator genT decl body deps
|
||||||
|
|
||||||
|
genT :: TG.TypeGenerator TC.TypeCandidate
|
||||||
|
genT _ = (FuncTy [VarTy "p"] UnitTy StaticLifetimeTy)
|
||||||
|
|
||||||
|
decl :: TG.TokenGenerator TC.TypeCandidate
|
||||||
|
decl _ = toTemplate "void $NAME($p p)"
|
||||||
|
|
||||||
|
body :: TG.TokenGenerator TC.TypeCandidate
|
||||||
|
body GeneratorArg{tenv, env, originalT, instanceT=(FuncTy [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 :: 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
|
||||||
|
generator :: TG.TemplateGenerator TC.TypeCandidate
|
||||||
|
generator = TG.mkTemplateGenerator genT decl body deps
|
||||||
|
|
||||||
|
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 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 {",
|
[ "$DECL {",
|
||||||
case allocationMode of
|
allocate alloc,
|
||||||
StackAlloc -> " $p instance;"
|
joinLines (assign alloc fieldname . fst <$> unitless),
|
||||||
HeapAlloc -> " $p instance = CARP_MALLOC(sizeof(" ++ show sumTy ++ "));",
|
" instance._tag = " ++ tagName concrete fieldname ++ ";",
|
||||||
joinLines $ caseMemberAssignment allocationMode correctedName . fst <$> unitless,
|
|
||||||
" instance._tag = " ++ tagName sumTy correctedName ++ ";",
|
|
||||||
" return instance;",
|
" return instance;",
|
||||||
"}"
|
"}"
|
||||||
]
|
]
|
||||||
where
|
where allocate :: AllocationMode -> String
|
||||||
correctedName = caseName sumtypeCase
|
allocate StackAlloc = " $p instance;"
|
||||||
unitless = zip anonMemberNames $ remove isUnit (caseTys sumtypeCase)
|
allocate HeapAlloc = " $p instance = CARP_MALLOC(sizeof(" ++ show concrete ++ "));"
|
||||||
tokensForCaseInit _ _ _ = error "tokensforcaseinit"
|
|
||||||
|
|
||||||
caseMemberAssignment :: AllocationMode -> String -> String -> String
|
assign :: AllocationMode -> String -> String -> String
|
||||||
caseMemberAssignment allocationMode caseNm memberName =
|
assign alloc' name member =
|
||||||
" instance" ++ sep ++ caseNm ++ "." ++ memberName ++ " = " ++ memberName ++ ";"
|
" instance" ++ (accessor alloc') ++ "u." ++ name ++ "." ++ member ++ " = " ++ member ++ ";"
|
||||||
where
|
tokensForCaseInit _ _ _ _ = error "tokenForCaseInit"
|
||||||
sep = case allocationMode of
|
|
||||||
StackAlloc -> ".u."
|
|
||||||
HeapAlloc -> "->u."
|
|
||||||
|
|
||||||
binderForTag :: [String] -> Ty -> Either TypeError (String, Binder)
|
accessor :: AllocationMode -> String
|
||||||
binderForTag insidePath originalStructTy@(StructTy (ConcreteNameTy _) _) =
|
accessor StackAlloc = "."
|
||||||
Right $ instanceBinder path (FuncTy [RefTy originalStructTy (VarTy "q")] IntTy StaticLifetimeTy) template doc
|
accessor HeapAlloc = "->"
|
||||||
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 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])
|
-- Copy
|
||||||
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.
|
-- | Generates dependencies for sum type copy functions.
|
||||||
concreteStr :: TypeEnv -> Env -> [String] -> Ty -> [SumtypeCase] -> String -> ((String, Binder), [XObj])
|
depsForCopy :: DepGen
|
||||||
concreteStr typeEnv env insidePath concreteStructTy@(StructTy (ConcreteNameTy name) _) cases strOrPrn =
|
depsForCopy tenv env generic concrete fields =
|
||||||
instanceBinderWithDeps (SymPath insidePath strOrPrn) (FuncTy [RefTy concreteStructTy (VarTy "q")] StringTy StaticLifetimeTy) template doc
|
let mappings = unifySignatures generic concrete
|
||||||
where
|
concreteFields = replaceGenericTypesOnCases mappings fields
|
||||||
doc = "converts a `" ++ (show concreteStructTy) ++ "` to a string."
|
in if isTypeGeneric concrete
|
||||||
template =
|
then []
|
||||||
Template
|
else
|
||||||
(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
|
concatMap
|
||||||
(depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv env)
|
(depsOfPolymorphicFunction tenv env [] "copy" . typesCopyFunctionType)
|
||||||
(remove isFullyGenericType (concatMap caseTys cases))
|
(filter (isManaged tenv env) (concatMap TC.fieldTypes concreteFields))
|
||||||
)
|
|
||||||
concreteStr _ _ _ _ _ _ = error "concretestr"
|
|
||||||
|
|
||||||
-- | The template for the 'str' function for a generic deftype.
|
-- | Generates C function bodies for sum type copy functions.
|
||||||
genericStr :: [String] -> Ty -> [SumtypeCase] -> String -> (String, Binder)
|
tokensForSumtypeCopy :: TypeEnv -> Env -> Ty -> Ty -> [TC.TypeField] -> [Token]
|
||||||
genericStr insidePath originalStructTy@(StructTy (ConcreteNameTy name) _) cases strOrPrn =
|
tokensForSumtypeCopy typeEnv env generic concrete fields =
|
||||||
defineTypeParameterizedTemplate templateCreator path t docs
|
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;",
|
||||||
|
"}"
|
||||||
|
]
|
||||||
where
|
where
|
||||||
path = SymPath insidePath strOrPrn
|
copyCase :: (TC.TypeField, Bool) -> String
|
||||||
t = FuncTy [RefTy originalStructTy (VarTy "q")] StringTy StaticLifetimeTy
|
copyCase (theCase, isFirstCase) =
|
||||||
docs = "stringifies a `" ++ show originalStructTy ++ "`."
|
let (name, tys, correctedTagName) = namesFromCase theCase concrete
|
||||||
templateCreator = TemplateCreator $
|
in unlines
|
||||||
\typeEnv env ->
|
[ " " ++ (if isFirstCase then "" else "else ") ++ "if(pRef->_tag == " ++ correctedTagName ++ ") {",
|
||||||
Template
|
joinLines $ memberCopy typeEnv env <$> unionMembers name tys,
|
||||||
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"
|
|
||||||
|
|
||||||
tokensForStr :: TypeEnv -> Env -> String -> [SumtypeCase] -> Ty -> [Token]
|
--------------------------------------------------------------------------------
|
||||||
tokensForStr typeEnv env _ cases concreteStructTy =
|
-- Delete
|
||||||
toTemplate $
|
|
||||||
unlines
|
-- | 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 {",
|
[ "$DECL {",
|
||||||
" // convert members to String here:",
|
" // convert members to String here:",
|
||||||
" String temp = NULL;",
|
" String temp = NULL;",
|
||||||
" int tempsize = 0;",
|
" int tempsize = 0;",
|
||||||
" (void)tempsize; // that way we remove the occasional unused warning ",
|
" (void)tempsize; // that way we remove the occasional unused warning ",
|
||||||
calculateStructStrSize typeEnv env cases concreteStructTy,
|
calculateStructStrSize concreteFields,
|
||||||
" String buffer = CARP_MALLOC(size);",
|
" String buffer = CARP_MALLOC(size);",
|
||||||
" String bufferPtr = buffer;",
|
" String bufferPtr = buffer;",
|
||||||
"",
|
"",
|
||||||
concatMap (strCase typeEnv env concreteStructTy) cases,
|
concatMap strCase concreteFields,
|
||||||
" return buffer;",
|
" return buffer;",
|
||||||
"}"
|
"}"
|
||||||
]
|
]
|
||||||
|
where strCase :: TC.TypeField -> String
|
||||||
namesFromCase :: SumtypeCase -> Ty -> (String, [Ty], String)
|
strCase theCase =
|
||||||
namesFromCase theCase concreteStructTy =
|
let (name, tys, correctedTagName) = namesFromCase theCase concrete
|
||||||
let name = caseName theCase
|
|
||||||
in (name, caseTys theCase {caseTys = remove isUnit (caseTys theCase)}, tagName concreteStructTy name)
|
|
||||||
|
|
||||||
strCase :: TypeEnv -> Env -> Ty -> SumtypeCase -> String
|
|
||||||
strCase typeEnv env concreteStructTy@(StructTy _ _) theCase =
|
|
||||||
let (name, tys, correctedTagName) = namesFromCase theCase concreteStructTy
|
|
||||||
in unlines
|
in unlines
|
||||||
[ " if(p->_tag == " ++ correctedTagName ++ ") {",
|
[ " if(p->_tag == " ++ correctedTagName ++ ") {",
|
||||||
" sprintf(bufferPtr, \"(%s \", \"" ++ name ++ "\");",
|
" sprintf(bufferPtr, \"(%s \", \"" ++ name ++ "\");",
|
||||||
@ -263,186 +421,28 @@ strCase typeEnv env concreteStructTy@(StructTy _ _) theCase =
|
|||||||
" sprintf(bufferPtr, \")\");",
|
" sprintf(bufferPtr, \")\");",
|
||||||
" }"
|
" }"
|
||||||
]
|
]
|
||||||
strCase _ _ _ _ = error "strcase"
|
|
||||||
|
|
||||||
-- | Figure out how big the string needed for the string representation of the struct has to be.
|
-- | Figure out how big the string needed for the string representation of the struct has to be.
|
||||||
calculateStructStrSize :: TypeEnv -> Env -> [SumtypeCase] -> Ty -> String
|
calculateStructStrSize :: [TC.TypeField] -> String
|
||||||
calculateStructStrSize typeEnv env cases structTy@(StructTy (ConcreteNameTy _) _) =
|
calculateStructStrSize cases = " int size = 1;\n" ++ concatMap strSizeCase cases
|
||||||
" int size = 1;\n"
|
|
||||||
++ concatMap (strSizeCase typeEnv env structTy) cases
|
|
||||||
calculateStructStrSize _ _ _ _ = error "calculatestructstrsize"
|
|
||||||
|
|
||||||
strSizeCase :: TypeEnv -> Env -> Ty -> SumtypeCase -> String
|
strSizeCase :: TC.TypeField -> String
|
||||||
strSizeCase typeEnv env concreteStructTy@(StructTy _ _) theCase =
|
strSizeCase theCase =
|
||||||
let (name, tys, correctedTagName) = namesFromCase theCase concreteStructTy
|
let (name, tys, correctedTagName) = namesFromCase theCase concrete
|
||||||
in unlines
|
in unlines
|
||||||
[ " if(p->_tag == " ++ correctedTagName ++ ") {",
|
[ " if(p->_tag == " ++ correctedTagName ++ ") {",
|
||||||
" size += snprintf(NULL, 0, \"(%s \", \"" ++ name ++ "\");",
|
" size += snprintf(NULL, 0, \"(%s \", \"" ++ name ++ "\");",
|
||||||
joinLines $ memberPrnSize typeEnv env <$> unionMembers name tys,
|
joinLines $ memberPrnSize typeEnv env <$> unionMembers name tys,
|
||||||
" }"
|
" }"
|
||||||
]
|
]
|
||||||
strSizeCase _ _ _ _ = error "strsizecase"
|
|
||||||
|
|
||||||
-- | Helper function to create the binder for the 'delete' template.
|
--------------------------------------------------------------------------------
|
||||||
binderForDelete :: TypeEnv -> Env -> [String] -> Ty -> [SumtypeCase] -> Either TypeError (String, Binder)
|
-- Additional utilities
|
||||||
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.
|
namesFromCase :: TC.TypeField -> Ty -> (String, [Ty], String)
|
||||||
genericSumtypeDelete :: [String] -> Ty -> [SumtypeCase] -> (String, Binder)
|
namesFromCase theCase concreteStructTy =
|
||||||
genericSumtypeDelete pathStrings originalStructTy cases =
|
let name = TC.fieldName theCase
|
||||||
defineTypeParameterizedTemplate templateCreator path (FuncTy [originalStructTy] UnitTy StaticLifetimeTy) docs
|
in (name, TC.fieldTypes (TC.SumField (TC.fieldName theCase) (remove isUnit (TC.fieldTypes theCase))), tagName concreteStructTy name)
|
||||||
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))
|
|
||||||
)
|
|
||||||
|
|
||||||
-- | 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"
|
|
||||||
|
|
||||||
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"
|
|
||||||
|
|
||||||
-- | 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
|
|
||||||
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))
|
|
||||||
)
|
|
||||||
|
|
||||||
-- | 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"
|
|
||||||
|
|
||||||
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;",
|
|
||||||
"}"
|
|
||||||
]
|
|
||||||
|
|
||||||
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,
|
|
||||||
" }"
|
|
||||||
]
|
|
||||||
copyCase _ _ _ _ = error "copycase"
|
|
||||||
|
|
||||||
anonMemberName :: String -> String -> String
|
anonMemberName :: String -> String -> String
|
||||||
anonMemberName name anon = "u." ++ name ++ "." ++ anon
|
anonMemberName name anon = "u." ++ name ++ "." ++ anon
|
||||||
|
97
src/TemplateGenerator.hs
Normal file
97
src/TemplateGenerator.hs
Normal file
@ -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}))
|
174
src/TypeCandidate.hs
Normal file
174
src/TypeCandidate.hs
Normal file
@ -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)
|
@ -62,6 +62,7 @@ data TypeError
|
|||||||
| InconsistentKinds String [XObj]
|
| InconsistentKinds String [XObj]
|
||||||
| FailedToAddLambdaStructToTyEnv SymPath XObj
|
| FailedToAddLambdaStructToTyEnv SymPath XObj
|
||||||
| FailedToInstantiateGenericType Ty
|
| FailedToInstantiateGenericType Ty
|
||||||
|
| InvalidStructField XObj
|
||||||
|
|
||||||
instance Show TypeError where
|
instance Show TypeError where
|
||||||
show (SymbolMissingType xobj env) =
|
show (SymbolMissingType xobj env) =
|
||||||
@ -279,6 +280,10 @@ instance Show TypeError where
|
|||||||
"I failed to read `" ++ pretty xobj ++ "` as a sumtype case at "
|
"I failed to read `" ++ pretty xobj ++ "` as a sumtype case at "
|
||||||
++ prettyInfoFromXObj xobj
|
++ prettyInfoFromXObj xobj
|
||||||
++ ".\n\nSumtype cases look like this: `(Foo [Int typevar])`"
|
++ ".\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) =
|
show (InvalidMemberType t xobj) =
|
||||||
"I can’t use the type `" ++ show t ++ "` as a member type at "
|
"I can’t use the type `" ++ show t ++ "` as a member type at "
|
||||||
++ prettyInfoFromXObj xobj
|
++ prettyInfoFromXObj xobj
|
||||||
|
124
src/Validate.hs
124
src/Validate.hs
@ -1,77 +1,58 @@
|
|||||||
module Validate where
|
module Validate where
|
||||||
|
|
||||||
import Control.Monad (foldM)
|
import Control.Monad (foldM)
|
||||||
import Data.Function (on)
|
|
||||||
import Data.List (nubBy, (\\))
|
import Data.List (nubBy, (\\))
|
||||||
import Data.Maybe (fromJust)
|
|
||||||
import qualified Env as E
|
import qualified Env as E
|
||||||
import Obj
|
import Obj
|
||||||
import TypeError
|
import TypeError
|
||||||
import TypePredicates
|
import TypePredicates
|
||||||
import Types
|
import Types
|
||||||
import Util
|
import qualified TypeCandidate as TC
|
||||||
|
import qualified Reify as R
|
||||||
|
|
||||||
{-# ANN validateMemberCases "HLint: ignore Eta reduce" #-}
|
--------------------------------------------------------------------------------
|
||||||
|
-- Public
|
||||||
|
|
||||||
data TypeVarRestriction
|
-- | Determine whether a given type candidate is a valid type.
|
||||||
= AllowAnyTypeVariableNames -- Used when checking a type found in the code, e.g. (Foo a), any name is OK for 'a'
|
validateType :: TC.TypeCandidate -> Either TypeError ()
|
||||||
| AllowOnlyNamesInScope -- Used when checking a type definition, e.g. (deftype (Foo a) [x a]), requires a to be in scope
|
validateType candidate =
|
||||||
deriving (Eq)
|
do checkDuplicateMembers candidate
|
||||||
|
checkMembers candidate
|
||||||
|
checkKindConsistency candidate
|
||||||
|
|
||||||
-- | Make sure that the member declarations in a type definition
|
--------------------------------------------------------------------------------
|
||||||
-- | Follow the pattern [<name> <type>, <name> <type>, ...]
|
-- Private
|
||||||
-- | 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)
|
|
||||||
|
|
||||||
validateMembers :: TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> [XObj] -> Either TypeError ()
|
-- | Checks whether any field names in the type are used more than once.
|
||||||
validateMembers typeVarRestriction typeEnv globalEnv typeVariables membersXObjs =
|
checkDuplicateMembers :: TC.TypeCandidate -> Either TypeError ()
|
||||||
checkUnevenMembers >> checkDuplicateMembers >> checkMembers >> checkKindConsistency
|
checkDuplicateMembers candidate =
|
||||||
where
|
let allFields = fmap TC.fieldName (TC.getFields candidate)
|
||||||
pairs = pairwise membersXObjs
|
uniqueFields = nubBy (==) allFields
|
||||||
-- Are the number of members even?
|
duplicates = allFields \\ uniqueFields
|
||||||
checkUnevenMembers :: Either TypeError ()
|
in if null duplicates
|
||||||
checkUnevenMembers =
|
|
||||||
if even (length membersXObjs)
|
|
||||||
then Right ()
|
then Right ()
|
||||||
else Left (UnevenMembers membersXObjs)
|
else Left (DuplicatedMembers (map R.symbol duplicates))
|
||||||
-- Are any members duplicated?
|
|
||||||
checkDuplicateMembers :: Either TypeError ()
|
-- | Returns an error if one of the types fields can't be used as a member type.
|
||||||
checkDuplicateMembers =
|
checkMembers :: TC.TypeCandidate -> Either TypeError ()
|
||||||
if length fields == length uniqueFields
|
checkMembers candidate =
|
||||||
then Right ()
|
let tenv = TC.getTypeEnv candidate
|
||||||
else Left (DuplicatedMembers dups)
|
env = TC.getValueEnv candidate
|
||||||
where
|
tys = concat (map TC.fieldTypes (TC.getFields candidate))
|
||||||
fields = fst <$> pairs
|
in mapM_ (canBeUsedAsMemberType (TC.getName candidate) (TC.getRestriction candidate) tenv env (TC.getVariables candidate)) tys
|
||||||
uniqueFields = nubBy ((==) `on` xobjObj) fields
|
|
||||||
dups = fields \\ uniqueFields
|
-- | 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.
|
||||||
-- Do all type variables have consistent kinds?
|
checkKindConsistency :: TC.TypeCandidate -> Either TypeError ()
|
||||||
checkKindConsistency :: Either TypeError ()
|
checkKindConsistency candidate =
|
||||||
checkKindConsistency =
|
let allFieldTypes = concat (map TC.fieldTypes (TC.getFields candidate))
|
||||||
case areKindsConsistent varsOnly of
|
allGenerics = filter isTypeGeneric $ allFieldTypes
|
||||||
Left var -> Left (InconsistentKinds var membersXObjs)
|
in case areKindsConsistent allGenerics of
|
||||||
|
Left var -> Left (InconsistentKinds var (map R.reify allFieldTypes))
|
||||||
_ -> pure ()
|
_ -> 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?
|
-- | Can this type be used as a member for a deftype?
|
||||||
canBeUsedAsMemberType :: TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> Ty -> XObj -> Either TypeError ()
|
canBeUsedAsMemberType :: String -> TC.TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> Ty -> Either TypeError ()
|
||||||
canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables ty xobj =
|
canBeUsedAsMemberType tname typeVarRestriction typeEnv globalEnv typeVariables ty =
|
||||||
case ty of
|
case ty of
|
||||||
UnitTy -> pure ()
|
UnitTy -> pure ()
|
||||||
IntTy -> pure ()
|
IntTy -> pure ()
|
||||||
@ -86,8 +67,7 @@ canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables ty xobj
|
|||||||
FuncTy {} -> pure ()
|
FuncTy {} -> pure ()
|
||||||
PointerTy UnitTy -> pure ()
|
PointerTy UnitTy -> pure ()
|
||||||
PointerTy inner ->
|
PointerTy inner ->
|
||||||
canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables inner xobj
|
canBeUsedAsMemberType tname typeVarRestriction typeEnv globalEnv typeVariables inner
|
||||||
>> pure ()
|
|
||||||
-- Struct variables may appear as complete applications or individual
|
-- Struct variables may appear as complete applications or individual
|
||||||
-- components in the head of a definition; that is the forms:
|
-- components in the head of a definition; that is the forms:
|
||||||
-- ((Foo (f a b)) [x (f a b)])
|
-- ((Foo (f a b)) [x (f a b)])
|
||||||
@ -108,41 +88,39 @@ canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables ty xobj
|
|||||||
struct@(StructTy name tyVars) ->
|
struct@(StructTy name tyVars) ->
|
||||||
checkVar struct <> checkStruct name tyVars
|
checkVar struct <> checkStruct name tyVars
|
||||||
v@(VarTy _) -> checkVar v
|
v@(VarTy _) -> checkVar v
|
||||||
_ -> Left (InvalidMemberType ty xobj)
|
_ -> Left (InvalidMemberType ty (R.reify ty))
|
||||||
where
|
where
|
||||||
checkStruct :: Ty -> [Ty] -> Either TypeError ()
|
checkStruct :: Ty -> [Ty] -> Either TypeError ()
|
||||||
checkStruct (ConcreteNameTy (SymPath [] "Array")) [innerType] =
|
checkStruct (ConcreteNameTy (SymPath [] "Array")) [innerType] =
|
||||||
canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables innerType xobj
|
canBeUsedAsMemberType tname typeVarRestriction typeEnv globalEnv typeVariables innerType
|
||||||
>> pure ()
|
|
||||||
checkStruct (ConcreteNameTy path@(SymPath _ name)) vars =
|
checkStruct (ConcreteNameTy path@(SymPath _ name)) vars =
|
||||||
case E.getTypeBinder typeEnv name <> E.findTypeBinder globalEnv path of
|
case E.getTypeBinder typeEnv name <> E.findTypeBinder globalEnv path of
|
||||||
Right (Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) ->
|
Right (Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) ->
|
||||||
pure ()
|
pure ()
|
||||||
Right (Binder _ (XObj (Lst (XObj (Deftype t) _ _ : _)) _ _)) ->
|
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) _ _ : _)) _ _)) ->
|
Right (Binder _ (XObj (Lst (XObj (DefSumtype 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
|
||||||
_ -> Left (NotAmongRegisteredTypes ty xobj)
|
_ -> Left (NotAmongRegisteredTypes ty (R.reify ty))
|
||||||
where
|
where
|
||||||
checkInhabitants :: Ty -> Either TypeError ()
|
checkInhabitants :: Ty -> Either TypeError ()
|
||||||
checkInhabitants (StructTy _ vs) =
|
checkInhabitants (StructTy _ vs) =
|
||||||
if length vs == length vars
|
if length vs == length vars
|
||||||
then pure ()
|
then pure ()
|
||||||
else Left (UninhabitedConstructor ty xobj (length vs) (length vars))
|
else Left (UninhabitedConstructor ty (R.reify ty) (length vs) (length vars))
|
||||||
checkInhabitants _ = Left (InvalidMemberType ty xobj)
|
checkInhabitants _ = Left (InvalidMemberType ty (R.reify ty))
|
||||||
checkStruct v@(VarTy _) vars =
|
checkStruct v@(VarTy _) vars =
|
||||||
canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables v xobj
|
canBeUsedAsMemberType tname typeVarRestriction typeEnv globalEnv typeVariables v
|
||||||
>> foldM (\_ typ -> canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars
|
>> foldM (\_ typ -> canBeUsedAsMemberType tname typeVarRestriction typeEnv globalEnv typeVariables typ) () vars
|
||||||
checkStruct _ _ = error "checkstruct"
|
checkStruct _ _ = error "checkstruct"
|
||||||
checkVar :: Ty -> Either TypeError ()
|
checkVar :: Ty -> Either TypeError ()
|
||||||
checkVar variable =
|
checkVar variable =
|
||||||
case typeVarRestriction of
|
case typeVarRestriction of
|
||||||
AllowAnyTypeVariableNames ->
|
TC.AllowAny -> pure ()
|
||||||
pure ()
|
TC.OnlyNamesInScope ->
|
||||||
AllowOnlyNamesInScope ->
|
|
||||||
if any (isCaptured variable) typeVariables
|
if any (isCaptured variable) typeVariables
|
||||||
then pure ()
|
then pure ()
|
||||||
else Left (InvalidMemberType ty xobj)
|
else Left (InvalidMemberType ty (R.reify ty))
|
||||||
where
|
where
|
||||||
-- If a variable `a` appears in a higher-order polymorphic form, such as `(f a)`
|
-- 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
|
-- `a` may be used as a member, sans `f`, but `f` may not appear
|
||||||
|
@ -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.
|
||||||
|
@ -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.
|
||||||
|
Loading…
Reference in New Issue
Block a user