-- ------------------------------------------------------------------------ -- -- 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) }