diff --git a/src-derived/KWOrder.hs b/src-derived/KWOrder.hs new file mode 100644 --- /dev/null +++ b/src-derived/KWOrder.hs @@ -0,0 +1,1469 @@ + + +-- UUAGC 0.9.38.1 (KWOrder.ag) +module KWOrder where +{-# LINE 6 "KWOrder.ag" #-} + +import AbstractSyntax +import HsToken +import Expression +import Patterns +import Options +import PPUtil +import Pretty +import Knuth1 +import KennedyWarren +import Maybe +import qualified Data.Set as Set +import qualified Data.Map as Map +{-# LINE 20 "../src-derived/KWOrder.hs" #-} + +{-# LINE 2 "./AbstractSyntax.ag" #-} + +-- AbstractSyntax.ag imports +import Data.Set(Set) +import Data.Map(Map) +import Patterns (Pattern(..),Patterns) +import Expression (Expression(..)) +import CommonTypes +{-# LINE 30 "../src-derived/KWOrder.hs" #-} + +{-# LINE 2 "./HsToken.ag" #-} + +import CommonTypes +import UU.Scanner.Position(Pos) +{-# LINE 36 "../src-derived/KWOrder.hs" #-} + +{-# LINE 2 "./Expression.ag" #-} + +import UU.Scanner.Position(Pos) +import HsToken +{-# LINE 42 "../src-derived/KWOrder.hs" #-} + +{-# LINE 2 "./Patterns.ag" #-} + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (ConstructorIdent,Identifier) +{-# LINE 49 "../src-derived/KWOrder.hs" #-} +-- Child ------------------------------------------------------- +{- + visit 0: + synthesized attributes: + edges : Set.Set Edge + nontnames : [(Identifier, Identifier)] + vertices : Set.Set Vertex + alternatives: + alternative Child: + child name : {Identifier} + child tp : {Type} + child inh : {Attributes} + child syn : {Attributes} + child virtual : {Maybe (Maybe Type)} + visit 0: + local vertex : _ + local synvertices : _ + local inhvertices : _ + local edgesout : _ + local edgesin : _ +-} +-- cata +sem_Child :: Child -> + T_Child +sem_Child (Child _name _tp _inh _syn _virtual ) = + (sem_Child_Child _name _tp _inh _syn _virtual ) +-- semantic domain +newtype T_Child = T_Child (( (Set.Set Edge),([(Identifier, Identifier)]),(Set.Set Vertex))) +data Inh_Child = Inh_Child {} +data Syn_Child = Syn_Child {edges_Syn_Child :: (Set.Set Edge),nontnames_Syn_Child :: ([(Identifier, Identifier)]),vertices_Syn_Child :: (Set.Set Vertex)} +wrap_Child :: T_Child -> + Inh_Child -> + Syn_Child +wrap_Child (T_Child sem ) (Inh_Child ) = + (let ( _lhsOedges,_lhsOnontnames,_lhsOvertices) = sem + in (Syn_Child _lhsOedges _lhsOnontnames _lhsOvertices )) +sem_Child_Child :: Identifier -> + Type -> + Attributes -> + Attributes -> + (Maybe (Maybe Type)) -> + T_Child +sem_Child_Child name_ tp_ inh_ syn_ virtual_ = + (T_Child (let _lhsOvertices :: (Set.Set Vertex) + _lhsOedges :: (Set.Set Edge) + _lhsOnontnames :: ([(Identifier, Identifier)]) + -- "KWOrder.ag"(line 76, column 12) + _vertex = + ({-# LINE 76 "KWOrder.ag" #-} + VChild name_ + {-# LINE 100 "KWOrder.hs" #-} + ) + -- "KWOrder.ag"(line 77, column 12) + _synvertices = + ({-# LINE 77 "KWOrder.ag" #-} + map (VAttr Syn name_) . Map.keys $ syn_ + {-# LINE 106 "KWOrder.hs" #-} + ) + -- "KWOrder.ag"(line 78, column 12) + _inhvertices = + ({-# LINE 78 "KWOrder.ag" #-} + map (VAttr Inh name_) . Map.keys $ inh_ + {-# LINE 112 "KWOrder.hs" #-} + ) + -- "KWOrder.ag"(line 79, column 12) + _lhsOvertices = + ({-# LINE 79 "KWOrder.ag" #-} + case tp_ of + NT _ _ -> Set.insert _vertex (Set.fromList $ _synvertices ++ _inhvertices ) + _ -> Set.empty + {-# LINE 120 "KWOrder.hs" #-} + ) + -- "KWOrder.ag"(line 104, column 12) + _edgesout = + ({-# LINE 104 "KWOrder.ag" #-} + [] + {-# LINE 126 "KWOrder.hs" #-} + ) + -- "KWOrder.ag"(line 105, column 12) + _edgesin = + ({-# LINE 105 "KWOrder.ag" #-} + map (flip (,) _vertex ) _synvertices + {-# LINE 132 "KWOrder.hs" #-} + ) + -- "KWOrder.ag"(line 106, column 12) + _lhsOedges = + ({-# LINE 106 "KWOrder.ag" #-} + Set.fromList $ _edgesout ++ _edgesin + {-# LINE 138 "KWOrder.hs" #-} + ) + -- "KWOrder.ag"(line 116, column 12) + _lhsOnontnames = + ({-# LINE 116 "KWOrder.ag" #-} + case tp_ of + NT nont _ -> [(name_, nont)] + _ -> [] + {-# LINE 146 "KWOrder.hs" #-} + ) + in ( _lhsOedges,_lhsOnontnames,_lhsOvertices)) ) +-- Children ---------------------------------------------------- +{- + visit 0: + synthesized attributes: + edges : Set.Set Edge + nontnames : [(Identifier, Identifier)] + vertices : Set.Set Vertex + 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 (( (Set.Set Edge),([(Identifier, Identifier)]),(Set.Set Vertex))) +data Inh_Children = Inh_Children {} +data Syn_Children = Syn_Children {edges_Syn_Children :: (Set.Set Edge),nontnames_Syn_Children :: ([(Identifier, Identifier)]),vertices_Syn_Children :: (Set.Set Vertex)} +wrap_Children :: T_Children -> + Inh_Children -> + Syn_Children +wrap_Children (T_Children sem ) (Inh_Children ) = + (let ( _lhsOedges,_lhsOnontnames,_lhsOvertices) = sem + in (Syn_Children _lhsOedges _lhsOnontnames _lhsOvertices )) +sem_Children_Cons :: T_Child -> + T_Children -> + T_Children +sem_Children_Cons (T_Child hd_ ) (T_Children tl_ ) = + (T_Children (let _lhsOedges :: (Set.Set Edge) + _lhsOnontnames :: ([(Identifier, Identifier)]) + _lhsOvertices :: (Set.Set Vertex) + _hdIedges :: (Set.Set Edge) + _hdInontnames :: ([(Identifier, Identifier)]) + _hdIvertices :: (Set.Set Vertex) + _tlIedges :: (Set.Set Edge) + _tlInontnames :: ([(Identifier, Identifier)]) + _tlIvertices :: (Set.Set Vertex) + -- use rule "KWOrder.ag"(line 94, column 33) + _lhsOedges = + ({-# LINE 94 "KWOrder.ag" #-} + _hdIedges `Set.union` _tlIedges + {-# LINE 194 "KWOrder.hs" #-} + ) + -- use rule "KWOrder.ag"(line 113, column 37) + _lhsOnontnames = + ({-# LINE 113 "KWOrder.ag" #-} + _hdInontnames ++ _tlInontnames + {-# LINE 200 "KWOrder.hs" #-} + ) + -- use rule "KWOrder.ag"(line 52, column 36) + _lhsOvertices = + ({-# LINE 52 "KWOrder.ag" #-} + _hdIvertices `Set.union` _tlIvertices + {-# LINE 206 "KWOrder.hs" #-} + ) + ( _hdIedges,_hdInontnames,_hdIvertices) = + hd_ + ( _tlIedges,_tlInontnames,_tlIvertices) = + tl_ + in ( _lhsOedges,_lhsOnontnames,_lhsOvertices)) ) +sem_Children_Nil :: T_Children +sem_Children_Nil = + (T_Children (let _lhsOedges :: (Set.Set Edge) + _lhsOnontnames :: ([(Identifier, Identifier)]) + _lhsOvertices :: (Set.Set Vertex) + -- use rule "KWOrder.ag"(line 94, column 33) + _lhsOedges = + ({-# LINE 94 "KWOrder.ag" #-} + Set.empty + {-# LINE 222 "KWOrder.hs" #-} + ) + -- use rule "KWOrder.ag"(line 113, column 37) + _lhsOnontnames = + ({-# LINE 113 "KWOrder.ag" #-} + [] + {-# LINE 228 "KWOrder.hs" #-} + ) + -- use rule "KWOrder.ag"(line 52, column 36) + _lhsOvertices = + ({-# LINE 52 "KWOrder.ag" #-} + Set.empty + {-# LINE 234 "KWOrder.hs" #-} + ) + in ( _lhsOedges,_lhsOnontnames,_lhsOvertices)) ) +-- Expression -------------------------------------------------- +{- + visit 0: + synthesized attribute: + vertices : Set.Set Vertex + 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 (( (Set.Set Vertex))) +data Inh_Expression = Inh_Expression {} +data Syn_Expression = Syn_Expression {vertices_Syn_Expression :: (Set.Set Vertex)} +wrap_Expression :: T_Expression -> + Inh_Expression -> + Syn_Expression +wrap_Expression (T_Expression sem ) (Inh_Expression ) = + (let ( _lhsOvertices) = sem + in (Syn_Expression _lhsOvertices )) +sem_Expression_Expression :: Pos -> + ([HsToken]) -> + T_Expression +sem_Expression_Expression pos_ tks_ = + (T_Expression (let _lhsOvertices :: (Set.Set Vertex) + -- "KWOrder.ag"(line 63, column 17) + _lhsOvertices = + ({-# LINE 63 "KWOrder.ag" #-} + Set.unions $ map (\tok -> vertices_Syn_HsToken + (wrap_HsToken (sem_HsToken tok) Inh_HsToken)) tks_ + {-# LINE 272 "KWOrder.hs" #-} + ) + in ( _lhsOvertices)) ) +-- Grammar ----------------------------------------------------- +{- + visit 0: + inherited attribute: + options : Options + synthesized attribute: + debugoutput : PP_Doc + 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} + child quantMap : {QuantMap} + child uniqueMap : {UniqueMap} + child augmentsMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} + child aroundsMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} + child mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression)))} +-} +-- cata +sem_Grammar :: Grammar -> + T_Grammar +sem_Grammar (Grammar _typeSyns _useMap _derivings _wrappers _nonts _pragmas _manualAttrOrderMap _paramMap _contextMap _quantMap _uniqueMap _augmentsMap _aroundsMap _mergeMap ) = + (sem_Grammar_Grammar _typeSyns _useMap _derivings _wrappers (sem_Nonterminals _nonts ) _pragmas _manualAttrOrderMap _paramMap _contextMap _quantMap _uniqueMap _augmentsMap _aroundsMap _mergeMap ) +-- semantic domain +newtype T_Grammar = T_Grammar (Options -> + ( PP_Doc)) +data Inh_Grammar = Inh_Grammar {options_Inh_Grammar :: Options} +data Syn_Grammar = Syn_Grammar {debugoutput_Syn_Grammar :: PP_Doc} +wrap_Grammar :: T_Grammar -> + Inh_Grammar -> + Syn_Grammar +wrap_Grammar (T_Grammar sem ) (Inh_Grammar _lhsIoptions ) = + (let ( _lhsOdebugoutput) = sem _lhsIoptions + in (Syn_Grammar _lhsOdebugoutput )) +sem_Grammar_Grammar :: TypeSyns -> + UseMap -> + Derivings -> + (Set NontermIdent) -> + T_Nonterminals -> + PragmaMap -> + AttrOrderMap -> + ParamMap -> + ContextMap -> + QuantMap -> + UniqueMap -> + (Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) -> + (Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) -> + (Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression)))) -> + T_Grammar +sem_Grammar_Grammar typeSyns_ useMap_ derivings_ wrappers_ (T_Nonterminals nonts_ ) pragmas_ manualAttrOrderMap_ paramMap_ contextMap_ quantMap_ uniqueMap_ augmentsMap_ aroundsMap_ mergeMap_ = + (T_Grammar (\ _lhsIoptions -> + (let _nontsOrulenumber :: Int + _lhsOdebugoutput :: PP_Doc + _nontsIdepinfo :: ([NontDependencyInformation]) + _nontsIrulenumber :: Int + -- "KWOrder.ag"(line 39, column 14) + _nontsOrulenumber = + ({-# LINE 39 "KWOrder.ag" #-} + 0 + {-# LINE 340 "KWOrder.hs" #-} + ) + -- "KWOrder.ag"(line 160, column 14) + _lhsOdebugoutput = + ({-# LINE 160 "KWOrder.ag" #-} + kennedyWarrenIO _nontsIdepinfo + {-# LINE 346 "KWOrder.hs" #-} + ) + ( _nontsIdepinfo,_nontsIrulenumber) = + nonts_ _nontsOrulenumber + in ( _lhsOdebugoutput))) ) +-- HsToken ----------------------------------------------------- +{- + visit 0: + synthesized attribute: + vertices : Set.Set Vertex + alternatives: + alternative AGField: + child field : {Identifier} + child attr : {Identifier} + child pos : {Pos} + child rdesc : {Maybe String} + alternative AGLocal: + child var : {Identifier} + child pos : {Pos} + child rdesc : {Maybe String} + 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 _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 (( (Set.Set Vertex))) +data Inh_HsToken = Inh_HsToken {} +data Syn_HsToken = Syn_HsToken {vertices_Syn_HsToken :: (Set.Set Vertex)} +wrap_HsToken :: T_HsToken -> + Inh_HsToken -> + Syn_HsToken +wrap_HsToken (T_HsToken sem ) (Inh_HsToken ) = + (let ( _lhsOvertices) = sem + in (Syn_HsToken _lhsOvertices )) +sem_HsToken_AGField :: Identifier -> + Identifier -> + Pos -> + (Maybe String) -> + T_HsToken +sem_HsToken_AGField field_ attr_ pos_ rdesc_ = + (T_HsToken (let _lhsOvertices :: (Set.Set Vertex) + -- "KWOrder.ag"(line 57, column 14) + _lhsOvertices = + ({-# LINE 57 "KWOrder.ag" #-} + Set.singleton $ VAttr (if field_ == _LHS then Inh + else if field_ == _LOC then Loc + else Syn) field_ attr_ + {-# LINE 417 "KWOrder.hs" #-} + ) + in ( _lhsOvertices)) ) +sem_HsToken_AGLocal :: Identifier -> + Pos -> + (Maybe String) -> + T_HsToken +sem_HsToken_AGLocal var_ pos_ rdesc_ = + (T_HsToken (let _lhsOvertices :: (Set.Set Vertex) + -- "KWOrder.ag"(line 56, column 14) + _lhsOvertices = + ({-# LINE 56 "KWOrder.ag" #-} + Set.singleton $ VAttr Loc _LOC var_ + {-# LINE 430 "KWOrder.hs" #-} + ) + in ( _lhsOvertices)) ) +sem_HsToken_CharToken :: String -> + Pos -> + T_HsToken +sem_HsToken_CharToken value_ pos_ = + (T_HsToken (let _lhsOvertices :: (Set.Set Vertex) + -- use rule "KWOrder.ag"(line 52, column 36) + _lhsOvertices = + ({-# LINE 52 "KWOrder.ag" #-} + Set.empty + {-# LINE 442 "KWOrder.hs" #-} + ) + in ( _lhsOvertices)) ) +sem_HsToken_Err :: String -> + Pos -> + T_HsToken +sem_HsToken_Err mesg_ pos_ = + (T_HsToken (let _lhsOvertices :: (Set.Set Vertex) + -- use rule "KWOrder.ag"(line 52, column 36) + _lhsOvertices = + ({-# LINE 52 "KWOrder.ag" #-} + Set.empty + {-# LINE 454 "KWOrder.hs" #-} + ) + in ( _lhsOvertices)) ) +sem_HsToken_HsToken :: String -> + Pos -> + T_HsToken +sem_HsToken_HsToken value_ pos_ = + (T_HsToken (let _lhsOvertices :: (Set.Set Vertex) + -- use rule "KWOrder.ag"(line 52, column 36) + _lhsOvertices = + ({-# LINE 52 "KWOrder.ag" #-} + Set.empty + {-# LINE 466 "KWOrder.hs" #-} + ) + in ( _lhsOvertices)) ) +sem_HsToken_StrToken :: String -> + Pos -> + T_HsToken +sem_HsToken_StrToken value_ pos_ = + (T_HsToken (let _lhsOvertices :: (Set.Set Vertex) + -- use rule "KWOrder.ag"(line 52, column 36) + _lhsOvertices = + ({-# LINE 52 "KWOrder.ag" #-} + Set.empty + {-# LINE 478 "KWOrder.hs" #-} + ) + in ( _lhsOvertices)) ) +-- HsTokens ---------------------------------------------------- +{- + 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 (( )) +data Inh_HsTokens = Inh_HsTokens {} +data Syn_HsTokens = Syn_HsTokens {} +wrap_HsTokens :: T_HsTokens -> + Inh_HsTokens -> + Syn_HsTokens +wrap_HsTokens (T_HsTokens sem ) (Inh_HsTokens ) = + (let ( ) = sem + in (Syn_HsTokens )) +sem_HsTokens_Cons :: T_HsToken -> + T_HsTokens -> + T_HsTokens +sem_HsTokens_Cons (T_HsToken hd_ ) (T_HsTokens tl_ ) = + (T_HsTokens (let _hdIvertices :: (Set.Set Vertex) + ( _hdIvertices) = + hd_ + in ( )) ) +sem_HsTokens_Nil :: T_HsTokens +sem_HsTokens_Nil = + (T_HsTokens (let + in ( )) ) +-- HsTokensRoot ------------------------------------------------ +{- + 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 (( )) +data Inh_HsTokensRoot = Inh_HsTokensRoot {} +data Syn_HsTokensRoot = Syn_HsTokensRoot {} +wrap_HsTokensRoot :: T_HsTokensRoot -> + Inh_HsTokensRoot -> + Syn_HsTokensRoot +wrap_HsTokensRoot (T_HsTokensRoot sem ) (Inh_HsTokensRoot ) = + (let ( ) = sem + in (Syn_HsTokensRoot )) +sem_HsTokensRoot_HsTokensRoot :: T_HsTokens -> + T_HsTokensRoot +sem_HsTokensRoot_HsTokensRoot (T_HsTokens tokens_ ) = + (T_HsTokensRoot (let + in ( )) ) +-- Nonterminal ------------------------------------------------- +{- + visit 0: + chained attribute: + rulenumber : Int + synthesized attribute: + depinfo : NontDependencyInformation + alternatives: + alternative Nonterminal: + child nt : {NontermIdent} + child params : {[Identifier]} + child inh : {Attributes} + child syn : {Attributes} + child prods : Productions + visit 0: + local synvertices : _ + local inhvertices : _ + local vertices : _ + local nontgraph : _ +-} +-- 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 -> + ( NontDependencyInformation,Int)) +data Inh_Nonterminal = Inh_Nonterminal {rulenumber_Inh_Nonterminal :: Int} +data Syn_Nonterminal = Syn_Nonterminal {depinfo_Syn_Nonterminal :: NontDependencyInformation,rulenumber_Syn_Nonterminal :: Int} +wrap_Nonterminal :: T_Nonterminal -> + Inh_Nonterminal -> + Syn_Nonterminal +wrap_Nonterminal (T_Nonterminal sem ) (Inh_Nonterminal _lhsIrulenumber ) = + (let ( _lhsOdepinfo,_lhsOrulenumber) = sem _lhsIrulenumber + in (Syn_Nonterminal _lhsOdepinfo _lhsOrulenumber )) +sem_Nonterminal_Nonterminal :: NontermIdent -> + ([Identifier]) -> + Attributes -> + Attributes -> + T_Productions -> + T_Nonterminal +sem_Nonterminal_Nonterminal nt_ params_ inh_ syn_ (T_Productions prods_ ) = + (T_Nonterminal (\ _lhsIrulenumber -> + (let _lhsOdepinfo :: NontDependencyInformation + _lhsOrulenumber :: Int + _prodsOrulenumber :: Int + _prodsIdepgraph :: ([ProdDependencyGraph]) + _prodsIrulenumber :: Int + -- "KWOrder.ag"(line 136, column 18) + _synvertices = + ({-# LINE 136 "KWOrder.ag" #-} + map (VAttr Syn nt_) . Map.keys $ syn_ + {-# LINE 595 "KWOrder.hs" #-} + ) + -- "KWOrder.ag"(line 137, column 18) + _inhvertices = + ({-# LINE 137 "KWOrder.ag" #-} + map (VAttr Inh nt_) . Map.keys $ inh_ + {-# LINE 601 "KWOrder.hs" #-} + ) + -- "KWOrder.ag"(line 138, column 18) + _vertices = + ({-# LINE 138 "KWOrder.ag" #-} + _synvertices ++ _inhvertices + {-# LINE 607 "KWOrder.hs" #-} + ) + -- "KWOrder.ag"(line 142, column 18) + _nontgraph = + ({-# LINE 142 "KWOrder.ag" #-} + NontDependencyGraph { ndgVertices = _vertices + , ndgEdges = [] } + {-# LINE 614 "KWOrder.hs" #-} + ) + -- "KWOrder.ag"(line 150, column 18) + _lhsOdepinfo = + ({-# LINE 150 "KWOrder.ag" #-} + NontDependencyInformation { ndiNonterminal = nt_ + , ndiInh = Map.keys inh_ + , ndiSyn = Map.keys syn_ + , ndiDepGraph = _nontgraph + , ndiProds = _prodsIdepgraph } + {-# LINE 624 "KWOrder.hs" #-} + ) + -- copy rule (up) + _lhsOrulenumber = + ({-# LINE 36 "KWOrder.ag" #-} + _prodsIrulenumber + {-# LINE 630 "KWOrder.hs" #-} + ) + -- copy rule (down) + _prodsOrulenumber = + ({-# LINE 36 "KWOrder.ag" #-} + _lhsIrulenumber + {-# LINE 636 "KWOrder.hs" #-} + ) + ( _prodsIdepgraph,_prodsIrulenumber) = + prods_ _prodsOrulenumber + in ( _lhsOdepinfo,_lhsOrulenumber))) ) +-- Nonterminals ------------------------------------------------ +{- + visit 0: + chained attribute: + rulenumber : Int + synthesized attribute: + depinfo : [NontDependencyInformation] + 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 -> + ( ([NontDependencyInformation]),Int)) +data Inh_Nonterminals = Inh_Nonterminals {rulenumber_Inh_Nonterminals :: Int} +data Syn_Nonterminals = Syn_Nonterminals {depinfo_Syn_Nonterminals :: ([NontDependencyInformation]),rulenumber_Syn_Nonterminals :: Int} +wrap_Nonterminals :: T_Nonterminals -> + Inh_Nonterminals -> + Syn_Nonterminals +wrap_Nonterminals (T_Nonterminals sem ) (Inh_Nonterminals _lhsIrulenumber ) = + (let ( _lhsOdepinfo,_lhsOrulenumber) = sem _lhsIrulenumber + in (Syn_Nonterminals _lhsOdepinfo _lhsOrulenumber )) +sem_Nonterminals_Cons :: T_Nonterminal -> + T_Nonterminals -> + T_Nonterminals +sem_Nonterminals_Cons (T_Nonterminal hd_ ) (T_Nonterminals tl_ ) = + (T_Nonterminals (\ _lhsIrulenumber -> + (let _lhsOdepinfo :: ([NontDependencyInformation]) + _lhsOrulenumber :: Int + _hdOrulenumber :: Int + _tlOrulenumber :: Int + _hdIdepinfo :: NontDependencyInformation + _hdIrulenumber :: Int + _tlIdepinfo :: ([NontDependencyInformation]) + _tlIrulenumber :: Int + -- use rule "KWOrder.ag"(line 147, column 33) + _lhsOdepinfo = + ({-# LINE 147 "KWOrder.ag" #-} + _hdIdepinfo : _tlIdepinfo + {-# LINE 687 "KWOrder.hs" #-} + ) + -- copy rule (up) + _lhsOrulenumber = + ({-# LINE 36 "KWOrder.ag" #-} + _tlIrulenumber + {-# LINE 693 "KWOrder.hs" #-} + ) + -- copy rule (down) + _hdOrulenumber = + ({-# LINE 36 "KWOrder.ag" #-} + _lhsIrulenumber + {-# LINE 699 "KWOrder.hs" #-} + ) + -- copy rule (chain) + _tlOrulenumber = + ({-# LINE 36 "KWOrder.ag" #-} + _hdIrulenumber + {-# LINE 705 "KWOrder.hs" #-} + ) + ( _hdIdepinfo,_hdIrulenumber) = + hd_ _hdOrulenumber + ( _tlIdepinfo,_tlIrulenumber) = + tl_ _tlOrulenumber + in ( _lhsOdepinfo,_lhsOrulenumber))) ) +sem_Nonterminals_Nil :: T_Nonterminals +sem_Nonterminals_Nil = + (T_Nonterminals (\ _lhsIrulenumber -> + (let _lhsOdepinfo :: ([NontDependencyInformation]) + _lhsOrulenumber :: Int + -- use rule "KWOrder.ag"(line 147, column 33) + _lhsOdepinfo = + ({-# LINE 147 "KWOrder.ag" #-} + [] + {-# LINE 721 "KWOrder.hs" #-} + ) + -- copy rule (chain) + _lhsOrulenumber = + ({-# LINE 36 "KWOrder.ag" #-} + _lhsIrulenumber + {-# LINE 727 "KWOrder.hs" #-} + ) + in ( _lhsOdepinfo,_lhsOrulenumber))) ) +-- Pattern ----------------------------------------------------- +{- + visit 0: + synthesized attributes: + copy : SELF + vertices : Set.Set Vertex + alternatives: + alternative Alias: + child field : {Identifier} + child attr : {Identifier} + child pat : Pattern + child parts : Patterns + visit 0: + local vertex : _ + 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 ,(Set.Set Vertex))) +data Inh_Pattern = Inh_Pattern {} +data Syn_Pattern = Syn_Pattern {copy_Syn_Pattern :: Pattern ,vertices_Syn_Pattern :: (Set.Set Vertex)} +wrap_Pattern :: T_Pattern -> + Inh_Pattern -> + Syn_Pattern +wrap_Pattern (T_Pattern sem ) (Inh_Pattern ) = + (let ( _lhsOcopy,_lhsOvertices) = sem + in (Syn_Pattern _lhsOcopy _lhsOvertices )) +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 _lhsOvertices :: (Set.Set Vertex) + _lhsOcopy :: Pattern + _patIcopy :: Pattern + _patIvertices :: (Set.Set Vertex) + _partsIcopy :: Patterns + _partsIvertices :: (Set.Set Vertex) + -- "KWOrder.ag"(line 68, column 12) + _vertex = + ({-# LINE 68 "KWOrder.ag" #-} + if field_ == _INST then VChild attr_ + else VAttr (if field_ == _LHS then Syn + else if field_ == _LOC then Loc + else Inh) field_ attr_ + {-# LINE 806 "KWOrder.hs" #-} + ) + -- "KWOrder.ag"(line 72, column 12) + _lhsOvertices = + ({-# LINE 72 "KWOrder.ag" #-} + Set.insert _vertex $ _partsIvertices `Set.union` _patIvertices + {-# LINE 812 "KWOrder.hs" #-} + ) + -- self rule + _copy = + ({-# LINE 23 "./Patterns.ag" #-} + Alias field_ attr_ _patIcopy _partsIcopy + {-# LINE 818 "KWOrder.hs" #-} + ) + -- self rule + _lhsOcopy = + ({-# LINE 23 "./Patterns.ag" #-} + _copy + {-# LINE 824 "KWOrder.hs" #-} + ) + ( _patIcopy,_patIvertices) = + pat_ + ( _partsIcopy,_partsIvertices) = + parts_ + in ( _lhsOcopy,_lhsOvertices)) ) +sem_Pattern_Constr :: ConstructorIdent -> + T_Patterns -> + T_Pattern +sem_Pattern_Constr name_ (T_Patterns pats_ ) = + (T_Pattern (let _lhsOvertices :: (Set.Set Vertex) + _lhsOcopy :: Pattern + _patsIcopy :: Patterns + _patsIvertices :: (Set.Set Vertex) + -- use rule "KWOrder.ag"(line 52, column 36) + _lhsOvertices = + ({-# LINE 52 "KWOrder.ag" #-} + _patsIvertices + {-# LINE 843 "KWOrder.hs" #-} + ) + -- self rule + _copy = + ({-# LINE 23 "./Patterns.ag" #-} + Constr name_ _patsIcopy + {-# LINE 849 "KWOrder.hs" #-} + ) + -- self rule + _lhsOcopy = + ({-# LINE 23 "./Patterns.ag" #-} + _copy + {-# LINE 855 "KWOrder.hs" #-} + ) + ( _patsIcopy,_patsIvertices) = + pats_ + in ( _lhsOcopy,_lhsOvertices)) ) +sem_Pattern_Irrefutable :: T_Pattern -> + T_Pattern +sem_Pattern_Irrefutable (T_Pattern pat_ ) = + (T_Pattern (let _lhsOvertices :: (Set.Set Vertex) + _lhsOcopy :: Pattern + _patIcopy :: Pattern + _patIvertices :: (Set.Set Vertex) + -- use rule "KWOrder.ag"(line 52, column 36) + _lhsOvertices = + ({-# LINE 52 "KWOrder.ag" #-} + _patIvertices + {-# LINE 871 "KWOrder.hs" #-} + ) + -- self rule + _copy = + ({-# LINE 23 "./Patterns.ag" #-} + Irrefutable _patIcopy + {-# LINE 877 "KWOrder.hs" #-} + ) + -- self rule + _lhsOcopy = + ({-# LINE 23 "./Patterns.ag" #-} + _copy + {-# LINE 883 "KWOrder.hs" #-} + ) + ( _patIcopy,_patIvertices) = + pat_ + in ( _lhsOcopy,_lhsOvertices)) ) +sem_Pattern_Product :: Pos -> + T_Patterns -> + T_Pattern +sem_Pattern_Product pos_ (T_Patterns pats_ ) = + (T_Pattern (let _lhsOvertices :: (Set.Set Vertex) + _lhsOcopy :: Pattern + _patsIcopy :: Patterns + _patsIvertices :: (Set.Set Vertex) + -- use rule "KWOrder.ag"(line 52, column 36) + _lhsOvertices = + ({-# LINE 52 "KWOrder.ag" #-} + _patsIvertices + {-# LINE 900 "KWOrder.hs" #-} + ) + -- self rule + _copy = + ({-# LINE 23 "./Patterns.ag" #-} + Product pos_ _patsIcopy + {-# LINE 906 "KWOrder.hs" #-} + ) + -- self rule + _lhsOcopy = + ({-# LINE 23 "./Patterns.ag" #-} + _copy + {-# LINE 912 "KWOrder.hs" #-} + ) + ( _patsIcopy,_patsIvertices) = + pats_ + in ( _lhsOcopy,_lhsOvertices)) ) +sem_Pattern_Underscore :: Pos -> + T_Pattern +sem_Pattern_Underscore pos_ = + (T_Pattern (let _lhsOvertices :: (Set.Set Vertex) + _lhsOcopy :: Pattern + -- use rule "KWOrder.ag"(line 52, column 36) + _lhsOvertices = + ({-# LINE 52 "KWOrder.ag" #-} + Set.empty + {-# LINE 926 "KWOrder.hs" #-} + ) + -- self rule + _copy = + ({-# LINE 23 "./Patterns.ag" #-} + Underscore pos_ + {-# LINE 932 "KWOrder.hs" #-} + ) + -- self rule + _lhsOcopy = + ({-# LINE 23 "./Patterns.ag" #-} + _copy + {-# LINE 938 "KWOrder.hs" #-} + ) + in ( _lhsOcopy,_lhsOvertices)) ) +-- Patterns ---------------------------------------------------- +{- + visit 0: + synthesized attributes: + copy : SELF + vertices : Set.Set Vertex + 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 ,(Set.Set Vertex))) +data Inh_Patterns = Inh_Patterns {} +data Syn_Patterns = Syn_Patterns {copy_Syn_Patterns :: Patterns ,vertices_Syn_Patterns :: (Set.Set Vertex)} +wrap_Patterns :: T_Patterns -> + Inh_Patterns -> + Syn_Patterns +wrap_Patterns (T_Patterns sem ) (Inh_Patterns ) = + (let ( _lhsOcopy,_lhsOvertices) = sem + in (Syn_Patterns _lhsOcopy _lhsOvertices )) +sem_Patterns_Cons :: T_Pattern -> + T_Patterns -> + T_Patterns +sem_Patterns_Cons (T_Pattern hd_ ) (T_Patterns tl_ ) = + (T_Patterns (let _lhsOvertices :: (Set.Set Vertex) + _lhsOcopy :: Patterns + _hdIcopy :: Pattern + _hdIvertices :: (Set.Set Vertex) + _tlIcopy :: Patterns + _tlIvertices :: (Set.Set Vertex) + -- use rule "KWOrder.ag"(line 52, column 36) + _lhsOvertices = + ({-# LINE 52 "KWOrder.ag" #-} + _hdIvertices `Set.union` _tlIvertices + {-# LINE 986 "KWOrder.hs" #-} + ) + -- self rule + _copy = + ({-# LINE 23 "./Patterns.ag" #-} + (:) _hdIcopy _tlIcopy + {-# LINE 992 "KWOrder.hs" #-} + ) + -- self rule + _lhsOcopy = + ({-# LINE 23 "./Patterns.ag" #-} + _copy + {-# LINE 998 "KWOrder.hs" #-} + ) + ( _hdIcopy,_hdIvertices) = + hd_ + ( _tlIcopy,_tlIvertices) = + tl_ + in ( _lhsOcopy,_lhsOvertices)) ) +sem_Patterns_Nil :: T_Patterns +sem_Patterns_Nil = + (T_Patterns (let _lhsOvertices :: (Set.Set Vertex) + _lhsOcopy :: Patterns + -- use rule "KWOrder.ag"(line 52, column 36) + _lhsOvertices = + ({-# LINE 52 "KWOrder.ag" #-} + Set.empty + {-# LINE 1013 "KWOrder.hs" #-} + ) + -- self rule + _copy = + ({-# LINE 23 "./Patterns.ag" #-} + [] + {-# LINE 1019 "KWOrder.hs" #-} + ) + -- self rule + _lhsOcopy = + ({-# LINE 23 "./Patterns.ag" #-} + _copy + {-# LINE 1025 "KWOrder.hs" #-} + ) + in ( _lhsOcopy,_lhsOvertices)) ) +-- Production -------------------------------------------------- +{- + visit 0: + chained attribute: + rulenumber : Int + synthesized attribute: + depgraph : ProdDependencyGraph + alternatives: + alternative Production: + child con : {ConstructorIdent} + child children : Children + child rules : Rules + child typeSigs : TypeSigs + visit 0: + local vertices : _ + local edges : _ +-} +-- 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 (Int -> + ( ProdDependencyGraph,Int)) +data Inh_Production = Inh_Production {rulenumber_Inh_Production :: Int} +data Syn_Production = Syn_Production {depgraph_Syn_Production :: ProdDependencyGraph,rulenumber_Syn_Production :: Int} +wrap_Production :: T_Production -> + Inh_Production -> + Syn_Production +wrap_Production (T_Production sem ) (Inh_Production _lhsIrulenumber ) = + (let ( _lhsOdepgraph,_lhsOrulenumber) = sem _lhsIrulenumber + in (Syn_Production _lhsOdepgraph _lhsOrulenumber )) +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 (\ _lhsIrulenumber -> + (let _lhsOdepgraph :: ProdDependencyGraph + _lhsOrulenumber :: Int + _rulesOrulenumber :: Int + _childrenIedges :: (Set.Set Edge) + _childrenInontnames :: ([(Identifier, Identifier)]) + _childrenIvertices :: (Set.Set Vertex) + _rulesIedges :: (Set.Set Edge) + _rulesIrulenumber :: Int + _rulesIvertices :: (Set.Set Vertex) + -- "KWOrder.ag"(line 90, column 17) + _vertices = + ({-# LINE 90 "KWOrder.ag" #-} + _rulesIvertices `Set.union` _childrenIvertices + {-# LINE 1081 "KWOrder.hs" #-} + ) + -- "KWOrder.ag"(line 110, column 17) + _edges = + ({-# LINE 110 "KWOrder.ag" #-} + _rulesIedges `Set.union` _childrenIedges + {-# LINE 1087 "KWOrder.hs" #-} + ) + -- "KWOrder.ag"(line 125, column 17) + _lhsOdepgraph = + ({-# LINE 125 "KWOrder.ag" #-} + ProdDependencyGraph { pdgVertices = Set.toList _vertices + , pdgEdges = Set.toList _edges + , pdgProduction = con_ + , pdgChildMap = _childrenInontnames } + {-# LINE 1096 "KWOrder.hs" #-} + ) + -- copy rule (up) + _lhsOrulenumber = + ({-# LINE 36 "KWOrder.ag" #-} + _rulesIrulenumber + {-# LINE 1102 "KWOrder.hs" #-} + ) + -- copy rule (down) + _rulesOrulenumber = + ({-# LINE 36 "KWOrder.ag" #-} + _lhsIrulenumber + {-# LINE 1108 "KWOrder.hs" #-} + ) + ( _childrenIedges,_childrenInontnames,_childrenIvertices) = + children_ + ( _rulesIedges,_rulesIrulenumber,_rulesIvertices) = + rules_ _rulesOrulenumber + in ( _lhsOdepgraph,_lhsOrulenumber))) ) +-- Productions ------------------------------------------------- +{- + visit 0: + chained attribute: + rulenumber : Int + synthesized attribute: + depgraph : [ProdDependencyGraph] + 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 -> + ( ([ProdDependencyGraph]),Int)) +data Inh_Productions = Inh_Productions {rulenumber_Inh_Productions :: Int} +data Syn_Productions = Syn_Productions {depgraph_Syn_Productions :: ([ProdDependencyGraph]),rulenumber_Syn_Productions :: Int} +wrap_Productions :: T_Productions -> + Inh_Productions -> + Syn_Productions +wrap_Productions (T_Productions sem ) (Inh_Productions _lhsIrulenumber ) = + (let ( _lhsOdepgraph,_lhsOrulenumber) = sem _lhsIrulenumber + in (Syn_Productions _lhsOdepgraph _lhsOrulenumber )) +sem_Productions_Cons :: T_Production -> + T_Productions -> + T_Productions +sem_Productions_Cons (T_Production hd_ ) (T_Productions tl_ ) = + (T_Productions (\ _lhsIrulenumber -> + (let _lhsOdepgraph :: ([ProdDependencyGraph]) + _lhsOrulenumber :: Int + _hdOrulenumber :: Int + _tlOrulenumber :: Int + _hdIdepgraph :: ProdDependencyGraph + _hdIrulenumber :: Int + _tlIdepgraph :: ([ProdDependencyGraph]) + _tlIrulenumber :: Int + -- use rule "KWOrder.ag"(line 122, column 33) + _lhsOdepgraph = + ({-# LINE 122 "KWOrder.ag" #-} + _hdIdepgraph : _tlIdepgraph + {-# LINE 1161 "KWOrder.hs" #-} + ) + -- copy rule (up) + _lhsOrulenumber = + ({-# LINE 36 "KWOrder.ag" #-} + _tlIrulenumber + {-# LINE 1167 "KWOrder.hs" #-} + ) + -- copy rule (down) + _hdOrulenumber = + ({-# LINE 36 "KWOrder.ag" #-} + _lhsIrulenumber + {-# LINE 1173 "KWOrder.hs" #-} + ) + -- copy rule (chain) + _tlOrulenumber = + ({-# LINE 36 "KWOrder.ag" #-} + _hdIrulenumber + {-# LINE 1179 "KWOrder.hs" #-} + ) + ( _hdIdepgraph,_hdIrulenumber) = + hd_ _hdOrulenumber + ( _tlIdepgraph,_tlIrulenumber) = + tl_ _tlOrulenumber + in ( _lhsOdepgraph,_lhsOrulenumber))) ) +sem_Productions_Nil :: T_Productions +sem_Productions_Nil = + (T_Productions (\ _lhsIrulenumber -> + (let _lhsOdepgraph :: ([ProdDependencyGraph]) + _lhsOrulenumber :: Int + -- use rule "KWOrder.ag"(line 122, column 33) + _lhsOdepgraph = + ({-# LINE 122 "KWOrder.ag" #-} + [] + {-# LINE 1195 "KWOrder.hs" #-} + ) + -- copy rule (chain) + _lhsOrulenumber = + ({-# LINE 36 "KWOrder.ag" #-} + _lhsIrulenumber + {-# LINE 1201 "KWOrder.hs" #-} + ) + in ( _lhsOdepgraph,_lhsOrulenumber))) ) +-- Rule -------------------------------------------------------- +{- + visit 0: + chained attribute: + rulenumber : Int + synthesized attributes: + edges : Set.Set Edge + vertices : Set.Set Vertex + alternatives: + alternative Rule: + child mbName : {Maybe Identifier} + child pattern : Pattern + child rhs : Expression + child owrt : {Bool} + child origin : {String} + child explicit : {Bool} + visit 0: + local rulename : _ + local vertex : _ + local edgesout : _ + local edgesin : _ +-} +-- cata +sem_Rule :: Rule -> + T_Rule +sem_Rule (Rule _mbName _pattern _rhs _owrt _origin _explicit ) = + (sem_Rule_Rule _mbName (sem_Pattern _pattern ) (sem_Expression _rhs ) _owrt _origin _explicit ) +-- semantic domain +newtype T_Rule = T_Rule (Int -> + ( (Set.Set Edge),Int,(Set.Set Vertex))) +data Inh_Rule = Inh_Rule {rulenumber_Inh_Rule :: Int} +data Syn_Rule = Syn_Rule {edges_Syn_Rule :: (Set.Set Edge),rulenumber_Syn_Rule :: Int,vertices_Syn_Rule :: (Set.Set Vertex)} +wrap_Rule :: T_Rule -> + Inh_Rule -> + Syn_Rule +wrap_Rule (T_Rule sem ) (Inh_Rule _lhsIrulenumber ) = + (let ( _lhsOedges,_lhsOrulenumber,_lhsOvertices) = sem _lhsIrulenumber + in (Syn_Rule _lhsOedges _lhsOrulenumber _lhsOvertices )) +sem_Rule_Rule :: (Maybe Identifier) -> + T_Pattern -> + T_Expression -> + Bool -> + String -> + Bool -> + T_Rule +sem_Rule_Rule mbName_ (T_Pattern pattern_ ) (T_Expression rhs_ ) owrt_ origin_ explicit_ = + (T_Rule (\ _lhsIrulenumber -> + (let _lhsOrulenumber :: Int + _lhsOvertices :: (Set.Set Vertex) + _lhsOedges :: (Set.Set Edge) + _patternIcopy :: Pattern + _patternIvertices :: (Set.Set Vertex) + _rhsIvertices :: (Set.Set Vertex) + -- "KWOrder.ag"(line 42, column 11) + _lhsOrulenumber = + ({-# LINE 42 "KWOrder.ag" #-} + _lhsIrulenumber + 1 + {-# LINE 1261 "KWOrder.hs" #-} + ) + -- "KWOrder.ag"(line 43, column 11) + _rulename = + ({-# LINE 43 "KWOrder.ag" #-} + maybe (identifier $ "rule" ++ show _lhsIrulenumber) id mbName_ + {-# LINE 1267 "KWOrder.hs" #-} + ) + -- "KWOrder.ag"(line 85, column 11) + _vertex = + ({-# LINE 85 "KWOrder.ag" #-} + VRule _rulename + {-# LINE 1273 "KWOrder.hs" #-} + ) + -- "KWOrder.ag"(line 86, column 11) + _lhsOvertices = + ({-# LINE 86 "KWOrder.ag" #-} + Set.insert _vertex $ _patternIvertices `Set.union` _rhsIvertices + {-# LINE 1279 "KWOrder.hs" #-} + ) + -- "KWOrder.ag"(line 98, column 11) + _edgesout = + ({-# LINE 98 "KWOrder.ag" #-} + map ((,) _vertex ) (Set.toList _rhsIvertices) + {-# LINE 1285 "KWOrder.hs" #-} + ) + -- "KWOrder.ag"(line 99, column 11) + _edgesin = + ({-# LINE 99 "KWOrder.ag" #-} + map (flip (,) _vertex ) (Set.toList _patternIvertices) + {-# LINE 1291 "KWOrder.hs" #-} + ) + -- "KWOrder.ag"(line 100, column 11) + _lhsOedges = + ({-# LINE 100 "KWOrder.ag" #-} + Set.fromList $ _edgesout ++ _edgesin + {-# LINE 1297 "KWOrder.hs" #-} + ) + ( _patternIcopy,_patternIvertices) = + pattern_ + ( _rhsIvertices) = + rhs_ + in ( _lhsOedges,_lhsOrulenumber,_lhsOvertices))) ) +-- Rules ------------------------------------------------------- +{- + visit 0: + chained attribute: + rulenumber : Int + synthesized attributes: + edges : Set.Set Edge + vertices : Set.Set Vertex + 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 (Int -> + ( (Set.Set Edge),Int,(Set.Set Vertex))) +data Inh_Rules = Inh_Rules {rulenumber_Inh_Rules :: Int} +data Syn_Rules = Syn_Rules {edges_Syn_Rules :: (Set.Set Edge),rulenumber_Syn_Rules :: Int,vertices_Syn_Rules :: (Set.Set Vertex)} +wrap_Rules :: T_Rules -> + Inh_Rules -> + Syn_Rules +wrap_Rules (T_Rules sem ) (Inh_Rules _lhsIrulenumber ) = + (let ( _lhsOedges,_lhsOrulenumber,_lhsOvertices) = sem _lhsIrulenumber + in (Syn_Rules _lhsOedges _lhsOrulenumber _lhsOvertices )) +sem_Rules_Cons :: T_Rule -> + T_Rules -> + T_Rules +sem_Rules_Cons (T_Rule hd_ ) (T_Rules tl_ ) = + (T_Rules (\ _lhsIrulenumber -> + (let _lhsOedges :: (Set.Set Edge) + _lhsOvertices :: (Set.Set Vertex) + _lhsOrulenumber :: Int + _hdOrulenumber :: Int + _tlOrulenumber :: Int + _hdIedges :: (Set.Set Edge) + _hdIrulenumber :: Int + _hdIvertices :: (Set.Set Vertex) + _tlIedges :: (Set.Set Edge) + _tlIrulenumber :: Int + _tlIvertices :: (Set.Set Vertex) + -- use rule "KWOrder.ag"(line 94, column 33) + _lhsOedges = + ({-# LINE 94 "KWOrder.ag" #-} + _hdIedges `Set.union` _tlIedges + {-# LINE 1354 "KWOrder.hs" #-} + ) + -- use rule "KWOrder.ag"(line 52, column 36) + _lhsOvertices = + ({-# LINE 52 "KWOrder.ag" #-} + _hdIvertices `Set.union` _tlIvertices + {-# LINE 1360 "KWOrder.hs" #-} + ) + -- copy rule (up) + _lhsOrulenumber = + ({-# LINE 36 "KWOrder.ag" #-} + _tlIrulenumber + {-# LINE 1366 "KWOrder.hs" #-} + ) + -- copy rule (down) + _hdOrulenumber = + ({-# LINE 36 "KWOrder.ag" #-} + _lhsIrulenumber + {-# LINE 1372 "KWOrder.hs" #-} + ) + -- copy rule (chain) + _tlOrulenumber = + ({-# LINE 36 "KWOrder.ag" #-} + _hdIrulenumber + {-# LINE 1378 "KWOrder.hs" #-} + ) + ( _hdIedges,_hdIrulenumber,_hdIvertices) = + hd_ _hdOrulenumber + ( _tlIedges,_tlIrulenumber,_tlIvertices) = + tl_ _tlOrulenumber + in ( _lhsOedges,_lhsOrulenumber,_lhsOvertices))) ) +sem_Rules_Nil :: T_Rules +sem_Rules_Nil = + (T_Rules (\ _lhsIrulenumber -> + (let _lhsOedges :: (Set.Set Edge) + _lhsOvertices :: (Set.Set Vertex) + _lhsOrulenumber :: Int + -- use rule "KWOrder.ag"(line 94, column 33) + _lhsOedges = + ({-# LINE 94 "KWOrder.ag" #-} + Set.empty + {-# LINE 1395 "KWOrder.hs" #-} + ) + -- use rule "KWOrder.ag"(line 52, column 36) + _lhsOvertices = + ({-# LINE 52 "KWOrder.ag" #-} + Set.empty + {-# LINE 1401 "KWOrder.hs" #-} + ) + -- copy rule (chain) + _lhsOrulenumber = + ({-# LINE 36 "KWOrder.ag" #-} + _lhsIrulenumber + {-# LINE 1407 "KWOrder.hs" #-} + ) + in ( _lhsOedges,_lhsOrulenumber,_lhsOvertices))) ) +-- 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 -> + Inh_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 -> + Inh_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/KennedyWarren.hs b/src/KennedyWarren.hs new file mode 100644 --- /dev/null +++ b/src/KennedyWarren.hs @@ -0,0 +1,117 @@ +module KennedyWarren where + +import CommonTypes +import Pretty +import Knuth1 +import Debug.Trace +import Control.Monad.ST +import Control.Monad.State +import Control.Monad.Error +import Data.STRef +import Data.Maybe +import Data.List + +import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet + +kennedyWarrenIO :: [NontDependencyInformation] -> PP_Doc +kennedyWarrenIO ndis = runST $ do + indi <- mapM mkNontDependencyInformationM ndis + knuth1 indi + -- Check all graphs for cyclicity, transitive closure and consistency + traceST $ "Checking graphs..." + forM_ indi $ \ndi -> do + let nont = ndiNonterminal . ndimOrig $ ndi + let g = ndgmDepGraph . ndimDepGraph $ ndi + -- Cyclicity check + c1 <- graphIsCyclic g + when c1 $ traceST $ "Nonterminal graph " ++ show nont ++ " is cylic!" + -- Transtive closure check + trc <- graphIsTRC g + when (not trc) $ traceST $ "Nonterminal graph " ++ show nont ++ " is not transitively closed!" + -- Consistency check + cons <- graphCheckConsistency g + when (not cons) $ traceST $ "Nonterminal graph " ++ show nont ++ " is not consistent!" + -- Loop trough all productions + forM_ (ndimProds ndi) $ \prod -> do + let pr = pdgProduction $ pdgmOrig prod + let g = pdgmDepGraph $ prod + -- Check for cyclicity + c2 <- graphIsCyclic g + when c2 $ traceST $ "Production graph " ++ show pr ++ " of nonterminal " + ++ show nont ++ " is cylic!" + -- Transtive closure check + trc <- graphIsTRC g + when (not trc) $ traceST $ "Production graph " ++ show pr ++ " of nonterminal " + ++ show nont ++ " is not transitively closed!" + -- Check consistency + cons <- graphCheckConsistency g + when (not cons) $ traceST $ "Production graph " ++ show pr ++ " of nonterminal " + ++ show nont ++ " is not consistent!" + -- Recreate non-transitive closed graph for efficiency + indi <- undoTransitiveClosure indi + -- Debug output + traceST $ "Converting to string..." + rtexts <- mapM toGVNontDependencyInfo indi + traceST $ "Done." + return (vlist rtexts) + +------------------------------------------------------------------------------- +-- Debugging functionality +------------------------------------------------------------------------------- + +-- | Pretty print a vertex in GraphViz format +toGVVertex :: Bool -> Vertex -> ST s PP_Doc +toGVVertex l (VAttr t a b) = return $ (text $ "attr_" ++ show t ++ "_" ++ show a ++ "_" ++ show b) >#< if l + then text ("[shape=box,label=\"" ++ show t ++ " @" ++ show a ++ "." ++ show b ++ "\"]") else empty +toGVVertex l (VChild c) = return $ (text $ "child_" ++ show c) >#< if l + then text ("[shape=ellipse,label=\"Child " ++ show c ++ "\"]") else empty +toGVVertex l (VRule r) = return $ (text $ "rule_" ++ show r) >#< if l + then text ("[shape=diamond,label=\"" ++ show r ++ "\"]") else empty + +-- | Pretty print an edge in GraphViz format +toGVEdge :: Edge -> ST s PP_Doc +toGVEdge (v1, v2) = do r1 <- toGVVertex False v1 + r2 <- toGVVertex False v2 + return $ r1 >|< text "->" >#< r2 + +-- | Pretty print a NontDependencyInformation in GraphViz format +toGVNontDependencyInfo :: NontDependencyInformationM s -> ST s PP_Doc +toGVNontDependencyInfo ndi = do dg <- return $ ndgmDepGraph . ndimDepGraph $ ndi + verts <- graphVertices dg + edges <- graphEdges dg + vtexts <- mapM (toGVVertex True) verts + etexts <- mapM toGVEdge edges + ptexts <- mapM toGVProdDependencyGraph (ndimProds ndi) + return $ (text ("digraph ndg_" ++ show (ndiNonterminal $ ndimOrig ndi) ++ " {") + >-< + vlist vtexts + >-< + vlist etexts + >-< + text "}" + >-< + text "" -- empty line + >-< + vlist ptexts) + +-- | Pretty print a ProdDependencyGraph in GraphViz format +toGVProdDependencyGraph :: ProdDependencyGraphM s -> ST s PP_Doc +toGVProdDependencyGraph pdg = do dg <- return $ pdgmDepGraph pdg + verts <- graphVertices dg + edges <- graphEdges dg + vtexts <- mapM (toGVVertex True) verts + etexts <- mapM toGVEdge edges + return $ (text ("digraph pdg_" ++ show (pdgProduction $ pdgmOrig pdg) ++ " {") + >-< + (vlist vtexts) + >-< + (vlist etexts) + >-< + text ("info [shape=box,label=\"" ++ show (pdgChildMap $ pdgmOrig pdg) ++ "\"];") + >-< + text "}" + >-< + text "") diff --git a/src/Knuth1.hs b/src/Knuth1.hs new file mode 100644 --- /dev/null +++ b/src/Knuth1.hs @@ -0,0 +1,445 @@ +module Knuth1 where + +import Pretty +import CommonTypes +import Control.Monad +import Control.Monad.ST +import Data.Maybe +import Data.List +import Data.STRef +import Debug.Trace + +import qualified Data.Array as Array +import qualified Data.Map as Map +import qualified Data.Set as Set + +-- | Trace a message in the ST monad +traceST :: String -> ST s () +traceST s = trace s (return ()) + +------------------------------------------------------------------------------- +-- Dependency graph representation +------------------------------------------------------------------------------- + +-- Vertices +data AttrType = Inh | Syn | Loc deriving (Eq, Ord, Show) +data Vertex = VAttr AttrType Identifier Identifier + | VChild Identifier + | VRule Identifier deriving (Eq, Ord) + +instance Show Vertex where + show (VAttr ty ch at) = show ty ++ " @" ++ show ch ++ "." ++ show at + show (VChild ch) = "Child " ++ show ch + show (VRule ru) = "Rule " ++ show ru + +-- | Check if a vertex is an attribute +isVertexAttr :: Vertex -> Bool +isVertexAttr (VAttr _ _ _) = True +isVertexAttr _ = False + +-- | Get the child name of an attribute +getAttrChildName :: Vertex -> Identifier +getAttrChildName (VAttr _ n _) = n + +-- | Set the child name of an attribute +setAttrChildName :: Vertex -> Identifier -> Vertex +setAttrChildName (VAttr t _ a) n = VAttr t n a + +-- | Get the type of an attribute +getAttrType :: Vertex -> AttrType +getAttrType (VAttr t _ _) = t + +-- | Get the name of an attribute +getAttrName :: Vertex -> Identifier +getAttrName (VAttr _ _ a) = a + +-- Edges +type Edge = (Vertex, Vertex) + +-- Internal representation of a vertex +type IVertex = Int +type IEdge = (IVertex, IVertex) + +-- Representation of the graph +data DependencyGraph s = DependencyGraph { vertexIMap :: Map.Map Vertex IVertex + , vertexOMap :: Array.Array IVertex Vertex + , successors :: Array.Array IVertex (STRef s (Set.Set IVertex)) + , predecessors :: Array.Array IVertex (STRef s (Set.Set IVertex)) } + +------------------------------------------------------------------------------- +-- Dependency graph fuctions +------------------------------------------------------------------------------- + +-- | Construct a dependency graph +graphConstruct :: [Vertex] -> ST s (DependencyGraph s) +graphConstruct vs = do let nv = length vs + let ivs = [0..nv-1] + let ivb = (0,nv-1) + let vimap = Map.fromList (zip vs ivs) + let vomap = Array.array ivb (zip ivs vs) + succs <- replicateM nv (newSTRef Set.empty) + preds <- replicateM nv (newSTRef Set.empty) + let su = Array.array ivb (zip ivs succs) + let pr = Array.array ivb (zip ivs preds) + let graph = DependencyGraph { vertexIMap = vimap + , vertexOMap = vomap + , successors = su + , predecessors = pr } + return graph + +-- | Construct a transitivelly closed graph +graphConstructTRC :: [Vertex] -> [Edge] -> ST s (DependencyGraph s) +graphConstructTRC vs es = do g <- graphConstruct vs + -- Insert all initial edges + graphInsertEdgesTRC g es + return g + + +-- | Return all successors of a vertex +graphSuccessors :: DependencyGraph s -> Vertex -> ST s (Set.Set Vertex) +graphSuccessors g v = do sucs <- readSTRef $ (successors g) Array.! (graphGetIVertex g v) + return $ Set.map (graphGetVertex g) sucs + +-- | Check if the graph contains an edge +graphContainsEdge :: DependencyGraph s -> Edge -> ST s Bool +graphContainsEdge g (v1,v2) = do let iv1 = graphGetIVertex g v1 + let iv2 = graphGetIVertex g v2 + sucs <- readSTRef $ (successors g) Array.! iv1 + return $ iv2 `Set.member` sucs + +-- | Insert an edge in a transtive closed graph and return all other edges that were +-- added due to transtivity +graphInsert :: DependencyGraph s -> Edge -> ST s () +graphInsert g (v1,v2) = do let iv1 = graphGetIVertex g v1 + let iv2 = graphGetIVertex g v2 + -- Add v2 to the successors of v1 and v1 to predecessors of v2 + modifySTRef ((successors g) Array.! iv1) $ Set.insert iv2 + modifySTRef ((predecessors g) Array.! iv2) $ Set.insert iv1 + +-- | Insert an edge in a transtive closed graph and return all other edges that were +-- added due to transtivity +graphInsertTRC :: DependencyGraph s -> Edge -> ST s [(IVertex, Set.Set IVertex)] +graphInsertTRC g (v1,v2) = do let iv1 = graphGetIVertex g v1 + let iv2 = graphGetIVertex g v2 + -- Read predecessors of v1 and successors of v2 + pred1 <- readSTRef $ (predecessors g) Array.! iv1 + succ2 <- readSTRef $ (successors g) Array.! iv2 + -- First insert all edges from v1 + let rsucc1 = (successors g) Array.! iv1 + succ1 <- readSTRef rsucc1 + let add1 = succ2 `Set.difference` succ1 + modifySTRef rsucc1 (Set.union add1 . Set.insert iv2) + -- All edges to v2 + let rpred2 = (predecessors g) Array.! iv2 + modifySTRef rpred2 (Set.union pred1 . Set.insert iv1) + -- Connect every predecessor of v1 to every successor of v2 + sucl <- forM (Set.toList pred1) $ \pred -> do + -- Connect pred to v2 and all successors of v2 + let rsucc = (successors g) Array.! pred + csucc <- readSTRef rsucc + let cadd = (Set.insert iv2 succ2) `Set.difference` csucc + modifySTRef rsucc (Set.union cadd) + return (pred, cadd) + -- Connect every successor of v2 to every predecessor of v1 + forM_ (Set.toList succ2) $ \succ -> do + -- Connect succ to v1 and all predecessors of v1 + let rpred = (predecessors g) Array.! succ + cpred <- readSTRef rpred + let cadd = (Set.insert iv1 pred1) `Set.difference` cpred + modifySTRef rpred (Set.union cadd) + -- Create return + return $ (iv1,add1) : sucl + +-- | Return all vertices of the graph +graphVertices :: DependencyGraph s -> ST s [Vertex] +graphVertices = return . Array.elems . vertexOMap + +-- | Return all edges of the graph +graphEdges :: DependencyGraph s -> ST s [Edge] +graphEdges g = do let vs = Array.indices $ vertexOMap g + perv <- forM vs $ \v -> do + let rv = graphGetVertex g v + sucs <- readSTRef $ (successors g) Array.! v + let sucl = Set.toList sucs + return $ map ((,) rv . graphGetVertex g) sucl + return $ concat perv + +-- | Insert a list of edges in the graph and return all other edges that +-- were added due to transitivity +graphInsertEdgesTRC :: DependencyGraph s -> [Edge] -> ST s [Edge] +graphInsertEdgesTRC g ed = do -- rets :: [[(IVertex, Set.Set IVertex)]] + rets <- mapM (graphInsertTRC g) ed + -- Combine all successor sets + let f :: (IVertex, (Set.Set IVertex)) -> [(IVertex, IVertex)] + f (v,s) = map ((,) v) (Set.toList s) + let comb :: [(IVertex, IVertex)] + comb = concatMap (concatMap f) rets + -- Construct edges from this + return $ map (graphGetEdge g) $ comb + +-- | Check whether the graph is cyclic +graphIsCyclic :: DependencyGraph s -> ST s Bool +graphIsCyclic g = do vs <- return $ Array.indices $ vertexOMap g + selfcyc <- forM vs $ \v -> do + sucs <- readSTRef $ (successors g) Array.! v + return $ v `Set.member` sucs + return $ or selfcyc + +-- | Get internal representation of a vertex +graphGetIVertex :: DependencyGraph s -> Vertex -> IVertex +graphGetIVertex g v = vertexIMap g Map.! v + +-- | Get external representation of a vertex +graphGetVertex :: DependencyGraph s -> IVertex -> Vertex +graphGetVertex g v = vertexOMap g Array.! v + +-- | Get external representation of an edge +graphGetEdge :: DependencyGraph s -> IEdge -> Edge +graphGetEdge g (v1,v2) = (graphGetVertex g v1, graphGetVertex g v2) + +-- | Check if the graph is transitively closed +graphIsTRC :: DependencyGraph s -> ST s Bool +graphIsTRC g = do let vs = Array.indices $ vertexOMap g + bs <- forM vs $ \v -> do + succs <- readSTRef $ (successors g) Array.! v + bs2 <- forM (Set.toList succs) $ \v2 -> do + succs2 <- readSTRef $ (successors g) Array.! v2 + return $ succs2 `Set.isSubsetOf` succs + return $ and bs2 + return $ and bs + +-- | Check consistency of the graph (successor and predecessor sets) +graphCheckConsistency :: DependencyGraph s -> ST s Bool +graphCheckConsistency g = do let vs = Array.indices $ vertexOMap g + ret <- forM vs $ \v -> do + -- V must appear in every predecessor set of its successors + succs <- readSTRef $ (successors g) Array.! v + r1 <- forM (Set.toList succs) $ \succ -> do + preds2 <- readSTRef $ (predecessors g) Array.! succ + return (v `Set.member` preds2) + -- V must appear in every successor set of its predecessors + preds <- readSTRef $ (predecessors g) Array.! v + r2 <- forM (Set.toList preds) $ \pred -> do + succs2 <- readSTRef $ (successors g) Array.! pred + return (v `Set.member` succs2) + return $ and $ r1 ++ r2 + return $ and $ ret + +------------------------------------------------------------------------------- +-- Dependency graph information wrappers +------------------------------------------------------------------------------- + +-- | Special wrapper for nonterminal dependency graphs (so that we can easily add other meta-information) +data NontDependencyGraph = NontDependencyGraph { ndgVertices :: [Vertex] + , ndgEdges :: [Edge] } + +-- | Special wrapper for production dependency graphs, including mapping between child names and nonterminals +data ProdDependencyGraph = ProdDependencyGraph { pdgVertices :: [Vertex] + , pdgEdges :: [Edge] + , pdgProduction :: Identifier + , pdgChildMap :: [(Identifier, Identifier)] } + + +-- | Represent all information from the dependency graphs for a nonterminal +data NontDependencyInformation = NontDependencyInformation { ndiNonterminal :: Identifier + , ndiInh :: [Identifier] + , ndiSyn :: [Identifier] + , ndiDepGraph :: NontDependencyGraph + , ndiProds :: [ProdDependencyGraph] } + +--- Monadic versions of these records, for use with the ST monad + +-- | Monadic wrapper of NontDependencyGraph +data NontDependencyGraphM s = NontDependencyGraphM { ndgmDepGraph :: DependencyGraph s + , ndgmOrig :: NontDependencyGraph } + +-- | Monadic wrapper of ProdDependencyGraph +data ProdDependencyGraphM s = ProdDependencyGraphM { pdgmDepGraph :: DependencyGraph s + , pdgmOrig :: ProdDependencyGraph } + + +-- | Monadic wrapper of NontDependencyInformation +data NontDependencyInformationM s = NontDependencyInformationM { ndimOrig :: NontDependencyInformation + , ndimDepGraph :: NontDependencyGraphM s + , ndimProds :: [ProdDependencyGraphM s] } + + +-- | Convert a NontDependencyGraph to the corresponding monadic version +mkNontDependencyGraphM :: NontDependencyGraph -> ST s (NontDependencyGraphM s) +mkNontDependencyGraphM ndg = do g <- graphConstructTRC (ndgVertices ndg) (ndgEdges ndg) + return $ NontDependencyGraphM { ndgmDepGraph = g + , ndgmOrig = ndg } + + +-- | Convert a ProdDependencyGraph to the corresponding monadic version +mkProdDependencyGraphM :: Bool -> ProdDependencyGraph -> ST s (ProdDependencyGraphM s) +mkProdDependencyGraphM trc pdg = do g <- if trc + then graphConstructTRC (pdgVertices pdg) (pdgEdges pdg) + else do g <- graphConstruct (pdgVertices pdg) + mapM_ (graphInsert g) (pdgEdges pdg) + return g + return $ ProdDependencyGraphM { pdgmDepGraph = g + , pdgmOrig = pdg } + +-- | Convert a NontDependencyInformation to the corresponding monadic version +mkNontDependencyInformationM :: NontDependencyInformation -> ST s (NontDependencyInformationM s) +mkNontDependencyInformationM ndi = do dg <- mkNontDependencyGraphM (ndiDepGraph ndi) + prods <- mapM (mkProdDependencyGraphM True) (ndiProds ndi) + return $ NontDependencyInformationM { ndimOrig = ndi + , ndimDepGraph = dg + , ndimProds = prods } + +-- | Construct the production graphs from the +undoTransitiveClosure :: [NontDependencyInformationM s] -> ST s [NontDependencyInformationM s] +undoTransitiveClosure ndis = do edgesl <- mapM (\ndi -> graphEdges (ndgmDepGraph $ ndimDepGraph ndi)) ndis + let edges = concat edgesl + forM ndis $ \ndi -> do + prods <- mapM (mkProdDependencyGraphM False) (ndiProds $ ndimOrig ndi) + let ret = NontDependencyInformationM { ndimOrig = ndimOrig ndi + , ndimDepGraph = ndimDepGraph ndi + , ndimProds = prods } + addNontProd False (edges, ret) + return ret + +------------------------------------------------------------------------------- +-- Knuth-1 algorithm +------------------------------------------------------------------------------- + +-- | Combine the dependency and nonterminal graphs using Knuth-1 +-- this function assumes that the nonterminal graphs initially contains no edges +knuth1 :: [NontDependencyInformationM s] -> ST s () +knuth1 ndis = do -- Create initial list of pending edges for each ndi (just all edges of the production graphs) + let ipending :: NontDependencyInformationM s -> ST s [Edge] + ipending = liftM concat . mapM (graphEdges . pdgmDepGraph) . ndimProds +-- pndis :: [([Edge], NontDependencyInformation)] + pndis <- mapM (\ndi -> liftM2 (,) (ipending ndi) (return ndi)) ndis + knuth1' pndis + +-- | Helper function for |knuth1| which repeats the process until we are done +knuth1' :: [([Edge], NontDependencyInformationM s)] -> ST s () +knuth1' ndis = do -- Add edges from the production graphs to the nonterminal graph +-- ndis' :: [Maybe [Edge]] + ndis' <- mapM addProdNont ndis + -- List of all newly added edges +-- ntedge :: [Edge] + let ntedge = concatMap (\x -> maybe [] id x) ndis' + if null ntedge + -- When no new edges have been added we are done + then return () + else do -- Otherwise, the next step is to add edges from nonterminal to production graphs +-- ndis'' :: [Maybe [Edge]] + ndis'' <- mapM (\(_,x) -> addNontProd True (ntedge, x)) ndis + -- List of new states (production edges + dependency graphs) +-- nndis' :: [([Edge], NontDependencyInformation)] + nndis' <- zipWithM (\(_,ndi) me -> return (maybe [] id me, ndi)) ndis ndis'' + if any isJust ndis'' + -- We have added some edges, so continue the process + then knuth1' nndis' + -- No new edges added, we are done + else return () + +-- | Add pending edges from the production graphs to the nonterminal graph, return Nothing if none were added +-- otherwise, return the list of newly added nonterminal edges +addProdNont :: ([Edge], NontDependencyInformationM s) -> ST s (Maybe [Edge]) +addProdNont (pending, ndi) = do -- Unwrapping of the records + let nontDepGraph = ndimDepGraph ndi + let nontGraph = ndgmDepGraph nontDepGraph + -- nub the list because multiple productions can result in the same new edges + let possa = nub $ do (v1,v2) <- pending + -- Take only edges from syn.lhs to inh.lhs + guard $ isVertexAttr v1 + guard $ getAttrChildName v1 == _LHS + guard $ getAttrType v1 == Syn + guard $ isVertexAttr v2 + guard $ getAttrChildName v2 == _LHS + guard $ getAttrType v2 == Inh + -- Construct edge as it should be in nonterminal graph + let nv1 = setAttrChildName v1 (ndiNonterminal $ ndimOrig ndi) + let nv2 = setAttrChildName v2 (ndiNonterminal $ ndimOrig ndi) + return (nv1, nv2) + -- Edges that are not in the nonterminal graph yet + toadd <- filterM (\e -> return not `ap` graphContainsEdge nontGraph e) possa + -- Check whether new edges are to be added and return the added edges + if null toadd + then return Nothing + else do graphInsertEdgesTRC nontGraph toadd + -- Debug output + --mapM_ (\edge -> traceST $ "Adding nonterminal edge " ++ show edge) toadd + return $ Just toadd + +-- | Add edges from the nonterminal graphs to the production graphs, return Nothing if none were added +-- otherwise, return the list of newly added production edges and the updated graph +addNontProd :: Bool -> ([Edge], NontDependencyInformationM s) -> ST s (Maybe [Edge]) +addNontProd trc (pending, ndi) = do -- Call the helper function for each nonterminal + prods' <- mapM (addNontProd' trc pending) (ndimProds ndi) + -- Check if any edges were added + if any isJust prods' + then -- Return list of newly created edges + return $ Just $ concatMap (maybe [] id) prods' + else return Nothing + +-- | Helper function for |addNontProd| for a single production +addNontProd' :: Bool -> [Edge] -> ProdDependencyGraphM s -> ST s (Maybe [Edge]) +addNontProd' trc pend pdg = do -- Unwrapping of the records + prodGraph <- return $ pdgmDepGraph pdg + -- Construct all possible new edges + let possa = do (v1,v2) <- pend + -- Take a child of this nonterminal type + guard $ isVertexAttr v1 + guard $ isVertexAttr v2 + let tp = getAttrChildName v1 + (ch,chtp) <- pdgChildMap $ pdgmOrig pdg + guard $ tp == chtp + -- Construct edge as it should be in the production graph + let nv1 = setAttrChildName v1 ch + let nv2 = setAttrChildName v2 ch + return (nv1, nv2) + -- Edges that are not in the production graph yet + toadd <- filterM (\e -> return not `ap` graphContainsEdge prodGraph e) possa + -- Check whether new edges are to be added and return the result + if null toadd + then return Nothing + else do -- Insert all edges and return transitive edges that are added in this process + ret <- if trc + then graphInsertEdgesTRC prodGraph toadd + else do mapM_ (graphInsert prodGraph) toadd + return [] + -- Debug output + --mapM_ (\edge -> traceST $ "Adding production edge " ++ show edge) toadd + return $ Just ret + +-- | Add the "back edges" to the nonterminal graphs for creating a global ordering +addBackEdges :: [NontDependencyInformationM s] -> ST s () +addBackEdges ndis = do -- gather all back edges + lBackEdges <- forM ndis $ \ndi -> do + -- For every production + bs <- forM (ndimProds ndi) $ \prod -> do + -- Go through all edges + edg <- graphEdges . pdgmDepGraph $ prod + return $ do (v1,v2) <- edg + -- Backedges are from inh.ch to syn.ch + guard $ isVertexAttr v1 + guard $ getAttrChildName v1 /= _LHS + guard $ getAttrType v1 == Inh + guard $ isVertexAttr v2 + guard $ getAttrChildName v2 /= _LHS + guard $ getAttrType v2 == Syn + guard $ getAttrChildName v1 == getAttrChildName v2 + -- Find the correct child name + (ch,chtp) <- pdgChildMap $ pdgmOrig prod + let tp = getAttrChildName v1 + guard $ tp == ch + -- Construct the edge as it should be in the nonterminal graph + let nv1 = setAttrChildName v1 chtp + let nv2 = setAttrChildName v2 chtp + return (nv1, nv2) + return $ concat bs + -- Concatenate all lists of backedges + let backedges = concat lBackEdges + -- Now add backedges to every nonterminal graph + forM_ ndis $ \ndi -> do + -- Find the backedges for this nonterminal + let nont = ndiNonterminal . ndimOrig $ ndi + let thisbe = filter ((==) nont . getAttrChildName . fst) backedges + -- Add them to the graph + graphInsertEdgesTRC (ndgmDepGraph . ndimDepGraph $ ndi) thisbe 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.38.3" +banner = "Attribute Grammar compiler / HUT project. Version 0.9.38.4" 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.38.3 +version: 0.9.38.4 license: GPL license-file: LICENSE maintainer: Arie Middelkoop @@ -77,6 +77,9 @@ , VisagePatterns , AG2AspectAG , RhsCheck + , Knuth1 + , KennedyWarren + , KWOrder 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.38.3 +version: 0.9.38.4 license: GPL license-file: LICENSE maintainer: Arie Middelkoop