helium-1.8: src/Helium/CodeGeneration/ToCoreExpr.ag
-- ------------------------------------------------------------------------
-- -- Expressions --
-- ------------------------------------------------------------------------
SEM MaybeExpression [ | | core : { Maybe Core.Expr } ]
| Nothing lhs.core = Nothing
| Just lhs.core = Just @expression.core
-- expression : Expression
ATTR Expressions [ | | core USE { : } { [] } : { [Core.Expr] } ]
SEM Expression [ | | core : { Core.Expr } ]
| Literal lhs.core = @literal.core
-- range : Range
-- literal : Literal
| Variable lhs.core = insertDictionaries @name.self @lhs.dictionaryEnv
-- range : Range
-- name : Name
| Hole lhs.core = Core.Var (idFromString "undefined")
-- range : Range
-- id : Integer
| Constructor lhs.core = Core.Con (Core.ConId (idFromName @name.self))
-- range : Range
-- name : Name
| Parenthesized lhs.core = @expression.core
-- range : Range
-- expression : Expression
| NormalApplication lhs.core = foldl Core.Ap @function.core @arguments.core
-- range : Range
-- function : Expression
-- arguments : Expressions
| InfixApplication lhs.core =
case (@leftExpression.core, @rightExpression.core) of
(Nothing, Nothing) -> @operator.core
(Just l , Nothing) -> Core.Ap @operator.core l
(Nothing, Just r ) -> Core.Lam parameterId
(foldl Core.Ap @operator.core [Core.Var parameterId, r])
{-
-- At most one new variable is needed. Consider
-- (. (+ 3)) == \x -> (.) x (\x -> (+) x 3)
-}
(Just l , Just r ) -> foldl Core.Ap @operator.core [l,r]
-- range : Range
-- leftExpression : MaybeExpression
-- operator : Expression
-- rightExpression : MaybeExpression
| If lhs.core =
if_ @guardExpression.core @thenExpression.core @elseExpression.core
-- range : Range
-- guardExpression : Expression
-- thenExpression : Expression
-- elseExpression : Expression
| Lambda lhs.core =
let ids = freshIds "u$" @patterns.length
in let_ nextClauseId (patternMatchFail "lambda expression" @range.self)
(foldr
Core.Lam
(patternsToCore
(zip ids @patterns.self)
@expression.core
)
ids
)
-- range : Range
-- patterns : Patterns
-- expression : Expression
| Case lhs.core = let_ caseExprId @expression.core @alternatives.core
alternatives.caseRange = @range.self
-- range : Range
-- expression : Expression
-- alternatives : Alternatives
| Let declarations.patBindNr = 0
declarations.isTopLevel = False
lhs.core =
letrec_ @declarations.decls @expression.core
-- range : Range
-- declarations : Declarations
-- expression : Expression
| Do lhs.core = chainCode @statements.core
-- range : Range
-- statements : Statements
| List lhs.core = coreList @expressions.core
-- range : Range
-- expressions : Expressions
| Tuple lhs.core =
foldl
Core.Ap
(Core.Con
(Core.ConTag
(Core.Lit (Core.LitInt 0))
(length @expressions.core)
)
)
@expressions.core
-- range : Range
-- expressions : Expressions
| Comprehension lhs.core =
let singleton x = cons x nil
in foldr ($) (singleton @expression.core) @qualifiers.core
-- range : Range
-- expression : Expression
-- qualifiers : Qualifiers
| Typed lhs.core = @expression.core
-- range : Range
-- expression : Expression
-- type : Type
-- negate is overloaded and we need to insert a dictionary argument
| Negate lhs.core = insertDictionaries (setNameRange intUnaryMinusName @range.self) @lhs.dictionaryEnv
`app_` @expression.core
-- range : Range
-- expression : Expression
| NegateFloat lhs.core =
var "$primNegFloat" `app_` @expression.core
-- range : Range
-- expression : Expression
-- enumerations are overloaded and we need to insert a dictionary argument
| Enum lhs.core =
case (@then.core, @to.core) of
(Just then_, Just to) ->
insertDictionaries (setNameRange enumFromThenToName @range.self) @lhs.dictionaryEnv
`app_` @from.core `app_` then_ `app_` to
(Just then_, Nothing) ->
insertDictionaries (setNameRange enumFromThenName @range.self) @lhs.dictionaryEnv
`app_` @from.core `app_` then_
(Nothing, Just to) ->
insertDictionaries (setNameRange enumFromToName @range.self) @lhs.dictionaryEnv
`app_` @from.core `app_` to
(Nothing, Nothing) ->
insertDictionaries (setNameRange enumFromName @range.self) @lhs.dictionaryEnv
`app_` @from.core
-- range : Range
-- from : Expression
-- then : MaybeExpression
-- to : MaybeExpression
| RecordConstruction lhs.core = internalError "ToCoreExpr" "Expression" "records not supported"
-- range : Range
-- name : Name
-- recordExpressionBindings : RecordExpressionBindings
| RecordUpdate lhs.core = internalError "ToCoreExpr" "Expression" "records not supported"
-- range : Range
-- expression : Expression
-- recordExpressionBindings : RecordExpressionBindings
ATTR Statements [ | | core USE { : } { [] } : { [Maybe Core.Expr -> Core.Expr] } ]
SEM Statement [ | | core : { Maybe Core.Expr -> Core.Expr } ]
| Expression lhs.core =
\theRest ->
case theRest of
Nothing -> @expression.core
Just rest -> bind @expression.core (Core.Lam dummyId rest)
-- range : Range
-- expression : Expression
| Let declarations.patBindNr = 0
declarations.isTopLevel = False
lhs.core =
\theRest ->
case theRest of
Nothing -> internalError "ToCoreExpr" "Statement" "'let' can't be last in 'do'"
Just rest -> letrec_ @declarations.decls rest
-- range : Range
-- declarations : Declarations
-- let _nextClause = <throw exception> in
-- let _ok = \_misc -> case _misc of { pattern -> ...; _ -> _nextClause }
-- in expression >>= ok
| Generator lhs.core =
\theRest -> case theRest of
Nothing -> internalError "ToCoreExpr" "Statement" "generator can't be last in 'do'"
Just rest ->
let_ nextClauseId (patternMatchFail "generator" @range.self)
(let_
okId
(Core.Lam parameterId
(patternToCore (parameterId, @pattern.self) rest)
)
(@expression.core `bind` Core.Var okId)
)
-- range : Range
-- pattern : Pattern
-- expression : Expression
-- Not supported
| Empty lhs.core =
\theRest ->
case theRest of
Nothing -> internalError "ToCoreExpr" "Statement" "empty statements not supported"
Just rest -> rest
-- range : Range
ATTR Qualifiers [ | | core USE { : } { [] } : { [Core.Expr -> Core.Expr] } ]
SEM Qualifier [ | | core : { Core.Expr -> Core.Expr } ]
| Guard lhs.core = \continue -> if_ @guard.core continue nil
-- range : Range
-- guard : Expression -- type: Boolean
| Let declarations.patBindNr = 0
declarations.isTopLevel = False
lhs.core = \continue -> letrec_ @declarations.decls continue
-- range : Range
-- declarations : Declarations
-- See Haskell report 3.11
-- let _nextClause = [] in
-- let _ok = \_misc -> case _misc of { pattern -> ...; _ -> _nextClause }
-- in concatMap _ok expression
| Generator lhs.core =
\continue ->
let_ nextClauseId nil
(let_
okId
(Core.Lam parameterId
(patternToCore (parameterId, @pattern.self) continue)
)
(var "$primConcatMap"
`app_` Core.Var okId
`app_` @expression.core
)
)
-- range : Range
-- pattern : Pattern
-- expression : Expression
-- Not supported
| Empty lhs.core = internalError "ToCoreExpr" "Qualifier" "empty qualifiers not supported"
-- range : Range
SEM Alternatives [ caseRange : Range | | core : { Core.Expr } ]
| Cons lhs.core = @hd.core @tl.core
| Nil lhs.core = patternMatchFail "case expression" @lhs.caseRange
SEM Alternative [ | | core : { Core.Expr -> Core.Expr } ]
| Hole lhs.core = id
| Alternative lhs.core = \nextCase ->
let thisCase =
patternToCore
(caseExprId, @pattern.self)
@righthandside.core
in
let_ nextClauseId nextCase thisCase
-- range : Range
-- pattern : Pattern
-- righthandside : RightHandSide
| Empty lhs.core = id
-- range : Range
ATTR GuardedExpressions [ | | core USE { : } { [] } : { [Core.Expr -> Core.Expr] } ]
SEM GuardedExpression [ | | core : { Core.Expr -> Core.Expr } ]
| GuardedExpression lhs.core =
\fail' -> if_ @guard.core @expression.core fail'
-- range : Range
-- guard : Expression -- type: Boolean
-- expression : Expression
SEM Literal [ | | core : { Core.Expr } ]
| Int lhs.core = Core.Lit (Core.LitInt (read @value))
-- range : Range
-- value : String
| Char lhs.core =
Core.Lit (Core.LitInt (ord
(read ("'" ++ @value ++ "'"))))
-- range : Range
-- value : String -- without the quotes
| Float lhs.core = float @value
-- range : Range
-- value : String
| String lhs.core =
var "$primPackedToString" `app_`
packedString (read ("\"" ++ @value ++ "\""))
-- range : Range
-- value : String -- without the quotes
{
-- Function "bind" is used in the translation of do-expressions
bind :: Core.Expr -> Core.Expr -> Core.Expr
bind ma f = Core.Var primBindIOId `app_` ma `app_` f
primBindIOId, caseExprId, okId, parameterId :: Id
( primBindIOId : caseExprId : okId : parameterId : []) = map idFromString $
"$primBindIO" : "caseExpr$" : "ok$" : "parameter$" : []
-- Function "chainCode" is used in the translation of do-expressions
chainCode :: [Maybe Core.Expr -> Core.Expr] -> Core.Expr
chainCode theCores =
case theCores of
[core] -> core Nothing
(core:cores) -> core (Just (chainCode cores))
[] -> error "pattern match failure in CodeGeneration.ToCoreExpr.chainCode"
}