-- ------------------------------------------------------------------------ -- -- 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 = 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" }