mirror of
https://github.com/carp-lang/Carp.git
synced 2024-08-15 00:00:34 +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:
Scott Olsen
GitHub
parent
b3ae93bfc4
commit
d82e8a5a3f
@ -56,11 +56,12 @@ library
|
||||
StartingEnv,
|
||||
StaticArrayTemplates,
|
||||
StructUtils,
|
||||
SumtypeCase,
|
||||
Sumtypes,
|
||||
SymPath,
|
||||
Template,
|
||||
TemplateGenerator,
|
||||
ToTemplate,
|
||||
TypeCandidate,
|
||||
TypeError,
|
||||
TypePredicates,
|
||||
Types,
|
||||
|
||||
@ -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)
|
||||
|
||||
968
src/Deftype.hs
968
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)
|
||||
732
src/Sumtypes.hs
732
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
|
||||
|
||||
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]
|
||||
| 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
|
||||
|
||||
124
src/Validate.hs
124
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 [<name> <type>, <name> <type>, ...]
|
||||
-- | 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
|
||||
|
||||
@ -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