diff --git a/src-derived/AbstractSyntax.hs b/src-derived/AbstractSyntax.hs --- a/src-derived/AbstractSyntax.hs +++ b/src-derived/AbstractSyntax.hs @@ -1,4 +1,3 @@ - -- UUAGC 0.9.5 (AbstractSyntax.ag) module AbstractSyntax where @@ -8,36 +7,17 @@ import Patterns (Pattern(..),Patterns) import Expression (Expression(..)) import CommonTypes --- Alternative ------------------------------------------------- -{- - alternatives: - alternative Alternative: - child con : {Constructor} - child children : Children - child rules : Rules - child typeSigs : TypeSigs --} -data Alternative = Alternative (Constructor) (Children) (Rules) (TypeSigs) --- Alternatives ------------------------------------------------ -{- - alternatives: - alternative Cons: - child hd : Alternative - child tl : Alternatives - alternative Nil: --} -type Alternatives = [Alternative] -- Child ------------------------------------------------------- {- alternatives: alternative Child: - child name : {Name} + child name : {Identifier} child tp : {Type} child inh : {Attributes} child syn : {Attributes} child higherOrder : {Bool} -} -data Child = Child (Name) (Type) (Attributes) (Attributes) (Bool) +data Child = Child (Identifier) (Type) (Attributes) (Attributes) (Bool) -- Children ---------------------------------------------------- {- alternatives: @@ -54,22 +34,44 @@ child typeSyns : {TypeSyns} child useMap : {UseMap} child derivings : {Derivings} - child wrappers : {Set Nonterminal} - child prods : Productions + child wrappers : {Set NontermIdent} + child nonts : Nonterminals child pragmas : {PragmaMap} child manualAttrOrderMap : {AttrOrderMap} + child paramMap : {ParamMap} + child contextMap : {ContextMap} -} -data Grammar = Grammar (TypeSyns) (UseMap) (Derivings) (Set Nonterminal) (Productions) (PragmaMap) (AttrOrderMap) --- Production -------------------------------------------------- +data Grammar = Grammar (TypeSyns) (UseMap) (Derivings) (Set NontermIdent) (Nonterminals) (PragmaMap) (AttrOrderMap) (ParamMap) (ContextMap) +-- Nonterminal ------------------------------------------------- {- alternatives: - alternative Production: - child nt : {Nonterminal} + alternative Nonterminal: + child nt : {NontermIdent} + child params : {[Identifier]} child inh : {Attributes} child syn : {Attributes} - child alts : Alternatives + child prods : Productions -} -data Production = Production (Nonterminal) (Attributes) (Attributes) (Alternatives) +data Nonterminal = Nonterminal (NontermIdent) ([Identifier]) (Attributes) (Attributes) (Productions) +-- Nonterminals ------------------------------------------------ +{- + alternatives: + alternative Cons: + child hd : Nonterminal + child tl : Nonterminals + alternative Nil: +-} +type Nonterminals = [Nonterminal] +-- Production -------------------------------------------------- +{- + alternatives: + alternative Production: + child con : {ConstructorIdent} + child children : Children + child rules : Rules + child typeSigs : TypeSigs +-} +data Production = Production (ConstructorIdent) (Children) (Rules) (TypeSigs) -- Productions ------------------------------------------------- {- alternatives: @@ -88,7 +90,7 @@ child owrt : {Bool} child origin : {String} -} -data Rule = Rule (Pattern) (Expression) (Bool) (String) +data Rule = Rule (Pattern) (Expression) (Bool) (String) -- Rules ------------------------------------------------------- {- alternatives: @@ -102,10 +104,10 @@ {- alternatives: alternative TypeSig: - child name : {Name} + child name : {Identifier} child tp : {Type} -} -data TypeSig = TypeSig (Name) (Type) +data TypeSig = TypeSig (Identifier) (Type) -- TypeSigs ---------------------------------------------------- {- alternatives: diff --git a/src-derived/AbstractSyntaxDump.hs b/src-derived/AbstractSyntaxDump.hs --- a/src-derived/AbstractSyntaxDump.hs +++ b/src-derived/AbstractSyntaxDump.hs @@ -1,4 +1,3 @@ - -- UUAGC 0.9.5 (AbstractSyntaxDump.ag) module AbstractSyntaxDump where @@ -9,6 +8,7 @@ import PPUtil import AbstractSyntax +import TokenDef -- AbstractSyntax.ag imports import Data.Set(Set) @@ -19,113 +19,10 @@ -- Patterns.ag imports import UU.Scanner.Position(Pos) -import CommonTypes (Constructor,Name) +import CommonTypes (ConstructorIdent,Identifier) import UU.Scanner.Position(Pos) --- Alternative ------------------------------------------------- -{- - visit 0: - synthesized attribute: - pp : PP_Doc - alternatives: - alternative Alternative: - child con : {Constructor} - child children : Children - child rules : Rules - child typeSigs : TypeSigs --} --- cata -sem_Alternative :: Alternative -> - T_Alternative -sem_Alternative (Alternative _con _children _rules _typeSigs ) = - (sem_Alternative_Alternative _con (sem_Children _children ) (sem_Rules _rules ) (sem_TypeSigs _typeSigs ) ) --- semantic domain -newtype T_Alternative = T_Alternative (( PP_Doc)) -data Inh_Alternative = Inh_Alternative {} -data Syn_Alternative = Syn_Alternative {pp_Syn_Alternative :: PP_Doc} -wrap_Alternative (T_Alternative sem ) (Inh_Alternative ) = - (let ( _lhsOpp) = - (sem ) - in (Syn_Alternative _lhsOpp )) -sem_Alternative_Alternative :: Constructor -> - T_Children -> - T_Rules -> - T_TypeSigs -> - T_Alternative -sem_Alternative_Alternative con_ (T_Children children_ ) (T_Rules rules_ ) (T_TypeSigs typeSigs_ ) = - (T_Alternative (let _lhsOpp :: PP_Doc - _childrenIpp :: PP_Doc - _childrenIppL :: ([PP_Doc]) - _rulesIpp :: PP_Doc - _rulesIppL :: ([PP_Doc]) - _typeSigsIpp :: PP_Doc - _typeSigsIppL :: ([PP_Doc]) - -- "AbstractSyntaxDump.ag"(line 31, column 25) - _lhsOpp = - ppNestInfo ["Alternative","Alternative"] [pp con_] [ppF "children" $ ppVList _childrenIppL,ppF "rules" $ ppVList _rulesIppL,ppF "typeSigs" $ ppVList _typeSigsIppL] [] - ( _childrenIpp,_childrenIppL) = - (children_ ) - ( _rulesIpp,_rulesIppL) = - (rules_ ) - ( _typeSigsIpp,_typeSigsIppL) = - (typeSigs_ ) - in ( _lhsOpp)) ) --- Alternatives ------------------------------------------------ -{- - visit 0: - synthesized attributes: - pp : PP_Doc - ppL : [PP_Doc] - alternatives: - alternative Cons: - child hd : Alternative - child tl : Alternatives - alternative Nil: --} --- cata -sem_Alternatives :: Alternatives -> - T_Alternatives -sem_Alternatives list = - (Prelude.foldr sem_Alternatives_Cons sem_Alternatives_Nil (Prelude.map sem_Alternative list) ) --- semantic domain -newtype T_Alternatives = T_Alternatives (( PP_Doc,([PP_Doc]))) -data Inh_Alternatives = Inh_Alternatives {} -data Syn_Alternatives = Syn_Alternatives {pp_Syn_Alternatives :: PP_Doc,ppL_Syn_Alternatives :: [PP_Doc]} -wrap_Alternatives (T_Alternatives sem ) (Inh_Alternatives ) = - (let ( _lhsOpp,_lhsOppL) = - (sem ) - in (Syn_Alternatives _lhsOpp _lhsOppL )) -sem_Alternatives_Cons :: T_Alternative -> - T_Alternatives -> - T_Alternatives -sem_Alternatives_Cons (T_Alternative hd_ ) (T_Alternatives tl_ ) = - (T_Alternatives (let _lhsOppL :: ([PP_Doc]) - _lhsOpp :: PP_Doc - _hdIpp :: PP_Doc - _tlIpp :: PP_Doc - _tlIppL :: ([PP_Doc]) - -- "AbstractSyntaxDump.ag"(line 70, column 33) - _lhsOppL = - _hdIpp : _tlIppL - -- use rule "AbstractSyntaxDump.ag"(line 16, column 58) - _lhsOpp = - _hdIpp >-< _tlIpp - ( _hdIpp) = - (hd_ ) - ( _tlIpp,_tlIppL) = - (tl_ ) - in ( _lhsOpp,_lhsOppL)) ) -sem_Alternatives_Nil :: T_Alternatives -sem_Alternatives_Nil = - (T_Alternatives (let _lhsOppL :: ([PP_Doc]) - _lhsOpp :: PP_Doc - -- "AbstractSyntaxDump.ag"(line 71, column 33) - _lhsOppL = - [] - -- use rule "AbstractSyntaxDump.ag"(line 16, column 58) - _lhsOpp = - empty - in ( _lhsOpp,_lhsOppL)) ) +import HsToken -- Child ------------------------------------------------------- {- visit 0: @@ -133,7 +30,7 @@ pp : PP_Doc alternatives: alternative Child: - child name : {Name} + child name : {Identifier} child tp : {Type} child inh : {Attributes} child syn : {Attributes} @@ -142,28 +39,28 @@ -- cata sem_Child :: Child -> T_Child -sem_Child (Child _name _tp _inh _syn _higherOrder ) = - (sem_Child_Child _name _tp _inh _syn _higherOrder ) +sem_Child (Child _name _tp _inh _syn _higherOrder) = + (sem_Child_Child _name _tp _inh _syn _higherOrder) -- semantic domain newtype T_Child = T_Child (( PP_Doc)) data Inh_Child = Inh_Child {} data Syn_Child = Syn_Child {pp_Syn_Child :: PP_Doc} -wrap_Child (T_Child sem ) (Inh_Child ) = +wrap_Child (T_Child sem) (Inh_Child ) = (let ( _lhsOpp) = (sem ) - in (Syn_Child _lhsOpp )) -sem_Child_Child :: Name -> + in (Syn_Child _lhsOpp)) +sem_Child_Child :: Identifier -> Type -> Attributes -> Attributes -> Bool -> T_Child -sem_Child_Child name_ tp_ inh_ syn_ higherOrder_ = +sem_Child_Child name_ tp_ inh_ syn_ higherOrder_ = (T_Child (let _lhsOpp :: PP_Doc - -- "AbstractSyntaxDump.ag"(line 34, column 33) + -- "AbstractSyntaxDump.ag"(line 35, column 33) _lhsOpp = ppNestInfo ["Child","Child"] [pp name_, ppShow tp_] [ppF "inh" $ ppMap inh_, ppF "syn" $ ppMap syn_] [] - in ( _lhsOpp)) ) + in ( _lhsOpp))) -- Children ---------------------------------------------------- {- visit 0: @@ -179,47 +76,47 @@ -- cata sem_Children :: Children -> T_Children -sem_Children list = - (Prelude.foldr sem_Children_Cons sem_Children_Nil (Prelude.map sem_Child list) ) +sem_Children list = + (Prelude.foldr sem_Children_Cons sem_Children_Nil (Prelude.map sem_Child list)) -- semantic domain newtype T_Children = T_Children (( PP_Doc,([PP_Doc]))) data Inh_Children = Inh_Children {} data Syn_Children = Syn_Children {pp_Syn_Children :: PP_Doc,ppL_Syn_Children :: [PP_Doc]} -wrap_Children (T_Children sem ) (Inh_Children ) = +wrap_Children (T_Children sem) (Inh_Children ) = (let ( _lhsOpp,_lhsOppL) = (sem ) - in (Syn_Children _lhsOpp _lhsOppL )) + in (Syn_Children _lhsOpp _lhsOppL)) sem_Children_Cons :: T_Child -> T_Children -> T_Children -sem_Children_Cons (T_Child hd_ ) (T_Children tl_ ) = +sem_Children_Cons (T_Child hd_) (T_Children tl_) = (T_Children (let _lhsOppL :: ([PP_Doc]) _lhsOpp :: PP_Doc _hdIpp :: PP_Doc _tlIpp :: PP_Doc _tlIppL :: ([PP_Doc]) - -- "AbstractSyntaxDump.ag"(line 66, column 33) + -- "AbstractSyntaxDump.ag"(line 67, column 33) _lhsOppL = _hdIpp : _tlIppL - -- use rule "AbstractSyntaxDump.ag"(line 16, column 58) + -- use rule "AbstractSyntaxDump.ag"(line 17, column 58) _lhsOpp = _hdIpp >-< _tlIpp ( _hdIpp) = (hd_ ) ( _tlIpp,_tlIppL) = (tl_ ) - in ( _lhsOpp,_lhsOppL)) ) + in ( _lhsOpp,_lhsOppL))) sem_Children_Nil :: T_Children sem_Children_Nil = (T_Children (let _lhsOppL :: ([PP_Doc]) _lhsOpp :: PP_Doc - -- "AbstractSyntaxDump.ag"(line 67, column 33) + -- "AbstractSyntaxDump.ag"(line 68, column 33) _lhsOppL = [] - -- use rule "AbstractSyntaxDump.ag"(line 16, column 58) + -- use rule "AbstractSyntaxDump.ag"(line 17, column 58) _lhsOpp = empty - in ( _lhsOpp,_lhsOppL)) ) + in ( _lhsOpp,_lhsOppL))) -- Expression -------------------------------------------------- {- visit 0: @@ -228,30 +125,30 @@ alternatives: alternative Expression: child pos : {Pos} - child txt : {String} + child tks : {[HsToken]} -} -- cata sem_Expression :: Expression -> T_Expression -sem_Expression (Expression _pos _txt ) = - (sem_Expression_Expression _pos _txt ) +sem_Expression (Expression _pos _tks) = + (sem_Expression_Expression _pos _tks) -- semantic domain newtype T_Expression = T_Expression (( PP_Doc)) data Inh_Expression = Inh_Expression {} data Syn_Expression = Syn_Expression {pp_Syn_Expression :: PP_Doc} -wrap_Expression (T_Expression sem ) (Inh_Expression ) = +wrap_Expression (T_Expression sem) (Inh_Expression ) = (let ( _lhsOpp) = (sem ) - in (Syn_Expression _lhsOpp )) + in (Syn_Expression _lhsOpp)) sem_Expression_Expression :: Pos -> - String -> + ([HsToken]) -> T_Expression -sem_Expression_Expression pos_ txt_ = +sem_Expression_Expression pos_ tks_ = (T_Expression (let _lhsOpp :: PP_Doc - -- "AbstractSyntaxDump.ag"(line 49, column 25) + -- "AbstractSyntaxDump.ag"(line 50, column 25) _lhsOpp = - ppNestInfo ["Expression","Expression"] [ppShow pos_] [ppF "txt" $ text txt_] [] - in ( _lhsOpp)) ) + ppNestInfo ["Expression","Expression"] [ppShow pos_] [ppF "txt" $ vlist . showTokens . tokensToStrings $ tks_] [] + in ( _lhsOpp))) -- Grammar ----------------------------------------------------- {- visit 0: @@ -262,48 +159,150 @@ child typeSyns : {TypeSyns} child useMap : {UseMap} child derivings : {Derivings} - child wrappers : {Set Nonterminal} - child prods : Productions + child wrappers : {Set NontermIdent} + child nonts : Nonterminals child pragmas : {PragmaMap} child manualAttrOrderMap : {AttrOrderMap} + child paramMap : {ParamMap} + child contextMap : {ContextMap} -} -- cata sem_Grammar :: Grammar -> T_Grammar -sem_Grammar (Grammar _typeSyns _useMap _derivings _wrappers _prods _pragmas _manualAttrOrderMap ) = - (sem_Grammar_Grammar _typeSyns _useMap _derivings _wrappers (sem_Productions _prods ) _pragmas _manualAttrOrderMap ) +sem_Grammar (Grammar _typeSyns _useMap _derivings _wrappers _nonts _pragmas _manualAttrOrderMap _paramMap _contextMap) = + (sem_Grammar_Grammar _typeSyns _useMap _derivings _wrappers (sem_Nonterminals _nonts) _pragmas _manualAttrOrderMap _paramMap _contextMap) -- semantic domain newtype T_Grammar = T_Grammar (( PP_Doc)) data Inh_Grammar = Inh_Grammar {} data Syn_Grammar = Syn_Grammar {pp_Syn_Grammar :: PP_Doc} -wrap_Grammar (T_Grammar sem ) (Inh_Grammar ) = +wrap_Grammar (T_Grammar sem) (Inh_Grammar ) = (let ( _lhsOpp) = (sem ) - in (Syn_Grammar _lhsOpp )) + in (Syn_Grammar _lhsOpp)) sem_Grammar_Grammar :: TypeSyns -> UseMap -> Derivings -> - (Set Nonterminal) -> - T_Productions -> + (Set NontermIdent) -> + T_Nonterminals -> PragmaMap -> AttrOrderMap -> + ParamMap -> + ContextMap -> T_Grammar -sem_Grammar_Grammar typeSyns_ useMap_ derivings_ wrappers_ (T_Productions prods_ ) pragmas_ manualAttrOrderMap_ = +sem_Grammar_Grammar typeSyns_ useMap_ derivings_ wrappers_ (T_Nonterminals nonts_) pragmas_ manualAttrOrderMap_ paramMap_ contextMap_ = (T_Grammar (let _lhsOpp :: PP_Doc - _prodsIpp :: PP_Doc - _prodsIppL :: ([PP_Doc]) - -- "AbstractSyntaxDump.ag"(line 19, column 25) + _nontsIpp :: PP_Doc + _nontsIppL :: ([PP_Doc]) + -- "AbstractSyntaxDump.ag"(line 20, column 25) _lhsOpp = ppNestInfo ["Grammar","Grammar"] [] [ ppF "typeSyns" $ ppAssocL typeSyns_ , ppF "useMap" $ ppMap $ Map.map ppMap $ useMap_ , ppF "derivings" $ ppMap $ derivings_ , ppF "wrappers" $ ppShow $ wrappers_ - , ppF "prods" $ ppVList _prodsIppL + , ppF "nonts" $ ppVList _nontsIppL ] [] - ( _prodsIpp,_prodsIppL) = - (prods_ ) - in ( _lhsOpp)) ) + ( _nontsIpp,_nontsIppL) = + (nonts_ ) + in ( _lhsOpp))) +-- Nonterminal ------------------------------------------------- +{- + visit 0: + synthesized attribute: + pp : PP_Doc + alternatives: + alternative Nonterminal: + child nt : {NontermIdent} + child params : {[Identifier]} + child inh : {Attributes} + child syn : {Attributes} + child prods : Productions +-} +-- cata +sem_Nonterminal :: Nonterminal -> + T_Nonterminal +sem_Nonterminal (Nonterminal _nt _params _inh _syn _prods) = + (sem_Nonterminal_Nonterminal _nt _params _inh _syn (sem_Productions _prods)) +-- semantic domain +newtype T_Nonterminal = T_Nonterminal (( PP_Doc)) +data Inh_Nonterminal = Inh_Nonterminal {} +data Syn_Nonterminal = Syn_Nonterminal {pp_Syn_Nonterminal :: PP_Doc} +wrap_Nonterminal (T_Nonterminal sem) (Inh_Nonterminal ) = + (let ( _lhsOpp) = + (sem ) + in (Syn_Nonterminal _lhsOpp)) +sem_Nonterminal_Nonterminal :: NontermIdent -> + ([Identifier]) -> + Attributes -> + Attributes -> + T_Productions -> + T_Nonterminal +sem_Nonterminal_Nonterminal nt_ params_ inh_ syn_ (T_Productions prods_) = + (T_Nonterminal (let _lhsOpp :: PP_Doc + _prodsIpp :: PP_Doc + _prodsIppL :: ([PP_Doc]) + -- "AbstractSyntaxDump.ag"(line 29, column 25) + _lhsOpp = + ppNestInfo ["Nonterminal","Nonterminal"] (pp nt_ : map pp params_) [ppF "inh" $ ppMap inh_, ppF "syn" $ ppMap syn_, ppF "prods" $ ppVList _prodsIppL] [] + ( _prodsIpp,_prodsIppL) = + (prods_ ) + in ( _lhsOpp))) +-- Nonterminals ------------------------------------------------ +{- + visit 0: + synthesized attributes: + pp : PP_Doc + ppL : [PP_Doc] + alternatives: + alternative Cons: + child hd : Nonterminal + child tl : Nonterminals + alternative Nil: +-} +-- cata +sem_Nonterminals :: Nonterminals -> + T_Nonterminals +sem_Nonterminals list = + (Prelude.foldr sem_Nonterminals_Cons sem_Nonterminals_Nil (Prelude.map sem_Nonterminal list)) +-- semantic domain +newtype T_Nonterminals = T_Nonterminals (( PP_Doc,([PP_Doc]))) +data Inh_Nonterminals = Inh_Nonterminals {} +data Syn_Nonterminals = Syn_Nonterminals {pp_Syn_Nonterminals :: PP_Doc,ppL_Syn_Nonterminals :: [PP_Doc]} +wrap_Nonterminals (T_Nonterminals sem) (Inh_Nonterminals ) = + (let ( _lhsOpp,_lhsOppL) = + (sem ) + in (Syn_Nonterminals _lhsOpp _lhsOppL)) +sem_Nonterminals_Cons :: T_Nonterminal -> + T_Nonterminals -> + T_Nonterminals +sem_Nonterminals_Cons (T_Nonterminal hd_) (T_Nonterminals tl_) = + (T_Nonterminals (let _lhsOppL :: ([PP_Doc]) + _lhsOpp :: PP_Doc + _hdIpp :: PP_Doc + _tlIpp :: PP_Doc + _tlIppL :: ([PP_Doc]) + -- "AbstractSyntaxDump.ag"(line 75, column 33) + _lhsOppL = + _hdIpp : _tlIppL + -- use rule "AbstractSyntaxDump.ag"(line 17, column 58) + _lhsOpp = + _hdIpp >-< _tlIpp + ( _hdIpp) = + (hd_ ) + ( _tlIpp,_tlIppL) = + (tl_ ) + in ( _lhsOpp,_lhsOppL))) +sem_Nonterminals_Nil :: T_Nonterminals +sem_Nonterminals_Nil = + (T_Nonterminals (let _lhsOppL :: ([PP_Doc]) + _lhsOpp :: PP_Doc + -- "AbstractSyntaxDump.ag"(line 76, column 33) + _lhsOppL = + [] + -- use rule "AbstractSyntaxDump.ag"(line 17, column 58) + _lhsOpp = + empty + in ( _lhsOpp,_lhsOppL))) -- Pattern ----------------------------------------------------- {- visit 0: @@ -312,17 +311,21 @@ pp : PP_Doc alternatives: alternative Alias: - child field : {Name} - child attr : {Name} + child field : {Identifier} + child attr : {Identifier} child pat : Pattern child parts : Patterns visit 0: local copy : _ alternative Constr: - child name : {Constructor} + child name : {ConstructorIdent} child pats : Patterns visit 0: local copy : _ + alternative Irrefutable: + child pat : Pattern + visit 0: + local copy : _ alternative Product: child pos : {Pos} child pats : Patterns @@ -336,28 +339,30 @@ -- cata sem_Pattern :: Pattern -> T_Pattern -sem_Pattern (Alias _field _attr _pat _parts ) = - (sem_Pattern_Alias _field _attr (sem_Pattern _pat ) (sem_Patterns _parts ) ) -sem_Pattern (Constr _name _pats ) = - (sem_Pattern_Constr _name (sem_Patterns _pats ) ) -sem_Pattern (Product _pos _pats ) = - (sem_Pattern_Product _pos (sem_Patterns _pats ) ) -sem_Pattern (Underscore _pos ) = - (sem_Pattern_Underscore _pos ) +sem_Pattern (Alias _field _attr _pat _parts) = + (sem_Pattern_Alias _field _attr (sem_Pattern _pat) (sem_Patterns _parts)) +sem_Pattern (Constr _name _pats) = + (sem_Pattern_Constr _name (sem_Patterns _pats)) +sem_Pattern (Irrefutable _pat) = + (sem_Pattern_Irrefutable (sem_Pattern _pat)) +sem_Pattern (Product _pos _pats) = + (sem_Pattern_Product _pos (sem_Patterns _pats)) +sem_Pattern (Underscore _pos) = + (sem_Pattern_Underscore _pos) -- semantic domain newtype T_Pattern = T_Pattern (( Pattern,PP_Doc)) data Inh_Pattern = Inh_Pattern {} data Syn_Pattern = Syn_Pattern {copy_Syn_Pattern :: Pattern,pp_Syn_Pattern :: PP_Doc} -wrap_Pattern (T_Pattern sem ) (Inh_Pattern ) = +wrap_Pattern (T_Pattern sem) (Inh_Pattern ) = (let ( _lhsOcopy,_lhsOpp) = (sem ) - in (Syn_Pattern _lhsOcopy _lhsOpp )) -sem_Pattern_Alias :: Name -> - Name -> + in (Syn_Pattern _lhsOcopy _lhsOpp)) +sem_Pattern_Alias :: Identifier -> + Identifier -> T_Pattern -> T_Patterns -> T_Pattern -sem_Pattern_Alias field_ attr_ (T_Pattern pat_ ) (T_Patterns parts_ ) = +sem_Pattern_Alias field_ attr_ (T_Pattern pat_) (T_Patterns parts_) = (T_Pattern (let _lhsOpp :: PP_Doc _lhsOcopy :: Pattern _patIcopy :: Pattern @@ -365,7 +370,7 @@ _partsIcopy :: Patterns _partsIpp :: PP_Doc _partsIppL :: ([PP_Doc]) - -- "AbstractSyntaxDump.ag"(line 45, column 33) + -- "AbstractSyntaxDump.ag"(line 46, column 33) _lhsOpp = ppNestInfo ["Pattern","Alias"] [pp field_, pp attr_] [ppF "pat" $ _patIpp] [] -- self rule @@ -378,17 +383,17 @@ (pat_ ) ( _partsIcopy,_partsIpp,_partsIppL) = (parts_ ) - in ( _lhsOcopy,_lhsOpp)) ) -sem_Pattern_Constr :: Constructor -> + in ( _lhsOcopy,_lhsOpp))) +sem_Pattern_Constr :: ConstructorIdent -> T_Patterns -> T_Pattern -sem_Pattern_Constr name_ (T_Patterns pats_ ) = +sem_Pattern_Constr name_ (T_Patterns pats_) = (T_Pattern (let _lhsOpp :: PP_Doc _lhsOcopy :: Pattern _patsIcopy :: Patterns _patsIpp :: PP_Doc _patsIppL :: ([PP_Doc]) - -- "AbstractSyntaxDump.ag"(line 43, column 33) + -- "AbstractSyntaxDump.ag"(line 44, column 33) _lhsOpp = ppNestInfo ["Pattern","Constr"] [pp name_] [ppF "pats" $ ppVList _patsIppL] [] -- self rule @@ -399,17 +404,36 @@ _copy ( _patsIcopy,_patsIpp,_patsIppL) = (pats_ ) - in ( _lhsOcopy,_lhsOpp)) ) + in ( _lhsOcopy,_lhsOpp))) +sem_Pattern_Irrefutable :: T_Pattern -> + T_Pattern +sem_Pattern_Irrefutable (T_Pattern pat_) = + (T_Pattern (let _lhsOpp :: PP_Doc + _lhsOcopy :: Pattern + _patIcopy :: Pattern + _patIpp :: PP_Doc + -- use rule "AbstractSyntaxDump.ag"(line 17, column 58) + _lhsOpp = + _patIpp + -- self rule + _copy = + Irrefutable _patIcopy + -- self rule + _lhsOcopy = + _copy + ( _patIcopy,_patIpp) = + (pat_ ) + in ( _lhsOcopy,_lhsOpp))) sem_Pattern_Product :: Pos -> T_Patterns -> T_Pattern -sem_Pattern_Product pos_ (T_Patterns pats_ ) = +sem_Pattern_Product pos_ (T_Patterns pats_) = (T_Pattern (let _lhsOpp :: PP_Doc _lhsOcopy :: Pattern _patsIcopy :: Patterns _patsIpp :: PP_Doc _patsIppL :: ([PP_Doc]) - -- "AbstractSyntaxDump.ag"(line 44, column 33) + -- "AbstractSyntaxDump.ag"(line 45, column 33) _lhsOpp = ppNestInfo ["Pattern","Product"] [ppShow pos_] [ppF "pats" $ ppVList _patsIppL] [] -- self rule @@ -420,13 +444,13 @@ _copy ( _patsIcopy,_patsIpp,_patsIppL) = (pats_ ) - in ( _lhsOcopy,_lhsOpp)) ) + in ( _lhsOcopy,_lhsOpp))) sem_Pattern_Underscore :: Pos -> T_Pattern -sem_Pattern_Underscore pos_ = +sem_Pattern_Underscore pos_ = (T_Pattern (let _lhsOpp :: PP_Doc _lhsOcopy :: Pattern - -- "AbstractSyntaxDump.ag"(line 46, column 25) + -- "AbstractSyntaxDump.ag"(line 47, column 25) _lhsOpp = ppNestInfo ["Pattern","Underscore"] [ppShow pos_] [] [] -- self rule @@ -435,7 +459,7 @@ -- self rule _lhsOcopy = _copy - in ( _lhsOcopy,_lhsOpp)) ) + in ( _lhsOcopy,_lhsOpp))) -- Patterns ---------------------------------------------------- {- visit 0: @@ -456,20 +480,20 @@ -- cata sem_Patterns :: Patterns -> T_Patterns -sem_Patterns list = - (Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list) ) +sem_Patterns list = + (Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list)) -- semantic domain newtype T_Patterns = T_Patterns (( Patterns,PP_Doc,([PP_Doc]))) data Inh_Patterns = Inh_Patterns {} data Syn_Patterns = Syn_Patterns {copy_Syn_Patterns :: Patterns,pp_Syn_Patterns :: PP_Doc,ppL_Syn_Patterns :: [PP_Doc]} -wrap_Patterns (T_Patterns sem ) (Inh_Patterns ) = +wrap_Patterns (T_Patterns sem) (Inh_Patterns ) = (let ( _lhsOcopy,_lhsOpp,_lhsOppL) = (sem ) - in (Syn_Patterns _lhsOcopy _lhsOpp _lhsOppL )) + in (Syn_Patterns _lhsOcopy _lhsOpp _lhsOppL)) sem_Patterns_Cons :: T_Pattern -> T_Patterns -> T_Patterns -sem_Patterns_Cons (T_Pattern hd_ ) (T_Patterns tl_ ) = +sem_Patterns_Cons (T_Pattern hd_) (T_Patterns tl_) = (T_Patterns (let _lhsOppL :: ([PP_Doc]) _lhsOpp :: PP_Doc _lhsOcopy :: Patterns @@ -478,10 +502,10 @@ _tlIcopy :: Patterns _tlIpp :: PP_Doc _tlIppL :: ([PP_Doc]) - -- "AbstractSyntaxDump.ag"(line 54, column 33) + -- "AbstractSyntaxDump.ag"(line 55, column 33) _lhsOppL = _hdIpp : _tlIppL - -- use rule "AbstractSyntaxDump.ag"(line 16, column 58) + -- use rule "AbstractSyntaxDump.ag"(line 17, column 58) _lhsOpp = _hdIpp >-< _tlIpp -- self rule @@ -494,16 +518,16 @@ (hd_ ) ( _tlIcopy,_tlIpp,_tlIppL) = (tl_ ) - in ( _lhsOcopy,_lhsOpp,_lhsOppL)) ) + in ( _lhsOcopy,_lhsOpp,_lhsOppL))) sem_Patterns_Nil :: T_Patterns sem_Patterns_Nil = (T_Patterns (let _lhsOppL :: ([PP_Doc]) _lhsOpp :: PP_Doc _lhsOcopy :: Patterns - -- "AbstractSyntaxDump.ag"(line 55, column 33) + -- "AbstractSyntaxDump.ag"(line 56, column 33) _lhsOppL = [] - -- use rule "AbstractSyntaxDump.ag"(line 16, column 58) + -- use rule "AbstractSyntaxDump.ag"(line 17, column 58) _lhsOpp = empty -- self rule @@ -512,7 +536,7 @@ -- self rule _lhsOcopy = _copy - in ( _lhsOcopy,_lhsOpp,_lhsOppL)) ) + in ( _lhsOcopy,_lhsOpp,_lhsOppL))) -- Production -------------------------------------------------- {- visit 0: @@ -520,39 +544,47 @@ pp : PP_Doc alternatives: alternative Production: - child nt : {Nonterminal} - child inh : {Attributes} - child syn : {Attributes} - child alts : Alternatives + child con : {ConstructorIdent} + child children : Children + child rules : Rules + child typeSigs : TypeSigs -} -- cata sem_Production :: Production -> T_Production -sem_Production (Production _nt _inh _syn _alts ) = - (sem_Production_Production _nt _inh _syn (sem_Alternatives _alts ) ) +sem_Production (Production _con _children _rules _typeSigs) = + (sem_Production_Production _con (sem_Children _children) (sem_Rules _rules) (sem_TypeSigs _typeSigs)) -- semantic domain newtype T_Production = T_Production (( PP_Doc)) data Inh_Production = Inh_Production {} data Syn_Production = Syn_Production {pp_Syn_Production :: PP_Doc} -wrap_Production (T_Production sem ) (Inh_Production ) = +wrap_Production (T_Production sem) (Inh_Production ) = (let ( _lhsOpp) = (sem ) - in (Syn_Production _lhsOpp )) -sem_Production_Production :: Nonterminal -> - Attributes -> - Attributes -> - T_Alternatives -> + in (Syn_Production _lhsOpp)) +sem_Production_Production :: ConstructorIdent -> + T_Children -> + T_Rules -> + T_TypeSigs -> T_Production -sem_Production_Production nt_ inh_ syn_ (T_Alternatives alts_ ) = +sem_Production_Production con_ (T_Children children_) (T_Rules rules_) (T_TypeSigs typeSigs_) = (T_Production (let _lhsOpp :: PP_Doc - _altsIpp :: PP_Doc - _altsIppL :: ([PP_Doc]) - -- "AbstractSyntaxDump.ag"(line 28, column 25) + _childrenIpp :: PP_Doc + _childrenIppL :: ([PP_Doc]) + _rulesIpp :: PP_Doc + _rulesIppL :: ([PP_Doc]) + _typeSigsIpp :: PP_Doc + _typeSigsIppL :: ([PP_Doc]) + -- "AbstractSyntaxDump.ag"(line 32, column 25) _lhsOpp = - ppNestInfo ["Production","Production"] [pp nt_] [ppF "inh" $ ppMap inh_, ppF "syn" $ ppMap syn_, ppF "alts" $ ppVList _altsIppL] [] - ( _altsIpp,_altsIppL) = - (alts_ ) - in ( _lhsOpp)) ) + ppNestInfo ["Production","Production"] [pp con_] [ppF "children" $ ppVList _childrenIppL,ppF "rules" $ ppVList _rulesIppL,ppF "typeSigs" $ ppVList _typeSigsIppL] [] + ( _childrenIpp,_childrenIppL) = + (children_ ) + ( _rulesIpp,_rulesIppL) = + (rules_ ) + ( _typeSigsIpp,_typeSigsIppL) = + (typeSigs_ ) + in ( _lhsOpp))) -- Productions ------------------------------------------------- {- visit 0: @@ -568,47 +600,47 @@ -- cata sem_Productions :: Productions -> T_Productions -sem_Productions list = - (Prelude.foldr sem_Productions_Cons sem_Productions_Nil (Prelude.map sem_Production list) ) +sem_Productions list = + (Prelude.foldr sem_Productions_Cons sem_Productions_Nil (Prelude.map sem_Production list)) -- semantic domain newtype T_Productions = T_Productions (( PP_Doc,([PP_Doc]))) data Inh_Productions = Inh_Productions {} data Syn_Productions = Syn_Productions {pp_Syn_Productions :: PP_Doc,ppL_Syn_Productions :: [PP_Doc]} -wrap_Productions (T_Productions sem ) (Inh_Productions ) = +wrap_Productions (T_Productions sem) (Inh_Productions ) = (let ( _lhsOpp,_lhsOppL) = (sem ) - in (Syn_Productions _lhsOpp _lhsOppL )) + in (Syn_Productions _lhsOpp _lhsOppL)) sem_Productions_Cons :: T_Production -> T_Productions -> T_Productions -sem_Productions_Cons (T_Production hd_ ) (T_Productions tl_ ) = +sem_Productions_Cons (T_Production hd_) (T_Productions tl_) = (T_Productions (let _lhsOppL :: ([PP_Doc]) _lhsOpp :: PP_Doc _hdIpp :: PP_Doc _tlIpp :: PP_Doc _tlIppL :: ([PP_Doc]) - -- "AbstractSyntaxDump.ag"(line 74, column 33) + -- "AbstractSyntaxDump.ag"(line 71, column 33) _lhsOppL = _hdIpp : _tlIppL - -- use rule "AbstractSyntaxDump.ag"(line 16, column 58) + -- use rule "AbstractSyntaxDump.ag"(line 17, column 58) _lhsOpp = _hdIpp >-< _tlIpp ( _hdIpp) = (hd_ ) ( _tlIpp,_tlIppL) = (tl_ ) - in ( _lhsOpp,_lhsOppL)) ) + in ( _lhsOpp,_lhsOppL))) sem_Productions_Nil :: T_Productions sem_Productions_Nil = (T_Productions (let _lhsOppL :: ([PP_Doc]) _lhsOpp :: PP_Doc - -- "AbstractSyntaxDump.ag"(line 75, column 33) + -- "AbstractSyntaxDump.ag"(line 72, column 33) _lhsOppL = [] - -- use rule "AbstractSyntaxDump.ag"(line 16, column 58) + -- use rule "AbstractSyntaxDump.ag"(line 17, column 58) _lhsOpp = empty - in ( _lhsOpp,_lhsOppL)) ) + in ( _lhsOpp,_lhsOppL))) -- Rule -------------------------------------------------------- {- visit 0: @@ -624,34 +656,34 @@ -- cata sem_Rule :: Rule -> T_Rule -sem_Rule (Rule _pattern _rhs _owrt _origin ) = - (sem_Rule_Rule (sem_Pattern _pattern ) (sem_Expression _rhs ) _owrt _origin ) +sem_Rule (Rule _pattern _rhs _owrt _origin) = + (sem_Rule_Rule (sem_Pattern _pattern) (sem_Expression _rhs) _owrt _origin) -- semantic domain newtype T_Rule = T_Rule (( PP_Doc)) data Inh_Rule = Inh_Rule {} data Syn_Rule = Syn_Rule {pp_Syn_Rule :: PP_Doc} -wrap_Rule (T_Rule sem ) (Inh_Rule ) = +wrap_Rule (T_Rule sem) (Inh_Rule ) = (let ( _lhsOpp) = (sem ) - in (Syn_Rule _lhsOpp )) + in (Syn_Rule _lhsOpp)) sem_Rule_Rule :: T_Pattern -> T_Expression -> Bool -> String -> T_Rule -sem_Rule_Rule (T_Pattern pattern_ ) (T_Expression rhs_ ) owrt_ origin_ = +sem_Rule_Rule (T_Pattern pattern_) (T_Expression rhs_) owrt_ origin_ = (T_Rule (let _lhsOpp :: PP_Doc _patternIcopy :: Pattern _patternIpp :: PP_Doc _rhsIpp :: PP_Doc - -- "AbstractSyntaxDump.ag"(line 37, column 33) + -- "AbstractSyntaxDump.ag"(line 38, column 33) _lhsOpp = ppNestInfo ["Rule","Rule"] [ppShow owrt_, pp origin_] [ppF "pattern" $ _patternIpp, ppF "rhs" $ _rhsIpp] [] ( _patternIcopy,_patternIpp) = (pattern_ ) ( _rhsIpp) = (rhs_ ) - in ( _lhsOpp)) ) + in ( _lhsOpp))) -- Rules ------------------------------------------------------- {- visit 0: @@ -667,47 +699,47 @@ -- cata sem_Rules :: Rules -> T_Rules -sem_Rules list = - (Prelude.foldr sem_Rules_Cons sem_Rules_Nil (Prelude.map sem_Rule list) ) +sem_Rules list = + (Prelude.foldr sem_Rules_Cons sem_Rules_Nil (Prelude.map sem_Rule list)) -- semantic domain newtype T_Rules = T_Rules (( PP_Doc,([PP_Doc]))) data Inh_Rules = Inh_Rules {} data Syn_Rules = Syn_Rules {pp_Syn_Rules :: PP_Doc,ppL_Syn_Rules :: [PP_Doc]} -wrap_Rules (T_Rules sem ) (Inh_Rules ) = +wrap_Rules (T_Rules sem) (Inh_Rules ) = (let ( _lhsOpp,_lhsOppL) = (sem ) - in (Syn_Rules _lhsOpp _lhsOppL )) + in (Syn_Rules _lhsOpp _lhsOppL)) sem_Rules_Cons :: T_Rule -> T_Rules -> T_Rules -sem_Rules_Cons (T_Rule hd_ ) (T_Rules tl_ ) = +sem_Rules_Cons (T_Rule hd_) (T_Rules tl_) = (T_Rules (let _lhsOppL :: ([PP_Doc]) _lhsOpp :: PP_Doc _hdIpp :: PP_Doc _tlIpp :: PP_Doc _tlIppL :: ([PP_Doc]) - -- "AbstractSyntaxDump.ag"(line 62, column 33) + -- "AbstractSyntaxDump.ag"(line 63, column 33) _lhsOppL = _hdIpp : _tlIppL - -- use rule "AbstractSyntaxDump.ag"(line 16, column 58) + -- use rule "AbstractSyntaxDump.ag"(line 17, column 58) _lhsOpp = _hdIpp >-< _tlIpp ( _hdIpp) = (hd_ ) ( _tlIpp,_tlIppL) = (tl_ ) - in ( _lhsOpp,_lhsOppL)) ) + in ( _lhsOpp,_lhsOppL))) sem_Rules_Nil :: T_Rules sem_Rules_Nil = (T_Rules (let _lhsOppL :: ([PP_Doc]) _lhsOpp :: PP_Doc - -- "AbstractSyntaxDump.ag"(line 63, column 33) + -- "AbstractSyntaxDump.ag"(line 64, column 33) _lhsOppL = [] - -- use rule "AbstractSyntaxDump.ag"(line 16, column 58) + -- use rule "AbstractSyntaxDump.ag"(line 17, column 58) _lhsOpp = empty - in ( _lhsOpp,_lhsOppL)) ) + in ( _lhsOpp,_lhsOppL))) -- TypeSig ----------------------------------------------------- {- visit 0: @@ -715,31 +747,31 @@ pp : PP_Doc alternatives: alternative TypeSig: - child name : {Name} + child name : {Identifier} child tp : {Type} -} -- cata sem_TypeSig :: TypeSig -> T_TypeSig -sem_TypeSig (TypeSig _name _tp ) = - (sem_TypeSig_TypeSig _name _tp ) +sem_TypeSig (TypeSig _name _tp) = + (sem_TypeSig_TypeSig _name _tp) -- semantic domain newtype T_TypeSig = T_TypeSig (( PP_Doc)) data Inh_TypeSig = Inh_TypeSig {} data Syn_TypeSig = Syn_TypeSig {pp_Syn_TypeSig :: PP_Doc} -wrap_TypeSig (T_TypeSig sem ) (Inh_TypeSig ) = +wrap_TypeSig (T_TypeSig sem) (Inh_TypeSig ) = (let ( _lhsOpp) = (sem ) - in (Syn_TypeSig _lhsOpp )) -sem_TypeSig_TypeSig :: Name -> + in (Syn_TypeSig _lhsOpp)) +sem_TypeSig_TypeSig :: Identifier -> Type -> T_TypeSig -sem_TypeSig_TypeSig name_ tp_ = +sem_TypeSig_TypeSig name_ tp_ = (T_TypeSig (let _lhsOpp :: PP_Doc - -- "AbstractSyntaxDump.ag"(line 40, column 33) + -- "AbstractSyntaxDump.ag"(line 41, column 33) _lhsOpp = ppNestInfo ["TypeSig","TypeSig"] [pp name_, ppShow tp_] [] [] - in ( _lhsOpp)) ) + in ( _lhsOpp))) -- TypeSigs ---------------------------------------------------- {- visit 0: @@ -755,44 +787,44 @@ -- cata sem_TypeSigs :: TypeSigs -> T_TypeSigs -sem_TypeSigs list = - (Prelude.foldr sem_TypeSigs_Cons sem_TypeSigs_Nil (Prelude.map sem_TypeSig list) ) +sem_TypeSigs list = + (Prelude.foldr sem_TypeSigs_Cons sem_TypeSigs_Nil (Prelude.map sem_TypeSig list)) -- semantic domain newtype T_TypeSigs = T_TypeSigs (( PP_Doc,([PP_Doc]))) data Inh_TypeSigs = Inh_TypeSigs {} data Syn_TypeSigs = Syn_TypeSigs {pp_Syn_TypeSigs :: PP_Doc,ppL_Syn_TypeSigs :: [PP_Doc]} -wrap_TypeSigs (T_TypeSigs sem ) (Inh_TypeSigs ) = +wrap_TypeSigs (T_TypeSigs sem) (Inh_TypeSigs ) = (let ( _lhsOpp,_lhsOppL) = (sem ) - in (Syn_TypeSigs _lhsOpp _lhsOppL )) + in (Syn_TypeSigs _lhsOpp _lhsOppL)) sem_TypeSigs_Cons :: T_TypeSig -> T_TypeSigs -> T_TypeSigs -sem_TypeSigs_Cons (T_TypeSig hd_ ) (T_TypeSigs tl_ ) = +sem_TypeSigs_Cons (T_TypeSig hd_) (T_TypeSigs tl_) = (T_TypeSigs (let _lhsOppL :: ([PP_Doc]) _lhsOpp :: PP_Doc _hdIpp :: PP_Doc _tlIpp :: PP_Doc _tlIppL :: ([PP_Doc]) - -- "AbstractSyntaxDump.ag"(line 58, column 33) + -- "AbstractSyntaxDump.ag"(line 59, column 33) _lhsOppL = _hdIpp : _tlIppL - -- use rule "AbstractSyntaxDump.ag"(line 16, column 58) + -- use rule "AbstractSyntaxDump.ag"(line 17, column 58) _lhsOpp = _hdIpp >-< _tlIpp ( _hdIpp) = (hd_ ) ( _tlIpp,_tlIppL) = (tl_ ) - in ( _lhsOpp,_lhsOppL)) ) + in ( _lhsOpp,_lhsOppL))) sem_TypeSigs_Nil :: T_TypeSigs sem_TypeSigs_Nil = (T_TypeSigs (let _lhsOppL :: ([PP_Doc]) _lhsOpp :: PP_Doc - -- "AbstractSyntaxDump.ag"(line 59, column 33) + -- "AbstractSyntaxDump.ag"(line 60, column 33) _lhsOppL = [] - -- use rule "AbstractSyntaxDump.ag"(line 16, column 58) + -- use rule "AbstractSyntaxDump.ag"(line 17, column 58) _lhsOpp = empty - in ( _lhsOpp,_lhsOppL)) ) + in ( _lhsOpp,_lhsOppL))) diff --git a/src-derived/Code.hs b/src-derived/Code.hs --- a/src-derived/Code.hs +++ b/src-derived/Code.hs @@ -1,4 +1,3 @@ - -- UUAGC 0.9.5 (Code.ag) module Code where @@ -32,7 +31,7 @@ child left : Lhs child expr : Expr -} -data CaseAlt = CaseAlt (Lhs) (Expr) +data CaseAlt = CaseAlt (Lhs) (Expr) -- CaseAlts ---------------------------------------------------- {- alternatives: @@ -56,7 +55,7 @@ child semFunctions : Decls child semNames : {[String]} -} -data Chunk = Chunk (String) (Decl) (Decls) (Decls) (Decls) (Decls) (Decls) (Decls) ([String]) +data Chunk = Chunk (String) (Decl) (Decls) (Decls) (Decls) (Decls) (Decls) (Decls) ([String]) -- Chunks ------------------------------------------------------ {- alternatives: @@ -76,8 +75,8 @@ child name : {String} child args : {[(String,String)]} -} -data DataAlt = DataAlt (String) ([String]) - | Record (String) ([(String,String)]) +data DataAlt = DataAlt (String) ([String]) + | Record (String) ([(String,String)]) -- DataAlts ---------------------------------------------------- {- alternatives: @@ -94,6 +93,7 @@ child txt : {String} alternative Data: child name : {String} + child params : {[String]} child alts : DataAlts child strict : {Bool} child derivings : {[String]} @@ -104,6 +104,7 @@ child uses : {Set String} alternative NewType: child name : {String} + child params : {[String]} child con : {String} child tp : Type alternative PragmaDecl: @@ -113,15 +114,16 @@ child tp : Type alternative Type: child name : {String} + child params : {[String]} child tp : Type -} -data Decl = Comment (String) - | Data (String) (DataAlts) (Bool) ([String]) - | Decl (Lhs) (Expr) (Set String) (Set String) - | NewType (String) (String) (Type) - | PragmaDecl (String) - | TSig (String) (Type) - | Type (String) (Type) +data Decl = Comment (String) + | Data (String) ([String]) (DataAlts) (Bool) ([String]) + | Decl (Lhs) (Expr) (Set String) (Set String) + | NewType (String) ([String]) (String) (Type) + | PragmaDecl (String) + | TSig (String) (Type) + | Type (String) ([String]) (Type) -- Decls ------------------------------------------------------- {- alternatives: @@ -141,7 +143,7 @@ child expr : Expr child alts : CaseAlts alternative Lambda: - child args : {[String]} + child args : Exprs child body : Expr alternative Let: child decls : Decls @@ -162,20 +164,24 @@ child expr : Expr alternative TupleExpr: child exprs : Exprs + alternative TypedExpr: + child expr : Expr + child tp : Type alternative UnboxedTupleExpr: child exprs : Exprs -} -data Expr = App (String) (Exprs) - | Case (Expr) (CaseAlts) - | Lambda ([String]) (Expr) - | Let (Decls) (Expr) - | LineExpr (Expr) - | PragmaExpr (Bool) (Bool) (String) (Expr) - | SimpleExpr (String) - | TextExpr ([String]) - | Trace (String) (Expr) - | TupleExpr (Exprs) - | UnboxedTupleExpr (Exprs) +data Expr = App (String) (Exprs) + | Case (Expr) (CaseAlts) + | Lambda (Exprs) (Expr) + | Let (Decls) (Expr) + | LineExpr (Expr) + | PragmaExpr (Bool) (Bool) (String) (Expr) + | SimpleExpr (String) + | TextExpr ([String]) + | Trace (String) (Expr) + | TupleExpr (Exprs) + | TypedExpr (Expr) (Type) + | UnboxedTupleExpr (Exprs) -- Exprs ------------------------------------------------------- {- alternatives: @@ -200,38 +206,46 @@ alternative UnboxedTupleLhs: child comps : {[String]} -} -data Lhs = Fun (String) (Exprs) - | Pattern3 (Pattern) - | Pattern3SM (Pattern) - | TupleLhs ([String]) - | UnboxedTupleLhs ([String]) +data Lhs = Fun (String) (Exprs) + | Pattern3 (Pattern) + | Pattern3SM (Pattern) + | TupleLhs ([String]) + | UnboxedTupleLhs ([String]) -- Program ----------------------------------------------------- {- alternatives: alternative Program: child chunks : Chunks -} -data Program = Program (Chunks) +data Program = Program (Chunks) -- Type -------------------------------------------------------- {- alternatives: alternative Arr: child left : Type child right : Type + alternative CtxApp: + child left : {[(String, [String])]} + child right : Type alternative List: child tp : Type alternative SimpleType: child txt : {String} alternative TupleType: child tps : Types + alternative TypeApp: + child func : Type + child args : Types alternative UnboxedTupleType: child tps : Types -} -data Type = Arr (Type) (Type) - | List (Type) - | SimpleType (String) - | TupleType (Types) - | UnboxedTupleType (Types) +data Type = Arr (Type) (Type) + | CtxApp ([(String, [String])]) (Type) + | List (Type) + | SimpleType (String) + | TupleType (Types) + | TypeApp (Type) (Types) + | UnboxedTupleType (Types) -- Types ------------------------------------------------------- {- alternatives: diff --git a/src-derived/CodeSyntax.hs b/src-derived/CodeSyntax.hs --- a/src-derived/CodeSyntax.hs +++ b/src-derived/CodeSyntax.hs @@ -1,4 +1,3 @@ - -- UUAGC 0.9.5 (CodeSyntax.ag) module CodeSyntax where @@ -6,54 +5,57 @@ import CommonTypes import Data.Map(Map) import Data.Set(Set) --- CAlternative ------------------------------------------------ -{- - alternatives: - alternative CAlternative: - child con : {Constructor} - child visits : CVisits - child children : {[(Name,Type,Bool)]} - child terminals : {[Name]} --} -data CAlternative = CAlternative (Constructor) (CVisits) ([(Name,Type,Bool)]) ([Name]) --- CAlternatives ----------------------------------------------- -{- - alternatives: - alternative Cons: - child hd : CAlternative - child tl : CAlternatives - alternative Nil: --} -type CAlternatives = [CAlternative] -- CGrammar ---------------------------------------------------- {- alternatives: alternative CGrammar: child typeSyns : {TypeSyns} child derivings : {Derivings} - child wrappers : {Set Nonterminal} - child prods : CProductions + child wrappers : {Set NontermIdent} + child nonts : CNonterminals child pragmas : {PragmaMap} + child paramMap : {ParamMap} + child contextMap : {ContextMap} -} -data CGrammar = CGrammar (TypeSyns) (Derivings) (Set Nonterminal) (CProductions) (PragmaMap) +data CGrammar = CGrammar (TypeSyns) (Derivings) (Set NontermIdent) (CNonterminals) (PragmaMap) (ParamMap) (ContextMap) -- CInterface -------------------------------------------------- {- alternatives: alternative CInterface: child seg : CSegments -} -data CInterface = CInterface (CSegments) --- CProduction ------------------------------------------------- +data CInterface = CInterface (CSegments) +-- CNonterminal ------------------------------------------------ {- alternatives: - alternative CProduction: - child nt : {Nonterminal} + alternative CNonterminal: + child nt : {NontermIdent} + child params : {[Identifier]} child inh : {Attributes} child syn : {Attributes} - child alts : CAlternatives + child prods : CProductions child inter : CInterface -} -data CProduction = CProduction (Nonterminal) (Attributes) (Attributes) (CAlternatives) (CInterface) +data CNonterminal = CNonterminal (NontermIdent) ([Identifier]) (Attributes) (Attributes) (CProductions) (CInterface) +-- CNonterminals ----------------------------------------------- +{- + alternatives: + alternative Cons: + child hd : CNonterminal + child tl : CNonterminals + alternative Nil: +-} +type CNonterminals = [CNonterminal] +-- CProduction ------------------------------------------------- +{- + alternatives: + alternative CProduction: + child con : {ConstructorIdent} + child visits : CVisits + child children : {[(Identifier,Type,Bool)]} + child terminals : {[Identifier]} +-} +data CProduction = CProduction (ConstructorIdent) (CVisits) ([(Identifier,Type,Bool)]) ([Identifier]) -- CProductions ------------------------------------------------ {- alternatives: @@ -67,30 +69,30 @@ {- alternatives: alternative CChildVisit: - child name : {Name} - child nt : {Nonterminal} + child name : {Identifier} + child nt : {NontermIdent} child nr : {Int} child inh : {Attributes} child syn : {Attributes} child isLast : {Bool} alternative CRule: - child name : {Name} + child name : {Identifier} child isIn : {Bool} child hasCode : {Bool} - child nt : {Nonterminal} - child con : {Constructor} - child field : {Name} - child childnt : {Maybe Nonterminal} + child nt : {NontermIdent} + child con : {ConstructorIdent} + child field : {Identifier} + child childnt : {Maybe NontermIdent} child tp : {Maybe Type} child pattern : {Pattern} child rhs : {[String]} - child defines : {Map Int (Name,Name,Maybe Type)} + child defines : {Map Int (Identifier,Identifier,Maybe Type)} child owrt : {Bool} child origin : {String} - child uses : {Set (Name, Name)} + child uses : {Set (Identifier, Identifier)} -} -data CRule = CChildVisit (Name) (Nonterminal) (Int) (Attributes) (Attributes) (Bool) - | CRule (Name) (Bool) (Bool) (Nonterminal) (Constructor) (Name) (Maybe Nonterminal) (Maybe Type) (Pattern) ([String]) (Map Int (Name,Name,Maybe Type)) (Bool) (String) (Set (Name, Name)) +data CRule = CChildVisit (Identifier) (NontermIdent) (Int) (Attributes) (Attributes) (Bool) + | CRule (Identifier) (Bool) (Bool) (NontermIdent) (ConstructorIdent) (Identifier) (Maybe NontermIdent) (Maybe Type) (Pattern) ([String]) (Map Int (Identifier,Identifier,Maybe Type)) (Bool) (String) (Set (Identifier, Identifier)) -- CSegment ---------------------------------------------------- {- alternatives: @@ -98,7 +100,7 @@ child inh : {Attributes} child syn : {Attributes} -} -data CSegment = CSegment (Attributes) (Attributes) +data CSegment = CSegment (Attributes) (Attributes) -- CSegments --------------------------------------------------- {- alternatives: @@ -118,7 +120,7 @@ child intra : Sequence child ordered : {Bool} -} -data CVisit = CVisit (Attributes) (Attributes) (Sequence) (Sequence) (Bool) +data CVisit = CVisit (Attributes) (Attributes) (Sequence) (Sequence) (Bool) -- CVisits ----------------------------------------------------- {- alternatives: diff --git a/src-derived/CodeSyntaxDump.hs b/src-derived/CodeSyntaxDump.hs --- a/src-derived/CodeSyntaxDump.hs +++ b/src-derived/CodeSyntaxDump.hs @@ -1,4 +1,3 @@ - -- UUAGC 0.9.5 (CodeSyntaxDump.ag) module CodeSyntaxDump where @@ -17,17 +16,17 @@ -- Patterns.ag imports import UU.Scanner.Position(Pos) -import CommonTypes (Constructor,Name) +import CommonTypes (ConstructorIdent,Identifier) -ppChild :: (Name,Type,Bool) -> PP_Doc +ppChild :: (Identifier,Type,Bool) -> PP_Doc ppChild (nm,tp,b) = pp nm >#< "::" >#< pp (show tp) >#< "<" >|< ppBool b >|< ">" -ppVertexMap :: Map Int (Name,Name,Maybe Type) -> PP_Doc +ppVertexMap :: Map Int (Identifier,Identifier,Maybe Type) -> PP_Doc ppVertexMap m = ppVList [ ppF (show k) $ ppAttr v | (k,v) <- Map.toList m ] -ppAttr :: (Name,Name,Maybe Type) -> PP_Doc +ppAttr :: (Identifier,Identifier,Maybe Type) -> PP_Doc ppAttr (fld,nm,mTp) = pp fld >|< "." >|< pp nm >#< case mTp of @@ -44,102 +43,6 @@ ppStrings :: [String] -> PP_Doc ppStrings = vlist --- CAlternative ------------------------------------------------ -{- - visit 0: - synthesized attribute: - pp : PP_Doc - alternatives: - alternative CAlternative: - child con : {Constructor} - child visits : CVisits - child children : {[(Name,Type,Bool)]} - child terminals : {[Name]} --} --- cata -sem_CAlternative :: CAlternative -> - T_CAlternative -sem_CAlternative (CAlternative _con _visits _children _terminals ) = - (sem_CAlternative_CAlternative _con (sem_CVisits _visits ) _children _terminals ) --- semantic domain -newtype T_CAlternative = T_CAlternative (( PP_Doc)) -data Inh_CAlternative = Inh_CAlternative {} -data Syn_CAlternative = Syn_CAlternative {pp_Syn_CAlternative :: PP_Doc} -wrap_CAlternative (T_CAlternative sem ) (Inh_CAlternative ) = - (let ( _lhsOpp) = - (sem ) - in (Syn_CAlternative _lhsOpp )) -sem_CAlternative_CAlternative :: Constructor -> - T_CVisits -> - ([(Name,Type,Bool)]) -> - ([Name]) -> - T_CAlternative -sem_CAlternative_CAlternative con_ (T_CVisits visits_ ) children_ terminals_ = - (T_CAlternative (let _lhsOpp :: PP_Doc - _visitsIpp :: PP_Doc - _visitsIppL :: ([PP_Doc]) - -- "CodeSyntaxDump.ag"(line 63, column 25) - _lhsOpp = - ppNestInfo ["CAlternative","CAlternative"] [pp con_] [ppF "visits" $ ppVList _visitsIppL, ppF "children" $ ppVList (map ppChild children_),ppF "terminals" $ ppVList (map ppShow terminals_)] [] - ( _visitsIpp,_visitsIppL) = - (visits_ ) - in ( _lhsOpp)) ) --- CAlternatives ----------------------------------------------- -{- - visit 0: - synthesized attributes: - pp : PP_Doc - ppL : [PP_Doc] - alternatives: - alternative Cons: - child hd : CAlternative - child tl : CAlternatives - alternative Nil: --} --- cata -sem_CAlternatives :: CAlternatives -> - T_CAlternatives -sem_CAlternatives list = - (Prelude.foldr sem_CAlternatives_Cons sem_CAlternatives_Nil (Prelude.map sem_CAlternative list) ) --- semantic domain -newtype T_CAlternatives = T_CAlternatives (( PP_Doc,([PP_Doc]))) -data Inh_CAlternatives = Inh_CAlternatives {} -data Syn_CAlternatives = Syn_CAlternatives {pp_Syn_CAlternatives :: PP_Doc,ppL_Syn_CAlternatives :: [PP_Doc]} -wrap_CAlternatives (T_CAlternatives sem ) (Inh_CAlternatives ) = - (let ( _lhsOpp,_lhsOppL) = - (sem ) - in (Syn_CAlternatives _lhsOpp _lhsOppL )) -sem_CAlternatives_Cons :: T_CAlternative -> - T_CAlternatives -> - T_CAlternatives -sem_CAlternatives_Cons (T_CAlternative hd_ ) (T_CAlternatives tl_ ) = - (T_CAlternatives (let _lhsOppL :: ([PP_Doc]) - _lhsOpp :: PP_Doc - _hdIpp :: PP_Doc - _tlIpp :: PP_Doc - _tlIppL :: ([PP_Doc]) - -- "CodeSyntaxDump.ag"(line 94, column 33) - _lhsOppL = - _hdIpp : _tlIppL - -- use rule "CodeSyntaxDump.ag"(line 44, column 40) - _lhsOpp = - _hdIpp >-< _tlIpp - ( _hdIpp) = - (hd_ ) - ( _tlIpp,_tlIppL) = - (tl_ ) - in ( _lhsOpp,_lhsOppL)) ) -sem_CAlternatives_Nil :: T_CAlternatives -sem_CAlternatives_Nil = - (T_CAlternatives (let _lhsOppL :: ([PP_Doc]) - _lhsOpp :: PP_Doc - -- "CodeSyntaxDump.ag"(line 95, column 33) - _lhsOppL = - [] - -- use rule "CodeSyntaxDump.ag"(line 44, column 40) - _lhsOpp = - empty - in ( _lhsOpp,_lhsOppL)) ) -- CGrammar ---------------------------------------------------- {- visit 0: @@ -149,43 +52,47 @@ alternative CGrammar: child typeSyns : {TypeSyns} child derivings : {Derivings} - child wrappers : {Set Nonterminal} - child prods : CProductions + child wrappers : {Set NontermIdent} + child nonts : CNonterminals child pragmas : {PragmaMap} + child paramMap : {ParamMap} + child contextMap : {ContextMap} -} -- cata sem_CGrammar :: CGrammar -> T_CGrammar -sem_CGrammar (CGrammar _typeSyns _derivings _wrappers _prods _pragmas ) = - (sem_CGrammar_CGrammar _typeSyns _derivings _wrappers (sem_CProductions _prods ) _pragmas ) +sem_CGrammar (CGrammar _typeSyns _derivings _wrappers _nonts _pragmas _paramMap _contextMap) = + (sem_CGrammar_CGrammar _typeSyns _derivings _wrappers (sem_CNonterminals _nonts) _pragmas _paramMap _contextMap) -- semantic domain newtype T_CGrammar = T_CGrammar (( PP_Doc)) data Inh_CGrammar = Inh_CGrammar {} data Syn_CGrammar = Syn_CGrammar {pp_Syn_CGrammar :: PP_Doc} -wrap_CGrammar (T_CGrammar sem ) (Inh_CGrammar ) = +wrap_CGrammar (T_CGrammar sem) (Inh_CGrammar ) = (let ( _lhsOpp) = (sem ) - in (Syn_CGrammar _lhsOpp )) + in (Syn_CGrammar _lhsOpp)) sem_CGrammar_CGrammar :: TypeSyns -> Derivings -> - (Set Nonterminal) -> - T_CProductions -> + (Set NontermIdent) -> + T_CNonterminals -> PragmaMap -> + ParamMap -> + ContextMap -> T_CGrammar -sem_CGrammar_CGrammar typeSyns_ derivings_ wrappers_ (T_CProductions prods_ ) pragmas_ = +sem_CGrammar_CGrammar typeSyns_ derivings_ wrappers_ (T_CNonterminals nonts_) pragmas_ paramMap_ contextMap_ = (T_CGrammar (let _lhsOpp :: PP_Doc - _prodsIpp :: PP_Doc - _prodsIppL :: ([PP_Doc]) + _nontsIpp :: PP_Doc + _nontsIppL :: ([PP_Doc]) -- "CodeSyntaxDump.ag"(line 47, column 21) _lhsOpp = ppNestInfo ["CGrammar","CGrammar"] [] [ ppF "typeSyns" $ ppAssocL typeSyns_ , ppF "derivings" $ ppMap $ derivings_ - , ppF "prods" $ ppVList _prodsIppL + , ppF "nonts" $ ppVList _nontsIppL ] [] - ( _prodsIpp,_prodsIppL) = - (prods_ ) - in ( _lhsOpp)) ) + ( _nontsIpp,_nontsIppL) = + (nonts_ ) + in ( _lhsOpp))) -- CInterface -------------------------------------------------- {- visit 0: @@ -198,19 +105,19 @@ -- cata sem_CInterface :: CInterface -> T_CInterface -sem_CInterface (CInterface _seg ) = - (sem_CInterface_CInterface (sem_CSegments _seg ) ) +sem_CInterface (CInterface _seg) = + (sem_CInterface_CInterface (sem_CSegments _seg)) -- semantic domain newtype T_CInterface = T_CInterface (( PP_Doc)) data Inh_CInterface = Inh_CInterface {} data Syn_CInterface = Syn_CInterface {pp_Syn_CInterface :: PP_Doc} -wrap_CInterface (T_CInterface sem ) (Inh_CInterface ) = +wrap_CInterface (T_CInterface sem) (Inh_CInterface ) = (let ( _lhsOpp) = (sem ) - in (Syn_CInterface _lhsOpp )) + in (Syn_CInterface _lhsOpp)) sem_CInterface_CInterface :: T_CSegments -> T_CInterface -sem_CInterface_CInterface (T_CSegments seg_ ) = +sem_CInterface_CInterface (T_CSegments seg_) = (T_CInterface (let _lhsOpp :: PP_Doc _segIpp :: PP_Doc _segIppL :: ([PP_Doc]) @@ -219,52 +126,150 @@ ppNestInfo ["CInterface","CInterface"] [] [ppF "seg" $ ppVList _segIppL] [] ( _segIpp,_segIppL) = (seg_ ) - in ( _lhsOpp)) ) --- CProduction ------------------------------------------------- + in ( _lhsOpp))) +-- CNonterminal ------------------------------------------------ {- visit 0: synthesized attribute: pp : PP_Doc alternatives: - alternative CProduction: - child nt : {Nonterminal} + alternative CNonterminal: + child nt : {NontermIdent} + child params : {[Identifier]} child inh : {Attributes} child syn : {Attributes} - child alts : CAlternatives + child prods : CProductions child inter : CInterface -} -- cata +sem_CNonterminal :: CNonterminal -> + T_CNonterminal +sem_CNonterminal (CNonterminal _nt _params _inh _syn _prods _inter) = + (sem_CNonterminal_CNonterminal _nt _params _inh _syn (sem_CProductions _prods) (sem_CInterface _inter)) +-- semantic domain +newtype T_CNonterminal = T_CNonterminal (( PP_Doc)) +data Inh_CNonterminal = Inh_CNonterminal {} +data Syn_CNonterminal = Syn_CNonterminal {pp_Syn_CNonterminal :: PP_Doc} +wrap_CNonterminal (T_CNonterminal sem) (Inh_CNonterminal ) = + (let ( _lhsOpp) = + (sem ) + in (Syn_CNonterminal _lhsOpp)) +sem_CNonterminal_CNonterminal :: NontermIdent -> + ([Identifier]) -> + Attributes -> + Attributes -> + T_CProductions -> + T_CInterface -> + T_CNonterminal +sem_CNonterminal_CNonterminal nt_ params_ inh_ syn_ (T_CProductions prods_) (T_CInterface inter_) = + (T_CNonterminal (let _lhsOpp :: PP_Doc + _prodsIpp :: PP_Doc + _prodsIppL :: ([PP_Doc]) + _interIpp :: PP_Doc + -- "CodeSyntaxDump.ag"(line 54, column 33) + _lhsOpp = + ppNestInfo ["CNonterminal","CNonterminal"] (pp nt_ : map pp params_) [ppF "inh" $ ppMap inh_, ppF "syn" $ ppMap syn_, ppF "prods" $ ppVList _prodsIppL, ppF "inter" _interIpp] [] + ( _prodsIpp,_prodsIppL) = + (prods_ ) + ( _interIpp) = + (inter_ ) + in ( _lhsOpp))) +-- CNonterminals ----------------------------------------------- +{- + visit 0: + synthesized attributes: + pp : PP_Doc + ppL : [PP_Doc] + alternatives: + alternative Cons: + child hd : CNonterminal + child tl : CNonterminals + alternative Nil: +-} +-- cata +sem_CNonterminals :: CNonterminals -> + T_CNonterminals +sem_CNonterminals list = + (Prelude.foldr sem_CNonterminals_Cons sem_CNonterminals_Nil (Prelude.map sem_CNonterminal list)) +-- semantic domain +newtype T_CNonterminals = T_CNonterminals (( PP_Doc,([PP_Doc]))) +data Inh_CNonterminals = Inh_CNonterminals {} +data Syn_CNonterminals = Syn_CNonterminals {pp_Syn_CNonterminals :: PP_Doc,ppL_Syn_CNonterminals :: [PP_Doc]} +wrap_CNonterminals (T_CNonterminals sem) (Inh_CNonterminals ) = + (let ( _lhsOpp,_lhsOppL) = + (sem ) + in (Syn_CNonterminals _lhsOpp _lhsOppL)) +sem_CNonterminals_Cons :: T_CNonterminal -> + T_CNonterminals -> + T_CNonterminals +sem_CNonterminals_Cons (T_CNonterminal hd_) (T_CNonterminals tl_) = + (T_CNonterminals (let _lhsOppL :: ([PP_Doc]) + _lhsOpp :: PP_Doc + _hdIpp :: PP_Doc + _tlIpp :: PP_Doc + _tlIppL :: ([PP_Doc]) + -- "CodeSyntaxDump.ag"(line 102, column 33) + _lhsOppL = + _hdIpp : _tlIppL + -- use rule "CodeSyntaxDump.ag"(line 44, column 40) + _lhsOpp = + _hdIpp >-< _tlIpp + ( _hdIpp) = + (hd_ ) + ( _tlIpp,_tlIppL) = + (tl_ ) + in ( _lhsOpp,_lhsOppL))) +sem_CNonterminals_Nil :: T_CNonterminals +sem_CNonterminals_Nil = + (T_CNonterminals (let _lhsOppL :: ([PP_Doc]) + _lhsOpp :: PP_Doc + -- "CodeSyntaxDump.ag"(line 103, column 33) + _lhsOppL = + [] + -- use rule "CodeSyntaxDump.ag"(line 44, column 40) + _lhsOpp = + empty + in ( _lhsOpp,_lhsOppL))) +-- CProduction ------------------------------------------------- +{- + visit 0: + synthesized attribute: + pp : PP_Doc + alternatives: + alternative CProduction: + child con : {ConstructorIdent} + child visits : CVisits + child children : {[(Identifier,Type,Bool)]} + child terminals : {[Identifier]} +-} +-- cata sem_CProduction :: CProduction -> T_CProduction -sem_CProduction (CProduction _nt _inh _syn _alts _inter ) = - (sem_CProduction_CProduction _nt _inh _syn (sem_CAlternatives _alts ) (sem_CInterface _inter ) ) +sem_CProduction (CProduction _con _visits _children _terminals) = + (sem_CProduction_CProduction _con (sem_CVisits _visits) _children _terminals) -- semantic domain newtype T_CProduction = T_CProduction (( PP_Doc)) data Inh_CProduction = Inh_CProduction {} data Syn_CProduction = Syn_CProduction {pp_Syn_CProduction :: PP_Doc} -wrap_CProduction (T_CProduction sem ) (Inh_CProduction ) = +wrap_CProduction (T_CProduction sem) (Inh_CProduction ) = (let ( _lhsOpp) = (sem ) - in (Syn_CProduction _lhsOpp )) -sem_CProduction_CProduction :: Nonterminal -> - Attributes -> - Attributes -> - T_CAlternatives -> - T_CInterface -> + in (Syn_CProduction _lhsOpp)) +sem_CProduction_CProduction :: ConstructorIdent -> + T_CVisits -> + ([(Identifier,Type,Bool)]) -> + ([Identifier]) -> T_CProduction -sem_CProduction_CProduction nt_ inh_ syn_ (T_CAlternatives alts_ ) (T_CInterface inter_ ) = +sem_CProduction_CProduction con_ (T_CVisits visits_) children_ terminals_ = (T_CProduction (let _lhsOpp :: PP_Doc - _altsIpp :: PP_Doc - _altsIppL :: ([PP_Doc]) - _interIpp :: PP_Doc - -- "CodeSyntaxDump.ag"(line 54, column 25) + _visitsIpp :: PP_Doc + _visitsIppL :: ([PP_Doc]) + -- "CodeSyntaxDump.ag"(line 63, column 17) _lhsOpp = - ppNestInfo ["CProduction","CProduction"] [pp nt_] [ppF "inh" $ ppMap inh_, ppF "syn" $ ppMap syn_, ppF "alts" $ ppVList _altsIppL, ppF "inter" _interIpp] [] - ( _altsIpp,_altsIppL) = - (alts_ ) - ( _interIpp) = - (inter_ ) - in ( _lhsOpp)) ) + ppNestInfo ["CProduction","CProduction"] [pp con_] [ppF "visits" $ ppVList _visitsIppL, ppF "children" $ ppVList (map ppChild children_),ppF "terminals" $ ppVList (map ppShow terminals_)] [] + ( _visitsIpp,_visitsIppL) = + (visits_ ) + in ( _lhsOpp))) -- CProductions ------------------------------------------------ {- visit 0: @@ -280,26 +285,26 @@ -- cata sem_CProductions :: CProductions -> T_CProductions -sem_CProductions list = - (Prelude.foldr sem_CProductions_Cons sem_CProductions_Nil (Prelude.map sem_CProduction list) ) +sem_CProductions list = + (Prelude.foldr sem_CProductions_Cons sem_CProductions_Nil (Prelude.map sem_CProduction list)) -- semantic domain newtype T_CProductions = T_CProductions (( PP_Doc,([PP_Doc]))) data Inh_CProductions = Inh_CProductions {} data Syn_CProductions = Syn_CProductions {pp_Syn_CProductions :: PP_Doc,ppL_Syn_CProductions :: [PP_Doc]} -wrap_CProductions (T_CProductions sem ) (Inh_CProductions ) = +wrap_CProductions (T_CProductions sem) (Inh_CProductions ) = (let ( _lhsOpp,_lhsOppL) = (sem ) - in (Syn_CProductions _lhsOpp _lhsOppL )) + in (Syn_CProductions _lhsOpp _lhsOppL)) sem_CProductions_Cons :: T_CProduction -> T_CProductions -> T_CProductions -sem_CProductions_Cons (T_CProduction hd_ ) (T_CProductions tl_ ) = +sem_CProductions_Cons (T_CProduction hd_) (T_CProductions tl_) = (T_CProductions (let _lhsOppL :: ([PP_Doc]) _lhsOpp :: PP_Doc _hdIpp :: PP_Doc _tlIpp :: PP_Doc _tlIppL :: ([PP_Doc]) - -- "CodeSyntaxDump.ag"(line 102, column 33) + -- "CodeSyntaxDump.ag"(line 94, column 33) _lhsOppL = _hdIpp : _tlIppL -- use rule "CodeSyntaxDump.ag"(line 44, column 40) @@ -309,18 +314,18 @@ (hd_ ) ( _tlIpp,_tlIppL) = (tl_ ) - in ( _lhsOpp,_lhsOppL)) ) + in ( _lhsOpp,_lhsOppL))) sem_CProductions_Nil :: T_CProductions sem_CProductions_Nil = (T_CProductions (let _lhsOppL :: ([PP_Doc]) _lhsOpp :: PP_Doc - -- "CodeSyntaxDump.ag"(line 103, column 33) + -- "CodeSyntaxDump.ag"(line 95, column 33) _lhsOppL = [] -- use rule "CodeSyntaxDump.ag"(line 44, column 40) _lhsOpp = empty - in ( _lhsOpp,_lhsOppL)) ) + in ( _lhsOpp,_lhsOppL))) -- CRule ------------------------------------------------------- {- visit 0: @@ -328,72 +333,72 @@ pp : PP_Doc alternatives: alternative CChildVisit: - child name : {Name} - child nt : {Nonterminal} + child name : {Identifier} + child nt : {NontermIdent} child nr : {Int} child inh : {Attributes} child syn : {Attributes} child isLast : {Bool} alternative CRule: - child name : {Name} + child name : {Identifier} child isIn : {Bool} child hasCode : {Bool} - child nt : {Nonterminal} - child con : {Constructor} - child field : {Name} - child childnt : {Maybe Nonterminal} + child nt : {NontermIdent} + child con : {ConstructorIdent} + child field : {Identifier} + child childnt : {Maybe NontermIdent} child tp : {Maybe Type} child pattern : Pattern child rhs : {[String]} - child defines : {Map Int (Name,Name,Maybe Type)} + child defines : {Map Int (Identifier,Identifier,Maybe Type)} child owrt : {Bool} child origin : {String} - child uses : {Set (Name, Name)} + child uses : {Set (Identifier, Identifier)} -} -- cata sem_CRule :: CRule -> T_CRule -sem_CRule (CChildVisit _name _nt _nr _inh _syn _isLast ) = - (sem_CRule_CChildVisit _name _nt _nr _inh _syn _isLast ) -sem_CRule (CRule _name _isIn _hasCode _nt _con _field _childnt _tp _pattern _rhs _defines _owrt _origin _uses ) = - (sem_CRule_CRule _name _isIn _hasCode _nt _con _field _childnt _tp (sem_Pattern _pattern ) _rhs _defines _owrt _origin _uses ) +sem_CRule (CChildVisit _name _nt _nr _inh _syn _isLast) = + (sem_CRule_CChildVisit _name _nt _nr _inh _syn _isLast) +sem_CRule (CRule _name _isIn _hasCode _nt _con _field _childnt _tp _pattern _rhs _defines _owrt _origin _uses) = + (sem_CRule_CRule _name _isIn _hasCode _nt _con _field _childnt _tp (sem_Pattern _pattern) _rhs _defines _owrt _origin _uses) -- semantic domain newtype T_CRule = T_CRule (( PP_Doc)) data Inh_CRule = Inh_CRule {} data Syn_CRule = Syn_CRule {pp_Syn_CRule :: PP_Doc} -wrap_CRule (T_CRule sem ) (Inh_CRule ) = +wrap_CRule (T_CRule sem) (Inh_CRule ) = (let ( _lhsOpp) = (sem ) - in (Syn_CRule _lhsOpp )) -sem_CRule_CChildVisit :: Name -> - Nonterminal -> + in (Syn_CRule _lhsOpp)) +sem_CRule_CChildVisit :: Identifier -> + NontermIdent -> Int -> Attributes -> Attributes -> Bool -> T_CRule -sem_CRule_CChildVisit name_ nt_ nr_ inh_ syn_ isLast_ = +sem_CRule_CChildVisit name_ nt_ nr_ inh_ syn_ isLast_ = (T_CRule (let _lhsOpp :: PP_Doc -- "CodeSyntaxDump.ag"(line 70, column 21) _lhsOpp = ppNestInfo ["CRule","CChildVisit"] [pp name_] [ppF "nt" $ pp nt_, ppF "nr" $ ppShow nr_, ppF "inh" $ ppMap inh_, ppF "syn" $ ppMap syn_, ppF "last" $ ppBool isLast_] [] - in ( _lhsOpp)) ) -sem_CRule_CRule :: Name -> + in ( _lhsOpp))) +sem_CRule_CRule :: Identifier -> Bool -> Bool -> - Nonterminal -> - Constructor -> - Name -> - (Maybe Nonterminal) -> + NontermIdent -> + ConstructorIdent -> + Identifier -> + (Maybe NontermIdent) -> (Maybe Type) -> T_Pattern -> ([String]) -> - (Map Int (Name,Name,Maybe Type)) -> + (Map Int (Identifier,Identifier,Maybe Type)) -> Bool -> String -> - (Set (Name, Name)) -> + (Set (Identifier, Identifier)) -> T_CRule -sem_CRule_CRule name_ isIn_ hasCode_ nt_ con_ field_ childnt_ tp_ (T_Pattern pattern_ ) rhs_ defines_ owrt_ origin_ uses_ = +sem_CRule_CRule name_ isIn_ hasCode_ nt_ con_ field_ childnt_ tp_ (T_Pattern pattern_) rhs_ defines_ owrt_ origin_ uses_ = (T_CRule (let _lhsOpp :: PP_Doc _patternIcopy :: Pattern _patternIpp :: PP_Doc @@ -402,7 +407,7 @@ ppNestInfo ["CRule","CRule"] [pp name_] [ppF "isIn" $ ppBool isIn_, ppF "hasCode" $ ppBool hasCode_, ppF "nt" $ pp nt_, ppF "con" $ pp con_, ppF "field" $ pp field_, ppF "childnt" $ ppMaybeShow childnt_, ppF "tp" $ ppMaybeShow tp_, ppF "pattern" $ if isIn_ then pp "" else _patternIpp, ppF "rhs" $ ppStrings rhs_, ppF "defines" $ ppVertexMap defines_, ppF "owrt" $ ppBool owrt_, ppF "origin" $ pp origin_] [] ( _patternIcopy,_patternIpp) = (pattern_ ) - in ( _lhsOpp)) ) + in ( _lhsOpp))) -- CSegment ---------------------------------------------------- {- visit 0: @@ -416,25 +421,25 @@ -- cata sem_CSegment :: CSegment -> T_CSegment -sem_CSegment (CSegment _inh _syn ) = - (sem_CSegment_CSegment _inh _syn ) +sem_CSegment (CSegment _inh _syn) = + (sem_CSegment_CSegment _inh _syn) -- semantic domain newtype T_CSegment = T_CSegment (( PP_Doc)) data Inh_CSegment = Inh_CSegment {} data Syn_CSegment = Syn_CSegment {pp_Syn_CSegment :: PP_Doc} -wrap_CSegment (T_CSegment sem ) (Inh_CSegment ) = +wrap_CSegment (T_CSegment sem) (Inh_CSegment ) = (let ( _lhsOpp) = (sem ) - in (Syn_CSegment _lhsOpp )) + in (Syn_CSegment _lhsOpp)) sem_CSegment_CSegment :: Attributes -> Attributes -> T_CSegment -sem_CSegment_CSegment inh_ syn_ = +sem_CSegment_CSegment inh_ syn_ = (T_CSegment (let _lhsOpp :: PP_Doc -- "CodeSyntaxDump.ag"(line 60, column 21) _lhsOpp = ppNestInfo ["CSegment","CSegment"] [] [ppF "inh" $ ppMap inh_, ppF "syn" $ ppMap syn_] [] - in ( _lhsOpp)) ) + in ( _lhsOpp))) -- CSegments --------------------------------------------------- {- visit 0: @@ -450,20 +455,20 @@ -- cata sem_CSegments :: CSegments -> T_CSegments -sem_CSegments list = - (Prelude.foldr sem_CSegments_Cons sem_CSegments_Nil (Prelude.map sem_CSegment list) ) +sem_CSegments list = + (Prelude.foldr sem_CSegments_Cons sem_CSegments_Nil (Prelude.map sem_CSegment list)) -- semantic domain newtype T_CSegments = T_CSegments (( PP_Doc,([PP_Doc]))) data Inh_CSegments = Inh_CSegments {} data Syn_CSegments = Syn_CSegments {pp_Syn_CSegments :: PP_Doc,ppL_Syn_CSegments :: [PP_Doc]} -wrap_CSegments (T_CSegments sem ) (Inh_CSegments ) = +wrap_CSegments (T_CSegments sem) (Inh_CSegments ) = (let ( _lhsOpp,_lhsOppL) = (sem ) - in (Syn_CSegments _lhsOpp _lhsOppL )) + in (Syn_CSegments _lhsOpp _lhsOppL)) sem_CSegments_Cons :: T_CSegment -> T_CSegments -> T_CSegments -sem_CSegments_Cons (T_CSegment hd_ ) (T_CSegments tl_ ) = +sem_CSegments_Cons (T_CSegment hd_) (T_CSegments tl_) = (T_CSegments (let _lhsOppL :: ([PP_Doc]) _lhsOpp :: PP_Doc _hdIpp :: PP_Doc @@ -479,7 +484,7 @@ (hd_ ) ( _tlIpp,_tlIppL) = (tl_ ) - in ( _lhsOpp,_lhsOppL)) ) + in ( _lhsOpp,_lhsOppL))) sem_CSegments_Nil :: T_CSegments sem_CSegments_Nil = (T_CSegments (let _lhsOppL :: ([PP_Doc]) @@ -490,7 +495,7 @@ -- use rule "CodeSyntaxDump.ag"(line 44, column 40) _lhsOpp = empty - in ( _lhsOpp,_lhsOppL)) ) + in ( _lhsOpp,_lhsOppL))) -- CVisit ------------------------------------------------------ {- visit 0: @@ -507,23 +512,23 @@ -- cata sem_CVisit :: CVisit -> T_CVisit -sem_CVisit (CVisit _inh _syn _vss _intra _ordered ) = - (sem_CVisit_CVisit _inh _syn (sem_Sequence _vss ) (sem_Sequence _intra ) _ordered ) +sem_CVisit (CVisit _inh _syn _vss _intra _ordered) = + (sem_CVisit_CVisit _inh _syn (sem_Sequence _vss) (sem_Sequence _intra) _ordered) -- semantic domain newtype T_CVisit = T_CVisit (( PP_Doc)) data Inh_CVisit = Inh_CVisit {} data Syn_CVisit = Syn_CVisit {pp_Syn_CVisit :: PP_Doc} -wrap_CVisit (T_CVisit sem ) (Inh_CVisit ) = +wrap_CVisit (T_CVisit sem) (Inh_CVisit ) = (let ( _lhsOpp) = (sem ) - in (Syn_CVisit _lhsOpp )) + in (Syn_CVisit _lhsOpp)) sem_CVisit_CVisit :: Attributes -> Attributes -> T_Sequence -> T_Sequence -> Bool -> T_CVisit -sem_CVisit_CVisit inh_ syn_ (T_Sequence vss_ ) (T_Sequence intra_ ) ordered_ = +sem_CVisit_CVisit inh_ syn_ (T_Sequence vss_) (T_Sequence intra_) ordered_ = (T_CVisit (let _lhsOpp :: PP_Doc _vssIppL :: ([PP_Doc]) _intraIppL :: ([PP_Doc]) @@ -534,7 +539,7 @@ (vss_ ) ( _intraIppL) = (intra_ ) - in ( _lhsOpp)) ) + in ( _lhsOpp))) -- CVisits ----------------------------------------------------- {- visit 0: @@ -550,20 +555,20 @@ -- cata sem_CVisits :: CVisits -> T_CVisits -sem_CVisits list = - (Prelude.foldr sem_CVisits_Cons sem_CVisits_Nil (Prelude.map sem_CVisit list) ) +sem_CVisits list = + (Prelude.foldr sem_CVisits_Cons sem_CVisits_Nil (Prelude.map sem_CVisit list)) -- semantic domain newtype T_CVisits = T_CVisits (( PP_Doc,([PP_Doc]))) data Inh_CVisits = Inh_CVisits {} data Syn_CVisits = Syn_CVisits {pp_Syn_CVisits :: PP_Doc,ppL_Syn_CVisits :: [PP_Doc]} -wrap_CVisits (T_CVisits sem ) (Inh_CVisits ) = +wrap_CVisits (T_CVisits sem) (Inh_CVisits ) = (let ( _lhsOpp,_lhsOppL) = (sem ) - in (Syn_CVisits _lhsOpp _lhsOppL )) + in (Syn_CVisits _lhsOpp _lhsOppL)) sem_CVisits_Cons :: T_CVisit -> T_CVisits -> T_CVisits -sem_CVisits_Cons (T_CVisit hd_ ) (T_CVisits tl_ ) = +sem_CVisits_Cons (T_CVisit hd_) (T_CVisits tl_) = (T_CVisits (let _lhsOppL :: ([PP_Doc]) _lhsOpp :: PP_Doc _hdIpp :: PP_Doc @@ -579,7 +584,7 @@ (hd_ ) ( _tlIpp,_tlIppL) = (tl_ ) - in ( _lhsOpp,_lhsOppL)) ) + in ( _lhsOpp,_lhsOppL))) sem_CVisits_Nil :: T_CVisits sem_CVisits_Nil = (T_CVisits (let _lhsOppL :: ([PP_Doc]) @@ -590,7 +595,7 @@ -- use rule "CodeSyntaxDump.ag"(line 44, column 40) _lhsOpp = empty - in ( _lhsOpp,_lhsOppL)) ) + in ( _lhsOpp,_lhsOppL))) -- Pattern ----------------------------------------------------- {- visit 0: @@ -599,17 +604,21 @@ pp : PP_Doc alternatives: alternative Alias: - child field : {Name} - child attr : {Name} + child field : {Identifier} + child attr : {Identifier} child pat : Pattern child parts : Patterns visit 0: local copy : _ alternative Constr: - child name : {Constructor} + child name : {ConstructorIdent} child pats : Patterns visit 0: local copy : _ + alternative Irrefutable: + child pat : Pattern + visit 0: + local copy : _ alternative Product: child pos : {Pos} child pats : Patterns @@ -623,28 +632,30 @@ -- cata sem_Pattern :: Pattern -> T_Pattern -sem_Pattern (Alias _field _attr _pat _parts ) = - (sem_Pattern_Alias _field _attr (sem_Pattern _pat ) (sem_Patterns _parts ) ) -sem_Pattern (Constr _name _pats ) = - (sem_Pattern_Constr _name (sem_Patterns _pats ) ) -sem_Pattern (Product _pos _pats ) = - (sem_Pattern_Product _pos (sem_Patterns _pats ) ) -sem_Pattern (Underscore _pos ) = - (sem_Pattern_Underscore _pos ) +sem_Pattern (Alias _field _attr _pat _parts) = + (sem_Pattern_Alias _field _attr (sem_Pattern _pat) (sem_Patterns _parts)) +sem_Pattern (Constr _name _pats) = + (sem_Pattern_Constr _name (sem_Patterns _pats)) +sem_Pattern (Irrefutable _pat) = + (sem_Pattern_Irrefutable (sem_Pattern _pat)) +sem_Pattern (Product _pos _pats) = + (sem_Pattern_Product _pos (sem_Patterns _pats)) +sem_Pattern (Underscore _pos) = + (sem_Pattern_Underscore _pos) -- semantic domain newtype T_Pattern = T_Pattern (( Pattern,PP_Doc)) data Inh_Pattern = Inh_Pattern {} data Syn_Pattern = Syn_Pattern {copy_Syn_Pattern :: Pattern,pp_Syn_Pattern :: PP_Doc} -wrap_Pattern (T_Pattern sem ) (Inh_Pattern ) = +wrap_Pattern (T_Pattern sem) (Inh_Pattern ) = (let ( _lhsOcopy,_lhsOpp) = (sem ) - in (Syn_Pattern _lhsOcopy _lhsOpp )) -sem_Pattern_Alias :: Name -> - Name -> + in (Syn_Pattern _lhsOcopy _lhsOpp)) +sem_Pattern_Alias :: Identifier -> + Identifier -> T_Pattern -> T_Patterns -> T_Pattern -sem_Pattern_Alias field_ attr_ (T_Pattern pat_ ) (T_Patterns parts_ ) = +sem_Pattern_Alias field_ attr_ (T_Pattern pat_) (T_Patterns parts_) = (T_Pattern (let _lhsOpp :: PP_Doc _lhsOcopy :: Pattern _patIcopy :: Pattern @@ -665,11 +676,11 @@ (pat_ ) ( _partsIcopy,_partsIpp,_partsIppL) = (parts_ ) - in ( _lhsOcopy,_lhsOpp)) ) -sem_Pattern_Constr :: Constructor -> + in ( _lhsOcopy,_lhsOpp))) +sem_Pattern_Constr :: ConstructorIdent -> T_Patterns -> T_Pattern -sem_Pattern_Constr name_ (T_Patterns pats_ ) = +sem_Pattern_Constr name_ (T_Patterns pats_) = (T_Pattern (let _lhsOpp :: PP_Doc _lhsOcopy :: Pattern _patsIcopy :: Patterns @@ -686,11 +697,30 @@ _copy ( _patsIcopy,_patsIpp,_patsIppL) = (pats_ ) - in ( _lhsOcopy,_lhsOpp)) ) + in ( _lhsOcopy,_lhsOpp))) +sem_Pattern_Irrefutable :: T_Pattern -> + T_Pattern +sem_Pattern_Irrefutable (T_Pattern pat_) = + (T_Pattern (let _lhsOpp :: PP_Doc + _lhsOcopy :: Pattern + _patIcopy :: Pattern + _patIpp :: PP_Doc + -- use rule "CodeSyntaxDump.ag"(line 44, column 40) + _lhsOpp = + _patIpp + -- self rule + _copy = + Irrefutable _patIcopy + -- self rule + _lhsOcopy = + _copy + ( _patIcopy,_patIpp) = + (pat_ ) + in ( _lhsOcopy,_lhsOpp))) sem_Pattern_Product :: Pos -> T_Patterns -> T_Pattern -sem_Pattern_Product pos_ (T_Patterns pats_ ) = +sem_Pattern_Product pos_ (T_Patterns pats_) = (T_Pattern (let _lhsOpp :: PP_Doc _lhsOcopy :: Pattern _patsIcopy :: Patterns @@ -707,10 +737,10 @@ _copy ( _patsIcopy,_patsIpp,_patsIppL) = (pats_ ) - in ( _lhsOcopy,_lhsOpp)) ) + in ( _lhsOcopy,_lhsOpp))) sem_Pattern_Underscore :: Pos -> T_Pattern -sem_Pattern_Underscore pos_ = +sem_Pattern_Underscore pos_ = (T_Pattern (let _lhsOpp :: PP_Doc _lhsOcopy :: Pattern -- "CodeSyntaxDump.ag"(line 76, column 25) @@ -722,7 +752,7 @@ -- self rule _lhsOcopy = _copy - in ( _lhsOcopy,_lhsOpp)) ) + in ( _lhsOcopy,_lhsOpp))) -- Patterns ---------------------------------------------------- {- visit 0: @@ -743,20 +773,20 @@ -- cata sem_Patterns :: Patterns -> T_Patterns -sem_Patterns list = - (Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list) ) +sem_Patterns list = + (Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list)) -- semantic domain newtype T_Patterns = T_Patterns (( Patterns,PP_Doc,([PP_Doc]))) data Inh_Patterns = Inh_Patterns {} data Syn_Patterns = Syn_Patterns {copy_Syn_Patterns :: Patterns,pp_Syn_Patterns :: PP_Doc,ppL_Syn_Patterns :: [PP_Doc]} -wrap_Patterns (T_Patterns sem ) (Inh_Patterns ) = +wrap_Patterns (T_Patterns sem) (Inh_Patterns ) = (let ( _lhsOcopy,_lhsOpp,_lhsOppL) = (sem ) - in (Syn_Patterns _lhsOcopy _lhsOpp _lhsOppL )) + in (Syn_Patterns _lhsOcopy _lhsOpp _lhsOppL)) sem_Patterns_Cons :: T_Pattern -> T_Patterns -> T_Patterns -sem_Patterns_Cons (T_Pattern hd_ ) (T_Patterns tl_ ) = +sem_Patterns_Cons (T_Pattern hd_) (T_Patterns tl_) = (T_Patterns (let _lhsOppL :: ([PP_Doc]) _lhsOpp :: PP_Doc _lhsOcopy :: Patterns @@ -781,7 +811,7 @@ (hd_ ) ( _tlIcopy,_tlIpp,_tlIppL) = (tl_ ) - in ( _lhsOcopy,_lhsOpp,_lhsOppL)) ) + in ( _lhsOcopy,_lhsOpp,_lhsOppL))) sem_Patterns_Nil :: T_Patterns sem_Patterns_Nil = (T_Patterns (let _lhsOppL :: ([PP_Doc]) @@ -799,7 +829,7 @@ -- self rule _lhsOcopy = _copy - in ( _lhsOcopy,_lhsOpp,_lhsOppL)) ) + in ( _lhsOcopy,_lhsOpp,_lhsOppL))) -- Sequence ---------------------------------------------------- {- visit 0: @@ -814,20 +844,20 @@ -- cata sem_Sequence :: Sequence -> T_Sequence -sem_Sequence list = - (Prelude.foldr sem_Sequence_Cons sem_Sequence_Nil (Prelude.map sem_CRule list) ) +sem_Sequence list = + (Prelude.foldr sem_Sequence_Cons sem_Sequence_Nil (Prelude.map sem_CRule list)) -- semantic domain newtype T_Sequence = T_Sequence (( ([PP_Doc]))) data Inh_Sequence = Inh_Sequence {} data Syn_Sequence = Syn_Sequence {ppL_Syn_Sequence :: [PP_Doc]} -wrap_Sequence (T_Sequence sem ) (Inh_Sequence ) = +wrap_Sequence (T_Sequence sem) (Inh_Sequence ) = (let ( _lhsOppL) = (sem ) - in (Syn_Sequence _lhsOppL )) + in (Syn_Sequence _lhsOppL)) sem_Sequence_Cons :: T_CRule -> T_Sequence -> T_Sequence -sem_Sequence_Cons (T_CRule hd_ ) (T_Sequence tl_ ) = +sem_Sequence_Cons (T_CRule hd_) (T_Sequence tl_) = (T_Sequence (let _lhsOppL :: ([PP_Doc]) _hdIpp :: PP_Doc _tlIppL :: ([PP_Doc]) @@ -838,11 +868,11 @@ (hd_ ) ( _tlIppL) = (tl_ ) - in ( _lhsOppL)) ) + in ( _lhsOppL))) sem_Sequence_Nil :: T_Sequence sem_Sequence_Nil = (T_Sequence (let _lhsOppL :: ([PP_Doc]) -- "CodeSyntaxDump.ag"(line 87, column 33) _lhsOppL = [] - in ( _lhsOppL)) ) + in ( _lhsOppL))) diff --git a/src-derived/ConcreteSyntax.hs b/src-derived/ConcreteSyntax.hs --- a/src-derived/ConcreteSyntax.hs +++ b/src-derived/ConcreteSyntax.hs @@ -1,4 +1,3 @@ - -- UUAGC 0.9.5 (ConcreteSyntax.ag) module ConcreteSyntax where @@ -12,7 +11,7 @@ alternative AG: child elems : Elems -} -data AG = AG (Elems) +data AG = AG (Elems) -- Alt --------------------------------------------------------- {- alternatives: @@ -21,7 +20,7 @@ child names : ConstructorSet child fields : {Fields} -} -data Alt = Alt (Pos) (ConstructorSet) (Fields) +data Alt = Alt (Pos) (ConstructorSet) (Fields) -- Alts -------------------------------------------------------- {- alternatives: @@ -40,7 +39,7 @@ child chn : {AttrNames} child syn : {AttrNames} -} -data Attrs = Attrs (Pos) (AttrNames) (AttrNames) (AttrNames) +data Attrs = Attrs (Pos) (AttrNames) (AttrNames) (AttrNames) -- ConstructorSet ---------------------------------------------- {- alternatives: @@ -49,32 +48,35 @@ child set1 : ConstructorSet child set2 : ConstructorSet alternative CName: - child name : {Constructor} + child name : {ConstructorIdent} alternative CUnion: child set1 : ConstructorSet child set2 : ConstructorSet -} data ConstructorSet = CAll - | CDifference (ConstructorSet) (ConstructorSet) - | CName (Constructor) - | CUnion (ConstructorSet) (ConstructorSet) + | CDifference (ConstructorSet) (ConstructorSet) + | CName (ConstructorIdent) + | CUnion (ConstructorSet) (ConstructorSet) -- Elem -------------------------------------------------------- {- alternatives: alternative Attr: child pos : {Pos} + child ctx : {ClassContext} child names : NontSet child attrs : Attrs alternative Data: child pos : {Pos} + child ctx : {ClassContext} child names : NontSet + child params : {[Identifier]} child attrs : Attrs child alts : Alts child ext : {Bool} alternative Deriving: child pos : {Pos} child set : NontSet - child classes : {[Name]} + child classes : {[NontermIdent]} alternative Module: child pos : {Pos} child name : {String} @@ -82,38 +84,41 @@ child imports : {String} alternative Pragma: child pos : {Pos} - child names : {[Name]} + child names : {[NontermIdent]} alternative Sem: child pos : {Pos} + child ctx : {ClassContext} child names : NontSet child attrs : Attrs child alts : SemAlts alternative Set: child pos : {Pos} - child name : {Name} + child name : {NontermIdent} child set : NontSet alternative Txt: child pos : {Pos} - child name : {Name} + child name : {NontermIdent} child lines : {[String]} alternative Type: child pos : {Pos} - child name : {Nonterminal} + child ctx : {ClassContext} + child name : {NontermIdent} + child params : {[Identifier]} child type : {ComplexType} alternative Wrapper: child pos : {Pos} child set : NontSet -} -data Elem = Attr (Pos) (NontSet) (Attrs) - | Data (Pos) (NontSet) (Attrs) (Alts) (Bool) - | Deriving (Pos) (NontSet) ([Name]) - | Module (Pos) (String) (String) (String) - | Pragma (Pos) ([Name]) - | Sem (Pos) (NontSet) (Attrs) (SemAlts) - | Set (Pos) (Name) (NontSet) - | Txt (Pos) (Name) ([String]) - | Type (Pos) (Nonterminal) (ComplexType) - | Wrapper (Pos) (NontSet) +data Elem = Attr (Pos) (ClassContext) (NontSet) (Attrs) + | Data (Pos) (ClassContext) (NontSet) ([Identifier]) (Attrs) (Alts) (Bool) + | Deriving (Pos) (NontSet) ([NontermIdent]) + | Module (Pos) (String) (String) (String) + | Pragma (Pos) ([NontermIdent]) + | Sem (Pos) (ClassContext) (NontSet) (Attrs) (SemAlts) + | Set (Pos) (NontermIdent) (NontSet) + | Txt (Pos) (NontermIdent) ([String]) + | Type (Pos) (ClassContext) (NontermIdent) ([Identifier]) (ComplexType) + | Wrapper (Pos) (NontSet) -- Elems ------------------------------------------------------- {- alternatives: @@ -134,20 +139,20 @@ child set1 : NontSet child set2 : NontSet alternative NamedSet: - child name : {Nonterminal} + child name : {NontermIdent} alternative Path: - child from : {Nonterminal} - child to : {Nonterminal} + child from : {NontermIdent} + child to : {NontermIdent} alternative Union: child set1 : NontSet child set2 : NontSet -} data NontSet = All - | Difference (NontSet) (NontSet) - | Intersect (NontSet) (NontSet) - | NamedSet (Nonterminal) - | Path (Nonterminal) (Nonterminal) - | Union (NontSet) (NontSet) + | Difference (NontSet) (NontSet) + | Intersect (NontSet) (NontSet) + | NamedSet (NontermIdent) + | Path (NontermIdent) (NontermIdent) + | Union (NontSet) (NontSet) -- SemAlt ------------------------------------------------------ {- alternatives: @@ -156,7 +161,7 @@ child constructorSet : ConstructorSet child rules : SemDefs -} -data SemAlt = SemAlt (Pos) (ConstructorSet) (SemDefs) +data SemAlt = SemAlt (Pos) (ConstructorSet) (SemDefs) -- SemAlts ----------------------------------------------------- {- alternatives: @@ -170,22 +175,22 @@ {- alternatives: alternative AttrOrderBefore: - child before : {(Identifier,Identifier)} - child after : {(Identifier,Identifier)} + child before : {[(Identifier,Identifier)]} + child after : {[(Identifier,Identifier)]} alternative Def: child pattern : {Pattern} child rhs : {Expression} child owrt : {Bool} alternative SemPragma: - child names : {[Name]} + child names : {[NontermIdent]} alternative TypeDef: child ident : {Identifier} child tp : {Type} -} -data SemDef = AttrOrderBefore ((Identifier,Identifier)) ((Identifier,Identifier)) - | Def (Pattern) (Expression) (Bool) - | SemPragma ([Name]) - | TypeDef (Identifier) (Type) +data SemDef = AttrOrderBefore ([(Identifier,Identifier)]) ([(Identifier,Identifier)]) + | Def (Pattern) (Expression) (Bool) + | SemPragma ([NontermIdent]) + | TypeDef (Identifier) (Type) -- SemDefs ----------------------------------------------------- {- alternatives: diff --git a/src-derived/DeclBlocks.hs b/src-derived/DeclBlocks.hs --- a/src-derived/DeclBlocks.hs +++ b/src-derived/DeclBlocks.hs @@ -9,7 +9,7 @@ alternative DeclBlock: child defs : {[Decl]} child visit : {Decl} - child next : DeclBlocks + child next : DeclBlocks alternative DeclTerminator: child defs : {[Decl]} child result : {Expr} @@ -20,6 +20,6 @@ {- alternatives: alternative DeclBlocksRoot: - child blocks : DeclBlocks + child blocks : DeclBlocks -} data DeclBlocksRoot = DeclBlocksRoot (DeclBlocks) diff --git a/src-derived/DefaultRules.hs b/src-derived/DefaultRules.hs --- a/src-derived/DefaultRules.hs +++ b/src-derived/DefaultRules.hs @@ -1,2034 +1,2115 @@ - --- UUAGC 0.9.5 (DefaultRules.ag) -module DefaultRules where - -import qualified List (delete,intersperse) - -import qualified Data.Set as Set -import qualified Data.Map as Map -import Data.Map(Map) -import qualified UU.DData.Seq as Seq -import UU.DData.Seq(Seq,(<>)) -import UU.Scanner.Position(noPos) -import Pretty -import Maybe - -import AbstractSyntax -import ErrorMessages - -import Options(Options,modcopy,rename) - --- AbstractSyntax.ag imports -import Data.Set(Set) -import Data.Map(Map) -import Patterns (Pattern(..),Patterns) -import Expression (Expression(..)) -import CommonTypes - --- Patterns.ag imports -import UU.Scanner.Position(Pos) -import CommonTypes (Constructor,Name) - -fieldName n = '@' : getName n - -locName n = '@' : getName n - -attrName fld attr - | fld == _LOC = '@' : getName attr - | otherwise = '@' : getName fld ++ "." ++ getName attr - -_ACHILD = Ident "(" noPos -- hack - - -getConName typeSyns rename nt con1 - | nt `elem` map fst typeSyns = synonym - | otherwise = normalName - where con = getName con1 - normalName | rename = getName nt++"_"++ con - | otherwise = con - synonym | con == "Cons" = "(:)" - | con == "Nil" = "[]" - | con == "Just" = "Just" - | con == "Nothing" = "Nothing" - | otherwise = normalName - - - -concatSeq = foldr Seq.append Seq.empty - -splitAttrs :: Map Name a -> [Name] -> ([(Name,a)],[Name]) -- a used as (String,String) -splitAttrs _ [] - = ([],[]) -splitAttrs useMap (n:rest) - = let (uses,normals) = splitAttrs useMap rest - in case Map.lookup n useMap of - Just x -> ((n,x):uses , normals ) - Nothing -> ( uses , n:normals ) - -removeDefined :: Set (Name,Name) -> (Name,Attributes) -> (Name,[Name]) -removeDefined defined (fld,as) - = ( fld - , [ a - | a <- Map.keys as - , not (Set.member (fld,a) defined) - ] - ) - - - - - -deprecatedCopyRuleError nt con fld a - = let mesg = - "In the definitions for alternative" - >#< getName con - >#< "of nonterminal" - >#< getName nt - >|< "," - >-< "the value of field" - >#< getName a - >#< "is copied by a copy-rule." - >-< "Copying the value of a field using a copy-rule is deprecated" - >-< "Please add the following lines to your code:" - >-< ( "SEM" - >#< getName nt - >-< indent 2 ( "|" - >#< getName con - >#< getName fld - >#< "." - >#< a - >#< "=" - >#< "@" - >|< a - ) - ) - in CustomError True (getPos a) mesg - - -missingRuleErrorExpr nt con fld a - = "error \"missing rule: " - ++ show nt ++ "." ++ show con ++ "." - ++ show fld ++ "." ++ show a ++ "\"" - - - -makeRule :: (Name,Name) -> Expression -> String -> Rule -makeRule (f1,a1) expr origin - = Rule (Alias f1 a1 (Underscore noPos) []) - expr - False - origin - - -useRule :: Set Name -> [(Name,Attributes)] -> (Name,(String,String,String)) -> Rule -useRule locals ch_outs (n,(op,e,pos)) - = let elems = [ fld - | (fld,as) <- ch_outs - , Map.member n as - ] - - expr | Set.member n locals = attrName _LOC n - | null elems = e - | otherwise = foldr1 (\x y -> x ++ " " ++ op ++ " " ++ y) - (map (flip attrName n) elems) - - in makeRule (_LHS,n) - (Expression noPos expr) - ("use rule " ++ pos) - - - - -selfRule lhsNecLoc attr x - = let expr | lhsNecLoc = locName attr - | otherwise = x - - in makeRule (if lhsNecLoc then _LHS else _LOC,attr) - (Expression noPos expr) - "self rule" - - - - -concatRE rsess = let (rss,ess) = unzip rsess - in (concat rss, concatSeq ess) - - -copyRule :: Name -> Name -> Bool -> Set Name -> (Map Name Name, (Name,[Name])) -> ([Rule], Seq Error) -copyRule nt con modcopy locals (env,(fld,as)) - = concatRE (map copyRu as) - - where - copyRu a - = ( [ makeRule (fld,a) - (Expression noPos expr) - (cruletxt sel) - ] - , err - ) - - where - sel - | not modcopy - && Set.member a locals = Just _LOC - | otherwise = Map.lookup a env - - (expr,err) - = case sel of - Nothing -> ( missingRuleErrorExpr nt con fld a - , Seq.single (MissingRule nt con fld a) - ) - Just f - | f == _ACHILD -> ( fieldName a - , Seq.single (deprecatedCopyRuleError nt con fld a) - ) - | otherwise -> ( attrName f a - , Seq.empty - ) - - cruletxt sel - | local = "copy rule (from local)" - | deprChild = "deprecated child copy" - | Set.member a locals && nonlocal = "modified copy rule" - | incoming && outgoing = "copy rule (chain)" - | incoming = "copy rule (down)" - | outgoing = "copy rule (up)" - | otherwise = "copy rule (chain)" - where outgoing = fld == _LHS - incoming = maybe False (== _LHS) sel - nonlocal = maybe False (/= _LOC) sel - local = maybe False (== _LOC) sel - deprChild = maybe False (== _ACHILD) sel - -{- -multiRule replaces - loc.(a,b) = e -by - loc.tup1 = e - loc.(a,_) = @loc.tup1 - loc.(_,b) = @loc.tup1 -It needs to thread a unique number for inventing names for the tuples. - -It also works for nested tuples: - loc.(a,(b,c)) = e -becomes - loc.tup1 = e - loc.(a,_) = @loc.tup1 - loc.(_,tup2) = @loc.tup1 - loc.(b,_) = @loc.tup2 - loc.(_,c) = @loc.tup2 --} - -multiRule :: Rule -> Int -> ([Rule], Int) -multiRule (Rule pat expr owrt origin) uniq - = let f :: (Pattern->Pattern) -> Expression -> Pattern -> Int -> (Pattern, ([Rule], Int)) - f w e (Product pos pats) n - = let freshName = Ident ("_tup" ++ show n) pos - freshExpr = Expression pos (attrName _LOC freshName) - freshPat = Alias _LOC freshName (Underscore pos) pats - a = length pats - 1 - us b p = Product pos (replicate (a-b) (Underscore pos) ++ [p] ++ replicate b (Underscore pos)) - g :: Pattern -> ([Pattern],[Rule],Int) -> ([Pattern],[Rule],Int) - g p (xs1,rs1,n1) = let (x2,(rs2,n2)) = f (us (length xs1)) freshExpr p n1 - in (x2:xs1, rs2++rs1, n2) - (xs9,rs9,n9) = foldr g ([], [], n+1) pats - in ( freshPat - , ( Rule (w freshPat) e owrt origin : rs9 - , n9 - ) - ) - f w e p n - = ( p - , ( [Rule (w p) e owrt origin] - , n - ) - ) - in snd (f id expr pat uniq) - - -isDefined :: Map Name Attributes -> Identifier -> Identifier -> Bool -isDefined mp fld nm - = Map.member nm $ Map.findWithDefault Map.empty fld mp - --- check that for a dependency a < b, that a is an In attribute -isInAttribute :: [(Name,Attributes)] -> Identifier -> Identifier -> Bool -isInAttribute allSyns fld nm - | fld == _INST || fld == _LOC || fld == _LHS - = True - | otherwise -- is nm it a synthesized attribute of fld? - = maybe False (Map.member nm) (lookup fld allSyns) --- Alternative ------------------------------------------------- -{- - visit 0: - inherited attributes: - cr : Bool - inh : Attributes - manualAttrOrderMap : AttrOrderMap - nonterminals : Set Nonterminal - nt : Nonterminal - o_rename : Bool - syn : Attributes - typeSyns : TypeSyns - useMap : Map Name (String,String,String) - chained attribute: - uniq : Int - synthesized attributes: - errors : Seq Error - output : SELF - alternatives: - alternative Alternative: - child con : {Constructor} - child children : Children - child rules : Rules - child typeSigs : TypeSigs - visit 0: - local _tup1 : _ - local newRls : _ - local errs : _ - local orderDeps : _ - local allAttrsInScope : _ - local invalidOrderDepsErrors : _ - local undefinedAttributeInDepsErrors : _ - local orderErrs : _ - local output : _ --} --- cata -sem_Alternative :: Alternative -> - T_Alternative -sem_Alternative (Alternative _con _children _rules _typeSigs ) = - (sem_Alternative_Alternative _con (sem_Children _children ) (sem_Rules _rules ) (sem_TypeSigs _typeSigs ) ) --- semantic domain -newtype T_Alternative = T_Alternative (Bool -> - Attributes -> - AttrOrderMap -> - (Set Nonterminal) -> - Nonterminal -> - Bool -> - Attributes -> - TypeSyns -> - Int -> - (Map Name (String,String,String)) -> - ( (Seq Error),Alternative,Int)) -data Inh_Alternative = Inh_Alternative {cr_Inh_Alternative :: Bool,inh_Inh_Alternative :: Attributes,manualAttrOrderMap_Inh_Alternative :: AttrOrderMap,nonterminals_Inh_Alternative :: Set Nonterminal,nt_Inh_Alternative :: Nonterminal,o_rename_Inh_Alternative :: Bool,syn_Inh_Alternative :: Attributes,typeSyns_Inh_Alternative :: TypeSyns,uniq_Inh_Alternative :: Int,useMap_Inh_Alternative :: Map Name (String,String,String)} -data Syn_Alternative = Syn_Alternative {errors_Syn_Alternative :: Seq Error,output_Syn_Alternative :: Alternative,uniq_Syn_Alternative :: Int} -wrap_Alternative (T_Alternative sem ) (Inh_Alternative _lhsIcr _lhsIinh _lhsImanualAttrOrderMap _lhsInonterminals _lhsInt _lhsIo_rename _lhsIsyn _lhsItypeSyns _lhsIuniq _lhsIuseMap ) = - (let ( _lhsOerrors,_lhsOoutput,_lhsOuniq) = - (sem _lhsIcr _lhsIinh _lhsImanualAttrOrderMap _lhsInonterminals _lhsInt _lhsIo_rename _lhsIsyn _lhsItypeSyns _lhsIuniq _lhsIuseMap ) - in (Syn_Alternative _lhsOerrors _lhsOoutput _lhsOuniq )) -sem_Alternative_Alternative :: Constructor -> - T_Children -> - T_Rules -> - T_TypeSigs -> - T_Alternative -sem_Alternative_Alternative con_ (T_Children children_ ) (T_Rules rules_ ) (T_TypeSigs typeSigs_ ) = - (T_Alternative (\ _lhsIcr - _lhsIinh - _lhsImanualAttrOrderMap - _lhsInonterminals - _lhsInt - _lhsIo_rename - _lhsIsyn - _lhsItypeSyns - _lhsIuniq - _lhsIuseMap -> - (let _rulesOcon :: Constructor - _childrenOcon :: Constructor - _lhsOerrors :: (Seq Error) - _lhsOoutput :: Alternative - _lhsOuniq :: Int - _childrenOcr :: Bool - _childrenOnt :: Nonterminal - _rulesOnt :: Nonterminal - _rulesOuniq :: Int - _childrenIerrors :: (Seq Error) - _childrenIfields :: ([(Name,Type,Bool)]) - _childrenIinputs :: ([(Name, Attributes)]) - _childrenIoutput :: Children - _childrenIoutputs :: ([(Name, Attributes)]) - _rulesIdefinedAttrs :: (Set (Name,Name)) - _rulesIerrors :: (Seq Error) - _rulesIlocals :: (Set Name) - _rulesIoutput :: Rules - _rulesIuniq :: Int - _typeSigsIoutput :: TypeSigs - -- "DefaultRules.ag"(line 135, column 17) - _rulesOcon = - con_ - -- "DefaultRules.ag"(line 136, column 17) - _childrenOcon = - con_ - -- "DefaultRules.ag"(line 295, column 4) - _lhsOerrors = - _childrenIerrors <> _errs <> _rulesIerrors <> _orderErrs - -- "DefaultRules.ag"(line 297, column 8) - __tup1 = - let locals = _rulesIlocals - initenv = Map.fromList ( [ (a,_ACHILD) - | (a,_,_) <- _childrenIfields - ] - ++ attrs(_LHS, _lhsIinh) - ++ [ (a,_LOC) - | a <- Set.toList locals - ] - ) - attrs (n,as) = [ (a,n) | a <- Map.keys as ] - envs = scanl (flip Map.union) - initenv - (map (Map.fromList . attrs ) _childrenIoutputs) - child_envs = init envs - lhs_env = last envs - (selfAttrs, normalAttrs) - = Map.partition (==NT _SELF) _lhsIsyn - (_,undefAttrs) - = removeDefined _rulesIdefinedAttrs (_LHS, normalAttrs) - (useAttrs,others) - = splitAttrs _lhsIuseMap undefAttrs - (rules1, errors1) - = concatRE $ map (copyRule _lhsInt con_ _lhsIcr locals) - (zip envs (map (removeDefined _rulesIdefinedAttrs) _childrenIinputs)) - uRules - = map (useRule locals _childrenIoutputs) useAttrs - selfLocRules - = [ selfRule False attr (constructor [childSelf attr nm tp | (nm,tp,ho) <- _childrenIfields, not ho]) - | attr <- Map.keys selfAttrs - , not (Set.member attr locals) - ] - where - childSelf self nm tp - = case tp of NT nt -> attrName nm self - _ | nm `Set.member` locals -> locname nm - | otherwise -> fieldName nm - constructor fs - | getName con_ == "Tuple" && _lhsInt `elem` map fst _lhsItypeSyns - = "(" ++ concat (List.intersperse "," fs) ++ ")" - | otherwise - = getConName _lhsItypeSyns _lhsIo_rename _lhsInt con_ ++ " " ++ unwords fs - selfRules - = [ selfRule True attr undefined - | attr <- Map.keys selfAttrs - , not (Set.member (_LHS,attr) _rulesIdefinedAttrs) - ] - (rules5, errs5) - = copyRule _lhsInt - con_ - _lhsIcr - locals - (lhs_env, (_LHS, others)) - in (uRules++selfLocRules++selfRules++rules5++rules1, errors1<>errs5) - -- "DefaultRules.ag"(line 297, column 8) - (_newRls,_) = - __tup1 - -- "DefaultRules.ag"(line 297, column 8) - (_,_errs) = - __tup1 - -- "DefaultRules.ag"(line 413, column 17) - _lhsOoutput = - Alternative con_ _childrenIoutput (_rulesIoutput ++ _newRls) _typeSigsIoutput - -- "DefaultRules.ag"(line 484, column 7) - _orderDeps = - Set.toList $ Map.findWithDefault Set.empty con_ $ Map.findWithDefault Map.empty _lhsInt _lhsImanualAttrOrderMap - -- "DefaultRules.ag"(line 486, column 7) - _allAttrsInScope = - Map.fromList ( [ (_LHS, _lhsIsyn `Map.union` _lhsIinh) - , (_LOC, Map.fromList [ (l,Haskell "LOC") | l <- Set.toList _rulesIlocals]) ] - ++ _childrenIinputs - ++ _childrenIoutputs - ) - -- "DefaultRules.ag"(line 493, column 7) - _invalidOrderDepsErrors = - [ ErroneousOrder _lhsInt con_ dep - | dep@(Dependency (fld,nm) _) <- _orderDeps - , not $ isInAttribute _childrenIoutputs fld nm - ] - -- "DefaultRules.ag"(line 499, column 7) - _undefinedAttributeInDepsErrors = - [ UndefAttr _lhsInt con_ fld nm - | (fld,nm) <- concatMap (\(Dependency a b) -> [a,b]) $ _orderDeps - , not $ isDefined _allAttrsInScope fld nm - ] - -- "DefaultRules.ag"(line 505, column 7) - _orderErrs = - if null _undefinedAttributeInDepsErrors - then Seq.fromList _invalidOrderDepsErrors - else Seq.fromList _undefinedAttributeInDepsErrors - -- self rule - _output = - Alternative con_ _childrenIoutput _rulesIoutput _typeSigsIoutput - -- copy rule (up) - _lhsOuniq = - _rulesIuniq - -- copy rule (down) - _childrenOcr = - _lhsIcr - -- copy rule (down) - _childrenOnt = - _lhsInt - -- copy rule (down) - _rulesOnt = - _lhsInt - -- copy rule (down) - _rulesOuniq = - _lhsIuniq - ( _childrenIerrors,_childrenIfields,_childrenIinputs,_childrenIoutput,_childrenIoutputs) = - (children_ _childrenOcon _childrenOcr _childrenOnt ) - ( _rulesIdefinedAttrs,_rulesIerrors,_rulesIlocals,_rulesIoutput,_rulesIuniq) = - (rules_ _rulesOcon _rulesOnt _rulesOuniq ) - ( _typeSigsIoutput) = - (typeSigs_ ) - in ( _lhsOerrors,_lhsOoutput,_lhsOuniq))) ) --- Alternatives ------------------------------------------------ -{- - visit 0: - inherited attributes: - cr : Bool - inh : Attributes - manualAttrOrderMap : AttrOrderMap - nonterminals : Set Nonterminal - nt : Nonterminal - o_rename : Bool - syn : Attributes - typeSyns : TypeSyns - useMap : Map Name (String,String,String) - chained attribute: - uniq : Int - synthesized attributes: - errors : Seq Error - output : SELF - alternatives: - alternative Cons: - child hd : Alternative - child tl : Alternatives - visit 0: - local output : _ - alternative Nil: - visit 0: - local output : _ --} --- cata -sem_Alternatives :: Alternatives -> - T_Alternatives -sem_Alternatives list = - (Prelude.foldr sem_Alternatives_Cons sem_Alternatives_Nil (Prelude.map sem_Alternative list) ) --- semantic domain -newtype T_Alternatives = T_Alternatives (Bool -> - Attributes -> - AttrOrderMap -> - (Set Nonterminal) -> - Nonterminal -> - Bool -> - Attributes -> - TypeSyns -> - Int -> - (Map Name (String,String,String)) -> - ( (Seq Error),Alternatives,Int)) -data Inh_Alternatives = Inh_Alternatives {cr_Inh_Alternatives :: Bool,inh_Inh_Alternatives :: Attributes,manualAttrOrderMap_Inh_Alternatives :: AttrOrderMap,nonterminals_Inh_Alternatives :: Set Nonterminal,nt_Inh_Alternatives :: Nonterminal,o_rename_Inh_Alternatives :: Bool,syn_Inh_Alternatives :: Attributes,typeSyns_Inh_Alternatives :: TypeSyns,uniq_Inh_Alternatives :: Int,useMap_Inh_Alternatives :: Map Name (String,String,String)} -data Syn_Alternatives = Syn_Alternatives {errors_Syn_Alternatives :: Seq Error,output_Syn_Alternatives :: Alternatives,uniq_Syn_Alternatives :: Int} -wrap_Alternatives (T_Alternatives sem ) (Inh_Alternatives _lhsIcr _lhsIinh _lhsImanualAttrOrderMap _lhsInonterminals _lhsInt _lhsIo_rename _lhsIsyn _lhsItypeSyns _lhsIuniq _lhsIuseMap ) = - (let ( _lhsOerrors,_lhsOoutput,_lhsOuniq) = - (sem _lhsIcr _lhsIinh _lhsImanualAttrOrderMap _lhsInonterminals _lhsInt _lhsIo_rename _lhsIsyn _lhsItypeSyns _lhsIuniq _lhsIuseMap ) - in (Syn_Alternatives _lhsOerrors _lhsOoutput _lhsOuniq )) -sem_Alternatives_Cons :: T_Alternative -> - T_Alternatives -> - T_Alternatives -sem_Alternatives_Cons (T_Alternative hd_ ) (T_Alternatives tl_ ) = - (T_Alternatives (\ _lhsIcr - _lhsIinh - _lhsImanualAttrOrderMap - _lhsInonterminals - _lhsInt - _lhsIo_rename - _lhsIsyn - _lhsItypeSyns - _lhsIuniq - _lhsIuseMap -> - (let _lhsOerrors :: (Seq Error) - _lhsOoutput :: Alternatives - _lhsOuniq :: Int - _hdOcr :: Bool - _hdOinh :: Attributes - _hdOmanualAttrOrderMap :: AttrOrderMap - _hdOnonterminals :: (Set Nonterminal) - _hdOnt :: Nonterminal - _hdOo_rename :: Bool - _hdOsyn :: Attributes - _hdOtypeSyns :: TypeSyns - _hdOuniq :: Int - _hdOuseMap :: (Map Name (String,String,String)) - _tlOcr :: Bool - _tlOinh :: Attributes - _tlOmanualAttrOrderMap :: AttrOrderMap - _tlOnonterminals :: (Set Nonterminal) - _tlOnt :: Nonterminal - _tlOo_rename :: Bool - _tlOsyn :: Attributes - _tlOtypeSyns :: TypeSyns - _tlOuniq :: Int - _tlOuseMap :: (Map Name (String,String,String)) - _hdIerrors :: (Seq Error) - _hdIoutput :: Alternative - _hdIuniq :: Int - _tlIerrors :: (Seq Error) - _tlIoutput :: Alternatives - _tlIuniq :: Int - -- use rule "DefaultRules.ag"(line 107, column 19) - _lhsOerrors = - _hdIerrors Seq.<> _tlIerrors - -- self rule - _output = - (:) _hdIoutput _tlIoutput - -- self rule - _lhsOoutput = - _output - -- copy rule (up) - _lhsOuniq = - _tlIuniq - -- copy rule (down) - _hdOcr = - _lhsIcr - -- copy rule (down) - _hdOinh = - _lhsIinh - -- copy rule (down) - _hdOmanualAttrOrderMap = - _lhsImanualAttrOrderMap - -- copy rule (down) - _hdOnonterminals = - _lhsInonterminals - -- copy rule (down) - _hdOnt = - _lhsInt - -- copy rule (down) - _hdOo_rename = - _lhsIo_rename - -- copy rule (down) - _hdOsyn = - _lhsIsyn - -- copy rule (down) - _hdOtypeSyns = - _lhsItypeSyns - -- copy rule (down) - _hdOuniq = - _lhsIuniq - -- copy rule (down) - _hdOuseMap = - _lhsIuseMap - -- copy rule (down) - _tlOcr = - _lhsIcr - -- copy rule (down) - _tlOinh = - _lhsIinh - -- copy rule (down) - _tlOmanualAttrOrderMap = - _lhsImanualAttrOrderMap - -- copy rule (down) - _tlOnonterminals = - _lhsInonterminals - -- copy rule (down) - _tlOnt = - _lhsInt - -- copy rule (down) - _tlOo_rename = - _lhsIo_rename - -- copy rule (down) - _tlOsyn = - _lhsIsyn - -- copy rule (down) - _tlOtypeSyns = - _lhsItypeSyns - -- copy rule (chain) - _tlOuniq = - _hdIuniq - -- copy rule (down) - _tlOuseMap = - _lhsIuseMap - ( _hdIerrors,_hdIoutput,_hdIuniq) = - (hd_ _hdOcr _hdOinh _hdOmanualAttrOrderMap _hdOnonterminals _hdOnt _hdOo_rename _hdOsyn _hdOtypeSyns _hdOuniq _hdOuseMap ) - ( _tlIerrors,_tlIoutput,_tlIuniq) = - (tl_ _tlOcr _tlOinh _tlOmanualAttrOrderMap _tlOnonterminals _tlOnt _tlOo_rename _tlOsyn _tlOtypeSyns _tlOuniq _tlOuseMap ) - in ( _lhsOerrors,_lhsOoutput,_lhsOuniq))) ) -sem_Alternatives_Nil :: T_Alternatives -sem_Alternatives_Nil = - (T_Alternatives (\ _lhsIcr - _lhsIinh - _lhsImanualAttrOrderMap - _lhsInonterminals - _lhsInt - _lhsIo_rename - _lhsIsyn - _lhsItypeSyns - _lhsIuniq - _lhsIuseMap -> - (let _lhsOerrors :: (Seq Error) - _lhsOoutput :: Alternatives - _lhsOuniq :: Int - -- use rule "DefaultRules.ag"(line 107, column 19) - _lhsOerrors = - Seq.empty - -- self rule - _output = - [] - -- self rule - _lhsOoutput = - _output - -- copy rule (chain) - _lhsOuniq = - _lhsIuniq - in ( _lhsOerrors,_lhsOoutput,_lhsOuniq))) ) --- Child ------------------------------------------------------- -{- - visit 0: - inherited attributes: - con : Constructor - cr : Bool - nt : Nonterminal - synthesized attributes: - errors : Seq Error - field : (Name,Type,Bool) - inherited : Attributes - name : Name - output : SELF - synthesized : Attributes - alternatives: - alternative Child: - child name : {Name} - child tp : {Type} - child inh : {Attributes} - child syn : {Attributes} - child higherOrder : {Bool} - visit 0: - local output : _ --} --- cata -sem_Child :: Child -> - T_Child -sem_Child (Child _name _tp _inh _syn _higherOrder ) = - (sem_Child_Child _name _tp _inh _syn _higherOrder ) --- semantic domain -newtype T_Child = T_Child (Constructor -> - Bool -> - Nonterminal -> - ( (Seq Error),( (Name,Type,Bool) ),Attributes,Name,Child,Attributes)) -data Inh_Child = Inh_Child {con_Inh_Child :: Constructor,cr_Inh_Child :: Bool,nt_Inh_Child :: Nonterminal} -data Syn_Child = Syn_Child {errors_Syn_Child :: Seq Error,field_Syn_Child :: (Name,Type,Bool) ,inherited_Syn_Child :: Attributes,name_Syn_Child :: Name,output_Syn_Child :: Child,synthesized_Syn_Child :: Attributes} -wrap_Child (T_Child sem ) (Inh_Child _lhsIcon _lhsIcr _lhsInt ) = - (let ( _lhsOerrors,_lhsOfield,_lhsOinherited,_lhsOname,_lhsOoutput,_lhsOsynthesized) = - (sem _lhsIcon _lhsIcr _lhsInt ) - in (Syn_Child _lhsOerrors _lhsOfield _lhsOinherited _lhsOname _lhsOoutput _lhsOsynthesized )) -sem_Child_Child :: Name -> - Type -> - Attributes -> - Attributes -> - Bool -> - T_Child -sem_Child_Child name_ tp_ inh_ syn_ higherOrder_ = - (T_Child (\ _lhsIcon - _lhsIcr - _lhsInt -> - (let _lhsOname :: Name - _lhsOinherited :: Attributes - _lhsOsynthesized :: Attributes - _lhsOfield :: ( (Name,Type,Bool) ) - _lhsOerrors :: (Seq Error) - _lhsOoutput :: Child - -- "DefaultRules.ag"(line 138, column 11) - _lhsOname = - name_ - -- "DefaultRules.ag"(line 147, column 11) - _lhsOinherited = - inh_ - -- "DefaultRules.ag"(line 148, column 11) - _lhsOsynthesized = - syn_ - -- "DefaultRules.ag"(line 386, column 11) - _lhsOfield = - (name_,tp_,higherOrder_) - -- use rule "DefaultRules.ag"(line 107, column 19) - _lhsOerrors = - Seq.empty - -- self rule - _output = - Child name_ tp_ inh_ syn_ higherOrder_ - -- self rule - _lhsOoutput = - _output - in ( _lhsOerrors,_lhsOfield,_lhsOinherited,_lhsOname,_lhsOoutput,_lhsOsynthesized))) ) --- Children ---------------------------------------------------- -{- - visit 0: - inherited attributes: - con : Constructor - cr : Bool - nt : Nonterminal - synthesized attributes: - errors : Seq Error - fields : [(Name,Type,Bool)] - inputs : [(Name, Attributes)] - output : SELF - outputs : [(Name, Attributes)] - alternatives: - alternative Cons: - child hd : Child - child tl : Children - visit 0: - local output : _ - alternative Nil: - visit 0: - local output : _ --} --- cata -sem_Children :: Children -> - T_Children -sem_Children list = - (Prelude.foldr sem_Children_Cons sem_Children_Nil (Prelude.map sem_Child list) ) --- semantic domain -newtype T_Children = T_Children (Constructor -> - Bool -> - Nonterminal -> - ( (Seq Error),([(Name,Type,Bool)]),([(Name, Attributes)]),Children,([(Name, Attributes)]))) -data Inh_Children = Inh_Children {con_Inh_Children :: Constructor,cr_Inh_Children :: Bool,nt_Inh_Children :: Nonterminal} -data Syn_Children = Syn_Children {errors_Syn_Children :: Seq Error,fields_Syn_Children :: [(Name,Type,Bool)],inputs_Syn_Children :: [(Name, Attributes)],output_Syn_Children :: Children,outputs_Syn_Children :: [(Name, Attributes)]} -wrap_Children (T_Children sem ) (Inh_Children _lhsIcon _lhsIcr _lhsInt ) = - (let ( _lhsOerrors,_lhsOfields,_lhsOinputs,_lhsOoutput,_lhsOoutputs) = - (sem _lhsIcon _lhsIcr _lhsInt ) - in (Syn_Children _lhsOerrors _lhsOfields _lhsOinputs _lhsOoutput _lhsOoutputs )) -sem_Children_Cons :: T_Child -> - T_Children -> - T_Children -sem_Children_Cons (T_Child hd_ ) (T_Children tl_ ) = - (T_Children (\ _lhsIcon - _lhsIcr - _lhsInt -> - (let _lhsOinputs :: ([(Name, Attributes)]) - _lhsOoutputs :: ([(Name, Attributes)]) - _lhsOfields :: ([(Name,Type,Bool)]) - _lhsOerrors :: (Seq Error) - _lhsOoutput :: Children - _hdOcon :: Constructor - _hdOcr :: Bool - _hdOnt :: Nonterminal - _tlOcon :: Constructor - _tlOcr :: Bool - _tlOnt :: Nonterminal - _hdIerrors :: (Seq Error) - _hdIfield :: ( (Name,Type,Bool) ) - _hdIinherited :: Attributes - _hdIname :: Name - _hdIoutput :: Child - _hdIsynthesized :: Attributes - _tlIerrors :: (Seq Error) - _tlIfields :: ([(Name,Type,Bool)]) - _tlIinputs :: ([(Name, Attributes)]) - _tlIoutput :: Children - _tlIoutputs :: ([(Name, Attributes)]) - -- "DefaultRules.ag"(line 151, column 10) - _lhsOinputs = - (_hdIname, _hdIinherited) : _tlIinputs - -- "DefaultRules.ag"(line 151, column 10) - _lhsOoutputs = - (_hdIname, _hdIsynthesized) : _tlIoutputs - -- "DefaultRules.ag"(line 382, column 10) - _lhsOfields = - _hdIfield : _tlIfields - -- use rule "DefaultRules.ag"(line 107, column 19) - _lhsOerrors = - _hdIerrors Seq.<> _tlIerrors - -- self rule - _output = - (:) _hdIoutput _tlIoutput - -- self rule - _lhsOoutput = - _output - -- copy rule (down) - _hdOcon = - _lhsIcon - -- copy rule (down) - _hdOcr = - _lhsIcr - -- copy rule (down) - _hdOnt = - _lhsInt - -- copy rule (down) - _tlOcon = - _lhsIcon - -- copy rule (down) - _tlOcr = - _lhsIcr - -- copy rule (down) - _tlOnt = - _lhsInt - ( _hdIerrors,_hdIfield,_hdIinherited,_hdIname,_hdIoutput,_hdIsynthesized) = - (hd_ _hdOcon _hdOcr _hdOnt ) - ( _tlIerrors,_tlIfields,_tlIinputs,_tlIoutput,_tlIoutputs) = - (tl_ _tlOcon _tlOcr _tlOnt ) - in ( _lhsOerrors,_lhsOfields,_lhsOinputs,_lhsOoutput,_lhsOoutputs))) ) -sem_Children_Nil :: T_Children -sem_Children_Nil = - (T_Children (\ _lhsIcon - _lhsIcr - _lhsInt -> - (let _lhsOinputs :: ([(Name, Attributes)]) - _lhsOoutputs :: ([(Name, Attributes)]) - _lhsOfields :: ([(Name,Type,Bool)]) - _lhsOerrors :: (Seq Error) - _lhsOoutput :: Children - -- "DefaultRules.ag"(line 153, column 10) - _lhsOinputs = - [] - -- "DefaultRules.ag"(line 153, column 10) - _lhsOoutputs = - [] - -- "DefaultRules.ag"(line 383, column 10) - _lhsOfields = - [] - -- use rule "DefaultRules.ag"(line 107, column 19) - _lhsOerrors = - Seq.empty - -- self rule - _output = - [] - -- self rule - _lhsOoutput = - _output - in ( _lhsOerrors,_lhsOfields,_lhsOinputs,_lhsOoutput,_lhsOoutputs))) ) --- Grammar ----------------------------------------------------- -{- - visit 0: - inherited attribute: - options : Options - synthesized attributes: - errors : Seq Error - output : SELF - alternatives: - alternative Grammar: - child typeSyns : {TypeSyns} - child useMap : {UseMap} - child derivings : {Derivings} - child wrappers : {Set Nonterminal} - child prods : Productions - child pragmas : {PragmaMap} - child manualAttrOrderMap : {AttrOrderMap} - visit 0: - local output : _ --} --- cata -sem_Grammar :: Grammar -> - T_Grammar -sem_Grammar (Grammar _typeSyns _useMap _derivings _wrappers _prods _pragmas _manualAttrOrderMap ) = - (sem_Grammar_Grammar _typeSyns _useMap _derivings _wrappers (sem_Productions _prods ) _pragmas _manualAttrOrderMap ) --- semantic domain -newtype T_Grammar = T_Grammar (Options -> - ( (Seq Error),Grammar)) -data Inh_Grammar = Inh_Grammar {options_Inh_Grammar :: Options} -data Syn_Grammar = Syn_Grammar {errors_Syn_Grammar :: Seq Error,output_Syn_Grammar :: Grammar} -wrap_Grammar (T_Grammar sem ) (Inh_Grammar _lhsIoptions ) = - (let ( _lhsOerrors,_lhsOoutput) = - (sem _lhsIoptions ) - in (Syn_Grammar _lhsOerrors _lhsOoutput )) -sem_Grammar_Grammar :: TypeSyns -> - UseMap -> - Derivings -> - (Set Nonterminal) -> - T_Productions -> - PragmaMap -> - AttrOrderMap -> - T_Grammar -sem_Grammar_Grammar typeSyns_ useMap_ derivings_ wrappers_ (T_Productions prods_ ) pragmas_ manualAttrOrderMap_ = - (T_Grammar (\ _lhsIoptions -> - (let _prodsOo_rename :: Bool - _prodsOcr :: Bool - _prodsOnonterminals :: (Set Nonterminal) - _prodsOuseMap :: UseMap - _prodsOtypeSyns :: TypeSyns - _prodsOuniq :: Int - _prodsOmanualAttrOrderMap :: AttrOrderMap - _lhsOerrors :: (Seq Error) - _lhsOoutput :: Grammar - _prodsIcollect_nts :: (Set Nonterminal) - _prodsIerrors :: (Seq Error) - _prodsIoutput :: Productions - _prodsIuniq :: Int - -- "DefaultRules.ag"(line 41, column 17) - _prodsOo_rename = - rename _lhsIoptions - -- "DefaultRules.ag"(line 42, column 17) - _prodsOcr = - modcopy _lhsIoptions - -- "DefaultRules.ag"(line 119, column 13) - _prodsOnonterminals = - _prodsIcollect_nts - -- "DefaultRules.ag"(line 140, column 13) - _prodsOuseMap = - useMap_ - -- "DefaultRules.ag"(line 142, column 13) - _prodsOtypeSyns = - typeSyns_ - -- "DefaultRules.ag"(line 403, column 13) - _prodsOuniq = - 1 - -- "DefaultRules.ag"(line 479, column 7) - _prodsOmanualAttrOrderMap = - manualAttrOrderMap_ - -- use rule "DefaultRules.ag"(line 107, column 19) - _lhsOerrors = - _prodsIerrors - -- self rule - _output = - Grammar typeSyns_ useMap_ derivings_ wrappers_ _prodsIoutput pragmas_ manualAttrOrderMap_ - -- self rule - _lhsOoutput = - _output - ( _prodsIcollect_nts,_prodsIerrors,_prodsIoutput,_prodsIuniq) = - (prods_ _prodsOcr _prodsOmanualAttrOrderMap _prodsOnonterminals _prodsOo_rename _prodsOtypeSyns _prodsOuniq _prodsOuseMap ) - in ( _lhsOerrors,_lhsOoutput))) ) --- Pattern ----------------------------------------------------- -{- - visit 0: - inherited attributes: - con : Constructor - nt : Nonterminal - synthesized attributes: - containsVars : Bool - copy : SELF - definedAttrs : Set (Name,Name) - errors : Seq Error - locals : Set Name - output : SELF - alternatives: - alternative Alias: - child field : {Name} - child attr : {Name} - child pat : Pattern - child parts : Patterns - visit 0: - local copy : _ - local output : _ - alternative Constr: - child name : {Constructor} - child pats : Patterns - visit 0: - local copy : _ - local output : _ - alternative Product: - child pos : {Pos} - child pats : Patterns - visit 0: - local copy : _ - local output : _ - alternative Underscore: - child pos : {Pos} - visit 0: - local copy : _ - local output : _ --} --- cata -sem_Pattern :: Pattern -> - T_Pattern -sem_Pattern (Alias _field _attr _pat _parts ) = - (sem_Pattern_Alias _field _attr (sem_Pattern _pat ) (sem_Patterns _parts ) ) -sem_Pattern (Constr _name _pats ) = - (sem_Pattern_Constr _name (sem_Patterns _pats ) ) -sem_Pattern (Product _pos _pats ) = - (sem_Pattern_Product _pos (sem_Patterns _pats ) ) -sem_Pattern (Underscore _pos ) = - (sem_Pattern_Underscore _pos ) --- semantic domain -newtype T_Pattern = T_Pattern (Constructor -> - Nonterminal -> - ( Bool,Pattern,(Set (Name,Name)),(Seq Error),(Set Name),Pattern)) -data Inh_Pattern = Inh_Pattern {con_Inh_Pattern :: Constructor,nt_Inh_Pattern :: Nonterminal} -data Syn_Pattern = Syn_Pattern {containsVars_Syn_Pattern :: Bool,copy_Syn_Pattern :: Pattern,definedAttrs_Syn_Pattern :: Set (Name,Name),errors_Syn_Pattern :: Seq Error,locals_Syn_Pattern :: Set Name,output_Syn_Pattern :: Pattern} -wrap_Pattern (T_Pattern sem ) (Inh_Pattern _lhsIcon _lhsInt ) = - (let ( _lhsOcontainsVars,_lhsOcopy,_lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput) = - (sem _lhsIcon _lhsInt ) - in (Syn_Pattern _lhsOcontainsVars _lhsOcopy _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput )) -sem_Pattern_Alias :: Name -> - Name -> - T_Pattern -> - T_Patterns -> - T_Pattern -sem_Pattern_Alias field_ attr_ (T_Pattern pat_ ) (T_Patterns parts_ ) = - (T_Pattern (\ _lhsIcon - _lhsInt -> - (let _lhsOdefinedAttrs :: (Set (Name,Name)) - _lhsOlocals :: (Set Name) - _lhsOcontainsVars :: Bool - _lhsOerrors :: (Seq Error) - _lhsOcopy :: Pattern - _lhsOoutput :: Pattern - _patOcon :: Constructor - _patOnt :: Nonterminal - _partsOcon :: Constructor - _partsOnt :: Nonterminal - _patIcontainsVars :: Bool - _patIcopy :: Pattern - _patIdefinedAttrs :: (Set (Name,Name)) - _patIerrors :: (Seq Error) - _patIlocals :: (Set Name) - _patIoutput :: Pattern - _partsIcontainsVars :: Bool - _partsIcopy :: Patterns - _partsIdefinedAttrs :: (Set (Name,Name)) - _partsIerrors :: (Seq Error) - _partsIlocals :: (Set Name) - _partsIoutput :: Patterns - -- "DefaultRules.ag"(line 376, column 11) - _lhsOdefinedAttrs = - Set.insert (field_,attr_) _patIdefinedAttrs - -- "DefaultRules.ag"(line 376, column 11) - _lhsOlocals = - if field_ == _LOC - then Set.insert attr_ _patIlocals - else _patIlocals - -- "DefaultRules.ag"(line 394, column 16) - _lhsOcontainsVars = - True - -- use rule "DefaultRules.ag"(line 107, column 19) - _lhsOerrors = - _patIerrors Seq.<> _partsIerrors - -- self rule - _copy = - Alias field_ attr_ _patIcopy _partsIcopy - -- self rule - _output = - Alias field_ attr_ _patIoutput _partsIoutput - -- self rule - _lhsOcopy = - _copy - -- self rule - _lhsOoutput = - _output - -- copy rule (down) - _patOcon = - _lhsIcon - -- copy rule (down) - _patOnt = - _lhsInt - -- copy rule (down) - _partsOcon = - _lhsIcon - -- copy rule (down) - _partsOnt = - _lhsInt - ( _patIcontainsVars,_patIcopy,_patIdefinedAttrs,_patIerrors,_patIlocals,_patIoutput) = - (pat_ _patOcon _patOnt ) - ( _partsIcontainsVars,_partsIcopy,_partsIdefinedAttrs,_partsIerrors,_partsIlocals,_partsIoutput) = - (parts_ _partsOcon _partsOnt ) - in ( _lhsOcontainsVars,_lhsOcopy,_lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput))) ) -sem_Pattern_Constr :: Constructor -> - T_Patterns -> - T_Pattern -sem_Pattern_Constr name_ (T_Patterns pats_ ) = - (T_Pattern (\ _lhsIcon - _lhsInt -> - (let _lhsOcontainsVars :: Bool - _lhsOdefinedAttrs :: (Set (Name,Name)) - _lhsOerrors :: (Seq Error) - _lhsOlocals :: (Set Name) - _lhsOcopy :: Pattern - _lhsOoutput :: Pattern - _patsOcon :: Constructor - _patsOnt :: Nonterminal - _patsIcontainsVars :: Bool - _patsIcopy :: Patterns - _patsIdefinedAttrs :: (Set (Name,Name)) - _patsIerrors :: (Seq Error) - _patsIlocals :: (Set Name) - _patsIoutput :: Patterns - -- use rule "DefaultRules.ag"(line 391, column 46) - _lhsOcontainsVars = - _patsIcontainsVars - -- use rule "DefaultRules.ag"(line 371, column 23) - _lhsOdefinedAttrs = - _patsIdefinedAttrs - -- use rule "DefaultRules.ag"(line 107, column 19) - _lhsOerrors = - _patsIerrors - -- use rule "DefaultRules.ag"(line 370, column 23) - _lhsOlocals = - _patsIlocals - -- self rule - _copy = - Constr name_ _patsIcopy - -- self rule - _output = - Constr name_ _patsIoutput - -- self rule - _lhsOcopy = - _copy - -- self rule - _lhsOoutput = - _output - -- copy rule (down) - _patsOcon = - _lhsIcon - -- copy rule (down) - _patsOnt = - _lhsInt - ( _patsIcontainsVars,_patsIcopy,_patsIdefinedAttrs,_patsIerrors,_patsIlocals,_patsIoutput) = - (pats_ _patsOcon _patsOnt ) - in ( _lhsOcontainsVars,_lhsOcopy,_lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput))) ) -sem_Pattern_Product :: Pos -> - T_Patterns -> - T_Pattern -sem_Pattern_Product pos_ (T_Patterns pats_ ) = - (T_Pattern (\ _lhsIcon - _lhsInt -> - (let _lhsOcontainsVars :: Bool - _lhsOdefinedAttrs :: (Set (Name,Name)) - _lhsOerrors :: (Seq Error) - _lhsOlocals :: (Set Name) - _lhsOcopy :: Pattern - _lhsOoutput :: Pattern - _patsOcon :: Constructor - _patsOnt :: Nonterminal - _patsIcontainsVars :: Bool - _patsIcopy :: Patterns - _patsIdefinedAttrs :: (Set (Name,Name)) - _patsIerrors :: (Seq Error) - _patsIlocals :: (Set Name) - _patsIoutput :: Patterns - -- use rule "DefaultRules.ag"(line 391, column 46) - _lhsOcontainsVars = - _patsIcontainsVars - -- use rule "DefaultRules.ag"(line 371, column 23) - _lhsOdefinedAttrs = - _patsIdefinedAttrs - -- use rule "DefaultRules.ag"(line 107, column 19) - _lhsOerrors = - _patsIerrors - -- use rule "DefaultRules.ag"(line 370, column 23) - _lhsOlocals = - _patsIlocals - -- self rule - _copy = - Product pos_ _patsIcopy - -- self rule - _output = - Product pos_ _patsIoutput - -- self rule - _lhsOcopy = - _copy - -- self rule - _lhsOoutput = - _output - -- copy rule (down) - _patsOcon = - _lhsIcon - -- copy rule (down) - _patsOnt = - _lhsInt - ( _patsIcontainsVars,_patsIcopy,_patsIdefinedAttrs,_patsIerrors,_patsIlocals,_patsIoutput) = - (pats_ _patsOcon _patsOnt ) - in ( _lhsOcontainsVars,_lhsOcopy,_lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput))) ) -sem_Pattern_Underscore :: Pos -> - T_Pattern -sem_Pattern_Underscore pos_ = - (T_Pattern (\ _lhsIcon - _lhsInt -> - (let _lhsOcontainsVars :: Bool - _lhsOdefinedAttrs :: (Set (Name,Name)) - _lhsOerrors :: (Seq Error) - _lhsOlocals :: (Set Name) - _lhsOcopy :: Pattern - _lhsOoutput :: Pattern - -- use rule "DefaultRules.ag"(line 391, column 46) - _lhsOcontainsVars = - False - -- use rule "DefaultRules.ag"(line 371, column 23) - _lhsOdefinedAttrs = - Set.empty - -- use rule "DefaultRules.ag"(line 107, column 19) - _lhsOerrors = - Seq.empty - -- use rule "DefaultRules.ag"(line 370, column 23) - _lhsOlocals = - Set.empty - -- self rule - _copy = - Underscore pos_ - -- self rule - _output = - Underscore pos_ - -- self rule - _lhsOcopy = - _copy - -- self rule - _lhsOoutput = - _output - in ( _lhsOcontainsVars,_lhsOcopy,_lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput))) ) --- Patterns ---------------------------------------------------- -{- - visit 0: - inherited attributes: - con : Constructor - nt : Nonterminal - synthesized attributes: - containsVars : Bool - copy : SELF - definedAttrs : Set (Name,Name) - errors : Seq Error - locals : Set Name - output : SELF - alternatives: - alternative Cons: - child hd : Pattern - child tl : Patterns - visit 0: - local copy : _ - local output : _ - alternative Nil: - visit 0: - local copy : _ - local output : _ --} --- cata -sem_Patterns :: Patterns -> - T_Patterns -sem_Patterns list = - (Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list) ) --- semantic domain -newtype T_Patterns = T_Patterns (Constructor -> - Nonterminal -> - ( Bool,Patterns,(Set (Name,Name)),(Seq Error),(Set Name),Patterns)) -data Inh_Patterns = Inh_Patterns {con_Inh_Patterns :: Constructor,nt_Inh_Patterns :: Nonterminal} -data Syn_Patterns = Syn_Patterns {containsVars_Syn_Patterns :: Bool,copy_Syn_Patterns :: Patterns,definedAttrs_Syn_Patterns :: Set (Name,Name),errors_Syn_Patterns :: Seq Error,locals_Syn_Patterns :: Set Name,output_Syn_Patterns :: Patterns} -wrap_Patterns (T_Patterns sem ) (Inh_Patterns _lhsIcon _lhsInt ) = - (let ( _lhsOcontainsVars,_lhsOcopy,_lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput) = - (sem _lhsIcon _lhsInt ) - in (Syn_Patterns _lhsOcontainsVars _lhsOcopy _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput )) -sem_Patterns_Cons :: T_Pattern -> - T_Patterns -> - T_Patterns -sem_Patterns_Cons (T_Pattern hd_ ) (T_Patterns tl_ ) = - (T_Patterns (\ _lhsIcon - _lhsInt -> - (let _lhsOcontainsVars :: Bool - _lhsOdefinedAttrs :: (Set (Name,Name)) - _lhsOerrors :: (Seq Error) - _lhsOlocals :: (Set Name) - _lhsOcopy :: Patterns - _lhsOoutput :: Patterns - _hdOcon :: Constructor - _hdOnt :: Nonterminal - _tlOcon :: Constructor - _tlOnt :: Nonterminal - _hdIcontainsVars :: Bool - _hdIcopy :: Pattern - _hdIdefinedAttrs :: (Set (Name,Name)) - _hdIerrors :: (Seq Error) - _hdIlocals :: (Set Name) - _hdIoutput :: Pattern - _tlIcontainsVars :: Bool - _tlIcopy :: Patterns - _tlIdefinedAttrs :: (Set (Name,Name)) - _tlIerrors :: (Seq Error) - _tlIlocals :: (Set Name) - _tlIoutput :: Patterns - -- use rule "DefaultRules.ag"(line 391, column 46) - _lhsOcontainsVars = - _hdIcontainsVars || _tlIcontainsVars - -- use rule "DefaultRules.ag"(line 371, column 23) - _lhsOdefinedAttrs = - _hdIdefinedAttrs `Set.union` _tlIdefinedAttrs - -- use rule "DefaultRules.ag"(line 107, column 19) - _lhsOerrors = - _hdIerrors Seq.<> _tlIerrors - -- use rule "DefaultRules.ag"(line 370, column 23) - _lhsOlocals = - _hdIlocals `Set.union` _tlIlocals - -- self rule - _copy = - (:) _hdIcopy _tlIcopy - -- self rule - _output = - (:) _hdIoutput _tlIoutput - -- self rule - _lhsOcopy = - _copy - -- self rule - _lhsOoutput = - _output - -- copy rule (down) - _hdOcon = - _lhsIcon - -- copy rule (down) - _hdOnt = - _lhsInt - -- copy rule (down) - _tlOcon = - _lhsIcon - -- copy rule (down) - _tlOnt = - _lhsInt - ( _hdIcontainsVars,_hdIcopy,_hdIdefinedAttrs,_hdIerrors,_hdIlocals,_hdIoutput) = - (hd_ _hdOcon _hdOnt ) - ( _tlIcontainsVars,_tlIcopy,_tlIdefinedAttrs,_tlIerrors,_tlIlocals,_tlIoutput) = - (tl_ _tlOcon _tlOnt ) - in ( _lhsOcontainsVars,_lhsOcopy,_lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput))) ) -sem_Patterns_Nil :: T_Patterns -sem_Patterns_Nil = - (T_Patterns (\ _lhsIcon - _lhsInt -> - (let _lhsOcontainsVars :: Bool - _lhsOdefinedAttrs :: (Set (Name,Name)) - _lhsOerrors :: (Seq Error) - _lhsOlocals :: (Set Name) - _lhsOcopy :: Patterns - _lhsOoutput :: Patterns - -- use rule "DefaultRules.ag"(line 391, column 46) - _lhsOcontainsVars = - False - -- use rule "DefaultRules.ag"(line 371, column 23) - _lhsOdefinedAttrs = - Set.empty - -- use rule "DefaultRules.ag"(line 107, column 19) - _lhsOerrors = - Seq.empty - -- use rule "DefaultRules.ag"(line 370, column 23) - _lhsOlocals = - Set.empty - -- self rule - _copy = - [] - -- self rule - _output = - [] - -- self rule - _lhsOcopy = - _copy - -- self rule - _lhsOoutput = - _output - in ( _lhsOcontainsVars,_lhsOcopy,_lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput))) ) --- Production -------------------------------------------------- -{- - visit 0: - inherited attributes: - cr : Bool - manualAttrOrderMap : AttrOrderMap - nonterminals : Set Nonterminal - o_rename : Bool - typeSyns : TypeSyns - useMap : UseMap - chained attribute: - uniq : Int - synthesized attributes: - collect_nts : Set Nonterminal - errors : Seq Error - output : SELF - alternatives: - alternative Production: - child nt : {Nonterminal} - child inh : {Attributes} - child syn : {Attributes} - child alts : Alternatives - visit 0: - local output : _ --} --- cata -sem_Production :: Production -> - T_Production -sem_Production (Production _nt _inh _syn _alts ) = - (sem_Production_Production _nt _inh _syn (sem_Alternatives _alts ) ) --- semantic domain -newtype T_Production = T_Production (Bool -> - AttrOrderMap -> - (Set Nonterminal) -> - Bool -> - TypeSyns -> - Int -> - UseMap -> - ( (Set Nonterminal),(Seq Error),Production,Int)) -data Inh_Production = Inh_Production {cr_Inh_Production :: Bool,manualAttrOrderMap_Inh_Production :: AttrOrderMap,nonterminals_Inh_Production :: Set Nonterminal,o_rename_Inh_Production :: Bool,typeSyns_Inh_Production :: TypeSyns,uniq_Inh_Production :: Int,useMap_Inh_Production :: UseMap} -data Syn_Production = Syn_Production {collect_nts_Syn_Production :: Set Nonterminal,errors_Syn_Production :: Seq Error,output_Syn_Production :: Production,uniq_Syn_Production :: Int} -wrap_Production (T_Production sem ) (Inh_Production _lhsIcr _lhsImanualAttrOrderMap _lhsInonterminals _lhsIo_rename _lhsItypeSyns _lhsIuniq _lhsIuseMap ) = - (let ( _lhsOcollect_nts,_lhsOerrors,_lhsOoutput,_lhsOuniq) = - (sem _lhsIcr _lhsImanualAttrOrderMap _lhsInonterminals _lhsIo_rename _lhsItypeSyns _lhsIuniq _lhsIuseMap ) - in (Syn_Production _lhsOcollect_nts _lhsOerrors _lhsOoutput _lhsOuniq )) -sem_Production_Production :: Nonterminal -> - Attributes -> - Attributes -> - T_Alternatives -> - T_Production -sem_Production_Production nt_ inh_ syn_ (T_Alternatives alts_ ) = - (T_Production (\ _lhsIcr - _lhsImanualAttrOrderMap - _lhsInonterminals - _lhsIo_rename - _lhsItypeSyns - _lhsIuniq - _lhsIuseMap -> - (let _lhsOcollect_nts :: (Set Nonterminal) - _altsOinh :: Attributes - _altsOsyn :: Attributes - _altsOuseMap :: (Map Name (String,String,String)) - _altsOnt :: Nonterminal - _lhsOerrors :: (Seq Error) - _lhsOoutput :: Production - _lhsOuniq :: Int - _altsOcr :: Bool - _altsOmanualAttrOrderMap :: AttrOrderMap - _altsOnonterminals :: (Set Nonterminal) - _altsOo_rename :: Bool - _altsOtypeSyns :: TypeSyns - _altsOuniq :: Int - _altsIerrors :: (Seq Error) - _altsIoutput :: Alternatives - _altsIuniq :: Int - -- "DefaultRules.ag"(line 115, column 16) - _lhsOcollect_nts = - Set.singleton nt_ - -- "DefaultRules.ag"(line 130, column 17) - _altsOinh = - inh_ - -- "DefaultRules.ag"(line 131, column 17) - _altsOsyn = - syn_ - -- "DefaultRules.ag"(line 132, column 17) - _altsOuseMap = - Map.findWithDefault Map.empty nt_ _lhsIuseMap - -- "DefaultRules.ag"(line 144, column 16) - _altsOnt = - nt_ - -- use rule "DefaultRules.ag"(line 107, column 19) - _lhsOerrors = - _altsIerrors - -- self rule - _output = - Production nt_ inh_ syn_ _altsIoutput - -- self rule - _lhsOoutput = - _output - -- copy rule (up) - _lhsOuniq = - _altsIuniq - -- copy rule (down) - _altsOcr = - _lhsIcr - -- copy rule (down) - _altsOmanualAttrOrderMap = - _lhsImanualAttrOrderMap - -- copy rule (down) - _altsOnonterminals = - _lhsInonterminals - -- copy rule (down) - _altsOo_rename = - _lhsIo_rename - -- copy rule (down) - _altsOtypeSyns = - _lhsItypeSyns - -- copy rule (down) - _altsOuniq = - _lhsIuniq - ( _altsIerrors,_altsIoutput,_altsIuniq) = - (alts_ _altsOcr _altsOinh _altsOmanualAttrOrderMap _altsOnonterminals _altsOnt _altsOo_rename _altsOsyn _altsOtypeSyns _altsOuniq _altsOuseMap ) - in ( _lhsOcollect_nts,_lhsOerrors,_lhsOoutput,_lhsOuniq))) ) --- Productions ------------------------------------------------- -{- - visit 0: - inherited attributes: - cr : Bool - manualAttrOrderMap : AttrOrderMap - nonterminals : Set Nonterminal - o_rename : Bool - typeSyns : TypeSyns - useMap : UseMap - chained attribute: - uniq : Int - synthesized attributes: - collect_nts : Set Nonterminal - errors : Seq Error - output : SELF - alternatives: - alternative Cons: - child hd : Production - child tl : Productions - visit 0: - local output : _ - alternative Nil: - visit 0: - local output : _ --} --- cata -sem_Productions :: Productions -> - T_Productions -sem_Productions list = - (Prelude.foldr sem_Productions_Cons sem_Productions_Nil (Prelude.map sem_Production list) ) --- semantic domain -newtype T_Productions = T_Productions (Bool -> - AttrOrderMap -> - (Set Nonterminal) -> - Bool -> - TypeSyns -> - Int -> - UseMap -> - ( (Set Nonterminal),(Seq Error),Productions,Int)) -data Inh_Productions = Inh_Productions {cr_Inh_Productions :: Bool,manualAttrOrderMap_Inh_Productions :: AttrOrderMap,nonterminals_Inh_Productions :: Set Nonterminal,o_rename_Inh_Productions :: Bool,typeSyns_Inh_Productions :: TypeSyns,uniq_Inh_Productions :: Int,useMap_Inh_Productions :: UseMap} -data Syn_Productions = Syn_Productions {collect_nts_Syn_Productions :: Set Nonterminal,errors_Syn_Productions :: Seq Error,output_Syn_Productions :: Productions,uniq_Syn_Productions :: Int} -wrap_Productions (T_Productions sem ) (Inh_Productions _lhsIcr _lhsImanualAttrOrderMap _lhsInonterminals _lhsIo_rename _lhsItypeSyns _lhsIuniq _lhsIuseMap ) = - (let ( _lhsOcollect_nts,_lhsOerrors,_lhsOoutput,_lhsOuniq) = - (sem _lhsIcr _lhsImanualAttrOrderMap _lhsInonterminals _lhsIo_rename _lhsItypeSyns _lhsIuniq _lhsIuseMap ) - in (Syn_Productions _lhsOcollect_nts _lhsOerrors _lhsOoutput _lhsOuniq )) -sem_Productions_Cons :: T_Production -> - T_Productions -> - T_Productions -sem_Productions_Cons (T_Production hd_ ) (T_Productions tl_ ) = - (T_Productions (\ _lhsIcr - _lhsImanualAttrOrderMap - _lhsInonterminals - _lhsIo_rename - _lhsItypeSyns - _lhsIuniq - _lhsIuseMap -> - (let _lhsOcollect_nts :: (Set Nonterminal) - _lhsOerrors :: (Seq Error) - _lhsOoutput :: Productions - _lhsOuniq :: Int - _hdOcr :: Bool - _hdOmanualAttrOrderMap :: AttrOrderMap - _hdOnonterminals :: (Set Nonterminal) - _hdOo_rename :: Bool - _hdOtypeSyns :: TypeSyns - _hdOuniq :: Int - _hdOuseMap :: UseMap - _tlOcr :: Bool - _tlOmanualAttrOrderMap :: AttrOrderMap - _tlOnonterminals :: (Set Nonterminal) - _tlOo_rename :: Bool - _tlOtypeSyns :: TypeSyns - _tlOuniq :: Int - _tlOuseMap :: UseMap - _hdIcollect_nts :: (Set Nonterminal) - _hdIerrors :: (Seq Error) - _hdIoutput :: Production - _hdIuniq :: Int - _tlIcollect_nts :: (Set Nonterminal) - _tlIerrors :: (Seq Error) - _tlIoutput :: Productions - _tlIuniq :: Int - -- use rule "DefaultRules.ag"(line 113, column 47) - _lhsOcollect_nts = - _hdIcollect_nts `Set.union` _tlIcollect_nts - -- use rule "DefaultRules.ag"(line 107, column 19) - _lhsOerrors = - _hdIerrors Seq.<> _tlIerrors - -- self rule - _output = - (:) _hdIoutput _tlIoutput - -- self rule - _lhsOoutput = - _output - -- copy rule (up) - _lhsOuniq = - _tlIuniq - -- copy rule (down) - _hdOcr = - _lhsIcr - -- copy rule (down) - _hdOmanualAttrOrderMap = - _lhsImanualAttrOrderMap - -- copy rule (down) - _hdOnonterminals = - _lhsInonterminals - -- copy rule (down) - _hdOo_rename = - _lhsIo_rename - -- copy rule (down) - _hdOtypeSyns = - _lhsItypeSyns - -- copy rule (down) - _hdOuniq = - _lhsIuniq - -- copy rule (down) - _hdOuseMap = - _lhsIuseMap - -- copy rule (down) - _tlOcr = - _lhsIcr - -- copy rule (down) - _tlOmanualAttrOrderMap = - _lhsImanualAttrOrderMap - -- copy rule (down) - _tlOnonterminals = - _lhsInonterminals - -- copy rule (down) - _tlOo_rename = - _lhsIo_rename - -- copy rule (down) - _tlOtypeSyns = - _lhsItypeSyns - -- copy rule (chain) - _tlOuniq = - _hdIuniq - -- copy rule (down) - _tlOuseMap = - _lhsIuseMap - ( _hdIcollect_nts,_hdIerrors,_hdIoutput,_hdIuniq) = - (hd_ _hdOcr _hdOmanualAttrOrderMap _hdOnonterminals _hdOo_rename _hdOtypeSyns _hdOuniq _hdOuseMap ) - ( _tlIcollect_nts,_tlIerrors,_tlIoutput,_tlIuniq) = - (tl_ _tlOcr _tlOmanualAttrOrderMap _tlOnonterminals _tlOo_rename _tlOtypeSyns _tlOuniq _tlOuseMap ) - in ( _lhsOcollect_nts,_lhsOerrors,_lhsOoutput,_lhsOuniq))) ) -sem_Productions_Nil :: T_Productions -sem_Productions_Nil = - (T_Productions (\ _lhsIcr - _lhsImanualAttrOrderMap - _lhsInonterminals - _lhsIo_rename - _lhsItypeSyns - _lhsIuniq - _lhsIuseMap -> - (let _lhsOcollect_nts :: (Set Nonterminal) - _lhsOerrors :: (Seq Error) - _lhsOoutput :: Productions - _lhsOuniq :: Int - -- use rule "DefaultRules.ag"(line 113, column 47) - _lhsOcollect_nts = - Set.empty - -- use rule "DefaultRules.ag"(line 107, column 19) - _lhsOerrors = - Seq.empty - -- self rule - _output = - [] - -- self rule - _lhsOoutput = - _output - -- copy rule (chain) - _lhsOuniq = - _lhsIuniq - in ( _lhsOcollect_nts,_lhsOerrors,_lhsOoutput,_lhsOuniq))) ) --- Rule -------------------------------------------------------- -{- - visit 0: - inherited attributes: - con : Constructor - nt : Nonterminal - chained attribute: - uniq : Int - synthesized attributes: - containsVars : Bool - definedAttrs : Set (Name,Name) - errors : Seq Error - locals : Set Name - output : SELF - outputs : Rules - alternatives: - alternative Rule: - child pattern : Pattern - child rhs : {Expression} - child owrt : {Bool} - child origin : {String} - visit 0: - local _tup2 : {(Rules,Int)} - local output : _ --} --- cata -sem_Rule :: Rule -> - T_Rule -sem_Rule (Rule _pattern _rhs _owrt _origin ) = - (sem_Rule_Rule (sem_Pattern _pattern ) _rhs _owrt _origin ) --- semantic domain -newtype T_Rule = T_Rule (Constructor -> - Nonterminal -> - Int -> - ( Bool,(Set (Name,Name)),(Seq Error),(Set Name),Rule,Rules,Int)) -data Inh_Rule = Inh_Rule {con_Inh_Rule :: Constructor,nt_Inh_Rule :: Nonterminal,uniq_Inh_Rule :: Int} -data Syn_Rule = Syn_Rule {containsVars_Syn_Rule :: Bool,definedAttrs_Syn_Rule :: Set (Name,Name),errors_Syn_Rule :: Seq Error,locals_Syn_Rule :: Set Name,output_Syn_Rule :: Rule,outputs_Syn_Rule :: Rules,uniq_Syn_Rule :: Int} -wrap_Rule (T_Rule sem ) (Inh_Rule _lhsIcon _lhsInt _lhsIuniq ) = - (let ( _lhsOcontainsVars,_lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput,_lhsOoutputs,_lhsOuniq) = - (sem _lhsIcon _lhsInt _lhsIuniq ) - in (Syn_Rule _lhsOcontainsVars _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput _lhsOoutputs _lhsOuniq )) -sem_Rule_Rule :: T_Pattern -> - Expression -> - Bool -> - String -> - T_Rule -sem_Rule_Rule (T_Pattern pattern_ ) rhs_ owrt_ origin_ = - (T_Rule (\ _lhsIcon - _lhsInt - _lhsIuniq -> - (let __tup2 :: ((Rules,Int)) - _lhsOoutputs :: Rules - _lhsOuniq :: Int - _lhsOcontainsVars :: Bool - _lhsOdefinedAttrs :: (Set (Name,Name)) - _lhsOerrors :: (Seq Error) - _lhsOlocals :: (Set Name) - _lhsOoutput :: Rule - _patternOcon :: Constructor - _patternOnt :: Nonterminal - _patternIcontainsVars :: Bool - _patternIcopy :: Pattern - _patternIdefinedAttrs :: (Set (Name,Name)) - _patternIerrors :: (Seq Error) - _patternIlocals :: (Set Name) - _patternIoutput :: Pattern - -- "DefaultRules.ag"(line 420, column 11) - __tup2 = - multiRule _output _lhsIuniq - -- "DefaultRules.ag"(line 420, column 11) - (_lhsOoutputs,_) = - __tup2 - -- "DefaultRules.ag"(line 420, column 11) - (_,_lhsOuniq) = - __tup2 - -- use rule "DefaultRules.ag"(line 391, column 46) - _lhsOcontainsVars = - _patternIcontainsVars - -- use rule "DefaultRules.ag"(line 371, column 23) - _lhsOdefinedAttrs = - _patternIdefinedAttrs - -- use rule "DefaultRules.ag"(line 107, column 19) - _lhsOerrors = - _patternIerrors - -- use rule "DefaultRules.ag"(line 370, column 23) - _lhsOlocals = - _patternIlocals - -- self rule - _output = - Rule _patternIoutput rhs_ owrt_ origin_ - -- self rule - _lhsOoutput = - _output - -- copy rule (down) - _patternOcon = - _lhsIcon - -- copy rule (down) - _patternOnt = - _lhsInt - ( _patternIcontainsVars,_patternIcopy,_patternIdefinedAttrs,_patternIerrors,_patternIlocals,_patternIoutput) = - (pattern_ _patternOcon _patternOnt ) - in ( _lhsOcontainsVars,_lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput,_lhsOoutputs,_lhsOuniq))) ) --- Rules ------------------------------------------------------- -{- - visit 0: - inherited attributes: - con : Constructor - nt : Nonterminal - chained attribute: - uniq : Int - synthesized attributes: - definedAttrs : Set (Name,Name) - errors : Seq Error - locals : Set Name - output : SELF - alternatives: - alternative Cons: - child hd : Rule - child tl : Rules - visit 0: - local output : _ - alternative Nil: - visit 0: - local output : _ --} --- cata -sem_Rules :: Rules -> - T_Rules -sem_Rules list = - (Prelude.foldr sem_Rules_Cons sem_Rules_Nil (Prelude.map sem_Rule list) ) --- semantic domain -newtype T_Rules = T_Rules (Constructor -> - Nonterminal -> - Int -> - ( (Set (Name,Name)),(Seq Error),(Set Name),Rules,Int)) -data Inh_Rules = Inh_Rules {con_Inh_Rules :: Constructor,nt_Inh_Rules :: Nonterminal,uniq_Inh_Rules :: Int} -data Syn_Rules = Syn_Rules {definedAttrs_Syn_Rules :: Set (Name,Name),errors_Syn_Rules :: Seq Error,locals_Syn_Rules :: Set Name,output_Syn_Rules :: Rules,uniq_Syn_Rules :: Int} -wrap_Rules (T_Rules sem ) (Inh_Rules _lhsIcon _lhsInt _lhsIuniq ) = - (let ( _lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput,_lhsOuniq) = - (sem _lhsIcon _lhsInt _lhsIuniq ) - in (Syn_Rules _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput _lhsOuniq )) -sem_Rules_Cons :: T_Rule -> - T_Rules -> - T_Rules -sem_Rules_Cons (T_Rule hd_ ) (T_Rules tl_ ) = - (T_Rules (\ _lhsIcon - _lhsInt - _lhsIuniq -> - (let _lhsOoutput :: Rules - _lhsOdefinedAttrs :: (Set (Name,Name)) - _lhsOerrors :: (Seq Error) - _lhsOlocals :: (Set Name) - _lhsOuniq :: Int - _hdOcon :: Constructor - _hdOnt :: Nonterminal - _hdOuniq :: Int - _tlOcon :: Constructor - _tlOnt :: Nonterminal - _tlOuniq :: Int - _hdIcontainsVars :: Bool - _hdIdefinedAttrs :: (Set (Name,Name)) - _hdIerrors :: (Seq Error) - _hdIlocals :: (Set Name) - _hdIoutput :: Rule - _hdIoutputs :: Rules - _hdIuniq :: Int - _tlIdefinedAttrs :: (Set (Name,Name)) - _tlIerrors :: (Seq Error) - _tlIlocals :: (Set Name) - _tlIoutput :: Rules - _tlIuniq :: Int - -- "DefaultRules.ag"(line 416, column 10) - _lhsOoutput = - if _hdIcontainsVars then _hdIoutputs ++ _tlIoutput else _tlIoutput - -- use rule "DefaultRules.ag"(line 371, column 23) - _lhsOdefinedAttrs = - _hdIdefinedAttrs `Set.union` _tlIdefinedAttrs - -- use rule "DefaultRules.ag"(line 107, column 19) - _lhsOerrors = - _hdIerrors Seq.<> _tlIerrors - -- use rule "DefaultRules.ag"(line 370, column 23) - _lhsOlocals = - _hdIlocals `Set.union` _tlIlocals - -- self rule - _output = - (:) _hdIoutput _tlIoutput - -- copy rule (up) - _lhsOuniq = - _tlIuniq - -- copy rule (down) - _hdOcon = - _lhsIcon - -- copy rule (down) - _hdOnt = - _lhsInt - -- copy rule (down) - _hdOuniq = - _lhsIuniq - -- copy rule (down) - _tlOcon = - _lhsIcon - -- copy rule (down) - _tlOnt = - _lhsInt - -- copy rule (chain) - _tlOuniq = - _hdIuniq - ( _hdIcontainsVars,_hdIdefinedAttrs,_hdIerrors,_hdIlocals,_hdIoutput,_hdIoutputs,_hdIuniq) = - (hd_ _hdOcon _hdOnt _hdOuniq ) - ( _tlIdefinedAttrs,_tlIerrors,_tlIlocals,_tlIoutput,_tlIuniq) = - (tl_ _tlOcon _tlOnt _tlOuniq ) - in ( _lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput,_lhsOuniq))) ) -sem_Rules_Nil :: T_Rules -sem_Rules_Nil = - (T_Rules (\ _lhsIcon - _lhsInt - _lhsIuniq -> - (let _lhsOdefinedAttrs :: (Set (Name,Name)) - _lhsOerrors :: (Seq Error) - _lhsOlocals :: (Set Name) - _lhsOoutput :: Rules - _lhsOuniq :: Int - -- use rule "DefaultRules.ag"(line 371, column 23) - _lhsOdefinedAttrs = - Set.empty - -- use rule "DefaultRules.ag"(line 107, column 19) - _lhsOerrors = - Seq.empty - -- use rule "DefaultRules.ag"(line 370, column 23) - _lhsOlocals = - Set.empty - -- self rule - _output = - [] - -- self rule - _lhsOoutput = - _output - -- copy rule (chain) - _lhsOuniq = - _lhsIuniq - in ( _lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput,_lhsOuniq))) ) --- TypeSig ----------------------------------------------------- -{- - visit 0: - synthesized attribute: - output : SELF - alternatives: - alternative TypeSig: - child name : {Name} - child tp : {Type} - visit 0: - local output : _ --} --- cata -sem_TypeSig :: TypeSig -> - T_TypeSig -sem_TypeSig (TypeSig _name _tp ) = - (sem_TypeSig_TypeSig _name _tp ) --- semantic domain -newtype T_TypeSig = T_TypeSig (( TypeSig)) -data Inh_TypeSig = Inh_TypeSig {} -data Syn_TypeSig = Syn_TypeSig {output_Syn_TypeSig :: TypeSig} -wrap_TypeSig (T_TypeSig sem ) (Inh_TypeSig ) = - (let ( _lhsOoutput) = - (sem ) - in (Syn_TypeSig _lhsOoutput )) -sem_TypeSig_TypeSig :: Name -> - Type -> - T_TypeSig -sem_TypeSig_TypeSig name_ tp_ = - (T_TypeSig (let _lhsOoutput :: TypeSig - -- self rule - _output = - TypeSig name_ tp_ - -- self rule - _lhsOoutput = - _output - in ( _lhsOoutput)) ) --- TypeSigs ---------------------------------------------------- -{- - visit 0: - synthesized attribute: - output : SELF - alternatives: - alternative Cons: - child hd : TypeSig - child tl : TypeSigs - visit 0: - local output : _ - alternative Nil: - visit 0: - local output : _ --} --- cata -sem_TypeSigs :: TypeSigs -> - T_TypeSigs -sem_TypeSigs list = - (Prelude.foldr sem_TypeSigs_Cons sem_TypeSigs_Nil (Prelude.map sem_TypeSig list) ) --- semantic domain -newtype T_TypeSigs = T_TypeSigs (( TypeSigs)) -data Inh_TypeSigs = Inh_TypeSigs {} -data Syn_TypeSigs = Syn_TypeSigs {output_Syn_TypeSigs :: TypeSigs} -wrap_TypeSigs (T_TypeSigs sem ) (Inh_TypeSigs ) = - (let ( _lhsOoutput) = - (sem ) - in (Syn_TypeSigs _lhsOoutput )) -sem_TypeSigs_Cons :: T_TypeSig -> - T_TypeSigs -> - T_TypeSigs -sem_TypeSigs_Cons (T_TypeSig hd_ ) (T_TypeSigs tl_ ) = - (T_TypeSigs (let _lhsOoutput :: TypeSigs - _hdIoutput :: TypeSig - _tlIoutput :: TypeSigs - -- self rule - _output = - (:) _hdIoutput _tlIoutput - -- self rule - _lhsOoutput = - _output - ( _hdIoutput) = - (hd_ ) - ( _tlIoutput) = - (tl_ ) - in ( _lhsOoutput)) ) -sem_TypeSigs_Nil :: T_TypeSigs -sem_TypeSigs_Nil = - (T_TypeSigs (let _lhsOoutput :: TypeSigs - -- self rule - _output = - [] - -- self rule - _lhsOoutput = - _output - in ( _lhsOoutput)) ) +-- UUAGC 0.9.5 (DefaultRules.ag) +module DefaultRules where + +import qualified List (delete,intersperse) + +import qualified Data.Set as Set +import qualified Data.Map as Map +import Data.Map(Map) +import qualified UU.DData.Seq as Seq +import UU.DData.Seq(Seq,(<>)) +import UU.Scanner.Position(noPos) +import Pretty +import Maybe +import HsToken +import HsTokenScanner + +import AbstractSyntax +import ErrorMessages + +import Options(Options,modcopy,rename) + +-- AbstractSyntax.ag imports +import Data.Set(Set) +import Data.Map(Map) +import Patterns (Pattern(..),Patterns) +import Expression (Expression(..)) +import CommonTypes + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (ConstructorIdent,Identifier) + +fieldName n = '@' : getName n + +locName n = '@' : getName n + +attrName fld attr + | fld == _LOC = '@' : getName attr + | otherwise = '@' : getName fld ++ "." ++ getName attr + +_ACHILD = Ident "(" noPos -- hack + + +getConName typeSyns rename nt con1 + | nt `elem` map fst typeSyns = synonym + | otherwise = normalName + where con = getName con1 + normalName | rename = getName nt++"_"++ con + | otherwise = con + synonym | con == "Cons" = "(:)" + | con == "Nil" = "[]" + | con == "Just" = "Just" + | con == "Nothing" = "Nothing" + | otherwise = normalName + + + +concatSeq = foldr Seq.append Seq.empty + +splitAttrs :: Map Identifier a -> [Identifier] -> ([(Identifier,a)],[Identifier]) -- a used as (String,String) +splitAttrs _ [] + = ([],[]) +splitAttrs useMap (n:rest) + = let (uses,normals) = splitAttrs useMap rest + in case Map.lookup n useMap of + Just x -> ((n,x):uses , normals ) + Nothing -> ( uses , n:normals ) + +removeDefined :: Set (Identifier,Identifier) -> (Identifier,Attributes) -> (Identifier,[Identifier]) +removeDefined defined (fld,as) + = ( fld + , [ a + | a <- Map.keys as + , not (Set.member (fld,a) defined) + ] + ) + + + + + +deprecatedCopyRuleError nt con fld a + = let mesg = + "In the definitions for alternative" + >#< getName con + >#< "of nonterminal" + >#< getName nt + >|< "," + >-< "the value of field" + >#< getName a + >#< "is copied by a copy-rule." + >-< "Copying the value of a field using a copy-rule is deprecated" + >-< "Please add the following lines to your code:" + >-< ( "SEM" + >#< getName nt + >-< indent 2 ( "|" + >#< getName con + >#< getName fld + >#< "." + >#< a + >#< "=" + >#< "@" + >|< a + ) + ) + in CustomError True (getPos a) mesg + + +missingRuleErrorExpr nt con fld a + = "error \"missing rule: " + ++ show nt ++ "." ++ show con ++ "." + ++ show fld ++ "." ++ show a ++ "\"" + + + +makeRule :: (Identifier,Identifier) -> Expression -> String -> Rule +makeRule (f1,a1) expr origin + = Rule (Alias f1 a1 (Underscore noPos) []) + expr + False + origin + + +useRule :: Set Identifier -> [(Identifier,Attributes)] -> (Identifier,(String,String,String)) -> Rule +useRule locals ch_outs (n,(op,e,pos)) + = let elems = [ fld + | (fld,as) <- ch_outs + , Map.member n as + ] + + expr | Set.member n locals = attrName _LOC n + | null elems = e + | otherwise = foldr1 (\x y -> x ++ " " ++ op ++ " " ++ y) + (map (flip attrName n) elems) + + tks | Set.member n locals = [AGLocal n noPos Nothing] + | null elems = lexTokens noPos e + | otherwise = lexTokens noPos str + where + str = foldr1 (\x y -> x ++ " " ++ op ++ " " ++ y) + (map (flip attrName n) elems) + + in makeRule (_LHS,n) + (Expression noPos tks) + ("use rule " ++ pos) + + + + +selfRule lhsNecLoc attr x + = let expr | lhsNecLoc = locName attr + | otherwise = x + + tks | lhsNecLoc = [AGLocal attr noPos Nothing] + | otherwise = lexTokens noPos x + + in makeRule (if lhsNecLoc then _LHS else _LOC,attr) + (Expression noPos tks) + "self rule" + + + + +concatRE rsess = let (rss,ess) = unzip rsess + in (concat rss, concatSeq ess) + + +copyRule :: Identifier -> Identifier -> Bool -> Set Identifier -> (Map Identifier Identifier, (Identifier,[Identifier])) -> ([Rule], Seq Error) +copyRule nt con modcopy locals (env,(fld,as)) + = concatRE (map copyRu as) + + where + copyRu a + = ( [ makeRule (fld,a) + (Expression noPos tks) + (cruletxt sel) + ] + , err + ) + + where + sel + | not modcopy + && Set.member a locals = Just _LOC + | otherwise = Map.lookup a env + + (expr,err) + = case sel of + Nothing -> ( missingRuleErrorExpr nt con fld a + , Seq.single (MissingRule nt con fld a) + ) + Just f + | f == _ACHILD -> ( fieldName a + , Seq.single (deprecatedCopyRuleError nt con fld a) + ) + | otherwise -> ( attrName f a + , Seq.empty + ) + + (tks,err') + = case sel of + Nothing -> ( [HsToken (missingRuleErrorExpr nt con fld a) noPos] + , Seq.single (MissingRule nt con fld a) + ) + Just f + | f == _ACHILD -> ( [AGLocal a noPos Nothing] + , Seq.single (deprecatedCopyRuleError nt con fld a) + ) + | otherwise -> ( [AGField f a noPos Nothing] + , Seq.empty + ) + + cruletxt sel + | local = "copy rule (from local)" + | deprChild = "deprecated child copy" + | Set.member a locals && nonlocal = "modified copy rule" + | incoming && outgoing = "copy rule (chain)" + | incoming = "copy rule (down)" + | outgoing = "copy rule (up)" + | otherwise = "copy rule (chain)" + where outgoing = fld == _LHS + incoming = maybe False (== _LHS) sel + nonlocal = maybe False (/= _LOC) sel + local = maybe False (== _LOC) sel + deprChild = maybe False (== _ACHILD) sel + +{- +multiRule replaces + loc.(a,b) = e +by + loc.tup1 = e + loc.(a,_) = @loc.tup1 + loc.(_,b) = @loc.tup1 +It needs to thread a unique number for inventing names for the tuples. + +It also works for nested tuples: + loc.(a,(b,c)) = e +becomes + loc.tup1 = e + loc.(a,_) = @loc.tup1 + loc.(_,tup2) = @loc.tup1 + loc.(b,_) = @loc.tup2 + loc.(_,c) = @loc.tup2 +-} + +multiRule :: Rule -> Int -> ([Rule], Int) +multiRule (Rule pat expr owrt origin) uniq + = let f :: (Pattern->Pattern) -> Expression -> Pattern -> Int -> (Pattern, ([Rule], Int)) + f w e (Product pos pats) n + = let freshName = Ident ("_tup" ++ show n) pos + freshExpr = Expression pos freshTks + freshTks = [AGField _LOC freshName pos Nothing] + freshPat = Alias _LOC freshName (Underscore pos) pats + a = length pats - 1 + us b p = Product pos (replicate (a-b) (Underscore pos) ++ [p] ++ replicate b (Underscore pos)) + g :: Pattern -> ([Pattern],[Rule],Int) -> ([Pattern],[Rule],Int) + g p (xs1,rs1,n1) = let (x2,(rs2,n2)) = f (us (length xs1)) freshExpr p n1 + in (x2:xs1, rs2++rs1, n2) + (xs9,rs9,n9) = foldr g ([], [], n+1) pats + in ( freshPat + , ( Rule (w freshPat) e owrt origin : rs9 + , n9 + ) + ) + f w e p n + = ( p + , ( [Rule (w p) e owrt origin] + , n + ) + ) + in snd (f id expr pat uniq) + +-- Child ------------------------------------------------------- +{- + visit 0: + inherited attributes: + con : ConstructorIdent + cr : Bool + nt : NontermIdent + synthesized attributes: + errors : Seq Error + field : (Identifier,Type,Bool) + inherited : Attributes + name : Identifier + output : SELF + synthesized : Attributes + alternatives: + alternative Child: + child name : {Identifier} + child tp : {Type} + child inh : {Attributes} + child syn : {Attributes} + child higherOrder : {Bool} + visit 0: + local output : _ +-} +-- cata +sem_Child :: Child -> + T_Child +sem_Child (Child _name _tp _inh _syn _higherOrder) = + (sem_Child_Child _name _tp _inh _syn _higherOrder) +-- semantic domain +newtype T_Child = T_Child (ConstructorIdent -> + Bool -> + NontermIdent -> + ( (Seq Error),( (Identifier,Type,Bool) ),Attributes,Identifier,Child,Attributes)) +data Inh_Child = Inh_Child {con_Inh_Child :: ConstructorIdent,cr_Inh_Child :: Bool,nt_Inh_Child :: NontermIdent} +data Syn_Child = Syn_Child {errors_Syn_Child :: Seq Error,field_Syn_Child :: (Identifier,Type,Bool) ,inherited_Syn_Child :: Attributes,name_Syn_Child :: Identifier,output_Syn_Child :: Child,synthesized_Syn_Child :: Attributes} +wrap_Child (T_Child sem) (Inh_Child _lhsIcon _lhsIcr _lhsInt) = + (let ( _lhsOerrors,_lhsOfield,_lhsOinherited,_lhsOname,_lhsOoutput,_lhsOsynthesized) = + (sem _lhsIcon _lhsIcr _lhsInt) + in (Syn_Child _lhsOerrors _lhsOfield _lhsOinherited _lhsOname _lhsOoutput _lhsOsynthesized)) +sem_Child_Child :: Identifier -> + Type -> + Attributes -> + Attributes -> + Bool -> + T_Child +sem_Child_Child name_ tp_ inh_ syn_ higherOrder_ = + (T_Child (\ _lhsIcon + _lhsIcr + _lhsInt -> + (let _lhsOname :: Identifier + _lhsOinherited :: Attributes + _lhsOsynthesized :: Attributes + _lhsOfield :: ( (Identifier,Type,Bool) ) + _lhsOerrors :: (Seq Error) + _lhsOoutput :: Child + -- "DefaultRules.ag"(line 140, column 11) + _lhsOname = + name_ + -- "DefaultRules.ag"(line 149, column 11) + _lhsOinherited = + inh_ + -- "DefaultRules.ag"(line 150, column 11) + _lhsOsynthesized = + syn_ + -- "DefaultRules.ag"(line 411, column 11) + _lhsOfield = + (name_,tp_,higherOrder_) + -- use rule "DefaultRules.ag"(line 109, column 19) + _lhsOerrors = + Seq.empty + -- self rule + _output = + Child name_ tp_ inh_ syn_ higherOrder_ + -- self rule + _lhsOoutput = + _output + in ( _lhsOerrors,_lhsOfield,_lhsOinherited,_lhsOname,_lhsOoutput,_lhsOsynthesized)))) +-- Children ---------------------------------------------------- +{- + visit 0: + inherited attributes: + con : ConstructorIdent + cr : Bool + nt : NontermIdent + synthesized attributes: + errors : Seq Error + fields : [(Identifier,Type,Bool)] + inputs : [(Identifier, Attributes)] + output : SELF + outputs : [(Identifier, Attributes)] + alternatives: + alternative Cons: + child hd : Child + child tl : Children + visit 0: + local output : _ + alternative Nil: + visit 0: + local output : _ +-} +-- cata +sem_Children :: Children -> + T_Children +sem_Children list = + (Prelude.foldr sem_Children_Cons sem_Children_Nil (Prelude.map sem_Child list)) +-- semantic domain +newtype T_Children = T_Children (ConstructorIdent -> + Bool -> + NontermIdent -> + ( (Seq Error),([(Identifier,Type,Bool)]),([(Identifier, Attributes)]),Children,([(Identifier, Attributes)]))) +data Inh_Children = Inh_Children {con_Inh_Children :: ConstructorIdent,cr_Inh_Children :: Bool,nt_Inh_Children :: NontermIdent} +data Syn_Children = Syn_Children {errors_Syn_Children :: Seq Error,fields_Syn_Children :: [(Identifier,Type,Bool)],inputs_Syn_Children :: [(Identifier, Attributes)],output_Syn_Children :: Children,outputs_Syn_Children :: [(Identifier, Attributes)]} +wrap_Children (T_Children sem) (Inh_Children _lhsIcon _lhsIcr _lhsInt) = + (let ( _lhsOerrors,_lhsOfields,_lhsOinputs,_lhsOoutput,_lhsOoutputs) = + (sem _lhsIcon _lhsIcr _lhsInt) + in (Syn_Children _lhsOerrors _lhsOfields _lhsOinputs _lhsOoutput _lhsOoutputs)) +sem_Children_Cons :: T_Child -> + T_Children -> + T_Children +sem_Children_Cons (T_Child hd_) (T_Children tl_) = + (T_Children (\ _lhsIcon + _lhsIcr + _lhsInt -> + (let _lhsOinputs :: ([(Identifier, Attributes)]) + _lhsOoutputs :: ([(Identifier, Attributes)]) + _lhsOfields :: ([(Identifier,Type,Bool)]) + _lhsOerrors :: (Seq Error) + _lhsOoutput :: Children + _hdOcon :: ConstructorIdent + _hdOcr :: Bool + _hdOnt :: NontermIdent + _tlOcon :: ConstructorIdent + _tlOcr :: Bool + _tlOnt :: NontermIdent + _hdIerrors :: (Seq Error) + _hdIfield :: ( (Identifier,Type,Bool) ) + _hdIinherited :: Attributes + _hdIname :: Identifier + _hdIoutput :: Child + _hdIsynthesized :: Attributes + _tlIerrors :: (Seq Error) + _tlIfields :: ([(Identifier,Type,Bool)]) + _tlIinputs :: ([(Identifier, Attributes)]) + _tlIoutput :: Children + _tlIoutputs :: ([(Identifier, Attributes)]) + -- "DefaultRules.ag"(line 153, column 10) + _lhsOinputs = + (_hdIname, _hdIinherited) : _tlIinputs + -- "DefaultRules.ag"(line 153, column 10) + _lhsOoutputs = + (_hdIname, _hdIsynthesized) : _tlIoutputs + -- "DefaultRules.ag"(line 407, column 10) + _lhsOfields = + _hdIfield : _tlIfields + -- use rule "DefaultRules.ag"(line 109, column 19) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- self rule + _output = + (:) _hdIoutput _tlIoutput + -- self rule + _lhsOoutput = + _output + -- copy rule (down) + _hdOcon = + _lhsIcon + -- copy rule (down) + _hdOcr = + _lhsIcr + -- copy rule (down) + _hdOnt = + _lhsInt + -- copy rule (down) + _tlOcon = + _lhsIcon + -- copy rule (down) + _tlOcr = + _lhsIcr + -- copy rule (down) + _tlOnt = + _lhsInt + ( _hdIerrors,_hdIfield,_hdIinherited,_hdIname,_hdIoutput,_hdIsynthesized) = + (hd_ _hdOcon _hdOcr _hdOnt) + ( _tlIerrors,_tlIfields,_tlIinputs,_tlIoutput,_tlIoutputs) = + (tl_ _tlOcon _tlOcr _tlOnt) + in ( _lhsOerrors,_lhsOfields,_lhsOinputs,_lhsOoutput,_lhsOoutputs)))) +sem_Children_Nil :: T_Children +sem_Children_Nil = + (T_Children (\ _lhsIcon + _lhsIcr + _lhsInt -> + (let _lhsOinputs :: ([(Identifier, Attributes)]) + _lhsOoutputs :: ([(Identifier, Attributes)]) + _lhsOfields :: ([(Identifier,Type,Bool)]) + _lhsOerrors :: (Seq Error) + _lhsOoutput :: Children + -- "DefaultRules.ag"(line 155, column 10) + _lhsOinputs = + [] + -- "DefaultRules.ag"(line 155, column 10) + _lhsOoutputs = + [] + -- "DefaultRules.ag"(line 408, column 10) + _lhsOfields = + [] + -- use rule "DefaultRules.ag"(line 109, column 19) + _lhsOerrors = + Seq.empty + -- self rule + _output = + [] + -- self rule + _lhsOoutput = + _output + in ( _lhsOerrors,_lhsOfields,_lhsOinputs,_lhsOoutput,_lhsOoutputs)))) +-- Grammar ----------------------------------------------------- +{- + visit 0: + inherited attribute: + options : Options + synthesized attributes: + errors : Seq Error + output : SELF + alternatives: + alternative Grammar: + child typeSyns : {TypeSyns} + child useMap : {UseMap} + child derivings : {Derivings} + child wrappers : {Set NontermIdent} + child nonts : Nonterminals + child pragmas : {PragmaMap} + child manualAttrOrderMap : {AttrOrderMap} + child paramMap : {ParamMap} + child contextMap : {ContextMap} + visit 0: + local output : _ +-} +-- cata +sem_Grammar :: Grammar -> + T_Grammar +sem_Grammar (Grammar _typeSyns _useMap _derivings _wrappers _nonts _pragmas _manualAttrOrderMap _paramMap _contextMap) = + (sem_Grammar_Grammar _typeSyns _useMap _derivings _wrappers (sem_Nonterminals _nonts) _pragmas _manualAttrOrderMap _paramMap _contextMap) +-- semantic domain +newtype T_Grammar = T_Grammar (Options -> + ( (Seq Error),Grammar)) +data Inh_Grammar = Inh_Grammar {options_Inh_Grammar :: Options} +data Syn_Grammar = Syn_Grammar {errors_Syn_Grammar :: Seq Error,output_Syn_Grammar :: Grammar} +wrap_Grammar (T_Grammar sem) (Inh_Grammar _lhsIoptions) = + (let ( _lhsOerrors,_lhsOoutput) = + (sem _lhsIoptions) + in (Syn_Grammar _lhsOerrors _lhsOoutput)) +sem_Grammar_Grammar :: TypeSyns -> + UseMap -> + Derivings -> + (Set NontermIdent) -> + T_Nonterminals -> + PragmaMap -> + AttrOrderMap -> + ParamMap -> + ContextMap -> + T_Grammar +sem_Grammar_Grammar typeSyns_ useMap_ derivings_ wrappers_ (T_Nonterminals nonts_) pragmas_ manualAttrOrderMap_ paramMap_ contextMap_ = + (T_Grammar (\ _lhsIoptions -> + (let _nontsOo_rename :: Bool + _nontsOcr :: Bool + _nontsOnonterminals :: (Set NontermIdent) + _nontsOuseMap :: UseMap + _nontsOtypeSyns :: TypeSyns + _nontsOuniq :: Int + _nontsOmanualAttrOrderMap :: AttrOrderMap + _lhsOerrors :: (Seq Error) + _lhsOoutput :: Grammar + _nontsIcollect_nts :: (Set NontermIdent) + _nontsIerrors :: (Seq Error) + _nontsIoutput :: Nonterminals + _nontsIuniq :: Int + -- "DefaultRules.ag"(line 43, column 17) + _nontsOo_rename = + rename _lhsIoptions + -- "DefaultRules.ag"(line 44, column 17) + _nontsOcr = + modcopy _lhsIoptions + -- "DefaultRules.ag"(line 121, column 13) + _nontsOnonterminals = + _nontsIcollect_nts + -- "DefaultRules.ag"(line 142, column 13) + _nontsOuseMap = + useMap_ + -- "DefaultRules.ag"(line 144, column 13) + _nontsOtypeSyns = + typeSyns_ + -- "DefaultRules.ag"(line 428, column 13) + _nontsOuniq = + 1 + -- "DefaultRules.ag"(line 505, column 7) + _nontsOmanualAttrOrderMap = + manualAttrOrderMap_ + -- use rule "DefaultRules.ag"(line 109, column 19) + _lhsOerrors = + _nontsIerrors + -- self rule + _output = + Grammar typeSyns_ useMap_ derivings_ wrappers_ _nontsIoutput pragmas_ manualAttrOrderMap_ paramMap_ contextMap_ + -- self rule + _lhsOoutput = + _output + ( _nontsIcollect_nts,_nontsIerrors,_nontsIoutput,_nontsIuniq) = + (nonts_ _nontsOcr _nontsOmanualAttrOrderMap _nontsOnonterminals _nontsOo_rename _nontsOtypeSyns _nontsOuniq _nontsOuseMap) + in ( _lhsOerrors,_lhsOoutput)))) +-- Nonterminal ------------------------------------------------- +{- + visit 0: + inherited attributes: + cr : Bool + manualAttrOrderMap : AttrOrderMap + nonterminals : Set NontermIdent + o_rename : Bool + typeSyns : TypeSyns + useMap : UseMap + chained attribute: + uniq : Int + synthesized attributes: + collect_nts : Set NontermIdent + errors : Seq Error + output : SELF + alternatives: + alternative Nonterminal: + child nt : {NontermIdent} + child params : {[Identifier]} + child inh : {Attributes} + child syn : {Attributes} + child prods : Productions + visit 0: + local output : _ +-} +-- cata +sem_Nonterminal :: Nonterminal -> + T_Nonterminal +sem_Nonterminal (Nonterminal _nt _params _inh _syn _prods) = + (sem_Nonterminal_Nonterminal _nt _params _inh _syn (sem_Productions _prods)) +-- semantic domain +newtype T_Nonterminal = T_Nonterminal (Bool -> + AttrOrderMap -> + (Set NontermIdent) -> + Bool -> + TypeSyns -> + Int -> + UseMap -> + ( (Set NontermIdent),(Seq Error),Nonterminal,Int)) +data Inh_Nonterminal = Inh_Nonterminal {cr_Inh_Nonterminal :: Bool,manualAttrOrderMap_Inh_Nonterminal :: AttrOrderMap,nonterminals_Inh_Nonterminal :: Set NontermIdent,o_rename_Inh_Nonterminal :: Bool,typeSyns_Inh_Nonterminal :: TypeSyns,uniq_Inh_Nonterminal :: Int,useMap_Inh_Nonterminal :: UseMap} +data Syn_Nonterminal = Syn_Nonterminal {collect_nts_Syn_Nonterminal :: Set NontermIdent,errors_Syn_Nonterminal :: Seq Error,output_Syn_Nonterminal :: Nonterminal,uniq_Syn_Nonterminal :: Int} +wrap_Nonterminal (T_Nonterminal sem) (Inh_Nonterminal _lhsIcr _lhsImanualAttrOrderMap _lhsInonterminals _lhsIo_rename _lhsItypeSyns _lhsIuniq _lhsIuseMap) = + (let ( _lhsOcollect_nts,_lhsOerrors,_lhsOoutput,_lhsOuniq) = + (sem _lhsIcr _lhsImanualAttrOrderMap _lhsInonterminals _lhsIo_rename _lhsItypeSyns _lhsIuniq _lhsIuseMap) + in (Syn_Nonterminal _lhsOcollect_nts _lhsOerrors _lhsOoutput _lhsOuniq)) +sem_Nonterminal_Nonterminal :: NontermIdent -> + ([Identifier]) -> + Attributes -> + Attributes -> + T_Productions -> + T_Nonterminal +sem_Nonterminal_Nonterminal nt_ params_ inh_ syn_ (T_Productions prods_) = + (T_Nonterminal (\ _lhsIcr + _lhsImanualAttrOrderMap + _lhsInonterminals + _lhsIo_rename + _lhsItypeSyns + _lhsIuniq + _lhsIuseMap -> + (let _lhsOcollect_nts :: (Set NontermIdent) + _prodsOinh :: Attributes + _prodsOsyn :: Attributes + _prodsOuseMap :: (Map Identifier (String,String,String)) + _prodsOnt :: NontermIdent + _lhsOerrors :: (Seq Error) + _lhsOoutput :: Nonterminal + _lhsOuniq :: Int + _prodsOcr :: Bool + _prodsOmanualAttrOrderMap :: AttrOrderMap + _prodsOnonterminals :: (Set NontermIdent) + _prodsOo_rename :: Bool + _prodsOtypeSyns :: TypeSyns + _prodsOuniq :: Int + _prodsIerrors :: (Seq Error) + _prodsIoutput :: Productions + _prodsIuniq :: Int + -- "DefaultRules.ag"(line 117, column 17) + _lhsOcollect_nts = + Set.singleton nt_ + -- "DefaultRules.ag"(line 132, column 18) + _prodsOinh = + inh_ + -- "DefaultRules.ag"(line 133, column 18) + _prodsOsyn = + syn_ + -- "DefaultRules.ag"(line 134, column 18) + _prodsOuseMap = + Map.findWithDefault Map.empty nt_ _lhsIuseMap + -- "DefaultRules.ag"(line 146, column 17) + _prodsOnt = + nt_ + -- use rule "DefaultRules.ag"(line 109, column 19) + _lhsOerrors = + _prodsIerrors + -- self rule + _output = + Nonterminal nt_ params_ inh_ syn_ _prodsIoutput + -- self rule + _lhsOoutput = + _output + -- copy rule (up) + _lhsOuniq = + _prodsIuniq + -- copy rule (down) + _prodsOcr = + _lhsIcr + -- copy rule (down) + _prodsOmanualAttrOrderMap = + _lhsImanualAttrOrderMap + -- copy rule (down) + _prodsOnonterminals = + _lhsInonterminals + -- copy rule (down) + _prodsOo_rename = + _lhsIo_rename + -- copy rule (down) + _prodsOtypeSyns = + _lhsItypeSyns + -- copy rule (down) + _prodsOuniq = + _lhsIuniq + ( _prodsIerrors,_prodsIoutput,_prodsIuniq) = + (prods_ _prodsOcr _prodsOinh _prodsOmanualAttrOrderMap _prodsOnonterminals _prodsOnt _prodsOo_rename _prodsOsyn _prodsOtypeSyns _prodsOuniq _prodsOuseMap) + in ( _lhsOcollect_nts,_lhsOerrors,_lhsOoutput,_lhsOuniq)))) +-- Nonterminals ------------------------------------------------ +{- + visit 0: + inherited attributes: + cr : Bool + manualAttrOrderMap : AttrOrderMap + nonterminals : Set NontermIdent + o_rename : Bool + typeSyns : TypeSyns + useMap : UseMap + chained attribute: + uniq : Int + synthesized attributes: + collect_nts : Set NontermIdent + errors : Seq Error + output : SELF + alternatives: + alternative Cons: + child hd : Nonterminal + child tl : Nonterminals + visit 0: + local output : _ + alternative Nil: + visit 0: + local output : _ +-} +-- cata +sem_Nonterminals :: Nonterminals -> + T_Nonterminals +sem_Nonterminals list = + (Prelude.foldr sem_Nonterminals_Cons sem_Nonterminals_Nil (Prelude.map sem_Nonterminal list)) +-- semantic domain +newtype T_Nonterminals = T_Nonterminals (Bool -> + AttrOrderMap -> + (Set NontermIdent) -> + Bool -> + TypeSyns -> + Int -> + UseMap -> + ( (Set NontermIdent),(Seq Error),Nonterminals,Int)) +data Inh_Nonterminals = Inh_Nonterminals {cr_Inh_Nonterminals :: Bool,manualAttrOrderMap_Inh_Nonterminals :: AttrOrderMap,nonterminals_Inh_Nonterminals :: Set NontermIdent,o_rename_Inh_Nonterminals :: Bool,typeSyns_Inh_Nonterminals :: TypeSyns,uniq_Inh_Nonterminals :: Int,useMap_Inh_Nonterminals :: UseMap} +data Syn_Nonterminals = Syn_Nonterminals {collect_nts_Syn_Nonterminals :: Set NontermIdent,errors_Syn_Nonterminals :: Seq Error,output_Syn_Nonterminals :: Nonterminals,uniq_Syn_Nonterminals :: Int} +wrap_Nonterminals (T_Nonterminals sem) (Inh_Nonterminals _lhsIcr _lhsImanualAttrOrderMap _lhsInonterminals _lhsIo_rename _lhsItypeSyns _lhsIuniq _lhsIuseMap) = + (let ( _lhsOcollect_nts,_lhsOerrors,_lhsOoutput,_lhsOuniq) = + (sem _lhsIcr _lhsImanualAttrOrderMap _lhsInonterminals _lhsIo_rename _lhsItypeSyns _lhsIuniq _lhsIuseMap) + in (Syn_Nonterminals _lhsOcollect_nts _lhsOerrors _lhsOoutput _lhsOuniq)) +sem_Nonterminals_Cons :: T_Nonterminal -> + T_Nonterminals -> + T_Nonterminals +sem_Nonterminals_Cons (T_Nonterminal hd_) (T_Nonterminals tl_) = + (T_Nonterminals (\ _lhsIcr + _lhsImanualAttrOrderMap + _lhsInonterminals + _lhsIo_rename + _lhsItypeSyns + _lhsIuniq + _lhsIuseMap -> + (let _lhsOcollect_nts :: (Set NontermIdent) + _lhsOerrors :: (Seq Error) + _lhsOoutput :: Nonterminals + _lhsOuniq :: Int + _hdOcr :: Bool + _hdOmanualAttrOrderMap :: AttrOrderMap + _hdOnonterminals :: (Set NontermIdent) + _hdOo_rename :: Bool + _hdOtypeSyns :: TypeSyns + _hdOuniq :: Int + _hdOuseMap :: UseMap + _tlOcr :: Bool + _tlOmanualAttrOrderMap :: AttrOrderMap + _tlOnonterminals :: (Set NontermIdent) + _tlOo_rename :: Bool + _tlOtypeSyns :: TypeSyns + _tlOuniq :: Int + _tlOuseMap :: UseMap + _hdIcollect_nts :: (Set NontermIdent) + _hdIerrors :: (Seq Error) + _hdIoutput :: Nonterminal + _hdIuniq :: Int + _tlIcollect_nts :: (Set NontermIdent) + _tlIerrors :: (Seq Error) + _tlIoutput :: Nonterminals + _tlIuniq :: Int + -- use rule "DefaultRules.ag"(line 115, column 49) + _lhsOcollect_nts = + _hdIcollect_nts `Set.union` _tlIcollect_nts + -- use rule "DefaultRules.ag"(line 109, column 19) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- self rule + _output = + (:) _hdIoutput _tlIoutput + -- self rule + _lhsOoutput = + _output + -- copy rule (up) + _lhsOuniq = + _tlIuniq + -- copy rule (down) + _hdOcr = + _lhsIcr + -- copy rule (down) + _hdOmanualAttrOrderMap = + _lhsImanualAttrOrderMap + -- copy rule (down) + _hdOnonterminals = + _lhsInonterminals + -- copy rule (down) + _hdOo_rename = + _lhsIo_rename + -- copy rule (down) + _hdOtypeSyns = + _lhsItypeSyns + -- copy rule (down) + _hdOuniq = + _lhsIuniq + -- copy rule (down) + _hdOuseMap = + _lhsIuseMap + -- copy rule (down) + _tlOcr = + _lhsIcr + -- copy rule (down) + _tlOmanualAttrOrderMap = + _lhsImanualAttrOrderMap + -- copy rule (down) + _tlOnonterminals = + _lhsInonterminals + -- copy rule (down) + _tlOo_rename = + _lhsIo_rename + -- copy rule (down) + _tlOtypeSyns = + _lhsItypeSyns + -- copy rule (chain) + _tlOuniq = + _hdIuniq + -- copy rule (down) + _tlOuseMap = + _lhsIuseMap + ( _hdIcollect_nts,_hdIerrors,_hdIoutput,_hdIuniq) = + (hd_ _hdOcr _hdOmanualAttrOrderMap _hdOnonterminals _hdOo_rename _hdOtypeSyns _hdOuniq _hdOuseMap) + ( _tlIcollect_nts,_tlIerrors,_tlIoutput,_tlIuniq) = + (tl_ _tlOcr _tlOmanualAttrOrderMap _tlOnonterminals _tlOo_rename _tlOtypeSyns _tlOuniq _tlOuseMap) + in ( _lhsOcollect_nts,_lhsOerrors,_lhsOoutput,_lhsOuniq)))) +sem_Nonterminals_Nil :: T_Nonterminals +sem_Nonterminals_Nil = + (T_Nonterminals (\ _lhsIcr + _lhsImanualAttrOrderMap + _lhsInonterminals + _lhsIo_rename + _lhsItypeSyns + _lhsIuniq + _lhsIuseMap -> + (let _lhsOcollect_nts :: (Set NontermIdent) + _lhsOerrors :: (Seq Error) + _lhsOoutput :: Nonterminals + _lhsOuniq :: Int + -- use rule "DefaultRules.ag"(line 115, column 49) + _lhsOcollect_nts = + Set.empty + -- use rule "DefaultRules.ag"(line 109, column 19) + _lhsOerrors = + Seq.empty + -- self rule + _output = + [] + -- self rule + _lhsOoutput = + _output + -- copy rule (chain) + _lhsOuniq = + _lhsIuniq + in ( _lhsOcollect_nts,_lhsOerrors,_lhsOoutput,_lhsOuniq)))) +-- Pattern ----------------------------------------------------- +{- + visit 0: + inherited attributes: + con : ConstructorIdent + nt : NontermIdent + synthesized attributes: + containsVars : Bool + copy : SELF + definedAttrs : Set (Identifier,Identifier) + errors : Seq Error + locals : Set Identifier + output : SELF + alternatives: + alternative Alias: + child field : {Identifier} + child attr : {Identifier} + child pat : Pattern + child parts : Patterns + visit 0: + local copy : _ + local output : _ + alternative Constr: + child name : {ConstructorIdent} + child pats : Patterns + visit 0: + local copy : _ + local output : _ + alternative Irrefutable: + child pat : Pattern + visit 0: + local copy : _ + local output : _ + alternative Product: + child pos : {Pos} + child pats : Patterns + visit 0: + local copy : _ + local output : _ + alternative Underscore: + child pos : {Pos} + visit 0: + local copy : _ + local output : _ +-} +-- cata +sem_Pattern :: Pattern -> + T_Pattern +sem_Pattern (Alias _field _attr _pat _parts) = + (sem_Pattern_Alias _field _attr (sem_Pattern _pat) (sem_Patterns _parts)) +sem_Pattern (Constr _name _pats) = + (sem_Pattern_Constr _name (sem_Patterns _pats)) +sem_Pattern (Irrefutable _pat) = + (sem_Pattern_Irrefutable (sem_Pattern _pat)) +sem_Pattern (Product _pos _pats) = + (sem_Pattern_Product _pos (sem_Patterns _pats)) +sem_Pattern (Underscore _pos) = + (sem_Pattern_Underscore _pos) +-- semantic domain +newtype T_Pattern = T_Pattern (ConstructorIdent -> + NontermIdent -> + ( Bool,Pattern,(Set (Identifier,Identifier)),(Seq Error),(Set Identifier),Pattern)) +data Inh_Pattern = Inh_Pattern {con_Inh_Pattern :: ConstructorIdent,nt_Inh_Pattern :: NontermIdent} +data Syn_Pattern = Syn_Pattern {containsVars_Syn_Pattern :: Bool,copy_Syn_Pattern :: Pattern,definedAttrs_Syn_Pattern :: Set (Identifier,Identifier),errors_Syn_Pattern :: Seq Error,locals_Syn_Pattern :: Set Identifier,output_Syn_Pattern :: Pattern} +wrap_Pattern (T_Pattern sem) (Inh_Pattern _lhsIcon _lhsInt) = + (let ( _lhsOcontainsVars,_lhsOcopy,_lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput) = + (sem _lhsIcon _lhsInt) + in (Syn_Pattern _lhsOcontainsVars _lhsOcopy _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput)) +sem_Pattern_Alias :: Identifier -> + Identifier -> + T_Pattern -> + T_Patterns -> + T_Pattern +sem_Pattern_Alias field_ attr_ (T_Pattern pat_) (T_Patterns parts_) = + (T_Pattern (\ _lhsIcon + _lhsInt -> + (let _lhsOdefinedAttrs :: (Set (Identifier,Identifier)) + _lhsOlocals :: (Set Identifier) + _lhsOcontainsVars :: Bool + _lhsOerrors :: (Seq Error) + _lhsOcopy :: Pattern + _lhsOoutput :: Pattern + _patOcon :: ConstructorIdent + _patOnt :: NontermIdent + _partsOcon :: ConstructorIdent + _partsOnt :: NontermIdent + _patIcontainsVars :: Bool + _patIcopy :: Pattern + _patIdefinedAttrs :: (Set (Identifier,Identifier)) + _patIerrors :: (Seq Error) + _patIlocals :: (Set Identifier) + _patIoutput :: Pattern + _partsIcontainsVars :: Bool + _partsIcopy :: Patterns + _partsIdefinedAttrs :: (Set (Identifier,Identifier)) + _partsIerrors :: (Seq Error) + _partsIlocals :: (Set Identifier) + _partsIoutput :: Patterns + -- "DefaultRules.ag"(line 401, column 11) + _lhsOdefinedAttrs = + Set.insert (field_,attr_) _patIdefinedAttrs + -- "DefaultRules.ag"(line 401, column 11) + _lhsOlocals = + if field_ == _LOC + then Set.insert attr_ _patIlocals + else _patIlocals + -- "DefaultRules.ag"(line 419, column 16) + _lhsOcontainsVars = + True + -- use rule "DefaultRules.ag"(line 109, column 19) + _lhsOerrors = + _patIerrors Seq.<> _partsIerrors + -- self rule + _copy = + Alias field_ attr_ _patIcopy _partsIcopy + -- self rule + _output = + Alias field_ attr_ _patIoutput _partsIoutput + -- self rule + _lhsOcopy = + _copy + -- self rule + _lhsOoutput = + _output + -- copy rule (down) + _patOcon = + _lhsIcon + -- copy rule (down) + _patOnt = + _lhsInt + -- copy rule (down) + _partsOcon = + _lhsIcon + -- copy rule (down) + _partsOnt = + _lhsInt + ( _patIcontainsVars,_patIcopy,_patIdefinedAttrs,_patIerrors,_patIlocals,_patIoutput) = + (pat_ _patOcon _patOnt) + ( _partsIcontainsVars,_partsIcopy,_partsIdefinedAttrs,_partsIerrors,_partsIlocals,_partsIoutput) = + (parts_ _partsOcon _partsOnt) + in ( _lhsOcontainsVars,_lhsOcopy,_lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput)))) +sem_Pattern_Constr :: ConstructorIdent -> + T_Patterns -> + T_Pattern +sem_Pattern_Constr name_ (T_Patterns pats_) = + (T_Pattern (\ _lhsIcon + _lhsInt -> + (let _lhsOcontainsVars :: Bool + _lhsOdefinedAttrs :: (Set (Identifier,Identifier)) + _lhsOerrors :: (Seq Error) + _lhsOlocals :: (Set Identifier) + _lhsOcopy :: Pattern + _lhsOoutput :: Pattern + _patsOcon :: ConstructorIdent + _patsOnt :: NontermIdent + _patsIcontainsVars :: Bool + _patsIcopy :: Patterns + _patsIdefinedAttrs :: (Set (Identifier,Identifier)) + _patsIerrors :: (Seq Error) + _patsIlocals :: (Set Identifier) + _patsIoutput :: Patterns + -- use rule "DefaultRules.ag"(line 416, column 46) + _lhsOcontainsVars = + _patsIcontainsVars + -- use rule "DefaultRules.ag"(line 396, column 23) + _lhsOdefinedAttrs = + _patsIdefinedAttrs + -- use rule "DefaultRules.ag"(line 109, column 19) + _lhsOerrors = + _patsIerrors + -- use rule "DefaultRules.ag"(line 395, column 23) + _lhsOlocals = + _patsIlocals + -- self rule + _copy = + Constr name_ _patsIcopy + -- self rule + _output = + Constr name_ _patsIoutput + -- self rule + _lhsOcopy = + _copy + -- self rule + _lhsOoutput = + _output + -- copy rule (down) + _patsOcon = + _lhsIcon + -- copy rule (down) + _patsOnt = + _lhsInt + ( _patsIcontainsVars,_patsIcopy,_patsIdefinedAttrs,_patsIerrors,_patsIlocals,_patsIoutput) = + (pats_ _patsOcon _patsOnt) + in ( _lhsOcontainsVars,_lhsOcopy,_lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput)))) +sem_Pattern_Irrefutable :: T_Pattern -> + T_Pattern +sem_Pattern_Irrefutable (T_Pattern pat_) = + (T_Pattern (\ _lhsIcon + _lhsInt -> + (let _lhsOcontainsVars :: Bool + _lhsOdefinedAttrs :: (Set (Identifier,Identifier)) + _lhsOerrors :: (Seq Error) + _lhsOlocals :: (Set Identifier) + _lhsOcopy :: Pattern + _lhsOoutput :: Pattern + _patOcon :: ConstructorIdent + _patOnt :: NontermIdent + _patIcontainsVars :: Bool + _patIcopy :: Pattern + _patIdefinedAttrs :: (Set (Identifier,Identifier)) + _patIerrors :: (Seq Error) + _patIlocals :: (Set Identifier) + _patIoutput :: Pattern + -- use rule "DefaultRules.ag"(line 416, column 46) + _lhsOcontainsVars = + _patIcontainsVars + -- use rule "DefaultRules.ag"(line 396, column 23) + _lhsOdefinedAttrs = + _patIdefinedAttrs + -- use rule "DefaultRules.ag"(line 109, column 19) + _lhsOerrors = + _patIerrors + -- use rule "DefaultRules.ag"(line 395, column 23) + _lhsOlocals = + _patIlocals + -- self rule + _copy = + Irrefutable _patIcopy + -- self rule + _output = + Irrefutable _patIoutput + -- self rule + _lhsOcopy = + _copy + -- self rule + _lhsOoutput = + _output + -- copy rule (down) + _patOcon = + _lhsIcon + -- copy rule (down) + _patOnt = + _lhsInt + ( _patIcontainsVars,_patIcopy,_patIdefinedAttrs,_patIerrors,_patIlocals,_patIoutput) = + (pat_ _patOcon _patOnt) + in ( _lhsOcontainsVars,_lhsOcopy,_lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput)))) +sem_Pattern_Product :: Pos -> + T_Patterns -> + T_Pattern +sem_Pattern_Product pos_ (T_Patterns pats_) = + (T_Pattern (\ _lhsIcon + _lhsInt -> + (let _lhsOcontainsVars :: Bool + _lhsOdefinedAttrs :: (Set (Identifier,Identifier)) + _lhsOerrors :: (Seq Error) + _lhsOlocals :: (Set Identifier) + _lhsOcopy :: Pattern + _lhsOoutput :: Pattern + _patsOcon :: ConstructorIdent + _patsOnt :: NontermIdent + _patsIcontainsVars :: Bool + _patsIcopy :: Patterns + _patsIdefinedAttrs :: (Set (Identifier,Identifier)) + _patsIerrors :: (Seq Error) + _patsIlocals :: (Set Identifier) + _patsIoutput :: Patterns + -- use rule "DefaultRules.ag"(line 416, column 46) + _lhsOcontainsVars = + _patsIcontainsVars + -- use rule "DefaultRules.ag"(line 396, column 23) + _lhsOdefinedAttrs = + _patsIdefinedAttrs + -- use rule "DefaultRules.ag"(line 109, column 19) + _lhsOerrors = + _patsIerrors + -- use rule "DefaultRules.ag"(line 395, column 23) + _lhsOlocals = + _patsIlocals + -- self rule + _copy = + Product pos_ _patsIcopy + -- self rule + _output = + Product pos_ _patsIoutput + -- self rule + _lhsOcopy = + _copy + -- self rule + _lhsOoutput = + _output + -- copy rule (down) + _patsOcon = + _lhsIcon + -- copy rule (down) + _patsOnt = + _lhsInt + ( _patsIcontainsVars,_patsIcopy,_patsIdefinedAttrs,_patsIerrors,_patsIlocals,_patsIoutput) = + (pats_ _patsOcon _patsOnt) + in ( _lhsOcontainsVars,_lhsOcopy,_lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput)))) +sem_Pattern_Underscore :: Pos -> + T_Pattern +sem_Pattern_Underscore pos_ = + (T_Pattern (\ _lhsIcon + _lhsInt -> + (let _lhsOcontainsVars :: Bool + _lhsOdefinedAttrs :: (Set (Identifier,Identifier)) + _lhsOerrors :: (Seq Error) + _lhsOlocals :: (Set Identifier) + _lhsOcopy :: Pattern + _lhsOoutput :: Pattern + -- use rule "DefaultRules.ag"(line 416, column 46) + _lhsOcontainsVars = + False + -- use rule "DefaultRules.ag"(line 396, column 23) + _lhsOdefinedAttrs = + Set.empty + -- use rule "DefaultRules.ag"(line 109, column 19) + _lhsOerrors = + Seq.empty + -- use rule "DefaultRules.ag"(line 395, column 23) + _lhsOlocals = + Set.empty + -- self rule + _copy = + Underscore pos_ + -- self rule + _output = + Underscore pos_ + -- self rule + _lhsOcopy = + _copy + -- self rule + _lhsOoutput = + _output + in ( _lhsOcontainsVars,_lhsOcopy,_lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput)))) +-- Patterns ---------------------------------------------------- +{- + visit 0: + inherited attributes: + con : ConstructorIdent + nt : NontermIdent + synthesized attributes: + containsVars : Bool + copy : SELF + definedAttrs : Set (Identifier,Identifier) + errors : Seq Error + locals : Set Identifier + output : SELF + alternatives: + alternative Cons: + child hd : Pattern + child tl : Patterns + visit 0: + local copy : _ + local output : _ + alternative Nil: + visit 0: + local copy : _ + local output : _ +-} +-- cata +sem_Patterns :: Patterns -> + T_Patterns +sem_Patterns list = + (Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list)) +-- semantic domain +newtype T_Patterns = T_Patterns (ConstructorIdent -> + NontermIdent -> + ( Bool,Patterns,(Set (Identifier,Identifier)),(Seq Error),(Set Identifier),Patterns)) +data Inh_Patterns = Inh_Patterns {con_Inh_Patterns :: ConstructorIdent,nt_Inh_Patterns :: NontermIdent} +data Syn_Patterns = Syn_Patterns {containsVars_Syn_Patterns :: Bool,copy_Syn_Patterns :: Patterns,definedAttrs_Syn_Patterns :: Set (Identifier,Identifier),errors_Syn_Patterns :: Seq Error,locals_Syn_Patterns :: Set Identifier,output_Syn_Patterns :: Patterns} +wrap_Patterns (T_Patterns sem) (Inh_Patterns _lhsIcon _lhsInt) = + (let ( _lhsOcontainsVars,_lhsOcopy,_lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput) = + (sem _lhsIcon _lhsInt) + in (Syn_Patterns _lhsOcontainsVars _lhsOcopy _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput)) +sem_Patterns_Cons :: T_Pattern -> + T_Patterns -> + T_Patterns +sem_Patterns_Cons (T_Pattern hd_) (T_Patterns tl_) = + (T_Patterns (\ _lhsIcon + _lhsInt -> + (let _lhsOcontainsVars :: Bool + _lhsOdefinedAttrs :: (Set (Identifier,Identifier)) + _lhsOerrors :: (Seq Error) + _lhsOlocals :: (Set Identifier) + _lhsOcopy :: Patterns + _lhsOoutput :: Patterns + _hdOcon :: ConstructorIdent + _hdOnt :: NontermIdent + _tlOcon :: ConstructorIdent + _tlOnt :: NontermIdent + _hdIcontainsVars :: Bool + _hdIcopy :: Pattern + _hdIdefinedAttrs :: (Set (Identifier,Identifier)) + _hdIerrors :: (Seq Error) + _hdIlocals :: (Set Identifier) + _hdIoutput :: Pattern + _tlIcontainsVars :: Bool + _tlIcopy :: Patterns + _tlIdefinedAttrs :: (Set (Identifier,Identifier)) + _tlIerrors :: (Seq Error) + _tlIlocals :: (Set Identifier) + _tlIoutput :: Patterns + -- use rule "DefaultRules.ag"(line 416, column 46) + _lhsOcontainsVars = + _hdIcontainsVars || _tlIcontainsVars + -- use rule "DefaultRules.ag"(line 396, column 23) + _lhsOdefinedAttrs = + _hdIdefinedAttrs `Set.union` _tlIdefinedAttrs + -- use rule "DefaultRules.ag"(line 109, column 19) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- use rule "DefaultRules.ag"(line 395, column 23) + _lhsOlocals = + _hdIlocals `Set.union` _tlIlocals + -- self rule + _copy = + (:) _hdIcopy _tlIcopy + -- self rule + _output = + (:) _hdIoutput _tlIoutput + -- self rule + _lhsOcopy = + _copy + -- self rule + _lhsOoutput = + _output + -- copy rule (down) + _hdOcon = + _lhsIcon + -- copy rule (down) + _hdOnt = + _lhsInt + -- copy rule (down) + _tlOcon = + _lhsIcon + -- copy rule (down) + _tlOnt = + _lhsInt + ( _hdIcontainsVars,_hdIcopy,_hdIdefinedAttrs,_hdIerrors,_hdIlocals,_hdIoutput) = + (hd_ _hdOcon _hdOnt) + ( _tlIcontainsVars,_tlIcopy,_tlIdefinedAttrs,_tlIerrors,_tlIlocals,_tlIoutput) = + (tl_ _tlOcon _tlOnt) + in ( _lhsOcontainsVars,_lhsOcopy,_lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput)))) +sem_Patterns_Nil :: T_Patterns +sem_Patterns_Nil = + (T_Patterns (\ _lhsIcon + _lhsInt -> + (let _lhsOcontainsVars :: Bool + _lhsOdefinedAttrs :: (Set (Identifier,Identifier)) + _lhsOerrors :: (Seq Error) + _lhsOlocals :: (Set Identifier) + _lhsOcopy :: Patterns + _lhsOoutput :: Patterns + -- use rule "DefaultRules.ag"(line 416, column 46) + _lhsOcontainsVars = + False + -- use rule "DefaultRules.ag"(line 396, column 23) + _lhsOdefinedAttrs = + Set.empty + -- use rule "DefaultRules.ag"(line 109, column 19) + _lhsOerrors = + Seq.empty + -- use rule "DefaultRules.ag"(line 395, column 23) + _lhsOlocals = + Set.empty + -- self rule + _copy = + [] + -- self rule + _output = + [] + -- self rule + _lhsOcopy = + _copy + -- self rule + _lhsOoutput = + _output + in ( _lhsOcontainsVars,_lhsOcopy,_lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput)))) +-- Production -------------------------------------------------- +{- + visit 0: + inherited attributes: + cr : Bool + inh : Attributes + manualAttrOrderMap : AttrOrderMap + nonterminals : Set NontermIdent + nt : NontermIdent + o_rename : Bool + syn : Attributes + typeSyns : TypeSyns + useMap : Map Identifier (String,String,String) + chained attribute: + uniq : Int + synthesized attributes: + errors : Seq Error + output : SELF + alternatives: + alternative Production: + child con : {ConstructorIdent} + child children : Children + child rules : Rules + child typeSigs : TypeSigs + visit 0: + local _tup1 : _ + local newRls : _ + local errs : _ + local orderDeps : _ + local orderErrs : _ + local output : _ +-} +-- cata +sem_Production :: Production -> + T_Production +sem_Production (Production _con _children _rules _typeSigs) = + (sem_Production_Production _con (sem_Children _children) (sem_Rules _rules) (sem_TypeSigs _typeSigs)) +-- semantic domain +newtype T_Production = T_Production (Bool -> + Attributes -> + AttrOrderMap -> + (Set NontermIdent) -> + NontermIdent -> + Bool -> + Attributes -> + TypeSyns -> + Int -> + (Map Identifier (String,String,String)) -> + ( (Seq Error),Production,Int)) +data Inh_Production = Inh_Production {cr_Inh_Production :: Bool,inh_Inh_Production :: Attributes,manualAttrOrderMap_Inh_Production :: AttrOrderMap,nonterminals_Inh_Production :: Set NontermIdent,nt_Inh_Production :: NontermIdent,o_rename_Inh_Production :: Bool,syn_Inh_Production :: Attributes,typeSyns_Inh_Production :: TypeSyns,uniq_Inh_Production :: Int,useMap_Inh_Production :: Map Identifier (String,String,String)} +data Syn_Production = Syn_Production {errors_Syn_Production :: Seq Error,output_Syn_Production :: Production,uniq_Syn_Production :: Int} +wrap_Production (T_Production sem) (Inh_Production _lhsIcr _lhsIinh _lhsImanualAttrOrderMap _lhsInonterminals _lhsInt _lhsIo_rename _lhsIsyn _lhsItypeSyns _lhsIuniq _lhsIuseMap) = + (let ( _lhsOerrors,_lhsOoutput,_lhsOuniq) = + (sem _lhsIcr _lhsIinh _lhsImanualAttrOrderMap _lhsInonterminals _lhsInt _lhsIo_rename _lhsIsyn _lhsItypeSyns _lhsIuniq _lhsIuseMap) + in (Syn_Production _lhsOerrors _lhsOoutput _lhsOuniq)) +sem_Production_Production :: ConstructorIdent -> + T_Children -> + T_Rules -> + T_TypeSigs -> + T_Production +sem_Production_Production con_ (T_Children children_) (T_Rules rules_) (T_TypeSigs typeSigs_) = + (T_Production (\ _lhsIcr + _lhsIinh + _lhsImanualAttrOrderMap + _lhsInonterminals + _lhsInt + _lhsIo_rename + _lhsIsyn + _lhsItypeSyns + _lhsIuniq + _lhsIuseMap -> + (let _rulesOcon :: ConstructorIdent + _childrenOcon :: ConstructorIdent + _lhsOerrors :: (Seq Error) + _lhsOoutput :: Production + _lhsOuniq :: Int + _childrenOcr :: Bool + _childrenOnt :: NontermIdent + _rulesOnt :: NontermIdent + _rulesOuniq :: Int + _childrenIerrors :: (Seq Error) + _childrenIfields :: ([(Identifier,Type,Bool)]) + _childrenIinputs :: ([(Identifier, Attributes)]) + _childrenIoutput :: Children + _childrenIoutputs :: ([(Identifier, Attributes)]) + _rulesIdefinedAttrs :: (Set (Identifier,Identifier)) + _rulesIerrors :: (Seq Error) + _rulesIlocals :: (Set Identifier) + _rulesIoutput :: Rules + _rulesIuniq :: Int + _typeSigsIoutput :: TypeSigs + -- "DefaultRules.ag"(line 137, column 16) + _rulesOcon = + con_ + -- "DefaultRules.ag"(line 138, column 17) + _childrenOcon = + con_ + -- "DefaultRules.ag"(line 320, column 4) + _lhsOerrors = + _childrenIerrors <> _errs <> _rulesIerrors <> _orderErrs + -- "DefaultRules.ag"(line 322, column 8) + __tup1 = + let locals = _rulesIlocals + initenv = Map.fromList ( [ (a,_ACHILD) + | (a,_,_) <- _childrenIfields + ] + ++ attrs(_LHS, _lhsIinh) + ++ [ (a,_LOC) + | a <- Set.toList locals + ] + ) + attrs (n,as) = [ (a,n) | a <- Map.keys as ] + envs = scanl (flip Map.union) + initenv + (map (Map.fromList . attrs ) _childrenIoutputs) + child_envs = init envs + lhs_env = last envs + (selfAttrs, normalAttrs) + = Map.partition isSELFNonterminal _lhsIsyn + (_,undefAttrs) + = removeDefined _rulesIdefinedAttrs (_LHS, normalAttrs) + (useAttrs,others) + = splitAttrs _lhsIuseMap undefAttrs + (rules1, errors1) + = concatRE $ map (copyRule _lhsInt con_ _lhsIcr locals) + (zip envs (map (removeDefined _rulesIdefinedAttrs) _childrenIinputs)) + uRules + = map (useRule locals _childrenIoutputs) useAttrs + selfLocRules + = [ selfRule False attr (constructor [childSelf attr nm tp | (nm,tp,ho) <- _childrenIfields, not ho]) + | attr <- Map.keys selfAttrs + , not (Set.member attr locals) + ] + where + childSelf self nm tp + = case tp of NT nt _ -> attrName nm self + _ | nm `Set.member` locals -> locname nm + | otherwise -> fieldName nm + constructor fs + | getName con_ == "Tuple" && _lhsInt `elem` map fst _lhsItypeSyns + = "(" ++ concat (List.intersperse "," fs) ++ ")" + | otherwise + = getConName _lhsItypeSyns _lhsIo_rename _lhsInt con_ ++ " " ++ unwords fs + selfRules + = [ selfRule True attr undefined + | attr <- Map.keys selfAttrs + , not (Set.member (_LHS,attr) _rulesIdefinedAttrs) + ] + (rules5, errs5) + = copyRule _lhsInt + con_ + _lhsIcr + locals + (lhs_env, (_LHS, others)) + in (uRules++selfLocRules++selfRules++rules5++rules1, errors1<>errs5) + -- "DefaultRules.ag"(line 322, column 8) + (_newRls,_) = + __tup1 + -- "DefaultRules.ag"(line 322, column 8) + (_,_errs) = + __tup1 + -- "DefaultRules.ag"(line 438, column 16) + _lhsOoutput = + Production con_ _childrenIoutput (_rulesIoutput ++ _newRls) _typeSigsIoutput + -- "DefaultRules.ag"(line 510, column 7) + _orderDeps = + Set.toList $ Map.findWithDefault Set.empty con_ $ Map.findWithDefault Map.empty _lhsInt _lhsImanualAttrOrderMap + -- "DefaultRules.ag"(line 512, column 7) + _orderErrs = + let chldOutMap = Map.fromList [ (k, Map.keysSet s) | (k,s) <- _childrenIoutputs ] + chldInMap = Map.fromList [ (k, Map.keysSet s) | (k,s) <- _childrenIinputs ] + isInAttribute :: Identifier -> Identifier -> [Error] + isInAttribute fld nm + | fld == _LOC = if nm `Set.member` _rulesIlocals + then [] + else [UndefAttr _lhsInt con_ fld nm False] + | fld == _LHS = if nm `Map.member` _lhsIinh + then [] + else [UndefAttr _lhsInt con_ fld nm False] + | otherwise = if nm `Set.member` (Map.findWithDefault Set.empty fld chldOutMap) + then [] + else [UndefAttr _lhsInt con_ fld nm False] + isOutAttribute :: Identifier -> Identifier -> [Error] + isOutAttribute fld nm + | fld == _LOC = if nm `Set.member` _rulesIlocals + then [] + else [UndefAttr _lhsInt con_ fld nm True] + | fld == _LHS = if nm `Map.member` _lhsIsyn + then [] + else [UndefAttr _lhsInt con_ fld nm True] + | otherwise = if nm `Set.member` (Map.findWithDefault Set.empty fld chldInMap) + then [] + else [UndefAttr _lhsInt con_ fld nm True] + in Seq.fromList . concat $ + [ isInAttribute fldA nmA ++ isOutAttribute fldB nmB + | dep@(Dependency (fldA,nmA) (fldB,nmB)) <- _orderDeps + ] + -- self rule + _output = + Production con_ _childrenIoutput _rulesIoutput _typeSigsIoutput + -- copy rule (up) + _lhsOuniq = + _rulesIuniq + -- copy rule (down) + _childrenOcr = + _lhsIcr + -- copy rule (down) + _childrenOnt = + _lhsInt + -- copy rule (down) + _rulesOnt = + _lhsInt + -- copy rule (down) + _rulesOuniq = + _lhsIuniq + ( _childrenIerrors,_childrenIfields,_childrenIinputs,_childrenIoutput,_childrenIoutputs) = + (children_ _childrenOcon _childrenOcr _childrenOnt) + ( _rulesIdefinedAttrs,_rulesIerrors,_rulesIlocals,_rulesIoutput,_rulesIuniq) = + (rules_ _rulesOcon _rulesOnt _rulesOuniq) + ( _typeSigsIoutput) = + (typeSigs_ ) + in ( _lhsOerrors,_lhsOoutput,_lhsOuniq)))) +-- Productions ------------------------------------------------- +{- + visit 0: + inherited attributes: + cr : Bool + inh : Attributes + manualAttrOrderMap : AttrOrderMap + nonterminals : Set NontermIdent + nt : NontermIdent + o_rename : Bool + syn : Attributes + typeSyns : TypeSyns + useMap : Map Identifier (String,String,String) + chained attribute: + uniq : Int + synthesized attributes: + errors : Seq Error + output : SELF + alternatives: + alternative Cons: + child hd : Production + child tl : Productions + visit 0: + local output : _ + alternative Nil: + visit 0: + local output : _ +-} +-- cata +sem_Productions :: Productions -> + T_Productions +sem_Productions list = + (Prelude.foldr sem_Productions_Cons sem_Productions_Nil (Prelude.map sem_Production list)) +-- semantic domain +newtype T_Productions = T_Productions (Bool -> + Attributes -> + AttrOrderMap -> + (Set NontermIdent) -> + NontermIdent -> + Bool -> + Attributes -> + TypeSyns -> + Int -> + (Map Identifier (String,String,String)) -> + ( (Seq Error),Productions,Int)) +data Inh_Productions = Inh_Productions {cr_Inh_Productions :: Bool,inh_Inh_Productions :: Attributes,manualAttrOrderMap_Inh_Productions :: AttrOrderMap,nonterminals_Inh_Productions :: Set NontermIdent,nt_Inh_Productions :: NontermIdent,o_rename_Inh_Productions :: Bool,syn_Inh_Productions :: Attributes,typeSyns_Inh_Productions :: TypeSyns,uniq_Inh_Productions :: Int,useMap_Inh_Productions :: Map Identifier (String,String,String)} +data Syn_Productions = Syn_Productions {errors_Syn_Productions :: Seq Error,output_Syn_Productions :: Productions,uniq_Syn_Productions :: Int} +wrap_Productions (T_Productions sem) (Inh_Productions _lhsIcr _lhsIinh _lhsImanualAttrOrderMap _lhsInonterminals _lhsInt _lhsIo_rename _lhsIsyn _lhsItypeSyns _lhsIuniq _lhsIuseMap) = + (let ( _lhsOerrors,_lhsOoutput,_lhsOuniq) = + (sem _lhsIcr _lhsIinh _lhsImanualAttrOrderMap _lhsInonterminals _lhsInt _lhsIo_rename _lhsIsyn _lhsItypeSyns _lhsIuniq _lhsIuseMap) + in (Syn_Productions _lhsOerrors _lhsOoutput _lhsOuniq)) +sem_Productions_Cons :: T_Production -> + T_Productions -> + T_Productions +sem_Productions_Cons (T_Production hd_) (T_Productions tl_) = + (T_Productions (\ _lhsIcr + _lhsIinh + _lhsImanualAttrOrderMap + _lhsInonterminals + _lhsInt + _lhsIo_rename + _lhsIsyn + _lhsItypeSyns + _lhsIuniq + _lhsIuseMap -> + (let _lhsOerrors :: (Seq Error) + _lhsOoutput :: Productions + _lhsOuniq :: Int + _hdOcr :: Bool + _hdOinh :: Attributes + _hdOmanualAttrOrderMap :: AttrOrderMap + _hdOnonterminals :: (Set NontermIdent) + _hdOnt :: NontermIdent + _hdOo_rename :: Bool + _hdOsyn :: Attributes + _hdOtypeSyns :: TypeSyns + _hdOuniq :: Int + _hdOuseMap :: (Map Identifier (String,String,String)) + _tlOcr :: Bool + _tlOinh :: Attributes + _tlOmanualAttrOrderMap :: AttrOrderMap + _tlOnonterminals :: (Set NontermIdent) + _tlOnt :: NontermIdent + _tlOo_rename :: Bool + _tlOsyn :: Attributes + _tlOtypeSyns :: TypeSyns + _tlOuniq :: Int + _tlOuseMap :: (Map Identifier (String,String,String)) + _hdIerrors :: (Seq Error) + _hdIoutput :: Production + _hdIuniq :: Int + _tlIerrors :: (Seq Error) + _tlIoutput :: Productions + _tlIuniq :: Int + -- use rule "DefaultRules.ag"(line 109, column 19) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- self rule + _output = + (:) _hdIoutput _tlIoutput + -- self rule + _lhsOoutput = + _output + -- copy rule (up) + _lhsOuniq = + _tlIuniq + -- copy rule (down) + _hdOcr = + _lhsIcr + -- copy rule (down) + _hdOinh = + _lhsIinh + -- copy rule (down) + _hdOmanualAttrOrderMap = + _lhsImanualAttrOrderMap + -- copy rule (down) + _hdOnonterminals = + _lhsInonterminals + -- copy rule (down) + _hdOnt = + _lhsInt + -- copy rule (down) + _hdOo_rename = + _lhsIo_rename + -- copy rule (down) + _hdOsyn = + _lhsIsyn + -- copy rule (down) + _hdOtypeSyns = + _lhsItypeSyns + -- copy rule (down) + _hdOuniq = + _lhsIuniq + -- copy rule (down) + _hdOuseMap = + _lhsIuseMap + -- copy rule (down) + _tlOcr = + _lhsIcr + -- copy rule (down) + _tlOinh = + _lhsIinh + -- copy rule (down) + _tlOmanualAttrOrderMap = + _lhsImanualAttrOrderMap + -- copy rule (down) + _tlOnonterminals = + _lhsInonterminals + -- copy rule (down) + _tlOnt = + _lhsInt + -- copy rule (down) + _tlOo_rename = + _lhsIo_rename + -- copy rule (down) + _tlOsyn = + _lhsIsyn + -- copy rule (down) + _tlOtypeSyns = + _lhsItypeSyns + -- copy rule (chain) + _tlOuniq = + _hdIuniq + -- copy rule (down) + _tlOuseMap = + _lhsIuseMap + ( _hdIerrors,_hdIoutput,_hdIuniq) = + (hd_ _hdOcr _hdOinh _hdOmanualAttrOrderMap _hdOnonterminals _hdOnt _hdOo_rename _hdOsyn _hdOtypeSyns _hdOuniq _hdOuseMap) + ( _tlIerrors,_tlIoutput,_tlIuniq) = + (tl_ _tlOcr _tlOinh _tlOmanualAttrOrderMap _tlOnonterminals _tlOnt _tlOo_rename _tlOsyn _tlOtypeSyns _tlOuniq _tlOuseMap) + in ( _lhsOerrors,_lhsOoutput,_lhsOuniq)))) +sem_Productions_Nil :: T_Productions +sem_Productions_Nil = + (T_Productions (\ _lhsIcr + _lhsIinh + _lhsImanualAttrOrderMap + _lhsInonterminals + _lhsInt + _lhsIo_rename + _lhsIsyn + _lhsItypeSyns + _lhsIuniq + _lhsIuseMap -> + (let _lhsOerrors :: (Seq Error) + _lhsOoutput :: Productions + _lhsOuniq :: Int + -- use rule "DefaultRules.ag"(line 109, column 19) + _lhsOerrors = + Seq.empty + -- self rule + _output = + [] + -- self rule + _lhsOoutput = + _output + -- copy rule (chain) + _lhsOuniq = + _lhsIuniq + in ( _lhsOerrors,_lhsOoutput,_lhsOuniq)))) +-- Rule -------------------------------------------------------- +{- + visit 0: + inherited attributes: + con : ConstructorIdent + nt : NontermIdent + chained attribute: + uniq : Int + synthesized attributes: + containsVars : Bool + definedAttrs : Set (Identifier,Identifier) + errors : Seq Error + locals : Set Identifier + output : SELF + outputs : Rules + alternatives: + alternative Rule: + child pattern : Pattern + child rhs : {Expression} + child owrt : {Bool} + child origin : {String} + visit 0: + local _tup2 : {(Rules,Int)} + local output : _ +-} +-- cata +sem_Rule :: Rule -> + T_Rule +sem_Rule (Rule _pattern _rhs _owrt _origin) = + (sem_Rule_Rule (sem_Pattern _pattern) _rhs _owrt _origin) +-- semantic domain +newtype T_Rule = T_Rule (ConstructorIdent -> + NontermIdent -> + Int -> + ( Bool,(Set (Identifier,Identifier)),(Seq Error),(Set Identifier),Rule,Rules,Int)) +data Inh_Rule = Inh_Rule {con_Inh_Rule :: ConstructorIdent,nt_Inh_Rule :: NontermIdent,uniq_Inh_Rule :: Int} +data Syn_Rule = Syn_Rule {containsVars_Syn_Rule :: Bool,definedAttrs_Syn_Rule :: Set (Identifier,Identifier),errors_Syn_Rule :: Seq Error,locals_Syn_Rule :: Set Identifier,output_Syn_Rule :: Rule,outputs_Syn_Rule :: Rules,uniq_Syn_Rule :: Int} +wrap_Rule (T_Rule sem) (Inh_Rule _lhsIcon _lhsInt _lhsIuniq) = + (let ( _lhsOcontainsVars,_lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput,_lhsOoutputs,_lhsOuniq) = + (sem _lhsIcon _lhsInt _lhsIuniq) + in (Syn_Rule _lhsOcontainsVars _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput _lhsOoutputs _lhsOuniq)) +sem_Rule_Rule :: T_Pattern -> + Expression -> + Bool -> + String -> + T_Rule +sem_Rule_Rule (T_Pattern pattern_) rhs_ owrt_ origin_ = + (T_Rule (\ _lhsIcon + _lhsInt + _lhsIuniq -> + (let __tup2 :: ((Rules,Int)) + _lhsOoutputs :: Rules + _lhsOuniq :: Int + _lhsOcontainsVars :: Bool + _lhsOdefinedAttrs :: (Set (Identifier,Identifier)) + _lhsOerrors :: (Seq Error) + _lhsOlocals :: (Set Identifier) + _lhsOoutput :: Rule + _patternOcon :: ConstructorIdent + _patternOnt :: NontermIdent + _patternIcontainsVars :: Bool + _patternIcopy :: Pattern + _patternIdefinedAttrs :: (Set (Identifier,Identifier)) + _patternIerrors :: (Seq Error) + _patternIlocals :: (Set Identifier) + _patternIoutput :: Pattern + -- "DefaultRules.ag"(line 445, column 11) + __tup2 = + multiRule _output _lhsIuniq + -- "DefaultRules.ag"(line 445, column 11) + (_lhsOoutputs,_) = + __tup2 + -- "DefaultRules.ag"(line 445, column 11) + (_,_lhsOuniq) = + __tup2 + -- use rule "DefaultRules.ag"(line 416, column 46) + _lhsOcontainsVars = + _patternIcontainsVars + -- use rule "DefaultRules.ag"(line 396, column 23) + _lhsOdefinedAttrs = + _patternIdefinedAttrs + -- use rule "DefaultRules.ag"(line 109, column 19) + _lhsOerrors = + _patternIerrors + -- use rule "DefaultRules.ag"(line 395, column 23) + _lhsOlocals = + _patternIlocals + -- self rule + _output = + Rule _patternIoutput rhs_ owrt_ origin_ + -- self rule + _lhsOoutput = + _output + -- copy rule (down) + _patternOcon = + _lhsIcon + -- copy rule (down) + _patternOnt = + _lhsInt + ( _patternIcontainsVars,_patternIcopy,_patternIdefinedAttrs,_patternIerrors,_patternIlocals,_patternIoutput) = + (pattern_ _patternOcon _patternOnt) + in ( _lhsOcontainsVars,_lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput,_lhsOoutputs,_lhsOuniq)))) +-- Rules ------------------------------------------------------- +{- + visit 0: + inherited attributes: + con : ConstructorIdent + nt : NontermIdent + chained attribute: + uniq : Int + synthesized attributes: + definedAttrs : Set (Identifier,Identifier) + errors : Seq Error + locals : Set Identifier + output : SELF + alternatives: + alternative Cons: + child hd : Rule + child tl : Rules + visit 0: + local output : _ + alternative Nil: + visit 0: + local output : _ +-} +-- cata +sem_Rules :: Rules -> + T_Rules +sem_Rules list = + (Prelude.foldr sem_Rules_Cons sem_Rules_Nil (Prelude.map sem_Rule list)) +-- semantic domain +newtype T_Rules = T_Rules (ConstructorIdent -> + NontermIdent -> + Int -> + ( (Set (Identifier,Identifier)),(Seq Error),(Set Identifier),Rules,Int)) +data Inh_Rules = Inh_Rules {con_Inh_Rules :: ConstructorIdent,nt_Inh_Rules :: NontermIdent,uniq_Inh_Rules :: Int} +data Syn_Rules = Syn_Rules {definedAttrs_Syn_Rules :: Set (Identifier,Identifier),errors_Syn_Rules :: Seq Error,locals_Syn_Rules :: Set Identifier,output_Syn_Rules :: Rules,uniq_Syn_Rules :: Int} +wrap_Rules (T_Rules sem) (Inh_Rules _lhsIcon _lhsInt _lhsIuniq) = + (let ( _lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput,_lhsOuniq) = + (sem _lhsIcon _lhsInt _lhsIuniq) + in (Syn_Rules _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput _lhsOuniq)) +sem_Rules_Cons :: T_Rule -> + T_Rules -> + T_Rules +sem_Rules_Cons (T_Rule hd_) (T_Rules tl_) = + (T_Rules (\ _lhsIcon + _lhsInt + _lhsIuniq -> + (let _lhsOoutput :: Rules + _lhsOdefinedAttrs :: (Set (Identifier,Identifier)) + _lhsOerrors :: (Seq Error) + _lhsOlocals :: (Set Identifier) + _lhsOuniq :: Int + _hdOcon :: ConstructorIdent + _hdOnt :: NontermIdent + _hdOuniq :: Int + _tlOcon :: ConstructorIdent + _tlOnt :: NontermIdent + _tlOuniq :: Int + _hdIcontainsVars :: Bool + _hdIdefinedAttrs :: (Set (Identifier,Identifier)) + _hdIerrors :: (Seq Error) + _hdIlocals :: (Set Identifier) + _hdIoutput :: Rule + _hdIoutputs :: Rules + _hdIuniq :: Int + _tlIdefinedAttrs :: (Set (Identifier,Identifier)) + _tlIerrors :: (Seq Error) + _tlIlocals :: (Set Identifier) + _tlIoutput :: Rules + _tlIuniq :: Int + -- "DefaultRules.ag"(line 441, column 10) + _lhsOoutput = + if _hdIcontainsVars then _hdIoutputs ++ _tlIoutput else _tlIoutput + -- use rule "DefaultRules.ag"(line 396, column 23) + _lhsOdefinedAttrs = + _hdIdefinedAttrs `Set.union` _tlIdefinedAttrs + -- use rule "DefaultRules.ag"(line 109, column 19) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- use rule "DefaultRules.ag"(line 395, column 23) + _lhsOlocals = + _hdIlocals `Set.union` _tlIlocals + -- self rule + _output = + (:) _hdIoutput _tlIoutput + -- copy rule (up) + _lhsOuniq = + _tlIuniq + -- copy rule (down) + _hdOcon = + _lhsIcon + -- copy rule (down) + _hdOnt = + _lhsInt + -- copy rule (down) + _hdOuniq = + _lhsIuniq + -- copy rule (down) + _tlOcon = + _lhsIcon + -- copy rule (down) + _tlOnt = + _lhsInt + -- copy rule (chain) + _tlOuniq = + _hdIuniq + ( _hdIcontainsVars,_hdIdefinedAttrs,_hdIerrors,_hdIlocals,_hdIoutput,_hdIoutputs,_hdIuniq) = + (hd_ _hdOcon _hdOnt _hdOuniq) + ( _tlIdefinedAttrs,_tlIerrors,_tlIlocals,_tlIoutput,_tlIuniq) = + (tl_ _tlOcon _tlOnt _tlOuniq) + in ( _lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput,_lhsOuniq)))) +sem_Rules_Nil :: T_Rules +sem_Rules_Nil = + (T_Rules (\ _lhsIcon + _lhsInt + _lhsIuniq -> + (let _lhsOdefinedAttrs :: (Set (Identifier,Identifier)) + _lhsOerrors :: (Seq Error) + _lhsOlocals :: (Set Identifier) + _lhsOoutput :: Rules + _lhsOuniq :: Int + -- use rule "DefaultRules.ag"(line 396, column 23) + _lhsOdefinedAttrs = + Set.empty + -- use rule "DefaultRules.ag"(line 109, column 19) + _lhsOerrors = + Seq.empty + -- use rule "DefaultRules.ag"(line 395, column 23) + _lhsOlocals = + Set.empty + -- self rule + _output = + [] + -- self rule + _lhsOoutput = + _output + -- copy rule (chain) + _lhsOuniq = + _lhsIuniq + in ( _lhsOdefinedAttrs,_lhsOerrors,_lhsOlocals,_lhsOoutput,_lhsOuniq)))) +-- TypeSig ----------------------------------------------------- +{- + visit 0: + synthesized attribute: + output : SELF + alternatives: + alternative TypeSig: + child name : {Identifier} + child tp : {Type} + visit 0: + local output : _ +-} +-- cata +sem_TypeSig :: TypeSig -> + T_TypeSig +sem_TypeSig (TypeSig _name _tp) = + (sem_TypeSig_TypeSig _name _tp) +-- semantic domain +newtype T_TypeSig = T_TypeSig (( TypeSig)) +data Inh_TypeSig = Inh_TypeSig {} +data Syn_TypeSig = Syn_TypeSig {output_Syn_TypeSig :: TypeSig} +wrap_TypeSig (T_TypeSig sem) (Inh_TypeSig ) = + (let ( _lhsOoutput) = + (sem ) + in (Syn_TypeSig _lhsOoutput)) +sem_TypeSig_TypeSig :: Identifier -> + Type -> + T_TypeSig +sem_TypeSig_TypeSig name_ tp_ = + (T_TypeSig (let _lhsOoutput :: TypeSig + -- self rule + _output = + TypeSig name_ tp_ + -- self rule + _lhsOoutput = + _output + in ( _lhsOoutput))) +-- TypeSigs ---------------------------------------------------- +{- + visit 0: + synthesized attribute: + output : SELF + alternatives: + alternative Cons: + child hd : TypeSig + child tl : TypeSigs + visit 0: + local output : _ + alternative Nil: + visit 0: + local output : _ +-} +-- cata +sem_TypeSigs :: TypeSigs -> + T_TypeSigs +sem_TypeSigs list = + (Prelude.foldr sem_TypeSigs_Cons sem_TypeSigs_Nil (Prelude.map sem_TypeSig list)) +-- semantic domain +newtype T_TypeSigs = T_TypeSigs (( TypeSigs)) +data Inh_TypeSigs = Inh_TypeSigs {} +data Syn_TypeSigs = Syn_TypeSigs {output_Syn_TypeSigs :: TypeSigs} +wrap_TypeSigs (T_TypeSigs sem) (Inh_TypeSigs ) = + (let ( _lhsOoutput) = + (sem ) + in (Syn_TypeSigs _lhsOoutput)) +sem_TypeSigs_Cons :: T_TypeSig -> + T_TypeSigs -> + T_TypeSigs +sem_TypeSigs_Cons (T_TypeSig hd_) (T_TypeSigs tl_) = + (T_TypeSigs (let _lhsOoutput :: TypeSigs + _hdIoutput :: TypeSig + _tlIoutput :: TypeSigs + -- self rule + _output = + (:) _hdIoutput _tlIoutput + -- self rule + _lhsOoutput = + _output + ( _hdIoutput) = + (hd_ ) + ( _tlIoutput) = + (tl_ ) + in ( _lhsOoutput))) +sem_TypeSigs_Nil :: T_TypeSigs +sem_TypeSigs_Nil = + (T_TypeSigs (let _lhsOoutput :: TypeSigs + -- self rule + _output = + [] + -- self rule + _lhsOoutput = + _output + in ( _lhsOoutput))) diff --git a/src-derived/Desugar.hs b/src-derived/Desugar.hs --- a/src-derived/Desugar.hs +++ b/src-derived/Desugar.hs @@ -1,1837 +1,2279 @@ - --- UUAGC 0.9.5 (Desugar.ag) -module Desugar where - -import qualified Data.Set as Set -import qualified Data.Map as Map -import Data.Map(Map) -import qualified UU.DData.Seq as Seq -import UU.DData.Seq(Seq,(<>)) -import UU.Scanner.Position(Pos(..)) -import Maybe - -import AbstractSyntax -import ErrorMessages -import Options -import HsToken -import HsTokenScanner -import TokenDef - --- AbstractSyntax.ag imports -import Data.Set(Set) -import Data.Map(Map) -import Patterns (Pattern(..),Patterns) -import Expression (Expression(..)) -import CommonTypes - --- Patterns.ag imports -import UU.Scanner.Position(Pos) -import CommonTypes (Constructor,Name) - -import UU.Scanner.Position(Pos) - -import CommonTypes -import UU.Scanner.Position(Pos) - -addl :: Int -> Pos -> Pos -addl n (Pos l c f) = Pos (l+n) c f - -maybeError :: a -> Error -> Maybe a -> (a, Seq Error) -maybeError def err mb - = maybe (def, Seq.single err) (\r -> (r, Seq.empty)) mb - -findField :: Name -> Name -> [(Name,Name)] -> Maybe Name -findField fld attr list - | fld == _FIRST = f list - | fld == _LAST = f (reverse list) - | otherwise = Just fld - where - f = lookup attr --- Alternative ------------------------------------------------- -{- - visit 0: - inherited attribute: - nt : Nonterminal - synthesized attributes: - errors : Seq Error - output : SELF - alternatives: - alternative Alternative: - child con : {Constructor} - child children : Children - child rules : Rules - child typeSigs : TypeSigs - visit 0: - local output : _ --} --- cata -sem_Alternative :: Alternative -> - T_Alternative -sem_Alternative (Alternative _con _children _rules _typeSigs ) = - (sem_Alternative_Alternative _con (sem_Children _children ) (sem_Rules _rules ) (sem_TypeSigs _typeSigs ) ) --- semantic domain -newtype T_Alternative = T_Alternative (Nonterminal -> - ( (Seq Error),Alternative)) -data Inh_Alternative = Inh_Alternative {nt_Inh_Alternative :: Nonterminal} -data Syn_Alternative = Syn_Alternative {errors_Syn_Alternative :: Seq Error,output_Syn_Alternative :: Alternative} -wrap_Alternative (T_Alternative sem ) (Inh_Alternative _lhsInt ) = - (let ( _lhsOerrors,_lhsOoutput) = - (sem _lhsInt ) - in (Syn_Alternative _lhsOerrors _lhsOoutput )) -sem_Alternative_Alternative :: Constructor -> - T_Children -> - T_Rules -> - T_TypeSigs -> - T_Alternative -sem_Alternative_Alternative con_ (T_Children children_ ) (T_Rules rules_ ) (T_TypeSigs typeSigs_ ) = - (T_Alternative (\ _lhsInt -> - (let _rulesOcon :: Constructor - _rulesOdefs :: (Set (Name, Name)) - _lhsOerrors :: (Seq Error) - _lhsOoutput :: Alternative - _rulesOchildInhs :: ([(Name, Name)]) - _rulesOchildSyns :: ([(Name, Name)]) - _rulesOnt :: Nonterminal - _childrenIchildInhs :: ([(Name, Name)]) - _childrenIchildSyns :: ([(Name, Name)]) - _childrenIoutput :: Children - _rulesIdefsCollect :: (Set (Name, Name)) - _rulesIerrors :: (Seq Error) - _rulesIoutput :: Rules - _typeSigsIoutput :: TypeSigs - -- "Desugar.ag"(line 149, column 7) - _rulesOcon = - con_ - -- "Desugar.ag"(line 165, column 7) - _rulesOdefs = - _rulesIdefsCollect - -- use rule "Desugar.ag"(line 30, column 144) - _lhsOerrors = - _rulesIerrors - -- self rule - _output = - Alternative con_ _childrenIoutput _rulesIoutput _typeSigsIoutput - -- self rule - _lhsOoutput = - _output - -- copy rule (chain) - _rulesOchildInhs = - _childrenIchildInhs - -- copy rule (chain) - _rulesOchildSyns = - _childrenIchildSyns - -- copy rule (down) - _rulesOnt = - _lhsInt - ( _childrenIchildInhs,_childrenIchildSyns,_childrenIoutput) = - (children_ ) - ( _rulesIdefsCollect,_rulesIerrors,_rulesIoutput) = - (rules_ _rulesOchildInhs _rulesOchildSyns _rulesOcon _rulesOdefs _rulesOnt ) - ( _typeSigsIoutput) = - (typeSigs_ ) - in ( _lhsOerrors,_lhsOoutput))) ) --- Alternatives ------------------------------------------------ -{- - visit 0: - inherited attribute: - nt : Nonterminal - synthesized attributes: - errors : Seq Error - output : SELF - alternatives: - alternative Cons: - child hd : Alternative - child tl : Alternatives - visit 0: - local output : _ - alternative Nil: - visit 0: - local output : _ --} --- cata -sem_Alternatives :: Alternatives -> - T_Alternatives -sem_Alternatives list = - (Prelude.foldr sem_Alternatives_Cons sem_Alternatives_Nil (Prelude.map sem_Alternative list) ) --- semantic domain -newtype T_Alternatives = T_Alternatives (Nonterminal -> - ( (Seq Error),Alternatives)) -data Inh_Alternatives = Inh_Alternatives {nt_Inh_Alternatives :: Nonterminal} -data Syn_Alternatives = Syn_Alternatives {errors_Syn_Alternatives :: Seq Error,output_Syn_Alternatives :: Alternatives} -wrap_Alternatives (T_Alternatives sem ) (Inh_Alternatives _lhsInt ) = - (let ( _lhsOerrors,_lhsOoutput) = - (sem _lhsInt ) - in (Syn_Alternatives _lhsOerrors _lhsOoutput )) -sem_Alternatives_Cons :: T_Alternative -> - T_Alternatives -> - T_Alternatives -sem_Alternatives_Cons (T_Alternative hd_ ) (T_Alternatives tl_ ) = - (T_Alternatives (\ _lhsInt -> - (let _lhsOerrors :: (Seq Error) - _lhsOoutput :: Alternatives - _hdOnt :: Nonterminal - _tlOnt :: Nonterminal - _hdIerrors :: (Seq Error) - _hdIoutput :: Alternative - _tlIerrors :: (Seq Error) - _tlIoutput :: Alternatives - -- use rule "Desugar.ag"(line 30, column 144) - _lhsOerrors = - _hdIerrors Seq.<> _tlIerrors - -- self rule - _output = - (:) _hdIoutput _tlIoutput - -- self rule - _lhsOoutput = - _output - -- copy rule (down) - _hdOnt = - _lhsInt - -- copy rule (down) - _tlOnt = - _lhsInt - ( _hdIerrors,_hdIoutput) = - (hd_ _hdOnt ) - ( _tlIerrors,_tlIoutput) = - (tl_ _tlOnt ) - in ( _lhsOerrors,_lhsOoutput))) ) -sem_Alternatives_Nil :: T_Alternatives -sem_Alternatives_Nil = - (T_Alternatives (\ _lhsInt -> - (let _lhsOerrors :: (Seq Error) - _lhsOoutput :: Alternatives - -- use rule "Desugar.ag"(line 30, column 144) - _lhsOerrors = - Seq.empty - -- self rule - _output = - [] - -- self rule - _lhsOoutput = - _output - in ( _lhsOerrors,_lhsOoutput))) ) --- Child ------------------------------------------------------- -{- - visit 0: - synthesized attributes: - childInhs : [(Name, Name)] - childSyns : [(Name, Name)] - output : SELF - alternatives: - alternative Child: - child name : {Name} - child tp : {Type} - child inh : {Attributes} - child syn : {Attributes} - child higherOrder : {Bool} - visit 0: - local output : _ --} --- cata -sem_Child :: Child -> - T_Child -sem_Child (Child _name _tp _inh _syn _higherOrder ) = - (sem_Child_Child _name _tp _inh _syn _higherOrder ) --- semantic domain -newtype T_Child = T_Child (( ([(Name, Name)]),([(Name, Name)]),Child)) -data Inh_Child = Inh_Child {} -data Syn_Child = Syn_Child {childInhs_Syn_Child :: [(Name, Name)],childSyns_Syn_Child :: [(Name, Name)],output_Syn_Child :: Child} -wrap_Child (T_Child sem ) (Inh_Child ) = - (let ( _lhsOchildInhs,_lhsOchildSyns,_lhsOoutput) = - (sem ) - in (Syn_Child _lhsOchildInhs _lhsOchildSyns _lhsOoutput )) -sem_Child_Child :: Name -> - Type -> - Attributes -> - Attributes -> - Bool -> - T_Child -sem_Child_Child name_ tp_ inh_ syn_ higherOrder_ = - (T_Child (let _lhsOchildInhs :: ([(Name, Name)]) - _lhsOchildSyns :: ([(Name, Name)]) - _lhsOoutput :: Child - -- "Desugar.ag"(line 118, column 7) - _lhsOchildInhs = - [(i, name_) | i <- Map.keys inh_ ] - -- "Desugar.ag"(line 119, column 7) - _lhsOchildSyns = - [(s, name_) | s <- Map.keys syn_ ] - -- self rule - _output = - Child name_ tp_ inh_ syn_ higherOrder_ - -- self rule - _lhsOoutput = - _output - in ( _lhsOchildInhs,_lhsOchildSyns,_lhsOoutput)) ) --- Children ---------------------------------------------------- -{- - visit 0: - synthesized attributes: - childInhs : [(Name, Name)] - childSyns : [(Name, Name)] - output : SELF - alternatives: - alternative Cons: - child hd : Child - child tl : Children - visit 0: - local output : _ - alternative Nil: - visit 0: - local output : _ --} --- cata -sem_Children :: Children -> - T_Children -sem_Children list = - (Prelude.foldr sem_Children_Cons sem_Children_Nil (Prelude.map sem_Child list) ) --- semantic domain -newtype T_Children = T_Children (( ([(Name, Name)]),([(Name, Name)]),Children)) -data Inh_Children = Inh_Children {} -data Syn_Children = Syn_Children {childInhs_Syn_Children :: [(Name, Name)],childSyns_Syn_Children :: [(Name, Name)],output_Syn_Children :: Children} -wrap_Children (T_Children sem ) (Inh_Children ) = - (let ( _lhsOchildInhs,_lhsOchildSyns,_lhsOoutput) = - (sem ) - in (Syn_Children _lhsOchildInhs _lhsOchildSyns _lhsOoutput )) -sem_Children_Cons :: T_Child -> - T_Children -> - T_Children -sem_Children_Cons (T_Child hd_ ) (T_Children tl_ ) = - (T_Children (let _lhsOchildInhs :: ([(Name, Name)]) - _lhsOchildSyns :: ([(Name, Name)]) - _lhsOoutput :: Children - _hdIchildInhs :: ([(Name, Name)]) - _hdIchildSyns :: ([(Name, Name)]) - _hdIoutput :: Child - _tlIchildInhs :: ([(Name, Name)]) - _tlIchildSyns :: ([(Name, Name)]) - _tlIoutput :: Children - -- use rule "Desugar.ag"(line 113, column 48) - _lhsOchildInhs = - _hdIchildInhs ++ _tlIchildInhs - -- use rule "Desugar.ag"(line 113, column 48) - _lhsOchildSyns = - _hdIchildSyns ++ _tlIchildSyns - -- self rule - _output = - (:) _hdIoutput _tlIoutput - -- self rule - _lhsOoutput = - _output - ( _hdIchildInhs,_hdIchildSyns,_hdIoutput) = - (hd_ ) - ( _tlIchildInhs,_tlIchildSyns,_tlIoutput) = - (tl_ ) - in ( _lhsOchildInhs,_lhsOchildSyns,_lhsOoutput)) ) -sem_Children_Nil :: T_Children -sem_Children_Nil = - (T_Children (let _lhsOchildInhs :: ([(Name, Name)]) - _lhsOchildSyns :: ([(Name, Name)]) - _lhsOoutput :: Children - -- use rule "Desugar.ag"(line 113, column 48) - _lhsOchildInhs = - [] - -- use rule "Desugar.ag"(line 113, column 48) - _lhsOchildSyns = - [] - -- self rule - _output = - [] - -- self rule - _lhsOoutput = - _output - in ( _lhsOchildInhs,_lhsOchildSyns,_lhsOoutput)) ) --- Expression -------------------------------------------------- -{- - visit 0: - inherited attributes: - childInhs : [(Name, Name)] - childSyns : [(Name, Name)] - con : Constructor - nt : Nonterminal - synthesized attributes: - errors : Seq Error - output : SELF - alternatives: - alternative Expression: - child pos : {Pos} - child txt : {String} - visit 0: - local tokens : _ - local _tup1 : _ - local txt' : _ - local output : _ --} --- cata -sem_Expression :: Expression -> - T_Expression -sem_Expression (Expression _pos _txt ) = - (sem_Expression_Expression _pos _txt ) --- semantic domain -newtype T_Expression = T_Expression (([(Name, Name)]) -> - ([(Name, Name)]) -> - Constructor -> - Nonterminal -> - ( (Seq Error),Expression)) -data Inh_Expression = Inh_Expression {childInhs_Inh_Expression :: [(Name, Name)],childSyns_Inh_Expression :: [(Name, Name)],con_Inh_Expression :: Constructor,nt_Inh_Expression :: Nonterminal} -data Syn_Expression = Syn_Expression {errors_Syn_Expression :: Seq Error,output_Syn_Expression :: Expression} -wrap_Expression (T_Expression sem ) (Inh_Expression _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt ) = - (let ( _lhsOerrors,_lhsOoutput) = - (sem _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt ) - in (Syn_Expression _lhsOerrors _lhsOoutput )) -sem_Expression_Expression :: Pos -> - String -> - T_Expression -sem_Expression_Expression pos_ txt_ = - (T_Expression (\ _lhsIchildInhs - _lhsIchildSyns - _lhsIcon - _lhsInt -> - (let _lhsOerrors :: (Seq Error) - _lhsOoutput :: Expression - -- "Desugar.ag"(line 41, column 7) - _tokens = - lexTokens pos_ txt_ - -- "Desugar.ag"(line 42, column 7) - __tup1 = - let inh = Inh_HsTokensRoot { childInhs_Inh_HsTokensRoot = _lhsIchildInhs - , childSyns_Inh_HsTokensRoot = _lhsIchildSyns - , nt_Inh_HsTokensRoot = _lhsInt - , con_Inh_HsTokensRoot = _lhsIcon - } - sem = sem_HsTokensRoot (HsTokensRoot _tokens ) - syn = wrap_HsTokensRoot sem inh - in (txt_Syn_HsTokensRoot syn, errors_Syn_HsTokensRoot syn) - -- "Desugar.ag"(line 42, column 7) - (_txt',_) = - __tup1 - -- "Desugar.ag"(line 42, column 7) - (_,_lhsOerrors) = - __tup1 - -- "Desugar.ag"(line 50, column 7) - _lhsOoutput = - Expression pos_ _txt' - -- self rule - _output = - Expression pos_ txt_ - in ( _lhsOerrors,_lhsOoutput))) ) --- Grammar ----------------------------------------------------- -{- - visit 0: - inherited attribute: - options : Options - synthesized attributes: - errors : Seq Error - output : SELF - alternatives: - alternative Grammar: - child typeSyns : {TypeSyns} - child useMap : {UseMap} - child derivings : {Derivings} - child wrappers : {Set Nonterminal} - child prods : Productions - child pragmas : {PragmaMap} - child manualAttrOrderMap : {AttrOrderMap} - visit 0: - local output : _ --} --- cata -sem_Grammar :: Grammar -> - T_Grammar -sem_Grammar (Grammar _typeSyns _useMap _derivings _wrappers _prods _pragmas _manualAttrOrderMap ) = - (sem_Grammar_Grammar _typeSyns _useMap _derivings _wrappers (sem_Productions _prods ) _pragmas _manualAttrOrderMap ) --- semantic domain -newtype T_Grammar = T_Grammar (Options -> - ( (Seq Error),Grammar)) -data Inh_Grammar = Inh_Grammar {options_Inh_Grammar :: Options} -data Syn_Grammar = Syn_Grammar {errors_Syn_Grammar :: Seq Error,output_Syn_Grammar :: Grammar} -wrap_Grammar (T_Grammar sem ) (Inh_Grammar _lhsIoptions ) = - (let ( _lhsOerrors,_lhsOoutput) = - (sem _lhsIoptions ) - in (Syn_Grammar _lhsOerrors _lhsOoutput )) -sem_Grammar_Grammar :: TypeSyns -> - UseMap -> - Derivings -> - (Set Nonterminal) -> - T_Productions -> - PragmaMap -> - AttrOrderMap -> - T_Grammar -sem_Grammar_Grammar typeSyns_ useMap_ derivings_ wrappers_ (T_Productions prods_ ) pragmas_ manualAttrOrderMap_ = - (T_Grammar (\ _lhsIoptions -> - (let _lhsOerrors :: (Seq Error) - _lhsOoutput :: Grammar - _prodsIerrors :: (Seq Error) - _prodsIoutput :: Productions - -- use rule "Desugar.ag"(line 30, column 144) - _lhsOerrors = - _prodsIerrors - -- self rule - _output = - Grammar typeSyns_ useMap_ derivings_ wrappers_ _prodsIoutput pragmas_ manualAttrOrderMap_ - -- self rule - _lhsOoutput = - _output - ( _prodsIerrors,_prodsIoutput) = - (prods_ ) - in ( _lhsOerrors,_lhsOoutput))) ) --- HsToken ----------------------------------------------------- -{- - visit 0: - inherited attributes: - childInhs : [(Name, Name)] - childSyns : [(Name, Name)] - con : Constructor - nt : Nonterminal - chained attribute: - addLines : Int - synthesized attributes: - errors : Seq Error - tks : [(Pos,String)] - alternatives: - alternative AGField: - child field : {Name} - child attr : {Name} - child pos : {Pos} - visit 0: - local mField : _ - local field' : _ - alternative AGLocal: - child var : {Name} - child pos : {Pos} - alternative CharToken: - child value : {String} - child pos : {Pos} - alternative Err: - child mesg : {String} - child pos : {Pos} - alternative HsToken: - child value : {String} - child pos : {Pos} - alternative StrToken: - child value : {String} - child pos : {Pos} --} --- cata -sem_HsToken :: HsToken -> - T_HsToken -sem_HsToken (AGField _field _attr _pos ) = - (sem_HsToken_AGField _field _attr _pos ) -sem_HsToken (AGLocal _var _pos ) = - (sem_HsToken_AGLocal _var _pos ) -sem_HsToken (CharToken _value _pos ) = - (sem_HsToken_CharToken _value _pos ) -sem_HsToken (Err _mesg _pos ) = - (sem_HsToken_Err _mesg _pos ) -sem_HsToken (HsToken _value _pos ) = - (sem_HsToken_HsToken _value _pos ) -sem_HsToken (StrToken _value _pos ) = - (sem_HsToken_StrToken _value _pos ) --- semantic domain -newtype T_HsToken = T_HsToken (Int -> - ([(Name, Name)]) -> - ([(Name, Name)]) -> - Constructor -> - Nonterminal -> - ( Int,(Seq Error),([(Pos,String)]))) -data Inh_HsToken = Inh_HsToken {addLines_Inh_HsToken :: Int,childInhs_Inh_HsToken :: [(Name, Name)],childSyns_Inh_HsToken :: [(Name, Name)],con_Inh_HsToken :: Constructor,nt_Inh_HsToken :: Nonterminal} -data Syn_HsToken = Syn_HsToken {addLines_Syn_HsToken :: Int,errors_Syn_HsToken :: Seq Error,tks_Syn_HsToken :: [(Pos,String)]} -wrap_HsToken (T_HsToken sem ) (Inh_HsToken _lhsIaddLines _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt ) = - (let ( _lhsOaddLines,_lhsOerrors,_lhsOtks) = - (sem _lhsIaddLines _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt ) - in (Syn_HsToken _lhsOaddLines _lhsOerrors _lhsOtks )) -sem_HsToken_AGField :: Name -> - Name -> - Pos -> - T_HsToken -sem_HsToken_AGField field_ attr_ pos_ = - (T_HsToken (\ _lhsIaddLines - _lhsIchildInhs - _lhsIchildSyns - _lhsIcon - _lhsInt -> - (let _lhsOerrors :: (Seq Error) - _lhsOaddLines :: Int - _lhsOtks :: ([(Pos,String)]) - -- "Desugar.ag"(line 67, column 7) - _mField = - findField field_ attr_ _lhsIchildSyns - -- "Desugar.ag"(line 69, column 7) - _field' = - maybe field_ id _mField - -- "Desugar.ag"(line 70, column 7) - _lhsOerrors = - maybe (Seq.single (UndefAttr _lhsInt _lhsIcon field_ (Ident "" (getPos field_)))) (const Seq.empty) _mField - -- "Desugar.ag"(line 72, column 7) - _lhsOaddLines = - if length (getName field_) < length (getName _field' ) - then _lhsIaddLines + 1 - else _lhsIaddLines - -- "Desugar.ag"(line 76, column 7) - _lhsOtks = - [(addl _lhsIaddLines pos_, "@" ++ show _field' ++ "." ++ show attr_)] - in ( _lhsOaddLines,_lhsOerrors,_lhsOtks))) ) -sem_HsToken_AGLocal :: Name -> - Pos -> - T_HsToken -sem_HsToken_AGLocal var_ pos_ = - (T_HsToken (\ _lhsIaddLines - _lhsIchildInhs - _lhsIchildSyns - _lhsIcon - _lhsInt -> - (let _lhsOtks :: ([(Pos,String)]) - _lhsOerrors :: (Seq Error) - _lhsOaddLines :: Int - -- "Desugar.ag"(line 65, column 7) - _lhsOtks = - [(addl _lhsIaddLines pos_, "@" ++ show var_)] - -- use rule "Desugar.ag"(line 30, column 144) - _lhsOerrors = - Seq.empty - -- copy rule (chain) - _lhsOaddLines = - _lhsIaddLines - in ( _lhsOaddLines,_lhsOerrors,_lhsOtks))) ) -sem_HsToken_CharToken :: String -> - Pos -> - T_HsToken -sem_HsToken_CharToken value_ pos_ = - (T_HsToken (\ _lhsIaddLines - _lhsIchildInhs - _lhsIchildSyns - _lhsIcon - _lhsInt -> - (let _lhsOtks :: ([(Pos,String)]) - _lhsOerrors :: (Seq Error) - _lhsOaddLines :: Int - -- "Desugar.ag"(line 80, column 7) - _lhsOtks = - [(addl _lhsIaddLines pos_, if null value_ then "" else showCharShort (head value_))] - -- use rule "Desugar.ag"(line 30, column 144) - _lhsOerrors = - Seq.empty - -- copy rule (chain) - _lhsOaddLines = - _lhsIaddLines - in ( _lhsOaddLines,_lhsOerrors,_lhsOtks))) ) -sem_HsToken_Err :: String -> - Pos -> - T_HsToken -sem_HsToken_Err mesg_ pos_ = - (T_HsToken (\ _lhsIaddLines - _lhsIchildInhs - _lhsIchildSyns - _lhsIcon - _lhsInt -> - (let _lhsOtks :: ([(Pos,String)]) - _lhsOerrors :: (Seq Error) - _lhsOaddLines :: Int - -- "Desugar.ag"(line 84, column 7) - _lhsOtks = - [(addl _lhsIaddLines pos_, "***" ++ mesg_ ++ "***")] - -- use rule "Desugar.ag"(line 30, column 144) - _lhsOerrors = - Seq.empty - -- copy rule (chain) - _lhsOaddLines = - _lhsIaddLines - in ( _lhsOaddLines,_lhsOerrors,_lhsOtks))) ) -sem_HsToken_HsToken :: String -> - Pos -> - T_HsToken -sem_HsToken_HsToken value_ pos_ = - (T_HsToken (\ _lhsIaddLines - _lhsIchildInhs - _lhsIchildSyns - _lhsIcon - _lhsInt -> - (let _lhsOtks :: ([(Pos,String)]) - _lhsOerrors :: (Seq Error) - _lhsOaddLines :: Int - -- "Desugar.ag"(line 78, column 7) - _lhsOtks = - [(addl _lhsIaddLines pos_, value_)] - -- use rule "Desugar.ag"(line 30, column 144) - _lhsOerrors = - Seq.empty - -- copy rule (chain) - _lhsOaddLines = - _lhsIaddLines - in ( _lhsOaddLines,_lhsOerrors,_lhsOtks))) ) -sem_HsToken_StrToken :: String -> - Pos -> - T_HsToken -sem_HsToken_StrToken value_ pos_ = - (T_HsToken (\ _lhsIaddLines - _lhsIchildInhs - _lhsIchildSyns - _lhsIcon - _lhsInt -> - (let _lhsOtks :: ([(Pos,String)]) - _lhsOerrors :: (Seq Error) - _lhsOaddLines :: Int - -- "Desugar.ag"(line 82, column 7) - _lhsOtks = - [(addl _lhsIaddLines pos_, showStrShort value_)] - -- use rule "Desugar.ag"(line 30, column 144) - _lhsOerrors = - Seq.empty - -- copy rule (chain) - _lhsOaddLines = - _lhsIaddLines - in ( _lhsOaddLines,_lhsOerrors,_lhsOtks))) ) --- HsTokens ---------------------------------------------------- -{- - visit 0: - inherited attributes: - childInhs : [(Name, Name)] - childSyns : [(Name, Name)] - con : Constructor - nt : Nonterminal - chained attribute: - addLines : Int - synthesized attributes: - errors : Seq Error - tks : [(Pos,String)] - alternatives: - alternative Cons: - child hd : HsToken - child tl : HsTokens - alternative Nil: --} --- cata -sem_HsTokens :: HsTokens -> - T_HsTokens -sem_HsTokens list = - (Prelude.foldr sem_HsTokens_Cons sem_HsTokens_Nil (Prelude.map sem_HsToken list) ) --- semantic domain -newtype T_HsTokens = T_HsTokens (Int -> - ([(Name, Name)]) -> - ([(Name, Name)]) -> - Constructor -> - Nonterminal -> - ( Int,(Seq Error),([(Pos,String)]))) -data Inh_HsTokens = Inh_HsTokens {addLines_Inh_HsTokens :: Int,childInhs_Inh_HsTokens :: [(Name, Name)],childSyns_Inh_HsTokens :: [(Name, Name)],con_Inh_HsTokens :: Constructor,nt_Inh_HsTokens :: Nonterminal} -data Syn_HsTokens = Syn_HsTokens {addLines_Syn_HsTokens :: Int,errors_Syn_HsTokens :: Seq Error,tks_Syn_HsTokens :: [(Pos,String)]} -wrap_HsTokens (T_HsTokens sem ) (Inh_HsTokens _lhsIaddLines _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt ) = - (let ( _lhsOaddLines,_lhsOerrors,_lhsOtks) = - (sem _lhsIaddLines _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt ) - in (Syn_HsTokens _lhsOaddLines _lhsOerrors _lhsOtks )) -sem_HsTokens_Cons :: T_HsToken -> - T_HsTokens -> - T_HsTokens -sem_HsTokens_Cons (T_HsToken hd_ ) (T_HsTokens tl_ ) = - (T_HsTokens (\ _lhsIaddLines - _lhsIchildInhs - _lhsIchildSyns - _lhsIcon - _lhsInt -> - (let _lhsOerrors :: (Seq Error) - _lhsOtks :: ([(Pos,String)]) - _lhsOaddLines :: Int - _hdOaddLines :: Int - _hdOchildInhs :: ([(Name, Name)]) - _hdOchildSyns :: ([(Name, Name)]) - _hdOcon :: Constructor - _hdOnt :: Nonterminal - _tlOaddLines :: Int - _tlOchildInhs :: ([(Name, Name)]) - _tlOchildSyns :: ([(Name, Name)]) - _tlOcon :: Constructor - _tlOnt :: Nonterminal - _hdIaddLines :: Int - _hdIerrors :: (Seq Error) - _hdItks :: ([(Pos,String)]) - _tlIaddLines :: Int - _tlIerrors :: (Seq Error) - _tlItks :: ([(Pos,String)]) - -- use rule "Desugar.ag"(line 30, column 144) - _lhsOerrors = - _hdIerrors Seq.<> _tlIerrors - -- use rule "Desugar.ag"(line 62, column 46) - _lhsOtks = - _hdItks ++ _tlItks - -- copy rule (up) - _lhsOaddLines = - _tlIaddLines - -- copy rule (down) - _hdOaddLines = - _lhsIaddLines - -- copy rule (down) - _hdOchildInhs = - _lhsIchildInhs - -- copy rule (down) - _hdOchildSyns = - _lhsIchildSyns - -- copy rule (down) - _hdOcon = - _lhsIcon - -- copy rule (down) - _hdOnt = - _lhsInt - -- copy rule (chain) - _tlOaddLines = - _hdIaddLines - -- copy rule (down) - _tlOchildInhs = - _lhsIchildInhs - -- copy rule (down) - _tlOchildSyns = - _lhsIchildSyns - -- copy rule (down) - _tlOcon = - _lhsIcon - -- copy rule (down) - _tlOnt = - _lhsInt - ( _hdIaddLines,_hdIerrors,_hdItks) = - (hd_ _hdOaddLines _hdOchildInhs _hdOchildSyns _hdOcon _hdOnt ) - ( _tlIaddLines,_tlIerrors,_tlItks) = - (tl_ _tlOaddLines _tlOchildInhs _tlOchildSyns _tlOcon _tlOnt ) - in ( _lhsOaddLines,_lhsOerrors,_lhsOtks))) ) -sem_HsTokens_Nil :: T_HsTokens -sem_HsTokens_Nil = - (T_HsTokens (\ _lhsIaddLines - _lhsIchildInhs - _lhsIchildSyns - _lhsIcon - _lhsInt -> - (let _lhsOerrors :: (Seq Error) - _lhsOtks :: ([(Pos,String)]) - _lhsOaddLines :: Int - -- use rule "Desugar.ag"(line 30, column 144) - _lhsOerrors = - Seq.empty - -- use rule "Desugar.ag"(line 62, column 46) - _lhsOtks = - [] - -- copy rule (chain) - _lhsOaddLines = - _lhsIaddLines - in ( _lhsOaddLines,_lhsOerrors,_lhsOtks))) ) --- HsTokensRoot ------------------------------------------------ -{- - visit 0: - inherited attributes: - childInhs : [(Name, Name)] - childSyns : [(Name, Name)] - con : Constructor - nt : Nonterminal - synthesized attributes: - errors : Seq Error - tks : [(Pos,String)] - txt : String - alternatives: - alternative HsTokensRoot: - child tokens : HsTokens --} --- cata -sem_HsTokensRoot :: HsTokensRoot -> - T_HsTokensRoot -sem_HsTokensRoot (HsTokensRoot _tokens ) = - (sem_HsTokensRoot_HsTokensRoot (sem_HsTokens _tokens ) ) --- semantic domain -newtype T_HsTokensRoot = T_HsTokensRoot (([(Name, Name)]) -> - ([(Name, Name)]) -> - Constructor -> - Nonterminal -> - ( (Seq Error),([(Pos,String)]),String)) -data Inh_HsTokensRoot = Inh_HsTokensRoot {childInhs_Inh_HsTokensRoot :: [(Name, Name)],childSyns_Inh_HsTokensRoot :: [(Name, Name)],con_Inh_HsTokensRoot :: Constructor,nt_Inh_HsTokensRoot :: Nonterminal} -data Syn_HsTokensRoot = Syn_HsTokensRoot {errors_Syn_HsTokensRoot :: Seq Error,tks_Syn_HsTokensRoot :: [(Pos,String)],txt_Syn_HsTokensRoot :: String} -wrap_HsTokensRoot (T_HsTokensRoot sem ) (Inh_HsTokensRoot _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt ) = - (let ( _lhsOerrors,_lhsOtks,_lhsOtxt) = - (sem _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt ) - in (Syn_HsTokensRoot _lhsOerrors _lhsOtks _lhsOtxt )) -sem_HsTokensRoot_HsTokensRoot :: T_HsTokens -> - T_HsTokensRoot -sem_HsTokensRoot_HsTokensRoot (T_HsTokens tokens_ ) = - (T_HsTokensRoot (\ _lhsIchildInhs - _lhsIchildSyns - _lhsIcon - _lhsInt -> - (let _lhsOtxt :: String - _tokensOaddLines :: Int - _lhsOerrors :: (Seq Error) - _lhsOtks :: ([(Pos,String)]) - _tokensOchildInhs :: ([(Name, Name)]) - _tokensOchildSyns :: ([(Name, Name)]) - _tokensOcon :: Constructor - _tokensOnt :: Nonterminal - _tokensIaddLines :: Int - _tokensIerrors :: (Seq Error) - _tokensItks :: ([(Pos,String)]) - -- "Desugar.ag"(line 55, column 7) - _lhsOtxt = - unlines $ showTokens _tokensItks - -- "Desugar.ag"(line 60, column 7) - _tokensOaddLines = - 0 - -- use rule "Desugar.ag"(line 30, column 144) - _lhsOerrors = - _tokensIerrors - -- use rule "Desugar.ag"(line 62, column 46) - _lhsOtks = - _tokensItks - -- copy rule (down) - _tokensOchildInhs = - _lhsIchildInhs - -- copy rule (down) - _tokensOchildSyns = - _lhsIchildSyns - -- copy rule (down) - _tokensOcon = - _lhsIcon - -- copy rule (down) - _tokensOnt = - _lhsInt - ( _tokensIaddLines,_tokensIerrors,_tokensItks) = - (tokens_ _tokensOaddLines _tokensOchildInhs _tokensOchildSyns _tokensOcon _tokensOnt ) - in ( _lhsOerrors,_lhsOtks,_lhsOtxt))) ) --- Pattern ----------------------------------------------------- -{- - visit 0: - inherited attributes: - childInhs : [(Name, Name)] - childSyns : [(Name, Name)] - con : Constructor - defs : Set (Name, Name) - nt : Nonterminal - synthesized attributes: - copy : SELF - defsCollect : Set (Name, Name) - errors : Seq Error - output : SELF - alternatives: - alternative Alias: - child field : {Name} - child attr : {Name} - child pat : Pattern - child parts : Patterns - visit 0: - local _tup2 : _ - local field' : _ - local err1 : _ - local err2 : _ - local def : _ - local copy : _ - local output : _ - alternative Constr: - child name : {Constructor} - child pats : Patterns - visit 0: - local copy : _ - local output : _ - alternative Product: - child pos : {Pos} - child pats : Patterns - visit 0: - local copy : _ - local output : _ - alternative Underscore: - child pos : {Pos} - visit 0: - local copy : _ - local output : _ --} --- cata -sem_Pattern :: Pattern -> - T_Pattern -sem_Pattern (Alias _field _attr _pat _parts ) = - (sem_Pattern_Alias _field _attr (sem_Pattern _pat ) (sem_Patterns _parts ) ) -sem_Pattern (Constr _name _pats ) = - (sem_Pattern_Constr _name (sem_Patterns _pats ) ) -sem_Pattern (Product _pos _pats ) = - (sem_Pattern_Product _pos (sem_Patterns _pats ) ) -sem_Pattern (Underscore _pos ) = - (sem_Pattern_Underscore _pos ) --- semantic domain -newtype T_Pattern = T_Pattern (([(Name, Name)]) -> - ([(Name, Name)]) -> - Constructor -> - (Set (Name, Name)) -> - Nonterminal -> - ( Pattern,(Set (Name, Name)),(Seq Error),Pattern)) -data Inh_Pattern = Inh_Pattern {childInhs_Inh_Pattern :: [(Name, Name)],childSyns_Inh_Pattern :: [(Name, Name)],con_Inh_Pattern :: Constructor,defs_Inh_Pattern :: Set (Name, Name),nt_Inh_Pattern :: Nonterminal} -data Syn_Pattern = Syn_Pattern {copy_Syn_Pattern :: Pattern,defsCollect_Syn_Pattern :: Set (Name, Name),errors_Syn_Pattern :: Seq Error,output_Syn_Pattern :: Pattern} -wrap_Pattern (T_Pattern sem ) (Inh_Pattern _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsInt ) = - (let ( _lhsOcopy,_lhsOdefsCollect,_lhsOerrors,_lhsOoutput) = - (sem _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsInt ) - in (Syn_Pattern _lhsOcopy _lhsOdefsCollect _lhsOerrors _lhsOoutput )) -sem_Pattern_Alias :: Name -> - Name -> - T_Pattern -> - T_Patterns -> - T_Pattern -sem_Pattern_Alias field_ attr_ (T_Pattern pat_ ) (T_Patterns parts_ ) = - (T_Pattern (\ _lhsIchildInhs - _lhsIchildSyns - _lhsIcon - _lhsIdefs - _lhsInt -> - (let _lhsOerrors :: (Seq Error) - _lhsOoutput :: Pattern - _lhsOdefsCollect :: (Set (Name, Name)) - _lhsOcopy :: Pattern - _patOchildInhs :: ([(Name, Name)]) - _patOchildSyns :: ([(Name, Name)]) - _patOcon :: Constructor - _patOdefs :: (Set (Name, Name)) - _patOnt :: Nonterminal - _partsOchildInhs :: ([(Name, Name)]) - _partsOchildSyns :: ([(Name, Name)]) - _partsOcon :: Constructor - _partsOdefs :: (Set (Name, Name)) - _partsOnt :: Nonterminal - _patIcopy :: Pattern - _patIdefsCollect :: (Set (Name, Name)) - _patIerrors :: (Seq Error) - _patIoutput :: Pattern - _partsIcopy :: Patterns - _partsIdefsCollect :: (Set (Name, Name)) - _partsIerrors :: (Seq Error) - _partsIoutput :: Patterns - -- "Desugar.ag"(line 98, column 7) - __tup2 = - maybeError field_ (UndefAttr _lhsInt _lhsIcon (Ident "" (getPos field_)) attr_) $ - findField field_ attr_ _lhsIchildInhs - -- "Desugar.ag"(line 98, column 7) - (_field',_) = - __tup2 - -- "Desugar.ag"(line 98, column 7) - (_,_err1) = - __tup2 - -- "Desugar.ag"(line 100, column 7) - _err2 = - if _field' == field_ - then Seq.empty - else if (_field' , attr_) `Set.member` _lhsIdefs - then Seq.single $ DupRule _lhsInt _lhsIcon field_ attr_ _field' - else Seq.empty - -- "Desugar.ag"(line 105, column 7) - _lhsOerrors = - _err1 Seq.<> _err2 Seq.<> _patIerrors <> _partsIerrors - -- "Desugar.ag"(line 106, column 7) - _lhsOoutput = - Alias _field' attr_ _patIoutput _partsIoutput - -- "Desugar.ag"(line 159, column 7) - _def = - Set.singleton (field_, attr_) - -- "Desugar.ag"(line 160, column 7) - _lhsOdefsCollect = - _def `Set.union` _patIdefsCollect `Set.union` _partsIdefsCollect - -- self rule - _copy = - Alias field_ attr_ _patIcopy _partsIcopy - -- self rule - _output = - Alias field_ attr_ _patIoutput _partsIoutput - -- self rule - _lhsOcopy = - _copy - -- copy rule (down) - _patOchildInhs = - _lhsIchildInhs - -- copy rule (down) - _patOchildSyns = - _lhsIchildSyns - -- copy rule (down) - _patOcon = - _lhsIcon - -- copy rule (down) - _patOdefs = - _lhsIdefs - -- copy rule (down) - _patOnt = - _lhsInt - -- copy rule (down) - _partsOchildInhs = - _lhsIchildInhs - -- copy rule (down) - _partsOchildSyns = - _lhsIchildSyns - -- copy rule (down) - _partsOcon = - _lhsIcon - -- copy rule (down) - _partsOdefs = - _lhsIdefs - -- copy rule (down) - _partsOnt = - _lhsInt - ( _patIcopy,_patIdefsCollect,_patIerrors,_patIoutput) = - (pat_ _patOchildInhs _patOchildSyns _patOcon _patOdefs _patOnt ) - ( _partsIcopy,_partsIdefsCollect,_partsIerrors,_partsIoutput) = - (parts_ _partsOchildInhs _partsOchildSyns _partsOcon _partsOdefs _partsOnt ) - in ( _lhsOcopy,_lhsOdefsCollect,_lhsOerrors,_lhsOoutput))) ) -sem_Pattern_Constr :: Constructor -> - T_Patterns -> - T_Pattern -sem_Pattern_Constr name_ (T_Patterns pats_ ) = - (T_Pattern (\ _lhsIchildInhs - _lhsIchildSyns - _lhsIcon - _lhsIdefs - _lhsInt -> - (let _lhsOdefsCollect :: (Set (Name, Name)) - _lhsOerrors :: (Seq Error) - _lhsOcopy :: Pattern - _lhsOoutput :: Pattern - _patsOchildInhs :: ([(Name, Name)]) - _patsOchildSyns :: ([(Name, Name)]) - _patsOcon :: Constructor - _patsOdefs :: (Set (Name, Name)) - _patsOnt :: Nonterminal - _patsIcopy :: Patterns - _patsIdefsCollect :: (Set (Name, Name)) - _patsIerrors :: (Seq Error) - _patsIoutput :: Patterns - -- use rule "Desugar.ag"(line 156, column 52) - _lhsOdefsCollect = - _patsIdefsCollect - -- use rule "Desugar.ag"(line 30, column 144) - _lhsOerrors = - _patsIerrors - -- self rule - _copy = - Constr name_ _patsIcopy - -- self rule - _output = - Constr name_ _patsIoutput - -- self rule - _lhsOcopy = - _copy - -- self rule - _lhsOoutput = - _output - -- copy rule (down) - _patsOchildInhs = - _lhsIchildInhs - -- copy rule (down) - _patsOchildSyns = - _lhsIchildSyns - -- copy rule (down) - _patsOcon = - _lhsIcon - -- copy rule (down) - _patsOdefs = - _lhsIdefs - -- copy rule (down) - _patsOnt = - _lhsInt - ( _patsIcopy,_patsIdefsCollect,_patsIerrors,_patsIoutput) = - (pats_ _patsOchildInhs _patsOchildSyns _patsOcon _patsOdefs _patsOnt ) - in ( _lhsOcopy,_lhsOdefsCollect,_lhsOerrors,_lhsOoutput))) ) -sem_Pattern_Product :: Pos -> - T_Patterns -> - T_Pattern -sem_Pattern_Product pos_ (T_Patterns pats_ ) = - (T_Pattern (\ _lhsIchildInhs - _lhsIchildSyns - _lhsIcon - _lhsIdefs - _lhsInt -> - (let _lhsOdefsCollect :: (Set (Name, Name)) - _lhsOerrors :: (Seq Error) - _lhsOcopy :: Pattern - _lhsOoutput :: Pattern - _patsOchildInhs :: ([(Name, Name)]) - _patsOchildSyns :: ([(Name, Name)]) - _patsOcon :: Constructor - _patsOdefs :: (Set (Name, Name)) - _patsOnt :: Nonterminal - _patsIcopy :: Patterns - _patsIdefsCollect :: (Set (Name, Name)) - _patsIerrors :: (Seq Error) - _patsIoutput :: Patterns - -- use rule "Desugar.ag"(line 156, column 52) - _lhsOdefsCollect = - _patsIdefsCollect - -- use rule "Desugar.ag"(line 30, column 144) - _lhsOerrors = - _patsIerrors - -- self rule - _copy = - Product pos_ _patsIcopy - -- self rule - _output = - Product pos_ _patsIoutput - -- self rule - _lhsOcopy = - _copy - -- self rule - _lhsOoutput = - _output - -- copy rule (down) - _patsOchildInhs = - _lhsIchildInhs - -- copy rule (down) - _patsOchildSyns = - _lhsIchildSyns - -- copy rule (down) - _patsOcon = - _lhsIcon - -- copy rule (down) - _patsOdefs = - _lhsIdefs - -- copy rule (down) - _patsOnt = - _lhsInt - ( _patsIcopy,_patsIdefsCollect,_patsIerrors,_patsIoutput) = - (pats_ _patsOchildInhs _patsOchildSyns _patsOcon _patsOdefs _patsOnt ) - in ( _lhsOcopy,_lhsOdefsCollect,_lhsOerrors,_lhsOoutput))) ) -sem_Pattern_Underscore :: Pos -> - T_Pattern -sem_Pattern_Underscore pos_ = - (T_Pattern (\ _lhsIchildInhs - _lhsIchildSyns - _lhsIcon - _lhsIdefs - _lhsInt -> - (let _lhsOdefsCollect :: (Set (Name, Name)) - _lhsOerrors :: (Seq Error) - _lhsOcopy :: Pattern - _lhsOoutput :: Pattern - -- use rule "Desugar.ag"(line 156, column 52) - _lhsOdefsCollect = - Set.empty - -- use rule "Desugar.ag"(line 30, column 144) - _lhsOerrors = - Seq.empty - -- self rule - _copy = - Underscore pos_ - -- self rule - _output = - Underscore pos_ - -- self rule - _lhsOcopy = - _copy - -- self rule - _lhsOoutput = - _output - in ( _lhsOcopy,_lhsOdefsCollect,_lhsOerrors,_lhsOoutput))) ) --- Patterns ---------------------------------------------------- -{- - visit 0: - inherited attributes: - childInhs : [(Name, Name)] - childSyns : [(Name, Name)] - con : Constructor - defs : Set (Name, Name) - nt : Nonterminal - synthesized attributes: - copy : SELF - defsCollect : Set (Name, Name) - errors : Seq Error - output : SELF - alternatives: - alternative Cons: - child hd : Pattern - child tl : Patterns - visit 0: - local copy : _ - local output : _ - alternative Nil: - visit 0: - local copy : _ - local output : _ --} --- cata -sem_Patterns :: Patterns -> - T_Patterns -sem_Patterns list = - (Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list) ) --- semantic domain -newtype T_Patterns = T_Patterns (([(Name, Name)]) -> - ([(Name, Name)]) -> - Constructor -> - (Set (Name, Name)) -> - Nonterminal -> - ( Patterns,(Set (Name, Name)),(Seq Error),Patterns)) -data Inh_Patterns = Inh_Patterns {childInhs_Inh_Patterns :: [(Name, Name)],childSyns_Inh_Patterns :: [(Name, Name)],con_Inh_Patterns :: Constructor,defs_Inh_Patterns :: Set (Name, Name),nt_Inh_Patterns :: Nonterminal} -data Syn_Patterns = Syn_Patterns {copy_Syn_Patterns :: Patterns,defsCollect_Syn_Patterns :: Set (Name, Name),errors_Syn_Patterns :: Seq Error,output_Syn_Patterns :: Patterns} -wrap_Patterns (T_Patterns sem ) (Inh_Patterns _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsInt ) = - (let ( _lhsOcopy,_lhsOdefsCollect,_lhsOerrors,_lhsOoutput) = - (sem _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsInt ) - in (Syn_Patterns _lhsOcopy _lhsOdefsCollect _lhsOerrors _lhsOoutput )) -sem_Patterns_Cons :: T_Pattern -> - T_Patterns -> - T_Patterns -sem_Patterns_Cons (T_Pattern hd_ ) (T_Patterns tl_ ) = - (T_Patterns (\ _lhsIchildInhs - _lhsIchildSyns - _lhsIcon - _lhsIdefs - _lhsInt -> - (let _lhsOdefsCollect :: (Set (Name, Name)) - _lhsOerrors :: (Seq Error) - _lhsOcopy :: Patterns - _lhsOoutput :: Patterns - _hdOchildInhs :: ([(Name, Name)]) - _hdOchildSyns :: ([(Name, Name)]) - _hdOcon :: Constructor - _hdOdefs :: (Set (Name, Name)) - _hdOnt :: Nonterminal - _tlOchildInhs :: ([(Name, Name)]) - _tlOchildSyns :: ([(Name, Name)]) - _tlOcon :: Constructor - _tlOdefs :: (Set (Name, Name)) - _tlOnt :: Nonterminal - _hdIcopy :: Pattern - _hdIdefsCollect :: (Set (Name, Name)) - _hdIerrors :: (Seq Error) - _hdIoutput :: Pattern - _tlIcopy :: Patterns - _tlIdefsCollect :: (Set (Name, Name)) - _tlIerrors :: (Seq Error) - _tlIoutput :: Patterns - -- use rule "Desugar.ag"(line 156, column 52) - _lhsOdefsCollect = - _hdIdefsCollect `Set.union` _tlIdefsCollect - -- use rule "Desugar.ag"(line 30, column 144) - _lhsOerrors = - _hdIerrors Seq.<> _tlIerrors - -- self rule - _copy = - (:) _hdIcopy _tlIcopy - -- self rule - _output = - (:) _hdIoutput _tlIoutput - -- self rule - _lhsOcopy = - _copy - -- self rule - _lhsOoutput = - _output - -- copy rule (down) - _hdOchildInhs = - _lhsIchildInhs - -- copy rule (down) - _hdOchildSyns = - _lhsIchildSyns - -- copy rule (down) - _hdOcon = - _lhsIcon - -- copy rule (down) - _hdOdefs = - _lhsIdefs - -- copy rule (down) - _hdOnt = - _lhsInt - -- copy rule (down) - _tlOchildInhs = - _lhsIchildInhs - -- copy rule (down) - _tlOchildSyns = - _lhsIchildSyns - -- copy rule (down) - _tlOcon = - _lhsIcon - -- copy rule (down) - _tlOdefs = - _lhsIdefs - -- copy rule (down) - _tlOnt = - _lhsInt - ( _hdIcopy,_hdIdefsCollect,_hdIerrors,_hdIoutput) = - (hd_ _hdOchildInhs _hdOchildSyns _hdOcon _hdOdefs _hdOnt ) - ( _tlIcopy,_tlIdefsCollect,_tlIerrors,_tlIoutput) = - (tl_ _tlOchildInhs _tlOchildSyns _tlOcon _tlOdefs _tlOnt ) - in ( _lhsOcopy,_lhsOdefsCollect,_lhsOerrors,_lhsOoutput))) ) -sem_Patterns_Nil :: T_Patterns -sem_Patterns_Nil = - (T_Patterns (\ _lhsIchildInhs - _lhsIchildSyns - _lhsIcon - _lhsIdefs - _lhsInt -> - (let _lhsOdefsCollect :: (Set (Name, Name)) - _lhsOerrors :: (Seq Error) - _lhsOcopy :: Patterns - _lhsOoutput :: Patterns - -- use rule "Desugar.ag"(line 156, column 52) - _lhsOdefsCollect = - Set.empty - -- use rule "Desugar.ag"(line 30, column 144) - _lhsOerrors = - Seq.empty - -- self rule - _copy = - [] - -- self rule - _output = - [] - -- self rule - _lhsOcopy = - _copy - -- self rule - _lhsOoutput = - _output - in ( _lhsOcopy,_lhsOdefsCollect,_lhsOerrors,_lhsOoutput))) ) --- Production -------------------------------------------------- -{- - visit 0: - synthesized attributes: - errors : Seq Error - output : SELF - alternatives: - alternative Production: - child nt : {Nonterminal} - child inh : {Attributes} - child syn : {Attributes} - child alts : Alternatives - visit 0: - local output : _ --} --- cata -sem_Production :: Production -> - T_Production -sem_Production (Production _nt _inh _syn _alts ) = - (sem_Production_Production _nt _inh _syn (sem_Alternatives _alts ) ) --- semantic domain -newtype T_Production = T_Production (( (Seq Error),Production)) -data Inh_Production = Inh_Production {} -data Syn_Production = Syn_Production {errors_Syn_Production :: Seq Error,output_Syn_Production :: Production} -wrap_Production (T_Production sem ) (Inh_Production ) = - (let ( _lhsOerrors,_lhsOoutput) = - (sem ) - in (Syn_Production _lhsOerrors _lhsOoutput )) -sem_Production_Production :: Nonterminal -> - Attributes -> - Attributes -> - T_Alternatives -> - T_Production -sem_Production_Production nt_ inh_ syn_ (T_Alternatives alts_ ) = - (T_Production (let _altsOnt :: Nonterminal - _lhsOerrors :: (Seq Error) - _lhsOoutput :: Production - _altsIerrors :: (Seq Error) - _altsIoutput :: Alternatives - -- "Desugar.ag"(line 145, column 7) - _altsOnt = - nt_ - -- use rule "Desugar.ag"(line 30, column 144) - _lhsOerrors = - _altsIerrors - -- self rule - _output = - Production nt_ inh_ syn_ _altsIoutput - -- self rule - _lhsOoutput = - _output - ( _altsIerrors,_altsIoutput) = - (alts_ _altsOnt ) - in ( _lhsOerrors,_lhsOoutput)) ) --- Productions ------------------------------------------------- -{- - visit 0: - synthesized attributes: - errors : Seq Error - output : SELF - alternatives: - alternative Cons: - child hd : Production - child tl : Productions - visit 0: - local output : _ - alternative Nil: - visit 0: - local output : _ --} --- cata -sem_Productions :: Productions -> - T_Productions -sem_Productions list = - (Prelude.foldr sem_Productions_Cons sem_Productions_Nil (Prelude.map sem_Production list) ) --- semantic domain -newtype T_Productions = T_Productions (( (Seq Error),Productions)) -data Inh_Productions = Inh_Productions {} -data Syn_Productions = Syn_Productions {errors_Syn_Productions :: Seq Error,output_Syn_Productions :: Productions} -wrap_Productions (T_Productions sem ) (Inh_Productions ) = - (let ( _lhsOerrors,_lhsOoutput) = - (sem ) - in (Syn_Productions _lhsOerrors _lhsOoutput )) -sem_Productions_Cons :: T_Production -> - T_Productions -> - T_Productions -sem_Productions_Cons (T_Production hd_ ) (T_Productions tl_ ) = - (T_Productions (let _lhsOerrors :: (Seq Error) - _lhsOoutput :: Productions - _hdIerrors :: (Seq Error) - _hdIoutput :: Production - _tlIerrors :: (Seq Error) - _tlIoutput :: Productions - -- use rule "Desugar.ag"(line 30, column 144) - _lhsOerrors = - _hdIerrors Seq.<> _tlIerrors - -- self rule - _output = - (:) _hdIoutput _tlIoutput - -- self rule - _lhsOoutput = - _output - ( _hdIerrors,_hdIoutput) = - (hd_ ) - ( _tlIerrors,_tlIoutput) = - (tl_ ) - in ( _lhsOerrors,_lhsOoutput)) ) -sem_Productions_Nil :: T_Productions -sem_Productions_Nil = - (T_Productions (let _lhsOerrors :: (Seq Error) - _lhsOoutput :: Productions - -- use rule "Desugar.ag"(line 30, column 144) - _lhsOerrors = - Seq.empty - -- self rule - _output = - [] - -- self rule - _lhsOoutput = - _output - in ( _lhsOerrors,_lhsOoutput)) ) --- Rule -------------------------------------------------------- -{- - visit 0: - inherited attributes: - childInhs : [(Name, Name)] - childSyns : [(Name, Name)] - con : Constructor - defs : Set (Name, Name) - nt : Nonterminal - synthesized attributes: - defsCollect : Set (Name, Name) - errors : Seq Error - output : SELF - alternatives: - alternative Rule: - child pattern : Pattern - child rhs : Expression - child owrt : {Bool} - child origin : {String} - visit 0: - local output : _ --} --- cata -sem_Rule :: Rule -> - T_Rule -sem_Rule (Rule _pattern _rhs _owrt _origin ) = - (sem_Rule_Rule (sem_Pattern _pattern ) (sem_Expression _rhs ) _owrt _origin ) --- semantic domain -newtype T_Rule = T_Rule (([(Name, Name)]) -> - ([(Name, Name)]) -> - Constructor -> - (Set (Name, Name)) -> - Nonterminal -> - ( (Set (Name, Name)),(Seq Error),Rule)) -data Inh_Rule = Inh_Rule {childInhs_Inh_Rule :: [(Name, Name)],childSyns_Inh_Rule :: [(Name, Name)],con_Inh_Rule :: Constructor,defs_Inh_Rule :: Set (Name, Name),nt_Inh_Rule :: Nonterminal} -data Syn_Rule = Syn_Rule {defsCollect_Syn_Rule :: Set (Name, Name),errors_Syn_Rule :: Seq Error,output_Syn_Rule :: Rule} -wrap_Rule (T_Rule sem ) (Inh_Rule _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsInt ) = - (let ( _lhsOdefsCollect,_lhsOerrors,_lhsOoutput) = - (sem _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsInt ) - in (Syn_Rule _lhsOdefsCollect _lhsOerrors _lhsOoutput )) -sem_Rule_Rule :: T_Pattern -> - T_Expression -> - Bool -> - String -> - T_Rule -sem_Rule_Rule (T_Pattern pattern_ ) (T_Expression rhs_ ) owrt_ origin_ = - (T_Rule (\ _lhsIchildInhs - _lhsIchildSyns - _lhsIcon - _lhsIdefs - _lhsInt -> - (let _lhsOdefsCollect :: (Set (Name, Name)) - _lhsOerrors :: (Seq Error) - _lhsOoutput :: Rule - _patternOchildInhs :: ([(Name, Name)]) - _patternOchildSyns :: ([(Name, Name)]) - _patternOcon :: Constructor - _patternOdefs :: (Set (Name, Name)) - _patternOnt :: Nonterminal - _rhsOchildInhs :: ([(Name, Name)]) - _rhsOchildSyns :: ([(Name, Name)]) - _rhsOcon :: Constructor - _rhsOnt :: Nonterminal - _patternIcopy :: Pattern - _patternIdefsCollect :: (Set (Name, Name)) - _patternIerrors :: (Seq Error) - _patternIoutput :: Pattern - _rhsIerrors :: (Seq Error) - _rhsIoutput :: Expression - -- use rule "Desugar.ag"(line 156, column 52) - _lhsOdefsCollect = - _patternIdefsCollect - -- use rule "Desugar.ag"(line 30, column 144) - _lhsOerrors = - _patternIerrors Seq.<> _rhsIerrors - -- self rule - _output = - Rule _patternIoutput _rhsIoutput owrt_ origin_ - -- self rule - _lhsOoutput = - _output - -- copy rule (down) - _patternOchildInhs = - _lhsIchildInhs - -- copy rule (down) - _patternOchildSyns = - _lhsIchildSyns - -- copy rule (down) - _patternOcon = - _lhsIcon - -- copy rule (down) - _patternOdefs = - _lhsIdefs - -- copy rule (down) - _patternOnt = - _lhsInt - -- copy rule (down) - _rhsOchildInhs = - _lhsIchildInhs - -- copy rule (down) - _rhsOchildSyns = - _lhsIchildSyns - -- copy rule (down) - _rhsOcon = - _lhsIcon - -- copy rule (down) - _rhsOnt = - _lhsInt - ( _patternIcopy,_patternIdefsCollect,_patternIerrors,_patternIoutput) = - (pattern_ _patternOchildInhs _patternOchildSyns _patternOcon _patternOdefs _patternOnt ) - ( _rhsIerrors,_rhsIoutput) = - (rhs_ _rhsOchildInhs _rhsOchildSyns _rhsOcon _rhsOnt ) - in ( _lhsOdefsCollect,_lhsOerrors,_lhsOoutput))) ) --- Rules ------------------------------------------------------- -{- - visit 0: - inherited attributes: - childInhs : [(Name, Name)] - childSyns : [(Name, Name)] - con : Constructor - defs : Set (Name, Name) - nt : Nonterminal - synthesized attributes: - defsCollect : Set (Name, Name) - errors : Seq Error - output : SELF - alternatives: - alternative Cons: - child hd : Rule - child tl : Rules - visit 0: - local output : _ - alternative Nil: - visit 0: - local output : _ --} --- cata -sem_Rules :: Rules -> - T_Rules -sem_Rules list = - (Prelude.foldr sem_Rules_Cons sem_Rules_Nil (Prelude.map sem_Rule list) ) --- semantic domain -newtype T_Rules = T_Rules (([(Name, Name)]) -> - ([(Name, Name)]) -> - Constructor -> - (Set (Name, Name)) -> - Nonterminal -> - ( (Set (Name, Name)),(Seq Error),Rules)) -data Inh_Rules = Inh_Rules {childInhs_Inh_Rules :: [(Name, Name)],childSyns_Inh_Rules :: [(Name, Name)],con_Inh_Rules :: Constructor,defs_Inh_Rules :: Set (Name, Name),nt_Inh_Rules :: Nonterminal} -data Syn_Rules = Syn_Rules {defsCollect_Syn_Rules :: Set (Name, Name),errors_Syn_Rules :: Seq Error,output_Syn_Rules :: Rules} -wrap_Rules (T_Rules sem ) (Inh_Rules _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsInt ) = - (let ( _lhsOdefsCollect,_lhsOerrors,_lhsOoutput) = - (sem _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsInt ) - in (Syn_Rules _lhsOdefsCollect _lhsOerrors _lhsOoutput )) -sem_Rules_Cons :: T_Rule -> - T_Rules -> - T_Rules -sem_Rules_Cons (T_Rule hd_ ) (T_Rules tl_ ) = - (T_Rules (\ _lhsIchildInhs - _lhsIchildSyns - _lhsIcon - _lhsIdefs - _lhsInt -> - (let _lhsOdefsCollect :: (Set (Name, Name)) - _lhsOerrors :: (Seq Error) - _lhsOoutput :: Rules - _hdOchildInhs :: ([(Name, Name)]) - _hdOchildSyns :: ([(Name, Name)]) - _hdOcon :: Constructor - _hdOdefs :: (Set (Name, Name)) - _hdOnt :: Nonterminal - _tlOchildInhs :: ([(Name, Name)]) - _tlOchildSyns :: ([(Name, Name)]) - _tlOcon :: Constructor - _tlOdefs :: (Set (Name, Name)) - _tlOnt :: Nonterminal - _hdIdefsCollect :: (Set (Name, Name)) - _hdIerrors :: (Seq Error) - _hdIoutput :: Rule - _tlIdefsCollect :: (Set (Name, Name)) - _tlIerrors :: (Seq Error) - _tlIoutput :: Rules - -- use rule "Desugar.ag"(line 156, column 52) - _lhsOdefsCollect = - _hdIdefsCollect `Set.union` _tlIdefsCollect - -- use rule "Desugar.ag"(line 30, column 144) - _lhsOerrors = - _hdIerrors Seq.<> _tlIerrors - -- self rule - _output = - (:) _hdIoutput _tlIoutput - -- self rule - _lhsOoutput = - _output - -- copy rule (down) - _hdOchildInhs = - _lhsIchildInhs - -- copy rule (down) - _hdOchildSyns = - _lhsIchildSyns - -- copy rule (down) - _hdOcon = - _lhsIcon - -- copy rule (down) - _hdOdefs = - _lhsIdefs - -- copy rule (down) - _hdOnt = - _lhsInt - -- copy rule (down) - _tlOchildInhs = - _lhsIchildInhs - -- copy rule (down) - _tlOchildSyns = - _lhsIchildSyns - -- copy rule (down) - _tlOcon = - _lhsIcon - -- copy rule (down) - _tlOdefs = - _lhsIdefs - -- copy rule (down) - _tlOnt = - _lhsInt - ( _hdIdefsCollect,_hdIerrors,_hdIoutput) = - (hd_ _hdOchildInhs _hdOchildSyns _hdOcon _hdOdefs _hdOnt ) - ( _tlIdefsCollect,_tlIerrors,_tlIoutput) = - (tl_ _tlOchildInhs _tlOchildSyns _tlOcon _tlOdefs _tlOnt ) - in ( _lhsOdefsCollect,_lhsOerrors,_lhsOoutput))) ) -sem_Rules_Nil :: T_Rules -sem_Rules_Nil = - (T_Rules (\ _lhsIchildInhs - _lhsIchildSyns - _lhsIcon - _lhsIdefs - _lhsInt -> - (let _lhsOdefsCollect :: (Set (Name, Name)) - _lhsOerrors :: (Seq Error) - _lhsOoutput :: Rules - -- use rule "Desugar.ag"(line 156, column 52) - _lhsOdefsCollect = - Set.empty - -- use rule "Desugar.ag"(line 30, column 144) - _lhsOerrors = - Seq.empty - -- self rule - _output = - [] - -- self rule - _lhsOoutput = - _output - in ( _lhsOdefsCollect,_lhsOerrors,_lhsOoutput))) ) --- TypeSig ----------------------------------------------------- -{- - visit 0: - synthesized attribute: - output : SELF - alternatives: - alternative TypeSig: - child name : {Name} - child tp : {Type} - visit 0: - local output : _ --} --- cata -sem_TypeSig :: TypeSig -> - T_TypeSig -sem_TypeSig (TypeSig _name _tp ) = - (sem_TypeSig_TypeSig _name _tp ) --- semantic domain -newtype T_TypeSig = T_TypeSig (( TypeSig)) -data Inh_TypeSig = Inh_TypeSig {} -data Syn_TypeSig = Syn_TypeSig {output_Syn_TypeSig :: TypeSig} -wrap_TypeSig (T_TypeSig sem ) (Inh_TypeSig ) = - (let ( _lhsOoutput) = - (sem ) - in (Syn_TypeSig _lhsOoutput )) -sem_TypeSig_TypeSig :: Name -> - Type -> - T_TypeSig -sem_TypeSig_TypeSig name_ tp_ = - (T_TypeSig (let _lhsOoutput :: TypeSig - -- self rule - _output = - TypeSig name_ tp_ - -- self rule - _lhsOoutput = - _output - in ( _lhsOoutput)) ) --- TypeSigs ---------------------------------------------------- -{- - visit 0: - synthesized attribute: - output : SELF - alternatives: - alternative Cons: - child hd : TypeSig - child tl : TypeSigs - visit 0: - local output : _ - alternative Nil: - visit 0: - local output : _ --} --- cata -sem_TypeSigs :: TypeSigs -> - T_TypeSigs -sem_TypeSigs list = - (Prelude.foldr sem_TypeSigs_Cons sem_TypeSigs_Nil (Prelude.map sem_TypeSig list) ) --- semantic domain -newtype T_TypeSigs = T_TypeSigs (( TypeSigs)) -data Inh_TypeSigs = Inh_TypeSigs {} -data Syn_TypeSigs = Syn_TypeSigs {output_Syn_TypeSigs :: TypeSigs} -wrap_TypeSigs (T_TypeSigs sem ) (Inh_TypeSigs ) = - (let ( _lhsOoutput) = - (sem ) - in (Syn_TypeSigs _lhsOoutput )) -sem_TypeSigs_Cons :: T_TypeSig -> - T_TypeSigs -> - T_TypeSigs -sem_TypeSigs_Cons (T_TypeSig hd_ ) (T_TypeSigs tl_ ) = - (T_TypeSigs (let _lhsOoutput :: TypeSigs - _hdIoutput :: TypeSig - _tlIoutput :: TypeSigs - -- self rule - _output = - (:) _hdIoutput _tlIoutput - -- self rule - _lhsOoutput = - _output - ( _hdIoutput) = - (hd_ ) - ( _tlIoutput) = - (tl_ ) - in ( _lhsOoutput)) ) -sem_TypeSigs_Nil :: T_TypeSigs -sem_TypeSigs_Nil = - (T_TypeSigs (let _lhsOoutput :: TypeSigs - -- self rule - _output = - [] - -- self rule - _lhsOoutput = - _output - in ( _lhsOoutput)) ) +-- UUAGC 0.9.5 (Desugar.ag) +module Desugar where + +import qualified Data.Set as Set +import qualified Data.Map as Map +import Data.Map(Map) +import qualified UU.DData.Seq as Seq +import UU.DData.Seq(Seq,(<>)) +import UU.Scanner.Position(Pos(..)) +import Maybe +import Data.List(intersperse) + +import AbstractSyntax +import ErrorMessages +import Options +import HsToken +import HsTokenScanner +import TokenDef + +-- AbstractSyntax.ag imports +import Data.Set(Set) +import Data.Map(Map) +import Patterns (Pattern(..),Patterns) +import Expression (Expression(..)) +import CommonTypes + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (ConstructorIdent,Identifier) + +import UU.Scanner.Position(Pos) +import HsToken + +import CommonTypes +import UU.Scanner.Position(Pos) + +addl :: Int -> Pos -> Pos +addl n (Pos l c f) = Pos (l+n) c f + +maybeError :: a -> Error -> Maybe a -> (a, Seq Error) +maybeError def err mb + = maybe (def, Seq.single err) (\r -> (r, Seq.empty)) mb + +findField :: Identifier -> Identifier -> [(Identifier,Identifier)] -> Maybe Identifier +findField fld attr list + | fld == _FIRST = f list + | fld == _LAST = f (reverse list) + | otherwise = Just fld + where + f = lookup attr + +mergeAttributes :: AttrMap -> AttrMap -> AttrMap +mergeAttributes = Map.unionWith $ Map.unionWith $ Set.union +-- Child ------------------------------------------------------- +{- + visit 0: + synthesized attributes: + childInhs : [(Identifier, Identifier)] + childSyns : [(Identifier, Identifier)] + output : SELF + alternatives: + alternative Child: + child name : {Identifier} + child tp : {Type} + child inh : {Attributes} + child syn : {Attributes} + child higherOrder : {Bool} + visit 0: + local output : _ +-} +-- cata +sem_Child :: Child -> + T_Child +sem_Child (Child _name _tp _inh _syn _higherOrder) = + (sem_Child_Child _name _tp _inh _syn _higherOrder) +-- semantic domain +newtype T_Child = T_Child (( ([(Identifier, Identifier)]),([(Identifier, Identifier)]),Child)) +data Inh_Child = Inh_Child {} +data Syn_Child = Syn_Child {childInhs_Syn_Child :: [(Identifier, Identifier)],childSyns_Syn_Child :: [(Identifier, Identifier)],output_Syn_Child :: Child} +wrap_Child (T_Child sem) (Inh_Child ) = + (let ( _lhsOchildInhs,_lhsOchildSyns,_lhsOoutput) = + (sem ) + in (Syn_Child _lhsOchildInhs _lhsOchildSyns _lhsOoutput)) +sem_Child_Child :: Identifier -> + Type -> + Attributes -> + Attributes -> + Bool -> + T_Child +sem_Child_Child name_ tp_ inh_ syn_ higherOrder_ = + (T_Child (let _lhsOchildInhs :: ([(Identifier, Identifier)]) + _lhsOchildSyns :: ([(Identifier, Identifier)]) + _lhsOoutput :: Child + -- "Desugar.ag"(line 123, column 7) + _lhsOchildInhs = + [(i, name_) | i <- Map.keys inh_ ] + -- "Desugar.ag"(line 124, column 7) + _lhsOchildSyns = + [(s, name_) | s <- Map.keys syn_ ] + -- self rule + _output = + Child name_ tp_ inh_ syn_ higherOrder_ + -- self rule + _lhsOoutput = + _output + in ( _lhsOchildInhs,_lhsOchildSyns,_lhsOoutput))) +-- Children ---------------------------------------------------- +{- + visit 0: + synthesized attributes: + childInhs : [(Identifier, Identifier)] + childSyns : [(Identifier, Identifier)] + output : SELF + alternatives: + alternative Cons: + child hd : Child + child tl : Children + visit 0: + local output : _ + alternative Nil: + visit 0: + local output : _ +-} +-- cata +sem_Children :: Children -> + T_Children +sem_Children list = + (Prelude.foldr sem_Children_Cons sem_Children_Nil (Prelude.map sem_Child list)) +-- semantic domain +newtype T_Children = T_Children (( ([(Identifier, Identifier)]),([(Identifier, Identifier)]),Children)) +data Inh_Children = Inh_Children {} +data Syn_Children = Syn_Children {childInhs_Syn_Children :: [(Identifier, Identifier)],childSyns_Syn_Children :: [(Identifier, Identifier)],output_Syn_Children :: Children} +wrap_Children (T_Children sem) (Inh_Children ) = + (let ( _lhsOchildInhs,_lhsOchildSyns,_lhsOoutput) = + (sem ) + in (Syn_Children _lhsOchildInhs _lhsOchildSyns _lhsOoutput)) +sem_Children_Cons :: T_Child -> + T_Children -> + T_Children +sem_Children_Cons (T_Child hd_) (T_Children tl_) = + (T_Children (let _lhsOchildInhs :: ([(Identifier, Identifier)]) + _lhsOchildSyns :: ([(Identifier, Identifier)]) + _lhsOoutput :: Children + _hdIchildInhs :: ([(Identifier, Identifier)]) + _hdIchildSyns :: ([(Identifier, Identifier)]) + _hdIoutput :: Child + _tlIchildInhs :: ([(Identifier, Identifier)]) + _tlIchildSyns :: ([(Identifier, Identifier)]) + _tlIoutput :: Children + -- use rule "Desugar.ag"(line 118, column 48) + _lhsOchildInhs = + _hdIchildInhs ++ _tlIchildInhs + -- use rule "Desugar.ag"(line 118, column 48) + _lhsOchildSyns = + _hdIchildSyns ++ _tlIchildSyns + -- self rule + _output = + (:) _hdIoutput _tlIoutput + -- self rule + _lhsOoutput = + _output + ( _hdIchildInhs,_hdIchildSyns,_hdIoutput) = + (hd_ ) + ( _tlIchildInhs,_tlIchildSyns,_tlIoutput) = + (tl_ ) + in ( _lhsOchildInhs,_lhsOchildSyns,_lhsOoutput))) +sem_Children_Nil :: T_Children +sem_Children_Nil = + (T_Children (let _lhsOchildInhs :: ([(Identifier, Identifier)]) + _lhsOchildSyns :: ([(Identifier, Identifier)]) + _lhsOoutput :: Children + -- use rule "Desugar.ag"(line 118, column 48) + _lhsOchildInhs = + [] + -- use rule "Desugar.ag"(line 118, column 48) + _lhsOchildSyns = + [] + -- self rule + _output = + [] + -- self rule + _lhsOoutput = + _output + in ( _lhsOchildInhs,_lhsOchildSyns,_lhsOoutput))) +-- Expression -------------------------------------------------- +{- + visit 0: + inherited attributes: + childInhs : [(Identifier, Identifier)] + childSyns : [(Identifier, Identifier)] + con : ConstructorIdent + nt : NontermIdent + options : Options + ruleDescr : String + synthesized attributes: + errors : Seq Error + output : SELF + alternatives: + alternative Expression: + child pos : {Pos} + child tks : {[HsToken]} + visit 0: + local _tup1 : _ + local tks' : _ + local output : _ +-} +-- cata +sem_Expression :: Expression -> + T_Expression +sem_Expression (Expression _pos _tks) = + (sem_Expression_Expression _pos _tks) +-- semantic domain +newtype T_Expression = T_Expression (([(Identifier, Identifier)]) -> + ([(Identifier, Identifier)]) -> + ConstructorIdent -> + NontermIdent -> + Options -> + String -> + ( (Seq Error),Expression)) +data Inh_Expression = Inh_Expression {childInhs_Inh_Expression :: [(Identifier, Identifier)],childSyns_Inh_Expression :: [(Identifier, Identifier)],con_Inh_Expression :: ConstructorIdent,nt_Inh_Expression :: NontermIdent,options_Inh_Expression :: Options,ruleDescr_Inh_Expression :: String} +data Syn_Expression = Syn_Expression {errors_Syn_Expression :: Seq Error,output_Syn_Expression :: Expression} +wrap_Expression (T_Expression sem) (Inh_Expression _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt _lhsIoptions _lhsIruleDescr) = + (let ( _lhsOerrors,_lhsOoutput) = + (sem _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt _lhsIoptions _lhsIruleDescr) + in (Syn_Expression _lhsOerrors _lhsOoutput)) +sem_Expression_Expression :: Pos -> + ([HsToken]) -> + T_Expression +sem_Expression_Expression pos_ tks_ = + (T_Expression (\ _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsInt + _lhsIoptions + _lhsIruleDescr -> + (let _lhsOerrors :: (Seq Error) + _lhsOoutput :: Expression + -- "Desugar.ag"(line 42, column 7) + __tup1 = + let inh = Inh_HsTokensRoot { childInhs_Inh_HsTokensRoot = _lhsIchildInhs + , childSyns_Inh_HsTokensRoot = _lhsIchildSyns + , nt_Inh_HsTokensRoot = _lhsInt + , con_Inh_HsTokensRoot = _lhsIcon + , ruleDescr_Inh_HsTokensRoot = _lhsIruleDescr + , useFieldIdent_Inh_HsTokensRoot = genUseTraces _lhsIoptions + } + sem = sem_HsTokensRoot (HsTokensRoot tks_) + syn = wrap_HsTokensRoot sem inh + in (tks_Syn_HsTokensRoot syn, errors_Syn_HsTokensRoot syn) + -- "Desugar.ag"(line 42, column 7) + (_tks',_) = + __tup1 + -- "Desugar.ag"(line 42, column 7) + (_,_lhsOerrors) = + __tup1 + -- "Desugar.ag"(line 52, column 7) + _lhsOoutput = + Expression pos_ _tks' + -- self rule + _output = + Expression pos_ tks_ + in ( _lhsOerrors,_lhsOoutput)))) +-- Grammar ----------------------------------------------------- +{- + visit 0: + inherited attributes: + forcedIrrefutables : AttrMap + options : Options + synthesized attributes: + allAttributes : AttrMap + errors : Seq Error + output : SELF + alternatives: + alternative Grammar: + child typeSyns : {TypeSyns} + child useMap : {UseMap} + child derivings : {Derivings} + child wrappers : {Set NontermIdent} + child nonts : Nonterminals + child pragmas : {PragmaMap} + child manualAttrOrderMap : {AttrOrderMap} + child paramMap : {ParamMap} + child contextMap : {ContextMap} + visit 0: + local output : _ +-} +-- cata +sem_Grammar :: Grammar -> + T_Grammar +sem_Grammar (Grammar _typeSyns _useMap _derivings _wrappers _nonts _pragmas _manualAttrOrderMap _paramMap _contextMap) = + (sem_Grammar_Grammar _typeSyns _useMap _derivings _wrappers (sem_Nonterminals _nonts) _pragmas _manualAttrOrderMap _paramMap _contextMap) +-- semantic domain +newtype T_Grammar = T_Grammar (AttrMap -> + Options -> + ( AttrMap,(Seq Error),Grammar)) +data Inh_Grammar = Inh_Grammar {forcedIrrefutables_Inh_Grammar :: AttrMap,options_Inh_Grammar :: Options} +data Syn_Grammar = Syn_Grammar {allAttributes_Syn_Grammar :: AttrMap,errors_Syn_Grammar :: Seq Error,output_Syn_Grammar :: Grammar} +wrap_Grammar (T_Grammar sem) (Inh_Grammar _lhsIforcedIrrefutables _lhsIoptions) = + (let ( _lhsOallAttributes,_lhsOerrors,_lhsOoutput) = + (sem _lhsIforcedIrrefutables _lhsIoptions) + in (Syn_Grammar _lhsOallAttributes _lhsOerrors _lhsOoutput)) +sem_Grammar_Grammar :: TypeSyns -> + UseMap -> + Derivings -> + (Set NontermIdent) -> + T_Nonterminals -> + PragmaMap -> + AttrOrderMap -> + ParamMap -> + ContextMap -> + T_Grammar +sem_Grammar_Grammar typeSyns_ useMap_ derivings_ wrappers_ (T_Nonterminals nonts_) pragmas_ manualAttrOrderMap_ paramMap_ contextMap_ = + (T_Grammar (\ _lhsIforcedIrrefutables + _lhsIoptions -> + (let _lhsOallAttributes :: AttrMap + _lhsOerrors :: (Seq Error) + _lhsOoutput :: Grammar + _nontsOforcedIrrefutables :: AttrMap + _nontsOoptions :: Options + _nontsIallAttributes :: AttrMap + _nontsIerrors :: (Seq Error) + _nontsIoutput :: Nonterminals + -- use rule "Desugar.ag"(line 189, column 23) + _lhsOallAttributes = + _nontsIallAttributes + -- use rule "Desugar.ag"(line 31, column 144) + _lhsOerrors = + _nontsIerrors + -- self rule + _output = + Grammar typeSyns_ useMap_ derivings_ wrappers_ _nontsIoutput pragmas_ manualAttrOrderMap_ paramMap_ contextMap_ + -- self rule + _lhsOoutput = + _output + -- copy rule (down) + _nontsOforcedIrrefutables = + _lhsIforcedIrrefutables + -- copy rule (down) + _nontsOoptions = + _lhsIoptions + ( _nontsIallAttributes,_nontsIerrors,_nontsIoutput) = + (nonts_ _nontsOforcedIrrefutables _nontsOoptions) + in ( _lhsOallAttributes,_lhsOerrors,_lhsOoutput)))) +-- HsToken ----------------------------------------------------- +{- + visit 0: + inherited attributes: + childInhs : [(Identifier, Identifier)] + childSyns : [(Identifier, Identifier)] + con : ConstructorIdent + nt : NontermIdent + ruleDescr : String + useFieldIdent : Bool + chained attribute: + addLines : Int + synthesized attributes: + errors : Seq Error + tks : SELF + alternatives: + alternative AGField: + child field : {Identifier} + child attr : {Identifier} + child pos : {Pos} + child rdesc : {Maybe String} + visit 0: + local mField : _ + local field' : _ + local tks : _ + alternative AGLocal: + child var : {Identifier} + child pos : {Pos} + child rdesc : {Maybe String} + visit 0: + local tks : _ + alternative CharToken: + child value : {String} + child pos : {Pos} + visit 0: + local tks : _ + alternative Err: + child mesg : {String} + child pos : {Pos} + visit 0: + local tks : _ + alternative HsToken: + child value : {String} + child pos : {Pos} + visit 0: + local tks : _ + alternative StrToken: + child value : {String} + child pos : {Pos} + visit 0: + local tks : _ +-} +-- cata +sem_HsToken :: HsToken -> + T_HsToken +sem_HsToken (AGField _field _attr _pos _rdesc) = + (sem_HsToken_AGField _field _attr _pos _rdesc) +sem_HsToken (AGLocal _var _pos _rdesc) = + (sem_HsToken_AGLocal _var _pos _rdesc) +sem_HsToken (CharToken _value _pos) = + (sem_HsToken_CharToken _value _pos) +sem_HsToken (Err _mesg _pos) = + (sem_HsToken_Err _mesg _pos) +sem_HsToken (HsToken _value _pos) = + (sem_HsToken_HsToken _value _pos) +sem_HsToken (StrToken _value _pos) = + (sem_HsToken_StrToken _value _pos) +-- semantic domain +newtype T_HsToken = T_HsToken (Int -> + ([(Identifier, Identifier)]) -> + ([(Identifier, Identifier)]) -> + ConstructorIdent -> + NontermIdent -> + String -> + Bool -> + ( Int,(Seq Error),HsToken)) +data Inh_HsToken = Inh_HsToken {addLines_Inh_HsToken :: Int,childInhs_Inh_HsToken :: [(Identifier, Identifier)],childSyns_Inh_HsToken :: [(Identifier, Identifier)],con_Inh_HsToken :: ConstructorIdent,nt_Inh_HsToken :: NontermIdent,ruleDescr_Inh_HsToken :: String,useFieldIdent_Inh_HsToken :: Bool} +data Syn_HsToken = Syn_HsToken {addLines_Syn_HsToken :: Int,errors_Syn_HsToken :: Seq Error,tks_Syn_HsToken :: HsToken} +wrap_HsToken (T_HsToken sem) (Inh_HsToken _lhsIaddLines _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt _lhsIruleDescr _lhsIuseFieldIdent) = + (let ( _lhsOaddLines,_lhsOerrors,_lhsOtks) = + (sem _lhsIaddLines _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt _lhsIruleDescr _lhsIuseFieldIdent) + in (Syn_HsToken _lhsOaddLines _lhsOerrors _lhsOtks)) +sem_HsToken_AGField :: Identifier -> + Identifier -> + Pos -> + (Maybe String) -> + T_HsToken +sem_HsToken_AGField field_ attr_ pos_ rdesc_ = + (T_HsToken (\ _lhsIaddLines + _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsInt + _lhsIruleDescr + _lhsIuseFieldIdent -> + (let _lhsOerrors :: (Seq Error) + _lhsOaddLines :: Int + _lhsOtks :: HsToken + -- "Desugar.ag"(line 72, column 7) + _mField = + findField field_ attr_ _lhsIchildSyns + -- "Desugar.ag"(line 74, column 7) + _field' = + maybe field_ id _mField + -- "Desugar.ag"(line 75, column 7) + _lhsOerrors = + maybe (Seq.single (UndefAttr _lhsInt _lhsIcon field_ (Ident "" (getPos field_)) False)) (const Seq.empty) _mField + -- "Desugar.ag"(line 77, column 7) + _lhsOaddLines = + if _lhsIuseFieldIdent || length (getName field_) < length (getName _field' ) + then _lhsIaddLines + 1 + else _lhsIaddLines + -- "Desugar.ag"(line 81, column 7) + _tks = + AGField field_ attr_ (addl _lhsIaddLines pos_) (if _lhsIuseFieldIdent then Just _lhsIruleDescr else Nothing) + -- self rule + _lhsOtks = + _tks + in ( _lhsOaddLines,_lhsOerrors,_lhsOtks)))) +sem_HsToken_AGLocal :: Identifier -> + Pos -> + (Maybe String) -> + T_HsToken +sem_HsToken_AGLocal var_ pos_ rdesc_ = + (T_HsToken (\ _lhsIaddLines + _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsInt + _lhsIruleDescr + _lhsIuseFieldIdent -> + (let _lhsOaddLines :: Int + _lhsOerrors :: (Seq Error) + _lhsOtks :: HsToken + -- "Desugar.ag"(line 67, column 7) + _lhsOaddLines = + if _lhsIuseFieldIdent + then _lhsIaddLines + 1 + else _lhsIaddLines + -- "Desugar.ag"(line 70, column 7) + _tks = + AGLocal var_ (addl _lhsIaddLines pos_) (if _lhsIuseFieldIdent then Just _lhsIruleDescr else Nothing) + -- use rule "Desugar.ag"(line 31, column 144) + _lhsOerrors = + Seq.empty + -- self rule + _lhsOtks = + _tks + in ( _lhsOaddLines,_lhsOerrors,_lhsOtks)))) +sem_HsToken_CharToken :: String -> + Pos -> + T_HsToken +sem_HsToken_CharToken value_ pos_ = + (T_HsToken (\ _lhsIaddLines + _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsInt + _lhsIruleDescr + _lhsIuseFieldIdent -> + (let _lhsOerrors :: (Seq Error) + _lhsOtks :: HsToken + _lhsOaddLines :: Int + -- "Desugar.ag"(line 85, column 7) + _tks = + CharToken value_ (addl _lhsIaddLines pos_) + -- use rule "Desugar.ag"(line 31, column 144) + _lhsOerrors = + Seq.empty + -- self rule + _lhsOtks = + _tks + -- copy rule (chain) + _lhsOaddLines = + _lhsIaddLines + in ( _lhsOaddLines,_lhsOerrors,_lhsOtks)))) +sem_HsToken_Err :: String -> + Pos -> + T_HsToken +sem_HsToken_Err mesg_ pos_ = + (T_HsToken (\ _lhsIaddLines + _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsInt + _lhsIruleDescr + _lhsIuseFieldIdent -> + (let _lhsOerrors :: (Seq Error) + _lhsOtks :: HsToken + _lhsOaddLines :: Int + -- "Desugar.ag"(line 89, column 7) + _tks = + Err mesg_ (addl _lhsIaddLines pos_) + -- use rule "Desugar.ag"(line 31, column 144) + _lhsOerrors = + Seq.empty + -- self rule + _lhsOtks = + _tks + -- copy rule (chain) + _lhsOaddLines = + _lhsIaddLines + in ( _lhsOaddLines,_lhsOerrors,_lhsOtks)))) +sem_HsToken_HsToken :: String -> + Pos -> + T_HsToken +sem_HsToken_HsToken value_ pos_ = + (T_HsToken (\ _lhsIaddLines + _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsInt + _lhsIruleDescr + _lhsIuseFieldIdent -> + (let _lhsOerrors :: (Seq Error) + _lhsOtks :: HsToken + _lhsOaddLines :: Int + -- "Desugar.ag"(line 83, column 7) + _tks = + HsToken value_ (addl _lhsIaddLines pos_) + -- use rule "Desugar.ag"(line 31, column 144) + _lhsOerrors = + Seq.empty + -- self rule + _lhsOtks = + _tks + -- copy rule (chain) + _lhsOaddLines = + _lhsIaddLines + in ( _lhsOaddLines,_lhsOerrors,_lhsOtks)))) +sem_HsToken_StrToken :: String -> + Pos -> + T_HsToken +sem_HsToken_StrToken value_ pos_ = + (T_HsToken (\ _lhsIaddLines + _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsInt + _lhsIruleDescr + _lhsIuseFieldIdent -> + (let _lhsOerrors :: (Seq Error) + _lhsOtks :: HsToken + _lhsOaddLines :: Int + -- "Desugar.ag"(line 87, column 7) + _tks = + StrToken value_ (addl _lhsIaddLines pos_) + -- use rule "Desugar.ag"(line 31, column 144) + _lhsOerrors = + Seq.empty + -- self rule + _lhsOtks = + _tks + -- copy rule (chain) + _lhsOaddLines = + _lhsIaddLines + in ( _lhsOaddLines,_lhsOerrors,_lhsOtks)))) +-- HsTokens ---------------------------------------------------- +{- + visit 0: + inherited attributes: + childInhs : [(Identifier, Identifier)] + childSyns : [(Identifier, Identifier)] + con : ConstructorIdent + nt : NontermIdent + ruleDescr : String + useFieldIdent : Bool + chained attribute: + addLines : Int + synthesized attributes: + errors : Seq Error + tks : SELF + alternatives: + alternative Cons: + child hd : HsToken + child tl : HsTokens + visit 0: + local tks : _ + alternative Nil: + visit 0: + local tks : _ +-} +-- cata +sem_HsTokens :: HsTokens -> + T_HsTokens +sem_HsTokens list = + (Prelude.foldr sem_HsTokens_Cons sem_HsTokens_Nil (Prelude.map sem_HsToken list)) +-- semantic domain +newtype T_HsTokens = T_HsTokens (Int -> + ([(Identifier, Identifier)]) -> + ([(Identifier, Identifier)]) -> + ConstructorIdent -> + NontermIdent -> + String -> + Bool -> + ( Int,(Seq Error),HsTokens)) +data Inh_HsTokens = Inh_HsTokens {addLines_Inh_HsTokens :: Int,childInhs_Inh_HsTokens :: [(Identifier, Identifier)],childSyns_Inh_HsTokens :: [(Identifier, Identifier)],con_Inh_HsTokens :: ConstructorIdent,nt_Inh_HsTokens :: NontermIdent,ruleDescr_Inh_HsTokens :: String,useFieldIdent_Inh_HsTokens :: Bool} +data Syn_HsTokens = Syn_HsTokens {addLines_Syn_HsTokens :: Int,errors_Syn_HsTokens :: Seq Error,tks_Syn_HsTokens :: HsTokens} +wrap_HsTokens (T_HsTokens sem) (Inh_HsTokens _lhsIaddLines _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt _lhsIruleDescr _lhsIuseFieldIdent) = + (let ( _lhsOaddLines,_lhsOerrors,_lhsOtks) = + (sem _lhsIaddLines _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt _lhsIruleDescr _lhsIuseFieldIdent) + in (Syn_HsTokens _lhsOaddLines _lhsOerrors _lhsOtks)) +sem_HsTokens_Cons :: T_HsToken -> + T_HsTokens -> + T_HsTokens +sem_HsTokens_Cons (T_HsToken hd_) (T_HsTokens tl_) = + (T_HsTokens (\ _lhsIaddLines + _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsInt + _lhsIruleDescr + _lhsIuseFieldIdent -> + (let _lhsOerrors :: (Seq Error) + _lhsOtks :: HsTokens + _lhsOaddLines :: Int + _hdOaddLines :: Int + _hdOchildInhs :: ([(Identifier, Identifier)]) + _hdOchildSyns :: ([(Identifier, Identifier)]) + _hdOcon :: ConstructorIdent + _hdOnt :: NontermIdent + _hdOruleDescr :: String + _hdOuseFieldIdent :: Bool + _tlOaddLines :: Int + _tlOchildInhs :: ([(Identifier, Identifier)]) + _tlOchildSyns :: ([(Identifier, Identifier)]) + _tlOcon :: ConstructorIdent + _tlOnt :: NontermIdent + _tlOruleDescr :: String + _tlOuseFieldIdent :: Bool + _hdIaddLines :: Int + _hdIerrors :: (Seq Error) + _hdItks :: HsToken + _tlIaddLines :: Int + _tlIerrors :: (Seq Error) + _tlItks :: HsTokens + -- use rule "Desugar.ag"(line 31, column 144) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- self rule + _tks = + (:) _hdItks _tlItks + -- self rule + _lhsOtks = + _tks + -- copy rule (up) + _lhsOaddLines = + _tlIaddLines + -- copy rule (down) + _hdOaddLines = + _lhsIaddLines + -- copy rule (down) + _hdOchildInhs = + _lhsIchildInhs + -- copy rule (down) + _hdOchildSyns = + _lhsIchildSyns + -- copy rule (down) + _hdOcon = + _lhsIcon + -- copy rule (down) + _hdOnt = + _lhsInt + -- copy rule (down) + _hdOruleDescr = + _lhsIruleDescr + -- copy rule (down) + _hdOuseFieldIdent = + _lhsIuseFieldIdent + -- copy rule (chain) + _tlOaddLines = + _hdIaddLines + -- copy rule (down) + _tlOchildInhs = + _lhsIchildInhs + -- copy rule (down) + _tlOchildSyns = + _lhsIchildSyns + -- copy rule (down) + _tlOcon = + _lhsIcon + -- copy rule (down) + _tlOnt = + _lhsInt + -- copy rule (down) + _tlOruleDescr = + _lhsIruleDescr + -- copy rule (down) + _tlOuseFieldIdent = + _lhsIuseFieldIdent + ( _hdIaddLines,_hdIerrors,_hdItks) = + (hd_ _hdOaddLines _hdOchildInhs _hdOchildSyns _hdOcon _hdOnt _hdOruleDescr _hdOuseFieldIdent) + ( _tlIaddLines,_tlIerrors,_tlItks) = + (tl_ _tlOaddLines _tlOchildInhs _tlOchildSyns _tlOcon _tlOnt _tlOruleDescr _tlOuseFieldIdent) + in ( _lhsOaddLines,_lhsOerrors,_lhsOtks)))) +sem_HsTokens_Nil :: T_HsTokens +sem_HsTokens_Nil = + (T_HsTokens (\ _lhsIaddLines + _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsInt + _lhsIruleDescr + _lhsIuseFieldIdent -> + (let _lhsOerrors :: (Seq Error) + _lhsOtks :: HsTokens + _lhsOaddLines :: Int + -- use rule "Desugar.ag"(line 31, column 144) + _lhsOerrors = + Seq.empty + -- self rule + _tks = + [] + -- self rule + _lhsOtks = + _tks + -- copy rule (chain) + _lhsOaddLines = + _lhsIaddLines + in ( _lhsOaddLines,_lhsOerrors,_lhsOtks)))) +-- HsTokensRoot ------------------------------------------------ +{- + visit 0: + inherited attributes: + childInhs : [(Identifier, Identifier)] + childSyns : [(Identifier, Identifier)] + con : ConstructorIdent + nt : NontermIdent + ruleDescr : String + useFieldIdent : Bool + synthesized attributes: + errors : Seq Error + tks : [HsToken] + alternatives: + alternative HsTokensRoot: + child tokens : HsTokens +-} +-- cata +sem_HsTokensRoot :: HsTokensRoot -> + T_HsTokensRoot +sem_HsTokensRoot (HsTokensRoot _tokens) = + (sem_HsTokensRoot_HsTokensRoot (sem_HsTokens _tokens)) +-- semantic domain +newtype T_HsTokensRoot = T_HsTokensRoot (([(Identifier, Identifier)]) -> + ([(Identifier, Identifier)]) -> + ConstructorIdent -> + NontermIdent -> + String -> + Bool -> + ( (Seq Error),([HsToken]))) +data Inh_HsTokensRoot = Inh_HsTokensRoot {childInhs_Inh_HsTokensRoot :: [(Identifier, Identifier)],childSyns_Inh_HsTokensRoot :: [(Identifier, Identifier)],con_Inh_HsTokensRoot :: ConstructorIdent,nt_Inh_HsTokensRoot :: NontermIdent,ruleDescr_Inh_HsTokensRoot :: String,useFieldIdent_Inh_HsTokensRoot :: Bool} +data Syn_HsTokensRoot = Syn_HsTokensRoot {errors_Syn_HsTokensRoot :: Seq Error,tks_Syn_HsTokensRoot :: [HsToken]} +wrap_HsTokensRoot (T_HsTokensRoot sem) (Inh_HsTokensRoot _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt _lhsIruleDescr _lhsIuseFieldIdent) = + (let ( _lhsOerrors,_lhsOtks) = + (sem _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt _lhsIruleDescr _lhsIuseFieldIdent) + in (Syn_HsTokensRoot _lhsOerrors _lhsOtks)) +sem_HsTokensRoot_HsTokensRoot :: T_HsTokens -> + T_HsTokensRoot +sem_HsTokensRoot_HsTokensRoot (T_HsTokens tokens_) = + (T_HsTokensRoot (\ _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsInt + _lhsIruleDescr + _lhsIuseFieldIdent -> + (let _tokensOaddLines :: Int + _lhsOerrors :: (Seq Error) + _lhsOtks :: ([HsToken]) + _tokensOchildInhs :: ([(Identifier, Identifier)]) + _tokensOchildSyns :: ([(Identifier, Identifier)]) + _tokensOcon :: ConstructorIdent + _tokensOnt :: NontermIdent + _tokensOruleDescr :: String + _tokensOuseFieldIdent :: Bool + _tokensIaddLines :: Int + _tokensIerrors :: (Seq Error) + _tokensItks :: HsTokens + -- "Desugar.ag"(line 60, column 7) + _tokensOaddLines = + 0 + -- use rule "Desugar.ag"(line 31, column 144) + _lhsOerrors = + _tokensIerrors + -- copy rule (up) + _lhsOtks = + _tokensItks + -- copy rule (down) + _tokensOchildInhs = + _lhsIchildInhs + -- copy rule (down) + _tokensOchildSyns = + _lhsIchildSyns + -- copy rule (down) + _tokensOcon = + _lhsIcon + -- copy rule (down) + _tokensOnt = + _lhsInt + -- copy rule (down) + _tokensOruleDescr = + _lhsIruleDescr + -- copy rule (down) + _tokensOuseFieldIdent = + _lhsIuseFieldIdent + ( _tokensIaddLines,_tokensIerrors,_tokensItks) = + (tokens_ _tokensOaddLines _tokensOchildInhs _tokensOchildSyns _tokensOcon _tokensOnt _tokensOruleDescr _tokensOuseFieldIdent) + in ( _lhsOerrors,_lhsOtks)))) +-- Nonterminal ------------------------------------------------- +{- + visit 0: + inherited attributes: + forcedIrrefutables : AttrMap + options : Options + synthesized attributes: + allAttributes : AttrMap + errors : Seq Error + output : SELF + alternatives: + alternative Nonterminal: + child nt : {NontermIdent} + child params : {[Identifier]} + child inh : {Attributes} + child syn : {Attributes} + child prods : Productions + visit 0: + local output : _ +-} +-- cata +sem_Nonterminal :: Nonterminal -> + T_Nonterminal +sem_Nonterminal (Nonterminal _nt _params _inh _syn _prods) = + (sem_Nonterminal_Nonterminal _nt _params _inh _syn (sem_Productions _prods)) +-- semantic domain +newtype T_Nonterminal = T_Nonterminal (AttrMap -> + Options -> + ( AttrMap,(Seq Error),Nonterminal)) +data Inh_Nonterminal = Inh_Nonterminal {forcedIrrefutables_Inh_Nonterminal :: AttrMap,options_Inh_Nonterminal :: Options} +data Syn_Nonterminal = Syn_Nonterminal {allAttributes_Syn_Nonterminal :: AttrMap,errors_Syn_Nonterminal :: Seq Error,output_Syn_Nonterminal :: Nonterminal} +wrap_Nonterminal (T_Nonterminal sem) (Inh_Nonterminal _lhsIforcedIrrefutables _lhsIoptions) = + (let ( _lhsOallAttributes,_lhsOerrors,_lhsOoutput) = + (sem _lhsIforcedIrrefutables _lhsIoptions) + in (Syn_Nonterminal _lhsOallAttributes _lhsOerrors _lhsOoutput)) +sem_Nonterminal_Nonterminal :: NontermIdent -> + ([Identifier]) -> + Attributes -> + Attributes -> + T_Productions -> + T_Nonterminal +sem_Nonterminal_Nonterminal nt_ params_ inh_ syn_ (T_Productions prods_) = + (T_Nonterminal (\ _lhsIforcedIrrefutables + _lhsIoptions -> + (let _prodsOnt :: NontermIdent + _lhsOallAttributes :: AttrMap + _lhsOerrors :: (Seq Error) + _lhsOoutput :: Nonterminal + _prodsOforcedIrrefutables :: AttrMap + _prodsOoptions :: Options + _prodsIallAttributes :: AttrMap + _prodsIerrors :: (Seq Error) + _prodsIoutput :: Productions + -- "Desugar.ag"(line 150, column 7) + _prodsOnt = + nt_ + -- use rule "Desugar.ag"(line 189, column 23) + _lhsOallAttributes = + _prodsIallAttributes + -- use rule "Desugar.ag"(line 31, column 144) + _lhsOerrors = + _prodsIerrors + -- self rule + _output = + Nonterminal nt_ params_ inh_ syn_ _prodsIoutput + -- self rule + _lhsOoutput = + _output + -- copy rule (down) + _prodsOforcedIrrefutables = + _lhsIforcedIrrefutables + -- copy rule (down) + _prodsOoptions = + _lhsIoptions + ( _prodsIallAttributes,_prodsIerrors,_prodsIoutput) = + (prods_ _prodsOforcedIrrefutables _prodsOnt _prodsOoptions) + in ( _lhsOallAttributes,_lhsOerrors,_lhsOoutput)))) +-- Nonterminals ------------------------------------------------ +{- + visit 0: + inherited attributes: + forcedIrrefutables : AttrMap + options : Options + synthesized attributes: + allAttributes : AttrMap + errors : Seq Error + output : SELF + alternatives: + alternative Cons: + child hd : Nonterminal + child tl : Nonterminals + visit 0: + local output : _ + alternative Nil: + visit 0: + local output : _ +-} +-- cata +sem_Nonterminals :: Nonterminals -> + T_Nonterminals +sem_Nonterminals list = + (Prelude.foldr sem_Nonterminals_Cons sem_Nonterminals_Nil (Prelude.map sem_Nonterminal list)) +-- semantic domain +newtype T_Nonterminals = T_Nonterminals (AttrMap -> + Options -> + ( AttrMap,(Seq Error),Nonterminals)) +data Inh_Nonterminals = Inh_Nonterminals {forcedIrrefutables_Inh_Nonterminals :: AttrMap,options_Inh_Nonterminals :: Options} +data Syn_Nonterminals = Syn_Nonterminals {allAttributes_Syn_Nonterminals :: AttrMap,errors_Syn_Nonterminals :: Seq Error,output_Syn_Nonterminals :: Nonterminals} +wrap_Nonterminals (T_Nonterminals sem) (Inh_Nonterminals _lhsIforcedIrrefutables _lhsIoptions) = + (let ( _lhsOallAttributes,_lhsOerrors,_lhsOoutput) = + (sem _lhsIforcedIrrefutables _lhsIoptions) + in (Syn_Nonterminals _lhsOallAttributes _lhsOerrors _lhsOoutput)) +sem_Nonterminals_Cons :: T_Nonterminal -> + T_Nonterminals -> + T_Nonterminals +sem_Nonterminals_Cons (T_Nonterminal hd_) (T_Nonterminals tl_) = + (T_Nonterminals (\ _lhsIforcedIrrefutables + _lhsIoptions -> + (let _lhsOallAttributes :: AttrMap + _lhsOerrors :: (Seq Error) + _lhsOoutput :: Nonterminals + _hdOforcedIrrefutables :: AttrMap + _hdOoptions :: Options + _tlOforcedIrrefutables :: AttrMap + _tlOoptions :: Options + _hdIallAttributes :: AttrMap + _hdIerrors :: (Seq Error) + _hdIoutput :: Nonterminal + _tlIallAttributes :: AttrMap + _tlIerrors :: (Seq Error) + _tlIoutput :: Nonterminals + -- use rule "Desugar.ag"(line 189, column 23) + _lhsOallAttributes = + _hdIallAttributes `mergeAttributes` _tlIallAttributes + -- use rule "Desugar.ag"(line 31, column 144) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- self rule + _output = + (:) _hdIoutput _tlIoutput + -- self rule + _lhsOoutput = + _output + -- copy rule (down) + _hdOforcedIrrefutables = + _lhsIforcedIrrefutables + -- copy rule (down) + _hdOoptions = + _lhsIoptions + -- copy rule (down) + _tlOforcedIrrefutables = + _lhsIforcedIrrefutables + -- copy rule (down) + _tlOoptions = + _lhsIoptions + ( _hdIallAttributes,_hdIerrors,_hdIoutput) = + (hd_ _hdOforcedIrrefutables _hdOoptions) + ( _tlIallAttributes,_tlIerrors,_tlIoutput) = + (tl_ _tlOforcedIrrefutables _tlOoptions) + in ( _lhsOallAttributes,_lhsOerrors,_lhsOoutput)))) +sem_Nonterminals_Nil :: T_Nonterminals +sem_Nonterminals_Nil = + (T_Nonterminals (\ _lhsIforcedIrrefutables + _lhsIoptions -> + (let _lhsOallAttributes :: AttrMap + _lhsOerrors :: (Seq Error) + _lhsOoutput :: Nonterminals + -- use rule "Desugar.ag"(line 189, column 23) + _lhsOallAttributes = + Map.empty + -- use rule "Desugar.ag"(line 31, column 144) + _lhsOerrors = + Seq.empty + -- self rule + _output = + [] + -- self rule + _lhsOoutput = + _output + in ( _lhsOallAttributes,_lhsOerrors,_lhsOoutput)))) +-- Pattern ----------------------------------------------------- +{- + visit 0: + inherited attributes: + childInhs : [(Identifier, Identifier)] + childSyns : [(Identifier, Identifier)] + con : ConstructorIdent + defs : Set (Identifier, Identifier) + forcedIrrefutables : AttrMap + nt : NontermIdent + synthesized attributes: + allAttributes : AttrMap + copy : SELF + defsCollect : Set (Identifier, Identifier) + errors : Seq Error + output : SELF + alternatives: + alternative Alias: + child field : {Identifier} + child attr : {Identifier} + child pat : Pattern + child parts : Patterns + visit 0: + local _tup2 : _ + local field' : _ + local err1 : _ + local err2 : _ + local output : _ + local def : _ + local copy : _ + alternative Constr: + child name : {ConstructorIdent} + child pats : Patterns + visit 0: + local copy : _ + local output : _ + alternative Irrefutable: + child pat : Pattern + visit 0: + local copy : _ + local output : _ + alternative Product: + child pos : {Pos} + child pats : Patterns + visit 0: + local copy : _ + local output : _ + alternative Underscore: + child pos : {Pos} + visit 0: + local copy : _ + local output : _ +-} +-- cata +sem_Pattern :: Pattern -> + T_Pattern +sem_Pattern (Alias _field _attr _pat _parts) = + (sem_Pattern_Alias _field _attr (sem_Pattern _pat) (sem_Patterns _parts)) +sem_Pattern (Constr _name _pats) = + (sem_Pattern_Constr _name (sem_Patterns _pats)) +sem_Pattern (Irrefutable _pat) = + (sem_Pattern_Irrefutable (sem_Pattern _pat)) +sem_Pattern (Product _pos _pats) = + (sem_Pattern_Product _pos (sem_Patterns _pats)) +sem_Pattern (Underscore _pos) = + (sem_Pattern_Underscore _pos) +-- semantic domain +newtype T_Pattern = T_Pattern (([(Identifier, Identifier)]) -> + ([(Identifier, Identifier)]) -> + ConstructorIdent -> + (Set (Identifier, Identifier)) -> + AttrMap -> + NontermIdent -> + ( AttrMap,Pattern,(Set (Identifier, Identifier)),(Seq Error),Pattern)) +data Inh_Pattern = Inh_Pattern {childInhs_Inh_Pattern :: [(Identifier, Identifier)],childSyns_Inh_Pattern :: [(Identifier, Identifier)],con_Inh_Pattern :: ConstructorIdent,defs_Inh_Pattern :: Set (Identifier, Identifier),forcedIrrefutables_Inh_Pattern :: AttrMap,nt_Inh_Pattern :: NontermIdent} +data Syn_Pattern = Syn_Pattern {allAttributes_Syn_Pattern :: AttrMap,copy_Syn_Pattern :: Pattern,defsCollect_Syn_Pattern :: Set (Identifier, Identifier),errors_Syn_Pattern :: Seq Error,output_Syn_Pattern :: Pattern} +wrap_Pattern (T_Pattern sem) (Inh_Pattern _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt) = + (let ( _lhsOallAttributes,_lhsOcopy,_lhsOdefsCollect,_lhsOerrors,_lhsOoutput) = + (sem _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt) + in (Syn_Pattern _lhsOallAttributes _lhsOcopy _lhsOdefsCollect _lhsOerrors _lhsOoutput)) +sem_Pattern_Alias :: Identifier -> + Identifier -> + T_Pattern -> + T_Patterns -> + T_Pattern +sem_Pattern_Alias field_ attr_ (T_Pattern pat_) (T_Patterns parts_) = + (T_Pattern (\ _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsIdefs + _lhsIforcedIrrefutables + _lhsInt -> + (let _lhsOerrors :: (Seq Error) + _lhsOdefsCollect :: (Set (Identifier, Identifier)) + _lhsOallAttributes :: AttrMap + _lhsOoutput :: Pattern + _lhsOcopy :: Pattern + _patOchildInhs :: ([(Identifier, Identifier)]) + _patOchildSyns :: ([(Identifier, Identifier)]) + _patOcon :: ConstructorIdent + _patOdefs :: (Set (Identifier, Identifier)) + _patOforcedIrrefutables :: AttrMap + _patOnt :: NontermIdent + _partsOchildInhs :: ([(Identifier, Identifier)]) + _partsOchildSyns :: ([(Identifier, Identifier)]) + _partsOcon :: ConstructorIdent + _partsOdefs :: (Set (Identifier, Identifier)) + _partsOforcedIrrefutables :: AttrMap + _partsOnt :: NontermIdent + _patIallAttributes :: AttrMap + _patIcopy :: Pattern + _patIdefsCollect :: (Set (Identifier, Identifier)) + _patIerrors :: (Seq Error) + _patIoutput :: Pattern + _partsIallAttributes :: AttrMap + _partsIcopy :: Patterns + _partsIdefsCollect :: (Set (Identifier, Identifier)) + _partsIerrors :: (Seq Error) + _partsIoutput :: Patterns + -- "Desugar.ag"(line 103, column 7) + __tup2 = + maybeError field_ (UndefAttr _lhsInt _lhsIcon (Ident "" (getPos field_)) attr_ True) $ + findField field_ attr_ _lhsIchildInhs + -- "Desugar.ag"(line 103, column 7) + (_field',_) = + __tup2 + -- "Desugar.ag"(line 103, column 7) + (_,_err1) = + __tup2 + -- "Desugar.ag"(line 105, column 7) + _err2 = + if _field' == field_ + then Seq.empty + else if (_field' , attr_) `Set.member` _lhsIdefs + then Seq.single $ DupRule _lhsInt _lhsIcon field_ attr_ _field' + else Seq.empty + -- "Desugar.ag"(line 110, column 7) + _lhsOerrors = + _err1 Seq.<> _err2 Seq.<> _patIerrors <> _partsIerrors + -- "Desugar.ag"(line 111, column 7) + _output = + Alias _field' attr_ _patIoutput _partsIoutput + -- "Desugar.ag"(line 175, column 7) + _def = + Set.singleton (field_, attr_) + -- "Desugar.ag"(line 176, column 7) + _lhsOdefsCollect = + _def `Set.union` _patIdefsCollect `Set.union` _partsIdefsCollect + -- "Desugar.ag"(line 193, column 7) + _lhsOallAttributes = + (Map.singleton _lhsInt $ Map.singleton _lhsIcon $ Set.singleton (field_, attr_)) `mergeAttributes` _patIallAttributes + -- "Desugar.ag"(line 212, column 7) + _lhsOoutput = + if Set.member (field_, attr_) $ Map.findWithDefault Set.empty _lhsIcon $ Map.findWithDefault Map.empty _lhsInt $ _lhsIforcedIrrefutables + then Irrefutable _output + else _output + -- self rule + _copy = + Alias field_ attr_ _patIcopy _partsIcopy + -- self rule + _lhsOcopy = + _copy + -- copy rule (down) + _patOchildInhs = + _lhsIchildInhs + -- copy rule (down) + _patOchildSyns = + _lhsIchildSyns + -- copy rule (down) + _patOcon = + _lhsIcon + -- copy rule (down) + _patOdefs = + _lhsIdefs + -- copy rule (down) + _patOforcedIrrefutables = + _lhsIforcedIrrefutables + -- copy rule (down) + _patOnt = + _lhsInt + -- copy rule (down) + _partsOchildInhs = + _lhsIchildInhs + -- copy rule (down) + _partsOchildSyns = + _lhsIchildSyns + -- copy rule (down) + _partsOcon = + _lhsIcon + -- copy rule (down) + _partsOdefs = + _lhsIdefs + -- copy rule (down) + _partsOforcedIrrefutables = + _lhsIforcedIrrefutables + -- copy rule (down) + _partsOnt = + _lhsInt + ( _patIallAttributes,_patIcopy,_patIdefsCollect,_patIerrors,_patIoutput) = + (pat_ _patOchildInhs _patOchildSyns _patOcon _patOdefs _patOforcedIrrefutables _patOnt) + ( _partsIallAttributes,_partsIcopy,_partsIdefsCollect,_partsIerrors,_partsIoutput) = + (parts_ _partsOchildInhs _partsOchildSyns _partsOcon _partsOdefs _partsOforcedIrrefutables _partsOnt) + in ( _lhsOallAttributes,_lhsOcopy,_lhsOdefsCollect,_lhsOerrors,_lhsOoutput)))) +sem_Pattern_Constr :: ConstructorIdent -> + T_Patterns -> + T_Pattern +sem_Pattern_Constr name_ (T_Patterns pats_) = + (T_Pattern (\ _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsIdefs + _lhsIforcedIrrefutables + _lhsInt -> + (let _lhsOallAttributes :: AttrMap + _lhsOdefsCollect :: (Set (Identifier, Identifier)) + _lhsOerrors :: (Seq Error) + _lhsOcopy :: Pattern + _lhsOoutput :: Pattern + _patsOchildInhs :: ([(Identifier, Identifier)]) + _patsOchildSyns :: ([(Identifier, Identifier)]) + _patsOcon :: ConstructorIdent + _patsOdefs :: (Set (Identifier, Identifier)) + _patsOforcedIrrefutables :: AttrMap + _patsOnt :: NontermIdent + _patsIallAttributes :: AttrMap + _patsIcopy :: Patterns + _patsIdefsCollect :: (Set (Identifier, Identifier)) + _patsIerrors :: (Seq Error) + _patsIoutput :: Patterns + -- use rule "Desugar.ag"(line 189, column 23) + _lhsOallAttributes = + _patsIallAttributes + -- use rule "Desugar.ag"(line 172, column 52) + _lhsOdefsCollect = + _patsIdefsCollect + -- use rule "Desugar.ag"(line 31, column 144) + _lhsOerrors = + _patsIerrors + -- self rule + _copy = + Constr name_ _patsIcopy + -- self rule + _output = + Constr name_ _patsIoutput + -- self rule + _lhsOcopy = + _copy + -- self rule + _lhsOoutput = + _output + -- copy rule (down) + _patsOchildInhs = + _lhsIchildInhs + -- copy rule (down) + _patsOchildSyns = + _lhsIchildSyns + -- copy rule (down) + _patsOcon = + _lhsIcon + -- copy rule (down) + _patsOdefs = + _lhsIdefs + -- copy rule (down) + _patsOforcedIrrefutables = + _lhsIforcedIrrefutables + -- copy rule (down) + _patsOnt = + _lhsInt + ( _patsIallAttributes,_patsIcopy,_patsIdefsCollect,_patsIerrors,_patsIoutput) = + (pats_ _patsOchildInhs _patsOchildSyns _patsOcon _patsOdefs _patsOforcedIrrefutables _patsOnt) + in ( _lhsOallAttributes,_lhsOcopy,_lhsOdefsCollect,_lhsOerrors,_lhsOoutput)))) +sem_Pattern_Irrefutable :: T_Pattern -> + T_Pattern +sem_Pattern_Irrefutable (T_Pattern pat_) = + (T_Pattern (\ _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsIdefs + _lhsIforcedIrrefutables + _lhsInt -> + (let _lhsOallAttributes :: AttrMap + _lhsOdefsCollect :: (Set (Identifier, Identifier)) + _lhsOerrors :: (Seq Error) + _lhsOcopy :: Pattern + _lhsOoutput :: Pattern + _patOchildInhs :: ([(Identifier, Identifier)]) + _patOchildSyns :: ([(Identifier, Identifier)]) + _patOcon :: ConstructorIdent + _patOdefs :: (Set (Identifier, Identifier)) + _patOforcedIrrefutables :: AttrMap + _patOnt :: NontermIdent + _patIallAttributes :: AttrMap + _patIcopy :: Pattern + _patIdefsCollect :: (Set (Identifier, Identifier)) + _patIerrors :: (Seq Error) + _patIoutput :: Pattern + -- "Desugar.ag"(line 195, column 7) + _lhsOallAttributes = + Map.empty + -- use rule "Desugar.ag"(line 172, column 52) + _lhsOdefsCollect = + _patIdefsCollect + -- use rule "Desugar.ag"(line 31, column 144) + _lhsOerrors = + _patIerrors + -- self rule + _copy = + Irrefutable _patIcopy + -- self rule + _output = + Irrefutable _patIoutput + -- self rule + _lhsOcopy = + _copy + -- self rule + _lhsOoutput = + _output + -- copy rule (down) + _patOchildInhs = + _lhsIchildInhs + -- copy rule (down) + _patOchildSyns = + _lhsIchildSyns + -- copy rule (down) + _patOcon = + _lhsIcon + -- copy rule (down) + _patOdefs = + _lhsIdefs + -- copy rule (down) + _patOforcedIrrefutables = + _lhsIforcedIrrefutables + -- copy rule (down) + _patOnt = + _lhsInt + ( _patIallAttributes,_patIcopy,_patIdefsCollect,_patIerrors,_patIoutput) = + (pat_ _patOchildInhs _patOchildSyns _patOcon _patOdefs _patOforcedIrrefutables _patOnt) + in ( _lhsOallAttributes,_lhsOcopy,_lhsOdefsCollect,_lhsOerrors,_lhsOoutput)))) +sem_Pattern_Product :: Pos -> + T_Patterns -> + T_Pattern +sem_Pattern_Product pos_ (T_Patterns pats_) = + (T_Pattern (\ _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsIdefs + _lhsIforcedIrrefutables + _lhsInt -> + (let _lhsOallAttributes :: AttrMap + _lhsOdefsCollect :: (Set (Identifier, Identifier)) + _lhsOerrors :: (Seq Error) + _lhsOcopy :: Pattern + _lhsOoutput :: Pattern + _patsOchildInhs :: ([(Identifier, Identifier)]) + _patsOchildSyns :: ([(Identifier, Identifier)]) + _patsOcon :: ConstructorIdent + _patsOdefs :: (Set (Identifier, Identifier)) + _patsOforcedIrrefutables :: AttrMap + _patsOnt :: NontermIdent + _patsIallAttributes :: AttrMap + _patsIcopy :: Patterns + _patsIdefsCollect :: (Set (Identifier, Identifier)) + _patsIerrors :: (Seq Error) + _patsIoutput :: Patterns + -- use rule "Desugar.ag"(line 189, column 23) + _lhsOallAttributes = + _patsIallAttributes + -- use rule "Desugar.ag"(line 172, column 52) + _lhsOdefsCollect = + _patsIdefsCollect + -- use rule "Desugar.ag"(line 31, column 144) + _lhsOerrors = + _patsIerrors + -- self rule + _copy = + Product pos_ _patsIcopy + -- self rule + _output = + Product pos_ _patsIoutput + -- self rule + _lhsOcopy = + _copy + -- self rule + _lhsOoutput = + _output + -- copy rule (down) + _patsOchildInhs = + _lhsIchildInhs + -- copy rule (down) + _patsOchildSyns = + _lhsIchildSyns + -- copy rule (down) + _patsOcon = + _lhsIcon + -- copy rule (down) + _patsOdefs = + _lhsIdefs + -- copy rule (down) + _patsOforcedIrrefutables = + _lhsIforcedIrrefutables + -- copy rule (down) + _patsOnt = + _lhsInt + ( _patsIallAttributes,_patsIcopy,_patsIdefsCollect,_patsIerrors,_patsIoutput) = + (pats_ _patsOchildInhs _patsOchildSyns _patsOcon _patsOdefs _patsOforcedIrrefutables _patsOnt) + in ( _lhsOallAttributes,_lhsOcopy,_lhsOdefsCollect,_lhsOerrors,_lhsOoutput)))) +sem_Pattern_Underscore :: Pos -> + T_Pattern +sem_Pattern_Underscore pos_ = + (T_Pattern (\ _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsIdefs + _lhsIforcedIrrefutables + _lhsInt -> + (let _lhsOallAttributes :: AttrMap + _lhsOdefsCollect :: (Set (Identifier, Identifier)) + _lhsOerrors :: (Seq Error) + _lhsOcopy :: Pattern + _lhsOoutput :: Pattern + -- use rule "Desugar.ag"(line 189, column 23) + _lhsOallAttributes = + Map.empty + -- use rule "Desugar.ag"(line 172, column 52) + _lhsOdefsCollect = + Set.empty + -- use rule "Desugar.ag"(line 31, column 144) + _lhsOerrors = + Seq.empty + -- self rule + _copy = + Underscore pos_ + -- self rule + _output = + Underscore pos_ + -- self rule + _lhsOcopy = + _copy + -- self rule + _lhsOoutput = + _output + in ( _lhsOallAttributes,_lhsOcopy,_lhsOdefsCollect,_lhsOerrors,_lhsOoutput)))) +-- Patterns ---------------------------------------------------- +{- + visit 0: + inherited attributes: + childInhs : [(Identifier, Identifier)] + childSyns : [(Identifier, Identifier)] + con : ConstructorIdent + defs : Set (Identifier, Identifier) + forcedIrrefutables : AttrMap + nt : NontermIdent + synthesized attributes: + allAttributes : AttrMap + copy : SELF + defsCollect : Set (Identifier, Identifier) + errors : Seq Error + output : SELF + alternatives: + alternative Cons: + child hd : Pattern + child tl : Patterns + visit 0: + local copy : _ + local output : _ + alternative Nil: + visit 0: + local copy : _ + local output : _ +-} +-- cata +sem_Patterns :: Patterns -> + T_Patterns +sem_Patterns list = + (Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list)) +-- semantic domain +newtype T_Patterns = T_Patterns (([(Identifier, Identifier)]) -> + ([(Identifier, Identifier)]) -> + ConstructorIdent -> + (Set (Identifier, Identifier)) -> + AttrMap -> + NontermIdent -> + ( AttrMap,Patterns,(Set (Identifier, Identifier)),(Seq Error),Patterns)) +data Inh_Patterns = Inh_Patterns {childInhs_Inh_Patterns :: [(Identifier, Identifier)],childSyns_Inh_Patterns :: [(Identifier, Identifier)],con_Inh_Patterns :: ConstructorIdent,defs_Inh_Patterns :: Set (Identifier, Identifier),forcedIrrefutables_Inh_Patterns :: AttrMap,nt_Inh_Patterns :: NontermIdent} +data Syn_Patterns = Syn_Patterns {allAttributes_Syn_Patterns :: AttrMap,copy_Syn_Patterns :: Patterns,defsCollect_Syn_Patterns :: Set (Identifier, Identifier),errors_Syn_Patterns :: Seq Error,output_Syn_Patterns :: Patterns} +wrap_Patterns (T_Patterns sem) (Inh_Patterns _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt) = + (let ( _lhsOallAttributes,_lhsOcopy,_lhsOdefsCollect,_lhsOerrors,_lhsOoutput) = + (sem _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt) + in (Syn_Patterns _lhsOallAttributes _lhsOcopy _lhsOdefsCollect _lhsOerrors _lhsOoutput)) +sem_Patterns_Cons :: T_Pattern -> + T_Patterns -> + T_Patterns +sem_Patterns_Cons (T_Pattern hd_) (T_Patterns tl_) = + (T_Patterns (\ _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsIdefs + _lhsIforcedIrrefutables + _lhsInt -> + (let _lhsOallAttributes :: AttrMap + _lhsOdefsCollect :: (Set (Identifier, Identifier)) + _lhsOerrors :: (Seq Error) + _lhsOcopy :: Patterns + _lhsOoutput :: Patterns + _hdOchildInhs :: ([(Identifier, Identifier)]) + _hdOchildSyns :: ([(Identifier, Identifier)]) + _hdOcon :: ConstructorIdent + _hdOdefs :: (Set (Identifier, Identifier)) + _hdOforcedIrrefutables :: AttrMap + _hdOnt :: NontermIdent + _tlOchildInhs :: ([(Identifier, Identifier)]) + _tlOchildSyns :: ([(Identifier, Identifier)]) + _tlOcon :: ConstructorIdent + _tlOdefs :: (Set (Identifier, Identifier)) + _tlOforcedIrrefutables :: AttrMap + _tlOnt :: NontermIdent + _hdIallAttributes :: AttrMap + _hdIcopy :: Pattern + _hdIdefsCollect :: (Set (Identifier, Identifier)) + _hdIerrors :: (Seq Error) + _hdIoutput :: Pattern + _tlIallAttributes :: AttrMap + _tlIcopy :: Patterns + _tlIdefsCollect :: (Set (Identifier, Identifier)) + _tlIerrors :: (Seq Error) + _tlIoutput :: Patterns + -- use rule "Desugar.ag"(line 189, column 23) + _lhsOallAttributes = + _hdIallAttributes `mergeAttributes` _tlIallAttributes + -- use rule "Desugar.ag"(line 172, column 52) + _lhsOdefsCollect = + _hdIdefsCollect `Set.union` _tlIdefsCollect + -- use rule "Desugar.ag"(line 31, column 144) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- self rule + _copy = + (:) _hdIcopy _tlIcopy + -- self rule + _output = + (:) _hdIoutput _tlIoutput + -- self rule + _lhsOcopy = + _copy + -- self rule + _lhsOoutput = + _output + -- copy rule (down) + _hdOchildInhs = + _lhsIchildInhs + -- copy rule (down) + _hdOchildSyns = + _lhsIchildSyns + -- copy rule (down) + _hdOcon = + _lhsIcon + -- copy rule (down) + _hdOdefs = + _lhsIdefs + -- copy rule (down) + _hdOforcedIrrefutables = + _lhsIforcedIrrefutables + -- copy rule (down) + _hdOnt = + _lhsInt + -- copy rule (down) + _tlOchildInhs = + _lhsIchildInhs + -- copy rule (down) + _tlOchildSyns = + _lhsIchildSyns + -- copy rule (down) + _tlOcon = + _lhsIcon + -- copy rule (down) + _tlOdefs = + _lhsIdefs + -- copy rule (down) + _tlOforcedIrrefutables = + _lhsIforcedIrrefutables + -- copy rule (down) + _tlOnt = + _lhsInt + ( _hdIallAttributes,_hdIcopy,_hdIdefsCollect,_hdIerrors,_hdIoutput) = + (hd_ _hdOchildInhs _hdOchildSyns _hdOcon _hdOdefs _hdOforcedIrrefutables _hdOnt) + ( _tlIallAttributes,_tlIcopy,_tlIdefsCollect,_tlIerrors,_tlIoutput) = + (tl_ _tlOchildInhs _tlOchildSyns _tlOcon _tlOdefs _tlOforcedIrrefutables _tlOnt) + in ( _lhsOallAttributes,_lhsOcopy,_lhsOdefsCollect,_lhsOerrors,_lhsOoutput)))) +sem_Patterns_Nil :: T_Patterns +sem_Patterns_Nil = + (T_Patterns (\ _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsIdefs + _lhsIforcedIrrefutables + _lhsInt -> + (let _lhsOallAttributes :: AttrMap + _lhsOdefsCollect :: (Set (Identifier, Identifier)) + _lhsOerrors :: (Seq Error) + _lhsOcopy :: Patterns + _lhsOoutput :: Patterns + -- use rule "Desugar.ag"(line 189, column 23) + _lhsOallAttributes = + Map.empty + -- use rule "Desugar.ag"(line 172, column 52) + _lhsOdefsCollect = + Set.empty + -- use rule "Desugar.ag"(line 31, column 144) + _lhsOerrors = + Seq.empty + -- self rule + _copy = + [] + -- self rule + _output = + [] + -- self rule + _lhsOcopy = + _copy + -- self rule + _lhsOoutput = + _output + in ( _lhsOallAttributes,_lhsOcopy,_lhsOdefsCollect,_lhsOerrors,_lhsOoutput)))) +-- Production -------------------------------------------------- +{- + visit 0: + inherited attributes: + forcedIrrefutables : AttrMap + nt : NontermIdent + options : Options + synthesized attributes: + allAttributes : AttrMap + errors : Seq Error + output : SELF + alternatives: + alternative Production: + child con : {ConstructorIdent} + child children : Children + child rules : Rules + child typeSigs : TypeSigs + visit 0: + local output : _ +-} +-- cata +sem_Production :: Production -> + T_Production +sem_Production (Production _con _children _rules _typeSigs) = + (sem_Production_Production _con (sem_Children _children) (sem_Rules _rules) (sem_TypeSigs _typeSigs)) +-- semantic domain +newtype T_Production = T_Production (AttrMap -> + NontermIdent -> + Options -> + ( AttrMap,(Seq Error),Production)) +data Inh_Production = Inh_Production {forcedIrrefutables_Inh_Production :: AttrMap,nt_Inh_Production :: NontermIdent,options_Inh_Production :: Options} +data Syn_Production = Syn_Production {allAttributes_Syn_Production :: AttrMap,errors_Syn_Production :: Seq Error,output_Syn_Production :: Production} +wrap_Production (T_Production sem) (Inh_Production _lhsIforcedIrrefutables _lhsInt _lhsIoptions) = + (let ( _lhsOallAttributes,_lhsOerrors,_lhsOoutput) = + (sem _lhsIforcedIrrefutables _lhsInt _lhsIoptions) + in (Syn_Production _lhsOallAttributes _lhsOerrors _lhsOoutput)) +sem_Production_Production :: ConstructorIdent -> + T_Children -> + T_Rules -> + T_TypeSigs -> + T_Production +sem_Production_Production con_ (T_Children children_) (T_Rules rules_) (T_TypeSigs typeSigs_) = + (T_Production (\ _lhsIforcedIrrefutables + _lhsInt + _lhsIoptions -> + (let _rulesOcon :: ConstructorIdent + _rulesOdefs :: (Set (Identifier, Identifier)) + _lhsOallAttributes :: AttrMap + _lhsOerrors :: (Seq Error) + _lhsOoutput :: Production + _rulesOchildInhs :: ([(Identifier, Identifier)]) + _rulesOchildSyns :: ([(Identifier, Identifier)]) + _rulesOforcedIrrefutables :: AttrMap + _rulesOnt :: NontermIdent + _rulesOoptions :: Options + _childrenIchildInhs :: ([(Identifier, Identifier)]) + _childrenIchildSyns :: ([(Identifier, Identifier)]) + _childrenIoutput :: Children + _rulesIallAttributes :: AttrMap + _rulesIdefsCollect :: (Set (Identifier, Identifier)) + _rulesIerrors :: (Seq Error) + _rulesIoutput :: Rules + _typeSigsIoutput :: TypeSigs + -- "Desugar.ag"(line 154, column 7) + _rulesOcon = + con_ + -- "Desugar.ag"(line 181, column 7) + _rulesOdefs = + _rulesIdefsCollect + -- use rule "Desugar.ag"(line 189, column 23) + _lhsOallAttributes = + _rulesIallAttributes + -- use rule "Desugar.ag"(line 31, column 144) + _lhsOerrors = + _rulesIerrors + -- self rule + _output = + Production con_ _childrenIoutput _rulesIoutput _typeSigsIoutput + -- self rule + _lhsOoutput = + _output + -- copy rule (chain) + _rulesOchildInhs = + _childrenIchildInhs + -- copy rule (chain) + _rulesOchildSyns = + _childrenIchildSyns + -- copy rule (down) + _rulesOforcedIrrefutables = + _lhsIforcedIrrefutables + -- copy rule (down) + _rulesOnt = + _lhsInt + -- copy rule (down) + _rulesOoptions = + _lhsIoptions + ( _childrenIchildInhs,_childrenIchildSyns,_childrenIoutput) = + (children_ ) + ( _rulesIallAttributes,_rulesIdefsCollect,_rulesIerrors,_rulesIoutput) = + (rules_ _rulesOchildInhs _rulesOchildSyns _rulesOcon _rulesOdefs _rulesOforcedIrrefutables _rulesOnt _rulesOoptions) + ( _typeSigsIoutput) = + (typeSigs_ ) + in ( _lhsOallAttributes,_lhsOerrors,_lhsOoutput)))) +-- Productions ------------------------------------------------- +{- + visit 0: + inherited attributes: + forcedIrrefutables : AttrMap + nt : NontermIdent + options : Options + synthesized attributes: + allAttributes : AttrMap + errors : Seq Error + output : SELF + alternatives: + alternative Cons: + child hd : Production + child tl : Productions + visit 0: + local output : _ + alternative Nil: + visit 0: + local output : _ +-} +-- cata +sem_Productions :: Productions -> + T_Productions +sem_Productions list = + (Prelude.foldr sem_Productions_Cons sem_Productions_Nil (Prelude.map sem_Production list)) +-- semantic domain +newtype T_Productions = T_Productions (AttrMap -> + NontermIdent -> + Options -> + ( AttrMap,(Seq Error),Productions)) +data Inh_Productions = Inh_Productions {forcedIrrefutables_Inh_Productions :: AttrMap,nt_Inh_Productions :: NontermIdent,options_Inh_Productions :: Options} +data Syn_Productions = Syn_Productions {allAttributes_Syn_Productions :: AttrMap,errors_Syn_Productions :: Seq Error,output_Syn_Productions :: Productions} +wrap_Productions (T_Productions sem) (Inh_Productions _lhsIforcedIrrefutables _lhsInt _lhsIoptions) = + (let ( _lhsOallAttributes,_lhsOerrors,_lhsOoutput) = + (sem _lhsIforcedIrrefutables _lhsInt _lhsIoptions) + in (Syn_Productions _lhsOallAttributes _lhsOerrors _lhsOoutput)) +sem_Productions_Cons :: T_Production -> + T_Productions -> + T_Productions +sem_Productions_Cons (T_Production hd_) (T_Productions tl_) = + (T_Productions (\ _lhsIforcedIrrefutables + _lhsInt + _lhsIoptions -> + (let _lhsOallAttributes :: AttrMap + _lhsOerrors :: (Seq Error) + _lhsOoutput :: Productions + _hdOforcedIrrefutables :: AttrMap + _hdOnt :: NontermIdent + _hdOoptions :: Options + _tlOforcedIrrefutables :: AttrMap + _tlOnt :: NontermIdent + _tlOoptions :: Options + _hdIallAttributes :: AttrMap + _hdIerrors :: (Seq Error) + _hdIoutput :: Production + _tlIallAttributes :: AttrMap + _tlIerrors :: (Seq Error) + _tlIoutput :: Productions + -- use rule "Desugar.ag"(line 189, column 23) + _lhsOallAttributes = + _hdIallAttributes `mergeAttributes` _tlIallAttributes + -- use rule "Desugar.ag"(line 31, column 144) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- self rule + _output = + (:) _hdIoutput _tlIoutput + -- self rule + _lhsOoutput = + _output + -- copy rule (down) + _hdOforcedIrrefutables = + _lhsIforcedIrrefutables + -- copy rule (down) + _hdOnt = + _lhsInt + -- copy rule (down) + _hdOoptions = + _lhsIoptions + -- copy rule (down) + _tlOforcedIrrefutables = + _lhsIforcedIrrefutables + -- copy rule (down) + _tlOnt = + _lhsInt + -- copy rule (down) + _tlOoptions = + _lhsIoptions + ( _hdIallAttributes,_hdIerrors,_hdIoutput) = + (hd_ _hdOforcedIrrefutables _hdOnt _hdOoptions) + ( _tlIallAttributes,_tlIerrors,_tlIoutput) = + (tl_ _tlOforcedIrrefutables _tlOnt _tlOoptions) + in ( _lhsOallAttributes,_lhsOerrors,_lhsOoutput)))) +sem_Productions_Nil :: T_Productions +sem_Productions_Nil = + (T_Productions (\ _lhsIforcedIrrefutables + _lhsInt + _lhsIoptions -> + (let _lhsOallAttributes :: AttrMap + _lhsOerrors :: (Seq Error) + _lhsOoutput :: Productions + -- use rule "Desugar.ag"(line 189, column 23) + _lhsOallAttributes = + Map.empty + -- use rule "Desugar.ag"(line 31, column 144) + _lhsOerrors = + Seq.empty + -- self rule + _output = + [] + -- self rule + _lhsOoutput = + _output + in ( _lhsOallAttributes,_lhsOerrors,_lhsOoutput)))) +-- Rule -------------------------------------------------------- +{- + visit 0: + inherited attributes: + childInhs : [(Identifier, Identifier)] + childSyns : [(Identifier, Identifier)] + con : ConstructorIdent + defs : Set (Identifier, Identifier) + forcedIrrefutables : AttrMap + nt : NontermIdent + options : Options + synthesized attributes: + allAttributes : AttrMap + defsCollect : Set (Identifier, Identifier) + errors : Seq Error + output : SELF + alternatives: + alternative Rule: + child pattern : Pattern + child rhs : Expression + child owrt : {Bool} + child origin : {String} + visit 0: + local ruleDescr : _ + local output : _ +-} +-- cata +sem_Rule :: Rule -> + T_Rule +sem_Rule (Rule _pattern _rhs _owrt _origin) = + (sem_Rule_Rule (sem_Pattern _pattern) (sem_Expression _rhs) _owrt _origin) +-- semantic domain +newtype T_Rule = T_Rule (([(Identifier, Identifier)]) -> + ([(Identifier, Identifier)]) -> + ConstructorIdent -> + (Set (Identifier, Identifier)) -> + AttrMap -> + NontermIdent -> + Options -> + ( AttrMap,(Set (Identifier, Identifier)),(Seq Error),Rule)) +data Inh_Rule = Inh_Rule {childInhs_Inh_Rule :: [(Identifier, Identifier)],childSyns_Inh_Rule :: [(Identifier, Identifier)],con_Inh_Rule :: ConstructorIdent,defs_Inh_Rule :: Set (Identifier, Identifier),forcedIrrefutables_Inh_Rule :: AttrMap,nt_Inh_Rule :: NontermIdent,options_Inh_Rule :: Options} +data Syn_Rule = Syn_Rule {allAttributes_Syn_Rule :: AttrMap,defsCollect_Syn_Rule :: Set (Identifier, Identifier),errors_Syn_Rule :: Seq Error,output_Syn_Rule :: Rule} +wrap_Rule (T_Rule sem) (Inh_Rule _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt _lhsIoptions) = + (let ( _lhsOallAttributes,_lhsOdefsCollect,_lhsOerrors,_lhsOoutput) = + (sem _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt _lhsIoptions) + in (Syn_Rule _lhsOallAttributes _lhsOdefsCollect _lhsOerrors _lhsOoutput)) +sem_Rule_Rule :: T_Pattern -> + T_Expression -> + Bool -> + String -> + T_Rule +sem_Rule_Rule (T_Pattern pattern_) (T_Expression rhs_) owrt_ origin_ = + (T_Rule (\ _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsIdefs + _lhsIforcedIrrefutables + _lhsInt + _lhsIoptions -> + (let _lhsOallAttributes :: AttrMap + _lhsOdefsCollect :: (Set (Identifier, Identifier)) + _lhsOerrors :: (Seq Error) + _lhsOoutput :: Rule + _patternOchildInhs :: ([(Identifier, Identifier)]) + _patternOchildSyns :: ([(Identifier, Identifier)]) + _patternOcon :: ConstructorIdent + _patternOdefs :: (Set (Identifier, Identifier)) + _patternOforcedIrrefutables :: AttrMap + _patternOnt :: NontermIdent + _rhsOchildInhs :: ([(Identifier, Identifier)]) + _rhsOchildSyns :: ([(Identifier, Identifier)]) + _rhsOcon :: ConstructorIdent + _rhsOnt :: NontermIdent + _rhsOoptions :: Options + _rhsOruleDescr :: String + _patternIallAttributes :: AttrMap + _patternIcopy :: Pattern + _patternIdefsCollect :: (Set (Identifier, Identifier)) + _patternIerrors :: (Seq Error) + _patternIoutput :: Pattern + _rhsIerrors :: (Seq Error) + _rhsIoutput :: Expression + -- "Desugar.ag"(line 165, column 7) + _ruleDescr = + show _lhsInt ++ " :: " ++ show _lhsIcon ++ " :: " ++ (concat $ intersperse "," $ map (\(f,a) -> show f ++ "." ++ show a) $ Set.toList _patternIdefsCollect) + -- use rule "Desugar.ag"(line 189, column 23) + _lhsOallAttributes = + _patternIallAttributes + -- use rule "Desugar.ag"(line 172, column 52) + _lhsOdefsCollect = + _patternIdefsCollect + -- use rule "Desugar.ag"(line 31, column 144) + _lhsOerrors = + _patternIerrors Seq.<> _rhsIerrors + -- self rule + _output = + Rule _patternIoutput _rhsIoutput owrt_ origin_ + -- self rule + _lhsOoutput = + _output + -- copy rule (down) + _patternOchildInhs = + _lhsIchildInhs + -- copy rule (down) + _patternOchildSyns = + _lhsIchildSyns + -- copy rule (down) + _patternOcon = + _lhsIcon + -- copy rule (down) + _patternOdefs = + _lhsIdefs + -- copy rule (down) + _patternOforcedIrrefutables = + _lhsIforcedIrrefutables + -- copy rule (down) + _patternOnt = + _lhsInt + -- copy rule (down) + _rhsOchildInhs = + _lhsIchildInhs + -- copy rule (down) + _rhsOchildSyns = + _lhsIchildSyns + -- copy rule (down) + _rhsOcon = + _lhsIcon + -- copy rule (down) + _rhsOnt = + _lhsInt + -- copy rule (down) + _rhsOoptions = + _lhsIoptions + -- copy rule (from local) + _rhsOruleDescr = + _ruleDescr + ( _patternIallAttributes,_patternIcopy,_patternIdefsCollect,_patternIerrors,_patternIoutput) = + (pattern_ _patternOchildInhs _patternOchildSyns _patternOcon _patternOdefs _patternOforcedIrrefutables _patternOnt) + ( _rhsIerrors,_rhsIoutput) = + (rhs_ _rhsOchildInhs _rhsOchildSyns _rhsOcon _rhsOnt _rhsOoptions _rhsOruleDescr) + in ( _lhsOallAttributes,_lhsOdefsCollect,_lhsOerrors,_lhsOoutput)))) +-- Rules ------------------------------------------------------- +{- + visit 0: + inherited attributes: + childInhs : [(Identifier, Identifier)] + childSyns : [(Identifier, Identifier)] + con : ConstructorIdent + defs : Set (Identifier, Identifier) + forcedIrrefutables : AttrMap + nt : NontermIdent + options : Options + synthesized attributes: + allAttributes : AttrMap + defsCollect : Set (Identifier, Identifier) + errors : Seq Error + output : SELF + alternatives: + alternative Cons: + child hd : Rule + child tl : Rules + visit 0: + local output : _ + alternative Nil: + visit 0: + local output : _ +-} +-- cata +sem_Rules :: Rules -> + T_Rules +sem_Rules list = + (Prelude.foldr sem_Rules_Cons sem_Rules_Nil (Prelude.map sem_Rule list)) +-- semantic domain +newtype T_Rules = T_Rules (([(Identifier, Identifier)]) -> + ([(Identifier, Identifier)]) -> + ConstructorIdent -> + (Set (Identifier, Identifier)) -> + AttrMap -> + NontermIdent -> + Options -> + ( AttrMap,(Set (Identifier, Identifier)),(Seq Error),Rules)) +data Inh_Rules = Inh_Rules {childInhs_Inh_Rules :: [(Identifier, Identifier)],childSyns_Inh_Rules :: [(Identifier, Identifier)],con_Inh_Rules :: ConstructorIdent,defs_Inh_Rules :: Set (Identifier, Identifier),forcedIrrefutables_Inh_Rules :: AttrMap,nt_Inh_Rules :: NontermIdent,options_Inh_Rules :: Options} +data Syn_Rules = Syn_Rules {allAttributes_Syn_Rules :: AttrMap,defsCollect_Syn_Rules :: Set (Identifier, Identifier),errors_Syn_Rules :: Seq Error,output_Syn_Rules :: Rules} +wrap_Rules (T_Rules sem) (Inh_Rules _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt _lhsIoptions) = + (let ( _lhsOallAttributes,_lhsOdefsCollect,_lhsOerrors,_lhsOoutput) = + (sem _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt _lhsIoptions) + in (Syn_Rules _lhsOallAttributes _lhsOdefsCollect _lhsOerrors _lhsOoutput)) +sem_Rules_Cons :: T_Rule -> + T_Rules -> + T_Rules +sem_Rules_Cons (T_Rule hd_) (T_Rules tl_) = + (T_Rules (\ _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsIdefs + _lhsIforcedIrrefutables + _lhsInt + _lhsIoptions -> + (let _lhsOallAttributes :: AttrMap + _lhsOdefsCollect :: (Set (Identifier, Identifier)) + _lhsOerrors :: (Seq Error) + _lhsOoutput :: Rules + _hdOchildInhs :: ([(Identifier, Identifier)]) + _hdOchildSyns :: ([(Identifier, Identifier)]) + _hdOcon :: ConstructorIdent + _hdOdefs :: (Set (Identifier, Identifier)) + _hdOforcedIrrefutables :: AttrMap + _hdOnt :: NontermIdent + _hdOoptions :: Options + _tlOchildInhs :: ([(Identifier, Identifier)]) + _tlOchildSyns :: ([(Identifier, Identifier)]) + _tlOcon :: ConstructorIdent + _tlOdefs :: (Set (Identifier, Identifier)) + _tlOforcedIrrefutables :: AttrMap + _tlOnt :: NontermIdent + _tlOoptions :: Options + _hdIallAttributes :: AttrMap + _hdIdefsCollect :: (Set (Identifier, Identifier)) + _hdIerrors :: (Seq Error) + _hdIoutput :: Rule + _tlIallAttributes :: AttrMap + _tlIdefsCollect :: (Set (Identifier, Identifier)) + _tlIerrors :: (Seq Error) + _tlIoutput :: Rules + -- use rule "Desugar.ag"(line 189, column 23) + _lhsOallAttributes = + _hdIallAttributes `mergeAttributes` _tlIallAttributes + -- use rule "Desugar.ag"(line 172, column 52) + _lhsOdefsCollect = + _hdIdefsCollect `Set.union` _tlIdefsCollect + -- use rule "Desugar.ag"(line 31, column 144) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- self rule + _output = + (:) _hdIoutput _tlIoutput + -- self rule + _lhsOoutput = + _output + -- copy rule (down) + _hdOchildInhs = + _lhsIchildInhs + -- copy rule (down) + _hdOchildSyns = + _lhsIchildSyns + -- copy rule (down) + _hdOcon = + _lhsIcon + -- copy rule (down) + _hdOdefs = + _lhsIdefs + -- copy rule (down) + _hdOforcedIrrefutables = + _lhsIforcedIrrefutables + -- copy rule (down) + _hdOnt = + _lhsInt + -- copy rule (down) + _hdOoptions = + _lhsIoptions + -- copy rule (down) + _tlOchildInhs = + _lhsIchildInhs + -- copy rule (down) + _tlOchildSyns = + _lhsIchildSyns + -- copy rule (down) + _tlOcon = + _lhsIcon + -- copy rule (down) + _tlOdefs = + _lhsIdefs + -- copy rule (down) + _tlOforcedIrrefutables = + _lhsIforcedIrrefutables + -- copy rule (down) + _tlOnt = + _lhsInt + -- copy rule (down) + _tlOoptions = + _lhsIoptions + ( _hdIallAttributes,_hdIdefsCollect,_hdIerrors,_hdIoutput) = + (hd_ _hdOchildInhs _hdOchildSyns _hdOcon _hdOdefs _hdOforcedIrrefutables _hdOnt _hdOoptions) + ( _tlIallAttributes,_tlIdefsCollect,_tlIerrors,_tlIoutput) = + (tl_ _tlOchildInhs _tlOchildSyns _tlOcon _tlOdefs _tlOforcedIrrefutables _tlOnt _tlOoptions) + in ( _lhsOallAttributes,_lhsOdefsCollect,_lhsOerrors,_lhsOoutput)))) +sem_Rules_Nil :: T_Rules +sem_Rules_Nil = + (T_Rules (\ _lhsIchildInhs + _lhsIchildSyns + _lhsIcon + _lhsIdefs + _lhsIforcedIrrefutables + _lhsInt + _lhsIoptions -> + (let _lhsOallAttributes :: AttrMap + _lhsOdefsCollect :: (Set (Identifier, Identifier)) + _lhsOerrors :: (Seq Error) + _lhsOoutput :: Rules + -- use rule "Desugar.ag"(line 189, column 23) + _lhsOallAttributes = + Map.empty + -- use rule "Desugar.ag"(line 172, column 52) + _lhsOdefsCollect = + Set.empty + -- use rule "Desugar.ag"(line 31, column 144) + _lhsOerrors = + Seq.empty + -- self rule + _output = + [] + -- self rule + _lhsOoutput = + _output + in ( _lhsOallAttributes,_lhsOdefsCollect,_lhsOerrors,_lhsOoutput)))) +-- TypeSig ----------------------------------------------------- +{- + visit 0: + synthesized attribute: + output : SELF + alternatives: + alternative TypeSig: + child name : {Identifier} + child tp : {Type} + visit 0: + local output : _ +-} +-- cata +sem_TypeSig :: TypeSig -> + T_TypeSig +sem_TypeSig (TypeSig _name _tp) = + (sem_TypeSig_TypeSig _name _tp) +-- semantic domain +newtype T_TypeSig = T_TypeSig (( TypeSig)) +data Inh_TypeSig = Inh_TypeSig {} +data Syn_TypeSig = Syn_TypeSig {output_Syn_TypeSig :: TypeSig} +wrap_TypeSig (T_TypeSig sem) (Inh_TypeSig ) = + (let ( _lhsOoutput) = + (sem ) + in (Syn_TypeSig _lhsOoutput)) +sem_TypeSig_TypeSig :: Identifier -> + Type -> + T_TypeSig +sem_TypeSig_TypeSig name_ tp_ = + (T_TypeSig (let _lhsOoutput :: TypeSig + -- self rule + _output = + TypeSig name_ tp_ + -- self rule + _lhsOoutput = + _output + in ( _lhsOoutput))) +-- TypeSigs ---------------------------------------------------- +{- + visit 0: + synthesized attribute: + output : SELF + alternatives: + alternative Cons: + child hd : TypeSig + child tl : TypeSigs + visit 0: + local output : _ + alternative Nil: + visit 0: + local output : _ +-} +-- cata +sem_TypeSigs :: TypeSigs -> + T_TypeSigs +sem_TypeSigs list = + (Prelude.foldr sem_TypeSigs_Cons sem_TypeSigs_Nil (Prelude.map sem_TypeSig list)) +-- semantic domain +newtype T_TypeSigs = T_TypeSigs (( TypeSigs)) +data Inh_TypeSigs = Inh_TypeSigs {} +data Syn_TypeSigs = Syn_TypeSigs {output_Syn_TypeSigs :: TypeSigs} +wrap_TypeSigs (T_TypeSigs sem) (Inh_TypeSigs ) = + (let ( _lhsOoutput) = + (sem ) + in (Syn_TypeSigs _lhsOoutput)) +sem_TypeSigs_Cons :: T_TypeSig -> + T_TypeSigs -> + T_TypeSigs +sem_TypeSigs_Cons (T_TypeSig hd_) (T_TypeSigs tl_) = + (T_TypeSigs (let _lhsOoutput :: TypeSigs + _hdIoutput :: TypeSig + _tlIoutput :: TypeSigs + -- self rule + _output = + (:) _hdIoutput _tlIoutput + -- self rule + _lhsOoutput = + _output + ( _hdIoutput) = + (hd_ ) + ( _tlIoutput) = + (tl_ ) + in ( _lhsOoutput))) +sem_TypeSigs_Nil :: T_TypeSigs +sem_TypeSigs_Nil = + (T_TypeSigs (let _lhsOoutput :: TypeSigs + -- self rule + _output = + [] + -- self rule + _lhsOoutput = + _output + in ( _lhsOoutput))) diff --git a/src-derived/ErrorMessages.hs b/src-derived/ErrorMessages.hs --- a/src-derived/ErrorMessages.hs +++ b/src-derived/ErrorMessages.hs @@ -1,4 +1,3 @@ - -- UUAGC 0.9.5 (ErrorMessages.ag) module ErrorMessages where @@ -11,139 +10,135 @@ {- alternatives: alternative ChildAsLocal: - child nt : {Nonterminal} - child con : {Constructor} - child var : {Name} + child nt : {NontermIdent} + child con : {ConstructorIdent} + child var : {Identifier} alternative CustomError: child isWarning : {Bool} child pos : {Pos} child mesg : {PP_Doc} alternative CyclicSet: - child name : {Name} + child name : {Identifier} alternative DirectCirc: - child nt : {Nonterminal} + child nt : {NontermIdent} child o_visit : {Bool} - child cyclic : {[((Name,Name),[String],[String])]} + child cyclic : {[((Identifier,Identifier),[String],[String])]} alternative DupAlt: - child nt : {Nonterminal} - child con : {Constructor} - child occ1 : {Constructor} + child nt : {NontermIdent} + child con : {ConstructorIdent} + child occ1 : {ConstructorIdent} alternative DupChild: - child nt : {Nonterminal} - child con : {Constructor} - child name : {Name} - child occ1 : {Name} + child nt : {NontermIdent} + child con : {ConstructorIdent} + child name : {Identifier} + child occ1 : {Identifier} alternative DupInhAttr: - child nt : {Nonterminal} - child attr : {Name} - child occ1 : {Name} + child nt : {NontermIdent} + child attr : {Identifier} + child occ1 : {Identifier} alternative DupRule: - child nt : {Nonterminal} - child con : {Constructor} - child field : {Name} - child attr : {Name} - child occ1 : {Name} + child nt : {NontermIdent} + child con : {ConstructorIdent} + child field : {Identifier} + child attr : {Identifier} + child occ1 : {Identifier} alternative DupSet: - child name : {Nonterminal} - child occ1 : {Nonterminal} + child name : {NontermIdent} + child occ1 : {NontermIdent} alternative DupSig: - child nt : {Nonterminal} - child con : {Constructor} - child attr : {Name} + child nt : {NontermIdent} + child con : {ConstructorIdent} + child attr : {Identifier} alternative DupSynAttr: - child nt : {Nonterminal} - child attr : {Name} - child occ1 : {Name} + child nt : {NontermIdent} + child attr : {Identifier} + child occ1 : {Identifier} alternative DupSynonym: - child nt : {Nonterminal} - child occ1 : {Nonterminal} - alternative ErroneousOrder: - child nt : {Nonterminal} - child con : {Constructor} - child order : {Dependency} + child nt : {NontermIdent} + child occ1 : {NontermIdent} alternative InducedCirc: - child nt : {Nonterminal} + child nt : {NontermIdent} child cinter : {CInterface} - child cyclic : {[((Name,Name),[String],[String])]} + child cyclic : {[((Identifier,Identifier),[String],[String])]} alternative InstCirc: - child nt : {Nonterminal} - child con : {Constructor} - child attr : {Name} + child nt : {NontermIdent} + child con : {ConstructorIdent} + child attr : {Identifier} child o_visit : {Bool} child path : {[String]} alternative LocalCirc: - child nt : {Nonterminal} - child con : {Constructor} - child attr : {Name} + child nt : {NontermIdent} + child con : {ConstructorIdent} + child attr : {Identifier} child o_visit : {Bool} child path : {[String]} alternative MissingInstSig: - child nt : {Nonterminal} - child con : {Constructor} - child attr : {Name} + child nt : {NontermIdent} + child con : {ConstructorIdent} + child attr : {Identifier} alternative MissingRule: - child nt : {Nonterminal} - child con : {Constructor} - child field : {Name} - child attr : {Name} + child nt : {NontermIdent} + child con : {ConstructorIdent} + child field : {Identifier} + child attr : {Identifier} alternative MissingTypeSig: - child nt : {Nonterminal} - child con : {Constructor} - child attr : {Name} + child nt : {NontermIdent} + child con : {ConstructorIdent} + child attr : {Identifier} alternative ParserError: child pos : {Pos} child problem : {String} child action : {String} alternative SuperfluousRule: - child nt : {Nonterminal} - child con : {Constructor} - child field : {Name} - child attr : {Name} + child nt : {NontermIdent} + child con : {ConstructorIdent} + child field : {Identifier} + child attr : {Identifier} alternative UndefAlt: - child nt : {Nonterminal} - child con : {Constructor} + child nt : {NontermIdent} + child con : {ConstructorIdent} alternative UndefAttr: - child nt : {Nonterminal} - child con : {Constructor} - child field : {Name} - child attr : {Name} + child nt : {NontermIdent} + child con : {ConstructorIdent} + child field : {Identifier} + child attr : {Identifier} + child isOut : {Bool} alternative UndefChild: - child nt : {Nonterminal} - child con : {Constructor} - child name : {Name} + child nt : {NontermIdent} + child con : {ConstructorIdent} + child name : {Identifier} alternative UndefLocal: - child nt : {Nonterminal} - child con : {Constructor} - child var : {Name} + child nt : {NontermIdent} + child con : {ConstructorIdent} + child var : {Identifier} alternative UndefNont: - child nt : {Nonterminal} + child nt : {NontermIdent} -} -data Error = ChildAsLocal (Nonterminal) (Constructor) (Name) - | CustomError (Bool) (Pos) (PP_Doc) - | CyclicSet (Name) - | DirectCirc (Nonterminal) (Bool) ([((Name,Name),[String],[String])]) - | DupAlt (Nonterminal) (Constructor) (Constructor) - | DupChild (Nonterminal) (Constructor) (Name) (Name) - | DupInhAttr (Nonterminal) (Name) (Name) - | DupRule (Nonterminal) (Constructor) (Name) (Name) (Name) - | DupSet (Nonterminal) (Nonterminal) - | DupSig (Nonterminal) (Constructor) (Name) - | DupSynAttr (Nonterminal) (Name) (Name) - | DupSynonym (Nonterminal) (Nonterminal) - | ErroneousOrder (Nonterminal) (Constructor) (Dependency) - | InducedCirc (Nonterminal) (CInterface) ([((Name,Name),[String],[String])]) - | InstCirc (Nonterminal) (Constructor) (Name) (Bool) ([String]) - | LocalCirc (Nonterminal) (Constructor) (Name) (Bool) ([String]) - | MissingInstSig (Nonterminal) (Constructor) (Name) - | MissingRule (Nonterminal) (Constructor) (Name) (Name) - | MissingTypeSig (Nonterminal) (Constructor) (Name) - | ParserError (Pos) (String) (String) - | SuperfluousRule (Nonterminal) (Constructor) (Name) (Name) - | UndefAlt (Nonterminal) (Constructor) - | UndefAttr (Nonterminal) (Constructor) (Name) (Name) - | UndefChild (Nonterminal) (Constructor) (Name) - | UndefLocal (Nonterminal) (Constructor) (Name) - | UndefNont (Nonterminal) +data Error = ChildAsLocal (NontermIdent) (ConstructorIdent) (Identifier) + | CustomError (Bool) (Pos) (PP_Doc) + | CyclicSet (Identifier) + | DirectCirc (NontermIdent) (Bool) ([((Identifier,Identifier),[String],[String])]) + | DupAlt (NontermIdent) (ConstructorIdent) (ConstructorIdent) + | DupChild (NontermIdent) (ConstructorIdent) (Identifier) (Identifier) + | DupInhAttr (NontermIdent) (Identifier) (Identifier) + | DupRule (NontermIdent) (ConstructorIdent) (Identifier) (Identifier) (Identifier) + | DupSet (NontermIdent) (NontermIdent) + | DupSig (NontermIdent) (ConstructorIdent) (Identifier) + | DupSynAttr (NontermIdent) (Identifier) (Identifier) + | DupSynonym (NontermIdent) (NontermIdent) + | InducedCirc (NontermIdent) (CInterface) ([((Identifier,Identifier),[String],[String])]) + | InstCirc (NontermIdent) (ConstructorIdent) (Identifier) (Bool) ([String]) + | LocalCirc (NontermIdent) (ConstructorIdent) (Identifier) (Bool) ([String]) + | MissingInstSig (NontermIdent) (ConstructorIdent) (Identifier) + | MissingRule (NontermIdent) (ConstructorIdent) (Identifier) (Identifier) + | MissingTypeSig (NontermIdent) (ConstructorIdent) (Identifier) + | ParserError (Pos) (String) (String) + | SuperfluousRule (NontermIdent) (ConstructorIdent) (Identifier) (Identifier) + | UndefAlt (NontermIdent) (ConstructorIdent) + | UndefAttr (NontermIdent) (ConstructorIdent) (Identifier) (Identifier) (Bool) + | UndefChild (NontermIdent) (ConstructorIdent) (Identifier) + | UndefLocal (NontermIdent) (ConstructorIdent) (Identifier) + | UndefNont (NontermIdent) -- Errors ------------------------------------------------------ {- alternatives: diff --git a/src-derived/Expression.hs b/src-derived/Expression.hs --- a/src-derived/Expression.hs +++ b/src-derived/Expression.hs @@ -3,11 +3,12 @@ module Expression where import UU.Scanner.Position(Pos) +import HsToken -- Expression -------------------------------------------------- {- alternatives: alternative Expression: child pos : {Pos} - child txt : {String} + child tks : {[HsToken]} -} -data Expression = Expression (Pos) (String) +data Expression = Expression (Pos) ([HsToken]) diff --git a/src-derived/GenerateCode.hs b/src-derived/GenerateCode.hs --- a/src-derived/GenerateCode.hs +++ b/src-derived/GenerateCode.hs @@ -1,4544 +1,5024 @@ - --- UUAGC 0.9.5 (GenerateCode.ag) -module GenerateCode where - -import SequentialTypes -import Code hiding (Type) -import qualified Code -import Options -import CodeSyntax -import ErrorMessages -import GrammarInfo -import DeclBlocks - -import qualified Data.Map as Map -import Data.Map(Map) -import qualified Data.Set as Set -import Data.Set(Set) -import qualified UU.DData.Seq as Seq -import UU.DData.Seq(Seq) -import UU.Scanner.Position - -import Data.List(partition,intersperse,intersect,(\\)) -import Maybe(fromJust,isJust) - -import Patterns -import CommonTypes -import Data.Map(Map) -import Data.Set(Set) - --- Patterns.ag imports -import UU.Scanner.Position(Pos) -import CommonTypes (Constructor,Name) - -import Code (Decl,Expr) - -substSelf nt tp = if tp==NT _SELF - then Haskell (getName nt) - else tp - -mkLambda [] e = e -mkLambda xs e = Lambda xs e - --- dead code - replaced by mkPartitionedFunction -{- -localCpsToExpr :: Bool -> [Decl] -> DeclBlocks -> Expr -localCpsToExpr o_case nextVisitDecl - = rec - where - rec cps - = case cps of - DeclTerminator decls expr - -> mkLet o_case (decls ++ nextVisitDecl) expr - DeclBlock decls (Decl lhs rhs _ _) remainder - -> let inDecls = [ PragmaDecl ("NOINLINE " ++ internalCpsName) - , Decl (Fun internalCpsName [SimpleExpr internalCpsVarName]) - (mkLet o_case [Decl lhs (SimpleExpr internalCpsVarName) Set.empty Set.empty] (rec remainder)) - Set.empty Set.empty - ] - inBody = App "head" [App "(:)" [App internalCpsName [rhs], App "(:)" [App internalCpsName [rhs], SimpleExpr "[]"]]] - outerBody = Let inDecls inBody - block = mkLet o_case decls outerBody - in block - -internalCpsName :: String -internalCpsName = "internalCps_" - -internalCpsVarName :: String -internalCpsVarName = "internalCps_var_" --} - -mkPartitionedFunction :: String -> Bool -> [Decl] -> [String] -> DeclBlocks -> ([Decl], Expr) -mkPartitionedFunction prefix optCase nextVisitDecls lastExprVars cpsTree - = let inh = Inh_DeclBlocksRoot { prefix_Inh_DeclBlocksRoot = prefix - , optCase_Inh_DeclBlocksRoot = optCase - , nextVisitDecls_Inh_DeclBlocksRoot = nextVisitDecls - , lastExprVars_Inh_DeclBlocksRoot = lastExprVars - } - sem = sem_DeclBlocksRoot (DeclBlocksRoot cpsTree) - syn = wrap_DeclBlocksRoot sem inh - in (lambdas_Syn_DeclBlocksRoot syn, firstCall_Syn_DeclBlocksRoot syn) - -freevars :: [String] -> [Decl] -> [String] -freevars additional decls - = Set.toList (allused `Set.difference` alldefined) - where - allused = Set.unions (Set.fromList additional : map usedvars decls) - alldefined = Set.unions (map definedvars decls) - - usedvars (Decl _ _ _ uses) = uses - usedvars _ = Set.empty - - definedvars (Decl _ _ defs _) = defs - definedvars _ = Set.empty - -mkBlockLambda :: Bool -> String -> [String] -> [Decl] -> Expr -> Decl -mkBlockLambda optCase name args decls expr - = Decl lhs rhs Set.empty Set.empty - where - lhs = Fun name (map SimpleExpr args) - rhs = mkLet optCase decls expr - -makeLocalComment :: Int -> String -> Name -> Maybe Type -> String -makeLocalComment width what name tp = let x = getName name - y = maybe "_" (\t -> case t of (NT nt) -> getName nt; Haskell t -> '{':t++"}") tp - in ( what ++ " " ++ x ++ replicate ((width - length x) `max` 0) ' ' ++ " : " ++ y ) - - --- Lets or nested Cases? -mkLet :: Bool -> Decls -> Expr -> Expr -mkLet False decls body = Let decls body -mkLet True decls body = foldr oneCase body decls - -oneCase :: Decl -> Expr -> Expr -oneCase (Decl left rhs _ _) exp = Case rhs [CaseAlt left exp] -oneCase _ exp = exp - --- Gives the name of the visit function -funname field 0 = show field ++ "_" -funname field nr = show field ++ "_" ++ show nr - --- Gives the name of a semantic function -seqSemname :: String -> Nonterminal -> Constructor -> Int -> String -seqSemname pre nt con 0 = semname pre nt con -seqSemname pre nt con nr = semname pre nt con ++ "_" ++ show nr - --- Gives the name of a type -typeName :: Nonterminal -> Int -> String -typeName nt 0 = "T_" ++ show nt -typeName nt n = "T_" ++ show nt ++ "_" ++ show n - --- Gives the name of a visit function -visitname :: String -> Nonterminal -> Int -> String -visitname pre nt n = pre ++ getName nt ++ "_" ++ show n --- CAlternative ------------------------------------------------ -{- - visit 0: - inherited attributes: - allPragmas : PragmaMap - inh : Attributes - nt : Nonterminal - o_case : Bool - o_cata : Bool - o_costcentre : Bool - o_data : Maybe Bool - o_linePragmas : Bool - o_newtypes : Bool - o_pretty : Bool - o_rename : Bool - o_sem : Bool - o_sig : Bool - o_splitsems : Bool - o_strictwrap : Bool - o_traces : Bool - o_unbox : Bool - prefix : String - syn : Attributes - with_sig : Bool - chained attribute: - errors : Seq Error - synthesized attributes: - allTpsFound : Bool - cataAlt : Decl - comments : [String] - dataAlt : DataAlt - decls : Decls - semNames : [String] - alternatives: - alternative CAlternative: - child con : {Constructor} - child visits : CVisits - child children : {[(Name,Type,Bool)]} - child terminals : {[Name]} - visit 0: - local firstOrderChildren : _ --} --- cata -sem_CAlternative :: CAlternative -> - T_CAlternative -sem_CAlternative (CAlternative _con _visits _children _terminals ) = - (sem_CAlternative_CAlternative _con (sem_CVisits _visits ) _children _terminals ) --- semantic domain -newtype T_CAlternative = T_CAlternative (PragmaMap -> - (Seq Error) -> - Attributes -> - Nonterminal -> - Bool -> - Bool -> - Bool -> - (Maybe Bool) -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - String -> - Attributes -> - Bool -> - ( Bool,Decl,([String]),DataAlt,Decls,(Seq Error),([String]))) -data Inh_CAlternative = Inh_CAlternative {allPragmas_Inh_CAlternative :: PragmaMap,errors_Inh_CAlternative :: Seq Error,inh_Inh_CAlternative :: Attributes,nt_Inh_CAlternative :: Nonterminal,o_case_Inh_CAlternative :: Bool,o_cata_Inh_CAlternative :: Bool,o_costcentre_Inh_CAlternative :: Bool,o_data_Inh_CAlternative :: Maybe Bool,o_linePragmas_Inh_CAlternative :: Bool,o_newtypes_Inh_CAlternative :: Bool,o_pretty_Inh_CAlternative :: Bool,o_rename_Inh_CAlternative :: Bool,o_sem_Inh_CAlternative :: Bool,o_sig_Inh_CAlternative :: Bool,o_splitsems_Inh_CAlternative :: Bool,o_strictwrap_Inh_CAlternative :: Bool,o_traces_Inh_CAlternative :: Bool,o_unbox_Inh_CAlternative :: Bool,prefix_Inh_CAlternative :: String,syn_Inh_CAlternative :: Attributes,with_sig_Inh_CAlternative :: Bool} -data Syn_CAlternative = Syn_CAlternative {allTpsFound_Syn_CAlternative :: Bool,cataAlt_Syn_CAlternative :: Decl,comments_Syn_CAlternative :: [String],dataAlt_Syn_CAlternative :: DataAlt,decls_Syn_CAlternative :: Decls,errors_Syn_CAlternative :: Seq Error,semNames_Syn_CAlternative :: [String]} -wrap_CAlternative (T_CAlternative sem ) (Inh_CAlternative _lhsIallPragmas _lhsIerrors _lhsIinh _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn _lhsIwith_sig ) = - (let ( _lhsOallTpsFound,_lhsOcataAlt,_lhsOcomments,_lhsOdataAlt,_lhsOdecls,_lhsOerrors,_lhsOsemNames) = - (sem _lhsIallPragmas _lhsIerrors _lhsIinh _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn _lhsIwith_sig ) - in (Syn_CAlternative _lhsOallTpsFound _lhsOcataAlt _lhsOcomments _lhsOdataAlt _lhsOdecls _lhsOerrors _lhsOsemNames )) -sem_CAlternative_CAlternative :: Constructor -> - T_CVisits -> - ([(Name,Type,Bool)]) -> - ([Name]) -> - T_CAlternative -sem_CAlternative_CAlternative con_ (T_CVisits visits_ ) children_ terminals_ = - (T_CAlternative (\ _lhsIallPragmas - _lhsIerrors - _lhsIinh - _lhsInt - _lhsIo_case - _lhsIo_cata - _lhsIo_costcentre - _lhsIo_data - _lhsIo_linePragmas - _lhsIo_newtypes - _lhsIo_pretty - _lhsIo_rename - _lhsIo_sem - _lhsIo_sig - _lhsIo_splitsems - _lhsIo_strictwrap - _lhsIo_traces - _lhsIo_unbox - _lhsIprefix - _lhsIsyn - _lhsIwith_sig -> - (let _visitsOcon :: Constructor - _visitsOterminals :: ([Name]) - _visitsOnr :: Int - _visitsOchildren :: ([(Name,Type,Bool)]) - _visitsOinstVisitNrs :: (Map Identifier Int) - _lhsOcomments :: ([String]) - _lhsOdataAlt :: DataAlt - _lhsOcataAlt :: Decl - _lhsOallTpsFound :: Bool - _lhsOdecls :: Decls - _lhsOerrors :: (Seq Error) - _lhsOsemNames :: ([String]) - _visitsOallPragmas :: PragmaMap - _visitsOerrors :: (Seq Error) - _visitsOinh :: Attributes - _visitsOnt :: Nonterminal - _visitsOo_case :: Bool - _visitsOo_cata :: Bool - _visitsOo_costcentre :: Bool - _visitsOo_data :: (Maybe Bool) - _visitsOo_linePragmas :: Bool - _visitsOo_newtypes :: Bool - _visitsOo_pretty :: Bool - _visitsOo_rename :: Bool - _visitsOo_sem :: Bool - _visitsOo_sig :: Bool - _visitsOo_splitsems :: Bool - _visitsOo_strictwrap :: Bool - _visitsOo_traces :: Bool - _visitsOo_unbox :: Bool - _visitsOprefix :: String - _visitsOsyn :: Attributes - _visitsOwith_sig :: Bool - _visitsIallTpsFound :: Bool - _visitsIcomments :: ([String]) - _visitsIdecls :: Decls - _visitsIerrors :: (Seq Error) - _visitsIgatherInstVisitNrs :: (Map Identifier Int) - _visitsIintra :: Exprs - _visitsIintraVars :: (Set String) - _visitsIisNil :: Bool - _visitsIsemNames :: ([String]) - -- "GenerateCode.ag"(line 78, column 20) - _visitsOcon = - con_ - -- "GenerateCode.ag"(line 79, column 20) - _visitsOterminals = - terminals_ - -- "GenerateCode.ag"(line 159, column 19) - _visitsOnr = - 0 - -- "GenerateCode.ag"(line 261, column 19) - _visitsOchildren = - children_ - -- "GenerateCode.ag"(line 349, column 7) - _visitsOinstVisitNrs = - _visitsIgatherInstVisitNrs - -- "GenerateCode.ag"(line 594, column 18) - _firstOrderChildren = - filter (\(_,_,ho) -> not ho) children_ - -- "GenerateCode.ag"(line 595, column 18) - _lhsOcomments = - ("alternative " ++ getName con_ ++ ":") - : map ind ( map (\(x,y,_) -> makeLocalComment 14 "child" x (Just y)) _firstOrderChildren - ++ _visitsIcomments - ) - -- "GenerateCode.ag"(line 704, column 19) - _lhsOdataAlt = - DataAlt (conname _lhsIo_rename _lhsInt con_) (map (\(_,t,_) -> typeToString _lhsInt t) _firstOrderChildren ) - -- "GenerateCode.ag"(line 759, column 18) - _lhsOcataAlt = - let lhs = Fun (cataname _lhsIprefix _lhsInt) [lhs_pat] - lhs_pat = App (conname _lhsIo_rename _lhsInt con_) - (map (\(n,_,_) -> SimpleExpr $ locname $ n) _firstOrderChildren ) - rhs = App (semname _lhsIprefix _lhsInt con_) - (map argument _firstOrderChildren ) - argument (nm,NT tp,_) = App (cataname _lhsIprefix tp) - [SimpleExpr (locname nm)] - argument (nm, _,_) = SimpleExpr (locname nm) - in Decl lhs rhs Set.empty Set.empty - -- use rule "GenerateCode.ag"(line 551, column 39) - _lhsOallTpsFound = - _visitsIallTpsFound - -- use rule "GenerateCode.ag"(line 626, column 46) - _lhsOdecls = - _visitsIdecls - -- use rule "GenerateCode.ag"(line 564, column 32) - _lhsOerrors = - _visitsIerrors - -- use rule "GenerateCode.ag"(line 774, column 63) - _lhsOsemNames = - _visitsIsemNames - -- copy rule (down) - _visitsOallPragmas = - _lhsIallPragmas - -- copy rule (down) - _visitsOerrors = - _lhsIerrors - -- copy rule (down) - _visitsOinh = - _lhsIinh - -- copy rule (down) - _visitsOnt = - _lhsInt - -- copy rule (down) - _visitsOo_case = - _lhsIo_case - -- copy rule (down) - _visitsOo_cata = - _lhsIo_cata - -- copy rule (down) - _visitsOo_costcentre = - _lhsIo_costcentre - -- copy rule (down) - _visitsOo_data = - _lhsIo_data - -- copy rule (down) - _visitsOo_linePragmas = - _lhsIo_linePragmas - -- copy rule (down) - _visitsOo_newtypes = - _lhsIo_newtypes - -- copy rule (down) - _visitsOo_pretty = - _lhsIo_pretty - -- copy rule (down) - _visitsOo_rename = - _lhsIo_rename - -- copy rule (down) - _visitsOo_sem = - _lhsIo_sem - -- copy rule (down) - _visitsOo_sig = - _lhsIo_sig - -- copy rule (down) - _visitsOo_splitsems = - _lhsIo_splitsems - -- copy rule (down) - _visitsOo_strictwrap = - _lhsIo_strictwrap - -- copy rule (down) - _visitsOo_traces = - _lhsIo_traces - -- copy rule (down) - _visitsOo_unbox = - _lhsIo_unbox - -- copy rule (down) - _visitsOprefix = - _lhsIprefix - -- copy rule (down) - _visitsOsyn = - _lhsIsyn - -- copy rule (down) - _visitsOwith_sig = - _lhsIwith_sig - ( _visitsIallTpsFound,_visitsIcomments,_visitsIdecls,_visitsIerrors,_visitsIgatherInstVisitNrs,_visitsIintra,_visitsIintraVars,_visitsIisNil,_visitsIsemNames) = - (visits_ _visitsOallPragmas _visitsOchildren _visitsOcon _visitsOerrors _visitsOinh _visitsOinstVisitNrs _visitsOnr _visitsOnt _visitsOo_case _visitsOo_cata _visitsOo_costcentre _visitsOo_data _visitsOo_linePragmas _visitsOo_newtypes _visitsOo_pretty _visitsOo_rename _visitsOo_sem _visitsOo_sig _visitsOo_splitsems _visitsOo_strictwrap _visitsOo_traces _visitsOo_unbox _visitsOprefix _visitsOsyn _visitsOterminals _visitsOwith_sig ) - in ( _lhsOallTpsFound,_lhsOcataAlt,_lhsOcomments,_lhsOdataAlt,_lhsOdecls,_lhsOerrors,_lhsOsemNames))) ) --- CAlternatives ----------------------------------------------- -{- - visit 0: - inherited attributes: - allPragmas : PragmaMap - inh : Attributes - nt : Nonterminal - o_case : Bool - o_cata : Bool - o_costcentre : Bool - o_data : Maybe Bool - o_linePragmas : Bool - o_newtypes : Bool - o_pretty : Bool - o_rename : Bool - o_sem : Bool - o_sig : Bool - o_splitsems : Bool - o_strictwrap : Bool - o_traces : Bool - o_unbox : Bool - prefix : String - syn : Attributes - with_sig : Bool - chained attribute: - errors : Seq Error - synthesized attributes: - allTpsFound : Bool - cataAlts : Decls - comments : [String] - dataAlts : DataAlts - decls : Decls - semNames : [String] - alternatives: - alternative Cons: - child hd : CAlternative - child tl : CAlternatives - alternative Nil: --} --- cata -sem_CAlternatives :: CAlternatives -> - T_CAlternatives -sem_CAlternatives list = - (Prelude.foldr sem_CAlternatives_Cons sem_CAlternatives_Nil (Prelude.map sem_CAlternative list) ) --- semantic domain -newtype T_CAlternatives = T_CAlternatives (PragmaMap -> - (Seq Error) -> - Attributes -> - Nonterminal -> - Bool -> - Bool -> - Bool -> - (Maybe Bool) -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - String -> - Attributes -> - Bool -> - ( Bool,Decls,([String]),DataAlts,Decls,(Seq Error),([String]))) -data Inh_CAlternatives = Inh_CAlternatives {allPragmas_Inh_CAlternatives :: PragmaMap,errors_Inh_CAlternatives :: Seq Error,inh_Inh_CAlternatives :: Attributes,nt_Inh_CAlternatives :: Nonterminal,o_case_Inh_CAlternatives :: Bool,o_cata_Inh_CAlternatives :: Bool,o_costcentre_Inh_CAlternatives :: Bool,o_data_Inh_CAlternatives :: Maybe Bool,o_linePragmas_Inh_CAlternatives :: Bool,o_newtypes_Inh_CAlternatives :: Bool,o_pretty_Inh_CAlternatives :: Bool,o_rename_Inh_CAlternatives :: Bool,o_sem_Inh_CAlternatives :: Bool,o_sig_Inh_CAlternatives :: Bool,o_splitsems_Inh_CAlternatives :: Bool,o_strictwrap_Inh_CAlternatives :: Bool,o_traces_Inh_CAlternatives :: Bool,o_unbox_Inh_CAlternatives :: Bool,prefix_Inh_CAlternatives :: String,syn_Inh_CAlternatives :: Attributes,with_sig_Inh_CAlternatives :: Bool} -data Syn_CAlternatives = Syn_CAlternatives {allTpsFound_Syn_CAlternatives :: Bool,cataAlts_Syn_CAlternatives :: Decls,comments_Syn_CAlternatives :: [String],dataAlts_Syn_CAlternatives :: DataAlts,decls_Syn_CAlternatives :: Decls,errors_Syn_CAlternatives :: Seq Error,semNames_Syn_CAlternatives :: [String]} -wrap_CAlternatives (T_CAlternatives sem ) (Inh_CAlternatives _lhsIallPragmas _lhsIerrors _lhsIinh _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn _lhsIwith_sig ) = - (let ( _lhsOallTpsFound,_lhsOcataAlts,_lhsOcomments,_lhsOdataAlts,_lhsOdecls,_lhsOerrors,_lhsOsemNames) = - (sem _lhsIallPragmas _lhsIerrors _lhsIinh _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn _lhsIwith_sig ) - in (Syn_CAlternatives _lhsOallTpsFound _lhsOcataAlts _lhsOcomments _lhsOdataAlts _lhsOdecls _lhsOerrors _lhsOsemNames )) -sem_CAlternatives_Cons :: T_CAlternative -> - T_CAlternatives -> - T_CAlternatives -sem_CAlternatives_Cons (T_CAlternative hd_ ) (T_CAlternatives tl_ ) = - (T_CAlternatives (\ _lhsIallPragmas - _lhsIerrors - _lhsIinh - _lhsInt - _lhsIo_case - _lhsIo_cata - _lhsIo_costcentre - _lhsIo_data - _lhsIo_linePragmas - _lhsIo_newtypes - _lhsIo_pretty - _lhsIo_rename - _lhsIo_sem - _lhsIo_sig - _lhsIo_splitsems - _lhsIo_strictwrap - _lhsIo_traces - _lhsIo_unbox - _lhsIprefix - _lhsIsyn - _lhsIwith_sig -> - (let _lhsOdataAlts :: DataAlts - _lhsOcataAlts :: Decls - _lhsOallTpsFound :: Bool - _lhsOcomments :: ([String]) - _lhsOdecls :: Decls - _lhsOerrors :: (Seq Error) - _lhsOsemNames :: ([String]) - _hdOallPragmas :: PragmaMap - _hdOerrors :: (Seq Error) - _hdOinh :: Attributes - _hdOnt :: Nonterminal - _hdOo_case :: Bool - _hdOo_cata :: Bool - _hdOo_costcentre :: Bool - _hdOo_data :: (Maybe Bool) - _hdOo_linePragmas :: Bool - _hdOo_newtypes :: Bool - _hdOo_pretty :: Bool - _hdOo_rename :: Bool - _hdOo_sem :: Bool - _hdOo_sig :: Bool - _hdOo_splitsems :: Bool - _hdOo_strictwrap :: Bool - _hdOo_traces :: Bool - _hdOo_unbox :: Bool - _hdOprefix :: String - _hdOsyn :: Attributes - _hdOwith_sig :: Bool - _tlOallPragmas :: PragmaMap - _tlOerrors :: (Seq Error) - _tlOinh :: Attributes - _tlOnt :: Nonterminal - _tlOo_case :: Bool - _tlOo_cata :: Bool - _tlOo_costcentre :: Bool - _tlOo_data :: (Maybe Bool) - _tlOo_linePragmas :: Bool - _tlOo_newtypes :: Bool - _tlOo_pretty :: Bool - _tlOo_rename :: Bool - _tlOo_sem :: Bool - _tlOo_sig :: Bool - _tlOo_splitsems :: Bool - _tlOo_strictwrap :: Bool - _tlOo_traces :: Bool - _tlOo_unbox :: Bool - _tlOprefix :: String - _tlOsyn :: Attributes - _tlOwith_sig :: Bool - _hdIallTpsFound :: Bool - _hdIcataAlt :: Decl - _hdIcomments :: ([String]) - _hdIdataAlt :: DataAlt - _hdIdecls :: Decls - _hdIerrors :: (Seq Error) - _hdIsemNames :: ([String]) - _tlIallTpsFound :: Bool - _tlIcataAlts :: Decls - _tlIcomments :: ([String]) - _tlIdataAlts :: DataAlts - _tlIdecls :: Decls - _tlIerrors :: (Seq Error) - _tlIsemNames :: ([String]) - -- "GenerateCode.ag"(line 700, column 17) - _lhsOdataAlts = - _hdIdataAlt : _tlIdataAlts - -- "GenerateCode.ag"(line 755, column 10) - _lhsOcataAlts = - _hdIcataAlt : _tlIcataAlts - -- use rule "GenerateCode.ag"(line 551, column 39) - _lhsOallTpsFound = - _hdIallTpsFound && _tlIallTpsFound - -- use rule "GenerateCode.ag"(line 583, column 52) - _lhsOcomments = - _hdIcomments ++ _tlIcomments - -- use rule "GenerateCode.ag"(line 626, column 46) - _lhsOdecls = - _hdIdecls ++ _tlIdecls - -- use rule "GenerateCode.ag"(line 564, column 32) - _lhsOerrors = - _hdIerrors Seq.<> _tlIerrors - -- use rule "GenerateCode.ag"(line 774, column 63) - _lhsOsemNames = - _hdIsemNames ++ _tlIsemNames - -- copy rule (down) - _hdOallPragmas = - _lhsIallPragmas - -- copy rule (down) - _hdOerrors = - _lhsIerrors - -- copy rule (down) - _hdOinh = - _lhsIinh - -- copy rule (down) - _hdOnt = - _lhsInt - -- copy rule (down) - _hdOo_case = - _lhsIo_case - -- copy rule (down) - _hdOo_cata = - _lhsIo_cata - -- copy rule (down) - _hdOo_costcentre = - _lhsIo_costcentre - -- copy rule (down) - _hdOo_data = - _lhsIo_data - -- copy rule (down) - _hdOo_linePragmas = - _lhsIo_linePragmas - -- copy rule (down) - _hdOo_newtypes = - _lhsIo_newtypes - -- copy rule (down) - _hdOo_pretty = - _lhsIo_pretty - -- copy rule (down) - _hdOo_rename = - _lhsIo_rename - -- copy rule (down) - _hdOo_sem = - _lhsIo_sem - -- copy rule (down) - _hdOo_sig = - _lhsIo_sig - -- copy rule (down) - _hdOo_splitsems = - _lhsIo_splitsems - -- copy rule (down) - _hdOo_strictwrap = - _lhsIo_strictwrap - -- copy rule (down) - _hdOo_traces = - _lhsIo_traces - -- copy rule (down) - _hdOo_unbox = - _lhsIo_unbox - -- copy rule (down) - _hdOprefix = - _lhsIprefix - -- copy rule (down) - _hdOsyn = - _lhsIsyn - -- copy rule (down) - _hdOwith_sig = - _lhsIwith_sig - -- copy rule (down) - _tlOallPragmas = - _lhsIallPragmas - -- copy rule (chain) - _tlOerrors = - _hdIerrors - -- copy rule (down) - _tlOinh = - _lhsIinh - -- copy rule (down) - _tlOnt = - _lhsInt - -- copy rule (down) - _tlOo_case = - _lhsIo_case - -- copy rule (down) - _tlOo_cata = - _lhsIo_cata - -- copy rule (down) - _tlOo_costcentre = - _lhsIo_costcentre - -- copy rule (down) - _tlOo_data = - _lhsIo_data - -- copy rule (down) - _tlOo_linePragmas = - _lhsIo_linePragmas - -- copy rule (down) - _tlOo_newtypes = - _lhsIo_newtypes - -- copy rule (down) - _tlOo_pretty = - _lhsIo_pretty - -- copy rule (down) - _tlOo_rename = - _lhsIo_rename - -- copy rule (down) - _tlOo_sem = - _lhsIo_sem - -- copy rule (down) - _tlOo_sig = - _lhsIo_sig - -- copy rule (down) - _tlOo_splitsems = - _lhsIo_splitsems - -- copy rule (down) - _tlOo_strictwrap = - _lhsIo_strictwrap - -- copy rule (down) - _tlOo_traces = - _lhsIo_traces - -- copy rule (down) - _tlOo_unbox = - _lhsIo_unbox - -- copy rule (down) - _tlOprefix = - _lhsIprefix - -- copy rule (down) - _tlOsyn = - _lhsIsyn - -- copy rule (down) - _tlOwith_sig = - _lhsIwith_sig - ( _hdIallTpsFound,_hdIcataAlt,_hdIcomments,_hdIdataAlt,_hdIdecls,_hdIerrors,_hdIsemNames) = - (hd_ _hdOallPragmas _hdOerrors _hdOinh _hdOnt _hdOo_case _hdOo_cata _hdOo_costcentre _hdOo_data _hdOo_linePragmas _hdOo_newtypes _hdOo_pretty _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_splitsems _hdOo_strictwrap _hdOo_traces _hdOo_unbox _hdOprefix _hdOsyn _hdOwith_sig ) - ( _tlIallTpsFound,_tlIcataAlts,_tlIcomments,_tlIdataAlts,_tlIdecls,_tlIerrors,_tlIsemNames) = - (tl_ _tlOallPragmas _tlOerrors _tlOinh _tlOnt _tlOo_case _tlOo_cata _tlOo_costcentre _tlOo_data _tlOo_linePragmas _tlOo_newtypes _tlOo_pretty _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_splitsems _tlOo_strictwrap _tlOo_traces _tlOo_unbox _tlOprefix _tlOsyn _tlOwith_sig ) - in ( _lhsOallTpsFound,_lhsOcataAlts,_lhsOcomments,_lhsOdataAlts,_lhsOdecls,_lhsOerrors,_lhsOsemNames))) ) -sem_CAlternatives_Nil :: T_CAlternatives -sem_CAlternatives_Nil = - (T_CAlternatives (\ _lhsIallPragmas - _lhsIerrors - _lhsIinh - _lhsInt - _lhsIo_case - _lhsIo_cata - _lhsIo_costcentre - _lhsIo_data - _lhsIo_linePragmas - _lhsIo_newtypes - _lhsIo_pretty - _lhsIo_rename - _lhsIo_sem - _lhsIo_sig - _lhsIo_splitsems - _lhsIo_strictwrap - _lhsIo_traces - _lhsIo_unbox - _lhsIprefix - _lhsIsyn - _lhsIwith_sig -> - (let _lhsOdataAlts :: DataAlts - _lhsOcataAlts :: Decls - _lhsOallTpsFound :: Bool - _lhsOcomments :: ([String]) - _lhsOdecls :: Decls - _lhsOerrors :: (Seq Error) - _lhsOsemNames :: ([String]) - -- "GenerateCode.ag"(line 701, column 17) - _lhsOdataAlts = - [] - -- "GenerateCode.ag"(line 756, column 10) - _lhsOcataAlts = - [] - -- use rule "GenerateCode.ag"(line 551, column 39) - _lhsOallTpsFound = - True - -- use rule "GenerateCode.ag"(line 583, column 52) - _lhsOcomments = - [] - -- use rule "GenerateCode.ag"(line 626, column 46) - _lhsOdecls = - [] - -- use rule "GenerateCode.ag"(line 564, column 32) - _lhsOerrors = - Seq.empty - -- use rule "GenerateCode.ag"(line 774, column 63) - _lhsOsemNames = - [] - in ( _lhsOallTpsFound,_lhsOcataAlts,_lhsOcomments,_lhsOdataAlts,_lhsOdecls,_lhsOerrors,_lhsOsemNames))) ) --- CGrammar ---------------------------------------------------- -{- - visit 0: - inherited attribute: - options : Options - synthesized attributes: - errors : Seq Error - output : Program - alternatives: - alternative CGrammar: - child typeSyns : {TypeSyns} - child derivings : {Derivings} - child wrappers : {Set Nonterminal} - child prods : CProductions - child pragmas : {PragmaMap} --} --- cata -sem_CGrammar :: CGrammar -> - T_CGrammar -sem_CGrammar (CGrammar _typeSyns _derivings _wrappers _prods _pragmas ) = - (sem_CGrammar_CGrammar _typeSyns _derivings _wrappers (sem_CProductions _prods ) _pragmas ) --- semantic domain -newtype T_CGrammar = T_CGrammar (Options -> - ( (Seq Error),Program)) -data Inh_CGrammar = Inh_CGrammar {options_Inh_CGrammar :: Options} -data Syn_CGrammar = Syn_CGrammar {errors_Syn_CGrammar :: Seq Error,output_Syn_CGrammar :: Program} -wrap_CGrammar (T_CGrammar sem ) (Inh_CGrammar _lhsIoptions ) = - (let ( _lhsOerrors,_lhsOoutput) = - (sem _lhsIoptions ) - in (Syn_CGrammar _lhsOerrors _lhsOoutput )) -sem_CGrammar_CGrammar :: TypeSyns -> - Derivings -> - (Set Nonterminal) -> - T_CProductions -> - PragmaMap -> - T_CGrammar -sem_CGrammar_CGrammar typeSyns_ derivings_ wrappers_ (T_CProductions prods_ ) pragmas_ = - (T_CGrammar (\ _lhsIoptions -> - (let _prodsOo_sig :: Bool - _prodsOo_cata :: Bool - _prodsOo_sem :: Bool - _prodsOo_newtypes :: Bool - _prodsOo_unbox :: Bool - _prodsOo_case :: Bool - _prodsOo_pretty :: Bool - _prodsOo_rename :: Bool - _prodsOo_strictwrap :: Bool - _prodsOo_splitsems :: Bool - _prodsOo_data :: (Maybe Bool) - _prodsOprefix :: String - _prodsOo_traces :: Bool - _prodsOo_costcentre :: Bool - _prodsOo_linePragmas :: Bool - _prodsOallPragmas :: PragmaMap - _prodsOwith_sig :: Bool - _prodsOerrors :: (Seq Error) - _lhsOoutput :: Program - _prodsOtypeSyns :: TypeSyns - _prodsOderivings :: Derivings - _prodsOwrappers :: (Set Nonterminal) - _lhsOerrors :: (Seq Error) - _prodsIallTpsFound :: Bool - _prodsIchunks :: Chunks - _prodsIerrors :: (Seq Error) - -- "GenerateCode.ag"(line 43, column 17) - _prodsOo_sig = - typeSigs _lhsIoptions - -- "GenerateCode.ag"(line 43, column 17) - _prodsOo_cata = - folds _lhsIoptions - -- "GenerateCode.ag"(line 43, column 17) - _prodsOo_sem = - semfuns _lhsIoptions - -- "GenerateCode.ag"(line 43, column 17) - _prodsOo_newtypes = - newtypes _lhsIoptions - -- "GenerateCode.ag"(line 43, column 17) - _prodsOo_unbox = - unbox _lhsIoptions - -- "GenerateCode.ag"(line 43, column 17) - _prodsOo_case = - cases _lhsIoptions - -- "GenerateCode.ag"(line 43, column 17) - _prodsOo_pretty = - attrInfo _lhsIoptions - -- "GenerateCode.ag"(line 43, column 17) - _prodsOo_rename = - rename _lhsIoptions - -- "GenerateCode.ag"(line 43, column 17) - _prodsOo_strictwrap = - strictWrap _lhsIoptions - -- "GenerateCode.ag"(line 43, column 17) - _prodsOo_splitsems = - splitSems _lhsIoptions - -- "GenerateCode.ag"(line 43, column 17) - _prodsOo_data = - if dataTypes _lhsIoptions then Just (strictData _lhsIoptions) else Nothing - -- "GenerateCode.ag"(line 43, column 17) - _prodsOprefix = - prefix _lhsIoptions - -- "GenerateCode.ag"(line 43, column 17) - _prodsOo_traces = - genTraces _lhsIoptions - -- "GenerateCode.ag"(line 43, column 17) - _prodsOo_costcentre = - genCostCentres _lhsIoptions - -- "GenerateCode.ag"(line 43, column 17) - _prodsOo_linePragmas = - genLinePragmas _lhsIoptions - -- "GenerateCode.ag"(line 62, column 15) - _prodsOallPragmas = - pragmas_ - -- "GenerateCode.ag"(line 559, column 14) - _prodsOwith_sig = - typeSigs _lhsIoptions && _prodsIallTpsFound - -- "GenerateCode.ag"(line 566, column 15) - _prodsOerrors = - Seq.empty - -- "GenerateCode.ag"(line 630, column 17) - _lhsOoutput = - Program _prodsIchunks - -- "GenerateCode.ag"(line 679, column 14) - _prodsOtypeSyns = - typeSyns_ - -- "GenerateCode.ag"(line 679, column 14) - _prodsOderivings = - derivings_ - -- "GenerateCode.ag"(line 679, column 14) - _prodsOwrappers = - wrappers_ - -- copy rule (up) - _lhsOerrors = - _prodsIerrors - ( _prodsIallTpsFound,_prodsIchunks,_prodsIerrors) = - (prods_ _prodsOallPragmas _prodsOderivings _prodsOerrors _prodsOo_case _prodsOo_cata _prodsOo_costcentre _prodsOo_data _prodsOo_linePragmas _prodsOo_newtypes _prodsOo_pretty _prodsOo_rename _prodsOo_sem _prodsOo_sig _prodsOo_splitsems _prodsOo_strictwrap _prodsOo_traces _prodsOo_unbox _prodsOprefix _prodsOtypeSyns _prodsOwith_sig _prodsOwrappers ) - in ( _lhsOerrors,_lhsOoutput))) ) --- CInterface -------------------------------------------------- -{- - visit 0: - inherited attributes: - inh : Attributes - nt : Nonterminal - o_case : Bool - o_cata : Bool - o_costcentre : Bool - o_data : Maybe Bool - o_linePragmas : Bool - o_newtypes : Bool - o_pretty : Bool - o_rename : Bool - o_sem : Bool - o_sig : Bool - o_splitsems : Bool - o_strictwrap : Bool - o_traces : Bool - o_unbox : Bool - prefix : String - syn : Attributes - synthesized attributes: - comments : [String] - semDom : [Decl] - wrapDecls : Decls - alternatives: - alternative CInterface: - child seg : CSegments --} --- cata -sem_CInterface :: CInterface -> - T_CInterface -sem_CInterface (CInterface _seg ) = - (sem_CInterface_CInterface (sem_CSegments _seg ) ) --- semantic domain -newtype T_CInterface = T_CInterface (Attributes -> - Nonterminal -> - Bool -> - Bool -> - Bool -> - (Maybe Bool) -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - String -> - Attributes -> - ( ([String]),([Decl]),Decls)) -data Inh_CInterface = Inh_CInterface {inh_Inh_CInterface :: Attributes,nt_Inh_CInterface :: Nonterminal,o_case_Inh_CInterface :: Bool,o_cata_Inh_CInterface :: Bool,o_costcentre_Inh_CInterface :: Bool,o_data_Inh_CInterface :: Maybe Bool,o_linePragmas_Inh_CInterface :: Bool,o_newtypes_Inh_CInterface :: Bool,o_pretty_Inh_CInterface :: Bool,o_rename_Inh_CInterface :: Bool,o_sem_Inh_CInterface :: Bool,o_sig_Inh_CInterface :: Bool,o_splitsems_Inh_CInterface :: Bool,o_strictwrap_Inh_CInterface :: Bool,o_traces_Inh_CInterface :: Bool,o_unbox_Inh_CInterface :: Bool,prefix_Inh_CInterface :: String,syn_Inh_CInterface :: Attributes} -data Syn_CInterface = Syn_CInterface {comments_Syn_CInterface :: [String],semDom_Syn_CInterface :: [Decl],wrapDecls_Syn_CInterface :: Decls} -wrap_CInterface (T_CInterface sem ) (Inh_CInterface _lhsIinh _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn ) = - (let ( _lhsOcomments,_lhsOsemDom,_lhsOwrapDecls) = - (sem _lhsIinh _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn ) - in (Syn_CInterface _lhsOcomments _lhsOsemDom _lhsOwrapDecls )) -sem_CInterface_CInterface :: T_CSegments -> - T_CInterface -sem_CInterface_CInterface (T_CSegments seg_ ) = - (T_CInterface (\ _lhsIinh - _lhsInt - _lhsIo_case - _lhsIo_cata - _lhsIo_costcentre - _lhsIo_data - _lhsIo_linePragmas - _lhsIo_newtypes - _lhsIo_pretty - _lhsIo_rename - _lhsIo_sem - _lhsIo_sig - _lhsIo_splitsems - _lhsIo_strictwrap - _lhsIo_traces - _lhsIo_unbox - _lhsIprefix - _lhsIsyn -> - (let _segOnr :: Int - _lhsOsemDom :: ([Decl]) - _lhsOcomments :: ([String]) - _lhsOwrapDecls :: Decls - _segOinh :: Attributes - _segOnt :: Nonterminal - _segOo_case :: Bool - _segOo_cata :: Bool - _segOo_costcentre :: Bool - _segOo_data :: (Maybe Bool) - _segOo_linePragmas :: Bool - _segOo_newtypes :: Bool - _segOo_pretty :: Bool - _segOo_rename :: Bool - _segOo_sem :: Bool - _segOo_sig :: Bool - _segOo_splitsems :: Bool - _segOo_strictwrap :: Bool - _segOo_traces :: Bool - _segOo_unbox :: Bool - _segOprefix :: String - _segOsyn :: Attributes - _segIcomments :: ([String]) - _segIisNil :: Bool - _segIsemDom :: ([Decl]) - _segIwrapDecls :: Decls - -- "GenerateCode.ag"(line 163, column 17) - _segOnr = - 0 - -- "GenerateCode.ag"(line 493, column 18) - _lhsOsemDom = - Comment "semantic domain" : _segIsemDom - -- use rule "GenerateCode.ag"(line 583, column 52) - _lhsOcomments = - _segIcomments - -- use rule "GenerateCode.ag"(line 532, column 52) - _lhsOwrapDecls = - _segIwrapDecls - -- copy rule (down) - _segOinh = - _lhsIinh - -- copy rule (down) - _segOnt = - _lhsInt - -- copy rule (down) - _segOo_case = - _lhsIo_case - -- copy rule (down) - _segOo_cata = - _lhsIo_cata - -- copy rule (down) - _segOo_costcentre = - _lhsIo_costcentre - -- copy rule (down) - _segOo_data = - _lhsIo_data - -- copy rule (down) - _segOo_linePragmas = - _lhsIo_linePragmas - -- copy rule (down) - _segOo_newtypes = - _lhsIo_newtypes - -- copy rule (down) - _segOo_pretty = - _lhsIo_pretty - -- copy rule (down) - _segOo_rename = - _lhsIo_rename - -- copy rule (down) - _segOo_sem = - _lhsIo_sem - -- copy rule (down) - _segOo_sig = - _lhsIo_sig - -- copy rule (down) - _segOo_splitsems = - _lhsIo_splitsems - -- copy rule (down) - _segOo_strictwrap = - _lhsIo_strictwrap - -- copy rule (down) - _segOo_traces = - _lhsIo_traces - -- copy rule (down) - _segOo_unbox = - _lhsIo_unbox - -- copy rule (down) - _segOprefix = - _lhsIprefix - -- copy rule (down) - _segOsyn = - _lhsIsyn - ( _segIcomments,_segIisNil,_segIsemDom,_segIwrapDecls) = - (seg_ _segOinh _segOnr _segOnt _segOo_case _segOo_cata _segOo_costcentre _segOo_data _segOo_linePragmas _segOo_newtypes _segOo_pretty _segOo_rename _segOo_sem _segOo_sig _segOo_splitsems _segOo_strictwrap _segOo_traces _segOo_unbox _segOprefix _segOsyn ) - in ( _lhsOcomments,_lhsOsemDom,_lhsOwrapDecls))) ) --- CProduction ------------------------------------------------- -{- - visit 0: - inherited attributes: - allPragmas : PragmaMap - derivings : Derivings - o_case : Bool - o_cata : Bool - o_costcentre : Bool - o_data : Maybe Bool - o_linePragmas : Bool - o_newtypes : Bool - o_pretty : Bool - o_rename : Bool - o_sem : Bool - o_sig : Bool - o_splitsems : Bool - o_strictwrap : Bool - o_traces : Bool - o_unbox : Bool - prefix : String - typeSyns : TypeSyns - with_sig : Bool - wrappers : Set Nonterminal - chained attribute: - errors : Seq Error - synthesized attributes: - allTpsFound : Bool - chunks : Chunks - alternatives: - alternative CProduction: - child nt : {Nonterminal} - child inh : {Attributes} - child syn : {Attributes} - child alts : CAlternatives - child inter : CInterface - visit 0: - local _tup1 : {(Attributes,Attributes,Nonterminal)} - local _tup2 : {(Attributes,Attributes,Nonterminal)} - local semWrapper : _ - local comment : _ - local dataDef : _ - local cataFun : _ --} --- cata -sem_CProduction :: CProduction -> - T_CProduction -sem_CProduction (CProduction _nt _inh _syn _alts _inter ) = - (sem_CProduction_CProduction _nt _inh _syn (sem_CAlternatives _alts ) (sem_CInterface _inter ) ) --- semantic domain -newtype T_CProduction = T_CProduction (PragmaMap -> - Derivings -> - (Seq Error) -> - Bool -> - Bool -> - Bool -> - (Maybe Bool) -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - String -> - TypeSyns -> - Bool -> - (Set Nonterminal) -> - ( Bool,Chunks,(Seq Error))) -data Inh_CProduction = Inh_CProduction {allPragmas_Inh_CProduction :: PragmaMap,derivings_Inh_CProduction :: Derivings,errors_Inh_CProduction :: Seq Error,o_case_Inh_CProduction :: Bool,o_cata_Inh_CProduction :: Bool,o_costcentre_Inh_CProduction :: Bool,o_data_Inh_CProduction :: Maybe Bool,o_linePragmas_Inh_CProduction :: Bool,o_newtypes_Inh_CProduction :: Bool,o_pretty_Inh_CProduction :: Bool,o_rename_Inh_CProduction :: Bool,o_sem_Inh_CProduction :: Bool,o_sig_Inh_CProduction :: Bool,o_splitsems_Inh_CProduction :: Bool,o_strictwrap_Inh_CProduction :: Bool,o_traces_Inh_CProduction :: Bool,o_unbox_Inh_CProduction :: Bool,prefix_Inh_CProduction :: String,typeSyns_Inh_CProduction :: TypeSyns,with_sig_Inh_CProduction :: Bool,wrappers_Inh_CProduction :: Set Nonterminal} -data Syn_CProduction = Syn_CProduction {allTpsFound_Syn_CProduction :: Bool,chunks_Syn_CProduction :: Chunks,errors_Syn_CProduction :: Seq Error} -wrap_CProduction (T_CProduction sem ) (Inh_CProduction _lhsIallPragmas _lhsIderivings _lhsIerrors _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsItypeSyns _lhsIwith_sig _lhsIwrappers ) = - (let ( _lhsOallTpsFound,_lhsOchunks,_lhsOerrors) = - (sem _lhsIallPragmas _lhsIderivings _lhsIerrors _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsItypeSyns _lhsIwith_sig _lhsIwrappers ) - in (Syn_CProduction _lhsOallTpsFound _lhsOchunks _lhsOerrors )) -sem_CProduction_CProduction :: Nonterminal -> - Attributes -> - Attributes -> - T_CAlternatives -> - T_CInterface -> - T_CProduction -sem_CProduction_CProduction nt_ inh_ syn_ (T_CAlternatives alts_ ) (T_CInterface inter_ ) = - (T_CProduction (\ _lhsIallPragmas - _lhsIderivings - _lhsIerrors - _lhsIo_case - _lhsIo_cata - _lhsIo_costcentre - _lhsIo_data - _lhsIo_linePragmas - _lhsIo_newtypes - _lhsIo_pretty - _lhsIo_rename - _lhsIo_sem - _lhsIo_sig - _lhsIo_splitsems - _lhsIo_strictwrap - _lhsIo_traces - _lhsIo_unbox - _lhsIprefix - _lhsItypeSyns - _lhsIwith_sig - _lhsIwrappers -> - (let __tup1 :: ((Attributes,Attributes,Nonterminal)) - _interOinh :: Attributes - _interOsyn :: Attributes - _interOnt :: Nonterminal - __tup2 :: ((Attributes,Attributes,Nonterminal)) - _altsOinh :: Attributes - _altsOsyn :: Attributes - _altsOnt :: Nonterminal - _lhsOchunks :: Chunks - _lhsOallTpsFound :: Bool - _lhsOerrors :: (Seq Error) - _altsOallPragmas :: PragmaMap - _altsOerrors :: (Seq Error) - _altsOo_case :: Bool - _altsOo_cata :: Bool - _altsOo_costcentre :: Bool - _altsOo_data :: (Maybe Bool) - _altsOo_linePragmas :: Bool - _altsOo_newtypes :: Bool - _altsOo_pretty :: Bool - _altsOo_rename :: Bool - _altsOo_sem :: Bool - _altsOo_sig :: Bool - _altsOo_splitsems :: Bool - _altsOo_strictwrap :: Bool - _altsOo_traces :: Bool - _altsOo_unbox :: Bool - _altsOprefix :: String - _altsOwith_sig :: Bool - _interOo_case :: Bool - _interOo_cata :: Bool - _interOo_costcentre :: Bool - _interOo_data :: (Maybe Bool) - _interOo_linePragmas :: Bool - _interOo_newtypes :: Bool - _interOo_pretty :: Bool - _interOo_rename :: Bool - _interOo_sem :: Bool - _interOo_sig :: Bool - _interOo_splitsems :: Bool - _interOo_strictwrap :: Bool - _interOo_traces :: Bool - _interOo_unbox :: Bool - _interOprefix :: String - _altsIallTpsFound :: Bool - _altsIcataAlts :: Decls - _altsIcomments :: ([String]) - _altsIdataAlts :: DataAlts - _altsIdecls :: Decls - _altsIerrors :: (Seq Error) - _altsIsemNames :: ([String]) - _interIcomments :: ([String]) - _interIsemDom :: ([Decl]) - _interIwrapDecls :: Decls - -- "GenerateCode.ag"(line 72, column 25) - __tup1 = - (inh_,syn_,nt_) - -- "GenerateCode.ag"(line 72, column 25) - (_interOinh,_,_) = - __tup1 - -- "GenerateCode.ag"(line 72, column 25) - (_,_interOsyn,_) = - __tup1 - -- "GenerateCode.ag"(line 72, column 25) - (_,_,_interOnt) = - __tup1 - -- "GenerateCode.ag"(line 73, column 24) - __tup2 = - (inh_,syn_,nt_) - -- "GenerateCode.ag"(line 73, column 24) - (_altsOinh,_,_) = - __tup2 - -- "GenerateCode.ag"(line 73, column 24) - (_,_altsOsyn,_) = - __tup2 - -- "GenerateCode.ag"(line 73, column 24) - (_,_,_altsOnt) = - __tup2 - -- "GenerateCode.ag"(line 512, column 17) - _semWrapper = - let inhAttrs = Map.toList inh_ - synAttrs = Map.toList syn_ - inhVars = [ SimpleExpr (attrname True _LHS a) | (a,_) <- inhAttrs ] - synVars = [ SimpleExpr (attrname False _LHS a) | (a,_) <- synAttrs ] - var = "sem" - wrapNT = "wrap" ++ "_" ++ getName nt_ - inhNT = "Inh" ++ "_" ++ getName nt_ - synNT = "Syn" ++ "_" ++ getName nt_ - varPat = if _lhsIo_newtypes - then App (sdtype nt_) [SimpleExpr var] - else SimpleExpr var - typeSig = TSig wrapNT (SimpleType (sdtype nt_) `Arr` (SimpleType inhNT `Arr` SimpleType synNT)) - mkstrict = if _lhsIo_strictwrap then (\x -> "!(" ++ x ++ ")") else id - mkdata n attrs = Data n [Record n [(getName f++"_"++n,mkstrict $ typeToString nt_ t) | (f,t) <- attrs]] False [] - datas = [mkdata inhNT inhAttrs, mkdata synNT synAttrs] - in datas ++ [ Decl (Fun wrapNT [varPat, App inhNT inhVars]) - (Let _interIwrapDecls (App synNT synVars)) - Set.empty Set.empty - ] - -- "GenerateCode.ag"(line 579, column 17) - _comment = - Comment . unlines . map ind $ ( _interIcomments ++ ("alternatives:" : map ind _altsIcomments) ) - -- "GenerateCode.ag"(line 633, column 18) - _lhsOchunks = - [ Chunk (getName nt_) - (Comment (getName nt_ ++ " " ++ replicate (60 - length (getName nt_)) '-')) - (if _lhsIo_pretty then [_comment ] else []) - (if isJust _lhsIo_data then [_dataDef ] else []) - (if _lhsIo_cata then _cataFun else []) - (if _lhsIo_sig then _interIsemDom else []) - (if nt_ `Set.member` _lhsIwrappers then _semWrapper else []) - (if _lhsIo_sem then _altsIdecls else []) - (if _lhsIo_sem then _altsIsemNames else []) - ] - -- "GenerateCode.ag"(line 684, column 17) - _dataDef = - let typeSyn tp = let theType = - case tp of - CommonTypes.Maybe t -> SimpleType ("Maybe (" ++ typeToString nt_ t ++")") - CommonTypes.List t -> Code.List $ SimpleType (typeToString nt_ t) - CommonTypes.Tuple ts -> Code.TupleType [SimpleType (typeToString nt_ t) - | (_,t) <- ts - ] - in Code.Type (getName nt_) theType - derivings = maybe [] (map getName . Set.toList) (Map.lookup nt_ _lhsIderivings) - dataDef = Data (getName nt_) _altsIdataAlts (maybe False id _lhsIo_data) derivings - in maybe dataDef typeSyn $ lookup nt_ _lhsItypeSyns - -- "GenerateCode.ag"(line 711, column 17) - _cataFun = - let tSig = TSig (cataname _lhsIprefix nt_) - (SimpleType (getName nt_) `Arr` SimpleType (sdtype nt_)) - special typ = case typ of - CommonTypes.List tp -> - let cons = SimpleExpr (semname _lhsIprefix nt_ (identifier "Cons")) - nil = SimpleExpr (semname _lhsIprefix nt_ (identifier "Nil" )) - arg = SimpleExpr "list" - rarg = case tp of - NT t -> SimpleExpr ("(Prelude.map " ++ (cataname _lhsIprefix t) ++ " list)") - _ -> arg - lhs = Fun (cataname _lhsIprefix nt_) [arg] - rhs = (App "Prelude.foldr" [cons,nil,rarg]) - in [Decl lhs rhs Set.empty Set.empty] - CommonTypes.Maybe tp -> - let just = semname _lhsIprefix nt_ (identifier "Just") - nothing = semname _lhsIprefix nt_ (identifier "Nothing" ) - arg = SimpleExpr "x" - rarg = case tp of - NT t -> App (cataname _lhsIprefix t) [arg] - _ -> arg - lhs a = Fun (cataname _lhsIprefix nt_) [a] - in [Decl (lhs (App "Prelude.Just" [arg])) (App just [rarg]) Set.empty Set.empty - ,Decl (lhs (SimpleExpr "Prelude.Nothing")) (SimpleExpr nothing) Set.empty Set.empty - ] - CommonTypes.Tuple tps -> - let con = semname _lhsIprefix nt_ (identifier "Tuple") - tps' = [ (SimpleExpr (getName x),y) | (x,y) <- tps] - rargs = map rarg tps' - rarg (n, tp) = case tp of - NT t -> App (cataname _lhsIprefix t) [n] - _ -> n - lhs = Fun (cataname _lhsIprefix nt_) [TupleExpr (map fst tps')] - rhs = App con rargs - in [Decl lhs rhs Set.empty Set.empty] - in Comment "cata" : - (if _lhsIo_sig then [tSig] else []) ++ - maybe _altsIcataAlts special (lookup nt_ _lhsItypeSyns) - -- use rule "GenerateCode.ag"(line 551, column 39) - _lhsOallTpsFound = - _altsIallTpsFound - -- use rule "GenerateCode.ag"(line 564, column 32) - _lhsOerrors = - _altsIerrors - -- copy rule (down) - _altsOallPragmas = - _lhsIallPragmas - -- copy rule (down) - _altsOerrors = - _lhsIerrors - -- copy rule (down) - _altsOo_case = - _lhsIo_case - -- copy rule (down) - _altsOo_cata = - _lhsIo_cata - -- copy rule (down) - _altsOo_costcentre = - _lhsIo_costcentre - -- copy rule (down) - _altsOo_data = - _lhsIo_data - -- copy rule (down) - _altsOo_linePragmas = - _lhsIo_linePragmas - -- copy rule (down) - _altsOo_newtypes = - _lhsIo_newtypes - -- copy rule (down) - _altsOo_pretty = - _lhsIo_pretty - -- copy rule (down) - _altsOo_rename = - _lhsIo_rename - -- copy rule (down) - _altsOo_sem = - _lhsIo_sem - -- copy rule (down) - _altsOo_sig = - _lhsIo_sig - -- copy rule (down) - _altsOo_splitsems = - _lhsIo_splitsems - -- copy rule (down) - _altsOo_strictwrap = - _lhsIo_strictwrap - -- copy rule (down) - _altsOo_traces = - _lhsIo_traces - -- copy rule (down) - _altsOo_unbox = - _lhsIo_unbox - -- copy rule (down) - _altsOprefix = - _lhsIprefix - -- copy rule (down) - _altsOwith_sig = - _lhsIwith_sig - -- copy rule (down) - _interOo_case = - _lhsIo_case - -- copy rule (down) - _interOo_cata = - _lhsIo_cata - -- copy rule (down) - _interOo_costcentre = - _lhsIo_costcentre - -- copy rule (down) - _interOo_data = - _lhsIo_data - -- copy rule (down) - _interOo_linePragmas = - _lhsIo_linePragmas - -- copy rule (down) - _interOo_newtypes = - _lhsIo_newtypes - -- copy rule (down) - _interOo_pretty = - _lhsIo_pretty - -- copy rule (down) - _interOo_rename = - _lhsIo_rename - -- copy rule (down) - _interOo_sem = - _lhsIo_sem - -- copy rule (down) - _interOo_sig = - _lhsIo_sig - -- copy rule (down) - _interOo_splitsems = - _lhsIo_splitsems - -- copy rule (down) - _interOo_strictwrap = - _lhsIo_strictwrap - -- copy rule (down) - _interOo_traces = - _lhsIo_traces - -- copy rule (down) - _interOo_unbox = - _lhsIo_unbox - -- copy rule (down) - _interOprefix = - _lhsIprefix - ( _altsIallTpsFound,_altsIcataAlts,_altsIcomments,_altsIdataAlts,_altsIdecls,_altsIerrors,_altsIsemNames) = - (alts_ _altsOallPragmas _altsOerrors _altsOinh _altsOnt _altsOo_case _altsOo_cata _altsOo_costcentre _altsOo_data _altsOo_linePragmas _altsOo_newtypes _altsOo_pretty _altsOo_rename _altsOo_sem _altsOo_sig _altsOo_splitsems _altsOo_strictwrap _altsOo_traces _altsOo_unbox _altsOprefix _altsOsyn _altsOwith_sig ) - ( _interIcomments,_interIsemDom,_interIwrapDecls) = - (inter_ _interOinh _interOnt _interOo_case _interOo_cata _interOo_costcentre _interOo_data _interOo_linePragmas _interOo_newtypes _interOo_pretty _interOo_rename _interOo_sem _interOo_sig _interOo_splitsems _interOo_strictwrap _interOo_traces _interOo_unbox _interOprefix _interOsyn ) - in ( _lhsOallTpsFound,_lhsOchunks,_lhsOerrors))) ) --- CProductions ------------------------------------------------ -{- - visit 0: - inherited attributes: - allPragmas : PragmaMap - derivings : Derivings - o_case : Bool - o_cata : Bool - o_costcentre : Bool - o_data : Maybe Bool - o_linePragmas : Bool - o_newtypes : Bool - o_pretty : Bool - o_rename : Bool - o_sem : Bool - o_sig : Bool - o_splitsems : Bool - o_strictwrap : Bool - o_traces : Bool - o_unbox : Bool - prefix : String - typeSyns : TypeSyns - with_sig : Bool - wrappers : Set Nonterminal - chained attribute: - errors : Seq Error - synthesized attributes: - allTpsFound : Bool - chunks : Chunks - alternatives: - alternative Cons: - child hd : CProduction - child tl : CProductions - alternative Nil: --} --- cata -sem_CProductions :: CProductions -> - T_CProductions -sem_CProductions list = - (Prelude.foldr sem_CProductions_Cons sem_CProductions_Nil (Prelude.map sem_CProduction list) ) --- semantic domain -newtype T_CProductions = T_CProductions (PragmaMap -> - Derivings -> - (Seq Error) -> - Bool -> - Bool -> - Bool -> - (Maybe Bool) -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - String -> - TypeSyns -> - Bool -> - (Set Nonterminal) -> - ( Bool,Chunks,(Seq Error))) -data Inh_CProductions = Inh_CProductions {allPragmas_Inh_CProductions :: PragmaMap,derivings_Inh_CProductions :: Derivings,errors_Inh_CProductions :: Seq Error,o_case_Inh_CProductions :: Bool,o_cata_Inh_CProductions :: Bool,o_costcentre_Inh_CProductions :: Bool,o_data_Inh_CProductions :: Maybe Bool,o_linePragmas_Inh_CProductions :: Bool,o_newtypes_Inh_CProductions :: Bool,o_pretty_Inh_CProductions :: Bool,o_rename_Inh_CProductions :: Bool,o_sem_Inh_CProductions :: Bool,o_sig_Inh_CProductions :: Bool,o_splitsems_Inh_CProductions :: Bool,o_strictwrap_Inh_CProductions :: Bool,o_traces_Inh_CProductions :: Bool,o_unbox_Inh_CProductions :: Bool,prefix_Inh_CProductions :: String,typeSyns_Inh_CProductions :: TypeSyns,with_sig_Inh_CProductions :: Bool,wrappers_Inh_CProductions :: Set Nonterminal} -data Syn_CProductions = Syn_CProductions {allTpsFound_Syn_CProductions :: Bool,chunks_Syn_CProductions :: Chunks,errors_Syn_CProductions :: Seq Error} -wrap_CProductions (T_CProductions sem ) (Inh_CProductions _lhsIallPragmas _lhsIderivings _lhsIerrors _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsItypeSyns _lhsIwith_sig _lhsIwrappers ) = - (let ( _lhsOallTpsFound,_lhsOchunks,_lhsOerrors) = - (sem _lhsIallPragmas _lhsIderivings _lhsIerrors _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsItypeSyns _lhsIwith_sig _lhsIwrappers ) - in (Syn_CProductions _lhsOallTpsFound _lhsOchunks _lhsOerrors )) -sem_CProductions_Cons :: T_CProduction -> - T_CProductions -> - T_CProductions -sem_CProductions_Cons (T_CProduction hd_ ) (T_CProductions tl_ ) = - (T_CProductions (\ _lhsIallPragmas - _lhsIderivings - _lhsIerrors - _lhsIo_case - _lhsIo_cata - _lhsIo_costcentre - _lhsIo_data - _lhsIo_linePragmas - _lhsIo_newtypes - _lhsIo_pretty - _lhsIo_rename - _lhsIo_sem - _lhsIo_sig - _lhsIo_splitsems - _lhsIo_strictwrap - _lhsIo_traces - _lhsIo_unbox - _lhsIprefix - _lhsItypeSyns - _lhsIwith_sig - _lhsIwrappers -> - (let _lhsOallTpsFound :: Bool - _lhsOchunks :: Chunks - _lhsOerrors :: (Seq Error) - _hdOallPragmas :: PragmaMap - _hdOderivings :: Derivings - _hdOerrors :: (Seq Error) - _hdOo_case :: Bool - _hdOo_cata :: Bool - _hdOo_costcentre :: Bool - _hdOo_data :: (Maybe Bool) - _hdOo_linePragmas :: Bool - _hdOo_newtypes :: Bool - _hdOo_pretty :: Bool - _hdOo_rename :: Bool - _hdOo_sem :: Bool - _hdOo_sig :: Bool - _hdOo_splitsems :: Bool - _hdOo_strictwrap :: Bool - _hdOo_traces :: Bool - _hdOo_unbox :: Bool - _hdOprefix :: String - _hdOtypeSyns :: TypeSyns - _hdOwith_sig :: Bool - _hdOwrappers :: (Set Nonterminal) - _tlOallPragmas :: PragmaMap - _tlOderivings :: Derivings - _tlOerrors :: (Seq Error) - _tlOo_case :: Bool - _tlOo_cata :: Bool - _tlOo_costcentre :: Bool - _tlOo_data :: (Maybe Bool) - _tlOo_linePragmas :: Bool - _tlOo_newtypes :: Bool - _tlOo_pretty :: Bool - _tlOo_rename :: Bool - _tlOo_sem :: Bool - _tlOo_sig :: Bool - _tlOo_splitsems :: Bool - _tlOo_strictwrap :: Bool - _tlOo_traces :: Bool - _tlOo_unbox :: Bool - _tlOprefix :: String - _tlOtypeSyns :: TypeSyns - _tlOwith_sig :: Bool - _tlOwrappers :: (Set Nonterminal) - _hdIallTpsFound :: Bool - _hdIchunks :: Chunks - _hdIerrors :: (Seq Error) - _tlIallTpsFound :: Bool - _tlIchunks :: Chunks - _tlIerrors :: (Seq Error) - -- use rule "GenerateCode.ag"(line 551, column 39) - _lhsOallTpsFound = - _hdIallTpsFound && _tlIallTpsFound - -- use rule "GenerateCode.ag"(line 625, column 47) - _lhsOchunks = - _hdIchunks ++ _tlIchunks - -- use rule "GenerateCode.ag"(line 564, column 32) - _lhsOerrors = - _hdIerrors Seq.<> _tlIerrors - -- copy rule (down) - _hdOallPragmas = - _lhsIallPragmas - -- copy rule (down) - _hdOderivings = - _lhsIderivings - -- copy rule (down) - _hdOerrors = - _lhsIerrors - -- copy rule (down) - _hdOo_case = - _lhsIo_case - -- copy rule (down) - _hdOo_cata = - _lhsIo_cata - -- copy rule (down) - _hdOo_costcentre = - _lhsIo_costcentre - -- copy rule (down) - _hdOo_data = - _lhsIo_data - -- copy rule (down) - _hdOo_linePragmas = - _lhsIo_linePragmas - -- copy rule (down) - _hdOo_newtypes = - _lhsIo_newtypes - -- copy rule (down) - _hdOo_pretty = - _lhsIo_pretty - -- copy rule (down) - _hdOo_rename = - _lhsIo_rename - -- copy rule (down) - _hdOo_sem = - _lhsIo_sem - -- copy rule (down) - _hdOo_sig = - _lhsIo_sig - -- copy rule (down) - _hdOo_splitsems = - _lhsIo_splitsems - -- copy rule (down) - _hdOo_strictwrap = - _lhsIo_strictwrap - -- copy rule (down) - _hdOo_traces = - _lhsIo_traces - -- copy rule (down) - _hdOo_unbox = - _lhsIo_unbox - -- copy rule (down) - _hdOprefix = - _lhsIprefix - -- copy rule (down) - _hdOtypeSyns = - _lhsItypeSyns - -- copy rule (down) - _hdOwith_sig = - _lhsIwith_sig - -- copy rule (down) - _hdOwrappers = - _lhsIwrappers - -- copy rule (down) - _tlOallPragmas = - _lhsIallPragmas - -- copy rule (down) - _tlOderivings = - _lhsIderivings - -- copy rule (chain) - _tlOerrors = - _hdIerrors - -- copy rule (down) - _tlOo_case = - _lhsIo_case - -- copy rule (down) - _tlOo_cata = - _lhsIo_cata - -- copy rule (down) - _tlOo_costcentre = - _lhsIo_costcentre - -- copy rule (down) - _tlOo_data = - _lhsIo_data - -- copy rule (down) - _tlOo_linePragmas = - _lhsIo_linePragmas - -- copy rule (down) - _tlOo_newtypes = - _lhsIo_newtypes - -- copy rule (down) - _tlOo_pretty = - _lhsIo_pretty - -- copy rule (down) - _tlOo_rename = - _lhsIo_rename - -- copy rule (down) - _tlOo_sem = - _lhsIo_sem - -- copy rule (down) - _tlOo_sig = - _lhsIo_sig - -- copy rule (down) - _tlOo_splitsems = - _lhsIo_splitsems - -- copy rule (down) - _tlOo_strictwrap = - _lhsIo_strictwrap - -- copy rule (down) - _tlOo_traces = - _lhsIo_traces - -- copy rule (down) - _tlOo_unbox = - _lhsIo_unbox - -- copy rule (down) - _tlOprefix = - _lhsIprefix - -- copy rule (down) - _tlOtypeSyns = - _lhsItypeSyns - -- copy rule (down) - _tlOwith_sig = - _lhsIwith_sig - -- copy rule (down) - _tlOwrappers = - _lhsIwrappers - ( _hdIallTpsFound,_hdIchunks,_hdIerrors) = - (hd_ _hdOallPragmas _hdOderivings _hdOerrors _hdOo_case _hdOo_cata _hdOo_costcentre _hdOo_data _hdOo_linePragmas _hdOo_newtypes _hdOo_pretty _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_splitsems _hdOo_strictwrap _hdOo_traces _hdOo_unbox _hdOprefix _hdOtypeSyns _hdOwith_sig _hdOwrappers ) - ( _tlIallTpsFound,_tlIchunks,_tlIerrors) = - (tl_ _tlOallPragmas _tlOderivings _tlOerrors _tlOo_case _tlOo_cata _tlOo_costcentre _tlOo_data _tlOo_linePragmas _tlOo_newtypes _tlOo_pretty _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_splitsems _tlOo_strictwrap _tlOo_traces _tlOo_unbox _tlOprefix _tlOtypeSyns _tlOwith_sig _tlOwrappers ) - in ( _lhsOallTpsFound,_lhsOchunks,_lhsOerrors))) ) -sem_CProductions_Nil :: T_CProductions -sem_CProductions_Nil = - (T_CProductions (\ _lhsIallPragmas - _lhsIderivings - _lhsIerrors - _lhsIo_case - _lhsIo_cata - _lhsIo_costcentre - _lhsIo_data - _lhsIo_linePragmas - _lhsIo_newtypes - _lhsIo_pretty - _lhsIo_rename - _lhsIo_sem - _lhsIo_sig - _lhsIo_splitsems - _lhsIo_strictwrap - _lhsIo_traces - _lhsIo_unbox - _lhsIprefix - _lhsItypeSyns - _lhsIwith_sig - _lhsIwrappers -> - (let _lhsOallTpsFound :: Bool - _lhsOchunks :: Chunks - _lhsOerrors :: (Seq Error) - -- use rule "GenerateCode.ag"(line 551, column 39) - _lhsOallTpsFound = - True - -- use rule "GenerateCode.ag"(line 625, column 47) - _lhsOchunks = - [] - -- use rule "GenerateCode.ag"(line 564, column 32) - _lhsOerrors = - Seq.empty - in ( _lhsOallTpsFound,_lhsOchunks,_lhsOerrors))) ) --- CRule ------------------------------------------------------- -{- - visit 0: - inherited attributes: - children : [(Name,Type,Bool)] - con : Constructor - higherOrderChildren : [(Name,Type,Bool)] - inh : Attributes - instVisitNrs : Map Identifier Int - nr : Int - nt : Nonterminal - o_case : Bool - o_cata : Bool - o_costcentre : Bool - o_data : Maybe Bool - o_linePragmas : Bool - o_newtypes : Bool - o_pretty : Bool - o_rename : Bool - o_sem : Bool - o_sig : Bool - o_splitsems : Bool - o_strictwrap : Bool - o_traces : Bool - o_unbox : Bool - prefix : String - syn : Attributes - terminals : [Name] - what : String - chained attributes: - declsAbove : [Decl] - errors : Seq Error - synthesized attributes: - allTpsFound : Bool - bldBlocksFun : DeclBlocks -> DeclBlocks - comments : [String] - decls : Decls - definedInsts : [Identifier] - exprs : Exprs - tSigs : [Decl] - tps : [Type] - usedVars : Set String - alternatives: - alternative CChildVisit: - child name : {Name} - child nt : {Nonterminal} - child nr : {Int} - child inh : {Attributes} - child syn : {Attributes} - child isLast : {Bool} - visit 0: - local costCentreDescr : _ - local addCostCentre : _ - local decls : _ - local isSuperfluousHigherOrderIntra : _ - local names : _ - local mkTp : _ - local definedTps : _ - local nextTp : _ - alternative CRule: - child name : {Name} - child isIn : {Bool} - child hasCode : {Bool} - child nt : {Nonterminal} - child con : {Constructor} - child field : {Name} - child childnt : {Maybe Nonterminal} - child tp : {Maybe Type} - child pattern : Pattern - child rhs : {[String]} - child defines : {Map Int (Name,Name,Maybe Type)} - child owrt : {Bool} - child origin : {String} - child uses : {Set (Name, Name)} - visit 0: - local instTypes : _ - local originComment : _ - local instDecls : _ - local patDescr : _ - local traceDescr : _ - local addTrace : _ - local costCentreDescr : _ - local addCostCentre : _ - local addLinePragma : _ - local decls : _ - local definedInsts : _ - local name : _ - local mkTp : _ - local _tup3 : {([Type],Bool)} --} --- cata -sem_CRule :: CRule -> - T_CRule -sem_CRule (CChildVisit _name _nt _nr _inh _syn _isLast ) = - (sem_CRule_CChildVisit _name _nt _nr _inh _syn _isLast ) -sem_CRule (CRule _name _isIn _hasCode _nt _con _field _childnt _tp _pattern _rhs _defines _owrt _origin _uses ) = - (sem_CRule_CRule _name _isIn _hasCode _nt _con _field _childnt _tp (sem_Pattern _pattern ) _rhs _defines _owrt _origin _uses ) --- semantic domain -newtype T_CRule = T_CRule (([(Name,Type,Bool)]) -> - Constructor -> - ([Decl]) -> - (Seq Error) -> - ([(Name,Type,Bool)]) -> - Attributes -> - (Map Identifier Int) -> - Int -> - Nonterminal -> - Bool -> - Bool -> - Bool -> - (Maybe Bool) -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - String -> - Attributes -> - ([Name]) -> - String -> - ( Bool,(DeclBlocks -> DeclBlocks),([String]),Decls,([Decl]),([Identifier]),(Seq Error),Exprs,([Decl]),([Type]),(Set String))) -data Inh_CRule = Inh_CRule {children_Inh_CRule :: [(Name,Type,Bool)],con_Inh_CRule :: Constructor,declsAbove_Inh_CRule :: [Decl],errors_Inh_CRule :: Seq Error,higherOrderChildren_Inh_CRule :: [(Name,Type,Bool)],inh_Inh_CRule :: Attributes,instVisitNrs_Inh_CRule :: Map Identifier Int,nr_Inh_CRule :: Int,nt_Inh_CRule :: Nonterminal,o_case_Inh_CRule :: Bool,o_cata_Inh_CRule :: Bool,o_costcentre_Inh_CRule :: Bool,o_data_Inh_CRule :: Maybe Bool,o_linePragmas_Inh_CRule :: Bool,o_newtypes_Inh_CRule :: Bool,o_pretty_Inh_CRule :: Bool,o_rename_Inh_CRule :: Bool,o_sem_Inh_CRule :: Bool,o_sig_Inh_CRule :: Bool,o_splitsems_Inh_CRule :: Bool,o_strictwrap_Inh_CRule :: Bool,o_traces_Inh_CRule :: Bool,o_unbox_Inh_CRule :: Bool,prefix_Inh_CRule :: String,syn_Inh_CRule :: Attributes,terminals_Inh_CRule :: [Name],what_Inh_CRule :: String} -data Syn_CRule = Syn_CRule {allTpsFound_Syn_CRule :: Bool,bldBlocksFun_Syn_CRule :: DeclBlocks -> DeclBlocks,comments_Syn_CRule :: [String],decls_Syn_CRule :: Decls,declsAbove_Syn_CRule :: [Decl],definedInsts_Syn_CRule :: [Identifier],errors_Syn_CRule :: Seq Error,exprs_Syn_CRule :: Exprs,tSigs_Syn_CRule :: [Decl],tps_Syn_CRule :: [Type],usedVars_Syn_CRule :: Set String} -wrap_CRule (T_CRule sem ) (Inh_CRule _lhsIchildren _lhsIcon _lhsIdeclsAbove _lhsIerrors _lhsIhigherOrderChildren _lhsIinh _lhsIinstVisitNrs _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn _lhsIterminals _lhsIwhat ) = - (let ( _lhsOallTpsFound,_lhsObldBlocksFun,_lhsOcomments,_lhsOdecls,_lhsOdeclsAbove,_lhsOdefinedInsts,_lhsOerrors,_lhsOexprs,_lhsOtSigs,_lhsOtps,_lhsOusedVars) = - (sem _lhsIchildren _lhsIcon _lhsIdeclsAbove _lhsIerrors _lhsIhigherOrderChildren _lhsIinh _lhsIinstVisitNrs _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn _lhsIterminals _lhsIwhat ) - in (Syn_CRule _lhsOallTpsFound _lhsObldBlocksFun _lhsOcomments _lhsOdecls _lhsOdeclsAbove _lhsOdefinedInsts _lhsOerrors _lhsOexprs _lhsOtSigs _lhsOtps _lhsOusedVars )) -sem_CRule_CChildVisit :: Name -> - Nonterminal -> - Int -> - Attributes -> - Attributes -> - Bool -> - T_CRule -sem_CRule_CChildVisit name_ nt_ nr_ inh_ syn_ isLast_ = - (T_CRule (\ _lhsIchildren - _lhsIcon - _lhsIdeclsAbove - _lhsIerrors - _lhsIhigherOrderChildren - _lhsIinh - _lhsIinstVisitNrs - _lhsInr - _lhsInt - _lhsIo_case - _lhsIo_cata - _lhsIo_costcentre - _lhsIo_data - _lhsIo_linePragmas - _lhsIo_newtypes - _lhsIo_pretty - _lhsIo_rename - _lhsIo_sem - _lhsIo_sig - _lhsIo_splitsems - _lhsIo_strictwrap - _lhsIo_traces - _lhsIo_unbox - _lhsIprefix - _lhsIsyn - _lhsIterminals - _lhsIwhat -> - (let _lhsOexprs :: Exprs - _lhsOusedVars :: (Set String) - _lhsOtSigs :: ([Decl]) - _lhsOtps :: ([Type]) - _lhsOdeclsAbove :: ([Decl]) - _lhsObldBlocksFun :: (DeclBlocks -> DeclBlocks) - _lhsOallTpsFound :: Bool - _lhsOcomments :: ([String]) - _lhsOdecls :: Decls - _lhsOdefinedInsts :: ([Identifier]) - _lhsOerrors :: (Seq Error) - -- "GenerateCode.ag"(line 126, column 18) - _costCentreDescr = - show _lhsInt ++ ":" ++ show _lhsIcon ++ ":" ++ show name_ ++ ":" ++ show nt_ ++ ":" ++ show nr_ - -- "GenerateCode.ag"(line 127, column 18) - _addCostCentre = - \v -> if _lhsIo_costcentre - then PragmaExpr True False ("SCC \"" ++ _costCentreDescr ++ "\"") v - else v - -- "GenerateCode.ag"(line 130, column 18) - _decls = - let lhsVars = map (attrname True name_) (Map.keys syn_) - ++ if isLast_ then [] else [unwrap ++ funname name_ (nr_+1)] - rhsVars = map (attrname False name_) (Map.keys inh_) - unwrap = if _lhsIo_newtypes then typeName nt_ (nr_ + 1) ++ " " else "" - tuple = mkTupleLhs _lhsIo_unbox (null $ Map.keys inh_) lhsVars - rhs = _addCostCentre $ App (funname name_ nr_) (map SimpleExpr rhsVars) - in [Decl tuple rhs (Set.fromList lhsVars) (Set.fromList (funname name_ nr_ : rhsVars))] - -- "GenerateCode.ag"(line 206, column 7) - _isSuperfluousHigherOrderIntra = - _lhsInr <= Map.findWithDefault (-1) name_ _lhsIinstVisitNrs - -- "GenerateCode.ag"(line 220, column 8) - _names = - if _isSuperfluousHigherOrderIntra - then [] - else [funname name_ (nr_+1)] - -- "GenerateCode.ag"(line 224, column 8) - _lhsOexprs = - let wrap = if _lhsIo_newtypes then \x -> App (typeName nt_ (nr_ + 1)) [x] else id - in map (wrap . SimpleExpr) _names - -- "GenerateCode.ag"(line 232, column 7) - _lhsOusedVars = - Set.fromList _names - -- "GenerateCode.ag"(line 243, column 19) - _mkTp = - SimpleType . typeToString nt_ - -- "GenerateCode.ag"(line 244, column 19) - _definedTps = - [ TSig (attrname True name_ a) (_mkTp tp) | (a,tp) <- Map.toList syn_ ] - -- "GenerateCode.ag"(line 245, column 19) - _nextTp = - typeName nt_ (nr_+1) - -- "GenerateCode.ag"(line 246, column 19) - _lhsOtSigs = - (if isLast_ then id else (TSig (funname name_ (nr_+1)) (SimpleType _nextTp) :)) _definedTps - -- "GenerateCode.ag"(line 268, column 19) - _lhsOtps = - if _isSuperfluousHigherOrderIntra - then [] - else [Haskell _nextTp] - -- "GenerateCode.ag"(line 371, column 7) - _lhsOdeclsAbove = - [] - -- "GenerateCode.ag"(line 384, column 7) - _lhsObldBlocksFun = - DeclBlock _lhsIdeclsAbove (head _decls ) - -- use rule "GenerateCode.ag"(line 265, column 39) - _lhsOallTpsFound = - True - -- use rule "GenerateCode.ag"(line 583, column 52) - _lhsOcomments = - [] - -- use rule "GenerateCode.ag"(line 87, column 34) - _lhsOdecls = - _decls - -- use rule "GenerateCode.ag"(line 140, column 55) - _lhsOdefinedInsts = - [] - -- use rule "GenerateCode.ag"(line 564, column 32) - _lhsOerrors = - Seq.empty - in ( _lhsOallTpsFound,_lhsObldBlocksFun,_lhsOcomments,_lhsOdecls,_lhsOdeclsAbove,_lhsOdefinedInsts,_lhsOerrors,_lhsOexprs,_lhsOtSigs,_lhsOtps,_lhsOusedVars))) ) -sem_CRule_CRule :: Name -> - Bool -> - Bool -> - Nonterminal -> - Constructor -> - Name -> - (Maybe Nonterminal) -> - (Maybe Type) -> - T_Pattern -> - ([String]) -> - (Map Int (Name,Name,Maybe Type)) -> - Bool -> - String -> - (Set (Name, Name)) -> - T_CRule -sem_CRule_CRule name_ isIn_ hasCode_ nt_ con_ field_ childnt_ tp_ (T_Pattern pattern_ ) rhs_ defines_ owrt_ origin_ uses_ = - (T_CRule (\ _lhsIchildren - _lhsIcon - _lhsIdeclsAbove - _lhsIerrors - _lhsIhigherOrderChildren - _lhsIinh - _lhsIinstVisitNrs - _lhsInr - _lhsInt - _lhsIo_case - _lhsIo_cata - _lhsIo_costcentre - _lhsIo_data - _lhsIo_linePragmas - _lhsIo_newtypes - _lhsIo_pretty - _lhsIo_rename - _lhsIo_sem - _lhsIo_sig - _lhsIo_splitsems - _lhsIo_strictwrap - _lhsIo_traces - _lhsIo_unbox - _lhsIprefix - _lhsIsyn - _lhsIterminals - _lhsIwhat -> - (let _lhsOexprs :: Exprs - _lhsOusedVars :: (Set String) - _lhsOtSigs :: ([Decl]) - __tup3 :: (([Type],Bool)) - _lhsOtps :: ([Type]) - _lhsOallTpsFound :: Bool - _lhsOdeclsAbove :: ([Decl]) - _lhsObldBlocksFun :: (DeclBlocks -> DeclBlocks) - _lhsOerrors :: (Seq Error) - _lhsOcomments :: ([String]) - _lhsOdecls :: Decls - _lhsOdefinedInsts :: ([Identifier]) - _patternIcopy :: Pattern - _patternIdefinedInsts :: ([Identifier]) - _patternIpatternAttributes :: ([(Name, Name)]) - -- "GenerateCode.ag"(line 89, column 12) - _instTypes = - map (\(n,NT t,_) -> (n,t)) _lhsIhigherOrderChildren - -- "GenerateCode.ag"(line 90, column 12) - _originComment = - if _lhsIo_pretty - then (Comment origin_:) - else id - -- "GenerateCode.ag"(line 93, column 12) - _instDecls = - [ Decl (Pattern3 (Alias _INST' inst (Underscore (getPos inst)) [])) - (App (cataname _lhsIprefix (fromJust $ inst `lookup` _instTypes )) - [SimpleExpr instLocFieldName]) - (Set.singleton instSemFieldName) - (Set.singleton instLocFieldName) - | inst <- _definedInsts - , let instLocFieldName = attrname True _INST inst - , let instSemFieldName = attrname False _INST' inst ] - -- "GenerateCode.ag"(line 101, column 12) - _patDescr = - if isIn_ - then "_" - else concat $ intersperse "," (map (\(f,a) -> show f ++ "." ++ show a) _patternIpatternAttributes) - -- "GenerateCode.ag"(line 104, column 12) - _traceDescr = - show nt_ ++ " :: " ++ show con_ ++ " :: " ++ _patDescr - -- "GenerateCode.ag"(line 106, column 12) - _addTrace = - \v -> if _lhsIo_traces - then Trace _traceDescr v - else v - -- "GenerateCode.ag"(line 109, column 12) - _costCentreDescr = - show nt_ ++ ":" ++ show con_ ++ ":" ++ _patDescr - -- "GenerateCode.ag"(line 110, column 12) - _addCostCentre = - \v -> if _lhsIo_costcentre - then PragmaExpr True False ("SCC \"" ++ _costCentreDescr ++ "\"") v - else v - -- "GenerateCode.ag"(line 113, column 12) - _addLinePragma = - \v -> let p = getPos name_ - hasPos = line p > 0 && column p >= 0 && not (null (file p)) - in if _lhsIo_linePragmas && hasPos - then PragmaExpr True True ("LINE " ++ show (line p) ++ " " ++ show (file p)) - $ LineExpr - $ v - else v - -- "GenerateCode.ag"(line 120, column 12) - _decls = - if hasCode_ - then _originComment ( Decl (Pattern3 _patternIcopy) (_addTrace $ _addCostCentre $ _addLinePragma $ (TextExpr rhs_)) - (Set.fromList [attrname False fld nm | (fld,nm,_) <- Map.elems defines_]) - (Set.fromList [attrname True fld nm | (fld,nm) <- Set.toList uses_]) - : _instDecls ) - else _instDecls - -- "GenerateCode.ag"(line 145, column 12) - _definedInsts = - if isIn_ then [] else _patternIdefinedInsts - -- "GenerateCode.ag"(line 215, column 12) - _name = - if field_ == _LOC && name_ `elem` _lhsIterminals - then funname name_ 0 - else attrname isIn_ field_ name_ - -- "GenerateCode.ag"(line 218, column 12) - _lhsOexprs = - [SimpleExpr _name ] - -- "GenerateCode.ag"(line 230, column 7) - _lhsOusedVars = - Set.singleton _name - -- "GenerateCode.ag"(line 240, column 19) - _mkTp = - SimpleType . typeToString _lhsInt - -- "GenerateCode.ag"(line 241, column 19) - _lhsOtSigs = - [ TSig (attrname False field attr) (_mkTp (fromJust tp)) - | (field,attr,tp) <- Map.elems defines_, isJust tp ] - -- "GenerateCode.ag"(line 267, column 23) - __tup3 = - maybe ([],False) (\tp -> ([substSelf (fromJust childnt_) tp],True)) tp_ - -- "GenerateCode.ag"(line 267, column 23) - (_lhsOtps,_) = - __tup3 - -- "GenerateCode.ag"(line 267, column 23) - (_,_lhsOallTpsFound) = - __tup3 - -- "GenerateCode.ag"(line 369, column 7) - _lhsOdeclsAbove = - _lhsIdeclsAbove ++ _decls - -- "GenerateCode.ag"(line 382, column 7) - _lhsObldBlocksFun = - id - -- "GenerateCode.ag"(line 570, column 12) - _lhsOerrors = - let nameOf (Alias _ _ _ pats@(_:_)) = Ident (show (map (\(Alias _ a _ _)->a) pats)) (getPos name_) - nameOf _ = name_ - in maybe (Seq.single (MissingTypeSig _lhsInt _lhsIcon (nameOf _patternIcopy))) (const Seq.empty) tp_ - -- "GenerateCode.ag"(line 610, column 18) - _lhsOcomments = - [ makeLocalComment 11 _lhsIwhat name tp | (field,name,tp) <- Map.elems defines_, field == _LOC ] - ++ [ makeLocalComment 11 "inst " name tp | (field,name,tp) <- Map.elems defines_, field == _INST ] - -- use rule "GenerateCode.ag"(line 87, column 34) - _lhsOdecls = - _decls - -- use rule "GenerateCode.ag"(line 140, column 55) - _lhsOdefinedInsts = - _definedInsts - ( _patternIcopy,_patternIdefinedInsts,_patternIpatternAttributes) = - (pattern_ ) - in ( _lhsOallTpsFound,_lhsObldBlocksFun,_lhsOcomments,_lhsOdecls,_lhsOdeclsAbove,_lhsOdefinedInsts,_lhsOerrors,_lhsOexprs,_lhsOtSigs,_lhsOtps,_lhsOusedVars))) ) --- CSegment ---------------------------------------------------- -{- - visit 0: - inherited attributes: - inh : Attributes - isLast : Bool - nr : Int - nt : Nonterminal - o_case : Bool - o_cata : Bool - o_costcentre : Bool - o_data : Maybe Bool - o_linePragmas : Bool - o_newtypes : Bool - o_pretty : Bool - o_rename : Bool - o_sem : Bool - o_sig : Bool - o_splitsems : Bool - o_strictwrap : Bool - o_traces : Bool - o_unbox : Bool - prefix : String - syn : Attributes - synthesized attributes: - comments : [String] - semDom : [Decl] - wrapDecls : Decls - alternatives: - alternative CSegment: - child inh : {Attributes} - child syn : {Attributes} --} --- cata -sem_CSegment :: CSegment -> - T_CSegment -sem_CSegment (CSegment _inh _syn ) = - (sem_CSegment_CSegment _inh _syn ) --- semantic domain -newtype T_CSegment = T_CSegment (Attributes -> - Bool -> - Int -> - Nonterminal -> - Bool -> - Bool -> - Bool -> - (Maybe Bool) -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - String -> - Attributes -> - ( ([String]),([Decl]),Decls)) -data Inh_CSegment = Inh_CSegment {inh_Inh_CSegment :: Attributes,isLast_Inh_CSegment :: Bool,nr_Inh_CSegment :: Int,nt_Inh_CSegment :: Nonterminal,o_case_Inh_CSegment :: Bool,o_cata_Inh_CSegment :: Bool,o_costcentre_Inh_CSegment :: Bool,o_data_Inh_CSegment :: Maybe Bool,o_linePragmas_Inh_CSegment :: Bool,o_newtypes_Inh_CSegment :: Bool,o_pretty_Inh_CSegment :: Bool,o_rename_Inh_CSegment :: Bool,o_sem_Inh_CSegment :: Bool,o_sig_Inh_CSegment :: Bool,o_splitsems_Inh_CSegment :: Bool,o_strictwrap_Inh_CSegment :: Bool,o_traces_Inh_CSegment :: Bool,o_unbox_Inh_CSegment :: Bool,prefix_Inh_CSegment :: String,syn_Inh_CSegment :: Attributes} -data Syn_CSegment = Syn_CSegment {comments_Syn_CSegment :: [String],semDom_Syn_CSegment :: [Decl],wrapDecls_Syn_CSegment :: Decls} -wrap_CSegment (T_CSegment sem ) (Inh_CSegment _lhsIinh _lhsIisLast _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn ) = - (let ( _lhsOcomments,_lhsOsemDom,_lhsOwrapDecls) = - (sem _lhsIinh _lhsIisLast _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn ) - in (Syn_CSegment _lhsOcomments _lhsOsemDom _lhsOwrapDecls )) -sem_CSegment_CSegment :: Attributes -> - Attributes -> - T_CSegment -sem_CSegment_CSegment inh_ syn_ = - (T_CSegment (\ _lhsIinh - _lhsIisLast - _lhsInr - _lhsInt - _lhsIo_case - _lhsIo_cata - _lhsIo_costcentre - _lhsIo_data - _lhsIo_linePragmas - _lhsIo_newtypes - _lhsIo_pretty - _lhsIo_rename - _lhsIo_sem - _lhsIo_sig - _lhsIo_splitsems - _lhsIo_strictwrap - _lhsIo_traces - _lhsIo_unbox - _lhsIprefix - _lhsIsyn -> - (let _lhsOsemDom :: ([Decl]) - _lhsOwrapDecls :: Decls - _lhsOcomments :: ([String]) - -- "GenerateCode.ag"(line 496, column 15) - _lhsOsemDom = - let name = typeName _lhsInt _lhsInr - tp = foldr Arr synTps inhTps - inhTps = [SimpleType (typeToString _lhsInt tp) | tp <- Map.elems inh_] - synTps = mkTupleType _lhsIo_unbox (null inhTps) ([SimpleType (typeToString _lhsInt tp) | tp <- Map.elems syn_] ++ continuation) - continuation = if _lhsIisLast - then [] - else [SimpleType (typeName _lhsInt (_lhsInr + 1))] - in if _lhsIo_newtypes - then [ Code.NewType name name tp ] - else [ Code.Type name tp ] - -- "GenerateCode.ag"(line 534, column 15) - _lhsOwrapDecls = - let lhsVars = map (lhsname False) (Map.keys syn_) - ++ if _lhsIisLast then [] else [unwrap ++ sem (_lhsInr+1)] - rhsVars = map (lhsname True) (Map.keys inh_) - rhs = map SimpleExpr rhsVars - unwrap = if _lhsIo_newtypes then typeName _lhsInt (_lhsInr + 1) ++ " " else "" - var = "sem" - sem 0 = var - sem n = var ++ "_" ++ show n - in [ Decl (mkTupleLhs _lhsIo_unbox (null $ Map.keys inh_) lhsVars) (App (sem _lhsInr) rhs) (Set.fromList lhsVars) (Set.fromList rhsVars) ] - -- "GenerateCode.ag"(line 588, column 18) - _lhsOcomments = - let body = map ind (showsSegment (CSegment inh_ syn_)) - in if null body - then [] - else ("visit " ++ show _lhsInr ++ ":") : body - in ( _lhsOcomments,_lhsOsemDom,_lhsOwrapDecls))) ) --- CSegments --------------------------------------------------- -{- - visit 0: - inherited attributes: - inh : Attributes - nr : Int - nt : Nonterminal - o_case : Bool - o_cata : Bool - o_costcentre : Bool - o_data : Maybe Bool - o_linePragmas : Bool - o_newtypes : Bool - o_pretty : Bool - o_rename : Bool - o_sem : Bool - o_sig : Bool - o_splitsems : Bool - o_strictwrap : Bool - o_traces : Bool - o_unbox : Bool - prefix : String - syn : Attributes - synthesized attributes: - comments : [String] - isNil : Bool - semDom : [Decl] - wrapDecls : Decls - alternatives: - alternative Cons: - child hd : CSegment - child tl : CSegments - alternative Nil: --} --- cata -sem_CSegments :: CSegments -> - T_CSegments -sem_CSegments list = - (Prelude.foldr sem_CSegments_Cons sem_CSegments_Nil (Prelude.map sem_CSegment list) ) --- semantic domain -newtype T_CSegments = T_CSegments (Attributes -> - Int -> - Nonterminal -> - Bool -> - Bool -> - Bool -> - (Maybe Bool) -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - String -> - Attributes -> - ( ([String]),Bool,([Decl]),Decls)) -data Inh_CSegments = Inh_CSegments {inh_Inh_CSegments :: Attributes,nr_Inh_CSegments :: Int,nt_Inh_CSegments :: Nonterminal,o_case_Inh_CSegments :: Bool,o_cata_Inh_CSegments :: Bool,o_costcentre_Inh_CSegments :: Bool,o_data_Inh_CSegments :: Maybe Bool,o_linePragmas_Inh_CSegments :: Bool,o_newtypes_Inh_CSegments :: Bool,o_pretty_Inh_CSegments :: Bool,o_rename_Inh_CSegments :: Bool,o_sem_Inh_CSegments :: Bool,o_sig_Inh_CSegments :: Bool,o_splitsems_Inh_CSegments :: Bool,o_strictwrap_Inh_CSegments :: Bool,o_traces_Inh_CSegments :: Bool,o_unbox_Inh_CSegments :: Bool,prefix_Inh_CSegments :: String,syn_Inh_CSegments :: Attributes} -data Syn_CSegments = Syn_CSegments {comments_Syn_CSegments :: [String],isNil_Syn_CSegments :: Bool,semDom_Syn_CSegments :: [Decl],wrapDecls_Syn_CSegments :: Decls} -wrap_CSegments (T_CSegments sem ) (Inh_CSegments _lhsIinh _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn ) = - (let ( _lhsOcomments,_lhsOisNil,_lhsOsemDom,_lhsOwrapDecls) = - (sem _lhsIinh _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn ) - in (Syn_CSegments _lhsOcomments _lhsOisNil _lhsOsemDom _lhsOwrapDecls )) -sem_CSegments_Cons :: T_CSegment -> - T_CSegments -> - T_CSegments -sem_CSegments_Cons (T_CSegment hd_ ) (T_CSegments tl_ ) = - (T_CSegments (\ _lhsIinh - _lhsInr - _lhsInt - _lhsIo_case - _lhsIo_cata - _lhsIo_costcentre - _lhsIo_data - _lhsIo_linePragmas - _lhsIo_newtypes - _lhsIo_pretty - _lhsIo_rename - _lhsIo_sem - _lhsIo_sig - _lhsIo_splitsems - _lhsIo_strictwrap - _lhsIo_traces - _lhsIo_unbox - _lhsIprefix - _lhsIsyn -> - (let _tlOnr :: Int - _lhsOisNil :: Bool - _hdOisLast :: Bool - _lhsOcomments :: ([String]) - _lhsOsemDom :: ([Decl]) - _lhsOwrapDecls :: Decls - _hdOinh :: Attributes - _hdOnr :: Int - _hdOnt :: Nonterminal - _hdOo_case :: Bool - _hdOo_cata :: Bool - _hdOo_costcentre :: Bool - _hdOo_data :: (Maybe Bool) - _hdOo_linePragmas :: Bool - _hdOo_newtypes :: Bool - _hdOo_pretty :: Bool - _hdOo_rename :: Bool - _hdOo_sem :: Bool - _hdOo_sig :: Bool - _hdOo_splitsems :: Bool - _hdOo_strictwrap :: Bool - _hdOo_traces :: Bool - _hdOo_unbox :: Bool - _hdOprefix :: String - _hdOsyn :: Attributes - _tlOinh :: Attributes - _tlOnt :: Nonterminal - _tlOo_case :: Bool - _tlOo_cata :: Bool - _tlOo_costcentre :: Bool - _tlOo_data :: (Maybe Bool) - _tlOo_linePragmas :: Bool - _tlOo_newtypes :: Bool - _tlOo_pretty :: Bool - _tlOo_rename :: Bool - _tlOo_sem :: Bool - _tlOo_sig :: Bool - _tlOo_splitsems :: Bool - _tlOo_strictwrap :: Bool - _tlOo_traces :: Bool - _tlOo_unbox :: Bool - _tlOprefix :: String - _tlOsyn :: Attributes - _hdIcomments :: ([String]) - _hdIsemDom :: ([Decl]) - _hdIwrapDecls :: Decls - _tlIcomments :: ([String]) - _tlIisNil :: Bool - _tlIsemDom :: ([Decl]) - _tlIwrapDecls :: Decls - -- "GenerateCode.ag"(line 165, column 11) - _tlOnr = - _lhsInr + 1 - -- "GenerateCode.ag"(line 178, column 12) - _lhsOisNil = - False - -- "GenerateCode.ag"(line 179, column 12) - _hdOisLast = - _tlIisNil - -- use rule "GenerateCode.ag"(line 583, column 52) - _lhsOcomments = - _hdIcomments ++ _tlIcomments - -- use rule "GenerateCode.ag"(line 491, column 50) - _lhsOsemDom = - _hdIsemDom ++ _tlIsemDom - -- use rule "GenerateCode.ag"(line 532, column 52) - _lhsOwrapDecls = - _hdIwrapDecls ++ _tlIwrapDecls - -- copy rule (down) - _hdOinh = - _lhsIinh - -- copy rule (down) - _hdOnr = - _lhsInr - -- copy rule (down) - _hdOnt = - _lhsInt - -- copy rule (down) - _hdOo_case = - _lhsIo_case - -- copy rule (down) - _hdOo_cata = - _lhsIo_cata - -- copy rule (down) - _hdOo_costcentre = - _lhsIo_costcentre - -- copy rule (down) - _hdOo_data = - _lhsIo_data - -- copy rule (down) - _hdOo_linePragmas = - _lhsIo_linePragmas - -- copy rule (down) - _hdOo_newtypes = - _lhsIo_newtypes - -- copy rule (down) - _hdOo_pretty = - _lhsIo_pretty - -- copy rule (down) - _hdOo_rename = - _lhsIo_rename - -- copy rule (down) - _hdOo_sem = - _lhsIo_sem - -- copy rule (down) - _hdOo_sig = - _lhsIo_sig - -- copy rule (down) - _hdOo_splitsems = - _lhsIo_splitsems - -- copy rule (down) - _hdOo_strictwrap = - _lhsIo_strictwrap - -- copy rule (down) - _hdOo_traces = - _lhsIo_traces - -- copy rule (down) - _hdOo_unbox = - _lhsIo_unbox - -- copy rule (down) - _hdOprefix = - _lhsIprefix - -- copy rule (down) - _hdOsyn = - _lhsIsyn - -- copy rule (down) - _tlOinh = - _lhsIinh - -- copy rule (down) - _tlOnt = - _lhsInt - -- copy rule (down) - _tlOo_case = - _lhsIo_case - -- copy rule (down) - _tlOo_cata = - _lhsIo_cata - -- copy rule (down) - _tlOo_costcentre = - _lhsIo_costcentre - -- copy rule (down) - _tlOo_data = - _lhsIo_data - -- copy rule (down) - _tlOo_linePragmas = - _lhsIo_linePragmas - -- copy rule (down) - _tlOo_newtypes = - _lhsIo_newtypes - -- copy rule (down) - _tlOo_pretty = - _lhsIo_pretty - -- copy rule (down) - _tlOo_rename = - _lhsIo_rename - -- copy rule (down) - _tlOo_sem = - _lhsIo_sem - -- copy rule (down) - _tlOo_sig = - _lhsIo_sig - -- copy rule (down) - _tlOo_splitsems = - _lhsIo_splitsems - -- copy rule (down) - _tlOo_strictwrap = - _lhsIo_strictwrap - -- copy rule (down) - _tlOo_traces = - _lhsIo_traces - -- copy rule (down) - _tlOo_unbox = - _lhsIo_unbox - -- copy rule (down) - _tlOprefix = - _lhsIprefix - -- copy rule (down) - _tlOsyn = - _lhsIsyn - ( _hdIcomments,_hdIsemDom,_hdIwrapDecls) = - (hd_ _hdOinh _hdOisLast _hdOnr _hdOnt _hdOo_case _hdOo_cata _hdOo_costcentre _hdOo_data _hdOo_linePragmas _hdOo_newtypes _hdOo_pretty _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_splitsems _hdOo_strictwrap _hdOo_traces _hdOo_unbox _hdOprefix _hdOsyn ) - ( _tlIcomments,_tlIisNil,_tlIsemDom,_tlIwrapDecls) = - (tl_ _tlOinh _tlOnr _tlOnt _tlOo_case _tlOo_cata _tlOo_costcentre _tlOo_data _tlOo_linePragmas _tlOo_newtypes _tlOo_pretty _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_splitsems _tlOo_strictwrap _tlOo_traces _tlOo_unbox _tlOprefix _tlOsyn ) - in ( _lhsOcomments,_lhsOisNil,_lhsOsemDom,_lhsOwrapDecls))) ) -sem_CSegments_Nil :: T_CSegments -sem_CSegments_Nil = - (T_CSegments (\ _lhsIinh - _lhsInr - _lhsInt - _lhsIo_case - _lhsIo_cata - _lhsIo_costcentre - _lhsIo_data - _lhsIo_linePragmas - _lhsIo_newtypes - _lhsIo_pretty - _lhsIo_rename - _lhsIo_sem - _lhsIo_sig - _lhsIo_splitsems - _lhsIo_strictwrap - _lhsIo_traces - _lhsIo_unbox - _lhsIprefix - _lhsIsyn -> - (let _lhsOisNil :: Bool - _lhsOcomments :: ([String]) - _lhsOsemDom :: ([Decl]) - _lhsOwrapDecls :: Decls - -- "GenerateCode.ag"(line 180, column 10) - _lhsOisNil = - True - -- use rule "GenerateCode.ag"(line 583, column 52) - _lhsOcomments = - [] - -- use rule "GenerateCode.ag"(line 491, column 50) - _lhsOsemDom = - [] - -- use rule "GenerateCode.ag"(line 532, column 52) - _lhsOwrapDecls = - [] - in ( _lhsOcomments,_lhsOisNil,_lhsOsemDom,_lhsOwrapDecls))) ) --- CVisit ------------------------------------------------------ -{- - visit 0: - inherited attributes: - allPragmas : PragmaMap - children : [(Name,Type,Bool)] - con : Constructor - inh : Attributes - instVisitNrs : Map Identifier Int - isLast : Bool - nextIntra : Exprs - nextIntraVars : Set String - nr : Int - nt : Nonterminal - o_case : Bool - o_cata : Bool - o_costcentre : Bool - o_data : Maybe Bool - o_linePragmas : Bool - o_newtypes : Bool - o_pretty : Bool - o_rename : Bool - o_sem : Bool - o_sig : Bool - o_splitsems : Bool - o_strictwrap : Bool - o_traces : Bool - o_unbox : Bool - prefix : String - syn : Attributes - terminals : [Name] - with_sig : Bool - chained attribute: - errors : Seq Error - synthesized attributes: - allTpsFound : Bool - comments : [String] - decls : Decls - gatherInstVisitNrs : Map Identifier Int - intra : Exprs - intraVars : Set String - semNames : [String] - alternatives: - alternative CVisit: - child inh : {Attributes} - child syn : {Attributes} - child vss : Sequence - child intra : Sequence - child ordered : {Bool} - visit 0: - local _tup4 : _ - local higherOrderChildren : _ - local firstOrderChildren : _ - local funcname : _ - local nextVisitName : _ - local nextVisitDecl : _ - local decls : _ - local lastExprVars : _ - local _tup5 : _ - local blockFunDecls : _ - local blockFirstFunCall : _ - local costCentreDescr : _ - local addCostCentre : _ - local semFun : _ - local tsig : _ - local semType : _ - local typeSigs : _ - local o_case : _ - local o_splitsems : _ --} --- cata -sem_CVisit :: CVisit -> - T_CVisit -sem_CVisit (CVisit _inh _syn _vss _intra _ordered ) = - (sem_CVisit_CVisit _inh _syn (sem_Sequence _vss ) (sem_Sequence _intra ) _ordered ) --- semantic domain -newtype T_CVisit = T_CVisit (PragmaMap -> - ([(Name,Type,Bool)]) -> - Constructor -> - (Seq Error) -> - Attributes -> - (Map Identifier Int) -> - Bool -> - Exprs -> - (Set String) -> - Int -> - Nonterminal -> - Bool -> - Bool -> - Bool -> - (Maybe Bool) -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - String -> - Attributes -> - ([Name]) -> - Bool -> - ( Bool,([String]),Decls,(Seq Error),(Map Identifier Int),Exprs,(Set String),([String]))) -data Inh_CVisit = Inh_CVisit {allPragmas_Inh_CVisit :: PragmaMap,children_Inh_CVisit :: [(Name,Type,Bool)],con_Inh_CVisit :: Constructor,errors_Inh_CVisit :: Seq Error,inh_Inh_CVisit :: Attributes,instVisitNrs_Inh_CVisit :: Map Identifier Int,isLast_Inh_CVisit :: Bool,nextIntra_Inh_CVisit :: Exprs,nextIntraVars_Inh_CVisit :: Set String,nr_Inh_CVisit :: Int,nt_Inh_CVisit :: Nonterminal,o_case_Inh_CVisit :: Bool,o_cata_Inh_CVisit :: Bool,o_costcentre_Inh_CVisit :: Bool,o_data_Inh_CVisit :: Maybe Bool,o_linePragmas_Inh_CVisit :: Bool,o_newtypes_Inh_CVisit :: Bool,o_pretty_Inh_CVisit :: Bool,o_rename_Inh_CVisit :: Bool,o_sem_Inh_CVisit :: Bool,o_sig_Inh_CVisit :: Bool,o_splitsems_Inh_CVisit :: Bool,o_strictwrap_Inh_CVisit :: Bool,o_traces_Inh_CVisit :: Bool,o_unbox_Inh_CVisit :: Bool,prefix_Inh_CVisit :: String,syn_Inh_CVisit :: Attributes,terminals_Inh_CVisit :: [Name],with_sig_Inh_CVisit :: Bool} -data Syn_CVisit = Syn_CVisit {allTpsFound_Syn_CVisit :: Bool,comments_Syn_CVisit :: [String],decls_Syn_CVisit :: Decls,errors_Syn_CVisit :: Seq Error,gatherInstVisitNrs_Syn_CVisit :: Map Identifier Int,intra_Syn_CVisit :: Exprs,intraVars_Syn_CVisit :: Set String,semNames_Syn_CVisit :: [String]} -wrap_CVisit (T_CVisit sem ) (Inh_CVisit _lhsIallPragmas _lhsIchildren _lhsIcon _lhsIerrors _lhsIinh _lhsIinstVisitNrs _lhsIisLast _lhsInextIntra _lhsInextIntraVars _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn _lhsIterminals _lhsIwith_sig ) = - (let ( _lhsOallTpsFound,_lhsOcomments,_lhsOdecls,_lhsOerrors,_lhsOgatherInstVisitNrs,_lhsOintra,_lhsOintraVars,_lhsOsemNames) = - (sem _lhsIallPragmas _lhsIchildren _lhsIcon _lhsIerrors _lhsIinh _lhsIinstVisitNrs _lhsIisLast _lhsInextIntra _lhsInextIntraVars _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn _lhsIterminals _lhsIwith_sig ) - in (Syn_CVisit _lhsOallTpsFound _lhsOcomments _lhsOdecls _lhsOerrors _lhsOgatherInstVisitNrs _lhsOintra _lhsOintraVars _lhsOsemNames )) -sem_CVisit_CVisit :: Attributes -> - Attributes -> - T_Sequence -> - T_Sequence -> - Bool -> - T_CVisit -sem_CVisit_CVisit inh_ syn_ (T_Sequence vss_ ) (T_Sequence intra_ ) ordered_ = - (T_CVisit (\ _lhsIallPragmas - _lhsIchildren - _lhsIcon - _lhsIerrors - _lhsIinh - _lhsIinstVisitNrs - _lhsIisLast - _lhsInextIntra - _lhsInextIntraVars - _lhsInr - _lhsInt - _lhsIo_case - _lhsIo_cata - _lhsIo_costcentre - _lhsIo_data - _lhsIo_linePragmas - _lhsIo_newtypes - _lhsIo_pretty - _lhsIo_rename - _lhsIo_sem - _lhsIo_sig - _lhsIo_splitsems - _lhsIo_strictwrap - _lhsIo_traces - _lhsIo_unbox - _lhsIprefix - _lhsIsyn - _lhsIterminals - _lhsIwith_sig -> - (let _lhsOintra :: Exprs - _lhsOintraVars :: (Set String) - _vssOlastExpr :: Expr - _intraOlastExpr :: Expr - _lhsOdecls :: Decls - _lhsOgatherInstVisitNrs :: (Map Identifier Int) - _vssOdeclsAbove :: ([Decl]) - _intraOdeclsAbove :: ([Decl]) - _lhsOallTpsFound :: Bool - _lhsOerrors :: (Seq Error) - _lhsOcomments :: ([String]) - _vssOwhat :: String - _intraOwhat :: String - _lhsOsemNames :: ([String]) - _vssOchildren :: ([(Name,Type,Bool)]) - _vssOcon :: Constructor - _vssOerrors :: (Seq Error) - _vssOhigherOrderChildren :: ([(Name,Type,Bool)]) - _vssOinh :: Attributes - _vssOinstVisitNrs :: (Map Identifier Int) - _vssOnr :: Int - _vssOnt :: Nonterminal - _vssOo_case :: Bool - _vssOo_cata :: Bool - _vssOo_costcentre :: Bool - _vssOo_data :: (Maybe Bool) - _vssOo_linePragmas :: Bool - _vssOo_newtypes :: Bool - _vssOo_pretty :: Bool - _vssOo_rename :: Bool - _vssOo_sem :: Bool - _vssOo_sig :: Bool - _vssOo_splitsems :: Bool - _vssOo_strictwrap :: Bool - _vssOo_traces :: Bool - _vssOo_unbox :: Bool - _vssOprefix :: String - _vssOsyn :: Attributes - _vssOterminals :: ([Name]) - _intraOchildren :: ([(Name,Type,Bool)]) - _intraOcon :: Constructor - _intraOerrors :: (Seq Error) - _intraOhigherOrderChildren :: ([(Name,Type,Bool)]) - _intraOinh :: Attributes - _intraOinstVisitNrs :: (Map Identifier Int) - _intraOnr :: Int - _intraOnt :: Nonterminal - _intraOo_case :: Bool - _intraOo_cata :: Bool - _intraOo_costcentre :: Bool - _intraOo_data :: (Maybe Bool) - _intraOo_linePragmas :: Bool - _intraOo_newtypes :: Bool - _intraOo_pretty :: Bool - _intraOo_rename :: Bool - _intraOo_sem :: Bool - _intraOo_sig :: Bool - _intraOo_splitsems :: Bool - _intraOo_strictwrap :: Bool - _intraOo_traces :: Bool - _intraOo_unbox :: Bool - _intraOprefix :: String - _intraOsyn :: Attributes - _intraOterminals :: ([Name]) - _vssIallTpsFound :: Bool - _vssIblockDecls :: DeclBlocks - _vssIcomments :: ([String]) - _vssIdecls :: Decls - _vssIdeclsAbove :: ([Decl]) - _vssIdefinedInsts :: ([Identifier]) - _vssIerrors :: (Seq Error) - _vssIexprs :: Exprs - _vssItSigs :: ([Decl]) - _vssItps :: ([Type]) - _vssIusedVars :: (Set String) - _intraIallTpsFound :: Bool - _intraIblockDecls :: DeclBlocks - _intraIcomments :: ([String]) - _intraIdecls :: Decls - _intraIdeclsAbove :: ([Decl]) - _intraIdefinedInsts :: ([Identifier]) - _intraIerrors :: (Seq Error) - _intraIexprs :: Exprs - _intraItSigs :: ([Decl]) - _intraItps :: ([Type]) - _intraIusedVars :: (Set String) - -- "GenerateCode.ag"(line 189, column 13) - _lhsOintra = - _intraIexprs - -- "GenerateCode.ag"(line 190, column 13) - _lhsOintraVars = - _intraIusedVars - -- "GenerateCode.ag"(line 278, column 13) - __tup4 = - partition (\(_,_,ho) -> ho) _lhsIchildren - -- "GenerateCode.ag"(line 278, column 13) - (_higherOrderChildren,_) = - __tup4 - -- "GenerateCode.ag"(line 278, column 13) - (_,_firstOrderChildren) = - __tup4 - -- "GenerateCode.ag"(line 279, column 13) - _funcname = - seqSemname _lhsIprefix _lhsInt _lhsIcon _lhsInr - -- "GenerateCode.ag"(line 280, column 13) - _nextVisitName = - if _lhsIisLast then [] else [visitname _lhsIprefix _lhsInt (_lhsInr+1)] - -- "GenerateCode.ag"(line 281, column 13) - _nextVisitDecl = - let lhs = TupleLhs _nextVisitName - rhs = App fun _lhsInextIntra - fun = seqSemname _lhsIprefix _lhsInt _lhsIcon (_lhsInr+1) - in if _lhsIisLast - then [] - else [Decl lhs rhs (Set.fromList _nextVisitName) _lhsInextIntraVars] - -- "GenerateCode.ag"(line 287, column 13) - _decls = - _typeSigs ++ _vssIdecls ++ _nextVisitDecl - -- "GenerateCode.ag"(line 288, column 13) - _vssOlastExpr = - mkTupleExpr _lhsIo_unbox (null $ Map.keys inh_) $ map (SimpleExpr . lhsname False) (Map.keys syn_) ++ map SimpleExpr _nextVisitName - -- "GenerateCode.ag"(line 289, column 13) - _intraOlastExpr = - error "lastExpr: not used here" - -- "GenerateCode.ag"(line 290, column 13) - _lastExprVars = - map (lhsname False) (Map.keys syn_) ++ _nextVisitName - -- "GenerateCode.ag"(line 291, column 13) - __tup5 = - mkPartitionedFunction _funcname _o_case _nextVisitDecl _lastExprVars _vssIblockDecls - -- "GenerateCode.ag"(line 291, column 13) - (_blockFunDecls,_) = - __tup5 - -- "GenerateCode.ag"(line 291, column 13) - (_,_blockFirstFunCall) = - __tup5 - -- "GenerateCode.ag"(line 293, column 13) - _costCentreDescr = - "b" ++ ":" ++ show _lhsInt ++ ":" ++ show _lhsIcon ++ ":" ++ show _lhsInr - -- "GenerateCode.ag"(line 294, column 13) - _addCostCentre = - \v -> if _lhsIo_costcentre - then PragmaExpr True False ("SCC \"" ++ _costCentreDescr ++ "\"") v - else v - -- "GenerateCode.ag"(line 298, column 13) - _semFun = - let lhs = Fun _funcname lhs_args - lhs_args = if _lhsInr == 0 then map field _firstOrderChildren else _intraIexprs - field (name,NT tp,_) = let unwrap | _lhsIo_newtypes = \x -> App (sdtype tp) [x] - | otherwise = id - in unwrap (SimpleExpr (funname name 0)) - field (name,_,_) = SimpleExpr (funname name 0) - rhs = wrap - . mkLambda (map (lhsname True) (Map.keys inh_)) - $ _addCostCentre - $ if ordered_ && _o_splitsems - then _blockFirstFunCall - else mkLet _o_case _decls - . mkTupleExpr _lhsIo_unbox (null $ Map.keys inh_) - $ map (SimpleExpr . lhsname False) (Map.keys syn_) ++ map SimpleExpr _nextVisitName - wrap = if _lhsIo_newtypes - then \x -> App (typeName _lhsInt _lhsInr) [x] - else id - in Decl lhs rhs Set.empty Set.empty - -- "GenerateCode.ag"(line 319, column 13) - _tsig = - TSig _funcname _semType - -- "GenerateCode.ag"(line 320, column 13) - _semType = - let argType (NT tp) rec | tp /= _SELF = SimpleType (sdtype tp) `Arr` rec - | tp == _SELF = error "GenerateCode: found an intra-type with type SELF, which should have been prevented by CRule.tps" - argType (Haskell tp) rec = SimpleType tp `Arr` rec - in if _lhsInr == 0 - then foldr argType (SimpleType (sdtype _lhsInt )) (map (\(_,t,_) -> t) _firstOrderChildren ) - else foldr argType (SimpleType (typeName _lhsInt _lhsInr)) _intraItps - -- "GenerateCode.ag"(line 326, column 13) - _lhsOdecls = - ( if _lhsIwith_sig - then [_tsig, _semFun] - else [_semFun] - ) ++ - ( if ordered_ && _o_splitsems - then _blockFunDecls - else [] - ) - -- "GenerateCode.ag"(line 334, column 13) - _typeSigs = - if _lhsIo_sig && not _o_case - then _vssItSigs - else [] - -- "GenerateCode.ag"(line 337, column 13) - _o_case = - _lhsIo_case && ordered_ && not (hasPragma _lhsIallPragmas _lhsInt _lhsIcon _NOCASE) - -- "GenerateCode.ag"(line 338, column 13) - _o_splitsems = - ordered_ && _lhsIo_splitsems - -- "GenerateCode.ag"(line 353, column 7) - _lhsOgatherInstVisitNrs = - Map.fromList [(i,_lhsInr) | i <- _vssIdefinedInsts] - -- "GenerateCode.ag"(line 364, column 7) - _vssOdeclsAbove = - [] - -- "GenerateCode.ag"(line 365, column 7) - _intraOdeclsAbove = - error "declsAbove: not used here" - -- "GenerateCode.ag"(line 557, column 13) - _lhsOallTpsFound = - _intraIallTpsFound - -- "GenerateCode.ag"(line 568, column 13) - _lhsOerrors = - _intraIerrors - -- "GenerateCode.ag"(line 601, column 18) - _lhsOcomments = - let body = map ind (_vssIcomments ++ _intraIcomments) - in if null body - then [] - else ("visit " ++ show _lhsInr ++ ":") : body - -- "GenerateCode.ag"(line 605, column 18) - _vssOwhat = - "local" - -- "GenerateCode.ag"(line 606, column 18) - _intraOwhat = - "intra" - -- "GenerateCode.ag"(line 784, column 7) - _lhsOsemNames = - [_funcname ] - -- copy rule (down) - _vssOchildren = - _lhsIchildren - -- copy rule (down) - _vssOcon = - _lhsIcon - -- copy rule (down) - _vssOerrors = - _lhsIerrors - -- copy rule (from local) - _vssOhigherOrderChildren = - _higherOrderChildren - -- copy rule (down) - _vssOinh = - _lhsIinh - -- copy rule (down) - _vssOinstVisitNrs = - _lhsIinstVisitNrs - -- copy rule (down) - _vssOnr = - _lhsInr - -- copy rule (down) - _vssOnt = - _lhsInt - -- copy rule (from local) - _vssOo_case = - _o_case - -- copy rule (down) - _vssOo_cata = - _lhsIo_cata - -- copy rule (down) - _vssOo_costcentre = - _lhsIo_costcentre - -- copy rule (down) - _vssOo_data = - _lhsIo_data - -- copy rule (down) - _vssOo_linePragmas = - _lhsIo_linePragmas - -- copy rule (down) - _vssOo_newtypes = - _lhsIo_newtypes - -- copy rule (down) - _vssOo_pretty = - _lhsIo_pretty - -- copy rule (down) - _vssOo_rename = - _lhsIo_rename - -- copy rule (down) - _vssOo_sem = - _lhsIo_sem - -- copy rule (down) - _vssOo_sig = - _lhsIo_sig - -- copy rule (from local) - _vssOo_splitsems = - _o_splitsems - -- copy rule (down) - _vssOo_strictwrap = - _lhsIo_strictwrap - -- copy rule (down) - _vssOo_traces = - _lhsIo_traces - -- copy rule (down) - _vssOo_unbox = - _lhsIo_unbox - -- copy rule (down) - _vssOprefix = - _lhsIprefix - -- copy rule (down) - _vssOsyn = - _lhsIsyn - -- copy rule (down) - _vssOterminals = - _lhsIterminals - -- copy rule (down) - _intraOchildren = - _lhsIchildren - -- copy rule (down) - _intraOcon = - _lhsIcon - -- copy rule (chain) - _intraOerrors = - _vssIerrors - -- copy rule (from local) - _intraOhigherOrderChildren = - _higherOrderChildren - -- copy rule (down) - _intraOinh = - _lhsIinh - -- copy rule (down) - _intraOinstVisitNrs = - _lhsIinstVisitNrs - -- copy rule (down) - _intraOnr = - _lhsInr - -- copy rule (down) - _intraOnt = - _lhsInt - -- copy rule (from local) - _intraOo_case = - _o_case - -- copy rule (down) - _intraOo_cata = - _lhsIo_cata - -- copy rule (down) - _intraOo_costcentre = - _lhsIo_costcentre - -- copy rule (down) - _intraOo_data = - _lhsIo_data - -- copy rule (down) - _intraOo_linePragmas = - _lhsIo_linePragmas - -- copy rule (down) - _intraOo_newtypes = - _lhsIo_newtypes - -- copy rule (down) - _intraOo_pretty = - _lhsIo_pretty - -- copy rule (down) - _intraOo_rename = - _lhsIo_rename - -- copy rule (down) - _intraOo_sem = - _lhsIo_sem - -- copy rule (down) - _intraOo_sig = - _lhsIo_sig - -- copy rule (from local) - _intraOo_splitsems = - _o_splitsems - -- copy rule (down) - _intraOo_strictwrap = - _lhsIo_strictwrap - -- copy rule (down) - _intraOo_traces = - _lhsIo_traces - -- copy rule (down) - _intraOo_unbox = - _lhsIo_unbox - -- copy rule (down) - _intraOprefix = - _lhsIprefix - -- copy rule (down) - _intraOsyn = - _lhsIsyn - -- copy rule (down) - _intraOterminals = - _lhsIterminals - ( _vssIallTpsFound,_vssIblockDecls,_vssIcomments,_vssIdecls,_vssIdeclsAbove,_vssIdefinedInsts,_vssIerrors,_vssIexprs,_vssItSigs,_vssItps,_vssIusedVars) = - (vss_ _vssOchildren _vssOcon _vssOdeclsAbove _vssOerrors _vssOhigherOrderChildren _vssOinh _vssOinstVisitNrs _vssOlastExpr _vssOnr _vssOnt _vssOo_case _vssOo_cata _vssOo_costcentre _vssOo_data _vssOo_linePragmas _vssOo_newtypes _vssOo_pretty _vssOo_rename _vssOo_sem _vssOo_sig _vssOo_splitsems _vssOo_strictwrap _vssOo_traces _vssOo_unbox _vssOprefix _vssOsyn _vssOterminals _vssOwhat ) - ( _intraIallTpsFound,_intraIblockDecls,_intraIcomments,_intraIdecls,_intraIdeclsAbove,_intraIdefinedInsts,_intraIerrors,_intraIexprs,_intraItSigs,_intraItps,_intraIusedVars) = - (intra_ _intraOchildren _intraOcon _intraOdeclsAbove _intraOerrors _intraOhigherOrderChildren _intraOinh _intraOinstVisitNrs _intraOlastExpr _intraOnr _intraOnt _intraOo_case _intraOo_cata _intraOo_costcentre _intraOo_data _intraOo_linePragmas _intraOo_newtypes _intraOo_pretty _intraOo_rename _intraOo_sem _intraOo_sig _intraOo_splitsems _intraOo_strictwrap _intraOo_traces _intraOo_unbox _intraOprefix _intraOsyn _intraOterminals _intraOwhat ) - in ( _lhsOallTpsFound,_lhsOcomments,_lhsOdecls,_lhsOerrors,_lhsOgatherInstVisitNrs,_lhsOintra,_lhsOintraVars,_lhsOsemNames))) ) --- CVisits ----------------------------------------------------- -{- - visit 0: - inherited attributes: - allPragmas : PragmaMap - children : [(Name,Type,Bool)] - con : Constructor - inh : Attributes - instVisitNrs : Map Identifier Int - nr : Int - nt : Nonterminal - o_case : Bool - o_cata : Bool - o_costcentre : Bool - o_data : Maybe Bool - o_linePragmas : Bool - o_newtypes : Bool - o_pretty : Bool - o_rename : Bool - o_sem : Bool - o_sig : Bool - o_splitsems : Bool - o_strictwrap : Bool - o_traces : Bool - o_unbox : Bool - prefix : String - syn : Attributes - terminals : [Name] - with_sig : Bool - chained attribute: - errors : Seq Error - synthesized attributes: - allTpsFound : Bool - comments : [String] - decls : Decls - gatherInstVisitNrs : Map Identifier Int - intra : Exprs - intraVars : Set String - isNil : Bool - semNames : [String] - alternatives: - alternative Cons: - child hd : CVisit - child tl : CVisits - alternative Nil: --} --- cata -sem_CVisits :: CVisits -> - T_CVisits -sem_CVisits list = - (Prelude.foldr sem_CVisits_Cons sem_CVisits_Nil (Prelude.map sem_CVisit list) ) --- semantic domain -newtype T_CVisits = T_CVisits (PragmaMap -> - ([(Name,Type,Bool)]) -> - Constructor -> - (Seq Error) -> - Attributes -> - (Map Identifier Int) -> - Int -> - Nonterminal -> - Bool -> - Bool -> - Bool -> - (Maybe Bool) -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - String -> - Attributes -> - ([Name]) -> - Bool -> - ( Bool,([String]),Decls,(Seq Error),(Map Identifier Int),Exprs,(Set String),Bool,([String]))) -data Inh_CVisits = Inh_CVisits {allPragmas_Inh_CVisits :: PragmaMap,children_Inh_CVisits :: [(Name,Type,Bool)],con_Inh_CVisits :: Constructor,errors_Inh_CVisits :: Seq Error,inh_Inh_CVisits :: Attributes,instVisitNrs_Inh_CVisits :: Map Identifier Int,nr_Inh_CVisits :: Int,nt_Inh_CVisits :: Nonterminal,o_case_Inh_CVisits :: Bool,o_cata_Inh_CVisits :: Bool,o_costcentre_Inh_CVisits :: Bool,o_data_Inh_CVisits :: Maybe Bool,o_linePragmas_Inh_CVisits :: Bool,o_newtypes_Inh_CVisits :: Bool,o_pretty_Inh_CVisits :: Bool,o_rename_Inh_CVisits :: Bool,o_sem_Inh_CVisits :: Bool,o_sig_Inh_CVisits :: Bool,o_splitsems_Inh_CVisits :: Bool,o_strictwrap_Inh_CVisits :: Bool,o_traces_Inh_CVisits :: Bool,o_unbox_Inh_CVisits :: Bool,prefix_Inh_CVisits :: String,syn_Inh_CVisits :: Attributes,terminals_Inh_CVisits :: [Name],with_sig_Inh_CVisits :: Bool} -data Syn_CVisits = Syn_CVisits {allTpsFound_Syn_CVisits :: Bool,comments_Syn_CVisits :: [String],decls_Syn_CVisits :: Decls,errors_Syn_CVisits :: Seq Error,gatherInstVisitNrs_Syn_CVisits :: Map Identifier Int,intra_Syn_CVisits :: Exprs,intraVars_Syn_CVisits :: Set String,isNil_Syn_CVisits :: Bool,semNames_Syn_CVisits :: [String]} -wrap_CVisits (T_CVisits sem ) (Inh_CVisits _lhsIallPragmas _lhsIchildren _lhsIcon _lhsIerrors _lhsIinh _lhsIinstVisitNrs _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn _lhsIterminals _lhsIwith_sig ) = - (let ( _lhsOallTpsFound,_lhsOcomments,_lhsOdecls,_lhsOerrors,_lhsOgatherInstVisitNrs,_lhsOintra,_lhsOintraVars,_lhsOisNil,_lhsOsemNames) = - (sem _lhsIallPragmas _lhsIchildren _lhsIcon _lhsIerrors _lhsIinh _lhsIinstVisitNrs _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn _lhsIterminals _lhsIwith_sig ) - in (Syn_CVisits _lhsOallTpsFound _lhsOcomments _lhsOdecls _lhsOerrors _lhsOgatherInstVisitNrs _lhsOintra _lhsOintraVars _lhsOisNil _lhsOsemNames )) -sem_CVisits_Cons :: T_CVisit -> - T_CVisits -> - T_CVisits -sem_CVisits_Cons (T_CVisit hd_ ) (T_CVisits tl_ ) = - (T_CVisits (\ _lhsIallPragmas - _lhsIchildren - _lhsIcon - _lhsIerrors - _lhsIinh - _lhsIinstVisitNrs - _lhsInr - _lhsInt - _lhsIo_case - _lhsIo_cata - _lhsIo_costcentre - _lhsIo_data - _lhsIo_linePragmas - _lhsIo_newtypes - _lhsIo_pretty - _lhsIo_rename - _lhsIo_sem - _lhsIo_sig - _lhsIo_splitsems - _lhsIo_strictwrap - _lhsIo_traces - _lhsIo_unbox - _lhsIprefix - _lhsIsyn - _lhsIterminals - _lhsIwith_sig -> - (let _tlOnr :: Int - _lhsOisNil :: Bool - _hdOisLast :: Bool - _hdOnextIntra :: Exprs - _hdOnextIntraVars :: (Set String) - _lhsOintra :: Exprs - _lhsOintraVars :: (Set String) - _lhsOallTpsFound :: Bool - _lhsOcomments :: ([String]) - _lhsOdecls :: Decls - _lhsOerrors :: (Seq Error) - _lhsOgatherInstVisitNrs :: (Map Identifier Int) - _lhsOsemNames :: ([String]) - _hdOallPragmas :: PragmaMap - _hdOchildren :: ([(Name,Type,Bool)]) - _hdOcon :: Constructor - _hdOerrors :: (Seq Error) - _hdOinh :: Attributes - _hdOinstVisitNrs :: (Map Identifier Int) - _hdOnr :: Int - _hdOnt :: Nonterminal - _hdOo_case :: Bool - _hdOo_cata :: Bool - _hdOo_costcentre :: Bool - _hdOo_data :: (Maybe Bool) - _hdOo_linePragmas :: Bool - _hdOo_newtypes :: Bool - _hdOo_pretty :: Bool - _hdOo_rename :: Bool - _hdOo_sem :: Bool - _hdOo_sig :: Bool - _hdOo_splitsems :: Bool - _hdOo_strictwrap :: Bool - _hdOo_traces :: Bool - _hdOo_unbox :: Bool - _hdOprefix :: String - _hdOsyn :: Attributes - _hdOterminals :: ([Name]) - _hdOwith_sig :: Bool - _tlOallPragmas :: PragmaMap - _tlOchildren :: ([(Name,Type,Bool)]) - _tlOcon :: Constructor - _tlOerrors :: (Seq Error) - _tlOinh :: Attributes - _tlOinstVisitNrs :: (Map Identifier Int) - _tlOnt :: Nonterminal - _tlOo_case :: Bool - _tlOo_cata :: Bool - _tlOo_costcentre :: Bool - _tlOo_data :: (Maybe Bool) - _tlOo_linePragmas :: Bool - _tlOo_newtypes :: Bool - _tlOo_pretty :: Bool - _tlOo_rename :: Bool - _tlOo_sem :: Bool - _tlOo_sig :: Bool - _tlOo_splitsems :: Bool - _tlOo_strictwrap :: Bool - _tlOo_traces :: Bool - _tlOo_unbox :: Bool - _tlOprefix :: String - _tlOsyn :: Attributes - _tlOterminals :: ([Name]) - _tlOwith_sig :: Bool - _hdIallTpsFound :: Bool - _hdIcomments :: ([String]) - _hdIdecls :: Decls - _hdIerrors :: (Seq Error) - _hdIgatherInstVisitNrs :: (Map Identifier Int) - _hdIintra :: Exprs - _hdIintraVars :: (Set String) - _hdIsemNames :: ([String]) - _tlIallTpsFound :: Bool - _tlIcomments :: ([String]) - _tlIdecls :: Decls - _tlIerrors :: (Seq Error) - _tlIgatherInstVisitNrs :: (Map Identifier Int) - _tlIintra :: Exprs - _tlIintraVars :: (Set String) - _tlIisNil :: Bool - _tlIsemNames :: ([String]) - -- "GenerateCode.ag"(line 161, column 11) - _tlOnr = - _lhsInr + 1 - -- "GenerateCode.ag"(line 174, column 12) - _lhsOisNil = - False - -- "GenerateCode.ag"(line 175, column 12) - _hdOisLast = - _tlIisNil - -- "GenerateCode.ag"(line 192, column 12) - _hdOnextIntra = - _tlIintra - -- "GenerateCode.ag"(line 193, column 12) - _hdOnextIntraVars = - _tlIintraVars - -- "GenerateCode.ag"(line 194, column 12) - _lhsOintra = - _hdIintra - -- "GenerateCode.ag"(line 195, column 12) - _lhsOintraVars = - _hdIintraVars - -- use rule "GenerateCode.ag"(line 551, column 39) - _lhsOallTpsFound = - _hdIallTpsFound && _tlIallTpsFound - -- use rule "GenerateCode.ag"(line 583, column 52) - _lhsOcomments = - _hdIcomments ++ _tlIcomments - -- use rule "GenerateCode.ag"(line 276, column 33) - _lhsOdecls = - _hdIdecls ++ _tlIdecls - -- use rule "GenerateCode.ag"(line 564, column 32) - _lhsOerrors = - _hdIerrors Seq.<> _tlIerrors - -- use rule "GenerateCode.ag"(line 346, column 44) - _lhsOgatherInstVisitNrs = - _hdIgatherInstVisitNrs `Map.union` _tlIgatherInstVisitNrs - -- use rule "GenerateCode.ag"(line 774, column 63) - _lhsOsemNames = - _hdIsemNames ++ _tlIsemNames - -- copy rule (down) - _hdOallPragmas = - _lhsIallPragmas - -- copy rule (down) - _hdOchildren = - _lhsIchildren - -- copy rule (down) - _hdOcon = - _lhsIcon - -- copy rule (down) - _hdOerrors = - _lhsIerrors - -- copy rule (down) - _hdOinh = - _lhsIinh - -- copy rule (down) - _hdOinstVisitNrs = - _lhsIinstVisitNrs - -- copy rule (down) - _hdOnr = - _lhsInr - -- copy rule (down) - _hdOnt = - _lhsInt - -- copy rule (down) - _hdOo_case = - _lhsIo_case - -- copy rule (down) - _hdOo_cata = - _lhsIo_cata - -- copy rule (down) - _hdOo_costcentre = - _lhsIo_costcentre - -- copy rule (down) - _hdOo_data = - _lhsIo_data - -- copy rule (down) - _hdOo_linePragmas = - _lhsIo_linePragmas - -- copy rule (down) - _hdOo_newtypes = - _lhsIo_newtypes - -- copy rule (down) - _hdOo_pretty = - _lhsIo_pretty - -- copy rule (down) - _hdOo_rename = - _lhsIo_rename - -- copy rule (down) - _hdOo_sem = - _lhsIo_sem - -- copy rule (down) - _hdOo_sig = - _lhsIo_sig - -- copy rule (down) - _hdOo_splitsems = - _lhsIo_splitsems - -- copy rule (down) - _hdOo_strictwrap = - _lhsIo_strictwrap - -- copy rule (down) - _hdOo_traces = - _lhsIo_traces - -- copy rule (down) - _hdOo_unbox = - _lhsIo_unbox - -- copy rule (down) - _hdOprefix = - _lhsIprefix - -- copy rule (down) - _hdOsyn = - _lhsIsyn - -- copy rule (down) - _hdOterminals = - _lhsIterminals - -- copy rule (down) - _hdOwith_sig = - _lhsIwith_sig - -- copy rule (down) - _tlOallPragmas = - _lhsIallPragmas - -- copy rule (down) - _tlOchildren = - _lhsIchildren - -- copy rule (down) - _tlOcon = - _lhsIcon - -- copy rule (chain) - _tlOerrors = - _hdIerrors - -- copy rule (down) - _tlOinh = - _lhsIinh - -- copy rule (down) - _tlOinstVisitNrs = - _lhsIinstVisitNrs - -- copy rule (down) - _tlOnt = - _lhsInt - -- copy rule (down) - _tlOo_case = - _lhsIo_case - -- copy rule (down) - _tlOo_cata = - _lhsIo_cata - -- copy rule (down) - _tlOo_costcentre = - _lhsIo_costcentre - -- copy rule (down) - _tlOo_data = - _lhsIo_data - -- copy rule (down) - _tlOo_linePragmas = - _lhsIo_linePragmas - -- copy rule (down) - _tlOo_newtypes = - _lhsIo_newtypes - -- copy rule (down) - _tlOo_pretty = - _lhsIo_pretty - -- copy rule (down) - _tlOo_rename = - _lhsIo_rename - -- copy rule (down) - _tlOo_sem = - _lhsIo_sem - -- copy rule (down) - _tlOo_sig = - _lhsIo_sig - -- copy rule (down) - _tlOo_splitsems = - _lhsIo_splitsems - -- copy rule (down) - _tlOo_strictwrap = - _lhsIo_strictwrap - -- copy rule (down) - _tlOo_traces = - _lhsIo_traces - -- copy rule (down) - _tlOo_unbox = - _lhsIo_unbox - -- copy rule (down) - _tlOprefix = - _lhsIprefix - -- copy rule (down) - _tlOsyn = - _lhsIsyn - -- copy rule (down) - _tlOterminals = - _lhsIterminals - -- copy rule (down) - _tlOwith_sig = - _lhsIwith_sig - ( _hdIallTpsFound,_hdIcomments,_hdIdecls,_hdIerrors,_hdIgatherInstVisitNrs,_hdIintra,_hdIintraVars,_hdIsemNames) = - (hd_ _hdOallPragmas _hdOchildren _hdOcon _hdOerrors _hdOinh _hdOinstVisitNrs _hdOisLast _hdOnextIntra _hdOnextIntraVars _hdOnr _hdOnt _hdOo_case _hdOo_cata _hdOo_costcentre _hdOo_data _hdOo_linePragmas _hdOo_newtypes _hdOo_pretty _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_splitsems _hdOo_strictwrap _hdOo_traces _hdOo_unbox _hdOprefix _hdOsyn _hdOterminals _hdOwith_sig ) - ( _tlIallTpsFound,_tlIcomments,_tlIdecls,_tlIerrors,_tlIgatherInstVisitNrs,_tlIintra,_tlIintraVars,_tlIisNil,_tlIsemNames) = - (tl_ _tlOallPragmas _tlOchildren _tlOcon _tlOerrors _tlOinh _tlOinstVisitNrs _tlOnr _tlOnt _tlOo_case _tlOo_cata _tlOo_costcentre _tlOo_data _tlOo_linePragmas _tlOo_newtypes _tlOo_pretty _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_splitsems _tlOo_strictwrap _tlOo_traces _tlOo_unbox _tlOprefix _tlOsyn _tlOterminals _tlOwith_sig ) - in ( _lhsOallTpsFound,_lhsOcomments,_lhsOdecls,_lhsOerrors,_lhsOgatherInstVisitNrs,_lhsOintra,_lhsOintraVars,_lhsOisNil,_lhsOsemNames))) ) -sem_CVisits_Nil :: T_CVisits -sem_CVisits_Nil = - (T_CVisits (\ _lhsIallPragmas - _lhsIchildren - _lhsIcon - _lhsIerrors - _lhsIinh - _lhsIinstVisitNrs - _lhsInr - _lhsInt - _lhsIo_case - _lhsIo_cata - _lhsIo_costcentre - _lhsIo_data - _lhsIo_linePragmas - _lhsIo_newtypes - _lhsIo_pretty - _lhsIo_rename - _lhsIo_sem - _lhsIo_sig - _lhsIo_splitsems - _lhsIo_strictwrap - _lhsIo_traces - _lhsIo_unbox - _lhsIprefix - _lhsIsyn - _lhsIterminals - _lhsIwith_sig -> - (let _lhsOisNil :: Bool - _lhsOintra :: Exprs - _lhsOintraVars :: (Set String) - _lhsOallTpsFound :: Bool - _lhsOcomments :: ([String]) - _lhsOdecls :: Decls - _lhsOerrors :: (Seq Error) - _lhsOgatherInstVisitNrs :: (Map Identifier Int) - _lhsOsemNames :: ([String]) - -- "GenerateCode.ag"(line 176, column 10) - _lhsOisNil = - True - -- "GenerateCode.ag"(line 196, column 10) - _lhsOintra = - [] - -- "GenerateCode.ag"(line 197, column 10) - _lhsOintraVars = - Set.empty - -- use rule "GenerateCode.ag"(line 551, column 39) - _lhsOallTpsFound = - True - -- use rule "GenerateCode.ag"(line 583, column 52) - _lhsOcomments = - [] - -- use rule "GenerateCode.ag"(line 276, column 33) - _lhsOdecls = - [] - -- use rule "GenerateCode.ag"(line 564, column 32) - _lhsOerrors = - Seq.empty - -- use rule "GenerateCode.ag"(line 346, column 44) - _lhsOgatherInstVisitNrs = - Map.empty - -- use rule "GenerateCode.ag"(line 774, column 63) - _lhsOsemNames = - [] - in ( _lhsOallTpsFound,_lhsOcomments,_lhsOdecls,_lhsOerrors,_lhsOgatherInstVisitNrs,_lhsOintra,_lhsOintraVars,_lhsOisNil,_lhsOsemNames))) ) --- DeclBlocks -------------------------------------------------- -{- - visit 0: - inherited attributes: - blockNr : Int - lastExprVars : [String] - nextVisitDecls : [Decl] - optCase : Bool - prefix : String - synthesized attributes: - callExpr : Expr - decls : [Decl] - freeVars : [String] - alternatives: - alternative DeclBlock: - child defs : {[Decl]} - child visit : {Decl} - child next : DeclBlocks - visit 0: - local lambdaName : _ - local pragmaDecl : _ - local freeVars : _ - local decl : _ - alternative DeclTerminator: - child defs : {[Decl]} - child result : {Expr} - visit 0: - local lambdaName : _ - local pragmaDecl : _ - local freeVars : _ --} --- cata -sem_DeclBlocks :: DeclBlocks -> - T_DeclBlocks -sem_DeclBlocks (DeclBlock _defs _visit _next ) = - (sem_DeclBlocks_DeclBlock _defs _visit (sem_DeclBlocks _next ) ) -sem_DeclBlocks (DeclTerminator _defs _result ) = - (sem_DeclBlocks_DeclTerminator _defs _result ) --- semantic domain -newtype T_DeclBlocks = T_DeclBlocks (Int -> - ([String]) -> - ([Decl]) -> - Bool -> - String -> - ( Expr,([Decl]),([String]))) -data Inh_DeclBlocks = Inh_DeclBlocks {blockNr_Inh_DeclBlocks :: Int,lastExprVars_Inh_DeclBlocks :: [String],nextVisitDecls_Inh_DeclBlocks :: [Decl],optCase_Inh_DeclBlocks :: Bool,prefix_Inh_DeclBlocks :: String} -data Syn_DeclBlocks = Syn_DeclBlocks {callExpr_Syn_DeclBlocks :: Expr,decls_Syn_DeclBlocks :: [Decl],freeVars_Syn_DeclBlocks :: [String]} -wrap_DeclBlocks (T_DeclBlocks sem ) (Inh_DeclBlocks _lhsIblockNr _lhsIlastExprVars _lhsInextVisitDecls _lhsIoptCase _lhsIprefix ) = - (let ( _lhsOcallExpr,_lhsOdecls,_lhsOfreeVars) = - (sem _lhsIblockNr _lhsIlastExprVars _lhsInextVisitDecls _lhsIoptCase _lhsIprefix ) - in (Syn_DeclBlocks _lhsOcallExpr _lhsOdecls _lhsOfreeVars )) -sem_DeclBlocks_DeclBlock :: ([Decl]) -> - Decl -> - T_DeclBlocks -> - T_DeclBlocks -sem_DeclBlocks_DeclBlock defs_ visit_ (T_DeclBlocks next_ ) = - (T_DeclBlocks (\ _lhsIblockNr - _lhsIlastExprVars - _lhsInextVisitDecls - _lhsIoptCase - _lhsIprefix -> - (let _nextOblockNr :: Int - _lhsOcallExpr :: Expr - _lhsOdecls :: ([Decl]) - _lhsOfreeVars :: ([String]) - _nextOlastExprVars :: ([String]) - _nextOnextVisitDecls :: ([Decl]) - _nextOoptCase :: Bool - _nextOprefix :: String - _nextIcallExpr :: Expr - _nextIdecls :: ([Decl]) - _nextIfreeVars :: ([String]) - -- "GenerateCode.ag"(line 443, column 7) - _nextOblockNr = - _lhsIblockNr + 1 - -- "GenerateCode.ag"(line 448, column 7) - _lambdaName = - _lhsIprefix ++ "_block" ++ show _lhsIblockNr - -- "GenerateCode.ag"(line 449, column 7) - _pragmaDecl = - PragmaDecl ("NOINLINE " ++ _lambdaName ) - -- "GenerateCode.ag"(line 450, column 7) - _lhsOcallExpr = - App _lambdaName (map SimpleExpr _freeVars ) - -- "GenerateCode.ag"(line 454, column 7) - _freeVars = - freevars _nextIfreeVars (visit_ : defs_) - -- "GenerateCode.ag"(line 461, column 7) - _decl = - mkBlockLambda _lhsIoptCase _lambdaName _freeVars (defs_ ++ [visit_]) _nextIcallExpr - -- "GenerateCode.ag"(line 462, column 7) - _lhsOdecls = - (if _lhsIblockNr > 1 then [_pragmaDecl ] else []) ++ [_decl ] ++ _nextIdecls - -- copy rule (from local) - _lhsOfreeVars = - _freeVars - -- copy rule (down) - _nextOlastExprVars = - _lhsIlastExprVars - -- copy rule (down) - _nextOnextVisitDecls = - _lhsInextVisitDecls - -- copy rule (down) - _nextOoptCase = - _lhsIoptCase - -- copy rule (down) - _nextOprefix = - _lhsIprefix - ( _nextIcallExpr,_nextIdecls,_nextIfreeVars) = - (next_ _nextOblockNr _nextOlastExprVars _nextOnextVisitDecls _nextOoptCase _nextOprefix ) - in ( _lhsOcallExpr,_lhsOdecls,_lhsOfreeVars))) ) -sem_DeclBlocks_DeclTerminator :: ([Decl]) -> - Expr -> - T_DeclBlocks -sem_DeclBlocks_DeclTerminator defs_ result_ = - (T_DeclBlocks (\ _lhsIblockNr - _lhsIlastExprVars - _lhsInextVisitDecls - _lhsIoptCase - _lhsIprefix -> - (let _lhsOcallExpr :: Expr - _lhsOdecls :: ([Decl]) - _lhsOfreeVars :: ([String]) - -- "GenerateCode.ag"(line 448, column 7) - _lambdaName = - _lhsIprefix ++ "_block" ++ show _lhsIblockNr - -- "GenerateCode.ag"(line 449, column 7) - _pragmaDecl = - PragmaDecl ("NOINLINE " ++ _lambdaName ) - -- "GenerateCode.ag"(line 450, column 7) - _lhsOcallExpr = - App _lambdaName (map SimpleExpr _freeVars ) - -- "GenerateCode.ag"(line 452, column 7) - _freeVars = - freevars _lhsIlastExprVars (defs_ ++ _lhsInextVisitDecls) - -- "GenerateCode.ag"(line 459, column 7) - _lhsOdecls = - [ mkBlockLambda _lhsIoptCase _lambdaName _freeVars (defs_ ++ _lhsInextVisitDecls) result_ ] - -- copy rule (from local) - _lhsOfreeVars = - _freeVars - in ( _lhsOcallExpr,_lhsOdecls,_lhsOfreeVars))) ) --- DeclBlocksRoot ---------------------------------------------- -{- - visit 0: - inherited attributes: - lastExprVars : [String] - nextVisitDecls : [Decl] - optCase : Bool - prefix : String - synthesized attributes: - firstCall : Expr - lambdas : [Decl] - alternatives: - alternative DeclBlocksRoot: - child blocks : DeclBlocks --} --- cata -sem_DeclBlocksRoot :: DeclBlocksRoot -> - T_DeclBlocksRoot -sem_DeclBlocksRoot (DeclBlocksRoot _blocks ) = - (sem_DeclBlocksRoot_DeclBlocksRoot (sem_DeclBlocks _blocks ) ) --- semantic domain -newtype T_DeclBlocksRoot = T_DeclBlocksRoot (([String]) -> - ([Decl]) -> - Bool -> - String -> - ( Expr,([Decl]))) -data Inh_DeclBlocksRoot = Inh_DeclBlocksRoot {lastExprVars_Inh_DeclBlocksRoot :: [String],nextVisitDecls_Inh_DeclBlocksRoot :: [Decl],optCase_Inh_DeclBlocksRoot :: Bool,prefix_Inh_DeclBlocksRoot :: String} -data Syn_DeclBlocksRoot = Syn_DeclBlocksRoot {firstCall_Syn_DeclBlocksRoot :: Expr,lambdas_Syn_DeclBlocksRoot :: [Decl]} -wrap_DeclBlocksRoot (T_DeclBlocksRoot sem ) (Inh_DeclBlocksRoot _lhsIlastExprVars _lhsInextVisitDecls _lhsIoptCase _lhsIprefix ) = - (let ( _lhsOfirstCall,_lhsOlambdas) = - (sem _lhsIlastExprVars _lhsInextVisitDecls _lhsIoptCase _lhsIprefix ) - in (Syn_DeclBlocksRoot _lhsOfirstCall _lhsOlambdas )) -sem_DeclBlocksRoot_DeclBlocksRoot :: T_DeclBlocks -> - T_DeclBlocksRoot -sem_DeclBlocksRoot_DeclBlocksRoot (T_DeclBlocks blocks_ ) = - (T_DeclBlocksRoot (\ _lhsIlastExprVars - _lhsInextVisitDecls - _lhsIoptCase - _lhsIprefix -> - (let _lhsOlambdas :: ([Decl]) - _lhsOfirstCall :: Expr - _blocksOblockNr :: Int - _blocksOlastExprVars :: ([String]) - _blocksOnextVisitDecls :: ([Decl]) - _blocksOoptCase :: Bool - _blocksOprefix :: String - _blocksIcallExpr :: Expr - _blocksIdecls :: ([Decl]) - _blocksIfreeVars :: ([String]) - -- "GenerateCode.ag"(line 434, column 7) - _lhsOlambdas = - _blocksIdecls - -- "GenerateCode.ag"(line 435, column 7) - _lhsOfirstCall = - _blocksIcallExpr - -- "GenerateCode.ag"(line 440, column 7) - _blocksOblockNr = - 1 - -- copy rule (down) - _blocksOlastExprVars = - _lhsIlastExprVars - -- copy rule (down) - _blocksOnextVisitDecls = - _lhsInextVisitDecls - -- copy rule (down) - _blocksOoptCase = - _lhsIoptCase - -- copy rule (down) - _blocksOprefix = - _lhsIprefix - ( _blocksIcallExpr,_blocksIdecls,_blocksIfreeVars) = - (blocks_ _blocksOblockNr _blocksOlastExprVars _blocksOnextVisitDecls _blocksOoptCase _blocksOprefix ) - in ( _lhsOfirstCall,_lhsOlambdas))) ) --- Pattern ----------------------------------------------------- -{- - visit 0: - synthesized attributes: - copy : SELF - definedInsts : [Identifier] - patternAttributes : [(Name, Name)] - alternatives: - alternative Alias: - child field : {Name} - child attr : {Name} - child pat : Pattern - child parts : Patterns - visit 0: - local copy : _ - alternative Constr: - child name : {Constructor} - child pats : Patterns - visit 0: - local copy : _ - alternative Product: - child pos : {Pos} - child pats : Patterns - visit 0: - local copy : _ - alternative Underscore: - child pos : {Pos} - visit 0: - local copy : _ --} --- cata -sem_Pattern :: Pattern -> - T_Pattern -sem_Pattern (Alias _field _attr _pat _parts ) = - (sem_Pattern_Alias _field _attr (sem_Pattern _pat ) (sem_Patterns _parts ) ) -sem_Pattern (Constr _name _pats ) = - (sem_Pattern_Constr _name (sem_Patterns _pats ) ) -sem_Pattern (Product _pos _pats ) = - (sem_Pattern_Product _pos (sem_Patterns _pats ) ) -sem_Pattern (Underscore _pos ) = - (sem_Pattern_Underscore _pos ) --- semantic domain -newtype T_Pattern = T_Pattern (( Pattern,([Identifier]),([(Name, Name)]))) -data Inh_Pattern = Inh_Pattern {} -data Syn_Pattern = Syn_Pattern {copy_Syn_Pattern :: Pattern,definedInsts_Syn_Pattern :: [Identifier],patternAttributes_Syn_Pattern :: [(Name, Name)]} -wrap_Pattern (T_Pattern sem ) (Inh_Pattern ) = - (let ( _lhsOcopy,_lhsOdefinedInsts,_lhsOpatternAttributes) = - (sem ) - in (Syn_Pattern _lhsOcopy _lhsOdefinedInsts _lhsOpatternAttributes )) -sem_Pattern_Alias :: Name -> - Name -> - T_Pattern -> - T_Patterns -> - T_Pattern -sem_Pattern_Alias field_ attr_ (T_Pattern pat_ ) (T_Patterns parts_ ) = - (T_Pattern (let _lhsOdefinedInsts :: ([Identifier]) - _lhsOpatternAttributes :: ([(Name, Name)]) - _lhsOcopy :: Pattern - _patIcopy :: Pattern - _patIdefinedInsts :: ([Identifier]) - _patIpatternAttributes :: ([(Name, Name)]) - _partsIcopy :: Patterns - _partsIdefinedInsts :: ([Identifier]) - _partsIpatternAttributes :: ([(Name, Name)]) - -- "GenerateCode.ag"(line 142, column 11) - _lhsOdefinedInsts = - (if field_ == _INST then [attr_] else []) ++ _patIdefinedInsts - -- "GenerateCode.ag"(line 150, column 7) - _lhsOpatternAttributes = - (field_,attr_) : (_patIpatternAttributes ++ _partsIpatternAttributes) - -- self rule - _copy = - Alias field_ attr_ _patIcopy _partsIcopy - -- self rule - _lhsOcopy = - _copy - ( _patIcopy,_patIdefinedInsts,_patIpatternAttributes) = - (pat_ ) - ( _partsIcopy,_partsIdefinedInsts,_partsIpatternAttributes) = - (parts_ ) - in ( _lhsOcopy,_lhsOdefinedInsts,_lhsOpatternAttributes)) ) -sem_Pattern_Constr :: Constructor -> - T_Patterns -> - T_Pattern -sem_Pattern_Constr name_ (T_Patterns pats_ ) = - (T_Pattern (let _lhsOdefinedInsts :: ([Identifier]) - _lhsOpatternAttributes :: ([(Name, Name)]) - _lhsOcopy :: Pattern - _patsIcopy :: Patterns - _patsIdefinedInsts :: ([Identifier]) - _patsIpatternAttributes :: ([(Name, Name)]) - -- use rule "GenerateCode.ag"(line 140, column 55) - _lhsOdefinedInsts = - _patsIdefinedInsts - -- use rule "GenerateCode.ag"(line 147, column 47) - _lhsOpatternAttributes = - _patsIpatternAttributes - -- self rule - _copy = - Constr name_ _patsIcopy - -- self rule - _lhsOcopy = - _copy - ( _patsIcopy,_patsIdefinedInsts,_patsIpatternAttributes) = - (pats_ ) - in ( _lhsOcopy,_lhsOdefinedInsts,_lhsOpatternAttributes)) ) -sem_Pattern_Product :: Pos -> - T_Patterns -> - T_Pattern -sem_Pattern_Product pos_ (T_Patterns pats_ ) = - (T_Pattern (let _lhsOdefinedInsts :: ([Identifier]) - _lhsOpatternAttributes :: ([(Name, Name)]) - _lhsOcopy :: Pattern - _patsIcopy :: Patterns - _patsIdefinedInsts :: ([Identifier]) - _patsIpatternAttributes :: ([(Name, Name)]) - -- use rule "GenerateCode.ag"(line 140, column 55) - _lhsOdefinedInsts = - _patsIdefinedInsts - -- use rule "GenerateCode.ag"(line 147, column 47) - _lhsOpatternAttributes = - _patsIpatternAttributes - -- self rule - _copy = - Product pos_ _patsIcopy - -- self rule - _lhsOcopy = - _copy - ( _patsIcopy,_patsIdefinedInsts,_patsIpatternAttributes) = - (pats_ ) - in ( _lhsOcopy,_lhsOdefinedInsts,_lhsOpatternAttributes)) ) -sem_Pattern_Underscore :: Pos -> - T_Pattern -sem_Pattern_Underscore pos_ = - (T_Pattern (let _lhsOdefinedInsts :: ([Identifier]) - _lhsOpatternAttributes :: ([(Name, Name)]) - _lhsOcopy :: Pattern - -- use rule "GenerateCode.ag"(line 140, column 55) - _lhsOdefinedInsts = - [] - -- use rule "GenerateCode.ag"(line 147, column 47) - _lhsOpatternAttributes = - [] - -- self rule - _copy = - Underscore pos_ - -- self rule - _lhsOcopy = - _copy - in ( _lhsOcopy,_lhsOdefinedInsts,_lhsOpatternAttributes)) ) --- Patterns ---------------------------------------------------- -{- - visit 0: - synthesized attributes: - copy : SELF - definedInsts : [Identifier] - patternAttributes : [(Name, Name)] - alternatives: - alternative Cons: - child hd : Pattern - child tl : Patterns - visit 0: - local copy : _ - alternative Nil: - visit 0: - local copy : _ --} --- cata -sem_Patterns :: Patterns -> - T_Patterns -sem_Patterns list = - (Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list) ) --- semantic domain -newtype T_Patterns = T_Patterns (( Patterns,([Identifier]),([(Name, Name)]))) -data Inh_Patterns = Inh_Patterns {} -data Syn_Patterns = Syn_Patterns {copy_Syn_Patterns :: Patterns,definedInsts_Syn_Patterns :: [Identifier],patternAttributes_Syn_Patterns :: [(Name, Name)]} -wrap_Patterns (T_Patterns sem ) (Inh_Patterns ) = - (let ( _lhsOcopy,_lhsOdefinedInsts,_lhsOpatternAttributes) = - (sem ) - in (Syn_Patterns _lhsOcopy _lhsOdefinedInsts _lhsOpatternAttributes )) -sem_Patterns_Cons :: T_Pattern -> - T_Patterns -> - T_Patterns -sem_Patterns_Cons (T_Pattern hd_ ) (T_Patterns tl_ ) = - (T_Patterns (let _lhsOdefinedInsts :: ([Identifier]) - _lhsOpatternAttributes :: ([(Name, Name)]) - _lhsOcopy :: Patterns - _hdIcopy :: Pattern - _hdIdefinedInsts :: ([Identifier]) - _hdIpatternAttributes :: ([(Name, Name)]) - _tlIcopy :: Patterns - _tlIdefinedInsts :: ([Identifier]) - _tlIpatternAttributes :: ([(Name, Name)]) - -- use rule "GenerateCode.ag"(line 140, column 55) - _lhsOdefinedInsts = - _hdIdefinedInsts ++ _tlIdefinedInsts - -- use rule "GenerateCode.ag"(line 147, column 47) - _lhsOpatternAttributes = - _hdIpatternAttributes ++ _tlIpatternAttributes - -- self rule - _copy = - (:) _hdIcopy _tlIcopy - -- self rule - _lhsOcopy = - _copy - ( _hdIcopy,_hdIdefinedInsts,_hdIpatternAttributes) = - (hd_ ) - ( _tlIcopy,_tlIdefinedInsts,_tlIpatternAttributes) = - (tl_ ) - in ( _lhsOcopy,_lhsOdefinedInsts,_lhsOpatternAttributes)) ) -sem_Patterns_Nil :: T_Patterns -sem_Patterns_Nil = - (T_Patterns (let _lhsOdefinedInsts :: ([Identifier]) - _lhsOpatternAttributes :: ([(Name, Name)]) - _lhsOcopy :: Patterns - -- use rule "GenerateCode.ag"(line 140, column 55) - _lhsOdefinedInsts = - [] - -- use rule "GenerateCode.ag"(line 147, column 47) - _lhsOpatternAttributes = - [] - -- self rule - _copy = - [] - -- self rule - _lhsOcopy = - _copy - in ( _lhsOcopy,_lhsOdefinedInsts,_lhsOpatternAttributes)) ) --- Sequence ---------------------------------------------------- -{- - visit 0: - inherited attributes: - children : [(Name,Type,Bool)] - con : Constructor - higherOrderChildren : [(Name,Type,Bool)] - inh : Attributes - instVisitNrs : Map Identifier Int - lastExpr : Expr - nr : Int - nt : Nonterminal - o_case : Bool - o_cata : Bool - o_costcentre : Bool - o_data : Maybe Bool - o_linePragmas : Bool - o_newtypes : Bool - o_pretty : Bool - o_rename : Bool - o_sem : Bool - o_sig : Bool - o_splitsems : Bool - o_strictwrap : Bool - o_traces : Bool - o_unbox : Bool - prefix : String - syn : Attributes - terminals : [Name] - what : String - chained attributes: - declsAbove : [Decl] - errors : Seq Error - synthesized attributes: - allTpsFound : Bool - blockDecls : DeclBlocks - comments : [String] - decls : Decls - definedInsts : [Identifier] - exprs : Exprs - tSigs : [Decl] - tps : [Type] - usedVars : Set String - alternatives: - alternative Cons: - child hd : CRule - child tl : Sequence - alternative Nil: --} --- cata -sem_Sequence :: Sequence -> - T_Sequence -sem_Sequence list = - (Prelude.foldr sem_Sequence_Cons sem_Sequence_Nil (Prelude.map sem_CRule list) ) --- semantic domain -newtype T_Sequence = T_Sequence (([(Name,Type,Bool)]) -> - Constructor -> - ([Decl]) -> - (Seq Error) -> - ([(Name,Type,Bool)]) -> - Attributes -> - (Map Identifier Int) -> - Expr -> - Int -> - Nonterminal -> - Bool -> - Bool -> - Bool -> - (Maybe Bool) -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - String -> - Attributes -> - ([Name]) -> - String -> - ( Bool,DeclBlocks,([String]),Decls,([Decl]),([Identifier]),(Seq Error),Exprs,([Decl]),([Type]),(Set String))) -data Inh_Sequence = Inh_Sequence {children_Inh_Sequence :: [(Name,Type,Bool)],con_Inh_Sequence :: Constructor,declsAbove_Inh_Sequence :: [Decl],errors_Inh_Sequence :: Seq Error,higherOrderChildren_Inh_Sequence :: [(Name,Type,Bool)],inh_Inh_Sequence :: Attributes,instVisitNrs_Inh_Sequence :: Map Identifier Int,lastExpr_Inh_Sequence :: Expr,nr_Inh_Sequence :: Int,nt_Inh_Sequence :: Nonterminal,o_case_Inh_Sequence :: Bool,o_cata_Inh_Sequence :: Bool,o_costcentre_Inh_Sequence :: Bool,o_data_Inh_Sequence :: Maybe Bool,o_linePragmas_Inh_Sequence :: Bool,o_newtypes_Inh_Sequence :: Bool,o_pretty_Inh_Sequence :: Bool,o_rename_Inh_Sequence :: Bool,o_sem_Inh_Sequence :: Bool,o_sig_Inh_Sequence :: Bool,o_splitsems_Inh_Sequence :: Bool,o_strictwrap_Inh_Sequence :: Bool,o_traces_Inh_Sequence :: Bool,o_unbox_Inh_Sequence :: Bool,prefix_Inh_Sequence :: String,syn_Inh_Sequence :: Attributes,terminals_Inh_Sequence :: [Name],what_Inh_Sequence :: String} -data Syn_Sequence = Syn_Sequence {allTpsFound_Syn_Sequence :: Bool,blockDecls_Syn_Sequence :: DeclBlocks,comments_Syn_Sequence :: [String],decls_Syn_Sequence :: Decls,declsAbove_Syn_Sequence :: [Decl],definedInsts_Syn_Sequence :: [Identifier],errors_Syn_Sequence :: Seq Error,exprs_Syn_Sequence :: Exprs,tSigs_Syn_Sequence :: [Decl],tps_Syn_Sequence :: [Type],usedVars_Syn_Sequence :: Set String} -wrap_Sequence (T_Sequence sem ) (Inh_Sequence _lhsIchildren _lhsIcon _lhsIdeclsAbove _lhsIerrors _lhsIhigherOrderChildren _lhsIinh _lhsIinstVisitNrs _lhsIlastExpr _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn _lhsIterminals _lhsIwhat ) = - (let ( _lhsOallTpsFound,_lhsOblockDecls,_lhsOcomments,_lhsOdecls,_lhsOdeclsAbove,_lhsOdefinedInsts,_lhsOerrors,_lhsOexprs,_lhsOtSigs,_lhsOtps,_lhsOusedVars) = - (sem _lhsIchildren _lhsIcon _lhsIdeclsAbove _lhsIerrors _lhsIhigherOrderChildren _lhsIinh _lhsIinstVisitNrs _lhsIlastExpr _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIprefix _lhsIsyn _lhsIterminals _lhsIwhat ) - in (Syn_Sequence _lhsOallTpsFound _lhsOblockDecls _lhsOcomments _lhsOdecls _lhsOdeclsAbove _lhsOdefinedInsts _lhsOerrors _lhsOexprs _lhsOtSigs _lhsOtps _lhsOusedVars )) -sem_Sequence_Cons :: T_CRule -> - T_Sequence -> - T_Sequence -sem_Sequence_Cons (T_CRule hd_ ) (T_Sequence tl_ ) = - (T_Sequence (\ _lhsIchildren - _lhsIcon - _lhsIdeclsAbove - _lhsIerrors - _lhsIhigherOrderChildren - _lhsIinh - _lhsIinstVisitNrs - _lhsIlastExpr - _lhsInr - _lhsInt - _lhsIo_case - _lhsIo_cata - _lhsIo_costcentre - _lhsIo_data - _lhsIo_linePragmas - _lhsIo_newtypes - _lhsIo_pretty - _lhsIo_rename - _lhsIo_sem - _lhsIo_sig - _lhsIo_splitsems - _lhsIo_strictwrap - _lhsIo_traces - _lhsIo_unbox - _lhsIprefix - _lhsIsyn - _lhsIterminals - _lhsIwhat -> - (let _lhsOblockDecls :: DeclBlocks - _lhsOallTpsFound :: Bool - _lhsOcomments :: ([String]) - _lhsOdecls :: Decls - _lhsOdefinedInsts :: ([Identifier]) - _lhsOerrors :: (Seq Error) - _lhsOexprs :: Exprs - _lhsOtSigs :: ([Decl]) - _lhsOtps :: ([Type]) - _lhsOusedVars :: (Set String) - _lhsOdeclsAbove :: ([Decl]) - _hdOchildren :: ([(Name,Type,Bool)]) - _hdOcon :: Constructor - _hdOdeclsAbove :: ([Decl]) - _hdOerrors :: (Seq Error) - _hdOhigherOrderChildren :: ([(Name,Type,Bool)]) - _hdOinh :: Attributes - _hdOinstVisitNrs :: (Map Identifier Int) - _hdOnr :: Int - _hdOnt :: Nonterminal - _hdOo_case :: Bool - _hdOo_cata :: Bool - _hdOo_costcentre :: Bool - _hdOo_data :: (Maybe Bool) - _hdOo_linePragmas :: Bool - _hdOo_newtypes :: Bool - _hdOo_pretty :: Bool - _hdOo_rename :: Bool - _hdOo_sem :: Bool - _hdOo_sig :: Bool - _hdOo_splitsems :: Bool - _hdOo_strictwrap :: Bool - _hdOo_traces :: Bool - _hdOo_unbox :: Bool - _hdOprefix :: String - _hdOsyn :: Attributes - _hdOterminals :: ([Name]) - _hdOwhat :: String - _tlOchildren :: ([(Name,Type,Bool)]) - _tlOcon :: Constructor - _tlOdeclsAbove :: ([Decl]) - _tlOerrors :: (Seq Error) - _tlOhigherOrderChildren :: ([(Name,Type,Bool)]) - _tlOinh :: Attributes - _tlOinstVisitNrs :: (Map Identifier Int) - _tlOlastExpr :: Expr - _tlOnr :: Int - _tlOnt :: Nonterminal - _tlOo_case :: Bool - _tlOo_cata :: Bool - _tlOo_costcentre :: Bool - _tlOo_data :: (Maybe Bool) - _tlOo_linePragmas :: Bool - _tlOo_newtypes :: Bool - _tlOo_pretty :: Bool - _tlOo_rename :: Bool - _tlOo_sem :: Bool - _tlOo_sig :: Bool - _tlOo_splitsems :: Bool - _tlOo_strictwrap :: Bool - _tlOo_traces :: Bool - _tlOo_unbox :: Bool - _tlOprefix :: String - _tlOsyn :: Attributes - _tlOterminals :: ([Name]) - _tlOwhat :: String - _hdIallTpsFound :: Bool - _hdIbldBlocksFun :: (DeclBlocks -> DeclBlocks) - _hdIcomments :: ([String]) - _hdIdecls :: Decls - _hdIdeclsAbove :: ([Decl]) - _hdIdefinedInsts :: ([Identifier]) - _hdIerrors :: (Seq Error) - _hdIexprs :: Exprs - _hdItSigs :: ([Decl]) - _hdItps :: ([Type]) - _hdIusedVars :: (Set String) - _tlIallTpsFound :: Bool - _tlIblockDecls :: DeclBlocks - _tlIcomments :: ([String]) - _tlIdecls :: Decls - _tlIdeclsAbove :: ([Decl]) - _tlIdefinedInsts :: ([Identifier]) - _tlIerrors :: (Seq Error) - _tlIexprs :: Exprs - _tlItSigs :: ([Decl]) - _tlItps :: ([Type]) - _tlIusedVars :: (Set String) - -- "GenerateCode.ag"(line 375, column 7) - _lhsOblockDecls = - _hdIbldBlocksFun _tlIblockDecls - -- use rule "GenerateCode.ag"(line 265, column 39) - _lhsOallTpsFound = - _hdIallTpsFound && _tlIallTpsFound - -- use rule "GenerateCode.ag"(line 583, column 52) - _lhsOcomments = - _hdIcomments ++ _tlIcomments - -- use rule "GenerateCode.ag"(line 87, column 34) - _lhsOdecls = - _hdIdecls ++ _tlIdecls - -- use rule "GenerateCode.ag"(line 140, column 55) - _lhsOdefinedInsts = - _hdIdefinedInsts ++ _tlIdefinedInsts - -- use rule "GenerateCode.ag"(line 564, column 32) - _lhsOerrors = - _hdIerrors Seq.<> _tlIerrors - -- use rule "GenerateCode.ag"(line 213, column 34) - _lhsOexprs = - _hdIexprs ++ _tlIexprs - -- use rule "GenerateCode.ag"(line 238, column 33) - _lhsOtSigs = - _hdItSigs ++ _tlItSigs - -- use rule "GenerateCode.ag"(line 264, column 31) - _lhsOtps = - _hdItps ++ _tlItps - -- use rule "GenerateCode.ag"(line 227, column 37) - _lhsOusedVars = - _hdIusedVars `Set.union` _tlIusedVars - -- copy rule (up) - _lhsOdeclsAbove = - _tlIdeclsAbove - -- copy rule (down) - _hdOchildren = - _lhsIchildren - -- copy rule (down) - _hdOcon = - _lhsIcon - -- copy rule (down) - _hdOdeclsAbove = - _lhsIdeclsAbove - -- copy rule (down) - _hdOerrors = - _lhsIerrors - -- copy rule (down) - _hdOhigherOrderChildren = - _lhsIhigherOrderChildren - -- copy rule (down) - _hdOinh = - _lhsIinh - -- copy rule (down) - _hdOinstVisitNrs = - _lhsIinstVisitNrs - -- copy rule (down) - _hdOnr = - _lhsInr - -- copy rule (down) - _hdOnt = - _lhsInt - -- copy rule (down) - _hdOo_case = - _lhsIo_case - -- copy rule (down) - _hdOo_cata = - _lhsIo_cata - -- copy rule (down) - _hdOo_costcentre = - _lhsIo_costcentre - -- copy rule (down) - _hdOo_data = - _lhsIo_data - -- copy rule (down) - _hdOo_linePragmas = - _lhsIo_linePragmas - -- copy rule (down) - _hdOo_newtypes = - _lhsIo_newtypes - -- copy rule (down) - _hdOo_pretty = - _lhsIo_pretty - -- copy rule (down) - _hdOo_rename = - _lhsIo_rename - -- copy rule (down) - _hdOo_sem = - _lhsIo_sem - -- copy rule (down) - _hdOo_sig = - _lhsIo_sig - -- copy rule (down) - _hdOo_splitsems = - _lhsIo_splitsems - -- copy rule (down) - _hdOo_strictwrap = - _lhsIo_strictwrap - -- copy rule (down) - _hdOo_traces = - _lhsIo_traces - -- copy rule (down) - _hdOo_unbox = - _lhsIo_unbox - -- copy rule (down) - _hdOprefix = - _lhsIprefix - -- copy rule (down) - _hdOsyn = - _lhsIsyn - -- copy rule (down) - _hdOterminals = - _lhsIterminals - -- copy rule (down) - _hdOwhat = - _lhsIwhat - -- copy rule (down) - _tlOchildren = - _lhsIchildren - -- copy rule (down) - _tlOcon = - _lhsIcon - -- copy rule (chain) - _tlOdeclsAbove = - _hdIdeclsAbove - -- copy rule (chain) - _tlOerrors = - _hdIerrors - -- copy rule (down) - _tlOhigherOrderChildren = - _lhsIhigherOrderChildren - -- copy rule (down) - _tlOinh = - _lhsIinh - -- copy rule (down) - _tlOinstVisitNrs = - _lhsIinstVisitNrs - -- copy rule (down) - _tlOlastExpr = - _lhsIlastExpr - -- copy rule (down) - _tlOnr = - _lhsInr - -- copy rule (down) - _tlOnt = - _lhsInt - -- copy rule (down) - _tlOo_case = - _lhsIo_case - -- copy rule (down) - _tlOo_cata = - _lhsIo_cata - -- copy rule (down) - _tlOo_costcentre = - _lhsIo_costcentre - -- copy rule (down) - _tlOo_data = - _lhsIo_data - -- copy rule (down) - _tlOo_linePragmas = - _lhsIo_linePragmas - -- copy rule (down) - _tlOo_newtypes = - _lhsIo_newtypes - -- copy rule (down) - _tlOo_pretty = - _lhsIo_pretty - -- copy rule (down) - _tlOo_rename = - _lhsIo_rename - -- copy rule (down) - _tlOo_sem = - _lhsIo_sem - -- copy rule (down) - _tlOo_sig = - _lhsIo_sig - -- copy rule (down) - _tlOo_splitsems = - _lhsIo_splitsems - -- copy rule (down) - _tlOo_strictwrap = - _lhsIo_strictwrap - -- copy rule (down) - _tlOo_traces = - _lhsIo_traces - -- copy rule (down) - _tlOo_unbox = - _lhsIo_unbox - -- copy rule (down) - _tlOprefix = - _lhsIprefix - -- copy rule (down) - _tlOsyn = - _lhsIsyn - -- copy rule (down) - _tlOterminals = - _lhsIterminals - -- copy rule (down) - _tlOwhat = - _lhsIwhat - ( _hdIallTpsFound,_hdIbldBlocksFun,_hdIcomments,_hdIdecls,_hdIdeclsAbove,_hdIdefinedInsts,_hdIerrors,_hdIexprs,_hdItSigs,_hdItps,_hdIusedVars) = - (hd_ _hdOchildren _hdOcon _hdOdeclsAbove _hdOerrors _hdOhigherOrderChildren _hdOinh _hdOinstVisitNrs _hdOnr _hdOnt _hdOo_case _hdOo_cata _hdOo_costcentre _hdOo_data _hdOo_linePragmas _hdOo_newtypes _hdOo_pretty _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_splitsems _hdOo_strictwrap _hdOo_traces _hdOo_unbox _hdOprefix _hdOsyn _hdOterminals _hdOwhat ) - ( _tlIallTpsFound,_tlIblockDecls,_tlIcomments,_tlIdecls,_tlIdeclsAbove,_tlIdefinedInsts,_tlIerrors,_tlIexprs,_tlItSigs,_tlItps,_tlIusedVars) = - (tl_ _tlOchildren _tlOcon _tlOdeclsAbove _tlOerrors _tlOhigherOrderChildren _tlOinh _tlOinstVisitNrs _tlOlastExpr _tlOnr _tlOnt _tlOo_case _tlOo_cata _tlOo_costcentre _tlOo_data _tlOo_linePragmas _tlOo_newtypes _tlOo_pretty _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_splitsems _tlOo_strictwrap _tlOo_traces _tlOo_unbox _tlOprefix _tlOsyn _tlOterminals _tlOwhat ) - in ( _lhsOallTpsFound,_lhsOblockDecls,_lhsOcomments,_lhsOdecls,_lhsOdeclsAbove,_lhsOdefinedInsts,_lhsOerrors,_lhsOexprs,_lhsOtSigs,_lhsOtps,_lhsOusedVars))) ) -sem_Sequence_Nil :: T_Sequence -sem_Sequence_Nil = - (T_Sequence (\ _lhsIchildren - _lhsIcon - _lhsIdeclsAbove - _lhsIerrors - _lhsIhigherOrderChildren - _lhsIinh - _lhsIinstVisitNrs - _lhsIlastExpr - _lhsInr - _lhsInt - _lhsIo_case - _lhsIo_cata - _lhsIo_costcentre - _lhsIo_data - _lhsIo_linePragmas - _lhsIo_newtypes - _lhsIo_pretty - _lhsIo_rename - _lhsIo_sem - _lhsIo_sig - _lhsIo_splitsems - _lhsIo_strictwrap - _lhsIo_traces - _lhsIo_unbox - _lhsIprefix - _lhsIsyn - _lhsIterminals - _lhsIwhat -> - (let _lhsOblockDecls :: DeclBlocks - _lhsOallTpsFound :: Bool - _lhsOcomments :: ([String]) - _lhsOdecls :: Decls - _lhsOdefinedInsts :: ([Identifier]) - _lhsOerrors :: (Seq Error) - _lhsOexprs :: Exprs - _lhsOtSigs :: ([Decl]) - _lhsOtps :: ([Type]) - _lhsOusedVars :: (Set String) - _lhsOdeclsAbove :: ([Decl]) - -- "GenerateCode.ag"(line 377, column 7) - _lhsOblockDecls = - DeclTerminator _lhsIdeclsAbove _lhsIlastExpr - -- use rule "GenerateCode.ag"(line 265, column 39) - _lhsOallTpsFound = - True - -- use rule "GenerateCode.ag"(line 583, column 52) - _lhsOcomments = - [] - -- use rule "GenerateCode.ag"(line 87, column 34) - _lhsOdecls = - [] - -- use rule "GenerateCode.ag"(line 140, column 55) - _lhsOdefinedInsts = - [] - -- use rule "GenerateCode.ag"(line 564, column 32) - _lhsOerrors = - Seq.empty - -- use rule "GenerateCode.ag"(line 213, column 34) - _lhsOexprs = - [] - -- use rule "GenerateCode.ag"(line 238, column 33) - _lhsOtSigs = - [] - -- use rule "GenerateCode.ag"(line 264, column 31) - _lhsOtps = - [] - -- use rule "GenerateCode.ag"(line 227, column 37) - _lhsOusedVars = - Set.empty - -- copy rule (chain) - _lhsOdeclsAbove = - _lhsIdeclsAbove - in ( _lhsOallTpsFound,_lhsOblockDecls,_lhsOcomments,_lhsOdecls,_lhsOdeclsAbove,_lhsOdefinedInsts,_lhsOerrors,_lhsOexprs,_lhsOtSigs,_lhsOtps,_lhsOusedVars))) ) +-- UUAGC 0.9.5 (GenerateCode.ag) +module GenerateCode where + +import SequentialTypes +import Code hiding (Type) +import qualified Code +import Options +import CodeSyntax +import ErrorMessages +import GrammarInfo +import DeclBlocks + +import qualified Data.Map as Map +import Data.Map(Map) +import qualified Data.Set as Set +import Data.Set(Set) +import qualified UU.DData.Seq as Seq +import UU.DData.Seq(Seq) +import UU.Scanner.Position +import TokenDef +import HsToken +import HsTokenScanner + +import Data.List(partition,intersperse,intersect,(\\)) +import Maybe(fromJust,isJust) + +import Patterns +import CommonTypes +import Data.Map(Map) +import Data.Set(Set) + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (ConstructorIdent,Identifier) + +import Code (Decl,Expr) + +-- remove possible @v references in the types of a data type. +cleanupArg :: String -> String +cleanupArg s + = case idEvalType (SimpleType s) of + SimpleType s' -> s' + +appContext :: ContextMap -> NontermIdent -> Code.Type -> Code.Type +appContext mp nt tp + = maybe tp (\ctx -> CtxApp (map (\(n,ns) -> (getName n, ns)) ctx) tp) $ Map.lookup nt mp + +substSelf nt tp = case tp of + NT t tps | t == _SELF -> Haskell (getName nt ++ " " ++ unwords tps) + _ -> tp + +mkLambdaArg :: String -> Maybe Code.Type -> Expr +mkLambdaArg nm Nothing = SimpleExpr nm +mkLambdaArg nm (Just tp) = TypedExpr (SimpleExpr nm) tp + +mkLambda :: Exprs -> Expr -> Expr +mkLambda [] e = e +mkLambda xs e = Lambda xs e + +typeAppStrs nm params = TypeApp (SimpleType nm) (map SimpleType params) + +-- dead code - replaced by mkPartitionedFunction +{- +localCpsToExpr :: Bool -> [Decl] -> DeclBlocks -> Expr +localCpsToExpr o_case nextVisitDecl + = rec + where + rec cps + = case cps of + DeclTerminator decls expr + -> mkLet o_case (decls ++ nextVisitDecl) expr + DeclBlock decls (Decl lhs rhs _ _) remainder + -> let inDecls = [ PragmaDecl ("NOINLINE " ++ internalCpsName) + , Decl (Fun internalCpsName [SimpleExpr internalCpsVarName]) + (mkLet o_case [Decl lhs (SimpleExpr internalCpsVarName) Set.empty Set.empty] (rec remainder)) + Set.empty Set.empty + ] + inBody = App "head" [App "(:)" [App internalCpsName [rhs], App "(:)" [App internalCpsName [rhs], SimpleExpr "[]"]]] + outerBody = Let inDecls inBody + block = mkLet o_case decls outerBody + in block + +internalCpsName :: String +internalCpsName = "internalCps_" + +internalCpsVarName :: String +internalCpsVarName = "internalCps_var_" +-} + +mkPartitionedFunction :: String -> Bool -> [Decl] -> [String] -> DeclBlocks -> ([Decl], Expr) +mkPartitionedFunction prefix optCase nextVisitDecls lastExprVars cpsTree + = let inh = Inh_DeclBlocksRoot { prefix_Inh_DeclBlocksRoot = prefix + , optCase_Inh_DeclBlocksRoot = optCase + , nextVisitDecls_Inh_DeclBlocksRoot = nextVisitDecls + , lastExprVars_Inh_DeclBlocksRoot = lastExprVars + } + sem = sem_DeclBlocksRoot (DeclBlocksRoot cpsTree) + syn = wrap_DeclBlocksRoot sem inh + in (lambdas_Syn_DeclBlocksRoot syn, firstCall_Syn_DeclBlocksRoot syn) + +freevars :: [String] -> [Decl] -> [String] +freevars additional decls + = Set.toList (allused `Set.difference` alldefined) + where + allused = Set.unions (Set.fromList additional : map usedvars decls) + alldefined = Set.unions (map definedvars decls) + + usedvars (Decl _ _ _ uses) = uses + usedvars _ = Set.empty + + definedvars (Decl _ _ defs _) = defs + definedvars _ = Set.empty + +mkBlockLambda :: Bool -> String -> [String] -> [Decl] -> Expr -> Decl +mkBlockLambda optCase name args decls expr + = Decl lhs rhs Set.empty Set.empty + where + lhs = Fun name (map SimpleExpr args) + rhs = mkLet optCase decls expr + +evalType :: (String -> String) -> Code.Type -> Code.Type +evalType replf t + = chase t + where + chase t + = case t of + Arr l r -> Arr (chase l) (chase r) + TypeApp f as -> TypeApp (chase f) (map chase as) + TupleType tps -> TupleType (map chase tps) + UnboxedTupleType tps -> UnboxedTupleType (map chase tps) + Code.List tp -> Code.List (chase tp) + SimpleType txt -> let tks = lexTokens (initPos txt) txt + tks' = map replaceTok tks + txt' = unlines . showTokens . tokensToStrings $ tks' + in SimpleType txt' + + replaceTok t + = case t of + AGLocal v p _ -> HsToken (replf $ getName v) p + _ -> t + +idEvalType :: Code.Type -> Code.Type +idEvalType = evalType id + +makeLocalComment :: Int -> String -> Identifier -> Maybe Type -> String +makeLocalComment width what name tp = let x = getName name + y = maybe "_" (\t -> case t of (NT nt tps) -> getName nt ++ " " ++ unwords tps; Haskell t -> '{':t++"}") tp + in ( what ++ " " ++ x ++ replicate ((width - length x) `max` 0) ' ' ++ " : " ++ y ) + + +-- Lets or nested Cases? +mkLet :: Bool -> Decls -> Expr -> Expr +mkLet False decls body = Let decls body +mkLet True decls body = foldr oneCase body decls + +oneCase :: Decl -> Expr -> Expr +oneCase (Decl left rhs _ _) exp = Case rhs [CaseAlt left exp] +oneCase _ exp = exp + +-- Gives the name of the visit function +funname field 0 = show field ++ "_" +funname field nr = show field ++ "_" ++ show nr + +-- Gives the name of a semantic function +seqSemname :: String -> NontermIdent -> ConstructorIdent -> Int -> String +seqSemname pre nt con 0 = semname pre nt con +seqSemname pre nt con nr = semname pre nt con ++ "_" ++ show nr + +-- Gives the name of a type +typeName :: NontermIdent -> Int -> String +typeName nt 0 = "T_" ++ show nt +typeName nt n = "T_" ++ show nt ++ "_" ++ show n + +-- Gives the name of a visit function +visitname :: String -> NontermIdent -> Int -> String +visitname pre nt n = pre ++ getName nt ++ "_" ++ show n +-- CGrammar ---------------------------------------------------- +{- + visit 0: + inherited attribute: + options : Options + synthesized attributes: + errors : Seq Error + output : Program + alternatives: + alternative CGrammar: + child typeSyns : {TypeSyns} + child derivings : {Derivings} + child wrappers : {Set NontermIdent} + child nonts : CNonterminals + child pragmas : {PragmaMap} + child paramMap : {ParamMap} + child contextMap : {ContextMap} + visit 0: + local unfoldSemDom : _ +-} +-- cata +sem_CGrammar :: CGrammar -> + T_CGrammar +sem_CGrammar (CGrammar _typeSyns _derivings _wrappers _nonts _pragmas _paramMap _contextMap) = + (sem_CGrammar_CGrammar _typeSyns _derivings _wrappers (sem_CNonterminals _nonts) _pragmas _paramMap _contextMap) +-- semantic domain +newtype T_CGrammar = T_CGrammar (Options -> + ( (Seq Error),Program)) +data Inh_CGrammar = Inh_CGrammar {options_Inh_CGrammar :: Options} +data Syn_CGrammar = Syn_CGrammar {errors_Syn_CGrammar :: Seq Error,output_Syn_CGrammar :: Program} +wrap_CGrammar (T_CGrammar sem) (Inh_CGrammar _lhsIoptions) = + (let ( _lhsOerrors,_lhsOoutput) = + (sem _lhsIoptions) + in (Syn_CGrammar _lhsOerrors _lhsOoutput)) +sem_CGrammar_CGrammar :: TypeSyns -> + Derivings -> + (Set NontermIdent) -> + T_CNonterminals -> + PragmaMap -> + ParamMap -> + ContextMap -> + T_CGrammar +sem_CGrammar_CGrammar typeSyns_ derivings_ wrappers_ (T_CNonterminals nonts_) pragmas_ paramMap_ contextMap_ = + (T_CGrammar (\ _lhsIoptions -> + (let _nontsOo_sig :: Bool + _nontsOo_cata :: Bool + _nontsOo_sem :: Bool + _nontsOo_newtypes :: Bool + _nontsOo_unbox :: Bool + _nontsOo_case :: Bool + _nontsOo_pretty :: Bool + _nontsOo_rename :: Bool + _nontsOo_strictwrap :: Bool + _nontsOo_splitsems :: Bool + _nontsOo_data :: (Maybe Bool) + _nontsOprefix :: String + _nontsOo_traces :: Bool + _nontsOo_costcentre :: Bool + _nontsOo_linePragmas :: Bool + _nontsOallPragmas :: PragmaMap + _nontsOparamMap :: ParamMap + _nontsOcontextMap :: ContextMap + _nontsOwith_sig :: Bool + _nontsOerrors :: (Seq Error) + _lhsOoutput :: Program + _nontsOtypeSyns :: TypeSyns + _nontsOderivings :: Derivings + _nontsOwrappers :: (Set NontermIdent) + _lhsOerrors :: (Seq Error) + _nontsOunfoldSemDom :: (NontermIdent -> Int -> [String] -> Code.Type) + _nontsIallTpsFound :: Bool + _nontsIchunks :: Chunks + _nontsIerrors :: (Seq Error) + _nontsIsemDomUnfoldGath :: (Map (NontermIdent, Int) ([String], Code.Type)) + -- "GenerateCode.ag"(line 46, column 17) + _nontsOo_sig = + typeSigs _lhsIoptions + -- "GenerateCode.ag"(line 46, column 17) + _nontsOo_cata = + folds _lhsIoptions + -- "GenerateCode.ag"(line 46, column 17) + _nontsOo_sem = + semfuns _lhsIoptions + -- "GenerateCode.ag"(line 46, column 17) + _nontsOo_newtypes = + newtypes _lhsIoptions + -- "GenerateCode.ag"(line 46, column 17) + _nontsOo_unbox = + unbox _lhsIoptions + -- "GenerateCode.ag"(line 46, column 17) + _nontsOo_case = + cases _lhsIoptions + -- "GenerateCode.ag"(line 46, column 17) + _nontsOo_pretty = + attrInfo _lhsIoptions + -- "GenerateCode.ag"(line 46, column 17) + _nontsOo_rename = + rename _lhsIoptions + -- "GenerateCode.ag"(line 46, column 17) + _nontsOo_strictwrap = + strictWrap _lhsIoptions + -- "GenerateCode.ag"(line 46, column 17) + _nontsOo_splitsems = + splitSems _lhsIoptions + -- "GenerateCode.ag"(line 46, column 17) + _nontsOo_data = + if dataTypes _lhsIoptions then Just (strictData _lhsIoptions) else Nothing + -- "GenerateCode.ag"(line 46, column 17) + _nontsOprefix = + prefix _lhsIoptions + -- "GenerateCode.ag"(line 46, column 17) + _nontsOo_traces = + genTraces _lhsIoptions + -- "GenerateCode.ag"(line 46, column 17) + _nontsOo_costcentre = + genCostCentres _lhsIoptions + -- "GenerateCode.ag"(line 46, column 17) + _nontsOo_linePragmas = + genLinePragmas _lhsIoptions + -- "GenerateCode.ag"(line 65, column 15) + _nontsOallPragmas = + pragmas_ + -- "GenerateCode.ag"(line 87, column 14) + _nontsOparamMap = + paramMap_ + -- "GenerateCode.ag"(line 108, column 7) + _nontsOcontextMap = + contextMap_ + -- "GenerateCode.ag"(line 597, column 7) + _unfoldSemDom = + \nt nr repl -> + let (params, tp) = Map.findWithDefault (error "No such semantic domain") (nt, nr) _nontsIsemDomUnfoldGath + replMap = Map.fromList (zip params repl) + replace k = Map.findWithDefault k k replMap + in evalType replace tp + -- "GenerateCode.ag"(line 690, column 14) + _nontsOwith_sig = + typeSigs _lhsIoptions && _nontsIallTpsFound + -- "GenerateCode.ag"(line 697, column 15) + _nontsOerrors = + Seq.empty + -- "GenerateCode.ag"(line 761, column 17) + _lhsOoutput = + Program _nontsIchunks + -- "GenerateCode.ag"(line 810, column 14) + _nontsOtypeSyns = + typeSyns_ + -- "GenerateCode.ag"(line 810, column 14) + _nontsOderivings = + derivings_ + -- "GenerateCode.ag"(line 810, column 14) + _nontsOwrappers = + wrappers_ + -- copy rule (up) + _lhsOerrors = + _nontsIerrors + -- copy rule (from local) + _nontsOunfoldSemDom = + _unfoldSemDom + ( _nontsIallTpsFound,_nontsIchunks,_nontsIerrors,_nontsIsemDomUnfoldGath) = + (nonts_ _nontsOallPragmas _nontsOcontextMap _nontsOderivings _nontsOerrors _nontsOo_case _nontsOo_cata _nontsOo_costcentre _nontsOo_data _nontsOo_linePragmas _nontsOo_newtypes _nontsOo_pretty _nontsOo_rename _nontsOo_sem _nontsOo_sig _nontsOo_splitsems _nontsOo_strictwrap _nontsOo_traces _nontsOo_unbox _nontsOparamMap _nontsOprefix _nontsOtypeSyns _nontsOunfoldSemDom _nontsOwith_sig _nontsOwrappers) + in ( _lhsOerrors,_lhsOoutput)))) +-- CInterface -------------------------------------------------- +{- + visit 0: + inherited attributes: + inh : Attributes + nt : NontermIdent + o_case : Bool + o_cata : Bool + o_costcentre : Bool + o_data : Maybe Bool + o_linePragmas : Bool + o_newtypes : Bool + o_pretty : Bool + o_rename : Bool + o_sem : Bool + o_sig : Bool + o_splitsems : Bool + o_strictwrap : Bool + o_traces : Bool + o_unbox : Bool + paramMap : ParamMap + prefix : String + syn : Attributes + synthesized attributes: + comments : [String] + semDom : [Decl] + semDomUnfoldGath : Map (NontermIdent, Int) ([String], Code.Type) + wrapDecls : Decls + alternatives: + alternative CInterface: + child seg : CSegments +-} +-- cata +sem_CInterface :: CInterface -> + T_CInterface +sem_CInterface (CInterface _seg) = + (sem_CInterface_CInterface (sem_CSegments _seg)) +-- semantic domain +newtype T_CInterface = T_CInterface (Attributes -> + NontermIdent -> + Bool -> + Bool -> + Bool -> + (Maybe Bool) -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + ParamMap -> + String -> + Attributes -> + ( ([String]),([Decl]),(Map (NontermIdent, Int) ([String], Code.Type)),Decls)) +data Inh_CInterface = Inh_CInterface {inh_Inh_CInterface :: Attributes,nt_Inh_CInterface :: NontermIdent,o_case_Inh_CInterface :: Bool,o_cata_Inh_CInterface :: Bool,o_costcentre_Inh_CInterface :: Bool,o_data_Inh_CInterface :: Maybe Bool,o_linePragmas_Inh_CInterface :: Bool,o_newtypes_Inh_CInterface :: Bool,o_pretty_Inh_CInterface :: Bool,o_rename_Inh_CInterface :: Bool,o_sem_Inh_CInterface :: Bool,o_sig_Inh_CInterface :: Bool,o_splitsems_Inh_CInterface :: Bool,o_strictwrap_Inh_CInterface :: Bool,o_traces_Inh_CInterface :: Bool,o_unbox_Inh_CInterface :: Bool,paramMap_Inh_CInterface :: ParamMap,prefix_Inh_CInterface :: String,syn_Inh_CInterface :: Attributes} +data Syn_CInterface = Syn_CInterface {comments_Syn_CInterface :: [String],semDom_Syn_CInterface :: [Decl],semDomUnfoldGath_Syn_CInterface :: Map (NontermIdent, Int) ([String], Code.Type),wrapDecls_Syn_CInterface :: Decls} +wrap_CInterface (T_CInterface sem) (Inh_CInterface _lhsIinh _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIparamMap _lhsIprefix _lhsIsyn) = + (let ( _lhsOcomments,_lhsOsemDom,_lhsOsemDomUnfoldGath,_lhsOwrapDecls) = + (sem _lhsIinh _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIparamMap _lhsIprefix _lhsIsyn) + in (Syn_CInterface _lhsOcomments _lhsOsemDom _lhsOsemDomUnfoldGath _lhsOwrapDecls)) +sem_CInterface_CInterface :: T_CSegments -> + T_CInterface +sem_CInterface_CInterface (T_CSegments seg_) = + (T_CInterface (\ _lhsIinh + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_costcentre + _lhsIo_data + _lhsIo_linePragmas + _lhsIo_newtypes + _lhsIo_pretty + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_splitsems + _lhsIo_strictwrap + _lhsIo_traces + _lhsIo_unbox + _lhsIparamMap + _lhsIprefix + _lhsIsyn -> + (let _segOnr :: Int + _lhsOsemDom :: ([Decl]) + _lhsOcomments :: ([String]) + _lhsOsemDomUnfoldGath :: (Map (NontermIdent, Int) ([String], Code.Type)) + _lhsOwrapDecls :: Decls + _segOinh :: Attributes + _segOnt :: NontermIdent + _segOo_case :: Bool + _segOo_cata :: Bool + _segOo_costcentre :: Bool + _segOo_data :: (Maybe Bool) + _segOo_linePragmas :: Bool + _segOo_newtypes :: Bool + _segOo_pretty :: Bool + _segOo_rename :: Bool + _segOo_sem :: Bool + _segOo_sig :: Bool + _segOo_splitsems :: Bool + _segOo_strictwrap :: Bool + _segOo_traces :: Bool + _segOo_unbox :: Bool + _segOparamMap :: ParamMap + _segOprefix :: String + _segOsyn :: Attributes + _segIcomments :: ([String]) + _segIisNil :: Bool + _segIsemDom :: ([Decl]) + _segIsemDomUnfoldGath :: (Map (NontermIdent, Int) ([String], Code.Type)) + _segIwrapDecls :: Decls + -- "GenerateCode.ag"(line 198, column 17) + _segOnr = + 0 + -- "GenerateCode.ag"(line 570, column 18) + _lhsOsemDom = + Comment "semantic domain" : _segIsemDom + -- use rule "GenerateCode.ag"(line 714, column 52) + _lhsOcomments = + _segIcomments + -- use rule "GenerateCode.ag"(line 587, column 86) + _lhsOsemDomUnfoldGath = + _segIsemDomUnfoldGath + -- use rule "GenerateCode.ag"(line 663, column 52) + _lhsOwrapDecls = + _segIwrapDecls + -- copy rule (down) + _segOinh = + _lhsIinh + -- copy rule (down) + _segOnt = + _lhsInt + -- copy rule (down) + _segOo_case = + _lhsIo_case + -- copy rule (down) + _segOo_cata = + _lhsIo_cata + -- copy rule (down) + _segOo_costcentre = + _lhsIo_costcentre + -- copy rule (down) + _segOo_data = + _lhsIo_data + -- copy rule (down) + _segOo_linePragmas = + _lhsIo_linePragmas + -- copy rule (down) + _segOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _segOo_pretty = + _lhsIo_pretty + -- copy rule (down) + _segOo_rename = + _lhsIo_rename + -- copy rule (down) + _segOo_sem = + _lhsIo_sem + -- copy rule (down) + _segOo_sig = + _lhsIo_sig + -- copy rule (down) + _segOo_splitsems = + _lhsIo_splitsems + -- copy rule (down) + _segOo_strictwrap = + _lhsIo_strictwrap + -- copy rule (down) + _segOo_traces = + _lhsIo_traces + -- copy rule (down) + _segOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _segOparamMap = + _lhsIparamMap + -- copy rule (down) + _segOprefix = + _lhsIprefix + -- copy rule (down) + _segOsyn = + _lhsIsyn + ( _segIcomments,_segIisNil,_segIsemDom,_segIsemDomUnfoldGath,_segIwrapDecls) = + (seg_ _segOinh _segOnr _segOnt _segOo_case _segOo_cata _segOo_costcentre _segOo_data _segOo_linePragmas _segOo_newtypes _segOo_pretty _segOo_rename _segOo_sem _segOo_sig _segOo_splitsems _segOo_strictwrap _segOo_traces _segOo_unbox _segOparamMap _segOprefix _segOsyn) + in ( _lhsOcomments,_lhsOsemDom,_lhsOsemDomUnfoldGath,_lhsOwrapDecls)))) +-- CNonterminal ------------------------------------------------ +{- + visit 0: + inherited attributes: + allPragmas : PragmaMap + contextMap : ContextMap + derivings : Derivings + o_case : Bool + o_cata : Bool + o_costcentre : Bool + o_data : Maybe Bool + o_linePragmas : Bool + o_newtypes : Bool + o_pretty : Bool + o_rename : Bool + o_sem : Bool + o_sig : Bool + o_splitsems : Bool + o_strictwrap : Bool + o_traces : Bool + o_unbox : Bool + paramMap : ParamMap + prefix : String + typeSyns : TypeSyns + unfoldSemDom : NontermIdent -> Int -> [String] -> Code.Type + with_sig : Bool + wrappers : Set NontermIdent + chained attribute: + errors : Seq Error + synthesized attributes: + allTpsFound : Bool + chunks : Chunks + semDomUnfoldGath : Map (NontermIdent, Int) ([String], Code.Type) + alternatives: + alternative CNonterminal: + child nt : {NontermIdent} + child params : {[Identifier]} + child inh : {Attributes} + child syn : {Attributes} + child prods : CProductions + child inter : CInterface + visit 0: + local _tup1 : {(Attributes,Attributes,NontermIdent)} + local _tup2 : {(Attributes,Attributes,NontermIdent)} + local semWrapper : _ + local comment : _ + local dataDef : _ + local cataFun : _ +-} +-- cata +sem_CNonterminal :: CNonterminal -> + T_CNonterminal +sem_CNonterminal (CNonterminal _nt _params _inh _syn _prods _inter) = + (sem_CNonterminal_CNonterminal _nt _params _inh _syn (sem_CProductions _prods) (sem_CInterface _inter)) +-- semantic domain +newtype T_CNonterminal = T_CNonterminal (PragmaMap -> + ContextMap -> + Derivings -> + (Seq Error) -> + Bool -> + Bool -> + Bool -> + (Maybe Bool) -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + ParamMap -> + String -> + TypeSyns -> + (NontermIdent -> Int -> [String] -> Code.Type) -> + Bool -> + (Set NontermIdent) -> + ( Bool,Chunks,(Seq Error),(Map (NontermIdent, Int) ([String], Code.Type)))) +data Inh_CNonterminal = Inh_CNonterminal {allPragmas_Inh_CNonterminal :: PragmaMap,contextMap_Inh_CNonterminal :: ContextMap,derivings_Inh_CNonterminal :: Derivings,errors_Inh_CNonterminal :: Seq Error,o_case_Inh_CNonterminal :: Bool,o_cata_Inh_CNonterminal :: Bool,o_costcentre_Inh_CNonterminal :: Bool,o_data_Inh_CNonterminal :: Maybe Bool,o_linePragmas_Inh_CNonterminal :: Bool,o_newtypes_Inh_CNonterminal :: Bool,o_pretty_Inh_CNonterminal :: Bool,o_rename_Inh_CNonterminal :: Bool,o_sem_Inh_CNonterminal :: Bool,o_sig_Inh_CNonterminal :: Bool,o_splitsems_Inh_CNonterminal :: Bool,o_strictwrap_Inh_CNonterminal :: Bool,o_traces_Inh_CNonterminal :: Bool,o_unbox_Inh_CNonterminal :: Bool,paramMap_Inh_CNonterminal :: ParamMap,prefix_Inh_CNonterminal :: String,typeSyns_Inh_CNonterminal :: TypeSyns,unfoldSemDom_Inh_CNonterminal :: NontermIdent -> Int -> [String] -> Code.Type,with_sig_Inh_CNonterminal :: Bool,wrappers_Inh_CNonterminal :: Set NontermIdent} +data Syn_CNonterminal = Syn_CNonterminal {allTpsFound_Syn_CNonterminal :: Bool,chunks_Syn_CNonterminal :: Chunks,errors_Syn_CNonterminal :: Seq Error,semDomUnfoldGath_Syn_CNonterminal :: Map (NontermIdent, Int) ([String], Code.Type)} +wrap_CNonterminal (T_CNonterminal sem) (Inh_CNonterminal _lhsIallPragmas _lhsIcontextMap _lhsIderivings _lhsIerrors _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIparamMap _lhsIprefix _lhsItypeSyns _lhsIunfoldSemDom _lhsIwith_sig _lhsIwrappers) = + (let ( _lhsOallTpsFound,_lhsOchunks,_lhsOerrors,_lhsOsemDomUnfoldGath) = + (sem _lhsIallPragmas _lhsIcontextMap _lhsIderivings _lhsIerrors _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIparamMap _lhsIprefix _lhsItypeSyns _lhsIunfoldSemDom _lhsIwith_sig _lhsIwrappers) + in (Syn_CNonterminal _lhsOallTpsFound _lhsOchunks _lhsOerrors _lhsOsemDomUnfoldGath)) +sem_CNonterminal_CNonterminal :: NontermIdent -> + ([Identifier]) -> + Attributes -> + Attributes -> + T_CProductions -> + T_CInterface -> + T_CNonterminal +sem_CNonterminal_CNonterminal nt_ params_ inh_ syn_ (T_CProductions prods_) (T_CInterface inter_) = + (T_CNonterminal (\ _lhsIallPragmas + _lhsIcontextMap + _lhsIderivings + _lhsIerrors + _lhsIo_case + _lhsIo_cata + _lhsIo_costcentre + _lhsIo_data + _lhsIo_linePragmas + _lhsIo_newtypes + _lhsIo_pretty + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_splitsems + _lhsIo_strictwrap + _lhsIo_traces + _lhsIo_unbox + _lhsIparamMap + _lhsIprefix + _lhsItypeSyns + _lhsIunfoldSemDom + _lhsIwith_sig + _lhsIwrappers -> + (let __tup1 :: ((Attributes,Attributes,NontermIdent)) + _interOinh :: Attributes + _interOsyn :: Attributes + _interOnt :: NontermIdent + __tup2 :: ((Attributes,Attributes,NontermIdent)) + _prodsOinh :: Attributes + _prodsOsyn :: Attributes + _prodsOnt :: NontermIdent + _lhsOchunks :: Chunks + _lhsOallTpsFound :: Bool + _lhsOerrors :: (Seq Error) + _lhsOsemDomUnfoldGath :: (Map (NontermIdent, Int) ([String], Code.Type)) + _prodsOallPragmas :: PragmaMap + _prodsOcontextMap :: ContextMap + _prodsOerrors :: (Seq Error) + _prodsOo_case :: Bool + _prodsOo_cata :: Bool + _prodsOo_costcentre :: Bool + _prodsOo_data :: (Maybe Bool) + _prodsOo_linePragmas :: Bool + _prodsOo_newtypes :: Bool + _prodsOo_pretty :: Bool + _prodsOo_rename :: Bool + _prodsOo_sem :: Bool + _prodsOo_sig :: Bool + _prodsOo_splitsems :: Bool + _prodsOo_strictwrap :: Bool + _prodsOo_traces :: Bool + _prodsOo_unbox :: Bool + _prodsOparamMap :: ParamMap + _prodsOprefix :: String + _prodsOunfoldSemDom :: (NontermIdent -> Int -> [String] -> Code.Type) + _prodsOwith_sig :: Bool + _interOo_case :: Bool + _interOo_cata :: Bool + _interOo_costcentre :: Bool + _interOo_data :: (Maybe Bool) + _interOo_linePragmas :: Bool + _interOo_newtypes :: Bool + _interOo_pretty :: Bool + _interOo_rename :: Bool + _interOo_sem :: Bool + _interOo_sig :: Bool + _interOo_splitsems :: Bool + _interOo_strictwrap :: Bool + _interOo_traces :: Bool + _interOo_unbox :: Bool + _interOparamMap :: ParamMap + _interOprefix :: String + _prodsIallTpsFound :: Bool + _prodsIcataAlts :: Decls + _prodsIcomments :: ([String]) + _prodsIdataAlts :: DataAlts + _prodsIdecls :: Decls + _prodsIerrors :: (Seq Error) + _prodsIsemNames :: ([String]) + _interIcomments :: ([String]) + _interIsemDom :: ([Decl]) + _interIsemDomUnfoldGath :: (Map (NontermIdent, Int) ([String], Code.Type)) + _interIwrapDecls :: Decls + -- "GenerateCode.ag"(line 75, column 26) + __tup1 = + (inh_,syn_,nt_) + -- "GenerateCode.ag"(line 75, column 26) + (_interOinh,_,_) = + __tup1 + -- "GenerateCode.ag"(line 75, column 26) + (_,_interOsyn,_) = + __tup1 + -- "GenerateCode.ag"(line 75, column 26) + (_,_,_interOnt) = + __tup1 + -- "GenerateCode.ag"(line 76, column 25) + __tup2 = + (inh_,syn_,nt_) + -- "GenerateCode.ag"(line 76, column 25) + (_prodsOinh,_,_) = + __tup2 + -- "GenerateCode.ag"(line 76, column 25) + (_,_prodsOsyn,_) = + __tup2 + -- "GenerateCode.ag"(line 76, column 25) + (_,_,_prodsOnt) = + __tup2 + -- "GenerateCode.ag"(line 635, column 18) + _semWrapper = + let params' = map getName params_ + inhAttrs = Map.toList inh_ + synAttrs = Map.toList syn_ + inhVars = [ SimpleExpr (attrname True _LHS a) | (a,_) <- inhAttrs ] + synVars = [ SimpleExpr (attrname False _LHS a) | (a,_) <- synAttrs ] + var = "sem" + wrapNT = "wrap" ++ "_" ++ getName nt_ + inhNT = "Inh" ++ "_" ++ getName nt_ + synNT = "Syn" ++ "_" ++ getName nt_ + varPat = if _lhsIo_newtypes + then App (sdtype nt_) [SimpleExpr var] + else SimpleExpr var + evalTp | null params' = id + | otherwise = idEvalType + evalTpCommon t | null params' = t + | otherwise = case (evalTp (SimpleType t)) of SimpleType t' -> t' + appParams nm = TypeApp (SimpleType nm) (map SimpleType params') + typeSig = TSig wrapNT (evalTp $ appParams (sdtype nt_) `Arr` (appParams inhNT `Arr` appParams synNT)) + mkstrict = if _lhsIo_strictwrap then (\x -> "!(" ++ x ++ ")") else id + mkdata n attrs = Data n params' [Record n [(getName f++"_"++n,mkstrict $ evalTpCommon $ typeToHaskellString (Just nt_) params' t) | (f,t) <- attrs]] False [] + datas = [mkdata inhNT inhAttrs, mkdata synNT synAttrs] + in datas ++ [ typeSig + , Decl (Fun wrapNT [varPat, App inhNT inhVars]) + (Let _interIwrapDecls (App synNT synVars)) + Set.empty Set.empty + ] + -- "GenerateCode.ag"(line 710, column 18) + _comment = + Comment . unlines . map ind $ ( _interIcomments ++ ("alternatives:" : map ind _prodsIcomments) ) + -- "GenerateCode.ag"(line 764, column 19) + _lhsOchunks = + [ Chunk (getName nt_) + (Comment (getName nt_ ++ " " ++ replicate (60 - length (getName nt_)) '-')) + (if _lhsIo_pretty then [_comment ] else []) + (if isJust _lhsIo_data then [_dataDef ] else []) + (if _lhsIo_cata then _cataFun else []) + (if _lhsIo_sig then _interIsemDom else []) + (if nt_ `Set.member` _lhsIwrappers then _semWrapper else []) + (if _lhsIo_sem then _prodsIdecls else []) + (if _lhsIo_sem then _prodsIsemNames else []) + ] + -- "GenerateCode.ag"(line 815, column 18) + _dataDef = + let params' = map getName params_ + typeSyn tp = let theType = + case tp of + CommonTypes.Maybe t -> SimpleType ("Maybe (" ++ typeToHaskellString (Just nt_) params' t ++")") + CommonTypes.List t -> Code.List $ SimpleType (typeToHaskellString (Just nt_) params' t) + CommonTypes.Tuple ts -> Code.TupleType [SimpleType (typeToHaskellString (Just nt_) params' t) + | (_,t) <- ts + ] + in Code.Type (getName nt_) params' theType + derivings = maybe [] (map getName . Set.toList) (Map.lookup nt_ _lhsIderivings) + dataDef = Data (getName nt_) (map getName params_) _prodsIdataAlts (maybe False id _lhsIo_data) derivings + in maybe dataDef typeSyn $ lookup nt_ _lhsItypeSyns + -- "GenerateCode.ag"(line 844, column 18) + _cataFun = + let appParams nm = TypeApp (SimpleType nm) (map SimpleType (map getName params_)) + evalTp | null params_ = id + | otherwise = idEvalType + tSig = TSig (cataname _lhsIprefix nt_) + (appContext _lhsIcontextMap nt_ $ evalTp $ appParams (getName nt_) `Arr` appParams (sdtype nt_)) + special typ = case typ of + CommonTypes.List tp -> + let cons = SimpleExpr (semname _lhsIprefix nt_ (identifier "Cons")) + nil = SimpleExpr (semname _lhsIprefix nt_ (identifier "Nil" )) + arg = SimpleExpr "list" + rarg = case tp of + NT t _ -> SimpleExpr ("(Prelude.map " ++ (cataname _lhsIprefix t) ++ " list)") + _ -> arg + lhs = Fun (cataname _lhsIprefix nt_) [arg] + rhs = (App "Prelude.foldr" [cons,nil,rarg]) + in [Decl lhs rhs Set.empty Set.empty] + CommonTypes.Maybe tp -> + let just = semname _lhsIprefix nt_ (identifier "Just") + nothing = semname _lhsIprefix nt_ (identifier "Nothing" ) + arg = SimpleExpr "x" + rarg = case tp of + NT t _ -> App (cataname _lhsIprefix t) [arg] + _ -> arg + lhs a = Fun (cataname _lhsIprefix nt_) [a] + in [Decl (lhs (App "Prelude.Just" [arg])) (App just [rarg]) Set.empty Set.empty + ,Decl (lhs (SimpleExpr "Prelude.Nothing")) (SimpleExpr nothing) Set.empty Set.empty + ] + CommonTypes.Tuple tps -> + let con = semname _lhsIprefix nt_ (identifier "Tuple") + tps' = [ (SimpleExpr (getName x),y) | (x,y) <- tps] + rargs = map rarg tps' + rarg (n, tp) = case tp of + NT t _ -> App (cataname _lhsIprefix t) [n] + _ -> n + lhs = Fun (cataname _lhsIprefix nt_) [TupleExpr (map fst tps')] + rhs = App con rargs + in [Decl lhs rhs Set.empty Set.empty] + in Comment "cata" : + (if _lhsIo_sig then [tSig] else []) ++ + maybe _prodsIcataAlts special (lookup nt_ _lhsItypeSyns) + -- use rule "GenerateCode.ag"(line 682, column 39) + _lhsOallTpsFound = + _prodsIallTpsFound + -- use rule "GenerateCode.ag"(line 695, column 32) + _lhsOerrors = + _prodsIerrors + -- use rule "GenerateCode.ag"(line 587, column 86) + _lhsOsemDomUnfoldGath = + _interIsemDomUnfoldGath + -- copy rule (down) + _prodsOallPragmas = + _lhsIallPragmas + -- copy rule (down) + _prodsOcontextMap = + _lhsIcontextMap + -- copy rule (down) + _prodsOerrors = + _lhsIerrors + -- copy rule (down) + _prodsOo_case = + _lhsIo_case + -- copy rule (down) + _prodsOo_cata = + _lhsIo_cata + -- copy rule (down) + _prodsOo_costcentre = + _lhsIo_costcentre + -- copy rule (down) + _prodsOo_data = + _lhsIo_data + -- copy rule (down) + _prodsOo_linePragmas = + _lhsIo_linePragmas + -- copy rule (down) + _prodsOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _prodsOo_pretty = + _lhsIo_pretty + -- copy rule (down) + _prodsOo_rename = + _lhsIo_rename + -- copy rule (down) + _prodsOo_sem = + _lhsIo_sem + -- copy rule (down) + _prodsOo_sig = + _lhsIo_sig + -- copy rule (down) + _prodsOo_splitsems = + _lhsIo_splitsems + -- copy rule (down) + _prodsOo_strictwrap = + _lhsIo_strictwrap + -- copy rule (down) + _prodsOo_traces = + _lhsIo_traces + -- copy rule (down) + _prodsOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _prodsOparamMap = + _lhsIparamMap + -- copy rule (down) + _prodsOprefix = + _lhsIprefix + -- copy rule (down) + _prodsOunfoldSemDom = + _lhsIunfoldSemDom + -- copy rule (down) + _prodsOwith_sig = + _lhsIwith_sig + -- copy rule (down) + _interOo_case = + _lhsIo_case + -- copy rule (down) + _interOo_cata = + _lhsIo_cata + -- copy rule (down) + _interOo_costcentre = + _lhsIo_costcentre + -- copy rule (down) + _interOo_data = + _lhsIo_data + -- copy rule (down) + _interOo_linePragmas = + _lhsIo_linePragmas + -- copy rule (down) + _interOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _interOo_pretty = + _lhsIo_pretty + -- copy rule (down) + _interOo_rename = + _lhsIo_rename + -- copy rule (down) + _interOo_sem = + _lhsIo_sem + -- copy rule (down) + _interOo_sig = + _lhsIo_sig + -- copy rule (down) + _interOo_splitsems = + _lhsIo_splitsems + -- copy rule (down) + _interOo_strictwrap = + _lhsIo_strictwrap + -- copy rule (down) + _interOo_traces = + _lhsIo_traces + -- copy rule (down) + _interOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _interOparamMap = + _lhsIparamMap + -- copy rule (down) + _interOprefix = + _lhsIprefix + ( _prodsIallTpsFound,_prodsIcataAlts,_prodsIcomments,_prodsIdataAlts,_prodsIdecls,_prodsIerrors,_prodsIsemNames) = + (prods_ _prodsOallPragmas _prodsOcontextMap _prodsOerrors _prodsOinh _prodsOnt _prodsOo_case _prodsOo_cata _prodsOo_costcentre _prodsOo_data _prodsOo_linePragmas _prodsOo_newtypes _prodsOo_pretty _prodsOo_rename _prodsOo_sem _prodsOo_sig _prodsOo_splitsems _prodsOo_strictwrap _prodsOo_traces _prodsOo_unbox _prodsOparamMap _prodsOprefix _prodsOsyn _prodsOunfoldSemDom _prodsOwith_sig) + ( _interIcomments,_interIsemDom,_interIsemDomUnfoldGath,_interIwrapDecls) = + (inter_ _interOinh _interOnt _interOo_case _interOo_cata _interOo_costcentre _interOo_data _interOo_linePragmas _interOo_newtypes _interOo_pretty _interOo_rename _interOo_sem _interOo_sig _interOo_splitsems _interOo_strictwrap _interOo_traces _interOo_unbox _interOparamMap _interOprefix _interOsyn) + in ( _lhsOallTpsFound,_lhsOchunks,_lhsOerrors,_lhsOsemDomUnfoldGath)))) +-- CNonterminals ----------------------------------------------- +{- + visit 0: + inherited attributes: + allPragmas : PragmaMap + contextMap : ContextMap + derivings : Derivings + o_case : Bool + o_cata : Bool + o_costcentre : Bool + o_data : Maybe Bool + o_linePragmas : Bool + o_newtypes : Bool + o_pretty : Bool + o_rename : Bool + o_sem : Bool + o_sig : Bool + o_splitsems : Bool + o_strictwrap : Bool + o_traces : Bool + o_unbox : Bool + paramMap : ParamMap + prefix : String + typeSyns : TypeSyns + unfoldSemDom : NontermIdent -> Int -> [String] -> Code.Type + with_sig : Bool + wrappers : Set NontermIdent + chained attribute: + errors : Seq Error + synthesized attributes: + allTpsFound : Bool + chunks : Chunks + semDomUnfoldGath : Map (NontermIdent, Int) ([String], Code.Type) + alternatives: + alternative Cons: + child hd : CNonterminal + child tl : CNonterminals + alternative Nil: +-} +-- cata +sem_CNonterminals :: CNonterminals -> + T_CNonterminals +sem_CNonterminals list = + (Prelude.foldr sem_CNonterminals_Cons sem_CNonterminals_Nil (Prelude.map sem_CNonterminal list)) +-- semantic domain +newtype T_CNonterminals = T_CNonterminals (PragmaMap -> + ContextMap -> + Derivings -> + (Seq Error) -> + Bool -> + Bool -> + Bool -> + (Maybe Bool) -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + ParamMap -> + String -> + TypeSyns -> + (NontermIdent -> Int -> [String] -> Code.Type) -> + Bool -> + (Set NontermIdent) -> + ( Bool,Chunks,(Seq Error),(Map (NontermIdent, Int) ([String], Code.Type)))) +data Inh_CNonterminals = Inh_CNonterminals {allPragmas_Inh_CNonterminals :: PragmaMap,contextMap_Inh_CNonterminals :: ContextMap,derivings_Inh_CNonterminals :: Derivings,errors_Inh_CNonterminals :: Seq Error,o_case_Inh_CNonterminals :: Bool,o_cata_Inh_CNonterminals :: Bool,o_costcentre_Inh_CNonterminals :: Bool,o_data_Inh_CNonterminals :: Maybe Bool,o_linePragmas_Inh_CNonterminals :: Bool,o_newtypes_Inh_CNonterminals :: Bool,o_pretty_Inh_CNonterminals :: Bool,o_rename_Inh_CNonterminals :: Bool,o_sem_Inh_CNonterminals :: Bool,o_sig_Inh_CNonterminals :: Bool,o_splitsems_Inh_CNonterminals :: Bool,o_strictwrap_Inh_CNonterminals :: Bool,o_traces_Inh_CNonterminals :: Bool,o_unbox_Inh_CNonterminals :: Bool,paramMap_Inh_CNonterminals :: ParamMap,prefix_Inh_CNonterminals :: String,typeSyns_Inh_CNonterminals :: TypeSyns,unfoldSemDom_Inh_CNonterminals :: NontermIdent -> Int -> [String] -> Code.Type,with_sig_Inh_CNonterminals :: Bool,wrappers_Inh_CNonterminals :: Set NontermIdent} +data Syn_CNonterminals = Syn_CNonterminals {allTpsFound_Syn_CNonterminals :: Bool,chunks_Syn_CNonterminals :: Chunks,errors_Syn_CNonterminals :: Seq Error,semDomUnfoldGath_Syn_CNonterminals :: Map (NontermIdent, Int) ([String], Code.Type)} +wrap_CNonterminals (T_CNonterminals sem) (Inh_CNonterminals _lhsIallPragmas _lhsIcontextMap _lhsIderivings _lhsIerrors _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIparamMap _lhsIprefix _lhsItypeSyns _lhsIunfoldSemDom _lhsIwith_sig _lhsIwrappers) = + (let ( _lhsOallTpsFound,_lhsOchunks,_lhsOerrors,_lhsOsemDomUnfoldGath) = + (sem _lhsIallPragmas _lhsIcontextMap _lhsIderivings _lhsIerrors _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIparamMap _lhsIprefix _lhsItypeSyns _lhsIunfoldSemDom _lhsIwith_sig _lhsIwrappers) + in (Syn_CNonterminals _lhsOallTpsFound _lhsOchunks _lhsOerrors _lhsOsemDomUnfoldGath)) +sem_CNonterminals_Cons :: T_CNonterminal -> + T_CNonterminals -> + T_CNonterminals +sem_CNonterminals_Cons (T_CNonterminal hd_) (T_CNonterminals tl_) = + (T_CNonterminals (\ _lhsIallPragmas + _lhsIcontextMap + _lhsIderivings + _lhsIerrors + _lhsIo_case + _lhsIo_cata + _lhsIo_costcentre + _lhsIo_data + _lhsIo_linePragmas + _lhsIo_newtypes + _lhsIo_pretty + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_splitsems + _lhsIo_strictwrap + _lhsIo_traces + _lhsIo_unbox + _lhsIparamMap + _lhsIprefix + _lhsItypeSyns + _lhsIunfoldSemDom + _lhsIwith_sig + _lhsIwrappers -> + (let _lhsOallTpsFound :: Bool + _lhsOchunks :: Chunks + _lhsOerrors :: (Seq Error) + _lhsOsemDomUnfoldGath :: (Map (NontermIdent, Int) ([String], Code.Type)) + _hdOallPragmas :: PragmaMap + _hdOcontextMap :: ContextMap + _hdOderivings :: Derivings + _hdOerrors :: (Seq Error) + _hdOo_case :: Bool + _hdOo_cata :: Bool + _hdOo_costcentre :: Bool + _hdOo_data :: (Maybe Bool) + _hdOo_linePragmas :: Bool + _hdOo_newtypes :: Bool + _hdOo_pretty :: Bool + _hdOo_rename :: Bool + _hdOo_sem :: Bool + _hdOo_sig :: Bool + _hdOo_splitsems :: Bool + _hdOo_strictwrap :: Bool + _hdOo_traces :: Bool + _hdOo_unbox :: Bool + _hdOparamMap :: ParamMap + _hdOprefix :: String + _hdOtypeSyns :: TypeSyns + _hdOunfoldSemDom :: (NontermIdent -> Int -> [String] -> Code.Type) + _hdOwith_sig :: Bool + _hdOwrappers :: (Set NontermIdent) + _tlOallPragmas :: PragmaMap + _tlOcontextMap :: ContextMap + _tlOderivings :: Derivings + _tlOerrors :: (Seq Error) + _tlOo_case :: Bool + _tlOo_cata :: Bool + _tlOo_costcentre :: Bool + _tlOo_data :: (Maybe Bool) + _tlOo_linePragmas :: Bool + _tlOo_newtypes :: Bool + _tlOo_pretty :: Bool + _tlOo_rename :: Bool + _tlOo_sem :: Bool + _tlOo_sig :: Bool + _tlOo_splitsems :: Bool + _tlOo_strictwrap :: Bool + _tlOo_traces :: Bool + _tlOo_unbox :: Bool + _tlOparamMap :: ParamMap + _tlOprefix :: String + _tlOtypeSyns :: TypeSyns + _tlOunfoldSemDom :: (NontermIdent -> Int -> [String] -> Code.Type) + _tlOwith_sig :: Bool + _tlOwrappers :: (Set NontermIdent) + _hdIallTpsFound :: Bool + _hdIchunks :: Chunks + _hdIerrors :: (Seq Error) + _hdIsemDomUnfoldGath :: (Map (NontermIdent, Int) ([String], Code.Type)) + _tlIallTpsFound :: Bool + _tlIchunks :: Chunks + _tlIerrors :: (Seq Error) + _tlIsemDomUnfoldGath :: (Map (NontermIdent, Int) ([String], Code.Type)) + -- use rule "GenerateCode.ag"(line 682, column 39) + _lhsOallTpsFound = + _hdIallTpsFound && _tlIallTpsFound + -- use rule "GenerateCode.ag"(line 756, column 49) + _lhsOchunks = + _hdIchunks ++ _tlIchunks + -- use rule "GenerateCode.ag"(line 695, column 32) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- use rule "GenerateCode.ag"(line 587, column 86) + _lhsOsemDomUnfoldGath = + _hdIsemDomUnfoldGath `Map.union` _tlIsemDomUnfoldGath + -- copy rule (down) + _hdOallPragmas = + _lhsIallPragmas + -- copy rule (down) + _hdOcontextMap = + _lhsIcontextMap + -- copy rule (down) + _hdOderivings = + _lhsIderivings + -- copy rule (down) + _hdOerrors = + _lhsIerrors + -- copy rule (down) + _hdOo_case = + _lhsIo_case + -- copy rule (down) + _hdOo_cata = + _lhsIo_cata + -- copy rule (down) + _hdOo_costcentre = + _lhsIo_costcentre + -- copy rule (down) + _hdOo_data = + _lhsIo_data + -- copy rule (down) + _hdOo_linePragmas = + _lhsIo_linePragmas + -- copy rule (down) + _hdOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _hdOo_pretty = + _lhsIo_pretty + -- copy rule (down) + _hdOo_rename = + _lhsIo_rename + -- copy rule (down) + _hdOo_sem = + _lhsIo_sem + -- copy rule (down) + _hdOo_sig = + _lhsIo_sig + -- copy rule (down) + _hdOo_splitsems = + _lhsIo_splitsems + -- copy rule (down) + _hdOo_strictwrap = + _lhsIo_strictwrap + -- copy rule (down) + _hdOo_traces = + _lhsIo_traces + -- copy rule (down) + _hdOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _hdOparamMap = + _lhsIparamMap + -- copy rule (down) + _hdOprefix = + _lhsIprefix + -- copy rule (down) + _hdOtypeSyns = + _lhsItypeSyns + -- copy rule (down) + _hdOunfoldSemDom = + _lhsIunfoldSemDom + -- copy rule (down) + _hdOwith_sig = + _lhsIwith_sig + -- copy rule (down) + _hdOwrappers = + _lhsIwrappers + -- copy rule (down) + _tlOallPragmas = + _lhsIallPragmas + -- copy rule (down) + _tlOcontextMap = + _lhsIcontextMap + -- copy rule (down) + _tlOderivings = + _lhsIderivings + -- copy rule (chain) + _tlOerrors = + _hdIerrors + -- copy rule (down) + _tlOo_case = + _lhsIo_case + -- copy rule (down) + _tlOo_cata = + _lhsIo_cata + -- copy rule (down) + _tlOo_costcentre = + _lhsIo_costcentre + -- copy rule (down) + _tlOo_data = + _lhsIo_data + -- copy rule (down) + _tlOo_linePragmas = + _lhsIo_linePragmas + -- copy rule (down) + _tlOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _tlOo_pretty = + _lhsIo_pretty + -- copy rule (down) + _tlOo_rename = + _lhsIo_rename + -- copy rule (down) + _tlOo_sem = + _lhsIo_sem + -- copy rule (down) + _tlOo_sig = + _lhsIo_sig + -- copy rule (down) + _tlOo_splitsems = + _lhsIo_splitsems + -- copy rule (down) + _tlOo_strictwrap = + _lhsIo_strictwrap + -- copy rule (down) + _tlOo_traces = + _lhsIo_traces + -- copy rule (down) + _tlOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _tlOparamMap = + _lhsIparamMap + -- copy rule (down) + _tlOprefix = + _lhsIprefix + -- copy rule (down) + _tlOtypeSyns = + _lhsItypeSyns + -- copy rule (down) + _tlOunfoldSemDom = + _lhsIunfoldSemDom + -- copy rule (down) + _tlOwith_sig = + _lhsIwith_sig + -- copy rule (down) + _tlOwrappers = + _lhsIwrappers + ( _hdIallTpsFound,_hdIchunks,_hdIerrors,_hdIsemDomUnfoldGath) = + (hd_ _hdOallPragmas _hdOcontextMap _hdOderivings _hdOerrors _hdOo_case _hdOo_cata _hdOo_costcentre _hdOo_data _hdOo_linePragmas _hdOo_newtypes _hdOo_pretty _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_splitsems _hdOo_strictwrap _hdOo_traces _hdOo_unbox _hdOparamMap _hdOprefix _hdOtypeSyns _hdOunfoldSemDom _hdOwith_sig _hdOwrappers) + ( _tlIallTpsFound,_tlIchunks,_tlIerrors,_tlIsemDomUnfoldGath) = + (tl_ _tlOallPragmas _tlOcontextMap _tlOderivings _tlOerrors _tlOo_case _tlOo_cata _tlOo_costcentre _tlOo_data _tlOo_linePragmas _tlOo_newtypes _tlOo_pretty _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_splitsems _tlOo_strictwrap _tlOo_traces _tlOo_unbox _tlOparamMap _tlOprefix _tlOtypeSyns _tlOunfoldSemDom _tlOwith_sig _tlOwrappers) + in ( _lhsOallTpsFound,_lhsOchunks,_lhsOerrors,_lhsOsemDomUnfoldGath)))) +sem_CNonterminals_Nil :: T_CNonterminals +sem_CNonterminals_Nil = + (T_CNonterminals (\ _lhsIallPragmas + _lhsIcontextMap + _lhsIderivings + _lhsIerrors + _lhsIo_case + _lhsIo_cata + _lhsIo_costcentre + _lhsIo_data + _lhsIo_linePragmas + _lhsIo_newtypes + _lhsIo_pretty + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_splitsems + _lhsIo_strictwrap + _lhsIo_traces + _lhsIo_unbox + _lhsIparamMap + _lhsIprefix + _lhsItypeSyns + _lhsIunfoldSemDom + _lhsIwith_sig + _lhsIwrappers -> + (let _lhsOallTpsFound :: Bool + _lhsOchunks :: Chunks + _lhsOerrors :: (Seq Error) + _lhsOsemDomUnfoldGath :: (Map (NontermIdent, Int) ([String], Code.Type)) + -- use rule "GenerateCode.ag"(line 682, column 39) + _lhsOallTpsFound = + True + -- use rule "GenerateCode.ag"(line 756, column 49) + _lhsOchunks = + [] + -- use rule "GenerateCode.ag"(line 695, column 32) + _lhsOerrors = + Seq.empty + -- use rule "GenerateCode.ag"(line 587, column 86) + _lhsOsemDomUnfoldGath = + Map.empty + in ( _lhsOallTpsFound,_lhsOchunks,_lhsOerrors,_lhsOsemDomUnfoldGath)))) +-- CProduction ------------------------------------------------- +{- + visit 0: + inherited attributes: + allPragmas : PragmaMap + contextMap : ContextMap + inh : Attributes + nt : NontermIdent + o_case : Bool + o_cata : Bool + o_costcentre : Bool + o_data : Maybe Bool + o_linePragmas : Bool + o_newtypes : Bool + o_pretty : Bool + o_rename : Bool + o_sem : Bool + o_sig : Bool + o_splitsems : Bool + o_strictwrap : Bool + o_traces : Bool + o_unbox : Bool + paramMap : ParamMap + prefix : String + syn : Attributes + unfoldSemDom : NontermIdent -> Int -> [String] -> Code.Type + with_sig : Bool + chained attribute: + errors : Seq Error + synthesized attributes: + allTpsFound : Bool + cataAlt : Decl + comments : [String] + dataAlt : DataAlt + decls : Decls + semNames : [String] + alternatives: + alternative CProduction: + child con : {ConstructorIdent} + child visits : CVisits + child children : {[(Identifier,Type,Bool)]} + child terminals : {[Identifier]} + visit 0: + local paramInstMap : _ + local firstOrderChildren : _ + local params : _ +-} +-- cata +sem_CProduction :: CProduction -> + T_CProduction +sem_CProduction (CProduction _con _visits _children _terminals) = + (sem_CProduction_CProduction _con (sem_CVisits _visits) _children _terminals) +-- semantic domain +newtype T_CProduction = T_CProduction (PragmaMap -> + ContextMap -> + (Seq Error) -> + Attributes -> + NontermIdent -> + Bool -> + Bool -> + Bool -> + (Maybe Bool) -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + ParamMap -> + String -> + Attributes -> + (NontermIdent -> Int -> [String] -> Code.Type) -> + Bool -> + ( Bool,Decl,([String]),DataAlt,Decls,(Seq Error),([String]))) +data Inh_CProduction = Inh_CProduction {allPragmas_Inh_CProduction :: PragmaMap,contextMap_Inh_CProduction :: ContextMap,errors_Inh_CProduction :: Seq Error,inh_Inh_CProduction :: Attributes,nt_Inh_CProduction :: NontermIdent,o_case_Inh_CProduction :: Bool,o_cata_Inh_CProduction :: Bool,o_costcentre_Inh_CProduction :: Bool,o_data_Inh_CProduction :: Maybe Bool,o_linePragmas_Inh_CProduction :: Bool,o_newtypes_Inh_CProduction :: Bool,o_pretty_Inh_CProduction :: Bool,o_rename_Inh_CProduction :: Bool,o_sem_Inh_CProduction :: Bool,o_sig_Inh_CProduction :: Bool,o_splitsems_Inh_CProduction :: Bool,o_strictwrap_Inh_CProduction :: Bool,o_traces_Inh_CProduction :: Bool,o_unbox_Inh_CProduction :: Bool,paramMap_Inh_CProduction :: ParamMap,prefix_Inh_CProduction :: String,syn_Inh_CProduction :: Attributes,unfoldSemDom_Inh_CProduction :: NontermIdent -> Int -> [String] -> Code.Type,with_sig_Inh_CProduction :: Bool} +data Syn_CProduction = Syn_CProduction {allTpsFound_Syn_CProduction :: Bool,cataAlt_Syn_CProduction :: Decl,comments_Syn_CProduction :: [String],dataAlt_Syn_CProduction :: DataAlt,decls_Syn_CProduction :: Decls,errors_Syn_CProduction :: Seq Error,semNames_Syn_CProduction :: [String]} +wrap_CProduction (T_CProduction sem) (Inh_CProduction _lhsIallPragmas _lhsIcontextMap _lhsIerrors _lhsIinh _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIparamMap _lhsIprefix _lhsIsyn _lhsIunfoldSemDom _lhsIwith_sig) = + (let ( _lhsOallTpsFound,_lhsOcataAlt,_lhsOcomments,_lhsOdataAlt,_lhsOdecls,_lhsOerrors,_lhsOsemNames) = + (sem _lhsIallPragmas _lhsIcontextMap _lhsIerrors _lhsIinh _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIparamMap _lhsIprefix _lhsIsyn _lhsIunfoldSemDom _lhsIwith_sig) + in (Syn_CProduction _lhsOallTpsFound _lhsOcataAlt _lhsOcomments _lhsOdataAlt _lhsOdecls _lhsOerrors _lhsOsemNames)) +sem_CProduction_CProduction :: ConstructorIdent -> + T_CVisits -> + ([(Identifier,Type,Bool)]) -> + ([Identifier]) -> + T_CProduction +sem_CProduction_CProduction con_ (T_CVisits visits_) children_ terminals_ = + (T_CProduction (\ _lhsIallPragmas + _lhsIcontextMap + _lhsIerrors + _lhsIinh + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_costcentre + _lhsIo_data + _lhsIo_linePragmas + _lhsIo_newtypes + _lhsIo_pretty + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_splitsems + _lhsIo_strictwrap + _lhsIo_traces + _lhsIo_unbox + _lhsIparamMap + _lhsIprefix + _lhsIsyn + _lhsIunfoldSemDom + _lhsIwith_sig -> + (let _visitsOcon :: ConstructorIdent + _visitsOterminals :: ([Identifier]) + _visitsOnr :: Int + _visitsOchildren :: ([(Identifier,Type,Bool)]) + _visitsOinstVisitNrs :: (Map Identifier Int) + _lhsOcomments :: ([String]) + _lhsOdataAlt :: DataAlt + _lhsOcataAlt :: Decl + _lhsOallTpsFound :: Bool + _lhsOdecls :: Decls + _lhsOerrors :: (Seq Error) + _lhsOsemNames :: ([String]) + _visitsOallPragmas :: PragmaMap + _visitsOcontextMap :: ContextMap + _visitsOerrors :: (Seq Error) + _visitsOinh :: Attributes + _visitsOnt :: NontermIdent + _visitsOo_case :: Bool + _visitsOo_cata :: Bool + _visitsOo_costcentre :: Bool + _visitsOo_data :: (Maybe Bool) + _visitsOo_linePragmas :: Bool + _visitsOo_newtypes :: Bool + _visitsOo_pretty :: Bool + _visitsOo_rename :: Bool + _visitsOo_sem :: Bool + _visitsOo_sig :: Bool + _visitsOo_splitsems :: Bool + _visitsOo_strictwrap :: Bool + _visitsOo_traces :: Bool + _visitsOo_unbox :: Bool + _visitsOparamInstMap :: (Map Identifier (NontermIdent, [String])) + _visitsOparamMap :: ParamMap + _visitsOprefix :: String + _visitsOsyn :: Attributes + _visitsOunfoldSemDom :: (NontermIdent -> Int -> [String] -> Code.Type) + _visitsOwith_sig :: Bool + _visitsIallTpsFound :: Bool + _visitsIcomments :: ([String]) + _visitsIdecls :: Decls + _visitsIerrors :: (Seq Error) + _visitsIgatherInstVisitNrs :: (Map Identifier Int) + _visitsIintra :: Exprs + _visitsIintraVars :: (Set String) + _visitsIisNil :: Bool + _visitsIsemNames :: ([String]) + -- "GenerateCode.ag"(line 81, column 19) + _visitsOcon = + con_ + -- "GenerateCode.ag"(line 82, column 20) + _visitsOterminals = + terminals_ + -- "GenerateCode.ag"(line 94, column 7) + _paramInstMap = + Map.fromList [(nm, (extractNonterminal tp, tps)) | (nm,tp,_) <- children_, let tps = map cleanupArg $ nontermArgs tp, not (null tps) ] + -- "GenerateCode.ag"(line 194, column 18) + _visitsOnr = + 0 + -- "GenerateCode.ag"(line 316, column 18) + _visitsOchildren = + children_ + -- "GenerateCode.ag"(line 426, column 7) + _visitsOinstVisitNrs = + _visitsIgatherInstVisitNrs + -- "GenerateCode.ag"(line 725, column 17) + _firstOrderChildren = + filter (\(_,_,ho) -> not ho) children_ + -- "GenerateCode.ag"(line 726, column 18) + _lhsOcomments = + ("alternative " ++ getName con_ ++ ":") + : map ind ( map (\(x,y,_) -> makeLocalComment 14 "child" x (Just y)) _firstOrderChildren + ++ _visitsIcomments + ) + -- "GenerateCode.ag"(line 836, column 17) + _params = + map getName $ Map.findWithDefault [] _lhsInt _lhsIparamMap + -- "GenerateCode.ag"(line 837, column 17) + _lhsOdataAlt = + DataAlt (conname _lhsIo_rename _lhsInt con_) (map (\(_,t,_) -> typeToHaskellString (Just _lhsInt) _params t) _firstOrderChildren ) + -- "GenerateCode.ag"(line 895, column 17) + _lhsOcataAlt = + let lhs = Fun (cataname _lhsIprefix _lhsInt) [lhs_pat] + lhs_pat = App (conname _lhsIo_rename _lhsInt con_) + (map (\(n,_,_) -> SimpleExpr $ locname $ n) _firstOrderChildren ) + rhs = App (semname _lhsIprefix _lhsInt con_) + (map argument _firstOrderChildren ) + argument (nm,NT tp _,_) = App (cataname _lhsIprefix tp) + [SimpleExpr (locname nm)] + argument (nm, _,_) = SimpleExpr (locname nm) + in Decl lhs rhs Set.empty Set.empty + -- use rule "GenerateCode.ag"(line 682, column 39) + _lhsOallTpsFound = + _visitsIallTpsFound + -- use rule "GenerateCode.ag"(line 757, column 44) + _lhsOdecls = + _visitsIdecls + -- use rule "GenerateCode.ag"(line 695, column 32) + _lhsOerrors = + _visitsIerrors + -- use rule "GenerateCode.ag"(line 910, column 61) + _lhsOsemNames = + _visitsIsemNames + -- copy rule (down) + _visitsOallPragmas = + _lhsIallPragmas + -- copy rule (down) + _visitsOcontextMap = + _lhsIcontextMap + -- copy rule (down) + _visitsOerrors = + _lhsIerrors + -- copy rule (down) + _visitsOinh = + _lhsIinh + -- copy rule (down) + _visitsOnt = + _lhsInt + -- copy rule (down) + _visitsOo_case = + _lhsIo_case + -- copy rule (down) + _visitsOo_cata = + _lhsIo_cata + -- copy rule (down) + _visitsOo_costcentre = + _lhsIo_costcentre + -- copy rule (down) + _visitsOo_data = + _lhsIo_data + -- copy rule (down) + _visitsOo_linePragmas = + _lhsIo_linePragmas + -- copy rule (down) + _visitsOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _visitsOo_pretty = + _lhsIo_pretty + -- copy rule (down) + _visitsOo_rename = + _lhsIo_rename + -- copy rule (down) + _visitsOo_sem = + _lhsIo_sem + -- copy rule (down) + _visitsOo_sig = + _lhsIo_sig + -- copy rule (down) + _visitsOo_splitsems = + _lhsIo_splitsems + -- copy rule (down) + _visitsOo_strictwrap = + _lhsIo_strictwrap + -- copy rule (down) + _visitsOo_traces = + _lhsIo_traces + -- copy rule (down) + _visitsOo_unbox = + _lhsIo_unbox + -- copy rule (from local) + _visitsOparamInstMap = + _paramInstMap + -- copy rule (down) + _visitsOparamMap = + _lhsIparamMap + -- copy rule (down) + _visitsOprefix = + _lhsIprefix + -- copy rule (down) + _visitsOsyn = + _lhsIsyn + -- copy rule (down) + _visitsOunfoldSemDom = + _lhsIunfoldSemDom + -- copy rule (down) + _visitsOwith_sig = + _lhsIwith_sig + ( _visitsIallTpsFound,_visitsIcomments,_visitsIdecls,_visitsIerrors,_visitsIgatherInstVisitNrs,_visitsIintra,_visitsIintraVars,_visitsIisNil,_visitsIsemNames) = + (visits_ _visitsOallPragmas _visitsOchildren _visitsOcon _visitsOcontextMap _visitsOerrors _visitsOinh _visitsOinstVisitNrs _visitsOnr _visitsOnt _visitsOo_case _visitsOo_cata _visitsOo_costcentre _visitsOo_data _visitsOo_linePragmas _visitsOo_newtypes _visitsOo_pretty _visitsOo_rename _visitsOo_sem _visitsOo_sig _visitsOo_splitsems _visitsOo_strictwrap _visitsOo_traces _visitsOo_unbox _visitsOparamInstMap _visitsOparamMap _visitsOprefix _visitsOsyn _visitsOterminals _visitsOunfoldSemDom _visitsOwith_sig) + in ( _lhsOallTpsFound,_lhsOcataAlt,_lhsOcomments,_lhsOdataAlt,_lhsOdecls,_lhsOerrors,_lhsOsemNames)))) +-- CProductions ------------------------------------------------ +{- + visit 0: + inherited attributes: + allPragmas : PragmaMap + contextMap : ContextMap + inh : Attributes + nt : NontermIdent + o_case : Bool + o_cata : Bool + o_costcentre : Bool + o_data : Maybe Bool + o_linePragmas : Bool + o_newtypes : Bool + o_pretty : Bool + o_rename : Bool + o_sem : Bool + o_sig : Bool + o_splitsems : Bool + o_strictwrap : Bool + o_traces : Bool + o_unbox : Bool + paramMap : ParamMap + prefix : String + syn : Attributes + unfoldSemDom : NontermIdent -> Int -> [String] -> Code.Type + with_sig : Bool + chained attribute: + errors : Seq Error + synthesized attributes: + allTpsFound : Bool + cataAlts : Decls + comments : [String] + dataAlts : DataAlts + decls : Decls + semNames : [String] + alternatives: + alternative Cons: + child hd : CProduction + child tl : CProductions + alternative Nil: +-} +-- cata +sem_CProductions :: CProductions -> + T_CProductions +sem_CProductions list = + (Prelude.foldr sem_CProductions_Cons sem_CProductions_Nil (Prelude.map sem_CProduction list)) +-- semantic domain +newtype T_CProductions = T_CProductions (PragmaMap -> + ContextMap -> + (Seq Error) -> + Attributes -> + NontermIdent -> + Bool -> + Bool -> + Bool -> + (Maybe Bool) -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + ParamMap -> + String -> + Attributes -> + (NontermIdent -> Int -> [String] -> Code.Type) -> + Bool -> + ( Bool,Decls,([String]),DataAlts,Decls,(Seq Error),([String]))) +data Inh_CProductions = Inh_CProductions {allPragmas_Inh_CProductions :: PragmaMap,contextMap_Inh_CProductions :: ContextMap,errors_Inh_CProductions :: Seq Error,inh_Inh_CProductions :: Attributes,nt_Inh_CProductions :: NontermIdent,o_case_Inh_CProductions :: Bool,o_cata_Inh_CProductions :: Bool,o_costcentre_Inh_CProductions :: Bool,o_data_Inh_CProductions :: Maybe Bool,o_linePragmas_Inh_CProductions :: Bool,o_newtypes_Inh_CProductions :: Bool,o_pretty_Inh_CProductions :: Bool,o_rename_Inh_CProductions :: Bool,o_sem_Inh_CProductions :: Bool,o_sig_Inh_CProductions :: Bool,o_splitsems_Inh_CProductions :: Bool,o_strictwrap_Inh_CProductions :: Bool,o_traces_Inh_CProductions :: Bool,o_unbox_Inh_CProductions :: Bool,paramMap_Inh_CProductions :: ParamMap,prefix_Inh_CProductions :: String,syn_Inh_CProductions :: Attributes,unfoldSemDom_Inh_CProductions :: NontermIdent -> Int -> [String] -> Code.Type,with_sig_Inh_CProductions :: Bool} +data Syn_CProductions = Syn_CProductions {allTpsFound_Syn_CProductions :: Bool,cataAlts_Syn_CProductions :: Decls,comments_Syn_CProductions :: [String],dataAlts_Syn_CProductions :: DataAlts,decls_Syn_CProductions :: Decls,errors_Syn_CProductions :: Seq Error,semNames_Syn_CProductions :: [String]} +wrap_CProductions (T_CProductions sem) (Inh_CProductions _lhsIallPragmas _lhsIcontextMap _lhsIerrors _lhsIinh _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIparamMap _lhsIprefix _lhsIsyn _lhsIunfoldSemDom _lhsIwith_sig) = + (let ( _lhsOallTpsFound,_lhsOcataAlts,_lhsOcomments,_lhsOdataAlts,_lhsOdecls,_lhsOerrors,_lhsOsemNames) = + (sem _lhsIallPragmas _lhsIcontextMap _lhsIerrors _lhsIinh _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIparamMap _lhsIprefix _lhsIsyn _lhsIunfoldSemDom _lhsIwith_sig) + in (Syn_CProductions _lhsOallTpsFound _lhsOcataAlts _lhsOcomments _lhsOdataAlts _lhsOdecls _lhsOerrors _lhsOsemNames)) +sem_CProductions_Cons :: T_CProduction -> + T_CProductions -> + T_CProductions +sem_CProductions_Cons (T_CProduction hd_) (T_CProductions tl_) = + (T_CProductions (\ _lhsIallPragmas + _lhsIcontextMap + _lhsIerrors + _lhsIinh + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_costcentre + _lhsIo_data + _lhsIo_linePragmas + _lhsIo_newtypes + _lhsIo_pretty + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_splitsems + _lhsIo_strictwrap + _lhsIo_traces + _lhsIo_unbox + _lhsIparamMap + _lhsIprefix + _lhsIsyn + _lhsIunfoldSemDom + _lhsIwith_sig -> + (let _lhsOdataAlts :: DataAlts + _lhsOcataAlts :: Decls + _lhsOallTpsFound :: Bool + _lhsOcomments :: ([String]) + _lhsOdecls :: Decls + _lhsOerrors :: (Seq Error) + _lhsOsemNames :: ([String]) + _hdOallPragmas :: PragmaMap + _hdOcontextMap :: ContextMap + _hdOerrors :: (Seq Error) + _hdOinh :: Attributes + _hdOnt :: NontermIdent + _hdOo_case :: Bool + _hdOo_cata :: Bool + _hdOo_costcentre :: Bool + _hdOo_data :: (Maybe Bool) + _hdOo_linePragmas :: Bool + _hdOo_newtypes :: Bool + _hdOo_pretty :: Bool + _hdOo_rename :: Bool + _hdOo_sem :: Bool + _hdOo_sig :: Bool + _hdOo_splitsems :: Bool + _hdOo_strictwrap :: Bool + _hdOo_traces :: Bool + _hdOo_unbox :: Bool + _hdOparamMap :: ParamMap + _hdOprefix :: String + _hdOsyn :: Attributes + _hdOunfoldSemDom :: (NontermIdent -> Int -> [String] -> Code.Type) + _hdOwith_sig :: Bool + _tlOallPragmas :: PragmaMap + _tlOcontextMap :: ContextMap + _tlOerrors :: (Seq Error) + _tlOinh :: Attributes + _tlOnt :: NontermIdent + _tlOo_case :: Bool + _tlOo_cata :: Bool + _tlOo_costcentre :: Bool + _tlOo_data :: (Maybe Bool) + _tlOo_linePragmas :: Bool + _tlOo_newtypes :: Bool + _tlOo_pretty :: Bool + _tlOo_rename :: Bool + _tlOo_sem :: Bool + _tlOo_sig :: Bool + _tlOo_splitsems :: Bool + _tlOo_strictwrap :: Bool + _tlOo_traces :: Bool + _tlOo_unbox :: Bool + _tlOparamMap :: ParamMap + _tlOprefix :: String + _tlOsyn :: Attributes + _tlOunfoldSemDom :: (NontermIdent -> Int -> [String] -> Code.Type) + _tlOwith_sig :: Bool + _hdIallTpsFound :: Bool + _hdIcataAlt :: Decl + _hdIcomments :: ([String]) + _hdIdataAlt :: DataAlt + _hdIdecls :: Decls + _hdIerrors :: (Seq Error) + _hdIsemNames :: ([String]) + _tlIallTpsFound :: Bool + _tlIcataAlts :: Decls + _tlIcomments :: ([String]) + _tlIdataAlts :: DataAlts + _tlIdecls :: Decls + _tlIerrors :: (Seq Error) + _tlIsemNames :: ([String]) + -- "GenerateCode.ag"(line 832, column 17) + _lhsOdataAlts = + _hdIdataAlt : _tlIdataAlts + -- "GenerateCode.ag"(line 891, column 10) + _lhsOcataAlts = + _hdIcataAlt : _tlIcataAlts + -- use rule "GenerateCode.ag"(line 682, column 39) + _lhsOallTpsFound = + _hdIallTpsFound && _tlIallTpsFound + -- use rule "GenerateCode.ag"(line 714, column 52) + _lhsOcomments = + _hdIcomments ++ _tlIcomments + -- use rule "GenerateCode.ag"(line 757, column 44) + _lhsOdecls = + _hdIdecls ++ _tlIdecls + -- use rule "GenerateCode.ag"(line 695, column 32) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- use rule "GenerateCode.ag"(line 910, column 61) + _lhsOsemNames = + _hdIsemNames ++ _tlIsemNames + -- copy rule (down) + _hdOallPragmas = + _lhsIallPragmas + -- copy rule (down) + _hdOcontextMap = + _lhsIcontextMap + -- copy rule (down) + _hdOerrors = + _lhsIerrors + -- copy rule (down) + _hdOinh = + _lhsIinh + -- copy rule (down) + _hdOnt = + _lhsInt + -- copy rule (down) + _hdOo_case = + _lhsIo_case + -- copy rule (down) + _hdOo_cata = + _lhsIo_cata + -- copy rule (down) + _hdOo_costcentre = + _lhsIo_costcentre + -- copy rule (down) + _hdOo_data = + _lhsIo_data + -- copy rule (down) + _hdOo_linePragmas = + _lhsIo_linePragmas + -- copy rule (down) + _hdOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _hdOo_pretty = + _lhsIo_pretty + -- copy rule (down) + _hdOo_rename = + _lhsIo_rename + -- copy rule (down) + _hdOo_sem = + _lhsIo_sem + -- copy rule (down) + _hdOo_sig = + _lhsIo_sig + -- copy rule (down) + _hdOo_splitsems = + _lhsIo_splitsems + -- copy rule (down) + _hdOo_strictwrap = + _lhsIo_strictwrap + -- copy rule (down) + _hdOo_traces = + _lhsIo_traces + -- copy rule (down) + _hdOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _hdOparamMap = + _lhsIparamMap + -- copy rule (down) + _hdOprefix = + _lhsIprefix + -- copy rule (down) + _hdOsyn = + _lhsIsyn + -- copy rule (down) + _hdOunfoldSemDom = + _lhsIunfoldSemDom + -- copy rule (down) + _hdOwith_sig = + _lhsIwith_sig + -- copy rule (down) + _tlOallPragmas = + _lhsIallPragmas + -- copy rule (down) + _tlOcontextMap = + _lhsIcontextMap + -- copy rule (chain) + _tlOerrors = + _hdIerrors + -- copy rule (down) + _tlOinh = + _lhsIinh + -- copy rule (down) + _tlOnt = + _lhsInt + -- copy rule (down) + _tlOo_case = + _lhsIo_case + -- copy rule (down) + _tlOo_cata = + _lhsIo_cata + -- copy rule (down) + _tlOo_costcentre = + _lhsIo_costcentre + -- copy rule (down) + _tlOo_data = + _lhsIo_data + -- copy rule (down) + _tlOo_linePragmas = + _lhsIo_linePragmas + -- copy rule (down) + _tlOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _tlOo_pretty = + _lhsIo_pretty + -- copy rule (down) + _tlOo_rename = + _lhsIo_rename + -- copy rule (down) + _tlOo_sem = + _lhsIo_sem + -- copy rule (down) + _tlOo_sig = + _lhsIo_sig + -- copy rule (down) + _tlOo_splitsems = + _lhsIo_splitsems + -- copy rule (down) + _tlOo_strictwrap = + _lhsIo_strictwrap + -- copy rule (down) + _tlOo_traces = + _lhsIo_traces + -- copy rule (down) + _tlOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _tlOparamMap = + _lhsIparamMap + -- copy rule (down) + _tlOprefix = + _lhsIprefix + -- copy rule (down) + _tlOsyn = + _lhsIsyn + -- copy rule (down) + _tlOunfoldSemDom = + _lhsIunfoldSemDom + -- copy rule (down) + _tlOwith_sig = + _lhsIwith_sig + ( _hdIallTpsFound,_hdIcataAlt,_hdIcomments,_hdIdataAlt,_hdIdecls,_hdIerrors,_hdIsemNames) = + (hd_ _hdOallPragmas _hdOcontextMap _hdOerrors _hdOinh _hdOnt _hdOo_case _hdOo_cata _hdOo_costcentre _hdOo_data _hdOo_linePragmas _hdOo_newtypes _hdOo_pretty _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_splitsems _hdOo_strictwrap _hdOo_traces _hdOo_unbox _hdOparamMap _hdOprefix _hdOsyn _hdOunfoldSemDom _hdOwith_sig) + ( _tlIallTpsFound,_tlIcataAlts,_tlIcomments,_tlIdataAlts,_tlIdecls,_tlIerrors,_tlIsemNames) = + (tl_ _tlOallPragmas _tlOcontextMap _tlOerrors _tlOinh _tlOnt _tlOo_case _tlOo_cata _tlOo_costcentre _tlOo_data _tlOo_linePragmas _tlOo_newtypes _tlOo_pretty _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_splitsems _tlOo_strictwrap _tlOo_traces _tlOo_unbox _tlOparamMap _tlOprefix _tlOsyn _tlOunfoldSemDom _tlOwith_sig) + in ( _lhsOallTpsFound,_lhsOcataAlts,_lhsOcomments,_lhsOdataAlts,_lhsOdecls,_lhsOerrors,_lhsOsemNames)))) +sem_CProductions_Nil :: T_CProductions +sem_CProductions_Nil = + (T_CProductions (\ _lhsIallPragmas + _lhsIcontextMap + _lhsIerrors + _lhsIinh + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_costcentre + _lhsIo_data + _lhsIo_linePragmas + _lhsIo_newtypes + _lhsIo_pretty + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_splitsems + _lhsIo_strictwrap + _lhsIo_traces + _lhsIo_unbox + _lhsIparamMap + _lhsIprefix + _lhsIsyn + _lhsIunfoldSemDom + _lhsIwith_sig -> + (let _lhsOdataAlts :: DataAlts + _lhsOcataAlts :: Decls + _lhsOallTpsFound :: Bool + _lhsOcomments :: ([String]) + _lhsOdecls :: Decls + _lhsOerrors :: (Seq Error) + _lhsOsemNames :: ([String]) + -- "GenerateCode.ag"(line 833, column 17) + _lhsOdataAlts = + [] + -- "GenerateCode.ag"(line 892, column 10) + _lhsOcataAlts = + [] + -- use rule "GenerateCode.ag"(line 682, column 39) + _lhsOallTpsFound = + True + -- use rule "GenerateCode.ag"(line 714, column 52) + _lhsOcomments = + [] + -- use rule "GenerateCode.ag"(line 757, column 44) + _lhsOdecls = + [] + -- use rule "GenerateCode.ag"(line 695, column 32) + _lhsOerrors = + Seq.empty + -- use rule "GenerateCode.ag"(line 910, column 61) + _lhsOsemNames = + [] + in ( _lhsOallTpsFound,_lhsOcataAlts,_lhsOcomments,_lhsOdataAlts,_lhsOdecls,_lhsOerrors,_lhsOsemNames)))) +-- CRule ------------------------------------------------------- +{- + visit 0: + inherited attributes: + children : [(Identifier,Type,Bool)] + con : ConstructorIdent + higherOrderChildren : [(Identifier,Type,Bool)] + inh : Attributes + instVisitNrs : Map Identifier Int + nr : Int + nt : NontermIdent + o_case : Bool + o_cata : Bool + o_costcentre : Bool + o_data : Maybe Bool + o_linePragmas : Bool + o_newtypes : Bool + o_pretty : Bool + o_rename : Bool + o_sem : Bool + o_sig : Bool + o_splitsems : Bool + o_strictwrap : Bool + o_traces : Bool + o_unbox : Bool + paramInstMap : Map Identifier (NontermIdent, [String]) + paramMap : ParamMap + prefix : String + syn : Attributes + terminals : [Identifier] + what : String + chained attributes: + declsAbove : [Decl] + errors : Seq Error + synthesized attributes: + allTpsFound : Bool + bldBlocksFun : DeclBlocks -> DeclBlocks + comments : [String] + decls : Decls + definedInsts : [Identifier] + exprs : Exprs + tSigs : [Decl] + tps : [Type] + usedVars : Set String + alternatives: + alternative CChildVisit: + child name : {Identifier} + child nt : {NontermIdent} + child nr : {Int} + child inh : {Attributes} + child syn : {Attributes} + child isLast : {Bool} + visit 0: + local costCentreDescr : _ + local addCostCentre : _ + local decls : _ + local isSuperfluousHigherOrderIntra : _ + local names : _ + local mkTp : _ + local definedTps : _ + local nextTp : _ + local orgParams : _ + local instParams : _ + local replParamMap : _ + local replace : _ + local evalTp : _ + alternative CRule: + child name : {Identifier} + child isIn : {Bool} + child hasCode : {Bool} + child nt : {NontermIdent} + child con : {ConstructorIdent} + child field : {Identifier} + child childnt : {Maybe NontermIdent} + child tp : {Maybe Type} + child pattern : Pattern + child rhs : {[String]} + child defines : {Map Int (Identifier,Identifier,Maybe Type)} + child owrt : {Bool} + child origin : {String} + child uses : {Set (Identifier, Identifier)} + visit 0: + local instTypes : _ + local originComment : _ + local instDecls : _ + local patDescr : _ + local traceDescr : _ + local addTrace : _ + local costCentreDescr : _ + local addCostCentre : _ + local addLinePragma : _ + local decls : _ + local definedInsts : _ + local name : _ + local mkTp : _ + local orgParams : _ + local evalTp : _ + local _tup3 : {([Type],Bool)} +-} +-- cata +sem_CRule :: CRule -> + T_CRule +sem_CRule (CChildVisit _name _nt _nr _inh _syn _isLast) = + (sem_CRule_CChildVisit _name _nt _nr _inh _syn _isLast) +sem_CRule (CRule _name _isIn _hasCode _nt _con _field _childnt _tp _pattern _rhs _defines _owrt _origin _uses) = + (sem_CRule_CRule _name _isIn _hasCode _nt _con _field _childnt _tp (sem_Pattern _pattern) _rhs _defines _owrt _origin _uses) +-- semantic domain +newtype T_CRule = T_CRule (([(Identifier,Type,Bool)]) -> + ConstructorIdent -> + ([Decl]) -> + (Seq Error) -> + ([(Identifier,Type,Bool)]) -> + Attributes -> + (Map Identifier Int) -> + Int -> + NontermIdent -> + Bool -> + Bool -> + Bool -> + (Maybe Bool) -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + (Map Identifier (NontermIdent, [String])) -> + ParamMap -> + String -> + Attributes -> + ([Identifier]) -> + String -> + ( Bool,(DeclBlocks -> DeclBlocks),([String]),Decls,([Decl]),([Identifier]),(Seq Error),Exprs,([Decl]),([Type]),(Set String))) +data Inh_CRule = Inh_CRule {children_Inh_CRule :: [(Identifier,Type,Bool)],con_Inh_CRule :: ConstructorIdent,declsAbove_Inh_CRule :: [Decl],errors_Inh_CRule :: Seq Error,higherOrderChildren_Inh_CRule :: [(Identifier,Type,Bool)],inh_Inh_CRule :: Attributes,instVisitNrs_Inh_CRule :: Map Identifier Int,nr_Inh_CRule :: Int,nt_Inh_CRule :: NontermIdent,o_case_Inh_CRule :: Bool,o_cata_Inh_CRule :: Bool,o_costcentre_Inh_CRule :: Bool,o_data_Inh_CRule :: Maybe Bool,o_linePragmas_Inh_CRule :: Bool,o_newtypes_Inh_CRule :: Bool,o_pretty_Inh_CRule :: Bool,o_rename_Inh_CRule :: Bool,o_sem_Inh_CRule :: Bool,o_sig_Inh_CRule :: Bool,o_splitsems_Inh_CRule :: Bool,o_strictwrap_Inh_CRule :: Bool,o_traces_Inh_CRule :: Bool,o_unbox_Inh_CRule :: Bool,paramInstMap_Inh_CRule :: Map Identifier (NontermIdent, [String]),paramMap_Inh_CRule :: ParamMap,prefix_Inh_CRule :: String,syn_Inh_CRule :: Attributes,terminals_Inh_CRule :: [Identifier],what_Inh_CRule :: String} +data Syn_CRule = Syn_CRule {allTpsFound_Syn_CRule :: Bool,bldBlocksFun_Syn_CRule :: DeclBlocks -> DeclBlocks,comments_Syn_CRule :: [String],decls_Syn_CRule :: Decls,declsAbove_Syn_CRule :: [Decl],definedInsts_Syn_CRule :: [Identifier],errors_Syn_CRule :: Seq Error,exprs_Syn_CRule :: Exprs,tSigs_Syn_CRule :: [Decl],tps_Syn_CRule :: [Type],usedVars_Syn_CRule :: Set String} +wrap_CRule (T_CRule sem) (Inh_CRule _lhsIchildren _lhsIcon _lhsIdeclsAbove _lhsIerrors _lhsIhigherOrderChildren _lhsIinh _lhsIinstVisitNrs _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIparamInstMap _lhsIparamMap _lhsIprefix _lhsIsyn _lhsIterminals _lhsIwhat) = + (let ( _lhsOallTpsFound,_lhsObldBlocksFun,_lhsOcomments,_lhsOdecls,_lhsOdeclsAbove,_lhsOdefinedInsts,_lhsOerrors,_lhsOexprs,_lhsOtSigs,_lhsOtps,_lhsOusedVars) = + (sem _lhsIchildren _lhsIcon _lhsIdeclsAbove _lhsIerrors _lhsIhigherOrderChildren _lhsIinh _lhsIinstVisitNrs _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIparamInstMap _lhsIparamMap _lhsIprefix _lhsIsyn _lhsIterminals _lhsIwhat) + in (Syn_CRule _lhsOallTpsFound _lhsObldBlocksFun _lhsOcomments _lhsOdecls _lhsOdeclsAbove _lhsOdefinedInsts _lhsOerrors _lhsOexprs _lhsOtSigs _lhsOtps _lhsOusedVars)) +sem_CRule_CChildVisit :: Identifier -> + NontermIdent -> + Int -> + Attributes -> + Attributes -> + Bool -> + T_CRule +sem_CRule_CChildVisit name_ nt_ nr_ inh_ syn_ isLast_ = + (T_CRule (\ _lhsIchildren + _lhsIcon + _lhsIdeclsAbove + _lhsIerrors + _lhsIhigherOrderChildren + _lhsIinh + _lhsIinstVisitNrs + _lhsInr + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_costcentre + _lhsIo_data + _lhsIo_linePragmas + _lhsIo_newtypes + _lhsIo_pretty + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_splitsems + _lhsIo_strictwrap + _lhsIo_traces + _lhsIo_unbox + _lhsIparamInstMap + _lhsIparamMap + _lhsIprefix + _lhsIsyn + _lhsIterminals + _lhsIwhat -> + (let _lhsOexprs :: Exprs + _lhsOusedVars :: (Set String) + _lhsOtSigs :: ([Decl]) + _lhsOtps :: ([Type]) + _lhsOdeclsAbove :: ([Decl]) + _lhsObldBlocksFun :: (DeclBlocks -> DeclBlocks) + _lhsOallTpsFound :: Bool + _lhsOcomments :: ([String]) + _lhsOdecls :: Decls + _lhsOdefinedInsts :: ([Identifier]) + _lhsOerrors :: (Seq Error) + -- "GenerateCode.ag"(line 161, column 18) + _costCentreDescr = + show _lhsInt ++ ":" ++ show _lhsIcon ++ ":" ++ show name_ ++ ":" ++ show nt_ ++ ":" ++ show nr_ + -- "GenerateCode.ag"(line 162, column 18) + _addCostCentre = + \v -> if _lhsIo_costcentre + then PragmaExpr True False ("SCC \"" ++ _costCentreDescr ++ "\"") v + else v + -- "GenerateCode.ag"(line 165, column 18) + _decls = + let lhsVars = map (attrname True name_) (Map.keys syn_) + ++ if isLast_ then [] else [unwrap ++ funname name_ (nr_+1)] + rhsVars = map (attrname False name_) (Map.keys inh_) + unwrap = if _lhsIo_newtypes then typeName nt_ (nr_ + 1) ++ " " else "" + tuple = mkTupleLhs _lhsIo_unbox (null $ Map.keys inh_) lhsVars + rhs = _addCostCentre $ App (funname name_ nr_) (map SimpleExpr rhsVars) + in [Decl tuple rhs (Set.fromList lhsVars) (Set.fromList (funname name_ nr_ : rhsVars))] + -- "GenerateCode.ag"(line 241, column 7) + _isSuperfluousHigherOrderIntra = + _lhsInr <= Map.findWithDefault (-1) name_ _lhsIinstVisitNrs + -- "GenerateCode.ag"(line 255, column 8) + _names = + if _isSuperfluousHigherOrderIntra + then [] + else [funname name_ (nr_+1)] + -- "GenerateCode.ag"(line 259, column 8) + _lhsOexprs = + let wrap = if _lhsIo_newtypes then \x -> App (typeName nt_ (nr_ + 1)) [x] else id + in map (wrap . SimpleExpr) _names + -- "GenerateCode.ag"(line 267, column 7) + _lhsOusedVars = + Set.fromList _names + -- "GenerateCode.ag"(line 291, column 19) + _mkTp = + _evalTp . SimpleType . typeToHaskellString (Just nt_) _orgParams + -- "GenerateCode.ag"(line 292, column 19) + _definedTps = + [ TSig (attrname True name_ a) (_mkTp tp) | (a,tp) <- Map.toList syn_ ] + -- "GenerateCode.ag"(line 293, column 19) + _nextTp = + typeName nt_ (nr_+1) + -- "GenerateCode.ag"(line 294, column 19) + _lhsOtSigs = + (if isLast_ then id else (TSig (funname name_ (nr_+1)) (TypeApp (SimpleType _nextTp) (map SimpleType _instParams )) :)) _definedTps + -- "GenerateCode.ag"(line 296, column 19) + _orgParams = + map getName $ Map.findWithDefault [] nt_ _lhsIparamMap + -- "GenerateCode.ag"(line 297, column 19) + _instParams = + snd $ Map.findWithDefault (nt_,[]) name_ _lhsIparamInstMap + -- "GenerateCode.ag"(line 298, column 19) + _replParamMap = + Map.fromList (zip _orgParams _instParams ) + -- "GenerateCode.ag"(line 299, column 19) + _replace = + \k -> Map.findWithDefault k k _replParamMap + -- "GenerateCode.ag"(line 300, column 19) + _evalTp = + if null _orgParams then id else evalType _replace + -- "GenerateCode.ag"(line 323, column 19) + _lhsOtps = + if _isSuperfluousHigherOrderIntra + then [] + else [Haskell _nextTp] + -- "GenerateCode.ag"(line 448, column 7) + _lhsOdeclsAbove = + [] + -- "GenerateCode.ag"(line 461, column 7) + _lhsObldBlocksFun = + DeclBlock _lhsIdeclsAbove (head _decls ) + -- use rule "GenerateCode.ag"(line 320, column 39) + _lhsOallTpsFound = + True + -- use rule "GenerateCode.ag"(line 714, column 52) + _lhsOcomments = + [] + -- use rule "GenerateCode.ag"(line 122, column 34) + _lhsOdecls = + _decls + -- use rule "GenerateCode.ag"(line 175, column 55) + _lhsOdefinedInsts = + [] + -- use rule "GenerateCode.ag"(line 695, column 32) + _lhsOerrors = + Seq.empty + in ( _lhsOallTpsFound,_lhsObldBlocksFun,_lhsOcomments,_lhsOdecls,_lhsOdeclsAbove,_lhsOdefinedInsts,_lhsOerrors,_lhsOexprs,_lhsOtSigs,_lhsOtps,_lhsOusedVars)))) +sem_CRule_CRule :: Identifier -> + Bool -> + Bool -> + NontermIdent -> + ConstructorIdent -> + Identifier -> + (Maybe NontermIdent) -> + (Maybe Type) -> + T_Pattern -> + ([String]) -> + (Map Int (Identifier,Identifier,Maybe Type)) -> + Bool -> + String -> + (Set (Identifier, Identifier)) -> + T_CRule +sem_CRule_CRule name_ isIn_ hasCode_ nt_ con_ field_ childnt_ tp_ (T_Pattern pattern_) rhs_ defines_ owrt_ origin_ uses_ = + (T_CRule (\ _lhsIchildren + _lhsIcon + _lhsIdeclsAbove + _lhsIerrors + _lhsIhigherOrderChildren + _lhsIinh + _lhsIinstVisitNrs + _lhsInr + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_costcentre + _lhsIo_data + _lhsIo_linePragmas + _lhsIo_newtypes + _lhsIo_pretty + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_splitsems + _lhsIo_strictwrap + _lhsIo_traces + _lhsIo_unbox + _lhsIparamInstMap + _lhsIparamMap + _lhsIprefix + _lhsIsyn + _lhsIterminals + _lhsIwhat -> + (let _lhsOexprs :: Exprs + _lhsOusedVars :: (Set String) + _lhsOtSigs :: ([Decl]) + __tup3 :: (([Type],Bool)) + _lhsOtps :: ([Type]) + _lhsOallTpsFound :: Bool + _lhsOdeclsAbove :: ([Decl]) + _lhsObldBlocksFun :: (DeclBlocks -> DeclBlocks) + _lhsOerrors :: (Seq Error) + _lhsOcomments :: ([String]) + _lhsOdecls :: Decls + _lhsOdefinedInsts :: ([Identifier]) + _patternIcopy :: Pattern + _patternIdefinedInsts :: ([Identifier]) + _patternIpatternAttributes :: ([(Identifier, Identifier)]) + -- "GenerateCode.ag"(line 124, column 12) + _instTypes = + map (\(n,NT t _,_) -> (n,t)) _lhsIhigherOrderChildren + -- "GenerateCode.ag"(line 125, column 12) + _originComment = + if _lhsIo_pretty + then (Comment origin_:) + else id + -- "GenerateCode.ag"(line 128, column 12) + _instDecls = + [ Decl (Pattern3 (Alias _INST' inst (Underscore (getPos inst)) [])) + (App (cataname _lhsIprefix (fromJust $ inst `lookup` _instTypes )) + [SimpleExpr instLocFieldName]) + (Set.singleton instSemFieldName) + (Set.singleton instLocFieldName) + | inst <- _definedInsts + , let instLocFieldName = attrname True _INST inst + , let instSemFieldName = attrname False _INST' inst ] + -- "GenerateCode.ag"(line 136, column 12) + _patDescr = + if isIn_ + then "_" + else concat $ intersperse "," (map (\(f,a) -> show f ++ "." ++ show a) _patternIpatternAttributes) + -- "GenerateCode.ag"(line 139, column 12) + _traceDescr = + show nt_ ++ " :: " ++ show con_ ++ " :: " ++ _patDescr + -- "GenerateCode.ag"(line 141, column 12) + _addTrace = + \v -> if _lhsIo_traces + then Trace _traceDescr v + else v + -- "GenerateCode.ag"(line 144, column 12) + _costCentreDescr = + show nt_ ++ ":" ++ show con_ ++ ":" ++ _patDescr + -- "GenerateCode.ag"(line 145, column 12) + _addCostCentre = + \v -> if _lhsIo_costcentre + then PragmaExpr True False ("SCC \"" ++ _costCentreDescr ++ "\"") v + else v + -- "GenerateCode.ag"(line 148, column 12) + _addLinePragma = + \v -> let p = getPos name_ + hasPos = line p > 0 && column p >= 0 && not (null (file p)) + in if _lhsIo_linePragmas && hasPos + then PragmaExpr True True ("LINE " ++ show (line p) ++ " " ++ show (file p)) + $ LineExpr + $ v + else v + -- "GenerateCode.ag"(line 155, column 12) + _decls = + if hasCode_ + then _originComment ( Decl (Pattern3 _patternIcopy) (_addTrace $ _addCostCentre $ _addLinePragma $ (TextExpr rhs_)) + (Set.fromList [attrname False fld nm | (fld,nm,_) <- Map.elems defines_]) + (Set.fromList [attrname True fld nm | (fld,nm) <- Set.toList uses_]) + : _instDecls ) + else _instDecls + -- "GenerateCode.ag"(line 180, column 12) + _definedInsts = + if isIn_ then [] else _patternIdefinedInsts + -- "GenerateCode.ag"(line 250, column 12) + _name = + if field_ == _LOC && name_ `elem` _lhsIterminals + then funname name_ 0 + else attrname isIn_ field_ name_ + -- "GenerateCode.ag"(line 253, column 12) + _lhsOexprs = + [SimpleExpr _name ] + -- "GenerateCode.ag"(line 265, column 7) + _lhsOusedVars = + Set.singleton _name + -- "GenerateCode.ag"(line 275, column 19) + _mkTp = + SimpleType . typeToHaskellString (Just _lhsInt) _orgParams + -- "GenerateCode.ag"(line 276, column 19) + _lhsOtSigs = + [ TSig (attrname False field attr) (_evalTp field $ _mkTp (fromJust tp)) + | (field,attr,tp) <- Map.elems defines_, isJust tp ] + -- "GenerateCode.ag"(line 279, column 19) + _orgParams = + map getName $ Map.findWithDefault [] _lhsInt _lhsIparamMap + -- "GenerateCode.ag"(line 280, column 19) + _evalTp = + \field tp -> let orgFldParams = map getName $ Map.findWithDefault [] childNt _lhsIparamMap + (childNt,instParams) = Map.findWithDefault (_lhsInt,[]) field _lhsIparamInstMap + replMap = Map.fromList (zip orgFldParams instParams) + replace k = Map.findWithDefault k k replMap + in if null instParams + then if null _orgParams + then tp + else idEvalType tp + else evalType replace tp + -- "GenerateCode.ag"(line 322, column 23) + __tup3 = + maybe ([],False) (\tp -> ([substSelf (fromJust childnt_) tp],True)) tp_ + -- "GenerateCode.ag"(line 322, column 23) + (_lhsOtps,_) = + __tup3 + -- "GenerateCode.ag"(line 322, column 23) + (_,_lhsOallTpsFound) = + __tup3 + -- "GenerateCode.ag"(line 446, column 7) + _lhsOdeclsAbove = + _lhsIdeclsAbove ++ _decls + -- "GenerateCode.ag"(line 459, column 7) + _lhsObldBlocksFun = + id + -- "GenerateCode.ag"(line 701, column 12) + _lhsOerrors = + let nameOf (Alias _ _ _ pats@(_:_)) = Ident (show (map (\(Alias _ a _ _)->a) pats)) (getPos name_) + nameOf _ = name_ + in maybe (Seq.single (MissingTypeSig _lhsInt _lhsIcon (nameOf _patternIcopy))) (const Seq.empty) tp_ + -- "GenerateCode.ag"(line 741, column 18) + _lhsOcomments = + [ makeLocalComment 11 _lhsIwhat name tp | (field,name,tp) <- Map.elems defines_, field == _LOC ] + ++ [ makeLocalComment 11 "inst " name tp | (field,name,tp) <- Map.elems defines_, field == _INST ] + -- use rule "GenerateCode.ag"(line 122, column 34) + _lhsOdecls = + _decls + -- use rule "GenerateCode.ag"(line 175, column 55) + _lhsOdefinedInsts = + _definedInsts + ( _patternIcopy,_patternIdefinedInsts,_patternIpatternAttributes) = + (pattern_ ) + in ( _lhsOallTpsFound,_lhsObldBlocksFun,_lhsOcomments,_lhsOdecls,_lhsOdeclsAbove,_lhsOdefinedInsts,_lhsOerrors,_lhsOexprs,_lhsOtSigs,_lhsOtps,_lhsOusedVars)))) +-- CSegment ---------------------------------------------------- +{- + visit 0: + inherited attributes: + inh : Attributes + isLast : Bool + nr : Int + nt : NontermIdent + o_case : Bool + o_cata : Bool + o_costcentre : Bool + o_data : Maybe Bool + o_linePragmas : Bool + o_newtypes : Bool + o_pretty : Bool + o_rename : Bool + o_sem : Bool + o_sig : Bool + o_splitsems : Bool + o_strictwrap : Bool + o_traces : Bool + o_unbox : Bool + paramMap : ParamMap + prefix : String + syn : Attributes + synthesized attributes: + comments : [String] + semDom : [Decl] + semDomUnfoldGath : Map (NontermIdent, Int) ([String], Code.Type) + wrapDecls : Decls + alternatives: + alternative CSegment: + child inh : {Attributes} + child syn : {Attributes} + visit 0: + local tp : _ + local inhTps : _ + local synTps : _ + local continuation : _ + local params : _ +-} +-- cata +sem_CSegment :: CSegment -> + T_CSegment +sem_CSegment (CSegment _inh _syn) = + (sem_CSegment_CSegment _inh _syn) +-- semantic domain +newtype T_CSegment = T_CSegment (Attributes -> + Bool -> + Int -> + NontermIdent -> + Bool -> + Bool -> + Bool -> + (Maybe Bool) -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + ParamMap -> + String -> + Attributes -> + ( ([String]),([Decl]),(Map (NontermIdent, Int) ([String], Code.Type)),Decls)) +data Inh_CSegment = Inh_CSegment {inh_Inh_CSegment :: Attributes,isLast_Inh_CSegment :: Bool,nr_Inh_CSegment :: Int,nt_Inh_CSegment :: NontermIdent,o_case_Inh_CSegment :: Bool,o_cata_Inh_CSegment :: Bool,o_costcentre_Inh_CSegment :: Bool,o_data_Inh_CSegment :: Maybe Bool,o_linePragmas_Inh_CSegment :: Bool,o_newtypes_Inh_CSegment :: Bool,o_pretty_Inh_CSegment :: Bool,o_rename_Inh_CSegment :: Bool,o_sem_Inh_CSegment :: Bool,o_sig_Inh_CSegment :: Bool,o_splitsems_Inh_CSegment :: Bool,o_strictwrap_Inh_CSegment :: Bool,o_traces_Inh_CSegment :: Bool,o_unbox_Inh_CSegment :: Bool,paramMap_Inh_CSegment :: ParamMap,prefix_Inh_CSegment :: String,syn_Inh_CSegment :: Attributes} +data Syn_CSegment = Syn_CSegment {comments_Syn_CSegment :: [String],semDom_Syn_CSegment :: [Decl],semDomUnfoldGath_Syn_CSegment :: Map (NontermIdent, Int) ([String], Code.Type),wrapDecls_Syn_CSegment :: Decls} +wrap_CSegment (T_CSegment sem) (Inh_CSegment _lhsIinh _lhsIisLast _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIparamMap _lhsIprefix _lhsIsyn) = + (let ( _lhsOcomments,_lhsOsemDom,_lhsOsemDomUnfoldGath,_lhsOwrapDecls) = + (sem _lhsIinh _lhsIisLast _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIparamMap _lhsIprefix _lhsIsyn) + in (Syn_CSegment _lhsOcomments _lhsOsemDom _lhsOsemDomUnfoldGath _lhsOwrapDecls)) +sem_CSegment_CSegment :: Attributes -> + Attributes -> + T_CSegment +sem_CSegment_CSegment inh_ syn_ = + (T_CSegment (\ _lhsIinh + _lhsIisLast + _lhsInr + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_costcentre + _lhsIo_data + _lhsIo_linePragmas + _lhsIo_newtypes + _lhsIo_pretty + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_splitsems + _lhsIo_strictwrap + _lhsIo_traces + _lhsIo_unbox + _lhsIparamMap + _lhsIprefix + _lhsIsyn -> + (let _lhsOsemDom :: ([Decl]) + _lhsOsemDomUnfoldGath :: (Map (NontermIdent, Int) ([String], Code.Type)) + _lhsOwrapDecls :: Decls + _lhsOcomments :: ([String]) + -- "GenerateCode.ag"(line 573, column 15) + _tp = + foldr Arr _synTps _inhTps + -- "GenerateCode.ag"(line 574, column 15) + _inhTps = + [SimpleType (typeToHaskellString (Just _lhsInt) _params tp) | tp <- Map.elems inh_] + -- "GenerateCode.ag"(line 575, column 15) + _synTps = + mkTupleType _lhsIo_unbox (null _inhTps ) ([SimpleType (typeToHaskellString (Just _lhsInt) _params tp) | tp <- Map.elems syn_] ++ _continuation ) + -- "GenerateCode.ag"(line 576, column 15) + _continuation = + if _lhsIisLast + then [] + else [TypeApp (SimpleType (typeName _lhsInt (_lhsInr + 1))) (map SimpleType _params )] + -- "GenerateCode.ag"(line 579, column 15) + _params = + map getName $ Map.findWithDefault [] _lhsInt _lhsIparamMap + -- "GenerateCode.ag"(line 580, column 15) + _lhsOsemDom = + let name = typeName _lhsInt _lhsInr + evalTp | null _params = id + | otherwise = idEvalType + in if _lhsIo_newtypes + then [ Code.NewType name _params name (evalTp _tp ) ] + else [ Code.Type name _params (evalTp _tp ) ] + -- "GenerateCode.ag"(line 591, column 7) + _lhsOsemDomUnfoldGath = + Map.singleton (_lhsInt, _lhsInr) (_params , _tp ) + -- "GenerateCode.ag"(line 665, column 15) + _lhsOwrapDecls = + let lhsVars = map (lhsname False) (Map.keys syn_) + ++ if _lhsIisLast then [] else [unwrap ++ sem (_lhsInr+1)] + rhsVars = map (lhsname True) (Map.keys inh_) + rhs = map SimpleExpr rhsVars + unwrap = if _lhsIo_newtypes then typeName _lhsInt (_lhsInr + 1) ++ " " else "" + var = "sem" + sem 0 = var + sem n = var ++ "_" ++ show n + in [ Decl (mkTupleLhs _lhsIo_unbox (null $ Map.keys inh_) lhsVars) (App (sem _lhsInr) rhs) (Set.fromList lhsVars) (Set.fromList rhsVars) ] + -- "GenerateCode.ag"(line 719, column 18) + _lhsOcomments = + let body = map ind (showsSegment (CSegment inh_ syn_)) + in if null body + then [] + else ("visit " ++ show _lhsInr ++ ":") : body + in ( _lhsOcomments,_lhsOsemDom,_lhsOsemDomUnfoldGath,_lhsOwrapDecls)))) +-- CSegments --------------------------------------------------- +{- + visit 0: + inherited attributes: + inh : Attributes + nr : Int + nt : NontermIdent + o_case : Bool + o_cata : Bool + o_costcentre : Bool + o_data : Maybe Bool + o_linePragmas : Bool + o_newtypes : Bool + o_pretty : Bool + o_rename : Bool + o_sem : Bool + o_sig : Bool + o_splitsems : Bool + o_strictwrap : Bool + o_traces : Bool + o_unbox : Bool + paramMap : ParamMap + prefix : String + syn : Attributes + synthesized attributes: + comments : [String] + isNil : Bool + semDom : [Decl] + semDomUnfoldGath : Map (NontermIdent, Int) ([String], Code.Type) + wrapDecls : Decls + alternatives: + alternative Cons: + child hd : CSegment + child tl : CSegments + alternative Nil: +-} +-- cata +sem_CSegments :: CSegments -> + T_CSegments +sem_CSegments list = + (Prelude.foldr sem_CSegments_Cons sem_CSegments_Nil (Prelude.map sem_CSegment list)) +-- semantic domain +newtype T_CSegments = T_CSegments (Attributes -> + Int -> + NontermIdent -> + Bool -> + Bool -> + Bool -> + (Maybe Bool) -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + ParamMap -> + String -> + Attributes -> + ( ([String]),Bool,([Decl]),(Map (NontermIdent, Int) ([String], Code.Type)),Decls)) +data Inh_CSegments = Inh_CSegments {inh_Inh_CSegments :: Attributes,nr_Inh_CSegments :: Int,nt_Inh_CSegments :: NontermIdent,o_case_Inh_CSegments :: Bool,o_cata_Inh_CSegments :: Bool,o_costcentre_Inh_CSegments :: Bool,o_data_Inh_CSegments :: Maybe Bool,o_linePragmas_Inh_CSegments :: Bool,o_newtypes_Inh_CSegments :: Bool,o_pretty_Inh_CSegments :: Bool,o_rename_Inh_CSegments :: Bool,o_sem_Inh_CSegments :: Bool,o_sig_Inh_CSegments :: Bool,o_splitsems_Inh_CSegments :: Bool,o_strictwrap_Inh_CSegments :: Bool,o_traces_Inh_CSegments :: Bool,o_unbox_Inh_CSegments :: Bool,paramMap_Inh_CSegments :: ParamMap,prefix_Inh_CSegments :: String,syn_Inh_CSegments :: Attributes} +data Syn_CSegments = Syn_CSegments {comments_Syn_CSegments :: [String],isNil_Syn_CSegments :: Bool,semDom_Syn_CSegments :: [Decl],semDomUnfoldGath_Syn_CSegments :: Map (NontermIdent, Int) ([String], Code.Type),wrapDecls_Syn_CSegments :: Decls} +wrap_CSegments (T_CSegments sem) (Inh_CSegments _lhsIinh _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIparamMap _lhsIprefix _lhsIsyn) = + (let ( _lhsOcomments,_lhsOisNil,_lhsOsemDom,_lhsOsemDomUnfoldGath,_lhsOwrapDecls) = + (sem _lhsIinh _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIparamMap _lhsIprefix _lhsIsyn) + in (Syn_CSegments _lhsOcomments _lhsOisNil _lhsOsemDom _lhsOsemDomUnfoldGath _lhsOwrapDecls)) +sem_CSegments_Cons :: T_CSegment -> + T_CSegments -> + T_CSegments +sem_CSegments_Cons (T_CSegment hd_) (T_CSegments tl_) = + (T_CSegments (\ _lhsIinh + _lhsInr + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_costcentre + _lhsIo_data + _lhsIo_linePragmas + _lhsIo_newtypes + _lhsIo_pretty + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_splitsems + _lhsIo_strictwrap + _lhsIo_traces + _lhsIo_unbox + _lhsIparamMap + _lhsIprefix + _lhsIsyn -> + (let _tlOnr :: Int + _lhsOisNil :: Bool + _hdOisLast :: Bool + _lhsOcomments :: ([String]) + _lhsOsemDom :: ([Decl]) + _lhsOsemDomUnfoldGath :: (Map (NontermIdent, Int) ([String], Code.Type)) + _lhsOwrapDecls :: Decls + _hdOinh :: Attributes + _hdOnr :: Int + _hdOnt :: NontermIdent + _hdOo_case :: Bool + _hdOo_cata :: Bool + _hdOo_costcentre :: Bool + _hdOo_data :: (Maybe Bool) + _hdOo_linePragmas :: Bool + _hdOo_newtypes :: Bool + _hdOo_pretty :: Bool + _hdOo_rename :: Bool + _hdOo_sem :: Bool + _hdOo_sig :: Bool + _hdOo_splitsems :: Bool + _hdOo_strictwrap :: Bool + _hdOo_traces :: Bool + _hdOo_unbox :: Bool + _hdOparamMap :: ParamMap + _hdOprefix :: String + _hdOsyn :: Attributes + _tlOinh :: Attributes + _tlOnt :: NontermIdent + _tlOo_case :: Bool + _tlOo_cata :: Bool + _tlOo_costcentre :: Bool + _tlOo_data :: (Maybe Bool) + _tlOo_linePragmas :: Bool + _tlOo_newtypes :: Bool + _tlOo_pretty :: Bool + _tlOo_rename :: Bool + _tlOo_sem :: Bool + _tlOo_sig :: Bool + _tlOo_splitsems :: Bool + _tlOo_strictwrap :: Bool + _tlOo_traces :: Bool + _tlOo_unbox :: Bool + _tlOparamMap :: ParamMap + _tlOprefix :: String + _tlOsyn :: Attributes + _hdIcomments :: ([String]) + _hdIsemDom :: ([Decl]) + _hdIsemDomUnfoldGath :: (Map (NontermIdent, Int) ([String], Code.Type)) + _hdIwrapDecls :: Decls + _tlIcomments :: ([String]) + _tlIisNil :: Bool + _tlIsemDom :: ([Decl]) + _tlIsemDomUnfoldGath :: (Map (NontermIdent, Int) ([String], Code.Type)) + _tlIwrapDecls :: Decls + -- "GenerateCode.ag"(line 200, column 11) + _tlOnr = + _lhsInr + 1 + -- "GenerateCode.ag"(line 213, column 12) + _lhsOisNil = + False + -- "GenerateCode.ag"(line 214, column 12) + _hdOisLast = + _tlIisNil + -- use rule "GenerateCode.ag"(line 714, column 52) + _lhsOcomments = + _hdIcomments ++ _tlIcomments + -- use rule "GenerateCode.ag"(line 568, column 50) + _lhsOsemDom = + _hdIsemDom ++ _tlIsemDom + -- use rule "GenerateCode.ag"(line 587, column 86) + _lhsOsemDomUnfoldGath = + _hdIsemDomUnfoldGath `Map.union` _tlIsemDomUnfoldGath + -- use rule "GenerateCode.ag"(line 663, column 52) + _lhsOwrapDecls = + _hdIwrapDecls ++ _tlIwrapDecls + -- copy rule (down) + _hdOinh = + _lhsIinh + -- copy rule (down) + _hdOnr = + _lhsInr + -- copy rule (down) + _hdOnt = + _lhsInt + -- copy rule (down) + _hdOo_case = + _lhsIo_case + -- copy rule (down) + _hdOo_cata = + _lhsIo_cata + -- copy rule (down) + _hdOo_costcentre = + _lhsIo_costcentre + -- copy rule (down) + _hdOo_data = + _lhsIo_data + -- copy rule (down) + _hdOo_linePragmas = + _lhsIo_linePragmas + -- copy rule (down) + _hdOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _hdOo_pretty = + _lhsIo_pretty + -- copy rule (down) + _hdOo_rename = + _lhsIo_rename + -- copy rule (down) + _hdOo_sem = + _lhsIo_sem + -- copy rule (down) + _hdOo_sig = + _lhsIo_sig + -- copy rule (down) + _hdOo_splitsems = + _lhsIo_splitsems + -- copy rule (down) + _hdOo_strictwrap = + _lhsIo_strictwrap + -- copy rule (down) + _hdOo_traces = + _lhsIo_traces + -- copy rule (down) + _hdOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _hdOparamMap = + _lhsIparamMap + -- copy rule (down) + _hdOprefix = + _lhsIprefix + -- copy rule (down) + _hdOsyn = + _lhsIsyn + -- copy rule (down) + _tlOinh = + _lhsIinh + -- copy rule (down) + _tlOnt = + _lhsInt + -- copy rule (down) + _tlOo_case = + _lhsIo_case + -- copy rule (down) + _tlOo_cata = + _lhsIo_cata + -- copy rule (down) + _tlOo_costcentre = + _lhsIo_costcentre + -- copy rule (down) + _tlOo_data = + _lhsIo_data + -- copy rule (down) + _tlOo_linePragmas = + _lhsIo_linePragmas + -- copy rule (down) + _tlOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _tlOo_pretty = + _lhsIo_pretty + -- copy rule (down) + _tlOo_rename = + _lhsIo_rename + -- copy rule (down) + _tlOo_sem = + _lhsIo_sem + -- copy rule (down) + _tlOo_sig = + _lhsIo_sig + -- copy rule (down) + _tlOo_splitsems = + _lhsIo_splitsems + -- copy rule (down) + _tlOo_strictwrap = + _lhsIo_strictwrap + -- copy rule (down) + _tlOo_traces = + _lhsIo_traces + -- copy rule (down) + _tlOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _tlOparamMap = + _lhsIparamMap + -- copy rule (down) + _tlOprefix = + _lhsIprefix + -- copy rule (down) + _tlOsyn = + _lhsIsyn + ( _hdIcomments,_hdIsemDom,_hdIsemDomUnfoldGath,_hdIwrapDecls) = + (hd_ _hdOinh _hdOisLast _hdOnr _hdOnt _hdOo_case _hdOo_cata _hdOo_costcentre _hdOo_data _hdOo_linePragmas _hdOo_newtypes _hdOo_pretty _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_splitsems _hdOo_strictwrap _hdOo_traces _hdOo_unbox _hdOparamMap _hdOprefix _hdOsyn) + ( _tlIcomments,_tlIisNil,_tlIsemDom,_tlIsemDomUnfoldGath,_tlIwrapDecls) = + (tl_ _tlOinh _tlOnr _tlOnt _tlOo_case _tlOo_cata _tlOo_costcentre _tlOo_data _tlOo_linePragmas _tlOo_newtypes _tlOo_pretty _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_splitsems _tlOo_strictwrap _tlOo_traces _tlOo_unbox _tlOparamMap _tlOprefix _tlOsyn) + in ( _lhsOcomments,_lhsOisNil,_lhsOsemDom,_lhsOsemDomUnfoldGath,_lhsOwrapDecls)))) +sem_CSegments_Nil :: T_CSegments +sem_CSegments_Nil = + (T_CSegments (\ _lhsIinh + _lhsInr + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_costcentre + _lhsIo_data + _lhsIo_linePragmas + _lhsIo_newtypes + _lhsIo_pretty + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_splitsems + _lhsIo_strictwrap + _lhsIo_traces + _lhsIo_unbox + _lhsIparamMap + _lhsIprefix + _lhsIsyn -> + (let _lhsOisNil :: Bool + _lhsOcomments :: ([String]) + _lhsOsemDom :: ([Decl]) + _lhsOsemDomUnfoldGath :: (Map (NontermIdent, Int) ([String], Code.Type)) + _lhsOwrapDecls :: Decls + -- "GenerateCode.ag"(line 215, column 10) + _lhsOisNil = + True + -- use rule "GenerateCode.ag"(line 714, column 52) + _lhsOcomments = + [] + -- use rule "GenerateCode.ag"(line 568, column 50) + _lhsOsemDom = + [] + -- use rule "GenerateCode.ag"(line 587, column 86) + _lhsOsemDomUnfoldGath = + Map.empty + -- use rule "GenerateCode.ag"(line 663, column 52) + _lhsOwrapDecls = + [] + in ( _lhsOcomments,_lhsOisNil,_lhsOsemDom,_lhsOsemDomUnfoldGath,_lhsOwrapDecls)))) +-- CVisit ------------------------------------------------------ +{- + visit 0: + inherited attributes: + allPragmas : PragmaMap + children : [(Identifier,Type,Bool)] + con : ConstructorIdent + contextMap : ContextMap + inh : Attributes + instVisitNrs : Map Identifier Int + isLast : Bool + nextIntra : Exprs + nextIntraVars : Set String + nr : Int + nt : NontermIdent + o_case : Bool + o_cata : Bool + o_costcentre : Bool + o_data : Maybe Bool + o_linePragmas : Bool + o_newtypes : Bool + o_pretty : Bool + o_rename : Bool + o_sem : Bool + o_sig : Bool + o_splitsems : Bool + o_strictwrap : Bool + o_traces : Bool + o_unbox : Bool + paramInstMap : Map Identifier (NontermIdent, [String]) + paramMap : ParamMap + prefix : String + syn : Attributes + terminals : [Identifier] + unfoldSemDom : NontermIdent -> Int -> [String] -> Code.Type + with_sig : Bool + chained attribute: + errors : Seq Error + synthesized attributes: + allTpsFound : Bool + comments : [String] + decls : Decls + gatherInstVisitNrs : Map Identifier Int + intra : Exprs + intraVars : Set String + semNames : [String] + alternatives: + alternative CVisit: + child inh : {Attributes} + child syn : {Attributes} + child vss : Sequence + child intra : Sequence + child ordered : {Bool} + visit 0: + local _tup4 : _ + local higherOrderChildren : _ + local firstOrderChildren : _ + local funcname : _ + local nextVisitName : _ + local nextVisitDecl : _ + local decls : _ + local lastExprVars : _ + local _tup5 : _ + local blockFunDecls : _ + local blockFirstFunCall : _ + local costCentreDescr : _ + local addCostCentre : _ + local params : _ + local semFun : _ + local tsig : _ + local semType : _ + local typeSigs : _ + local o_case : _ + local o_splitsems : _ +-} +-- cata +sem_CVisit :: CVisit -> + T_CVisit +sem_CVisit (CVisit _inh _syn _vss _intra _ordered) = + (sem_CVisit_CVisit _inh _syn (sem_Sequence _vss) (sem_Sequence _intra) _ordered) +-- semantic domain +newtype T_CVisit = T_CVisit (PragmaMap -> + ([(Identifier,Type,Bool)]) -> + ConstructorIdent -> + ContextMap -> + (Seq Error) -> + Attributes -> + (Map Identifier Int) -> + Bool -> + Exprs -> + (Set String) -> + Int -> + NontermIdent -> + Bool -> + Bool -> + Bool -> + (Maybe Bool) -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + (Map Identifier (NontermIdent, [String])) -> + ParamMap -> + String -> + Attributes -> + ([Identifier]) -> + (NontermIdent -> Int -> [String] -> Code.Type) -> + Bool -> + ( Bool,([String]),Decls,(Seq Error),(Map Identifier Int),Exprs,(Set String),([String]))) +data Inh_CVisit = Inh_CVisit {allPragmas_Inh_CVisit :: PragmaMap,children_Inh_CVisit :: [(Identifier,Type,Bool)],con_Inh_CVisit :: ConstructorIdent,contextMap_Inh_CVisit :: ContextMap,errors_Inh_CVisit :: Seq Error,inh_Inh_CVisit :: Attributes,instVisitNrs_Inh_CVisit :: Map Identifier Int,isLast_Inh_CVisit :: Bool,nextIntra_Inh_CVisit :: Exprs,nextIntraVars_Inh_CVisit :: Set String,nr_Inh_CVisit :: Int,nt_Inh_CVisit :: NontermIdent,o_case_Inh_CVisit :: Bool,o_cata_Inh_CVisit :: Bool,o_costcentre_Inh_CVisit :: Bool,o_data_Inh_CVisit :: Maybe Bool,o_linePragmas_Inh_CVisit :: Bool,o_newtypes_Inh_CVisit :: Bool,o_pretty_Inh_CVisit :: Bool,o_rename_Inh_CVisit :: Bool,o_sem_Inh_CVisit :: Bool,o_sig_Inh_CVisit :: Bool,o_splitsems_Inh_CVisit :: Bool,o_strictwrap_Inh_CVisit :: Bool,o_traces_Inh_CVisit :: Bool,o_unbox_Inh_CVisit :: Bool,paramInstMap_Inh_CVisit :: Map Identifier (NontermIdent, [String]),paramMap_Inh_CVisit :: ParamMap,prefix_Inh_CVisit :: String,syn_Inh_CVisit :: Attributes,terminals_Inh_CVisit :: [Identifier],unfoldSemDom_Inh_CVisit :: NontermIdent -> Int -> [String] -> Code.Type,with_sig_Inh_CVisit :: Bool} +data Syn_CVisit = Syn_CVisit {allTpsFound_Syn_CVisit :: Bool,comments_Syn_CVisit :: [String],decls_Syn_CVisit :: Decls,errors_Syn_CVisit :: Seq Error,gatherInstVisitNrs_Syn_CVisit :: Map Identifier Int,intra_Syn_CVisit :: Exprs,intraVars_Syn_CVisit :: Set String,semNames_Syn_CVisit :: [String]} +wrap_CVisit (T_CVisit sem) (Inh_CVisit _lhsIallPragmas _lhsIchildren _lhsIcon _lhsIcontextMap _lhsIerrors _lhsIinh _lhsIinstVisitNrs _lhsIisLast _lhsInextIntra _lhsInextIntraVars _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIparamInstMap _lhsIparamMap _lhsIprefix _lhsIsyn _lhsIterminals _lhsIunfoldSemDom _lhsIwith_sig) = + (let ( _lhsOallTpsFound,_lhsOcomments,_lhsOdecls,_lhsOerrors,_lhsOgatherInstVisitNrs,_lhsOintra,_lhsOintraVars,_lhsOsemNames) = + (sem _lhsIallPragmas _lhsIchildren _lhsIcon _lhsIcontextMap _lhsIerrors _lhsIinh _lhsIinstVisitNrs _lhsIisLast _lhsInextIntra _lhsInextIntraVars _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIparamInstMap _lhsIparamMap _lhsIprefix _lhsIsyn _lhsIterminals _lhsIunfoldSemDom _lhsIwith_sig) + in (Syn_CVisit _lhsOallTpsFound _lhsOcomments _lhsOdecls _lhsOerrors _lhsOgatherInstVisitNrs _lhsOintra _lhsOintraVars _lhsOsemNames)) +sem_CVisit_CVisit :: Attributes -> + Attributes -> + T_Sequence -> + T_Sequence -> + Bool -> + T_CVisit +sem_CVisit_CVisit inh_ syn_ (T_Sequence vss_) (T_Sequence intra_) ordered_ = + (T_CVisit (\ _lhsIallPragmas + _lhsIchildren + _lhsIcon + _lhsIcontextMap + _lhsIerrors + _lhsIinh + _lhsIinstVisitNrs + _lhsIisLast + _lhsInextIntra + _lhsInextIntraVars + _lhsInr + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_costcentre + _lhsIo_data + _lhsIo_linePragmas + _lhsIo_newtypes + _lhsIo_pretty + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_splitsems + _lhsIo_strictwrap + _lhsIo_traces + _lhsIo_unbox + _lhsIparamInstMap + _lhsIparamMap + _lhsIprefix + _lhsIsyn + _lhsIterminals + _lhsIunfoldSemDom + _lhsIwith_sig -> + (let _lhsOintra :: Exprs + _lhsOintraVars :: (Set String) + _vssOlastExpr :: Expr + _intraOlastExpr :: Expr + _lhsOdecls :: Decls + _lhsOgatherInstVisitNrs :: (Map Identifier Int) + _vssOdeclsAbove :: ([Decl]) + _intraOdeclsAbove :: ([Decl]) + _lhsOallTpsFound :: Bool + _lhsOerrors :: (Seq Error) + _lhsOcomments :: ([String]) + _vssOwhat :: String + _intraOwhat :: String + _lhsOsemNames :: ([String]) + _vssOchildren :: ([(Identifier,Type,Bool)]) + _vssOcon :: ConstructorIdent + _vssOerrors :: (Seq Error) + _vssOhigherOrderChildren :: ([(Identifier,Type,Bool)]) + _vssOinh :: Attributes + _vssOinstVisitNrs :: (Map Identifier Int) + _vssOnr :: Int + _vssOnt :: NontermIdent + _vssOo_case :: Bool + _vssOo_cata :: Bool + _vssOo_costcentre :: Bool + _vssOo_data :: (Maybe Bool) + _vssOo_linePragmas :: Bool + _vssOo_newtypes :: Bool + _vssOo_pretty :: Bool + _vssOo_rename :: Bool + _vssOo_sem :: Bool + _vssOo_sig :: Bool + _vssOo_splitsems :: Bool + _vssOo_strictwrap :: Bool + _vssOo_traces :: Bool + _vssOo_unbox :: Bool + _vssOparamInstMap :: (Map Identifier (NontermIdent, [String])) + _vssOparamMap :: ParamMap + _vssOprefix :: String + _vssOsyn :: Attributes + _vssOterminals :: ([Identifier]) + _intraOchildren :: ([(Identifier,Type,Bool)]) + _intraOcon :: ConstructorIdent + _intraOerrors :: (Seq Error) + _intraOhigherOrderChildren :: ([(Identifier,Type,Bool)]) + _intraOinh :: Attributes + _intraOinstVisitNrs :: (Map Identifier Int) + _intraOnr :: Int + _intraOnt :: NontermIdent + _intraOo_case :: Bool + _intraOo_cata :: Bool + _intraOo_costcentre :: Bool + _intraOo_data :: (Maybe Bool) + _intraOo_linePragmas :: Bool + _intraOo_newtypes :: Bool + _intraOo_pretty :: Bool + _intraOo_rename :: Bool + _intraOo_sem :: Bool + _intraOo_sig :: Bool + _intraOo_splitsems :: Bool + _intraOo_strictwrap :: Bool + _intraOo_traces :: Bool + _intraOo_unbox :: Bool + _intraOparamInstMap :: (Map Identifier (NontermIdent, [String])) + _intraOparamMap :: ParamMap + _intraOprefix :: String + _intraOsyn :: Attributes + _intraOterminals :: ([Identifier]) + _vssIallTpsFound :: Bool + _vssIblockDecls :: DeclBlocks + _vssIcomments :: ([String]) + _vssIdecls :: Decls + _vssIdeclsAbove :: ([Decl]) + _vssIdefinedInsts :: ([Identifier]) + _vssIerrors :: (Seq Error) + _vssIexprs :: Exprs + _vssItSigs :: ([Decl]) + _vssItps :: ([Type]) + _vssIusedVars :: (Set String) + _intraIallTpsFound :: Bool + _intraIblockDecls :: DeclBlocks + _intraIcomments :: ([String]) + _intraIdecls :: Decls + _intraIdeclsAbove :: ([Decl]) + _intraIdefinedInsts :: ([Identifier]) + _intraIerrors :: (Seq Error) + _intraIexprs :: Exprs + _intraItSigs :: ([Decl]) + _intraItps :: ([Type]) + _intraIusedVars :: (Set String) + -- "GenerateCode.ag"(line 224, column 13) + _lhsOintra = + _intraIexprs + -- "GenerateCode.ag"(line 225, column 13) + _lhsOintraVars = + _intraIusedVars + -- "GenerateCode.ag"(line 333, column 13) + __tup4 = + partition (\(_,_,ho) -> ho) _lhsIchildren + -- "GenerateCode.ag"(line 333, column 13) + (_higherOrderChildren,_) = + __tup4 + -- "GenerateCode.ag"(line 333, column 13) + (_,_firstOrderChildren) = + __tup4 + -- "GenerateCode.ag"(line 334, column 13) + _funcname = + seqSemname _lhsIprefix _lhsInt _lhsIcon _lhsInr + -- "GenerateCode.ag"(line 335, column 13) + _nextVisitName = + if _lhsIisLast then [] else [visitname _lhsIprefix _lhsInt (_lhsInr+1)] + -- "GenerateCode.ag"(line 336, column 13) + _nextVisitDecl = + let lhs = TupleLhs _nextVisitName + rhs = App fun _lhsInextIntra + fun = seqSemname _lhsIprefix _lhsInt _lhsIcon (_lhsInr+1) + in if _lhsIisLast + then [] + else [Decl lhs rhs (Set.fromList _nextVisitName) _lhsInextIntraVars] + -- "GenerateCode.ag"(line 342, column 13) + _decls = + _typeSigs ++ _vssIdecls ++ _nextVisitDecl + -- "GenerateCode.ag"(line 343, column 13) + _vssOlastExpr = + mkTupleExpr _lhsIo_unbox (null $ Map.keys inh_) $ map (SimpleExpr . lhsname False) (Map.keys syn_) ++ map SimpleExpr _nextVisitName + -- "GenerateCode.ag"(line 344, column 13) + _intraOlastExpr = + error "lastExpr: not used here" + -- "GenerateCode.ag"(line 345, column 13) + _lastExprVars = + map (lhsname False) (Map.keys syn_) ++ _nextVisitName + -- "GenerateCode.ag"(line 346, column 13) + __tup5 = + mkPartitionedFunction _funcname _o_case _nextVisitDecl _lastExprVars _vssIblockDecls + -- "GenerateCode.ag"(line 346, column 13) + (_blockFunDecls,_) = + __tup5 + -- "GenerateCode.ag"(line 346, column 13) + (_,_blockFirstFunCall) = + __tup5 + -- "GenerateCode.ag"(line 348, column 13) + _costCentreDescr = + "b" ++ ":" ++ show _lhsInt ++ ":" ++ show _lhsIcon ++ ":" ++ show _lhsInr + -- "GenerateCode.ag"(line 349, column 13) + _addCostCentre = + \v -> if _lhsIo_costcentre + then PragmaExpr True False ("SCC \"" ++ _costCentreDescr ++ "\"") v + else v + -- "GenerateCode.ag"(line 353, column 13) + _params = + map getName $ Map.findWithDefault [] _lhsInt _lhsIparamMap + -- "GenerateCode.ag"(line 354, column 13) + _semFun = + let lhs = Fun _funcname lhs_args + lhs_args = if _lhsInr == 0 then map field _firstOrderChildren else _intraIexprs + field (name,NT tp tps,_) = let unwrap | _lhsIo_newtypes = \x -> App (sdtype tp) [x] + | otherwise = id + addType expr | null tps = expr + | otherwise = TypedExpr expr (_lhsIunfoldSemDom tp 0 tps) + in unwrap $ addType $ SimpleExpr $ funname name 0 + field (name,tp,_) = let expr = SimpleExpr (funname name 0) + in if null _params + then expr + else TypedExpr expr (SimpleType (typeToHaskellString (Just _lhsInt) _params tp)) + mbEvalTp | null _params = const Nothing + | otherwise = Just . idEvalType + rhs = wrap + . mkLambda [mkLambdaArg (lhsname True nm) (mbEvalTp $ SimpleType $ typeToHaskellString (Just _lhsInt) _params tp) | (nm,tp) <- Map.assocs inh_] + $ _addCostCentre + $ if ordered_ && _o_splitsems + then _blockFirstFunCall + else mkLet _o_case _decls + . mkTupleExpr _lhsIo_unbox (null $ Map.keys inh_) + $ map (SimpleExpr . lhsname False) (Map.keys syn_) ++ map SimpleExpr _nextVisitName + wrap = if _lhsIo_newtypes + then \x -> App (typeName _lhsInt _lhsInr) [x] + else id + in Decl lhs rhs Set.empty Set.empty + -- "GenerateCode.ag"(line 384, column 13) + _tsig = + TSig _funcname _semType + -- "GenerateCode.ag"(line 385, column 13) + _semType = + let argType (NT tp tps) rec | tp /= _SELF = typeAppStrs (sdtype tp) tps `Arr` rec + | tp == _SELF = error "GenerateCode: found an intra-type with type SELF, which should have been prevented by CRule.tps" + argType (Haskell tp) rec = SimpleType tp `Arr` rec + evalTp | null _params = id + | otherwise = idEvalType + in appContext _lhsIcontextMap _lhsInt $ evalTp $ + if _lhsInr == 0 + then foldr argType (typeAppStrs (sdtype _lhsInt ) _params ) (map (\(_,t,_) -> t) _firstOrderChildren ) + else foldr argType (typeAppStrs (typeName _lhsInt _lhsInr) _params ) _intraItps + -- "GenerateCode.ag"(line 396, column 13) + _lhsOdecls = + ( if _lhsIwith_sig + then [_tsig, _semFun] + else [_semFun] + ) ++ + ( if ordered_ && _o_splitsems + then _blockFunDecls + else [] + ) + -- "GenerateCode.ag"(line 404, column 13) + _typeSigs = + if _lhsIo_sig && not _o_case + then _vssItSigs + else [] + -- "GenerateCode.ag"(line 407, column 13) + _o_case = + _lhsIo_case && ordered_ && not (hasPragma _lhsIallPragmas _lhsInt _lhsIcon _NOCASE) + -- "GenerateCode.ag"(line 408, column 13) + _o_splitsems = + ordered_ && _lhsIo_splitsems + -- "GenerateCode.ag"(line 430, column 7) + _lhsOgatherInstVisitNrs = + Map.fromList [(i,_lhsInr) | i <- _vssIdefinedInsts] + -- "GenerateCode.ag"(line 441, column 7) + _vssOdeclsAbove = + [] + -- "GenerateCode.ag"(line 442, column 7) + _intraOdeclsAbove = + error "declsAbove: not used here" + -- "GenerateCode.ag"(line 688, column 13) + _lhsOallTpsFound = + _intraIallTpsFound + -- "GenerateCode.ag"(line 699, column 13) + _lhsOerrors = + _intraIerrors + -- "GenerateCode.ag"(line 732, column 18) + _lhsOcomments = + let body = map ind (_vssIcomments ++ _intraIcomments) + in if null body + then [] + else ("visit " ++ show _lhsInr ++ ":") : body + -- "GenerateCode.ag"(line 736, column 18) + _vssOwhat = + "local" + -- "GenerateCode.ag"(line 737, column 18) + _intraOwhat = + "intra" + -- "GenerateCode.ag"(line 920, column 7) + _lhsOsemNames = + [_funcname ] + -- copy rule (down) + _vssOchildren = + _lhsIchildren + -- copy rule (down) + _vssOcon = + _lhsIcon + -- copy rule (down) + _vssOerrors = + _lhsIerrors + -- copy rule (from local) + _vssOhigherOrderChildren = + _higherOrderChildren + -- copy rule (down) + _vssOinh = + _lhsIinh + -- copy rule (down) + _vssOinstVisitNrs = + _lhsIinstVisitNrs + -- copy rule (down) + _vssOnr = + _lhsInr + -- copy rule (down) + _vssOnt = + _lhsInt + -- copy rule (from local) + _vssOo_case = + _o_case + -- copy rule (down) + _vssOo_cata = + _lhsIo_cata + -- copy rule (down) + _vssOo_costcentre = + _lhsIo_costcentre + -- copy rule (down) + _vssOo_data = + _lhsIo_data + -- copy rule (down) + _vssOo_linePragmas = + _lhsIo_linePragmas + -- copy rule (down) + _vssOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _vssOo_pretty = + _lhsIo_pretty + -- copy rule (down) + _vssOo_rename = + _lhsIo_rename + -- copy rule (down) + _vssOo_sem = + _lhsIo_sem + -- copy rule (down) + _vssOo_sig = + _lhsIo_sig + -- copy rule (from local) + _vssOo_splitsems = + _o_splitsems + -- copy rule (down) + _vssOo_strictwrap = + _lhsIo_strictwrap + -- copy rule (down) + _vssOo_traces = + _lhsIo_traces + -- copy rule (down) + _vssOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _vssOparamInstMap = + _lhsIparamInstMap + -- copy rule (down) + _vssOparamMap = + _lhsIparamMap + -- copy rule (down) + _vssOprefix = + _lhsIprefix + -- copy rule (down) + _vssOsyn = + _lhsIsyn + -- copy rule (down) + _vssOterminals = + _lhsIterminals + -- copy rule (down) + _intraOchildren = + _lhsIchildren + -- copy rule (down) + _intraOcon = + _lhsIcon + -- copy rule (chain) + _intraOerrors = + _vssIerrors + -- copy rule (from local) + _intraOhigherOrderChildren = + _higherOrderChildren + -- copy rule (down) + _intraOinh = + _lhsIinh + -- copy rule (down) + _intraOinstVisitNrs = + _lhsIinstVisitNrs + -- copy rule (down) + _intraOnr = + _lhsInr + -- copy rule (down) + _intraOnt = + _lhsInt + -- copy rule (from local) + _intraOo_case = + _o_case + -- copy rule (down) + _intraOo_cata = + _lhsIo_cata + -- copy rule (down) + _intraOo_costcentre = + _lhsIo_costcentre + -- copy rule (down) + _intraOo_data = + _lhsIo_data + -- copy rule (down) + _intraOo_linePragmas = + _lhsIo_linePragmas + -- copy rule (down) + _intraOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _intraOo_pretty = + _lhsIo_pretty + -- copy rule (down) + _intraOo_rename = + _lhsIo_rename + -- copy rule (down) + _intraOo_sem = + _lhsIo_sem + -- copy rule (down) + _intraOo_sig = + _lhsIo_sig + -- copy rule (from local) + _intraOo_splitsems = + _o_splitsems + -- copy rule (down) + _intraOo_strictwrap = + _lhsIo_strictwrap + -- copy rule (down) + _intraOo_traces = + _lhsIo_traces + -- copy rule (down) + _intraOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _intraOparamInstMap = + _lhsIparamInstMap + -- copy rule (down) + _intraOparamMap = + _lhsIparamMap + -- copy rule (down) + _intraOprefix = + _lhsIprefix + -- copy rule (down) + _intraOsyn = + _lhsIsyn + -- copy rule (down) + _intraOterminals = + _lhsIterminals + ( _vssIallTpsFound,_vssIblockDecls,_vssIcomments,_vssIdecls,_vssIdeclsAbove,_vssIdefinedInsts,_vssIerrors,_vssIexprs,_vssItSigs,_vssItps,_vssIusedVars) = + (vss_ _vssOchildren _vssOcon _vssOdeclsAbove _vssOerrors _vssOhigherOrderChildren _vssOinh _vssOinstVisitNrs _vssOlastExpr _vssOnr _vssOnt _vssOo_case _vssOo_cata _vssOo_costcentre _vssOo_data _vssOo_linePragmas _vssOo_newtypes _vssOo_pretty _vssOo_rename _vssOo_sem _vssOo_sig _vssOo_splitsems _vssOo_strictwrap _vssOo_traces _vssOo_unbox _vssOparamInstMap _vssOparamMap _vssOprefix _vssOsyn _vssOterminals _vssOwhat) + ( _intraIallTpsFound,_intraIblockDecls,_intraIcomments,_intraIdecls,_intraIdeclsAbove,_intraIdefinedInsts,_intraIerrors,_intraIexprs,_intraItSigs,_intraItps,_intraIusedVars) = + (intra_ _intraOchildren _intraOcon _intraOdeclsAbove _intraOerrors _intraOhigherOrderChildren _intraOinh _intraOinstVisitNrs _intraOlastExpr _intraOnr _intraOnt _intraOo_case _intraOo_cata _intraOo_costcentre _intraOo_data _intraOo_linePragmas _intraOo_newtypes _intraOo_pretty _intraOo_rename _intraOo_sem _intraOo_sig _intraOo_splitsems _intraOo_strictwrap _intraOo_traces _intraOo_unbox _intraOparamInstMap _intraOparamMap _intraOprefix _intraOsyn _intraOterminals _intraOwhat) + in ( _lhsOallTpsFound,_lhsOcomments,_lhsOdecls,_lhsOerrors,_lhsOgatherInstVisitNrs,_lhsOintra,_lhsOintraVars,_lhsOsemNames)))) +-- CVisits ----------------------------------------------------- +{- + visit 0: + inherited attributes: + allPragmas : PragmaMap + children : [(Identifier,Type,Bool)] + con : ConstructorIdent + contextMap : ContextMap + inh : Attributes + instVisitNrs : Map Identifier Int + nr : Int + nt : NontermIdent + o_case : Bool + o_cata : Bool + o_costcentre : Bool + o_data : Maybe Bool + o_linePragmas : Bool + o_newtypes : Bool + o_pretty : Bool + o_rename : Bool + o_sem : Bool + o_sig : Bool + o_splitsems : Bool + o_strictwrap : Bool + o_traces : Bool + o_unbox : Bool + paramInstMap : Map Identifier (NontermIdent, [String]) + paramMap : ParamMap + prefix : String + syn : Attributes + terminals : [Identifier] + unfoldSemDom : NontermIdent -> Int -> [String] -> Code.Type + with_sig : Bool + chained attribute: + errors : Seq Error + synthesized attributes: + allTpsFound : Bool + comments : [String] + decls : Decls + gatherInstVisitNrs : Map Identifier Int + intra : Exprs + intraVars : Set String + isNil : Bool + semNames : [String] + alternatives: + alternative Cons: + child hd : CVisit + child tl : CVisits + alternative Nil: +-} +-- cata +sem_CVisits :: CVisits -> + T_CVisits +sem_CVisits list = + (Prelude.foldr sem_CVisits_Cons sem_CVisits_Nil (Prelude.map sem_CVisit list)) +-- semantic domain +newtype T_CVisits = T_CVisits (PragmaMap -> + ([(Identifier,Type,Bool)]) -> + ConstructorIdent -> + ContextMap -> + (Seq Error) -> + Attributes -> + (Map Identifier Int) -> + Int -> + NontermIdent -> + Bool -> + Bool -> + Bool -> + (Maybe Bool) -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + (Map Identifier (NontermIdent, [String])) -> + ParamMap -> + String -> + Attributes -> + ([Identifier]) -> + (NontermIdent -> Int -> [String] -> Code.Type) -> + Bool -> + ( Bool,([String]),Decls,(Seq Error),(Map Identifier Int),Exprs,(Set String),Bool,([String]))) +data Inh_CVisits = Inh_CVisits {allPragmas_Inh_CVisits :: PragmaMap,children_Inh_CVisits :: [(Identifier,Type,Bool)],con_Inh_CVisits :: ConstructorIdent,contextMap_Inh_CVisits :: ContextMap,errors_Inh_CVisits :: Seq Error,inh_Inh_CVisits :: Attributes,instVisitNrs_Inh_CVisits :: Map Identifier Int,nr_Inh_CVisits :: Int,nt_Inh_CVisits :: NontermIdent,o_case_Inh_CVisits :: Bool,o_cata_Inh_CVisits :: Bool,o_costcentre_Inh_CVisits :: Bool,o_data_Inh_CVisits :: Maybe Bool,o_linePragmas_Inh_CVisits :: Bool,o_newtypes_Inh_CVisits :: Bool,o_pretty_Inh_CVisits :: Bool,o_rename_Inh_CVisits :: Bool,o_sem_Inh_CVisits :: Bool,o_sig_Inh_CVisits :: Bool,o_splitsems_Inh_CVisits :: Bool,o_strictwrap_Inh_CVisits :: Bool,o_traces_Inh_CVisits :: Bool,o_unbox_Inh_CVisits :: Bool,paramInstMap_Inh_CVisits :: Map Identifier (NontermIdent, [String]),paramMap_Inh_CVisits :: ParamMap,prefix_Inh_CVisits :: String,syn_Inh_CVisits :: Attributes,terminals_Inh_CVisits :: [Identifier],unfoldSemDom_Inh_CVisits :: NontermIdent -> Int -> [String] -> Code.Type,with_sig_Inh_CVisits :: Bool} +data Syn_CVisits = Syn_CVisits {allTpsFound_Syn_CVisits :: Bool,comments_Syn_CVisits :: [String],decls_Syn_CVisits :: Decls,errors_Syn_CVisits :: Seq Error,gatherInstVisitNrs_Syn_CVisits :: Map Identifier Int,intra_Syn_CVisits :: Exprs,intraVars_Syn_CVisits :: Set String,isNil_Syn_CVisits :: Bool,semNames_Syn_CVisits :: [String]} +wrap_CVisits (T_CVisits sem) (Inh_CVisits _lhsIallPragmas _lhsIchildren _lhsIcon _lhsIcontextMap _lhsIerrors _lhsIinh _lhsIinstVisitNrs _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIparamInstMap _lhsIparamMap _lhsIprefix _lhsIsyn _lhsIterminals _lhsIunfoldSemDom _lhsIwith_sig) = + (let ( _lhsOallTpsFound,_lhsOcomments,_lhsOdecls,_lhsOerrors,_lhsOgatherInstVisitNrs,_lhsOintra,_lhsOintraVars,_lhsOisNil,_lhsOsemNames) = + (sem _lhsIallPragmas _lhsIchildren _lhsIcon _lhsIcontextMap _lhsIerrors _lhsIinh _lhsIinstVisitNrs _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIparamInstMap _lhsIparamMap _lhsIprefix _lhsIsyn _lhsIterminals _lhsIunfoldSemDom _lhsIwith_sig) + in (Syn_CVisits _lhsOallTpsFound _lhsOcomments _lhsOdecls _lhsOerrors _lhsOgatherInstVisitNrs _lhsOintra _lhsOintraVars _lhsOisNil _lhsOsemNames)) +sem_CVisits_Cons :: T_CVisit -> + T_CVisits -> + T_CVisits +sem_CVisits_Cons (T_CVisit hd_) (T_CVisits tl_) = + (T_CVisits (\ _lhsIallPragmas + _lhsIchildren + _lhsIcon + _lhsIcontextMap + _lhsIerrors + _lhsIinh + _lhsIinstVisitNrs + _lhsInr + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_costcentre + _lhsIo_data + _lhsIo_linePragmas + _lhsIo_newtypes + _lhsIo_pretty + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_splitsems + _lhsIo_strictwrap + _lhsIo_traces + _lhsIo_unbox + _lhsIparamInstMap + _lhsIparamMap + _lhsIprefix + _lhsIsyn + _lhsIterminals + _lhsIunfoldSemDom + _lhsIwith_sig -> + (let _tlOnr :: Int + _lhsOisNil :: Bool + _hdOisLast :: Bool + _hdOnextIntra :: Exprs + _hdOnextIntraVars :: (Set String) + _lhsOintra :: Exprs + _lhsOintraVars :: (Set String) + _lhsOallTpsFound :: Bool + _lhsOcomments :: ([String]) + _lhsOdecls :: Decls + _lhsOerrors :: (Seq Error) + _lhsOgatherInstVisitNrs :: (Map Identifier Int) + _lhsOsemNames :: ([String]) + _hdOallPragmas :: PragmaMap + _hdOchildren :: ([(Identifier,Type,Bool)]) + _hdOcon :: ConstructorIdent + _hdOcontextMap :: ContextMap + _hdOerrors :: (Seq Error) + _hdOinh :: Attributes + _hdOinstVisitNrs :: (Map Identifier Int) + _hdOnr :: Int + _hdOnt :: NontermIdent + _hdOo_case :: Bool + _hdOo_cata :: Bool + _hdOo_costcentre :: Bool + _hdOo_data :: (Maybe Bool) + _hdOo_linePragmas :: Bool + _hdOo_newtypes :: Bool + _hdOo_pretty :: Bool + _hdOo_rename :: Bool + _hdOo_sem :: Bool + _hdOo_sig :: Bool + _hdOo_splitsems :: Bool + _hdOo_strictwrap :: Bool + _hdOo_traces :: Bool + _hdOo_unbox :: Bool + _hdOparamInstMap :: (Map Identifier (NontermIdent, [String])) + _hdOparamMap :: ParamMap + _hdOprefix :: String + _hdOsyn :: Attributes + _hdOterminals :: ([Identifier]) + _hdOunfoldSemDom :: (NontermIdent -> Int -> [String] -> Code.Type) + _hdOwith_sig :: Bool + _tlOallPragmas :: PragmaMap + _tlOchildren :: ([(Identifier,Type,Bool)]) + _tlOcon :: ConstructorIdent + _tlOcontextMap :: ContextMap + _tlOerrors :: (Seq Error) + _tlOinh :: Attributes + _tlOinstVisitNrs :: (Map Identifier Int) + _tlOnt :: NontermIdent + _tlOo_case :: Bool + _tlOo_cata :: Bool + _tlOo_costcentre :: Bool + _tlOo_data :: (Maybe Bool) + _tlOo_linePragmas :: Bool + _tlOo_newtypes :: Bool + _tlOo_pretty :: Bool + _tlOo_rename :: Bool + _tlOo_sem :: Bool + _tlOo_sig :: Bool + _tlOo_splitsems :: Bool + _tlOo_strictwrap :: Bool + _tlOo_traces :: Bool + _tlOo_unbox :: Bool + _tlOparamInstMap :: (Map Identifier (NontermIdent, [String])) + _tlOparamMap :: ParamMap + _tlOprefix :: String + _tlOsyn :: Attributes + _tlOterminals :: ([Identifier]) + _tlOunfoldSemDom :: (NontermIdent -> Int -> [String] -> Code.Type) + _tlOwith_sig :: Bool + _hdIallTpsFound :: Bool + _hdIcomments :: ([String]) + _hdIdecls :: Decls + _hdIerrors :: (Seq Error) + _hdIgatherInstVisitNrs :: (Map Identifier Int) + _hdIintra :: Exprs + _hdIintraVars :: (Set String) + _hdIsemNames :: ([String]) + _tlIallTpsFound :: Bool + _tlIcomments :: ([String]) + _tlIdecls :: Decls + _tlIerrors :: (Seq Error) + _tlIgatherInstVisitNrs :: (Map Identifier Int) + _tlIintra :: Exprs + _tlIintraVars :: (Set String) + _tlIisNil :: Bool + _tlIsemNames :: ([String]) + -- "GenerateCode.ag"(line 196, column 11) + _tlOnr = + _lhsInr + 1 + -- "GenerateCode.ag"(line 209, column 12) + _lhsOisNil = + False + -- "GenerateCode.ag"(line 210, column 12) + _hdOisLast = + _tlIisNil + -- "GenerateCode.ag"(line 227, column 12) + _hdOnextIntra = + _tlIintra + -- "GenerateCode.ag"(line 228, column 12) + _hdOnextIntraVars = + _tlIintraVars + -- "GenerateCode.ag"(line 229, column 12) + _lhsOintra = + _hdIintra + -- "GenerateCode.ag"(line 230, column 12) + _lhsOintraVars = + _hdIintraVars + -- use rule "GenerateCode.ag"(line 682, column 39) + _lhsOallTpsFound = + _hdIallTpsFound && _tlIallTpsFound + -- use rule "GenerateCode.ag"(line 714, column 52) + _lhsOcomments = + _hdIcomments ++ _tlIcomments + -- use rule "GenerateCode.ag"(line 331, column 33) + _lhsOdecls = + _hdIdecls ++ _tlIdecls + -- use rule "GenerateCode.ag"(line 695, column 32) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- use rule "GenerateCode.ag"(line 423, column 44) + _lhsOgatherInstVisitNrs = + _hdIgatherInstVisitNrs `Map.union` _tlIgatherInstVisitNrs + -- use rule "GenerateCode.ag"(line 910, column 61) + _lhsOsemNames = + _hdIsemNames ++ _tlIsemNames + -- copy rule (down) + _hdOallPragmas = + _lhsIallPragmas + -- copy rule (down) + _hdOchildren = + _lhsIchildren + -- copy rule (down) + _hdOcon = + _lhsIcon + -- copy rule (down) + _hdOcontextMap = + _lhsIcontextMap + -- copy rule (down) + _hdOerrors = + _lhsIerrors + -- copy rule (down) + _hdOinh = + _lhsIinh + -- copy rule (down) + _hdOinstVisitNrs = + _lhsIinstVisitNrs + -- copy rule (down) + _hdOnr = + _lhsInr + -- copy rule (down) + _hdOnt = + _lhsInt + -- copy rule (down) + _hdOo_case = + _lhsIo_case + -- copy rule (down) + _hdOo_cata = + _lhsIo_cata + -- copy rule (down) + _hdOo_costcentre = + _lhsIo_costcentre + -- copy rule (down) + _hdOo_data = + _lhsIo_data + -- copy rule (down) + _hdOo_linePragmas = + _lhsIo_linePragmas + -- copy rule (down) + _hdOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _hdOo_pretty = + _lhsIo_pretty + -- copy rule (down) + _hdOo_rename = + _lhsIo_rename + -- copy rule (down) + _hdOo_sem = + _lhsIo_sem + -- copy rule (down) + _hdOo_sig = + _lhsIo_sig + -- copy rule (down) + _hdOo_splitsems = + _lhsIo_splitsems + -- copy rule (down) + _hdOo_strictwrap = + _lhsIo_strictwrap + -- copy rule (down) + _hdOo_traces = + _lhsIo_traces + -- copy rule (down) + _hdOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _hdOparamInstMap = + _lhsIparamInstMap + -- copy rule (down) + _hdOparamMap = + _lhsIparamMap + -- copy rule (down) + _hdOprefix = + _lhsIprefix + -- copy rule (down) + _hdOsyn = + _lhsIsyn + -- copy rule (down) + _hdOterminals = + _lhsIterminals + -- copy rule (down) + _hdOunfoldSemDom = + _lhsIunfoldSemDom + -- copy rule (down) + _hdOwith_sig = + _lhsIwith_sig + -- copy rule (down) + _tlOallPragmas = + _lhsIallPragmas + -- copy rule (down) + _tlOchildren = + _lhsIchildren + -- copy rule (down) + _tlOcon = + _lhsIcon + -- copy rule (down) + _tlOcontextMap = + _lhsIcontextMap + -- copy rule (chain) + _tlOerrors = + _hdIerrors + -- copy rule (down) + _tlOinh = + _lhsIinh + -- copy rule (down) + _tlOinstVisitNrs = + _lhsIinstVisitNrs + -- copy rule (down) + _tlOnt = + _lhsInt + -- copy rule (down) + _tlOo_case = + _lhsIo_case + -- copy rule (down) + _tlOo_cata = + _lhsIo_cata + -- copy rule (down) + _tlOo_costcentre = + _lhsIo_costcentre + -- copy rule (down) + _tlOo_data = + _lhsIo_data + -- copy rule (down) + _tlOo_linePragmas = + _lhsIo_linePragmas + -- copy rule (down) + _tlOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _tlOo_pretty = + _lhsIo_pretty + -- copy rule (down) + _tlOo_rename = + _lhsIo_rename + -- copy rule (down) + _tlOo_sem = + _lhsIo_sem + -- copy rule (down) + _tlOo_sig = + _lhsIo_sig + -- copy rule (down) + _tlOo_splitsems = + _lhsIo_splitsems + -- copy rule (down) + _tlOo_strictwrap = + _lhsIo_strictwrap + -- copy rule (down) + _tlOo_traces = + _lhsIo_traces + -- copy rule (down) + _tlOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _tlOparamInstMap = + _lhsIparamInstMap + -- copy rule (down) + _tlOparamMap = + _lhsIparamMap + -- copy rule (down) + _tlOprefix = + _lhsIprefix + -- copy rule (down) + _tlOsyn = + _lhsIsyn + -- copy rule (down) + _tlOterminals = + _lhsIterminals + -- copy rule (down) + _tlOunfoldSemDom = + _lhsIunfoldSemDom + -- copy rule (down) + _tlOwith_sig = + _lhsIwith_sig + ( _hdIallTpsFound,_hdIcomments,_hdIdecls,_hdIerrors,_hdIgatherInstVisitNrs,_hdIintra,_hdIintraVars,_hdIsemNames) = + (hd_ _hdOallPragmas _hdOchildren _hdOcon _hdOcontextMap _hdOerrors _hdOinh _hdOinstVisitNrs _hdOisLast _hdOnextIntra _hdOnextIntraVars _hdOnr _hdOnt _hdOo_case _hdOo_cata _hdOo_costcentre _hdOo_data _hdOo_linePragmas _hdOo_newtypes _hdOo_pretty _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_splitsems _hdOo_strictwrap _hdOo_traces _hdOo_unbox _hdOparamInstMap _hdOparamMap _hdOprefix _hdOsyn _hdOterminals _hdOunfoldSemDom _hdOwith_sig) + ( _tlIallTpsFound,_tlIcomments,_tlIdecls,_tlIerrors,_tlIgatherInstVisitNrs,_tlIintra,_tlIintraVars,_tlIisNil,_tlIsemNames) = + (tl_ _tlOallPragmas _tlOchildren _tlOcon _tlOcontextMap _tlOerrors _tlOinh _tlOinstVisitNrs _tlOnr _tlOnt _tlOo_case _tlOo_cata _tlOo_costcentre _tlOo_data _tlOo_linePragmas _tlOo_newtypes _tlOo_pretty _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_splitsems _tlOo_strictwrap _tlOo_traces _tlOo_unbox _tlOparamInstMap _tlOparamMap _tlOprefix _tlOsyn _tlOterminals _tlOunfoldSemDom _tlOwith_sig) + in ( _lhsOallTpsFound,_lhsOcomments,_lhsOdecls,_lhsOerrors,_lhsOgatherInstVisitNrs,_lhsOintra,_lhsOintraVars,_lhsOisNil,_lhsOsemNames)))) +sem_CVisits_Nil :: T_CVisits +sem_CVisits_Nil = + (T_CVisits (\ _lhsIallPragmas + _lhsIchildren + _lhsIcon + _lhsIcontextMap + _lhsIerrors + _lhsIinh + _lhsIinstVisitNrs + _lhsInr + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_costcentre + _lhsIo_data + _lhsIo_linePragmas + _lhsIo_newtypes + _lhsIo_pretty + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_splitsems + _lhsIo_strictwrap + _lhsIo_traces + _lhsIo_unbox + _lhsIparamInstMap + _lhsIparamMap + _lhsIprefix + _lhsIsyn + _lhsIterminals + _lhsIunfoldSemDom + _lhsIwith_sig -> + (let _lhsOisNil :: Bool + _lhsOintra :: Exprs + _lhsOintraVars :: (Set String) + _lhsOallTpsFound :: Bool + _lhsOcomments :: ([String]) + _lhsOdecls :: Decls + _lhsOerrors :: (Seq Error) + _lhsOgatherInstVisitNrs :: (Map Identifier Int) + _lhsOsemNames :: ([String]) + -- "GenerateCode.ag"(line 211, column 10) + _lhsOisNil = + True + -- "GenerateCode.ag"(line 231, column 10) + _lhsOintra = + [] + -- "GenerateCode.ag"(line 232, column 10) + _lhsOintraVars = + Set.empty + -- use rule "GenerateCode.ag"(line 682, column 39) + _lhsOallTpsFound = + True + -- use rule "GenerateCode.ag"(line 714, column 52) + _lhsOcomments = + [] + -- use rule "GenerateCode.ag"(line 331, column 33) + _lhsOdecls = + [] + -- use rule "GenerateCode.ag"(line 695, column 32) + _lhsOerrors = + Seq.empty + -- use rule "GenerateCode.ag"(line 423, column 44) + _lhsOgatherInstVisitNrs = + Map.empty + -- use rule "GenerateCode.ag"(line 910, column 61) + _lhsOsemNames = + [] + in ( _lhsOallTpsFound,_lhsOcomments,_lhsOdecls,_lhsOerrors,_lhsOgatherInstVisitNrs,_lhsOintra,_lhsOintraVars,_lhsOisNil,_lhsOsemNames)))) +-- DeclBlocks -------------------------------------------------- +{- + visit 0: + inherited attributes: + blockNr : Int + lastExprVars : [String] + nextVisitDecls : [Decl] + optCase : Bool + prefix : String + synthesized attributes: + callExpr : Expr + decls : [Decl] + freeVars : [String] + alternatives: + alternative DeclBlock: + child defs : {[Decl]} + child visit : {Decl} + child next : DeclBlocks + visit 0: + local lambdaName : _ + local pragmaDecl : _ + local freeVars : _ + local decl : _ + alternative DeclTerminator: + child defs : {[Decl]} + child result : {Expr} + visit 0: + local lambdaName : _ + local pragmaDecl : _ + local freeVars : _ +-} +-- cata +sem_DeclBlocks :: DeclBlocks -> + T_DeclBlocks +sem_DeclBlocks (DeclBlock _defs _visit _next) = + (sem_DeclBlocks_DeclBlock _defs _visit (sem_DeclBlocks _next)) +sem_DeclBlocks (DeclTerminator _defs _result) = + (sem_DeclBlocks_DeclTerminator _defs _result) +-- semantic domain +newtype T_DeclBlocks = T_DeclBlocks (Int -> + ([String]) -> + ([Decl]) -> + Bool -> + String -> + ( Expr,([Decl]),([String]))) +data Inh_DeclBlocks = Inh_DeclBlocks {blockNr_Inh_DeclBlocks :: Int,lastExprVars_Inh_DeclBlocks :: [String],nextVisitDecls_Inh_DeclBlocks :: [Decl],optCase_Inh_DeclBlocks :: Bool,prefix_Inh_DeclBlocks :: String} +data Syn_DeclBlocks = Syn_DeclBlocks {callExpr_Syn_DeclBlocks :: Expr,decls_Syn_DeclBlocks :: [Decl],freeVars_Syn_DeclBlocks :: [String]} +wrap_DeclBlocks (T_DeclBlocks sem) (Inh_DeclBlocks _lhsIblockNr _lhsIlastExprVars _lhsInextVisitDecls _lhsIoptCase _lhsIprefix) = + (let ( _lhsOcallExpr,_lhsOdecls,_lhsOfreeVars) = + (sem _lhsIblockNr _lhsIlastExprVars _lhsInextVisitDecls _lhsIoptCase _lhsIprefix) + in (Syn_DeclBlocks _lhsOcallExpr _lhsOdecls _lhsOfreeVars)) +sem_DeclBlocks_DeclBlock :: ([Decl]) -> + Decl -> + T_DeclBlocks -> + T_DeclBlocks +sem_DeclBlocks_DeclBlock defs_ visit_ (T_DeclBlocks next_) = + (T_DeclBlocks (\ _lhsIblockNr + _lhsIlastExprVars + _lhsInextVisitDecls + _lhsIoptCase + _lhsIprefix -> + (let _nextOblockNr :: Int + _lhsOcallExpr :: Expr + _lhsOdecls :: ([Decl]) + _lhsOfreeVars :: ([String]) + _nextOlastExprVars :: ([String]) + _nextOnextVisitDecls :: ([Decl]) + _nextOoptCase :: Bool + _nextOprefix :: String + _nextIcallExpr :: Expr + _nextIdecls :: ([Decl]) + _nextIfreeVars :: ([String]) + -- "GenerateCode.ag"(line 520, column 7) + _nextOblockNr = + _lhsIblockNr + 1 + -- "GenerateCode.ag"(line 525, column 7) + _lambdaName = + _lhsIprefix ++ "_block" ++ show _lhsIblockNr + -- "GenerateCode.ag"(line 526, column 7) + _pragmaDecl = + PragmaDecl ("NOINLINE " ++ _lambdaName ) + -- "GenerateCode.ag"(line 527, column 7) + _lhsOcallExpr = + App _lambdaName (map SimpleExpr _freeVars ) + -- "GenerateCode.ag"(line 531, column 7) + _freeVars = + freevars _nextIfreeVars (visit_ : defs_) + -- "GenerateCode.ag"(line 538, column 7) + _decl = + mkBlockLambda _lhsIoptCase _lambdaName _freeVars (defs_ ++ [visit_]) _nextIcallExpr + -- "GenerateCode.ag"(line 539, column 7) + _lhsOdecls = + (if _lhsIblockNr > 1 then [_pragmaDecl ] else []) ++ [_decl ] ++ _nextIdecls + -- copy rule (from local) + _lhsOfreeVars = + _freeVars + -- copy rule (down) + _nextOlastExprVars = + _lhsIlastExprVars + -- copy rule (down) + _nextOnextVisitDecls = + _lhsInextVisitDecls + -- copy rule (down) + _nextOoptCase = + _lhsIoptCase + -- copy rule (down) + _nextOprefix = + _lhsIprefix + ( _nextIcallExpr,_nextIdecls,_nextIfreeVars) = + (next_ _nextOblockNr _nextOlastExprVars _nextOnextVisitDecls _nextOoptCase _nextOprefix) + in ( _lhsOcallExpr,_lhsOdecls,_lhsOfreeVars)))) +sem_DeclBlocks_DeclTerminator :: ([Decl]) -> + Expr -> + T_DeclBlocks +sem_DeclBlocks_DeclTerminator defs_ result_ = + (T_DeclBlocks (\ _lhsIblockNr + _lhsIlastExprVars + _lhsInextVisitDecls + _lhsIoptCase + _lhsIprefix -> + (let _lhsOcallExpr :: Expr + _lhsOdecls :: ([Decl]) + _lhsOfreeVars :: ([String]) + -- "GenerateCode.ag"(line 525, column 7) + _lambdaName = + _lhsIprefix ++ "_block" ++ show _lhsIblockNr + -- "GenerateCode.ag"(line 526, column 7) + _pragmaDecl = + PragmaDecl ("NOINLINE " ++ _lambdaName ) + -- "GenerateCode.ag"(line 527, column 7) + _lhsOcallExpr = + App _lambdaName (map SimpleExpr _freeVars ) + -- "GenerateCode.ag"(line 529, column 7) + _freeVars = + freevars _lhsIlastExprVars (defs_ ++ _lhsInextVisitDecls) + -- "GenerateCode.ag"(line 536, column 7) + _lhsOdecls = + [ mkBlockLambda _lhsIoptCase _lambdaName _freeVars (defs_ ++ _lhsInextVisitDecls) result_ ] + -- copy rule (from local) + _lhsOfreeVars = + _freeVars + in ( _lhsOcallExpr,_lhsOdecls,_lhsOfreeVars)))) +-- DeclBlocksRoot ---------------------------------------------- +{- + visit 0: + inherited attributes: + lastExprVars : [String] + nextVisitDecls : [Decl] + optCase : Bool + prefix : String + synthesized attributes: + firstCall : Expr + lambdas : [Decl] + alternatives: + alternative DeclBlocksRoot: + child blocks : DeclBlocks +-} +-- cata +sem_DeclBlocksRoot :: DeclBlocksRoot -> + T_DeclBlocksRoot +sem_DeclBlocksRoot (DeclBlocksRoot _blocks) = + (sem_DeclBlocksRoot_DeclBlocksRoot (sem_DeclBlocks _blocks)) +-- semantic domain +newtype T_DeclBlocksRoot = T_DeclBlocksRoot (([String]) -> + ([Decl]) -> + Bool -> + String -> + ( Expr,([Decl]))) +data Inh_DeclBlocksRoot = Inh_DeclBlocksRoot {lastExprVars_Inh_DeclBlocksRoot :: [String],nextVisitDecls_Inh_DeclBlocksRoot :: [Decl],optCase_Inh_DeclBlocksRoot :: Bool,prefix_Inh_DeclBlocksRoot :: String} +data Syn_DeclBlocksRoot = Syn_DeclBlocksRoot {firstCall_Syn_DeclBlocksRoot :: Expr,lambdas_Syn_DeclBlocksRoot :: [Decl]} +wrap_DeclBlocksRoot (T_DeclBlocksRoot sem) (Inh_DeclBlocksRoot _lhsIlastExprVars _lhsInextVisitDecls _lhsIoptCase _lhsIprefix) = + (let ( _lhsOfirstCall,_lhsOlambdas) = + (sem _lhsIlastExprVars _lhsInextVisitDecls _lhsIoptCase _lhsIprefix) + in (Syn_DeclBlocksRoot _lhsOfirstCall _lhsOlambdas)) +sem_DeclBlocksRoot_DeclBlocksRoot :: T_DeclBlocks -> + T_DeclBlocksRoot +sem_DeclBlocksRoot_DeclBlocksRoot (T_DeclBlocks blocks_) = + (T_DeclBlocksRoot (\ _lhsIlastExprVars + _lhsInextVisitDecls + _lhsIoptCase + _lhsIprefix -> + (let _lhsOlambdas :: ([Decl]) + _lhsOfirstCall :: Expr + _blocksOblockNr :: Int + _blocksOlastExprVars :: ([String]) + _blocksOnextVisitDecls :: ([Decl]) + _blocksOoptCase :: Bool + _blocksOprefix :: String + _blocksIcallExpr :: Expr + _blocksIdecls :: ([Decl]) + _blocksIfreeVars :: ([String]) + -- "GenerateCode.ag"(line 511, column 7) + _lhsOlambdas = + _blocksIdecls + -- "GenerateCode.ag"(line 512, column 7) + _lhsOfirstCall = + _blocksIcallExpr + -- "GenerateCode.ag"(line 517, column 7) + _blocksOblockNr = + 1 + -- copy rule (down) + _blocksOlastExprVars = + _lhsIlastExprVars + -- copy rule (down) + _blocksOnextVisitDecls = + _lhsInextVisitDecls + -- copy rule (down) + _blocksOoptCase = + _lhsIoptCase + -- copy rule (down) + _blocksOprefix = + _lhsIprefix + ( _blocksIcallExpr,_blocksIdecls,_blocksIfreeVars) = + (blocks_ _blocksOblockNr _blocksOlastExprVars _blocksOnextVisitDecls _blocksOoptCase _blocksOprefix) + in ( _lhsOfirstCall,_lhsOlambdas)))) +-- Pattern ----------------------------------------------------- +{- + visit 0: + synthesized attributes: + copy : SELF + definedInsts : [Identifier] + patternAttributes : [(Identifier, Identifier)] + alternatives: + alternative Alias: + child field : {Identifier} + child attr : {Identifier} + child pat : Pattern + child parts : Patterns + visit 0: + local copy : _ + alternative Constr: + child name : {ConstructorIdent} + child pats : Patterns + visit 0: + local copy : _ + alternative Irrefutable: + child pat : Pattern + visit 0: + local copy : _ + alternative Product: + child pos : {Pos} + child pats : Patterns + visit 0: + local copy : _ + alternative Underscore: + child pos : {Pos} + visit 0: + local copy : _ +-} +-- cata +sem_Pattern :: Pattern -> + T_Pattern +sem_Pattern (Alias _field _attr _pat _parts) = + (sem_Pattern_Alias _field _attr (sem_Pattern _pat) (sem_Patterns _parts)) +sem_Pattern (Constr _name _pats) = + (sem_Pattern_Constr _name (sem_Patterns _pats)) +sem_Pattern (Irrefutable _pat) = + (sem_Pattern_Irrefutable (sem_Pattern _pat)) +sem_Pattern (Product _pos _pats) = + (sem_Pattern_Product _pos (sem_Patterns _pats)) +sem_Pattern (Underscore _pos) = + (sem_Pattern_Underscore _pos) +-- semantic domain +newtype T_Pattern = T_Pattern (( Pattern,([Identifier]),([(Identifier, Identifier)]))) +data Inh_Pattern = Inh_Pattern {} +data Syn_Pattern = Syn_Pattern {copy_Syn_Pattern :: Pattern,definedInsts_Syn_Pattern :: [Identifier],patternAttributes_Syn_Pattern :: [(Identifier, Identifier)]} +wrap_Pattern (T_Pattern sem) (Inh_Pattern ) = + (let ( _lhsOcopy,_lhsOdefinedInsts,_lhsOpatternAttributes) = + (sem ) + in (Syn_Pattern _lhsOcopy _lhsOdefinedInsts _lhsOpatternAttributes)) +sem_Pattern_Alias :: Identifier -> + Identifier -> + T_Pattern -> + T_Patterns -> + T_Pattern +sem_Pattern_Alias field_ attr_ (T_Pattern pat_) (T_Patterns parts_) = + (T_Pattern (let _lhsOdefinedInsts :: ([Identifier]) + _lhsOpatternAttributes :: ([(Identifier, Identifier)]) + _lhsOcopy :: Pattern + _patIcopy :: Pattern + _patIdefinedInsts :: ([Identifier]) + _patIpatternAttributes :: ([(Identifier, Identifier)]) + _partsIcopy :: Patterns + _partsIdefinedInsts :: ([Identifier]) + _partsIpatternAttributes :: ([(Identifier, Identifier)]) + -- "GenerateCode.ag"(line 177, column 11) + _lhsOdefinedInsts = + (if field_ == _INST then [attr_] else []) ++ _patIdefinedInsts + -- "GenerateCode.ag"(line 185, column 7) + _lhsOpatternAttributes = + (field_,attr_) : (_patIpatternAttributes ++ _partsIpatternAttributes) + -- self rule + _copy = + Alias field_ attr_ _patIcopy _partsIcopy + -- self rule + _lhsOcopy = + _copy + ( _patIcopy,_patIdefinedInsts,_patIpatternAttributes) = + (pat_ ) + ( _partsIcopy,_partsIdefinedInsts,_partsIpatternAttributes) = + (parts_ ) + in ( _lhsOcopy,_lhsOdefinedInsts,_lhsOpatternAttributes))) +sem_Pattern_Constr :: ConstructorIdent -> + T_Patterns -> + T_Pattern +sem_Pattern_Constr name_ (T_Patterns pats_) = + (T_Pattern (let _lhsOdefinedInsts :: ([Identifier]) + _lhsOpatternAttributes :: ([(Identifier, Identifier)]) + _lhsOcopy :: Pattern + _patsIcopy :: Patterns + _patsIdefinedInsts :: ([Identifier]) + _patsIpatternAttributes :: ([(Identifier, Identifier)]) + -- use rule "GenerateCode.ag"(line 175, column 55) + _lhsOdefinedInsts = + _patsIdefinedInsts + -- use rule "GenerateCode.ag"(line 182, column 47) + _lhsOpatternAttributes = + _patsIpatternAttributes + -- self rule + _copy = + Constr name_ _patsIcopy + -- self rule + _lhsOcopy = + _copy + ( _patsIcopy,_patsIdefinedInsts,_patsIpatternAttributes) = + (pats_ ) + in ( _lhsOcopy,_lhsOdefinedInsts,_lhsOpatternAttributes))) +sem_Pattern_Irrefutable :: T_Pattern -> + T_Pattern +sem_Pattern_Irrefutable (T_Pattern pat_) = + (T_Pattern (let _lhsOdefinedInsts :: ([Identifier]) + _lhsOpatternAttributes :: ([(Identifier, Identifier)]) + _lhsOcopy :: Pattern + _patIcopy :: Pattern + _patIdefinedInsts :: ([Identifier]) + _patIpatternAttributes :: ([(Identifier, Identifier)]) + -- use rule "GenerateCode.ag"(line 175, column 55) + _lhsOdefinedInsts = + _patIdefinedInsts + -- use rule "GenerateCode.ag"(line 182, column 47) + _lhsOpatternAttributes = + _patIpatternAttributes + -- self rule + _copy = + Irrefutable _patIcopy + -- self rule + _lhsOcopy = + _copy + ( _patIcopy,_patIdefinedInsts,_patIpatternAttributes) = + (pat_ ) + in ( _lhsOcopy,_lhsOdefinedInsts,_lhsOpatternAttributes))) +sem_Pattern_Product :: Pos -> + T_Patterns -> + T_Pattern +sem_Pattern_Product pos_ (T_Patterns pats_) = + (T_Pattern (let _lhsOdefinedInsts :: ([Identifier]) + _lhsOpatternAttributes :: ([(Identifier, Identifier)]) + _lhsOcopy :: Pattern + _patsIcopy :: Patterns + _patsIdefinedInsts :: ([Identifier]) + _patsIpatternAttributes :: ([(Identifier, Identifier)]) + -- use rule "GenerateCode.ag"(line 175, column 55) + _lhsOdefinedInsts = + _patsIdefinedInsts + -- use rule "GenerateCode.ag"(line 182, column 47) + _lhsOpatternAttributes = + _patsIpatternAttributes + -- self rule + _copy = + Product pos_ _patsIcopy + -- self rule + _lhsOcopy = + _copy + ( _patsIcopy,_patsIdefinedInsts,_patsIpatternAttributes) = + (pats_ ) + in ( _lhsOcopy,_lhsOdefinedInsts,_lhsOpatternAttributes))) +sem_Pattern_Underscore :: Pos -> + T_Pattern +sem_Pattern_Underscore pos_ = + (T_Pattern (let _lhsOdefinedInsts :: ([Identifier]) + _lhsOpatternAttributes :: ([(Identifier, Identifier)]) + _lhsOcopy :: Pattern + -- use rule "GenerateCode.ag"(line 175, column 55) + _lhsOdefinedInsts = + [] + -- use rule "GenerateCode.ag"(line 182, column 47) + _lhsOpatternAttributes = + [] + -- self rule + _copy = + Underscore pos_ + -- self rule + _lhsOcopy = + _copy + in ( _lhsOcopy,_lhsOdefinedInsts,_lhsOpatternAttributes))) +-- Patterns ---------------------------------------------------- +{- + visit 0: + synthesized attributes: + copy : SELF + definedInsts : [Identifier] + patternAttributes : [(Identifier, Identifier)] + alternatives: + alternative Cons: + child hd : Pattern + child tl : Patterns + visit 0: + local copy : _ + alternative Nil: + visit 0: + local copy : _ +-} +-- cata +sem_Patterns :: Patterns -> + T_Patterns +sem_Patterns list = + (Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list)) +-- semantic domain +newtype T_Patterns = T_Patterns (( Patterns,([Identifier]),([(Identifier, Identifier)]))) +data Inh_Patterns = Inh_Patterns {} +data Syn_Patterns = Syn_Patterns {copy_Syn_Patterns :: Patterns,definedInsts_Syn_Patterns :: [Identifier],patternAttributes_Syn_Patterns :: [(Identifier, Identifier)]} +wrap_Patterns (T_Patterns sem) (Inh_Patterns ) = + (let ( _lhsOcopy,_lhsOdefinedInsts,_lhsOpatternAttributes) = + (sem ) + in (Syn_Patterns _lhsOcopy _lhsOdefinedInsts _lhsOpatternAttributes)) +sem_Patterns_Cons :: T_Pattern -> + T_Patterns -> + T_Patterns +sem_Patterns_Cons (T_Pattern hd_) (T_Patterns tl_) = + (T_Patterns (let _lhsOdefinedInsts :: ([Identifier]) + _lhsOpatternAttributes :: ([(Identifier, Identifier)]) + _lhsOcopy :: Patterns + _hdIcopy :: Pattern + _hdIdefinedInsts :: ([Identifier]) + _hdIpatternAttributes :: ([(Identifier, Identifier)]) + _tlIcopy :: Patterns + _tlIdefinedInsts :: ([Identifier]) + _tlIpatternAttributes :: ([(Identifier, Identifier)]) + -- use rule "GenerateCode.ag"(line 175, column 55) + _lhsOdefinedInsts = + _hdIdefinedInsts ++ _tlIdefinedInsts + -- use rule "GenerateCode.ag"(line 182, column 47) + _lhsOpatternAttributes = + _hdIpatternAttributes ++ _tlIpatternAttributes + -- self rule + _copy = + (:) _hdIcopy _tlIcopy + -- self rule + _lhsOcopy = + _copy + ( _hdIcopy,_hdIdefinedInsts,_hdIpatternAttributes) = + (hd_ ) + ( _tlIcopy,_tlIdefinedInsts,_tlIpatternAttributes) = + (tl_ ) + in ( _lhsOcopy,_lhsOdefinedInsts,_lhsOpatternAttributes))) +sem_Patterns_Nil :: T_Patterns +sem_Patterns_Nil = + (T_Patterns (let _lhsOdefinedInsts :: ([Identifier]) + _lhsOpatternAttributes :: ([(Identifier, Identifier)]) + _lhsOcopy :: Patterns + -- use rule "GenerateCode.ag"(line 175, column 55) + _lhsOdefinedInsts = + [] + -- use rule "GenerateCode.ag"(line 182, column 47) + _lhsOpatternAttributes = + [] + -- self rule + _copy = + [] + -- self rule + _lhsOcopy = + _copy + in ( _lhsOcopy,_lhsOdefinedInsts,_lhsOpatternAttributes))) +-- Sequence ---------------------------------------------------- +{- + visit 0: + inherited attributes: + children : [(Identifier,Type,Bool)] + con : ConstructorIdent + higherOrderChildren : [(Identifier,Type,Bool)] + inh : Attributes + instVisitNrs : Map Identifier Int + lastExpr : Expr + nr : Int + nt : NontermIdent + o_case : Bool + o_cata : Bool + o_costcentre : Bool + o_data : Maybe Bool + o_linePragmas : Bool + o_newtypes : Bool + o_pretty : Bool + o_rename : Bool + o_sem : Bool + o_sig : Bool + o_splitsems : Bool + o_strictwrap : Bool + o_traces : Bool + o_unbox : Bool + paramInstMap : Map Identifier (NontermIdent, [String]) + paramMap : ParamMap + prefix : String + syn : Attributes + terminals : [Identifier] + what : String + chained attributes: + declsAbove : [Decl] + errors : Seq Error + synthesized attributes: + allTpsFound : Bool + blockDecls : DeclBlocks + comments : [String] + decls : Decls + definedInsts : [Identifier] + exprs : Exprs + tSigs : [Decl] + tps : [Type] + usedVars : Set String + alternatives: + alternative Cons: + child hd : CRule + child tl : Sequence + alternative Nil: +-} +-- cata +sem_Sequence :: Sequence -> + T_Sequence +sem_Sequence list = + (Prelude.foldr sem_Sequence_Cons sem_Sequence_Nil (Prelude.map sem_CRule list)) +-- semantic domain +newtype T_Sequence = T_Sequence (([(Identifier,Type,Bool)]) -> + ConstructorIdent -> + ([Decl]) -> + (Seq Error) -> + ([(Identifier,Type,Bool)]) -> + Attributes -> + (Map Identifier Int) -> + Expr -> + Int -> + NontermIdent -> + Bool -> + Bool -> + Bool -> + (Maybe Bool) -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + (Map Identifier (NontermIdent, [String])) -> + ParamMap -> + String -> + Attributes -> + ([Identifier]) -> + String -> + ( Bool,DeclBlocks,([String]),Decls,([Decl]),([Identifier]),(Seq Error),Exprs,([Decl]),([Type]),(Set String))) +data Inh_Sequence = Inh_Sequence {children_Inh_Sequence :: [(Identifier,Type,Bool)],con_Inh_Sequence :: ConstructorIdent,declsAbove_Inh_Sequence :: [Decl],errors_Inh_Sequence :: Seq Error,higherOrderChildren_Inh_Sequence :: [(Identifier,Type,Bool)],inh_Inh_Sequence :: Attributes,instVisitNrs_Inh_Sequence :: Map Identifier Int,lastExpr_Inh_Sequence :: Expr,nr_Inh_Sequence :: Int,nt_Inh_Sequence :: NontermIdent,o_case_Inh_Sequence :: Bool,o_cata_Inh_Sequence :: Bool,o_costcentre_Inh_Sequence :: Bool,o_data_Inh_Sequence :: Maybe Bool,o_linePragmas_Inh_Sequence :: Bool,o_newtypes_Inh_Sequence :: Bool,o_pretty_Inh_Sequence :: Bool,o_rename_Inh_Sequence :: Bool,o_sem_Inh_Sequence :: Bool,o_sig_Inh_Sequence :: Bool,o_splitsems_Inh_Sequence :: Bool,o_strictwrap_Inh_Sequence :: Bool,o_traces_Inh_Sequence :: Bool,o_unbox_Inh_Sequence :: Bool,paramInstMap_Inh_Sequence :: Map Identifier (NontermIdent, [String]),paramMap_Inh_Sequence :: ParamMap,prefix_Inh_Sequence :: String,syn_Inh_Sequence :: Attributes,terminals_Inh_Sequence :: [Identifier],what_Inh_Sequence :: String} +data Syn_Sequence = Syn_Sequence {allTpsFound_Syn_Sequence :: Bool,blockDecls_Syn_Sequence :: DeclBlocks,comments_Syn_Sequence :: [String],decls_Syn_Sequence :: Decls,declsAbove_Syn_Sequence :: [Decl],definedInsts_Syn_Sequence :: [Identifier],errors_Syn_Sequence :: Seq Error,exprs_Syn_Sequence :: Exprs,tSigs_Syn_Sequence :: [Decl],tps_Syn_Sequence :: [Type],usedVars_Syn_Sequence :: Set String} +wrap_Sequence (T_Sequence sem) (Inh_Sequence _lhsIchildren _lhsIcon _lhsIdeclsAbove _lhsIerrors _lhsIhigherOrderChildren _lhsIinh _lhsIinstVisitNrs _lhsIlastExpr _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIparamInstMap _lhsIparamMap _lhsIprefix _lhsIsyn _lhsIterminals _lhsIwhat) = + (let ( _lhsOallTpsFound,_lhsOblockDecls,_lhsOcomments,_lhsOdecls,_lhsOdeclsAbove,_lhsOdefinedInsts,_lhsOerrors,_lhsOexprs,_lhsOtSigs,_lhsOtps,_lhsOusedVars) = + (sem _lhsIchildren _lhsIcon _lhsIdeclsAbove _lhsIerrors _lhsIhigherOrderChildren _lhsIinh _lhsIinstVisitNrs _lhsIlastExpr _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIparamInstMap _lhsIparamMap _lhsIprefix _lhsIsyn _lhsIterminals _lhsIwhat) + in (Syn_Sequence _lhsOallTpsFound _lhsOblockDecls _lhsOcomments _lhsOdecls _lhsOdeclsAbove _lhsOdefinedInsts _lhsOerrors _lhsOexprs _lhsOtSigs _lhsOtps _lhsOusedVars)) +sem_Sequence_Cons :: T_CRule -> + T_Sequence -> + T_Sequence +sem_Sequence_Cons (T_CRule hd_) (T_Sequence tl_) = + (T_Sequence (\ _lhsIchildren + _lhsIcon + _lhsIdeclsAbove + _lhsIerrors + _lhsIhigherOrderChildren + _lhsIinh + _lhsIinstVisitNrs + _lhsIlastExpr + _lhsInr + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_costcentre + _lhsIo_data + _lhsIo_linePragmas + _lhsIo_newtypes + _lhsIo_pretty + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_splitsems + _lhsIo_strictwrap + _lhsIo_traces + _lhsIo_unbox + _lhsIparamInstMap + _lhsIparamMap + _lhsIprefix + _lhsIsyn + _lhsIterminals + _lhsIwhat -> + (let _lhsOblockDecls :: DeclBlocks + _lhsOallTpsFound :: Bool + _lhsOcomments :: ([String]) + _lhsOdecls :: Decls + _lhsOdefinedInsts :: ([Identifier]) + _lhsOerrors :: (Seq Error) + _lhsOexprs :: Exprs + _lhsOtSigs :: ([Decl]) + _lhsOtps :: ([Type]) + _lhsOusedVars :: (Set String) + _lhsOdeclsAbove :: ([Decl]) + _hdOchildren :: ([(Identifier,Type,Bool)]) + _hdOcon :: ConstructorIdent + _hdOdeclsAbove :: ([Decl]) + _hdOerrors :: (Seq Error) + _hdOhigherOrderChildren :: ([(Identifier,Type,Bool)]) + _hdOinh :: Attributes + _hdOinstVisitNrs :: (Map Identifier Int) + _hdOnr :: Int + _hdOnt :: NontermIdent + _hdOo_case :: Bool + _hdOo_cata :: Bool + _hdOo_costcentre :: Bool + _hdOo_data :: (Maybe Bool) + _hdOo_linePragmas :: Bool + _hdOo_newtypes :: Bool + _hdOo_pretty :: Bool + _hdOo_rename :: Bool + _hdOo_sem :: Bool + _hdOo_sig :: Bool + _hdOo_splitsems :: Bool + _hdOo_strictwrap :: Bool + _hdOo_traces :: Bool + _hdOo_unbox :: Bool + _hdOparamInstMap :: (Map Identifier (NontermIdent, [String])) + _hdOparamMap :: ParamMap + _hdOprefix :: String + _hdOsyn :: Attributes + _hdOterminals :: ([Identifier]) + _hdOwhat :: String + _tlOchildren :: ([(Identifier,Type,Bool)]) + _tlOcon :: ConstructorIdent + _tlOdeclsAbove :: ([Decl]) + _tlOerrors :: (Seq Error) + _tlOhigherOrderChildren :: ([(Identifier,Type,Bool)]) + _tlOinh :: Attributes + _tlOinstVisitNrs :: (Map Identifier Int) + _tlOlastExpr :: Expr + _tlOnr :: Int + _tlOnt :: NontermIdent + _tlOo_case :: Bool + _tlOo_cata :: Bool + _tlOo_costcentre :: Bool + _tlOo_data :: (Maybe Bool) + _tlOo_linePragmas :: Bool + _tlOo_newtypes :: Bool + _tlOo_pretty :: Bool + _tlOo_rename :: Bool + _tlOo_sem :: Bool + _tlOo_sig :: Bool + _tlOo_splitsems :: Bool + _tlOo_strictwrap :: Bool + _tlOo_traces :: Bool + _tlOo_unbox :: Bool + _tlOparamInstMap :: (Map Identifier (NontermIdent, [String])) + _tlOparamMap :: ParamMap + _tlOprefix :: String + _tlOsyn :: Attributes + _tlOterminals :: ([Identifier]) + _tlOwhat :: String + _hdIallTpsFound :: Bool + _hdIbldBlocksFun :: (DeclBlocks -> DeclBlocks) + _hdIcomments :: ([String]) + _hdIdecls :: Decls + _hdIdeclsAbove :: ([Decl]) + _hdIdefinedInsts :: ([Identifier]) + _hdIerrors :: (Seq Error) + _hdIexprs :: Exprs + _hdItSigs :: ([Decl]) + _hdItps :: ([Type]) + _hdIusedVars :: (Set String) + _tlIallTpsFound :: Bool + _tlIblockDecls :: DeclBlocks + _tlIcomments :: ([String]) + _tlIdecls :: Decls + _tlIdeclsAbove :: ([Decl]) + _tlIdefinedInsts :: ([Identifier]) + _tlIerrors :: (Seq Error) + _tlIexprs :: Exprs + _tlItSigs :: ([Decl]) + _tlItps :: ([Type]) + _tlIusedVars :: (Set String) + -- "GenerateCode.ag"(line 452, column 7) + _lhsOblockDecls = + _hdIbldBlocksFun _tlIblockDecls + -- use rule "GenerateCode.ag"(line 320, column 39) + _lhsOallTpsFound = + _hdIallTpsFound && _tlIallTpsFound + -- use rule "GenerateCode.ag"(line 714, column 52) + _lhsOcomments = + _hdIcomments ++ _tlIcomments + -- use rule "GenerateCode.ag"(line 122, column 34) + _lhsOdecls = + _hdIdecls ++ _tlIdecls + -- use rule "GenerateCode.ag"(line 175, column 55) + _lhsOdefinedInsts = + _hdIdefinedInsts ++ _tlIdefinedInsts + -- use rule "GenerateCode.ag"(line 695, column 32) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- use rule "GenerateCode.ag"(line 248, column 34) + _lhsOexprs = + _hdIexprs ++ _tlIexprs + -- use rule "GenerateCode.ag"(line 273, column 33) + _lhsOtSigs = + _hdItSigs ++ _tlItSigs + -- use rule "GenerateCode.ag"(line 319, column 31) + _lhsOtps = + _hdItps ++ _tlItps + -- use rule "GenerateCode.ag"(line 262, column 37) + _lhsOusedVars = + _hdIusedVars `Set.union` _tlIusedVars + -- copy rule (up) + _lhsOdeclsAbove = + _tlIdeclsAbove + -- copy rule (down) + _hdOchildren = + _lhsIchildren + -- copy rule (down) + _hdOcon = + _lhsIcon + -- copy rule (down) + _hdOdeclsAbove = + _lhsIdeclsAbove + -- copy rule (down) + _hdOerrors = + _lhsIerrors + -- copy rule (down) + _hdOhigherOrderChildren = + _lhsIhigherOrderChildren + -- copy rule (down) + _hdOinh = + _lhsIinh + -- copy rule (down) + _hdOinstVisitNrs = + _lhsIinstVisitNrs + -- copy rule (down) + _hdOnr = + _lhsInr + -- copy rule (down) + _hdOnt = + _lhsInt + -- copy rule (down) + _hdOo_case = + _lhsIo_case + -- copy rule (down) + _hdOo_cata = + _lhsIo_cata + -- copy rule (down) + _hdOo_costcentre = + _lhsIo_costcentre + -- copy rule (down) + _hdOo_data = + _lhsIo_data + -- copy rule (down) + _hdOo_linePragmas = + _lhsIo_linePragmas + -- copy rule (down) + _hdOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _hdOo_pretty = + _lhsIo_pretty + -- copy rule (down) + _hdOo_rename = + _lhsIo_rename + -- copy rule (down) + _hdOo_sem = + _lhsIo_sem + -- copy rule (down) + _hdOo_sig = + _lhsIo_sig + -- copy rule (down) + _hdOo_splitsems = + _lhsIo_splitsems + -- copy rule (down) + _hdOo_strictwrap = + _lhsIo_strictwrap + -- copy rule (down) + _hdOo_traces = + _lhsIo_traces + -- copy rule (down) + _hdOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _hdOparamInstMap = + _lhsIparamInstMap + -- copy rule (down) + _hdOparamMap = + _lhsIparamMap + -- copy rule (down) + _hdOprefix = + _lhsIprefix + -- copy rule (down) + _hdOsyn = + _lhsIsyn + -- copy rule (down) + _hdOterminals = + _lhsIterminals + -- copy rule (down) + _hdOwhat = + _lhsIwhat + -- copy rule (down) + _tlOchildren = + _lhsIchildren + -- copy rule (down) + _tlOcon = + _lhsIcon + -- copy rule (chain) + _tlOdeclsAbove = + _hdIdeclsAbove + -- copy rule (chain) + _tlOerrors = + _hdIerrors + -- copy rule (down) + _tlOhigherOrderChildren = + _lhsIhigherOrderChildren + -- copy rule (down) + _tlOinh = + _lhsIinh + -- copy rule (down) + _tlOinstVisitNrs = + _lhsIinstVisitNrs + -- copy rule (down) + _tlOlastExpr = + _lhsIlastExpr + -- copy rule (down) + _tlOnr = + _lhsInr + -- copy rule (down) + _tlOnt = + _lhsInt + -- copy rule (down) + _tlOo_case = + _lhsIo_case + -- copy rule (down) + _tlOo_cata = + _lhsIo_cata + -- copy rule (down) + _tlOo_costcentre = + _lhsIo_costcentre + -- copy rule (down) + _tlOo_data = + _lhsIo_data + -- copy rule (down) + _tlOo_linePragmas = + _lhsIo_linePragmas + -- copy rule (down) + _tlOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _tlOo_pretty = + _lhsIo_pretty + -- copy rule (down) + _tlOo_rename = + _lhsIo_rename + -- copy rule (down) + _tlOo_sem = + _lhsIo_sem + -- copy rule (down) + _tlOo_sig = + _lhsIo_sig + -- copy rule (down) + _tlOo_splitsems = + _lhsIo_splitsems + -- copy rule (down) + _tlOo_strictwrap = + _lhsIo_strictwrap + -- copy rule (down) + _tlOo_traces = + _lhsIo_traces + -- copy rule (down) + _tlOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _tlOparamInstMap = + _lhsIparamInstMap + -- copy rule (down) + _tlOparamMap = + _lhsIparamMap + -- copy rule (down) + _tlOprefix = + _lhsIprefix + -- copy rule (down) + _tlOsyn = + _lhsIsyn + -- copy rule (down) + _tlOterminals = + _lhsIterminals + -- copy rule (down) + _tlOwhat = + _lhsIwhat + ( _hdIallTpsFound,_hdIbldBlocksFun,_hdIcomments,_hdIdecls,_hdIdeclsAbove,_hdIdefinedInsts,_hdIerrors,_hdIexprs,_hdItSigs,_hdItps,_hdIusedVars) = + (hd_ _hdOchildren _hdOcon _hdOdeclsAbove _hdOerrors _hdOhigherOrderChildren _hdOinh _hdOinstVisitNrs _hdOnr _hdOnt _hdOo_case _hdOo_cata _hdOo_costcentre _hdOo_data _hdOo_linePragmas _hdOo_newtypes _hdOo_pretty _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_splitsems _hdOo_strictwrap _hdOo_traces _hdOo_unbox _hdOparamInstMap _hdOparamMap _hdOprefix _hdOsyn _hdOterminals _hdOwhat) + ( _tlIallTpsFound,_tlIblockDecls,_tlIcomments,_tlIdecls,_tlIdeclsAbove,_tlIdefinedInsts,_tlIerrors,_tlIexprs,_tlItSigs,_tlItps,_tlIusedVars) = + (tl_ _tlOchildren _tlOcon _tlOdeclsAbove _tlOerrors _tlOhigherOrderChildren _tlOinh _tlOinstVisitNrs _tlOlastExpr _tlOnr _tlOnt _tlOo_case _tlOo_cata _tlOo_costcentre _tlOo_data _tlOo_linePragmas _tlOo_newtypes _tlOo_pretty _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_splitsems _tlOo_strictwrap _tlOo_traces _tlOo_unbox _tlOparamInstMap _tlOparamMap _tlOprefix _tlOsyn _tlOterminals _tlOwhat) + in ( _lhsOallTpsFound,_lhsOblockDecls,_lhsOcomments,_lhsOdecls,_lhsOdeclsAbove,_lhsOdefinedInsts,_lhsOerrors,_lhsOexprs,_lhsOtSigs,_lhsOtps,_lhsOusedVars)))) +sem_Sequence_Nil :: T_Sequence +sem_Sequence_Nil = + (T_Sequence (\ _lhsIchildren + _lhsIcon + _lhsIdeclsAbove + _lhsIerrors + _lhsIhigherOrderChildren + _lhsIinh + _lhsIinstVisitNrs + _lhsIlastExpr + _lhsInr + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_costcentre + _lhsIo_data + _lhsIo_linePragmas + _lhsIo_newtypes + _lhsIo_pretty + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_splitsems + _lhsIo_strictwrap + _lhsIo_traces + _lhsIo_unbox + _lhsIparamInstMap + _lhsIparamMap + _lhsIprefix + _lhsIsyn + _lhsIterminals + _lhsIwhat -> + (let _lhsOblockDecls :: DeclBlocks + _lhsOallTpsFound :: Bool + _lhsOcomments :: ([String]) + _lhsOdecls :: Decls + _lhsOdefinedInsts :: ([Identifier]) + _lhsOerrors :: (Seq Error) + _lhsOexprs :: Exprs + _lhsOtSigs :: ([Decl]) + _lhsOtps :: ([Type]) + _lhsOusedVars :: (Set String) + _lhsOdeclsAbove :: ([Decl]) + -- "GenerateCode.ag"(line 454, column 7) + _lhsOblockDecls = + DeclTerminator _lhsIdeclsAbove _lhsIlastExpr + -- use rule "GenerateCode.ag"(line 320, column 39) + _lhsOallTpsFound = + True + -- use rule "GenerateCode.ag"(line 714, column 52) + _lhsOcomments = + [] + -- use rule "GenerateCode.ag"(line 122, column 34) + _lhsOdecls = + [] + -- use rule "GenerateCode.ag"(line 175, column 55) + _lhsOdefinedInsts = + [] + -- use rule "GenerateCode.ag"(line 695, column 32) + _lhsOerrors = + Seq.empty + -- use rule "GenerateCode.ag"(line 248, column 34) + _lhsOexprs = + [] + -- use rule "GenerateCode.ag"(line 273, column 33) + _lhsOtSigs = + [] + -- use rule "GenerateCode.ag"(line 319, column 31) + _lhsOtps = + [] + -- use rule "GenerateCode.ag"(line 262, column 37) + _lhsOusedVars = + Set.empty + -- copy rule (chain) + _lhsOdeclsAbove = + _lhsIdeclsAbove + in ( _lhsOallTpsFound,_lhsOblockDecls,_lhsOcomments,_lhsOdecls,_lhsOdeclsAbove,_lhsOdefinedInsts,_lhsOerrors,_lhsOexprs,_lhsOtSigs,_lhsOtps,_lhsOusedVars)))) diff --git a/src-derived/HsToken.hs b/src-derived/HsToken.hs --- a/src-derived/HsToken.hs +++ b/src-derived/HsToken.hs @@ -1,4 +1,3 @@ - -- UUAGC 0.9.5 (HsToken.ag) module HsToken where @@ -8,12 +7,14 @@ {- alternatives: alternative AGField: - child field : {Name} - child attr : {Name} + child field : {Identifier} + child attr : {Identifier} child pos : {Pos} + child rdesc : {Maybe String} alternative AGLocal: - child var : {Name} + child var : {Identifier} child pos : {Pos} + child rdesc : {Maybe String} alternative CharToken: child value : {String} child pos : {Pos} @@ -27,12 +28,12 @@ child value : {String} child pos : {Pos} -} -data HsToken = AGField (Name) (Name) (Pos) - | AGLocal (Name) (Pos) - | CharToken (String) (Pos) - | Err (String) (Pos) - | HsToken (String) (Pos) - | StrToken (String) (Pos) +data HsToken = AGField (Identifier) (Identifier) (Pos) (Maybe String) + | AGLocal (Identifier) (Pos) (Maybe String) + | CharToken (String) (Pos) + | Err (String) (Pos) + | HsToken (String) (Pos) + | StrToken (String) (Pos) -- HsTokens ---------------------------------------------------- {- alternatives: @@ -48,4 +49,4 @@ alternative HsTokensRoot: child tokens : HsTokens -} -data HsTokensRoot = HsTokensRoot (HsTokens) +data HsTokensRoot = HsTokensRoot (HsTokens) diff --git a/src-derived/Interfaces.hs b/src-derived/Interfaces.hs --- a/src-derived/Interfaces.hs +++ b/src-derived/Interfaces.hs @@ -8,24 +8,24 @@ {- alternatives: alternative IRoot: - child inters : Interfaces + child inters : Interfaces -} data IRoot = IRoot (Interfaces) -- Interface --------------------------------------------------- {- alternatives: alternative Interface: - child nt : {Nonterminal} - child cons : {[Constructor]} - child seg : Segments + child nt : {NontermIdent} + child cons : {[ConstructorIdent]} + child seg : Segments -} -data Interface = Interface (Nonterminal) ([Constructor]) (Segments) +data Interface = Interface (NontermIdent) ([ConstructorIdent]) (Segments) -- Interfaces -------------------------------------------------- {- alternatives: alternative Cons: - child hd : Interface - child tl : Interfaces + child hd : Interface + child tl : Interfaces alternative Nil: -} type Interfaces = [Interface] @@ -41,8 +41,8 @@ {- alternatives: alternative Cons: - child hd : Segment - child tl : Segments + child hd : Segment + child tl : Segments alternative Nil: -} type Segments = [Segment] diff --git a/src-derived/InterfacesRules.hs b/src-derived/InterfacesRules.hs --- a/src-derived/InterfacesRules.hs +++ b/src-derived/InterfacesRules.hs @@ -15,20 +15,23 @@ import Data.Tree(Tree(Node)) import Data.Graph(Graph, dfs, edges, buildG, transposeG) import Data.Maybe (fromJust) -import Data.List (partition,transpose,(\\),nub,intersect) +import Data.List (partition,transpose,(\\),nub,intersect, findIndex) import Data.Array ((!),inRange,bounds,assocs) import Debug.Trace(trace) + import CommonTypes import SequentialTypes type VisitSS = [Vertex] + gather :: Info -> [Vertex] -> [[Vertex]] gather info = eqClasses comp where comp a b = isEqualField (ruleTable info ! a) (ruleTable info ! b) + -- Only non-empty syn will ever be forced, because visits with empty syn are never performed -- Right hand side synthesized attributes always have a field cv :: (Vertex -> CRule) -> Int -> Vertex -> ([Vertex],[Vertex]) -> (Vertex,ChildVisit) @@ -37,18 +40,23 @@ d = ChildVisit fld rnt n inh syn in (v,d) + ed v (inh,syn) = map (\i -> (i,v)) inh ++ map (\s -> (v,s)) syn + postorder (Node a ts) = postorderF ts ++ [a] postorderF = concatMap postorder postOrd g = postorderF . dfs g topSort' g = postOrd g + type IntraVisit = [Vertex] + swap (a,b) = (b,a) -ccv :: Name -> Nonterminal -> Int -> CInterfaceMap -> CRule + +ccv :: Identifier -> NontermIdent -> Int -> CInterfaceMap -> CRule ccv name nt n table = CChildVisit name nt n inh syn last where CInterface segs = Map.findWithDefault (error ("InterfacesRules::ccv::interfaces not in table for nt: " ++ show nt)) nt table @@ -68,7 +76,7 @@ visits : CVisitsMap alternatives: alternative IRoot: - child inters : Interfaces + child inters : Interfaces visit 0: local newedges : _ local visitssGraph : _ @@ -137,13 +145,13 @@ _intersOprev = let terminals = [ v | (v,cr) <- assocs (ruleTable _lhsIinfo), not (getHasCode cr), isLocal cr ] in _intersIfirstvisitvertices ++ terminals - -- "InterfacesRules.lag"(line 325, column 12) + -- "InterfacesRules.lag"(line 328, column 12) _intersOddp = buildG (0,_intersIv-1) (map swap (_lhsIdpr ++ _newedges)) - -- "InterfacesRules.lag"(line 362, column 13) + -- "InterfacesRules.lag"(line 365, column 13) _intersOallInters = _intersIinters - -- "InterfacesRules.lag"(line 422, column 13) + -- "InterfacesRules.lag"(line 425, column 13) _lhsOedp = Seq.toList _intersIedp -- copy rule (up) @@ -176,13 +184,13 @@ firstvisitvertices : [Vertex] inter : CInterface newedges : Seq Edge - nt : Nonterminal - visits : Map Constructor CVisits + nt : NontermIdent + visits : Map ConstructorIdent CVisits alternatives: alternative Interface: - child nt : {Nonterminal} - child cons : {[Constructor]} - child seg : Segments + child nt : {NontermIdent} + child cons : {[ConstructorIdent]} + child seg : Segments visit 0: local v : _ local firstvisitvertices : _ @@ -203,15 +211,15 @@ Vertex -> (Map Vertex ChildVisit) -> Graph -> - ( (Seq (Vertex,ChildVisit)),(Seq Edge),([Vertex]),CInterface,(Seq Edge ),Nonterminal,Vertex,(Map Constructor CVisits))) + ( (Seq (Vertex,ChildVisit)),(Seq Edge),([Vertex]),CInterface,(Seq Edge ),NontermIdent,Vertex,(Map ConstructorIdent CVisits))) data Inh_Interface = Inh_Interface {allInters_Inh_Interface :: CInterfaceMap,ddp_Inh_Interface :: Graph,info_Inh_Interface :: Info,prev_Inh_Interface :: [Vertex],v_Inh_Interface :: Vertex,visitDescr_Inh_Interface :: Map Vertex ChildVisit,vssGraph_Inh_Interface :: Graph} -data Syn_Interface = Syn_Interface {descr_Syn_Interface :: Seq (Vertex,ChildVisit),edp_Syn_Interface :: Seq Edge,firstvisitvertices_Syn_Interface :: [Vertex],inter_Syn_Interface :: CInterface,newedges_Syn_Interface :: Seq Edge ,nt_Syn_Interface :: Nonterminal,v_Syn_Interface :: Vertex,visits_Syn_Interface :: Map Constructor CVisits} +data Syn_Interface = Syn_Interface {descr_Syn_Interface :: Seq (Vertex,ChildVisit),edp_Syn_Interface :: Seq Edge,firstvisitvertices_Syn_Interface :: [Vertex],inter_Syn_Interface :: CInterface,newedges_Syn_Interface :: Seq Edge ,nt_Syn_Interface :: NontermIdent,v_Syn_Interface :: Vertex,visits_Syn_Interface :: Map ConstructorIdent CVisits} wrap_Interface (T_Interface sem ) (Inh_Interface _lhsIallInters _lhsIddp _lhsIinfo _lhsIprev _lhsIv _lhsIvisitDescr _lhsIvssGraph ) = (let ( _lhsOdescr,_lhsOedp,_lhsOfirstvisitvertices,_lhsOinter,_lhsOnewedges,_lhsOnt,_lhsOv,_lhsOvisits) = (sem _lhsIallInters _lhsIddp _lhsIinfo _lhsIprev _lhsIv _lhsIvisitDescr _lhsIvssGraph ) in (Syn_Interface _lhsOdescr _lhsOedp _lhsOfirstvisitvertices _lhsOinter _lhsOnewedges _lhsOnt _lhsOv _lhsOvisits )) -sem_Interface_Interface :: Nonterminal -> - ([Constructor]) -> +sem_Interface_Interface :: NontermIdent -> + ([ConstructorIdent]) -> T_Segments -> T_Interface sem_Interface_Interface nt_ cons_ (T_Segments seg_ ) = @@ -227,12 +235,12 @@ _lhsOnewedges :: (Seq Edge ) _lhsOdescr :: (Seq (Vertex,ChildVisit)) _segOn :: Int - _segOcons :: ([Constructor]) + _segOcons :: ([ConstructorIdent]) _segOisFirst :: Bool _segOfromLhs :: ([Vertex]) - _lhsOnt :: Nonterminal + _lhsOnt :: NontermIdent _lhsOinter :: CInterface - _lhsOvisits :: (Map Constructor CVisits) + _lhsOvisits :: (Map ConstructorIdent CVisits) _lhsOedp :: (Seq Edge) _lhsOfirstvisitvertices :: ([Vertex]) _segOallInters :: CInterfaceMap @@ -285,22 +293,22 @@ -- "InterfacesRules.lag"(line 223, column 16) _segOcons = cons_ - -- "InterfacesRules.lag"(line 296, column 16) + -- "InterfacesRules.lag"(line 299, column 16) _segOisFirst = True - -- "InterfacesRules.lag"(line 333, column 16) + -- "InterfacesRules.lag"(line 336, column 16) _segOfromLhs = _lhsIprev - -- "InterfacesRules.lag"(line 373, column 16) + -- "InterfacesRules.lag"(line 376, column 16) _lhsOnt = nt_ - -- "InterfacesRules.lag"(line 377, column 17) + -- "InterfacesRules.lag"(line 380, column 17) _lhsOinter = CInterface _segIsegs - -- "InterfacesRules.lag"(line 378, column 17) + -- "InterfacesRules.lag"(line 381, column 17) _lhsOvisits = Map.fromList (zip cons_ (transpose _segIcvisits)) - -- use rule "InterfacesRules.lag"(line 417, column 54) + -- use rule "InterfacesRules.lag"(line 420, column 54) _lhsOedp = _segIedp -- use rule "InterfacesRules.lag"(line 244, column 70) @@ -348,8 +356,8 @@ visits : CVisitsMap alternatives: alternative Cons: - child hd : Interface - child tl : Interfaces + child hd : Interface + child tl : Interfaces alternative Nil: -} -- cata @@ -409,9 +417,9 @@ _hdIfirstvisitvertices :: ([Vertex]) _hdIinter :: CInterface _hdInewedges :: (Seq Edge ) - _hdInt :: Nonterminal + _hdInt :: NontermIdent _hdIv :: Vertex - _hdIvisits :: (Map Constructor CVisits) + _hdIvisits :: (Map ConstructorIdent CVisits) _tlIdescr :: (Seq (Vertex,ChildVisit)) _tlIedp :: (Seq Edge) _tlIfirstvisitvertices :: ([Vertex]) @@ -419,16 +427,16 @@ _tlInewedges :: (Seq Edge ) _tlIv :: Vertex _tlIvisits :: CVisitsMap - -- "InterfacesRules.lag"(line 367, column 12) + -- "InterfacesRules.lag"(line 370, column 12) _lhsOinters = Map.insert _hdInt _hdIinter _tlIinters - -- "InterfacesRules.lag"(line 368, column 12) + -- "InterfacesRules.lag"(line 371, column 12) _lhsOvisits = Map.insert _hdInt _hdIvisits _tlIvisits -- use rule "InterfacesRules.lag"(line 118, column 20) _lhsOdescr = _hdIdescr Seq.<> _tlIdescr - -- use rule "InterfacesRules.lag"(line 417, column 54) + -- use rule "InterfacesRules.lag"(line 420, column 54) _lhsOedp = _hdIedp Seq.<> _tlIedp -- use rule "InterfacesRules.lag"(line 244, column 70) @@ -503,16 +511,16 @@ _lhsOfirstvisitvertices :: ([Vertex]) _lhsOnewedges :: (Seq Edge ) _lhsOv :: Vertex - -- "InterfacesRules.lag"(line 369, column 12) + -- "InterfacesRules.lag"(line 372, column 12) _lhsOinters = Map.empty - -- "InterfacesRules.lag"(line 370, column 12) + -- "InterfacesRules.lag"(line 373, column 12) _lhsOvisits = Map.empty -- use rule "InterfacesRules.lag"(line 118, column 20) _lhsOdescr = Seq.empty - -- use rule "InterfacesRules.lag"(line 417, column 54) + -- use rule "InterfacesRules.lag"(line 420, column 54) _lhsOedp = Seq.empty -- use rule "InterfacesRules.lag"(line 244, column 70) @@ -530,7 +538,7 @@ visit 0: inherited attributes: allInters : CInterfaceMap - cons : [Constructor] + cons : [ConstructorIdent] ddp : Graph fromLhs : [Vertex] info : Info @@ -587,7 +595,7 @@ (sem_Segment_Segment _inh _syn ) -- semantic domain newtype T_Segment = T_Segment (CInterfaceMap -> - ([Constructor]) -> + ([ConstructorIdent]) -> Graph -> ([Vertex]) -> Info -> @@ -601,7 +609,7 @@ (Map Vertex ChildVisit) -> Graph -> ( ([CVisit]),(Seq (Vertex,ChildVisit)),(Seq Edge),([([Vertex],[Vertex])]),([Vertex]),([IntraVisit]),(Seq Edge ),([Vertex]),([Vertex]),CSegment,Vertex,([VisitSS]))) -data Inh_Segment = Inh_Segment {allInters_Inh_Segment :: CInterfaceMap,cons_Inh_Segment :: [Constructor],ddp_Inh_Segment :: Graph,fromLhs_Inh_Segment :: [Vertex],info_Inh_Segment :: Info,isFirst_Inh_Segment :: Bool,n_Inh_Segment :: Int,nextInh_Inh_Segment :: [Vertex],nextIntravisits_Inh_Segment :: [IntraVisit],nextNewvertices_Inh_Segment :: [Vertex],prev_Inh_Segment :: [Vertex],v_Inh_Segment :: Vertex,visitDescr_Inh_Segment :: Map Vertex ChildVisit,vssGraph_Inh_Segment :: Graph} +data Inh_Segment = Inh_Segment {allInters_Inh_Segment :: CInterfaceMap,cons_Inh_Segment :: [ConstructorIdent],ddp_Inh_Segment :: Graph,fromLhs_Inh_Segment :: [Vertex],info_Inh_Segment :: Info,isFirst_Inh_Segment :: Bool,n_Inh_Segment :: Int,nextInh_Inh_Segment :: [Vertex],nextIntravisits_Inh_Segment :: [IntraVisit],nextNewvertices_Inh_Segment :: [Vertex],prev_Inh_Segment :: [Vertex],v_Inh_Segment :: Vertex,visitDescr_Inh_Segment :: Map Vertex ChildVisit,vssGraph_Inh_Segment :: Graph} data Syn_Segment = Syn_Segment {cvisits_Syn_Segment :: [CVisit],descr_Syn_Segment :: Seq (Vertex,ChildVisit),edp_Syn_Segment :: Seq Edge,groups_Syn_Segment :: [([Vertex],[Vertex])],inh_Syn_Segment :: [Vertex],intravisits_Syn_Segment :: [IntraVisit],newedges_Syn_Segment :: Seq Edge ,newvertices_Syn_Segment :: [Vertex],prev_Syn_Segment :: [Vertex],seg_Syn_Segment :: CSegment,v_Syn_Segment :: Vertex,visitss_Syn_Segment :: [VisitSS]} wrap_Segment (T_Segment sem ) (Inh_Segment _lhsIallInters _lhsIcons _lhsIddp _lhsIfromLhs _lhsIinfo _lhsIisFirst _lhsIn _lhsInextInh _lhsInextIntravisits _lhsInextNewvertices _lhsIprev _lhsIv _lhsIvisitDescr _lhsIvssGraph ) = (let ( _lhsOcvisits,_lhsOdescr,_lhsOedp,_lhsOgroups,_lhsOinh,_lhsOintravisits,_lhsOnewedges,_lhsOnewvertices,_lhsOprev,_lhsOseg,_lhsOv,_lhsOvisitss) = @@ -691,51 +699,54 @@ _lhsIprev ++ _defined -- "InterfacesRules.lag"(line 269, column 15) _visitss = - let rem :: [(Name,Name,Maybe Type)] -> [Vertex] -> [Vertex] + let rem :: [(Identifier,Identifier,Maybe Type)] -> [Vertex] -> [Vertex] rem prev [] = [] rem prev (v:vs) | inRange (bounds table) v = let cr = table ! v - addV = if (getField cr,getAttr cr,getType cr) `elem` prev - then id - else (v:) + addV = case findIndex cmp prev of + Just _ -> id + _ -> (v:) + cmp (fld,attr,tp) = getField cr == fld && getAttr cr == attr && sameNT (getType cr) tp + sameNT (Just (NT ntA _)) (Just (NT ntB _)) = ntA == ntB + sameNT _ _ = False def = Map.elems (getDefines cr) in addV (rem (def ++ prev) vs) | otherwise = v:rem prev vs table = ruleTable _lhsIinfo in map (rem []) _visitss' - -- "InterfacesRules.lag"(line 338, column 15) + -- "InterfacesRules.lag"(line 341, column 15) _fromLhs = _occurAs isLhs inh_ ++ _lhsIfromLhs - -- "InterfacesRules.lag"(line 339, column 15) + -- "InterfacesRules.lag"(line 342, column 15) _computed = let computes v = case Map.lookup v _lhsIvisitDescr of Nothing -> Map.keys (getDefines (ruleTable _lhsIinfo ! v)) Just (ChildVisit _ _ _ _ syn) -> v:syn in concatMap (concatMap computes) _visitss - -- "InterfacesRules.lag"(line 343, column 15) + -- "InterfacesRules.lag"(line 346, column 15) _intravisits = zipWith _iv _visitss _lhsInextIntravisits - -- "InterfacesRules.lag"(line 344, column 15) + -- "InterfacesRules.lag"(line 347, column 15) _iv = \vs next -> let needed = concatMap (_lhsIddp !) vs in nub (needed ++ next) \\ (_fromLhs ++ _computed) - -- "InterfacesRules.lag"(line 387, column 15) + -- "InterfacesRules.lag"(line 390, column 15) _lhsOseg = if False then undefined _lhsIvssGraph _lhsIvisitDescr _lhsIprev else CSegment _inhmap _synmap - -- "InterfacesRules.lag"(line 389, column 19) + -- "InterfacesRules.lag"(line 392, column 19) __tup1 = let makemap = Map.fromList . map findType findType v = getNtaNameType (attrTable _lhsIinfo ! v) in (makemap inh_,makemap syn_) - -- "InterfacesRules.lag"(line 389, column 19) + -- "InterfacesRules.lag"(line 392, column 19) (_inhmap,_) = __tup1 - -- "InterfacesRules.lag"(line 389, column 19) + -- "InterfacesRules.lag"(line 392, column 19) (_,_synmap) = __tup1 - -- "InterfacesRules.lag"(line 392, column 15) + -- "InterfacesRules.lag"(line 395, column 15) _lhsOcvisits = let mkVisit vss intra = CVisit _inhmap _synmap (mkSequence vss) (mkSequence intra) True mkSequence = map mkRule @@ -743,11 +754,11 @@ Nothing -> ruleTable _lhsIinfo ! v Just (ChildVisit name nt n _ _) -> ccv name nt n _lhsIallInters in zipWith mkVisit _visitss _intravisits - -- "InterfacesRules.lag"(line 419, column 14) + -- "InterfacesRules.lag"(line 422, column 14) _lhsOedp = Seq.fromList [(i,s) | i <- inh_, s <- syn_] Seq.<> Seq.fromList [(s,i) | s <- syn_, i <- _lhsInextInh ] - -- "InterfacesRules.lag"(line 424, column 14) + -- "InterfacesRules.lag"(line 427, column 14) _lhsOinh = inh_ -- copy rule (from local) @@ -771,7 +782,7 @@ visit 0: inherited attributes: allInters : CInterfaceMap - cons : [Constructor] + cons : [ConstructorIdent] ddp : Graph fromLhs : [Vertex] info : Info @@ -794,8 +805,8 @@ segs : CSegments alternatives: alternative Cons: - child hd : Segment - child tl : Segments + child hd : Segment + child tl : Segments alternative Nil: -} -- cata @@ -805,7 +816,7 @@ (Prelude.foldr sem_Segments_Cons sem_Segments_Nil (Prelude.map sem_Segment list) ) -- semantic domain newtype T_Segments = T_Segments (CInterfaceMap -> - ([Constructor]) -> + ([ConstructorIdent]) -> Graph -> ([Vertex]) -> Info -> @@ -816,7 +827,7 @@ (Map Vertex ChildVisit) -> Graph -> ( ([[CVisit]]),(Seq (Vertex,ChildVisit)),(Seq Edge),([Vertex]),([([Vertex],[Vertex])]),([IntraVisit]),(Seq Edge ),([Vertex]),([Vertex]),CSegments,Vertex)) -data Inh_Segments = Inh_Segments {allInters_Inh_Segments :: CInterfaceMap,cons_Inh_Segments :: [Constructor],ddp_Inh_Segments :: Graph,fromLhs_Inh_Segments :: [Vertex],info_Inh_Segments :: Info,isFirst_Inh_Segments :: Bool,n_Inh_Segments :: Int,prev_Inh_Segments :: [Vertex],v_Inh_Segments :: Vertex,visitDescr_Inh_Segments :: Map Vertex ChildVisit,vssGraph_Inh_Segments :: Graph} +data Inh_Segments = Inh_Segments {allInters_Inh_Segments :: CInterfaceMap,cons_Inh_Segments :: [ConstructorIdent],ddp_Inh_Segments :: Graph,fromLhs_Inh_Segments :: [Vertex],info_Inh_Segments :: Info,isFirst_Inh_Segments :: Bool,n_Inh_Segments :: Int,prev_Inh_Segments :: [Vertex],v_Inh_Segments :: Vertex,visitDescr_Inh_Segments :: Map Vertex ChildVisit,vssGraph_Inh_Segments :: Graph} data Syn_Segments = Syn_Segments {cvisits_Syn_Segments :: [[CVisit]],descr_Syn_Segments :: Seq (Vertex,ChildVisit),edp_Syn_Segments :: Seq Edge,firstInh_Syn_Segments :: [Vertex],groups_Syn_Segments :: [([Vertex],[Vertex])],hdIntravisits_Syn_Segments :: [IntraVisit],newedges_Syn_Segments :: Seq Edge ,newvertices_Syn_Segments :: [Vertex],prev_Syn_Segments :: [Vertex],segs_Syn_Segments :: CSegments,v_Syn_Segments :: Vertex} wrap_Segments (T_Segments sem ) (Inh_Segments _lhsIallInters _lhsIcons _lhsIddp _lhsIfromLhs _lhsIinfo _lhsIisFirst _lhsIn _lhsIprev _lhsIv _lhsIvisitDescr _lhsIvssGraph ) = (let ( _lhsOcvisits,_lhsOdescr,_lhsOedp,_lhsOfirstInh,_lhsOgroups,_lhsOhdIntravisits,_lhsOnewedges,_lhsOnewvertices,_lhsOprev,_lhsOsegs,_lhsOv) = @@ -856,7 +867,7 @@ _lhsOprev :: ([Vertex]) _lhsOv :: Vertex _hdOallInters :: CInterfaceMap - _hdOcons :: ([Constructor]) + _hdOcons :: ([ConstructorIdent]) _hdOddp :: Graph _hdOinfo :: Info _hdOisFirst :: Bool @@ -866,7 +877,7 @@ _hdOvisitDescr :: (Map Vertex ChildVisit) _hdOvssGraph :: Graph _tlOallInters :: CInterfaceMap - _tlOcons :: ([Constructor]) + _tlOcons :: ([ConstructorIdent]) _tlOddp :: Graph _tlOinfo :: Info _tlOprev :: ([Vertex]) @@ -908,37 +919,37 @@ -- "InterfacesRules.lag"(line 193, column 11) _tlOn = _lhsIn + 1 - -- "InterfacesRules.lag"(line 298, column 11) + -- "InterfacesRules.lag"(line 301, column 11) _tlOisFirst = False - -- "InterfacesRules.lag"(line 311, column 12) + -- "InterfacesRules.lag"(line 314, column 12) _hdOnextIntravisits = _tlIhdIntravisits - -- "InterfacesRules.lag"(line 312, column 12) + -- "InterfacesRules.lag"(line 315, column 12) _lhsOhdIntravisits = _hdIintravisits - -- "InterfacesRules.lag"(line 335, column 12) + -- "InterfacesRules.lag"(line 338, column 12) _hdOfromLhs = _lhsIfromLhs - -- "InterfacesRules.lag"(line 336, column 12) + -- "InterfacesRules.lag"(line 339, column 12) _tlOfromLhs = [] - -- "InterfacesRules.lag"(line 382, column 12) + -- "InterfacesRules.lag"(line 385, column 12) _lhsOsegs = _hdIseg : _tlIsegs - -- "InterfacesRules.lag"(line 426, column 12) + -- "InterfacesRules.lag"(line 429, column 12) _hdOnextInh = _tlIfirstInh - -- "InterfacesRules.lag"(line 427, column 12) + -- "InterfacesRules.lag"(line 430, column 12) _lhsOfirstInh = _hdIinh - -- use rule "InterfacesRules.lag"(line 381, column 29) + -- use rule "InterfacesRules.lag"(line 384, column 29) _lhsOcvisits = _hdIcvisits : _tlIcvisits -- use rule "InterfacesRules.lag"(line 118, column 20) _lhsOdescr = _hdIdescr Seq.<> _tlIdescr - -- use rule "InterfacesRules.lag"(line 417, column 54) + -- use rule "InterfacesRules.lag"(line 420, column 54) _lhsOedp = _hdIedp Seq.<> _tlIedp -- use rule "InterfacesRules.lag"(line 117, column 23) @@ -1039,22 +1050,22 @@ -- "InterfacesRules.lag"(line 173, column 11) _lhsOgroups = [] - -- "InterfacesRules.lag"(line 313, column 10) + -- "InterfacesRules.lag"(line 316, column 10) _lhsOhdIntravisits = repeat [] - -- "InterfacesRules.lag"(line 383, column 12) + -- "InterfacesRules.lag"(line 386, column 12) _lhsOsegs = [] - -- "InterfacesRules.lag"(line 428, column 11) + -- "InterfacesRules.lag"(line 431, column 11) _lhsOfirstInh = [] - -- use rule "InterfacesRules.lag"(line 381, column 29) + -- use rule "InterfacesRules.lag"(line 384, column 29) _lhsOcvisits = [] -- use rule "InterfacesRules.lag"(line 118, column 20) _lhsOdescr = Seq.empty - -- use rule "InterfacesRules.lag"(line 417, column 54) + -- use rule "InterfacesRules.lag"(line 420, column 54) _lhsOedp = Seq.empty -- use rule "InterfacesRules.lag"(line 117, column 23) diff --git a/src-derived/Order.hs b/src-derived/Order.hs --- a/src-derived/Order.hs +++ b/src-derived/Order.hs @@ -1,3399 +1,3481 @@ - --- UUAGC 0.9.5 (Order.ag) -module Order where - --- From uuagc -import CommonTypes -import Patterns -import ErrorMessages -import AbstractSyntax -import Code hiding (Type) -import qualified Code -import Expression -import Options -import SequentialComputation -import SequentialTypes -import CodeSyntax -import GrammarInfo -import HsToken(HsTokensRoot(HsTokensRoot)) -import HsTokenScanner(lexTokens) -import SemHsTokens(sem_HsTokensRoot,wrap_HsTokensRoot, Syn_HsTokensRoot(..),Inh_HsTokensRoot(..)) --- From uulib -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified UU.DData.Seq as Seq -import Data.Map(Map) -import Data.Set(Set) -import UU.DData.Seq(Seq, (<>)) -import UU.Util.Utils -import UU.Scanner.Position(Pos(..),initPos) - --- From haskell libraries -import Control.Monad(liftM) -import qualified Data.Array as Array -import Data.Array((!),bounds,inRange) -import Data.List(elemIndex,partition,sort,mapAccumL,find,nubBy,intersperse,groupBy,transpose) -import qualified Data.Tree as Tree -import Maybe - --- Patterns.ag imports -import UU.Scanner.Position(Pos) -import CommonTypes (Constructor,Name) - -import UU.Scanner.Position(Pos) - --- AbstractSyntax.ag imports -import Data.Set(Set) -import Data.Map(Map) -import Patterns (Pattern(..),Patterns) -import Expression (Expression(..)) -import CommonTypes - --- Terminates with an error if the key is not in the map -findWithErr1 :: (Ord k, Show k) => String -> k -> Map k a -> a -findWithErr1 s k - = Map.findWithDefault (error ("findWithErr1 " ++ s ++ ": key " ++ show k ++ " not in map.")) k - -findWithErr2 :: (Ord k, Show k, Show a) => k -> Map k a -> a -findWithErr2 k m - = Map.findWithDefault (error ("findWithErr2: key " ++ show k ++ " not in map: " ++ show m)) k m - -getNtName :: Type -> Nonterminal -getNtName (NT nt) = nt -getNtName _ = nullIdent - -data AltAttr = AltAttr Name Name Bool - deriving (Eq, Ord, Show) - -substSelf nt tp = if tp==NT _SELF - then Haskell (getName nt) - else tp - -haskellTupel :: [Type] -> Maybe Type -haskellTupel ts = Just ( Haskell ( '(' : (concat (intersperse "," (map show ts))) ++ ")" )) - -lookupVertices :: Identifier -> Identifier -> Map AltAttr Int -> [Int] -lookupVertices fld nm attrs - = catMaybes ( [Map.lookup (AltAttr fld nm True) attrs] - ++ [Map.lookup (AltAttr fld nm False) attrs] - ) - -swap (a,b) = (b,a) - -showPath :: Table CRule -> [Vertex] -> [String] -showPath ruleTable path - = let look a | inRange (bounds ruleTable) a = [showOrigin (ruleTable ! a)] - | otherwise = ["Vertex " ++ show a] - showOrigin cr | getHasCode cr && getName (getAttr cr) /= "self" = prettyCRule cr ++ " (" ++ show (getPos (getAttr cr)) ++ ")" - | otherwise = prettyCRule cr - in concatMap look path - - -showPathLocal :: Table CRule -> [Vertex] -> [String] -showPathLocal _ [] = [] -showPathLocal ruleTable xs = showP (xs++[-1]) - where showP [] = [] - showP (v1:v2:vs) = let line = step v1 v2 - lines = showP vs - in line:lines - step v1 v2 = " - " ++ a1 - where r1 = ruleTable ! v1 - a1 = show (getAttr r1) - - -limitTo :: Int -> [String] -> [String] -limitTo _ [] = [] -limitTo 0 _ = ["....etcetera, etcetera...."] -limitTo n (x:xs) = x : limitTo (n-1) xs - -showPathNice :: Table CRule -> [Vertex] -> [String] -showPathNice _ [] = [] -showPathNice ruleTable xs = limitTo 100 (showP ((-1):xs++[-1])) - where [maxf, maxa, maxn, maxc] = maxWidths ruleTable (take 100 xs) - showP [] = [] - showP (v1:v2:vs) = let line = step v1 v2 - lines = showP vs - in if null line then lines else line:lines - step v1 v2 | last && first = induced - | last && isSyn r1 = "pass up " ++ alignR maxf "" ++ " " ++ alignL maxa a1 ++ " in " ++ alignR maxn n1 ++ "|" ++ c1 ++ induced - | first&& not(isSyn r2) = "get from above " ++ alignR maxf "" ++ " " ++ alignL maxa a2 ++ " in " ++ alignR maxn n2 ++ "|" ++ c2 - | last = "pass down " ++ alignR maxf f1 ++ "." ++ a1 ++ induced - | isSyn r2 = "get from below " ++ alignR maxf f2 ++ "." ++ alignL maxa a2 ++ " in " ++ alignR maxn n2 ++ "|" ++ c2 - | isLocal r1 = if head a1 == '_' - then "" - else "calculate " ++ alignR maxf "loc" ++ "." ++ a1 - | otherwise = "pass down " ++ alignR maxf f1 ++ "." ++ alignL maxa a1 ++ " to " ++ alignR maxn n2 ++ "|" ++ c2 - where - first = v1<0 - last = v2<0 - r1 = ruleTable ! v1 - r2 = ruleTable ! v2 - a1 = show (getAttr r1) - a2 = show (getAttr r2) - f1 = show (getField r1) - f2 = show (getField r2) - n1 = show (getLhsNt r1) - n2 = show (getLhsNt r2) - c1 = show (getCon r1) - c2 = show (getCon r2) - induced | v2== -2 = " INDUCED dependency to " - | otherwise = "" - - -maxWidths ruleTable vs - = map maximum (transpose (map getWidth vs)) - where getWidth v | v<0 = [0,0,0,0] - | otherwise = map (length . show . ($ (ruleTable!v))) [getField, getAttr, getLhsNt, getCon] - -alignL n xs | k Bool -> Route -> Error -localCycleErr ruleTable o_visit (s:path) - = let cr = ruleTable ! s - attr = getAttr cr - nt = getLhsNt cr - con = getCon cr - in LocalCirc nt con attr o_visit (showPathLocal ruleTable path) - -instCycleErr :: Table CRule -> Bool -> Route -> Error -instCycleErr ruleTable o_visit (s:path) - = let cr = ruleTable ! s - attr = getAttr cr - nt = getLhsNt cr - con = getCon cr - in InstCirc nt con attr o_visit (showPathLocal ruleTable path) - -directCycleErrs :: Table NTAttr -> Table CRule -> Bool -> [EdgeRoutes] -> [Error] -directCycleErrs attrTable ruleTable o_visit xs - = let getNont v = case attrTable ! v of - NTASyn nt _ _ -> nt - NTAInh nt _ _ -> nt - getAttr v = case attrTable ! v of - NTASyn _ a _ -> a - NTAInh _ a _ -> a - sameNont ((v1,_),_,_) ((v2,_),_,_) = getNont v1 == getNont v2 - procCycle ((v1,v2),p1,p2) = ((getAttr v1, getAttr v2), showPathNice ruleTable p1, showPathNice ruleTable p2) - wrapGroup gr@(((v1,_),_,_):_) = DirectCirc (getNont v1) o_visit (map procCycle gr) - in map wrapGroup (groupBy sameNont xs) - -inducedCycleErrs :: Table NTAttr -> Table CRule -> CInterfaceMap -> [EdgeRoutes] -> [Error] -inducedCycleErrs attrTable ruleTable cim xs - = let getNont v = case attrTable ! v of - NTASyn nt _ _ -> nt - NTAInh nt _ _ -> nt - getAttr v = case attrTable ! v of - NTASyn _ a _ -> a - NTAInh _ a _ -> a - sameNont ((v1,_),_,_) ((v2,_),_,_) = getNont v1 == getNont v2 - procCycle ((v1,v2),p1,p2) = ((getAttr v1, getAttr v2), showPathNice ruleTable p1, showPathNice ruleTable p2) - wrapGroup gr@(((v1,_),_,_):_) = InducedCirc (getNont v1) (findWithErr1 "inducedCycleErr.cinter" (getNont v1) cim) (map procCycle gr) - in map wrapGroup (groupBy sameNont xs) --- Alternative ------------------------------------------------- -{- - visit 0: - inherited attributes: - allnts : [Name] - cVisitsMap : CVisitsMap - inh : Attributes - manualAttrDepMap : AttrOrderMap - nt : Identifier - o_case : Bool - o_cata : Bool - o_dovisit : Bool - o_newtypes : Bool - o_rename : Bool - o_sem : Bool - o_sig : Bool - o_unbox : Bool - o_wantvisit : Bool - prefix : String - syn : Attributes - chained attribute: - vcount : Int - synthesized attributes: - additionalDep : Seq Edge - cAlternative : CAlternative - cons : [Constructor] - directDep : Seq Edge - errors : Seq Error - instDep : Seq Edge - rules : Seq (Vertex,CRule) - alternatives: - alternative Alternative: - child con : {Constructor} - child children : Children - child rules : Rules - child typeSigs : TypeSigs - visit 0: - local gathAltAttrs : _ - local inhRules : _ - local gathRules : _ - local cVisits : _ - local allfields : _ - local attrs : _ - local inhnames : _ - local synnames : _ --} --- cata -sem_Alternative :: Alternative -> - T_Alternative -sem_Alternative (Alternative _con _children _rules _typeSigs ) = - (sem_Alternative_Alternative _con (sem_Children _children ) (sem_Rules _rules ) (sem_TypeSigs _typeSigs ) ) --- semantic domain -newtype T_Alternative = T_Alternative (([Name]) -> - CVisitsMap -> - Attributes -> - AttrOrderMap -> - Identifier -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - String -> - Attributes -> - Int -> - ( (Seq Edge),CAlternative,([Constructor]),(Seq Edge),(Seq Error),(Seq Edge),(Seq (Vertex,CRule)),Int)) -data Inh_Alternative = Inh_Alternative {allnts_Inh_Alternative :: [Name],cVisitsMap_Inh_Alternative :: CVisitsMap,inh_Inh_Alternative :: Attributes,manualAttrDepMap_Inh_Alternative :: AttrOrderMap,nt_Inh_Alternative :: Identifier,o_case_Inh_Alternative :: Bool,o_cata_Inh_Alternative :: Bool,o_dovisit_Inh_Alternative :: Bool,o_newtypes_Inh_Alternative :: Bool,o_rename_Inh_Alternative :: Bool,o_sem_Inh_Alternative :: Bool,o_sig_Inh_Alternative :: Bool,o_unbox_Inh_Alternative :: Bool,o_wantvisit_Inh_Alternative :: Bool,prefix_Inh_Alternative :: String,syn_Inh_Alternative :: Attributes,vcount_Inh_Alternative :: Int} -data Syn_Alternative = Syn_Alternative {additionalDep_Syn_Alternative :: Seq Edge,cAlternative_Syn_Alternative :: CAlternative,cons_Syn_Alternative :: [Constructor],directDep_Syn_Alternative :: Seq Edge,errors_Syn_Alternative :: Seq Error,instDep_Syn_Alternative :: Seq Edge,rules_Syn_Alternative :: Seq (Vertex,CRule),vcount_Syn_Alternative :: Int} -wrap_Alternative (T_Alternative sem ) (Inh_Alternative _lhsIallnts _lhsIcVisitsMap _lhsIinh _lhsImanualAttrDepMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIvcount ) = - (let ( _lhsOadditionalDep,_lhsOcAlternative,_lhsOcons,_lhsOdirectDep,_lhsOerrors,_lhsOinstDep,_lhsOrules,_lhsOvcount) = - (sem _lhsIallnts _lhsIcVisitsMap _lhsIinh _lhsImanualAttrDepMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIvcount ) - in (Syn_Alternative _lhsOadditionalDep _lhsOcAlternative _lhsOcons _lhsOdirectDep _lhsOerrors _lhsOinstDep _lhsOrules _lhsOvcount )) -sem_Alternative_Alternative :: Constructor -> - T_Children -> - T_Rules -> - T_TypeSigs -> - T_Alternative -sem_Alternative_Alternative con_ (T_Children children_ ) (T_Rules rules_ ) (T_TypeSigs typeSigs_ ) = - (T_Alternative (\ _lhsIallnts - _lhsIcVisitsMap - _lhsIinh - _lhsImanualAttrDepMap - _lhsInt - _lhsIo_case - _lhsIo_cata - _lhsIo_dovisit - _lhsIo_newtypes - _lhsIo_rename - _lhsIo_sem - _lhsIo_sig - _lhsIo_unbox - _lhsIo_wantvisit - _lhsIprefix - _lhsIsyn - _lhsIvcount -> - (let _childrenOcon :: Identifier - _rulesOcon :: Identifier - _rulesOaltAttrs :: (Map AltAttr Vertex) - _rulesOchildNts :: (Map Name Nonterminal) - _rulesOchildInhs :: (Map Name Attributes) - _lhsOrules :: (Seq (Vertex,CRule)) - _lhsOvcount :: Int - _rulesOsynsOfChildren :: (Map Name Attributes) - _lhsOcons :: ([Constructor]) - _typeSigsOtypeSigs :: (Map Name Type) - _rulesOallTypeSigs :: (Map Name Type) - _lhsOcAlternative :: CAlternative - _lhsOadditionalDep :: (Seq Edge) - _lhsOdirectDep :: (Seq Edge) - _lhsOerrors :: (Seq Error) - _lhsOinstDep :: (Seq Edge) - _childrenOallfields :: ([(Name,Type,Bool)]) - _childrenOallnts :: ([Name]) - _childrenOattrs :: ([(Name,Name)]) - _childrenOinh :: Attributes - _childrenOnt :: Identifier - _childrenOo_unbox :: Bool - _childrenOsyn :: Attributes - _rulesOallfields :: ([(Name,Type,Bool)]) - _rulesOallnts :: ([Name]) - _rulesOattrs :: ([(Name,Name)]) - _rulesOinh :: Attributes - _rulesOmanualAttrDepMap :: AttrOrderMap - _rulesOnt :: Identifier - _rulesOo_case :: Bool - _rulesOo_cata :: Bool - _rulesOo_dovisit :: Bool - _rulesOo_newtypes :: Bool - _rulesOo_rename :: Bool - _rulesOo_sem :: Bool - _rulesOo_sig :: Bool - _rulesOo_wantvisit :: Bool - _rulesOprefix :: String - _rulesOsyn :: Attributes - _childrenIattributes :: ([(Name,Attributes,Attributes)]) - _childrenIcollectChildrenSyns :: (Map Name Attributes ) - _childrenIerrors :: (Seq Error) - _childrenIfields :: ([(Name,Type,Bool)]) - _childrenIgathAltAttrs :: ([AltAttr]) - _childrenIgathRules :: (Seq CRule) - _childrenIinhs :: (Seq (Name,Attributes)) - _childrenInts :: (Seq (Name,Nonterminal)) - _childrenIsinglevisits :: ([CRule]) - _childrenIterminals :: ([Name]) - _rulesIadditionalDep :: (Seq Edge) - _rulesIdirectDep :: (Seq Edge) - _rulesIerrors :: (Seq Error) - _rulesIgathAltAttrs :: ([AltAttr]) - _rulesIgathRules :: (Seq CRule) - _rulesIinstDep :: (Seq Edge) - _rulesIinstVars :: ([Name]) - _rulesIlocVars :: ([Name]) - _typeSigsItypeSigs :: (Map Name Type) - -- "Order.ag"(line 69, column 17) - _childrenOcon = - con_ - -- "Order.ag"(line 71, column 17) - _rulesOcon = - con_ - -- "Order.ag"(line 148, column 19) - _gathAltAttrs = - [ AltAttr _LHS inh True | inh <- Map.keys _lhsIinh ] - ++ _childrenIgathAltAttrs - ++ _rulesIgathAltAttrs - -- "Order.ag"(line 164, column 18) - _rulesOaltAttrs = - Map.fromList (zip _gathAltAttrs [_lhsIvcount..]) - -- "Order.ag"(line 177, column 19) - _rulesOchildNts = - Map.fromList (Seq.toList _childrenInts) - -- "Order.ag"(line 178, column 19) - _rulesOchildInhs = - Map.fromList (Seq.toList _childrenIinhs) - -- "Order.ag"(line 184, column 19) - _inhRules = - [ cRuleLhsInh inh _lhsInt con_ tp | (inh,tp) <- Map.assocs _lhsIinh ] - -- "Order.ag"(line 185, column 19) - _gathRules = - _inhRules ++ Seq.toList (_childrenIgathRules Seq.<> _rulesIgathRules) - -- "Order.ag"(line 238, column 19) - _lhsOrules = - Seq.fromList (zip [_lhsIvcount..] _gathRules) - -- "Order.ag"(line 239, column 19) - _lhsOvcount = - _lhsIvcount + length _gathRules - -- "Order.ag"(line 306, column 18) - _rulesOsynsOfChildren = - _childrenIcollectChildrenSyns - -- "Order.ag"(line 384, column 19) - _lhsOcons = - [con_] - -- "Order.ag"(line 391, column 17) - _typeSigsOtypeSigs = - Map.empty - -- "Order.ag"(line 397, column 18) - _rulesOallTypeSigs = - _typeSigsItypeSigs - -- "Order.ag"(line 463, column 18) - _cVisits = - if _lhsIo_dovisit - then let altsVisitsMap = findWithErr1 "Alternative.cVisits.nt" _lhsInt _lhsIcVisitsMap - visits = findWithErr1 "Alternative.cVisits.con" con_ altsVisitsMap - in visits - else let vss = nubBy eqCRuleDefines _gathRules ++ _childrenIsinglevisits - in [CVisit _lhsIinh _lhsIsyn vss [] False] - -- "Order.ag"(line 489, column 19) - _lhsOcAlternative = - CAlternative con_ _cVisits _childrenIfields _childrenIterminals - -- "Order.ag"(line 513, column 17) - _allfields = - _childrenIfields - -- "Order.ag"(line 513, column 17) - _attrs = - map ((,) _LOC) _rulesIlocVars ++ - map ((,) _INST) _rulesIinstVars ++ - map ((,) _LHS) _inhnames ++ - concat [map ((,) nm) (Map.keys as) | (nm,_,as) <- _childrenIattributes] - -- "Order.ag"(line 513, column 17) - _inhnames = - Map.keys _lhsIinh - -- "Order.ag"(line 513, column 17) - _synnames = - Map.keys _lhsIsyn - -- use rule "Order.ag"(line 258, column 71) - _lhsOadditionalDep = - _rulesIadditionalDep - -- use rule "Order.ag"(line 244, column 33) - _lhsOdirectDep = - _rulesIdirectDep - -- use rule "Order.ag"(line 60, column 70) - _lhsOerrors = - _childrenIerrors Seq.<> _rulesIerrors - -- use rule "Order.ag"(line 289, column 31) - _lhsOinstDep = - _rulesIinstDep - -- copy rule (from local) - _childrenOallfields = - _allfields - -- copy rule (down) - _childrenOallnts = - _lhsIallnts - -- copy rule (from local) - _childrenOattrs = - _attrs - -- copy rule (down) - _childrenOinh = - _lhsIinh - -- copy rule (down) - _childrenOnt = - _lhsInt - -- copy rule (down) - _childrenOo_unbox = - _lhsIo_unbox - -- copy rule (down) - _childrenOsyn = - _lhsIsyn - -- copy rule (from local) - _rulesOallfields = - _allfields - -- copy rule (down) - _rulesOallnts = - _lhsIallnts - -- copy rule (from local) - _rulesOattrs = - _attrs - -- copy rule (down) - _rulesOinh = - _lhsIinh - -- copy rule (down) - _rulesOmanualAttrDepMap = - _lhsImanualAttrDepMap - -- copy rule (down) - _rulesOnt = - _lhsInt - -- copy rule (down) - _rulesOo_case = - _lhsIo_case - -- copy rule (down) - _rulesOo_cata = - _lhsIo_cata - -- copy rule (down) - _rulesOo_dovisit = - _lhsIo_dovisit - -- copy rule (down) - _rulesOo_newtypes = - _lhsIo_newtypes - -- copy rule (down) - _rulesOo_rename = - _lhsIo_rename - -- copy rule (down) - _rulesOo_sem = - _lhsIo_sem - -- copy rule (down) - _rulesOo_sig = - _lhsIo_sig - -- copy rule (down) - _rulesOo_wantvisit = - _lhsIo_wantvisit - -- copy rule (down) - _rulesOprefix = - _lhsIprefix - -- copy rule (down) - _rulesOsyn = - _lhsIsyn - ( _childrenIattributes,_childrenIcollectChildrenSyns,_childrenIerrors,_childrenIfields,_childrenIgathAltAttrs,_childrenIgathRules,_childrenIinhs,_childrenInts,_childrenIsinglevisits,_childrenIterminals) = - (children_ _childrenOallfields _childrenOallnts _childrenOattrs _childrenOcon _childrenOinh _childrenOnt _childrenOo_unbox _childrenOsyn ) - ( _rulesIadditionalDep,_rulesIdirectDep,_rulesIerrors,_rulesIgathAltAttrs,_rulesIgathRules,_rulesIinstDep,_rulesIinstVars,_rulesIlocVars) = - (rules_ _rulesOallTypeSigs _rulesOallfields _rulesOallnts _rulesOaltAttrs _rulesOattrs _rulesOchildInhs _rulesOchildNts _rulesOcon _rulesOinh _rulesOmanualAttrDepMap _rulesOnt _rulesOo_case _rulesOo_cata _rulesOo_dovisit _rulesOo_newtypes _rulesOo_rename _rulesOo_sem _rulesOo_sig _rulesOo_wantvisit _rulesOprefix _rulesOsyn _rulesOsynsOfChildren ) - ( _typeSigsItypeSigs) = - (typeSigs_ _typeSigsOtypeSigs ) - in ( _lhsOadditionalDep,_lhsOcAlternative,_lhsOcons,_lhsOdirectDep,_lhsOerrors,_lhsOinstDep,_lhsOrules,_lhsOvcount))) ) --- Alternatives ------------------------------------------------ -{- - visit 0: - inherited attributes: - allnts : [Name] - cVisitsMap : CVisitsMap - inh : Attributes - manualAttrDepMap : AttrOrderMap - nt : Identifier - o_case : Bool - o_cata : Bool - o_dovisit : Bool - o_newtypes : Bool - o_rename : Bool - o_sem : Bool - o_sig : Bool - o_unbox : Bool - o_wantvisit : Bool - prefix : String - syn : Attributes - chained attribute: - vcount : Int - synthesized attributes: - additionalDep : Seq Edge - cAlternatives : CAlternatives - cons : [Constructor] - directDep : Seq Edge - errors : Seq Error - instDep : Seq Edge - rules : Seq (Vertex,CRule) - alternatives: - alternative Cons: - child hd : Alternative - child tl : Alternatives - alternative Nil: --} --- cata -sem_Alternatives :: Alternatives -> - T_Alternatives -sem_Alternatives list = - (Prelude.foldr sem_Alternatives_Cons sem_Alternatives_Nil (Prelude.map sem_Alternative list) ) --- semantic domain -newtype T_Alternatives = T_Alternatives (([Name]) -> - CVisitsMap -> - Attributes -> - AttrOrderMap -> - Identifier -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - String -> - Attributes -> - Int -> - ( (Seq Edge),CAlternatives,([Constructor]),(Seq Edge),(Seq Error),(Seq Edge),(Seq (Vertex,CRule)),Int)) -data Inh_Alternatives = Inh_Alternatives {allnts_Inh_Alternatives :: [Name],cVisitsMap_Inh_Alternatives :: CVisitsMap,inh_Inh_Alternatives :: Attributes,manualAttrDepMap_Inh_Alternatives :: AttrOrderMap,nt_Inh_Alternatives :: Identifier,o_case_Inh_Alternatives :: Bool,o_cata_Inh_Alternatives :: Bool,o_dovisit_Inh_Alternatives :: Bool,o_newtypes_Inh_Alternatives :: Bool,o_rename_Inh_Alternatives :: Bool,o_sem_Inh_Alternatives :: Bool,o_sig_Inh_Alternatives :: Bool,o_unbox_Inh_Alternatives :: Bool,o_wantvisit_Inh_Alternatives :: Bool,prefix_Inh_Alternatives :: String,syn_Inh_Alternatives :: Attributes,vcount_Inh_Alternatives :: Int} -data Syn_Alternatives = Syn_Alternatives {additionalDep_Syn_Alternatives :: Seq Edge,cAlternatives_Syn_Alternatives :: CAlternatives,cons_Syn_Alternatives :: [Constructor],directDep_Syn_Alternatives :: Seq Edge,errors_Syn_Alternatives :: Seq Error,instDep_Syn_Alternatives :: Seq Edge,rules_Syn_Alternatives :: Seq (Vertex,CRule),vcount_Syn_Alternatives :: Int} -wrap_Alternatives (T_Alternatives sem ) (Inh_Alternatives _lhsIallnts _lhsIcVisitsMap _lhsIinh _lhsImanualAttrDepMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIvcount ) = - (let ( _lhsOadditionalDep,_lhsOcAlternatives,_lhsOcons,_lhsOdirectDep,_lhsOerrors,_lhsOinstDep,_lhsOrules,_lhsOvcount) = - (sem _lhsIallnts _lhsIcVisitsMap _lhsIinh _lhsImanualAttrDepMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIvcount ) - in (Syn_Alternatives _lhsOadditionalDep _lhsOcAlternatives _lhsOcons _lhsOdirectDep _lhsOerrors _lhsOinstDep _lhsOrules _lhsOvcount )) -sem_Alternatives_Cons :: T_Alternative -> - T_Alternatives -> - T_Alternatives -sem_Alternatives_Cons (T_Alternative hd_ ) (T_Alternatives tl_ ) = - (T_Alternatives (\ _lhsIallnts - _lhsIcVisitsMap - _lhsIinh - _lhsImanualAttrDepMap - _lhsInt - _lhsIo_case - _lhsIo_cata - _lhsIo_dovisit - _lhsIo_newtypes - _lhsIo_rename - _lhsIo_sem - _lhsIo_sig - _lhsIo_unbox - _lhsIo_wantvisit - _lhsIprefix - _lhsIsyn - _lhsIvcount -> - (let _lhsOcAlternatives :: CAlternatives - _lhsOadditionalDep :: (Seq Edge) - _lhsOcons :: ([Constructor]) - _lhsOdirectDep :: (Seq Edge) - _lhsOerrors :: (Seq Error) - _lhsOinstDep :: (Seq Edge) - _lhsOrules :: (Seq (Vertex,CRule)) - _lhsOvcount :: Int - _hdOallnts :: ([Name]) - _hdOcVisitsMap :: CVisitsMap - _hdOinh :: Attributes - _hdOmanualAttrDepMap :: AttrOrderMap - _hdOnt :: Identifier - _hdOo_case :: Bool - _hdOo_cata :: Bool - _hdOo_dovisit :: Bool - _hdOo_newtypes :: Bool - _hdOo_rename :: Bool - _hdOo_sem :: Bool - _hdOo_sig :: Bool - _hdOo_unbox :: Bool - _hdOo_wantvisit :: Bool - _hdOprefix :: String - _hdOsyn :: Attributes - _hdOvcount :: Int - _tlOallnts :: ([Name]) - _tlOcVisitsMap :: CVisitsMap - _tlOinh :: Attributes - _tlOmanualAttrDepMap :: AttrOrderMap - _tlOnt :: Identifier - _tlOo_case :: Bool - _tlOo_cata :: Bool - _tlOo_dovisit :: Bool - _tlOo_newtypes :: Bool - _tlOo_rename :: Bool - _tlOo_sem :: Bool - _tlOo_sig :: Bool - _tlOo_unbox :: Bool - _tlOo_wantvisit :: Bool - _tlOprefix :: String - _tlOsyn :: Attributes - _tlOvcount :: Int - _hdIadditionalDep :: (Seq Edge) - _hdIcAlternative :: CAlternative - _hdIcons :: ([Constructor]) - _hdIdirectDep :: (Seq Edge) - _hdIerrors :: (Seq Error) - _hdIinstDep :: (Seq Edge) - _hdIrules :: (Seq (Vertex,CRule)) - _hdIvcount :: Int - _tlIadditionalDep :: (Seq Edge) - _tlIcAlternatives :: CAlternatives - _tlIcons :: ([Constructor]) - _tlIdirectDep :: (Seq Edge) - _tlIerrors :: (Seq Error) - _tlIinstDep :: (Seq Edge) - _tlIrules :: (Seq (Vertex,CRule)) - _tlIvcount :: Int - -- "Order.ag"(line 486, column 12) - _lhsOcAlternatives = - _hdIcAlternative : _tlIcAlternatives - -- use rule "Order.ag"(line 258, column 71) - _lhsOadditionalDep = - _hdIadditionalDep Seq.<> _tlIadditionalDep - -- use rule "Order.ag"(line 382, column 42) - _lhsOcons = - _hdIcons ++ _tlIcons - -- use rule "Order.ag"(line 244, column 33) - _lhsOdirectDep = - _hdIdirectDep Seq.<> _tlIdirectDep - -- use rule "Order.ag"(line 60, column 70) - _lhsOerrors = - _hdIerrors Seq.<> _tlIerrors - -- use rule "Order.ag"(line 289, column 31) - _lhsOinstDep = - _hdIinstDep Seq.<> _tlIinstDep - -- use rule "Order.ag"(line 234, column 18) - _lhsOrules = - _hdIrules Seq.<> _tlIrules - -- copy rule (up) - _lhsOvcount = - _tlIvcount - -- copy rule (down) - _hdOallnts = - _lhsIallnts - -- copy rule (down) - _hdOcVisitsMap = - _lhsIcVisitsMap - -- copy rule (down) - _hdOinh = - _lhsIinh - -- copy rule (down) - _hdOmanualAttrDepMap = - _lhsImanualAttrDepMap - -- copy rule (down) - _hdOnt = - _lhsInt - -- copy rule (down) - _hdOo_case = - _lhsIo_case - -- copy rule (down) - _hdOo_cata = - _lhsIo_cata - -- copy rule (down) - _hdOo_dovisit = - _lhsIo_dovisit - -- copy rule (down) - _hdOo_newtypes = - _lhsIo_newtypes - -- copy rule (down) - _hdOo_rename = - _lhsIo_rename - -- copy rule (down) - _hdOo_sem = - _lhsIo_sem - -- copy rule (down) - _hdOo_sig = - _lhsIo_sig - -- copy rule (down) - _hdOo_unbox = - _lhsIo_unbox - -- copy rule (down) - _hdOo_wantvisit = - _lhsIo_wantvisit - -- copy rule (down) - _hdOprefix = - _lhsIprefix - -- copy rule (down) - _hdOsyn = - _lhsIsyn - -- copy rule (down) - _hdOvcount = - _lhsIvcount - -- copy rule (down) - _tlOallnts = - _lhsIallnts - -- copy rule (down) - _tlOcVisitsMap = - _lhsIcVisitsMap - -- copy rule (down) - _tlOinh = - _lhsIinh - -- copy rule (down) - _tlOmanualAttrDepMap = - _lhsImanualAttrDepMap - -- copy rule (down) - _tlOnt = - _lhsInt - -- copy rule (down) - _tlOo_case = - _lhsIo_case - -- copy rule (down) - _tlOo_cata = - _lhsIo_cata - -- copy rule (down) - _tlOo_dovisit = - _lhsIo_dovisit - -- copy rule (down) - _tlOo_newtypes = - _lhsIo_newtypes - -- copy rule (down) - _tlOo_rename = - _lhsIo_rename - -- copy rule (down) - _tlOo_sem = - _lhsIo_sem - -- copy rule (down) - _tlOo_sig = - _lhsIo_sig - -- copy rule (down) - _tlOo_unbox = - _lhsIo_unbox - -- copy rule (down) - _tlOo_wantvisit = - _lhsIo_wantvisit - -- copy rule (down) - _tlOprefix = - _lhsIprefix - -- copy rule (down) - _tlOsyn = - _lhsIsyn - -- copy rule (chain) - _tlOvcount = - _hdIvcount - ( _hdIadditionalDep,_hdIcAlternative,_hdIcons,_hdIdirectDep,_hdIerrors,_hdIinstDep,_hdIrules,_hdIvcount) = - (hd_ _hdOallnts _hdOcVisitsMap _hdOinh _hdOmanualAttrDepMap _hdOnt _hdOo_case _hdOo_cata _hdOo_dovisit _hdOo_newtypes _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_unbox _hdOo_wantvisit _hdOprefix _hdOsyn _hdOvcount ) - ( _tlIadditionalDep,_tlIcAlternatives,_tlIcons,_tlIdirectDep,_tlIerrors,_tlIinstDep,_tlIrules,_tlIvcount) = - (tl_ _tlOallnts _tlOcVisitsMap _tlOinh _tlOmanualAttrDepMap _tlOnt _tlOo_case _tlOo_cata _tlOo_dovisit _tlOo_newtypes _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_unbox _tlOo_wantvisit _tlOprefix _tlOsyn _tlOvcount ) - in ( _lhsOadditionalDep,_lhsOcAlternatives,_lhsOcons,_lhsOdirectDep,_lhsOerrors,_lhsOinstDep,_lhsOrules,_lhsOvcount))) ) -sem_Alternatives_Nil :: T_Alternatives -sem_Alternatives_Nil = - (T_Alternatives (\ _lhsIallnts - _lhsIcVisitsMap - _lhsIinh - _lhsImanualAttrDepMap - _lhsInt - _lhsIo_case - _lhsIo_cata - _lhsIo_dovisit - _lhsIo_newtypes - _lhsIo_rename - _lhsIo_sem - _lhsIo_sig - _lhsIo_unbox - _lhsIo_wantvisit - _lhsIprefix - _lhsIsyn - _lhsIvcount -> - (let _lhsOcAlternatives :: CAlternatives - _lhsOadditionalDep :: (Seq Edge) - _lhsOcons :: ([Constructor]) - _lhsOdirectDep :: (Seq Edge) - _lhsOerrors :: (Seq Error) - _lhsOinstDep :: (Seq Edge) - _lhsOrules :: (Seq (Vertex,CRule)) - _lhsOvcount :: Int - -- "Order.ag"(line 487, column 12) - _lhsOcAlternatives = - [] - -- use rule "Order.ag"(line 258, column 71) - _lhsOadditionalDep = - Seq.empty - -- use rule "Order.ag"(line 382, column 42) - _lhsOcons = - [] - -- use rule "Order.ag"(line 244, column 33) - _lhsOdirectDep = - Seq.empty - -- use rule "Order.ag"(line 60, column 70) - _lhsOerrors = - Seq.empty - -- use rule "Order.ag"(line 289, column 31) - _lhsOinstDep = - Seq.empty - -- use rule "Order.ag"(line 234, column 18) - _lhsOrules = - Seq.empty - -- copy rule (chain) - _lhsOvcount = - _lhsIvcount - in ( _lhsOadditionalDep,_lhsOcAlternatives,_lhsOcons,_lhsOdirectDep,_lhsOerrors,_lhsOinstDep,_lhsOrules,_lhsOvcount))) ) --- Child ------------------------------------------------------- -{- - visit 0: - inherited attributes: - allfields : [(Name,Type,Bool)] - allnts : [Name] - attrs : [(Name,Name)] - con : Identifier - inh : Attributes - nt : Identifier - o_unbox : Bool - syn : Attributes - synthesized attributes: - attributes : [(Name,Attributes,Attributes)] - collectChildrenSyns : Map Name Attributes - errors : Seq Error - field : (Name,Type,Bool) - gathAltAttrs : [AltAttr] - gathRules : Seq CRule - inhs : Seq (Name,Attributes) - nts : Seq (Name,Nonterminal) - singlevisits : [CRule] - terminals : [Name] - alternatives: - alternative Child: - child name : {Name} - child tp : {Type} - child inh : {Attributes} - child syn : {Attributes} - child higherOrder : {Bool} - visit 0: - local maptolocal : _ - local gathRules : _ --} --- cata -sem_Child :: Child -> - T_Child -sem_Child (Child _name _tp _inh _syn _higherOrder ) = - (sem_Child_Child _name _tp _inh _syn _higherOrder ) --- semantic domain -newtype T_Child = T_Child (([(Name,Type,Bool)]) -> - ([Name]) -> - ([(Name,Name)]) -> - Identifier -> - Attributes -> - Identifier -> - Bool -> - Attributes -> - ( ([(Name,Attributes,Attributes)]),(Map Name Attributes ),(Seq Error),((Name,Type,Bool)),([AltAttr]),(Seq CRule),(Seq (Name,Attributes)),(Seq (Name,Nonterminal)),([CRule]),([Name]))) -data Inh_Child = Inh_Child {allfields_Inh_Child :: [(Name,Type,Bool)],allnts_Inh_Child :: [Name],attrs_Inh_Child :: [(Name,Name)],con_Inh_Child :: Identifier,inh_Inh_Child :: Attributes,nt_Inh_Child :: Identifier,o_unbox_Inh_Child :: Bool,syn_Inh_Child :: Attributes} -data Syn_Child = Syn_Child {attributes_Syn_Child :: [(Name,Attributes,Attributes)],collectChildrenSyns_Syn_Child :: Map Name Attributes ,errors_Syn_Child :: Seq Error,field_Syn_Child :: (Name,Type,Bool),gathAltAttrs_Syn_Child :: [AltAttr],gathRules_Syn_Child :: Seq CRule,inhs_Syn_Child :: Seq (Name,Attributes),nts_Syn_Child :: Seq (Name,Nonterminal),singlevisits_Syn_Child :: [CRule],terminals_Syn_Child :: [Name]} -wrap_Child (T_Child sem ) (Inh_Child _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsInt _lhsIo_unbox _lhsIsyn ) = - (let ( _lhsOattributes,_lhsOcollectChildrenSyns,_lhsOerrors,_lhsOfield,_lhsOgathAltAttrs,_lhsOgathRules,_lhsOinhs,_lhsOnts,_lhsOsinglevisits,_lhsOterminals) = - (sem _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsInt _lhsIo_unbox _lhsIsyn ) - in (Syn_Child _lhsOattributes _lhsOcollectChildrenSyns _lhsOerrors _lhsOfield _lhsOgathAltAttrs _lhsOgathRules _lhsOinhs _lhsOnts _lhsOsinglevisits _lhsOterminals )) -sem_Child_Child :: Name -> - Type -> - Attributes -> - Attributes -> - Bool -> - T_Child -sem_Child_Child name_ tp_ inh_ syn_ higherOrder_ = - (T_Child (\ _lhsIallfields - _lhsIallnts - _lhsIattrs - _lhsIcon - _lhsIinh - _lhsInt - _lhsIo_unbox - _lhsIsyn -> - (let _lhsOgathAltAttrs :: ([AltAttr]) - _lhsOnts :: (Seq (Name,Nonterminal)) - _lhsOinhs :: (Seq (Name,Attributes)) - _lhsOcollectChildrenSyns :: (Map Name Attributes ) - _lhsOsinglevisits :: ([CRule]) - _lhsOterminals :: ([Name]) - _lhsOattributes :: ([(Name,Attributes,Attributes)]) - _lhsOfield :: ((Name,Type,Bool)) - _lhsOerrors :: (Seq Error) - _lhsOgathRules :: (Seq CRule) - -- "Order.ag"(line 153, column 13) - _maptolocal = - case tp_ of - NT nt -> Map.null syn_ - _ -> True - -- "Order.ag"(line 156, column 13) - _lhsOgathAltAttrs = - if _maptolocal - then [ AltAttr _LOC name_ True ] - else [ AltAttr name_ syn True | syn <- Map.keys syn_ ] - -- "Order.ag"(line 171, column 13) - _lhsOnts = - Seq.single (name_,getNtName tp_) - -- "Order.ag"(line 172, column 13) - _lhsOinhs = - Seq.single (name_,inh_) - -- "Order.ag"(line 188, column 13) - _gathRules = - if _maptolocal - then Seq.single (cRuleTerminal name_ _lhsInt _lhsIcon tp_) - else Seq.fromList [ cRuleRhsSyn syn _lhsInt _lhsIcon tp name_ (getNtName tp_) | (syn,tp) <- Map.assocs syn_] - -- "Order.ag"(line 310, column 12) - _lhsOcollectChildrenSyns = - Map.singleton name_ syn_ - -- "Order.ag"(line 473, column 11) - _lhsOsinglevisits = - if _maptolocal - then [] - else [CChildVisit name_ (getNtName tp_) 0 inh_ syn_ True] - -- "Order.ag"(line 494, column 11) - _lhsOterminals = - if _maptolocal - then [name_] - else [] - -- "Order.ag"(line 523, column 11) - _lhsOattributes = - [(name_, inh_, syn_)] - -- "Order.ag"(line 527, column 11) - _lhsOfield = - (name_, tp_, higherOrder_) - -- use rule "Order.ag"(line 60, column 70) - _lhsOerrors = - Seq.empty - -- use rule "Order.ag"(line 182, column 23) - _lhsOgathRules = - _gathRules - in ( _lhsOattributes,_lhsOcollectChildrenSyns,_lhsOerrors,_lhsOfield,_lhsOgathAltAttrs,_lhsOgathRules,_lhsOinhs,_lhsOnts,_lhsOsinglevisits,_lhsOterminals))) ) --- Children ---------------------------------------------------- -{- - visit 0: - inherited attributes: - allfields : [(Name,Type,Bool)] - allnts : [Name] - attrs : [(Name,Name)] - con : Identifier - inh : Attributes - nt : Identifier - o_unbox : Bool - syn : Attributes - synthesized attributes: - attributes : [(Name,Attributes,Attributes)] - collectChildrenSyns : Map Name Attributes - errors : Seq Error - fields : [(Name,Type,Bool)] - gathAltAttrs : [AltAttr] - gathRules : Seq CRule - inhs : Seq (Name,Attributes) - nts : Seq (Name,Nonterminal) - singlevisits : [CRule] - terminals : [Name] - alternatives: - alternative Cons: - child hd : Child - child tl : Children - alternative Nil: --} --- cata -sem_Children :: Children -> - T_Children -sem_Children list = - (Prelude.foldr sem_Children_Cons sem_Children_Nil (Prelude.map sem_Child list) ) --- semantic domain -newtype T_Children = T_Children (([(Name,Type,Bool)]) -> - ([Name]) -> - ([(Name,Name)]) -> - Identifier -> - Attributes -> - Identifier -> - Bool -> - Attributes -> - ( ([(Name,Attributes,Attributes)]),(Map Name Attributes ),(Seq Error),([(Name,Type,Bool)]),([AltAttr]),(Seq CRule),(Seq (Name,Attributes)),(Seq (Name,Nonterminal)),([CRule]),([Name]))) -data Inh_Children = Inh_Children {allfields_Inh_Children :: [(Name,Type,Bool)],allnts_Inh_Children :: [Name],attrs_Inh_Children :: [(Name,Name)],con_Inh_Children :: Identifier,inh_Inh_Children :: Attributes,nt_Inh_Children :: Identifier,o_unbox_Inh_Children :: Bool,syn_Inh_Children :: Attributes} -data Syn_Children = Syn_Children {attributes_Syn_Children :: [(Name,Attributes,Attributes)],collectChildrenSyns_Syn_Children :: Map Name Attributes ,errors_Syn_Children :: Seq Error,fields_Syn_Children :: [(Name,Type,Bool)],gathAltAttrs_Syn_Children :: [AltAttr],gathRules_Syn_Children :: Seq CRule,inhs_Syn_Children :: Seq (Name,Attributes),nts_Syn_Children :: Seq (Name,Nonterminal),singlevisits_Syn_Children :: [CRule],terminals_Syn_Children :: [Name]} -wrap_Children (T_Children sem ) (Inh_Children _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsInt _lhsIo_unbox _lhsIsyn ) = - (let ( _lhsOattributes,_lhsOcollectChildrenSyns,_lhsOerrors,_lhsOfields,_lhsOgathAltAttrs,_lhsOgathRules,_lhsOinhs,_lhsOnts,_lhsOsinglevisits,_lhsOterminals) = - (sem _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsInt _lhsIo_unbox _lhsIsyn ) - in (Syn_Children _lhsOattributes _lhsOcollectChildrenSyns _lhsOerrors _lhsOfields _lhsOgathAltAttrs _lhsOgathRules _lhsOinhs _lhsOnts _lhsOsinglevisits _lhsOterminals )) -sem_Children_Cons :: T_Child -> - T_Children -> - T_Children -sem_Children_Cons (T_Child hd_ ) (T_Children tl_ ) = - (T_Children (\ _lhsIallfields - _lhsIallnts - _lhsIattrs - _lhsIcon - _lhsIinh - _lhsInt - _lhsIo_unbox - _lhsIsyn -> - (let _lhsOfields :: ([(Name,Type,Bool)]) - _lhsOattributes :: ([(Name,Attributes,Attributes)]) - _lhsOcollectChildrenSyns :: (Map Name Attributes ) - _lhsOerrors :: (Seq Error) - _lhsOgathAltAttrs :: ([AltAttr]) - _lhsOgathRules :: (Seq CRule) - _lhsOinhs :: (Seq (Name,Attributes)) - _lhsOnts :: (Seq (Name,Nonterminal)) - _lhsOsinglevisits :: ([CRule]) - _lhsOterminals :: ([Name]) - _hdOallfields :: ([(Name,Type,Bool)]) - _hdOallnts :: ([Name]) - _hdOattrs :: ([(Name,Name)]) - _hdOcon :: Identifier - _hdOinh :: Attributes - _hdOnt :: Identifier - _hdOo_unbox :: Bool - _hdOsyn :: Attributes - _tlOallfields :: ([(Name,Type,Bool)]) - _tlOallnts :: ([Name]) - _tlOattrs :: ([(Name,Name)]) - _tlOcon :: Identifier - _tlOinh :: Attributes - _tlOnt :: Identifier - _tlOo_unbox :: Bool - _tlOsyn :: Attributes - _hdIattributes :: ([(Name,Attributes,Attributes)]) - _hdIcollectChildrenSyns :: (Map Name Attributes ) - _hdIerrors :: (Seq Error) - _hdIfield :: ((Name,Type,Bool)) - _hdIgathAltAttrs :: ([AltAttr]) - _hdIgathRules :: (Seq CRule) - _hdIinhs :: (Seq (Name,Attributes)) - _hdInts :: (Seq (Name,Nonterminal)) - _hdIsinglevisits :: ([CRule]) - _hdIterminals :: ([Name]) - _tlIattributes :: ([(Name,Attributes,Attributes)]) - _tlIcollectChildrenSyns :: (Map Name Attributes ) - _tlIerrors :: (Seq Error) - _tlIfields :: ([(Name,Type,Bool)]) - _tlIgathAltAttrs :: ([AltAttr]) - _tlIgathRules :: (Seq CRule) - _tlIinhs :: (Seq (Name,Attributes)) - _tlInts :: (Seq (Name,Nonterminal)) - _tlIsinglevisits :: ([CRule]) - _tlIterminals :: ([Name]) - -- "Order.ag"(line 530, column 11) - _lhsOfields = - _hdIfield : _tlIfields - -- use rule "Order.ag"(line 521, column 32) - _lhsOattributes = - _hdIattributes ++ _tlIattributes - -- use rule "Order.ag"(line 308, column 47) - _lhsOcollectChildrenSyns = - _hdIcollectChildrenSyns `Map.union` _tlIcollectChildrenSyns - -- use rule "Order.ag"(line 60, column 70) - _lhsOerrors = - _hdIerrors Seq.<> _tlIerrors - -- use rule "Order.ag"(line 146, column 68) - _lhsOgathAltAttrs = - _hdIgathAltAttrs ++ _tlIgathAltAttrs - -- use rule "Order.ag"(line 182, column 23) - _lhsOgathRules = - _hdIgathRules Seq.<> _tlIgathRules - -- use rule "Order.ag"(line 169, column 20) - _lhsOinhs = - _hdIinhs Seq.<> _tlIinhs - -- use rule "Order.ag"(line 168, column 19) - _lhsOnts = - _hdInts Seq.<> _tlInts - -- use rule "Order.ag"(line 471, column 40) - _lhsOsinglevisits = - _hdIsinglevisits ++ _tlIsinglevisits - -- use rule "Order.ag"(line 492, column 38) - _lhsOterminals = - _hdIterminals ++ _tlIterminals - -- copy rule (down) - _hdOallfields = - _lhsIallfields - -- copy rule (down) - _hdOallnts = - _lhsIallnts - -- copy rule (down) - _hdOattrs = - _lhsIattrs - -- copy rule (down) - _hdOcon = - _lhsIcon - -- copy rule (down) - _hdOinh = - _lhsIinh - -- copy rule (down) - _hdOnt = - _lhsInt - -- copy rule (down) - _hdOo_unbox = - _lhsIo_unbox - -- copy rule (down) - _hdOsyn = - _lhsIsyn - -- copy rule (down) - _tlOallfields = - _lhsIallfields - -- copy rule (down) - _tlOallnts = - _lhsIallnts - -- copy rule (down) - _tlOattrs = - _lhsIattrs - -- copy rule (down) - _tlOcon = - _lhsIcon - -- copy rule (down) - _tlOinh = - _lhsIinh - -- copy rule (down) - _tlOnt = - _lhsInt - -- copy rule (down) - _tlOo_unbox = - _lhsIo_unbox - -- copy rule (down) - _tlOsyn = - _lhsIsyn - ( _hdIattributes,_hdIcollectChildrenSyns,_hdIerrors,_hdIfield,_hdIgathAltAttrs,_hdIgathRules,_hdIinhs,_hdInts,_hdIsinglevisits,_hdIterminals) = - (hd_ _hdOallfields _hdOallnts _hdOattrs _hdOcon _hdOinh _hdOnt _hdOo_unbox _hdOsyn ) - ( _tlIattributes,_tlIcollectChildrenSyns,_tlIerrors,_tlIfields,_tlIgathAltAttrs,_tlIgathRules,_tlIinhs,_tlInts,_tlIsinglevisits,_tlIterminals) = - (tl_ _tlOallfields _tlOallnts _tlOattrs _tlOcon _tlOinh _tlOnt _tlOo_unbox _tlOsyn ) - in ( _lhsOattributes,_lhsOcollectChildrenSyns,_lhsOerrors,_lhsOfields,_lhsOgathAltAttrs,_lhsOgathRules,_lhsOinhs,_lhsOnts,_lhsOsinglevisits,_lhsOterminals))) ) -sem_Children_Nil :: T_Children -sem_Children_Nil = - (T_Children (\ _lhsIallfields - _lhsIallnts - _lhsIattrs - _lhsIcon - _lhsIinh - _lhsInt - _lhsIo_unbox - _lhsIsyn -> - (let _lhsOfields :: ([(Name,Type,Bool)]) - _lhsOattributes :: ([(Name,Attributes,Attributes)]) - _lhsOcollectChildrenSyns :: (Map Name Attributes ) - _lhsOerrors :: (Seq Error) - _lhsOgathAltAttrs :: ([AltAttr]) - _lhsOgathRules :: (Seq CRule) - _lhsOinhs :: (Seq (Name,Attributes)) - _lhsOnts :: (Seq (Name,Nonterminal)) - _lhsOsinglevisits :: ([CRule]) - _lhsOterminals :: ([Name]) - -- "Order.ag"(line 531, column 11) - _lhsOfields = - [] - -- use rule "Order.ag"(line 521, column 32) - _lhsOattributes = - [] - -- use rule "Order.ag"(line 308, column 47) - _lhsOcollectChildrenSyns = - Map.empty - -- use rule "Order.ag"(line 60, column 70) - _lhsOerrors = - Seq.empty - -- use rule "Order.ag"(line 146, column 68) - _lhsOgathAltAttrs = - [] - -- use rule "Order.ag"(line 182, column 23) - _lhsOgathRules = - Seq.empty - -- use rule "Order.ag"(line 169, column 20) - _lhsOinhs = - Seq.empty - -- use rule "Order.ag"(line 168, column 19) - _lhsOnts = - Seq.empty - -- use rule "Order.ag"(line 471, column 40) - _lhsOsinglevisits = - [] - -- use rule "Order.ag"(line 492, column 38) - _lhsOterminals = - [] - in ( _lhsOattributes,_lhsOcollectChildrenSyns,_lhsOerrors,_lhsOfields,_lhsOgathAltAttrs,_lhsOgathRules,_lhsOinhs,_lhsOnts,_lhsOsinglevisits,_lhsOterminals))) ) --- Expression -------------------------------------------------- -{- - visit 0: - inherited attributes: - allfields : [(Name,Type,Bool)] - allnts : [Name] - attrs : [(Name,Name)] - con : Name - nt : Name - synthesized attributes: - allRhsVars : Set (Name,Name) - copy : SELF - errors : Seq Error - textLines : [String] - usedAttrs : [(Name,Name)] - usedFields : [Name] - usedLocals : [Name] - alternatives: - alternative Expression: - child pos : {Pos} - child txt : {String} - visit 0: - local _tup1 : _ - local errors : _ - local textLines : _ - local usedAttrs : _ - local usedLocals : _ - local usedFields : _ - local copy : _ --} --- cata -sem_Expression :: Expression -> - T_Expression -sem_Expression (Expression _pos _txt ) = - (sem_Expression_Expression _pos _txt ) --- semantic domain -newtype T_Expression = T_Expression (([(Name,Type,Bool)]) -> - ([Name]) -> - ([(Name,Name)]) -> - Name -> - Name -> - ( (Set (Name,Name)),Expression,(Seq Error),([String]),([(Name,Name)]),([Name]),([Name]))) -data Inh_Expression = Inh_Expression {allfields_Inh_Expression :: [(Name,Type,Bool)],allnts_Inh_Expression :: [Name],attrs_Inh_Expression :: [(Name,Name)],con_Inh_Expression :: Name,nt_Inh_Expression :: Name} -data Syn_Expression = Syn_Expression {allRhsVars_Syn_Expression :: Set (Name,Name),copy_Syn_Expression :: Expression,errors_Syn_Expression :: Seq Error,textLines_Syn_Expression :: [String],usedAttrs_Syn_Expression :: [(Name,Name)],usedFields_Syn_Expression :: [Name],usedLocals_Syn_Expression :: [Name]} -wrap_Expression (T_Expression sem ) (Inh_Expression _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsInt ) = - (let ( _lhsOallRhsVars,_lhsOcopy,_lhsOerrors,_lhsOtextLines,_lhsOusedAttrs,_lhsOusedFields,_lhsOusedLocals) = - (sem _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsInt ) - in (Syn_Expression _lhsOallRhsVars _lhsOcopy _lhsOerrors _lhsOtextLines _lhsOusedAttrs _lhsOusedFields _lhsOusedLocals )) -sem_Expression_Expression :: Pos -> - String -> - T_Expression -sem_Expression_Expression pos_ txt_ = - (T_Expression (\ _lhsIallfields - _lhsIallnts - _lhsIattrs - _lhsIcon - _lhsInt -> - (let _lhsOallRhsVars :: (Set (Name,Name)) - _lhsOcopy :: Expression - _lhsOerrors :: (Seq Error) - _lhsOtextLines :: ([String]) - _lhsOusedAttrs :: ([(Name,Name)]) - _lhsOusedFields :: ([Name]) - _lhsOusedLocals :: ([Name]) - -- "Order.ag"(line 330, column 21) - __tup1 = - let inherited = Inh_HsTokensRoot - { attrs_Inh_HsTokensRoot = _lhsIattrs - , con_Inh_HsTokensRoot = _lhsIcon - , allfields_Inh_HsTokensRoot = _lhsIallfields - , allnts_Inh_HsTokensRoot = _lhsIallnts - , nt_Inh_HsTokensRoot = _lhsInt - } - pos' = case pos_ of - Pos l k f -> Pos l 1 f - synthesized = wrap_HsTokensRoot (sem_HsTokensRoot (HsTokensRoot $ lexTokens pos' txt_)) inherited - in case synthesized of - Syn_HsTokensRoot - { errors_Syn_HsTokensRoot = errors - , textLines_Syn_HsTokensRoot = textLines - , usedAttrs_Syn_HsTokensRoot = usedAttrs - , usedLocals_Syn_HsTokensRoot = usedLocals - , usedFields_Syn_HsTokensRoot = usedFields - } -> (errors,textLines,usedAttrs,usedLocals,usedFields) - -- "Order.ag"(line 330, column 21) - (_errors,_,_,_,_) = - __tup1 - -- "Order.ag"(line 330, column 21) - (_,_textLines,_,_,_) = - __tup1 - -- "Order.ag"(line 330, column 21) - (_,_,_usedAttrs,_,_) = - __tup1 - -- "Order.ag"(line 330, column 21) - (_,_,_,_usedLocals,_) = - __tup1 - -- "Order.ag"(line 330, column 21) - (_,_,_,_,_usedFields) = - __tup1 - -- "Order.ag"(line 351, column 17) - _lhsOallRhsVars = - Set.fromList _usedAttrs - `Set.union` - Set.fromList [ (_LOC, l) | l <- _usedLocals ] - `Set.union` - Set.fromList [ (_FIELD, fld) | fld <- _usedFields ] - -- self rule - _copy = - Expression pos_ txt_ - -- self rule - _lhsOcopy = - _copy - -- copy rule (from local) - _lhsOerrors = - _errors - -- copy rule (from local) - _lhsOtextLines = - _textLines - -- copy rule (from local) - _lhsOusedAttrs = - _usedAttrs - -- copy rule (from local) - _lhsOusedFields = - _usedFields - -- copy rule (from local) - _lhsOusedLocals = - _usedLocals - in ( _lhsOallRhsVars,_lhsOcopy,_lhsOerrors,_lhsOtextLines,_lhsOusedAttrs,_lhsOusedFields,_lhsOusedLocals))) ) --- Grammar ----------------------------------------------------- -{- - visit 0: - inherited attribute: - options : Options - synthesized attributes: - errors : Seq Error - output : CGrammar - alternatives: - alternative Grammar: - child typeSyns : {TypeSyns} - child useMap : {UseMap} - child derivings : {Derivings} - child wrappers : {Set Nonterminal} - child prods : Productions - child pragmas : {PragmaMap} - child manualAttrOrderMap : {AttrOrderMap} - visit 0: - local ruleTable : _ - local attrTable : _ - local attrVertex : _ - local tdpToTds : _ - local tdsToTdp : _ - local directDep : _ - local instDep : _ - local info : _ - local _tup2 : _ - local cInterfaceMap : _ - local cVisitsMap : _ - local cyclesErrors : _ --} --- cata -sem_Grammar :: Grammar -> - T_Grammar -sem_Grammar (Grammar _typeSyns _useMap _derivings _wrappers _prods _pragmas _manualAttrOrderMap ) = - (sem_Grammar_Grammar _typeSyns _useMap _derivings _wrappers (sem_Productions _prods ) _pragmas _manualAttrOrderMap ) --- semantic domain -newtype T_Grammar = T_Grammar (Options -> - ( (Seq Error),CGrammar)) -data Inh_Grammar = Inh_Grammar {options_Inh_Grammar :: Options} -data Syn_Grammar = Syn_Grammar {errors_Syn_Grammar :: Seq Error,output_Syn_Grammar :: CGrammar} -wrap_Grammar (T_Grammar sem ) (Inh_Grammar _lhsIoptions ) = - (let ( _lhsOerrors,_lhsOoutput) = - (sem _lhsIoptions ) - in (Syn_Grammar _lhsOerrors _lhsOoutput )) -sem_Grammar_Grammar :: TypeSyns -> - UseMap -> - Derivings -> - (Set Nonterminal) -> - T_Productions -> - PragmaMap -> - AttrOrderMap -> - T_Grammar -sem_Grammar_Grammar typeSyns_ useMap_ derivings_ wrappers_ (T_Productions prods_ ) pragmas_ manualAttrOrderMap_ = - (T_Grammar (\ _lhsIoptions -> - (let _prodsOo_cata :: Bool - _prodsOo_data :: Bool - _prodsOo_sig :: Bool - _prodsOo_sem :: Bool - _prodsOo_rename :: Bool - _prodsOo_newtypes :: Bool - _prodsOo_wantvisit :: Bool - _prodsOo_dovisit :: Bool - _prodsOo_unbox :: Bool - _prodsOo_case :: Bool - _prodsOprefix :: String - _prodsOvcount :: Int - _prodsOmanualAttrDepMap :: AttrOrderMap - _prodsOacount :: Int - _lhsOerrors :: (Seq Error) - _lhsOoutput :: CGrammar - _prodsOallnts :: ([Name]) - _prodsOcInterfaceMap :: CInterfaceMap - _prodsOcVisitsMap :: CVisitsMap - _prodsIacount :: Int - _prodsIadditionalDep :: (Seq Edge) - _prodsIaranges :: (Seq (Int,Int,Int)) - _prodsIcProductions :: CProductions - _prodsIdirectDep :: (Seq Edge) - _prodsIerrors :: (Seq Error) - _prodsIinstDep :: (Seq Edge) - _prodsIntattrs :: (Seq (Vertex,NTAttr)) - _prodsIprods :: ([(Nonterminal,[Constructor])]) - _prodsIrules :: (Seq (Vertex,CRule)) - _prodsIvcount :: Int - -- "Order.ag"(line 99, column 17) - _prodsOo_cata = - folds _lhsIoptions - -- "Order.ag"(line 99, column 17) - _prodsOo_data = - dataTypes _lhsIoptions - -- "Order.ag"(line 99, column 17) - _prodsOo_sig = - typeSigs _lhsIoptions - -- "Order.ag"(line 99, column 17) - _prodsOo_sem = - semfuns _lhsIoptions - -- "Order.ag"(line 99, column 17) - _prodsOo_rename = - rename _lhsIoptions - -- "Order.ag"(line 99, column 17) - _prodsOo_newtypes = - newtypes _lhsIoptions - -- "Order.ag"(line 99, column 17) - _prodsOo_wantvisit = - visit _lhsIoptions - -- "Order.ag"(line 99, column 17) - _prodsOo_dovisit = - visit _lhsIoptions && null _cyclesErrors - -- "Order.ag"(line 99, column 17) - _prodsOo_unbox = - unbox _lhsIoptions - -- "Order.ag"(line 99, column 17) - _prodsOo_case = - cases _lhsIoptions - -- "Order.ag"(line 99, column 17) - _prodsOprefix = - prefix _lhsIoptions - -- "Order.ag"(line 236, column 15) - _prodsOvcount = - 0 - -- "Order.ag"(line 261, column 7) - _prodsOmanualAttrDepMap = - manualAttrOrderMap_ - -- "Order.ag"(line 365, column 13) - _prodsOacount = - 0 - -- "Order.ag"(line 403, column 13) - _ruleTable = - Array.array (0,_prodsIvcount-1) (Seq.toList _prodsIrules) - -- "Order.ag"(line 404, column 13) - _attrTable = - Array.array (0,_prodsIacount-1) (Seq.toList _prodsIntattrs) - -- "Order.ag"(line 405, column 13) - _attrVertex = - Map.fromList (map swap (Seq.toList _prodsIntattrs)) - -- "Order.ag"(line 406, column 13) - _tdpToTds = - [ (s, maybe (-1) (\v -> findWithErr1 "Grammar.tdpToTds" v _attrVertex) (ntattr cr)) - | (s,cr) <- Seq.toList _prodsIrules] - -- "Order.ag"(line 408, column 13) - _tdsToTdp = - let eq (_,v) (_,v') = v == v' - conv ((s,v):svs) | v == -1 = Nothing - | otherwise = Just (v,s:map fst svs) - in mapMaybe conv (eqClasses eq _tdpToTds) - -- "Order.ag"(line 412, column 13) - _directDep = - Seq.toList (_prodsIdirectDep Seq.<> _prodsIadditionalDep) - -- "Order.ag"(line 413, column 13) - _instDep = - Seq.toList _prodsIinstDep - -- "Order.ag"(line 414, column 13) - _info = - let def [] = -1 - def (v:vs) = v - in Info { tdsToTdp = Array.array (0,_prodsIacount-1) _tdsToTdp - , tdpToTds = Array.array (0,_prodsIvcount-1) _tdpToTds - , attrTable = _attrTable - , ruleTable = _ruleTable - , lmh = Seq.toList _prodsIaranges - , prods = _prodsIprods - , wraps = wrappers_ - } - -- "Order.ag"(line 425, column 17) - __tup2 = - case computeSequential _info _directDep _instDep of - CycleFree cim cvm -> ( cim - , cvm - , [] - ) - LocalCycle errs -> ( error "No interfaces for AG with local cycles" - , error "No visit sub-sequences for AG with local cycles" - , map (localCycleErr _ruleTable (visit _lhsIoptions)) errs - ) - InstCycle errs -> ( error "No interfaces for AG with cycles through insts" - , error "No visit sub-sequences for AG with cycles through insts" - , map (instCycleErr _ruleTable (visit _lhsIoptions)) errs - ) - DirectCycle errs -> ( error "No interfaces for AG with direct cycles" - , error "No visit sub-sequences for AG with direct cycles" - , directCycleErrs _attrTable _ruleTable (visit _lhsIoptions) errs - ) - InducedCycle cim errs -> ( cim - , error "No visit sub-sequences for AG with induced cycles" - , inducedCycleErrs _attrTable _ruleTable cim errs - ) - -- "Order.ag"(line 425, column 17) - (_cInterfaceMap,_,_) = - __tup2 - -- "Order.ag"(line 425, column 17) - (_,_cVisitsMap,_) = - __tup2 - -- "Order.ag"(line 425, column 17) - (_,_,_cyclesErrors) = - __tup2 - -- "Order.ag"(line 447, column 13) - _lhsOerrors = - (if withCycle _lhsIoptions then Seq.fromList _cyclesErrors else Seq.empty) - Seq.<> _prodsIerrors - -- "Order.ag"(line 479, column 15) - _lhsOoutput = - CGrammar typeSyns_ derivings_ wrappers_ _prodsIcProductions pragmas_ - -- "Order.ag"(line 506, column 13) - _prodsOallnts = - map fst (_prodsIprods) - -- copy rule (from local) - _prodsOcInterfaceMap = - _cInterfaceMap - -- copy rule (from local) - _prodsOcVisitsMap = - _cVisitsMap - ( _prodsIacount,_prodsIadditionalDep,_prodsIaranges,_prodsIcProductions,_prodsIdirectDep,_prodsIerrors,_prodsIinstDep,_prodsIntattrs,_prodsIprods,_prodsIrules,_prodsIvcount) = - (prods_ _prodsOacount _prodsOallnts _prodsOcInterfaceMap _prodsOcVisitsMap _prodsOmanualAttrDepMap _prodsOo_case _prodsOo_cata _prodsOo_data _prodsOo_dovisit _prodsOo_newtypes _prodsOo_rename _prodsOo_sem _prodsOo_sig _prodsOo_unbox _prodsOo_wantvisit _prodsOprefix _prodsOvcount ) - in ( _lhsOerrors,_lhsOoutput))) ) --- Pattern ----------------------------------------------------- -{- - visit 0: - inherited attributes: - allTypeSigs : Map Name Type - altAttrs : Map AltAttr Vertex - con : Identifier - inh : Attributes - nt : Identifier - syn : Attributes - synthesized attributes: - copy : SELF - errors : Seq Error - gathAltAttrs : [AltAttr] - instVars : [Name] - locVars : [Name] - patternAttrs : [(Name,Name,Bool,Patterns)] - alternatives: - alternative Alias: - child field : {Name} - child attr : {Name} - child pat : Pattern - child parts : Patterns - visit 0: - local copy : _ - alternative Constr: - child name : {Constructor} - child pats : Patterns - visit 0: - local copy : _ - alternative Product: - child pos : {Pos} - child pats : Patterns - visit 0: - local copy : _ - alternative Underscore: - child pos : {Pos} - visit 0: - local copy : _ --} --- cata -sem_Pattern :: Pattern -> - T_Pattern -sem_Pattern (Alias _field _attr _pat _parts ) = - (sem_Pattern_Alias _field _attr (sem_Pattern _pat ) (sem_Patterns _parts ) ) -sem_Pattern (Constr _name _pats ) = - (sem_Pattern_Constr _name (sem_Patterns _pats ) ) -sem_Pattern (Product _pos _pats ) = - (sem_Pattern_Product _pos (sem_Patterns _pats ) ) -sem_Pattern (Underscore _pos ) = - (sem_Pattern_Underscore _pos ) --- semantic domain -newtype T_Pattern = T_Pattern ((Map Name Type) -> - (Map AltAttr Vertex) -> - Identifier -> - Attributes -> - Identifier -> - Attributes -> - ( Pattern,(Seq Error),([AltAttr]),([Name]),([Name]),([(Name,Name,Bool,Patterns)]))) -data Inh_Pattern = Inh_Pattern {allTypeSigs_Inh_Pattern :: Map Name Type,altAttrs_Inh_Pattern :: Map AltAttr Vertex,con_Inh_Pattern :: Identifier,inh_Inh_Pattern :: Attributes,nt_Inh_Pattern :: Identifier,syn_Inh_Pattern :: Attributes} -data Syn_Pattern = Syn_Pattern {copy_Syn_Pattern :: Pattern,errors_Syn_Pattern :: Seq Error,gathAltAttrs_Syn_Pattern :: [AltAttr],instVars_Syn_Pattern :: [Name],locVars_Syn_Pattern :: [Name],patternAttrs_Syn_Pattern :: [(Name,Name,Bool,Patterns)]} -wrap_Pattern (T_Pattern sem ) (Inh_Pattern _lhsIallTypeSigs _lhsIaltAttrs _lhsIcon _lhsIinh _lhsInt _lhsIsyn ) = - (let ( _lhsOcopy,_lhsOerrors,_lhsOgathAltAttrs,_lhsOinstVars,_lhsOlocVars,_lhsOpatternAttrs) = - (sem _lhsIallTypeSigs _lhsIaltAttrs _lhsIcon _lhsIinh _lhsInt _lhsIsyn ) - in (Syn_Pattern _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOlocVars _lhsOpatternAttrs )) -sem_Pattern_Alias :: Name -> - Name -> - T_Pattern -> - T_Patterns -> - T_Pattern -sem_Pattern_Alias field_ attr_ (T_Pattern pat_ ) (T_Patterns parts_ ) = - (T_Pattern (\ _lhsIallTypeSigs - _lhsIaltAttrs - _lhsIcon - _lhsIinh - _lhsInt - _lhsIsyn -> - (let _lhsOgathAltAttrs :: ([AltAttr]) - _lhsOpatternAttrs :: ([(Name,Name,Bool,Patterns)]) - _lhsOlocVars :: ([Name]) - _lhsOinstVars :: ([Name]) - _lhsOerrors :: (Seq Error) - _lhsOcopy :: Pattern - _patOallTypeSigs :: (Map Name Type) - _patOaltAttrs :: (Map AltAttr Vertex) - _patOcon :: Identifier - _patOinh :: Attributes - _patOnt :: Identifier - _patOsyn :: Attributes - _partsOallTypeSigs :: (Map Name Type) - _partsOaltAttrs :: (Map AltAttr Vertex) - _partsOcon :: Identifier - _partsOinh :: Attributes - _partsOnt :: Identifier - _partsOsyn :: Attributes - _patIcopy :: Pattern - _patIerrors :: (Seq Error) - _patIgathAltAttrs :: ([AltAttr]) - _patIinstVars :: ([Name]) - _patIlocVars :: ([Name]) - _patIpatternAttrs :: ([(Name,Name,Bool,Patterns)]) - _partsIcopy :: Patterns - _partsIerrors :: (Seq Error) - _partsIgathAltAttrs :: ([AltAttr]) - _partsIinstVars :: ([Name]) - _partsIlocVars :: ([Name]) - _partsIpatternAttrs :: ([(Name,Name,Bool,Patterns)]) - -- "Order.ag"(line 160, column 12) - _lhsOgathAltAttrs = - [AltAttr field_ attr_ (field_ == _LOC || field_ == _INST)] - -- "Order.ag"(line 227, column 12) - _lhsOpatternAttrs = - [(field_,attr_,(field_ == _LOC || field_ == _INST),_partsIcopy)] - -- "Order.ag"(line 536, column 14) - _lhsOlocVars = - if field_ == _LOC - then [attr_] - else [] - -- "Order.ag"(line 539, column 14) - _lhsOinstVars = - if field_ == _INST - then [attr_] - else [] - -- use rule "Order.ag"(line 60, column 70) - _lhsOerrors = - _patIerrors Seq.<> _partsIerrors - -- self rule - _copy = - Alias field_ attr_ _patIcopy _partsIcopy - -- self rule - _lhsOcopy = - _copy - -- copy rule (down) - _patOallTypeSigs = - _lhsIallTypeSigs - -- copy rule (down) - _patOaltAttrs = - _lhsIaltAttrs - -- copy rule (down) - _patOcon = - _lhsIcon - -- copy rule (down) - _patOinh = - _lhsIinh - -- copy rule (down) - _patOnt = - _lhsInt - -- copy rule (down) - _patOsyn = - _lhsIsyn - -- copy rule (down) - _partsOallTypeSigs = - _lhsIallTypeSigs - -- copy rule (down) - _partsOaltAttrs = - _lhsIaltAttrs - -- copy rule (down) - _partsOcon = - _lhsIcon - -- copy rule (down) - _partsOinh = - _lhsIinh - -- copy rule (down) - _partsOnt = - _lhsInt - -- copy rule (down) - _partsOsyn = - _lhsIsyn - ( _patIcopy,_patIerrors,_patIgathAltAttrs,_patIinstVars,_patIlocVars,_patIpatternAttrs) = - (pat_ _patOallTypeSigs _patOaltAttrs _patOcon _patOinh _patOnt _patOsyn ) - ( _partsIcopy,_partsIerrors,_partsIgathAltAttrs,_partsIinstVars,_partsIlocVars,_partsIpatternAttrs) = - (parts_ _partsOallTypeSigs _partsOaltAttrs _partsOcon _partsOinh _partsOnt _partsOsyn ) - in ( _lhsOcopy,_lhsOerrors,_lhsOgathAltAttrs,_lhsOinstVars,_lhsOlocVars,_lhsOpatternAttrs))) ) -sem_Pattern_Constr :: Constructor -> - T_Patterns -> - T_Pattern -sem_Pattern_Constr name_ (T_Patterns pats_ ) = - (T_Pattern (\ _lhsIallTypeSigs - _lhsIaltAttrs - _lhsIcon - _lhsIinh - _lhsInt - _lhsIsyn -> - (let _lhsOerrors :: (Seq Error) - _lhsOgathAltAttrs :: ([AltAttr]) - _lhsOinstVars :: ([Name]) - _lhsOlocVars :: ([Name]) - _lhsOpatternAttrs :: ([(Name,Name,Bool,Patterns)]) - _lhsOcopy :: Pattern - _patsOallTypeSigs :: (Map Name Type) - _patsOaltAttrs :: (Map AltAttr Vertex) - _patsOcon :: Identifier - _patsOinh :: Attributes - _patsOnt :: Identifier - _patsOsyn :: Attributes - _patsIcopy :: Patterns - _patsIerrors :: (Seq Error) - _patsIgathAltAttrs :: ([AltAttr]) - _patsIinstVars :: ([Name]) - _patsIlocVars :: ([Name]) - _patsIpatternAttrs :: ([(Name,Name,Bool,Patterns)]) - -- use rule "Order.ag"(line 60, column 70) - _lhsOerrors = - _patsIerrors - -- use rule "Order.ag"(line 146, column 68) - _lhsOgathAltAttrs = - _patsIgathAltAttrs - -- use rule "Order.ag"(line 533, column 80) - _lhsOinstVars = - _patsIinstVars - -- use rule "Order.ag"(line 533, column 48) - _lhsOlocVars = - _patsIlocVars - -- use rule "Order.ag"(line 224, column 42) - _lhsOpatternAttrs = - _patsIpatternAttrs - -- self rule - _copy = - Constr name_ _patsIcopy - -- self rule - _lhsOcopy = - _copy - -- copy rule (down) - _patsOallTypeSigs = - _lhsIallTypeSigs - -- copy rule (down) - _patsOaltAttrs = - _lhsIaltAttrs - -- copy rule (down) - _patsOcon = - _lhsIcon - -- copy rule (down) - _patsOinh = - _lhsIinh - -- copy rule (down) - _patsOnt = - _lhsInt - -- copy rule (down) - _patsOsyn = - _lhsIsyn - ( _patsIcopy,_patsIerrors,_patsIgathAltAttrs,_patsIinstVars,_patsIlocVars,_patsIpatternAttrs) = - (pats_ _patsOallTypeSigs _patsOaltAttrs _patsOcon _patsOinh _patsOnt _patsOsyn ) - in ( _lhsOcopy,_lhsOerrors,_lhsOgathAltAttrs,_lhsOinstVars,_lhsOlocVars,_lhsOpatternAttrs))) ) -sem_Pattern_Product :: Pos -> - T_Patterns -> - T_Pattern -sem_Pattern_Product pos_ (T_Patterns pats_ ) = - (T_Pattern (\ _lhsIallTypeSigs - _lhsIaltAttrs - _lhsIcon - _lhsIinh - _lhsInt - _lhsIsyn -> - (let _lhsOerrors :: (Seq Error) - _lhsOgathAltAttrs :: ([AltAttr]) - _lhsOinstVars :: ([Name]) - _lhsOlocVars :: ([Name]) - _lhsOpatternAttrs :: ([(Name,Name,Bool,Patterns)]) - _lhsOcopy :: Pattern - _patsOallTypeSigs :: (Map Name Type) - _patsOaltAttrs :: (Map AltAttr Vertex) - _patsOcon :: Identifier - _patsOinh :: Attributes - _patsOnt :: Identifier - _patsOsyn :: Attributes - _patsIcopy :: Patterns - _patsIerrors :: (Seq Error) - _patsIgathAltAttrs :: ([AltAttr]) - _patsIinstVars :: ([Name]) - _patsIlocVars :: ([Name]) - _patsIpatternAttrs :: ([(Name,Name,Bool,Patterns)]) - -- use rule "Order.ag"(line 60, column 70) - _lhsOerrors = - _patsIerrors - -- use rule "Order.ag"(line 146, column 68) - _lhsOgathAltAttrs = - _patsIgathAltAttrs - -- use rule "Order.ag"(line 533, column 80) - _lhsOinstVars = - _patsIinstVars - -- use rule "Order.ag"(line 533, column 48) - _lhsOlocVars = - _patsIlocVars - -- use rule "Order.ag"(line 224, column 42) - _lhsOpatternAttrs = - _patsIpatternAttrs - -- self rule - _copy = - Product pos_ _patsIcopy - -- self rule - _lhsOcopy = - _copy - -- copy rule (down) - _patsOallTypeSigs = - _lhsIallTypeSigs - -- copy rule (down) - _patsOaltAttrs = - _lhsIaltAttrs - -- copy rule (down) - _patsOcon = - _lhsIcon - -- copy rule (down) - _patsOinh = - _lhsIinh - -- copy rule (down) - _patsOnt = - _lhsInt - -- copy rule (down) - _patsOsyn = - _lhsIsyn - ( _patsIcopy,_patsIerrors,_patsIgathAltAttrs,_patsIinstVars,_patsIlocVars,_patsIpatternAttrs) = - (pats_ _patsOallTypeSigs _patsOaltAttrs _patsOcon _patsOinh _patsOnt _patsOsyn ) - in ( _lhsOcopy,_lhsOerrors,_lhsOgathAltAttrs,_lhsOinstVars,_lhsOlocVars,_lhsOpatternAttrs))) ) -sem_Pattern_Underscore :: Pos -> - T_Pattern -sem_Pattern_Underscore pos_ = - (T_Pattern (\ _lhsIallTypeSigs - _lhsIaltAttrs - _lhsIcon - _lhsIinh - _lhsInt - _lhsIsyn -> - (let _lhsOerrors :: (Seq Error) - _lhsOgathAltAttrs :: ([AltAttr]) - _lhsOinstVars :: ([Name]) - _lhsOlocVars :: ([Name]) - _lhsOpatternAttrs :: ([(Name,Name,Bool,Patterns)]) - _lhsOcopy :: Pattern - -- use rule "Order.ag"(line 60, column 70) - _lhsOerrors = - Seq.empty - -- use rule "Order.ag"(line 146, column 68) - _lhsOgathAltAttrs = - [] - -- use rule "Order.ag"(line 533, column 80) - _lhsOinstVars = - [] - -- use rule "Order.ag"(line 533, column 48) - _lhsOlocVars = - [] - -- use rule "Order.ag"(line 224, column 42) - _lhsOpatternAttrs = - [] - -- self rule - _copy = - Underscore pos_ - -- self rule - _lhsOcopy = - _copy - in ( _lhsOcopy,_lhsOerrors,_lhsOgathAltAttrs,_lhsOinstVars,_lhsOlocVars,_lhsOpatternAttrs))) ) --- Patterns ---------------------------------------------------- -{- - visit 0: - inherited attributes: - allTypeSigs : Map Name Type - altAttrs : Map AltAttr Vertex - con : Identifier - inh : Attributes - nt : Identifier - syn : Attributes - synthesized attributes: - copy : SELF - errors : Seq Error - gathAltAttrs : [AltAttr] - instVars : [Name] - locVars : [Name] - patternAttrs : [(Name,Name,Bool,Patterns)] - alternatives: - alternative Cons: - child hd : Pattern - child tl : Patterns - visit 0: - local copy : _ - alternative Nil: - visit 0: - local copy : _ --} --- cata -sem_Patterns :: Patterns -> - T_Patterns -sem_Patterns list = - (Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list) ) --- semantic domain -newtype T_Patterns = T_Patterns ((Map Name Type) -> - (Map AltAttr Vertex) -> - Identifier -> - Attributes -> - Identifier -> - Attributes -> - ( Patterns,(Seq Error),([AltAttr]),([Name]),([Name]),([(Name,Name,Bool,Patterns)]))) -data Inh_Patterns = Inh_Patterns {allTypeSigs_Inh_Patterns :: Map Name Type,altAttrs_Inh_Patterns :: Map AltAttr Vertex,con_Inh_Patterns :: Identifier,inh_Inh_Patterns :: Attributes,nt_Inh_Patterns :: Identifier,syn_Inh_Patterns :: Attributes} -data Syn_Patterns = Syn_Patterns {copy_Syn_Patterns :: Patterns,errors_Syn_Patterns :: Seq Error,gathAltAttrs_Syn_Patterns :: [AltAttr],instVars_Syn_Patterns :: [Name],locVars_Syn_Patterns :: [Name],patternAttrs_Syn_Patterns :: [(Name,Name,Bool,Patterns)]} -wrap_Patterns (T_Patterns sem ) (Inh_Patterns _lhsIallTypeSigs _lhsIaltAttrs _lhsIcon _lhsIinh _lhsInt _lhsIsyn ) = - (let ( _lhsOcopy,_lhsOerrors,_lhsOgathAltAttrs,_lhsOinstVars,_lhsOlocVars,_lhsOpatternAttrs) = - (sem _lhsIallTypeSigs _lhsIaltAttrs _lhsIcon _lhsIinh _lhsInt _lhsIsyn ) - in (Syn_Patterns _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOlocVars _lhsOpatternAttrs )) -sem_Patterns_Cons :: T_Pattern -> - T_Patterns -> - T_Patterns -sem_Patterns_Cons (T_Pattern hd_ ) (T_Patterns tl_ ) = - (T_Patterns (\ _lhsIallTypeSigs - _lhsIaltAttrs - _lhsIcon - _lhsIinh - _lhsInt - _lhsIsyn -> - (let _lhsOerrors :: (Seq Error) - _lhsOgathAltAttrs :: ([AltAttr]) - _lhsOinstVars :: ([Name]) - _lhsOlocVars :: ([Name]) - _lhsOpatternAttrs :: ([(Name,Name,Bool,Patterns)]) - _lhsOcopy :: Patterns - _hdOallTypeSigs :: (Map Name Type) - _hdOaltAttrs :: (Map AltAttr Vertex) - _hdOcon :: Identifier - _hdOinh :: Attributes - _hdOnt :: Identifier - _hdOsyn :: Attributes - _tlOallTypeSigs :: (Map Name Type) - _tlOaltAttrs :: (Map AltAttr Vertex) - _tlOcon :: Identifier - _tlOinh :: Attributes - _tlOnt :: Identifier - _tlOsyn :: Attributes - _hdIcopy :: Pattern - _hdIerrors :: (Seq Error) - _hdIgathAltAttrs :: ([AltAttr]) - _hdIinstVars :: ([Name]) - _hdIlocVars :: ([Name]) - _hdIpatternAttrs :: ([(Name,Name,Bool,Patterns)]) - _tlIcopy :: Patterns - _tlIerrors :: (Seq Error) - _tlIgathAltAttrs :: ([AltAttr]) - _tlIinstVars :: ([Name]) - _tlIlocVars :: ([Name]) - _tlIpatternAttrs :: ([(Name,Name,Bool,Patterns)]) - -- use rule "Order.ag"(line 60, column 70) - _lhsOerrors = - _hdIerrors Seq.<> _tlIerrors - -- use rule "Order.ag"(line 146, column 68) - _lhsOgathAltAttrs = - _hdIgathAltAttrs ++ _tlIgathAltAttrs - -- use rule "Order.ag"(line 533, column 80) - _lhsOinstVars = - _hdIinstVars ++ _tlIinstVars - -- use rule "Order.ag"(line 533, column 48) - _lhsOlocVars = - _hdIlocVars ++ _tlIlocVars - -- use rule "Order.ag"(line 224, column 42) - _lhsOpatternAttrs = - _hdIpatternAttrs ++ _tlIpatternAttrs - -- self rule - _copy = - (:) _hdIcopy _tlIcopy - -- self rule - _lhsOcopy = - _copy - -- copy rule (down) - _hdOallTypeSigs = - _lhsIallTypeSigs - -- copy rule (down) - _hdOaltAttrs = - _lhsIaltAttrs - -- copy rule (down) - _hdOcon = - _lhsIcon - -- copy rule (down) - _hdOinh = - _lhsIinh - -- copy rule (down) - _hdOnt = - _lhsInt - -- copy rule (down) - _hdOsyn = - _lhsIsyn - -- copy rule (down) - _tlOallTypeSigs = - _lhsIallTypeSigs - -- copy rule (down) - _tlOaltAttrs = - _lhsIaltAttrs - -- copy rule (down) - _tlOcon = - _lhsIcon - -- copy rule (down) - _tlOinh = - _lhsIinh - -- copy rule (down) - _tlOnt = - _lhsInt - -- copy rule (down) - _tlOsyn = - _lhsIsyn - ( _hdIcopy,_hdIerrors,_hdIgathAltAttrs,_hdIinstVars,_hdIlocVars,_hdIpatternAttrs) = - (hd_ _hdOallTypeSigs _hdOaltAttrs _hdOcon _hdOinh _hdOnt _hdOsyn ) - ( _tlIcopy,_tlIerrors,_tlIgathAltAttrs,_tlIinstVars,_tlIlocVars,_tlIpatternAttrs) = - (tl_ _tlOallTypeSigs _tlOaltAttrs _tlOcon _tlOinh _tlOnt _tlOsyn ) - in ( _lhsOcopy,_lhsOerrors,_lhsOgathAltAttrs,_lhsOinstVars,_lhsOlocVars,_lhsOpatternAttrs))) ) -sem_Patterns_Nil :: T_Patterns -sem_Patterns_Nil = - (T_Patterns (\ _lhsIallTypeSigs - _lhsIaltAttrs - _lhsIcon - _lhsIinh - _lhsInt - _lhsIsyn -> - (let _lhsOerrors :: (Seq Error) - _lhsOgathAltAttrs :: ([AltAttr]) - _lhsOinstVars :: ([Name]) - _lhsOlocVars :: ([Name]) - _lhsOpatternAttrs :: ([(Name,Name,Bool,Patterns)]) - _lhsOcopy :: Patterns - -- use rule "Order.ag"(line 60, column 70) - _lhsOerrors = - Seq.empty - -- use rule "Order.ag"(line 146, column 68) - _lhsOgathAltAttrs = - [] - -- use rule "Order.ag"(line 533, column 80) - _lhsOinstVars = - [] - -- use rule "Order.ag"(line 533, column 48) - _lhsOlocVars = - [] - -- use rule "Order.ag"(line 224, column 42) - _lhsOpatternAttrs = - [] - -- self rule - _copy = - [] - -- self rule - _lhsOcopy = - _copy - in ( _lhsOcopy,_lhsOerrors,_lhsOgathAltAttrs,_lhsOinstVars,_lhsOlocVars,_lhsOpatternAttrs))) ) --- Production -------------------------------------------------- -{- - visit 0: - inherited attributes: - allnts : [Name] - cInterfaceMap : CInterfaceMap - cVisitsMap : CVisitsMap - manualAttrDepMap : AttrOrderMap - o_case : Bool - o_cata : Bool - o_data : Bool - o_dovisit : Bool - o_newtypes : Bool - o_rename : Bool - o_sem : Bool - o_sig : Bool - o_unbox : Bool - o_wantvisit : Bool - prefix : String - chained attributes: - acount : Int - vcount : Int - synthesized attributes: - additionalDep : Seq Edge - aranges : Seq (Int,Int,Int) - cProduction : CProduction - directDep : Seq Edge - errors : Seq Error - instDep : Seq Edge - ntattrs : Seq (Vertex,NTAttr) - prods : [(Nonterminal,[Constructor])] - rules : Seq (Vertex,CRule) - alternatives: - alternative Production: - child nt : {Nonterminal} - child inh : {Attributes} - child syn : {Attributes} - child alts : Alternatives - visit 0: - local ntattrs : _ - local cInter : _ --} --- cata -sem_Production :: Production -> - T_Production -sem_Production (Production _nt _inh _syn _alts ) = - (sem_Production_Production _nt _inh _syn (sem_Alternatives _alts ) ) --- semantic domain -newtype T_Production = T_Production (Int -> - ([Name]) -> - CInterfaceMap -> - CVisitsMap -> - AttrOrderMap -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - String -> - Int -> - ( Int,(Seq Edge),(Seq (Int,Int,Int)),CProduction,(Seq Edge),(Seq Error),(Seq Edge),(Seq (Vertex,NTAttr)),([(Nonterminal,[Constructor])]),(Seq (Vertex,CRule)),Int)) -data Inh_Production = Inh_Production {acount_Inh_Production :: Int,allnts_Inh_Production :: [Name],cInterfaceMap_Inh_Production :: CInterfaceMap,cVisitsMap_Inh_Production :: CVisitsMap,manualAttrDepMap_Inh_Production :: AttrOrderMap,o_case_Inh_Production :: Bool,o_cata_Inh_Production :: Bool,o_data_Inh_Production :: Bool,o_dovisit_Inh_Production :: Bool,o_newtypes_Inh_Production :: Bool,o_rename_Inh_Production :: Bool,o_sem_Inh_Production :: Bool,o_sig_Inh_Production :: Bool,o_unbox_Inh_Production :: Bool,o_wantvisit_Inh_Production :: Bool,prefix_Inh_Production :: String,vcount_Inh_Production :: Int} -data Syn_Production = Syn_Production {acount_Syn_Production :: Int,additionalDep_Syn_Production :: Seq Edge,aranges_Syn_Production :: Seq (Int,Int,Int),cProduction_Syn_Production :: CProduction,directDep_Syn_Production :: Seq Edge,errors_Syn_Production :: Seq Error,instDep_Syn_Production :: Seq Edge,ntattrs_Syn_Production :: Seq (Vertex,NTAttr),prods_Syn_Production :: [(Nonterminal,[Constructor])],rules_Syn_Production :: Seq (Vertex,CRule),vcount_Syn_Production :: Int} -wrap_Production (T_Production sem ) (Inh_Production _lhsIacount _lhsIallnts _lhsIcInterfaceMap _lhsIcVisitsMap _lhsImanualAttrDepMap _lhsIo_case _lhsIo_cata _lhsIo_data _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIvcount ) = - (let ( _lhsOacount,_lhsOadditionalDep,_lhsOaranges,_lhsOcProduction,_lhsOdirectDep,_lhsOerrors,_lhsOinstDep,_lhsOntattrs,_lhsOprods,_lhsOrules,_lhsOvcount) = - (sem _lhsIacount _lhsIallnts _lhsIcInterfaceMap _lhsIcVisitsMap _lhsImanualAttrDepMap _lhsIo_case _lhsIo_cata _lhsIo_data _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIvcount ) - in (Syn_Production _lhsOacount _lhsOadditionalDep _lhsOaranges _lhsOcProduction _lhsOdirectDep _lhsOerrors _lhsOinstDep _lhsOntattrs _lhsOprods _lhsOrules _lhsOvcount )) -sem_Production_Production :: Nonterminal -> - Attributes -> - Attributes -> - T_Alternatives -> - T_Production -sem_Production_Production nt_ inh_ syn_ (T_Alternatives alts_ ) = - (T_Production (\ _lhsIacount - _lhsIallnts - _lhsIcInterfaceMap - _lhsIcVisitsMap - _lhsImanualAttrDepMap - _lhsIo_case - _lhsIo_cata - _lhsIo_data - _lhsIo_dovisit - _lhsIo_newtypes - _lhsIo_rename - _lhsIo_sem - _lhsIo_sig - _lhsIo_unbox - _lhsIo_wantvisit - _lhsIprefix - _lhsIvcount -> - (let _altsOnt :: Identifier - _altsOinh :: Attributes - _altsOsyn :: Attributes - _lhsOntattrs :: (Seq (Vertex,NTAttr)) - _lhsOacount :: Int - _lhsOaranges :: (Seq (Int,Int,Int)) - _lhsOprods :: ([(Nonterminal,[Constructor])]) - _lhsOcProduction :: CProduction - _lhsOadditionalDep :: (Seq Edge) - _lhsOdirectDep :: (Seq Edge) - _lhsOerrors :: (Seq Error) - _lhsOinstDep :: (Seq Edge) - _lhsOrules :: (Seq (Vertex,CRule)) - _lhsOvcount :: Int - _altsOallnts :: ([Name]) - _altsOcVisitsMap :: CVisitsMap - _altsOmanualAttrDepMap :: AttrOrderMap - _altsOo_case :: Bool - _altsOo_cata :: Bool - _altsOo_dovisit :: Bool - _altsOo_newtypes :: Bool - _altsOo_rename :: Bool - _altsOo_sem :: Bool - _altsOo_sig :: Bool - _altsOo_unbox :: Bool - _altsOo_wantvisit :: Bool - _altsOprefix :: String - _altsOvcount :: Int - _altsIadditionalDep :: (Seq Edge) - _altsIcAlternatives :: CAlternatives - _altsIcons :: ([Constructor]) - _altsIdirectDep :: (Seq Edge) - _altsIerrors :: (Seq Error) - _altsIinstDep :: (Seq Edge) - _altsIrules :: (Seq (Vertex,CRule)) - _altsIvcount :: Int - -- "Order.ag"(line 73, column 16) - _altsOnt = - nt_ - -- "Order.ag"(line 76, column 16) - _altsOinh = - inh_ - -- "Order.ag"(line 77, column 16) - _altsOsyn = - syn_ - -- "Order.ag"(line 368, column 16) - _ntattrs = - [ NTAInh nt_ inh tp | (inh,tp) <- Map.assocs inh_ ] - ++ [NTASyn nt_ syn tp | (syn,tp) <- Map.assocs syn_ ] - -- "Order.ag"(line 370, column 16) - _lhsOntattrs = - Seq.fromList (zip [_lhsIacount ..] _ntattrs) - -- "Order.ag"(line 371, column 16) - _lhsOacount = - _lhsIacount + Map.size inh_ + Map.size syn_ - -- "Order.ag"(line 372, column 16) - _lhsOaranges = - Seq.single - (_lhsIacount - ,_lhsIacount + Map.size inh_ - ,_lhsIacount + Map.size syn_ + Map.size inh_ - 1) - -- "Order.ag"(line 381, column 18) - _lhsOprods = - [(nt_,_altsIcons)] - -- "Order.ag"(line 456, column 18) - _cInter = - if _lhsIo_dovisit - then findWithErr1 "Production.cInter" nt_ _lhsIcInterfaceMap - else CInterface [CSegment inh_ syn_] - -- "Order.ag"(line 484, column 18) - _lhsOcProduction = - CProduction nt_ inh_ syn_ _altsIcAlternatives _cInter - -- use rule "Order.ag"(line 258, column 71) - _lhsOadditionalDep = - _altsIadditionalDep - -- use rule "Order.ag"(line 244, column 33) - _lhsOdirectDep = - _altsIdirectDep - -- use rule "Order.ag"(line 60, column 70) - _lhsOerrors = - _altsIerrors - -- use rule "Order.ag"(line 289, column 31) - _lhsOinstDep = - _altsIinstDep - -- use rule "Order.ag"(line 234, column 18) - _lhsOrules = - _altsIrules - -- copy rule (up) - _lhsOvcount = - _altsIvcount - -- copy rule (down) - _altsOallnts = - _lhsIallnts - -- copy rule (down) - _altsOcVisitsMap = - _lhsIcVisitsMap - -- copy rule (down) - _altsOmanualAttrDepMap = - _lhsImanualAttrDepMap - -- copy rule (down) - _altsOo_case = - _lhsIo_case - -- copy rule (down) - _altsOo_cata = - _lhsIo_cata - -- copy rule (down) - _altsOo_dovisit = - _lhsIo_dovisit - -- copy rule (down) - _altsOo_newtypes = - _lhsIo_newtypes - -- copy rule (down) - _altsOo_rename = - _lhsIo_rename - -- copy rule (down) - _altsOo_sem = - _lhsIo_sem - -- copy rule (down) - _altsOo_sig = - _lhsIo_sig - -- copy rule (down) - _altsOo_unbox = - _lhsIo_unbox - -- copy rule (down) - _altsOo_wantvisit = - _lhsIo_wantvisit - -- copy rule (down) - _altsOprefix = - _lhsIprefix - -- copy rule (down) - _altsOvcount = - _lhsIvcount - ( _altsIadditionalDep,_altsIcAlternatives,_altsIcons,_altsIdirectDep,_altsIerrors,_altsIinstDep,_altsIrules,_altsIvcount) = - (alts_ _altsOallnts _altsOcVisitsMap _altsOinh _altsOmanualAttrDepMap _altsOnt _altsOo_case _altsOo_cata _altsOo_dovisit _altsOo_newtypes _altsOo_rename _altsOo_sem _altsOo_sig _altsOo_unbox _altsOo_wantvisit _altsOprefix _altsOsyn _altsOvcount ) - in ( _lhsOacount,_lhsOadditionalDep,_lhsOaranges,_lhsOcProduction,_lhsOdirectDep,_lhsOerrors,_lhsOinstDep,_lhsOntattrs,_lhsOprods,_lhsOrules,_lhsOvcount))) ) --- Productions ------------------------------------------------- -{- - visit 0: - inherited attributes: - allnts : [Name] - cInterfaceMap : CInterfaceMap - cVisitsMap : CVisitsMap - manualAttrDepMap : AttrOrderMap - o_case : Bool - o_cata : Bool - o_data : Bool - o_dovisit : Bool - o_newtypes : Bool - o_rename : Bool - o_sem : Bool - o_sig : Bool - o_unbox : Bool - o_wantvisit : Bool - prefix : String - chained attributes: - acount : Int - vcount : Int - synthesized attributes: - additionalDep : Seq Edge - aranges : Seq (Int,Int,Int) - cProductions : CProductions - directDep : Seq Edge - errors : Seq Error - instDep : Seq Edge - ntattrs : Seq (Vertex,NTAttr) - prods : [(Nonterminal,[Constructor])] - rules : Seq (Vertex,CRule) - alternatives: - alternative Cons: - child hd : Production - child tl : Productions - alternative Nil: --} --- cata -sem_Productions :: Productions -> - T_Productions -sem_Productions list = - (Prelude.foldr sem_Productions_Cons sem_Productions_Nil (Prelude.map sem_Production list) ) --- semantic domain -newtype T_Productions = T_Productions (Int -> - ([Name]) -> - CInterfaceMap -> - CVisitsMap -> - AttrOrderMap -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - String -> - Int -> - ( Int,(Seq Edge),(Seq (Int,Int,Int)),CProductions,(Seq Edge),(Seq Error),(Seq Edge),(Seq (Vertex,NTAttr)),([(Nonterminal,[Constructor])]),(Seq (Vertex,CRule)),Int)) -data Inh_Productions = Inh_Productions {acount_Inh_Productions :: Int,allnts_Inh_Productions :: [Name],cInterfaceMap_Inh_Productions :: CInterfaceMap,cVisitsMap_Inh_Productions :: CVisitsMap,manualAttrDepMap_Inh_Productions :: AttrOrderMap,o_case_Inh_Productions :: Bool,o_cata_Inh_Productions :: Bool,o_data_Inh_Productions :: Bool,o_dovisit_Inh_Productions :: Bool,o_newtypes_Inh_Productions :: Bool,o_rename_Inh_Productions :: Bool,o_sem_Inh_Productions :: Bool,o_sig_Inh_Productions :: Bool,o_unbox_Inh_Productions :: Bool,o_wantvisit_Inh_Productions :: Bool,prefix_Inh_Productions :: String,vcount_Inh_Productions :: Int} -data Syn_Productions = Syn_Productions {acount_Syn_Productions :: Int,additionalDep_Syn_Productions :: Seq Edge,aranges_Syn_Productions :: Seq (Int,Int,Int),cProductions_Syn_Productions :: CProductions,directDep_Syn_Productions :: Seq Edge,errors_Syn_Productions :: Seq Error,instDep_Syn_Productions :: Seq Edge,ntattrs_Syn_Productions :: Seq (Vertex,NTAttr),prods_Syn_Productions :: [(Nonterminal,[Constructor])],rules_Syn_Productions :: Seq (Vertex,CRule),vcount_Syn_Productions :: Int} -wrap_Productions (T_Productions sem ) (Inh_Productions _lhsIacount _lhsIallnts _lhsIcInterfaceMap _lhsIcVisitsMap _lhsImanualAttrDepMap _lhsIo_case _lhsIo_cata _lhsIo_data _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIvcount ) = - (let ( _lhsOacount,_lhsOadditionalDep,_lhsOaranges,_lhsOcProductions,_lhsOdirectDep,_lhsOerrors,_lhsOinstDep,_lhsOntattrs,_lhsOprods,_lhsOrules,_lhsOvcount) = - (sem _lhsIacount _lhsIallnts _lhsIcInterfaceMap _lhsIcVisitsMap _lhsImanualAttrDepMap _lhsIo_case _lhsIo_cata _lhsIo_data _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIvcount ) - in (Syn_Productions _lhsOacount _lhsOadditionalDep _lhsOaranges _lhsOcProductions _lhsOdirectDep _lhsOerrors _lhsOinstDep _lhsOntattrs _lhsOprods _lhsOrules _lhsOvcount )) -sem_Productions_Cons :: T_Production -> - T_Productions -> - T_Productions -sem_Productions_Cons (T_Production hd_ ) (T_Productions tl_ ) = - (T_Productions (\ _lhsIacount - _lhsIallnts - _lhsIcInterfaceMap - _lhsIcVisitsMap - _lhsImanualAttrDepMap - _lhsIo_case - _lhsIo_cata - _lhsIo_data - _lhsIo_dovisit - _lhsIo_newtypes - _lhsIo_rename - _lhsIo_sem - _lhsIo_sig - _lhsIo_unbox - _lhsIo_wantvisit - _lhsIprefix - _lhsIvcount -> - (let _lhsOcProductions :: CProductions - _lhsOadditionalDep :: (Seq Edge) - _lhsOaranges :: (Seq (Int,Int,Int)) - _lhsOdirectDep :: (Seq Edge) - _lhsOerrors :: (Seq Error) - _lhsOinstDep :: (Seq Edge) - _lhsOntattrs :: (Seq (Vertex,NTAttr)) - _lhsOprods :: ([(Nonterminal,[Constructor])]) - _lhsOrules :: (Seq (Vertex,CRule)) - _lhsOacount :: Int - _lhsOvcount :: Int - _hdOacount :: Int - _hdOallnts :: ([Name]) - _hdOcInterfaceMap :: CInterfaceMap - _hdOcVisitsMap :: CVisitsMap - _hdOmanualAttrDepMap :: AttrOrderMap - _hdOo_case :: Bool - _hdOo_cata :: Bool - _hdOo_data :: Bool - _hdOo_dovisit :: Bool - _hdOo_newtypes :: Bool - _hdOo_rename :: Bool - _hdOo_sem :: Bool - _hdOo_sig :: Bool - _hdOo_unbox :: Bool - _hdOo_wantvisit :: Bool - _hdOprefix :: String - _hdOvcount :: Int - _tlOacount :: Int - _tlOallnts :: ([Name]) - _tlOcInterfaceMap :: CInterfaceMap - _tlOcVisitsMap :: CVisitsMap - _tlOmanualAttrDepMap :: AttrOrderMap - _tlOo_case :: Bool - _tlOo_cata :: Bool - _tlOo_data :: Bool - _tlOo_dovisit :: Bool - _tlOo_newtypes :: Bool - _tlOo_rename :: Bool - _tlOo_sem :: Bool - _tlOo_sig :: Bool - _tlOo_unbox :: Bool - _tlOo_wantvisit :: Bool - _tlOprefix :: String - _tlOvcount :: Int - _hdIacount :: Int - _hdIadditionalDep :: (Seq Edge) - _hdIaranges :: (Seq (Int,Int,Int)) - _hdIcProduction :: CProduction - _hdIdirectDep :: (Seq Edge) - _hdIerrors :: (Seq Error) - _hdIinstDep :: (Seq Edge) - _hdIntattrs :: (Seq (Vertex,NTAttr)) - _hdIprods :: ([(Nonterminal,[Constructor])]) - _hdIrules :: (Seq (Vertex,CRule)) - _hdIvcount :: Int - _tlIacount :: Int - _tlIadditionalDep :: (Seq Edge) - _tlIaranges :: (Seq (Int,Int,Int)) - _tlIcProductions :: CProductions - _tlIdirectDep :: (Seq Edge) - _tlIerrors :: (Seq Error) - _tlIinstDep :: (Seq Edge) - _tlIntattrs :: (Seq (Vertex,NTAttr)) - _tlIprods :: ([(Nonterminal,[Constructor])]) - _tlIrules :: (Seq (Vertex,CRule)) - _tlIvcount :: Int - -- "Order.ag"(line 481, column 12) - _lhsOcProductions = - _hdIcProduction : _tlIcProductions - -- use rule "Order.ag"(line 258, column 71) - _lhsOadditionalDep = - _hdIadditionalDep Seq.<> _tlIadditionalDep - -- use rule "Order.ag"(line 362, column 36) - _lhsOaranges = - _hdIaranges Seq.<> _tlIaranges - -- use rule "Order.ag"(line 244, column 33) - _lhsOdirectDep = - _hdIdirectDep Seq.<> _tlIdirectDep - -- use rule "Order.ag"(line 60, column 70) - _lhsOerrors = - _hdIerrors Seq.<> _tlIerrors - -- use rule "Order.ag"(line 289, column 31) - _lhsOinstDep = - _hdIinstDep Seq.<> _tlIinstDep - -- use rule "Order.ag"(line 361, column 35) - _lhsOntattrs = - _hdIntattrs Seq.<> _tlIntattrs - -- use rule "Order.ag"(line 379, column 41) - _lhsOprods = - _hdIprods ++ _tlIprods - -- use rule "Order.ag"(line 234, column 18) - _lhsOrules = - _hdIrules Seq.<> _tlIrules - -- copy rule (up) - _lhsOacount = - _tlIacount - -- copy rule (up) - _lhsOvcount = - _tlIvcount - -- copy rule (down) - _hdOacount = - _lhsIacount - -- copy rule (down) - _hdOallnts = - _lhsIallnts - -- copy rule (down) - _hdOcInterfaceMap = - _lhsIcInterfaceMap - -- copy rule (down) - _hdOcVisitsMap = - _lhsIcVisitsMap - -- copy rule (down) - _hdOmanualAttrDepMap = - _lhsImanualAttrDepMap - -- copy rule (down) - _hdOo_case = - _lhsIo_case - -- copy rule (down) - _hdOo_cata = - _lhsIo_cata - -- copy rule (down) - _hdOo_data = - _lhsIo_data - -- copy rule (down) - _hdOo_dovisit = - _lhsIo_dovisit - -- copy rule (down) - _hdOo_newtypes = - _lhsIo_newtypes - -- copy rule (down) - _hdOo_rename = - _lhsIo_rename - -- copy rule (down) - _hdOo_sem = - _lhsIo_sem - -- copy rule (down) - _hdOo_sig = - _lhsIo_sig - -- copy rule (down) - _hdOo_unbox = - _lhsIo_unbox - -- copy rule (down) - _hdOo_wantvisit = - _lhsIo_wantvisit - -- copy rule (down) - _hdOprefix = - _lhsIprefix - -- copy rule (down) - _hdOvcount = - _lhsIvcount - -- copy rule (chain) - _tlOacount = - _hdIacount - -- copy rule (down) - _tlOallnts = - _lhsIallnts - -- copy rule (down) - _tlOcInterfaceMap = - _lhsIcInterfaceMap - -- copy rule (down) - _tlOcVisitsMap = - _lhsIcVisitsMap - -- copy rule (down) - _tlOmanualAttrDepMap = - _lhsImanualAttrDepMap - -- copy rule (down) - _tlOo_case = - _lhsIo_case - -- copy rule (down) - _tlOo_cata = - _lhsIo_cata - -- copy rule (down) - _tlOo_data = - _lhsIo_data - -- copy rule (down) - _tlOo_dovisit = - _lhsIo_dovisit - -- copy rule (down) - _tlOo_newtypes = - _lhsIo_newtypes - -- copy rule (down) - _tlOo_rename = - _lhsIo_rename - -- copy rule (down) - _tlOo_sem = - _lhsIo_sem - -- copy rule (down) - _tlOo_sig = - _lhsIo_sig - -- copy rule (down) - _tlOo_unbox = - _lhsIo_unbox - -- copy rule (down) - _tlOo_wantvisit = - _lhsIo_wantvisit - -- copy rule (down) - _tlOprefix = - _lhsIprefix - -- copy rule (chain) - _tlOvcount = - _hdIvcount - ( _hdIacount,_hdIadditionalDep,_hdIaranges,_hdIcProduction,_hdIdirectDep,_hdIerrors,_hdIinstDep,_hdIntattrs,_hdIprods,_hdIrules,_hdIvcount) = - (hd_ _hdOacount _hdOallnts _hdOcInterfaceMap _hdOcVisitsMap _hdOmanualAttrDepMap _hdOo_case _hdOo_cata _hdOo_data _hdOo_dovisit _hdOo_newtypes _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_unbox _hdOo_wantvisit _hdOprefix _hdOvcount ) - ( _tlIacount,_tlIadditionalDep,_tlIaranges,_tlIcProductions,_tlIdirectDep,_tlIerrors,_tlIinstDep,_tlIntattrs,_tlIprods,_tlIrules,_tlIvcount) = - (tl_ _tlOacount _tlOallnts _tlOcInterfaceMap _tlOcVisitsMap _tlOmanualAttrDepMap _tlOo_case _tlOo_cata _tlOo_data _tlOo_dovisit _tlOo_newtypes _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_unbox _tlOo_wantvisit _tlOprefix _tlOvcount ) - in ( _lhsOacount,_lhsOadditionalDep,_lhsOaranges,_lhsOcProductions,_lhsOdirectDep,_lhsOerrors,_lhsOinstDep,_lhsOntattrs,_lhsOprods,_lhsOrules,_lhsOvcount))) ) -sem_Productions_Nil :: T_Productions -sem_Productions_Nil = - (T_Productions (\ _lhsIacount - _lhsIallnts - _lhsIcInterfaceMap - _lhsIcVisitsMap - _lhsImanualAttrDepMap - _lhsIo_case - _lhsIo_cata - _lhsIo_data - _lhsIo_dovisit - _lhsIo_newtypes - _lhsIo_rename - _lhsIo_sem - _lhsIo_sig - _lhsIo_unbox - _lhsIo_wantvisit - _lhsIprefix - _lhsIvcount -> - (let _lhsOcProductions :: CProductions - _lhsOadditionalDep :: (Seq Edge) - _lhsOaranges :: (Seq (Int,Int,Int)) - _lhsOdirectDep :: (Seq Edge) - _lhsOerrors :: (Seq Error) - _lhsOinstDep :: (Seq Edge) - _lhsOntattrs :: (Seq (Vertex,NTAttr)) - _lhsOprods :: ([(Nonterminal,[Constructor])]) - _lhsOrules :: (Seq (Vertex,CRule)) - _lhsOacount :: Int - _lhsOvcount :: Int - -- "Order.ag"(line 482, column 12) - _lhsOcProductions = - [] - -- use rule "Order.ag"(line 258, column 71) - _lhsOadditionalDep = - Seq.empty - -- use rule "Order.ag"(line 362, column 36) - _lhsOaranges = - Seq.empty - -- use rule "Order.ag"(line 244, column 33) - _lhsOdirectDep = - Seq.empty - -- use rule "Order.ag"(line 60, column 70) - _lhsOerrors = - Seq.empty - -- use rule "Order.ag"(line 289, column 31) - _lhsOinstDep = - Seq.empty - -- use rule "Order.ag"(line 361, column 35) - _lhsOntattrs = - Seq.empty - -- use rule "Order.ag"(line 379, column 41) - _lhsOprods = - [] - -- use rule "Order.ag"(line 234, column 18) - _lhsOrules = - Seq.empty - -- copy rule (chain) - _lhsOacount = - _lhsIacount - -- copy rule (chain) - _lhsOvcount = - _lhsIvcount - in ( _lhsOacount,_lhsOadditionalDep,_lhsOaranges,_lhsOcProductions,_lhsOdirectDep,_lhsOerrors,_lhsOinstDep,_lhsOntattrs,_lhsOprods,_lhsOrules,_lhsOvcount))) ) --- Rule -------------------------------------------------------- -{- - visit 0: - inherited attributes: - allTypeSigs : Map Name Type - allfields : [(Name,Type,Bool)] - allnts : [Name] - altAttrs : Map AltAttr Vertex - attrs : [(Name,Name)] - childInhs : Map Name Attributes - childNts : Map Name Nonterminal - con : Identifier - inh : Attributes - manualAttrDepMap : AttrOrderMap - nt : Identifier - o_case : Bool - o_cata : Bool - o_dovisit : Bool - o_newtypes : Bool - o_rename : Bool - o_sem : Bool - o_sig : Bool - o_wantvisit : Bool - prefix : String - syn : Attributes - synsOfChildren : Map Name Attributes - synthesized attributes: - additionalDep : Seq Edge - directDep : Seq Edge - errors : Seq Error - gathAltAttrs : [AltAttr] - gathRules : Seq CRule - instDep : Seq Edge - instVars : [Name] - locVars : [Name] - alternatives: - alternative Rule: - child pattern : Pattern - child rhs : Expression - child owrt : {Bool} - child origin : {String} - visit 0: - local defines : _ - local gathRules : _ - local manualDeps : _ --} --- cata -sem_Rule :: Rule -> - T_Rule -sem_Rule (Rule _pattern _rhs _owrt _origin ) = - (sem_Rule_Rule (sem_Pattern _pattern ) (sem_Expression _rhs ) _owrt _origin ) --- semantic domain -newtype T_Rule = T_Rule ((Map Name Type) -> - ([(Name,Type,Bool)]) -> - ([Name]) -> - (Map AltAttr Vertex) -> - ([(Name,Name)]) -> - (Map Name Attributes) -> - (Map Name Nonterminal) -> - Identifier -> - Attributes -> - AttrOrderMap -> - Identifier -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - String -> - Attributes -> - (Map Name Attributes) -> - ( (Seq Edge),(Seq Edge),(Seq Error),([AltAttr]),(Seq CRule),(Seq Edge),([Name]),([Name]))) -data Inh_Rule = Inh_Rule {allTypeSigs_Inh_Rule :: Map Name Type,allfields_Inh_Rule :: [(Name,Type,Bool)],allnts_Inh_Rule :: [Name],altAttrs_Inh_Rule :: Map AltAttr Vertex,attrs_Inh_Rule :: [(Name,Name)],childInhs_Inh_Rule :: Map Name Attributes,childNts_Inh_Rule :: Map Name Nonterminal,con_Inh_Rule :: Identifier,inh_Inh_Rule :: Attributes,manualAttrDepMap_Inh_Rule :: AttrOrderMap,nt_Inh_Rule :: Identifier,o_case_Inh_Rule :: Bool,o_cata_Inh_Rule :: Bool,o_dovisit_Inh_Rule :: Bool,o_newtypes_Inh_Rule :: Bool,o_rename_Inh_Rule :: Bool,o_sem_Inh_Rule :: Bool,o_sig_Inh_Rule :: Bool,o_wantvisit_Inh_Rule :: Bool,prefix_Inh_Rule :: String,syn_Inh_Rule :: Attributes,synsOfChildren_Inh_Rule :: Map Name Attributes} -data Syn_Rule = Syn_Rule {additionalDep_Syn_Rule :: Seq Edge,directDep_Syn_Rule :: Seq Edge,errors_Syn_Rule :: Seq Error,gathAltAttrs_Syn_Rule :: [AltAttr],gathRules_Syn_Rule :: Seq CRule,instDep_Syn_Rule :: Seq Edge,instVars_Syn_Rule :: [Name],locVars_Syn_Rule :: [Name]} -wrap_Rule (T_Rule sem ) (Inh_Rule _lhsIallTypeSigs _lhsIallfields _lhsIallnts _lhsIaltAttrs _lhsIattrs _lhsIchildInhs _lhsIchildNts _lhsIcon _lhsIinh _lhsImanualAttrDepMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIsynsOfChildren ) = - (let ( _lhsOadditionalDep,_lhsOdirectDep,_lhsOerrors,_lhsOgathAltAttrs,_lhsOgathRules,_lhsOinstDep,_lhsOinstVars,_lhsOlocVars) = - (sem _lhsIallTypeSigs _lhsIallfields _lhsIallnts _lhsIaltAttrs _lhsIattrs _lhsIchildInhs _lhsIchildNts _lhsIcon _lhsIinh _lhsImanualAttrDepMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIsynsOfChildren ) - in (Syn_Rule _lhsOadditionalDep _lhsOdirectDep _lhsOerrors _lhsOgathAltAttrs _lhsOgathRules _lhsOinstDep _lhsOinstVars _lhsOlocVars )) -sem_Rule_Rule :: T_Pattern -> - T_Expression -> - Bool -> - String -> - T_Rule -sem_Rule_Rule (T_Pattern pattern_ ) (T_Expression rhs_ ) owrt_ origin_ = - (T_Rule (\ _lhsIallTypeSigs - _lhsIallfields - _lhsIallnts - _lhsIaltAttrs - _lhsIattrs - _lhsIchildInhs - _lhsIchildNts - _lhsIcon - _lhsIinh - _lhsImanualAttrDepMap - _lhsInt - _lhsIo_case - _lhsIo_cata - _lhsIo_dovisit - _lhsIo_newtypes - _lhsIo_rename - _lhsIo_sem - _lhsIo_sig - _lhsIo_wantvisit - _lhsIprefix - _lhsIsyn - _lhsIsynsOfChildren -> - (let _lhsOdirectDep :: (Seq Edge) - _lhsOadditionalDep :: (Seq Edge) - _lhsOinstDep :: (Seq Edge) - _lhsOerrors :: (Seq Error) - _lhsOgathAltAttrs :: ([AltAttr]) - _lhsOgathRules :: (Seq CRule) - _lhsOinstVars :: ([Name]) - _lhsOlocVars :: ([Name]) - _patternOallTypeSigs :: (Map Name Type) - _patternOaltAttrs :: (Map AltAttr Vertex) - _patternOcon :: Identifier - _patternOinh :: Attributes - _patternOnt :: Identifier - _patternOsyn :: Attributes - _rhsOallfields :: ([(Name,Type,Bool)]) - _rhsOallnts :: ([Name]) - _rhsOattrs :: ([(Name,Name)]) - _rhsOcon :: Name - _rhsOnt :: Name - _patternIcopy :: Pattern - _patternIerrors :: (Seq Error) - _patternIgathAltAttrs :: ([AltAttr]) - _patternIinstVars :: ([Name]) - _patternIlocVars :: ([Name]) - _patternIpatternAttrs :: ([(Name,Name,Bool,Patterns)]) - _rhsIallRhsVars :: (Set (Name,Name)) - _rhsIcopy :: Expression - _rhsIerrors :: (Seq Error) - _rhsItextLines :: ([String]) - _rhsIusedAttrs :: ([(Name,Name)]) - _rhsIusedFields :: ([Name]) - _rhsIusedLocals :: ([Name]) - -- "Order.ag"(line 193, column 12) - _defines = - let tp field attr parts | field == _LOC || field == _INST - = case parts of - [] -> Map.lookup attr _lhsIallTypeSigs - _ -> (sequence (map typ parts)) >>= (haskellTupel . map (substSelf _lhsInt)) - | field == _LHS = Map.lookup attr _lhsIsyn - | otherwise = Map.lookup attr (findWithErr1 "Rule.defines.tp" field _lhsIchildInhs) - typ :: Pattern -> Maybe Type - typ (Alias field attr _ parts) = tp field attr parts - typ (Underscore _) = Nothing - typ (Product _ pats) = tp _LOC undefined pats - typ _ = Nothing - in Map.fromList [ (findWithErr1 "Rule.defines" aa _lhsIaltAttrs, (field,attr,(tp field attr parts))) - | (field,attr,isLocalOrInst,parts) <- _patternIpatternAttrs - , let aa = AltAttr field attr isLocalOrInst - ] - -- "Order.ag"(line 209, column 12) - _gathRules = - let childnt field = Map.lookup field _lhsIchildNts - in Seq.fromList [ CRule attr False True _lhsInt _lhsIcon field (childnt field) tp _patternIcopy _rhsItextLines _defines owrt_ origin_ _rhsIallRhsVars - | (field,attr,tp) <- Map.elems _defines - ] - -- "Order.ag"(line 246, column 12) - _lhsOdirectDep = - let defined = Map.keys _defines - used = [ Map.lookup (AltAttr field attr True) _lhsIaltAttrs | (field,attr) <- _rhsIusedAttrs] - ++ [ Map.lookup (AltAttr _LOC attr True) _lhsIaltAttrs | attr <- _rhsIusedLocals ++ _rhsIusedFields ] - in Seq.fromList [ (x,y) | Just x <- used, y <- defined ] - -- "Order.ag"(line 264, column 7) - _manualDeps = - Set.toList $ Map.findWithDefault Set.empty _lhsIcon $ Map.findWithDefault Map.empty _lhsInt _lhsImanualAttrDepMap - -- "Order.ag"(line 266, column 7) - _lhsOadditionalDep = - Seq.fromList [ (vertexA, vertexB) - | Dependency (fldA,nmA) (fldB,nmB) <- _manualDeps - , let vertexA = findWithErr2 (AltAttr fldA nmA True) _lhsIaltAttrs - , vertexB <- lookupVertices fldB nmB _lhsIaltAttrs - ] - -- "Order.ag"(line 292, column 7) - _lhsOinstDep = - Seq.fromList $ - [ (instVert, synVert) - | (field,instNm,_) <- Map.elems _defines - , field == _INST - , synNm <- Map.keys (findWithErr2 instNm _lhsIsynsOfChildren) - , let instAttr = AltAttr _INST instNm True - synAttr = AltAttr instNm synNm True - instVert = findWithErr2 instAttr _lhsIaltAttrs - synVert = findWithErr2 synAttr _lhsIaltAttrs - ] - -- use rule "Order.ag"(line 60, column 70) - _lhsOerrors = - _patternIerrors Seq.<> _rhsIerrors - -- use rule "Order.ag"(line 146, column 68) - _lhsOgathAltAttrs = - _patternIgathAltAttrs - -- use rule "Order.ag"(line 182, column 23) - _lhsOgathRules = - _gathRules - -- use rule "Order.ag"(line 533, column 80) - _lhsOinstVars = - _patternIinstVars - -- use rule "Order.ag"(line 533, column 48) - _lhsOlocVars = - _patternIlocVars - -- copy rule (down) - _patternOallTypeSigs = - _lhsIallTypeSigs - -- copy rule (down) - _patternOaltAttrs = - _lhsIaltAttrs - -- copy rule (down) - _patternOcon = - _lhsIcon - -- copy rule (down) - _patternOinh = - _lhsIinh - -- copy rule (down) - _patternOnt = - _lhsInt - -- copy rule (down) - _patternOsyn = - _lhsIsyn - -- copy rule (down) - _rhsOallfields = - _lhsIallfields - -- copy rule (down) - _rhsOallnts = - _lhsIallnts - -- copy rule (down) - _rhsOattrs = - _lhsIattrs - -- copy rule (down) - _rhsOcon = - _lhsIcon - -- copy rule (down) - _rhsOnt = - _lhsInt - ( _patternIcopy,_patternIerrors,_patternIgathAltAttrs,_patternIinstVars,_patternIlocVars,_patternIpatternAttrs) = - (pattern_ _patternOallTypeSigs _patternOaltAttrs _patternOcon _patternOinh _patternOnt _patternOsyn ) - ( _rhsIallRhsVars,_rhsIcopy,_rhsIerrors,_rhsItextLines,_rhsIusedAttrs,_rhsIusedFields,_rhsIusedLocals) = - (rhs_ _rhsOallfields _rhsOallnts _rhsOattrs _rhsOcon _rhsOnt ) - in ( _lhsOadditionalDep,_lhsOdirectDep,_lhsOerrors,_lhsOgathAltAttrs,_lhsOgathRules,_lhsOinstDep,_lhsOinstVars,_lhsOlocVars))) ) --- Rules ------------------------------------------------------- -{- - visit 0: - inherited attributes: - allTypeSigs : Map Name Type - allfields : [(Name,Type,Bool)] - allnts : [Name] - altAttrs : Map AltAttr Vertex - attrs : [(Name,Name)] - childInhs : Map Name Attributes - childNts : Map Name Nonterminal - con : Identifier - inh : Attributes - manualAttrDepMap : AttrOrderMap - nt : Identifier - o_case : Bool - o_cata : Bool - o_dovisit : Bool - o_newtypes : Bool - o_rename : Bool - o_sem : Bool - o_sig : Bool - o_wantvisit : Bool - prefix : String - syn : Attributes - synsOfChildren : Map Name Attributes - synthesized attributes: - additionalDep : Seq Edge - directDep : Seq Edge - errors : Seq Error - gathAltAttrs : [AltAttr] - gathRules : Seq CRule - instDep : Seq Edge - instVars : [Name] - locVars : [Name] - alternatives: - alternative Cons: - child hd : Rule - child tl : Rules - alternative Nil: --} --- cata -sem_Rules :: Rules -> - T_Rules -sem_Rules list = - (Prelude.foldr sem_Rules_Cons sem_Rules_Nil (Prelude.map sem_Rule list) ) --- semantic domain -newtype T_Rules = T_Rules ((Map Name Type) -> - ([(Name,Type,Bool)]) -> - ([Name]) -> - (Map AltAttr Vertex) -> - ([(Name,Name)]) -> - (Map Name Attributes) -> - (Map Name Nonterminal) -> - Identifier -> - Attributes -> - AttrOrderMap -> - Identifier -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - Bool -> - String -> - Attributes -> - (Map Name Attributes) -> - ( (Seq Edge),(Seq Edge),(Seq Error),([AltAttr]),(Seq CRule),(Seq Edge),([Name]),([Name]))) -data Inh_Rules = Inh_Rules {allTypeSigs_Inh_Rules :: Map Name Type,allfields_Inh_Rules :: [(Name,Type,Bool)],allnts_Inh_Rules :: [Name],altAttrs_Inh_Rules :: Map AltAttr Vertex,attrs_Inh_Rules :: [(Name,Name)],childInhs_Inh_Rules :: Map Name Attributes,childNts_Inh_Rules :: Map Name Nonterminal,con_Inh_Rules :: Identifier,inh_Inh_Rules :: Attributes,manualAttrDepMap_Inh_Rules :: AttrOrderMap,nt_Inh_Rules :: Identifier,o_case_Inh_Rules :: Bool,o_cata_Inh_Rules :: Bool,o_dovisit_Inh_Rules :: Bool,o_newtypes_Inh_Rules :: Bool,o_rename_Inh_Rules :: Bool,o_sem_Inh_Rules :: Bool,o_sig_Inh_Rules :: Bool,o_wantvisit_Inh_Rules :: Bool,prefix_Inh_Rules :: String,syn_Inh_Rules :: Attributes,synsOfChildren_Inh_Rules :: Map Name Attributes} -data Syn_Rules = Syn_Rules {additionalDep_Syn_Rules :: Seq Edge,directDep_Syn_Rules :: Seq Edge,errors_Syn_Rules :: Seq Error,gathAltAttrs_Syn_Rules :: [AltAttr],gathRules_Syn_Rules :: Seq CRule,instDep_Syn_Rules :: Seq Edge,instVars_Syn_Rules :: [Name],locVars_Syn_Rules :: [Name]} -wrap_Rules (T_Rules sem ) (Inh_Rules _lhsIallTypeSigs _lhsIallfields _lhsIallnts _lhsIaltAttrs _lhsIattrs _lhsIchildInhs _lhsIchildNts _lhsIcon _lhsIinh _lhsImanualAttrDepMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIsynsOfChildren ) = - (let ( _lhsOadditionalDep,_lhsOdirectDep,_lhsOerrors,_lhsOgathAltAttrs,_lhsOgathRules,_lhsOinstDep,_lhsOinstVars,_lhsOlocVars) = - (sem _lhsIallTypeSigs _lhsIallfields _lhsIallnts _lhsIaltAttrs _lhsIattrs _lhsIchildInhs _lhsIchildNts _lhsIcon _lhsIinh _lhsImanualAttrDepMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIsynsOfChildren ) - in (Syn_Rules _lhsOadditionalDep _lhsOdirectDep _lhsOerrors _lhsOgathAltAttrs _lhsOgathRules _lhsOinstDep _lhsOinstVars _lhsOlocVars )) -sem_Rules_Cons :: T_Rule -> - T_Rules -> - T_Rules -sem_Rules_Cons (T_Rule hd_ ) (T_Rules tl_ ) = - (T_Rules (\ _lhsIallTypeSigs - _lhsIallfields - _lhsIallnts - _lhsIaltAttrs - _lhsIattrs - _lhsIchildInhs - _lhsIchildNts - _lhsIcon - _lhsIinh - _lhsImanualAttrDepMap - _lhsInt - _lhsIo_case - _lhsIo_cata - _lhsIo_dovisit - _lhsIo_newtypes - _lhsIo_rename - _lhsIo_sem - _lhsIo_sig - _lhsIo_wantvisit - _lhsIprefix - _lhsIsyn - _lhsIsynsOfChildren -> - (let _lhsOadditionalDep :: (Seq Edge) - _lhsOdirectDep :: (Seq Edge) - _lhsOerrors :: (Seq Error) - _lhsOgathAltAttrs :: ([AltAttr]) - _lhsOgathRules :: (Seq CRule) - _lhsOinstDep :: (Seq Edge) - _lhsOinstVars :: ([Name]) - _lhsOlocVars :: ([Name]) - _hdOallTypeSigs :: (Map Name Type) - _hdOallfields :: ([(Name,Type,Bool)]) - _hdOallnts :: ([Name]) - _hdOaltAttrs :: (Map AltAttr Vertex) - _hdOattrs :: ([(Name,Name)]) - _hdOchildInhs :: (Map Name Attributes) - _hdOchildNts :: (Map Name Nonterminal) - _hdOcon :: Identifier - _hdOinh :: Attributes - _hdOmanualAttrDepMap :: AttrOrderMap - _hdOnt :: Identifier - _hdOo_case :: Bool - _hdOo_cata :: Bool - _hdOo_dovisit :: Bool - _hdOo_newtypes :: Bool - _hdOo_rename :: Bool - _hdOo_sem :: Bool - _hdOo_sig :: Bool - _hdOo_wantvisit :: Bool - _hdOprefix :: String - _hdOsyn :: Attributes - _hdOsynsOfChildren :: (Map Name Attributes) - _tlOallTypeSigs :: (Map Name Type) - _tlOallfields :: ([(Name,Type,Bool)]) - _tlOallnts :: ([Name]) - _tlOaltAttrs :: (Map AltAttr Vertex) - _tlOattrs :: ([(Name,Name)]) - _tlOchildInhs :: (Map Name Attributes) - _tlOchildNts :: (Map Name Nonterminal) - _tlOcon :: Identifier - _tlOinh :: Attributes - _tlOmanualAttrDepMap :: AttrOrderMap - _tlOnt :: Identifier - _tlOo_case :: Bool - _tlOo_cata :: Bool - _tlOo_dovisit :: Bool - _tlOo_newtypes :: Bool - _tlOo_rename :: Bool - _tlOo_sem :: Bool - _tlOo_sig :: Bool - _tlOo_wantvisit :: Bool - _tlOprefix :: String - _tlOsyn :: Attributes - _tlOsynsOfChildren :: (Map Name Attributes) - _hdIadditionalDep :: (Seq Edge) - _hdIdirectDep :: (Seq Edge) - _hdIerrors :: (Seq Error) - _hdIgathAltAttrs :: ([AltAttr]) - _hdIgathRules :: (Seq CRule) - _hdIinstDep :: (Seq Edge) - _hdIinstVars :: ([Name]) - _hdIlocVars :: ([Name]) - _tlIadditionalDep :: (Seq Edge) - _tlIdirectDep :: (Seq Edge) - _tlIerrors :: (Seq Error) - _tlIgathAltAttrs :: ([AltAttr]) - _tlIgathRules :: (Seq CRule) - _tlIinstDep :: (Seq Edge) - _tlIinstVars :: ([Name]) - _tlIlocVars :: ([Name]) - -- use rule "Order.ag"(line 258, column 71) - _lhsOadditionalDep = - _hdIadditionalDep Seq.<> _tlIadditionalDep - -- use rule "Order.ag"(line 244, column 33) - _lhsOdirectDep = - _hdIdirectDep Seq.<> _tlIdirectDep - -- use rule "Order.ag"(line 60, column 70) - _lhsOerrors = - _hdIerrors Seq.<> _tlIerrors - -- use rule "Order.ag"(line 146, column 68) - _lhsOgathAltAttrs = - _hdIgathAltAttrs ++ _tlIgathAltAttrs - -- use rule "Order.ag"(line 182, column 23) - _lhsOgathRules = - _hdIgathRules Seq.<> _tlIgathRules - -- use rule "Order.ag"(line 289, column 31) - _lhsOinstDep = - _hdIinstDep Seq.<> _tlIinstDep - -- use rule "Order.ag"(line 533, column 80) - _lhsOinstVars = - _hdIinstVars ++ _tlIinstVars - -- use rule "Order.ag"(line 533, column 48) - _lhsOlocVars = - _hdIlocVars ++ _tlIlocVars - -- copy rule (down) - _hdOallTypeSigs = - _lhsIallTypeSigs - -- copy rule (down) - _hdOallfields = - _lhsIallfields - -- copy rule (down) - _hdOallnts = - _lhsIallnts - -- copy rule (down) - _hdOaltAttrs = - _lhsIaltAttrs - -- copy rule (down) - _hdOattrs = - _lhsIattrs - -- copy rule (down) - _hdOchildInhs = - _lhsIchildInhs - -- copy rule (down) - _hdOchildNts = - _lhsIchildNts - -- copy rule (down) - _hdOcon = - _lhsIcon - -- copy rule (down) - _hdOinh = - _lhsIinh - -- copy rule (down) - _hdOmanualAttrDepMap = - _lhsImanualAttrDepMap - -- copy rule (down) - _hdOnt = - _lhsInt - -- copy rule (down) - _hdOo_case = - _lhsIo_case - -- copy rule (down) - _hdOo_cata = - _lhsIo_cata - -- copy rule (down) - _hdOo_dovisit = - _lhsIo_dovisit - -- copy rule (down) - _hdOo_newtypes = - _lhsIo_newtypes - -- copy rule (down) - _hdOo_rename = - _lhsIo_rename - -- copy rule (down) - _hdOo_sem = - _lhsIo_sem - -- copy rule (down) - _hdOo_sig = - _lhsIo_sig - -- copy rule (down) - _hdOo_wantvisit = - _lhsIo_wantvisit - -- copy rule (down) - _hdOprefix = - _lhsIprefix - -- copy rule (down) - _hdOsyn = - _lhsIsyn - -- copy rule (down) - _hdOsynsOfChildren = - _lhsIsynsOfChildren - -- copy rule (down) - _tlOallTypeSigs = - _lhsIallTypeSigs - -- copy rule (down) - _tlOallfields = - _lhsIallfields - -- copy rule (down) - _tlOallnts = - _lhsIallnts - -- copy rule (down) - _tlOaltAttrs = - _lhsIaltAttrs - -- copy rule (down) - _tlOattrs = - _lhsIattrs - -- copy rule (down) - _tlOchildInhs = - _lhsIchildInhs - -- copy rule (down) - _tlOchildNts = - _lhsIchildNts - -- copy rule (down) - _tlOcon = - _lhsIcon - -- copy rule (down) - _tlOinh = - _lhsIinh - -- copy rule (down) - _tlOmanualAttrDepMap = - _lhsImanualAttrDepMap - -- copy rule (down) - _tlOnt = - _lhsInt - -- copy rule (down) - _tlOo_case = - _lhsIo_case - -- copy rule (down) - _tlOo_cata = - _lhsIo_cata - -- copy rule (down) - _tlOo_dovisit = - _lhsIo_dovisit - -- copy rule (down) - _tlOo_newtypes = - _lhsIo_newtypes - -- copy rule (down) - _tlOo_rename = - _lhsIo_rename - -- copy rule (down) - _tlOo_sem = - _lhsIo_sem - -- copy rule (down) - _tlOo_sig = - _lhsIo_sig - -- copy rule (down) - _tlOo_wantvisit = - _lhsIo_wantvisit - -- copy rule (down) - _tlOprefix = - _lhsIprefix - -- copy rule (down) - _tlOsyn = - _lhsIsyn - -- copy rule (down) - _tlOsynsOfChildren = - _lhsIsynsOfChildren - ( _hdIadditionalDep,_hdIdirectDep,_hdIerrors,_hdIgathAltAttrs,_hdIgathRules,_hdIinstDep,_hdIinstVars,_hdIlocVars) = - (hd_ _hdOallTypeSigs _hdOallfields _hdOallnts _hdOaltAttrs _hdOattrs _hdOchildInhs _hdOchildNts _hdOcon _hdOinh _hdOmanualAttrDepMap _hdOnt _hdOo_case _hdOo_cata _hdOo_dovisit _hdOo_newtypes _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_wantvisit _hdOprefix _hdOsyn _hdOsynsOfChildren ) - ( _tlIadditionalDep,_tlIdirectDep,_tlIerrors,_tlIgathAltAttrs,_tlIgathRules,_tlIinstDep,_tlIinstVars,_tlIlocVars) = - (tl_ _tlOallTypeSigs _tlOallfields _tlOallnts _tlOaltAttrs _tlOattrs _tlOchildInhs _tlOchildNts _tlOcon _tlOinh _tlOmanualAttrDepMap _tlOnt _tlOo_case _tlOo_cata _tlOo_dovisit _tlOo_newtypes _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_wantvisit _tlOprefix _tlOsyn _tlOsynsOfChildren ) - in ( _lhsOadditionalDep,_lhsOdirectDep,_lhsOerrors,_lhsOgathAltAttrs,_lhsOgathRules,_lhsOinstDep,_lhsOinstVars,_lhsOlocVars))) ) -sem_Rules_Nil :: T_Rules -sem_Rules_Nil = - (T_Rules (\ _lhsIallTypeSigs - _lhsIallfields - _lhsIallnts - _lhsIaltAttrs - _lhsIattrs - _lhsIchildInhs - _lhsIchildNts - _lhsIcon - _lhsIinh - _lhsImanualAttrDepMap - _lhsInt - _lhsIo_case - _lhsIo_cata - _lhsIo_dovisit - _lhsIo_newtypes - _lhsIo_rename - _lhsIo_sem - _lhsIo_sig - _lhsIo_wantvisit - _lhsIprefix - _lhsIsyn - _lhsIsynsOfChildren -> - (let _lhsOadditionalDep :: (Seq Edge) - _lhsOdirectDep :: (Seq Edge) - _lhsOerrors :: (Seq Error) - _lhsOgathAltAttrs :: ([AltAttr]) - _lhsOgathRules :: (Seq CRule) - _lhsOinstDep :: (Seq Edge) - _lhsOinstVars :: ([Name]) - _lhsOlocVars :: ([Name]) - -- use rule "Order.ag"(line 258, column 71) - _lhsOadditionalDep = - Seq.empty - -- use rule "Order.ag"(line 244, column 33) - _lhsOdirectDep = - Seq.empty - -- use rule "Order.ag"(line 60, column 70) - _lhsOerrors = - Seq.empty - -- use rule "Order.ag"(line 146, column 68) - _lhsOgathAltAttrs = - [] - -- use rule "Order.ag"(line 182, column 23) - _lhsOgathRules = - Seq.empty - -- use rule "Order.ag"(line 289, column 31) - _lhsOinstDep = - Seq.empty - -- use rule "Order.ag"(line 533, column 80) - _lhsOinstVars = - [] - -- use rule "Order.ag"(line 533, column 48) - _lhsOlocVars = - [] - in ( _lhsOadditionalDep,_lhsOdirectDep,_lhsOerrors,_lhsOgathAltAttrs,_lhsOgathRules,_lhsOinstDep,_lhsOinstVars,_lhsOlocVars))) ) --- TypeSig ----------------------------------------------------- -{- - visit 0: - chained attribute: - typeSigs : Map Name Type - alternatives: - alternative TypeSig: - child name : {Name} - child tp : {Type} --} --- cata -sem_TypeSig :: TypeSig -> - T_TypeSig -sem_TypeSig (TypeSig _name _tp ) = - (sem_TypeSig_TypeSig _name _tp ) --- semantic domain -newtype T_TypeSig = T_TypeSig ((Map Name Type) -> - ( (Map Name Type))) -data Inh_TypeSig = Inh_TypeSig {typeSigs_Inh_TypeSig :: Map Name Type} -data Syn_TypeSig = Syn_TypeSig {typeSigs_Syn_TypeSig :: Map Name Type} -wrap_TypeSig (T_TypeSig sem ) (Inh_TypeSig _lhsItypeSigs ) = - (let ( _lhsOtypeSigs) = - (sem _lhsItypeSigs ) - in (Syn_TypeSig _lhsOtypeSigs )) -sem_TypeSig_TypeSig :: Name -> - Type -> - T_TypeSig -sem_TypeSig_TypeSig name_ tp_ = - (T_TypeSig (\ _lhsItypeSigs -> - (let _lhsOtypeSigs :: (Map Name Type) - -- "Order.ag"(line 393, column 13) - _lhsOtypeSigs = - Map.insert name_ tp_ _lhsItypeSigs - in ( _lhsOtypeSigs))) ) --- TypeSigs ---------------------------------------------------- -{- - visit 0: - chained attribute: - typeSigs : Map Name Type - alternatives: - alternative Cons: - child hd : TypeSig - child tl : TypeSigs - alternative Nil: --} --- cata -sem_TypeSigs :: TypeSigs -> - T_TypeSigs -sem_TypeSigs list = - (Prelude.foldr sem_TypeSigs_Cons sem_TypeSigs_Nil (Prelude.map sem_TypeSig list) ) --- semantic domain -newtype T_TypeSigs = T_TypeSigs ((Map Name Type) -> - ( (Map Name Type))) -data Inh_TypeSigs = Inh_TypeSigs {typeSigs_Inh_TypeSigs :: Map Name Type} -data Syn_TypeSigs = Syn_TypeSigs {typeSigs_Syn_TypeSigs :: Map Name Type} -wrap_TypeSigs (T_TypeSigs sem ) (Inh_TypeSigs _lhsItypeSigs ) = - (let ( _lhsOtypeSigs) = - (sem _lhsItypeSigs ) - in (Syn_TypeSigs _lhsOtypeSigs )) -sem_TypeSigs_Cons :: T_TypeSig -> - T_TypeSigs -> - T_TypeSigs -sem_TypeSigs_Cons (T_TypeSig hd_ ) (T_TypeSigs tl_ ) = - (T_TypeSigs (\ _lhsItypeSigs -> - (let _lhsOtypeSigs :: (Map Name Type) - _hdOtypeSigs :: (Map Name Type) - _tlOtypeSigs :: (Map Name Type) - _hdItypeSigs :: (Map Name Type) - _tlItypeSigs :: (Map Name Type) - -- copy rule (up) - _lhsOtypeSigs = - _tlItypeSigs - -- copy rule (down) - _hdOtypeSigs = - _lhsItypeSigs - -- copy rule (chain) - _tlOtypeSigs = - _hdItypeSigs - ( _hdItypeSigs) = - (hd_ _hdOtypeSigs ) - ( _tlItypeSigs) = - (tl_ _tlOtypeSigs ) - in ( _lhsOtypeSigs))) ) -sem_TypeSigs_Nil :: T_TypeSigs -sem_TypeSigs_Nil = - (T_TypeSigs (\ _lhsItypeSigs -> - (let _lhsOtypeSigs :: (Map Name Type) - -- copy rule (chain) - _lhsOtypeSigs = - _lhsItypeSigs - in ( _lhsOtypeSigs))) ) +-- UUAGC 0.9.5 (Order.ag) +module Order where + +-- From uuagc +import CommonTypes +import Patterns +import ErrorMessages +import AbstractSyntax +import Code hiding (Type) +import qualified Code +import Expression +import Options +import SequentialComputation +import SequentialTypes +import CodeSyntax +import GrammarInfo +import HsToken(HsTokensRoot(HsTokensRoot)) +import HsTokenScanner(lexTokens) +import SemHsTokens(sem_HsTokensRoot,wrap_HsTokensRoot, Syn_HsTokensRoot(..),Inh_HsTokensRoot(..)) +-- From uulib +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified UU.DData.Seq as Seq +import Data.Map(Map) +import Data.Set(Set) +import UU.DData.Seq(Seq, (<>)) +import UU.Util.Utils +import UU.Scanner.Position(Pos(..),initPos) + +-- From haskell libraries +import Control.Monad(liftM) +import qualified Data.Array as Array +import Data.Array((!),bounds,inRange) +import Data.List(elemIndex,partition,sort,mapAccumL,find,nubBy,intersperse,groupBy,transpose) +import qualified Data.Tree as Tree +import Maybe + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (ConstructorIdent,Identifier) + +import UU.Scanner.Position(Pos) +import HsToken + +-- AbstractSyntax.ag imports +import Data.Set(Set) +import Data.Map(Map) +import Patterns (Pattern(..),Patterns) +import Expression (Expression(..)) +import CommonTypes + +-- Terminates with an error if the key is not in the map +findWithErr1 :: (Ord k, Show k) => String -> k -> Map k a -> a +findWithErr1 s k + = Map.findWithDefault (error ("findWithErr1 " ++ s ++ ": key " ++ show k ++ " not in map.")) k + +findWithErr2 :: (Ord k, Show k, Show a) => k -> Map k a -> a +findWithErr2 k m + = Map.findWithDefault (error ("findWithErr2: key " ++ show k ++ " not in map: " ++ show m)) k m + +getNtName :: Type -> NontermIdent +getNtName (NT nt _) = nt +getNtName _ = nullIdent + +data AltAttr = AltAttr Identifier Identifier Bool + deriving (Eq, Ord, Show) + +substSelf nt tp + = case tp of + NT n tps | n == _SELF -> NT nt tps + _ -> tp + +haskellTupel :: [Type] -> Maybe Type +haskellTupel ts = Just ( Haskell ( '(' : (concat (intersperse "," (map show ts))) ++ ")" )) + +lookupVertices :: Identifier -> Identifier -> Map AltAttr Int -> [Int] +lookupVertices fld nm attrs + = catMaybes ( [Map.lookup (AltAttr fld nm False) attrs] -- look for all "out" attributes + ++ if fld == _LOC + then [Map.lookup (AltAttr fld nm True) attrs] + else [] + ) + +swap (a,b) = (b,a) + +showPath :: Table CRule -> [Vertex] -> [String] +showPath ruleTable path + = let look a | inRange (bounds ruleTable) a = [showOrigin (ruleTable ! a)] + | otherwise = ["Vertex " ++ show a] + showOrigin cr | getHasCode cr && getName (getAttr cr) /= "self" = prettyCRule cr ++ " (" ++ show (getPos (getAttr cr)) ++ ")" + | otherwise = prettyCRule cr + in concatMap look path + + +showPathLocal :: Table CRule -> [Vertex] -> [String] +showPathLocal _ [] = [] +showPathLocal ruleTable xs = showP (xs++[-1]) + where showP [] = [] + showP (v1:v2:vs) = let line = step v1 v2 + lines = showP vs + in line:lines + step v1 v2 = " - " ++ a1 + where r1 = ruleTable ! v1 + a1 = show (getAttr r1) + + +limitTo :: Int -> [String] -> [String] +limitTo _ [] = [] +limitTo 0 _ = ["....etcetera, etcetera...."] +limitTo n (x:xs) = x : limitTo (n-1) xs + +showPathNice :: Table CRule -> [Vertex] -> [String] +showPathNice _ [] = [] +showPathNice ruleTable xs = limitTo 100 (showP ((-1):xs++[-1])) + where [maxf, maxa, maxn, maxc] = maxWidths ruleTable (take 100 xs) + showP [] = [] + showP (v1:v2:vs) = let line = step v1 v2 + lines = showP vs + in if null line then lines else line:lines + step v1 v2 | last && first = induced + | last && isSyn r1 = "pass up " ++ alignR maxf "" ++ " " ++ alignL maxa a1 ++ " in " ++ alignR maxn n1 ++ "|" ++ c1 ++ induced + | first&& not(isSyn r2) = "get from above " ++ alignR maxf "" ++ " " ++ alignL maxa a2 ++ " in " ++ alignR maxn n2 ++ "|" ++ c2 + | last = "pass down " ++ alignR maxf f1 ++ "." ++ a1 ++ induced + | isSyn r2 = "get from below " ++ alignR maxf f2 ++ "." ++ alignL maxa a2 ++ " in " ++ alignR maxn n2 ++ "|" ++ c2 + | isLocal r1 = if head a1 == '_' + then "" + else "calculate " ++ alignR maxf "loc" ++ "." ++ a1 + | otherwise = "pass down " ++ alignR maxf f1 ++ "." ++ alignL maxa a1 ++ " to " ++ alignR maxn n2 ++ "|" ++ c2 + where + first = v1<0 + last = v2<0 + r1 = ruleTable ! v1 + r2 = ruleTable ! v2 + a1 = show (getAttr r1) + a2 = show (getAttr r2) + f1 = show (getField r1) + f2 = show (getField r2) + n1 = show (getLhsNt r1) + n2 = show (getLhsNt r2) + c1 = show (getCon r1) + c2 = show (getCon r2) + induced | v2== -2 = " INDUCED dependency to " + | otherwise = "" + + +maxWidths ruleTable vs + = map maximum (transpose (map getWidth vs)) + where getWidth v | v<0 = [0,0,0,0] + | otherwise = map (length . show . ($ (ruleTable!v))) [getField, getAttr, getLhsNt, getCon] + +alignL n xs | k Bool -> Route -> Error +localCycleErr ruleTable o_visit (s:path) + = let cr = ruleTable ! s + attr = getAttr cr + nt = getLhsNt cr + con = getCon cr + in LocalCirc nt con attr o_visit (showPathLocal ruleTable path) + +instCycleErr :: Table CRule -> Bool -> Route -> Error +instCycleErr ruleTable o_visit (s:path) + = let cr = ruleTable ! s + attr = getAttr cr + nt = getLhsNt cr + con = getCon cr + in InstCirc nt con attr o_visit (showPathLocal ruleTable path) + +directCycleErrs :: Table NTAttr -> Table CRule -> Bool -> [EdgeRoutes] -> [Error] +directCycleErrs attrTable ruleTable o_visit xs + = let getNont v = case attrTable ! v of + NTASyn nt _ _ -> nt + NTAInh nt _ _ -> nt + getAttr v = case attrTable ! v of + NTASyn _ a _ -> a + NTAInh _ a _ -> a + sameNont ((v1,_),_,_) ((v2,_),_,_) = getNont v1 == getNont v2 + procCycle ((v1,v2),p1,p2) = ((getAttr v1, getAttr v2), showPathNice ruleTable p1, showPathNice ruleTable p2) + wrapGroup gr@(((v1,_),_,_):_) = DirectCirc (getNont v1) o_visit (map procCycle gr) + in map wrapGroup (groupBy sameNont xs) + +inducedCycleErrs :: Table NTAttr -> Table CRule -> CInterfaceMap -> [EdgeRoutes] -> [Error] +inducedCycleErrs attrTable ruleTable cim xs + = let getNont v = case attrTable ! v of + NTASyn nt _ _ -> nt + NTAInh nt _ _ -> nt + getAttr v = case attrTable ! v of + NTASyn _ a _ -> a + NTAInh _ a _ -> a + sameNont ((v1,_),_,_) ((v2,_),_,_) = getNont v1 == getNont v2 + procCycle ((v1,v2),p1,p2) = ((getAttr v1, getAttr v2), showPathNice ruleTable p1, showPathNice ruleTable p2) + wrapGroup gr@(((v1,_),_,_):_) = InducedCirc (getNont v1) (findWithErr1 "inducedCycleErr.cinter" (getNont v1) cim) (map procCycle gr) + in map wrapGroup (groupBy sameNont xs) +-- Child ------------------------------------------------------- +{- + visit 0: + inherited attributes: + allfields : [(Identifier,Type,Bool)] + allnts : [Identifier] + attrs : [(Identifier,Identifier)] + con : Identifier + inh : Attributes + nt : Identifier + o_unbox : Bool + syn : Attributes + synthesized attributes: + attributes : [(Identifier,Attributes,Attributes)] + collectChildrenSyns : Map Identifier Attributes + errors : Seq Error + field : (Identifier,Type,Bool) + gathAltAttrs : [AltAttr] + gathRules : Seq CRule + inhs : Seq (Identifier,Attributes) + nts : Seq (Identifier,NontermIdent) + singlevisits : [CRule] + terminals : [Identifier] + alternatives: + alternative Child: + child name : {Identifier} + child tp : {Type} + child inh : {Attributes} + child syn : {Attributes} + child higherOrder : {Bool} + visit 0: + local maptolocal : _ + local gathRules : _ +-} +-- cata +sem_Child :: Child -> + T_Child +sem_Child (Child _name _tp _inh _syn _higherOrder) = + (sem_Child_Child _name _tp _inh _syn _higherOrder) +-- semantic domain +newtype T_Child = T_Child (([(Identifier,Type,Bool)]) -> + ([Identifier]) -> + ([(Identifier,Identifier)]) -> + Identifier -> + Attributes -> + Identifier -> + Bool -> + Attributes -> + ( ([(Identifier,Attributes,Attributes)]),(Map Identifier Attributes ),(Seq Error),((Identifier,Type,Bool)),([AltAttr]),(Seq CRule),(Seq (Identifier,Attributes)),(Seq (Identifier,NontermIdent)),([CRule]),([Identifier]))) +data Inh_Child = Inh_Child {allfields_Inh_Child :: [(Identifier,Type,Bool)],allnts_Inh_Child :: [Identifier],attrs_Inh_Child :: [(Identifier,Identifier)],con_Inh_Child :: Identifier,inh_Inh_Child :: Attributes,nt_Inh_Child :: Identifier,o_unbox_Inh_Child :: Bool,syn_Inh_Child :: Attributes} +data Syn_Child = Syn_Child {attributes_Syn_Child :: [(Identifier,Attributes,Attributes)],collectChildrenSyns_Syn_Child :: Map Identifier Attributes ,errors_Syn_Child :: Seq Error,field_Syn_Child :: (Identifier,Type,Bool),gathAltAttrs_Syn_Child :: [AltAttr],gathRules_Syn_Child :: Seq CRule,inhs_Syn_Child :: Seq (Identifier,Attributes),nts_Syn_Child :: Seq (Identifier,NontermIdent),singlevisits_Syn_Child :: [CRule],terminals_Syn_Child :: [Identifier]} +wrap_Child (T_Child sem) (Inh_Child _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsInt _lhsIo_unbox _lhsIsyn) = + (let ( _lhsOattributes,_lhsOcollectChildrenSyns,_lhsOerrors,_lhsOfield,_lhsOgathAltAttrs,_lhsOgathRules,_lhsOinhs,_lhsOnts,_lhsOsinglevisits,_lhsOterminals) = + (sem _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsInt _lhsIo_unbox _lhsIsyn) + in (Syn_Child _lhsOattributes _lhsOcollectChildrenSyns _lhsOerrors _lhsOfield _lhsOgathAltAttrs _lhsOgathRules _lhsOinhs _lhsOnts _lhsOsinglevisits _lhsOterminals)) +sem_Child_Child :: Identifier -> + Type -> + Attributes -> + Attributes -> + Bool -> + T_Child +sem_Child_Child name_ tp_ inh_ syn_ higherOrder_ = + (T_Child (\ _lhsIallfields + _lhsIallnts + _lhsIattrs + _lhsIcon + _lhsIinh + _lhsInt + _lhsIo_unbox + _lhsIsyn -> + (let _lhsOgathAltAttrs :: ([AltAttr]) + _lhsOnts :: (Seq (Identifier,NontermIdent)) + _lhsOinhs :: (Seq (Identifier,Attributes)) + _lhsOcollectChildrenSyns :: (Map Identifier Attributes ) + _lhsOsinglevisits :: ([CRule]) + _lhsOterminals :: ([Identifier]) + _lhsOattributes :: ([(Identifier,Attributes,Attributes)]) + _lhsOfield :: ((Identifier,Type,Bool)) + _lhsOerrors :: (Seq Error) + _lhsOgathRules :: (Seq CRule) + -- "Order.ag"(line 153, column 13) + _maptolocal = + case tp_ of + NT nt _ -> Map.null syn_ + _ -> True + -- "Order.ag"(line 156, column 13) + _lhsOgathAltAttrs = + if _maptolocal + then [ AltAttr _LOC name_ True ] + else [ AltAttr name_ syn True | syn <- Map.keys syn_ ] + -- "Order.ag"(line 171, column 13) + _lhsOnts = + Seq.single (name_,getNtName tp_) + -- "Order.ag"(line 172, column 13) + _lhsOinhs = + Seq.single (name_,inh_) + -- "Order.ag"(line 188, column 13) + _gathRules = + if _maptolocal + then Seq.single (cRuleTerminal name_ _lhsInt _lhsIcon tp_) + else Seq.fromList [ cRuleRhsSyn syn _lhsInt _lhsIcon tp name_ (getNtName tp_) | (syn,tp) <- Map.assocs syn_] + -- "Order.ag"(line 313, column 12) + _lhsOcollectChildrenSyns = + Map.singleton name_ syn_ + -- "Order.ag"(line 473, column 11) + _lhsOsinglevisits = + if _maptolocal + then [] + else [CChildVisit name_ (getNtName tp_) 0 inh_ syn_ True] + -- "Order.ag"(line 494, column 11) + _lhsOterminals = + if _maptolocal + then [name_] + else [] + -- "Order.ag"(line 523, column 11) + _lhsOattributes = + [(name_, inh_, syn_)] + -- "Order.ag"(line 527, column 11) + _lhsOfield = + (name_, tp_, higherOrder_) + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + Seq.empty + -- use rule "Order.ag"(line 182, column 23) + _lhsOgathRules = + _gathRules + in ( _lhsOattributes,_lhsOcollectChildrenSyns,_lhsOerrors,_lhsOfield,_lhsOgathAltAttrs,_lhsOgathRules,_lhsOinhs,_lhsOnts,_lhsOsinglevisits,_lhsOterminals)))) +-- Children ---------------------------------------------------- +{- + visit 0: + inherited attributes: + allfields : [(Identifier,Type,Bool)] + allnts : [Identifier] + attrs : [(Identifier,Identifier)] + con : Identifier + inh : Attributes + nt : Identifier + o_unbox : Bool + syn : Attributes + synthesized attributes: + attributes : [(Identifier,Attributes,Attributes)] + collectChildrenSyns : Map Identifier Attributes + errors : Seq Error + fields : [(Identifier,Type,Bool)] + gathAltAttrs : [AltAttr] + gathRules : Seq CRule + inhs : Seq (Identifier,Attributes) + nts : Seq (Identifier,NontermIdent) + singlevisits : [CRule] + terminals : [Identifier] + alternatives: + alternative Cons: + child hd : Child + child tl : Children + alternative Nil: +-} +-- cata +sem_Children :: Children -> + T_Children +sem_Children list = + (Prelude.foldr sem_Children_Cons sem_Children_Nil (Prelude.map sem_Child list)) +-- semantic domain +newtype T_Children = T_Children (([(Identifier,Type,Bool)]) -> + ([Identifier]) -> + ([(Identifier,Identifier)]) -> + Identifier -> + Attributes -> + Identifier -> + Bool -> + Attributes -> + ( ([(Identifier,Attributes,Attributes)]),(Map Identifier Attributes ),(Seq Error),([(Identifier,Type,Bool)]),([AltAttr]),(Seq CRule),(Seq (Identifier,Attributes)),(Seq (Identifier,NontermIdent)),([CRule]),([Identifier]))) +data Inh_Children = Inh_Children {allfields_Inh_Children :: [(Identifier,Type,Bool)],allnts_Inh_Children :: [Identifier],attrs_Inh_Children :: [(Identifier,Identifier)],con_Inh_Children :: Identifier,inh_Inh_Children :: Attributes,nt_Inh_Children :: Identifier,o_unbox_Inh_Children :: Bool,syn_Inh_Children :: Attributes} +data Syn_Children = Syn_Children {attributes_Syn_Children :: [(Identifier,Attributes,Attributes)],collectChildrenSyns_Syn_Children :: Map Identifier Attributes ,errors_Syn_Children :: Seq Error,fields_Syn_Children :: [(Identifier,Type,Bool)],gathAltAttrs_Syn_Children :: [AltAttr],gathRules_Syn_Children :: Seq CRule,inhs_Syn_Children :: Seq (Identifier,Attributes),nts_Syn_Children :: Seq (Identifier,NontermIdent),singlevisits_Syn_Children :: [CRule],terminals_Syn_Children :: [Identifier]} +wrap_Children (T_Children sem) (Inh_Children _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsInt _lhsIo_unbox _lhsIsyn) = + (let ( _lhsOattributes,_lhsOcollectChildrenSyns,_lhsOerrors,_lhsOfields,_lhsOgathAltAttrs,_lhsOgathRules,_lhsOinhs,_lhsOnts,_lhsOsinglevisits,_lhsOterminals) = + (sem _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsInt _lhsIo_unbox _lhsIsyn) + in (Syn_Children _lhsOattributes _lhsOcollectChildrenSyns _lhsOerrors _lhsOfields _lhsOgathAltAttrs _lhsOgathRules _lhsOinhs _lhsOnts _lhsOsinglevisits _lhsOterminals)) +sem_Children_Cons :: T_Child -> + T_Children -> + T_Children +sem_Children_Cons (T_Child hd_) (T_Children tl_) = + (T_Children (\ _lhsIallfields + _lhsIallnts + _lhsIattrs + _lhsIcon + _lhsIinh + _lhsInt + _lhsIo_unbox + _lhsIsyn -> + (let _lhsOfields :: ([(Identifier,Type,Bool)]) + _lhsOattributes :: ([(Identifier,Attributes,Attributes)]) + _lhsOcollectChildrenSyns :: (Map Identifier Attributes ) + _lhsOerrors :: (Seq Error) + _lhsOgathAltAttrs :: ([AltAttr]) + _lhsOgathRules :: (Seq CRule) + _lhsOinhs :: (Seq (Identifier,Attributes)) + _lhsOnts :: (Seq (Identifier,NontermIdent)) + _lhsOsinglevisits :: ([CRule]) + _lhsOterminals :: ([Identifier]) + _hdOallfields :: ([(Identifier,Type,Bool)]) + _hdOallnts :: ([Identifier]) + _hdOattrs :: ([(Identifier,Identifier)]) + _hdOcon :: Identifier + _hdOinh :: Attributes + _hdOnt :: Identifier + _hdOo_unbox :: Bool + _hdOsyn :: Attributes + _tlOallfields :: ([(Identifier,Type,Bool)]) + _tlOallnts :: ([Identifier]) + _tlOattrs :: ([(Identifier,Identifier)]) + _tlOcon :: Identifier + _tlOinh :: Attributes + _tlOnt :: Identifier + _tlOo_unbox :: Bool + _tlOsyn :: Attributes + _hdIattributes :: ([(Identifier,Attributes,Attributes)]) + _hdIcollectChildrenSyns :: (Map Identifier Attributes ) + _hdIerrors :: (Seq Error) + _hdIfield :: ((Identifier,Type,Bool)) + _hdIgathAltAttrs :: ([AltAttr]) + _hdIgathRules :: (Seq CRule) + _hdIinhs :: (Seq (Identifier,Attributes)) + _hdInts :: (Seq (Identifier,NontermIdent)) + _hdIsinglevisits :: ([CRule]) + _hdIterminals :: ([Identifier]) + _tlIattributes :: ([(Identifier,Attributes,Attributes)]) + _tlIcollectChildrenSyns :: (Map Identifier Attributes ) + _tlIerrors :: (Seq Error) + _tlIfields :: ([(Identifier,Type,Bool)]) + _tlIgathAltAttrs :: ([AltAttr]) + _tlIgathRules :: (Seq CRule) + _tlIinhs :: (Seq (Identifier,Attributes)) + _tlInts :: (Seq (Identifier,NontermIdent)) + _tlIsinglevisits :: ([CRule]) + _tlIterminals :: ([Identifier]) + -- "Order.ag"(line 530, column 11) + _lhsOfields = + _hdIfield : _tlIfields + -- use rule "Order.ag"(line 521, column 32) + _lhsOattributes = + _hdIattributes ++ _tlIattributes + -- use rule "Order.ag"(line 311, column 47) + _lhsOcollectChildrenSyns = + _hdIcollectChildrenSyns `Map.union` _tlIcollectChildrenSyns + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- use rule "Order.ag"(line 146, column 68) + _lhsOgathAltAttrs = + _hdIgathAltAttrs ++ _tlIgathAltAttrs + -- use rule "Order.ag"(line 182, column 23) + _lhsOgathRules = + _hdIgathRules Seq.<> _tlIgathRules + -- use rule "Order.ag"(line 169, column 20) + _lhsOinhs = + _hdIinhs Seq.<> _tlIinhs + -- use rule "Order.ag"(line 168, column 19) + _lhsOnts = + _hdInts Seq.<> _tlInts + -- use rule "Order.ag"(line 471, column 40) + _lhsOsinglevisits = + _hdIsinglevisits ++ _tlIsinglevisits + -- use rule "Order.ag"(line 492, column 38) + _lhsOterminals = + _hdIterminals ++ _tlIterminals + -- copy rule (down) + _hdOallfields = + _lhsIallfields + -- copy rule (down) + _hdOallnts = + _lhsIallnts + -- copy rule (down) + _hdOattrs = + _lhsIattrs + -- copy rule (down) + _hdOcon = + _lhsIcon + -- copy rule (down) + _hdOinh = + _lhsIinh + -- copy rule (down) + _hdOnt = + _lhsInt + -- copy rule (down) + _hdOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _hdOsyn = + _lhsIsyn + -- copy rule (down) + _tlOallfields = + _lhsIallfields + -- copy rule (down) + _tlOallnts = + _lhsIallnts + -- copy rule (down) + _tlOattrs = + _lhsIattrs + -- copy rule (down) + _tlOcon = + _lhsIcon + -- copy rule (down) + _tlOinh = + _lhsIinh + -- copy rule (down) + _tlOnt = + _lhsInt + -- copy rule (down) + _tlOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _tlOsyn = + _lhsIsyn + ( _hdIattributes,_hdIcollectChildrenSyns,_hdIerrors,_hdIfield,_hdIgathAltAttrs,_hdIgathRules,_hdIinhs,_hdInts,_hdIsinglevisits,_hdIterminals) = + (hd_ _hdOallfields _hdOallnts _hdOattrs _hdOcon _hdOinh _hdOnt _hdOo_unbox _hdOsyn) + ( _tlIattributes,_tlIcollectChildrenSyns,_tlIerrors,_tlIfields,_tlIgathAltAttrs,_tlIgathRules,_tlIinhs,_tlInts,_tlIsinglevisits,_tlIterminals) = + (tl_ _tlOallfields _tlOallnts _tlOattrs _tlOcon _tlOinh _tlOnt _tlOo_unbox _tlOsyn) + in ( _lhsOattributes,_lhsOcollectChildrenSyns,_lhsOerrors,_lhsOfields,_lhsOgathAltAttrs,_lhsOgathRules,_lhsOinhs,_lhsOnts,_lhsOsinglevisits,_lhsOterminals)))) +sem_Children_Nil :: T_Children +sem_Children_Nil = + (T_Children (\ _lhsIallfields + _lhsIallnts + _lhsIattrs + _lhsIcon + _lhsIinh + _lhsInt + _lhsIo_unbox + _lhsIsyn -> + (let _lhsOfields :: ([(Identifier,Type,Bool)]) + _lhsOattributes :: ([(Identifier,Attributes,Attributes)]) + _lhsOcollectChildrenSyns :: (Map Identifier Attributes ) + _lhsOerrors :: (Seq Error) + _lhsOgathAltAttrs :: ([AltAttr]) + _lhsOgathRules :: (Seq CRule) + _lhsOinhs :: (Seq (Identifier,Attributes)) + _lhsOnts :: (Seq (Identifier,NontermIdent)) + _lhsOsinglevisits :: ([CRule]) + _lhsOterminals :: ([Identifier]) + -- "Order.ag"(line 531, column 11) + _lhsOfields = + [] + -- use rule "Order.ag"(line 521, column 32) + _lhsOattributes = + [] + -- use rule "Order.ag"(line 311, column 47) + _lhsOcollectChildrenSyns = + Map.empty + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + Seq.empty + -- use rule "Order.ag"(line 146, column 68) + _lhsOgathAltAttrs = + [] + -- use rule "Order.ag"(line 182, column 23) + _lhsOgathRules = + Seq.empty + -- use rule "Order.ag"(line 169, column 20) + _lhsOinhs = + Seq.empty + -- use rule "Order.ag"(line 168, column 19) + _lhsOnts = + Seq.empty + -- use rule "Order.ag"(line 471, column 40) + _lhsOsinglevisits = + [] + -- use rule "Order.ag"(line 492, column 38) + _lhsOterminals = + [] + in ( _lhsOattributes,_lhsOcollectChildrenSyns,_lhsOerrors,_lhsOfields,_lhsOgathAltAttrs,_lhsOgathRules,_lhsOinhs,_lhsOnts,_lhsOsinglevisits,_lhsOterminals)))) +-- Expression -------------------------------------------------- +{- + visit 0: + inherited attributes: + allfields : [(Identifier,Type,Bool)] + allnts : [Identifier] + attrs : [(Identifier,Identifier)] + con : Identifier + nt : Identifier + synthesized attributes: + allRhsVars : Set (Identifier,Identifier) + copy : SELF + errors : Seq Error + textLines : [String] + usedAttrs : [(Identifier,Identifier)] + usedFields : [Identifier] + usedLocals : [Identifier] + alternatives: + alternative Expression: + child pos : {Pos} + child tks : {[HsToken]} + visit 0: + local _tup1 : _ + local errors : _ + local textLines : _ + local usedAttrs : _ + local usedLocals : _ + local usedFields : _ + local copy : _ +-} +-- cata +sem_Expression :: Expression -> + T_Expression +sem_Expression (Expression _pos _tks) = + (sem_Expression_Expression _pos _tks) +-- semantic domain +newtype T_Expression = T_Expression (([(Identifier,Type,Bool)]) -> + ([Identifier]) -> + ([(Identifier,Identifier)]) -> + Identifier -> + Identifier -> + ( (Set (Identifier,Identifier)),Expression,(Seq Error),([String]),([(Identifier,Identifier)]),([Identifier]),([Identifier]))) +data Inh_Expression = Inh_Expression {allfields_Inh_Expression :: [(Identifier,Type,Bool)],allnts_Inh_Expression :: [Identifier],attrs_Inh_Expression :: [(Identifier,Identifier)],con_Inh_Expression :: Identifier,nt_Inh_Expression :: Identifier} +data Syn_Expression = Syn_Expression {allRhsVars_Syn_Expression :: Set (Identifier,Identifier),copy_Syn_Expression :: Expression,errors_Syn_Expression :: Seq Error,textLines_Syn_Expression :: [String],usedAttrs_Syn_Expression :: [(Identifier,Identifier)],usedFields_Syn_Expression :: [Identifier],usedLocals_Syn_Expression :: [Identifier]} +wrap_Expression (T_Expression sem) (Inh_Expression _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsInt) = + (let ( _lhsOallRhsVars,_lhsOcopy,_lhsOerrors,_lhsOtextLines,_lhsOusedAttrs,_lhsOusedFields,_lhsOusedLocals) = + (sem _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsInt) + in (Syn_Expression _lhsOallRhsVars _lhsOcopy _lhsOerrors _lhsOtextLines _lhsOusedAttrs _lhsOusedFields _lhsOusedLocals)) +sem_Expression_Expression :: Pos -> + ([HsToken]) -> + T_Expression +sem_Expression_Expression pos_ tks_ = + (T_Expression (\ _lhsIallfields + _lhsIallnts + _lhsIattrs + _lhsIcon + _lhsInt -> + (let _lhsOallRhsVars :: (Set (Identifier,Identifier)) + _lhsOcopy :: Expression + _lhsOerrors :: (Seq Error) + _lhsOtextLines :: ([String]) + _lhsOusedAttrs :: ([(Identifier,Identifier)]) + _lhsOusedFields :: ([Identifier]) + _lhsOusedLocals :: ([Identifier]) + -- "Order.ag"(line 333, column 21) + __tup1 = + let inherited = Inh_HsTokensRoot + { attrs_Inh_HsTokensRoot = _lhsIattrs + , con_Inh_HsTokensRoot = _lhsIcon + , allfields_Inh_HsTokensRoot = _lhsIallfields + , allnts_Inh_HsTokensRoot = _lhsIallnts + , nt_Inh_HsTokensRoot = _lhsInt + } + synthesized = wrap_HsTokensRoot (sem_HsTokensRoot (HsTokensRoot tks_)) inherited + in case synthesized of + Syn_HsTokensRoot + { errors_Syn_HsTokensRoot = errors + , textLines_Syn_HsTokensRoot = textLines + , usedAttrs_Syn_HsTokensRoot = usedAttrs + , usedLocals_Syn_HsTokensRoot = usedLocals + , usedFields_Syn_HsTokensRoot = usedFields + } -> (errors,textLines,usedAttrs,usedLocals,usedFields) + -- "Order.ag"(line 333, column 21) + (_errors,_,_,_,_) = + __tup1 + -- "Order.ag"(line 333, column 21) + (_,_textLines,_,_,_) = + __tup1 + -- "Order.ag"(line 333, column 21) + (_,_,_usedAttrs,_,_) = + __tup1 + -- "Order.ag"(line 333, column 21) + (_,_,_,_usedLocals,_) = + __tup1 + -- "Order.ag"(line 333, column 21) + (_,_,_,_,_usedFields) = + __tup1 + -- "Order.ag"(line 351, column 17) + _lhsOallRhsVars = + Set.fromList _usedAttrs + `Set.union` + Set.fromList [ (_LOC, l) | l <- _usedLocals ] + `Set.union` + Set.fromList [ (_FIELD, fld) | fld <- _usedFields ] + -- self rule + _copy = + Expression pos_ tks_ + -- self rule + _lhsOcopy = + _copy + -- copy rule (from local) + _lhsOerrors = + _errors + -- copy rule (from local) + _lhsOtextLines = + _textLines + -- copy rule (from local) + _lhsOusedAttrs = + _usedAttrs + -- copy rule (from local) + _lhsOusedFields = + _usedFields + -- copy rule (from local) + _lhsOusedLocals = + _usedLocals + in ( _lhsOallRhsVars,_lhsOcopy,_lhsOerrors,_lhsOtextLines,_lhsOusedAttrs,_lhsOusedFields,_lhsOusedLocals)))) +-- Grammar ----------------------------------------------------- +{- + visit 0: + inherited attribute: + options : Options + synthesized attributes: + errors : Seq Error + output : CGrammar + alternatives: + alternative Grammar: + child typeSyns : {TypeSyns} + child useMap : {UseMap} + child derivings : {Derivings} + child wrappers : {Set NontermIdent} + child nonts : Nonterminals + child pragmas : {PragmaMap} + child manualAttrOrderMap : {AttrOrderMap} + child paramMap : {ParamMap} + child contextMap : {ContextMap} + visit 0: + local ruleTable : _ + local attrTable : _ + local attrVertex : _ + local tdpToTds : _ + local tdsToTdp : _ + local directDep : _ + local instDep : _ + local info : _ + local _tup2 : _ + local cInterfaceMap : _ + local cVisitsMap : _ + local cyclesErrors : _ +-} +-- cata +sem_Grammar :: Grammar -> + T_Grammar +sem_Grammar (Grammar _typeSyns _useMap _derivings _wrappers _nonts _pragmas _manualAttrOrderMap _paramMap _contextMap) = + (sem_Grammar_Grammar _typeSyns _useMap _derivings _wrappers (sem_Nonterminals _nonts) _pragmas _manualAttrOrderMap _paramMap _contextMap) +-- semantic domain +newtype T_Grammar = T_Grammar (Options -> + ( (Seq Error),CGrammar)) +data Inh_Grammar = Inh_Grammar {options_Inh_Grammar :: Options} +data Syn_Grammar = Syn_Grammar {errors_Syn_Grammar :: Seq Error,output_Syn_Grammar :: CGrammar} +wrap_Grammar (T_Grammar sem) (Inh_Grammar _lhsIoptions) = + (let ( _lhsOerrors,_lhsOoutput) = + (sem _lhsIoptions) + in (Syn_Grammar _lhsOerrors _lhsOoutput)) +sem_Grammar_Grammar :: TypeSyns -> + UseMap -> + Derivings -> + (Set NontermIdent) -> + T_Nonterminals -> + PragmaMap -> + AttrOrderMap -> + ParamMap -> + ContextMap -> + T_Grammar +sem_Grammar_Grammar typeSyns_ useMap_ derivings_ wrappers_ (T_Nonterminals nonts_) pragmas_ manualAttrOrderMap_ paramMap_ contextMap_ = + (T_Grammar (\ _lhsIoptions -> + (let _nontsOo_cata :: Bool + _nontsOo_data :: Bool + _nontsOo_sig :: Bool + _nontsOo_sem :: Bool + _nontsOo_rename :: Bool + _nontsOo_newtypes :: Bool + _nontsOo_wantvisit :: Bool + _nontsOo_dovisit :: Bool + _nontsOo_unbox :: Bool + _nontsOo_case :: Bool + _nontsOprefix :: String + _nontsOvcount :: Int + _nontsOmanualAttrDepMap :: AttrOrderMap + _nontsOacount :: Int + _lhsOerrors :: (Seq Error) + _lhsOoutput :: CGrammar + _nontsOallnts :: ([Identifier]) + _nontsOcInterfaceMap :: CInterfaceMap + _nontsOcVisitsMap :: CVisitsMap + _nontsIacount :: Int + _nontsIadditionalDep :: (Seq Edge) + _nontsIaranges :: (Seq (Int,Int,Int)) + _nontsIcNonterminals :: CNonterminals + _nontsIdirectDep :: (Seq Edge) + _nontsIerrors :: (Seq Error) + _nontsIinstDep :: (Seq Edge) + _nontsInonts :: ([(NontermIdent,[ConstructorIdent])]) + _nontsIntattrs :: (Seq (Vertex,NTAttr)) + _nontsIrules :: (Seq (Vertex,CRule)) + _nontsIvcount :: Int + -- "Order.ag"(line 99, column 17) + _nontsOo_cata = + folds _lhsIoptions + -- "Order.ag"(line 99, column 17) + _nontsOo_data = + dataTypes _lhsIoptions + -- "Order.ag"(line 99, column 17) + _nontsOo_sig = + typeSigs _lhsIoptions + -- "Order.ag"(line 99, column 17) + _nontsOo_sem = + semfuns _lhsIoptions + -- "Order.ag"(line 99, column 17) + _nontsOo_rename = + rename _lhsIoptions + -- "Order.ag"(line 99, column 17) + _nontsOo_newtypes = + newtypes _lhsIoptions + -- "Order.ag"(line 99, column 17) + _nontsOo_wantvisit = + visit _lhsIoptions + -- "Order.ag"(line 99, column 17) + _nontsOo_dovisit = + visit _lhsIoptions && null _cyclesErrors + -- "Order.ag"(line 99, column 17) + _nontsOo_unbox = + unbox _lhsIoptions + -- "Order.ag"(line 99, column 17) + _nontsOo_case = + cases _lhsIoptions + -- "Order.ag"(line 99, column 17) + _nontsOprefix = + prefix _lhsIoptions + -- "Order.ag"(line 237, column 15) + _nontsOvcount = + 0 + -- "Order.ag"(line 262, column 7) + _nontsOmanualAttrDepMap = + manualAttrOrderMap_ + -- "Order.ag"(line 365, column 13) + _nontsOacount = + 0 + -- "Order.ag"(line 403, column 13) + _ruleTable = + Array.array (0,_nontsIvcount-1) (Seq.toList _nontsIrules) + -- "Order.ag"(line 404, column 13) + _attrTable = + Array.array (0,_nontsIacount-1) (Seq.toList _nontsIntattrs) + -- "Order.ag"(line 405, column 13) + _attrVertex = + Map.fromList (map swap (Seq.toList _nontsIntattrs)) + -- "Order.ag"(line 406, column 13) + _tdpToTds = + [ (s, maybe (-1) (\v -> findWithErr1 "Grammar.tdpToTds" v _attrVertex) (ntattr cr)) + | (s,cr) <- Seq.toList _nontsIrules] + -- "Order.ag"(line 408, column 13) + _tdsToTdp = + let eq (_,v) (_,v') = v == v' + conv ((s,v):svs) | v == -1 = Nothing + | otherwise = Just (v,s:map fst svs) + in mapMaybe conv (eqClasses eq _tdpToTds) + -- "Order.ag"(line 412, column 13) + _directDep = + Seq.toList (_nontsIdirectDep Seq.<> _nontsIadditionalDep) + -- "Order.ag"(line 413, column 13) + _instDep = + Seq.toList _nontsIinstDep + -- "Order.ag"(line 414, column 13) + _info = + let def [] = -1 + def (v:vs) = v + in Info { tdsToTdp = Array.array (0,_nontsIacount-1) _tdsToTdp + , tdpToTds = Array.array (0,_nontsIvcount-1) _tdpToTds + , attrTable = _attrTable + , ruleTable = _ruleTable + , lmh = Seq.toList _nontsIaranges + , nonts = _nontsInonts + , wraps = wrappers_ + } + -- "Order.ag"(line 425, column 17) + __tup2 = + case computeSequential _info _directDep _instDep of + CycleFree cim cvm -> ( cim + , cvm + , [] + ) + LocalCycle errs -> ( error "No interfaces for AG with local cycles" + , error "No visit sub-sequences for AG with local cycles" + , map (localCycleErr _ruleTable (visit _lhsIoptions)) errs + ) + InstCycle errs -> ( error "No interfaces for AG with cycles through insts" + , error "No visit sub-sequences for AG with cycles through insts" + , map (instCycleErr _ruleTable (visit _lhsIoptions)) errs + ) + DirectCycle errs -> ( error "No interfaces for AG with direct cycles" + , error "No visit sub-sequences for AG with direct cycles" + , directCycleErrs _attrTable _ruleTable (visit _lhsIoptions) errs + ) + InducedCycle cim errs -> ( cim + , error "No visit sub-sequences for AG with induced cycles" + , inducedCycleErrs _attrTable _ruleTable cim errs + ) + -- "Order.ag"(line 425, column 17) + (_cInterfaceMap,_,_) = + __tup2 + -- "Order.ag"(line 425, column 17) + (_,_cVisitsMap,_) = + __tup2 + -- "Order.ag"(line 425, column 17) + (_,_,_cyclesErrors) = + __tup2 + -- "Order.ag"(line 447, column 13) + _lhsOerrors = + (if withCycle _lhsIoptions then Seq.fromList _cyclesErrors else Seq.empty) + Seq.<> _nontsIerrors + -- "Order.ag"(line 479, column 15) + _lhsOoutput = + CGrammar typeSyns_ derivings_ wrappers_ _nontsIcNonterminals pragmas_ paramMap_ contextMap_ + -- "Order.ag"(line 506, column 13) + _nontsOallnts = + map fst (_nontsInonts) + -- copy rule (from local) + _nontsOcInterfaceMap = + _cInterfaceMap + -- copy rule (from local) + _nontsOcVisitsMap = + _cVisitsMap + ( _nontsIacount,_nontsIadditionalDep,_nontsIaranges,_nontsIcNonterminals,_nontsIdirectDep,_nontsIerrors,_nontsIinstDep,_nontsInonts,_nontsIntattrs,_nontsIrules,_nontsIvcount) = + (nonts_ _nontsOacount _nontsOallnts _nontsOcInterfaceMap _nontsOcVisitsMap _nontsOmanualAttrDepMap _nontsOo_case _nontsOo_cata _nontsOo_data _nontsOo_dovisit _nontsOo_newtypes _nontsOo_rename _nontsOo_sem _nontsOo_sig _nontsOo_unbox _nontsOo_wantvisit _nontsOprefix _nontsOvcount) + in ( _lhsOerrors,_lhsOoutput)))) +-- Nonterminal ------------------------------------------------- +{- + visit 0: + inherited attributes: + allnts : [Identifier] + cInterfaceMap : CInterfaceMap + cVisitsMap : CVisitsMap + manualAttrDepMap : AttrOrderMap + o_case : Bool + o_cata : Bool + o_data : Bool + o_dovisit : Bool + o_newtypes : Bool + o_rename : Bool + o_sem : Bool + o_sig : Bool + o_unbox : Bool + o_wantvisit : Bool + prefix : String + chained attributes: + acount : Int + vcount : Int + synthesized attributes: + additionalDep : Seq Edge + aranges : Seq (Int,Int,Int) + cNonterminal : CNonterminal + directDep : Seq Edge + errors : Seq Error + instDep : Seq Edge + nonts : [(NontermIdent,[ConstructorIdent])] + ntattrs : Seq (Vertex,NTAttr) + rules : Seq (Vertex,CRule) + alternatives: + alternative Nonterminal: + child nt : {NontermIdent} + child params : {[Identifier]} + child inh : {Attributes} + child syn : {Attributes} + child prods : Productions + visit 0: + local ntattrs : _ + local cInter : _ +-} +-- cata +sem_Nonterminal :: Nonterminal -> + T_Nonterminal +sem_Nonterminal (Nonterminal _nt _params _inh _syn _prods) = + (sem_Nonterminal_Nonterminal _nt _params _inh _syn (sem_Productions _prods)) +-- semantic domain +newtype T_Nonterminal = T_Nonterminal (Int -> + ([Identifier]) -> + CInterfaceMap -> + CVisitsMap -> + AttrOrderMap -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + String -> + Int -> + ( Int,(Seq Edge),(Seq (Int,Int,Int)),CNonterminal,(Seq Edge),(Seq Error),(Seq Edge),([(NontermIdent,[ConstructorIdent])]),(Seq (Vertex,NTAttr)),(Seq (Vertex,CRule)),Int)) +data Inh_Nonterminal = Inh_Nonterminal {acount_Inh_Nonterminal :: Int,allnts_Inh_Nonterminal :: [Identifier],cInterfaceMap_Inh_Nonterminal :: CInterfaceMap,cVisitsMap_Inh_Nonterminal :: CVisitsMap,manualAttrDepMap_Inh_Nonterminal :: AttrOrderMap,o_case_Inh_Nonterminal :: Bool,o_cata_Inh_Nonterminal :: Bool,o_data_Inh_Nonterminal :: Bool,o_dovisit_Inh_Nonterminal :: Bool,o_newtypes_Inh_Nonterminal :: Bool,o_rename_Inh_Nonterminal :: Bool,o_sem_Inh_Nonterminal :: Bool,o_sig_Inh_Nonterminal :: Bool,o_unbox_Inh_Nonterminal :: Bool,o_wantvisit_Inh_Nonterminal :: Bool,prefix_Inh_Nonterminal :: String,vcount_Inh_Nonterminal :: Int} +data Syn_Nonterminal = Syn_Nonterminal {acount_Syn_Nonterminal :: Int,additionalDep_Syn_Nonterminal :: Seq Edge,aranges_Syn_Nonterminal :: Seq (Int,Int,Int),cNonterminal_Syn_Nonterminal :: CNonterminal,directDep_Syn_Nonterminal :: Seq Edge,errors_Syn_Nonterminal :: Seq Error,instDep_Syn_Nonterminal :: Seq Edge,nonts_Syn_Nonterminal :: [(NontermIdent,[ConstructorIdent])],ntattrs_Syn_Nonterminal :: Seq (Vertex,NTAttr),rules_Syn_Nonterminal :: Seq (Vertex,CRule),vcount_Syn_Nonterminal :: Int} +wrap_Nonterminal (T_Nonterminal sem) (Inh_Nonterminal _lhsIacount _lhsIallnts _lhsIcInterfaceMap _lhsIcVisitsMap _lhsImanualAttrDepMap _lhsIo_case _lhsIo_cata _lhsIo_data _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIvcount) = + (let ( _lhsOacount,_lhsOadditionalDep,_lhsOaranges,_lhsOcNonterminal,_lhsOdirectDep,_lhsOerrors,_lhsOinstDep,_lhsOnonts,_lhsOntattrs,_lhsOrules,_lhsOvcount) = + (sem _lhsIacount _lhsIallnts _lhsIcInterfaceMap _lhsIcVisitsMap _lhsImanualAttrDepMap _lhsIo_case _lhsIo_cata _lhsIo_data _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIvcount) + in (Syn_Nonterminal _lhsOacount _lhsOadditionalDep _lhsOaranges _lhsOcNonterminal _lhsOdirectDep _lhsOerrors _lhsOinstDep _lhsOnonts _lhsOntattrs _lhsOrules _lhsOvcount)) +sem_Nonterminal_Nonterminal :: NontermIdent -> + ([Identifier]) -> + Attributes -> + Attributes -> + T_Productions -> + T_Nonterminal +sem_Nonterminal_Nonterminal nt_ params_ inh_ syn_ (T_Productions prods_) = + (T_Nonterminal (\ _lhsIacount + _lhsIallnts + _lhsIcInterfaceMap + _lhsIcVisitsMap + _lhsImanualAttrDepMap + _lhsIo_case + _lhsIo_cata + _lhsIo_data + _lhsIo_dovisit + _lhsIo_newtypes + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_unbox + _lhsIo_wantvisit + _lhsIprefix + _lhsIvcount -> + (let _prodsOnt :: Identifier + _prodsOinh :: Attributes + _prodsOsyn :: Attributes + _lhsOntattrs :: (Seq (Vertex,NTAttr)) + _lhsOacount :: Int + _lhsOaranges :: (Seq (Int,Int,Int)) + _lhsOnonts :: ([(NontermIdent,[ConstructorIdent])]) + _lhsOcNonterminal :: CNonterminal + _lhsOadditionalDep :: (Seq Edge) + _lhsOdirectDep :: (Seq Edge) + _lhsOerrors :: (Seq Error) + _lhsOinstDep :: (Seq Edge) + _lhsOrules :: (Seq (Vertex,CRule)) + _lhsOvcount :: Int + _prodsOallnts :: ([Identifier]) + _prodsOcVisitsMap :: CVisitsMap + _prodsOmanualAttrDepMap :: AttrOrderMap + _prodsOo_case :: Bool + _prodsOo_cata :: Bool + _prodsOo_dovisit :: Bool + _prodsOo_newtypes :: Bool + _prodsOo_rename :: Bool + _prodsOo_sem :: Bool + _prodsOo_sig :: Bool + _prodsOo_unbox :: Bool + _prodsOo_wantvisit :: Bool + _prodsOprefix :: String + _prodsOvcount :: Int + _prodsIadditionalDep :: (Seq Edge) + _prodsIcProductions :: CProductions + _prodsIcons :: ([ConstructorIdent]) + _prodsIdirectDep :: (Seq Edge) + _prodsIerrors :: (Seq Error) + _prodsIinstDep :: (Seq Edge) + _prodsIrules :: (Seq (Vertex,CRule)) + _prodsIvcount :: Int + -- "Order.ag"(line 73, column 17) + _prodsOnt = + nt_ + -- "Order.ag"(line 76, column 17) + _prodsOinh = + inh_ + -- "Order.ag"(line 77, column 17) + _prodsOsyn = + syn_ + -- "Order.ag"(line 368, column 17) + _ntattrs = + [ NTAInh nt_ inh tp | (inh,tp) <- Map.assocs inh_ ] + ++ [NTASyn nt_ syn tp | (syn,tp) <- Map.assocs syn_ ] + -- "Order.ag"(line 370, column 17) + _lhsOntattrs = + Seq.fromList (zip [_lhsIacount ..] _ntattrs) + -- "Order.ag"(line 371, column 17) + _lhsOacount = + _lhsIacount + Map.size inh_ + Map.size syn_ + -- "Order.ag"(line 372, column 17) + _lhsOaranges = + Seq.single + (_lhsIacount + ,_lhsIacount + Map.size inh_ + ,_lhsIacount + Map.size syn_ + Map.size inh_ - 1) + -- "Order.ag"(line 381, column 19) + _lhsOnonts = + [(nt_,_prodsIcons)] + -- "Order.ag"(line 456, column 19) + _cInter = + if _lhsIo_dovisit + then findWithErr1 "Nonterminal.cInter" nt_ _lhsIcInterfaceMap + else CInterface [CSegment inh_ syn_] + -- "Order.ag"(line 484, column 19) + _lhsOcNonterminal = + CNonterminal nt_ params_ inh_ syn_ _prodsIcProductions _cInter + -- use rule "Order.ag"(line 259, column 71) + _lhsOadditionalDep = + _prodsIadditionalDep + -- use rule "Order.ag"(line 245, column 33) + _lhsOdirectDep = + _prodsIdirectDep + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + _prodsIerrors + -- use rule "Order.ag"(line 292, column 31) + _lhsOinstDep = + _prodsIinstDep + -- use rule "Order.ag"(line 235, column 18) + _lhsOrules = + _prodsIrules + -- copy rule (up) + _lhsOvcount = + _prodsIvcount + -- copy rule (down) + _prodsOallnts = + _lhsIallnts + -- copy rule (down) + _prodsOcVisitsMap = + _lhsIcVisitsMap + -- copy rule (down) + _prodsOmanualAttrDepMap = + _lhsImanualAttrDepMap + -- copy rule (down) + _prodsOo_case = + _lhsIo_case + -- copy rule (down) + _prodsOo_cata = + _lhsIo_cata + -- copy rule (down) + _prodsOo_dovisit = + _lhsIo_dovisit + -- copy rule (down) + _prodsOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _prodsOo_rename = + _lhsIo_rename + -- copy rule (down) + _prodsOo_sem = + _lhsIo_sem + -- copy rule (down) + _prodsOo_sig = + _lhsIo_sig + -- copy rule (down) + _prodsOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _prodsOo_wantvisit = + _lhsIo_wantvisit + -- copy rule (down) + _prodsOprefix = + _lhsIprefix + -- copy rule (down) + _prodsOvcount = + _lhsIvcount + ( _prodsIadditionalDep,_prodsIcProductions,_prodsIcons,_prodsIdirectDep,_prodsIerrors,_prodsIinstDep,_prodsIrules,_prodsIvcount) = + (prods_ _prodsOallnts _prodsOcVisitsMap _prodsOinh _prodsOmanualAttrDepMap _prodsOnt _prodsOo_case _prodsOo_cata _prodsOo_dovisit _prodsOo_newtypes _prodsOo_rename _prodsOo_sem _prodsOo_sig _prodsOo_unbox _prodsOo_wantvisit _prodsOprefix _prodsOsyn _prodsOvcount) + in ( _lhsOacount,_lhsOadditionalDep,_lhsOaranges,_lhsOcNonterminal,_lhsOdirectDep,_lhsOerrors,_lhsOinstDep,_lhsOnonts,_lhsOntattrs,_lhsOrules,_lhsOvcount)))) +-- Nonterminals ------------------------------------------------ +{- + visit 0: + inherited attributes: + allnts : [Identifier] + cInterfaceMap : CInterfaceMap + cVisitsMap : CVisitsMap + manualAttrDepMap : AttrOrderMap + o_case : Bool + o_cata : Bool + o_data : Bool + o_dovisit : Bool + o_newtypes : Bool + o_rename : Bool + o_sem : Bool + o_sig : Bool + o_unbox : Bool + o_wantvisit : Bool + prefix : String + chained attributes: + acount : Int + vcount : Int + synthesized attributes: + additionalDep : Seq Edge + aranges : Seq (Int,Int,Int) + cNonterminals : CNonterminals + directDep : Seq Edge + errors : Seq Error + instDep : Seq Edge + nonts : [(NontermIdent,[ConstructorIdent])] + ntattrs : Seq (Vertex,NTAttr) + rules : Seq (Vertex,CRule) + alternatives: + alternative Cons: + child hd : Nonterminal + child tl : Nonterminals + alternative Nil: +-} +-- cata +sem_Nonterminals :: Nonterminals -> + T_Nonterminals +sem_Nonterminals list = + (Prelude.foldr sem_Nonterminals_Cons sem_Nonterminals_Nil (Prelude.map sem_Nonterminal list)) +-- semantic domain +newtype T_Nonterminals = T_Nonterminals (Int -> + ([Identifier]) -> + CInterfaceMap -> + CVisitsMap -> + AttrOrderMap -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + String -> + Int -> + ( Int,(Seq Edge),(Seq (Int,Int,Int)),CNonterminals,(Seq Edge),(Seq Error),(Seq Edge),([(NontermIdent,[ConstructorIdent])]),(Seq (Vertex,NTAttr)),(Seq (Vertex,CRule)),Int)) +data Inh_Nonterminals = Inh_Nonterminals {acount_Inh_Nonterminals :: Int,allnts_Inh_Nonterminals :: [Identifier],cInterfaceMap_Inh_Nonterminals :: CInterfaceMap,cVisitsMap_Inh_Nonterminals :: CVisitsMap,manualAttrDepMap_Inh_Nonterminals :: AttrOrderMap,o_case_Inh_Nonterminals :: Bool,o_cata_Inh_Nonterminals :: Bool,o_data_Inh_Nonterminals :: Bool,o_dovisit_Inh_Nonterminals :: Bool,o_newtypes_Inh_Nonterminals :: Bool,o_rename_Inh_Nonterminals :: Bool,o_sem_Inh_Nonterminals :: Bool,o_sig_Inh_Nonterminals :: Bool,o_unbox_Inh_Nonterminals :: Bool,o_wantvisit_Inh_Nonterminals :: Bool,prefix_Inh_Nonterminals :: String,vcount_Inh_Nonterminals :: Int} +data Syn_Nonterminals = Syn_Nonterminals {acount_Syn_Nonterminals :: Int,additionalDep_Syn_Nonterminals :: Seq Edge,aranges_Syn_Nonterminals :: Seq (Int,Int,Int),cNonterminals_Syn_Nonterminals :: CNonterminals,directDep_Syn_Nonterminals :: Seq Edge,errors_Syn_Nonterminals :: Seq Error,instDep_Syn_Nonterminals :: Seq Edge,nonts_Syn_Nonterminals :: [(NontermIdent,[ConstructorIdent])],ntattrs_Syn_Nonterminals :: Seq (Vertex,NTAttr),rules_Syn_Nonterminals :: Seq (Vertex,CRule),vcount_Syn_Nonterminals :: Int} +wrap_Nonterminals (T_Nonterminals sem) (Inh_Nonterminals _lhsIacount _lhsIallnts _lhsIcInterfaceMap _lhsIcVisitsMap _lhsImanualAttrDepMap _lhsIo_case _lhsIo_cata _lhsIo_data _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIvcount) = + (let ( _lhsOacount,_lhsOadditionalDep,_lhsOaranges,_lhsOcNonterminals,_lhsOdirectDep,_lhsOerrors,_lhsOinstDep,_lhsOnonts,_lhsOntattrs,_lhsOrules,_lhsOvcount) = + (sem _lhsIacount _lhsIallnts _lhsIcInterfaceMap _lhsIcVisitsMap _lhsImanualAttrDepMap _lhsIo_case _lhsIo_cata _lhsIo_data _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIvcount) + in (Syn_Nonterminals _lhsOacount _lhsOadditionalDep _lhsOaranges _lhsOcNonterminals _lhsOdirectDep _lhsOerrors _lhsOinstDep _lhsOnonts _lhsOntattrs _lhsOrules _lhsOvcount)) +sem_Nonterminals_Cons :: T_Nonterminal -> + T_Nonterminals -> + T_Nonterminals +sem_Nonterminals_Cons (T_Nonterminal hd_) (T_Nonterminals tl_) = + (T_Nonterminals (\ _lhsIacount + _lhsIallnts + _lhsIcInterfaceMap + _lhsIcVisitsMap + _lhsImanualAttrDepMap + _lhsIo_case + _lhsIo_cata + _lhsIo_data + _lhsIo_dovisit + _lhsIo_newtypes + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_unbox + _lhsIo_wantvisit + _lhsIprefix + _lhsIvcount -> + (let _lhsOcNonterminals :: CNonterminals + _lhsOadditionalDep :: (Seq Edge) + _lhsOaranges :: (Seq (Int,Int,Int)) + _lhsOdirectDep :: (Seq Edge) + _lhsOerrors :: (Seq Error) + _lhsOinstDep :: (Seq Edge) + _lhsOnonts :: ([(NontermIdent,[ConstructorIdent])]) + _lhsOntattrs :: (Seq (Vertex,NTAttr)) + _lhsOrules :: (Seq (Vertex,CRule)) + _lhsOacount :: Int + _lhsOvcount :: Int + _hdOacount :: Int + _hdOallnts :: ([Identifier]) + _hdOcInterfaceMap :: CInterfaceMap + _hdOcVisitsMap :: CVisitsMap + _hdOmanualAttrDepMap :: AttrOrderMap + _hdOo_case :: Bool + _hdOo_cata :: Bool + _hdOo_data :: Bool + _hdOo_dovisit :: Bool + _hdOo_newtypes :: Bool + _hdOo_rename :: Bool + _hdOo_sem :: Bool + _hdOo_sig :: Bool + _hdOo_unbox :: Bool + _hdOo_wantvisit :: Bool + _hdOprefix :: String + _hdOvcount :: Int + _tlOacount :: Int + _tlOallnts :: ([Identifier]) + _tlOcInterfaceMap :: CInterfaceMap + _tlOcVisitsMap :: CVisitsMap + _tlOmanualAttrDepMap :: AttrOrderMap + _tlOo_case :: Bool + _tlOo_cata :: Bool + _tlOo_data :: Bool + _tlOo_dovisit :: Bool + _tlOo_newtypes :: Bool + _tlOo_rename :: Bool + _tlOo_sem :: Bool + _tlOo_sig :: Bool + _tlOo_unbox :: Bool + _tlOo_wantvisit :: Bool + _tlOprefix :: String + _tlOvcount :: Int + _hdIacount :: Int + _hdIadditionalDep :: (Seq Edge) + _hdIaranges :: (Seq (Int,Int,Int)) + _hdIcNonterminal :: CNonterminal + _hdIdirectDep :: (Seq Edge) + _hdIerrors :: (Seq Error) + _hdIinstDep :: (Seq Edge) + _hdInonts :: ([(NontermIdent,[ConstructorIdent])]) + _hdIntattrs :: (Seq (Vertex,NTAttr)) + _hdIrules :: (Seq (Vertex,CRule)) + _hdIvcount :: Int + _tlIacount :: Int + _tlIadditionalDep :: (Seq Edge) + _tlIaranges :: (Seq (Int,Int,Int)) + _tlIcNonterminals :: CNonterminals + _tlIdirectDep :: (Seq Edge) + _tlIerrors :: (Seq Error) + _tlIinstDep :: (Seq Edge) + _tlInonts :: ([(NontermIdent,[ConstructorIdent])]) + _tlIntattrs :: (Seq (Vertex,NTAttr)) + _tlIrules :: (Seq (Vertex,CRule)) + _tlIvcount :: Int + -- "Order.ag"(line 481, column 12) + _lhsOcNonterminals = + _hdIcNonterminal : _tlIcNonterminals + -- use rule "Order.ag"(line 259, column 71) + _lhsOadditionalDep = + _hdIadditionalDep Seq.<> _tlIadditionalDep + -- use rule "Order.ag"(line 362, column 36) + _lhsOaranges = + _hdIaranges Seq.<> _tlIaranges + -- use rule "Order.ag"(line 245, column 33) + _lhsOdirectDep = + _hdIdirectDep Seq.<> _tlIdirectDep + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- use rule "Order.ag"(line 292, column 31) + _lhsOinstDep = + _hdIinstDep Seq.<> _tlIinstDep + -- use rule "Order.ag"(line 379, column 43) + _lhsOnonts = + _hdInonts ++ _tlInonts + -- use rule "Order.ag"(line 361, column 35) + _lhsOntattrs = + _hdIntattrs Seq.<> _tlIntattrs + -- use rule "Order.ag"(line 235, column 18) + _lhsOrules = + _hdIrules Seq.<> _tlIrules + -- copy rule (up) + _lhsOacount = + _tlIacount + -- copy rule (up) + _lhsOvcount = + _tlIvcount + -- copy rule (down) + _hdOacount = + _lhsIacount + -- copy rule (down) + _hdOallnts = + _lhsIallnts + -- copy rule (down) + _hdOcInterfaceMap = + _lhsIcInterfaceMap + -- copy rule (down) + _hdOcVisitsMap = + _lhsIcVisitsMap + -- copy rule (down) + _hdOmanualAttrDepMap = + _lhsImanualAttrDepMap + -- copy rule (down) + _hdOo_case = + _lhsIo_case + -- copy rule (down) + _hdOo_cata = + _lhsIo_cata + -- copy rule (down) + _hdOo_data = + _lhsIo_data + -- copy rule (down) + _hdOo_dovisit = + _lhsIo_dovisit + -- copy rule (down) + _hdOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _hdOo_rename = + _lhsIo_rename + -- copy rule (down) + _hdOo_sem = + _lhsIo_sem + -- copy rule (down) + _hdOo_sig = + _lhsIo_sig + -- copy rule (down) + _hdOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _hdOo_wantvisit = + _lhsIo_wantvisit + -- copy rule (down) + _hdOprefix = + _lhsIprefix + -- copy rule (down) + _hdOvcount = + _lhsIvcount + -- copy rule (chain) + _tlOacount = + _hdIacount + -- copy rule (down) + _tlOallnts = + _lhsIallnts + -- copy rule (down) + _tlOcInterfaceMap = + _lhsIcInterfaceMap + -- copy rule (down) + _tlOcVisitsMap = + _lhsIcVisitsMap + -- copy rule (down) + _tlOmanualAttrDepMap = + _lhsImanualAttrDepMap + -- copy rule (down) + _tlOo_case = + _lhsIo_case + -- copy rule (down) + _tlOo_cata = + _lhsIo_cata + -- copy rule (down) + _tlOo_data = + _lhsIo_data + -- copy rule (down) + _tlOo_dovisit = + _lhsIo_dovisit + -- copy rule (down) + _tlOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _tlOo_rename = + _lhsIo_rename + -- copy rule (down) + _tlOo_sem = + _lhsIo_sem + -- copy rule (down) + _tlOo_sig = + _lhsIo_sig + -- copy rule (down) + _tlOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _tlOo_wantvisit = + _lhsIo_wantvisit + -- copy rule (down) + _tlOprefix = + _lhsIprefix + -- copy rule (chain) + _tlOvcount = + _hdIvcount + ( _hdIacount,_hdIadditionalDep,_hdIaranges,_hdIcNonterminal,_hdIdirectDep,_hdIerrors,_hdIinstDep,_hdInonts,_hdIntattrs,_hdIrules,_hdIvcount) = + (hd_ _hdOacount _hdOallnts _hdOcInterfaceMap _hdOcVisitsMap _hdOmanualAttrDepMap _hdOo_case _hdOo_cata _hdOo_data _hdOo_dovisit _hdOo_newtypes _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_unbox _hdOo_wantvisit _hdOprefix _hdOvcount) + ( _tlIacount,_tlIadditionalDep,_tlIaranges,_tlIcNonterminals,_tlIdirectDep,_tlIerrors,_tlIinstDep,_tlInonts,_tlIntattrs,_tlIrules,_tlIvcount) = + (tl_ _tlOacount _tlOallnts _tlOcInterfaceMap _tlOcVisitsMap _tlOmanualAttrDepMap _tlOo_case _tlOo_cata _tlOo_data _tlOo_dovisit _tlOo_newtypes _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_unbox _tlOo_wantvisit _tlOprefix _tlOvcount) + in ( _lhsOacount,_lhsOadditionalDep,_lhsOaranges,_lhsOcNonterminals,_lhsOdirectDep,_lhsOerrors,_lhsOinstDep,_lhsOnonts,_lhsOntattrs,_lhsOrules,_lhsOvcount)))) +sem_Nonterminals_Nil :: T_Nonterminals +sem_Nonterminals_Nil = + (T_Nonterminals (\ _lhsIacount + _lhsIallnts + _lhsIcInterfaceMap + _lhsIcVisitsMap + _lhsImanualAttrDepMap + _lhsIo_case + _lhsIo_cata + _lhsIo_data + _lhsIo_dovisit + _lhsIo_newtypes + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_unbox + _lhsIo_wantvisit + _lhsIprefix + _lhsIvcount -> + (let _lhsOcNonterminals :: CNonterminals + _lhsOadditionalDep :: (Seq Edge) + _lhsOaranges :: (Seq (Int,Int,Int)) + _lhsOdirectDep :: (Seq Edge) + _lhsOerrors :: (Seq Error) + _lhsOinstDep :: (Seq Edge) + _lhsOnonts :: ([(NontermIdent,[ConstructorIdent])]) + _lhsOntattrs :: (Seq (Vertex,NTAttr)) + _lhsOrules :: (Seq (Vertex,CRule)) + _lhsOacount :: Int + _lhsOvcount :: Int + -- "Order.ag"(line 482, column 12) + _lhsOcNonterminals = + [] + -- use rule "Order.ag"(line 259, column 71) + _lhsOadditionalDep = + Seq.empty + -- use rule "Order.ag"(line 362, column 36) + _lhsOaranges = + Seq.empty + -- use rule "Order.ag"(line 245, column 33) + _lhsOdirectDep = + Seq.empty + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + Seq.empty + -- use rule "Order.ag"(line 292, column 31) + _lhsOinstDep = + Seq.empty + -- use rule "Order.ag"(line 379, column 43) + _lhsOnonts = + [] + -- use rule "Order.ag"(line 361, column 35) + _lhsOntattrs = + Seq.empty + -- use rule "Order.ag"(line 235, column 18) + _lhsOrules = + Seq.empty + -- copy rule (chain) + _lhsOacount = + _lhsIacount + -- copy rule (chain) + _lhsOvcount = + _lhsIvcount + in ( _lhsOacount,_lhsOadditionalDep,_lhsOaranges,_lhsOcNonterminals,_lhsOdirectDep,_lhsOerrors,_lhsOinstDep,_lhsOnonts,_lhsOntattrs,_lhsOrules,_lhsOvcount)))) +-- Pattern ----------------------------------------------------- +{- + visit 0: + inherited attributes: + allTypeSigs : Map Identifier Type + altAttrs : Map AltAttr Vertex + con : Identifier + inh : Attributes + nt : Identifier + syn : Attributes + synthesized attributes: + copy : SELF + errors : Seq Error + gathAltAttrs : [AltAttr] + instVars : [Identifier] + locVars : [Identifier] + patternAttrs : [(Identifier,Identifier,Bool,Patterns)] + alternatives: + alternative Alias: + child field : {Identifier} + child attr : {Identifier} + child pat : Pattern + child parts : Patterns + visit 0: + local copy : _ + alternative Constr: + child name : {ConstructorIdent} + child pats : Patterns + visit 0: + local copy : _ + alternative Irrefutable: + child pat : Pattern + visit 0: + local copy : _ + alternative Product: + child pos : {Pos} + child pats : Patterns + visit 0: + local copy : _ + alternative Underscore: + child pos : {Pos} + visit 0: + local copy : _ +-} +-- cata +sem_Pattern :: Pattern -> + T_Pattern +sem_Pattern (Alias _field _attr _pat _parts) = + (sem_Pattern_Alias _field _attr (sem_Pattern _pat) (sem_Patterns _parts)) +sem_Pattern (Constr _name _pats) = + (sem_Pattern_Constr _name (sem_Patterns _pats)) +sem_Pattern (Irrefutable _pat) = + (sem_Pattern_Irrefutable (sem_Pattern _pat)) +sem_Pattern (Product _pos _pats) = + (sem_Pattern_Product _pos (sem_Patterns _pats)) +sem_Pattern (Underscore _pos) = + (sem_Pattern_Underscore _pos) +-- semantic domain +newtype T_Pattern = T_Pattern ((Map Identifier Type) -> + (Map AltAttr Vertex) -> + Identifier -> + Attributes -> + Identifier -> + Attributes -> + ( Pattern,(Seq Error),([AltAttr]),([Identifier]),([Identifier]),([(Identifier,Identifier,Bool,Patterns)]))) +data Inh_Pattern = Inh_Pattern {allTypeSigs_Inh_Pattern :: Map Identifier Type,altAttrs_Inh_Pattern :: Map AltAttr Vertex,con_Inh_Pattern :: Identifier,inh_Inh_Pattern :: Attributes,nt_Inh_Pattern :: Identifier,syn_Inh_Pattern :: Attributes} +data Syn_Pattern = Syn_Pattern {copy_Syn_Pattern :: Pattern,errors_Syn_Pattern :: Seq Error,gathAltAttrs_Syn_Pattern :: [AltAttr],instVars_Syn_Pattern :: [Identifier],locVars_Syn_Pattern :: [Identifier],patternAttrs_Syn_Pattern :: [(Identifier,Identifier,Bool,Patterns)]} +wrap_Pattern (T_Pattern sem) (Inh_Pattern _lhsIallTypeSigs _lhsIaltAttrs _lhsIcon _lhsIinh _lhsInt _lhsIsyn) = + (let ( _lhsOcopy,_lhsOerrors,_lhsOgathAltAttrs,_lhsOinstVars,_lhsOlocVars,_lhsOpatternAttrs) = + (sem _lhsIallTypeSigs _lhsIaltAttrs _lhsIcon _lhsIinh _lhsInt _lhsIsyn) + in (Syn_Pattern _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOlocVars _lhsOpatternAttrs)) +sem_Pattern_Alias :: Identifier -> + Identifier -> + T_Pattern -> + T_Patterns -> + T_Pattern +sem_Pattern_Alias field_ attr_ (T_Pattern pat_) (T_Patterns parts_) = + (T_Pattern (\ _lhsIallTypeSigs + _lhsIaltAttrs + _lhsIcon + _lhsIinh + _lhsInt + _lhsIsyn -> + (let _lhsOgathAltAttrs :: ([AltAttr]) + _lhsOpatternAttrs :: ([(Identifier,Identifier,Bool,Patterns)]) + _lhsOlocVars :: ([Identifier]) + _lhsOinstVars :: ([Identifier]) + _lhsOerrors :: (Seq Error) + _lhsOcopy :: Pattern + _patOallTypeSigs :: (Map Identifier Type) + _patOaltAttrs :: (Map AltAttr Vertex) + _patOcon :: Identifier + _patOinh :: Attributes + _patOnt :: Identifier + _patOsyn :: Attributes + _partsOallTypeSigs :: (Map Identifier Type) + _partsOaltAttrs :: (Map AltAttr Vertex) + _partsOcon :: Identifier + _partsOinh :: Attributes + _partsOnt :: Identifier + _partsOsyn :: Attributes + _patIcopy :: Pattern + _patIerrors :: (Seq Error) + _patIgathAltAttrs :: ([AltAttr]) + _patIinstVars :: ([Identifier]) + _patIlocVars :: ([Identifier]) + _patIpatternAttrs :: ([(Identifier,Identifier,Bool,Patterns)]) + _partsIcopy :: Patterns + _partsIerrors :: (Seq Error) + _partsIgathAltAttrs :: ([AltAttr]) + _partsIinstVars :: ([Identifier]) + _partsIlocVars :: ([Identifier]) + _partsIpatternAttrs :: ([(Identifier,Identifier,Bool,Patterns)]) + -- "Order.ag"(line 160, column 12) + _lhsOgathAltAttrs = + [AltAttr field_ attr_ (field_ == _LOC || field_ == _INST)] + -- "Order.ag"(line 228, column 12) + _lhsOpatternAttrs = + [(field_,attr_,(field_ == _LOC || field_ == _INST),_partsIcopy)] + -- "Order.ag"(line 536, column 14) + _lhsOlocVars = + if field_ == _LOC + then [attr_] + else [] + -- "Order.ag"(line 539, column 14) + _lhsOinstVars = + if field_ == _INST + then [attr_] + else [] + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + _patIerrors Seq.<> _partsIerrors + -- self rule + _copy = + Alias field_ attr_ _patIcopy _partsIcopy + -- self rule + _lhsOcopy = + _copy + -- copy rule (down) + _patOallTypeSigs = + _lhsIallTypeSigs + -- copy rule (down) + _patOaltAttrs = + _lhsIaltAttrs + -- copy rule (down) + _patOcon = + _lhsIcon + -- copy rule (down) + _patOinh = + _lhsIinh + -- copy rule (down) + _patOnt = + _lhsInt + -- copy rule (down) + _patOsyn = + _lhsIsyn + -- copy rule (down) + _partsOallTypeSigs = + _lhsIallTypeSigs + -- copy rule (down) + _partsOaltAttrs = + _lhsIaltAttrs + -- copy rule (down) + _partsOcon = + _lhsIcon + -- copy rule (down) + _partsOinh = + _lhsIinh + -- copy rule (down) + _partsOnt = + _lhsInt + -- copy rule (down) + _partsOsyn = + _lhsIsyn + ( _patIcopy,_patIerrors,_patIgathAltAttrs,_patIinstVars,_patIlocVars,_patIpatternAttrs) = + (pat_ _patOallTypeSigs _patOaltAttrs _patOcon _patOinh _patOnt _patOsyn) + ( _partsIcopy,_partsIerrors,_partsIgathAltAttrs,_partsIinstVars,_partsIlocVars,_partsIpatternAttrs) = + (parts_ _partsOallTypeSigs _partsOaltAttrs _partsOcon _partsOinh _partsOnt _partsOsyn) + in ( _lhsOcopy,_lhsOerrors,_lhsOgathAltAttrs,_lhsOinstVars,_lhsOlocVars,_lhsOpatternAttrs)))) +sem_Pattern_Constr :: ConstructorIdent -> + T_Patterns -> + T_Pattern +sem_Pattern_Constr name_ (T_Patterns pats_) = + (T_Pattern (\ _lhsIallTypeSigs + _lhsIaltAttrs + _lhsIcon + _lhsIinh + _lhsInt + _lhsIsyn -> + (let _lhsOerrors :: (Seq Error) + _lhsOgathAltAttrs :: ([AltAttr]) + _lhsOinstVars :: ([Identifier]) + _lhsOlocVars :: ([Identifier]) + _lhsOpatternAttrs :: ([(Identifier,Identifier,Bool,Patterns)]) + _lhsOcopy :: Pattern + _patsOallTypeSigs :: (Map Identifier Type) + _patsOaltAttrs :: (Map AltAttr Vertex) + _patsOcon :: Identifier + _patsOinh :: Attributes + _patsOnt :: Identifier + _patsOsyn :: Attributes + _patsIcopy :: Patterns + _patsIerrors :: (Seq Error) + _patsIgathAltAttrs :: ([AltAttr]) + _patsIinstVars :: ([Identifier]) + _patsIlocVars :: ([Identifier]) + _patsIpatternAttrs :: ([(Identifier,Identifier,Bool,Patterns)]) + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + _patsIerrors + -- use rule "Order.ag"(line 146, column 68) + _lhsOgathAltAttrs = + _patsIgathAltAttrs + -- use rule "Order.ag"(line 533, column 86) + _lhsOinstVars = + _patsIinstVars + -- use rule "Order.ag"(line 533, column 48) + _lhsOlocVars = + _patsIlocVars + -- use rule "Order.ag"(line 225, column 42) + _lhsOpatternAttrs = + _patsIpatternAttrs + -- self rule + _copy = + Constr name_ _patsIcopy + -- self rule + _lhsOcopy = + _copy + -- copy rule (down) + _patsOallTypeSigs = + _lhsIallTypeSigs + -- copy rule (down) + _patsOaltAttrs = + _lhsIaltAttrs + -- copy rule (down) + _patsOcon = + _lhsIcon + -- copy rule (down) + _patsOinh = + _lhsIinh + -- copy rule (down) + _patsOnt = + _lhsInt + -- copy rule (down) + _patsOsyn = + _lhsIsyn + ( _patsIcopy,_patsIerrors,_patsIgathAltAttrs,_patsIinstVars,_patsIlocVars,_patsIpatternAttrs) = + (pats_ _patsOallTypeSigs _patsOaltAttrs _patsOcon _patsOinh _patsOnt _patsOsyn) + in ( _lhsOcopy,_lhsOerrors,_lhsOgathAltAttrs,_lhsOinstVars,_lhsOlocVars,_lhsOpatternAttrs)))) +sem_Pattern_Irrefutable :: T_Pattern -> + T_Pattern +sem_Pattern_Irrefutable (T_Pattern pat_) = + (T_Pattern (\ _lhsIallTypeSigs + _lhsIaltAttrs + _lhsIcon + _lhsIinh + _lhsInt + _lhsIsyn -> + (let _lhsOerrors :: (Seq Error) + _lhsOgathAltAttrs :: ([AltAttr]) + _lhsOinstVars :: ([Identifier]) + _lhsOlocVars :: ([Identifier]) + _lhsOpatternAttrs :: ([(Identifier,Identifier,Bool,Patterns)]) + _lhsOcopy :: Pattern + _patOallTypeSigs :: (Map Identifier Type) + _patOaltAttrs :: (Map AltAttr Vertex) + _patOcon :: Identifier + _patOinh :: Attributes + _patOnt :: Identifier + _patOsyn :: Attributes + _patIcopy :: Pattern + _patIerrors :: (Seq Error) + _patIgathAltAttrs :: ([AltAttr]) + _patIinstVars :: ([Identifier]) + _patIlocVars :: ([Identifier]) + _patIpatternAttrs :: ([(Identifier,Identifier,Bool,Patterns)]) + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + _patIerrors + -- use rule "Order.ag"(line 146, column 68) + _lhsOgathAltAttrs = + _patIgathAltAttrs + -- use rule "Order.ag"(line 533, column 86) + _lhsOinstVars = + _patIinstVars + -- use rule "Order.ag"(line 533, column 48) + _lhsOlocVars = + _patIlocVars + -- use rule "Order.ag"(line 225, column 42) + _lhsOpatternAttrs = + _patIpatternAttrs + -- self rule + _copy = + Irrefutable _patIcopy + -- self rule + _lhsOcopy = + _copy + -- copy rule (down) + _patOallTypeSigs = + _lhsIallTypeSigs + -- copy rule (down) + _patOaltAttrs = + _lhsIaltAttrs + -- copy rule (down) + _patOcon = + _lhsIcon + -- copy rule (down) + _patOinh = + _lhsIinh + -- copy rule (down) + _patOnt = + _lhsInt + -- copy rule (down) + _patOsyn = + _lhsIsyn + ( _patIcopy,_patIerrors,_patIgathAltAttrs,_patIinstVars,_patIlocVars,_patIpatternAttrs) = + (pat_ _patOallTypeSigs _patOaltAttrs _patOcon _patOinh _patOnt _patOsyn) + in ( _lhsOcopy,_lhsOerrors,_lhsOgathAltAttrs,_lhsOinstVars,_lhsOlocVars,_lhsOpatternAttrs)))) +sem_Pattern_Product :: Pos -> + T_Patterns -> + T_Pattern +sem_Pattern_Product pos_ (T_Patterns pats_) = + (T_Pattern (\ _lhsIallTypeSigs + _lhsIaltAttrs + _lhsIcon + _lhsIinh + _lhsInt + _lhsIsyn -> + (let _lhsOerrors :: (Seq Error) + _lhsOgathAltAttrs :: ([AltAttr]) + _lhsOinstVars :: ([Identifier]) + _lhsOlocVars :: ([Identifier]) + _lhsOpatternAttrs :: ([(Identifier,Identifier,Bool,Patterns)]) + _lhsOcopy :: Pattern + _patsOallTypeSigs :: (Map Identifier Type) + _patsOaltAttrs :: (Map AltAttr Vertex) + _patsOcon :: Identifier + _patsOinh :: Attributes + _patsOnt :: Identifier + _patsOsyn :: Attributes + _patsIcopy :: Patterns + _patsIerrors :: (Seq Error) + _patsIgathAltAttrs :: ([AltAttr]) + _patsIinstVars :: ([Identifier]) + _patsIlocVars :: ([Identifier]) + _patsIpatternAttrs :: ([(Identifier,Identifier,Bool,Patterns)]) + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + _patsIerrors + -- use rule "Order.ag"(line 146, column 68) + _lhsOgathAltAttrs = + _patsIgathAltAttrs + -- use rule "Order.ag"(line 533, column 86) + _lhsOinstVars = + _patsIinstVars + -- use rule "Order.ag"(line 533, column 48) + _lhsOlocVars = + _patsIlocVars + -- use rule "Order.ag"(line 225, column 42) + _lhsOpatternAttrs = + _patsIpatternAttrs + -- self rule + _copy = + Product pos_ _patsIcopy + -- self rule + _lhsOcopy = + _copy + -- copy rule (down) + _patsOallTypeSigs = + _lhsIallTypeSigs + -- copy rule (down) + _patsOaltAttrs = + _lhsIaltAttrs + -- copy rule (down) + _patsOcon = + _lhsIcon + -- copy rule (down) + _patsOinh = + _lhsIinh + -- copy rule (down) + _patsOnt = + _lhsInt + -- copy rule (down) + _patsOsyn = + _lhsIsyn + ( _patsIcopy,_patsIerrors,_patsIgathAltAttrs,_patsIinstVars,_patsIlocVars,_patsIpatternAttrs) = + (pats_ _patsOallTypeSigs _patsOaltAttrs _patsOcon _patsOinh _patsOnt _patsOsyn) + in ( _lhsOcopy,_lhsOerrors,_lhsOgathAltAttrs,_lhsOinstVars,_lhsOlocVars,_lhsOpatternAttrs)))) +sem_Pattern_Underscore :: Pos -> + T_Pattern +sem_Pattern_Underscore pos_ = + (T_Pattern (\ _lhsIallTypeSigs + _lhsIaltAttrs + _lhsIcon + _lhsIinh + _lhsInt + _lhsIsyn -> + (let _lhsOerrors :: (Seq Error) + _lhsOgathAltAttrs :: ([AltAttr]) + _lhsOinstVars :: ([Identifier]) + _lhsOlocVars :: ([Identifier]) + _lhsOpatternAttrs :: ([(Identifier,Identifier,Bool,Patterns)]) + _lhsOcopy :: Pattern + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + Seq.empty + -- use rule "Order.ag"(line 146, column 68) + _lhsOgathAltAttrs = + [] + -- use rule "Order.ag"(line 533, column 86) + _lhsOinstVars = + [] + -- use rule "Order.ag"(line 533, column 48) + _lhsOlocVars = + [] + -- use rule "Order.ag"(line 225, column 42) + _lhsOpatternAttrs = + [] + -- self rule + _copy = + Underscore pos_ + -- self rule + _lhsOcopy = + _copy + in ( _lhsOcopy,_lhsOerrors,_lhsOgathAltAttrs,_lhsOinstVars,_lhsOlocVars,_lhsOpatternAttrs)))) +-- Patterns ---------------------------------------------------- +{- + visit 0: + inherited attributes: + allTypeSigs : Map Identifier Type + altAttrs : Map AltAttr Vertex + con : Identifier + inh : Attributes + nt : Identifier + syn : Attributes + synthesized attributes: + copy : SELF + errors : Seq Error + gathAltAttrs : [AltAttr] + instVars : [Identifier] + locVars : [Identifier] + patternAttrs : [(Identifier,Identifier,Bool,Patterns)] + alternatives: + alternative Cons: + child hd : Pattern + child tl : Patterns + visit 0: + local copy : _ + alternative Nil: + visit 0: + local copy : _ +-} +-- cata +sem_Patterns :: Patterns -> + T_Patterns +sem_Patterns list = + (Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list)) +-- semantic domain +newtype T_Patterns = T_Patterns ((Map Identifier Type) -> + (Map AltAttr Vertex) -> + Identifier -> + Attributes -> + Identifier -> + Attributes -> + ( Patterns,(Seq Error),([AltAttr]),([Identifier]),([Identifier]),([(Identifier,Identifier,Bool,Patterns)]))) +data Inh_Patterns = Inh_Patterns {allTypeSigs_Inh_Patterns :: Map Identifier Type,altAttrs_Inh_Patterns :: Map AltAttr Vertex,con_Inh_Patterns :: Identifier,inh_Inh_Patterns :: Attributes,nt_Inh_Patterns :: Identifier,syn_Inh_Patterns :: Attributes} +data Syn_Patterns = Syn_Patterns {copy_Syn_Patterns :: Patterns,errors_Syn_Patterns :: Seq Error,gathAltAttrs_Syn_Patterns :: [AltAttr],instVars_Syn_Patterns :: [Identifier],locVars_Syn_Patterns :: [Identifier],patternAttrs_Syn_Patterns :: [(Identifier,Identifier,Bool,Patterns)]} +wrap_Patterns (T_Patterns sem) (Inh_Patterns _lhsIallTypeSigs _lhsIaltAttrs _lhsIcon _lhsIinh _lhsInt _lhsIsyn) = + (let ( _lhsOcopy,_lhsOerrors,_lhsOgathAltAttrs,_lhsOinstVars,_lhsOlocVars,_lhsOpatternAttrs) = + (sem _lhsIallTypeSigs _lhsIaltAttrs _lhsIcon _lhsIinh _lhsInt _lhsIsyn) + in (Syn_Patterns _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOlocVars _lhsOpatternAttrs)) +sem_Patterns_Cons :: T_Pattern -> + T_Patterns -> + T_Patterns +sem_Patterns_Cons (T_Pattern hd_) (T_Patterns tl_) = + (T_Patterns (\ _lhsIallTypeSigs + _lhsIaltAttrs + _lhsIcon + _lhsIinh + _lhsInt + _lhsIsyn -> + (let _lhsOerrors :: (Seq Error) + _lhsOgathAltAttrs :: ([AltAttr]) + _lhsOinstVars :: ([Identifier]) + _lhsOlocVars :: ([Identifier]) + _lhsOpatternAttrs :: ([(Identifier,Identifier,Bool,Patterns)]) + _lhsOcopy :: Patterns + _hdOallTypeSigs :: (Map Identifier Type) + _hdOaltAttrs :: (Map AltAttr Vertex) + _hdOcon :: Identifier + _hdOinh :: Attributes + _hdOnt :: Identifier + _hdOsyn :: Attributes + _tlOallTypeSigs :: (Map Identifier Type) + _tlOaltAttrs :: (Map AltAttr Vertex) + _tlOcon :: Identifier + _tlOinh :: Attributes + _tlOnt :: Identifier + _tlOsyn :: Attributes + _hdIcopy :: Pattern + _hdIerrors :: (Seq Error) + _hdIgathAltAttrs :: ([AltAttr]) + _hdIinstVars :: ([Identifier]) + _hdIlocVars :: ([Identifier]) + _hdIpatternAttrs :: ([(Identifier,Identifier,Bool,Patterns)]) + _tlIcopy :: Patterns + _tlIerrors :: (Seq Error) + _tlIgathAltAttrs :: ([AltAttr]) + _tlIinstVars :: ([Identifier]) + _tlIlocVars :: ([Identifier]) + _tlIpatternAttrs :: ([(Identifier,Identifier,Bool,Patterns)]) + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- use rule "Order.ag"(line 146, column 68) + _lhsOgathAltAttrs = + _hdIgathAltAttrs ++ _tlIgathAltAttrs + -- use rule "Order.ag"(line 533, column 86) + _lhsOinstVars = + _hdIinstVars ++ _tlIinstVars + -- use rule "Order.ag"(line 533, column 48) + _lhsOlocVars = + _hdIlocVars ++ _tlIlocVars + -- use rule "Order.ag"(line 225, column 42) + _lhsOpatternAttrs = + _hdIpatternAttrs ++ _tlIpatternAttrs + -- self rule + _copy = + (:) _hdIcopy _tlIcopy + -- self rule + _lhsOcopy = + _copy + -- copy rule (down) + _hdOallTypeSigs = + _lhsIallTypeSigs + -- copy rule (down) + _hdOaltAttrs = + _lhsIaltAttrs + -- copy rule (down) + _hdOcon = + _lhsIcon + -- copy rule (down) + _hdOinh = + _lhsIinh + -- copy rule (down) + _hdOnt = + _lhsInt + -- copy rule (down) + _hdOsyn = + _lhsIsyn + -- copy rule (down) + _tlOallTypeSigs = + _lhsIallTypeSigs + -- copy rule (down) + _tlOaltAttrs = + _lhsIaltAttrs + -- copy rule (down) + _tlOcon = + _lhsIcon + -- copy rule (down) + _tlOinh = + _lhsIinh + -- copy rule (down) + _tlOnt = + _lhsInt + -- copy rule (down) + _tlOsyn = + _lhsIsyn + ( _hdIcopy,_hdIerrors,_hdIgathAltAttrs,_hdIinstVars,_hdIlocVars,_hdIpatternAttrs) = + (hd_ _hdOallTypeSigs _hdOaltAttrs _hdOcon _hdOinh _hdOnt _hdOsyn) + ( _tlIcopy,_tlIerrors,_tlIgathAltAttrs,_tlIinstVars,_tlIlocVars,_tlIpatternAttrs) = + (tl_ _tlOallTypeSigs _tlOaltAttrs _tlOcon _tlOinh _tlOnt _tlOsyn) + in ( _lhsOcopy,_lhsOerrors,_lhsOgathAltAttrs,_lhsOinstVars,_lhsOlocVars,_lhsOpatternAttrs)))) +sem_Patterns_Nil :: T_Patterns +sem_Patterns_Nil = + (T_Patterns (\ _lhsIallTypeSigs + _lhsIaltAttrs + _lhsIcon + _lhsIinh + _lhsInt + _lhsIsyn -> + (let _lhsOerrors :: (Seq Error) + _lhsOgathAltAttrs :: ([AltAttr]) + _lhsOinstVars :: ([Identifier]) + _lhsOlocVars :: ([Identifier]) + _lhsOpatternAttrs :: ([(Identifier,Identifier,Bool,Patterns)]) + _lhsOcopy :: Patterns + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + Seq.empty + -- use rule "Order.ag"(line 146, column 68) + _lhsOgathAltAttrs = + [] + -- use rule "Order.ag"(line 533, column 86) + _lhsOinstVars = + [] + -- use rule "Order.ag"(line 533, column 48) + _lhsOlocVars = + [] + -- use rule "Order.ag"(line 225, column 42) + _lhsOpatternAttrs = + [] + -- self rule + _copy = + [] + -- self rule + _lhsOcopy = + _copy + in ( _lhsOcopy,_lhsOerrors,_lhsOgathAltAttrs,_lhsOinstVars,_lhsOlocVars,_lhsOpatternAttrs)))) +-- Production -------------------------------------------------- +{- + visit 0: + inherited attributes: + allnts : [Identifier] + cVisitsMap : CVisitsMap + inh : Attributes + manualAttrDepMap : AttrOrderMap + nt : Identifier + o_case : Bool + o_cata : Bool + o_dovisit : Bool + o_newtypes : Bool + o_rename : Bool + o_sem : Bool + o_sig : Bool + o_unbox : Bool + o_wantvisit : Bool + prefix : String + syn : Attributes + chained attribute: + vcount : Int + synthesized attributes: + additionalDep : Seq Edge + cProduction : CProduction + cons : [ConstructorIdent] + directDep : Seq Edge + errors : Seq Error + instDep : Seq Edge + rules : Seq (Vertex,CRule) + alternatives: + alternative Production: + child con : {ConstructorIdent} + child children : Children + child rules : Rules + child typeSigs : TypeSigs + visit 0: + local gathAltAttrs : _ + local inhRules : _ + local gathRules : _ + local cVisits : _ + local allfields : _ + local attrs : _ + local inhnames : _ + local synnames : _ +-} +-- cata +sem_Production :: Production -> + T_Production +sem_Production (Production _con _children _rules _typeSigs) = + (sem_Production_Production _con (sem_Children _children) (sem_Rules _rules) (sem_TypeSigs _typeSigs)) +-- semantic domain +newtype T_Production = T_Production (([Identifier]) -> + CVisitsMap -> + Attributes -> + AttrOrderMap -> + Identifier -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + String -> + Attributes -> + Int -> + ( (Seq Edge),CProduction,([ConstructorIdent]),(Seq Edge),(Seq Error),(Seq Edge),(Seq (Vertex,CRule)),Int)) +data Inh_Production = Inh_Production {allnts_Inh_Production :: [Identifier],cVisitsMap_Inh_Production :: CVisitsMap,inh_Inh_Production :: Attributes,manualAttrDepMap_Inh_Production :: AttrOrderMap,nt_Inh_Production :: Identifier,o_case_Inh_Production :: Bool,o_cata_Inh_Production :: Bool,o_dovisit_Inh_Production :: Bool,o_newtypes_Inh_Production :: Bool,o_rename_Inh_Production :: Bool,o_sem_Inh_Production :: Bool,o_sig_Inh_Production :: Bool,o_unbox_Inh_Production :: Bool,o_wantvisit_Inh_Production :: Bool,prefix_Inh_Production :: String,syn_Inh_Production :: Attributes,vcount_Inh_Production :: Int} +data Syn_Production = Syn_Production {additionalDep_Syn_Production :: Seq Edge,cProduction_Syn_Production :: CProduction,cons_Syn_Production :: [ConstructorIdent],directDep_Syn_Production :: Seq Edge,errors_Syn_Production :: Seq Error,instDep_Syn_Production :: Seq Edge,rules_Syn_Production :: Seq (Vertex,CRule),vcount_Syn_Production :: Int} +wrap_Production (T_Production sem) (Inh_Production _lhsIallnts _lhsIcVisitsMap _lhsIinh _lhsImanualAttrDepMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIvcount) = + (let ( _lhsOadditionalDep,_lhsOcProduction,_lhsOcons,_lhsOdirectDep,_lhsOerrors,_lhsOinstDep,_lhsOrules,_lhsOvcount) = + (sem _lhsIallnts _lhsIcVisitsMap _lhsIinh _lhsImanualAttrDepMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIvcount) + in (Syn_Production _lhsOadditionalDep _lhsOcProduction _lhsOcons _lhsOdirectDep _lhsOerrors _lhsOinstDep _lhsOrules _lhsOvcount)) +sem_Production_Production :: ConstructorIdent -> + T_Children -> + T_Rules -> + T_TypeSigs -> + T_Production +sem_Production_Production con_ (T_Children children_) (T_Rules rules_) (T_TypeSigs typeSigs_) = + (T_Production (\ _lhsIallnts + _lhsIcVisitsMap + _lhsIinh + _lhsImanualAttrDepMap + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_dovisit + _lhsIo_newtypes + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_unbox + _lhsIo_wantvisit + _lhsIprefix + _lhsIsyn + _lhsIvcount -> + (let _childrenOcon :: Identifier + _rulesOcon :: Identifier + _rulesOaltAttrs :: (Map AltAttr Vertex) + _rulesOchildNts :: (Map Identifier NontermIdent) + _rulesOchildInhs :: (Map Identifier Attributes) + _lhsOrules :: (Seq (Vertex,CRule)) + _lhsOvcount :: Int + _rulesOsynsOfChildren :: (Map Identifier Attributes) + _lhsOcons :: ([ConstructorIdent]) + _typeSigsOtypeSigs :: (Map Identifier Type) + _rulesOallTypeSigs :: (Map Identifier Type) + _lhsOcProduction :: CProduction + _lhsOadditionalDep :: (Seq Edge) + _lhsOdirectDep :: (Seq Edge) + _lhsOerrors :: (Seq Error) + _lhsOinstDep :: (Seq Edge) + _childrenOallfields :: ([(Identifier,Type,Bool)]) + _childrenOallnts :: ([Identifier]) + _childrenOattrs :: ([(Identifier,Identifier)]) + _childrenOinh :: Attributes + _childrenOnt :: Identifier + _childrenOo_unbox :: Bool + _childrenOsyn :: Attributes + _rulesOallfields :: ([(Identifier,Type,Bool)]) + _rulesOallnts :: ([Identifier]) + _rulesOattrs :: ([(Identifier,Identifier)]) + _rulesOinh :: Attributes + _rulesOmanualAttrDepMap :: AttrOrderMap + _rulesOnt :: Identifier + _rulesOo_case :: Bool + _rulesOo_cata :: Bool + _rulesOo_dovisit :: Bool + _rulesOo_newtypes :: Bool + _rulesOo_rename :: Bool + _rulesOo_sem :: Bool + _rulesOo_sig :: Bool + _rulesOo_wantvisit :: Bool + _rulesOprefix :: String + _rulesOsyn :: Attributes + _childrenIattributes :: ([(Identifier,Attributes,Attributes)]) + _childrenIcollectChildrenSyns :: (Map Identifier Attributes ) + _childrenIerrors :: (Seq Error) + _childrenIfields :: ([(Identifier,Type,Bool)]) + _childrenIgathAltAttrs :: ([AltAttr]) + _childrenIgathRules :: (Seq CRule) + _childrenIinhs :: (Seq (Identifier,Attributes)) + _childrenInts :: (Seq (Identifier,NontermIdent)) + _childrenIsinglevisits :: ([CRule]) + _childrenIterminals :: ([Identifier]) + _rulesIadditionalDep :: (Seq Edge) + _rulesIdirectDep :: (Seq Edge) + _rulesIerrors :: (Seq Error) + _rulesIgathAltAttrs :: ([AltAttr]) + _rulesIgathRules :: (Seq CRule) + _rulesIinstDep :: (Seq Edge) + _rulesIinstVars :: ([Identifier]) + _rulesIlocVars :: ([Identifier]) + _typeSigsItypeSigs :: (Map Identifier Type) + -- "Order.ag"(line 69, column 16) + _childrenOcon = + con_ + -- "Order.ag"(line 71, column 16) + _rulesOcon = + con_ + -- "Order.ag"(line 148, column 18) + _gathAltAttrs = + [ AltAttr _LHS inh True | inh <- Map.keys _lhsIinh ] + ++ _childrenIgathAltAttrs + ++ _rulesIgathAltAttrs + -- "Order.ag"(line 164, column 17) + _rulesOaltAttrs = + Map.fromList (zip _gathAltAttrs [_lhsIvcount..]) + -- "Order.ag"(line 177, column 18) + _rulesOchildNts = + Map.fromList (Seq.toList _childrenInts) + -- "Order.ag"(line 178, column 19) + _rulesOchildInhs = + Map.fromList (Seq.toList _childrenIinhs) + -- "Order.ag"(line 184, column 18) + _inhRules = + [ cRuleLhsInh inh _lhsInt con_ tp | (inh,tp) <- Map.assocs _lhsIinh ] + -- "Order.ag"(line 185, column 19) + _gathRules = + _inhRules ++ Seq.toList (_childrenIgathRules Seq.<> _rulesIgathRules) + -- "Order.ag"(line 239, column 18) + _lhsOrules = + Seq.fromList (zip [_lhsIvcount..] _gathRules) + -- "Order.ag"(line 240, column 19) + _lhsOvcount = + _lhsIvcount + length _gathRules + -- "Order.ag"(line 309, column 17) + _rulesOsynsOfChildren = + _childrenIcollectChildrenSyns + -- "Order.ag"(line 384, column 18) + _lhsOcons = + [con_] + -- "Order.ag"(line 391, column 16) + _typeSigsOtypeSigs = + Map.empty + -- "Order.ag"(line 397, column 17) + _rulesOallTypeSigs = + _typeSigsItypeSigs + -- "Order.ag"(line 463, column 17) + _cVisits = + if _lhsIo_dovisit + then let prodsVisitsMap = findWithErr1 "Production.cVisits.nt" _lhsInt _lhsIcVisitsMap + visits = findWithErr1 "Production.cVisits.con" con_ prodsVisitsMap + in visits + else let vss = nubBy eqCRuleDefines _gathRules ++ _childrenIsinglevisits + in [CVisit _lhsIinh _lhsIsyn vss [] False] + -- "Order.ag"(line 489, column 18) + _lhsOcProduction = + CProduction con_ _cVisits _childrenIfields _childrenIterminals + -- "Order.ag"(line 513, column 16) + _allfields = + _childrenIfields + -- "Order.ag"(line 513, column 16) + _attrs = + map ((,) _LOC) _rulesIlocVars ++ + map ((,) _INST) _rulesIinstVars ++ + map ((,) _LHS) _inhnames ++ + concat [map ((,) nm) (Map.keys as) | (nm,_,as) <- _childrenIattributes] + -- "Order.ag"(line 513, column 16) + _inhnames = + Map.keys _lhsIinh + -- "Order.ag"(line 513, column 16) + _synnames = + Map.keys _lhsIsyn + -- use rule "Order.ag"(line 259, column 71) + _lhsOadditionalDep = + _rulesIadditionalDep + -- use rule "Order.ag"(line 245, column 33) + _lhsOdirectDep = + _rulesIdirectDep + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + _childrenIerrors Seq.<> _rulesIerrors + -- use rule "Order.ag"(line 292, column 31) + _lhsOinstDep = + _rulesIinstDep + -- copy rule (from local) + _childrenOallfields = + _allfields + -- copy rule (down) + _childrenOallnts = + _lhsIallnts + -- copy rule (from local) + _childrenOattrs = + _attrs + -- copy rule (down) + _childrenOinh = + _lhsIinh + -- copy rule (down) + _childrenOnt = + _lhsInt + -- copy rule (down) + _childrenOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _childrenOsyn = + _lhsIsyn + -- copy rule (from local) + _rulesOallfields = + _allfields + -- copy rule (down) + _rulesOallnts = + _lhsIallnts + -- copy rule (from local) + _rulesOattrs = + _attrs + -- copy rule (down) + _rulesOinh = + _lhsIinh + -- copy rule (down) + _rulesOmanualAttrDepMap = + _lhsImanualAttrDepMap + -- copy rule (down) + _rulesOnt = + _lhsInt + -- copy rule (down) + _rulesOo_case = + _lhsIo_case + -- copy rule (down) + _rulesOo_cata = + _lhsIo_cata + -- copy rule (down) + _rulesOo_dovisit = + _lhsIo_dovisit + -- copy rule (down) + _rulesOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _rulesOo_rename = + _lhsIo_rename + -- copy rule (down) + _rulesOo_sem = + _lhsIo_sem + -- copy rule (down) + _rulesOo_sig = + _lhsIo_sig + -- copy rule (down) + _rulesOo_wantvisit = + _lhsIo_wantvisit + -- copy rule (down) + _rulesOprefix = + _lhsIprefix + -- copy rule (down) + _rulesOsyn = + _lhsIsyn + ( _childrenIattributes,_childrenIcollectChildrenSyns,_childrenIerrors,_childrenIfields,_childrenIgathAltAttrs,_childrenIgathRules,_childrenIinhs,_childrenInts,_childrenIsinglevisits,_childrenIterminals) = + (children_ _childrenOallfields _childrenOallnts _childrenOattrs _childrenOcon _childrenOinh _childrenOnt _childrenOo_unbox _childrenOsyn) + ( _rulesIadditionalDep,_rulesIdirectDep,_rulesIerrors,_rulesIgathAltAttrs,_rulesIgathRules,_rulesIinstDep,_rulesIinstVars,_rulesIlocVars) = + (rules_ _rulesOallTypeSigs _rulesOallfields _rulesOallnts _rulesOaltAttrs _rulesOattrs _rulesOchildInhs _rulesOchildNts _rulesOcon _rulesOinh _rulesOmanualAttrDepMap _rulesOnt _rulesOo_case _rulesOo_cata _rulesOo_dovisit _rulesOo_newtypes _rulesOo_rename _rulesOo_sem _rulesOo_sig _rulesOo_wantvisit _rulesOprefix _rulesOsyn _rulesOsynsOfChildren) + ( _typeSigsItypeSigs) = + (typeSigs_ _typeSigsOtypeSigs) + in ( _lhsOadditionalDep,_lhsOcProduction,_lhsOcons,_lhsOdirectDep,_lhsOerrors,_lhsOinstDep,_lhsOrules,_lhsOvcount)))) +-- Productions ------------------------------------------------- +{- + visit 0: + inherited attributes: + allnts : [Identifier] + cVisitsMap : CVisitsMap + inh : Attributes + manualAttrDepMap : AttrOrderMap + nt : Identifier + o_case : Bool + o_cata : Bool + o_dovisit : Bool + o_newtypes : Bool + o_rename : Bool + o_sem : Bool + o_sig : Bool + o_unbox : Bool + o_wantvisit : Bool + prefix : String + syn : Attributes + chained attribute: + vcount : Int + synthesized attributes: + additionalDep : Seq Edge + cProductions : CProductions + cons : [ConstructorIdent] + directDep : Seq Edge + errors : Seq Error + instDep : Seq Edge + rules : Seq (Vertex,CRule) + alternatives: + alternative Cons: + child hd : Production + child tl : Productions + alternative Nil: +-} +-- cata +sem_Productions :: Productions -> + T_Productions +sem_Productions list = + (Prelude.foldr sem_Productions_Cons sem_Productions_Nil (Prelude.map sem_Production list)) +-- semantic domain +newtype T_Productions = T_Productions (([Identifier]) -> + CVisitsMap -> + Attributes -> + AttrOrderMap -> + Identifier -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + String -> + Attributes -> + Int -> + ( (Seq Edge),CProductions,([ConstructorIdent]),(Seq Edge),(Seq Error),(Seq Edge),(Seq (Vertex,CRule)),Int)) +data Inh_Productions = Inh_Productions {allnts_Inh_Productions :: [Identifier],cVisitsMap_Inh_Productions :: CVisitsMap,inh_Inh_Productions :: Attributes,manualAttrDepMap_Inh_Productions :: AttrOrderMap,nt_Inh_Productions :: Identifier,o_case_Inh_Productions :: Bool,o_cata_Inh_Productions :: Bool,o_dovisit_Inh_Productions :: Bool,o_newtypes_Inh_Productions :: Bool,o_rename_Inh_Productions :: Bool,o_sem_Inh_Productions :: Bool,o_sig_Inh_Productions :: Bool,o_unbox_Inh_Productions :: Bool,o_wantvisit_Inh_Productions :: Bool,prefix_Inh_Productions :: String,syn_Inh_Productions :: Attributes,vcount_Inh_Productions :: Int} +data Syn_Productions = Syn_Productions {additionalDep_Syn_Productions :: Seq Edge,cProductions_Syn_Productions :: CProductions,cons_Syn_Productions :: [ConstructorIdent],directDep_Syn_Productions :: Seq Edge,errors_Syn_Productions :: Seq Error,instDep_Syn_Productions :: Seq Edge,rules_Syn_Productions :: Seq (Vertex,CRule),vcount_Syn_Productions :: Int} +wrap_Productions (T_Productions sem) (Inh_Productions _lhsIallnts _lhsIcVisitsMap _lhsIinh _lhsImanualAttrDepMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIvcount) = + (let ( _lhsOadditionalDep,_lhsOcProductions,_lhsOcons,_lhsOdirectDep,_lhsOerrors,_lhsOinstDep,_lhsOrules,_lhsOvcount) = + (sem _lhsIallnts _lhsIcVisitsMap _lhsIinh _lhsImanualAttrDepMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIvcount) + in (Syn_Productions _lhsOadditionalDep _lhsOcProductions _lhsOcons _lhsOdirectDep _lhsOerrors _lhsOinstDep _lhsOrules _lhsOvcount)) +sem_Productions_Cons :: T_Production -> + T_Productions -> + T_Productions +sem_Productions_Cons (T_Production hd_) (T_Productions tl_) = + (T_Productions (\ _lhsIallnts + _lhsIcVisitsMap + _lhsIinh + _lhsImanualAttrDepMap + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_dovisit + _lhsIo_newtypes + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_unbox + _lhsIo_wantvisit + _lhsIprefix + _lhsIsyn + _lhsIvcount -> + (let _lhsOcProductions :: CProductions + _lhsOadditionalDep :: (Seq Edge) + _lhsOcons :: ([ConstructorIdent]) + _lhsOdirectDep :: (Seq Edge) + _lhsOerrors :: (Seq Error) + _lhsOinstDep :: (Seq Edge) + _lhsOrules :: (Seq (Vertex,CRule)) + _lhsOvcount :: Int + _hdOallnts :: ([Identifier]) + _hdOcVisitsMap :: CVisitsMap + _hdOinh :: Attributes + _hdOmanualAttrDepMap :: AttrOrderMap + _hdOnt :: Identifier + _hdOo_case :: Bool + _hdOo_cata :: Bool + _hdOo_dovisit :: Bool + _hdOo_newtypes :: Bool + _hdOo_rename :: Bool + _hdOo_sem :: Bool + _hdOo_sig :: Bool + _hdOo_unbox :: Bool + _hdOo_wantvisit :: Bool + _hdOprefix :: String + _hdOsyn :: Attributes + _hdOvcount :: Int + _tlOallnts :: ([Identifier]) + _tlOcVisitsMap :: CVisitsMap + _tlOinh :: Attributes + _tlOmanualAttrDepMap :: AttrOrderMap + _tlOnt :: Identifier + _tlOo_case :: Bool + _tlOo_cata :: Bool + _tlOo_dovisit :: Bool + _tlOo_newtypes :: Bool + _tlOo_rename :: Bool + _tlOo_sem :: Bool + _tlOo_sig :: Bool + _tlOo_unbox :: Bool + _tlOo_wantvisit :: Bool + _tlOprefix :: String + _tlOsyn :: Attributes + _tlOvcount :: Int + _hdIadditionalDep :: (Seq Edge) + _hdIcProduction :: CProduction + _hdIcons :: ([ConstructorIdent]) + _hdIdirectDep :: (Seq Edge) + _hdIerrors :: (Seq Error) + _hdIinstDep :: (Seq Edge) + _hdIrules :: (Seq (Vertex,CRule)) + _hdIvcount :: Int + _tlIadditionalDep :: (Seq Edge) + _tlIcProductions :: CProductions + _tlIcons :: ([ConstructorIdent]) + _tlIdirectDep :: (Seq Edge) + _tlIerrors :: (Seq Error) + _tlIinstDep :: (Seq Edge) + _tlIrules :: (Seq (Vertex,CRule)) + _tlIvcount :: Int + -- "Order.ag"(line 486, column 12) + _lhsOcProductions = + _hdIcProduction : _tlIcProductions + -- use rule "Order.ag"(line 259, column 71) + _lhsOadditionalDep = + _hdIadditionalDep Seq.<> _tlIadditionalDep + -- use rule "Order.ag"(line 382, column 40) + _lhsOcons = + _hdIcons ++ _tlIcons + -- use rule "Order.ag"(line 245, column 33) + _lhsOdirectDep = + _hdIdirectDep Seq.<> _tlIdirectDep + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- use rule "Order.ag"(line 292, column 31) + _lhsOinstDep = + _hdIinstDep Seq.<> _tlIinstDep + -- use rule "Order.ag"(line 235, column 18) + _lhsOrules = + _hdIrules Seq.<> _tlIrules + -- copy rule (up) + _lhsOvcount = + _tlIvcount + -- copy rule (down) + _hdOallnts = + _lhsIallnts + -- copy rule (down) + _hdOcVisitsMap = + _lhsIcVisitsMap + -- copy rule (down) + _hdOinh = + _lhsIinh + -- copy rule (down) + _hdOmanualAttrDepMap = + _lhsImanualAttrDepMap + -- copy rule (down) + _hdOnt = + _lhsInt + -- copy rule (down) + _hdOo_case = + _lhsIo_case + -- copy rule (down) + _hdOo_cata = + _lhsIo_cata + -- copy rule (down) + _hdOo_dovisit = + _lhsIo_dovisit + -- copy rule (down) + _hdOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _hdOo_rename = + _lhsIo_rename + -- copy rule (down) + _hdOo_sem = + _lhsIo_sem + -- copy rule (down) + _hdOo_sig = + _lhsIo_sig + -- copy rule (down) + _hdOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _hdOo_wantvisit = + _lhsIo_wantvisit + -- copy rule (down) + _hdOprefix = + _lhsIprefix + -- copy rule (down) + _hdOsyn = + _lhsIsyn + -- copy rule (down) + _hdOvcount = + _lhsIvcount + -- copy rule (down) + _tlOallnts = + _lhsIallnts + -- copy rule (down) + _tlOcVisitsMap = + _lhsIcVisitsMap + -- copy rule (down) + _tlOinh = + _lhsIinh + -- copy rule (down) + _tlOmanualAttrDepMap = + _lhsImanualAttrDepMap + -- copy rule (down) + _tlOnt = + _lhsInt + -- copy rule (down) + _tlOo_case = + _lhsIo_case + -- copy rule (down) + _tlOo_cata = + _lhsIo_cata + -- copy rule (down) + _tlOo_dovisit = + _lhsIo_dovisit + -- copy rule (down) + _tlOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _tlOo_rename = + _lhsIo_rename + -- copy rule (down) + _tlOo_sem = + _lhsIo_sem + -- copy rule (down) + _tlOo_sig = + _lhsIo_sig + -- copy rule (down) + _tlOo_unbox = + _lhsIo_unbox + -- copy rule (down) + _tlOo_wantvisit = + _lhsIo_wantvisit + -- copy rule (down) + _tlOprefix = + _lhsIprefix + -- copy rule (down) + _tlOsyn = + _lhsIsyn + -- copy rule (chain) + _tlOvcount = + _hdIvcount + ( _hdIadditionalDep,_hdIcProduction,_hdIcons,_hdIdirectDep,_hdIerrors,_hdIinstDep,_hdIrules,_hdIvcount) = + (hd_ _hdOallnts _hdOcVisitsMap _hdOinh _hdOmanualAttrDepMap _hdOnt _hdOo_case _hdOo_cata _hdOo_dovisit _hdOo_newtypes _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_unbox _hdOo_wantvisit _hdOprefix _hdOsyn _hdOvcount) + ( _tlIadditionalDep,_tlIcProductions,_tlIcons,_tlIdirectDep,_tlIerrors,_tlIinstDep,_tlIrules,_tlIvcount) = + (tl_ _tlOallnts _tlOcVisitsMap _tlOinh _tlOmanualAttrDepMap _tlOnt _tlOo_case _tlOo_cata _tlOo_dovisit _tlOo_newtypes _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_unbox _tlOo_wantvisit _tlOprefix _tlOsyn _tlOvcount) + in ( _lhsOadditionalDep,_lhsOcProductions,_lhsOcons,_lhsOdirectDep,_lhsOerrors,_lhsOinstDep,_lhsOrules,_lhsOvcount)))) +sem_Productions_Nil :: T_Productions +sem_Productions_Nil = + (T_Productions (\ _lhsIallnts + _lhsIcVisitsMap + _lhsIinh + _lhsImanualAttrDepMap + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_dovisit + _lhsIo_newtypes + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_unbox + _lhsIo_wantvisit + _lhsIprefix + _lhsIsyn + _lhsIvcount -> + (let _lhsOcProductions :: CProductions + _lhsOadditionalDep :: (Seq Edge) + _lhsOcons :: ([ConstructorIdent]) + _lhsOdirectDep :: (Seq Edge) + _lhsOerrors :: (Seq Error) + _lhsOinstDep :: (Seq Edge) + _lhsOrules :: (Seq (Vertex,CRule)) + _lhsOvcount :: Int + -- "Order.ag"(line 487, column 12) + _lhsOcProductions = + [] + -- use rule "Order.ag"(line 259, column 71) + _lhsOadditionalDep = + Seq.empty + -- use rule "Order.ag"(line 382, column 40) + _lhsOcons = + [] + -- use rule "Order.ag"(line 245, column 33) + _lhsOdirectDep = + Seq.empty + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + Seq.empty + -- use rule "Order.ag"(line 292, column 31) + _lhsOinstDep = + Seq.empty + -- use rule "Order.ag"(line 235, column 18) + _lhsOrules = + Seq.empty + -- copy rule (chain) + _lhsOvcount = + _lhsIvcount + in ( _lhsOadditionalDep,_lhsOcProductions,_lhsOcons,_lhsOdirectDep,_lhsOerrors,_lhsOinstDep,_lhsOrules,_lhsOvcount)))) +-- Rule -------------------------------------------------------- +{- + visit 0: + inherited attributes: + allTypeSigs : Map Identifier Type + allfields : [(Identifier,Type,Bool)] + allnts : [Identifier] + altAttrs : Map AltAttr Vertex + attrs : [(Identifier,Identifier)] + childInhs : Map Identifier Attributes + childNts : Map Identifier NontermIdent + con : Identifier + inh : Attributes + manualAttrDepMap : AttrOrderMap + nt : Identifier + o_case : Bool + o_cata : Bool + o_dovisit : Bool + o_newtypes : Bool + o_rename : Bool + o_sem : Bool + o_sig : Bool + o_wantvisit : Bool + prefix : String + syn : Attributes + synsOfChildren : Map Identifier Attributes + synthesized attributes: + additionalDep : Seq Edge + directDep : Seq Edge + errors : Seq Error + gathAltAttrs : [AltAttr] + gathRules : Seq CRule + instDep : Seq Edge + instVars : [Identifier] + locVars : [Identifier] + alternatives: + alternative Rule: + child pattern : Pattern + child rhs : Expression + child owrt : {Bool} + child origin : {String} + visit 0: + local defines : _ + local gathRules : _ + local manualDeps : _ +-} +-- cata +sem_Rule :: Rule -> + T_Rule +sem_Rule (Rule _pattern _rhs _owrt _origin) = + (sem_Rule_Rule (sem_Pattern _pattern) (sem_Expression _rhs) _owrt _origin) +-- semantic domain +newtype T_Rule = T_Rule ((Map Identifier Type) -> + ([(Identifier,Type,Bool)]) -> + ([Identifier]) -> + (Map AltAttr Vertex) -> + ([(Identifier,Identifier)]) -> + (Map Identifier Attributes) -> + (Map Identifier NontermIdent) -> + Identifier -> + Attributes -> + AttrOrderMap -> + Identifier -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + String -> + Attributes -> + (Map Identifier Attributes) -> + ( (Seq Edge),(Seq Edge),(Seq Error),([AltAttr]),(Seq CRule),(Seq Edge),([Identifier]),([Identifier]))) +data Inh_Rule = Inh_Rule {allTypeSigs_Inh_Rule :: Map Identifier Type,allfields_Inh_Rule :: [(Identifier,Type,Bool)],allnts_Inh_Rule :: [Identifier],altAttrs_Inh_Rule :: Map AltAttr Vertex,attrs_Inh_Rule :: [(Identifier,Identifier)],childInhs_Inh_Rule :: Map Identifier Attributes,childNts_Inh_Rule :: Map Identifier NontermIdent,con_Inh_Rule :: Identifier,inh_Inh_Rule :: Attributes,manualAttrDepMap_Inh_Rule :: AttrOrderMap,nt_Inh_Rule :: Identifier,o_case_Inh_Rule :: Bool,o_cata_Inh_Rule :: Bool,o_dovisit_Inh_Rule :: Bool,o_newtypes_Inh_Rule :: Bool,o_rename_Inh_Rule :: Bool,o_sem_Inh_Rule :: Bool,o_sig_Inh_Rule :: Bool,o_wantvisit_Inh_Rule :: Bool,prefix_Inh_Rule :: String,syn_Inh_Rule :: Attributes,synsOfChildren_Inh_Rule :: Map Identifier Attributes} +data Syn_Rule = Syn_Rule {additionalDep_Syn_Rule :: Seq Edge,directDep_Syn_Rule :: Seq Edge,errors_Syn_Rule :: Seq Error,gathAltAttrs_Syn_Rule :: [AltAttr],gathRules_Syn_Rule :: Seq CRule,instDep_Syn_Rule :: Seq Edge,instVars_Syn_Rule :: [Identifier],locVars_Syn_Rule :: [Identifier]} +wrap_Rule (T_Rule sem) (Inh_Rule _lhsIallTypeSigs _lhsIallfields _lhsIallnts _lhsIaltAttrs _lhsIattrs _lhsIchildInhs _lhsIchildNts _lhsIcon _lhsIinh _lhsImanualAttrDepMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIsynsOfChildren) = + (let ( _lhsOadditionalDep,_lhsOdirectDep,_lhsOerrors,_lhsOgathAltAttrs,_lhsOgathRules,_lhsOinstDep,_lhsOinstVars,_lhsOlocVars) = + (sem _lhsIallTypeSigs _lhsIallfields _lhsIallnts _lhsIaltAttrs _lhsIattrs _lhsIchildInhs _lhsIchildNts _lhsIcon _lhsIinh _lhsImanualAttrDepMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIsynsOfChildren) + in (Syn_Rule _lhsOadditionalDep _lhsOdirectDep _lhsOerrors _lhsOgathAltAttrs _lhsOgathRules _lhsOinstDep _lhsOinstVars _lhsOlocVars)) +sem_Rule_Rule :: T_Pattern -> + T_Expression -> + Bool -> + String -> + T_Rule +sem_Rule_Rule (T_Pattern pattern_) (T_Expression rhs_) owrt_ origin_ = + (T_Rule (\ _lhsIallTypeSigs + _lhsIallfields + _lhsIallnts + _lhsIaltAttrs + _lhsIattrs + _lhsIchildInhs + _lhsIchildNts + _lhsIcon + _lhsIinh + _lhsImanualAttrDepMap + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_dovisit + _lhsIo_newtypes + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_wantvisit + _lhsIprefix + _lhsIsyn + _lhsIsynsOfChildren -> + (let _lhsOdirectDep :: (Seq Edge) + _lhsOadditionalDep :: (Seq Edge) + _lhsOinstDep :: (Seq Edge) + _lhsOerrors :: (Seq Error) + _lhsOgathAltAttrs :: ([AltAttr]) + _lhsOgathRules :: (Seq CRule) + _lhsOinstVars :: ([Identifier]) + _lhsOlocVars :: ([Identifier]) + _patternOallTypeSigs :: (Map Identifier Type) + _patternOaltAttrs :: (Map AltAttr Vertex) + _patternOcon :: Identifier + _patternOinh :: Attributes + _patternOnt :: Identifier + _patternOsyn :: Attributes + _rhsOallfields :: ([(Identifier,Type,Bool)]) + _rhsOallnts :: ([Identifier]) + _rhsOattrs :: ([(Identifier,Identifier)]) + _rhsOcon :: Identifier + _rhsOnt :: Identifier + _patternIcopy :: Pattern + _patternIerrors :: (Seq Error) + _patternIgathAltAttrs :: ([AltAttr]) + _patternIinstVars :: ([Identifier]) + _patternIlocVars :: ([Identifier]) + _patternIpatternAttrs :: ([(Identifier,Identifier,Bool,Patterns)]) + _rhsIallRhsVars :: (Set (Identifier,Identifier)) + _rhsIcopy :: Expression + _rhsIerrors :: (Seq Error) + _rhsItextLines :: ([String]) + _rhsIusedAttrs :: ([(Identifier,Identifier)]) + _rhsIusedFields :: ([Identifier]) + _rhsIusedLocals :: ([Identifier]) + -- "Order.ag"(line 193, column 12) + _defines = + let tp field attr parts | field == _LOC || field == _INST + = case parts of + [] -> Map.lookup attr _lhsIallTypeSigs + _ -> (sequence (map typ parts)) >>= (haskellTupel . map (substSelf _lhsInt)) + | field == _LHS = Map.lookup attr _lhsIsyn + | otherwise = Map.lookup attr (findWithErr1 "Rule.defines.tp" field _lhsIchildInhs) + typ :: Pattern -> Maybe Type + typ (Alias field attr _ parts) = tp field attr parts + typ (Underscore _) = Nothing + typ (Product _ pats) = tp _LOC undefined pats + typ _ = Nothing + in Map.fromList [ (findWithErr1 "Rule.defines" aa _lhsIaltAttrs, (field,attr,(tp field attr parts))) + | (field,attr,isLocalOrInst,parts) <- _patternIpatternAttrs + , let aa = AltAttr field attr isLocalOrInst + ] + -- "Order.ag"(line 209, column 12) + _gathRules = + let childnt field = Map.lookup field _lhsIchildNts + in Seq.fromList [ CRule attr False True _lhsInt _lhsIcon field (childnt field) tp _patternIcopy _rhsItextLines _defines owrt_ origin_ _rhsIallRhsVars + | (field,attr,tp) <- Map.elems _defines + ] + -- "Order.ag"(line 247, column 12) + _lhsOdirectDep = + let defined = Map.keys _defines + used = [ Map.lookup (AltAttr field attr True) _lhsIaltAttrs | (field,attr) <- _rhsIusedAttrs] + ++ [ Map.lookup (AltAttr _LOC attr True) _lhsIaltAttrs | attr <- _rhsIusedLocals ++ _rhsIusedFields ] + in Seq.fromList [ (x,y) | Just x <- used, y <- defined ] + -- "Order.ag"(line 265, column 7) + _manualDeps = + Set.toList $ Map.findWithDefault Set.empty _lhsIcon $ Map.findWithDefault Map.empty _lhsInt _lhsImanualAttrDepMap + -- "Order.ag"(line 267, column 7) + _lhsOadditionalDep = + Seq.fromList [ (vertexA, vertexB) + | Dependency (fldA,nmA) (fldB,nmB) <- _manualDeps + , let vertexA = findWithErr2 (AltAttr fldA nmA True) _lhsIaltAttrs + , vertexB <- lookupVertices fldB nmB _lhsIaltAttrs + ] + -- "Order.ag"(line 295, column 7) + _lhsOinstDep = + Seq.fromList $ + [ (instVert, synVert) + | (field,instNm,_) <- Map.elems _defines + , field == _INST + , synNm <- Map.keys (findWithErr2 instNm _lhsIsynsOfChildren) + , let instAttr = AltAttr _INST instNm True + synAttr = AltAttr instNm synNm True + instVert = findWithErr2 instAttr _lhsIaltAttrs + synVert = findWithErr2 synAttr _lhsIaltAttrs + ] + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + _patternIerrors Seq.<> _rhsIerrors + -- use rule "Order.ag"(line 146, column 68) + _lhsOgathAltAttrs = + _patternIgathAltAttrs + -- use rule "Order.ag"(line 182, column 23) + _lhsOgathRules = + _gathRules + -- use rule "Order.ag"(line 533, column 86) + _lhsOinstVars = + _patternIinstVars + -- use rule "Order.ag"(line 533, column 48) + _lhsOlocVars = + _patternIlocVars + -- copy rule (down) + _patternOallTypeSigs = + _lhsIallTypeSigs + -- copy rule (down) + _patternOaltAttrs = + _lhsIaltAttrs + -- copy rule (down) + _patternOcon = + _lhsIcon + -- copy rule (down) + _patternOinh = + _lhsIinh + -- copy rule (down) + _patternOnt = + _lhsInt + -- copy rule (down) + _patternOsyn = + _lhsIsyn + -- copy rule (down) + _rhsOallfields = + _lhsIallfields + -- copy rule (down) + _rhsOallnts = + _lhsIallnts + -- copy rule (down) + _rhsOattrs = + _lhsIattrs + -- copy rule (down) + _rhsOcon = + _lhsIcon + -- copy rule (down) + _rhsOnt = + _lhsInt + ( _patternIcopy,_patternIerrors,_patternIgathAltAttrs,_patternIinstVars,_patternIlocVars,_patternIpatternAttrs) = + (pattern_ _patternOallTypeSigs _patternOaltAttrs _patternOcon _patternOinh _patternOnt _patternOsyn) + ( _rhsIallRhsVars,_rhsIcopy,_rhsIerrors,_rhsItextLines,_rhsIusedAttrs,_rhsIusedFields,_rhsIusedLocals) = + (rhs_ _rhsOallfields _rhsOallnts _rhsOattrs _rhsOcon _rhsOnt) + in ( _lhsOadditionalDep,_lhsOdirectDep,_lhsOerrors,_lhsOgathAltAttrs,_lhsOgathRules,_lhsOinstDep,_lhsOinstVars,_lhsOlocVars)))) +-- Rules ------------------------------------------------------- +{- + visit 0: + inherited attributes: + allTypeSigs : Map Identifier Type + allfields : [(Identifier,Type,Bool)] + allnts : [Identifier] + altAttrs : Map AltAttr Vertex + attrs : [(Identifier,Identifier)] + childInhs : Map Identifier Attributes + childNts : Map Identifier NontermIdent + con : Identifier + inh : Attributes + manualAttrDepMap : AttrOrderMap + nt : Identifier + o_case : Bool + o_cata : Bool + o_dovisit : Bool + o_newtypes : Bool + o_rename : Bool + o_sem : Bool + o_sig : Bool + o_wantvisit : Bool + prefix : String + syn : Attributes + synsOfChildren : Map Identifier Attributes + synthesized attributes: + additionalDep : Seq Edge + directDep : Seq Edge + errors : Seq Error + gathAltAttrs : [AltAttr] + gathRules : Seq CRule + instDep : Seq Edge + instVars : [Identifier] + locVars : [Identifier] + alternatives: + alternative Cons: + child hd : Rule + child tl : Rules + alternative Nil: +-} +-- cata +sem_Rules :: Rules -> + T_Rules +sem_Rules list = + (Prelude.foldr sem_Rules_Cons sem_Rules_Nil (Prelude.map sem_Rule list)) +-- semantic domain +newtype T_Rules = T_Rules ((Map Identifier Type) -> + ([(Identifier,Type,Bool)]) -> + ([Identifier]) -> + (Map AltAttr Vertex) -> + ([(Identifier,Identifier)]) -> + (Map Identifier Attributes) -> + (Map Identifier NontermIdent) -> + Identifier -> + Attributes -> + AttrOrderMap -> + Identifier -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + Bool -> + String -> + Attributes -> + (Map Identifier Attributes) -> + ( (Seq Edge),(Seq Edge),(Seq Error),([AltAttr]),(Seq CRule),(Seq Edge),([Identifier]),([Identifier]))) +data Inh_Rules = Inh_Rules {allTypeSigs_Inh_Rules :: Map Identifier Type,allfields_Inh_Rules :: [(Identifier,Type,Bool)],allnts_Inh_Rules :: [Identifier],altAttrs_Inh_Rules :: Map AltAttr Vertex,attrs_Inh_Rules :: [(Identifier,Identifier)],childInhs_Inh_Rules :: Map Identifier Attributes,childNts_Inh_Rules :: Map Identifier NontermIdent,con_Inh_Rules :: Identifier,inh_Inh_Rules :: Attributes,manualAttrDepMap_Inh_Rules :: AttrOrderMap,nt_Inh_Rules :: Identifier,o_case_Inh_Rules :: Bool,o_cata_Inh_Rules :: Bool,o_dovisit_Inh_Rules :: Bool,o_newtypes_Inh_Rules :: Bool,o_rename_Inh_Rules :: Bool,o_sem_Inh_Rules :: Bool,o_sig_Inh_Rules :: Bool,o_wantvisit_Inh_Rules :: Bool,prefix_Inh_Rules :: String,syn_Inh_Rules :: Attributes,synsOfChildren_Inh_Rules :: Map Identifier Attributes} +data Syn_Rules = Syn_Rules {additionalDep_Syn_Rules :: Seq Edge,directDep_Syn_Rules :: Seq Edge,errors_Syn_Rules :: Seq Error,gathAltAttrs_Syn_Rules :: [AltAttr],gathRules_Syn_Rules :: Seq CRule,instDep_Syn_Rules :: Seq Edge,instVars_Syn_Rules :: [Identifier],locVars_Syn_Rules :: [Identifier]} +wrap_Rules (T_Rules sem) (Inh_Rules _lhsIallTypeSigs _lhsIallfields _lhsIallnts _lhsIaltAttrs _lhsIattrs _lhsIchildInhs _lhsIchildNts _lhsIcon _lhsIinh _lhsImanualAttrDepMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIsynsOfChildren) = + (let ( _lhsOadditionalDep,_lhsOdirectDep,_lhsOerrors,_lhsOgathAltAttrs,_lhsOgathRules,_lhsOinstDep,_lhsOinstVars,_lhsOlocVars) = + (sem _lhsIallTypeSigs _lhsIallfields _lhsIallnts _lhsIaltAttrs _lhsIattrs _lhsIchildInhs _lhsIchildNts _lhsIcon _lhsIinh _lhsImanualAttrDepMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIsynsOfChildren) + in (Syn_Rules _lhsOadditionalDep _lhsOdirectDep _lhsOerrors _lhsOgathAltAttrs _lhsOgathRules _lhsOinstDep _lhsOinstVars _lhsOlocVars)) +sem_Rules_Cons :: T_Rule -> + T_Rules -> + T_Rules +sem_Rules_Cons (T_Rule hd_) (T_Rules tl_) = + (T_Rules (\ _lhsIallTypeSigs + _lhsIallfields + _lhsIallnts + _lhsIaltAttrs + _lhsIattrs + _lhsIchildInhs + _lhsIchildNts + _lhsIcon + _lhsIinh + _lhsImanualAttrDepMap + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_dovisit + _lhsIo_newtypes + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_wantvisit + _lhsIprefix + _lhsIsyn + _lhsIsynsOfChildren -> + (let _lhsOadditionalDep :: (Seq Edge) + _lhsOdirectDep :: (Seq Edge) + _lhsOerrors :: (Seq Error) + _lhsOgathAltAttrs :: ([AltAttr]) + _lhsOgathRules :: (Seq CRule) + _lhsOinstDep :: (Seq Edge) + _lhsOinstVars :: ([Identifier]) + _lhsOlocVars :: ([Identifier]) + _hdOallTypeSigs :: (Map Identifier Type) + _hdOallfields :: ([(Identifier,Type,Bool)]) + _hdOallnts :: ([Identifier]) + _hdOaltAttrs :: (Map AltAttr Vertex) + _hdOattrs :: ([(Identifier,Identifier)]) + _hdOchildInhs :: (Map Identifier Attributes) + _hdOchildNts :: (Map Identifier NontermIdent) + _hdOcon :: Identifier + _hdOinh :: Attributes + _hdOmanualAttrDepMap :: AttrOrderMap + _hdOnt :: Identifier + _hdOo_case :: Bool + _hdOo_cata :: Bool + _hdOo_dovisit :: Bool + _hdOo_newtypes :: Bool + _hdOo_rename :: Bool + _hdOo_sem :: Bool + _hdOo_sig :: Bool + _hdOo_wantvisit :: Bool + _hdOprefix :: String + _hdOsyn :: Attributes + _hdOsynsOfChildren :: (Map Identifier Attributes) + _tlOallTypeSigs :: (Map Identifier Type) + _tlOallfields :: ([(Identifier,Type,Bool)]) + _tlOallnts :: ([Identifier]) + _tlOaltAttrs :: (Map AltAttr Vertex) + _tlOattrs :: ([(Identifier,Identifier)]) + _tlOchildInhs :: (Map Identifier Attributes) + _tlOchildNts :: (Map Identifier NontermIdent) + _tlOcon :: Identifier + _tlOinh :: Attributes + _tlOmanualAttrDepMap :: AttrOrderMap + _tlOnt :: Identifier + _tlOo_case :: Bool + _tlOo_cata :: Bool + _tlOo_dovisit :: Bool + _tlOo_newtypes :: Bool + _tlOo_rename :: Bool + _tlOo_sem :: Bool + _tlOo_sig :: Bool + _tlOo_wantvisit :: Bool + _tlOprefix :: String + _tlOsyn :: Attributes + _tlOsynsOfChildren :: (Map Identifier Attributes) + _hdIadditionalDep :: (Seq Edge) + _hdIdirectDep :: (Seq Edge) + _hdIerrors :: (Seq Error) + _hdIgathAltAttrs :: ([AltAttr]) + _hdIgathRules :: (Seq CRule) + _hdIinstDep :: (Seq Edge) + _hdIinstVars :: ([Identifier]) + _hdIlocVars :: ([Identifier]) + _tlIadditionalDep :: (Seq Edge) + _tlIdirectDep :: (Seq Edge) + _tlIerrors :: (Seq Error) + _tlIgathAltAttrs :: ([AltAttr]) + _tlIgathRules :: (Seq CRule) + _tlIinstDep :: (Seq Edge) + _tlIinstVars :: ([Identifier]) + _tlIlocVars :: ([Identifier]) + -- use rule "Order.ag"(line 259, column 71) + _lhsOadditionalDep = + _hdIadditionalDep Seq.<> _tlIadditionalDep + -- use rule "Order.ag"(line 245, column 33) + _lhsOdirectDep = + _hdIdirectDep Seq.<> _tlIdirectDep + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- use rule "Order.ag"(line 146, column 68) + _lhsOgathAltAttrs = + _hdIgathAltAttrs ++ _tlIgathAltAttrs + -- use rule "Order.ag"(line 182, column 23) + _lhsOgathRules = + _hdIgathRules Seq.<> _tlIgathRules + -- use rule "Order.ag"(line 292, column 31) + _lhsOinstDep = + _hdIinstDep Seq.<> _tlIinstDep + -- use rule "Order.ag"(line 533, column 86) + _lhsOinstVars = + _hdIinstVars ++ _tlIinstVars + -- use rule "Order.ag"(line 533, column 48) + _lhsOlocVars = + _hdIlocVars ++ _tlIlocVars + -- copy rule (down) + _hdOallTypeSigs = + _lhsIallTypeSigs + -- copy rule (down) + _hdOallfields = + _lhsIallfields + -- copy rule (down) + _hdOallnts = + _lhsIallnts + -- copy rule (down) + _hdOaltAttrs = + _lhsIaltAttrs + -- copy rule (down) + _hdOattrs = + _lhsIattrs + -- copy rule (down) + _hdOchildInhs = + _lhsIchildInhs + -- copy rule (down) + _hdOchildNts = + _lhsIchildNts + -- copy rule (down) + _hdOcon = + _lhsIcon + -- copy rule (down) + _hdOinh = + _lhsIinh + -- copy rule (down) + _hdOmanualAttrDepMap = + _lhsImanualAttrDepMap + -- copy rule (down) + _hdOnt = + _lhsInt + -- copy rule (down) + _hdOo_case = + _lhsIo_case + -- copy rule (down) + _hdOo_cata = + _lhsIo_cata + -- copy rule (down) + _hdOo_dovisit = + _lhsIo_dovisit + -- copy rule (down) + _hdOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _hdOo_rename = + _lhsIo_rename + -- copy rule (down) + _hdOo_sem = + _lhsIo_sem + -- copy rule (down) + _hdOo_sig = + _lhsIo_sig + -- copy rule (down) + _hdOo_wantvisit = + _lhsIo_wantvisit + -- copy rule (down) + _hdOprefix = + _lhsIprefix + -- copy rule (down) + _hdOsyn = + _lhsIsyn + -- copy rule (down) + _hdOsynsOfChildren = + _lhsIsynsOfChildren + -- copy rule (down) + _tlOallTypeSigs = + _lhsIallTypeSigs + -- copy rule (down) + _tlOallfields = + _lhsIallfields + -- copy rule (down) + _tlOallnts = + _lhsIallnts + -- copy rule (down) + _tlOaltAttrs = + _lhsIaltAttrs + -- copy rule (down) + _tlOattrs = + _lhsIattrs + -- copy rule (down) + _tlOchildInhs = + _lhsIchildInhs + -- copy rule (down) + _tlOchildNts = + _lhsIchildNts + -- copy rule (down) + _tlOcon = + _lhsIcon + -- copy rule (down) + _tlOinh = + _lhsIinh + -- copy rule (down) + _tlOmanualAttrDepMap = + _lhsImanualAttrDepMap + -- copy rule (down) + _tlOnt = + _lhsInt + -- copy rule (down) + _tlOo_case = + _lhsIo_case + -- copy rule (down) + _tlOo_cata = + _lhsIo_cata + -- copy rule (down) + _tlOo_dovisit = + _lhsIo_dovisit + -- copy rule (down) + _tlOo_newtypes = + _lhsIo_newtypes + -- copy rule (down) + _tlOo_rename = + _lhsIo_rename + -- copy rule (down) + _tlOo_sem = + _lhsIo_sem + -- copy rule (down) + _tlOo_sig = + _lhsIo_sig + -- copy rule (down) + _tlOo_wantvisit = + _lhsIo_wantvisit + -- copy rule (down) + _tlOprefix = + _lhsIprefix + -- copy rule (down) + _tlOsyn = + _lhsIsyn + -- copy rule (down) + _tlOsynsOfChildren = + _lhsIsynsOfChildren + ( _hdIadditionalDep,_hdIdirectDep,_hdIerrors,_hdIgathAltAttrs,_hdIgathRules,_hdIinstDep,_hdIinstVars,_hdIlocVars) = + (hd_ _hdOallTypeSigs _hdOallfields _hdOallnts _hdOaltAttrs _hdOattrs _hdOchildInhs _hdOchildNts _hdOcon _hdOinh _hdOmanualAttrDepMap _hdOnt _hdOo_case _hdOo_cata _hdOo_dovisit _hdOo_newtypes _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_wantvisit _hdOprefix _hdOsyn _hdOsynsOfChildren) + ( _tlIadditionalDep,_tlIdirectDep,_tlIerrors,_tlIgathAltAttrs,_tlIgathRules,_tlIinstDep,_tlIinstVars,_tlIlocVars) = + (tl_ _tlOallTypeSigs _tlOallfields _tlOallnts _tlOaltAttrs _tlOattrs _tlOchildInhs _tlOchildNts _tlOcon _tlOinh _tlOmanualAttrDepMap _tlOnt _tlOo_case _tlOo_cata _tlOo_dovisit _tlOo_newtypes _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_wantvisit _tlOprefix _tlOsyn _tlOsynsOfChildren) + in ( _lhsOadditionalDep,_lhsOdirectDep,_lhsOerrors,_lhsOgathAltAttrs,_lhsOgathRules,_lhsOinstDep,_lhsOinstVars,_lhsOlocVars)))) +sem_Rules_Nil :: T_Rules +sem_Rules_Nil = + (T_Rules (\ _lhsIallTypeSigs + _lhsIallfields + _lhsIallnts + _lhsIaltAttrs + _lhsIattrs + _lhsIchildInhs + _lhsIchildNts + _lhsIcon + _lhsIinh + _lhsImanualAttrDepMap + _lhsInt + _lhsIo_case + _lhsIo_cata + _lhsIo_dovisit + _lhsIo_newtypes + _lhsIo_rename + _lhsIo_sem + _lhsIo_sig + _lhsIo_wantvisit + _lhsIprefix + _lhsIsyn + _lhsIsynsOfChildren -> + (let _lhsOadditionalDep :: (Seq Edge) + _lhsOdirectDep :: (Seq Edge) + _lhsOerrors :: (Seq Error) + _lhsOgathAltAttrs :: ([AltAttr]) + _lhsOgathRules :: (Seq CRule) + _lhsOinstDep :: (Seq Edge) + _lhsOinstVars :: ([Identifier]) + _lhsOlocVars :: ([Identifier]) + -- use rule "Order.ag"(line 259, column 71) + _lhsOadditionalDep = + Seq.empty + -- use rule "Order.ag"(line 245, column 33) + _lhsOdirectDep = + Seq.empty + -- use rule "Order.ag"(line 60, column 70) + _lhsOerrors = + Seq.empty + -- use rule "Order.ag"(line 146, column 68) + _lhsOgathAltAttrs = + [] + -- use rule "Order.ag"(line 182, column 23) + _lhsOgathRules = + Seq.empty + -- use rule "Order.ag"(line 292, column 31) + _lhsOinstDep = + Seq.empty + -- use rule "Order.ag"(line 533, column 86) + _lhsOinstVars = + [] + -- use rule "Order.ag"(line 533, column 48) + _lhsOlocVars = + [] + in ( _lhsOadditionalDep,_lhsOdirectDep,_lhsOerrors,_lhsOgathAltAttrs,_lhsOgathRules,_lhsOinstDep,_lhsOinstVars,_lhsOlocVars)))) +-- TypeSig ----------------------------------------------------- +{- + visit 0: + chained attribute: + typeSigs : Map Identifier Type + alternatives: + alternative TypeSig: + child name : {Identifier} + child tp : {Type} +-} +-- cata +sem_TypeSig :: TypeSig -> + T_TypeSig +sem_TypeSig (TypeSig _name _tp) = + (sem_TypeSig_TypeSig _name _tp) +-- semantic domain +newtype T_TypeSig = T_TypeSig ((Map Identifier Type) -> + ( (Map Identifier Type))) +data Inh_TypeSig = Inh_TypeSig {typeSigs_Inh_TypeSig :: Map Identifier Type} +data Syn_TypeSig = Syn_TypeSig {typeSigs_Syn_TypeSig :: Map Identifier Type} +wrap_TypeSig (T_TypeSig sem) (Inh_TypeSig _lhsItypeSigs) = + (let ( _lhsOtypeSigs) = + (sem _lhsItypeSigs) + in (Syn_TypeSig _lhsOtypeSigs)) +sem_TypeSig_TypeSig :: Identifier -> + Type -> + T_TypeSig +sem_TypeSig_TypeSig name_ tp_ = + (T_TypeSig (\ _lhsItypeSigs -> + (let _lhsOtypeSigs :: (Map Identifier Type) + -- "Order.ag"(line 393, column 13) + _lhsOtypeSigs = + Map.insert name_ tp_ _lhsItypeSigs + in ( _lhsOtypeSigs)))) +-- TypeSigs ---------------------------------------------------- +{- + visit 0: + chained attribute: + typeSigs : Map Identifier Type + alternatives: + alternative Cons: + child hd : TypeSig + child tl : TypeSigs + alternative Nil: +-} +-- cata +sem_TypeSigs :: TypeSigs -> + T_TypeSigs +sem_TypeSigs list = + (Prelude.foldr sem_TypeSigs_Cons sem_TypeSigs_Nil (Prelude.map sem_TypeSig list)) +-- semantic domain +newtype T_TypeSigs = T_TypeSigs ((Map Identifier Type) -> + ( (Map Identifier Type))) +data Inh_TypeSigs = Inh_TypeSigs {typeSigs_Inh_TypeSigs :: Map Identifier Type} +data Syn_TypeSigs = Syn_TypeSigs {typeSigs_Syn_TypeSigs :: Map Identifier Type} +wrap_TypeSigs (T_TypeSigs sem) (Inh_TypeSigs _lhsItypeSigs) = + (let ( _lhsOtypeSigs) = + (sem _lhsItypeSigs) + in (Syn_TypeSigs _lhsOtypeSigs)) +sem_TypeSigs_Cons :: T_TypeSig -> + T_TypeSigs -> + T_TypeSigs +sem_TypeSigs_Cons (T_TypeSig hd_) (T_TypeSigs tl_) = + (T_TypeSigs (\ _lhsItypeSigs -> + (let _lhsOtypeSigs :: (Map Identifier Type) + _hdOtypeSigs :: (Map Identifier Type) + _tlOtypeSigs :: (Map Identifier Type) + _hdItypeSigs :: (Map Identifier Type) + _tlItypeSigs :: (Map Identifier Type) + -- copy rule (up) + _lhsOtypeSigs = + _tlItypeSigs + -- copy rule (down) + _hdOtypeSigs = + _lhsItypeSigs + -- copy rule (chain) + _tlOtypeSigs = + _hdItypeSigs + ( _hdItypeSigs) = + (hd_ _hdOtypeSigs) + ( _tlItypeSigs) = + (tl_ _tlOtypeSigs) + in ( _lhsOtypeSigs)))) +sem_TypeSigs_Nil :: T_TypeSigs +sem_TypeSigs_Nil = + (T_TypeSigs (\ _lhsItypeSigs -> + (let _lhsOtypeSigs :: (Map Identifier Type) + -- copy rule (chain) + _lhsOtypeSigs = + _lhsItypeSigs + in ( _lhsOtypeSigs)))) diff --git a/src-derived/Patterns.hs b/src-derived/Patterns.hs --- a/src-derived/Patterns.hs +++ b/src-derived/Patterns.hs @@ -1,10 +1,9 @@ - -- UUAGC 0.9.5 (Patterns.ag) module Patterns where -- Patterns.ag imports import UU.Scanner.Position(Pos) -import CommonTypes (Constructor,Name) +import CommonTypes (ConstructorIdent,Identifier) -- Pattern ----------------------------------------------------- {- visit 0: @@ -12,17 +11,21 @@ copy : SELF alternatives: alternative Alias: - child field : {Name} - child attr : {Name} + child field : {Identifier} + child attr : {Identifier} child pat : Pattern child parts : Patterns visit 0: local copy : _ alternative Constr: - child name : {Constructor} + child name : {ConstructorIdent} child pats : Patterns visit 0: local copy : _ + alternative Irrefutable: + child pat : Pattern + visit 0: + local copy : _ alternative Product: child pos : {Pos} child pats : Patterns @@ -33,10 +36,11 @@ visit 0: local copy : _ -} -data Pattern = Alias (Name) (Name) (Pattern) (Patterns) - | Constr (Constructor) (Patterns) - | Product (Pos) (Patterns) - | Underscore (Pos) +data Pattern = Alias (Identifier) (Identifier) (Pattern) (Patterns) + | Constr (ConstructorIdent) (Patterns) + | Irrefutable (Pattern) + | Product (Pos) (Patterns) + | Underscore (Pos) deriving ( Show) -- Patterns ---------------------------------------------------- {- diff --git a/src-derived/PrintCode.hs b/src-derived/PrintCode.hs --- a/src-derived/PrintCode.hs +++ b/src-derived/PrintCode.hs @@ -1,2620 +1,2858 @@ - --- UUAGC 0.9.5 (PrintCode.ag) -module PrintCode where - -import Char (isAlphaNum) -import Pretty -import Code -import Patterns -import Options -import CommonTypes (attrname, _LOC, getName, nullIdent) -import Data.List(intersperse) -import System.IO -import System.Directory - -import Pretty -import Patterns -import Data.List(partition) -import Data.Set(Set) -import qualified UU.DData.Set as Set -import Data.Map(Map) -import qualified Data.Map as Map - --- Patterns.ag imports -import UU.Scanner.Position(Pos) -import CommonTypes (Constructor,Name) - -type PP_Docs = [PP_Doc] - -ppMultiSeqH :: [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeqH = ppMultiSeq' (>#<) - -ppMultiSeqV :: [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeqV = ppMultiSeq' (>-<) - -ppMultiSeq' :: (PP_Doc -> PP_Doc -> PP_Doc) -> [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeq' next strictArgs expr - = foldr (\v r -> (v >#< "`seq`") `next` pp_parens r) expr strictArgs - - -reallySimple :: String -> Bool -reallySimple = and . map (\x -> isAlphaNum x || x=='_') - -ppTuple True pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps -ppTuple False pps = "(" >|< pp_block " " ")" "," pps -ppUnboxedTuple True pps = "(# " >|< pp_block " " (concat $ replicate (length pps `max` 1) " #)") ",(# " pps -ppUnboxedTuple False pps = "(# " >|< pp_block " " " #)" "," pps - - -locname' n = "_loc_" ++ getName n - -renderDocs :: [PP_Doc] -> String -renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) "" - -writeModule :: FilePath -> [PP_Doc] -> IO () -writeModule path docs - = do bExists <- doesFileExist path - if bExists - then do input <- readFile path - seq (length input) (return ()) - if input /= output - then dumpIt - else return () - else dumpIt - where - output = renderDocs docs - dumpIt = writeFile path output - --- Unboxed tuples --- unbox Whether unboxed tuples are wanted or not --- inh The inherited attributes. --- If there are none, no unboxing can take place, --- because in that case the semantic function (a top-level identifier) would have an unboxed type. --- Of course we can't have an unboxed 1-tuple -mkTupleExpr :: Bool -> Bool -> Exprs -> Expr -mkTupleExpr unbox noInh exprs | not unbox || noInh || length exprs == 1 = TupleExpr exprs - | otherwise = UnboxedTupleExpr exprs -mkTupleType :: Bool -> Bool -> Types -> Type -mkTupleType unbox noInh tps | not unbox || noInh || length tps == 1 = TupleType tps - | otherwise = UnboxedTupleType tps -mkTupleLhs :: Bool -> Bool -> [String] -> Lhs -mkTupleLhs unbox noInh comps | not unbox || noInh || length comps == 1 = TupleLhs comps - | otherwise = UnboxedTupleLhs comps --- CaseAlt ----------------------------------------------------- -{- - visit 0: - inherited attributes: - nested : Bool - options : Options - outputfile : String - synthesized attribute: - pps : PP_Docs - alternatives: - alternative CaseAlt: - child left : Lhs - child expr : Expr --} --- cata -sem_CaseAlt :: CaseAlt -> - T_CaseAlt -sem_CaseAlt (CaseAlt _left _expr ) = - (sem_CaseAlt_CaseAlt (sem_Lhs _left ) (sem_Expr _expr ) ) --- semantic domain -newtype T_CaseAlt = T_CaseAlt (Bool -> - Options -> - String -> - ( PP_Docs)) -data Inh_CaseAlt = Inh_CaseAlt {nested_Inh_CaseAlt :: Bool,options_Inh_CaseAlt :: Options,outputfile_Inh_CaseAlt :: String} -data Syn_CaseAlt = Syn_CaseAlt {pps_Syn_CaseAlt :: PP_Docs} -wrap_CaseAlt (T_CaseAlt sem ) (Inh_CaseAlt _lhsInested _lhsIoptions _lhsIoutputfile ) = - (let ( _lhsOpps) = - (sem _lhsInested _lhsIoptions _lhsIoutputfile ) - in (Syn_CaseAlt _lhsOpps )) -sem_CaseAlt_CaseAlt :: T_Lhs -> - T_Expr -> - T_CaseAlt -sem_CaseAlt_CaseAlt (T_Lhs left_ ) (T_Expr expr_ ) = - (T_CaseAlt (\ _lhsInested - _lhsIoptions - _lhsIoutputfile -> - (let _lhsOpps :: PP_Docs - _leftOisDeclOfLet :: Bool - _leftOnested :: Bool - _leftOoptions :: Options - _leftOoutputfile :: String - _exprOnested :: Bool - _exprOoptions :: Options - _exprOoutputfile :: String - _leftIpp :: PP_Doc - _exprIpp :: PP_Doc - -- "PrintCode.ag"(line 149, column 16) - _lhsOpps = - ["{" >#< _leftIpp >#< "->", _exprIpp >#< "}"] - -- "PrintCode.ag"(line 303, column 7) - _leftOisDeclOfLet = - False - -- copy rule (down) - _leftOnested = - _lhsInested - -- copy rule (down) - _leftOoptions = - _lhsIoptions - -- copy rule (down) - _leftOoutputfile = - _lhsIoutputfile - -- copy rule (down) - _exprOnested = - _lhsInested - -- copy rule (down) - _exprOoptions = - _lhsIoptions - -- copy rule (down) - _exprOoutputfile = - _lhsIoutputfile - ( _leftIpp) = - (left_ _leftOisDeclOfLet _leftOnested _leftOoptions _leftOoutputfile ) - ( _exprIpp) = - (expr_ _exprOnested _exprOoptions _exprOoutputfile ) - in ( _lhsOpps))) ) --- CaseAlts ---------------------------------------------------- -{- - visit 0: - inherited attributes: - nested : Bool - options : Options - outputfile : String - synthesized attribute: - pps : PP_Docs - alternatives: - alternative Cons: - child hd : CaseAlt - child tl : CaseAlts - alternative Nil: --} --- cata -sem_CaseAlts :: CaseAlts -> - T_CaseAlts -sem_CaseAlts list = - (Prelude.foldr sem_CaseAlts_Cons sem_CaseAlts_Nil (Prelude.map sem_CaseAlt list) ) --- semantic domain -newtype T_CaseAlts = T_CaseAlts (Bool -> - Options -> - String -> - ( PP_Docs)) -data Inh_CaseAlts = Inh_CaseAlts {nested_Inh_CaseAlts :: Bool,options_Inh_CaseAlts :: Options,outputfile_Inh_CaseAlts :: String} -data Syn_CaseAlts = Syn_CaseAlts {pps_Syn_CaseAlts :: PP_Docs} -wrap_CaseAlts (T_CaseAlts sem ) (Inh_CaseAlts _lhsInested _lhsIoptions _lhsIoutputfile ) = - (let ( _lhsOpps) = - (sem _lhsInested _lhsIoptions _lhsIoutputfile ) - in (Syn_CaseAlts _lhsOpps )) -sem_CaseAlts_Cons :: T_CaseAlt -> - T_CaseAlts -> - T_CaseAlts -sem_CaseAlts_Cons (T_CaseAlt hd_ ) (T_CaseAlts tl_ ) = - (T_CaseAlts (\ _lhsInested - _lhsIoptions - _lhsIoutputfile -> - (let _lhsOpps :: PP_Docs - _hdOnested :: Bool - _hdOoptions :: Options - _hdOoutputfile :: String - _tlOnested :: Bool - _tlOoptions :: Options - _tlOoutputfile :: String - _hdIpps :: PP_Docs - _tlIpps :: PP_Docs - -- "PrintCode.ag"(line 59, column 10) - _lhsOpps = - _hdIpps ++ _tlIpps - -- copy rule (down) - _hdOnested = - _lhsInested - -- copy rule (down) - _hdOoptions = - _lhsIoptions - -- copy rule (down) - _hdOoutputfile = - _lhsIoutputfile - -- copy rule (down) - _tlOnested = - _lhsInested - -- copy rule (down) - _tlOoptions = - _lhsIoptions - -- copy rule (down) - _tlOoutputfile = - _lhsIoutputfile - ( _hdIpps) = - (hd_ _hdOnested _hdOoptions _hdOoutputfile ) - ( _tlIpps) = - (tl_ _tlOnested _tlOoptions _tlOoutputfile ) - in ( _lhsOpps))) ) -sem_CaseAlts_Nil :: T_CaseAlts -sem_CaseAlts_Nil = - (T_CaseAlts (\ _lhsInested - _lhsIoptions - _lhsIoutputfile -> - (let _lhsOpps :: PP_Docs - -- "PrintCode.ag"(line 60, column 10) - _lhsOpps = - [] - in ( _lhsOpps))) ) --- Chunk ------------------------------------------------------- -{- - visit 0: - inherited attributes: - importBlocks : PP_Doc - isDeclOfLet : Bool - mainFile : String - mainName : String - moduleHeader : String -> String -> String -> Bool -> String - nested : Bool - options : Options - optionsLine : String - pragmaBlocks : String - textBlocks : PP_Doc - synthesized attributes: - appendCommon : [[PP_Doc]] - appendMain : [[PP_Doc]] - genSems : IO () - imports : [String] - pps : PP_Docs - alternatives: - alternative Chunk: - child name : {String} - child comment : Decl - child info : Decls - child dataDef : Decls - child cataFun : Decls - child semDom : Decls - child semWrapper : Decls - child semFunctions : Decls - child semNames : {[String]} - visit 0: - local outputfile : _ - local exports : _ --} --- cata -sem_Chunk :: Chunk -> - T_Chunk -sem_Chunk (Chunk _name _comment _info _dataDef _cataFun _semDom _semWrapper _semFunctions _semNames ) = - (sem_Chunk_Chunk _name (sem_Decl _comment ) (sem_Decls _info ) (sem_Decls _dataDef ) (sem_Decls _cataFun ) (sem_Decls _semDom ) (sem_Decls _semWrapper ) (sem_Decls _semFunctions ) _semNames ) --- semantic domain -newtype T_Chunk = T_Chunk (PP_Doc -> - Bool -> - String -> - String -> - (String -> String -> String -> Bool -> String) -> - Bool -> - Options -> - String -> - String -> - PP_Doc -> - ( ([[PP_Doc]]),([[PP_Doc]]),(IO ()),([String]),PP_Docs)) -data Inh_Chunk = Inh_Chunk {importBlocks_Inh_Chunk :: PP_Doc,isDeclOfLet_Inh_Chunk :: Bool,mainFile_Inh_Chunk :: String,mainName_Inh_Chunk :: String,moduleHeader_Inh_Chunk :: String -> String -> String -> Bool -> String,nested_Inh_Chunk :: Bool,options_Inh_Chunk :: Options,optionsLine_Inh_Chunk :: String,pragmaBlocks_Inh_Chunk :: String,textBlocks_Inh_Chunk :: PP_Doc} -data Syn_Chunk = Syn_Chunk {appendCommon_Syn_Chunk :: [[PP_Doc]],appendMain_Syn_Chunk :: [[PP_Doc]],genSems_Syn_Chunk :: IO (),imports_Syn_Chunk :: [String],pps_Syn_Chunk :: PP_Docs} -wrap_Chunk (T_Chunk sem ) (Inh_Chunk _lhsIimportBlocks _lhsIisDeclOfLet _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInested _lhsIoptions _lhsIoptionsLine _lhsIpragmaBlocks _lhsItextBlocks ) = - (let ( _lhsOappendCommon,_lhsOappendMain,_lhsOgenSems,_lhsOimports,_lhsOpps) = - (sem _lhsIimportBlocks _lhsIisDeclOfLet _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInested _lhsIoptions _lhsIoptionsLine _lhsIpragmaBlocks _lhsItextBlocks ) - in (Syn_Chunk _lhsOappendCommon _lhsOappendMain _lhsOgenSems _lhsOimports _lhsOpps )) -sem_Chunk_Chunk :: String -> - T_Decl -> - T_Decls -> - T_Decls -> - T_Decls -> - T_Decls -> - T_Decls -> - T_Decls -> - ([String]) -> - T_Chunk -sem_Chunk_Chunk name_ (T_Decl comment_ ) (T_Decls info_ ) (T_Decls dataDef_ ) (T_Decls cataFun_ ) (T_Decls semDom_ ) (T_Decls semWrapper_ ) (T_Decls semFunctions_ ) semNames_ = - (T_Chunk (\ _lhsIimportBlocks - _lhsIisDeclOfLet - _lhsImainFile - _lhsImainName - _lhsImoduleHeader - _lhsInested - _lhsIoptions - _lhsIoptionsLine - _lhsIpragmaBlocks - _lhsItextBlocks -> - (let _lhsOpps :: PP_Docs - _lhsOimports :: ([String]) - _lhsOappendCommon :: ([[PP_Doc]]) - _lhsOappendMain :: ([[PP_Doc]]) - _lhsOgenSems :: (IO ()) - _commentOisDeclOfLet :: Bool - _commentOnested :: Bool - _commentOoptions :: Options - _commentOoutputfile :: String - _infoOisDeclOfLet :: Bool - _infoOnested :: Bool - _infoOoptions :: Options - _infoOoutputfile :: String - _dataDefOisDeclOfLet :: Bool - _dataDefOnested :: Bool - _dataDefOoptions :: Options - _dataDefOoutputfile :: String - _cataFunOisDeclOfLet :: Bool - _cataFunOnested :: Bool - _cataFunOoptions :: Options - _cataFunOoutputfile :: String - _semDomOisDeclOfLet :: Bool - _semDomOnested :: Bool - _semDomOoptions :: Options - _semDomOoutputfile :: String - _semWrapperOisDeclOfLet :: Bool - _semWrapperOnested :: Bool - _semWrapperOoptions :: Options - _semWrapperOoutputfile :: String - _semFunctionsOisDeclOfLet :: Bool - _semFunctionsOnested :: Bool - _semFunctionsOoptions :: Options - _semFunctionsOoutputfile :: String - _commentIpp :: PP_Doc - _infoIpps :: PP_Docs - _dataDefIpps :: PP_Docs - _cataFunIpps :: PP_Docs - _semDomIpps :: PP_Docs - _semWrapperIpps :: PP_Docs - _semFunctionsIpps :: PP_Docs - -- "PrintCode.ag"(line 37, column 7) - _outputfile = - if sepSemMods _lhsIoptions - then _lhsImainFile ++ "_" ++ name_ ++ ".hs" - else _lhsImainFile ++ ".hs" - -- "PrintCode.ag"(line 83, column 16) - _lhsOpps = - _commentIpp - : _infoIpps - ++ _dataDefIpps - ++ _cataFunIpps - ++ _semDomIpps - ++ _semWrapperIpps - ++ _semFunctionsIpps - -- "PrintCode.ag"(line 360, column 7) - _lhsOimports = - ["import " ++ _lhsImainName ++ "_" ++ name_ ++ "\n"] - -- "PrintCode.ag"(line 366, column 7) - _lhsOappendCommon = - [ [_commentIpp] - , _dataDefIpps - , _semDomIpps - ] - -- "PrintCode.ag"(line 371, column 7) - _lhsOappendMain = - [ [_commentIpp] - , _cataFunIpps - , _semWrapperIpps - ] - -- "PrintCode.ag"(line 381, column 7) - _lhsOgenSems = - writeModule _outputfile - [ pp $ _lhsIpragmaBlocks - , pp $ _lhsIoptionsLine - , pp $ _lhsImoduleHeader _lhsImainName ("_" ++ name_) _exports True - , pp $ ("import " ++ _lhsImainName ++ "_common\n") - , _commentIpp - , vlist_sep "" _infoIpps - , vlist_sep "" _semFunctionsIpps - ] - -- "PrintCode.ag"(line 394, column 7) - _exports = - concat $ intersperse "," semNames_ - -- copy rule (down) - _commentOisDeclOfLet = - _lhsIisDeclOfLet - -- copy rule (down) - _commentOnested = - _lhsInested - -- copy rule (down) - _commentOoptions = - _lhsIoptions - -- copy rule (from local) - _commentOoutputfile = - _outputfile - -- copy rule (down) - _infoOisDeclOfLet = - _lhsIisDeclOfLet - -- copy rule (down) - _infoOnested = - _lhsInested - -- copy rule (down) - _infoOoptions = - _lhsIoptions - -- copy rule (from local) - _infoOoutputfile = - _outputfile - -- copy rule (down) - _dataDefOisDeclOfLet = - _lhsIisDeclOfLet - -- copy rule (down) - _dataDefOnested = - _lhsInested - -- copy rule (down) - _dataDefOoptions = - _lhsIoptions - -- copy rule (from local) - _dataDefOoutputfile = - _outputfile - -- copy rule (down) - _cataFunOisDeclOfLet = - _lhsIisDeclOfLet - -- copy rule (down) - _cataFunOnested = - _lhsInested - -- copy rule (down) - _cataFunOoptions = - _lhsIoptions - -- copy rule (from local) - _cataFunOoutputfile = - _outputfile - -- copy rule (down) - _semDomOisDeclOfLet = - _lhsIisDeclOfLet - -- copy rule (down) - _semDomOnested = - _lhsInested - -- copy rule (down) - _semDomOoptions = - _lhsIoptions - -- copy rule (from local) - _semDomOoutputfile = - _outputfile - -- copy rule (down) - _semWrapperOisDeclOfLet = - _lhsIisDeclOfLet - -- copy rule (down) - _semWrapperOnested = - _lhsInested - -- copy rule (down) - _semWrapperOoptions = - _lhsIoptions - -- copy rule (from local) - _semWrapperOoutputfile = - _outputfile - -- copy rule (down) - _semFunctionsOisDeclOfLet = - _lhsIisDeclOfLet - -- copy rule (down) - _semFunctionsOnested = - _lhsInested - -- copy rule (down) - _semFunctionsOoptions = - _lhsIoptions - -- copy rule (from local) - _semFunctionsOoutputfile = - _outputfile - ( _commentIpp) = - (comment_ _commentOisDeclOfLet _commentOnested _commentOoptions _commentOoutputfile ) - ( _infoIpps) = - (info_ _infoOisDeclOfLet _infoOnested _infoOoptions _infoOoutputfile ) - ( _dataDefIpps) = - (dataDef_ _dataDefOisDeclOfLet _dataDefOnested _dataDefOoptions _dataDefOoutputfile ) - ( _cataFunIpps) = - (cataFun_ _cataFunOisDeclOfLet _cataFunOnested _cataFunOoptions _cataFunOoutputfile ) - ( _semDomIpps) = - (semDom_ _semDomOisDeclOfLet _semDomOnested _semDomOoptions _semDomOoutputfile ) - ( _semWrapperIpps) = - (semWrapper_ _semWrapperOisDeclOfLet _semWrapperOnested _semWrapperOoptions _semWrapperOoutputfile ) - ( _semFunctionsIpps) = - (semFunctions_ _semFunctionsOisDeclOfLet _semFunctionsOnested _semFunctionsOoptions _semFunctionsOoutputfile ) - in ( _lhsOappendCommon,_lhsOappendMain,_lhsOgenSems,_lhsOimports,_lhsOpps))) ) --- Chunks ------------------------------------------------------ -{- - visit 0: - inherited attributes: - importBlocks : PP_Doc - isDeclOfLet : Bool - mainFile : String - mainName : String - moduleHeader : String -> String -> String -> Bool -> String - nested : Bool - options : Options - optionsLine : String - pragmaBlocks : String - textBlocks : PP_Doc - synthesized attributes: - appendCommon : [[PP_Doc]] - appendMain : [[PP_Doc]] - genSems : IO () - imports : [String] - pps : PP_Docs - alternatives: - alternative Cons: - child hd : Chunk - child tl : Chunks - alternative Nil: --} --- cata -sem_Chunks :: Chunks -> - T_Chunks -sem_Chunks list = - (Prelude.foldr sem_Chunks_Cons sem_Chunks_Nil (Prelude.map sem_Chunk list) ) --- semantic domain -newtype T_Chunks = T_Chunks (PP_Doc -> - Bool -> - String -> - String -> - (String -> String -> String -> Bool -> String) -> - Bool -> - Options -> - String -> - String -> - PP_Doc -> - ( ([[PP_Doc]]),([[PP_Doc]]),(IO ()),([String]),PP_Docs)) -data Inh_Chunks = Inh_Chunks {importBlocks_Inh_Chunks :: PP_Doc,isDeclOfLet_Inh_Chunks :: Bool,mainFile_Inh_Chunks :: String,mainName_Inh_Chunks :: String,moduleHeader_Inh_Chunks :: String -> String -> String -> Bool -> String,nested_Inh_Chunks :: Bool,options_Inh_Chunks :: Options,optionsLine_Inh_Chunks :: String,pragmaBlocks_Inh_Chunks :: String,textBlocks_Inh_Chunks :: PP_Doc} -data Syn_Chunks = Syn_Chunks {appendCommon_Syn_Chunks :: [[PP_Doc]],appendMain_Syn_Chunks :: [[PP_Doc]],genSems_Syn_Chunks :: IO (),imports_Syn_Chunks :: [String],pps_Syn_Chunks :: PP_Docs} -wrap_Chunks (T_Chunks sem ) (Inh_Chunks _lhsIimportBlocks _lhsIisDeclOfLet _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInested _lhsIoptions _lhsIoptionsLine _lhsIpragmaBlocks _lhsItextBlocks ) = - (let ( _lhsOappendCommon,_lhsOappendMain,_lhsOgenSems,_lhsOimports,_lhsOpps) = - (sem _lhsIimportBlocks _lhsIisDeclOfLet _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInested _lhsIoptions _lhsIoptionsLine _lhsIpragmaBlocks _lhsItextBlocks ) - in (Syn_Chunks _lhsOappendCommon _lhsOappendMain _lhsOgenSems _lhsOimports _lhsOpps )) -sem_Chunks_Cons :: T_Chunk -> - T_Chunks -> - T_Chunks -sem_Chunks_Cons (T_Chunk hd_ ) (T_Chunks tl_ ) = - (T_Chunks (\ _lhsIimportBlocks - _lhsIisDeclOfLet - _lhsImainFile - _lhsImainName - _lhsImoduleHeader - _lhsInested - _lhsIoptions - _lhsIoptionsLine - _lhsIpragmaBlocks - _lhsItextBlocks -> - (let _lhsOpps :: PP_Docs - _lhsOappendCommon :: ([[PP_Doc]]) - _lhsOappendMain :: ([[PP_Doc]]) - _lhsOgenSems :: (IO ()) - _lhsOimports :: ([String]) - _hdOimportBlocks :: PP_Doc - _hdOisDeclOfLet :: Bool - _hdOmainFile :: String - _hdOmainName :: String - _hdOmoduleHeader :: (String -> String -> String -> Bool -> String) - _hdOnested :: Bool - _hdOoptions :: Options - _hdOoptionsLine :: String - _hdOpragmaBlocks :: String - _hdOtextBlocks :: PP_Doc - _tlOimportBlocks :: PP_Doc - _tlOisDeclOfLet :: Bool - _tlOmainFile :: String - _tlOmainName :: String - _tlOmoduleHeader :: (String -> String -> String -> Bool -> String) - _tlOnested :: Bool - _tlOoptions :: Options - _tlOoptionsLine :: String - _tlOpragmaBlocks :: String - _tlOtextBlocks :: PP_Doc - _hdIappendCommon :: ([[PP_Doc]]) - _hdIappendMain :: ([[PP_Doc]]) - _hdIgenSems :: (IO ()) - _hdIimports :: ([String]) - _hdIpps :: PP_Docs - _tlIappendCommon :: ([[PP_Doc]]) - _tlIappendMain :: ([[PP_Doc]]) - _tlIgenSems :: (IO ()) - _tlIimports :: ([String]) - _tlIpps :: PP_Docs - -- "PrintCode.ag"(line 75, column 10) - _lhsOpps = - _hdIpps ++ _tlIpps - -- use rule "PrintCode.ag"(line 362, column 50) - _lhsOappendCommon = - _hdIappendCommon ++ _tlIappendCommon - -- use rule "PrintCode.ag"(line 362, column 50) - _lhsOappendMain = - _hdIappendMain ++ _tlIappendMain - -- use rule "PrintCode.ag"(line 377, column 33) - _lhsOgenSems = - _hdIgenSems >> _tlIgenSems - -- use rule "PrintCode.ag"(line 357, column 33) - _lhsOimports = - _hdIimports ++ _tlIimports - -- copy rule (down) - _hdOimportBlocks = - _lhsIimportBlocks - -- copy rule (down) - _hdOisDeclOfLet = - _lhsIisDeclOfLet - -- copy rule (down) - _hdOmainFile = - _lhsImainFile - -- copy rule (down) - _hdOmainName = - _lhsImainName - -- copy rule (down) - _hdOmoduleHeader = - _lhsImoduleHeader - -- copy rule (down) - _hdOnested = - _lhsInested - -- copy rule (down) - _hdOoptions = - _lhsIoptions - -- copy rule (down) - _hdOoptionsLine = - _lhsIoptionsLine - -- copy rule (down) - _hdOpragmaBlocks = - _lhsIpragmaBlocks - -- copy rule (down) - _hdOtextBlocks = - _lhsItextBlocks - -- copy rule (down) - _tlOimportBlocks = - _lhsIimportBlocks - -- copy rule (down) - _tlOisDeclOfLet = - _lhsIisDeclOfLet - -- copy rule (down) - _tlOmainFile = - _lhsImainFile - -- copy rule (down) - _tlOmainName = - _lhsImainName - -- copy rule (down) - _tlOmoduleHeader = - _lhsImoduleHeader - -- copy rule (down) - _tlOnested = - _lhsInested - -- copy rule (down) - _tlOoptions = - _lhsIoptions - -- copy rule (down) - _tlOoptionsLine = - _lhsIoptionsLine - -- copy rule (down) - _tlOpragmaBlocks = - _lhsIpragmaBlocks - -- copy rule (down) - _tlOtextBlocks = - _lhsItextBlocks - ( _hdIappendCommon,_hdIappendMain,_hdIgenSems,_hdIimports,_hdIpps) = - (hd_ _hdOimportBlocks _hdOisDeclOfLet _hdOmainFile _hdOmainName _hdOmoduleHeader _hdOnested _hdOoptions _hdOoptionsLine _hdOpragmaBlocks _hdOtextBlocks ) - ( _tlIappendCommon,_tlIappendMain,_tlIgenSems,_tlIimports,_tlIpps) = - (tl_ _tlOimportBlocks _tlOisDeclOfLet _tlOmainFile _tlOmainName _tlOmoduleHeader _tlOnested _tlOoptions _tlOoptionsLine _tlOpragmaBlocks _tlOtextBlocks ) - in ( _lhsOappendCommon,_lhsOappendMain,_lhsOgenSems,_lhsOimports,_lhsOpps))) ) -sem_Chunks_Nil :: T_Chunks -sem_Chunks_Nil = - (T_Chunks (\ _lhsIimportBlocks - _lhsIisDeclOfLet - _lhsImainFile - _lhsImainName - _lhsImoduleHeader - _lhsInested - _lhsIoptions - _lhsIoptionsLine - _lhsIpragmaBlocks - _lhsItextBlocks -> - (let _lhsOpps :: PP_Docs - _lhsOappendCommon :: ([[PP_Doc]]) - _lhsOappendMain :: ([[PP_Doc]]) - _lhsOgenSems :: (IO ()) - _lhsOimports :: ([String]) - -- "PrintCode.ag"(line 76, column 10) - _lhsOpps = - [] - -- use rule "PrintCode.ag"(line 362, column 50) - _lhsOappendCommon = - [] - -- use rule "PrintCode.ag"(line 362, column 50) - _lhsOappendMain = - [] - -- use rule "PrintCode.ag"(line 377, column 33) - _lhsOgenSems = - return () - -- use rule "PrintCode.ag"(line 357, column 33) - _lhsOimports = - [] - in ( _lhsOappendCommon,_lhsOappendMain,_lhsOgenSems,_lhsOimports,_lhsOpps))) ) --- DataAlt ----------------------------------------------------- -{- - visit 0: - inherited attributes: - nested : Bool - strictPre : PP_Doc - synthesized attribute: - pp : PP_Doc - alternatives: - alternative DataAlt: - child name : {String} - child args : {[String]} - alternative Record: - child name : {String} - child args : {[(String,String)]} --} --- cata -sem_DataAlt :: DataAlt -> - T_DataAlt -sem_DataAlt (DataAlt _name _args ) = - (sem_DataAlt_DataAlt _name _args ) -sem_DataAlt (Record _name _args ) = - (sem_DataAlt_Record _name _args ) --- semantic domain -newtype T_DataAlt = T_DataAlt (Bool -> - PP_Doc -> - ( PP_Doc)) -data Inh_DataAlt = Inh_DataAlt {nested_Inh_DataAlt :: Bool,strictPre_Inh_DataAlt :: PP_Doc} -data Syn_DataAlt = Syn_DataAlt {pp_Syn_DataAlt :: PP_Doc} -wrap_DataAlt (T_DataAlt sem ) (Inh_DataAlt _lhsInested _lhsIstrictPre ) = - (let ( _lhsOpp) = - (sem _lhsInested _lhsIstrictPre ) - in (Syn_DataAlt _lhsOpp )) -sem_DataAlt_DataAlt :: String -> - ([String]) -> - T_DataAlt -sem_DataAlt_DataAlt name_ args_ = - (T_DataAlt (\ _lhsInested - _lhsIstrictPre -> - (let _lhsOpp :: PP_Doc - -- "PrintCode.ag"(line 152, column 16) - _lhsOpp = - name_ >#< hv_sp (map ((_lhsIstrictPre >|<) . pp_parens . text) args_) - in ( _lhsOpp))) ) -sem_DataAlt_Record :: String -> - ([(String,String)]) -> - T_DataAlt -sem_DataAlt_Record name_ args_ = - (T_DataAlt (\ _lhsInested - _lhsIstrictPre -> - (let _lhsOpp :: PP_Doc - -- "PrintCode.ag"(line 153, column 16) - _lhsOpp = - name_ >#< pp_block "{" "}" "," - [ f >#< "::" >#< t | (f,t) <- args_ ] - in ( _lhsOpp))) ) --- DataAlts ---------------------------------------------------- -{- - visit 0: - inherited attributes: - nested : Bool - strictPre : PP_Doc - synthesized attribute: - pps : PP_Docs - alternatives: - alternative Cons: - child hd : DataAlt - child tl : DataAlts - alternative Nil: --} --- cata -sem_DataAlts :: DataAlts -> - T_DataAlts -sem_DataAlts list = - (Prelude.foldr sem_DataAlts_Cons sem_DataAlts_Nil (Prelude.map sem_DataAlt list) ) --- semantic domain -newtype T_DataAlts = T_DataAlts (Bool -> - PP_Doc -> - ( PP_Docs)) -data Inh_DataAlts = Inh_DataAlts {nested_Inh_DataAlts :: Bool,strictPre_Inh_DataAlts :: PP_Doc} -data Syn_DataAlts = Syn_DataAlts {pps_Syn_DataAlts :: PP_Docs} -wrap_DataAlts (T_DataAlts sem ) (Inh_DataAlts _lhsInested _lhsIstrictPre ) = - (let ( _lhsOpps) = - (sem _lhsInested _lhsIstrictPre ) - in (Syn_DataAlts _lhsOpps )) -sem_DataAlts_Cons :: T_DataAlt -> - T_DataAlts -> - T_DataAlts -sem_DataAlts_Cons (T_DataAlt hd_ ) (T_DataAlts tl_ ) = - (T_DataAlts (\ _lhsInested - _lhsIstrictPre -> - (let _lhsOpps :: PP_Docs - _hdOnested :: Bool - _hdOstrictPre :: PP_Doc - _tlOnested :: Bool - _tlOstrictPre :: PP_Doc - _hdIpp :: PP_Doc - _tlIpps :: PP_Docs - -- "PrintCode.ag"(line 63, column 10) - _lhsOpps = - _hdIpp : _tlIpps - -- copy rule (down) - _hdOnested = - _lhsInested - -- copy rule (down) - _hdOstrictPre = - _lhsIstrictPre - -- copy rule (down) - _tlOnested = - _lhsInested - -- copy rule (down) - _tlOstrictPre = - _lhsIstrictPre - ( _hdIpp) = - (hd_ _hdOnested _hdOstrictPre ) - ( _tlIpps) = - (tl_ _tlOnested _tlOstrictPre ) - in ( _lhsOpps))) ) -sem_DataAlts_Nil :: T_DataAlts -sem_DataAlts_Nil = - (T_DataAlts (\ _lhsInested - _lhsIstrictPre -> - (let _lhsOpps :: PP_Docs - -- "PrintCode.ag"(line 64, column 10) - _lhsOpps = - [] - in ( _lhsOpps))) ) --- Decl -------------------------------------------------------- -{- - visit 0: - inherited attributes: - isDeclOfLet : Bool - nested : Bool - options : Options - outputfile : String - synthesized attribute: - pp : PP_Doc - alternatives: - alternative Comment: - child txt : {String} - alternative Data: - child name : {String} - child alts : DataAlts - child strict : {Bool} - child derivings : {[String]} - alternative Decl: - child left : Lhs - child rhs : Expr - child binds : {Set String} - child uses : {Set String} - alternative NewType: - child name : {String} - child con : {String} - child tp : Type - alternative PragmaDecl: - child txt : {String} - alternative TSig: - child name : {String} - child tp : Type - alternative Type: - child name : {String} - child tp : Type --} --- cata -sem_Decl :: Decl -> - T_Decl -sem_Decl (Comment _txt ) = - (sem_Decl_Comment _txt ) -sem_Decl (Data _name _alts _strict _derivings ) = - (sem_Decl_Data _name (sem_DataAlts _alts ) _strict _derivings ) -sem_Decl (Decl _left _rhs _binds _uses ) = - (sem_Decl_Decl (sem_Lhs _left ) (sem_Expr _rhs ) _binds _uses ) -sem_Decl (NewType _name _con _tp ) = - (sem_Decl_NewType _name _con (sem_Type _tp ) ) -sem_Decl (PragmaDecl _txt ) = - (sem_Decl_PragmaDecl _txt ) -sem_Decl (TSig _name _tp ) = - (sem_Decl_TSig _name (sem_Type _tp ) ) -sem_Decl (Type _name _tp ) = - (sem_Decl_Type _name (sem_Type _tp ) ) --- semantic domain -newtype T_Decl = T_Decl (Bool -> - Bool -> - Options -> - String -> - ( PP_Doc)) -data Inh_Decl = Inh_Decl {isDeclOfLet_Inh_Decl :: Bool,nested_Inh_Decl :: Bool,options_Inh_Decl :: Options,outputfile_Inh_Decl :: String} -data Syn_Decl = Syn_Decl {pp_Syn_Decl :: PP_Doc} -wrap_Decl (T_Decl sem ) (Inh_Decl _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile ) = - (let ( _lhsOpp) = - (sem _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile ) - in (Syn_Decl _lhsOpp )) -sem_Decl_Comment :: String -> - T_Decl -sem_Decl_Comment txt_ = - (T_Decl (\ _lhsIisDeclOfLet - _lhsInested - _lhsIoptions - _lhsIoutputfile -> - (let _lhsOpp :: PP_Doc - -- "PrintCode.ag"(line 106, column 16) - _lhsOpp = - if '\n' `elem` txt_ - then "{-" >-< vlist (lines txt_) >-< "-}" - else "--" >#< txt_ - in ( _lhsOpp))) ) -sem_Decl_Data :: String -> - T_DataAlts -> - Bool -> - ([String]) -> - T_Decl -sem_Decl_Data name_ (T_DataAlts alts_ ) strict_ derivings_ = - (T_Decl (\ _lhsIisDeclOfLet - _lhsInested - _lhsIoptions - _lhsIoutputfile -> - (let _lhsOpp :: PP_Doc - _altsOstrictPre :: PP_Doc - _altsOnested :: Bool - _altsIpps :: PP_Docs - -- "PrintCode.ag"(line 94, column 16) - _lhsOpp = - "data" >#< name_ - >#< ( case _altsIpps of - [] -> empty - (x:xs) -> "=" >#< x - >-< vlist (map ("|" >#<) xs) - >-< if null derivings_ - then empty - else "deriving" >#< ppTuple False (map text derivings_) - ) - -- "PrintCode.ag"(line 218, column 10) - _altsOstrictPre = - if strict_ then pp "!" else empty - -- copy rule (down) - _altsOnested = - _lhsInested - ( _altsIpps) = - (alts_ _altsOnested _altsOstrictPre ) - in ( _lhsOpp))) ) -sem_Decl_Decl :: T_Lhs -> - T_Expr -> - (Set String) -> - (Set String) -> - T_Decl -sem_Decl_Decl (T_Lhs left_ ) (T_Expr rhs_ ) binds_ uses_ = - (T_Decl (\ _lhsIisDeclOfLet - _lhsInested - _lhsIoptions - _lhsIoutputfile -> - (let _lhsOpp :: PP_Doc - _leftOisDeclOfLet :: Bool - _leftOnested :: Bool - _leftOoptions :: Options - _leftOoutputfile :: String - _rhsOnested :: Bool - _rhsOoptions :: Options - _rhsOoutputfile :: String - _leftIpp :: PP_Doc - _rhsIpp :: PP_Doc - -- "PrintCode.ag"(line 92, column 16) - _lhsOpp = - _leftIpp >#< "=" - >-< indent 4 _rhsIpp - -- copy rule (down) - _leftOisDeclOfLet = - _lhsIisDeclOfLet - -- copy rule (down) - _leftOnested = - _lhsInested - -- copy rule (down) - _leftOoptions = - _lhsIoptions - -- copy rule (down) - _leftOoutputfile = - _lhsIoutputfile - -- copy rule (down) - _rhsOnested = - _lhsInested - -- copy rule (down) - _rhsOoptions = - _lhsIoptions - -- copy rule (down) - _rhsOoutputfile = - _lhsIoutputfile - ( _leftIpp) = - (left_ _leftOisDeclOfLet _leftOnested _leftOoptions _leftOoutputfile ) - ( _rhsIpp) = - (rhs_ _rhsOnested _rhsOoptions _rhsOoutputfile ) - in ( _lhsOpp))) ) -sem_Decl_NewType :: String -> - String -> - T_Type -> - T_Decl -sem_Decl_NewType name_ con_ (T_Type tp_ ) = - (T_Decl (\ _lhsIisDeclOfLet - _lhsInested - _lhsIoptions - _lhsIoutputfile -> - (let _lhsOpp :: PP_Doc - _tpOnested :: Bool - _tpIpp :: PP_Doc - _tpIprec :: Int - -- "PrintCode.ag"(line 103, column 16) - _lhsOpp = - "newtype" >#< name_ >#< "=" >#< con_ >#< pp_parens _tpIpp - -- copy rule (down) - _tpOnested = - _lhsInested - ( _tpIpp,_tpIprec) = - (tp_ _tpOnested ) - in ( _lhsOpp))) ) -sem_Decl_PragmaDecl :: String -> - T_Decl -sem_Decl_PragmaDecl txt_ = - (T_Decl (\ _lhsIisDeclOfLet - _lhsInested - _lhsIoptions - _lhsIoutputfile -> - (let _lhsOpp :: PP_Doc - -- "PrintCode.ag"(line 109, column 16) - _lhsOpp = - "{-#" >#< text txt_ >#< "#-}" - in ( _lhsOpp))) ) -sem_Decl_TSig :: String -> - T_Type -> - T_Decl -sem_Decl_TSig name_ (T_Type tp_ ) = - (T_Decl (\ _lhsIisDeclOfLet - _lhsInested - _lhsIoptions - _lhsIoutputfile -> - (let _lhsOpp :: PP_Doc - _tpOnested :: Bool - _tpIpp :: PP_Doc - _tpIprec :: Int - -- "PrintCode.ag"(line 105, column 16) - _lhsOpp = - name_ >#< "::" >#< _tpIpp - -- copy rule (down) - _tpOnested = - _lhsInested - ( _tpIpp,_tpIprec) = - (tp_ _tpOnested ) - in ( _lhsOpp))) ) -sem_Decl_Type :: String -> - T_Type -> - T_Decl -sem_Decl_Type name_ (T_Type tp_ ) = - (T_Decl (\ _lhsIisDeclOfLet - _lhsInested - _lhsIoptions - _lhsIoutputfile -> - (let _lhsOpp :: PP_Doc - _tpOnested :: Bool - _tpIpp :: PP_Doc - _tpIprec :: Int - -- "PrintCode.ag"(line 104, column 16) - _lhsOpp = - "type" >#< name_ >#< "=" >#< _tpIpp - -- copy rule (down) - _tpOnested = - _lhsInested - ( _tpIpp,_tpIprec) = - (tp_ _tpOnested ) - in ( _lhsOpp))) ) --- Decls ------------------------------------------------------- -{- - visit 0: - inherited attributes: - isDeclOfLet : Bool - nested : Bool - options : Options - outputfile : String - synthesized attribute: - pps : PP_Docs - alternatives: - alternative Cons: - child hd : Decl - child tl : Decls - alternative Nil: --} --- cata -sem_Decls :: Decls -> - T_Decls -sem_Decls list = - (Prelude.foldr sem_Decls_Cons sem_Decls_Nil (Prelude.map sem_Decl list) ) --- semantic domain -newtype T_Decls = T_Decls (Bool -> - Bool -> - Options -> - String -> - ( PP_Docs)) -data Inh_Decls = Inh_Decls {isDeclOfLet_Inh_Decls :: Bool,nested_Inh_Decls :: Bool,options_Inh_Decls :: Options,outputfile_Inh_Decls :: String} -data Syn_Decls = Syn_Decls {pps_Syn_Decls :: PP_Docs} -wrap_Decls (T_Decls sem ) (Inh_Decls _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile ) = - (let ( _lhsOpps) = - (sem _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile ) - in (Syn_Decls _lhsOpps )) -sem_Decls_Cons :: T_Decl -> - T_Decls -> - T_Decls -sem_Decls_Cons (T_Decl hd_ ) (T_Decls tl_ ) = - (T_Decls (\ _lhsIisDeclOfLet - _lhsInested - _lhsIoptions - _lhsIoutputfile -> - (let _lhsOpps :: PP_Docs - _hdOisDeclOfLet :: Bool - _hdOnested :: Bool - _hdOoptions :: Options - _hdOoutputfile :: String - _tlOisDeclOfLet :: Bool - _tlOnested :: Bool - _tlOoptions :: Options - _tlOoutputfile :: String - _hdIpp :: PP_Doc - _tlIpps :: PP_Docs - -- "PrintCode.ag"(line 71, column 10) - _lhsOpps = - _hdIpp : _tlIpps - -- copy rule (down) - _hdOisDeclOfLet = - _lhsIisDeclOfLet - -- copy rule (down) - _hdOnested = - _lhsInested - -- copy rule (down) - _hdOoptions = - _lhsIoptions - -- copy rule (down) - _hdOoutputfile = - _lhsIoutputfile - -- copy rule (down) - _tlOisDeclOfLet = - _lhsIisDeclOfLet - -- copy rule (down) - _tlOnested = - _lhsInested - -- copy rule (down) - _tlOoptions = - _lhsIoptions - -- copy rule (down) - _tlOoutputfile = - _lhsIoutputfile - ( _hdIpp) = - (hd_ _hdOisDeclOfLet _hdOnested _hdOoptions _hdOoutputfile ) - ( _tlIpps) = - (tl_ _tlOisDeclOfLet _tlOnested _tlOoptions _tlOoutputfile ) - in ( _lhsOpps))) ) -sem_Decls_Nil :: T_Decls -sem_Decls_Nil = - (T_Decls (\ _lhsIisDeclOfLet - _lhsInested - _lhsIoptions - _lhsIoutputfile -> - (let _lhsOpps :: PP_Docs - -- "PrintCode.ag"(line 72, column 10) - _lhsOpps = - [] - in ( _lhsOpps))) ) --- Expr -------------------------------------------------------- -{- - visit 0: - inherited attributes: - nested : Bool - options : Options - outputfile : String - synthesized attribute: - pp : PP_Doc - alternatives: - alternative App: - child name : {String} - child args : Exprs - alternative Case: - child expr : Expr - child alts : CaseAlts - alternative Lambda: - child args : {[String]} - child body : Expr - visit 0: - local strictParams : _ - local addBang : _ - alternative Let: - child decls : Decls - child body : Expr - alternative LineExpr: - child expr : Expr - alternative PragmaExpr: - child onLeftSide : {Bool} - child onNewLine : {Bool} - child txt : {String} - child expr : Expr - alternative SimpleExpr: - child txt : {String} - alternative TextExpr: - child lns : {[String]} - alternative Trace: - child txt : {String} - child expr : Expr - alternative TupleExpr: - child exprs : Exprs - alternative UnboxedTupleExpr: - child exprs : Exprs --} --- cata -sem_Expr :: Expr -> - T_Expr -sem_Expr (App _name _args ) = - (sem_Expr_App _name (sem_Exprs _args ) ) -sem_Expr (Case _expr _alts ) = - (sem_Expr_Case (sem_Expr _expr ) (sem_CaseAlts _alts ) ) -sem_Expr (Lambda _args _body ) = - (sem_Expr_Lambda _args (sem_Expr _body ) ) -sem_Expr (Let _decls _body ) = - (sem_Expr_Let (sem_Decls _decls ) (sem_Expr _body ) ) -sem_Expr (LineExpr _expr ) = - (sem_Expr_LineExpr (sem_Expr _expr ) ) -sem_Expr (PragmaExpr _onLeftSide _onNewLine _txt _expr ) = - (sem_Expr_PragmaExpr _onLeftSide _onNewLine _txt (sem_Expr _expr ) ) -sem_Expr (SimpleExpr _txt ) = - (sem_Expr_SimpleExpr _txt ) -sem_Expr (TextExpr _lns ) = - (sem_Expr_TextExpr _lns ) -sem_Expr (Trace _txt _expr ) = - (sem_Expr_Trace _txt (sem_Expr _expr ) ) -sem_Expr (TupleExpr _exprs ) = - (sem_Expr_TupleExpr (sem_Exprs _exprs ) ) -sem_Expr (UnboxedTupleExpr _exprs ) = - (sem_Expr_UnboxedTupleExpr (sem_Exprs _exprs ) ) --- semantic domain -newtype T_Expr = T_Expr (Bool -> - Options -> - String -> - ( PP_Doc)) -data Inh_Expr = Inh_Expr {nested_Inh_Expr :: Bool,options_Inh_Expr :: Options,outputfile_Inh_Expr :: String} -data Syn_Expr = Syn_Expr {pp_Syn_Expr :: PP_Doc} -wrap_Expr (T_Expr sem ) (Inh_Expr _lhsInested _lhsIoptions _lhsIoutputfile ) = - (let ( _lhsOpp) = - (sem _lhsInested _lhsIoptions _lhsIoutputfile ) - in (Syn_Expr _lhsOpp )) -sem_Expr_App :: String -> - T_Exprs -> - T_Expr -sem_Expr_App name_ (T_Exprs args_ ) = - (T_Expr (\ _lhsInested - _lhsIoptions - _lhsIoutputfile -> - (let _lhsOpp :: PP_Doc - _argsOnested :: Bool - _argsOoptions :: Options - _argsOoutputfile :: String - _argsIpps :: PP_Docs - -- "PrintCode.ag"(line 129, column 16) - _lhsOpp = - pp_parens $ name_ >#< hv_sp _argsIpps - -- copy rule (down) - _argsOnested = - _lhsInested - -- copy rule (down) - _argsOoptions = - _lhsIoptions - -- copy rule (down) - _argsOoutputfile = - _lhsIoutputfile - ( _argsIpps) = - (args_ _argsOnested _argsOoptions _argsOoutputfile ) - in ( _lhsOpp))) ) -sem_Expr_Case :: T_Expr -> - T_CaseAlts -> - T_Expr -sem_Expr_Case (T_Expr expr_ ) (T_CaseAlts alts_ ) = - (T_Expr (\ _lhsInested - _lhsIoptions - _lhsIoutputfile -> - (let _lhsOpp :: PP_Doc - _exprOnested :: Bool - _exprOoptions :: Options - _exprOoutputfile :: String - _altsOnested :: Bool - _altsOoptions :: Options - _altsOoutputfile :: String - _exprIpp :: PP_Doc - _altsIpps :: PP_Docs - -- "PrintCode.ag"(line 115, column 16) - _lhsOpp = - pp_parens ( "case" >#< pp_parens _exprIpp >#< "of" - >-< (vlist _altsIpps) - ) - -- copy rule (down) - _exprOnested = - _lhsInested - -- copy rule (down) - _exprOoptions = - _lhsIoptions - -- copy rule (down) - _exprOoutputfile = - _lhsIoutputfile - -- copy rule (down) - _altsOnested = - _lhsInested - -- copy rule (down) - _altsOoptions = - _lhsIoptions - -- copy rule (down) - _altsOoutputfile = - _lhsIoutputfile - ( _exprIpp) = - (expr_ _exprOnested _exprOoptions _exprOoutputfile ) - ( _altsIpps) = - (alts_ _altsOnested _altsOoptions _altsOoutputfile ) - in ( _lhsOpp))) ) -sem_Expr_Lambda :: ([String]) -> - T_Expr -> - T_Expr -sem_Expr_Lambda args_ (T_Expr body_ ) = - (T_Expr (\ _lhsInested - _lhsIoptions - _lhsIoutputfile -> - (let _lhsOpp :: PP_Doc - _bodyOnested :: Bool - _bodyOoptions :: Options - _bodyOoutputfile :: String - _bodyIpp :: PP_Doc - -- "PrintCode.ag"(line 118, column 16) - _strictParams = - if strictSems _lhsIoptions - then map text args_ - else [] - -- "PrintCode.ag"(line 121, column 16) - _addBang = - if bangpats _lhsIoptions - then \p -> pp_parens ("!" >|< p) - else id - -- "PrintCode.ag"(line 124, column 16) - _lhsOpp = - pp_parens ( "\\" >#< (vlist (map (_addBang . pp) args_)) >#< "->" - >-< indent 4 (_strictParams `ppMultiSeqV` _bodyIpp) - ) - -- copy rule (down) - _bodyOnested = - _lhsInested - -- copy rule (down) - _bodyOoptions = - _lhsIoptions - -- copy rule (down) - _bodyOoutputfile = - _lhsIoutputfile - ( _bodyIpp) = - (body_ _bodyOnested _bodyOoptions _bodyOoutputfile ) - in ( _lhsOpp))) ) -sem_Expr_Let :: T_Decls -> - T_Expr -> - T_Expr -sem_Expr_Let (T_Decls decls_ ) (T_Expr body_ ) = - (T_Expr (\ _lhsInested - _lhsIoptions - _lhsIoutputfile -> - (let _lhsOpp :: PP_Doc - _declsOisDeclOfLet :: Bool - _declsOnested :: Bool - _declsOoptions :: Options - _declsOoutputfile :: String - _bodyOnested :: Bool - _bodyOoptions :: Options - _bodyOoutputfile :: String - _declsIpps :: PP_Docs - _bodyIpp :: PP_Doc - -- "PrintCode.ag"(line 112, column 16) - _lhsOpp = - pp_parens ( "let" >#< (vlist _declsIpps) - >-< "in " >#< _bodyIpp - ) - -- "PrintCode.ag"(line 299, column 7) - _declsOisDeclOfLet = - True - -- copy rule (down) - _declsOnested = - _lhsInested - -- copy rule (down) - _declsOoptions = - _lhsIoptions - -- copy rule (down) - _declsOoutputfile = - _lhsIoutputfile - -- copy rule (down) - _bodyOnested = - _lhsInested - -- copy rule (down) - _bodyOoptions = - _lhsIoptions - -- copy rule (down) - _bodyOoutputfile = - _lhsIoutputfile - ( _declsIpps) = - (decls_ _declsOisDeclOfLet _declsOnested _declsOoptions _declsOoutputfile ) - ( _bodyIpp) = - (body_ _bodyOnested _bodyOoptions _bodyOoutputfile ) - in ( _lhsOpp))) ) -sem_Expr_LineExpr :: T_Expr -> - T_Expr -sem_Expr_LineExpr (T_Expr expr_ ) = - (T_Expr (\ _lhsInested - _lhsIoptions - _lhsIoutputfile -> - (let _lhsOpp :: PP_Doc - _exprOnested :: Bool - _exprOoptions :: Options - _exprOoutputfile :: String - _exprIpp :: PP_Doc - -- "PrintCode.ag"(line 146, column 16) - _lhsOpp = - _exprIpp >-< "{-# LINE" >#< ppWithLineNr (\n -> pp $ show $ n + 1) >#< show _lhsIoutputfile >#< "#-}" - -- copy rule (down) - _exprOnested = - _lhsInested - -- copy rule (down) - _exprOoptions = - _lhsIoptions - -- copy rule (down) - _exprOoutputfile = - _lhsIoutputfile - ( _exprIpp) = - (expr_ _exprOnested _exprOoptions _exprOoutputfile ) - in ( _lhsOpp))) ) -sem_Expr_PragmaExpr :: Bool -> - Bool -> - String -> - T_Expr -> - T_Expr -sem_Expr_PragmaExpr onLeftSide_ onNewLine_ txt_ (T_Expr expr_ ) = - (T_Expr (\ _lhsInested - _lhsIoptions - _lhsIoutputfile -> - (let _lhsOpp :: PP_Doc - _exprOnested :: Bool - _exprOoptions :: Options - _exprOoutputfile :: String - _exprIpp :: PP_Doc - -- "PrintCode.ag"(line 135, column 16) - _lhsOpp = - let pragmaDoc = "{-#" >#< txt_ >#< "#-}" - op = if onNewLine_ - then (>-<) - else (>#<) - leftOp x y = if onLeftSide_ - then x `op` y - else y - rightOp x y = if onLeftSide_ - then x - else x `op` y - in pragmaDoc `leftOp` _exprIpp `rightOp` pragmaDoc - -- copy rule (down) - _exprOnested = - _lhsInested - -- copy rule (down) - _exprOoptions = - _lhsIoptions - -- copy rule (down) - _exprOoutputfile = - _lhsIoutputfile - ( _exprIpp) = - (expr_ _exprOnested _exprOoptions _exprOoutputfile ) - in ( _lhsOpp))) ) -sem_Expr_SimpleExpr :: String -> - T_Expr -sem_Expr_SimpleExpr txt_ = - (T_Expr (\ _lhsInested - _lhsIoptions - _lhsIoutputfile -> - (let _lhsOpp :: PP_Doc - -- "PrintCode.ag"(line 130, column 16) - _lhsOpp = - text txt_ - in ( _lhsOpp))) ) -sem_Expr_TextExpr :: ([String]) -> - T_Expr -sem_Expr_TextExpr lns_ = - (T_Expr (\ _lhsInested - _lhsIoptions - _lhsIoutputfile -> - (let _lhsOpp :: PP_Doc - -- "PrintCode.ag"(line 131, column 16) - _lhsOpp = - vlist (map text lns_) - in ( _lhsOpp))) ) -sem_Expr_Trace :: String -> - T_Expr -> - T_Expr -sem_Expr_Trace txt_ (T_Expr expr_ ) = - (T_Expr (\ _lhsInested - _lhsIoptions - _lhsIoutputfile -> - (let _lhsOpp :: PP_Doc - _exprOnested :: Bool - _exprOoptions :: Options - _exprOoutputfile :: String - _exprIpp :: PP_Doc - -- "PrintCode.ag"(line 132, column 16) - _lhsOpp = - "trace" >#< ( pp_parens ("\"" >|< text txt_ >|< "\"") - >-< pp_parens _exprIpp - ) - -- copy rule (down) - _exprOnested = - _lhsInested - -- copy rule (down) - _exprOoptions = - _lhsIoptions - -- copy rule (down) - _exprOoutputfile = - _lhsIoutputfile - ( _exprIpp) = - (expr_ _exprOnested _exprOoptions _exprOoutputfile ) - in ( _lhsOpp))) ) -sem_Expr_TupleExpr :: T_Exprs -> - T_Expr -sem_Expr_TupleExpr (T_Exprs exprs_ ) = - (T_Expr (\ _lhsInested - _lhsIoptions - _lhsIoutputfile -> - (let _lhsOpp :: PP_Doc - _exprsOnested :: Bool - _exprsOoptions :: Options - _exprsOoutputfile :: String - _exprsIpps :: PP_Docs - -- "PrintCode.ag"(line 127, column 16) - _lhsOpp = - ppTuple _lhsInested _exprsIpps - -- copy rule (down) - _exprsOnested = - _lhsInested - -- copy rule (down) - _exprsOoptions = - _lhsIoptions - -- copy rule (down) - _exprsOoutputfile = - _lhsIoutputfile - ( _exprsIpps) = - (exprs_ _exprsOnested _exprsOoptions _exprsOoutputfile ) - in ( _lhsOpp))) ) -sem_Expr_UnboxedTupleExpr :: T_Exprs -> - T_Expr -sem_Expr_UnboxedTupleExpr (T_Exprs exprs_ ) = - (T_Expr (\ _lhsInested - _lhsIoptions - _lhsIoutputfile -> - (let _lhsOpp :: PP_Doc - _exprsOnested :: Bool - _exprsOoptions :: Options - _exprsOoutputfile :: String - _exprsIpps :: PP_Docs - -- "PrintCode.ag"(line 128, column 23) - _lhsOpp = - ppUnboxedTuple _lhsInested _exprsIpps - -- copy rule (down) - _exprsOnested = - _lhsInested - -- copy rule (down) - _exprsOoptions = - _lhsIoptions - -- copy rule (down) - _exprsOoutputfile = - _lhsIoutputfile - ( _exprsIpps) = - (exprs_ _exprsOnested _exprsOoptions _exprsOoutputfile ) - in ( _lhsOpp))) ) --- Exprs ------------------------------------------------------- -{- - visit 0: - inherited attributes: - nested : Bool - options : Options - outputfile : String - synthesized attribute: - pps : PP_Docs - alternatives: - alternative Cons: - child hd : Expr - child tl : Exprs - alternative Nil: --} --- cata -sem_Exprs :: Exprs -> - T_Exprs -sem_Exprs list = - (Prelude.foldr sem_Exprs_Cons sem_Exprs_Nil (Prelude.map sem_Expr list) ) --- semantic domain -newtype T_Exprs = T_Exprs (Bool -> - Options -> - String -> - ( PP_Docs)) -data Inh_Exprs = Inh_Exprs {nested_Inh_Exprs :: Bool,options_Inh_Exprs :: Options,outputfile_Inh_Exprs :: String} -data Syn_Exprs = Syn_Exprs {pps_Syn_Exprs :: PP_Docs} -wrap_Exprs (T_Exprs sem ) (Inh_Exprs _lhsInested _lhsIoptions _lhsIoutputfile ) = - (let ( _lhsOpps) = - (sem _lhsInested _lhsIoptions _lhsIoutputfile ) - in (Syn_Exprs _lhsOpps )) -sem_Exprs_Cons :: T_Expr -> - T_Exprs -> - T_Exprs -sem_Exprs_Cons (T_Expr hd_ ) (T_Exprs tl_ ) = - (T_Exprs (\ _lhsInested - _lhsIoptions - _lhsIoutputfile -> - (let _lhsOpps :: PP_Docs - _hdOnested :: Bool - _hdOoptions :: Options - _hdOoutputfile :: String - _tlOnested :: Bool - _tlOoptions :: Options - _tlOoutputfile :: String - _hdIpp :: PP_Doc - _tlIpps :: PP_Docs - -- "PrintCode.ag"(line 55, column 10) - _lhsOpps = - _hdIpp : _tlIpps - -- copy rule (down) - _hdOnested = - _lhsInested - -- copy rule (down) - _hdOoptions = - _lhsIoptions - -- copy rule (down) - _hdOoutputfile = - _lhsIoutputfile - -- copy rule (down) - _tlOnested = - _lhsInested - -- copy rule (down) - _tlOoptions = - _lhsIoptions - -- copy rule (down) - _tlOoutputfile = - _lhsIoutputfile - ( _hdIpp) = - (hd_ _hdOnested _hdOoptions _hdOoutputfile ) - ( _tlIpps) = - (tl_ _tlOnested _tlOoptions _tlOoutputfile ) - in ( _lhsOpps))) ) -sem_Exprs_Nil :: T_Exprs -sem_Exprs_Nil = - (T_Exprs (\ _lhsInested - _lhsIoptions - _lhsIoutputfile -> - (let _lhsOpps :: PP_Docs - -- "PrintCode.ag"(line 56, column 10) - _lhsOpps = - [] - in ( _lhsOpps))) ) --- Lhs --------------------------------------------------------- -{- - visit 0: - inherited attributes: - isDeclOfLet : Bool - nested : Bool - options : Options - outputfile : String - synthesized attribute: - pp : PP_Doc - alternatives: - alternative Fun: - child name : {String} - child args : Exprs - visit 0: - local addStrictGuard : _ - local strictGuard : _ - local addBang : _ - alternative Pattern3: - child pat3 : Pattern - visit 0: - local addStrictGuard : _ - local strictGuard : _ - alternative Pattern3SM: - child pat3 : Pattern - alternative TupleLhs: - child comps : {[String]} - visit 0: - local addStrictGuard : _ - local strictGuard : _ - local addBang : _ - alternative UnboxedTupleLhs: - child comps : {[String]} - visit 0: - local addStrictGuard : _ - local strictGuard : _ - local addBang : _ --} --- cata -sem_Lhs :: Lhs -> - T_Lhs -sem_Lhs (Fun _name _args ) = - (sem_Lhs_Fun _name (sem_Exprs _args ) ) -sem_Lhs (Pattern3 _pat3 ) = - (sem_Lhs_Pattern3 (sem_Pattern _pat3 ) ) -sem_Lhs (Pattern3SM _pat3 ) = - (sem_Lhs_Pattern3SM (sem_Pattern _pat3 ) ) -sem_Lhs (TupleLhs _comps ) = - (sem_Lhs_TupleLhs _comps ) -sem_Lhs (UnboxedTupleLhs _comps ) = - (sem_Lhs_UnboxedTupleLhs _comps ) --- semantic domain -newtype T_Lhs = T_Lhs (Bool -> - Bool -> - Options -> - String -> - ( PP_Doc)) -data Inh_Lhs = Inh_Lhs {isDeclOfLet_Inh_Lhs :: Bool,nested_Inh_Lhs :: Bool,options_Inh_Lhs :: Options,outputfile_Inh_Lhs :: String} -data Syn_Lhs = Syn_Lhs {pp_Syn_Lhs :: PP_Doc} -wrap_Lhs (T_Lhs sem ) (Inh_Lhs _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile ) = - (let ( _lhsOpp) = - (sem _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile ) - in (Syn_Lhs _lhsOpp )) -sem_Lhs_Fun :: String -> - T_Exprs -> - T_Lhs -sem_Lhs_Fun name_ (T_Exprs args_ ) = - (T_Lhs (\ _lhsIisDeclOfLet - _lhsInested - _lhsIoptions - _lhsIoutputfile -> - (let _lhsOpp :: PP_Doc - _argsOnested :: Bool - _argsOoptions :: Options - _argsOoutputfile :: String - _argsIpps :: PP_Docs - -- "PrintCode.ag"(line 166, column 7) - _addStrictGuard = - if strictSems _lhsIoptions then \v -> v >#< "|" >#< _strictGuard else id - -- "PrintCode.ag"(line 167, column 7) - _strictGuard = - _argsIpps `ppMultiSeqH` (pp "True") - -- "PrintCode.ag"(line 170, column 7) - _addBang = - if bangpats _lhsIoptions - then \p -> "!" >|< p - else id - -- "PrintCode.ag"(line 178, column 16) - _lhsOpp = - _addStrictGuard (name_ >#< hv_sp (map _addBang _argsIpps)) - -- copy rule (down) - _argsOnested = - _lhsInested - -- copy rule (down) - _argsOoptions = - _lhsIoptions - -- copy rule (down) - _argsOoutputfile = - _lhsIoutputfile - ( _argsIpps) = - (args_ _argsOnested _argsOoptions _argsOoutputfile ) - in ( _lhsOpp))) ) -sem_Lhs_Pattern3 :: T_Pattern -> - T_Lhs -sem_Lhs_Pattern3 (T_Pattern pat3_ ) = - (T_Lhs (\ _lhsIisDeclOfLet - _lhsInested - _lhsIoptions - _lhsIoutputfile -> - (let _lhsOpp :: PP_Doc - _pat3OisDeclOfLet :: Bool - _pat3Ooptions :: Options - _pat3Icopy :: Pattern - _pat3IisUnderscore :: Bool - _pat3Ipp :: PP_Doc - _pat3Ipp' :: PP_Doc - _pat3IstrictVars :: ([PP_Doc]) - -- "PrintCode.ag"(line 157, column 7) - _addStrictGuard = - if strictCases _lhsIoptions then \v -> v >#< "|" >#< _strictGuard else id - -- "PrintCode.ag"(line 159, column 7) - _strictGuard = - _pat3IstrictVars `ppMultiSeqH` (pp "True") - -- "PrintCode.ag"(line 174, column 16) - _lhsOpp = - _addStrictGuard _pat3Ipp - -- copy rule (down) - _pat3OisDeclOfLet = - _lhsIisDeclOfLet - -- copy rule (down) - _pat3Ooptions = - _lhsIoptions - ( _pat3Icopy,_pat3IisUnderscore,_pat3Ipp,_pat3Ipp',_pat3IstrictVars) = - (pat3_ _pat3OisDeclOfLet _pat3Ooptions ) - in ( _lhsOpp))) ) -sem_Lhs_Pattern3SM :: T_Pattern -> - T_Lhs -sem_Lhs_Pattern3SM (T_Pattern pat3_ ) = - (T_Lhs (\ _lhsIisDeclOfLet - _lhsInested - _lhsIoptions - _lhsIoutputfile -> - (let _lhsOpp :: PP_Doc - _pat3OisDeclOfLet :: Bool - _pat3Ooptions :: Options - _pat3Icopy :: Pattern - _pat3IisUnderscore :: Bool - _pat3Ipp :: PP_Doc - _pat3Ipp' :: PP_Doc - _pat3IstrictVars :: ([PP_Doc]) - -- "PrintCode.ag"(line 175, column 16) - _lhsOpp = - _pat3Ipp' - -- copy rule (down) - _pat3OisDeclOfLet = - _lhsIisDeclOfLet - -- copy rule (down) - _pat3Ooptions = - _lhsIoptions - ( _pat3Icopy,_pat3IisUnderscore,_pat3Ipp,_pat3Ipp',_pat3IstrictVars) = - (pat3_ _pat3OisDeclOfLet _pat3Ooptions ) - in ( _lhsOpp))) ) -sem_Lhs_TupleLhs :: ([String]) -> - T_Lhs -sem_Lhs_TupleLhs comps_ = - (T_Lhs (\ _lhsIisDeclOfLet - _lhsInested - _lhsIoptions - _lhsIoutputfile -> - (let _lhsOpp :: PP_Doc - -- "PrintCode.ag"(line 157, column 7) - _addStrictGuard = - if strictCases _lhsIoptions then \v -> v >#< "|" >#< _strictGuard else id - -- "PrintCode.ag"(line 161, column 7) - _strictGuard = - if stricterCases _lhsIoptions && not _lhsIisDeclOfLet - then map text comps_ `ppMultiSeqH` (pp "True") - else pp "True" - -- "PrintCode.ag"(line 170, column 7) - _addBang = - if bangpats _lhsIoptions - then \p -> "!" >|< p - else id - -- "PrintCode.ag"(line 176, column 16) - _lhsOpp = - _addStrictGuard $ ppTuple _lhsInested (map (_addBang . text) comps_) - in ( _lhsOpp))) ) -sem_Lhs_UnboxedTupleLhs :: ([String]) -> - T_Lhs -sem_Lhs_UnboxedTupleLhs comps_ = - (T_Lhs (\ _lhsIisDeclOfLet - _lhsInested - _lhsIoptions - _lhsIoutputfile -> - (let _lhsOpp :: PP_Doc - -- "PrintCode.ag"(line 157, column 7) - _addStrictGuard = - if strictCases _lhsIoptions then \v -> v >#< "|" >#< _strictGuard else id - -- "PrintCode.ag"(line 161, column 7) - _strictGuard = - if stricterCases _lhsIoptions && not _lhsIisDeclOfLet - then map text comps_ `ppMultiSeqH` (pp "True") - else pp "True" - -- "PrintCode.ag"(line 170, column 7) - _addBang = - if bangpats _lhsIoptions - then \p -> "!" >|< p - else id - -- "PrintCode.ag"(line 177, column 23) - _lhsOpp = - _addStrictGuard $ ppUnboxedTuple _lhsInested (map (_addBang . text) comps_) - in ( _lhsOpp))) ) --- Pattern ----------------------------------------------------- -{- - visit 0: - inherited attributes: - isDeclOfLet : Bool - options : Options - synthesized attributes: - copy : SELF - isUnderscore : Bool - pp : PP_Doc - pp' : PP_Doc - strictVars : [PP_Doc] - alternatives: - alternative Alias: - child field : {Name} - child attr : {Name} - child pat : Pattern - child parts : Patterns - visit 0: - local strictVar : _ - local strictPatVars : _ - local addBang : _ - local ppVar : _ - local copy : _ - alternative Constr: - child name : {Constructor} - child pats : Patterns - visit 0: - local addBang : _ - local copy : _ - alternative Product: - child pos : {Pos} - child pats : Patterns - visit 0: - local addBang : _ - local copy : _ - alternative Underscore: - child pos : {Pos} - visit 0: - local copy : _ --} --- cata -sem_Pattern :: Pattern -> - T_Pattern -sem_Pattern (Alias _field _attr _pat _parts ) = - (sem_Pattern_Alias _field _attr (sem_Pattern _pat ) (sem_Patterns _parts ) ) -sem_Pattern (Constr _name _pats ) = - (sem_Pattern_Constr _name (sem_Patterns _pats ) ) -sem_Pattern (Product _pos _pats ) = - (sem_Pattern_Product _pos (sem_Patterns _pats ) ) -sem_Pattern (Underscore _pos ) = - (sem_Pattern_Underscore _pos ) --- semantic domain -newtype T_Pattern = T_Pattern (Bool -> - Options -> - ( Pattern,Bool,PP_Doc,PP_Doc,([PP_Doc]))) -data Inh_Pattern = Inh_Pattern {isDeclOfLet_Inh_Pattern :: Bool,options_Inh_Pattern :: Options} -data Syn_Pattern = Syn_Pattern {copy_Syn_Pattern :: Pattern,isUnderscore_Syn_Pattern :: Bool,pp_Syn_Pattern :: PP_Doc,pp'_Syn_Pattern :: PP_Doc,strictVars_Syn_Pattern :: [PP_Doc]} -wrap_Pattern (T_Pattern sem ) (Inh_Pattern _lhsIisDeclOfLet _lhsIoptions ) = - (let ( _lhsOcopy,_lhsOisUnderscore,_lhsOpp,_lhsOpp',_lhsOstrictVars) = - (sem _lhsIisDeclOfLet _lhsIoptions ) - in (Syn_Pattern _lhsOcopy _lhsOisUnderscore _lhsOpp _lhsOpp' _lhsOstrictVars )) -sem_Pattern_Alias :: Name -> - Name -> - T_Pattern -> - T_Patterns -> - T_Pattern -sem_Pattern_Alias field_ attr_ (T_Pattern pat_ ) (T_Patterns parts_ ) = - (T_Pattern (\ _lhsIisDeclOfLet - _lhsIoptions -> - (let _lhsOstrictVars :: ([PP_Doc]) - _lhsOpp :: PP_Doc - _lhsOisUnderscore :: Bool - _lhsOpp' :: PP_Doc - _lhsOcopy :: Pattern - _patOisDeclOfLet :: Bool - _patOoptions :: Options - _partsOisDeclOfLet :: Bool - _partsOoptions :: Options - _patIcopy :: Pattern - _patIisUnderscore :: Bool - _patIpp :: PP_Doc - _patIpp' :: PP_Doc - _patIstrictVars :: ([PP_Doc]) - _partsIcopy :: Patterns - _partsIpps :: ([PP_Doc]) - _partsIpps' :: ([PP_Doc]) - _partsIstrictVars :: ([PP_Doc]) - -- "PrintCode.ag"(line 227, column 7) - _strictVar = - if strictCases _lhsIoptions && not _lhsIisDeclOfLet - then [_ppVar ] - else [] - -- "PrintCode.ag"(line 231, column 7) - _strictPatVars = - if stricterCases _lhsIoptions && not _lhsIisDeclOfLet - then _patIstrictVars - else [] - -- "PrintCode.ag"(line 235, column 7) - _lhsOstrictVars = - _strictVar ++ _strictPatVars - -- "PrintCode.ag"(line 249, column 7) - _addBang = - if bangpats _lhsIoptions && not _lhsIisDeclOfLet - then \p -> "!" >|< p - else id - -- "PrintCode.ag"(line 256, column 13) - _ppVar = - _addBang $ pp (attrname False field_ attr_) - -- "PrintCode.ag"(line 257, column 13) - _lhsOpp = - if _patIisUnderscore - then _ppVar - else _ppVar >|< "@" >|< _patIpp - -- "PrintCode.ag"(line 265, column 15) - _lhsOisUnderscore = - False - -- "PrintCode.ag"(line 279, column 13) - _lhsOpp' = - let attribute | field_ == _LOC || field_ == nullIdent = locname' attr_ - | otherwise = attrname False field_ attr_ - in attribute >|< "@" >|< _patIpp' - -- self rule - _copy = - Alias field_ attr_ _patIcopy _partsIcopy - -- self rule - _lhsOcopy = - _copy - -- copy rule (down) - _patOisDeclOfLet = - _lhsIisDeclOfLet - -- copy rule (down) - _patOoptions = - _lhsIoptions - -- copy rule (down) - _partsOisDeclOfLet = - _lhsIisDeclOfLet - -- copy rule (down) - _partsOoptions = - _lhsIoptions - ( _patIcopy,_patIisUnderscore,_patIpp,_patIpp',_patIstrictVars) = - (pat_ _patOisDeclOfLet _patOoptions ) - ( _partsIcopy,_partsIpps,_partsIpps',_partsIstrictVars) = - (parts_ _partsOisDeclOfLet _partsOoptions ) - in ( _lhsOcopy,_lhsOisUnderscore,_lhsOpp,_lhsOpp',_lhsOstrictVars))) ) -sem_Pattern_Constr :: Constructor -> - T_Patterns -> - T_Pattern -sem_Pattern_Constr name_ (T_Patterns pats_ ) = - (T_Pattern (\ _lhsIisDeclOfLet - _lhsIoptions -> - (let _lhsOpp :: PP_Doc - _lhsOisUnderscore :: Bool - _lhsOpp' :: PP_Doc - _lhsOstrictVars :: ([PP_Doc]) - _lhsOcopy :: Pattern - _patsOisDeclOfLet :: Bool - _patsOoptions :: Options - _patsIcopy :: Patterns - _patsIpps :: ([PP_Doc]) - _patsIpps' :: ([PP_Doc]) - _patsIstrictVars :: ([PP_Doc]) - -- "PrintCode.ag"(line 249, column 7) - _addBang = - if bangpats _lhsIoptions && not _lhsIisDeclOfLet - then \p -> "!" >|< p - else id - -- "PrintCode.ag"(line 254, column 13) - _lhsOpp = - _addBang $ pp_parens $ name_ >#< hv_sp _patsIpps - -- "PrintCode.ag"(line 263, column 15) - _lhsOisUnderscore = - False - -- "PrintCode.ag"(line 277, column 13) - _lhsOpp' = - pp_parens $ name_ >#< hv_sp (map pp_parens _patsIpps') - -- use rule "PrintCode.ag"(line 224, column 40) - _lhsOstrictVars = - _patsIstrictVars - -- self rule - _copy = - Constr name_ _patsIcopy - -- self rule - _lhsOcopy = - _copy - -- copy rule (down) - _patsOisDeclOfLet = - _lhsIisDeclOfLet - -- copy rule (down) - _patsOoptions = - _lhsIoptions - ( _patsIcopy,_patsIpps,_patsIpps',_patsIstrictVars) = - (pats_ _patsOisDeclOfLet _patsOoptions ) - in ( _lhsOcopy,_lhsOisUnderscore,_lhsOpp,_lhsOpp',_lhsOstrictVars))) ) -sem_Pattern_Product :: Pos -> - T_Patterns -> - T_Pattern -sem_Pattern_Product pos_ (T_Patterns pats_ ) = - (T_Pattern (\ _lhsIisDeclOfLet - _lhsIoptions -> - (let _lhsOpp :: PP_Doc - _lhsOisUnderscore :: Bool - _lhsOpp' :: PP_Doc - _lhsOstrictVars :: ([PP_Doc]) - _lhsOcopy :: Pattern - _patsOisDeclOfLet :: Bool - _patsOoptions :: Options - _patsIcopy :: Patterns - _patsIpps :: ([PP_Doc]) - _patsIpps' :: ([PP_Doc]) - _patsIstrictVars :: ([PP_Doc]) - -- "PrintCode.ag"(line 249, column 7) - _addBang = - if bangpats _lhsIoptions && not _lhsIisDeclOfLet - then \p -> "!" >|< p - else id - -- "PrintCode.ag"(line 255, column 13) - _lhsOpp = - _addBang $ pp_block "(" ")" "," _patsIpps - -- "PrintCode.ag"(line 264, column 15) - _lhsOisUnderscore = - False - -- "PrintCode.ag"(line 278, column 13) - _lhsOpp' = - pp_block "(" ")" "," _patsIpps' - -- use rule "PrintCode.ag"(line 224, column 40) - _lhsOstrictVars = - _patsIstrictVars - -- self rule - _copy = - Product pos_ _patsIcopy - -- self rule - _lhsOcopy = - _copy - -- copy rule (down) - _patsOisDeclOfLet = - _lhsIisDeclOfLet - -- copy rule (down) - _patsOoptions = - _lhsIoptions - ( _patsIcopy,_patsIpps,_patsIpps',_patsIstrictVars) = - (pats_ _patsOisDeclOfLet _patsOoptions ) - in ( _lhsOcopy,_lhsOisUnderscore,_lhsOpp,_lhsOpp',_lhsOstrictVars))) ) -sem_Pattern_Underscore :: Pos -> - T_Pattern -sem_Pattern_Underscore pos_ = - (T_Pattern (\ _lhsIisDeclOfLet - _lhsIoptions -> - (let _lhsOpp :: PP_Doc - _lhsOisUnderscore :: Bool - _lhsOpp' :: PP_Doc - _lhsOstrictVars :: ([PP_Doc]) - _lhsOcopy :: Pattern - -- "PrintCode.ag"(line 260, column 16) - _lhsOpp = - text "_" - -- "PrintCode.ag"(line 266, column 15) - _lhsOisUnderscore = - True - -- "PrintCode.ag"(line 282, column 16) - _lhsOpp' = - text "_" - -- use rule "PrintCode.ag"(line 224, column 40) - _lhsOstrictVars = - [] - -- self rule - _copy = - Underscore pos_ - -- self rule - _lhsOcopy = - _copy - in ( _lhsOcopy,_lhsOisUnderscore,_lhsOpp,_lhsOpp',_lhsOstrictVars))) ) --- Patterns ---------------------------------------------------- -{- - visit 0: - inherited attributes: - isDeclOfLet : Bool - options : Options - synthesized attributes: - copy : SELF - pps : [PP_Doc] - pps' : [PP_Doc] - strictVars : [PP_Doc] - alternatives: - alternative Cons: - child hd : Pattern - child tl : Patterns - visit 0: - local copy : _ - alternative Nil: - visit 0: - local copy : _ --} --- cata -sem_Patterns :: Patterns -> - T_Patterns -sem_Patterns list = - (Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list) ) --- semantic domain -newtype T_Patterns = T_Patterns (Bool -> - Options -> - ( Patterns,([PP_Doc]),([PP_Doc]),([PP_Doc]))) -data Inh_Patterns = Inh_Patterns {isDeclOfLet_Inh_Patterns :: Bool,options_Inh_Patterns :: Options} -data Syn_Patterns = Syn_Patterns {copy_Syn_Patterns :: Patterns,pps_Syn_Patterns :: [PP_Doc],pps'_Syn_Patterns :: [PP_Doc],strictVars_Syn_Patterns :: [PP_Doc]} -wrap_Patterns (T_Patterns sem ) (Inh_Patterns _lhsIisDeclOfLet _lhsIoptions ) = - (let ( _lhsOcopy,_lhsOpps,_lhsOpps',_lhsOstrictVars) = - (sem _lhsIisDeclOfLet _lhsIoptions ) - in (Syn_Patterns _lhsOcopy _lhsOpps _lhsOpps' _lhsOstrictVars )) -sem_Patterns_Cons :: T_Pattern -> - T_Patterns -> - T_Patterns -sem_Patterns_Cons (T_Pattern hd_ ) (T_Patterns tl_ ) = - (T_Patterns (\ _lhsIisDeclOfLet - _lhsIoptions -> - (let _lhsOpps :: ([PP_Doc]) - _lhsOpps' :: ([PP_Doc]) - _lhsOstrictVars :: ([PP_Doc]) - _lhsOcopy :: Patterns - _hdOisDeclOfLet :: Bool - _hdOoptions :: Options - _tlOisDeclOfLet :: Bool - _tlOoptions :: Options - _hdIcopy :: Pattern - _hdIisUnderscore :: Bool - _hdIpp :: PP_Doc - _hdIpp' :: PP_Doc - _hdIstrictVars :: ([PP_Doc]) - _tlIcopy :: Patterns - _tlIpps :: ([PP_Doc]) - _tlIpps' :: ([PP_Doc]) - _tlIstrictVars :: ([PP_Doc]) - -- "PrintCode.ag"(line 244, column 10) - _lhsOpps = - _hdIpp : _tlIpps - -- "PrintCode.ag"(line 273, column 10) - _lhsOpps' = - _hdIpp' : _tlIpps' - -- use rule "PrintCode.ag"(line 224, column 40) - _lhsOstrictVars = - _hdIstrictVars ++ _tlIstrictVars - -- self rule - _copy = - (:) _hdIcopy _tlIcopy - -- self rule - _lhsOcopy = - _copy - -- copy rule (down) - _hdOisDeclOfLet = - _lhsIisDeclOfLet - -- copy rule (down) - _hdOoptions = - _lhsIoptions - -- copy rule (down) - _tlOisDeclOfLet = - _lhsIisDeclOfLet - -- copy rule (down) - _tlOoptions = - _lhsIoptions - ( _hdIcopy,_hdIisUnderscore,_hdIpp,_hdIpp',_hdIstrictVars) = - (hd_ _hdOisDeclOfLet _hdOoptions ) - ( _tlIcopy,_tlIpps,_tlIpps',_tlIstrictVars) = - (tl_ _tlOisDeclOfLet _tlOoptions ) - in ( _lhsOcopy,_lhsOpps,_lhsOpps',_lhsOstrictVars))) ) -sem_Patterns_Nil :: T_Patterns -sem_Patterns_Nil = - (T_Patterns (\ _lhsIisDeclOfLet - _lhsIoptions -> - (let _lhsOpps :: ([PP_Doc]) - _lhsOpps' :: ([PP_Doc]) - _lhsOstrictVars :: ([PP_Doc]) - _lhsOcopy :: Patterns - -- "PrintCode.ag"(line 245, column 10) - _lhsOpps = - [] - -- "PrintCode.ag"(line 274, column 10) - _lhsOpps' = - [] - -- use rule "PrintCode.ag"(line 224, column 40) - _lhsOstrictVars = - [] - -- self rule - _copy = - [] - -- self rule - _lhsOcopy = - _copy - in ( _lhsOcopy,_lhsOpps,_lhsOpps',_lhsOstrictVars))) ) --- Program ----------------------------------------------------- -{- - visit 0: - inherited attributes: - importBlocks : PP_Doc - mainFile : String - mainName : String - moduleHeader : String -> String -> String -> Bool -> String - options : Options - optionsLine : String - pragmaBlocks : String - textBlocks : PP_Doc - synthesized attributes: - genIO : IO () - output : PP_Docs - alternatives: - alternative Program: - child chunks : Chunks - visit 0: - local mainModuleFile : _ - local genMainModule : _ - local commonFile : _ - local genCommonModule : _ --} --- cata -sem_Program :: Program -> - T_Program -sem_Program (Program _chunks ) = - (sem_Program_Program (sem_Chunks _chunks ) ) --- semantic domain -newtype T_Program = T_Program (PP_Doc -> - String -> - String -> - (String -> String -> String -> Bool -> String) -> - Options -> - String -> - String -> - PP_Doc -> - ( (IO ()),PP_Docs)) -data Inh_Program = Inh_Program {importBlocks_Inh_Program :: PP_Doc,mainFile_Inh_Program :: String,mainName_Inh_Program :: String,moduleHeader_Inh_Program :: String -> String -> String -> Bool -> String,options_Inh_Program :: Options,optionsLine_Inh_Program :: String,pragmaBlocks_Inh_Program :: String,textBlocks_Inh_Program :: PP_Doc} -data Syn_Program = Syn_Program {genIO_Syn_Program :: IO (),output_Syn_Program :: PP_Docs} -wrap_Program (T_Program sem ) (Inh_Program _lhsIimportBlocks _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsIoptions _lhsIoptionsLine _lhsIpragmaBlocks _lhsItextBlocks ) = - (let ( _lhsOgenIO,_lhsOoutput) = - (sem _lhsIimportBlocks _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsIoptions _lhsIoptionsLine _lhsIpragmaBlocks _lhsItextBlocks ) - in (Syn_Program _lhsOgenIO _lhsOoutput )) -sem_Program_Program :: T_Chunks -> - T_Program -sem_Program_Program (T_Chunks chunks_ ) = - (T_Program (\ _lhsIimportBlocks - _lhsImainFile - _lhsImainName - _lhsImoduleHeader - _lhsIoptions - _lhsIoptionsLine - _lhsIpragmaBlocks - _lhsItextBlocks -> - (let _chunksOnested :: Bool - _lhsOoutput :: PP_Docs - _chunksOisDeclOfLet :: Bool - _lhsOgenIO :: (IO ()) - _chunksOimportBlocks :: PP_Doc - _chunksOmainFile :: String - _chunksOmainName :: String - _chunksOmoduleHeader :: (String -> String -> String -> Bool -> String) - _chunksOoptions :: Options - _chunksOoptionsLine :: String - _chunksOpragmaBlocks :: String - _chunksOtextBlocks :: PP_Doc - _chunksIappendCommon :: ([[PP_Doc]]) - _chunksIappendMain :: ([[PP_Doc]]) - _chunksIgenSems :: (IO ()) - _chunksIimports :: ([String]) - _chunksIpps :: PP_Docs - -- "PrintCode.ag"(line 52, column 13) - _chunksOnested = - nest _lhsIoptions - -- "PrintCode.ag"(line 80, column 16) - _lhsOoutput = - _chunksIpps - -- "PrintCode.ag"(line 295, column 7) - _chunksOisDeclOfLet = - False - -- "PrintCode.ag"(line 324, column 7) - _mainModuleFile = - _lhsImainFile ++ ".hs" - -- "PrintCode.ag"(line 325, column 7) - _genMainModule = - writeModule _mainModuleFile - ( [ pp $ _lhsIpragmaBlocks - , pp $ _lhsIoptionsLine - , pp $ _lhsImoduleHeader _lhsImainName "" "" False - , pp $ ("import " ++ _lhsImainName ++ "_common\n") - ] - ++ map pp _chunksIimports - ++ map vlist _chunksIappendMain - ) - -- "PrintCode.ag"(line 336, column 7) - _commonFile = - _lhsImainFile ++ "_common.hs" - -- "PrintCode.ag"(line 337, column 7) - _genCommonModule = - writeModule _commonFile - ( [ pp $ _lhsIpragmaBlocks - , pp $ _lhsIoptionsLine - , pp $ _lhsImoduleHeader _lhsImainName "_common" "" True - , _lhsIimportBlocks - , _lhsItextBlocks - ] - ++ map vlist _chunksIappendCommon - ) - -- "PrintCode.ag"(line 348, column 7) - _lhsOgenIO = - do _genMainModule - _genCommonModule - _chunksIgenSems - -- copy rule (down) - _chunksOimportBlocks = - _lhsIimportBlocks - -- copy rule (down) - _chunksOmainFile = - _lhsImainFile - -- copy rule (down) - _chunksOmainName = - _lhsImainName - -- copy rule (down) - _chunksOmoduleHeader = - _lhsImoduleHeader - -- copy rule (down) - _chunksOoptions = - _lhsIoptions - -- copy rule (down) - _chunksOoptionsLine = - _lhsIoptionsLine - -- copy rule (down) - _chunksOpragmaBlocks = - _lhsIpragmaBlocks - -- copy rule (down) - _chunksOtextBlocks = - _lhsItextBlocks - ( _chunksIappendCommon,_chunksIappendMain,_chunksIgenSems,_chunksIimports,_chunksIpps) = - (chunks_ _chunksOimportBlocks _chunksOisDeclOfLet _chunksOmainFile _chunksOmainName _chunksOmoduleHeader _chunksOnested _chunksOoptions _chunksOoptionsLine _chunksOpragmaBlocks _chunksOtextBlocks ) - in ( _lhsOgenIO,_lhsOoutput))) ) --- Type -------------------------------------------------------- -{- - visit 0: - inherited attribute: - nested : Bool - synthesized attributes: - pp : PP_Doc - prec : Int - alternatives: - alternative Arr: - child left : Type - child right : Type - visit 0: - local l : _ - local r : _ - alternative List: - child tp : Type - alternative SimpleType: - child txt : {String} - alternative TupleType: - child tps : Types - alternative UnboxedTupleType: - child tps : Types --} --- cata -sem_Type :: Type -> - T_Type -sem_Type (Arr _left _right ) = - (sem_Type_Arr (sem_Type _left ) (sem_Type _right ) ) -sem_Type (List _tp ) = - (sem_Type_List (sem_Type _tp ) ) -sem_Type (SimpleType _txt ) = - (sem_Type_SimpleType _txt ) -sem_Type (TupleType _tps ) = - (sem_Type_TupleType (sem_Types _tps ) ) -sem_Type (UnboxedTupleType _tps ) = - (sem_Type_UnboxedTupleType (sem_Types _tps ) ) --- semantic domain -newtype T_Type = T_Type (Bool -> - ( PP_Doc,Int)) -data Inh_Type = Inh_Type {nested_Inh_Type :: Bool} -data Syn_Type = Syn_Type {pp_Syn_Type :: PP_Doc,prec_Syn_Type :: Int} -wrap_Type (T_Type sem ) (Inh_Type _lhsInested ) = - (let ( _lhsOpp,_lhsOprec) = - (sem _lhsInested ) - in (Syn_Type _lhsOpp _lhsOprec )) -sem_Type_Arr :: T_Type -> - T_Type -> - T_Type -sem_Type_Arr (T_Type left_ ) (T_Type right_ ) = - (T_Type (\ _lhsInested -> - (let _lhsOprec :: Int - _lhsOpp :: PP_Doc - _leftOnested :: Bool - _rightOnested :: Bool - _leftIpp :: PP_Doc - _leftIprec :: Int - _rightIpp :: PP_Doc - _rightIprec :: Int - -- "PrintCode.ag"(line 181, column 16) - _lhsOprec = - 2 - -- "PrintCode.ag"(line 181, column 16) - _lhsOpp = - _l >#< "->" >-< _r - -- "PrintCode.ag"(line 183, column 16) - _l = - if _leftIprec <= 2 then pp_parens _leftIpp else _leftIpp - -- "PrintCode.ag"(line 183, column 16) - _r = - if _rightIprec < 2 then pp_parens _rightIpp else _rightIpp - -- copy rule (down) - _leftOnested = - _lhsInested - -- copy rule (down) - _rightOnested = - _lhsInested - ( _leftIpp,_leftIprec) = - (left_ _leftOnested ) - ( _rightIpp,_rightIprec) = - (right_ _rightOnested ) - in ( _lhsOpp,_lhsOprec))) ) -sem_Type_List :: T_Type -> - T_Type -sem_Type_List (T_Type tp_ ) = - (T_Type (\ _lhsInested -> - (let _lhsOprec :: Int - _lhsOpp :: PP_Doc - _tpOnested :: Bool - _tpIpp :: PP_Doc - _tpIprec :: Int - -- "PrintCode.ag"(line 192, column 16) - _lhsOprec = - 5 - -- "PrintCode.ag"(line 192, column 16) - _lhsOpp = - "[" >|< _tpIpp >|< "]" - -- copy rule (down) - _tpOnested = - _lhsInested - ( _tpIpp,_tpIprec) = - (tp_ _tpOnested ) - in ( _lhsOpp,_lhsOprec))) ) -sem_Type_SimpleType :: String -> - T_Type -sem_Type_SimpleType txt_ = - (T_Type (\ _lhsInested -> - (let _lhsOprec :: Int - _lhsOpp :: PP_Doc - -- "PrintCode.ag"(line 195, column 16) - _lhsOprec = - 5 - -- "PrintCode.ag"(line 195, column 16) - _lhsOpp = - if reallySimple txt_ then text txt_ else pp_parens (text txt_) - in ( _lhsOpp,_lhsOprec))) ) -sem_Type_TupleType :: T_Types -> - T_Type -sem_Type_TupleType (T_Types tps_ ) = - (T_Type (\ _lhsInested -> - (let _lhsOprec :: Int - _lhsOpp :: PP_Doc - _tpsOnested :: Bool - _tpsIpps :: PP_Docs - -- "PrintCode.ag"(line 186, column 16) - _lhsOprec = - 5 - -- "PrintCode.ag"(line 186, column 16) - _lhsOpp = - ppTuple _lhsInested _tpsIpps - -- copy rule (down) - _tpsOnested = - _lhsInested - ( _tpsIpps) = - (tps_ _tpsOnested ) - in ( _lhsOpp,_lhsOprec))) ) -sem_Type_UnboxedTupleType :: T_Types -> - T_Type -sem_Type_UnboxedTupleType (T_Types tps_ ) = - (T_Type (\ _lhsInested -> - (let _lhsOprec :: Int - _lhsOpp :: PP_Doc - _tpsOnested :: Bool - _tpsIpps :: PP_Docs - -- "PrintCode.ag"(line 189, column 23) - _lhsOprec = - 5 - -- "PrintCode.ag"(line 189, column 23) - _lhsOpp = - ppUnboxedTuple _lhsInested _tpsIpps - -- copy rule (down) - _tpsOnested = - _lhsInested - ( _tpsIpps) = - (tps_ _tpsOnested ) - in ( _lhsOpp,_lhsOprec))) ) --- Types ------------------------------------------------------- -{- - visit 0: - inherited attribute: - nested : Bool - synthesized attribute: - pps : PP_Docs - alternatives: - alternative Cons: - child hd : Type - child tl : Types - alternative Nil: --} --- cata -sem_Types :: Types -> - T_Types -sem_Types list = - (Prelude.foldr sem_Types_Cons sem_Types_Nil (Prelude.map sem_Type list) ) --- semantic domain -newtype T_Types = T_Types (Bool -> - ( PP_Docs)) -data Inh_Types = Inh_Types {nested_Inh_Types :: Bool} -data Syn_Types = Syn_Types {pps_Syn_Types :: PP_Docs} -wrap_Types (T_Types sem ) (Inh_Types _lhsInested ) = - (let ( _lhsOpps) = - (sem _lhsInested ) - in (Syn_Types _lhsOpps )) -sem_Types_Cons :: T_Type -> - T_Types -> - T_Types -sem_Types_Cons (T_Type hd_ ) (T_Types tl_ ) = - (T_Types (\ _lhsInested -> - (let _lhsOpps :: PP_Docs - _hdOnested :: Bool - _tlOnested :: Bool - _hdIpp :: PP_Doc - _hdIprec :: Int - _tlIpps :: PP_Docs - -- "PrintCode.ag"(line 67, column 10) - _lhsOpps = - _hdIpp : _tlIpps - -- copy rule (down) - _hdOnested = - _lhsInested - -- copy rule (down) - _tlOnested = - _lhsInested - ( _hdIpp,_hdIprec) = - (hd_ _hdOnested ) - ( _tlIpps) = - (tl_ _tlOnested ) - in ( _lhsOpps))) ) -sem_Types_Nil :: T_Types -sem_Types_Nil = - (T_Types (\ _lhsInested -> - (let _lhsOpps :: PP_Docs - -- "PrintCode.ag"(line 68, column 10) - _lhsOpps = - [] - in ( _lhsOpps))) ) +-- UUAGC 0.9.5 (PrintCode.ag) +module PrintCode where + +import Char (isAlphaNum) +import Pretty +import Code +import Patterns +import Options +import CommonTypes (attrname, _LOC, getName, nullIdent) +import Data.List(intersperse) +import System.IO +import System.Directory + +import Pretty +import Patterns +import Data.List(partition) +import Data.Set(Set) +import qualified UU.DData.Set as Set +import Data.Map(Map) +import qualified Data.Map as Map + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (ConstructorIdent,Identifier) + +type PP_Docs = [PP_Doc] + +ppMultiSeqH :: [PP_Doc] -> PP_Doc -> PP_Doc +ppMultiSeqH = ppMultiSeq' (>#<) + +ppMultiSeqV :: [PP_Doc] -> PP_Doc -> PP_Doc +ppMultiSeqV = ppMultiSeq' (>-<) + +ppMultiSeq' :: (PP_Doc -> PP_Doc -> PP_Doc) -> [PP_Doc] -> PP_Doc -> PP_Doc +ppMultiSeq' next strictArgs expr + = foldr (\v r -> (v >#< "`seq`") `next` pp_parens r) expr strictArgs + + +reallySimple :: String -> Bool +reallySimple = and . map (\x -> isAlphaNum x || x=='_') + +ppTuple True pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps +ppTuple False pps = "(" >|< pp_block " " ")" "," pps +ppUnboxedTuple True pps = "(# " >|< pp_block " " (concat $ replicate (length pps `max` 1) " #)") ",(# " pps +ppUnboxedTuple False pps = "(# " >|< pp_block " " " #)" "," pps + + +locname' n = "_loc_" ++ getName n + +renderDocs :: [PP_Doc] -> String +renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) "" + +writeModule :: FilePath -> [PP_Doc] -> IO () +writeModule path docs + = do bExists <- doesFileExist path + if bExists + then do input <- readFile path + seq (length input) (return ()) + if input /= output + then dumpIt + else return () + else dumpIt + where + output = renderDocs docs + dumpIt = writeFile path output + +-- Unboxed tuples +-- unbox Whether unboxed tuples are wanted or not +-- inh The inherited attributes. +-- If there are none, no unboxing can take place, +-- because in that case the semantic function (a top-level identifier) would have an unboxed type. +-- Of course we can't have an unboxed 1-tuple +mkTupleExpr :: Bool -> Bool -> Exprs -> Expr +mkTupleExpr unbox noInh exprs | not unbox || noInh || length exprs == 1 = TupleExpr exprs + | otherwise = UnboxedTupleExpr exprs +mkTupleType :: Bool -> Bool -> Types -> Type +mkTupleType unbox noInh tps | not unbox || noInh || length tps == 1 = TupleType tps + | otherwise = UnboxedTupleType tps +mkTupleLhs :: Bool -> Bool -> [String] -> Lhs +mkTupleLhs unbox noInh comps | not unbox || noInh || length comps == 1 = TupleLhs comps + | otherwise = UnboxedTupleLhs comps +-- CaseAlt ----------------------------------------------------- +{- + visit 0: + inherited attributes: + nested : Bool + options : Options + outputfile : String + synthesized attribute: + pps : PP_Docs + alternatives: + alternative CaseAlt: + child left : Lhs + child expr : Expr +-} +-- cata +sem_CaseAlt :: CaseAlt -> + T_CaseAlt +sem_CaseAlt (CaseAlt _left _expr) = + (sem_CaseAlt_CaseAlt (sem_Lhs _left) (sem_Expr _expr)) +-- semantic domain +newtype T_CaseAlt = T_CaseAlt (Bool -> + Options -> + String -> + ( PP_Docs)) +data Inh_CaseAlt = Inh_CaseAlt {nested_Inh_CaseAlt :: Bool,options_Inh_CaseAlt :: Options,outputfile_Inh_CaseAlt :: String} +data Syn_CaseAlt = Syn_CaseAlt {pps_Syn_CaseAlt :: PP_Docs} +wrap_CaseAlt (T_CaseAlt sem) (Inh_CaseAlt _lhsInested _lhsIoptions _lhsIoutputfile) = + (let ( _lhsOpps) = + (sem _lhsInested _lhsIoptions _lhsIoutputfile) + in (Syn_CaseAlt _lhsOpps)) +sem_CaseAlt_CaseAlt :: T_Lhs -> + T_Expr -> + T_CaseAlt +sem_CaseAlt_CaseAlt (T_Lhs left_) (T_Expr expr_) = + (T_CaseAlt (\ _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpps :: PP_Docs + _leftOisDeclOfLet :: Bool + _leftOnested :: Bool + _leftOoptions :: Options + _leftOoutputfile :: String + _exprOnested :: Bool + _exprOoptions :: Options + _exprOoutputfile :: String + _leftIpp :: PP_Doc + _exprIpp :: PP_Doc + -- "PrintCode.ag"(line 150, column 16) + _lhsOpps = + ["{" >#< _leftIpp >#< "->", _exprIpp >#< "}"] + -- "PrintCode.ag"(line 326, column 7) + _leftOisDeclOfLet = + False + -- copy rule (down) + _leftOnested = + _lhsInested + -- copy rule (down) + _leftOoptions = + _lhsIoptions + -- copy rule (down) + _leftOoutputfile = + _lhsIoutputfile + -- copy rule (down) + _exprOnested = + _lhsInested + -- copy rule (down) + _exprOoptions = + _lhsIoptions + -- copy rule (down) + _exprOoutputfile = + _lhsIoutputfile + ( _leftIpp) = + (left_ _leftOisDeclOfLet _leftOnested _leftOoptions _leftOoutputfile) + ( _exprIpp) = + (expr_ _exprOnested _exprOoptions _exprOoutputfile) + in ( _lhsOpps)))) +-- CaseAlts ---------------------------------------------------- +{- + visit 0: + inherited attributes: + nested : Bool + options : Options + outputfile : String + synthesized attribute: + pps : PP_Docs + alternatives: + alternative Cons: + child hd : CaseAlt + child tl : CaseAlts + alternative Nil: +-} +-- cata +sem_CaseAlts :: CaseAlts -> + T_CaseAlts +sem_CaseAlts list = + (Prelude.foldr sem_CaseAlts_Cons sem_CaseAlts_Nil (Prelude.map sem_CaseAlt list)) +-- semantic domain +newtype T_CaseAlts = T_CaseAlts (Bool -> + Options -> + String -> + ( PP_Docs)) +data Inh_CaseAlts = Inh_CaseAlts {nested_Inh_CaseAlts :: Bool,options_Inh_CaseAlts :: Options,outputfile_Inh_CaseAlts :: String} +data Syn_CaseAlts = Syn_CaseAlts {pps_Syn_CaseAlts :: PP_Docs} +wrap_CaseAlts (T_CaseAlts sem) (Inh_CaseAlts _lhsInested _lhsIoptions _lhsIoutputfile) = + (let ( _lhsOpps) = + (sem _lhsInested _lhsIoptions _lhsIoutputfile) + in (Syn_CaseAlts _lhsOpps)) +sem_CaseAlts_Cons :: T_CaseAlt -> + T_CaseAlts -> + T_CaseAlts +sem_CaseAlts_Cons (T_CaseAlt hd_) (T_CaseAlts tl_) = + (T_CaseAlts (\ _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpps :: PP_Docs + _hdOnested :: Bool + _hdOoptions :: Options + _hdOoutputfile :: String + _tlOnested :: Bool + _tlOoptions :: Options + _tlOoutputfile :: String + _hdIpps :: PP_Docs + _tlIpps :: PP_Docs + -- "PrintCode.ag"(line 59, column 10) + _lhsOpps = + _hdIpps ++ _tlIpps + -- copy rule (down) + _hdOnested = + _lhsInested + -- copy rule (down) + _hdOoptions = + _lhsIoptions + -- copy rule (down) + _hdOoutputfile = + _lhsIoutputfile + -- copy rule (down) + _tlOnested = + _lhsInested + -- copy rule (down) + _tlOoptions = + _lhsIoptions + -- copy rule (down) + _tlOoutputfile = + _lhsIoutputfile + ( _hdIpps) = + (hd_ _hdOnested _hdOoptions _hdOoutputfile) + ( _tlIpps) = + (tl_ _tlOnested _tlOoptions _tlOoutputfile) + in ( _lhsOpps)))) +sem_CaseAlts_Nil :: T_CaseAlts +sem_CaseAlts_Nil = + (T_CaseAlts (\ _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpps :: PP_Docs + -- "PrintCode.ag"(line 60, column 10) + _lhsOpps = + [] + in ( _lhsOpps)))) +-- Chunk ------------------------------------------------------- +{- + visit 0: + inherited attributes: + importBlocks : PP_Doc + isDeclOfLet : Bool + mainFile : String + mainName : String + moduleHeader : String -> String -> String -> Bool -> String + nested : Bool + options : Options + optionsLine : String + pragmaBlocks : String + textBlocks : PP_Doc + synthesized attributes: + appendCommon : [[PP_Doc]] + appendMain : [[PP_Doc]] + genSems : IO () + imports : [String] + pps : PP_Docs + alternatives: + alternative Chunk: + child name : {String} + child comment : Decl + child info : Decls + child dataDef : Decls + child cataFun : Decls + child semDom : Decls + child semWrapper : Decls + child semFunctions : Decls + child semNames : {[String]} + visit 0: + local outputfile : _ + local exports : _ +-} +-- cata +sem_Chunk :: Chunk -> + T_Chunk +sem_Chunk (Chunk _name _comment _info _dataDef _cataFun _semDom _semWrapper _semFunctions _semNames) = + (sem_Chunk_Chunk _name (sem_Decl _comment) (sem_Decls _info) (sem_Decls _dataDef) (sem_Decls _cataFun) (sem_Decls _semDom) (sem_Decls _semWrapper) (sem_Decls _semFunctions) _semNames) +-- semantic domain +newtype T_Chunk = T_Chunk (PP_Doc -> + Bool -> + String -> + String -> + (String -> String -> String -> Bool -> String) -> + Bool -> + Options -> + String -> + String -> + PP_Doc -> + ( ([[PP_Doc]]),([[PP_Doc]]),(IO ()),([String]),PP_Docs)) +data Inh_Chunk = Inh_Chunk {importBlocks_Inh_Chunk :: PP_Doc,isDeclOfLet_Inh_Chunk :: Bool,mainFile_Inh_Chunk :: String,mainName_Inh_Chunk :: String,moduleHeader_Inh_Chunk :: String -> String -> String -> Bool -> String,nested_Inh_Chunk :: Bool,options_Inh_Chunk :: Options,optionsLine_Inh_Chunk :: String,pragmaBlocks_Inh_Chunk :: String,textBlocks_Inh_Chunk :: PP_Doc} +data Syn_Chunk = Syn_Chunk {appendCommon_Syn_Chunk :: [[PP_Doc]],appendMain_Syn_Chunk :: [[PP_Doc]],genSems_Syn_Chunk :: IO (),imports_Syn_Chunk :: [String],pps_Syn_Chunk :: PP_Docs} +wrap_Chunk (T_Chunk sem) (Inh_Chunk _lhsIimportBlocks _lhsIisDeclOfLet _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInested _lhsIoptions _lhsIoptionsLine _lhsIpragmaBlocks _lhsItextBlocks) = + (let ( _lhsOappendCommon,_lhsOappendMain,_lhsOgenSems,_lhsOimports,_lhsOpps) = + (sem _lhsIimportBlocks _lhsIisDeclOfLet _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInested _lhsIoptions _lhsIoptionsLine _lhsIpragmaBlocks _lhsItextBlocks) + in (Syn_Chunk _lhsOappendCommon _lhsOappendMain _lhsOgenSems _lhsOimports _lhsOpps)) +sem_Chunk_Chunk :: String -> + T_Decl -> + T_Decls -> + T_Decls -> + T_Decls -> + T_Decls -> + T_Decls -> + T_Decls -> + ([String]) -> + T_Chunk +sem_Chunk_Chunk name_ (T_Decl comment_) (T_Decls info_) (T_Decls dataDef_) (T_Decls cataFun_) (T_Decls semDom_) (T_Decls semWrapper_) (T_Decls semFunctions_) semNames_ = + (T_Chunk (\ _lhsIimportBlocks + _lhsIisDeclOfLet + _lhsImainFile + _lhsImainName + _lhsImoduleHeader + _lhsInested + _lhsIoptions + _lhsIoptionsLine + _lhsIpragmaBlocks + _lhsItextBlocks -> + (let _lhsOpps :: PP_Docs + _lhsOimports :: ([String]) + _lhsOappendCommon :: ([[PP_Doc]]) + _lhsOappendMain :: ([[PP_Doc]]) + _lhsOgenSems :: (IO ()) + _commentOisDeclOfLet :: Bool + _commentOnested :: Bool + _commentOoptions :: Options + _commentOoutputfile :: String + _infoOisDeclOfLet :: Bool + _infoOnested :: Bool + _infoOoptions :: Options + _infoOoutputfile :: String + _dataDefOisDeclOfLet :: Bool + _dataDefOnested :: Bool + _dataDefOoptions :: Options + _dataDefOoutputfile :: String + _cataFunOisDeclOfLet :: Bool + _cataFunOnested :: Bool + _cataFunOoptions :: Options + _cataFunOoutputfile :: String + _semDomOisDeclOfLet :: Bool + _semDomOnested :: Bool + _semDomOoptions :: Options + _semDomOoutputfile :: String + _semWrapperOisDeclOfLet :: Bool + _semWrapperOnested :: Bool + _semWrapperOoptions :: Options + _semWrapperOoutputfile :: String + _semFunctionsOisDeclOfLet :: Bool + _semFunctionsOnested :: Bool + _semFunctionsOoptions :: Options + _semFunctionsOoutputfile :: String + _commentIpp :: PP_Doc + _infoIpps :: PP_Docs + _dataDefIpps :: PP_Docs + _cataFunIpps :: PP_Docs + _semDomIpps :: PP_Docs + _semWrapperIpps :: PP_Docs + _semFunctionsIpps :: PP_Docs + -- "PrintCode.ag"(line 37, column 7) + _outputfile = + if sepSemMods _lhsIoptions + then _lhsImainFile ++ "_" ++ name_ ++ ".hs" + else _lhsImainFile ++ ".hs" + -- "PrintCode.ag"(line 83, column 16) + _lhsOpps = + _commentIpp + : _infoIpps + ++ _dataDefIpps + ++ _cataFunIpps + ++ _semDomIpps + ++ _semWrapperIpps + ++ _semFunctionsIpps + -- "PrintCode.ag"(line 383, column 7) + _lhsOimports = + ["import " ++ _lhsImainName ++ "_" ++ name_ ++ "\n"] + -- "PrintCode.ag"(line 389, column 7) + _lhsOappendCommon = + [ [_commentIpp] + , _dataDefIpps + , _semDomIpps + ] + -- "PrintCode.ag"(line 394, column 7) + _lhsOappendMain = + [ [_commentIpp] + , _cataFunIpps + , _semWrapperIpps + ] + -- "PrintCode.ag"(line 404, column 7) + _lhsOgenSems = + writeModule _outputfile + [ pp $ _lhsIpragmaBlocks + , pp $ _lhsIoptionsLine + , pp $ _lhsImoduleHeader _lhsImainName ("_" ++ name_) _exports True + , pp $ ("import " ++ _lhsImainName ++ "_common\n") + , _commentIpp + , vlist_sep "" _infoIpps + , vlist_sep "" _semFunctionsIpps + ] + -- "PrintCode.ag"(line 417, column 7) + _exports = + concat $ intersperse "," semNames_ + -- copy rule (down) + _commentOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _commentOnested = + _lhsInested + -- copy rule (down) + _commentOoptions = + _lhsIoptions + -- copy rule (from local) + _commentOoutputfile = + _outputfile + -- copy rule (down) + _infoOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _infoOnested = + _lhsInested + -- copy rule (down) + _infoOoptions = + _lhsIoptions + -- copy rule (from local) + _infoOoutputfile = + _outputfile + -- copy rule (down) + _dataDefOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _dataDefOnested = + _lhsInested + -- copy rule (down) + _dataDefOoptions = + _lhsIoptions + -- copy rule (from local) + _dataDefOoutputfile = + _outputfile + -- copy rule (down) + _cataFunOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _cataFunOnested = + _lhsInested + -- copy rule (down) + _cataFunOoptions = + _lhsIoptions + -- copy rule (from local) + _cataFunOoutputfile = + _outputfile + -- copy rule (down) + _semDomOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _semDomOnested = + _lhsInested + -- copy rule (down) + _semDomOoptions = + _lhsIoptions + -- copy rule (from local) + _semDomOoutputfile = + _outputfile + -- copy rule (down) + _semWrapperOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _semWrapperOnested = + _lhsInested + -- copy rule (down) + _semWrapperOoptions = + _lhsIoptions + -- copy rule (from local) + _semWrapperOoutputfile = + _outputfile + -- copy rule (down) + _semFunctionsOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _semFunctionsOnested = + _lhsInested + -- copy rule (down) + _semFunctionsOoptions = + _lhsIoptions + -- copy rule (from local) + _semFunctionsOoutputfile = + _outputfile + ( _commentIpp) = + (comment_ _commentOisDeclOfLet _commentOnested _commentOoptions _commentOoutputfile) + ( _infoIpps) = + (info_ _infoOisDeclOfLet _infoOnested _infoOoptions _infoOoutputfile) + ( _dataDefIpps) = + (dataDef_ _dataDefOisDeclOfLet _dataDefOnested _dataDefOoptions _dataDefOoutputfile) + ( _cataFunIpps) = + (cataFun_ _cataFunOisDeclOfLet _cataFunOnested _cataFunOoptions _cataFunOoutputfile) + ( _semDomIpps) = + (semDom_ _semDomOisDeclOfLet _semDomOnested _semDomOoptions _semDomOoutputfile) + ( _semWrapperIpps) = + (semWrapper_ _semWrapperOisDeclOfLet _semWrapperOnested _semWrapperOoptions _semWrapperOoutputfile) + ( _semFunctionsIpps) = + (semFunctions_ _semFunctionsOisDeclOfLet _semFunctionsOnested _semFunctionsOoptions _semFunctionsOoutputfile) + in ( _lhsOappendCommon,_lhsOappendMain,_lhsOgenSems,_lhsOimports,_lhsOpps)))) +-- Chunks ------------------------------------------------------ +{- + visit 0: + inherited attributes: + importBlocks : PP_Doc + isDeclOfLet : Bool + mainFile : String + mainName : String + moduleHeader : String -> String -> String -> Bool -> String + nested : Bool + options : Options + optionsLine : String + pragmaBlocks : String + textBlocks : PP_Doc + synthesized attributes: + appendCommon : [[PP_Doc]] + appendMain : [[PP_Doc]] + genSems : IO () + imports : [String] + pps : PP_Docs + alternatives: + alternative Cons: + child hd : Chunk + child tl : Chunks + alternative Nil: +-} +-- cata +sem_Chunks :: Chunks -> + T_Chunks +sem_Chunks list = + (Prelude.foldr sem_Chunks_Cons sem_Chunks_Nil (Prelude.map sem_Chunk list)) +-- semantic domain +newtype T_Chunks = T_Chunks (PP_Doc -> + Bool -> + String -> + String -> + (String -> String -> String -> Bool -> String) -> + Bool -> + Options -> + String -> + String -> + PP_Doc -> + ( ([[PP_Doc]]),([[PP_Doc]]),(IO ()),([String]),PP_Docs)) +data Inh_Chunks = Inh_Chunks {importBlocks_Inh_Chunks :: PP_Doc,isDeclOfLet_Inh_Chunks :: Bool,mainFile_Inh_Chunks :: String,mainName_Inh_Chunks :: String,moduleHeader_Inh_Chunks :: String -> String -> String -> Bool -> String,nested_Inh_Chunks :: Bool,options_Inh_Chunks :: Options,optionsLine_Inh_Chunks :: String,pragmaBlocks_Inh_Chunks :: String,textBlocks_Inh_Chunks :: PP_Doc} +data Syn_Chunks = Syn_Chunks {appendCommon_Syn_Chunks :: [[PP_Doc]],appendMain_Syn_Chunks :: [[PP_Doc]],genSems_Syn_Chunks :: IO (),imports_Syn_Chunks :: [String],pps_Syn_Chunks :: PP_Docs} +wrap_Chunks (T_Chunks sem) (Inh_Chunks _lhsIimportBlocks _lhsIisDeclOfLet _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInested _lhsIoptions _lhsIoptionsLine _lhsIpragmaBlocks _lhsItextBlocks) = + (let ( _lhsOappendCommon,_lhsOappendMain,_lhsOgenSems,_lhsOimports,_lhsOpps) = + (sem _lhsIimportBlocks _lhsIisDeclOfLet _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInested _lhsIoptions _lhsIoptionsLine _lhsIpragmaBlocks _lhsItextBlocks) + in (Syn_Chunks _lhsOappendCommon _lhsOappendMain _lhsOgenSems _lhsOimports _lhsOpps)) +sem_Chunks_Cons :: T_Chunk -> + T_Chunks -> + T_Chunks +sem_Chunks_Cons (T_Chunk hd_) (T_Chunks tl_) = + (T_Chunks (\ _lhsIimportBlocks + _lhsIisDeclOfLet + _lhsImainFile + _lhsImainName + _lhsImoduleHeader + _lhsInested + _lhsIoptions + _lhsIoptionsLine + _lhsIpragmaBlocks + _lhsItextBlocks -> + (let _lhsOpps :: PP_Docs + _lhsOappendCommon :: ([[PP_Doc]]) + _lhsOappendMain :: ([[PP_Doc]]) + _lhsOgenSems :: (IO ()) + _lhsOimports :: ([String]) + _hdOimportBlocks :: PP_Doc + _hdOisDeclOfLet :: Bool + _hdOmainFile :: String + _hdOmainName :: String + _hdOmoduleHeader :: (String -> String -> String -> Bool -> String) + _hdOnested :: Bool + _hdOoptions :: Options + _hdOoptionsLine :: String + _hdOpragmaBlocks :: String + _hdOtextBlocks :: PP_Doc + _tlOimportBlocks :: PP_Doc + _tlOisDeclOfLet :: Bool + _tlOmainFile :: String + _tlOmainName :: String + _tlOmoduleHeader :: (String -> String -> String -> Bool -> String) + _tlOnested :: Bool + _tlOoptions :: Options + _tlOoptionsLine :: String + _tlOpragmaBlocks :: String + _tlOtextBlocks :: PP_Doc + _hdIappendCommon :: ([[PP_Doc]]) + _hdIappendMain :: ([[PP_Doc]]) + _hdIgenSems :: (IO ()) + _hdIimports :: ([String]) + _hdIpps :: PP_Docs + _tlIappendCommon :: ([[PP_Doc]]) + _tlIappendMain :: ([[PP_Doc]]) + _tlIgenSems :: (IO ()) + _tlIimports :: ([String]) + _tlIpps :: PP_Docs + -- "PrintCode.ag"(line 75, column 10) + _lhsOpps = + _hdIpps ++ _tlIpps + -- use rule "PrintCode.ag"(line 385, column 50) + _lhsOappendCommon = + _hdIappendCommon ++ _tlIappendCommon + -- use rule "PrintCode.ag"(line 385, column 50) + _lhsOappendMain = + _hdIappendMain ++ _tlIappendMain + -- use rule "PrintCode.ag"(line 400, column 33) + _lhsOgenSems = + _hdIgenSems >> _tlIgenSems + -- use rule "PrintCode.ag"(line 380, column 33) + _lhsOimports = + _hdIimports ++ _tlIimports + -- copy rule (down) + _hdOimportBlocks = + _lhsIimportBlocks + -- copy rule (down) + _hdOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _hdOmainFile = + _lhsImainFile + -- copy rule (down) + _hdOmainName = + _lhsImainName + -- copy rule (down) + _hdOmoduleHeader = + _lhsImoduleHeader + -- copy rule (down) + _hdOnested = + _lhsInested + -- copy rule (down) + _hdOoptions = + _lhsIoptions + -- copy rule (down) + _hdOoptionsLine = + _lhsIoptionsLine + -- copy rule (down) + _hdOpragmaBlocks = + _lhsIpragmaBlocks + -- copy rule (down) + _hdOtextBlocks = + _lhsItextBlocks + -- copy rule (down) + _tlOimportBlocks = + _lhsIimportBlocks + -- copy rule (down) + _tlOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _tlOmainFile = + _lhsImainFile + -- copy rule (down) + _tlOmainName = + _lhsImainName + -- copy rule (down) + _tlOmoduleHeader = + _lhsImoduleHeader + -- copy rule (down) + _tlOnested = + _lhsInested + -- copy rule (down) + _tlOoptions = + _lhsIoptions + -- copy rule (down) + _tlOoptionsLine = + _lhsIoptionsLine + -- copy rule (down) + _tlOpragmaBlocks = + _lhsIpragmaBlocks + -- copy rule (down) + _tlOtextBlocks = + _lhsItextBlocks + ( _hdIappendCommon,_hdIappendMain,_hdIgenSems,_hdIimports,_hdIpps) = + (hd_ _hdOimportBlocks _hdOisDeclOfLet _hdOmainFile _hdOmainName _hdOmoduleHeader _hdOnested _hdOoptions _hdOoptionsLine _hdOpragmaBlocks _hdOtextBlocks) + ( _tlIappendCommon,_tlIappendMain,_tlIgenSems,_tlIimports,_tlIpps) = + (tl_ _tlOimportBlocks _tlOisDeclOfLet _tlOmainFile _tlOmainName _tlOmoduleHeader _tlOnested _tlOoptions _tlOoptionsLine _tlOpragmaBlocks _tlOtextBlocks) + in ( _lhsOappendCommon,_lhsOappendMain,_lhsOgenSems,_lhsOimports,_lhsOpps)))) +sem_Chunks_Nil :: T_Chunks +sem_Chunks_Nil = + (T_Chunks (\ _lhsIimportBlocks + _lhsIisDeclOfLet + _lhsImainFile + _lhsImainName + _lhsImoduleHeader + _lhsInested + _lhsIoptions + _lhsIoptionsLine + _lhsIpragmaBlocks + _lhsItextBlocks -> + (let _lhsOpps :: PP_Docs + _lhsOappendCommon :: ([[PP_Doc]]) + _lhsOappendMain :: ([[PP_Doc]]) + _lhsOgenSems :: (IO ()) + _lhsOimports :: ([String]) + -- "PrintCode.ag"(line 76, column 10) + _lhsOpps = + [] + -- use rule "PrintCode.ag"(line 385, column 50) + _lhsOappendCommon = + [] + -- use rule "PrintCode.ag"(line 385, column 50) + _lhsOappendMain = + [] + -- use rule "PrintCode.ag"(line 400, column 33) + _lhsOgenSems = + return () + -- use rule "PrintCode.ag"(line 380, column 33) + _lhsOimports = + [] + in ( _lhsOappendCommon,_lhsOappendMain,_lhsOgenSems,_lhsOimports,_lhsOpps)))) +-- DataAlt ----------------------------------------------------- +{- + visit 0: + inherited attributes: + nested : Bool + strictPre : PP_Doc + synthesized attribute: + pp : PP_Doc + alternatives: + alternative DataAlt: + child name : {String} + child args : {[String]} + alternative Record: + child name : {String} + child args : {[(String,String)]} +-} +-- cata +sem_DataAlt :: DataAlt -> + T_DataAlt +sem_DataAlt (DataAlt _name _args) = + (sem_DataAlt_DataAlt _name _args) +sem_DataAlt (Record _name _args) = + (sem_DataAlt_Record _name _args) +-- semantic domain +newtype T_DataAlt = T_DataAlt (Bool -> + PP_Doc -> + ( PP_Doc)) +data Inh_DataAlt = Inh_DataAlt {nested_Inh_DataAlt :: Bool,strictPre_Inh_DataAlt :: PP_Doc} +data Syn_DataAlt = Syn_DataAlt {pp_Syn_DataAlt :: PP_Doc} +wrap_DataAlt (T_DataAlt sem) (Inh_DataAlt _lhsInested _lhsIstrictPre) = + (let ( _lhsOpp) = + (sem _lhsInested _lhsIstrictPre) + in (Syn_DataAlt _lhsOpp)) +sem_DataAlt_DataAlt :: String -> + ([String]) -> + T_DataAlt +sem_DataAlt_DataAlt name_ args_ = + (T_DataAlt (\ _lhsInested + _lhsIstrictPre -> + (let _lhsOpp :: PP_Doc + -- "PrintCode.ag"(line 153, column 16) + _lhsOpp = + name_ >#< hv_sp (map ((_lhsIstrictPre >|<) . pp_parens . text) args_) + in ( _lhsOpp)))) +sem_DataAlt_Record :: String -> + ([(String,String)]) -> + T_DataAlt +sem_DataAlt_Record name_ args_ = + (T_DataAlt (\ _lhsInested + _lhsIstrictPre -> + (let _lhsOpp :: PP_Doc + -- "PrintCode.ag"(line 154, column 16) + _lhsOpp = + name_ >#< pp_block "{" "}" "," + [ f >#< "::" >#< t | (f,t) <- args_ ] + in ( _lhsOpp)))) +-- DataAlts ---------------------------------------------------- +{- + visit 0: + inherited attributes: + nested : Bool + strictPre : PP_Doc + synthesized attribute: + pps : PP_Docs + alternatives: + alternative Cons: + child hd : DataAlt + child tl : DataAlts + alternative Nil: +-} +-- cata +sem_DataAlts :: DataAlts -> + T_DataAlts +sem_DataAlts list = + (Prelude.foldr sem_DataAlts_Cons sem_DataAlts_Nil (Prelude.map sem_DataAlt list)) +-- semantic domain +newtype T_DataAlts = T_DataAlts (Bool -> + PP_Doc -> + ( PP_Docs)) +data Inh_DataAlts = Inh_DataAlts {nested_Inh_DataAlts :: Bool,strictPre_Inh_DataAlts :: PP_Doc} +data Syn_DataAlts = Syn_DataAlts {pps_Syn_DataAlts :: PP_Docs} +wrap_DataAlts (T_DataAlts sem) (Inh_DataAlts _lhsInested _lhsIstrictPre) = + (let ( _lhsOpps) = + (sem _lhsInested _lhsIstrictPre) + in (Syn_DataAlts _lhsOpps)) +sem_DataAlts_Cons :: T_DataAlt -> + T_DataAlts -> + T_DataAlts +sem_DataAlts_Cons (T_DataAlt hd_) (T_DataAlts tl_) = + (T_DataAlts (\ _lhsInested + _lhsIstrictPre -> + (let _lhsOpps :: PP_Docs + _hdOnested :: Bool + _hdOstrictPre :: PP_Doc + _tlOnested :: Bool + _tlOstrictPre :: PP_Doc + _hdIpp :: PP_Doc + _tlIpps :: PP_Docs + -- "PrintCode.ag"(line 63, column 10) + _lhsOpps = + _hdIpp : _tlIpps + -- copy rule (down) + _hdOnested = + _lhsInested + -- copy rule (down) + _hdOstrictPre = + _lhsIstrictPre + -- copy rule (down) + _tlOnested = + _lhsInested + -- copy rule (down) + _tlOstrictPre = + _lhsIstrictPre + ( _hdIpp) = + (hd_ _hdOnested _hdOstrictPre) + ( _tlIpps) = + (tl_ _tlOnested _tlOstrictPre) + in ( _lhsOpps)))) +sem_DataAlts_Nil :: T_DataAlts +sem_DataAlts_Nil = + (T_DataAlts (\ _lhsInested + _lhsIstrictPre -> + (let _lhsOpps :: PP_Docs + -- "PrintCode.ag"(line 64, column 10) + _lhsOpps = + [] + in ( _lhsOpps)))) +-- Decl -------------------------------------------------------- +{- + visit 0: + inherited attributes: + isDeclOfLet : Bool + nested : Bool + options : Options + outputfile : String + synthesized attribute: + pp : PP_Doc + alternatives: + alternative Comment: + child txt : {String} + alternative Data: + child name : {String} + child params : {[String]} + child alts : DataAlts + child strict : {Bool} + child derivings : {[String]} + alternative Decl: + child left : Lhs + child rhs : Expr + child binds : {Set String} + child uses : {Set String} + alternative NewType: + child name : {String} + child params : {[String]} + child con : {String} + child tp : Type + alternative PragmaDecl: + child txt : {String} + alternative TSig: + child name : {String} + child tp : Type + alternative Type: + child name : {String} + child params : {[String]} + child tp : Type +-} +-- cata +sem_Decl :: Decl -> + T_Decl +sem_Decl (Comment _txt) = + (sem_Decl_Comment _txt) +sem_Decl (Data _name _params _alts _strict _derivings) = + (sem_Decl_Data _name _params (sem_DataAlts _alts) _strict _derivings) +sem_Decl (Decl _left _rhs _binds _uses) = + (sem_Decl_Decl (sem_Lhs _left) (sem_Expr _rhs) _binds _uses) +sem_Decl (NewType _name _params _con _tp) = + (sem_Decl_NewType _name _params _con (sem_Type _tp)) +sem_Decl (PragmaDecl _txt) = + (sem_Decl_PragmaDecl _txt) +sem_Decl (TSig _name _tp) = + (sem_Decl_TSig _name (sem_Type _tp)) +sem_Decl (Type _name _params _tp) = + (sem_Decl_Type _name _params (sem_Type _tp)) +-- semantic domain +newtype T_Decl = T_Decl (Bool -> + Bool -> + Options -> + String -> + ( PP_Doc)) +data Inh_Decl = Inh_Decl {isDeclOfLet_Inh_Decl :: Bool,nested_Inh_Decl :: Bool,options_Inh_Decl :: Options,outputfile_Inh_Decl :: String} +data Syn_Decl = Syn_Decl {pp_Syn_Decl :: PP_Doc} +wrap_Decl (T_Decl sem) (Inh_Decl _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile) = + (let ( _lhsOpp) = + (sem _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile) + in (Syn_Decl _lhsOpp)) +sem_Decl_Comment :: String -> + T_Decl +sem_Decl_Comment txt_ = + (T_Decl (\ _lhsIisDeclOfLet + _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + -- "PrintCode.ag"(line 106, column 16) + _lhsOpp = + if '\n' `elem` txt_ + then "{-" >-< vlist (lines txt_) >-< "-}" + else "--" >#< txt_ + in ( _lhsOpp)))) +sem_Decl_Data :: String -> + ([String]) -> + T_DataAlts -> + Bool -> + ([String]) -> + T_Decl +sem_Decl_Data name_ params_ (T_DataAlts alts_) strict_ derivings_ = + (T_Decl (\ _lhsIisDeclOfLet + _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _altsOstrictPre :: PP_Doc + _altsOnested :: Bool + _altsIpps :: PP_Docs + -- "PrintCode.ag"(line 94, column 16) + _lhsOpp = + "data" >#< hv_sp (name_ : params_) + >#< ( case _altsIpps of + [] -> empty + (x:xs) -> "=" >#< x + >-< vlist (map ("|" >#<) xs) + >-< if null derivings_ + then empty + else "deriving" >#< ppTuple False (map text derivings_) + ) + -- "PrintCode.ag"(line 228, column 10) + _altsOstrictPre = + if strict_ then pp "!" else empty + -- copy rule (down) + _altsOnested = + _lhsInested + ( _altsIpps) = + (alts_ _altsOnested _altsOstrictPre) + in ( _lhsOpp)))) +sem_Decl_Decl :: T_Lhs -> + T_Expr -> + (Set String) -> + (Set String) -> + T_Decl +sem_Decl_Decl (T_Lhs left_) (T_Expr rhs_) binds_ uses_ = + (T_Decl (\ _lhsIisDeclOfLet + _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _leftOisDeclOfLet :: Bool + _leftOnested :: Bool + _leftOoptions :: Options + _leftOoutputfile :: String + _rhsOnested :: Bool + _rhsOoptions :: Options + _rhsOoutputfile :: String + _leftIpp :: PP_Doc + _rhsIpp :: PP_Doc + -- "PrintCode.ag"(line 92, column 16) + _lhsOpp = + _leftIpp >#< "=" + >-< indent 4 _rhsIpp + -- copy rule (down) + _leftOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _leftOnested = + _lhsInested + -- copy rule (down) + _leftOoptions = + _lhsIoptions + -- copy rule (down) + _leftOoutputfile = + _lhsIoutputfile + -- copy rule (down) + _rhsOnested = + _lhsInested + -- copy rule (down) + _rhsOoptions = + _lhsIoptions + -- copy rule (down) + _rhsOoutputfile = + _lhsIoutputfile + ( _leftIpp) = + (left_ _leftOisDeclOfLet _leftOnested _leftOoptions _leftOoutputfile) + ( _rhsIpp) = + (rhs_ _rhsOnested _rhsOoptions _rhsOoutputfile) + in ( _lhsOpp)))) +sem_Decl_NewType :: String -> + ([String]) -> + String -> + T_Type -> + T_Decl +sem_Decl_NewType name_ params_ con_ (T_Type tp_) = + (T_Decl (\ _lhsIisDeclOfLet + _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _tpOnested :: Bool + _tpIpp :: PP_Doc + _tpIprec :: Int + -- "PrintCode.ag"(line 103, column 16) + _lhsOpp = + "newtype" >#< hv_sp (name_ : params_) >#< "=" >#< con_ >#< pp_parens _tpIpp + -- copy rule (down) + _tpOnested = + _lhsInested + ( _tpIpp,_tpIprec) = + (tp_ _tpOnested) + in ( _lhsOpp)))) +sem_Decl_PragmaDecl :: String -> + T_Decl +sem_Decl_PragmaDecl txt_ = + (T_Decl (\ _lhsIisDeclOfLet + _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + -- "PrintCode.ag"(line 109, column 16) + _lhsOpp = + "{-#" >#< text txt_ >#< "#-}" + in ( _lhsOpp)))) +sem_Decl_TSig :: String -> + T_Type -> + T_Decl +sem_Decl_TSig name_ (T_Type tp_) = + (T_Decl (\ _lhsIisDeclOfLet + _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _tpOnested :: Bool + _tpIpp :: PP_Doc + _tpIprec :: Int + -- "PrintCode.ag"(line 105, column 16) + _lhsOpp = + name_ >#< "::" >#< _tpIpp + -- copy rule (down) + _tpOnested = + _lhsInested + ( _tpIpp,_tpIprec) = + (tp_ _tpOnested) + in ( _lhsOpp)))) +sem_Decl_Type :: String -> + ([String]) -> + T_Type -> + T_Decl +sem_Decl_Type name_ params_ (T_Type tp_) = + (T_Decl (\ _lhsIisDeclOfLet + _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _tpOnested :: Bool + _tpIpp :: PP_Doc + _tpIprec :: Int + -- "PrintCode.ag"(line 104, column 16) + _lhsOpp = + "type" >#< hv_sp (name_ : params_) >#< "=" >#< _tpIpp + -- copy rule (down) + _tpOnested = + _lhsInested + ( _tpIpp,_tpIprec) = + (tp_ _tpOnested) + in ( _lhsOpp)))) +-- Decls ------------------------------------------------------- +{- + visit 0: + inherited attributes: + isDeclOfLet : Bool + nested : Bool + options : Options + outputfile : String + synthesized attribute: + pps : PP_Docs + alternatives: + alternative Cons: + child hd : Decl + child tl : Decls + alternative Nil: +-} +-- cata +sem_Decls :: Decls -> + T_Decls +sem_Decls list = + (Prelude.foldr sem_Decls_Cons sem_Decls_Nil (Prelude.map sem_Decl list)) +-- semantic domain +newtype T_Decls = T_Decls (Bool -> + Bool -> + Options -> + String -> + ( PP_Docs)) +data Inh_Decls = Inh_Decls {isDeclOfLet_Inh_Decls :: Bool,nested_Inh_Decls :: Bool,options_Inh_Decls :: Options,outputfile_Inh_Decls :: String} +data Syn_Decls = Syn_Decls {pps_Syn_Decls :: PP_Docs} +wrap_Decls (T_Decls sem) (Inh_Decls _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile) = + (let ( _lhsOpps) = + (sem _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile) + in (Syn_Decls _lhsOpps)) +sem_Decls_Cons :: T_Decl -> + T_Decls -> + T_Decls +sem_Decls_Cons (T_Decl hd_) (T_Decls tl_) = + (T_Decls (\ _lhsIisDeclOfLet + _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpps :: PP_Docs + _hdOisDeclOfLet :: Bool + _hdOnested :: Bool + _hdOoptions :: Options + _hdOoutputfile :: String + _tlOisDeclOfLet :: Bool + _tlOnested :: Bool + _tlOoptions :: Options + _tlOoutputfile :: String + _hdIpp :: PP_Doc + _tlIpps :: PP_Docs + -- "PrintCode.ag"(line 71, column 10) + _lhsOpps = + _hdIpp : _tlIpps + -- copy rule (down) + _hdOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _hdOnested = + _lhsInested + -- copy rule (down) + _hdOoptions = + _lhsIoptions + -- copy rule (down) + _hdOoutputfile = + _lhsIoutputfile + -- copy rule (down) + _tlOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _tlOnested = + _lhsInested + -- copy rule (down) + _tlOoptions = + _lhsIoptions + -- copy rule (down) + _tlOoutputfile = + _lhsIoutputfile + ( _hdIpp) = + (hd_ _hdOisDeclOfLet _hdOnested _hdOoptions _hdOoutputfile) + ( _tlIpps) = + (tl_ _tlOisDeclOfLet _tlOnested _tlOoptions _tlOoutputfile) + in ( _lhsOpps)))) +sem_Decls_Nil :: T_Decls +sem_Decls_Nil = + (T_Decls (\ _lhsIisDeclOfLet + _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpps :: PP_Docs + -- "PrintCode.ag"(line 72, column 10) + _lhsOpps = + [] + in ( _lhsOpps)))) +-- Expr -------------------------------------------------------- +{- + visit 0: + inherited attributes: + nested : Bool + options : Options + outputfile : String + synthesized attribute: + pp : PP_Doc + alternatives: + alternative App: + child name : {String} + child args : Exprs + alternative Case: + child expr : Expr + child alts : CaseAlts + alternative Lambda: + child args : Exprs + child body : Expr + visit 0: + local strictParams : _ + local addBang : _ + alternative Let: + child decls : Decls + child body : Expr + alternative LineExpr: + child expr : Expr + alternative PragmaExpr: + child onLeftSide : {Bool} + child onNewLine : {Bool} + child txt : {String} + child expr : Expr + alternative SimpleExpr: + child txt : {String} + alternative TextExpr: + child lns : {[String]} + alternative Trace: + child txt : {String} + child expr : Expr + alternative TupleExpr: + child exprs : Exprs + alternative TypedExpr: + child expr : Expr + child tp : Type + alternative UnboxedTupleExpr: + child exprs : Exprs +-} +-- cata +sem_Expr :: Expr -> + T_Expr +sem_Expr (App _name _args) = + (sem_Expr_App _name (sem_Exprs _args)) +sem_Expr (Case _expr _alts) = + (sem_Expr_Case (sem_Expr _expr) (sem_CaseAlts _alts)) +sem_Expr (Lambda _args _body) = + (sem_Expr_Lambda (sem_Exprs _args) (sem_Expr _body)) +sem_Expr (Let _decls _body) = + (sem_Expr_Let (sem_Decls _decls) (sem_Expr _body)) +sem_Expr (LineExpr _expr) = + (sem_Expr_LineExpr (sem_Expr _expr)) +sem_Expr (PragmaExpr _onLeftSide _onNewLine _txt _expr) = + (sem_Expr_PragmaExpr _onLeftSide _onNewLine _txt (sem_Expr _expr)) +sem_Expr (SimpleExpr _txt) = + (sem_Expr_SimpleExpr _txt) +sem_Expr (TextExpr _lns) = + (sem_Expr_TextExpr _lns) +sem_Expr (Trace _txt _expr) = + (sem_Expr_Trace _txt (sem_Expr _expr)) +sem_Expr (TupleExpr _exprs) = + (sem_Expr_TupleExpr (sem_Exprs _exprs)) +sem_Expr (TypedExpr _expr _tp) = + (sem_Expr_TypedExpr (sem_Expr _expr) (sem_Type _tp)) +sem_Expr (UnboxedTupleExpr _exprs) = + (sem_Expr_UnboxedTupleExpr (sem_Exprs _exprs)) +-- semantic domain +newtype T_Expr = T_Expr (Bool -> + Options -> + String -> + ( PP_Doc)) +data Inh_Expr = Inh_Expr {nested_Inh_Expr :: Bool,options_Inh_Expr :: Options,outputfile_Inh_Expr :: String} +data Syn_Expr = Syn_Expr {pp_Syn_Expr :: PP_Doc} +wrap_Expr (T_Expr sem) (Inh_Expr _lhsInested _lhsIoptions _lhsIoutputfile) = + (let ( _lhsOpp) = + (sem _lhsInested _lhsIoptions _lhsIoutputfile) + in (Syn_Expr _lhsOpp)) +sem_Expr_App :: String -> + T_Exprs -> + T_Expr +sem_Expr_App name_ (T_Exprs args_) = + (T_Expr (\ _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _argsOnested :: Bool + _argsOoptions :: Options + _argsOoutputfile :: String + _argsIpps :: PP_Docs + -- "PrintCode.ag"(line 129, column 16) + _lhsOpp = + pp_parens $ name_ >#< hv_sp _argsIpps + -- copy rule (down) + _argsOnested = + _lhsInested + -- copy rule (down) + _argsOoptions = + _lhsIoptions + -- copy rule (down) + _argsOoutputfile = + _lhsIoutputfile + ( _argsIpps) = + (args_ _argsOnested _argsOoptions _argsOoutputfile) + in ( _lhsOpp)))) +sem_Expr_Case :: T_Expr -> + T_CaseAlts -> + T_Expr +sem_Expr_Case (T_Expr expr_) (T_CaseAlts alts_) = + (T_Expr (\ _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _exprOnested :: Bool + _exprOoptions :: Options + _exprOoutputfile :: String + _altsOnested :: Bool + _altsOoptions :: Options + _altsOoutputfile :: String + _exprIpp :: PP_Doc + _altsIpps :: PP_Docs + -- "PrintCode.ag"(line 115, column 16) + _lhsOpp = + pp_parens ( "case" >#< pp_parens _exprIpp >#< "of" + >-< (vlist _altsIpps) + ) + -- copy rule (down) + _exprOnested = + _lhsInested + -- copy rule (down) + _exprOoptions = + _lhsIoptions + -- copy rule (down) + _exprOoutputfile = + _lhsIoutputfile + -- copy rule (down) + _altsOnested = + _lhsInested + -- copy rule (down) + _altsOoptions = + _lhsIoptions + -- copy rule (down) + _altsOoutputfile = + _lhsIoutputfile + ( _exprIpp) = + (expr_ _exprOnested _exprOoptions _exprOoutputfile) + ( _altsIpps) = + (alts_ _altsOnested _altsOoptions _altsOoutputfile) + in ( _lhsOpp)))) +sem_Expr_Lambda :: T_Exprs -> + T_Expr -> + T_Expr +sem_Expr_Lambda (T_Exprs args_) (T_Expr body_) = + (T_Expr (\ _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _argsOnested :: Bool + _argsOoptions :: Options + _argsOoutputfile :: String + _bodyOnested :: Bool + _bodyOoptions :: Options + _bodyOoutputfile :: String + _argsIpps :: PP_Docs + _bodyIpp :: PP_Doc + -- "PrintCode.ag"(line 118, column 16) + _strictParams = + if strictSems _lhsIoptions + then _argsIpps + else [] + -- "PrintCode.ag"(line 121, column 16) + _addBang = + if bangpats _lhsIoptions + then \p -> pp_parens ("!" >|< p) + else id + -- "PrintCode.ag"(line 124, column 16) + _lhsOpp = + pp_parens ( "\\" >#< (vlist (map _addBang _argsIpps)) >#< "->" + >-< indent 4 (_strictParams `ppMultiSeqV` _bodyIpp) + ) + -- copy rule (down) + _argsOnested = + _lhsInested + -- copy rule (down) + _argsOoptions = + _lhsIoptions + -- copy rule (down) + _argsOoutputfile = + _lhsIoutputfile + -- copy rule (down) + _bodyOnested = + _lhsInested + -- copy rule (down) + _bodyOoptions = + _lhsIoptions + -- copy rule (down) + _bodyOoutputfile = + _lhsIoutputfile + ( _argsIpps) = + (args_ _argsOnested _argsOoptions _argsOoutputfile) + ( _bodyIpp) = + (body_ _bodyOnested _bodyOoptions _bodyOoutputfile) + in ( _lhsOpp)))) +sem_Expr_Let :: T_Decls -> + T_Expr -> + T_Expr +sem_Expr_Let (T_Decls decls_) (T_Expr body_) = + (T_Expr (\ _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _declsOisDeclOfLet :: Bool + _declsOnested :: Bool + _declsOoptions :: Options + _declsOoutputfile :: String + _bodyOnested :: Bool + _bodyOoptions :: Options + _bodyOoutputfile :: String + _declsIpps :: PP_Docs + _bodyIpp :: PP_Doc + -- "PrintCode.ag"(line 112, column 16) + _lhsOpp = + pp_parens ( "let" >#< (vlist _declsIpps) + >-< "in " >#< _bodyIpp + ) + -- "PrintCode.ag"(line 322, column 7) + _declsOisDeclOfLet = + True + -- copy rule (down) + _declsOnested = + _lhsInested + -- copy rule (down) + _declsOoptions = + _lhsIoptions + -- copy rule (down) + _declsOoutputfile = + _lhsIoutputfile + -- copy rule (down) + _bodyOnested = + _lhsInested + -- copy rule (down) + _bodyOoptions = + _lhsIoptions + -- copy rule (down) + _bodyOoutputfile = + _lhsIoutputfile + ( _declsIpps) = + (decls_ _declsOisDeclOfLet _declsOnested _declsOoptions _declsOoutputfile) + ( _bodyIpp) = + (body_ _bodyOnested _bodyOoptions _bodyOoutputfile) + in ( _lhsOpp)))) +sem_Expr_LineExpr :: T_Expr -> + T_Expr +sem_Expr_LineExpr (T_Expr expr_) = + (T_Expr (\ _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _exprOnested :: Bool + _exprOoptions :: Options + _exprOoutputfile :: String + _exprIpp :: PP_Doc + -- "PrintCode.ag"(line 146, column 16) + _lhsOpp = + _exprIpp >-< "{-# LINE" >#< ppWithLineNr (\n -> pp $ show $ n + 1) >#< show _lhsIoutputfile >#< "#-}" + -- copy rule (down) + _exprOnested = + _lhsInested + -- copy rule (down) + _exprOoptions = + _lhsIoptions + -- copy rule (down) + _exprOoutputfile = + _lhsIoutputfile + ( _exprIpp) = + (expr_ _exprOnested _exprOoptions _exprOoutputfile) + in ( _lhsOpp)))) +sem_Expr_PragmaExpr :: Bool -> + Bool -> + String -> + T_Expr -> + T_Expr +sem_Expr_PragmaExpr onLeftSide_ onNewLine_ txt_ (T_Expr expr_) = + (T_Expr (\ _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _exprOnested :: Bool + _exprOoptions :: Options + _exprOoutputfile :: String + _exprIpp :: PP_Doc + -- "PrintCode.ag"(line 135, column 16) + _lhsOpp = + let pragmaDoc = "{-#" >#< txt_ >#< "#-}" + op = if onNewLine_ + then (>-<) + else (>#<) + leftOp x y = if onLeftSide_ + then x `op` y + else y + rightOp x y = if onLeftSide_ + then x + else x `op` y + in pragmaDoc `leftOp` _exprIpp `rightOp` pragmaDoc + -- copy rule (down) + _exprOnested = + _lhsInested + -- copy rule (down) + _exprOoptions = + _lhsIoptions + -- copy rule (down) + _exprOoutputfile = + _lhsIoutputfile + ( _exprIpp) = + (expr_ _exprOnested _exprOoptions _exprOoutputfile) + in ( _lhsOpp)))) +sem_Expr_SimpleExpr :: String -> + T_Expr +sem_Expr_SimpleExpr txt_ = + (T_Expr (\ _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + -- "PrintCode.ag"(line 130, column 16) + _lhsOpp = + text txt_ + in ( _lhsOpp)))) +sem_Expr_TextExpr :: ([String]) -> + T_Expr +sem_Expr_TextExpr lns_ = + (T_Expr (\ _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + -- "PrintCode.ag"(line 131, column 16) + _lhsOpp = + vlist (map text lns_) + in ( _lhsOpp)))) +sem_Expr_Trace :: String -> + T_Expr -> + T_Expr +sem_Expr_Trace txt_ (T_Expr expr_) = + (T_Expr (\ _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _exprOnested :: Bool + _exprOoptions :: Options + _exprOoutputfile :: String + _exprIpp :: PP_Doc + -- "PrintCode.ag"(line 132, column 16) + _lhsOpp = + "trace" >#< ( pp_parens ("\"" >|< text txt_ >|< "\"") + >-< pp_parens _exprIpp + ) + -- copy rule (down) + _exprOnested = + _lhsInested + -- copy rule (down) + _exprOoptions = + _lhsIoptions + -- copy rule (down) + _exprOoutputfile = + _lhsIoutputfile + ( _exprIpp) = + (expr_ _exprOnested _exprOoptions _exprOoutputfile) + in ( _lhsOpp)))) +sem_Expr_TupleExpr :: T_Exprs -> + T_Expr +sem_Expr_TupleExpr (T_Exprs exprs_) = + (T_Expr (\ _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _exprsOnested :: Bool + _exprsOoptions :: Options + _exprsOoutputfile :: String + _exprsIpps :: PP_Docs + -- "PrintCode.ag"(line 127, column 16) + _lhsOpp = + ppTuple _lhsInested _exprsIpps + -- copy rule (down) + _exprsOnested = + _lhsInested + -- copy rule (down) + _exprsOoptions = + _lhsIoptions + -- copy rule (down) + _exprsOoutputfile = + _lhsIoutputfile + ( _exprsIpps) = + (exprs_ _exprsOnested _exprsOoptions _exprsOoutputfile) + in ( _lhsOpp)))) +sem_Expr_TypedExpr :: T_Expr -> + T_Type -> + T_Expr +sem_Expr_TypedExpr (T_Expr expr_) (T_Type tp_) = + (T_Expr (\ _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _exprOnested :: Bool + _exprOoptions :: Options + _exprOoutputfile :: String + _tpOnested :: Bool + _exprIpp :: PP_Doc + _tpIpp :: PP_Doc + _tpIprec :: Int + -- "PrintCode.ag"(line 147, column 16) + _lhsOpp = + pp_parens (_exprIpp >#< "::" >#< _tpIpp) + -- copy rule (down) + _exprOnested = + _lhsInested + -- copy rule (down) + _exprOoptions = + _lhsIoptions + -- copy rule (down) + _exprOoutputfile = + _lhsIoutputfile + -- copy rule (down) + _tpOnested = + _lhsInested + ( _exprIpp) = + (expr_ _exprOnested _exprOoptions _exprOoutputfile) + ( _tpIpp,_tpIprec) = + (tp_ _tpOnested) + in ( _lhsOpp)))) +sem_Expr_UnboxedTupleExpr :: T_Exprs -> + T_Expr +sem_Expr_UnboxedTupleExpr (T_Exprs exprs_) = + (T_Expr (\ _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _exprsOnested :: Bool + _exprsOoptions :: Options + _exprsOoutputfile :: String + _exprsIpps :: PP_Docs + -- "PrintCode.ag"(line 128, column 23) + _lhsOpp = + ppUnboxedTuple _lhsInested _exprsIpps + -- copy rule (down) + _exprsOnested = + _lhsInested + -- copy rule (down) + _exprsOoptions = + _lhsIoptions + -- copy rule (down) + _exprsOoutputfile = + _lhsIoutputfile + ( _exprsIpps) = + (exprs_ _exprsOnested _exprsOoptions _exprsOoutputfile) + in ( _lhsOpp)))) +-- Exprs ------------------------------------------------------- +{- + visit 0: + inherited attributes: + nested : Bool + options : Options + outputfile : String + synthesized attribute: + pps : PP_Docs + alternatives: + alternative Cons: + child hd : Expr + child tl : Exprs + alternative Nil: +-} +-- cata +sem_Exprs :: Exprs -> + T_Exprs +sem_Exprs list = + (Prelude.foldr sem_Exprs_Cons sem_Exprs_Nil (Prelude.map sem_Expr list)) +-- semantic domain +newtype T_Exprs = T_Exprs (Bool -> + Options -> + String -> + ( PP_Docs)) +data Inh_Exprs = Inh_Exprs {nested_Inh_Exprs :: Bool,options_Inh_Exprs :: Options,outputfile_Inh_Exprs :: String} +data Syn_Exprs = Syn_Exprs {pps_Syn_Exprs :: PP_Docs} +wrap_Exprs (T_Exprs sem) (Inh_Exprs _lhsInested _lhsIoptions _lhsIoutputfile) = + (let ( _lhsOpps) = + (sem _lhsInested _lhsIoptions _lhsIoutputfile) + in (Syn_Exprs _lhsOpps)) +sem_Exprs_Cons :: T_Expr -> + T_Exprs -> + T_Exprs +sem_Exprs_Cons (T_Expr hd_) (T_Exprs tl_) = + (T_Exprs (\ _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpps :: PP_Docs + _hdOnested :: Bool + _hdOoptions :: Options + _hdOoutputfile :: String + _tlOnested :: Bool + _tlOoptions :: Options + _tlOoutputfile :: String + _hdIpp :: PP_Doc + _tlIpps :: PP_Docs + -- "PrintCode.ag"(line 55, column 10) + _lhsOpps = + _hdIpp : _tlIpps + -- copy rule (down) + _hdOnested = + _lhsInested + -- copy rule (down) + _hdOoptions = + _lhsIoptions + -- copy rule (down) + _hdOoutputfile = + _lhsIoutputfile + -- copy rule (down) + _tlOnested = + _lhsInested + -- copy rule (down) + _tlOoptions = + _lhsIoptions + -- copy rule (down) + _tlOoutputfile = + _lhsIoutputfile + ( _hdIpp) = + (hd_ _hdOnested _hdOoptions _hdOoutputfile) + ( _tlIpps) = + (tl_ _tlOnested _tlOoptions _tlOoutputfile) + in ( _lhsOpps)))) +sem_Exprs_Nil :: T_Exprs +sem_Exprs_Nil = + (T_Exprs (\ _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpps :: PP_Docs + -- "PrintCode.ag"(line 56, column 10) + _lhsOpps = + [] + in ( _lhsOpps)))) +-- Lhs --------------------------------------------------------- +{- + visit 0: + inherited attributes: + isDeclOfLet : Bool + nested : Bool + options : Options + outputfile : String + synthesized attribute: + pp : PP_Doc + alternatives: + alternative Fun: + child name : {String} + child args : Exprs + visit 0: + local addStrictGuard : _ + local hasStrictVars : _ + local strictGuard : _ + local addBang : _ + alternative Pattern3: + child pat3 : Pattern + visit 0: + local addStrictGuard : _ + local strictGuard : _ + local hasStrictVars : _ + alternative Pattern3SM: + child pat3 : Pattern + alternative TupleLhs: + child comps : {[String]} + visit 0: + local addStrictGuard : _ + local strictGuard : _ + local hasStrictVars : _ + local addBang : _ + alternative UnboxedTupleLhs: + child comps : {[String]} + visit 0: + local addStrictGuard : _ + local strictGuard : _ + local hasStrictVars : _ + local addBang : _ +-} +-- cata +sem_Lhs :: Lhs -> + T_Lhs +sem_Lhs (Fun _name _args) = + (sem_Lhs_Fun _name (sem_Exprs _args)) +sem_Lhs (Pattern3 _pat3) = + (sem_Lhs_Pattern3 (sem_Pattern _pat3)) +sem_Lhs (Pattern3SM _pat3) = + (sem_Lhs_Pattern3SM (sem_Pattern _pat3)) +sem_Lhs (TupleLhs _comps) = + (sem_Lhs_TupleLhs _comps) +sem_Lhs (UnboxedTupleLhs _comps) = + (sem_Lhs_UnboxedTupleLhs _comps) +-- semantic domain +newtype T_Lhs = T_Lhs (Bool -> + Bool -> + Options -> + String -> + ( PP_Doc)) +data Inh_Lhs = Inh_Lhs {isDeclOfLet_Inh_Lhs :: Bool,nested_Inh_Lhs :: Bool,options_Inh_Lhs :: Options,outputfile_Inh_Lhs :: String} +data Syn_Lhs = Syn_Lhs {pp_Syn_Lhs :: PP_Doc} +wrap_Lhs (T_Lhs sem) (Inh_Lhs _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile) = + (let ( _lhsOpp) = + (sem _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile) + in (Syn_Lhs _lhsOpp)) +sem_Lhs_Fun :: String -> + T_Exprs -> + T_Lhs +sem_Lhs_Fun name_ (T_Exprs args_) = + (T_Lhs (\ _lhsIisDeclOfLet + _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _argsOnested :: Bool + _argsOoptions :: Options + _argsOoutputfile :: String + _argsIpps :: PP_Docs + -- "PrintCode.ag"(line 169, column 7) + _addStrictGuard = + if strictSems _lhsIoptions && _hasStrictVars then \v -> v >#< "|" >#< _strictGuard else id + -- "PrintCode.ag"(line 170, column 7) + _hasStrictVars = + not (null _argsIpps) + -- "PrintCode.ag"(line 171, column 7) + _strictGuard = + _argsIpps `ppMultiSeqH` (pp "True") + -- "PrintCode.ag"(line 174, column 7) + _addBang = + if bangpats _lhsIoptions + then \p -> "!" >|< p + else id + -- "PrintCode.ag"(line 182, column 16) + _lhsOpp = + _addStrictGuard (name_ >#< hv_sp (map _addBang _argsIpps)) + -- copy rule (down) + _argsOnested = + _lhsInested + -- copy rule (down) + _argsOoptions = + _lhsIoptions + -- copy rule (down) + _argsOoutputfile = + _lhsIoutputfile + ( _argsIpps) = + (args_ _argsOnested _argsOoptions _argsOoutputfile) + in ( _lhsOpp)))) +sem_Lhs_Pattern3 :: T_Pattern -> + T_Lhs +sem_Lhs_Pattern3 (T_Pattern pat3_) = + (T_Lhs (\ _lhsIisDeclOfLet + _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _pat3ObelowIrrefutable :: Bool + _pat3OisDeclOfLet :: Bool + _pat3Ooptions :: Options + _pat3Icopy :: Pattern + _pat3IisUnderscore :: Bool + _pat3Ipp :: PP_Doc + _pat3Ipp' :: PP_Doc + _pat3IstrictVars :: ([PP_Doc]) + -- "PrintCode.ag"(line 158, column 7) + _addStrictGuard = + if strictCases _lhsIoptions && _hasStrictVars then \v -> v >#< "|" >#< _strictGuard else id + -- "PrintCode.ag"(line 160, column 7) + _strictGuard = + _pat3IstrictVars `ppMultiSeqH` (pp "True") + -- "PrintCode.ag"(line 161, column 7) + _hasStrictVars = + not (null _pat3IstrictVars) + -- "PrintCode.ag"(line 178, column 16) + _lhsOpp = + _addStrictGuard _pat3Ipp + -- "PrintCode.ag"(line 288, column 7) + _pat3ObelowIrrefutable = + False + -- copy rule (down) + _pat3OisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _pat3Ooptions = + _lhsIoptions + ( _pat3Icopy,_pat3IisUnderscore,_pat3Ipp,_pat3Ipp',_pat3IstrictVars) = + (pat3_ _pat3ObelowIrrefutable _pat3OisDeclOfLet _pat3Ooptions) + in ( _lhsOpp)))) +sem_Lhs_Pattern3SM :: T_Pattern -> + T_Lhs +sem_Lhs_Pattern3SM (T_Pattern pat3_) = + (T_Lhs (\ _lhsIisDeclOfLet + _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + _pat3ObelowIrrefutable :: Bool + _pat3OisDeclOfLet :: Bool + _pat3Ooptions :: Options + _pat3Icopy :: Pattern + _pat3IisUnderscore :: Bool + _pat3Ipp :: PP_Doc + _pat3Ipp' :: PP_Doc + _pat3IstrictVars :: ([PP_Doc]) + -- "PrintCode.ag"(line 179, column 16) + _lhsOpp = + _pat3Ipp' + -- "PrintCode.ag"(line 288, column 7) + _pat3ObelowIrrefutable = + False + -- copy rule (down) + _pat3OisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _pat3Ooptions = + _lhsIoptions + ( _pat3Icopy,_pat3IisUnderscore,_pat3Ipp,_pat3Ipp',_pat3IstrictVars) = + (pat3_ _pat3ObelowIrrefutable _pat3OisDeclOfLet _pat3Ooptions) + in ( _lhsOpp)))) +sem_Lhs_TupleLhs :: ([String]) -> + T_Lhs +sem_Lhs_TupleLhs comps_ = + (T_Lhs (\ _lhsIisDeclOfLet + _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + -- "PrintCode.ag"(line 158, column 7) + _addStrictGuard = + if strictCases _lhsIoptions && _hasStrictVars then \v -> v >#< "|" >#< _strictGuard else id + -- "PrintCode.ag"(line 163, column 7) + _strictGuard = + if stricterCases _lhsIoptions && not _lhsIisDeclOfLet + then map text comps_ `ppMultiSeqH` (pp "True") + else pp "True" + -- "PrintCode.ag"(line 166, column 7) + _hasStrictVars = + not (null comps_) + -- "PrintCode.ag"(line 174, column 7) + _addBang = + if bangpats _lhsIoptions + then \p -> "!" >|< p + else id + -- "PrintCode.ag"(line 180, column 16) + _lhsOpp = + _addStrictGuard $ ppTuple _lhsInested (map (_addBang . text) comps_) + in ( _lhsOpp)))) +sem_Lhs_UnboxedTupleLhs :: ([String]) -> + T_Lhs +sem_Lhs_UnboxedTupleLhs comps_ = + (T_Lhs (\ _lhsIisDeclOfLet + _lhsInested + _lhsIoptions + _lhsIoutputfile -> + (let _lhsOpp :: PP_Doc + -- "PrintCode.ag"(line 158, column 7) + _addStrictGuard = + if strictCases _lhsIoptions && _hasStrictVars then \v -> v >#< "|" >#< _strictGuard else id + -- "PrintCode.ag"(line 163, column 7) + _strictGuard = + if stricterCases _lhsIoptions && not _lhsIisDeclOfLet + then map text comps_ `ppMultiSeqH` (pp "True") + else pp "True" + -- "PrintCode.ag"(line 166, column 7) + _hasStrictVars = + not (null comps_) + -- "PrintCode.ag"(line 174, column 7) + _addBang = + if bangpats _lhsIoptions + then \p -> "!" >|< p + else id + -- "PrintCode.ag"(line 181, column 23) + _lhsOpp = + _addStrictGuard $ ppUnboxedTuple _lhsInested (map (_addBang . text) comps_) + in ( _lhsOpp)))) +-- Pattern ----------------------------------------------------- +{- + visit 0: + inherited attributes: + belowIrrefutable : Bool + isDeclOfLet : Bool + options : Options + synthesized attributes: + copy : SELF + isUnderscore : Bool + pp : PP_Doc + pp' : PP_Doc + strictVars : [PP_Doc] + alternatives: + alternative Alias: + child field : {Identifier} + child attr : {Identifier} + child pat : Pattern + child parts : Patterns + visit 0: + local strictVar : _ + local strictPatVars : _ + local addBang : _ + local ppVar : _ + local ppVarBang : _ + local copy : _ + alternative Constr: + child name : {ConstructorIdent} + child pats : Patterns + visit 0: + local addBang : _ + local copy : _ + alternative Irrefutable: + child pat : Pattern + visit 0: + local copy : _ + alternative Product: + child pos : {Pos} + child pats : Patterns + visit 0: + local addBang : _ + local copy : _ + alternative Underscore: + child pos : {Pos} + visit 0: + local copy : _ +-} +-- cata +sem_Pattern :: Pattern -> + T_Pattern +sem_Pattern (Alias _field _attr _pat _parts) = + (sem_Pattern_Alias _field _attr (sem_Pattern _pat) (sem_Patterns _parts)) +sem_Pattern (Constr _name _pats) = + (sem_Pattern_Constr _name (sem_Patterns _pats)) +sem_Pattern (Irrefutable _pat) = + (sem_Pattern_Irrefutable (sem_Pattern _pat)) +sem_Pattern (Product _pos _pats) = + (sem_Pattern_Product _pos (sem_Patterns _pats)) +sem_Pattern (Underscore _pos) = + (sem_Pattern_Underscore _pos) +-- semantic domain +newtype T_Pattern = T_Pattern (Bool -> + Bool -> + Options -> + ( Pattern,Bool,PP_Doc,PP_Doc,([PP_Doc]))) +data Inh_Pattern = Inh_Pattern {belowIrrefutable_Inh_Pattern :: Bool,isDeclOfLet_Inh_Pattern :: Bool,options_Inh_Pattern :: Options} +data Syn_Pattern = Syn_Pattern {copy_Syn_Pattern :: Pattern,isUnderscore_Syn_Pattern :: Bool,pp_Syn_Pattern :: PP_Doc,pp'_Syn_Pattern :: PP_Doc,strictVars_Syn_Pattern :: [PP_Doc]} +wrap_Pattern (T_Pattern sem) (Inh_Pattern _lhsIbelowIrrefutable _lhsIisDeclOfLet _lhsIoptions) = + (let ( _lhsOcopy,_lhsOisUnderscore,_lhsOpp,_lhsOpp',_lhsOstrictVars) = + (sem _lhsIbelowIrrefutable _lhsIisDeclOfLet _lhsIoptions) + in (Syn_Pattern _lhsOcopy _lhsOisUnderscore _lhsOpp _lhsOpp' _lhsOstrictVars)) +sem_Pattern_Alias :: Identifier -> + Identifier -> + T_Pattern -> + T_Patterns -> + T_Pattern +sem_Pattern_Alias field_ attr_ (T_Pattern pat_) (T_Patterns parts_) = + (T_Pattern (\ _lhsIbelowIrrefutable + _lhsIisDeclOfLet + _lhsIoptions -> + (let _lhsOstrictVars :: ([PP_Doc]) + _lhsOpp :: PP_Doc + _lhsOisUnderscore :: Bool + _lhsOpp' :: PP_Doc + _lhsOcopy :: Pattern + _patObelowIrrefutable :: Bool + _patOisDeclOfLet :: Bool + _patOoptions :: Options + _partsObelowIrrefutable :: Bool + _partsOisDeclOfLet :: Bool + _partsOoptions :: Options + _patIcopy :: Pattern + _patIisUnderscore :: Bool + _patIpp :: PP_Doc + _patIpp' :: PP_Doc + _patIstrictVars :: ([PP_Doc]) + _partsIcopy :: Patterns + _partsIpps :: ([PP_Doc]) + _partsIpps' :: ([PP_Doc]) + _partsIstrictVars :: ([PP_Doc]) + -- "PrintCode.ag"(line 237, column 7) + _strictVar = + if strictCases _lhsIoptions && not _lhsIisDeclOfLet + then [_ppVar ] + else [] + -- "PrintCode.ag"(line 241, column 7) + _strictPatVars = + if stricterCases _lhsIoptions && not _lhsIisDeclOfLet + then _patIstrictVars + else [] + -- "PrintCode.ag"(line 245, column 7) + _lhsOstrictVars = + _strictVar ++ _strictPatVars + -- "PrintCode.ag"(line 260, column 7) + _addBang = + if bangpats _lhsIoptions && not _lhsIisDeclOfLet && not _lhsIbelowIrrefutable + then \p -> "!" >|< p + else id + -- "PrintCode.ag"(line 267, column 13) + _ppVar = + pp (attrname False field_ attr_) + -- "PrintCode.ag"(line 268, column 13) + _ppVarBang = + _addBang $ _ppVar + -- "PrintCode.ag"(line 269, column 13) + _lhsOpp = + if _patIisUnderscore + then _ppVarBang + else _ppVarBang >|< "@" >|< _patIpp + -- "PrintCode.ag"(line 278, column 16) + _lhsOisUnderscore = + False + -- "PrintCode.ag"(line 301, column 13) + _lhsOpp' = + let attribute | field_ == _LOC || field_ == nullIdent = locname' attr_ + | otherwise = attrname False field_ attr_ + in attribute >|< "@" >|< _patIpp' + -- self rule + _copy = + Alias field_ attr_ _patIcopy _partsIcopy + -- self rule + _lhsOcopy = + _copy + -- copy rule (down) + _patObelowIrrefutable = + _lhsIbelowIrrefutable + -- copy rule (down) + _patOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _patOoptions = + _lhsIoptions + -- copy rule (down) + _partsObelowIrrefutable = + _lhsIbelowIrrefutable + -- copy rule (down) + _partsOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _partsOoptions = + _lhsIoptions + ( _patIcopy,_patIisUnderscore,_patIpp,_patIpp',_patIstrictVars) = + (pat_ _patObelowIrrefutable _patOisDeclOfLet _patOoptions) + ( _partsIcopy,_partsIpps,_partsIpps',_partsIstrictVars) = + (parts_ _partsObelowIrrefutable _partsOisDeclOfLet _partsOoptions) + in ( _lhsOcopy,_lhsOisUnderscore,_lhsOpp,_lhsOpp',_lhsOstrictVars)))) +sem_Pattern_Constr :: ConstructorIdent -> + T_Patterns -> + T_Pattern +sem_Pattern_Constr name_ (T_Patterns pats_) = + (T_Pattern (\ _lhsIbelowIrrefutable + _lhsIisDeclOfLet + _lhsIoptions -> + (let _lhsOpp :: PP_Doc + _lhsOisUnderscore :: Bool + _lhsOpp' :: PP_Doc + _lhsOstrictVars :: ([PP_Doc]) + _lhsOcopy :: Pattern + _patsObelowIrrefutable :: Bool + _patsOisDeclOfLet :: Bool + _patsOoptions :: Options + _patsIcopy :: Patterns + _patsIpps :: ([PP_Doc]) + _patsIpps' :: ([PP_Doc]) + _patsIstrictVars :: ([PP_Doc]) + -- "PrintCode.ag"(line 260, column 7) + _addBang = + if bangpats _lhsIoptions && not _lhsIisDeclOfLet && not _lhsIbelowIrrefutable + then \p -> "!" >|< p + else id + -- "PrintCode.ag"(line 265, column 13) + _lhsOpp = + _addBang $ pp_parens $ name_ >#< hv_sp _patsIpps + -- "PrintCode.ag"(line 276, column 16) + _lhsOisUnderscore = + False + -- "PrintCode.ag"(line 299, column 13) + _lhsOpp' = + pp_parens $ name_ >#< hv_sp (map pp_parens _patsIpps') + -- use rule "PrintCode.ag"(line 234, column 40) + _lhsOstrictVars = + _patsIstrictVars + -- self rule + _copy = + Constr name_ _patsIcopy + -- self rule + _lhsOcopy = + _copy + -- copy rule (down) + _patsObelowIrrefutable = + _lhsIbelowIrrefutable + -- copy rule (down) + _patsOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _patsOoptions = + _lhsIoptions + ( _patsIcopy,_patsIpps,_patsIpps',_patsIstrictVars) = + (pats_ _patsObelowIrrefutable _patsOisDeclOfLet _patsOoptions) + in ( _lhsOcopy,_lhsOisUnderscore,_lhsOpp,_lhsOpp',_lhsOstrictVars)))) +sem_Pattern_Irrefutable :: T_Pattern -> + T_Pattern +sem_Pattern_Irrefutable (T_Pattern pat_) = + (T_Pattern (\ _lhsIbelowIrrefutable + _lhsIisDeclOfLet + _lhsIoptions -> + (let _lhsOstrictVars :: ([PP_Doc]) + _lhsOpp :: PP_Doc + _patObelowIrrefutable :: Bool + _lhsOpp' :: PP_Doc + _lhsOcopy :: Pattern + _lhsOisUnderscore :: Bool + _patOisDeclOfLet :: Bool + _patOoptions :: Options + _patIcopy :: Pattern + _patIisUnderscore :: Bool + _patIpp :: PP_Doc + _patIpp' :: PP_Doc + _patIstrictVars :: ([PP_Doc]) + -- "PrintCode.ag"(line 248, column 7) + _lhsOstrictVars = + [] + -- "PrintCode.ag"(line 272, column 17) + _lhsOpp = + text "~" >|< pp_parens _patIpp + -- "PrintCode.ag"(line 284, column 7) + _patObelowIrrefutable = + True + -- "PrintCode.ag"(line 304, column 17) + _lhsOpp' = + text "~" >|< pp_parens _patIpp + -- self rule + _copy = + Irrefutable _patIcopy + -- self rule + _lhsOcopy = + _copy + -- copy rule (up) + _lhsOisUnderscore = + _patIisUnderscore + -- copy rule (down) + _patOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _patOoptions = + _lhsIoptions + ( _patIcopy,_patIisUnderscore,_patIpp,_patIpp',_patIstrictVars) = + (pat_ _patObelowIrrefutable _patOisDeclOfLet _patOoptions) + in ( _lhsOcopy,_lhsOisUnderscore,_lhsOpp,_lhsOpp',_lhsOstrictVars)))) +sem_Pattern_Product :: Pos -> + T_Patterns -> + T_Pattern +sem_Pattern_Product pos_ (T_Patterns pats_) = + (T_Pattern (\ _lhsIbelowIrrefutable + _lhsIisDeclOfLet + _lhsIoptions -> + (let _lhsOpp :: PP_Doc + _lhsOisUnderscore :: Bool + _lhsOpp' :: PP_Doc + _lhsOstrictVars :: ([PP_Doc]) + _lhsOcopy :: Pattern + _patsObelowIrrefutable :: Bool + _patsOisDeclOfLet :: Bool + _patsOoptions :: Options + _patsIcopy :: Patterns + _patsIpps :: ([PP_Doc]) + _patsIpps' :: ([PP_Doc]) + _patsIstrictVars :: ([PP_Doc]) + -- "PrintCode.ag"(line 260, column 7) + _addBang = + if bangpats _lhsIoptions && not _lhsIisDeclOfLet && not _lhsIbelowIrrefutable + then \p -> "!" >|< p + else id + -- "PrintCode.ag"(line 266, column 13) + _lhsOpp = + _addBang $ pp_block "(" ")" "," _patsIpps + -- "PrintCode.ag"(line 277, column 16) + _lhsOisUnderscore = + False + -- "PrintCode.ag"(line 300, column 13) + _lhsOpp' = + pp_block "(" ")" "," _patsIpps' + -- use rule "PrintCode.ag"(line 234, column 40) + _lhsOstrictVars = + _patsIstrictVars + -- self rule + _copy = + Product pos_ _patsIcopy + -- self rule + _lhsOcopy = + _copy + -- copy rule (down) + _patsObelowIrrefutable = + _lhsIbelowIrrefutable + -- copy rule (down) + _patsOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _patsOoptions = + _lhsIoptions + ( _patsIcopy,_patsIpps,_patsIpps',_patsIstrictVars) = + (pats_ _patsObelowIrrefutable _patsOisDeclOfLet _patsOoptions) + in ( _lhsOcopy,_lhsOisUnderscore,_lhsOpp,_lhsOpp',_lhsOstrictVars)))) +sem_Pattern_Underscore :: Pos -> + T_Pattern +sem_Pattern_Underscore pos_ = + (T_Pattern (\ _lhsIbelowIrrefutable + _lhsIisDeclOfLet + _lhsIoptions -> + (let _lhsOpp :: PP_Doc + _lhsOisUnderscore :: Bool + _lhsOpp' :: PP_Doc + _lhsOstrictVars :: ([PP_Doc]) + _lhsOcopy :: Pattern + -- "PrintCode.ag"(line 273, column 16) + _lhsOpp = + text "_" + -- "PrintCode.ag"(line 279, column 16) + _lhsOisUnderscore = + True + -- "PrintCode.ag"(line 305, column 16) + _lhsOpp' = + text "_" + -- use rule "PrintCode.ag"(line 234, column 40) + _lhsOstrictVars = + [] + -- self rule + _copy = + Underscore pos_ + -- self rule + _lhsOcopy = + _copy + in ( _lhsOcopy,_lhsOisUnderscore,_lhsOpp,_lhsOpp',_lhsOstrictVars)))) +-- Patterns ---------------------------------------------------- +{- + visit 0: + inherited attributes: + belowIrrefutable : Bool + isDeclOfLet : Bool + options : Options + synthesized attributes: + copy : SELF + pps : [PP_Doc] + pps' : [PP_Doc] + strictVars : [PP_Doc] + alternatives: + alternative Cons: + child hd : Pattern + child tl : Patterns + visit 0: + local copy : _ + alternative Nil: + visit 0: + local copy : _ +-} +-- cata +sem_Patterns :: Patterns -> + T_Patterns +sem_Patterns list = + (Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list)) +-- semantic domain +newtype T_Patterns = T_Patterns (Bool -> + Bool -> + Options -> + ( Patterns,([PP_Doc]),([PP_Doc]),([PP_Doc]))) +data Inh_Patterns = Inh_Patterns {belowIrrefutable_Inh_Patterns :: Bool,isDeclOfLet_Inh_Patterns :: Bool,options_Inh_Patterns :: Options} +data Syn_Patterns = Syn_Patterns {copy_Syn_Patterns :: Patterns,pps_Syn_Patterns :: [PP_Doc],pps'_Syn_Patterns :: [PP_Doc],strictVars_Syn_Patterns :: [PP_Doc]} +wrap_Patterns (T_Patterns sem) (Inh_Patterns _lhsIbelowIrrefutable _lhsIisDeclOfLet _lhsIoptions) = + (let ( _lhsOcopy,_lhsOpps,_lhsOpps',_lhsOstrictVars) = + (sem _lhsIbelowIrrefutable _lhsIisDeclOfLet _lhsIoptions) + in (Syn_Patterns _lhsOcopy _lhsOpps _lhsOpps' _lhsOstrictVars)) +sem_Patterns_Cons :: T_Pattern -> + T_Patterns -> + T_Patterns +sem_Patterns_Cons (T_Pattern hd_) (T_Patterns tl_) = + (T_Patterns (\ _lhsIbelowIrrefutable + _lhsIisDeclOfLet + _lhsIoptions -> + (let _lhsOpps :: ([PP_Doc]) + _lhsOpps' :: ([PP_Doc]) + _lhsOstrictVars :: ([PP_Doc]) + _lhsOcopy :: Patterns + _hdObelowIrrefutable :: Bool + _hdOisDeclOfLet :: Bool + _hdOoptions :: Options + _tlObelowIrrefutable :: Bool + _tlOisDeclOfLet :: Bool + _tlOoptions :: Options + _hdIcopy :: Pattern + _hdIisUnderscore :: Bool + _hdIpp :: PP_Doc + _hdIpp' :: PP_Doc + _hdIstrictVars :: ([PP_Doc]) + _tlIcopy :: Patterns + _tlIpps :: ([PP_Doc]) + _tlIpps' :: ([PP_Doc]) + _tlIstrictVars :: ([PP_Doc]) + -- "PrintCode.ag"(line 255, column 10) + _lhsOpps = + _hdIpp : _tlIpps + -- "PrintCode.ag"(line 295, column 10) + _lhsOpps' = + _hdIpp' : _tlIpps' + -- use rule "PrintCode.ag"(line 234, column 40) + _lhsOstrictVars = + _hdIstrictVars ++ _tlIstrictVars + -- self rule + _copy = + (:) _hdIcopy _tlIcopy + -- self rule + _lhsOcopy = + _copy + -- copy rule (down) + _hdObelowIrrefutable = + _lhsIbelowIrrefutable + -- copy rule (down) + _hdOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _hdOoptions = + _lhsIoptions + -- copy rule (down) + _tlObelowIrrefutable = + _lhsIbelowIrrefutable + -- copy rule (down) + _tlOisDeclOfLet = + _lhsIisDeclOfLet + -- copy rule (down) + _tlOoptions = + _lhsIoptions + ( _hdIcopy,_hdIisUnderscore,_hdIpp,_hdIpp',_hdIstrictVars) = + (hd_ _hdObelowIrrefutable _hdOisDeclOfLet _hdOoptions) + ( _tlIcopy,_tlIpps,_tlIpps',_tlIstrictVars) = + (tl_ _tlObelowIrrefutable _tlOisDeclOfLet _tlOoptions) + in ( _lhsOcopy,_lhsOpps,_lhsOpps',_lhsOstrictVars)))) +sem_Patterns_Nil :: T_Patterns +sem_Patterns_Nil = + (T_Patterns (\ _lhsIbelowIrrefutable + _lhsIisDeclOfLet + _lhsIoptions -> + (let _lhsOpps :: ([PP_Doc]) + _lhsOpps' :: ([PP_Doc]) + _lhsOstrictVars :: ([PP_Doc]) + _lhsOcopy :: Patterns + -- "PrintCode.ag"(line 256, column 10) + _lhsOpps = + [] + -- "PrintCode.ag"(line 296, column 10) + _lhsOpps' = + [] + -- use rule "PrintCode.ag"(line 234, column 40) + _lhsOstrictVars = + [] + -- self rule + _copy = + [] + -- self rule + _lhsOcopy = + _copy + in ( _lhsOcopy,_lhsOpps,_lhsOpps',_lhsOstrictVars)))) +-- Program ----------------------------------------------------- +{- + visit 0: + inherited attributes: + importBlocks : PP_Doc + mainFile : String + mainName : String + moduleHeader : String -> String -> String -> Bool -> String + options : Options + optionsLine : String + pragmaBlocks : String + textBlocks : PP_Doc + synthesized attributes: + genIO : IO () + output : PP_Docs + alternatives: + alternative Program: + child chunks : Chunks + visit 0: + local mainModuleFile : _ + local genMainModule : _ + local commonFile : _ + local genCommonModule : _ +-} +-- cata +sem_Program :: Program -> + T_Program +sem_Program (Program _chunks) = + (sem_Program_Program (sem_Chunks _chunks)) +-- semantic domain +newtype T_Program = T_Program (PP_Doc -> + String -> + String -> + (String -> String -> String -> Bool -> String) -> + Options -> + String -> + String -> + PP_Doc -> + ( (IO ()),PP_Docs)) +data Inh_Program = Inh_Program {importBlocks_Inh_Program :: PP_Doc,mainFile_Inh_Program :: String,mainName_Inh_Program :: String,moduleHeader_Inh_Program :: String -> String -> String -> Bool -> String,options_Inh_Program :: Options,optionsLine_Inh_Program :: String,pragmaBlocks_Inh_Program :: String,textBlocks_Inh_Program :: PP_Doc} +data Syn_Program = Syn_Program {genIO_Syn_Program :: IO (),output_Syn_Program :: PP_Docs} +wrap_Program (T_Program sem) (Inh_Program _lhsIimportBlocks _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsIoptions _lhsIoptionsLine _lhsIpragmaBlocks _lhsItextBlocks) = + (let ( _lhsOgenIO,_lhsOoutput) = + (sem _lhsIimportBlocks _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsIoptions _lhsIoptionsLine _lhsIpragmaBlocks _lhsItextBlocks) + in (Syn_Program _lhsOgenIO _lhsOoutput)) +sem_Program_Program :: T_Chunks -> + T_Program +sem_Program_Program (T_Chunks chunks_) = + (T_Program (\ _lhsIimportBlocks + _lhsImainFile + _lhsImainName + _lhsImoduleHeader + _lhsIoptions + _lhsIoptionsLine + _lhsIpragmaBlocks + _lhsItextBlocks -> + (let _chunksOnested :: Bool + _lhsOoutput :: PP_Docs + _chunksOisDeclOfLet :: Bool + _lhsOgenIO :: (IO ()) + _chunksOimportBlocks :: PP_Doc + _chunksOmainFile :: String + _chunksOmainName :: String + _chunksOmoduleHeader :: (String -> String -> String -> Bool -> String) + _chunksOoptions :: Options + _chunksOoptionsLine :: String + _chunksOpragmaBlocks :: String + _chunksOtextBlocks :: PP_Doc + _chunksIappendCommon :: ([[PP_Doc]]) + _chunksIappendMain :: ([[PP_Doc]]) + _chunksIgenSems :: (IO ()) + _chunksIimports :: ([String]) + _chunksIpps :: PP_Docs + -- "PrintCode.ag"(line 52, column 13) + _chunksOnested = + nest _lhsIoptions + -- "PrintCode.ag"(line 80, column 16) + _lhsOoutput = + _chunksIpps + -- "PrintCode.ag"(line 318, column 7) + _chunksOisDeclOfLet = + False + -- "PrintCode.ag"(line 347, column 7) + _mainModuleFile = + _lhsImainFile ++ ".hs" + -- "PrintCode.ag"(line 348, column 7) + _genMainModule = + writeModule _mainModuleFile + ( [ pp $ _lhsIpragmaBlocks + , pp $ _lhsIoptionsLine + , pp $ _lhsImoduleHeader _lhsImainName "" "" False + , pp $ ("import " ++ _lhsImainName ++ "_common\n") + ] + ++ map pp _chunksIimports + ++ map vlist _chunksIappendMain + ) + -- "PrintCode.ag"(line 359, column 7) + _commonFile = + _lhsImainFile ++ "_common.hs" + -- "PrintCode.ag"(line 360, column 7) + _genCommonModule = + writeModule _commonFile + ( [ pp $ _lhsIpragmaBlocks + , pp $ _lhsIoptionsLine + , pp $ _lhsImoduleHeader _lhsImainName "_common" "" True + , _lhsIimportBlocks + , _lhsItextBlocks + ] + ++ map vlist _chunksIappendCommon + ) + -- "PrintCode.ag"(line 371, column 7) + _lhsOgenIO = + do _genMainModule + _genCommonModule + _chunksIgenSems + -- copy rule (down) + _chunksOimportBlocks = + _lhsIimportBlocks + -- copy rule (down) + _chunksOmainFile = + _lhsImainFile + -- copy rule (down) + _chunksOmainName = + _lhsImainName + -- copy rule (down) + _chunksOmoduleHeader = + _lhsImoduleHeader + -- copy rule (down) + _chunksOoptions = + _lhsIoptions + -- copy rule (down) + _chunksOoptionsLine = + _lhsIoptionsLine + -- copy rule (down) + _chunksOpragmaBlocks = + _lhsIpragmaBlocks + -- copy rule (down) + _chunksOtextBlocks = + _lhsItextBlocks + ( _chunksIappendCommon,_chunksIappendMain,_chunksIgenSems,_chunksIimports,_chunksIpps) = + (chunks_ _chunksOimportBlocks _chunksOisDeclOfLet _chunksOmainFile _chunksOmainName _chunksOmoduleHeader _chunksOnested _chunksOoptions _chunksOoptionsLine _chunksOpragmaBlocks _chunksOtextBlocks) + in ( _lhsOgenIO,_lhsOoutput)))) +-- Type -------------------------------------------------------- +{- + visit 0: + inherited attribute: + nested : Bool + synthesized attributes: + pp : PP_Doc + prec : Int + alternatives: + alternative Arr: + child left : Type + child right : Type + visit 0: + local l : _ + local r : _ + alternative CtxApp: + child left : {[(String, [String])]} + child right : Type + alternative List: + child tp : Type + alternative SimpleType: + child txt : {String} + alternative TupleType: + child tps : Types + alternative TypeApp: + child func : Type + child args : Types + alternative UnboxedTupleType: + child tps : Types +-} +-- cata +sem_Type :: Type -> + T_Type +sem_Type (Arr _left _right) = + (sem_Type_Arr (sem_Type _left) (sem_Type _right)) +sem_Type (CtxApp _left _right) = + (sem_Type_CtxApp _left (sem_Type _right)) +sem_Type (List _tp) = + (sem_Type_List (sem_Type _tp)) +sem_Type (SimpleType _txt) = + (sem_Type_SimpleType _txt) +sem_Type (TupleType _tps) = + (sem_Type_TupleType (sem_Types _tps)) +sem_Type (TypeApp _func _args) = + (sem_Type_TypeApp (sem_Type _func) (sem_Types _args)) +sem_Type (UnboxedTupleType _tps) = + (sem_Type_UnboxedTupleType (sem_Types _tps)) +-- semantic domain +newtype T_Type = T_Type (Bool -> + ( PP_Doc,Int)) +data Inh_Type = Inh_Type {nested_Inh_Type :: Bool} +data Syn_Type = Syn_Type {pp_Syn_Type :: PP_Doc,prec_Syn_Type :: Int} +wrap_Type (T_Type sem) (Inh_Type _lhsInested) = + (let ( _lhsOpp,_lhsOprec) = + (sem _lhsInested) + in (Syn_Type _lhsOpp _lhsOprec)) +sem_Type_Arr :: T_Type -> + T_Type -> + T_Type +sem_Type_Arr (T_Type left_) (T_Type right_) = + (T_Type (\ _lhsInested -> + (let _lhsOprec :: Int + _lhsOpp :: PP_Doc + _leftOnested :: Bool + _rightOnested :: Bool + _leftIpp :: PP_Doc + _leftIprec :: Int + _rightIpp :: PP_Doc + _rightIprec :: Int + -- "PrintCode.ag"(line 185, column 16) + _lhsOprec = + 2 + -- "PrintCode.ag"(line 185, column 16) + _lhsOpp = + _l >#< "->" >-< _r + -- "PrintCode.ag"(line 187, column 16) + _l = + if _leftIprec <= 2 then pp_parens _leftIpp else _leftIpp + -- "PrintCode.ag"(line 187, column 16) + _r = + if _rightIprec < 2 then pp_parens _rightIpp else _rightIpp + -- copy rule (down) + _leftOnested = + _lhsInested + -- copy rule (down) + _rightOnested = + _lhsInested + ( _leftIpp,_leftIprec) = + (left_ _leftOnested) + ( _rightIpp,_rightIprec) = + (right_ _rightOnested) + in ( _lhsOpp,_lhsOprec)))) +sem_Type_CtxApp :: ([(String, [String])]) -> + T_Type -> + T_Type +sem_Type_CtxApp left_ (T_Type right_) = + (T_Type (\ _lhsInested -> + (let _lhsOpp :: PP_Doc + _lhsOprec :: Int + _rightOnested :: Bool + _rightIpp :: PP_Doc + _rightIprec :: Int + -- "PrintCode.ag"(line 194, column 7) + _lhsOpp = + (pp_block "(" ")" "," $ map (\(n,ns) -> hv_sp $ map pp (n:ns)) left_) >#< "=>" >#< _rightIpp + -- copy rule (up) + _lhsOprec = + _rightIprec + -- copy rule (down) + _rightOnested = + _lhsInested + ( _rightIpp,_rightIprec) = + (right_ _rightOnested) + in ( _lhsOpp,_lhsOprec)))) +sem_Type_List :: T_Type -> + T_Type +sem_Type_List (T_Type tp_) = + (T_Type (\ _lhsInested -> + (let _lhsOprec :: Int + _lhsOpp :: PP_Doc + _tpOnested :: Bool + _tpIpp :: PP_Doc + _tpIprec :: Int + -- "PrintCode.ag"(line 202, column 16) + _lhsOprec = + 5 + -- "PrintCode.ag"(line 202, column 16) + _lhsOpp = + "[" >|< _tpIpp >|< "]" + -- copy rule (down) + _tpOnested = + _lhsInested + ( _tpIpp,_tpIprec) = + (tp_ _tpOnested) + in ( _lhsOpp,_lhsOprec)))) +sem_Type_SimpleType :: String -> + T_Type +sem_Type_SimpleType txt_ = + (T_Type (\ _lhsInested -> + (let _lhsOprec :: Int + _lhsOpp :: PP_Doc + -- "PrintCode.ag"(line 205, column 16) + _lhsOprec = + 5 + -- "PrintCode.ag"(line 205, column 16) + _lhsOpp = + if reallySimple txt_ then text txt_ else pp_parens (text txt_) + in ( _lhsOpp,_lhsOprec)))) +sem_Type_TupleType :: T_Types -> + T_Type +sem_Type_TupleType (T_Types tps_) = + (T_Type (\ _lhsInested -> + (let _lhsOprec :: Int + _lhsOpp :: PP_Doc + _tpsOnested :: Bool + _tpsIpps :: PP_Docs + -- "PrintCode.ag"(line 196, column 16) + _lhsOprec = + 5 + -- "PrintCode.ag"(line 196, column 16) + _lhsOpp = + ppTuple _lhsInested _tpsIpps + -- copy rule (down) + _tpsOnested = + _lhsInested + ( _tpsIpps) = + (tps_ _tpsOnested) + in ( _lhsOpp,_lhsOprec)))) +sem_Type_TypeApp :: T_Type -> + T_Types -> + T_Type +sem_Type_TypeApp (T_Type func_) (T_Types args_) = + (T_Type (\ _lhsInested -> + (let _lhsOpp :: PP_Doc + _lhsOprec :: Int + _funcOnested :: Bool + _argsOnested :: Bool + _funcIpp :: PP_Doc + _funcIprec :: Int + _argsIpps :: PP_Docs + -- "PrintCode.ag"(line 191, column 7) + _lhsOpp = + hv_sp (_funcIpp : _argsIpps) + -- copy rule (up) + _lhsOprec = + _funcIprec + -- copy rule (down) + _funcOnested = + _lhsInested + -- copy rule (down) + _argsOnested = + _lhsInested + ( _funcIpp,_funcIprec) = + (func_ _funcOnested) + ( _argsIpps) = + (args_ _argsOnested) + in ( _lhsOpp,_lhsOprec)))) +sem_Type_UnboxedTupleType :: T_Types -> + T_Type +sem_Type_UnboxedTupleType (T_Types tps_) = + (T_Type (\ _lhsInested -> + (let _lhsOprec :: Int + _lhsOpp :: PP_Doc + _tpsOnested :: Bool + _tpsIpps :: PP_Docs + -- "PrintCode.ag"(line 199, column 23) + _lhsOprec = + 5 + -- "PrintCode.ag"(line 199, column 23) + _lhsOpp = + ppUnboxedTuple _lhsInested _tpsIpps + -- copy rule (down) + _tpsOnested = + _lhsInested + ( _tpsIpps) = + (tps_ _tpsOnested) + in ( _lhsOpp,_lhsOprec)))) +-- Types ------------------------------------------------------- +{- + visit 0: + inherited attribute: + nested : Bool + synthesized attribute: + pps : PP_Docs + alternatives: + alternative Cons: + child hd : Type + child tl : Types + alternative Nil: +-} +-- cata +sem_Types :: Types -> + T_Types +sem_Types list = + (Prelude.foldr sem_Types_Cons sem_Types_Nil (Prelude.map sem_Type list)) +-- semantic domain +newtype T_Types = T_Types (Bool -> + ( PP_Docs)) +data Inh_Types = Inh_Types {nested_Inh_Types :: Bool} +data Syn_Types = Syn_Types {pps_Syn_Types :: PP_Docs} +wrap_Types (T_Types sem) (Inh_Types _lhsInested) = + (let ( _lhsOpps) = + (sem _lhsInested) + in (Syn_Types _lhsOpps)) +sem_Types_Cons :: T_Type -> + T_Types -> + T_Types +sem_Types_Cons (T_Type hd_) (T_Types tl_) = + (T_Types (\ _lhsInested -> + (let _lhsOpps :: PP_Docs + _hdOnested :: Bool + _tlOnested :: Bool + _hdIpp :: PP_Doc + _hdIprec :: Int + _tlIpps :: PP_Docs + -- "PrintCode.ag"(line 67, column 10) + _lhsOpps = + _hdIpp : _tlIpps + -- copy rule (down) + _hdOnested = + _lhsInested + -- copy rule (down) + _tlOnested = + _lhsInested + ( _hdIpp,_hdIprec) = + (hd_ _hdOnested) + ( _tlIpps) = + (tl_ _tlOnested) + in ( _lhsOpps)))) +sem_Types_Nil :: T_Types +sem_Types_Nil = + (T_Types (\ _lhsInested -> + (let _lhsOpps :: PP_Docs + -- "PrintCode.ag"(line 68, column 10) + _lhsOpps = + [] + in ( _lhsOpps)))) diff --git a/src-derived/PrintErrorMessages.hs b/src-derived/PrintErrorMessages.hs --- a/src-derived/PrintErrorMessages.hs +++ b/src-derived/PrintErrorMessages.hs @@ -1,4 +1,3 @@ - -- UUAGC 0.9.5 (PrintErrorMessages.ag) module PrintErrorMessages where @@ -6,7 +5,7 @@ import UU.Scanner.Position(Pos(..), noPos) import ErrorMessages import DepTypes -import Options (Options,verbose) +import Options import Data.List(mapAccumL,intersect,(\\)) import GrammarInfo @@ -16,34 +15,37 @@ import CodeSyntax import CommonTypes -isError :: Error -> Bool -isError (ParserError _ _ _ ) = True -isError (DupAlt _ _ _ ) = False -isError (DupSynonym _ _ ) = False -isError (DupSet _ _ ) = False -isError (DupInhAttr _ _ _ ) = True -isError (DupSynAttr _ _ _ ) = True -isError (DupChild _ _ _ _ ) = False -isError (DupRule _ _ _ _ _) = True -isError (DupSig _ _ _ ) = True -isError (UndefNont _ ) = True -isError (UndefAlt _ _ ) = True -isError (UndefChild _ _ _ ) = True -isError (MissingRule _ _ _ _ ) = False -isError (SuperfluousRule _ _ _ _ ) = False -isError (UndefLocal _ _ _ ) = True -isError (ChildAsLocal _ _ _ ) = False -isError (UndefAttr _ _ _ _ ) = True -isError (CyclicSet _ ) = True -isError (CustomError w _ _ ) = not w -isError (LocalCirc _ _ _ _ _) = False -isError (InstCirc _ _ _ _ _) = False -isError (DirectCirc _ _ _ ) = False -isError (InducedCirc _ _ _ ) = False -isError (MissingTypeSig _ _ _ ) = False -isError (MissingInstSig _ _ _ ) = True -isError (ErroneousOrder _ _ _ ) = True +isError :: Options -> Error -> Bool +isError opts (ParserError _ _ _ ) = True +isError opts (DupAlt _ _ _ ) = False +isError opts (DupSynonym _ _ ) = False +isError opts (DupSet _ _ ) = False +isError opts (DupInhAttr _ _ _ ) = True +isError opts (DupSynAttr _ _ _ ) = True +isError opts (DupChild _ _ _ _ ) = False +isError opts (DupRule _ _ _ _ _) = True +isError opts (DupSig _ _ _ ) = True +isError opts (UndefNont _ ) = True +isError opts (UndefAlt _ _ ) = True +isError opts (UndefChild _ _ _ ) = True +isError opts (MissingRule _ _ _ _ ) = False +isError opts (SuperfluousRule _ _ _ _ ) = False +isError opts (UndefLocal _ _ _ ) = True +isError opts (ChildAsLocal _ _ _ ) = False +isError opts (UndefAttr _ _ _ _ _) = True +isError opts (CyclicSet _ ) = True +isError opts (CustomError w _ _ ) = not w +isError opts (LocalCirc _ _ _ _ _) = cycleIsDangerous opts +isError opts (InstCirc _ _ _ _ _) = cycleIsDangerous opts +isError opts (DirectCirc _ _ _ ) = cycleIsDangerous opts +isError opts (InducedCirc _ _ _ ) = cycleIsDangerous opts +isError opts (MissingTypeSig _ _ _ ) = False +isError opts (MissingInstSig _ _ _ ) = True +cycleIsDangerous :: Options -> Bool +cycleIsDangerous opts + = any ($ opts) [ wignore, bangpats, cases, strictCases, stricterCases, strictSems, withCycle ] + toWidth n xs | k T_Error -sem_Error (ChildAsLocal _nt _con _var ) = - (sem_Error_ChildAsLocal _nt _con _var ) -sem_Error (CustomError _isWarning _pos _mesg ) = - (sem_Error_CustomError _isWarning _pos _mesg ) -sem_Error (CyclicSet _name ) = - (sem_Error_CyclicSet _name ) -sem_Error (DirectCirc _nt _o_visit _cyclic ) = - (sem_Error_DirectCirc _nt _o_visit _cyclic ) -sem_Error (DupAlt _nt _con _occ1 ) = - (sem_Error_DupAlt _nt _con _occ1 ) -sem_Error (DupChild _nt _con _name _occ1 ) = - (sem_Error_DupChild _nt _con _name _occ1 ) -sem_Error (DupInhAttr _nt _attr _occ1 ) = - (sem_Error_DupInhAttr _nt _attr _occ1 ) -sem_Error (DupRule _nt _con _field _attr _occ1 ) = - (sem_Error_DupRule _nt _con _field _attr _occ1 ) -sem_Error (DupSet _name _occ1 ) = - (sem_Error_DupSet _name _occ1 ) -sem_Error (DupSig _nt _con _attr ) = - (sem_Error_DupSig _nt _con _attr ) -sem_Error (DupSynAttr _nt _attr _occ1 ) = - (sem_Error_DupSynAttr _nt _attr _occ1 ) -sem_Error (DupSynonym _nt _occ1 ) = - (sem_Error_DupSynonym _nt _occ1 ) -sem_Error (ErroneousOrder _nt _con _order ) = - (sem_Error_ErroneousOrder _nt _con _order ) -sem_Error (InducedCirc _nt _cinter _cyclic ) = - (sem_Error_InducedCirc _nt _cinter _cyclic ) -sem_Error (InstCirc _nt _con _attr _o_visit _path ) = - (sem_Error_InstCirc _nt _con _attr _o_visit _path ) -sem_Error (LocalCirc _nt _con _attr _o_visit _path ) = - (sem_Error_LocalCirc _nt _con _attr _o_visit _path ) -sem_Error (MissingInstSig _nt _con _attr ) = - (sem_Error_MissingInstSig _nt _con _attr ) -sem_Error (MissingRule _nt _con _field _attr ) = - (sem_Error_MissingRule _nt _con _field _attr ) -sem_Error (MissingTypeSig _nt _con _attr ) = - (sem_Error_MissingTypeSig _nt _con _attr ) -sem_Error (ParserError _pos _problem _action ) = - (sem_Error_ParserError _pos _problem _action ) -sem_Error (SuperfluousRule _nt _con _field _attr ) = - (sem_Error_SuperfluousRule _nt _con _field _attr ) -sem_Error (UndefAlt _nt _con ) = - (sem_Error_UndefAlt _nt _con ) -sem_Error (UndefAttr _nt _con _field _attr ) = - (sem_Error_UndefAttr _nt _con _field _attr ) -sem_Error (UndefChild _nt _con _name ) = - (sem_Error_UndefChild _nt _con _name ) -sem_Error (UndefLocal _nt _con _var ) = - (sem_Error_UndefLocal _nt _con _var ) -sem_Error (UndefNont _nt ) = - (sem_Error_UndefNont _nt ) +sem_Error (ChildAsLocal _nt _con _var) = + (sem_Error_ChildAsLocal _nt _con _var) +sem_Error (CustomError _isWarning _pos _mesg) = + (sem_Error_CustomError _isWarning _pos _mesg) +sem_Error (CyclicSet _name) = + (sem_Error_CyclicSet _name) +sem_Error (DirectCirc _nt _o_visit _cyclic) = + (sem_Error_DirectCirc _nt _o_visit _cyclic) +sem_Error (DupAlt _nt _con _occ1) = + (sem_Error_DupAlt _nt _con _occ1) +sem_Error (DupChild _nt _con _name _occ1) = + (sem_Error_DupChild _nt _con _name _occ1) +sem_Error (DupInhAttr _nt _attr _occ1) = + (sem_Error_DupInhAttr _nt _attr _occ1) +sem_Error (DupRule _nt _con _field _attr _occ1) = + (sem_Error_DupRule _nt _con _field _attr _occ1) +sem_Error (DupSet _name _occ1) = + (sem_Error_DupSet _name _occ1) +sem_Error (DupSig _nt _con _attr) = + (sem_Error_DupSig _nt _con _attr) +sem_Error (DupSynAttr _nt _attr _occ1) = + (sem_Error_DupSynAttr _nt _attr _occ1) +sem_Error (DupSynonym _nt _occ1) = + (sem_Error_DupSynonym _nt _occ1) +sem_Error (InducedCirc _nt _cinter _cyclic) = + (sem_Error_InducedCirc _nt _cinter _cyclic) +sem_Error (InstCirc _nt _con _attr _o_visit _path) = + (sem_Error_InstCirc _nt _con _attr _o_visit _path) +sem_Error (LocalCirc _nt _con _attr _o_visit _path) = + (sem_Error_LocalCirc _nt _con _attr _o_visit _path) +sem_Error (MissingInstSig _nt _con _attr) = + (sem_Error_MissingInstSig _nt _con _attr) +sem_Error (MissingRule _nt _con _field _attr) = + (sem_Error_MissingRule _nt _con _field _attr) +sem_Error (MissingTypeSig _nt _con _attr) = + (sem_Error_MissingTypeSig _nt _con _attr) +sem_Error (ParserError _pos _problem _action) = + (sem_Error_ParserError _pos _problem _action) +sem_Error (SuperfluousRule _nt _con _field _attr) = + (sem_Error_SuperfluousRule _nt _con _field _attr) +sem_Error (UndefAlt _nt _con) = + (sem_Error_UndefAlt _nt _con) +sem_Error (UndefAttr _nt _con _field _attr _isOut) = + (sem_Error_UndefAttr _nt _con _field _attr _isOut) +sem_Error (UndefChild _nt _con _name) = + (sem_Error_UndefChild _nt _con _name) +sem_Error (UndefLocal _nt _con _var) = + (sem_Error_UndefLocal _nt _con _var) +sem_Error (UndefNont _nt) = + (sem_Error_UndefNont _nt) -- semantic domain -newtype T_Error = T_Error (Bool -> +newtype T_Error = T_Error (Options -> + Bool -> ( Error,PP_Doc)) -data Inh_Error = Inh_Error {verbose_Inh_Error :: Bool} +data Inh_Error = Inh_Error {options_Inh_Error :: Options,verbose_Inh_Error :: Bool} data Syn_Error = Syn_Error {me_Syn_Error :: Error,pp_Syn_Error :: PP_Doc} -wrap_Error (T_Error sem ) (Inh_Error _lhsIverbose ) = +wrap_Error (T_Error sem) (Inh_Error _lhsIoptions _lhsIverbose) = (let ( _lhsOme,_lhsOpp) = - (sem _lhsIverbose ) - in (Syn_Error _lhsOme _lhsOpp )) -sem_Error_ChildAsLocal :: Nonterminal -> - Constructor -> - Name -> + (sem _lhsIoptions _lhsIverbose) + in (Syn_Error _lhsOme _lhsOpp)) +sem_Error_ChildAsLocal :: NontermIdent -> + ConstructorIdent -> + Identifier -> T_Error -sem_Error_ChildAsLocal nt_ con_ var_ = - (T_Error (\ _lhsIverbose -> +sem_Error_ChildAsLocal nt_ con_ var_ = + (T_Error (\ _lhsIoptions + _lhsIverbose -> (let _lhsOpp :: PP_Doc _lhsOme :: Error - -- "PrintErrorMessages.ag"(line 297, column 21) + -- "PrintErrorMessages.ag"(line 300, column 21) _lhsOpp = let mesg = wfill ["Nontrivial field ",getName var_, "is used as local at constructor" , getName con_ , "of nonterminal",getName nt_, "." @@ -404,42 +402,44 @@ ,"You should use @", getName var_, ".self instead, where self is a SELF-attribute." ] act = wfill ["The generated program probably contains a type error or has undefined variables."] - in ppError (isError _me) (getPos var_) mesg pat help act _lhsIverbose + in ppError (isError _lhsIoptions _me) (getPos var_) mesg pat help act _lhsIverbose -- self rule _me = ChildAsLocal nt_ con_ var_ -- self rule _lhsOme = _me - in ( _lhsOme,_lhsOpp))) ) + in ( _lhsOme,_lhsOpp)))) sem_Error_CustomError :: Bool -> Pos -> PP_Doc -> T_Error -sem_Error_CustomError isWarning_ pos_ mesg_ = - (T_Error (\ _lhsIverbose -> +sem_Error_CustomError isWarning_ pos_ mesg_ = + (T_Error (\ _lhsIoptions + _lhsIverbose -> (let _lhsOpp :: PP_Doc _lhsOme :: Error - -- "PrintErrorMessages.ag"(line 335, column 21) + -- "PrintErrorMessages.ag"(line 342, column 21) _lhsOpp = let pat = text "unknown" help = wfill ["not available."] act = wfill ["unknown"] - in ppError (isError _me) pos_ mesg_ pat help act False + in ppError (isError _lhsIoptions _me) pos_ mesg_ pat help act False -- self rule _me = CustomError isWarning_ pos_ mesg_ -- self rule _lhsOme = _me - in ( _lhsOme,_lhsOpp))) ) -sem_Error_CyclicSet :: Name -> + in ( _lhsOme,_lhsOpp)))) +sem_Error_CyclicSet :: Identifier -> T_Error -sem_Error_CyclicSet name_ = - (T_Error (\ _lhsIverbose -> +sem_Error_CyclicSet name_ = + (T_Error (\ _lhsIoptions + _lhsIverbose -> (let _lhsOpp :: PP_Doc _lhsOme :: Error - -- "PrintErrorMessages.ag"(line 326, column 21) + -- "PrintErrorMessages.ag"(line 333, column 21) _lhsOpp = let mesg = wfill ["Cyclic definition for nonterminal set", getName name_] pat = "SET" >#< getName name_ >#< "=" >#< "..." >#< getName name_ >#< "..." @@ -448,23 +448,24 @@ ,"Adapt the definition of the nonterminal set, to remove the cyclic dependency." ] act = wfill ["The nonterminal set", getName name_, "is considered to be empty."] - in ppError (isError _me) (getPos name_) mesg pat help act _lhsIverbose + in ppError (isError _lhsIoptions _me) (getPos name_) mesg pat help act _lhsIverbose -- self rule _me = CyclicSet name_ -- self rule _lhsOme = _me - in ( _lhsOme,_lhsOpp))) ) -sem_Error_DirectCirc :: Nonterminal -> + in ( _lhsOme,_lhsOpp)))) +sem_Error_DirectCirc :: NontermIdent -> Bool -> - ([((Name,Name),[String],[String])]) -> + ([((Identifier,Identifier),[String],[String])]) -> T_Error -sem_Error_DirectCirc nt_ o_visit_ cyclic_ = - (T_Error (\ _lhsIverbose -> +sem_Error_DirectCirc nt_ o_visit_ cyclic_ = + (T_Error (\ _lhsIoptions + _lhsIverbose -> (let _lhsOpp :: PP_Doc _lhsOme :: Error - -- "PrintErrorMessages.ag"(line 364, column 21) + -- "PrintErrorMessages.ag"(line 371, column 21) _lhsOpp = let mesg = wfill ["In nonterminal", getName nt_, "synthesized and inherited attributes are mutually dependent" ] >-< vlist (map showEdge cyclic_) @@ -472,23 +473,24 @@ help = vlist (map showEdgeLong cyclic_) act | o_visit_ = text "An unoptimized version was generated. It might hang when run." | otherwise = text "The generated program might hang when run." - in ppError (isError _me) noPos mesg pat help act _lhsIverbose + in ppError (isError _lhsIoptions _me) noPos mesg pat help act _lhsIverbose -- self rule _me = DirectCirc nt_ o_visit_ cyclic_ -- self rule _lhsOme = _me - in ( _lhsOme,_lhsOpp))) ) -sem_Error_DupAlt :: Nonterminal -> - Constructor -> - Constructor -> + in ( _lhsOme,_lhsOpp)))) +sem_Error_DupAlt :: NontermIdent -> + ConstructorIdent -> + ConstructorIdent -> T_Error -sem_Error_DupAlt nt_ con_ occ1_ = - (T_Error (\ _lhsIverbose -> +sem_Error_DupAlt nt_ con_ occ1_ = + (T_Error (\ _lhsIoptions + _lhsIverbose -> (let _lhsOpp :: PP_Doc _lhsOme :: Error - -- "PrintErrorMessages.ag"(line 70, column 21) + -- "PrintErrorMessages.ag"(line 73, column 21) _lhsOpp = let mesg = wfill ["Repeated definition for alternative", getName con_ ,"of nonterminal", getName nt_, "." @@ -507,24 +509,25 @@ ,"you have given for nonterminal",getName nt_ ,"is considered valid. All other alternatives have been discarded." ] - in ppError (isError _me) (getPos con_) mesg pat help act _lhsIverbose + in ppError (isError _lhsIoptions _me) (getPos con_) mesg pat help act _lhsIverbose -- self rule _me = DupAlt nt_ con_ occ1_ -- self rule _lhsOme = _me - in ( _lhsOme,_lhsOpp))) ) -sem_Error_DupChild :: Nonterminal -> - Constructor -> - Name -> - Name -> + in ( _lhsOme,_lhsOpp)))) +sem_Error_DupChild :: NontermIdent -> + ConstructorIdent -> + Identifier -> + Identifier -> T_Error -sem_Error_DupChild nt_ con_ name_ occ1_ = - (T_Error (\ _lhsIverbose -> +sem_Error_DupChild nt_ con_ name_ occ1_ = + (T_Error (\ _lhsIoptions + _lhsIverbose -> (let _lhsOpp :: PP_Doc _lhsOme :: Error - -- "PrintErrorMessages.ag"(line 163, column 21) + -- "PrintErrorMessages.ag"(line 166, column 21) _lhsOpp = let mesg = wfill ["Repeated declaration for field", getName name_, "of alternative" ,getName con_, "of nonterminal", getName nt_, "." @@ -542,23 +545,24 @@ act = wfill ["The last declaration with its corresponding type is considered valid." ,"All others have been discarded." ] - in ppError (isError _me) (getPos name_) mesg pat help act _lhsIverbose + in ppError (isError _lhsIoptions _me) (getPos name_) mesg pat help act _lhsIverbose -- self rule _me = DupChild nt_ con_ name_ occ1_ -- self rule _lhsOme = _me - in ( _lhsOme,_lhsOpp))) ) -sem_Error_DupInhAttr :: Nonterminal -> - Name -> - Name -> + in ( _lhsOme,_lhsOpp)))) +sem_Error_DupInhAttr :: NontermIdent -> + Identifier -> + Identifier -> T_Error -sem_Error_DupInhAttr nt_ attr_ occ1_ = - (T_Error (\ _lhsIverbose -> +sem_Error_DupInhAttr nt_ attr_ occ1_ = + (T_Error (\ _lhsIoptions + _lhsIverbose -> (let _lhsOpp :: PP_Doc _lhsOme :: Error - -- "PrintErrorMessages.ag"(line 125, column 21) + -- "PrintErrorMessages.ag"(line 128, column 21) _lhsOpp = let mesg = wfill ["Repeated declaration of inherited attribute", getName attr_ , "of nonterminal", getName nt_, "." @@ -575,25 +579,26 @@ act = wfill ["One declaration with its corresponding type is considered valid." ,"All others have been discarded. The generated program will probably not run." ] - in ppError (isError _me) (getPos attr_) mesg pat help act _lhsIverbose + in ppError (isError _lhsIoptions _me) (getPos attr_) mesg pat help act _lhsIverbose -- self rule _me = DupInhAttr nt_ attr_ occ1_ -- self rule _lhsOme = _me - in ( _lhsOme,_lhsOpp))) ) -sem_Error_DupRule :: Nonterminal -> - Constructor -> - Name -> - Name -> - Name -> + in ( _lhsOme,_lhsOpp)))) +sem_Error_DupRule :: NontermIdent -> + ConstructorIdent -> + Identifier -> + Identifier -> + Identifier -> T_Error -sem_Error_DupRule nt_ con_ field_ attr_ occ1_ = - (T_Error (\ _lhsIverbose -> +sem_Error_DupRule nt_ con_ field_ attr_ occ1_ = + (T_Error (\ _lhsIoptions + _lhsIverbose -> (let _lhsOpp :: PP_Doc _lhsOme :: Error - -- "PrintErrorMessages.ag"(line 183, column 21) + -- "PrintErrorMessages.ag"(line 186, column 21) _lhsOpp = let mesg = wfill ["At constructor",getName con_, "of nonterminal", getName nt_, "there are two or more rules for" ,showAttrDef field_ attr_,"." @@ -609,22 +614,23 @@ ,getName con_ , "of nonterminal " ,getName nt_ , "uniquely named." ] act = wfill ["The last rule given is considered valid. All others have been discarded."] - in ppError (isError _me) (getPos attr_) mesg pat help act _lhsIverbose + in ppError (isError _lhsIoptions _me) (getPos attr_) mesg pat help act _lhsIverbose -- self rule _me = DupRule nt_ con_ field_ attr_ occ1_ -- self rule _lhsOme = _me - in ( _lhsOme,_lhsOpp))) ) -sem_Error_DupSet :: Nonterminal -> - Nonterminal -> + in ( _lhsOme,_lhsOpp)))) +sem_Error_DupSet :: NontermIdent -> + NontermIdent -> T_Error -sem_Error_DupSet name_ occ1_ = - (T_Error (\ _lhsIverbose -> +sem_Error_DupSet name_ occ1_ = + (T_Error (\ _lhsIoptions + _lhsIverbose -> (let _lhsOpp :: PP_Doc _lhsOme :: Error - -- "PrintErrorMessages.ag"(line 109, column 21) + -- "PrintErrorMessages.ag"(line 112, column 21) _lhsOpp = let mesg = wfill ["Definition of nonterminal set", getName name_, "clashes with another" ,"set, a type synonym or a data definition." @@ -640,23 +646,24 @@ ] act = wfill [ "The clashing nonterminal set will be ignored." ] - in ppError (isError _me) (getPos name_) mesg pat help act _lhsIverbose + in ppError (isError _lhsIoptions _me) (getPos name_) mesg pat help act _lhsIverbose -- self rule _me = DupSet name_ occ1_ -- self rule _lhsOme = _me - in ( _lhsOme,_lhsOpp))) ) -sem_Error_DupSig :: Nonterminal -> - Constructor -> - Name -> + in ( _lhsOme,_lhsOpp)))) +sem_Error_DupSig :: NontermIdent -> + ConstructorIdent -> + Identifier -> T_Error -sem_Error_DupSig nt_ con_ attr_ = - (T_Error (\ _lhsIverbose -> +sem_Error_DupSig nt_ con_ attr_ = + (T_Error (\ _lhsIoptions + _lhsIverbose -> (let _lhsOpp :: PP_Doc _lhsOme :: Error - -- "PrintErrorMessages.ag"(line 201, column 21) + -- "PrintErrorMessages.ag"(line 204, column 21) _lhsOpp = let mesg = wfill ["At constructor",getName con_, "of nonterminal", getName nt_, "there are two or more typesignatures for" ,showAttrDef _LOC attr_,"." @@ -671,23 +678,24 @@ ,getName con_ , "of nonterminal " ,getName nt_ , "unique." ] act = wfill ["The last typesignature given is considered valid. All others have been discarded."] - in ppError (isError _me) (getPos attr_) mesg pat help act _lhsIverbose + in ppError (isError _lhsIoptions _me) (getPos attr_) mesg pat help act _lhsIverbose -- self rule _me = DupSig nt_ con_ attr_ -- self rule _lhsOme = _me - in ( _lhsOme,_lhsOpp))) ) -sem_Error_DupSynAttr :: Nonterminal -> - Name -> - Name -> + in ( _lhsOme,_lhsOpp)))) +sem_Error_DupSynAttr :: NontermIdent -> + Identifier -> + Identifier -> T_Error -sem_Error_DupSynAttr nt_ attr_ occ1_ = - (T_Error (\ _lhsIverbose -> +sem_Error_DupSynAttr nt_ attr_ occ1_ = + (T_Error (\ _lhsIoptions + _lhsIverbose -> (let _lhsOpp :: PP_Doc _lhsOme :: Error - -- "PrintErrorMessages.ag"(line 144, column 21) + -- "PrintErrorMessages.ag"(line 147, column 21) _lhsOpp = let mesg = wfill ["Repeated declaration of synthesized attribute", getName attr_ , "of nonterminal", getName nt_, "." @@ -704,22 +712,23 @@ act = wfill ["One declaration with its corresponding type is considered valid." ,"All others have been discarded. The generated program will probably not run." ] - in ppError (isError _me) (getPos attr_) mesg pat help act _lhsIverbose + in ppError (isError _lhsIoptions _me) (getPos attr_) mesg pat help act _lhsIverbose -- self rule _me = DupSynAttr nt_ attr_ occ1_ -- self rule _lhsOme = _me - in ( _lhsOme,_lhsOpp))) ) -sem_Error_DupSynonym :: Nonterminal -> - Nonterminal -> + in ( _lhsOme,_lhsOpp)))) +sem_Error_DupSynonym :: NontermIdent -> + NontermIdent -> T_Error -sem_Error_DupSynonym nt_ occ1_ = - (T_Error (\ _lhsIverbose -> +sem_Error_DupSynonym nt_ occ1_ = + (T_Error (\ _lhsIoptions + _lhsIverbose -> (let _lhsOpp :: PP_Doc _lhsOme :: Error - -- "PrintErrorMessages.ag"(line 92, column 21) + -- "PrintErrorMessages.ag"(line 95, column 21) _lhsOpp = let mesg = wfill ["Definition of type synonym", getName nt_, "clashes with another" ,"type synonym." @@ -736,57 +745,24 @@ ] act = wfill [ "The clashing type synonym will be ignored." ] - in ppError (isError _me) (getPos nt_) mesg pat help act _lhsIverbose + in ppError (isError _lhsIoptions _me) (getPos nt_) mesg pat help act _lhsIverbose -- self rule _me = DupSynonym nt_ occ1_ -- self rule _lhsOme = _me - in ( _lhsOme,_lhsOpp))) ) -sem_Error_ErroneousOrder :: Nonterminal -> - Constructor -> - Dependency -> - T_Error -sem_Error_ErroneousOrder nt_ con_ order_ = - (T_Error (\ _lhsIverbose -> - (let _lhsOpp :: PP_Doc - _lhsOme :: Error - -- "PrintErrorMessages.ag"(line 409, column 21) - _lhsOpp = - let (Dependency (fldA,nmA) (fldB,nmB)) = order_ - mesg = wfill ["At alternative",getName con_, "of nonterminal", getName nt_, "there is an erroneous order" - , showAttrDef fldA nmA - , "<" - , showAttrDef fldB nmB - ] - pat = "SEM" >#< getName nt_ - >-< indent 2 ("|" >#< getName con_ >#< ppAttr fldA nmA >#< "<" >#< ppAttr fldB nmB) - help = wfill [ "In the rules for alternative" , getName con_ , "of nonterminal" , getName nt_ - , ", there is an erroneous attribute order defined" - , showAttrDef fldA nmA, "<", showAttrDef fldB nmB - , "because" - , showAttrDef fldA nmA - , "is not an In-attribute (inherited attribute of the production, or a synthesized attribute of a child)" - ] - act = wfill ["Please change the order definition."] - in ppError (isError _me) (getPos fldA) mesg pat help act _lhsIverbose - -- self rule - _me = - ErroneousOrder nt_ con_ order_ - -- self rule - _lhsOme = - _me - in ( _lhsOme,_lhsOpp))) ) -sem_Error_InducedCirc :: Nonterminal -> + in ( _lhsOme,_lhsOpp)))) +sem_Error_InducedCirc :: NontermIdent -> CInterface -> - ([((Name,Name),[String],[String])]) -> + ([((Identifier,Identifier),[String],[String])]) -> T_Error -sem_Error_InducedCirc nt_ cinter_ cyclic_ = - (T_Error (\ _lhsIverbose -> +sem_Error_InducedCirc nt_ cinter_ cyclic_ = + (T_Error (\ _lhsIoptions + _lhsIverbose -> (let _lhsOpp :: PP_Doc _lhsOme :: Error - -- "PrintErrorMessages.ag"(line 372, column 21) + -- "PrintErrorMessages.ag"(line 379, column 21) _lhsOpp = let mesg = wfill ["After scheduling, in nonterminal", getName nt_, "synthesized and inherited attributes have an INDUCED mutual dependency" ] >-< vlist (map showEdge cyclic_) @@ -795,25 +771,26 @@ help = vlist (("Interface for nonterminal " ++ getName nt_ ++ ":") : map ind (showInter cinter_)) >-< vlist (map showEdgeLong cyclic_) act = text "An unoptimized version was generated. It might hang when run." - in ppError (isError _me) noPos mesg pat help act _lhsIverbose + in ppError (isError _lhsIoptions _me) noPos mesg pat help act _lhsIverbose -- self rule _me = InducedCirc nt_ cinter_ cyclic_ -- self rule _lhsOme = _me - in ( _lhsOme,_lhsOpp))) ) -sem_Error_InstCirc :: Nonterminal -> - Constructor -> - Name -> + in ( _lhsOme,_lhsOpp)))) +sem_Error_InstCirc :: NontermIdent -> + ConstructorIdent -> + Identifier -> Bool -> ([String]) -> T_Error -sem_Error_InstCirc nt_ con_ attr_ o_visit_ path_ = - (T_Error (\ _lhsIverbose -> +sem_Error_InstCirc nt_ con_ attr_ o_visit_ path_ = + (T_Error (\ _lhsIoptions + _lhsIverbose -> (let _lhsOpp :: PP_Doc _lhsOme :: Error - -- "PrintErrorMessages.ag"(line 352, column 21) + -- "PrintErrorMessages.ag"(line 359, column 21) _lhsOpp = let mesg = wfill ["Circular dependency for inst attribute", getName attr_ , "of alternative", getName con_, "of nonterminal", getName nt_] @@ -825,25 +802,26 @@ else hlist ("The following attributes are involved in the cycle:": path_) act | o_visit_ = text "An unoptimized version was generated. It might hang when run." | otherwise = text "The generated program might hang when run." - in ppError (isError _me) (getPos (attr_)) mesg pat help act _lhsIverbose + in ppError (isError _lhsIoptions _me) (getPos (attr_)) mesg pat help act _lhsIverbose -- self rule _me = InstCirc nt_ con_ attr_ o_visit_ path_ -- self rule _lhsOme = _me - in ( _lhsOme,_lhsOpp))) ) -sem_Error_LocalCirc :: Nonterminal -> - Constructor -> - Name -> + in ( _lhsOme,_lhsOpp)))) +sem_Error_LocalCirc :: NontermIdent -> + ConstructorIdent -> + Identifier -> Bool -> ([String]) -> T_Error -sem_Error_LocalCirc nt_ con_ attr_ o_visit_ path_ = - (T_Error (\ _lhsIverbose -> +sem_Error_LocalCirc nt_ con_ attr_ o_visit_ path_ = + (T_Error (\ _lhsIoptions + _lhsIverbose -> (let _lhsOpp :: PP_Doc _lhsOme :: Error - -- "PrintErrorMessages.ag"(line 340, column 21) + -- "PrintErrorMessages.ag"(line 347, column 21) _lhsOpp = let mesg = wfill ["Circular dependency for local attribute", getName attr_ , "of alternative", getName con_, "of nonterminal", getName nt_] @@ -855,23 +833,24 @@ else hlist ("The following attributes are involved in the cycle:": path_) act | o_visit_ = text "An unoptimized version was generated. It might hang when run." | otherwise = text "The generated program might hang when run." - in ppError (isError _me) (getPos (attr_)) mesg pat help act _lhsIverbose + in ppError (isError _lhsIoptions _me) (getPos (attr_)) mesg pat help act _lhsIverbose -- self rule _me = LocalCirc nt_ con_ attr_ o_visit_ path_ -- self rule _lhsOme = _me - in ( _lhsOme,_lhsOpp))) ) -sem_Error_MissingInstSig :: Nonterminal -> - Constructor -> - Name -> + in ( _lhsOme,_lhsOpp)))) +sem_Error_MissingInstSig :: NontermIdent -> + ConstructorIdent -> + Identifier -> T_Error -sem_Error_MissingInstSig nt_ con_ attr_ = - (T_Error (\ _lhsIverbose -> +sem_Error_MissingInstSig nt_ con_ attr_ = + (T_Error (\ _lhsIoptions + _lhsIverbose -> (let _lhsOpp :: PP_Doc _lhsOme :: Error - -- "PrintErrorMessages.ag"(line 395, column 21) + -- "PrintErrorMessages.ag"(line 402, column 21) _lhsOpp = let mesg = wfill ["Type signature needed, but not found for", showAttrDef _INST attr_ , "in alternative" , getName con_ , "of nonterminal",getName nt_ ,"." @@ -885,24 +864,25 @@ ,"Please supply its type." ] act = wfill ["It is not possible to proceed without this signature."] - in ppError (isError _me) (getPos attr_) mesg pat help act _lhsIverbose + in ppError (isError _lhsIoptions _me) (getPos attr_) mesg pat help act _lhsIverbose -- self rule _me = MissingInstSig nt_ con_ attr_ -- self rule _lhsOme = _me - in ( _lhsOme,_lhsOpp))) ) -sem_Error_MissingRule :: Nonterminal -> - Constructor -> - Name -> - Name -> + in ( _lhsOme,_lhsOpp)))) +sem_Error_MissingRule :: NontermIdent -> + ConstructorIdent -> + Identifier -> + Identifier -> T_Error -sem_Error_MissingRule nt_ con_ field_ attr_ = - (T_Error (\ _lhsIverbose -> +sem_Error_MissingRule nt_ con_ field_ attr_ = + (T_Error (\ _lhsIoptions + _lhsIverbose -> (let _lhsOpp :: PP_Doc _lhsOme :: Error - -- "PrintErrorMessages.ag"(line 255, column 21) + -- "PrintErrorMessages.ag"(line 258, column 21) _lhsOpp = let mesg = wfill ["Missing rule for", showAttrDef field_ attr_ , "in alternative" , getName con_ , "of nonterminal",getName nt_ ,"." @@ -914,23 +894,24 @@ ,"by a copy rule, so you should add an appropriate rule." ] act = wfill ["The value of the attribute has been set to undefined."] - in ppError (isError _me) (getPos attr_) mesg pat help act _lhsIverbose + in ppError (isError _lhsIoptions _me) (getPos attr_) mesg pat help act _lhsIverbose -- self rule _me = MissingRule nt_ con_ field_ attr_ -- self rule _lhsOme = _me - in ( _lhsOme,_lhsOpp))) ) -sem_Error_MissingTypeSig :: Nonterminal -> - Constructor -> - Name -> + in ( _lhsOme,_lhsOpp)))) +sem_Error_MissingTypeSig :: NontermIdent -> + ConstructorIdent -> + Identifier -> T_Error -sem_Error_MissingTypeSig nt_ con_ attr_ = - (T_Error (\ _lhsIverbose -> +sem_Error_MissingTypeSig nt_ con_ attr_ = + (T_Error (\ _lhsIoptions + _lhsIverbose -> (let _lhsOpp :: PP_Doc _lhsOme :: Error - -- "PrintErrorMessages.ag"(line 381, column 21) + -- "PrintErrorMessages.ag"(line 388, column 21) _lhsOpp = let mesg = wfill ["Type signature needed, but not found for", showAttrDef _LOC attr_ , "in alternative" , getName con_ , "of nonterminal",getName nt_ ,"." @@ -944,46 +925,48 @@ ,"Please supply its type." ] act = wfill ["The type signatures of semantic functions are not generated."] - in ppError (isError _me) (getPos attr_) mesg pat help act _lhsIverbose + in ppError (isError _lhsIoptions _me) (getPos attr_) mesg pat help act _lhsIverbose -- self rule _me = MissingTypeSig nt_ con_ attr_ -- self rule _lhsOme = _me - in ( _lhsOme,_lhsOpp))) ) + in ( _lhsOme,_lhsOpp)))) sem_Error_ParserError :: Pos -> String -> String -> T_Error -sem_Error_ParserError pos_ problem_ action_ = - (T_Error (\ _lhsIverbose -> +sem_Error_ParserError pos_ problem_ action_ = + (T_Error (\ _lhsIoptions + _lhsIverbose -> (let _lhsOpp :: PP_Doc _lhsOme :: Error - -- "PrintErrorMessages.ag"(line 64, column 21) + -- "PrintErrorMessages.ag"(line 67, column 21) _lhsOpp = let mesg = text ("parser expecting " ++ problem_) pat = text "" help = text "" act = text action_ - in ppError (isError _me) pos_ mesg pat help act _lhsIverbose + in ppError (isError _lhsIoptions _me) pos_ mesg pat help act _lhsIverbose -- self rule _me = ParserError pos_ problem_ action_ -- self rule _lhsOme = _me - in ( _lhsOme,_lhsOpp))) ) -sem_Error_SuperfluousRule :: Nonterminal -> - Constructor -> - Name -> - Name -> + in ( _lhsOme,_lhsOpp)))) +sem_Error_SuperfluousRule :: NontermIdent -> + ConstructorIdent -> + Identifier -> + Identifier -> T_Error -sem_Error_SuperfluousRule nt_ con_ field_ attr_ = - (T_Error (\ _lhsIverbose -> +sem_Error_SuperfluousRule nt_ con_ field_ attr_ = + (T_Error (\ _lhsIoptions + _lhsIverbose -> (let _lhsOpp :: PP_Doc _lhsOme :: Error - -- "PrintErrorMessages.ag"(line 268, column 21) + -- "PrintErrorMessages.ag"(line 271, column 21) _lhsOpp = let mesg = wfill ["Rule for non-existing", showAttrDef field_ attr_ , "at alternative" , getName con_ , "of nonterminal",getName nt_, "." @@ -995,22 +978,23 @@ ,"Otherwise either remove the rule or add an appropriate attribute definition." ] act = wfill ["The rule has been ignored."] - in ppError (isError _me) (getPos attr_) mesg pat help act _lhsIverbose + in ppError (isError _lhsIoptions _me) (getPos attr_) mesg pat help act _lhsIverbose -- self rule _me = SuperfluousRule nt_ con_ field_ attr_ -- self rule _lhsOme = _me - in ( _lhsOme,_lhsOpp))) ) -sem_Error_UndefAlt :: Nonterminal -> - Constructor -> + in ( _lhsOme,_lhsOpp)))) +sem_Error_UndefAlt :: NontermIdent -> + ConstructorIdent -> T_Error -sem_Error_UndefAlt nt_ con_ = - (T_Error (\ _lhsIverbose -> +sem_Error_UndefAlt nt_ con_ = + (T_Error (\ _lhsIoptions + _lhsIverbose -> (let _lhsOpp :: PP_Doc _lhsOme :: Error - -- "PrintErrorMessages.ag"(line 228, column 21) + -- "PrintErrorMessages.ag"(line 231, column 21) _lhsOpp = let mesg = wfill ["Constructor", getName con_, "of nonterminal" ,getName nt_, "is not defined." ] @@ -1021,26 +1005,32 @@ ,"nonterminal" , getName nt_, ". Maybe you misspelled it? Otherwise insert a definition." ] act = wfill ["All rules for the unknown alternative have been ignored."] - in ppError (isError _me) (getPos con_) mesg pat help act _lhsIverbose + in ppError (isError _lhsIoptions _me) (getPos con_) mesg pat help act _lhsIverbose -- self rule _me = UndefAlt nt_ con_ -- self rule _lhsOme = _me - in ( _lhsOme,_lhsOpp))) ) -sem_Error_UndefAttr :: Nonterminal -> - Constructor -> - Name -> - Name -> + in ( _lhsOme,_lhsOpp)))) +sem_Error_UndefAttr :: NontermIdent -> + ConstructorIdent -> + Identifier -> + Identifier -> + Bool -> T_Error -sem_Error_UndefAttr nt_ con_ field_ attr_ = - (T_Error (\ _lhsIverbose -> +sem_Error_UndefAttr nt_ con_ field_ attr_ isOut_ = + (T_Error (\ _lhsIoptions + _lhsIverbose -> (let _lhsOpp :: PP_Doc _lhsOme :: Error - -- "PrintErrorMessages.ag"(line 311, column 21) + -- "PrintErrorMessages.ag"(line 314, column 21) _lhsOpp = - let mesg = wfill ["Undefined", showAttrUse field_ attr_, "at constructor" + let mesg = wfill ["Undefined" + , if isOut_ + then showAttrDef field_ attr_ + else showAttrUse field_ attr_ + , "at constructor" , getName con_ , "of nonterminal",getName nt_, "." ] pat = "SEM" >#< getName nt_ @@ -1052,23 +1042,24 @@ ,"Otherwise either remove the rule or add an appropriate attribute definition." ] act = wfill ["The generated program will not run."] - in ppError (isError _me) (getPos attr_) mesg pat help act _lhsIverbose + in ppError (isError _lhsIoptions _me) (getPos attr_) mesg pat help act _lhsIverbose -- self rule _me = - UndefAttr nt_ con_ field_ attr_ + UndefAttr nt_ con_ field_ attr_ isOut_ -- self rule _lhsOme = _me - in ( _lhsOme,_lhsOpp))) ) -sem_Error_UndefChild :: Nonterminal -> - Constructor -> - Name -> + in ( _lhsOme,_lhsOpp)))) +sem_Error_UndefChild :: NontermIdent -> + ConstructorIdent -> + Identifier -> T_Error -sem_Error_UndefChild nt_ con_ name_ = - (T_Error (\ _lhsIverbose -> +sem_Error_UndefChild nt_ con_ name_ = + (T_Error (\ _lhsIoptions + _lhsIverbose -> (let _lhsOpp :: PP_Doc _lhsOme :: Error - -- "PrintErrorMessages.ag"(line 240, column 21) + -- "PrintErrorMessages.ag"(line 243, column 21) _lhsOpp = let mesg = wfill ["Constructor", getName con_, "of nonterminal" ,getName nt_ , "does not have a nontrivial field named", getName name_ , "." @@ -1082,23 +1073,24 @@ ,"or change its type from an HS-type to an AG-type." ] act = wfill ["All rules for the unknown field have been ignored."] - in ppError (isError _me) (getPos name_) mesg pat help act _lhsIverbose + in ppError (isError _lhsIoptions _me) (getPos name_) mesg pat help act _lhsIverbose -- self rule _me = UndefChild nt_ con_ name_ -- self rule _lhsOme = _me - in ( _lhsOme,_lhsOpp))) ) -sem_Error_UndefLocal :: Nonterminal -> - Constructor -> - Name -> + in ( _lhsOme,_lhsOpp)))) +sem_Error_UndefLocal :: NontermIdent -> + ConstructorIdent -> + Identifier -> T_Error -sem_Error_UndefLocal nt_ con_ var_ = - (T_Error (\ _lhsIverbose -> +sem_Error_UndefLocal nt_ con_ var_ = + (T_Error (\ _lhsIoptions + _lhsIverbose -> (let _lhsOpp :: PP_Doc _lhsOme :: Error - -- "PrintErrorMessages.ag"(line 282, column 21) + -- "PrintErrorMessages.ag"(line 285, column 21) _lhsOpp = let mesg = wfill ["Undefined local variable or field",getName var_, "at constructor" , getName con_ , "of nonterminal",getName nt_, "." @@ -1107,26 +1099,27 @@ >-< indent 2 ("|" >#< getName con_ >#< ". = " >#< "..." >#< "@" >|< getName var_ >#< "..." ) help = wfill ["A rule in the definitions for alternative" , getName con_ ,"of nonterminal" - , getName nt_ , "contains a local variable or field name that is not defined" + , getName nt_ , "contains a local variable or field name that is not defined. " ,"Maybe you misspelled it?" ,"Otherwise either remove the rule or add an appropriate definition." ] act = wfill ["The generated program will not run."] - in ppError (isError _me) (getPos var_) mesg pat help act _lhsIverbose + in ppError (isError _lhsIoptions _me) (getPos var_) mesg pat help act _lhsIverbose -- self rule _me = UndefLocal nt_ con_ var_ -- self rule _lhsOme = _me - in ( _lhsOme,_lhsOpp))) ) -sem_Error_UndefNont :: Nonterminal -> + in ( _lhsOme,_lhsOpp)))) +sem_Error_UndefNont :: NontermIdent -> T_Error -sem_Error_UndefNont nt_ = - (T_Error (\ _lhsIverbose -> +sem_Error_UndefNont nt_ = + (T_Error (\ _lhsIoptions + _lhsIverbose -> (let _lhsOpp :: PP_Doc _lhsOme :: Error - -- "PrintErrorMessages.ag"(line 218, column 21) + -- "PrintErrorMessages.ag"(line 221, column 21) _lhsOpp = let mesg = wfill ["Nonterminal", getName nt_, "is not defined." ] @@ -1135,14 +1128,14 @@ , "for" ,getName nt_, ". Maybe you misspelled it? Otherwise insert a definition." ] act = wfill ["Everything regarding the unknown nonterminal has been ignored."] - in ppError (isError _me) (getPos nt_) mesg pat help act _lhsIverbose + in ppError (isError _lhsIoptions _me) (getPos nt_) mesg pat help act _lhsIverbose -- self rule _me = UndefNont nt_ -- self rule _lhsOme = _me - in ( _lhsOme,_lhsOpp))) ) + in ( _lhsOme,_lhsOpp)))) -- Errors ------------------------------------------------------ {- visit 0: @@ -1163,34 +1156,38 @@ -- cata sem_Errors :: Errors -> T_Errors -sem_Errors list = - (Prelude.foldr sem_Errors_Cons sem_Errors_Nil (Prelude.map sem_Error list) ) +sem_Errors list = + (Prelude.foldr sem_Errors_Cons sem_Errors_Nil (Prelude.map sem_Error list)) -- semantic domain newtype T_Errors = T_Errors (Options -> ( PP_Doc)) data Inh_Errors = Inh_Errors {options_Inh_Errors :: Options} data Syn_Errors = Syn_Errors {pp_Syn_Errors :: PP_Doc} -wrap_Errors (T_Errors sem ) (Inh_Errors _lhsIoptions ) = +wrap_Errors (T_Errors sem) (Inh_Errors _lhsIoptions) = (let ( _lhsOpp) = - (sem _lhsIoptions ) - in (Syn_Errors _lhsOpp )) + (sem _lhsIoptions) + in (Syn_Errors _lhsOpp)) sem_Errors_Cons :: T_Error -> T_Errors -> T_Errors -sem_Errors_Cons (T_Error hd_ ) (T_Errors tl_ ) = +sem_Errors_Cons (T_Error hd_) (T_Errors tl_) = (T_Errors (\ _lhsIoptions -> (let _lhsOpp :: PP_Doc + _hdOoptions :: Options _hdOverbose :: Bool _tlOoptions :: Options _hdIme :: Error _hdIpp :: PP_Doc _tlIpp :: PP_Doc - -- "PrintErrorMessages.ag"(line 59, column 8) + -- "PrintErrorMessages.ag"(line 62, column 8) _verbose = verbose _lhsIoptions - -- use rule "PrintErrorMessages.ag"(line 55, column 49) + -- use rule "PrintErrorMessages.ag"(line 58, column 49) _lhsOpp = _hdIpp >-< _tlIpp + -- copy rule (down) + _hdOoptions = + _lhsIoptions -- copy rule (from local) _hdOverbose = _verbose @@ -1198,18 +1195,18 @@ _tlOoptions = _lhsIoptions ( _hdIme,_hdIpp) = - (hd_ _hdOverbose ) + (hd_ _hdOoptions _hdOverbose) ( _tlIpp) = - (tl_ _tlOoptions ) - in ( _lhsOpp))) ) + (tl_ _tlOoptions) + in ( _lhsOpp)))) sem_Errors_Nil :: T_Errors sem_Errors_Nil = (T_Errors (\ _lhsIoptions -> (let _lhsOpp :: PP_Doc - -- "PrintErrorMessages.ag"(line 59, column 8) + -- "PrintErrorMessages.ag"(line 62, column 8) _verbose = verbose _lhsIoptions - -- use rule "PrintErrorMessages.ag"(line 55, column 49) + -- use rule "PrintErrorMessages.ag"(line 58, column 49) _lhsOpp = text "" - in ( _lhsOpp))) ) + in ( _lhsOpp)))) diff --git a/src-derived/SemHsTokens.hs b/src-derived/SemHsTokens.hs --- a/src-derived/SemHsTokens.hs +++ b/src-derived/SemHsTokens.hs @@ -11,14 +11,14 @@ import CommonTypes import UU.Scanner.Position(Pos) -isNTname allnts (Just (NT nt)) = nt `elem` allnts -isNTname allnts _ = False +isNTname allnts (Just (NT nt _)) = nt `elem` allnts +isNTname allnts _ = False -- HsToken ----------------------------------------------------- {- visit 0: inherited attributes: - allfields : [(Name,Type,Bool)] - allnts : [Name] + allfields : [(Identifier,Type,Bool)] + allnts : [Identifier] attrs : [(Identifier,Identifier)] con : Identifier fieldnames : [Identifier] @@ -31,12 +31,16 @@ usedLocals : [Identifier] alternatives: alternative AGField: - child field : {Name} - child attr : {Name} + child field : {Identifier} + child attr : {Identifier} child pos : {Pos} + child rdesc : {Maybe String} + visit 0: + local addTrace : _ alternative AGLocal: - child var : {Name} + child var : {Identifier} child pos : {Pos} + child rdesc : {Maybe String} visit 0: local _tup1 : _ local errors : _ @@ -58,10 +62,10 @@ -- cata sem_HsToken :: HsToken -> T_HsToken -sem_HsToken (AGField _field _attr _pos) = - (sem_HsToken_AGField _field _attr _pos) -sem_HsToken (AGLocal _var _pos) = - (sem_HsToken_AGLocal _var _pos) +sem_HsToken (AGField _field _attr _pos _rdesc) = + (sem_HsToken_AGField _field _attr _pos _rdesc) +sem_HsToken (AGLocal _var _pos _rdesc) = + (sem_HsToken_AGLocal _var _pos _rdesc) sem_HsToken (CharToken _value _pos) = (sem_HsToken_CharToken _value _pos) sem_HsToken (Err _mesg _pos) = @@ -71,24 +75,25 @@ sem_HsToken (StrToken _value _pos) = (sem_HsToken_StrToken _value _pos) -- semantic domain -newtype T_HsToken = T_HsToken (([(Name,Type,Bool)]) -> - ([Name]) -> +newtype T_HsToken = T_HsToken (([(Identifier,Type,Bool)]) -> + ([Identifier]) -> ([(Identifier,Identifier)]) -> Identifier -> ([Identifier]) -> Identifier -> ( (Seq Error),((Pos,String)),([(Identifier,Identifier)]),(Seq Identifier),([Identifier]))) -data Inh_HsToken = Inh_HsToken {allfields_Inh_HsToken :: [(Name,Type,Bool)],allnts_Inh_HsToken :: [Name],attrs_Inh_HsToken :: [(Identifier,Identifier)],con_Inh_HsToken :: Identifier,fieldnames_Inh_HsToken :: [Identifier],nt_Inh_HsToken :: Identifier} +data Inh_HsToken = Inh_HsToken {allfields_Inh_HsToken :: [(Identifier,Type,Bool)],allnts_Inh_HsToken :: [Identifier],attrs_Inh_HsToken :: [(Identifier,Identifier)],con_Inh_HsToken :: Identifier,fieldnames_Inh_HsToken :: [Identifier],nt_Inh_HsToken :: Identifier} data Syn_HsToken = Syn_HsToken {errors_Syn_HsToken :: Seq Error,tok_Syn_HsToken :: (Pos,String),usedAttrs_Syn_HsToken :: [(Identifier,Identifier)],usedFields_Syn_HsToken :: Seq Identifier,usedLocals_Syn_HsToken :: [Identifier]} wrap_HsToken (T_HsToken sem) (Inh_HsToken _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIfieldnames _lhsInt) = (let ( _lhsOerrors,_lhsOtok,_lhsOusedAttrs,_lhsOusedFields,_lhsOusedLocals) = (sem _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIfieldnames _lhsInt) in (Syn_HsToken _lhsOerrors _lhsOtok _lhsOusedAttrs _lhsOusedFields _lhsOusedLocals)) -sem_HsToken_AGField :: Name -> - Name -> +sem_HsToken_AGField :: Identifier -> + Identifier -> Pos -> + (Maybe String) -> T_HsToken -sem_HsToken_AGField field_ attr_ pos_ = +sem_HsToken_AGField field_ attr_ pos_ rdesc_ = (T_HsToken (\ _lhsIallfields _lhsIallnts _lhsIattrs @@ -100,30 +105,36 @@ _lhsOtok :: ((Pos,String)) _lhsOusedFields :: (Seq Identifier) _lhsOusedLocals :: ([Identifier]) - -- "SemHsTokens.ag"(line 73, column 15) + -- "SemHsTokens.ag"(line 72, column 15) _lhsOerrors = if (field_,attr_) `elem` _lhsIattrs then Seq.empty else if not(field_ `elem` (_LHS : _LOC: _lhsIfieldnames)) then Seq.single (UndefChild _lhsInt _lhsIcon field_) - else Seq.single (UndefAttr _lhsInt _lhsIcon field_ attr_) - -- "SemHsTokens.ag"(line 87, column 13) + else Seq.single (UndefAttr _lhsInt _lhsIcon field_ attr_ False) + -- "SemHsTokens.ag"(line 86, column 13) _lhsOusedAttrs = [(field_,attr_)] - -- "SemHsTokens.ag"(line 113, column 14) + -- "SemHsTokens.ag"(line 113, column 8) + _addTrace = + case rdesc_ of + Just d -> \x -> "(trace " ++ show (d ++ " -> " ++ show field_ ++ "." ++ show attr_) ++ " (" ++ x ++ "))" + Nothing -> id + -- "SemHsTokens.ag"(line 116, column 8) _lhsOtok = - (pos_, attrname True field_ attr_) - -- use rule "SemHsTokens.ag"(line 92, column 40) + (pos_, _addTrace $ attrname True field_ attr_) + -- use rule "SemHsTokens.ag"(line 91, column 40) _lhsOusedFields = Seq.empty - -- use rule "SemHsTokens.ag"(line 83, column 40) + -- use rule "SemHsTokens.ag"(line 82, column 40) _lhsOusedLocals = [] in ( _lhsOerrors,_lhsOtok,_lhsOusedAttrs,_lhsOusedFields,_lhsOusedLocals)))) -sem_HsToken_AGLocal :: Name -> +sem_HsToken_AGLocal :: Identifier -> Pos -> + (Maybe String) -> T_HsToken -sem_HsToken_AGLocal var_ pos_ = +sem_HsToken_AGLocal var_ pos_ rdesc_ = (T_HsToken (\ _lhsIallfields _lhsIallnts _lhsIattrs @@ -135,7 +146,7 @@ _lhsOusedAttrs :: ([(Identifier,Identifier)]) _lhsOusedLocals :: ([Identifier]) _lhsOtok :: ((Pos,String)) - -- "SemHsTokens.ag"(line 63, column 19) + -- "SemHsTokens.ag"(line 62, column 19) __tup1 = if var_ `elem` _lhsIfieldnames then if isNTname _lhsIallnts (lookup var_ (map (\(n,t,_) -> (n,t)) _lhsIallfields)) @@ -144,27 +155,27 @@ else if (_LOC,var_) `elem` _lhsIattrs then (Seq.empty , (pos_,locname var_), [var_]) else (Seq.single(UndefLocal _lhsInt _lhsIcon var_), (pos_,locname var_), [] ) - -- "SemHsTokens.ag"(line 63, column 19) + -- "SemHsTokens.ag"(line 62, column 19) (_errors,_,_) = __tup1 - -- "SemHsTokens.ag"(line 63, column 19) + -- "SemHsTokens.ag"(line 62, column 19) (_,_tok,_) = __tup1 - -- "SemHsTokens.ag"(line 63, column 19) + -- "SemHsTokens.ag"(line 62, column 19) (_,_,_usedLocals) = __tup1 - -- "SemHsTokens.ag"(line 95, column 13) + -- "SemHsTokens.ag"(line 94, column 13) _lhsOusedFields = if var_ `elem` _lhsIfieldnames then Seq.single var_ else Seq.empty - -- use rule "SemHsTokens.ag"(line 42, column 37) + -- use rule "SemHsTokens.ag"(line 41, column 37) _lhsOerrors = _errors - -- use rule "SemHsTokens.ag"(line 84, column 40) + -- use rule "SemHsTokens.ag"(line 83, column 40) _lhsOusedAttrs = [] - -- use rule "SemHsTokens.ag"(line 83, column 40) + -- use rule "SemHsTokens.ag"(line 82, column 40) _lhsOusedLocals = _usedLocals -- copy rule (from local) @@ -186,22 +197,22 @@ _lhsOusedAttrs :: ([(Identifier,Identifier)]) _lhsOusedFields :: (Seq Identifier) _lhsOusedLocals :: ([Identifier]) - -- "SemHsTokens.ag"(line 117, column 16) + -- "SemHsTokens.ag"(line 120, column 16) _lhsOtok = (pos_, if null value_ then "" else showCharShort (head value_) ) - -- use rule "SemHsTokens.ag"(line 42, column 37) + -- use rule "SemHsTokens.ag"(line 41, column 37) _lhsOerrors = Seq.empty - -- use rule "SemHsTokens.ag"(line 84, column 40) + -- use rule "SemHsTokens.ag"(line 83, column 40) _lhsOusedAttrs = [] - -- use rule "SemHsTokens.ag"(line 92, column 40) + -- use rule "SemHsTokens.ag"(line 91, column 40) _lhsOusedFields = Seq.empty - -- use rule "SemHsTokens.ag"(line 83, column 40) + -- use rule "SemHsTokens.ag"(line 82, column 40) _lhsOusedLocals = [] in ( _lhsOerrors,_lhsOtok,_lhsOusedAttrs,_lhsOusedFields,_lhsOusedLocals)))) @@ -220,20 +231,20 @@ _lhsOusedAttrs :: ([(Identifier,Identifier)]) _lhsOusedFields :: (Seq Identifier) _lhsOusedLocals :: ([Identifier]) - -- "SemHsTokens.ag"(line 49, column 9) + -- "SemHsTokens.ag"(line 48, column 9) _lhsOerrors = let m = text mesg_ in Seq.single (CustomError False pos_ m) - -- "SemHsTokens.ag"(line 123, column 16) + -- "SemHsTokens.ag"(line 126, column 16) _lhsOtok = (pos_, "") - -- use rule "SemHsTokens.ag"(line 84, column 40) + -- use rule "SemHsTokens.ag"(line 83, column 40) _lhsOusedAttrs = [] - -- use rule "SemHsTokens.ag"(line 92, column 40) + -- use rule "SemHsTokens.ag"(line 91, column 40) _lhsOusedFields = Seq.empty - -- use rule "SemHsTokens.ag"(line 83, column 40) + -- use rule "SemHsTokens.ag"(line 82, column 40) _lhsOusedLocals = [] in ( _lhsOerrors,_lhsOtok,_lhsOusedAttrs,_lhsOusedFields,_lhsOusedLocals)))) @@ -252,19 +263,19 @@ _lhsOusedAttrs :: ([(Identifier,Identifier)]) _lhsOusedFields :: (Seq Identifier) _lhsOusedLocals :: ([Identifier]) - -- "SemHsTokens.ag"(line 115, column 14) + -- "SemHsTokens.ag"(line 118, column 14) _lhsOtok = (pos_, value_) - -- use rule "SemHsTokens.ag"(line 42, column 37) + -- use rule "SemHsTokens.ag"(line 41, column 37) _lhsOerrors = Seq.empty - -- use rule "SemHsTokens.ag"(line 84, column 40) + -- use rule "SemHsTokens.ag"(line 83, column 40) _lhsOusedAttrs = [] - -- use rule "SemHsTokens.ag"(line 92, column 40) + -- use rule "SemHsTokens.ag"(line 91, column 40) _lhsOusedFields = Seq.empty - -- use rule "SemHsTokens.ag"(line 83, column 40) + -- use rule "SemHsTokens.ag"(line 82, column 40) _lhsOusedLocals = [] in ( _lhsOerrors,_lhsOtok,_lhsOusedAttrs,_lhsOusedFields,_lhsOusedLocals)))) @@ -283,19 +294,19 @@ _lhsOusedAttrs :: ([(Identifier,Identifier)]) _lhsOusedFields :: (Seq Identifier) _lhsOusedLocals :: ([Identifier]) - -- "SemHsTokens.ag"(line 122, column 16) + -- "SemHsTokens.ag"(line 125, column 16) _lhsOtok = (pos_, showStrShort value_) - -- use rule "SemHsTokens.ag"(line 42, column 37) + -- use rule "SemHsTokens.ag"(line 41, column 37) _lhsOerrors = Seq.empty - -- use rule "SemHsTokens.ag"(line 84, column 40) + -- use rule "SemHsTokens.ag"(line 83, column 40) _lhsOusedAttrs = [] - -- use rule "SemHsTokens.ag"(line 92, column 40) + -- use rule "SemHsTokens.ag"(line 91, column 40) _lhsOusedFields = Seq.empty - -- use rule "SemHsTokens.ag"(line 83, column 40) + -- use rule "SemHsTokens.ag"(line 82, column 40) _lhsOusedLocals = [] in ( _lhsOerrors,_lhsOtok,_lhsOusedAttrs,_lhsOusedFields,_lhsOusedLocals)))) @@ -303,8 +314,8 @@ {- visit 0: inherited attributes: - allfields : [(Name,Type,Bool)] - allnts : [Name] + allfields : [(Identifier,Type,Bool)] + allnts : [Identifier] attrs : [(Identifier,Identifier)] con : Identifier fieldnames : [Identifier] @@ -327,14 +338,14 @@ sem_HsTokens list = (Prelude.foldr sem_HsTokens_Cons sem_HsTokens_Nil (Prelude.map sem_HsToken list)) -- semantic domain -newtype T_HsTokens = T_HsTokens (([(Name,Type,Bool)]) -> - ([Name]) -> +newtype T_HsTokens = T_HsTokens (([(Identifier,Type,Bool)]) -> + ([Identifier]) -> ([(Identifier,Identifier)]) -> Identifier -> ([Identifier]) -> Identifier -> ( (Seq Error),([(Pos,String)]),([(Identifier,Identifier)]),(Seq Identifier),([Identifier]))) -data Inh_HsTokens = Inh_HsTokens {allfields_Inh_HsTokens :: [(Name,Type,Bool)],allnts_Inh_HsTokens :: [Name],attrs_Inh_HsTokens :: [(Identifier,Identifier)],con_Inh_HsTokens :: Identifier,fieldnames_Inh_HsTokens :: [Identifier],nt_Inh_HsTokens :: Identifier} +data Inh_HsTokens = Inh_HsTokens {allfields_Inh_HsTokens :: [(Identifier,Type,Bool)],allnts_Inh_HsTokens :: [Identifier],attrs_Inh_HsTokens :: [(Identifier,Identifier)],con_Inh_HsTokens :: Identifier,fieldnames_Inh_HsTokens :: [Identifier],nt_Inh_HsTokens :: Identifier} data Syn_HsTokens = Syn_HsTokens {errors_Syn_HsTokens :: Seq Error,tks_Syn_HsTokens :: [(Pos,String)],usedAttrs_Syn_HsTokens :: [(Identifier,Identifier)],usedFields_Syn_HsTokens :: Seq Identifier,usedLocals_Syn_HsTokens :: [Identifier]} wrap_HsTokens (T_HsTokens sem) (Inh_HsTokens _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIfieldnames _lhsInt) = (let ( _lhsOerrors,_lhsOtks,_lhsOusedAttrs,_lhsOusedFields,_lhsOusedLocals) = @@ -355,14 +366,14 @@ _lhsOusedAttrs :: ([(Identifier,Identifier)]) _lhsOusedFields :: (Seq Identifier) _lhsOusedLocals :: ([Identifier]) - _hdOallfields :: ([(Name,Type,Bool)]) - _hdOallnts :: ([Name]) + _hdOallfields :: ([(Identifier,Type,Bool)]) + _hdOallnts :: ([Identifier]) _hdOattrs :: ([(Identifier,Identifier)]) _hdOcon :: Identifier _hdOfieldnames :: ([Identifier]) _hdOnt :: Identifier - _tlOallfields :: ([(Name,Type,Bool)]) - _tlOallnts :: ([Name]) + _tlOallfields :: ([(Identifier,Type,Bool)]) + _tlOallnts :: ([Identifier]) _tlOattrs :: ([(Identifier,Identifier)]) _tlOcon :: Identifier _tlOfieldnames :: ([Identifier]) @@ -377,19 +388,19 @@ _tlIusedAttrs :: ([(Identifier,Identifier)]) _tlIusedFields :: (Seq Identifier) _tlIusedLocals :: ([Identifier]) - -- "SemHsTokens.ag"(line 109, column 10) + -- "SemHsTokens.ag"(line 108, column 10) _lhsOtks = _hdItok : _tlItks - -- use rule "SemHsTokens.ag"(line 42, column 37) + -- use rule "SemHsTokens.ag"(line 41, column 37) _lhsOerrors = _hdIerrors Seq.<> _tlIerrors - -- use rule "SemHsTokens.ag"(line 84, column 40) + -- use rule "SemHsTokens.ag"(line 83, column 40) _lhsOusedAttrs = _hdIusedAttrs ++ _tlIusedAttrs - -- use rule "SemHsTokens.ag"(line 92, column 40) + -- use rule "SemHsTokens.ag"(line 91, column 40) _lhsOusedFields = _hdIusedFields Seq.<> _tlIusedFields - -- use rule "SemHsTokens.ag"(line 83, column 40) + -- use rule "SemHsTokens.ag"(line 82, column 40) _lhsOusedLocals = _hdIusedLocals ++ _tlIusedLocals -- copy rule (down) @@ -446,19 +457,19 @@ _lhsOusedAttrs :: ([(Identifier,Identifier)]) _lhsOusedFields :: (Seq Identifier) _lhsOusedLocals :: ([Identifier]) - -- "SemHsTokens.ag"(line 110, column 10) + -- "SemHsTokens.ag"(line 109, column 10) _lhsOtks = [] - -- use rule "SemHsTokens.ag"(line 42, column 37) + -- use rule "SemHsTokens.ag"(line 41, column 37) _lhsOerrors = Seq.empty - -- use rule "SemHsTokens.ag"(line 84, column 40) + -- use rule "SemHsTokens.ag"(line 83, column 40) _lhsOusedAttrs = [] - -- use rule "SemHsTokens.ag"(line 92, column 40) + -- use rule "SemHsTokens.ag"(line 91, column 40) _lhsOusedFields = Seq.empty - -- use rule "SemHsTokens.ag"(line 83, column 40) + -- use rule "SemHsTokens.ag"(line 82, column 40) _lhsOusedLocals = [] in ( _lhsOerrors,_lhsOtks,_lhsOusedAttrs,_lhsOusedFields,_lhsOusedLocals)))) @@ -466,8 +477,8 @@ {- visit 0: inherited attributes: - allfields : [(Name,Type,Bool)] - allnts : [Name] + allfields : [(Identifier,Type,Bool)] + allnts : [Identifier] attrs : [(Identifier,Identifier)] con : Identifier nt : Identifier @@ -487,13 +498,13 @@ sem_HsTokensRoot (HsTokensRoot _tokens) = (sem_HsTokensRoot_HsTokensRoot (sem_HsTokens _tokens)) -- semantic domain -newtype T_HsTokensRoot = T_HsTokensRoot (([(Name,Type,Bool)]) -> - ([Name]) -> +newtype T_HsTokensRoot = T_HsTokensRoot (([(Identifier,Type,Bool)]) -> + ([Identifier]) -> ([(Identifier,Identifier)]) -> Identifier -> Identifier -> ( (Seq Error),([String]),([(Identifier,Identifier)]),([Identifier]),([Identifier]))) -data Inh_HsTokensRoot = Inh_HsTokensRoot {allfields_Inh_HsTokensRoot :: [(Name,Type,Bool)],allnts_Inh_HsTokensRoot :: [Name],attrs_Inh_HsTokensRoot :: [(Identifier,Identifier)],con_Inh_HsTokensRoot :: Identifier,nt_Inh_HsTokensRoot :: Identifier} +data Inh_HsTokensRoot = Inh_HsTokensRoot {allfields_Inh_HsTokensRoot :: [(Identifier,Type,Bool)],allnts_Inh_HsTokensRoot :: [Identifier],attrs_Inh_HsTokensRoot :: [(Identifier,Identifier)],con_Inh_HsTokensRoot :: Identifier,nt_Inh_HsTokensRoot :: Identifier} data Syn_HsTokensRoot = Syn_HsTokensRoot {errors_Syn_HsTokensRoot :: Seq Error,textLines_Syn_HsTokensRoot :: [String],usedAttrs_Syn_HsTokensRoot :: [(Identifier,Identifier)],usedFields_Syn_HsTokensRoot :: [Identifier],usedLocals_Syn_HsTokensRoot :: [Identifier]} wrap_HsTokensRoot (T_HsTokensRoot sem) (Inh_HsTokensRoot _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsInt) = (let ( _lhsOerrors,_lhsOtextLines,_lhsOusedAttrs,_lhsOusedFields,_lhsOusedLocals) = @@ -513,8 +524,8 @@ _lhsOerrors :: (Seq Error) _lhsOusedAttrs :: ([(Identifier,Identifier)]) _lhsOusedLocals :: ([Identifier]) - _tokensOallfields :: ([(Name,Type,Bool)]) - _tokensOallnts :: ([Name]) + _tokensOallfields :: ([(Identifier,Type,Bool)]) + _tokensOallnts :: ([Identifier]) _tokensOattrs :: ([(Identifier,Identifier)]) _tokensOcon :: Identifier _tokensOnt :: Identifier @@ -523,13 +534,13 @@ _tokensIusedAttrs :: ([(Identifier,Identifier)]) _tokensIusedFields :: (Seq Identifier) _tokensIusedLocals :: ([Identifier]) - -- "SemHsTokens.ag"(line 37, column 18) + -- "SemHsTokens.ag"(line 36, column 18) _tokensOfieldnames = map (\(n,_,_) -> n) _lhsIallfields - -- "SemHsTokens.ag"(line 99, column 18) + -- "SemHsTokens.ag"(line 98, column 18) _lhsOusedFields = Seq.toList _tokensIusedFields - -- "SemHsTokens.ag"(line 106, column 18) + -- "SemHsTokens.ag"(line 105, column 18) _lhsOtextLines = showTokens _tokensItks -- use rule "SemHsTokens.ag"(line 16, column 18) diff --git a/src-derived/TfmToVisage.hs b/src-derived/TfmToVisage.hs new file mode 100644 --- /dev/null +++ b/src-derived/TfmToVisage.hs @@ -0,0 +1,926 @@ +-- UUAGC 0.9.5 (TfmToVisage.ag) +module TfmToVisage where + +import AbstractSyntax +import VisagePatterns +import VisageSyntax + +-- AbstractSyntax.ag imports +import Data.Set(Set) +import Data.Map(Map) +import Patterns (Pattern(..),Patterns) +import Expression (Expression(..)) +import CommonTypes + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (ConstructorIdent,Identifier) + +import UU.Scanner.Position(Pos) +import HsToken + +-- Maps a rule to a pair +-- Later, I expect to map to a list of rules, because we might need to unfold. + + +-- Checks that a certain alias is in fact a Var in the old representation of the AG system +isVar (Alias _ _ (Underscore _) _) = True +isVar _ = False + +type VisageRuleMap = [(String, VisageRule)] + +splitVRules :: [VisageRule] -> VisageRuleMap +splitVRules vrs = concat (map unfoldvrs vrs) + +unfoldvrs :: VisageRule -> VisageRuleMap +unfoldvrs vr@(VRule attrfields _ _ _ _) = zip (map (getName . fst) attrfields) (map (copyRule vr) attrfields) + +copyRule :: VisageRule -> (Identifier,Identifier) -> VisageRule +copyRule (VRule attrfields _ pat expr owrt) (field,attr) = VRule attrfields attr pat expr owrt + +getForField :: String -> VisageRuleMap -> [VisageRule] +getForField field xs = map snd (filter ((field ==) . fst) xs) + +{- + Delivers a map from fieldname to VisageRule with all references to others underscored. + So, (lhs.x, rt.y, loc.z) = (0,1,2) becomes something like + [("lhs", (lhs.x,_,_) = (0,1,2) + + At this point, we do not use this anymore. + +allways :: VisageRule -> VisageRuleMap +allways vr@(VRule vrfields _ _ _ _) = zip vrfields (map (underScoreRule vr) (nub vrfields)) + +splitVRules :: [VisageRule] -> VisageRuleMap +splitVRules vrs = concat (map allways vrs) + +underScoreRule :: VisageRule -> String -> VisageRule +underScoreRule (VRule fields pat expr owrt rule) s = VRule fields (underScore s pat) expr owrt rule + +underScore :: String -> VisagePattern -> VisagePattern +underScore field (VConstr name pats) = VConstr name (map (underScore field) pats) +underScore field (VProduct pos pats) = VProduct pos (map (underScore field) pats) +underScore field vp@(VVar vfield attr) = + if (field == getName vfield) + then vp + else (VUnderscore (getPos vfield)) +-- Should I recurse into the pat of VAlias? +underScore field vp@(VAlias afield attr pat) = + if (field == getName afield) + then vp + else (VUnderscore (getPos afield)) +underScore field vp@(VUnderscore pos) = vp + +-} +-- Child ------------------------------------------------------- +{- + visit 0: + inherited attribute: + rulemap : VisageRuleMap + synthesized attribute: + vchild : VisageChild + alternatives: + alternative Child: + child name : {Identifier} + child tp : {Type} + child inh : {Attributes} + child syn : {Attributes} + child higherOrder : {Bool} +-} +-- cata +sem_Child :: Child -> + T_Child +sem_Child (Child _name _tp _inh _syn _higherOrder) = + (sem_Child_Child _name _tp _inh _syn _higherOrder) +-- semantic domain +newtype T_Child = T_Child (VisageRuleMap -> + ( VisageChild)) +data Inh_Child = Inh_Child {rulemap_Inh_Child :: VisageRuleMap} +data Syn_Child = Syn_Child {vchild_Syn_Child :: VisageChild} +wrap_Child (T_Child sem) (Inh_Child _lhsIrulemap) = + (let ( _lhsOvchild) = + (sem _lhsIrulemap) + in (Syn_Child _lhsOvchild)) +sem_Child_Child :: Identifier -> + Type -> + Attributes -> + Attributes -> + Bool -> + T_Child +sem_Child_Child name_ tp_ inh_ syn_ higherOrder_ = + (T_Child (\ _lhsIrulemap -> + (let _lhsOvchild :: VisageChild + -- "TfmToVisage.ag"(line 111, column 11) + _lhsOvchild = + VChild name_ tp_ inh_ syn_ (getForField (getName name_) _lhsIrulemap) + in ( _lhsOvchild)))) +-- Children ---------------------------------------------------- +{- + visit 0: + inherited attribute: + rulemap : VisageRuleMap + synthesized attribute: + vchildren : [VisageChild] + alternatives: + alternative Cons: + child hd : Child + child tl : Children + alternative Nil: +-} +-- cata +sem_Children :: Children -> + T_Children +sem_Children list = + (Prelude.foldr sem_Children_Cons sem_Children_Nil (Prelude.map sem_Child list)) +-- semantic domain +newtype T_Children = T_Children (VisageRuleMap -> + ( ([VisageChild]))) +data Inh_Children = Inh_Children {rulemap_Inh_Children :: VisageRuleMap} +data Syn_Children = Syn_Children {vchildren_Syn_Children :: [VisageChild]} +wrap_Children (T_Children sem) (Inh_Children _lhsIrulemap) = + (let ( _lhsOvchildren) = + (sem _lhsIrulemap) + in (Syn_Children _lhsOvchildren)) +sem_Children_Cons :: T_Child -> + T_Children -> + T_Children +sem_Children_Cons (T_Child hd_) (T_Children tl_) = + (T_Children (\ _lhsIrulemap -> + (let _lhsOvchildren :: ([VisageChild]) + _hdOrulemap :: VisageRuleMap + _tlOrulemap :: VisageRuleMap + _hdIvchild :: VisageChild + _tlIvchildren :: ([VisageChild]) + -- "TfmToVisage.ag"(line 107, column 17) + _lhsOvchildren = + _hdIvchild : _tlIvchildren + -- copy rule (down) + _hdOrulemap = + _lhsIrulemap + -- copy rule (down) + _tlOrulemap = + _lhsIrulemap + ( _hdIvchild) = + (hd_ _hdOrulemap) + ( _tlIvchildren) = + (tl_ _tlOrulemap) + in ( _lhsOvchildren)))) +sem_Children_Nil :: T_Children +sem_Children_Nil = + (T_Children (\ _lhsIrulemap -> + (let _lhsOvchildren :: ([VisageChild]) + -- "TfmToVisage.ag"(line 108, column 17) + _lhsOvchildren = + [] + in ( _lhsOvchildren)))) +-- Expression -------------------------------------------------- +{- + visit 0: + synthesized attribute: + self : SELF + alternatives: + alternative Expression: + child pos : {Pos} + child tks : {[HsToken]} + visit 0: + local self : _ +-} +-- cata +sem_Expression :: Expression -> + T_Expression +sem_Expression (Expression _pos _tks) = + (sem_Expression_Expression _pos _tks) +-- semantic domain +newtype T_Expression = T_Expression (( Expression)) +data Inh_Expression = Inh_Expression {} +data Syn_Expression = Syn_Expression {self_Syn_Expression :: Expression} +wrap_Expression (T_Expression sem) (Inh_Expression ) = + (let ( _lhsOself) = + (sem ) + in (Syn_Expression _lhsOself)) +sem_Expression_Expression :: Pos -> + ([HsToken]) -> + T_Expression +sem_Expression_Expression pos_ tks_ = + (T_Expression (let _lhsOself :: Expression + -- self rule + _self = + Expression pos_ tks_ + -- self rule + _lhsOself = + _self + in ( _lhsOself))) +-- Grammar ----------------------------------------------------- +{- + visit 0: + synthesized attribute: + visage : VisageGrammar + alternatives: + alternative Grammar: + child typeSyns : {TypeSyns} + child useMap : {UseMap} + child derivings : {Derivings} + child wrappers : {Set NontermIdent} + child nonts : Nonterminals + child pragmas : {PragmaMap} + child manualAttrOrderMap : {AttrOrderMap} + child paramMap : {ParamMap} + child contextMap : {ContextMap} +-} +-- cata +sem_Grammar :: Grammar -> + T_Grammar +sem_Grammar (Grammar _typeSyns _useMap _derivings _wrappers _nonts _pragmas _manualAttrOrderMap _paramMap _contextMap) = + (sem_Grammar_Grammar _typeSyns _useMap _derivings _wrappers (sem_Nonterminals _nonts) _pragmas _manualAttrOrderMap _paramMap _contextMap) +-- semantic domain +newtype T_Grammar = T_Grammar (( VisageGrammar)) +data Inh_Grammar = Inh_Grammar {} +data Syn_Grammar = Syn_Grammar {visage_Syn_Grammar :: VisageGrammar} +wrap_Grammar (T_Grammar sem) (Inh_Grammar ) = + (let ( _lhsOvisage) = + (sem ) + in (Syn_Grammar _lhsOvisage)) +sem_Grammar_Grammar :: TypeSyns -> + UseMap -> + Derivings -> + (Set NontermIdent) -> + T_Nonterminals -> + PragmaMap -> + AttrOrderMap -> + ParamMap -> + ContextMap -> + T_Grammar +sem_Grammar_Grammar typeSyns_ useMap_ derivings_ wrappers_ (T_Nonterminals nonts_) pragmas_ manualAttrOrderMap_ paramMap_ contextMap_ = + (T_Grammar (let _lhsOvisage :: VisageGrammar + _nontsIvnonts :: ([VisageNonterminal]) + -- "TfmToVisage.ag"(line 86, column 17) + _lhsOvisage = + VGrammar _nontsIvnonts + ( _nontsIvnonts) = + (nonts_ ) + in ( _lhsOvisage))) +-- Nonterminal ------------------------------------------------- +{- + visit 0: + synthesized attribute: + vnont : VisageNonterminal + alternatives: + alternative Nonterminal: + child nt : {NontermIdent} + child params : {[Identifier]} + child inh : {Attributes} + child syn : {Attributes} + child prods : Productions +-} +-- cata +sem_Nonterminal :: Nonterminal -> + T_Nonterminal +sem_Nonterminal (Nonterminal _nt _params _inh _syn _prods) = + (sem_Nonterminal_Nonterminal _nt _params _inh _syn (sem_Productions _prods)) +-- semantic domain +newtype T_Nonterminal = T_Nonterminal (( VisageNonterminal)) +data Inh_Nonterminal = Inh_Nonterminal {} +data Syn_Nonterminal = Syn_Nonterminal {vnont_Syn_Nonterminal :: VisageNonterminal} +wrap_Nonterminal (T_Nonterminal sem) (Inh_Nonterminal ) = + (let ( _lhsOvnont) = + (sem ) + in (Syn_Nonterminal _lhsOvnont)) +sem_Nonterminal_Nonterminal :: NontermIdent -> + ([Identifier]) -> + Attributes -> + Attributes -> + T_Productions -> + T_Nonterminal +sem_Nonterminal_Nonterminal nt_ params_ inh_ syn_ (T_Productions prods_) = + (T_Nonterminal (let _lhsOvnont :: VisageNonterminal + _prodsIvprods :: ([VisageProduction]) + -- "TfmToVisage.ag"(line 93, column 18) + _lhsOvnont = + VNonterminal nt_ inh_ syn_ _prodsIvprods + ( _prodsIvprods) = + (prods_ ) + in ( _lhsOvnont))) +-- Nonterminals ------------------------------------------------ +{- + visit 0: + synthesized attribute: + vnonts : [VisageNonterminal] + alternatives: + alternative Cons: + child hd : Nonterminal + child tl : Nonterminals + alternative Nil: +-} +-- cata +sem_Nonterminals :: Nonterminals -> + T_Nonterminals +sem_Nonterminals list = + (Prelude.foldr sem_Nonterminals_Cons sem_Nonterminals_Nil (Prelude.map sem_Nonterminal list)) +-- semantic domain +newtype T_Nonterminals = T_Nonterminals (( ([VisageNonterminal]))) +data Inh_Nonterminals = Inh_Nonterminals {} +data Syn_Nonterminals = Syn_Nonterminals {vnonts_Syn_Nonterminals :: [VisageNonterminal]} +wrap_Nonterminals (T_Nonterminals sem) (Inh_Nonterminals ) = + (let ( _lhsOvnonts) = + (sem ) + in (Syn_Nonterminals _lhsOvnonts)) +sem_Nonterminals_Cons :: T_Nonterminal -> + T_Nonterminals -> + T_Nonterminals +sem_Nonterminals_Cons (T_Nonterminal hd_) (T_Nonterminals tl_) = + (T_Nonterminals (let _lhsOvnonts :: ([VisageNonterminal]) + _hdIvnont :: VisageNonterminal + _tlIvnonts :: ([VisageNonterminal]) + -- "TfmToVisage.ag"(line 89, column 17) + _lhsOvnonts = + _hdIvnont : _tlIvnonts + ( _hdIvnont) = + (hd_ ) + ( _tlIvnonts) = + (tl_ ) + in ( _lhsOvnonts))) +sem_Nonterminals_Nil :: T_Nonterminals +sem_Nonterminals_Nil = + (T_Nonterminals (let _lhsOvnonts :: ([VisageNonterminal]) + -- "TfmToVisage.ag"(line 90, column 17) + _lhsOvnonts = + [] + in ( _lhsOvnonts))) +-- Pattern ----------------------------------------------------- +{- + visit 0: + synthesized attributes: + copy : SELF + fieldattrs : [(Identifier,Identifier)] + self : SELF + vpat : VisagePattern + alternatives: + alternative Alias: + child field : {Identifier} + child attr : {Identifier} + child pat : Pattern + child parts : Patterns + visit 0: + local copy : _ + local self : _ + alternative Constr: + child name : {ConstructorIdent} + child pats : Patterns + visit 0: + local copy : _ + local self : _ + alternative Irrefutable: + child pat : Pattern + visit 0: + local copy : _ + local self : _ + alternative Product: + child pos : {Pos} + child pats : Patterns + visit 0: + local copy : _ + local self : _ + alternative Underscore: + child pos : {Pos} + visit 0: + local copy : _ + local self : _ +-} +-- cata +sem_Pattern :: Pattern -> + T_Pattern +sem_Pattern (Alias _field _attr _pat _parts) = + (sem_Pattern_Alias _field _attr (sem_Pattern _pat) (sem_Patterns _parts)) +sem_Pattern (Constr _name _pats) = + (sem_Pattern_Constr _name (sem_Patterns _pats)) +sem_Pattern (Irrefutable _pat) = + (sem_Pattern_Irrefutable (sem_Pattern _pat)) +sem_Pattern (Product _pos _pats) = + (sem_Pattern_Product _pos (sem_Patterns _pats)) +sem_Pattern (Underscore _pos) = + (sem_Pattern_Underscore _pos) +-- semantic domain +newtype T_Pattern = T_Pattern (( Pattern,( [(Identifier,Identifier)] ),Pattern,VisagePattern)) +data Inh_Pattern = Inh_Pattern {} +data Syn_Pattern = Syn_Pattern {copy_Syn_Pattern :: Pattern,fieldattrs_Syn_Pattern :: [(Identifier,Identifier)] ,self_Syn_Pattern :: Pattern,vpat_Syn_Pattern :: VisagePattern} +wrap_Pattern (T_Pattern sem) (Inh_Pattern ) = + (let ( _lhsOcopy,_lhsOfieldattrs,_lhsOself,_lhsOvpat) = + (sem ) + in (Syn_Pattern _lhsOcopy _lhsOfieldattrs _lhsOself _lhsOvpat)) +sem_Pattern_Alias :: Identifier -> + Identifier -> + T_Pattern -> + T_Patterns -> + T_Pattern +sem_Pattern_Alias field_ attr_ (T_Pattern pat_) (T_Patterns parts_) = + (T_Pattern (let _lhsOvpat :: VisagePattern + _lhsOfieldattrs :: ( [(Identifier,Identifier)] ) + _lhsOcopy :: Pattern + _lhsOself :: Pattern + _patIcopy :: Pattern + _patIfieldattrs :: ( [(Identifier,Identifier)] ) + _patIself :: Pattern + _patIvpat :: VisagePattern + _partsIcopy :: Patterns + _partsIfieldattrs :: ( [(Identifier,Identifier)] ) + _partsIself :: Patterns + _partsIvpats :: ([VisagePattern]) + -- "TfmToVisage.ag"(line 128, column 17) + _lhsOvpat = + if (isVar _self) + then VVar field_ attr_ + else VAlias field_ attr_ _patIvpat + -- "TfmToVisage.ag"(line 137, column 17) + _lhsOfieldattrs = + [(field_, attr_)] + -- self rule + _copy = + Alias field_ attr_ _patIcopy _partsIcopy + -- self rule + _self = + Alias field_ attr_ _patIself _partsIself + -- self rule + _lhsOcopy = + _copy + -- self rule + _lhsOself = + _self + ( _patIcopy,_patIfieldattrs,_patIself,_patIvpat) = + (pat_ ) + ( _partsIcopy,_partsIfieldattrs,_partsIself,_partsIvpats) = + (parts_ ) + in ( _lhsOcopy,_lhsOfieldattrs,_lhsOself,_lhsOvpat))) +sem_Pattern_Constr :: ConstructorIdent -> + T_Patterns -> + T_Pattern +sem_Pattern_Constr name_ (T_Patterns pats_) = + (T_Pattern (let _lhsOvpat :: VisagePattern + _lhsOfieldattrs :: ( [(Identifier,Identifier)] ) + _lhsOcopy :: Pattern + _lhsOself :: Pattern + _patsIcopy :: Patterns + _patsIfieldattrs :: ( [(Identifier,Identifier)] ) + _patsIself :: Patterns + _patsIvpats :: ([VisagePattern]) + -- "TfmToVisage.ag"(line 126, column 17) + _lhsOvpat = + VConstr name_ _patsIvpats + -- use rule "TfmToVisage.ag"(line 134, column 43) + _lhsOfieldattrs = + _patsIfieldattrs + -- self rule + _copy = + Constr name_ _patsIcopy + -- self rule + _self = + Constr name_ _patsIself + -- self rule + _lhsOcopy = + _copy + -- self rule + _lhsOself = + _self + ( _patsIcopy,_patsIfieldattrs,_patsIself,_patsIvpats) = + (pats_ ) + in ( _lhsOcopy,_lhsOfieldattrs,_lhsOself,_lhsOvpat))) +sem_Pattern_Irrefutable :: T_Pattern -> + T_Pattern +sem_Pattern_Irrefutable (T_Pattern pat_) = + (T_Pattern (let _lhsOfieldattrs :: ( [(Identifier,Identifier)] ) + _lhsOcopy :: Pattern + _lhsOself :: Pattern + _lhsOvpat :: VisagePattern + _patIcopy :: Pattern + _patIfieldattrs :: ( [(Identifier,Identifier)] ) + _patIself :: Pattern + _patIvpat :: VisagePattern + -- use rule "TfmToVisage.ag"(line 134, column 43) + _lhsOfieldattrs = + _patIfieldattrs + -- self rule + _copy = + Irrefutable _patIcopy + -- self rule + _self = + Irrefutable _patIself + -- self rule + _lhsOcopy = + _copy + -- self rule + _lhsOself = + _self + -- copy rule (up) + _lhsOvpat = + _patIvpat + ( _patIcopy,_patIfieldattrs,_patIself,_patIvpat) = + (pat_ ) + in ( _lhsOcopy,_lhsOfieldattrs,_lhsOself,_lhsOvpat))) +sem_Pattern_Product :: Pos -> + T_Patterns -> + T_Pattern +sem_Pattern_Product pos_ (T_Patterns pats_) = + (T_Pattern (let _lhsOvpat :: VisagePattern + _lhsOfieldattrs :: ( [(Identifier,Identifier)] ) + _lhsOcopy :: Pattern + _lhsOself :: Pattern + _patsIcopy :: Patterns + _patsIfieldattrs :: ( [(Identifier,Identifier)] ) + _patsIself :: Patterns + _patsIvpats :: ([VisagePattern]) + -- "TfmToVisage.ag"(line 127, column 17) + _lhsOvpat = + VProduct pos_ _patsIvpats + -- use rule "TfmToVisage.ag"(line 134, column 43) + _lhsOfieldattrs = + _patsIfieldattrs + -- self rule + _copy = + Product pos_ _patsIcopy + -- self rule + _self = + Product pos_ _patsIself + -- self rule + _lhsOcopy = + _copy + -- self rule + _lhsOself = + _self + ( _patsIcopy,_patsIfieldattrs,_patsIself,_patsIvpats) = + (pats_ ) + in ( _lhsOcopy,_lhsOfieldattrs,_lhsOself,_lhsOvpat))) +sem_Pattern_Underscore :: Pos -> + T_Pattern +sem_Pattern_Underscore pos_ = + (T_Pattern (let _lhsOvpat :: VisagePattern + _lhsOfieldattrs :: ( [(Identifier,Identifier)] ) + _lhsOcopy :: Pattern + _lhsOself :: Pattern + -- "TfmToVisage.ag"(line 131, column 17) + _lhsOvpat = + VUnderscore pos_ + -- use rule "TfmToVisage.ag"(line 134, column 43) + _lhsOfieldattrs = + [] + -- self rule + _copy = + Underscore pos_ + -- self rule + _self = + Underscore pos_ + -- self rule + _lhsOcopy = + _copy + -- self rule + _lhsOself = + _self + in ( _lhsOcopy,_lhsOfieldattrs,_lhsOself,_lhsOvpat))) +-- Patterns ---------------------------------------------------- +{- + visit 0: + synthesized attributes: + copy : SELF + fieldattrs : [(Identifier,Identifier)] + self : SELF + vpats : [VisagePattern] + alternatives: + alternative Cons: + child hd : Pattern + child tl : Patterns + visit 0: + local copy : _ + local self : _ + alternative Nil: + visit 0: + local copy : _ + local self : _ +-} +-- cata +sem_Patterns :: Patterns -> + T_Patterns +sem_Patterns list = + (Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list)) +-- semantic domain +newtype T_Patterns = T_Patterns (( Patterns,( [(Identifier,Identifier)] ),Patterns,([VisagePattern]))) +data Inh_Patterns = Inh_Patterns {} +data Syn_Patterns = Syn_Patterns {copy_Syn_Patterns :: Patterns,fieldattrs_Syn_Patterns :: [(Identifier,Identifier)] ,self_Syn_Patterns :: Patterns,vpats_Syn_Patterns :: [VisagePattern]} +wrap_Patterns (T_Patterns sem) (Inh_Patterns ) = + (let ( _lhsOcopy,_lhsOfieldattrs,_lhsOself,_lhsOvpats) = + (sem ) + in (Syn_Patterns _lhsOcopy _lhsOfieldattrs _lhsOself _lhsOvpats)) +sem_Patterns_Cons :: T_Pattern -> + T_Patterns -> + T_Patterns +sem_Patterns_Cons (T_Pattern hd_) (T_Patterns tl_) = + (T_Patterns (let _lhsOvpats :: ([VisagePattern]) + _lhsOfieldattrs :: ( [(Identifier,Identifier)] ) + _lhsOcopy :: Patterns + _lhsOself :: Patterns + _hdIcopy :: Pattern + _hdIfieldattrs :: ( [(Identifier,Identifier)] ) + _hdIself :: Pattern + _hdIvpat :: VisagePattern + _tlIcopy :: Patterns + _tlIfieldattrs :: ( [(Identifier,Identifier)] ) + _tlIself :: Patterns + _tlIvpats :: ([VisagePattern]) + -- "TfmToVisage.ag"(line 122, column 17) + _lhsOvpats = + _hdIvpat : _tlIvpats + -- use rule "TfmToVisage.ag"(line 134, column 43) + _lhsOfieldattrs = + _hdIfieldattrs ++ _tlIfieldattrs + -- self rule + _copy = + (:) _hdIcopy _tlIcopy + -- self rule + _self = + (:) _hdIself _tlIself + -- self rule + _lhsOcopy = + _copy + -- self rule + _lhsOself = + _self + ( _hdIcopy,_hdIfieldattrs,_hdIself,_hdIvpat) = + (hd_ ) + ( _tlIcopy,_tlIfieldattrs,_tlIself,_tlIvpats) = + (tl_ ) + in ( _lhsOcopy,_lhsOfieldattrs,_lhsOself,_lhsOvpats))) +sem_Patterns_Nil :: T_Patterns +sem_Patterns_Nil = + (T_Patterns (let _lhsOvpats :: ([VisagePattern]) + _lhsOfieldattrs :: ( [(Identifier,Identifier)] ) + _lhsOcopy :: Patterns + _lhsOself :: Patterns + -- "TfmToVisage.ag"(line 123, column 17) + _lhsOvpats = + [] + -- use rule "TfmToVisage.ag"(line 134, column 43) + _lhsOfieldattrs = + [] + -- self rule + _copy = + [] + -- self rule + _self = + [] + -- self rule + _lhsOcopy = + _copy + -- self rule + _lhsOself = + _self + in ( _lhsOcopy,_lhsOfieldattrs,_lhsOself,_lhsOvpats))) +-- Production -------------------------------------------------- +{- + visit 0: + synthesized attribute: + vprod : VisageProduction + alternatives: + alternative Production: + child con : {ConstructorIdent} + child children : Children + child rules : Rules + child typeSigs : TypeSigs + visit 0: + local splitVRules : _ + local locrules : _ + local lhsrules : _ +-} +-- cata +sem_Production :: Production -> + T_Production +sem_Production (Production _con _children _rules _typeSigs) = + (sem_Production_Production _con (sem_Children _children) (sem_Rules _rules) (sem_TypeSigs _typeSigs)) +-- semantic domain +newtype T_Production = T_Production (( VisageProduction)) +data Inh_Production = Inh_Production {} +data Syn_Production = Syn_Production {vprod_Syn_Production :: VisageProduction} +wrap_Production (T_Production sem) (Inh_Production ) = + (let ( _lhsOvprod) = + (sem ) + in (Syn_Production _lhsOvprod)) +sem_Production_Production :: ConstructorIdent -> + T_Children -> + T_Rules -> + T_TypeSigs -> + T_Production +sem_Production_Production con_ (T_Children children_) (T_Rules rules_) (T_TypeSigs typeSigs_) = + (T_Production (let _lhsOvprod :: VisageProduction + _childrenOrulemap :: VisageRuleMap + _childrenIvchildren :: ([VisageChild]) + _rulesIvrules :: ([VisageRule]) + -- "TfmToVisage.ag"(line 100, column 17) + _lhsOvprod = + VProduction con_ _childrenIvchildren _lhsrules _locrules + -- "TfmToVisage.ag"(line 101, column 17) + _splitVRules = + splitVRules _rulesIvrules + -- "TfmToVisage.ag"(line 102, column 17) + _locrules = + getForField "loc" _splitVRules + -- "TfmToVisage.ag"(line 103, column 17) + _lhsrules = + getForField "lhs" _splitVRules + -- "TfmToVisage.ag"(line 104, column 17) + _childrenOrulemap = + _splitVRules + ( _childrenIvchildren) = + (children_ _childrenOrulemap) + ( _rulesIvrules) = + (rules_ ) + in ( _lhsOvprod))) +-- Productions ------------------------------------------------- +{- + visit 0: + synthesized attribute: + vprods : [VisageProduction] + alternatives: + alternative Cons: + child hd : Production + child tl : Productions + alternative Nil: +-} +-- cata +sem_Productions :: Productions -> + T_Productions +sem_Productions list = + (Prelude.foldr sem_Productions_Cons sem_Productions_Nil (Prelude.map sem_Production list)) +-- semantic domain +newtype T_Productions = T_Productions (( ([VisageProduction]))) +data Inh_Productions = Inh_Productions {} +data Syn_Productions = Syn_Productions {vprods_Syn_Productions :: [VisageProduction]} +wrap_Productions (T_Productions sem) (Inh_Productions ) = + (let ( _lhsOvprods) = + (sem ) + in (Syn_Productions _lhsOvprods)) +sem_Productions_Cons :: T_Production -> + T_Productions -> + T_Productions +sem_Productions_Cons (T_Production hd_) (T_Productions tl_) = + (T_Productions (let _lhsOvprods :: ([VisageProduction]) + _hdIvprod :: VisageProduction + _tlIvprods :: ([VisageProduction]) + -- "TfmToVisage.ag"(line 96, column 17) + _lhsOvprods = + _hdIvprod : _tlIvprods + ( _hdIvprod) = + (hd_ ) + ( _tlIvprods) = + (tl_ ) + in ( _lhsOvprods))) +sem_Productions_Nil :: T_Productions +sem_Productions_Nil = + (T_Productions (let _lhsOvprods :: ([VisageProduction]) + -- "TfmToVisage.ag"(line 97, column 17) + _lhsOvprods = + [] + in ( _lhsOvprods))) +-- Rule -------------------------------------------------------- +{- + visit 0: + synthesized attribute: + vrule : VisageRule + alternatives: + alternative Rule: + child pattern : Pattern + child rhs : Expression + child owrt : {Bool} + child origin : {String} +-} +-- cata +sem_Rule :: Rule -> + T_Rule +sem_Rule (Rule _pattern _rhs _owrt _origin) = + (sem_Rule_Rule (sem_Pattern _pattern) (sem_Expression _rhs) _owrt _origin) +-- semantic domain +newtype T_Rule = T_Rule (( VisageRule)) +data Inh_Rule = Inh_Rule {} +data Syn_Rule = Syn_Rule {vrule_Syn_Rule :: VisageRule} +wrap_Rule (T_Rule sem) (Inh_Rule ) = + (let ( _lhsOvrule) = + (sem ) + in (Syn_Rule _lhsOvrule)) +sem_Rule_Rule :: T_Pattern -> + T_Expression -> + Bool -> + String -> + T_Rule +sem_Rule_Rule (T_Pattern pattern_) (T_Expression rhs_) owrt_ origin_ = + (T_Rule (let _lhsOvrule :: VisageRule + _patternIcopy :: Pattern + _patternIfieldattrs :: ( [(Identifier,Identifier)] ) + _patternIself :: Pattern + _patternIvpat :: VisagePattern + _rhsIself :: Expression + -- "TfmToVisage.ag"(line 119, column 11) + _lhsOvrule = + VRule _patternIfieldattrs undefined _patternIvpat _rhsIself owrt_ + ( _patternIcopy,_patternIfieldattrs,_patternIself,_patternIvpat) = + (pattern_ ) + ( _rhsIself) = + (rhs_ ) + in ( _lhsOvrule))) +-- Rules ------------------------------------------------------- +{- + visit 0: + synthesized attribute: + vrules : [VisageRule] + alternatives: + alternative Cons: + child hd : Rule + child tl : Rules + alternative Nil: +-} +-- cata +sem_Rules :: Rules -> + T_Rules +sem_Rules list = + (Prelude.foldr sem_Rules_Cons sem_Rules_Nil (Prelude.map sem_Rule list)) +-- semantic domain +newtype T_Rules = T_Rules (( ([VisageRule]))) +data Inh_Rules = Inh_Rules {} +data Syn_Rules = Syn_Rules {vrules_Syn_Rules :: [VisageRule]} +wrap_Rules (T_Rules sem) (Inh_Rules ) = + (let ( _lhsOvrules) = + (sem ) + in (Syn_Rules _lhsOvrules)) +sem_Rules_Cons :: T_Rule -> + T_Rules -> + T_Rules +sem_Rules_Cons (T_Rule hd_) (T_Rules tl_) = + (T_Rules (let _lhsOvrules :: ([VisageRule]) + _hdIvrule :: VisageRule + _tlIvrules :: ([VisageRule]) + -- "TfmToVisage.ag"(line 114, column 17) + _lhsOvrules = + _hdIvrule : _tlIvrules + ( _hdIvrule) = + (hd_ ) + ( _tlIvrules) = + (tl_ ) + in ( _lhsOvrules))) +sem_Rules_Nil :: T_Rules +sem_Rules_Nil = + (T_Rules (let _lhsOvrules :: ([VisageRule]) + -- "TfmToVisage.ag"(line 115, column 17) + _lhsOvrules = + [] + in ( _lhsOvrules))) +-- TypeSig ----------------------------------------------------- +{- + alternatives: + alternative TypeSig: + child name : {Identifier} + child tp : {Type} +-} +-- cata +sem_TypeSig :: TypeSig -> + T_TypeSig +sem_TypeSig (TypeSig _name _tp) = + (sem_TypeSig_TypeSig _name _tp) +-- semantic domain +newtype T_TypeSig = T_TypeSig (( )) +data Inh_TypeSig = Inh_TypeSig {} +data Syn_TypeSig = Syn_TypeSig {} +wrap_TypeSig (T_TypeSig sem) (Inh_TypeSig ) = + (let ( ) = + (sem ) + in (Syn_TypeSig )) +sem_TypeSig_TypeSig :: Identifier -> + Type -> + T_TypeSig +sem_TypeSig_TypeSig name_ tp_ = + (T_TypeSig (let + in ( ))) +-- TypeSigs ---------------------------------------------------- +{- + alternatives: + alternative Cons: + child hd : TypeSig + child tl : TypeSigs + alternative Nil: +-} +-- cata +sem_TypeSigs :: TypeSigs -> + T_TypeSigs +sem_TypeSigs list = + (Prelude.foldr sem_TypeSigs_Cons sem_TypeSigs_Nil (Prelude.map sem_TypeSig list)) +-- semantic domain +newtype T_TypeSigs = T_TypeSigs (( )) +data Inh_TypeSigs = Inh_TypeSigs {} +data Syn_TypeSigs = Syn_TypeSigs {} +wrap_TypeSigs (T_TypeSigs sem) (Inh_TypeSigs ) = + (let ( ) = + (sem ) + in (Syn_TypeSigs )) +sem_TypeSigs_Cons :: T_TypeSig -> + T_TypeSigs -> + T_TypeSigs +sem_TypeSigs_Cons (T_TypeSig hd_) (T_TypeSigs tl_) = + (T_TypeSigs (let + in ( ))) +sem_TypeSigs_Nil :: T_TypeSigs +sem_TypeSigs_Nil = + (T_TypeSigs (let + in ( ))) diff --git a/src-derived/Transform.hs b/src-derived/Transform.hs --- a/src-derived/Transform.hs +++ b/src-derived/Transform.hs @@ -2,3547 +2,3663 @@ module Transform where import Control.Monad(mplus,mzero) -import List (partition, elem) -import Data.Maybe -import qualified Data.Map as Map -import Data.Map (Map) -import Data.Set as Set (Set, member, union, toList, fromList, empty, singleton, member, unions, size, fold, intersection, difference, insert) -import UU.DData.Seq as Seq (Seq, empty, (<>), single, cons, toList, fromList) -import UU.Scanner.Position(noPos) - -import ConcreteSyntax -import AbstractSyntax -import ErrorMessages -import Patterns (Patterns(..),Pattern(..)) -import Expression (Expression(..)) - -import Options -import CommonTypes - -import UU.Scanner.Position (Pos) -import Patterns (Pattern) -import Expression (Expression) -import CommonTypes - --- Patterns.ag imports -import UU.Scanner.Position(Pos) -import CommonTypes (Constructor,Name) -type DefinedSets = Map Name (Set Nonterminal) -type FieldMap = [(Name, Type)] -type DataTypes = Map.Map Nonterminal (Map.Map Constructor FieldMap) -type AttrName = (Name,Name) -type RuleInfo = ([AttrName]->Pattern, Expression, [AttrName], Bool, String) -type SigInfo = (Identifier,Type) - - -checkDuplicate :: (Identifier -> Identifier -> Error) - -> Identifier -> val -> Map Identifier val -> (Map Identifier val,Seq Error) -checkDuplicate dupError key val m - = case Map.lookupIndex key m of - Just ix -> let (key',_) = Map.elemAt ix m - in (m,Seq.single (dupError key key')) - Nothing -> (Map.insert key val m,Seq.empty) - -checkDuplicates :: (Identifier -> Identifier -> Error) - -> [(Identifier, val)] -> Map Identifier val -> (Map Identifier val,Seq Error) -checkDuplicates dupError new m = foldErrors check m new - where check = uncurry (checkDuplicate dupError) - -foldErrors f e xs = foldl g (e,Seq.empty) xs - where g ~(e,es) x = let (e',es') = f x e - in (e', es <> es') - - -checkForDuplicates :: (Identifier -> Identifier -> Error) -> [Identifier] -> [Error] -checkForDuplicates err [] = [] -checkForDuplicates err (x:xs) = let (same,other) = List.partition (equalId x) xs - in map (err x) same ++ checkForDuplicates err other - -equalId :: Identifier -> Identifier -> Bool -equalId x y = getName x == getName y - - -type RulesAndErrors = ([Rule], Seq Error) -type SigsAndErrors = ([TypeSig], Seq Error) -type InstsAndErrors = ([(Identifier, Type)], Seq Error) -type AttrOverwrite = Map AttrName Bool -type AccumRuleCheck = (RulesAndErrors, AttrOverwrite) -type AccumDefiCheck = (Seq Error, AttrOverwrite, [AttrName], [AttrName]) - -checkRules :: Map Nonterminal (Attributes, Attributes) -> Map Nonterminal (Map Constructor FieldMap) -> - Map Nonterminal (Map Constructor [Identifier]) -> Map Nonterminal (Map Constructor [SigInfo]) -> - Nonterminal -> Constructor -> [RuleInfo] -> RulesAndErrors -checkRules attributes fields allinsts allsigs nt con rs - = let fieldmap :: FieldMap - fieldmap = (_LHS,NT nt) : (_LOC,NT undefined) : (_INST, NT undefined) : (_FIRST, NT undefined) : (_LAST, NT undefined) - : Map.findWithDefault [] con (Map.findWithDefault Map.empty nt fields) - ++ mapMaybe (\instNm -> lookup instNm sigs >>= \tp -> return (instNm, tp)) (Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allinsts)) - - sigs = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allsigs) - - hasAttrib f tp attr = Map.member attr (f (Map.findWithDefault (Map.empty,Map.empty) tp attributes)) - - checkRule :: RuleInfo -> AccumRuleCheck -> AccumRuleCheck - checkRule (pat,exp,as,owrt,str) ((r1,e1),m1) - = let (e2,m2,u2,b2) = foldr (checkDefi owrt) (e1,m1,[],[]) as - in ( (Rule (pat u2) exp owrt str : r1, e2), m2) - - checkDefi :: Bool -> AttrName -> AccumDefiCheck -> AccumDefiCheck - checkDefi owrt fa@(field,attr) (e,m,u,bs) - = case lookup field fieldmap - of Just (NT tp) -> if field == _LOC || field == _INST || field == _FIRST || field == _LAST - || hasAttrib (if getName field==getName _LHS then snd else fst) tp attr - then case Map.lookupIndex fa m - of Just ix -> let ((_,attr2),b) = Map.elemAt ix m - in if b && not (fa `elem` bs) - then ( e, Map.insert fa owrt m, fa:u, fa:bs) - else (Seq.cons (DupRule nt con field attr2 attr) e, m, fa:u, bs) - Nothing -> ( e, Map.insert fa owrt m, u, fa:bs) - else (Seq.cons (SuperfluousRule nt con field attr) e, m, fa:u, bs) - _ -> (Seq.cons (UndefChild nt con field) e, m, fa:u, bs ) - - in fst (foldr checkRule (([],Seq.empty),Map.empty) rs) - -checkSigs :: Nonterminal -> Constructor -> [SigInfo] -> SigsAndErrors -checkSigs nt con sis - = let checkSig (ide,typ) (sigs,errs) - = if ide `elem` map (\(TypeSig n t)-> n) sigs - then (sigs, Seq.cons (DupSig nt con ide) errs) - -- else if not (ide `elem` locattrdefs) - -- then (sigs, Seq.cons (SupSig nt con ide) errs) - else (TypeSig ide typ:sigs, errs) - in foldr checkSig ([],Seq.empty) sis - -checkInsts :: Map Nonterminal (Map Constructor [SigInfo]) -> Nonterminal -> Constructor -> [Identifier] -> InstsAndErrors -checkInsts sigMap nt con - = foldr (\inst (insts, errs) -> maybe (insts, Seq.single (MissingInstSig nt con inst) <> errs) - (\info -> (info : insts, errs)) $ findSig inst) ([], Seq.empty) - where - sigs = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt sigMap) - - findSig name - = do tp@(NT _) <- lookup name sigs - return (name, tp) - -flattenDatas :: DataTypes -> Map Nonterminal (Set Nonterminal) -flattenDatas ds = Map.map flatten ds - where flatten cs = Set.fromList [ nt | (_,NT nt) <- concatMap snd (Map.toList cs)] - -reachableFrom :: Map Nonterminal (Set Nonterminal) -> Set Nonterminal -> Set Nonterminal -reachableFrom table nts = reach nts - where reach nts = let nts' = Set.unions (nts : [ ns | nt <- Set.toList nts - , let ns = Map.findWithDefault Set.empty nt table ]) - in if Set.size nts' > Set.size nts - then reach nts' - else nts -invert :: Map Nonterminal (Set Nonterminal) -> Map Nonterminal (Set Nonterminal) -invert m = foldr inv Map.empty (Map.toList m) - where inv (x,ns) m = fold (\n m -> Map.insertWith Set.union n (Set.singleton x) m) m ns - -path :: Map Nonterminal (Set Nonterminal) -> Nonterminal -> Nonterminal -> Set Nonterminal -path table from to = let children = Map.findWithDefault Set.empty from table - forward = reachableFrom table children - backward = reachableFrom (invert table) - (Set.singleton to) - in Set.intersection forward backward - -pragmaMapUnion :: PragmaMap -> PragmaMap -> PragmaMap -pragmaMapUnion = Map.unionWith (Map.unionWith Set.union) - -pragmaMapSingle :: Nonterminal -> Constructor -> Set Name -> PragmaMap -pragmaMapSingle nt con nms = Map.singleton nt (Map.singleton con nms) - -orderMapUnion :: AttrOrderMap -> AttrOrderMap -> AttrOrderMap -orderMapUnion = Map.unionWith (Map.unionWith Set.union) - -orderMapSingle :: Nonterminal -> Constructor -> Set Dependency -> AttrOrderMap -orderMapSingle nt con deps = Map.singleton nt (Map.singleton con deps) - -mergeDerivings m1 m2 = foldr (\(n,cs) m -> Map.insertWith Set.union n cs m) m2 (Map.toList m1) - -merge x y = foldr f y (Map.toList x) - where f ~(k,v) m = Map.insertWith (Map.union) k v m - -checkAttrs allFields nts inherited synthesized decls = foldErrors check decls nts where - check nt decls | not (nt `Map.member` allFields) = (decls,Seq.single(UndefNont nt)) - | otherwise = let (inh,syn) = Map.findWithDefault (Map.empty,Map.empty) nt decls - (inh',einh) = checkDuplicates (DupInhAttr nt) inherited inh - (syn',esyn) = checkDuplicates (DupSynAttr nt) synthesized syn - in (Map.insert nt (inh',syn') decls,einh <> esyn) - -addSelf name atMap = let (eInh,eSyn) = Map.findWithDefault(Map.empty,Map.empty) name atMap - in Map.insert name (eInh, Map.insert (Ident "self" noPos) (NT _SELF) eSyn)atMap - -makeType :: Set Nonterminal -> Type -> Type -makeType nts tp@(NT x) | x == _SELF = tp - | Set.member x nts = tp - | otherwise = Haskell (getName x) -makeType _ tp = tp - -constructGrammar :: Set Nonterminal - -> DataTypes - -> Map Nonterminal (Attributes, Attributes) - -> Map Nonterminal (Map Name (String, String, String)) - -> Derivings - -> Set Nonterminal - -> Map Nonterminal (Map Constructor [Rule]) - -> Map Nonterminal (Map Constructor [TypeSig]) - -> Map Nonterminal (Map Constructor [(Identifier, Type)]) - -> TypeSyns - -> PragmaMap - -> AttrOrderMap - -> Grammar - -constructGrammar nts gram attrs uses derivings wrappers allrules tsigs allinsts tsyns pragmaMap orderMap = - let gr = [ (nt,Map.toList alts) | (nt,alts) <- Map.toList gram] - prods = map prod gr - prod (nt,alts) = let (inh,syn) = Map.findWithDefault (Map.empty,Map.empty) nt attrs - rmap = Map.findWithDefault Map.empty nt allrules - tsmap = Map.findWithDefault Map.empty nt tsigs - instsmap = Map.findWithDefault Map.empty nt allinsts - alt (con,flds) = - let rules = maybe [] id (Map.lookup con rmap) - tsigs = maybe [] id (Map.lookup con tsmap) - insts = maybe [] id (Map.lookup con instsmap) - cldrn = map (child False) flds ++ map (child True) insts - child isVirtual (nm, tp) = - let (inh,syn) = case tp of - NT nt -> Map.findWithDefault (Map.empty,Map.empty) nt attrs - _ -> (Map.empty,Map.empty) - in Child nm tp inh syn isVirtual - in Alternative con cldrn rules tsigs - in Production nt inh syn (map alt alts) - in Grammar tsyns uses derivings wrappers prods pragmaMap orderMap - -mapUnionWithSetUnion = Map.unionWith Set.union -mapUnionWithPlusPlus = Map.unionWith (++) --- AG ---------------------------------------------------------- -{- - visit 0: - inherited attribute: - options : Options - synthesized attributes: - blocks : Blocks - errors : Seq Error - moduleDecl : Maybe (String,String,String) - output : Grammar - pragmas : Options -> Options - alternatives: - alternative AG: - child elems : Elems - visit 0: - local allFields : _ - local allConstrs : _ - local allRules : _ - local allSigs : _ - local allInsts : _ - local allRulesErrs : _ - local allSigsErrs : _ - local allInstsErrs : _ - local checkedRules : _ - local checkedSigs : _ - local checkedInsts : _ - local errs1 : _ - local errs2 : _ - local errs3 : _ - local errs4 : _ - local errs5 : _ - local errs6 : _ - local allNonterminals : _ - local allAttrDecls : _ --} --- cata -sem_AG :: AG -> - T_AG -sem_AG (AG _elems) = - (sem_AG_AG (sem_Elems _elems)) --- semantic domain -newtype T_AG = T_AG (Options -> - ( Blocks,(Seq Error),(Maybe (String,String,String)),Grammar,(Options -> Options))) -data Inh_AG = Inh_AG {options_Inh_AG :: Options} -data Syn_AG = Syn_AG {blocks_Syn_AG :: Blocks,errors_Syn_AG :: Seq Error,moduleDecl_Syn_AG :: Maybe (String,String,String),output_Syn_AG :: Grammar,pragmas_Syn_AG :: Options -> Options} -wrap_AG (T_AG sem) (Inh_AG _lhsIoptions) = - (let ( _lhsOblocks,_lhsOerrors,_lhsOmoduleDecl,_lhsOoutput,_lhsOpragmas) = - (sem _lhsIoptions) - in (Syn_AG _lhsOblocks _lhsOerrors _lhsOmoduleDecl _lhsOoutput _lhsOpragmas)) -sem_AG_AG :: T_Elems -> - T_AG -sem_AG_AG (T_Elems elems_) = - (T_AG (\ _lhsIoptions -> - (let _lhsOoutput :: Grammar - _lhsOerrors :: (Seq Error) - _elemsOallConstructors :: (Map Nonterminal (Set Constructor)) - _elemsOdefSets :: (Map Name (Set Nonterminal,Set Name)) - _elemsOdefinedSets :: DefinedSets - _elemsOattrDecls :: (Map Nonterminal (Attributes, Attributes)) - _lhsOblocks :: Blocks - _lhsOmoduleDecl :: (Maybe (String,String,String)) - _lhsOpragmas :: (Options -> Options) - _elemsOallAttrDecls :: (Map Nonterminal (Attributes, Attributes)) - _elemsOallFields :: DataTypes - _elemsOallNonterminals :: (Set Nonterminal) - _elemsIattrDecls :: (Map Nonterminal (Attributes, Attributes)) - _elemsIattrOrderCollect :: AttrOrderMap - _elemsIblocks :: Blocks - _elemsIcollectedConstructorsMap :: (Map Nonterminal (Set Constructor)) - _elemsIcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) - _elemsIcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) - _elemsIcollectedNames :: (Set Name) - _elemsIcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) - _elemsIcollectedSetNames :: (Set Name) - _elemsIcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) - _elemsIdefSets :: (Map Name (Set Nonterminal,Set Name)) - _elemsIderivings :: Derivings - _elemsIerrors :: (Seq Error) - _elemsImoduleDecl :: (Maybe (String,String,String)) - _elemsIorderDepErrorsCollect :: (Seq Error) - _elemsIpragmas :: (Options -> Options) - _elemsIsemPragmasCollect :: PragmaMap - _elemsItypeSyns :: TypeSyns - _elemsIuseMap :: (Map Nonterminal (Map Name (String,String,String))) - _elemsIwrappers :: (Set Nonterminal) - -- "Transform.ag"(line 45, column 8) - _lhsOoutput = - constructGrammar _allNonterminals - _allFields - _allAttrDecls - _elemsIuseMap - _elemsIderivings - (if wrappers _lhsIoptions then _allNonterminals else _elemsIwrappers) - _checkedRules - _checkedSigs - _checkedInsts - _elemsItypeSyns - _elemsIsemPragmasCollect - _elemsIattrOrderCollect - -- "Transform.ag"(line 217, column 10) - _allFields = - let f (nt,con,fm) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con fm) - in foldr f (Map.empty) _elemsIcollectedFields - -- "Transform.ag"(line 220, column 10) - _allConstrs = - let f (nt,con,_) = Map.insertWith (++) nt [con] - in foldr f (Map.empty) _elemsIcollectedFields - -- "Transform.ag"(line 223, column 10) - _allRules = - let f (nt,con,r) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con [r]) - in foldr f (Map.empty) _elemsIcollectedRules - -- "Transform.ag"(line 226, column 10) - _allSigs = - let f (nt,con,t) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con [t]) - in foldr f (Map.empty) _elemsIcollectedSigs - -- "Transform.ag"(line 229, column 10) - _allInsts = - let f (nt,con,is) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con is) - in foldr f (Map.empty) _elemsIcollectedInsts - -- "Transform.ag"(line 232, column 10) - _allRulesErrs = - Map.mapWithKey (Map.mapWithKey . (checkRules _allAttrDecls _allFields _allInsts _allSigs )) _allRules - -- "Transform.ag"(line 233, column 10) - _allSigsErrs = - Map.mapWithKey (Map.mapWithKey . (checkSigs )) _allSigs - -- "Transform.ag"(line 234, column 10) - _allInstsErrs = - Map.mapWithKey (Map.mapWithKey . (checkInsts _allSigs )) _allInsts - -- "Transform.ag"(line 236, column 10) - _checkedRules = - Map.map (Map.map fst) _allRulesErrs - -- "Transform.ag"(line 237, column 10) - _checkedSigs = - Map.map (Map.map fst) _allSigsErrs - -- "Transform.ag"(line 238, column 10) - _checkedInsts = - Map.map (Map.map fst) _allInstsErrs - -- "Transform.ag"(line 240, column 10) - _errs1 = - let f = checkForDuplicates (DupSynonym) - in Seq.fromList . f . map fst $ _elemsItypeSyns - -- "Transform.ag"(line 243, column 10) - _errs2 = - let g nt (con,fm) = checkForDuplicates (DupChild nt con) (map fst fm) - f (nt,cfm) = concat . map (g nt) . Map.toList $ cfm - in Seq.fromList . concat . map f . Map.toList $ _allFields - -- "Transform.ag"(line 247, column 10) - _errs3 = - let f (nt,cons) = checkForDuplicates (DupAlt nt) cons - in Seq.empty - -- "Transform.ag"(line 251, column 10) - _errs4 = - let f m s = Map.fold ((<>) . snd) s m - in Map.fold f Seq.empty _allRulesErrs - -- "Transform.ag"(line 254, column 10) - _errs5 = - let f m s = Map.fold ((<>) . snd) s m - in Map.fold f Seq.empty _allSigsErrs - -- "Transform.ag"(line 257, column 10) - _errs6 = - let f m s = Map.fold ((<>) . snd) s m - in Map.fold f Seq.empty _allInstsErrs - -- "Transform.ag"(line 260, column 10) - _lhsOerrors = - _elemsIerrors <> _errs1 <> _errs2 <> _errs3 <> _errs4 <> _errs5 <> _errs6 <> _elemsIorderDepErrorsCollect - -- "Transform.ag"(line 343, column 10) - _allNonterminals = - _elemsIcollectedNames `Set.difference` _elemsIcollectedSetNames - -- "Transform.ag"(line 363, column 8) - _elemsOallConstructors = - _elemsIcollectedConstructorsMap - -- "Transform.ag"(line 417, column 8) - _elemsOdefSets = - Map.fromList (map (\x->(x,(Set.singleton x, Set.empty))) (Set.toList _allNonterminals )) - -- "Transform.ag"(line 418, column 8) - _elemsOdefinedSets = - Map.map fst _elemsIdefSets - -- "Transform.ag"(line 612, column 8) - _elemsOattrDecls = - Map.empty - -- "Transform.ag"(line 651, column 9) - _allAttrDecls = - if withSelf _lhsIoptions - then foldr addSelf _elemsIattrDecls (Set.toList _allNonterminals ) - else _elemsIattrDecls - -- use rule "Transform.ag"(line 38, column 19) - _lhsOblocks = - _elemsIblocks - -- use rule "Transform.ag"(line 734, column 37) - _lhsOmoduleDecl = - _elemsImoduleDecl - -- use rule "Transform.ag"(line 499, column 34) - _lhsOpragmas = - _elemsIpragmas - -- copy rule (from local) - _elemsOallAttrDecls = - _allAttrDecls - -- copy rule (from local) - _elemsOallFields = - _allFields - -- copy rule (from local) - _elemsOallNonterminals = - _allNonterminals - ( _elemsIattrDecls,_elemsIattrOrderCollect,_elemsIblocks,_elemsIcollectedConstructorsMap,_elemsIcollectedFields,_elemsIcollectedInsts,_elemsIcollectedNames,_elemsIcollectedRules,_elemsIcollectedSetNames,_elemsIcollectedSigs,_elemsIdefSets,_elemsIderivings,_elemsIerrors,_elemsImoduleDecl,_elemsIorderDepErrorsCollect,_elemsIpragmas,_elemsIsemPragmasCollect,_elemsItypeSyns,_elemsIuseMap,_elemsIwrappers) = - (elems_ _elemsOallAttrDecls _elemsOallConstructors _elemsOallFields _elemsOallNonterminals _elemsOattrDecls _elemsOdefSets _elemsOdefinedSets) - in ( _lhsOblocks,_lhsOerrors,_lhsOmoduleDecl,_lhsOoutput,_lhsOpragmas)))) --- Alt --------------------------------------------------------- -{- - visit 0: - inherited attributes: - allConstructors : Map Nonterminal (Set Constructor) - allNonterminals : Set Nonterminal - nts : Set Nonterminal - synthesized attributes: - collectedConstructorNames : Set Constructor - collectedFields : [(Nonterminal, Constructor, FieldMap)] - alternatives: - alternative Alt: - child pos : {Pos} - child names : ConstructorSet - child fields : {Fields} --} --- cata -sem_Alt :: Alt -> - T_Alt -sem_Alt (Alt _pos _names _fields) = - (sem_Alt_Alt _pos (sem_ConstructorSet _names) _fields) --- semantic domain -newtype T_Alt = T_Alt ((Map Nonterminal (Set Constructor)) -> - (Set Nonterminal) -> - (Set Nonterminal) -> - ( (Set Constructor),([(Nonterminal, Constructor, FieldMap)]))) -data Inh_Alt = Inh_Alt {allConstructors_Inh_Alt :: Map Nonterminal (Set Constructor),allNonterminals_Inh_Alt :: Set Nonterminal,nts_Inh_Alt :: Set Nonterminal} -data Syn_Alt = Syn_Alt {collectedConstructorNames_Syn_Alt :: Set Constructor,collectedFields_Syn_Alt :: [(Nonterminal, Constructor, FieldMap)]} -wrap_Alt (T_Alt sem) (Inh_Alt _lhsIallConstructors _lhsIallNonterminals _lhsInts) = - (let ( _lhsOcollectedConstructorNames,_lhsOcollectedFields) = - (sem _lhsIallConstructors _lhsIallNonterminals _lhsInts) - in (Syn_Alt _lhsOcollectedConstructorNames _lhsOcollectedFields)) -sem_Alt_Alt :: Pos -> - T_ConstructorSet -> - Fields -> - T_Alt -sem_Alt_Alt pos_ (T_ConstructorSet names_) fields_ = - (T_Alt (\ _lhsIallConstructors - _lhsIallNonterminals - _lhsInts -> - (let _lhsOcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) - _lhsOcollectedConstructorNames :: (Set Constructor) - _namesIcollectedConstructorNames :: (Set Constructor) - _namesIconstructors :: ((Set Constructor->Set Constructor)) - _namesIerrors :: (Seq Error) - -- "Transform.ag"(line 202, column 10) - _lhsOcollectedFields = - let fieldTable = - [ (attr, makeType _lhsIallNonterminals tp) - | (attr, tp) <- fields_ - ] - in [ (nt, con, fieldTable) - | nt <- Set.toList _lhsInts - , con <- Set.toList (_namesIconstructors (Map.findWithDefault Set.empty nt _lhsIallConstructors)) - ] - -- use rule "Transform.ag"(line 80, column 62) - _lhsOcollectedConstructorNames = - _namesIcollectedConstructorNames - ( _namesIcollectedConstructorNames,_namesIconstructors,_namesIerrors) = - (names_ ) - in ( _lhsOcollectedConstructorNames,_lhsOcollectedFields)))) --- Alts -------------------------------------------------------- -{- - visit 0: - inherited attributes: - allConstructors : Map Nonterminal (Set Constructor) - allNonterminals : Set Nonterminal - nts : Set Nonterminal - synthesized attributes: - collectedConstructorNames : Set Constructor - collectedFields : [(Nonterminal, Constructor, FieldMap)] - alternatives: - alternative Cons: - child hd : Alt - child tl : Alts - alternative Nil: --} --- cata -sem_Alts :: Alts -> - T_Alts -sem_Alts list = - (Prelude.foldr sem_Alts_Cons sem_Alts_Nil (Prelude.map sem_Alt list)) --- semantic domain -newtype T_Alts = T_Alts ((Map Nonterminal (Set Constructor)) -> - (Set Nonterminal) -> - (Set Nonterminal) -> - ( (Set Constructor),([(Nonterminal, Constructor, FieldMap)]))) -data Inh_Alts = Inh_Alts {allConstructors_Inh_Alts :: Map Nonterminal (Set Constructor),allNonterminals_Inh_Alts :: Set Nonterminal,nts_Inh_Alts :: Set Nonterminal} -data Syn_Alts = Syn_Alts {collectedConstructorNames_Syn_Alts :: Set Constructor,collectedFields_Syn_Alts :: [(Nonterminal, Constructor, FieldMap)]} -wrap_Alts (T_Alts sem) (Inh_Alts _lhsIallConstructors _lhsIallNonterminals _lhsInts) = - (let ( _lhsOcollectedConstructorNames,_lhsOcollectedFields) = - (sem _lhsIallConstructors _lhsIallNonterminals _lhsInts) - in (Syn_Alts _lhsOcollectedConstructorNames _lhsOcollectedFields)) -sem_Alts_Cons :: T_Alt -> - T_Alts -> - T_Alts -sem_Alts_Cons (T_Alt hd_) (T_Alts tl_) = - (T_Alts (\ _lhsIallConstructors - _lhsIallNonterminals - _lhsInts -> - (let _lhsOcollectedConstructorNames :: (Set Constructor) - _lhsOcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) - _hdOallConstructors :: (Map Nonterminal (Set Constructor)) - _hdOallNonterminals :: (Set Nonterminal) - _hdOnts :: (Set Nonterminal) - _tlOallConstructors :: (Map Nonterminal (Set Constructor)) - _tlOallNonterminals :: (Set Nonterminal) - _tlOnts :: (Set Nonterminal) - _hdIcollectedConstructorNames :: (Set Constructor) - _hdIcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) - _tlIcollectedConstructorNames :: (Set Constructor) - _tlIcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) - -- use rule "Transform.ag"(line 80, column 62) - _lhsOcollectedConstructorNames = - _hdIcollectedConstructorNames `Set.union` _tlIcollectedConstructorNames - -- use rule "Transform.ag"(line 112, column 28) - _lhsOcollectedFields = - _hdIcollectedFields ++ _tlIcollectedFields - -- copy rule (down) - _hdOallConstructors = - _lhsIallConstructors - -- copy rule (down) - _hdOallNonterminals = - _lhsIallNonterminals - -- copy rule (down) - _hdOnts = - _lhsInts - -- copy rule (down) - _tlOallConstructors = - _lhsIallConstructors - -- copy rule (down) - _tlOallNonterminals = - _lhsIallNonterminals - -- copy rule (down) - _tlOnts = - _lhsInts - ( _hdIcollectedConstructorNames,_hdIcollectedFields) = - (hd_ _hdOallConstructors _hdOallNonterminals _hdOnts) - ( _tlIcollectedConstructorNames,_tlIcollectedFields) = - (tl_ _tlOallConstructors _tlOallNonterminals _tlOnts) - in ( _lhsOcollectedConstructorNames,_lhsOcollectedFields)))) -sem_Alts_Nil :: T_Alts -sem_Alts_Nil = - (T_Alts (\ _lhsIallConstructors - _lhsIallNonterminals - _lhsInts -> - (let _lhsOcollectedConstructorNames :: (Set Constructor) - _lhsOcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) - -- use rule "Transform.ag"(line 80, column 62) - _lhsOcollectedConstructorNames = - Set.empty - -- use rule "Transform.ag"(line 112, column 28) - _lhsOcollectedFields = - [] - in ( _lhsOcollectedConstructorNames,_lhsOcollectedFields)))) --- Attrs ------------------------------------------------------- -{- - visit 0: - inherited attributes: - allFields : DataTypes - allNonterminals : Set Nonterminal - nts : Set Nonterminal - chained attribute: - attrDecls : Map Nonterminal (Attributes, Attributes) - synthesized attributes: - errors : Seq Error - useMap : Map Nonterminal (Map Name (String,String,String)) - alternatives: - alternative Attrs: - child pos : {Pos} - child inh : {AttrNames} - child chn : {AttrNames} - child syn : {AttrNames} - visit 0: - local _tup1 : _ - local attrDecls : _ - local errors : _ - local _tup2 : _ - local inherited : _ - local synthesized : _ - local useMap : _ --} --- cata -sem_Attrs :: Attrs -> - T_Attrs -sem_Attrs (Attrs _pos _inh _chn _syn) = - (sem_Attrs_Attrs _pos _inh _chn _syn) --- semantic domain -newtype T_Attrs = T_Attrs (DataTypes -> - (Set Nonterminal) -> - (Map Nonterminal (Attributes, Attributes)) -> - (Set Nonterminal) -> - ( (Map Nonterminal (Attributes, Attributes)),(Seq Error),(Map Nonterminal (Map Name (String,String,String))))) -data Inh_Attrs = Inh_Attrs {allFields_Inh_Attrs :: DataTypes,allNonterminals_Inh_Attrs :: Set Nonterminal,attrDecls_Inh_Attrs :: Map Nonterminal (Attributes, Attributes),nts_Inh_Attrs :: Set Nonterminal} -data Syn_Attrs = Syn_Attrs {attrDecls_Syn_Attrs :: Map Nonterminal (Attributes, Attributes),errors_Syn_Attrs :: Seq Error,useMap_Syn_Attrs :: Map Nonterminal (Map Name (String,String,String))} -wrap_Attrs (T_Attrs sem) (Inh_Attrs _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsInts) = - (let ( _lhsOattrDecls,_lhsOerrors,_lhsOuseMap) = - (sem _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsInts) - in (Syn_Attrs _lhsOattrDecls _lhsOerrors _lhsOuseMap)) -sem_Attrs_Attrs :: Pos -> - AttrNames -> - AttrNames -> - AttrNames -> - T_Attrs -sem_Attrs_Attrs pos_ inh_ chn_ syn_ = - (T_Attrs (\ _lhsIallFields - _lhsIallNonterminals - _lhsIattrDecls - _lhsInts -> - (let _lhsOuseMap :: (Map Nonterminal (Map Name (String,String,String))) - _lhsOerrors :: (Seq Error) - _lhsOattrDecls :: (Map Nonterminal (Attributes, Attributes)) - -- "Transform.ag"(line 620, column 15) - __tup1 = - checkAttrs _lhsIallFields (Set.toList _lhsInts) _inherited _synthesized _lhsIattrDecls - -- "Transform.ag"(line 620, column 15) - (_attrDecls,_) = - __tup1 - -- "Transform.ag"(line 620, column 15) - (_,_errors) = - __tup1 - -- "Transform.ag"(line 622, column 15) - __tup2 = - let splitAttrs xs = unzip [ ((n,makeType _lhsIallNonterminals t),(n,ud)) - | (n,t,ud) <- xs - ] - (inh,_) = splitAttrs inh_ - (chn,uses1) = splitAttrs chn_ - (syn,uses2) = splitAttrs syn_ - isUse (n,(e1,e2,_)) = not (null e1 || null e2) - in (inh++chn,chn++syn, Map.fromList (Prelude.filter isUse (uses1++uses2))) - -- "Transform.ag"(line 622, column 15) - (_inherited,_,_) = - __tup2 - -- "Transform.ag"(line 622, column 15) - (_,_synthesized,_) = - __tup2 - -- "Transform.ag"(line 622, column 15) - (_,_,_useMap) = - __tup2 - -- "Transform.ag"(line 630, column 11) - _lhsOuseMap = - Map.fromList (zip (Set.toList _lhsInts) (repeat _useMap)) - -- use rule "Transform.ag"(line 36, column 19) - _lhsOerrors = - _errors - -- copy rule (from local) - _lhsOattrDecls = - _attrDecls - in ( _lhsOattrDecls,_lhsOerrors,_lhsOuseMap)))) --- ConstructorSet ---------------------------------------------- -{- - visit 0: - synthesized attributes: - collectedConstructorNames : Set Constructor - constructors : (Set Constructor->Set Constructor) - errors : Seq Error - alternatives: - alternative CAll: - alternative CDifference: - child set1 : ConstructorSet - child set2 : ConstructorSet - alternative CName: - child name : {Constructor} - alternative CUnion: - child set1 : ConstructorSet - child set2 : ConstructorSet --} --- cata -sem_ConstructorSet :: ConstructorSet -> - T_ConstructorSet -sem_ConstructorSet (CAll ) = - (sem_ConstructorSet_CAll ) -sem_ConstructorSet (CDifference _set1 _set2) = - (sem_ConstructorSet_CDifference (sem_ConstructorSet _set1) (sem_ConstructorSet _set2)) -sem_ConstructorSet (CName _name) = - (sem_ConstructorSet_CName _name) -sem_ConstructorSet (CUnion _set1 _set2) = - (sem_ConstructorSet_CUnion (sem_ConstructorSet _set1) (sem_ConstructorSet _set2)) --- semantic domain -newtype T_ConstructorSet = T_ConstructorSet (( (Set Constructor),((Set Constructor->Set Constructor)),(Seq Error))) -data Inh_ConstructorSet = Inh_ConstructorSet {} -data Syn_ConstructorSet = Syn_ConstructorSet {collectedConstructorNames_Syn_ConstructorSet :: Set Constructor,constructors_Syn_ConstructorSet :: (Set Constructor->Set Constructor),errors_Syn_ConstructorSet :: Seq Error} -wrap_ConstructorSet (T_ConstructorSet sem) (Inh_ConstructorSet ) = - (let ( _lhsOcollectedConstructorNames,_lhsOconstructors,_lhsOerrors) = - (sem ) - in (Syn_ConstructorSet _lhsOcollectedConstructorNames _lhsOconstructors _lhsOerrors)) -sem_ConstructorSet_CAll :: T_ConstructorSet -sem_ConstructorSet_CAll = - (T_ConstructorSet (let _lhsOconstructors :: ((Set Constructor->Set Constructor)) - _lhsOcollectedConstructorNames :: (Set Constructor) - _lhsOerrors :: (Seq Error) - -- "Transform.ag"(line 484, column 17) - _lhsOconstructors = - \ds -> ds - -- use rule "Transform.ag"(line 80, column 62) - _lhsOcollectedConstructorNames = - Set.empty - -- use rule "Transform.ag"(line 36, column 19) - _lhsOerrors = - Seq.empty - in ( _lhsOcollectedConstructorNames,_lhsOconstructors,_lhsOerrors))) -sem_ConstructorSet_CDifference :: T_ConstructorSet -> - T_ConstructorSet -> - T_ConstructorSet -sem_ConstructorSet_CDifference (T_ConstructorSet set1_) (T_ConstructorSet set2_) = - (T_ConstructorSet (let _lhsOconstructors :: ((Set Constructor->Set Constructor)) - _lhsOcollectedConstructorNames :: (Set Constructor) - _lhsOerrors :: (Seq Error) - _set1IcollectedConstructorNames :: (Set Constructor) - _set1Iconstructors :: ((Set Constructor->Set Constructor)) - _set1Ierrors :: (Seq Error) - _set2IcollectedConstructorNames :: (Set Constructor) - _set2Iconstructors :: ((Set Constructor->Set Constructor)) - _set2Ierrors :: (Seq Error) - -- "Transform.ag"(line 483, column 17) - _lhsOconstructors = - \ds -> _set1Iconstructors ds `Set.difference` _set2Iconstructors ds - -- use rule "Transform.ag"(line 80, column 62) - _lhsOcollectedConstructorNames = - _set1IcollectedConstructorNames `Set.union` _set2IcollectedConstructorNames - -- use rule "Transform.ag"(line 36, column 19) - _lhsOerrors = - _set1Ierrors Seq.<> _set2Ierrors - ( _set1IcollectedConstructorNames,_set1Iconstructors,_set1Ierrors) = - (set1_ ) - ( _set2IcollectedConstructorNames,_set2Iconstructors,_set2Ierrors) = - (set2_ ) - in ( _lhsOcollectedConstructorNames,_lhsOconstructors,_lhsOerrors))) -sem_ConstructorSet_CName :: Constructor -> - T_ConstructorSet -sem_ConstructorSet_CName name_ = - (T_ConstructorSet (let _lhsOcollectedConstructorNames :: (Set Constructor) - _lhsOconstructors :: ((Set Constructor->Set Constructor)) - _lhsOerrors :: (Seq Error) - -- "Transform.ag"(line 351, column 11) - _lhsOcollectedConstructorNames = - Set.singleton name_ - -- "Transform.ag"(line 481, column 17) - _lhsOconstructors = - \ds -> Set.singleton name_ - -- use rule "Transform.ag"(line 36, column 19) - _lhsOerrors = - Seq.empty - in ( _lhsOcollectedConstructorNames,_lhsOconstructors,_lhsOerrors))) -sem_ConstructorSet_CUnion :: T_ConstructorSet -> - T_ConstructorSet -> - T_ConstructorSet -sem_ConstructorSet_CUnion (T_ConstructorSet set1_) (T_ConstructorSet set2_) = - (T_ConstructorSet (let _lhsOconstructors :: ((Set Constructor->Set Constructor)) - _lhsOcollectedConstructorNames :: (Set Constructor) - _lhsOerrors :: (Seq Error) - _set1IcollectedConstructorNames :: (Set Constructor) - _set1Iconstructors :: ((Set Constructor->Set Constructor)) - _set1Ierrors :: (Seq Error) - _set2IcollectedConstructorNames :: (Set Constructor) - _set2Iconstructors :: ((Set Constructor->Set Constructor)) - _set2Ierrors :: (Seq Error) - -- "Transform.ag"(line 482, column 17) - _lhsOconstructors = - \ds -> _set1Iconstructors ds `Set.union` _set2Iconstructors ds - -- use rule "Transform.ag"(line 80, column 62) - _lhsOcollectedConstructorNames = - _set1IcollectedConstructorNames `Set.union` _set2IcollectedConstructorNames - -- use rule "Transform.ag"(line 36, column 19) - _lhsOerrors = - _set1Ierrors Seq.<> _set2Ierrors - ( _set1IcollectedConstructorNames,_set1Iconstructors,_set1Ierrors) = - (set1_ ) - ( _set2IcollectedConstructorNames,_set2Iconstructors,_set2Ierrors) = - (set2_ ) - in ( _lhsOcollectedConstructorNames,_lhsOconstructors,_lhsOerrors))) --- Elem -------------------------------------------------------- -{- - visit 0: - inherited attributes: - allAttrDecls : Map Nonterminal (Attributes, Attributes) - allConstructors : Map Nonterminal (Set Constructor) - allFields : DataTypes - allNonterminals : Set Nonterminal - definedSets : DefinedSets - chained attributes: - attrDecls : Map Nonterminal (Attributes, Attributes) - defSets : Map Name (Set Nonterminal,Set Name) - synthesized attributes: - attrOrderCollect : AttrOrderMap - blocks : Blocks - collectedConstructorsMap : Map Nonterminal (Set Constructor) - collectedFields : [(Nonterminal, Constructor, FieldMap)] - collectedInsts : [ (Nonterminal, Constructor, [Identifier]) ] - collectedNames : Set Name - collectedRules : [ (Nonterminal, Constructor, RuleInfo)] - collectedSetNames : Set Name - collectedSigs : [ (Nonterminal, Constructor, SigInfo) ] - derivings : Derivings - errors : Seq Error - moduleDecl : Maybe (String,String,String) - orderDepErrorsCollect : Seq Error - pragmas : Options -> Options - semPragmasCollect : PragmaMap - typeSyns : TypeSyns - useMap : Map Nonterminal (Map Name (String,String,String)) - wrappers : Set Nonterminal - alternatives: - alternative Attr: - child pos : {Pos} - child names : NontSet - child attrs : Attrs - alternative Data: - child pos : {Pos} - child names : NontSet - child attrs : Attrs - child alts : Alts - child ext : {Bool} - alternative Deriving: - child pos : {Pos} - child set : NontSet - child classes : {[Name]} - alternative Module: - child pos : {Pos} - child name : {String} - child exports : {String} - child imports : {String} - alternative Pragma: - child pos : {Pos} - child names : {[Name]} - alternative Sem: - child pos : {Pos} - child names : NontSet - child attrs : Attrs - child alts : SemAlts - alternative Set: - child pos : {Pos} - child name : {Name} - child set : NontSet - visit 0: - local _tup3 : _ - local defSets2 : _ - local errs : _ - alternative Txt: - child pos : {Pos} - child name : {Name} - child lines : {[String]} - alternative Type: - child pos : {Pos} - child name : {Nonterminal} - child type : {ComplexType} - visit 0: - local expanded : _ - local argType : _ - alternative Wrapper: - child pos : {Pos} - child set : NontSet --} --- cata -sem_Elem :: Elem -> - T_Elem -sem_Elem (Attr _pos _names _attrs) = - (sem_Elem_Attr _pos (sem_NontSet _names) (sem_Attrs _attrs)) -sem_Elem (Data _pos _names _attrs _alts _ext) = - (sem_Elem_Data _pos (sem_NontSet _names) (sem_Attrs _attrs) (sem_Alts _alts) _ext) -sem_Elem (Deriving _pos _set _classes) = - (sem_Elem_Deriving _pos (sem_NontSet _set) _classes) -sem_Elem (Module _pos _name _exports _imports) = - (sem_Elem_Module _pos _name _exports _imports) -sem_Elem (Pragma _pos _names) = - (sem_Elem_Pragma _pos _names) -sem_Elem (Sem _pos _names _attrs _alts) = - (sem_Elem_Sem _pos (sem_NontSet _names) (sem_Attrs _attrs) (sem_SemAlts _alts)) -sem_Elem (Set _pos _name _set) = - (sem_Elem_Set _pos _name (sem_NontSet _set)) -sem_Elem (Txt _pos _name _lines) = - (sem_Elem_Txt _pos _name _lines) -sem_Elem (Type _pos _name _type) = - (sem_Elem_Type _pos _name _type) -sem_Elem (Wrapper _pos _set) = - (sem_Elem_Wrapper _pos (sem_NontSet _set)) --- semantic domain -newtype T_Elem = T_Elem ((Map Nonterminal (Attributes, Attributes)) -> - (Map Nonterminal (Set Constructor)) -> - DataTypes -> - (Set Nonterminal) -> - (Map Nonterminal (Attributes, Attributes)) -> - (Map Name (Set Nonterminal,Set Name)) -> - DefinedSets -> - ( (Map Nonterminal (Attributes, Attributes)),AttrOrderMap,Blocks,(Map Nonterminal (Set Constructor)),([(Nonterminal, Constructor, FieldMap)]),([ (Nonterminal, Constructor, [Identifier]) ]),(Set Name),([ (Nonterminal, Constructor, RuleInfo)]),(Set Name),([ (Nonterminal, Constructor, SigInfo) ]),(Map Name (Set Nonterminal,Set Name)),Derivings,(Seq Error),(Maybe (String,String,String)),(Seq Error),(Options -> Options),PragmaMap,TypeSyns,(Map Nonterminal (Map Name (String,String,String))),(Set Nonterminal))) -data Inh_Elem = Inh_Elem {allAttrDecls_Inh_Elem :: Map Nonterminal (Attributes, Attributes),allConstructors_Inh_Elem :: Map Nonterminal (Set Constructor),allFields_Inh_Elem :: DataTypes,allNonterminals_Inh_Elem :: Set Nonterminal,attrDecls_Inh_Elem :: Map Nonterminal (Attributes, Attributes),defSets_Inh_Elem :: Map Name (Set Nonterminal,Set Name),definedSets_Inh_Elem :: DefinedSets} -data Syn_Elem = Syn_Elem {attrDecls_Syn_Elem :: Map Nonterminal (Attributes, Attributes),attrOrderCollect_Syn_Elem :: AttrOrderMap,blocks_Syn_Elem :: Blocks,collectedConstructorsMap_Syn_Elem :: Map Nonterminal (Set Constructor),collectedFields_Syn_Elem :: [(Nonterminal, Constructor, FieldMap)],collectedInsts_Syn_Elem :: [ (Nonterminal, Constructor, [Identifier]) ],collectedNames_Syn_Elem :: Set Name,collectedRules_Syn_Elem :: [ (Nonterminal, Constructor, RuleInfo)],collectedSetNames_Syn_Elem :: Set Name,collectedSigs_Syn_Elem :: [ (Nonterminal, Constructor, SigInfo) ],defSets_Syn_Elem :: Map Name (Set Nonterminal,Set Name),derivings_Syn_Elem :: Derivings,errors_Syn_Elem :: Seq Error,moduleDecl_Syn_Elem :: Maybe (String,String,String),orderDepErrorsCollect_Syn_Elem :: Seq Error,pragmas_Syn_Elem :: Options -> Options,semPragmasCollect_Syn_Elem :: PragmaMap,typeSyns_Syn_Elem :: TypeSyns,useMap_Syn_Elem :: Map Nonterminal (Map Name (String,String,String)),wrappers_Syn_Elem :: Set Nonterminal} -wrap_Elem (T_Elem sem) (Inh_Elem _lhsIallAttrDecls _lhsIallConstructors _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsIdefSets _lhsIdefinedSets) = - (let ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOorderDepErrorsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers) = - (sem _lhsIallAttrDecls _lhsIallConstructors _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsIdefSets _lhsIdefinedSets) - in (Syn_Elem _lhsOattrDecls _lhsOattrOrderCollect _lhsOblocks _lhsOcollectedConstructorsMap _lhsOcollectedFields _lhsOcollectedInsts _lhsOcollectedNames _lhsOcollectedRules _lhsOcollectedSetNames _lhsOcollectedSigs _lhsOdefSets _lhsOderivings _lhsOerrors _lhsOmoduleDecl _lhsOorderDepErrorsCollect _lhsOpragmas _lhsOsemPragmasCollect _lhsOtypeSyns _lhsOuseMap _lhsOwrappers)) -sem_Elem_Attr :: Pos -> - T_NontSet -> - T_Attrs -> - T_Elem -sem_Elem_Attr pos_ (T_NontSet names_) (T_Attrs attrs_) = - (T_Elem (\ _lhsIallAttrDecls - _lhsIallConstructors - _lhsIallFields - _lhsIallNonterminals - _lhsIattrDecls - _lhsIdefSets - _lhsIdefinedSets -> - (let _attrsOnts :: (Set Nonterminal) - _lhsOattrOrderCollect :: AttrOrderMap - _lhsOblocks :: Blocks - _lhsOcollectedConstructorsMap :: (Map Nonterminal (Set Constructor)) - _lhsOcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) - _lhsOcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) - _lhsOcollectedNames :: (Set Name) - _lhsOcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) - _lhsOcollectedSetNames :: (Set Name) - _lhsOcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) - _lhsOderivings :: Derivings - _lhsOerrors :: (Seq Error) - _lhsOmoduleDecl :: (Maybe (String,String,String)) - _lhsOorderDepErrorsCollect :: (Seq Error) - _lhsOpragmas :: (Options -> Options) - _lhsOsemPragmasCollect :: PragmaMap - _lhsOtypeSyns :: TypeSyns - _lhsOuseMap :: (Map Nonterminal (Map Name (String,String,String))) - _lhsOwrappers :: (Set Nonterminal) - _lhsOattrDecls :: (Map Nonterminal (Attributes, Attributes)) - _lhsOdefSets :: (Map Name (Set Nonterminal,Set Name)) - _namesOallFields :: DataTypes - _namesOallNonterminals :: (Set Nonterminal) - _namesOdefinedSets :: DefinedSets - _attrsOallFields :: DataTypes - _attrsOallNonterminals :: (Set Nonterminal) - _attrsOattrDecls :: (Map Nonterminal (Attributes, Attributes)) - _namesIcollectedNames :: (Set Name) - _namesIerrors :: (Seq Error) - _namesInontSet :: (Set Nonterminal) - _attrsIattrDecls :: (Map Nonterminal (Attributes, Attributes)) - _attrsIerrors :: (Seq Error) - _attrsIuseMap :: (Map Nonterminal (Map Name (String,String,String))) - -- "Transform.ag"(line 616, column 10) - _attrsOnts = - _namesInontSet - -- use rule "Transform.ag"(line 560, column 55) - _lhsOattrOrderCollect = - Map.empty - -- use rule "Transform.ag"(line 38, column 19) - _lhsOblocks = - Map.empty - -- use rule "Transform.ag"(line 81, column 48) - _lhsOcollectedConstructorsMap = - Map.empty - -- use rule "Transform.ag"(line 112, column 28) - _lhsOcollectedFields = - [] - -- use rule "Transform.ag"(line 136, column 29) - _lhsOcollectedInsts = - [] - -- use rule "Transform.ag"(line 73, column 50) - _lhsOcollectedNames = - _namesIcollectedNames - -- use rule "Transform.ag"(line 134, column 29) - _lhsOcollectedRules = - [] - -- use rule "Transform.ag"(line 72, column 50) - _lhsOcollectedSetNames = - Set.empty - -- use rule "Transform.ag"(line 135, column 29) - _lhsOcollectedSigs = - [] - -- use rule "Transform.ag"(line 593, column 33) - _lhsOderivings = - Map.empty - -- use rule "Transform.ag"(line 36, column 19) - _lhsOerrors = - _namesIerrors Seq.<> _attrsIerrors - -- use rule "Transform.ag"(line 734, column 37) - _lhsOmoduleDecl = - mzero - -- use rule "Transform.ag"(line 561, column 60) - _lhsOorderDepErrorsCollect = - Seq.empty - -- use rule "Transform.ag"(line 499, column 34) - _lhsOpragmas = - id - -- use rule "Transform.ag"(line 532, column 56) - _lhsOsemPragmasCollect = - Map.empty - -- use rule "Transform.ag"(line 378, column 32) - _lhsOtypeSyns = - [] - -- use rule "Transform.ag"(line 124, column 15) - _lhsOuseMap = - _attrsIuseMap - -- use rule "Transform.ag"(line 490, column 32) - _lhsOwrappers = - Set.empty - -- copy rule (up) - _lhsOattrDecls = - _attrsIattrDecls - -- copy rule (chain) - _lhsOdefSets = - _lhsIdefSets - -- copy rule (down) - _namesOallFields = - _lhsIallFields - -- copy rule (down) - _namesOallNonterminals = - _lhsIallNonterminals - -- copy rule (down) - _namesOdefinedSets = - _lhsIdefinedSets - -- copy rule (down) - _attrsOallFields = - _lhsIallFields - -- copy rule (down) - _attrsOallNonterminals = - _lhsIallNonterminals - -- copy rule (down) - _attrsOattrDecls = - _lhsIattrDecls - ( _namesIcollectedNames,_namesIerrors,_namesInontSet) = - (names_ _namesOallFields _namesOallNonterminals _namesOdefinedSets) - ( _attrsIattrDecls,_attrsIerrors,_attrsIuseMap) = - (attrs_ _attrsOallFields _attrsOallNonterminals _attrsOattrDecls _attrsOnts) - in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOorderDepErrorsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) -sem_Elem_Data :: Pos -> - T_NontSet -> - T_Attrs -> - T_Alts -> - Bool -> - T_Elem -sem_Elem_Data pos_ (T_NontSet names_) (T_Attrs attrs_) (T_Alts alts_) ext_ = - (T_Elem (\ _lhsIallAttrDecls - _lhsIallConstructors - _lhsIallFields - _lhsIallNonterminals - _lhsIattrDecls - _lhsIdefSets - _lhsIdefinedSets -> - (let _altsOnts :: (Set Nonterminal) - _lhsOcollectedConstructorsMap :: (Map Nonterminal (Set Constructor)) - _attrsOnts :: (Set Nonterminal) - _lhsOattrOrderCollect :: AttrOrderMap - _lhsOblocks :: Blocks - _lhsOcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) - _lhsOcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) - _lhsOcollectedNames :: (Set Name) - _lhsOcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) - _lhsOcollectedSetNames :: (Set Name) - _lhsOcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) - _lhsOderivings :: Derivings - _lhsOerrors :: (Seq Error) - _lhsOmoduleDecl :: (Maybe (String,String,String)) - _lhsOorderDepErrorsCollect :: (Seq Error) - _lhsOpragmas :: (Options -> Options) - _lhsOsemPragmasCollect :: PragmaMap - _lhsOtypeSyns :: TypeSyns - _lhsOuseMap :: (Map Nonterminal (Map Name (String,String,String))) - _lhsOwrappers :: (Set Nonterminal) - _lhsOattrDecls :: (Map Nonterminal (Attributes, Attributes)) - _lhsOdefSets :: (Map Name (Set Nonterminal,Set Name)) - _namesOallFields :: DataTypes - _namesOallNonterminals :: (Set Nonterminal) - _namesOdefinedSets :: DefinedSets - _attrsOallFields :: DataTypes - _attrsOallNonterminals :: (Set Nonterminal) - _attrsOattrDecls :: (Map Nonterminal (Attributes, Attributes)) - _altsOallConstructors :: (Map Nonterminal (Set Constructor)) - _altsOallNonterminals :: (Set Nonterminal) - _namesIcollectedNames :: (Set Name) - _namesIerrors :: (Seq Error) - _namesInontSet :: (Set Nonterminal) - _attrsIattrDecls :: (Map Nonterminal (Attributes, Attributes)) - _attrsIerrors :: (Seq Error) - _attrsIuseMap :: (Map Nonterminal (Map Name (String,String,String))) - _altsIcollectedConstructorNames :: (Set Constructor) - _altsIcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) - -- "Transform.ag"(line 149, column 10) - _altsOnts = - _namesInontSet - -- "Transform.ag"(line 357, column 11) - _lhsOcollectedConstructorsMap = - Map.fromList - [ (n, _altsIcollectedConstructorNames) - | n <- Set.toList _namesInontSet - ] - -- "Transform.ag"(line 615, column 10) - _attrsOnts = - _namesInontSet - -- use rule "Transform.ag"(line 560, column 55) - _lhsOattrOrderCollect = - Map.empty - -- use rule "Transform.ag"(line 38, column 19) - _lhsOblocks = - Map.empty - -- use rule "Transform.ag"(line 112, column 28) - _lhsOcollectedFields = - _altsIcollectedFields - -- use rule "Transform.ag"(line 136, column 29) - _lhsOcollectedInsts = - [] - -- use rule "Transform.ag"(line 73, column 50) - _lhsOcollectedNames = - _namesIcollectedNames - -- use rule "Transform.ag"(line 134, column 29) - _lhsOcollectedRules = - [] - -- use rule "Transform.ag"(line 72, column 50) - _lhsOcollectedSetNames = - Set.empty - -- use rule "Transform.ag"(line 135, column 29) - _lhsOcollectedSigs = - [] - -- use rule "Transform.ag"(line 593, column 33) - _lhsOderivings = - Map.empty - -- use rule "Transform.ag"(line 36, column 19) - _lhsOerrors = - _namesIerrors Seq.<> _attrsIerrors - -- use rule "Transform.ag"(line 734, column 37) - _lhsOmoduleDecl = - mzero - -- use rule "Transform.ag"(line 561, column 60) - _lhsOorderDepErrorsCollect = - Seq.empty - -- use rule "Transform.ag"(line 499, column 34) - _lhsOpragmas = - id - -- use rule "Transform.ag"(line 532, column 56) - _lhsOsemPragmasCollect = - Map.empty - -- use rule "Transform.ag"(line 378, column 32) - _lhsOtypeSyns = - [] - -- use rule "Transform.ag"(line 124, column 15) - _lhsOuseMap = - _attrsIuseMap - -- use rule "Transform.ag"(line 490, column 32) - _lhsOwrappers = - Set.empty - -- copy rule (up) - _lhsOattrDecls = - _attrsIattrDecls - -- copy rule (chain) - _lhsOdefSets = - _lhsIdefSets - -- copy rule (down) - _namesOallFields = - _lhsIallFields - -- copy rule (down) - _namesOallNonterminals = - _lhsIallNonterminals - -- copy rule (down) - _namesOdefinedSets = - _lhsIdefinedSets - -- copy rule (down) - _attrsOallFields = - _lhsIallFields - -- copy rule (down) - _attrsOallNonterminals = - _lhsIallNonterminals - -- copy rule (down) - _attrsOattrDecls = - _lhsIattrDecls - -- copy rule (down) - _altsOallConstructors = - _lhsIallConstructors - -- copy rule (down) - _altsOallNonterminals = - _lhsIallNonterminals - ( _namesIcollectedNames,_namesIerrors,_namesInontSet) = - (names_ _namesOallFields _namesOallNonterminals _namesOdefinedSets) - ( _attrsIattrDecls,_attrsIerrors,_attrsIuseMap) = - (attrs_ _attrsOallFields _attrsOallNonterminals _attrsOattrDecls _attrsOnts) - ( _altsIcollectedConstructorNames,_altsIcollectedFields) = - (alts_ _altsOallConstructors _altsOallNonterminals _altsOnts) - in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOorderDepErrorsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) -sem_Elem_Deriving :: Pos -> - T_NontSet -> - ([Name]) -> - T_Elem -sem_Elem_Deriving pos_ (T_NontSet set_) classes_ = - (T_Elem (\ _lhsIallAttrDecls - _lhsIallConstructors - _lhsIallFields - _lhsIallNonterminals - _lhsIattrDecls - _lhsIdefSets - _lhsIdefinedSets -> - (let _lhsOderivings :: Derivings - _lhsOattrOrderCollect :: AttrOrderMap - _lhsOblocks :: Blocks - _lhsOcollectedConstructorsMap :: (Map Nonterminal (Set Constructor)) - _lhsOcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) - _lhsOcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) - _lhsOcollectedNames :: (Set Name) - _lhsOcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) - _lhsOcollectedSetNames :: (Set Name) - _lhsOcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) - _lhsOerrors :: (Seq Error) - _lhsOmoduleDecl :: (Maybe (String,String,String)) - _lhsOorderDepErrorsCollect :: (Seq Error) - _lhsOpragmas :: (Options -> Options) - _lhsOsemPragmasCollect :: PragmaMap - _lhsOtypeSyns :: TypeSyns - _lhsOuseMap :: (Map Nonterminal (Map Name (String,String,String))) - _lhsOwrappers :: (Set Nonterminal) - _lhsOattrDecls :: (Map Nonterminal (Attributes, Attributes)) - _lhsOdefSets :: (Map Name (Set Nonterminal,Set Name)) - _setOallFields :: DataTypes - _setOallNonterminals :: (Set Nonterminal) - _setOdefinedSets :: DefinedSets - _setIcollectedNames :: (Set Name) - _setIerrors :: (Seq Error) - _setInontSet :: (Set Nonterminal) - -- "Transform.ag"(line 600, column 14) - _lhsOderivings = - Map.fromList [(nt,Set.fromList classes_) | nt <- Set.toList _setInontSet] - -- use rule "Transform.ag"(line 560, column 55) - _lhsOattrOrderCollect = - Map.empty - -- use rule "Transform.ag"(line 38, column 19) - _lhsOblocks = - Map.empty - -- use rule "Transform.ag"(line 81, column 48) - _lhsOcollectedConstructorsMap = - Map.empty - -- use rule "Transform.ag"(line 112, column 28) - _lhsOcollectedFields = - [] - -- use rule "Transform.ag"(line 136, column 29) - _lhsOcollectedInsts = - [] - -- use rule "Transform.ag"(line 73, column 50) - _lhsOcollectedNames = - _setIcollectedNames - -- use rule "Transform.ag"(line 134, column 29) - _lhsOcollectedRules = - [] - -- use rule "Transform.ag"(line 72, column 50) - _lhsOcollectedSetNames = - Set.empty - -- use rule "Transform.ag"(line 135, column 29) - _lhsOcollectedSigs = - [] - -- use rule "Transform.ag"(line 36, column 19) - _lhsOerrors = - _setIerrors - -- use rule "Transform.ag"(line 734, column 37) - _lhsOmoduleDecl = - mzero - -- use rule "Transform.ag"(line 561, column 60) - _lhsOorderDepErrorsCollect = - Seq.empty - -- use rule "Transform.ag"(line 499, column 34) - _lhsOpragmas = - id - -- use rule "Transform.ag"(line 532, column 56) - _lhsOsemPragmasCollect = - Map.empty - -- use rule "Transform.ag"(line 378, column 32) - _lhsOtypeSyns = - [] - -- use rule "Transform.ag"(line 124, column 15) - _lhsOuseMap = - Map.empty - -- use rule "Transform.ag"(line 490, column 32) - _lhsOwrappers = - Set.empty - -- copy rule (chain) - _lhsOattrDecls = - _lhsIattrDecls - -- copy rule (chain) - _lhsOdefSets = - _lhsIdefSets - -- copy rule (down) - _setOallFields = - _lhsIallFields - -- copy rule (down) - _setOallNonterminals = - _lhsIallNonterminals - -- copy rule (down) - _setOdefinedSets = - _lhsIdefinedSets - ( _setIcollectedNames,_setIerrors,_setInontSet) = - (set_ _setOallFields _setOallNonterminals _setOdefinedSets) - in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOorderDepErrorsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) -sem_Elem_Module :: Pos -> - String -> - String -> - String -> - T_Elem -sem_Elem_Module pos_ name_ exports_ imports_ = - (T_Elem (\ _lhsIallAttrDecls - _lhsIallConstructors - _lhsIallFields - _lhsIallNonterminals - _lhsIattrDecls - _lhsIdefSets - _lhsIdefinedSets -> - (let _lhsOmoduleDecl :: (Maybe (String,String,String)) - _lhsOattrOrderCollect :: AttrOrderMap - _lhsOblocks :: Blocks - _lhsOcollectedConstructorsMap :: (Map Nonterminal (Set Constructor)) - _lhsOcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) - _lhsOcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) - _lhsOcollectedNames :: (Set Name) - _lhsOcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) - _lhsOcollectedSetNames :: (Set Name) - _lhsOcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) - _lhsOderivings :: Derivings - _lhsOerrors :: (Seq Error) - _lhsOorderDepErrorsCollect :: (Seq Error) - _lhsOpragmas :: (Options -> Options) - _lhsOsemPragmasCollect :: PragmaMap - _lhsOtypeSyns :: TypeSyns - _lhsOuseMap :: (Map Nonterminal (Map Name (String,String,String))) - _lhsOwrappers :: (Set Nonterminal) - _lhsOattrDecls :: (Map Nonterminal (Attributes, Attributes)) - _lhsOdefSets :: (Map Name (Set Nonterminal,Set Name)) - -- "Transform.ag"(line 738, column 7) - _lhsOmoduleDecl = - Just (name_, exports_, imports_) - -- use rule "Transform.ag"(line 560, column 55) - _lhsOattrOrderCollect = - Map.empty - -- use rule "Transform.ag"(line 38, column 19) - _lhsOblocks = - Map.empty - -- use rule "Transform.ag"(line 81, column 48) - _lhsOcollectedConstructorsMap = - Map.empty - -- use rule "Transform.ag"(line 112, column 28) - _lhsOcollectedFields = - [] - -- use rule "Transform.ag"(line 136, column 29) - _lhsOcollectedInsts = - [] - -- use rule "Transform.ag"(line 73, column 50) - _lhsOcollectedNames = - Set.empty - -- use rule "Transform.ag"(line 134, column 29) - _lhsOcollectedRules = - [] - -- use rule "Transform.ag"(line 72, column 50) - _lhsOcollectedSetNames = - Set.empty - -- use rule "Transform.ag"(line 135, column 29) - _lhsOcollectedSigs = - [] - -- use rule "Transform.ag"(line 593, column 33) - _lhsOderivings = - Map.empty - -- use rule "Transform.ag"(line 36, column 19) - _lhsOerrors = - Seq.empty - -- use rule "Transform.ag"(line 561, column 60) - _lhsOorderDepErrorsCollect = - Seq.empty - -- use rule "Transform.ag"(line 499, column 34) - _lhsOpragmas = - id - -- use rule "Transform.ag"(line 532, column 56) - _lhsOsemPragmasCollect = - Map.empty - -- use rule "Transform.ag"(line 378, column 32) - _lhsOtypeSyns = - [] - -- use rule "Transform.ag"(line 124, column 15) - _lhsOuseMap = - Map.empty - -- use rule "Transform.ag"(line 490, column 32) - _lhsOwrappers = - Set.empty - -- copy rule (chain) - _lhsOattrDecls = - _lhsIattrDecls - -- copy rule (chain) - _lhsOdefSets = - _lhsIdefSets - in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOorderDepErrorsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) -sem_Elem_Pragma :: Pos -> - ([Name]) -> - T_Elem -sem_Elem_Pragma pos_ names_ = - (T_Elem (\ _lhsIallAttrDecls - _lhsIallConstructors - _lhsIallFields - _lhsIallNonterminals - _lhsIattrDecls - _lhsIdefSets - _lhsIdefinedSets -> - (let _lhsOpragmas :: (Options -> Options) - _lhsOattrOrderCollect :: AttrOrderMap - _lhsOblocks :: Blocks - _lhsOcollectedConstructorsMap :: (Map Nonterminal (Set Constructor)) - _lhsOcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) - _lhsOcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) - _lhsOcollectedNames :: (Set Name) - _lhsOcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) - _lhsOcollectedSetNames :: (Set Name) - _lhsOcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) - _lhsOderivings :: Derivings - _lhsOerrors :: (Seq Error) - _lhsOmoduleDecl :: (Maybe (String,String,String)) - _lhsOorderDepErrorsCollect :: (Seq Error) - _lhsOsemPragmasCollect :: PragmaMap - _lhsOtypeSyns :: TypeSyns - _lhsOuseMap :: (Map Nonterminal (Map Name (String,String,String))) - _lhsOwrappers :: (Set Nonterminal) - _lhsOattrDecls :: (Map Nonterminal (Attributes, Attributes)) - _lhsOdefSets :: (Map Name (Set Nonterminal,Set Name)) - -- "Transform.ag"(line 502, column 13) - _lhsOpragmas = - let mk n o = case getName n of - "nocycle" -> o { withCycle = False } - "cycle" -> o { withCycle = True } - "nostrictdata" -> o { strictData = False } - "strictdata" -> o { strictData = True } - "nostrictcase" -> o { strictCases = False } - "strictcase" -> o { strictCases = True } - "strictercase" -> o { strictCases = True, stricterCases = True } - "nostrictwrap" -> o { strictWrap = False } - "strictwrap" -> o { strictWrap = True } - "novisit" -> o { visit = False } - "visit" -> o { visit = True } - "nocase" -> o { cases = False } - "case" -> o { cases = True } - "noseq" -> o { withSeq = False } - "seq" -> o { withSeq = True } - "nounbox" -> o { unbox = False } - "unbox" -> o { unbox = True } - "bangpats" -> o { bangpats = True } - "nooptimize" -> o { cases = False , visit = False } - "optimize" -> o { cases = True , visit = True } - "strictsem" -> o { strictSems = True } - "gentraces" -> o { genTraces = True } - "splitsems" -> o { splitSems = True } - "gencostcentres" -> o { genCostCentres = True } - "sepsemmods" -> o { sepSemMods = True } - "genlinepragmas" -> o { genLinePragmas = True } - _ -> o - in \o -> foldr mk o names_ - -- use rule "Transform.ag"(line 560, column 55) - _lhsOattrOrderCollect = - Map.empty - -- use rule "Transform.ag"(line 38, column 19) - _lhsOblocks = - Map.empty - -- use rule "Transform.ag"(line 81, column 48) - _lhsOcollectedConstructorsMap = - Map.empty - -- use rule "Transform.ag"(line 112, column 28) - _lhsOcollectedFields = - [] - -- use rule "Transform.ag"(line 136, column 29) - _lhsOcollectedInsts = - [] - -- use rule "Transform.ag"(line 73, column 50) - _lhsOcollectedNames = - Set.empty - -- use rule "Transform.ag"(line 134, column 29) - _lhsOcollectedRules = - [] - -- use rule "Transform.ag"(line 72, column 50) - _lhsOcollectedSetNames = - Set.empty - -- use rule "Transform.ag"(line 135, column 29) - _lhsOcollectedSigs = - [] - -- use rule "Transform.ag"(line 593, column 33) - _lhsOderivings = - Map.empty - -- use rule "Transform.ag"(line 36, column 19) - _lhsOerrors = - Seq.empty - -- use rule "Transform.ag"(line 734, column 37) - _lhsOmoduleDecl = - mzero - -- use rule "Transform.ag"(line 561, column 60) - _lhsOorderDepErrorsCollect = - Seq.empty - -- use rule "Transform.ag"(line 532, column 56) - _lhsOsemPragmasCollect = - Map.empty - -- use rule "Transform.ag"(line 378, column 32) - _lhsOtypeSyns = - [] - -- use rule "Transform.ag"(line 124, column 15) - _lhsOuseMap = - Map.empty - -- use rule "Transform.ag"(line 490, column 32) - _lhsOwrappers = - Set.empty - -- copy rule (chain) - _lhsOattrDecls = - _lhsIattrDecls - -- copy rule (chain) - _lhsOdefSets = - _lhsIdefSets - in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOorderDepErrorsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) -sem_Elem_Sem :: Pos -> - T_NontSet -> - T_Attrs -> - T_SemAlts -> - T_Elem -sem_Elem_Sem pos_ (T_NontSet names_) (T_Attrs attrs_) (T_SemAlts alts_) = - (T_Elem (\ _lhsIallAttrDecls - _lhsIallConstructors - _lhsIallFields - _lhsIallNonterminals - _lhsIattrDecls - _lhsIdefSets - _lhsIdefinedSets -> - (let _altsOnts :: (Set Nonterminal) - _attrsOnts :: (Set Nonterminal) - _lhsOattrOrderCollect :: AttrOrderMap - _lhsOblocks :: Blocks - _lhsOcollectedConstructorsMap :: (Map Nonterminal (Set Constructor)) - _lhsOcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) - _lhsOcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) - _lhsOcollectedNames :: (Set Name) - _lhsOcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) - _lhsOcollectedSetNames :: (Set Name) - _lhsOcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) - _lhsOderivings :: Derivings - _lhsOerrors :: (Seq Error) - _lhsOmoduleDecl :: (Maybe (String,String,String)) - _lhsOorderDepErrorsCollect :: (Seq Error) - _lhsOpragmas :: (Options -> Options) - _lhsOsemPragmasCollect :: PragmaMap - _lhsOtypeSyns :: TypeSyns - _lhsOuseMap :: (Map Nonterminal (Map Name (String,String,String))) - _lhsOwrappers :: (Set Nonterminal) - _lhsOattrDecls :: (Map Nonterminal (Attributes, Attributes)) - _lhsOdefSets :: (Map Name (Set Nonterminal,Set Name)) - _namesOallFields :: DataTypes - _namesOallNonterminals :: (Set Nonterminal) - _namesOdefinedSets :: DefinedSets - _attrsOallFields :: DataTypes - _attrsOallNonterminals :: (Set Nonterminal) - _attrsOattrDecls :: (Map Nonterminal (Attributes, Attributes)) - _altsOallAttrDecls :: (Map Nonterminal (Attributes, Attributes)) - _altsOallFields :: DataTypes - _namesIcollectedNames :: (Set Name) - _namesIerrors :: (Seq Error) - _namesInontSet :: (Set Nonterminal) - _attrsIattrDecls :: (Map Nonterminal (Attributes, Attributes)) - _attrsIerrors :: (Seq Error) - _attrsIuseMap :: (Map Nonterminal (Map Name (String,String,String))) - _altsIattrOrderCollect :: AttrOrderMap - _altsIcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) - _altsIcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) - _altsIcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) - _altsIerrors :: (Seq Error) - _altsIorderDepErrorsCollect :: (Seq Error) - _altsIsemPragmasCollect :: PragmaMap - -- "Transform.ag"(line 150, column 10) - _altsOnts = - _namesInontSet - -- "Transform.ag"(line 617, column 10) - _attrsOnts = - _namesInontSet - -- use rule "Transform.ag"(line 560, column 55) - _lhsOattrOrderCollect = - _altsIattrOrderCollect - -- use rule "Transform.ag"(line 38, column 19) - _lhsOblocks = - Map.empty - -- use rule "Transform.ag"(line 81, column 48) - _lhsOcollectedConstructorsMap = - Map.empty - -- use rule "Transform.ag"(line 112, column 28) - _lhsOcollectedFields = - [] - -- use rule "Transform.ag"(line 136, column 29) - _lhsOcollectedInsts = - _altsIcollectedInsts - -- use rule "Transform.ag"(line 73, column 50) - _lhsOcollectedNames = - _namesIcollectedNames - -- use rule "Transform.ag"(line 134, column 29) - _lhsOcollectedRules = - _altsIcollectedRules - -- use rule "Transform.ag"(line 72, column 50) - _lhsOcollectedSetNames = - Set.empty - -- use rule "Transform.ag"(line 135, column 29) - _lhsOcollectedSigs = - _altsIcollectedSigs - -- use rule "Transform.ag"(line 593, column 33) - _lhsOderivings = - Map.empty - -- use rule "Transform.ag"(line 36, column 19) - _lhsOerrors = - _namesIerrors Seq.<> _attrsIerrors Seq.<> _altsIerrors - -- use rule "Transform.ag"(line 734, column 37) - _lhsOmoduleDecl = - mzero - -- use rule "Transform.ag"(line 561, column 60) - _lhsOorderDepErrorsCollect = - _altsIorderDepErrorsCollect - -- use rule "Transform.ag"(line 499, column 34) - _lhsOpragmas = - id - -- use rule "Transform.ag"(line 532, column 56) - _lhsOsemPragmasCollect = - _altsIsemPragmasCollect - -- use rule "Transform.ag"(line 378, column 32) - _lhsOtypeSyns = - [] - -- use rule "Transform.ag"(line 124, column 15) - _lhsOuseMap = - _attrsIuseMap - -- use rule "Transform.ag"(line 490, column 32) - _lhsOwrappers = - Set.empty - -- copy rule (up) - _lhsOattrDecls = - _attrsIattrDecls - -- copy rule (chain) - _lhsOdefSets = - _lhsIdefSets - -- copy rule (down) - _namesOallFields = - _lhsIallFields - -- copy rule (down) - _namesOallNonterminals = - _lhsIallNonterminals - -- copy rule (down) - _namesOdefinedSets = - _lhsIdefinedSets - -- copy rule (down) - _attrsOallFields = - _lhsIallFields - -- copy rule (down) - _attrsOallNonterminals = - _lhsIallNonterminals - -- copy rule (down) - _attrsOattrDecls = - _lhsIattrDecls - -- copy rule (down) - _altsOallAttrDecls = - _lhsIallAttrDecls - -- copy rule (down) - _altsOallFields = - _lhsIallFields - ( _namesIcollectedNames,_namesIerrors,_namesInontSet) = - (names_ _namesOallFields _namesOallNonterminals _namesOdefinedSets) - ( _attrsIattrDecls,_attrsIerrors,_attrsIuseMap) = - (attrs_ _attrsOallFields _attrsOallNonterminals _attrsOattrDecls _attrsOnts) - ( _altsIattrOrderCollect,_altsIcollectedInsts,_altsIcollectedRules,_altsIcollectedSigs,_altsIerrors,_altsIorderDepErrorsCollect,_altsIsemPragmasCollect) = - (alts_ _altsOallAttrDecls _altsOallFields _altsOnts) - in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOorderDepErrorsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) -sem_Elem_Set :: Pos -> - Name -> - T_NontSet -> - T_Elem -sem_Elem_Set pos_ name_ (T_NontSet set_) = - (T_Elem (\ _lhsIallAttrDecls - _lhsIallConstructors - _lhsIallFields - _lhsIallNonterminals - _lhsIattrDecls - _lhsIdefSets - _lhsIdefinedSets -> - (let _lhsOcollectedSetNames :: (Set Name) - _lhsOdefSets :: (Map Name (Set Nonterminal,Set Name)) - _lhsOerrors :: (Seq Error) - _lhsOattrOrderCollect :: AttrOrderMap - _lhsOblocks :: Blocks - _lhsOcollectedConstructorsMap :: (Map Nonterminal (Set Constructor)) - _lhsOcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) - _lhsOcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) - _lhsOcollectedNames :: (Set Name) - _lhsOcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) - _lhsOcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) - _lhsOderivings :: Derivings - _lhsOmoduleDecl :: (Maybe (String,String,String)) - _lhsOorderDepErrorsCollect :: (Seq Error) - _lhsOpragmas :: (Options -> Options) - _lhsOsemPragmasCollect :: PragmaMap - _lhsOtypeSyns :: TypeSyns - _lhsOuseMap :: (Map Nonterminal (Map Name (String,String,String))) - _lhsOwrappers :: (Set Nonterminal) - _lhsOattrDecls :: (Map Nonterminal (Attributes, Attributes)) - _setOallFields :: DataTypes - _setOallNonterminals :: (Set Nonterminal) - _setOdefinedSets :: DefinedSets - _setIcollectedNames :: (Set Name) - _setIerrors :: (Seq Error) - _setInontSet :: (Set Nonterminal) - -- "Transform.ag"(line 334, column 10) - _lhsOcollectedSetNames = - Set.singleton name_ - -- "Transform.ag"(line 422, column 13) - __tup3 = - let allUsedNames = Set.unions [ maybe (Set.singleton n) - snd - (Map.lookup n _lhsIdefSets) - | n <- Set.toList _setIcollectedNames - ] - (nontSet,e1) | Set.member name_ allUsedNames - = (Set.empty, Seq.single(CyclicSet name_)) - | otherwise = (_setInontSet, Seq.empty) - (res, e2) = checkDuplicate DupSet name_ (nontSet,Set.insert name_ allUsedNames) _lhsIdefSets - in (res, e1 Seq.<> e2) - -- "Transform.ag"(line 422, column 13) - (_defSets2,_) = - __tup3 - -- "Transform.ag"(line 422, column 13) - (_,_errs) = - __tup3 - -- "Transform.ag"(line 432, column 9) - _lhsOdefSets = - _defSets2 - -- "Transform.ag"(line 432, column 9) - _lhsOerrors = - _errs <> _setIerrors - -- use rule "Transform.ag"(line 560, column 55) - _lhsOattrOrderCollect = - Map.empty - -- use rule "Transform.ag"(line 38, column 19) - _lhsOblocks = - Map.empty - -- use rule "Transform.ag"(line 81, column 48) - _lhsOcollectedConstructorsMap = - Map.empty - -- use rule "Transform.ag"(line 112, column 28) - _lhsOcollectedFields = - [] - -- use rule "Transform.ag"(line 136, column 29) - _lhsOcollectedInsts = - [] - -- use rule "Transform.ag"(line 73, column 50) - _lhsOcollectedNames = - _setIcollectedNames - -- use rule "Transform.ag"(line 134, column 29) - _lhsOcollectedRules = - [] - -- use rule "Transform.ag"(line 135, column 29) - _lhsOcollectedSigs = - [] - -- use rule "Transform.ag"(line 593, column 33) - _lhsOderivings = - Map.empty - -- use rule "Transform.ag"(line 734, column 37) - _lhsOmoduleDecl = - mzero - -- use rule "Transform.ag"(line 561, column 60) - _lhsOorderDepErrorsCollect = - Seq.empty - -- use rule "Transform.ag"(line 499, column 34) - _lhsOpragmas = - id - -- use rule "Transform.ag"(line 532, column 56) - _lhsOsemPragmasCollect = - Map.empty - -- use rule "Transform.ag"(line 378, column 32) - _lhsOtypeSyns = - [] - -- use rule "Transform.ag"(line 124, column 15) - _lhsOuseMap = - Map.empty - -- use rule "Transform.ag"(line 490, column 32) - _lhsOwrappers = - Set.empty - -- copy rule (chain) - _lhsOattrDecls = - _lhsIattrDecls - -- copy rule (down) - _setOallFields = - _lhsIallFields - -- copy rule (down) - _setOallNonterminals = - _lhsIallNonterminals - -- copy rule (down) - _setOdefinedSets = - _lhsIdefinedSets - ( _setIcollectedNames,_setIerrors,_setInontSet) = - (set_ _setOallFields _setOallNonterminals _setOdefinedSets) - in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOorderDepErrorsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) -sem_Elem_Txt :: Pos -> - Name -> - ([String]) -> - T_Elem -sem_Elem_Txt pos_ name_ lines_ = - (T_Elem (\ _lhsIallAttrDecls - _lhsIallConstructors - _lhsIallFields - _lhsIallNonterminals - _lhsIattrDecls - _lhsIdefSets - _lhsIdefinedSets -> - (let _lhsOblocks :: Blocks - _lhsOattrOrderCollect :: AttrOrderMap - _lhsOcollectedConstructorsMap :: (Map Nonterminal (Set Constructor)) - _lhsOcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) - _lhsOcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) - _lhsOcollectedNames :: (Set Name) - _lhsOcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) - _lhsOcollectedSetNames :: (Set Name) - _lhsOcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) - _lhsOderivings :: Derivings - _lhsOerrors :: (Seq Error) - _lhsOmoduleDecl :: (Maybe (String,String,String)) - _lhsOorderDepErrorsCollect :: (Seq Error) - _lhsOpragmas :: (Options -> Options) - _lhsOsemPragmasCollect :: PragmaMap - _lhsOtypeSyns :: TypeSyns - _lhsOuseMap :: (Map Nonterminal (Map Name (String,String,String))) - _lhsOwrappers :: (Set Nonterminal) - _lhsOattrDecls :: (Map Nonterminal (Attributes, Attributes)) - _lhsOdefSets :: (Map Name (Set Nonterminal,Set Name)) - -- "Transform.ag"(line 159, column 11) - _lhsOblocks = - Map.singleton (getName name_) [(lines_, pos_)] - -- use rule "Transform.ag"(line 560, column 55) - _lhsOattrOrderCollect = - Map.empty - -- use rule "Transform.ag"(line 81, column 48) - _lhsOcollectedConstructorsMap = - Map.empty - -- use rule "Transform.ag"(line 112, column 28) - _lhsOcollectedFields = - [] - -- use rule "Transform.ag"(line 136, column 29) - _lhsOcollectedInsts = - [] - -- use rule "Transform.ag"(line 73, column 50) - _lhsOcollectedNames = - Set.empty - -- use rule "Transform.ag"(line 134, column 29) - _lhsOcollectedRules = - [] - -- use rule "Transform.ag"(line 72, column 50) - _lhsOcollectedSetNames = - Set.empty - -- use rule "Transform.ag"(line 135, column 29) - _lhsOcollectedSigs = - [] - -- use rule "Transform.ag"(line 593, column 33) - _lhsOderivings = - Map.empty - -- use rule "Transform.ag"(line 36, column 19) - _lhsOerrors = - Seq.empty - -- use rule "Transform.ag"(line 734, column 37) - _lhsOmoduleDecl = - mzero - -- use rule "Transform.ag"(line 561, column 60) - _lhsOorderDepErrorsCollect = - Seq.empty - -- use rule "Transform.ag"(line 499, column 34) - _lhsOpragmas = - id - -- use rule "Transform.ag"(line 532, column 56) - _lhsOsemPragmasCollect = - Map.empty - -- use rule "Transform.ag"(line 378, column 32) - _lhsOtypeSyns = - [] - -- use rule "Transform.ag"(line 124, column 15) - _lhsOuseMap = - Map.empty - -- use rule "Transform.ag"(line 490, column 32) - _lhsOwrappers = - Set.empty - -- copy rule (chain) - _lhsOattrDecls = - _lhsIattrDecls - -- copy rule (chain) - _lhsOdefSets = - _lhsIdefSets - in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOorderDepErrorsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) -sem_Elem_Type :: Pos -> - Nonterminal -> - ComplexType -> - T_Elem -sem_Elem_Type pos_ name_ type_ = - (T_Elem (\ _lhsIallAttrDecls - _lhsIallConstructors - _lhsIallFields - _lhsIallNonterminals - _lhsIattrDecls - _lhsIdefSets - _lhsIdefinedSets -> - (let _lhsOcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) - _lhsOcollectedNames :: (Set Name) - _lhsOtypeSyns :: TypeSyns - _lhsOattrOrderCollect :: AttrOrderMap - _lhsOblocks :: Blocks - _lhsOcollectedConstructorsMap :: (Map Nonterminal (Set Constructor)) - _lhsOcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) - _lhsOcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) - _lhsOcollectedSetNames :: (Set Name) - _lhsOcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) - _lhsOderivings :: Derivings - _lhsOerrors :: (Seq Error) - _lhsOmoduleDecl :: (Maybe (String,String,String)) - _lhsOorderDepErrorsCollect :: (Seq Error) - _lhsOpragmas :: (Options -> Options) - _lhsOsemPragmasCollect :: PragmaMap - _lhsOuseMap :: (Map Nonterminal (Map Name (String,String,String))) - _lhsOwrappers :: (Set Nonterminal) - _lhsOattrDecls :: (Map Nonterminal (Attributes, Attributes)) - _lhsOdefSets :: (Map Name (Set Nonterminal,Set Name)) - -- "Transform.ag"(line 212, column 10) - _lhsOcollectedFields = - map (\(x,y)->(name_, x, y)) _expanded - -- "Transform.ag"(line 337, column 11) - _lhsOcollectedNames = - Set.singleton name_ - -- "Transform.ag"(line 391, column 11) - _expanded = - case _argType of - List tp -> [(Ident "Cons" pos_, [(Ident "hd" pos_, tp) - ,(Ident "tl" pos_, NT name_) - ] - ) - ,(Ident "Nil" pos_, []) - ] - Maybe tp -> [(Ident "Just" pos_, [(Ident "just" pos_, tp) - ] - ) - ,(Ident "Nothing" pos_, []) - ] - Tuple xs -> [(Ident "Tuple" pos_, xs)] - -- "Transform.ag"(line 404, column 11) - _argType = - case type_ of - Maybe tp -> Maybe ( makeType _lhsIallNonterminals tp) - List tp -> List ( makeType _lhsIallNonterminals tp) - Tuple xs -> Tuple [(f,makeType _lhsIallNonterminals tp) | (f,tp) <- xs] - -- "Transform.ag"(line 408, column 11) - _lhsOtypeSyns = - [(name_,_argType)] - -- use rule "Transform.ag"(line 560, column 55) - _lhsOattrOrderCollect = - Map.empty - -- use rule "Transform.ag"(line 38, column 19) - _lhsOblocks = - Map.empty - -- use rule "Transform.ag"(line 81, column 48) - _lhsOcollectedConstructorsMap = - Map.empty - -- use rule "Transform.ag"(line 136, column 29) - _lhsOcollectedInsts = - [] - -- use rule "Transform.ag"(line 134, column 29) - _lhsOcollectedRules = - [] - -- use rule "Transform.ag"(line 72, column 50) - _lhsOcollectedSetNames = - Set.empty - -- use rule "Transform.ag"(line 135, column 29) - _lhsOcollectedSigs = - [] - -- use rule "Transform.ag"(line 593, column 33) - _lhsOderivings = - Map.empty - -- use rule "Transform.ag"(line 36, column 19) - _lhsOerrors = - Seq.empty - -- use rule "Transform.ag"(line 734, column 37) - _lhsOmoduleDecl = - mzero - -- use rule "Transform.ag"(line 561, column 60) - _lhsOorderDepErrorsCollect = - Seq.empty - -- use rule "Transform.ag"(line 499, column 34) - _lhsOpragmas = - id - -- use rule "Transform.ag"(line 532, column 56) - _lhsOsemPragmasCollect = - Map.empty - -- use rule "Transform.ag"(line 124, column 15) - _lhsOuseMap = - Map.empty - -- use rule "Transform.ag"(line 490, column 32) - _lhsOwrappers = - Set.empty - -- copy rule (chain) - _lhsOattrDecls = - _lhsIattrDecls - -- copy rule (chain) - _lhsOdefSets = - _lhsIdefSets - in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOorderDepErrorsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) -sem_Elem_Wrapper :: Pos -> - T_NontSet -> - T_Elem -sem_Elem_Wrapper pos_ (T_NontSet set_) = - (T_Elem (\ _lhsIallAttrDecls - _lhsIallConstructors - _lhsIallFields - _lhsIallNonterminals - _lhsIattrDecls - _lhsIdefSets - _lhsIdefinedSets -> - (let _lhsOwrappers :: (Set Nonterminal) - _lhsOattrOrderCollect :: AttrOrderMap - _lhsOblocks :: Blocks - _lhsOcollectedConstructorsMap :: (Map Nonterminal (Set Constructor)) - _lhsOcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) - _lhsOcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) - _lhsOcollectedNames :: (Set Name) - _lhsOcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) - _lhsOcollectedSetNames :: (Set Name) - _lhsOcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) - _lhsOderivings :: Derivings - _lhsOerrors :: (Seq Error) - _lhsOmoduleDecl :: (Maybe (String,String,String)) - _lhsOorderDepErrorsCollect :: (Seq Error) - _lhsOpragmas :: (Options -> Options) - _lhsOsemPragmasCollect :: PragmaMap - _lhsOtypeSyns :: TypeSyns - _lhsOuseMap :: (Map Nonterminal (Map Name (String,String,String))) - _lhsOattrDecls :: (Map Nonterminal (Attributes, Attributes)) - _lhsOdefSets :: (Map Name (Set Nonterminal,Set Name)) - _setOallFields :: DataTypes - _setOallNonterminals :: (Set Nonterminal) - _setOdefinedSets :: DefinedSets - _setIcollectedNames :: (Set Name) - _setIerrors :: (Seq Error) - _setInontSet :: (Set Nonterminal) - -- "Transform.ag"(line 493, column 13) - _lhsOwrappers = - _setInontSet - -- use rule "Transform.ag"(line 560, column 55) - _lhsOattrOrderCollect = - Map.empty - -- use rule "Transform.ag"(line 38, column 19) - _lhsOblocks = - Map.empty - -- use rule "Transform.ag"(line 81, column 48) - _lhsOcollectedConstructorsMap = - Map.empty - -- use rule "Transform.ag"(line 112, column 28) - _lhsOcollectedFields = - [] - -- use rule "Transform.ag"(line 136, column 29) - _lhsOcollectedInsts = - [] - -- use rule "Transform.ag"(line 73, column 50) - _lhsOcollectedNames = - _setIcollectedNames - -- use rule "Transform.ag"(line 134, column 29) - _lhsOcollectedRules = - [] - -- use rule "Transform.ag"(line 72, column 50) - _lhsOcollectedSetNames = - Set.empty - -- use rule "Transform.ag"(line 135, column 29) - _lhsOcollectedSigs = - [] - -- use rule "Transform.ag"(line 593, column 33) - _lhsOderivings = - Map.empty - -- use rule "Transform.ag"(line 36, column 19) - _lhsOerrors = - _setIerrors - -- use rule "Transform.ag"(line 734, column 37) - _lhsOmoduleDecl = - mzero - -- use rule "Transform.ag"(line 561, column 60) - _lhsOorderDepErrorsCollect = - Seq.empty - -- use rule "Transform.ag"(line 499, column 34) - _lhsOpragmas = - id - -- use rule "Transform.ag"(line 532, column 56) - _lhsOsemPragmasCollect = - Map.empty - -- use rule "Transform.ag"(line 378, column 32) - _lhsOtypeSyns = - [] - -- use rule "Transform.ag"(line 124, column 15) - _lhsOuseMap = - Map.empty - -- copy rule (chain) - _lhsOattrDecls = - _lhsIattrDecls - -- copy rule (chain) - _lhsOdefSets = - _lhsIdefSets - -- copy rule (down) - _setOallFields = - _lhsIallFields - -- copy rule (down) - _setOallNonterminals = - _lhsIallNonterminals - -- copy rule (down) - _setOdefinedSets = - _lhsIdefinedSets - ( _setIcollectedNames,_setIerrors,_setInontSet) = - (set_ _setOallFields _setOallNonterminals _setOdefinedSets) - in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOorderDepErrorsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) --- Elems ------------------------------------------------------- -{- - visit 0: - inherited attributes: - allAttrDecls : Map Nonterminal (Attributes, Attributes) - allConstructors : Map Nonterminal (Set Constructor) - allFields : DataTypes - allNonterminals : Set Nonterminal - definedSets : DefinedSets - chained attributes: - attrDecls : Map Nonterminal (Attributes, Attributes) - defSets : Map Name (Set Nonterminal,Set Name) - synthesized attributes: - attrOrderCollect : AttrOrderMap - blocks : Blocks - collectedConstructorsMap : Map Nonterminal (Set Constructor) - collectedFields : [(Nonterminal, Constructor, FieldMap)] - collectedInsts : [ (Nonterminal, Constructor, [Identifier]) ] - collectedNames : Set Name - collectedRules : [ (Nonterminal, Constructor, RuleInfo)] - collectedSetNames : Set Name - collectedSigs : [ (Nonterminal, Constructor, SigInfo) ] - derivings : Derivings - errors : Seq Error - moduleDecl : Maybe (String,String,String) - orderDepErrorsCollect : Seq Error - pragmas : Options -> Options - semPragmasCollect : PragmaMap - typeSyns : TypeSyns - useMap : Map Nonterminal (Map Name (String,String,String)) - wrappers : Set Nonterminal - alternatives: - alternative Cons: - child hd : Elem - child tl : Elems - alternative Nil: --} --- cata -sem_Elems :: Elems -> - T_Elems -sem_Elems list = - (Prelude.foldr sem_Elems_Cons sem_Elems_Nil (Prelude.map sem_Elem list)) --- semantic domain -newtype T_Elems = T_Elems ((Map Nonterminal (Attributes, Attributes)) -> - (Map Nonterminal (Set Constructor)) -> - DataTypes -> - (Set Nonterminal) -> - (Map Nonterminal (Attributes, Attributes)) -> - (Map Name (Set Nonterminal,Set Name)) -> - DefinedSets -> - ( (Map Nonterminal (Attributes, Attributes)),AttrOrderMap,Blocks,(Map Nonterminal (Set Constructor)),([(Nonterminal, Constructor, FieldMap)]),([ (Nonterminal, Constructor, [Identifier]) ]),(Set Name),([ (Nonterminal, Constructor, RuleInfo)]),(Set Name),([ (Nonterminal, Constructor, SigInfo) ]),(Map Name (Set Nonterminal,Set Name)),Derivings,(Seq Error),(Maybe (String,String,String)),(Seq Error),(Options -> Options),PragmaMap,TypeSyns,(Map Nonterminal (Map Name (String,String,String))),(Set Nonterminal))) -data Inh_Elems = Inh_Elems {allAttrDecls_Inh_Elems :: Map Nonterminal (Attributes, Attributes),allConstructors_Inh_Elems :: Map Nonterminal (Set Constructor),allFields_Inh_Elems :: DataTypes,allNonterminals_Inh_Elems :: Set Nonterminal,attrDecls_Inh_Elems :: Map Nonterminal (Attributes, Attributes),defSets_Inh_Elems :: Map Name (Set Nonterminal,Set Name),definedSets_Inh_Elems :: DefinedSets} -data Syn_Elems = Syn_Elems {attrDecls_Syn_Elems :: Map Nonterminal (Attributes, Attributes),attrOrderCollect_Syn_Elems :: AttrOrderMap,blocks_Syn_Elems :: Blocks,collectedConstructorsMap_Syn_Elems :: Map Nonterminal (Set Constructor),collectedFields_Syn_Elems :: [(Nonterminal, Constructor, FieldMap)],collectedInsts_Syn_Elems :: [ (Nonterminal, Constructor, [Identifier]) ],collectedNames_Syn_Elems :: Set Name,collectedRules_Syn_Elems :: [ (Nonterminal, Constructor, RuleInfo)],collectedSetNames_Syn_Elems :: Set Name,collectedSigs_Syn_Elems :: [ (Nonterminal, Constructor, SigInfo) ],defSets_Syn_Elems :: Map Name (Set Nonterminal,Set Name),derivings_Syn_Elems :: Derivings,errors_Syn_Elems :: Seq Error,moduleDecl_Syn_Elems :: Maybe (String,String,String),orderDepErrorsCollect_Syn_Elems :: Seq Error,pragmas_Syn_Elems :: Options -> Options,semPragmasCollect_Syn_Elems :: PragmaMap,typeSyns_Syn_Elems :: TypeSyns,useMap_Syn_Elems :: Map Nonterminal (Map Name (String,String,String)),wrappers_Syn_Elems :: Set Nonterminal} -wrap_Elems (T_Elems sem) (Inh_Elems _lhsIallAttrDecls _lhsIallConstructors _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsIdefSets _lhsIdefinedSets) = - (let ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOorderDepErrorsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers) = - (sem _lhsIallAttrDecls _lhsIallConstructors _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsIdefSets _lhsIdefinedSets) - in (Syn_Elems _lhsOattrDecls _lhsOattrOrderCollect _lhsOblocks _lhsOcollectedConstructorsMap _lhsOcollectedFields _lhsOcollectedInsts _lhsOcollectedNames _lhsOcollectedRules _lhsOcollectedSetNames _lhsOcollectedSigs _lhsOdefSets _lhsOderivings _lhsOerrors _lhsOmoduleDecl _lhsOorderDepErrorsCollect _lhsOpragmas _lhsOsemPragmasCollect _lhsOtypeSyns _lhsOuseMap _lhsOwrappers)) -sem_Elems_Cons :: T_Elem -> - T_Elems -> - T_Elems -sem_Elems_Cons (T_Elem hd_) (T_Elems tl_) = - (T_Elems (\ _lhsIallAttrDecls - _lhsIallConstructors - _lhsIallFields - _lhsIallNonterminals - _lhsIattrDecls - _lhsIdefSets - _lhsIdefinedSets -> - (let _lhsOattrOrderCollect :: AttrOrderMap - _lhsOblocks :: Blocks - _lhsOcollectedConstructorsMap :: (Map Nonterminal (Set Constructor)) - _lhsOcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) - _lhsOcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) - _lhsOcollectedNames :: (Set Name) - _lhsOcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) - _lhsOcollectedSetNames :: (Set Name) - _lhsOcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) - _lhsOderivings :: Derivings - _lhsOerrors :: (Seq Error) - _lhsOmoduleDecl :: (Maybe (String,String,String)) - _lhsOorderDepErrorsCollect :: (Seq Error) - _lhsOpragmas :: (Options -> Options) - _lhsOsemPragmasCollect :: PragmaMap - _lhsOtypeSyns :: TypeSyns - _lhsOuseMap :: (Map Nonterminal (Map Name (String,String,String))) - _lhsOwrappers :: (Set Nonterminal) - _lhsOattrDecls :: (Map Nonterminal (Attributes, Attributes)) - _lhsOdefSets :: (Map Name (Set Nonterminal,Set Name)) - _hdOallAttrDecls :: (Map Nonterminal (Attributes, Attributes)) - _hdOallConstructors :: (Map Nonterminal (Set Constructor)) - _hdOallFields :: DataTypes - _hdOallNonterminals :: (Set Nonterminal) - _hdOattrDecls :: (Map Nonterminal (Attributes, Attributes)) - _hdOdefSets :: (Map Name (Set Nonterminal,Set Name)) - _hdOdefinedSets :: DefinedSets - _tlOallAttrDecls :: (Map Nonterminal (Attributes, Attributes)) - _tlOallConstructors :: (Map Nonterminal (Set Constructor)) - _tlOallFields :: DataTypes - _tlOallNonterminals :: (Set Nonterminal) - _tlOattrDecls :: (Map Nonterminal (Attributes, Attributes)) - _tlOdefSets :: (Map Name (Set Nonterminal,Set Name)) - _tlOdefinedSets :: DefinedSets - _hdIattrDecls :: (Map Nonterminal (Attributes, Attributes)) - _hdIattrOrderCollect :: AttrOrderMap - _hdIblocks :: Blocks - _hdIcollectedConstructorsMap :: (Map Nonterminal (Set Constructor)) - _hdIcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) - _hdIcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) - _hdIcollectedNames :: (Set Name) - _hdIcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) - _hdIcollectedSetNames :: (Set Name) - _hdIcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) - _hdIdefSets :: (Map Name (Set Nonterminal,Set Name)) - _hdIderivings :: Derivings - _hdIerrors :: (Seq Error) - _hdImoduleDecl :: (Maybe (String,String,String)) - _hdIorderDepErrorsCollect :: (Seq Error) - _hdIpragmas :: (Options -> Options) - _hdIsemPragmasCollect :: PragmaMap - _hdItypeSyns :: TypeSyns - _hdIuseMap :: (Map Nonterminal (Map Name (String,String,String))) - _hdIwrappers :: (Set Nonterminal) - _tlIattrDecls :: (Map Nonterminal (Attributes, Attributes)) - _tlIattrOrderCollect :: AttrOrderMap - _tlIblocks :: Blocks - _tlIcollectedConstructorsMap :: (Map Nonterminal (Set Constructor)) - _tlIcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) - _tlIcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) - _tlIcollectedNames :: (Set Name) - _tlIcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) - _tlIcollectedSetNames :: (Set Name) - _tlIcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) - _tlIdefSets :: (Map Name (Set Nonterminal,Set Name)) - _tlIderivings :: Derivings - _tlIerrors :: (Seq Error) - _tlImoduleDecl :: (Maybe (String,String,String)) - _tlIorderDepErrorsCollect :: (Seq Error) - _tlIpragmas :: (Options -> Options) - _tlIsemPragmasCollect :: PragmaMap - _tlItypeSyns :: TypeSyns - _tlIuseMap :: (Map Nonterminal (Map Name (String,String,String))) - _tlIwrappers :: (Set Nonterminal) - -- use rule "Transform.ag"(line 560, column 55) - _lhsOattrOrderCollect = - _hdIattrOrderCollect `orderMapUnion` _tlIattrOrderCollect - -- use rule "Transform.ag"(line 38, column 19) - _lhsOblocks = - _hdIblocks `mapUnionWithPlusPlus` _tlIblocks - -- use rule "Transform.ag"(line 81, column 48) - _lhsOcollectedConstructorsMap = - _hdIcollectedConstructorsMap `mapUnionWithSetUnion` _tlIcollectedConstructorsMap - -- use rule "Transform.ag"(line 112, column 28) - _lhsOcollectedFields = - _hdIcollectedFields ++ _tlIcollectedFields - -- use rule "Transform.ag"(line 136, column 29) - _lhsOcollectedInsts = - _hdIcollectedInsts ++ _tlIcollectedInsts - -- use rule "Transform.ag"(line 73, column 50) - _lhsOcollectedNames = - _hdIcollectedNames `Set.union` _tlIcollectedNames - -- use rule "Transform.ag"(line 134, column 29) - _lhsOcollectedRules = - _hdIcollectedRules ++ _tlIcollectedRules - -- use rule "Transform.ag"(line 72, column 50) - _lhsOcollectedSetNames = - _hdIcollectedSetNames `Set.union` _tlIcollectedSetNames - -- use rule "Transform.ag"(line 135, column 29) - _lhsOcollectedSigs = - _hdIcollectedSigs ++ _tlIcollectedSigs - -- use rule "Transform.ag"(line 593, column 33) - _lhsOderivings = - _hdIderivings `mergeDerivings` _tlIderivings - -- use rule "Transform.ag"(line 36, column 19) - _lhsOerrors = - _hdIerrors Seq.<> _tlIerrors - -- use rule "Transform.ag"(line 734, column 37) - _lhsOmoduleDecl = - _hdImoduleDecl `mplus` _tlImoduleDecl - -- use rule "Transform.ag"(line 561, column 60) - _lhsOorderDepErrorsCollect = - _hdIorderDepErrorsCollect Seq.<> _tlIorderDepErrorsCollect - -- use rule "Transform.ag"(line 499, column 34) - _lhsOpragmas = - _hdIpragmas . _tlIpragmas - -- use rule "Transform.ag"(line 532, column 56) - _lhsOsemPragmasCollect = - _hdIsemPragmasCollect `pragmaMapUnion` _tlIsemPragmasCollect - -- use rule "Transform.ag"(line 378, column 32) - _lhsOtypeSyns = - _hdItypeSyns ++ _tlItypeSyns - -- use rule "Transform.ag"(line 124, column 15) - _lhsOuseMap = - _hdIuseMap `merge` _tlIuseMap - -- use rule "Transform.ag"(line 490, column 32) - _lhsOwrappers = - _hdIwrappers `Set.union` _tlIwrappers - -- copy rule (up) - _lhsOattrDecls = - _tlIattrDecls - -- copy rule (up) - _lhsOdefSets = - _tlIdefSets - -- copy rule (down) - _hdOallAttrDecls = - _lhsIallAttrDecls - -- copy rule (down) - _hdOallConstructors = - _lhsIallConstructors - -- copy rule (down) - _hdOallFields = - _lhsIallFields - -- copy rule (down) - _hdOallNonterminals = - _lhsIallNonterminals - -- copy rule (down) - _hdOattrDecls = - _lhsIattrDecls - -- copy rule (down) - _hdOdefSets = - _lhsIdefSets - -- copy rule (down) - _hdOdefinedSets = - _lhsIdefinedSets - -- copy rule (down) - _tlOallAttrDecls = - _lhsIallAttrDecls - -- copy rule (down) - _tlOallConstructors = - _lhsIallConstructors - -- copy rule (down) - _tlOallFields = - _lhsIallFields - -- copy rule (down) - _tlOallNonterminals = - _lhsIallNonterminals - -- copy rule (chain) - _tlOattrDecls = - _hdIattrDecls - -- copy rule (chain) - _tlOdefSets = - _hdIdefSets - -- copy rule (down) - _tlOdefinedSets = - _lhsIdefinedSets - ( _hdIattrDecls,_hdIattrOrderCollect,_hdIblocks,_hdIcollectedConstructorsMap,_hdIcollectedFields,_hdIcollectedInsts,_hdIcollectedNames,_hdIcollectedRules,_hdIcollectedSetNames,_hdIcollectedSigs,_hdIdefSets,_hdIderivings,_hdIerrors,_hdImoduleDecl,_hdIorderDepErrorsCollect,_hdIpragmas,_hdIsemPragmasCollect,_hdItypeSyns,_hdIuseMap,_hdIwrappers) = - (hd_ _hdOallAttrDecls _hdOallConstructors _hdOallFields _hdOallNonterminals _hdOattrDecls _hdOdefSets _hdOdefinedSets) - ( _tlIattrDecls,_tlIattrOrderCollect,_tlIblocks,_tlIcollectedConstructorsMap,_tlIcollectedFields,_tlIcollectedInsts,_tlIcollectedNames,_tlIcollectedRules,_tlIcollectedSetNames,_tlIcollectedSigs,_tlIdefSets,_tlIderivings,_tlIerrors,_tlImoduleDecl,_tlIorderDepErrorsCollect,_tlIpragmas,_tlIsemPragmasCollect,_tlItypeSyns,_tlIuseMap,_tlIwrappers) = - (tl_ _tlOallAttrDecls _tlOallConstructors _tlOallFields _tlOallNonterminals _tlOattrDecls _tlOdefSets _tlOdefinedSets) - in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOorderDepErrorsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) -sem_Elems_Nil :: T_Elems -sem_Elems_Nil = - (T_Elems (\ _lhsIallAttrDecls - _lhsIallConstructors - _lhsIallFields - _lhsIallNonterminals - _lhsIattrDecls - _lhsIdefSets - _lhsIdefinedSets -> - (let _lhsOattrOrderCollect :: AttrOrderMap - _lhsOblocks :: Blocks - _lhsOcollectedConstructorsMap :: (Map Nonterminal (Set Constructor)) - _lhsOcollectedFields :: ([(Nonterminal, Constructor, FieldMap)]) - _lhsOcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) - _lhsOcollectedNames :: (Set Name) - _lhsOcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) - _lhsOcollectedSetNames :: (Set Name) - _lhsOcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) - _lhsOderivings :: Derivings - _lhsOerrors :: (Seq Error) - _lhsOmoduleDecl :: (Maybe (String,String,String)) - _lhsOorderDepErrorsCollect :: (Seq Error) - _lhsOpragmas :: (Options -> Options) - _lhsOsemPragmasCollect :: PragmaMap - _lhsOtypeSyns :: TypeSyns - _lhsOuseMap :: (Map Nonterminal (Map Name (String,String,String))) - _lhsOwrappers :: (Set Nonterminal) - _lhsOattrDecls :: (Map Nonterminal (Attributes, Attributes)) - _lhsOdefSets :: (Map Name (Set Nonterminal,Set Name)) - -- use rule "Transform.ag"(line 560, column 55) - _lhsOattrOrderCollect = - Map.empty - -- use rule "Transform.ag"(line 38, column 19) - _lhsOblocks = - Map.empty - -- use rule "Transform.ag"(line 81, column 48) - _lhsOcollectedConstructorsMap = - Map.empty - -- use rule "Transform.ag"(line 112, column 28) - _lhsOcollectedFields = - [] - -- use rule "Transform.ag"(line 136, column 29) - _lhsOcollectedInsts = - [] - -- use rule "Transform.ag"(line 73, column 50) - _lhsOcollectedNames = - Set.empty - -- use rule "Transform.ag"(line 134, column 29) - _lhsOcollectedRules = - [] - -- use rule "Transform.ag"(line 72, column 50) - _lhsOcollectedSetNames = - Set.empty - -- use rule "Transform.ag"(line 135, column 29) - _lhsOcollectedSigs = - [] - -- use rule "Transform.ag"(line 593, column 33) - _lhsOderivings = - Map.empty - -- use rule "Transform.ag"(line 36, column 19) - _lhsOerrors = - Seq.empty - -- use rule "Transform.ag"(line 734, column 37) - _lhsOmoduleDecl = - mzero - -- use rule "Transform.ag"(line 561, column 60) - _lhsOorderDepErrorsCollect = - Seq.empty - -- use rule "Transform.ag"(line 499, column 34) - _lhsOpragmas = - id - -- use rule "Transform.ag"(line 532, column 56) - _lhsOsemPragmasCollect = - Map.empty - -- use rule "Transform.ag"(line 378, column 32) - _lhsOtypeSyns = - [] - -- use rule "Transform.ag"(line 124, column 15) - _lhsOuseMap = - Map.empty - -- use rule "Transform.ag"(line 490, column 32) - _lhsOwrappers = - Set.empty - -- copy rule (chain) - _lhsOattrDecls = - _lhsIattrDecls - -- copy rule (chain) - _lhsOdefSets = - _lhsIdefSets - in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOorderDepErrorsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) --- NontSet ----------------------------------------------------- -{- - visit 0: - inherited attributes: - allFields : DataTypes - allNonterminals : Set Nonterminal - definedSets : DefinedSets - synthesized attributes: - collectedNames : Set Name - errors : Seq Error - nontSet : Set Nonterminal - alternatives: - alternative All: - alternative Difference: - child set1 : NontSet - child set2 : NontSet - alternative Intersect: - child set1 : NontSet - child set2 : NontSet - alternative NamedSet: - child name : {Nonterminal} - visit 0: - local _tup4 : _ - local nontSet : _ - local errors : _ - alternative Path: - child from : {Nonterminal} - child to : {Nonterminal} - alternative Union: - child set1 : NontSet - child set2 : NontSet --} --- cata -sem_NontSet :: NontSet -> - T_NontSet -sem_NontSet (All ) = - (sem_NontSet_All ) -sem_NontSet (Difference _set1 _set2) = - (sem_NontSet_Difference (sem_NontSet _set1) (sem_NontSet _set2)) -sem_NontSet (Intersect _set1 _set2) = - (sem_NontSet_Intersect (sem_NontSet _set1) (sem_NontSet _set2)) -sem_NontSet (NamedSet _name) = - (sem_NontSet_NamedSet _name) -sem_NontSet (Path _from _to) = - (sem_NontSet_Path _from _to) -sem_NontSet (Union _set1 _set2) = - (sem_NontSet_Union (sem_NontSet _set1) (sem_NontSet _set2)) --- semantic domain -newtype T_NontSet = T_NontSet (DataTypes -> - (Set Nonterminal) -> - DefinedSets -> - ( (Set Name),(Seq Error),(Set Nonterminal))) -data Inh_NontSet = Inh_NontSet {allFields_Inh_NontSet :: DataTypes,allNonterminals_Inh_NontSet :: Set Nonterminal,definedSets_Inh_NontSet :: DefinedSets} -data Syn_NontSet = Syn_NontSet {collectedNames_Syn_NontSet :: Set Name,errors_Syn_NontSet :: Seq Error,nontSet_Syn_NontSet :: Set Nonterminal} -wrap_NontSet (T_NontSet sem) (Inh_NontSet _lhsIallFields _lhsIallNonterminals _lhsIdefinedSets) = - (let ( _lhsOcollectedNames,_lhsOerrors,_lhsOnontSet) = - (sem _lhsIallFields _lhsIallNonterminals _lhsIdefinedSets) - in (Syn_NontSet _lhsOcollectedNames _lhsOerrors _lhsOnontSet)) -sem_NontSet_All :: T_NontSet -sem_NontSet_All = - (T_NontSet (\ _lhsIallFields - _lhsIallNonterminals - _lhsIdefinedSets -> - (let _lhsOnontSet :: (Set Nonterminal) - _lhsOcollectedNames :: (Set Name) - _lhsOerrors :: (Seq Error) - -- "Transform.ag"(line 436, column 16) - _lhsOnontSet = - _lhsIallNonterminals - -- use rule "Transform.ag"(line 73, column 50) - _lhsOcollectedNames = - Set.empty - -- use rule "Transform.ag"(line 36, column 19) - _lhsOerrors = - Seq.empty - in ( _lhsOcollectedNames,_lhsOerrors,_lhsOnontSet)))) -sem_NontSet_Difference :: T_NontSet -> - T_NontSet -> - T_NontSet -sem_NontSet_Difference (T_NontSet set1_) (T_NontSet set2_) = - (T_NontSet (\ _lhsIallFields - _lhsIallNonterminals - _lhsIdefinedSets -> - (let _lhsOnontSet :: (Set Nonterminal) - _lhsOcollectedNames :: (Set Name) - _lhsOerrors :: (Seq Error) - _set1OallFields :: DataTypes - _set1OallNonterminals :: (Set Nonterminal) - _set1OdefinedSets :: DefinedSets - _set2OallFields :: DataTypes - _set2OallNonterminals :: (Set Nonterminal) - _set2OdefinedSets :: DefinedSets - _set1IcollectedNames :: (Set Name) - _set1Ierrors :: (Seq Error) - _set1InontSet :: (Set Nonterminal) - _set2IcollectedNames :: (Set Name) - _set2Ierrors :: (Seq Error) - _set2InontSet :: (Set Nonterminal) - -- "Transform.ag"(line 442, column 16) - _lhsOnontSet = - Set.difference _set1InontSet _set2InontSet - -- use rule "Transform.ag"(line 73, column 50) - _lhsOcollectedNames = - _set1IcollectedNames `Set.union` _set2IcollectedNames - -- use rule "Transform.ag"(line 36, column 19) - _lhsOerrors = - _set1Ierrors Seq.<> _set2Ierrors - -- copy rule (down) - _set1OallFields = - _lhsIallFields - -- copy rule (down) - _set1OallNonterminals = - _lhsIallNonterminals - -- copy rule (down) - _set1OdefinedSets = - _lhsIdefinedSets - -- copy rule (down) - _set2OallFields = - _lhsIallFields - -- copy rule (down) - _set2OallNonterminals = - _lhsIallNonterminals - -- copy rule (down) - _set2OdefinedSets = - _lhsIdefinedSets - ( _set1IcollectedNames,_set1Ierrors,_set1InontSet) = - (set1_ _set1OallFields _set1OallNonterminals _set1OdefinedSets) - ( _set2IcollectedNames,_set2Ierrors,_set2InontSet) = - (set2_ _set2OallFields _set2OallNonterminals _set2OdefinedSets) - in ( _lhsOcollectedNames,_lhsOerrors,_lhsOnontSet)))) -sem_NontSet_Intersect :: T_NontSet -> - T_NontSet -> - T_NontSet -sem_NontSet_Intersect (T_NontSet set1_) (T_NontSet set2_) = - (T_NontSet (\ _lhsIallFields - _lhsIallNonterminals - _lhsIdefinedSets -> - (let _lhsOnontSet :: (Set Nonterminal) - _lhsOcollectedNames :: (Set Name) - _lhsOerrors :: (Seq Error) - _set1OallFields :: DataTypes - _set1OallNonterminals :: (Set Nonterminal) - _set1OdefinedSets :: DefinedSets - _set2OallFields :: DataTypes - _set2OallNonterminals :: (Set Nonterminal) - _set2OdefinedSets :: DefinedSets - _set1IcollectedNames :: (Set Name) - _set1Ierrors :: (Seq Error) - _set1InontSet :: (Set Nonterminal) - _set2IcollectedNames :: (Set Name) - _set2Ierrors :: (Seq Error) - _set2InontSet :: (Set Nonterminal) - -- "Transform.ag"(line 441, column 16) - _lhsOnontSet = - Set.intersection _set1InontSet _set2InontSet - -- use rule "Transform.ag"(line 73, column 50) - _lhsOcollectedNames = - _set1IcollectedNames `Set.union` _set2IcollectedNames - -- use rule "Transform.ag"(line 36, column 19) - _lhsOerrors = - _set1Ierrors Seq.<> _set2Ierrors - -- copy rule (down) - _set1OallFields = - _lhsIallFields - -- copy rule (down) - _set1OallNonterminals = - _lhsIallNonterminals - -- copy rule (down) - _set1OdefinedSets = - _lhsIdefinedSets - -- copy rule (down) - _set2OallFields = - _lhsIallFields - -- copy rule (down) - _set2OallNonterminals = - _lhsIallNonterminals - -- copy rule (down) - _set2OdefinedSets = - _lhsIdefinedSets - ( _set1IcollectedNames,_set1Ierrors,_set1InontSet) = - (set1_ _set1OallFields _set1OallNonterminals _set1OdefinedSets) - ( _set2IcollectedNames,_set2Ierrors,_set2InontSet) = - (set2_ _set2OallFields _set2OallNonterminals _set2OdefinedSets) - in ( _lhsOcollectedNames,_lhsOerrors,_lhsOnontSet)))) -sem_NontSet_NamedSet :: Nonterminal -> - T_NontSet -sem_NontSet_NamedSet name_ = - (T_NontSet (\ _lhsIallFields - _lhsIallNonterminals - _lhsIdefinedSets -> - (let _lhsOcollectedNames :: (Set Name) - _lhsOerrors :: (Seq Error) - _lhsOnontSet :: (Set Nonterminal) - -- "Transform.ag"(line 340, column 14) - _lhsOcollectedNames = - Set.singleton name_ - -- "Transform.ag"(line 437, column 20) - __tup4 = - case Map.lookup name_ _lhsIdefinedSets of - Nothing -> (Set.empty, Seq.single (UndefNont name_)) - Just set -> (set, Seq.empty) - -- "Transform.ag"(line 437, column 20) - (_nontSet,_) = - __tup4 - -- "Transform.ag"(line 437, column 20) - (_,_errors) = - __tup4 - -- use rule "Transform.ag"(line 36, column 19) - _lhsOerrors = - _errors - -- copy rule (from local) - _lhsOnontSet = - _nontSet - in ( _lhsOcollectedNames,_lhsOerrors,_lhsOnontSet)))) -sem_NontSet_Path :: Nonterminal -> - Nonterminal -> - T_NontSet -sem_NontSet_Path from_ to_ = - (T_NontSet (\ _lhsIallFields - _lhsIallNonterminals - _lhsIdefinedSets -> - (let _lhsOnontSet :: (Set Nonterminal) - _lhsOerrors :: (Seq Error) - _lhsOcollectedNames :: (Set Name) - -- "Transform.ag"(line 443, column 16) - _lhsOnontSet = - let table = flattenDatas _lhsIallFields - in path table from_ to_ - -- "Transform.ag"(line 445, column 16) - _lhsOerrors = - let check name | Set.member name _lhsIallNonterminals - = Seq.empty - | otherwise = Seq.single (UndefNont name) - in check from_ <> check to_ - -- use rule "Transform.ag"(line 73, column 50) - _lhsOcollectedNames = - Set.empty - in ( _lhsOcollectedNames,_lhsOerrors,_lhsOnontSet)))) -sem_NontSet_Union :: T_NontSet -> - T_NontSet -> - T_NontSet -sem_NontSet_Union (T_NontSet set1_) (T_NontSet set2_) = - (T_NontSet (\ _lhsIallFields - _lhsIallNonterminals - _lhsIdefinedSets -> - (let _lhsOnontSet :: (Set Nonterminal) - _lhsOcollectedNames :: (Set Name) - _lhsOerrors :: (Seq Error) - _set1OallFields :: DataTypes - _set1OallNonterminals :: (Set Nonterminal) - _set1OdefinedSets :: DefinedSets - _set2OallFields :: DataTypes - _set2OallNonterminals :: (Set Nonterminal) - _set2OdefinedSets :: DefinedSets - _set1IcollectedNames :: (Set Name) - _set1Ierrors :: (Seq Error) - _set1InontSet :: (Set Nonterminal) - _set2IcollectedNames :: (Set Name) - _set2Ierrors :: (Seq Error) - _set2InontSet :: (Set Nonterminal) - -- "Transform.ag"(line 440, column 16) - _lhsOnontSet = - Set.union _set1InontSet _set2InontSet - -- use rule "Transform.ag"(line 73, column 50) - _lhsOcollectedNames = - _set1IcollectedNames `Set.union` _set2IcollectedNames - -- use rule "Transform.ag"(line 36, column 19) - _lhsOerrors = - _set1Ierrors Seq.<> _set2Ierrors - -- copy rule (down) - _set1OallFields = - _lhsIallFields - -- copy rule (down) - _set1OallNonterminals = - _lhsIallNonterminals - -- copy rule (down) - _set1OdefinedSets = - _lhsIdefinedSets - -- copy rule (down) - _set2OallFields = - _lhsIallFields - -- copy rule (down) - _set2OallNonterminals = - _lhsIallNonterminals - -- copy rule (down) - _set2OdefinedSets = - _lhsIdefinedSets - ( _set1IcollectedNames,_set1Ierrors,_set1InontSet) = - (set1_ _set1OallFields _set1OallNonterminals _set1OdefinedSets) - ( _set2IcollectedNames,_set2Ierrors,_set2InontSet) = - (set2_ _set2OallFields _set2OallNonterminals _set2OdefinedSets) - in ( _lhsOcollectedNames,_lhsOerrors,_lhsOnontSet)))) --- Pattern ----------------------------------------------------- -{- - visit 0: - synthesized attributes: - copy : SELF - definedAttrs : [AttrName] - definedInsts : [Identifier] - patunder : [AttrName]->Pattern - stpos : Pos - alternatives: - alternative Alias: - child field : {Name} - child attr : {Name} - child pat : Pattern - child parts : Patterns - visit 0: - local copy : _ - alternative Constr: - child name : {Constructor} - child pats : Patterns - visit 0: - local copy : _ - alternative Product: - child pos : {Pos} - child pats : Patterns - visit 0: - local copy : _ - alternative Underscore: - child pos : {Pos} - visit 0: - local copy : _ --} --- cata -sem_Pattern :: Pattern -> - T_Pattern -sem_Pattern (Alias _field _attr _pat _parts) = - (sem_Pattern_Alias _field _attr (sem_Pattern _pat) (sem_Patterns _parts)) -sem_Pattern (Constr _name _pats) = - (sem_Pattern_Constr _name (sem_Patterns _pats)) -sem_Pattern (Product _pos _pats) = - (sem_Pattern_Product _pos (sem_Patterns _pats)) -sem_Pattern (Underscore _pos) = - (sem_Pattern_Underscore _pos) --- semantic domain -newtype T_Pattern = T_Pattern (( Pattern,([AttrName]),([Identifier]),([AttrName]->Pattern),Pos)) -data Inh_Pattern = Inh_Pattern {} -data Syn_Pattern = Syn_Pattern {copy_Syn_Pattern :: Pattern,definedAttrs_Syn_Pattern :: [AttrName],definedInsts_Syn_Pattern :: [Identifier],patunder_Syn_Pattern :: [AttrName]->Pattern,stpos_Syn_Pattern :: Pos} -wrap_Pattern (T_Pattern sem) (Inh_Pattern ) = - (let ( _lhsOcopy,_lhsOdefinedAttrs,_lhsOdefinedInsts,_lhsOpatunder,_lhsOstpos) = - (sem ) - in (Syn_Pattern _lhsOcopy _lhsOdefinedAttrs _lhsOdefinedInsts _lhsOpatunder _lhsOstpos)) -sem_Pattern_Alias :: Name -> - Name -> - T_Pattern -> - T_Patterns -> - T_Pattern -sem_Pattern_Alias field_ attr_ (T_Pattern pat_) (T_Patterns parts_) = - (T_Pattern (let _lhsOdefinedAttrs :: ([AttrName]) - _lhsOpatunder :: ([AttrName]->Pattern) - _lhsOdefinedInsts :: ([Identifier]) - _lhsOstpos :: Pos - _lhsOcopy :: Pattern - _patIcopy :: Pattern - _patIdefinedAttrs :: ([AttrName]) - _patIdefinedInsts :: ([Identifier]) - _patIpatunder :: ([AttrName]->Pattern) - _patIstpos :: Pos - _partsIcopy :: Patterns - _partsIdefinedAttrs :: ([AttrName]) - _partsIdefinedInsts :: ([Identifier]) - _partsIpatunder :: ([AttrName]->Patterns) - -- "Transform.ag"(line 711, column 11) - _lhsOdefinedAttrs = - (field_, attr_) : _patIdefinedAttrs - -- "Transform.ag"(line 712, column 11) - _lhsOpatunder = - \us -> if ((field_,attr_) `elem` us) then Underscore noPos else _copy - -- "Transform.ag"(line 713, column 11) - _lhsOdefinedInsts = - (if field_ == _INST then [attr_] else []) ++ _patIdefinedInsts - -- "Transform.ag"(line 727, column 16) - _lhsOstpos = - getPos field_ - -- self rule - _copy = - Alias field_ attr_ _patIcopy _partsIcopy - -- self rule - _lhsOcopy = - _copy - ( _patIcopy,_patIdefinedAttrs,_patIdefinedInsts,_patIpatunder,_patIstpos) = - (pat_ ) - ( _partsIcopy,_partsIdefinedAttrs,_partsIdefinedInsts,_partsIpatunder) = - (parts_ ) - in ( _lhsOcopy,_lhsOdefinedAttrs,_lhsOdefinedInsts,_lhsOpatunder,_lhsOstpos))) -sem_Pattern_Constr :: Constructor -> - T_Patterns -> - T_Pattern -sem_Pattern_Constr name_ (T_Patterns pats_) = - (T_Pattern (let _lhsOpatunder :: ([AttrName]->Pattern) - _lhsOstpos :: Pos - _lhsOdefinedAttrs :: ([AttrName]) - _lhsOdefinedInsts :: ([Identifier]) - _lhsOcopy :: Pattern - _patsIcopy :: Patterns - _patsIdefinedAttrs :: ([AttrName]) - _patsIdefinedInsts :: ([Identifier]) - _patsIpatunder :: ([AttrName]->Patterns) - -- "Transform.ag"(line 715, column 12) - _lhsOpatunder = - \us -> Constr name_ (_patsIpatunder us) - -- "Transform.ag"(line 725, column 16) - _lhsOstpos = - getPos name_ - -- use rule "Transform.ag"(line 706, column 42) - _lhsOdefinedAttrs = - _patsIdefinedAttrs - -- use rule "Transform.ag"(line 705, column 55) - _lhsOdefinedInsts = - _patsIdefinedInsts - -- self rule - _copy = - Constr name_ _patsIcopy - -- self rule - _lhsOcopy = - _copy - ( _patsIcopy,_patsIdefinedAttrs,_patsIdefinedInsts,_patsIpatunder) = - (pats_ ) - in ( _lhsOcopy,_lhsOdefinedAttrs,_lhsOdefinedInsts,_lhsOpatunder,_lhsOstpos))) -sem_Pattern_Product :: Pos -> - T_Patterns -> - T_Pattern -sem_Pattern_Product pos_ (T_Patterns pats_) = - (T_Pattern (let _lhsOpatunder :: ([AttrName]->Pattern) - _lhsOstpos :: Pos - _lhsOdefinedAttrs :: ([AttrName]) - _lhsOdefinedInsts :: ([Identifier]) - _lhsOcopy :: Pattern - _patsIcopy :: Patterns - _patsIdefinedAttrs :: ([AttrName]) - _patsIdefinedInsts :: ([Identifier]) - _patsIpatunder :: ([AttrName]->Patterns) - -- "Transform.ag"(line 716, column 13) - _lhsOpatunder = - \us -> Product pos_ (_patsIpatunder us) - -- "Transform.ag"(line 726, column 16) - _lhsOstpos = - pos_ - -- use rule "Transform.ag"(line 706, column 42) - _lhsOdefinedAttrs = - _patsIdefinedAttrs - -- use rule "Transform.ag"(line 705, column 55) - _lhsOdefinedInsts = - _patsIdefinedInsts - -- self rule - _copy = - Product pos_ _patsIcopy - -- self rule - _lhsOcopy = - _copy - ( _patsIcopy,_patsIdefinedAttrs,_patsIdefinedInsts,_patsIpatunder) = - (pats_ ) - in ( _lhsOcopy,_lhsOdefinedAttrs,_lhsOdefinedInsts,_lhsOpatunder,_lhsOstpos))) -sem_Pattern_Underscore :: Pos -> - T_Pattern -sem_Pattern_Underscore pos_ = - (T_Pattern (let _lhsOpatunder :: ([AttrName]->Pattern) - _lhsOstpos :: Pos - _lhsOdefinedAttrs :: ([AttrName]) - _lhsOdefinedInsts :: ([Identifier]) - _lhsOcopy :: Pattern - -- "Transform.ag"(line 714, column 16) - _lhsOpatunder = - \us -> _copy - -- "Transform.ag"(line 728, column 16) - _lhsOstpos = - pos_ - -- use rule "Transform.ag"(line 706, column 42) - _lhsOdefinedAttrs = - [] - -- use rule "Transform.ag"(line 705, column 55) - _lhsOdefinedInsts = - [] - -- self rule - _copy = - Underscore pos_ - -- self rule - _lhsOcopy = - _copy - in ( _lhsOcopy,_lhsOdefinedAttrs,_lhsOdefinedInsts,_lhsOpatunder,_lhsOstpos))) --- Patterns ---------------------------------------------------- -{- - visit 0: - synthesized attributes: - copy : SELF - definedAttrs : [AttrName] - definedInsts : [Identifier] - patunder : [AttrName]->Patterns - alternatives: - alternative Cons: - child hd : Pattern - child tl : Patterns - visit 0: - local copy : _ - alternative Nil: - visit 0: - local copy : _ --} --- cata -sem_Patterns :: Patterns -> - T_Patterns -sem_Patterns list = - (Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list)) --- semantic domain -newtype T_Patterns = T_Patterns (( Patterns,([AttrName]),([Identifier]),([AttrName]->Patterns))) -data Inh_Patterns = Inh_Patterns {} -data Syn_Patterns = Syn_Patterns {copy_Syn_Patterns :: Patterns,definedAttrs_Syn_Patterns :: [AttrName],definedInsts_Syn_Patterns :: [Identifier],patunder_Syn_Patterns :: [AttrName]->Patterns} -wrap_Patterns (T_Patterns sem) (Inh_Patterns ) = - (let ( _lhsOcopy,_lhsOdefinedAttrs,_lhsOdefinedInsts,_lhsOpatunder) = - (sem ) - in (Syn_Patterns _lhsOcopy _lhsOdefinedAttrs _lhsOdefinedInsts _lhsOpatunder)) -sem_Patterns_Cons :: T_Pattern -> - T_Patterns -> - T_Patterns -sem_Patterns_Cons (T_Pattern hd_) (T_Patterns tl_) = - (T_Patterns (let _lhsOpatunder :: ([AttrName]->Patterns) - _lhsOdefinedAttrs :: ([AttrName]) - _lhsOdefinedInsts :: ([Identifier]) - _lhsOcopy :: Patterns - _hdIcopy :: Pattern - _hdIdefinedAttrs :: ([AttrName]) - _hdIdefinedInsts :: ([Identifier]) - _hdIpatunder :: ([AttrName]->Pattern) - _hdIstpos :: Pos - _tlIcopy :: Patterns - _tlIdefinedAttrs :: ([AttrName]) - _tlIdefinedInsts :: ([Identifier]) - _tlIpatunder :: ([AttrName]->Patterns) - -- "Transform.ag"(line 720, column 10) - _lhsOpatunder = - \us -> (_hdIpatunder us) : (_tlIpatunder us) - -- use rule "Transform.ag"(line 706, column 42) - _lhsOdefinedAttrs = - _hdIdefinedAttrs ++ _tlIdefinedAttrs - -- use rule "Transform.ag"(line 705, column 55) - _lhsOdefinedInsts = - _hdIdefinedInsts ++ _tlIdefinedInsts - -- self rule - _copy = - (:) _hdIcopy _tlIcopy - -- self rule - _lhsOcopy = - _copy - ( _hdIcopy,_hdIdefinedAttrs,_hdIdefinedInsts,_hdIpatunder,_hdIstpos) = - (hd_ ) - ( _tlIcopy,_tlIdefinedAttrs,_tlIdefinedInsts,_tlIpatunder) = - (tl_ ) - in ( _lhsOcopy,_lhsOdefinedAttrs,_lhsOdefinedInsts,_lhsOpatunder))) -sem_Patterns_Nil :: T_Patterns -sem_Patterns_Nil = - (T_Patterns (let _lhsOpatunder :: ([AttrName]->Patterns) - _lhsOdefinedAttrs :: ([AttrName]) - _lhsOdefinedInsts :: ([Identifier]) - _lhsOcopy :: Patterns - -- "Transform.ag"(line 719, column 9) - _lhsOpatunder = - \us -> [] - -- use rule "Transform.ag"(line 706, column 42) - _lhsOdefinedAttrs = - [] - -- use rule "Transform.ag"(line 705, column 55) - _lhsOdefinedInsts = - [] - -- self rule - _copy = - [] - -- self rule - _lhsOcopy = - _copy - in ( _lhsOcopy,_lhsOdefinedAttrs,_lhsOdefinedInsts,_lhsOpatunder))) --- SemAlt ------------------------------------------------------ -{- - visit 0: - inherited attributes: - allAttrDecls : Map Nonterminal (Attributes, Attributes) - allFields : DataTypes - nts : Set Nonterminal - synthesized attributes: - attrOrderCollect : AttrOrderMap - collectedInsts : [ (Nonterminal, Constructor, [Identifier]) ] - collectedRules : [ (Nonterminal, Constructor, RuleInfo)] - collectedSigs : [ (Nonterminal, Constructor, SigInfo) ] - errors : Seq Error - orderDepErrorsCollect : Seq Error - semPragmasCollect : PragmaMap - alternatives: - alternative SemAlt: - child pos : {Pos} - child constructorSet : ConstructorSet - child rules : SemDefs - visit 0: - local pragmaNames : _ - local attrOrders : _ - local coninfo : _ --} --- cata -sem_SemAlt :: SemAlt -> - T_SemAlt -sem_SemAlt (SemAlt _pos _constructorSet _rules) = - (sem_SemAlt_SemAlt _pos (sem_ConstructorSet _constructorSet) (sem_SemDefs _rules)) --- semantic domain -newtype T_SemAlt = T_SemAlt ((Map Nonterminal (Attributes, Attributes)) -> - DataTypes -> - (Set Nonterminal) -> - ( AttrOrderMap,([ (Nonterminal, Constructor, [Identifier]) ]),([ (Nonterminal, Constructor, RuleInfo)]),([ (Nonterminal, Constructor, SigInfo) ]),(Seq Error),(Seq Error),PragmaMap)) -data Inh_SemAlt = Inh_SemAlt {allAttrDecls_Inh_SemAlt :: Map Nonterminal (Attributes, Attributes),allFields_Inh_SemAlt :: DataTypes,nts_Inh_SemAlt :: Set Nonterminal} -data Syn_SemAlt = Syn_SemAlt {attrOrderCollect_Syn_SemAlt :: AttrOrderMap,collectedInsts_Syn_SemAlt :: [ (Nonterminal, Constructor, [Identifier]) ],collectedRules_Syn_SemAlt :: [ (Nonterminal, Constructor, RuleInfo)],collectedSigs_Syn_SemAlt :: [ (Nonterminal, Constructor, SigInfo) ],errors_Syn_SemAlt :: Seq Error,orderDepErrorsCollect_Syn_SemAlt :: Seq Error,semPragmasCollect_Syn_SemAlt :: PragmaMap} -wrap_SemAlt (T_SemAlt sem) (Inh_SemAlt _lhsIallAttrDecls _lhsIallFields _lhsInts) = - (let ( _lhsOattrOrderCollect,_lhsOcollectedInsts,_lhsOcollectedRules,_lhsOcollectedSigs,_lhsOerrors,_lhsOorderDepErrorsCollect,_lhsOsemPragmasCollect) = - (sem _lhsIallAttrDecls _lhsIallFields _lhsInts) - in (Syn_SemAlt _lhsOattrOrderCollect _lhsOcollectedInsts _lhsOcollectedRules _lhsOcollectedSigs _lhsOerrors _lhsOorderDepErrorsCollect _lhsOsemPragmasCollect)) -sem_SemAlt_SemAlt :: Pos -> - T_ConstructorSet -> - T_SemDefs -> - T_SemAlt -sem_SemAlt_SemAlt pos_ (T_ConstructorSet constructorSet_) (T_SemDefs rules_) = - (T_SemAlt (\ _lhsIallAttrDecls - _lhsIallFields - _lhsInts -> - (let _lhsOsemPragmasCollect :: PragmaMap - _lhsOattrOrderCollect :: AttrOrderMap - _lhsOerrors :: (Seq Error) - _lhsOcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) - _lhsOcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) - _lhsOcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) - _lhsOorderDepErrorsCollect :: (Seq Error) - _constructorSetIcollectedConstructorNames :: (Set Constructor) - _constructorSetIconstructors :: ((Set Constructor->Set Constructor)) - _constructorSetIerrors :: (Seq Error) - _rulesIdefinedInsts :: ([Identifier]) - _rulesIorderDepsCollect :: (Set Dependency) - _rulesIpragmaNamesCollect :: ([Name]) - _rulesIruleInfos :: ([RuleInfo]) - _rulesIsigInfos :: ([SigInfo] ) - -- "Transform.ag"(line 536, column 7) - _pragmaNames = - Set.fromList _rulesIpragmaNamesCollect - -- "Transform.ag"(line 537, column 7) - _lhsOsemPragmasCollect = - foldr pragmaMapUnion Map.empty [ pragmaMapSingle nt con _pragmaNames - | (nt, conset, _) <- _coninfo - , con <- Set.toList conset - ] - -- "Transform.ag"(line 566, column 7) - _attrOrders = - [ orderMapSingle nt con _rulesIorderDepsCollect - | (nt, conset, _) <- _coninfo - , con <- Set.toList conset - ] - -- "Transform.ag"(line 572, column 7) - _lhsOattrOrderCollect = - foldr orderMapUnion Map.empty _attrOrders - -- "Transform.ag"(line 666, column 12) - _coninfo = - [ (nt, conset, conkeys) - | nt <- Set.toList _lhsInts - , let conmap = Map.findWithDefault Map.empty nt _lhsIallFields - , let conkeys = Set.fromList (Map.keys conmap) - , let conset = _constructorSetIconstructors conkeys - ] - -- "Transform.ag"(line 673, column 12) - _lhsOerrors = - Seq.fromList - [ UndefAlt nt con - | (nt, conset, conkeys) <- _coninfo - , con <- Set.toList (Set.difference conset conkeys) - ] - -- "Transform.ag"(line 678, column 12) - _lhsOcollectedRules = - [ (nt,con,r) - | (nt, conset, _) <- _coninfo - , con <- Set.toList conset - , r <- _rulesIruleInfos - ] - -- "Transform.ag"(line 684, column 12) - _lhsOcollectedSigs = - [ (nt,con,ts) - | (nt, conset, _) <- _coninfo - , con <- Set.toList conset - , ts <- _rulesIsigInfos - ] - -- "Transform.ag"(line 691, column 12) - _lhsOcollectedInsts = - [ (nt,con,_rulesIdefinedInsts) - | (nt, conset, _) <- _coninfo - , con <- Set.toList conset - ] - -- use rule "Transform.ag"(line 561, column 60) - _lhsOorderDepErrorsCollect = - Seq.empty - ( _constructorSetIcollectedConstructorNames,_constructorSetIconstructors,_constructorSetIerrors) = - (constructorSet_ ) - ( _rulesIdefinedInsts,_rulesIorderDepsCollect,_rulesIpragmaNamesCollect,_rulesIruleInfos,_rulesIsigInfos) = - (rules_ ) - in ( _lhsOattrOrderCollect,_lhsOcollectedInsts,_lhsOcollectedRules,_lhsOcollectedSigs,_lhsOerrors,_lhsOorderDepErrorsCollect,_lhsOsemPragmasCollect)))) --- SemAlts ----------------------------------------------------- -{- - visit 0: - inherited attributes: - allAttrDecls : Map Nonterminal (Attributes, Attributes) - allFields : DataTypes - nts : Set Nonterminal - synthesized attributes: - attrOrderCollect : AttrOrderMap - collectedInsts : [ (Nonterminal, Constructor, [Identifier]) ] - collectedRules : [ (Nonterminal, Constructor, RuleInfo)] - collectedSigs : [ (Nonterminal, Constructor, SigInfo) ] - errors : Seq Error - orderDepErrorsCollect : Seq Error - semPragmasCollect : PragmaMap - alternatives: - alternative Cons: - child hd : SemAlt - child tl : SemAlts - alternative Nil: --} --- cata -sem_SemAlts :: SemAlts -> - T_SemAlts -sem_SemAlts list = - (Prelude.foldr sem_SemAlts_Cons sem_SemAlts_Nil (Prelude.map sem_SemAlt list)) --- semantic domain -newtype T_SemAlts = T_SemAlts ((Map Nonterminal (Attributes, Attributes)) -> - DataTypes -> - (Set Nonterminal) -> - ( AttrOrderMap,([ (Nonterminal, Constructor, [Identifier]) ]),([ (Nonterminal, Constructor, RuleInfo)]),([ (Nonterminal, Constructor, SigInfo) ]),(Seq Error),(Seq Error),PragmaMap)) -data Inh_SemAlts = Inh_SemAlts {allAttrDecls_Inh_SemAlts :: Map Nonterminal (Attributes, Attributes),allFields_Inh_SemAlts :: DataTypes,nts_Inh_SemAlts :: Set Nonterminal} -data Syn_SemAlts = Syn_SemAlts {attrOrderCollect_Syn_SemAlts :: AttrOrderMap,collectedInsts_Syn_SemAlts :: [ (Nonterminal, Constructor, [Identifier]) ],collectedRules_Syn_SemAlts :: [ (Nonterminal, Constructor, RuleInfo)],collectedSigs_Syn_SemAlts :: [ (Nonterminal, Constructor, SigInfo) ],errors_Syn_SemAlts :: Seq Error,orderDepErrorsCollect_Syn_SemAlts :: Seq Error,semPragmasCollect_Syn_SemAlts :: PragmaMap} -wrap_SemAlts (T_SemAlts sem) (Inh_SemAlts _lhsIallAttrDecls _lhsIallFields _lhsInts) = - (let ( _lhsOattrOrderCollect,_lhsOcollectedInsts,_lhsOcollectedRules,_lhsOcollectedSigs,_lhsOerrors,_lhsOorderDepErrorsCollect,_lhsOsemPragmasCollect) = - (sem _lhsIallAttrDecls _lhsIallFields _lhsInts) - in (Syn_SemAlts _lhsOattrOrderCollect _lhsOcollectedInsts _lhsOcollectedRules _lhsOcollectedSigs _lhsOerrors _lhsOorderDepErrorsCollect _lhsOsemPragmasCollect)) -sem_SemAlts_Cons :: T_SemAlt -> - T_SemAlts -> - T_SemAlts -sem_SemAlts_Cons (T_SemAlt hd_) (T_SemAlts tl_) = - (T_SemAlts (\ _lhsIallAttrDecls - _lhsIallFields - _lhsInts -> - (let _lhsOattrOrderCollect :: AttrOrderMap - _lhsOcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) - _lhsOcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) - _lhsOcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) - _lhsOerrors :: (Seq Error) - _lhsOorderDepErrorsCollect :: (Seq Error) - _lhsOsemPragmasCollect :: PragmaMap - _hdOallAttrDecls :: (Map Nonterminal (Attributes, Attributes)) - _hdOallFields :: DataTypes - _hdOnts :: (Set Nonterminal) - _tlOallAttrDecls :: (Map Nonterminal (Attributes, Attributes)) - _tlOallFields :: DataTypes - _tlOnts :: (Set Nonterminal) - _hdIattrOrderCollect :: AttrOrderMap - _hdIcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) - _hdIcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) - _hdIcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) - _hdIerrors :: (Seq Error) - _hdIorderDepErrorsCollect :: (Seq Error) - _hdIsemPragmasCollect :: PragmaMap - _tlIattrOrderCollect :: AttrOrderMap - _tlIcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) - _tlIcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) - _tlIcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) - _tlIerrors :: (Seq Error) - _tlIorderDepErrorsCollect :: (Seq Error) - _tlIsemPragmasCollect :: PragmaMap - -- use rule "Transform.ag"(line 560, column 55) - _lhsOattrOrderCollect = - _hdIattrOrderCollect `orderMapUnion` _tlIattrOrderCollect - -- use rule "Transform.ag"(line 136, column 29) - _lhsOcollectedInsts = - _hdIcollectedInsts ++ _tlIcollectedInsts - -- use rule "Transform.ag"(line 134, column 29) - _lhsOcollectedRules = - _hdIcollectedRules ++ _tlIcollectedRules - -- use rule "Transform.ag"(line 135, column 29) - _lhsOcollectedSigs = - _hdIcollectedSigs ++ _tlIcollectedSigs - -- use rule "Transform.ag"(line 36, column 19) - _lhsOerrors = - _hdIerrors Seq.<> _tlIerrors - -- use rule "Transform.ag"(line 561, column 60) - _lhsOorderDepErrorsCollect = - _hdIorderDepErrorsCollect Seq.<> _tlIorderDepErrorsCollect - -- use rule "Transform.ag"(line 532, column 56) - _lhsOsemPragmasCollect = - _hdIsemPragmasCollect `pragmaMapUnion` _tlIsemPragmasCollect - -- copy rule (down) - _hdOallAttrDecls = - _lhsIallAttrDecls - -- copy rule (down) - _hdOallFields = - _lhsIallFields - -- copy rule (down) - _hdOnts = - _lhsInts - -- copy rule (down) - _tlOallAttrDecls = - _lhsIallAttrDecls - -- copy rule (down) - _tlOallFields = - _lhsIallFields - -- copy rule (down) - _tlOnts = - _lhsInts - ( _hdIattrOrderCollect,_hdIcollectedInsts,_hdIcollectedRules,_hdIcollectedSigs,_hdIerrors,_hdIorderDepErrorsCollect,_hdIsemPragmasCollect) = - (hd_ _hdOallAttrDecls _hdOallFields _hdOnts) - ( _tlIattrOrderCollect,_tlIcollectedInsts,_tlIcollectedRules,_tlIcollectedSigs,_tlIerrors,_tlIorderDepErrorsCollect,_tlIsemPragmasCollect) = - (tl_ _tlOallAttrDecls _tlOallFields _tlOnts) - in ( _lhsOattrOrderCollect,_lhsOcollectedInsts,_lhsOcollectedRules,_lhsOcollectedSigs,_lhsOerrors,_lhsOorderDepErrorsCollect,_lhsOsemPragmasCollect)))) -sem_SemAlts_Nil :: T_SemAlts -sem_SemAlts_Nil = - (T_SemAlts (\ _lhsIallAttrDecls - _lhsIallFields - _lhsInts -> - (let _lhsOattrOrderCollect :: AttrOrderMap - _lhsOcollectedInsts :: ([ (Nonterminal, Constructor, [Identifier]) ]) - _lhsOcollectedRules :: ([ (Nonterminal, Constructor, RuleInfo)]) - _lhsOcollectedSigs :: ([ (Nonterminal, Constructor, SigInfo) ]) - _lhsOerrors :: (Seq Error) - _lhsOorderDepErrorsCollect :: (Seq Error) - _lhsOsemPragmasCollect :: PragmaMap - -- use rule "Transform.ag"(line 560, column 55) - _lhsOattrOrderCollect = - Map.empty - -- use rule "Transform.ag"(line 136, column 29) - _lhsOcollectedInsts = - [] - -- use rule "Transform.ag"(line 134, column 29) - _lhsOcollectedRules = - [] - -- use rule "Transform.ag"(line 135, column 29) - _lhsOcollectedSigs = - [] - -- use rule "Transform.ag"(line 36, column 19) - _lhsOerrors = - Seq.empty - -- use rule "Transform.ag"(line 561, column 60) - _lhsOorderDepErrorsCollect = - Seq.empty - -- use rule "Transform.ag"(line 532, column 56) - _lhsOsemPragmasCollect = - Map.empty - in ( _lhsOattrOrderCollect,_lhsOcollectedInsts,_lhsOcollectedRules,_lhsOcollectedSigs,_lhsOerrors,_lhsOorderDepErrorsCollect,_lhsOsemPragmasCollect)))) --- SemDef ------------------------------------------------------ -{- - visit 0: - synthesized attributes: - definedInsts : [Identifier] - orderDepsCollect : Set Dependency - pragmaNamesCollect : [Name] - ruleInfos : [RuleInfo] - sigInfos : [SigInfo] - alternatives: - alternative AttrOrderBefore: - child before : {(Identifier,Identifier)} - child after : {(Identifier,Identifier)} - visit 0: - local dependency : _ - alternative Def: - child pattern : Pattern - child rhs : {Expression} - child owrt : {Bool} - alternative SemPragma: - child names : {[Name]} - alternative TypeDef: - child ident : {Identifier} - child tp : {Type} --} --- cata -sem_SemDef :: SemDef -> - T_SemDef -sem_SemDef (AttrOrderBefore _before _after) = - (sem_SemDef_AttrOrderBefore _before _after) -sem_SemDef (Def _pattern _rhs _owrt) = - (sem_SemDef_Def (sem_Pattern _pattern) _rhs _owrt) -sem_SemDef (SemPragma _names) = - (sem_SemDef_SemPragma _names) -sem_SemDef (TypeDef _ident _tp) = - (sem_SemDef_TypeDef _ident _tp) --- semantic domain -newtype T_SemDef = T_SemDef (( ([Identifier]),(Set Dependency),([Name]),([RuleInfo]),([SigInfo] ))) -data Inh_SemDef = Inh_SemDef {} -data Syn_SemDef = Syn_SemDef {definedInsts_Syn_SemDef :: [Identifier],orderDepsCollect_Syn_SemDef :: Set Dependency,pragmaNamesCollect_Syn_SemDef :: [Name],ruleInfos_Syn_SemDef :: [RuleInfo],sigInfos_Syn_SemDef :: [SigInfo] } -wrap_SemDef (T_SemDef sem) (Inh_SemDef ) = - (let ( _lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos) = - (sem ) - in (Syn_SemDef _lhsOdefinedInsts _lhsOorderDepsCollect _lhsOpragmaNamesCollect _lhsOruleInfos _lhsOsigInfos)) -sem_SemDef_AttrOrderBefore :: ((Identifier,Identifier)) -> - ((Identifier,Identifier)) -> - T_SemDef -sem_SemDef_AttrOrderBefore before_ after_ = - (T_SemDef (let _lhsOorderDepsCollect :: (Set Dependency) - _lhsOdefinedInsts :: ([Identifier]) - _lhsOpragmaNamesCollect :: ([Name]) - _lhsOruleInfos :: ([RuleInfo]) - _lhsOsigInfos :: ([SigInfo] ) - -- "Transform.ag"(line 578, column 7) - _dependency = - Dependency before_ after_ - -- "Transform.ag"(line 579, column 7) - _lhsOorderDepsCollect = - Set.singleton _dependency - -- use rule "Transform.ag"(line 705, column 55) - _lhsOdefinedInsts = - [] - -- use rule "Transform.ag"(line 542, column 46) - _lhsOpragmaNamesCollect = - [] - -- use rule "Transform.ag"(line 660, column 37) - _lhsOruleInfos = - [] - -- use rule "Transform.ag"(line 661, column 37) - _lhsOsigInfos = - [] - in ( _lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos))) -sem_SemDef_Def :: T_Pattern -> - Expression -> - Bool -> - T_SemDef -sem_SemDef_Def (T_Pattern pattern_) rhs_ owrt_ = - (T_SemDef (let _lhsOruleInfos :: ([RuleInfo]) - _lhsOdefinedInsts :: ([Identifier]) - _lhsOorderDepsCollect :: (Set Dependency) - _lhsOpragmaNamesCollect :: ([Name]) - _lhsOsigInfos :: ([SigInfo] ) - _patternIcopy :: Pattern - _patternIdefinedAttrs :: ([AttrName]) - _patternIdefinedInsts :: ([Identifier]) - _patternIpatunder :: ([AttrName]->Pattern) - _patternIstpos :: Pos - -- "Transform.ag"(line 699, column 10) - _lhsOruleInfos = - [ (_patternIpatunder, rhs_, _patternIdefinedAttrs, owrt_, show _patternIstpos) ] - -- use rule "Transform.ag"(line 705, column 55) - _lhsOdefinedInsts = - _patternIdefinedInsts - -- use rule "Transform.ag"(line 574, column 44) - _lhsOorderDepsCollect = - Set.empty - -- use rule "Transform.ag"(line 542, column 46) - _lhsOpragmaNamesCollect = - [] - -- use rule "Transform.ag"(line 661, column 37) - _lhsOsigInfos = - [] - ( _patternIcopy,_patternIdefinedAttrs,_patternIdefinedInsts,_patternIpatunder,_patternIstpos) = - (pattern_ ) - in ( _lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos))) -sem_SemDef_SemPragma :: ([Name]) -> - T_SemDef -sem_SemDef_SemPragma names_ = - (T_SemDef (let _lhsOpragmaNamesCollect :: ([Name]) - _lhsOdefinedInsts :: ([Identifier]) - _lhsOorderDepsCollect :: (Set Dependency) - _lhsOruleInfos :: ([RuleInfo]) - _lhsOsigInfos :: ([SigInfo] ) - -- "Transform.ag"(line 546, column 7) - _lhsOpragmaNamesCollect = - names_ - -- use rule "Transform.ag"(line 705, column 55) - _lhsOdefinedInsts = - [] - -- use rule "Transform.ag"(line 574, column 44) - _lhsOorderDepsCollect = - Set.empty - -- use rule "Transform.ag"(line 660, column 37) - _lhsOruleInfos = - [] - -- use rule "Transform.ag"(line 661, column 37) - _lhsOsigInfos = - [] - in ( _lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos))) -sem_SemDef_TypeDef :: Identifier -> - Type -> - T_SemDef -sem_SemDef_TypeDef ident_ tp_ = - (T_SemDef (let _lhsOsigInfos :: ([SigInfo] ) - _lhsOdefinedInsts :: ([Identifier]) - _lhsOorderDepsCollect :: (Set Dependency) - _lhsOpragmaNamesCollect :: ([Name]) - _lhsOruleInfos :: ([RuleInfo]) - -- "Transform.ag"(line 702, column 14) - _lhsOsigInfos = - [ (ident_, tp_) ] - -- use rule "Transform.ag"(line 705, column 55) - _lhsOdefinedInsts = - [] - -- use rule "Transform.ag"(line 574, column 44) - _lhsOorderDepsCollect = - Set.empty - -- use rule "Transform.ag"(line 542, column 46) - _lhsOpragmaNamesCollect = - [] - -- use rule "Transform.ag"(line 660, column 37) - _lhsOruleInfos = - [] - in ( _lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos))) --- SemDefs ----------------------------------------------------- -{- - visit 0: - synthesized attributes: - definedInsts : [Identifier] - orderDepsCollect : Set Dependency - pragmaNamesCollect : [Name] - ruleInfos : [RuleInfo] - sigInfos : [SigInfo] - alternatives: - alternative Cons: - child hd : SemDef - child tl : SemDefs - alternative Nil: --} --- cata -sem_SemDefs :: SemDefs -> - T_SemDefs -sem_SemDefs list = - (Prelude.foldr sem_SemDefs_Cons sem_SemDefs_Nil (Prelude.map sem_SemDef list)) --- semantic domain -newtype T_SemDefs = T_SemDefs (( ([Identifier]),(Set Dependency),([Name]),([RuleInfo]),([SigInfo] ))) -data Inh_SemDefs = Inh_SemDefs {} -data Syn_SemDefs = Syn_SemDefs {definedInsts_Syn_SemDefs :: [Identifier],orderDepsCollect_Syn_SemDefs :: Set Dependency,pragmaNamesCollect_Syn_SemDefs :: [Name],ruleInfos_Syn_SemDefs :: [RuleInfo],sigInfos_Syn_SemDefs :: [SigInfo] } -wrap_SemDefs (T_SemDefs sem) (Inh_SemDefs ) = - (let ( _lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos) = - (sem ) - in (Syn_SemDefs _lhsOdefinedInsts _lhsOorderDepsCollect _lhsOpragmaNamesCollect _lhsOruleInfos _lhsOsigInfos)) -sem_SemDefs_Cons :: T_SemDef -> - T_SemDefs -> - T_SemDefs -sem_SemDefs_Cons (T_SemDef hd_) (T_SemDefs tl_) = - (T_SemDefs (let _lhsOdefinedInsts :: ([Identifier]) - _lhsOorderDepsCollect :: (Set Dependency) - _lhsOpragmaNamesCollect :: ([Name]) - _lhsOruleInfos :: ([RuleInfo]) - _lhsOsigInfos :: ([SigInfo] ) - _hdIdefinedInsts :: ([Identifier]) - _hdIorderDepsCollect :: (Set Dependency) - _hdIpragmaNamesCollect :: ([Name]) - _hdIruleInfos :: ([RuleInfo]) - _hdIsigInfos :: ([SigInfo] ) - _tlIdefinedInsts :: ([Identifier]) - _tlIorderDepsCollect :: (Set Dependency) - _tlIpragmaNamesCollect :: ([Name]) - _tlIruleInfos :: ([RuleInfo]) - _tlIsigInfos :: ([SigInfo] ) - -- use rule "Transform.ag"(line 705, column 55) - _lhsOdefinedInsts = - _hdIdefinedInsts ++ _tlIdefinedInsts - -- use rule "Transform.ag"(line 574, column 44) - _lhsOorderDepsCollect = - _hdIorderDepsCollect `Set.union` _tlIorderDepsCollect - -- use rule "Transform.ag"(line 542, column 46) - _lhsOpragmaNamesCollect = - _hdIpragmaNamesCollect ++ _tlIpragmaNamesCollect - -- use rule "Transform.ag"(line 660, column 37) - _lhsOruleInfos = - _hdIruleInfos ++ _tlIruleInfos - -- use rule "Transform.ag"(line 661, column 37) - _lhsOsigInfos = - _hdIsigInfos ++ _tlIsigInfos - ( _hdIdefinedInsts,_hdIorderDepsCollect,_hdIpragmaNamesCollect,_hdIruleInfos,_hdIsigInfos) = - (hd_ ) - ( _tlIdefinedInsts,_tlIorderDepsCollect,_tlIpragmaNamesCollect,_tlIruleInfos,_tlIsigInfos) = - (tl_ ) - in ( _lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos))) -sem_SemDefs_Nil :: T_SemDefs -sem_SemDefs_Nil = - (T_SemDefs (let _lhsOdefinedInsts :: ([Identifier]) - _lhsOorderDepsCollect :: (Set Dependency) - _lhsOpragmaNamesCollect :: ([Name]) - _lhsOruleInfos :: ([RuleInfo]) - _lhsOsigInfos :: ([SigInfo] ) - -- use rule "Transform.ag"(line 705, column 55) - _lhsOdefinedInsts = - [] - -- use rule "Transform.ag"(line 574, column 44) - _lhsOorderDepsCollect = - Set.empty - -- use rule "Transform.ag"(line 542, column 46) - _lhsOpragmaNamesCollect = - [] - -- use rule "Transform.ag"(line 660, column 37) - _lhsOruleInfos = - [] - -- use rule "Transform.ag"(line 661, column 37) +import List (partition, elem, nub) +import Data.Maybe +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Set as Set (Set, member, union, toList, fromList, empty, singleton, member, unions, size, fold, intersection, difference, insert) +import UU.DData.Seq as Seq (Seq, empty, (<>), single, cons, toList, fromList) +import UU.Scanner.Position(noPos) + +import ConcreteSyntax +import AbstractSyntax +import ErrorMessages +import Patterns (Patterns(..),Pattern(..)) +import Expression (Expression(..)) + +import Options +import CommonTypes + +import UU.Scanner.Position (Pos) +import Patterns (Pattern) +import Expression (Expression) +import CommonTypes + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (ConstructorIdent,Identifier) +type DefinedSets = Map Identifier (Set NontermIdent) +type FieldMap = [(Identifier, Type)] +type DataTypes = Map.Map NontermIdent (Map.Map ConstructorIdent FieldMap) +type AttrName = (Identifier,Identifier) +type RuleInfo = ([AttrName]->Pattern, Expression, [AttrName], Bool, String) +type SigInfo = (Identifier,Type) + + +checkDuplicate :: (Identifier -> Identifier -> Error) + -> Identifier -> val -> Map Identifier val -> (Map Identifier val,Seq Error) +checkDuplicate dupError key val m + = case Map.lookupIndex key m of + Just ix -> let (key',_) = Map.elemAt ix m + in (m,Seq.single (dupError key key')) + Nothing -> (Map.insert key val m,Seq.empty) + +checkDuplicates :: (Identifier -> Identifier -> Error) + -> [(Identifier, val)] -> Map Identifier val -> (Map Identifier val,Seq Error) +checkDuplicates dupError new m = foldErrors check m new + where check = uncurry (checkDuplicate dupError) + +foldErrors f e xs = foldl g (e,Seq.empty) xs + where g ~(e,es) x = let (e',es') = f x e + in (e', es <> es') + + +checkForDuplicates :: (Identifier -> Identifier -> Error) -> [Identifier] -> [Error] +checkForDuplicates err [] = [] +checkForDuplicates err (x:xs) = let (same,other) = List.partition (equalId x) xs + in map (err x) same ++ checkForDuplicates err other + +equalId :: Identifier -> Identifier -> Bool +equalId x y = getName x == getName y + + +type RulesAndErrors = ([Rule], Seq Error) +type SigsAndErrors = ([TypeSig], Seq Error) +type InstsAndErrors = ([(Identifier, Type)], Seq Error) +type AttrOverwrite = Map AttrName Bool +type AccumRuleCheck = (RulesAndErrors, AttrOverwrite) +type AccumDefiCheck = (Seq Error, AttrOverwrite, [AttrName], [AttrName]) + +checkRules :: Map NontermIdent (Attributes, Attributes) -> Map NontermIdent (Map ConstructorIdent FieldMap) -> + Map NontermIdent (Map ConstructorIdent [Identifier]) -> Map NontermIdent (Map ConstructorIdent [SigInfo]) -> + NontermIdent -> ConstructorIdent -> [RuleInfo] -> RulesAndErrors +checkRules attributes fields allinsts allsigs nt con rs + = let fieldmap :: FieldMap + fieldmap = (_LHS,NT nt undefined) : (_LOC,NT undefined undefined) : (_INST, NT undefined undefined) : (_FIRST, NT undefined undefined) : (_LAST, NT undefined undefined) + : Map.findWithDefault [] con (Map.findWithDefault Map.empty nt fields) + ++ mapMaybe (\instNm -> lookup instNm sigs >>= \tp -> return (instNm, tp)) (Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allinsts)) + + sigs = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allsigs) + + hasAttrib f tp attr = Map.member attr (f (Map.findWithDefault (Map.empty,Map.empty) tp attributes)) + + checkRule :: RuleInfo -> AccumRuleCheck -> AccumRuleCheck + checkRule (pat,exp,as,owrt,str) ((r1,e1),m1) + = let (e2,m2,u2,b2) = foldr (checkDefi owrt) (e1,m1,[],[]) as + in ( (Rule (pat u2) exp owrt str : r1, e2), m2) + + checkDefi :: Bool -> AttrName -> AccumDefiCheck -> AccumDefiCheck + checkDefi owrt fa@(field,attr) (e,m,u,bs) + = case lookup field fieldmap + of Just (NT tp _) -> if field == _LOC || field == _INST || field == _FIRST || field == _LAST + || hasAttrib (if getName field==getName _LHS then snd else fst) tp attr + then case Map.lookupIndex fa m of + Just ix -> let ((_,attr2),b) = Map.elemAt ix m + in if b && not (fa `elem` bs) + then ( e, Map.insert fa owrt m, fa:u, fa:bs) + else (Seq.cons (DupRule nt con field attr2 attr) e, m, fa:u, bs) + Nothing -> ( e, Map.insert fa owrt m, u, fa:bs) + else (Seq.cons (SuperfluousRule nt con field attr) e, m, fa:u, bs) + _ -> (Seq.cons (UndefChild nt con field) e, m, fa:u, bs ) + + in fst (foldr checkRule (([],Seq.empty),Map.empty) rs) + +checkSigs :: NontermIdent -> ConstructorIdent -> [SigInfo] -> SigsAndErrors +checkSigs nt con sis + = let checkSig (ide,typ) (sigs,errs) + = if ide `elem` map (\(TypeSig n t)-> n) sigs + then (sigs, Seq.cons (DupSig nt con ide) errs) + -- else if not (ide `elem` locattrdefs) + -- then (sigs, Seq.cons (SupSig nt con ide) errs) + else (TypeSig ide typ:sigs, errs) + in foldr checkSig ([],Seq.empty) sis + +checkInsts :: Map NontermIdent (Map ConstructorIdent [SigInfo]) -> NontermIdent -> ConstructorIdent -> [Identifier] -> InstsAndErrors +checkInsts sigMap nt con + = foldr (\inst (insts, errs) -> maybe (insts, Seq.single (MissingInstSig nt con inst) <> errs) + (\info -> (info : insts, errs)) $ findSig inst) ([], Seq.empty) + where + sigs = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt sigMap) + + findSig name + = do tp@(NT _ _) <- lookup name sigs + return (name, tp) + +flattenDatas :: DataTypes -> Map NontermIdent (Set NontermIdent) +flattenDatas ds = Map.map flatten ds + where flatten cs = Set.fromList [ nt | (_,NT nt _) <- concatMap snd (Map.toList cs)] + +reachableFrom :: Map NontermIdent (Set NontermIdent) -> Set NontermIdent -> Set NontermIdent +reachableFrom table nts = reach nts + where reach nts = let nts' = Set.unions (nts : [ ns | nt <- Set.toList nts + , let ns = Map.findWithDefault Set.empty nt table ]) + in if Set.size nts' > Set.size nts + then reach nts' + else nts +invert :: Map NontermIdent (Set NontermIdent) -> Map NontermIdent (Set NontermIdent) +invert m = foldr inv Map.empty (Map.toList m) + where inv (x,ns) m = fold (\n m -> Map.insertWith Set.union n (Set.singleton x) m) m ns + +path :: Map NontermIdent (Set NontermIdent) -> NontermIdent -> NontermIdent -> Set NontermIdent +path table from to = let children = Map.findWithDefault Set.empty from table + forward = reachableFrom table children + backward = reachableFrom (invert table) + (Set.singleton to) + in Set.intersection forward backward + +pragmaMapUnion :: PragmaMap -> PragmaMap -> PragmaMap +pragmaMapUnion = Map.unionWith (Map.unionWith Set.union) + +pragmaMapSingle :: NontermIdent -> ConstructorIdent -> Set Identifier -> PragmaMap +pragmaMapSingle nt con nms = Map.singleton nt (Map.singleton con nms) + +orderMapUnion :: AttrOrderMap -> AttrOrderMap -> AttrOrderMap +orderMapUnion = Map.unionWith (Map.unionWith Set.union) + +orderMapSingle :: NontermIdent -> ConstructorIdent -> Set Dependency -> AttrOrderMap +orderMapSingle nt con deps = Map.singleton nt (Map.singleton con deps) + +mergeParams :: ParamMap -> ParamMap -> ParamMap +mergeParams = Map.unionWith (++) + +mergeCtx :: ContextMap -> ContextMap -> ContextMap +mergeCtx + = Map.unionWith nubconcat + where nubconcat a b = nub (a ++ b) + +mergeDerivings m1 m2 = foldr (\(n,cs) m -> Map.insertWith Set.union n cs m) m2 (Map.toList m1) + +merge x y = foldr f y (Map.toList x) + where f ~(k,v) m = Map.insertWith (Map.union) k v m + +checkAttrs allFields nts inherited synthesized decls = foldErrors check decls nts where + check nt decls | not (nt `Map.member` allFields) = (decls,Seq.single(UndefNont nt)) + | otherwise = let (inh,syn) = Map.findWithDefault (Map.empty,Map.empty) nt decls + (inh',einh) = checkDuplicates (DupInhAttr nt) inherited inh + (syn',esyn) = checkDuplicates (DupSynAttr nt) synthesized syn + in (Map.insert nt (inh',syn') decls,einh <> esyn) + +addSelf name atMap = let (eInh,eSyn) = Map.findWithDefault(Map.empty,Map.empty) name atMap + in Map.insert name (eInh, Map.insert (Ident "self" noPos) (NT _SELF []) eSyn)atMap + +makeType :: Set NontermIdent -> Type -> Type +makeType nts tp@(NT x _) | x == _SELF = tp + | Set.member x nts = tp + | otherwise = Haskell (typeToHaskellString Nothing [] tp) +makeType _ tp = tp + +constructGrammar :: Set NontermIdent + -> ParamMap + -> DataTypes + -> Map NontermIdent (Attributes, Attributes) + -> Map NontermIdent (Map Identifier (String, String, String)) + -> Derivings + -> Set NontermIdent + -> Map NontermIdent (Map ConstructorIdent [Rule]) + -> Map NontermIdent (Map ConstructorIdent [TypeSig]) + -> Map NontermIdent (Map ConstructorIdent [(Identifier, Type)]) + -> TypeSyns + -> PragmaMap + -> AttrOrderMap + -> ContextMap + -> Grammar + +constructGrammar nts ntParams gram attrs uses derivings wrappers allrules tsigs allinsts tsyns pragmaMap orderMap contextMap = + let gr = [ (nt,Map.toList alts) | (nt,alts) <- Map.toList gram] + nonts = map nont gr + nont (nt,alts) = let (inh,syn) = Map.findWithDefault (Map.empty,Map.empty) nt attrs + rmap = Map.findWithDefault Map.empty nt allrules + tsmap = Map.findWithDefault Map.empty nt tsigs + instsmap = Map.findWithDefault Map.empty nt allinsts + params = Map.findWithDefault [] nt ntParams + alt (con,flds) = + let rules = maybe [] id (Map.lookup con rmap) + tsigs = maybe [] id (Map.lookup con tsmap) + insts = maybe [] id (Map.lookup con instsmap) + cldrn = map (child False) flds ++ map (child True) insts + child isVirtual (nm, tp) = + let (inh,syn) = case tp of + NT nt _ -> Map.findWithDefault (Map.empty,Map.empty) nt attrs + _ -> (Map.empty,Map.empty) + in Child nm tp inh syn isVirtual + in Production con cldrn rules tsigs + in Nonterminal nt params inh syn (map alt alts) + in Grammar tsyns uses derivings wrappers nonts pragmaMap orderMap ntParams contextMap + +mapUnionWithSetUnion = Map.unionWith Set.union +mapUnionWithPlusPlus = Map.unionWith (++) +-- AG ---------------------------------------------------------- +{- + visit 0: + inherited attribute: + options : Options + synthesized attributes: + blocks : Blocks + errors : Seq Error + moduleDecl : Maybe (String,String,String) + output : Grammar + pragmas : Options -> Options + alternatives: + alternative AG: + child elems : Elems + visit 0: + local allFields : _ + local allConstrs : _ + local allRules : _ + local allSigs : _ + local allInsts : _ + local allRulesErrs : _ + local allSigsErrs : _ + local allInstsErrs : _ + local checkedRules : _ + local checkedSigs : _ + local checkedInsts : _ + local errs1 : _ + local errs2 : _ + local errs3 : _ + local errs4 : _ + local errs5 : _ + local errs6 : _ + local allNonterminals : _ + local allAttrDecls : _ +-} +-- cata +sem_AG :: AG -> + T_AG +sem_AG (AG _elems) = + (sem_AG_AG (sem_Elems _elems)) +-- semantic domain +newtype T_AG = T_AG (Options -> + ( Blocks,(Seq Error),(Maybe (String,String,String)),Grammar,(Options -> Options))) +data Inh_AG = Inh_AG {options_Inh_AG :: Options} +data Syn_AG = Syn_AG {blocks_Syn_AG :: Blocks,errors_Syn_AG :: Seq Error,moduleDecl_Syn_AG :: Maybe (String,String,String),output_Syn_AG :: Grammar,pragmas_Syn_AG :: Options -> Options} +wrap_AG (T_AG sem) (Inh_AG _lhsIoptions) = + (let ( _lhsOblocks,_lhsOerrors,_lhsOmoduleDecl,_lhsOoutput,_lhsOpragmas) = + (sem _lhsIoptions) + in (Syn_AG _lhsOblocks _lhsOerrors _lhsOmoduleDecl _lhsOoutput _lhsOpragmas)) +sem_AG_AG :: T_Elems -> + T_AG +sem_AG_AG (T_Elems elems_) = + (T_AG (\ _lhsIoptions -> + (let _lhsOoutput :: Grammar + _lhsOerrors :: (Seq Error) + _elemsOallConstructors :: (Map NontermIdent (Set ConstructorIdent)) + _elemsOdefSets :: (Map Identifier (Set NontermIdent,Set Identifier)) + _elemsOdefinedSets :: DefinedSets + _elemsOattrDecls :: (Map NontermIdent (Attributes, Attributes)) + _lhsOblocks :: Blocks + _lhsOmoduleDecl :: (Maybe (String,String,String)) + _lhsOpragmas :: (Options -> Options) + _elemsOallAttrDecls :: (Map NontermIdent (Attributes, Attributes)) + _elemsOallFields :: DataTypes + _elemsOallNonterminals :: (Set NontermIdent) + _elemsIattrDecls :: (Map NontermIdent (Attributes, Attributes)) + _elemsIattrOrderCollect :: AttrOrderMap + _elemsIblocks :: Blocks + _elemsIcollectedConstructorsMap :: (Map NontermIdent (Set ConstructorIdent)) + _elemsIcollectedFields :: ([(NontermIdent, ConstructorIdent, FieldMap)]) + _elemsIcollectedInsts :: ([ (NontermIdent, ConstructorIdent, [Identifier]) ]) + _elemsIcollectedNames :: (Set Identifier) + _elemsIcollectedRules :: ([ (NontermIdent, ConstructorIdent, RuleInfo)]) + _elemsIcollectedSetNames :: (Set Identifier) + _elemsIcollectedSigs :: ([ (NontermIdent, ConstructorIdent, SigInfo) ]) + _elemsIctxCollect :: ContextMap + _elemsIdefSets :: (Map Identifier (Set NontermIdent,Set Identifier)) + _elemsIderivings :: Derivings + _elemsIerrors :: (Seq Error) + _elemsImoduleDecl :: (Maybe (String,String,String)) + _elemsIparamsCollect :: ParamMap + _elemsIpragmas :: (Options -> Options) + _elemsIsemPragmasCollect :: PragmaMap + _elemsItypeSyns :: TypeSyns + _elemsIuseMap :: (Map NontermIdent (Map Identifier (String,String,String))) + _elemsIwrappers :: (Set NontermIdent) + -- "Transform.ag"(line 45, column 8) + _lhsOoutput = + constructGrammar _allNonterminals + _elemsIparamsCollect + _allFields + _allAttrDecls + _elemsIuseMap + _elemsIderivings + (if wrappers _lhsIoptions then _allNonterminals else _elemsIwrappers) + _checkedRules + _checkedSigs + _checkedInsts + _elemsItypeSyns + _elemsIsemPragmasCollect + _elemsIattrOrderCollect + _elemsIctxCollect + -- "Transform.ag"(line 219, column 10) + _allFields = + let f (nt,con,fm) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con fm) + in foldr f (Map.empty) _elemsIcollectedFields + -- "Transform.ag"(line 222, column 10) + _allConstrs = + let f (nt,con,_) = Map.insertWith (++) nt [con] + in foldr f (Map.empty) _elemsIcollectedFields + -- "Transform.ag"(line 225, column 10) + _allRules = + let f (nt,con,r) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con [r]) + in foldr f (Map.empty) _elemsIcollectedRules + -- "Transform.ag"(line 228, column 10) + _allSigs = + let f (nt,con,t) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con [t]) + in foldr f (Map.empty) _elemsIcollectedSigs + -- "Transform.ag"(line 231, column 10) + _allInsts = + let f (nt,con,is) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con is) + in foldr f (Map.empty) _elemsIcollectedInsts + -- "Transform.ag"(line 234, column 10) + _allRulesErrs = + Map.mapWithKey (Map.mapWithKey . (checkRules _allAttrDecls _allFields _allInsts _allSigs )) _allRules + -- "Transform.ag"(line 235, column 10) + _allSigsErrs = + Map.mapWithKey (Map.mapWithKey . (checkSigs )) _allSigs + -- "Transform.ag"(line 236, column 10) + _allInstsErrs = + Map.mapWithKey (Map.mapWithKey . (checkInsts _allSigs )) _allInsts + -- "Transform.ag"(line 238, column 10) + _checkedRules = + Map.map (Map.map fst) _allRulesErrs + -- "Transform.ag"(line 239, column 10) + _checkedSigs = + Map.map (Map.map fst) _allSigsErrs + -- "Transform.ag"(line 240, column 10) + _checkedInsts = + Map.map (Map.map fst) _allInstsErrs + -- "Transform.ag"(line 242, column 10) + _errs1 = + let f = checkForDuplicates (DupSynonym) + in Seq.fromList . f . map fst $ _elemsItypeSyns + -- "Transform.ag"(line 245, column 10) + _errs2 = + let g nt (con,fm) = checkForDuplicates (DupChild nt con) (map fst fm) + f (nt,cfm) = concat . map (g nt) . Map.toList $ cfm + in Seq.fromList . concat . map f . Map.toList $ _allFields + -- "Transform.ag"(line 249, column 10) + _errs3 = + let f (nt,cons) = checkForDuplicates (DupAlt nt) cons + in Seq.empty + -- "Transform.ag"(line 253, column 10) + _errs4 = + let f m s = Map.fold ((<>) . snd) s m + in Map.fold f Seq.empty _allRulesErrs + -- "Transform.ag"(line 256, column 10) + _errs5 = + let f m s = Map.fold ((<>) . snd) s m + in Map.fold f Seq.empty _allSigsErrs + -- "Transform.ag"(line 259, column 10) + _errs6 = + let f m s = Map.fold ((<>) . snd) s m + in Map.fold f Seq.empty _allInstsErrs + -- "Transform.ag"(line 262, column 10) + _lhsOerrors = + _elemsIerrors <> _errs1 <> _errs2 <> _errs3 <> _errs4 <> _errs5 <> _errs6 + -- "Transform.ag"(line 345, column 10) + _allNonterminals = + _elemsIcollectedNames `Set.difference` _elemsIcollectedSetNames + -- "Transform.ag"(line 365, column 8) + _elemsOallConstructors = + _elemsIcollectedConstructorsMap + -- "Transform.ag"(line 419, column 8) + _elemsOdefSets = + Map.fromList (map (\x->(x,(Set.singleton x, Set.empty))) (Set.toList _allNonterminals )) + -- "Transform.ag"(line 420, column 8) + _elemsOdefinedSets = + Map.map fst _elemsIdefSets + -- "Transform.ag"(line 664, column 8) + _elemsOattrDecls = + Map.empty + -- "Transform.ag"(line 703, column 9) + _allAttrDecls = + if withSelf _lhsIoptions + then foldr addSelf _elemsIattrDecls (Set.toList _allNonterminals ) + else _elemsIattrDecls + -- use rule "Transform.ag"(line 38, column 19) + _lhsOblocks = + _elemsIblocks + -- use rule "Transform.ag"(line 787, column 37) + _lhsOmoduleDecl = + _elemsImoduleDecl + -- use rule "Transform.ag"(line 501, column 34) + _lhsOpragmas = + _elemsIpragmas + -- copy rule (from local) + _elemsOallAttrDecls = + _allAttrDecls + -- copy rule (from local) + _elemsOallFields = + _allFields + -- copy rule (from local) + _elemsOallNonterminals = + _allNonterminals + ( _elemsIattrDecls,_elemsIattrOrderCollect,_elemsIblocks,_elemsIcollectedConstructorsMap,_elemsIcollectedFields,_elemsIcollectedInsts,_elemsIcollectedNames,_elemsIcollectedRules,_elemsIcollectedSetNames,_elemsIcollectedSigs,_elemsIctxCollect,_elemsIdefSets,_elemsIderivings,_elemsIerrors,_elemsImoduleDecl,_elemsIparamsCollect,_elemsIpragmas,_elemsIsemPragmasCollect,_elemsItypeSyns,_elemsIuseMap,_elemsIwrappers) = + (elems_ _elemsOallAttrDecls _elemsOallConstructors _elemsOallFields _elemsOallNonterminals _elemsOattrDecls _elemsOdefSets _elemsOdefinedSets) + in ( _lhsOblocks,_lhsOerrors,_lhsOmoduleDecl,_lhsOoutput,_lhsOpragmas)))) +-- Alt --------------------------------------------------------- +{- + visit 0: + inherited attributes: + allConstructors : Map NontermIdent (Set ConstructorIdent) + allNonterminals : Set NontermIdent + nts : Set NontermIdent + synthesized attributes: + collectedConstructorNames : Set ConstructorIdent + collectedFields : [(NontermIdent, ConstructorIdent, FieldMap)] + alternatives: + alternative Alt: + child pos : {Pos} + child names : ConstructorSet + child fields : {Fields} +-} +-- cata +sem_Alt :: Alt -> + T_Alt +sem_Alt (Alt _pos _names _fields) = + (sem_Alt_Alt _pos (sem_ConstructorSet _names) _fields) +-- semantic domain +newtype T_Alt = T_Alt ((Map NontermIdent (Set ConstructorIdent)) -> + (Set NontermIdent) -> + (Set NontermIdent) -> + ( (Set ConstructorIdent),([(NontermIdent, ConstructorIdent, FieldMap)]))) +data Inh_Alt = Inh_Alt {allConstructors_Inh_Alt :: Map NontermIdent (Set ConstructorIdent),allNonterminals_Inh_Alt :: Set NontermIdent,nts_Inh_Alt :: Set NontermIdent} +data Syn_Alt = Syn_Alt {collectedConstructorNames_Syn_Alt :: Set ConstructorIdent,collectedFields_Syn_Alt :: [(NontermIdent, ConstructorIdent, FieldMap)]} +wrap_Alt (T_Alt sem) (Inh_Alt _lhsIallConstructors _lhsIallNonterminals _lhsInts) = + (let ( _lhsOcollectedConstructorNames,_lhsOcollectedFields) = + (sem _lhsIallConstructors _lhsIallNonterminals _lhsInts) + in (Syn_Alt _lhsOcollectedConstructorNames _lhsOcollectedFields)) +sem_Alt_Alt :: Pos -> + T_ConstructorSet -> + Fields -> + T_Alt +sem_Alt_Alt pos_ (T_ConstructorSet names_) fields_ = + (T_Alt (\ _lhsIallConstructors + _lhsIallNonterminals + _lhsInts -> + (let _lhsOcollectedFields :: ([(NontermIdent, ConstructorIdent, FieldMap)]) + _lhsOcollectedConstructorNames :: (Set ConstructorIdent) + _namesIcollectedConstructorNames :: (Set ConstructorIdent) + _namesIconstructors :: ((Set ConstructorIdent->Set ConstructorIdent)) + _namesIerrors :: (Seq Error) + -- "Transform.ag"(line 204, column 10) + _lhsOcollectedFields = + let fieldTable = + [ (attr, makeType _lhsIallNonterminals tp) + | (attr, tp) <- fields_ + ] + in [ (nt, con, fieldTable) + | nt <- Set.toList _lhsInts + , con <- Set.toList (_namesIconstructors (Map.findWithDefault Set.empty nt _lhsIallConstructors)) + ] + -- use rule "Transform.ag"(line 82, column 62) + _lhsOcollectedConstructorNames = + _namesIcollectedConstructorNames + ( _namesIcollectedConstructorNames,_namesIconstructors,_namesIerrors) = + (names_ ) + in ( _lhsOcollectedConstructorNames,_lhsOcollectedFields)))) +-- Alts -------------------------------------------------------- +{- + visit 0: + inherited attributes: + allConstructors : Map NontermIdent (Set ConstructorIdent) + allNonterminals : Set NontermIdent + nts : Set NontermIdent + synthesized attributes: + collectedConstructorNames : Set ConstructorIdent + collectedFields : [(NontermIdent, ConstructorIdent, FieldMap)] + alternatives: + alternative Cons: + child hd : Alt + child tl : Alts + alternative Nil: +-} +-- cata +sem_Alts :: Alts -> + T_Alts +sem_Alts list = + (Prelude.foldr sem_Alts_Cons sem_Alts_Nil (Prelude.map sem_Alt list)) +-- semantic domain +newtype T_Alts = T_Alts ((Map NontermIdent (Set ConstructorIdent)) -> + (Set NontermIdent) -> + (Set NontermIdent) -> + ( (Set ConstructorIdent),([(NontermIdent, ConstructorIdent, FieldMap)]))) +data Inh_Alts = Inh_Alts {allConstructors_Inh_Alts :: Map NontermIdent (Set ConstructorIdent),allNonterminals_Inh_Alts :: Set NontermIdent,nts_Inh_Alts :: Set NontermIdent} +data Syn_Alts = Syn_Alts {collectedConstructorNames_Syn_Alts :: Set ConstructorIdent,collectedFields_Syn_Alts :: [(NontermIdent, ConstructorIdent, FieldMap)]} +wrap_Alts (T_Alts sem) (Inh_Alts _lhsIallConstructors _lhsIallNonterminals _lhsInts) = + (let ( _lhsOcollectedConstructorNames,_lhsOcollectedFields) = + (sem _lhsIallConstructors _lhsIallNonterminals _lhsInts) + in (Syn_Alts _lhsOcollectedConstructorNames _lhsOcollectedFields)) +sem_Alts_Cons :: T_Alt -> + T_Alts -> + T_Alts +sem_Alts_Cons (T_Alt hd_) (T_Alts tl_) = + (T_Alts (\ _lhsIallConstructors + _lhsIallNonterminals + _lhsInts -> + (let _lhsOcollectedConstructorNames :: (Set ConstructorIdent) + _lhsOcollectedFields :: ([(NontermIdent, ConstructorIdent, FieldMap)]) + _hdOallConstructors :: (Map NontermIdent (Set ConstructorIdent)) + _hdOallNonterminals :: (Set NontermIdent) + _hdOnts :: (Set NontermIdent) + _tlOallConstructors :: (Map NontermIdent (Set ConstructorIdent)) + _tlOallNonterminals :: (Set NontermIdent) + _tlOnts :: (Set NontermIdent) + _hdIcollectedConstructorNames :: (Set ConstructorIdent) + _hdIcollectedFields :: ([(NontermIdent, ConstructorIdent, FieldMap)]) + _tlIcollectedConstructorNames :: (Set ConstructorIdent) + _tlIcollectedFields :: ([(NontermIdent, ConstructorIdent, FieldMap)]) + -- use rule "Transform.ag"(line 82, column 62) + _lhsOcollectedConstructorNames = + _hdIcollectedConstructorNames `Set.union` _tlIcollectedConstructorNames + -- use rule "Transform.ag"(line 114, column 28) + _lhsOcollectedFields = + _hdIcollectedFields ++ _tlIcollectedFields + -- copy rule (down) + _hdOallConstructors = + _lhsIallConstructors + -- copy rule (down) + _hdOallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _hdOnts = + _lhsInts + -- copy rule (down) + _tlOallConstructors = + _lhsIallConstructors + -- copy rule (down) + _tlOallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _tlOnts = + _lhsInts + ( _hdIcollectedConstructorNames,_hdIcollectedFields) = + (hd_ _hdOallConstructors _hdOallNonterminals _hdOnts) + ( _tlIcollectedConstructorNames,_tlIcollectedFields) = + (tl_ _tlOallConstructors _tlOallNonterminals _tlOnts) + in ( _lhsOcollectedConstructorNames,_lhsOcollectedFields)))) +sem_Alts_Nil :: T_Alts +sem_Alts_Nil = + (T_Alts (\ _lhsIallConstructors + _lhsIallNonterminals + _lhsInts -> + (let _lhsOcollectedConstructorNames :: (Set ConstructorIdent) + _lhsOcollectedFields :: ([(NontermIdent, ConstructorIdent, FieldMap)]) + -- use rule "Transform.ag"(line 82, column 62) + _lhsOcollectedConstructorNames = + Set.empty + -- use rule "Transform.ag"(line 114, column 28) + _lhsOcollectedFields = + [] + in ( _lhsOcollectedConstructorNames,_lhsOcollectedFields)))) +-- Attrs ------------------------------------------------------- +{- + visit 0: + inherited attributes: + allFields : DataTypes + allNonterminals : Set NontermIdent + nts : Set NontermIdent + chained attribute: + attrDecls : Map NontermIdent (Attributes, Attributes) + synthesized attributes: + errors : Seq Error + useMap : Map NontermIdent (Map Identifier (String,String,String)) + alternatives: + alternative Attrs: + child pos : {Pos} + child inh : {AttrNames} + child chn : {AttrNames} + child syn : {AttrNames} + visit 0: + local _tup1 : _ + local attrDecls : _ + local errors : _ + local _tup2 : _ + local inherited : _ + local synthesized : _ + local useMap : _ +-} +-- cata +sem_Attrs :: Attrs -> + T_Attrs +sem_Attrs (Attrs _pos _inh _chn _syn) = + (sem_Attrs_Attrs _pos _inh _chn _syn) +-- semantic domain +newtype T_Attrs = T_Attrs (DataTypes -> + (Set NontermIdent) -> + (Map NontermIdent (Attributes, Attributes)) -> + (Set NontermIdent) -> + ( (Map NontermIdent (Attributes, Attributes)),(Seq Error),(Map NontermIdent (Map Identifier (String,String,String))))) +data Inh_Attrs = Inh_Attrs {allFields_Inh_Attrs :: DataTypes,allNonterminals_Inh_Attrs :: Set NontermIdent,attrDecls_Inh_Attrs :: Map NontermIdent (Attributes, Attributes),nts_Inh_Attrs :: Set NontermIdent} +data Syn_Attrs = Syn_Attrs {attrDecls_Syn_Attrs :: Map NontermIdent (Attributes, Attributes),errors_Syn_Attrs :: Seq Error,useMap_Syn_Attrs :: Map NontermIdent (Map Identifier (String,String,String))} +wrap_Attrs (T_Attrs sem) (Inh_Attrs _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsInts) = + (let ( _lhsOattrDecls,_lhsOerrors,_lhsOuseMap) = + (sem _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsInts) + in (Syn_Attrs _lhsOattrDecls _lhsOerrors _lhsOuseMap)) +sem_Attrs_Attrs :: Pos -> + AttrNames -> + AttrNames -> + AttrNames -> + T_Attrs +sem_Attrs_Attrs pos_ inh_ chn_ syn_ = + (T_Attrs (\ _lhsIallFields + _lhsIallNonterminals + _lhsIattrDecls + _lhsInts -> + (let _lhsOuseMap :: (Map NontermIdent (Map Identifier (String,String,String))) + _lhsOerrors :: (Seq Error) + _lhsOattrDecls :: (Map NontermIdent (Attributes, Attributes)) + -- "Transform.ag"(line 672, column 15) + __tup1 = + checkAttrs _lhsIallFields (Set.toList _lhsInts) _inherited _synthesized _lhsIattrDecls + -- "Transform.ag"(line 672, column 15) + (_attrDecls,_) = + __tup1 + -- "Transform.ag"(line 672, column 15) + (_,_errors) = + __tup1 + -- "Transform.ag"(line 674, column 15) + __tup2 = + let splitAttrs xs = unzip [ ((n,makeType _lhsIallNonterminals t),(n,ud)) + | (n,t,ud) <- xs + ] + (inh,_) = splitAttrs inh_ + (chn,uses1) = splitAttrs chn_ + (syn,uses2) = splitAttrs syn_ + isUse (n,(e1,e2,_)) = not (null e1 || null e2) + in (inh++chn,chn++syn, Map.fromList (Prelude.filter isUse (uses1++uses2))) + -- "Transform.ag"(line 674, column 15) + (_inherited,_,_) = + __tup2 + -- "Transform.ag"(line 674, column 15) + (_,_synthesized,_) = + __tup2 + -- "Transform.ag"(line 674, column 15) + (_,_,_useMap) = + __tup2 + -- "Transform.ag"(line 682, column 11) + _lhsOuseMap = + Map.fromList (zip (Set.toList _lhsInts) (repeat _useMap)) + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + _errors + -- copy rule (from local) + _lhsOattrDecls = + _attrDecls + in ( _lhsOattrDecls,_lhsOerrors,_lhsOuseMap)))) +-- ConstructorSet ---------------------------------------------- +{- + visit 0: + synthesized attributes: + collectedConstructorNames : Set ConstructorIdent + constructors : (Set ConstructorIdent->Set ConstructorIdent) + errors : Seq Error + alternatives: + alternative CAll: + alternative CDifference: + child set1 : ConstructorSet + child set2 : ConstructorSet + alternative CName: + child name : {ConstructorIdent} + alternative CUnion: + child set1 : ConstructorSet + child set2 : ConstructorSet +-} +-- cata +sem_ConstructorSet :: ConstructorSet -> + T_ConstructorSet +sem_ConstructorSet (CAll ) = + (sem_ConstructorSet_CAll ) +sem_ConstructorSet (CDifference _set1 _set2) = + (sem_ConstructorSet_CDifference (sem_ConstructorSet _set1) (sem_ConstructorSet _set2)) +sem_ConstructorSet (CName _name) = + (sem_ConstructorSet_CName _name) +sem_ConstructorSet (CUnion _set1 _set2) = + (sem_ConstructorSet_CUnion (sem_ConstructorSet _set1) (sem_ConstructorSet _set2)) +-- semantic domain +newtype T_ConstructorSet = T_ConstructorSet (( (Set ConstructorIdent),((Set ConstructorIdent->Set ConstructorIdent)),(Seq Error))) +data Inh_ConstructorSet = Inh_ConstructorSet {} +data Syn_ConstructorSet = Syn_ConstructorSet {collectedConstructorNames_Syn_ConstructorSet :: Set ConstructorIdent,constructors_Syn_ConstructorSet :: (Set ConstructorIdent->Set ConstructorIdent),errors_Syn_ConstructorSet :: Seq Error} +wrap_ConstructorSet (T_ConstructorSet sem) (Inh_ConstructorSet ) = + (let ( _lhsOcollectedConstructorNames,_lhsOconstructors,_lhsOerrors) = + (sem ) + in (Syn_ConstructorSet _lhsOcollectedConstructorNames _lhsOconstructors _lhsOerrors)) +sem_ConstructorSet_CAll :: T_ConstructorSet +sem_ConstructorSet_CAll = + (T_ConstructorSet (let _lhsOconstructors :: ((Set ConstructorIdent->Set ConstructorIdent)) + _lhsOcollectedConstructorNames :: (Set ConstructorIdent) + _lhsOerrors :: (Seq Error) + -- "Transform.ag"(line 486, column 17) + _lhsOconstructors = + \ds -> ds + -- use rule "Transform.ag"(line 82, column 62) + _lhsOcollectedConstructorNames = + Set.empty + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + Seq.empty + in ( _lhsOcollectedConstructorNames,_lhsOconstructors,_lhsOerrors))) +sem_ConstructorSet_CDifference :: T_ConstructorSet -> + T_ConstructorSet -> + T_ConstructorSet +sem_ConstructorSet_CDifference (T_ConstructorSet set1_) (T_ConstructorSet set2_) = + (T_ConstructorSet (let _lhsOconstructors :: ((Set ConstructorIdent->Set ConstructorIdent)) + _lhsOcollectedConstructorNames :: (Set ConstructorIdent) + _lhsOerrors :: (Seq Error) + _set1IcollectedConstructorNames :: (Set ConstructorIdent) + _set1Iconstructors :: ((Set ConstructorIdent->Set ConstructorIdent)) + _set1Ierrors :: (Seq Error) + _set2IcollectedConstructorNames :: (Set ConstructorIdent) + _set2Iconstructors :: ((Set ConstructorIdent->Set ConstructorIdent)) + _set2Ierrors :: (Seq Error) + -- "Transform.ag"(line 485, column 17) + _lhsOconstructors = + \ds -> _set1Iconstructors ds `Set.difference` _set2Iconstructors ds + -- use rule "Transform.ag"(line 82, column 62) + _lhsOcollectedConstructorNames = + _set1IcollectedConstructorNames `Set.union` _set2IcollectedConstructorNames + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + _set1Ierrors Seq.<> _set2Ierrors + ( _set1IcollectedConstructorNames,_set1Iconstructors,_set1Ierrors) = + (set1_ ) + ( _set2IcollectedConstructorNames,_set2Iconstructors,_set2Ierrors) = + (set2_ ) + in ( _lhsOcollectedConstructorNames,_lhsOconstructors,_lhsOerrors))) +sem_ConstructorSet_CName :: ConstructorIdent -> + T_ConstructorSet +sem_ConstructorSet_CName name_ = + (T_ConstructorSet (let _lhsOcollectedConstructorNames :: (Set ConstructorIdent) + _lhsOconstructors :: ((Set ConstructorIdent->Set ConstructorIdent)) + _lhsOerrors :: (Seq Error) + -- "Transform.ag"(line 353, column 11) + _lhsOcollectedConstructorNames = + Set.singleton name_ + -- "Transform.ag"(line 483, column 17) + _lhsOconstructors = + \ds -> Set.singleton name_ + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + Seq.empty + in ( _lhsOcollectedConstructorNames,_lhsOconstructors,_lhsOerrors))) +sem_ConstructorSet_CUnion :: T_ConstructorSet -> + T_ConstructorSet -> + T_ConstructorSet +sem_ConstructorSet_CUnion (T_ConstructorSet set1_) (T_ConstructorSet set2_) = + (T_ConstructorSet (let _lhsOconstructors :: ((Set ConstructorIdent->Set ConstructorIdent)) + _lhsOcollectedConstructorNames :: (Set ConstructorIdent) + _lhsOerrors :: (Seq Error) + _set1IcollectedConstructorNames :: (Set ConstructorIdent) + _set1Iconstructors :: ((Set ConstructorIdent->Set ConstructorIdent)) + _set1Ierrors :: (Seq Error) + _set2IcollectedConstructorNames :: (Set ConstructorIdent) + _set2Iconstructors :: ((Set ConstructorIdent->Set ConstructorIdent)) + _set2Ierrors :: (Seq Error) + -- "Transform.ag"(line 484, column 17) + _lhsOconstructors = + \ds -> _set1Iconstructors ds `Set.union` _set2Iconstructors ds + -- use rule "Transform.ag"(line 82, column 62) + _lhsOcollectedConstructorNames = + _set1IcollectedConstructorNames `Set.union` _set2IcollectedConstructorNames + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + _set1Ierrors Seq.<> _set2Ierrors + ( _set1IcollectedConstructorNames,_set1Iconstructors,_set1Ierrors) = + (set1_ ) + ( _set2IcollectedConstructorNames,_set2Iconstructors,_set2Ierrors) = + (set2_ ) + in ( _lhsOcollectedConstructorNames,_lhsOconstructors,_lhsOerrors))) +-- Elem -------------------------------------------------------- +{- + visit 0: + inherited attributes: + allAttrDecls : Map NontermIdent (Attributes, Attributes) + allConstructors : Map NontermIdent (Set ConstructorIdent) + allFields : DataTypes + allNonterminals : Set NontermIdent + definedSets : DefinedSets + chained attributes: + attrDecls : Map NontermIdent (Attributes, Attributes) + defSets : Map Identifier (Set NontermIdent,Set Identifier) + synthesized attributes: + attrOrderCollect : AttrOrderMap + blocks : Blocks + collectedConstructorsMap : Map NontermIdent (Set ConstructorIdent) + collectedFields : [(NontermIdent, ConstructorIdent, FieldMap)] + collectedInsts : [ (NontermIdent, ConstructorIdent, [Identifier]) ] + collectedNames : Set Identifier + collectedRules : [ (NontermIdent, ConstructorIdent, RuleInfo)] + collectedSetNames : Set Identifier + collectedSigs : [ (NontermIdent, ConstructorIdent, SigInfo) ] + ctxCollect : ContextMap + derivings : Derivings + errors : Seq Error + moduleDecl : Maybe (String,String,String) + paramsCollect : ParamMap + pragmas : Options -> Options + semPragmasCollect : PragmaMap + typeSyns : TypeSyns + useMap : Map NontermIdent (Map Identifier (String,String,String)) + wrappers : Set NontermIdent + alternatives: + alternative Attr: + child pos : {Pos} + child ctx : {ClassContext} + child names : NontSet + child attrs : Attrs + alternative Data: + child pos : {Pos} + child ctx : {ClassContext} + child names : NontSet + child params : {[Identifier]} + child attrs : Attrs + child alts : Alts + child ext : {Bool} + alternative Deriving: + child pos : {Pos} + child set : NontSet + child classes : {[NontermIdent]} + alternative Module: + child pos : {Pos} + child name : {String} + child exports : {String} + child imports : {String} + alternative Pragma: + child pos : {Pos} + child names : {[NontermIdent]} + alternative Sem: + child pos : {Pos} + child ctx : {ClassContext} + child names : NontSet + child attrs : Attrs + child alts : SemAlts + alternative Set: + child pos : {Pos} + child name : {NontermIdent} + child set : NontSet + visit 0: + local _tup3 : _ + local defSets2 : _ + local errs : _ + alternative Txt: + child pos : {Pos} + child name : {NontermIdent} + child lines : {[String]} + alternative Type: + child pos : {Pos} + child ctx : {ClassContext} + child name : {NontermIdent} + child params : {[Identifier]} + child type : {ComplexType} + visit 0: + local expanded : _ + local argType : _ + alternative Wrapper: + child pos : {Pos} + child set : NontSet +-} +-- cata +sem_Elem :: Elem -> + T_Elem +sem_Elem (Attr _pos _ctx _names _attrs) = + (sem_Elem_Attr _pos _ctx (sem_NontSet _names) (sem_Attrs _attrs)) +sem_Elem (Data _pos _ctx _names _params _attrs _alts _ext) = + (sem_Elem_Data _pos _ctx (sem_NontSet _names) _params (sem_Attrs _attrs) (sem_Alts _alts) _ext) +sem_Elem (Deriving _pos _set _classes) = + (sem_Elem_Deriving _pos (sem_NontSet _set) _classes) +sem_Elem (Module _pos _name _exports _imports) = + (sem_Elem_Module _pos _name _exports _imports) +sem_Elem (Pragma _pos _names) = + (sem_Elem_Pragma _pos _names) +sem_Elem (Sem _pos _ctx _names _attrs _alts) = + (sem_Elem_Sem _pos _ctx (sem_NontSet _names) (sem_Attrs _attrs) (sem_SemAlts _alts)) +sem_Elem (Set _pos _name _set) = + (sem_Elem_Set _pos _name (sem_NontSet _set)) +sem_Elem (Txt _pos _name _lines) = + (sem_Elem_Txt _pos _name _lines) +sem_Elem (Type _pos _ctx _name _params _type) = + (sem_Elem_Type _pos _ctx _name _params _type) +sem_Elem (Wrapper _pos _set) = + (sem_Elem_Wrapper _pos (sem_NontSet _set)) +-- semantic domain +newtype T_Elem = T_Elem ((Map NontermIdent (Attributes, Attributes)) -> + (Map NontermIdent (Set ConstructorIdent)) -> + DataTypes -> + (Set NontermIdent) -> + (Map NontermIdent (Attributes, Attributes)) -> + (Map Identifier (Set NontermIdent,Set Identifier)) -> + DefinedSets -> + ( (Map NontermIdent (Attributes, Attributes)),AttrOrderMap,Blocks,(Map NontermIdent (Set ConstructorIdent)),([(NontermIdent, ConstructorIdent, FieldMap)]),([ (NontermIdent, ConstructorIdent, [Identifier]) ]),(Set Identifier),([ (NontermIdent, ConstructorIdent, RuleInfo)]),(Set Identifier),([ (NontermIdent, ConstructorIdent, SigInfo) ]),ContextMap,(Map Identifier (Set NontermIdent,Set Identifier)),Derivings,(Seq Error),(Maybe (String,String,String)),ParamMap,(Options -> Options),PragmaMap,TypeSyns,(Map NontermIdent (Map Identifier (String,String,String))),(Set NontermIdent))) +data Inh_Elem = Inh_Elem {allAttrDecls_Inh_Elem :: Map NontermIdent (Attributes, Attributes),allConstructors_Inh_Elem :: Map NontermIdent (Set ConstructorIdent),allFields_Inh_Elem :: DataTypes,allNonterminals_Inh_Elem :: Set NontermIdent,attrDecls_Inh_Elem :: Map NontermIdent (Attributes, Attributes),defSets_Inh_Elem :: Map Identifier (Set NontermIdent,Set Identifier),definedSets_Inh_Elem :: DefinedSets} +data Syn_Elem = Syn_Elem {attrDecls_Syn_Elem :: Map NontermIdent (Attributes, Attributes),attrOrderCollect_Syn_Elem :: AttrOrderMap,blocks_Syn_Elem :: Blocks,collectedConstructorsMap_Syn_Elem :: Map NontermIdent (Set ConstructorIdent),collectedFields_Syn_Elem :: [(NontermIdent, ConstructorIdent, FieldMap)],collectedInsts_Syn_Elem :: [ (NontermIdent, ConstructorIdent, [Identifier]) ],collectedNames_Syn_Elem :: Set Identifier,collectedRules_Syn_Elem :: [ (NontermIdent, ConstructorIdent, RuleInfo)],collectedSetNames_Syn_Elem :: Set Identifier,collectedSigs_Syn_Elem :: [ (NontermIdent, ConstructorIdent, SigInfo) ],ctxCollect_Syn_Elem :: ContextMap,defSets_Syn_Elem :: Map Identifier (Set NontermIdent,Set Identifier),derivings_Syn_Elem :: Derivings,errors_Syn_Elem :: Seq Error,moduleDecl_Syn_Elem :: Maybe (String,String,String),paramsCollect_Syn_Elem :: ParamMap,pragmas_Syn_Elem :: Options -> Options,semPragmasCollect_Syn_Elem :: PragmaMap,typeSyns_Syn_Elem :: TypeSyns,useMap_Syn_Elem :: Map NontermIdent (Map Identifier (String,String,String)),wrappers_Syn_Elem :: Set NontermIdent} +wrap_Elem (T_Elem sem) (Inh_Elem _lhsIallAttrDecls _lhsIallConstructors _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsIdefSets _lhsIdefinedSets) = + (let ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOctxCollect,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOparamsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers) = + (sem _lhsIallAttrDecls _lhsIallConstructors _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsIdefSets _lhsIdefinedSets) + in (Syn_Elem _lhsOattrDecls _lhsOattrOrderCollect _lhsOblocks _lhsOcollectedConstructorsMap _lhsOcollectedFields _lhsOcollectedInsts _lhsOcollectedNames _lhsOcollectedRules _lhsOcollectedSetNames _lhsOcollectedSigs _lhsOctxCollect _lhsOdefSets _lhsOderivings _lhsOerrors _lhsOmoduleDecl _lhsOparamsCollect _lhsOpragmas _lhsOsemPragmasCollect _lhsOtypeSyns _lhsOuseMap _lhsOwrappers)) +sem_Elem_Attr :: Pos -> + ClassContext -> + T_NontSet -> + T_Attrs -> + T_Elem +sem_Elem_Attr pos_ ctx_ (T_NontSet names_) (T_Attrs attrs_) = + (T_Elem (\ _lhsIallAttrDecls + _lhsIallConstructors + _lhsIallFields + _lhsIallNonterminals + _lhsIattrDecls + _lhsIdefSets + _lhsIdefinedSets -> + (let _lhsOctxCollect :: ContextMap + _attrsOnts :: (Set NontermIdent) + _lhsOattrOrderCollect :: AttrOrderMap + _lhsOblocks :: Blocks + _lhsOcollectedConstructorsMap :: (Map NontermIdent (Set ConstructorIdent)) + _lhsOcollectedFields :: ([(NontermIdent, ConstructorIdent, FieldMap)]) + _lhsOcollectedInsts :: ([ (NontermIdent, ConstructorIdent, [Identifier]) ]) + _lhsOcollectedNames :: (Set Identifier) + _lhsOcollectedRules :: ([ (NontermIdent, ConstructorIdent, RuleInfo)]) + _lhsOcollectedSetNames :: (Set Identifier) + _lhsOcollectedSigs :: ([ (NontermIdent, ConstructorIdent, SigInfo) ]) + _lhsOderivings :: Derivings + _lhsOerrors :: (Seq Error) + _lhsOmoduleDecl :: (Maybe (String,String,String)) + _lhsOparamsCollect :: ParamMap + _lhsOpragmas :: (Options -> Options) + _lhsOsemPragmasCollect :: PragmaMap + _lhsOtypeSyns :: TypeSyns + _lhsOuseMap :: (Map NontermIdent (Map Identifier (String,String,String))) + _lhsOwrappers :: (Set NontermIdent) + _lhsOattrDecls :: (Map NontermIdent (Attributes, Attributes)) + _lhsOdefSets :: (Map Identifier (Set NontermIdent,Set Identifier)) + _namesOallFields :: DataTypes + _namesOallNonterminals :: (Set NontermIdent) + _namesOdefinedSets :: DefinedSets + _attrsOallFields :: DataTypes + _attrsOallNonterminals :: (Set NontermIdent) + _attrsOattrDecls :: (Map NontermIdent (Attributes, Attributes)) + _namesIcollectedNames :: (Set Identifier) + _namesIerrors :: (Seq Error) + _namesInontSet :: (Set NontermIdent) + _attrsIattrDecls :: (Map NontermIdent (Attributes, Attributes)) + _attrsIerrors :: (Seq Error) + _attrsIuseMap :: (Map NontermIdent (Map Identifier (String,String,String))) + -- "Transform.ag"(line 624, column 7) + _lhsOctxCollect = + if null ctx_ + then Map.empty + else Map.fromList [(nt, ctx_) | nt <- Set.toList _namesInontSet] + -- "Transform.ag"(line 668, column 10) + _attrsOnts = + _namesInontSet + -- use rule "Transform.ag"(line 565, column 55) + _lhsOattrOrderCollect = + Map.empty + -- use rule "Transform.ag"(line 38, column 19) + _lhsOblocks = + Map.empty + -- use rule "Transform.ag"(line 83, column 48) + _lhsOcollectedConstructorsMap = + Map.empty + -- use rule "Transform.ag"(line 114, column 28) + _lhsOcollectedFields = + [] + -- use rule "Transform.ag"(line 138, column 29) + _lhsOcollectedInsts = + [] + -- use rule "Transform.ag"(line 75, column 50) + _lhsOcollectedNames = + _namesIcollectedNames + -- use rule "Transform.ag"(line 136, column 29) + _lhsOcollectedRules = + [] + -- use rule "Transform.ag"(line 74, column 50) + _lhsOcollectedSetNames = + Set.empty + -- use rule "Transform.ag"(line 137, column 29) + _lhsOcollectedSigs = + [] + -- use rule "Transform.ag"(line 645, column 33) + _lhsOderivings = + Map.empty + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + _namesIerrors Seq.<> _attrsIerrors + -- use rule "Transform.ag"(line 787, column 37) + _lhsOmoduleDecl = + mzero + -- use rule "Transform.ag"(line 597, column 37) + _lhsOparamsCollect = + Map.empty + -- use rule "Transform.ag"(line 501, column 34) + _lhsOpragmas = + id + -- use rule "Transform.ag"(line 537, column 56) + _lhsOsemPragmasCollect = + Map.empty + -- use rule "Transform.ag"(line 380, column 32) + _lhsOtypeSyns = + [] + -- use rule "Transform.ag"(line 126, column 15) + _lhsOuseMap = + _attrsIuseMap + -- use rule "Transform.ag"(line 492, column 32) + _lhsOwrappers = + Set.empty + -- copy rule (up) + _lhsOattrDecls = + _attrsIattrDecls + -- copy rule (chain) + _lhsOdefSets = + _lhsIdefSets + -- copy rule (down) + _namesOallFields = + _lhsIallFields + -- copy rule (down) + _namesOallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _namesOdefinedSets = + _lhsIdefinedSets + -- copy rule (down) + _attrsOallFields = + _lhsIallFields + -- copy rule (down) + _attrsOallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _attrsOattrDecls = + _lhsIattrDecls + ( _namesIcollectedNames,_namesIerrors,_namesInontSet) = + (names_ _namesOallFields _namesOallNonterminals _namesOdefinedSets) + ( _attrsIattrDecls,_attrsIerrors,_attrsIuseMap) = + (attrs_ _attrsOallFields _attrsOallNonterminals _attrsOattrDecls _attrsOnts) + in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOctxCollect,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOparamsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) +sem_Elem_Data :: Pos -> + ClassContext -> + T_NontSet -> + ([Identifier]) -> + T_Attrs -> + T_Alts -> + Bool -> + T_Elem +sem_Elem_Data pos_ ctx_ (T_NontSet names_) params_ (T_Attrs attrs_) (T_Alts alts_) ext_ = + (T_Elem (\ _lhsIallAttrDecls + _lhsIallConstructors + _lhsIallFields + _lhsIallNonterminals + _lhsIattrDecls + _lhsIdefSets + _lhsIdefinedSets -> + (let _altsOnts :: (Set NontermIdent) + _lhsOcollectedConstructorsMap :: (Map NontermIdent (Set ConstructorIdent)) + _lhsOparamsCollect :: ParamMap + _lhsOctxCollect :: ContextMap + _attrsOnts :: (Set NontermIdent) + _lhsOattrOrderCollect :: AttrOrderMap + _lhsOblocks :: Blocks + _lhsOcollectedFields :: ([(NontermIdent, ConstructorIdent, FieldMap)]) + _lhsOcollectedInsts :: ([ (NontermIdent, ConstructorIdent, [Identifier]) ]) + _lhsOcollectedNames :: (Set Identifier) + _lhsOcollectedRules :: ([ (NontermIdent, ConstructorIdent, RuleInfo)]) + _lhsOcollectedSetNames :: (Set Identifier) + _lhsOcollectedSigs :: ([ (NontermIdent, ConstructorIdent, SigInfo) ]) + _lhsOderivings :: Derivings + _lhsOerrors :: (Seq Error) + _lhsOmoduleDecl :: (Maybe (String,String,String)) + _lhsOpragmas :: (Options -> Options) + _lhsOsemPragmasCollect :: PragmaMap + _lhsOtypeSyns :: TypeSyns + _lhsOuseMap :: (Map NontermIdent (Map Identifier (String,String,String))) + _lhsOwrappers :: (Set NontermIdent) + _lhsOattrDecls :: (Map NontermIdent (Attributes, Attributes)) + _lhsOdefSets :: (Map Identifier (Set NontermIdent,Set Identifier)) + _namesOallFields :: DataTypes + _namesOallNonterminals :: (Set NontermIdent) + _namesOdefinedSets :: DefinedSets + _attrsOallFields :: DataTypes + _attrsOallNonterminals :: (Set NontermIdent) + _attrsOattrDecls :: (Map NontermIdent (Attributes, Attributes)) + _altsOallConstructors :: (Map NontermIdent (Set ConstructorIdent)) + _altsOallNonterminals :: (Set NontermIdent) + _namesIcollectedNames :: (Set Identifier) + _namesIerrors :: (Seq Error) + _namesInontSet :: (Set NontermIdent) + _attrsIattrDecls :: (Map NontermIdent (Attributes, Attributes)) + _attrsIerrors :: (Seq Error) + _attrsIuseMap :: (Map NontermIdent (Map Identifier (String,String,String))) + _altsIcollectedConstructorNames :: (Set ConstructorIdent) + _altsIcollectedFields :: ([(NontermIdent, ConstructorIdent, FieldMap)]) + -- "Transform.ag"(line 151, column 10) + _altsOnts = + _namesInontSet + -- "Transform.ag"(line 359, column 11) + _lhsOcollectedConstructorsMap = + Map.fromList + [ (n, _altsIcollectedConstructorNames) + | n <- Set.toList _namesInontSet + ] + -- "Transform.ag"(line 601, column 7) + _lhsOparamsCollect = + if null params_ + then Map.empty + else Map.fromList [(nt, params_) | nt <- Set.toList _namesInontSet] + -- "Transform.ag"(line 624, column 7) + _lhsOctxCollect = + if null ctx_ + then Map.empty + else Map.fromList [(nt, ctx_) | nt <- Set.toList _namesInontSet] + -- "Transform.ag"(line 667, column 10) + _attrsOnts = + _namesInontSet + -- use rule "Transform.ag"(line 565, column 55) + _lhsOattrOrderCollect = + Map.empty + -- use rule "Transform.ag"(line 38, column 19) + _lhsOblocks = + Map.empty + -- use rule "Transform.ag"(line 114, column 28) + _lhsOcollectedFields = + _altsIcollectedFields + -- use rule "Transform.ag"(line 138, column 29) + _lhsOcollectedInsts = + [] + -- use rule "Transform.ag"(line 75, column 50) + _lhsOcollectedNames = + _namesIcollectedNames + -- use rule "Transform.ag"(line 136, column 29) + _lhsOcollectedRules = + [] + -- use rule "Transform.ag"(line 74, column 50) + _lhsOcollectedSetNames = + Set.empty + -- use rule "Transform.ag"(line 137, column 29) + _lhsOcollectedSigs = + [] + -- use rule "Transform.ag"(line 645, column 33) + _lhsOderivings = + Map.empty + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + _namesIerrors Seq.<> _attrsIerrors + -- use rule "Transform.ag"(line 787, column 37) + _lhsOmoduleDecl = + mzero + -- use rule "Transform.ag"(line 501, column 34) + _lhsOpragmas = + id + -- use rule "Transform.ag"(line 537, column 56) + _lhsOsemPragmasCollect = + Map.empty + -- use rule "Transform.ag"(line 380, column 32) + _lhsOtypeSyns = + [] + -- use rule "Transform.ag"(line 126, column 15) + _lhsOuseMap = + _attrsIuseMap + -- use rule "Transform.ag"(line 492, column 32) + _lhsOwrappers = + Set.empty + -- copy rule (up) + _lhsOattrDecls = + _attrsIattrDecls + -- copy rule (chain) + _lhsOdefSets = + _lhsIdefSets + -- copy rule (down) + _namesOallFields = + _lhsIallFields + -- copy rule (down) + _namesOallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _namesOdefinedSets = + _lhsIdefinedSets + -- copy rule (down) + _attrsOallFields = + _lhsIallFields + -- copy rule (down) + _attrsOallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _attrsOattrDecls = + _lhsIattrDecls + -- copy rule (down) + _altsOallConstructors = + _lhsIallConstructors + -- copy rule (down) + _altsOallNonterminals = + _lhsIallNonterminals + ( _namesIcollectedNames,_namesIerrors,_namesInontSet) = + (names_ _namesOallFields _namesOallNonterminals _namesOdefinedSets) + ( _attrsIattrDecls,_attrsIerrors,_attrsIuseMap) = + (attrs_ _attrsOallFields _attrsOallNonterminals _attrsOattrDecls _attrsOnts) + ( _altsIcollectedConstructorNames,_altsIcollectedFields) = + (alts_ _altsOallConstructors _altsOallNonterminals _altsOnts) + in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOctxCollect,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOparamsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) +sem_Elem_Deriving :: Pos -> + T_NontSet -> + ([NontermIdent]) -> + T_Elem +sem_Elem_Deriving pos_ (T_NontSet set_) classes_ = + (T_Elem (\ _lhsIallAttrDecls + _lhsIallConstructors + _lhsIallFields + _lhsIallNonterminals + _lhsIattrDecls + _lhsIdefSets + _lhsIdefinedSets -> + (let _lhsOderivings :: Derivings + _lhsOattrOrderCollect :: AttrOrderMap + _lhsOblocks :: Blocks + _lhsOcollectedConstructorsMap :: (Map NontermIdent (Set ConstructorIdent)) + _lhsOcollectedFields :: ([(NontermIdent, ConstructorIdent, FieldMap)]) + _lhsOcollectedInsts :: ([ (NontermIdent, ConstructorIdent, [Identifier]) ]) + _lhsOcollectedNames :: (Set Identifier) + _lhsOcollectedRules :: ([ (NontermIdent, ConstructorIdent, RuleInfo)]) + _lhsOcollectedSetNames :: (Set Identifier) + _lhsOcollectedSigs :: ([ (NontermIdent, ConstructorIdent, SigInfo) ]) + _lhsOctxCollect :: ContextMap + _lhsOerrors :: (Seq Error) + _lhsOmoduleDecl :: (Maybe (String,String,String)) + _lhsOparamsCollect :: ParamMap + _lhsOpragmas :: (Options -> Options) + _lhsOsemPragmasCollect :: PragmaMap + _lhsOtypeSyns :: TypeSyns + _lhsOuseMap :: (Map NontermIdent (Map Identifier (String,String,String))) + _lhsOwrappers :: (Set NontermIdent) + _lhsOattrDecls :: (Map NontermIdent (Attributes, Attributes)) + _lhsOdefSets :: (Map Identifier (Set NontermIdent,Set Identifier)) + _setOallFields :: DataTypes + _setOallNonterminals :: (Set NontermIdent) + _setOdefinedSets :: DefinedSets + _setIcollectedNames :: (Set Identifier) + _setIerrors :: (Seq Error) + _setInontSet :: (Set NontermIdent) + -- "Transform.ag"(line 652, column 14) + _lhsOderivings = + Map.fromList [(nt,Set.fromList classes_) | nt <- Set.toList _setInontSet] + -- use rule "Transform.ag"(line 565, column 55) + _lhsOattrOrderCollect = + Map.empty + -- use rule "Transform.ag"(line 38, column 19) + _lhsOblocks = + Map.empty + -- use rule "Transform.ag"(line 83, column 48) + _lhsOcollectedConstructorsMap = + Map.empty + -- use rule "Transform.ag"(line 114, column 28) + _lhsOcollectedFields = + [] + -- use rule "Transform.ag"(line 138, column 29) + _lhsOcollectedInsts = + [] + -- use rule "Transform.ag"(line 75, column 50) + _lhsOcollectedNames = + _setIcollectedNames + -- use rule "Transform.ag"(line 136, column 29) + _lhsOcollectedRules = + [] + -- use rule "Transform.ag"(line 74, column 50) + _lhsOcollectedSetNames = + Set.empty + -- use rule "Transform.ag"(line 137, column 29) + _lhsOcollectedSigs = + [] + -- use rule "Transform.ag"(line 620, column 34) + _lhsOctxCollect = + Map.empty + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + _setIerrors + -- use rule "Transform.ag"(line 787, column 37) + _lhsOmoduleDecl = + mzero + -- use rule "Transform.ag"(line 597, column 37) + _lhsOparamsCollect = + Map.empty + -- use rule "Transform.ag"(line 501, column 34) + _lhsOpragmas = + id + -- use rule "Transform.ag"(line 537, column 56) + _lhsOsemPragmasCollect = + Map.empty + -- use rule "Transform.ag"(line 380, column 32) + _lhsOtypeSyns = + [] + -- use rule "Transform.ag"(line 126, column 15) + _lhsOuseMap = + Map.empty + -- use rule "Transform.ag"(line 492, column 32) + _lhsOwrappers = + Set.empty + -- copy rule (chain) + _lhsOattrDecls = + _lhsIattrDecls + -- copy rule (chain) + _lhsOdefSets = + _lhsIdefSets + -- copy rule (down) + _setOallFields = + _lhsIallFields + -- copy rule (down) + _setOallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _setOdefinedSets = + _lhsIdefinedSets + ( _setIcollectedNames,_setIerrors,_setInontSet) = + (set_ _setOallFields _setOallNonterminals _setOdefinedSets) + in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOctxCollect,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOparamsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) +sem_Elem_Module :: Pos -> + String -> + String -> + String -> + T_Elem +sem_Elem_Module pos_ name_ exports_ imports_ = + (T_Elem (\ _lhsIallAttrDecls + _lhsIallConstructors + _lhsIallFields + _lhsIallNonterminals + _lhsIattrDecls + _lhsIdefSets + _lhsIdefinedSets -> + (let _lhsOmoduleDecl :: (Maybe (String,String,String)) + _lhsOattrOrderCollect :: AttrOrderMap + _lhsOblocks :: Blocks + _lhsOcollectedConstructorsMap :: (Map NontermIdent (Set ConstructorIdent)) + _lhsOcollectedFields :: ([(NontermIdent, ConstructorIdent, FieldMap)]) + _lhsOcollectedInsts :: ([ (NontermIdent, ConstructorIdent, [Identifier]) ]) + _lhsOcollectedNames :: (Set Identifier) + _lhsOcollectedRules :: ([ (NontermIdent, ConstructorIdent, RuleInfo)]) + _lhsOcollectedSetNames :: (Set Identifier) + _lhsOcollectedSigs :: ([ (NontermIdent, ConstructorIdent, SigInfo) ]) + _lhsOctxCollect :: ContextMap + _lhsOderivings :: Derivings + _lhsOerrors :: (Seq Error) + _lhsOparamsCollect :: ParamMap + _lhsOpragmas :: (Options -> Options) + _lhsOsemPragmasCollect :: PragmaMap + _lhsOtypeSyns :: TypeSyns + _lhsOuseMap :: (Map NontermIdent (Map Identifier (String,String,String))) + _lhsOwrappers :: (Set NontermIdent) + _lhsOattrDecls :: (Map NontermIdent (Attributes, Attributes)) + _lhsOdefSets :: (Map Identifier (Set NontermIdent,Set Identifier)) + -- "Transform.ag"(line 791, column 7) + _lhsOmoduleDecl = + Just (name_, exports_, imports_) + -- use rule "Transform.ag"(line 565, column 55) + _lhsOattrOrderCollect = + Map.empty + -- use rule "Transform.ag"(line 38, column 19) + _lhsOblocks = + Map.empty + -- use rule "Transform.ag"(line 83, column 48) + _lhsOcollectedConstructorsMap = + Map.empty + -- use rule "Transform.ag"(line 114, column 28) + _lhsOcollectedFields = + [] + -- use rule "Transform.ag"(line 138, column 29) + _lhsOcollectedInsts = + [] + -- use rule "Transform.ag"(line 75, column 50) + _lhsOcollectedNames = + Set.empty + -- use rule "Transform.ag"(line 136, column 29) + _lhsOcollectedRules = + [] + -- use rule "Transform.ag"(line 74, column 50) + _lhsOcollectedSetNames = + Set.empty + -- use rule "Transform.ag"(line 137, column 29) + _lhsOcollectedSigs = + [] + -- use rule "Transform.ag"(line 620, column 34) + _lhsOctxCollect = + Map.empty + -- use rule "Transform.ag"(line 645, column 33) + _lhsOderivings = + Map.empty + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + Seq.empty + -- use rule "Transform.ag"(line 597, column 37) + _lhsOparamsCollect = + Map.empty + -- use rule "Transform.ag"(line 501, column 34) + _lhsOpragmas = + id + -- use rule "Transform.ag"(line 537, column 56) + _lhsOsemPragmasCollect = + Map.empty + -- use rule "Transform.ag"(line 380, column 32) + _lhsOtypeSyns = + [] + -- use rule "Transform.ag"(line 126, column 15) + _lhsOuseMap = + Map.empty + -- use rule "Transform.ag"(line 492, column 32) + _lhsOwrappers = + Set.empty + -- copy rule (chain) + _lhsOattrDecls = + _lhsIattrDecls + -- copy rule (chain) + _lhsOdefSets = + _lhsIdefSets + in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOctxCollect,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOparamsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) +sem_Elem_Pragma :: Pos -> + ([NontermIdent]) -> + T_Elem +sem_Elem_Pragma pos_ names_ = + (T_Elem (\ _lhsIallAttrDecls + _lhsIallConstructors + _lhsIallFields + _lhsIallNonterminals + _lhsIattrDecls + _lhsIdefSets + _lhsIdefinedSets -> + (let _lhsOpragmas :: (Options -> Options) + _lhsOattrOrderCollect :: AttrOrderMap + _lhsOblocks :: Blocks + _lhsOcollectedConstructorsMap :: (Map NontermIdent (Set ConstructorIdent)) + _lhsOcollectedFields :: ([(NontermIdent, ConstructorIdent, FieldMap)]) + _lhsOcollectedInsts :: ([ (NontermIdent, ConstructorIdent, [Identifier]) ]) + _lhsOcollectedNames :: (Set Identifier) + _lhsOcollectedRules :: ([ (NontermIdent, ConstructorIdent, RuleInfo)]) + _lhsOcollectedSetNames :: (Set Identifier) + _lhsOcollectedSigs :: ([ (NontermIdent, ConstructorIdent, SigInfo) ]) + _lhsOctxCollect :: ContextMap + _lhsOderivings :: Derivings + _lhsOerrors :: (Seq Error) + _lhsOmoduleDecl :: (Maybe (String,String,String)) + _lhsOparamsCollect :: ParamMap + _lhsOsemPragmasCollect :: PragmaMap + _lhsOtypeSyns :: TypeSyns + _lhsOuseMap :: (Map NontermIdent (Map Identifier (String,String,String))) + _lhsOwrappers :: (Set NontermIdent) + _lhsOattrDecls :: (Map NontermIdent (Attributes, Attributes)) + _lhsOdefSets :: (Map Identifier (Set NontermIdent,Set Identifier)) + -- "Transform.ag"(line 504, column 13) + _lhsOpragmas = + let mk n o = case getName n of + "nocycle" -> o { withCycle = False } + "cycle" -> o { withCycle = True } + "nostrictdata" -> o { strictData = False } + "strictdata" -> o { strictData = True } + "nostrictcase" -> o { strictCases = False } + "strictcase" -> o { strictCases = True } + "strictercase" -> o { strictCases = True, stricterCases = True } + "nostrictwrap" -> o { strictWrap = False } + "strictwrap" -> o { strictWrap = True } + "novisit" -> o { visit = False } + "visit" -> o { visit = True } + "nocase" -> o { cases = False } + "case" -> o { cases = True } + "noseq" -> o { withSeq = False } + "seq" -> o { withSeq = True } + "nounbox" -> o { unbox = False } + "unbox" -> o { unbox = True } + "bangpats" -> o { bangpats = True } + "nooptimize" -> o { cases = False , visit = False } + "optimize" -> o { cases = True , visit = True } + "strictsem" -> o { strictSems = True } + "gentraces" -> o { genTraces = True } + "genusetraces" -> o { genUseTraces = True } + "splitsems" -> o { splitSems = True } + "gencostcentres" -> o { genCostCentres = True } + "sepsemmods" -> o { sepSemMods = True } + "genlinepragmas" -> o { genLinePragmas = True } + "newtypes" -> o { newtypes = True } + "nonewtypes" -> o { newtypes = False } + _ -> o + in \o -> foldr mk o names_ + -- use rule "Transform.ag"(line 565, column 55) + _lhsOattrOrderCollect = + Map.empty + -- use rule "Transform.ag"(line 38, column 19) + _lhsOblocks = + Map.empty + -- use rule "Transform.ag"(line 83, column 48) + _lhsOcollectedConstructorsMap = + Map.empty + -- use rule "Transform.ag"(line 114, column 28) + _lhsOcollectedFields = + [] + -- use rule "Transform.ag"(line 138, column 29) + _lhsOcollectedInsts = + [] + -- use rule "Transform.ag"(line 75, column 50) + _lhsOcollectedNames = + Set.empty + -- use rule "Transform.ag"(line 136, column 29) + _lhsOcollectedRules = + [] + -- use rule "Transform.ag"(line 74, column 50) + _lhsOcollectedSetNames = + Set.empty + -- use rule "Transform.ag"(line 137, column 29) + _lhsOcollectedSigs = + [] + -- use rule "Transform.ag"(line 620, column 34) + _lhsOctxCollect = + Map.empty + -- use rule "Transform.ag"(line 645, column 33) + _lhsOderivings = + Map.empty + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + Seq.empty + -- use rule "Transform.ag"(line 787, column 37) + _lhsOmoduleDecl = + mzero + -- use rule "Transform.ag"(line 597, column 37) + _lhsOparamsCollect = + Map.empty + -- use rule "Transform.ag"(line 537, column 56) + _lhsOsemPragmasCollect = + Map.empty + -- use rule "Transform.ag"(line 380, column 32) + _lhsOtypeSyns = + [] + -- use rule "Transform.ag"(line 126, column 15) + _lhsOuseMap = + Map.empty + -- use rule "Transform.ag"(line 492, column 32) + _lhsOwrappers = + Set.empty + -- copy rule (chain) + _lhsOattrDecls = + _lhsIattrDecls + -- copy rule (chain) + _lhsOdefSets = + _lhsIdefSets + in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOctxCollect,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOparamsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) +sem_Elem_Sem :: Pos -> + ClassContext -> + T_NontSet -> + T_Attrs -> + T_SemAlts -> + T_Elem +sem_Elem_Sem pos_ ctx_ (T_NontSet names_) (T_Attrs attrs_) (T_SemAlts alts_) = + (T_Elem (\ _lhsIallAttrDecls + _lhsIallConstructors + _lhsIallFields + _lhsIallNonterminals + _lhsIattrDecls + _lhsIdefSets + _lhsIdefinedSets -> + (let _altsOnts :: (Set NontermIdent) + _lhsOctxCollect :: ContextMap + _attrsOnts :: (Set NontermIdent) + _lhsOattrOrderCollect :: AttrOrderMap + _lhsOblocks :: Blocks + _lhsOcollectedConstructorsMap :: (Map NontermIdent (Set ConstructorIdent)) + _lhsOcollectedFields :: ([(NontermIdent, ConstructorIdent, FieldMap)]) + _lhsOcollectedInsts :: ([ (NontermIdent, ConstructorIdent, [Identifier]) ]) + _lhsOcollectedNames :: (Set Identifier) + _lhsOcollectedRules :: ([ (NontermIdent, ConstructorIdent, RuleInfo)]) + _lhsOcollectedSetNames :: (Set Identifier) + _lhsOcollectedSigs :: ([ (NontermIdent, ConstructorIdent, SigInfo) ]) + _lhsOderivings :: Derivings + _lhsOerrors :: (Seq Error) + _lhsOmoduleDecl :: (Maybe (String,String,String)) + _lhsOparamsCollect :: ParamMap + _lhsOpragmas :: (Options -> Options) + _lhsOsemPragmasCollect :: PragmaMap + _lhsOtypeSyns :: TypeSyns + _lhsOuseMap :: (Map NontermIdent (Map Identifier (String,String,String))) + _lhsOwrappers :: (Set NontermIdent) + _lhsOattrDecls :: (Map NontermIdent (Attributes, Attributes)) + _lhsOdefSets :: (Map Identifier (Set NontermIdent,Set Identifier)) + _namesOallFields :: DataTypes + _namesOallNonterminals :: (Set NontermIdent) + _namesOdefinedSets :: DefinedSets + _attrsOallFields :: DataTypes + _attrsOallNonterminals :: (Set NontermIdent) + _attrsOattrDecls :: (Map NontermIdent (Attributes, Attributes)) + _altsOallAttrDecls :: (Map NontermIdent (Attributes, Attributes)) + _altsOallFields :: DataTypes + _namesIcollectedNames :: (Set Identifier) + _namesIerrors :: (Seq Error) + _namesInontSet :: (Set NontermIdent) + _attrsIattrDecls :: (Map NontermIdent (Attributes, Attributes)) + _attrsIerrors :: (Seq Error) + _attrsIuseMap :: (Map NontermIdent (Map Identifier (String,String,String))) + _altsIattrOrderCollect :: AttrOrderMap + _altsIcollectedInsts :: ([ (NontermIdent, ConstructorIdent, [Identifier]) ]) + _altsIcollectedRules :: ([ (NontermIdent, ConstructorIdent, RuleInfo)]) + _altsIcollectedSigs :: ([ (NontermIdent, ConstructorIdent, SigInfo) ]) + _altsIerrors :: (Seq Error) + _altsIsemPragmasCollect :: PragmaMap + -- "Transform.ag"(line 152, column 10) + _altsOnts = + _namesInontSet + -- "Transform.ag"(line 624, column 7) + _lhsOctxCollect = + if null ctx_ + then Map.empty + else Map.fromList [(nt, ctx_) | nt <- Set.toList _namesInontSet] + -- "Transform.ag"(line 669, column 10) + _attrsOnts = + _namesInontSet + -- use rule "Transform.ag"(line 565, column 55) + _lhsOattrOrderCollect = + _altsIattrOrderCollect + -- use rule "Transform.ag"(line 38, column 19) + _lhsOblocks = + Map.empty + -- use rule "Transform.ag"(line 83, column 48) + _lhsOcollectedConstructorsMap = + Map.empty + -- use rule "Transform.ag"(line 114, column 28) + _lhsOcollectedFields = + [] + -- use rule "Transform.ag"(line 138, column 29) + _lhsOcollectedInsts = + _altsIcollectedInsts + -- use rule "Transform.ag"(line 75, column 50) + _lhsOcollectedNames = + _namesIcollectedNames + -- use rule "Transform.ag"(line 136, column 29) + _lhsOcollectedRules = + _altsIcollectedRules + -- use rule "Transform.ag"(line 74, column 50) + _lhsOcollectedSetNames = + Set.empty + -- use rule "Transform.ag"(line 137, column 29) + _lhsOcollectedSigs = + _altsIcollectedSigs + -- use rule "Transform.ag"(line 645, column 33) + _lhsOderivings = + Map.empty + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + _namesIerrors Seq.<> _attrsIerrors Seq.<> _altsIerrors + -- use rule "Transform.ag"(line 787, column 37) + _lhsOmoduleDecl = + mzero + -- use rule "Transform.ag"(line 597, column 37) + _lhsOparamsCollect = + Map.empty + -- use rule "Transform.ag"(line 501, column 34) + _lhsOpragmas = + id + -- use rule "Transform.ag"(line 537, column 56) + _lhsOsemPragmasCollect = + _altsIsemPragmasCollect + -- use rule "Transform.ag"(line 380, column 32) + _lhsOtypeSyns = + [] + -- use rule "Transform.ag"(line 126, column 15) + _lhsOuseMap = + _attrsIuseMap + -- use rule "Transform.ag"(line 492, column 32) + _lhsOwrappers = + Set.empty + -- copy rule (up) + _lhsOattrDecls = + _attrsIattrDecls + -- copy rule (chain) + _lhsOdefSets = + _lhsIdefSets + -- copy rule (down) + _namesOallFields = + _lhsIallFields + -- copy rule (down) + _namesOallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _namesOdefinedSets = + _lhsIdefinedSets + -- copy rule (down) + _attrsOallFields = + _lhsIallFields + -- copy rule (down) + _attrsOallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _attrsOattrDecls = + _lhsIattrDecls + -- copy rule (down) + _altsOallAttrDecls = + _lhsIallAttrDecls + -- copy rule (down) + _altsOallFields = + _lhsIallFields + ( _namesIcollectedNames,_namesIerrors,_namesInontSet) = + (names_ _namesOallFields _namesOallNonterminals _namesOdefinedSets) + ( _attrsIattrDecls,_attrsIerrors,_attrsIuseMap) = + (attrs_ _attrsOallFields _attrsOallNonterminals _attrsOattrDecls _attrsOnts) + ( _altsIattrOrderCollect,_altsIcollectedInsts,_altsIcollectedRules,_altsIcollectedSigs,_altsIerrors,_altsIsemPragmasCollect) = + (alts_ _altsOallAttrDecls _altsOallFields _altsOnts) + in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOctxCollect,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOparamsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) +sem_Elem_Set :: Pos -> + NontermIdent -> + T_NontSet -> + T_Elem +sem_Elem_Set pos_ name_ (T_NontSet set_) = + (T_Elem (\ _lhsIallAttrDecls + _lhsIallConstructors + _lhsIallFields + _lhsIallNonterminals + _lhsIattrDecls + _lhsIdefSets + _lhsIdefinedSets -> + (let _lhsOcollectedSetNames :: (Set Identifier) + _lhsOdefSets :: (Map Identifier (Set NontermIdent,Set Identifier)) + _lhsOerrors :: (Seq Error) + _lhsOattrOrderCollect :: AttrOrderMap + _lhsOblocks :: Blocks + _lhsOcollectedConstructorsMap :: (Map NontermIdent (Set ConstructorIdent)) + _lhsOcollectedFields :: ([(NontermIdent, ConstructorIdent, FieldMap)]) + _lhsOcollectedInsts :: ([ (NontermIdent, ConstructorIdent, [Identifier]) ]) + _lhsOcollectedNames :: (Set Identifier) + _lhsOcollectedRules :: ([ (NontermIdent, ConstructorIdent, RuleInfo)]) + _lhsOcollectedSigs :: ([ (NontermIdent, ConstructorIdent, SigInfo) ]) + _lhsOctxCollect :: ContextMap + _lhsOderivings :: Derivings + _lhsOmoduleDecl :: (Maybe (String,String,String)) + _lhsOparamsCollect :: ParamMap + _lhsOpragmas :: (Options -> Options) + _lhsOsemPragmasCollect :: PragmaMap + _lhsOtypeSyns :: TypeSyns + _lhsOuseMap :: (Map NontermIdent (Map Identifier (String,String,String))) + _lhsOwrappers :: (Set NontermIdent) + _lhsOattrDecls :: (Map NontermIdent (Attributes, Attributes)) + _setOallFields :: DataTypes + _setOallNonterminals :: (Set NontermIdent) + _setOdefinedSets :: DefinedSets + _setIcollectedNames :: (Set Identifier) + _setIerrors :: (Seq Error) + _setInontSet :: (Set NontermIdent) + -- "Transform.ag"(line 336, column 10) + _lhsOcollectedSetNames = + Set.singleton name_ + -- "Transform.ag"(line 424, column 13) + __tup3 = + let allUsedNames = Set.unions [ maybe (Set.singleton n) + snd + (Map.lookup n _lhsIdefSets) + | n <- Set.toList _setIcollectedNames + ] + (nontSet,e1) | Set.member name_ allUsedNames + = (Set.empty, Seq.single(CyclicSet name_)) + | otherwise = (_setInontSet, Seq.empty) + (res, e2) = checkDuplicate DupSet name_ (nontSet,Set.insert name_ allUsedNames) _lhsIdefSets + in (res, e1 Seq.<> e2) + -- "Transform.ag"(line 424, column 13) + (_defSets2,_) = + __tup3 + -- "Transform.ag"(line 424, column 13) + (_,_errs) = + __tup3 + -- "Transform.ag"(line 434, column 9) + _lhsOdefSets = + _defSets2 + -- "Transform.ag"(line 434, column 9) + _lhsOerrors = + _errs <> _setIerrors + -- use rule "Transform.ag"(line 565, column 55) + _lhsOattrOrderCollect = + Map.empty + -- use rule "Transform.ag"(line 38, column 19) + _lhsOblocks = + Map.empty + -- use rule "Transform.ag"(line 83, column 48) + _lhsOcollectedConstructorsMap = + Map.empty + -- use rule "Transform.ag"(line 114, column 28) + _lhsOcollectedFields = + [] + -- use rule "Transform.ag"(line 138, column 29) + _lhsOcollectedInsts = + [] + -- use rule "Transform.ag"(line 75, column 50) + _lhsOcollectedNames = + _setIcollectedNames + -- use rule "Transform.ag"(line 136, column 29) + _lhsOcollectedRules = + [] + -- use rule "Transform.ag"(line 137, column 29) + _lhsOcollectedSigs = + [] + -- use rule "Transform.ag"(line 620, column 34) + _lhsOctxCollect = + Map.empty + -- use rule "Transform.ag"(line 645, column 33) + _lhsOderivings = + Map.empty + -- use rule "Transform.ag"(line 787, column 37) + _lhsOmoduleDecl = + mzero + -- use rule "Transform.ag"(line 597, column 37) + _lhsOparamsCollect = + Map.empty + -- use rule "Transform.ag"(line 501, column 34) + _lhsOpragmas = + id + -- use rule "Transform.ag"(line 537, column 56) + _lhsOsemPragmasCollect = + Map.empty + -- use rule "Transform.ag"(line 380, column 32) + _lhsOtypeSyns = + [] + -- use rule "Transform.ag"(line 126, column 15) + _lhsOuseMap = + Map.empty + -- use rule "Transform.ag"(line 492, column 32) + _lhsOwrappers = + Set.empty + -- copy rule (chain) + _lhsOattrDecls = + _lhsIattrDecls + -- copy rule (down) + _setOallFields = + _lhsIallFields + -- copy rule (down) + _setOallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _setOdefinedSets = + _lhsIdefinedSets + ( _setIcollectedNames,_setIerrors,_setInontSet) = + (set_ _setOallFields _setOallNonterminals _setOdefinedSets) + in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOctxCollect,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOparamsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) +sem_Elem_Txt :: Pos -> + NontermIdent -> + ([String]) -> + T_Elem +sem_Elem_Txt pos_ name_ lines_ = + (T_Elem (\ _lhsIallAttrDecls + _lhsIallConstructors + _lhsIallFields + _lhsIallNonterminals + _lhsIattrDecls + _lhsIdefSets + _lhsIdefinedSets -> + (let _lhsOblocks :: Blocks + _lhsOattrOrderCollect :: AttrOrderMap + _lhsOcollectedConstructorsMap :: (Map NontermIdent (Set ConstructorIdent)) + _lhsOcollectedFields :: ([(NontermIdent, ConstructorIdent, FieldMap)]) + _lhsOcollectedInsts :: ([ (NontermIdent, ConstructorIdent, [Identifier]) ]) + _lhsOcollectedNames :: (Set Identifier) + _lhsOcollectedRules :: ([ (NontermIdent, ConstructorIdent, RuleInfo)]) + _lhsOcollectedSetNames :: (Set Identifier) + _lhsOcollectedSigs :: ([ (NontermIdent, ConstructorIdent, SigInfo) ]) + _lhsOctxCollect :: ContextMap + _lhsOderivings :: Derivings + _lhsOerrors :: (Seq Error) + _lhsOmoduleDecl :: (Maybe (String,String,String)) + _lhsOparamsCollect :: ParamMap + _lhsOpragmas :: (Options -> Options) + _lhsOsemPragmasCollect :: PragmaMap + _lhsOtypeSyns :: TypeSyns + _lhsOuseMap :: (Map NontermIdent (Map Identifier (String,String,String))) + _lhsOwrappers :: (Set NontermIdent) + _lhsOattrDecls :: (Map NontermIdent (Attributes, Attributes)) + _lhsOdefSets :: (Map Identifier (Set NontermIdent,Set Identifier)) + -- "Transform.ag"(line 161, column 11) + _lhsOblocks = + Map.singleton (getName name_) [(lines_, pos_)] + -- use rule "Transform.ag"(line 565, column 55) + _lhsOattrOrderCollect = + Map.empty + -- use rule "Transform.ag"(line 83, column 48) + _lhsOcollectedConstructorsMap = + Map.empty + -- use rule "Transform.ag"(line 114, column 28) + _lhsOcollectedFields = + [] + -- use rule "Transform.ag"(line 138, column 29) + _lhsOcollectedInsts = + [] + -- use rule "Transform.ag"(line 75, column 50) + _lhsOcollectedNames = + Set.empty + -- use rule "Transform.ag"(line 136, column 29) + _lhsOcollectedRules = + [] + -- use rule "Transform.ag"(line 74, column 50) + _lhsOcollectedSetNames = + Set.empty + -- use rule "Transform.ag"(line 137, column 29) + _lhsOcollectedSigs = + [] + -- use rule "Transform.ag"(line 620, column 34) + _lhsOctxCollect = + Map.empty + -- use rule "Transform.ag"(line 645, column 33) + _lhsOderivings = + Map.empty + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + Seq.empty + -- use rule "Transform.ag"(line 787, column 37) + _lhsOmoduleDecl = + mzero + -- use rule "Transform.ag"(line 597, column 37) + _lhsOparamsCollect = + Map.empty + -- use rule "Transform.ag"(line 501, column 34) + _lhsOpragmas = + id + -- use rule "Transform.ag"(line 537, column 56) + _lhsOsemPragmasCollect = + Map.empty + -- use rule "Transform.ag"(line 380, column 32) + _lhsOtypeSyns = + [] + -- use rule "Transform.ag"(line 126, column 15) + _lhsOuseMap = + Map.empty + -- use rule "Transform.ag"(line 492, column 32) + _lhsOwrappers = + Set.empty + -- copy rule (chain) + _lhsOattrDecls = + _lhsIattrDecls + -- copy rule (chain) + _lhsOdefSets = + _lhsIdefSets + in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOctxCollect,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOparamsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) +sem_Elem_Type :: Pos -> + ClassContext -> + NontermIdent -> + ([Identifier]) -> + ComplexType -> + T_Elem +sem_Elem_Type pos_ ctx_ name_ params_ type_ = + (T_Elem (\ _lhsIallAttrDecls + _lhsIallConstructors + _lhsIallFields + _lhsIallNonterminals + _lhsIattrDecls + _lhsIdefSets + _lhsIdefinedSets -> + (let _lhsOcollectedFields :: ([(NontermIdent, ConstructorIdent, FieldMap)]) + _lhsOcollectedNames :: (Set Identifier) + _lhsOtypeSyns :: TypeSyns + _lhsOparamsCollect :: ParamMap + _lhsOctxCollect :: ContextMap + _lhsOattrOrderCollect :: AttrOrderMap + _lhsOblocks :: Blocks + _lhsOcollectedConstructorsMap :: (Map NontermIdent (Set ConstructorIdent)) + _lhsOcollectedInsts :: ([ (NontermIdent, ConstructorIdent, [Identifier]) ]) + _lhsOcollectedRules :: ([ (NontermIdent, ConstructorIdent, RuleInfo)]) + _lhsOcollectedSetNames :: (Set Identifier) + _lhsOcollectedSigs :: ([ (NontermIdent, ConstructorIdent, SigInfo) ]) + _lhsOderivings :: Derivings + _lhsOerrors :: (Seq Error) + _lhsOmoduleDecl :: (Maybe (String,String,String)) + _lhsOpragmas :: (Options -> Options) + _lhsOsemPragmasCollect :: PragmaMap + _lhsOuseMap :: (Map NontermIdent (Map Identifier (String,String,String))) + _lhsOwrappers :: (Set NontermIdent) + _lhsOattrDecls :: (Map NontermIdent (Attributes, Attributes)) + _lhsOdefSets :: (Map Identifier (Set NontermIdent,Set Identifier)) + -- "Transform.ag"(line 214, column 10) + _lhsOcollectedFields = + map (\(x,y)->(name_, x, y)) _expanded + -- "Transform.ag"(line 339, column 11) + _lhsOcollectedNames = + Set.singleton name_ + -- "Transform.ag"(line 393, column 11) + _expanded = + case _argType of + List tp -> [(Ident "Cons" pos_, [(Ident "hd" pos_, tp) + ,(Ident "tl" pos_, NT name_ (map getName params_)) + ] + ) + ,(Ident "Nil" pos_, []) + ] + Maybe tp -> [(Ident "Just" pos_, [(Ident "just" pos_, tp) + ] + ) + ,(Ident "Nothing" pos_, []) + ] + Tuple xs -> [(Ident "Tuple" pos_, xs)] + -- "Transform.ag"(line 406, column 11) + _argType = + case type_ of + Maybe tp -> Maybe ( makeType _lhsIallNonterminals tp) + List tp -> List ( makeType _lhsIallNonterminals tp) + Tuple xs -> Tuple [(f,makeType _lhsIallNonterminals tp) | (f,tp) <- xs] + -- "Transform.ag"(line 410, column 11) + _lhsOtypeSyns = + [(name_,_argType)] + -- "Transform.ag"(line 607, column 7) + _lhsOparamsCollect = + if null params_ + then Map.empty + else Map.singleton name_ params_ + -- "Transform.ag"(line 630, column 7) + _lhsOctxCollect = + if null ctx_ + then Map.empty + else Map.singleton name_ ctx_ + -- use rule "Transform.ag"(line 565, column 55) + _lhsOattrOrderCollect = + Map.empty + -- use rule "Transform.ag"(line 38, column 19) + _lhsOblocks = + Map.empty + -- use rule "Transform.ag"(line 83, column 48) + _lhsOcollectedConstructorsMap = + Map.empty + -- use rule "Transform.ag"(line 138, column 29) + _lhsOcollectedInsts = + [] + -- use rule "Transform.ag"(line 136, column 29) + _lhsOcollectedRules = + [] + -- use rule "Transform.ag"(line 74, column 50) + _lhsOcollectedSetNames = + Set.empty + -- use rule "Transform.ag"(line 137, column 29) + _lhsOcollectedSigs = + [] + -- use rule "Transform.ag"(line 645, column 33) + _lhsOderivings = + Map.empty + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + Seq.empty + -- use rule "Transform.ag"(line 787, column 37) + _lhsOmoduleDecl = + mzero + -- use rule "Transform.ag"(line 501, column 34) + _lhsOpragmas = + id + -- use rule "Transform.ag"(line 537, column 56) + _lhsOsemPragmasCollect = + Map.empty + -- use rule "Transform.ag"(line 126, column 15) + _lhsOuseMap = + Map.empty + -- use rule "Transform.ag"(line 492, column 32) + _lhsOwrappers = + Set.empty + -- copy rule (chain) + _lhsOattrDecls = + _lhsIattrDecls + -- copy rule (chain) + _lhsOdefSets = + _lhsIdefSets + in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOctxCollect,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOparamsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) +sem_Elem_Wrapper :: Pos -> + T_NontSet -> + T_Elem +sem_Elem_Wrapper pos_ (T_NontSet set_) = + (T_Elem (\ _lhsIallAttrDecls + _lhsIallConstructors + _lhsIallFields + _lhsIallNonterminals + _lhsIattrDecls + _lhsIdefSets + _lhsIdefinedSets -> + (let _lhsOwrappers :: (Set NontermIdent) + _lhsOattrOrderCollect :: AttrOrderMap + _lhsOblocks :: Blocks + _lhsOcollectedConstructorsMap :: (Map NontermIdent (Set ConstructorIdent)) + _lhsOcollectedFields :: ([(NontermIdent, ConstructorIdent, FieldMap)]) + _lhsOcollectedInsts :: ([ (NontermIdent, ConstructorIdent, [Identifier]) ]) + _lhsOcollectedNames :: (Set Identifier) + _lhsOcollectedRules :: ([ (NontermIdent, ConstructorIdent, RuleInfo)]) + _lhsOcollectedSetNames :: (Set Identifier) + _lhsOcollectedSigs :: ([ (NontermIdent, ConstructorIdent, SigInfo) ]) + _lhsOctxCollect :: ContextMap + _lhsOderivings :: Derivings + _lhsOerrors :: (Seq Error) + _lhsOmoduleDecl :: (Maybe (String,String,String)) + _lhsOparamsCollect :: ParamMap + _lhsOpragmas :: (Options -> Options) + _lhsOsemPragmasCollect :: PragmaMap + _lhsOtypeSyns :: TypeSyns + _lhsOuseMap :: (Map NontermIdent (Map Identifier (String,String,String))) + _lhsOattrDecls :: (Map NontermIdent (Attributes, Attributes)) + _lhsOdefSets :: (Map Identifier (Set NontermIdent,Set Identifier)) + _setOallFields :: DataTypes + _setOallNonterminals :: (Set NontermIdent) + _setOdefinedSets :: DefinedSets + _setIcollectedNames :: (Set Identifier) + _setIerrors :: (Seq Error) + _setInontSet :: (Set NontermIdent) + -- "Transform.ag"(line 495, column 13) + _lhsOwrappers = + _setInontSet + -- use rule "Transform.ag"(line 565, column 55) + _lhsOattrOrderCollect = + Map.empty + -- use rule "Transform.ag"(line 38, column 19) + _lhsOblocks = + Map.empty + -- use rule "Transform.ag"(line 83, column 48) + _lhsOcollectedConstructorsMap = + Map.empty + -- use rule "Transform.ag"(line 114, column 28) + _lhsOcollectedFields = + [] + -- use rule "Transform.ag"(line 138, column 29) + _lhsOcollectedInsts = + [] + -- use rule "Transform.ag"(line 75, column 50) + _lhsOcollectedNames = + _setIcollectedNames + -- use rule "Transform.ag"(line 136, column 29) + _lhsOcollectedRules = + [] + -- use rule "Transform.ag"(line 74, column 50) + _lhsOcollectedSetNames = + Set.empty + -- use rule "Transform.ag"(line 137, column 29) + _lhsOcollectedSigs = + [] + -- use rule "Transform.ag"(line 620, column 34) + _lhsOctxCollect = + Map.empty + -- use rule "Transform.ag"(line 645, column 33) + _lhsOderivings = + Map.empty + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + _setIerrors + -- use rule "Transform.ag"(line 787, column 37) + _lhsOmoduleDecl = + mzero + -- use rule "Transform.ag"(line 597, column 37) + _lhsOparamsCollect = + Map.empty + -- use rule "Transform.ag"(line 501, column 34) + _lhsOpragmas = + id + -- use rule "Transform.ag"(line 537, column 56) + _lhsOsemPragmasCollect = + Map.empty + -- use rule "Transform.ag"(line 380, column 32) + _lhsOtypeSyns = + [] + -- use rule "Transform.ag"(line 126, column 15) + _lhsOuseMap = + Map.empty + -- copy rule (chain) + _lhsOattrDecls = + _lhsIattrDecls + -- copy rule (chain) + _lhsOdefSets = + _lhsIdefSets + -- copy rule (down) + _setOallFields = + _lhsIallFields + -- copy rule (down) + _setOallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _setOdefinedSets = + _lhsIdefinedSets + ( _setIcollectedNames,_setIerrors,_setInontSet) = + (set_ _setOallFields _setOallNonterminals _setOdefinedSets) + in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOctxCollect,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOparamsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) +-- Elems ------------------------------------------------------- +{- + visit 0: + inherited attributes: + allAttrDecls : Map NontermIdent (Attributes, Attributes) + allConstructors : Map NontermIdent (Set ConstructorIdent) + allFields : DataTypes + allNonterminals : Set NontermIdent + definedSets : DefinedSets + chained attributes: + attrDecls : Map NontermIdent (Attributes, Attributes) + defSets : Map Identifier (Set NontermIdent,Set Identifier) + synthesized attributes: + attrOrderCollect : AttrOrderMap + blocks : Blocks + collectedConstructorsMap : Map NontermIdent (Set ConstructorIdent) + collectedFields : [(NontermIdent, ConstructorIdent, FieldMap)] + collectedInsts : [ (NontermIdent, ConstructorIdent, [Identifier]) ] + collectedNames : Set Identifier + collectedRules : [ (NontermIdent, ConstructorIdent, RuleInfo)] + collectedSetNames : Set Identifier + collectedSigs : [ (NontermIdent, ConstructorIdent, SigInfo) ] + ctxCollect : ContextMap + derivings : Derivings + errors : Seq Error + moduleDecl : Maybe (String,String,String) + paramsCollect : ParamMap + pragmas : Options -> Options + semPragmasCollect : PragmaMap + typeSyns : TypeSyns + useMap : Map NontermIdent (Map Identifier (String,String,String)) + wrappers : Set NontermIdent + alternatives: + alternative Cons: + child hd : Elem + child tl : Elems + alternative Nil: +-} +-- cata +sem_Elems :: Elems -> + T_Elems +sem_Elems list = + (Prelude.foldr sem_Elems_Cons sem_Elems_Nil (Prelude.map sem_Elem list)) +-- semantic domain +newtype T_Elems = T_Elems ((Map NontermIdent (Attributes, Attributes)) -> + (Map NontermIdent (Set ConstructorIdent)) -> + DataTypes -> + (Set NontermIdent) -> + (Map NontermIdent (Attributes, Attributes)) -> + (Map Identifier (Set NontermIdent,Set Identifier)) -> + DefinedSets -> + ( (Map NontermIdent (Attributes, Attributes)),AttrOrderMap,Blocks,(Map NontermIdent (Set ConstructorIdent)),([(NontermIdent, ConstructorIdent, FieldMap)]),([ (NontermIdent, ConstructorIdent, [Identifier]) ]),(Set Identifier),([ (NontermIdent, ConstructorIdent, RuleInfo)]),(Set Identifier),([ (NontermIdent, ConstructorIdent, SigInfo) ]),ContextMap,(Map Identifier (Set NontermIdent,Set Identifier)),Derivings,(Seq Error),(Maybe (String,String,String)),ParamMap,(Options -> Options),PragmaMap,TypeSyns,(Map NontermIdent (Map Identifier (String,String,String))),(Set NontermIdent))) +data Inh_Elems = Inh_Elems {allAttrDecls_Inh_Elems :: Map NontermIdent (Attributes, Attributes),allConstructors_Inh_Elems :: Map NontermIdent (Set ConstructorIdent),allFields_Inh_Elems :: DataTypes,allNonterminals_Inh_Elems :: Set NontermIdent,attrDecls_Inh_Elems :: Map NontermIdent (Attributes, Attributes),defSets_Inh_Elems :: Map Identifier (Set NontermIdent,Set Identifier),definedSets_Inh_Elems :: DefinedSets} +data Syn_Elems = Syn_Elems {attrDecls_Syn_Elems :: Map NontermIdent (Attributes, Attributes),attrOrderCollect_Syn_Elems :: AttrOrderMap,blocks_Syn_Elems :: Blocks,collectedConstructorsMap_Syn_Elems :: Map NontermIdent (Set ConstructorIdent),collectedFields_Syn_Elems :: [(NontermIdent, ConstructorIdent, FieldMap)],collectedInsts_Syn_Elems :: [ (NontermIdent, ConstructorIdent, [Identifier]) ],collectedNames_Syn_Elems :: Set Identifier,collectedRules_Syn_Elems :: [ (NontermIdent, ConstructorIdent, RuleInfo)],collectedSetNames_Syn_Elems :: Set Identifier,collectedSigs_Syn_Elems :: [ (NontermIdent, ConstructorIdent, SigInfo) ],ctxCollect_Syn_Elems :: ContextMap,defSets_Syn_Elems :: Map Identifier (Set NontermIdent,Set Identifier),derivings_Syn_Elems :: Derivings,errors_Syn_Elems :: Seq Error,moduleDecl_Syn_Elems :: Maybe (String,String,String),paramsCollect_Syn_Elems :: ParamMap,pragmas_Syn_Elems :: Options -> Options,semPragmasCollect_Syn_Elems :: PragmaMap,typeSyns_Syn_Elems :: TypeSyns,useMap_Syn_Elems :: Map NontermIdent (Map Identifier (String,String,String)),wrappers_Syn_Elems :: Set NontermIdent} +wrap_Elems (T_Elems sem) (Inh_Elems _lhsIallAttrDecls _lhsIallConstructors _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsIdefSets _lhsIdefinedSets) = + (let ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOctxCollect,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOparamsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers) = + (sem _lhsIallAttrDecls _lhsIallConstructors _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsIdefSets _lhsIdefinedSets) + in (Syn_Elems _lhsOattrDecls _lhsOattrOrderCollect _lhsOblocks _lhsOcollectedConstructorsMap _lhsOcollectedFields _lhsOcollectedInsts _lhsOcollectedNames _lhsOcollectedRules _lhsOcollectedSetNames _lhsOcollectedSigs _lhsOctxCollect _lhsOdefSets _lhsOderivings _lhsOerrors _lhsOmoduleDecl _lhsOparamsCollect _lhsOpragmas _lhsOsemPragmasCollect _lhsOtypeSyns _lhsOuseMap _lhsOwrappers)) +sem_Elems_Cons :: T_Elem -> + T_Elems -> + T_Elems +sem_Elems_Cons (T_Elem hd_) (T_Elems tl_) = + (T_Elems (\ _lhsIallAttrDecls + _lhsIallConstructors + _lhsIallFields + _lhsIallNonterminals + _lhsIattrDecls + _lhsIdefSets + _lhsIdefinedSets -> + (let _lhsOattrOrderCollect :: AttrOrderMap + _lhsOblocks :: Blocks + _lhsOcollectedConstructorsMap :: (Map NontermIdent (Set ConstructorIdent)) + _lhsOcollectedFields :: ([(NontermIdent, ConstructorIdent, FieldMap)]) + _lhsOcollectedInsts :: ([ (NontermIdent, ConstructorIdent, [Identifier]) ]) + _lhsOcollectedNames :: (Set Identifier) + _lhsOcollectedRules :: ([ (NontermIdent, ConstructorIdent, RuleInfo)]) + _lhsOcollectedSetNames :: (Set Identifier) + _lhsOcollectedSigs :: ([ (NontermIdent, ConstructorIdent, SigInfo) ]) + _lhsOctxCollect :: ContextMap + _lhsOderivings :: Derivings + _lhsOerrors :: (Seq Error) + _lhsOmoduleDecl :: (Maybe (String,String,String)) + _lhsOparamsCollect :: ParamMap + _lhsOpragmas :: (Options -> Options) + _lhsOsemPragmasCollect :: PragmaMap + _lhsOtypeSyns :: TypeSyns + _lhsOuseMap :: (Map NontermIdent (Map Identifier (String,String,String))) + _lhsOwrappers :: (Set NontermIdent) + _lhsOattrDecls :: (Map NontermIdent (Attributes, Attributes)) + _lhsOdefSets :: (Map Identifier (Set NontermIdent,Set Identifier)) + _hdOallAttrDecls :: (Map NontermIdent (Attributes, Attributes)) + _hdOallConstructors :: (Map NontermIdent (Set ConstructorIdent)) + _hdOallFields :: DataTypes + _hdOallNonterminals :: (Set NontermIdent) + _hdOattrDecls :: (Map NontermIdent (Attributes, Attributes)) + _hdOdefSets :: (Map Identifier (Set NontermIdent,Set Identifier)) + _hdOdefinedSets :: DefinedSets + _tlOallAttrDecls :: (Map NontermIdent (Attributes, Attributes)) + _tlOallConstructors :: (Map NontermIdent (Set ConstructorIdent)) + _tlOallFields :: DataTypes + _tlOallNonterminals :: (Set NontermIdent) + _tlOattrDecls :: (Map NontermIdent (Attributes, Attributes)) + _tlOdefSets :: (Map Identifier (Set NontermIdent,Set Identifier)) + _tlOdefinedSets :: DefinedSets + _hdIattrDecls :: (Map NontermIdent (Attributes, Attributes)) + _hdIattrOrderCollect :: AttrOrderMap + _hdIblocks :: Blocks + _hdIcollectedConstructorsMap :: (Map NontermIdent (Set ConstructorIdent)) + _hdIcollectedFields :: ([(NontermIdent, ConstructorIdent, FieldMap)]) + _hdIcollectedInsts :: ([ (NontermIdent, ConstructorIdent, [Identifier]) ]) + _hdIcollectedNames :: (Set Identifier) + _hdIcollectedRules :: ([ (NontermIdent, ConstructorIdent, RuleInfo)]) + _hdIcollectedSetNames :: (Set Identifier) + _hdIcollectedSigs :: ([ (NontermIdent, ConstructorIdent, SigInfo) ]) + _hdIctxCollect :: ContextMap + _hdIdefSets :: (Map Identifier (Set NontermIdent,Set Identifier)) + _hdIderivings :: Derivings + _hdIerrors :: (Seq Error) + _hdImoduleDecl :: (Maybe (String,String,String)) + _hdIparamsCollect :: ParamMap + _hdIpragmas :: (Options -> Options) + _hdIsemPragmasCollect :: PragmaMap + _hdItypeSyns :: TypeSyns + _hdIuseMap :: (Map NontermIdent (Map Identifier (String,String,String))) + _hdIwrappers :: (Set NontermIdent) + _tlIattrDecls :: (Map NontermIdent (Attributes, Attributes)) + _tlIattrOrderCollect :: AttrOrderMap + _tlIblocks :: Blocks + _tlIcollectedConstructorsMap :: (Map NontermIdent (Set ConstructorIdent)) + _tlIcollectedFields :: ([(NontermIdent, ConstructorIdent, FieldMap)]) + _tlIcollectedInsts :: ([ (NontermIdent, ConstructorIdent, [Identifier]) ]) + _tlIcollectedNames :: (Set Identifier) + _tlIcollectedRules :: ([ (NontermIdent, ConstructorIdent, RuleInfo)]) + _tlIcollectedSetNames :: (Set Identifier) + _tlIcollectedSigs :: ([ (NontermIdent, ConstructorIdent, SigInfo) ]) + _tlIctxCollect :: ContextMap + _tlIdefSets :: (Map Identifier (Set NontermIdent,Set Identifier)) + _tlIderivings :: Derivings + _tlIerrors :: (Seq Error) + _tlImoduleDecl :: (Maybe (String,String,String)) + _tlIparamsCollect :: ParamMap + _tlIpragmas :: (Options -> Options) + _tlIsemPragmasCollect :: PragmaMap + _tlItypeSyns :: TypeSyns + _tlIuseMap :: (Map NontermIdent (Map Identifier (String,String,String))) + _tlIwrappers :: (Set NontermIdent) + -- use rule "Transform.ag"(line 565, column 55) + _lhsOattrOrderCollect = + _hdIattrOrderCollect `orderMapUnion` _tlIattrOrderCollect + -- use rule "Transform.ag"(line 38, column 19) + _lhsOblocks = + _hdIblocks `mapUnionWithPlusPlus` _tlIblocks + -- use rule "Transform.ag"(line 83, column 48) + _lhsOcollectedConstructorsMap = + _hdIcollectedConstructorsMap `mapUnionWithSetUnion` _tlIcollectedConstructorsMap + -- use rule "Transform.ag"(line 114, column 28) + _lhsOcollectedFields = + _hdIcollectedFields ++ _tlIcollectedFields + -- use rule "Transform.ag"(line 138, column 29) + _lhsOcollectedInsts = + _hdIcollectedInsts ++ _tlIcollectedInsts + -- use rule "Transform.ag"(line 75, column 50) + _lhsOcollectedNames = + _hdIcollectedNames `Set.union` _tlIcollectedNames + -- use rule "Transform.ag"(line 136, column 29) + _lhsOcollectedRules = + _hdIcollectedRules ++ _tlIcollectedRules + -- use rule "Transform.ag"(line 74, column 50) + _lhsOcollectedSetNames = + _hdIcollectedSetNames `Set.union` _tlIcollectedSetNames + -- use rule "Transform.ag"(line 137, column 29) + _lhsOcollectedSigs = + _hdIcollectedSigs ++ _tlIcollectedSigs + -- use rule "Transform.ag"(line 620, column 34) + _lhsOctxCollect = + _hdIctxCollect `mergeCtx` _tlIctxCollect + -- use rule "Transform.ag"(line 645, column 33) + _lhsOderivings = + _hdIderivings `mergeDerivings` _tlIderivings + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- use rule "Transform.ag"(line 787, column 37) + _lhsOmoduleDecl = + _hdImoduleDecl `mplus` _tlImoduleDecl + -- use rule "Transform.ag"(line 597, column 37) + _lhsOparamsCollect = + _hdIparamsCollect `mergeParams` _tlIparamsCollect + -- use rule "Transform.ag"(line 501, column 34) + _lhsOpragmas = + _hdIpragmas . _tlIpragmas + -- use rule "Transform.ag"(line 537, column 56) + _lhsOsemPragmasCollect = + _hdIsemPragmasCollect `pragmaMapUnion` _tlIsemPragmasCollect + -- use rule "Transform.ag"(line 380, column 32) + _lhsOtypeSyns = + _hdItypeSyns ++ _tlItypeSyns + -- use rule "Transform.ag"(line 126, column 15) + _lhsOuseMap = + _hdIuseMap `merge` _tlIuseMap + -- use rule "Transform.ag"(line 492, column 32) + _lhsOwrappers = + _hdIwrappers `Set.union` _tlIwrappers + -- copy rule (up) + _lhsOattrDecls = + _tlIattrDecls + -- copy rule (up) + _lhsOdefSets = + _tlIdefSets + -- copy rule (down) + _hdOallAttrDecls = + _lhsIallAttrDecls + -- copy rule (down) + _hdOallConstructors = + _lhsIallConstructors + -- copy rule (down) + _hdOallFields = + _lhsIallFields + -- copy rule (down) + _hdOallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _hdOattrDecls = + _lhsIattrDecls + -- copy rule (down) + _hdOdefSets = + _lhsIdefSets + -- copy rule (down) + _hdOdefinedSets = + _lhsIdefinedSets + -- copy rule (down) + _tlOallAttrDecls = + _lhsIallAttrDecls + -- copy rule (down) + _tlOallConstructors = + _lhsIallConstructors + -- copy rule (down) + _tlOallFields = + _lhsIallFields + -- copy rule (down) + _tlOallNonterminals = + _lhsIallNonterminals + -- copy rule (chain) + _tlOattrDecls = + _hdIattrDecls + -- copy rule (chain) + _tlOdefSets = + _hdIdefSets + -- copy rule (down) + _tlOdefinedSets = + _lhsIdefinedSets + ( _hdIattrDecls,_hdIattrOrderCollect,_hdIblocks,_hdIcollectedConstructorsMap,_hdIcollectedFields,_hdIcollectedInsts,_hdIcollectedNames,_hdIcollectedRules,_hdIcollectedSetNames,_hdIcollectedSigs,_hdIctxCollect,_hdIdefSets,_hdIderivings,_hdIerrors,_hdImoduleDecl,_hdIparamsCollect,_hdIpragmas,_hdIsemPragmasCollect,_hdItypeSyns,_hdIuseMap,_hdIwrappers) = + (hd_ _hdOallAttrDecls _hdOallConstructors _hdOallFields _hdOallNonterminals _hdOattrDecls _hdOdefSets _hdOdefinedSets) + ( _tlIattrDecls,_tlIattrOrderCollect,_tlIblocks,_tlIcollectedConstructorsMap,_tlIcollectedFields,_tlIcollectedInsts,_tlIcollectedNames,_tlIcollectedRules,_tlIcollectedSetNames,_tlIcollectedSigs,_tlIctxCollect,_tlIdefSets,_tlIderivings,_tlIerrors,_tlImoduleDecl,_tlIparamsCollect,_tlIpragmas,_tlIsemPragmasCollect,_tlItypeSyns,_tlIuseMap,_tlIwrappers) = + (tl_ _tlOallAttrDecls _tlOallConstructors _tlOallFields _tlOallNonterminals _tlOattrDecls _tlOdefSets _tlOdefinedSets) + in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOctxCollect,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOparamsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) +sem_Elems_Nil :: T_Elems +sem_Elems_Nil = + (T_Elems (\ _lhsIallAttrDecls + _lhsIallConstructors + _lhsIallFields + _lhsIallNonterminals + _lhsIattrDecls + _lhsIdefSets + _lhsIdefinedSets -> + (let _lhsOattrOrderCollect :: AttrOrderMap + _lhsOblocks :: Blocks + _lhsOcollectedConstructorsMap :: (Map NontermIdent (Set ConstructorIdent)) + _lhsOcollectedFields :: ([(NontermIdent, ConstructorIdent, FieldMap)]) + _lhsOcollectedInsts :: ([ (NontermIdent, ConstructorIdent, [Identifier]) ]) + _lhsOcollectedNames :: (Set Identifier) + _lhsOcollectedRules :: ([ (NontermIdent, ConstructorIdent, RuleInfo)]) + _lhsOcollectedSetNames :: (Set Identifier) + _lhsOcollectedSigs :: ([ (NontermIdent, ConstructorIdent, SigInfo) ]) + _lhsOctxCollect :: ContextMap + _lhsOderivings :: Derivings + _lhsOerrors :: (Seq Error) + _lhsOmoduleDecl :: (Maybe (String,String,String)) + _lhsOparamsCollect :: ParamMap + _lhsOpragmas :: (Options -> Options) + _lhsOsemPragmasCollect :: PragmaMap + _lhsOtypeSyns :: TypeSyns + _lhsOuseMap :: (Map NontermIdent (Map Identifier (String,String,String))) + _lhsOwrappers :: (Set NontermIdent) + _lhsOattrDecls :: (Map NontermIdent (Attributes, Attributes)) + _lhsOdefSets :: (Map Identifier (Set NontermIdent,Set Identifier)) + -- use rule "Transform.ag"(line 565, column 55) + _lhsOattrOrderCollect = + Map.empty + -- use rule "Transform.ag"(line 38, column 19) + _lhsOblocks = + Map.empty + -- use rule "Transform.ag"(line 83, column 48) + _lhsOcollectedConstructorsMap = + Map.empty + -- use rule "Transform.ag"(line 114, column 28) + _lhsOcollectedFields = + [] + -- use rule "Transform.ag"(line 138, column 29) + _lhsOcollectedInsts = + [] + -- use rule "Transform.ag"(line 75, column 50) + _lhsOcollectedNames = + Set.empty + -- use rule "Transform.ag"(line 136, column 29) + _lhsOcollectedRules = + [] + -- use rule "Transform.ag"(line 74, column 50) + _lhsOcollectedSetNames = + Set.empty + -- use rule "Transform.ag"(line 137, column 29) + _lhsOcollectedSigs = + [] + -- use rule "Transform.ag"(line 620, column 34) + _lhsOctxCollect = + Map.empty + -- use rule "Transform.ag"(line 645, column 33) + _lhsOderivings = + Map.empty + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + Seq.empty + -- use rule "Transform.ag"(line 787, column 37) + _lhsOmoduleDecl = + mzero + -- use rule "Transform.ag"(line 597, column 37) + _lhsOparamsCollect = + Map.empty + -- use rule "Transform.ag"(line 501, column 34) + _lhsOpragmas = + id + -- use rule "Transform.ag"(line 537, column 56) + _lhsOsemPragmasCollect = + Map.empty + -- use rule "Transform.ag"(line 380, column 32) + _lhsOtypeSyns = + [] + -- use rule "Transform.ag"(line 126, column 15) + _lhsOuseMap = + Map.empty + -- use rule "Transform.ag"(line 492, column 32) + _lhsOwrappers = + Set.empty + -- copy rule (chain) + _lhsOattrDecls = + _lhsIattrDecls + -- copy rule (chain) + _lhsOdefSets = + _lhsIdefSets + in ( _lhsOattrDecls,_lhsOattrOrderCollect,_lhsOblocks,_lhsOcollectedConstructorsMap,_lhsOcollectedFields,_lhsOcollectedInsts,_lhsOcollectedNames,_lhsOcollectedRules,_lhsOcollectedSetNames,_lhsOcollectedSigs,_lhsOctxCollect,_lhsOdefSets,_lhsOderivings,_lhsOerrors,_lhsOmoduleDecl,_lhsOparamsCollect,_lhsOpragmas,_lhsOsemPragmasCollect,_lhsOtypeSyns,_lhsOuseMap,_lhsOwrappers)))) +-- NontSet ----------------------------------------------------- +{- + visit 0: + inherited attributes: + allFields : DataTypes + allNonterminals : Set NontermIdent + definedSets : DefinedSets + synthesized attributes: + collectedNames : Set Identifier + errors : Seq Error + nontSet : Set NontermIdent + alternatives: + alternative All: + alternative Difference: + child set1 : NontSet + child set2 : NontSet + alternative Intersect: + child set1 : NontSet + child set2 : NontSet + alternative NamedSet: + child name : {NontermIdent} + visit 0: + local _tup4 : _ + local nontSet : _ + local errors : _ + alternative Path: + child from : {NontermIdent} + child to : {NontermIdent} + alternative Union: + child set1 : NontSet + child set2 : NontSet +-} +-- cata +sem_NontSet :: NontSet -> + T_NontSet +sem_NontSet (All ) = + (sem_NontSet_All ) +sem_NontSet (Difference _set1 _set2) = + (sem_NontSet_Difference (sem_NontSet _set1) (sem_NontSet _set2)) +sem_NontSet (Intersect _set1 _set2) = + (sem_NontSet_Intersect (sem_NontSet _set1) (sem_NontSet _set2)) +sem_NontSet (NamedSet _name) = + (sem_NontSet_NamedSet _name) +sem_NontSet (Path _from _to) = + (sem_NontSet_Path _from _to) +sem_NontSet (Union _set1 _set2) = + (sem_NontSet_Union (sem_NontSet _set1) (sem_NontSet _set2)) +-- semantic domain +newtype T_NontSet = T_NontSet (DataTypes -> + (Set NontermIdent) -> + DefinedSets -> + ( (Set Identifier),(Seq Error),(Set NontermIdent))) +data Inh_NontSet = Inh_NontSet {allFields_Inh_NontSet :: DataTypes,allNonterminals_Inh_NontSet :: Set NontermIdent,definedSets_Inh_NontSet :: DefinedSets} +data Syn_NontSet = Syn_NontSet {collectedNames_Syn_NontSet :: Set Identifier,errors_Syn_NontSet :: Seq Error,nontSet_Syn_NontSet :: Set NontermIdent} +wrap_NontSet (T_NontSet sem) (Inh_NontSet _lhsIallFields _lhsIallNonterminals _lhsIdefinedSets) = + (let ( _lhsOcollectedNames,_lhsOerrors,_lhsOnontSet) = + (sem _lhsIallFields _lhsIallNonterminals _lhsIdefinedSets) + in (Syn_NontSet _lhsOcollectedNames _lhsOerrors _lhsOnontSet)) +sem_NontSet_All :: T_NontSet +sem_NontSet_All = + (T_NontSet (\ _lhsIallFields + _lhsIallNonterminals + _lhsIdefinedSets -> + (let _lhsOnontSet :: (Set NontermIdent) + _lhsOcollectedNames :: (Set Identifier) + _lhsOerrors :: (Seq Error) + -- "Transform.ag"(line 438, column 16) + _lhsOnontSet = + _lhsIallNonterminals + -- use rule "Transform.ag"(line 75, column 50) + _lhsOcollectedNames = + Set.empty + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + Seq.empty + in ( _lhsOcollectedNames,_lhsOerrors,_lhsOnontSet)))) +sem_NontSet_Difference :: T_NontSet -> + T_NontSet -> + T_NontSet +sem_NontSet_Difference (T_NontSet set1_) (T_NontSet set2_) = + (T_NontSet (\ _lhsIallFields + _lhsIallNonterminals + _lhsIdefinedSets -> + (let _lhsOnontSet :: (Set NontermIdent) + _lhsOcollectedNames :: (Set Identifier) + _lhsOerrors :: (Seq Error) + _set1OallFields :: DataTypes + _set1OallNonterminals :: (Set NontermIdent) + _set1OdefinedSets :: DefinedSets + _set2OallFields :: DataTypes + _set2OallNonterminals :: (Set NontermIdent) + _set2OdefinedSets :: DefinedSets + _set1IcollectedNames :: (Set Identifier) + _set1Ierrors :: (Seq Error) + _set1InontSet :: (Set NontermIdent) + _set2IcollectedNames :: (Set Identifier) + _set2Ierrors :: (Seq Error) + _set2InontSet :: (Set NontermIdent) + -- "Transform.ag"(line 444, column 16) + _lhsOnontSet = + Set.difference _set1InontSet _set2InontSet + -- use rule "Transform.ag"(line 75, column 50) + _lhsOcollectedNames = + _set1IcollectedNames `Set.union` _set2IcollectedNames + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + _set1Ierrors Seq.<> _set2Ierrors + -- copy rule (down) + _set1OallFields = + _lhsIallFields + -- copy rule (down) + _set1OallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _set1OdefinedSets = + _lhsIdefinedSets + -- copy rule (down) + _set2OallFields = + _lhsIallFields + -- copy rule (down) + _set2OallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _set2OdefinedSets = + _lhsIdefinedSets + ( _set1IcollectedNames,_set1Ierrors,_set1InontSet) = + (set1_ _set1OallFields _set1OallNonterminals _set1OdefinedSets) + ( _set2IcollectedNames,_set2Ierrors,_set2InontSet) = + (set2_ _set2OallFields _set2OallNonterminals _set2OdefinedSets) + in ( _lhsOcollectedNames,_lhsOerrors,_lhsOnontSet)))) +sem_NontSet_Intersect :: T_NontSet -> + T_NontSet -> + T_NontSet +sem_NontSet_Intersect (T_NontSet set1_) (T_NontSet set2_) = + (T_NontSet (\ _lhsIallFields + _lhsIallNonterminals + _lhsIdefinedSets -> + (let _lhsOnontSet :: (Set NontermIdent) + _lhsOcollectedNames :: (Set Identifier) + _lhsOerrors :: (Seq Error) + _set1OallFields :: DataTypes + _set1OallNonterminals :: (Set NontermIdent) + _set1OdefinedSets :: DefinedSets + _set2OallFields :: DataTypes + _set2OallNonterminals :: (Set NontermIdent) + _set2OdefinedSets :: DefinedSets + _set1IcollectedNames :: (Set Identifier) + _set1Ierrors :: (Seq Error) + _set1InontSet :: (Set NontermIdent) + _set2IcollectedNames :: (Set Identifier) + _set2Ierrors :: (Seq Error) + _set2InontSet :: (Set NontermIdent) + -- "Transform.ag"(line 443, column 16) + _lhsOnontSet = + Set.intersection _set1InontSet _set2InontSet + -- use rule "Transform.ag"(line 75, column 50) + _lhsOcollectedNames = + _set1IcollectedNames `Set.union` _set2IcollectedNames + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + _set1Ierrors Seq.<> _set2Ierrors + -- copy rule (down) + _set1OallFields = + _lhsIallFields + -- copy rule (down) + _set1OallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _set1OdefinedSets = + _lhsIdefinedSets + -- copy rule (down) + _set2OallFields = + _lhsIallFields + -- copy rule (down) + _set2OallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _set2OdefinedSets = + _lhsIdefinedSets + ( _set1IcollectedNames,_set1Ierrors,_set1InontSet) = + (set1_ _set1OallFields _set1OallNonterminals _set1OdefinedSets) + ( _set2IcollectedNames,_set2Ierrors,_set2InontSet) = + (set2_ _set2OallFields _set2OallNonterminals _set2OdefinedSets) + in ( _lhsOcollectedNames,_lhsOerrors,_lhsOnontSet)))) +sem_NontSet_NamedSet :: NontermIdent -> + T_NontSet +sem_NontSet_NamedSet name_ = + (T_NontSet (\ _lhsIallFields + _lhsIallNonterminals + _lhsIdefinedSets -> + (let _lhsOcollectedNames :: (Set Identifier) + _lhsOerrors :: (Seq Error) + _lhsOnontSet :: (Set NontermIdent) + -- "Transform.ag"(line 342, column 14) + _lhsOcollectedNames = + Set.singleton name_ + -- "Transform.ag"(line 439, column 20) + __tup4 = + case Map.lookup name_ _lhsIdefinedSets of + Nothing -> (Set.empty, Seq.single (UndefNont name_)) + Just set -> (set, Seq.empty) + -- "Transform.ag"(line 439, column 20) + (_nontSet,_) = + __tup4 + -- "Transform.ag"(line 439, column 20) + (_,_errors) = + __tup4 + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + _errors + -- copy rule (from local) + _lhsOnontSet = + _nontSet + in ( _lhsOcollectedNames,_lhsOerrors,_lhsOnontSet)))) +sem_NontSet_Path :: NontermIdent -> + NontermIdent -> + T_NontSet +sem_NontSet_Path from_ to_ = + (T_NontSet (\ _lhsIallFields + _lhsIallNonterminals + _lhsIdefinedSets -> + (let _lhsOnontSet :: (Set NontermIdent) + _lhsOerrors :: (Seq Error) + _lhsOcollectedNames :: (Set Identifier) + -- "Transform.ag"(line 445, column 16) + _lhsOnontSet = + let table = flattenDatas _lhsIallFields + in path table from_ to_ + -- "Transform.ag"(line 447, column 16) + _lhsOerrors = + let check name | Set.member name _lhsIallNonterminals + = Seq.empty + | otherwise = Seq.single (UndefNont name) + in check from_ <> check to_ + -- use rule "Transform.ag"(line 75, column 50) + _lhsOcollectedNames = + Set.empty + in ( _lhsOcollectedNames,_lhsOerrors,_lhsOnontSet)))) +sem_NontSet_Union :: T_NontSet -> + T_NontSet -> + T_NontSet +sem_NontSet_Union (T_NontSet set1_) (T_NontSet set2_) = + (T_NontSet (\ _lhsIallFields + _lhsIallNonterminals + _lhsIdefinedSets -> + (let _lhsOnontSet :: (Set NontermIdent) + _lhsOcollectedNames :: (Set Identifier) + _lhsOerrors :: (Seq Error) + _set1OallFields :: DataTypes + _set1OallNonterminals :: (Set NontermIdent) + _set1OdefinedSets :: DefinedSets + _set2OallFields :: DataTypes + _set2OallNonterminals :: (Set NontermIdent) + _set2OdefinedSets :: DefinedSets + _set1IcollectedNames :: (Set Identifier) + _set1Ierrors :: (Seq Error) + _set1InontSet :: (Set NontermIdent) + _set2IcollectedNames :: (Set Identifier) + _set2Ierrors :: (Seq Error) + _set2InontSet :: (Set NontermIdent) + -- "Transform.ag"(line 442, column 16) + _lhsOnontSet = + Set.union _set1InontSet _set2InontSet + -- use rule "Transform.ag"(line 75, column 50) + _lhsOcollectedNames = + _set1IcollectedNames `Set.union` _set2IcollectedNames + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + _set1Ierrors Seq.<> _set2Ierrors + -- copy rule (down) + _set1OallFields = + _lhsIallFields + -- copy rule (down) + _set1OallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _set1OdefinedSets = + _lhsIdefinedSets + -- copy rule (down) + _set2OallFields = + _lhsIallFields + -- copy rule (down) + _set2OallNonterminals = + _lhsIallNonterminals + -- copy rule (down) + _set2OdefinedSets = + _lhsIdefinedSets + ( _set1IcollectedNames,_set1Ierrors,_set1InontSet) = + (set1_ _set1OallFields _set1OallNonterminals _set1OdefinedSets) + ( _set2IcollectedNames,_set2Ierrors,_set2InontSet) = + (set2_ _set2OallFields _set2OallNonterminals _set2OdefinedSets) + in ( _lhsOcollectedNames,_lhsOerrors,_lhsOnontSet)))) +-- Pattern ----------------------------------------------------- +{- + visit 0: + synthesized attributes: + copy : SELF + definedAttrs : [AttrName] + definedInsts : [Identifier] + patunder : [AttrName]->Pattern + stpos : Pos + alternatives: + alternative Alias: + child field : {Identifier} + child attr : {Identifier} + child pat : Pattern + child parts : Patterns + visit 0: + local copy : _ + alternative Constr: + child name : {ConstructorIdent} + child pats : Patterns + visit 0: + local copy : _ + alternative Irrefutable: + child pat : Pattern + visit 0: + local copy : _ + alternative Product: + child pos : {Pos} + child pats : Patterns + visit 0: + local copy : _ + alternative Underscore: + child pos : {Pos} + visit 0: + local copy : _ +-} +-- cata +sem_Pattern :: Pattern -> + T_Pattern +sem_Pattern (Alias _field _attr _pat _parts) = + (sem_Pattern_Alias _field _attr (sem_Pattern _pat) (sem_Patterns _parts)) +sem_Pattern (Constr _name _pats) = + (sem_Pattern_Constr _name (sem_Patterns _pats)) +sem_Pattern (Irrefutable _pat) = + (sem_Pattern_Irrefutable (sem_Pattern _pat)) +sem_Pattern (Product _pos _pats) = + (sem_Pattern_Product _pos (sem_Patterns _pats)) +sem_Pattern (Underscore _pos) = + (sem_Pattern_Underscore _pos) +-- semantic domain +newtype T_Pattern = T_Pattern (( Pattern,([AttrName]),([Identifier]),([AttrName]->Pattern),Pos)) +data Inh_Pattern = Inh_Pattern {} +data Syn_Pattern = Syn_Pattern {copy_Syn_Pattern :: Pattern,definedAttrs_Syn_Pattern :: [AttrName],definedInsts_Syn_Pattern :: [Identifier],patunder_Syn_Pattern :: [AttrName]->Pattern,stpos_Syn_Pattern :: Pos} +wrap_Pattern (T_Pattern sem) (Inh_Pattern ) = + (let ( _lhsOcopy,_lhsOdefinedAttrs,_lhsOdefinedInsts,_lhsOpatunder,_lhsOstpos) = + (sem ) + in (Syn_Pattern _lhsOcopy _lhsOdefinedAttrs _lhsOdefinedInsts _lhsOpatunder _lhsOstpos)) +sem_Pattern_Alias :: Identifier -> + Identifier -> + T_Pattern -> + T_Patterns -> + T_Pattern +sem_Pattern_Alias field_ attr_ (T_Pattern pat_) (T_Patterns parts_) = + (T_Pattern (let _lhsOdefinedAttrs :: ([AttrName]) + _lhsOpatunder :: ([AttrName]->Pattern) + _lhsOdefinedInsts :: ([Identifier]) + _lhsOstpos :: Pos + _lhsOcopy :: Pattern + _patIcopy :: Pattern + _patIdefinedAttrs :: ([AttrName]) + _patIdefinedInsts :: ([Identifier]) + _patIpatunder :: ([AttrName]->Pattern) + _patIstpos :: Pos + _partsIcopy :: Patterns + _partsIdefinedAttrs :: ([AttrName]) + _partsIdefinedInsts :: ([Identifier]) + _partsIpatunder :: ([AttrName]->Patterns) + -- "Transform.ag"(line 763, column 11) + _lhsOdefinedAttrs = + (field_, attr_) : _patIdefinedAttrs + -- "Transform.ag"(line 764, column 11) + _lhsOpatunder = + \us -> if ((field_,attr_) `elem` us) then Underscore noPos else _copy + -- "Transform.ag"(line 765, column 11) + _lhsOdefinedInsts = + (if field_ == _INST then [attr_] else []) ++ _patIdefinedInsts + -- "Transform.ag"(line 780, column 16) + _lhsOstpos = + getPos field_ + -- self rule + _copy = + Alias field_ attr_ _patIcopy _partsIcopy + -- self rule + _lhsOcopy = + _copy + ( _patIcopy,_patIdefinedAttrs,_patIdefinedInsts,_patIpatunder,_patIstpos) = + (pat_ ) + ( _partsIcopy,_partsIdefinedAttrs,_partsIdefinedInsts,_partsIpatunder) = + (parts_ ) + in ( _lhsOcopy,_lhsOdefinedAttrs,_lhsOdefinedInsts,_lhsOpatunder,_lhsOstpos))) +sem_Pattern_Constr :: ConstructorIdent -> + T_Patterns -> + T_Pattern +sem_Pattern_Constr name_ (T_Patterns pats_) = + (T_Pattern (let _lhsOpatunder :: ([AttrName]->Pattern) + _lhsOstpos :: Pos + _lhsOdefinedAttrs :: ([AttrName]) + _lhsOdefinedInsts :: ([Identifier]) + _lhsOcopy :: Pattern + _patsIcopy :: Patterns + _patsIdefinedAttrs :: ([AttrName]) + _patsIdefinedInsts :: ([Identifier]) + _patsIpatunder :: ([AttrName]->Patterns) + -- "Transform.ag"(line 767, column 12) + _lhsOpatunder = + \us -> Constr name_ (_patsIpatunder us) + -- "Transform.ag"(line 778, column 16) + _lhsOstpos = + getPos name_ + -- use rule "Transform.ag"(line 758, column 42) + _lhsOdefinedAttrs = + _patsIdefinedAttrs + -- use rule "Transform.ag"(line 757, column 55) + _lhsOdefinedInsts = + _patsIdefinedInsts + -- self rule + _copy = + Constr name_ _patsIcopy + -- self rule + _lhsOcopy = + _copy + ( _patsIcopy,_patsIdefinedAttrs,_patsIdefinedInsts,_patsIpatunder) = + (pats_ ) + in ( _lhsOcopy,_lhsOdefinedAttrs,_lhsOdefinedInsts,_lhsOpatunder,_lhsOstpos))) +sem_Pattern_Irrefutable :: T_Pattern -> + T_Pattern +sem_Pattern_Irrefutable (T_Pattern pat_) = + (T_Pattern (let _lhsOpatunder :: ([AttrName]->Pattern) + _lhsOdefinedAttrs :: ([AttrName]) + _lhsOdefinedInsts :: ([Identifier]) + _lhsOcopy :: Pattern + _lhsOstpos :: Pos + _patIcopy :: Pattern + _patIdefinedAttrs :: ([AttrName]) + _patIdefinedInsts :: ([Identifier]) + _patIpatunder :: ([AttrName]->Pattern) + _patIstpos :: Pos + -- "Transform.ag"(line 769, column 17) + _lhsOpatunder = + \us -> Irrefutable (_patIpatunder us) + -- use rule "Transform.ag"(line 758, column 42) + _lhsOdefinedAttrs = + _patIdefinedAttrs + -- use rule "Transform.ag"(line 757, column 55) + _lhsOdefinedInsts = + _patIdefinedInsts + -- self rule + _copy = + Irrefutable _patIcopy + -- self rule + _lhsOcopy = + _copy + -- copy rule (up) + _lhsOstpos = + _patIstpos + ( _patIcopy,_patIdefinedAttrs,_patIdefinedInsts,_patIpatunder,_patIstpos) = + (pat_ ) + in ( _lhsOcopy,_lhsOdefinedAttrs,_lhsOdefinedInsts,_lhsOpatunder,_lhsOstpos))) +sem_Pattern_Product :: Pos -> + T_Patterns -> + T_Pattern +sem_Pattern_Product pos_ (T_Patterns pats_) = + (T_Pattern (let _lhsOpatunder :: ([AttrName]->Pattern) + _lhsOstpos :: Pos + _lhsOdefinedAttrs :: ([AttrName]) + _lhsOdefinedInsts :: ([Identifier]) + _lhsOcopy :: Pattern + _patsIcopy :: Patterns + _patsIdefinedAttrs :: ([AttrName]) + _patsIdefinedInsts :: ([Identifier]) + _patsIpatunder :: ([AttrName]->Patterns) + -- "Transform.ag"(line 768, column 13) + _lhsOpatunder = + \us -> Product pos_ (_patsIpatunder us) + -- "Transform.ag"(line 779, column 16) + _lhsOstpos = + pos_ + -- use rule "Transform.ag"(line 758, column 42) + _lhsOdefinedAttrs = + _patsIdefinedAttrs + -- use rule "Transform.ag"(line 757, column 55) + _lhsOdefinedInsts = + _patsIdefinedInsts + -- self rule + _copy = + Product pos_ _patsIcopy + -- self rule + _lhsOcopy = + _copy + ( _patsIcopy,_patsIdefinedAttrs,_patsIdefinedInsts,_patsIpatunder) = + (pats_ ) + in ( _lhsOcopy,_lhsOdefinedAttrs,_lhsOdefinedInsts,_lhsOpatunder,_lhsOstpos))) +sem_Pattern_Underscore :: Pos -> + T_Pattern +sem_Pattern_Underscore pos_ = + (T_Pattern (let _lhsOpatunder :: ([AttrName]->Pattern) + _lhsOstpos :: Pos + _lhsOdefinedAttrs :: ([AttrName]) + _lhsOdefinedInsts :: ([Identifier]) + _lhsOcopy :: Pattern + -- "Transform.ag"(line 766, column 16) + _lhsOpatunder = + \us -> _copy + -- "Transform.ag"(line 781, column 16) + _lhsOstpos = + pos_ + -- use rule "Transform.ag"(line 758, column 42) + _lhsOdefinedAttrs = + [] + -- use rule "Transform.ag"(line 757, column 55) + _lhsOdefinedInsts = + [] + -- self rule + _copy = + Underscore pos_ + -- self rule + _lhsOcopy = + _copy + in ( _lhsOcopy,_lhsOdefinedAttrs,_lhsOdefinedInsts,_lhsOpatunder,_lhsOstpos))) +-- Patterns ---------------------------------------------------- +{- + visit 0: + synthesized attributes: + copy : SELF + definedAttrs : [AttrName] + definedInsts : [Identifier] + patunder : [AttrName]->Patterns + alternatives: + alternative Cons: + child hd : Pattern + child tl : Patterns + visit 0: + local copy : _ + alternative Nil: + visit 0: + local copy : _ +-} +-- cata +sem_Patterns :: Patterns -> + T_Patterns +sem_Patterns list = + (Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list)) +-- semantic domain +newtype T_Patterns = T_Patterns (( Patterns,([AttrName]),([Identifier]),([AttrName]->Patterns))) +data Inh_Patterns = Inh_Patterns {} +data Syn_Patterns = Syn_Patterns {copy_Syn_Patterns :: Patterns,definedAttrs_Syn_Patterns :: [AttrName],definedInsts_Syn_Patterns :: [Identifier],patunder_Syn_Patterns :: [AttrName]->Patterns} +wrap_Patterns (T_Patterns sem) (Inh_Patterns ) = + (let ( _lhsOcopy,_lhsOdefinedAttrs,_lhsOdefinedInsts,_lhsOpatunder) = + (sem ) + in (Syn_Patterns _lhsOcopy _lhsOdefinedAttrs _lhsOdefinedInsts _lhsOpatunder)) +sem_Patterns_Cons :: T_Pattern -> + T_Patterns -> + T_Patterns +sem_Patterns_Cons (T_Pattern hd_) (T_Patterns tl_) = + (T_Patterns (let _lhsOpatunder :: ([AttrName]->Patterns) + _lhsOdefinedAttrs :: ([AttrName]) + _lhsOdefinedInsts :: ([Identifier]) + _lhsOcopy :: Patterns + _hdIcopy :: Pattern + _hdIdefinedAttrs :: ([AttrName]) + _hdIdefinedInsts :: ([Identifier]) + _hdIpatunder :: ([AttrName]->Pattern) + _hdIstpos :: Pos + _tlIcopy :: Patterns + _tlIdefinedAttrs :: ([AttrName]) + _tlIdefinedInsts :: ([Identifier]) + _tlIpatunder :: ([AttrName]->Patterns) + -- "Transform.ag"(line 773, column 10) + _lhsOpatunder = + \us -> (_hdIpatunder us) : (_tlIpatunder us) + -- use rule "Transform.ag"(line 758, column 42) + _lhsOdefinedAttrs = + _hdIdefinedAttrs ++ _tlIdefinedAttrs + -- use rule "Transform.ag"(line 757, column 55) + _lhsOdefinedInsts = + _hdIdefinedInsts ++ _tlIdefinedInsts + -- self rule + _copy = + (:) _hdIcopy _tlIcopy + -- self rule + _lhsOcopy = + _copy + ( _hdIcopy,_hdIdefinedAttrs,_hdIdefinedInsts,_hdIpatunder,_hdIstpos) = + (hd_ ) + ( _tlIcopy,_tlIdefinedAttrs,_tlIdefinedInsts,_tlIpatunder) = + (tl_ ) + in ( _lhsOcopy,_lhsOdefinedAttrs,_lhsOdefinedInsts,_lhsOpatunder))) +sem_Patterns_Nil :: T_Patterns +sem_Patterns_Nil = + (T_Patterns (let _lhsOpatunder :: ([AttrName]->Patterns) + _lhsOdefinedAttrs :: ([AttrName]) + _lhsOdefinedInsts :: ([Identifier]) + _lhsOcopy :: Patterns + -- "Transform.ag"(line 772, column 9) + _lhsOpatunder = + \us -> [] + -- use rule "Transform.ag"(line 758, column 42) + _lhsOdefinedAttrs = + [] + -- use rule "Transform.ag"(line 757, column 55) + _lhsOdefinedInsts = + [] + -- self rule + _copy = + [] + -- self rule + _lhsOcopy = + _copy + in ( _lhsOcopy,_lhsOdefinedAttrs,_lhsOdefinedInsts,_lhsOpatunder))) +-- SemAlt ------------------------------------------------------ +{- + visit 0: + inherited attributes: + allAttrDecls : Map NontermIdent (Attributes, Attributes) + allFields : DataTypes + nts : Set NontermIdent + synthesized attributes: + attrOrderCollect : AttrOrderMap + collectedInsts : [ (NontermIdent, ConstructorIdent, [Identifier]) ] + collectedRules : [ (NontermIdent, ConstructorIdent, RuleInfo)] + collectedSigs : [ (NontermIdent, ConstructorIdent, SigInfo) ] + errors : Seq Error + semPragmasCollect : PragmaMap + alternatives: + alternative SemAlt: + child pos : {Pos} + child constructorSet : ConstructorSet + child rules : SemDefs + visit 0: + local pragmaNames : _ + local attrOrders : _ + local coninfo : _ +-} +-- cata +sem_SemAlt :: SemAlt -> + T_SemAlt +sem_SemAlt (SemAlt _pos _constructorSet _rules) = + (sem_SemAlt_SemAlt _pos (sem_ConstructorSet _constructorSet) (sem_SemDefs _rules)) +-- semantic domain +newtype T_SemAlt = T_SemAlt ((Map NontermIdent (Attributes, Attributes)) -> + DataTypes -> + (Set NontermIdent) -> + ( AttrOrderMap,([ (NontermIdent, ConstructorIdent, [Identifier]) ]),([ (NontermIdent, ConstructorIdent, RuleInfo)]),([ (NontermIdent, ConstructorIdent, SigInfo) ]),(Seq Error),PragmaMap)) +data Inh_SemAlt = Inh_SemAlt {allAttrDecls_Inh_SemAlt :: Map NontermIdent (Attributes, Attributes),allFields_Inh_SemAlt :: DataTypes,nts_Inh_SemAlt :: Set NontermIdent} +data Syn_SemAlt = Syn_SemAlt {attrOrderCollect_Syn_SemAlt :: AttrOrderMap,collectedInsts_Syn_SemAlt :: [ (NontermIdent, ConstructorIdent, [Identifier]) ],collectedRules_Syn_SemAlt :: [ (NontermIdent, ConstructorIdent, RuleInfo)],collectedSigs_Syn_SemAlt :: [ (NontermIdent, ConstructorIdent, SigInfo) ],errors_Syn_SemAlt :: Seq Error,semPragmasCollect_Syn_SemAlt :: PragmaMap} +wrap_SemAlt (T_SemAlt sem) (Inh_SemAlt _lhsIallAttrDecls _lhsIallFields _lhsInts) = + (let ( _lhsOattrOrderCollect,_lhsOcollectedInsts,_lhsOcollectedRules,_lhsOcollectedSigs,_lhsOerrors,_lhsOsemPragmasCollect) = + (sem _lhsIallAttrDecls _lhsIallFields _lhsInts) + in (Syn_SemAlt _lhsOattrOrderCollect _lhsOcollectedInsts _lhsOcollectedRules _lhsOcollectedSigs _lhsOerrors _lhsOsemPragmasCollect)) +sem_SemAlt_SemAlt :: Pos -> + T_ConstructorSet -> + T_SemDefs -> + T_SemAlt +sem_SemAlt_SemAlt pos_ (T_ConstructorSet constructorSet_) (T_SemDefs rules_) = + (T_SemAlt (\ _lhsIallAttrDecls + _lhsIallFields + _lhsInts -> + (let _lhsOsemPragmasCollect :: PragmaMap + _lhsOattrOrderCollect :: AttrOrderMap + _lhsOerrors :: (Seq Error) + _lhsOcollectedRules :: ([ (NontermIdent, ConstructorIdent, RuleInfo)]) + _lhsOcollectedSigs :: ([ (NontermIdent, ConstructorIdent, SigInfo) ]) + _lhsOcollectedInsts :: ([ (NontermIdent, ConstructorIdent, [Identifier]) ]) + _constructorSetIcollectedConstructorNames :: (Set ConstructorIdent) + _constructorSetIconstructors :: ((Set ConstructorIdent->Set ConstructorIdent)) + _constructorSetIerrors :: (Seq Error) + _rulesIdefinedInsts :: ([Identifier]) + _rulesIorderDepsCollect :: (Set Dependency) + _rulesIpragmaNamesCollect :: ([Identifier]) + _rulesIruleInfos :: ([RuleInfo]) + _rulesIsigInfos :: ([SigInfo] ) + -- "Transform.ag"(line 541, column 7) + _pragmaNames = + Set.fromList _rulesIpragmaNamesCollect + -- "Transform.ag"(line 542, column 7) + _lhsOsemPragmasCollect = + foldr pragmaMapUnion Map.empty [ pragmaMapSingle nt con _pragmaNames + | (nt, conset, _) <- _coninfo + , con <- Set.toList conset + ] + -- "Transform.ag"(line 570, column 7) + _attrOrders = + [ orderMapSingle nt con _rulesIorderDepsCollect + | (nt, conset, _) <- _coninfo + , con <- Set.toList conset + ] + -- "Transform.ag"(line 576, column 7) + _lhsOattrOrderCollect = + foldr orderMapUnion Map.empty _attrOrders + -- "Transform.ag"(line 718, column 12) + _coninfo = + [ (nt, conset, conkeys) + | nt <- Set.toList _lhsInts + , let conmap = Map.findWithDefault Map.empty nt _lhsIallFields + , let conkeys = Set.fromList (Map.keys conmap) + , let conset = _constructorSetIconstructors conkeys + ] + -- "Transform.ag"(line 725, column 12) + _lhsOerrors = + Seq.fromList + [ UndefAlt nt con + | (nt, conset, conkeys) <- _coninfo + , con <- Set.toList (Set.difference conset conkeys) + ] + -- "Transform.ag"(line 730, column 12) + _lhsOcollectedRules = + [ (nt,con,r) + | (nt, conset, _) <- _coninfo + , con <- Set.toList conset + , r <- _rulesIruleInfos + ] + -- "Transform.ag"(line 736, column 12) + _lhsOcollectedSigs = + [ (nt,con,ts) + | (nt, conset, _) <- _coninfo + , con <- Set.toList conset + , ts <- _rulesIsigInfos + ] + -- "Transform.ag"(line 743, column 12) + _lhsOcollectedInsts = + [ (nt,con,_rulesIdefinedInsts) + | (nt, conset, _) <- _coninfo + , con <- Set.toList conset + ] + ( _constructorSetIcollectedConstructorNames,_constructorSetIconstructors,_constructorSetIerrors) = + (constructorSet_ ) + ( _rulesIdefinedInsts,_rulesIorderDepsCollect,_rulesIpragmaNamesCollect,_rulesIruleInfos,_rulesIsigInfos) = + (rules_ ) + in ( _lhsOattrOrderCollect,_lhsOcollectedInsts,_lhsOcollectedRules,_lhsOcollectedSigs,_lhsOerrors,_lhsOsemPragmasCollect)))) +-- SemAlts ----------------------------------------------------- +{- + visit 0: + inherited attributes: + allAttrDecls : Map NontermIdent (Attributes, Attributes) + allFields : DataTypes + nts : Set NontermIdent + synthesized attributes: + attrOrderCollect : AttrOrderMap + collectedInsts : [ (NontermIdent, ConstructorIdent, [Identifier]) ] + collectedRules : [ (NontermIdent, ConstructorIdent, RuleInfo)] + collectedSigs : [ (NontermIdent, ConstructorIdent, SigInfo) ] + errors : Seq Error + semPragmasCollect : PragmaMap + alternatives: + alternative Cons: + child hd : SemAlt + child tl : SemAlts + alternative Nil: +-} +-- cata +sem_SemAlts :: SemAlts -> + T_SemAlts +sem_SemAlts list = + (Prelude.foldr sem_SemAlts_Cons sem_SemAlts_Nil (Prelude.map sem_SemAlt list)) +-- semantic domain +newtype T_SemAlts = T_SemAlts ((Map NontermIdent (Attributes, Attributes)) -> + DataTypes -> + (Set NontermIdent) -> + ( AttrOrderMap,([ (NontermIdent, ConstructorIdent, [Identifier]) ]),([ (NontermIdent, ConstructorIdent, RuleInfo)]),([ (NontermIdent, ConstructorIdent, SigInfo) ]),(Seq Error),PragmaMap)) +data Inh_SemAlts = Inh_SemAlts {allAttrDecls_Inh_SemAlts :: Map NontermIdent (Attributes, Attributes),allFields_Inh_SemAlts :: DataTypes,nts_Inh_SemAlts :: Set NontermIdent} +data Syn_SemAlts = Syn_SemAlts {attrOrderCollect_Syn_SemAlts :: AttrOrderMap,collectedInsts_Syn_SemAlts :: [ (NontermIdent, ConstructorIdent, [Identifier]) ],collectedRules_Syn_SemAlts :: [ (NontermIdent, ConstructorIdent, RuleInfo)],collectedSigs_Syn_SemAlts :: [ (NontermIdent, ConstructorIdent, SigInfo) ],errors_Syn_SemAlts :: Seq Error,semPragmasCollect_Syn_SemAlts :: PragmaMap} +wrap_SemAlts (T_SemAlts sem) (Inh_SemAlts _lhsIallAttrDecls _lhsIallFields _lhsInts) = + (let ( _lhsOattrOrderCollect,_lhsOcollectedInsts,_lhsOcollectedRules,_lhsOcollectedSigs,_lhsOerrors,_lhsOsemPragmasCollect) = + (sem _lhsIallAttrDecls _lhsIallFields _lhsInts) + in (Syn_SemAlts _lhsOattrOrderCollect _lhsOcollectedInsts _lhsOcollectedRules _lhsOcollectedSigs _lhsOerrors _lhsOsemPragmasCollect)) +sem_SemAlts_Cons :: T_SemAlt -> + T_SemAlts -> + T_SemAlts +sem_SemAlts_Cons (T_SemAlt hd_) (T_SemAlts tl_) = + (T_SemAlts (\ _lhsIallAttrDecls + _lhsIallFields + _lhsInts -> + (let _lhsOattrOrderCollect :: AttrOrderMap + _lhsOcollectedInsts :: ([ (NontermIdent, ConstructorIdent, [Identifier]) ]) + _lhsOcollectedRules :: ([ (NontermIdent, ConstructorIdent, RuleInfo)]) + _lhsOcollectedSigs :: ([ (NontermIdent, ConstructorIdent, SigInfo) ]) + _lhsOerrors :: (Seq Error) + _lhsOsemPragmasCollect :: PragmaMap + _hdOallAttrDecls :: (Map NontermIdent (Attributes, Attributes)) + _hdOallFields :: DataTypes + _hdOnts :: (Set NontermIdent) + _tlOallAttrDecls :: (Map NontermIdent (Attributes, Attributes)) + _tlOallFields :: DataTypes + _tlOnts :: (Set NontermIdent) + _hdIattrOrderCollect :: AttrOrderMap + _hdIcollectedInsts :: ([ (NontermIdent, ConstructorIdent, [Identifier]) ]) + _hdIcollectedRules :: ([ (NontermIdent, ConstructorIdent, RuleInfo)]) + _hdIcollectedSigs :: ([ (NontermIdent, ConstructorIdent, SigInfo) ]) + _hdIerrors :: (Seq Error) + _hdIsemPragmasCollect :: PragmaMap + _tlIattrOrderCollect :: AttrOrderMap + _tlIcollectedInsts :: ([ (NontermIdent, ConstructorIdent, [Identifier]) ]) + _tlIcollectedRules :: ([ (NontermIdent, ConstructorIdent, RuleInfo)]) + _tlIcollectedSigs :: ([ (NontermIdent, ConstructorIdent, SigInfo) ]) + _tlIerrors :: (Seq Error) + _tlIsemPragmasCollect :: PragmaMap + -- use rule "Transform.ag"(line 565, column 55) + _lhsOattrOrderCollect = + _hdIattrOrderCollect `orderMapUnion` _tlIattrOrderCollect + -- use rule "Transform.ag"(line 138, column 29) + _lhsOcollectedInsts = + _hdIcollectedInsts ++ _tlIcollectedInsts + -- use rule "Transform.ag"(line 136, column 29) + _lhsOcollectedRules = + _hdIcollectedRules ++ _tlIcollectedRules + -- use rule "Transform.ag"(line 137, column 29) + _lhsOcollectedSigs = + _hdIcollectedSigs ++ _tlIcollectedSigs + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + _hdIerrors Seq.<> _tlIerrors + -- use rule "Transform.ag"(line 537, column 56) + _lhsOsemPragmasCollect = + _hdIsemPragmasCollect `pragmaMapUnion` _tlIsemPragmasCollect + -- copy rule (down) + _hdOallAttrDecls = + _lhsIallAttrDecls + -- copy rule (down) + _hdOallFields = + _lhsIallFields + -- copy rule (down) + _hdOnts = + _lhsInts + -- copy rule (down) + _tlOallAttrDecls = + _lhsIallAttrDecls + -- copy rule (down) + _tlOallFields = + _lhsIallFields + -- copy rule (down) + _tlOnts = + _lhsInts + ( _hdIattrOrderCollect,_hdIcollectedInsts,_hdIcollectedRules,_hdIcollectedSigs,_hdIerrors,_hdIsemPragmasCollect) = + (hd_ _hdOallAttrDecls _hdOallFields _hdOnts) + ( _tlIattrOrderCollect,_tlIcollectedInsts,_tlIcollectedRules,_tlIcollectedSigs,_tlIerrors,_tlIsemPragmasCollect) = + (tl_ _tlOallAttrDecls _tlOallFields _tlOnts) + in ( _lhsOattrOrderCollect,_lhsOcollectedInsts,_lhsOcollectedRules,_lhsOcollectedSigs,_lhsOerrors,_lhsOsemPragmasCollect)))) +sem_SemAlts_Nil :: T_SemAlts +sem_SemAlts_Nil = + (T_SemAlts (\ _lhsIallAttrDecls + _lhsIallFields + _lhsInts -> + (let _lhsOattrOrderCollect :: AttrOrderMap + _lhsOcollectedInsts :: ([ (NontermIdent, ConstructorIdent, [Identifier]) ]) + _lhsOcollectedRules :: ([ (NontermIdent, ConstructorIdent, RuleInfo)]) + _lhsOcollectedSigs :: ([ (NontermIdent, ConstructorIdent, SigInfo) ]) + _lhsOerrors :: (Seq Error) + _lhsOsemPragmasCollect :: PragmaMap + -- use rule "Transform.ag"(line 565, column 55) + _lhsOattrOrderCollect = + Map.empty + -- use rule "Transform.ag"(line 138, column 29) + _lhsOcollectedInsts = + [] + -- use rule "Transform.ag"(line 136, column 29) + _lhsOcollectedRules = + [] + -- use rule "Transform.ag"(line 137, column 29) + _lhsOcollectedSigs = + [] + -- use rule "Transform.ag"(line 36, column 19) + _lhsOerrors = + Seq.empty + -- use rule "Transform.ag"(line 537, column 56) + _lhsOsemPragmasCollect = + Map.empty + in ( _lhsOattrOrderCollect,_lhsOcollectedInsts,_lhsOcollectedRules,_lhsOcollectedSigs,_lhsOerrors,_lhsOsemPragmasCollect)))) +-- SemDef ------------------------------------------------------ +{- + visit 0: + synthesized attributes: + definedInsts : [Identifier] + orderDepsCollect : Set Dependency + pragmaNamesCollect : [Identifier] + ruleInfos : [RuleInfo] + sigInfos : [SigInfo] + alternatives: + alternative AttrOrderBefore: + child before : {[(Identifier,Identifier)]} + child after : {[(Identifier,Identifier)]} + visit 0: + local dependency : _ + alternative Def: + child pattern : Pattern + child rhs : {Expression} + child owrt : {Bool} + alternative SemPragma: + child names : {[NontermIdent]} + alternative TypeDef: + child ident : {Identifier} + child tp : {Type} +-} +-- cata +sem_SemDef :: SemDef -> + T_SemDef +sem_SemDef (AttrOrderBefore _before _after) = + (sem_SemDef_AttrOrderBefore _before _after) +sem_SemDef (Def _pattern _rhs _owrt) = + (sem_SemDef_Def (sem_Pattern _pattern) _rhs _owrt) +sem_SemDef (SemPragma _names) = + (sem_SemDef_SemPragma _names) +sem_SemDef (TypeDef _ident _tp) = + (sem_SemDef_TypeDef _ident _tp) +-- semantic domain +newtype T_SemDef = T_SemDef (( ([Identifier]),(Set Dependency),([Identifier]),([RuleInfo]),([SigInfo] ))) +data Inh_SemDef = Inh_SemDef {} +data Syn_SemDef = Syn_SemDef {definedInsts_Syn_SemDef :: [Identifier],orderDepsCollect_Syn_SemDef :: Set Dependency,pragmaNamesCollect_Syn_SemDef :: [Identifier],ruleInfos_Syn_SemDef :: [RuleInfo],sigInfos_Syn_SemDef :: [SigInfo] } +wrap_SemDef (T_SemDef sem) (Inh_SemDef ) = + (let ( _lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos) = + (sem ) + in (Syn_SemDef _lhsOdefinedInsts _lhsOorderDepsCollect _lhsOpragmaNamesCollect _lhsOruleInfos _lhsOsigInfos)) +sem_SemDef_AttrOrderBefore :: ([(Identifier,Identifier)]) -> + ([(Identifier,Identifier)]) -> + T_SemDef +sem_SemDef_AttrOrderBefore before_ after_ = + (T_SemDef (let _lhsOorderDepsCollect :: (Set Dependency) + _lhsOdefinedInsts :: ([Identifier]) + _lhsOpragmaNamesCollect :: ([Identifier]) + _lhsOruleInfos :: ([RuleInfo]) + _lhsOsigInfos :: ([SigInfo] ) + -- "Transform.ag"(line 582, column 7) + _dependency = + [ Dependency b a | b <- before_, a <- after_ ] + -- "Transform.ag"(line 583, column 7) + _lhsOorderDepsCollect = + Set.fromList _dependency + -- use rule "Transform.ag"(line 757, column 55) + _lhsOdefinedInsts = + [] + -- use rule "Transform.ag"(line 547, column 46) + _lhsOpragmaNamesCollect = + [] + -- use rule "Transform.ag"(line 712, column 37) + _lhsOruleInfos = + [] + -- use rule "Transform.ag"(line 713, column 37) + _lhsOsigInfos = + [] + in ( _lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos))) +sem_SemDef_Def :: T_Pattern -> + Expression -> + Bool -> + T_SemDef +sem_SemDef_Def (T_Pattern pattern_) rhs_ owrt_ = + (T_SemDef (let _lhsOruleInfos :: ([RuleInfo]) + _lhsOdefinedInsts :: ([Identifier]) + _lhsOorderDepsCollect :: (Set Dependency) + _lhsOpragmaNamesCollect :: ([Identifier]) + _lhsOsigInfos :: ([SigInfo] ) + _patternIcopy :: Pattern + _patternIdefinedAttrs :: ([AttrName]) + _patternIdefinedInsts :: ([Identifier]) + _patternIpatunder :: ([AttrName]->Pattern) + _patternIstpos :: Pos + -- "Transform.ag"(line 751, column 10) + _lhsOruleInfos = + [ (_patternIpatunder, rhs_, _patternIdefinedAttrs, owrt_, show _patternIstpos) ] + -- use rule "Transform.ag"(line 757, column 55) + _lhsOdefinedInsts = + _patternIdefinedInsts + -- use rule "Transform.ag"(line 578, column 44) + _lhsOorderDepsCollect = + Set.empty + -- use rule "Transform.ag"(line 547, column 46) + _lhsOpragmaNamesCollect = + [] + -- use rule "Transform.ag"(line 713, column 37) + _lhsOsigInfos = + [] + ( _patternIcopy,_patternIdefinedAttrs,_patternIdefinedInsts,_patternIpatunder,_patternIstpos) = + (pattern_ ) + in ( _lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos))) +sem_SemDef_SemPragma :: ([NontermIdent]) -> + T_SemDef +sem_SemDef_SemPragma names_ = + (T_SemDef (let _lhsOpragmaNamesCollect :: ([Identifier]) + _lhsOdefinedInsts :: ([Identifier]) + _lhsOorderDepsCollect :: (Set Dependency) + _lhsOruleInfos :: ([RuleInfo]) + _lhsOsigInfos :: ([SigInfo] ) + -- "Transform.ag"(line 551, column 7) + _lhsOpragmaNamesCollect = + names_ + -- use rule "Transform.ag"(line 757, column 55) + _lhsOdefinedInsts = + [] + -- use rule "Transform.ag"(line 578, column 44) + _lhsOorderDepsCollect = + Set.empty + -- use rule "Transform.ag"(line 712, column 37) + _lhsOruleInfos = + [] + -- use rule "Transform.ag"(line 713, column 37) + _lhsOsigInfos = + [] + in ( _lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos))) +sem_SemDef_TypeDef :: Identifier -> + Type -> + T_SemDef +sem_SemDef_TypeDef ident_ tp_ = + (T_SemDef (let _lhsOsigInfos :: ([SigInfo] ) + _lhsOdefinedInsts :: ([Identifier]) + _lhsOorderDepsCollect :: (Set Dependency) + _lhsOpragmaNamesCollect :: ([Identifier]) + _lhsOruleInfos :: ([RuleInfo]) + -- "Transform.ag"(line 754, column 14) + _lhsOsigInfos = + [ (ident_, tp_) ] + -- use rule "Transform.ag"(line 757, column 55) + _lhsOdefinedInsts = + [] + -- use rule "Transform.ag"(line 578, column 44) + _lhsOorderDepsCollect = + Set.empty + -- use rule "Transform.ag"(line 547, column 46) + _lhsOpragmaNamesCollect = + [] + -- use rule "Transform.ag"(line 712, column 37) + _lhsOruleInfos = + [] + in ( _lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos))) +-- SemDefs ----------------------------------------------------- +{- + visit 0: + synthesized attributes: + definedInsts : [Identifier] + orderDepsCollect : Set Dependency + pragmaNamesCollect : [Identifier] + ruleInfos : [RuleInfo] + sigInfos : [SigInfo] + alternatives: + alternative Cons: + child hd : SemDef + child tl : SemDefs + alternative Nil: +-} +-- cata +sem_SemDefs :: SemDefs -> + T_SemDefs +sem_SemDefs list = + (Prelude.foldr sem_SemDefs_Cons sem_SemDefs_Nil (Prelude.map sem_SemDef list)) +-- semantic domain +newtype T_SemDefs = T_SemDefs (( ([Identifier]),(Set Dependency),([Identifier]),([RuleInfo]),([SigInfo] ))) +data Inh_SemDefs = Inh_SemDefs {} +data Syn_SemDefs = Syn_SemDefs {definedInsts_Syn_SemDefs :: [Identifier],orderDepsCollect_Syn_SemDefs :: Set Dependency,pragmaNamesCollect_Syn_SemDefs :: [Identifier],ruleInfos_Syn_SemDefs :: [RuleInfo],sigInfos_Syn_SemDefs :: [SigInfo] } +wrap_SemDefs (T_SemDefs sem) (Inh_SemDefs ) = + (let ( _lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos) = + (sem ) + in (Syn_SemDefs _lhsOdefinedInsts _lhsOorderDepsCollect _lhsOpragmaNamesCollect _lhsOruleInfos _lhsOsigInfos)) +sem_SemDefs_Cons :: T_SemDef -> + T_SemDefs -> + T_SemDefs +sem_SemDefs_Cons (T_SemDef hd_) (T_SemDefs tl_) = + (T_SemDefs (let _lhsOdefinedInsts :: ([Identifier]) + _lhsOorderDepsCollect :: (Set Dependency) + _lhsOpragmaNamesCollect :: ([Identifier]) + _lhsOruleInfos :: ([RuleInfo]) + _lhsOsigInfos :: ([SigInfo] ) + _hdIdefinedInsts :: ([Identifier]) + _hdIorderDepsCollect :: (Set Dependency) + _hdIpragmaNamesCollect :: ([Identifier]) + _hdIruleInfos :: ([RuleInfo]) + _hdIsigInfos :: ([SigInfo] ) + _tlIdefinedInsts :: ([Identifier]) + _tlIorderDepsCollect :: (Set Dependency) + _tlIpragmaNamesCollect :: ([Identifier]) + _tlIruleInfos :: ([RuleInfo]) + _tlIsigInfos :: ([SigInfo] ) + -- use rule "Transform.ag"(line 757, column 55) + _lhsOdefinedInsts = + _hdIdefinedInsts ++ _tlIdefinedInsts + -- use rule "Transform.ag"(line 578, column 44) + _lhsOorderDepsCollect = + _hdIorderDepsCollect `Set.union` _tlIorderDepsCollect + -- use rule "Transform.ag"(line 547, column 46) + _lhsOpragmaNamesCollect = + _hdIpragmaNamesCollect ++ _tlIpragmaNamesCollect + -- use rule "Transform.ag"(line 712, column 37) + _lhsOruleInfos = + _hdIruleInfos ++ _tlIruleInfos + -- use rule "Transform.ag"(line 713, column 37) + _lhsOsigInfos = + _hdIsigInfos ++ _tlIsigInfos + ( _hdIdefinedInsts,_hdIorderDepsCollect,_hdIpragmaNamesCollect,_hdIruleInfos,_hdIsigInfos) = + (hd_ ) + ( _tlIdefinedInsts,_tlIorderDepsCollect,_tlIpragmaNamesCollect,_tlIruleInfos,_tlIsigInfos) = + (tl_ ) + in ( _lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos))) +sem_SemDefs_Nil :: T_SemDefs +sem_SemDefs_Nil = + (T_SemDefs (let _lhsOdefinedInsts :: ([Identifier]) + _lhsOorderDepsCollect :: (Set Dependency) + _lhsOpragmaNamesCollect :: ([Identifier]) + _lhsOruleInfos :: ([RuleInfo]) + _lhsOsigInfos :: ([SigInfo] ) + -- use rule "Transform.ag"(line 757, column 55) + _lhsOdefinedInsts = + [] + -- use rule "Transform.ag"(line 578, column 44) + _lhsOorderDepsCollect = + Set.empty + -- use rule "Transform.ag"(line 547, column 46) + _lhsOpragmaNamesCollect = + [] + -- use rule "Transform.ag"(line 712, column 37) + _lhsOruleInfos = + [] + -- use rule "Transform.ag"(line 713, column 37) _lhsOsigInfos = [] in ( _lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos))) diff --git a/src-derived/Visage.hs b/src-derived/Visage.hs new file mode 100644 --- /dev/null +++ b/src-derived/Visage.hs @@ -0,0 +1,655 @@ + +-- UUAGC 0.9.5 (Visage.ag) +module Visage where + +import UU.Scanner.Position(Pos(..)) +import CommonTypes +import ATermAbstractSyntax +import Expression +import VisagePatterns +import VisageSyntax +import qualified Data.Map as Map +import Data.Map(Map) +import Data.List(intersperse) +import TokenDef + + +import CommonTypes +import UU.Pretty +import AbstractSyntax +import VisagePatterns +import Expression + + +import UU.Scanner.Position(Pos) +import CommonTypes + + +import UU.Scanner.Position(Pos) +import HsToken + +convert :: String -> String +convert [] = [] +convert (c:ct) | c == '\n' = '\\' : 'n' : convert ct + | otherwise = c : convert ct + +sQ :: String -> String +sQ [] = [] +sQ (x:xs) = if (x=='"') then rest else x:rest + where + rest = if not (null xs) && last xs == '"' then init xs else xs + +showAGPos :: Pos -> String +showAGPos (Pos l c f) | l == (-1) = "" + | otherwise = let file = if null f then "" else f -- No show of f + lc = "(line " ++ show l ++ ", column " ++ show c ++")" + in file ++ lc + +showMap :: (Show a, Show b) => Map a b -> String +showMap + = braces . concat . intersperse "," . map (uncurry assign) . Map.assocs + where + braces s = "{" ++ s ++ "}" + assign a b = show a ++ ":=" ++ show b +-- Expression -------------------------------------------------- +{- + visit 0: + synthesized attribute: + aterm : ATerm + alternatives: + alternative Expression: + child pos : {Pos} + child tks : {[HsToken]} +-} +-- cata +sem_Expression :: Expression -> + T_Expression +sem_Expression (Expression _pos _tks ) = + (sem_Expression_Expression _pos _tks ) +-- semantic domain +newtype T_Expression = T_Expression (( ATerm)) +data Inh_Expression = Inh_Expression {} +data Syn_Expression = Syn_Expression {aterm_Syn_Expression :: ATerm} +wrap_Expression (T_Expression sem ) (Inh_Expression ) = + (let ( _lhsOaterm) = + (sem ) + in (Syn_Expression _lhsOaterm )) +sem_Expression_Expression :: Pos -> + ([HsToken]) -> + T_Expression +sem_Expression_Expression pos_ tks_ = + (T_Expression (let _lhsOaterm :: ATerm + -- "Visage.ag"(line 103, column 17) + _lhsOaterm = + AAppl "Expression" [AString (sQ (showAGPos pos_)), AString (sQ (unlines . showTokens . tokensToStrings $ tks_))] + in ( _lhsOaterm)) ) +-- VisageChild ------------------------------------------------- +{- + visit 0: + synthesized attribute: + aterm : ATerm + alternatives: + alternative VChild: + child name : {Identifier} + child tp : {Type} + child inh : {Attributes} + child syn : {Attributes} + child rules : VisageRules +-} +-- cata +sem_VisageChild :: VisageChild -> + T_VisageChild +sem_VisageChild (VChild _name _tp _inh _syn _rules ) = + (sem_VisageChild_VChild _name _tp _inh _syn (sem_VisageRules _rules ) ) +-- semantic domain +newtype T_VisageChild = T_VisageChild (( ATerm)) +data Inh_VisageChild = Inh_VisageChild {} +data Syn_VisageChild = Syn_VisageChild {aterm_Syn_VisageChild :: ATerm} +wrap_VisageChild (T_VisageChild sem ) (Inh_VisageChild ) = + (let ( _lhsOaterm) = + (sem ) + in (Syn_VisageChild _lhsOaterm )) +sem_VisageChild_VChild :: Identifier -> + Type -> + Attributes -> + Attributes -> + T_VisageRules -> + T_VisageChild +sem_VisageChild_VChild name_ tp_ inh_ syn_ (T_VisageRules rules_ ) = + (T_VisageChild (let _lhsOaterm :: ATerm + _rulesOisLoc :: Bool + _rulesIaterms :: ([ATerm]) + -- "Visage.ag"(line 85, column 18) + _lhsOaterm = + AAppl "Child" [AString (sQ (getName name_)), AString (sQ (show tp_)), + AString (sQ (showMap inh_)), + AString (sQ (showMap syn_)), + AAppl "Rules" _rulesIaterms] + -- "Visage.ag"(line 89, column 18) + _rulesOisLoc = + False + ( _rulesIaterms) = + (rules_ _rulesOisLoc ) + in ( _lhsOaterm)) ) +-- VisageChildren ---------------------------------------------- +{- + visit 0: + synthesized attribute: + aterms : [ATerm] + alternatives: + alternative Cons: + child hd : VisageChild + child tl : VisageChildren + alternative Nil: +-} +-- cata +sem_VisageChildren :: VisageChildren -> + T_VisageChildren +sem_VisageChildren list = + (Prelude.foldr sem_VisageChildren_Cons sem_VisageChildren_Nil (Prelude.map sem_VisageChild list) ) +-- semantic domain +newtype T_VisageChildren = T_VisageChildren (( ([ATerm]))) +data Inh_VisageChildren = Inh_VisageChildren {} +data Syn_VisageChildren = Syn_VisageChildren {aterms_Syn_VisageChildren :: [ATerm]} +wrap_VisageChildren (T_VisageChildren sem ) (Inh_VisageChildren ) = + (let ( _lhsOaterms) = + (sem ) + in (Syn_VisageChildren _lhsOaterms )) +sem_VisageChildren_Cons :: T_VisageChild -> + T_VisageChildren -> + T_VisageChildren +sem_VisageChildren_Cons (T_VisageChild hd_ ) (T_VisageChildren tl_ ) = + (T_VisageChildren (let _lhsOaterms :: ([ATerm]) + _hdIaterm :: ATerm + _tlIaterms :: ([ATerm]) + -- "Visage.ag"(line 80, column 17) + _lhsOaterms = + _hdIaterm : _tlIaterms + ( _hdIaterm) = + (hd_ ) + ( _tlIaterms) = + (tl_ ) + in ( _lhsOaterms)) ) +sem_VisageChildren_Nil :: T_VisageChildren +sem_VisageChildren_Nil = + (T_VisageChildren (let _lhsOaterms :: ([ATerm]) + -- "Visage.ag"(line 81, column 17) + _lhsOaterms = + [] + in ( _lhsOaterms)) ) +-- VisageGrammar ----------------------------------------------- +{- + visit 0: + synthesized attribute: + aterm : ATerm + alternatives: + alternative VGrammar: + child nonts : VisageNonterminals +-} +-- cata +sem_VisageGrammar :: VisageGrammar -> + T_VisageGrammar +sem_VisageGrammar (VGrammar _nonts ) = + (sem_VisageGrammar_VGrammar (sem_VisageNonterminals _nonts ) ) +-- semantic domain +newtype T_VisageGrammar = T_VisageGrammar (( ATerm)) +data Inh_VisageGrammar = Inh_VisageGrammar {} +data Syn_VisageGrammar = Syn_VisageGrammar {aterm_Syn_VisageGrammar :: ATerm} +wrap_VisageGrammar (T_VisageGrammar sem ) (Inh_VisageGrammar ) = + (let ( _lhsOaterm) = + (sem ) + in (Syn_VisageGrammar _lhsOaterm )) +sem_VisageGrammar_VGrammar :: T_VisageNonterminals -> + T_VisageGrammar +sem_VisageGrammar_VGrammar (T_VisageNonterminals nonts_ ) = + (T_VisageGrammar (let _lhsOaterm :: ATerm + _nontsIaterms :: ([ATerm]) + -- "Visage.ag"(line 54, column 18) + _lhsOaterm = + AAppl "Productions" _nontsIaterms + ( _nontsIaterms) = + (nonts_ ) + in ( _lhsOaterm)) ) +-- VisageNonterminal ------------------------------------------- +{- + visit 0: + synthesized attribute: + aterm : ATerm + alternatives: + alternative VNonterminal: + child nt : {NontermIdent} + child inh : {Attributes} + child syn : {Attributes} + child alts : VisageProductions +-} +-- cata +sem_VisageNonterminal :: VisageNonterminal -> + T_VisageNonterminal +sem_VisageNonterminal (VNonterminal _nt _inh _syn _alts ) = + (sem_VisageNonterminal_VNonterminal _nt _inh _syn (sem_VisageProductions _alts ) ) +-- semantic domain +newtype T_VisageNonterminal = T_VisageNonterminal (( ATerm)) +data Inh_VisageNonterminal = Inh_VisageNonterminal {} +data Syn_VisageNonterminal = Syn_VisageNonterminal {aterm_Syn_VisageNonterminal :: ATerm} +wrap_VisageNonterminal (T_VisageNonterminal sem ) (Inh_VisageNonterminal ) = + (let ( _lhsOaterm) = + (sem ) + in (Syn_VisageNonterminal _lhsOaterm )) +sem_VisageNonterminal_VNonterminal :: NontermIdent -> + Attributes -> + Attributes -> + T_VisageProductions -> + T_VisageNonterminal +sem_VisageNonterminal_VNonterminal nt_ inh_ syn_ (T_VisageProductions alts_ ) = + (T_VisageNonterminal (let _lhsOaterm :: ATerm + _altsIaterms :: ([ATerm]) + -- "Visage.ag"(line 63, column 19) + _lhsOaterm = + AAppl "Production" [AString (sQ (getName nt_)), AString (sQ(showMap inh_)), + AString (sQ(showMap syn_)), AAppl "Alternatives" _altsIaterms] + ( _altsIaterms) = + (alts_ ) + in ( _lhsOaterm)) ) +-- VisageNonterminals ------------------------------------------ +{- + visit 0: + synthesized attribute: + aterms : [ATerm] + alternatives: + alternative Cons: + child hd : VisageNonterminal + child tl : VisageNonterminals + alternative Nil: +-} +-- cata +sem_VisageNonterminals :: VisageNonterminals -> + T_VisageNonterminals +sem_VisageNonterminals list = + (Prelude.foldr sem_VisageNonterminals_Cons sem_VisageNonterminals_Nil (Prelude.map sem_VisageNonterminal list) ) +-- semantic domain +newtype T_VisageNonterminals = T_VisageNonterminals (( ([ATerm]))) +data Inh_VisageNonterminals = Inh_VisageNonterminals {} +data Syn_VisageNonterminals = Syn_VisageNonterminals {aterms_Syn_VisageNonterminals :: [ATerm]} +wrap_VisageNonterminals (T_VisageNonterminals sem ) (Inh_VisageNonterminals ) = + (let ( _lhsOaterms) = + (sem ) + in (Syn_VisageNonterminals _lhsOaterms )) +sem_VisageNonterminals_Cons :: T_VisageNonterminal -> + T_VisageNonterminals -> + T_VisageNonterminals +sem_VisageNonterminals_Cons (T_VisageNonterminal hd_ ) (T_VisageNonterminals tl_ ) = + (T_VisageNonterminals (let _lhsOaterms :: ([ATerm]) + _hdIaterm :: ATerm + _tlIaterms :: ([ATerm]) + -- "Visage.ag"(line 58, column 17) + _lhsOaterms = + _hdIaterm : _tlIaterms + ( _hdIaterm) = + (hd_ ) + ( _tlIaterms) = + (tl_ ) + in ( _lhsOaterms)) ) +sem_VisageNonterminals_Nil :: T_VisageNonterminals +sem_VisageNonterminals_Nil = + (T_VisageNonterminals (let _lhsOaterms :: ([ATerm]) + -- "Visage.ag"(line 59, column 17) + _lhsOaterms = + [] + in ( _lhsOaterms)) ) +-- VisagePattern ----------------------------------------------- +{- + visit 0: + synthesized attribute: + aterm : ATerm + alternatives: + alternative VAlias: + child field : {Identifier} + child attr : {Identifier} + child pat : VisagePattern + alternative VConstr: + child name : {ConstructorIdent} + child pats : VisagePatterns + alternative VProduct: + child pos : {Pos} + child pats : VisagePatterns + alternative VUnderscore: + child pos : {Pos} + alternative VVar: + child field : {Identifier} + child attr : {Identifier} +-} +-- cata +sem_VisagePattern :: VisagePattern -> + T_VisagePattern +sem_VisagePattern (VAlias _field _attr _pat ) = + (sem_VisagePattern_VAlias _field _attr (sem_VisagePattern _pat ) ) +sem_VisagePattern (VConstr _name _pats ) = + (sem_VisagePattern_VConstr _name (sem_VisagePatterns _pats ) ) +sem_VisagePattern (VProduct _pos _pats ) = + (sem_VisagePattern_VProduct _pos (sem_VisagePatterns _pats ) ) +sem_VisagePattern (VUnderscore _pos ) = + (sem_VisagePattern_VUnderscore _pos ) +sem_VisagePattern (VVar _field _attr ) = + (sem_VisagePattern_VVar _field _attr ) +-- semantic domain +newtype T_VisagePattern = T_VisagePattern (( ATerm)) +data Inh_VisagePattern = Inh_VisagePattern {} +data Syn_VisagePattern = Syn_VisagePattern {aterm_Syn_VisagePattern :: ATerm} +wrap_VisagePattern (T_VisagePattern sem ) (Inh_VisagePattern ) = + (let ( _lhsOaterm) = + (sem ) + in (Syn_VisagePattern _lhsOaterm )) +sem_VisagePattern_VAlias :: Identifier -> + Identifier -> + T_VisagePattern -> + T_VisagePattern +sem_VisagePattern_VAlias field_ attr_ (T_VisagePattern pat_ ) = + (T_VisagePattern (let _lhsOaterm :: ATerm + _patIaterm :: ATerm + -- "Visage.ag"(line 119, column 18) + _lhsOaterm = + AAppl "Pattern" [AAppl "Alias" [AString (sQ (showAGPos (getPos field_))), + AString (sQ (getName field_ ++ "." ++ getName attr_)), _patIaterm]] + ( _patIaterm) = + (pat_ ) + in ( _lhsOaterm)) ) +sem_VisagePattern_VConstr :: ConstructorIdent -> + T_VisagePatterns -> + T_VisagePattern +sem_VisagePattern_VConstr name_ (T_VisagePatterns pats_ ) = + (T_VisagePattern (let _lhsOaterm :: ATerm + _patsIaterms :: ([ATerm]) + -- "Visage.ag"(line 112, column 18) + _lhsOaterm = + AAppl "Pattern" [AAppl "Constr" [AString (sQ (showAGPos (getPos name_))), + AString (sQ (getName name_)), + AAppl "Patterns" _patsIaterms]] + ( _patsIaterms) = + (pats_ ) + in ( _lhsOaterm)) ) +sem_VisagePattern_VProduct :: Pos -> + T_VisagePatterns -> + T_VisagePattern +sem_VisagePattern_VProduct pos_ (T_VisagePatterns pats_ ) = + (T_VisagePattern (let _lhsOaterm :: ATerm + _patsIaterms :: ([ATerm]) + -- "Visage.ag"(line 115, column 18) + _lhsOaterm = + AAppl "Pattern" [AAppl "Product" [AString (sQ (showAGPos pos_)), + AAppl "Patterns" _patsIaterms]] + ( _patsIaterms) = + (pats_ ) + in ( _lhsOaterm)) ) +sem_VisagePattern_VUnderscore :: Pos -> + T_VisagePattern +sem_VisagePattern_VUnderscore pos_ = + (T_VisagePattern (let _lhsOaterm :: ATerm + -- "Visage.ag"(line 121, column 18) + _lhsOaterm = + AAppl "Pattern" [AAppl "Underscore" [AString (sQ (showAGPos pos_))]] + in ( _lhsOaterm)) ) +sem_VisagePattern_VVar :: Identifier -> + Identifier -> + T_VisagePattern +sem_VisagePattern_VVar field_ attr_ = + (T_VisagePattern (let _lhsOaterm :: ATerm + -- "Visage.ag"(line 117, column 18) + _lhsOaterm = + AAppl "Pattern" [AAppl "Var" [AString (sQ (showAGPos (getPos field_))), + AString (sQ (getName field_ ++ "." ++ getName attr_))]] + in ( _lhsOaterm)) ) +-- VisagePatterns ---------------------------------------------- +{- + visit 0: + synthesized attribute: + aterms : [ATerm] + alternatives: + alternative Cons: + child hd : VisagePattern + child tl : VisagePatterns + alternative Nil: +-} +-- cata +sem_VisagePatterns :: VisagePatterns -> + T_VisagePatterns +sem_VisagePatterns list = + (Prelude.foldr sem_VisagePatterns_Cons sem_VisagePatterns_Nil (Prelude.map sem_VisagePattern list) ) +-- semantic domain +newtype T_VisagePatterns = T_VisagePatterns (( ([ATerm]))) +data Inh_VisagePatterns = Inh_VisagePatterns {} +data Syn_VisagePatterns = Syn_VisagePatterns {aterms_Syn_VisagePatterns :: [ATerm]} +wrap_VisagePatterns (T_VisagePatterns sem ) (Inh_VisagePatterns ) = + (let ( _lhsOaterms) = + (sem ) + in (Syn_VisagePatterns _lhsOaterms )) +sem_VisagePatterns_Cons :: T_VisagePattern -> + T_VisagePatterns -> + T_VisagePatterns +sem_VisagePatterns_Cons (T_VisagePattern hd_ ) (T_VisagePatterns tl_ ) = + (T_VisagePatterns (let _lhsOaterms :: ([ATerm]) + _hdIaterm :: ATerm + _tlIaterms :: ([ATerm]) + -- "Visage.ag"(line 107, column 17) + _lhsOaterms = + _hdIaterm : _tlIaterms + ( _hdIaterm) = + (hd_ ) + ( _tlIaterms) = + (tl_ ) + in ( _lhsOaterms)) ) +sem_VisagePatterns_Nil :: T_VisagePatterns +sem_VisagePatterns_Nil = + (T_VisagePatterns (let _lhsOaterms :: ([ATerm]) + -- "Visage.ag"(line 108, column 17) + _lhsOaterms = + [] + in ( _lhsOaterms)) ) +-- VisageProduction -------------------------------------------- +{- + visit 0: + synthesized attribute: + aterm : ATerm + alternatives: + alternative VProduction: + child con : {ConstructorIdent} + child children : VisageChildren + child rules : VisageRules + child locrules : VisageRules +-} +-- cata +sem_VisageProduction :: VisageProduction -> + T_VisageProduction +sem_VisageProduction (VProduction _con _children _rules _locrules ) = + (sem_VisageProduction_VProduction _con (sem_VisageChildren _children ) (sem_VisageRules _rules ) (sem_VisageRules _locrules ) ) +-- semantic domain +newtype T_VisageProduction = T_VisageProduction (( ATerm)) +data Inh_VisageProduction = Inh_VisageProduction {} +data Syn_VisageProduction = Syn_VisageProduction {aterm_Syn_VisageProduction :: ATerm} +wrap_VisageProduction (T_VisageProduction sem ) (Inh_VisageProduction ) = + (let ( _lhsOaterm) = + (sem ) + in (Syn_VisageProduction _lhsOaterm )) +sem_VisageProduction_VProduction :: ConstructorIdent -> + T_VisageChildren -> + T_VisageRules -> + T_VisageRules -> + T_VisageProduction +sem_VisageProduction_VProduction con_ (T_VisageChildren children_ ) (T_VisageRules rules_ ) (T_VisageRules locrules_ ) = + (T_VisageProduction (let _lhsOaterm :: ATerm + _locrulesOisLoc :: Bool + _rulesOisLoc :: Bool + _childrenIaterms :: ([ATerm]) + _rulesIaterms :: ([ATerm]) + _locrulesIaterms :: ([ATerm]) + -- "Visage.ag"(line 73, column 17) + _lhsOaterm = + AAppl "Alternative" [AString (sQ (getName con_)), AAppl "Children" _childrenIaterms, + AAppl "Rules" _rulesIaterms, + AAppl "LocRules" _locrulesIaterms] + -- "Visage.ag"(line 76, column 18) + _locrulesOisLoc = + True + -- "Visage.ag"(line 77, column 18) + _rulesOisLoc = + False + ( _childrenIaterms) = + (children_ ) + ( _rulesIaterms) = + (rules_ _rulesOisLoc ) + ( _locrulesIaterms) = + (locrules_ _locrulesOisLoc ) + in ( _lhsOaterm)) ) +-- VisageProductions ------------------------------------------- +{- + visit 0: + synthesized attribute: + aterms : [ATerm] + alternatives: + alternative Cons: + child hd : VisageProduction + child tl : VisageProductions + alternative Nil: +-} +-- cata +sem_VisageProductions :: VisageProductions -> + T_VisageProductions +sem_VisageProductions list = + (Prelude.foldr sem_VisageProductions_Cons sem_VisageProductions_Nil (Prelude.map sem_VisageProduction list) ) +-- semantic domain +newtype T_VisageProductions = T_VisageProductions (( ([ATerm]))) +data Inh_VisageProductions = Inh_VisageProductions {} +data Syn_VisageProductions = Syn_VisageProductions {aterms_Syn_VisageProductions :: [ATerm]} +wrap_VisageProductions (T_VisageProductions sem ) (Inh_VisageProductions ) = + (let ( _lhsOaterms) = + (sem ) + in (Syn_VisageProductions _lhsOaterms )) +sem_VisageProductions_Cons :: T_VisageProduction -> + T_VisageProductions -> + T_VisageProductions +sem_VisageProductions_Cons (T_VisageProduction hd_ ) (T_VisageProductions tl_ ) = + (T_VisageProductions (let _lhsOaterms :: ([ATerm]) + _hdIaterm :: ATerm + _tlIaterms :: ([ATerm]) + -- "Visage.ag"(line 68, column 17) + _lhsOaterms = + _hdIaterm : _tlIaterms + ( _hdIaterm) = + (hd_ ) + ( _tlIaterms) = + (tl_ ) + in ( _lhsOaterms)) ) +sem_VisageProductions_Nil :: T_VisageProductions +sem_VisageProductions_Nil = + (T_VisageProductions (let _lhsOaterms :: ([ATerm]) + -- "Visage.ag"(line 69, column 17) + _lhsOaterms = + [] + in ( _lhsOaterms)) ) +-- VisageRule -------------------------------------------------- +{- + visit 0: + inherited attribute: + isLoc : Bool + synthesized attribute: + aterm : ATerm + alternatives: + alternative VRule: + child fieldattrs : {[(Identifier,Identifier)]} + child attr : {Identifier} + child pat : VisagePattern + child rhs : Expression + child owrt : {Bool} +-} +-- cata +sem_VisageRule :: VisageRule -> + T_VisageRule +sem_VisageRule (VRule _fieldattrs _attr _pat _rhs _owrt ) = + (sem_VisageRule_VRule _fieldattrs _attr (sem_VisagePattern _pat ) (sem_Expression _rhs ) _owrt ) +-- semantic domain +newtype T_VisageRule = T_VisageRule (Bool -> + ( ATerm)) +data Inh_VisageRule = Inh_VisageRule {isLoc_Inh_VisageRule :: Bool} +data Syn_VisageRule = Syn_VisageRule {aterm_Syn_VisageRule :: ATerm} +wrap_VisageRule (T_VisageRule sem ) (Inh_VisageRule _lhsIisLoc ) = + (let ( _lhsOaterm) = + (sem _lhsIisLoc ) + in (Syn_VisageRule _lhsOaterm )) +sem_VisageRule_VRule :: ([(Identifier,Identifier)]) -> + Identifier -> + T_VisagePattern -> + T_Expression -> + Bool -> + T_VisageRule +sem_VisageRule_VRule fieldattrs_ attr_ (T_VisagePattern pat_ ) (T_Expression rhs_ ) owrt_ = + (T_VisageRule (\ _lhsIisLoc -> + (let _lhsOaterm :: ATerm + _patIaterm :: ATerm + _rhsIaterm :: ATerm + -- "Visage.ag"(line 97, column 18) + _lhsOaterm = + AAppl (if _lhsIisLoc then "LocRule" else "Rule") + ([AString (sQ (getName attr_)), _patIaterm, _rhsIaterm] ++ if _lhsIisLoc then [AString (sQ (show owrt_))] else []) + ( _patIaterm) = + (pat_ ) + ( _rhsIaterm) = + (rhs_ ) + in ( _lhsOaterm))) ) +-- VisageRules ------------------------------------------------- +{- + visit 0: + inherited attribute: + isLoc : Bool + synthesized attribute: + aterms : [ATerm] + alternatives: + alternative Cons: + child hd : VisageRule + child tl : VisageRules + alternative Nil: +-} +-- cata +sem_VisageRules :: VisageRules -> + T_VisageRules +sem_VisageRules list = + (Prelude.foldr sem_VisageRules_Cons sem_VisageRules_Nil (Prelude.map sem_VisageRule list) ) +-- semantic domain +newtype T_VisageRules = T_VisageRules (Bool -> + ( ([ATerm]))) +data Inh_VisageRules = Inh_VisageRules {isLoc_Inh_VisageRules :: Bool} +data Syn_VisageRules = Syn_VisageRules {aterms_Syn_VisageRules :: [ATerm]} +wrap_VisageRules (T_VisageRules sem ) (Inh_VisageRules _lhsIisLoc ) = + (let ( _lhsOaterms) = + (sem _lhsIisLoc ) + in (Syn_VisageRules _lhsOaterms )) +sem_VisageRules_Cons :: T_VisageRule -> + T_VisageRules -> + T_VisageRules +sem_VisageRules_Cons (T_VisageRule hd_ ) (T_VisageRules tl_ ) = + (T_VisageRules (\ _lhsIisLoc -> + (let _lhsOaterms :: ([ATerm]) + _hdOisLoc :: Bool + _tlOisLoc :: Bool + _hdIaterm :: ATerm + _tlIaterms :: ([ATerm]) + -- "Visage.ag"(line 92, column 17) + _lhsOaterms = + _hdIaterm : _tlIaterms + -- copy rule (down) + _hdOisLoc = + _lhsIisLoc + -- copy rule (down) + _tlOisLoc = + _lhsIisLoc + ( _hdIaterm) = + (hd_ _hdOisLoc ) + ( _tlIaterms) = + (tl_ _tlOisLoc ) + in ( _lhsOaterms))) ) +sem_VisageRules_Nil :: T_VisageRules +sem_VisageRules_Nil = + (T_VisageRules (\ _lhsIisLoc -> + (let _lhsOaterms :: ([ATerm]) + -- "Visage.ag"(line 93, column 17) + _lhsOaterms = + [] + in ( _lhsOaterms))) ) diff --git a/src-derived/VisagePatterns.hs b/src-derived/VisagePatterns.hs new file mode 100644 --- /dev/null +++ b/src-derived/VisagePatterns.hs @@ -0,0 +1,39 @@ + +-- UUAGC 0.9.5 (VisagePatterns.ag) +module VisagePatterns where + +import UU.Scanner.Position(Pos) +import CommonTypes +-- VisagePattern ----------------------------------------------- +{- + alternatives: + alternative VAlias: + child field : {Identifier} + child attr : {Identifier} + child pat : VisagePattern + alternative VConstr: + child name : {ConstructorIdent} + child pats : VisagePatterns + alternative VProduct: + child pos : {Pos} + child pats : VisagePatterns + alternative VUnderscore: + child pos : {Pos} + alternative VVar: + child field : {Identifier} + child attr : {Identifier} +-} +data VisagePattern = VAlias (Identifier) (Identifier) (VisagePattern) + | VConstr (ConstructorIdent) (VisagePatterns) + | VProduct (Pos) (VisagePatterns) + | VUnderscore (Pos) + | VVar (Identifier) (Identifier) +-- VisagePatterns ---------------------------------------------- +{- + alternatives: + alternative Cons: + child hd : VisagePattern + child tl : VisagePatterns + alternative Nil: +-} +type VisagePatterns = [VisagePattern] diff --git a/src-derived/VisageSyntax.hs b/src-derived/VisageSyntax.hs new file mode 100644 --- /dev/null +++ b/src-derived/VisageSyntax.hs @@ -0,0 +1,94 @@ + +-- UUAGC 0.9.5 (VisageSyntax.ag) +module VisageSyntax where + +import CommonTypes +import UU.Pretty +import AbstractSyntax +import VisagePatterns +import Expression +-- VisageChild ------------------------------------------------- +{- + alternatives: + alternative VChild: + child name : {Identifier} + child tp : {Type} + child inh : {Attributes} + child syn : {Attributes} + child rules : VisageRules +-} +data VisageChild = VChild (Identifier) (Type) (Attributes) (Attributes) (VisageRules) +-- VisageChildren ---------------------------------------------- +{- + alternatives: + alternative Cons: + child hd : VisageChild + child tl : VisageChildren + alternative Nil: +-} +type VisageChildren = [VisageChild] +-- VisageGrammar ----------------------------------------------- +{- + alternatives: + alternative VGrammar: + child nonts : VisageNonterminals +-} +data VisageGrammar = VGrammar (VisageNonterminals) +-- VisageNonterminal ------------------------------------------- +{- + alternatives: + alternative VNonterminal: + child nt : {NontermIdent} + child inh : {Attributes} + child syn : {Attributes} + child alts : VisageProductions +-} +data VisageNonterminal = VNonterminal (NontermIdent) (Attributes) (Attributes) (VisageProductions) +-- VisageNonterminals ------------------------------------------ +{- + alternatives: + alternative Cons: + child hd : VisageNonterminal + child tl : VisageNonterminals + alternative Nil: +-} +type VisageNonterminals = [VisageNonterminal] +-- VisageProduction -------------------------------------------- +{- + alternatives: + alternative VProduction: + child con : {ConstructorIdent} + child children : VisageChildren + child rules : VisageRules + child locrules : VisageRules +-} +data VisageProduction = VProduction (ConstructorIdent) (VisageChildren) (VisageRules) (VisageRules) +-- VisageProductions ------------------------------------------- +{- + alternatives: + alternative Cons: + child hd : VisageProduction + child tl : VisageProductions + alternative Nil: +-} +type VisageProductions = [VisageProduction] +-- VisageRule -------------------------------------------------- +{- + alternatives: + alternative VRule: + child fieldattrs : {[(Identifier,Identifier)]} + child attr : {Identifier} + child pat : {VisagePattern} + child rhs : {Expression} + child owrt : {Bool} +-} +data VisageRule = VRule ([(Identifier,Identifier)]) (Identifier) (VisagePattern) (Expression) (Bool) +-- VisageRules ------------------------------------------------- +{- + alternatives: + alternative Cons: + child hd : VisageRule + child tl : VisageRules + alternative Nil: +-} +type VisageRules = [VisageRule] diff --git a/src/ATermAbstractSyntax.hs b/src/ATermAbstractSyntax.hs new file mode 100644 --- /dev/null +++ b/src/ATermAbstractSyntax.hs @@ -0,0 +1,23 @@ +{----------------------------------------------------------------------------- + + Haskell ATerm Library + + Joost Visser + CWI, Amsterdam + + This module is part of the ATerm library for Haskell. It defines the + abstract syntax of ATerms as a Haskell datatype. + +------------------------------------------------------------------------------} + +module ATermAbstractSyntax where + +-- Abstract syntax ----------------------------------------------------------- + +data ATerm = AAppl String [ATerm] + | AList [ATerm] + | AInt Integer + | AString String + deriving (Read,Show,Eq,Ord) + +------------------------------------------------------------------------------ diff --git a/src/ATermWrite.hs b/src/ATermWrite.hs new file mode 100644 --- /dev/null +++ b/src/ATermWrite.hs @@ -0,0 +1,24 @@ +module ATermWrite where + +import ATermAbstractSyntax + +writeATerm t = writeAT 0 t + +writeAT :: Int -> ATerm -> String +writeAT n (AAppl c ts) = (if (n > 0) then "\n" else "") + ++ replicate n ' ' + ++ writeATermAux c (map (writeAT (n+2)) ts) +writeAT n (AList ts) = bracket (commaSep (map (writeAT n) ts)) +writeAT n (AInt i) = show i +writeAT n (AString s) = quote s + +writeATermAux c [] = c++(parenthesise "") +writeATermAux c ts = c++(parenthesise (commaSep ts)) + +sepBy sep (x:y:ys) = x:sep:sepBy sep (y:ys) +sepBy sep ys = ys + +commaSep strs = concat (sepBy "," strs) +bracket str = "["++str++"]" +parenthesise str = "("++str++")" +quote str = "\""++str++"\"" diff --git a/src/Ag.hs b/src/Ag.hs --- a/src/Ag.hs +++ b/src/Ag.hs @@ -6,7 +6,8 @@ import Monad (zipWithM_) import Data.Maybe -import qualified Data.Map as Map (elems, partitionWithKey, unionWith) +import qualified Data.Set as Set +import qualified Data.Map as Map import qualified UU.DData.Seq as Seq ((<>),toList) import Pretty @@ -21,15 +22,18 @@ import qualified GenerateCode as Pass4 (sem_CGrammar, wrap_CGrammar, Syn_CGrammar(..), Inh_CGrammar(..)) import qualified PrintCode as Pass5 (sem_Program, wrap_Program, Syn_Program (..), Inh_Program (..)) import qualified PrintErrorMessages as PrErr (sem_Errors , wrap_Errors , Syn_Errors (..), Inh_Errors (..), isError) +import qualified TfmToVisage as PassV (sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) import qualified AbstractSyntaxDump as GrammarDump (sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) import qualified CodeSyntaxDump as CGrammarDump (sem_CGrammar, wrap_CGrammar, Syn_CGrammar (..), Inh_CGrammar (..)) +import qualified Visage as VisageDump (sem_VisageGrammar, wrap_VisageGrammar, Syn_VisageGrammar(..), Inh_VisageGrammar(..)) import Options import Version (banner) import Parser (parseAG, depsAG) import ErrorMessages (Error(ParserError), Errors) -import CommonTypes (Blocks) +import CommonTypes +import ATermWrite main :: IO () @@ -52,14 +56,17 @@ compile :: Options -> String -> String -> IO () compile flags input output = do (output0,parseErrors) <- parseAG (searchPath flags) (inputFile input) + irrefutableMap <- readIrrefutableMap flags let output1 = Pass1.wrap_AG (Pass1.sem_AG output0 ) Pass1.Inh_AG {Pass1.options_Inh_AG = flags} flags' = Pass1.pragmas_Syn_AG output1 $ flags grammar1 = Pass1.output_Syn_AG output1 - output1a = Pass1a.wrap_Grammar (Pass1a.sem_Grammar grammar1 ) Pass1a.Inh_Grammar {Pass1a.options_Inh_Grammar = flags'} + output1a = Pass1a.wrap_Grammar (Pass1a.sem_Grammar grammar1 ) Pass1a.Inh_Grammar {Pass1a.options_Inh_Grammar = flags', Pass1a.forcedIrrefutables_Inh_Grammar = irrefutableMap } grammar1a =Pass1a.output_Syn_Grammar output1a output2 = Pass2.wrap_Grammar (Pass2.sem_Grammar grammar1a ) Pass2.Inh_Grammar {Pass2.options_Inh_Grammar = flags'} grammar2 = Pass2.output_Syn_Grammar output2 + outputV = PassV.wrap_Grammar (PassV.sem_Grammar grammar2 ) PassV.Inh_Grammar {} + grammarV = PassV.visage_Syn_Grammar outputV output3 = Pass3.wrap_Grammar (Pass3.sem_Grammar grammar2 ) Pass3.Inh_Grammar {Pass3.options_Inh_Grammar = flags'} grammar3 = Pass3.output_Syn_Grammar output3 output4 = Pass4.wrap_CGrammar (Pass4.sem_CGrammar(Pass3.output_Syn_Grammar output3)) Pass4.Inh_CGrammar {Pass4.options_Inh_CGrammar = flags'} @@ -69,6 +76,9 @@ dump1 = GrammarDump.wrap_Grammar (GrammarDump.sem_Grammar grammar1 ) GrammarDump.Inh_Grammar dump2 = GrammarDump.wrap_Grammar (GrammarDump.sem_Grammar grammar2 ) GrammarDump.Inh_Grammar dump3 = CGrammarDump.wrap_CGrammar (CGrammarDump.sem_CGrammar grammar3 ) CGrammarDump.Inh_CGrammar + + outputVisage = VisageDump.wrap_VisageGrammar (VisageDump.sem_VisageGrammar grammarV) VisageDump.Inh_VisageGrammar + aterm = VisageDump.aterm_Syn_VisageGrammar outputVisage parseErrorList = map message2error parseErrors errorList = parseErrorList @@ -79,12 +89,12 @@ Seq.<> Pass4.errors_Syn_CGrammar output4 ) - fatalErrorList = filter PrErr.isError errorList + fatalErrorList = filter (PrErr.isError flags') errorList allErrors = if null parseErrors then if wignore flags' then fatalErrorList - else errorsToFront errorList + else errorsToFront flags' errorList else take 1 parseErrorList -- the other 1000 or so parse errors are usually not that informative @@ -120,10 +130,10 @@ mainName = stripPath $ defaultModuleName input mainFile = defaultModuleName input - nrOfErrorsToReport = length $ filter PrErr.isError errorsToReport - nrOfWarningsToReport = length $ filter (not.PrErr.isError) errorsToReport - totalNrOfErrors = length $ filter PrErr.isError allErrors - totalNrOfWarnings = length $ filter (not.PrErr.isError) allErrors + nrOfErrorsToReport = length $ filter (PrErr.isError flags') errorsToReport + nrOfWarningsToReport = length $ filter (not.(PrErr.isError flags')) errorsToReport + totalNrOfErrors = length $ filter (PrErr.isError flags') allErrors + totalNrOfWarnings = length $ filter (not.(PrErr.isError flags')) allErrors additionalErrors = totalNrOfErrors - nrOfErrorsToReport additionalWarnings = totalNrOfWarnings - nrOfWarningsToReport pluralS n = if n == 1 then "" else "s" @@ -141,12 +151,22 @@ if not (null fatalErrorList) then exitFailure - else if sepSemMods flags' + else + do if genvisage flags' + then writeFile (outputfile++".visage") (writeATerm aterm) + else return () + + if genAttributeList flags' + then writeAttributeList (outputfile++".attrs") (Pass1a.allAttributes_Syn_Grammar output1a) + else return () + + if sepSemMods flags' then do -- alternative module gen Pass5.genIO_Syn_Program output5 if not (null errorsToStopOn) then exitFailure else return () else do -- conventional module gen let doc = vlist [ pp optionsLine + , pp pragmaBlocksTxt , pp $ take 70 ("-- UUAGC " ++ drop 50 banner ++ " (" ++ input) ++ ")" , pp $ if isNothing $ Pass1.moduleDecl_Syn_AG output1 then moduleHeader flags' mainName @@ -191,8 +211,8 @@ Other ms -> ms -errorsToFront :: [Error] -> [Error] -errorsToFront mesgs = filter PrErr.isError mesgs ++ filter (not.PrErr.isError) mesgs +errorsToFront :: Options -> [Error] -> [Error] +errorsToFront flags mesgs = filter (PrErr.isError flags) mesgs ++ filter (not.(PrErr.isError flags)) mesgs moduleHeader :: Options -> String -> String @@ -258,4 +278,21 @@ combine :: ([a],[b]) -> ([a], [b]) -> ([a], [b]) combine (fs, mesgs) (fsr, mesgsr) = (fs ++ fsr, mesgs ++ mesgsr) + + +writeAttributeList :: String -> AttrMap -> IO () +writeAttributeList file mp + = writeFile file s + where + s = show $ map (\(x,y) -> (show x, y)) $ Map.toList $ Map.map (map (\(x,y) -> (show x, y)) . Map.toList . Map.map (map (\(x,y) -> (show x, show y)) . Set.toList)) $ mp + +readIrrefutableMap :: Options -> IO AttrMap +readIrrefutableMap flags + = case forceIrrefutables flags of + Just file -> do s <- readFile file + seq (length s) (return ()) + let lists :: [(String,[(String,[(String, String)])])] + lists = read s + return $ Map.fromList [ (identifier n, Map.fromList [(identifier c, Set.fromList [ (identifier fld, identifier attr) | (fld,attr) <- ss ]) | (c,ss) <- cs ]) | (n,cs) <- lists ] + Nothing -> return Map.empty diff --git a/src/CommonTypes.hs b/src/CommonTypes.hs --- a/src/CommonTypes.hs +++ b/src/CommonTypes.hs @@ -1,6 +1,5 @@ module CommonTypes where ---import UU.Pretty (PP,text,pp) import Pretty import UU.Scanner.Position(Pos,noPos) import qualified Data.Map as Map @@ -26,7 +25,7 @@ pp = text . getName data Type = Haskell String - | NT Name + | NT Identifier [String] data ComplexType = List Type | Tuple [(Identifier, Type)] @@ -38,30 +37,27 @@ show (Maybe t ) = "Maybe " ++ show t instance Show Type where - show (Haskell t) = t - show (NT nt ) = getName nt - -instance Eq Type where - NT x == NT y = x == y - _ == _ = False - -type Attributes = Map Name Type -type TypeSyns = [(Nonterminal,ComplexType)] + show = typeToHaskellString Nothing [] -type AttrNames = [(Name,Type,(String,String,String))] -type UseMap = Map Nonterminal (Map Name (String,String,String)) -type PragmaMap = Map Nonterminal (Map Constructor (Set Name)) -type Fields = [(Name,Type)] -type Derivings = Map Nonterminal (Set Name) +type Attributes = Map Identifier Type +type TypeSyns = [(NontermIdent,ComplexType)] +type ParamMap = Map NontermIdent [Identifier] +type AttrNames = [(Identifier,Type,(String,String,String))] +type UseMap = Map NontermIdent (Map Identifier (String,String,String)) +type PragmaMap = Map NontermIdent (Map ConstructorIdent (Set Identifier)) +type AttrMap = Map NontermIdent (Map ConstructorIdent (Set (Identifier,Identifier))) +type Fields = [(Identifier,Type)] +type Derivings = Map NontermIdent (Set Identifier) +type ClassContext = [(Identifier, [String])] +type ContextMap = Map NontermIdent ClassContext type Strings = [String] -type Name = Identifier -type Nonterminal = Name -type Constructor = Name -type AttrOrderMap = Map Nonterminal (Map Constructor (Set Dependency)) +type NontermIdent = Identifier +type ConstructorIdent = Identifier +type AttrOrderMap = Map NontermIdent (Map ConstructorIdent (Set Dependency)) data Dependency = Dependency (Identifier,Identifier) (Identifier,Identifier) deriving (Eq,Ord,Show) -type AttrEnv = ( [Name] - , [(Name,Name)] +type AttrEnv = ( [Identifier] + , [(Identifier,Identifier)] ) identifier x = Ident x noPos @@ -75,23 +71,23 @@ _FIRST = identifier "first" _LAST = identifier "last" -sdtype :: Nonterminal -> String +sdtype :: NontermIdent -> String sdtype nt = "T_"++getName nt -cataname :: String -> Name -> String +cataname :: String -> Identifier -> String cataname pre name = pre++getName name -conname :: Bool -> Nonterminal -> Constructor -> String +conname :: Bool -> NontermIdent -> ConstructorIdent -> String conname rename nt con | rename = getName nt ++ "_" ++ getName con | otherwise = getName con -semname :: String -> Nonterminal -> Constructor -> String +semname :: String -> NontermIdent -> ConstructorIdent -> String semname pre nt con = pre ++ (getName nt ++ "_" ++ getName con) -lhsname :: Bool -> Name -> String +lhsname :: Bool -> Identifier -> String lhsname isIn = attrname isIn _LHS -attrname :: Bool -> Name -> Name -> String +attrname :: Bool -> Identifier -> Identifier -> String attrname isIn field attr | field == _LOC = locname attr | field == _INST = instname attr | field == _INST' = inst'name attr @@ -105,25 +101,47 @@ inst'name v = getName v ++ "_" fieldname v = getName v++"_" -typeToString :: Nonterminal -> Type -> String -typeToString _ (Haskell t) = t -typeToString nt (NT t ) | t == _SELF = getName nt - | otherwise = getName t +typeToAGString :: Type -> String +typeToAGString tp + = case tp of + Haskell t -> t + NT nt tps -> formatNonterminalToHaskell (getName nt) (map (\s -> "{" ++ s ++ "}") tps) +typeToHaskellString :: Maybe NontermIdent -> [String] -> Type -> String +typeToHaskellString mbNt params tp + = case tp of + Haskell t -> t + NT nt tps | nt == _SELF -> formatNonterminalToHaskell (maybe "Unknown" getName mbNt) params + | otherwise -> formatNonterminalToHaskell (getName nt) tps + +formatNonterminalToHaskell :: String -> [String] -> String +formatNonterminalToHaskell nt tps + = unwords (nt:tps) + ind :: String -> String ind s = replicate 3 ' ' ++ s -_NOCASE :: Name +_NOCASE :: Identifier _NOCASE = identifier "nocase" -hasPragma :: PragmaMap -> Nonterminal -> Constructor -> Name -> Bool +hasPragma :: PragmaMap -> NontermIdent -> ConstructorIdent -> Identifier -> Bool hasPragma mp nt con nm = nm `Set.member` Map.findWithDefault Set.empty con (Map.findWithDefault Map.empty nt mp) isNonterminal :: Type -> Bool -isNonterminal (NT _) = True -isNonterminal _ = False +isNonterminal (NT _ _) = True +isNonterminal _ = False -extractNonterminal :: Type -> Nonterminal -extractNonterminal (NT n) = n +isSELFNonterminal :: Type -> Bool +isSELFNonterminal (NT nt _) | nt == _SELF = True +isSELFNonterminal _ = False + +extractNonterminal :: Type -> NontermIdent +extractNonterminal (NT n _) = n + +nontermArgs :: Type -> [String] +nontermArgs tp + = case tp of + NT _ args -> args + _ -> [] diff --git a/src/DepTypes.hs b/src/DepTypes.hs --- a/src/DepTypes.hs +++ b/src/DepTypes.hs @@ -21,15 +21,15 @@ -- kan helaas niet met named fields, want dat levert een conflict op in de uniekheid vd naamgeving. -- ERROR "CommonTypes.hs" (line 44): Repeated definition for selector "nt" -data Vertex = Local Name Name Name -- lhs nt, constructor, attribute - | LHSInh Name Name Name -- lhs nt, constructor, attribute - | LHSSyn Name Name Name -- lhs nt, constructor, attribute - | ShRHSInh Name Name Name Name -- lhs nt, constructor, field, attribute !!rhs nt not known, equal to RHSInh!! - | ShRHSSyn Name Name Name Name -- lhs nt, constructor, field, attribute !!rhs nt not known, equal to RHSSyn!! - | RHSInh Name Name Name Name Name -- rhs nt, lhs nt, constructor, field, attribute - | RHSSyn Name Name Name Name Name -- rhs nt, lhs nt, constructor, field, attribute - | NTInh Name Name -- nt, attribute - | NTSyn Name Name -- nt, attribute +data Vertex = Local Identifier Identifier Identifier -- lhs nt, constructor, attribute + | LHSInh Identifier Identifier Identifier -- lhs nt, constructor, attribute + | LHSSyn Identifier Identifier Identifier -- lhs nt, constructor, attribute + | ShRHSInh Identifier Identifier Identifier Identifier -- lhs nt, constructor, field, attribute !!rhs nt not known, equal to RHSInh!! + | ShRHSSyn Identifier Identifier Identifier Identifier -- lhs nt, constructor, field, attribute !!rhs nt not known, equal to RHSSyn!! + | RHSInh Identifier Identifier Identifier Identifier Identifier -- rhs nt, lhs nt, constructor, field, attribute + | RHSSyn Identifier Identifier Identifier Identifier Identifier -- rhs nt, lhs nt, constructor, field, attribute + | NTInh Identifier Identifier -- nt, attribute + | NTSyn Identifier Identifier -- nt, attribute instance Eq Vertex where Local lhs1 con1 attr1 == Local lhs2 con2 attr2 = lhs1==lhs2 && con1==con2 && attr1==attr2 @@ -86,18 +86,18 @@ type UseStream = (Vertex,Stream) type Stream = [Result] type Result = ([UsedAttr],[UsedAttr]) -data UsedAttr = Loc Name Name Trace -- field name and attribute name - | Glo Name Trace -- attribute name +data UsedAttr = Loc Identifier Identifier Trace -- field name and attribute name + | Glo Identifier Trace -- attribute name -- lhs en rhs slaan op de lhs en rhs van een attribute equation en niet van de productie!! data TraceElem = TE { lineNr :: Int - , nt :: Nonterminal - , prod :: Name - , lhsNt :: Nonterminal - , lhsFld :: Name - , lhsAttr :: Name - , rhsFld :: Name - , rhsAttr :: Name } deriving Show + , nt :: NontermIdent + , prod :: Identifier + , lhsNt :: NontermIdent + , lhsFld :: Identifier + , lhsAttr :: Identifier + , rhsFld :: Identifier + , rhsAttr :: Identifier } deriving Show type Trace = [TraceElem] @@ -105,7 +105,7 @@ getTrace (Loc _ _ trace) = trace getTrace (Glo _ trace) = trace -toPair :: UsedAttr -> (Name,Trace) +toPair :: UsedAttr -> (Identifier,Trace) toPair (Loc _ attr trace) = (attr,trace) toPair (Glo attr trace) = (attr,trace) diff --git a/src/GrammarInfo.hs b/src/GrammarInfo.hs --- a/src/GrammarInfo.hs +++ b/src/GrammarInfo.hs @@ -15,8 +15,8 @@ , attrTable :: Table NTAttr , ruleTable :: Table CRule , lmh :: [LMH] - , prods :: [(Nonterminal,[Constructor])] - , wraps :: Set Nonterminal + , nonts :: [(NontermIdent,[ConstructorIdent])] + , wraps :: Set NontermIdent } deriving Show @@ -25,8 +25,8 @@ = "CRule " ++ show name ++ " nt: " ++ show nt ++ " con: " ++ show con ++ " field: " ++ show field ++ " childnt: " ++ show childnt ++ " rhs: " ++ concat rhs ++ " uses: " ++ show [ attrname True fld nm | (fld,nm) <- Set.toList uses ] -type CInterfaceMap = Map Nonterminal CInterface -type CVisitsMap = Map Nonterminal (Map Constructor CVisits) +type CInterfaceMap = Map NontermIdent CInterface +type CVisitsMap = Map NontermIdent (Map ConstructorIdent CVisits) data CycleStatus = CycleFree CInterfaceMap CVisitsMap @@ -39,7 +39,7 @@ showsSegment (CSegment inh syn) = let syn' = map toString (Map.toList syn) inh' = map toString (Map.toList inh) - toString (a,t) = (getName a, case t of (NT nt) -> getName nt; Haskell t -> t) + toString (a,t) = (getName a, case t of (NT nt tps) -> getName nt ++ " " ++ unwords tps; Haskell t -> t) chnn = inh' `intersect` syn' inhn = inh' \\ chnn synn = syn' \\ chnn diff --git a/src/HsTokenScanner.hs b/src/HsTokenScanner.hs --- a/src/HsTokenScanner.hs +++ b/src/HsTokenScanner.hs @@ -48,8 +48,8 @@ ('.':r:rs) | isIdStart r -> let (at,p3,rest2) = scanIdent (advc 2 p2) rs attr = r : at - in AGField (Ident field p) (Ident attr p) p : doScan p3 rest2 - _ -> AGLocal (Ident field p) p : doScan p2 rest + in AGField (Ident field p) (Ident attr p) p Nothing : doScan p3 rest2 + _ -> AGLocal (Ident field p) p Nothing : doScan p2 rest doScan p ('-':'-':s) = doScan p (dropWhile (/= '\n') s) doScan p ('{':'-':s) = advc' 2 p (lexNest doScan) s -- } diff --git a/src/Options.hs b/src/Options.hs --- a/src/Options.hs +++ b/src/Options.hs @@ -44,10 +44,14 @@ , Option [] ["dumpgrammar"] (NoArg dumpgrammarOpt) "Dump internal grammar representation (in generated code)" , Option [] ["dumpcgrammar"] (NoArg dumpcgrammarOpt) "Dump internal cgrammar representation (in generated code)" , Option [] ["gentraces"] (NoArg genTracesOpt) "Generate trace expressions (in generated code)" + , Option [] ["genusetraces"] (NoArg genUseTracesOpt) "Generate trace expressions at attribute use sites (in generated code)" , Option [] ["gencostcentres"] (NoArg genCostCentresOpt) "Generate cost centre pragmas (in generated code)" , Option [] ["genlinepragmas"] (NoArg genLinePragmasOpt) "Generate GHC LINE pragmas (in generated code)" , Option [] ["sepsemmods"] (NoArg sepSemModsOpt) "Generate separate modules for semantic functions (in generated code)" , Option ['M'] ["genfiledeps"] (NoArg genFileDepsOpt) "Generate a list of dependencies on the input AG files" + , Option [] ["genvisage"] (NoArg genVisageOpt) "Generate output for the AG visualizer Visage" + , Option [] ["genattrlist"] (NoArg genAttrListOpt) "Generate a list of all explicitly defined attributes (outside irrefutable patterns)" + , Option [] ["forceirrefutable"] (OptArg forceIrrefutableOpt "file") "Force a set of explicitly defined attributes to be irrefutable, specify file containing the attribute set" ] allc = "dcfsprm" @@ -90,10 +94,14 @@ , dumpgrammar :: Bool , dumpcgrammar :: Bool , genTraces :: Bool + , genUseTraces :: Bool , genCostCentres :: Bool , sepSemMods :: Bool , genFileDeps :: Bool , genLinePragmas :: Bool + , genvisage :: Bool + , genAttributeList :: Bool + , forceIrrefutables :: Maybe String } deriving Show noOptions = Options { moduleName = NoName , dataTypes = False @@ -133,10 +141,14 @@ , dumpgrammar = False , dumpcgrammar = False , genTraces = False + , genUseTraces = False , genCostCentres = False , sepSemMods = False , genFileDeps = False , genLinePragmas = False + , genvisage = False + , genAttributeList = False + , forceIrrefutables = Nothing } @@ -176,10 +188,14 @@ dumpgrammarOpt opts = opts{dumpgrammar = True} dumpcgrammarOpt opts = opts{dumpcgrammar = True} genTracesOpt opts = opts{genTraces = True} +genUseTracesOpt opts = opts{genUseTraces = True} genCostCentresOpt opts = opts{genCostCentres = True} sepSemModsOpt opts = opts{sepSemMods = True} genFileDepsOpt opts = opts{genFileDeps = True} genLinePragmasOpt opts = opts{genLinePragmas = True} +genVisageOpt opts = opts{genvisage = True } +genAttrListOpt opts = opts { genAttributeList = True } +forceIrrefutableOpt mbNm opts = opts { forceIrrefutables = mbNm } outputOpt file opts = opts{outputFiles = file : outputFiles opts} searchPathOpt path opts = opts{searchPath = extract path ++ searchPath opts} diff --git a/src/Parser.hs b/src/Parser.hs --- a/src/Parser.hs +++ b/src/Parser.hs @@ -19,7 +19,8 @@ import UU.Scanner.GenTokenParser import UU.Scanner.Position import UU.Scanner.TokenShow() -import System.Directory +import System.Directory +import HsTokenScanner type AGParser = AnaParser Input Pair Token Pos @@ -129,7 +130,7 @@ <|> All <$ pStar <|> pParens set0 -pNames :: AGParser [Name] +pNames :: AGParser [Identifier] pNames = pList1 pIdentifier pAG :: AGParser AG @@ -138,27 +139,33 @@ pElems :: AGParser Elems pElems = pList_ng pElem -pComplexType = List <$> pBracks pType +pComplexType = List <$> pBracks pTypeEncapsulated <|> Maybe <$ pMAYBE <*> pType <|> tuple <$> pParens (pListSep pComma field) - where field = (,) <$> ((Just <$> pIdentifier <* pColon) `opt` Nothing) <*> pType + where field = (,) <$> ((Just <$> pIdentifier <* pColon) `opt` Nothing) <*> pTypeEncapsulated tuple xs = Tuple [(fromMaybe (Ident ("x"++show n) noPos) f, t) | (n,(f,t)) <- zip [1..] xs ] pElem :: AGParser Elem -pElem = Data <$> pDATA - <*> pNontSet +pElem = Data <$> pDATA + <*> pOptClassContext + <*> pNontSet + <*> pList pIdentifier <*> pOptAttrs <*> pAlts <*> pSucceed False - <|> Attr <$> pATTR + <|> Attr <$> pATTR + <*> pOptClassContext <*> pNontSet <*> pAttrs - <|> Type <$> pTYPE - <*> pIdentifierU + <|> Type <$> pTYPE + <*> pOptClassContext + <*> pIdentifierU + <*> pList pIdentifier <* pEquals <*> pComplexType - <|> Sem <$> pSEM + <|> Sem <$> pSEM + <*> pOptClassContext <*> pNontSet <*> pOptAttrs <*> pSemAlts @@ -185,11 +192,21 @@ <|> codeBlock <$> (pIdentifier <|> pSucceed (Ident "" noPos)) <*> pCodeBlock "a statement" where codeBlock nm (txt,pos) = Txt pos nm (lines txt) + -- Insertion is expensive for pCodeBlock in order to prevent infinite inserts. pCodeBlock :: AGParser (String,Pos) pCodeBlock = pCostValToken 90 TkTextln "" "a code block" +pOptClassContext :: AGParser ClassContext +pOptClassContext + = pClassContext <* pDoubleArrow + <|> pSucceed [] + +pClassContext :: AGParser ClassContext +pClassContext + = pListSep pComma ((,) <$> pIdentifierU <*> pList pTypeHaskellAnyAsString) + pAttrs :: AGParser Attrs pAttrs = Attrs <$> pOBrackPos <*> (concat <$> pList pInhAttrNames "inherited attribute declarations") <* pBar <*> (concat <$> pList pAttrNames "chained attribute declarations" ) @@ -197,10 +214,29 @@ <* pCBrack pOptAttrs :: AGParser Attrs -pOptAttrs = pAttrs `opt` Attrs noPos [] [] [] +pOptAttrs = pAttrs `opt` Attrs noPos [] [] [] + +pTypeNt :: AGParser Type +pTypeNt + = (\nt -> NT nt []) <$> pIdentifierU + <|> pParens (NT <$> pIdentifierU <*> pList pTypeHaskellAnyAsString) + +pTypeHaskellAnyAsString :: AGParser String +pTypeHaskellAnyAsString + = getName <$> pIdentifier + <|> getName <$> pIdentifierU + <|> pCodescrap' "a type" + +-- if the type is within some kind of parentheses or brackets (then we allow lowercase identifiers as well) +pTypeEncapsulated :: AGParser Type +pTypeEncapsulated + = pParens pTypeEncapsulated + <|> NT <$> pIdentifierU <*> pList pTypeHaskellAnyAsString + <|> (Haskell . getName) <$> pIdentifier + <|> Haskell <$> pCodescrap' "a type" pType :: AGParser Type -pType = NT <$> pIdentifierU +pType = pTypeNt <|> Haskell <$> pCodescrap' "a type" @@ -231,7 +267,7 @@ pField :: AGParser Fields pField = (\nms tp -> map (flip (,) tp) nms) <$> pIdentifiers <* pColon <*> pType - <|> (\s -> [(Ident (mklower (getName s)) (getPos s) ,NT s)]) <$> pIdentifierU + <|> (\s -> [(Ident (mklower (getName s)) (getPos s) ,NT s [])]) <$> pIdentifierU mklower :: String -> String mklower (x:xs) = toLower x : xs @@ -256,8 +292,9 @@ pSemAlts :: AGParser SemAlts pSemAlts = pList pSemAlt "SEM alternatives" -pFieldIdentifier = pIdentifier - <|> Ident "lhs" <$> pLHS +pFieldIdentifier :: AGParser Identifier +pFieldIdentifier = pIdentifier + <|> Ident "lhs" <$> pLHS <|> Ident "loc" <$> pLOC <|> Ident "inst" <$> pINST @@ -266,16 +303,16 @@ <|> pLOC *> pList1 pLocDecl <|> pINST *> pList1 pInstDecl <|> pSEMPRAGMA *> pList1 (SemPragma <$> pNames) - <|> (\a b -> [AttrOrderBefore a b]) <$> pAttr <* pSmaller <*> pAttr + <|> (\a b -> [AttrOrderBefore a [b]]) <$> pList1 pAttr <* pSmaller <*> pAttr <|> (\pat owrt exp -> [Def (pat ()) exp owrt]) <$> pPattern (const <$> pAttr) <*> pAssign <*> pExpr pAttr = (,) <$> pFieldIdentifier <* pDot <*> pIdentifier -pAttrDef :: AGParser (Name -> SemDef) +pAttrDef :: AGParser (Identifier -> SemDef) pAttrDef = (\pat owrt exp fld -> Def (pat fld) exp owrt) <$ pDot <*> pattern <*> pAssign <*> pExpr where pattern = pPattern pVar - <|> (\a fld -> Alias fld a (Underscore noPos) []) <$> pIdentifier + <|> (\ir a fld -> ir $ Alias fld a (Underscore noPos) []) <$> ((Irrefutable <$ pTilde) `opt` id) <*> pIdentifier nl2sp :: Char -> Char @@ -292,36 +329,36 @@ pInstDecl :: AGParser SemDef pInstDecl = (\ident tp -> TypeDef ident tp) - <$ pDot <*> pIdentifier <* pColon <*> (NT <$> pIdentifierU) + <$ pDot <*> pIdentifier <* pColon <*> pTypeNt pSemDefs :: AGParser SemDefs pSemDefs = concat <$> pList_ng pSemDef "attribute rules" -pVar :: AGParser (Name -> (Name, Name)) +pVar :: AGParser (Identifier -> (Identifier, Identifier)) pVar = (\att fld -> (fld,att)) <$> pIdentifier pExpr :: AGParser Expression -pExpr = (\(str,pos) -> Expression pos str) <$> ( pCodescrapL ) "an expression" +pExpr = (\(str,pos) -> Expression pos (lexTokens pos str)) <$> pCodescrapL "an expression" pAssign :: AGParser Bool pAssign = False <$ pReserved "=" <|> True <$ pReserved ":=" -pAttrDefs :: AGParser (Name -> [SemDef]) +pAttrDefs :: AGParser (Identifier -> [SemDef]) pAttrDefs = (\fs field -> map ($ field) fs) <$> pList1 pAttrDef "attribute definitions" -pPattern :: AGParser (a -> (Name,Name)) -> AGParser (a -> Pattern) +pPattern :: AGParser (a -> (Identifier,Identifier)) -> AGParser (a -> Pattern) pPattern pvar = pPattern2 where pPattern0 = (\i pats a -> Constr i (map ($ a) pats)) <$> pIdentifierU <*> pList pPattern1 <|> pPattern1 "a pattern" - pPattern1 = pvariable + pPattern1 = pvariable <|> pPattern2 - pvariable = (\var pat a -> case var a of (fld,att) -> Alias fld att (pat a) []) - <$> pvar <*> ((pAt *> pPattern1) `opt` const (Underscore noPos)) + pvariable = (\ir var pat a -> case var a of (fld,att) -> ir $ Alias fld att (pat a) []) + <$> ((Irrefutable <$ pTilde) `opt` id) <*> pvar <*> ((pAt *> pPattern1) `opt` const (Underscore noPos)) pPattern2 = (mkTuple <$> pOParenPos <*> pListSep pComma pPattern0 <* pCParen ) - <|> (const . Underscore) <$> pUScore "a pattern" + <|> (const . Underscore) <$> pUScore "a pattern" where mkTuple _ [x] a = x a mkTuple p xs a = Product p (map ($ a) xs) @@ -333,10 +370,10 @@ pCodescrap :: AGParser (String,Pos) pCodescrap = pCodeBlock -pSEM, pATTR, pDATA, pUSE, pLOC,pINCLUDE, pTYPE, pEquals, pColonEquals, - pBar, pColon, pLHS,pINST,pSET,pDERIVING,pMinus,pIntersect,pArrow, - pDot, pUScore, pEXT,pAt,pStar, pSmaller, pWRAPPER, pMAYBE, pMODULE - :: AGParser Pos +pSEM, pATTR, pDATA, pUSE, pLOC,pINCLUDE, pTYPE, pEquals, pColonEquals, pTilde, + pBar, pColon, pLHS,pINST,pSET,pDERIVING,pMinus,pIntersect,pDoubleArrow,pArrow, + pDot, pUScore, pEXT,pAt,pStar, pSmaller, pWRAPPER, pPRAGMA, pMAYBE, pMODULE + :: AGParser Pos pSET = pCostReserved 90 "SET" "SET" pDERIVING = pCostReserved 90 "DERIVING" "DERIVING" pWRAPPER = pCostReserved 90 "WRAPPER" "WRAPPER" @@ -358,10 +395,12 @@ pUScore = pCostReserved 5 "_" "_" pColon = pCostReserved 5 ":" ":" pEquals = pCostReserved 5 "=" "=" -pColonEquals = pCostReserved 5 ":=" ":=" +pColonEquals = pCostReserved 5 ":=" ":=" +pTilde = pCostReserved 5 "~" "~" pBar = pCostReserved 5 "|" "|" pIntersect = pCostReserved 5 "/\\" "/\\" -pMinus = pCostReserved 5 "-" "-" +pMinus = pCostReserved 5 "-" "-" +pDoubleArrow = pCostReserved 5 "=>" "=>" pArrow = pCostReserved 5 "->" "->" pStar = pCostReserved 5 "*" "*" pSmaller = pCostReserved 5 "<" "<" diff --git a/src/Scanner.hs b/src/Scanner.hs --- a/src/Scanner.hs +++ b/src/Scanner.hs @@ -51,6 +51,7 @@ scan' ('@' :rs) = (reserved "@" p, advc 1 p, rs) scan' (',' :rs) = (reserved "," p, advc 1 p, rs) scan' ('_' :rs) = (reserved "_" p, advc 1 p, rs) + scan' ('~' :rs) = (reserved "~" p, advc 1 p, rs) scan' ('<' :rs) = (reserved "<" p, advc 1 p, rs) scan' ('[' :rs) = (reserved "[" p, advc 1 p, rs) scan' (']' :rs) = (reserved "]" p, advc 1 p, rs) @@ -66,6 +67,7 @@ , advc (1+length str) p,rest) else (valueToken TkString str p, advc (2+length str) p, tail rest) + scan' ('=' : '>' : rs) = (reserved "=>" p, advc 2 p, rs) scan' ('=' :rs) = (reserved "=" p, advc 1 p, rs) scan' (':':'=':rs) = (reserved ":=" p, advc 2 p, rs) diff --git a/src/SequentialComputation.lhs b/src/SequentialComputation.lhs --- a/src/SequentialComputation.lhs +++ b/src/SequentialComputation.lhs @@ -212,7 +212,7 @@ = let interslist = reverse . makeInterface tds [] mkSegments = foldr (sem_Segments_Cons . uncurry sem_Segment_Segment) sem_Segments_Nil . interslist mkInter ((nt,cons),lmh) = sem_Interface_Interface nt cons (mkSegments lmh) - inters = foldr (sem_Interfaces_Cons . mkInter) sem_Interfaces_Nil (zip (prods info) (lmh info)) + inters = foldr (sem_Interfaces_Cons . mkInter) sem_Interfaces_Nil (zip (nonts info) (lmh info)) in sem_IRoot_IRoot inters \end{code} diff --git a/src/SequentialTypes.hs b/src/SequentialTypes.hs --- a/src/SequentialTypes.hs +++ b/src/SequentialTypes.hs @@ -30,9 +30,9 @@ type Table a = Array Vertex a -data ChildVisit = ChildVisit Name Name Int [Vertex] [Vertex] deriving (Eq,Show) -- field, rhs nt, visit nr., inh, syn -data NTAttr = NTAInh Nonterminal Name Type -- nt, attribute, type - | NTASyn Nonterminal Name Type -- nt, attribute, type +data ChildVisit = ChildVisit Identifier Identifier Int [Vertex] [Vertex] deriving (Eq,Show) -- field, rhs nt, visit nr., inh, syn +data NTAttr = NTAInh NontermIdent Identifier Type -- nt, attribute, type + | NTASyn NontermIdent Identifier Type -- nt, attribute, type deriving Show getNtaNameType (NTAInh nt name tp) = (name,tp) @@ -75,14 +75,14 @@ getNt cr = if isRhs cr then fromJust (getRhsNt cr) else getLhsNt cr in Just (at (getNt cr) (getAttr cr) (fromJust (getType cr))) -cRuleLhsInh :: Name -> Nonterminal -> Constructor -> Type -> CRule +cRuleLhsInh :: Identifier -> NontermIdent -> ConstructorIdent -> Type -> CRule cRuleLhsInh attr nt con tp = CRule attr True False nt con _LHS Nothing (Just tp) (error "cRuleLhsInh") [] Map.empty False "" Set.empty -cRuleTerminal :: Name -> Nonterminal -> Constructor -> Type -> CRule +cRuleTerminal :: Identifier -> NontermIdent -> ConstructorIdent -> Type -> CRule cRuleTerminal attr nt con tp = CRule attr True False nt con _LOC Nothing (Just tp) (error ("cRuleTerminal: " ++ show (attr, nt, con, tp))) [] Map.empty False "" Set.empty -cRuleRhsSyn :: Name -> Nonterminal -> Constructor -> Type -> Name -> Nonterminal -> CRule +cRuleRhsSyn :: Identifier -> NontermIdent -> ConstructorIdent -> Type -> Identifier -> NontermIdent -> CRule cRuleRhsSyn attr nt con tp field childnt = CRule attr True False nt con field (Just childnt) (Just tp) (error ("cRuleRhsSyn: " ++ show (attr, nt, con, tp, field))) [] Map.empty False "" Set.empty -defaultRule :: Name -> Nonterminal -> Constructor -> Name -> CRule +defaultRule :: Identifier -> NontermIdent -> ConstructorIdent -> Identifier -> CRule defaultRule attr nt con field = CRule attr (er 1) (er 2) nt con field (er 3) (er 4) (er 5) (er 6) (er 7) (er 8) (er 9) (er 10) where er i = error ("Default rule has no code " ++ show i) @@ -121,7 +121,7 @@ lhsshow (NTAInh field attr _) = lhsname True attr lhsshow (NTASyn field attr _) = lhsname False attr -rhsshow :: Name -> NTAttr -> String +rhsshow :: Identifier -> NTAttr -> String rhsshow field (NTAInh _ attr _) = attrname False field attr rhsshow field (NTASyn _ attr _) = attrname True field attr diff --git a/src/TokenDef.hs b/src/TokenDef.hs --- a/src/TokenDef.hs +++ b/src/TokenDef.hs @@ -7,6 +7,8 @@ import UU.Scanner.Position import UU.Parsing.MachineInterface(Symbol(..)) import Char(isPrint,ord) +import HsToken +import CommonTypes @@ -23,6 +25,20 @@ TkError -> 0 _ -> 5 + +tokensToStrings :: [HsToken] -> [(Pos,String)] +tokensToStrings + = map tokenToString + +tokenToString :: HsToken -> (Pos, String) +tokenToString tk + = case tk of + AGLocal var pos _ -> (pos, "@" ++ getName var) + AGField field attr pos _ -> (pos, "@" ++ getName field ++ "." ++ getName attr) + HsToken value pos -> (pos, value) + CharToken value pos -> (pos, show value) + StrToken value pos -> (pos, show value) + Err mesg pos -> (pos, " ***" ++ mesg ++ "*** ") showTokens :: [(Pos,String)] -> [String] showTokens [] = [] diff --git a/src/Version.hs b/src/Version.hs --- a/src/Version.hs +++ b/src/Version.hs @@ -1,4 +1,4 @@ module Version where banner :: String -banner = "Attribute Grammar compiler / HUT project. Version 0.9.5" +banner = "Attribute Grammar compiler / HUT project. Version 0.9.6" diff --git a/uuagc.cabal b/uuagc.cabal --- a/uuagc.cabal +++ b/uuagc.cabal @@ -1,7 +1,7 @@ cabal-version: >=1.2 build-type: Simple name: uuagc -version: 0.9.5 +version: 0.9.6 license: GPL license-file: LICENSE maintainer: Arie Middelkoop @@ -59,6 +59,12 @@ , PrintErrorMessages , SemHsTokens , Transform + , ATermWrite + , ATermAbstractSyntax + , TfmToVisage + , Visage + , VisageSyntax + , VisagePatterns extensions: TypeSynonymInstances, MultiParamTypeClasses hs-source-dirs: src, src-derived diff --git a/uuagc.cabal-for-ghc-6.6 b/uuagc.cabal-for-ghc-6.6 --- a/uuagc.cabal-for-ghc-6.6 +++ b/uuagc.cabal-for-ghc-6.6 @@ -1,5 +1,5 @@ name: uuagc -version: 0.9.5 +version: 0.9.6 license: GPL license-file: LICENSE maintainer: Arie Middelkoop @@ -43,5 +43,11 @@ , PrintErrorMessages , SemHsTokens , Transform + , ATermWrite + , ATermAbstractSyntax + , TfmToVisage + , Visage + , VisageSyntax + , VisagePatterns Extensions: TypeSynonymInstances, MultiParamTypeClasses Hs-Source-Dirs: src, src-derived