helium-1.8: src/Helium/CodeGeneration/ToCoreDecl.ag
-- ------------------------------------------------------------------------
-- -- Declarations --
-- ------------------------------------------------------------------------
ATTR Declaration Declarations [ | patBindNr : Int | ]
SEM MaybeDeclarations [ | | core : { Core.Expr -> Core.Expr } ]
| Nothing lhs.core = \continue -> continue
| Just declarations.patBindNr = 0
declarations.isTopLevel = False
lhs.core = \continue -> letrec_ @declarations.decls continue
SEM Declaration
| Type lhs.decls =
let -- if we would have the collected type synonym information here, things could have been
-- done much easier.
(t1,[t2]) = convertFromSimpleTypeAndTypes @simpletype.self [@type.self]
allTypeVars = ftv [t1,t2]
(ts1,ts2) = ( Quantification (allTypeVars, [], [] .=>. t1) :: TpScheme
, Quantification (allTypeVars, [], [] .=>. t2) :: TpScheme
)
in
[ Core.DeclCustom
{ Core.declName = idFromString (getNameName @simpletype.name)
, Core.declAccess = Core.private
, Core.declKind = Core.DeclKindCustom (idFromString "typedecl")
, Core.declCustoms =
[ Core.CustomBytes
(Byte.bytesFromString
( show ts1
++ " = "
++ show ts2
)
)
, Core.CustomInt
(length @simpletype.typevariables)
]
}
]
++
[ DerivingShow.typeShowFunction @self ]
| Data constructors.tag = 0
constructors.dataTypeName = @simpletype.name
lhs.decls =
map snd @constructors.cons
++
[ Core.DeclCustom
{ Core.declName = idFromString (getNameName @simpletype.name)
, Core.declAccess = Core.private
, Core.declKind = Core.DeclKindCustom (idFromString "data")
, Core.declCustoms = [Core.CustomInt (length @simpletype.typevariables)]
}
]
++
[ DerivingShow.dataShowFunction @self ]
++
(if "Show" `elem` map show @derivings.self
then [ DerivingShow.dataDictionary @self ]
else []
)
++
(if "Eq" `elem` map show @derivings.self
then [ DerivingEq.dataDictionary @self ]
else []
)
-- range : Range
-- context : ContextItems
-- simpletype : SimpleType
-- constructors : Constructors
-- derivings : Names
| FunctionBindings loc.ids = freshIds "u$" @bindings.arity
bindings.ids = @loc.ids
bindings.range = @range.self
loc.dictionaries = map predicateToId
(getPredicateForDecl @bindings.name @lhs.dictionaryEnv)
lhs.decls =
[ Core.DeclValue
{ Core.declName = idFromName @bindings.name
, Core.declAccess = Core.private
, Core.valueEnc = Nothing
, Core.valueValue = foldr Core.Lam @bindings.core (@dictionaries ++ @ids)
, Core.declCustoms = toplevelType @bindings.name @lhs.importEnv @lhs.isTopLevel
}
]
-- range : Range
-- bindings : FunctionBindings -- should all be for the same function
| PatternBinding lhs.patBindNr = @lhs.patBindNr + 1
loc.dictionaries =
case @pattern.self of
Pattern_Variable _ n ->
map predicateToId
(getPredicateForDecl n @lhs.dictionaryEnv)
_ -> []
lhs.decls =
case @pattern.self of
Pattern_Variable _ n ->
[ Core.DeclValue
{ Core.declName = idFromName n
, Core.declAccess = Core.private
, Core.valueEnc = Nothing
, Core.valueValue =
foldr Core.Lam
( let_ -- because guards can fail
nextClauseId (patternMatchFail "pattern binding" @range.self)
@righthandside.core
)
@dictionaries
, Core.declCustoms = toplevelType n @lhs.importEnv @lhs.isTopLevel
}
]
_ ->
Core.DeclValue
{ Core.declName = patBindId
, Core.declAccess = Core.private
, Core.valueEnc = Nothing
, Core.valueValue =
let_
nextClauseId (patternMatchFail "pattern binding" @range.self)
@righthandside.core
, Core.declCustoms = [custom "type" "patternbinding"]
}
:
[ Core.DeclValue
{ Core.declName = idFromName v
, Core.declAccess = Core.private
, Core.valueEnc = Nothing
, Core.valueValue =
(let_ nextClauseId (patternMatchFail "pattern binding" @range.self)
(patternToCore (patBindId, @pattern.self) (Core.Var (idFromName v)))
)
, Core.declCustoms = toplevelType v @lhs.importEnv @lhs.isTopLevel
}
| v <- @pattern.vars
]
where
patBindId = idFromString ("patBind$" ++ show @lhs.patBindNr)
-- range : Range
-- pattern : Pattern
-- righthandside : RightHandSide
| TypeSignature lhs.decls = []
-- range : Range
-- names : Names
-- type : Type -- may have context
| Fixity lhs.decls =
map
( ( \n ->
Core.DeclCustom
{ Core.declName = idFromString n
, Core.declAccess = Core.private
, Core.declKind = (Core.DeclKindCustom . idFromString) "infix"
, Core.declCustoms =
[ Core.CustomInt
( case @priority.self of
MaybeInt_Just i -> i
MaybeInt_Nothing -> 9 )
, (Core.CustomBytes . bytesFromString)
( case @fixity.self of
Fixity_Infixr _ -> "right"
Fixity_Infixl _ -> "left"
Fixity_Infix _ -> "none"
-- _ -> internalError
-- "ToCoreDecl.ag"
-- "SEM Declaration.Fixity"
-- "unknown fixity"
)
]
}
)
.
getNameName
)
@operators.self
-- range : Range
-- fixity : Fixity
-- priority : MaybeInt
-- operators : Names
-- Not supported
| Newtype lhs.decls = internalError "ToCoreDecl" "Declaration" "'newType' not supported"
constructor.tag = 0
constructor.dataTypeName = @simpletype.name
-- range : Range
-- context : ContextItems
-- simpletype : SimpleType
-- constructor : Constructor -- has only one field, no strictness
-- derivings : Names
| Class lhs.decls = internalError "ToCoreDecl" "Declaration" "'class' not supported"
-- range : Range
-- context : ContextItems -- is a "simple" context
-- simpletype : SimpleType -- Haskell 98 allows only one variable
-- where : MaybeDeclarations -- cannot have everything
| Instance lhs.decls = internalError "ToCoreDecl" "Declaration" "'instance' not supported"
-- range : Range
-- context : ContextItems -- is a "simple" context
-- name : Name
-- types : Types -- Haskell 98 allows only one type
-- that is severely restricted
-- where : MaybeDeclarations -- cannot have everything
| Default lhs.decls = internalError "ToCoreDecl" "Declaration" "'default' not supported"
-- range : Range
-- types : Types -- should be instances of Num
| Empty lhs.decls = internalError "ToCoreDecl" "Declaration" "empty declarations not supported"
-- range : Range
ATTR FunctionBinding FunctionBindings
[ ids : { [Id] }
|
| arity : Int
]
SEM FunctionBindings [ range : Range | | core : {Core.Expr} ]
| Cons lhs.core = @hd.core @tl.core
.arity = @hd.arity
| Nil lhs.core = patternMatchFail "function bindings" @lhs.range
.arity = internalError "ToCoreDecl" "FunctionBindings" "arity: empty list of function bindings"
SEM FunctionBinding [ | | core : { Core.Expr -> Core.Expr } ]
| Hole lhs.arity = 0
. core = internalError "ToCoreDecl" "FunctionBinding" "holes not supported"
| FunctionBinding lhs.arity = @lefthandside.arity
lhs.core =
\nextClause ->
let thisClause =
patternsToCore
(zip @lhs.ids @lefthandside.patterns)
@righthandside.core in
if all patternAlwaysSucceeds @lefthandside.patterns
&&
not @righthandside.isGuarded
then
thisClause
else
let_ nextClauseId nextClause thisClause
-- range : Range
-- lefthandside : LeftHandSide
-- righthandside : RightHandSide
{
predicateToId :: Predicate -> Id
predicateToId (Predicate class_ tp) =
idFromString $ "$dict" ++ class_ ++ show tp
dictionaryTreeToCore :: DictionaryTree -> Core.Expr
dictionaryTreeToCore theTree =
case theTree of
ByPredicate predicate ->
Core.Var (predicateToId predicate)
ByInstance className instanceName trees ->
foldl Core.Ap
(Core.Var (idFromString ("$dict"++className++instanceName)))
(map dictionaryTreeToCore trees)
BySuperClass subClass superClass tree ->
Core.Ap (Core.Var (idFromString ("$get" ++ superClass ++ "From" ++ subClass)))
(dictionaryTreeToCore tree)
insertDictionaries :: Name -> DictionaryEnvironment -> Core.Expr
insertDictionaries name dictionaryEnv =
foldl Core.Ap
(Core.Var (idFromName name))
(map dictionaryTreeToCore (getDictionaryTrees name dictionaryEnv))
}
ATTR LeftHandSide
[
|
| arity : Int
patterns : Patterns
]
SEM LeftHandSide
| Function lhs.arity = @patterns.length
.patterns = @patterns.self
-- range : Range
-- name : Name
-- patterns : Patterns
| Infix lhs.arity = 2
.patterns = [@leftPattern.self, @rightPattern.self ]
-- range : Range
-- leftPattern : Pattern
-- operator : Name
-- rightPattern : Pattern
| Parenthesized lhs.arity = @lefthandside.arity + @patterns.length
.patterns = @lefthandside.patterns ++ @patterns.self
-- range : Range
-- lefthandside : LeftHandSide
-- patterns : Patterns
SEM RightHandSide
[
|
| core : { Core.Expr }
isGuarded : Bool
]
| Expression lhs.core = @where.core @expression.core
.isGuarded = False
-- range : Range
-- expression : Expression
-- where : MaybeDeclarations
| Guarded lhs.isGuarded = True
.core =
@where.core (foldr ($) (Core.Var nextClauseId) @guardedexpressions.core)
-- range : Range
-- guardedexpressions : GuardedExpressions
-- where : MaybeDeclarations
-- ------------------------------------------------------------------------
-- -- Types --
-- ------------------------------------------------------------------------
ATTR Constructors Constructor
[ tag : Int
|
| cons USE { ++ } { [] } : { [(Id, CoreDecl)] }
]
SEM Constructors [ dataTypeName : Name | | ]
| Cons hd.tag = @lhs.tag
tl.tag = @lhs.tag + 1
SEM Constructor [ dataTypeName : Name | | ]
| Constructor lhs.cons =
[ (idFromName @constructor.self, Core.DeclCon
{ Core.declName = idFromName @constructor.self
, Core.declAccess = Core.private
, Core.declArity = @types.length
, Core.conTag = @lhs.tag
, Core.declCustoms = constructorCustoms
@lhs.dataTypeName
@constructor.self
(valueConstructors @lhs.importEnv)
}
)
]
-- range : Range
-- constructor : Name
-- types : AnnotatedTypes
| Infix lhs.cons =
[ (idFromName @constructorOperator.self, Core.DeclCon
{ Core.declName = idFromName @constructorOperator.self
, Core.declAccess = Core.private
, Core.declArity = 2
, Core.conTag = @lhs.tag
, Core.declCustoms = constructorCustoms
@lhs.dataTypeName
@constructorOperator.self
(valueConstructors @lhs.importEnv)
}
)
]
-- range : Range
-- leftType : AnnotatedType
-- constructorOperator : Name
-- rightType : AnnotatedType
-- Not supported
| Record lhs.cons = internalError "ToCoreDecl" "Constructor" "records not supported"
-- range : Range
-- constructor : Name
-- fieldDeclarations : FieldDeclarations
SEM AnnotatedTypes [ | | length : Int ]
| Cons lhs.length = 1 + @tl.length
| Nil lhs.length = 0
{
toplevelType :: Name -> ImportEnvironment -> Bool -> [Core.Custom]
toplevelType name ie isTopLevel
| isTopLevel = [custom "type" typeString]
| otherwise = []
where
typeString = maybe
(internalError "ToCoreDecl" "Declaration" ("no type found for " ++ getNameName name))
show
(M.lookup name (typeEnvironment ie))
constructorCustoms :: Name -> Name -> ValueConstructorEnvironment -> [Core.Custom]
constructorCustoms dataTypeName name env =
maybe
(internalError "ToCoreDecl" "Constructor" ("no type found for " ++ show name))
(\tpScheme ->
[ custom "type" (show tpScheme)
, Core.CustomLink
(idFromName dataTypeName)
(Core.DeclKindCustom (idFromString "data"))
]
)
(M.lookup name env)
}