packages feed

uuagc 0.9.53.1 → 0.9.54

raw patch · 112 files changed

+29595/−25274 lines, 112 filesdep +aesondep +bytestringdep ~uuagc-cabalsetup-changed

Dependencies added: aeson, bytestring

Dependency ranges changed: uuagc-cabal

Files

LICENSE view
@@ -1,23 +1,23 @@-All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are met:
-    * Redistributions of source code must retain the above copyright
-      notice, this list of conditions and the following disclaimer.
-    * Redistributions in binary form must reproduce the above copyright
-      notice, this list of conditions and the following disclaimer in the
-      documentation and/or other materials provided with the distribution.
-    * Neither the name of the Universiteit Utrecht nor the
-      names of its contributors may be used to endorse or promote products
-      derived from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-DISCLAIMED. IN NO EVENT SHALL UNIVERSITEIT UTRECHT BE LIABLE FOR ANY
-DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
-(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
-LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
-ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.+    * Redistributions in binary form must reproduce the above copyright+      notice, this list of conditions and the following disclaimer in the+      documentation and/or other materials provided with the distribution.+    * Neither the name of the Universiteit Utrecht nor the+      names of its contributors may be used to endorse or promote products+      derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL UNIVERSITEIT UTRECHT BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
README view
@@ -1,19 +1,19 @@-To install UUAG, use cabal in combination with Setup.hs
-
-By default, "cabal install" will install UUAGC from the
-included Haskell sources. To build from the AG sources
-using an existing uuagc installation, use:
-
-cabal install --ghc-options="-DEXTERNAL_UUAGC"
-
-Note: to produce a source release, you'll need to use the
-Setup.hs because cabal-install at the time is not able to
-do this in combination with the cabal plugin:
-
---
-cabal clean    # remove possible junk
-ghc --make Setup.hs -o setup
-./setup configure --user
-./setup build
-./setup sdist
---
+To install UUAG, use cabal in combination with Setup.hs++By default, "cabal install" will install UUAGC from the+included Haskell sources. To build from the AG sources+using an existing uuagc installation, use:++cabal install --ghc-options="-DEXTERNAL_UUAGC"++Note: to produce a source release, you'll need to use the+Setup.hs because cabal-install at the time is not able to+do this in combination with the cabal plugin:++--+cabal clean    # remove possible junk+ghc --make Setup.hs -o setup+./setup configure --user+./setup build+./setup sdist+--
Setup.hs view
@@ -1,40 +1,40 @@--- Note: to bootstrap uuagc with a commandline uuagc,
--- pass the -DEXTERNAL_UUAGC to GHC
--- when building setup.hs. This can be accomplished using
--- cabal install with --ghc-options="-DEXTERNAL_UUAGC".
---
--- When this option is used, a cabal flag will be set so
--- that the Haskell sources will be regenerated from
--- the attribute grammar sources
---
--- Note: it would be nicer if this behavior could be enabled
--- with a configure flag. However, a compiled Setup.hs is
--- required in order to perform 'configure', so configure
--- flags are regarded too late in the process.
--- Also note that this Setup.hs has conditional package
--- requirements depending on what code is used.
-
-{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
-{-# LANGUAGE CPP #-}
-module Main where
-
-#ifdef EXTERNAL_UUAGC
-import System.Environment (getArgs)
-import Distribution.Simple (defaultMainWithHooksArgs)
-import Distribution.Simple.UUAGC (uuagcUserHook)
-
-main :: IO ()
-main = args >>= defaultMainWithHooksArgs uuagcUserHook
-
-args :: IO [String]
-args = do
-  as <- getArgs
-  let addFlags | "configure" `elem` as = ("--flags=bootstrap_external" :)
-               | otherwise             = id
-  return (addFlags as)
-#else
-import Distribution.Simple (defaultMain, defaultMainWithHooksArgs)
-
-main :: IO ()
-main = defaultMain
-#endif
+-- Note: to bootstrap uuagc with a commandline uuagc,+-- pass the -DEXTERNAL_UUAGC to GHC+-- when building setup.hs. This can be accomplished using+-- cabal install with --ghc-options="-DEXTERNAL_UUAGC".+--+-- When this option is used, a cabal flag will be set so+-- that the Haskell sources will be regenerated from+-- the attribute grammar sources+--+-- Note: it would be nicer if this behavior could be enabled+-- with a configure flag. However, a compiled Setup.hs is+-- required in order to perform 'configure', so configure+-- flags are regarded too late in the process.+-- Also note that this Setup.hs has conditional package+-- requirements depending on what code is used.++{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}+{-# LANGUAGE CPP #-}+module Main where++#ifdef EXTERNAL_UUAGC+import System.Environment (getArgs)+import Distribution.Simple (defaultMainWithHooksArgs)+import Distribution.Simple.UUAGC (uuagcUserHook)++main :: IO ()+main = args >>= defaultMainWithHooksArgs uuagcUserHook++args :: IO [String]+args = do+  as <- getArgs+  let addFlags | "configure" `elem` as = ("--flags=bootstrap_external" :)+               | otherwise             = id+  return (addFlags as)+#else+import Distribution.Simple (defaultMain, defaultMainWithHooksArgs)++main :: IO ()+main = defaultMain+#endif
src-ag/AG2AspectAG.ag view
@@ -1,857 +1,857 @@-INCLUDE "AbstractSyntax.ag"
-INCLUDE "Patterns.ag"
-INCLUDE "Expression.ag"
-INCLUDE "HsToken.ag"
-INCLUDE "DistChildAttr.ag"
-
-imports
-{
-import Options
-
-import Data.Char
-import Data.List
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import Data.Maybe
-
-import Pretty
-import PPUtil
-import UU.Scanner.Position
-
-import AbstractSyntax
-import TokenDef
-import CommonTypes
-
--- import Debug.Trace
-}
-
-{
-pragmaAspectAG =  pp  "{-# LANGUAGE EmptyDataDecls, NoMonomorphismRestriction , TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-}"
-
-}
-
-{
-ppName l = ppListSep "" "" "_" l
-}
-
-
-ATTR Grammar [ options : Options | | ]
-
-
-ATTR Nonterminals Nonterminal Productions Production Children Child [ o_rename : Bool | | ]
-SEM Grammar
-  | Grammar  nonts.o_rename    = rename    @lhs.options
-
-ATTR Nonterminals Nonterminal Productions Production Children Child Rules Rule   [ o_noGroup : {[String]} | | ]
-SEM Grammar
-  | Grammar  loc.o_noGroup     = sort $ noGroup    @lhs.options
-             nonts.o_noGroup   = @loc.o_noGroup
-
-SEM Nonterminal
-  | Nonterminal  loc.inhNoGroup     = Map.filterWithKey (\att _ -> elem (getName att) @lhs.o_noGroup) @prods.prdInh
-  | Nonterminal  loc.synNoGroup     = Map.filterWithKey (\att _ -> elem (getName att) @lhs.o_noGroup) @syn
-
-
-ATTR Productions Production Children Child Rules Rule [ inhNoGroup, synNoGroup : {[String]}  | | ]
-SEM Nonterminal
-  | Nonterminal  prods.inhNoGroup     = map show $ Map.keys @loc.inhNoGroup
-  | Nonterminal  prods.synNoGroup     = map show $ Map.keys @loc.synNoGroup
-
-
-SEM Productions
-  | Cons  hd.inhNoGroup     = filter (flip Map.member @hd.prdInh . identifier) @lhs.inhNoGroup
-
-
-ATTR Productions Production Children Child [ | | prdInh USE {`Map.union`} {Map.empty} : {Attributes}  ]
-SEM Child
-  | Child  lhs.prdInh     = @loc.inh
-
-
-{
-type FieldMap  = [(Identifier, Type)]
-type DataTypes = Map.Map NontermIdent (Map.Map ConstructorIdent FieldMap)
-}
-
-ATTR Grammar   [ agi : {(Set NontermIdent, DataTypes, Map NontermIdent (Attributes, Attributes))} | | ]
-
-
-ATTR Nonterminals Nonterminal Productions Production  Children Child Rules Rule [ newAtts : { Attributes } | | ]
-
-SEM Grammar | Grammar loc.newAtts     = case @lhs.agi of
-                                                (_,_,atts) -> ( Map.unions . (\(a,b) -> a++b) . unzip . Map.elems) atts
-                      nonts.newAtts   = @loc.newAtts
-
-
-ATTR Nonterminals Nonterminal  [ newProds : { DataTypes } | | ]
-ATTR Productions Production    [ newProds : { Map.Map ConstructorIdent FieldMap } | | ]
-
-SEM Grammar | Grammar loc.newProds     = case @lhs.agi of
-                                                (_,prods,_) -> prods
-                      nonts.newProds   = @loc.newProds
-
-
-SEM Nonterminal
-  | Nonterminal prods.newProds = case Map.lookup @nt @lhs.newProds of
-                                        Just prds -> prds
-                                        Nothing   -> Map.empty
-
-
-ATTR Nonterminals Nonterminal  [ newNTs : {Set NontermIdent}  | | ]
-
-ATTR Productions Production    [ | | hasMoreProds USE { || } {False} : { Bool } ]
-
-SEM Production | Production lhs.hasMoreProds = not $ Map.member @con @lhs.newProds
-
-ATTR Nonterminals Nonterminal    [ | | extendedNTs USE {`Set.union`} {Set.empty} : {Set NontermIdent} ]
-
-SEM Nonterminal | Nonterminal lhs.extendedNTs = if @prods.hasMoreProds
-                                                then Set.singleton @nt
-                                                else Set.empty
-
-
-SEM Grammar | Grammar nonts.newNTs    = case @lhs.agi of
-                                                (newNTs,_,_) -> Set.difference newNTs @nonts.extendedNTs
-
-
-
-
-
-ATTR Grammar Nonterminals Nonterminal Productions Production Children Child Rules Rule [ ext : {Maybe String} | | ]
-
-
--- IMPORT
-
-ATTR Grammar [ | | imp USE {>-<} {empty} : PP_Doc ]
-
-SEM Grammar
-  | Grammar             lhs     .       imp     =  "import Language.Grammars.AspectAG" >-<
-                                                   "import Language.Grammars.AspectAG.Derive" >-<
-                                                   "import Data.HList.Label4" >-<
-                                                   "import Data.HList.TypeEqGeneric1" >-<
-                                                   "import Data.HList.TypeCastGeneric1" >-<
-                                                   maybe empty ("import qualified" >#<) @lhs.ext >-<
-                                                   maybe empty (\ext -> "import" >#< ext >#< ppListSep "(" ")" "," (@nonts.ppDI ++ @nonts.ppLI ++ @loc.ppAI ++ @loc.ppANT)) @lhs.ext
-
--- CODE
-
-ATTR Grammar [ | | pp USE {>-<} {empty} : PP_Doc ]
-
-SEM Grammar
-  | Grammar             lhs     .       pp      =  (if dataTypes @lhs.options
-                                                   then  "-- datatypes"               >-< @nonts.ppD >-<
-                                                         "-- labels"                  >-< @nonts.ppL
-                                                   else  empty)
-
-                                                   >-<
-
-                                                   (if folds @lhs.options
-                                                   then  "-- attributes"              >-< @loc.ppA >-<
-                                                         "-- rules"                   >-< @loc.ppR >-<
-                                                         "-- catas"                   >-< @nonts.ppCata
-
-                                                   else  empty)
-
-                                                   >-<
-
-
-                                                   (if semfuns @lhs.options
-                                                   then  "-- semantic functions"      >-< @nonts.ppSF
-                                                   else  empty)
-
-
-                                                   >-<
-
-                                                   (if wrappers @lhs.options
-                                                   then  "-- wrappers"    >-< @nonts.ppW
-                                                   else  empty)
-
-
-
--- data definitions
-
-SEM Nonterminal
-  | Nonterminal         loc       .     ppNt     =  pp @nt
-
-SEM Production
-  | Production          loc       .     ppProd   =  pp @con
-                        loc       .     prodName =  ppName [@lhs.ppNt, @loc.ppProd]
-                        loc       .     conName  =  if @lhs.o_rename
-                                                    then @loc.prodName
-                                                    else @loc.ppProd
-SEM Child
-  | Child               loc       .     ppCh     =  pp @name
-                        loc       .     ppTCh    =  ppShow @tp
-                        loc       .     chName   =  ppName [@loc.ppCh, @lhs.ppNt, @lhs.ppProd]
-
-
-ATTR Productions Production Rules Rule Children Child Expression [ ppNt : PP_Doc | |  ]
-
-SEM Nonterminal
-  | Nonterminal         prods     .     ppNt    =  @loc.ppNt
-
-ATTR Rules Rule Children Child Expression [ ppProd : PP_Doc | |  ]
-
-SEM Production
-  | Production          children  .     ppProd  =  @loc.ppProd
-                        rules     .     ppProd  =  @loc.ppProd
-
-
-ATTR Nonterminals Nonterminal [ derivs : {Derivings} | |  ]
-
-SEM Grammar
-  | Grammar             nonts     .     derivs  =  @derivings
-
-
-ATTR Nonterminals Nonterminal Production [ | | ppD USE {>-<} {empty} : {PP_Doc} ppDI USE {++} {[]} : {[PP_Doc]} ]
-
-SEM Nonterminal
-  | Nonterminal         lhs     .       ppD     =
-                                     if (Set.member @nt @lhs.newNTs)
-                                     then  case (lookup @nt @lhs.tSyns) of
-                                                    -- if it's a data type
-                                                    Nothing ->  "data " >|< @loc.ppNt
-                                                                 >|< " = " >|< vlist_sep " | " @prods.ppDL >-<
-                                                                case (Map.lookup @nt @lhs.derivs) of
-                                                                 Just ntds -> pp "  deriving " >|<  (ppListSep "(" ")" ", " $ Set.elems ntds)
-                                                                 Nothing   -> empty -- uncommented for testing purposes 
-                                                    -- if it's a type synonym
-                                                    Just tp ->  "type " >|< @loc.ppNt >|< " = " >|< ppShow tp
-                                     else  empty
-
-                        lhs     .       ppDI            =
-                                     if (not $ Set.member @nt @lhs.newNTs)
-                                     then  [ @loc.ppNt ]
-                                     else  [ ]
--- uncommented for testing purposes
-
-SEM Production
-  | Production          lhs     .       ppD     = @loc.conName >|< ppListSep " {" "}" ", " @children.ppDL
-
-
-ATTR Productions Children Child  [ | | ppDL : {[PP_Doc]} ]
-
-SEM Productions
-  | Cons                        lhs             .       ppDL            =       @hd.ppD : @tl.ppDL
-  | Nil                         lhs             .       ppDL            =       []
-
-SEM Children
-  | Cons                        lhs             .       ppDL            =       @hd.ppDL ++ @tl.ppDL
-  | Nil                         lhs             .       ppDL            =       []
-
-SEM Child
-  | Child               lhs     .       ppDL    = case @kind of
-                                                   ChildSyntax    ->  [ @loc.chName  >|< pp " :: " >|< @loc.ppTCh ]
-                                                   _              ->  []
-
-
-
-ATTR Nonterminals Nonterminal  [ tSyns : {TypeSyns} | |  ]
-
-SEM Grammar
-  | Grammar                      nonts          .       tSyns           =       @typeSyns
-
-
-
-
--- grammar labels
-
-
-ATTR Nonterminals Nonterminal Productions Production Children Child [ | | ppL USE {>-<} {empty} : PP_Doc  ppLI USE {++} {[]} : {[PP_Doc]}  ]
-
-SEM Nonterminal
-  | Nonterminal         loc     .       ntLabel = "nt_" >|< @loc.ppNt
-
-                        lhs     .       ppL     =  ( if (Set.member @nt @lhs.newNTs)
-                                                     then @loc.ntLabel >|< " = proxy :: Proxy " >|< @loc.ppNt
-                                                     else empty)  >-<
-                                                   @prods.ppL
-
-                        lhs     .       ppLI    =  ( if (not $ Set.member @nt @lhs.newNTs)
-                                                     then [ @loc.ntLabel ]
-                                                     else [ ])  ++
-                                                   @prods.ppLI
-
-SEM Production
-  | Production          lhs     .       ppL     =  if (Map.member @con @lhs.newProds)
-                                                     then @children.ppL
-                                                     else empty
-
-                        lhs     .       ppLI    =  if (not $ Map.member @con @lhs.newProds)
-                                                     then @children.ppLI
-                                                     else []
-
-
-SEM Child
-  | Child               loc     .       chLabel  = "ch_" >|< @loc.chName
-                        loc     .       chTLabel = "Ch_" >|< @loc.chName
-                        lhs     .       ppL      = "data " >|< @loc.chTLabel >|< "; " >|< @loc.chLabel >|< pp " = proxy :: " >|<
-                                                   case @kind of
-                                                    ChildSyntax    ->  "Proxy " >|< "(" >|< @loc.chTLabel >|< ", " >|< @loc.ppTCh >|< ")"
-                                                    _              ->  "SemType " >|< @loc.ppTCh >|< pp " nt =>  Proxy " >|<
-                                                                       "(" >|< @loc.chTLabel >|< ", nt)"
-
-                        lhs     .       ppLI     = [ @loc.chLabel, @loc.chTLabel ]
-
-
--- attributes
-
-
-SEM Grammar
-  | Grammar             loc     .       ppA     =  vlist (map defAtt (filterAtts @loc.newAtts @loc.o_noGroup)) >-<     -- not grouped
-                                                   defAtt "loc" >-<                                                    -- local
-                                                   (case @lhs.ext of
-                                                     Nothing    ->  defAtt "inh" >-< defAtt "syn"                      -- grouped
-                                                     otherwise  ->  empty) >-<
-                                                   @nonts.ppA                                                          -- record definitions
-
-                        loc     .       ppAI    =
-                                                let atts =  filterNotAtts @loc.newAtts @loc.o_noGroup
-                                                in  (foldr (\a as -> attName a : as) [] atts) ++
-                                                    (foldr (\a as -> attTName a : as) [] atts) ++
-                                                    (case @lhs.ext of
-                                                      Nothing    ->  []
-                                                      otherwise  ->  [ attName "inh", attName "syn", attTName "inh", attTName "syn" ]) ++
-                                                    @nonts.ppAI
-
-
-                        loc     .       ppANT   =
-                                                let atts =  filterNotAtts @loc.newAtts @loc.o_noGroup
-                                                in  (foldr (\a as -> ("nts_" >|< a) : as) [] atts)
-
-ATTR Nonterminals Nonterminal Productions Production [ | | ppA USE {>-<} {empty} : PP_Doc ]
-
-SEM Nonterminal
-  | Nonterminal         lhs     .       ppA     =  ( if (Set.member @nt @lhs.newNTs)
-                                                     then   
-                                                            defAttRec (pp "InhG") @loc.ppNt @inh @loc.inhNoGroup >-<
-                                                            defAttRec (pp "SynG") @loc.ppNt @syn @loc.synNoGroup 
-                                                     else   empty) >-<
-                                                   @prods.ppA
-
-SEM Production
-  | Production          lhs     .       ppA     =  defLocalAtts @loc.prodName (length @rules.locals) 1 $ sort @rules.locals
-
-
-ATTR Nonterminals Nonterminal [ | | ppAI USE {++} {[]} : {[PP_Doc]} ]
-
-SEM Nonterminal
-  | Nonterminal         lhs     .       ppAI    =  if (not $ Set.member @nt @lhs.newNTs)
-                                                   then [ ppName [(pp "InhG"), @loc.ppNt ] >#< pp "(..)", ppName [(pp "SynG"), @loc.ppNt ] >#< pp "(..)" ]
-                                                   else [ ]
-
-{
-filterAtts newAtts = filter (\att -> Map.member (identifier att) newAtts)
-filterNotAtts newAtts = filter (\att -> not (Map.member (identifier att) newAtts))
-
-defAtt  att = "data " >|< attTName att >|< "; " >|< attName att >|< " = proxy :: Proxy " >|< attTName att
-attName att = pp $ "att_" ++ att
-attTName att = pp $ "Att_" ++ att
-
-
-defAttRec  recPref ppNt atts noGroup  =
-           let     recName    = ppName [recPref, ppNt]
-                   fields     = ppCommas (map (\(a,t) -> ppName [pp a, recName ] >|< " ::" >|< ppShow t) (groupAtts atts noGroup))
-           in
-                   "data " >|<  recName >|< " = " >|< recName >|< " { " >|<   fields  >|< " }"
-
-groupAtts atts noGroup = (Map.toAscList . Map.difference atts) noGroup
-
--- it defines selectors with the form:
--- l1_nt_prod(x, _, .., _) = x
--- ln_nt_prod(_, .., _, x) = x
-defLocalAtts prodName total actual (l:ls) =  ppName [pp l, prodName] >|<
-                                             ppListSep "(" ")" ","  (replicate (actual-1) "_" ++ "x" : replicate (total-actual) "_") >|<
-                                             pp " = x" >-<
-                                             defLocalAtts prodName total (actual+1) ls
-defLocalAtts _        _     _      []     =  empty
-
-}
-
-
-ATTR Rules Rule [ | | locals USE {++} {[]} : {[Identifier]} ]
-
-
-SEM Rule
-  | Rule                lhs     .       locals    =  if (show (fst @pattern.info) == "loc")
-                                                      then [ snd @pattern.info ]
-                                                      else [ ]
-
-
-ATTR Pattern [ || info : {(Identifier, Identifier)} ]
-SEM Pattern
-  | Alias               lhs     .       info    = (@field, @attr)
-  | Constr              lhs     .       info    = error "Pattern Constr undefined!!"
-  | Product             lhs     .       info    = error "Pattern Product undefined!!"
-  | Underscore          lhs     .       info    = error "Pattern Underscore undefined!!"
-
-
-
--- rules
-
-SEM Grammar
-  | Grammar             loc     .       ppNtL   =  @nonts.ppNtL
-                        loc     .       ppR     =  ntsList "group" @loc.ppNtL  >-<
-                                                   vlist (map (\att -> ntsList att (filterNts att @loc.ppNtL)) (filterAtts @newAtts @loc.o_noGroup))  >-<
-                                                   @nonts.ppR
-
-{
-ntsList att ppNtL = "nts_" ++ att ++ " = " >|<  ppListSep "" "" " .*. " ((map fst ppNtL) ++ [pp "hNil"])
-
-filterNts att = filter ( Map.member (identifier att) . snd )
-}
-
-ATTR Nonterminals Nonterminal  [ | | ppNtL USE {++} {[]} : {[(PP_Doc, Attributes)]} ] -- list of nonterminals and its attributes
-
-SEM Nonterminal
-  | Nonterminal         lhs     .       ppNtL   =  [ ("nt_" >|< @nt, Map.union @inh @syn) ]
-
-
-
-
-ATTR Productions Production    [ newNT : {Bool} | |  ]
-ATTR Rules Rule    [ newProd : {Bool} | |  ]
-
-SEM Nonterminal
-  | Nonterminal         prods     .       newNT     =  Set.member @nt @lhs.newNTs
-
-
-ATTR Nonterminals Nonterminal Productions Production Children Child [ | | ppR USE {>-<} {empty} : PP_Doc ]
-ATTR Productions Production    [ | | ppRA USE {++} {[]} : {[PP_Doc]} ]
-
-
-
-
-SEM Nonterminal
-  | Nonterminal         lhs     .       ppR     =  pp "----" >|< pp @nt >-< @prods.ppR
-
-SEM Production
-  | Production          loc     .       newProd  = Map.member @con @lhs.newProds
-                        loc     .       (ppR,ppRA)
-                           =  let  (instR, instRA)  = defInstRules  @lhs.ppNt @con @lhs.newNT @loc.newProd
-                                                                    @children.ppR @rules.ppRL @children.idCL @rules.locals
-                                   (locR,  locRA)   = defLocRule    @lhs.ppNt @con @lhs.newNT @loc.newProd
-                                                                    @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals
-                                   (inhGR, inhGRA)  = defInhGRule   @lhs.ppNt @loc.prodName @lhs.newNT @loc.newProd
-                                                                    @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals
-                                   (synGR, synGRA)  = defSynGRule   @lhs.ppNt @con @lhs.newNT @loc.newProd
-                                                                    @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals
-                                   (inhR,  inhRA)   = defInhRules   @lhs.ppNt @loc.prodName @lhs.newNT @loc.newProd @lhs.newAtts
-                                                                    @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals
-                                   (synR,  synRA)   = defSynRules   @lhs.ppNt @con @lhs.newNT @loc.newProd @lhs.newAtts
-                                                                    @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals
-                                   (inhMR,  inhMRA) = modInhRules   @lhs.ppNt @loc.prodName @lhs.newNT @loc.newProd @lhs.newAtts
-                                                                    @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals
-                                   (synMR,  synMRA) = modSynRules   @lhs.ppNt @con @lhs.newNT @loc.newProd @lhs.newAtts
-                                                                    @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup  @children.idCL @rules.locals
-                              in   ( vlist [instR,locR,inhGR,synGR,inhR,synR,inhMR,synMR]
-                                   , instRA ++ locRA ++ inhGRA ++ synGRA ++ inhMRA ++ synMRA ++ inhRA ++ synRA)
-
-
-SEM Child
-  | Child               lhs     .       ppR     =  let chName = ppListSep "" "" "_" [pp @name, @lhs.ppNt, @lhs.ppProd]
-                                                   in  pp @name >|< " <- at ch_" >|< chName
-
-
-{
-data PPRule = PPRule Identifier Identifier Bool ([(Identifier,Type)] -> [Identifier] -> PP_Doc)
-
-ppRule (field,attr) owrt def = PPRule field attr owrt def
-ruleField (PPRule field  _     _     _  ) = field
-ruleAttr  (PPRule _      attr  _     _  ) = attr
-ruleOwrt  (PPRule _      _     owrt  _  ) = owrt
-ruleDef   (PPRule _      _     _     def) = def
-
-}
-ATTR Rules Rule [ | | ppRL  : {[ PPRule ]} ]
-
-SEM Rules
-  | Cons                        lhs             .       ppRL            =       @hd.ppRL ++ @tl.ppRL
-  | Nil                         lhs             .       ppRL            =       []
-
-SEM Rule
-  | Rule                        lhs             .       ppRL            =  if (not @explicit &&  not @lhs.newProd && not (Map.member (snd @pattern.info) @lhs.newAtts) )
-                                                                           then []
-                                                                           else [ ppRule @pattern.info @owrt (defRule @lhs.ppNt @pattern.info @lhs.o_noGroup @rhs.ppRE) ]
-
-{-
-ATTR Expression [ | | ppRE : {Identifier -> [String] -> [String] -> [(Identifier,Type)] -> [Identifier] -> PP_Doc} ]
-SEM Expression
-   | Expression         lhs     .       ppRE     =  rhsRule @lhs.ppNt @lhs.ppProd @tks
--}
-
-ATTR Expression [ | | ppRE : {[String] -> Identifier -> [(Identifier,Type)] -> [Identifier] -> PP_Doc} ]
-SEM Expression
-   | Expression         lhs     .       ppRE     =  rhsRule @lhs.ppNt @lhs.ppProd @tks
-
-
-ATTR Children Child [ || idCL USE {++} {[]} : {[(Identifier,Type)]} ]
-SEM Child
- | Child                lhs     .        idCL   = [ (@name, removeDeforested @tp ) ]
-
-
-
-
-{
-
-defInhGRule ppNt prodName newNT newProd ch rules inhNoGroup synNoGroup chids locals =
-                       let  ppAtt = ppName [pp "inh", prodName]
-                            ppR =  ppAtt >|< pp " = inhdefM att_inh nts_group $" >-<
-                                   indent 4  "do " >-<
-                                   indent 5  "loc <- at loc" >-<
-                                   indent 5  "lhs <- at lhs" >-<
-                                   indent 5  ch >-<
-                                   indent 5  "return $"  >-<
-                                   indent 6  (foldr (>-<) (pp "emptyRecord") (map (chGRule ppNt prodName rules inhNoGroup synNoGroup chids locals) chids))
-                       in  if (newNT || (not newNT && newProd))
-                           then (ppR, [ ppAtt ])
-                           else (empty, [])
-
-chGRule ppNt prodName rules inhNoGroup synNoGroup chids locals (idCh,tp) =
-                       let  chName = ppName [pp "ch", pp idCh, prodName]
-                            ppTp   = ppShow tp
-                            chRules = ppCommas $ mapGRuleDefs (== idCh)  rules inhNoGroup synNoGroup chids locals
-                       in   if (isNonterminal tp)
-                             then   chName >|< ".=." >-<
-                                    indent 1 "InhG_" >|< ppShow tp >|< pp " {"  >-<
-                                    indent 2 chRules >-<
-                                    indent 1 "} .*. "
-                             else   empty
-
-
-defSynGRule ppNt prod newNT newProd ch rules inhNoGroup synNoGroup chids locals =
-                       let  ppAtt = ppName [pp "syn", ppNt, pp prod]
-                            ppTAtt = "SynG_" >|< ppNt
-                            ppR =  ppAtt >|< pp " = syndefM att_syn $" >-<
-                                   indent 4  "do " >-<
-                                   indent 5  "loc <- at loc" >-<
-                                   indent 5  "lhs <- at lhs" >-<
-                                   indent 5  ch >-<
-                                   indent 5  "return $"  >-<
-                                   indent 6  ppTAtt >|< pp " {"  >-<
-                                   indent 7  (ppCommas $ mapGRuleDefs ((== "lhs") . show)  rules inhNoGroup synNoGroup chids locals) >-<
-                                   indent 6  "}"
-                       in  if (newNT || (not newNT && newProd))
-                           then (ppR, [ ppAtt ])
-                           else (empty, [])
-
-defLocRule ppNt prod newNT newProd ch rules inhNoGroup synNoGroup chids locals =
-                       let  ppAtt  = ppName [pp "loc", ppNt, pp prod]
-                            ppTAtt = ppName [pp "Loc", ppNt, pp prod]
-                            ppR =    ppAtt >|< pp " = locdefM att_loc $" >-<
-                                     indent 4  "do " >-<
-                                     indent 5  "loc <- at loc" >-<
-                                     indent 5  "lhs <- at lhs" >-<
-                                     indent 5  ch >-<
-                                     indent 5  "return $"  >-<
-                                     indent 6  (ppListSep "(" ")" "," $ mapLRuleDefs rules inhNoGroup synNoGroup chids locals)
-                       in  (ppR, [ ppAtt ])
-
-defInstRules ppNt prod newNT newProd ch rules chids locals
-                                             = let  ppAsp     = ppName [pp "inst", ppNt, pp prod]
-                                                    instRules = filter ((=="inst") . show . ruleField) rules
-                                                    ppAtt att = ppListSep "`ext` " "" "_" [pp "inst_ch", pp att, ppNt, pp prod]
-                                               in   (  ppAsp >|< pp " = emptyRule " >|< (map (ppAtt . ruleAttr) instRules) >-<
-                                                       (vlist $ map (defInstRule  ppNt prod ch chids locals) instRules)
-                                                    ,  [ ppAsp ])
-
-
-defInstRule  ppNt prod ch chids locals rule =
-                       let  ppAtt  = ppName [pp "ch", pp (ruleAttr rule), ppNt, pp prod]
-                       in   pp "inst_" >|< ppAtt >|< pp " = instdefM " >|< ppAtt >|< pp " $" >-<
-                            indent 4  "do " >-<
-                            indent 5  "loc <- at loc" >-<
-                            indent 5  "lhs <- at lhs" >-<
-                            indent 5  ch >-<
-                            indent 5  "return $"  >-<
-                            indent 6  ((ruleDef rule) chids locals)
-
-
-defSynRules ppNt prod newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals
-                                             = let  synRules     = filter ( (=="lhs") . show . ruleField)  rules
-                                                    ngRules      = filter ((flip elem synNoGroup) . getName . ruleAttr) synRules
-                                                    (ppR, ppRA)  = unzip $  map (defSynRule True ppNt prod newNT newProd newAtts ch chids locals) ngRules
-                                               in   (vlist ppR, concat ppRA )
-
-modSynRules ppNt prod newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals
-                                             = let  synRules     = filter ( (=="lhs") . show . ruleField)  rules
-                                                    ngRules      = filter ((flip elem synNoGroup) . getName . ruleAttr) synRules
-                                                    (ppR, ppRA)  = unzip $  map (defSynRule False ppNt prod newNT newProd newAtts ch chids locals) ngRules
-                                               in   (vlist ppR, concat ppRA )
-
-defSynRule  new ppNt prod newNT newProd newAtts ch chids locals rule =
-                       let  att    = ruleAttr rule
-                            newAtt = Map.member att newAtts
-                            owrt   = ruleOwrt rule
-                            ppAtt  = ppName [pp att, pp (if new then "syn" else "synM"), ppNt, pp prod]
-                            ppR def =   ppAtt >|< pp (" = " ++ def ++ " ") >|< attName (show att) >|< pp " $" >-<
-                                        indent 4  "do " >-<
-                                        indent 5  "loc <- at loc" >-<
-                                        indent 5  "lhs <- at lhs" >-<
-                                        indent 5  ch >-<
-                                        indent 5  "return $"  >-<
-                                        indent 6  ((ruleDef rule) chids locals)
-                       in   
-                           if new
-                           then  if (not owrt && (newNT || (not newNT && newProd) || newAtt))
-                                 then  (ppR "syndefM", [ ppAtt ])
-                                 else  (empty,         [])
-                           else  if owrt
-                                 then  (ppR "synmodM", [ ppAtt ])
-                                 else  (empty,         [])
-
-
-
-defInhRules ppNt prodName newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals
-                                             = let  ngRules      = filter ((flip elem inhNoGroup) . getName . ruleAttr) rules
-                                                    (ppR, ppRA)  = unzip $ map (defInhRule True  ppNt prodName newNT newProd newAtts ch ngRules inhNoGroup synNoGroup chids locals) inhNoGroup
-                                               in   (vlist ppR, concat ppRA)
-
-modInhRules ppNt prodName newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals
-                                             = let  ngRules      = filter ((flip elem inhNoGroup) . getName . ruleAttr) rules
-                                                    (ppR, ppRA)  = unzip $ map (defInhRule  False ppNt prodName newNT newProd newAtts ch ngRules inhNoGroup synNoGroup chids locals) inhNoGroup
-                                               in   (vlist ppR, concat ppRA)
-
-
-defInhRule new ppNt prodName newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals att =
-                       let  ppAtt       =  ppName [pp att, pp (if new then "inh" else "inhM"),prodName]
-                            newAtt      =  Map.member (identifier att) newAtts
-                            chRMaybe    =  map (chRule new ppNt prodName att rules inhNoGroup synNoGroup chids locals) chids
-                            chR         =  [ x | (Just x) <- chRMaybe ]
-                            ppR def  =  ppAtt >|< pp (" = " ++ def ++ " ") >|< attName att >|< " nts_" >|< att >|< " $" >-<
-                                        indent 4  "do " >-<
-                                        indent 5  "loc <- at loc" >-<
-                                        indent 5  "lhs <- at lhs" >-<
-                                        indent 5  ch >-<
-                                        indent 5  "return $"  >-<
-                                        indent 6  (foldr (>-<) (pp "emptyRecord") chR)
-                       in
-                           if new
-                           then  if (newNT || (not newNT && newProd) || newAtt)
-                                 then  (ppR "inhdefM", [ ppAtt ])
-                                 else  (empty,         [])
-                           else  if (not . null) chR
-                                 then  (ppR "inhmodM", [ ppAtt ])
-                                 else  (empty,         [])
-
-
-chRule new ppNt prodName att rules inhNoGroup synNoGroup chids locals (idCh,tp) =
-                       let  chName = ppName [pp "ch", pp idCh, prodName]
-                            ppTp   = ppShow tp
-                            chRule = inhRuleDef new (== idCh) (== att) rules inhNoGroup synNoGroup chids locals  -- it's supposed to be only one
-                       in   if (isNonterminal tp && (not . null) chRule)
-                             then   Just $ chName >|< ".=. (" >|< chRule >|< ") .*. "
-                             else   Nothing
-
-
-mapLRuleDefs rules inhNoGroup synNoGroup chids locals
-                 = map appSnd $ sortBy cmpField $ filter ((== "loc") . show . ruleField)  rules
-                                      where cmpField r1 r2 = compare (ruleField r1) (ruleField r2)
-                                            appSnd rule = (ruleDef rule)  chids locals
-
-
-mapGRuleDefs filt rules inhNoGroup synNoGroup chids locals
-                 = map appSnd $ sortBy cmpField $ filter (not . (flip elem inhNoGroup) . getName . ruleAttr)
-                                                $ filter (not . (flip elem synNoGroup) . getName . ruleAttr)
-                                                $ filter ( filt . ruleField)  rules
-                                      where cmpField r1 r2 = compare (ruleField r1) (ruleField r2)
-                                            appSnd rule = (ruleDef rule)  chids locals
-
-inhRuleDef new filt1 filt2 rules inhNoGroup synNoGroup chids locals
-                 = map appSnd $ sortBy cmpField $ filter ( (== not new) . ruleOwrt)
-                                                $ filter ((flip elem inhNoGroup) . getName . ruleAttr)
-                                                $ filter ( filt2 . getName . ruleAttr)
-                                                $ filter ( filt1 . ruleField)  rules
-                                      where cmpField r1 r2 = compare (ruleField r1) (ruleField r2)
-                                            appSnd rule = (ruleDef rule)  chids locals
-
-defRule ppNt (field,att) noGroup rhs = \chids locals ->
-                                     let ppAtt = if (elem (getName att) noGroup)
-                                                  then empty
-                                                  else case (show field) of
-                                                        "lhs"     -> att >|< "_" >|< pp "SynG" >|< pp "_" >|< ppNt  >|< " = "
-                                                        "loc"     -> empty
-                                                        "inst"    -> empty
-                                                        otherwise -> att >|< "_" >|< pp "InhG" >|< pp "_" >|<
-                                                                     (maybe (error $ "lhs field " ++ show field ++" is not a child")
-                                                                            ppShow (lookup field chids))
-                                                                     >|< " = "
-                                     in  ppAtt >|< (rhs noGroup field chids locals)
-
-
-rhsRule ppNt ppProd tks noGroup field chids locals  =  vlist . lines2PP . (map (token2PP ppNt ppProd field chids locals noGroup )) $ tks
-
-
-lines2PP [] = []
-lines2PP xs = map line2PP . shiftLeft . getLines $ xs
-
-
-token2PP ppNt ppProd field chids locals noGroup  tk
-  = case tk of
-      AGLocal var pos _        -> (pos, if (elem var locals)
-                                        then  (ppListSep "(" "" "_" [pp var, ppNt, ppProd]) >|< pp " (loc # att_loc)) "
-                                        else  pp var)
-      AGField field attr pos _ -> let ppChT =    maybe (error $ "rhs field " ++ show field ++ " is not a child") ppShow (lookup field chids)
-                                      ppAtt =    case (show field) of
-                                                 "lhs"      ->  attName "inh"
-                                                 "loc"      ->  attName "loc"
-                                                 otherwise  ->  attName "syn"
-                                      ppSubAtt = case (show field) of
-                                                 "lhs"      -> ppName [pp (getName attr), pp "InhG", ppNt]
-                                                 "loc"      -> ppName [pp (getName attr), ppNt, ppProd]
-                                                 otherwise  -> ppName [pp (getName attr), pp "SynG", ppChT]
-                                  in  (pos, if ((elem (getName attr) noGroup) && ((show field) /= "loc"))
-                                             then pp "(" >|< pp (getName field)  >|< " # " >|< attName (getName attr) >|< pp ")"
-                                             else pp "(" >|< ppSubAtt >|< " (" >|< pp (getName field) >|< " # " >|< ppAtt >|< ")) ")
-      HsToken value pos        -> (pos, pp value)
-      CharToken value pos      -> (pos, pp (show value))
-      StrToken value pos       -> (pos, pp (show value))
-      Err mesg pos             -> (pos, pp $ " ***" ++ mesg ++ "*** ")
-
-line2PP ts =         let f (p,t) r = let ct = column p
-                                     in \c -> pp (spaces (ct-c)) >|< t >|< r (length (show t) +ct)
-                         spaces x | x < 0 = ""
-                                  | otherwise = replicate x ' '
-                     in foldr f (pp . const "") ts 1
-
-}
-
-----------------------------------------------------------------------------------------------------------------------------------------------
-
-
-{
-ppMacro (Macro con children) = "( atts_" >|< show con >|< ", " >|<  ppListSep "" "" " <.> " ppChildren  >|<")"
-                where   ppChildren = map  ppChild children
-                        ppChild (RuleChild  ch n) = chName ch >|< " ==> " >|< ppMacro n
-                        ppChild (ChildChild ch n) = chName ch >|< " --> " >|< n
-                        ppChild (ValueChild ch n) = chName ch >|< " ~~> " >|< n
-                        chName ch = ppName [pp "ch", pp ch, pp con]
-}
-
--- catamorphisms
-
-ATTR Nonterminals Nonterminal Productions Production [ | | ppCata USE {>-<} {empty} : PP_Doc ]
-
-SEM Nonterminal
-  | Nonterminal         lhs     .      ppCata    =  "----" >|< @loc.ppNt >-< @prods.ppCata
-
-
-SEM Production
-  | Production          lhs     .      ppCata    =
-                                            let  extend = maybe  []
-                                                                 (  \ext ->  if (@lhs.newNT || (not @lhs.newNT && @loc.newProd))
-                                                                             then []
-                                                                             else [ ext >|< ".atts_" >|< @loc.prodName ])
-                                                                 @lhs.ext
-                                                 macro  = case @macro of
-                                                                             Nothing ->  []
-                                                                             Just macro ->  [ "agMacro " >|<  ppMacro macro  ]
-                                                 atts = sortBy (\a b -> compare (show a) (show b)) @loc.ppRA
-                                            in   "atts_" >|< @loc.prodName >|< " = " >|<
-                                                                               ppListSep "" "" " `ext` "
-                                                                               (atts ++ macro ++ extend ) >-<
-                                                 "semP_" >|< @loc.prodName >|< pp " = knit atts_" >|< @loc.prodName
-
-{
-ppNoGroupAtts syn noGroup = let synatts = Map.keys $ Map.filterWithKey (\att _ -> elem (getName att) noGroup) syn
-                            in  map (flip (>|<) "_inh") noGroup ++  map (flip (>|<) "_syn") synatts
-
-ruleName att prodName = ppName [att,prodName]
-
-elemNT a b = False
-}
-
-ATTR Productions Production [ syn, inh : { Attributes } | | ]
-
-SEM Nonterminal
-  | Nonterminal         prods     .     syn     =  @syn
-                        prods     .     inh     =  @inh
-
-
-
--- semantic functions
-
-ATTR Nonterminals Nonterminal Productions Production  [ | | ppSF USE {>-<} {empty} : PP_Doc ]
-ATTR Productions Production  [ | | ppSPF USE {>-<} {empty} : PP_Doc ]
-
-
-SEM Nonterminal
-  | Nonterminal         lhs     .       ppSF            =
-                                         let      inhAtts = attTypes @loc.inhNoGroup
-                                                  synAtts = attTypes @loc.synNoGroup
-                                         in
-                                                  "----" >|< @loc.ppNt >-<
-                                                  "type T_" >|< @loc.ppNt >|< " = " >|<
-                                                  "(Record " >|<
-                                                  inhAtts >|<
-                                                  "(HCons (LVPair (Proxy Att_inh) InhG_" >|< @loc.ppNt >|< ") HNil))" >|<
-                                                  replicate (length inhAtts) ")" >|< " -> " >|<
-                                                  "(Record " >|<
-                                                  synAtts >|<
-                                                  "(HCons (LVPair (Proxy Att_syn) SynG_" >|< @loc.ppNt >|< ") HNil))" >|<
-                                                  replicate (length synAtts) ")" >-<
-                                                  "-- instance SemType T_" >|< @loc.ppNt >|< " " >|< @loc.ppNt >-<
-                                                  "-- sem_" >|< @loc.ppNt >|< " :: " >|< @loc.ppNt >|< " -> T_" >|<  @loc.ppNt >-<
-                                                  @prods.ppSPF -- >-<
-                                                  -- @prods.ppSF
-
-{
-attTypes atts = map (\(a,t) -> "(HCons (LVPair (Proxy Att_" >|< a >|< ") " >|< ppShow t >|< ") ") $ Map.toAscList atts
-}
-
-
-SEM Production
-  | Production          lhs     .       ppSF            =
-                                            let  chi = @children.ppCSF
-                                                 ppPattern = case (show @con) of
-                                                              -- hardcoded list support
-                                                              "Cons"    -> ppParams (ppListSep "" "" " : ")
-                                                              "Nil"     -> pp "[]"
-                                                              -- general case
-                                                              otherwise -> @loc.conName >|< " " >|< (ppParams ppSpaced)
-
-                                                 ppParams f =   f $ map (((>|<) (pp "_")) . fst) chi
-                                            in   "sem_" >|< @lhs.ppNt >|< " (" >|< ppPattern >|< ") = sem_" >|< @loc.prodName >|<
-                                                 " (" >|< map (fst . snd) chi >|< "emptyRecord)"
-                        lhs     .       ppSPF           =
-                                            let  chi = @children.ppCSF
-                                                 ppParams f =   f $ map (((>|<) (pp "_")) . fst) chi
-                                            in   "sem_" >|< @lhs.ppNt >|< "_" >|< @con >#< ppParams ppSpaced >|< " = semP_" >|< @loc.prodName >|<
-                                                 " (" >|< map (snd . snd) chi >|< "emptyRecord)"
-
-
-ATTR Children Child  [ | | ppCSF USE {++} {[]} : {[(Identifier,(PP_Doc,PP_Doc))]} ]
-
-
-SEM Child
-  | Child               lhs     .       ppCSF           =
-                                            let
-                                                 semC   = if (isNonterminal @tp)
-                                                           then "sem_" >|< ppShow @tp >|<  " _" >|< @name
-                                                           else "sem_Lit _" >|< @name
-                                            in   case @kind of
-                                                      ChildSyntax ->  [(@name, (  @loc.chLabel >|< " .=. (" >|< semC >|< ") .*. "
-                                                                              ,  @loc.chLabel >|< " .=. _" >|< @name >|< " .*. "))]
-                                                      _           ->  []
-
-
-
-
--- wrappers
-
---TODO: create the records Inh_nt and Syn_nt to wrap the attributes
-
-ATTR Nonterminals Nonterminal  [ | | ppW USE {>-<} {empty} : PP_Doc ]
-
-SEM Nonterminal
-  | Nonterminal         lhs     .       ppW     =
-                                            ppName [pp "wrap", @loc.ppNt] >|< " sem " >|< attVars @inh >|< " = " >-<
-                                            "   sem " >|< attFields @inh @loc.inhNoGroup @loc.ppNt
-
-
-{
-attVars atts = map (\(a,_) -> "_" >|< a >|< " ") $ Map.toAscList atts
-attFields atts noGroup ppNt =
-     let ng = map (\(a,_) -> attName (getName a) >|< " .=. _" >|< a >|< " .*. ") $ Map.toAscList noGroup
-         g  = ppCommas $ map (\(a,_) -> ppName [pp a, pp "InhG",ppNt]  >|< "= _" >|< a) $ Map.toAscList $ Map.difference atts noGroup
-     in "(" >|< ng >|< "att_inh .=. " >|< ppName [pp "InhG", ppNt] >|< " { " >|< g >|< " } .*. emptyRecord)"
-}
+INCLUDE "AbstractSyntax.ag"+INCLUDE "Patterns.ag"+INCLUDE "Expression.ag"+INCLUDE "HsToken.ag"+INCLUDE "DistChildAttr.ag"++imports+{+import Options++import Data.Char+import Data.List+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Maybe++import Pretty+import PPUtil+import UU.Scanner.Position++import AbstractSyntax+import TokenDef+import CommonTypes++-- import Debug.Trace+}++{+pragmaAspectAG =  pp  "{-# LANGUAGE EmptyDataDecls, NoMonomorphismRestriction , TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-}"++}++{+ppName l = ppListSep "" "" "_" l+}+++ATTR Grammar [ options : Options | | ]+++ATTR Nonterminals Nonterminal Productions Production Children Child [ o_rename : Bool | | ]+SEM Grammar+  | Grammar  nonts.o_rename    = rename    @lhs.options++ATTR Nonterminals Nonterminal Productions Production Children Child Rules Rule   [ o_noGroup : {[String]} | | ]+SEM Grammar+  | Grammar  loc.o_noGroup     = sort $ noGroup    @lhs.options+             nonts.o_noGroup   = @loc.o_noGroup++SEM Nonterminal+  | Nonterminal  loc.inhNoGroup     = Map.filterWithKey (\att _ -> elem (getName att) @lhs.o_noGroup) @prods.prdInh+  | Nonterminal  loc.synNoGroup     = Map.filterWithKey (\att _ -> elem (getName att) @lhs.o_noGroup) @syn+++ATTR Productions Production Children Child Rules Rule [ inhNoGroup, synNoGroup : {[String]}  | | ]+SEM Nonterminal+  | Nonterminal  prods.inhNoGroup     = map show $ Map.keys @loc.inhNoGroup+  | Nonterminal  prods.synNoGroup     = map show $ Map.keys @loc.synNoGroup+++SEM Productions+  | Cons  hd.inhNoGroup     = filter (flip Map.member @hd.prdInh . identifier) @lhs.inhNoGroup+++ATTR Productions Production Children Child [ | | prdInh USE {`Map.union`} {Map.empty} : {Attributes}  ]+SEM Child+  | Child  lhs.prdInh     = @loc.inh+++{+type FieldMap  = [(Identifier, Type)]+type DataTypes = Map.Map NontermIdent (Map.Map ConstructorIdent FieldMap)+}++ATTR Grammar   [ agi : {(Set NontermIdent, DataTypes, Map NontermIdent (Attributes, Attributes))} | | ]+++ATTR Nonterminals Nonterminal Productions Production  Children Child Rules Rule [ newAtts : { Attributes } | | ]++SEM Grammar | Grammar loc.newAtts     = case @lhs.agi of+                                                (_,_,atts) -> ( Map.unions . (\(a,b) -> a++b) . unzip . Map.elems) atts+                      nonts.newAtts   = @loc.newAtts+++ATTR Nonterminals Nonterminal  [ newProds : { DataTypes } | | ]+ATTR Productions Production    [ newProds : { Map.Map ConstructorIdent FieldMap } | | ]++SEM Grammar | Grammar loc.newProds     = case @lhs.agi of+                                                (_,prods,_) -> prods+                      nonts.newProds   = @loc.newProds+++SEM Nonterminal+  | Nonterminal prods.newProds = case Map.lookup @nt @lhs.newProds of+                                        Just prds -> prds+                                        Nothing   -> Map.empty+++ATTR Nonterminals Nonterminal  [ newNTs : {Set NontermIdent}  | | ]++ATTR Productions Production    [ | | hasMoreProds USE { || } {False} : { Bool } ]++SEM Production | Production lhs.hasMoreProds = not $ Map.member @con @lhs.newProds++ATTR Nonterminals Nonterminal    [ | | extendedNTs USE {`Set.union`} {Set.empty} : {Set NontermIdent} ]++SEM Nonterminal | Nonterminal lhs.extendedNTs = if @prods.hasMoreProds+                                                then Set.singleton @nt+                                                else Set.empty+++SEM Grammar | Grammar nonts.newNTs    = case @lhs.agi of+                                                (newNTs,_,_) -> Set.difference newNTs @nonts.extendedNTs++++++ATTR Grammar Nonterminals Nonterminal Productions Production Children Child Rules Rule [ ext : {Maybe String} | | ]+++-- IMPORT++ATTR Grammar [ | | imp USE {>-<} {empty} : PP_Doc ]++SEM Grammar+  | Grammar             lhs     .       imp     =  "import Language.Grammars.AspectAG" >-<+                                                   "import Language.Grammars.AspectAG.Derive" >-<+                                                   "import Data.HList.Label4" >-<+                                                   "import Data.HList.TypeEqGeneric1" >-<+                                                   "import Data.HList.TypeCastGeneric1" >-<+                                                   maybe empty ("import qualified" >#<) @lhs.ext >-<+                                                   maybe empty (\ext -> "import" >#< ext >#< ppListSep "(" ")" "," (@nonts.ppDI ++ @nonts.ppLI ++ @loc.ppAI ++ @loc.ppANT)) @lhs.ext++-- CODE++ATTR Grammar [ | | pp USE {>-<} {empty} : PP_Doc ]++SEM Grammar+  | Grammar             lhs     .       pp      =  (if dataTypes @lhs.options+                                                   then  "-- datatypes"               >-< @nonts.ppD >-<+                                                         "-- labels"                  >-< @nonts.ppL+                                                   else  empty)++                                                   >-<++                                                   (if folds @lhs.options+                                                   then  "-- attributes"              >-< @loc.ppA >-<+                                                         "-- rules"                   >-< @loc.ppR >-<+                                                         "-- catas"                   >-< @nonts.ppCata++                                                   else  empty)++                                                   >-<+++                                                   (if semfuns @lhs.options+                                                   then  "-- semantic functions"      >-< @nonts.ppSF+                                                   else  empty)+++                                                   >-<++                                                   (if wrappers @lhs.options+                                                   then  "-- wrappers"    >-< @nonts.ppW+                                                   else  empty)++++-- data definitions++SEM Nonterminal+  | Nonterminal         loc       .     ppNt     =  pp @nt++SEM Production+  | Production          loc       .     ppProd   =  pp @con+                        loc       .     prodName =  ppName [@lhs.ppNt, @loc.ppProd]+                        loc       .     conName  =  if @lhs.o_rename+                                                    then @loc.prodName+                                                    else @loc.ppProd+SEM Child+  | Child               loc       .     ppCh     =  pp @name+                        loc       .     ppTCh    =  ppShow @tp+                        loc       .     chName   =  ppName [@loc.ppCh, @lhs.ppNt, @lhs.ppProd]+++ATTR Productions Production Rules Rule Children Child Expression [ ppNt : PP_Doc | |  ]++SEM Nonterminal+  | Nonterminal         prods     .     ppNt    =  @loc.ppNt++ATTR Rules Rule Children Child Expression [ ppProd : PP_Doc | |  ]++SEM Production+  | Production          children  .     ppProd  =  @loc.ppProd+                        rules     .     ppProd  =  @loc.ppProd+++ATTR Nonterminals Nonterminal [ derivs : {Derivings} | |  ]++SEM Grammar+  | Grammar             nonts     .     derivs  =  @derivings+++ATTR Nonterminals Nonterminal Production [ | | ppD USE {>-<} {empty} : {PP_Doc} ppDI USE {++} {[]} : {[PP_Doc]} ]++SEM Nonterminal+  | Nonterminal         lhs     .       ppD     =+                                     if (Set.member @nt @lhs.newNTs)+                                     then  case (lookup @nt @lhs.tSyns) of+                                                    -- if it's a data type+                                                    Nothing ->  "data " >|< @loc.ppNt+                                                                 >|< " = " >|< vlist_sep " | " @prods.ppDL >-<+                                                                case (Map.lookup @nt @lhs.derivs) of+                                                                 Just ntds -> pp "  deriving " >|<  (ppListSep "(" ")" ", " $ Set.elems ntds)+                                                                 Nothing   -> empty -- uncommented for testing purposes +                                                    -- if it's a type synonym+                                                    Just tp ->  "type " >|< @loc.ppNt >|< " = " >|< ppShow tp+                                     else  empty++                        lhs     .       ppDI            =+                                     if (not $ Set.member @nt @lhs.newNTs)+                                     then  [ @loc.ppNt ]+                                     else  [ ]+-- uncommented for testing purposes++SEM Production+  | Production          lhs     .       ppD     = @loc.conName >|< ppListSep " {" "}" ", " @children.ppDL+++ATTR Productions Children Child  [ | | ppDL : {[PP_Doc]} ]++SEM Productions+  | Cons                        lhs             .       ppDL            =       @hd.ppD : @tl.ppDL+  | Nil                         lhs             .       ppDL            =       []++SEM Children+  | Cons                        lhs             .       ppDL            =       @hd.ppDL ++ @tl.ppDL+  | Nil                         lhs             .       ppDL            =       []++SEM Child+  | Child               lhs     .       ppDL    = case @kind of+                                                   ChildSyntax    ->  [ @loc.chName  >|< pp " :: " >|< @loc.ppTCh ]+                                                   _              ->  []++++ATTR Nonterminals Nonterminal  [ tSyns : {TypeSyns} | |  ]++SEM Grammar+  | Grammar                      nonts          .       tSyns           =       @typeSyns+++++-- grammar labels+++ATTR Nonterminals Nonterminal Productions Production Children Child [ | | ppL USE {>-<} {empty} : PP_Doc  ppLI USE {++} {[]} : {[PP_Doc]}  ]++SEM Nonterminal+  | Nonterminal         loc     .       ntLabel = "nt_" >|< @loc.ppNt++                        lhs     .       ppL     =  ( if (Set.member @nt @lhs.newNTs)+                                                     then @loc.ntLabel >|< " = proxy :: Proxy " >|< @loc.ppNt+                                                     else empty)  >-<+                                                   @prods.ppL++                        lhs     .       ppLI    =  ( if (not $ Set.member @nt @lhs.newNTs)+                                                     then [ @loc.ntLabel ]+                                                     else [ ])  +++                                                   @prods.ppLI++SEM Production+  | Production          lhs     .       ppL     =  if (Map.member @con @lhs.newProds)+                                                     then @children.ppL+                                                     else empty++                        lhs     .       ppLI    =  if (not $ Map.member @con @lhs.newProds)+                                                     then @children.ppLI+                                                     else []+++SEM Child+  | Child               loc     .       chLabel  = "ch_" >|< @loc.chName+                        loc     .       chTLabel = "Ch_" >|< @loc.chName+                        lhs     .       ppL      = "data " >|< @loc.chTLabel >|< "; " >|< @loc.chLabel >|< pp " = proxy :: " >|<+                                                   case @kind of+                                                    ChildSyntax    ->  "Proxy " >|< "(" >|< @loc.chTLabel >|< ", " >|< @loc.ppTCh >|< ")"+                                                    _              ->  "SemType " >|< @loc.ppTCh >|< pp " nt =>  Proxy " >|<+                                                                       "(" >|< @loc.chTLabel >|< ", nt)"++                        lhs     .       ppLI     = [ @loc.chLabel, @loc.chTLabel ]+++-- attributes+++SEM Grammar+  | Grammar             loc     .       ppA     =  vlist (map defAtt (filterAtts @loc.newAtts @loc.o_noGroup)) >-<     -- not grouped+                                                   defAtt "loc" >-<                                                    -- local+                                                   (case @lhs.ext of+                                                     Nothing    ->  defAtt "inh" >-< defAtt "syn"                      -- grouped+                                                     otherwise  ->  empty) >-<+                                                   @nonts.ppA                                                          -- record definitions++                        loc     .       ppAI    =+                                                let atts =  filterNotAtts @loc.newAtts @loc.o_noGroup+                                                in  (foldr (\a as -> attName a : as) [] atts) +++                                                    (foldr (\a as -> attTName a : as) [] atts) +++                                                    (case @lhs.ext of+                                                      Nothing    ->  []+                                                      otherwise  ->  [ attName "inh", attName "syn", attTName "inh", attTName "syn" ]) +++                                                    @nonts.ppAI+++                        loc     .       ppANT   =+                                                let atts =  filterNotAtts @loc.newAtts @loc.o_noGroup+                                                in  (foldr (\a as -> ("nts_" >|< a) : as) [] atts)++ATTR Nonterminals Nonterminal Productions Production [ | | ppA USE {>-<} {empty} : PP_Doc ]++SEM Nonterminal+  | Nonterminal         lhs     .       ppA     =  ( if (Set.member @nt @lhs.newNTs)+                                                     then   +                                                            defAttRec (pp "InhG") @loc.ppNt @inh @loc.inhNoGroup >-<+                                                            defAttRec (pp "SynG") @loc.ppNt @syn @loc.synNoGroup +                                                     else   empty) >-<+                                                   @prods.ppA++SEM Production+  | Production          lhs     .       ppA     =  defLocalAtts @loc.prodName (length @rules.locals) 1 $ sort @rules.locals+++ATTR Nonterminals Nonterminal [ | | ppAI USE {++} {[]} : {[PP_Doc]} ]++SEM Nonterminal+  | Nonterminal         lhs     .       ppAI    =  if (not $ Set.member @nt @lhs.newNTs)+                                                   then [ ppName [(pp "InhG"), @loc.ppNt ] >#< pp "(..)", ppName [(pp "SynG"), @loc.ppNt ] >#< pp "(..)" ]+                                                   else [ ]++{+filterAtts newAtts = filter (\att -> Map.member (identifier att) newAtts)+filterNotAtts newAtts = filter (\att -> not (Map.member (identifier att) newAtts))++defAtt  att = "data " >|< attTName att >|< "; " >|< attName att >|< " = proxy :: Proxy " >|< attTName att+attName att = pp $ "att_" ++ att+attTName att = pp $ "Att_" ++ att+++defAttRec  recPref ppNt atts noGroup  =+           let     recName    = ppName [recPref, ppNt]+                   fields     = ppCommas (map (\(a,t) -> ppName [pp a, recName ] >|< " ::" >|< ppShow t) (groupAtts atts noGroup))+           in+                   "data " >|<  recName >|< " = " >|< recName >|< " { " >|<   fields  >|< " }"++groupAtts atts noGroup = (Map.toAscList . Map.difference atts) noGroup++-- it defines selectors with the form:+-- l1_nt_prod(x, _, .., _) = x+-- ln_nt_prod(_, .., _, x) = x+defLocalAtts prodName total actual (l:ls) =  ppName [pp l, prodName] >|<+                                             ppListSep "(" ")" ","  (replicate (actual-1) "_" ++ "x" : replicate (total-actual) "_") >|<+                                             pp " = x" >-<+                                             defLocalAtts prodName total (actual+1) ls+defLocalAtts _        _     _      []     =  empty++}+++ATTR Rules Rule [ | | locals USE {++} {[]} : {[Identifier]} ]+++SEM Rule+  | Rule                lhs     .       locals    =  if (show (fst @pattern.info) == "loc")+                                                      then [ snd @pattern.info ]+                                                      else [ ]+++ATTR Pattern [ || info : {(Identifier, Identifier)} ]+SEM Pattern+  | Alias               lhs     .       info    = (@field, @attr)+  | Constr              lhs     .       info    = error "Pattern Constr undefined!!"+  | Product             lhs     .       info    = error "Pattern Product undefined!!"+  | Underscore          lhs     .       info    = error "Pattern Underscore undefined!!"++++-- rules++SEM Grammar+  | Grammar             loc     .       ppNtL   =  @nonts.ppNtL+                        loc     .       ppR     =  ntsList "group" @loc.ppNtL  >-<+                                                   vlist (map (\att -> ntsList att (filterNts att @loc.ppNtL)) (filterAtts @newAtts @loc.o_noGroup))  >-<+                                                   @nonts.ppR++{+ntsList att ppNtL = "nts_" ++ att ++ " = " >|<  ppListSep "" "" " .*. " ((map fst ppNtL) ++ [pp "hNil"])++filterNts att = filter ( Map.member (identifier att) . snd )+}++ATTR Nonterminals Nonterminal  [ | | ppNtL USE {++} {[]} : {[(PP_Doc, Attributes)]} ] -- list of nonterminals and its attributes++SEM Nonterminal+  | Nonterminal         lhs     .       ppNtL   =  [ ("nt_" >|< @nt, Map.union @inh @syn) ]+++++ATTR Productions Production    [ newNT : {Bool} | |  ]+ATTR Rules Rule    [ newProd : {Bool} | |  ]++SEM Nonterminal+  | Nonterminal         prods     .       newNT     =  Set.member @nt @lhs.newNTs+++ATTR Nonterminals Nonterminal Productions Production Children Child [ | | ppR USE {>-<} {empty} : PP_Doc ]+ATTR Productions Production    [ | | ppRA USE {++} {[]} : {[PP_Doc]} ]+++++SEM Nonterminal+  | Nonterminal         lhs     .       ppR     =  pp "----" >|< pp @nt >-< @prods.ppR++SEM Production+  | Production          loc     .       newProd  = Map.member @con @lhs.newProds+                        loc     .       (ppR,ppRA)+                           =  let  (instR, instRA)  = defInstRules  @lhs.ppNt @con @lhs.newNT @loc.newProd+                                                                    @children.ppR @rules.ppRL @children.idCL @rules.locals+                                   (locR,  locRA)   = defLocRule    @lhs.ppNt @con @lhs.newNT @loc.newProd+                                                                    @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals+                                   (inhGR, inhGRA)  = defInhGRule   @lhs.ppNt @loc.prodName @lhs.newNT @loc.newProd+                                                                    @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals+                                   (synGR, synGRA)  = defSynGRule   @lhs.ppNt @con @lhs.newNT @loc.newProd+                                                                    @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals+                                   (inhR,  inhRA)   = defInhRules   @lhs.ppNt @loc.prodName @lhs.newNT @loc.newProd @lhs.newAtts+                                                                    @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals+                                   (synR,  synRA)   = defSynRules   @lhs.ppNt @con @lhs.newNT @loc.newProd @lhs.newAtts+                                                                    @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals+                                   (inhMR,  inhMRA) = modInhRules   @lhs.ppNt @loc.prodName @lhs.newNT @loc.newProd @lhs.newAtts+                                                                    @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals+                                   (synMR,  synMRA) = modSynRules   @lhs.ppNt @con @lhs.newNT @loc.newProd @lhs.newAtts+                                                                    @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup  @children.idCL @rules.locals+                              in   ( vlist [instR,locR,inhGR,synGR,inhR,synR,inhMR,synMR]+                                   , instRA ++ locRA ++ inhGRA ++ synGRA ++ inhMRA ++ synMRA ++ inhRA ++ synRA)+++SEM Child+  | Child               lhs     .       ppR     =  let chName = ppListSep "" "" "_" [pp @name, @lhs.ppNt, @lhs.ppProd]+                                                   in  pp @name >|< " <- at ch_" >|< chName+++{+data PPRule = PPRule Identifier Identifier Bool ([(Identifier,Type)] -> [Identifier] -> PP_Doc)++ppRule (field,attr) owrt def = PPRule field attr owrt def+ruleField (PPRule field  _     _     _  ) = field+ruleAttr  (PPRule _      attr  _     _  ) = attr+ruleOwrt  (PPRule _      _     owrt  _  ) = owrt+ruleDef   (PPRule _      _     _     def) = def++}+ATTR Rules Rule [ | | ppRL  : {[ PPRule ]} ]++SEM Rules+  | Cons                        lhs             .       ppRL            =       @hd.ppRL ++ @tl.ppRL+  | Nil                         lhs             .       ppRL            =       []++SEM Rule+  | Rule                        lhs             .       ppRL            =  if (not @explicit &&  not @lhs.newProd && not (Map.member (snd @pattern.info) @lhs.newAtts) )+                                                                           then []+                                                                           else [ ppRule @pattern.info @owrt (defRule @lhs.ppNt @pattern.info @lhs.o_noGroup @rhs.ppRE) ]++{-+ATTR Expression [ | | ppRE : {Identifier -> [String] -> [String] -> [(Identifier,Type)] -> [Identifier] -> PP_Doc} ]+SEM Expression+   | Expression         lhs     .       ppRE     =  rhsRule @lhs.ppNt @lhs.ppProd @tks+-}++ATTR Expression [ | | ppRE : {[String] -> Identifier -> [(Identifier,Type)] -> [Identifier] -> PP_Doc} ]+SEM Expression+   | Expression         lhs     .       ppRE     =  rhsRule @lhs.ppNt @lhs.ppProd @tks+++ATTR Children Child [ || idCL USE {++} {[]} : {[(Identifier,Type)]} ]+SEM Child+ | Child                lhs     .        idCL   = [ (@name, removeDeforested @tp ) ]+++++{++defInhGRule ppNt prodName newNT newProd ch rules inhNoGroup synNoGroup chids locals =+                       let  ppAtt = ppName [pp "inh", prodName]+                            ppR =  ppAtt >|< pp " = inhdefM att_inh nts_group $" >-<+                                   indent 4  "do " >-<+                                   indent 5  "loc <- at loc" >-<+                                   indent 5  "lhs <- at lhs" >-<+                                   indent 5  ch >-<+                                   indent 5  "return $"  >-<+                                   indent 6  (foldr (>-<) (pp "emptyRecord") (map (chGRule ppNt prodName rules inhNoGroup synNoGroup chids locals) chids))+                       in  if (newNT || (not newNT && newProd))+                           then (ppR, [ ppAtt ])+                           else (empty, [])++chGRule ppNt prodName rules inhNoGroup synNoGroup chids locals (idCh,tp) =+                       let  chName = ppName [pp "ch", pp idCh, prodName]+                            ppTp   = ppShow tp+                            chRules = ppCommas $ mapGRuleDefs (== idCh)  rules inhNoGroup synNoGroup chids locals+                       in   if (isNonterminal tp)+                             then   chName >|< ".=." >-<+                                    indent 1 "InhG_" >|< ppShow tp >|< pp " {"  >-<+                                    indent 2 chRules >-<+                                    indent 1 "} .*. "+                             else   empty+++defSynGRule ppNt prod newNT newProd ch rules inhNoGroup synNoGroup chids locals =+                       let  ppAtt = ppName [pp "syn", ppNt, pp prod]+                            ppTAtt = "SynG_" >|< ppNt+                            ppR =  ppAtt >|< pp " = syndefM att_syn $" >-<+                                   indent 4  "do " >-<+                                   indent 5  "loc <- at loc" >-<+                                   indent 5  "lhs <- at lhs" >-<+                                   indent 5  ch >-<+                                   indent 5  "return $"  >-<+                                   indent 6  ppTAtt >|< pp " {"  >-<+                                   indent 7  (ppCommas $ mapGRuleDefs ((== "lhs") . show)  rules inhNoGroup synNoGroup chids locals) >-<+                                   indent 6  "}"+                       in  if (newNT || (not newNT && newProd))+                           then (ppR, [ ppAtt ])+                           else (empty, [])++defLocRule ppNt prod newNT newProd ch rules inhNoGroup synNoGroup chids locals =+                       let  ppAtt  = ppName [pp "loc", ppNt, pp prod]+                            ppTAtt = ppName [pp "Loc", ppNt, pp prod]+                            ppR =    ppAtt >|< pp " = locdefM att_loc $" >-<+                                     indent 4  "do " >-<+                                     indent 5  "loc <- at loc" >-<+                                     indent 5  "lhs <- at lhs" >-<+                                     indent 5  ch >-<+                                     indent 5  "return $"  >-<+                                     indent 6  (ppListSep "(" ")" "," $ mapLRuleDefs rules inhNoGroup synNoGroup chids locals)+                       in  (ppR, [ ppAtt ])++defInstRules ppNt prod newNT newProd ch rules chids locals+                                             = let  ppAsp     = ppName [pp "inst", ppNt, pp prod]+                                                    instRules = filter ((=="inst") . show . ruleField) rules+                                                    ppAtt att = ppListSep "`ext` " "" "_" [pp "inst_ch", pp att, ppNt, pp prod]+                                               in   (  ppAsp >|< pp " = emptyRule " >|< (map (ppAtt . ruleAttr) instRules) >-<+                                                       (vlist $ map (defInstRule  ppNt prod ch chids locals) instRules)+                                                    ,  [ ppAsp ])+++defInstRule  ppNt prod ch chids locals rule =+                       let  ppAtt  = ppName [pp "ch", pp (ruleAttr rule), ppNt, pp prod]+                       in   pp "inst_" >|< ppAtt >|< pp " = instdefM " >|< ppAtt >|< pp " $" >-<+                            indent 4  "do " >-<+                            indent 5  "loc <- at loc" >-<+                            indent 5  "lhs <- at lhs" >-<+                            indent 5  ch >-<+                            indent 5  "return $"  >-<+                            indent 6  ((ruleDef rule) chids locals)+++defSynRules ppNt prod newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals+                                             = let  synRules     = filter ( (=="lhs") . show . ruleField)  rules+                                                    ngRules      = filter ((flip elem synNoGroup) . getName . ruleAttr) synRules+                                                    (ppR, ppRA)  = unzip $  map (defSynRule True ppNt prod newNT newProd newAtts ch chids locals) ngRules+                                               in   (vlist ppR, concat ppRA )++modSynRules ppNt prod newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals+                                             = let  synRules     = filter ( (=="lhs") . show . ruleField)  rules+                                                    ngRules      = filter ((flip elem synNoGroup) . getName . ruleAttr) synRules+                                                    (ppR, ppRA)  = unzip $  map (defSynRule False ppNt prod newNT newProd newAtts ch chids locals) ngRules+                                               in   (vlist ppR, concat ppRA )++defSynRule  new ppNt prod newNT newProd newAtts ch chids locals rule =+                       let  att    = ruleAttr rule+                            newAtt = Map.member att newAtts+                            owrt   = ruleOwrt rule+                            ppAtt  = ppName [pp att, pp (if new then "syn" else "synM"), ppNt, pp prod]+                            ppR def =   ppAtt >|< pp (" = " ++ def ++ " ") >|< attName (show att) >|< pp " $" >-<+                                        indent 4  "do " >-<+                                        indent 5  "loc <- at loc" >-<+                                        indent 5  "lhs <- at lhs" >-<+                                        indent 5  ch >-<+                                        indent 5  "return $"  >-<+                                        indent 6  ((ruleDef rule) chids locals)+                       in   +                           if new+                           then  if (not owrt && (newNT || (not newNT && newProd) || newAtt))+                                 then  (ppR "syndefM", [ ppAtt ])+                                 else  (empty,         [])+                           else  if owrt+                                 then  (ppR "synmodM", [ ppAtt ])+                                 else  (empty,         [])++++defInhRules ppNt prodName newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals+                                             = let  ngRules      = filter ((flip elem inhNoGroup) . getName . ruleAttr) rules+                                                    (ppR, ppRA)  = unzip $ map (defInhRule True  ppNt prodName newNT newProd newAtts ch ngRules inhNoGroup synNoGroup chids locals) inhNoGroup+                                               in   (vlist ppR, concat ppRA)++modInhRules ppNt prodName newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals+                                             = let  ngRules      = filter ((flip elem inhNoGroup) . getName . ruleAttr) rules+                                                    (ppR, ppRA)  = unzip $ map (defInhRule  False ppNt prodName newNT newProd newAtts ch ngRules inhNoGroup synNoGroup chids locals) inhNoGroup+                                               in   (vlist ppR, concat ppRA)+++defInhRule new ppNt prodName newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals att =+                       let  ppAtt       =  ppName [pp att, pp (if new then "inh" else "inhM"),prodName]+                            newAtt      =  Map.member (identifier att) newAtts+                            chRMaybe    =  map (chRule new ppNt prodName att rules inhNoGroup synNoGroup chids locals) chids+                            chR         =  [ x | (Just x) <- chRMaybe ]+                            ppR def  =  ppAtt >|< pp (" = " ++ def ++ " ") >|< attName att >|< " nts_" >|< att >|< " $" >-<+                                        indent 4  "do " >-<+                                        indent 5  "loc <- at loc" >-<+                                        indent 5  "lhs <- at lhs" >-<+                                        indent 5  ch >-<+                                        indent 5  "return $"  >-<+                                        indent 6  (foldr (>-<) (pp "emptyRecord") chR)+                       in+                           if new+                           then  if (newNT || (not newNT && newProd) || newAtt)+                                 then  (ppR "inhdefM", [ ppAtt ])+                                 else  (empty,         [])+                           else  if (not . null) chR+                                 then  (ppR "inhmodM", [ ppAtt ])+                                 else  (empty,         [])+++chRule new ppNt prodName att rules inhNoGroup synNoGroup chids locals (idCh,tp) =+                       let  chName = ppName [pp "ch", pp idCh, prodName]+                            ppTp   = ppShow tp+                            chRule = inhRuleDef new (== idCh) (== att) rules inhNoGroup synNoGroup chids locals  -- it's supposed to be only one+                       in   if (isNonterminal tp && (not . null) chRule)+                             then   Just $ chName >|< ".=. (" >|< chRule >|< ") .*. "+                             else   Nothing+++mapLRuleDefs rules inhNoGroup synNoGroup chids locals+                 = map appSnd $ sortBy cmpField $ filter ((== "loc") . show . ruleField)  rules+                                      where cmpField r1 r2 = compare (ruleField r1) (ruleField r2)+                                            appSnd rule = (ruleDef rule)  chids locals+++mapGRuleDefs filt rules inhNoGroup synNoGroup chids locals+                 = map appSnd $ sortBy cmpField $ filter (not . (flip elem inhNoGroup) . getName . ruleAttr)+                                                $ filter (not . (flip elem synNoGroup) . getName . ruleAttr)+                                                $ filter ( filt . ruleField)  rules+                                      where cmpField r1 r2 = compare (ruleField r1) (ruleField r2)+                                            appSnd rule = (ruleDef rule)  chids locals++inhRuleDef new filt1 filt2 rules inhNoGroup synNoGroup chids locals+                 = map appSnd $ sortBy cmpField $ filter ( (== not new) . ruleOwrt)+                                                $ filter ((flip elem inhNoGroup) . getName . ruleAttr)+                                                $ filter ( filt2 . getName . ruleAttr)+                                                $ filter ( filt1 . ruleField)  rules+                                      where cmpField r1 r2 = compare (ruleField r1) (ruleField r2)+                                            appSnd rule = (ruleDef rule)  chids locals++defRule ppNt (field,att) noGroup rhs = \chids locals ->+                                     let ppAtt = if (elem (getName att) noGroup)+                                                  then empty+                                                  else case (show field) of+                                                        "lhs"     -> att >|< "_" >|< pp "SynG" >|< pp "_" >|< ppNt  >|< " = "+                                                        "loc"     -> empty+                                                        "inst"    -> empty+                                                        otherwise -> att >|< "_" >|< pp "InhG" >|< pp "_" >|<+                                                                     (maybe (error $ "lhs field " ++ show field ++" is not a child")+                                                                            ppShow (lookup field chids))+                                                                     >|< " = "+                                     in  ppAtt >|< (rhs noGroup field chids locals)+++rhsRule ppNt ppProd tks noGroup field chids locals  =  vlist . lines2PP . (map (token2PP ppNt ppProd field chids locals noGroup )) $ tks+++lines2PP [] = []+lines2PP xs = map line2PP . shiftLeft . getLines $ xs+++token2PP ppNt ppProd field chids locals noGroup  tk+  = case tk of+      AGLocal var pos _        -> (pos, if (elem var locals)+                                        then  (ppListSep "(" "" "_" [pp var, ppNt, ppProd]) >|< pp " (loc # att_loc)) "+                                        else  pp var)+      AGField field attr pos _ -> let ppChT =    maybe (error $ "rhs field " ++ show field ++ " is not a child") ppShow (lookup field chids)+                                      ppAtt =    case (show field) of+                                                 "lhs"      ->  attName "inh"+                                                 "loc"      ->  attName "loc"+                                                 otherwise  ->  attName "syn"+                                      ppSubAtt = case (show field) of+                                                 "lhs"      -> ppName [pp (getName attr), pp "InhG", ppNt]+                                                 "loc"      -> ppName [pp (getName attr), ppNt, ppProd]+                                                 otherwise  -> ppName [pp (getName attr), pp "SynG", ppChT]+                                  in  (pos, if ((elem (getName attr) noGroup) && ((show field) /= "loc"))+                                             then pp "(" >|< pp (getName field)  >|< " # " >|< attName (getName attr) >|< pp ")"+                                             else pp "(" >|< ppSubAtt >|< " (" >|< pp (getName field) >|< " # " >|< ppAtt >|< ")) ")+      HsToken value pos        -> (pos, pp value)+      CharToken value pos      -> (pos, pp (show value))+      StrToken value pos       -> (pos, pp (show value))+      Err mesg pos             -> (pos, pp $ " ***" ++ mesg ++ "*** ")++line2PP ts =         let f (p,t) r = let ct = column p+                                     in \c -> pp (spaces (ct-c)) >|< t >|< r (length (show t) +ct)+                         spaces x | x < 0 = ""+                                  | otherwise = replicate x ' '+                     in foldr f (pp . const "") ts 1++}++----------------------------------------------------------------------------------------------------------------------------------------------+++{+ppMacro (Macro con children) = "( atts_" >|< show con >|< ", " >|<  ppListSep "" "" " <.> " ppChildren  >|<")"+                where   ppChildren = map  ppChild children+                        ppChild (RuleChild  ch n) = chName ch >|< " ==> " >|< ppMacro n+                        ppChild (ChildChild ch n) = chName ch >|< " --> " >|< n+                        ppChild (ValueChild ch n) = chName ch >|< " ~~> " >|< n+                        chName ch = ppName [pp "ch", pp ch, pp con]+}++-- catamorphisms++ATTR Nonterminals Nonterminal Productions Production [ | | ppCata USE {>-<} {empty} : PP_Doc ]++SEM Nonterminal+  | Nonterminal         lhs     .      ppCata    =  "----" >|< @loc.ppNt >-< @prods.ppCata+++SEM Production+  | Production          lhs     .      ppCata    =+                                            let  extend = maybe  []+                                                                 (  \ext ->  if (@lhs.newNT || (not @lhs.newNT && @loc.newProd))+                                                                             then []+                                                                             else [ ext >|< ".atts_" >|< @loc.prodName ])+                                                                 @lhs.ext+                                                 macro  = case @macro of+                                                                             Nothing ->  []+                                                                             Just macro ->  [ "agMacro " >|<  ppMacro macro  ]+                                                 atts = sortBy (\a b -> compare (show a) (show b)) @loc.ppRA+                                            in   "atts_" >|< @loc.prodName >|< " = " >|<+                                                                               ppListSep "" "" " `ext` "+                                                                               (atts ++ macro ++ extend ) >-<+                                                 "semP_" >|< @loc.prodName >|< pp " = knit atts_" >|< @loc.prodName++{+ppNoGroupAtts syn noGroup = let synatts = Map.keys $ Map.filterWithKey (\att _ -> elem (getName att) noGroup) syn+                            in  map (flip (>|<) "_inh") noGroup ++  map (flip (>|<) "_syn") synatts++ruleName att prodName = ppName [att,prodName]++elemNT a b = False+}++ATTR Productions Production [ syn, inh : { Attributes } | | ]++SEM Nonterminal+  | Nonterminal         prods     .     syn     =  @syn+                        prods     .     inh     =  @inh++++-- semantic functions++ATTR Nonterminals Nonterminal Productions Production  [ | | ppSF USE {>-<} {empty} : PP_Doc ]+ATTR Productions Production  [ | | ppSPF USE {>-<} {empty} : PP_Doc ]+++SEM Nonterminal+  | Nonterminal         lhs     .       ppSF            =+                                         let      inhAtts = attTypes @loc.inhNoGroup+                                                  synAtts = attTypes @loc.synNoGroup+                                         in+                                                  "----" >|< @loc.ppNt >-<+                                                  "type T_" >|< @loc.ppNt >|< " = " >|<+                                                  "(Record " >|<+                                                  inhAtts >|<+                                                  "(HCons (LVPair (Proxy Att_inh) InhG_" >|< @loc.ppNt >|< ") HNil))" >|<+                                                  replicate (length inhAtts) ")" >|< " -> " >|<+                                                  "(Record " >|<+                                                  synAtts >|<+                                                  "(HCons (LVPair (Proxy Att_syn) SynG_" >|< @loc.ppNt >|< ") HNil))" >|<+                                                  replicate (length synAtts) ")" >-<+                                                  "-- instance SemType T_" >|< @loc.ppNt >|< " " >|< @loc.ppNt >-<+                                                  "-- sem_" >|< @loc.ppNt >|< " :: " >|< @loc.ppNt >|< " -> T_" >|<  @loc.ppNt >-<+                                                  @prods.ppSPF -- >-<+                                                  -- @prods.ppSF++{+attTypes atts = map (\(a,t) -> "(HCons (LVPair (Proxy Att_" >|< a >|< ") " >|< ppShow t >|< ") ") $ Map.toAscList atts+}+++SEM Production+  | Production          lhs     .       ppSF            =+                                            let  chi = @children.ppCSF+                                                 ppPattern = case (show @con) of+                                                              -- hardcoded list support+                                                              "Cons"    -> ppParams (ppListSep "" "" " : ")+                                                              "Nil"     -> pp "[]"+                                                              -- general case+                                                              otherwise -> @loc.conName >|< " " >|< (ppParams ppSpaced)++                                                 ppParams f =   f $ map (((>|<) (pp "_")) . fst) chi+                                            in   "sem_" >|< @lhs.ppNt >|< " (" >|< ppPattern >|< ") = sem_" >|< @loc.prodName >|<+                                                 " (" >|< map (fst . snd) chi >|< "emptyRecord)"+                        lhs     .       ppSPF           =+                                            let  chi = @children.ppCSF+                                                 ppParams f =   f $ map (((>|<) (pp "_")) . fst) chi+                                            in   "sem_" >|< @lhs.ppNt >|< "_" >|< @con >#< ppParams ppSpaced >|< " = semP_" >|< @loc.prodName >|<+                                                 " (" >|< map (snd . snd) chi >|< "emptyRecord)"+++ATTR Children Child  [ | | ppCSF USE {++} {[]} : {[(Identifier,(PP_Doc,PP_Doc))]} ]+++SEM Child+  | Child               lhs     .       ppCSF           =+                                            let+                                                 semC   = if (isNonterminal @tp)+                                                           then "sem_" >|< ppShow @tp >|<  " _" >|< @name+                                                           else "sem_Lit _" >|< @name+                                            in   case @kind of+                                                      ChildSyntax ->  [(@name, (  @loc.chLabel >|< " .=. (" >|< semC >|< ") .*. "+                                                                              ,  @loc.chLabel >|< " .=. _" >|< @name >|< " .*. "))]+                                                      _           ->  []+++++-- wrappers++--TODO: create the records Inh_nt and Syn_nt to wrap the attributes++ATTR Nonterminals Nonterminal  [ | | ppW USE {>-<} {empty} : PP_Doc ]++SEM Nonterminal+  | Nonterminal         lhs     .       ppW     =+                                            ppName [pp "wrap", @loc.ppNt] >|< " sem " >|< attVars @inh >|< " = " >-<+                                            "   sem " >|< attFields @inh @loc.inhNoGroup @loc.ppNt+++{+attVars atts = map (\(a,_) -> "_" >|< a >|< " ") $ Map.toAscList atts+attFields atts noGroup ppNt =+     let ng = map (\(a,_) -> attName (getName a) >|< " .=. _" >|< a >|< " .*. ") $ Map.toAscList noGroup+         g  = ppCommas $ map (\(a,_) -> ppName [pp a, pp "InhG",ppNt]  >|< "= _" >|< a) $ Map.toAscList $ Map.difference atts noGroup+     in "(" >|< ng >|< "att_inh .=. " >|< ppName [pp "InhG", ppNt] >|< " { " >|< g >|< " } .*. emptyRecord)"+}
src-ag/AbstractSyntax.ag view
@@ -1,76 +1,76 @@-imports
-{
--- AbstractSyntax.ag imports
-import Data.Set(Set)
-import Data.Map(Map)
-import Patterns    (Pattern(..),Patterns)
-import Expression  (Expression(..))
-import Macro --marcos
-import CommonTypes
-import ErrorMessages
-}
-
-DATA Grammar      | Grammar typeSyns  : {TypeSyns}
-                            useMap    : {UseMap}
-                            derivings : {Derivings}
-                            wrappers  : {Set NontermIdent}
-                            nonts     : Nonterminals
-                            pragmas   : {PragmaMap}     -- pragmas defined at a certain alternative
-                            manualAttrOrderMap : {AttrOrderMap}  -- manually enforced dependencies between attributes
-                            paramMap   : {ParamMap}
-                            contextMap : {ContextMap}
-                            quantMap   : {QuantMap}
-                            uniqueMap  : {UniqueMap}
-                            augmentsMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))}
-                            aroundsMap  : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))}
-                            mergeMap    : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression)))}
-
-TYPE Nonterminals = [Nonterminal]
-
-TYPE Productions  = [Production]
-
-TYPE Children     = [Child]
-
-TYPE Rules        = [Rule]
-
-TYPE TypeSigs     = [TypeSig]
-
-DATA Nonterminal  | Nonterminal nt     : {NontermIdent}
-                                params : {[Identifier]}
-                                inh    : {Attributes}
-                                syn    : {Attributes}
-                                prods  : Productions
-
-DATA Production  | Production   con         : {ConstructorIdent}
-                                params      : {[Identifier]}
-                                constraints : {[Type]}
-                                children    : Children
-                                rules       : Rules
-                                typeSigs    : TypeSigs
-                                macro       : MaybeMacro --marcos
-
-DATA Child        | Child   name        : {Identifier}
-                            tp          : {Type}
-                            kind        : {ChildKind}
-
-DATA Rule         | Rule    mbName   : {Maybe Identifier}
-                            pattern  : Pattern
-                            rhs      : Expression
-                            owrt     : {Bool}
-                            origin   : String  -- just for documentation (and maybe errors)
-                            explicit : Bool   -- True if this rule defined in the source code
-                            pure     : Bool   -- True if this rule is pure (does not have side effects)
-                            identity : Bool   -- True if this rule is an identity rule
-                            mbError  : {Maybe Error}   -- scheduling this rule yields the given error, if present
-                            eager    : Bool    -- for ordered scheduling: use an eager semantics
-
-DATA TypeSig      | TypeSig name : {Identifier}
-                            tp   : {Type}
-
-SET AllAbstractSyntax
-  = Grammar
-    Nonterminal Nonterminals
-    Production Productions
-    Child Children
-    Rule Rules
-    TypeSig TypeSigs
+imports+{+-- AbstractSyntax.ag imports+import Data.Set(Set)+import Data.Map(Map)+import Patterns    (Pattern(..),Patterns)+import Expression  (Expression(..))+import Macro --marcos+import CommonTypes+import ErrorMessages+}++DATA Grammar      | Grammar typeSyns  : {TypeSyns}+                            useMap    : {UseMap}+                            derivings : {Derivings}+                            wrappers  : {Set NontermIdent}+                            nonts     : Nonterminals+                            pragmas   : {PragmaMap}     -- pragmas defined at a certain alternative+                            manualAttrOrderMap : {AttrOrderMap}  -- manually enforced dependencies between attributes+                            paramMap   : {ParamMap}+                            contextMap : {ContextMap}+                            quantMap   : {QuantMap}+                            uniqueMap  : {UniqueMap}+                            augmentsMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))}+                            aroundsMap  : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))}+                            mergeMap    : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression)))}++TYPE Nonterminals = [Nonterminal]++TYPE Productions  = [Production]++TYPE Children     = [Child]++TYPE Rules        = [Rule]++TYPE TypeSigs     = [TypeSig]++DATA Nonterminal  | Nonterminal nt     : {NontermIdent}+                                params : {[Identifier]}+                                inh    : {Attributes}+                                syn    : {Attributes}+                                prods  : Productions++DATA Production  | Production   con         : {ConstructorIdent}+                                params      : {[Identifier]}+                                constraints : {[Type]}+                                children    : Children+                                rules       : Rules+                                typeSigs    : TypeSigs+                                macro       : MaybeMacro --marcos++DATA Child        | Child   name        : {Identifier}+                            tp          : {Type}+                            kind        : {ChildKind}++DATA Rule         | Rule    mbName   : {Maybe Identifier}+                            pattern  : Pattern+                            rhs      : Expression+                            owrt     : {Bool}+                            origin   : String  -- just for documentation (and maybe errors)+                            explicit : Bool   -- True if this rule defined in the source code+                            pure     : Bool   -- True if this rule is pure (does not have side effects)+                            identity : Bool   -- True if this rule is an identity rule+                            mbError  : {Maybe Error}   -- scheduling this rule yields the given error, if present+                            eager    : Bool    -- for ordered scheduling: use an eager semantics++DATA TypeSig      | TypeSig name : {Identifier}+                            tp   : {Type}++SET AllAbstractSyntax+  = Grammar+    Nonterminal Nonterminals+    Production Productions+    Child Children+    Rule Rules+    TypeSig TypeSigs
src-ag/AbstractSyntaxDump.ag view
@@ -1,76 +1,76 @@-INCLUDE "AbstractSyntax.ag"
-INCLUDE "Patterns.ag"
-INCLUDE "Expression.ag"
-
-imports
-{
-import Data.List
-import qualified Data.Map as Map
-
-import Pretty
-import PPUtil
-
-import AbstractSyntax
-import TokenDef
-}
-
-ATTR AllPattern AllAbstractSyntax AllExpression [ | | pp USE {>-<} {empty} : PP_Doc ]
-
-SEM Grammar
-  | Grammar         lhs     .   pp      =   ppNestInfo ["Grammar","Grammar"] []
-                                                       [ ppF "typeSyns" $ ppAssocL @typeSyns
-                                                       , ppF "useMap" $ ppMap $ Map.map ppMap $ @useMap
-                                                       , ppF "derivings" $ ppMap $ @derivings
-                                                       , ppF "wrappers" $ ppShow $ @wrappers
-                                                       , ppF "nonts" $ ppVList @nonts.ppL
-                                                       ] []
-
-SEM Nonterminal
-  | Nonterminal     lhs     .   pp      =   ppNestInfo ["Nonterminal","Nonterminal"] (pp @nt : map pp @params) [ppF "inh" $ ppMap @inh, ppF "syn" $ ppMap @syn, ppF "prods" $ ppVList @prods.ppL] []
-
-SEM Production
-  | Production      lhs     .   pp      =   ppNestInfo ["Production","Production"] [pp @con] [ppF "children" $ ppVList @children.ppL,ppF "rules" $ ppVList @rules.ppL,ppF "typeSigs" $ ppVList @typeSigs.ppL] []
-
-SEM Child
-  | Child           lhs     .   pp      =   ppNestInfo ["Child","Child"] [pp @name, ppShow @tp] [ppF "kind" $ ppShow @kind] []
-
-SEM Rule
-  | Rule            lhs     .   pp      =   ppNestInfo ["Rule","Rule"] [ppShow @owrt, pp @origin] [ppF "pattern" $ @pattern.pp, ppF "rhs" $ @rhs.pp] []
-
-SEM TypeSig
-  | TypeSig         lhs     .   pp      =   ppNestInfo ["TypeSig","TypeSig"] [pp @name, ppShow @tp] [] []
-
-SEM Pattern
-  | Constr          lhs     .   pp      =   ppNestInfo ["Pattern","Constr"] [pp @name] [ppF "pats" $ ppVList @pats.ppL] []
-  | Product         lhs     .   pp      =   ppNestInfo ["Pattern","Product"] [ppShow @pos] [ppF "pats" $ ppVList @pats.ppL] []
-  | Alias           lhs     .   pp      =   ppNestInfo ["Pattern","Alias"] [pp @field, pp @attr] [ppF "pat" $ @pat.pp] []
-  | Underscore      lhs     .   pp      =   ppNestInfo ["Pattern","Underscore"] [ppShow @pos] [] []
-
-SEM Expression
-  | Expression      lhs     .   pp      =   ppNestInfo ["Expression","Expression"] [ppShow @pos] [ppF "txt" $ vlist . showTokens . tokensToStrings $ @tks] []
-
-ATTR Productions Nonterminals Children Rules TypeSigs Patterns [ | | ppL: {[PP_Doc]} ]
-
-SEM Patterns
-  | Cons            lhs     .   ppL     =   @hd.pp : @tl.ppL
-  | Nil             lhs     .   ppL     =   []
-
-SEM TypeSigs
-  | Cons            lhs     .   ppL     =   @hd.pp : @tl.ppL
-  | Nil             lhs     .   ppL     =   []
-
-SEM Rules
-  | Cons            lhs     .   ppL     =   @hd.pp : @tl.ppL
-  | Nil             lhs     .   ppL     =   []
-
-SEM Children
-  | Cons            lhs     .   ppL     =   @hd.pp : @tl.ppL
-  | Nil             lhs     .   ppL     =   []
-
-SEM Productions
-  | Cons            lhs     .   ppL     =   @hd.pp : @tl.ppL
-  | Nil             lhs     .   ppL     =   []
-
-SEM Nonterminals
-  | Cons            lhs     .   ppL     =   @hd.pp : @tl.ppL
-  | Nil             lhs     .   ppL     =   []
+INCLUDE "AbstractSyntax.ag"+INCLUDE "Patterns.ag"+INCLUDE "Expression.ag"++imports+{+import Data.List+import qualified Data.Map as Map++import Pretty+import PPUtil++import AbstractSyntax+import TokenDef+}++ATTR AllPattern AllAbstractSyntax AllExpression [ | | pp USE {>-<} {empty} : PP_Doc ]++SEM Grammar+  | Grammar         lhs     .   pp      =   ppNestInfo ["Grammar","Grammar"] []+                                                       [ ppF "typeSyns" $ ppAssocL @typeSyns+                                                       , ppF "useMap" $ ppMap $ Map.map ppMap $ @useMap+                                                       , ppF "derivings" $ ppMap $ @derivings+                                                       , ppF "wrappers" $ ppShow $ @wrappers+                                                       , ppF "nonts" $ ppVList @nonts.ppL+                                                       ] []++SEM Nonterminal+  | Nonterminal     lhs     .   pp      =   ppNestInfo ["Nonterminal","Nonterminal"] (pp @nt : map pp @params) [ppF "inh" $ ppMap @inh, ppF "syn" $ ppMap @syn, ppF "prods" $ ppVList @prods.ppL] []++SEM Production+  | Production      lhs     .   pp      =   ppNestInfo ["Production","Production"] [pp @con] [ppF "children" $ ppVList @children.ppL,ppF "rules" $ ppVList @rules.ppL,ppF "typeSigs" $ ppVList @typeSigs.ppL] []++SEM Child+  | Child           lhs     .   pp      =   ppNestInfo ["Child","Child"] [pp @name, ppShow @tp] [ppF "kind" $ ppShow @kind] []++SEM Rule+  | Rule            lhs     .   pp      =   ppNestInfo ["Rule","Rule"] [ppShow @owrt, pp @origin] [ppF "pattern" $ @pattern.pp, ppF "rhs" $ @rhs.pp] []++SEM TypeSig+  | TypeSig         lhs     .   pp      =   ppNestInfo ["TypeSig","TypeSig"] [pp @name, ppShow @tp] [] []++SEM Pattern+  | Constr          lhs     .   pp      =   ppNestInfo ["Pattern","Constr"] [pp @name] [ppF "pats" $ ppVList @pats.ppL] []+  | Product         lhs     .   pp      =   ppNestInfo ["Pattern","Product"] [ppShow @pos] [ppF "pats" $ ppVList @pats.ppL] []+  | Alias           lhs     .   pp      =   ppNestInfo ["Pattern","Alias"] [pp @field, pp @attr] [ppF "pat" $ @pat.pp] []+  | Underscore      lhs     .   pp      =   ppNestInfo ["Pattern","Underscore"] [ppShow @pos] [] []++SEM Expression+  | Expression      lhs     .   pp      =   ppNestInfo ["Expression","Expression"] [ppShow @pos] [ppF "txt" $ vlist . showTokens . tokensToStrings $ @tks] []++ATTR Productions Nonterminals Children Rules TypeSigs Patterns [ | | ppL: {[PP_Doc]} ]++SEM Patterns+  | Cons            lhs     .   ppL     =   @hd.pp : @tl.ppL+  | Nil             lhs     .   ppL     =   []++SEM TypeSigs+  | Cons            lhs     .   ppL     =   @hd.pp : @tl.ppL+  | Nil             lhs     .   ppL     =   []++SEM Rules+  | Cons            lhs     .   ppL     =   @hd.pp : @tl.ppL+  | Nil             lhs     .   ppL     =   []++SEM Children+  | Cons            lhs     .   ppL     =   @hd.pp : @tl.ppL+  | Nil             lhs     .   ppL     =   []++SEM Productions+  | Cons            lhs     .   ppL     =   @hd.pp : @tl.ppL+  | Nil             lhs     .   ppL     =   []++SEM Nonterminals+  | Cons            lhs     .   ppL     =   @hd.pp : @tl.ppL+  | Nil             lhs     .   ppL     =   []
src-ag/Code.ag view
@@ -1,163 +1,163 @@-imports
-{
-import Patterns
-import Data.Set(Set)
-import qualified Data.Set as Set
-import Data.Map(Map)
-import qualified Data.Map as Map
-}
-
-TYPE Exprs    = [Expr]
-TYPE Decls    = [Decl]
-TYPE Chunks   = [Chunk]
-TYPE DataAlts = [DataAlt]
-TYPE CaseAlts = [CaseAlt]
-TYPE Types    = [Type]
-TYPE NamedTypes = [NamedType]
-
-DATA Program  | Program          chunks : Chunks
-                                 ordered : Bool
-
-DATA Chunk    | Chunk            name         : String
-                                 comment      : Decl
-                                 info         : Decls
-                                 dataDef      : Decls
-                                 cataFun      : Decls
-                                 semDom       : Decls
-                                 semWrapper   : Decls
-                                 semFunctions : Decls
-                                 semNames     : {[String]}
-
-DATA Expr     | Let              decls : Decls
-                                 body  : Expr
-              | Case             expr  : Expr
-                                 alts  : CaseAlts
-              | Do               stmts : Decls
-                                 body  : Expr
-              | Lambda           args :  Exprs
-                                 body : Expr
-              | TupleExpr        exprs : Exprs
-              | UnboxedTupleExpr exprs : Exprs
-              | App              name  : {String}
-                                 args  : Exprs
-              | SimpleExpr       txt   : {String}
-              | TextExpr         lns   : {[String]}
-              | Trace            txt   : {String}
-                                 expr  : Expr
-              | PragmaExpr       onLeftSide : {Bool}
-                                 onNewLine  : {Bool}
-                                 txt   : {String}
-                                 expr  : Expr
-              | LineExpr         expr  : Expr
-              | TypedExpr        expr  : Expr
-                                 tp    : Type
-              | ResultExpr       nt    : String
-                                 expr  : Expr
-              | InvokeExpr       nt    : String
-                                 expr  : Expr
-                                 args  : Exprs
-              | ResumeExpr       nt    : String
-                                 expr  : Expr
-                                 left  : Lhs
-                                 rhs   : Expr
-              | SemFun           nt    : {String}
-                                 args  : Exprs
-                                 body  : Expr
-
-DATA CaseAlt  | CaseAlt          left  : Lhs
-                                 expr  : Expr
-
-DATA Decl     | Decl             left  : Lhs
-                                 rhs   : Expr
-                                 binds : {Set String}  -- set of variable names bound by the left-hand side
-                                 uses  : {Set String}  -- set of variable names used by the right-hand side
-              | Bind             left  : Lhs
-                                 rhs   : Expr
-              | BindLet          left  : Lhs
-                                 rhs   : Expr
-              | Data             name  : {String}
-                                 params: {[String]}
-                                 alts  : DataAlts
-                                 strict: Bool
-                                 derivings : {[String]}
-              | NewType          name  : {String}
-                                 params: {[String]}
-                                 con   : {String}
-                                 tp    : Type
-              | Type             name  : {String}
-                                 params: {[String]}
-                                 tp    : Type
-              | TSig             name  : {String}
-                                 tp    : Type
-              | Comment          txt   : {String}
-              | PragmaDecl       txt   : {String}
-
-              | Resume           monadic : {Bool}
-                                 nt    : String
-                                 left  : Lhs
-                                 rhs   : Expr
-              | EvalDecl         nt    : String
-                                 left  : Lhs
-                                 rhs   : Expr
-
-DATA DataAlt  | DataAlt          name  : {String}
-                                 args  : Types
-              | Record           name  : {String}
-                                 args  : NamedTypes
-
-DATA NamedType | Named           strict: {Bool}
-                                 name  : {String}
-                                 tp    : Type
-
-DATA Type     | Arr              left  : Type
-                                 right : Type
-              | CtxApp           left  : {[(String, [String])]}
-                                 right : Type
-              | QuantApp         left  : String
-                                 right : Type
-              | TypeApp          func  : Type
-                                 args  : Types
-              | TupleType        tps   : Types
-              | UnboxedTupleType tps   : Types
-              | List             tp    : Type
-              | SimpleType       txt   : {String}
-              | NontermType      name   : String
-                                 params : {[String]}
-                                 deforested : Bool
-              | TMaybe           tp    : Type
-              | TEither          left  : Type
-                                 right : Type
-              | TMap             key   : Type
-                                 value : Type
-              | TIntMap          value : Type
-              | TSet             tp    : Type
-              | TIntSet
-
-DATA Lhs      | Pattern3    pat3  : Pattern
-              | Pattern3SM  pat3  : Pattern
-              | TupleLhs         comps : {[String]} -- \ [Lhs] appears to be more sensible
-              | UnboxedTupleLhs  comps : {[String]} -- /
-              | Fun              name  : {String}
-                                 args  : Exprs
-              | Unwrap name : {String} sub : Lhs
-
-DERIVING Type : Show
-
-{
--- 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
-}
-
+imports+{+import Patterns+import Data.Set(Set)+import qualified Data.Set as Set+import Data.Map(Map)+import qualified Data.Map as Map+}++TYPE Exprs    = [Expr]+TYPE Decls    = [Decl]+TYPE Chunks   = [Chunk]+TYPE DataAlts = [DataAlt]+TYPE CaseAlts = [CaseAlt]+TYPE Types    = [Type]+TYPE NamedTypes = [NamedType]++DATA Program  | Program          chunks : Chunks+                                 ordered : Bool++DATA Chunk    | Chunk            name         : String+                                 comment      : Decl+                                 info         : Decls+                                 dataDef      : Decls+                                 cataFun      : Decls+                                 semDom       : Decls+                                 semWrapper   : Decls+                                 semFunctions : Decls+                                 semNames     : {[String]}++DATA Expr     | Let              decls : Decls+                                 body  : Expr+              | Case             expr  : Expr+                                 alts  : CaseAlts+              | Do               stmts : Decls+                                 body  : Expr+              | Lambda           args :  Exprs+                                 body : Expr+              | TupleExpr        exprs : Exprs+              | UnboxedTupleExpr exprs : Exprs+              | App              name  : {String}+                                 args  : Exprs+              | SimpleExpr       txt   : {String}+              | TextExpr         lns   : {[String]}+              | Trace            txt   : {String}+                                 expr  : Expr+              | PragmaExpr       onLeftSide : {Bool}+                                 onNewLine  : {Bool}+                                 txt   : {String}+                                 expr  : Expr+              | LineExpr         expr  : Expr+              | TypedExpr        expr  : Expr+                                 tp    : Type+              | ResultExpr       nt    : String+                                 expr  : Expr+              | InvokeExpr       nt    : String+                                 expr  : Expr+                                 args  : Exprs+              | ResumeExpr       nt    : String+                                 expr  : Expr+                                 left  : Lhs+                                 rhs   : Expr+              | SemFun           nt    : {String}+                                 args  : Exprs+                                 body  : Expr++DATA CaseAlt  | CaseAlt          left  : Lhs+                                 expr  : Expr++DATA Decl     | Decl             left  : Lhs+                                 rhs   : Expr+                                 binds : {Set String}  -- set of variable names bound by the left-hand side+                                 uses  : {Set String}  -- set of variable names used by the right-hand side+              | Bind             left  : Lhs+                                 rhs   : Expr+              | BindLet          left  : Lhs+                                 rhs   : Expr+              | Data             name  : {String}+                                 params: {[String]}+                                 alts  : DataAlts+                                 strict: Bool+                                 derivings : {[String]}+              | NewType          name  : {String}+                                 params: {[String]}+                                 con   : {String}+                                 tp    : Type+              | Type             name  : {String}+                                 params: {[String]}+                                 tp    : Type+              | TSig             name  : {String}+                                 tp    : Type+              | Comment          txt   : {String}+              | PragmaDecl       txt   : {String}++              | Resume           monadic : {Bool}+                                 nt    : String+                                 left  : Lhs+                                 rhs   : Expr+              | EvalDecl         nt    : String+                                 left  : Lhs+                                 rhs   : Expr++DATA DataAlt  | DataAlt          name  : {String}+                                 args  : Types+              | Record           name  : {String}+                                 args  : NamedTypes++DATA NamedType | Named           strict: {Bool}+                                 name  : {String}+                                 tp    : Type++DATA Type     | Arr              left  : Type+                                 right : Type+              | CtxApp           left  : {[(String, [String])]}+                                 right : Type+              | QuantApp         left  : String+                                 right : Type+              | TypeApp          func  : Type+                                 args  : Types+              | TupleType        tps   : Types+              | UnboxedTupleType tps   : Types+              | List             tp    : Type+              | SimpleType       txt   : {String}+              | NontermType      name   : String+                                 params : {[String]}+                                 deforested : Bool+              | TMaybe           tp    : Type+              | TEither          left  : Type+                                 right : Type+              | TMap             key   : Type+                                 value : Type+              | TIntMap          value : Type+              | TSet             tp    : Type+              | TIntSet++DATA Lhs      | Pattern3    pat3  : Pattern+              | Pattern3SM  pat3  : Pattern+              | TupleLhs         comps : {[String]} -- \ [Lhs] appears to be more sensible+              | UnboxedTupleLhs  comps : {[String]} -- /+              | Fun              name  : {String}+                                 args  : Exprs+              | Unwrap name : {String} sub : Lhs++DERIVING Type : Show++{+-- 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+}+
src-ag/CodeSyntax.ag view
@@ -1,90 +1,90 @@-imports
-{
-import Patterns
-import CommonTypes
-import Data.Map(Map)
-import Data.Set(Set)
-}
-
-DATA  CGrammar
-   |  CGrammar  typeSyns  : {TypeSyns}
-                derivings : {Derivings}
-                wrappers  : {Set NontermIdent}
-                nonts     : CNonterminals
-                pragmas   : {PragmaMap}
-                paramMap  : {ParamMap}
-                contextMap: {ContextMap}
-                quantMap  : {QuantMap}
-                aroundsMap: {Map NontermIdent (Map ConstructorIdent (Set Identifier))}
-                mergeMap  : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))}
-                multivisit : {Bool}
-
-TYPE CNonterminals = [CNonterminal]
-
-DATA  CNonterminal
-   |  CNonterminal nt     :  NontermIdent
-                   params :  {[Identifier]}
-                   inh    :  Attributes
-                   syn    :  Attributes
-                   prods  :  CProductions
-                   inter  :  CInterface
-
-DATA  CInterface
-   |  CInterface seg:CSegments
-
-TYPE CSegments = [CSegment]
-
-DATA  CSegment
-   |  CSegment  inh  :  Attributes
-                syn  :  Attributes
-
-TYPE CProductions = [CProduction]
-
-DATA  CProduction
-   |  CProduction   con        : ConstructorIdent
-                    visits     : CVisits
-                    children   : {[(Identifier,Type,ChildKind)]}
-                    terminals  : {[Identifier]}
-
-TYPE CVisits = [CVisit]
-
-DATA  CVisit
-   |  CVisit  inh     :  Attributes
-              syn     :  Attributes
-              vss     :  Sequence  -- sequence of "steps", where each "step" is either an attribute definition or a child visit
-              intra   :  Sequence  -- how to glue the visits together (child visits are child-intra's, attr-defs are attr-intra's)
-              ordered :  Bool -- indicates that vss is ordered
-
-TYPE Sequence = [CRule]
-
-DATA  CRule
-   |  CRule        name       :  Identifier
-                   isIn       :  Bool   -- True iff there is a definition for an inherited attribute
-                   hasCode    :  Bool   -- True iff there is an RHS
-                   nt         :  NontermIdent
-                   con        :  ConstructorIdent
-                   field      :  Identifier
-                   childnt    :  {Maybe NontermIdent}  -- Just n: 'field' of 'nt' and 'con' is a nonterminal 'n', Nothing: it is a terminal
-                   tp         :  {Maybe Type}     -- type of the attribute
-                   pattern    :  Pattern     -- only defined if 'isIn' is False
-                   rhs        :  {[String]}     -- empty string if 'hasCode' is False
-                   defines    :  {Map Int (Identifier,Identifier,Maybe Type)}   -- the attributes defined by this rule
-                   owrt       :  {Bool}
-                   origin     :  String  -- just for documentation (and maybe errors)
-                   uses       :  {Set (Identifier, Identifier)}
-                   explicit   :  Bool   -- True if this an explicit rule found in the source file
-                   mbNamed    : {Maybe Identifier}
-   |  CChildVisit  name    :  Identifier  -- corresponding to the name of the child
-                   nt      :  NontermIdent
-                   nr      :  Int   -- visit number
-                   inh     :  Attributes
-                   syn     :  Attributes
-                   isLast  :  Bool  -- indicates whether this is the last visit to this child
-
-SET AllCodeSyntax
-  = CGrammar
-    CNonterminal CNonterminals
-    CInterface CSegments CSegment
-    CProduction CProductions
-    CVisits CVisit
-    CRule
+imports+{+import Patterns+import CommonTypes+import Data.Map(Map)+import Data.Set(Set)+}++DATA  CGrammar+   |  CGrammar  typeSyns  : {TypeSyns}+                derivings : {Derivings}+                wrappers  : {Set NontermIdent}+                nonts     : CNonterminals+                pragmas   : {PragmaMap}+                paramMap  : {ParamMap}+                contextMap: {ContextMap}+                quantMap  : {QuantMap}+                aroundsMap: {Map NontermIdent (Map ConstructorIdent (Set Identifier))}+                mergeMap  : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))}+                multivisit : {Bool}++TYPE CNonterminals = [CNonterminal]++DATA  CNonterminal+   |  CNonterminal nt     :  NontermIdent+                   params :  {[Identifier]}+                   inh    :  Attributes+                   syn    :  Attributes+                   prods  :  CProductions+                   inter  :  CInterface++DATA  CInterface+   |  CInterface seg:CSegments++TYPE CSegments = [CSegment]++DATA  CSegment+   |  CSegment  inh  :  Attributes+                syn  :  Attributes++TYPE CProductions = [CProduction]++DATA  CProduction+   |  CProduction   con        : ConstructorIdent+                    visits     : CVisits+                    children   : {[(Identifier,Type,ChildKind)]}+                    terminals  : {[Identifier]}++TYPE CVisits = [CVisit]++DATA  CVisit+   |  CVisit  inh     :  Attributes+              syn     :  Attributes+              vss     :  Sequence  -- sequence of "steps", where each "step" is either an attribute definition or a child visit+              intra   :  Sequence  -- how to glue the visits together (child visits are child-intra's, attr-defs are attr-intra's)+              ordered :  Bool -- indicates that vss is ordered++TYPE Sequence = [CRule]++DATA  CRule+   |  CRule        name       :  Identifier+                   isIn       :  Bool   -- True iff there is a definition for an inherited attribute+                   hasCode    :  Bool   -- True iff there is an RHS+                   nt         :  NontermIdent+                   con        :  ConstructorIdent+                   field      :  Identifier+                   childnt    :  {Maybe NontermIdent}  -- Just n: 'field' of 'nt' and 'con' is a nonterminal 'n', Nothing: it is a terminal+                   tp         :  {Maybe Type}     -- type of the attribute+                   pattern    :  Pattern     -- only defined if 'isIn' is False+                   rhs        :  {[String]}     -- empty string if 'hasCode' is False+                   defines    :  {Map Int (Identifier,Identifier,Maybe Type)}   -- the attributes defined by this rule+                   owrt       :  {Bool}+                   origin     :  String  -- just for documentation (and maybe errors)+                   uses       :  {Set (Identifier, Identifier)}+                   explicit   :  Bool   -- True if this an explicit rule found in the source file+                   mbNamed    : {Maybe Identifier}+   |  CChildVisit  name    :  Identifier  -- corresponding to the name of the child+                   nt      :  NontermIdent+                   nr      :  Int   -- visit number+                   inh     :  Attributes+                   syn     :  Attributes+                   isLast  :  Bool  -- indicates whether this is the last visit to this child++SET AllCodeSyntax+  = CGrammar+    CNonterminal CNonterminals+    CInterface CSegments CSegment+    CProduction CProductions+    CVisits CVisit+    CRule
src-ag/CodeSyntaxDump.ag view
@@ -1,103 +1,103 @@-INCLUDE "CodeSyntax.ag"
-INCLUDE "Patterns.ag"
-
-imports
-{
-import Data.List
-import qualified Data.Map as Map
-
-import Pretty
-import PPUtil
-
-import CodeSyntax
-}
-
-{
-ppChild :: (Identifier,Type,ChildKind) -> PP_Doc
-ppChild (nm,tp,_)
-  = pp nm >#< "::" >#< pp (show tp)
-
-ppVertexMap :: Map Int (Identifier,Identifier,Maybe Type) -> PP_Doc
-ppVertexMap m
-  = ppVList [ ppF (show k) $ ppAttr v | (k,v) <- Map.toList m ]
-
-ppAttr :: (Identifier,Identifier,Maybe Type) -> PP_Doc
-ppAttr (fld,nm,mTp)
-  = pp fld >|< "." >|< pp nm >#<
-    case mTp of
-      Just tp -> pp "::" >#< show tp
-      Nothing -> empty
-
-ppBool :: Bool -> PP_Doc
-ppBool True  = pp "T"
-ppBool False = pp "F"
-
-ppMaybeShow :: Show a => Maybe a -> PP_Doc
-ppMaybeShow (Just x) = pp (show x)
-ppMaybeShow Nothing  = pp "_"
-
-ppStrings :: [String] -> PP_Doc
-ppStrings = vlist
-}
-
-
-ATTR AllPattern AllCodeSyntax [ | | pp USE {>-<} {empty} : PP_Doc ]
-
-SEM CGrammar
-  | CGrammar        lhs     .   pp      =   ppNestInfo ["CGrammar","CGrammar"] []
-                                                       [ ppF "typeSyns"  $ ppAssocL @typeSyns
-                                                       , ppF "derivings" $ ppMap $ @derivings
-                                                       , ppF "nonts"     $ ppVList @nonts.ppL
-                                                       ] []
-
-SEM CNonterminal
-  | CNonterminal        lhs     .   pp      =   ppNestInfo ["CNonterminal","CNonterminal"] (pp @nt : map pp @params) [ppF "inh" $ ppMap @inh, ppF "syn" $ ppMap @syn, ppF "prods" $ ppVList @prods.ppL, ppF "inter" @inter.pp] []
-
-SEM CInterface
-  | CInterface      lhs     .   pp      =   ppNestInfo ["CInterface","CInterface"] [] [ppF "seg" $ ppVList @seg.ppL] []
-
-SEM CSegment
-  | CSegment        lhs     .   pp      =   ppNestInfo ["CSegment","CSegment"] [] [ppF "inh" $ ppMap @inh, ppF "syn" $ ppMap @syn] []
-
-SEM CProduction
-  | CProduction lhs     .   pp      =   ppNestInfo ["CProduction","CProduction"] [pp @con] [ppF "visits" $ ppVList @visits.ppL, ppF "children" $ ppVList (map ppChild @children),ppF "terminals" $ ppVList (map ppShow @terminals)] []
-
-SEM CVisit
-  | CVisit          lhs     .   pp      =   ppNestInfo ["CVisit","CVisit"] [] [ppF "inh" $ ppMap @inh, ppF "syn" $ ppMap @syn, ppF "sequence" $ ppVList @vss.ppL, ppF "intra" $ ppVList @intra.ppL, ppF "ordered" $ ppBool @ordered] []
-
-SEM CRule
-  | CRule           lhs     .   pp      =   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 "<no pat because In>" else @pattern.pp, ppF "rhs" $ ppStrings @rhs, ppF "defines" $ ppVertexMap @defines, ppF "owrt" $ ppBool @owrt, ppF "origin" $ pp @origin] []
-  | CChildVisit     lhs     .   pp      =   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] []
-
-SEM Pattern
-  | Constr          lhs     .   pp      =   ppNestInfo ["Pattern","Constr"] [pp @name] [ppF "pats" $ ppVList @pats.ppL] []
-  | Product         lhs     .   pp      =   ppNestInfo ["Pattern","Product"] [ppShow @pos] [ppF "pats" $ ppVList @pats.ppL] []
-  | Alias           lhs     .   pp      =   ppNestInfo ["Pattern","Alias"] [pp @field, pp @attr] [ppF "pat" $ @pat.pp] []
-  | Underscore      lhs     .   pp      =   ppNestInfo ["Pattern","Underscore"] [ppShow @pos] [] []
-
-
-ATTR CNonterminals CSegments CProductions CVisits Sequence Patterns [ | | ppL: {[PP_Doc]} ]
-
-SEM Patterns
-  | Cons            lhs     .   ppL     =   @hd.pp : @tl.ppL
-  | Nil             lhs     .   ppL     =   []
-
-SEM Sequence
-  | Cons            lhs     .   ppL     =   @hd.pp : @tl.ppL
-  | Nil             lhs     .   ppL     =   []
-
-SEM CVisits
-  | Cons            lhs     .   ppL     =   @hd.pp : @tl.ppL
-  | Nil             lhs     .   ppL     =   []
-
-SEM CProductions
-  | Cons            lhs     .   ppL     =   @hd.pp : @tl.ppL
-  | Nil             lhs     .   ppL     =   []
-
-SEM CSegments
-  | Cons            lhs     .   ppL     =   @hd.pp : @tl.ppL
-  | Nil             lhs     .   ppL     =   []
-
-SEM CNonterminals
-  | Cons            lhs     .   ppL     =   @hd.pp : @tl.ppL
-  | Nil             lhs     .   ppL     =   []
+INCLUDE "CodeSyntax.ag"+INCLUDE "Patterns.ag"++imports+{+import Data.List+import qualified Data.Map as Map++import Pretty+import PPUtil++import CodeSyntax+}++{+ppChild :: (Identifier,Type,ChildKind) -> PP_Doc+ppChild (nm,tp,_)+  = pp nm >#< "::" >#< pp (show tp)++ppVertexMap :: Map Int (Identifier,Identifier,Maybe Type) -> PP_Doc+ppVertexMap m+  = ppVList [ ppF (show k) $ ppAttr v | (k,v) <- Map.toList m ]++ppAttr :: (Identifier,Identifier,Maybe Type) -> PP_Doc+ppAttr (fld,nm,mTp)+  = pp fld >|< "." >|< pp nm >#<+    case mTp of+      Just tp -> pp "::" >#< show tp+      Nothing -> empty++ppBool :: Bool -> PP_Doc+ppBool True  = pp "T"+ppBool False = pp "F"++ppMaybeShow :: Show a => Maybe a -> PP_Doc+ppMaybeShow (Just x) = pp (show x)+ppMaybeShow Nothing  = pp "_"++ppStrings :: [String] -> PP_Doc+ppStrings = vlist+}+++ATTR AllPattern AllCodeSyntax [ | | pp USE {>-<} {empty} : PP_Doc ]++SEM CGrammar+  | CGrammar        lhs     .   pp      =   ppNestInfo ["CGrammar","CGrammar"] []+                                                       [ ppF "typeSyns"  $ ppAssocL @typeSyns+                                                       , ppF "derivings" $ ppMap $ @derivings+                                                       , ppF "nonts"     $ ppVList @nonts.ppL+                                                       ] []++SEM CNonterminal+  | CNonterminal        lhs     .   pp      =   ppNestInfo ["CNonterminal","CNonterminal"] (pp @nt : map pp @params) [ppF "inh" $ ppMap @inh, ppF "syn" $ ppMap @syn, ppF "prods" $ ppVList @prods.ppL, ppF "inter" @inter.pp] []++SEM CInterface+  | CInterface      lhs     .   pp      =   ppNestInfo ["CInterface","CInterface"] [] [ppF "seg" $ ppVList @seg.ppL] []++SEM CSegment+  | CSegment        lhs     .   pp      =   ppNestInfo ["CSegment","CSegment"] [] [ppF "inh" $ ppMap @inh, ppF "syn" $ ppMap @syn] []++SEM CProduction+  | CProduction lhs     .   pp      =   ppNestInfo ["CProduction","CProduction"] [pp @con] [ppF "visits" $ ppVList @visits.ppL, ppF "children" $ ppVList (map ppChild @children),ppF "terminals" $ ppVList (map ppShow @terminals)] []++SEM CVisit+  | CVisit          lhs     .   pp      =   ppNestInfo ["CVisit","CVisit"] [] [ppF "inh" $ ppMap @inh, ppF "syn" $ ppMap @syn, ppF "sequence" $ ppVList @vss.ppL, ppF "intra" $ ppVList @intra.ppL, ppF "ordered" $ ppBool @ordered] []++SEM CRule+  | CRule           lhs     .   pp      =   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 "<no pat because In>" else @pattern.pp, ppF "rhs" $ ppStrings @rhs, ppF "defines" $ ppVertexMap @defines, ppF "owrt" $ ppBool @owrt, ppF "origin" $ pp @origin] []+  | CChildVisit     lhs     .   pp      =   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] []++SEM Pattern+  | Constr          lhs     .   pp      =   ppNestInfo ["Pattern","Constr"] [pp @name] [ppF "pats" $ ppVList @pats.ppL] []+  | Product         lhs     .   pp      =   ppNestInfo ["Pattern","Product"] [ppShow @pos] [ppF "pats" $ ppVList @pats.ppL] []+  | Alias           lhs     .   pp      =   ppNestInfo ["Pattern","Alias"] [pp @field, pp @attr] [ppF "pat" $ @pat.pp] []+  | Underscore      lhs     .   pp      =   ppNestInfo ["Pattern","Underscore"] [ppShow @pos] [] []+++ATTR CNonterminals CSegments CProductions CVisits Sequence Patterns [ | | ppL: {[PP_Doc]} ]++SEM Patterns+  | Cons            lhs     .   ppL     =   @hd.pp : @tl.ppL+  | Nil             lhs     .   ppL     =   []++SEM Sequence+  | Cons            lhs     .   ppL     =   @hd.pp : @tl.ppL+  | Nil             lhs     .   ppL     =   []++SEM CVisits+  | Cons            lhs     .   ppL     =   @hd.pp : @tl.ppL+  | Nil             lhs     .   ppL     =   []++SEM CProductions+  | Cons            lhs     .   ppL     =   @hd.pp : @tl.ppL+  | Nil             lhs     .   ppL     =   []++SEM CSegments+  | Cons            lhs     .   ppL     =   @hd.pp : @tl.ppL+  | Nil             lhs     .   ppL     =   []++SEM CNonterminals+  | Cons            lhs     .   ppL     =   @hd.pp : @tl.ppL+  | Nil             lhs     .   ppL     =   []
src-ag/ConcreteSyntax.ag view
@@ -1,132 +1,132 @@-imports
-{
-import UU.Scanner.Position (Pos)
-import Patterns   (Pattern)
-import Expression (Expression)
-import CommonTypes
-import Macro --marcos
-}
-
-
-TYPE Elems     = [Elem]
-
-TYPE Alts      = [Alt]
-
-TYPE Fields    = [Field]
-
-TYPE SemAlts   = [SemAlt]
-
-TYPE SemDefs   = [SemDef]
-
-DATA AG        | AG     elems  : Elems
-
-DATA Elem      | Data   pos     : {Pos}
-                        contype : {ConstructorType}
-                        ctx     : {ClassContext}
-                        names   : NontSet
-                        params  : {[Identifier]}
-                        attrs   : Attrs
-                        alts    : Alts
-                        ext     : {Bool}
-
-               | Type   pos    : {Pos}
-                        ctx    : {ClassContext}
-                        name   : {NontermIdent}
-                        params : {[Identifier]}
-                        type   : {ComplexType}
-
-               | Attr   pos    : {Pos}
-                        ctx    : {ClassContext}
-                        names  : NontSet
-                        quants : {[String]}
-                        attrs  : Attrs
-
-               | Sem    pos    : {Pos}
-                        ctx    : {ClassContext}
-                        names  : NontSet
-                        attrs  : Attrs
-                        quants : {[String]}
-                        alts   : SemAlts
-
-               | Txt    pos    : {Pos}
-                        kind   : {BlockKind}
-                        mbNt   : {Maybe NontermIdent}
-                        lines  : {[String]}
-
-               | Set    pos    : {Pos}
-                        name   : {NontermIdent}
-                        merge  : Bool
-                        set    : NontSet
-
-               | Deriving pos  : {Pos}
-                          set  : NontSet
-                          classes : {[NontermIdent]}
-
-               | Wrapper  pos  : {Pos}
-                          set  : NontSet
-
-               | Nocatas  pos  : {Pos}
-                          set  : NontSet
-
-               | Pragma   pos  : {Pos}
-                          names: {[NontermIdent]}
-
-               | Module   pos     : {Pos}
-                          name    : {String}  -- name of the haskell module
-                          exports : {String}  -- exports of the haskell module
-                          imports : {String}  -- imports to replicate to generated haskell modules
-
-DATA Attrs     | Attrs  pos    : {Pos}
-                        inh,chn,syn : {AttrNames}
-
-DATA Alt       | Alt    pos    : {Pos}
-                        names  : ConstructorSet
-                        tyvars : {[Identifier]}
-                        fields : Fields
-                        macro  : MaybeMacro --marcos: macro extension
-
-DATA Field     | FChild  name : Identifier
-                         tp   : Type
-               | FCtx    tps  : {[Type]}
-
-DATA SemAlt    | SemAlt pos    : {Pos}
-                        constructorSet   : ConstructorSet
-                        rules  : SemDefs
-
-DATA SemDef    | Def    pos    : Pos
-                        mbName : {Maybe Identifier}
-                        pattern: Pattern
-                        rhs    : {Expression}
-                        owrt   : {Bool}
-                        pure   : Bool
-                        eager  : Bool
-               | TypeDef pos   : {Pos}
-                         ident : {Identifier}
-                         tp    : Type
-               | UniqueDef ident : {Identifier}
-                           ref   : {Identifier}
-               | AugmentDef ident : {Identifier}
-                            rhs   : {Expression}
-               | AroundDef ident : {Identifier}
-                           rhs    : {Expression}
-               | MergeDef  target  : {Identifier}
-                           nt      : {Identifier}
-                           sources : {[Identifier]}
-                           rhs     : {Expression}
-               | SemPragma  names : {[NontermIdent]}
-               | AttrOrderBefore  before : {[Occurrence]}
-                                  after  : {[Occurrence]}
-
-DATA ConstructorSet | CName       name      : {ConstructorIdent}
-                    | CUnion      set1,set2 : ConstructorSet
-                    | CDifference set1,set2 : ConstructorSet
-                    | CAll
-
-DATA NontSet   | NamedSet   name      : {NontermIdent}
-               | All
-               | Union      set1,set2 : NontSet
-               | Intersect  set1,set2 : NontSet
-               | Difference set1,set2 : NontSet
-               | Path       from,to   : {NontermIdent}
-
-
+imports+{+import UU.Scanner.Position (Pos)+import Patterns   (Pattern)+import Expression (Expression)+import CommonTypes+import Macro --marcos+}+++TYPE Elems     = [Elem]++TYPE Alts      = [Alt]++TYPE Fields    = [Field]++TYPE SemAlts   = [SemAlt]++TYPE SemDefs   = [SemDef]++DATA AG        | AG     elems  : Elems++DATA Elem      | Data   pos     : {Pos}+                        contype : {ConstructorType}+                        ctx     : {ClassContext}+                        names   : NontSet+                        params  : {[Identifier]}+                        attrs   : Attrs+                        alts    : Alts+                        ext     : {Bool}++               | Type   pos    : {Pos}+                        ctx    : {ClassContext}+                        name   : {NontermIdent}+                        params : {[Identifier]}+                        type   : {ComplexType}++               | Attr   pos    : {Pos}+                        ctx    : {ClassContext}+                        names  : NontSet+                        quants : {[String]}+                        attrs  : Attrs++               | Sem    pos    : {Pos}+                        ctx    : {ClassContext}+                        names  : NontSet+                        attrs  : Attrs+                        quants : {[String]}+                        alts   : SemAlts++               | Txt    pos    : {Pos}+                        kind   : {BlockKind}+                        mbNt   : {Maybe NontermIdent}+                        lines  : {[String]}++               | Set    pos    : {Pos}+                        name   : {NontermIdent}+                        merge  : Bool+                        set    : NontSet++               | Deriving pos  : {Pos}+                          set  : NontSet+                          classes : {[NontermIdent]}++               | Wrapper  pos  : {Pos}+                          set  : NontSet++               | Nocatas  pos  : {Pos}+                          set  : NontSet++               | Pragma   pos  : {Pos}+                          names: {[NontermIdent]}++               | Module   pos     : {Pos}+                          name    : {String}  -- name of the haskell module+                          exports : {String}  -- exports of the haskell module+                          imports : {String}  -- imports to replicate to generated haskell modules++DATA Attrs     | Attrs  pos    : {Pos}+                        inh,chn,syn : {AttrNames}++DATA Alt       | Alt    pos    : {Pos}+                        names  : ConstructorSet+                        tyvars : {[Identifier]}+                        fields : Fields+                        macro  : MaybeMacro --marcos: macro extension++DATA Field     | FChild  name : Identifier+                         tp   : Type+               | FCtx    tps  : {[Type]}++DATA SemAlt    | SemAlt pos    : {Pos}+                        constructorSet   : ConstructorSet+                        rules  : SemDefs++DATA SemDef    | Def    pos    : Pos+                        mbName : {Maybe Identifier}+                        pattern: Pattern+                        rhs    : {Expression}+                        owrt   : {Bool}+                        pure   : Bool+                        eager  : Bool+               | TypeDef pos   : {Pos}+                         ident : {Identifier}+                         tp    : Type+               | UniqueDef ident : {Identifier}+                           ref   : {Identifier}+               | AugmentDef ident : {Identifier}+                            rhs   : {Expression}+               | AroundDef ident : {Identifier}+                           rhs    : {Expression}+               | MergeDef  target  : {Identifier}+                           nt      : {Identifier}+                           sources : {[Identifier]}+                           rhs     : {Expression}+               | SemPragma  names : {[NontermIdent]}+               | AttrOrderBefore  before : {[Occurrence]}+                                  after  : {[Occurrence]}++DATA ConstructorSet | CName       name      : {ConstructorIdent}+                    | CUnion      set1,set2 : ConstructorSet+                    | CDifference set1,set2 : ConstructorSet+                    | CAll++DATA NontSet   | NamedSet   name      : {NontermIdent}+               | All+               | Union      set1,set2 : NontSet+               | Intersect  set1,set2 : NontSet+               | Difference set1,set2 : NontSet+               | Path       from,to   : {NontermIdent}++
src-ag/DeclBlocks.ag view
@@ -1,20 +1,20 @@-imports
-{
-import Code (Decl,Expr)
-}
-
-
-DATA DeclBlocksRoot
-  | DeclBlocksRoot
-      blocks : DeclBlocks
-
-
-DATA DeclBlocks
-  | DeclBlock
-      defs : {[Decl]}
-      visit : {Decl}
-      next : DeclBlocks
-  | DeclTerminator
-      defs : {[Decl]}
-      result : {Expr}
-
+imports+{+import Code (Decl,Expr)+}+++DATA DeclBlocksRoot+  | DeclBlocksRoot+      blocks : DeclBlocks+++DATA DeclBlocks+  | DeclBlock+      defs : {[Decl]}+      visit : {Decl}+      next : DeclBlocks+  | DeclTerminator+      defs : {[Decl]}+      result : {Expr}+
src-ag/DefaultRules.ag view
@@ -1,821 +1,821 @@--- 13 okt 2011: eliminated the "multiRule" transformation for all but the Kastens-code
--- the SELF types are also eliminated in this phase: in a Type value, there should not be
--- a Self constructor anymore.
-
-PRAGMA strictdata
-PRAGMA optimize
-PRAGMA bangpats
-PRAGMA strictwrap
-
-INCLUDE "AbstractSyntax.ag"
-INCLUDE "Patterns.ag"
-INCLUDE "DistChildAttr.ag"
-
-imports
-{
-import qualified Data.List
-import qualified Data.Set as Set
-import qualified Data.Map as Map
-import Data.Map(Map)
-import qualified Data.Sequence as Seq
-import Data.Sequence(Seq,(><))
-import UU.Scanner.Position(noPos)
-import Pretty
-import Data.Maybe
-import HsToken
-import HsTokenScanner
-import Data.List(intersperse)
-import Data.Char
-
-import AbstractSyntax
-import ErrorMessages
-
-import Options
-}
-
--------------------------------------------------------------------------------
---         Passing down corresponding nonterminal and constructor names
--------------------------------------------------------------------------------
-ATTR Rule Rules Child Children Production Productions TypeSigs TypeSig  Pattern Patterns [ nt:NontermIdent | | ]
-ATTR Rule Rules Child Children Pattern Patterns [ con:ConstructorIdent | | ]
-
-ATTR Productions Production Children Child TypeSigs TypeSig [ params : {[Identifier]} | | ]
-SEM Nonterminal | Nonterminal
-  prods.params = @params
-
-
--------------------------------------------------------------------------------
---         Distributing options
--------------------------------------------------------------------------------
-
-ATTR Grammar Nonterminals Nonterminal Productions Production Rules Rule
-  [ options:{Options}
-    constructorTypeMap : {Map NontermIdent ConstructorType} | | ]
-ATTR Nonterminals Nonterminal Productions Production [ o_rename:{Bool}
-                                                       cr:Bool {- copy rule -}
-                                                     | | ]
-
-ATTR Children Child [ cr:Bool {- copy rule -}  | | ]
-SEM Grammar
-  | Grammar     nonts.o_rename  = rename    @lhs.options
-                nonts.cr        = modcopy   @lhs.options
-
--------------------------------------------------------------------------------
---         Passing down the set of wrapper names
--------------------------------------------------------------------------------
-
-ATTR Nonterminals Nonterminal Productions Production [ wrappers : {Set NontermIdent} | | ]
-SEM Grammar | Grammar
-  nonts.wrappers = @wrappers
-
--------------------------------------------------------------------------------
--- Type synonyms environment
--------------------------------------------------------------------------------
-ATTR Nonterminals Nonterminal Productions Production [ typeSyns : {TypeSyns} | | ]
-
-
--------------------------------------------------------------------------------
--- some auxiliary functions
--------------------------------------------------------------------------------
-{
-fieldName n       = '@' : getName n
-
-locName n         = "@loc." ++ getName n
-
-attrName fld attr
- | fld == _LOC    = locName attr
- | fld == _FIELD  = fieldName attr
- | otherwise      = '@' : getName fld ++ "." ++ getName attr
-
-_ACHILD = Ident "(" noPos -- hack
-
-mkLocVar = AGField _LOC
-
-isRecordConstructor :: NontermIdent -> Map NontermIdent ConstructorType -> Bool
-isRecordConstructor nt ctm = Map.lookup nt ctm == Just RecordConstructor
-
-buildConExpr ocaml clean conmap typeSyns rename nt con1 fs'
- | nt `elem` map fst typeSyns  =  if ocaml then synonymMl
-                                           else if clean then synonymClean
-                                                         else synonymHs
- | otherwise                   = normalExpr
- where fs                      = map fst fs'
-       con                     = getName con1
-       tup                     = " " ++ buildTuple fs
-       args                    = " " ++ unwords fs
-       normalExpr              = if clean && isRecordConstructor nt conmap
-                                   then "{" ++ con ++ "|" ++
-                                        unwords (intersperse "," $ map (\(new, old) -> getName old ++ " = " ++ new) fs')
-                                        ++ "}"
-                                   else conname' ++ args
-
-       conname' | rename    = getName nt ++ "_" ++ getName con1
-                | otherwise = getName con1
-
-       synonymHs  | con == "Tuple"    = buildTuple fs
-                  | con == "Cons"     = "(:)" ++ args
-                  | con == "Nil"      = case lookup nt typeSyns of
-                                          Just (Map _ _)  -> "Data.Map.empty"
-                                          Just (IntMap _) -> "Data.IntMap.empty"
-                                          Just (OrdSet _) -> "Data.Set.empty"
-                                          Just IntSet     -> "Data.IntSet.empty"
-                                          _               -> "[]"
-                  | con == "Just"     = "Just" ++ args
-                  | con == "Nothing"  = "Nothing"
-                  | con == "Entry"    = ( case lookup nt typeSyns of
-                                            Just (Map _ _)  -> "Data.Map.insert"
-                                            Just (IntMap _) -> "Data.IntMap.insert"
-                                            Just (OrdSet _) -> "Data.Set.insert"
-                                            Just IntSet     -> "Data.IntSet.insert" ) ++ args
-                  | otherwise         = normalExpr
-
-       synonymMl  | con == "Tuple"    = buildTuple fs
-                  | con == "Cons"     = "(::)" ++ tup
-                  | con == "Nil"      = case lookup nt typeSyns of
-                                          Just (Map _ _)  -> prefixMod nt "empty"
-                                          Just (IntMap _) -> prefixMod nt "empty"
-                                          Just (OrdSet _) -> prefixMod nt "empty"
-                                          Just IntSet     -> prefixMod nt "empty"
-                                          _               -> "[]"
-                  | con == "Just"     = "Some" ++ tup
-                  | con == "Nothing"  = "None"
-                  | con == "Entry"    = ( case lookup nt typeSyns of
-                                            Just (Map _ _)  -> prefixMod nt "add"
-                                            Just (IntMap _) -> prefixMod nt "add"
-                                            Just (OrdSet _) -> prefixMod nt "add"
-                                            Just IntSet     -> prefixMod nt "add" ) ++ args
-                  | otherwise         = normalExpr
-
-       synonymClean  | con == "Tuple"    = buildTuple fs
-                     | con == "Cons"     = "(\\x xs -> [x:xs])" ++ args
-                     | con == "Nil"      = case lookup nt typeSyns of
-                                             Just (Map _ _)  -> "Data.Map.empty"
-                                             Just (IntMap _) -> "Data.IntMap.empty"
-                                             Just (OrdSet _) -> "Data.Set.empty"
-                                             Just IntSet     -> "Data.IntSet.empty"
-                                             _               -> "[]"
-                     | con == "Just"     = "Just" ++ args
-                     | con == "Nothing"  = "Nothing"
-                     | con == "Entry"    = ( case lookup nt typeSyns of
-                                               Just (Map _ _)  -> "Data.Map.insert"
-                                               Just (IntMap _) -> "Data.IntMap.insert"
-                                               Just (OrdSet _) -> "Data.Set.insert"
-                                               Just IntSet     -> "Data.IntSet.insert" ) ++ args
-                     | otherwise         = normalExpr
-
-
-       prefixMod nt nm = "M_" ++ getName nt ++ "." ++ nm
-
-concatSeq = foldr (Seq.><) 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)
-      ]
-    )
-
-}
-
--------------------------------------------------------------------------------
---         Errors
--------------------------------------------------------------------------------
-
-ATTR Grammar Nonterminals Nonterminal Productions Production
-     Child Children Rule Rules Pattern Patterns
-     [ | | errors USE {Seq.><} {Seq.empty}:{Seq Error} ]
-
--------------------------------------------------------------------------------
--- Set of all defined nonterminals
--------------------------------------------------------------------------------
-
-ATTR Nonterminals Nonterminal  [ || collect_nts USE {`Set.union`} {Set.empty} : {Set NontermIdent}  ]
-SEM Nonterminal
-  | Nonterminal lhs.collect_nts = Set.singleton @nt
-
-ATTR Nonterminals Nonterminal Productions Production [ nonterminals  : {Set NontermIdent} || ]
-SEM Grammar
-  | Grammar nonts.nonterminals = @nonts.collect_nts
-
--------------------------------------------------------------------------------
--- Pass down the lhs-attributes and the USE's to each alternative of a nonterminal
--------------------------------------------------------------------------------
-
-ATTR Nonterminals Nonterminal [ useMap : {UseMap} || ]
-ATTR Productions Production [ inh, syn, inhOrig, synOrig : {Attributes} useMap : {Map Identifier (String,String,String)}|| ]
-
-SEM Nonterminal
-  | Nonterminal  prods.inh     = @loc.inh1
-                 prods.syn     = @loc.syn1
-                 prods.inhOrig = @inh
-                 prods.synOrig = @syn
-                 prods.useMap  = Map.findWithDefault Map.empty @nt @lhs.useMap
-
-SEM Production
-  | Production  rules.con    = @con
-                children.con = @con
-SEM Child
-  | Child lhs . name = @name
-SEM Grammar
-  | Grammar nonts . useMap = @useMap
-SEM Grammar
-  | Grammar nonts . typeSyns = @typeSyns
-SEM Nonterminal
-  | Nonterminal prods . nt = @nt
-
-SEM Child [ | | name:{Identifier} inherited,synthesized:{Attributes} ]
-  | Child lhs.inherited = @loc.inh1
-          lhs.synthesized = if @name `Set.member` @lhs.merged
-                            then Map.empty
-                            else @loc.syn1
-
-SEM Children [ | | inputs,outputs:{[(Identifier, Attributes)]} ]
-  | Cons lhs.inputs  = (@hd.name, @hd.inherited) : @tl.inputs
-            .outputs = (@hd.name, @hd.synthesized) : @tl.outputs
-  | Nil  lhs.inputs  = []
-            .outputs = []
-
-
-
--------------------------------------------------------------------------------
--- Implementation of Use-rule and Copy-rule
--------------------------------------------------------------------------------
-
-{
-
-
-
-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 clean nt con fld a
- = (if clean then "abort" else "error")
-   ++ " \"missing rule: "
-   ++ show nt  ++ "." ++ show con ++ "."
-   ++ show fld ++ "." ++ show a   ++ "\""
-
-makeRule :: (Identifier,Identifier) -> Expression -> String -> Bool -> Maybe Error -> Rule
-makeRule (f1,a1) expr origin identity mbDelayedError
- = Rule Nothing
-        (Alias f1 a1 (Underscore noPos))
-        expr
-        False
-        origin
-        False
-        True
-        identity
-        mbDelayedError
-        False
-
-
-useRule :: Options -> Set Identifier -> [(Identifier,Attributes)] -> (Identifier,(String,String,String)) -> Rule
-useRule opts locals ch_outs (n,(op,e,pos))
- =  let elems = [ fld
-                | (fld,as) <- ch_outs
-                , Map.member n as
-                ]
-
-        isOp [] = False
-        isOp (c:cs)
-          | isSpace c = isOp cs
-          | isAlpha c = case dropWhile isAlpha cs of
-                       ('.':cs2) -> isOp cs2 -- fully qualified name, drop prefix
-                       _         -> False
-          | c == '('  = False
-          | otherwise = True
-
-        tks | Set.member n locals  =  [mkLocVar n noPos Nothing]
-            | null elems           =  lexTokens opts noPos e
-            | otherwise            =  lexTokens opts noPos str
-                                      where
-                                        opExpr l r
-                                          | isOp op   = l ++ " " ++ op ++ " " ++ r         -- takes the associativity of the operator
-                                          | otherwise = "(" ++ op ++ " " ++ l ++ " " ++ r ++ ")"  -- associates to the right
-                                        str = foldr1 opExpr (map (flip attrName n) elems)
-
-    in makeRule (_LHS,n)
-                (Expression noPos tks)
-                ("use rule " ++ pos)
-                False
-                Nothing
-
-
-selfRule :: Bool -> Identifier -> [HsToken] -> Rule
-selfRule lhsNecLoc attr tks
- = makeRule (if lhsNecLoc then _LHS else _LOC,attr)
-               (Expression noPos tks)
-               "self rule"
-               False
-               Nothing
-
-
-
-
-concatRE rsess = let (rss,ess) = unzip rsess
-                 in (concat rss, concatSeq ess)
-
-
-copyRule :: Options -> Set NontermIdent -> Identifier -> Identifier -> Bool -> Set Identifier -> (Map Identifier Identifier, (Identifier,[Identifier])) -> ([Rule], Seq Error)
-copyRule options wrappers nt con modcopy locals (env,(fld,as))
- = concatRE (map copyRu as)
-
- where
-       copyRu a
-           = ( [ makeRule (fld,a)
-                          (Expression noPos tks)
-                          (cruletxt sel)
-                          True
-                          mbDelayedErr
-               ]
-             , err
-             )
-
-        where
-              sel
-               |    not modcopy
-                 && Set.member a locals  =  Just _LOC
-               | otherwise               =  Map.lookup a env
-
-              (tks,err,mbDelayedErr)
-               = case sel of
-                  Nothing         -> let tks = [HsToken (missingRuleErrorExpr (clean options) nt con fld a) noPos]
-                                         err = MissingRule nt con fld a
-                                     in if nt `Set.member` wrappers && kennedyWarren options
-                                        then (tks, Seq.empty, Just err)  -- yield error only if the rule is actually scheduled; for kennedyWarren code gen only
-                                        else (tks, Seq.singleton err, Nothing)
-                  Just f
-                   | f == _ACHILD -> ( [AGLocal a noPos Nothing]
-                                     , Seq.singleton (deprecatedCopyRuleError nt con fld a)
-                                     , Nothing
-                                     )
-                   | otherwise    -> ( [AGField f a noPos Nothing]
-                                     , Seq.empty
-                                     , Nothing
-                                     )
-
-              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
-}
-
-
-
-
-SEM Production
- | Production
-
-   lhs.errors = @children.errors >< @errs >< @rules.errors >< @loc.orderErrs
-
-   loc.(newRls, errs)
-   =
-    let locals       = @rules.locals
-        initenv      = Map.fromList (  [ (a,_ACHILD)  -- _ACHILD is used to mark identifiers in the environment that are terminals
-                                       | (a,_,_) <- @children.fields
-                                       ]
-                                    ++ attrs(_LHS, @lhs.inh)
-                                    ++ [ (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 ) @children.outputs)
-
-        child_envs = init envs
-        lhs_env    = last envs
-
-        (selfAttrs, normalAttrs)
-          = Map.partitionWithKey (\k _ -> maybe False isSELFNonterminal $ Map.lookup k @lhs.synOrig) @lhs.syn
-
-        (_,undefAttrs)
-          = removeDefined @rules.definedAttrs (_LHS, normalAttrs)
-
-        (useAttrs,others)
-          = splitAttrs @lhs.useMap undefAttrs
-
-        (rules1, errors1)
-          = concatRE $ map (copyRule @lhs.options @lhs.wrappers @lhs.nt @con @lhs.cr locals)
-                           (zip envs (map (removeDefined @rules.definedAttrs) @children.inputs))
-
-        uRules
-          = map (useRule @lhs.options locals @children.outputs) useAttrs
-
-        -- creates a loc.xxx if there is a synthesized attr xxx of type SELF and no
-        -- loc.xxx exists yet. If there exists a terminal yyy and a local loc.yyy, then
-        -- the local is chosen as value for the terminal.
-        selfLocRules
-          =  [ selfRule False attr $
-                 lexTokens @lhs.options noPos $  -- building a string and lexing it again is not so nice... but practical here
-                 constructor [(childSelf attr nm tp, nm) | (nm,tp,virt) <- @children.fields, childExists virt]
-             | 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
-                 = buildConExpr (ocaml @lhs.options) (clean @lhs.options) @lhs.constructorTypeMap @lhs.typeSyns @lhs.o_rename @lhs.nt @con fs
-
-               childExists ChildAttr = False
-               childExists _         = True
-
-        selfRules
-          = [ selfRule True attr [mkLocVar attr noPos Nothing]
-            | attr <- Map.keys selfAttrs
-            , not (Set.member (_LHS,attr) @rules.definedAttrs)
-            ]
-
-        (rules5, errs5)
-          = copyRule @lhs.options
-                     @lhs.wrappers
-                     @lhs.nt
-                     @con
-                     @lhs.cr
-                     locals
-                     (lhs_env, (_LHS, others))
-    in (uRules++selfLocRules++selfRules++rules5++rules1, errors1><errs5)
-
-{
-buildTuple fs = "(" ++ concat (intersperse "," fs) ++ ")"
-
-addAugments :: (Identifier, [Expression]) -> [Rule] -> [Rule]
-addAugments (_, exprs) rules
-  | null exprs = rules
-addAugments (syn, exprs) rules
-  = [rule] ++ funRules ++ map modify rules
-  where
-    rule = Rule Nothing (Alias _LHS syn (Underscore noPos)) rhs False "augmented rule" False True False Nothing False
-    rhs  = Expression noPos tks
-    tks  = [ HsToken "foldr ($) " noPos, mkLocVar substSyn noPos Nothing, HsToken " [" noPos] ++ funs ++ [HsToken "]" noPos]
-    funs = intersperse (HsToken ", " noPos) (map (\n -> mkLocVar n noPos Nothing) funNames)
-
-    substSyn = Ident (show syn ++ "_augmented_syn") (getPos syn)
-    funNames = zipWith (\i _ -> Ident (show syn ++ "_augmented_f" ++ show i) (getPos syn)) [1..] exprs
-    funRules = zipWith (\name expr -> Rule Nothing (Alias _LOC name (Underscore noPos)) expr False "augment function" False True False Nothing False) funNames exprs
-
-    modify (Rule mbNm pat rhs owrt origin expl pure identity mbErr eager)
-      | containsSyn pat = Rule mbNm (modifyPat pat) rhs owrt origin expl pure identity mbErr eager
-    modify r = r
-
-    containsSyn (Constr _ pats)   = any containsSyn pats
-    containsSyn (Product _ pats)  = any containsSyn pats
-    containsSyn (Irrefutable pat) = containsSyn pat
-    containsSyn (Alias field attr pat) = (field == _LHS && attr == syn) || containsSyn pat
-    containsSyn _ = False
-
-    modifyPat (Constr name pats) = Constr name (map modifyPat pats)
-    modifyPat (Product pos pats) = Product pos (map modifyPat pats)
-    modifyPat (Irrefutable pat)  = Irrefutable (modifyPat pat)
-    modifyPat (Alias field attr pat)
-      | field == _LHS && attr == syn = Alias _LOC substSyn (modifyPat pat)
-      | otherwise                    = Alias field attr (modifyPat pat)
-    modifyPat p = p
-
--- adds the additional rules needed for around, which creates a sequence of
--- rules that form a function that each transforms the semantics of a child
--- before attaching the child.
--- The rule defines a local attribute "<child>_around" and <child> is dependent
--- on this attribute.
-addArounds :: (Identifier, [Expression]) -> [Rule] -> [Rule]
-addArounds (_, exprs) rules | null exprs = rules
-addArounds (child, exprs) rules
-  = [rule] ++ funRules ++ rules
-  where
-    rule = Rule Nothing (Alias _LOC childLoc (Underscore noPos)) rhs False "around rule" False True False Nothing False
-    rhs  = Expression noPos tks
-    tks  = [ HsToken "\\s -> foldr ($) s " noPos, HsToken " [" noPos] ++ funs ++ [HsToken "]" noPos]
-    funs = intersperse (HsToken ", " noPos) (map (\n -> mkLocVar n noPos Nothing) funNames)
-
-    childLoc = Ident (show child ++ "_around") (getPos child)
-    funNames = zipWith (\i _ -> Ident (show child ++ "_around_f" ++ show i) (getPos child)) [1..] exprs
-    funRules = zipWith (\name expr -> Rule Nothing (Alias _LOC name (Underscore noPos)) expr False "around function" False True False Nothing False) funNames exprs
-
--- adds the additional rules needed for merging.
--- It produces for each merging child a rule with local attribute: "<child>_merged".
--- this rules takes the semantics of the first children and feeds it to the function
--- represented by this attribute. This attribute then defines the semantics for
--- the merging child.
-addMerges :: (Identifier, (Identifier,[Identifier],Expression)) -> [Rule] -> [Rule]
-addMerges (target,(_,_,expr)) rules
-  = rule : rules
-  where
-    rule = Rule Nothing (Alias _LOC childLoc (Underscore noPos)) expr False "merge rule" False True False Nothing False
-    childLoc = Ident (show target ++ "_merge") (getPos target)
-}
-
-
-ATTR Rule Rules Pattern Patterns
-  [ | | locals        USE {`Set.union`} {Set.empty} : {Set Identifier}
-        definedAttrs  USE {`Set.union`} {Set.empty} : {Set (Identifier,Identifier)}
-  ]
-
-
-SEM Pattern
-  | Alias lhs.definedAttrs = Set.insert (@field,@attr) @pat.definedAttrs
-             .locals       = if @field == _LOC
-                                then Set.insert @attr @pat.locals
-                                else @pat.locals
-
-SEM Children [ | | fields : {[(Identifier,Type,ChildKind)]} ]
-  | Cons lhs.fields = @hd.field : @tl.fields
-  | Nil  lhs.fields = []
-
-SEM Child    [ | | field  : { (Identifier,Type,ChildKind) } ]
-  | Child lhs.field = (@name,@tp,@kind)
-
--------------------------------------------------------------------------------
---
--------------------------------------------------------------------------------
-ATTR Rule Pattern Patterns [ || containsVars USE {||} {False} : Bool ]
-
-SEM Pattern
-  | Alias      lhs.containsVars = True
-
-ATTR Rule [ | | isPure : Bool ]
-SEM Rule | Rule  lhs.isPure = @pure
-
--------------------------------------------------------------------------------
---         Eliminate SELF types
--------------------------------------------------------------------------------
-
-SEM Nonterminal | Nonterminal
-  loc.inh1 = Map.map (elimSelfId @nt @params) @inh
-  loc.syn1 = Map.map (elimSelfId @nt @params) @syn
-
-SEM Child | Child
-  (loc.nt, loc.params) = case @tp of
-                           NT nt params _ -> (nt, params)
-                           Self           -> error ("The type of child " ++ show @name ++ " should not be a Self type.")
-                           Haskell t      -> (identifier t, []) -- should be ignored because the child is a terminal
-  loc.inh1 = Map.map (elimSelfStr @loc.nt @loc.params) @loc.inh
-  loc.syn1 = Map.map (elimSelfStr @loc.nt @loc.params) @loc.syn
-
-SEM TypeSig | TypeSig
-  loc.tp1 = elimSelfId @lhs.nt @lhs.params @tp
-
-{
-elimSelfId :: NontermIdent -> [Identifier] -> Type -> Type
-elimSelfId nt args Self = NT nt (map getName args) False
-elimSelfId _ _ tp = tp
-
-elimSelfStr :: NontermIdent -> [String] -> Type -> Type
-elimSelfStr nt args Self = NT nt args False
-elimSelfStr _ _ tp = tp
-}
-
--------------------------------------------------------------------------------
---         Reconstructing the tree
--------------------------------------------------------------------------------
-
-ATTR Nonterminals Nonterminal Productions Production Rules Rule [ | uniq:Int | ]
-
-SEM Grammar
-  | Grammar nonts.uniq = 1
-
-ATTR Grammar Nonterminals  Nonterminal   Productions
-    Production Children Child Rules Rule Pattern  Patterns TypeSigs TypeSig
-    [ | | output:SELF ]
-
-ATTR Rule [ | | outputs:Rules ]
-
-SEM Nonterminal | Nonterminal
-  lhs.output = Nonterminal @nt @params @loc.inh1 @loc.syn1 @prods.output
-
-SEM Production
-  | Production
-      loc.extra1 = foldr addAugments (@rules.output ++ @newRls) (Map.assocs @loc.augmentsIn)
-      loc.extra2 = foldr addArounds @loc.extra1 (Map.assocs @loc.aroundsIn)
-      loc.extra3 = foldr addMerges @loc.extra2 (Map.assocs @loc.mergesIn)
-      lhs.output = Production @con @params @constraints @children.output @loc.extra3 @typeSigs.output @macro
-
-SEM Child | Child
-  lhs.output = Child @name @tp @kind
-
-SEM TypeSig | TypeSig
-  lhs.output = TypeSig @name @loc.tp1
-
-SEM Rules
-  | Cons lhs.output = if @hd.containsVars && @hd.isPure then @hd.outputs ++ @tl.output else @tl.output
-    -- remove rules that define nothing and do not have side effects
-
-SEM Rule
-  | Rule  (loc.output1, loc.mbAlias) = mkRuleAlias @loc.output
-          (loc.outputs, lhs.uniq) = if needsMultiRules @lhs.options  -- check if this works for UHC
-                                    then multiRule @loc.output1 @lhs.uniq
-                                    else ([@loc.output1], @lhs.uniq)
-          lhs.outputs = maybe [] return @loc.mbAlias ++ @loc.outputs
-
-{
--- When a rule has a name, create an alias for a rule
--- and a modified rule that refers to the alias
--- Thus it removes rule names from rules
-mkRuleAlias :: Rule -> (Rule, Maybe Rule)
-mkRuleAlias r@(Rule Nothing _ _ _ _ _ _ _ _ _) = (r, Nothing)
-mkRuleAlias (Rule (Just nm) pat expr owrt origin expl pure identity mbErr eager) = (r', Just alias) where
-  alias = Rule Nothing (Alias _LOC (Ident ("_rule_" ++ show nm) pos) (Underscore pos)) expr owrt origin expl pure identity mbErr eager
-  pos   = getPos nm
-  expr' = Expression pos tks
-  tks   = [mkLocVar (Ident ("_rule_" ++ show nm) pos) pos (Just ("Indirection to rule " ++ show nm))]
-  r'    = Rule Nothing pat expr' owrt origin False True identity Nothing False
-}
-
-
--- Work towards removing the need of the "multiRule".
--- It's currently only needed for the Kastens code generation
-{
-needsMultiRules :: Options -> Bool
-needsMultiRules opts = (visit opts || withCycle opts) && not (kennedyWarren opts)
-}
-
-{
-{-
-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 expl pure identity mbErr eager) uniq
-  =  let f :: Bool -> (Pattern->Pattern) -> Expression -> Pattern -> Int -> (Pattern, ([Rule], Int))
-         f expl' 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)
-                 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 False (us (length xs1)) freshExpr p n1
-                                      in  (x2:xs1, rs2++rs1, n2)
-                 (xs9,rs9,n9) = foldr g ([], [], n+1) pats
-             in  ( freshPat
-                 , ( Rule Nothing (w freshPat) e owrt origin expl' True False mbErr eager : rs9
-                   , n9
-                   )
-                 )
-         f expl' w e p n
-           = ( p
-             , ( [Rule Nothing (w p) e owrt origin expl' True False mbErr eager]
-               , n
-               )
-             )
-     in snd (f expl id expr pat uniq)
-
-}
-
--------------------------------------------------------------------------------
---         Check the order definitions
--------------------------------------------------------------------------------
-
-ATTR Nonterminals Nonterminal Productions Production [ manualAttrOrderMap : {AttrOrderMap} | | ]
-
-SEM Grammar
-  | Grammar
-      nonts.manualAttrOrderMap = @manualAttrOrderMap
-
-ATTR Rules Rule [ | | ruleNames USE {`Set.union`} {Set.empty} : {Set Identifier} ]
-
-SEM Rule | Rule  lhs.ruleNames = case @mbName of
-                                   Nothing -> Set.empty
-                                   Just nm -> Set.singleton nm
-
-SEM Production
-  | Production
-      loc.orderDeps = Set.toList $ Map.findWithDefault Set.empty @con $ Map.findWithDefault Map.empty @lhs.nt @lhs.manualAttrOrderMap
-
-      loc.orderErrs
-        = let chldOutMap = Map.fromList [ (k, Map.keysSet s) | (k,s) <- @children.outputs ]
-              chldInMap  = Map.fromList [ (k, Map.keysSet s) | (k,s) <- @children.inputs ]
-
-              -- a local attribute
-              -- or an inherited attribute of the production
-              -- or an out-attribute of a child
-              isInAttribute :: Identifier -> Identifier -> [Error]
-              isInAttribute fld nm
-                 | fld == _LOC = if nm `Set.member` @rules.locals
-                                 then []
-                                 else [UndefAttr @lhs.nt @con fld nm False]
-                 | fld == _LHS = if nm `Map.member` @lhs.inh
-                                 then []
-                                 else [UndefAttr @lhs.nt @con fld nm False]
-                 | otherwise   = if nm `Set.member` (Map.findWithDefault Set.empty fld chldOutMap)
-                                 then []
-                                 else [UndefAttr @lhs.nt @con fld nm False]
-
-              -- a local attribute
-              -- or a synthesized attribute of the production
-              -- or an in-attribute of a child
-              isOutAttribute :: Identifier -> Identifier -> [Error]
-              isOutAttribute fld nm
-                 | fld == _LOC = if nm `Set.member` @rules.locals
-                                 then []
-                                 else [UndefAttr @lhs.nt @con fld nm True]
-                 | fld == _LHS = if nm `Map.member` @lhs.syn
-                                 then []
-                                 else [UndefAttr @lhs.nt @con fld nm True]
-                 | otherwise   = if nm `Set.member` (Map.findWithDefault Set.empty fld chldInMap)
-                                 then []
-                                 else [UndefAttr @lhs.nt @con fld nm True]
-
-              existsRule nm = if nm `Set.member` @rules.ruleNames
-                              then []
-                              else [MissingNamedRule @lhs.nt @con nm]
-
-              checkIn (OccAttr fld nm)  = isInAttribute fld nm
-              checkIn (OccRule nm)      = existsRule nm
-              checkOut (OccAttr fld nm) = isOutAttribute fld nm
-              checkOut (OccRule nm)     = existsRule nm
-          in Seq.fromList . concat $
-             [ checkIn occA ++ checkOut occB
-             | (Dependency occA occB) <- @loc.orderDeps
-             ]
-
--------------------------------------------------------------------------------
---         Decompose augment
--------------------------------------------------------------------------------
-
-ATTR Nonterminals Nonterminal [ augmentsIn : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} | | ]
-ATTR Productions Production [ augmentsIn : {Map ConstructorIdent (Map Identifier [Expression])} | | ]
-
-SEM Grammar     | Grammar      nonts.augmentsIn = @augmentsMap
-SEM Nonterminal | Nonterminal  loc.augmentsIn = Map.findWithDefault Map.empty @nt @lhs.augmentsIn
-SEM Production  | Production   loc.augmentsIn = Map.findWithDefault Map.empty @con @lhs.augmentsIn
-
-ATTR Nonterminals Nonterminal [ aroundsIn : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} | | ]
-ATTR Productions Production [ aroundsIn : {Map ConstructorIdent (Map Identifier [Expression])} | | ]
-
-SEM Grammar     | Grammar      nonts.aroundsIn = @aroundsMap
-SEM Nonterminal | Nonterminal  loc.aroundsIn   = Map.findWithDefault Map.empty @nt @lhs.aroundsIn
-SEM Production  | Production   loc.aroundsIn   = Map.findWithDefault Map.empty @con @lhs.aroundsIn
-
-ATTR Nonterminals Nonterminal [ mergesIn : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression)))} | | ]
-ATTR Productions Production [ mergesIn : {Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression))} | | ]
-ATTR Children Child [ merged : {Set Identifier} | | ]
-
-SEM Grammar     | Grammar      nonts.mergesIn = @mergeMap
-SEM Nonterminal | Nonterminal  loc.mergesIn   = Map.findWithDefault Map.empty @nt @lhs.mergesIn
-SEM Production  | Production   loc.mergesIn   = Map.findWithDefault Map.empty @con @lhs.mergesIn
-                               loc.merged     = Set.fromList [ c | (_,cs,_) <- Map.elems @loc.mergesIn, c <- cs ]
+-- 13 okt 2011: eliminated the "multiRule" transformation for all but the Kastens-code+-- the SELF types are also eliminated in this phase: in a Type value, there should not be+-- a Self constructor anymore.++PRAGMA strictdata+PRAGMA optimize+PRAGMA bangpats+PRAGMA strictwrap++INCLUDE "AbstractSyntax.ag"+INCLUDE "Patterns.ag"+INCLUDE "DistChildAttr.ag"++imports+{+import qualified Data.List+import qualified Data.Set as Set+import qualified Data.Map as Map+import Data.Map(Map)+import qualified Data.Sequence as Seq+import Data.Sequence(Seq,(><))+import UU.Scanner.Position(noPos)+import Pretty+import Data.Maybe+import HsToken+import HsTokenScanner+import Data.List(intersperse)+import Data.Char++import AbstractSyntax+import ErrorMessages++import Options+}++-------------------------------------------------------------------------------+--         Passing down corresponding nonterminal and constructor names+-------------------------------------------------------------------------------+ATTR Rule Rules Child Children Production Productions TypeSigs TypeSig  Pattern Patterns [ nt:NontermIdent | | ]+ATTR Rule Rules Child Children Pattern Patterns [ con:ConstructorIdent | | ]++ATTR Productions Production Children Child TypeSigs TypeSig [ params : {[Identifier]} | | ]+SEM Nonterminal | Nonterminal+  prods.params = @params+++-------------------------------------------------------------------------------+--         Distributing options+-------------------------------------------------------------------------------++ATTR Grammar Nonterminals Nonterminal Productions Production Rules Rule+  [ options:{Options}+    constructorTypeMap : {Map NontermIdent ConstructorType} | | ]+ATTR Nonterminals Nonterminal Productions Production [ o_rename:{Bool}+                                                       cr:Bool {- copy rule -}+                                                     | | ]++ATTR Children Child [ cr:Bool {- copy rule -}  | | ]+SEM Grammar+  | Grammar     nonts.o_rename  = rename    @lhs.options+                nonts.cr        = modcopy   @lhs.options++-------------------------------------------------------------------------------+--         Passing down the set of wrapper names+-------------------------------------------------------------------------------++ATTR Nonterminals Nonterminal Productions Production [ wrappers : {Set NontermIdent} | | ]+SEM Grammar | Grammar+  nonts.wrappers = @wrappers++-------------------------------------------------------------------------------+-- Type synonyms environment+-------------------------------------------------------------------------------+ATTR Nonterminals Nonterminal Productions Production [ typeSyns : {TypeSyns} | | ]+++-------------------------------------------------------------------------------+-- some auxiliary functions+-------------------------------------------------------------------------------+{+fieldName n       = '@' : getName n++locName n         = "@loc." ++ getName n++attrName fld attr+ | fld == _LOC    = locName attr+ | fld == _FIELD  = fieldName attr+ | otherwise      = '@' : getName fld ++ "." ++ getName attr++_ACHILD = Ident "(" noPos -- hack++mkLocVar = AGField _LOC++isRecordConstructor :: NontermIdent -> Map NontermIdent ConstructorType -> Bool+isRecordConstructor nt ctm = Map.lookup nt ctm == Just RecordConstructor++buildConExpr ocaml clean conmap typeSyns rename nt con1 fs'+ | nt `elem` map fst typeSyns  =  if ocaml then synonymMl+                                           else if clean then synonymClean+                                                         else synonymHs+ | otherwise                   = normalExpr+ where fs                      = map fst fs'+       con                     = getName con1+       tup                     = " " ++ buildTuple fs+       args                    = " " ++ unwords fs+       normalExpr              = if clean && isRecordConstructor nt conmap+                                   then "{" ++ con ++ "|" +++                                        unwords (intersperse "," $ map (\(new, old) -> getName old ++ " = " ++ new) fs')+                                        ++ "}"+                                   else conname' ++ args++       conname' | rename    = getName nt ++ "_" ++ getName con1+                | otherwise = getName con1++       synonymHs  | con == "Tuple"    = buildTuple fs+                  | con == "Cons"     = "(:)" ++ args+                  | con == "Nil"      = case lookup nt typeSyns of+                                          Just (Map _ _)  -> "Data.Map.empty"+                                          Just (IntMap _) -> "Data.IntMap.empty"+                                          Just (OrdSet _) -> "Data.Set.empty"+                                          Just IntSet     -> "Data.IntSet.empty"+                                          _               -> "[]"+                  | con == "Just"     = "Just" ++ args+                  | con == "Nothing"  = "Nothing"+                  | con == "Entry"    = ( case lookup nt typeSyns of+                                            Just (Map _ _)  -> "Data.Map.insert"+                                            Just (IntMap _) -> "Data.IntMap.insert"+                                            Just (OrdSet _) -> "Data.Set.insert"+                                            Just IntSet     -> "Data.IntSet.insert" ) ++ args+                  | otherwise         = normalExpr++       synonymMl  | con == "Tuple"    = buildTuple fs+                  | con == "Cons"     = "(::)" ++ tup+                  | con == "Nil"      = case lookup nt typeSyns of+                                          Just (Map _ _)  -> prefixMod nt "empty"+                                          Just (IntMap _) -> prefixMod nt "empty"+                                          Just (OrdSet _) -> prefixMod nt "empty"+                                          Just IntSet     -> prefixMod nt "empty"+                                          _               -> "[]"+                  | con == "Just"     = "Some" ++ tup+                  | con == "Nothing"  = "None"+                  | con == "Entry"    = ( case lookup nt typeSyns of+                                            Just (Map _ _)  -> prefixMod nt "add"+                                            Just (IntMap _) -> prefixMod nt "add"+                                            Just (OrdSet _) -> prefixMod nt "add"+                                            Just IntSet     -> prefixMod nt "add" ) ++ args+                  | otherwise         = normalExpr++       synonymClean  | con == "Tuple"    = buildTuple fs+                     | con == "Cons"     = "(\\x xs -> [x:xs])" ++ args+                     | con == "Nil"      = case lookup nt typeSyns of+                                             Just (Map _ _)  -> "Data.Map.empty"+                                             Just (IntMap _) -> "Data.IntMap.empty"+                                             Just (OrdSet _) -> "Data.Set.empty"+                                             Just IntSet     -> "Data.IntSet.empty"+                                             _               -> "[]"+                     | con == "Just"     = "Just" ++ args+                     | con == "Nothing"  = "Nothing"+                     | con == "Entry"    = ( case lookup nt typeSyns of+                                               Just (Map _ _)  -> "Data.Map.insert"+                                               Just (IntMap _) -> "Data.IntMap.insert"+                                               Just (OrdSet _) -> "Data.Set.insert"+                                               Just IntSet     -> "Data.IntSet.insert" ) ++ args+                     | otherwise         = normalExpr+++       prefixMod nt nm = "M_" ++ getName nt ++ "." ++ nm++concatSeq = foldr (Seq.><) 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)+      ]+    )++}++-------------------------------------------------------------------------------+--         Errors+-------------------------------------------------------------------------------++ATTR Grammar Nonterminals Nonterminal Productions Production+     Child Children Rule Rules Pattern Patterns+     [ | | errors USE {Seq.><} {Seq.empty}:{Seq Error} ]++-------------------------------------------------------------------------------+-- Set of all defined nonterminals+-------------------------------------------------------------------------------++ATTR Nonterminals Nonterminal  [ || collect_nts USE {`Set.union`} {Set.empty} : {Set NontermIdent}  ]+SEM Nonterminal+  | Nonterminal lhs.collect_nts = Set.singleton @nt++ATTR Nonterminals Nonterminal Productions Production [ nonterminals  : {Set NontermIdent} || ]+SEM Grammar+  | Grammar nonts.nonterminals = @nonts.collect_nts++-------------------------------------------------------------------------------+-- Pass down the lhs-attributes and the USE's to each alternative of a nonterminal+-------------------------------------------------------------------------------++ATTR Nonterminals Nonterminal [ useMap : {UseMap} || ]+ATTR Productions Production [ inh, syn, inhOrig, synOrig : {Attributes} useMap : {Map Identifier (String,String,String)}|| ]++SEM Nonterminal+  | Nonterminal  prods.inh     = @loc.inh1+                 prods.syn     = @loc.syn1+                 prods.inhOrig = @inh+                 prods.synOrig = @syn+                 prods.useMap  = Map.findWithDefault Map.empty @nt @lhs.useMap++SEM Production+  | Production  rules.con    = @con+                children.con = @con+SEM Child+  | Child lhs . name = @name+SEM Grammar+  | Grammar nonts . useMap = @useMap+SEM Grammar+  | Grammar nonts . typeSyns = @typeSyns+SEM Nonterminal+  | Nonterminal prods . nt = @nt++SEM Child [ | | name:{Identifier} inherited,synthesized:{Attributes} ]+  | Child lhs.inherited = @loc.inh1+          lhs.synthesized = if @name `Set.member` @lhs.merged+                            then Map.empty+                            else @loc.syn1++SEM Children [ | | inputs,outputs:{[(Identifier, Attributes)]} ]+  | Cons lhs.inputs  = (@hd.name, @hd.inherited) : @tl.inputs+            .outputs = (@hd.name, @hd.synthesized) : @tl.outputs+  | Nil  lhs.inputs  = []+            .outputs = []++++-------------------------------------------------------------------------------+-- Implementation of Use-rule and Copy-rule+-------------------------------------------------------------------------------++{++++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 clean nt con fld a+ = (if clean then "abort" else "error")+   ++ " \"missing rule: "+   ++ show nt  ++ "." ++ show con ++ "."+   ++ show fld ++ "." ++ show a   ++ "\""++makeRule :: (Identifier,Identifier) -> Expression -> String -> Bool -> Maybe Error -> Rule+makeRule (f1,a1) expr origin identity mbDelayedError+ = Rule Nothing+        (Alias f1 a1 (Underscore noPos))+        expr+        False+        origin+        False+        True+        identity+        mbDelayedError+        False+++useRule :: Options -> Set Identifier -> [(Identifier,Attributes)] -> (Identifier,(String,String,String)) -> Rule+useRule opts locals ch_outs (n,(op,e,pos))+ =  let elems = [ fld+                | (fld,as) <- ch_outs+                , Map.member n as+                ]++        isOp [] = False+        isOp (c:cs)+          | isSpace c = isOp cs+          | isAlpha c = case dropWhile isAlpha cs of+                       ('.':cs2) -> isOp cs2 -- fully qualified name, drop prefix+                       _         -> False+          | c == '('  = False+          | otherwise = True++        tks | Set.member n locals  =  [mkLocVar n noPos Nothing]+            | null elems           =  lexTokens opts noPos e+            | otherwise            =  lexTokens opts noPos str+                                      where+                                        opExpr l r+                                          | isOp op   = l ++ " " ++ op ++ " " ++ r         -- takes the associativity of the operator+                                          | otherwise = "(" ++ op ++ " " ++ l ++ " " ++ r ++ ")"  -- associates to the right+                                        str = foldr1 opExpr (map (flip attrName n) elems)++    in makeRule (_LHS,n)+                (Expression noPos tks)+                ("use rule " ++ pos)+                False+                Nothing+++selfRule :: Bool -> Identifier -> [HsToken] -> Rule+selfRule lhsNecLoc attr tks+ = makeRule (if lhsNecLoc then _LHS else _LOC,attr)+               (Expression noPos tks)+               "self rule"+               False+               Nothing+++++concatRE rsess = let (rss,ess) = unzip rsess+                 in (concat rss, concatSeq ess)+++copyRule :: Options -> Set NontermIdent -> Identifier -> Identifier -> Bool -> Set Identifier -> (Map Identifier Identifier, (Identifier,[Identifier])) -> ([Rule], Seq Error)+copyRule options wrappers nt con modcopy locals (env,(fld,as))+ = concatRE (map copyRu as)++ where+       copyRu a+           = ( [ makeRule (fld,a)+                          (Expression noPos tks)+                          (cruletxt sel)+                          True+                          mbDelayedErr+               ]+             , err+             )++        where+              sel+               |    not modcopy+                 && Set.member a locals  =  Just _LOC+               | otherwise               =  Map.lookup a env++              (tks,err,mbDelayedErr)+               = case sel of+                  Nothing         -> let tks = [HsToken (missingRuleErrorExpr (clean options) nt con fld a) noPos]+                                         err = MissingRule nt con fld a+                                     in if nt `Set.member` wrappers && kennedyWarren options+                                        then (tks, Seq.empty, Just err)  -- yield error only if the rule is actually scheduled; for kennedyWarren code gen only+                                        else (tks, Seq.singleton err, Nothing)+                  Just f+                   | f == _ACHILD -> ( [AGLocal a noPos Nothing]+                                     , Seq.singleton (deprecatedCopyRuleError nt con fld a)+                                     , Nothing+                                     )+                   | otherwise    -> ( [AGField f a noPos Nothing]+                                     , Seq.empty+                                     , Nothing+                                     )++              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+}+++++SEM Production+ | Production++   lhs.errors = @children.errors >< @errs >< @rules.errors >< @loc.orderErrs++   loc.(newRls, errs)+   =+    let locals       = @rules.locals+        initenv      = Map.fromList (  [ (a,_ACHILD)  -- _ACHILD is used to mark identifiers in the environment that are terminals+                                       | (a,_,_) <- @children.fields+                                       ]+                                    ++ attrs(_LHS, @lhs.inh)+                                    ++ [ (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 ) @children.outputs)++        child_envs = init envs+        lhs_env    = last envs++        (selfAttrs, normalAttrs)+          = Map.partitionWithKey (\k _ -> maybe False isSELFNonterminal $ Map.lookup k @lhs.synOrig) @lhs.syn++        (_,undefAttrs)+          = removeDefined @rules.definedAttrs (_LHS, normalAttrs)++        (useAttrs,others)+          = splitAttrs @lhs.useMap undefAttrs++        (rules1, errors1)+          = concatRE $ map (copyRule @lhs.options @lhs.wrappers @lhs.nt @con @lhs.cr locals)+                           (zip envs (map (removeDefined @rules.definedAttrs) @children.inputs))++        uRules+          = map (useRule @lhs.options locals @children.outputs) useAttrs++        -- creates a loc.xxx if there is a synthesized attr xxx of type SELF and no+        -- loc.xxx exists yet. If there exists a terminal yyy and a local loc.yyy, then+        -- the local is chosen as value for the terminal.+        selfLocRules+          =  [ selfRule False attr $+                 lexTokens @lhs.options noPos $  -- building a string and lexing it again is not so nice... but practical here+                 constructor [(childSelf attr nm tp, nm) | (nm,tp,virt) <- @children.fields, childExists virt]+             | 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+                 = buildConExpr (ocaml @lhs.options) (clean @lhs.options) @lhs.constructorTypeMap @lhs.typeSyns @lhs.o_rename @lhs.nt @con fs++               childExists ChildAttr = False+               childExists _         = True++        selfRules+          = [ selfRule True attr [mkLocVar attr noPos Nothing]+            | attr <- Map.keys selfAttrs+            , not (Set.member (_LHS,attr) @rules.definedAttrs)+            ]++        (rules5, errs5)+          = copyRule @lhs.options+                     @lhs.wrappers+                     @lhs.nt+                     @con+                     @lhs.cr+                     locals+                     (lhs_env, (_LHS, others))+    in (uRules++selfLocRules++selfRules++rules5++rules1, errors1><errs5)++{+buildTuple fs = "(" ++ concat (intersperse "," fs) ++ ")"++addAugments :: (Identifier, [Expression]) -> [Rule] -> [Rule]+addAugments (_, exprs) rules+  | null exprs = rules+addAugments (syn, exprs) rules+  = [rule] ++ funRules ++ map modify rules+  where+    rule = Rule Nothing (Alias _LHS syn (Underscore noPos)) rhs False "augmented rule" False True False Nothing False+    rhs  = Expression noPos tks+    tks  = [ HsToken "foldr ($) " noPos, mkLocVar substSyn noPos Nothing, HsToken " [" noPos] ++ funs ++ [HsToken "]" noPos]+    funs = intersperse (HsToken ", " noPos) (map (\n -> mkLocVar n noPos Nothing) funNames)++    substSyn = Ident (show syn ++ "_augmented_syn") (getPos syn)+    funNames = zipWith (\i _ -> Ident (show syn ++ "_augmented_f" ++ show i) (getPos syn)) [1..] exprs+    funRules = zipWith (\name expr -> Rule Nothing (Alias _LOC name (Underscore noPos)) expr False "augment function" False True False Nothing False) funNames exprs++    modify (Rule mbNm pat rhs owrt origin expl pure identity mbErr eager)+      | containsSyn pat = Rule mbNm (modifyPat pat) rhs owrt origin expl pure identity mbErr eager+    modify r = r++    containsSyn (Constr _ pats)   = any containsSyn pats+    containsSyn (Product _ pats)  = any containsSyn pats+    containsSyn (Irrefutable pat) = containsSyn pat+    containsSyn (Alias field attr pat) = (field == _LHS && attr == syn) || containsSyn pat+    containsSyn _ = False++    modifyPat (Constr name pats) = Constr name (map modifyPat pats)+    modifyPat (Product pos pats) = Product pos (map modifyPat pats)+    modifyPat (Irrefutable pat)  = Irrefutable (modifyPat pat)+    modifyPat (Alias field attr pat)+      | field == _LHS && attr == syn = Alias _LOC substSyn (modifyPat pat)+      | otherwise                    = Alias field attr (modifyPat pat)+    modifyPat p = p++-- adds the additional rules needed for around, which creates a sequence of+-- rules that form a function that each transforms the semantics of a child+-- before attaching the child.+-- The rule defines a local attribute "<child>_around" and <child> is dependent+-- on this attribute.+addArounds :: (Identifier, [Expression]) -> [Rule] -> [Rule]+addArounds (_, exprs) rules | null exprs = rules+addArounds (child, exprs) rules+  = [rule] ++ funRules ++ rules+  where+    rule = Rule Nothing (Alias _LOC childLoc (Underscore noPos)) rhs False "around rule" False True False Nothing False+    rhs  = Expression noPos tks+    tks  = [ HsToken "\\s -> foldr ($) s " noPos, HsToken " [" noPos] ++ funs ++ [HsToken "]" noPos]+    funs = intersperse (HsToken ", " noPos) (map (\n -> mkLocVar n noPos Nothing) funNames)++    childLoc = Ident (show child ++ "_around") (getPos child)+    funNames = zipWith (\i _ -> Ident (show child ++ "_around_f" ++ show i) (getPos child)) [1..] exprs+    funRules = zipWith (\name expr -> Rule Nothing (Alias _LOC name (Underscore noPos)) expr False "around function" False True False Nothing False) funNames exprs++-- adds the additional rules needed for merging.+-- It produces for each merging child a rule with local attribute: "<child>_merged".+-- this rules takes the semantics of the first children and feeds it to the function+-- represented by this attribute. This attribute then defines the semantics for+-- the merging child.+addMerges :: (Identifier, (Identifier,[Identifier],Expression)) -> [Rule] -> [Rule]+addMerges (target,(_,_,expr)) rules+  = rule : rules+  where+    rule = Rule Nothing (Alias _LOC childLoc (Underscore noPos)) expr False "merge rule" False True False Nothing False+    childLoc = Ident (show target ++ "_merge") (getPos target)+}+++ATTR Rule Rules Pattern Patterns+  [ | | locals        USE {`Set.union`} {Set.empty} : {Set Identifier}+        definedAttrs  USE {`Set.union`} {Set.empty} : {Set (Identifier,Identifier)}+  ]+++SEM Pattern+  | Alias lhs.definedAttrs = Set.insert (@field,@attr) @pat.definedAttrs+             .locals       = if @field == _LOC+                                then Set.insert @attr @pat.locals+                                else @pat.locals++SEM Children [ | | fields : {[(Identifier,Type,ChildKind)]} ]+  | Cons lhs.fields = @hd.field : @tl.fields+  | Nil  lhs.fields = []++SEM Child    [ | | field  : { (Identifier,Type,ChildKind) } ]+  | Child lhs.field = (@name,@tp,@kind)++-------------------------------------------------------------------------------+--+-------------------------------------------------------------------------------+ATTR Rule Pattern Patterns [ || containsVars USE {||} {False} : Bool ]++SEM Pattern+  | Alias      lhs.containsVars = True++ATTR Rule [ | | isPure : Bool ]+SEM Rule | Rule  lhs.isPure = @pure++-------------------------------------------------------------------------------+--         Eliminate SELF types+-------------------------------------------------------------------------------++SEM Nonterminal | Nonterminal+  loc.inh1 = Map.map (elimSelfId @nt @params) @inh+  loc.syn1 = Map.map (elimSelfId @nt @params) @syn++SEM Child | Child+  (loc.nt, loc.params) = case @tp of+                           NT nt params _ -> (nt, params)+                           Self           -> error ("The type of child " ++ show @name ++ " should not be a Self type.")+                           Haskell t      -> (identifier t, []) -- should be ignored because the child is a terminal+  loc.inh1 = Map.map (elimSelfStr @loc.nt @loc.params) @loc.inh+  loc.syn1 = Map.map (elimSelfStr @loc.nt @loc.params) @loc.syn++SEM TypeSig | TypeSig+  loc.tp1 = elimSelfId @lhs.nt @lhs.params @tp++{+elimSelfId :: NontermIdent -> [Identifier] -> Type -> Type+elimSelfId nt args Self = NT nt (map getName args) False+elimSelfId _ _ tp = tp++elimSelfStr :: NontermIdent -> [String] -> Type -> Type+elimSelfStr nt args Self = NT nt args False+elimSelfStr _ _ tp = tp+}++-------------------------------------------------------------------------------+--         Reconstructing the tree+-------------------------------------------------------------------------------++ATTR Nonterminals Nonterminal Productions Production Rules Rule [ | uniq:Int | ]++SEM Grammar+  | Grammar nonts.uniq = 1++ATTR Grammar Nonterminals  Nonterminal   Productions+    Production Children Child Rules Rule Pattern  Patterns TypeSigs TypeSig+    [ | | output:SELF ]++ATTR Rule [ | | outputs:Rules ]++SEM Nonterminal | Nonterminal+  lhs.output = Nonterminal @nt @params @loc.inh1 @loc.syn1 @prods.output++SEM Production+  | Production+      loc.extra1 = foldr addAugments (@rules.output ++ @newRls) (Map.assocs @loc.augmentsIn)+      loc.extra2 = foldr addArounds @loc.extra1 (Map.assocs @loc.aroundsIn)+      loc.extra3 = foldr addMerges @loc.extra2 (Map.assocs @loc.mergesIn)+      lhs.output = Production @con @params @constraints @children.output @loc.extra3 @typeSigs.output @macro++SEM Child | Child+  lhs.output = Child @name @tp @kind++SEM TypeSig | TypeSig+  lhs.output = TypeSig @name @loc.tp1++SEM Rules+  | Cons lhs.output = if @hd.containsVars && @hd.isPure then @hd.outputs ++ @tl.output else @tl.output+    -- remove rules that define nothing and do not have side effects++SEM Rule+  | Rule  (loc.output1, loc.mbAlias) = mkRuleAlias @loc.output+          (loc.outputs, lhs.uniq) = if needsMultiRules @lhs.options  -- check if this works for UHC+                                    then multiRule @loc.output1 @lhs.uniq+                                    else ([@loc.output1], @lhs.uniq)+          lhs.outputs = maybe [] return @loc.mbAlias ++ @loc.outputs++{+-- When a rule has a name, create an alias for a rule+-- and a modified rule that refers to the alias+-- Thus it removes rule names from rules+mkRuleAlias :: Rule -> (Rule, Maybe Rule)+mkRuleAlias r@(Rule Nothing _ _ _ _ _ _ _ _ _) = (r, Nothing)+mkRuleAlias (Rule (Just nm) pat expr owrt origin expl pure identity mbErr eager) = (r', Just alias) where+  alias = Rule Nothing (Alias _LOC (Ident ("_rule_" ++ show nm) pos) (Underscore pos)) expr owrt origin expl pure identity mbErr eager+  pos   = getPos nm+  expr' = Expression pos tks+  tks   = [mkLocVar (Ident ("_rule_" ++ show nm) pos) pos (Just ("Indirection to rule " ++ show nm))]+  r'    = Rule Nothing pat expr' owrt origin False True identity Nothing False+}+++-- Work towards removing the need of the "multiRule".+-- It's currently only needed for the Kastens code generation+{+needsMultiRules :: Options -> Bool+needsMultiRules opts = (visit opts || withCycle opts) && not (kennedyWarren opts)+}++{+{-+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 expl pure identity mbErr eager) uniq+  =  let f :: Bool -> (Pattern->Pattern) -> Expression -> Pattern -> Int -> (Pattern, ([Rule], Int))+         f expl' 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)+                 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 False (us (length xs1)) freshExpr p n1+                                      in  (x2:xs1, rs2++rs1, n2)+                 (xs9,rs9,n9) = foldr g ([], [], n+1) pats+             in  ( freshPat+                 , ( Rule Nothing (w freshPat) e owrt origin expl' True False mbErr eager : rs9+                   , n9+                   )+                 )+         f expl' w e p n+           = ( p+             , ( [Rule Nothing (w p) e owrt origin expl' True False mbErr eager]+               , n+               )+             )+     in snd (f expl id expr pat uniq)++}++-------------------------------------------------------------------------------+--         Check the order definitions+-------------------------------------------------------------------------------++ATTR Nonterminals Nonterminal Productions Production [ manualAttrOrderMap : {AttrOrderMap} | | ]++SEM Grammar+  | Grammar+      nonts.manualAttrOrderMap = @manualAttrOrderMap++ATTR Rules Rule [ | | ruleNames USE {`Set.union`} {Set.empty} : {Set Identifier} ]++SEM Rule | Rule  lhs.ruleNames = case @mbName of+                                   Nothing -> Set.empty+                                   Just nm -> Set.singleton nm++SEM Production+  | Production+      loc.orderDeps = Set.toList $ Map.findWithDefault Set.empty @con $ Map.findWithDefault Map.empty @lhs.nt @lhs.manualAttrOrderMap++      loc.orderErrs+        = let chldOutMap = Map.fromList [ (k, Map.keysSet s) | (k,s) <- @children.outputs ]+              chldInMap  = Map.fromList [ (k, Map.keysSet s) | (k,s) <- @children.inputs ]++              -- a local attribute+              -- or an inherited attribute of the production+              -- or an out-attribute of a child+              isInAttribute :: Identifier -> Identifier -> [Error]+              isInAttribute fld nm+                 | fld == _LOC = if nm `Set.member` @rules.locals+                                 then []+                                 else [UndefAttr @lhs.nt @con fld nm False]+                 | fld == _LHS = if nm `Map.member` @lhs.inh+                                 then []+                                 else [UndefAttr @lhs.nt @con fld nm False]+                 | otherwise   = if nm `Set.member` (Map.findWithDefault Set.empty fld chldOutMap)+                                 then []+                                 else [UndefAttr @lhs.nt @con fld nm False]++              -- a local attribute+              -- or a synthesized attribute of the production+              -- or an in-attribute of a child+              isOutAttribute :: Identifier -> Identifier -> [Error]+              isOutAttribute fld nm+                 | fld == _LOC = if nm `Set.member` @rules.locals+                                 then []+                                 else [UndefAttr @lhs.nt @con fld nm True]+                 | fld == _LHS = if nm `Map.member` @lhs.syn+                                 then []+                                 else [UndefAttr @lhs.nt @con fld nm True]+                 | otherwise   = if nm `Set.member` (Map.findWithDefault Set.empty fld chldInMap)+                                 then []+                                 else [UndefAttr @lhs.nt @con fld nm True]++              existsRule nm = if nm `Set.member` @rules.ruleNames+                              then []+                              else [MissingNamedRule @lhs.nt @con nm]++              checkIn (OccAttr fld nm)  = isInAttribute fld nm+              checkIn (OccRule nm)      = existsRule nm+              checkOut (OccAttr fld nm) = isOutAttribute fld nm+              checkOut (OccRule nm)     = existsRule nm+          in Seq.fromList . concat $+             [ checkIn occA ++ checkOut occB+             | (Dependency occA occB) <- @loc.orderDeps+             ]++-------------------------------------------------------------------------------+--         Decompose augment+-------------------------------------------------------------------------------++ATTR Nonterminals Nonterminal [ augmentsIn : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} | | ]+ATTR Productions Production [ augmentsIn : {Map ConstructorIdent (Map Identifier [Expression])} | | ]++SEM Grammar     | Grammar      nonts.augmentsIn = @augmentsMap+SEM Nonterminal | Nonterminal  loc.augmentsIn = Map.findWithDefault Map.empty @nt @lhs.augmentsIn+SEM Production  | Production   loc.augmentsIn = Map.findWithDefault Map.empty @con @lhs.augmentsIn++ATTR Nonterminals Nonterminal [ aroundsIn : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} | | ]+ATTR Productions Production [ aroundsIn : {Map ConstructorIdent (Map Identifier [Expression])} | | ]++SEM Grammar     | Grammar      nonts.aroundsIn = @aroundsMap+SEM Nonterminal | Nonterminal  loc.aroundsIn   = Map.findWithDefault Map.empty @nt @lhs.aroundsIn+SEM Production  | Production   loc.aroundsIn   = Map.findWithDefault Map.empty @con @lhs.aroundsIn++ATTR Nonterminals Nonterminal [ mergesIn : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression)))} | | ]+ATTR Productions Production [ mergesIn : {Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression))} | | ]+ATTR Children Child [ merged : {Set Identifier} | | ]++SEM Grammar     | Grammar      nonts.mergesIn = @mergeMap+SEM Nonterminal | Nonterminal  loc.mergesIn   = Map.findWithDefault Map.empty @nt @lhs.mergesIn+SEM Production  | Production   loc.mergesIn   = Map.findWithDefault Map.empty @con @lhs.mergesIn+                               loc.merged     = Set.fromList [ c | (_,cs,_) <- Map.elems @loc.mergesIn, c <- cs ]
src-ag/Desugar.ag view
@@ -1,332 +1,332 @@-PRAGMA strictdata
-PRAGMA optimize
-PRAGMA bangpats
-PRAGMA strictwrap
-
-INCLUDE "AbstractSyntax.ag"
-INCLUDE "Patterns.ag"
-INCLUDE "Expression.ag"
-INCLUDE "HsToken.ag"
-INCLUDE "DistChildAttr.ag"
-
-
-imports
-{
-import qualified Data.Set as Set
-import qualified Data.Map as Map
-import Data.Map(Map)
-import qualified Data.Sequence as Seq
-import Data.Sequence(Seq,(><))
-import UU.Scanner.Position(Pos(..))
-import Data.Maybe
-import Data.List(intersperse)
-
-import AbstractSyntax
-import ErrorMessages
-import Options
-import HsToken
-import HsTokenScanner
-import TokenDef
-import CommonTypes
-}
-
-WRAPPER HsTokensRoot
-
-
-ATTR Grammar Nonterminals Nonterminal Productions Production Children Child Rule Rules Expression [ options:{Options} | | ]
-
-ATTR Grammar Nonterminals Nonterminal Productions Production Rule Rules Pattern Patterns Expression HsTokensRoot HsToken HsTokens [ | | errors USE {Seq.><} {Seq.empty} : {Seq Error} ]
-
-ATTR Grammar Nonterminals Nonterminal Productions Production Child Children Rule Rules Pattern Patterns TypeSig TypeSigs Expression [ | | output : SELF ]
-
-
--------------------------------------------------------------------------------
---         Deal with RHS
--------------------------------------------------------------------------------
-
-SEM Expression
-  | Expression
-      (loc.tks', lhs.errors) = let inh = Inh_HsTokensRoot { childInhs_Inh_HsTokensRoot     = @lhs.childInhs
-                                                          , childSyns_Inh_HsTokensRoot     = @lhs.childSyns
-                                                          , nt_Inh_HsTokensRoot            = @lhs.nt
-                                                          , con_Inh_HsTokensRoot           = @lhs.con
-                                                          , ruleDescr_Inh_HsTokensRoot     = @lhs.ruleDescr
-                                                          , useFieldIdent_Inh_HsTokensRoot = genUseTraces @lhs.options
-                                                          }
-                                   sem = sem_HsTokensRoot (HsTokensRoot @tks)
-                                   syn = wrap_HsTokensRoot sem inh
-                               in (tks_Syn_HsTokensRoot syn, errors_Syn_HsTokensRoot syn)
-      lhs.output = Expression @pos @tks'
-
-
-ATTR HsTokensRoot HsTokens HsToken [ useFieldIdent : Bool | | ]
-
-ATTR HsToken HsTokens [ | addLines : Int | ]
-SEM HsTokensRoot
-  | HsTokensRoot
-      tokens.addLines = 0
-
-ATTR HsTokensRoot [ | | tks : {[HsToken]} ]
-ATTR HsToken HsTokens [ | | tks : SELF ]
-
-SEM HsToken
-  | AGLocal
-      lhs.addLines = if @lhs.useFieldIdent
-                     then @lhs.addLines + 1
-                     else @lhs.addLines
-      loc.tks = AGLocal @var (addl @lhs.addLines @pos) (if @lhs.useFieldIdent then Just @lhs.ruleDescr else Nothing)
-  | AGField
-      loc.mField = findField @field @attr @lhs.childSyns
-
-      loc.field' = maybe @field id @loc.mField
-      lhs.errors = maybe (Seq.singleton (UndefAttr @lhs.nt @lhs.con @field (Ident "<ANY>" (getPos @field)) False)) (const Seq.empty) @loc.mField
-
-      lhs.addLines = if @lhs.useFieldIdent || length (getName @field) < length (getName @loc.field')
-                     then @lhs.addLines + 1
-                     else @lhs.addLines
-
-      loc.tks = AGField @loc.field' @attr (addl @lhs.addLines @pos) (if @lhs.useFieldIdent then Just @lhs.ruleDescr else Nothing)
-  | HsToken
-      loc.tks = HsToken @value (addl @lhs.addLines @pos)
-  | CharToken
-      loc.tks = CharToken @value (addl @lhs.addLines @pos)
-  | StrToken
-      loc.tks = StrToken @value (addl @lhs.addLines @pos)
-  | Err
-      loc.tks = Err @mesg (addl @lhs.addLines @pos)
-
-{
-addl :: Int -> Pos -> Pos
-addl n (Pos l c f) = Pos (l+n) c f
-}
-
-
--------------------------------------------------------------------------------
---         Deal with LHS
--------------------------------------------------------------------------------
-
-SEM Pattern
-  | Alias
-      (loc.field', loc.err1) = maybeError @field (UndefAttr @lhs.nt @lhs.con (Ident "<ANY>" (getPos @field)) @attr True) $
-                                 findField @field @attr @lhs.childInhs
-      loc.err2 = if @loc.field' == @field
-                 then Seq.empty
-                 else if (@loc.field', @attr) `Set.member` @lhs.defs
-                      then Seq.singleton $ DupRule @lhs.nt @lhs.con @field @attr @loc.field'
-                      else Seq.empty
-      lhs.errors = @loc.err1 Seq.>< @loc.err2 Seq.>< @pat.errors
-      loc.output = Alias @loc.field' @attr @pat.output
-
-
--------------------------------------------------------------------------------
---         Distribute attributes of children
--------------------------------------------------------------------------------
-
-ATTR Children Child [ | | childInhs, childSyns USE {++} {[]} : {[(Identifier, Identifier)]} ]
-ATTR Rules Rule Pattern Patterns Expression HsTokensRoot HsToken HsTokens [ childInhs, childSyns : {[(Identifier, Identifier)]} | | ]
-
-SEM Child
-  | Child
-      lhs.childInhs = [(i, @name) | i <- Map.keys @loc.inh ]
-      lhs.childSyns = [(s, @name) | s <- Map.keys @loc.syn ]
-
-{
-maybeError :: a -> Error -> Maybe a -> (a, Seq Error)
-maybeError def err mb
-  = maybe (def, Seq.singleton 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
-}
-
-
--------------------------------------------------------------------------------
---         Distribute nt and con
--------------------------------------------------------------------------------
-
-ATTR Productions Production Rule Rules Pattern Patterns Expression HsTokensRoot HsToken HsTokens [ nt : NontermIdent | | ]
-ATTR Rule Rules Pattern Patterns Expression HsTokensRoot HsToken HsTokens [ con : ConstructorIdent | | ]
-
-SEM Nonterminal
-  | Nonterminal
-      prods.nt = @nt
-
-SEM Production
-  | Production
-      rules.con = @con
-
-
--------------------------------------------------------------------------------
---         Distribute a pattern description
--------------------------------------------------------------------------------
-
-ATTR Expression HsTokensRoot HsToken HsTokens [ ruleDescr : String | | ]
-
-SEM Rule
-  | Rule
-      loc.ruleDescr = show @lhs.nt ++ " :: " ++ show @lhs.con ++ " :: " ++ (concat $ intersperse "," $ map (\(f,a) -> show f ++ "." ++ show a) $ Set.toList @pattern.defsCollect)
-
-
--------------------------------------------------------------------------------
---         Distribute all defined attributes
--------------------------------------------------------------------------------
-
-ATTR Rule Rules Pattern Patterns [ | | defsCollect USE {`Set.union`} {Set.empty} : {Set (Identifier, Identifier)} ]
-SEM Pattern
-  | Alias
-      loc.def = Set.singleton (@field, @attr)
-      lhs.defsCollect = @loc.def `Set.union` @pat.defsCollect
-
-ATTR Rule Rules Pattern Patterns [ defs : {Set (Identifier, Identifier)} | | ]
-SEM Production
-  | Production
-      rules.defs = @rules.defsCollect
-
-
--------------------------------------------------------------------------------
---         Collect a list of all attributes (that are not irrefutable)
--------------------------------------------------------------------------------
-
-ATTR Grammar Nonterminals Nonterminal Productions Production Rule Rules Pattern Patterns
-  [ | | allAttributes USE {`mergeAttributes`} {Map.empty} : {AttrMap} ]
-
-SEM Pattern
-  | Alias
-      lhs.allAttributes = (Map.singleton @lhs.nt $ Map.singleton @lhs.con $ Set.singleton (@field, @attr)) `mergeAttributes` @pat.allAttributes
-  | Irrefutable
-      lhs.allAttributes = Map.empty
-
-{
-mergeAttributes :: AttrMap -> AttrMap -> AttrMap
-mergeAttributes = Map.unionWith $ Map.unionWith $ Set.union
-}
-
-
--------------------------------------------------------------------------------
---         Distribute a list of attributes forced to irrefutables
--------------------------------------------------------------------------------
-
-ATTR Grammar Nonterminals Nonterminal Productions Production Rule Rules Pattern Patterns
-  [ forcedIrrefutables : {AttrMap} | | ]
-
-SEM Pattern
-  | Alias
-      lhs.output = if Set.member (@field, @attr) $ Map.findWithDefault Set.empty @lhs.con $ Map.findWithDefault Map.empty @lhs.nt $ @lhs.forcedIrrefutables
-                   then Irrefutable @loc.output
-                   else @loc.output
-
-
--------------------------------------------------------------------------------
---         Decompose augment map and rebuild it
--------------------------------------------------------------------------------
-
-ATTR Nonterminals Nonterminal [ augmentsIn : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))}
-                              | | augmentsOut USE {`Map.union`} {Map.empty} : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} ]
-ATTR Productions Production [ augmentsIn : {Map ConstructorIdent (Map Identifier [Expression])}
-                            | | augmentsOut USE {`Map.union`} {Map.empty} : {Map ConstructorIdent (Map Identifier [Expression])} ]
-
-SEM Grammar
-  | Grammar
-      nonts.augmentsIn = @augmentsMap
-
-SEM Nonterminal
-  | Nonterminal
-      loc.augmentsIn = Map.findWithDefault Map.empty @nt @lhs.augmentsIn
-      loc.augmentsOut = Map.singleton @nt @prods.augmentsOut
-
-SEM Production
-  | Production
-      loc.augmentsIn = Map.findWithDefault Map.empty @con @lhs.augmentsIn
-      loc.augmentsOut = Map.singleton @con @loc.augmentsOut1
-
-      (loc.augmentErrs, loc.augmentsOut1) = Map.mapAccum (desugarExprs @lhs.options @lhs.nt @con @children.childInhs @children.childSyns) Seq.empty @loc.augmentsIn
-
-WRAPPER Expression
-
-{
-desugarExprs :: Options -> NontermIdent -> ConstructorIdent ->
-                [(Identifier, Identifier)] -> [(Identifier, Identifier)] ->
-                Seq Error -> [Expression] -> (Seq Error, [Expression])
-desugarExprs options nt con childInhs childSyns
-  = mapAccum (desugarExpr options nt con childInhs childSyns)
-  where mapAccum f e = foldr (\x (e0,xs) -> let (e1,x') = f e0 x in (e1, x:xs)) (e, [])
-
-desugarExpr :: Options -> NontermIdent -> ConstructorIdent ->
-               [(Identifier, Identifier)] -> [(Identifier, Identifier)] ->
-               Seq Error -> Expression -> (Seq Error, Expression)
-desugarExpr options nt con childInhs childSyns errs expr
-  = (errs Seq.>< errors_Syn_Expression syn, output_Syn_Expression syn)
-  where
-    inh = Inh_Expression { childInhs_Inh_Expression = childInhs
-                         , childSyns_Inh_Expression = childSyns
-                         , con_Inh_Expression       = con
-                         , nt_Inh_Expression        = nt
-                         , options_Inh_Expression   = options
-                         , ruleDescr_Inh_Expression = "augment-rule"
-                         }
-    sem = sem_Expression expr
-    syn = wrap_Expression sem inh
-}
-
-
--------------------------------------------------------------------------------
---         Errors of a production
--------------------------------------------------------------------------------
-
-SEM Production
-  | Production
-      lhs.errors = @rules.errors Seq.>< @loc.augmentErrs
-
--------------------------------------------------------------------------------
---         Support for late binding of higher order children
--------------------------------------------------------------------------------
-
-ATTR Grammar Nonterminals Nonterminal Productions Production Children Child [ mainName : {String} | | ]
-
-SEM Nonterminal | Nonterminal
-  loc.extraInh = addLateAttr @lhs.options @lhs.mainName
-
-{
-addLateAttr :: Options -> String -> Attributes
-addLateAttr options mainName
-  | kennedyWarren options && lateHigherOrderBinding options =
-      let tp = lateBindingType mainName
-      in Map.singleton idLateBindingAttr tp
-  | otherwise = Map.empty
-}
-
--------------------------------------------------------------------------------
---         Reconstruct the grammar
--------------------------------------------------------------------------------
-
-SEM Nonterminal | Nonterminal
-  lhs.output = Nonterminal
-                 @nt @params
-                 (@loc.extraInh `Map.union` @inh)
-                 @syn
-                 @prods.output
-
-SEM Child | Child
-  lhs.output = Child @name @tp @kind
-
-SEM Grammar
-  | Grammar
-      lhs.output = Grammar @typeSyns
-                           @useMap
-                           @derivings
-                           @wrappers
-                           @nonts.output
-                           @pragmas
-                           @manualAttrOrderMap
-                           @paramMap
-                           @contextMap
-                           @quantMap
-                           @uniqueMap
-                           @nonts.augmentsOut
-                           @aroundsMap
-                           @mergeMap
+PRAGMA strictdata+PRAGMA optimize+PRAGMA bangpats+PRAGMA strictwrap++INCLUDE "AbstractSyntax.ag"+INCLUDE "Patterns.ag"+INCLUDE "Expression.ag"+INCLUDE "HsToken.ag"+INCLUDE "DistChildAttr.ag"+++imports+{+import qualified Data.Set as Set+import qualified Data.Map as Map+import Data.Map(Map)+import qualified Data.Sequence as Seq+import Data.Sequence(Seq,(><))+import UU.Scanner.Position(Pos(..))+import Data.Maybe+import Data.List(intersperse)++import AbstractSyntax+import ErrorMessages+import Options+import HsToken+import HsTokenScanner+import TokenDef+import CommonTypes+}++WRAPPER HsTokensRoot+++ATTR Grammar Nonterminals Nonterminal Productions Production Children Child Rule Rules Expression [ options:{Options} | | ]++ATTR Grammar Nonterminals Nonterminal Productions Production Rule Rules Pattern Patterns Expression HsTokensRoot HsToken HsTokens [ | | errors USE {Seq.><} {Seq.empty} : {Seq Error} ]++ATTR Grammar Nonterminals Nonterminal Productions Production Child Children Rule Rules Pattern Patterns TypeSig TypeSigs Expression [ | | output : SELF ]+++-------------------------------------------------------------------------------+--         Deal with RHS+-------------------------------------------------------------------------------++SEM Expression+  | Expression+      (loc.tks', lhs.errors) = let inh = Inh_HsTokensRoot { childInhs_Inh_HsTokensRoot     = @lhs.childInhs+                                                          , childSyns_Inh_HsTokensRoot     = @lhs.childSyns+                                                          , nt_Inh_HsTokensRoot            = @lhs.nt+                                                          , con_Inh_HsTokensRoot           = @lhs.con+                                                          , ruleDescr_Inh_HsTokensRoot     = @lhs.ruleDescr+                                                          , useFieldIdent_Inh_HsTokensRoot = genUseTraces @lhs.options+                                                          }+                                   sem = sem_HsTokensRoot (HsTokensRoot @tks)+                                   syn = wrap_HsTokensRoot sem inh+                               in (tks_Syn_HsTokensRoot syn, errors_Syn_HsTokensRoot syn)+      lhs.output = Expression @pos @tks'+++ATTR HsTokensRoot HsTokens HsToken [ useFieldIdent : Bool | | ]++ATTR HsToken HsTokens [ | addLines : Int | ]+SEM HsTokensRoot+  | HsTokensRoot+      tokens.addLines = 0++ATTR HsTokensRoot [ | | tks : {[HsToken]} ]+ATTR HsToken HsTokens [ | | tks : SELF ]++SEM HsToken+  | AGLocal+      lhs.addLines = if @lhs.useFieldIdent+                     then @lhs.addLines + 1+                     else @lhs.addLines+      loc.tks = AGLocal @var (addl @lhs.addLines @pos) (if @lhs.useFieldIdent then Just @lhs.ruleDescr else Nothing)+  | AGField+      loc.mField = findField @field @attr @lhs.childSyns++      loc.field' = maybe @field id @loc.mField+      lhs.errors = maybe (Seq.singleton (UndefAttr @lhs.nt @lhs.con @field (Ident "<ANY>" (getPos @field)) False)) (const Seq.empty) @loc.mField++      lhs.addLines = if @lhs.useFieldIdent || length (getName @field) < length (getName @loc.field')+                     then @lhs.addLines + 1+                     else @lhs.addLines++      loc.tks = AGField @loc.field' @attr (addl @lhs.addLines @pos) (if @lhs.useFieldIdent then Just @lhs.ruleDescr else Nothing)+  | HsToken+      loc.tks = HsToken @value (addl @lhs.addLines @pos)+  | CharToken+      loc.tks = CharToken @value (addl @lhs.addLines @pos)+  | StrToken+      loc.tks = StrToken @value (addl @lhs.addLines @pos)+  | Err+      loc.tks = Err @mesg (addl @lhs.addLines @pos)++{+addl :: Int -> Pos -> Pos+addl n (Pos l c f) = Pos (l+n) c f+}+++-------------------------------------------------------------------------------+--         Deal with LHS+-------------------------------------------------------------------------------++SEM Pattern+  | Alias+      (loc.field', loc.err1) = maybeError @field (UndefAttr @lhs.nt @lhs.con (Ident "<ANY>" (getPos @field)) @attr True) $+                                 findField @field @attr @lhs.childInhs+      loc.err2 = if @loc.field' == @field+                 then Seq.empty+                 else if (@loc.field', @attr) `Set.member` @lhs.defs+                      then Seq.singleton $ DupRule @lhs.nt @lhs.con @field @attr @loc.field'+                      else Seq.empty+      lhs.errors = @loc.err1 Seq.>< @loc.err2 Seq.>< @pat.errors+      loc.output = Alias @loc.field' @attr @pat.output+++-------------------------------------------------------------------------------+--         Distribute attributes of children+-------------------------------------------------------------------------------++ATTR Children Child [ | | childInhs, childSyns USE {++} {[]} : {[(Identifier, Identifier)]} ]+ATTR Rules Rule Pattern Patterns Expression HsTokensRoot HsToken HsTokens [ childInhs, childSyns : {[(Identifier, Identifier)]} | | ]++SEM Child+  | Child+      lhs.childInhs = [(i, @name) | i <- Map.keys @loc.inh ]+      lhs.childSyns = [(s, @name) | s <- Map.keys @loc.syn ]++{+maybeError :: a -> Error -> Maybe a -> (a, Seq Error)+maybeError def err mb+  = maybe (def, Seq.singleton 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+}+++-------------------------------------------------------------------------------+--         Distribute nt and con+-------------------------------------------------------------------------------++ATTR Productions Production Rule Rules Pattern Patterns Expression HsTokensRoot HsToken HsTokens [ nt : NontermIdent | | ]+ATTR Rule Rules Pattern Patterns Expression HsTokensRoot HsToken HsTokens [ con : ConstructorIdent | | ]++SEM Nonterminal+  | Nonterminal+      prods.nt = @nt++SEM Production+  | Production+      rules.con = @con+++-------------------------------------------------------------------------------+--         Distribute a pattern description+-------------------------------------------------------------------------------++ATTR Expression HsTokensRoot HsToken HsTokens [ ruleDescr : String | | ]++SEM Rule+  | Rule+      loc.ruleDescr = show @lhs.nt ++ " :: " ++ show @lhs.con ++ " :: " ++ (concat $ intersperse "," $ map (\(f,a) -> show f ++ "." ++ show a) $ Set.toList @pattern.defsCollect)+++-------------------------------------------------------------------------------+--         Distribute all defined attributes+-------------------------------------------------------------------------------++ATTR Rule Rules Pattern Patterns [ | | defsCollect USE {`Set.union`} {Set.empty} : {Set (Identifier, Identifier)} ]+SEM Pattern+  | Alias+      loc.def = Set.singleton (@field, @attr)+      lhs.defsCollect = @loc.def `Set.union` @pat.defsCollect++ATTR Rule Rules Pattern Patterns [ defs : {Set (Identifier, Identifier)} | | ]+SEM Production+  | Production+      rules.defs = @rules.defsCollect+++-------------------------------------------------------------------------------+--         Collect a list of all attributes (that are not irrefutable)+-------------------------------------------------------------------------------++ATTR Grammar Nonterminals Nonterminal Productions Production Rule Rules Pattern Patterns+  [ | | allAttributes USE {`mergeAttributes`} {Map.empty} : {AttrMap} ]++SEM Pattern+  | Alias+      lhs.allAttributes = (Map.singleton @lhs.nt $ Map.singleton @lhs.con $ Set.singleton (@field, @attr)) `mergeAttributes` @pat.allAttributes+  | Irrefutable+      lhs.allAttributes = Map.empty++{+mergeAttributes :: AttrMap -> AttrMap -> AttrMap+mergeAttributes = Map.unionWith $ Map.unionWith $ Set.union+}+++-------------------------------------------------------------------------------+--         Distribute a list of attributes forced to irrefutables+-------------------------------------------------------------------------------++ATTR Grammar Nonterminals Nonterminal Productions Production Rule Rules Pattern Patterns+  [ forcedIrrefutables : {AttrMap} | | ]++SEM Pattern+  | Alias+      lhs.output = if Set.member (@field, @attr) $ Map.findWithDefault Set.empty @lhs.con $ Map.findWithDefault Map.empty @lhs.nt $ @lhs.forcedIrrefutables+                   then Irrefutable @loc.output+                   else @loc.output+++-------------------------------------------------------------------------------+--         Decompose augment map and rebuild it+-------------------------------------------------------------------------------++ATTR Nonterminals Nonterminal [ augmentsIn : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))}+                              | | augmentsOut USE {`Map.union`} {Map.empty} : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} ]+ATTR Productions Production [ augmentsIn : {Map ConstructorIdent (Map Identifier [Expression])}+                            | | augmentsOut USE {`Map.union`} {Map.empty} : {Map ConstructorIdent (Map Identifier [Expression])} ]++SEM Grammar+  | Grammar+      nonts.augmentsIn = @augmentsMap++SEM Nonterminal+  | Nonterminal+      loc.augmentsIn = Map.findWithDefault Map.empty @nt @lhs.augmentsIn+      loc.augmentsOut = Map.singleton @nt @prods.augmentsOut++SEM Production+  | Production+      loc.augmentsIn = Map.findWithDefault Map.empty @con @lhs.augmentsIn+      loc.augmentsOut = Map.singleton @con @loc.augmentsOut1++      (loc.augmentErrs, loc.augmentsOut1) = Map.mapAccum (desugarExprs @lhs.options @lhs.nt @con @children.childInhs @children.childSyns) Seq.empty @loc.augmentsIn++WRAPPER Expression++{+desugarExprs :: Options -> NontermIdent -> ConstructorIdent ->+                [(Identifier, Identifier)] -> [(Identifier, Identifier)] ->+                Seq Error -> [Expression] -> (Seq Error, [Expression])+desugarExprs options nt con childInhs childSyns+  = mapAccum (desugarExpr options nt con childInhs childSyns)+  where mapAccum f e = foldr (\x (e0,xs) -> let (e1,x') = f e0 x in (e1, x:xs)) (e, [])++desugarExpr :: Options -> NontermIdent -> ConstructorIdent ->+               [(Identifier, Identifier)] -> [(Identifier, Identifier)] ->+               Seq Error -> Expression -> (Seq Error, Expression)+desugarExpr options nt con childInhs childSyns errs expr+  = (errs Seq.>< errors_Syn_Expression syn, output_Syn_Expression syn)+  where+    inh = Inh_Expression { childInhs_Inh_Expression = childInhs+                         , childSyns_Inh_Expression = childSyns+                         , con_Inh_Expression       = con+                         , nt_Inh_Expression        = nt+                         , options_Inh_Expression   = options+                         , ruleDescr_Inh_Expression = "augment-rule"+                         }+    sem = sem_Expression expr+    syn = wrap_Expression sem inh+}+++-------------------------------------------------------------------------------+--         Errors of a production+-------------------------------------------------------------------------------++SEM Production+  | Production+      lhs.errors = @rules.errors Seq.>< @loc.augmentErrs++-------------------------------------------------------------------------------+--         Support for late binding of higher order children+-------------------------------------------------------------------------------++ATTR Grammar Nonterminals Nonterminal Productions Production Children Child [ mainName : {String} | | ]++SEM Nonterminal | Nonterminal+  loc.extraInh = addLateAttr @lhs.options @lhs.mainName++{+addLateAttr :: Options -> String -> Attributes+addLateAttr options mainName+  | kennedyWarren options && lateHigherOrderBinding options =+      let tp = lateBindingType mainName+      in Map.singleton idLateBindingAttr tp+  | otherwise = Map.empty+}++-------------------------------------------------------------------------------+--         Reconstruct the grammar+-------------------------------------------------------------------------------++SEM Nonterminal | Nonterminal+  lhs.output = Nonterminal+                 @nt @params+                 (@loc.extraInh `Map.union` @inh)+                 @syn+                 @prods.output++SEM Child | Child+  lhs.output = Child @name @tp @kind++SEM Grammar+  | Grammar+      lhs.output = Grammar @typeSyns+                           @useMap+                           @derivings+                           @wrappers+                           @nonts.output+                           @pragmas+                           @manualAttrOrderMap+                           @paramMap+                           @contextMap+                           @quantMap+                           @uniqueMap+                           @nonts.augmentsOut+                           @aroundsMap+                           @mergeMap
src-ag/DistChildAttr.ag view
@@ -1,24 +1,24 @@--------------------------------------------------------------------------------
--- Map of all inherited and synthesized attributes per nonterminal
--------------------------------------------------------------------------------
-ATTR Nonterminals Nonterminal [ || inhMap', synMap' USE {`Map.union`} {Map.empty} : {Map Identifier Attributes} ]
-
-SEM Nonterminal
-  | Nonterminal  lhs.inhMap' = Map.singleton @nt @inh
-                 lhs.synMap' = Map.singleton @nt @syn
-
-ATTR Nonterminals Nonterminal
-     Productions Production
-     Children Child [ inhMap, synMap : {Map Identifier Attributes} | | ]
-
-SEM Grammar
-  | Grammar nonts.inhMap = @nonts.inhMap'
-            nonts.synMap = @nonts.synMap'
-
-SEM Child
-  | Child loc.chnt = case @tp of
-                       NT nt _ _ -> nt
-                       Self      -> error ("The type of child " ++ show @name ++ " should not be a Self type.")
-                       Haskell t -> identifier "" -- should be ignored because the child is a terminal
-          loc.inh = Map.findWithDefault Map.empty @loc.chnt @lhs.inhMap
-          loc.syn = Map.findWithDefault Map.empty @loc.chnt @lhs.synMap
+-------------------------------------------------------------------------------+-- Map of all inherited and synthesized attributes per nonterminal+-------------------------------------------------------------------------------+ATTR Nonterminals Nonterminal [ || inhMap', synMap' USE {`Map.union`} {Map.empty} : {Map Identifier Attributes} ]++SEM Nonterminal+  | Nonterminal  lhs.inhMap' = Map.singleton @nt @inh+                 lhs.synMap' = Map.singleton @nt @syn++ATTR Nonterminals Nonterminal+     Productions Production+     Children Child [ inhMap, synMap : {Map Identifier Attributes} | | ]++SEM Grammar+  | Grammar nonts.inhMap = @nonts.inhMap'+            nonts.synMap = @nonts.synMap'++SEM Child+  | Child loc.chnt = case @tp of+                       NT nt _ _ -> nt+                       Self      -> error ("The type of child " ++ show @name ++ " should not be a Self type.")+                       Haskell t -> identifier "" -- should be ignored because the child is a terminal+          loc.inh = Map.findWithDefault Map.empty @loc.chnt @lhs.inhMap+          loc.syn = Map.findWithDefault Map.empty @loc.chnt @lhs.synMap
src-ag/ErrorMessages.ag view
@@ -1,148 +1,148 @@-imports
-{
-import UU.Scanner.Position(Pos)
-import Pretty
-import CodeSyntax
-import CommonTypes
-}
-
-TYPE Errors = [Error]
-
-DATA Error  | ParserError     pos     : {Pos}
-                              problem : {String}
-                              action  : {String}
-
-            | HsParseError    pos     : {Pos}
-                              msg     : {String}
-
-            | DupAlt          nt    : {NontermIdent}
-                              con,occ1 : {ConstructorIdent}
-
-            | DupSynonym      nt,occ1 : {NontermIdent}
-
-            | DupSet          name,occ1 : {NontermIdent}
-
-            | DupInhAttr      nt    : {NontermIdent}
-                              attr,occ1 :{Identifier}
-
-            | DupSynAttr      nt    : {NontermIdent}
-                              attr,occ1 : {Identifier}
-
-            | DupChild        nt    : {NontermIdent}
-                              con   : {ConstructorIdent}
-                              name,occ1 : {Identifier}
-
-            | DupRule         nt    : {NontermIdent}
-                              con   : {ConstructorIdent}
-                              field : {Identifier}
-                              attr,occ1 : {Identifier}
-
-            | DupRuleName     nt    : {NontermIdent}
-                              con   : {ConstructorIdent}
-                              nm    : {Identifier}
-
-            | DupSig          nt    : {NontermIdent}
-                              con   : {ConstructorIdent}
-                              attr  : {Identifier}
-
-            | UndefNont       nt    : {NontermIdent}
-
-            | UndefAlt        nt    : {NontermIdent}
-                              con   : {ConstructorIdent}
-
-            | UndefChild      nt    : {NontermIdent}
-                              con   : {ConstructorIdent}
-                              name  : {Identifier}
-
-            | MissingRule     --pos : {Pos}
-                              nt    : {NontermIdent}
-                              con   : {ConstructorIdent}
-                              field : {Identifier}
-                              attr  : {Identifier}
-
-            | MissingNamedRule  nt   : {NontermIdent}
-                                con  : {Identifier}
-                                name : {Identifier}
-
-            | SuperfluousRule nt    : {NontermIdent}
-                              con   : {ConstructorIdent}
-                              field : {Identifier}
-                              attr  : {Identifier}
-
---            | SuperfluousSig  nt    : {NontermIdent}
---                              con   : {ConstructorIdent}
---                              attr  : {Identifier}
-
-            | UndefLocal      nt    : {NontermIdent}
-                              con   : {ConstructorIdent}
-                              var   : {Identifier}
-
-            | ChildAsLocal    nt    : {NontermIdent}
-                              con   : {ConstructorIdent}
-                              var   : {Identifier}
-
-            | UndefAttr       nt    : {NontermIdent}
-                              con   : {ConstructorIdent}
-                              field : {Identifier}
-                              attr  : {Identifier}
-                              isOut : {Bool}
-
-            | Cyclic          nt    : {NontermIdent}
-                              mbCon : {Maybe ConstructorIdent}
-                              verts : {[String]}
-
-            | CyclicSet       name:{Identifier}
-
-            | CustomError     isWarning : {Bool}
-                              pos   : {Pos}
-                              mesg  : {PP_Doc}
-
-            | LocalCirc       nt      : {NontermIdent}
-                              con     : {ConstructorIdent}
-                              attr    : {Identifier}
-                              o_visit : {Bool}
-                              path    : {[String]}
-
-            | InstCirc        nt      : {NontermIdent}
-                              con     : {ConstructorIdent}
-                              attr    : {Identifier}
-                              o_visit : {Bool}
-                              path    : {[String]}
-
-            | DirectCirc      nt      : {NontermIdent}
-                              o_visit : {Bool}
-                              cyclic  : {[((Identifier,Identifier),[String],[String])]}
-
-            | InducedCirc     nt      : {NontermIdent}
-                              cinter  : {CInterface}
-                              cyclic  : {[((Identifier,Identifier),[String],[String])]}
-
-            | MissingTypeSig  nt      : {NontermIdent}
-                              con     : {ConstructorIdent}
-                              attr    : {Identifier}
-
-            | MissingInstSig  nt      : {NontermIdent}
-                              con     : {ConstructorIdent}
-                              attr    : {Identifier}
-
-            | DupUnique       nt      : {NontermIdent}
-                              con     : {ConstructorIdent}
-                              attr    : {Identifier}
-
-            | MissingUnique   nt      : {NontermIdent}
-                              attr    : {Identifier}
-
-            | MissingSyn      nt      : {NontermIdent}
-                              attr    : {Identifier}
-
-            | IncompatibleVisitKind
-                              child   : {Identifier}
-                              vis     : {VisitIdentifier}
-                              from    : {VisitKind}
-                              to      : {VisitKind}
-            | IncompatibleRuleKind
-                              rule    : {Identifier}
-                              kind    : {VisitKind}
-            | IncompatibleAttachKind
-                              child   : {Identifier}
-                              kind    : {VisitKind}
+imports+{+import UU.Scanner.Position(Pos)+import Pretty+import CodeSyntax+import CommonTypes+}++TYPE Errors = [Error]++DATA Error  | ParserError     pos     : {Pos}+                              problem : {String}+                              action  : {String}++            | HsParseError    pos     : {Pos}+                              msg     : {String}++            | DupAlt          nt    : {NontermIdent}+                              con,occ1 : {ConstructorIdent}++            | DupSynonym      nt,occ1 : {NontermIdent}++            | DupSet          name,occ1 : {NontermIdent}++            | DupInhAttr      nt    : {NontermIdent}+                              attr,occ1 :{Identifier}++            | DupSynAttr      nt    : {NontermIdent}+                              attr,occ1 : {Identifier}++            | DupChild        nt    : {NontermIdent}+                              con   : {ConstructorIdent}+                              name,occ1 : {Identifier}++            | DupRule         nt    : {NontermIdent}+                              con   : {ConstructorIdent}+                              field : {Identifier}+                              attr,occ1 : {Identifier}++            | DupRuleName     nt    : {NontermIdent}+                              con   : {ConstructorIdent}+                              nm    : {Identifier}++            | DupSig          nt    : {NontermIdent}+                              con   : {ConstructorIdent}+                              attr  : {Identifier}++            | UndefNont       nt    : {NontermIdent}++            | UndefAlt        nt    : {NontermIdent}+                              con   : {ConstructorIdent}++            | UndefChild      nt    : {NontermIdent}+                              con   : {ConstructorIdent}+                              name  : {Identifier}++            | MissingRule     --pos : {Pos}+                              nt    : {NontermIdent}+                              con   : {ConstructorIdent}+                              field : {Identifier}+                              attr  : {Identifier}++            | MissingNamedRule  nt   : {NontermIdent}+                                con  : {Identifier}+                                name : {Identifier}++            | SuperfluousRule nt    : {NontermIdent}+                              con   : {ConstructorIdent}+                              field : {Identifier}+                              attr  : {Identifier}++--            | SuperfluousSig  nt    : {NontermIdent}+--                              con   : {ConstructorIdent}+--                              attr  : {Identifier}++            | UndefLocal      nt    : {NontermIdent}+                              con   : {ConstructorIdent}+                              var   : {Identifier}++            | ChildAsLocal    nt    : {NontermIdent}+                              con   : {ConstructorIdent}+                              var   : {Identifier}++            | UndefAttr       nt    : {NontermIdent}+                              con   : {ConstructorIdent}+                              field : {Identifier}+                              attr  : {Identifier}+                              isOut : {Bool}++            | Cyclic          nt    : {NontermIdent}+                              mbCon : {Maybe ConstructorIdent}+                              verts : {[String]}++            | CyclicSet       name:{Identifier}++            | CustomError     isWarning : {Bool}+                              pos   : {Pos}+                              mesg  : {PP_Doc}++            | LocalCirc       nt      : {NontermIdent}+                              con     : {ConstructorIdent}+                              attr    : {Identifier}+                              o_visit : {Bool}+                              path    : {[String]}++            | InstCirc        nt      : {NontermIdent}+                              con     : {ConstructorIdent}+                              attr    : {Identifier}+                              o_visit : {Bool}+                              path    : {[String]}++            | DirectCirc      nt      : {NontermIdent}+                              o_visit : {Bool}+                              cyclic  : {[((Identifier,Identifier),[String],[String])]}++            | InducedCirc     nt      : {NontermIdent}+                              cinter  : {CInterface}+                              cyclic  : {[((Identifier,Identifier),[String],[String])]}++            | MissingTypeSig  nt      : {NontermIdent}+                              con     : {ConstructorIdent}+                              attr    : {Identifier}++            | MissingInstSig  nt      : {NontermIdent}+                              con     : {ConstructorIdent}+                              attr    : {Identifier}++            | DupUnique       nt      : {NontermIdent}+                              con     : {ConstructorIdent}+                              attr    : {Identifier}++            | MissingUnique   nt      : {NontermIdent}+                              attr    : {Identifier}++            | MissingSyn      nt      : {NontermIdent}+                              attr    : {Identifier}++            | IncompatibleVisitKind+                              child   : {Identifier}+                              vis     : {VisitIdentifier}+                              from    : {VisitKind}+                              to      : {VisitKind}+            | IncompatibleRuleKind+                              rule    : {Identifier}+                              kind    : {VisitKind}+            | IncompatibleAttachKind+                              child   : {Identifier}+                              kind    : {VisitKind}
src-ag/ExecutionPlan.ag view
@@ -1,83 +1,83 @@-imports
-{
--- VisitSyntax.ag imports
-import Patterns    (Pattern(..),Patterns)
-import Expression  (Expression(..))
-import CommonTypes
-import ErrorMessages
-
-import qualified Data.Set as Set
-import Data.Set(Set)
-import qualified Data.Map as Map
-import Data.Map(Map)
-}
-
-DATA ExecutionPlan | ExecutionPlan  nonts     : ENonterminals
-                                    typeSyns  : {TypeSyns}
-                                    wrappers  : {Set NontermIdent}
-                                    derivings : {Derivings}
-
-TYPE ENonterminals = [ENonterminal]
-
-TYPE EProductions  = [EProduction]
-
-TYPE ERules        = [ERule]
-
-TYPE EChildren     = [EChild]
-
-TYPE VisitSteps    = [VisitStep]
-
-TYPE Visits        = [Visit]
-
-DATA ENonterminal | ENonterminal nt          : {NontermIdent}
-                                 params      : {[Identifier]}
-                                 classCtxs   : {ClassContext}                  -- class context at the datatype level
-                                 initial     : {StateIdentifier}
-                                 initialv    : {[VisitIdentifier]}
-                                 nextVisits  : {Map StateIdentifier StateCtx}  -- info about the next visits from a given state
-                                 prevVisits  : {Map StateIdentifier StateCtx}  -- info about the previous visits to a given state
-                                 prods       : EProductions
-                                 recursive   : {Bool}
-                                 hoInfo      : {HigherOrderInfo}
-
-DATA EProduction  | EProduction  con         : {ConstructorIdent}
-                                 params      : {[Identifier]}
-                                 constraints : {[Type]}                        -- (class/equality) constraints on types (requires GADTs)
-                                 rules       : ERules
-                                 children    : EChildren
-                                 visits      : Visits
-
-DATA EChild       | EChild       name        : {Identifier}
-                                 tp          : {Type}
-                                 kind        : {ChildKind}
-                                 hasAround   : {Bool}  -- if there exists a rule <name>_around that transforms the child's sem
-                                 merges      : {Maybe [Identifier]} -- Nothing: not the result of a merge of other children (ignored for now)
-                                 isMerged    : {Bool}               -- False: not being used to merge other children (ignored for now)
-                  | ETerm        name        : {Identifier}
-                                 tp          : {Type}
-
-DATA ERule        | ERule       name         : {Identifier}
-                                pattern      : Pattern
-                                rhs          : Expression
-                                owrt         : {Bool}
-                                origin       : String           -- just for documentation (and maybe errors)
-                                explicit     : Bool             -- True if this rule defined in the source code
-                                pure         : Bool             -- True if this rule is pure (not monadic/no side effect)
-                                mbError      : {Maybe Error}    -- the rule may contain an error that is yielded when the rule is scheduled
-
-DATA Visit        | Visit       ident        : {VisitIdentifier}
-                                from         : {StateIdentifier}
-                                to           : {StateIdentifier}
-                                inh          : {Set Identifier}
-                                syn          : {Set Identifier}
-                                steps        : VisitSteps
-                                kind         : {VisitKind}
-
-DATA VisitStep    | Sem         name         : {Identifier}
-                  | ChildVisit  child        : {Identifier}
-                                nonterm      : {NontermIdent}
-                                visit        : {VisitIdentifier}
-                  | PureGroup   steps        : VisitSteps   -- A group of steps that should be executed purely
-                                ordered      : {Bool}
-                  | Sim         steps        : VisitSteps
-                  | ChildIntro  child        : {Identifier}
+imports+{+-- VisitSyntax.ag imports+import Patterns    (Pattern(..),Patterns)+import Expression  (Expression(..))+import CommonTypes+import ErrorMessages++import qualified Data.Set as Set+import Data.Set(Set)+import qualified Data.Map as Map+import Data.Map(Map)+}++DATA ExecutionPlan | ExecutionPlan  nonts     : ENonterminals+                                    typeSyns  : {TypeSyns}+                                    wrappers  : {Set NontermIdent}+                                    derivings : {Derivings}++TYPE ENonterminals = [ENonterminal]++TYPE EProductions  = [EProduction]++TYPE ERules        = [ERule]++TYPE EChildren     = [EChild]++TYPE VisitSteps    = [VisitStep]++TYPE Visits        = [Visit]++DATA ENonterminal | ENonterminal nt          : {NontermIdent}+                                 params      : {[Identifier]}+                                 classCtxs   : {ClassContext}                  -- class context at the datatype level+                                 initial     : {StateIdentifier}+                                 initialv    : {[VisitIdentifier]}+                                 nextVisits  : {Map StateIdentifier StateCtx}  -- info about the next visits from a given state+                                 prevVisits  : {Map StateIdentifier StateCtx}  -- info about the previous visits to a given state+                                 prods       : EProductions+                                 recursive   : {Bool}+                                 hoInfo      : {HigherOrderInfo}++DATA EProduction  | EProduction  con         : {ConstructorIdent}+                                 params      : {[Identifier]}+                                 constraints : {[Type]}                        -- (class/equality) constraints on types (requires GADTs)+                                 rules       : ERules+                                 children    : EChildren+                                 visits      : Visits++DATA EChild       | EChild       name        : {Identifier}+                                 tp          : {Type}+                                 kind        : {ChildKind}+                                 hasAround   : {Bool}  -- if there exists a rule <name>_around that transforms the child's sem+                                 merges      : {Maybe [Identifier]} -- Nothing: not the result of a merge of other children (ignored for now)+                                 isMerged    : {Bool}               -- False: not being used to merge other children (ignored for now)+                  | ETerm        name        : {Identifier}+                                 tp          : {Type}++DATA ERule        | ERule       name         : {Identifier}+                                pattern      : Pattern+                                rhs          : Expression+                                owrt         : {Bool}+                                origin       : String           -- just for documentation (and maybe errors)+                                explicit     : Bool             -- True if this rule defined in the source code+                                pure         : Bool             -- True if this rule is pure (not monadic/no side effect)+                                mbError      : {Maybe Error}    -- the rule may contain an error that is yielded when the rule is scheduled++DATA Visit        | Visit       ident        : {VisitIdentifier}+                                from         : {StateIdentifier}+                                to           : {StateIdentifier}+                                inh          : {Set Identifier}+                                syn          : {Set Identifier}+                                steps        : VisitSteps+                                kind         : {VisitKind}++DATA VisitStep    | Sem         name         : {Identifier}+                  | ChildVisit  child        : {Identifier}+                                nonterm      : {NontermIdent}+                                visit        : {VisitIdentifier}+                  | PureGroup   steps        : VisitSteps   -- A group of steps that should be executed purely+                                ordered      : {Bool}+                  | Sim         steps        : VisitSteps+                  | ChildIntro  child        : {Identifier}
src-ag/ExecutionPlan2Caml.ag view
@@ -1,1487 +1,1487 @@--- As expected, the code generation for ML resembles the code generation for Haskell quite a bit.
--- However, there are several differences:
---   * no inline pragmas
---   * no strictness annotations (not needed)
---   * separating data types from code
---
--- Generator conventions:
--- * we generate functions definitions with an 'and' binding and a match statement
--- * for some type aliasses, we'll introduce module decls in addition to a type
---
--- Future work:
--- * abuse the module system more?
--- * parse ocaml blocks?
--- * lazy evaluation?
---
--- Other comments:
--- * Empty records are not allowed in Ocaml. Mapping them to units.
--- * line pragmas. There are now line pragmas around the body of rules.
---   There cannot be syntactical mistakes in the patterns. However, there can be
---   type errors if a function returns a value with a type that differs from what
---   is expected. It's then not clear which location is reported.
---   Also, errors in type signatures are not caught.
---   However, usually, the problematic cases are syntax errors, and these are
---   prevented by parsing the definitions first.
-
-INCLUDE "ExecutionPlan.ag"
-INCLUDE "Patterns.ag"
-INCLUDE "Expression.ag"
-INCLUDE "HsToken.ag"
-
-imports
-{
-import ExecutionPlan
-import Pretty
-import PPUtil
-import Options
-import Data.Monoid(mappend,mempty)
-import Data.Maybe
-import Data.Graph
-import Debug.Trace
-import System.IO
-import System.Directory
-import System.FilePath
-import UU.Scanner.Position
-
-import TokenDef
-import HsToken
-import ErrorMessages
-
-import Data.Set (Set)
-import qualified Data.Set as Set
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Data.Sequence(Seq)
-import qualified Data.Sequence as Seq
-import Data.Foldable(toList)
-}
-
-ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule EChildren EChild
-  [ mainFile, mainName : String | | ]
-
--------------------------------------------------------------------------------
---  Options
--------------------------------------------------------------------------------
-ATTR ExecutionPlan
-     ENonterminals ENonterminal
-     EProductions EProduction
-     ERules ERule
-     EChildren EChild
-     Expression
-     HsToken HsTokens HsTokensRoot
-     Pattern Patterns
-     Visits Visit
-     VisitSteps VisitStep [ options : {Options} | | ]
-ATTR EProductions EProduction [ rename : {Bool} | | ]
-
-SEM ENonterminal | ENonterminal
-  prods.rename = rename @lhs.options
-
--------------------------------------------------------------------------------
---  Context info (nonterminal ident, constructor ident, nonterm params, etc.)
--------------------------------------------------------------------------------
-
-ATTR Visit Visits EProduction EProductions EChildren EChild ERules ERule [ nt : NontermIdent | | ]
-SEM ENonterminal | ENonterminal
-  prods.nt = @nt
-
-ATTR EChildren EChild ERules ERule Visits Visit [ con : ConstructorIdent | | ]
-
-SEM EProduction | EProduction children.con = @con
-  rules.con    = @con
-  visits.con   = @con
-
-ATTR EProductions EProduction Visits Visit [ params : {[Identifier]} | | ]
-SEM ENonterminal | ENonterminal
-  prods.params = @params
-
--------------------------------------------------------------------------------
---  output attributes: we make a distinction between data declarations
---  and code
--------------------------------------------------------------------------------
-ATTR ExecutionPlan [  | | datas, code, modules : {PP_Doc} ]
-
-SEM ExecutionPlan | ExecutionPlan
-  lhs.code   = @nonts.code  >-< @loc.wrappersExtra
-  lhs.datas  = @nonts.datas >-< @loc.commonExtra
-
-ATTR ENonterminal ENonterminals
-  [ wrappers : {Set NontermIdent} | | datas,code,modules USE {>-<} {empty} : {PP_Doc} ]
-
-SEM ExecutionPlan | ExecutionPlan
-  nonts.wrappers = @wrappers
-
-SEM ENonterminal | ENonterminal
-  lhs.datas = (    text ""
-               >-< "(* *** " ++ getName @nt ++ " *** [data] *)")
-               >-< (if dataTypes @lhs.options
-                    then pp "(* data *)"
-                         >-< @loc.datatypeNt
-                         >-< @loc.datatypeProds
-                         >-< ""
-                    else empty)
-               >-< (if @loc.hasWrapper
-                     then pp "(* wrapper *)"
-                          >-< @loc.wr_inh
-                          >-< @loc.wr_syn
-                          >-< ""
-                     else empty)
-               >-< (if semfuns @lhs.options
-                    then pp "(* semantic domain *)"
-                         >-< @loc.t_init
-                         >-< @loc.t_states
-                         >-< @loc.c_states
-                         >-< @prods.t_visits
-                         >-< ""
-                    else empty)
-
-  lhs.code   = (    text ""
-                >-< "(* *** " ++ getName @nt ++ " *** [code] *)")
-                >-< (if dataTypes @lhs.options
-                    then pp "(* constructor functions *)"
-                         >-< @loc.datatypeCon
-                    else empty)
-                >-< (if @loc.hasWrapper
-                     then pp "(* wrapper *)"
-                          >-< @loc.wrapper
-                          >-< ""
-                     else empty)
-                >-< (if folds @lhs.options
-                     then "(* cata *)"
-                          >-< @loc.sem_nt
-                          >-< ""
-                     else empty)
-                >-< (if semfuns @lhs.options
-                     then "(* semantic domain *)"
-                          >-< @prods.sem_prod
-                          >-< ""
-                     else empty)
-
-  -- note: we assume that these module declarations are not recursive, and
-  -- that their parameters do not depends on types generated by AG in the
-  -- same file.
-  lhs.modules = @loc.moduleDecl
-
-  loc.hasWrapper = @nt `Set.member` @lhs.wrappers
-
--------------------------------------------------------------------------------
---  Nonterminal datatype
--------------------------------------------------------------------------------
-ATTR ENonterminal ENonterminals [ typeSyns : {TypeSyns} | | ]
-
-SEM ExecutionPlan | ExecutionPlan
-  nonts.typeSyns = @typeSyns
-
-{
-ppRecordTp :: PP a => [a] -> PP_Doc
-ppRecordTp es
-  | null es   = text "unit"
-  | otherwise = pp_block "{" "}" "; " (map pp es)
-
-ppRecordVal :: PP a => [a] -> PP_Doc
-ppRecordVal es
-  | null es   = text "()"
-  | otherwise = pp_block "{" "}" "; " (map pp es)
-
-ppFieldsVal :: Bool -> [(PP_Doc,PP_Doc,PP_Doc,PP_Doc)] -> PP_Doc
-ppFieldsVal record fields
-  | null fields = text "()"
-  | record      = ppRecordVal [ r >#< "=" >#< x | (r,x,_,_) <- fields ]
-  | otherwise   = pp_block "(" ")" "," [ x | (_,x,_,_) <- fields ]
-
-ppFieldsType :: Bool -> Bool -> [(PP_Doc,PP_Doc,PP_Doc,PP_Doc)] -> PP_Doc
-ppFieldsType record defor fields
-  | null fields = text "unit"
-  | record      = ppRecordTp [ r >#< ":" >#< (if defor then d else f) | (r,_,d,f) <- fields ]
-  | otherwise   = pp_block "(" ")" "*" [ if defor then d else f | (_,_,d,f) <- fields ]
-}
-
-
--- for each nonterminal, the following data types in ocmal:
--- * data type for the nonterminal, with a constructor for
---   each production. The constructor takes a single field
---   with the type explained below.
--- * for each production, a record type comprising the
---   children of the production.
---
--- * class contexts are ignored
--- * at most one type variable
---
--- aliasses: lists, tuples
---  *** think about maps, sets, etc. Perhaps the name of
---  the alias should become a local module name.
---
-
-SEM ENonterminal | ENonterminal
-  loc.t_params = ppTypeParams @params
-  loc.aliasPre = "and" >#< @loc.t_params >#< @nt >#< "="
-  loc.aliasMod = @loc.aliasPre >#< modName @nt >|< ".t"
-  loc.datatypeNt
-    = case lookup @nt @lhs.typeSyns of
-        -- generate special code for certain type aliasses
-        Just (List t)     -> @loc.aliasPre >#< ppTp t >#< "list"
-        Just (Maybe t)    -> @loc.aliasPre >#< ppTp t >#< "option"
-        Just (Tuple ts)   -> @loc.aliasPre >#< (pp_block "(" ")" " * " $ map (ppTp . snd) ts)
-
-        Just (Map k v)    -> @loc.aliasMod
-        Just (IntMap t)   -> @loc.aliasMod
-        Just (OrdSet t)   -> @loc.aliasMod
-        Just IntSet       -> @loc.aliasMod
-
-        -- use the constructor-based data-type generation for all other types
-        _ -> "and" >#< @loc.t_params >#< @nt >#< "="
-             >-< ( if null @prods.datatype
-                   then pp "unit"
-                   else indent 2 $ vlist @prods.datatype_call
-                 )
-
-  loc.datatypeCon
-    = case lookup @nt @lhs.typeSyns of
-        Just _  -> empty  -- no constructor funs for type aliasses
-        Nothing -> vlist @prods.datatype_con
-
-  loc.moduleDecl
-    = let ppModule :: PP a => a -> PP_Doc
-          ppModule expr = "module" >#< modName @nt >#< "="
-      in case lookup @nt @lhs.typeSyns of
-           Just (Map k _)  -> ppModule ("Map.Make" >#< pp_parens (ppTp k))
-           Just (IntMap _) -> ppModule ("Map.Make ()")
-           Just (OrdSet t) -> ppModule ("Set.Make" >#< pp_parens (ppTp t))
-           Just IntSet     -> ppModule ("Set.Make (struct  type t = int  let compare = Pervasives.compare  end)")
-           _               -> empty
-
-  loc.datatypeProds = vlist @prods.datatype
-
-ATTR EProduction  [ | | datatype, datatype_call, datatype_con : {PP_Doc} ]
-ATTR EProductions [ | | datatype, datatype_call, datatype_con USE {:} {[]} : {[PP_Doc]} ]
-
-SEM EProduction | EProduction
-  loc.o_records = dataRecords @lhs.options
-  loc.t_params = ppTypeParams @lhs.params
-  loc.t_c_params = ppTypeParams (cont_tvar : map pp @params)
-  loc.conname = conname @lhs.rename @lhs.nt @con
-  loc.recname = pp "fields_" >|< @loc.conname
-  lhs.datatype = "and" >#< @loc.t_params >#< @loc.recname >#< "="
-                 >#< ppFieldsType @loc.o_records False @children.sigs
-  lhs.datatype_call = pp "|" >#< @loc.conname >#< "of" >#< pp_parens (@loc.t_params >#< @loc.recname)
-  lhs.datatype_con
-    = let funNm  = @lhs.nt >|< "_" >|< @con
-          decl   = "and" >#< ppFunDecl @loc.o_sigs funNm params (@loc.t_params >#< @lhs.nt) body
-          params = [ (x, t) | (_,x,_,t) <- @children.sigs ]
-          body   = @loc.conname >#< ppFieldsVal @loc.o_records @children.sigs
-      in decl
- 
-ATTR EChild EChildren [ | | sigs USE {++} {[]} : {[(PP_Doc,PP_Doc,PP_Doc,PP_Doc)]} ]
-
-SEM EChild
-  | EChild ETerm
-      loc.tpDocFor   = ppTp $ removeDeforested @tp
-      loc.tpDocDefor = ppTp $ forceDeforested @tp
-      loc.fieldNm    = text $ recordFieldname @lhs.nt @lhs.con @name
-      loc.childNm    = text (fieldname @name)
-      loc.field  = (@loc.fieldNm, @loc.childNm, @loc.tpDocDefor, @loc.tpDocFor)
-  | EChild  lhs.sigs = case @kind of
-                         ChildAttr -> []  -- higher order attributes are not part of the data type
-                         _         -> [@loc.field]
-  | ETerm   lhs.sigs = [@loc.field]
-
-{
-ppTp :: Type -> PP_Doc
-ppTp tp = case tp of
-  Haskell t -> pp t   -- ocaml type
-  NT nt tps deforested
-    | nt == _SELF -> pp "?SELF?"
-    | null tps    -> ppNontTp nt deforested
-    | otherwise   -> pp_parens (ppSpaced (map pp_parens tps) >#< ppNontTp nt deforested)
-  Self -> pp "?SELF?"
-
-ppNontTp :: NontermIdent -> Bool -> PP_Doc
-ppNontTp nt True  = pp "t_" >|< pp nt
-ppNontTp nt False = pp nt
-
--- multiple type parameters go into a tuple
-ppTypeParams :: PP a => [a] -> PP_Doc
-ppTypeParams []  = empty
-ppTypeParams [x] = pp x
-ppTypeParams xs  = pp_block "(" ")" "," (map pp xs)
-}
-
--------------------------------------------------------------------------------
---  Nonterminal semantic function
--------------------------------------------------------------------------------
-SEM ENonterminal | ENonterminal
-  loc.fsemname = \x -> prefix @lhs.options ++ show x
-  loc.semname = @loc.fsemname @nt
-  loc.frecarg = \t x -> case t of
-                  NT nt _ _ -> pp_parens (@fsemname nt >#< x)
-                  _         -> x
-
-  loc.sem_param_tp = @loc.t_params >#< @nt
-  loc.sem_res_tp   = @loc.t_params >#< @loc.t_type
-  loc.sem_tp       = @loc.sem_param_tp >#< "->" >#< @loc.sem_res_tp
-
-  loc.o_sigs  = typeSigs @lhs.options
-  loc.sem_nt_body = "match arg with" >-< (indent 2 $ @prods.sem_nt)
-  loc.sem_nt  = let genSem :: PP a => a -> PP_Doc -> PP_Doc
-                    genSem nm body = "and" >#< ppFunDecl @loc.o_sigs (pp @loc.semname) [(pp nm, @loc.sem_param_tp)] @loc.sem_res_tp body
-                    genAlias alts = genSem (pp "arg") (pp "match arg with" >-< (indent 2 $ vlist $ map (pp "|" >#<) alts))
-                    genMap v = let body = modName @nt >|< ".fold" >#< @loc.semname >|< "_Entry" >#< @loc.semname >|< "_Nil" >#< els
-                                   els  = case v of
-                                     NT nt _ _ -> pp_parens (modName @nt >|< ".map" >#< @loc.fsemname nt >#< "m")
-                                     _         -> pp "m"
-                               in genSem "m" body
-                    genSet mbNt = let body = "List.fold_right" >#< @loc.semname >|< "_Entry" >#<
-                                              els (pp_parens (modName @nt >|< ".elements" >#< "s")) >#< @loc.semname >|< "_Nil"
-                                      els r = maybe r (\nt -> pp_parens ("List.map" >#< @loc.fsemname nt >#< r)) mbNt
-                                  in genSem "s" body
-                in case lookup @nt @lhs.typeSyns of
-                     -- generate special code for some aliasses
-                     Just (List t) -> let body = "List.fold_right" >#< @loc.semname >|< "_Cons" >#< els >#< @loc.semname >|< "_Nil"
-                                          els  = case t of
-                                            NT nt _ _ -> pp_parens ("List.map" >#< @loc.fsemname nt >#< "list")
-                                            _         -> pp "list"
-                                      in genSem "list" body
-                     Just (Tuple ts) -> let pat = pp_parens (ppCommas $ map fst ts)
-                                            body = @loc.semname >|< "_Tuple" >#< ppSpaced (map (\t -> @loc.frecarg (snd t) (pp $ fst t)) ts)
-                                        in genSem pat body
-                     Just (Map _ v) -> genMap v
-                     Just (IntMap v) -> genMap v
-                     Just (Maybe t) -> genAlias
-                         [ "None" >#< "->" >#< "=" >#< @loc.semname >|< "_Nothing"
-                         , "Some" >#< "just" >#< "->" >#< @loc.semname >|< "_Just" >#< @frecarg t (pp "just")
-                         ]
-                     Just (OrdSet t) -> genSet $ case t of
-                                          NT nt _ _ -> Just nt
-                                          _         -> Nothing
-                     Just (IntSet) -> genSet Nothing
-
-                     -- structural fold for the remaining cases
-                     _ -> genSem "arg" @loc.sem_nt_body
-
-{
--- convention for nonterminals to module names
-modName :: NontermIdent -> PP_Doc
-modName nt = pp "M_" >|< pp nt
-
-ppFunDecl :: Bool -> PP_Doc -> [(PP_Doc,PP_Doc)] -> PP_Doc -> PP_Doc -> PP_Doc
-ppFunDecl gensigs nm args resSig expr = body where
-  body = nm >#< ppSpaced (map arg args) >#< ppRes >#< "="
-         >-< indent 2 expr
-  arg (arg,tp) = ppArg gensigs arg tp
-  ppRes
-    | gensigs  = ":" >#< resSig
-    | otherwise = empty
-
-ppArg :: Bool -> PP_Doc -> PP_Doc -> PP_Doc
-ppArg gensigs arg tp
-  | gensigs   = pp_parens (arg >#< ":" >#< tp)
-  | otherwise = arg
-
-}
-
--- The number of productions
-ATTR EProductions EProduction [ | | count USE {+} {0} : {Int} ]
-SEM EProduction | EProduction  lhs.count = {1}
-
--- The per-production match-expr cases for the sem_NT function
-ATTR EProduction EProductions [ | | sem_nt USE {>-<} {empty} : {PP_Doc} ]
-SEM EProduction | EProduction
-  lhs.sem_nt = "|" >#< conname @lhs.rename @lhs.nt @con >#< ppFieldsVal @loc.o_records @children.sigs >#< "->" >#<
-                 prefix @lhs.options >|< @lhs.nt >|< "_" >|< @con >#< ppSpaced @children.argnamesw
-
-ATTR EChild    [ | | argnamesw              : { PP_Doc } ]
-ATTR EChildren [ | | argnamesw USE {:} {[]} : {[PP_Doc]} ]
-
-SEM EChild
-  | EChild lhs.argnamesw = case @kind of
-                             ChildSyntax     -> "(" >#< prefix @lhs.options >|< @loc.nt >#< @name >|< "_" >#< ")"
-                             ChildAttr       -> empty  -- no sem-case for a higher-order child
-                             ChildReplace tp -> "(" >#< prefix @lhs.options >|< extractNonterminal tp >#< @name >|< "_" >#< ")"
-  | ETerm  lhs.argnamesw = text $ fieldname @name
-
--------------------------------------------------------------------------------
---  Types of attributes
--------------------------------------------------------------------------------
-ATTR ExecutionPlan
-     ENonterminals
-     ENonterminal  [ inhmap : {Map NontermIdent Attributes}
-                     synmap : {Map NontermIdent Attributes} | | ]
-
-ATTR EProductions EProduction
-     ERules ERule
-     Patterns Pattern
-     Visits
-     Visit   [ inhmap : {Attributes}
-               synmap : {Attributes}
-               allInhmap : {Map NontermIdent Attributes}
-               allSynmap : {Map NontermIdent Attributes} | | ]
-
-SEM ENonterminal
-  | ENonterminal (Just prods.inhmap) = Map.lookup @nt @lhs.inhmap
-                 (Just prods.synmap) = Map.lookup @nt @lhs.synmap
-                 prods.allInhmap = @lhs.inhmap
-                 prods.allSynmap = @lhs.synmap
-
--------------------------------------------------------------------------------
---  State datatypes
--------------------------------------------------------------------------------
-{type VisitStateState = (VisitIdentifier,StateIdentifier, StateIdentifier)}
-
-ATTR Visit  [ | | allvisits              : { VisitStateState }]
-ATTR Visits [ | | allvisits USE {:} {[]} : {[VisitStateState]}]
-ATTR EProduction
-     EProductions [ | | allvisits: {[VisitStateState]}]
-
-SEM Visit
-  | Visit lhs.allvisits = (@ident, @from, @to)
-
-SEM EProductions
-  | Cons lhs.allvisits = @hd.allvisits -- just pick the first production
-  | Nil  lhs.allvisits = error "Every nonterminal should have at least 1 production"
-
--- type of tree in a given state s
-SEM ENonterminal | ENonterminal
-  loc.allstates = orderStates @initial @prods.allvisits
-  loc.stvisits  = \st -> filter (\(v,f,t) -> f == st) @prods.allvisits
-  loc.t_type    = type_nt_sem_top @nt
-  loc.t_c_params = ppTypeParams (cont_tvar : map pp @params)
-
-  -- the initial "s" type: contains the "attach" function that delivers the initial st
-  loc.t_init    = "and" >#< @loc.t_params >#< @loc.t_type >#< "=" >#< pp_braces ( nm_attach @nt >#< ":" >#< "unit" >#< "->" >#< @loc.t_params >#< type_nt_sem @nt @initial)
-
-  -- the "s" type in a given state: contains the invoke function to go to a next state
-  loc.t_states  = vlist $ map (\st ->
-                    let s_st = type_nt_state @nt st
-                        t_st  = type_nt_sem @nt st
-                        c_st  = type_caller @nt st
-                        nextVisits = Map.findWithDefault ManyVis st @nextVisits
-                        decl = "and" >#< @loc.t_params >#< t_st >#< "="
-                    in case nextVisits of
-                         NoneVis    -> decl >#< "unit"  -- final state: no more subsequent visits
-                         _          -> decl >#< ppRecordVal [ nm_invoke @nt st >#< ":" >#< cont_tvar >#< "." >#< @loc.t_c_params >#< c_st >#< "->" >#< cont_tvar ]
-                   ) @loc.allstates
-
-{
---
--- conventions
---
-
--- type of the state of a node: a closure containing the children states and attributes,
--- with code of type 'type_nt_sem' that represents the subsequent visits to successor states.
-type_nt_state nt st = "s_" >|< nt >|< "_" >|< st
-
--- type of a visit to a node (the initial, and when in a given state)
--- an instance of this type is called the "semantics"
-type_nt_sem_top nt = "t_" >|< nt
-type_nt_sem nt st = type_nt_sem_top nt >|< "_s" >|< st
-
--- type of a caller (contains visit selection + inputs + continuation)
-type_caller nt st = "c_" >|< nt >|< "_s" >|< st
-
--- names of records
-nm_attach nt = "attach_">|< nt
-nm_invoke nt st = "inv_" >|< nt >|< "_s" >|< st
-
--- name of the type variable representing the result type of the continuation
-cont_tvar = text "'cont__"
-
-
--- order states in reverse topological order so that successor states are
--- earlier in the resulting list.
-orderStates :: StateIdentifier -> [VisitStateState] -> [StateIdentifier]
-orderStates initial edges = res where
-  source  = Map.singleton initial Set.empty  -- ensures that the initial state is in graph even when there are no edges
-  targets = [ Map.singleton t Set.empty | (_,_,t) <- edges ]
-  deps    = [ Map.singleton f (Set.singleton t) | (_,f,t) <- edges ]
-
-  mp  = Map.unionsWith Set.union (source : (targets ++ deps))
-  es  = [ (f,f,Set.toList ts) | (f,ts) <- Map.toList mp ]
-  cps = stronglyConnComp es
-  res = flattenSCCs cps
-}
-
--- type of a caller that selects a visit v from state s of the child, and
--- provides a continuation of the caller after the visit to the child
-SEM ENonterminal | ENonterminal
-  loc.c_states = vlist $ map (\st ->
-                   let nt_st = type_nt_state @nt st
-                       c_st  = type_caller @nt st
-                       outg  = filter (\(_,f,_) -> f == st) @prods.allvisits
-                       nextVisits = Map.findWithDefault ManyVis st @nextVisits
-                       declHead = "and" >#< @loc.t_c_params >#< c_st >#< "="
-                       visitcons = vlist $ map (\(v,_,_) ->
-                         "|" >#< con_visit @nt v >#< "of" >#< @loc.t_c_params >#< type_caller_visit @nt v
-                        ) outg
-                   in case nextVisits of   -- slight optimization for when there is only one visit
-                        NoneVis  -> empty  -- st is final state, no subsequent visits, thus no more caller info
-                        OneVis v -> declHead >#< @loc.t_c_params >#< type_caller_visit @nt v
-                        ManyVis  -> declHead >-< indent 3 visitcons
-                  ) @loc.allstates
-
-{
-type_caller_visit nt v = "c_" >|< nt >|< "_v" >|< v
-con_visit nt v = "C_" >|< nt >|< "_v" >|< v
-
--- field names
-nm_inh nt v  = "inh_" >|< nt >|< "_v" >|< v
-nm_cont nt v = "cont_" >|< nt >|< "_v" >|< v
-}
-
--- type t_visit of a call to a visit v (inputs to the visit + continuation of the parents that gets the output + new state of the child)
-ATTR Visit Visits EProduction EProductions [ | | t_visits USE {>-<} {empty} : {PP_Doc} ]
-
-SEM EProductions | Cons
-  lhs.t_visits = @hd.t_visits
-    -- just pick the first production (these results are the same for all of them)
-    -- todo: that means we should actually represent visit declarations in the AST...
-
-SEM Visit | Visit
-  loc.nameTIn_visit   = conNmTVisitIn @lhs.nt @ident
-  loc.nameTOut_visit  = conNmTVisitOut @lhs.nt @ident
-  loc.nameNextState    = type_nt_sem @lhs.nt @to
-  loc.nameCaller_visit = type_caller_visit @lhs.nt @ident
-
-  loc.nextVisitInfo   = Map.findWithDefault ManyVis @to @lhs.nextVisits  -- which visits can we do after we reach the @to state?
-
-  loc.t_params  = ppTypeParams @lhs.params
-  loc.t_c_params = ppTypeParams (cont_tvar : map pp @lhs.params)
-
-  -- data type decls for the t_visit type
-  -- we generate a type for the caller of a visit, the arguments of the visit and the result of the visit
-  lhs.t_visits =  "and" >#< @loc.t_c_params >#< @loc.nameCaller_visit >#< "=" >#< ppRecordTp
-                    [ nm_inh @lhs.nt @ident >#< ":" >#< @loc.t_params >#< conNmTVisitIn @lhs.nt @ident
-                    , nm_cont @lhs.nt @ident >#< ":" >#< @loc.t_params >#< conNmTVisitOut @lhs.nt @ident >#< "->" >#< cont_tvar
-                    ]
-                  >-< "and" >#< @loc.t_params >#< @loc.nameTIn_visit  >#< "=" >#< ppRecordTp @loc.inhpart
-                  >-< "and" >#< @loc.t_params >#< @loc.nameTOut_visit >#< "=" >#< ppRecordTp (@loc.synpart ++ @loc.contpart)
-
-  loc.contpart = case @loc.nextVisitInfo of
-                   NoneVis -> []                    -- don't provide a continuation at all
-                   _       -> [ nm_outarg_cont @lhs.nt @ident >#< ":" >#< @loc.t_params >#< @loc.nameNextState ]  -- normal route: select the next semantics
-
-  loc.inhpart   = @loc.ppTypeList nm_inarg @inh @lhs.inhmap
-  loc.synpart   = @loc.ppTypeList nm_outarg @syn @lhs.synmap
-  loc.ppTypeList = \f s m -> map (\i -> case Map.lookup i m of
-                                          Just tp -> f i @lhs.nt @ident >#< ":" >#< ppTp tp ) $ Set.toList s
-
-{
--- more naming conventions
-nm_inarg nm nt v = "i_" >|< nm >|< "_" >|< nt >|< "_v" >|< v
-nm_outarg nm nt v = "o_" >|< nm >|< "_" >|< nt >|< "_v" >|< v
-nm_outarg_cont = nm_outarg "_cont"
-
-conNmTVisit nt vId      = "t_" >|< nt >|< "_v"    >|< vId
-conNmTVisitIn nt vId    = "t_" >|< nt >|< "_vIn"  >|< vId
-conNmTVisitOut nt vId   = "t_" >|< nt >|< "_vOut" >|< vId
-
--- todo: remove ppMonadType
-ppMonadType :: Options -> PP_Doc
-ppMonadType opts
-  | parallelInvoke opts = text "IO"
-  | otherwise           = text "Identity"
-}
-
--------------------------------------------------------------------------------
---  Inh and Syn wrappers
--------------------------------------------------------------------------------
-SEM ENonterminal | ENonterminal
-  loc.wr_inh   = @loc.genwrap "inh" @loc.wr_inhs1  -- todo: is perhaps a mistake in 2hs
-  loc.wr_syn   = @loc.genwrap "syn" @loc.wr_syns
-  loc.genwrap  = \nm attrs ->
-                   "and" >#< @loc.t_params >#< nm >|< "_" >|< @nt >#< "=" >#< ppRecordTp
-                     [ i >|< "_" >|< nm >|< "_" >|< @nt >#< ":" >#< ppTp t | (i,t) <- attrs ]
-
-  loc.inhAttrs = fromJust $ Map.lookup @nt @lhs.inhmap
-  loc.wr_inhs  = Map.toList $ @loc.wr_filter $ @loc.inhAttrs
-  loc.wr_inhs1 = Map.toList @loc.inhAttrs
-  loc.wr_filter = if kennedyWarren @lhs.options && lateHigherOrderBinding @lhs.options
-                  then Map.delete idLateBindingAttr
-                  else id
-  loc.wr_syns  = Map.toList $ fromJust $ Map.lookup @nt @lhs.synmap
-
-  loc.wrapname = text ("wrap_" ++ show @nt)
-  loc.inhname  = text ("inh_" ++ show @nt)
-  loc.synname  = text ("syn_" ++ show @nt)
-  loc.firstVisitInfo = Map.findWithDefault ManyVis @initial @nextVisits
-
-  loc.wrapArgSemTp = @loc.t_params >#< @loc.t_type
-  loc.wrapArgInhTp = @loc.t_params >#< @loc.inhname
-  loc.wrapArgPats  = ppRecordVal [ i >|< "_inh_" >|< @nt >#< "=" >#< lhsname @lhs.options True i | (i,_) <- @loc.wr_inhs1 ]
-  loc.wrapResTp = @loc.t_params >#< @loc.synname
-  loc.wrapper  = "and" >#< ppFunDecl @loc.o_sigs @loc.wrapname [(pp "act", @loc.wrapArgSemTp), (@loc.wrapArgPats, @loc.wrapArgInhTp)] @loc.wrapResTp @loc.wrapperPreamble
-  loc.wrapperPreamble
-    = ( if lateHigherOrderBinding @lhs.options
-        then "let" >#< lhsname @lhs.options True idLateBindingAttr >#< "=" >#< lateBindingFieldNm @lhs.mainName >#< "in"
-        else empty
-      ) -- initial attribute for late binding
-      >-< @loc.wrapperBody
-  loc.wrapperBody
-    = case @initialv of
-        [] -> text "{ }"  -- case where there are no inherited or synthesized attributes
-        (initv:_) -> -- TODO: take care of multiple visits
-          let attach  = "let" >#< "sem" >#< "=" >#< "act." >|< nm_attach @nt >#< "()" >#< "in"  -- run attach code
-
-              -- result transformer to wrapper output record
-              pat     = ppRecordVal [ nm_outarg i @nt initv >#< "=" >#< lhsname @lhs.options False i | (i,_) <- @loc.wr_syns ]
-              bld     = ppRecordVal [ i >|< "_syn_" >|< @nt >#< "=" >#< lhsname @lhs.options False i | (i,_) <- @loc.wr_syns ]
-              res     = "let res = function" >#< pat >#< "->" >#< bld >#< "in"
-
-              -- input to the visit (inh attrs + continuation)
-              inps    = "let" >#< "inps" >#< "=" >#< ppRecordVal [ nm_inarg i @nt initv >#< "=" >#< lhsname @lhs.options True i | (i,_) <- @loc.wr_inhs ] >#< "in"
-              arg     = "let" >#< "arg" >#< "=" >#< argcon >#< argrec >#< "in"
-              argcon  = case @loc.firstVisitInfo of
-                          ManyVis -> con_visit @nt initv
-                          _       -> empty
-              argrec  = ppRecordVal
-                          [ nm_inh @nt initv >#< "=" >#<  "inps"
-                          , nm_cont @nt initv >#< "=" >#< "res"
-                          ]
-              invoke  = "sem." >|< nm_invoke @nt @initial >#< "arg"  -- invoke the visit
-          in attach >-< res >-< inps >-< arg >-< invoke
-
--------------------------------------------------------------------------------
---  Collection of NT / Production sem funs references
--------------------------------------------------------------------------------
-
-ATTR ENonterminals ENonterminal EProductions EProduction [ | | semFunBndDefs, semFunBndTps USE {Seq.><} {Seq.empty} : {Seq PP_Doc} ]
-SEM ENonterminal | ENonterminal
-  lhs.semFunBndDefs = @loc.semFunBndDef Seq.<| @prods.semFunBndDefs
-  lhs.semFunBndTps  = @loc.semFunBndTp Seq.<| @prods.semFunBndTps
-  loc.semFunBndDef  = @loc.semFunBndNm >#< "=" >#< @loc.semname
-  loc.semFunBndTp   = @loc.semFunBndNm >#< ":" >#< @loc.sem_tp
-  loc.semFunBndNm   = lateSemNtLabel @nt
-
-SEM EProduction | EProduction
-  lhs.semFunBndDefs = Seq.singleton @loc.semFunBndDef
-  lhs.semFunBndTps  = Seq.singleton @loc.semFunBndTp
-  loc.semFunBndDef  = @loc.semFunBndNm >#< "=" >#< @loc.semname
-  loc.semFunBndTp   = @loc.semFunBndNm >#< ":" >#< @loc.sem_tp
-  loc.semFunBndNm   = lateSemConLabel @lhs.nt @con
-
--- Generate a dictionary that contains the semantics of all semantic functions
-SEM ExecutionPlan | ExecutionPlan
-  loc.wrappersExtra = if lateHigherOrderBinding @lhs.options
-                      then @loc.lateSemBndDef
-                      else empty
-  loc.commonExtra   = if lateHigherOrderBinding @lhs.options
-                      then @loc.lateSemBndTp
-                      else empty
-  loc.lateSemBndTp = "and" >#< lateBindingTypeNm @lhs.mainName >#< "=" >#< ppRecordTp (toList @nonts.semFunBndTps)
-  loc.lateSemBndDef = "and" >#< lateBindingFieldNm @lhs.mainName >#< ":" >#< lateBindingTypeNm @lhs.mainName >#< "="
-                      >-< (indent 2 $ ppRecordVal $ toList @nonts.semFunBndDefs)
-
--------------------------------------------------------------------------------
---  Production semantic functions
--------------------------------------------------------------------------------
-ATTR EProduction  [ | | sem_prod                   : {PP_Doc} ]
-ATTR EProductions [ | | sem_prod USE {>-<} {empty} : {PP_Doc} ]
-
-ATTR EProduction EProductions [ initial : {StateIdentifier}
-                                allstates : {[StateIdentifier]} | | ]
-SEM ENonterminal | ENonterminal
-  prods.initial   = @initial
-  prods.allstates = @loc.allstates
-
-SEM EProduction | EProduction
-  loc.o_sigs     = typeSigs @lhs.options
-  loc.t_type     = type_nt_sem_top @lhs.nt
-  loc.semname    = prefix @lhs.options >|< @lhs.nt >|< "_" >|< @con
-  loc.sem_res_tp = @loc.t_params >#< @loc.t_type
-  loc.sem_tp     = pp_block "" "" "->" [ d | (_,_,d,_) <- @children.sigs ] >#< "->" >#< @loc.sem_res_tp
-
-  loc.initializer
-    = -- some actions, performed upon attaching a child, can
-      -- be specified here in the form of a let-expression.
-      -- The resulting bindings of these actions are
-      -- in scope of the rules of the production
-      empty  -- nothing for now
-
-  loc.sem_prod  = "and" >#< ppFunDecl @loc.o_sigs @loc.semname [ (x,d) | (_,x,d,_) <- @children.sigs ] @loc.sem_res_tp @loc.prod_body
-  loc.prod_body
-    = @loc.initializer
-      >-< "{" >#< nm_attach @lhs.nt >#< "=" >#< "function () ->"
-      >-< indent 2 
-          (   "(* rules of production" >#< @con >#< "*)"
-          >-< @rules.sem_rules
-          >-< "(* states of production" >#< @con >#< "*)"
-          >-< vlist @loc.statefuns
-          >-< nm_st @lhs.initial
-          )
-      >#< "}"
-
-  -- the semantic function of a production: defines a series of states and
-  -- their transitions. Two sorts of functions are important:
-  --   k-functions: inspect the caller_type to find out which visit the
-  --     caller wants and then dispatches that visit and continuation.
-  --   v-functions: the actual code of the visit.
-  loc.statefuns = map @loc.genstfn @lhs.allstates
-  loc.genstfn
-    = \st -> let nextVisitInfo = Map.findWithDefault ManyVis st @lhs.nextVisits
-                 stNm = nm_st st
-
-                 -- note about the initial state: the initial state should be the only
-                 -- state-binding that is not a function. It is non-recursive, its definition does
-                 -- not involve side effect, and its not needed
-                 -- anywhere except to be delivered as initial result.
-                 stDef body = "let" >#< stNm >#< (if st == @lhs.initial then empty else @loc.stargs st) >#< "="
-                              >-< indent 2 body >#< "in"
-
-             in case nextVisitInfo of
-                  NoneVis -> -- the (empty) closure of a (non-initial) end state is not referenced
-                             -- thus generating it is not needed (and omitting it may catch some small mistakes).
-                             if st == @lhs.initial
-                             then stDef (pp "unit")  -- empty state
-                             else empty              -- no state generated
-                  _       -> stDef $ mklets (@loc.stvs st ++ @loc.stks st) $ ppRecordVal
-                               [ nm_invoke @lhs.nt st >#< "=" >#< nm_k st ]
-
-  loc.stargs
-    = \st -> let attrs = maybe Map.empty id $ Map.lookup st @visits.intramap in ppSpaced
-               [ case mbAttr of
-                   Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) ->
-                     case Map.lookup nm @loc.localAttrTypes of
-                       Just tp -> pp_parens (strNm >#< ":" >#< ppTp tp)
-                       Nothing -> pp strNm
-                   Just attr | not (noPerStateTypeSigs @lhs.options) ->
-                     case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @loc.childTypes of
-                       Just tpDoc -> pp_parens (strNm >#< ":" >#< tpDoc)
-                       Nothing    -> pp strNm
-                   _ -> pp strNm
-               | (strNm, mbAttr) <- Map.assocs attrs
-               ] >#< dummyPat @lhs.options (Map.null attrs)
-
-  -- produces the "k" function that inspect the caller argument to dispatch a visit
-  loc.stvisits = \st -> filter (\(_,f,_) -> f == st) @visits.allvisits
-  loc.stks
-    = \st -> let stvisits = @loc.stvisits st
-                 def = ppFunDecl False {- @loc.o_sigs -} (pp $ nm_k st)
-                         [(pp "arg", @loc.t_c_params >#< type_caller @lhs.nt st)] (pp cont_tvar) body
-
-                 nextVisitInfo = Map.findWithDefault ManyVis st @lhs.nextVisits
-                 body = case nextVisitInfo of
-                   NoneVis  -> text "?no next visit?"
-                   OneVis v -> dispatch "arg" v
-                   ManyVis  -> let alt (v,_,_) = "|" >#< con_visit @lhs.nt v >#< "chosen" >#< "->" >-< indent 2 (dispatch "chosen" v)
-                               in "match arg with" >-< (indent 2 $ vlist $ map alt stvisits)
-
-                 dispatch nm v = "let" >#< ppRecordVal
-                                   [ nm_inh @lhs.nt v >#< "=" >#< "inp"
-                                   , nm_cont @lhs.nt v >#< "=" >#< "cont" ]
-                                 >#< "=" >#< pp nm
-                                 >-< "in" >#< "cont" >#< pp_parens (nm_visit v >#< "inp") -- call cont with res of visit
-
-             in if null stvisits
-                then []
-                else [ "(* k-function for production" >#< @con >#< " *)" >-< def ]
-
-  loc.stvs = \st -> [ppf | (f,ppf) <- @visits.sem_visit, f == st]
-  visits.mrules = @rules.mrules
-
-{
-nm_visit v = "__v" >|< v
-nm_k st = "__k" >|< st
-nm_st st = "__st" >|< st
-
-mklets :: (PP b, PP c) => [b] -> c -> PP_Doc
-mklets defs body = res where
-  ppLet def = "let" >#< def >#< "in"
-  res = vlist (map ppLet defs) >-< body
-}
-
--------------------------------------------------------------------------------
---  Visit semantic functions
--------------------------------------------------------------------------------
-ATTR Visit  [ | | sem_visit              : {  (StateIdentifier,PP_Doc)  } ]
-ATTR Visits [ | | sem_visit USE {:} {[]} : { [(StateIdentifier,PP_Doc)] } ]
-
-SEM Visit | Visit
-  loc.o_sigs = typeSigs @lhs.options
-  lhs.sem_visit = ( @from
-                  , let resTp = @loc.t_params >#< @loc.nameTOut_visit
-                        argTp = @loc.t_params >#< @loc.nameTIn_visit
-                        argMatch = ppRecordVal [ nm_inarg i @lhs.nt @ident >#< "=" >#< lhsname @lhs.options True i | i <- Set.toList @inh ]
-                    in ppFunDecl @loc.o_sigs (nm_visit @ident) [(argMatch, argTp)] resTp @steps.sem_steps
-                  )
-
-  steps.follow   = @loc.nextStBuild >-< @loc.resultval
-
-  loc.nextArgsMp = maybe Map.empty id $ Map.lookup @to @lhs.allintramap
-  loc.nextArgs   = ppSpaced $ Map.keys $ @loc.nextArgsMp
-  loc.nextStExp  = nm_st @to >#< @loc.nextArgs >#< dummyArg @lhs.options (Map.null @loc.nextArgsMp)
-
-  loc.resultval = ppRecordVal
-                    (  [ nm_outarg i @lhs.nt @ident >#< "=" >#< lhsname @lhs.options False i | i <- Set.toList @syn ]
-                    ++ [ @loc.nextStRefExp ])
-
-  (loc.nextStBuild, loc.nextStRefExp)
-     = case @loc.nextVisitInfo of
-         NoneVis  -> (empty, empty)
-         _        -> ( "let" >#< nextStName >#< "=" >#< @loc.nextStExp >#< "in"
-                     , nm_outarg_cont @lhs.nt @ident >#< "=" >#< nextStName)
-
-{
-resultValName :: String
-resultValName = "__result_"
-
-nextStName :: String
-nextStName = "__st_"
-}
-
--- Propagate the visit kind to the steps
-ATTR VisitStep VisitSteps [ kind : VisitKind | | ]
-SEM Visit | Visit  steps.kind = @kind
-
--- the steps in this group should be executed in a pure fashion
-SEM VisitStep | PureGroup
-  steps.kind = VisitPure @ordered
-
--- follow: the code of steps that follows after the VisitStep
-ATTR Visits Visit VisitStep VisitSteps [  mrules : {Map Identifier (VisitKind ->  Either Error PP_Doc)} | | ]
-ATTR VisitStep VisitSteps [ follow : PP_Doc | | sem_steps USE {>-<} {empty} : PP_Doc ]
-
--- continuation flow (passing the right steps as left follow steps)
-SEM VisitSteps
-  | Cons  hd.follow     = @tl.sem_steps
-          lhs.sem_steps = @hd.sem_steps
-  | Nil   lhs.sem_steps = @lhs.follow
-
-SEM VisitStep
-  | Sem        loc.ruleItf = Map.findWithDefault (error $ "Rule "  ++ show @name  ++ " not found") @name @lhs.mrules
-               (lhs.errors, loc.sem_steps) = case @loc.ruleItf @lhs.kind of
-                                               Left e     -> (Seq.singleton e, empty)
-                                               Right stmt -> (Seq.empty, stmt)
-               lhs.sem_steps = @loc.sem_steps >-< @lhs.follow
-  | ChildIntro loc.attachItf = Map.findWithDefault (error $ "Child " ++ show @child ++ " not found") @child @lhs.childintros
-               (lhs.errors,loc.sem_steps,lhs.defs,lhs.uses)
-                 = case @loc.attachItf @lhs.kind of
-                     Left e                   -> (Seq.singleton e, empty, Set.empty, Map.empty)
-                     Right (code, defs, uses) -> (Seq.empty, code, defs, uses)
-               lhs.sem_steps = @loc.sem_steps >-< @lhs.follow
-  | ChildVisit loc.visitItf = Map.findWithDefault (error $ "Visit " ++ show @visit ++ " not found") @visit @lhs.allchildvisit
-               loc.childType = Map.findWithDefault (error ("type of child " ++ show @child ++ " is not in the childTypes map! " ++ show @lhs.childTypes)) @child @lhs.childTypes
-               (lhs.errors, lhs.sem_steps) = case @loc.visitItf @child @loc.childType @lhs.kind @lhs.follow of
-                                               Left e      -> (Seq.singleton e, empty)
-                                               Right steps -> (Seq.empty, steps)
-  | Sim        -- simply propagates
-  | PureGroup  -- simply propagates
-
---
--- Some properties of VisitStep(s)
---
-
--- Number of steps in a 'Sim' block
-ATTR VisitSteps [ | | size : Int ]
-SEM VisitSteps
-  | Nil  lhs.size = 0
-  | Cons lhs.size = 1 + @tl.size
-
--- Number the steps in a 'Sim' block
-ATTR VisitSteps VisitStep [ | index : Int | ]
-SEM VisitSteps | Cons
-  hd.index  = @lhs.index  -- copy rule
-  tl.index  = 1 + @lhs.index
-  lhs.index = @tl.index   -- copy rule
-SEM Visit | Visit    steps.index = 0
-SEM VisitStep | Sim  steps.index = 0
-                     lhs.index   = @lhs.index  -- needed for if we ever allow nested Sims
-
--- Biggest number of steps in previous blocks that used parallel invocation
--- This number - 1 (minimum 0) is the number of references for parallel invocation created
-ATTR VisitSteps VisitStep [ | prevMaxSimRefs : Int | ]
-SEM Visit | Visit    steps.prevMaxSimRefs = 0
-SEM VisitStep | Sim
-  lhs.prevMaxSimRefs = if @loc.useParallel
-                       then @lhs.prevMaxSimRefs `max` (@steps.index - 1)  -- possibly new references made
-                       else @lhs.prevMaxSimRefs                           -- no references created
-
--- Is this the last step?
-ATTR VisitSteps VisitStep [ | | isLast : Bool ]
-ATTR VisitStep [ isLast : Bool | | ]
-SEM VisitSteps
-  | Nil   lhs.isLast = True
-  | Cons  lhs.isLast = False
-          hd.isLast  = @tl.isLast
-
--- Use parallel invocation: only when option enabled and there is more than one visit to a child
--- Todo: implement a parallel evaluator
-SEM VisitSteps VisitStep [ useParallel : Bool | | ]
-SEM Visit | Visit    steps.useParallel = False
-SEM VisitStep | Sim  loc.useParallel = parallelInvoke @lhs.options && @steps.size > 1
-
--- Child introduction
-ATTR EChild EChildren
-  [ | | childintros USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} ]
-
-ATTR Visits Visit VisitSteps VisitStep
-  [ childintros : {Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} | | ]
-
-SEM EProduction | EProduction
-  visits.childintros = @children.childintros
-
-SEM EChild
-  | ETerm  lhs.childintros = Map.singleton @name (\_ -> Right (empty, Set.empty, Map.empty))
-  | EChild lhs.childintros = Map.singleton @name @loc.introcode
-           loc.isDefor     = case @tp of
-                               NT _ _ defor -> defor
-                               _            -> False
-           loc.valcode     = case @kind of
-                               ChildSyntax -> @name >|< "_"
-                               ChildAttr   -> -- decide if we need to invoke the sem-function under the hood
-                                              let head | not @loc.isDefor = if lateHigherOrderBinding @lhs.options
-                                                                            then lateSemNtLabel @loc.nt >#< lhsname @lhs.options True idLateBindingAttr
-                                                                            else prefix @lhs.options >|< @loc.nt
-                                                       | otherwise        = empty -- no need to intro a terminal
-                                              in pp_parens (head >#< instname @name)
-                               ChildReplace _ -> -- the higher-order attribute is actually a function that transforms
-                                                 -- the semantics of the child (always deforested)
-                                                 pp_parens (instname @name >#< @name >|< "_")
-           loc.aroundcode  = if @hasAround
-                             then locname @lhs.options @name >|< "_around"
-                             else empty
-           loc.introcode   = \kind -> let pat    = text $ stname @name @loc.initSt
-                                          attach = pp_parens (@loc.aroundcode >#< @loc.valcode) >|< "." >|< nm_attach @loc.nt >#< "()"
-                                          decl   = pat >#< "=" >#< attach
-                                      in if compatibleAttach kind @loc.nt @lhs.options
-                                         then Right ( "let" >#< decl >#< "in"
-                                                    , Set.singleton (stname @name @loc.initSt)  -- variables defined by the child intro
-                                                    , case @kind of  -- variables used by the child introduction
-                                                        ChildAttr   -> Map.insert (instname @name) Nothing $  -- the sem attr
-                                                                         ( if @loc.isDefor || not (lateHigherOrderBinding @lhs.options)
-                                                                           then id   -- the sem dictionary attr is not used
-                                                                           else Map.insert (lhsname @lhs.options True idLateBindingAttr) (Just $ AttrInh _LHS idLateBindingAttr)
-                                                                         ) $
-                                                                         ( if @hasAround
-                                                                           then Map.insert (locname @lhs.options (@name) ++ "_around") Nothing
-                                                                           else id
-                                                                         ) $ Map.empty
-                                                        ChildReplace _ -> Map.singleton (instname @name) Nothing   -- uses the transformation function
-                                                        ChildSyntax    -> Map.empty
-                                                    )
-                                         else Left $ IncompatibleAttachKind @name kind
-           loc.nt = extractNonterminal @tp
-
-{
-stname :: Identifier -> Int -> String
-stname child st = "_" ++ getName child ++ "X" ++ show st
-
--- should actually return some conversion info
-compatibleAttach :: VisitKind -> NontermIdent -> Options -> Bool
-compatibleAttach _ _ _ = True
-}
-
--- rules
-ATTR ERules ERule [ | | sem_rules USE {>-<} {empty} : {PP_Doc}
-                        mrules USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> Either Error PP_Doc)} ]
-
-SEM ERule | ERule
-     lhs.sem_rules    = if @loc.used == 0
-                        then empty
-                        else @loc.rulecode
-     loc.rulecode     = ( if @loc.genpragma
-                          then @loc.pragma  -- this additional pragma *may* help to give some AG source location in the presence of
-                                            -- type errors in the rule. It will definitely not be precise, and may take some additional
-                                            -- source space, but let's see if it's worth it in practice.
-                          else empty
-                        )
-                        >-< @loc.declHead
-                        >-< indent ((column @rhs.pos - 2) `max` 2)
-                              ( if @loc.genpragma
-                                then @loc.pragma >-< @rhs.semfunc >-< @loc.endpragma
-                                else @rhs.semfunc
-                              )
-                        >#< "in"
-      loc.pragma       = ppLinePragma @lhs.options (line @rhs.pos) (file @rhs.pos)
-      loc.endpragma    = ppWithLineNr (\ln -> ppLinePragma @lhs.options (ln+1) @lhs.mainFile)
-      loc.genpragma    = genLinePragmas @lhs.options && @explicit && @loc.haspos
-      loc.haspos       = line @rhs.pos > 0 && column @rhs.pos >= 0 && not (null (file @rhs.pos))
-
-        -- Note: we also ensure that all rules are functions, so that they are not made part of any closures
-        -- but are lambda-lifted instead.
-      loc.declHead = "let" >#< @name >#< @loc.argPats >#< dummyPat @lhs.options (Map.null @rhs.attrs) >#< "="
-      loc.argPats
-        = ppSpaced
-            [ case mbAttr of
-                Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) ->
-                  case Map.lookup nm @lhs.localAttrTypes of
-                    Just tp -> pp_parens (strNm >#< ":" >#< ppTp tp)
-                    Nothing -> pp strNm
-                Just attr | not (noPerStateTypeSigs @lhs.options) ->
-                  case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @lhs.childTypes of
-                    Just tpDoc -> pp_parens (strNm >#< ":" >#< tpDoc)
-                    Nothing    -> pp strNm
-                _ -> pp strNm
-            | (strNm, mbAttr) <- Map.assocs @rhs.attrs
-            ]
-
-      loc.argExprs = ppSpaced $ Map.keys @rhs.attrs
-      loc.stepcode = \kind ->
-                       let mkBind (pat,expr) = "let" >#< pat >#< "=" >#< expr >#< "in"
-                       in if kind `compatibleRule` @pure
-                          then Right $ mkBind (@pattern.sem_lhs, @name >#< @loc.argExprs >#< dummyArg @lhs.options (Map.null @rhs.attrs))
-                                       >-< vlist (map mkBind @pattern.extraDefs)
-                          else Left $ IncompatibleRuleKind @name kind
-
-      lhs.mrules   = Map.singleton @name @loc.stepcode
-
-ATTR Expression [ | | tks : {[HsToken]} ]
-SEM Expression
-  | Expression lhs.tks = @tks
-
-{
-dummyPat :: Options -> Bool -> PP_Doc
-dummyPat opts noArgs
-  | not noArgs            = empty
-  | strictDummyToken opts = text "()"
-  | otherwise             = text "(_ : unit)"
-
-dummyArg :: Options -> Bool -> PP_Doc
-dummyArg opts noArgs
-  | not noArgs            = empty
-  | otherwise             = text "()"
-
-dummyType :: Options -> Bool -> PP_Doc
-dummyType opts noArgs
-  | not noArgs            = empty
-  | otherwise             = text "unit"
-}
-
-ATTR Expression [ | | pos : {Pos} ]
-SEM Expression | Expression lhs.pos = @pos
-
--- pattern and expression semantics
-ATTR Pattern  [ | | sem_lhs              : { PP_Doc } ]
-ATTR Patterns [ | | sem_lhs USE {:} {[]} : {[PP_Doc]} ]
-ATTR Pattern Patterns [ | | extraDefs USE {++} {[]} : {[(PP_Doc,PP_Doc)]} ]
-
-SEM Pattern
-  | Alias       loc.var       = text $ attrname @lhs.options False @field @attr
-                loc.hasTp     = isJust @loc.mbTp
-                loc.o_sigs    = typeSigs @lhs.options
-
-                lhs.sem_lhs   = ppArg (@loc.hasTp && @loc.o_sigs) @loc.var (maybe (text "?no type?") ppTp @loc.mbTp)
-                lhs.extraDefs = if @pat.isUnderscore
-                                then []
-                                else [ (@pat.sem_lhs, @loc.var) ]
-  | Product     lhs.sem_lhs   = pp_block "(" ")" "," @pats.sem_lhs
-  | Constr      lhs.sem_lhs   = pp_parens $ @name >#< pp_block "(" ")" "," @pats.sem_lhs
-  | Underscore  lhs.sem_lhs   = text "_"
-  | Irrefutable lhs.sem_lhs   = pp_parens (text "lazy" >#< @pat.sem_lhs)
-      -- note that the above has the inverse meaning compared to Haskell:
-      -- the above forces the evaluation of a lazy value. It seems appropriate though.
-
--- Check if a pattern is just an underscore
-ATTR Pattern [ | | isUnderscore:{Bool}]
-SEM Pattern
- | Constr      lhs.isUnderscore = False
- | Product     lhs.isUnderscore = False
- | Alias       lhs.isUnderscore = False
- | Underscore  lhs.isUnderscore = True
-
--- Collect the attributes defined by a pattern
-ATTR Pattern Patterns  [ | | attrs USE {`Set.union`} {Set.empty} : {Set String} ]
-SEM Pattern | Alias
-  lhs.attrs     = Set.insert (attrname @lhs.options False @field @attr) @pat.attrs
-
--- All attribute types of this pattern
--- Todo: if possible, make attribute types part of the pattern
-ATTR Pattern Patterns  [ | | attrTypes USE {>-<} {empty} : {PP_Doc} ]
-SEM Pattern | Alias
-  loc.mbTp      = if @field == _LHS
-                  then Map.lookup @attr @lhs.synmap
-                  else if @field == _LOC
-                       then Map.lookup @attr @lhs.localAttrTypes
-                       else Nothing
-  lhs.attrTypes = maybe empty (\tp -> (attrname @lhs.options False @field @attr) >#< "::" >#< ppTp tp) @loc.mbTp
-                  >-< @pat.attrTypes
-
--- Collect the attributes used by the right-hand side
-ATTR HsToken Expression [ | | attrs USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ]
-SEM HsToken
-  | AGLocal   lhs.attrs   = Map.singleton (fieldname @var) Nothing
-  | AGField   loc.mbAttr  = if @field == _INST || @field == _FIELD || @field == _INST'
-                            then Nothing  -- should not be used in the first place
-                            else Just $ mkNonLocalAttr (@field == _LHS) @field @attr
-              lhs.attrs   = Map.singleton (attrname @lhs.options True @field @attr) @loc.mbAttr
-
-{
-data NonLocalAttr
-  = AttrInh Identifier Identifier
-  | AttrSyn Identifier Identifier deriving Show
-
-mkNonLocalAttr :: Bool -> Identifier -> Identifier -> NonLocalAttr
-mkNonLocalAttr True  = AttrInh  -- True: inherited attr
-mkNonLocalAttr False = AttrSyn
-
-lookupAttrType :: NonLocalAttr -> Map Identifier Attributes -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc
-lookupAttrType (AttrInh child name) inhs _ = lookupType child name inhs
-lookupAttrType (AttrSyn child name) _ syns = lookupType child name syns
-
--- Note: if the child takes type parameters, the type of an attribute of this child may refer to these parameters. This means that
--- the actual type of the attribute needs to have its type parameters substituted with the actual type argument of the child.
--- However, for now we simply decide to return Nothing in this case, which skips the type annotation.
-lookupType :: Identifier -> Identifier -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc
-lookupType child name attrMp childMp
-  | noParameters childTp = Just ppDoc
-  | otherwise            = Nothing
-  where
-    attrTp     = Map.findWithDefault (error "lookupType: the attribute is not in the attrs of the child") name childAttrs
-    childAttrs = Map.findWithDefault (error "lookupType: the attributes of the nonterm are not in the map") nonterm attrMp
-    nonterm    = extractNonterminal childTp
-    childTp    = Map.findWithDefault (error ("lookupType: the child " ++ show child ++ "is not in the appropriate map")) child childMp
-    ppDoc      = ppTp attrTp
-
-noParameters :: Type -> Bool
-noParameters (Haskell _)   = True
-noParameters (NT _ args _) = null args
-}
-
-ATTR Expression [ | | semfunc : {PP_Doc} ]
-
-SEM Expression
-  | Expression lhs.attrs   = Map.unions $ map (\tok -> attrs_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks
-               lhs.semfunc = vlist $ showTokens $ map (\tok -> tok_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks
-               loc.inhhstoken = Inh_HsToken @lhs.options
-
--- child visit map
-ATTR Visit
-     Visits
-     EProduction
-     EProductions
-     ENonterminal
-     ENonterminals [ allchildvisit : {Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)}
-                     | | childvisit USE {`Map.union`} {Map.empty} : {Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)} ]
-
-ATTR VisitSteps VisitStep [ allchildvisit : {Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)} | | ]
-
-SEM ExecutionPlan
-  | ExecutionPlan nonts.allchildvisit = @nonts.childvisit
-
--- code for the invocation of the visit:
---   * "follow" is the pretty print of the code that follows this step, and is thus the code that comprises the continuation.
---   * the child state contain a field which is the operation to invoke
---   * we create a parameter with the inputs to the visit and the continuation
---   * the continuation obtains the resulting outputs plus the updated state
-SEM Visit | Visit
-  loc.prevVisitInfo = Map.findWithDefault ManyVis @from @lhs.nextVisits
-  lhs.childvisit = Map.singleton @ident @loc.invokecode
-  loc.invokecode
-    = \chld childTp kind follow ->   -- "chld" is the name of the child at the place of invocation, and "kind" the kind of the calling visit
-        let code = cont >-< inps >-< call
-
-            childNmTo   = text $ stname chld @to
-            childNmFrom = text $ stname chld @from
-            childTpArgs = case childTp of
-                            NT _ args _ -> args
-                            _           -> error "generate visit call: type of the child is not a nonterminal!"
-
-            -- cont is parameterized with the outputs of the child and brings them in scope
-            cont = "let" >#< contNm >#< ppArg @loc.o_sigs (ppRecordVal cont_in) cont_in_tp >#< "="
-                   >-< indent 2 follow  -- the continuation-code
-                   >#< "in"
-            cont_in = [ nm_outarg i @lhs.nt @ident >#< "=" >#< attrname @lhs.options True chld i | i <- Set.toList @syn ]
-                      ++ case @loc.nextVisitInfo of
-                           NoneVis -> []
-                           _       -> [ nm_outarg_cont @lhs.nt @ident >#< "=" >#< childNmTo ]
-            cont_in_tp = ppTypeParams childTpArgs >#< @loc.nameTOut_visit
-
-            -- defines the input records to the visit function
-            inps = "let" >#< inpsNm >#< "=" >#< ppRecordVal
-                     [ nm_inh @lhs.nt @ident >#< "=" >#< ppRecordVal inps_in
-                     , nm_cont @lhs.nt @ident >#< "=" >#< contNm
-                     ] >#< "in"
-            inps_in = [ nm_inarg i @lhs.nt @ident >#< "=" >#< attrname @lhs.options False chld i | i <- Set.toList @inh ]
-
-            -- the call to the visit function, with possible the need to specify which visit function to dispatch to
-            call = childNmFrom >|< "." >|< nm_invoke @lhs.nt @from >#< arg
-            arg = case @loc.prevVisitInfo of
-                    NoneVis  -> error "error: invocation of a visit from a state that has no next visits"
-                    OneVis _ -> pp inpsNm
-                    ManyVis  -> pp_parens (con_visit @lhs.nt @ident >#< inpsNm)
-        in if kind `compatibleKind` @kind
-           then Right code
-           else Left $ IncompatibleVisitKind chld @ident kind @kind
-
-{
-contNm = text "__cont_"
-inpsNm = text "__inps_"
-
--- a `compatibleKind` b  means: can kind b be invoked from a
-compatibleKind :: VisitKind -> VisitKind -> Bool
-compatibleKind _              _             = True
-
-compatibleRule :: VisitKind -> Bool -> Bool
-compatibleRule (VisitPure _) False = False
-compatibleRule _             _     = True
-}
-
--------------------------------------------------------------------------------
---  Properties of rules
--------------------------------------------------------------------------------
-
--- Construct an environment that counts how often certain rules are used
-ATTR Visits Visit VisitSteps VisitStep [ | | ruleUsage USE {`unionWithSum`} {Map.empty} : {Map Identifier Int} ]
-ATTR ERules ERule [ usageInfo : {Map Identifier Int} | | ]
-
-SEM EProduction | EProduction  rules.usageInfo = @visits.ruleUsage
-SEM VisitStep | Sem            lhs.ruleUsage = Map.singleton @name 1
-SEM ERule | ERule              loc.used      = Map.findWithDefault 0 @name @lhs.usageInfo
-
-{
-unionWithSum = Map.unionWith (+)
-}
-
--- Collect in what visit-kinds a rule is used
-ATTR Visits Visit VisitSteps VisitStep [ | | ruleKinds USE {`unionWithMappend`} {Map.empty} : {Map Identifier (Set VisitKind)} ]
-SEM VisitStep | Sem
-  lhs.ruleKinds = Map.singleton @name (Set.singleton @lhs.kind)
-
-ATTR ERules ERule [ ruleKinds : {Map Identifier (Set VisitKind)} | | ]
-SEM EProduction | EProduction
-  rules.ruleKinds = @visits.ruleKinds
-
-SEM ERule | ERule
-  loc.kinds = Map.findWithDefault Set.empty @name @lhs.ruleKinds
-  loc.anyLazyKind = Set.fold (\k r -> isLazyKind k || r) False @loc.kinds
-
-ATTR Pattern Patterns [ anyLazyKind : Bool | | ]
-
-
--------------------------------------------------------------------------------
---  Intra attributes
--------------------------------------------------------------------------------
-{
-uwSetUnion :: (Ord a, Ord b) => Map a (Set b) -> Map a (Set b) -> Map a (Set b)
-uwSetUnion = Map.unionWith Set.union
-
-uwMapUnion :: (Ord a, Ord b) => Map a (Map b c) -> Map a (Map b c) -> Map a (Map b c)
-uwMapUnion = Map.unionWith Map.union
-}
-ATTR Visit Visits [ allintramap : {Map StateIdentifier (Map String (Maybe NonLocalAttr))}
-                    | | intramap USE {`uwMapUnion`} {Map.empty} : {Map StateIdentifier (Map String (Maybe NonLocalAttr))} ]
-
-ATTR Visit Visits [ terminaldefs : {Set String} | | ]
-ATTR EChild EChildren [ | | terminaldefs USE {`Set.union`} {Set.empty} : {Set String} ]
-
-SEM EChild | ETerm
-  lhs.terminaldefs = Set.singleton $ fieldname @name
-
-SEM EProduction | EProduction
-  visits.allintramap  = @visits.intramap
-  visits.terminaldefs = @children.terminaldefs
-
-SEM Visit
-  | Visit loc.thisintra = (@loc.uses `Map.union` @loc.nextintra) `Map.difference` @loc.defsAsMap
-          lhs.intramap  = Map.singleton @from @loc.thisintra
-          loc.nextintra = maybe Map.empty id $ Map.lookup @to @lhs.allintramap
-          loc.uses      = let mp1 = @steps.uses
-                              mp2 = Map.fromList [ (lhsname @lhs.options False i, Just (AttrSyn _LHS i)) | i <- Set.elems @syn ]
-                          in mp1 `Map.union` mp2
-          loc.inhVarNms = Set.map (lhsname @lhs.options True) @inh
-          loc.defs      = @steps.defs `Set.union` @loc.inhVarNms `Set.union` @lhs.terminaldefs
-          loc.defsAsMap = Map.fromList [ (a, Nothing) | a <- Set.elems @loc.defs ]
-
-ATTR ERule ERules [ | | ruledefs USE {`uwSetUnion`} {Map.empty} : {Map Identifier (Set String)}
-                        ruleuses USE {`uwMapUnion`} {Map.empty} : {Map Identifier (Map String (Maybe NonLocalAttr))} ]
-ATTR Visit Visits
-     VisitSteps VisitStep [ ruledefs  : {Map Identifier (Set String)}
-                            ruleuses  : {Map Identifier (Map String (Maybe NonLocalAttr))} | | ]
-
-SEM ERule
-  | ERule lhs.ruledefs = Map.singleton @name @pattern.attrs
-          lhs.ruleuses = Map.singleton @name @rhs.attrs
-
-SEM EProduction
-  | EProduction visits.ruledefs = @rules.ruledefs
-                visits.ruleuses = @rules.ruleuses
-
-ATTR Visit Visits
-     EProduction
-     EProductions
-     ENonterminal
-     ENonterminals [ | | visitdefs USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (Set Identifier)}
-                         visituses USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (Set Identifier)} ]
-
-SEM Visit
-  | Visit lhs.visitdefs = Map.singleton @ident @syn
-          lhs.visituses = Map.singleton @ident @inh
-
-ATTR Visit Visits
-     VisitSteps VisitStep
-     EProduction EProductions
-     ENonterminal ENonterminals [ avisitdefs : {Map VisitIdentifier (Set Identifier)}
-                                  avisituses : {Map VisitIdentifier (Set Identifier)} | | ]
-
-SEM ExecutionPlan
-  | ExecutionPlan nonts.avisitdefs = @nonts.visitdefs
-                  nonts.avisituses = @nonts.visituses
-
-ATTR VisitSteps VisitStep [ | | defs USE {`Set.union`} {Set.empty} : {Set String}
-                                uses USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ]
-SEM VisitStep
-  | Sem        lhs.defs = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruledefs
-               lhs.uses = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruleuses
-  | ChildVisit lhs.defs = Set.insert (stname @child @to) $ maybe (error "Visit not found") (Set.map $ attrname @lhs.options True @child) $ Map.lookup @visit @lhs.avisitdefs
-               lhs.uses = let convert attrs = Map.fromList [ (attrname @lhs.options False @child attr, Just $ mkNonLocalAttr True @child attr) | attr <- Set.elems attrs ]
-                          in Map.insert (stname @child @from) Nothing $ convert $
-                               maybe (error "Visit not found") id $ Map.lookup @visit @lhs.avisituses
-
--------------------------------------------------------------------------------
---  Identification of lazy intra defs within a production
---
--- These identifiers will not be marked as strict in rules and state closures
--------------------------------------------------------------------------------
-
-ATTR Visits Visit VisitSteps VisitStep [ | | lazyIntras USE {`Set.union`} {Set.empty} : {Set String} ]
-ATTR ERules ERule [ lazyIntras : {Set String} | | ]
-
-SEM Visit | Visit
-  loc.lazyIntrasInh = case @kind of
-                        VisitPure False -> @loc.inhVarNms `Set.union` @steps.defs
-                        _               -> Set.empty
-  lhs.lazyIntras = @loc.lazyIntrasInh `Set.union` @steps.lazyIntras
-
-SEM VisitStep | PureGroup
-  lhs.lazyIntras = if @ordered
-                   then @steps.lazyIntras
-                   else @steps.defs
-
-SEM EProduction | EProduction
-  loc.lazyIntras = @visits.lazyIntras
-
--------------------------------------------------------------------------------
---  Pretty printing of haskell code
--------------------------------------------------------------------------------
-
--- note: this function produces strings, which are passed to showTokens which
--- preserves layout.
--- note: this may not be that important for ocaml code in comparison to Haskell
-SEM HsTokens [ || tks : {[(Pos,String)]} ]
-  | Cons lhs.tks = @hd.tok : @tl.tks
-  | Nil  lhs.tks = []
-
-SEM HsToken
-  | AGLocal   loc.tok = (@pos,fieldname @var)
-
-SEM HsToken [ || tok:{(Pos,String)}]
-   | AGField
-       loc.addTrace = case @rdesc of
-                        Just d  -> \x -> "(prerr_endline " ++ show (d ++ " -> " ++ show @field ++ "." ++ show @attr) ++ "; " ++ x ++ ")"
-                        Nothing -> id
-       lhs.tok = (@pos, @loc.addTrace $ attrname @lhs.options True @field @attr)
-
-   | HsToken lhs.tok = (@pos, @value)
-
-   | CharToken lhs.tok = (@pos, if null @value
-                                   then ""
-                                   else showCharShort (head @value)
-                         )
-
-   | StrToken  lhs.tok = (@pos, showStrShort @value)
-   | Err       lhs.tok = (@pos, "")
-
---
--- Distribute single-visit-next map downward
---
-
-ATTR EProductions EProduction Visits Visit
-  [ prevVisits, nextVisits : {Map StateIdentifier StateCtx} | | ]
-
-SEM ENonterminal | ENonterminal
-  prods.nextVisits = @nextVisits
-  prods.prevVisits = @prevVisits
-
---
--- Collect and distribute the from/to states of a visit
---
-
-ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit
-  [ | | fromToStates USE {`mappend`} {mempty} : {Map VisitIdentifier (Int,Int)} ]
-
-ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep
-  [ allFromToStates : {Map VisitIdentifier (Int,Int)} | | ]
-
-SEM Visit | Visit
-  lhs.fromToStates = Map.singleton @ident (@from, @to)
-
-SEM ExecutionPlan | ExecutionPlan
-  nonts.allFromToStates = @nonts.fromToStates
-
-SEM VisitStep | ChildVisit
-  (loc.from, loc.to) = Map.findWithDefault (error "visit not in allFromToStates") @visit @lhs.allFromToStates
-
-
---
--- Collect and distribute the actual types of children of productions
---
-
-ATTR EChildren EChild [ | | childTypes USE {`mappend`} {mempty} : {Map Identifier Type} ]
-ATTR ERules ERule Visits Visit VisitSteps VisitStep [ childTypes : {Map Identifier Type} | | ]
-
-SEM EProduction | EProduction
-  loc.childTypes = Map.singleton _LHS @lhs.ntType `Map.union` @children.childTypes
-
-SEM EChild | EChild ETerm
-  lhs.childTypes = Map.singleton @name @tp
-
---
--- Distribute types of local attributes
---
-
-ATTR ExecutionPlan ENonterminals ENonterminal  [ localAttrTypes : {Map NontermIdent (Map ConstructorIdent (Map Identifier Type))} | | ]
-ATTR EProductions EProduction                  [ localAttrTypes : {Map ConstructorIdent (Map Identifier Type)} | | ]
-ATTR ERules ERule Pattern Patterns             [ localAttrTypes : {Map Identifier Type} | | ]
-
-SEM ENonterminal | ENonterminal
-  prods.localAttrTypes = Map.findWithDefault Map.empty @nt @lhs.localAttrTypes
-
-SEM EProduction | EProduction
-  loc.localAttrTypes   = Map.findWithDefault Map.empty @con @lhs.localAttrTypes
-
---
--- Collect and distribute visit kinds
---
-
-ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep
-  [ allVisitKinds : {Map VisitIdentifier VisitKind} | | visitKinds USE {`mappend`} {mempty} : {Map VisitIdentifier VisitKind} ]
-
-SEM Visit | Visit
-  lhs.visitKinds = Map.singleton @ident @kind
-
-SEM ExecutionPlan | ExecutionPlan
-  nonts.allVisitKinds = @nonts.visitKinds
-
---
--- Collect and distribute the initial state of nonterminals
---
-
-ATTR ENonterminals ENonterminal [ | | initStates USE {`mappend`} {mempty} : {Map NontermIdent Int} ]
-ATTR ENonterminals ENonterminal EProductions EProduction EChildren EChild Visits Visit VisitSteps VisitStep
-  [ allInitStates : {Map NontermIdent Int} | | ]
-
-SEM ENonterminal | ENonterminal
-  lhs.initStates = Map.singleton @nt @initial
-
-SEM ExecutionPlan | ExecutionPlan
-  nonts.allInitStates = @nonts.initStates
-
-SEM EChild | EChild
-  loc.initSt = Map.findWithDefault (error "nonterminal not in allInitStates map") @loc.nt @lhs.allInitStates
-
---
--- Push the nonterminal type downward
---
-
-ATTR EProductions EProduction [ ntType : Type | | ]
-SEM ENonterminal | ENonterminal
-  loc.ntType = NT @nt (map show @params) False
-
---
--- Collect errors contained in rules that should be yielded when the
--- rules are scheduled.
---
-
-ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule Visits Visit VisitSteps VisitStep [ | | errors USE {Seq.><} {Seq.empty} : {Seq Error} ]
-SEM ERule | ERule
-  lhs.errors = case @mbError of
-                 Just e | @loc.used > 0 -> Seq.singleton e
-                 _                      -> Seq.empty
+-- As expected, the code generation for ML resembles the code generation for Haskell quite a bit.+-- However, there are several differences:+--   * no inline pragmas+--   * no strictness annotations (not needed)+--   * separating data types from code+--+-- Generator conventions:+-- * we generate functions definitions with an 'and' binding and a match statement+-- * for some type aliasses, we'll introduce module decls in addition to a type+--+-- Future work:+-- * abuse the module system more?+-- * parse ocaml blocks?+-- * lazy evaluation?+--+-- Other comments:+-- * Empty records are not allowed in Ocaml. Mapping them to units.+-- * line pragmas. There are now line pragmas around the body of rules.+--   There cannot be syntactical mistakes in the patterns. However, there can be+--   type errors if a function returns a value with a type that differs from what+--   is expected. It's then not clear which location is reported.+--   Also, errors in type signatures are not caught.+--   However, usually, the problematic cases are syntax errors, and these are+--   prevented by parsing the definitions first.++INCLUDE "ExecutionPlan.ag"+INCLUDE "Patterns.ag"+INCLUDE "Expression.ag"+INCLUDE "HsToken.ag"++imports+{+import ExecutionPlan+import Pretty+import PPUtil+import Options+import Data.Monoid(mappend,mempty)+import Data.Maybe+import Data.Graph+import Debug.Trace+import System.IO+import System.Directory+import System.FilePath+import UU.Scanner.Position++import TokenDef+import HsToken+import ErrorMessages++import Data.Set (Set)+import qualified Data.Set as Set+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Sequence(Seq)+import qualified Data.Sequence as Seq+import Data.Foldable(toList)+}++ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule EChildren EChild+  [ mainFile, mainName : String | | ]++-------------------------------------------------------------------------------+--  Options+-------------------------------------------------------------------------------+ATTR ExecutionPlan+     ENonterminals ENonterminal+     EProductions EProduction+     ERules ERule+     EChildren EChild+     Expression+     HsToken HsTokens HsTokensRoot+     Pattern Patterns+     Visits Visit+     VisitSteps VisitStep [ options : {Options} | | ]+ATTR EProductions EProduction [ rename : {Bool} | | ]++SEM ENonterminal | ENonterminal+  prods.rename = rename @lhs.options++-------------------------------------------------------------------------------+--  Context info (nonterminal ident, constructor ident, nonterm params, etc.)+-------------------------------------------------------------------------------++ATTR Visit Visits EProduction EProductions EChildren EChild ERules ERule [ nt : NontermIdent | | ]+SEM ENonterminal | ENonterminal+  prods.nt = @nt++ATTR EChildren EChild ERules ERule Visits Visit [ con : ConstructorIdent | | ]++SEM EProduction | EProduction children.con = @con+  rules.con    = @con+  visits.con   = @con++ATTR EProductions EProduction Visits Visit [ params : {[Identifier]} | | ]+SEM ENonterminal | ENonterminal+  prods.params = @params++-------------------------------------------------------------------------------+--  output attributes: we make a distinction between data declarations+--  and code+-------------------------------------------------------------------------------+ATTR ExecutionPlan [  | | datas, code, modules : {PP_Doc} ]++SEM ExecutionPlan | ExecutionPlan+  lhs.code   = @nonts.code  >-< @loc.wrappersExtra+  lhs.datas  = @nonts.datas >-< @loc.commonExtra++ATTR ENonterminal ENonterminals+  [ wrappers : {Set NontermIdent} | | datas,code,modules USE {>-<} {empty} : {PP_Doc} ]++SEM ExecutionPlan | ExecutionPlan+  nonts.wrappers = @wrappers++SEM ENonterminal | ENonterminal+  lhs.datas = (    text ""+               >-< "(* *** " ++ getName @nt ++ " *** [data] *)")+               >-< (if dataTypes @lhs.options+                    then pp "(* data *)"+                         >-< @loc.datatypeNt+                         >-< @loc.datatypeProds+                         >-< ""+                    else empty)+               >-< (if @loc.hasWrapper+                     then pp "(* wrapper *)"+                          >-< @loc.wr_inh+                          >-< @loc.wr_syn+                          >-< ""+                     else empty)+               >-< (if semfuns @lhs.options+                    then pp "(* semantic domain *)"+                         >-< @loc.t_init+                         >-< @loc.t_states+                         >-< @loc.c_states+                         >-< @prods.t_visits+                         >-< ""+                    else empty)++  lhs.code   = (    text ""+                >-< "(* *** " ++ getName @nt ++ " *** [code] *)")+                >-< (if dataTypes @lhs.options+                    then pp "(* constructor functions *)"+                         >-< @loc.datatypeCon+                    else empty)+                >-< (if @loc.hasWrapper+                     then pp "(* wrapper *)"+                          >-< @loc.wrapper+                          >-< ""+                     else empty)+                >-< (if folds @lhs.options+                     then "(* cata *)"+                          >-< @loc.sem_nt+                          >-< ""+                     else empty)+                >-< (if semfuns @lhs.options+                     then "(* semantic domain *)"+                          >-< @prods.sem_prod+                          >-< ""+                     else empty)++  -- note: we assume that these module declarations are not recursive, and+  -- that their parameters do not depends on types generated by AG in the+  -- same file.+  lhs.modules = @loc.moduleDecl++  loc.hasWrapper = @nt `Set.member` @lhs.wrappers++-------------------------------------------------------------------------------+--  Nonterminal datatype+-------------------------------------------------------------------------------+ATTR ENonterminal ENonterminals [ typeSyns : {TypeSyns} | | ]++SEM ExecutionPlan | ExecutionPlan+  nonts.typeSyns = @typeSyns++{+ppRecordTp :: PP a => [a] -> PP_Doc+ppRecordTp es+  | null es   = text "unit"+  | otherwise = pp_block "{" "}" "; " (map pp es)++ppRecordVal :: PP a => [a] -> PP_Doc+ppRecordVal es+  | null es   = text "()"+  | otherwise = pp_block "{" "}" "; " (map pp es)++ppFieldsVal :: Bool -> [(PP_Doc,PP_Doc,PP_Doc,PP_Doc)] -> PP_Doc+ppFieldsVal record fields+  | null fields = text "()"+  | record      = ppRecordVal [ r >#< "=" >#< x | (r,x,_,_) <- fields ]+  | otherwise   = pp_block "(" ")" "," [ x | (_,x,_,_) <- fields ]++ppFieldsType :: Bool -> Bool -> [(PP_Doc,PP_Doc,PP_Doc,PP_Doc)] -> PP_Doc+ppFieldsType record defor fields+  | null fields = text "unit"+  | record      = ppRecordTp [ r >#< ":" >#< (if defor then d else f) | (r,_,d,f) <- fields ]+  | otherwise   = pp_block "(" ")" "*" [ if defor then d else f | (_,_,d,f) <- fields ]+}+++-- for each nonterminal, the following data types in ocmal:+-- * data type for the nonterminal, with a constructor for+--   each production. The constructor takes a single field+--   with the type explained below.+-- * for each production, a record type comprising the+--   children of the production.+--+-- * class contexts are ignored+-- * at most one type variable+--+-- aliasses: lists, tuples+--  *** think about maps, sets, etc. Perhaps the name of+--  the alias should become a local module name.+--++SEM ENonterminal | ENonterminal+  loc.t_params = ppTypeParams @params+  loc.aliasPre = "and" >#< @loc.t_params >#< @nt >#< "="+  loc.aliasMod = @loc.aliasPre >#< modName @nt >|< ".t"+  loc.datatypeNt+    = case lookup @nt @lhs.typeSyns of+        -- generate special code for certain type aliasses+        Just (List t)     -> @loc.aliasPre >#< ppTp t >#< "list"+        Just (Maybe t)    -> @loc.aliasPre >#< ppTp t >#< "option"+        Just (Tuple ts)   -> @loc.aliasPre >#< (pp_block "(" ")" " * " $ map (ppTp . snd) ts)++        Just (Map k v)    -> @loc.aliasMod+        Just (IntMap t)   -> @loc.aliasMod+        Just (OrdSet t)   -> @loc.aliasMod+        Just IntSet       -> @loc.aliasMod++        -- use the constructor-based data-type generation for all other types+        _ -> "and" >#< @loc.t_params >#< @nt >#< "="+             >-< ( if null @prods.datatype+                   then pp "unit"+                   else indent 2 $ vlist @prods.datatype_call+                 )++  loc.datatypeCon+    = case lookup @nt @lhs.typeSyns of+        Just _  -> empty  -- no constructor funs for type aliasses+        Nothing -> vlist @prods.datatype_con++  loc.moduleDecl+    = let ppModule :: PP a => a -> PP_Doc+          ppModule expr = "module" >#< modName @nt >#< "="+      in case lookup @nt @lhs.typeSyns of+           Just (Map k _)  -> ppModule ("Map.Make" >#< pp_parens (ppTp k))+           Just (IntMap _) -> ppModule ("Map.Make ()")+           Just (OrdSet t) -> ppModule ("Set.Make" >#< pp_parens (ppTp t))+           Just IntSet     -> ppModule ("Set.Make (struct  type t = int  let compare = Pervasives.compare  end)")+           _               -> empty++  loc.datatypeProds = vlist @prods.datatype++ATTR EProduction  [ | | datatype, datatype_call, datatype_con : {PP_Doc} ]+ATTR EProductions [ | | datatype, datatype_call, datatype_con USE {:} {[]} : {[PP_Doc]} ]++SEM EProduction | EProduction+  loc.o_records = dataRecords @lhs.options+  loc.t_params = ppTypeParams @lhs.params+  loc.t_c_params = ppTypeParams (cont_tvar : map pp @params)+  loc.conname = conname @lhs.rename @lhs.nt @con+  loc.recname = pp "fields_" >|< @loc.conname+  lhs.datatype = "and" >#< @loc.t_params >#< @loc.recname >#< "="+                 >#< ppFieldsType @loc.o_records False @children.sigs+  lhs.datatype_call = pp "|" >#< @loc.conname >#< "of" >#< pp_parens (@loc.t_params >#< @loc.recname)+  lhs.datatype_con+    = let funNm  = @lhs.nt >|< "_" >|< @con+          decl   = "and" >#< ppFunDecl @loc.o_sigs funNm params (@loc.t_params >#< @lhs.nt) body+          params = [ (x, t) | (_,x,_,t) <- @children.sigs ]+          body   = @loc.conname >#< ppFieldsVal @loc.o_records @children.sigs+      in decl+ +ATTR EChild EChildren [ | | sigs USE {++} {[]} : {[(PP_Doc,PP_Doc,PP_Doc,PP_Doc)]} ]++SEM EChild+  | EChild ETerm+      loc.tpDocFor   = ppTp $ removeDeforested @tp+      loc.tpDocDefor = ppTp $ forceDeforested @tp+      loc.fieldNm    = text $ recordFieldname @lhs.nt @lhs.con @name+      loc.childNm    = text (fieldname @name)+      loc.field  = (@loc.fieldNm, @loc.childNm, @loc.tpDocDefor, @loc.tpDocFor)+  | EChild  lhs.sigs = case @kind of+                         ChildAttr -> []  -- higher order attributes are not part of the data type+                         _         -> [@loc.field]+  | ETerm   lhs.sigs = [@loc.field]++{+ppTp :: Type -> PP_Doc+ppTp tp = case tp of+  Haskell t -> pp t   -- ocaml type+  NT nt tps deforested+    | nt == _SELF -> pp "?SELF?"+    | null tps    -> ppNontTp nt deforested+    | otherwise   -> pp_parens (ppSpaced (map pp_parens tps) >#< ppNontTp nt deforested)+  Self -> pp "?SELF?"++ppNontTp :: NontermIdent -> Bool -> PP_Doc+ppNontTp nt True  = pp "t_" >|< pp nt+ppNontTp nt False = pp nt++-- multiple type parameters go into a tuple+ppTypeParams :: PP a => [a] -> PP_Doc+ppTypeParams []  = empty+ppTypeParams [x] = pp x+ppTypeParams xs  = pp_block "(" ")" "," (map pp xs)+}++-------------------------------------------------------------------------------+--  Nonterminal semantic function+-------------------------------------------------------------------------------+SEM ENonterminal | ENonterminal+  loc.fsemname = \x -> prefix @lhs.options ++ show x+  loc.semname = @loc.fsemname @nt+  loc.frecarg = \t x -> case t of+                  NT nt _ _ -> pp_parens (@fsemname nt >#< x)+                  _         -> x++  loc.sem_param_tp = @loc.t_params >#< @nt+  loc.sem_res_tp   = @loc.t_params >#< @loc.t_type+  loc.sem_tp       = @loc.sem_param_tp >#< "->" >#< @loc.sem_res_tp++  loc.o_sigs  = typeSigs @lhs.options+  loc.sem_nt_body = "match arg with" >-< (indent 2 $ @prods.sem_nt)+  loc.sem_nt  = let genSem :: PP a => a -> PP_Doc -> PP_Doc+                    genSem nm body = "and" >#< ppFunDecl @loc.o_sigs (pp @loc.semname) [(pp nm, @loc.sem_param_tp)] @loc.sem_res_tp body+                    genAlias alts = genSem (pp "arg") (pp "match arg with" >-< (indent 2 $ vlist $ map (pp "|" >#<) alts))+                    genMap v = let body = modName @nt >|< ".fold" >#< @loc.semname >|< "_Entry" >#< @loc.semname >|< "_Nil" >#< els+                                   els  = case v of+                                     NT nt _ _ -> pp_parens (modName @nt >|< ".map" >#< @loc.fsemname nt >#< "m")+                                     _         -> pp "m"+                               in genSem "m" body+                    genSet mbNt = let body = "List.fold_right" >#< @loc.semname >|< "_Entry" >#<+                                              els (pp_parens (modName @nt >|< ".elements" >#< "s")) >#< @loc.semname >|< "_Nil"+                                      els r = maybe r (\nt -> pp_parens ("List.map" >#< @loc.fsemname nt >#< r)) mbNt+                                  in genSem "s" body+                in case lookup @nt @lhs.typeSyns of+                     -- generate special code for some aliasses+                     Just (List t) -> let body = "List.fold_right" >#< @loc.semname >|< "_Cons" >#< els >#< @loc.semname >|< "_Nil"+                                          els  = case t of+                                            NT nt _ _ -> pp_parens ("List.map" >#< @loc.fsemname nt >#< "list")+                                            _         -> pp "list"+                                      in genSem "list" body+                     Just (Tuple ts) -> let pat = pp_parens (ppCommas $ map fst ts)+                                            body = @loc.semname >|< "_Tuple" >#< ppSpaced (map (\t -> @loc.frecarg (snd t) (pp $ fst t)) ts)+                                        in genSem pat body+                     Just (Map _ v) -> genMap v+                     Just (IntMap v) -> genMap v+                     Just (Maybe t) -> genAlias+                         [ "None" >#< "->" >#< "=" >#< @loc.semname >|< "_Nothing"+                         , "Some" >#< "just" >#< "->" >#< @loc.semname >|< "_Just" >#< @frecarg t (pp "just")+                         ]+                     Just (OrdSet t) -> genSet $ case t of+                                          NT nt _ _ -> Just nt+                                          _         -> Nothing+                     Just (IntSet) -> genSet Nothing++                     -- structural fold for the remaining cases+                     _ -> genSem "arg" @loc.sem_nt_body++{+-- convention for nonterminals to module names+modName :: NontermIdent -> PP_Doc+modName nt = pp "M_" >|< pp nt++ppFunDecl :: Bool -> PP_Doc -> [(PP_Doc,PP_Doc)] -> PP_Doc -> PP_Doc -> PP_Doc+ppFunDecl gensigs nm args resSig expr = body where+  body = nm >#< ppSpaced (map arg args) >#< ppRes >#< "="+         >-< indent 2 expr+  arg (arg,tp) = ppArg gensigs arg tp+  ppRes+    | gensigs  = ":" >#< resSig+    | otherwise = empty++ppArg :: Bool -> PP_Doc -> PP_Doc -> PP_Doc+ppArg gensigs arg tp+  | gensigs   = pp_parens (arg >#< ":" >#< tp)+  | otherwise = arg++}++-- The number of productions+ATTR EProductions EProduction [ | | count USE {+} {0} : {Int} ]+SEM EProduction | EProduction  lhs.count = {1}++-- The per-production match-expr cases for the sem_NT function+ATTR EProduction EProductions [ | | sem_nt USE {>-<} {empty} : {PP_Doc} ]+SEM EProduction | EProduction+  lhs.sem_nt = "|" >#< conname @lhs.rename @lhs.nt @con >#< ppFieldsVal @loc.o_records @children.sigs >#< "->" >#<+                 prefix @lhs.options >|< @lhs.nt >|< "_" >|< @con >#< ppSpaced @children.argnamesw++ATTR EChild    [ | | argnamesw              : { PP_Doc } ]+ATTR EChildren [ | | argnamesw USE {:} {[]} : {[PP_Doc]} ]++SEM EChild+  | EChild lhs.argnamesw = case @kind of+                             ChildSyntax     -> "(" >#< prefix @lhs.options >|< @loc.nt >#< @name >|< "_" >#< ")"+                             ChildAttr       -> empty  -- no sem-case for a higher-order child+                             ChildReplace tp -> "(" >#< prefix @lhs.options >|< extractNonterminal tp >#< @name >|< "_" >#< ")"+  | ETerm  lhs.argnamesw = text $ fieldname @name++-------------------------------------------------------------------------------+--  Types of attributes+-------------------------------------------------------------------------------+ATTR ExecutionPlan+     ENonterminals+     ENonterminal  [ inhmap : {Map NontermIdent Attributes}+                     synmap : {Map NontermIdent Attributes} | | ]++ATTR EProductions EProduction+     ERules ERule+     Patterns Pattern+     Visits+     Visit   [ inhmap : {Attributes}+               synmap : {Attributes}+               allInhmap : {Map NontermIdent Attributes}+               allSynmap : {Map NontermIdent Attributes} | | ]++SEM ENonterminal+  | ENonterminal (Just prods.inhmap) = Map.lookup @nt @lhs.inhmap+                 (Just prods.synmap) = Map.lookup @nt @lhs.synmap+                 prods.allInhmap = @lhs.inhmap+                 prods.allSynmap = @lhs.synmap++-------------------------------------------------------------------------------+--  State datatypes+-------------------------------------------------------------------------------+{type VisitStateState = (VisitIdentifier,StateIdentifier, StateIdentifier)}++ATTR Visit  [ | | allvisits              : { VisitStateState }]+ATTR Visits [ | | allvisits USE {:} {[]} : {[VisitStateState]}]+ATTR EProduction+     EProductions [ | | allvisits: {[VisitStateState]}]++SEM Visit+  | Visit lhs.allvisits = (@ident, @from, @to)++SEM EProductions+  | Cons lhs.allvisits = @hd.allvisits -- just pick the first production+  | Nil  lhs.allvisits = error "Every nonterminal should have at least 1 production"++-- type of tree in a given state s+SEM ENonterminal | ENonterminal+  loc.allstates = orderStates @initial @prods.allvisits+  loc.stvisits  = \st -> filter (\(v,f,t) -> f == st) @prods.allvisits+  loc.t_type    = type_nt_sem_top @nt+  loc.t_c_params = ppTypeParams (cont_tvar : map pp @params)++  -- the initial "s" type: contains the "attach" function that delivers the initial st+  loc.t_init    = "and" >#< @loc.t_params >#< @loc.t_type >#< "=" >#< pp_braces ( nm_attach @nt >#< ":" >#< "unit" >#< "->" >#< @loc.t_params >#< type_nt_sem @nt @initial)++  -- the "s" type in a given state: contains the invoke function to go to a next state+  loc.t_states  = vlist $ map (\st ->+                    let s_st = type_nt_state @nt st+                        t_st  = type_nt_sem @nt st+                        c_st  = type_caller @nt st+                        nextVisits = Map.findWithDefault ManyVis st @nextVisits+                        decl = "and" >#< @loc.t_params >#< t_st >#< "="+                    in case nextVisits of+                         NoneVis    -> decl >#< "unit"  -- final state: no more subsequent visits+                         _          -> decl >#< ppRecordVal [ nm_invoke @nt st >#< ":" >#< cont_tvar >#< "." >#< @loc.t_c_params >#< c_st >#< "->" >#< cont_tvar ]+                   ) @loc.allstates++{+--+-- conventions+--++-- type of the state of a node: a closure containing the children states and attributes,+-- with code of type 'type_nt_sem' that represents the subsequent visits to successor states.+type_nt_state nt st = "s_" >|< nt >|< "_" >|< st++-- type of a visit to a node (the initial, and when in a given state)+-- an instance of this type is called the "semantics"+type_nt_sem_top nt = "t_" >|< nt+type_nt_sem nt st = type_nt_sem_top nt >|< "_s" >|< st++-- type of a caller (contains visit selection + inputs + continuation)+type_caller nt st = "c_" >|< nt >|< "_s" >|< st++-- names of records+nm_attach nt = "attach_">|< nt+nm_invoke nt st = "inv_" >|< nt >|< "_s" >|< st++-- name of the type variable representing the result type of the continuation+cont_tvar = text "'cont__"+++-- order states in reverse topological order so that successor states are+-- earlier in the resulting list.+orderStates :: StateIdentifier -> [VisitStateState] -> [StateIdentifier]+orderStates initial edges = res where+  source  = Map.singleton initial Set.empty  -- ensures that the initial state is in graph even when there are no edges+  targets = [ Map.singleton t Set.empty | (_,_,t) <- edges ]+  deps    = [ Map.singleton f (Set.singleton t) | (_,f,t) <- edges ]++  mp  = Map.unionsWith Set.union (source : (targets ++ deps))+  es  = [ (f,f,Set.toList ts) | (f,ts) <- Map.toList mp ]+  cps = stronglyConnComp es+  res = flattenSCCs cps+}++-- type of a caller that selects a visit v from state s of the child, and+-- provides a continuation of the caller after the visit to the child+SEM ENonterminal | ENonterminal+  loc.c_states = vlist $ map (\st ->+                   let nt_st = type_nt_state @nt st+                       c_st  = type_caller @nt st+                       outg  = filter (\(_,f,_) -> f == st) @prods.allvisits+                       nextVisits = Map.findWithDefault ManyVis st @nextVisits+                       declHead = "and" >#< @loc.t_c_params >#< c_st >#< "="+                       visitcons = vlist $ map (\(v,_,_) ->+                         "|" >#< con_visit @nt v >#< "of" >#< @loc.t_c_params >#< type_caller_visit @nt v+                        ) outg+                   in case nextVisits of   -- slight optimization for when there is only one visit+                        NoneVis  -> empty  -- st is final state, no subsequent visits, thus no more caller info+                        OneVis v -> declHead >#< @loc.t_c_params >#< type_caller_visit @nt v+                        ManyVis  -> declHead >-< indent 3 visitcons+                  ) @loc.allstates++{+type_caller_visit nt v = "c_" >|< nt >|< "_v" >|< v+con_visit nt v = "C_" >|< nt >|< "_v" >|< v++-- field names+nm_inh nt v  = "inh_" >|< nt >|< "_v" >|< v+nm_cont nt v = "cont_" >|< nt >|< "_v" >|< v+}++-- type t_visit of a call to a visit v (inputs to the visit + continuation of the parents that gets the output + new state of the child)+ATTR Visit Visits EProduction EProductions [ | | t_visits USE {>-<} {empty} : {PP_Doc} ]++SEM EProductions | Cons+  lhs.t_visits = @hd.t_visits+    -- just pick the first production (these results are the same for all of them)+    -- todo: that means we should actually represent visit declarations in the AST...++SEM Visit | Visit+  loc.nameTIn_visit   = conNmTVisitIn @lhs.nt @ident+  loc.nameTOut_visit  = conNmTVisitOut @lhs.nt @ident+  loc.nameNextState    = type_nt_sem @lhs.nt @to+  loc.nameCaller_visit = type_caller_visit @lhs.nt @ident++  loc.nextVisitInfo   = Map.findWithDefault ManyVis @to @lhs.nextVisits  -- which visits can we do after we reach the @to state?++  loc.t_params  = ppTypeParams @lhs.params+  loc.t_c_params = ppTypeParams (cont_tvar : map pp @lhs.params)++  -- data type decls for the t_visit type+  -- we generate a type for the caller of a visit, the arguments of the visit and the result of the visit+  lhs.t_visits =  "and" >#< @loc.t_c_params >#< @loc.nameCaller_visit >#< "=" >#< ppRecordTp+                    [ nm_inh @lhs.nt @ident >#< ":" >#< @loc.t_params >#< conNmTVisitIn @lhs.nt @ident+                    , nm_cont @lhs.nt @ident >#< ":" >#< @loc.t_params >#< conNmTVisitOut @lhs.nt @ident >#< "->" >#< cont_tvar+                    ]+                  >-< "and" >#< @loc.t_params >#< @loc.nameTIn_visit  >#< "=" >#< ppRecordTp @loc.inhpart+                  >-< "and" >#< @loc.t_params >#< @loc.nameTOut_visit >#< "=" >#< ppRecordTp (@loc.synpart ++ @loc.contpart)++  loc.contpart = case @loc.nextVisitInfo of+                   NoneVis -> []                    -- don't provide a continuation at all+                   _       -> [ nm_outarg_cont @lhs.nt @ident >#< ":" >#< @loc.t_params >#< @loc.nameNextState ]  -- normal route: select the next semantics++  loc.inhpart   = @loc.ppTypeList nm_inarg @inh @lhs.inhmap+  loc.synpart   = @loc.ppTypeList nm_outarg @syn @lhs.synmap+  loc.ppTypeList = \f s m -> map (\i -> case Map.lookup i m of+                                          Just tp -> f i @lhs.nt @ident >#< ":" >#< ppTp tp ) $ Set.toList s++{+-- more naming conventions+nm_inarg nm nt v = "i_" >|< nm >|< "_" >|< nt >|< "_v" >|< v+nm_outarg nm nt v = "o_" >|< nm >|< "_" >|< nt >|< "_v" >|< v+nm_outarg_cont = nm_outarg "_cont"++conNmTVisit nt vId      = "t_" >|< nt >|< "_v"    >|< vId+conNmTVisitIn nt vId    = "t_" >|< nt >|< "_vIn"  >|< vId+conNmTVisitOut nt vId   = "t_" >|< nt >|< "_vOut" >|< vId++-- todo: remove ppMonadType+ppMonadType :: Options -> PP_Doc+ppMonadType opts+  | parallelInvoke opts = text "IO"+  | otherwise           = text "Identity"+}++-------------------------------------------------------------------------------+--  Inh and Syn wrappers+-------------------------------------------------------------------------------+SEM ENonterminal | ENonterminal+  loc.wr_inh   = @loc.genwrap "inh" @loc.wr_inhs1  -- todo: is perhaps a mistake in 2hs+  loc.wr_syn   = @loc.genwrap "syn" @loc.wr_syns+  loc.genwrap  = \nm attrs ->+                   "and" >#< @loc.t_params >#< nm >|< "_" >|< @nt >#< "=" >#< ppRecordTp+                     [ i >|< "_" >|< nm >|< "_" >|< @nt >#< ":" >#< ppTp t | (i,t) <- attrs ]++  loc.inhAttrs = fromJust $ Map.lookup @nt @lhs.inhmap+  loc.wr_inhs  = Map.toList $ @loc.wr_filter $ @loc.inhAttrs+  loc.wr_inhs1 = Map.toList @loc.inhAttrs+  loc.wr_filter = if kennedyWarren @lhs.options && lateHigherOrderBinding @lhs.options+                  then Map.delete idLateBindingAttr+                  else id+  loc.wr_syns  = Map.toList $ fromJust $ Map.lookup @nt @lhs.synmap++  loc.wrapname = text ("wrap_" ++ show @nt)+  loc.inhname  = text ("inh_" ++ show @nt)+  loc.synname  = text ("syn_" ++ show @nt)+  loc.firstVisitInfo = Map.findWithDefault ManyVis @initial @nextVisits++  loc.wrapArgSemTp = @loc.t_params >#< @loc.t_type+  loc.wrapArgInhTp = @loc.t_params >#< @loc.inhname+  loc.wrapArgPats  = ppRecordVal [ i >|< "_inh_" >|< @nt >#< "=" >#< lhsname @lhs.options True i | (i,_) <- @loc.wr_inhs1 ]+  loc.wrapResTp = @loc.t_params >#< @loc.synname+  loc.wrapper  = "and" >#< ppFunDecl @loc.o_sigs @loc.wrapname [(pp "act", @loc.wrapArgSemTp), (@loc.wrapArgPats, @loc.wrapArgInhTp)] @loc.wrapResTp @loc.wrapperPreamble+  loc.wrapperPreamble+    = ( if lateHigherOrderBinding @lhs.options+        then "let" >#< lhsname @lhs.options True idLateBindingAttr >#< "=" >#< lateBindingFieldNm @lhs.mainName >#< "in"+        else empty+      ) -- initial attribute for late binding+      >-< @loc.wrapperBody+  loc.wrapperBody+    = case @initialv of+        [] -> text "{ }"  -- case where there are no inherited or synthesized attributes+        (initv:_) -> -- TODO: take care of multiple visits+          let attach  = "let" >#< "sem" >#< "=" >#< "act." >|< nm_attach @nt >#< "()" >#< "in"  -- run attach code++              -- result transformer to wrapper output record+              pat     = ppRecordVal [ nm_outarg i @nt initv >#< "=" >#< lhsname @lhs.options False i | (i,_) <- @loc.wr_syns ]+              bld     = ppRecordVal [ i >|< "_syn_" >|< @nt >#< "=" >#< lhsname @lhs.options False i | (i,_) <- @loc.wr_syns ]+              res     = "let res = function" >#< pat >#< "->" >#< bld >#< "in"++              -- input to the visit (inh attrs + continuation)+              inps    = "let" >#< "inps" >#< "=" >#< ppRecordVal [ nm_inarg i @nt initv >#< "=" >#< lhsname @lhs.options True i | (i,_) <- @loc.wr_inhs ] >#< "in"+              arg     = "let" >#< "arg" >#< "=" >#< argcon >#< argrec >#< "in"+              argcon  = case @loc.firstVisitInfo of+                          ManyVis -> con_visit @nt initv+                          _       -> empty+              argrec  = ppRecordVal+                          [ nm_inh @nt initv >#< "=" >#<  "inps"+                          , nm_cont @nt initv >#< "=" >#< "res"+                          ]+              invoke  = "sem." >|< nm_invoke @nt @initial >#< "arg"  -- invoke the visit+          in attach >-< res >-< inps >-< arg >-< invoke++-------------------------------------------------------------------------------+--  Collection of NT / Production sem funs references+-------------------------------------------------------------------------------++ATTR ENonterminals ENonterminal EProductions EProduction [ | | semFunBndDefs, semFunBndTps USE {Seq.><} {Seq.empty} : {Seq PP_Doc} ]+SEM ENonterminal | ENonterminal+  lhs.semFunBndDefs = @loc.semFunBndDef Seq.<| @prods.semFunBndDefs+  lhs.semFunBndTps  = @loc.semFunBndTp Seq.<| @prods.semFunBndTps+  loc.semFunBndDef  = @loc.semFunBndNm >#< "=" >#< @loc.semname+  loc.semFunBndTp   = @loc.semFunBndNm >#< ":" >#< @loc.sem_tp+  loc.semFunBndNm   = lateSemNtLabel @nt++SEM EProduction | EProduction+  lhs.semFunBndDefs = Seq.singleton @loc.semFunBndDef+  lhs.semFunBndTps  = Seq.singleton @loc.semFunBndTp+  loc.semFunBndDef  = @loc.semFunBndNm >#< "=" >#< @loc.semname+  loc.semFunBndTp   = @loc.semFunBndNm >#< ":" >#< @loc.sem_tp+  loc.semFunBndNm   = lateSemConLabel @lhs.nt @con++-- Generate a dictionary that contains the semantics of all semantic functions+SEM ExecutionPlan | ExecutionPlan+  loc.wrappersExtra = if lateHigherOrderBinding @lhs.options+                      then @loc.lateSemBndDef+                      else empty+  loc.commonExtra   = if lateHigherOrderBinding @lhs.options+                      then @loc.lateSemBndTp+                      else empty+  loc.lateSemBndTp = "and" >#< lateBindingTypeNm @lhs.mainName >#< "=" >#< ppRecordTp (toList @nonts.semFunBndTps)+  loc.lateSemBndDef = "and" >#< lateBindingFieldNm @lhs.mainName >#< ":" >#< lateBindingTypeNm @lhs.mainName >#< "="+                      >-< (indent 2 $ ppRecordVal $ toList @nonts.semFunBndDefs)++-------------------------------------------------------------------------------+--  Production semantic functions+-------------------------------------------------------------------------------+ATTR EProduction  [ | | sem_prod                   : {PP_Doc} ]+ATTR EProductions [ | | sem_prod USE {>-<} {empty} : {PP_Doc} ]++ATTR EProduction EProductions [ initial : {StateIdentifier}+                                allstates : {[StateIdentifier]} | | ]+SEM ENonterminal | ENonterminal+  prods.initial   = @initial+  prods.allstates = @loc.allstates++SEM EProduction | EProduction+  loc.o_sigs     = typeSigs @lhs.options+  loc.t_type     = type_nt_sem_top @lhs.nt+  loc.semname    = prefix @lhs.options >|< @lhs.nt >|< "_" >|< @con+  loc.sem_res_tp = @loc.t_params >#< @loc.t_type+  loc.sem_tp     = pp_block "" "" "->" [ d | (_,_,d,_) <- @children.sigs ] >#< "->" >#< @loc.sem_res_tp++  loc.initializer+    = -- some actions, performed upon attaching a child, can+      -- be specified here in the form of a let-expression.+      -- The resulting bindings of these actions are+      -- in scope of the rules of the production+      empty  -- nothing for now++  loc.sem_prod  = "and" >#< ppFunDecl @loc.o_sigs @loc.semname [ (x,d) | (_,x,d,_) <- @children.sigs ] @loc.sem_res_tp @loc.prod_body+  loc.prod_body+    = @loc.initializer+      >-< "{" >#< nm_attach @lhs.nt >#< "=" >#< "function () ->"+      >-< indent 2 +          (   "(* rules of production" >#< @con >#< "*)"+          >-< @rules.sem_rules+          >-< "(* states of production" >#< @con >#< "*)"+          >-< vlist @loc.statefuns+          >-< nm_st @lhs.initial+          )+      >#< "}"++  -- the semantic function of a production: defines a series of states and+  -- their transitions. Two sorts of functions are important:+  --   k-functions: inspect the caller_type to find out which visit the+  --     caller wants and then dispatches that visit and continuation.+  --   v-functions: the actual code of the visit.+  loc.statefuns = map @loc.genstfn @lhs.allstates+  loc.genstfn+    = \st -> let nextVisitInfo = Map.findWithDefault ManyVis st @lhs.nextVisits+                 stNm = nm_st st++                 -- note about the initial state: the initial state should be the only+                 -- state-binding that is not a function. It is non-recursive, its definition does+                 -- not involve side effect, and its not needed+                 -- anywhere except to be delivered as initial result.+                 stDef body = "let" >#< stNm >#< (if st == @lhs.initial then empty else @loc.stargs st) >#< "="+                              >-< indent 2 body >#< "in"++             in case nextVisitInfo of+                  NoneVis -> -- the (empty) closure of a (non-initial) end state is not referenced+                             -- thus generating it is not needed (and omitting it may catch some small mistakes).+                             if st == @lhs.initial+                             then stDef (pp "unit")  -- empty state+                             else empty              -- no state generated+                  _       -> stDef $ mklets (@loc.stvs st ++ @loc.stks st) $ ppRecordVal+                               [ nm_invoke @lhs.nt st >#< "=" >#< nm_k st ]++  loc.stargs+    = \st -> let attrs = maybe Map.empty id $ Map.lookup st @visits.intramap in ppSpaced+               [ case mbAttr of+                   Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) ->+                     case Map.lookup nm @loc.localAttrTypes of+                       Just tp -> pp_parens (strNm >#< ":" >#< ppTp tp)+                       Nothing -> pp strNm+                   Just attr | not (noPerStateTypeSigs @lhs.options) ->+                     case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @loc.childTypes of+                       Just tpDoc -> pp_parens (strNm >#< ":" >#< tpDoc)+                       Nothing    -> pp strNm+                   _ -> pp strNm+               | (strNm, mbAttr) <- Map.assocs attrs+               ] >#< dummyPat @lhs.options (Map.null attrs)++  -- produces the "k" function that inspect the caller argument to dispatch a visit+  loc.stvisits = \st -> filter (\(_,f,_) -> f == st) @visits.allvisits+  loc.stks+    = \st -> let stvisits = @loc.stvisits st+                 def = ppFunDecl False {- @loc.o_sigs -} (pp $ nm_k st)+                         [(pp "arg", @loc.t_c_params >#< type_caller @lhs.nt st)] (pp cont_tvar) body++                 nextVisitInfo = Map.findWithDefault ManyVis st @lhs.nextVisits+                 body = case nextVisitInfo of+                   NoneVis  -> text "?no next visit?"+                   OneVis v -> dispatch "arg" v+                   ManyVis  -> let alt (v,_,_) = "|" >#< con_visit @lhs.nt v >#< "chosen" >#< "->" >-< indent 2 (dispatch "chosen" v)+                               in "match arg with" >-< (indent 2 $ vlist $ map alt stvisits)++                 dispatch nm v = "let" >#< ppRecordVal+                                   [ nm_inh @lhs.nt v >#< "=" >#< "inp"+                                   , nm_cont @lhs.nt v >#< "=" >#< "cont" ]+                                 >#< "=" >#< pp nm+                                 >-< "in" >#< "cont" >#< pp_parens (nm_visit v >#< "inp") -- call cont with res of visit++             in if null stvisits+                then []+                else [ "(* k-function for production" >#< @con >#< " *)" >-< def ]++  loc.stvs = \st -> [ppf | (f,ppf) <- @visits.sem_visit, f == st]+  visits.mrules = @rules.mrules++{+nm_visit v = "__v" >|< v+nm_k st = "__k" >|< st+nm_st st = "__st" >|< st++mklets :: (PP b, PP c) => [b] -> c -> PP_Doc+mklets defs body = res where+  ppLet def = "let" >#< def >#< "in"+  res = vlist (map ppLet defs) >-< body+}++-------------------------------------------------------------------------------+--  Visit semantic functions+-------------------------------------------------------------------------------+ATTR Visit  [ | | sem_visit              : {  (StateIdentifier,PP_Doc)  } ]+ATTR Visits [ | | sem_visit USE {:} {[]} : { [(StateIdentifier,PP_Doc)] } ]++SEM Visit | Visit+  loc.o_sigs = typeSigs @lhs.options+  lhs.sem_visit = ( @from+                  , let resTp = @loc.t_params >#< @loc.nameTOut_visit+                        argTp = @loc.t_params >#< @loc.nameTIn_visit+                        argMatch = ppRecordVal [ nm_inarg i @lhs.nt @ident >#< "=" >#< lhsname @lhs.options True i | i <- Set.toList @inh ]+                    in ppFunDecl @loc.o_sigs (nm_visit @ident) [(argMatch, argTp)] resTp @steps.sem_steps+                  )++  steps.follow   = @loc.nextStBuild >-< @loc.resultval++  loc.nextArgsMp = maybe Map.empty id $ Map.lookup @to @lhs.allintramap+  loc.nextArgs   = ppSpaced $ Map.keys $ @loc.nextArgsMp+  loc.nextStExp  = nm_st @to >#< @loc.nextArgs >#< dummyArg @lhs.options (Map.null @loc.nextArgsMp)++  loc.resultval = ppRecordVal+                    (  [ nm_outarg i @lhs.nt @ident >#< "=" >#< lhsname @lhs.options False i | i <- Set.toList @syn ]+                    ++ [ @loc.nextStRefExp ])++  (loc.nextStBuild, loc.nextStRefExp)+     = case @loc.nextVisitInfo of+         NoneVis  -> (empty, empty)+         _        -> ( "let" >#< nextStName >#< "=" >#< @loc.nextStExp >#< "in"+                     , nm_outarg_cont @lhs.nt @ident >#< "=" >#< nextStName)++{+resultValName :: String+resultValName = "__result_"++nextStName :: String+nextStName = "__st_"+}++-- Propagate the visit kind to the steps+ATTR VisitStep VisitSteps [ kind : VisitKind | | ]+SEM Visit | Visit  steps.kind = @kind++-- the steps in this group should be executed in a pure fashion+SEM VisitStep | PureGroup+  steps.kind = VisitPure @ordered++-- follow: the code of steps that follows after the VisitStep+ATTR Visits Visit VisitStep VisitSteps [  mrules : {Map Identifier (VisitKind ->  Either Error PP_Doc)} | | ]+ATTR VisitStep VisitSteps [ follow : PP_Doc | | sem_steps USE {>-<} {empty} : PP_Doc ]++-- continuation flow (passing the right steps as left follow steps)+SEM VisitSteps+  | Cons  hd.follow     = @tl.sem_steps+          lhs.sem_steps = @hd.sem_steps+  | Nil   lhs.sem_steps = @lhs.follow++SEM VisitStep+  | Sem        loc.ruleItf = Map.findWithDefault (error $ "Rule "  ++ show @name  ++ " not found") @name @lhs.mrules+               (lhs.errors, loc.sem_steps) = case @loc.ruleItf @lhs.kind of+                                               Left e     -> (Seq.singleton e, empty)+                                               Right stmt -> (Seq.empty, stmt)+               lhs.sem_steps = @loc.sem_steps >-< @lhs.follow+  | ChildIntro loc.attachItf = Map.findWithDefault (error $ "Child " ++ show @child ++ " not found") @child @lhs.childintros+               (lhs.errors,loc.sem_steps,lhs.defs,lhs.uses)+                 = case @loc.attachItf @lhs.kind of+                     Left e                   -> (Seq.singleton e, empty, Set.empty, Map.empty)+                     Right (code, defs, uses) -> (Seq.empty, code, defs, uses)+               lhs.sem_steps = @loc.sem_steps >-< @lhs.follow+  | ChildVisit loc.visitItf = Map.findWithDefault (error $ "Visit " ++ show @visit ++ " not found") @visit @lhs.allchildvisit+               loc.childType = Map.findWithDefault (error ("type of child " ++ show @child ++ " is not in the childTypes map! " ++ show @lhs.childTypes)) @child @lhs.childTypes+               (lhs.errors, lhs.sem_steps) = case @loc.visitItf @child @loc.childType @lhs.kind @lhs.follow of+                                               Left e      -> (Seq.singleton e, empty)+                                               Right steps -> (Seq.empty, steps)+  | Sim        -- simply propagates+  | PureGroup  -- simply propagates++--+-- Some properties of VisitStep(s)+--++-- Number of steps in a 'Sim' block+ATTR VisitSteps [ | | size : Int ]+SEM VisitSteps+  | Nil  lhs.size = 0+  | Cons lhs.size = 1 + @tl.size++-- Number the steps in a 'Sim' block+ATTR VisitSteps VisitStep [ | index : Int | ]+SEM VisitSteps | Cons+  hd.index  = @lhs.index  -- copy rule+  tl.index  = 1 + @lhs.index+  lhs.index = @tl.index   -- copy rule+SEM Visit | Visit    steps.index = 0+SEM VisitStep | Sim  steps.index = 0+                     lhs.index   = @lhs.index  -- needed for if we ever allow nested Sims++-- Biggest number of steps in previous blocks that used parallel invocation+-- This number - 1 (minimum 0) is the number of references for parallel invocation created+ATTR VisitSteps VisitStep [ | prevMaxSimRefs : Int | ]+SEM Visit | Visit    steps.prevMaxSimRefs = 0+SEM VisitStep | Sim+  lhs.prevMaxSimRefs = if @loc.useParallel+                       then @lhs.prevMaxSimRefs `max` (@steps.index - 1)  -- possibly new references made+                       else @lhs.prevMaxSimRefs                           -- no references created++-- Is this the last step?+ATTR VisitSteps VisitStep [ | | isLast : Bool ]+ATTR VisitStep [ isLast : Bool | | ]+SEM VisitSteps+  | Nil   lhs.isLast = True+  | Cons  lhs.isLast = False+          hd.isLast  = @tl.isLast++-- Use parallel invocation: only when option enabled and there is more than one visit to a child+-- Todo: implement a parallel evaluator+SEM VisitSteps VisitStep [ useParallel : Bool | | ]+SEM Visit | Visit    steps.useParallel = False+SEM VisitStep | Sim  loc.useParallel = parallelInvoke @lhs.options && @steps.size > 1++-- Child introduction+ATTR EChild EChildren+  [ | | childintros USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} ]++ATTR Visits Visit VisitSteps VisitStep+  [ childintros : {Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} | | ]++SEM EProduction | EProduction+  visits.childintros = @children.childintros++SEM EChild+  | ETerm  lhs.childintros = Map.singleton @name (\_ -> Right (empty, Set.empty, Map.empty))+  | EChild lhs.childintros = Map.singleton @name @loc.introcode+           loc.isDefor     = case @tp of+                               NT _ _ defor -> defor+                               _            -> False+           loc.valcode     = case @kind of+                               ChildSyntax -> @name >|< "_"+                               ChildAttr   -> -- decide if we need to invoke the sem-function under the hood+                                              let head | not @loc.isDefor = if lateHigherOrderBinding @lhs.options+                                                                            then lateSemNtLabel @loc.nt >#< lhsname @lhs.options True idLateBindingAttr+                                                                            else prefix @lhs.options >|< @loc.nt+                                                       | otherwise        = empty -- no need to intro a terminal+                                              in pp_parens (head >#< instname @name)+                               ChildReplace _ -> -- the higher-order attribute is actually a function that transforms+                                                 -- the semantics of the child (always deforested)+                                                 pp_parens (instname @name >#< @name >|< "_")+           loc.aroundcode  = if @hasAround+                             then locname @lhs.options @name >|< "_around"+                             else empty+           loc.introcode   = \kind -> let pat    = text $ stname @name @loc.initSt+                                          attach = pp_parens (@loc.aroundcode >#< @loc.valcode) >|< "." >|< nm_attach @loc.nt >#< "()"+                                          decl   = pat >#< "=" >#< attach+                                      in if compatibleAttach kind @loc.nt @lhs.options+                                         then Right ( "let" >#< decl >#< "in"+                                                    , Set.singleton (stname @name @loc.initSt)  -- variables defined by the child intro+                                                    , case @kind of  -- variables used by the child introduction+                                                        ChildAttr   -> Map.insert (instname @name) Nothing $  -- the sem attr+                                                                         ( if @loc.isDefor || not (lateHigherOrderBinding @lhs.options)+                                                                           then id   -- the sem dictionary attr is not used+                                                                           else Map.insert (lhsname @lhs.options True idLateBindingAttr) (Just $ AttrInh _LHS idLateBindingAttr)+                                                                         ) $+                                                                         ( if @hasAround+                                                                           then Map.insert (locname @lhs.options (@name) ++ "_around") Nothing+                                                                           else id+                                                                         ) $ Map.empty+                                                        ChildReplace _ -> Map.singleton (instname @name) Nothing   -- uses the transformation function+                                                        ChildSyntax    -> Map.empty+                                                    )+                                         else Left $ IncompatibleAttachKind @name kind+           loc.nt = extractNonterminal @tp++{+stname :: Identifier -> Int -> String+stname child st = "_" ++ getName child ++ "X" ++ show st++-- should actually return some conversion info+compatibleAttach :: VisitKind -> NontermIdent -> Options -> Bool+compatibleAttach _ _ _ = True+}++-- rules+ATTR ERules ERule [ | | sem_rules USE {>-<} {empty} : {PP_Doc}+                        mrules USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> Either Error PP_Doc)} ]++SEM ERule | ERule+     lhs.sem_rules    = if @loc.used == 0+                        then empty+                        else @loc.rulecode+     loc.rulecode     = ( if @loc.genpragma+                          then @loc.pragma  -- this additional pragma *may* help to give some AG source location in the presence of+                                            -- type errors in the rule. It will definitely not be precise, and may take some additional+                                            -- source space, but let's see if it's worth it in practice.+                          else empty+                        )+                        >-< @loc.declHead+                        >-< indent ((column @rhs.pos - 2) `max` 2)+                              ( if @loc.genpragma+                                then @loc.pragma >-< @rhs.semfunc >-< @loc.endpragma+                                else @rhs.semfunc+                              )+                        >#< "in"+      loc.pragma       = ppLinePragma @lhs.options (line @rhs.pos) (file @rhs.pos)+      loc.endpragma    = ppWithLineNr (\ln -> ppLinePragma @lhs.options (ln+1) @lhs.mainFile)+      loc.genpragma    = genLinePragmas @lhs.options && @explicit && @loc.haspos+      loc.haspos       = line @rhs.pos > 0 && column @rhs.pos >= 0 && not (null (file @rhs.pos))++        -- Note: we also ensure that all rules are functions, so that they are not made part of any closures+        -- but are lambda-lifted instead.+      loc.declHead = "let" >#< @name >#< @loc.argPats >#< dummyPat @lhs.options (Map.null @rhs.attrs) >#< "="+      loc.argPats+        = ppSpaced+            [ case mbAttr of+                Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) ->+                  case Map.lookup nm @lhs.localAttrTypes of+                    Just tp -> pp_parens (strNm >#< ":" >#< ppTp tp)+                    Nothing -> pp strNm+                Just attr | not (noPerStateTypeSigs @lhs.options) ->+                  case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @lhs.childTypes of+                    Just tpDoc -> pp_parens (strNm >#< ":" >#< tpDoc)+                    Nothing    -> pp strNm+                _ -> pp strNm+            | (strNm, mbAttr) <- Map.assocs @rhs.attrs+            ]++      loc.argExprs = ppSpaced $ Map.keys @rhs.attrs+      loc.stepcode = \kind ->+                       let mkBind (pat,expr) = "let" >#< pat >#< "=" >#< expr >#< "in"+                       in if kind `compatibleRule` @pure+                          then Right $ mkBind (@pattern.sem_lhs, @name >#< @loc.argExprs >#< dummyArg @lhs.options (Map.null @rhs.attrs))+                                       >-< vlist (map mkBind @pattern.extraDefs)+                          else Left $ IncompatibleRuleKind @name kind++      lhs.mrules   = Map.singleton @name @loc.stepcode++ATTR Expression [ | | tks : {[HsToken]} ]+SEM Expression+  | Expression lhs.tks = @tks++{+dummyPat :: Options -> Bool -> PP_Doc+dummyPat opts noArgs+  | not noArgs            = empty+  | strictDummyToken opts = text "()"+  | otherwise             = text "(_ : unit)"++dummyArg :: Options -> Bool -> PP_Doc+dummyArg opts noArgs+  | not noArgs            = empty+  | otherwise             = text "()"++dummyType :: Options -> Bool -> PP_Doc+dummyType opts noArgs+  | not noArgs            = empty+  | otherwise             = text "unit"+}++ATTR Expression [ | | pos : {Pos} ]+SEM Expression | Expression lhs.pos = @pos++-- pattern and expression semantics+ATTR Pattern  [ | | sem_lhs              : { PP_Doc } ]+ATTR Patterns [ | | sem_lhs USE {:} {[]} : {[PP_Doc]} ]+ATTR Pattern Patterns [ | | extraDefs USE {++} {[]} : {[(PP_Doc,PP_Doc)]} ]++SEM Pattern+  | Alias       loc.var       = text $ attrname @lhs.options False @field @attr+                loc.hasTp     = isJust @loc.mbTp+                loc.o_sigs    = typeSigs @lhs.options++                lhs.sem_lhs   = ppArg (@loc.hasTp && @loc.o_sigs) @loc.var (maybe (text "?no type?") ppTp @loc.mbTp)+                lhs.extraDefs = if @pat.isUnderscore+                                then []+                                else [ (@pat.sem_lhs, @loc.var) ]+  | Product     lhs.sem_lhs   = pp_block "(" ")" "," @pats.sem_lhs+  | Constr      lhs.sem_lhs   = pp_parens $ @name >#< pp_block "(" ")" "," @pats.sem_lhs+  | Underscore  lhs.sem_lhs   = text "_"+  | Irrefutable lhs.sem_lhs   = pp_parens (text "lazy" >#< @pat.sem_lhs)+      -- note that the above has the inverse meaning compared to Haskell:+      -- the above forces the evaluation of a lazy value. It seems appropriate though.++-- Check if a pattern is just an underscore+ATTR Pattern [ | | isUnderscore:{Bool}]+SEM Pattern+ | Constr      lhs.isUnderscore = False+ | Product     lhs.isUnderscore = False+ | Alias       lhs.isUnderscore = False+ | Underscore  lhs.isUnderscore = True++-- Collect the attributes defined by a pattern+ATTR Pattern Patterns  [ | | attrs USE {`Set.union`} {Set.empty} : {Set String} ]+SEM Pattern | Alias+  lhs.attrs     = Set.insert (attrname @lhs.options False @field @attr) @pat.attrs++-- All attribute types of this pattern+-- Todo: if possible, make attribute types part of the pattern+ATTR Pattern Patterns  [ | | attrTypes USE {>-<} {empty} : {PP_Doc} ]+SEM Pattern | Alias+  loc.mbTp      = if @field == _LHS+                  then Map.lookup @attr @lhs.synmap+                  else if @field == _LOC+                       then Map.lookup @attr @lhs.localAttrTypes+                       else Nothing+  lhs.attrTypes = maybe empty (\tp -> (attrname @lhs.options False @field @attr) >#< "::" >#< ppTp tp) @loc.mbTp+                  >-< @pat.attrTypes++-- Collect the attributes used by the right-hand side+ATTR HsToken Expression [ | | attrs USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ]+SEM HsToken+  | AGLocal   lhs.attrs   = Map.singleton (fieldname @var) Nothing+  | AGField   loc.mbAttr  = if @field == _INST || @field == _FIELD || @field == _INST'+                            then Nothing  -- should not be used in the first place+                            else Just $ mkNonLocalAttr (@field == _LHS) @field @attr+              lhs.attrs   = Map.singleton (attrname @lhs.options True @field @attr) @loc.mbAttr++{+data NonLocalAttr+  = AttrInh Identifier Identifier+  | AttrSyn Identifier Identifier deriving Show++mkNonLocalAttr :: Bool -> Identifier -> Identifier -> NonLocalAttr+mkNonLocalAttr True  = AttrInh  -- True: inherited attr+mkNonLocalAttr False = AttrSyn++lookupAttrType :: NonLocalAttr -> Map Identifier Attributes -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc+lookupAttrType (AttrInh child name) inhs _ = lookupType child name inhs+lookupAttrType (AttrSyn child name) _ syns = lookupType child name syns++-- Note: if the child takes type parameters, the type of an attribute of this child may refer to these parameters. This means that+-- the actual type of the attribute needs to have its type parameters substituted with the actual type argument of the child.+-- However, for now we simply decide to return Nothing in this case, which skips the type annotation.+lookupType :: Identifier -> Identifier -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc+lookupType child name attrMp childMp+  | noParameters childTp = Just ppDoc+  | otherwise            = Nothing+  where+    attrTp     = Map.findWithDefault (error "lookupType: the attribute is not in the attrs of the child") name childAttrs+    childAttrs = Map.findWithDefault (error "lookupType: the attributes of the nonterm are not in the map") nonterm attrMp+    nonterm    = extractNonterminal childTp+    childTp    = Map.findWithDefault (error ("lookupType: the child " ++ show child ++ "is not in the appropriate map")) child childMp+    ppDoc      = ppTp attrTp++noParameters :: Type -> Bool+noParameters (Haskell _)   = True+noParameters (NT _ args _) = null args+}++ATTR Expression [ | | semfunc : {PP_Doc} ]++SEM Expression+  | Expression lhs.attrs   = Map.unions $ map (\tok -> attrs_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks+               lhs.semfunc = vlist $ showTokens $ map (\tok -> tok_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks+               loc.inhhstoken = Inh_HsToken @lhs.options++-- child visit map+ATTR Visit+     Visits+     EProduction+     EProductions+     ENonterminal+     ENonterminals [ allchildvisit : {Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)}+                     | | childvisit USE {`Map.union`} {Map.empty} : {Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)} ]++ATTR VisitSteps VisitStep [ allchildvisit : {Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)} | | ]++SEM ExecutionPlan+  | ExecutionPlan nonts.allchildvisit = @nonts.childvisit++-- code for the invocation of the visit:+--   * "follow" is the pretty print of the code that follows this step, and is thus the code that comprises the continuation.+--   * the child state contain a field which is the operation to invoke+--   * we create a parameter with the inputs to the visit and the continuation+--   * the continuation obtains the resulting outputs plus the updated state+SEM Visit | Visit+  loc.prevVisitInfo = Map.findWithDefault ManyVis @from @lhs.nextVisits+  lhs.childvisit = Map.singleton @ident @loc.invokecode+  loc.invokecode+    = \chld childTp kind follow ->   -- "chld" is the name of the child at the place of invocation, and "kind" the kind of the calling visit+        let code = cont >-< inps >-< call++            childNmTo   = text $ stname chld @to+            childNmFrom = text $ stname chld @from+            childTpArgs = case childTp of+                            NT _ args _ -> args+                            _           -> error "generate visit call: type of the child is not a nonterminal!"++            -- cont is parameterized with the outputs of the child and brings them in scope+            cont = "let" >#< contNm >#< ppArg @loc.o_sigs (ppRecordVal cont_in) cont_in_tp >#< "="+                   >-< indent 2 follow  -- the continuation-code+                   >#< "in"+            cont_in = [ nm_outarg i @lhs.nt @ident >#< "=" >#< attrname @lhs.options True chld i | i <- Set.toList @syn ]+                      ++ case @loc.nextVisitInfo of+                           NoneVis -> []+                           _       -> [ nm_outarg_cont @lhs.nt @ident >#< "=" >#< childNmTo ]+            cont_in_tp = ppTypeParams childTpArgs >#< @loc.nameTOut_visit++            -- defines the input records to the visit function+            inps = "let" >#< inpsNm >#< "=" >#< ppRecordVal+                     [ nm_inh @lhs.nt @ident >#< "=" >#< ppRecordVal inps_in+                     , nm_cont @lhs.nt @ident >#< "=" >#< contNm+                     ] >#< "in"+            inps_in = [ nm_inarg i @lhs.nt @ident >#< "=" >#< attrname @lhs.options False chld i | i <- Set.toList @inh ]++            -- the call to the visit function, with possible the need to specify which visit function to dispatch to+            call = childNmFrom >|< "." >|< nm_invoke @lhs.nt @from >#< arg+            arg = case @loc.prevVisitInfo of+                    NoneVis  -> error "error: invocation of a visit from a state that has no next visits"+                    OneVis _ -> pp inpsNm+                    ManyVis  -> pp_parens (con_visit @lhs.nt @ident >#< inpsNm)+        in if kind `compatibleKind` @kind+           then Right code+           else Left $ IncompatibleVisitKind chld @ident kind @kind++{+contNm = text "__cont_"+inpsNm = text "__inps_"++-- a `compatibleKind` b  means: can kind b be invoked from a+compatibleKind :: VisitKind -> VisitKind -> Bool+compatibleKind _              _             = True++compatibleRule :: VisitKind -> Bool -> Bool+compatibleRule (VisitPure _) False = False+compatibleRule _             _     = True+}++-------------------------------------------------------------------------------+--  Properties of rules+-------------------------------------------------------------------------------++-- Construct an environment that counts how often certain rules are used+ATTR Visits Visit VisitSteps VisitStep [ | | ruleUsage USE {`unionWithSum`} {Map.empty} : {Map Identifier Int} ]+ATTR ERules ERule [ usageInfo : {Map Identifier Int} | | ]++SEM EProduction | EProduction  rules.usageInfo = @visits.ruleUsage+SEM VisitStep | Sem            lhs.ruleUsage = Map.singleton @name 1+SEM ERule | ERule              loc.used      = Map.findWithDefault 0 @name @lhs.usageInfo++{+unionWithSum = Map.unionWith (+)+}++-- Collect in what visit-kinds a rule is used+ATTR Visits Visit VisitSteps VisitStep [ | | ruleKinds USE {`unionWithMappend`} {Map.empty} : {Map Identifier (Set VisitKind)} ]+SEM VisitStep | Sem+  lhs.ruleKinds = Map.singleton @name (Set.singleton @lhs.kind)++ATTR ERules ERule [ ruleKinds : {Map Identifier (Set VisitKind)} | | ]+SEM EProduction | EProduction+  rules.ruleKinds = @visits.ruleKinds++SEM ERule | ERule+  loc.kinds = Map.findWithDefault Set.empty @name @lhs.ruleKinds+  loc.anyLazyKind = Set.fold (\k r -> isLazyKind k || r) False @loc.kinds++ATTR Pattern Patterns [ anyLazyKind : Bool | | ]+++-------------------------------------------------------------------------------+--  Intra attributes+-------------------------------------------------------------------------------+{+uwSetUnion :: (Ord a, Ord b) => Map a (Set b) -> Map a (Set b) -> Map a (Set b)+uwSetUnion = Map.unionWith Set.union++uwMapUnion :: (Ord a, Ord b) => Map a (Map b c) -> Map a (Map b c) -> Map a (Map b c)+uwMapUnion = Map.unionWith Map.union+}+ATTR Visit Visits [ allintramap : {Map StateIdentifier (Map String (Maybe NonLocalAttr))}+                    | | intramap USE {`uwMapUnion`} {Map.empty} : {Map StateIdentifier (Map String (Maybe NonLocalAttr))} ]++ATTR Visit Visits [ terminaldefs : {Set String} | | ]+ATTR EChild EChildren [ | | terminaldefs USE {`Set.union`} {Set.empty} : {Set String} ]++SEM EChild | ETerm+  lhs.terminaldefs = Set.singleton $ fieldname @name++SEM EProduction | EProduction+  visits.allintramap  = @visits.intramap+  visits.terminaldefs = @children.terminaldefs++SEM Visit+  | Visit loc.thisintra = (@loc.uses `Map.union` @loc.nextintra) `Map.difference` @loc.defsAsMap+          lhs.intramap  = Map.singleton @from @loc.thisintra+          loc.nextintra = maybe Map.empty id $ Map.lookup @to @lhs.allintramap+          loc.uses      = let mp1 = @steps.uses+                              mp2 = Map.fromList [ (lhsname @lhs.options False i, Just (AttrSyn _LHS i)) | i <- Set.elems @syn ]+                          in mp1 `Map.union` mp2+          loc.inhVarNms = Set.map (lhsname @lhs.options True) @inh+          loc.defs      = @steps.defs `Set.union` @loc.inhVarNms `Set.union` @lhs.terminaldefs+          loc.defsAsMap = Map.fromList [ (a, Nothing) | a <- Set.elems @loc.defs ]++ATTR ERule ERules [ | | ruledefs USE {`uwSetUnion`} {Map.empty} : {Map Identifier (Set String)}+                        ruleuses USE {`uwMapUnion`} {Map.empty} : {Map Identifier (Map String (Maybe NonLocalAttr))} ]+ATTR Visit Visits+     VisitSteps VisitStep [ ruledefs  : {Map Identifier (Set String)}+                            ruleuses  : {Map Identifier (Map String (Maybe NonLocalAttr))} | | ]++SEM ERule+  | ERule lhs.ruledefs = Map.singleton @name @pattern.attrs+          lhs.ruleuses = Map.singleton @name @rhs.attrs++SEM EProduction+  | EProduction visits.ruledefs = @rules.ruledefs+                visits.ruleuses = @rules.ruleuses++ATTR Visit Visits+     EProduction+     EProductions+     ENonterminal+     ENonterminals [ | | visitdefs USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (Set Identifier)}+                         visituses USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (Set Identifier)} ]++SEM Visit+  | Visit lhs.visitdefs = Map.singleton @ident @syn+          lhs.visituses = Map.singleton @ident @inh++ATTR Visit Visits+     VisitSteps VisitStep+     EProduction EProductions+     ENonterminal ENonterminals [ avisitdefs : {Map VisitIdentifier (Set Identifier)}+                                  avisituses : {Map VisitIdentifier (Set Identifier)} | | ]++SEM ExecutionPlan+  | ExecutionPlan nonts.avisitdefs = @nonts.visitdefs+                  nonts.avisituses = @nonts.visituses++ATTR VisitSteps VisitStep [ | | defs USE {`Set.union`} {Set.empty} : {Set String}+                                uses USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ]+SEM VisitStep+  | Sem        lhs.defs = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruledefs+               lhs.uses = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruleuses+  | ChildVisit lhs.defs = Set.insert (stname @child @to) $ maybe (error "Visit not found") (Set.map $ attrname @lhs.options True @child) $ Map.lookup @visit @lhs.avisitdefs+               lhs.uses = let convert attrs = Map.fromList [ (attrname @lhs.options False @child attr, Just $ mkNonLocalAttr True @child attr) | attr <- Set.elems attrs ]+                          in Map.insert (stname @child @from) Nothing $ convert $+                               maybe (error "Visit not found") id $ Map.lookup @visit @lhs.avisituses++-------------------------------------------------------------------------------+--  Identification of lazy intra defs within a production+--+-- These identifiers will not be marked as strict in rules and state closures+-------------------------------------------------------------------------------++ATTR Visits Visit VisitSteps VisitStep [ | | lazyIntras USE {`Set.union`} {Set.empty} : {Set String} ]+ATTR ERules ERule [ lazyIntras : {Set String} | | ]++SEM Visit | Visit+  loc.lazyIntrasInh = case @kind of+                        VisitPure False -> @loc.inhVarNms `Set.union` @steps.defs+                        _               -> Set.empty+  lhs.lazyIntras = @loc.lazyIntrasInh `Set.union` @steps.lazyIntras++SEM VisitStep | PureGroup+  lhs.lazyIntras = if @ordered+                   then @steps.lazyIntras+                   else @steps.defs++SEM EProduction | EProduction+  loc.lazyIntras = @visits.lazyIntras++-------------------------------------------------------------------------------+--  Pretty printing of haskell code+-------------------------------------------------------------------------------++-- note: this function produces strings, which are passed to showTokens which+-- preserves layout.+-- note: this may not be that important for ocaml code in comparison to Haskell+SEM HsTokens [ || tks : {[(Pos,String)]} ]+  | Cons lhs.tks = @hd.tok : @tl.tks+  | Nil  lhs.tks = []++SEM HsToken+  | AGLocal   loc.tok = (@pos,fieldname @var)++SEM HsToken [ || tok:{(Pos,String)}]+   | AGField+       loc.addTrace = case @rdesc of+                        Just d  -> \x -> "(prerr_endline " ++ show (d ++ " -> " ++ show @field ++ "." ++ show @attr) ++ "; " ++ x ++ ")"+                        Nothing -> id+       lhs.tok = (@pos, @loc.addTrace $ attrname @lhs.options True @field @attr)++   | HsToken lhs.tok = (@pos, @value)++   | CharToken lhs.tok = (@pos, if null @value+                                   then ""+                                   else showCharShort (head @value)+                         )++   | StrToken  lhs.tok = (@pos, showStrShort @value)+   | Err       lhs.tok = (@pos, "")++--+-- Distribute single-visit-next map downward+--++ATTR EProductions EProduction Visits Visit+  [ prevVisits, nextVisits : {Map StateIdentifier StateCtx} | | ]++SEM ENonterminal | ENonterminal+  prods.nextVisits = @nextVisits+  prods.prevVisits = @prevVisits++--+-- Collect and distribute the from/to states of a visit+--++ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit+  [ | | fromToStates USE {`mappend`} {mempty} : {Map VisitIdentifier (Int,Int)} ]++ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep+  [ allFromToStates : {Map VisitIdentifier (Int,Int)} | | ]++SEM Visit | Visit+  lhs.fromToStates = Map.singleton @ident (@from, @to)++SEM ExecutionPlan | ExecutionPlan+  nonts.allFromToStates = @nonts.fromToStates++SEM VisitStep | ChildVisit+  (loc.from, loc.to) = Map.findWithDefault (error "visit not in allFromToStates") @visit @lhs.allFromToStates+++--+-- Collect and distribute the actual types of children of productions+--++ATTR EChildren EChild [ | | childTypes USE {`mappend`} {mempty} : {Map Identifier Type} ]+ATTR ERules ERule Visits Visit VisitSteps VisitStep [ childTypes : {Map Identifier Type} | | ]++SEM EProduction | EProduction+  loc.childTypes = Map.singleton _LHS @lhs.ntType `Map.union` @children.childTypes++SEM EChild | EChild ETerm+  lhs.childTypes = Map.singleton @name @tp++--+-- Distribute types of local attributes+--++ATTR ExecutionPlan ENonterminals ENonterminal  [ localAttrTypes : {Map NontermIdent (Map ConstructorIdent (Map Identifier Type))} | | ]+ATTR EProductions EProduction                  [ localAttrTypes : {Map ConstructorIdent (Map Identifier Type)} | | ]+ATTR ERules ERule Pattern Patterns             [ localAttrTypes : {Map Identifier Type} | | ]++SEM ENonterminal | ENonterminal+  prods.localAttrTypes = Map.findWithDefault Map.empty @nt @lhs.localAttrTypes++SEM EProduction | EProduction+  loc.localAttrTypes   = Map.findWithDefault Map.empty @con @lhs.localAttrTypes++--+-- Collect and distribute visit kinds+--++ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep+  [ allVisitKinds : {Map VisitIdentifier VisitKind} | | visitKinds USE {`mappend`} {mempty} : {Map VisitIdentifier VisitKind} ]++SEM Visit | Visit+  lhs.visitKinds = Map.singleton @ident @kind++SEM ExecutionPlan | ExecutionPlan+  nonts.allVisitKinds = @nonts.visitKinds++--+-- Collect and distribute the initial state of nonterminals+--++ATTR ENonterminals ENonterminal [ | | initStates USE {`mappend`} {mempty} : {Map NontermIdent Int} ]+ATTR ENonterminals ENonterminal EProductions EProduction EChildren EChild Visits Visit VisitSteps VisitStep+  [ allInitStates : {Map NontermIdent Int} | | ]++SEM ENonterminal | ENonterminal+  lhs.initStates = Map.singleton @nt @initial++SEM ExecutionPlan | ExecutionPlan+  nonts.allInitStates = @nonts.initStates++SEM EChild | EChild+  loc.initSt = Map.findWithDefault (error "nonterminal not in allInitStates map") @loc.nt @lhs.allInitStates++--+-- Push the nonterminal type downward+--++ATTR EProductions EProduction [ ntType : Type | | ]+SEM ENonterminal | ENonterminal+  loc.ntType = NT @nt (map show @params) False++--+-- Collect errors contained in rules that should be yielded when the+-- rules are scheduled.+--++ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule Visits Visit VisitSteps VisitStep [ | | errors USE {Seq.><} {Seq.empty} : {Seq Error} ]+SEM ERule | ERule+  lhs.errors = case @mbError of+                 Just e | @loc.used > 0 -> Seq.singleton e+                 _                      -> Seq.empty
src-ag/ExecutionPlan2Clean.ag view
@@ -1,1684 +1,1684 @@-INCLUDE "ExecutionPlan.ag"
-INCLUDE "Patterns.ag"
-INCLUDE "Expression.ag"
-INCLUDE "HsToken.ag"
-
-imports
-{
-import ExecutionPlan
-import Pretty
-import PPUtil
-import Options
-import Data.Monoid(mappend,mempty)
-import Data.Maybe
-import Debug.Trace
-import System.IO
-import System.Directory
-import System.FilePath
-import UU.Scanner.Position
-
-import TokenDef
-import HsToken
-import ErrorMessages
-
-import Data.Set (Set)
-import qualified Data.Set as Set
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Data.Sequence(Seq)
-import qualified Data.Sequence as Seq
-import Data.Foldable(toList)
-}
-
-ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule EChildren EChild
-  [ importBlocks       : PP_Doc
-    textBlocks         : PP_Doc
-    iclModuleHeader    : {String -> String -> String -> Bool -> String}
-    dclModuleHeader    : {String -> String -> String -> Bool -> String}
-    mainFile           : String
-    mainName           : String
-    constructorTypeMap : {Map NontermIdent ConstructorType} | | ]
-
--------------------------------------------------------------------------------
---  Options
--------------------------------------------------------------------------------
-ATTR ExecutionPlan
-     ENonterminals ENonterminal
-     EProductions EProduction
-     ERules ERule
-     EChildren EChild
-     Expression
-     HsToken HsTokens HsTokensRoot
-     Pattern Patterns
-     Visits Visit
-     VisitSteps VisitStep [ options : {Options} | | ]
-ATTR EProductions EProduction [ rename : {Bool} | | ]
-
-SEM ENonterminal
-  | ENonterminal prods.rename = rename @lhs.options
-
--------------------------------------------------------------------------------
---  Context info (nonterminal ident, constructor ident, nonterm params, etc.)
--------------------------------------------------------------------------------
-
-ATTR Visit Visits EProduction EProductions EChildren EChild ERules ERule [ nt : NontermIdent | | ]
-SEM ENonterminal
-  | ENonterminal prods.nt = @nt
-
-ATTR EChildren EChild ERules ERule Visits Visit
-  [ con : ConstructorIdent | | ]
-
-SEM EProduction
-  | EProduction children.con = @con
-                rules.con    = @con
-                visits.con   = @con
-
-ATTR EProductions EProduction Visits Visit [ params : {[Identifier]} | | ]
-SEM ENonterminal | ENonterminal
-  prods.params = @params
-
-ATTR EProductions EProduction [ classCtxs : ClassContext | | ]
-SEM ENonterminal | ENonterminal
-  prods.classCtxs = @classCtxs
-
--------------------------------------------------------------------------------
---  Default output
--------------------------------------------------------------------------------
-ATTR ExecutionPlan [  | | output : {PP_Doc}
-                          output_dcl : {PP_Doc} ]
-
-SEM ExecutionPlan
-  | ExecutionPlan lhs.output = @nonts.output >-< @loc.commonExtra >-< @loc.wrappersExtra
-                  lhs.output_dcl = @nonts.output_dcl
-
-ATTR ENonterminal ENonterminals [ wrappers : {Set NontermIdent}
-                                 | | output USE {>-<} {empty} : {PP_Doc}
-                                     output_dcl USE {>-<} {empty} : {PP_Doc}]
-
-SEM ExecutionPlan
-  | ExecutionPlan nonts.wrappers = @wrappers
-
-SEM ENonterminal
-  | ENonterminal lhs.output = ("// " ++ getName @nt ++ " " ++ replicate (60 - length (getName @nt)) '-')
-                              >-< (if @loc.hasWrapper
-                                   then "// wrapper"
-                                        >-< @loc.wr_inh_icl
-                                        >-< @loc.wr_syn_icl
-                                        >-< @loc.wrapper_icl
-                                        >-< ""
-                                   else empty)
-                              >-< (if   folds @lhs.options
-                                   then "// cata"
-                                        >-< @loc.sem_nt
-                                        >-< ""
-                                   else empty)
-                              >-< (if   semfuns @lhs.options
-                                   then "// semantic domain"
-                                        >-< @loc.t_init_icl
-                                        >-< @loc.t_states_icl
-                                        >-< @loc.k_states
-                                        >-< @prods.sem_prod
-                                        >-< ""
-                                   else empty)
-                 loc.hasWrapper = @nt `Set.member` @lhs.wrappers
-                 
-                 lhs.output_dcl = ("// " ++ getName @nt ++ " " ++ replicate (60 - length (getName @nt)) '-')
-                                  >-< (if dataTypes @lhs.options
-                                       then "// data"
-                                            >-< @loc.datatype
-                                            >-< ""
-                                       else empty)
-                                  >-< (if @loc.hasWrapper
-                                       then "// wrapper"
-                                            >-< @loc.wr_inh_dcl
-                                            >-< @loc.wr_syn_dcl
-                                            >-< @loc.wrapper_dcl
-                                            >-< ""
-                                       else empty)
-                                  >-< (if   folds @lhs.options
-                                       then "// cata"
-                                            >-< @loc.semname >#< "::" >#< @loc.sem_tp
-                                            >-< ""
-                                       else empty)
-                                  >-< (if   semfuns @lhs.options
-                                       then "// semantic domain"
-                                            >-< @loc.t_init_dcl
-                                            >-< @loc.t_states_dcl
-                                            >-< @prods.t_visits
-                                            >-< @prods.sem_prod_tys
-                                            >-< ""
-                                       else empty)
-
--------------------------------------------------------------------------------
---  Nonterminal datatype
--------------------------------------------------------------------------------
-ATTR ENonterminal ENonterminals [ typeSyns : {TypeSyns}
-                                  derivings : {Derivings} | | ]
-
-SEM ExecutionPlan
-  | ExecutionPlan nonts.typeSyns = @typeSyns
-                  nonts.derivings = @derivings
-
-SEM ENonterminal
-  | ENonterminal loc.classPP  = ppClasses $ classCtxsToDocs @classCtxs
-                 loc.aliasPre = "::" >#< @loc.classPP >#< @nt >#< @loc.t_params >#< ":=="
-                 loc.datatype = case lookup @nt @lhs.typeSyns of
-                                   Nothing -> "::" >#< @loc.classPP >#< @nt >#< @loc.t_params
-                                              >-< ( if null @prods.datatype
-                                                    then empty
-                                                    else if isRecordConstructor @nt @lhs.constructorTypeMap
-                                                           then  indent 2 $ "=" >#< @prods.recordtype
-                                                           else  indent 2 $ vlist $ ( ("=" >#< head @prods.datatype)
-                                                                                  : (map ("|" >#<) $ tail @prods.datatype))
-                                                  )
-                                              >-< indent 2 @loc.derivings
-                                   Just (List t)     -> @loc.aliasPre >#< "[" >#< show t >#< "]"
-                                   Just (Maybe t)    -> @loc.aliasPre >#< "Data.Maybe" >#< pp_parens (show t)
-                                   Just (Tuple ts)   -> @loc.aliasPre >#< pp_parens (ppCommas $ map (show . snd) ts)
-                                   Just (Either l r) -> @loc.aliasPre >#< "Data.Either" >#< pp_parens (show l) >#< pp_parens (show r)
-                                   Just (Map k v)    -> @loc.aliasPre >#< "Data.Map" >#< pp_parens (show k) >#< pp_parens (show v)
-                                   Just (IntMap t)   -> @loc.aliasPre >#< "Data.IntMap.IntMap" >#< pp_parens (show t)
-                                   Just (OrdSet t)   -> @loc.aliasPre >#< "Data.Set.Set" >#< pp_parens (show t)
-                                   Just IntSet       -> @loc.aliasPre >#< "Data.IntSet.IntSet"
---                                   Just x -> error $ "Type " ++ show x ++ " is not supported"
-                 loc.derivings = case Map.lookup @nt @lhs.derivings of
-                                    Nothing -> empty
-                                    Just s  -> if   Set.null s
-                                               then empty
-                                               else "deriving" >#< (pp_parens $ ppCommas $ map pp $ Set.toList s)
-
-{
-classCtxsToDocs :: ClassContext -> [PP_Doc]
-classCtxsToDocs = map toDoc where
-  toDoc (ident,args) = (ident >#< ppSpaced (map pp_parens args))
-
-classConstrsToDocs :: [Type] -> [PP_Doc]
-classConstrsToDocs = map ppTp
-
-ppClasses :: [PP_Doc] -> PP_Doc
-ppClasses [] = empty
-ppClasses xs = "|" >#< pp_block "" "" "&" xs
-
-ppQuants :: [Identifier] -> PP_Doc
-ppQuants [] = empty
-ppQuants ps = "E." >#< ppSpaced ps >#< ":"
-}
-
-ATTR EProduction  [ | | datatype   : {PP_Doc}
-                        recordtype : {PP_Doc} ]
-ATTR EProductions [ | | datatype USE {:} {[]} : {[PP_Doc]}
-                        recordtype            : {PP_Doc} ]
-
--- we generate the data type in the type-class style instead of the GADT style
--- the GADT extension may be required if equality constraints are used
-SEM EProduction
-  | EProduction lhs.datatype = @loc.quantPP1 >#< @loc.classPP1
-                               >#< conname @lhs.rename @lhs.nt @con
-                               >#< ppConFields (dataRecords @lhs.options) @children.datatype
-                lhs.recordtype = @loc.quantPP1 >#< @loc.classPP1
-                                 >#< ppConFields True @children.recordtype
-                loc.classPP1 = ppClasses (classConstrsToDocs @constraints)
-                loc.quantPP1 = ppQuants @params
-
-SEM EProductions
-  | Cons  lhs.recordtype = @hd.recordtype
-  | Nil   lhs.recordtype = empty
-
-{
--- first parameter indicates: generate a record or not
-ppConFields :: Bool -> [PP_Doc] -> PP_Doc
-ppConFields True  flds = ppListSep "{" "}" ", " flds
-ppConFields False flds = ppSpaced flds
-}
-
-
-ATTR EChild    [ | | datatype   : {PP_Doc}
-                     recordtype : {PP_Doc} ]
-ATTR EChildren [ | | datatype    USE {:} {[]} : {[PP_Doc]}
-                     recordtype  USE {:} {[]} : {[PP_Doc]} ]
-
--- Note: the child may be a higher-order attribute, and its semantics may be deforested
-SEM EChild
-  | EChild ETerm
-      loc.tpDoc  = @loc.addStrict $ pp_parens $ ppTp $ removeDeforested @tp
-      loc.strNm  = recordFieldname @lhs.nt @lhs.con @name
-      loc.field  = if dataRecords @lhs.options
-                   then @loc.strNm >#< "::" >#< @loc.tpDoc
-                   else @loc.tpDoc
-      loc.recordfield  = @loc.strNm >#< "::" >#< @loc.tpDoc
-      loc.addStrict = \x -> if strictData @lhs.options then "!" >|< x else x
-  | EChild  lhs.datatype = case @kind of
-                             ChildAttr -> empty  -- higher order attributes are not part of the data type
-                             _         -> @loc.field
-
-            lhs.recordtype = case @kind of
-                               ChildAttr -> empty  -- higher order attributes are not part of the data type
-                               _         -> @loc.recordfield
-  | ETerm   lhs.datatype    = @loc.field
-            lhs.recordtype  = @loc.recordfield
-
-{
-ppTp :: Type -> PP_Doc
-ppTp = text . typeToHaskellString Nothing []
-}
-
--------------------------------------------------------------------------------
---  Nonterminal semantic function
--------------------------------------------------------------------------------
-SEM ENonterminal
-  | ENonterminal loc.fsemname = \x -> "sem_" ++ show x
-                 loc.semname = @loc.fsemname @nt
-                 loc.frecarg = \t x -> case t of
-                                          NT nt _ _ -> pp_parens (@fsemname nt >#< x)
-                                          _         -> pp x
-
-                 -- The sem_NT function is lazy in the AST: it depends on the application of "child"
-                 -- rules to which extend the AST needs to be constructed.
-                 loc.sem_tp  = @loc.quantPP >#< @loc.classPP >#< @nt >#< @loc.t_params >#< "->" >#< @loc.t_type >#< @loc.t_params
-                 loc.quantPP = ppQuants @params
-                 
-                 loc.sem_nt  = @loc.semname >#< "::" >#< @loc.sem_tp
-                               >-< case lookup @nt @lhs.typeSyns of
-                                      Nothing -> @prods.sem_nt
-                                      Just (List t) -> @loc.semname >#< "list" >#< "=" >#< "foldr" >#< @loc.semname >|< "_Cons"
-                                                       >#< @loc.semname >|< "_Nil"
-                                                       >#< case t of
-                                                              NT nt _ _ -> pp_parens ("map" >#< @fsemname nt >#< "list")
-                                                              _         -> pp "list"
-                                      Just (Maybe t) -> @loc.semname >#< "'Data.Maybe'.Nothing" >#< "=" >#< @loc.semname >|< "_Nothing"
-                                                        >-< @loc.semname >#< pp_parens ("'Data.Maybe'.Just just") >#< "="
-                                                        >#< @loc.semname >|< "_Just" >#< @frecarg t "just"
-                                      Just (Tuple ts) -> @loc.semname >#< pp_parens (ppCommas $ map fst ts) >#< "="
-                                                         >#< @loc.semname >|< "_Tuple" >#< ppSpaced (map (\t -> @frecarg (snd t) (show $ fst t)) ts)
-                                      Just (Either l r) -> @loc.semname >#< "('Data.Either'.Left left)" >#< "=" >#< @loc.semname >|< "_Left" >#< @frecarg l "left"
-                                                           >-< @loc.semname >#< "('Data.Either'.Right right)" >#< "=" >#< @loc.semname >|< "_Right" >#< @frecarg r "right"
-                                      Just (Map k v) -> @loc.semname >#< "m" >#< "=" >#< "'Data.Map'.foldrWithKey"
-                                                        >#< @loc.semname >|< "_Entry" >#< @loc.semname >|< "_Nil"
-                                                        >#< case v of
-                                                               NT nt _ _ -> pp_parens ("'Data.Map'.map" >#< @fsemname nt >#< "m")
-                                                               _         -> pp "m"
-                                      Just (IntMap v) -> @loc.semname >#< "m" >#< "=" >#< "'Data.IntMap'.foldWithKey"
-                                                         >#< @loc.semname >|< "_Entry" >#< @loc.semname >|< "_Nil"
-                                                         >#< case v of
-                                                                NT nt _ _ -> pp_parens ("'Data.IntMap'.map" >#< @fsemname nt >#< "m")
-                                                                _         -> pp "m"
-                                      Just (OrdSet t) -> @loc.semname >#< "s" >#< "=" >#< "foldr" >#< @loc.semname >|< "_Entry"
-                                                         >#< @loc.semname >|< "_Nil"
-                                                         >#< pp_parens (
-                                                               ( case t of
-                                                                   NT nt _ _ -> pp_parens ("map" >#< @fsemname nt)
-                                                                   _         -> empty
-                                                               ) >#< pp_parens ("'Data.IntSet'.elems" >#< "s")
-                                                             )
-                                      Just IntSet     -> @loc.semname >#< "s" >#< "=" >#< "foldr" >#< @loc.semname >|< "_Entry"
-                                                         >#< @loc.semname >|< "_Nil"
-                                                         >#< pp_parens ("'Data.IntSet'.elems" >#< "s")
---                                      Just x -> error $ "Type " ++ show x ++ " is not supported yet" -- TODO: other typeSyns
-
--- The number of productions
-ATTR EProductions EProduction [ | | count USE {+} {0} : {Int} ]
-SEM EProduction | EProduction  lhs.count = {1}
-
--- The per-production cases for the sem_NT function
-ATTR EProduction EProductions [ | | sem_nt USE {>-<} {empty} : {PP_Doc} ]
-SEM EProduction
-  | EProduction lhs.sem_nt = let lhs   = "sem_" >|< @lhs.nt
-                                 rhs   = "=" >#< "sem_" >|< @lhs.nt >|< "_" >|< @con >#< ppSpaced @children.argnamesw
-                                 cnnm  = conname @lhs.rename @lhs.nt @con
-                             in  if isRecordConstructor @lhs.nt @lhs.constructorTypeMap
-                                   then  lhs >#< "{" >#< cnnm >#< "|" >#<
-                                         pp_block "" "" "," (zipWith (\l r -> l >#< "=" >#< r) @children.recfields @children.argpats) >#< "}" >#< rhs
-                                   else  lhs >#< "(" >#< cnnm >#< ppSpaced @children.argpats >#< ")" >#< rhs
-
-{
-isRecordConstructor :: NontermIdent -> Map NontermIdent ConstructorType -> Bool
-isRecordConstructor nt ctm = Map.lookup nt ctm == Just RecordConstructor
-}
-
-ATTR EChild    [ | | argnamesw              : { PP_Doc } ]
-ATTR EChildren [ | | argnamesw USE {:} {[]} : {[PP_Doc]} ]
-
-SEM EChild
-  | EChild lhs.argnamesw = case @kind of
-                             ChildSyntax     -> "(" >#< "sem_" >|< @loc.nt >#< @name >|< "_" >#< ")"
-                             ChildAttr       -> empty  -- no sem-case for a higher-order child
-                             ChildReplace tp -> "(" >#< "sem_" >|< extractNonterminal tp >#< @name >|< "_" >#< ")"
-  | ETerm  lhs.argnamesw = text $ fieldname @name
-
--------------------------------------------------------------------------------
---  Types of attributes
--------------------------------------------------------------------------------
-ATTR ExecutionPlan
-     ENonterminals
-     ENonterminal  [ inhmap : {Map NontermIdent Attributes}
-                     synmap : {Map NontermIdent Attributes} | | ]
-
-ATTR EProductions EProduction
-     ERules ERule
-     Patterns Pattern
-     Visits
-     Visit   [ inhmap : {Attributes}
-               synmap : {Attributes}
-               allInhmap : {Map NontermIdent Attributes}
-               allSynmap : {Map NontermIdent Attributes} | | ]
-
-SEM ENonterminal
-  | ENonterminal (Just prods.inhmap) = Map.lookup @nt @lhs.inhmap
-                 (Just prods.synmap) = Map.lookup @nt @lhs.synmap
-                 prods.allInhmap = @lhs.inhmap
-                 prods.allSynmap = @lhs.synmap
-
--------------------------------------------------------------------------------
---  State datatypes
--------------------------------------------------------------------------------
-{type VisitStateState = (VisitIdentifier,StateIdentifier, StateIdentifier)}
-
-ATTR Visit  [ | | allvisits              : { VisitStateState }]
-ATTR Visits [ | | allvisits USE {:} {[]} : {[VisitStateState]}]
-ATTR EProduction
-     EProductions [ | | allvisits: {[VisitStateState]}]
-
-SEM Visit
-  | Visit lhs.allvisits = (@ident, @from, @to)
-
-SEM EProductions
-  | Cons lhs.allvisits = @hd.allvisits -- just pick the first production
-  | Nil  lhs.allvisits = error "Every nonterminal should have at least 1 production"
-
--- type of tree in a given state s
-SEM ENonterminal
-  | ENonterminal loc.outedges  = Set.fromList $ map (\(_,f,_) -> f) @prods.allvisits
-                 loc.inedges   = Set.fromList $ map (\(_,_,t) -> t) @prods.allvisits
-                 loc.allstates = Set.insert @initial $ @loc.inedges `Set.union` @loc.outedges
-                 loc.stvisits  = \st -> filter (\(v,f,t) -> f == st) @prods.allvisits
-                 loc.t_type    = "T_" >|< @nt
-                 loc.lt_type   = "t_" >|< @nt
-                 loc.t_params  = ppSpaced @params
-                 loc.t_init_icl    = @loc.t_init_dcl >-<
-                                     "attach_" >|< @loc.t_type >#< pp_parens (@loc.t_type >#< @loc.lt_type) >#< "=" >#< @loc.lt_type
-                 loc.t_init_dcl    = "::" >#< @loc.t_type >#< @loc.t_params >#< "=" >#< @loc.t_type
-                                     >#<
-                                     pp_parens (
-                                     ppMonadType @lhs.options >#< pp_parens (@loc.t_type >|< "_s" >|< @initial >#< @loc.t_params))
-                 loc.t_states_icl  = vlist $ map (\st ->
-                                       let nt_st = @nt >|< "_s" >|< st
-                                           c_st  = "C_" >|< nt_st
-                                           inv_st  = "inv_" >|< nt_st
-                                           nextVisit = Map.findWithDefault ManyVis st @nextVisits
-                                       in  case nextVisit of
-                                             NoneVis    -> empty  -- empty semantics
-                                             OneVis vId -> inv_st >#< pp_parens (c_st >#< "x") >#< "=" >#< "x"
-                                             ManyVis    -> empty
-                                           ) $ Set.toList @loc.allstates
-                 loc.t_states_dcl  = vlist $ map (\st ->
-                                       let nt_st   = @nt >|< "_s" >|< st
-                                           t_st    = "T_" >|< nt_st
-                                           k_st    = "K_" >|< nt_st
-                                           c_st    = "C_" >|< nt_st
-                                           inv_st  = "inv_" >|< nt_st
-                                           nextVisit = Map.findWithDefault ManyVis st @nextVisits
-                                       in  case nextVisit of
-                                             NoneVis    -> "::" >#< t_st >#< @loc.t_params >#< "=" >#< c_st  -- empty semantics
-                                             OneVis vId -> "::" >#< t_st >#< @loc.t_params >#< "=" >#< c_st >#< (pp_parens (conNmTVisit @nt vId >#< @loc.t_params))
-                                             ManyVis    -> "::" >#< t_st >#< @loc.t_params >#< "where" >#< c_st >#< "::" -- TODO : Cleanify
-                                                             >#< (pp_braces $ inv_st >#< "::" >#< "!" >|< pp_parens ("E.t:" >#< k_st >#< @loc.t_params >#< "t" >#< "->" >#< "t"))
-                                                             >#< "->" >#< t_st >#< @loc.t_params  -- this is a conventional data type, but declared with GADT syntax
-                                           ) $ Set.toList @loc.allstates
-                                       
--- type of a key which identifies a visit v from state s
-SEM ENonterminal
-  | ENonterminal loc.k_type   = "K_" ++ show @nt
-                 loc.k_states = vlist $ map (\st ->
-                                   let nt_st = @nt >|< "_s" >|< st
-                                       k_st  = "K_" >|< nt_st
-                                       outg  = filter (\(v,f,t) -> f == st) @prods.allvisits
-                                       visitlist = vlist $ map (\(v,f,t) ->
-                                           @loc.k_type >|< "_v" >|< v >#< "::" >#< k_st >#< @loc.t_params >#< pp_parens (@loc.t_type >|< "_v" >|< v >#< @loc.t_params)
-                                            ) outg
-                                       nextVisit = Map.findWithDefault ManyVis st @nextVisits
-                                       decl = "::" >#< k_st >#< "k" >#< @loc.t_params >#< "where" >-< indent 3 visitlist
-                                   in  case nextVisit of
-                                         NoneVis  -> empty
-                                         OneVis _ -> empty
-                                         ManyVis  -> decl
-                                   ) $ Set.toList @loc.allstates
-
--- type of a visit v, with continuation as new state s
-ATTR Visit Visits EProduction EProductions [ | | t_visits USE {>-<} {empty} : {PP_Doc} ]
-
-SEM EProductions
-  | Cons lhs.t_visits = @hd.t_visits -- just pick the first production
-
-SEM Visit
-  | Visit loc.nameT_visit     = conNmTVisit @lhs.nt @ident
-          loc.nameTIn_visit   = conNmTVisitIn @lhs.nt @ident
-          loc.nameTOut_visit  = conNmTVisitOut @lhs.nt @ident
-          loc.nameTNext_visit = conNmTNextVisit @lhs.nt @to
-
-          loc.nextVisitInfo   = Map.findWithDefault ManyVis @to @lhs.nextVisits  -- which visits can we do after we reach the @to state?
-          loc.typecon         = case @kind of
-                                  VisitPure _  -> empty
-                                  VisitMonadic -> ppMonadType @lhs.options
-
-          loc.t_params  = ppSpaced @lhs.params
-          lhs.t_visits = "::" >#< @loc.nameT_visit >#< @loc.t_params >#< ":==" >#<
-                           pp_parens (@loc.nameTIn_visit >#< @loc.t_params)
-                             >#< ( if dummyTokenVisit @lhs.options
-                                   then "->" >#< dummyType @lhs.options True  -- Additional (unused though) argument
-                                   else empty
-                                 )
-                             >#< "->" >#< @loc.typecon >#< pp_parens (@loc.nameTOut_visit >#< @loc.t_params)
-                         >-< "::" >#< @loc.nameTIn_visit >#< @loc.t_params >#< "=" >#< @loc.nameTIn_visit >#<
-                              @loc.inhpart
-                         >-< "::" >#< @loc.nameTOut_visit >#< @loc.t_params >#< "=" >#< @loc.nameTOut_visit >#<
-                              @loc.synpart >#< case @loc.nextVisitInfo of
-                                                 NoneVis    -> empty                    -- don't return a continuation at all
-                                                 _          -> @loc.addbang1 $ pp_parens (@loc.nameTNext_visit >#< @loc.t_params)  -- normal route: select the next semantics
-
-          loc.inhpart   = @loc.ppTypeList @inh @lhs.inhmap
-          loc.synpart   = @loc.ppTypeList @syn @lhs.synmap
-          loc.ppTypeList = \s m -> ppSpaced $ map (\i -> @loc.addbang1 $ pp_parens $ case Map.lookup i m of
-                                                                                      Just tp -> ppTp tp ) $ Set.toList s
-
-{
-conNmTVisit nt vId      = "T_" >|< nt >|< "_v"    >|< vId
-conNmTVisitIn nt vId    = "T_" >|< nt >|< "_vIn"  >|< vId
-conNmTVisitOut nt vId   = "T_" >|< nt >|< "_vOut" >|< vId
-conNmTNextVisit nt stId = "T_" >|< nt >|< "_s"    >|< stId
-
-ppMonadType :: Options -> PP_Doc
-ppMonadType opts
-  | parallelInvoke opts = text "IO"
-  | otherwise           = text "Identity"
-}
-
--------------------------------------------------------------------------------
---  Inh and Syn wrappers
--------------------------------------------------------------------------------
-SEM ENonterminal
-  | ENonterminal loc.wr_inh_icl   = @loc.genwrap_icl "Inh" @loc.wr_inhs
-                 loc.wr_syn_icl   = @loc.genwrap_icl "Syn" @loc.wr_syns
-                 loc.genwrap_icl  = \nm attr ->
-                                      let tyConName = nm >|< "_" >|< @nt
-                                      in  (let (d, _, _) = foldr (\(i, t) (d, c, n) -> (d >-<
-                                                             i >|< "_" >|< tyConName >#< "::" >#< tyConName >#< "->" >#< (@loc.addbang $ pp_parens $ typeToHaskellString (Just @nt) [] t)
-                                                             >-< i >|< "_" >|< tyConName >#< pp_parens (tyConName >#< unwords (replicate (n - c - 1) "_" ++ ["x"] ++ replicate c "_")) >#< "= x"
-                                                             , c + 1, n)
-                                                             ) (empty, 0, length attr) attr
-                                          in  d)
-                 loc.wr_inh_dcl   = @loc.genwrap_dcl "Inh" @loc.wr_inhs
-                 loc.wr_syn_dcl   = @loc.genwrap_dcl "Syn" @loc.wr_syns
-                 loc.genwrap_dcl  = \nm attr ->
-                                      let tyConName = nm >|< "_" >|< @nt
-                                      in  "::" >#< tyConName >#< @loc.t_params >#< "=" >#< tyConName -- >#< "{"
-                                          >#< (ppSpaced $ map (\(_,t) -> @loc.addbang $ pp_parens $ typeToHaskellString (Just @nt) [] t) attr) -- >#< "}"
-                                          >-<
-                                              (let (d, _, _) = foldr (\(i, t) (d, c, n) -> (d >-<
-                                                                i >|< "_" >|< tyConName >#< "::" >#< tyConName >#< "->" >#< (@loc.addbang $ pp_parens $ typeToHaskellString (Just @nt) [] t)
-                                                                , c + 1, n)
-                                                                ) (empty, 0, length attr) attr
-                                              in  d)
-                 loc.synAttrs = fromJust $ Map.lookup @nt @lhs.inhmap
-                 loc.wr_inhs  = Map.toList $ @loc.wr_filter $ @loc.synAttrs
-                 loc.wr_inhs1 = Map.toList @loc.synAttrs
-                 loc.wr_filter = if lateHigherOrderBinding @lhs.options
-                                 then Map.delete idLateBindingAttr
-                                 else id
-                 loc.wr_syns  = Map.toList $ fromJust $ Map.lookup @nt @lhs.synmap
-                 loc.inhlist  = map (lhsname @lhs.options True . fst) @loc.wr_inhs
-                 loc.inhlist1 = map (lhsname @lhs.options True . fst) @loc.wr_inhs1
-                 loc.synlist  = map (lhsname @lhs.options False . fst) @loc.wr_syns
-                 loc.wrapname = "wrap_" ++ show @nt
-                 loc.inhname  = "Inh_" ++ show @nt
-                 loc.synname  = "Syn_" ++ show @nt
-                 loc.firstVisitInfo = Map.findWithDefault ManyVis @initial @nextVisits
-                 loc.wrapper_icl  = (@loc.wrapname >#< "::" >#< @loc.quantPP >#< @loc.classPP >#< @loc.t_type >#< @loc.t_params -- TODO : Remove ? >#< "->"
-                                          >#< @loc.inhname >#< @loc.t_params >#< "->" >#< ( if monadicWrappers @lhs.options then ppMonadType @lhs.options else empty) >#< pp_parens (@loc.synname >#< @loc.t_params))
-                                    >-< (@loc.wrapname >#< (@loc.addbang $ pp_parens (@loc.t_type >#< pp "act"))
-                                        >#< (@loc.addbang $ pp_parens (@loc.inhname
-                                               >#< (ppSpaced $ map (@loc.addbangWrap . pp) @loc.inhlist)) >#< "="))
-                                    >-<
-                                    indent 3 (case @initialv of
-                                      -- case where there are no inherited or synthesized attributes
-                                      [] -> text @loc.synname -- TODO : Remove? >#< " { }"
-                                      (initv:_) -> -- TODO: take care of multiple visits
-                                        let inCon  = conNmTVisitIn @nt initv
-                                            outCon = conNmTVisitOut @nt initv
-                                            pat    = @loc.addbang $ pp_parens $ pat0
-                                            pat0   = outCon >#< ppSpaced @loc.synlist -- should be an "end" state, thus no continuation expected here
-                                            arg    = inCon >#< ppSpaced @loc.inhlist1
-                                            ind    = case @loc.firstVisitInfo of
-                                                       NoneVis  -> error "wrapper: initial state should have a next visit but it has none"
-                                                       OneVis _ -> empty
-                                                       ManyVis  -> @loc.k_type >|< "_v" >|< initv
-                                            extra  = if dummyTokenVisit @lhs.options
-                                                     then pp $ dummyArg @lhs.options True
-                                                     else empty
-                                            convert = case Map.lookup initv @lhs.allVisitKinds of
-                                                        Just kind -> case kind of
-                                                                       VisitPure _  -> text "lift"
-                                                                       VisitMonadic -> empty
-                                                        _         -> empty
-                                            unMonad | monadicWrappers @lhs.options = empty
-                                                    | otherwise                    = unMon @lhs.options
-                                        in unMonad >#< "("
-                                           >-< indent 2
-                                                 ("act >>= \\" >#< @loc.addbang (pp "sem") >#< "->"   -- run the per-node monadic code to get the initial state (of the root)
-                                                 >-< "lift" >#< pp_parens arg >#< ">>= \\" >#< @loc.addbangWrap (pp "arg") >#< "->"
-                                                 >-< convert >#< pp_parens ("inv_" >|< @nt >|< "_s" >|< @initial >#< "sem" >#< ind >#< "arg" >#< extra) >#< ">>= \\" >#< pat >#< "->"  -- invoke initial state (of the root)
-                                                 >-< "lift" >#< pp_parens (@loc.synname >#< ppSpaced @loc.synlist)
-                                                 )
-                                           >-< ")" )
-                                    >-< if lateHigherOrderBinding @lhs.options
-                                        then indent 2 ("where" >#< lhsname @lhs.options True idLateBindingAttr >#< "=" >#< lateBindingFieldNm @lhs.mainName)
-                                        else empty
-                 loc.wrapper_dcl  = (@loc.wrapname >#< "::" >#< @loc.quantPP >#< @loc.classPP >#< @loc.t_type >#< @loc.t_params -- TODO : Remove ? >#< "->"
-                                          >#< @loc.inhname >#< @loc.t_params >#< "->" >#< ( if monadicWrappers @lhs.options then ppMonadType @lhs.options else empty) >#< pp_parens (@loc.synname >#< @loc.t_params))
-
--------------------------------------------------------------------------------
---  Collection of NT / Production sem funs references
--------------------------------------------------------------------------------
-
-ATTR ENonterminals ENonterminal EProductions EProduction [ | | semFunBndDefs, semFunBndTps USE {Seq.><} {Seq.empty} : {Seq PP_Doc} ]
-SEM ENonterminal | ENonterminal
-  lhs.semFunBndDefs = @loc.semFunBndDef Seq.<| @prods.semFunBndDefs
-  lhs.semFunBndTps  = @loc.semFunBndTp Seq.<| @prods.semFunBndTps
-  loc.semFunBndDef  = @loc.semFunBndNm >#< "=" >#< @loc.semname
-  loc.semFunBndTp   = @loc.semFunBndNm >#< "::" >#< @loc.sem_tp
-  loc.semFunBndNm   = lateSemNtLabel @nt
-
-SEM EProduction | EProduction
-  lhs.semFunBndDefs = Seq.singleton @loc.semFunBndDef
-  lhs.semFunBndTps  = Seq.singleton @loc.semFunBndTp
-  loc.semFunBndDef  = @loc.semFunBndNm >#< "=" >#< @loc.semname
-  loc.semFunBndTp   = @loc.semFunBndNm >#< "::" >#< @loc.sem_tp
-  loc.semFunBndNm   = lateSemConLabel @lhs.nt @con
-
--- Generate a dictionary that contains the semantics of all semantic functions
-SEM ExecutionPlan | ExecutionPlan
-  loc.wrappersExtra = if lateHigherOrderBinding @lhs.options
-                      then @loc.lateSemBndDef
-                      else empty
-  loc.commonExtra   = if lateHigherOrderBinding @lhs.options
-                      then @loc.lateSemBndTp
-                      else empty
-  loc.lateSemBndTp = "::" >#< lateBindingTypeNm @lhs.mainName >#< "=" >#< lateBindingTypeNm @lhs.mainName
-                      >-< (indent 2 $ pp_block "{" "}" "," $ toList @nonts.semFunBndTps)
-  loc.lateSemBndDef = lateBindingFieldNm @lhs.mainName >#< "::" >#< lateBindingTypeNm @lhs.mainName
-                      >-< lateBindingFieldNm @lhs.mainName >#< "=" >#< lateBindingTypeNm @lhs.mainName
-                      >-< (indent 2 $ pp_block "{" "}" "," $ toList @nonts.semFunBndDefs )
-
--------------------------------------------------------------------------------
---  Production semantic functions
--------------------------------------------------------------------------------
-ATTR EProduction  [ | | sem_prod                       : {PP_Doc}
-                        sem_prod_tys                   : {PP_Doc} ]
-ATTR EProductions [ | | sem_prod USE {>-<} {empty}     : {PP_Doc}
-                        sem_prod_tys USE {>-<} {empty} : {PP_Doc} ]
-
-ATTR EProduction EProductions [ initial : {StateIdentifier}
-                                allstates : {Set StateIdentifier} | | ]
-SEM ENonterminal
-  | ENonterminal prods.initial   = @initial
-                 prods.allstates = @loc.allstates
-                                          
-ATTR EChild    [ | | argtps                  : {  PP_Doc  }
-                     argpats                 : {  PP_Doc  }
-                     recfields USE {++} {[]} : { [Identifier] }]
-ATTR EChildren [ | | argtps    USE {:}  {[]} : { [PP_Doc] }
-                     argpats   USE {:}  {[]} : { [PP_Doc] }
-                     recfields USE {++} {[]} : { [Identifier] }]
-
-SEM EChild
-  | EChild lhs.argtps   = case @kind of
-                            ChildSyntax     -> pp_parens $ ppDefor @tp -- TODO Remove? >#< "->"
-                            ChildReplace tp -> pp_parens $ ppDefor tp -- TODO Remove? >#< "->"
-                            _               -> empty  -- higher order attribute
-           loc.argpats = case @kind of
-                           ChildSyntax    -> @name >|< "_"                    -- no strictification of children semantics to allow infinite trees
-                           ChildReplace _ -> @name >|< "_"
-                           _              -> empty
-                           
-           lhs.recfields = case @kind of
-                             ChildSyntax    -> [@name]                    -- no strictification of children semantics to allow infinite trees
-                             ChildReplace _ -> [@name]
-                             _              -> []
-                           
- -- | ETerm  lhs.argtps  = (pp_parens $ show @tp) >#< "572->" -- TODO Remove?
-  | ETerm  lhs.argtps    = pp_parens $ show @tp
-           loc.argpats   = @loc.addbang $ text $ fieldname @name   -- terminals may be strict (perhaps this should become an option)
-           lhs.recfields = [@name]
-
-{
-ppDefor :: Type -> PP_Doc
-ppDefor (NT nt args _) = "T_" >|< nt >#< ppSpaced (map pp_parens args)
-ppDefor (Haskell s)    = text s
-}
-
-SEM EProduction
-  | EProduction loc.t_type   = "T_" >|< @lhs.nt
-                loc.t_params = ppSpaced @lhs.params
-                loc.usedArgs = @children.usedArgs `Set.union` @visits.usedArgs `Set.union` @rules.usedArgs
-                -- A bit ugly, but this code renames arguments and puts an underscore when the argument
-                -- is never used. This avoids compiler warnings of unused variables.
-                loc.args     = map (\x -> let (name,arg) = case show x of 
-                                                       ""       -> ("", empty)
-                                                       '!':name -> ("arg_" ++ name, "!arg_" >|< name)
-                                                       name     -> ("arg_" ++ name, "arg_"  >|< name)
-                                          in  if null name || name `Set.member` @loc.usedArgs
-                                                            then arg
-                                                            else text "_") @children.argpats
-                loc.semname  = "sem_" ++ show @lhs.nt ++ "_" ++ show @con
-                loc.sem_tp   = @loc.quantPP2 >#< @loc.classPP2 >#< ppSpaced @children.argtps
-                               >#< (if length @children.argtps > 0 then "->" else "")
-                               >#< @loc.t_type >#< @loc.t_params -- TODO Keep -> here?
-                loc.classPP2 = ppClasses (classCtxsToDocs @lhs.classCtxs ++ classConstrsToDocs @constraints)
-                loc.quantPP2 = ppQuants (@lhs.params ++ @params)
-                
-                lhs.sem_prod_tys = @loc.semname >#< " ::" >#< @loc.sem_tp
-                
-                loc.sem_prod = @loc.semname >#< " ::" >#< @loc.sem_tp
-                               >-< @loc.mkSemBody (@loc.semname >#< ppSpaced @loc.args >#< "=" >#< @loc.t_type)
-                                                  @loc.mbInitializer @loc.outerlet ("lift" >#< "st" >|< @lhs.initial)
-                loc.mkSemBody = \prefix mbInit outerlet ret ->
-                                  case mbInit of
-                                    Nothing -> prefix >#< pp_parens ret >#< "where"
-                                               >-< indent 3 outerlet  -- code for states and visits
-                                    Just m  -> prefix >#< "(" >#< "do" -- TODO: desugar
-                                               >-< indent 1 (
-                                                     m
-                                                     >-< "let"
-                                                     >-< indent 2 outerlet -- code for the states and visits
-                                                     >-< ret )
-                                               >-< indent 1 ")"
-
-                loc.mbInitializer   = --some monadic actions, performed upon attaching a child, can
-                                      -- be specified here. The resulting bindings of these actions are
-                                      -- in scope of the rules of the production
-                                      if parallelInvoke @lhs.options
-                                      then (Nothing :: Maybe PP_Doc)  -- perhaps do some per-node registation, etc. For now: nothing
-                                      else Nothing  -- nothing special here
-                loc.outerlet = vlist @loc.statefns >-< @rules.sem_rules
-                loc.statefns = map @loc.genstfn $ Set.toList @lhs.allstates
-                loc.genstfn  = \st -> let nextVisitInfo = Map.findWithDefault ManyVis st @lhs.nextVisits
-                                          prevVisitInfo = Map.findWithDefault ManyVis st @lhs.prevVisits
-                                          stNm = "st" >|< st
-                                          lhs  = bang stNm >#< "=" >#<
-                                                 ( -- generating a lambda for the same reasons as generating
-                                                   -- a lambda for rules: to ensure that overloading is
-                                                   -- resolved for all visit functions and rules together.
-                                                   if st == @lhs.initial
-                                                   then empty
-                                                   else "\\" >#< @loc.stargs st >#< "->"
-                                                 )
-
-                                          cCon = "C_" >|< @lhs.nt >|< "_s" >|< st
-                                          bang | st == @lhs.initial = @loc.addbang  -- initial state is not parameterized
-                                               | otherwise          = id
-
-                                          -- note about the initial state: the initial state should be the only
-                                          -- state-binding that is not a function. It is non-recursive and not needed
-                                          -- anywhere except delivered as initial result. This binding therefore does
-                                          -- not end up needlessly in any closure.
-                                      in case nextVisitInfo of
-                                           NoneVis    -> -- the (empty) closure of a (non-initial) end state is not referenced
-                                                         -- thus generating it is not needed (and omitting it may catch some small mistakes).
-                                                         if st == @lhs.initial
-                                                         then lhs >#< cCon  -- empty state
-                                                         else empty -- no state generated
-                                           OneVis vId -> mklet lhs (@loc.stvs st False) (cCon >#< "v" >|< vId)
-                                           ManyVis    -> mklet lhs (@loc.stks st >-< @loc.stvs st True) (cCon >#< "k" >|< st)
-                loc.stargs   = \st -> let attrs = maybe Map.empty id $ Map.lookup st @visits.intramap
-                                      in ppSpaced [ let match | str `Set.member` @loc.lazyIntras = pp str
-                                                              | otherwise                        = @loc.addbang (pp str)
-                                                    in case mbAttr of
-                                                         Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) ->
-                                                           case Map.lookup nm @loc.localAttrTypes of
-                                                             Just tp -> pp_parens (pp_parens match >#< "::" >#< ppTp tp)
-                                                             Nothing -> match
-                                                         Just attr | not (noPerStateTypeSigs @lhs.options) ->
-                                                           case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @loc.childTypes of
-                                                             Just tpDoc -> pp_parens (pp_parens match >#< "::" >#< tpDoc)
-                                                             Nothing    -> match
-                                                         _ -> match
-                                                 | (str,mbAttr) <- Map.assocs attrs
-                                                 ] >#< dummyPat @lhs.options (Map.null attrs)
-
-                loc.stks     = \st -> if null (@loc.stvisits st)
-                                      then empty
-                                      else "k" >|< st >#< "::" >#< "K_" >|< @lhs.nt >|< "_s" >|< st >#< @loc.t_params >#< "t" >#< "->" >#< "t"
-                                           >-< vlist (map (\(v,f,t) -> "k" >|< st >#< "K_" >|< @lhs.nt >|< "_v" >|< v >#< "="
-                                                                  >#< "v" >|< v) $ @loc.stvisits st)
-                loc.stvisits = \st -> filter (\(v,f,t) -> f == st) @visits.allvisits
-                loc.stvs     = \st inlinePragma -> vlist [ppf inlinePragma | (f,ppf) <- @visits.sem_visit, f == st]
-                visits.mrules = @rules.mrules
-
-{
-mklet :: (PP a, PP b, PP c) => a -> b -> c -> PP_Doc
-mklet prefix defs body =
-  prefix
-  >-< indent (length (show prefix))
-    ("let"
-     >-< indent 4 defs
-     >-< "in" >#< body)
-}
-
--------------------------------------------------------------------------------
---  Visit semantic functions
--------------------------------------------------------------------------------
-ATTR Visit  [ | | sem_visit              : {  (StateIdentifier,Bool -> PP_Doc)  } ]
-ATTR Visits [ | | sem_visit USE {:} {[]} : { [(StateIdentifier,Bool -> PP_Doc)] } ]
-
-SEM Visit
-  | Visit lhs.sem_visit = ( @from
-                          , \_ ->
-                               -- TODO: Generate type signature "v" >|< @ident >#< "::" >#< @loc.nameTIn_visit >#< "->" >#< @loc.nameT_visit >#< @loc.t_params >-< 
-
-                                      -- Haskell: generate a lambda here as well instead of a function definition
-                              -- >-< "v" >|< @ident >#< "=" >#< "\\" >#< (@loc.addbang $ pp_parens (@loc.nameTIn_visit >#< @loc.inhpats))
-                              -- Clean: generate a function
-                               "v" >|< @ident >#< (@loc.addbang $ pp_parens (@loc.nameTIn_visit >#< @loc.inhpats)) >#< "="
-                               >#< ( if dummyTokenVisit @lhs.options
-                                     then pp $ dummyPat @lhs.options True  -- extra (but unused) argument
-                                     else empty
-                                   )
-                               -- >#< "->"
-                               -- >#< "("
-                               >-< indent 10 (@loc.stepsInitial
-                               >-< indent 4 @steps.sem_steps) >-< indent 10 @loc.stepsClosing
-                               -- >#< ")"
-                          )
-          loc.stepsInitial = case @kind of
-                               VisitPure False -> text "let"
-                               VisitPure True  -> empty
-                               VisitMonadic    -> text "do"
-          loc.stepsClosing  = let decls =  @loc.nextStBuild
-                                           >-<  @loc.addbang (pp resultValName) >#< "=" >#< @loc.resultval
-                              in case @kind of
-                                   VisitPure False -> indent 4 decls
-                                                      >-< "in" >#< resultValName
-                                   VisitPure True  -> "let" >#< decls
-                                                      >-< indent 1 ("in" >#< resultValName)
-                                   VisitMonadic    -> "let" >#< decls
-                                                      >-< "lift" >#< resultValName
-          loc.vname     = "v" >|< @ident
-          loc.inhpats   = ppSpaced $ map (\arg -> pp $ attrname @lhs.options True _LHS arg) $ Set.toList @inh
-          loc.inhargs   = \chn -> ppSpaced $ map (attrname @lhs.options False chn) $ Set.toList @inh
-          loc.synargs   = ppSpaced $ map (\arg -> attrname @lhs.options False _LHS arg) $ Set.toList @syn
-          loc.nextargsMp = maybe Map.empty id $ Map.lookup @to @lhs.allintramap
-          loc.nextargs  = ppSpaced $ Map.keys $ @loc.nextargsMp
-          loc.nextst    = "st" >|< @to >#< @loc.nextargs >#< dummyArg @lhs.options (Map.null @loc.nextargsMp)
-          loc.resultval = @loc.nameTOut_visit >#< @loc.synargs >#< @loc.nextStRef
-          (loc.nextStBuild, loc.nextStRef)
-            = case @loc.nextVisitInfo of
-                NoneVis  -> (empty, empty)
-                _        -> (@loc.addbang (pp nextStName) >#< "=" >#< @loc.nextst, pp nextStName)
-
-{
-resultValName :: String
-resultValName = "ag__result_"
-
-nextStName :: String
-nextStName = "ag__st_"
-}
-
--- Propagate the visit kind to the steps
-ATTR VisitStep VisitSteps [ kind : VisitKind | | ]
-SEM Visit | Visit  steps.kind = @kind
-
--- the steps in this group should be executed in a pure fashion
-SEM VisitStep | PureGroup
-  steps.kind = VisitPure @ordered
-
-ATTR Visits Visit VisitStep VisitSteps [  mrules : {Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)} | | ]
-ATTR VisitStep VisitSteps [ | | sem_steps USE {>-<} {empty} : {PP_Doc} ]
-SEM VisitStep
-  | Sem        loc.ruleItf = Map.findWithDefault (error $ "Rule "  ++ show @name  ++ " not found") @name @lhs.mrules
-               (lhs.errors, loc.sem_steps) = case @loc.ruleItf @lhs.kind @lhs.fmtMode of
-                                               Left e     -> (Seq.singleton e, empty)
-                                               Right stmt -> (Seq.empty, stmt)
-  | ChildIntro loc.attachItf = Map.findWithDefault (error $ "Child " ++ show @child ++ " not found") @child @lhs.childintros
-               (lhs.errors,lhs.sem_steps,lhs.defs,lhs.uses)
-                 = case @loc.attachItf @lhs.kind @lhs.fmtMode of
-                     Left e                   -> (Seq.singleton e, empty, Set.empty, Map.empty)
-                     Right (code, defs, uses) -> (Seq.empty, code, defs, uses)
-  | ChildVisit loc.visitItf = Map.findWithDefault (error $ "Visit " ++ show @visit ++ " not found") @visit @lhs.allchildvisit
-               (lhs.errors, loc.patPP, loc.exprPP) = case @loc.visitItf @child @lhs.kind of
-                                                       Left e           -> (Seq.singleton e, empty, empty)
-                                                       Right (pat,expr) -> (Seq.empty, pat, expr)
-
-               lhs.sem_steps = let decl = case @lhs.kind of
-                                            VisitPure _  -> @loc.patPP >#< "=" >#< @loc.exprPP
-                                            VisitMonadic -> @loc.exprPP >#< ">>= \\" >#< @loc.patPP >#< "->"
-                               in fmtDecl False @lhs.fmtMode decl
-               loc.convToMonad = case @loc.callKind of
-                                   VisitPure _  -> text "lift"
-                                   VisitMonadic -> empty
-               loc.callKind  = Map.findWithDefault (error "visit kind should be in the map") @visit @lhs.allVisitKinds
-  | Sim        lhs.sem_steps = @steps.sem_steps
-  | PureGroup  lhs.sem_steps = case @lhs.fmtMode of
-                                 FormatDo -> "let" >#< @steps.sem_steps  -- formatted as a let-block (not a line-let)
-                                 _        -> @steps.sem_steps
-
--- The fmtMode indicates in what kind of expression (do/let/line-lets) we are printing
--- declarations, because that determines how we need to wrap declarations
--- Invariant: @lhs.kind == VisitMonadic ---> @lhs.fmtMode == FormatDo
-ATTR VisitSteps VisitStep [ fmtMode : FormatMode | | ]
-SEM Visit | Visit
-  steps.fmtMode = case @kind of
-                    VisitPure False -> FormatLetDecl
-                    VisitPure True  -> FormatLetLine
-                    VisitMonadic    -> FormatDo
-
-SEM VisitStep | PureGroup
-  steps.fmtMode = case @lhs.fmtMode of
-                    FormatDo      -> FormatLetDecl
-                    mode          -> mode
-
-{
-parResultName :: String
-parResultName = "__outcome_"
-
-fmtDecl :: PP a => Bool -> FormatMode -> a -> PP_Doc
-fmtDecl declPure fmt decl = case fmt of
-  FormatLetDecl -> pp decl
-  FormatLetLine -> "let" >#< decl >#< "in"
-  FormatDo | declPure  -> "let" >#< decl >#< "in"
-           | otherwise -> pp decl
-}
-
---
--- Some properties of VisitStep(s)
---
-
--- Used arguments
-ATTR VisitSteps VisitStep Visit Visits EChild EChildren ERule ERules [ | | usedArgs USE {`Set.union`} {Set.empty} : {Set String} ]
-SEM ERule
-  | ERule +usedArgs = Set.union $ Map.keysSet $ Map.mapKeys (\a -> "arg_" ++ a) $ Map.filter isNothing @rhs.attrs
-
-SEM EChild
-  | EChild +usedArgs = \s -> case @kind of
-                             ChildSyntax -> Set.insert ("arg_" ++ show @name ++ "_") s
-                             _           -> s
-
-
--- Number of steps in a 'Sim' block
-ATTR VisitSteps [ | | size : Int ]
-SEM VisitSteps
-  | Nil  lhs.size = 0
-  | Cons lhs.size = 1 + @tl.size
-
--- Number the steps in a 'Sim' block
-ATTR VisitSteps VisitStep [ | index : Int | ]
-SEM VisitSteps | Cons
-  hd.index  = @lhs.index  -- copy rule
-  tl.index  = 1 + @lhs.index
-  lhs.index = @tl.index   -- copy rule
-SEM Visit | Visit    steps.index = 0
-SEM VisitStep | Sim  steps.index = 0
-                     lhs.index   = @lhs.index  -- needed for if we ever allow nested Sims
-
--- Is this the last step?
-ATTR VisitSteps VisitStep [ | | isLast : Bool ]
-ATTR VisitStep [ isLast : Bool | | ]
-SEM VisitSteps
-  | Nil   lhs.isLast = True
-  | Cons  lhs.isLast = False
-          hd.isLast  = @tl.isLast
-
-SEM VisitStep | Sim
-                     loc.isMonadic   = case @lhs.kind of
-                                         VisitMonadic -> True
-                                         _            -> False
-
-
--- Child introduction
-ATTR EChild EChildren [ | | childintros USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} ]
-
-ATTR Visits Visit
-     VisitSteps VisitStep [ childintros : {Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} | | ]
-
-SEM EProduction
-  | EProduction visits.childintros = @children.childintros
-
-SEM EChild
-  | ETerm  lhs.childintros = Map.singleton @name (\_ _ -> Right (empty, Set.empty, Map.empty))
-  | EChild lhs.childintros = Map.singleton @name @loc.introcode
-           loc.isDefor     = case @tp of
-                               NT _ _ defor -> defor
-                               _            -> False
-           loc.valcode     = case @kind of
-                               ChildSyntax -> "arg_" >|< @name >|< "_"
-                               ChildAttr   -> -- decide if we need to invoke the sem-function under the hood
-                                              let prefix | not @loc.isDefor = if lateHigherOrderBinding @lhs.options -- && sepsemmods @lhs.options  -- when sepsemmods is not enabled, the indirection can be optimized away
-                                                                              then lateSemNtLabel @loc.nt >#< lhsname @lhs.options True idLateBindingAttr
-                                                                              else "sem_" >|< @loc.nt
-                                                         | otherwise        = empty -- no need to intro a terminal
-                                              in pp_parens (prefix >#< instname @name)
-                               ChildReplace _ -> -- the higher-order attribute is actually a function that transforms
-                                                 -- the semantics of the child (always deforested)
-                                                 pp_parens (instname @name >#< @name >|< "_")
-           loc.aroundcode  = if @hasAround
-                             then locname @lhs.options @name >|< "_around"
-                             else empty
-           loc.introcode   = \kind fmtMode ->
-                                      let pat       = text $ stname @name @loc.initSt
-                                          patStrict = @loc.addbang pat
-                                          attach    = "attach_T_" >|< @loc.nt >#< pp_parens (@loc.aroundcode >#< @loc.valcode)
-                                          runAttach = unMon @lhs.options >#< pp_parens attach
-                                          decl      = case kind of
-                                                        VisitPure False -> pat >#< "=" >#< runAttach
-                                                        VisitPure True  -> patStrict >#< "=" >#< runAttach
-                                                        VisitMonadic    -> attach >#< ">>= \\" >#< patStrict >#< "->"
-                                      in if compatibleAttach kind @loc.nt @lhs.options
-                                         then Right ( fmtDecl False fmtMode decl
-                                                    , Set.singleton (stname @name @loc.initSt)  -- variables defined by the child intro
-                                                    , case @kind of  -- variables used by the child introduction
-                                                        ChildAttr   -> Map.insert (instname @name) Nothing $  -- the sem attr
-                                                                         ( if @loc.isDefor || not (lateHigherOrderBinding @lhs.options)
-                                                                           then id   -- the sem dictionary attr is not used
-                                                                           else Map.insert (lhsname @lhs.options True idLateBindingAttr) (Just $ AttrInh _LHS idLateBindingAttr)
-                                                                         ) $
-                                                                         ( if @hasAround
-                                                                           then Map.insert (locname @lhs.options (@name) ++ "_around") Nothing
-                                                                           else id
-                                                                         ) $ Map.empty
-                                                        ChildReplace _ -> Map.singleton (instname @name) Nothing   -- uses the transformation function
-                                                        ChildSyntax    -> Map.empty
-                                                    )
-                                         else Left $ IncompatibleAttachKind @name kind
-           loc.nt       = extractNonterminal @tp
-
-{
-stname :: Identifier -> Int -> String
-stname child st = "st_" ++ getName child ++ "X" ++ show st
-
--- should actually return some conversion info
-compatibleAttach :: VisitKind -> NontermIdent -> Options -> Bool
-compatibleAttach _ _ _ = True
-
-unMon :: Options -> PP_Doc
-unMon options
-  | parallelInvoke options = text "'System.IO.Unsafe'.unsafePerformIO"    -- IO monad
-  | otherwise              = text "'Control.Monad.Identity'.runIdentity"  -- identity monad
-}
-
--- rules
-ATTR ERules ERule [ | | sem_rules USE {>-<} {empty} : {PP_Doc}
-                        mrules USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)} ]
-
-SEM ERule | ERule
-     lhs.sem_rules    = if @loc.used == 0
-                        then empty
-                        else @loc.rulecode
-     loc.rulecode     = ( if @loc.genpragma
-                          then @loc.pragma  -- this additional pragma *may* help to give some AG source location in the presence of
-                                            -- type errors in the rule. It will definitely not be precise, and may take some additional
-                                            -- source space, but let's see if it's worth it in practice.
-                          else empty
-                        )
-                        >-< @loc.lambda
-                        >-< indent ((column @rhs.pos - 2) `max` 2)
-                              ( if @loc.genpragma
-                                then @loc.pragma >-< @rhs.semfunc >-< @loc.endpragma
-                                else @rhs.semfunc
-                              )
-      loc.pragma       = "/*# LINE" >#< show (line @rhs.pos) >#< show (file @rhs.pos) >#< "#*/"
-      loc.endpragma    = ppWithLineNr (\ln -> "/*# LINE " ++ show (ln+1) ++ " " ++ show @lhs.mainFile ++ "#*/")
-      loc.genpragma    = genLinePragmas @lhs.options && @explicit && @loc.haspos
-      loc.haspos       = line @rhs.pos > 0 && column @rhs.pos >= 0 && not (null (file @rhs.pos))
-
-        -- This comment describes the Haskell rationale for lambdas
-        -- we generate a simple pattern binding because of overloading-resolving during the type inference process.
-        -- The types of the rules are not generalized (nor do we want that - rules are used in a single typing-context).
-        -- If overloading is resolved separately, it may not be clear which dictionaries to use. For that all rules have
-        -- to be considered together, which is done when we use simple pattern bindings with a lambda expression instead
-        -- of a function definition.
-        -- Note: we also ensure that all rules are lambda expressions, so that they are not made part of any closures
-        -- but are lambda-lifted instead.
-      -- loc.lambda       = @name >#< "=" >#< "\\" >#< @loc.argPats >#< dummyPat @lhs.options (Map.null @rhs.attrs) >#< "->"
-      
-      -- For Clean, we do not want to generate lambdas, but functions instead
-      loc.lambda       = @name >#< @loc.argPats >#< dummyPat @lhs.options (Map.null @rhs.attrs) >#< "="
-
-      loc.argPats      = ppSpaced [ let match | str `Set.member` @lhs.lazyIntras = pp str
-                                              | otherwise                        = @loc.addbang1 (pp str)
-                                    in case mbAttr of
-                                         Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) ->
-                                           case Map.lookup nm @lhs.localAttrTypes of
-                                             Just tp -> pp_parens (pp_parens match) -- TODO Remove? >#< "::" >#< ppTp tp)
-                                             Nothing -> match
-                                         Just attr | not (noPerRuleTypeSigs @lhs.options) ->
-                                           case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @lhs.childTypes of
-                                             Just tpDoc -> pp_parens (pp_parens match) -- TODO Remove? >#< "::" >#< tpDoc)
-                                             Nothing    -> match
-                                         _ -> match
-                                  | (str,mbAttr) <- Map.assocs @rhs.attrs
-                                  ]
-      loc.argExprs     = ppSpaced [ case mbAttr of
-                                      Nothing -> "arg_" >|< str
-                                      _       -> text str
-                                  | (str,mbAttr) <- Map.assocs @rhs.attrs
-                                  ]
-      loc.stepcode     = \kind fmtMode -> if kind `compatibleRule` @pure
-                                          then Right $ let oper | @pure     = "="
-                                                                | otherwise = "<-" -- TODO Desugar
-                                                           decl = @pattern.sem_lhs >#< oper >#< @name >#< @loc.argExprs >#< dummyArg @lhs.options (Map.null @rhs.attrs)
-                                                           tp   = if @pure && not (noPerRuleTypeSigs @lhs.options)
-                                                                    then @pattern.attrTypes
-                                                                    else empty
-                                                       in fmtDecl @pure fmtMode (tp >-< decl)
-                                          else Left $ IncompatibleRuleKind @name kind
-
-      lhs.mrules       = Map.singleton @name @loc.stepcode
-
-ATTR Expression [ | | tks : {[HsToken]} ]
-SEM Expression
-  | Expression lhs.tks = @tks
-
-{
-dummyPat :: Options -> Bool -> PP_Doc
-dummyPat opts noArgs
-  | not noArgs && tupleAsDummyToken opts = empty  -- no unnecessary tuples
-  | tupleAsDummyToken opts = if strictDummyToken opts
-                             then text "Void"
-                             else text "(_)"
-  | otherwise              = let match | strictDummyToken opts = "!_"
-                                       | otherwise             = "_"
-                             in pp_parens (match >#< "::" >#< dummyType opts noArgs)
-  where match | strictDummyToken opts = "(!_)"
-              | otherwise             = "_"
-
-dummyArg :: Options -> Bool -> PP_Doc
-dummyArg opts noArgs
-  | not noArgs && tupleAsDummyToken opts = empty    -- no unnecessary tuples
-  | tupleAsDummyToken opts = text "Void"
-  | otherwise              = text "GHC.Prim.realWorld#"
-
-dummyType :: Options -> Bool -> PP_Doc
-dummyType opts noArgs
-  | not noArgs && tupleAsDummyToken opts = empty     -- no unnecessary tuples
-  | tupleAsDummyToken opts = text "Void"
-  | otherwise              = text "(GHC.Prim.State# GHC.Prim.RealWorld)"
-}
-
-{
--- rules are "deinlined" to prevent needless code duplication.
--- if there is only a bit of duplication, we allow ghc to decide if it is worth it.
--- if the duplication crosses this threshold, however, we tell ghc definitely not to inline it.
-ruleInlineThresholdSoft :: Int
-ruleInlineThresholdSoft = 3
-
-ruleInlineThresholdHard :: Int
-ruleInlineThresholdHard = 5
-
-reallyOftenUsedThreshold :: Int
-reallyOftenUsedThreshold = 12
-}
-
-ATTR Expression [ | | pos : {Pos} ]
-SEM Expression | Expression lhs.pos = @pos
-
--- pattern and expression semantics
-ATTR Pattern  [ | | sem_lhs              : { PP_Doc } ]
-ATTR Patterns [ | | sem_lhs USE {:} {[]} : {[PP_Doc]} ]
-ATTR Pattern Patterns [ | | ]
-
-SEM Pattern
-  | Alias       loc.varPat    = text $ attrname @lhs.options False @field @attr
-                loc.patExpr   = if @pat.isUnderscore
-                                then @loc.varPat
-                                else @loc.varPat >|< "@" >|< @pat.sem_lhs
-                lhs.sem_lhs   = @loc.addbang1 @loc.patExpr
-  | Product     lhs.sem_lhs   = @loc.addbang1 $ pp_block "(" ")" "," @pats.sem_lhs
-  | Constr      lhs.sem_lhs   = @loc.addbang1 $ pp_parens $ @name >#< hv_sp @pats.sem_lhs
-  | Underscore  lhs.sem_lhs   = text "_"
-  | Irrefutable lhs.sem_lhs   = text "~" >|< pp_parens @pat.sem_lhs
-
--- Check if a pattern is just an underscore
-ATTR Pattern [ | | isUnderscore:{Bool}]
-SEM Pattern
- | Constr      lhs.isUnderscore = False
- | Product     lhs.isUnderscore = False
- | Alias       lhs.isUnderscore = False
- | Underscore  lhs.isUnderscore = True
-
--- Collect the attributes defined by a pattern
-ATTR Pattern Patterns  [ | | attrs USE {`Set.union`} {Set.empty} : {Set String} ]
-SEM Pattern | Alias
-  lhs.attrs     = Set.insert (attrname @lhs.options False @field @attr) @pat.attrs
-
--- All attribute types of this pattern
-ATTR Pattern Patterns  [ | | attrTypes USE {>-<} {empty} : {PP_Doc} ]
-SEM Pattern | Alias
-  loc.mbTp      = if @field == _LHS
-                  then Map.lookup @attr @lhs.synmap
-                  else if @field == _LOC
-                       then Map.lookup @attr @lhs.localAttrTypes
-                       else Nothing
-  lhs.attrTypes = empty -- Don't generate these type signatures; increases performance in Clean
-                  -- maybe empty (\tp -> (attrname @lhs.options False @field @attr) >#< "::" >#< ppTp tp) @loc.mbTp
-                            -- >-< @pat.attrTypes
-
--- Collect the attributes used by the right-hand side
-ATTR HsToken Expression [ | | attrs USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ]
-SEM HsToken
-  | AGLocal   lhs.attrs   = Map.singleton (fieldname @var) Nothing
-  | AGField   loc.mbAttr  = if @field == _INST || @field == _FIELD || @field == _INST'
-                            then Nothing  -- should not be used in the first place
-                            else Just $ mkNonLocalAttr (@field == _LHS) @field @attr
-              lhs.attrs   = Map.singleton (attrname @lhs.options True @field @attr) @loc.mbAttr
-
-{
-data NonLocalAttr
-  = AttrInh Identifier Identifier
-  | AttrSyn Identifier Identifier deriving Show
-
-mkNonLocalAttr :: Bool -> Identifier -> Identifier -> NonLocalAttr
-mkNonLocalAttr True  = AttrInh  -- True: inherited attr
-mkNonLocalAttr False = AttrSyn
-
-lookupAttrType :: NonLocalAttr -> Map Identifier Attributes -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc
-lookupAttrType (AttrInh child name) inhs _ = lookupType child name inhs
-lookupAttrType (AttrSyn child name) _ syns = lookupType child name syns
-
--- Note: if the child takes type parameters, the type of an attribute of this child may refer to these parameters. This means that
--- the actual type of the attribute needs to have its type parameters substituted with the actual type argument of the child.
--- However, for now we simply decide to return Nothing in this case, which skips the type annotation.
-lookupType :: Identifier -> Identifier -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc
-lookupType child name attrMp childMp
-  | noParameters childTp = Just ppDoc
-  | otherwise            = Nothing
-  where
-    attrTp     = Map.findWithDefault (error "lookupType: the attribute is not in the attrs of the child") name childAttrs
-    childAttrs = Map.findWithDefault (error "lookupType: the attributes of the nonterm are not in the map") nonterm attrMp
-    nonterm    = extractNonterminal childTp
-    childTp    = Map.findWithDefault (error ("lookupType: the child " ++ show child ++ "is not in the appropriate map")) child childMp
-    ppDoc      = ppTp attrTp
-
-noParameters :: Type -> Bool
-noParameters (Haskell _)   = True
-noParameters (NT _ args _) = null args
-}
-
-ATTR Expression [ | | semfunc : {PP_Doc} ]
-
-SEM Expression
-  | Expression lhs.attrs   = Map.unions $ map (\tok -> attrs_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks
-               lhs.semfunc = vlist $ showTokens $ map (\tok -> tok_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks
-               loc.inhhstoken = Inh_HsToken @lhs.options
-
--- child visit map
-ATTR Visit
-     Visits
-     EProduction
-     EProductions
-     ENonterminal
-     ENonterminals [ allchildvisit : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))}
-                     | | childvisit USE {`Map.union`} {Map.empty} : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} ]
-
-ATTR VisitSteps VisitStep [ allchildvisit : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} | | ]
-
-SEM ExecutionPlan
-  | ExecutionPlan nonts.allchildvisit = @nonts.childvisit
-
-SEM Visit
-  | Visit
-     loc.prevVisitInfo = Map.findWithDefault ManyVis @from @lhs.nextVisits
-     lhs.childvisit = Map.singleton @ident @loc.invokecode
-     loc.invokecode = \chn kind ->   -- "chn" is the name of the child at the place of invocation, and "kind" the kind of the calling visit
-                        if kind `compatibleKind` @kind
-                        then Right $
-                          let pat | isLazyKind @kind = pat0
-                                  | otherwise        = @loc.addbang pat0
-                              pat0  = pp_parens pat1
-                              pat1  = @loc.nameTOut_visit >#< (ppSpaced $ map (attrname @lhs.options True chn) $ Set.toList @syn)
-                                                          >#< cont
-                              cont  = case @loc.nextVisitInfo of
-                                        NoneVis  -> empty
-                                        _        -> ch1
-                              ch0   = text $ stname chn @from
-                              ch1   = text $ stname chn @to
-                              expr  = case (kind, @kind) of
-                                        (VisitPure _,  VisitPure _)  -> expr0
-                                        (VisitPure _,  VisitMonadic) -> unMon @lhs.options >#< expr0
-                                        (VisitMonadic, VisitPure _)  -> "lift" >#< expr0
-                                        (VisitMonadic, VisitMonadic) -> expr0
-                              expr0 = case @loc.prevVisitInfo of
-                                        NoneVis  -> error "error: invocation of a visit from a state that has no next visits"
-                                        OneVis _ -> "inv_" >|< @lhs.nt >|< "_s" >|< @from >#< ch0 >#< args
-                                        ManyVis  -> "inv_" >|< @lhs.nt >|< "_s" >|< @from >#< ch0
-                                                    >#< "K_" >|< @lhs.nt >|< "_v" >|< @ident >#< args
-                              args  = pp_parens args0 >#< args1
-                              args0 = @loc.nameTIn_visit >#< @loc.inhargs chn
-                              args1 | dummyTokenVisit @lhs.options = pp $ dummyArg @lhs.options True
-                                    | otherwise                    = empty
-                          in (pat, expr)  -- pretty print of the pattern and the expression part
-                        else Left $ IncompatibleVisitKind chn @ident kind @kind
-
-{
--- a `compatibleKind` b  means: can kind b be invoked from a
-compatibleKind :: VisitKind -> VisitKind -> Bool
-compatibleKind _              _             = True
-
-compatibleRule :: VisitKind -> Bool -> Bool
-compatibleRule (VisitPure _) False = False
-compatibleRule _             _     = True
-}
-
--------------------------------------------------------------------------------
---  Properties of rules
--------------------------------------------------------------------------------
-
--- Construct an environment that counts how often certain rules are used
-ATTR Visits Visit VisitSteps VisitStep [ | | ruleUsage USE {`unionWithSum`} {Map.empty} : {Map Identifier Int} ]
-ATTR ERules ERule [ usageInfo : {Map Identifier Int} | | ]
-
-SEM EProduction | EProduction  rules.usageInfo = @visits.ruleUsage
-SEM VisitStep | Sem            lhs.ruleUsage = Map.singleton @name 1
-SEM ERule | ERule              loc.used      = Map.findWithDefault 0 @name @lhs.usageInfo
-
-{
-unionWithSum = Map.unionWith (+)
-}
-
--- Collect in what visit-kinds a rule is used
-ATTR Visits Visit VisitSteps VisitStep [ | | ruleKinds USE {`unionWithMappend`} {Map.empty} : {Map Identifier (Set VisitKind)} ]
-SEM VisitStep | Sem
-  lhs.ruleKinds = Map.singleton @name (Set.singleton @lhs.kind)
-
-ATTR ERules ERule [ ruleKinds : {Map Identifier (Set VisitKind)} | | ]
-SEM EProduction | EProduction
-  rules.ruleKinds = @visits.ruleKinds
-
-SEM ERule | ERule
-  loc.kinds = Map.findWithDefault Set.empty @name @lhs.ruleKinds
-  loc.anyLazyKind = Set.fold (\k r -> isLazyKind k || r) False @loc.kinds
-
-ATTR Pattern Patterns [ anyLazyKind : Bool | | ]
-
-
--------------------------------------------------------------------------------
---  Intra attributes
--------------------------------------------------------------------------------
-{
-uwSetUnion :: (Ord a, Ord b) => Map a (Set b) -> Map a (Set b) -> Map a (Set b)
-uwSetUnion = Map.unionWith Set.union
-
-uwMapUnion :: (Ord a, Ord b) => Map a (Map b c) -> Map a (Map b c) -> Map a (Map b c)
-uwMapUnion = Map.unionWith Map.union
-}
-ATTR Visit Visits [ allintramap : {Map StateIdentifier (Map String (Maybe NonLocalAttr))}
-                    | | intramap USE {`uwMapUnion`} {Map.empty} : {Map StateIdentifier (Map String (Maybe NonLocalAttr))} ]
-
-ATTR Visit Visits [ terminaldefs : {Set String} | | ]
-ATTR EChild EChildren [ | | terminaldefs USE {`Set.union`} {Set.empty} : {Set String} ]
-
-SEM EChild | ETerm
-  lhs.terminaldefs = Set.singleton $ fieldname @name
-
-SEM EProduction | EProduction
-  visits.allintramap  = @visits.intramap
-  visits.terminaldefs = @children.terminaldefs
-
-SEM Visit
-  | Visit loc.thisintra = (@loc.uses `Map.union` @loc.nextintra) `Map.difference` @loc.defsAsMap
-          lhs.intramap  = Map.singleton @from @loc.thisintra
-          loc.nextintra = maybe Map.empty id $ Map.lookup @to @lhs.allintramap
-          loc.uses      = let mp1 = @steps.uses
-                              mp2 = Map.fromList [ (lhsname @lhs.options False i, Just (AttrSyn _LHS i)) | i <- Set.elems @syn ]
-                          in mp1 `Map.union` mp2
-          loc.inhVarNms = Set.map (lhsname @lhs.options True) @inh
-          loc.defs      = @steps.defs `Set.union` @loc.inhVarNms `Set.union` @lhs.terminaldefs
-          loc.defsAsMap = Map.fromList [ (a, Nothing) | a <- Set.elems @loc.defs ]
-
-ATTR ERule ERules [ | | ruledefs USE {`uwSetUnion`} {Map.empty} : {Map Identifier (Set String)}
-                        ruleuses USE {`uwMapUnion`} {Map.empty} : {Map Identifier (Map String (Maybe NonLocalAttr))} ]
-ATTR Visit Visits
-     VisitSteps VisitStep [ ruledefs  : {Map Identifier (Set String)}
-                            ruleuses  : {Map Identifier (Map String (Maybe NonLocalAttr))} | | ]
-
-SEM ERule
-  | ERule lhs.ruledefs = Map.singleton @name @pattern.attrs
-          lhs.ruleuses = Map.singleton @name @rhs.attrs
-
-SEM EProduction
-  | EProduction visits.ruledefs = @rules.ruledefs
-                visits.ruleuses = @rules.ruleuses
-
-ATTR Visit Visits
-     EProduction
-     EProductions
-     ENonterminal
-     ENonterminals [ | | visitdefs USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (Set Identifier)}
-                         visituses USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (Set Identifier)} ]
-
-SEM Visit
-  | Visit lhs.visitdefs = Map.singleton @ident @syn
-          lhs.visituses = Map.singleton @ident @inh
-
-ATTR Visit Visits
-     VisitSteps VisitStep
-     EProduction EProductions
-     ENonterminal ENonterminals [ avisitdefs : {Map VisitIdentifier (Set Identifier)}
-                                  avisituses : {Map VisitIdentifier (Set Identifier)} | | ]
-
-SEM ExecutionPlan
-  | ExecutionPlan nonts.avisitdefs = @nonts.visitdefs
-                  nonts.avisituses = @nonts.visituses
-
-ATTR VisitSteps VisitStep [ | | defs USE {`Set.union`} {Set.empty} : {Set String}
-                                uses USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ]
-SEM VisitStep
-  | Sem        lhs.defs = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruledefs
-               lhs.uses = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruleuses
-  | ChildVisit lhs.defs = Set.insert (stname @child @to) $ maybe (error "Visit not found") (Set.map $ attrname @lhs.options True @child) $ Map.lookup @visit @lhs.avisitdefs
-               lhs.uses = let convert attrs = Map.fromList [ (attrname @lhs.options False @child attr, Just $ mkNonLocalAttr True @child attr) | attr <- Set.elems attrs ]
-                          in Map.insert (stname @child @from) Nothing $ convert $
-                               maybe (error "Visit not found") id $ Map.lookup @visit @lhs.avisituses
-
--------------------------------------------------------------------------------
---  Identification of lazy intra defs within a production
---
--- These identifiers will not be marked as strict in rules and state closures
--------------------------------------------------------------------------------
-
-ATTR Visits Visit VisitSteps VisitStep [ | | lazyIntras USE {`Set.union`} {Set.empty} : {Set String} ]
-ATTR ERules ERule [ lazyIntras : {Set String} | | ]
-
-SEM Visit | Visit
-  loc.lazyIntrasInh = case @kind of
-                        VisitPure False -> @loc.inhVarNms `Set.union` @steps.defs
-                        _               -> Set.empty
-  lhs.lazyIntras = @loc.lazyIntrasInh `Set.union` @steps.lazyIntras
-
-SEM VisitStep | PureGroup
-  lhs.lazyIntras = if @ordered
-                   then @steps.lazyIntras
-                   else @steps.defs
-
-SEM EProduction | EProduction
-  loc.lazyIntras = @visits.lazyIntras
-
--------------------------------------------------------------------------------
---  Pretty printing of haskell code
--------------------------------------------------------------------------------
-
-SEM HsTokens [ || tks : {[(Pos,String)]} ]
-  | Cons lhs.tks = @hd.tok : @tl.tks
-  | Nil  lhs.tks = []
-
-SEM HsToken
-  | AGLocal   loc.tok = (@pos,fieldname @var)
-
-SEM HsToken [ || tok:{(Pos,String)}]
-   | AGField
-       loc.addTrace = case @rdesc of
-                        Just d  -> \x -> "(trace_n " ++ show (d ++ " -> " ++ show @field ++ "." ++ show @attr) ++ " (" ++ x ++ "))"
-                        Nothing -> id
-       lhs.tok = (@pos, @loc.addTrace $ attrname @lhs.options True @field @attr)
-
-   | HsToken lhs.tok = (@pos, @value)
-
-   | CharToken lhs.tok = (@pos, if null @value
-                                   then ""
-                                   else showCharShort (head @value)
-                         )
-
-   | StrToken  lhs.tok = (@pos, showStrShort @value)
-   | Err       lhs.tok = (@pos, "")
-
--------------------------------------------------------------------------------
---  Alternative code generation (sepsemmods)
--------------------------------------------------------------------------------
-
-ATTR ExecutionPlan [ mainBlocksDoc : PP_Doc textBlockMap : {Map BlockInfo PP_Doc}
-                   | | genIO : {IO ()} ]
-
-SEM ExecutionPlan
-  | ExecutionPlan lhs.genIO           = do @loc.genMainModule
-                                           @loc.genCommonModule
-                                           @nonts.genProdIO
-                  loc.mainModuleFile  = @lhs.mainFile
-                  loc.ppMonadImports  = pp "import qualified Control.Monad.Identity"
-                  loc.genMainModule   = writeModule @loc.mainModuleFile
-                                          ( [ pp $ @lhs.iclModuleHeader @lhs.mainName "" "" False
-                                            , @loc.ppMonadImports
-                                            , pp $ "import " ++ @lhs.mainName ++ "_common"
-                                            ]
-                                            ++ @nonts.imports
-                                            ++ [@lhs.mainBlocksDoc]
-                                            ++ [@loc.wrappersExtra]
-                                            ++ @nonts.appendMain
-                                          )
-                  loc.commonFile      = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_common")
-                  loc.genCommonModule = writeModule @loc.commonFile
-                                          ( [ pp $ @lhs.iclModuleHeader @lhs.mainName "_common" "" True
-                                            , @loc.ppMonadImports
-                                            , @lhs.importBlocks
-                                            , @lhs.textBlocks
-                                            , @loc.commonExtra
-                                            ]
-                                            ++ @nonts.appendCommon
-                                          )
-
-ATTR ENonterminal  [ | | appendCommon, appendMain              : { PP_Doc } ]
-ATTR ENonterminals [ | | appendCommon, appendMain USE {:} {[]} : {[PP_Doc]} ]
-
-SEM ENonterminal
-  | ENonterminal lhs.appendMain   = (if @nt `Set.member` @lhs.wrappers
-                                     then     @loc.wr_inh_icl
-                                          >-< @loc.wr_syn_icl
-                                          >-< @loc.wrapper_icl
-                                     else empty)
-                                    >-< @loc.sem_nt
-                 lhs.appendCommon = (if dataTypes @lhs.options then @loc.datatype else empty)
-                                    >-< @loc.t_init_icl
-                                    >-< @loc.t_states_icl
-                                    >-< @loc.k_states
-                                    >-< @prods.t_visits
-
-ATTR EProduction EProductions
-     ENonterminal ENonterminals [ | | imports USE {++} {[]} : {[PP_Doc]}
-                                      genProdIO USE {>>} {return ()} : {IO ()} ]
-
-SEM EProduction
-  | EProduction lhs.imports    = [pp $ "import " ++ @loc.moduleName]
-                loc.moduleName = @lhs.mainName ++ @loc.suffix
-                loc.suffix     = '_' : show @lhs.nt ++ ('_' : show @con)
-                loc.outputfile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ @loc.suffix)
-                loc.ppMonadImports  = pp "import qualified Control.Monad.Identity"
-                lhs.genProdIO  = writeModule @loc.outputfile
-                                     [ pp $ @lhs.iclModuleHeader @lhs.mainName @loc.suffix @loc.semname True
-                                     , @lhs.importBlocks
-                                     , @loc.ppMonadImports
-                                     , pp $ "import " ++ @lhs.mainName ++ "_common"
-                                     , @loc.sem_prod
-                                     ]
-
-{
-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
-
-cleanIclModuleHeader :: Options -> String -> String
-cleanIclModuleHeader flags input
- = case moduleName flags
-   of Name nm -> genMod nm
-      Default -> genMod (defaultModuleName input)
-      NoName  -> ""
-   where genMod x = "implementation module " ++ x 
-
-cleanDclModuleHeader :: Options -> String -> Maybe String -> String
-cleanDclModuleHeader flags input export
- = case moduleName flags
-   of Name nm -> genMod nm
-      Default -> genMod (defaultModuleName input)
-      NoName  -> ""
-   where genMod x = "definition module " ++ x ++ genExp export x
-         genExp Nothing _ = ""
-         genExp (Just e) x = "(module " ++ x ++ ", module " ++ e ++ ")"
-
-defaultModuleName :: String -> String
-defaultModuleName = dropExtension
-
-mkIclModuleHeader :: Maybe (String,String,String) -> String -> String -> String -> Bool -> String
-mkIclModuleHeader Nothing defaultName suffix _ _
-  = "implementation module " ++ defaultName ++ suffix
-mkIclModuleHeader (Just (name, exports, imports)) _ suffix addExports replaceExports
-  = "implementation module " ++ name ++ suffix ++ "\n" ++ imports ++ "\n"
-
-mkDclModuleHeader :: Maybe (String,String,String) -> String -> String -> String -> Bool -> String
-mkDclModuleHeader Nothing defaultName suffix _ _
-  = "definition module " ++ defaultName ++ suffix
-mkDclModuleHeader (Just (name, exports, _)) _ suffix addExports replaceExports
-  = "definition module " ++ name ++ suffix ++ ex ++ "\n"
-  where
-    ex  = if null exports || (replaceExports && null addExports)
-          then ""
-          else if null addExports
-               then exports
-               else if replaceExports
-                    then addExports
-                    else exports ++ "," ++ addExports
-}
-
-
---
--- Bang pattern usage
---
-
-SEM ERule | ERule                   loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x
-SEM Visit | Visit                   loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x
-SEM ENonterminal | ENonterminal     loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x
-SEM EProduction | EProduction       loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x
-SEM EChild | EChild                 loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x
-SEM EChild | ETerm                  loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x
-SEM VisitStep | ChildVisit          loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x
-SEM Pattern | Alias Constr Product  loc.addbang  = \x -> if bangpats @lhs.options then "!" >|< x else x
-
-SEM Visit | Visit                   loc.addbang1 = if isLazyKind @kind then id else @loc.addbang
-SEM ENonterminal | ENonterminal     loc.addbangWrap = id --if strictWrap @lhs.options then @loc.addbang else id
-SEM ERule | ERule                   loc.addbang1 = if @loc.anyLazyKind then id else @loc.addbang
-SEM Pattern | Alias Constr Product  loc.addbang1 = if @lhs.anyLazyKind then id else @loc.addbang
-
---
--- Distribute single-visit-next map downward
---
-
-ATTR EProductions EProduction Visits Visit
-  [ prevVisits, nextVisits : {Map StateIdentifier StateCtx} | | ]
-
-SEM ENonterminal | ENonterminal
-  prods.nextVisits = @nextVisits
-  prods.prevVisits = @prevVisits
-
---
--- Collect and distribute the from/to states of a visit
---
-
-ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit
-  [ | | fromToStates USE {`mappend`} {mempty} : {Map VisitIdentifier (Int,Int)} ]
-
-ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep
-  [ allFromToStates : {Map VisitIdentifier (Int,Int)} | | ]
-
-SEM Visit | Visit
-  lhs.fromToStates = Map.singleton @ident (@from, @to)
-
-SEM ExecutionPlan | ExecutionPlan
-  nonts.allFromToStates = @nonts.fromToStates
-
-SEM VisitStep | ChildVisit
-  (loc.from, loc.to) = Map.findWithDefault (error "visit not in allFromToStates") @visit @lhs.allFromToStates
-
-
---
--- Collect and distribute the actual types of children of productions
---
-
-ATTR EChildren EChild [ | | childTypes USE {`mappend`} {mempty} : {Map Identifier Type} ]
-ATTR ERules ERule Visits Visit VisitSteps VisitStep [ childTypes : {Map Identifier Type} | | ]
-
-SEM EProduction | EProduction
-  loc.childTypes = Map.singleton _LHS @lhs.ntType `Map.union` @children.childTypes
-
-SEM EChild | EChild ETerm
-  lhs.childTypes = Map.singleton @name @tp
-
---
--- Distribute types of local attributes
---
-
-ATTR ExecutionPlan ENonterminals ENonterminal  [ localAttrTypes : {Map NontermIdent (Map ConstructorIdent (Map Identifier Type))} | | ]
-ATTR EProductions EProduction                  [ localAttrTypes : {Map ConstructorIdent (Map Identifier Type)} | | ]
-ATTR ERules ERule Pattern Patterns             [ localAttrTypes : {Map Identifier Type} | | ]
-
-SEM ENonterminal | ENonterminal
-  prods.localAttrTypes = Map.findWithDefault Map.empty @nt @lhs.localAttrTypes
-
-SEM EProduction | EProduction
-  loc.localAttrTypes   = Map.findWithDefault Map.empty @con @lhs.localAttrTypes
-
---
--- Collect and distribute visit kinds
---
-
-ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep
-  [ allVisitKinds : {Map VisitIdentifier VisitKind} | | visitKinds USE {`mappend`} {mempty} : {Map VisitIdentifier VisitKind} ]
-
-SEM Visit | Visit
-  lhs.visitKinds = Map.singleton @ident @kind
-
-SEM ExecutionPlan | ExecutionPlan
-  nonts.allVisitKinds = @nonts.visitKinds
-
---
--- Collect and distribute the initial state of nonterminals
---
-
-ATTR ENonterminals ENonterminal [ | | initStates USE {`mappend`} {mempty} : {Map NontermIdent Int} ]
-ATTR ENonterminals ENonterminal EProductions EProduction EChildren EChild Visits Visit VisitSteps VisitStep
-  [ allInitStates : {Map NontermIdent Int} | | ]
-
-SEM ENonterminal | ENonterminal
-  lhs.initStates = Map.singleton @nt @initial
-
-SEM ExecutionPlan | ExecutionPlan
-  nonts.allInitStates = @nonts.initStates
-
-SEM EChild | EChild
-  loc.initSt = Map.findWithDefault (error "nonterminal not in allInitStates map") @loc.nt @lhs.allInitStates
-
---
--- Push the nonterminal type downward
---
-
-ATTR EProductions EProduction [ ntType : Type | | ]
-SEM ENonterminal | ENonterminal
-  loc.ntType = NT @nt (map show @params) False
-
---
--- Collect errors contained in rules that should be yielded when the
--- rules are scheduled.
---
-
-ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule Visits Visit VisitSteps VisitStep [ | | errors USE {Seq.><} {Seq.empty} : {Seq Error} ]
-SEM ERule | ERule
-  lhs.errors = case @mbError of
-                 Just e | @loc.used > 0 -> Seq.singleton e
-                 _                      -> Seq.empty
-
+INCLUDE "ExecutionPlan.ag"+INCLUDE "Patterns.ag"+INCLUDE "Expression.ag"+INCLUDE "HsToken.ag"++imports+{+import ExecutionPlan+import Pretty+import PPUtil+import Options+import Data.Monoid(mappend,mempty)+import Data.Maybe+import Debug.Trace+import System.IO+import System.Directory+import System.FilePath+import UU.Scanner.Position++import TokenDef+import HsToken+import ErrorMessages++import Data.Set (Set)+import qualified Data.Set as Set+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Sequence(Seq)+import qualified Data.Sequence as Seq+import Data.Foldable(toList)+}++ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule EChildren EChild+  [ importBlocks       : PP_Doc+    textBlocks         : PP_Doc+    iclModuleHeader    : {String -> String -> String -> Bool -> String}+    dclModuleHeader    : {String -> String -> String -> Bool -> String}+    mainFile           : String+    mainName           : String+    constructorTypeMap : {Map NontermIdent ConstructorType} | | ]++-------------------------------------------------------------------------------+--  Options+-------------------------------------------------------------------------------+ATTR ExecutionPlan+     ENonterminals ENonterminal+     EProductions EProduction+     ERules ERule+     EChildren EChild+     Expression+     HsToken HsTokens HsTokensRoot+     Pattern Patterns+     Visits Visit+     VisitSteps VisitStep [ options : {Options} | | ]+ATTR EProductions EProduction [ rename : {Bool} | | ]++SEM ENonterminal+  | ENonterminal prods.rename = rename @lhs.options++-------------------------------------------------------------------------------+--  Context info (nonterminal ident, constructor ident, nonterm params, etc.)+-------------------------------------------------------------------------------++ATTR Visit Visits EProduction EProductions EChildren EChild ERules ERule [ nt : NontermIdent | | ]+SEM ENonterminal+  | ENonterminal prods.nt = @nt++ATTR EChildren EChild ERules ERule Visits Visit+  [ con : ConstructorIdent | | ]++SEM EProduction+  | EProduction children.con = @con+                rules.con    = @con+                visits.con   = @con++ATTR EProductions EProduction Visits Visit [ params : {[Identifier]} | | ]+SEM ENonterminal | ENonterminal+  prods.params = @params++ATTR EProductions EProduction [ classCtxs : ClassContext | | ]+SEM ENonterminal | ENonterminal+  prods.classCtxs = @classCtxs++-------------------------------------------------------------------------------+--  Default output+-------------------------------------------------------------------------------+ATTR ExecutionPlan [  | | output : {PP_Doc}+                          output_dcl : {PP_Doc} ]++SEM ExecutionPlan+  | ExecutionPlan lhs.output = @nonts.output >-< @loc.commonExtra >-< @loc.wrappersExtra+                  lhs.output_dcl = @nonts.output_dcl++ATTR ENonterminal ENonterminals [ wrappers : {Set NontermIdent}+                                 | | output USE {>-<} {empty} : {PP_Doc}+                                     output_dcl USE {>-<} {empty} : {PP_Doc}]++SEM ExecutionPlan+  | ExecutionPlan nonts.wrappers = @wrappers++SEM ENonterminal+  | ENonterminal lhs.output = ("// " ++ getName @nt ++ " " ++ replicate (60 - length (getName @nt)) '-')+                              >-< (if @loc.hasWrapper+                                   then "// wrapper"+                                        >-< @loc.wr_inh_icl+                                        >-< @loc.wr_syn_icl+                                        >-< @loc.wrapper_icl+                                        >-< ""+                                   else empty)+                              >-< (if   folds @lhs.options+                                   then "// cata"+                                        >-< @loc.sem_nt+                                        >-< ""+                                   else empty)+                              >-< (if   semfuns @lhs.options+                                   then "// semantic domain"+                                        >-< @loc.t_init_icl+                                        >-< @loc.t_states_icl+                                        >-< @loc.k_states+                                        >-< @prods.sem_prod+                                        >-< ""+                                   else empty)+                 loc.hasWrapper = @nt `Set.member` @lhs.wrappers+                 +                 lhs.output_dcl = ("// " ++ getName @nt ++ " " ++ replicate (60 - length (getName @nt)) '-')+                                  >-< (if dataTypes @lhs.options+                                       then "// data"+                                            >-< @loc.datatype+                                            >-< ""+                                       else empty)+                                  >-< (if @loc.hasWrapper+                                       then "// wrapper"+                                            >-< @loc.wr_inh_dcl+                                            >-< @loc.wr_syn_dcl+                                            >-< @loc.wrapper_dcl+                                            >-< ""+                                       else empty)+                                  >-< (if   folds @lhs.options+                                       then "// cata"+                                            >-< @loc.semname >#< "::" >#< @loc.sem_tp+                                            >-< ""+                                       else empty)+                                  >-< (if   semfuns @lhs.options+                                       then "// semantic domain"+                                            >-< @loc.t_init_dcl+                                            >-< @loc.t_states_dcl+                                            >-< @prods.t_visits+                                            >-< @prods.sem_prod_tys+                                            >-< ""+                                       else empty)++-------------------------------------------------------------------------------+--  Nonterminal datatype+-------------------------------------------------------------------------------+ATTR ENonterminal ENonterminals [ typeSyns : {TypeSyns}+                                  derivings : {Derivings} | | ]++SEM ExecutionPlan+  | ExecutionPlan nonts.typeSyns = @typeSyns+                  nonts.derivings = @derivings++SEM ENonterminal+  | ENonterminal loc.classPP  = ppClasses $ classCtxsToDocs @classCtxs+                 loc.aliasPre = "::" >#< @loc.classPP >#< @nt >#< @loc.t_params >#< ":=="+                 loc.datatype = case lookup @nt @lhs.typeSyns of+                                   Nothing -> "::" >#< @loc.classPP >#< @nt >#< @loc.t_params+                                              >-< ( if null @prods.datatype+                                                    then empty+                                                    else if isRecordConstructor @nt @lhs.constructorTypeMap+                                                           then  indent 2 $ "=" >#< @prods.recordtype+                                                           else  indent 2 $ vlist $ ( ("=" >#< head @prods.datatype)+                                                                                  : (map ("|" >#<) $ tail @prods.datatype))+                                                  )+                                              >-< indent 2 @loc.derivings+                                   Just (List t)     -> @loc.aliasPre >#< "[" >#< show t >#< "]"+                                   Just (Maybe t)    -> @loc.aliasPre >#< "Data.Maybe" >#< pp_parens (show t)+                                   Just (Tuple ts)   -> @loc.aliasPre >#< pp_parens (ppCommas $ map (show . snd) ts)+                                   Just (Either l r) -> @loc.aliasPre >#< "Data.Either" >#< pp_parens (show l) >#< pp_parens (show r)+                                   Just (Map k v)    -> @loc.aliasPre >#< "Data.Map" >#< pp_parens (show k) >#< pp_parens (show v)+                                   Just (IntMap t)   -> @loc.aliasPre >#< "Data.IntMap.IntMap" >#< pp_parens (show t)+                                   Just (OrdSet t)   -> @loc.aliasPre >#< "Data.Set.Set" >#< pp_parens (show t)+                                   Just IntSet       -> @loc.aliasPre >#< "Data.IntSet.IntSet"+--                                   Just x -> error $ "Type " ++ show x ++ " is not supported"+                 loc.derivings = case Map.lookup @nt @lhs.derivings of+                                    Nothing -> empty+                                    Just s  -> if   Set.null s+                                               then empty+                                               else "deriving" >#< (pp_parens $ ppCommas $ map pp $ Set.toList s)++{+classCtxsToDocs :: ClassContext -> [PP_Doc]+classCtxsToDocs = map toDoc where+  toDoc (ident,args) = (ident >#< ppSpaced (map pp_parens args))++classConstrsToDocs :: [Type] -> [PP_Doc]+classConstrsToDocs = map ppTp++ppClasses :: [PP_Doc] -> PP_Doc+ppClasses [] = empty+ppClasses xs = "|" >#< pp_block "" "" "&" xs++ppQuants :: [Identifier] -> PP_Doc+ppQuants [] = empty+ppQuants ps = "E." >#< ppSpaced ps >#< ":"+}++ATTR EProduction  [ | | datatype   : {PP_Doc}+                        recordtype : {PP_Doc} ]+ATTR EProductions [ | | datatype USE {:} {[]} : {[PP_Doc]}+                        recordtype            : {PP_Doc} ]++-- we generate the data type in the type-class style instead of the GADT style+-- the GADT extension may be required if equality constraints are used+SEM EProduction+  | EProduction lhs.datatype = @loc.quantPP1 >#< @loc.classPP1+                               >#< conname @lhs.rename @lhs.nt @con+                               >#< ppConFields (dataRecords @lhs.options) @children.datatype+                lhs.recordtype = @loc.quantPP1 >#< @loc.classPP1+                                 >#< ppConFields True @children.recordtype+                loc.classPP1 = ppClasses (classConstrsToDocs @constraints)+                loc.quantPP1 = ppQuants @params++SEM EProductions+  | Cons  lhs.recordtype = @hd.recordtype+  | Nil   lhs.recordtype = empty++{+-- first parameter indicates: generate a record or not+ppConFields :: Bool -> [PP_Doc] -> PP_Doc+ppConFields True  flds = ppListSep "{" "}" ", " flds+ppConFields False flds = ppSpaced flds+}+++ATTR EChild    [ | | datatype   : {PP_Doc}+                     recordtype : {PP_Doc} ]+ATTR EChildren [ | | datatype    USE {:} {[]} : {[PP_Doc]}+                     recordtype  USE {:} {[]} : {[PP_Doc]} ]++-- Note: the child may be a higher-order attribute, and its semantics may be deforested+SEM EChild+  | EChild ETerm+      loc.tpDoc  = @loc.addStrict $ pp_parens $ ppTp $ removeDeforested @tp+      loc.strNm  = recordFieldname @lhs.nt @lhs.con @name+      loc.field  = if dataRecords @lhs.options+                   then @loc.strNm >#< "::" >#< @loc.tpDoc+                   else @loc.tpDoc+      loc.recordfield  = @loc.strNm >#< "::" >#< @loc.tpDoc+      loc.addStrict = \x -> if strictData @lhs.options then "!" >|< x else x+  | EChild  lhs.datatype = case @kind of+                             ChildAttr -> empty  -- higher order attributes are not part of the data type+                             _         -> @loc.field++            lhs.recordtype = case @kind of+                               ChildAttr -> empty  -- higher order attributes are not part of the data type+                               _         -> @loc.recordfield+  | ETerm   lhs.datatype    = @loc.field+            lhs.recordtype  = @loc.recordfield++{+ppTp :: Type -> PP_Doc+ppTp = text . typeToHaskellString Nothing []+}++-------------------------------------------------------------------------------+--  Nonterminal semantic function+-------------------------------------------------------------------------------+SEM ENonterminal+  | ENonterminal loc.fsemname = \x -> "sem_" ++ show x+                 loc.semname = @loc.fsemname @nt+                 loc.frecarg = \t x -> case t of+                                          NT nt _ _ -> pp_parens (@fsemname nt >#< x)+                                          _         -> pp x++                 -- The sem_NT function is lazy in the AST: it depends on the application of "child"+                 -- rules to which extend the AST needs to be constructed.+                 loc.sem_tp  = @loc.quantPP >#< @loc.classPP >#< @nt >#< @loc.t_params >#< "->" >#< @loc.t_type >#< @loc.t_params+                 loc.quantPP = ppQuants @params+                 +                 loc.sem_nt  = @loc.semname >#< "::" >#< @loc.sem_tp+                               >-< case lookup @nt @lhs.typeSyns of+                                      Nothing -> @prods.sem_nt+                                      Just (List t) -> @loc.semname >#< "list" >#< "=" >#< "foldr" >#< @loc.semname >|< "_Cons"+                                                       >#< @loc.semname >|< "_Nil"+                                                       >#< case t of+                                                              NT nt _ _ -> pp_parens ("map" >#< @fsemname nt >#< "list")+                                                              _         -> pp "list"+                                      Just (Maybe t) -> @loc.semname >#< "'Data.Maybe'.Nothing" >#< "=" >#< @loc.semname >|< "_Nothing"+                                                        >-< @loc.semname >#< pp_parens ("'Data.Maybe'.Just just") >#< "="+                                                        >#< @loc.semname >|< "_Just" >#< @frecarg t "just"+                                      Just (Tuple ts) -> @loc.semname >#< pp_parens (ppCommas $ map fst ts) >#< "="+                                                         >#< @loc.semname >|< "_Tuple" >#< ppSpaced (map (\t -> @frecarg (snd t) (show $ fst t)) ts)+                                      Just (Either l r) -> @loc.semname >#< "('Data.Either'.Left left)" >#< "=" >#< @loc.semname >|< "_Left" >#< @frecarg l "left"+                                                           >-< @loc.semname >#< "('Data.Either'.Right right)" >#< "=" >#< @loc.semname >|< "_Right" >#< @frecarg r "right"+                                      Just (Map k v) -> @loc.semname >#< "m" >#< "=" >#< "'Data.Map'.foldrWithKey"+                                                        >#< @loc.semname >|< "_Entry" >#< @loc.semname >|< "_Nil"+                                                        >#< case v of+                                                               NT nt _ _ -> pp_parens ("'Data.Map'.map" >#< @fsemname nt >#< "m")+                                                               _         -> pp "m"+                                      Just (IntMap v) -> @loc.semname >#< "m" >#< "=" >#< "'Data.IntMap'.foldWithKey"+                                                         >#< @loc.semname >|< "_Entry" >#< @loc.semname >|< "_Nil"+                                                         >#< case v of+                                                                NT nt _ _ -> pp_parens ("'Data.IntMap'.map" >#< @fsemname nt >#< "m")+                                                                _         -> pp "m"+                                      Just (OrdSet t) -> @loc.semname >#< "s" >#< "=" >#< "foldr" >#< @loc.semname >|< "_Entry"+                                                         >#< @loc.semname >|< "_Nil"+                                                         >#< pp_parens (+                                                               ( case t of+                                                                   NT nt _ _ -> pp_parens ("map" >#< @fsemname nt)+                                                                   _         -> empty+                                                               ) >#< pp_parens ("'Data.IntSet'.elems" >#< "s")+                                                             )+                                      Just IntSet     -> @loc.semname >#< "s" >#< "=" >#< "foldr" >#< @loc.semname >|< "_Entry"+                                                         >#< @loc.semname >|< "_Nil"+                                                         >#< pp_parens ("'Data.IntSet'.elems" >#< "s")+--                                      Just x -> error $ "Type " ++ show x ++ " is not supported yet" -- TODO: other typeSyns++-- The number of productions+ATTR EProductions EProduction [ | | count USE {+} {0} : {Int} ]+SEM EProduction | EProduction  lhs.count = {1}++-- The per-production cases for the sem_NT function+ATTR EProduction EProductions [ | | sem_nt USE {>-<} {empty} : {PP_Doc} ]+SEM EProduction+  | EProduction lhs.sem_nt = let lhs   = "sem_" >|< @lhs.nt+                                 rhs   = "=" >#< "sem_" >|< @lhs.nt >|< "_" >|< @con >#< ppSpaced @children.argnamesw+                                 cnnm  = conname @lhs.rename @lhs.nt @con+                             in  if isRecordConstructor @lhs.nt @lhs.constructorTypeMap+                                   then  lhs >#< "{" >#< cnnm >#< "|" >#<+                                         pp_block "" "" "," (zipWith (\l r -> l >#< "=" >#< r) @children.recfields @children.argpats) >#< "}" >#< rhs+                                   else  lhs >#< "(" >#< cnnm >#< ppSpaced @children.argpats >#< ")" >#< rhs++{+isRecordConstructor :: NontermIdent -> Map NontermIdent ConstructorType -> Bool+isRecordConstructor nt ctm = Map.lookup nt ctm == Just RecordConstructor+}++ATTR EChild    [ | | argnamesw              : { PP_Doc } ]+ATTR EChildren [ | | argnamesw USE {:} {[]} : {[PP_Doc]} ]++SEM EChild+  | EChild lhs.argnamesw = case @kind of+                             ChildSyntax     -> "(" >#< "sem_" >|< @loc.nt >#< @name >|< "_" >#< ")"+                             ChildAttr       -> empty  -- no sem-case for a higher-order child+                             ChildReplace tp -> "(" >#< "sem_" >|< extractNonterminal tp >#< @name >|< "_" >#< ")"+  | ETerm  lhs.argnamesw = text $ fieldname @name++-------------------------------------------------------------------------------+--  Types of attributes+-------------------------------------------------------------------------------+ATTR ExecutionPlan+     ENonterminals+     ENonterminal  [ inhmap : {Map NontermIdent Attributes}+                     synmap : {Map NontermIdent Attributes} | | ]++ATTR EProductions EProduction+     ERules ERule+     Patterns Pattern+     Visits+     Visit   [ inhmap : {Attributes}+               synmap : {Attributes}+               allInhmap : {Map NontermIdent Attributes}+               allSynmap : {Map NontermIdent Attributes} | | ]++SEM ENonterminal+  | ENonterminal (Just prods.inhmap) = Map.lookup @nt @lhs.inhmap+                 (Just prods.synmap) = Map.lookup @nt @lhs.synmap+                 prods.allInhmap = @lhs.inhmap+                 prods.allSynmap = @lhs.synmap++-------------------------------------------------------------------------------+--  State datatypes+-------------------------------------------------------------------------------+{type VisitStateState = (VisitIdentifier,StateIdentifier, StateIdentifier)}++ATTR Visit  [ | | allvisits              : { VisitStateState }]+ATTR Visits [ | | allvisits USE {:} {[]} : {[VisitStateState]}]+ATTR EProduction+     EProductions [ | | allvisits: {[VisitStateState]}]++SEM Visit+  | Visit lhs.allvisits = (@ident, @from, @to)++SEM EProductions+  | Cons lhs.allvisits = @hd.allvisits -- just pick the first production+  | Nil  lhs.allvisits = error "Every nonterminal should have at least 1 production"++-- type of tree in a given state s+SEM ENonterminal+  | ENonterminal loc.outedges  = Set.fromList $ map (\(_,f,_) -> f) @prods.allvisits+                 loc.inedges   = Set.fromList $ map (\(_,_,t) -> t) @prods.allvisits+                 loc.allstates = Set.insert @initial $ @loc.inedges `Set.union` @loc.outedges+                 loc.stvisits  = \st -> filter (\(v,f,t) -> f == st) @prods.allvisits+                 loc.t_type    = "T_" >|< @nt+                 loc.lt_type   = "t_" >|< @nt+                 loc.t_params  = ppSpaced @params+                 loc.t_init_icl    = @loc.t_init_dcl >-<+                                     "attach_" >|< @loc.t_type >#< pp_parens (@loc.t_type >#< @loc.lt_type) >#< "=" >#< @loc.lt_type+                 loc.t_init_dcl    = "::" >#< @loc.t_type >#< @loc.t_params >#< "=" >#< @loc.t_type+                                     >#<+                                     pp_parens (+                                     ppMonadType @lhs.options >#< pp_parens (@loc.t_type >|< "_s" >|< @initial >#< @loc.t_params))+                 loc.t_states_icl  = vlist $ map (\st ->+                                       let nt_st = @nt >|< "_s" >|< st+                                           c_st  = "C_" >|< nt_st+                                           inv_st  = "inv_" >|< nt_st+                                           nextVisit = Map.findWithDefault ManyVis st @nextVisits+                                       in  case nextVisit of+                                             NoneVis    -> empty  -- empty semantics+                                             OneVis vId -> inv_st >#< pp_parens (c_st >#< "x") >#< "=" >#< "x"+                                             ManyVis    -> empty+                                           ) $ Set.toList @loc.allstates+                 loc.t_states_dcl  = vlist $ map (\st ->+                                       let nt_st   = @nt >|< "_s" >|< st+                                           t_st    = "T_" >|< nt_st+                                           k_st    = "K_" >|< nt_st+                                           c_st    = "C_" >|< nt_st+                                           inv_st  = "inv_" >|< nt_st+                                           nextVisit = Map.findWithDefault ManyVis st @nextVisits+                                       in  case nextVisit of+                                             NoneVis    -> "::" >#< t_st >#< @loc.t_params >#< "=" >#< c_st  -- empty semantics+                                             OneVis vId -> "::" >#< t_st >#< @loc.t_params >#< "=" >#< c_st >#< (pp_parens (conNmTVisit @nt vId >#< @loc.t_params))+                                             ManyVis    -> "::" >#< t_st >#< @loc.t_params >#< "where" >#< c_st >#< "::" -- TODO : Cleanify+                                                             >#< (pp_braces $ inv_st >#< "::" >#< "!" >|< pp_parens ("E.t:" >#< k_st >#< @loc.t_params >#< "t" >#< "->" >#< "t"))+                                                             >#< "->" >#< t_st >#< @loc.t_params  -- this is a conventional data type, but declared with GADT syntax+                                           ) $ Set.toList @loc.allstates+                                       +-- type of a key which identifies a visit v from state s+SEM ENonterminal+  | ENonterminal loc.k_type   = "K_" ++ show @nt+                 loc.k_states = vlist $ map (\st ->+                                   let nt_st = @nt >|< "_s" >|< st+                                       k_st  = "K_" >|< nt_st+                                       outg  = filter (\(v,f,t) -> f == st) @prods.allvisits+                                       visitlist = vlist $ map (\(v,f,t) ->+                                           @loc.k_type >|< "_v" >|< v >#< "::" >#< k_st >#< @loc.t_params >#< pp_parens (@loc.t_type >|< "_v" >|< v >#< @loc.t_params)+                                            ) outg+                                       nextVisit = Map.findWithDefault ManyVis st @nextVisits+                                       decl = "::" >#< k_st >#< "k" >#< @loc.t_params >#< "where" >-< indent 3 visitlist+                                   in  case nextVisit of+                                         NoneVis  -> empty+                                         OneVis _ -> empty+                                         ManyVis  -> decl+                                   ) $ Set.toList @loc.allstates++-- type of a visit v, with continuation as new state s+ATTR Visit Visits EProduction EProductions [ | | t_visits USE {>-<} {empty} : {PP_Doc} ]++SEM EProductions+  | Cons lhs.t_visits = @hd.t_visits -- just pick the first production++SEM Visit+  | Visit loc.nameT_visit     = conNmTVisit @lhs.nt @ident+          loc.nameTIn_visit   = conNmTVisitIn @lhs.nt @ident+          loc.nameTOut_visit  = conNmTVisitOut @lhs.nt @ident+          loc.nameTNext_visit = conNmTNextVisit @lhs.nt @to++          loc.nextVisitInfo   = Map.findWithDefault ManyVis @to @lhs.nextVisits  -- which visits can we do after we reach the @to state?+          loc.typecon         = case @kind of+                                  VisitPure _  -> empty+                                  VisitMonadic -> ppMonadType @lhs.options++          loc.t_params  = ppSpaced @lhs.params+          lhs.t_visits = "::" >#< @loc.nameT_visit >#< @loc.t_params >#< ":==" >#<+                           pp_parens (@loc.nameTIn_visit >#< @loc.t_params)+                             >#< ( if dummyTokenVisit @lhs.options+                                   then "->" >#< dummyType @lhs.options True  -- Additional (unused though) argument+                                   else empty+                                 )+                             >#< "->" >#< @loc.typecon >#< pp_parens (@loc.nameTOut_visit >#< @loc.t_params)+                         >-< "::" >#< @loc.nameTIn_visit >#< @loc.t_params >#< "=" >#< @loc.nameTIn_visit >#<+                              @loc.inhpart+                         >-< "::" >#< @loc.nameTOut_visit >#< @loc.t_params >#< "=" >#< @loc.nameTOut_visit >#<+                              @loc.synpart >#< case @loc.nextVisitInfo of+                                                 NoneVis    -> empty                    -- don't return a continuation at all+                                                 _          -> @loc.addbang1 $ pp_parens (@loc.nameTNext_visit >#< @loc.t_params)  -- normal route: select the next semantics++          loc.inhpart   = @loc.ppTypeList @inh @lhs.inhmap+          loc.synpart   = @loc.ppTypeList @syn @lhs.synmap+          loc.ppTypeList = \s m -> ppSpaced $ map (\i -> @loc.addbang1 $ pp_parens $ case Map.lookup i m of+                                                                                      Just tp -> ppTp tp ) $ Set.toList s++{+conNmTVisit nt vId      = "T_" >|< nt >|< "_v"    >|< vId+conNmTVisitIn nt vId    = "T_" >|< nt >|< "_vIn"  >|< vId+conNmTVisitOut nt vId   = "T_" >|< nt >|< "_vOut" >|< vId+conNmTNextVisit nt stId = "T_" >|< nt >|< "_s"    >|< stId++ppMonadType :: Options -> PP_Doc+ppMonadType opts+  | parallelInvoke opts = text "IO"+  | otherwise           = text "Identity"+}++-------------------------------------------------------------------------------+--  Inh and Syn wrappers+-------------------------------------------------------------------------------+SEM ENonterminal+  | ENonterminal loc.wr_inh_icl   = @loc.genwrap_icl "Inh" @loc.wr_inhs+                 loc.wr_syn_icl   = @loc.genwrap_icl "Syn" @loc.wr_syns+                 loc.genwrap_icl  = \nm attr ->+                                      let tyConName = nm >|< "_" >|< @nt+                                      in  (let (d, _, _) = foldr (\(i, t) (d, c, n) -> (d >-<+                                                             i >|< "_" >|< tyConName >#< "::" >#< tyConName >#< "->" >#< (@loc.addbang $ pp_parens $ typeToHaskellString (Just @nt) [] t)+                                                             >-< i >|< "_" >|< tyConName >#< pp_parens (tyConName >#< unwords (replicate (n - c - 1) "_" ++ ["x"] ++ replicate c "_")) >#< "= x"+                                                             , c + 1, n)+                                                             ) (empty, 0, length attr) attr+                                          in  d)+                 loc.wr_inh_dcl   = @loc.genwrap_dcl "Inh" @loc.wr_inhs+                 loc.wr_syn_dcl   = @loc.genwrap_dcl "Syn" @loc.wr_syns+                 loc.genwrap_dcl  = \nm attr ->+                                      let tyConName = nm >|< "_" >|< @nt+                                      in  "::" >#< tyConName >#< @loc.t_params >#< "=" >#< tyConName -- >#< "{"+                                          >#< (ppSpaced $ map (\(_,t) -> @loc.addbang $ pp_parens $ typeToHaskellString (Just @nt) [] t) attr) -- >#< "}"+                                          >-<+                                              (let (d, _, _) = foldr (\(i, t) (d, c, n) -> (d >-<+                                                                i >|< "_" >|< tyConName >#< "::" >#< tyConName >#< "->" >#< (@loc.addbang $ pp_parens $ typeToHaskellString (Just @nt) [] t)+                                                                , c + 1, n)+                                                                ) (empty, 0, length attr) attr+                                              in  d)+                 loc.synAttrs = fromJust $ Map.lookup @nt @lhs.inhmap+                 loc.wr_inhs  = Map.toList $ @loc.wr_filter $ @loc.synAttrs+                 loc.wr_inhs1 = Map.toList @loc.synAttrs+                 loc.wr_filter = if lateHigherOrderBinding @lhs.options+                                 then Map.delete idLateBindingAttr+                                 else id+                 loc.wr_syns  = Map.toList $ fromJust $ Map.lookup @nt @lhs.synmap+                 loc.inhlist  = map (lhsname @lhs.options True . fst) @loc.wr_inhs+                 loc.inhlist1 = map (lhsname @lhs.options True . fst) @loc.wr_inhs1+                 loc.synlist  = map (lhsname @lhs.options False . fst) @loc.wr_syns+                 loc.wrapname = "wrap_" ++ show @nt+                 loc.inhname  = "Inh_" ++ show @nt+                 loc.synname  = "Syn_" ++ show @nt+                 loc.firstVisitInfo = Map.findWithDefault ManyVis @initial @nextVisits+                 loc.wrapper_icl  = (@loc.wrapname >#< "::" >#< @loc.quantPP >#< @loc.classPP >#< @loc.t_type >#< @loc.t_params -- TODO : Remove ? >#< "->"+                                          >#< @loc.inhname >#< @loc.t_params >#< "->" >#< ( if monadicWrappers @lhs.options then ppMonadType @lhs.options else empty) >#< pp_parens (@loc.synname >#< @loc.t_params))+                                    >-< (@loc.wrapname >#< (@loc.addbang $ pp_parens (@loc.t_type >#< pp "act"))+                                        >#< (@loc.addbang $ pp_parens (@loc.inhname+                                               >#< (ppSpaced $ map (@loc.addbangWrap . pp) @loc.inhlist)) >#< "="))+                                    >-<+                                    indent 3 (case @initialv of+                                      -- case where there are no inherited or synthesized attributes+                                      [] -> text @loc.synname -- TODO : Remove? >#< " { }"+                                      (initv:_) -> -- TODO: take care of multiple visits+                                        let inCon  = conNmTVisitIn @nt initv+                                            outCon = conNmTVisitOut @nt initv+                                            pat    = @loc.addbang $ pp_parens $ pat0+                                            pat0   = outCon >#< ppSpaced @loc.synlist -- should be an "end" state, thus no continuation expected here+                                            arg    = inCon >#< ppSpaced @loc.inhlist1+                                            ind    = case @loc.firstVisitInfo of+                                                       NoneVis  -> error "wrapper: initial state should have a next visit but it has none"+                                                       OneVis _ -> empty+                                                       ManyVis  -> @loc.k_type >|< "_v" >|< initv+                                            extra  = if dummyTokenVisit @lhs.options+                                                     then pp $ dummyArg @lhs.options True+                                                     else empty+                                            convert = case Map.lookup initv @lhs.allVisitKinds of+                                                        Just kind -> case kind of+                                                                       VisitPure _  -> text "lift"+                                                                       VisitMonadic -> empty+                                                        _         -> empty+                                            unMonad | monadicWrappers @lhs.options = empty+                                                    | otherwise                    = unMon @lhs.options+                                        in unMonad >#< "("+                                           >-< indent 2+                                                 ("act >>= \\" >#< @loc.addbang (pp "sem") >#< "->"   -- run the per-node monadic code to get the initial state (of the root)+                                                 >-< "lift" >#< pp_parens arg >#< ">>= \\" >#< @loc.addbangWrap (pp "arg") >#< "->"+                                                 >-< convert >#< pp_parens ("inv_" >|< @nt >|< "_s" >|< @initial >#< "sem" >#< ind >#< "arg" >#< extra) >#< ">>= \\" >#< pat >#< "->"  -- invoke initial state (of the root)+                                                 >-< "lift" >#< pp_parens (@loc.synname >#< ppSpaced @loc.synlist)+                                                 )+                                           >-< ")" )+                                    >-< if lateHigherOrderBinding @lhs.options+                                        then indent 2 ("where" >#< lhsname @lhs.options True idLateBindingAttr >#< "=" >#< lateBindingFieldNm @lhs.mainName)+                                        else empty+                 loc.wrapper_dcl  = (@loc.wrapname >#< "::" >#< @loc.quantPP >#< @loc.classPP >#< @loc.t_type >#< @loc.t_params -- TODO : Remove ? >#< "->"+                                          >#< @loc.inhname >#< @loc.t_params >#< "->" >#< ( if monadicWrappers @lhs.options then ppMonadType @lhs.options else empty) >#< pp_parens (@loc.synname >#< @loc.t_params))++-------------------------------------------------------------------------------+--  Collection of NT / Production sem funs references+-------------------------------------------------------------------------------++ATTR ENonterminals ENonterminal EProductions EProduction [ | | semFunBndDefs, semFunBndTps USE {Seq.><} {Seq.empty} : {Seq PP_Doc} ]+SEM ENonterminal | ENonterminal+  lhs.semFunBndDefs = @loc.semFunBndDef Seq.<| @prods.semFunBndDefs+  lhs.semFunBndTps  = @loc.semFunBndTp Seq.<| @prods.semFunBndTps+  loc.semFunBndDef  = @loc.semFunBndNm >#< "=" >#< @loc.semname+  loc.semFunBndTp   = @loc.semFunBndNm >#< "::" >#< @loc.sem_tp+  loc.semFunBndNm   = lateSemNtLabel @nt++SEM EProduction | EProduction+  lhs.semFunBndDefs = Seq.singleton @loc.semFunBndDef+  lhs.semFunBndTps  = Seq.singleton @loc.semFunBndTp+  loc.semFunBndDef  = @loc.semFunBndNm >#< "=" >#< @loc.semname+  loc.semFunBndTp   = @loc.semFunBndNm >#< "::" >#< @loc.sem_tp+  loc.semFunBndNm   = lateSemConLabel @lhs.nt @con++-- Generate a dictionary that contains the semantics of all semantic functions+SEM ExecutionPlan | ExecutionPlan+  loc.wrappersExtra = if lateHigherOrderBinding @lhs.options+                      then @loc.lateSemBndDef+                      else empty+  loc.commonExtra   = if lateHigherOrderBinding @lhs.options+                      then @loc.lateSemBndTp+                      else empty+  loc.lateSemBndTp = "::" >#< lateBindingTypeNm @lhs.mainName >#< "=" >#< lateBindingTypeNm @lhs.mainName+                      >-< (indent 2 $ pp_block "{" "}" "," $ toList @nonts.semFunBndTps)+  loc.lateSemBndDef = lateBindingFieldNm @lhs.mainName >#< "::" >#< lateBindingTypeNm @lhs.mainName+                      >-< lateBindingFieldNm @lhs.mainName >#< "=" >#< lateBindingTypeNm @lhs.mainName+                      >-< (indent 2 $ pp_block "{" "}" "," $ toList @nonts.semFunBndDefs )++-------------------------------------------------------------------------------+--  Production semantic functions+-------------------------------------------------------------------------------+ATTR EProduction  [ | | sem_prod                       : {PP_Doc}+                        sem_prod_tys                   : {PP_Doc} ]+ATTR EProductions [ | | sem_prod USE {>-<} {empty}     : {PP_Doc}+                        sem_prod_tys USE {>-<} {empty} : {PP_Doc} ]++ATTR EProduction EProductions [ initial : {StateIdentifier}+                                allstates : {Set StateIdentifier} | | ]+SEM ENonterminal+  | ENonterminal prods.initial   = @initial+                 prods.allstates = @loc.allstates+                                          +ATTR EChild    [ | | argtps                  : {  PP_Doc  }+                     argpats                 : {  PP_Doc  }+                     recfields USE {++} {[]} : { [Identifier] }]+ATTR EChildren [ | | argtps    USE {:}  {[]} : { [PP_Doc] }+                     argpats   USE {:}  {[]} : { [PP_Doc] }+                     recfields USE {++} {[]} : { [Identifier] }]++SEM EChild+  | EChild lhs.argtps   = case @kind of+                            ChildSyntax     -> pp_parens $ ppDefor @tp -- TODO Remove? >#< "->"+                            ChildReplace tp -> pp_parens $ ppDefor tp -- TODO Remove? >#< "->"+                            _               -> empty  -- higher order attribute+           loc.argpats = case @kind of+                           ChildSyntax    -> @name >|< "_"                    -- no strictification of children semantics to allow infinite trees+                           ChildReplace _ -> @name >|< "_"+                           _              -> empty+                           +           lhs.recfields = case @kind of+                             ChildSyntax    -> [@name]                    -- no strictification of children semantics to allow infinite trees+                             ChildReplace _ -> [@name]+                             _              -> []+                           + -- | ETerm  lhs.argtps  = (pp_parens $ show @tp) >#< "572->" -- TODO Remove?+  | ETerm  lhs.argtps    = pp_parens $ show @tp+           loc.argpats   = @loc.addbang $ text $ fieldname @name   -- terminals may be strict (perhaps this should become an option)+           lhs.recfields = [@name]++{+ppDefor :: Type -> PP_Doc+ppDefor (NT nt args _) = "T_" >|< nt >#< ppSpaced (map pp_parens args)+ppDefor (Haskell s)    = text s+}++SEM EProduction+  | EProduction loc.t_type   = "T_" >|< @lhs.nt+                loc.t_params = ppSpaced @lhs.params+                loc.usedArgs = @children.usedArgs `Set.union` @visits.usedArgs `Set.union` @rules.usedArgs+                -- A bit ugly, but this code renames arguments and puts an underscore when the argument+                -- is never used. This avoids compiler warnings of unused variables.+                loc.args     = map (\x -> let (name,arg) = case show x of +                                                       ""       -> ("", empty)+                                                       '!':name -> ("arg_" ++ name, "!arg_" >|< name)+                                                       name     -> ("arg_" ++ name, "arg_"  >|< name)+                                          in  if null name || name `Set.member` @loc.usedArgs+                                                            then arg+                                                            else text "_") @children.argpats+                loc.semname  = "sem_" ++ show @lhs.nt ++ "_" ++ show @con+                loc.sem_tp   = @loc.quantPP2 >#< @loc.classPP2 >#< ppSpaced @children.argtps+                               >#< (if length @children.argtps > 0 then "->" else "")+                               >#< @loc.t_type >#< @loc.t_params -- TODO Keep -> here?+                loc.classPP2 = ppClasses (classCtxsToDocs @lhs.classCtxs ++ classConstrsToDocs @constraints)+                loc.quantPP2 = ppQuants (@lhs.params ++ @params)+                +                lhs.sem_prod_tys = @loc.semname >#< " ::" >#< @loc.sem_tp+                +                loc.sem_prod = @loc.semname >#< " ::" >#< @loc.sem_tp+                               >-< @loc.mkSemBody (@loc.semname >#< ppSpaced @loc.args >#< "=" >#< @loc.t_type)+                                                  @loc.mbInitializer @loc.outerlet ("lift" >#< "st" >|< @lhs.initial)+                loc.mkSemBody = \prefix mbInit outerlet ret ->+                                  case mbInit of+                                    Nothing -> prefix >#< pp_parens ret >#< "where"+                                               >-< indent 3 outerlet  -- code for states and visits+                                    Just m  -> prefix >#< "(" >#< "do" -- TODO: desugar+                                               >-< indent 1 (+                                                     m+                                                     >-< "let"+                                                     >-< indent 2 outerlet -- code for the states and visits+                                                     >-< ret )+                                               >-< indent 1 ")"++                loc.mbInitializer   = --some monadic actions, performed upon attaching a child, can+                                      -- be specified here. The resulting bindings of these actions are+                                      -- in scope of the rules of the production+                                      if parallelInvoke @lhs.options+                                      then (Nothing :: Maybe PP_Doc)  -- perhaps do some per-node registation, etc. For now: nothing+                                      else Nothing  -- nothing special here+                loc.outerlet = vlist @loc.statefns >-< @rules.sem_rules+                loc.statefns = map @loc.genstfn $ Set.toList @lhs.allstates+                loc.genstfn  = \st -> let nextVisitInfo = Map.findWithDefault ManyVis st @lhs.nextVisits+                                          prevVisitInfo = Map.findWithDefault ManyVis st @lhs.prevVisits+                                          stNm = "st" >|< st+                                          lhs  = bang stNm >#< "=" >#<+                                                 ( -- generating a lambda for the same reasons as generating+                                                   -- a lambda for rules: to ensure that overloading is+                                                   -- resolved for all visit functions and rules together.+                                                   if st == @lhs.initial+                                                   then empty+                                                   else "\\" >#< @loc.stargs st >#< "->"+                                                 )++                                          cCon = "C_" >|< @lhs.nt >|< "_s" >|< st+                                          bang | st == @lhs.initial = @loc.addbang  -- initial state is not parameterized+                                               | otherwise          = id++                                          -- note about the initial state: the initial state should be the only+                                          -- state-binding that is not a function. It is non-recursive and not needed+                                          -- anywhere except delivered as initial result. This binding therefore does+                                          -- not end up needlessly in any closure.+                                      in case nextVisitInfo of+                                           NoneVis    -> -- the (empty) closure of a (non-initial) end state is not referenced+                                                         -- thus generating it is not needed (and omitting it may catch some small mistakes).+                                                         if st == @lhs.initial+                                                         then lhs >#< cCon  -- empty state+                                                         else empty -- no state generated+                                           OneVis vId -> mklet lhs (@loc.stvs st False) (cCon >#< "v" >|< vId)+                                           ManyVis    -> mklet lhs (@loc.stks st >-< @loc.stvs st True) (cCon >#< "k" >|< st)+                loc.stargs   = \st -> let attrs = maybe Map.empty id $ Map.lookup st @visits.intramap+                                      in ppSpaced [ let match | str `Set.member` @loc.lazyIntras = pp str+                                                              | otherwise                        = @loc.addbang (pp str)+                                                    in case mbAttr of+                                                         Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) ->+                                                           case Map.lookup nm @loc.localAttrTypes of+                                                             Just tp -> pp_parens (pp_parens match >#< "::" >#< ppTp tp)+                                                             Nothing -> match+                                                         Just attr | not (noPerStateTypeSigs @lhs.options) ->+                                                           case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @loc.childTypes of+                                                             Just tpDoc -> pp_parens (pp_parens match >#< "::" >#< tpDoc)+                                                             Nothing    -> match+                                                         _ -> match+                                                 | (str,mbAttr) <- Map.assocs attrs+                                                 ] >#< dummyPat @lhs.options (Map.null attrs)++                loc.stks     = \st -> if null (@loc.stvisits st)+                                      then empty+                                      else "k" >|< st >#< "::" >#< "K_" >|< @lhs.nt >|< "_s" >|< st >#< @loc.t_params >#< "t" >#< "->" >#< "t"+                                           >-< vlist (map (\(v,f,t) -> "k" >|< st >#< "K_" >|< @lhs.nt >|< "_v" >|< v >#< "="+                                                                  >#< "v" >|< v) $ @loc.stvisits st)+                loc.stvisits = \st -> filter (\(v,f,t) -> f == st) @visits.allvisits+                loc.stvs     = \st inlinePragma -> vlist [ppf inlinePragma | (f,ppf) <- @visits.sem_visit, f == st]+                visits.mrules = @rules.mrules++{+mklet :: (PP a, PP b, PP c) => a -> b -> c -> PP_Doc+mklet prefix defs body =+  prefix+  >-< indent (length (show prefix))+    ("let"+     >-< indent 4 defs+     >-< "in" >#< body)+}++-------------------------------------------------------------------------------+--  Visit semantic functions+-------------------------------------------------------------------------------+ATTR Visit  [ | | sem_visit              : {  (StateIdentifier,Bool -> PP_Doc)  } ]+ATTR Visits [ | | sem_visit USE {:} {[]} : { [(StateIdentifier,Bool -> PP_Doc)] } ]++SEM Visit+  | Visit lhs.sem_visit = ( @from+                          , \_ ->+                               -- TODO: Generate type signature "v" >|< @ident >#< "::" >#< @loc.nameTIn_visit >#< "->" >#< @loc.nameT_visit >#< @loc.t_params >-< ++                                      -- Haskell: generate a lambda here as well instead of a function definition+                              -- >-< "v" >|< @ident >#< "=" >#< "\\" >#< (@loc.addbang $ pp_parens (@loc.nameTIn_visit >#< @loc.inhpats))+                              -- Clean: generate a function+                               "v" >|< @ident >#< (@loc.addbang $ pp_parens (@loc.nameTIn_visit >#< @loc.inhpats)) >#< "="+                               >#< ( if dummyTokenVisit @lhs.options+                                     then pp $ dummyPat @lhs.options True  -- extra (but unused) argument+                                     else empty+                                   )+                               -- >#< "->"+                               -- >#< "("+                               >-< indent 10 (@loc.stepsInitial+                               >-< indent 4 @steps.sem_steps) >-< indent 10 @loc.stepsClosing+                               -- >#< ")"+                          )+          loc.stepsInitial = case @kind of+                               VisitPure False -> text "let"+                               VisitPure True  -> empty+                               VisitMonadic    -> text "do"+          loc.stepsClosing  = let decls =  @loc.nextStBuild+                                           >-<  @loc.addbang (pp resultValName) >#< "=" >#< @loc.resultval+                              in case @kind of+                                   VisitPure False -> indent 4 decls+                                                      >-< "in" >#< resultValName+                                   VisitPure True  -> "let" >#< decls+                                                      >-< indent 1 ("in" >#< resultValName)+                                   VisitMonadic    -> "let" >#< decls+                                                      >-< "lift" >#< resultValName+          loc.vname     = "v" >|< @ident+          loc.inhpats   = ppSpaced $ map (\arg -> pp $ attrname @lhs.options True _LHS arg) $ Set.toList @inh+          loc.inhargs   = \chn -> ppSpaced $ map (attrname @lhs.options False chn) $ Set.toList @inh+          loc.synargs   = ppSpaced $ map (\arg -> attrname @lhs.options False _LHS arg) $ Set.toList @syn+          loc.nextargsMp = maybe Map.empty id $ Map.lookup @to @lhs.allintramap+          loc.nextargs  = ppSpaced $ Map.keys $ @loc.nextargsMp+          loc.nextst    = "st" >|< @to >#< @loc.nextargs >#< dummyArg @lhs.options (Map.null @loc.nextargsMp)+          loc.resultval = @loc.nameTOut_visit >#< @loc.synargs >#< @loc.nextStRef+          (loc.nextStBuild, loc.nextStRef)+            = case @loc.nextVisitInfo of+                NoneVis  -> (empty, empty)+                _        -> (@loc.addbang (pp nextStName) >#< "=" >#< @loc.nextst, pp nextStName)++{+resultValName :: String+resultValName = "ag__result_"++nextStName :: String+nextStName = "ag__st_"+}++-- Propagate the visit kind to the steps+ATTR VisitStep VisitSteps [ kind : VisitKind | | ]+SEM Visit | Visit  steps.kind = @kind++-- the steps in this group should be executed in a pure fashion+SEM VisitStep | PureGroup+  steps.kind = VisitPure @ordered++ATTR Visits Visit VisitStep VisitSteps [  mrules : {Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)} | | ]+ATTR VisitStep VisitSteps [ | | sem_steps USE {>-<} {empty} : {PP_Doc} ]+SEM VisitStep+  | Sem        loc.ruleItf = Map.findWithDefault (error $ "Rule "  ++ show @name  ++ " not found") @name @lhs.mrules+               (lhs.errors, loc.sem_steps) = case @loc.ruleItf @lhs.kind @lhs.fmtMode of+                                               Left e     -> (Seq.singleton e, empty)+                                               Right stmt -> (Seq.empty, stmt)+  | ChildIntro loc.attachItf = Map.findWithDefault (error $ "Child " ++ show @child ++ " not found") @child @lhs.childintros+               (lhs.errors,lhs.sem_steps,lhs.defs,lhs.uses)+                 = case @loc.attachItf @lhs.kind @lhs.fmtMode of+                     Left e                   -> (Seq.singleton e, empty, Set.empty, Map.empty)+                     Right (code, defs, uses) -> (Seq.empty, code, defs, uses)+  | ChildVisit loc.visitItf = Map.findWithDefault (error $ "Visit " ++ show @visit ++ " not found") @visit @lhs.allchildvisit+               (lhs.errors, loc.patPP, loc.exprPP) = case @loc.visitItf @child @lhs.kind of+                                                       Left e           -> (Seq.singleton e, empty, empty)+                                                       Right (pat,expr) -> (Seq.empty, pat, expr)++               lhs.sem_steps = let decl = case @lhs.kind of+                                            VisitPure _  -> @loc.patPP >#< "=" >#< @loc.exprPP+                                            VisitMonadic -> @loc.exprPP >#< ">>= \\" >#< @loc.patPP >#< "->"+                               in fmtDecl False @lhs.fmtMode decl+               loc.convToMonad = case @loc.callKind of+                                   VisitPure _  -> text "lift"+                                   VisitMonadic -> empty+               loc.callKind  = Map.findWithDefault (error "visit kind should be in the map") @visit @lhs.allVisitKinds+  | Sim        lhs.sem_steps = @steps.sem_steps+  | PureGroup  lhs.sem_steps = case @lhs.fmtMode of+                                 FormatDo -> "let" >#< @steps.sem_steps  -- formatted as a let-block (not a line-let)+                                 _        -> @steps.sem_steps++-- The fmtMode indicates in what kind of expression (do/let/line-lets) we are printing+-- declarations, because that determines how we need to wrap declarations+-- Invariant: @lhs.kind == VisitMonadic ---> @lhs.fmtMode == FormatDo+ATTR VisitSteps VisitStep [ fmtMode : FormatMode | | ]+SEM Visit | Visit+  steps.fmtMode = case @kind of+                    VisitPure False -> FormatLetDecl+                    VisitPure True  -> FormatLetLine+                    VisitMonadic    -> FormatDo++SEM VisitStep | PureGroup+  steps.fmtMode = case @lhs.fmtMode of+                    FormatDo      -> FormatLetDecl+                    mode          -> mode++{+parResultName :: String+parResultName = "__outcome_"++fmtDecl :: PP a => Bool -> FormatMode -> a -> PP_Doc+fmtDecl declPure fmt decl = case fmt of+  FormatLetDecl -> pp decl+  FormatLetLine -> "let" >#< decl >#< "in"+  FormatDo | declPure  -> "let" >#< decl >#< "in"+           | otherwise -> pp decl+}++--+-- Some properties of VisitStep(s)+--++-- Used arguments+ATTR VisitSteps VisitStep Visit Visits EChild EChildren ERule ERules [ | | usedArgs USE {`Set.union`} {Set.empty} : {Set String} ]+SEM ERule+  | ERule +usedArgs = Set.union $ Map.keysSet $ Map.mapKeys (\a -> "arg_" ++ a) $ Map.filter isNothing @rhs.attrs++SEM EChild+  | EChild +usedArgs = \s -> case @kind of+                             ChildSyntax -> Set.insert ("arg_" ++ show @name ++ "_") s+                             _           -> s+++-- Number of steps in a 'Sim' block+ATTR VisitSteps [ | | size : Int ]+SEM VisitSteps+  | Nil  lhs.size = 0+  | Cons lhs.size = 1 + @tl.size++-- Number the steps in a 'Sim' block+ATTR VisitSteps VisitStep [ | index : Int | ]+SEM VisitSteps | Cons+  hd.index  = @lhs.index  -- copy rule+  tl.index  = 1 + @lhs.index+  lhs.index = @tl.index   -- copy rule+SEM Visit | Visit    steps.index = 0+SEM VisitStep | Sim  steps.index = 0+                     lhs.index   = @lhs.index  -- needed for if we ever allow nested Sims++-- Is this the last step?+ATTR VisitSteps VisitStep [ | | isLast : Bool ]+ATTR VisitStep [ isLast : Bool | | ]+SEM VisitSteps+  | Nil   lhs.isLast = True+  | Cons  lhs.isLast = False+          hd.isLast  = @tl.isLast++SEM VisitStep | Sim+                     loc.isMonadic   = case @lhs.kind of+                                         VisitMonadic -> True+                                         _            -> False+++-- Child introduction+ATTR EChild EChildren [ | | childintros USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} ]++ATTR Visits Visit+     VisitSteps VisitStep [ childintros : {Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} | | ]++SEM EProduction+  | EProduction visits.childintros = @children.childintros++SEM EChild+  | ETerm  lhs.childintros = Map.singleton @name (\_ _ -> Right (empty, Set.empty, Map.empty))+  | EChild lhs.childintros = Map.singleton @name @loc.introcode+           loc.isDefor     = case @tp of+                               NT _ _ defor -> defor+                               _            -> False+           loc.valcode     = case @kind of+                               ChildSyntax -> "arg_" >|< @name >|< "_"+                               ChildAttr   -> -- decide if we need to invoke the sem-function under the hood+                                              let prefix | not @loc.isDefor = if lateHigherOrderBinding @lhs.options -- && sepsemmods @lhs.options  -- when sepsemmods is not enabled, the indirection can be optimized away+                                                                              then lateSemNtLabel @loc.nt >#< lhsname @lhs.options True idLateBindingAttr+                                                                              else "sem_" >|< @loc.nt+                                                         | otherwise        = empty -- no need to intro a terminal+                                              in pp_parens (prefix >#< instname @name)+                               ChildReplace _ -> -- the higher-order attribute is actually a function that transforms+                                                 -- the semantics of the child (always deforested)+                                                 pp_parens (instname @name >#< @name >|< "_")+           loc.aroundcode  = if @hasAround+                             then locname @lhs.options @name >|< "_around"+                             else empty+           loc.introcode   = \kind fmtMode ->+                                      let pat       = text $ stname @name @loc.initSt+                                          patStrict = @loc.addbang pat+                                          attach    = "attach_T_" >|< @loc.nt >#< pp_parens (@loc.aroundcode >#< @loc.valcode)+                                          runAttach = unMon @lhs.options >#< pp_parens attach+                                          decl      = case kind of+                                                        VisitPure False -> pat >#< "=" >#< runAttach+                                                        VisitPure True  -> patStrict >#< "=" >#< runAttach+                                                        VisitMonadic    -> attach >#< ">>= \\" >#< patStrict >#< "->"+                                      in if compatibleAttach kind @loc.nt @lhs.options+                                         then Right ( fmtDecl False fmtMode decl+                                                    , Set.singleton (stname @name @loc.initSt)  -- variables defined by the child intro+                                                    , case @kind of  -- variables used by the child introduction+                                                        ChildAttr   -> Map.insert (instname @name) Nothing $  -- the sem attr+                                                                         ( if @loc.isDefor || not (lateHigherOrderBinding @lhs.options)+                                                                           then id   -- the sem dictionary attr is not used+                                                                           else Map.insert (lhsname @lhs.options True idLateBindingAttr) (Just $ AttrInh _LHS idLateBindingAttr)+                                                                         ) $+                                                                         ( if @hasAround+                                                                           then Map.insert (locname @lhs.options (@name) ++ "_around") Nothing+                                                                           else id+                                                                         ) $ Map.empty+                                                        ChildReplace _ -> Map.singleton (instname @name) Nothing   -- uses the transformation function+                                                        ChildSyntax    -> Map.empty+                                                    )+                                         else Left $ IncompatibleAttachKind @name kind+           loc.nt       = extractNonterminal @tp++{+stname :: Identifier -> Int -> String+stname child st = "st_" ++ getName child ++ "X" ++ show st++-- should actually return some conversion info+compatibleAttach :: VisitKind -> NontermIdent -> Options -> Bool+compatibleAttach _ _ _ = True++unMon :: Options -> PP_Doc+unMon options+  | parallelInvoke options = text "'System.IO.Unsafe'.unsafePerformIO"    -- IO monad+  | otherwise              = text "'Control.Monad.Identity'.runIdentity"  -- identity monad+}++-- rules+ATTR ERules ERule [ | | sem_rules USE {>-<} {empty} : {PP_Doc}+                        mrules USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)} ]++SEM ERule | ERule+     lhs.sem_rules    = if @loc.used == 0+                        then empty+                        else @loc.rulecode+     loc.rulecode     = ( if @loc.genpragma+                          then @loc.pragma  -- this additional pragma *may* help to give some AG source location in the presence of+                                            -- type errors in the rule. It will definitely not be precise, and may take some additional+                                            -- source space, but let's see if it's worth it in practice.+                          else empty+                        )+                        >-< @loc.lambda+                        >-< indent ((column @rhs.pos - 2) `max` 2)+                              ( if @loc.genpragma+                                then @loc.pragma >-< @rhs.semfunc >-< @loc.endpragma+                                else @rhs.semfunc+                              )+      loc.pragma       = "/*# LINE" >#< show (line @rhs.pos) >#< show (file @rhs.pos) >#< "#*/"+      loc.endpragma    = ppWithLineNr (\ln -> "/*# LINE " ++ show (ln+1) ++ " " ++ show @lhs.mainFile ++ "#*/")+      loc.genpragma    = genLinePragmas @lhs.options && @explicit && @loc.haspos+      loc.haspos       = line @rhs.pos > 0 && column @rhs.pos >= 0 && not (null (file @rhs.pos))++        -- This comment describes the Haskell rationale for lambdas+        -- we generate a simple pattern binding because of overloading-resolving during the type inference process.+        -- The types of the rules are not generalized (nor do we want that - rules are used in a single typing-context).+        -- If overloading is resolved separately, it may not be clear which dictionaries to use. For that all rules have+        -- to be considered together, which is done when we use simple pattern bindings with a lambda expression instead+        -- of a function definition.+        -- Note: we also ensure that all rules are lambda expressions, so that they are not made part of any closures+        -- but are lambda-lifted instead.+      -- loc.lambda       = @name >#< "=" >#< "\\" >#< @loc.argPats >#< dummyPat @lhs.options (Map.null @rhs.attrs) >#< "->"+      +      -- For Clean, we do not want to generate lambdas, but functions instead+      loc.lambda       = @name >#< @loc.argPats >#< dummyPat @lhs.options (Map.null @rhs.attrs) >#< "="++      loc.argPats      = ppSpaced [ let match | str `Set.member` @lhs.lazyIntras = pp str+                                              | otherwise                        = @loc.addbang1 (pp str)+                                    in case mbAttr of+                                         Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) ->+                                           case Map.lookup nm @lhs.localAttrTypes of+                                             Just tp -> pp_parens (pp_parens match) -- TODO Remove? >#< "::" >#< ppTp tp)+                                             Nothing -> match+                                         Just attr | not (noPerRuleTypeSigs @lhs.options) ->+                                           case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @lhs.childTypes of+                                             Just tpDoc -> pp_parens (pp_parens match) -- TODO Remove? >#< "::" >#< tpDoc)+                                             Nothing    -> match+                                         _ -> match+                                  | (str,mbAttr) <- Map.assocs @rhs.attrs+                                  ]+      loc.argExprs     = ppSpaced [ case mbAttr of+                                      Nothing -> "arg_" >|< str+                                      _       -> text str+                                  | (str,mbAttr) <- Map.assocs @rhs.attrs+                                  ]+      loc.stepcode     = \kind fmtMode -> if kind `compatibleRule` @pure+                                          then Right $ let oper | @pure     = "="+                                                                | otherwise = "<-" -- TODO Desugar+                                                           decl = @pattern.sem_lhs >#< oper >#< @name >#< @loc.argExprs >#< dummyArg @lhs.options (Map.null @rhs.attrs)+                                                           tp   = if @pure && not (noPerRuleTypeSigs @lhs.options)+                                                                    then @pattern.attrTypes+                                                                    else empty+                                                       in fmtDecl @pure fmtMode (tp >-< decl)+                                          else Left $ IncompatibleRuleKind @name kind++      lhs.mrules       = Map.singleton @name @loc.stepcode++ATTR Expression [ | | tks : {[HsToken]} ]+SEM Expression+  | Expression lhs.tks = @tks++{+dummyPat :: Options -> Bool -> PP_Doc+dummyPat opts noArgs+  | not noArgs && tupleAsDummyToken opts = empty  -- no unnecessary tuples+  | tupleAsDummyToken opts = if strictDummyToken opts+                             then text "Void"+                             else text "(_)"+  | otherwise              = let match | strictDummyToken opts = "!_"+                                       | otherwise             = "_"+                             in pp_parens (match >#< "::" >#< dummyType opts noArgs)+  where match | strictDummyToken opts = "(!_)"+              | otherwise             = "_"++dummyArg :: Options -> Bool -> PP_Doc+dummyArg opts noArgs+  | not noArgs && tupleAsDummyToken opts = empty    -- no unnecessary tuples+  | tupleAsDummyToken opts = text "Void"+  | otherwise              = text "GHC.Prim.realWorld#"++dummyType :: Options -> Bool -> PP_Doc+dummyType opts noArgs+  | not noArgs && tupleAsDummyToken opts = empty     -- no unnecessary tuples+  | tupleAsDummyToken opts = text "Void"+  | otherwise              = text "(GHC.Prim.State# GHC.Prim.RealWorld)"+}++{+-- rules are "deinlined" to prevent needless code duplication.+-- if there is only a bit of duplication, we allow ghc to decide if it is worth it.+-- if the duplication crosses this threshold, however, we tell ghc definitely not to inline it.+ruleInlineThresholdSoft :: Int+ruleInlineThresholdSoft = 3++ruleInlineThresholdHard :: Int+ruleInlineThresholdHard = 5++reallyOftenUsedThreshold :: Int+reallyOftenUsedThreshold = 12+}++ATTR Expression [ | | pos : {Pos} ]+SEM Expression | Expression lhs.pos = @pos++-- pattern and expression semantics+ATTR Pattern  [ | | sem_lhs              : { PP_Doc } ]+ATTR Patterns [ | | sem_lhs USE {:} {[]} : {[PP_Doc]} ]+ATTR Pattern Patterns [ | | ]++SEM Pattern+  | Alias       loc.varPat    = text $ attrname @lhs.options False @field @attr+                loc.patExpr   = if @pat.isUnderscore+                                then @loc.varPat+                                else @loc.varPat >|< "@" >|< @pat.sem_lhs+                lhs.sem_lhs   = @loc.addbang1 @loc.patExpr+  | Product     lhs.sem_lhs   = @loc.addbang1 $ pp_block "(" ")" "," @pats.sem_lhs+  | Constr      lhs.sem_lhs   = @loc.addbang1 $ pp_parens $ @name >#< hv_sp @pats.sem_lhs+  | Underscore  lhs.sem_lhs   = text "_"+  | Irrefutable lhs.sem_lhs   = text "~" >|< pp_parens @pat.sem_lhs++-- Check if a pattern is just an underscore+ATTR Pattern [ | | isUnderscore:{Bool}]+SEM Pattern+ | Constr      lhs.isUnderscore = False+ | Product     lhs.isUnderscore = False+ | Alias       lhs.isUnderscore = False+ | Underscore  lhs.isUnderscore = True++-- Collect the attributes defined by a pattern+ATTR Pattern Patterns  [ | | attrs USE {`Set.union`} {Set.empty} : {Set String} ]+SEM Pattern | Alias+  lhs.attrs     = Set.insert (attrname @lhs.options False @field @attr) @pat.attrs++-- All attribute types of this pattern+ATTR Pattern Patterns  [ | | attrTypes USE {>-<} {empty} : {PP_Doc} ]+SEM Pattern | Alias+  loc.mbTp      = if @field == _LHS+                  then Map.lookup @attr @lhs.synmap+                  else if @field == _LOC+                       then Map.lookup @attr @lhs.localAttrTypes+                       else Nothing+  lhs.attrTypes = empty -- Don't generate these type signatures; increases performance in Clean+                  -- maybe empty (\tp -> (attrname @lhs.options False @field @attr) >#< "::" >#< ppTp tp) @loc.mbTp+                            -- >-< @pat.attrTypes++-- Collect the attributes used by the right-hand side+ATTR HsToken Expression [ | | attrs USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ]+SEM HsToken+  | AGLocal   lhs.attrs   = Map.singleton (fieldname @var) Nothing+  | AGField   loc.mbAttr  = if @field == _INST || @field == _FIELD || @field == _INST'+                            then Nothing  -- should not be used in the first place+                            else Just $ mkNonLocalAttr (@field == _LHS) @field @attr+              lhs.attrs   = Map.singleton (attrname @lhs.options True @field @attr) @loc.mbAttr++{+data NonLocalAttr+  = AttrInh Identifier Identifier+  | AttrSyn Identifier Identifier deriving Show++mkNonLocalAttr :: Bool -> Identifier -> Identifier -> NonLocalAttr+mkNonLocalAttr True  = AttrInh  -- True: inherited attr+mkNonLocalAttr False = AttrSyn++lookupAttrType :: NonLocalAttr -> Map Identifier Attributes -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc+lookupAttrType (AttrInh child name) inhs _ = lookupType child name inhs+lookupAttrType (AttrSyn child name) _ syns = lookupType child name syns++-- Note: if the child takes type parameters, the type of an attribute of this child may refer to these parameters. This means that+-- the actual type of the attribute needs to have its type parameters substituted with the actual type argument of the child.+-- However, for now we simply decide to return Nothing in this case, which skips the type annotation.+lookupType :: Identifier -> Identifier -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc+lookupType child name attrMp childMp+  | noParameters childTp = Just ppDoc+  | otherwise            = Nothing+  where+    attrTp     = Map.findWithDefault (error "lookupType: the attribute is not in the attrs of the child") name childAttrs+    childAttrs = Map.findWithDefault (error "lookupType: the attributes of the nonterm are not in the map") nonterm attrMp+    nonterm    = extractNonterminal childTp+    childTp    = Map.findWithDefault (error ("lookupType: the child " ++ show child ++ "is not in the appropriate map")) child childMp+    ppDoc      = ppTp attrTp++noParameters :: Type -> Bool+noParameters (Haskell _)   = True+noParameters (NT _ args _) = null args+}++ATTR Expression [ | | semfunc : {PP_Doc} ]++SEM Expression+  | Expression lhs.attrs   = Map.unions $ map (\tok -> attrs_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks+               lhs.semfunc = vlist $ showTokens $ map (\tok -> tok_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks+               loc.inhhstoken = Inh_HsToken @lhs.options++-- child visit map+ATTR Visit+     Visits+     EProduction+     EProductions+     ENonterminal+     ENonterminals [ allchildvisit : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))}+                     | | childvisit USE {`Map.union`} {Map.empty} : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} ]++ATTR VisitSteps VisitStep [ allchildvisit : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} | | ]++SEM ExecutionPlan+  | ExecutionPlan nonts.allchildvisit = @nonts.childvisit++SEM Visit+  | Visit+     loc.prevVisitInfo = Map.findWithDefault ManyVis @from @lhs.nextVisits+     lhs.childvisit = Map.singleton @ident @loc.invokecode+     loc.invokecode = \chn kind ->   -- "chn" is the name of the child at the place of invocation, and "kind" the kind of the calling visit+                        if kind `compatibleKind` @kind+                        then Right $+                          let pat | isLazyKind @kind = pat0+                                  | otherwise        = @loc.addbang pat0+                              pat0  = pp_parens pat1+                              pat1  = @loc.nameTOut_visit >#< (ppSpaced $ map (attrname @lhs.options True chn) $ Set.toList @syn)+                                                          >#< cont+                              cont  = case @loc.nextVisitInfo of+                                        NoneVis  -> empty+                                        _        -> ch1+                              ch0   = text $ stname chn @from+                              ch1   = text $ stname chn @to+                              expr  = case (kind, @kind) of+                                        (VisitPure _,  VisitPure _)  -> expr0+                                        (VisitPure _,  VisitMonadic) -> unMon @lhs.options >#< expr0+                                        (VisitMonadic, VisitPure _)  -> "lift" >#< expr0+                                        (VisitMonadic, VisitMonadic) -> expr0+                              expr0 = case @loc.prevVisitInfo of+                                        NoneVis  -> error "error: invocation of a visit from a state that has no next visits"+                                        OneVis _ -> "inv_" >|< @lhs.nt >|< "_s" >|< @from >#< ch0 >#< args+                                        ManyVis  -> "inv_" >|< @lhs.nt >|< "_s" >|< @from >#< ch0+                                                    >#< "K_" >|< @lhs.nt >|< "_v" >|< @ident >#< args+                              args  = pp_parens args0 >#< args1+                              args0 = @loc.nameTIn_visit >#< @loc.inhargs chn+                              args1 | dummyTokenVisit @lhs.options = pp $ dummyArg @lhs.options True+                                    | otherwise                    = empty+                          in (pat, expr)  -- pretty print of the pattern and the expression part+                        else Left $ IncompatibleVisitKind chn @ident kind @kind++{+-- a `compatibleKind` b  means: can kind b be invoked from a+compatibleKind :: VisitKind -> VisitKind -> Bool+compatibleKind _              _             = True++compatibleRule :: VisitKind -> Bool -> Bool+compatibleRule (VisitPure _) False = False+compatibleRule _             _     = True+}++-------------------------------------------------------------------------------+--  Properties of rules+-------------------------------------------------------------------------------++-- Construct an environment that counts how often certain rules are used+ATTR Visits Visit VisitSteps VisitStep [ | | ruleUsage USE {`unionWithSum`} {Map.empty} : {Map Identifier Int} ]+ATTR ERules ERule [ usageInfo : {Map Identifier Int} | | ]++SEM EProduction | EProduction  rules.usageInfo = @visits.ruleUsage+SEM VisitStep | Sem            lhs.ruleUsage = Map.singleton @name 1+SEM ERule | ERule              loc.used      = Map.findWithDefault 0 @name @lhs.usageInfo++{+unionWithSum = Map.unionWith (+)+}++-- Collect in what visit-kinds a rule is used+ATTR Visits Visit VisitSteps VisitStep [ | | ruleKinds USE {`unionWithMappend`} {Map.empty} : {Map Identifier (Set VisitKind)} ]+SEM VisitStep | Sem+  lhs.ruleKinds = Map.singleton @name (Set.singleton @lhs.kind)++ATTR ERules ERule [ ruleKinds : {Map Identifier (Set VisitKind)} | | ]+SEM EProduction | EProduction+  rules.ruleKinds = @visits.ruleKinds++SEM ERule | ERule+  loc.kinds = Map.findWithDefault Set.empty @name @lhs.ruleKinds+  loc.anyLazyKind = Set.fold (\k r -> isLazyKind k || r) False @loc.kinds++ATTR Pattern Patterns [ anyLazyKind : Bool | | ]+++-------------------------------------------------------------------------------+--  Intra attributes+-------------------------------------------------------------------------------+{+uwSetUnion :: (Ord a, Ord b) => Map a (Set b) -> Map a (Set b) -> Map a (Set b)+uwSetUnion = Map.unionWith Set.union++uwMapUnion :: (Ord a, Ord b) => Map a (Map b c) -> Map a (Map b c) -> Map a (Map b c)+uwMapUnion = Map.unionWith Map.union+}+ATTR Visit Visits [ allintramap : {Map StateIdentifier (Map String (Maybe NonLocalAttr))}+                    | | intramap USE {`uwMapUnion`} {Map.empty} : {Map StateIdentifier (Map String (Maybe NonLocalAttr))} ]++ATTR Visit Visits [ terminaldefs : {Set String} | | ]+ATTR EChild EChildren [ | | terminaldefs USE {`Set.union`} {Set.empty} : {Set String} ]++SEM EChild | ETerm+  lhs.terminaldefs = Set.singleton $ fieldname @name++SEM EProduction | EProduction+  visits.allintramap  = @visits.intramap+  visits.terminaldefs = @children.terminaldefs++SEM Visit+  | Visit loc.thisintra = (@loc.uses `Map.union` @loc.nextintra) `Map.difference` @loc.defsAsMap+          lhs.intramap  = Map.singleton @from @loc.thisintra+          loc.nextintra = maybe Map.empty id $ Map.lookup @to @lhs.allintramap+          loc.uses      = let mp1 = @steps.uses+                              mp2 = Map.fromList [ (lhsname @lhs.options False i, Just (AttrSyn _LHS i)) | i <- Set.elems @syn ]+                          in mp1 `Map.union` mp2+          loc.inhVarNms = Set.map (lhsname @lhs.options True) @inh+          loc.defs      = @steps.defs `Set.union` @loc.inhVarNms `Set.union` @lhs.terminaldefs+          loc.defsAsMap = Map.fromList [ (a, Nothing) | a <- Set.elems @loc.defs ]++ATTR ERule ERules [ | | ruledefs USE {`uwSetUnion`} {Map.empty} : {Map Identifier (Set String)}+                        ruleuses USE {`uwMapUnion`} {Map.empty} : {Map Identifier (Map String (Maybe NonLocalAttr))} ]+ATTR Visit Visits+     VisitSteps VisitStep [ ruledefs  : {Map Identifier (Set String)}+                            ruleuses  : {Map Identifier (Map String (Maybe NonLocalAttr))} | | ]++SEM ERule+  | ERule lhs.ruledefs = Map.singleton @name @pattern.attrs+          lhs.ruleuses = Map.singleton @name @rhs.attrs++SEM EProduction+  | EProduction visits.ruledefs = @rules.ruledefs+                visits.ruleuses = @rules.ruleuses++ATTR Visit Visits+     EProduction+     EProductions+     ENonterminal+     ENonterminals [ | | visitdefs USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (Set Identifier)}+                         visituses USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (Set Identifier)} ]++SEM Visit+  | Visit lhs.visitdefs = Map.singleton @ident @syn+          lhs.visituses = Map.singleton @ident @inh++ATTR Visit Visits+     VisitSteps VisitStep+     EProduction EProductions+     ENonterminal ENonterminals [ avisitdefs : {Map VisitIdentifier (Set Identifier)}+                                  avisituses : {Map VisitIdentifier (Set Identifier)} | | ]++SEM ExecutionPlan+  | ExecutionPlan nonts.avisitdefs = @nonts.visitdefs+                  nonts.avisituses = @nonts.visituses++ATTR VisitSteps VisitStep [ | | defs USE {`Set.union`} {Set.empty} : {Set String}+                                uses USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ]+SEM VisitStep+  | Sem        lhs.defs = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruledefs+               lhs.uses = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruleuses+  | ChildVisit lhs.defs = Set.insert (stname @child @to) $ maybe (error "Visit not found") (Set.map $ attrname @lhs.options True @child) $ Map.lookup @visit @lhs.avisitdefs+               lhs.uses = let convert attrs = Map.fromList [ (attrname @lhs.options False @child attr, Just $ mkNonLocalAttr True @child attr) | attr <- Set.elems attrs ]+                          in Map.insert (stname @child @from) Nothing $ convert $+                               maybe (error "Visit not found") id $ Map.lookup @visit @lhs.avisituses++-------------------------------------------------------------------------------+--  Identification of lazy intra defs within a production+--+-- These identifiers will not be marked as strict in rules and state closures+-------------------------------------------------------------------------------++ATTR Visits Visit VisitSteps VisitStep [ | | lazyIntras USE {`Set.union`} {Set.empty} : {Set String} ]+ATTR ERules ERule [ lazyIntras : {Set String} | | ]++SEM Visit | Visit+  loc.lazyIntrasInh = case @kind of+                        VisitPure False -> @loc.inhVarNms `Set.union` @steps.defs+                        _               -> Set.empty+  lhs.lazyIntras = @loc.lazyIntrasInh `Set.union` @steps.lazyIntras++SEM VisitStep | PureGroup+  lhs.lazyIntras = if @ordered+                   then @steps.lazyIntras+                   else @steps.defs++SEM EProduction | EProduction+  loc.lazyIntras = @visits.lazyIntras++-------------------------------------------------------------------------------+--  Pretty printing of haskell code+-------------------------------------------------------------------------------++SEM HsTokens [ || tks : {[(Pos,String)]} ]+  | Cons lhs.tks = @hd.tok : @tl.tks+  | Nil  lhs.tks = []++SEM HsToken+  | AGLocal   loc.tok = (@pos,fieldname @var)++SEM HsToken [ || tok:{(Pos,String)}]+   | AGField+       loc.addTrace = case @rdesc of+                        Just d  -> \x -> "(trace_n " ++ show (d ++ " -> " ++ show @field ++ "." ++ show @attr) ++ " (" ++ x ++ "))"+                        Nothing -> id+       lhs.tok = (@pos, @loc.addTrace $ attrname @lhs.options True @field @attr)++   | HsToken lhs.tok = (@pos, @value)++   | CharToken lhs.tok = (@pos, if null @value+                                   then ""+                                   else showCharShort (head @value)+                         )++   | StrToken  lhs.tok = (@pos, showStrShort @value)+   | Err       lhs.tok = (@pos, "")++-------------------------------------------------------------------------------+--  Alternative code generation (sepsemmods)+-------------------------------------------------------------------------------++ATTR ExecutionPlan [ mainBlocksDoc : PP_Doc textBlockMap : {Map BlockInfo PP_Doc}+                   | | genIO : {IO ()} ]++SEM ExecutionPlan+  | ExecutionPlan lhs.genIO           = do @loc.genMainModule+                                           @loc.genCommonModule+                                           @nonts.genProdIO+                  loc.mainModuleFile  = @lhs.mainFile+                  loc.ppMonadImports  = pp "import qualified Control.Monad.Identity"+                  loc.genMainModule   = writeModule @loc.mainModuleFile+                                          ( [ pp $ @lhs.iclModuleHeader @lhs.mainName "" "" False+                                            , @loc.ppMonadImports+                                            , pp $ "import " ++ @lhs.mainName ++ "_common"+                                            ]+                                            ++ @nonts.imports+                                            ++ [@lhs.mainBlocksDoc]+                                            ++ [@loc.wrappersExtra]+                                            ++ @nonts.appendMain+                                          )+                  loc.commonFile      = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_common")+                  loc.genCommonModule = writeModule @loc.commonFile+                                          ( [ pp $ @lhs.iclModuleHeader @lhs.mainName "_common" "" True+                                            , @loc.ppMonadImports+                                            , @lhs.importBlocks+                                            , @lhs.textBlocks+                                            , @loc.commonExtra+                                            ]+                                            ++ @nonts.appendCommon+                                          )++ATTR ENonterminal  [ | | appendCommon, appendMain              : { PP_Doc } ]+ATTR ENonterminals [ | | appendCommon, appendMain USE {:} {[]} : {[PP_Doc]} ]++SEM ENonterminal+  | ENonterminal lhs.appendMain   = (if @nt `Set.member` @lhs.wrappers+                                     then     @loc.wr_inh_icl+                                          >-< @loc.wr_syn_icl+                                          >-< @loc.wrapper_icl+                                     else empty)+                                    >-< @loc.sem_nt+                 lhs.appendCommon = (if dataTypes @lhs.options then @loc.datatype else empty)+                                    >-< @loc.t_init_icl+                                    >-< @loc.t_states_icl+                                    >-< @loc.k_states+                                    >-< @prods.t_visits++ATTR EProduction EProductions+     ENonterminal ENonterminals [ | | imports USE {++} {[]} : {[PP_Doc]}+                                      genProdIO USE {>>} {return ()} : {IO ()} ]++SEM EProduction+  | EProduction lhs.imports    = [pp $ "import " ++ @loc.moduleName]+                loc.moduleName = @lhs.mainName ++ @loc.suffix+                loc.suffix     = '_' : show @lhs.nt ++ ('_' : show @con)+                loc.outputfile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ @loc.suffix)+                loc.ppMonadImports  = pp "import qualified Control.Monad.Identity"+                lhs.genProdIO  = writeModule @loc.outputfile+                                     [ pp $ @lhs.iclModuleHeader @lhs.mainName @loc.suffix @loc.semname True+                                     , @lhs.importBlocks+                                     , @loc.ppMonadImports+                                     , pp $ "import " ++ @lhs.mainName ++ "_common"+                                     , @loc.sem_prod+                                     ]++{+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++cleanIclModuleHeader :: Options -> String -> String+cleanIclModuleHeader flags input+ = case moduleName flags+   of Name nm -> genMod nm+      Default -> genMod (defaultModuleName input)+      NoName  -> ""+   where genMod x = "implementation module " ++ x ++cleanDclModuleHeader :: Options -> String -> Maybe String -> String+cleanDclModuleHeader flags input export+ = case moduleName flags+   of Name nm -> genMod nm+      Default -> genMod (defaultModuleName input)+      NoName  -> ""+   where genMod x = "definition module " ++ x ++ genExp export x+         genExp Nothing _ = ""+         genExp (Just e) x = "(module " ++ x ++ ", module " ++ e ++ ")"++defaultModuleName :: String -> String+defaultModuleName = dropExtension++mkIclModuleHeader :: Maybe (String,String,String) -> String -> String -> String -> Bool -> String+mkIclModuleHeader Nothing defaultName suffix _ _+  = "implementation module " ++ defaultName ++ suffix+mkIclModuleHeader (Just (name, exports, imports)) _ suffix addExports replaceExports+  = "implementation module " ++ name ++ suffix ++ "\n" ++ imports ++ "\n"++mkDclModuleHeader :: Maybe (String,String,String) -> String -> String -> String -> Bool -> String+mkDclModuleHeader Nothing defaultName suffix _ _+  = "definition module " ++ defaultName ++ suffix+mkDclModuleHeader (Just (name, exports, _)) _ suffix addExports replaceExports+  = "definition module " ++ name ++ suffix ++ ex ++ "\n"+  where+    ex  = if null exports || (replaceExports && null addExports)+          then ""+          else if null addExports+               then exports+               else if replaceExports+                    then addExports+                    else exports ++ "," ++ addExports+}+++--+-- Bang pattern usage+--++SEM ERule | ERule                   loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x+SEM Visit | Visit                   loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x+SEM ENonterminal | ENonterminal     loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x+SEM EProduction | EProduction       loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x+SEM EChild | EChild                 loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x+SEM EChild | ETerm                  loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x+SEM VisitStep | ChildVisit          loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x+SEM Pattern | Alias Constr Product  loc.addbang  = \x -> if bangpats @lhs.options then "!" >|< x else x++SEM Visit | Visit                   loc.addbang1 = if isLazyKind @kind then id else @loc.addbang+SEM ENonterminal | ENonterminal     loc.addbangWrap = id --if strictWrap @lhs.options then @loc.addbang else id+SEM ERule | ERule                   loc.addbang1 = if @loc.anyLazyKind then id else @loc.addbang+SEM Pattern | Alias Constr Product  loc.addbang1 = if @lhs.anyLazyKind then id else @loc.addbang++--+-- Distribute single-visit-next map downward+--++ATTR EProductions EProduction Visits Visit+  [ prevVisits, nextVisits : {Map StateIdentifier StateCtx} | | ]++SEM ENonterminal | ENonterminal+  prods.nextVisits = @nextVisits+  prods.prevVisits = @prevVisits++--+-- Collect and distribute the from/to states of a visit+--++ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit+  [ | | fromToStates USE {`mappend`} {mempty} : {Map VisitIdentifier (Int,Int)} ]++ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep+  [ allFromToStates : {Map VisitIdentifier (Int,Int)} | | ]++SEM Visit | Visit+  lhs.fromToStates = Map.singleton @ident (@from, @to)++SEM ExecutionPlan | ExecutionPlan+  nonts.allFromToStates = @nonts.fromToStates++SEM VisitStep | ChildVisit+  (loc.from, loc.to) = Map.findWithDefault (error "visit not in allFromToStates") @visit @lhs.allFromToStates+++--+-- Collect and distribute the actual types of children of productions+--++ATTR EChildren EChild [ | | childTypes USE {`mappend`} {mempty} : {Map Identifier Type} ]+ATTR ERules ERule Visits Visit VisitSteps VisitStep [ childTypes : {Map Identifier Type} | | ]++SEM EProduction | EProduction+  loc.childTypes = Map.singleton _LHS @lhs.ntType `Map.union` @children.childTypes++SEM EChild | EChild ETerm+  lhs.childTypes = Map.singleton @name @tp++--+-- Distribute types of local attributes+--++ATTR ExecutionPlan ENonterminals ENonterminal  [ localAttrTypes : {Map NontermIdent (Map ConstructorIdent (Map Identifier Type))} | | ]+ATTR EProductions EProduction                  [ localAttrTypes : {Map ConstructorIdent (Map Identifier Type)} | | ]+ATTR ERules ERule Pattern Patterns             [ localAttrTypes : {Map Identifier Type} | | ]++SEM ENonterminal | ENonterminal+  prods.localAttrTypes = Map.findWithDefault Map.empty @nt @lhs.localAttrTypes++SEM EProduction | EProduction+  loc.localAttrTypes   = Map.findWithDefault Map.empty @con @lhs.localAttrTypes++--+-- Collect and distribute visit kinds+--++ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep+  [ allVisitKinds : {Map VisitIdentifier VisitKind} | | visitKinds USE {`mappend`} {mempty} : {Map VisitIdentifier VisitKind} ]++SEM Visit | Visit+  lhs.visitKinds = Map.singleton @ident @kind++SEM ExecutionPlan | ExecutionPlan+  nonts.allVisitKinds = @nonts.visitKinds++--+-- Collect and distribute the initial state of nonterminals+--++ATTR ENonterminals ENonterminal [ | | initStates USE {`mappend`} {mempty} : {Map NontermIdent Int} ]+ATTR ENonterminals ENonterminal EProductions EProduction EChildren EChild Visits Visit VisitSteps VisitStep+  [ allInitStates : {Map NontermIdent Int} | | ]++SEM ENonterminal | ENonterminal+  lhs.initStates = Map.singleton @nt @initial++SEM ExecutionPlan | ExecutionPlan+  nonts.allInitStates = @nonts.initStates++SEM EChild | EChild+  loc.initSt = Map.findWithDefault (error "nonterminal not in allInitStates map") @loc.nt @lhs.allInitStates++--+-- Push the nonterminal type downward+--++ATTR EProductions EProduction [ ntType : Type | | ]+SEM ENonterminal | ENonterminal+  loc.ntType = NT @nt (map show @params) False++--+-- Collect errors contained in rules that should be yielded when the+-- rules are scheduled.+--++ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule Visits Visit VisitSteps VisitStep [ | | errors USE {Seq.><} {Seq.empty} : {Seq Error} ]+SEM ERule | ERule+  lhs.errors = case @mbError of+                 Just e | @loc.used > 0 -> Seq.singleton e+                 _                      -> Seq.empty+
src-ag/ExecutionPlan2Hs.ag view
@@ -1,1711 +1,1711 @@-INCLUDE "ExecutionPlan.ag"
-INCLUDE "Patterns.ag"
-INCLUDE "Expression.ag"
-INCLUDE "HsToken.ag"
-
-imports
-{
-import ExecutionPlan
-import Pretty
-import PPUtil
-import Options
-import Data.Monoid(mappend,mempty)
-import Data.Maybe
-import Debug.Trace
-import System.IO
-import System.Directory
-import System.FilePath
-import UU.Scanner.Position
-
-import TokenDef
-import HsToken
-import ErrorMessages
-
-import Data.Set (Set)
-import qualified Data.Set as Set
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Data.Sequence(Seq)
-import qualified Data.Sequence as Seq
-import Data.Foldable(toList)
-}
-
-ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule EChildren EChild
-  [ importBlocks : PP_Doc
-    pragmaBlocks : String
-    textBlocks   : PP_Doc
-    moduleHeader : {String -> String -> String -> Bool -> String}
-    mainFile     : String
-    mainName     : String | | ]
-
--------------------------------------------------------------------------------
---  Options
--------------------------------------------------------------------------------
-ATTR ExecutionPlan
-     ENonterminals ENonterminal
-     EProductions EProduction
-     ERules ERule
-     EChildren EChild
-     Expression
-     HsToken HsTokens HsTokensRoot
-     Pattern Patterns
-     Visits Visit
-     VisitSteps VisitStep [ options : {Options} | | ]
-ATTR EProductions EProduction [ rename : {Bool} | | ]
-
-SEM ENonterminal
-  | ENonterminal prods.rename = rename @lhs.options
-
--------------------------------------------------------------------------------
---  Context info (nonterminal ident, constructor ident, nonterm params, etc.)
--------------------------------------------------------------------------------
-
-ATTR Visit Visits EProduction EProductions EChildren EChild ERules ERule [ nt : NontermIdent | | ]
-SEM ENonterminal
-  | ENonterminal prods.nt = @nt
-
-ATTR EChildren EChild ERules ERule Visits Visit
-  [ con : ConstructorIdent | | ]
-
-SEM EProduction
-  | EProduction children.con = @con
-                rules.con    = @con
-                visits.con   = @con
-
-ATTR EProductions EProduction Visits Visit [ params : {[Identifier]} | | ]
-SEM ENonterminal | ENonterminal
-  prods.params = @params
-
-ATTR EProductions EProduction [ classCtxs : ClassContext | | ]
-SEM ENonterminal | ENonterminal
-  prods.classCtxs = @classCtxs
-
--------------------------------------------------------------------------------
---  Default output
--------------------------------------------------------------------------------
-ATTR ExecutionPlan [  | | output : {PP_Doc} ]
-
-SEM ExecutionPlan
-  | ExecutionPlan lhs.output = @nonts.output >-< @loc.commonExtra >-< @loc.wrappersExtra
-
-ATTR ENonterminal ENonterminals [ wrappers : {Set NontermIdent}
-                                 | | output USE {>-<} {empty} : {PP_Doc} ]
-
-SEM ExecutionPlan
-  | ExecutionPlan nonts.wrappers = @wrappers
-
-SEM ENonterminal
-  | ENonterminal lhs.output = ("-- " ++ getName @nt ++ " " ++ replicate (60 - length (getName @nt)) '-')
-                              >-< (if dataTypes @lhs.options
-                                   then "-- data"
-                                        >-< @loc.datatype
-                                        >-< ""
-                                   else empty)
-                              >-< (if @loc.hasWrapper
-                                   then "-- wrapper"
-                                        >-< @loc.wr_inh
-                                        >-< @loc.wr_syn
-                                        >-< @loc.wrapper
-                                        >-< ""
-                                   else empty)
-                              >-< (if   folds @lhs.options
-                                   then "-- cata"
-                                        >-< @loc.sem_nt
-                                        >-< ""
-                                   else empty)
-                              >-< (if   semfuns @lhs.options
-                                   then "-- semantic domain"
-                                        >-< @loc.t_init
-                                        >-< @loc.t_states
-                                        >-< @loc.k_states
-                                        >-< @prods.t_visits
-                                        >-< @prods.sem_prod
-                                        >-< ""
-                                   else empty)
-                 loc.hasWrapper = @nt `Set.member` @lhs.wrappers
-
--------------------------------------------------------------------------------
---  Nonterminal datatype
--------------------------------------------------------------------------------
-ATTR ENonterminal ENonterminals [ typeSyns : {TypeSyns}
-                                  derivings : {Derivings} | | ]
-
-SEM ExecutionPlan
-  | ExecutionPlan nonts.typeSyns = @typeSyns
-                  nonts.derivings = @derivings
-
-SEM ENonterminal
-  | ENonterminal loc.classPP  = ppClasses $ classCtxsToDocs @classCtxs
-                 loc.aliasPre = "type" >#< @loc.classPP >#< @nt >#< @loc.t_params >#< "="
-                 loc.datatype = case lookup @nt @lhs.typeSyns of
-                                   Nothing -> "data" >#< @loc.classPP >#< @nt >#< @loc.t_params
-                                              >-< ( if null @prods.datatype
-                                                    then empty
-                                                    else indent 2 $ vlist $ ( ("=" >#< head @prods.datatype)
-                                                                            : (map ("|" >#<) $ tail @prods.datatype))
-                                                  )
-                                              >-< indent 2 @loc.derivings
-                                   Just (List t)     -> @loc.aliasPre >#< "[" >#< show t >#< "]"
-                                   Just (Maybe t)    -> @loc.aliasPre >#< "Maybe" >#< pp_parens (show t)
-                                   Just (Tuple ts)   -> @loc.aliasPre >#< pp_parens (ppCommas $ map (show . snd) ts)
-                                   Just (Either l r) -> @loc.aliasPre >#< "Either" >#< pp_parens (show l) >#< pp_parens (show r)
-                                   Just (Map k v)    -> @loc.aliasPre >#< "Data.Map" >#< pp_parens (show k) >#< pp_parens (show v)
-                                   Just (IntMap t)   -> @loc.aliasPre >#< "Data.IntMap.IntMap" >#< pp_parens (show t)
-                                   Just (OrdSet t)   -> @loc.aliasPre >#< "Data.Set.Set" >#< pp_parens (show t)
-                                   Just IntSet       -> @loc.aliasPre >#< "Data.IntSet.IntSet"
---                                   Just x -> error $ "Type " ++ show x ++ " is not supported"
-                 loc.derivings = case Map.lookup @nt @lhs.derivings of
-                                    Nothing -> empty
-                                    Just s  -> if   Set.null s
-                                               then empty
-                                               else "deriving" >#< (pp_parens $ ppCommas $ map pp $ Set.toList s)
-
-{
-classCtxsToDocs :: ClassContext -> [PP_Doc]
-classCtxsToDocs = map toDoc where
-  toDoc (ident,args) = (ident >#< ppSpaced (map pp_parens args))
-
-classConstrsToDocs :: [Type] -> [PP_Doc]
-classConstrsToDocs = map ppTp
-
-ppClasses :: [PP_Doc] -> PP_Doc
-ppClasses [] = empty
-ppClasses xs = pp_block "(" ")" "," xs >#< "=>"
-
-ppQuants :: [Identifier] -> PP_Doc
-ppQuants [] = empty
-ppQuants ps = "forall" >#< ppSpaced ps >#< "."
-}
-
-ATTR EProduction  [ | | datatype : {PP_Doc} ]
-ATTR EProductions [ | | datatype USE {:} {[]} : {[PP_Doc]} ]
-
--- we generate the data type in the type-class style instead of the GADT style
--- the GADT extension may be required if equality constraints are used
-SEM EProduction
-  | EProduction lhs.datatype = @loc.quantPP1 >#< @loc.classPP1
-                               >#< conname @lhs.rename @lhs.nt @con
-                               >#< ppConFields (dataRecords @lhs.options) @children.datatype
-                loc.classPP1 = ppClasses (classConstrsToDocs @constraints)
-                loc.quantPP1 = ppQuants @params
-
-{
--- first parameter indicates: generate a record or not
-ppConFields :: Bool -> [PP_Doc] -> PP_Doc
-ppConFields True  flds = ppListSep "{" "}" ", " $ filter (not . isEmpty) flds
-ppConFields False flds = ppSpaced flds
-}
-
-
-ATTR EChild    [ | | datatype : {PP_Doc} ]
-ATTR EChildren [ | | datatype USE {:} {[]} : {[PP_Doc]} ]
-
--- Note: the child may be a higher-order attribute, and its semantics may be deforested
-SEM EChild
-  | EChild ETerm
-      loc.tpDoc  = @loc.addStrict $ pp_parens $ ppTp $ removeDeforested @tp
-      loc.strNm  = recordFieldname @lhs.nt @lhs.con @name
-      loc.field  = if dataRecords @lhs.options
-                   then @loc.strNm >#< "::" >#< @loc.tpDoc
-                   else @loc.tpDoc
-      loc.addStrict = \x -> if strictData @lhs.options then "!" >|< x else x
-  | EChild  lhs.datatype = case @kind of
-                             ChildAttr -> empty  -- higher order attributes are not part of the data type
-                             _         -> @loc.field
-
-  | ETerm   lhs.datatype = @loc.field
-
-{
-ppTp :: Type -> PP_Doc
-ppTp = text . typeToHaskellString Nothing []
-}
-
--------------------------------------------------------------------------------
---  Nonterminal semantic function
--------------------------------------------------------------------------------
-SEM ENonterminal
-  | ENonterminal loc.fsemname = \x -> "sem_" ++ show x
-                 loc.semname = @loc.fsemname @nt
-                 loc.frecarg = \t x -> case t of
-                                          NT nt _ _ -> pp_parens (@fsemname nt >#< x)
-                                          _         -> pp x
-
-                 -- The sem_NT function is lazy in the AST: it depends on the application of "child"
-                 -- rules to which extend the AST needs to be constructed.
-                 loc.sem_tp  = @loc.quantPP >#< @loc.classPP >#< @nt >#< @loc.t_params >#< "->" >#< @loc.t_type >#< @loc.t_params
-                 loc.quantPP = ppQuants @params
-                 loc.sem_nt  = @loc.semPragma
-                               >-< @loc.semname >#< "::" >#< @loc.sem_tp
-                               >-< case lookup @nt @lhs.typeSyns of
-                                      Nothing -> @prods.sem_nt
-                                      Just (List t) -> @loc.semname >#< "list" >#< "=" >#< "Prelude.foldr" >#< @loc.semname >|< "_Cons"
-                                                       >#< @loc.semname >|< "_Nil"
-                                                       >#< case t of
-                                                              NT nt _ _ -> pp_parens ("Prelude.map" >#< @fsemname nt >#< "list")
-                                                              _         -> pp "list"
-                                      Just (Maybe t) -> @loc.semname >#< "Prelude.Nothing" >#< "=" >#< @loc.semname >|< "_Nothing"
-                                                        >-< @loc.semname >#< pp_parens ("Prelude.Just just") >#< "="
-                                                        >#< @loc.semname >|< "_Just" >#< @frecarg t "just"
-                                      Just (Tuple ts) -> @loc.semname >#< pp_parens (ppCommas $ map fst ts) >#< "="
-                                                         >#< @loc.semname >|< "_Tuple" >#< ppSpaced (map (\t -> @frecarg (snd t) (show $ fst t)) ts)
-                                      Just (Either l r) -> @loc.semname >#< "(Prelude.Left left)" >#< "=" >#< @loc.semname >|< "_Left" >#< @frecarg l "left"
-                                                           >-< @loc.semname >#< "(Prelude.Right right)" >#< "=" >#< @loc.semname >|< "_Right" >#< @frecarg r "right"
-                                      Just (Map k v) -> @loc.semname >#< "m" >#< "=" >#< "Data.Map.foldrWithKey"
-                                                        >#< @loc.semname >|< "_Entry" >#< @loc.semname >|< "_Nil"
-                                                        >#< case v of
-                                                               NT nt _ _ -> pp_parens ("Data.Map.map" >#< @fsemname nt >#< "m")
-                                                               _         -> pp "m"
-                                      Just (IntMap v) -> @loc.semname >#< "m" >#< "=" >#< "Data.IntMap.foldWithKey"
-                                                         >#< @loc.semname >|< "_Entry" >#< @loc.semname >|< "_Nil"
-                                                         >#< case v of
-                                                                NT nt _ _ -> pp_parens ("Data.IntMap.map" >#< @fsemname nt >#< "m")
-                                                                _         -> pp "m"
-                                      Just (OrdSet t) -> @loc.semname >#< "s" >#< "=" >#< "Prelude.foldr" >#< @loc.semname >|< "_Entry"
-                                                         >#< @loc.semname >|< "_Nil"
-                                                         >#< pp_parens (
-                                                               ( case t of
-                                                                   NT nt _ _ -> pp_parens ("Prelude.map" >#< @fsemname nt)
-                                                                   _         -> empty
-                                                               ) >#< pp_parens ("Data.IntSet.elems" >#< "s")
-                                                             )
-                                      Just IntSet     -> @loc.semname >#< "s" >#< "=" >#< "Prelude.foldr" >#< @loc.semname >|< "_Entry"
-                                                         >#< @loc.semname >|< "_Nil"
-                                                         >#< pp_parens ("Data.IntSet.elems" >#< "s")
---                                      Just x -> error $ "Type " ++ show x ++ " is not supported yet" -- TODO: other typeSyns
-
-                -- precise inlining strategies for inlining
-                loc.inlineNt  = not (lateHigherOrderBinding @lhs.options) && not @recursive && (@prods.count == 1 || (aggressiveInlinePragmas @lhs.options && not @loc.hasWrapper))  -- lucrative for inlining
-                loc.semPragma = if noInlinePragmas @lhs.options
-                                then empty
-                                else if @loc.inlineNt
-                                     then ppInline @loc.semname
-                                     else if helpInlining @lhs.options && not (lateHigherOrderBinding @lhs.options)
-                                          then ppInlinable @loc.semname
-                                          else ppNoInline @loc.semname
-
--- The number of productions
-ATTR EProductions EProduction [ | | count USE {+} {0} : {Int} ]
-SEM EProduction | EProduction  lhs.count = {1}
-
--- The per-production cases for the sem_NT function
-ATTR EProduction EProductions [ | | sem_nt USE {>-<} {empty} : {PP_Doc} ]
-SEM EProduction
-  | EProduction lhs.sem_nt = "sem_" >|< @lhs.nt >#< "(" >#< conname @lhs.rename @lhs.nt @con >#< ppSpaced @children.argpats >#< ")"
-                             >#< "=" >#< "sem_" >|< @lhs.nt >|< "_" >|< @con >#< ppSpaced @children.argnamesw
-
-ATTR EChild    [ | | argnamesw              : { PP_Doc } ]
-ATTR EChildren [ | | argnamesw USE {:} {[]} : {[PP_Doc]} ]
-
-SEM EChild
-  | EChild lhs.argnamesw = case @kind of
-                             ChildSyntax     -> "(" >#< "sem_" >|< @loc.nt >#< @name >|< "_" >#< ")"
-                             ChildAttr       -> empty  -- no sem-case for a higher-order child
-                             ChildReplace tp -> "(" >#< "sem_" >|< extractNonterminal tp >#< @name >|< "_" >#< ")"
-  | ETerm  lhs.argnamesw = text $ fieldname @name
-
--------------------------------------------------------------------------------
---  Types of attributes
--------------------------------------------------------------------------------
-ATTR ExecutionPlan
-     ENonterminals
-     ENonterminal  [ inhmap : {Map NontermIdent Attributes}
-                     synmap : {Map NontermIdent Attributes} | | ]
-
-ATTR EProductions EProduction
-     ERules ERule
-     Patterns Pattern
-     Visits
-     Visit   [ inhmap : {Attributes}
-               synmap : {Attributes}
-               allInhmap : {Map NontermIdent Attributes}
-               allSynmap : {Map NontermIdent Attributes} | | ]
-
-SEM ENonterminal
-  | ENonterminal (Just prods.inhmap) = Map.lookup @nt @lhs.inhmap
-                 (Just prods.synmap) = Map.lookup @nt @lhs.synmap
-                 prods.allInhmap = @lhs.inhmap
-                 prods.allSynmap = @lhs.synmap
-
--------------------------------------------------------------------------------
---  State datatypes
--------------------------------------------------------------------------------
-{type VisitStateState = (VisitIdentifier,StateIdentifier, StateIdentifier)}
-
-ATTR Visit  [ | | allvisits              : { VisitStateState }]
-ATTR Visits [ | | allvisits USE {:} {[]} : {[VisitStateState]}]
-ATTR EProduction
-     EProductions [ | | allvisits: {[VisitStateState]}]
-
-SEM Visit
-  | Visit lhs.allvisits = (@ident, @from, @to)
-
-SEM EProductions
-  | Cons lhs.allvisits = @hd.allvisits -- just pick the first production
-  | Nil  lhs.allvisits = error "Every nonterminal should have at least 1 production"
-
--- type of tree in a given state s
-SEM ENonterminal
-  | ENonterminal loc.outedges  = Set.fromList $ map (\(_,f,_) -> f) @prods.allvisits
-                 loc.inedges   = Set.fromList $ map (\(_,_,t) -> t) @prods.allvisits
-                 loc.allstates = Set.insert @initial $ @loc.inedges `Set.union` @loc.outedges
-                 loc.stvisits  = \st -> filter (\(v,f,t) -> f == st) @prods.allvisits
-                 loc.t_type    = "T_" >|< @nt
-                 loc.t_params  = ppSpaced @params
-                 loc.t_init    = "newtype" >#< @loc.t_type >#< @loc.t_params >#< "=" >#< @loc.t_type >#<
-                                   pp_braces (
-                                     "attach_">|< @loc.t_type >#< "::"
-                                       >#< ppMonadType @lhs.options >#< pp_parens (@loc.t_type >|< "_s" >|< @initial >#< @loc.t_params))
-                 loc.t_states  = vlist $ map (\st ->
-                                    let nt_st = @nt >|< "_s" >|< st
-                                        t_st  = "T_" >|< nt_st
-                                        k_st  = "K_" >|< nt_st
-                                        c_st  = "C_" >|< nt_st
-                                        inv_st  = "inv_" >|< nt_st
-                                        nextVisit = Map.findWithDefault ManyVis st @nextVisits
-                                    in  case nextVisit of
-                                          NoneVis    -> "data" >#< t_st >#< @loc.t_params >#< "=" >#< c_st  -- empty semantics
-                                          OneVis vId -> "newtype" >#< t_st >#< @loc.t_params >#< "=" >#< c_st
-                                                         >#< (pp_braces $ inv_st >#< "::" >#< pp_parens (conNmTVisit @nt vId >#< @loc.t_params))
-                                          ManyVis    -> "data" >#< t_st >#< @loc.t_params >#< "where" >#< c_st >#< "::"
-                                                          >#< (pp_braces $ inv_st >#< "::" >#< "!" >|< pp_parens ("forall t." >#< k_st >#< @loc.t_params >#< "t" >#< "->" >#< "t"))
-                                                          >#< "->" >#< t_st >#< @loc.t_params  -- this is a conventional data type, but declared with GADT syntax
-                                        ) $ Set.toList @loc.allstates
-
--- type of a key which identifies a visit v from state s
-SEM ENonterminal
-  | ENonterminal loc.k_type   = "K_" ++ show @nt
-                 loc.k_states = vlist $ map (\st ->
-                                   let nt_st = @nt >|< "_s" >|< st
-                                       k_st  = "K_" >|< nt_st
-                                       outg  = filter (\(v,f,t) -> f == st) @prods.allvisits
-                                       visitlist = vlist $ map (\(v,f,t) ->
-                                           @loc.k_type >|< "_v" >|< v >#< "::" >#< k_st >#< @loc.t_params >#< pp_parens (@loc.t_type >|< "_v" >|< v >#< @loc.t_params)
-                                            ) outg
-                                       nextVisit = Map.findWithDefault ManyVis st @nextVisits
-                                       decl = "data" >#< k_st >#< "k" >#< @loc.t_params >#< "where" >-< indent 3 visitlist
-                                   in  case nextVisit of
-                                         NoneVis  -> empty
-                                         OneVis _ -> empty
-                                         ManyVis  -> decl
-                                   ) $ Set.toList @loc.allstates
-
--- type of a visit v, with continuation as new state s
-ATTR Visit Visits EProduction EProductions [ | | t_visits USE {>-<} {empty} : {PP_Doc} ]
-
-SEM EProductions
-  | Cons lhs.t_visits = @hd.t_visits -- just pick the first production
-
-SEM Visit
-  | Visit loc.nameT_visit     = conNmTVisit @lhs.nt @ident
-          loc.nameTIn_visit   = conNmTVisitIn @lhs.nt @ident
-          loc.nameTOut_visit  = conNmTVisitOut @lhs.nt @ident
-          loc.nameTNext_visit = conNmTNextVisit @lhs.nt @to
-
-          loc.nextVisitInfo   = Map.findWithDefault ManyVis @to @lhs.nextVisits  -- which visits can we do after we reach the @to state?
-          loc.typecon         = case @kind of
-                                  VisitPure _  -> empty
-                                  VisitMonadic -> ppMonadType @lhs.options
-
-          loc.t_params  = ppSpaced @lhs.params
-          lhs.t_visits = "type" >#< @loc.nameT_visit >#< @loc.t_params >#< "=" >#<
-                           pp_parens (@loc.nameTIn_visit >#< @loc.t_params)
-                             >#< ( if dummyTokenVisit @lhs.options
-                                   then "->" >#< dummyType @lhs.options True  -- Additional (unused though) argument
-                                   else empty
-                                 )
-                             >#< "->" >#< @loc.typecon >#< pp_parens (@loc.nameTOut_visit >#< @loc.t_params)
-                         >-< "data" >#< @loc.nameTIn_visit >#< @loc.t_params >#< "=" >#< @loc.nameTIn_visit >#<
-                              @loc.inhpart
-                         >-< "data" >#< @loc.nameTOut_visit >#< @loc.t_params >#< "=" >#< @loc.nameTOut_visit >#<
-                              @loc.synpart >#< case @loc.nextVisitInfo of
-                                                 NoneVis    -> empty                    -- don't return a continuation at all
-                                                 _          -> @loc.addbang1 $ pp_parens (@loc.nameTNext_visit >#< @loc.t_params)  -- normal route: select the next semantics
-          loc.inhpart   = @loc.ppTypeList @inh @lhs.inhmap
-          loc.synpart   = @loc.ppTypeList @syn @lhs.synmap
-          loc.ppTypeList = \s m -> ppSpaced $ map (\i -> @loc.addbang1 $ pp_parens $ case Map.lookup i m of
-                                                                                      Just tp -> ppTp tp ) $ Set.toList s
-
-{
-conNmTVisit nt vId      = "T_" >|< nt >|< "_v"    >|< vId
-conNmTVisitIn nt vId    = "T_" >|< nt >|< "_vIn"  >|< vId
-conNmTVisitOut nt vId   = "T_" >|< nt >|< "_vOut" >|< vId
-conNmTNextVisit nt stId = "T_" >|< nt >|< "_s"    >|< stId
-
-ppMonadType :: Options -> PP_Doc
-ppMonadType opts
-  | parallelInvoke opts = text "IO"
-  | otherwise           = text "Identity"
-}
-
--------------------------------------------------------------------------------
---  Inh and Syn wrappers
--------------------------------------------------------------------------------
-SEM ENonterminal
-  | ENonterminal loc.wr_inh   = @loc.genwrap "Inh" @loc.wr_inhs
-                 loc.wr_syn   = @loc.genwrap "Syn" @loc.wr_syns
-                 loc.genwrap  = \nm attr -> "data" >#< nm >|< "_" >|< @nt >#< @loc.t_params >#< "=" >#< nm >|< "_" >|< @nt >#< "{"
-                                            >#< (ppCommas $ map (\(i,t) -> i >|< "_" >|< nm >|< "_" >|< @nt >#< "::"
-                                            >#< (@loc.addbang $ pp_parens $ typeToHaskellString (Just @nt) [] t)) attr) >#< "}"
-                 loc.synAttrs = fromJust $ Map.lookup @nt @lhs.inhmap
-                 loc.wr_inhs  = Map.toList $ @loc.wr_filter $ @loc.synAttrs
-                 loc.wr_inhs1 = Map.toList @loc.synAttrs
-                 loc.wr_filter = if lateHigherOrderBinding @lhs.options
-                                 then Map.delete idLateBindingAttr
-                                 else id
-                 loc.wr_syns  = Map.toList $ fromJust $ Map.lookup @nt @lhs.synmap
-                 loc.inhlist  = map (lhsname @lhs.options True . fst) @loc.wr_inhs
-                 loc.inhlist1 = map (lhsname @lhs.options True . fst) @loc.wr_inhs1
-                 loc.synlist  = map (lhsname @lhs.options False . fst) @loc.wr_syns
-                 loc.wrapname = "wrap_" ++ show @nt
-                 loc.inhname  = "Inh_" ++ show @nt
-                 loc.synname  = "Syn_" ++ show @nt
-                 loc.firstVisitInfo = Map.findWithDefault ManyVis @initial @nextVisits
-                 loc.wrapper  = @loc.wrapPragma
-                                >-< (@loc.wrapname >#< "::" >#< @loc.quantPP >#< @loc.classPP >#< @loc.t_type >#< @loc.t_params >#< "->"
-                                      >#< @loc.inhname >#< @loc.t_params >#< "->" >#< ( if monadicWrappers @lhs.options then ppMonadType @lhs.options else empty) >#< pp_parens (@loc.synname >#< @loc.t_params))
-                                >-< (@loc.wrapname >#< (@loc.addbang $ pp_parens (@loc.t_type >#< pp "act"))
-                                    >#< (@loc.addbang $ pp_parens (@loc.inhname
-                                           >#< (ppSpaced $ map (@loc.addbangWrap . pp) @loc.inhlist)) >#< "="))
-                                >-<
-                                indent 3 (case @initialv of
-                                  -- case where there are no inherited or synthesized attributes
-                                  [] -> @loc.synname >#< " { }"
-                                  initvs@(initv:_) ->
-                                    let extra  = if dummyTokenVisit @lhs.options
-                                                 then pp $ dummyArg @lhs.options True
-                                                 else empty
-                                        unMonad | monadicWrappers @lhs.options = empty
-                                                | otherwise                    = unMon @lhs.options
-                                        genSteps _      []           = []
-                                        genSteps curst (curv:nextvs) = setarg : dovis : genSteps nextst nextvs where
-                                          inCon = conNmTVisitIn @nt curv
-                                          outCon = conNmTVisitOut @nt curv
-                                          pat    = @loc.addbang $ pp_parens $ pat0
-                                          pat0   = outCon >#< ppSpaced (map (lhsname @lhs.options False) syns) >#< cont
-                                          cont   | null nextvs = empty
-                                                 | otherwise   = pp "sem"
-                                          inhs = Set.toList $ Map.findWithDefault Set.empty curv @prods.visituses
-                                          syns = Set.toList $ Map.findWithDefault Set.empty curv @prods.visitdefs
-                                          arg = inCon >#< ppSpaced (map (lhsname @lhs.options True) inhs)
-                                          setarg = "let" >#< @loc.addbangWrap (pp "arg" >|< curv) >#< "=" >#< arg
-                                          ind    = case Map.findWithDefault ManyVis curst @nextVisits of
-                                                   NoneVis  -> error "wrapper: initial state should have a next visit but it has none"
-                                                   OneVis _ -> empty
-                                                   ManyVis  -> @loc.k_type >|< "_v" >|< initv
-                                          nextst = curst + 1 -- This is not correct, but works both for KW and AOAG
-                                                             -- Should be lookup up based on visit
-                                          convert = case Map.lookup curv @lhs.allVisitKinds of
-                                                      Just kind -> case kind of
-                                                         VisitPure _  -> text "return"
-                                                         VisitMonadic -> empty
-                                          dovis  = pat >#< "<-" >#< convert >#< pp_parens 
-                                            ("inv_" >|< @nt >|< "_s" >|< curst >#< "sem" >#< ind 
-                                            >#< "arg" >|< curv >#< extra)
-                                    in unMonad >#< "("
-                                       >-< indent 2 (
-                                              "do" >#< ( @loc.addbang (pp "sem") >#< "<-" >#< "act"   -- run the per-node monadic code to get the initial state (of the root)
-                                                       >-< vlist (genSteps @initial initvs)
-                                                       >-< "return" >#< pp_parens (@loc.synname >#< ppSpaced @loc.synlist)
-                                                       )
-                                            )
-                                       >-< ")" )
-                                >-< if lateHigherOrderBinding @lhs.options
-                                    then indent 2 ("where" >#< lhsname @lhs.options True idLateBindingAttr >#< "=" >#< lateBindingFieldNm @lhs.mainName)
-                                    else empty
-                 loc.wrapPragma = if parallelInvoke @lhs.options && not (monadicWrappers @lhs.options)
-                                  then ppNoInline @loc.wrapname  -- required for the use of unsafePerformIO in case of the IO monad
-                                  else if noInlinePragmas @lhs.options
-                                       then empty
-                                       else ppInlinable @loc.wrapname  -- ensure that the wrapper is exposed as inlinable
-
--------------------------------------------------------------------------------
---  Collection of NT / Production sem funs references
--------------------------------------------------------------------------------
-
-ATTR ENonterminals ENonterminal EProductions EProduction [ | | semFunBndDefs, semFunBndTps USE {Seq.><} {Seq.empty} : {Seq PP_Doc} ]
-SEM ENonterminal | ENonterminal
-  lhs.semFunBndDefs = @loc.semFunBndDef Seq.<| @prods.semFunBndDefs
-  lhs.semFunBndTps  = @loc.semFunBndTp Seq.<| @prods.semFunBndTps
-  loc.semFunBndDef  = @loc.semFunBndNm >#< "=" >#< @loc.semname
-  loc.semFunBndTp   = @loc.semFunBndNm >#< "::" >#< @loc.sem_tp
-  loc.semFunBndNm   = lateSemNtLabel @nt
-
-SEM EProduction | EProduction
-  lhs.semFunBndDefs = Seq.singleton @loc.semFunBndDef
-  lhs.semFunBndTps  = Seq.singleton @loc.semFunBndTp
-  loc.semFunBndDef  = @loc.semFunBndNm >#< "=" >#< @loc.semname
-  loc.semFunBndTp   = @loc.semFunBndNm >#< "::" >#< @loc.sem_tp
-  loc.semFunBndNm   = lateSemConLabel @lhs.nt @con
-
--- Generate a dictionary that contains the semantics of all semantic functions
-SEM ExecutionPlan | ExecutionPlan
-  loc.wrappersExtra = if lateHigherOrderBinding @lhs.options
-                      then @loc.lateSemBndDef
-                      else empty
-  loc.commonExtra   = if lateHigherOrderBinding @lhs.options
-                      then @loc.lateSemBndTp
-                      else empty
-  loc.lateSemBndTp = "data" >#< lateBindingTypeNm @lhs.mainName >#< "=" >#< lateBindingTypeNm @lhs.mainName
-                      >-< (indent 2 $ pp_block "{" "}" "," $ toList @nonts.semFunBndTps)
-  loc.lateSemBndDef = ( if noInlinePragmas @lhs.options
-                        then empty
-                        else if helpInlining @lhs.options && Set.size @wrappers == 1
-                             then ppInline $ lateBindingFieldNm @lhs.mainName  -- inline in the single wrapper
-                             else ppNoInline $ lateBindingFieldNm @lhs.mainName
-                      )
-                      >-< lateBindingFieldNm @lhs.mainName >#< "::" >#< lateBindingTypeNm @lhs.mainName
-                      >-< lateBindingFieldNm @lhs.mainName >#< "=" >#< lateBindingTypeNm @lhs.mainName
-                      >-< (indent 2 $ pp_block "{" "}" "," $ toList @nonts.semFunBndDefs )
-
--------------------------------------------------------------------------------
---  Production semantic functions
--------------------------------------------------------------------------------
-ATTR EProduction  [ | | sem_prod                   : {PP_Doc} ]
-ATTR EProductions [ | | sem_prod USE {>-<} {empty} : {PP_Doc} ]
-
-ATTR EProduction EProductions [ initial : {StateIdentifier}
-                                allstates : {Set StateIdentifier} | | ]
-SEM ENonterminal
-  | ENonterminal prods.initial   = @initial
-                 prods.allstates = @loc.allstates
-
-ATTR EChild    [ | | argtps               : {  PP_Doc  }
-                     argpats              : {  PP_Doc  } ]
-ATTR EChildren [ | | argtps  USE {:} {[]} : { [PP_Doc] }
-                     argpats USE {:} {[]} : { [PP_Doc] }  ]
-
-SEM EChild
-  | EChild lhs.argtps   = case @kind of
-                            ChildSyntax     -> ppDefor @tp >#< "->"
-                            ChildReplace tp -> ppDefor tp >#< "->"
-                            _               -> empty  -- higher order attribute
-           loc.argpats = case @kind of
-                           ChildSyntax    -> @name >|< "_"                    -- no strictification of children semantics to allow infinite trees
-                           ChildReplace _ -> @name >|< "_"
-                           _              -> empty
-  | ETerm  lhs.argtps  = (pp_parens $ show @tp) >#< "->"
-           loc.argpats = @loc.addbang $ text $ fieldname @name   -- terminals may be strict (perhaps this should become an option)
-
-{
-ppDefor :: Type -> PP_Doc
-ppDefor (NT nt args _) = "T_" >|< nt >#< ppSpaced (map pp_parens args)
-ppDefor (Haskell s)    = text s
-}
-
-SEM EProduction
-  | EProduction loc.t_type   = "T_" >|< @lhs.nt
-                loc.t_params = ppSpaced @lhs.params
-                loc.usedArgs = @children.usedArgs `Set.union` @visits.usedArgs `Set.union` @rules.usedArgs
-                -- A bit ugly, but this code renames arguments and puts an underscore when the argument
-                -- is never used. This avoids compiler warnings of unused variables.
-                loc.args     = map (\x -> let (name,arg) = case show x of 
-                                                       ""       -> ("", empty)
-                                                       '!':name -> ("arg_" ++ name, "!arg_" >|< name)
-                                                       name     -> ("arg_" ++ name, "arg_"  >|< name)
-                                          in  if null name || name `Set.member` @loc.usedArgs
-                                              then arg
-                                              else text "_") @children.argpats
-                loc.semname  = "sem_" ++ show @lhs.nt ++ "_" ++ show @con
-                loc.sem_tp   = @loc.quantPP2 >#< @loc.classPP2 >#< ppSpaced @children.argtps >#< @loc.t_type >#< @loc.t_params
-                loc.classPP2 = ppClasses (classCtxsToDocs @lhs.classCtxs ++ classConstrsToDocs @constraints)
-                loc.quantPP2 = ppQuants (@lhs.params ++ @params)
-                loc.sem_prod = @loc.semInlinePragma
-                               >-< @loc.semname >#< "::" >#< @loc.sem_tp
-                               >-< @loc.mkSemBody (@loc.semname >#< ppSpaced @loc.args >#< "=" >#< @loc.scc >#< @loc.t_type)
-                                                  @loc.mbInitializer @loc.outerlet ("return" >#< "st" >|< @lhs.initial)
-                loc.mkSemBody = \prefix mbInit outerlet ret ->
-                                  case mbInit of
-                                    Nothing -> prefix >#< pp_parens ret >#< "where"
-                                               >-< indent 3 outerlet  -- code for states and visits
-                                    Just m  -> prefix >#< "(" >#< "do"
-                                               >-< indent 1 (
-                                                     m
-                                                     >-< "let"
-                                                     >-< indent 2 outerlet -- code for the states and visits
-                                                     >-< ret )
-                                               >-< indent 1 ")"
-
-                loc.mbInitializer   = --some monadic actions, performed upon attaching a child, can
-                                      -- be specified here. The resulting bindings of these actions are
-                                      -- in scope of the rules of the production
-                                      if parallelInvoke @lhs.options
-                                      then (Nothing :: Maybe PP_Doc)  -- perhaps do some per-node registation, etc. For now: nothing
-                                      else Nothing  -- nothing special here
-                loc.scc             = if genCostCentres @lhs.options
-                                      then ppCostCentre @loc.semname
-                                      else empty
-                loc.semInlinePragma = if noInlinePragmas @lhs.options
-                                      then empty
-                                      else ppNoInline @loc.semname  -- prevent the semantic functions of constructors to be inlined (e.g. in the nt sem-funs)
-                loc.outerlet = vlist @loc.statefns >-< @rules.sem_rules
-                loc.statefns = map @loc.genstfn $ Set.toList @lhs.allstates
-                loc.genstfn  = \st -> let nextVisitInfo = Map.findWithDefault ManyVis st @lhs.nextVisits
-                                          prevVisitInfo = Map.findWithDefault ManyVis st @lhs.prevVisits
-                                          stNm = "st" >|< st
-                                          lhs  = pragma >-< bang stNm >#< "=" >#<
-                                                 ( -- generating a lambda for the same reasons as generating
-                                                   -- a lambda for rules: to ensure that overloading is
-                                                   -- resolved for all visit functions and rules together.
-                                                   if st == @lhs.initial
-                                                   then empty
-                                                   else "\\" >#< @loc.stargs st >#< "->"
-                                                 )
-
-                                          pragma = if noInlinePragmas @lhs.options
-                                                   then empty
-                                                   else if helpInlining @lhs.options
-                                                        then case prevVisitInfo of
-                                                               ManyVis  -> ppNoInline stNm
-                                                               OneVis _ -> if aggressiveInlinePragmas @lhs.options
-                                                                           then ppInline stNm
-                                                                           else ppInlinable stNm
-                                                               NoneVis  -> if st /= @lhs.initial
-                                                                           then error ("State " ++ show st ++ " is not reachable from the initial state.")
-                                                                           else if aggressiveInlinePragmas @lhs.options
-                                                                                then ppInline stNm    -- first state can be inlined
-                                                                                else ppInlinable stNm
-                                                        else ppNoInline stNm
-                                          cCon = "C_" >|< @lhs.nt >|< "_s" >|< st
-                                          bang | st == @lhs.initial = @loc.addbang  -- initial state is not parameterized
-                                               | otherwise          = id
-
-                                          -- note about the initial state: the initial state should be the only
-                                          -- state-binding that is not a function. It is non-recursive and not needed
-                                          -- anywhere except delivered as initial result. This binding therefore does
-                                          -- not end up needlessly in any closure.
-                                      in case nextVisitInfo of
-                                           NoneVis    -> -- the (empty) closure of a (non-initial) end state is not referenced
-                                                         -- thus generating it is not needed (and omitting it may catch some small mistakes).
-                                                         if st == @lhs.initial
-                                                         then lhs >#< cCon  -- empty state
-                                                         else empty -- no state generated
-                                           OneVis vId -> mklet lhs (@loc.stvs st False) (cCon >#< "v" >|< vId)
-                                           ManyVis    -> mklet lhs (@loc.stks st >-< @loc.stvs st True) (cCon >#< "k" >|< st)
-                loc.stargs   = \st -> let attrs = maybe Map.empty id $ Map.lookup st @visits.intramap
-                                      in ppSpaced [ let match | str `Set.member` @loc.lazyIntras = pp str
-                                                              | otherwise                        = @loc.addbang (pp str)
-                                                    in case mbAttr of
-                                                         Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) ->
-                                                           case Map.lookup nm @loc.localAttrTypes of
-                                                             Just tp -> pp_parens (pp_parens match >#< "::" >#< ppTp tp)
-                                                             Nothing -> match
-                                                         Just attr | not (noPerStateTypeSigs @lhs.options) ->
-                                                           case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @loc.childTypes of
-                                                             Just tpDoc -> pp_parens (pp_parens match >#< "::" >#< tpDoc)
-                                                             Nothing    -> match
-                                                         _ -> match
-                                                 | (str,mbAttr) <- Map.assocs attrs
-                                                 ] >#< dummyPat @lhs.options (Map.null attrs)
-
-                loc.stks     = \st -> if null (@loc.stvisits st)
-                                      then empty
-                                      else ( if not (noInlinePragmas @lhs.options) && helpInlining @lhs.options
-                                             then ppNoInline ("k" >|< st)
-                                             else empty
-                                           )
-                                           >-< "k" >|< st >#< "::" >#< "K_" >|< @lhs.nt >|< "_s" >|< st >#< @loc.t_params >#< "t" >#< "->" >#< "t"
-                                           >-< vlist (map (\(v,f,t) -> "k" >|< st >#< "K_" >|< @lhs.nt >|< "_v" >|< v >#< "="
-                                                                  >#< "v" >|< v) $ @loc.stvisits st)
-                loc.stvisits = \st -> filter (\(v,f,t) -> f == st) @visits.allvisits
-                loc.stvs     = \st inlinePragma -> vlist [ppf inlinePragma | (f,ppf) <- @visits.sem_visit, f == st]
-                visits.mrules = @rules.mrules
-
-{
-mklet :: (PP a, PP b, PP c) => a -> b -> c -> PP_Doc
-mklet prefix defs body =
-  prefix >#< "let"
-  >-< indent 3 defs
-  >-< indent 2 "in" >#< body
-}
-
--------------------------------------------------------------------------------
---  Visit semantic functions
--------------------------------------------------------------------------------
-ATTR Visit  [ | | sem_visit              : {  (StateIdentifier,Bool -> PP_Doc)  } ]
-ATTR Visits [ | | sem_visit USE {:} {[]} : { [(StateIdentifier,Bool -> PP_Doc)] } ]
-
-SEM Visit
-  | Visit lhs.sem_visit = ( @from
-                          , \addInlinePragma ->
-                               ( if noInlinePragmas @lhs.options
-                                 then empty
-                                 else if addInlinePragma && aggressiveInlinePragmas @lhs.options
-                                      then ppInline @loc.vname
-                                      else if helpInlining @lhs.options
-                                           then ppNoInline @loc.vname
-                                           else empty
-                               )
-                               >-< "v" >|< @ident >#< "::" >#< @loc.nameT_visit >#< @loc.t_params
-
-                                      -- generate a lambda here as well instead of a function definition
-                               >-< "v" >|< @ident >#< "=" >#< "\\" >#< (@loc.addbang $ pp_parens (@loc.nameTIn_visit >#< @loc.inhpats))
-                               >#< ( if dummyTokenVisit @lhs.options
-                                     then pp $ dummyPat @lhs.options True  -- extra (but unused) argument
-                                     else empty
-                                   )
-                               >#< "->"
-                               >#< ( if genCostCentres @lhs.options
-                                     then ppCostCentre (@loc.vname >|< "_" >|< @lhs.nt >|< "_" >|< @lhs.con)
-                                     else empty
-                                   ) >#< "(" >#< @loc.stepsInitial
-                               >-< indent 3 (@steps.sem_steps >-< @loc.stepsClosing >#< ")")
-                          )
-          loc.stepsInitial = case @kind of
-                               VisitPure False -> text "let"
-                               VisitPure True  -> empty
-                               VisitMonadic    -> text "do"
-          loc.stepsClosing  = let decls =  @loc.nextStBuild
-                                           >-<  @loc.addbang (pp resultValName) >#< "=" >#< @loc.resultval
-                              in case @kind of
-                                   VisitPure False -> decls
-                                                      >-< "in" >#< resultValName
-                                   VisitPure True  -> "let" >#< decls
-                                                      >-< indent 1 ("in" >#< resultValName)
-                                   VisitMonadic    -> "let" >#< decls
-                                                      >-< "return" >#< resultValName
-          loc.vname     = "v" >|< @ident
-          loc.inhpats   = ppSpaced $ map (\arg -> {-@loc.addbang $-} pp $ attrname @lhs.options True _LHS arg) $ Set.toList @inh
-          loc.inhargs   = \chn -> ppSpaced $ map (attrname @lhs.options False chn) $ Set.toList @inh
-          loc.synargs   = ppSpaced $ map (\arg -> attrname @lhs.options False _LHS arg) $ Set.toList @syn
-          loc.nextargsMp = maybe Map.empty id $ Map.lookup @to @lhs.allintramap
-          loc.nextargs  = ppSpaced $ Map.keys $ @loc.nextargsMp
-          loc.nextst    = "st" >|< @to >#< @loc.nextargs >#< dummyArg @lhs.options (Map.null @loc.nextargsMp)
-          loc.resultval = @loc.nameTOut_visit >#< @loc.synargs >#< @loc.nextStRef
-          (loc.nextStBuild, loc.nextStRef)
-            = case @loc.nextVisitInfo of
-                NoneVis  -> (empty, empty)
-                _        -> (@loc.addbang (pp nextStName) >#< "=" >#< @loc.nextst, pp nextStName)
-
-{
-resultValName :: String
-resultValName = "__result_"
-
-nextStName :: String
-nextStName = "__st_"
-}
-
--- Propagate the visit kind to the steps
-ATTR VisitStep VisitSteps [ kind : VisitKind | | ]
-SEM Visit | Visit  steps.kind = @kind
-
--- the steps in this group should be executed in a pure fashion
-SEM VisitStep | PureGroup
-  steps.kind = VisitPure @ordered
-
-ATTR Visits Visit VisitStep VisitSteps [  mrules : {Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)} | | ]
-ATTR VisitStep VisitSteps [ | | sem_steps USE {>-<} {empty} : {PP_Doc} ]
-SEM VisitStep
-  | Sem        loc.ruleItf = Map.findWithDefault (error $ "Rule "  ++ show @name  ++ " not found") @name @lhs.mrules
-               (lhs.errors, loc.sem_steps) = case @loc.ruleItf @lhs.kind @lhs.fmtMode of
-                                               Left e     -> (Seq.singleton e, empty)
-                                               Right stmt -> (Seq.empty, stmt)
-  | ChildIntro loc.attachItf = Map.findWithDefault (error $ "Child " ++ show @child ++ " not found") @child @lhs.childintros
-               (lhs.errors,lhs.sem_steps,lhs.defs,lhs.uses)
-                 = case @loc.attachItf @lhs.kind @lhs.fmtMode of
-                     Left e                   -> (Seq.singleton e, empty, Set.empty, Map.empty)
-                     Right (code, defs, uses) -> (Seq.empty, code, defs, uses)
-  | ChildVisit loc.visitItf = Map.findWithDefault (error $ "Visit " ++ show @visit ++ " not found") @visit @lhs.allchildvisit
-               (lhs.errors, loc.patPP, loc.exprPP) = case @loc.visitItf @child @lhs.kind of
-                                                       Left e           -> (Seq.singleton e, empty, empty)
-                                                       Right (pat,expr) -> (Seq.empty, pat, expr)
-
-               loc.useParallel = @lhs.useParallel && not @lhs.isLast
-               lhs.sem_steps = if @loc.useParallel  -- assumes to be in a monadic do-expression
-                               then @loc.addbang ("sync_" >|< @lhs.index) >#< "<- newEmptyMVar"
-                                    >-< "forkIO" >#< pp_parens (@loc.convToMonad >#< pp_parens @loc.exprPP >#< ">>= \\" >#< @loc.addbang (pp parResultName) >#< " -> putMVar sync_" >|< @lhs.index >#< parResultName)  -- parResultName is guaranteed to be evaluated
-                               else let decl = case @lhs.kind of
-                                                 VisitPure _  -> @loc.patPP >#< "=" >#< @loc.exprPP
-                                                 VisitMonadic -> @loc.patPP >#< "<-" >#< @loc.exprPP
-                                    in fmtDecl False @lhs.fmtMode decl
-               loc.convToMonad = case @loc.callKind of
-                                   VisitPure _  -> text "return"
-                                   VisitMonadic -> empty
-               loc.callKind  = Map.findWithDefault (error "visit kind should be in the map") @visit @lhs.allVisitKinds
-  | Sim        lhs.sem_steps = @steps.sem_steps >-< @steps.sync_steps
-  | PureGroup  lhs.sem_steps = case @lhs.fmtMode of
-                                 FormatDo -> "let" >#< @steps.sem_steps  -- formatted as a let-block (not a line-let)
-                                 _        -> @steps.sem_steps
-
-ATTR VisitSteps VisitStep [ | | sync_steps USE {>-<} {empty} : {PP_Doc} ]
-SEM VisitStep | ChildVisit
-  lhs.sync_steps = if @loc.useParallel
-                   then @loc.patPP >#< "<-" >#< "takeMVar sync_" >|< @lhs.index
-                   else empty
-
--- The fmtMode indicates in what kind of expression (do/let/line-lets) we are printing
--- declarations, because that determines how we need to wrap declarations
--- Invariant: @lhs.kind == VisitMonadic ---> @lhs.fmtMode == FormatDo
-ATTR VisitSteps VisitStep [ fmtMode : FormatMode | | ]
-SEM Visit | Visit
-  steps.fmtMode = case @kind of
-                    VisitPure False -> FormatLetDecl
-                    VisitPure True  -> FormatLetLine
-                    VisitMonadic    -> FormatDo
-
-SEM VisitStep | PureGroup
-  steps.fmtMode = case @lhs.fmtMode of
-                    FormatDo      -> FormatLetDecl
-                    mode          -> mode
-
-{
-parResultName :: String
-parResultName = "__outcome_"
-
-fmtDecl :: PP a => Bool -> FormatMode -> a -> PP_Doc
-fmtDecl declPure fmt decl = case fmt of
-  FormatLetDecl -> pp decl
-  FormatLetLine -> "let" >#< decl >#< "in"
-  FormatDo | declPure  -> "let" >#< decl
-           | otherwise -> pp decl
-}
-
---
--- Some properties of VisitStep(s)
---
-
--- Used arguments
-ATTR VisitSteps VisitStep Visit Visits EChild EChildren ERule ERules [ | | usedArgs USE {`Set.union`} {Set.empty} : {Set String} ]
-SEM ERule
-  | ERule +usedArgs = Set.union $ Map.keysSet $ Map.mapKeys (\a -> "arg_" ++ a) $ Map.filter isNothing @rhs.attrs
-
-SEM EChild
-  | EChild +usedArgs = \s -> case @kind of
-                             ChildSyntax -> Set.insert ("arg_" ++ show @name ++ "_") s
-                             _           -> s
-
-
--- Number of steps in a 'Sim' block
-ATTR VisitSteps [ | | size : Int ]
-SEM VisitSteps
-  | Nil  lhs.size = 0
-  | Cons lhs.size = 1 + @tl.size
-
--- Number the steps in a 'Sim' block
-ATTR VisitSteps VisitStep [ | index : Int | ]
-SEM VisitSteps | Cons
-  hd.index  = @lhs.index  -- copy rule
-  tl.index  = 1 + @lhs.index
-  lhs.index = @tl.index   -- copy rule
-SEM Visit | Visit    steps.index = 0
-SEM VisitStep | Sim  steps.index = 0
-                     lhs.index   = @lhs.index  -- needed for if we ever allow nested Sims
-
--- Biggest number of steps in previous blocks that used parallel invocation
--- This number - 1 (minimum 0) is the number of references for parallel invocation created
-ATTR VisitSteps VisitStep [ | prevMaxSimRefs : Int | ]
-SEM Visit | Visit    steps.prevMaxSimRefs = 0
-SEM VisitStep | Sim
-  lhs.prevMaxSimRefs = if @loc.useParallel
-                       then @lhs.prevMaxSimRefs `max` (@steps.index - 1)  -- possibly new references made
-                       else @lhs.prevMaxSimRefs                           -- no references created
-
--- Is this the last step?
-ATTR VisitSteps VisitStep [ | | isLast : Bool ]
-ATTR VisitStep [ isLast : Bool | | ]
-SEM VisitSteps
-  | Nil   lhs.isLast = True
-  | Cons  lhs.isLast = False
-          hd.isLast  = @tl.isLast
-
--- Use parallel invocation: only when option enabled and there is more than one visit to a child
-SEM VisitSteps VisitStep [ useParallel : Bool | | ]
-SEM Visit | Visit    steps.useParallel = False
-SEM VisitStep | Sim  loc.useParallel = parallelInvoke @lhs.options && @steps.size > 1 && @loc.isMonadic
-                     loc.isMonadic   = case @lhs.kind of
-                                         VisitMonadic -> True
-                                         _            -> False
-
-
--- Child introduction
-ATTR EChild EChildren [ | | childintros USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} ]
-
-ATTR Visits Visit
-     VisitSteps VisitStep [ childintros : {Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} | | ]
-
-SEM EProduction
-  | EProduction visits.childintros = @children.childintros
-
-SEM EChild
-  | ETerm  lhs.childintros = Map.singleton @name (\_ _ -> Right (empty, Set.empty, Map.empty))
-  | EChild lhs.childintros = Map.singleton @name @loc.introcode
-           loc.isDefor     = case @tp of
-                               NT _ _ defor -> defor
-                               _            -> False
-           loc.valcode     = case @kind of
-                               ChildSyntax -> "arg_" >|< @name >|< "_"
-                               ChildAttr   -> -- decide if we need to invoke the sem-function under the hood
-                                              let prefix | not @loc.isDefor = if lateHigherOrderBinding @lhs.options -- && sepsemmods @lhs.options  -- when sepsemmods is not enabled, the indirection can be optimized away
-                                                                              then lateSemNtLabel @loc.nt >#< lhsname @lhs.options True idLateBindingAttr
-                                                                              else "sem_" >|< @loc.nt
-                                                         | otherwise        = empty -- no need to intro a terminal
-                                              in pp_parens (prefix >#< instname @name)
-                               ChildReplace _ -> -- the higher-order attribute is actually a function that transforms
-                                                 -- the semantics of the child (always deforested)
-                                                 pp_parens (instname @name >#< @name >|< "_")
-           loc.aroundcode  = if @hasAround
-                             then locname @lhs.options @name >|< "_around"
-                             else empty
-           loc.introcode   = \kind fmtMode ->
-                                      let pat       = text $ stname @name @loc.initSt
-                                          patStrict = @loc.addbang pat
-                                          attach    = "attach_T_" >|< @loc.nt >#< pp_parens (@loc.aroundcode >#< @loc.valcode)
-                                          runAttach = unMon @lhs.options >#< pp_parens attach
-                                          decl      = case kind of
-                                                        VisitPure False -> pat >#< "=" >#< runAttach
-                                                        VisitPure True  -> patStrict >#< "=" >#< runAttach
-                                                        VisitMonadic    -> patStrict >#< "<-" >#< attach
-                                      in if compatibleAttach kind @loc.nt @lhs.options
-                                         then Right ( fmtDecl False fmtMode decl
-                                                    , Set.singleton (stname @name @loc.initSt)  -- variables defined by the child intro
-                                                    , case @kind of  -- variables used by the child introduction
-                                                        ChildAttr   -> Map.insert (instname @name) Nothing $  -- the sem attr
-                                                                         ( if @loc.isDefor || not (lateHigherOrderBinding @lhs.options)
-                                                                           then id   -- the sem dictionary attr is not used
-                                                                           else Map.insert (lhsname @lhs.options True idLateBindingAttr) (Just $ AttrInh _LHS idLateBindingAttr)
-                                                                         ) $
-                                                                         ( if @hasAround
-                                                                           then Map.insert (locname @lhs.options (@name) ++ "_around") Nothing
-                                                                           else id
-                                                                         ) $ Map.empty
-                                                        ChildReplace _ -> Map.singleton (instname @name) Nothing   -- uses the transformation function
-                                                        ChildSyntax    -> Map.empty
-                                                    )
-                                         else Left $ IncompatibleAttachKind @name kind
-           loc.nt       = extractNonterminal @tp
-
-{
-stname :: Identifier -> Int -> String
-stname child st = "_" ++ getName child ++ "X" ++ show st
-
--- should actually return some conversion info
-compatibleAttach :: VisitKind -> NontermIdent -> Options -> Bool
-compatibleAttach _ _ _ = True
-
-unMon :: Options -> PP_Doc
-unMon options
-  | parallelInvoke options = text "System.IO.Unsafe.unsafePerformIO"    -- IO monad
-  | otherwise              = text "Control.Monad.Identity.runIdentity"  -- identity monad
-}
-
--- rules
-ATTR ERules ERule [ | | sem_rules USE {>-<} {empty} : {PP_Doc}
-                        mrules USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)} ]
-
-SEM ERule | ERule
-     lhs.sem_rules    = if @loc.used == 0
-                        then empty
-                        else @loc.rulePragma >-< @loc.rulecode
-     loc.rulecode     = ( if @loc.genpragma
-                          then @loc.pragma  -- this additional pragma *may* help to give some AG source location in the presence of
-                                            -- type errors in the rule. It will definitely not be precise, and may take some additional
-                                            -- source space, but let's see if it's worth it in practice.
-                          else empty
-                        )
-                        >-< @loc.lambda >#< @loc.scc
-                        >-< indent ((column @rhs.pos - 2) `max` 2)
-                              ( if @loc.genpragma
-                                then @loc.pragma >-< @rhs.semfunc >-< @loc.endpragma
-                                else @rhs.semfunc
-                              )
-      loc.rulePragma   = ( let reallyInlineStr   = "INLINE"
-                               reallyNoInlineStr = "NOINLINE"
-                           in  if noInlinePragmas @lhs.options
-                               then empty
-                               else if @loc.used == 1
-                                    then ppPragmaBinding reallyInlineStr @name  -- always inline if used exactly once
-                                    else if helpInlining @lhs.options
-                                         then if not @explicit && @loc.used <= reallyOftenUsedThreshold
-                                              then ppPragmaBinding "INLINE[1]" @name  -- inline if copy rule
-                                              else if @loc.used > ruleInlineThresholdSoft && @explicit  -- noinline if it passes the threshold and is not a copy rule
-                                                   then if @loc.used > ruleInlineThresholdHard
-                                                        then ppPragmaBinding reallyNoInlineStr @name    -- used too often: force ghc not to inline it
-                                                        else if aggressiveInlinePragmas @lhs.options
-                                                             then ppPragmaBinding "NOINLINE[2]" @name -- allow inlining but only late in the process
-                                                             else ppNoInline @name
-                                                   else if aggressiveInlinePragmas @lhs.options
-                                                        then ppPragmaBinding "NOINLINE[1]" @name  -- otherwise, let GHC decide (but do other inlining first)
-                                                        else ppNoInline @name
-                                         else if not @explicit || @loc.used <= ruleInlineThresholdSoft
-                                              then ppPragmaBinding "NOINLINE[1]" @name  -- otherwise, let GHC decide (but do other inlining first)
-                                              else ppNoInline @name
-                             )
-      loc.scc          = if genCostCentres @lhs.options && @explicit && @pure && not (noPerRuleCostCentres @lhs.options)
-                         then ppCostCentre (@name >|< "_" >|< line @rhs.pos >|< "_" >|< @lhs.nt >|< "_" >|< @lhs.con)
-                         else empty
-      loc.pragma       = "{-# LINE" >#< show (line @rhs.pos) >#< show (file @rhs.pos) >#< "#-}"
-      loc.endpragma    = ppWithLineNr (\ln -> "{-# LINE " ++ show (ln+1) ++ " " ++ show @lhs.mainFile ++ "#-}")
-      loc.genpragma    = genLinePragmas @lhs.options && @explicit && @loc.haspos
-      loc.haspos       = line @rhs.pos > 0 && column @rhs.pos >= 0 && not (null (file @rhs.pos))
-
-        -- we generate a simple pattern binding because of overloading-resolving during the type inference process.
-        -- The types of the rules are not generalized (nor do we want that - rules are used in a single typing-context).
-        -- If overloading is resolved separately, it may not be clear which dictionaries to use. For that all rules have
-        -- to be considered together, which is done when we use simple pattern bindings with a lambda expression instead
-        -- of a function definition.
-        -- Note: we also ensure that all rules are lambda expressions, so that they are not made part of any closures
-        -- but are lambda-lifted instead.
-      loc.lambda       = @name >#< "=" >#< "\\" >#< @loc.argPats >#< dummyPat @lhs.options (Map.null @rhs.attrs) >#< "->"
-
-      loc.argPats      = ppSpaced [ let match | str `Set.member` @lhs.lazyIntras = pp str
-                                              | otherwise                        = @loc.addbang1 (pp str)
-                                    in case mbAttr of
-                                         Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) ->
-                                           case Map.lookup nm @lhs.localAttrTypes of
-                                             Just tp -> pp_parens (pp_parens match >#< "::" >#< ppTp tp)
-                                             Nothing -> match
-                                         Just attr | not (noPerRuleTypeSigs @lhs.options) ->
-                                           case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @lhs.childTypes of
-                                             Just tpDoc -> pp_parens (pp_parens match >#< "::" >#< tpDoc)
-                                             Nothing    -> match
-                                         _ -> match
-                                  | (str,mbAttr) <- Map.assocs @rhs.attrs
-                                  ]
-      loc.argExprs     = ppSpaced [ case mbAttr of
-                                       Nothing -> "arg_" >|< str
-                                       _       -> text str
-                                  | (str,mbAttr) <- Map.assocs @rhs.attrs
-                                  ]
-      loc.stepcode     = \kind fmtMode -> if kind `compatibleRule` @pure
-                                          then Right $ let oper | @pure     = "="
-                                                                | otherwise = "<-"
-                                                           decl = @pattern.sem_lhs >#< oper >#< @name >#< @loc.argExprs >#< dummyArg @lhs.options (Map.null @rhs.attrs)
-                                                           tp   = if @pure && not (noPerRuleTypeSigs @lhs.options)
-                                                                  then @pattern.attrTypes
-                                                                  else empty
-                                                       in fmtDecl @pure fmtMode (tp >-< decl)
-                                          else Left $ IncompatibleRuleKind @name kind
-
-      lhs.mrules       = Map.singleton @name @loc.stepcode
-
-ATTR Expression [ | | tks : {[HsToken]} ]
-SEM Expression
-  | Expression lhs.tks = @tks
-
-{
-dummyPat :: Options -> Bool -> PP_Doc
-dummyPat opts noArgs
-  | not noArgs && tupleAsDummyToken opts = empty  -- no unnecessary tuples
-  | tupleAsDummyToken opts = if strictDummyToken opts
-                             then text "()"
-                             else text "(_ :: ())"
-  | otherwise              = let match | strictDummyToken opts = "!_"
-                                       | otherwise             = "_"
-                             in pp_parens (match >#< "::" >#< dummyType opts noArgs)
-  where match | strictDummyToken opts = "(!_)"
-              | otherwise             = "_"
-
-dummyArg :: Options -> Bool -> PP_Doc
-dummyArg opts noArgs
-  | not noArgs && tupleAsDummyToken opts = empty    -- no unnecessary tuples
-  | tupleAsDummyToken opts = text "()"
-  | otherwise              = text "GHC.Prim.realWorld#"
-
-dummyType :: Options -> Bool -> PP_Doc
-dummyType opts noArgs
-  | not noArgs && tupleAsDummyToken opts = empty     -- no unnecessary tuples
-  | tupleAsDummyToken opts = text "()"
-  | otherwise              = text "(GHC.Prim.State# GHC.Prim.RealWorld)"
-}
-
-{
--- rules are "deinlined" to prevent needless code duplication.
--- if there is only a bit of duplication, we allow ghc to decide if it is worth it.
--- if the duplication crosses this threshold, however, we tell ghc definitely not to inline it.
-ruleInlineThresholdSoft :: Int
-ruleInlineThresholdSoft = 3
-
-ruleInlineThresholdHard :: Int
-ruleInlineThresholdHard = 5
-
-reallyOftenUsedThreshold :: Int
-reallyOftenUsedThreshold = 12
-}
-
-ATTR Expression [ | | pos : {Pos} ]
-SEM Expression | Expression lhs.pos = @pos
-
--- pattern and expression semantics
-ATTR Pattern  [ | | sem_lhs              : { PP_Doc } ]
-ATTR Patterns [ | | sem_lhs USE {:} {[]} : {[PP_Doc]} ]
-ATTR Pattern Patterns [ | | ]
-
-SEM Pattern
-  | Alias       loc.varPat    = text $ attrname @lhs.options False @field @attr
-                loc.patExpr   = if @pat.isUnderscore
-                                then @loc.varPat
-                                else @loc.varPat >|< "@" >|< @pat.sem_lhs
-                lhs.sem_lhs   = @loc.addbang1 @loc.patExpr
-  | Product     lhs.sem_lhs   = @loc.addbang1 $ pp_block "(" ")" "," @pats.sem_lhs
-  | Constr      lhs.sem_lhs   = @loc.addbang1 $ pp_parens $ @name >#< hv_sp @pats.sem_lhs
-  | Underscore  lhs.sem_lhs   = text "_"
-  | Irrefutable lhs.sem_lhs   = text "~" >|< pp_parens @pat.sem_lhs
-
--- Check if a pattern is just an underscore
-ATTR Pattern [ | | isUnderscore:{Bool}]
-SEM Pattern
- | Constr      lhs.isUnderscore = False
- | Product     lhs.isUnderscore = False
- | Alias       lhs.isUnderscore = False
- | Underscore  lhs.isUnderscore = True
-
--- Collect the attributes defined by a pattern
-ATTR Pattern Patterns  [ | | attrs USE {`Set.union`} {Set.empty} : {Set String} ]
-SEM Pattern | Alias
-  lhs.attrs     = Set.insert (attrname @lhs.options False @field @attr) @pat.attrs
-
--- All attribute types of this pattern
-ATTR Pattern Patterns  [ | | attrTypes USE {>-<} {empty} : {PP_Doc} ]
-SEM Pattern | Alias
-  loc.mbTp      = if @field == _LHS
-                  then Map.lookup @attr @lhs.synmap
-                  else if @field == _LOC
-                       then Map.lookup @attr @lhs.localAttrTypes
-                       else Nothing
-  lhs.attrTypes = maybe empty (\tp -> (attrname @lhs.options False @field @attr) >#< "::" >#< ppTp tp) @loc.mbTp
-                  >-< @pat.attrTypes
-
--- Collect the attributes used by the right-hand side
-ATTR HsToken Expression [ | | attrs USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ]
-SEM HsToken
-  | AGLocal   lhs.attrs   = Map.singleton (fieldname @var) Nothing
-  | AGField   loc.mbAttr  = if @field == _INST || @field == _FIELD || @field == _INST'
-                            then Nothing  -- should not be used in the first place
-                            else Just $ mkNonLocalAttr (@field == _LHS) @field @attr
-              lhs.attrs   = Map.singleton (attrname @lhs.options True @field @attr) @loc.mbAttr
-
-{
-data NonLocalAttr
-  = AttrInh Identifier Identifier
-  | AttrSyn Identifier Identifier deriving Show
-
-mkNonLocalAttr :: Bool -> Identifier -> Identifier -> NonLocalAttr
-mkNonLocalAttr True  = AttrInh  -- True: inherited attr
-mkNonLocalAttr False = AttrSyn
-
-lookupAttrType :: NonLocalAttr -> Map Identifier Attributes -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc
-lookupAttrType (AttrInh child name) inhs _ = lookupType child name inhs
-lookupAttrType (AttrSyn child name) _ syns = lookupType child name syns
-
--- Note: if the child takes type parameters, the type of an attribute of this child may refer to these parameters. This means that
--- the actual type of the attribute needs to have its type parameters substituted with the actual type argument of the child.
--- However, for now we simply decide to return Nothing in this case, which skips the type annotation.
-lookupType :: Identifier -> Identifier -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc
-lookupType child name attrMp childMp
-  | noParameters childTp = Just ppDoc
-  | otherwise            = Nothing
-  where
-    attrTp     = Map.findWithDefault (error "lookupType: the attribute is not in the attrs of the child") name childAttrs
-    childAttrs = Map.findWithDefault (error "lookupType: the attributes of the nonterm are not in the map") nonterm attrMp
-    nonterm    = extractNonterminal childTp
-    childTp    = Map.findWithDefault (error ("lookupType: the child " ++ show child ++ "is not in the appropriate map")) child childMp
-    ppDoc      = ppTp attrTp
-
-noParameters :: Type -> Bool
-noParameters (Haskell _)   = True
-noParameters (NT _ args _) = null args
-}
-
-ATTR Expression [ | | semfunc : {PP_Doc} ]
-
-SEM Expression
-  | Expression lhs.attrs   = Map.unions $ map (\tok -> attrs_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks
-               lhs.semfunc = vlist $ showTokens $ map (\tok -> tok_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks
-               loc.inhhstoken = Inh_HsToken @lhs.options
-
--- child visit map
-ATTR Visit
-     Visits
-     EProduction
-     EProductions
-     ENonterminal
-     ENonterminals [ allchildvisit : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))}
-                     | | childvisit USE {`Map.union`} {Map.empty} : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} ]
-
-ATTR VisitSteps VisitStep [ allchildvisit : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} | | ]
-
-SEM ExecutionPlan
-  | ExecutionPlan nonts.allchildvisit = @nonts.childvisit
-
-SEM Visit
-  | Visit
-     loc.prevVisitInfo = Map.findWithDefault ManyVis @from @lhs.nextVisits
-     lhs.childvisit = Map.singleton @ident @loc.invokecode
-     loc.invokecode = \chn kind ->   -- "chn" is the name of the child at the place of invocation, and "kind" the kind of the calling visit
-                        if kind `compatibleKind` @kind
-                        then Right $
-                          let pat | isLazyKind @kind = pat0
-                                  | otherwise        = @loc.addbang pat0
-                              pat0  = pp_parens pat1
-                              pat1  = @loc.nameTOut_visit >#< (ppSpaced $ map (attrname @lhs.options True chn) $ Set.toList @syn)
-                                                          >#< cont
-                              cont  = case @loc.nextVisitInfo of
-                                        NoneVis  -> empty
-                                        _        -> ch1
-                              ch0   = text $ stname chn @from
-                              ch1   = text $ stname chn @to
-                              expr  = case (kind, @kind) of
-                                        (VisitPure _,  VisitPure _)  -> expr0
-                                        (VisitPure _,  VisitMonadic) -> unMon @lhs.options >#< expr0
-                                        (VisitMonadic, VisitPure _)  -> "return" >#< expr0
-                                        (VisitMonadic, VisitMonadic) -> expr0
-                              expr0 = case @loc.prevVisitInfo of
-                                        NoneVis  -> error "error: invocation of a visit from a state that has no next visits"
-                                        OneVis _ -> "inv_" >|< @lhs.nt >|< "_s" >|< @from >#< ch0 >#< args
-                                        ManyVis  -> "inv_" >|< @lhs.nt >|< "_s" >|< @from >#< ch0
-                                                    >#< "K_" >|< @lhs.nt >|< "_v" >|< @ident >#< args
-                              args  = pp_parens args0 >#< args1
-                              args0 = @loc.nameTIn_visit >#< @loc.inhargs chn
-                              args1 | dummyTokenVisit @lhs.options = pp $ dummyArg @lhs.options True
-                                    | otherwise                    = empty
-                          in (pat, expr)  -- pretty print of the pattern and the expression part
-                        else Left $ IncompatibleVisitKind chn @ident kind @kind
-
-{
--- a `compatibleKind` b  means: can kind b be invoked from a
-compatibleKind :: VisitKind -> VisitKind -> Bool
-compatibleKind _              _             = True
-
-compatibleRule :: VisitKind -> Bool -> Bool
-compatibleRule (VisitPure _) False = False
-compatibleRule _             _     = True
-}
-
--------------------------------------------------------------------------------
---  Properties of rules
--------------------------------------------------------------------------------
-
--- Construct an environment that counts how often certain rules are used
-ATTR Visits Visit VisitSteps VisitStep [ | | ruleUsage USE {`unionWithSum`} {Map.empty} : {Map Identifier Int} ]
-ATTR ERules ERule [ usageInfo : {Map Identifier Int} | | ]
-
-SEM EProduction | EProduction  rules.usageInfo = @visits.ruleUsage
-SEM VisitStep | Sem            lhs.ruleUsage = Map.singleton @name 1
-SEM ERule | ERule              loc.used      = Map.findWithDefault 0 @name @lhs.usageInfo
-
-{
-unionWithSum = Map.unionWith (+)
-}
-
--- Collect in what visit-kinds a rule is used
-ATTR Visits Visit VisitSteps VisitStep [ | | ruleKinds USE {`unionWithMappend`} {Map.empty} : {Map Identifier (Set VisitKind)} ]
-SEM VisitStep | Sem
-  lhs.ruleKinds = Map.singleton @name (Set.singleton @lhs.kind)
-
-ATTR ERules ERule [ ruleKinds : {Map Identifier (Set VisitKind)} | | ]
-SEM EProduction | EProduction
-  rules.ruleKinds = @visits.ruleKinds
-
-SEM ERule | ERule
-  loc.kinds = Map.findWithDefault Set.empty @name @lhs.ruleKinds
-  loc.anyLazyKind = Set.fold (\k r -> isLazyKind k || r) False @loc.kinds
-
-ATTR Pattern Patterns [ anyLazyKind : Bool | | ]
-
-
--------------------------------------------------------------------------------
---  Intra attributes
--------------------------------------------------------------------------------
-{
-uwSetUnion :: (Ord a, Ord b) => Map a (Set b) -> Map a (Set b) -> Map a (Set b)
-uwSetUnion = Map.unionWith Set.union
-
-uwMapUnion :: (Ord a, Ord b) => Map a (Map b c) -> Map a (Map b c) -> Map a (Map b c)
-uwMapUnion = Map.unionWith Map.union
-}
-ATTR Visit Visits [ allintramap : {Map StateIdentifier (Map String (Maybe NonLocalAttr))}
-                    | | intramap USE {`uwMapUnion`} {Map.empty} : {Map StateIdentifier (Map String (Maybe NonLocalAttr))} ]
-
-ATTR Visit Visits [ terminaldefs : {Set String} | | ]
-ATTR EChild EChildren [ | | terminaldefs USE {`Set.union`} {Set.empty} : {Set String} ]
-
-SEM EChild | ETerm
-  lhs.terminaldefs = Set.singleton $ fieldname @name
-
-SEM EProduction | EProduction
-  visits.allintramap  = @visits.intramap
-  visits.terminaldefs = @children.terminaldefs
-
-SEM Visit
-  | Visit loc.thisintra = (@loc.uses `Map.union` @loc.nextintra) `Map.difference` @loc.defsAsMap
-          lhs.intramap  = Map.singleton @from @loc.thisintra
-          loc.nextintra = maybe Map.empty id $ Map.lookup @to @lhs.allintramap
-          loc.uses      = let mp1 = @steps.uses
-                              mp2 = Map.fromList [ (lhsname @lhs.options False i, Just (AttrSyn _LHS i)) | i <- Set.elems @syn ]
-                          in mp1 `Map.union` mp2
-          loc.inhVarNms = Set.map (lhsname @lhs.options True) @inh
-          loc.defs      = @steps.defs `Set.union` @loc.inhVarNms `Set.union` @lhs.terminaldefs
-          loc.defsAsMap = Map.fromList [ (a, Nothing) | a <- Set.elems @loc.defs ]
-
-ATTR ERule ERules [ | | ruledefs USE {`uwSetUnion`} {Map.empty} : {Map Identifier (Set String)}
-                        ruleuses USE {`uwMapUnion`} {Map.empty} : {Map Identifier (Map String (Maybe NonLocalAttr))} ]
-ATTR Visit Visits
-     VisitSteps VisitStep [ ruledefs  : {Map Identifier (Set String)}
-                            ruleuses  : {Map Identifier (Map String (Maybe NonLocalAttr))} | | ]
-
-SEM ERule
-  | ERule lhs.ruledefs = Map.singleton @name @pattern.attrs
-          lhs.ruleuses = Map.singleton @name @rhs.attrs
-
-SEM EProduction
-  | EProduction visits.ruledefs = @rules.ruledefs
-                visits.ruleuses = @rules.ruleuses
-
-ATTR Visit Visits
-     EProduction
-     EProductions
-     ENonterminal
-     ENonterminals [ | | visitdefs USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (Set Identifier)}
-                         visituses USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (Set Identifier)} ]
-
-SEM Visit
-  | Visit lhs.visitdefs = Map.singleton @ident @syn
-          lhs.visituses = Map.singleton @ident @inh
-
-ATTR Visit Visits
-     VisitSteps VisitStep
-     EProduction EProductions
-     ENonterminal ENonterminals [ avisitdefs : {Map VisitIdentifier (Set Identifier)}
-                                  avisituses : {Map VisitIdentifier (Set Identifier)} | | ]
-
-SEM ExecutionPlan
-  | ExecutionPlan nonts.avisitdefs = @nonts.visitdefs
-                  nonts.avisituses = @nonts.visituses
-
-ATTR VisitSteps VisitStep [ | | defs USE {`Set.union`} {Set.empty} : {Set String}
-                                uses USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ]
-SEM VisitStep
-  | Sem        lhs.defs = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruledefs
-               lhs.uses = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruleuses
-  | ChildVisit lhs.defs = Set.insert (stname @child @to) $ maybe (error "Visit not found") (Set.map $ attrname @lhs.options True @child) $ Map.lookup @visit @lhs.avisitdefs
-               lhs.uses = let convert attrs = Map.fromList [ (attrname @lhs.options False @child attr, Just $ mkNonLocalAttr True @child attr) | attr <- Set.elems attrs ]
-                          in Map.insert (stname @child @from) Nothing $ convert $
-                               maybe (error "Visit not found") id $ Map.lookup @visit @lhs.avisituses
-
--------------------------------------------------------------------------------
---  Identification of lazy intra defs within a production
---
--- These identifiers will not be marked as strict in rules and state closures
--------------------------------------------------------------------------------
-
-ATTR Visits Visit VisitSteps VisitStep [ | | lazyIntras USE {`Set.union`} {Set.empty} : {Set String} ]
-ATTR ERules ERule [ lazyIntras : {Set String} | | ]
-
-SEM Visit | Visit
-  loc.lazyIntrasInh = case @kind of
-                        VisitPure False -> @loc.inhVarNms `Set.union` @steps.defs
-                        _               -> Set.empty
-  lhs.lazyIntras = @loc.lazyIntrasInh `Set.union` @steps.lazyIntras
-
-SEM VisitStep | PureGroup
-  lhs.lazyIntras = if @ordered
-                   then @steps.lazyIntras
-                   else @steps.defs
-
-SEM EProduction | EProduction
-  loc.lazyIntras = @visits.lazyIntras
-
--------------------------------------------------------------------------------
---  Pretty printing of haskell code
--------------------------------------------------------------------------------
-
-SEM HsTokens [ || tks : {[(Pos,String)]} ]
-  | Cons lhs.tks = @hd.tok : @tl.tks
-  | Nil  lhs.tks = []
-
-SEM HsToken
-  | AGLocal   loc.tok = (@pos,fieldname @var)
-
-SEM HsToken [ || tok:{(Pos,String)}]
-   | AGField
-       loc.addTrace = case @rdesc of
-                        Just d  -> \x -> "(trace " ++ show (d ++ " -> " ++ show @field ++ "." ++ show @attr) ++ " (" ++ x ++ "))"
-                        Nothing -> id
-       lhs.tok = (@pos, @loc.addTrace $ attrname @lhs.options True @field @attr)
-
-   | HsToken lhs.tok = (@pos, @value)
-
-   | CharToken lhs.tok = (@pos, if null @value
-                                   then ""
-                                   else showCharShort (head @value)
-                         )
-
-   | StrToken  lhs.tok = (@pos, showStrShort @value)
-   | Err       lhs.tok = (@pos, "")
-
--------------------------------------------------------------------------------
---  Alternative code generation (sepsemmods)
--------------------------------------------------------------------------------
-
-ATTR ExecutionPlan [ mainBlocksDoc : PP_Doc textBlockMap : {Map BlockInfo PP_Doc}
-                   | | genIO : {IO ()} ]
-
-SEM ExecutionPlan
-  | ExecutionPlan lhs.genIO           = do @loc.genMainModule
-                                           @loc.genCommonModule
-                                           @nonts.genProdIO
-                  loc.mainModuleFile  = @lhs.mainFile
-                  loc.ppMonadImports  = ( if tupleAsDummyToken @lhs.options
-                                          then empty
-                                          else pp "import GHC.Prim"
-                                        )
-                                        >-< if parallelInvoke @lhs.options
-                                            then pp "import qualified System.IO.Unsafe(unsafePerformIO)"
-                                                 >-< pp "import System.IO(IO)"
-                                                 >-< pp "import Control.Concurrent(newEmptyMVar,forkIO,putMVar,takeMVar)"
-                                            else pp "import Control.Monad.Identity"
-                  loc.genMainModule   = writeModule @loc.mainModuleFile
-                                          ( [ warrenFlagsPP @lhs.options
-                                            , pp $ @lhs.pragmaBlocks
-                                            , pp $ @lhs.moduleHeader @lhs.mainName "" "" False
-                                            , @loc.ppMonadImports
-                                            , pp $ "import " ++ @lhs.mainName ++ "_common"
-                                            ]
-                                            ++ @nonts.imports
-                                            ++ [@lhs.mainBlocksDoc]
-                                            ++ [@loc.wrappersExtra]
-                                            ++ @nonts.appendMain
-                                          )
-                  loc.commonFile      = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_common")
-                  loc.genCommonModule = writeModule @loc.commonFile
-                                          ( [ pp $ "{-# LANGUAGE Rank2Types, GADTs #-}"  -- the common module only needs GADTs and Rank2Types
-                                            , pp $ @lhs.pragmaBlocks
-                                            , pp $ @lhs.moduleHeader @lhs.mainName "_common" "" True
-                                            , @loc.ppMonadImports
-                                            , @lhs.importBlocks
-                                            , @lhs.textBlocks
-                                            , @loc.commonExtra
-                                            ]
-                                            ++ @nonts.appendCommon
-                                          )
-
-ATTR ENonterminal  [ | | appendCommon, appendMain              : { PP_Doc } ]
-ATTR ENonterminals [ | | appendCommon, appendMain USE {:} {[]} : {[PP_Doc]} ]
-
-SEM ENonterminal
-  | ENonterminal lhs.appendMain   = (if @nt `Set.member` @lhs.wrappers
-                                     then     @loc.wr_inh
-                                          >-< @loc.wr_syn
-                                          >-< @loc.wrapper
-                                     else empty)
-                                    >-< @loc.sem_nt
-                 lhs.appendCommon = (if dataTypes @lhs.options then @loc.datatype else empty)
-                                    >-< @loc.t_init
-                                    >-< @loc.t_states
-                                    >-< @loc.k_states
-                                    >-< @prods.t_visits
-
-ATTR EProduction EProductions
-     ENonterminal ENonterminals [ | | imports USE {++} {[]} : {[PP_Doc]}
-                                      genProdIO USE {>>} {return ()} : {IO ()} ]
-
-SEM EProduction
-  | EProduction lhs.imports    = [pp $ "import " ++ @loc.moduleName]
-                loc.moduleName = @lhs.mainName ++ @loc.suffix
-                loc.suffix     = "_" ++ show @lhs.nt ++ "_" ++ show @con
-                loc.outputfile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ @loc.suffix)
-                loc.ppMonadImports  = if parallelInvoke @lhs.options
-                                      then pp "import qualified System.IO.Unsafe(unsafePerformIO)"
-                                           >-< pp "import System.IO(IO)"
-                                           >-< pp "import Control.Concurrent(newEmptyMVar,forkIO,putMVar,takeMVar)"
-                                      else pp "import Control.Monad.Identity"
-                lhs.genProdIO  = writeModule @loc.outputfile
-                                     [ warrenFlagsPP @lhs.options
-                                     , pp $ @lhs.pragmaBlocks
-                                     , pp $ @lhs.moduleHeader @lhs.mainName @loc.suffix @loc.semname True
-                                     , @lhs.importBlocks
-                                     , @loc.ppMonadImports
-                                     , ( if tupleAsDummyToken @lhs.options
-                                            then empty
-                                            else pp "import GHC.Prim"  -- need it to pass State#
-                                      )
-                                     , pp $ "import " ++ @lhs.mainName ++ "_common"
-                                     , @loc.sem_prod
-                                     ]
-
-{
-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
-}
-
-
---
--- Bang pattern usage
---
-
-SEM ERule | ERule                   loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x
-SEM Visit | Visit                   loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x
-SEM ENonterminal | ENonterminal     loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x
-SEM EProduction | EProduction       loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x
-SEM EChild | EChild                 loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x
-SEM EChild | ETerm                  loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x
-SEM VisitStep | ChildVisit          loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x
-SEM Pattern | Alias Constr Product  loc.addbang  = \x -> if bangpats @lhs.options then "!" >|< x else x
-
-SEM Visit | Visit                   loc.addbang1 = if isLazyKind @kind then id else @loc.addbang
-SEM ENonterminal | ENonterminal     loc.addbangWrap = id --if strictWrap @lhs.options then @loc.addbang else id
-SEM ERule | ERule                   loc.addbang1 = if @loc.anyLazyKind then id else @loc.addbang
-SEM Pattern | Alias Constr Product  loc.addbang1 = if @lhs.anyLazyKind then id else @loc.addbang
-
---
--- Distribute single-visit-next map downward
---
-
-ATTR EProductions EProduction Visits Visit
-  [ prevVisits, nextVisits : {Map StateIdentifier StateCtx} | | ]
-
-SEM ENonterminal | ENonterminal
-  prods.nextVisits = @nextVisits
-  prods.prevVisits = @prevVisits
-
---
--- Collect and distribute the from/to states of a visit
---
-
-ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit
-  [ | | fromToStates USE {`mappend`} {mempty} : {Map VisitIdentifier (Int,Int)} ]
-
-ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep
-  [ allFromToStates : {Map VisitIdentifier (Int,Int)} | | ]
-
-SEM Visit | Visit
-  lhs.fromToStates = Map.singleton @ident (@from, @to)
-
-SEM ExecutionPlan | ExecutionPlan
-  nonts.allFromToStates = @nonts.fromToStates
-
-SEM VisitStep | ChildVisit
-  (loc.from, loc.to) = Map.findWithDefault (error "visit not in allFromToStates") @visit @lhs.allFromToStates
-
-
---
--- Collect and distribute the actual types of children of productions
---
-
-ATTR EChildren EChild [ | | childTypes USE {`mappend`} {mempty} : {Map Identifier Type} ]
-ATTR ERules ERule Visits Visit VisitSteps VisitStep [ childTypes : {Map Identifier Type} | | ]
-
-SEM EProduction | EProduction
-  loc.childTypes = Map.singleton _LHS @lhs.ntType `Map.union` @children.childTypes
-
-SEM EChild | EChild ETerm
-  lhs.childTypes = Map.singleton @name @tp
-
---
--- Distribute types of local attributes
---
-
-ATTR ExecutionPlan ENonterminals ENonterminal  [ localAttrTypes : {Map NontermIdent (Map ConstructorIdent (Map Identifier Type))} | | ]
-ATTR EProductions EProduction                  [ localAttrTypes : {Map ConstructorIdent (Map Identifier Type)} | | ]
-ATTR ERules ERule Pattern Patterns             [ localAttrTypes : {Map Identifier Type} | | ]
-
-SEM ENonterminal | ENonterminal
-  prods.localAttrTypes = Map.findWithDefault Map.empty @nt @lhs.localAttrTypes
-
-SEM EProduction | EProduction
-  loc.localAttrTypes   = Map.findWithDefault Map.empty @con @lhs.localAttrTypes
-
---
--- Collect and distribute visit kinds
---
-
-ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep
-  [ allVisitKinds : {Map VisitIdentifier VisitKind} | | visitKinds USE {`mappend`} {mempty} : {Map VisitIdentifier VisitKind} ]
-
-SEM Visit | Visit
-  lhs.visitKinds = Map.singleton @ident @kind
-
-SEM ExecutionPlan | ExecutionPlan
-  nonts.allVisitKinds = @nonts.visitKinds
-
---
--- Collect and distribute the initial state of nonterminals
---
-
-ATTR ENonterminals ENonterminal [ | | initStates USE {`mappend`} {mempty} : {Map NontermIdent Int} ]
-ATTR ENonterminals ENonterminal EProductions EProduction EChildren EChild Visits Visit VisitSteps VisitStep
-  [ allInitStates : {Map NontermIdent Int} | | ]
-
-SEM ENonterminal | ENonterminal
-  lhs.initStates = Map.singleton @nt @initial
-
-SEM ExecutionPlan | ExecutionPlan
-  nonts.allInitStates = @nonts.initStates
-
-SEM EChild | EChild
-  loc.initSt = Map.findWithDefault (error "nonterminal not in allInitStates map") @loc.nt @lhs.allInitStates
-
---
--- Push the nonterminal type downward
---
-
-ATTR EProductions EProduction [ ntType : Type | | ]
-SEM ENonterminal | ENonterminal
-  loc.ntType = NT @nt (map show @params) False
-
---
--- Collect errors contained in rules that should be yielded when the
--- rules are scheduled.
---
-
-ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule Visits Visit VisitSteps VisitStep [ | | errors USE {Seq.><} {Seq.empty} : {Seq Error} ]
-SEM ERule | ERule
-  lhs.errors = case @mbError of
-                 Just e | @loc.used > 0 -> Seq.singleton e
-                 _                      -> Seq.empty
-
-
--- Some pretty printing utility functions
-{
-ppNoInline :: PP a => a -> PP_Doc
-ppNoInline = ppPragmaBinding "NOINLINE"
-
-ppInline :: PP a => a -> PP_Doc
-ppInline = ppPragmaBinding "INLINE"
-
-ppInlinable :: PP a => a -> PP_Doc
-ppInlinable = ppPragmaBinding "INLINABLE"
-
-ppPragmaBinding :: (PP a, PP b) => a -> b -> PP_Doc
-ppPragmaBinding pragma nm = "{-#" >#< pragma >#< nm >#< "#-}"
-
-ppCostCentre :: PP a => a -> PP_Doc
-ppCostCentre nm = "{-#" >#< "SCC" >#< "\"" >|< nm >|< "\"" >#< "#-}"
-
-warrenFlagsPP :: Options -> PP_Doc
-warrenFlagsPP options = vlist
-  [ pp "{-# LANGUAGE Rank2Types, GADTs #-}"
-  , if bangpats options
-    then pp "{-# LANGUAGE BangPatterns #-}"
-    else empty
-  , if noPerRuleTypeSigs options && noPerStateTypeSigs options
-    then empty
-    else pp "{-# LANGUAGE ScopedTypeVariables #-}"
-  , if tupleAsDummyToken options
-    then empty
-    else pp "{-# LANGUAGE ScopedTypeVariables, MagicHash #-}"
-  , -- not that the meaning of "unbox" is here that strict fields in data types may be
-    -- unboxed if possible. This may affect user-defined data types declared in the module.
-    -- Unfortunately, we cannot turn it on for only the AG generated data types without
-    -- causing a zillion of warnings.
-    if unbox options && bangpats options
-        then pp $ "{-# OPTIONS_GHC -funbox-strict-fields -fstrictness #-}"
-        else empty
-  , if parallelInvoke options && not (noEagerBlackholing options)
-    then pp $ "{-# OPTIONS_GHC -feager-blackholing #-}"
-    else empty
-  ]
-}
+INCLUDE "ExecutionPlan.ag"+INCLUDE "Patterns.ag"+INCLUDE "Expression.ag"+INCLUDE "HsToken.ag"++imports+{+import ExecutionPlan+import Pretty+import PPUtil+import Options+import Data.Monoid(mappend,mempty)+import Data.Maybe+import Debug.Trace+import System.IO+import System.Directory+import System.FilePath+import UU.Scanner.Position++import TokenDef+import HsToken+import ErrorMessages++import Data.Set (Set)+import qualified Data.Set as Set+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Sequence(Seq)+import qualified Data.Sequence as Seq+import Data.Foldable(toList)+}++ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule EChildren EChild+  [ importBlocks : PP_Doc+    pragmaBlocks : String+    textBlocks   : PP_Doc+    moduleHeader : {String -> String -> String -> Bool -> String}+    mainFile     : String+    mainName     : String | | ]++-------------------------------------------------------------------------------+--  Options+-------------------------------------------------------------------------------+ATTR ExecutionPlan+     ENonterminals ENonterminal+     EProductions EProduction+     ERules ERule+     EChildren EChild+     Expression+     HsToken HsTokens HsTokensRoot+     Pattern Patterns+     Visits Visit+     VisitSteps VisitStep [ options : {Options} | | ]+ATTR EProductions EProduction [ rename : {Bool} | | ]++SEM ENonterminal+  | ENonterminal prods.rename = rename @lhs.options++-------------------------------------------------------------------------------+--  Context info (nonterminal ident, constructor ident, nonterm params, etc.)+-------------------------------------------------------------------------------++ATTR Visit Visits EProduction EProductions EChildren EChild ERules ERule [ nt : NontermIdent | | ]+SEM ENonterminal+  | ENonterminal prods.nt = @nt++ATTR EChildren EChild ERules ERule Visits Visit+  [ con : ConstructorIdent | | ]++SEM EProduction+  | EProduction children.con = @con+                rules.con    = @con+                visits.con   = @con++ATTR EProductions EProduction Visits Visit [ params : {[Identifier]} | | ]+SEM ENonterminal | ENonterminal+  prods.params = @params++ATTR EProductions EProduction [ classCtxs : ClassContext | | ]+SEM ENonterminal | ENonterminal+  prods.classCtxs = @classCtxs++-------------------------------------------------------------------------------+--  Default output+-------------------------------------------------------------------------------+ATTR ExecutionPlan [  | | output : {PP_Doc} ]++SEM ExecutionPlan+  | ExecutionPlan lhs.output = @nonts.output >-< @loc.commonExtra >-< @loc.wrappersExtra++ATTR ENonterminal ENonterminals [ wrappers : {Set NontermIdent}+                                 | | output USE {>-<} {empty} : {PP_Doc} ]++SEM ExecutionPlan+  | ExecutionPlan nonts.wrappers = @wrappers++SEM ENonterminal+  | ENonterminal lhs.output = ("-- " ++ getName @nt ++ " " ++ replicate (60 - length (getName @nt)) '-')+                              >-< (if dataTypes @lhs.options+                                   then "-- data"+                                        >-< @loc.datatype+                                        >-< ""+                                   else empty)+                              >-< (if @loc.hasWrapper+                                   then "-- wrapper"+                                        >-< @loc.wr_inh+                                        >-< @loc.wr_syn+                                        >-< @loc.wrapper+                                        >-< ""+                                   else empty)+                              >-< (if   folds @lhs.options+                                   then "-- cata"+                                        >-< @loc.sem_nt+                                        >-< ""+                                   else empty)+                              >-< (if   semfuns @lhs.options+                                   then "-- semantic domain"+                                        >-< @loc.t_init+                                        >-< @loc.t_states+                                        >-< @loc.k_states+                                        >-< @prods.t_visits+                                        >-< @prods.sem_prod+                                        >-< ""+                                   else empty)+                 loc.hasWrapper = @nt `Set.member` @lhs.wrappers++-------------------------------------------------------------------------------+--  Nonterminal datatype+-------------------------------------------------------------------------------+ATTR ENonterminal ENonterminals [ typeSyns : {TypeSyns}+                                  derivings : {Derivings} | | ]++SEM ExecutionPlan+  | ExecutionPlan nonts.typeSyns = @typeSyns+                  nonts.derivings = @derivings++SEM ENonterminal+  | ENonterminal loc.classPP  = ppClasses $ classCtxsToDocs @classCtxs+                 loc.aliasPre = "type" >#< @loc.classPP >#< @nt >#< @loc.t_params >#< "="+                 loc.datatype = case lookup @nt @lhs.typeSyns of+                                   Nothing -> "data" >#< @loc.classPP >#< @nt >#< @loc.t_params+                                              >-< ( if null @prods.datatype+                                                    then empty+                                                    else indent 2 $ vlist $ ( ("=" >#< head @prods.datatype)+                                                                            : (map ("|" >#<) $ tail @prods.datatype))+                                                  )+                                              >-< indent 2 @loc.derivings+                                   Just (List t)     -> @loc.aliasPre >#< "[" >#< show t >#< "]"+                                   Just (Maybe t)    -> @loc.aliasPre >#< "Maybe" >#< pp_parens (show t)+                                   Just (Tuple ts)   -> @loc.aliasPre >#< pp_parens (ppCommas $ map (show . snd) ts)+                                   Just (Either l r) -> @loc.aliasPre >#< "Either" >#< pp_parens (show l) >#< pp_parens (show r)+                                   Just (Map k v)    -> @loc.aliasPre >#< "Data.Map" >#< pp_parens (show k) >#< pp_parens (show v)+                                   Just (IntMap t)   -> @loc.aliasPre >#< "Data.IntMap.IntMap" >#< pp_parens (show t)+                                   Just (OrdSet t)   -> @loc.aliasPre >#< "Data.Set.Set" >#< pp_parens (show t)+                                   Just IntSet       -> @loc.aliasPre >#< "Data.IntSet.IntSet"+--                                   Just x -> error $ "Type " ++ show x ++ " is not supported"+                 loc.derivings = case Map.lookup @nt @lhs.derivings of+                                    Nothing -> empty+                                    Just s  -> if   Set.null s+                                               then empty+                                               else "deriving" >#< (pp_parens $ ppCommas $ map pp $ Set.toList s)++{+classCtxsToDocs :: ClassContext -> [PP_Doc]+classCtxsToDocs = map toDoc where+  toDoc (ident,args) = (ident >#< ppSpaced (map pp_parens args))++classConstrsToDocs :: [Type] -> [PP_Doc]+classConstrsToDocs = map ppTp++ppClasses :: [PP_Doc] -> PP_Doc+ppClasses [] = empty+ppClasses xs = pp_block "(" ")" "," xs >#< "=>"++ppQuants :: [Identifier] -> PP_Doc+ppQuants [] = empty+ppQuants ps = "forall" >#< ppSpaced ps >#< "."+}++ATTR EProduction  [ | | datatype : {PP_Doc} ]+ATTR EProductions [ | | datatype USE {:} {[]} : {[PP_Doc]} ]++-- we generate the data type in the type-class style instead of the GADT style+-- the GADT extension may be required if equality constraints are used+SEM EProduction+  | EProduction lhs.datatype = @loc.quantPP1 >#< @loc.classPP1+                               >#< conname @lhs.rename @lhs.nt @con+                               >#< ppConFields (dataRecords @lhs.options) @children.datatype+                loc.classPP1 = ppClasses (classConstrsToDocs @constraints)+                loc.quantPP1 = ppQuants @params++{+-- first parameter indicates: generate a record or not+ppConFields :: Bool -> [PP_Doc] -> PP_Doc+ppConFields True  flds = ppListSep "{" "}" ", " $ filter (not . isEmpty) flds+ppConFields False flds = ppSpaced flds+}+++ATTR EChild    [ | | datatype : {PP_Doc} ]+ATTR EChildren [ | | datatype USE {:} {[]} : {[PP_Doc]} ]++-- Note: the child may be a higher-order attribute, and its semantics may be deforested+SEM EChild+  | EChild ETerm+      loc.tpDoc  = @loc.addStrict $ pp_parens $ ppTp $ removeDeforested @tp+      loc.strNm  = recordFieldname @lhs.nt @lhs.con @name+      loc.field  = if dataRecords @lhs.options+                   then @loc.strNm >#< "::" >#< @loc.tpDoc+                   else @loc.tpDoc+      loc.addStrict = \x -> if strictData @lhs.options then "!" >|< x else x+  | EChild  lhs.datatype = case @kind of+                             ChildAttr -> empty  -- higher order attributes are not part of the data type+                             _         -> @loc.field++  | ETerm   lhs.datatype = @loc.field++{+ppTp :: Type -> PP_Doc+ppTp = text . typeToHaskellString Nothing []+}++-------------------------------------------------------------------------------+--  Nonterminal semantic function+-------------------------------------------------------------------------------+SEM ENonterminal+  | ENonterminal loc.fsemname = \x -> "sem_" ++ show x+                 loc.semname = @loc.fsemname @nt+                 loc.frecarg = \t x -> case t of+                                          NT nt _ _ -> pp_parens (@fsemname nt >#< x)+                                          _         -> pp x++                 -- The sem_NT function is lazy in the AST: it depends on the application of "child"+                 -- rules to which extend the AST needs to be constructed.+                 loc.sem_tp  = @loc.quantPP >#< @loc.classPP >#< @nt >#< @loc.t_params >#< "->" >#< @loc.t_type >#< @loc.t_params+                 loc.quantPP = ppQuants @params+                 loc.sem_nt  = @loc.semPragma+                               >-< @loc.semname >#< "::" >#< @loc.sem_tp+                               >-< case lookup @nt @lhs.typeSyns of+                                      Nothing -> @prods.sem_nt+                                      Just (List t) -> @loc.semname >#< "list" >#< "=" >#< "Prelude.foldr" >#< @loc.semname >|< "_Cons"+                                                       >#< @loc.semname >|< "_Nil"+                                                       >#< case t of+                                                              NT nt _ _ -> pp_parens ("Prelude.map" >#< @fsemname nt >#< "list")+                                                              _         -> pp "list"+                                      Just (Maybe t) -> @loc.semname >#< "Prelude.Nothing" >#< "=" >#< @loc.semname >|< "_Nothing"+                                                        >-< @loc.semname >#< pp_parens ("Prelude.Just just") >#< "="+                                                        >#< @loc.semname >|< "_Just" >#< @frecarg t "just"+                                      Just (Tuple ts) -> @loc.semname >#< pp_parens (ppCommas $ map fst ts) >#< "="+                                                         >#< @loc.semname >|< "_Tuple" >#< ppSpaced (map (\t -> @frecarg (snd t) (show $ fst t)) ts)+                                      Just (Either l r) -> @loc.semname >#< "(Prelude.Left left)" >#< "=" >#< @loc.semname >|< "_Left" >#< @frecarg l "left"+                                                           >-< @loc.semname >#< "(Prelude.Right right)" >#< "=" >#< @loc.semname >|< "_Right" >#< @frecarg r "right"+                                      Just (Map k v) -> @loc.semname >#< "m" >#< "=" >#< "Data.Map.foldrWithKey"+                                                        >#< @loc.semname >|< "_Entry" >#< @loc.semname >|< "_Nil"+                                                        >#< case v of+                                                               NT nt _ _ -> pp_parens ("Data.Map.map" >#< @fsemname nt >#< "m")+                                                               _         -> pp "m"+                                      Just (IntMap v) -> @loc.semname >#< "m" >#< "=" >#< "Data.IntMap.foldWithKey"+                                                         >#< @loc.semname >|< "_Entry" >#< @loc.semname >|< "_Nil"+                                                         >#< case v of+                                                                NT nt _ _ -> pp_parens ("Data.IntMap.map" >#< @fsemname nt >#< "m")+                                                                _         -> pp "m"+                                      Just (OrdSet t) -> @loc.semname >#< "s" >#< "=" >#< "Prelude.foldr" >#< @loc.semname >|< "_Entry"+                                                         >#< @loc.semname >|< "_Nil"+                                                         >#< pp_parens (+                                                               ( case t of+                                                                   NT nt _ _ -> pp_parens ("Prelude.map" >#< @fsemname nt)+                                                                   _         -> empty+                                                               ) >#< pp_parens ("Data.IntSet.elems" >#< "s")+                                                             )+                                      Just IntSet     -> @loc.semname >#< "s" >#< "=" >#< "Prelude.foldr" >#< @loc.semname >|< "_Entry"+                                                         >#< @loc.semname >|< "_Nil"+                                                         >#< pp_parens ("Data.IntSet.elems" >#< "s")+--                                      Just x -> error $ "Type " ++ show x ++ " is not supported yet" -- TODO: other typeSyns++                -- precise inlining strategies for inlining+                loc.inlineNt  = not (lateHigherOrderBinding @lhs.options) && not @recursive && (@prods.count == 1 || (aggressiveInlinePragmas @lhs.options && not @loc.hasWrapper))  -- lucrative for inlining+                loc.semPragma = if noInlinePragmas @lhs.options+                                then empty+                                else if @loc.inlineNt+                                     then ppInline @loc.semname+                                     else if helpInlining @lhs.options && not (lateHigherOrderBinding @lhs.options)+                                          then ppInlinable @loc.semname+                                          else ppNoInline @loc.semname++-- The number of productions+ATTR EProductions EProduction [ | | count USE {+} {0} : {Int} ]+SEM EProduction | EProduction  lhs.count = {1}++-- The per-production cases for the sem_NT function+ATTR EProduction EProductions [ | | sem_nt USE {>-<} {empty} : {PP_Doc} ]+SEM EProduction+  | EProduction lhs.sem_nt = "sem_" >|< @lhs.nt >#< "(" >#< conname @lhs.rename @lhs.nt @con >#< ppSpaced @children.argpats >#< ")"+                             >#< "=" >#< "sem_" >|< @lhs.nt >|< "_" >|< @con >#< ppSpaced @children.argnamesw++ATTR EChild    [ | | argnamesw              : { PP_Doc } ]+ATTR EChildren [ | | argnamesw USE {:} {[]} : {[PP_Doc]} ]++SEM EChild+  | EChild lhs.argnamesw = case @kind of+                             ChildSyntax     -> "(" >#< "sem_" >|< @loc.nt >#< @name >|< "_" >#< ")"+                             ChildAttr       -> empty  -- no sem-case for a higher-order child+                             ChildReplace tp -> "(" >#< "sem_" >|< extractNonterminal tp >#< @name >|< "_" >#< ")"+  | ETerm  lhs.argnamesw = text $ fieldname @name++-------------------------------------------------------------------------------+--  Types of attributes+-------------------------------------------------------------------------------+ATTR ExecutionPlan+     ENonterminals+     ENonterminal  [ inhmap : {Map NontermIdent Attributes}+                     synmap : {Map NontermIdent Attributes} | | ]++ATTR EProductions EProduction+     ERules ERule+     Patterns Pattern+     Visits+     Visit   [ inhmap : {Attributes}+               synmap : {Attributes}+               allInhmap : {Map NontermIdent Attributes}+               allSynmap : {Map NontermIdent Attributes} | | ]++SEM ENonterminal+  | ENonterminal (Just prods.inhmap) = Map.lookup @nt @lhs.inhmap+                 (Just prods.synmap) = Map.lookup @nt @lhs.synmap+                 prods.allInhmap = @lhs.inhmap+                 prods.allSynmap = @lhs.synmap++-------------------------------------------------------------------------------+--  State datatypes+-------------------------------------------------------------------------------+{type VisitStateState = (VisitIdentifier,StateIdentifier, StateIdentifier)}++ATTR Visit  [ | | allvisits              : { VisitStateState }]+ATTR Visits [ | | allvisits USE {:} {[]} : {[VisitStateState]}]+ATTR EProduction+     EProductions [ | | allvisits: {[VisitStateState]}]++SEM Visit+  | Visit lhs.allvisits = (@ident, @from, @to)++SEM EProductions+  | Cons lhs.allvisits = @hd.allvisits -- just pick the first production+  | Nil  lhs.allvisits = error "Every nonterminal should have at least 1 production"++-- type of tree in a given state s+SEM ENonterminal+  | ENonterminal loc.outedges  = Set.fromList $ map (\(_,f,_) -> f) @prods.allvisits+                 loc.inedges   = Set.fromList $ map (\(_,_,t) -> t) @prods.allvisits+                 loc.allstates = Set.insert @initial $ @loc.inedges `Set.union` @loc.outedges+                 loc.stvisits  = \st -> filter (\(v,f,t) -> f == st) @prods.allvisits+                 loc.t_type    = "T_" >|< @nt+                 loc.t_params  = ppSpaced @params+                 loc.t_init    = "newtype" >#< @loc.t_type >#< @loc.t_params >#< "=" >#< @loc.t_type >#<+                                   pp_braces (+                                     "attach_">|< @loc.t_type >#< "::"+                                       >#< ppMonadType @lhs.options >#< pp_parens (@loc.t_type >|< "_s" >|< @initial >#< @loc.t_params))+                 loc.t_states  = vlist $ map (\st ->+                                    let nt_st = @nt >|< "_s" >|< st+                                        t_st  = "T_" >|< nt_st+                                        k_st  = "K_" >|< nt_st+                                        c_st  = "C_" >|< nt_st+                                        inv_st  = "inv_" >|< nt_st+                                        nextVisit = Map.findWithDefault ManyVis st @nextVisits+                                    in  case nextVisit of+                                          NoneVis    -> "data" >#< t_st >#< @loc.t_params >#< "=" >#< c_st  -- empty semantics+                                          OneVis vId -> "newtype" >#< t_st >#< @loc.t_params >#< "=" >#< c_st+                                                         >#< (pp_braces $ inv_st >#< "::" >#< pp_parens (conNmTVisit @nt vId >#< @loc.t_params))+                                          ManyVis    -> "data" >#< t_st >#< @loc.t_params >#< "where" >#< c_st >#< "::"+                                                          >#< (pp_braces $ inv_st >#< "::" >#< "!" >|< pp_parens ("forall t." >#< k_st >#< @loc.t_params >#< "t" >#< "->" >#< "t"))+                                                          >#< "->" >#< t_st >#< @loc.t_params  -- this is a conventional data type, but declared with GADT syntax+                                        ) $ Set.toList @loc.allstates++-- type of a key which identifies a visit v from state s+SEM ENonterminal+  | ENonterminal loc.k_type   = "K_" ++ show @nt+                 loc.k_states = vlist $ map (\st ->+                                   let nt_st = @nt >|< "_s" >|< st+                                       k_st  = "K_" >|< nt_st+                                       outg  = filter (\(v,f,t) -> f == st) @prods.allvisits+                                       visitlist = vlist $ map (\(v,f,t) ->+                                           @loc.k_type >|< "_v" >|< v >#< "::" >#< k_st >#< @loc.t_params >#< pp_parens (@loc.t_type >|< "_v" >|< v >#< @loc.t_params)+                                            ) outg+                                       nextVisit = Map.findWithDefault ManyVis st @nextVisits+                                       decl = "data" >#< k_st >#< "k" >#< @loc.t_params >#< "where" >-< indent 3 visitlist+                                   in  case nextVisit of+                                         NoneVis  -> empty+                                         OneVis _ -> empty+                                         ManyVis  -> decl+                                   ) $ Set.toList @loc.allstates++-- type of a visit v, with continuation as new state s+ATTR Visit Visits EProduction EProductions [ | | t_visits USE {>-<} {empty} : {PP_Doc} ]++SEM EProductions+  | Cons lhs.t_visits = @hd.t_visits -- just pick the first production++SEM Visit+  | Visit loc.nameT_visit     = conNmTVisit @lhs.nt @ident+          loc.nameTIn_visit   = conNmTVisitIn @lhs.nt @ident+          loc.nameTOut_visit  = conNmTVisitOut @lhs.nt @ident+          loc.nameTNext_visit = conNmTNextVisit @lhs.nt @to++          loc.nextVisitInfo   = Map.findWithDefault ManyVis @to @lhs.nextVisits  -- which visits can we do after we reach the @to state?+          loc.typecon         = case @kind of+                                  VisitPure _  -> empty+                                  VisitMonadic -> ppMonadType @lhs.options++          loc.t_params  = ppSpaced @lhs.params+          lhs.t_visits = "type" >#< @loc.nameT_visit >#< @loc.t_params >#< "=" >#<+                           pp_parens (@loc.nameTIn_visit >#< @loc.t_params)+                             >#< ( if dummyTokenVisit @lhs.options+                                   then "->" >#< dummyType @lhs.options True  -- Additional (unused though) argument+                                   else empty+                                 )+                             >#< "->" >#< @loc.typecon >#< pp_parens (@loc.nameTOut_visit >#< @loc.t_params)+                         >-< "data" >#< @loc.nameTIn_visit >#< @loc.t_params >#< "=" >#< @loc.nameTIn_visit >#<+                              @loc.inhpart+                         >-< "data" >#< @loc.nameTOut_visit >#< @loc.t_params >#< "=" >#< @loc.nameTOut_visit >#<+                              @loc.synpart >#< case @loc.nextVisitInfo of+                                                 NoneVis    -> empty                    -- don't return a continuation at all+                                                 _          -> @loc.addbang1 $ pp_parens (@loc.nameTNext_visit >#< @loc.t_params)  -- normal route: select the next semantics+          loc.inhpart   = @loc.ppTypeList @inh @lhs.inhmap+          loc.synpart   = @loc.ppTypeList @syn @lhs.synmap+          loc.ppTypeList = \s m -> ppSpaced $ map (\i -> @loc.addbang1 $ pp_parens $ case Map.lookup i m of+                                                                                      Just tp -> ppTp tp ) $ Set.toList s++{+conNmTVisit nt vId      = "T_" >|< nt >|< "_v"    >|< vId+conNmTVisitIn nt vId    = "T_" >|< nt >|< "_vIn"  >|< vId+conNmTVisitOut nt vId   = "T_" >|< nt >|< "_vOut" >|< vId+conNmTNextVisit nt stId = "T_" >|< nt >|< "_s"    >|< stId++ppMonadType :: Options -> PP_Doc+ppMonadType opts+  | parallelInvoke opts = text "IO"+  | otherwise           = text "Identity"+}++-------------------------------------------------------------------------------+--  Inh and Syn wrappers+-------------------------------------------------------------------------------+SEM ENonterminal+  | ENonterminal loc.wr_inh   = @loc.genwrap "Inh" @loc.wr_inhs+                 loc.wr_syn   = @loc.genwrap "Syn" @loc.wr_syns+                 loc.genwrap  = \nm attr -> "data" >#< nm >|< "_" >|< @nt >#< @loc.t_params >#< "=" >#< nm >|< "_" >|< @nt >#< "{"+                                            >#< (ppCommas $ map (\(i,t) -> i >|< "_" >|< nm >|< "_" >|< @nt >#< "::"+                                            >#< (@loc.addbang $ pp_parens $ typeToHaskellString (Just @nt) [] t)) attr) >#< "}"+                 loc.synAttrs = fromJust $ Map.lookup @nt @lhs.inhmap+                 loc.wr_inhs  = Map.toList $ @loc.wr_filter $ @loc.synAttrs+                 loc.wr_inhs1 = Map.toList @loc.synAttrs+                 loc.wr_filter = if lateHigherOrderBinding @lhs.options+                                 then Map.delete idLateBindingAttr+                                 else id+                 loc.wr_syns  = Map.toList $ fromJust $ Map.lookup @nt @lhs.synmap+                 loc.inhlist  = map (lhsname @lhs.options True . fst) @loc.wr_inhs+                 loc.inhlist1 = map (lhsname @lhs.options True . fst) @loc.wr_inhs1+                 loc.synlist  = map (lhsname @lhs.options False . fst) @loc.wr_syns+                 loc.wrapname = "wrap_" ++ show @nt+                 loc.inhname  = "Inh_" ++ show @nt+                 loc.synname  = "Syn_" ++ show @nt+                 loc.firstVisitInfo = Map.findWithDefault ManyVis @initial @nextVisits+                 loc.wrapper  = @loc.wrapPragma+                                >-< (@loc.wrapname >#< "::" >#< @loc.quantPP >#< @loc.classPP >#< @loc.t_type >#< @loc.t_params >#< "->"+                                      >#< @loc.inhname >#< @loc.t_params >#< "->" >#< ( if monadicWrappers @lhs.options then ppMonadType @lhs.options else empty) >#< pp_parens (@loc.synname >#< @loc.t_params))+                                >-< (@loc.wrapname >#< (@loc.addbang $ pp_parens (@loc.t_type >#< pp "act"))+                                    >#< (@loc.addbang $ pp_parens (@loc.inhname+                                           >#< (ppSpaced $ map (@loc.addbangWrap . pp) @loc.inhlist)) >#< "="))+                                >-<+                                indent 3 (case @initialv of+                                  -- case where there are no inherited or synthesized attributes+                                  [] -> @loc.synname >#< " { }"+                                  initvs@(initv:_) ->+                                    let extra  = if dummyTokenVisit @lhs.options+                                                 then pp $ dummyArg @lhs.options True+                                                 else empty+                                        unMonad | monadicWrappers @lhs.options = empty+                                                | otherwise                    = unMon @lhs.options+                                        genSteps _      []           = []+                                        genSteps curst (curv:nextvs) = setarg : dovis : genSteps nextst nextvs where+                                          inCon = conNmTVisitIn @nt curv+                                          outCon = conNmTVisitOut @nt curv+                                          pat    = @loc.addbang $ pp_parens $ pat0+                                          pat0   = outCon >#< ppSpaced (map (lhsname @lhs.options False) syns) >#< cont+                                          cont   | null nextvs = empty+                                                 | otherwise   = pp "sem"+                                          inhs = Set.toList $ Map.findWithDefault Set.empty curv @prods.visituses+                                          syns = Set.toList $ Map.findWithDefault Set.empty curv @prods.visitdefs+                                          arg = inCon >#< ppSpaced (map (lhsname @lhs.options True) inhs)+                                          setarg = "let" >#< @loc.addbangWrap (pp "arg" >|< curv) >#< "=" >#< arg+                                          ind    = case Map.findWithDefault ManyVis curst @nextVisits of+                                                   NoneVis  -> error "wrapper: initial state should have a next visit but it has none"+                                                   OneVis _ -> empty+                                                   ManyVis  -> @loc.k_type >|< "_v" >|< initv+                                          nextst = curst + 1 -- This is not correct, but works both for KW and AOAG+                                                             -- Should be lookup up based on visit+                                          convert = case Map.lookup curv @lhs.allVisitKinds of+                                                      Just kind -> case kind of+                                                         VisitPure _  -> text "return"+                                                         VisitMonadic -> empty+                                          dovis  = pat >#< "<-" >#< convert >#< pp_parens +                                            ("inv_" >|< @nt >|< "_s" >|< curst >#< "sem" >#< ind +                                            >#< "arg" >|< curv >#< extra)+                                    in unMonad >#< "("+                                       >-< indent 2 (+                                              "do" >#< ( @loc.addbang (pp "sem") >#< "<-" >#< "act"   -- run the per-node monadic code to get the initial state (of the root)+                                                       >-< vlist (genSteps @initial initvs)+                                                       >-< "return" >#< pp_parens (@loc.synname >#< ppSpaced @loc.synlist)+                                                       )+                                            )+                                       >-< ")" )+                                >-< if lateHigherOrderBinding @lhs.options+                                    then indent 2 ("where" >#< lhsname @lhs.options True idLateBindingAttr >#< "=" >#< lateBindingFieldNm @lhs.mainName)+                                    else empty+                 loc.wrapPragma = if parallelInvoke @lhs.options && not (monadicWrappers @lhs.options)+                                  then ppNoInline @loc.wrapname  -- required for the use of unsafePerformIO in case of the IO monad+                                  else if noInlinePragmas @lhs.options+                                       then empty+                                       else ppInlinable @loc.wrapname  -- ensure that the wrapper is exposed as inlinable++-------------------------------------------------------------------------------+--  Collection of NT / Production sem funs references+-------------------------------------------------------------------------------++ATTR ENonterminals ENonterminal EProductions EProduction [ | | semFunBndDefs, semFunBndTps USE {Seq.><} {Seq.empty} : {Seq PP_Doc} ]+SEM ENonterminal | ENonterminal+  lhs.semFunBndDefs = @loc.semFunBndDef Seq.<| @prods.semFunBndDefs+  lhs.semFunBndTps  = @loc.semFunBndTp Seq.<| @prods.semFunBndTps+  loc.semFunBndDef  = @loc.semFunBndNm >#< "=" >#< @loc.semname+  loc.semFunBndTp   = @loc.semFunBndNm >#< "::" >#< @loc.sem_tp+  loc.semFunBndNm   = lateSemNtLabel @nt++SEM EProduction | EProduction+  lhs.semFunBndDefs = Seq.singleton @loc.semFunBndDef+  lhs.semFunBndTps  = Seq.singleton @loc.semFunBndTp+  loc.semFunBndDef  = @loc.semFunBndNm >#< "=" >#< @loc.semname+  loc.semFunBndTp   = @loc.semFunBndNm >#< "::" >#< @loc.sem_tp+  loc.semFunBndNm   = lateSemConLabel @lhs.nt @con++-- Generate a dictionary that contains the semantics of all semantic functions+SEM ExecutionPlan | ExecutionPlan+  loc.wrappersExtra = if lateHigherOrderBinding @lhs.options+                      then @loc.lateSemBndDef+                      else empty+  loc.commonExtra   = if lateHigherOrderBinding @lhs.options+                      then @loc.lateSemBndTp+                      else empty+  loc.lateSemBndTp = "data" >#< lateBindingTypeNm @lhs.mainName >#< "=" >#< lateBindingTypeNm @lhs.mainName+                      >-< (indent 2 $ pp_block "{" "}" "," $ toList @nonts.semFunBndTps)+  loc.lateSemBndDef = ( if noInlinePragmas @lhs.options+                        then empty+                        else if helpInlining @lhs.options && Set.size @wrappers == 1+                             then ppInline $ lateBindingFieldNm @lhs.mainName  -- inline in the single wrapper+                             else ppNoInline $ lateBindingFieldNm @lhs.mainName+                      )+                      >-< lateBindingFieldNm @lhs.mainName >#< "::" >#< lateBindingTypeNm @lhs.mainName+                      >-< lateBindingFieldNm @lhs.mainName >#< "=" >#< lateBindingTypeNm @lhs.mainName+                      >-< (indent 2 $ pp_block "{" "}" "," $ toList @nonts.semFunBndDefs )++-------------------------------------------------------------------------------+--  Production semantic functions+-------------------------------------------------------------------------------+ATTR EProduction  [ | | sem_prod                   : {PP_Doc} ]+ATTR EProductions [ | | sem_prod USE {>-<} {empty} : {PP_Doc} ]++ATTR EProduction EProductions [ initial : {StateIdentifier}+                                allstates : {Set StateIdentifier} | | ]+SEM ENonterminal+  | ENonterminal prods.initial   = @initial+                 prods.allstates = @loc.allstates++ATTR EChild    [ | | argtps               : {  PP_Doc  }+                     argpats              : {  PP_Doc  } ]+ATTR EChildren [ | | argtps  USE {:} {[]} : { [PP_Doc] }+                     argpats USE {:} {[]} : { [PP_Doc] }  ]++SEM EChild+  | EChild lhs.argtps   = case @kind of+                            ChildSyntax     -> ppDefor @tp >#< "->"+                            ChildReplace tp -> ppDefor tp >#< "->"+                            _               -> empty  -- higher order attribute+           loc.argpats = case @kind of+                           ChildSyntax    -> @name >|< "_"                    -- no strictification of children semantics to allow infinite trees+                           ChildReplace _ -> @name >|< "_"+                           _              -> empty+  | ETerm  lhs.argtps  = (pp_parens $ show @tp) >#< "->"+           loc.argpats = @loc.addbang $ text $ fieldname @name   -- terminals may be strict (perhaps this should become an option)++{+ppDefor :: Type -> PP_Doc+ppDefor (NT nt args _) = "T_" >|< nt >#< ppSpaced (map pp_parens args)+ppDefor (Haskell s)    = text s+}++SEM EProduction+  | EProduction loc.t_type   = "T_" >|< @lhs.nt+                loc.t_params = ppSpaced @lhs.params+                loc.usedArgs = @children.usedArgs `Set.union` @visits.usedArgs `Set.union` @rules.usedArgs+                -- A bit ugly, but this code renames arguments and puts an underscore when the argument+                -- is never used. This avoids compiler warnings of unused variables.+                loc.args     = map (\x -> let (name,arg) = case show x of +                                                       ""       -> ("", empty)+                                                       '!':name -> ("arg_" ++ name, "!arg_" >|< name)+                                                       name     -> ("arg_" ++ name, "arg_"  >|< name)+                                          in  if null name || name `Set.member` @loc.usedArgs+                                              then arg+                                              else text "_") @children.argpats+                loc.semname  = "sem_" ++ show @lhs.nt ++ "_" ++ show @con+                loc.sem_tp   = @loc.quantPP2 >#< @loc.classPP2 >#< ppSpaced @children.argtps >#< @loc.t_type >#< @loc.t_params+                loc.classPP2 = ppClasses (classCtxsToDocs @lhs.classCtxs ++ classConstrsToDocs @constraints)+                loc.quantPP2 = ppQuants (@lhs.params ++ @params)+                loc.sem_prod = @loc.semInlinePragma+                               >-< @loc.semname >#< "::" >#< @loc.sem_tp+                               >-< @loc.mkSemBody (@loc.semname >#< ppSpaced @loc.args >#< "=" >#< @loc.scc >#< @loc.t_type)+                                                  @loc.mbInitializer @loc.outerlet ("return" >#< "st" >|< @lhs.initial)+                loc.mkSemBody = \prefix mbInit outerlet ret ->+                                  case mbInit of+                                    Nothing -> prefix >#< pp_parens ret >#< "where"+                                               >-< indent 3 outerlet  -- code for states and visits+                                    Just m  -> prefix >#< "(" >#< "do"+                                               >-< indent 1 (+                                                     m+                                                     >-< "let"+                                                     >-< indent 2 outerlet -- code for the states and visits+                                                     >-< ret )+                                               >-< indent 1 ")"++                loc.mbInitializer   = --some monadic actions, performed upon attaching a child, can+                                      -- be specified here. The resulting bindings of these actions are+                                      -- in scope of the rules of the production+                                      if parallelInvoke @lhs.options+                                      then (Nothing :: Maybe PP_Doc)  -- perhaps do some per-node registation, etc. For now: nothing+                                      else Nothing  -- nothing special here+                loc.scc             = if genCostCentres @lhs.options+                                      then ppCostCentre @loc.semname+                                      else empty+                loc.semInlinePragma = if noInlinePragmas @lhs.options+                                      then empty+                                      else ppNoInline @loc.semname  -- prevent the semantic functions of constructors to be inlined (e.g. in the nt sem-funs)+                loc.outerlet = vlist @loc.statefns >-< @rules.sem_rules+                loc.statefns = map @loc.genstfn $ Set.toList @lhs.allstates+                loc.genstfn  = \st -> let nextVisitInfo = Map.findWithDefault ManyVis st @lhs.nextVisits+                                          prevVisitInfo = Map.findWithDefault ManyVis st @lhs.prevVisits+                                          stNm = "st" >|< st+                                          lhs  = pragma >-< bang stNm >#< "=" >#<+                                                 ( -- generating a lambda for the same reasons as generating+                                                   -- a lambda for rules: to ensure that overloading is+                                                   -- resolved for all visit functions and rules together.+                                                   if st == @lhs.initial+                                                   then empty+                                                   else "\\" >#< @loc.stargs st >#< "->"+                                                 )++                                          pragma = if noInlinePragmas @lhs.options+                                                   then empty+                                                   else if helpInlining @lhs.options+                                                        then case prevVisitInfo of+                                                               ManyVis  -> ppNoInline stNm+                                                               OneVis _ -> if aggressiveInlinePragmas @lhs.options+                                                                           then ppInline stNm+                                                                           else ppInlinable stNm+                                                               NoneVis  -> if st /= @lhs.initial+                                                                           then error ("State " ++ show st ++ " is not reachable from the initial state.")+                                                                           else if aggressiveInlinePragmas @lhs.options+                                                                                then ppInline stNm    -- first state can be inlined+                                                                                else ppInlinable stNm+                                                        else ppNoInline stNm+                                          cCon = "C_" >|< @lhs.nt >|< "_s" >|< st+                                          bang | st == @lhs.initial = @loc.addbang  -- initial state is not parameterized+                                               | otherwise          = id++                                          -- note about the initial state: the initial state should be the only+                                          -- state-binding that is not a function. It is non-recursive and not needed+                                          -- anywhere except delivered as initial result. This binding therefore does+                                          -- not end up needlessly in any closure.+                                      in case nextVisitInfo of+                                           NoneVis    -> -- the (empty) closure of a (non-initial) end state is not referenced+                                                         -- thus generating it is not needed (and omitting it may catch some small mistakes).+                                                         if st == @lhs.initial+                                                         then lhs >#< cCon  -- empty state+                                                         else empty -- no state generated+                                           OneVis vId -> mklet lhs (@loc.stvs st False) (cCon >#< "v" >|< vId)+                                           ManyVis    -> mklet lhs (@loc.stks st >-< @loc.stvs st True) (cCon >#< "k" >|< st)+                loc.stargs   = \st -> let attrs = maybe Map.empty id $ Map.lookup st @visits.intramap+                                      in ppSpaced [ let match | str `Set.member` @loc.lazyIntras = pp str+                                                              | otherwise                        = @loc.addbang (pp str)+                                                    in case mbAttr of+                                                         Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) ->+                                                           case Map.lookup nm @loc.localAttrTypes of+                                                             Just tp -> pp_parens (pp_parens match >#< "::" >#< ppTp tp)+                                                             Nothing -> match+                                                         Just attr | not (noPerStateTypeSigs @lhs.options) ->+                                                           case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @loc.childTypes of+                                                             Just tpDoc -> pp_parens (pp_parens match >#< "::" >#< tpDoc)+                                                             Nothing    -> match+                                                         _ -> match+                                                 | (str,mbAttr) <- Map.assocs attrs+                                                 ] >#< dummyPat @lhs.options (Map.null attrs)++                loc.stks     = \st -> if null (@loc.stvisits st)+                                      then empty+                                      else ( if not (noInlinePragmas @lhs.options) && helpInlining @lhs.options+                                             then ppNoInline ("k" >|< st)+                                             else empty+                                           )+                                           >-< "k" >|< st >#< "::" >#< "K_" >|< @lhs.nt >|< "_s" >|< st >#< @loc.t_params >#< "t" >#< "->" >#< "t"+                                           >-< vlist (map (\(v,f,t) -> "k" >|< st >#< "K_" >|< @lhs.nt >|< "_v" >|< v >#< "="+                                                                  >#< "v" >|< v) $ @loc.stvisits st)+                loc.stvisits = \st -> filter (\(v,f,t) -> f == st) @visits.allvisits+                loc.stvs     = \st inlinePragma -> vlist [ppf inlinePragma | (f,ppf) <- @visits.sem_visit, f == st]+                visits.mrules = @rules.mrules++{+mklet :: (PP a, PP b, PP c) => a -> b -> c -> PP_Doc+mklet prefix defs body =+  prefix >#< "let"+  >-< indent 3 defs+  >-< indent 2 "in" >#< body+}++-------------------------------------------------------------------------------+--  Visit semantic functions+-------------------------------------------------------------------------------+ATTR Visit  [ | | sem_visit              : {  (StateIdentifier,Bool -> PP_Doc)  } ]+ATTR Visits [ | | sem_visit USE {:} {[]} : { [(StateIdentifier,Bool -> PP_Doc)] } ]++SEM Visit+  | Visit lhs.sem_visit = ( @from+                          , \addInlinePragma ->+                               ( if noInlinePragmas @lhs.options+                                 then empty+                                 else if addInlinePragma && aggressiveInlinePragmas @lhs.options+                                      then ppInline @loc.vname+                                      else if helpInlining @lhs.options+                                           then ppNoInline @loc.vname+                                           else empty+                               )+                               >-< "v" >|< @ident >#< "::" >#< @loc.nameT_visit >#< @loc.t_params++                                      -- generate a lambda here as well instead of a function definition+                               >-< "v" >|< @ident >#< "=" >#< "\\" >#< (@loc.addbang $ pp_parens (@loc.nameTIn_visit >#< @loc.inhpats))+                               >#< ( if dummyTokenVisit @lhs.options+                                     then pp $ dummyPat @lhs.options True  -- extra (but unused) argument+                                     else empty+                                   )+                               >#< "->"+                               >#< ( if genCostCentres @lhs.options+                                     then ppCostCentre (@loc.vname >|< "_" >|< @lhs.nt >|< "_" >|< @lhs.con)+                                     else empty+                                   ) >#< "(" >#< @loc.stepsInitial+                               >-< indent 3 (@steps.sem_steps >-< @loc.stepsClosing >#< ")")+                          )+          loc.stepsInitial = case @kind of+                               VisitPure False -> text "let"+                               VisitPure True  -> empty+                               VisitMonadic    -> text "do"+          loc.stepsClosing  = let decls =  @loc.nextStBuild+                                           >-<  @loc.addbang (pp resultValName) >#< "=" >#< @loc.resultval+                              in case @kind of+                                   VisitPure False -> decls+                                                      >-< "in" >#< resultValName+                                   VisitPure True  -> "let" >#< decls+                                                      >-< indent 1 ("in" >#< resultValName)+                                   VisitMonadic    -> "let" >#< decls+                                                      >-< "return" >#< resultValName+          loc.vname     = "v" >|< @ident+          loc.inhpats   = ppSpaced $ map (\arg -> {-@loc.addbang $-} pp $ attrname @lhs.options True _LHS arg) $ Set.toList @inh+          loc.inhargs   = \chn -> ppSpaced $ map (attrname @lhs.options False chn) $ Set.toList @inh+          loc.synargs   = ppSpaced $ map (\arg -> attrname @lhs.options False _LHS arg) $ Set.toList @syn+          loc.nextargsMp = maybe Map.empty id $ Map.lookup @to @lhs.allintramap+          loc.nextargs  = ppSpaced $ Map.keys $ @loc.nextargsMp+          loc.nextst    = "st" >|< @to >#< @loc.nextargs >#< dummyArg @lhs.options (Map.null @loc.nextargsMp)+          loc.resultval = @loc.nameTOut_visit >#< @loc.synargs >#< @loc.nextStRef+          (loc.nextStBuild, loc.nextStRef)+            = case @loc.nextVisitInfo of+                NoneVis  -> (empty, empty)+                _        -> (@loc.addbang (pp nextStName) >#< "=" >#< @loc.nextst, pp nextStName)++{+resultValName :: String+resultValName = "__result_"++nextStName :: String+nextStName = "__st_"+}++-- Propagate the visit kind to the steps+ATTR VisitStep VisitSteps [ kind : VisitKind | | ]+SEM Visit | Visit  steps.kind = @kind++-- the steps in this group should be executed in a pure fashion+SEM VisitStep | PureGroup+  steps.kind = VisitPure @ordered++ATTR Visits Visit VisitStep VisitSteps [  mrules : {Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)} | | ]+ATTR VisitStep VisitSteps [ | | sem_steps USE {>-<} {empty} : {PP_Doc} ]+SEM VisitStep+  | Sem        loc.ruleItf = Map.findWithDefault (error $ "Rule "  ++ show @name  ++ " not found") @name @lhs.mrules+               (lhs.errors, loc.sem_steps) = case @loc.ruleItf @lhs.kind @lhs.fmtMode of+                                               Left e     -> (Seq.singleton e, empty)+                                               Right stmt -> (Seq.empty, stmt)+  | ChildIntro loc.attachItf = Map.findWithDefault (error $ "Child " ++ show @child ++ " not found") @child @lhs.childintros+               (lhs.errors,lhs.sem_steps,lhs.defs,lhs.uses)+                 = case @loc.attachItf @lhs.kind @lhs.fmtMode of+                     Left e                   -> (Seq.singleton e, empty, Set.empty, Map.empty)+                     Right (code, defs, uses) -> (Seq.empty, code, defs, uses)+  | ChildVisit loc.visitItf = Map.findWithDefault (error $ "Visit " ++ show @visit ++ " not found") @visit @lhs.allchildvisit+               (lhs.errors, loc.patPP, loc.exprPP) = case @loc.visitItf @child @lhs.kind of+                                                       Left e           -> (Seq.singleton e, empty, empty)+                                                       Right (pat,expr) -> (Seq.empty, pat, expr)++               loc.useParallel = @lhs.useParallel && not @lhs.isLast+               lhs.sem_steps = if @loc.useParallel  -- assumes to be in a monadic do-expression+                               then @loc.addbang ("sync_" >|< @lhs.index) >#< "<- newEmptyMVar"+                                    >-< "forkIO" >#< pp_parens (@loc.convToMonad >#< pp_parens @loc.exprPP >#< ">>= \\" >#< @loc.addbang (pp parResultName) >#< " -> putMVar sync_" >|< @lhs.index >#< parResultName)  -- parResultName is guaranteed to be evaluated+                               else let decl = case @lhs.kind of+                                                 VisitPure _  -> @loc.patPP >#< "=" >#< @loc.exprPP+                                                 VisitMonadic -> @loc.patPP >#< "<-" >#< @loc.exprPP+                                    in fmtDecl False @lhs.fmtMode decl+               loc.convToMonad = case @loc.callKind of+                                   VisitPure _  -> text "return"+                                   VisitMonadic -> empty+               loc.callKind  = Map.findWithDefault (error "visit kind should be in the map") @visit @lhs.allVisitKinds+  | Sim        lhs.sem_steps = @steps.sem_steps >-< @steps.sync_steps+  | PureGroup  lhs.sem_steps = case @lhs.fmtMode of+                                 FormatDo -> "let" >#< @steps.sem_steps  -- formatted as a let-block (not a line-let)+                                 _        -> @steps.sem_steps++ATTR VisitSteps VisitStep [ | | sync_steps USE {>-<} {empty} : {PP_Doc} ]+SEM VisitStep | ChildVisit+  lhs.sync_steps = if @loc.useParallel+                   then @loc.patPP >#< "<-" >#< "takeMVar sync_" >|< @lhs.index+                   else empty++-- The fmtMode indicates in what kind of expression (do/let/line-lets) we are printing+-- declarations, because that determines how we need to wrap declarations+-- Invariant: @lhs.kind == VisitMonadic ---> @lhs.fmtMode == FormatDo+ATTR VisitSteps VisitStep [ fmtMode : FormatMode | | ]+SEM Visit | Visit+  steps.fmtMode = case @kind of+                    VisitPure False -> FormatLetDecl+                    VisitPure True  -> FormatLetLine+                    VisitMonadic    -> FormatDo++SEM VisitStep | PureGroup+  steps.fmtMode = case @lhs.fmtMode of+                    FormatDo      -> FormatLetDecl+                    mode          -> mode++{+parResultName :: String+parResultName = "__outcome_"++fmtDecl :: PP a => Bool -> FormatMode -> a -> PP_Doc+fmtDecl declPure fmt decl = case fmt of+  FormatLetDecl -> pp decl+  FormatLetLine -> "let" >#< decl >#< "in"+  FormatDo | declPure  -> "let" >#< decl+           | otherwise -> pp decl+}++--+-- Some properties of VisitStep(s)+--++-- Used arguments+ATTR VisitSteps VisitStep Visit Visits EChild EChildren ERule ERules [ | | usedArgs USE {`Set.union`} {Set.empty} : {Set String} ]+SEM ERule+  | ERule +usedArgs = Set.union $ Map.keysSet $ Map.mapKeys (\a -> "arg_" ++ a) $ Map.filter isNothing @rhs.attrs++SEM EChild+  | EChild +usedArgs = \s -> case @kind of+                             ChildSyntax -> Set.insert ("arg_" ++ show @name ++ "_") s+                             _           -> s+++-- Number of steps in a 'Sim' block+ATTR VisitSteps [ | | size : Int ]+SEM VisitSteps+  | Nil  lhs.size = 0+  | Cons lhs.size = 1 + @tl.size++-- Number the steps in a 'Sim' block+ATTR VisitSteps VisitStep [ | index : Int | ]+SEM VisitSteps | Cons+  hd.index  = @lhs.index  -- copy rule+  tl.index  = 1 + @lhs.index+  lhs.index = @tl.index   -- copy rule+SEM Visit | Visit    steps.index = 0+SEM VisitStep | Sim  steps.index = 0+                     lhs.index   = @lhs.index  -- needed for if we ever allow nested Sims++-- Biggest number of steps in previous blocks that used parallel invocation+-- This number - 1 (minimum 0) is the number of references for parallel invocation created+ATTR VisitSteps VisitStep [ | prevMaxSimRefs : Int | ]+SEM Visit | Visit    steps.prevMaxSimRefs = 0+SEM VisitStep | Sim+  lhs.prevMaxSimRefs = if @loc.useParallel+                       then @lhs.prevMaxSimRefs `max` (@steps.index - 1)  -- possibly new references made+                       else @lhs.prevMaxSimRefs                           -- no references created++-- Is this the last step?+ATTR VisitSteps VisitStep [ | | isLast : Bool ]+ATTR VisitStep [ isLast : Bool | | ]+SEM VisitSteps+  | Nil   lhs.isLast = True+  | Cons  lhs.isLast = False+          hd.isLast  = @tl.isLast++-- Use parallel invocation: only when option enabled and there is more than one visit to a child+SEM VisitSteps VisitStep [ useParallel : Bool | | ]+SEM Visit | Visit    steps.useParallel = False+SEM VisitStep | Sim  loc.useParallel = parallelInvoke @lhs.options && @steps.size > 1 && @loc.isMonadic+                     loc.isMonadic   = case @lhs.kind of+                                         VisitMonadic -> True+                                         _            -> False+++-- Child introduction+ATTR EChild EChildren [ | | childintros USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} ]++ATTR Visits Visit+     VisitSteps VisitStep [ childintros : {Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} | | ]++SEM EProduction+  | EProduction visits.childintros = @children.childintros++SEM EChild+  | ETerm  lhs.childintros = Map.singleton @name (\_ _ -> Right (empty, Set.empty, Map.empty))+  | EChild lhs.childintros = Map.singleton @name @loc.introcode+           loc.isDefor     = case @tp of+                               NT _ _ defor -> defor+                               _            -> False+           loc.valcode     = case @kind of+                               ChildSyntax -> "arg_" >|< @name >|< "_"+                               ChildAttr   -> -- decide if we need to invoke the sem-function under the hood+                                              let prefix | not @loc.isDefor = if lateHigherOrderBinding @lhs.options -- && sepsemmods @lhs.options  -- when sepsemmods is not enabled, the indirection can be optimized away+                                                                              then lateSemNtLabel @loc.nt >#< lhsname @lhs.options True idLateBindingAttr+                                                                              else "sem_" >|< @loc.nt+                                                         | otherwise        = empty -- no need to intro a terminal+                                              in pp_parens (prefix >#< instname @name)+                               ChildReplace _ -> -- the higher-order attribute is actually a function that transforms+                                                 -- the semantics of the child (always deforested)+                                                 pp_parens (instname @name >#< @name >|< "_")+           loc.aroundcode  = if @hasAround+                             then locname @lhs.options @name >|< "_around"+                             else empty+           loc.introcode   = \kind fmtMode ->+                                      let pat       = text $ stname @name @loc.initSt+                                          patStrict = @loc.addbang pat+                                          attach    = "attach_T_" >|< @loc.nt >#< pp_parens (@loc.aroundcode >#< @loc.valcode)+                                          runAttach = unMon @lhs.options >#< pp_parens attach+                                          decl      = case kind of+                                                        VisitPure False -> pat >#< "=" >#< runAttach+                                                        VisitPure True  -> patStrict >#< "=" >#< runAttach+                                                        VisitMonadic    -> patStrict >#< "<-" >#< attach+                                      in if compatibleAttach kind @loc.nt @lhs.options+                                         then Right ( fmtDecl False fmtMode decl+                                                    , Set.singleton (stname @name @loc.initSt)  -- variables defined by the child intro+                                                    , case @kind of  -- variables used by the child introduction+                                                        ChildAttr   -> Map.insert (instname @name) Nothing $  -- the sem attr+                                                                         ( if @loc.isDefor || not (lateHigherOrderBinding @lhs.options)+                                                                           then id   -- the sem dictionary attr is not used+                                                                           else Map.insert (lhsname @lhs.options True idLateBindingAttr) (Just $ AttrInh _LHS idLateBindingAttr)+                                                                         ) $+                                                                         ( if @hasAround+                                                                           then Map.insert (locname @lhs.options (@name) ++ "_around") Nothing+                                                                           else id+                                                                         ) $ Map.empty+                                                        ChildReplace _ -> Map.singleton (instname @name) Nothing   -- uses the transformation function+                                                        ChildSyntax    -> Map.empty+                                                    )+                                         else Left $ IncompatibleAttachKind @name kind+           loc.nt       = extractNonterminal @tp++{+stname :: Identifier -> Int -> String+stname child st = "_" ++ getName child ++ "X" ++ show st++-- should actually return some conversion info+compatibleAttach :: VisitKind -> NontermIdent -> Options -> Bool+compatibleAttach _ _ _ = True++unMon :: Options -> PP_Doc+unMon options+  | parallelInvoke options = text "System.IO.Unsafe.unsafePerformIO"    -- IO monad+  | otherwise              = text "Control.Monad.Identity.runIdentity"  -- identity monad+}++-- rules+ATTR ERules ERule [ | | sem_rules USE {>-<} {empty} : {PP_Doc}+                        mrules USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)} ]++SEM ERule | ERule+     lhs.sem_rules    = if @loc.used == 0+                        then empty+                        else @loc.rulePragma >-< @loc.rulecode+     loc.rulecode     = ( if @loc.genpragma+                          then @loc.pragma  -- this additional pragma *may* help to give some AG source location in the presence of+                                            -- type errors in the rule. It will definitely not be precise, and may take some additional+                                            -- source space, but let's see if it's worth it in practice.+                          else empty+                        )+                        >-< @loc.lambda >#< @loc.scc+                        >-< indent ((column @rhs.pos - 2) `max` 2)+                              ( if @loc.genpragma+                                then @loc.pragma >-< @rhs.semfunc >-< @loc.endpragma+                                else @rhs.semfunc+                              )+      loc.rulePragma   = ( let reallyInlineStr   = "INLINE"+                               reallyNoInlineStr = "NOINLINE"+                           in  if noInlinePragmas @lhs.options+                               then empty+                               else if @loc.used == 1+                                    then ppPragmaBinding reallyInlineStr @name  -- always inline if used exactly once+                                    else if helpInlining @lhs.options+                                         then if not @explicit && @loc.used <= reallyOftenUsedThreshold+                                              then ppPragmaBinding "INLINE[1]" @name  -- inline if copy rule+                                              else if @loc.used > ruleInlineThresholdSoft && @explicit  -- noinline if it passes the threshold and is not a copy rule+                                                   then if @loc.used > ruleInlineThresholdHard+                                                        then ppPragmaBinding reallyNoInlineStr @name    -- used too often: force ghc not to inline it+                                                        else if aggressiveInlinePragmas @lhs.options+                                                             then ppPragmaBinding "NOINLINE[2]" @name -- allow inlining but only late in the process+                                                             else ppNoInline @name+                                                   else if aggressiveInlinePragmas @lhs.options+                                                        then ppPragmaBinding "NOINLINE[1]" @name  -- otherwise, let GHC decide (but do other inlining first)+                                                        else ppNoInline @name+                                         else if not @explicit || @loc.used <= ruleInlineThresholdSoft+                                              then ppPragmaBinding "NOINLINE[1]" @name  -- otherwise, let GHC decide (but do other inlining first)+                                              else ppNoInline @name+                             )+      loc.scc          = if genCostCentres @lhs.options && @explicit && @pure && not (noPerRuleCostCentres @lhs.options)+                         then ppCostCentre (@name >|< "_" >|< line @rhs.pos >|< "_" >|< @lhs.nt >|< "_" >|< @lhs.con)+                         else empty+      loc.pragma       = "{-# LINE" >#< show (line @rhs.pos) >#< show (file @rhs.pos) >#< "#-}"+      loc.endpragma    = ppWithLineNr (\ln -> "{-# LINE " ++ show (ln+1) ++ " " ++ show @lhs.mainFile ++ "#-}")+      loc.genpragma    = genLinePragmas @lhs.options && @explicit && @loc.haspos+      loc.haspos       = line @rhs.pos > 0 && column @rhs.pos >= 0 && not (null (file @rhs.pos))++        -- we generate a simple pattern binding because of overloading-resolving during the type inference process.+        -- The types of the rules are not generalized (nor do we want that - rules are used in a single typing-context).+        -- If overloading is resolved separately, it may not be clear which dictionaries to use. For that all rules have+        -- to be considered together, which is done when we use simple pattern bindings with a lambda expression instead+        -- of a function definition.+        -- Note: we also ensure that all rules are lambda expressions, so that they are not made part of any closures+        -- but are lambda-lifted instead.+      loc.lambda       = @name >#< "=" >#< "\\" >#< @loc.argPats >#< dummyPat @lhs.options (Map.null @rhs.attrs) >#< "->"++      loc.argPats      = ppSpaced [ let match | str `Set.member` @lhs.lazyIntras = pp str+                                              | otherwise                        = @loc.addbang1 (pp str)+                                    in case mbAttr of+                                         Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) ->+                                           case Map.lookup nm @lhs.localAttrTypes of+                                             Just tp -> pp_parens (pp_parens match >#< "::" >#< ppTp tp)+                                             Nothing -> match+                                         Just attr | not (noPerRuleTypeSigs @lhs.options) ->+                                           case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @lhs.childTypes of+                                             Just tpDoc -> pp_parens (pp_parens match >#< "::" >#< tpDoc)+                                             Nothing    -> match+                                         _ -> match+                                  | (str,mbAttr) <- Map.assocs @rhs.attrs+                                  ]+      loc.argExprs     = ppSpaced [ case mbAttr of+                                       Nothing -> "arg_" >|< str+                                       _       -> text str+                                  | (str,mbAttr) <- Map.assocs @rhs.attrs+                                  ]+      loc.stepcode     = \kind fmtMode -> if kind `compatibleRule` @pure+                                          then Right $ let oper | @pure     = "="+                                                                | otherwise = "<-"+                                                           decl = @pattern.sem_lhs >#< oper >#< @name >#< @loc.argExprs >#< dummyArg @lhs.options (Map.null @rhs.attrs)+                                                           tp   = if @pure && not (noPerRuleTypeSigs @lhs.options)+                                                                  then @pattern.attrTypes+                                                                  else empty+                                                       in fmtDecl @pure fmtMode (tp >-< decl)+                                          else Left $ IncompatibleRuleKind @name kind++      lhs.mrules       = Map.singleton @name @loc.stepcode++ATTR Expression [ | | tks : {[HsToken]} ]+SEM Expression+  | Expression lhs.tks = @tks++{+dummyPat :: Options -> Bool -> PP_Doc+dummyPat opts noArgs+  | not noArgs && tupleAsDummyToken opts = empty  -- no unnecessary tuples+  | tupleAsDummyToken opts = if strictDummyToken opts+                             then text "()"+                             else text "(_ :: ())"+  | otherwise              = let match | strictDummyToken opts = "!_"+                                       | otherwise             = "_"+                             in pp_parens (match >#< "::" >#< dummyType opts noArgs)+  where match | strictDummyToken opts = "(!_)"+              | otherwise             = "_"++dummyArg :: Options -> Bool -> PP_Doc+dummyArg opts noArgs+  | not noArgs && tupleAsDummyToken opts = empty    -- no unnecessary tuples+  | tupleAsDummyToken opts = text "()"+  | otherwise              = text "GHC.Prim.realWorld#"++dummyType :: Options -> Bool -> PP_Doc+dummyType opts noArgs+  | not noArgs && tupleAsDummyToken opts = empty     -- no unnecessary tuples+  | tupleAsDummyToken opts = text "()"+  | otherwise              = text "(GHC.Prim.State# GHC.Prim.RealWorld)"+}++{+-- rules are "deinlined" to prevent needless code duplication.+-- if there is only a bit of duplication, we allow ghc to decide if it is worth it.+-- if the duplication crosses this threshold, however, we tell ghc definitely not to inline it.+ruleInlineThresholdSoft :: Int+ruleInlineThresholdSoft = 3++ruleInlineThresholdHard :: Int+ruleInlineThresholdHard = 5++reallyOftenUsedThreshold :: Int+reallyOftenUsedThreshold = 12+}++ATTR Expression [ | | pos : {Pos} ]+SEM Expression | Expression lhs.pos = @pos++-- pattern and expression semantics+ATTR Pattern  [ | | sem_lhs              : { PP_Doc } ]+ATTR Patterns [ | | sem_lhs USE {:} {[]} : {[PP_Doc]} ]+ATTR Pattern Patterns [ | | ]++SEM Pattern+  | Alias       loc.varPat    = text $ attrname @lhs.options False @field @attr+                loc.patExpr   = if @pat.isUnderscore+                                then @loc.varPat+                                else @loc.varPat >|< "@" >|< @pat.sem_lhs+                lhs.sem_lhs   = @loc.addbang1 @loc.patExpr+  | Product     lhs.sem_lhs   = @loc.addbang1 $ pp_block "(" ")" "," @pats.sem_lhs+  | Constr      lhs.sem_lhs   = @loc.addbang1 $ pp_parens $ @name >#< hv_sp @pats.sem_lhs+  | Underscore  lhs.sem_lhs   = text "_"+  | Irrefutable lhs.sem_lhs   = text "~" >|< pp_parens @pat.sem_lhs++-- Check if a pattern is just an underscore+ATTR Pattern [ | | isUnderscore:{Bool}]+SEM Pattern+ | Constr      lhs.isUnderscore = False+ | Product     lhs.isUnderscore = False+ | Alias       lhs.isUnderscore = False+ | Underscore  lhs.isUnderscore = True++-- Collect the attributes defined by a pattern+ATTR Pattern Patterns  [ | | attrs USE {`Set.union`} {Set.empty} : {Set String} ]+SEM Pattern | Alias+  lhs.attrs     = Set.insert (attrname @lhs.options False @field @attr) @pat.attrs++-- All attribute types of this pattern+ATTR Pattern Patterns  [ | | attrTypes USE {>-<} {empty} : {PP_Doc} ]+SEM Pattern | Alias+  loc.mbTp      = if @field == _LHS+                  then Map.lookup @attr @lhs.synmap+                  else if @field == _LOC+                       then Map.lookup @attr @lhs.localAttrTypes+                       else Nothing+  lhs.attrTypes = maybe empty (\tp -> (attrname @lhs.options False @field @attr) >#< "::" >#< ppTp tp) @loc.mbTp+                  >-< @pat.attrTypes++-- Collect the attributes used by the right-hand side+ATTR HsToken Expression [ | | attrs USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ]+SEM HsToken+  | AGLocal   lhs.attrs   = Map.singleton (fieldname @var) Nothing+  | AGField   loc.mbAttr  = if @field == _INST || @field == _FIELD || @field == _INST'+                            then Nothing  -- should not be used in the first place+                            else Just $ mkNonLocalAttr (@field == _LHS) @field @attr+              lhs.attrs   = Map.singleton (attrname @lhs.options True @field @attr) @loc.mbAttr++{+data NonLocalAttr+  = AttrInh Identifier Identifier+  | AttrSyn Identifier Identifier deriving Show++mkNonLocalAttr :: Bool -> Identifier -> Identifier -> NonLocalAttr+mkNonLocalAttr True  = AttrInh  -- True: inherited attr+mkNonLocalAttr False = AttrSyn++lookupAttrType :: NonLocalAttr -> Map Identifier Attributes -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc+lookupAttrType (AttrInh child name) inhs _ = lookupType child name inhs+lookupAttrType (AttrSyn child name) _ syns = lookupType child name syns++-- Note: if the child takes type parameters, the type of an attribute of this child may refer to these parameters. This means that+-- the actual type of the attribute needs to have its type parameters substituted with the actual type argument of the child.+-- However, for now we simply decide to return Nothing in this case, which skips the type annotation.+lookupType :: Identifier -> Identifier -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc+lookupType child name attrMp childMp+  | noParameters childTp = Just ppDoc+  | otherwise            = Nothing+  where+    attrTp     = Map.findWithDefault (error "lookupType: the attribute is not in the attrs of the child") name childAttrs+    childAttrs = Map.findWithDefault (error "lookupType: the attributes of the nonterm are not in the map") nonterm attrMp+    nonterm    = extractNonterminal childTp+    childTp    = Map.findWithDefault (error ("lookupType: the child " ++ show child ++ "is not in the appropriate map")) child childMp+    ppDoc      = ppTp attrTp++noParameters :: Type -> Bool+noParameters (Haskell _)   = True+noParameters (NT _ args _) = null args+}++ATTR Expression [ | | semfunc : {PP_Doc} ]++SEM Expression+  | Expression lhs.attrs   = Map.unions $ map (\tok -> attrs_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks+               lhs.semfunc = vlist $ showTokens $ map (\tok -> tok_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks+               loc.inhhstoken = Inh_HsToken @lhs.options++-- child visit map+ATTR Visit+     Visits+     EProduction+     EProductions+     ENonterminal+     ENonterminals [ allchildvisit : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))}+                     | | childvisit USE {`Map.union`} {Map.empty} : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} ]++ATTR VisitSteps VisitStep [ allchildvisit : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} | | ]++SEM ExecutionPlan+  | ExecutionPlan nonts.allchildvisit = @nonts.childvisit++SEM Visit+  | Visit+     loc.prevVisitInfo = Map.findWithDefault ManyVis @from @lhs.nextVisits+     lhs.childvisit = Map.singleton @ident @loc.invokecode+     loc.invokecode = \chn kind ->   -- "chn" is the name of the child at the place of invocation, and "kind" the kind of the calling visit+                        if kind `compatibleKind` @kind+                        then Right $+                          let pat | isLazyKind @kind = pat0+                                  | otherwise        = @loc.addbang pat0+                              pat0  = pp_parens pat1+                              pat1  = @loc.nameTOut_visit >#< (ppSpaced $ map (attrname @lhs.options True chn) $ Set.toList @syn)+                                                          >#< cont+                              cont  = case @loc.nextVisitInfo of+                                        NoneVis  -> empty+                                        _        -> ch1+                              ch0   = text $ stname chn @from+                              ch1   = text $ stname chn @to+                              expr  = case (kind, @kind) of+                                        (VisitPure _,  VisitPure _)  -> expr0+                                        (VisitPure _,  VisitMonadic) -> unMon @lhs.options >#< expr0+                                        (VisitMonadic, VisitPure _)  -> "return" >#< expr0+                                        (VisitMonadic, VisitMonadic) -> expr0+                              expr0 = case @loc.prevVisitInfo of+                                        NoneVis  -> error "error: invocation of a visit from a state that has no next visits"+                                        OneVis _ -> "inv_" >|< @lhs.nt >|< "_s" >|< @from >#< ch0 >#< args+                                        ManyVis  -> "inv_" >|< @lhs.nt >|< "_s" >|< @from >#< ch0+                                                    >#< "K_" >|< @lhs.nt >|< "_v" >|< @ident >#< args+                              args  = pp_parens args0 >#< args1+                              args0 = @loc.nameTIn_visit >#< @loc.inhargs chn+                              args1 | dummyTokenVisit @lhs.options = pp $ dummyArg @lhs.options True+                                    | otherwise                    = empty+                          in (pat, expr)  -- pretty print of the pattern and the expression part+                        else Left $ IncompatibleVisitKind chn @ident kind @kind++{+-- a `compatibleKind` b  means: can kind b be invoked from a+compatibleKind :: VisitKind -> VisitKind -> Bool+compatibleKind _              _             = True++compatibleRule :: VisitKind -> Bool -> Bool+compatibleRule (VisitPure _) False = False+compatibleRule _             _     = True+}++-------------------------------------------------------------------------------+--  Properties of rules+-------------------------------------------------------------------------------++-- Construct an environment that counts how often certain rules are used+ATTR Visits Visit VisitSteps VisitStep [ | | ruleUsage USE {`unionWithSum`} {Map.empty} : {Map Identifier Int} ]+ATTR ERules ERule [ usageInfo : {Map Identifier Int} | | ]++SEM EProduction | EProduction  rules.usageInfo = @visits.ruleUsage+SEM VisitStep | Sem            lhs.ruleUsage = Map.singleton @name 1+SEM ERule | ERule              loc.used      = Map.findWithDefault 0 @name @lhs.usageInfo++{+unionWithSum = Map.unionWith (+)+}++-- Collect in what visit-kinds a rule is used+ATTR Visits Visit VisitSteps VisitStep [ | | ruleKinds USE {`unionWithMappend`} {Map.empty} : {Map Identifier (Set VisitKind)} ]+SEM VisitStep | Sem+  lhs.ruleKinds = Map.singleton @name (Set.singleton @lhs.kind)++ATTR ERules ERule [ ruleKinds : {Map Identifier (Set VisitKind)} | | ]+SEM EProduction | EProduction+  rules.ruleKinds = @visits.ruleKinds++SEM ERule | ERule+  loc.kinds = Map.findWithDefault Set.empty @name @lhs.ruleKinds+  loc.anyLazyKind = Set.fold (\k r -> isLazyKind k || r) False @loc.kinds++ATTR Pattern Patterns [ anyLazyKind : Bool | | ]+++-------------------------------------------------------------------------------+--  Intra attributes+-------------------------------------------------------------------------------+{+uwSetUnion :: (Ord a, Ord b) => Map a (Set b) -> Map a (Set b) -> Map a (Set b)+uwSetUnion = Map.unionWith Set.union++uwMapUnion :: (Ord a, Ord b) => Map a (Map b c) -> Map a (Map b c) -> Map a (Map b c)+uwMapUnion = Map.unionWith Map.union+}+ATTR Visit Visits [ allintramap : {Map StateIdentifier (Map String (Maybe NonLocalAttr))}+                    | | intramap USE {`uwMapUnion`} {Map.empty} : {Map StateIdentifier (Map String (Maybe NonLocalAttr))} ]++ATTR Visit Visits [ terminaldefs : {Set String} | | ]+ATTR EChild EChildren [ | | terminaldefs USE {`Set.union`} {Set.empty} : {Set String} ]++SEM EChild | ETerm+  lhs.terminaldefs = Set.singleton $ fieldname @name++SEM EProduction | EProduction+  visits.allintramap  = @visits.intramap+  visits.terminaldefs = @children.terminaldefs++SEM Visit+  | Visit loc.thisintra = (@loc.uses `Map.union` @loc.nextintra) `Map.difference` @loc.defsAsMap+          lhs.intramap  = Map.singleton @from @loc.thisintra+          loc.nextintra = maybe Map.empty id $ Map.lookup @to @lhs.allintramap+          loc.uses      = let mp1 = @steps.uses+                              mp2 = Map.fromList [ (lhsname @lhs.options False i, Just (AttrSyn _LHS i)) | i <- Set.elems @syn ]+                          in mp1 `Map.union` mp2+          loc.inhVarNms = Set.map (lhsname @lhs.options True) @inh+          loc.defs      = @steps.defs `Set.union` @loc.inhVarNms `Set.union` @lhs.terminaldefs+          loc.defsAsMap = Map.fromList [ (a, Nothing) | a <- Set.elems @loc.defs ]++ATTR ERule ERules [ | | ruledefs USE {`uwSetUnion`} {Map.empty} : {Map Identifier (Set String)}+                        ruleuses USE {`uwMapUnion`} {Map.empty} : {Map Identifier (Map String (Maybe NonLocalAttr))} ]+ATTR Visit Visits+     VisitSteps VisitStep [ ruledefs  : {Map Identifier (Set String)}+                            ruleuses  : {Map Identifier (Map String (Maybe NonLocalAttr))} | | ]++SEM ERule+  | ERule lhs.ruledefs = Map.singleton @name @pattern.attrs+          lhs.ruleuses = Map.singleton @name @rhs.attrs++SEM EProduction+  | EProduction visits.ruledefs = @rules.ruledefs+                visits.ruleuses = @rules.ruleuses++ATTR Visit Visits+     EProduction+     EProductions+     ENonterminal+     ENonterminals [ | | visitdefs USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (Set Identifier)}+                         visituses USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (Set Identifier)} ]++SEM Visit+  | Visit lhs.visitdefs = Map.singleton @ident @syn+          lhs.visituses = Map.singleton @ident @inh++ATTR Visit Visits+     VisitSteps VisitStep+     EProduction EProductions+     ENonterminal ENonterminals [ avisitdefs : {Map VisitIdentifier (Set Identifier)}+                                  avisituses : {Map VisitIdentifier (Set Identifier)} | | ]++SEM ExecutionPlan+  | ExecutionPlan nonts.avisitdefs = @nonts.visitdefs+                  nonts.avisituses = @nonts.visituses++ATTR VisitSteps VisitStep [ | | defs USE {`Set.union`} {Set.empty} : {Set String}+                                uses USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ]+SEM VisitStep+  | Sem        lhs.defs = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruledefs+               lhs.uses = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruleuses+  | ChildVisit lhs.defs = Set.insert (stname @child @to) $ maybe (error "Visit not found") (Set.map $ attrname @lhs.options True @child) $ Map.lookup @visit @lhs.avisitdefs+               lhs.uses = let convert attrs = Map.fromList [ (attrname @lhs.options False @child attr, Just $ mkNonLocalAttr True @child attr) | attr <- Set.elems attrs ]+                          in Map.insert (stname @child @from) Nothing $ convert $+                               maybe (error "Visit not found") id $ Map.lookup @visit @lhs.avisituses++-------------------------------------------------------------------------------+--  Identification of lazy intra defs within a production+--+-- These identifiers will not be marked as strict in rules and state closures+-------------------------------------------------------------------------------++ATTR Visits Visit VisitSteps VisitStep [ | | lazyIntras USE {`Set.union`} {Set.empty} : {Set String} ]+ATTR ERules ERule [ lazyIntras : {Set String} | | ]++SEM Visit | Visit+  loc.lazyIntrasInh = case @kind of+                        VisitPure False -> @loc.inhVarNms `Set.union` @steps.defs+                        _               -> Set.empty+  lhs.lazyIntras = @loc.lazyIntrasInh `Set.union` @steps.lazyIntras++SEM VisitStep | PureGroup+  lhs.lazyIntras = if @ordered+                   then @steps.lazyIntras+                   else @steps.defs++SEM EProduction | EProduction+  loc.lazyIntras = @visits.lazyIntras++-------------------------------------------------------------------------------+--  Pretty printing of haskell code+-------------------------------------------------------------------------------++SEM HsTokens [ || tks : {[(Pos,String)]} ]+  | Cons lhs.tks = @hd.tok : @tl.tks+  | Nil  lhs.tks = []++SEM HsToken+  | AGLocal   loc.tok = (@pos,fieldname @var)++SEM HsToken [ || tok:{(Pos,String)}]+   | AGField+       loc.addTrace = case @rdesc of+                        Just d  -> \x -> "(trace " ++ show (d ++ " -> " ++ show @field ++ "." ++ show @attr) ++ " (" ++ x ++ "))"+                        Nothing -> id+       lhs.tok = (@pos, @loc.addTrace $ attrname @lhs.options True @field @attr)++   | HsToken lhs.tok = (@pos, @value)++   | CharToken lhs.tok = (@pos, if null @value+                                   then ""+                                   else showCharShort (head @value)+                         )++   | StrToken  lhs.tok = (@pos, showStrShort @value)+   | Err       lhs.tok = (@pos, "")++-------------------------------------------------------------------------------+--  Alternative code generation (sepsemmods)+-------------------------------------------------------------------------------++ATTR ExecutionPlan [ mainBlocksDoc : PP_Doc textBlockMap : {Map BlockInfo PP_Doc}+                   | | genIO : {IO ()} ]++SEM ExecutionPlan+  | ExecutionPlan lhs.genIO           = do @loc.genMainModule+                                           @loc.genCommonModule+                                           @nonts.genProdIO+                  loc.mainModuleFile  = @lhs.mainFile+                  loc.ppMonadImports  = ( if tupleAsDummyToken @lhs.options+                                          then empty+                                          else pp "import GHC.Prim"+                                        )+                                        >-< if parallelInvoke @lhs.options+                                            then pp "import qualified System.IO.Unsafe(unsafePerformIO)"+                                                 >-< pp "import System.IO(IO)"+                                                 >-< pp "import Control.Concurrent(newEmptyMVar,forkIO,putMVar,takeMVar)"+                                            else pp "import Control.Monad.Identity"+                  loc.genMainModule   = writeModule @loc.mainModuleFile+                                          ( [ warrenFlagsPP @lhs.options+                                            , pp $ @lhs.pragmaBlocks+                                            , pp $ @lhs.moduleHeader @lhs.mainName "" "" False+                                            , @loc.ppMonadImports+                                            , pp $ "import " ++ @lhs.mainName ++ "_common"+                                            ]+                                            ++ @nonts.imports+                                            ++ [@lhs.mainBlocksDoc]+                                            ++ [@loc.wrappersExtra]+                                            ++ @nonts.appendMain+                                          )+                  loc.commonFile      = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_common")+                  loc.genCommonModule = writeModule @loc.commonFile+                                          ( [ pp $ "{-# LANGUAGE Rank2Types, GADTs #-}"  -- the common module only needs GADTs and Rank2Types+                                            , pp $ @lhs.pragmaBlocks+                                            , pp $ @lhs.moduleHeader @lhs.mainName "_common" "" True+                                            , @loc.ppMonadImports+                                            , @lhs.importBlocks+                                            , @lhs.textBlocks+                                            , @loc.commonExtra+                                            ]+                                            ++ @nonts.appendCommon+                                          )++ATTR ENonterminal  [ | | appendCommon, appendMain              : { PP_Doc } ]+ATTR ENonterminals [ | | appendCommon, appendMain USE {:} {[]} : {[PP_Doc]} ]++SEM ENonterminal+  | ENonterminal lhs.appendMain   = (if @nt `Set.member` @lhs.wrappers+                                     then     @loc.wr_inh+                                          >-< @loc.wr_syn+                                          >-< @loc.wrapper+                                     else empty)+                                    >-< @loc.sem_nt+                 lhs.appendCommon = (if dataTypes @lhs.options then @loc.datatype else empty)+                                    >-< @loc.t_init+                                    >-< @loc.t_states+                                    >-< @loc.k_states+                                    >-< @prods.t_visits++ATTR EProduction EProductions+     ENonterminal ENonterminals [ | | imports USE {++} {[]} : {[PP_Doc]}+                                      genProdIO USE {>>} {return ()} : {IO ()} ]++SEM EProduction+  | EProduction lhs.imports    = [pp $ "import " ++ @loc.moduleName]+                loc.moduleName = @lhs.mainName ++ @loc.suffix+                loc.suffix     = "_" ++ show @lhs.nt ++ "_" ++ show @con+                loc.outputfile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ @loc.suffix)+                loc.ppMonadImports  = if parallelInvoke @lhs.options+                                      then pp "import qualified System.IO.Unsafe(unsafePerformIO)"+                                           >-< pp "import System.IO(IO)"+                                           >-< pp "import Control.Concurrent(newEmptyMVar,forkIO,putMVar,takeMVar)"+                                      else pp "import Control.Monad.Identity"+                lhs.genProdIO  = writeModule @loc.outputfile+                                     [ warrenFlagsPP @lhs.options+                                     , pp $ @lhs.pragmaBlocks+                                     , pp $ @lhs.moduleHeader @lhs.mainName @loc.suffix @loc.semname True+                                     , @lhs.importBlocks+                                     , @loc.ppMonadImports+                                     , ( if tupleAsDummyToken @lhs.options+                                            then empty+                                            else pp "import GHC.Prim"  -- need it to pass State#+                                      )+                                     , pp $ "import " ++ @lhs.mainName ++ "_common"+                                     , @loc.sem_prod+                                     ]++{+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+}+++--+-- Bang pattern usage+--++SEM ERule | ERule                   loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x+SEM Visit | Visit                   loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x+SEM ENonterminal | ENonterminal     loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x+SEM EProduction | EProduction       loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x+SEM EChild | EChild                 loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x+SEM EChild | ETerm                  loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x+SEM VisitStep | ChildVisit          loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x+SEM Pattern | Alias Constr Product  loc.addbang  = \x -> if bangpats @lhs.options then "!" >|< x else x++SEM Visit | Visit                   loc.addbang1 = if isLazyKind @kind then id else @loc.addbang+SEM ENonterminal | ENonterminal     loc.addbangWrap = id --if strictWrap @lhs.options then @loc.addbang else id+SEM ERule | ERule                   loc.addbang1 = if @loc.anyLazyKind then id else @loc.addbang+SEM Pattern | Alias Constr Product  loc.addbang1 = if @lhs.anyLazyKind then id else @loc.addbang++--+-- Distribute single-visit-next map downward+--++ATTR EProductions EProduction Visits Visit+  [ prevVisits, nextVisits : {Map StateIdentifier StateCtx} | | ]++SEM ENonterminal | ENonterminal+  prods.nextVisits = @nextVisits+  prods.prevVisits = @prevVisits++--+-- Collect and distribute the from/to states of a visit+--++ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit+  [ | | fromToStates USE {`mappend`} {mempty} : {Map VisitIdentifier (Int,Int)} ]++ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep+  [ allFromToStates : {Map VisitIdentifier (Int,Int)} | | ]++SEM Visit | Visit+  lhs.fromToStates = Map.singleton @ident (@from, @to)++SEM ExecutionPlan | ExecutionPlan+  nonts.allFromToStates = @nonts.fromToStates++SEM VisitStep | ChildVisit+  (loc.from, loc.to) = Map.findWithDefault (error "visit not in allFromToStates") @visit @lhs.allFromToStates+++--+-- Collect and distribute the actual types of children of productions+--++ATTR EChildren EChild [ | | childTypes USE {`mappend`} {mempty} : {Map Identifier Type} ]+ATTR ERules ERule Visits Visit VisitSteps VisitStep [ childTypes : {Map Identifier Type} | | ]++SEM EProduction | EProduction+  loc.childTypes = Map.singleton _LHS @lhs.ntType `Map.union` @children.childTypes++SEM EChild | EChild ETerm+  lhs.childTypes = Map.singleton @name @tp++--+-- Distribute types of local attributes+--++ATTR ExecutionPlan ENonterminals ENonterminal  [ localAttrTypes : {Map NontermIdent (Map ConstructorIdent (Map Identifier Type))} | | ]+ATTR EProductions EProduction                  [ localAttrTypes : {Map ConstructorIdent (Map Identifier Type)} | | ]+ATTR ERules ERule Pattern Patterns             [ localAttrTypes : {Map Identifier Type} | | ]++SEM ENonterminal | ENonterminal+  prods.localAttrTypes = Map.findWithDefault Map.empty @nt @lhs.localAttrTypes++SEM EProduction | EProduction+  loc.localAttrTypes   = Map.findWithDefault Map.empty @con @lhs.localAttrTypes++--+-- Collect and distribute visit kinds+--++ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep+  [ allVisitKinds : {Map VisitIdentifier VisitKind} | | visitKinds USE {`mappend`} {mempty} : {Map VisitIdentifier VisitKind} ]++SEM Visit | Visit+  lhs.visitKinds = Map.singleton @ident @kind++SEM ExecutionPlan | ExecutionPlan+  nonts.allVisitKinds = @nonts.visitKinds++--+-- Collect and distribute the initial state of nonterminals+--++ATTR ENonterminals ENonterminal [ | | initStates USE {`mappend`} {mempty} : {Map NontermIdent Int} ]+ATTR ENonterminals ENonterminal EProductions EProduction EChildren EChild Visits Visit VisitSteps VisitStep+  [ allInitStates : {Map NontermIdent Int} | | ]++SEM ENonterminal | ENonterminal+  lhs.initStates = Map.singleton @nt @initial++SEM ExecutionPlan | ExecutionPlan+  nonts.allInitStates = @nonts.initStates++SEM EChild | EChild+  loc.initSt = Map.findWithDefault (error "nonterminal not in allInitStates map") @loc.nt @lhs.allInitStates++--+-- Push the nonterminal type downward+--++ATTR EProductions EProduction [ ntType : Type | | ]+SEM ENonterminal | ENonterminal+  loc.ntType = NT @nt (map show @params) False++--+-- Collect errors contained in rules that should be yielded when the+-- rules are scheduled.+--++ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule Visits Visit VisitSteps VisitStep [ | | errors USE {Seq.><} {Seq.empty} : {Seq Error} ]+SEM ERule | ERule+  lhs.errors = case @mbError of+                 Just e | @loc.used > 0 -> Seq.singleton e+                 _                      -> Seq.empty+++-- Some pretty printing utility functions+{+ppNoInline :: PP a => a -> PP_Doc+ppNoInline = ppPragmaBinding "NOINLINE"++ppInline :: PP a => a -> PP_Doc+ppInline = ppPragmaBinding "INLINE"++ppInlinable :: PP a => a -> PP_Doc+ppInlinable = ppPragmaBinding "INLINABLE"++ppPragmaBinding :: (PP a, PP b) => a -> b -> PP_Doc+ppPragmaBinding pragma nm = "{-#" >#< pragma >#< nm >#< "#-}"++ppCostCentre :: PP a => a -> PP_Doc+ppCostCentre nm = "{-#" >#< "SCC" >#< "\"" >|< nm >|< "\"" >#< "#-}"++warrenFlagsPP :: Options -> PP_Doc+warrenFlagsPP options = vlist+  [ pp "{-# LANGUAGE Rank2Types, GADTs #-}"+  , if bangpats options+    then pp "{-# LANGUAGE BangPatterns #-}"+    else empty+  , if noPerRuleTypeSigs options && noPerStateTypeSigs options+    then empty+    else pp "{-# LANGUAGE ScopedTypeVariables #-}"+  , if tupleAsDummyToken options+    then empty+    else pp "{-# LANGUAGE ScopedTypeVariables, MagicHash #-}"+  , -- not that the meaning of "unbox" is here that strict fields in data types may be+    -- unboxed if possible. This may affect user-defined data types declared in the module.+    -- Unfortunately, we cannot turn it on for only the AG generated data types without+    -- causing a zillion of warnings.+    if unbox options && bangpats options+        then pp $ "{-# OPTIONS_GHC -funbox-strict-fields -fstrictness #-}"+        else empty+  , if parallelInvoke options && not (noEagerBlackholing options)+    then pp $ "{-# OPTIONS_GHC -feager-blackholing #-}"+    else empty+  ]+}
src-ag/ExecutionPlanCommon.ag view
@@ -1,161 +1,161 @@--------------------------------------------------------------------------------
---         Distributing options
--------------------------------------------------------------------------------
-ATTR Grammar Nonterminals Nonterminal Productions Production Children Child
-  [ options : {Options} | | ]
-
--------------------------------------------------------------------------------
---         Find out which nonterminals are recursive
--------------------------------------------------------------------------------
-
-ATTR Nonterminals Nonterminal [ | | ntDeps, ntHoDeps USE {`mappend`} {mempty} : {Map NontermIdent (Set NontermIdent)} ]
-ATTR Nonterminals Nonterminal [ closedNtDeps, closedHoNtDeps, closedHoNtRevDeps : {Map NontermIdent (Set NontermIdent)} | | ]
-ATTR Productions Production Children Child [ | | refNts, refHoNts USE {`mappend`} {mempty} : {Set NontermIdent} ]
-
-SEM Nonterminal | Nonterminal
-  lhs.ntDeps            = Map.singleton @nt @prods.refNts
-  lhs.ntHoDeps          = Map.singleton @nt @prods.refHoNts
-
-  loc.closedNtDeps      = Map.findWithDefault Set.empty @nt @lhs.closedNtDeps
-  loc.closedHoNtDeps    = Map.findWithDefault Set.empty @nt @lhs.closedHoNtDeps
-  loc.closedHoNtRevDeps = Map.findWithDefault Set.empty @nt @lhs.closedHoNtRevDeps
-
-  loc.recursive         = @nt `Set.member` @loc.closedNtDeps
-  loc.nontrivAcyc       = @nt `Set.member` @loc.closedHoNtDeps
-  loc.hoInfo            = HigherOrderInfo { hoNtDeps            = @loc.closedHoNtDeps
-                                          , hoNtRevDeps         = @loc.closedHoNtRevDeps
-                                          , hoAcyclic           = @loc.nontrivAcyc
-                                          }
-
-SEM Child | Child
-  loc.refNts = case @tp of
-                 NT nt _ _ -> Set.singleton nt
-                 _         -> mempty
-  loc.refHoNts = if @loc.isHigherOrder then @loc.refNts else mempty
-  loc.isHigherOrder = case @kind of
-                        ChildSyntax -> False
-                        _           -> True
-
-SEM Grammar | Grammar
-  loc.closedNtDeps      = closeMap @nonts.ntDeps
-  loc.closedHoNtDeps    = closeMap @nonts.ntHoDeps
-  loc.closedHoNtRevDeps = revDeps @loc.closedHoNtDeps
-
--------------------------------------------------------------------------------
---         Distribute the ContextMap to nonterminals
--------------------------------------------------------------------------------
-
-ATTR Nonterminals Nonterminal [ classContexts : ContextMap | | ]
-
-SEM Grammar | Grammar
-  nonts.classContexts = @contextMap
-
-SEM Nonterminal | Nonterminal
-  loc.classContexts = Map.findWithDefault [] @nt @lhs.classContexts
-
--------------------------------------------------------------------------------
---         Gather all rules per production for the execution plan
--------------------------------------------------------------------------------
-ATTR Expression [ | | copy : SELF ]
-
-ATTR Rule  [ | | erules : ERule ]
-ATTR Rules [ | | erules USE {:} {[]} : ERules  ]
-
-SEM Rule
-  | Rule lhs.erules = ERule @loc.rulename
-                            @pattern.copy
-                            @rhs.copy
-                            @owrt
-                            @origin
-                            @explicit
-                            @pure
-                            @mbError
-
--------------------------------------------------------------------------------
---         Determine which children have an around-rule
--------------------------------------------------------------------------------
-
--- Propagate the around-map downward
-ATTR Nonterminals Nonterminal
-  [ aroundMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} || ]
-
-ATTR Productions Production
-  [ aroundMap : {Map ConstructorIdent (Map Identifier [Expression])} || ]
-
-ATTR Children Child
-  [ aroundMap : {Map Identifier [Expression]} | | ]
-
-SEM Nonterminal | Nonterminal  loc.aroundMap = Map.findWithDefault Map.empty @nt @lhs.aroundMap
-SEM Production | Production    loc.aroundMap = Map.findWithDefault Map.empty @con @lhs.aroundMap
-
-SEM Grammar | Grammar
-  nonts.aroundMap = @aroundsMap
-
-SEM Child | Child
-  loc.hasArounds = case Map.lookup @name @lhs.aroundMap of
-                     Nothing -> False
-                     Just as -> not (null as)
-
--------------------------------------------------------------------------------
---         Determine which children are used by merges
--------------------------------------------------------------------------------
-
--- Propagate the around-map downward
-ATTR Nonterminals Nonterminal
-  [ mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression)))} || ]
-
-ATTR Productions Production
-  [ mergeMap : {Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression))} || ]
-
-ATTR Children Child
-  [ mergeMap : {Map Identifier (Identifier, [Identifier], Expression)} mergedChildren : {Set Identifier} | | ]
-
-SEM Nonterminal | Nonterminal  loc.mergeMap = Map.findWithDefault Map.empty @nt @lhs.mergeMap
-SEM Production | Production    loc.mergeMap = Map.findWithDefault Map.empty @con @lhs.mergeMap
-
-SEM Grammar | Grammar
-  nonts.mergeMap = @mergeMap
-
-SEM Production | Production
-  loc.mergedChildren = Set.unions [ Set.fromList ms | (_,ms,_) <- Map.elems @loc.mergeMap ]
-
-SEM Child | Child
-  loc.merges   = maybe Nothing (\(_,ms,_) -> Just ms) $ Map.lookup @name @lhs.mergeMap
-  loc.isMerged = @name `Set.member` @lhs.mergedChildren
-
-
--------------------------------------------------------------------------------
---         Gather all childs per production for the execution plan
--------------------------------------------------------------------------------
-
-ATTR Child    [ | | echilds : EChild ]
-ATTR Children [ | | echilds USE {:} {[]} : EChildren ]
-
-SEM Child
-  | Child lhs.echilds = case @tp of
-                          NT _ _ _ -> EChild @name @tp @kind @loc.hasArounds @loc.merges @loc.isMerged
-                          _        -> ETerm @name @tp
-
--------------------------------------------------------------------------------
---         Output nonterminal type mappings
--------------------------------------------------------------------------------
-ATTR Grammar
-     Nonterminals  [ | | inhmap USE {`Map.union`} {Map.empty} : {Map.Map NontermIdent Attributes}
-                         synmap USE {`Map.union`} {Map.empty} : {Map.Map NontermIdent Attributes} ]
-
-ATTR Nonterminal [ | | inhmap : {Map.Map NontermIdent Attributes}
-                       synmap : {Map.Map NontermIdent Attributes} ]
-SEM Nonterminal
-  | Nonterminal lhs.inhmap = Map.singleton @nt @inh
-                lhs.synmap = Map.singleton @nt @syn
-
--------------------------------------------------------------------------------
---         Output nonterminal type mappings
--------------------------------------------------------------------------------
-ATTR Grammar Nonterminals Nonterminal [ | | localSigMap USE {`Map.union`} {Map.empty} : {Map.Map NontermIdent (Map.Map ConstructorIdent (Map.Map Identifier Type))} ]
-ATTR Productions Production           [ | | localSigMap USE {`Map.union`} {Map.empty} : {Map.Map ConstructorIdent (Map.Map Identifier Type)} ]
-ATTR TypeSigs TypeSig                 [ | | localSigMap USE {`Map.union`} {Map.empty} : {Map Identifier Type} ]
-
-SEM Nonterminal | Nonterminal  lhs.localSigMap = Map.singleton @nt @prods.localSigMap
-SEM Production | Production    lhs.localSigMap = Map.singleton @con @typeSigs.localSigMap
-SEM TypeSig | TypeSig          lhs.localSigMap = Map.singleton @name @tp
+-------------------------------------------------------------------------------+--         Distributing options+-------------------------------------------------------------------------------+ATTR Grammar Nonterminals Nonterminal Productions Production Children Child+  [ options : {Options} | | ]++-------------------------------------------------------------------------------+--         Find out which nonterminals are recursive+-------------------------------------------------------------------------------++ATTR Nonterminals Nonterminal [ | | ntDeps, ntHoDeps USE {`mappend`} {mempty} : {Map NontermIdent (Set NontermIdent)} ]+ATTR Nonterminals Nonterminal [ closedNtDeps, closedHoNtDeps, closedHoNtRevDeps : {Map NontermIdent (Set NontermIdent)} | | ]+ATTR Productions Production Children Child [ | | refNts, refHoNts USE {`mappend`} {mempty} : {Set NontermIdent} ]++SEM Nonterminal | Nonterminal+  lhs.ntDeps            = Map.singleton @nt @prods.refNts+  lhs.ntHoDeps          = Map.singleton @nt @prods.refHoNts++  loc.closedNtDeps      = Map.findWithDefault Set.empty @nt @lhs.closedNtDeps+  loc.closedHoNtDeps    = Map.findWithDefault Set.empty @nt @lhs.closedHoNtDeps+  loc.closedHoNtRevDeps = Map.findWithDefault Set.empty @nt @lhs.closedHoNtRevDeps++  loc.recursive         = @nt `Set.member` @loc.closedNtDeps+  loc.nontrivAcyc       = @nt `Set.member` @loc.closedHoNtDeps+  loc.hoInfo            = HigherOrderInfo { hoNtDeps            = @loc.closedHoNtDeps+                                          , hoNtRevDeps         = @loc.closedHoNtRevDeps+                                          , hoAcyclic           = @loc.nontrivAcyc+                                          }++SEM Child | Child+  loc.refNts = case @tp of+                 NT nt _ _ -> Set.singleton nt+                 _         -> mempty+  loc.refHoNts = if @loc.isHigherOrder then @loc.refNts else mempty+  loc.isHigherOrder = case @kind of+                        ChildSyntax -> False+                        _           -> True++SEM Grammar | Grammar+  loc.closedNtDeps      = closeMap @nonts.ntDeps+  loc.closedHoNtDeps    = closeMap @nonts.ntHoDeps+  loc.closedHoNtRevDeps = revDeps @loc.closedHoNtDeps++-------------------------------------------------------------------------------+--         Distribute the ContextMap to nonterminals+-------------------------------------------------------------------------------++ATTR Nonterminals Nonterminal [ classContexts : ContextMap | | ]++SEM Grammar | Grammar+  nonts.classContexts = @contextMap++SEM Nonterminal | Nonterminal+  loc.classContexts = Map.findWithDefault [] @nt @lhs.classContexts++-------------------------------------------------------------------------------+--         Gather all rules per production for the execution plan+-------------------------------------------------------------------------------+ATTR Expression [ | | copy : SELF ]++ATTR Rule  [ | | erules : ERule ]+ATTR Rules [ | | erules USE {:} {[]} : ERules  ]++SEM Rule+  | Rule lhs.erules = ERule @loc.rulename+                            @pattern.copy+                            @rhs.copy+                            @owrt+                            @origin+                            @explicit+                            @pure+                            @mbError++-------------------------------------------------------------------------------+--         Determine which children have an around-rule+-------------------------------------------------------------------------------++-- Propagate the around-map downward+ATTR Nonterminals Nonterminal+  [ aroundMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} || ]++ATTR Productions Production+  [ aroundMap : {Map ConstructorIdent (Map Identifier [Expression])} || ]++ATTR Children Child+  [ aroundMap : {Map Identifier [Expression]} | | ]++SEM Nonterminal | Nonterminal  loc.aroundMap = Map.findWithDefault Map.empty @nt @lhs.aroundMap+SEM Production | Production    loc.aroundMap = Map.findWithDefault Map.empty @con @lhs.aroundMap++SEM Grammar | Grammar+  nonts.aroundMap = @aroundsMap++SEM Child | Child+  loc.hasArounds = case Map.lookup @name @lhs.aroundMap of+                     Nothing -> False+                     Just as -> not (null as)++-------------------------------------------------------------------------------+--         Determine which children are used by merges+-------------------------------------------------------------------------------++-- Propagate the around-map downward+ATTR Nonterminals Nonterminal+  [ mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression)))} || ]++ATTR Productions Production+  [ mergeMap : {Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression))} || ]++ATTR Children Child+  [ mergeMap : {Map Identifier (Identifier, [Identifier], Expression)} mergedChildren : {Set Identifier} | | ]++SEM Nonterminal | Nonterminal  loc.mergeMap = Map.findWithDefault Map.empty @nt @lhs.mergeMap+SEM Production | Production    loc.mergeMap = Map.findWithDefault Map.empty @con @lhs.mergeMap++SEM Grammar | Grammar+  nonts.mergeMap = @mergeMap++SEM Production | Production+  loc.mergedChildren = Set.unions [ Set.fromList ms | (_,ms,_) <- Map.elems @loc.mergeMap ]++SEM Child | Child+  loc.merges   = maybe Nothing (\(_,ms,_) -> Just ms) $ Map.lookup @name @lhs.mergeMap+  loc.isMerged = @name `Set.member` @lhs.mergedChildren+++-------------------------------------------------------------------------------+--         Gather all childs per production for the execution plan+-------------------------------------------------------------------------------++ATTR Child    [ | | echilds : EChild ]+ATTR Children [ | | echilds USE {:} {[]} : EChildren ]++SEM Child+  | Child lhs.echilds = case @tp of+                          NT _ _ _ -> EChild @name @tp @kind @loc.hasArounds @loc.merges @loc.isMerged+                          _        -> ETerm @name @tp++-------------------------------------------------------------------------------+--         Output nonterminal type mappings+-------------------------------------------------------------------------------+ATTR Grammar+     Nonterminals  [ | | inhmap USE {`Map.union`} {Map.empty} : {Map.Map NontermIdent Attributes}+                         synmap USE {`Map.union`} {Map.empty} : {Map.Map NontermIdent Attributes} ]++ATTR Nonterminal [ | | inhmap : {Map.Map NontermIdent Attributes}+                       synmap : {Map.Map NontermIdent Attributes} ]+SEM Nonterminal+  | Nonterminal lhs.inhmap = Map.singleton @nt @inh+                lhs.synmap = Map.singleton @nt @syn++-------------------------------------------------------------------------------+--         Output nonterminal type mappings+-------------------------------------------------------------------------------+ATTR Grammar Nonterminals Nonterminal [ | | localSigMap USE {`Map.union`} {Map.empty} : {Map.Map NontermIdent (Map.Map ConstructorIdent (Map.Map Identifier Type))} ]+ATTR Productions Production           [ | | localSigMap USE {`Map.union`} {Map.empty} : {Map.Map ConstructorIdent (Map.Map Identifier Type)} ]+ATTR TypeSigs TypeSig                 [ | | localSigMap USE {`Map.union`} {Map.empty} : {Map Identifier Type} ]++SEM Nonterminal | Nonterminal  lhs.localSigMap = Map.singleton @nt @prods.localSigMap+SEM Production | Production    lhs.localSigMap = Map.singleton @con @typeSigs.localSigMap+SEM TypeSig | TypeSig          lhs.localSigMap = Map.singleton @name @tp
src-ag/ExecutionPlanPre.ag view
@@ -1,15 +1,15 @@--------------------------------------------------------------------------------
---         Give unique names to rules
--------------------------------------------------------------------------------
-ATTR Nonterminal Nonterminals
-     Production Productions
-     Rule Rules  [ | rulenumber : Int | ]
-
-SEM  Grammar
-  |  Grammar nonts.rulenumber = 0
-
-SEM  Rule
-  |  Rule lhs.rulenumber = @lhs.rulenumber + 1
-          loc.rulename   = maybe (identifier $ "rule" ++ show @lhs.rulenumber) id @mbName
-
-
+-------------------------------------------------------------------------------+--         Give unique names to rules+-------------------------------------------------------------------------------+ATTR Nonterminal Nonterminals+     Production Productions+     Rule Rules  [ | rulenumber : Int | ]++SEM  Grammar+  |  Grammar nonts.rulenumber = 0++SEM  Rule+  |  Rule lhs.rulenumber = @lhs.rulenumber + 1+          loc.rulename   = maybe (identifier $ "rule" ++ show @lhs.rulenumber) id @mbName++
src-ag/Expression.ag view
@@ -1,12 +1,12 @@-imports
-{
-import UU.Scanner.Position(Pos)
-import HsToken
-}
-
-DATA Expression
-   | Expression pos:{Pos}
-                tks:{[HsToken]}
-
-SET AllExpression
-  = Expression
+imports+{+import UU.Scanner.Position(Pos)+import HsToken+}++DATA Expression+   | Expression pos:{Pos}+                tks:{[HsToken]}++SET AllExpression+  = Expression
src-ag/GenerateCode.ag view
@@ -1,1191 +1,1191 @@-PRAGMA strictwrap
-PRAGMA strictdata
-
-INCLUDE "CodeSyntax.ag"
-INCLUDE "Patterns.ag"
-INCLUDE "DeclBlocks.ag"
-
-imports
-{
-import CommonTypes
-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 Data.Sequence as Seq
-import Data.Sequence(Seq)
-import UU.Scanner.Position
-import TokenDef
-import HsToken
-import HsTokenScanner
-
-import Data.List(partition,intersperse)
-import Data.Maybe(fromJust,isJust)
-
-}
-
-
--------------------------------------------------------------------------------
---         Options
--------------------------------------------------------------------------------
-
-ATTR CNonterminals CNonterminal
-     CProductions CProduction
-     CVisits CVisit
-     Sequence CRule
-     CInterface CSegments CSegment
-       [ o_unbox,o_sig,o_sem,o_newtypes,o_case,o_pretty,o_rename,o_cata,o_strictwrap,o_splitsems,o_traces,o_costcentre,o_linePragmas,o_monadic,o_clean : Bool
-         o_data : {Maybe Bool}
-         prefix : String
-         options : Options
-       | | ]
-SEM CGrammar [ options : Options | | ]
-  | CGrammar    nonts.o_sig         = typeSigs       @lhs.options
-                     .o_cata        = folds          @lhs.options
-                     .o_sem         = semfuns        @lhs.options
-                     .o_newtypes    = newtypes       @lhs.options
-                     .o_unbox       = unbox          @lhs.options
-                     .o_case        = cases          @lhs.options
-                     .o_pretty      = attrInfo       @lhs.options
-                     .o_rename      = rename         @lhs.options
-                     .o_strictwrap  = strictWrap     @lhs.options
-                     .o_splitsems   = splitSems      @lhs.options
-                     .o_data        = if dataTypes @lhs.options then Just (strictData @lhs.options) else Nothing
-                     .prefix        = prefix         @lhs.options
-                     .o_traces      = genTraces      @lhs.options
-                     .o_costcentre  = genCostCentres @lhs.options
-                     .o_linePragmas = genLinePragmas @lhs.options
-                     .o_monadic     = monadic        @lhs.options
-                     .o_clean       = clean          @lhs.options
-
-SEM CGrammar | CGrammar
-  loc.options = @lhs.options { breadthFirst = breadthFirst @lhs.options && visit @lhs.options && cases @lhs.options && @multivisit }
-
-ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit [ allPragmas : PragmaMap | | ]
-
-SEM CGrammar
-  | CGrammar  nonts.allPragmas = @pragmas
-
--------------------------------------------------------------------------------
--- Passing information about nonterminal and constructor down
--------------------------------------------------------------------------------
-
-ATTR  CProductions CProduction CVisits
-      CVisit Sequence CRule CInterface
-      CSegments CSegment [ nt:NontermIdent inh,syn:Attributes | | ]
-SEM  CNonterminal
-  |  CNonterminal  inter.(inh,syn,nt) = (@inh,@syn,@nt)
-                  prods.(inh,syn,nt) = (@inh,@syn,@nt)
-
-ATTR CVisits CVisit Sequence CRule [ con:ConstructorIdent
-                                     terminals : {[Identifier]} | | ]
-SEM  CProduction
-  |  CProduction  visits.con = @con
-                   visits.terminals = @terminals
-
-ATTR CNonterminals CNonterminal CSegments CSegment CInterface CProductions CProduction CVisits CVisit Sequence CRule [ paramMap : ParamMap | | ]
-
-SEM CGrammar
-  | CGrammar nonts.paramMap = @paramMap
-
-
-ATTR CVisits CVisit Sequence CRule [ paramInstMap : {Map Identifier (NontermIdent, [String])} | | ]
-
-SEM CProduction
-  | CProduction
-      loc.paramInstMap = Map.fromList [(nm, (extractNonterminal tp, tps)) | (nm,tp,_) <- @children, let tps = map (cleanupArg @lhs.options) $ nontermArgs tp, not (null tps) ]
-
-{
--- remove possible @v references in the types of a data type.
-cleanupArg :: Options -> String -> String
-cleanupArg opts s
-  = case idEvalType opts (SimpleType s) of
-      SimpleType s' -> s'
-      _             -> error "Only SimpleType supported"
-}
-
-ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit [ contextMap : {ContextMap} quantMap : QuantMap | | ]
-
-SEM CGrammar
-  | CGrammar
-      nonts.contextMap = @contextMap
-      nonts.quantMap   = @quantMap
-
-{
-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
-
-appQuant :: QuantMap -> NontermIdent -> Code.Type -> Code.Type
-appQuant mp nt tp
-  = foldr QuantApp tp $ Map.findWithDefault [] nt mp
-}
-
-ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit Sequence CRule [ allNts : {Set NontermIdent} | | ]
-
-SEM CGrammar
-  | CGrammar
-      nonts.allNts = @nonts.gathNts
-
-ATTR CNonterminals CNonterminal [ | | gathNts USE {`Set.union`} {Set.empty} : {Set NontermIdent} ]
-
-SEM CNonterminal
-  | CNonterminal
-      lhs.gathNts = Set.singleton @nt
-
--- keep track of which children have had their first visit
-ATTR CVisits CVisit Sequence CRule [ | visitedSet : {Set Identifier} | ]
-SEM CProduction | CProduction  visits.visitedSet = Set.empty
-SEM CRule | CChildVisit  loc.visitedSet = Set.insert @name @lhs.visitedSet
-
--------------------------------------------------------------------------------
--- Generating declarations from the sequence. We generate the origin
--- comment if pretty printing is requested. A childvisit takes inherited
--- attributes and returns synthesized attributes and the next visit.
--------------------------------------------------------------------------------
-
-ATTR  Sequence CRule [ | | decls USE {++} {[]} : {Decls} ]
-SEM  CRule
-  |  CRule loc.instTypes = [ (n, (t, mb, for)) | (n, NT t _ for, mb) <- @lhs.children ]
-           loc.originComment = if  @lhs.o_pretty
-                                   then (Comment @origin:)
-                                   else id
-           loc.instDecls = [ mkDecl @lhs.o_monadic (Pattern3 (Alias _INST' inst (Underscore (getPos inst))))
-                                  ( let (nm,mb,defor) = fromJust $ inst `lookup` @loc.instTypes
-                                    in unwrapSem @lhs.o_newtypes nm
-                                       $ case mb of
-                                           ChildReplace _ -> App instLocFieldName [SimpleExpr $ fieldname inst]
-                                           _              ->
-                                              if defor
-                                              then SimpleExpr instLocFieldName
-                                              else App (cataname @lhs.prefix nm)
-                                                             [SimpleExpr instLocFieldName]
-                                  )
-                                  (Set.singleton instSemFieldName)
-                                  (Set.singleton instLocFieldName)
-                           | inst <- @loc.definedInsts
-                           , let instLocFieldName = attrname @lhs.options True _INST inst
-                                 instSemFieldName = attrname @lhs.options False _INST' inst
-                           ]
-           loc.patDescr = if @isIn
-                          then "_"
-                          else concat $ intersperse "," (map (\(f,a) -> show f ++ "." ++ show a) @pattern.patternAttributes)
-           loc.traceDescr = (maybe "" (\nm -> show nm ++ ":") @mbNamed) ++ show @nt ++ " :: " ++ show @con ++ " :: " ++ @loc.patDescr
-
-           loc.addTrace = \v -> if @lhs.o_traces
-                                then Trace @loc.traceDescr v
-                                else v
-           loc.costCentreDescr = show @nt ++ ":" ++ show @con ++ ":" ++ @loc.patDescr
-           loc.addCostCentre = \v -> if @lhs.o_costcentre
-                                     then PragmaExpr True False ("SCC \"" ++ @loc.costCentreDescr ++ "\"") v
-                                     else v
-           loc.addLinePragma = \v -> let p = getPos @name
-                                         hasPos = line p > 0 && column p >= 0 && not (null (file p))
-                                     in if @lhs.o_linePragmas && hasPos
-                                        then PragmaExpr True True ("LINE " ++ show (line p) ++ " " ++ show (file p))
-                                             $ LineExpr
-                                             $ v
-                                        else v
-           loc.decls = if @hasCode
-                       then @originComment ( mkDecl (@lhs.o_monadic && @explicit) (Pattern3 @pattern.copy) (@loc.addTrace $ @loc.addCostCentre $ @loc.addLinePragma $ (TextExpr @rhs))
-                                                  (Set.fromList [attrname @lhs.options False fld nm | (fld,nm,_) <- Map.elems @defines])
-                                                  (Set.fromList [attrname @lhs.options True fld nm | (fld,nm) <- Set.toList @uses])
-                                           : @loc.instDecls)
-                       else @loc.instDecls
-  |  CChildVisit loc.costCentreDescr = show @lhs.nt ++ ":" ++ show @lhs.con ++ ":" ++ show @name ++ ":" ++ show @nt ++ ":" ++ show @nr
-                 loc.addCostCentre = \v -> if @lhs.o_costcentre
-                                           then PragmaExpr True False ("SCC \"" ++ @loc.costCentreDescr ++ "\"") v
-                                           else v
-                 loc.decls = let  lhsVars =  map (attrname @lhs.options True @name) (Map.keys @syn)
-                                             ++ if @isLast then [] else [unwrap ++ funname @name (@nr+1)]
-                                  rhsVars = map (attrname @lhs.options False @name) (Map.keys @inh)
-                                  unwrap = if @lhs.o_newtypes then typeName @nt (@nr + 1) ++ " " else ""
-                                  tuple | isMerging = TupleLhs [locname @lhs.options @name ++ "_comp"]
-                                        | otherwise = mkTupleLhs @lhs.o_unbox (null $ Map.keys @inh) lhsVars
-                                  rhs = @loc.addCostCentre $ Code.InvokeExpr (typeName @nt @nr) (SimpleExpr fun) (map SimpleExpr rhsVars)
-                                  isVirtual _ [] = False
-                                  isVirtual nm ((n,_,kind) : r)
-                                    | nm == n   = case kind of
-                                                    ChildAttr      -> True
-                                                    ChildReplace _ -> True
-                                                    _              -> False
-                                    | otherwise = isVirtual nm r
-                                  isMerged = @name `Map.member` @lhs.mergeMap
-                                  isMerging = @name `elem` concatMap (\(_,cs) -> cs) (Map.elems @lhs.mergeMap)
-                                  merges = [ (c,cs) | (c,(_,cs)) <- Map.assocs @lhs.mergeMap, all (`Set.member` @loc.visitedSet) cs, @name `elem` (c:cs) ]
-
-                                  baseNm = if @nr == 0 && isVirtual @name @lhs.children
-                                           then Ident (getName @name ++ "_inst") (getPos @name)
-                                           else @name
-                                  fun | @nr == 0 && Set.member @name @lhs.aroundMap
-                                                  = locname @lhs.options @name ++ "_around " ++ funname baseNm 0
-                                      | otherwise = funname baseNm @nr
-                                  outDecls | isMerged  = []  -- merged variant is only produced after the last visit of the merged children
-                                           | otherwise = -- [mkDecl @lhs.o_monadic tuple rhs (Set.fromList lhsVars) (Set.fromList (funname baseNm @nr : rhsVars))]
-                                                         if isMerging
-                                                         then [mkDecl @lhs.o_monadic tuple rhs Set.empty Set.empty]
-                                                         else [Resume @lhs.o_monadic (typeName @nt @nr) tuple rhs]
-                                  outMerged | null merges || @nr /= 0 = []  -- no merged child to produce
-                                            | otherwise = let (c,cs) = head merges
-                                                              tuple' = mkTupleLhs @lhs.o_unbox (null $ Map.keys @inh) lhsVars'
-                                                              lhsVars' = map (attrname @lhs.options True c) (Map.keys @syn)
-                                                                         ++ if @isLast then [] else [unwrap ++ funname c (@nr+1)]
-                                                              rhsVars' = [ locname @lhs.options c' ++ "_comp" | c' <- cs ]
-                                                              fun'    = locname @lhs.options c ++ "_merge"
-                                                              rhs' = App fun' (map SimpleExpr rhsVars')
-                                                          in [Resume @lhs.o_monadic (typeName @nt @nr) tuple' rhs']
-                             in -- trace (show @name ++ " # " ++ show @loc.visitedSet ++ " # " ++ show (Map.assocs @lhs.mergeMap) ++ " # " ++ show merges ++ " # " ++ show @nr ++ " # " ++ show (length outMerged)) $
-                                (outDecls ++ outMerged)
-
-{
-mkDecl :: Bool -> Lhs -> Expr -> Set String -> Set String -> Decl
-mkDecl True  lhs rhs _ _   = Bind lhs rhs
-mkDecl False lhs rhs s1 s2 = Decl lhs rhs s1 s2
-
-unwrapSem :: Bool -> NontermIdent -> Expr -> Expr
-unwrapSem False _ e = e
-unwrapSem True nm e = Case e alts
-  where alts  = [CaseAlt left right]
-        left  = Fun (typeName nm 0) [SimpleExpr "x"]
-        right = SimpleExpr "x"
-}
-
-ATTR Sequence CRule [ children : {[(Identifier,Type,ChildKind)]} ||]
-
-ATTR Sequence CRule Pattern Patterns [|| definedInsts USE {++} {[]} : {[Identifier]} ]
-SEM Pattern
-  | Alias lhs.definedInsts = (if @field == _INST then [@attr] else []) ++ @pat.definedInsts
-
-SEM CRule
-  | CRule  loc.definedInsts = if @isIn then [] else @pattern.definedInsts
-
-ATTR Pattern Patterns [ | | patternAttributes USE {++} {[]} : {[(Identifier, Identifier)]} ]
-SEM Pattern
-  | Alias
-      lhs.patternAttributes = (@field,@attr) : @pat.patternAttributes
-
--------------------------------------------------------------------------------
--- Numbering the visits
--------------------------------------------------------------------------------
-
-ATTR  CVisits CVisit Sequence CRule
-      CSegments CSegment [ nr : Int | | ]
-SEM  CProduction
-  |  CProduction visits.nr = 0
-SEM  CVisits
-  |  Cons tl.nr = @lhs.nr + 1
-SEM  CInterface
-  |  CInterface seg.nr = 0
-SEM  CSegments
-  |  Cons tl.nr = @lhs.nr + 1
-
--------------------------------------------------------------------------------
--- Checking last visit
--------------------------------------------------------------------------------
-
-ATTR CVisit CSegment [ isLast : Bool | | ]
-ATTR CVisits CSegments [ | | isNil : Bool ]
-SEM  CVisits
-  |  Cons  lhs.isNil = False
-           hd.isLast = @tl.isNil
-  |  Nil lhs.isNil = True
-SEM  CSegments
-  |  Cons  lhs.isNil = False
-           hd.isLast = @tl.isNil
-  |  Nil lhs.isNil = True
-
--------------------------------------------------------------------------------
--- Getting the next intra-visit dependencies
--------------------------------------------------------------------------------
-
-ATTR CVisit [ nextIntra : {Exprs} nextIntraVars : {Set String} | | ]
-ATTR CVisits CVisit [ | | intra : {Exprs} intraVars : {Set String} ]
-SEM  CVisit
-  |  CVisit lhs.intra = @intra.exprs
-            lhs.intraVars = @intra.usedVars
-SEM  CVisits
-  |  Cons  hd.nextIntra = @tl.intra
-           hd.nextIntraVars = @tl.intraVars
-           lhs.intra = @hd.intra
-           lhs.intraVars = @hd.intraVars
-  |  Nil lhs.intra = []
-         lhs.intraVars = Set.empty
-
--------------------------------------------------------------------------------
--- Superfluous intra-visit dependencies due to higher-order children
---  (higher-order children can only be passed from their moment of creation)
--------------------------------------------------------------------------------
-
-SEM CRule
-  | CChildVisit
-      loc.isSuperfluousHigherOrderIntra
-        = @lhs.nr <= Map.findWithDefault (-1) @name @lhs.instVisitNrs
-
--------------------------------------------------------------------------------
--- Intra-visit dependencies are expressions that need to be passed
--------------------------------------------------------------------------------
-
-ATTR  Sequence CRule [ | | exprs USE {++} {[]} : {Exprs} ]
-SEM  CRule
-  |  CRule loc.rulename = if  @field == _LOC && @name `elem` @lhs.terminals
-                          then funname @name 0
-                          else attrname @lhs.options @isIn @field @name
-           lhs.exprs = [SimpleExpr @loc.rulename]
-  |  CChildVisit
-       loc.names = -- do not pass inst-childs as parameter if they are not defined yet
-                   if @loc.isSuperfluousHigherOrderIntra
-                   then []
-                   else [funname @name (@nr+1)]
-       lhs.exprs = let wrap = if @lhs.o_newtypes then \x -> App (typeName @nt (@nr + 1)) [x] else id
-
-                       addType expr | null @loc.instParams = expr
-                                    | otherwise            = TypedExpr expr (@lhs.unfoldSemDom @nt (@nr+1) @loc.instParams)
-
-                   in map (wrap . addType . SimpleExpr) @loc.names
-
-ATTR  Sequence CRule [ | | usedVars USE {`Set.union`} {Set.empty} : {Set String} ]
-SEM CRule
-  | CRule
-      lhs.usedVars = Set.singleton @loc.rulename
-  | CChildVisit
-      lhs.usedVars = Set.fromList @loc.names
-
--------------------------------------------------------------------------------
--- Type signatures are added to the declarations.
--------------------------------------------------------------------------------
-
-ATTR Sequence CRule [ | | tSigs USE {++} {[]} : {[Decl]} ]
-SEM  CRule
-  |  CRule        loc.mkTp = typeToCodeType (Just @lhs.nt) @loc.orgParams
-                  lhs.tSigs = [ TSig (attrname @lhs.options False field attr) tp'
-                              |  (field,attr,tp) <- Map.elems @defines, isJust tp
-                              , let tp1 = @loc.evalTp field $ @mkTp (fromJust tp)
-                                    tp' = case findOrigType attr @lhs.children of
-                                           Just tp' -> let tp'' = case tp' of
-                                                                    NT n params b -> NT (Ident ("T_" ++ show n) (getPos n)) params b
-                                                                    _ -> tp'
-                                                           tp2 = @loc.evalTp field $ @mkTp tp''
-                                                       in Arr tp2 tp1
-                                           Nothing -> tp1
-                                    findOrigType _ [] = Nothing
-                                    findOrigType nm ((n,_,kind) : r)
-                                      | nm == n = case kind of
-                                                    ChildReplace orig -> Just orig
-                                                    _                 -> Nothing
-                                      | otherwise = findOrigType nm r
-                              ]
-
-                  loc.orgParams = map getName $ Map.findWithDefault [] @lhs.nt @lhs.paramMap
-                  loc.evalTp =
-                    \field tp -> let orgFldParams = map getName $ Map.findWithDefault [] childNt @lhs.paramMap
-                                     (childNt,instParams) = Map.findWithDefault (@lhs.nt,[]) field @lhs.paramInstMap
-                                     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 @lhs.options tp
-                                    else evalType @lhs.options replace tp
-
-  |  CChildVisit  loc.mkTp = @loc.evalTp . typeToCodeType (Just @nt) @loc.orgParams
-                  loc.definedTps = [ TSig (attrname @lhs.options True @name a) (@mkTp tp) |  (a,tp) <- Map.toList @syn ]
-                  loc.nextTp = typeName @nt (@nr+1)
-                  lhs.tSigs = (if @isLast then id else (TSig (funname @name (@nr+1)) (TypeApp (SimpleType @nextTp) (map SimpleType @loc.instParams)) :)) @definedTps
-
-                  loc.orgParams = map getName $ Map.findWithDefault [] @nt @lhs.paramMap
-                  loc.instParams = snd $ Map.findWithDefault (@nt,[]) @name @lhs.paramInstMap
-                  loc.replParamMap = Map.fromList (zip @loc.orgParams @loc.instParams)
-                  loc.replace = \k -> Map.findWithDefault k k @loc.replParamMap
-                  loc.evalTp = if null @loc.orgParams then id else evalType @lhs.options @loc.replace
-
-
--------------------------------------------------------------------------------
--- Types of intra-visit dependencies are needed in the type of the
--- semantic function.
--------------------------------------------------------------------------------
-
-ATTR CVisits CVisit [ children : {[(Identifier,Type, ChildKind)]} | | ]
-SEM  CProduction
-  |  CProduction visits.children = @children
-
-
-ATTR Sequence CRule [ | | tps USE {++} {[]} : {[Type]}
-                          allTpsFound USE {&&} {True} : Bool ]
-SEM  CRule
-  |  CRule        lhs.(tps,allTpsFound) = maybe ([],False) (\tp -> ([tp],True)) @tp
-  |  CChildVisit  lhs.tps = if @loc.isSuperfluousHigherOrderIntra
-                            then []
-                            else [NT (ntOfVisit @nt (@nr+1)) @loc.instParams False]
-
--------------------------------------------------------------------------------
--- Each visit has its semantic function
--------------------------------------------------------------------------------
-
-ATTR CVisits [ | | decls : {Decls} ]
-ATTR CVisit [ | decls : {Decls} | ]
-SEM CVisits
-  | Nil   lhs.decls = []
-  | Cons  lhs.decls = @hd.decls
-          hd.decls  = @tl.decls
-
--- Note: lhs.decls are the decls related to the next visit function. We pass it
--- chained from right to left in order to build the next visit function inside
--- the previous one.
--- Note: intra decls are ignored. The intra-visit variables are not passed on
--- explicitly, but handled automatically due to nesting level.
-
-SEM  CVisit
-  |  CVisit (loc.higherOrderChildren,loc.firstOrderChildren) = partition (\(_,_,virt) -> isHigherOrder virt) @lhs.children
-            loc.firstOrderOrig = map pickOrigType @loc.firstOrderChildren
-            loc.funcname = seqSemname @lhs.prefix @lhs.nt @lhs.con @lhs.nr
-            loc.nextVisitName = if @lhs.isLast then [] else [visitname @lhs.prefix @lhs.nt (@lhs.nr+1)]
-            loc.nextVisitDecl = let  lhs = TupleLhs @nextVisitName
-                                     -- rhs = App fun @lhs.nextIntra
-                                     rhs = Let @lhs.decls (SimpleExpr fun)
-                                     fun = seqSemname @lhs.prefix @lhs.nt @lhs.con (@lhs.nr+1)
-                                in if @lhs.isLast
-                                   then []
-                                   else [Decl lhs rhs (Set.fromList @nextVisitName) @lhs.nextIntraVars]
-            loc.isOneVisit  = @lhs.isLast && @lhs.nr == 0
-            loc.hasWrappers = @lhs.nt `Set.member` @lhs.wrappers
-            loc.refDecls = if @loc.isOneVisit && @loc.hasWrappers && reference @lhs.options
-                           then let synAttrs = Map.toList @syn
-                                    synNT = "Syn" ++ "_" ++ getName @lhs.nt
-                                    synVars = [ SimpleExpr (attrname @lhs.options False _LHS a) | (a,_) <- synAttrs ]
-                                    rhs = App synNT synVars
-                                    lhs = Fun "___node" []
-                                in [Decl lhs rhs Set.empty Set.empty]
-                           else []
-            loc.decls = if @lhs.o_clean
-                          then @vss.decls ++ @nextVisitDecl ++ @loc.refDecls -- Don't generate type signatures for Clean, they will cause the compiler to generate functions, even for constants
-                          else @typeSigs ++ @vss.decls ++ @nextVisitDecl ++ @loc.refDecls
-            vss.lastExpr = mkTupleExpr @lhs.o_unbox (null $ Map.keys @inh) $ map (SimpleExpr . lhsname @lhs.options False) (Map.keys @syn) ++ map SimpleExpr @nextVisitName
-            intra.lastExpr = error "lastExpr: not used here"
-            loc.lastExprVars = map (lhsname @lhs.options False) (Map.keys @syn) ++ @loc.nextVisitName
-            (loc.blockFunDecls, loc.blockFirstFunCall) = mkPartitionedFunction @loc.funcname @loc.o_case @loc.nextVisitDecl @loc.lastExprVars @vss.blockDecls
-
-            loc.costCentreDescr = "b" ++ ":" ++ show @lhs.nt ++ ":" ++ show @lhs.con ++ ":" ++ show @lhs.nr
-            loc.addCostCentre = \v -> if @lhs.o_costcentre
-                                      then PragmaExpr True False ("SCC \"" ++ @loc.costCentreDescr ++ "\"") v
-                                      else v
-
-            loc.params = map getName $ Map.findWithDefault [] @lhs.nt @lhs.paramMap
-            loc.semFun = let  lhs = Fun @funcname lhs_args
-                              lhs_args = if @lhs.nr == 0 then map field @loc.firstOrderOrig else [] -- @intra.exprs
-
-                              field (name,NT tp tps _,_) = let unwrap | @lhs.o_newtypes = \x -> App (sdtype tp) [x]
-                                                                      | otherwise       = id
-
-                                                               addType expr | null tps  = expr
-                                                                            | otherwise = TypedExpr expr (@lhs.unfoldSemDom tp 0 tps)
-
-                                                           in unwrap $ addType $ SimpleExpr $ funname name 0
-                              field (name,tp,_)        = let expr = SimpleExpr (funname name 0)
-                                                         in if null @loc.params
-                                                            then expr
-                                                            else TypedExpr expr (idEvalType @lhs.options $ typeToCodeType (Just @lhs.nt) @loc.params $ removeDeforested tp)
-
-                              mbEvalTp | null @loc.params = const Nothing
-                                       | otherwise        = Just . (idEvalType @lhs.options)
-
-                              rhs = wrap
-                                  . mkSemFun @lhs.nt @lhs.nr [mkLambdaArg (lhsname @lhs.options True nm) (mbEvalTp $ typeToCodeType (Just @lhs.nt) @loc.params $ removeDeforested tp) | (nm,tp) <- Map.assocs @inh]
-                                  $ @loc.addCostCentre
-                                  $ if @ordered && @loc.o_splitsems
-                                    then @loc.blockFirstFunCall
-                                    else mkDecls @loc.declsType @decls
-                                         . ResultExpr (typeName @lhs.nt @lhs.nr)
-                                         . mkTupleExpr @lhs.o_unbox (null $ Map.keys @inh)
-                                         $ map (SimpleExpr . lhsname @lhs.options False) (Map.keys @syn) ++ map SimpleExpr @nextVisitName
-                              wrap = if  @lhs.o_newtypes
-                                         then \x -> App (typeName @lhs.nt @lhs.nr) [x]
-                                         else id
-                         in Decl lhs rhs Set.empty Set.empty
-            loc.tsig = TSig @funcname @semType
-            loc.semType = let argType (NT tp tps _)  r | tp /= _SELF = typeAppStrs (sdtype tp) tps `Arr` r
-                                                       | tp == _SELF = error "GenerateCode: found an intra-type with type SELF, which should have been prevented by CRule.tps"
-                              argType (Haskell tp) r                 = SimpleType tp          `Arr` r
-                              argType _ _ = error "Self type not allowed here"
-                              evalTp | null @loc.params = id
-                                     | otherwise        = idEvalType @lhs.options
-
-                          in appQuant @lhs.quantMap @lhs.nt $ appContext @lhs.contextMap @lhs.nt $ evalTp $
-                             if  @lhs.nr == 0
-                                 then foldr argType (typeAppStrs (sdtype   @lhs.nt        ) @loc.params) (map (\(_,t,_) -> t) @loc.firstOrderOrig)
-                                 else foldr argType (typeAppStrs (typeName @lhs.nt @lhs.nr) @loc.params) [] -- @intra.tps
-            lhs.decls =  ( if  @lhs.with_sig
-                           then [@tsig, @semFun]
-                           else [@semFun]
-                         ) ++
-                         ( if @ordered && @loc.o_splitsems
-                           then @loc.blockFunDecls
-                           else []
-                         )
-            loc.typeSigs =  if  @lhs.o_sig && not @o_case
-                                then  @vss.tSigs
-                                else  []
-            loc.o_do   = @ordered && @lhs.o_monadic
-            loc.o_case = not @loc.o_do && @lhs.o_case && @ordered && not (hasPragma @lhs.allPragmas @lhs.nt @lhs.con _NOCASE)
-            loc.declsType = if @loc.o_do
-                            then DeclsDo
-                            else if @loc.o_case
-                                 then DeclsCase
-                                 else DeclsLet
-            loc.o_splitsems = @ordered && @lhs.o_splitsems
-
-{
-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
-
-mkSemFun :: Identifier -> Int -> Exprs -> Expr -> Expr
-mkSemFun nt nr xs e = SemFun (typeName nt nr) xs e
-
-typeAppStrs :: String -> [String] -> Code.Type
-typeAppStrs nm params = TypeApp (SimpleType nm) (map SimpleType params)
-
-isHigherOrder :: ChildKind -> Bool
-isHigherOrder ChildAttr = True
-isHigherOrder _         = False
-
-pickOrigType :: (Identifier, Type, ChildKind) -> (Identifier, Type, ChildKind)
-pickOrigType (nm, _, virt@(ChildReplace x)) = (nm, x, virt)
-pickOrigType x = x
-}
-
-ATTR CVisits CVisit Sequence CRule [ instVisitNrs : {Map Identifier Int} || ]
-ATTR CVisits CVisit [|| gatherInstVisitNrs USE {`Map.union`} {Map.empty} : {Map Identifier Int} ]
-SEM CProduction
-  | CProduction
-      visits.instVisitNrs = @visits.gatherInstVisitNrs
-
-SEM CVisit
-  | CVisit
-      lhs.gatherInstVisitNrs = Map.fromList [(i,@lhs.nr) | i <- @vss.definedInsts]
-
--------------------------------------------------------------------------------
--- Push aroundsMap downward
--------------------------------------------------------------------------------
-
-ATTR CNonterminals CNonterminal
-  [ aroundMap : {Map NontermIdent (Map ConstructorIdent (Set Identifier))} || ]
-
-ATTR CProductions CProduction
-  [ aroundMap : {Map ConstructorIdent (Set Identifier)} || ]
-
-ATTR CVisits CVisit Sequence CRule [ aroundMap : {Set Identifier} | | ]
-
-SEM CGrammar | CGrammar          loc.aroundMap = @aroundsMap
-SEM CNonterminal | CNonterminal  loc.aroundMap = Map.findWithDefault Map.empty @nt @lhs.aroundMap
-SEM CProduction | CProduction    loc.aroundMap = Map.findWithDefault Set.empty @con @lhs.aroundMap
-
--------------------------------------------------------------------------------
--- Push mergeMap downward
--------------------------------------------------------------------------------
-
-ATTR CNonterminals CNonterminal
-  [ mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier])))} || ]
-
-ATTR CProductions CProduction
-  [ mergeMap : {Map ConstructorIdent (Map Identifier (Identifier, [Identifier]))} || ]
-
-ATTR CVisits CVisit Sequence CRule [ mergeMap : {Map Identifier (Identifier, [Identifier])} | | ]
-
-SEM CGrammar | CGrammar          loc.mergeMap = @mergeMap
-SEM CNonterminal | CNonterminal  loc.mergeMap = Map.findWithDefault Map.empty @nt @lhs.mergeMap
-SEM CProduction | CProduction    loc.mergeMap = Map.findWithDefault Map.empty @con @lhs.mergeMap
-
--------------------------------------------------------------------------------
--- Generate a partitioned version of the sequence of rules
--------------------------------------------------------------------------------
-
-ATTR Sequence [ lastExpr : Expr | | blockDecls : DeclBlocks ]
-
-ATTR Sequence CRule [ | declsAbove : {[Decl]}  | ]
-SEM CVisit
-  | CVisit
-      vss.declsAbove = []
-      intra.declsAbove = error "declsAbove: not used here"
-
-SEM CRule
-  | CRule
-      lhs.declsAbove = @lhs.declsAbove ++ @loc.decls
-  | CChildVisit
-      lhs.declsAbove = []
-
-SEM Sequence
-  | Cons
-      lhs.blockDecls = @hd.bldBlocksFun @tl.blockDecls
-  | Nil
-      lhs.blockDecls = DeclTerminator @lhs.declsAbove @lhs.lastExpr
-
-ATTR CRule [ | | bldBlocksFun : {DeclBlocks -> DeclBlocks} ]
-SEM CRule
-  | CRule
-      lhs.bldBlocksFun = id
-  | CChildVisit
-      lhs.bldBlocksFun = DeclBlock @lhs.declsAbove (head @loc.decls)
-
-{
-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)
-}
-
-WRAPPER DeclBlocksRoot
-
-ATTR DeclBlocksRoot DeclBlocks [ prefix : String optCase : Bool nextVisitDecls : {[Decl]} lastExprVars : {[String]} | | ]
-ATTR DeclBlocksRoot [ | | lambdas : {[Decl]} firstCall : Expr ]
-
-SEM DeclBlocksRoot
-  | DeclBlocksRoot
-      lhs.lambdas  = @blocks.decls
-      lhs.firstCall = @blocks.callExpr
-
-ATTR DeclBlocks [ blockNr : Int | | ]
-SEM DeclBlocksRoot
-  | DeclBlocksRoot
-      blocks.blockNr = 1
-SEM DeclBlocks
-  | DeclBlock
-      next.blockNr = @lhs.blockNr + 1
-
-ATTR DeclBlocks [ | | callExpr : Expr freeVars : {[String]} ]
-SEM DeclBlocks
-  | DeclBlock DeclTerminator
-      loc.lambdaName = @lhs.prefix ++ "_block" ++ show @lhs.blockNr
-      loc.pragmaDecl = PragmaDecl ("NOINLINE " ++ @loc.lambdaName)
-      lhs.callExpr = App @loc.lambdaName (map SimpleExpr @loc.freeVars)
-  | DeclTerminator
-      loc.freeVars = freevars @lhs.lastExprVars (@defs ++ @lhs.nextVisitDecls)
-  | DeclBlock
-      loc.freeVars = freevars @next.freeVars (@visit : @defs)
-
-ATTR DeclBlocks [ | | decls : {[Decl]} ]
-SEM DeclBlocks
-  | DeclTerminator
-      lhs.decls = [ mkBlockLambda @lhs.optCase @loc.lambdaName @loc.freeVars (@defs ++ @lhs.nextVisitDecls) @result ]
-  | DeclBlock
-      loc.decl = mkBlockLambda @lhs.optCase @loc.lambdaName @loc.freeVars (@defs ++ [@visit]) @next.callExpr
-      lhs.decls = (if @lhs.blockNr > 1 then [@loc.pragmaDecl] else []) ++ [@loc.decl] ++ @next.decls
-
-{
-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
-}
-
-
--------------------------------------------------------------------------------
--- The semantic domain is generated from the interface.
--------------------------------------------------------------------------------
-
-ATTR  CInterface CSegments CSegment [ | | semDom USE {++} {[]} : {[Decl]} ]
-SEM  CInterface
-  |  CInterface  lhs.semDom = Comment "semantic domain" : @seg.semDom
-
-SEM  CSegment
-  |  CSegment loc.altSemForm = breadthFirst @lhs.options
-              loc.tp = if @loc.altSemForm
-                       then TypeApp (SimpleType "Child") [SimpleType "EvalInfo", @loc.indexExpr ]
-                       else foldr Arr @loc.synTps @loc.inhTps
-              loc.inhTps = [typeToCodeType (Just @lhs.nt) @loc.params tp |  tp <- Map.elems @inh]
-              loc.inhTup = mkTupleType @lhs.o_unbox (null @loc.inhTps) @loc.inhTps
-              loc.synTps = mkTupleType @lhs.o_unbox (null @loc.inhTps) ([typeToCodeType (Just @lhs.nt) @loc.params tp |  tp <- Map.elems @syn] ++ @loc.continuation)
-              loc.curTypeName  = typeName @lhs.nt @lhs.nr
-              loc.nextTypeName = typeName @lhs.nt (@lhs.nr + 1)
-              loc.indexName    = "I_" ++ @loc.curTypeName
-              loc.dataIndex = Code.Data @loc.indexName @loc.params [DataAlt @loc.indexName []] False []
-              loc.indexExpr = TypeApp (SimpleType @loc.indexName) (map (SimpleType . ('@':)) @loc.params)
-              loc.indexStr  = "(" ++ @loc.indexName ++ concatMap (\p -> " " ++ p) @loc.params ++ ")"
-              loc.inhInstance = Code.Data "instance Inh" [@loc.indexStr] [DataAlt (typeName @lhs.nt @lhs.nr ++ "_Inh") [@loc.inhTup] ] False []
-              loc.synInstance = Code.Data "instance Syn" [@loc.indexStr] [DataAlt (typeName @lhs.nt @lhs.nr ++ "_Syn") [@loc.synTps] ] False []
-              loc.continuation = if  @lhs.isLast
-                                 then []
-                                 else [TypeApp (SimpleType @loc.nextTypeName) (map (SimpleType . ('@':)) @loc.params)]
-              loc.params = map getName $ Map.findWithDefault [] @lhs.nt @lhs.paramMap
-              lhs.semDom = let name = typeName @lhs.nt @lhs.nr
-                               evalTp | null @loc.params = id
-                                      | otherwise        = idEvalType @lhs.options
-                           in ( if @lhs.o_newtypes
-                                then [ Code.NewType name @loc.params name (evalTp @loc.tp) ]
-                                else [ Code.Type name @loc.params (evalTp @loc.tp) ] )
-                              ++ ( if @loc.altSemForm
-                                   then [@loc.dataIndex, @loc.inhInstance, @loc.synInstance]
-                                   else [] )
-
-ATTR CNonterminals CNonterminal CInterface CSegments CSegment [ | | semDomUnfoldGath USE {`Map.union`} {Map.empty} : {Map (NontermIdent, Int) ([String], Code.Type)} ]
-
-SEM CSegment
-  | CSegment
-      lhs.semDomUnfoldGath = Map.singleton (@lhs.nt, @lhs.nr) (@loc.params, @loc.tp)
-
-ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit Sequence CRule [ unfoldSemDom : {NontermIdent -> Int -> [String] -> Code.Type} | | ]
-
-SEM CGrammar
-  | CGrammar
-      loc.unfoldSemDom =
-       \nt nr repl ->
-        let (params, tp) = Map.findWithDefault (error ("No such semantic domain: " ++ show nt)) (nt, nr) @nonts.semDomUnfoldGath
-            replMap = Map.fromList (zip params repl)
-            replace k = Map.findWithDefault ('@':k) k replMap
-        in evalType @lhs.options replace tp
-
-{
-typeToCodeType :: Maybe NontermIdent -> [String] -> Type -> Code.Type
-typeToCodeType _ _ tp
-  = case tp of
-      NT nt tps defor -> NontermType (getName nt) tps defor
-      Haskell t       -> SimpleType t
-      Self            -> error "Self type not allowed here."
-
-evalType :: Options -> (String -> String) -> Code.Type -> Code.Type
-evalType opts 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 opts (initPos txt) txt
-                                      tks' = map replaceTok tks
-                                      txt' = unlines . showTokens . tokensToStrings $ tks'
-                                  in SimpleType txt'
-          TMaybe m             -> TMaybe (chase m)
-          TEither l r          -> TEither (chase l) (chase r)
-          TMap k v             -> TMap (chase k) (chase v)
-          TIntMap v            -> TIntMap (chase v)
-          TSet m               -> TSet (chase m)
-          _                    -> t
-
-    replaceTok t
-      = case t of
-          AGLocal v p _ -> HsToken (replf $ getName v) p
-          _             -> t
-
-idEvalType :: Options -> Code.Type -> Code.Type
-idEvalType options = evalType options id
-}
-
--------------------------------------------------------------------------------
--- Wrapper functions
--------------------------------------------------------------------------------
-
-SEM CNonterminal
-  | CNonterminal loc.semWrapper = let params' = map getName @params
-                                      inhAttrs = Map.toList @inh
-                                      synAttrs = Map.toList @syn
-                                      inhVars = [ SimpleExpr (attrname @lhs.options True _LHS a) | (a,_) <- inhAttrs ]
-                                      synVars = [ SimpleExpr (attrname @lhs.options False _LHS a) | (a,_) <- synAttrs ]
-                                      var = "sem"
-                                      wrapNT = "wrap" ++ "_" ++ getName @nt
-                                      inhNT = "Inh" ++ "_" ++ getName @nt
-                                      synNT = "Syn" ++ "_" ++ getName @nt
-                                      varPat = if  @lhs.o_newtypes
-                                                   then App (sdtype @nt) [SimpleExpr var]
-                                                   else SimpleExpr var
-
-                                      evalTp | null params' = id
-                                             | otherwise    = idEvalType @lhs.options
-                                      appParams nm = TypeApp (SimpleType nm) (map SimpleType params')
-                                      typeSig = TSig wrapNT (evalTp $ appParams (sdtype @nt) `Arr` (appParams inhNT `Arr` appParams synNT))
-                                      mkstrict = Named @lhs.o_strictwrap
-                                      mkdata n attrs = Data n params' [Record n [mkstrict (getName f++"_"++n) $ evalTp $ typeToCodeType (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 @inter.wrapDecls (App synNT synVars))
-                                                    Set.empty Set.empty
-                                              ]
-
-ATTR CInterface CSegments CSegment [ | | wrapDecls USE {++} {[]}: {Decls} ]
-SEM  CSegment
-  |  CSegment lhs.wrapDecls =  let lhsVars = map (lhsname @lhs.options False) (Map.keys @syn)
-                                             ++ if @lhs.isLast then [] else [unwrap ++ sem (@lhs.nr+1)]
-                                   rhsVars = map (lhsname @lhs.options True) (Map.keys @inh)
-                                   rhs = map SimpleExpr rhsVars
-                                   unwrap = if @lhs.o_newtypes then typeName @lhs.nt (@lhs.nr + 1) ++ " " else ""
-                                   var   = "sem"
-                                   sem 0 = var
-                                   sem n = var ++ "_" ++ show n
-                                   ntt   = typeName @lhs.nt @lhs.nr
-                               in [ EvalDecl ntt (mkTupleLhs @lhs.o_unbox (null $ Map.keys @inh) lhsVars) (InvokeExpr ntt (SimpleExpr $ sem @lhs.nr) rhs) ]
-                                  -- [ Decl (mkTupleLhs @lhs.o_unbox (null $ Map.keys @inh) lhsVars) (App (sem @lhs.nr) rhs) (Set.fromList lhsVars) (Set.fromList rhsVars) ]
-
--------------------------------------------------------------------------------
--- Errors for missing type signatures. It's an error when one of the
--- attributes in the intra-visit dependencies does not have a type.
--- UPDATE: it is not an error anymore...
--------------------------------------------------------------------------------
-
-ATTR CNonterminals CNonterminal
-     CProductions CProduction
-     CVisits CVisit [ with_sig : Bool | | ]
-
-SEM CGrammar
-  | CGrammar nonts.with_sig = typeSigs @lhs.options
-
-SEM  CGrammar [ | | errors : {Seq Error} ]
-  |  CGrammar lhs.errors = Seq.empty
-
--------------------------------------------------------------------------------
--- Provide a description of the interfaces as comments
--------------------------------------------------------------------------------
-
-SEM CNonterminal
-  | CNonterminal loc.comment = Comment . unlines . map ind $ ( @inter.comments ++ ("alternatives:" : map ind @prods.comments) )
-
-ATTR CInterface CSegments CSegment
-     CProductions CProduction
-     CVisits CVisit Sequence CRule  [ | | comments USE {++} {[]}: {[String]} ]
-
-ATTR Sequence CRule [ what:String | | ]
-
-SEM CSegment
-  | CSegment     lhs.comments =  let body = map ind (showsSegment (CSegment @inh @syn))
-                                 in if null body
-                                    then []
-                                    else ("visit " ++ show @lhs.nr ++ ":") : body
-
-SEM CProduction
-  | CProduction  loc.firstOrderChildren = [ (nm,fromJust mb,virt) | (nm,tp,virt) <- @children, let mb = isFirstOrder virt tp, isJust mb ]
-                 lhs.comments =  ("alternative " ++ getName @con ++ ":")
-                                 : map ind (  map (\(x,y,_) -> makeLocalComment 14 "child" x (Just y)) @loc.firstOrderChildren
-                                           ++ @visits.comments
-                                           )
-
-{
--- for a virtual child that already existed as a child, returns
-isFirstOrder :: ChildKind -> Type -> Maybe Type
-isFirstOrder ChildSyntax       tp = Just tp
-isFirstOrder ChildAttr         _  = Nothing
-isFirstOrder (ChildReplace tp) _  = Just tp
-}
-
-SEM CVisit
-  | CVisit       lhs.comments =  let body = map ind (@vss.comments ++ @intra.comments)
-                                 in if null body
-                                    then []
-                                    else ("visit " ++ show @lhs.nr ++ ":") : body
-                 vss.what     = "local"
-                 intra.what   = "intra"
-
-
-SEM CRule
-  | CRule        lhs.comments =  [ makeLocalComment 11 @lhs.what name tp | (field,name,tp) <- Map.elems @defines, field == _LOC ]
-                                 ++ [ makeLocalComment 11 "inst " name tp | (field,name,tp) <- Map.elems @defines, field == _INST ]
-
-{
-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' ++ "}"
-                                                                   Self -> error "Self type not allowed here.") tp
-                                       in   ( what ++ " " ++ x ++ replicate ((width - length x) `max` 0) ' ' ++ " : " ++ y )
-
-}
-
--------------------------------------------------------------------------------
--- And tie it all together
--------------------------------------------------------------------------------
-
-ATTR CNonterminals CNonterminal    [ | | chunks USE {++} {[]} : {Chunks} ]
-ATTR CProductions CProduction  [ | | decls USE {++} {[]} : {Decls} ]
-ATTR CGrammar [ | | output : Program ]
-
-SEM CGrammar
-  | CGrammar    lhs.output = Program @nonts.chunks @multivisit
-
-SEM CNonterminal
-  | CNonterminal  lhs.chunks = [ Chunk (getName @nt)
-                                      (Comment (getName @nt ++ " " ++ replicate (60 - length (getName @nt)) '-'))
-                                      (if @lhs.o_pretty                  then [@loc.comment]   else [])
-                                      (if isJust @lhs.o_data             then [@loc.dataDef]   else [])
-                                      (if @lhs.o_cata && @loc.genCata    then  @loc.cataFun    else [])
-                                      (if @lhs.o_sig                     then  @inter.semDom   else [])
-                                      (if @nt `Set.member` @lhs.wrappers then  @loc.semWrapper else [])
-                                      (if @lhs.o_sem                     then  @prods.decls     else [])
-                                      (if @lhs.o_sem                     then  @prods.semNames  else [])
-                               ]
-
-{
--- Lets or nested Cases?
--- or even a do-expression?
-
-data DeclsType = DeclsLet | DeclsCase | DeclsDo
-
-mkDecls :: DeclsType -> Decls -> Expr -> Expr
-mkDecls DeclsLet  = mkLet False
-mkDecls DeclsCase = mkLet True
-mkDecls DeclsDo   = \decls -> Do (map toBind decls)
-  where toBind (Decl lhs rhs _ _) = BindLet lhs rhs
-        toBind d                  = d
-
-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 _ _)      ex = Case rhs [CaseAlt left ex]
-oneCase (Resume _ nt left rhs)   ex = ResumeExpr nt rhs left ex
-oneCase _                        ex = ex
-
--- Gives the name of the visit function
-funname :: Show a => a -> Int -> String
-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
-
-ntOfVisit :: NontermIdent -> Int -> NontermIdent
-ntOfVisit nt 0 = nt
-ntOfVisit nt n = Ident (show nt ++ "_" ++ show n) (getPos nt)
-
--- Gives the name of a visit function
-visitname  ::  String -> NontermIdent -> Int -> String
-visitname pre nt n =  pre ++ getName nt ++ "_" ++ show n
-}
-
--------------------------------------------------------------------------------
--- Datatypes were already present
--------------------------------------------------------------------------------
-
-ATTR CNonterminals CNonterminal [ derivings: {Derivings} typeSyns : {TypeSyns} | | ]
-ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit [ wrappers:{Set NontermIdent} | | ]
-
-SEM CGrammar
-  | CGrammar nonts . typeSyns  = @typeSyns
-                   . derivings = @derivings
-                   . wrappers  = @wrappers
-
-SEM CNonterminal
-  | CNonterminal loc.dataDef = let params' = map getName @params
-                                   typeSyn tp = let theType =
-                                                      case tp of
-                                                        CommonTypes.Maybe t      -> TMaybe $ typeToCodeType (Just @nt) params' t
-                                                        CommonTypes.Either t1 t2 -> TEither (typeToCodeType (Just @nt) params' t1) (typeToCodeType (Just @nt) params' t2)
-                                                        CommonTypes.Map t1 t2    -> TMap (typeToCodeType (Just @nt) params' t1) (typeToCodeType (Just @nt) params' t2)
-                                                        CommonTypes.IntMap t     -> TIntMap $ typeToCodeType (Just @nt) params' t
-                                                        CommonTypes.List t       -> Code.List $ typeToCodeType (Just @nt) params' t
-                                                        CommonTypes.Tuple ts     -> Code.TupleType [typeToCodeType (Just @nt) params' t | (_,t) <- ts ]
-                                                        CommonTypes.OrdSet t     -> TSet $ typeToCodeType (Just @nt) params' t
-                                                        CommonTypes.IntSet       -> TIntSet
-                                                 in Code.Type (getName @nt) params' (idEvalType @lhs.options theType)
-                                   derivings  = maybe [] (map getName . Set.toList) (Map.lookup @nt @lhs.derivings)
-                                   dataDef    = Data (getName @nt) (map getName @params) @prods.dataAlts (maybe False id @lhs.o_data) derivings
-                               in maybe dataDef typeSyn $ lookup @nt @lhs.typeSyns
-
-ATTR CProductions     [ | | dataAlts : {DataAlts} ]
-ATTR CProduction      [ | | dataAlt  : {DataAlt}  ]
-
-SEM CProductions
-  | Cons        lhs.dataAlts  = @hd.dataAlt : @tl.dataAlts
-  | Nil         lhs.dataAlts  = []
-
-SEM CProduction
-  | CProduction loc.params  = map getName $ Map.findWithDefault [] @lhs.nt @lhs.paramMap
-                lhs.dataAlt = let conNm = conname @lhs.o_rename @lhs.nt @con
-                                  mkFields :: (NontermIdent -> ConstructorIdent -> Identifier -> Code.Type -> a) -> [a]
-                                  mkFields f = map (\(nm,t,_) -> f @lhs.nt @con nm (typeToCodeType (Just @lhs.nt) @loc.params $ removeDeforested t)) @loc.firstOrderChildren
-                              in if dataRecords @lhs.options
-                                 then Record conNm $ mkFields $ toNamedType (strictData @lhs.options)
-                                 else DataAlt conNm $ mkFields $ \_ _ _ t -> t
-
-{
-toNamedType :: Bool -> NontermIdent -> ConstructorIdent -> Identifier -> Code.Type -> Code.NamedType
-toNamedType genStrict nt con nm tp
-  = Code.Named genStrict strNm tp
-  where strNm = recordFieldname nt con nm
-}
-
--------------------------------------------------------------------------------
--- Catamorphism were already present
--------------------------------------------------------------------------------
-
-SEM CNonterminal
-  | CNonterminal loc.genCata = not (@nt `Set.member` nocatas @lhs.options)
-                 loc.cataFun = let appParams nm = TypeApp (SimpleType nm) (map SimpleType (map getName @params))
-                                   evalTp | null @params = id
-                                          | otherwise    = idEvalType @lhs.options
-                                   tSig = TSig (cataname @lhs.prefix @nt)
-                                               (appQuant @lhs.quantMap @nt $ appContext @lhs.contextMap @nt $ evalTp $ appParams (getName @nt) `Arr` appParams (sdtype @nt))
-                                   special typ = case typ of
-                                                 CommonTypes.List tp ->
-                                                     let cons = SimpleExpr (semname @lhs.prefix @nt (identifier "Cons"))
-                                                         nil  = SimpleExpr (semname @lhs.prefix @nt (identifier "Nil" ))
-                                                         arg  = SimpleExpr "list"
-                                                         rarg = case tp of
-                                                                  NT t _ _ -> let t' = maybe t id (deforestedNt t)
-                                                                              in SimpleExpr ("(Prelude.map " ++ (cataname @lhs.prefix t') ++ " list)")
-                                                                  _        -> arg
-                                                         lhs = Fun (cataname @lhs.prefix @nt) [arg]
-                                                         rhs = (App "Prelude.foldr" [cons,nil,rarg])
-                                                     in  [Decl lhs rhs Set.empty Set.empty]
-                                                 CommonTypes.Maybe tp ->
-                                                     let just    = semname @lhs.prefix @nt (identifier "Just")
-                                                         nothing = semname @lhs.prefix @nt (identifier "Nothing" )
-                                                         arg  = SimpleExpr "x"
-                                                         rarg = case tp of
-                                                                  NT t _ _ -> let t' = maybe t id (deforestedNt t)
-                                                                              in App (cataname @lhs.prefix t') [arg]
-                                                                  _        -> arg
-                                                         lhs a = Fun (cataname @lhs.prefix @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.Either tp1 tp2 ->
-                                                     let left  = semname @lhs.prefix @nt (identifier "Left")
-                                                         right = semname @lhs.prefix @nt (identifier "Right" )
-                                                         arg   = SimpleExpr "x"
-                                                         rarg0 = case tp1 of
-                                                                  NT t _ _ -> let t' = maybe t id (deforestedNt t)
-                                                                              in App (cataname @lhs.prefix t') [arg]
-                                                                  _        -> arg
-                                                         rarg1 = case tp2 of
-                                                                  NT t _ _ -> let t' = maybe t id (deforestedNt t)
-                                                                              in App (cataname @lhs.prefix t') [arg]
-                                                                  _        -> arg
-                                                         lhs a = Fun (cataname @lhs.prefix @nt) [a]
-                                                     in  [Decl (lhs (App "Prelude.Left"  [arg]))     (App left  [rarg0])    Set.empty Set.empty
-                                                         ,Decl (lhs (App "Prelude.Right" [arg]))     (App right [rarg1])    Set.empty Set.empty
-                                                         ]
-                                                 CommonTypes.Map _ tp ->
-                                                   let entry = SimpleExpr (semname @lhs.prefix @nt (identifier "Entry"))
-                                                       nil   = SimpleExpr (semname @lhs.prefix @nt (identifier "Nil"))
-                                                       arg   = SimpleExpr "m"
-                                                       rarg  = case tp of
-                                                                 NT t _ _ -> let t' = maybe t id (deforestedNt t)
-                                                                             in App "Data.Map.map" [SimpleExpr $ cataname @lhs.prefix t', arg]
-                                                                 _        -> arg
-                                                       lhs   = Fun (cataname @lhs.prefix @nt) [arg]
-                                                       rhs   = App "Data.Map.foldrWithKey" [entry,nil,rarg]
-                                                   in [Decl lhs rhs Set.empty Set.empty]
-                                                 CommonTypes.IntMap tp ->
-                                                   let entry = SimpleExpr (semname @lhs.prefix @nt (identifier "Entry"))
-                                                       nil   = SimpleExpr (semname @lhs.prefix @nt (identifier "Nil"))
-                                                       arg   = SimpleExpr "m"
-                                                       rarg  = case tp of
-                                                                 NT t _ _ -> let t' = maybe t id (deforestedNt t)
-                                                                             in App "Data.IntMap.map" [SimpleExpr $ cataname @lhs.prefix t', arg]
-                                                                 _        -> arg
-                                                       lhs   = Fun (cataname @lhs.prefix @nt) [arg]
-                                                       rhs   = App "Data.IntMap.foldWithKey" [entry,nil,rarg]
-                                                   in [Decl lhs rhs Set.empty Set.empty]
-                                                 CommonTypes.Tuple tps ->
-                                                     let con  = semname @lhs.prefix @nt (identifier "Tuple")
-                                                         tps' = [ (SimpleExpr (getName x),y) | (x,y) <- tps]
-                                                         rargs = map rarg tps'
-                                                         rarg (n, tp) = case tp of
-                                                                  NT t _ _ -> let t' = maybe t id (deforestedNt t)
-                                                                              in App (cataname @lhs.prefix t') [n]
-                                                                  _        -> n
-
-                                                         lhs = Fun (cataname @lhs.prefix @nt) [TupleExpr (map fst tps')]
-                                                         rhs = App con rargs
-                                                     in  [Decl lhs rhs Set.empty Set.empty] 
-                                                 CommonTypes.OrdSet tp ->
-                                                     let entry = SimpleExpr (semname @lhs.prefix @nt (identifier "Entry"))
-                                                         nil   = SimpleExpr (semname @lhs.prefix @nt (identifier "Nil" ))
-                                                         arg   = SimpleExpr "set"
-                                                         rentry = case tp of
-                                                                   NT t _ _ -> let t' = maybe t id (deforestedNt t)
-                                                                               in App "(.)" [entry, SimpleExpr $ cataname @lhs.prefix t']
-                                                                   _        -> entry
-                                                         lhs = Fun (cataname @lhs.prefix @nt) [arg]
-                                                         rhs = (App "Data.Set.foldr" [rentry,nil,arg])
-                                                     in  [Decl lhs rhs Set.empty Set.empty]
-                                                 CommonTypes.IntSet ->
-                                                     let entry = SimpleExpr (semname @lhs.prefix @nt (identifier "Entry"))
-                                                         nil   = SimpleExpr (semname @lhs.prefix @nt (identifier "Nil" ))
-                                                         arg   = SimpleExpr "set"
-                                                         lhs = Fun (cataname @lhs.prefix @nt) [arg]
-                                                         rhs = (App "Data.IntSet.foldr" [entry,nil,arg])
-                                                     in  [Decl lhs rhs Set.empty Set.empty]
-                               in  Comment "cata" :
-                                   (if @lhs.o_sig then [tSig] else []) ++
-                                   maybe @prods.cataAlts special (lookup @nt @lhs.typeSyns)
-
-ATTR CProductions     [ | | cataAlts : {Decls} ]
-ATTR CProduction      [ | | cataAlt  : {Decl}  ]
-
-
-SEM CProductions
-  | Cons lhs.cataAlts = @hd.cataAlt : @tl.cataAlts
-  | Nil  lhs.cataAlts = []
-
-SEM CProduction
-  | CProduction lhs.cataAlt = let lhs = Fun (cataname @lhs.prefix @lhs.nt) [lhs_pat]
-                                  lhs_pat = App (conname @lhs.o_rename @lhs.nt @con)
-                                                 (map (\(n,_,_) -> SimpleExpr $ locname @lhs.options $ n) @loc.firstOrderChildren)
-                                  rhs = App (semname @lhs.prefix @lhs.nt @con)
-                                             (map argument @loc.firstOrderChildren)
-                                  argument (nm,NT tp _ _,_) = App (cataname @lhs.prefix tp)
-                                                                   [SimpleExpr (locname @lhs.options nm)]
-                                  argument (nm, _,_)    = SimpleExpr (locname @lhs.options nm)
-                               in Decl lhs rhs Set.empty Set.empty
-
-
--------------------------------------------------------------------------------
--- Collect names of generated stuff
--------------------------------------------------------------------------------
-
-ATTR CProductions CProduction CVisits CVisit [ | | semNames USE {++} {[]} : {[String]} ]
-
-{-
-SEM CProduction
-  | CProduction
-      lhs.semNames = [cataname @lhs.prefix @lhs.nt] ++ @visits.semNames
--}
-
-SEM CVisit
-  | CVisit
-      lhs.semNames = [@loc.funcname]
-
+PRAGMA strictwrap+PRAGMA strictdata++INCLUDE "CodeSyntax.ag"+INCLUDE "Patterns.ag"+INCLUDE "DeclBlocks.ag"++imports+{+import CommonTypes+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 Data.Sequence as Seq+import Data.Sequence(Seq)+import UU.Scanner.Position+import TokenDef+import HsToken+import HsTokenScanner++import Data.List(partition,intersperse)+import Data.Maybe(fromJust,isJust)++}+++-------------------------------------------------------------------------------+--         Options+-------------------------------------------------------------------------------++ATTR CNonterminals CNonterminal+     CProductions CProduction+     CVisits CVisit+     Sequence CRule+     CInterface CSegments CSegment+       [ o_unbox,o_sig,o_sem,o_newtypes,o_case,o_pretty,o_rename,o_cata,o_strictwrap,o_splitsems,o_traces,o_costcentre,o_linePragmas,o_monadic,o_clean : Bool+         o_data : {Maybe Bool}+         prefix : String+         options : Options+       | | ]+SEM CGrammar [ options : Options | | ]+  | CGrammar    nonts.o_sig         = typeSigs       @lhs.options+                     .o_cata        = folds          @lhs.options+                     .o_sem         = semfuns        @lhs.options+                     .o_newtypes    = newtypes       @lhs.options+                     .o_unbox       = unbox          @lhs.options+                     .o_case        = cases          @lhs.options+                     .o_pretty      = attrInfo       @lhs.options+                     .o_rename      = rename         @lhs.options+                     .o_strictwrap  = strictWrap     @lhs.options+                     .o_splitsems   = splitSems      @lhs.options+                     .o_data        = if dataTypes @lhs.options then Just (strictData @lhs.options) else Nothing+                     .prefix        = prefix         @lhs.options+                     .o_traces      = genTraces      @lhs.options+                     .o_costcentre  = genCostCentres @lhs.options+                     .o_linePragmas = genLinePragmas @lhs.options+                     .o_monadic     = monadic        @lhs.options+                     .o_clean       = clean          @lhs.options++SEM CGrammar | CGrammar+  loc.options = @lhs.options { breadthFirst = breadthFirst @lhs.options && visit @lhs.options && cases @lhs.options && @multivisit }++ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit [ allPragmas : PragmaMap | | ]++SEM CGrammar+  | CGrammar  nonts.allPragmas = @pragmas++-------------------------------------------------------------------------------+-- Passing information about nonterminal and constructor down+-------------------------------------------------------------------------------++ATTR  CProductions CProduction CVisits+      CVisit Sequence CRule CInterface+      CSegments CSegment [ nt:NontermIdent inh,syn:Attributes | | ]+SEM  CNonterminal+  |  CNonterminal  inter.(inh,syn,nt) = (@inh,@syn,@nt)+                  prods.(inh,syn,nt) = (@inh,@syn,@nt)++ATTR CVisits CVisit Sequence CRule [ con:ConstructorIdent+                                     terminals : {[Identifier]} | | ]+SEM  CProduction+  |  CProduction  visits.con = @con+                   visits.terminals = @terminals++ATTR CNonterminals CNonterminal CSegments CSegment CInterface CProductions CProduction CVisits CVisit Sequence CRule [ paramMap : ParamMap | | ]++SEM CGrammar+  | CGrammar nonts.paramMap = @paramMap+++ATTR CVisits CVisit Sequence CRule [ paramInstMap : {Map Identifier (NontermIdent, [String])} | | ]++SEM CProduction+  | CProduction+      loc.paramInstMap = Map.fromList [(nm, (extractNonterminal tp, tps)) | (nm,tp,_) <- @children, let tps = map (cleanupArg @lhs.options) $ nontermArgs tp, not (null tps) ]++{+-- remove possible @v references in the types of a data type.+cleanupArg :: Options -> String -> String+cleanupArg opts s+  = case idEvalType opts (SimpleType s) of+      SimpleType s' -> s'+      _             -> error "Only SimpleType supported"+}++ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit [ contextMap : {ContextMap} quantMap : QuantMap | | ]++SEM CGrammar+  | CGrammar+      nonts.contextMap = @contextMap+      nonts.quantMap   = @quantMap++{+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++appQuant :: QuantMap -> NontermIdent -> Code.Type -> Code.Type+appQuant mp nt tp+  = foldr QuantApp tp $ Map.findWithDefault [] nt mp+}++ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit Sequence CRule [ allNts : {Set NontermIdent} | | ]++SEM CGrammar+  | CGrammar+      nonts.allNts = @nonts.gathNts++ATTR CNonterminals CNonterminal [ | | gathNts USE {`Set.union`} {Set.empty} : {Set NontermIdent} ]++SEM CNonterminal+  | CNonterminal+      lhs.gathNts = Set.singleton @nt++-- keep track of which children have had their first visit+ATTR CVisits CVisit Sequence CRule [ | visitedSet : {Set Identifier} | ]+SEM CProduction | CProduction  visits.visitedSet = Set.empty+SEM CRule | CChildVisit  loc.visitedSet = Set.insert @name @lhs.visitedSet++-------------------------------------------------------------------------------+-- Generating declarations from the sequence. We generate the origin+-- comment if pretty printing is requested. A childvisit takes inherited+-- attributes and returns synthesized attributes and the next visit.+-------------------------------------------------------------------------------++ATTR  Sequence CRule [ | | decls USE {++} {[]} : {Decls} ]+SEM  CRule+  |  CRule loc.instTypes = [ (n, (t, mb, for)) | (n, NT t _ for, mb) <- @lhs.children ]+           loc.originComment = if  @lhs.o_pretty+                                   then (Comment @origin:)+                                   else id+           loc.instDecls = [ mkDecl @lhs.o_monadic (Pattern3 (Alias _INST' inst (Underscore (getPos inst))))+                                  ( let (nm,mb,defor) = fromJust $ inst `lookup` @loc.instTypes+                                    in unwrapSem @lhs.o_newtypes nm+                                       $ case mb of+                                           ChildReplace _ -> App instLocFieldName [SimpleExpr $ fieldname inst]+                                           _              ->+                                              if defor+                                              then SimpleExpr instLocFieldName+                                              else App (cataname @lhs.prefix nm)+                                                             [SimpleExpr instLocFieldName]+                                  )+                                  (Set.singleton instSemFieldName)+                                  (Set.singleton instLocFieldName)+                           | inst <- @loc.definedInsts+                           , let instLocFieldName = attrname @lhs.options True _INST inst+                                 instSemFieldName = attrname @lhs.options False _INST' inst+                           ]+           loc.patDescr = if @isIn+                          then "_"+                          else concat $ intersperse "," (map (\(f,a) -> show f ++ "." ++ show a) @pattern.patternAttributes)+           loc.traceDescr = (maybe "" (\nm -> show nm ++ ":") @mbNamed) ++ show @nt ++ " :: " ++ show @con ++ " :: " ++ @loc.patDescr++           loc.addTrace = \v -> if @lhs.o_traces+                                then Trace @loc.traceDescr v+                                else v+           loc.costCentreDescr = show @nt ++ ":" ++ show @con ++ ":" ++ @loc.patDescr+           loc.addCostCentre = \v -> if @lhs.o_costcentre+                                     then PragmaExpr True False ("SCC \"" ++ @loc.costCentreDescr ++ "\"") v+                                     else v+           loc.addLinePragma = \v -> let p = getPos @name+                                         hasPos = line p > 0 && column p >= 0 && not (null (file p))+                                     in if @lhs.o_linePragmas && hasPos+                                        then PragmaExpr True True ("LINE " ++ show (line p) ++ " " ++ show (file p))+                                             $ LineExpr+                                             $ v+                                        else v+           loc.decls = if @hasCode+                       then @originComment ( mkDecl (@lhs.o_monadic && @explicit) (Pattern3 @pattern.copy) (@loc.addTrace $ @loc.addCostCentre $ @loc.addLinePragma $ (TextExpr @rhs))+                                                  (Set.fromList [attrname @lhs.options False fld nm | (fld,nm,_) <- Map.elems @defines])+                                                  (Set.fromList [attrname @lhs.options True fld nm | (fld,nm) <- Set.toList @uses])+                                           : @loc.instDecls)+                       else @loc.instDecls+  |  CChildVisit loc.costCentreDescr = show @lhs.nt ++ ":" ++ show @lhs.con ++ ":" ++ show @name ++ ":" ++ show @nt ++ ":" ++ show @nr+                 loc.addCostCentre = \v -> if @lhs.o_costcentre+                                           then PragmaExpr True False ("SCC \"" ++ @loc.costCentreDescr ++ "\"") v+                                           else v+                 loc.decls = let  lhsVars =  map (attrname @lhs.options True @name) (Map.keys @syn)+                                             ++ if @isLast then [] else [unwrap ++ funname @name (@nr+1)]+                                  rhsVars = map (attrname @lhs.options False @name) (Map.keys @inh)+                                  unwrap = if @lhs.o_newtypes then typeName @nt (@nr + 1) ++ " " else ""+                                  tuple | isMerging = TupleLhs [locname @lhs.options @name ++ "_comp"]+                                        | otherwise = mkTupleLhs @lhs.o_unbox (null $ Map.keys @inh) lhsVars+                                  rhs = @loc.addCostCentre $ Code.InvokeExpr (typeName @nt @nr) (SimpleExpr fun) (map SimpleExpr rhsVars)+                                  isVirtual _ [] = False+                                  isVirtual nm ((n,_,kind) : r)+                                    | nm == n   = case kind of+                                                    ChildAttr      -> True+                                                    ChildReplace _ -> True+                                                    _              -> False+                                    | otherwise = isVirtual nm r+                                  isMerged = @name `Map.member` @lhs.mergeMap+                                  isMerging = @name `elem` concatMap (\(_,cs) -> cs) (Map.elems @lhs.mergeMap)+                                  merges = [ (c,cs) | (c,(_,cs)) <- Map.assocs @lhs.mergeMap, all (`Set.member` @loc.visitedSet) cs, @name `elem` (c:cs) ]++                                  baseNm = if @nr == 0 && isVirtual @name @lhs.children+                                           then Ident (getName @name ++ "_inst") (getPos @name)+                                           else @name+                                  fun | @nr == 0 && Set.member @name @lhs.aroundMap+                                                  = locname @lhs.options @name ++ "_around " ++ funname baseNm 0+                                      | otherwise = funname baseNm @nr+                                  outDecls | isMerged  = []  -- merged variant is only produced after the last visit of the merged children+                                           | otherwise = -- [mkDecl @lhs.o_monadic tuple rhs (Set.fromList lhsVars) (Set.fromList (funname baseNm @nr : rhsVars))]+                                                         if isMerging+                                                         then [mkDecl @lhs.o_monadic tuple rhs Set.empty Set.empty]+                                                         else [Resume @lhs.o_monadic (typeName @nt @nr) tuple rhs]+                                  outMerged | null merges || @nr /= 0 = []  -- no merged child to produce+                                            | otherwise = let (c,cs) = head merges+                                                              tuple' = mkTupleLhs @lhs.o_unbox (null $ Map.keys @inh) lhsVars'+                                                              lhsVars' = map (attrname @lhs.options True c) (Map.keys @syn)+                                                                         ++ if @isLast then [] else [unwrap ++ funname c (@nr+1)]+                                                              rhsVars' = [ locname @lhs.options c' ++ "_comp" | c' <- cs ]+                                                              fun'    = locname @lhs.options c ++ "_merge"+                                                              rhs' = App fun' (map SimpleExpr rhsVars')+                                                          in [Resume @lhs.o_monadic (typeName @nt @nr) tuple' rhs']+                             in -- trace (show @name ++ " # " ++ show @loc.visitedSet ++ " # " ++ show (Map.assocs @lhs.mergeMap) ++ " # " ++ show merges ++ " # " ++ show @nr ++ " # " ++ show (length outMerged)) $+                                (outDecls ++ outMerged)++{+mkDecl :: Bool -> Lhs -> Expr -> Set String -> Set String -> Decl+mkDecl True  lhs rhs _ _   = Bind lhs rhs+mkDecl False lhs rhs s1 s2 = Decl lhs rhs s1 s2++unwrapSem :: Bool -> NontermIdent -> Expr -> Expr+unwrapSem False _ e = e+unwrapSem True nm e = Case e alts+  where alts  = [CaseAlt left right]+        left  = Fun (typeName nm 0) [SimpleExpr "x"]+        right = SimpleExpr "x"+}++ATTR Sequence CRule [ children : {[(Identifier,Type,ChildKind)]} ||]++ATTR Sequence CRule Pattern Patterns [|| definedInsts USE {++} {[]} : {[Identifier]} ]+SEM Pattern+  | Alias lhs.definedInsts = (if @field == _INST then [@attr] else []) ++ @pat.definedInsts++SEM CRule+  | CRule  loc.definedInsts = if @isIn then [] else @pattern.definedInsts++ATTR Pattern Patterns [ | | patternAttributes USE {++} {[]} : {[(Identifier, Identifier)]} ]+SEM Pattern+  | Alias+      lhs.patternAttributes = (@field,@attr) : @pat.patternAttributes++-------------------------------------------------------------------------------+-- Numbering the visits+-------------------------------------------------------------------------------++ATTR  CVisits CVisit Sequence CRule+      CSegments CSegment [ nr : Int | | ]+SEM  CProduction+  |  CProduction visits.nr = 0+SEM  CVisits+  |  Cons tl.nr = @lhs.nr + 1+SEM  CInterface+  |  CInterface seg.nr = 0+SEM  CSegments+  |  Cons tl.nr = @lhs.nr + 1++-------------------------------------------------------------------------------+-- Checking last visit+-------------------------------------------------------------------------------++ATTR CVisit CSegment [ isLast : Bool | | ]+ATTR CVisits CSegments [ | | isNil : Bool ]+SEM  CVisits+  |  Cons  lhs.isNil = False+           hd.isLast = @tl.isNil+  |  Nil lhs.isNil = True+SEM  CSegments+  |  Cons  lhs.isNil = False+           hd.isLast = @tl.isNil+  |  Nil lhs.isNil = True++-------------------------------------------------------------------------------+-- Getting the next intra-visit dependencies+-------------------------------------------------------------------------------++ATTR CVisit [ nextIntra : {Exprs} nextIntraVars : {Set String} | | ]+ATTR CVisits CVisit [ | | intra : {Exprs} intraVars : {Set String} ]+SEM  CVisit+  |  CVisit lhs.intra = @intra.exprs+            lhs.intraVars = @intra.usedVars+SEM  CVisits+  |  Cons  hd.nextIntra = @tl.intra+           hd.nextIntraVars = @tl.intraVars+           lhs.intra = @hd.intra+           lhs.intraVars = @hd.intraVars+  |  Nil lhs.intra = []+         lhs.intraVars = Set.empty++-------------------------------------------------------------------------------+-- Superfluous intra-visit dependencies due to higher-order children+--  (higher-order children can only be passed from their moment of creation)+-------------------------------------------------------------------------------++SEM CRule+  | CChildVisit+      loc.isSuperfluousHigherOrderIntra+        = @lhs.nr <= Map.findWithDefault (-1) @name @lhs.instVisitNrs++-------------------------------------------------------------------------------+-- Intra-visit dependencies are expressions that need to be passed+-------------------------------------------------------------------------------++ATTR  Sequence CRule [ | | exprs USE {++} {[]} : {Exprs} ]+SEM  CRule+  |  CRule loc.rulename = if  @field == _LOC && @name `elem` @lhs.terminals+                          then funname @name 0+                          else attrname @lhs.options @isIn @field @name+           lhs.exprs = [SimpleExpr @loc.rulename]+  |  CChildVisit+       loc.names = -- do not pass inst-childs as parameter if they are not defined yet+                   if @loc.isSuperfluousHigherOrderIntra+                   then []+                   else [funname @name (@nr+1)]+       lhs.exprs = let wrap = if @lhs.o_newtypes then \x -> App (typeName @nt (@nr + 1)) [x] else id++                       addType expr | null @loc.instParams = expr+                                    | otherwise            = TypedExpr expr (@lhs.unfoldSemDom @nt (@nr+1) @loc.instParams)++                   in map (wrap . addType . SimpleExpr) @loc.names++ATTR  Sequence CRule [ | | usedVars USE {`Set.union`} {Set.empty} : {Set String} ]+SEM CRule+  | CRule+      lhs.usedVars = Set.singleton @loc.rulename+  | CChildVisit+      lhs.usedVars = Set.fromList @loc.names++-------------------------------------------------------------------------------+-- Type signatures are added to the declarations.+-------------------------------------------------------------------------------++ATTR Sequence CRule [ | | tSigs USE {++} {[]} : {[Decl]} ]+SEM  CRule+  |  CRule        loc.mkTp = typeToCodeType (Just @lhs.nt) @loc.orgParams+                  lhs.tSigs = [ TSig (attrname @lhs.options False field attr) tp'+                              |  (field,attr,tp) <- Map.elems @defines, isJust tp+                              , let tp1 = @loc.evalTp field $ @mkTp (fromJust tp)+                                    tp' = case findOrigType attr @lhs.children of+                                           Just tp' -> let tp'' = case tp' of+                                                                    NT n params b -> NT (Ident ("T_" ++ show n) (getPos n)) params b+                                                                    _ -> tp'+                                                           tp2 = @loc.evalTp field $ @mkTp tp''+                                                       in Arr tp2 tp1+                                           Nothing -> tp1+                                    findOrigType _ [] = Nothing+                                    findOrigType nm ((n,_,kind) : r)+                                      | nm == n = case kind of+                                                    ChildReplace orig -> Just orig+                                                    _                 -> Nothing+                                      | otherwise = findOrigType nm r+                              ]++                  loc.orgParams = map getName $ Map.findWithDefault [] @lhs.nt @lhs.paramMap+                  loc.evalTp =+                    \field tp -> let orgFldParams = map getName $ Map.findWithDefault [] childNt @lhs.paramMap+                                     (childNt,instParams) = Map.findWithDefault (@lhs.nt,[]) field @lhs.paramInstMap+                                     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 @lhs.options tp+                                    else evalType @lhs.options replace tp++  |  CChildVisit  loc.mkTp = @loc.evalTp . typeToCodeType (Just @nt) @loc.orgParams+                  loc.definedTps = [ TSig (attrname @lhs.options True @name a) (@mkTp tp) |  (a,tp) <- Map.toList @syn ]+                  loc.nextTp = typeName @nt (@nr+1)+                  lhs.tSigs = (if @isLast then id else (TSig (funname @name (@nr+1)) (TypeApp (SimpleType @nextTp) (map SimpleType @loc.instParams)) :)) @definedTps++                  loc.orgParams = map getName $ Map.findWithDefault [] @nt @lhs.paramMap+                  loc.instParams = snd $ Map.findWithDefault (@nt,[]) @name @lhs.paramInstMap+                  loc.replParamMap = Map.fromList (zip @loc.orgParams @loc.instParams)+                  loc.replace = \k -> Map.findWithDefault k k @loc.replParamMap+                  loc.evalTp = if null @loc.orgParams then id else evalType @lhs.options @loc.replace+++-------------------------------------------------------------------------------+-- Types of intra-visit dependencies are needed in the type of the+-- semantic function.+-------------------------------------------------------------------------------++ATTR CVisits CVisit [ children : {[(Identifier,Type, ChildKind)]} | | ]+SEM  CProduction+  |  CProduction visits.children = @children+++ATTR Sequence CRule [ | | tps USE {++} {[]} : {[Type]}+                          allTpsFound USE {&&} {True} : Bool ]+SEM  CRule+  |  CRule        lhs.(tps,allTpsFound) = maybe ([],False) (\tp -> ([tp],True)) @tp+  |  CChildVisit  lhs.tps = if @loc.isSuperfluousHigherOrderIntra+                            then []+                            else [NT (ntOfVisit @nt (@nr+1)) @loc.instParams False]++-------------------------------------------------------------------------------+-- Each visit has its semantic function+-------------------------------------------------------------------------------++ATTR CVisits [ | | decls : {Decls} ]+ATTR CVisit [ | decls : {Decls} | ]+SEM CVisits+  | Nil   lhs.decls = []+  | Cons  lhs.decls = @hd.decls+          hd.decls  = @tl.decls++-- Note: lhs.decls are the decls related to the next visit function. We pass it+-- chained from right to left in order to build the next visit function inside+-- the previous one.+-- Note: intra decls are ignored. The intra-visit variables are not passed on+-- explicitly, but handled automatically due to nesting level.++SEM  CVisit+  |  CVisit (loc.higherOrderChildren,loc.firstOrderChildren) = partition (\(_,_,virt) -> isHigherOrder virt) @lhs.children+            loc.firstOrderOrig = map pickOrigType @loc.firstOrderChildren+            loc.funcname = seqSemname @lhs.prefix @lhs.nt @lhs.con @lhs.nr+            loc.nextVisitName = if @lhs.isLast then [] else [visitname @lhs.prefix @lhs.nt (@lhs.nr+1)]+            loc.nextVisitDecl = let  lhs = TupleLhs @nextVisitName+                                     -- rhs = App fun @lhs.nextIntra+                                     rhs = Let @lhs.decls (SimpleExpr fun)+                                     fun = seqSemname @lhs.prefix @lhs.nt @lhs.con (@lhs.nr+1)+                                in if @lhs.isLast+                                   then []+                                   else [Decl lhs rhs (Set.fromList @nextVisitName) @lhs.nextIntraVars]+            loc.isOneVisit  = @lhs.isLast && @lhs.nr == 0+            loc.hasWrappers = @lhs.nt `Set.member` @lhs.wrappers+            loc.refDecls = if @loc.isOneVisit && @loc.hasWrappers && reference @lhs.options+                           then let synAttrs = Map.toList @syn+                                    synNT = "Syn" ++ "_" ++ getName @lhs.nt+                                    synVars = [ SimpleExpr (attrname @lhs.options False _LHS a) | (a,_) <- synAttrs ]+                                    rhs = App synNT synVars+                                    lhs = Fun "___node" []+                                in [Decl lhs rhs Set.empty Set.empty]+                           else []+            loc.decls = if @lhs.o_clean+                          then @vss.decls ++ @nextVisitDecl ++ @loc.refDecls -- Don't generate type signatures for Clean, they will cause the compiler to generate functions, even for constants+                          else @typeSigs ++ @vss.decls ++ @nextVisitDecl ++ @loc.refDecls+            vss.lastExpr = mkTupleExpr @lhs.o_unbox (null $ Map.keys @inh) $ map (SimpleExpr . lhsname @lhs.options False) (Map.keys @syn) ++ map SimpleExpr @nextVisitName+            intra.lastExpr = error "lastExpr: not used here"+            loc.lastExprVars = map (lhsname @lhs.options False) (Map.keys @syn) ++ @loc.nextVisitName+            (loc.blockFunDecls, loc.blockFirstFunCall) = mkPartitionedFunction @loc.funcname @loc.o_case @loc.nextVisitDecl @loc.lastExprVars @vss.blockDecls++            loc.costCentreDescr = "b" ++ ":" ++ show @lhs.nt ++ ":" ++ show @lhs.con ++ ":" ++ show @lhs.nr+            loc.addCostCentre = \v -> if @lhs.o_costcentre+                                      then PragmaExpr True False ("SCC \"" ++ @loc.costCentreDescr ++ "\"") v+                                      else v++            loc.params = map getName $ Map.findWithDefault [] @lhs.nt @lhs.paramMap+            loc.semFun = let  lhs = Fun @funcname lhs_args+                              lhs_args = if @lhs.nr == 0 then map field @loc.firstOrderOrig else [] -- @intra.exprs++                              field (name,NT tp tps _,_) = let unwrap | @lhs.o_newtypes = \x -> App (sdtype tp) [x]+                                                                      | otherwise       = id++                                                               addType expr | null tps  = expr+                                                                            | otherwise = TypedExpr expr (@lhs.unfoldSemDom tp 0 tps)++                                                           in unwrap $ addType $ SimpleExpr $ funname name 0+                              field (name,tp,_)        = let expr = SimpleExpr (funname name 0)+                                                         in if null @loc.params+                                                            then expr+                                                            else TypedExpr expr (idEvalType @lhs.options $ typeToCodeType (Just @lhs.nt) @loc.params $ removeDeforested tp)++                              mbEvalTp | null @loc.params = const Nothing+                                       | otherwise        = Just . (idEvalType @lhs.options)++                              rhs = wrap+                                  . mkSemFun @lhs.nt @lhs.nr [mkLambdaArg (lhsname @lhs.options True nm) (mbEvalTp $ typeToCodeType (Just @lhs.nt) @loc.params $ removeDeforested tp) | (nm,tp) <- Map.assocs @inh]+                                  $ @loc.addCostCentre+                                  $ if @ordered && @loc.o_splitsems+                                    then @loc.blockFirstFunCall+                                    else mkDecls @loc.declsType @decls+                                         . ResultExpr (typeName @lhs.nt @lhs.nr)+                                         . mkTupleExpr @lhs.o_unbox (null $ Map.keys @inh)+                                         $ map (SimpleExpr . lhsname @lhs.options False) (Map.keys @syn) ++ map SimpleExpr @nextVisitName+                              wrap = if  @lhs.o_newtypes+                                         then \x -> App (typeName @lhs.nt @lhs.nr) [x]+                                         else id+                         in Decl lhs rhs Set.empty Set.empty+            loc.tsig = TSig @funcname @semType+            loc.semType = let argType (NT tp tps _)  r | tp /= _SELF = typeAppStrs (sdtype tp) tps `Arr` r+                                                       | tp == _SELF = error "GenerateCode: found an intra-type with type SELF, which should have been prevented by CRule.tps"+                              argType (Haskell tp) r                 = SimpleType tp          `Arr` r+                              argType _ _ = error "Self type not allowed here"+                              evalTp | null @loc.params = id+                                     | otherwise        = idEvalType @lhs.options++                          in appQuant @lhs.quantMap @lhs.nt $ appContext @lhs.contextMap @lhs.nt $ evalTp $+                             if  @lhs.nr == 0+                                 then foldr argType (typeAppStrs (sdtype   @lhs.nt        ) @loc.params) (map (\(_,t,_) -> t) @loc.firstOrderOrig)+                                 else foldr argType (typeAppStrs (typeName @lhs.nt @lhs.nr) @loc.params) [] -- @intra.tps+            lhs.decls =  ( if  @lhs.with_sig+                           then [@tsig, @semFun]+                           else [@semFun]+                         ) +++                         ( if @ordered && @loc.o_splitsems+                           then @loc.blockFunDecls+                           else []+                         )+            loc.typeSigs =  if  @lhs.o_sig && not @o_case+                                then  @vss.tSigs+                                else  []+            loc.o_do   = @ordered && @lhs.o_monadic+            loc.o_case = not @loc.o_do && @lhs.o_case && @ordered && not (hasPragma @lhs.allPragmas @lhs.nt @lhs.con _NOCASE)+            loc.declsType = if @loc.o_do+                            then DeclsDo+                            else if @loc.o_case+                                 then DeclsCase+                                 else DeclsLet+            loc.o_splitsems = @ordered && @lhs.o_splitsems++{+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++mkSemFun :: Identifier -> Int -> Exprs -> Expr -> Expr+mkSemFun nt nr xs e = SemFun (typeName nt nr) xs e++typeAppStrs :: String -> [String] -> Code.Type+typeAppStrs nm params = TypeApp (SimpleType nm) (map SimpleType params)++isHigherOrder :: ChildKind -> Bool+isHigherOrder ChildAttr = True+isHigherOrder _         = False++pickOrigType :: (Identifier, Type, ChildKind) -> (Identifier, Type, ChildKind)+pickOrigType (nm, _, virt@(ChildReplace x)) = (nm, x, virt)+pickOrigType x = x+}++ATTR CVisits CVisit Sequence CRule [ instVisitNrs : {Map Identifier Int} || ]+ATTR CVisits CVisit [|| gatherInstVisitNrs USE {`Map.union`} {Map.empty} : {Map Identifier Int} ]+SEM CProduction+  | CProduction+      visits.instVisitNrs = @visits.gatherInstVisitNrs++SEM CVisit+  | CVisit+      lhs.gatherInstVisitNrs = Map.fromList [(i,@lhs.nr) | i <- @vss.definedInsts]++-------------------------------------------------------------------------------+-- Push aroundsMap downward+-------------------------------------------------------------------------------++ATTR CNonterminals CNonterminal+  [ aroundMap : {Map NontermIdent (Map ConstructorIdent (Set Identifier))} || ]++ATTR CProductions CProduction+  [ aroundMap : {Map ConstructorIdent (Set Identifier)} || ]++ATTR CVisits CVisit Sequence CRule [ aroundMap : {Set Identifier} | | ]++SEM CGrammar | CGrammar          loc.aroundMap = @aroundsMap+SEM CNonterminal | CNonterminal  loc.aroundMap = Map.findWithDefault Map.empty @nt @lhs.aroundMap+SEM CProduction | CProduction    loc.aroundMap = Map.findWithDefault Set.empty @con @lhs.aroundMap++-------------------------------------------------------------------------------+-- Push mergeMap downward+-------------------------------------------------------------------------------++ATTR CNonterminals CNonterminal+  [ mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier])))} || ]++ATTR CProductions CProduction+  [ mergeMap : {Map ConstructorIdent (Map Identifier (Identifier, [Identifier]))} || ]++ATTR CVisits CVisit Sequence CRule [ mergeMap : {Map Identifier (Identifier, [Identifier])} | | ]++SEM CGrammar | CGrammar          loc.mergeMap = @mergeMap+SEM CNonterminal | CNonterminal  loc.mergeMap = Map.findWithDefault Map.empty @nt @lhs.mergeMap+SEM CProduction | CProduction    loc.mergeMap = Map.findWithDefault Map.empty @con @lhs.mergeMap++-------------------------------------------------------------------------------+-- Generate a partitioned version of the sequence of rules+-------------------------------------------------------------------------------++ATTR Sequence [ lastExpr : Expr | | blockDecls : DeclBlocks ]++ATTR Sequence CRule [ | declsAbove : {[Decl]}  | ]+SEM CVisit+  | CVisit+      vss.declsAbove = []+      intra.declsAbove = error "declsAbove: not used here"++SEM CRule+  | CRule+      lhs.declsAbove = @lhs.declsAbove ++ @loc.decls+  | CChildVisit+      lhs.declsAbove = []++SEM Sequence+  | Cons+      lhs.blockDecls = @hd.bldBlocksFun @tl.blockDecls+  | Nil+      lhs.blockDecls = DeclTerminator @lhs.declsAbove @lhs.lastExpr++ATTR CRule [ | | bldBlocksFun : {DeclBlocks -> DeclBlocks} ]+SEM CRule+  | CRule+      lhs.bldBlocksFun = id+  | CChildVisit+      lhs.bldBlocksFun = DeclBlock @lhs.declsAbove (head @loc.decls)++{+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)+}++WRAPPER DeclBlocksRoot++ATTR DeclBlocksRoot DeclBlocks [ prefix : String optCase : Bool nextVisitDecls : {[Decl]} lastExprVars : {[String]} | | ]+ATTR DeclBlocksRoot [ | | lambdas : {[Decl]} firstCall : Expr ]++SEM DeclBlocksRoot+  | DeclBlocksRoot+      lhs.lambdas  = @blocks.decls+      lhs.firstCall = @blocks.callExpr++ATTR DeclBlocks [ blockNr : Int | | ]+SEM DeclBlocksRoot+  | DeclBlocksRoot+      blocks.blockNr = 1+SEM DeclBlocks+  | DeclBlock+      next.blockNr = @lhs.blockNr + 1++ATTR DeclBlocks [ | | callExpr : Expr freeVars : {[String]} ]+SEM DeclBlocks+  | DeclBlock DeclTerminator+      loc.lambdaName = @lhs.prefix ++ "_block" ++ show @lhs.blockNr+      loc.pragmaDecl = PragmaDecl ("NOINLINE " ++ @loc.lambdaName)+      lhs.callExpr = App @loc.lambdaName (map SimpleExpr @loc.freeVars)+  | DeclTerminator+      loc.freeVars = freevars @lhs.lastExprVars (@defs ++ @lhs.nextVisitDecls)+  | DeclBlock+      loc.freeVars = freevars @next.freeVars (@visit : @defs)++ATTR DeclBlocks [ | | decls : {[Decl]} ]+SEM DeclBlocks+  | DeclTerminator+      lhs.decls = [ mkBlockLambda @lhs.optCase @loc.lambdaName @loc.freeVars (@defs ++ @lhs.nextVisitDecls) @result ]+  | DeclBlock+      loc.decl = mkBlockLambda @lhs.optCase @loc.lambdaName @loc.freeVars (@defs ++ [@visit]) @next.callExpr+      lhs.decls = (if @lhs.blockNr > 1 then [@loc.pragmaDecl] else []) ++ [@loc.decl] ++ @next.decls++{+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+}+++-------------------------------------------------------------------------------+-- The semantic domain is generated from the interface.+-------------------------------------------------------------------------------++ATTR  CInterface CSegments CSegment [ | | semDom USE {++} {[]} : {[Decl]} ]+SEM  CInterface+  |  CInterface  lhs.semDom = Comment "semantic domain" : @seg.semDom++SEM  CSegment+  |  CSegment loc.altSemForm = breadthFirst @lhs.options+              loc.tp = if @loc.altSemForm+                       then TypeApp (SimpleType "Child") [SimpleType "EvalInfo", @loc.indexExpr ]+                       else foldr Arr @loc.synTps @loc.inhTps+              loc.inhTps = [typeToCodeType (Just @lhs.nt) @loc.params tp |  tp <- Map.elems @inh]+              loc.inhTup = mkTupleType @lhs.o_unbox (null @loc.inhTps) @loc.inhTps+              loc.synTps = mkTupleType @lhs.o_unbox (null @loc.inhTps) ([typeToCodeType (Just @lhs.nt) @loc.params tp |  tp <- Map.elems @syn] ++ @loc.continuation)+              loc.curTypeName  = typeName @lhs.nt @lhs.nr+              loc.nextTypeName = typeName @lhs.nt (@lhs.nr + 1)+              loc.indexName    = "I_" ++ @loc.curTypeName+              loc.dataIndex = Code.Data @loc.indexName @loc.params [DataAlt @loc.indexName []] False []+              loc.indexExpr = TypeApp (SimpleType @loc.indexName) (map (SimpleType . ('@':)) @loc.params)+              loc.indexStr  = "(" ++ @loc.indexName ++ concatMap (\p -> " " ++ p) @loc.params ++ ")"+              loc.inhInstance = Code.Data "instance Inh" [@loc.indexStr] [DataAlt (typeName @lhs.nt @lhs.nr ++ "_Inh") [@loc.inhTup] ] False []+              loc.synInstance = Code.Data "instance Syn" [@loc.indexStr] [DataAlt (typeName @lhs.nt @lhs.nr ++ "_Syn") [@loc.synTps] ] False []+              loc.continuation = if  @lhs.isLast+                                 then []+                                 else [TypeApp (SimpleType @loc.nextTypeName) (map (SimpleType . ('@':)) @loc.params)]+              loc.params = map getName $ Map.findWithDefault [] @lhs.nt @lhs.paramMap+              lhs.semDom = let name = typeName @lhs.nt @lhs.nr+                               evalTp | null @loc.params = id+                                      | otherwise        = idEvalType @lhs.options+                           in ( if @lhs.o_newtypes+                                then [ Code.NewType name @loc.params name (evalTp @loc.tp) ]+                                else [ Code.Type name @loc.params (evalTp @loc.tp) ] )+                              ++ ( if @loc.altSemForm+                                   then [@loc.dataIndex, @loc.inhInstance, @loc.synInstance]+                                   else [] )++ATTR CNonterminals CNonterminal CInterface CSegments CSegment [ | | semDomUnfoldGath USE {`Map.union`} {Map.empty} : {Map (NontermIdent, Int) ([String], Code.Type)} ]++SEM CSegment+  | CSegment+      lhs.semDomUnfoldGath = Map.singleton (@lhs.nt, @lhs.nr) (@loc.params, @loc.tp)++ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit Sequence CRule [ unfoldSemDom : {NontermIdent -> Int -> [String] -> Code.Type} | | ]++SEM CGrammar+  | CGrammar+      loc.unfoldSemDom =+       \nt nr repl ->+        let (params, tp) = Map.findWithDefault (error ("No such semantic domain: " ++ show nt)) (nt, nr) @nonts.semDomUnfoldGath+            replMap = Map.fromList (zip params repl)+            replace k = Map.findWithDefault ('@':k) k replMap+        in evalType @lhs.options replace tp++{+typeToCodeType :: Maybe NontermIdent -> [String] -> Type -> Code.Type+typeToCodeType _ _ tp+  = case tp of+      NT nt tps defor -> NontermType (getName nt) tps defor+      Haskell t       -> SimpleType t+      Self            -> error "Self type not allowed here."++evalType :: Options -> (String -> String) -> Code.Type -> Code.Type+evalType opts 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 opts (initPos txt) txt+                                      tks' = map replaceTok tks+                                      txt' = unlines . showTokens . tokensToStrings $ tks'+                                  in SimpleType txt'+          TMaybe m             -> TMaybe (chase m)+          TEither l r          -> TEither (chase l) (chase r)+          TMap k v             -> TMap (chase k) (chase v)+          TIntMap v            -> TIntMap (chase v)+          TSet m               -> TSet (chase m)+          _                    -> t++    replaceTok t+      = case t of+          AGLocal v p _ -> HsToken (replf $ getName v) p+          _             -> t++idEvalType :: Options -> Code.Type -> Code.Type+idEvalType options = evalType options id+}++-------------------------------------------------------------------------------+-- Wrapper functions+-------------------------------------------------------------------------------++SEM CNonterminal+  | CNonterminal loc.semWrapper = let params' = map getName @params+                                      inhAttrs = Map.toList @inh+                                      synAttrs = Map.toList @syn+                                      inhVars = [ SimpleExpr (attrname @lhs.options True _LHS a) | (a,_) <- inhAttrs ]+                                      synVars = [ SimpleExpr (attrname @lhs.options False _LHS a) | (a,_) <- synAttrs ]+                                      var = "sem"+                                      wrapNT = "wrap" ++ "_" ++ getName @nt+                                      inhNT = "Inh" ++ "_" ++ getName @nt+                                      synNT = "Syn" ++ "_" ++ getName @nt+                                      varPat = if  @lhs.o_newtypes+                                                   then App (sdtype @nt) [SimpleExpr var]+                                                   else SimpleExpr var++                                      evalTp | null params' = id+                                             | otherwise    = idEvalType @lhs.options+                                      appParams nm = TypeApp (SimpleType nm) (map SimpleType params')+                                      typeSig = TSig wrapNT (evalTp $ appParams (sdtype @nt) `Arr` (appParams inhNT `Arr` appParams synNT))+                                      mkstrict = Named @lhs.o_strictwrap+                                      mkdata n attrs = Data n params' [Record n [mkstrict (getName f++"_"++n) $ evalTp $ typeToCodeType (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 @inter.wrapDecls (App synNT synVars))+                                                    Set.empty Set.empty+                                              ]++ATTR CInterface CSegments CSegment [ | | wrapDecls USE {++} {[]}: {Decls} ]+SEM  CSegment+  |  CSegment lhs.wrapDecls =  let lhsVars = map (lhsname @lhs.options False) (Map.keys @syn)+                                             ++ if @lhs.isLast then [] else [unwrap ++ sem (@lhs.nr+1)]+                                   rhsVars = map (lhsname @lhs.options True) (Map.keys @inh)+                                   rhs = map SimpleExpr rhsVars+                                   unwrap = if @lhs.o_newtypes then typeName @lhs.nt (@lhs.nr + 1) ++ " " else ""+                                   var   = "sem"+                                   sem 0 = var+                                   sem n = var ++ "_" ++ show n+                                   ntt   = typeName @lhs.nt @lhs.nr+                               in [ EvalDecl ntt (mkTupleLhs @lhs.o_unbox (null $ Map.keys @inh) lhsVars) (InvokeExpr ntt (SimpleExpr $ sem @lhs.nr) rhs) ]+                                  -- [ Decl (mkTupleLhs @lhs.o_unbox (null $ Map.keys @inh) lhsVars) (App (sem @lhs.nr) rhs) (Set.fromList lhsVars) (Set.fromList rhsVars) ]++-------------------------------------------------------------------------------+-- Errors for missing type signatures. It's an error when one of the+-- attributes in the intra-visit dependencies does not have a type.+-- UPDATE: it is not an error anymore...+-------------------------------------------------------------------------------++ATTR CNonterminals CNonterminal+     CProductions CProduction+     CVisits CVisit [ with_sig : Bool | | ]++SEM CGrammar+  | CGrammar nonts.with_sig = typeSigs @lhs.options++SEM  CGrammar [ | | errors : {Seq Error} ]+  |  CGrammar lhs.errors = Seq.empty++-------------------------------------------------------------------------------+-- Provide a description of the interfaces as comments+-------------------------------------------------------------------------------++SEM CNonterminal+  | CNonterminal loc.comment = Comment . unlines . map ind $ ( @inter.comments ++ ("alternatives:" : map ind @prods.comments) )++ATTR CInterface CSegments CSegment+     CProductions CProduction+     CVisits CVisit Sequence CRule  [ | | comments USE {++} {[]}: {[String]} ]++ATTR Sequence CRule [ what:String | | ]++SEM CSegment+  | CSegment     lhs.comments =  let body = map ind (showsSegment (CSegment @inh @syn))+                                 in if null body+                                    then []+                                    else ("visit " ++ show @lhs.nr ++ ":") : body++SEM CProduction+  | CProduction  loc.firstOrderChildren = [ (nm,fromJust mb,virt) | (nm,tp,virt) <- @children, let mb = isFirstOrder virt tp, isJust mb ]+                 lhs.comments =  ("alternative " ++ getName @con ++ ":")+                                 : map ind (  map (\(x,y,_) -> makeLocalComment 14 "child" x (Just y)) @loc.firstOrderChildren+                                           ++ @visits.comments+                                           )++{+-- for a virtual child that already existed as a child, returns+isFirstOrder :: ChildKind -> Type -> Maybe Type+isFirstOrder ChildSyntax       tp = Just tp+isFirstOrder ChildAttr         _  = Nothing+isFirstOrder (ChildReplace tp) _  = Just tp+}++SEM CVisit+  | CVisit       lhs.comments =  let body = map ind (@vss.comments ++ @intra.comments)+                                 in if null body+                                    then []+                                    else ("visit " ++ show @lhs.nr ++ ":") : body+                 vss.what     = "local"+                 intra.what   = "intra"+++SEM CRule+  | CRule        lhs.comments =  [ makeLocalComment 11 @lhs.what name tp | (field,name,tp) <- Map.elems @defines, field == _LOC ]+                                 ++ [ makeLocalComment 11 "inst " name tp | (field,name,tp) <- Map.elems @defines, field == _INST ]++{+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' ++ "}"+                                                                   Self -> error "Self type not allowed here.") tp+                                       in   ( what ++ " " ++ x ++ replicate ((width - length x) `max` 0) ' ' ++ " : " ++ y )++}++-------------------------------------------------------------------------------+-- And tie it all together+-------------------------------------------------------------------------------++ATTR CNonterminals CNonterminal    [ | | chunks USE {++} {[]} : {Chunks} ]+ATTR CProductions CProduction  [ | | decls USE {++} {[]} : {Decls} ]+ATTR CGrammar [ | | output : Program ]++SEM CGrammar+  | CGrammar    lhs.output = Program @nonts.chunks @multivisit++SEM CNonterminal+  | CNonterminal  lhs.chunks = [ Chunk (getName @nt)+                                      (Comment (getName @nt ++ " " ++ replicate (60 - length (getName @nt)) '-'))+                                      (if @lhs.o_pretty                  then [@loc.comment]   else [])+                                      (if isJust @lhs.o_data             then [@loc.dataDef]   else [])+                                      (if @lhs.o_cata && @loc.genCata    then  @loc.cataFun    else [])+                                      (if @lhs.o_sig                     then  @inter.semDom   else [])+                                      (if @nt `Set.member` @lhs.wrappers then  @loc.semWrapper else [])+                                      (if @lhs.o_sem                     then  @prods.decls     else [])+                                      (if @lhs.o_sem                     then  @prods.semNames  else [])+                               ]++{+-- Lets or nested Cases?+-- or even a do-expression?++data DeclsType = DeclsLet | DeclsCase | DeclsDo++mkDecls :: DeclsType -> Decls -> Expr -> Expr+mkDecls DeclsLet  = mkLet False+mkDecls DeclsCase = mkLet True+mkDecls DeclsDo   = \decls -> Do (map toBind decls)+  where toBind (Decl lhs rhs _ _) = BindLet lhs rhs+        toBind d                  = d++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 _ _)      ex = Case rhs [CaseAlt left ex]+oneCase (Resume _ nt left rhs)   ex = ResumeExpr nt rhs left ex+oneCase _                        ex = ex++-- Gives the name of the visit function+funname :: Show a => a -> Int -> String+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++ntOfVisit :: NontermIdent -> Int -> NontermIdent+ntOfVisit nt 0 = nt+ntOfVisit nt n = Ident (show nt ++ "_" ++ show n) (getPos nt)++-- Gives the name of a visit function+visitname  ::  String -> NontermIdent -> Int -> String+visitname pre nt n =  pre ++ getName nt ++ "_" ++ show n+}++-------------------------------------------------------------------------------+-- Datatypes were already present+-------------------------------------------------------------------------------++ATTR CNonterminals CNonterminal [ derivings: {Derivings} typeSyns : {TypeSyns} | | ]+ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit [ wrappers:{Set NontermIdent} | | ]++SEM CGrammar+  | CGrammar nonts . typeSyns  = @typeSyns+                   . derivings = @derivings+                   . wrappers  = @wrappers++SEM CNonterminal+  | CNonterminal loc.dataDef = let params' = map getName @params+                                   typeSyn tp = let theType =+                                                      case tp of+                                                        CommonTypes.Maybe t      -> TMaybe $ typeToCodeType (Just @nt) params' t+                                                        CommonTypes.Either t1 t2 -> TEither (typeToCodeType (Just @nt) params' t1) (typeToCodeType (Just @nt) params' t2)+                                                        CommonTypes.Map t1 t2    -> TMap (typeToCodeType (Just @nt) params' t1) (typeToCodeType (Just @nt) params' t2)+                                                        CommonTypes.IntMap t     -> TIntMap $ typeToCodeType (Just @nt) params' t+                                                        CommonTypes.List t       -> Code.List $ typeToCodeType (Just @nt) params' t+                                                        CommonTypes.Tuple ts     -> Code.TupleType [typeToCodeType (Just @nt) params' t | (_,t) <- ts ]+                                                        CommonTypes.OrdSet t     -> TSet $ typeToCodeType (Just @nt) params' t+                                                        CommonTypes.IntSet       -> TIntSet+                                                 in Code.Type (getName @nt) params' (idEvalType @lhs.options theType)+                                   derivings  = maybe [] (map getName . Set.toList) (Map.lookup @nt @lhs.derivings)+                                   dataDef    = Data (getName @nt) (map getName @params) @prods.dataAlts (maybe False id @lhs.o_data) derivings+                               in maybe dataDef typeSyn $ lookup @nt @lhs.typeSyns++ATTR CProductions     [ | | dataAlts : {DataAlts} ]+ATTR CProduction      [ | | dataAlt  : {DataAlt}  ]++SEM CProductions+  | Cons        lhs.dataAlts  = @hd.dataAlt : @tl.dataAlts+  | Nil         lhs.dataAlts  = []++SEM CProduction+  | CProduction loc.params  = map getName $ Map.findWithDefault [] @lhs.nt @lhs.paramMap+                lhs.dataAlt = let conNm = conname @lhs.o_rename @lhs.nt @con+                                  mkFields :: (NontermIdent -> ConstructorIdent -> Identifier -> Code.Type -> a) -> [a]+                                  mkFields f = map (\(nm,t,_) -> f @lhs.nt @con nm (typeToCodeType (Just @lhs.nt) @loc.params $ removeDeforested t)) @loc.firstOrderChildren+                              in if dataRecords @lhs.options+                                 then Record conNm $ mkFields $ toNamedType (strictData @lhs.options)+                                 else DataAlt conNm $ mkFields $ \_ _ _ t -> t++{+toNamedType :: Bool -> NontermIdent -> ConstructorIdent -> Identifier -> Code.Type -> Code.NamedType+toNamedType genStrict nt con nm tp+  = Code.Named genStrict strNm tp+  where strNm = recordFieldname nt con nm+}++-------------------------------------------------------------------------------+-- Catamorphism were already present+-------------------------------------------------------------------------------++SEM CNonterminal+  | CNonterminal loc.genCata = not (@nt `Set.member` nocatas @lhs.options)+                 loc.cataFun = let appParams nm = TypeApp (SimpleType nm) (map SimpleType (map getName @params))+                                   evalTp | null @params = id+                                          | otherwise    = idEvalType @lhs.options+                                   tSig = TSig (cataname @lhs.prefix @nt)+                                               (appQuant @lhs.quantMap @nt $ appContext @lhs.contextMap @nt $ evalTp $ appParams (getName @nt) `Arr` appParams (sdtype @nt))+                                   special typ = case typ of+                                                 CommonTypes.List tp ->+                                                     let cons = SimpleExpr (semname @lhs.prefix @nt (identifier "Cons"))+                                                         nil  = SimpleExpr (semname @lhs.prefix @nt (identifier "Nil" ))+                                                         arg  = SimpleExpr "list"+                                                         rarg = case tp of+                                                                  NT t _ _ -> let t' = maybe t id (deforestedNt t)+                                                                              in SimpleExpr ("(Prelude.map " ++ (cataname @lhs.prefix t') ++ " list)")+                                                                  _        -> arg+                                                         lhs = Fun (cataname @lhs.prefix @nt) [arg]+                                                         rhs = (App "Prelude.foldr" [cons,nil,rarg])+                                                     in  [Decl lhs rhs Set.empty Set.empty]+                                                 CommonTypes.Maybe tp ->+                                                     let just    = semname @lhs.prefix @nt (identifier "Just")+                                                         nothing = semname @lhs.prefix @nt (identifier "Nothing" )+                                                         arg  = SimpleExpr "x"+                                                         rarg = case tp of+                                                                  NT t _ _ -> let t' = maybe t id (deforestedNt t)+                                                                              in App (cataname @lhs.prefix t') [arg]+                                                                  _        -> arg+                                                         lhs a = Fun (cataname @lhs.prefix @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.Either tp1 tp2 ->+                                                     let left  = semname @lhs.prefix @nt (identifier "Left")+                                                         right = semname @lhs.prefix @nt (identifier "Right" )+                                                         arg   = SimpleExpr "x"+                                                         rarg0 = case tp1 of+                                                                  NT t _ _ -> let t' = maybe t id (deforestedNt t)+                                                                              in App (cataname @lhs.prefix t') [arg]+                                                                  _        -> arg+                                                         rarg1 = case tp2 of+                                                                  NT t _ _ -> let t' = maybe t id (deforestedNt t)+                                                                              in App (cataname @lhs.prefix t') [arg]+                                                                  _        -> arg+                                                         lhs a = Fun (cataname @lhs.prefix @nt) [a]+                                                     in  [Decl (lhs (App "Prelude.Left"  [arg]))     (App left  [rarg0])    Set.empty Set.empty+                                                         ,Decl (lhs (App "Prelude.Right" [arg]))     (App right [rarg1])    Set.empty Set.empty+                                                         ]+                                                 CommonTypes.Map _ tp ->+                                                   let entry = SimpleExpr (semname @lhs.prefix @nt (identifier "Entry"))+                                                       nil   = SimpleExpr (semname @lhs.prefix @nt (identifier "Nil"))+                                                       arg   = SimpleExpr "m"+                                                       rarg  = case tp of+                                                                 NT t _ _ -> let t' = maybe t id (deforestedNt t)+                                                                             in App "Data.Map.map" [SimpleExpr $ cataname @lhs.prefix t', arg]+                                                                 _        -> arg+                                                       lhs   = Fun (cataname @lhs.prefix @nt) [arg]+                                                       rhs   = App "Data.Map.foldrWithKey" [entry,nil,rarg]+                                                   in [Decl lhs rhs Set.empty Set.empty]+                                                 CommonTypes.IntMap tp ->+                                                   let entry = SimpleExpr (semname @lhs.prefix @nt (identifier "Entry"))+                                                       nil   = SimpleExpr (semname @lhs.prefix @nt (identifier "Nil"))+                                                       arg   = SimpleExpr "m"+                                                       rarg  = case tp of+                                                                 NT t _ _ -> let t' = maybe t id (deforestedNt t)+                                                                             in App "Data.IntMap.map" [SimpleExpr $ cataname @lhs.prefix t', arg]+                                                                 _        -> arg+                                                       lhs   = Fun (cataname @lhs.prefix @nt) [arg]+                                                       rhs   = App "Data.IntMap.foldWithKey" [entry,nil,rarg]+                                                   in [Decl lhs rhs Set.empty Set.empty]+                                                 CommonTypes.Tuple tps ->+                                                     let con  = semname @lhs.prefix @nt (identifier "Tuple")+                                                         tps' = [ (SimpleExpr (getName x),y) | (x,y) <- tps]+                                                         rargs = map rarg tps'+                                                         rarg (n, tp) = case tp of+                                                                  NT t _ _ -> let t' = maybe t id (deforestedNt t)+                                                                              in App (cataname @lhs.prefix t') [n]+                                                                  _        -> n++                                                         lhs = Fun (cataname @lhs.prefix @nt) [TupleExpr (map fst tps')]+                                                         rhs = App con rargs+                                                     in  [Decl lhs rhs Set.empty Set.empty] +                                                 CommonTypes.OrdSet tp ->+                                                     let entry = SimpleExpr (semname @lhs.prefix @nt (identifier "Entry"))+                                                         nil   = SimpleExpr (semname @lhs.prefix @nt (identifier "Nil" ))+                                                         arg   = SimpleExpr "set"+                                                         rentry = case tp of+                                                                   NT t _ _ -> let t' = maybe t id (deforestedNt t)+                                                                               in App "(.)" [entry, SimpleExpr $ cataname @lhs.prefix t']+                                                                   _        -> entry+                                                         lhs = Fun (cataname @lhs.prefix @nt) [arg]+                                                         rhs = (App "Data.Set.foldr" [rentry,nil,arg])+                                                     in  [Decl lhs rhs Set.empty Set.empty]+                                                 CommonTypes.IntSet ->+                                                     let entry = SimpleExpr (semname @lhs.prefix @nt (identifier "Entry"))+                                                         nil   = SimpleExpr (semname @lhs.prefix @nt (identifier "Nil" ))+                                                         arg   = SimpleExpr "set"+                                                         lhs = Fun (cataname @lhs.prefix @nt) [arg]+                                                         rhs = (App "Data.IntSet.foldr" [entry,nil,arg])+                                                     in  [Decl lhs rhs Set.empty Set.empty]+                               in  Comment "cata" :+                                   (if @lhs.o_sig then [tSig] else []) +++                                   maybe @prods.cataAlts special (lookup @nt @lhs.typeSyns)++ATTR CProductions     [ | | cataAlts : {Decls} ]+ATTR CProduction      [ | | cataAlt  : {Decl}  ]+++SEM CProductions+  | Cons lhs.cataAlts = @hd.cataAlt : @tl.cataAlts+  | Nil  lhs.cataAlts = []++SEM CProduction+  | CProduction lhs.cataAlt = let lhs = Fun (cataname @lhs.prefix @lhs.nt) [lhs_pat]+                                  lhs_pat = App (conname @lhs.o_rename @lhs.nt @con)+                                                 (map (\(n,_,_) -> SimpleExpr $ locname @lhs.options $ n) @loc.firstOrderChildren)+                                  rhs = App (semname @lhs.prefix @lhs.nt @con)+                                             (map argument @loc.firstOrderChildren)+                                  argument (nm,NT tp _ _,_) = App (cataname @lhs.prefix tp)+                                                                   [SimpleExpr (locname @lhs.options nm)]+                                  argument (nm, _,_)    = SimpleExpr (locname @lhs.options nm)+                               in Decl lhs rhs Set.empty Set.empty+++-------------------------------------------------------------------------------+-- Collect names of generated stuff+-------------------------------------------------------------------------------++ATTR CProductions CProduction CVisits CVisit [ | | semNames USE {++} {[]} : {[String]} ]++{-+SEM CProduction+  | CProduction+      lhs.semNames = [cataname @lhs.prefix @lhs.nt] ++ @visits.semNames+-}++SEM CVisit+  | CVisit+      lhs.semNames = [@loc.funcname]+
src-ag/HsToken.ag view
@@ -1,33 +1,33 @@-imports
-{
-import CommonTypes
-import UU.Scanner.Position(Pos)
-}
-
-DATA HsTokensRoot
-   | HsTokensRoot tokens : HsTokens
-
-TYPE HsTokens = [HsToken]
-
-DATA HsToken
-   | AGLocal   var   : {Identifier}    -- either a local or a terminal
-               pos   : {Pos}
-               rdesc : {Maybe String}  -- description of the rule the local reference appears in
-
-   | AGField   field : {Identifier}    -- Misnomer: this is actually a reference to an attribute, not a terminal!
-               attr  : {Identifier}
-               pos   : {Pos}
-               rdesc : {Maybe String}  -- description of the rule the attribute reference appears in
-
-   | HsToken   value : {String}
-               pos   : {Pos}
-   | CharToken value : {String}
-               pos   : {Pos}
-   | StrToken  value : {String}
-               pos   : {Pos}
-   | Err       mesg  : {String}
-               pos   : {Pos}
-
-
-
-DERIVING HsToken : Show
+imports+{+import CommonTypes+import UU.Scanner.Position(Pos)+}++DATA HsTokensRoot+   | HsTokensRoot tokens : HsTokens++TYPE HsTokens = [HsToken]++DATA HsToken+   | AGLocal   var   : {Identifier}    -- either a local or a terminal+               pos   : {Pos}+               rdesc : {Maybe String}  -- description of the rule the local reference appears in++   | AGField   field : {Identifier}    -- Misnomer: this is actually a reference to an attribute, not a terminal!+               attr  : {Identifier}+               pos   : {Pos}+               rdesc : {Maybe String}  -- description of the rule the attribute reference appears in++   | HsToken   value : {String}+               pos   : {Pos}+   | CharToken value : {String}+               pos   : {Pos}+   | StrToken  value : {String}+               pos   : {Pos}+   | Err       mesg  : {String}+               pos   : {Pos}++++DERIVING HsToken : Show
src-ag/Interfaces.ag view
@@ -1,16 +1,16 @@-imports
-{
-import CommonTypes
-import SequentialTypes
-}
-
-DATA IRoot | IRoot inters:Interfaces
-TYPE Interfaces = [Interface]
-DATA Interface | Interface nt:NontermIdent
-                           cons:{[ConstructorIdent]}
-                           seg:Segments
-TYPE Segments = [Segment]
-DATA Segment | Segment  inh:{[Vertex]}
-                        syn:{[Vertex]}
-                        
-
+imports+{+import CommonTypes+import SequentialTypes+}++DATA IRoot | IRoot inters:Interfaces+TYPE Interfaces = [Interface]+DATA Interface | Interface nt:NontermIdent+                           cons:{[ConstructorIdent]}+                           seg:Segments+TYPE Segments = [Segment]+DATA Segment | Segment  inh:{[Vertex]}+                        syn:{[Vertex]}+                        +
src-ag/KWOrder.ag view
@@ -1,217 +1,217 @@-INCLUDE "AbstractSyntax.ag"
-INCLUDE "HsToken.ag"
-INCLUDE "Expression.ag"
-INCLUDE "Patterns.ag"
-INCLUDE "DistChildAttr.ag"
-INCLUDE "ExecutionPlanPre.ag"
-INCLUDE "ExecutionPlanCommon.ag"
-
-imports
-{
-import AbstractSyntax
-import HsToken
-import Expression
-import Patterns
-import Options
-import PPUtil
-import Pretty
-import Knuth1
-import KennedyWarren
-import ExecutionPlan
-import Data.Maybe
-import Debug.Trace
-import Data.Set(Set)
-import Data.Map(Map)
-import Data.Sequence(Seq)
-import qualified Data.Set as Set
-import qualified Data.Map as Map
-import qualified Data.Sequence as Seq
-import Data.Monoid(mappend,mempty)
-}
-
--------------------------------------------------------------------------------
---         Dependency graph per production
--------------------------------------------------------------------------------
--- Gather vertices
-ATTR HsToken Expression
-     Rule Rules
-     Pattern Patterns
-     Child Children [ | | vertices USE {`Set.union`} {Set.empty} : {Set.Set Vertex} ]
-
--- All vertices from the righthandside of a rule
-SEM  HsToken
-  |  AGLocal lhs.vertices = Set.singleton $ VChild @var
-  |  AGField lhs.vertices = Set.singleton $ VAttr (if      @field == _LHS then Inh
-                                                   else if @field == _LOC then Loc
-                                                   else                        Syn) @field @attr
-
--- Gather vertices for an expression (make a higher order child)
-SEM  Expression
-  |  Expression lhs.vertices = Set.unions $ map (\tok -> vertices_Syn_HsToken
-                                            (wrap_HsToken (sem_HsToken tok) Inh_HsToken)) @tks
-
--- Gather vertices at patterns
-SEM  Pattern
-  |  Alias loc.vertex   = if                  @field == _INST then VChild @attr
-                          else VAttr (if      @field == _LHS  then Syn
-                                      else if @field == _LOC  then Loc
-                                      else                         Inh) @field @attr
-           lhs.vertices = Set.insert @loc.vertex @pat.vertices
-
--- Gather vertices for children
---
--- The behavior for merged children is a bit more complicated (and ignored for now)
-SEM  Child
-  |  Child loc.vertex      = VChild @name
-           loc.synvertices = map (VAttr Syn @name) . Map.keys $ @loc.syn
-           loc.inhvertices = map (VAttr Inh @name) . Map.keys $ @loc.inh
-           lhs.vertices    = case @tp of -- only Nonterminal children need to be in dependency graph
-                                NT _ _ _ -> Set.insert @loc.vertex $ Set.fromList (@loc.synvertices ++ @loc.inhvertices)
-                                _        -> Set.empty
-
--- Add extra vertex for a rule
-SEM  Rule
-  |  Rule loc.vertex   = VRule @loc.rulename
-          lhs.vertices = Set.insert @loc.vertex $ @pattern.vertices `Set.union` @rhs.vertices
-
--- Combine all vertices for a production
-SEM  Production
-  |  Production loc.vertices = @rules.vertices `Set.union` @children.vertices
-
--- Gather edges
-ATTR Rule Rules
-     Child Children [ | | edges USE {`Set.union`} {Set.empty} : {Set.Set Edge} ]
-
--- Gather edges for a rule
-SEM  Rule
-  |  Rule loc.edgesout = map ((,) @loc.vertex) (Set.toList @rhs.vertices)
-          loc.edgesin  = map (flip (,) @loc.vertex) (Set.toList @pattern.vertices)
-          lhs.edges    = Set.fromList $ @loc.edgesout ++ @loc.edgesin
-
--- When a child is defined by a higher order attribute and the late binding option
--- is enabled, we refer to the additional inherited attribute under the hood, hence
--- we need to tell the dependency analysis about this in order to actually have the
--- attribute available when we attach the child.
--- Note that the dependencies on the rule that creates the semantics of the child
--- is handled elsewhere by mapping an "inst"-attribute to the right child vertex.
-SEM Child | Child
-  loc.childIsDeforested = case @tp of
-                            NT _ _ defor -> defor
-                            _            -> False
-  loc.higherOrderEdges = case @kind of
-                           ChildAttr | lateHigherOrderBinding @lhs.options && not @loc.childIsDeforested
-                                        -> [(@loc.vertex, VAttr Inh _LHS idLateBindingAttr)]
-                           _            -> []  -- attribute is not referenced implicitly
-  loc.aroundEdges      = if @loc.hasArounds
-                         then [(@loc.vertex, VAttr Syn _LOC (Ident (getName @name ++ "_around") (getPos @name)))]
-                         else []
-
--- Gather edges for a child
-SEM  Child
-  |  Child loc.edgesout = @loc.higherOrderEdges
-           loc.edgesin  = map (flip (,) @loc.vertex) @loc.synvertices
-           lhs.edges    = Set.fromList (@loc.edgesout ++ @loc.edgesin)
-
--- Add manual attribute dependencies
-ATTR Nonterminals Nonterminal [ manualDeps : AttrOrderMap | | ]
-ATTR Productions Production [ manualDeps : {Map ConstructorIdent (Set Dependency)} | | ]
-
-SEM Grammar | Grammar         nonts.manualDeps = @manualAttrOrderMap
-SEM Nonterminal | Nonterminal prods.manualDeps = Map.findWithDefault Map.empty @nt @lhs.manualDeps
-SEM Production | Production
-  loc.manualDeps   = Map.findWithDefault Set.empty @con @lhs.manualDeps
-  loc.manualEdges  = Set.map depToEdge @loc.manualDeps
-
-{
--- a depends on b, thus a is a successor of b
-depToEdge :: Dependency -> Edge
-depToEdge (Dependency a b) = (occToVertex False b, occToVertex True a)
-
-occToVertex :: Bool -> Occurrence -> Vertex
-occToVertex _ (OccRule nm) = VRule nm
-occToVertex isDependency (OccAttr c a)
-  | c == _LOC  = VAttr Syn c a   -- local attributes are treated as synthesized attrs of 'loc'
-  | c == _INST = VChild a        -- higher-order attributes are treated as children
-  | otherwise  = VAttr kind c a where
-      kind | isDependency && c == _LHS     = Inh     -- these dependencies have the property that
-           | isDependency && c /= _LHS     = Syn     -- they can all be faked by writing a 'const' rule
-           | not isDependency && c == _LHS = Syn     -- Perhaps we should also allow other forms of dependencies
-           | not isDependency && c /= _LHS = Inh     -- as well, such as two inherited attributes, which would
-                                                     -- force them in different visits
-}
-
--- Combine all edges for a production
-SEM  Production
-  |  Production loc.edges = @rules.edges `Set.union` @children.edges
-
--- Find all child nonterminal names for a production
-ATTR Child Children [ | | nontnames USE {++} {[]} : {[(Identifier, Identifier)]}]
-
-SEM  Child
-  |  Child lhs.nontnames = case @tp of
-                             NT nont _ _ -> [(@name, nont)]
-                             _           -> []
-
--- Return a dependency graph for each production
-ATTR Production  [ | | depgraph : {ProdDependencyGraph} ]
-ATTR Productions [ | | depgraph USE {:} {[]} : {[ProdDependencyGraph]} ]
-
-SEM  Production
-  |  Production lhs.depgraph  = ProdDependencyGraph { pdgVertices    = Set.toList @loc.vertices
-                                                    , pdgEdges       = Set.toList @loc.edges
-                                                    , pdgRules       = @rules.erules
-                                                    , pdgChilds      = @children.echilds
-                                                    , pdgProduction  = @con
-                                                    , pdgChildMap    = @children.nontnames
-                                                    , pdgConstraints = @constraints
-                                                    , pdgParams      = @params }
-
--------------------------------------------------------------------------------
---         Dependency graph per nonterminal
--------------------------------------------------------------------------------
-
--- Vertices are just all inherited and syntesized attributes
-SEM  Nonterminal
-  |  Nonterminal loc.synvertices = map (VAttr Syn @nt) . Map.keys $ @syn
-                 loc.inhvertices = map (VAttr Inh @nt) . Map.keys $ @inh
-                 loc.vertices    = @loc.synvertices ++ @loc.inhvertices
-
--- Construct nonterminal dependency graph for production
-SEM  Nonterminal
-  |  Nonterminal loc.nontgraph = NontDependencyGraph { ndgVertices = @loc.vertices
-                                                     , ndgEdges    = [] }
-
--- Create dependency information for nonterminal and pass it upwards
-ATTR Nonterminal  [ | | depinfo : {NontDependencyInformation} ]
-ATTR Nonterminals [ | | depinfo USE {:} {[]} : {[NontDependencyInformation]} ]
-
-SEM  Nonterminal
-  |  Nonterminal lhs.depinfo = NontDependencyInformation { ndiNonterminal = @nt
-                                                         , ndiParams      = @params
-                                                         , ndiInh         = Map.keys @inh
-                                                         , ndiSyn         = Map.keys @syn
-                                                         , ndiDepGraph    = @loc.nontgraph
-                                                         , ndiProds       = @prods.depgraph
-                                                         , ndiRecursive   = @loc.recursive
-                                                         , ndiHoInfo      = @loc.hoInfo
-                                                         , ndiClassCtxs   = @loc.classContexts
-                                                         }
-
--------------------------------------------------------------------------------
---         Call the kennedy-warren algorithm
--------------------------------------------------------------------------------
-ATTR Grammar [ | | output : {ExecutionPlan}
-                   depgraphs : {PP_Doc}
-                   visitgraph : {PP_Doc}
-                   errors : {Seq Error} ]
-
-SEM  Grammar
-  |  Grammar  (lhs.output, lhs.depgraphs, lhs.visitgraph, lhs.errors)
-                = let lazyPlan = kennedyWarrenLazy @lhs.options @wrappers @nonts.depinfo @typeSyns @derivings
-                  in if visit @lhs.options && withCycle @lhs.options
-                     then case kennedyWarrenOrder @lhs.options @wrappers @nonts.depinfo @typeSyns @derivings of
-                            Left e        -> (lazyPlan,empty,empty,Seq.singleton e)
-                            Right (o,d,v) -> (o,d,v,Seq.empty)
-                     else (lazyPlan,empty,empty,Seq.empty)
-
-
+INCLUDE "AbstractSyntax.ag"+INCLUDE "HsToken.ag"+INCLUDE "Expression.ag"+INCLUDE "Patterns.ag"+INCLUDE "DistChildAttr.ag"+INCLUDE "ExecutionPlanPre.ag"+INCLUDE "ExecutionPlanCommon.ag"++imports+{+import AbstractSyntax+import HsToken+import Expression+import Patterns+import Options+import PPUtil+import Pretty+import Knuth1+import KennedyWarren+import ExecutionPlan+import Data.Maybe+import Debug.Trace+import Data.Set(Set)+import Data.Map(Map)+import Data.Sequence(Seq)+import qualified Data.Set as Set+import qualified Data.Map as Map+import qualified Data.Sequence as Seq+import Data.Monoid(mappend,mempty)+}++-------------------------------------------------------------------------------+--         Dependency graph per production+-------------------------------------------------------------------------------+-- Gather vertices+ATTR HsToken Expression+     Rule Rules+     Pattern Patterns+     Child Children [ | | vertices USE {`Set.union`} {Set.empty} : {Set.Set Vertex} ]++-- All vertices from the righthandside of a rule+SEM  HsToken+  |  AGLocal lhs.vertices = Set.singleton $ VChild @var+  |  AGField lhs.vertices = Set.singleton $ VAttr (if      @field == _LHS then Inh+                                                   else if @field == _LOC then Loc+                                                   else                        Syn) @field @attr++-- Gather vertices for an expression (make a higher order child)+SEM  Expression+  |  Expression lhs.vertices = Set.unions $ map (\tok -> vertices_Syn_HsToken+                                            (wrap_HsToken (sem_HsToken tok) Inh_HsToken)) @tks++-- Gather vertices at patterns+SEM  Pattern+  |  Alias loc.vertex   = if                  @field == _INST then VChild @attr+                          else VAttr (if      @field == _LHS  then Syn+                                      else if @field == _LOC  then Loc+                                      else                         Inh) @field @attr+           lhs.vertices = Set.insert @loc.vertex @pat.vertices++-- Gather vertices for children+--+-- The behavior for merged children is a bit more complicated (and ignored for now)+SEM  Child+  |  Child loc.vertex      = VChild @name+           loc.synvertices = map (VAttr Syn @name) . Map.keys $ @loc.syn+           loc.inhvertices = map (VAttr Inh @name) . Map.keys $ @loc.inh+           lhs.vertices    = case @tp of -- only Nonterminal children need to be in dependency graph+                                NT _ _ _ -> Set.insert @loc.vertex $ Set.fromList (@loc.synvertices ++ @loc.inhvertices)+                                _        -> Set.empty++-- Add extra vertex for a rule+SEM  Rule+  |  Rule loc.vertex   = VRule @loc.rulename+          lhs.vertices = Set.insert @loc.vertex $ @pattern.vertices `Set.union` @rhs.vertices++-- Combine all vertices for a production+SEM  Production+  |  Production loc.vertices = @rules.vertices `Set.union` @children.vertices++-- Gather edges+ATTR Rule Rules+     Child Children [ | | edges USE {`Set.union`} {Set.empty} : {Set.Set Edge} ]++-- Gather edges for a rule+SEM  Rule+  |  Rule loc.edgesout = map ((,) @loc.vertex) (Set.toList @rhs.vertices)+          loc.edgesin  = map (flip (,) @loc.vertex) (Set.toList @pattern.vertices)+          lhs.edges    = Set.fromList $ @loc.edgesout ++ @loc.edgesin++-- When a child is defined by a higher order attribute and the late binding option+-- is enabled, we refer to the additional inherited attribute under the hood, hence+-- we need to tell the dependency analysis about this in order to actually have the+-- attribute available when we attach the child.+-- Note that the dependencies on the rule that creates the semantics of the child+-- is handled elsewhere by mapping an "inst"-attribute to the right child vertex.+SEM Child | Child+  loc.childIsDeforested = case @tp of+                            NT _ _ defor -> defor+                            _            -> False+  loc.higherOrderEdges = case @kind of+                           ChildAttr | lateHigherOrderBinding @lhs.options && not @loc.childIsDeforested+                                        -> [(@loc.vertex, VAttr Inh _LHS idLateBindingAttr)]+                           _            -> []  -- attribute is not referenced implicitly+  loc.aroundEdges      = if @loc.hasArounds+                         then [(@loc.vertex, VAttr Syn _LOC (Ident (getName @name ++ "_around") (getPos @name)))]+                         else []++-- Gather edges for a child+SEM  Child+  |  Child loc.edgesout = @loc.higherOrderEdges+           loc.edgesin  = map (flip (,) @loc.vertex) @loc.synvertices+           lhs.edges    = Set.fromList (@loc.edgesout ++ @loc.edgesin)++-- Add manual attribute dependencies+ATTR Nonterminals Nonterminal [ manualDeps : AttrOrderMap | | ]+ATTR Productions Production [ manualDeps : {Map ConstructorIdent (Set Dependency)} | | ]++SEM Grammar | Grammar         nonts.manualDeps = @manualAttrOrderMap+SEM Nonterminal | Nonterminal prods.manualDeps = Map.findWithDefault Map.empty @nt @lhs.manualDeps+SEM Production | Production+  loc.manualDeps   = Map.findWithDefault Set.empty @con @lhs.manualDeps+  loc.manualEdges  = Set.map depToEdge @loc.manualDeps++{+-- a depends on b, thus a is a successor of b+depToEdge :: Dependency -> Edge+depToEdge (Dependency a b) = (occToVertex False b, occToVertex True a)++occToVertex :: Bool -> Occurrence -> Vertex+occToVertex _ (OccRule nm) = VRule nm+occToVertex isDependency (OccAttr c a)+  | c == _LOC  = VAttr Syn c a   -- local attributes are treated as synthesized attrs of 'loc'+  | c == _INST = VChild a        -- higher-order attributes are treated as children+  | otherwise  = VAttr kind c a where+      kind | isDependency && c == _LHS     = Inh     -- these dependencies have the property that+           | isDependency && c /= _LHS     = Syn     -- they can all be faked by writing a 'const' rule+           | not isDependency && c == _LHS = Syn     -- Perhaps we should also allow other forms of dependencies+           | not isDependency && c /= _LHS = Inh     -- as well, such as two inherited attributes, which would+                                                     -- force them in different visits+}++-- Combine all edges for a production+SEM  Production+  |  Production loc.edges = @rules.edges `Set.union` @children.edges++-- Find all child nonterminal names for a production+ATTR Child Children [ | | nontnames USE {++} {[]} : {[(Identifier, Identifier)]}]++SEM  Child+  |  Child lhs.nontnames = case @tp of+                             NT nont _ _ -> [(@name, nont)]+                             _           -> []++-- Return a dependency graph for each production+ATTR Production  [ | | depgraph : {ProdDependencyGraph} ]+ATTR Productions [ | | depgraph USE {:} {[]} : {[ProdDependencyGraph]} ]++SEM  Production+  |  Production lhs.depgraph  = ProdDependencyGraph { pdgVertices    = Set.toList @loc.vertices+                                                    , pdgEdges       = Set.toList @loc.edges+                                                    , pdgRules       = @rules.erules+                                                    , pdgChilds      = @children.echilds+                                                    , pdgProduction  = @con+                                                    , pdgChildMap    = @children.nontnames+                                                    , pdgConstraints = @constraints+                                                    , pdgParams      = @params }++-------------------------------------------------------------------------------+--         Dependency graph per nonterminal+-------------------------------------------------------------------------------++-- Vertices are just all inherited and syntesized attributes+SEM  Nonterminal+  |  Nonterminal loc.synvertices = map (VAttr Syn @nt) . Map.keys $ @syn+                 loc.inhvertices = map (VAttr Inh @nt) . Map.keys $ @inh+                 loc.vertices    = @loc.synvertices ++ @loc.inhvertices++-- Construct nonterminal dependency graph for production+SEM  Nonterminal+  |  Nonterminal loc.nontgraph = NontDependencyGraph { ndgVertices = @loc.vertices+                                                     , ndgEdges    = [] }++-- Create dependency information for nonterminal and pass it upwards+ATTR Nonterminal  [ | | depinfo : {NontDependencyInformation} ]+ATTR Nonterminals [ | | depinfo USE {:} {[]} : {[NontDependencyInformation]} ]++SEM  Nonterminal+  |  Nonterminal lhs.depinfo = NontDependencyInformation { ndiNonterminal = @nt+                                                         , ndiParams      = @params+                                                         , ndiInh         = Map.keys @inh+                                                         , ndiSyn         = Map.keys @syn+                                                         , ndiDepGraph    = @loc.nontgraph+                                                         , ndiProds       = @prods.depgraph+                                                         , ndiRecursive   = @loc.recursive+                                                         , ndiHoInfo      = @loc.hoInfo+                                                         , ndiClassCtxs   = @loc.classContexts+                                                         }++-------------------------------------------------------------------------------+--         Call the kennedy-warren algorithm+-------------------------------------------------------------------------------+ATTR Grammar [ | | output : {ExecutionPlan}+                   depgraphs : {PP_Doc}+                   visitgraph : {PP_Doc}+                   errors : {Seq Error} ]++SEM  Grammar+  |  Grammar  (lhs.output, lhs.depgraphs, lhs.visitgraph, lhs.errors)+                = let lazyPlan = kennedyWarrenLazy @lhs.options @wrappers @nonts.depinfo @typeSyns @derivings+                  in if visit @lhs.options && withCycle @lhs.options+                     then case kennedyWarrenOrder @lhs.options @wrappers @nonts.depinfo @typeSyns @derivings of+                            Left e        -> (lazyPlan,empty,empty,Seq.singleton e)+                            Right (o,d,v) -> (o,d,v,Seq.empty)+                     else (lazyPlan,empty,empty,Seq.empty)++
src-ag/LOAG/Order.ag view
@@ -1,435 +1,435 @@-INCLUDE "AbstractSyntax"
-INCLUDE "Patterns"
-INCLUDE "CodeSyntax"
-INCLUDE "Expression"
-INCLUDE "HsToken"
-INCLUDE "LOAG/Rep"
-INCLUDE "LOAG/Prepare"
-INCLUDE "ExecutionPlanCommon"
-
-MODULE {LOAG.Order}
-{}
-{}
-imports{
-import qualified Data.Array as A
-import qualified Data.Map as Map
-import qualified Data.IntMap as IMap
-import qualified Data.Set as Set
-import qualified Data.IntSet as IS
-import qualified Data.Sequence as Seq
-import qualified CommonTypes as CT
-import Control.Monad (forM,when)
-import Control.Monad.ST
-import Data.Maybe(catMaybes)
-import Data.Monoid(mappend,mempty)
-import Data.STRef
-import AbstractSyntax
-import qualified LOAG.AOAG as   AOAG
-import LOAG.Common
-import LOAG.Chordal
-import LOAG.Rep
-import LOAG.Graphs
-import CodeSyntax
-import Data.Maybe (isJust, fromJust)
-import ExecutionPlan
-import GrammarInfo
-import HsToken (HsToken(..))
-import Pretty
-import qualified System.IO as IO
-import           System.IO.Unsafe
-}
-
-{
-fst' (a,_,_) = a
-snd' (_,b,_) = b
-trd' (_,_,c) = c
-}
-
-ATTR Grammar [ | | 
-    output   : ExecutionPlan
-    ads      : {Maybe PP_Doc}
-    errors   : {Seq.Seq Error}]
-
-SEM Grammar | Grammar
-    lhs.errors = either Seq.singleton (const Seq.empty) @loc.schedRes
-    lhs.ads    = case either (const []) trd' @loc.schedRes of
-                    []  -> Nothing 
-                    ads -> Just $ ppAds @lhs.options @nonts.pmp ads 
-    lhs.output = ExecutionPlan @nonts.enonts @typeSyns @wrappers @derivings
-
-    nonts.sched   = either (const Map.empty) snd' @loc.schedRes
-    nonts.tdp     = either (error "no tdp") (fromJust.fst') @loc.schedRes
-
-    loc.schedRes =   if CT.loag @lhs.options
-                        then if CT.aoag @lhs.options
-                                then AOAG.schedule @smf.self @self @loc.ag @nonts.ads
-                                else @loc.loagRes
-                        else Right (Nothing,Map.empty,[])
-    loc.loagRes = let putStrLn s = when (verbose @lhs.options) (IO.putStrLn s)
-                  in  Right $ unsafePerformIO $ scheduleLOAG @loc.ag putStrLn @lhs.options
-    loc.ag = repToAg @smf.self @self
-
-    nonts.res_ads = either (const []) trd' @loc.schedRes
-
--- Gather the fake dependencies from the ads result of AOAG
-
-ATTR Nonterminals Nonterminal Productions Production
-    [ res_ads : {[Edge]} || ]
-ATTR Nonterminals Nonterminal 
-    [ || fdps USE {Map.union} {Map.empty} : AttrOrderMap ]
-
-SEM Nonterminal | Nonterminal
-    lhs.fdps    = Map.singleton @nt @prods.fdps
-
-ATTR Productions Production [ || 
-    fdps USE {Map.union} {Map.empty} : {Map.Map ConstructorIdent (Set Dependency)} ]
-
-SEM Production | Production
-    lhs.fdps    = 
-      let op d@(f,t) ds
-            | fst (argsOf $ findWithErr @lhs.pmpf "fdps" f) == (@lhs.dty,getName @con)
-                = Set.insert (edgeToDep @lhs.pmpf d) ds
-            | otherwise                     
-                = ds
-      in Map.singleton @con $ foldr op Set.empty @lhs.res_ads
-{
-data AltAttr = AltAttr Identifier Identifier Bool
-               deriving (Eq, Ord, Show)
-
-edgeToDep :: PMP -> Edge -> Dependency
-edgeToDep pmp (f,t) = 
-    Dependency (OccAttr (identifier f1) (identifier i1)) 
-               (OccAttr (identifier f2) (identifier i2))
-    where (MyOccurrence (_,f1) (i1,_),MyOccurrence (_,f2) (i2,_))
-            = (findWithErr pmp "edgeToDep" f, 
-               findWithErr pmp "edgeToDep" t) 
-
-ppAds :: Options -> PMP -> [Edge] -> PP_Doc
-ppAds opts pmp = foldr ((>-<) . ppEdge opts pmp) empty
-
-ppEdge :: Options -> PMP -> Edge -> PP_Doc
-ppEdge opts pmp (f,t) = 
-    text sem    >#< text (show ty) >|< " | " >|< text p >|< "   "
-                >|< ppOcc pmp f >|< text " < " >|< ppOcc pmp t
- where (MyOccurrence ((ty,p),_) _) = pmp Map.! f
-       sem | lcKeywords opts = "sem"
-           | otherwise       = "SEM"
-   
-ppOcc :: PMP -> Vertex -> PP_Doc
-ppOcc pmp v = text f >|< text "." >|< fst a
- where (MyOccurrence ((t,p),f) a) = findWithErr pmp "ppOcc" v
-
-}
-
--- Construct Execution Plan
-
-ATTR Nonterminals Nonterminal [ 
-    visMapf                         : {IMap.IntMap Int}
-    tdp                             : TDPRes ||
-    enonts USE {(++)} {[]}          : ENonterminals
-    visMap USE {IMap.union} {IMap.empty}  : {IMap.IntMap Int}]
-
-SEM Grammar
-  | Grammar nonts.visMapf = @nonts.visMap
-            nonts.visitnum = 0
-
-SEM Nonterminal
-  | Nonterminal
-        loc.initial = @lhs.visitnum 
-        loc.vnums   = zipWith const [@loc.initial..] @segments
-        loc.initialVisit = @vnums
-        loc.nextVis = Map.fromList $ (@loc.initial + length @vnums, NoneVis)
-                                   : [(v, OneVis v) | v <- @vnums ]
-        loc.prevVis = Map.fromList $ (@loc.initial, NoneVis)
-                                   : [(v+1, OneVis v) | v <- @vnums ]
-        loc.visMap  = let op vnr (MySegment visnr ins syns _ _) =
-                            IMap.fromList $ zip syns (repeat vnr)
-                       in IMap.unions $ zipWith op [@loc.initial..] @mysegments
-        lhs.enonts = [ENonterminal 
-                        @nt
-                        @params 
-                        @loc.classContexts
-                        @loc.initial
-                        @loc.initialVisit
-                        @loc.nextVis
-                        @loc.prevVis
-                        @prods.eprods
-                        @loc.recursive
-                        @loc.hoInfo ]
-
-ATTR Productions Production [
-    visMapf                 : {IMap.IntMap Int} 
-    tdp                     : TDPRes ||
-    eprods USE {(++)} {[]}  : EProductions ]
-
-SEM Production 
-  | Production
-        segs.ruleMap  = @rules.ruleMap
-        segs.done     = (Set.empty, Set.empty, Set.empty, Set.empty)
-        loc.intros  = let intro (Child nm _ kind)
-                            | kind == ChildAttr = Nothing
-                            | otherwise = Just $ ChildIntro nm
-                        in catMaybes $ map intro @children.self
-        lhs.eprods = 
-            let ((Visit ident from to inh syn steps kind):vss) = @segs.evisits
-                steps' = @loc.intros ++ steps
-                visits | null @segs.evisits = []
-                       | otherwise = 
-                            ((Visit ident from to inh syn steps' kind):vss)
-             in [EProduction
-                        @con
-                        @params
-                        @constraints
-                        @rules.erules
-                        @children.echilds
-                        visits ]
-
-ATTR Nonterminals Nonterminal Productions Production MySegments MySegment
-        [ | visitnum : Int |  ]
-
--- Visit nums should be the same for each production, but different globally
-SEM Productions
-  | Cons tl.visitnum  = @lhs.visitnum
-         lhs.visitnum = @hd.visitnum
-
-SEM MySegment | MySegment +visitnum = (+1)
-ATTR MySegments MySegment [
-    -- maps which attribute occurrence is calculated in which visit
-    visMapf : {IMap.IntMap Int} | | ]
-
-ATTR MySegments MySegment [
-    ps      : PLabel 
-    ruleMap : {Map.Map MyOccurrence Identifier}
-    nmprf   : NMP_R
-    options : {Options}
-    tdp     : TDPRes
-    done    : { (Set.Set MyOccurrence, Set.Set FLabel
-                , Set.Set Identifier, Set.Set (FLabel,Int))}
-    ||]
-
-ATTR MySegments [|| evisits USE {:} {[]} : {Visits}]
-ATTR MySegment  [|| 
-    evisits : {Visit}
-    -- synthesized attribute occurrences of this segment
-    synsO   : {[Int]}
-    visnr   : Int
-    done    : { (Set.Set MyOccurrence, Set.Set FLabel
-                ,Set.Set Identifier, Set.Set (FLabel,Int))}]
-
-SEM MySegments
-    | Cons  hd.done = @lhs.done
-            tl.done = @hd.done
-
-SEM MySegment 
-  | MySegment 
-      loc.inhs = Map.keysSet$ Map.unions $ map (vertexToAttr @lhs.nmp) @inhAttr
-      loc.syns = Map.keysSet$ Map.unions $ map (vertexToAttr @lhs.nmp) @synAttr
-      loc.inhsO= maybe (error "segment not instantiated") id @inhOccs
-      loc.synsO= maybe (error "segment not instantiated") id @synOccs
-      lhs.visnr= @visnr
-      loc.kind = if monadic @lhs.options then VisitMonadic else VisitPure True
-      lhs.evisits = Visit @lhs.visitnum @lhs.visitnum (@lhs.visitnum+1)
-                          @loc.inhs @loc.syns @loc.steps @loc.kind
-      loc.steps   = if monadic @lhs.options
-                        then [Sim @loc.vss] else [PureGroup @loc.vss True]
-      (loc.vss,lhs.done) = (runST $ getVss @lhs.done @lhs.ps @lhs.tdp @synsO 
-                            @lhs.lfpf @lhs.nmprf @lhs.pmpf @lhs.pmprf @lhs.fty
-                            @lhs.visMapf @lhs.ruleMap @lhs.hoMapf)
-
-{
-getVss (done,intros,rules,vnrs) ps tdp synsO lfp nmpr pmp pmpr fty visMap ruleMap hoMap = do
-    ref   <- newSTRef done
-    introed   <- newSTRef intros
-    ruleref   <- newSTRef rules 
-    vnrsref   <- newSTRef vnrs
-    lists <- forM synsO (visit ref introed ruleref vnrsref . (pmp Map.!))
-    done  <- readSTRef ref
-    intros  <- readSTRef introed
-    rules  <- readSTRef ruleref
-    vnrs  <- readSTRef vnrsref 
-    return (concat lists, (done, intros, rules, vnrs))
- where 
-    hochildren = maybe Set.empty id $ Map.lookup ps hoMap
-    visit ref introed ruleref vnrsref o@(MyOccurrence (_,f) (_,d)) = do
-        visited <- readSTRef ref
-        if (o `Set.member` visited) 
-         then return [] -- already visited
-         else do        -- prevent doubles
-          modifySTRef ref (Set.insert o)
-          if inOutput
-           then do -- has to be calculated in this sequence
-                rest' <- rest
-                locs' <- locs
-                sem'  <- sem o
-                return $ (rest' ++ locs' ++ sem')
-           else if "lhs" == (snd $ argsOf o)
-                 then return [] -- inherited of parent, nothing todo
-                 else do   -- other input occurrence, perform visit
-                    locs' <- locs
-                    rest' <- rest
-                    visit'<- toVisit o
-                    return (rest' ++ locs' ++ visit')
-     where preds  = maybe [] (IS.toList . (tdp A.!)) $ Map.lookup o pmpr
-           rest   = forM preds (visit ref introed ruleref vnrsref. (pmp Map.!)) 
-                        >>= (return . concat)
-           free   = maybe [] (Set.toList) $ Map.lookup o lfp
-           locs   = forM free (visit ref introed ruleref vnrsref)
-                        >>= (return . concat)
-           sem o  = do  rules <- readSTRef ruleref 
-                        if r `Set.member` rules
-                          then return []
-                          else do   writeSTRef ruleref (r `Set.insert` rules) 
-                                    return [Sem r]
-            where r = maybe (error "ruleMap") id $ Map.lookup o ruleMap
-           inOutput = f == "lhs" && d == Syn || f /= "lhs" && d == Inh
-           toVisit o = do
-             vnrs <- readSTRef vnrsref 
-             if (child,visnr) `Set.member` vnrs
-              then return []
-              else writeSTRef vnrsref ((child,visnr) `Set.insert` vnrs) >>
-                   if child `Set.member` hochildren 
-                   then do intros <- readSTRef introed
-                           case child `Set.member` intros of
-                            True    -> return [cvisit]
-                            False   -> do
-                                writeSTRef introed (Set.insert child intros)
-                                let occ = (ps,"inst") >.< (child, AnyDir)
-                                    preds = Set.toList $ setConcatMap rep $ 
-                                                        lfp Map.! occ
-                                    rep :: MyOccurrence -> Set.Set MyOccurrence 
-                                    rep occ | isLoc occ   = Set.insert occ $ 
-                                                setConcatMap rep $ lfp Map.! occ
-                                            | otherwise   = Set.singleton occ
-                                rest <- forM preds 
-                                            (visit ref introed ruleref vnrsref)
-                                sem' <- sem occ
-                                return $ (concat rest) ++
-                                         sem' ++
-                                         [ChildIntro (identifier child)] ++
-                                         [cvisit]
-                   else return [cvisit]
-             where  cvisit= ChildVisit (identifier child) ntid visnr
-                    child = snd $ argsOf o
-                    ntid  = ((\(NT name _ _ )-> name) . fromMyTy) nt 
-                    visnr = (\x-> visMap IMap.! x) (nmpr Map.! (nt <.> attr o))
-                    nt    = fty Map.! (ps,child)
-}
-
-ATTR Nonterminals Nonterminal [ 
-        sched : {InterfaceRes} ||]
-SEM  Nonterminal
-  |  Nonterminal  
-        loc.assigned = findWithErr @lhs.sched "could not const. interfaces" 
-                            (getName @nt)
-        loc.mx       = if Map.null @lhs.sched
-                        then 0 
-                        else let mx = fst $ IMap.findMax @loc.assigned in
-                              if even mx then mx else mx + 1 
-        loc.mysegments =  
-            map (\i -> MySegment ((@loc.mx - i) `div` 2)
-                        (maybe [] id $ IMap.lookup i @loc.assigned)
-                        (maybe [] id $ IMap.lookup (i-1) @loc.assigned) 
-                            Nothing Nothing)
-                 [@loc.mx,@loc.mx-2 .. 2]
-        loc.segments = 
-            map (\(MySegment visnr is ss _ _) -> 
-                    CSegment (Map.unions $ map (vertexToAttr @lhs.nmp) is)
-                             (Map.unions $ map (vertexToAttr @lhs.nmp) ss))
-                @loc.mysegments
-
-ATTR Productions Production [ mysegments : MySegments || ]
-SEM Production
-  | Production
-        inst.segs : MySegments
-        --translate from attribute to occurrences
-        inst.segs = 
-            map (\(MySegment visnr inhs syns _ _) -> 
-                   MySegment visnr inhs syns 
-                             (Just $ map (@lhs.pmprf Map.!) $ 
-                                    handAllOut (@loc.ps,"lhs") $ 
-                                        map (@lhs.nmp Map.!) inhs)
-                             (Just $ map (@lhs.pmprf Map.!) $ 
-                                    handAllOut (@loc.ps,"lhs") $ 
-                                        map (@lhs.nmp Map.!) syns)
-                         ) @lhs.mysegments
-
-{
-repToAg :: LOAGRep -> Grammar -> Ag
-repToAg sem (Grammar _ _ _ _ dats _ _ _ _ _ _ _ _ _) = 
-    Ag bounds_s bounds_p de (map toNt dats)
- where
-    pmp  = (pmp_LOAGRep_LOAGRep  sem)
-    pmpr = (pmpr_LOAGRep_LOAGRep sem)
-    nmp  = (nmp_LOAGRep_LOAGRep  sem)
-    nmpr = (nmpr_LOAGRep_LOAGRep sem)
-    genA = gen_LOAGRep_LOAGRep sem
-    fieldM  = fieldMap_LOAGRep_LOAGRep sem
-    genEdge (f,t) = (gen f, gen t)
-    fsInP  = map2F (fsInP_LOAGRep_LOAGRep sem)
-    siblings (f, t) = ofld A.! f == ofld A.! t
-    ofld = (ofld_LOAGRep_LOAGRep sem)
-    sfp  = map2F' (sfp_LOAGRep_LOAGRep sem)
-    afp  = filter inOutput . ap
-    ap   = map (findWithErr pmpr "building ap") . map2F (ap_LOAGRep_LOAGRep  sem)
-    inss = inss_LOAGRep_LOAGRep sem 
-    gen v = genA A.! v
-    ain  = map (findWithErr nmpr "building an") . map2F (ain_LOAGRep_LOAGRep sem)
-    asn  = map (findWithErr nmpr "building an") . map2F (asn_LOAGRep_LOAGRep sem)
-    inOutput = not . inContext 
-    inContext f = (f1 == "lhs" && d1 == Inh || f1 /= "lhs" && d1 == Syn) 
-        where (MyOccurrence (_,f1) (_,d1)) = pmp Map.! f
-    de    = [ e      | p <- ps,   e <- dpe p ]
-    dpe p = [ (findWithErr pmpr "building dpe" a, b) 
-            | b <- ap p, a <- Set.toList $ sfp (findWithErr pmp "fetching sfp" b) ]
-    ps   = ps_LOAGRep_LOAGRep   sem
-    bounds_p = if Map.null pmp then (0,-1) 
-                else (fst $ Map.findMin pmp, fst $ Map.findMax pmp)
-    bounds_s = if Map.null nmp then (0,-1) 
-                else (fst $ Map.findMin nmp, fst $ Map.findMax nmp)
- 
-
-
-    toNt :: Nonterminal -> Nt
-    toNt (Nonterminal ntid _ _ _ prods) = Nt nt dpf dpt 
-            (addD Inh $ ain ty) (addD Syn $ asn ty) (map (toPr ty) prods)
-     where nt  = getName ntid
-           ty  = TyData nt
-           dpt =  [ (as, ai) | ai <- ain ty
-                   , as <- nub$ [ gen s |
-                                  i <- inss A.! ai
-                                , s <- map (pmpr Map.!) $ 
-                                    Set.toList (sfp $ pmp Map.! i)
-                                , siblings (s,i)]]
-           dpf =  [ (ai, as) | as <- asn ty
-                   , ai <- nub$ [ gen i |
-                                  s <- inss A.! as
-                                , i <- map (pmpr Map.!) $
-                                    Set.toList (sfp $ pmp Map.! s)
-                                , siblings (i,s)]]
-           addD d = map (\i -> (i,inss A.! i,d))
-    toPr :: MyType -> Production -> Pr
-    toPr ty (Production con _ _ _ _ _ _) = 
-                Pr p dpp fc_occs (map toFd $ fsInP p)
-     where p = (ty, getName con)
-           dpp = [ (f',t)
-                    | t <- afp p, f <- (Set.toList $ sfp (pmp Map.! t))
-                    , let f' = pmpr Map.! f
-                    , not (siblings (f',t))]
-           fc_occs = foldl' match [] fss
-            where fss = fsInP p
-           match s fs = [ ready (inp, out) lhs | inp <- Set.toList inhs
-                                           , out <- Set.toList syns] ++ s
-            where ((inhs, syns), lhs)
-                               | (snd fs) /= "lhs" = 
-                                    (swap (fieldM Map.! fs),False)
-                               | otherwise = (fieldM Map.! fs, True)
-                  ready e@(f,t) b = (e', genEdge e', b)
-                   where e' = (pmpr Map.! f, pmpr Map.! t)
-    toFd :: (PLabel, FLabel) -> Fd
-    toFd fs@((TyData ty, pr), fd) = Fd fd ty inhs syns
-     where (is,ss) = fieldM Map.! fs
-           inhs = map (((genA A.!) &&& id).(pmpr Map.!))$ Set.toList is
-           syns = map (((genA A.!) &&& id).(pmpr Map.!))$ Set.toList ss
-
-
-}
+INCLUDE "AbstractSyntax"+INCLUDE "Patterns"+INCLUDE "CodeSyntax"+INCLUDE "Expression"+INCLUDE "HsToken"+INCLUDE "LOAG/Rep"+INCLUDE "LOAG/Prepare"+INCLUDE "ExecutionPlanCommon"++MODULE {LOAG.Order}+{}+{}+imports{+import qualified Data.Array as A+import qualified Data.Map as Map+import qualified Data.IntMap as IMap+import qualified Data.Set as Set+import qualified Data.IntSet as IS+import qualified Data.Sequence as Seq+import qualified CommonTypes as CT+import Control.Monad (forM,when)+import Control.Monad.ST+import Data.Maybe(catMaybes)+import Data.Monoid(mappend,mempty)+import Data.STRef+import AbstractSyntax+import qualified LOAG.AOAG as   AOAG+import LOAG.Common+import LOAG.Chordal+import LOAG.Rep+import LOAG.Graphs+import CodeSyntax+import Data.Maybe (isJust, fromJust)+import ExecutionPlan+import GrammarInfo+import HsToken (HsToken(..))+import Pretty+import qualified System.IO as IO+import           System.IO.Unsafe+}++{+fst' (a,_,_) = a+snd' (_,b,_) = b+trd' (_,_,c) = c+}++ATTR Grammar [ | | +    output   : ExecutionPlan+    ads      : {Maybe PP_Doc}+    errors   : {Seq.Seq Error}]++SEM Grammar | Grammar+    lhs.errors = either Seq.singleton (const Seq.empty) @loc.schedRes+    lhs.ads    = case either (const []) trd' @loc.schedRes of+                    []  -> Nothing +                    ads -> Just $ ppAds @lhs.options @nonts.pmp ads +    lhs.output = ExecutionPlan @nonts.enonts @typeSyns @wrappers @derivings++    nonts.sched   = either (const Map.empty) snd' @loc.schedRes+    nonts.tdp     = either (error "no tdp") (fromJust.fst') @loc.schedRes++    loc.schedRes =   if CT.loag @lhs.options+                        then if CT.aoag @lhs.options+                                then AOAG.schedule @smf.self @self @loc.ag @nonts.ads+                                else @loc.loagRes+                        else Right (Nothing,Map.empty,[])+    loc.loagRes = let putStrLn s = when (verbose @lhs.options) (IO.putStrLn s)+                  in  Right $ unsafePerformIO $ scheduleLOAG @loc.ag putStrLn @lhs.options+    loc.ag = repToAg @smf.self @self++    nonts.res_ads = either (const []) trd' @loc.schedRes++-- Gather the fake dependencies from the ads result of AOAG++ATTR Nonterminals Nonterminal Productions Production+    [ res_ads : {[Edge]} || ]+ATTR Nonterminals Nonterminal +    [ || fdps USE {Map.union} {Map.empty} : AttrOrderMap ]++SEM Nonterminal | Nonterminal+    lhs.fdps    = Map.singleton @nt @prods.fdps++ATTR Productions Production [ || +    fdps USE {Map.union} {Map.empty} : {Map.Map ConstructorIdent (Set Dependency)} ]++SEM Production | Production+    lhs.fdps    = +      let op d@(f,t) ds+            | fst (argsOf $ findWithErr @lhs.pmpf "fdps" f) == (@lhs.dty,getName @con)+                = Set.insert (edgeToDep @lhs.pmpf d) ds+            | otherwise                     +                = ds+      in Map.singleton @con $ foldr op Set.empty @lhs.res_ads+{+data AltAttr = AltAttr Identifier Identifier Bool+               deriving (Eq, Ord, Show)++edgeToDep :: PMP -> Edge -> Dependency+edgeToDep pmp (f,t) = +    Dependency (OccAttr (identifier f1) (identifier i1)) +               (OccAttr (identifier f2) (identifier i2))+    where (MyOccurrence (_,f1) (i1,_),MyOccurrence (_,f2) (i2,_))+            = (findWithErr pmp "edgeToDep" f, +               findWithErr pmp "edgeToDep" t) ++ppAds :: Options -> PMP -> [Edge] -> PP_Doc+ppAds opts pmp = foldr ((>-<) . ppEdge opts pmp) empty++ppEdge :: Options -> PMP -> Edge -> PP_Doc+ppEdge opts pmp (f,t) = +    text sem    >#< text (show ty) >|< " | " >|< text p >|< "   "+                >|< ppOcc pmp f >|< text " < " >|< ppOcc pmp t+ where (MyOccurrence ((ty,p),_) _) = pmp Map.! f+       sem | lcKeywords opts = "sem"+           | otherwise       = "SEM"+   +ppOcc :: PMP -> Vertex -> PP_Doc+ppOcc pmp v = text f >|< text "." >|< fst a+ where (MyOccurrence ((t,p),f) a) = findWithErr pmp "ppOcc" v++}++-- Construct Execution Plan++ATTR Nonterminals Nonterminal [ +    visMapf                         : {IMap.IntMap Int}+    tdp                             : TDPRes ||+    enonts USE {(++)} {[]}          : ENonterminals+    visMap USE {IMap.union} {IMap.empty}  : {IMap.IntMap Int}]++SEM Grammar+  | Grammar nonts.visMapf = @nonts.visMap+            nonts.visitnum = 0++SEM Nonterminal+  | Nonterminal+        loc.initial = @lhs.visitnum +        loc.vnums   = zipWith const [@loc.initial..] @segments+        loc.initialVisit = @vnums+        loc.nextVis = Map.fromList $ (@loc.initial + length @vnums, NoneVis)+                                   : [(v, OneVis v) | v <- @vnums ]+        loc.prevVis = Map.fromList $ (@loc.initial, NoneVis)+                                   : [(v+1, OneVis v) | v <- @vnums ]+        loc.visMap  = let op vnr (MySegment visnr ins syns _ _) =+                            IMap.fromList $ zip syns (repeat vnr)+                       in IMap.unions $ zipWith op [@loc.initial..] @mysegments+        lhs.enonts = [ENonterminal +                        @nt+                        @params +                        @loc.classContexts+                        @loc.initial+                        @loc.initialVisit+                        @loc.nextVis+                        @loc.prevVis+                        @prods.eprods+                        @loc.recursive+                        @loc.hoInfo ]++ATTR Productions Production [+    visMapf                 : {IMap.IntMap Int} +    tdp                     : TDPRes ||+    eprods USE {(++)} {[]}  : EProductions ]++SEM Production +  | Production+        segs.ruleMap  = @rules.ruleMap+        segs.done     = (Set.empty, Set.empty, Set.empty, Set.empty)+        loc.intros  = let intro (Child nm _ kind)+                            | kind == ChildAttr = Nothing+                            | otherwise = Just $ ChildIntro nm+                        in catMaybes $ map intro @children.self+        lhs.eprods = +            let ((Visit ident from to inh syn steps kind):vss) = @segs.evisits+                steps' = @loc.intros ++ steps+                visits | null @segs.evisits = []+                       | otherwise = +                            ((Visit ident from to inh syn steps' kind):vss)+             in [EProduction+                        @con+                        @params+                        @constraints+                        @rules.erules+                        @children.echilds+                        visits ]++ATTR Nonterminals Nonterminal Productions Production MySegments MySegment+        [ | visitnum : Int |  ]++-- Visit nums should be the same for each production, but different globally+SEM Productions+  | Cons tl.visitnum  = @lhs.visitnum+         lhs.visitnum = @hd.visitnum++SEM MySegment | MySegment +visitnum = (+1)+ATTR MySegments MySegment [+    -- maps which attribute occurrence is calculated in which visit+    visMapf : {IMap.IntMap Int} | | ]++ATTR MySegments MySegment [+    ps      : PLabel +    ruleMap : {Map.Map MyOccurrence Identifier}+    nmprf   : NMP_R+    options : {Options}+    tdp     : TDPRes+    done    : { (Set.Set MyOccurrence, Set.Set FLabel+                , Set.Set Identifier, Set.Set (FLabel,Int))}+    ||]++ATTR MySegments [|| evisits USE {:} {[]} : {Visits}]+ATTR MySegment  [|| +    evisits : {Visit}+    -- synthesized attribute occurrences of this segment+    synsO   : {[Int]}+    visnr   : Int+    done    : { (Set.Set MyOccurrence, Set.Set FLabel+                ,Set.Set Identifier, Set.Set (FLabel,Int))}]++SEM MySegments+    | Cons  hd.done = @lhs.done+            tl.done = @hd.done++SEM MySegment +  | MySegment +      loc.inhs = Map.keysSet$ Map.unions $ map (vertexToAttr @lhs.nmp) @inhAttr+      loc.syns = Map.keysSet$ Map.unions $ map (vertexToAttr @lhs.nmp) @synAttr+      loc.inhsO= maybe (error "segment not instantiated") id @inhOccs+      loc.synsO= maybe (error "segment not instantiated") id @synOccs+      lhs.visnr= @visnr+      loc.kind = if monadic @lhs.options then VisitMonadic else VisitPure True+      lhs.evisits = Visit @lhs.visitnum @lhs.visitnum (@lhs.visitnum+1)+                          @loc.inhs @loc.syns @loc.steps @loc.kind+      loc.steps   = if monadic @lhs.options+                        then [Sim @loc.vss] else [PureGroup @loc.vss True]+      (loc.vss,lhs.done) = (runST $ getVss @lhs.done @lhs.ps @lhs.tdp @synsO +                            @lhs.lfpf @lhs.nmprf @lhs.pmpf @lhs.pmprf @lhs.fty+                            @lhs.visMapf @lhs.ruleMap @lhs.hoMapf)++{+getVss (done,intros,rules,vnrs) ps tdp synsO lfp nmpr pmp pmpr fty visMap ruleMap hoMap = do+    ref   <- newSTRef done+    introed   <- newSTRef intros+    ruleref   <- newSTRef rules +    vnrsref   <- newSTRef vnrs+    lists <- forM synsO (visit ref introed ruleref vnrsref . (pmp Map.!))+    done  <- readSTRef ref+    intros  <- readSTRef introed+    rules  <- readSTRef ruleref+    vnrs  <- readSTRef vnrsref +    return (concat lists, (done, intros, rules, vnrs))+ where +    hochildren = maybe Set.empty id $ Map.lookup ps hoMap+    visit ref introed ruleref vnrsref o@(MyOccurrence (_,f) (_,d)) = do+        visited <- readSTRef ref+        if (o `Set.member` visited) +         then return [] -- already visited+         else do        -- prevent doubles+          modifySTRef ref (Set.insert o)+          if inOutput+           then do -- has to be calculated in this sequence+                rest' <- rest+                locs' <- locs+                sem'  <- sem o+                return $ (rest' ++ locs' ++ sem')+           else if "lhs" == (snd $ argsOf o)+                 then return [] -- inherited of parent, nothing todo+                 else do   -- other input occurrence, perform visit+                    locs' <- locs+                    rest' <- rest+                    visit'<- toVisit o+                    return (rest' ++ locs' ++ visit')+     where preds  = maybe [] (IS.toList . (tdp A.!)) $ Map.lookup o pmpr+           rest   = forM preds (visit ref introed ruleref vnrsref. (pmp Map.!)) +                        >>= (return . concat)+           free   = maybe [] (Set.toList) $ Map.lookup o lfp+           locs   = forM free (visit ref introed ruleref vnrsref)+                        >>= (return . concat)+           sem o  = do  rules <- readSTRef ruleref +                        if r `Set.member` rules+                          then return []+                          else do   writeSTRef ruleref (r `Set.insert` rules) +                                    return [Sem r]+            where r = maybe (error "ruleMap") id $ Map.lookup o ruleMap+           inOutput = f == "lhs" && d == Syn || f /= "lhs" && d == Inh+           toVisit o = do+             vnrs <- readSTRef vnrsref +             if (child,visnr) `Set.member` vnrs+              then return []+              else writeSTRef vnrsref ((child,visnr) `Set.insert` vnrs) >>+                   if child `Set.member` hochildren +                   then do intros <- readSTRef introed+                           case child `Set.member` intros of+                            True    -> return [cvisit]+                            False   -> do+                                writeSTRef introed (Set.insert child intros)+                                let occ = (ps,"inst") >.< (child, AnyDir)+                                    preds = Set.toList $ setConcatMap rep $ +                                                        lfp Map.! occ+                                    rep :: MyOccurrence -> Set.Set MyOccurrence +                                    rep occ | isLoc occ   = Set.insert occ $ +                                                setConcatMap rep $ lfp Map.! occ+                                            | otherwise   = Set.singleton occ+                                rest <- forM preds +                                            (visit ref introed ruleref vnrsref)+                                sem' <- sem occ+                                return $ (concat rest) +++                                         sem' +++                                         [ChildIntro (identifier child)] +++                                         [cvisit]+                   else return [cvisit]+             where  cvisit= ChildVisit (identifier child) ntid visnr+                    child = snd $ argsOf o+                    ntid  = ((\(NT name _ _ )-> name) . fromMyTy) nt +                    visnr = (\x-> visMap IMap.! x) (nmpr Map.! (nt <.> attr o))+                    nt    = fty Map.! (ps,child)+}++ATTR Nonterminals Nonterminal [ +        sched : {InterfaceRes} ||]+SEM  Nonterminal+  |  Nonterminal  +        loc.assigned = findWithErr @lhs.sched "could not const. interfaces" +                            (getName @nt)+        loc.mx       = if Map.null @lhs.sched+                        then 0 +                        else let mx = fst $ IMap.findMax @loc.assigned in+                              if even mx then mx else mx + 1 +        loc.mysegments =  +            map (\i -> MySegment ((@loc.mx - i) `div` 2)+                        (maybe [] id $ IMap.lookup i @loc.assigned)+                        (maybe [] id $ IMap.lookup (i-1) @loc.assigned) +                            Nothing Nothing)+                 [@loc.mx,@loc.mx-2 .. 2]+        loc.segments = +            map (\(MySegment visnr is ss _ _) -> +                    CSegment (Map.unions $ map (vertexToAttr @lhs.nmp) is)+                             (Map.unions $ map (vertexToAttr @lhs.nmp) ss))+                @loc.mysegments++ATTR Productions Production [ mysegments : MySegments || ]+SEM Production+  | Production+        inst.segs : MySegments+        --translate from attribute to occurrences+        inst.segs = +            map (\(MySegment visnr inhs syns _ _) -> +                   MySegment visnr inhs syns +                             (Just $ map (@lhs.pmprf Map.!) $ +                                    handAllOut (@loc.ps,"lhs") $ +                                        map (@lhs.nmp Map.!) inhs)+                             (Just $ map (@lhs.pmprf Map.!) $ +                                    handAllOut (@loc.ps,"lhs") $ +                                        map (@lhs.nmp Map.!) syns)+                         ) @lhs.mysegments++{+repToAg :: LOAGRep -> Grammar -> Ag+repToAg sem (Grammar _ _ _ _ dats _ _ _ _ _ _ _ _ _) = +    Ag bounds_s bounds_p de (map toNt dats)+ where+    pmp  = (pmp_LOAGRep_LOAGRep  sem)+    pmpr = (pmpr_LOAGRep_LOAGRep sem)+    nmp  = (nmp_LOAGRep_LOAGRep  sem)+    nmpr = (nmpr_LOAGRep_LOAGRep sem)+    genA = gen_LOAGRep_LOAGRep sem+    fieldM  = fieldMap_LOAGRep_LOAGRep sem+    genEdge (f,t) = (gen f, gen t)+    fsInP  = map2F (fsInP_LOAGRep_LOAGRep sem)+    siblings (f, t) = ofld A.! f == ofld A.! t+    ofld = (ofld_LOAGRep_LOAGRep sem)+    sfp  = map2F' (sfp_LOAGRep_LOAGRep sem)+    afp  = filter inOutput . ap+    ap   = map (findWithErr pmpr "building ap") . map2F (ap_LOAGRep_LOAGRep  sem)+    inss = inss_LOAGRep_LOAGRep sem +    gen v = genA A.! v+    ain  = map (findWithErr nmpr "building an") . map2F (ain_LOAGRep_LOAGRep sem)+    asn  = map (findWithErr nmpr "building an") . map2F (asn_LOAGRep_LOAGRep sem)+    inOutput = not . inContext +    inContext f = (f1 == "lhs" && d1 == Inh || f1 /= "lhs" && d1 == Syn) +        where (MyOccurrence (_,f1) (_,d1)) = pmp Map.! f+    de    = [ e      | p <- ps,   e <- dpe p ]+    dpe p = [ (findWithErr pmpr "building dpe" a, b) +            | b <- ap p, a <- Set.toList $ sfp (findWithErr pmp "fetching sfp" b) ]+    ps   = ps_LOAGRep_LOAGRep   sem+    bounds_p = if Map.null pmp then (0,-1) +                else (fst $ Map.findMin pmp, fst $ Map.findMax pmp)+    bounds_s = if Map.null nmp then (0,-1) +                else (fst $ Map.findMin nmp, fst $ Map.findMax nmp)+ +++    toNt :: Nonterminal -> Nt+    toNt (Nonterminal ntid _ _ _ prods) = Nt nt dpf dpt +            (addD Inh $ ain ty) (addD Syn $ asn ty) (map (toPr ty) prods)+     where nt  = getName ntid+           ty  = TyData nt+           dpt =  [ (as, ai) | ai <- ain ty+                   , as <- nub$ [ gen s |+                                  i <- inss A.! ai+                                , s <- map (pmpr Map.!) $ +                                    Set.toList (sfp $ pmp Map.! i)+                                , siblings (s,i)]]+           dpf =  [ (ai, as) | as <- asn ty+                   , ai <- nub$ [ gen i |+                                  s <- inss A.! as+                                , i <- map (pmpr Map.!) $+                                    Set.toList (sfp $ pmp Map.! s)+                                , siblings (i,s)]]+           addD d = map (\i -> (i,inss A.! i,d))+    toPr :: MyType -> Production -> Pr+    toPr ty (Production con _ _ _ _ _ _) = +                Pr p dpp fc_occs (map toFd $ fsInP p)+     where p = (ty, getName con)+           dpp = [ (f',t)+                    | t <- afp p, f <- (Set.toList $ sfp (pmp Map.! t))+                    , let f' = pmpr Map.! f+                    , not (siblings (f',t))]+           fc_occs = foldl' match [] fss+            where fss = fsInP p+           match s fs = [ ready (inp, out) lhs | inp <- Set.toList inhs+                                           , out <- Set.toList syns] ++ s+            where ((inhs, syns), lhs)+                               | (snd fs) /= "lhs" = +                                    (swap (fieldM Map.! fs),False)+                               | otherwise = (fieldM Map.! fs, True)+                  ready e@(f,t) b = (e', genEdge e', b)+                   where e' = (pmpr Map.! f, pmpr Map.! t)+    toFd :: (PLabel, FLabel) -> Fd+    toFd fs@((TyData ty, pr), fd) = Fd fd ty inhs syns+     where (is,ss) = fieldM Map.! fs+           inhs = map (((genA A.!) &&& id).(pmpr Map.!))$ Set.toList is+           syns = map (((genA A.!) &&& id).(pmpr Map.!))$ Set.toList ss+++}
src-ag/LOAG/Prepare.ag view
@@ -1,316 +1,316 @@-INCLUDE "AbstractSyntax.ag"
-INCLUDE "Patterns.ag"
-INCLUDE "CodeSyntax.ag"
-INCLUDE "Expression.ag"
-INCLUDE "HsToken.ag"
-INCLUDE "LOAG/Rep"
-INCLUDE "ExecutionPlanPre"
-
-MODULE {LOAG.Prepare}
-{}
-{}
-
-{
--- | Translating UUAGC types to MyTypes
-drhs f | f == _LHS               = Inh
-       | f == _LOC               = AnyDir
-       | f == _INST              = AnyDir
-       | otherwise               = Syn
-dlhs f | f == _LHS               = Syn
-       | f == _LOC               = AnyDir
-       | f == _INST              = AnyDir
-       | otherwise               = Inh 
-
-depToEdge :: PMP_R -> PLabel -> Dependency -> Edge
-depToEdge pmpr p e = 
-    (findWithErr pmpr "depToEdge" $ MyOccurrence (p,getName f1) (getName i1, drhs f1),
-     findWithErr pmpr "depToEdge" $ MyOccurrence (p,getName f2) (getName i2, dlhs f2))
-    where Dependency (OccAttr f1 i1) (OccAttr f2 i2) = e
-
-vertexToAttr :: NMP -> Vertex -> Attributes
-vertexToAttr nmp v = Map.singleton (identifier a) (fromMyTy ty)
-    where (MyAttribute ty (a,_)) = findWithErr nmp "vertexToAttr" v
-
-}
-
-SEM Grammar | Grammar
-    inst.smf : LOAGRep 
-    loc.initO= if Map.null @nonts.pmp then 1 else fst $ Map.findMin @nonts.pmp
-    inst.smf = 
-        LOAGRep @nonts.ps @nonts.ap @loc.an 
-           @loc.ain @loc.asn @loc.sfp
-           @nonts.pmp @nonts.pmpr @loc.nmp @loc.nmpr
-           (A.array (@loc.initO, @loc.initO + Map.size @nonts.gen)  $ 
-                Map.toList $ @nonts.gen)
-           (A.array (1,Map.size @nonts.inss) $ 
-                Map.toList $ @nonts.inss)
-           (A.array (@loc.initO, @loc.initO + length @nonts.ofld) $ 
-                @nonts.ofld) @nonts.fty @nonts.fieldMap @nonts.fsInP
-    loc.nmp  = Map.fromList $ zip [1..] @loc.atts
-    loc.nmpr = Map.fromList $ zip @loc.atts [1..]
-    loc.an   = Map.unionWith (++) @loc.ain @loc.asn
-    loc.ain  = @nonts.inhs
-    loc.asn  = @nonts.syns
-    loc.atts = concat $ Map.elems @loc.an
-    loc.occs = concat $ Map.elems @nonts.ap
-    nonts.augM = @manualAttrOrderMap
-
--- Collecting the attributes 
-ATTR Nonterminals Nonterminal [
-    augM   : {Map.Map Identifier (Map.Map Identifier (Set.Set Dependency))} ||  
-    inhs USE {Map.union} {Map.empty} : AI_N 
-    syns USE {Map.union} {Map.empty} : AS_N ]
-    
-SEM Nonterminal | Nonterminal 
-    lhs.inhs = let dty = TyData (getName @nt) 
-                in Map.singleton dty (toMyAttr Inh dty @inh)
-    lhs.syns = let dty = TyData (getName @nt) 
-                in Map.singleton dty (toMyAttr Syn dty @syn)
-    prods.augM = case Map.lookup @nt @lhs.augM of
-                    Nothing -> Map.empty 
-                    Just a  -> a
-
--- Adding all attribute sets to the AG type 
---   and sending it all down the abstract tree
-ATTR Nonterminals Nonterminal Productions Production Children Child 
-    MySegments MySegment [
-    ain   : {MyType -> MyAttributes} 
-    asn   : {MyType -> MyAttributes}
-    pmpf  : PMP
-    pmprf : PMP_R
-    lfpf  : SF_P
-    hoMapf: HOMap
-    fty   : FTY
-    nmp   : NMP || ]
-
-SEM Grammar | Grammar
-    nonts.ain  = map2F @loc.ain
-    nonts.asn  = map2F @loc.asn
-    nonts.pmpf  = @nonts.pmp
-    nonts.pmprf = @nonts.pmpr
-    nonts.lfpf  = @nonts.lfp
-    nonts.hoMapf= @nonts.hoMap
-    nonts.ftyf  = @nonts.fty
-    nonts.fty   = @nonts.fty
-
--- Make sure TDP AND LFPRF are passed around correctly to code-generation
-ATTR Nonterminals Nonterminal Productions Production [
-    ftyf: FTY ||]
-
-
--- Calculate the set of production labels
-SEM Grammar | Grammar 
-     loc.ps = @nonts.ps
-ATTR Nonterminals Nonterminal Productions Production [ || 
-    ads USE {(++)} {[]}   : {[Edge]}
-    fieldMap USE {(Map.union)} {Map.empty} : FMap
-    hoMap    USE {(Map.union)} {Map.empty} : HOMap
-    fsInP USE {(Map.union)} {Map.empty} : FsInP]
-
-SEM Nonterminals Nonterminal [ ||
-    ps  USE {(++)} {([])} : {[PLabel]} ]
-SEM Productions [ ||
-    ps  USE {:} {([])} : {[PLabel]}  ]
-SEM Production [ || ps : PLabel ] | Production 
-    loc.ps = (@lhs.dty,getName @con)
-    lhs.ads   = 
-        case Map.lookup @con @lhs.augM of
-         Nothing -> []
-         Just a  -> Set.toList $ Set.map (depToEdge @children.pmpr @loc.pll) a
-    children.dty = @lhs.dty
-
-ATTR Productions Production [
-   augM : {Map.Map Identifier (Set.Set Dependency)} || ]
--- We didnt calculate A_P yet, inheriting A_N we can
-ATTR Productions Production Rules Rule [ 
-    -- result type of this constructor 
-    dty : {MyType} || ]
-ATTR Rules Rule Children Child Expression HsTokensRoot HsTokens HsToken [
-    pll : {PLabel} || ]
-SEM Nonterminal | Nonterminal    
-    loc.dty  = TyData (getName @nt)
-
-ATTR Nonterminals Nonterminal Productions Production Children Child 
-     FieldAtts FieldAtt [
-    an      : {MyType -> MyAttributes} 
-    nmprf   : NMP_R|
-    olab    : Int --  chained attribute for handing out labels to occurrences
-    flab    : Int  |--chained attribute for handing out labels to fields
-    ap   USE {Map.unionWith (++)} {Map.empty}   : A_P
-    gen  USE {Map.union}          {Map.empty}   : {Map Int Int}
-    inss USE {Map.unionWith (++)} {Map.empty}   : {Map Int [Int]}
-    pmp  USE {Map.union}          {Map.empty}   : PMP
-    pmpr USE {Map.union}          {Map.empty}   : PMP_R
-    -- maps for each occurrence to which field it belongs
-    ofld USE {(++)}             {[]}        : {[(Int, Int)]}
-    fty  USE {Map.union}          {Map.empty}   : FTY
-    ]
-
-SEM Grammar | Grammar 
-    nonts.an = map2F @loc.an
-    nonts.nmprf= @loc.nmpr
-    nonts.olab = if Map.null @loc.nmp then 0 else (fst $ Map.findMax @loc.nmp)
-    nonts.flab = 0
-
-ATTR Children Child [||
-    fieldMap USE {Map.union} {Map.empty} : FMap
-    hoMap    USE {Map.unionWith (Set.union)} {Map.empty} : HOMap
-    ]
-SEM Children [ dty : {MyType} || ]
-    | Nil 
-    loc.flab    = @lhs.flab + 1
-    loc.atp     = fst @lhs.pll
-    inst.fatts  : FieldAtts
-    inst.fatts  = map ((FieldAtt @loc.atp @lhs.pll "lhs") . alab) $ 
-                        @lhs.an @loc.atp
-    fatts.flab  = @loc.flab
-    loc.label   = (@lhs.pll, "lhs")
-    loc.foccsI  = Set.fromList $ handAllOut @loc.label $ @lhs.ain @loc.atp
-    loc.foccsS  = Set.fromList $ handAllOut @loc.label $ @lhs.asn @loc.atp
-    loc.fieldMap= Map.singleton @loc.label (@loc.foccsI, @loc.foccsS)
-    lhs.fty     = Map.singleton @loc.label @lhs.dty
-
-SEM Child | Child
-    loc.flab    = @lhs.flab + 1
-    loc.atp     = toMyTy @tp
-    inst.fatts  : FieldAtts
-    inst.fatts  = map ((FieldAtt @loc.atp @lhs.pll (getName @name)) . alab)
-                        $ @lhs.an @loc.atp
-    fatts.flab  = @loc.flab
-    loc.ident   = getName @name
-    loc.label   = (@lhs.pll, @loc.ident)
-    loc.foccsI  = Set.fromList $ handAllOut @loc.label $ @lhs.ain @loc.atp
-    loc.foccsS  = Set.fromList $ handAllOut @loc.label $ @lhs.asn @loc.atp
-    loc.fieldMap= if Set.null @loc.foccsI && Set.null @loc.foccsS
-                        then Map.empty 
-                        else Map.singleton @loc.label (@loc.foccsS,@loc.foccsI)
-    loc.hoMap   = case @kind of
-                    ChildAttr -> Map.singleton @lhs.pll (Set.singleton @loc.ident)
-                    _         -> Map.empty
-    lhs.fty     = Map.singleton (@lhs.pll, getName @name) @loc.atp
-
-SEM FieldAtt | FieldAtt
-    loc.olab    = @lhs.olab + 1
-    loc.alab    = findWithErr @lhs.nmprf "getting attr label" @loc.att
-    loc.att     = @t <.> @a
-    loc.occ     = (@p, @f) >.< @a
-    loc.pmp     = Map.singleton @loc.olab @loc.occ
-    loc.pmpr    = Map.singleton @loc.occ  @loc.olab
-    loc.inss    = Map.singleton @loc.alab [@loc.olab]
-    loc.gen     = Map.singleton @loc.olab @loc.alab
-    lhs.ap      = Map.singleton @p [@loc.occ]
-    lhs.ofld    = [(@loc.olab, @lhs.flab)]
-
--- calculate representation of semantic function 
--- definitions per non-terminal and from it, calculate E_P
-SEM Grammar | Grammar
-     loc.sfp = repLocRefs @nonts.lfp $ addHigherOrders @nonts.lfp @nonts.sfp
-ATTR Nonterminals Nonterminal Productions Production Rules Rule [ || 
-    sfp  USE {Map.unionWith (Set.union)} {Map.empty} : SF_P  -- deps of non-locals
-    ruleMap USE {Map.union} {Map.empty} : {Map.Map MyOccurrence Identifier} 
-    lfp  USE {Map.unionWith (Set.union)} {Map.empty} : SF_P  -- deps of local attrs
-    lfpr USE {Map.unionWith (Set.union)} {Map.empty} : SF_P ]-- reverse 
-SEM Production | Production
-    loc.pll   = (@lhs.dty,getName @con)
-    rules.pll = @pll 
-    rules.pts = @children.pts
-    lhs.fsInP = Map.singleton @pll $ Map.keys @children.fieldMap
-
-ATTR Children Child [ ||
-    pts USE {Set.union} {Set.empty} : {Set.Set FLabel} ]
-
-SEM Child | Child
-    lhs.pts = Set.singleton $ getName @name
-
-ATTR Rules Rule [
-    lfpf : SF_P ||
-    usedLocals USE {(Set.union)} {Set.empty} : {Set.Set MyOccurrence}]
-
-SEM Rule | Rule
-    loc.usedLocals = Set.filter (\(MyOccurrence (_,f) _) -> f == "loc") @rhs.used
-    loc.usesLocals = not $ Set.null @loc.usedLocals
-    (lhs.sfp,lhs.ruleMap,lhs.lfp,lhs.lfpr) = 
-        foldr (\(f, a, b) (m',rm', l', lr') -> 
-          let att = (@lhs.pll, f) >.< a
-              rm  = Map.insert att @rulename rm' 
-              l   = if @loc.usesLocals && not b
-                      then Map.insert att @loc.usedLocals l'
-                      else l'
-              lr  = if @loc.usesLocals && not b
-                     then Set.fold (\k m -> Map.insertWith (Set.union) k 
-                                 (Set.singleton att) m) lr' @loc.usedLocals
-                     else lr'
-              sfpins = Map.insert att (@rhs.used `Set.union` fromHO) m'
-              fromHO = maybe Set.empty id (Map.lookup hOcc @lhs.lfpf)
-                where hOcc = (@lhs.pll, "inst") >.< (f, AnyDir)
-              
-            in if b
-                then (m',rm, Map.insert att @rhs.used l, 
-                        Set.fold (\k m -> Map.insertWith (Set.union) k 
-                                (Set.singleton att) m) lr @rhs.used)
-                else (sfpins,rm,l,lr))
-                        (Map.empty,Map.empty,Map.empty,Map.empty) @pattern.afs
-
-ATTR Patterns Pattern [ ||
-    -- the boolean represents whether this occurrence is 
-    --   an transparent occurrence (only there to pass on dependencies)
-    afs USE {++} {[]} : {[(FLabel, ALabel, Bool)]} ]
-
-SEM Pattern | Alias
-    lhs.afs = let isLocal = (@field == _LOC || @field == _INST)
-               in [(getName @field, (getName @attr, dlhs @field), 
-                    isLocal)] ++ @pat.afs
-
-ATTR Rules Rule Expression HsTokensRoot HsTokens HsToken [
-    -- the terminals of current production
-    pts                : {Set.Set (FLabel)} || ]
-
-ATTR Rule Expression HsTokensRoot HsTokens HsToken [ ||
-    used USE {Set.union} {Set.empty} : {Set.Set MyOccurrence} ]
-
-SEM Expression | Expression
-    inst.tokens : HsTokensRoot
-    inst.tokens = HsTokensRoot @tks
-    tokens.pll  = @lhs.pll
-    tokens.pts  = @lhs.pts
-    lhs.used    = @tokens.used
-
--- reference to terminals of which some are local attributes 
-SEM HsToken | AGLocal 
-    lhs.used = 
-        case getName @var `Set.member` @lhs.pts of
-          True  -> Set.empty 
-          -- local found without flabel
-          False -> Set.singleton $ (@lhs.pll, getName _LOC) >.< 
-                        (getName @var, drhs _LOC)
--- includes both locals and attributes
--- locals will be replaced later by repLocRefs
-SEM HsToken | AGField
-    lhs.used = Set.singleton $ (@lhs.pll, getName @field) >.< 
-                                (getName @attr, drhs @field)
-    
-{
--- | Replace the references to local attributes, by his attrs dependencies,
--- |    rendering the local attributes 'transparent'.
-repLocRefs :: SF_P -> SF_P -> SF_P
-repLocRefs lfp sfp =
-    Map.map (setConcatMap $ rep Set.empty) sfp
-    where rep :: Set.Set MyOccurrence -> MyOccurrence -> Set.Set MyOccurrence 
-          rep done occ | occ `Set.member` done = Set.empty
-                       | isLoc occ   = setConcatMap (rep $ Set.insert occ done) $ 
-                                       findWithErr lfp "repping locals" occ
-                       | otherwise   = Set.singleton occ
-
--- | Add dependencies from a higher order child to all its attributes
-addHigherOrders :: SF_P -> SF_P -> SF_P
-addHigherOrders lfp sfp = 
-   Map.mapWithKey f $ Map.map (setConcatMap (\mo -> f mo (Set.singleton mo))) sfp
-   where f :: MyOccurrence -> Set.Set MyOccurrence -> Set.Set MyOccurrence
-         f mo@(MyOccurrence (p,f) _) deps =
-           let ho = ((p,"inst") >.< (f,AnyDir))
-           in  if ho `Map.member` lfp
-               then ho `Set.insert` deps
-               else deps
-}
-
-
+INCLUDE "AbstractSyntax.ag"+INCLUDE "Patterns.ag"+INCLUDE "CodeSyntax.ag"+INCLUDE "Expression.ag"+INCLUDE "HsToken.ag"+INCLUDE "LOAG/Rep"+INCLUDE "ExecutionPlanPre"++MODULE {LOAG.Prepare}+{}+{}++{+-- | Translating UUAGC types to MyTypes+drhs f | f == _LHS               = Inh+       | f == _LOC               = AnyDir+       | f == _INST              = AnyDir+       | otherwise               = Syn+dlhs f | f == _LHS               = Syn+       | f == _LOC               = AnyDir+       | f == _INST              = AnyDir+       | otherwise               = Inh ++depToEdge :: PMP_R -> PLabel -> Dependency -> Edge+depToEdge pmpr p e = +    (findWithErr pmpr "depToEdge" $ MyOccurrence (p,getName f1) (getName i1, drhs f1),+     findWithErr pmpr "depToEdge" $ MyOccurrence (p,getName f2) (getName i2, dlhs f2))+    where Dependency (OccAttr f1 i1) (OccAttr f2 i2) = e++vertexToAttr :: NMP -> Vertex -> Attributes+vertexToAttr nmp v = Map.singleton (identifier a) (fromMyTy ty)+    where (MyAttribute ty (a,_)) = findWithErr nmp "vertexToAttr" v++}++SEM Grammar | Grammar+    inst.smf : LOAGRep +    loc.initO= if Map.null @nonts.pmp then 1 else fst $ Map.findMin @nonts.pmp+    inst.smf = +        LOAGRep @nonts.ps @nonts.ap @loc.an +           @loc.ain @loc.asn @loc.sfp+           @nonts.pmp @nonts.pmpr @loc.nmp @loc.nmpr+           (A.array (@loc.initO, @loc.initO + Map.size @nonts.gen)  $ +                Map.toList $ @nonts.gen)+           (A.array (1,Map.size @nonts.inss) $ +                Map.toList $ @nonts.inss)+           (A.array (@loc.initO, @loc.initO + length @nonts.ofld) $ +                @nonts.ofld) @nonts.fty @nonts.fieldMap @nonts.fsInP+    loc.nmp  = Map.fromList $ zip [1..] @loc.atts+    loc.nmpr = Map.fromList $ zip @loc.atts [1..]+    loc.an   = Map.unionWith (++) @loc.ain @loc.asn+    loc.ain  = @nonts.inhs+    loc.asn  = @nonts.syns+    loc.atts = concat $ Map.elems @loc.an+    loc.occs = concat $ Map.elems @nonts.ap+    nonts.augM = @manualAttrOrderMap++-- Collecting the attributes +ATTR Nonterminals Nonterminal [+    augM   : {Map.Map Identifier (Map.Map Identifier (Set.Set Dependency))} ||  +    inhs USE {Map.union} {Map.empty} : AI_N +    syns USE {Map.union} {Map.empty} : AS_N ]+    +SEM Nonterminal | Nonterminal +    lhs.inhs = let dty = TyData (getName @nt) +                in Map.singleton dty (toMyAttr Inh dty @inh)+    lhs.syns = let dty = TyData (getName @nt) +                in Map.singleton dty (toMyAttr Syn dty @syn)+    prods.augM = case Map.lookup @nt @lhs.augM of+                    Nothing -> Map.empty +                    Just a  -> a++-- Adding all attribute sets to the AG type +--   and sending it all down the abstract tree+ATTR Nonterminals Nonterminal Productions Production Children Child +    MySegments MySegment [+    ain   : {MyType -> MyAttributes} +    asn   : {MyType -> MyAttributes}+    pmpf  : PMP+    pmprf : PMP_R+    lfpf  : SF_P+    hoMapf: HOMap+    fty   : FTY+    nmp   : NMP || ]++SEM Grammar | Grammar+    nonts.ain  = map2F @loc.ain+    nonts.asn  = map2F @loc.asn+    nonts.pmpf  = @nonts.pmp+    nonts.pmprf = @nonts.pmpr+    nonts.lfpf  = @nonts.lfp+    nonts.hoMapf= @nonts.hoMap+    nonts.ftyf  = @nonts.fty+    nonts.fty   = @nonts.fty++-- Make sure TDP AND LFPRF are passed around correctly to code-generation+ATTR Nonterminals Nonterminal Productions Production [+    ftyf: FTY ||]+++-- Calculate the set of production labels+SEM Grammar | Grammar +     loc.ps = @nonts.ps+ATTR Nonterminals Nonterminal Productions Production [ || +    ads USE {(++)} {[]}   : {[Edge]}+    fieldMap USE {(Map.union)} {Map.empty} : FMap+    hoMap    USE {(Map.union)} {Map.empty} : HOMap+    fsInP USE {(Map.union)} {Map.empty} : FsInP]++SEM Nonterminals Nonterminal [ ||+    ps  USE {(++)} {([])} : {[PLabel]} ]+SEM Productions [ ||+    ps  USE {:} {([])} : {[PLabel]}  ]+SEM Production [ || ps : PLabel ] | Production +    loc.ps = (@lhs.dty,getName @con)+    lhs.ads   = +        case Map.lookup @con @lhs.augM of+         Nothing -> []+         Just a  -> Set.toList $ Set.map (depToEdge @children.pmpr @loc.pll) a+    children.dty = @lhs.dty++ATTR Productions Production [+   augM : {Map.Map Identifier (Set.Set Dependency)} || ]+-- We didnt calculate A_P yet, inheriting A_N we can+ATTR Productions Production Rules Rule [ +    -- result type of this constructor +    dty : {MyType} || ]+ATTR Rules Rule Children Child Expression HsTokensRoot HsTokens HsToken [+    pll : {PLabel} || ]+SEM Nonterminal | Nonterminal    +    loc.dty  = TyData (getName @nt)++ATTR Nonterminals Nonterminal Productions Production Children Child +     FieldAtts FieldAtt [+    an      : {MyType -> MyAttributes} +    nmprf   : NMP_R|+    olab    : Int --  chained attribute for handing out labels to occurrences+    flab    : Int  |--chained attribute for handing out labels to fields+    ap   USE {Map.unionWith (++)} {Map.empty}   : A_P+    gen  USE {Map.union}          {Map.empty}   : {Map Int Int}+    inss USE {Map.unionWith (++)} {Map.empty}   : {Map Int [Int]}+    pmp  USE {Map.union}          {Map.empty}   : PMP+    pmpr USE {Map.union}          {Map.empty}   : PMP_R+    -- maps for each occurrence to which field it belongs+    ofld USE {(++)}             {[]}        : {[(Int, Int)]}+    fty  USE {Map.union}          {Map.empty}   : FTY+    ]++SEM Grammar | Grammar +    nonts.an = map2F @loc.an+    nonts.nmprf= @loc.nmpr+    nonts.olab = if Map.null @loc.nmp then 0 else (fst $ Map.findMax @loc.nmp)+    nonts.flab = 0++ATTR Children Child [||+    fieldMap USE {Map.union} {Map.empty} : FMap+    hoMap    USE {Map.unionWith (Set.union)} {Map.empty} : HOMap+    ]+SEM Children [ dty : {MyType} || ]+    | Nil +    loc.flab    = @lhs.flab + 1+    loc.atp     = fst @lhs.pll+    inst.fatts  : FieldAtts+    inst.fatts  = map ((FieldAtt @loc.atp @lhs.pll "lhs") . alab) $ +                        @lhs.an @loc.atp+    fatts.flab  = @loc.flab+    loc.label   = (@lhs.pll, "lhs")+    loc.foccsI  = Set.fromList $ handAllOut @loc.label $ @lhs.ain @loc.atp+    loc.foccsS  = Set.fromList $ handAllOut @loc.label $ @lhs.asn @loc.atp+    loc.fieldMap= Map.singleton @loc.label (@loc.foccsI, @loc.foccsS)+    lhs.fty     = Map.singleton @loc.label @lhs.dty++SEM Child | Child+    loc.flab    = @lhs.flab + 1+    loc.atp     = toMyTy @tp+    inst.fatts  : FieldAtts+    inst.fatts  = map ((FieldAtt @loc.atp @lhs.pll (getName @name)) . alab)+                        $ @lhs.an @loc.atp+    fatts.flab  = @loc.flab+    loc.ident   = getName @name+    loc.label   = (@lhs.pll, @loc.ident)+    loc.foccsI  = Set.fromList $ handAllOut @loc.label $ @lhs.ain @loc.atp+    loc.foccsS  = Set.fromList $ handAllOut @loc.label $ @lhs.asn @loc.atp+    loc.fieldMap= if Set.null @loc.foccsI && Set.null @loc.foccsS+                        then Map.empty +                        else Map.singleton @loc.label (@loc.foccsS,@loc.foccsI)+    loc.hoMap   = case @kind of+                    ChildAttr -> Map.singleton @lhs.pll (Set.singleton @loc.ident)+                    _         -> Map.empty+    lhs.fty     = Map.singleton (@lhs.pll, getName @name) @loc.atp++SEM FieldAtt | FieldAtt+    loc.olab    = @lhs.olab + 1+    loc.alab    = findWithErr @lhs.nmprf "getting attr label" @loc.att+    loc.att     = @t <.> @a+    loc.occ     = (@p, @f) >.< @a+    loc.pmp     = Map.singleton @loc.olab @loc.occ+    loc.pmpr    = Map.singleton @loc.occ  @loc.olab+    loc.inss    = Map.singleton @loc.alab [@loc.olab]+    loc.gen     = Map.singleton @loc.olab @loc.alab+    lhs.ap      = Map.singleton @p [@loc.occ]+    lhs.ofld    = [(@loc.olab, @lhs.flab)]++-- calculate representation of semantic function +-- definitions per non-terminal and from it, calculate E_P+SEM Grammar | Grammar+     loc.sfp = repLocRefs @nonts.lfp $ addHigherOrders @nonts.lfp @nonts.sfp+ATTR Nonterminals Nonterminal Productions Production Rules Rule [ || +    sfp  USE {Map.unionWith (Set.union)} {Map.empty} : SF_P  -- deps of non-locals+    ruleMap USE {Map.union} {Map.empty} : {Map.Map MyOccurrence Identifier} +    lfp  USE {Map.unionWith (Set.union)} {Map.empty} : SF_P  -- deps of local attrs+    lfpr USE {Map.unionWith (Set.union)} {Map.empty} : SF_P ]-- reverse +SEM Production | Production+    loc.pll   = (@lhs.dty,getName @con)+    rules.pll = @pll +    rules.pts = @children.pts+    lhs.fsInP = Map.singleton @pll $ Map.keys @children.fieldMap++ATTR Children Child [ ||+    pts USE {Set.union} {Set.empty} : {Set.Set FLabel} ]++SEM Child | Child+    lhs.pts = Set.singleton $ getName @name++ATTR Rules Rule [+    lfpf : SF_P ||+    usedLocals USE {(Set.union)} {Set.empty} : {Set.Set MyOccurrence}]++SEM Rule | Rule+    loc.usedLocals = Set.filter (\(MyOccurrence (_,f) _) -> f == "loc") @rhs.used+    loc.usesLocals = not $ Set.null @loc.usedLocals+    (lhs.sfp,lhs.ruleMap,lhs.lfp,lhs.lfpr) = +        foldr (\(f, a, b) (m',rm', l', lr') -> +          let att = (@lhs.pll, f) >.< a+              rm  = Map.insert att @rulename rm' +              l   = if @loc.usesLocals && not b+                      then Map.insert att @loc.usedLocals l'+                      else l'+              lr  = if @loc.usesLocals && not b+                     then Set.fold (\k m -> Map.insertWith (Set.union) k +                                 (Set.singleton att) m) lr' @loc.usedLocals+                     else lr'+              sfpins = Map.insert att (@rhs.used `Set.union` fromHO) m'+              fromHO = maybe Set.empty id (Map.lookup hOcc @lhs.lfpf)+                where hOcc = (@lhs.pll, "inst") >.< (f, AnyDir)+              +            in if b+                then (m',rm, Map.insert att @rhs.used l, +                        Set.fold (\k m -> Map.insertWith (Set.union) k +                                (Set.singleton att) m) lr @rhs.used)+                else (sfpins,rm,l,lr))+                        (Map.empty,Map.empty,Map.empty,Map.empty) @pattern.afs++ATTR Patterns Pattern [ ||+    -- the boolean represents whether this occurrence is +    --   an transparent occurrence (only there to pass on dependencies)+    afs USE {++} {[]} : {[(FLabel, ALabel, Bool)]} ]++SEM Pattern | Alias+    lhs.afs = let isLocal = (@field == _LOC || @field == _INST)+               in [(getName @field, (getName @attr, dlhs @field), +                    isLocal)] ++ @pat.afs++ATTR Rules Rule Expression HsTokensRoot HsTokens HsToken [+    -- the terminals of current production+    pts                : {Set.Set (FLabel)} || ]++ATTR Rule Expression HsTokensRoot HsTokens HsToken [ ||+    used USE {Set.union} {Set.empty} : {Set.Set MyOccurrence} ]++SEM Expression | Expression+    inst.tokens : HsTokensRoot+    inst.tokens = HsTokensRoot @tks+    tokens.pll  = @lhs.pll+    tokens.pts  = @lhs.pts+    lhs.used    = @tokens.used++-- reference to terminals of which some are local attributes +SEM HsToken | AGLocal +    lhs.used = +        case getName @var `Set.member` @lhs.pts of+          True  -> Set.empty +          -- local found without flabel+          False -> Set.singleton $ (@lhs.pll, getName _LOC) >.< +                        (getName @var, drhs _LOC)+-- includes both locals and attributes+-- locals will be replaced later by repLocRefs+SEM HsToken | AGField+    lhs.used = Set.singleton $ (@lhs.pll, getName @field) >.< +                                (getName @attr, drhs @field)+    +{+-- | Replace the references to local attributes, by his attrs dependencies,+-- |    rendering the local attributes 'transparent'.+repLocRefs :: SF_P -> SF_P -> SF_P+repLocRefs lfp sfp =+    Map.map (setConcatMap $ rep Set.empty) sfp+    where rep :: Set.Set MyOccurrence -> MyOccurrence -> Set.Set MyOccurrence +          rep done occ | occ `Set.member` done = Set.empty+                       | isLoc occ   = setConcatMap (rep $ Set.insert occ done) $ +                                       findWithErr lfp "repping locals" occ+                       | otherwise   = Set.singleton occ++-- | Add dependencies from a higher order child to all its attributes+addHigherOrders :: SF_P -> SF_P -> SF_P+addHigherOrders lfp sfp = +   Map.mapWithKey f $ Map.map (setConcatMap (\mo -> f mo (Set.singleton mo))) sfp+   where f :: MyOccurrence -> Set.Set MyOccurrence -> Set.Set MyOccurrence+         f mo@(MyOccurrence (p,f) _) deps =+           let ho = ((p,"inst") >.< (f,AnyDir))+           in  if ho `Map.member` lfp+               then ho `Set.insert` deps+               else deps+}++
src-ag/LOAG/Rep.ag view
@@ -1,49 +1,49 @@-MODULE {LOAG.Rep}
-{}{
-import CommonTypes
-import AbstractSyntax
-import LOAG.Common
-import qualified Data.Array as A
-import qualified Data.Map   as Map
-import qualified Data.Set   as Set
-}
-imports{
-import Data.List (intercalate, foldl', nub)
-import Data.Tuple (swap)
-import Control.Arrow
-}
-
-DATA LOAGRep | LOAGRep
-    ps   : {[PLabel]}
-    ap   : A_P
-    an   : A_N
-    ain  : AI_N
-    asn  : AS_N
-    sfp  : SF_P 
-    pmp  : PMP
-    pmpr : PMP_R
-    nmp  : NMP
-    nmpr : NMP_R
-    gen  : {A.Array Int Int}
-    inss : {A.Array Int [Int]}
-    ofld : {A.Array Int Int}
-    fty  : FTY
-    fieldMap  : FMap 
-    fsInP: {Map.Map PLabel [(PLabel,FLabel)]}
-
-TYPE FieldAtts = [FieldAtt]
--- t is the type of the attribute this occurrence belongs to
-DATA FieldAtt | FieldAtt     t : {MyType} p : {PLabel} 
-                             f : {FLabel} a : {ALabel}
-
-TYPE MySegments = [MySegment]
-DATA MySegment | MySegment
-                    visnr   : Int 
-                    inhAttr : {[Int]}
-                    synAttr : {[Int]}
-                    inhOccs : {Maybe [Int]}
-                    synOccs : {Maybe [Int]}
-
-DERIVING MySegments MySegment : Show
-
-
+MODULE {LOAG.Rep}+{}{+import CommonTypes+import AbstractSyntax+import LOAG.Common+import qualified Data.Array as A+import qualified Data.Map   as Map+import qualified Data.Set   as Set+}+imports{+import Data.List (intercalate, foldl', nub)+import Data.Tuple (swap)+import Control.Arrow+}++DATA LOAGRep | LOAGRep+    ps   : {[PLabel]}+    ap   : A_P+    an   : A_N+    ain  : AI_N+    asn  : AS_N+    sfp  : SF_P +    pmp  : PMP+    pmpr : PMP_R+    nmp  : NMP+    nmpr : NMP_R+    gen  : {A.Array Int Int}+    inss : {A.Array Int [Int]}+    ofld : {A.Array Int Int}+    fty  : FTY+    fieldMap  : FMap +    fsInP: {Map.Map PLabel [(PLabel,FLabel)]}++TYPE FieldAtts = [FieldAtt]+-- t is the type of the attribute this occurrence belongs to+DATA FieldAtt | FieldAtt     t : {MyType} p : {PLabel} +                             f : {FLabel} a : {ALabel}++TYPE MySegments = [MySegment]+DATA MySegment | MySegment+                    visnr   : Int +                    inhAttr : {[Int]}+                    synAttr : {[Int]}+                    inhOccs : {Maybe [Int]}+                    synOccs : {Maybe [Int]}++DERIVING MySegments MySegment : Show++
src-ag/Macro.ag view
@@ -1,24 +1,24 @@---marcos: macros extension
-
-imports
-{
-import CommonTypes
-}
-
-TYPE MaybeMacro  = MAYBE Macro
-
-DATA Macro     | Macro   con      : {ConstructorIdent}
-                         children : MacroChildren
-               | None
-
-TYPE MacroChildren = [MacroChild]
-
-DATA MacroChild | RuleChild   name      : {Identifier}
-                              macro     : Macro
-                | ChildChild  name      : {Identifier}
-                              child     : {Identifier}
-
-                | ValueChild  name      : {Identifier}
-                              value     : {String}
-
-DERIVING MaybeMacro Macro MacroChildren MacroChild : Show
+--marcos: macros extension++imports+{+import CommonTypes+}++TYPE MaybeMacro  = MAYBE Macro++DATA Macro     | Macro   con      : {ConstructorIdent}+                         children : MacroChildren+               | None++TYPE MacroChildren = [MacroChild]++DATA MacroChild | RuleChild   name      : {Identifier}+                              macro     : Macro+                | ChildChild  name      : {Identifier}+                              child     : {Identifier}++                | ValueChild  name      : {Identifier}+                              value     : {String}++DERIVING MaybeMacro Macro MacroChildren MacroChild : Show
src-ag/Order.ag view
@@ -1,809 +1,809 @@-PRAGMA strictdata
-PRAGMA strictwrap
-
-INCLUDE "Patterns.ag"
-INCLUDE "Expression.ag"
-INCLUDE "AbstractSyntax.ag"
-INCLUDE "DistChildAttr.ag"
-
-imports
-{
--- 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 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 Data.Sequence as Seq
-import Data.Map(Map)
-import Data.Set(Set)
-import Data.Sequence(Seq, (><))
-import UU.Util.Utils
-import UU.Scanner.Position(Pos(..),initPos)
-import Data.Foldable(toList)
-
--- 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 Data.Maybe
-}
-
-{
--- 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
-}
-
---
--- Some statistics, count number of attributes
---
-
-ATTR Grammar Nonterminals Nonterminal Productions Production Rules Rule [ | | nAutoRules,nExplicitRules USE {+} {0} : {Int} ]
-
-SEM Rule
-  | Rule  lhs.nExplicitRules = if @explicit
-                               then 1
-                               else 0
-          lhs.nAutoRules = if startsWith "use rule" @origin || startsWith "copy rule" @origin
-                           then 1
-                           else 0
-
-{
-startsWith :: String -> String -> Bool
-startsWith k h = k == take (length k) h
-}
-
-
--------------------------------------------------------------------------------
---         Errors
--------------------------------------------------------------------------------
--- Everyone that wants to report an error can do this by adding an error message to the
--- stream of errors
-
-ATTR Nonterminals Nonterminal Productions Production
-     Child Children Rule Rules Pattern Patterns Grammar [ | | errors USE {Seq.><} {Seq.empty}:{Seq Error} ]
-
--------------------------------------------------------------------------------
---         Distributing name of nonterminal and names of attributes
--------------------------------------------------------------------------------
-ATTR Productions Production Child Children Rules Rule Patterns Pattern [ nt : {Identifier} inh,syn : {Attributes} | | ]
-ATTR Child Children Rules Rule Patterns Pattern [ con : {Identifier} | | ]
-
-SEM Production
-  | Production children . con = @con
-SEM Production
-  | Production rules . con = @con
-SEM Nonterminal
-  | Nonterminal prods . nt = @nt
-
-SEM Nonterminal
-  | Nonterminal prods.inh  = @inh
-                prods.syn  = @syn
-
-
--------------------------------------------------------------------------------
---         Distributing options
--------------------------------------------------------------------------------
-
-ATTR Grammar          [ options:{Options} | | ]
-ATTR Nonterminals Nonterminal Productions Production Rules Rule
-   [ o_newtypes
-   , o_cata
-   , o_sig
-   , o_sem
-   , o_rename
-   , o_wantvisit -- True if the option for visit functions has been specified
-   , o_dovisit   -- True if o_wantvisit and it is possible to generate visit functions (no cycles)
-   , o_case:{Bool}
-   prefix : {String} | | ]
-ATTR Nonterminals Nonterminal Productions Production Children Child [ o_unbox:{Bool} | | ]
-ATTR Nonterminals Nonterminal [ o_data:{Bool} | | ]
-
-SEM Grammar
-  | Grammar     loc.o_dovisit   = visit     @lhs.options && null @cyclesErrors
-                nonts.o_cata    = folds     @lhs.options
-                     .o_data    = dataTypes @lhs.options
-                     .o_sig     = typeSigs  @lhs.options
-                     .o_sem     = semfuns   @lhs.options
-                     .o_rename  = rename    @lhs.options
-                     .o_newtypes= newtypes  @lhs.options
-                     .o_wantvisit = visit   @lhs.options
-                     .o_unbox   = unbox     @lhs.options
-                     .o_case    = cases     @lhs.options
-                     .prefix    = prefix    @lhs.options
-
-------------------------------------------------------------------
--- Building a mapping from Vertices to Ints
-------------------------------------------------------------------
-{
-getNtName :: Type -> NontermIdent
-getNtName (NT nt _ _) = nt
-getNtName _           = nullIdent
-}
-
-------------------------------------------------------------------
--- Collect attribute occurrences
---
--- All attribute occurences in an alternative are gathered.
--- This is done by joining various sublists:
---  1.  inherited attributes for _LHS
---  2a. synthesized attributes for children
---  2b. children that are a trivial field
---  3a. inherited attributes for children
---  3b. synthesized attributes for _LHS
---  3c. local attributes
---
--- Sublist 3 is exactly the targets for ATTR definitions, and
--- thus can be obtained by traversing all rules.
---
--- The (field,attr) combination is not enough to uniquely identify
--- an attribute occurence, because threaded attributes occur twice.
--- Therefore, in the AltAttr structures, a boolean is added,
--- that is False in sublists 3a and 3b, i.e. the non-local output fields.
---
--- Each AltAttr, that is eacht attribute occurence, is mapped to a number
--- in the altAttrs Map, starting at vcount
-{
-data AltAttr = AltAttr Identifier Identifier Bool
-               deriving (Eq, Ord, Show)
-}
-ATTR  Rules Rule Production Productions Nonterminal Nonterminals
-  [ options : {Options} | | ]
-
-ATTR Children Child Rules Rule Patterns Pattern [ | | gathAltAttrs USE {++} {[]} : {[AltAttr]} ]
-SEM  Production
-  |  Production  loc.gathAltAttrs =  [ AltAttr _LHS inh True | inh <- Map.keys @lhs.inh ]   -- sublist 1
-                                      ++ @children.gathAltAttrs                              -- sublist 2
-                                      ++ @rules.gathAltAttrs                                 -- sublist 3
-
-SEM  Child
-  |  Child  loc.maptolocal =  case @tp of
-                                NT nt _ _ -> Map.null @syn
-                                _         -> True
-            lhs.gathAltAttrs = if  @maptolocal
-                                   then [ AltAttr _LOC @name True ]                          -- sublist 2b
-                                   else [ AltAttr @name syn True | syn <- Map.keys @loc.syn ]    -- sublist 2a
-SEM  Pattern
-  |  Alias lhs.gathAltAttrs = [AltAttr @field @attr (@field == _LOC || @field == _INST)]     -- sublist 3
-
-ATTR Rules Rule Patterns Pattern [ altAttrs : {Map AltAttr Vertex} | | ]
-SEM  Production
-  |  Production loc.altAttrs = Map.fromList (zip @gathAltAttrs [@lhs.vcount..])
-
--- Information passed to Pattern
-ATTR  Children Child
-      [  | |  nts USE {Seq.><} {Seq.empty} : {Seq (Identifier,NontermIdent)}
-              inhs USE {Seq.><} {Seq.empty} : {Seq (Identifier,Attributes)} ]
-SEM  Child
-  |  Child  lhs.nts = Seq.singleton (@name,getNtName @tp)
-            lhs.inhs = Seq.singleton (@name,@loc.inh)
-ATTR  Rules Rule
-      [  childNts : {Map Identifier NontermIdent}
-         childInhs : {Map Identifier Attributes} | | ]
-SEM  Production
-  |  Production  rules.childNts = Map.fromList (toList @children.nts)
-                  rules.childInhs = Map.fromList (toList @children.inhs)
-
--- Collect CRules
-ATTR  Children Child Rules Rule
-      [ | | gathRules USE {Seq.><} {Seq.empty} : {Seq CRule} ]
-SEM  Production
-  |  Production  loc.inhRules = [ cRuleLhsInh inh @lhs.nt @con tp | (inh,tp) <- Map.assocs @lhs.inh ]
-                  loc.gathRules = @inhRules ++ toList (@children.gathRules Seq.>< @rules.gathRules)
-
-SEM  Child
-  |  Child  loc.gathRules = if  @maptolocal
-                                then Seq.singleton (cRuleTerminal @name @lhs.nt @lhs.con @tp)
-                                else Seq.fromList [ cRuleRhsSyn syn @lhs.nt @lhs.con tp @name (getNtName @tp) | (syn,tp) <- Map.assocs @loc.syn]
-
-SEM  Rule
-  |  Rule  loc.defines = let  tp field attr      | field == _LOC || field == _INST
-                                                                  = Map.lookup attr @lhs.allTypeSigs
-                                                  | field == _LHS = Map.lookup attr @lhs.syn
-                                                  | otherwise     = Map.lookup attr (findWithErr1 "Rule.defines.tp" field @lhs.childInhs)
-                              typ :: Pattern -> Maybe Type
-                              typ (Alias field attr _)       = tp field attr
-                              typ (Underscore _)             = Nothing
-                              -- typ (Product _ pats)           = tp _LOC undefined pats
-                              typ _                          = Nothing
-
-                         in Map.fromList  [ (findWithErr1 "Rule.defines" aa @lhs.altAttrs, (field,attr,(tp field attr)))
-                                          | (field,attr,isLocalOrInst) <- @pattern.patternAttrs
-                                          , let aa = AltAttr field attr isLocalOrInst
-                                          ]
-           loc.gathRules =  let childnt field = Map.lookup field @lhs.childNts
-                            in Seq.fromList [ CRule attr False True @lhs.nt @lhs.con field (childnt field) tp @pattern.copy @rhs.textLines @defines @owrt @origin @rhs.allRhsVars @explicit @mbName
-                                            | (field,attr,tp) <- Map.elems @defines
-                                            ]
-
-{
-substSelf nt tp
-  = case tp of
-      NT n tps defor | n == _SELF -> NT nt tps defor
-      _                           -> tp
-
-haskellTupel :: [Type] -> Maybe Type
-haskellTupel ts =  Just ( Haskell ( '(' : (concat (intersperse "," (map show ts))) ++ ")" ))
-}
-
-
-ATTR Patterns Pattern [ | | patternAttrs USE {++} {[]} : {[(Identifier,Identifier,Bool)]} ]
-
-SEM  Pattern
-  |  Alias lhs.patternAttrs = [(@field,@attr,(@field == _LOC || @field == _INST))]
-
-
-
--- Giving them a number
-ATTR  Nonterminals Nonterminal Productions Production
-      [  | vcount : Int
-         | rules USE {Seq.><} {Seq.empty} : {Seq (Vertex,CRule)}]
-SEM  Grammar
-  |  Grammar  nonts.vcount = 0
-SEM  Production
-  |  Production  lhs.rules = Seq.fromList (zip [@lhs.vcount..] @gathRules)
-                  lhs.vcount = @lhs.vcount + length @gathRules
-
--- Direct dependencies
-ATTR Nonterminals Nonterminal
-     Productions Production
-     Rules Rule [ | | directDep USE {Seq.><} {Seq.empty} : {Seq Edge} ]
-SEM  Rule
-  |  Rule  lhs.directDep
-             = let  defined = Map.keys @defines
-                    used =  [ Map.lookup (AltAttr field attr True) @lhs.altAttrs | (field,attr) <- @rhs.usedAttrs]
-                            ++ [ Map.lookup (AltAttr _LOC attr True) @lhs.altAttrs | attr <- @rhs.usedLocals ++ @rhs.usedFields ]
-               in Seq.fromList [ (x,y) | Just x <- used, y <- defined ]
-
--- Manual depdendencies (provided by the programmer)
---
--- a dependency f1.a1 < f2.a2 is translated to
--- the edge (vertex(f1.a1), vertex(f2.a2))
-ATTR Nonterminals Nonterminal
-     Productions Production
-     [ manualAttrDepMap : {AttrOrderMap} | | additionalDep USE {Seq.><} {Seq.empty} : {Seq Edge} ]
-
-SEM Grammar
-  | Grammar
-      nonts.manualAttrDepMap = @manualAttrOrderMap
-
-SEM Production
-  | Production
-      loc.manualDeps
-        = Set.toList $ Map.findWithDefault Set.empty @con $ Map.findWithDefault Map.empty @lhs.nt @lhs.manualAttrDepMap
-
-      lhs.additionalDep
-        = Seq.fromList [ (vertex True occA, vertex False occB)
-                       | Dependency occA occB <- @loc.manualDeps
-                       , let vertex inout (OccAttr child nm)
-                               | child == _LOC = findWithErr2 (AltAttr _LOC nm True) @loc.altAttrs
-                               | otherwise     = findWithErr2 (AltAttr child nm inout) @loc.altAttrs
-                             vertex _ (OccRule nm)
-                               = findWithErr2 (AltAttr _LOC (Ident ("_rule_" ++ show nm) (getPos nm)) True) @loc.altAttrs
-                       ]
-
--- Inst dependencies
---
--- For each inst attribute x of nt N, add the dependency
---  (inst.x,x.y) for each synthesized attribute of N
---
-
-ATTR Nonterminals Nonterminal
-     Productions Production
-     Rules Rule [ | | instDep USE {Seq.><} {Seq.empty} : {Seq Edge} ]
-SEM Rule
-  | Rule
-     loc.instDep1
-        = Seq.fromList $
-            [ (instVert, synVert)
-            | (field,instNm,_) <- Map.elems @defines
-            , field == _INST
-            , synNm <- Map.keys (findWithErr2 instNm @lhs.synsOfChildren)
-            , let instAttr = AltAttr _INST instNm True
-                  synAttr  = AltAttr instNm synNm True
-                  instVert = findWithErr2 instAttr @lhs.altAttrs
-                  synVert  = findWithErr2 synAttr @lhs.altAttrs
-            ]
-     loc.instDep2
-        = Seq.fromList $
-            [ (instVert, inhVert)
-            | (field,instNm,_) <- Map.elems @defines
-            , field == _INST
-            , inhNm <- Map.keys (findWithErr2 instNm @lhs.inhsOfChildren)
-            , let instAttr = AltAttr _INST instNm True
-                  inhAttr  = AltAttr instNm inhNm False
-                  instVert = findWithErr2 instAttr @lhs.altAttrs
-                  inhVert  = findWithErr2 inhAttr @lhs.altAttrs
-            ]
-     lhs.instDep = @loc.instDep1 Seq.>< @loc.instDep2
-
-ATTR Rules Rule [ synsOfChildren, inhsOfChildren : {Map Identifier Attributes} | | ]
-SEM Production
-  | Production  rules.synsOfChildren = @children.collectChildrenSyns
-                rules.inhsOfChildren = @children.collectChildrenInhs
-
-ATTR Children Child [ | | collectChildrenSyns, collectChildrenInhs USE {`Map.union`} {Map.empty} : {Map Identifier Attributes } ]
-SEM Child
-  | Child  lhs.collectChildrenSyns = Map.singleton @name @loc.syn
-           lhs.collectChildrenInhs = Map.singleton @name @loc.inh
-
---
--- Merge stuff
---
-
-ATTR Nonterminals Nonterminal
-  [ mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))} | | ]
-
-ATTR Productions Production
-  [ mergeMap : {Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))} | | ]
-
-SEM Nonterminal | Nonterminal  loc.mergeMap = Map.findWithDefault Map.empty @nt @lhs.mergeMap
-SEM Production  | Production   loc.mergeMap = Map.findWithDefault Map.empty @con @lhs.mergeMap
-
-ATTR Rules Rule Children Child Expression [ mergeMap : {Map Identifier (Identifier,[Identifier])} | | ]
-
--- for a child c : N, with merged children cs, add dependencies between synthesized attrs of
--- c to synthesized attrs of cs, and to the merge-attribute
-ATTR Nonterminals Nonterminal Productions Production
-  [ | | mergeDep USE {Seq.><} {Seq.empty} : {Seq Edge} ]
-
-SEM Production
-  | Production
-      lhs.mergeDep = @loc.mergeDep1 Seq.>< @loc.mergeDep2
-      loc.mergeDep1
-        = Seq.fromList $
-             [ (childVert, synVert)
-             | childNm <- Map.keys @loc.mergeMap
-             , synNm <- Map.keys (findWithErr2 childNm @children.collectChildrenSyns)
-             , let childNm' = Ident (show childNm ++ "_merge") (getPos childNm)
-                   childAttr = AltAttr _LOC childNm' True
-                   synAttr  = AltAttr childNm synNm True
-                   childVert = findWithErr2 childAttr @loc.altAttrs
-                   synVert  = findWithErr2 synAttr @loc.altAttrs
-             ]
-      loc.mergeDep2
-        = Seq.fromList $
-             [ (mergedVert, sourceVert)
-             | (childNm, (_,cs)) <- Map.assocs @loc.mergeMap
-             , c <- cs
-             , synNm <- Map.keys (findWithErr2 childNm @children.collectChildrenSyns)
-             , let sourceAttr = AltAttr childNm synNm True
-                   mergedAttr = AltAttr c synNm True
-                   sourceVert = findWithErr2 sourceAttr @loc.altAttrs
-                   mergedVert = findWithErr2 mergedAttr @loc.altAttrs
-             ]
-
-
--- Around dependencies
---
--- For each around x_around on x of nt N, add the dependency
--- (x_around, x.y) for each synthesized attribute y of N
---
-
-ATTR Nonterminals Nonterminal
-     Productions Production
-       [ | | aroundDep USE {Seq.><} {Seq.empty} : {Seq Edge} ]
-
-ATTR Nonterminals Nonterminal
-  [ aroundMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} || ]
-
-ATTR Productions Production
-  [ aroundMap : {Map ConstructorIdent (Map Identifier [Expression])} || ]
-
-SEM Nonterminal | Nonterminal  loc.aroundMap = Map.findWithDefault Map.empty @nt @lhs.aroundMap
-SEM Production | Production    loc.aroundMap = Map.findWithDefault Map.empty @con @lhs.aroundMap
-
-SEM Grammar
-  | Grammar  nonts.aroundMap = @aroundsMap
-
-SEM Production
- | Production
-     loc.aroundDep1
-       = Seq.fromList $
-           [ (childVert, synVert)
-           | childNm <- Map.keys @loc.aroundMap
-           , synNm <- Map.keys (findWithErr2 childNm @children.collectChildrenSyns)
-           , let childNm' = Ident (show childNm ++ "_around") (getPos childNm)
-                 childAttr = AltAttr _LOC childNm' True
-                 synAttr  = AltAttr childNm synNm True
-                 childVert = findWithErr2 childAttr @loc.altAttrs
-                 synVert  = findWithErr2 synAttr @loc.altAttrs
-           ]
-     loc.aroundDep2
-        = Seq.fromList $
-            [ (childVert, inhVert)
-            | childNm <- Map.keys @loc.aroundMap
-            , inhNm <- Map.keys (findWithErr2 childNm @children.collectChildrenInhs)
-            , let childNm'  = Ident (show childNm ++ "_around") (getPos childNm)
-                  childAttr = AltAttr _LOC childNm' True
-                  inhAttr   = AltAttr childNm inhNm False
-                  childVert = findWithErr2 childAttr @loc.altAttrs
-                  inhVert   = findWithErr2 inhAttr @loc.altAttrs
-            ]
-     lhs.aroundDep = @loc.aroundDep1 Seq.>< @loc.aroundDep2
-
-
--- Wrapping an Expression
-
-ATTR Expression [ nt,con   :{Identifier}
-                  allfields:{[(Identifier,Type,ChildKind)]}
-                  allnts   :{[Identifier]}
-                  attrs    :{[(Identifier,Identifier)]}
-                  options  :{Options}
-                ||
-                  errors   :{Seq Error}
-                  usedLocals:{[Identifier]}
-                  usedAttrs :{[(Identifier,Identifier)]}
-                  usedFields:{[Identifier]}
-                  textLines :{[String]}
-                  copy : SELF
-                  allRhsVars : {Set (Identifier,Identifier)}
-                ]
-
--- appendum: filter out the syn attrs of merged children in the input attr list.
---           add the merged children to the used attr list
--- appendum: ignored the error reporting on expressions. These are already
---           reported by the separate 'ResolveLocals' pass.
-SEM Expression
-  | Expression  loc.(textLines,usedAttrs,usedLocals,usedFields)
-                            = let mergedChildren = [ x | (_,xs) <- Map.elems @lhs.mergeMap, x <- xs ]
-                                  attrsIn = filter (\(fld,_) -> not (fld `elem` mergedChildren)) @lhs.attrs
-                                  inherited = Inh_HsTokensRoot
-                                              { attrs_Inh_HsTokensRoot      = attrsIn
-                                              , con_Inh_HsTokensRoot        = @lhs.con
-                                              , allfields_Inh_HsTokensRoot  = @lhs.allfields
-                                              , allnts_Inh_HsTokensRoot     = @lhs.allnts
-                                              , nt_Inh_HsTokensRoot         = @lhs.nt
-                                              , options_Inh_HsTokensRoot    = @lhs.options
-                                              }
-                                  synthesized = wrap_HsTokensRoot (sem_HsTokensRoot (HsTokensRoot @tks)) inherited
-                              in case synthesized of
-                                   Syn_HsTokensRoot
-                                    { textLines_Syn_HsTokensRoot  = textLines
-                                    , usedAttrs_Syn_HsTokensRoot  = usedAttrs
-                                    , usedLocals_Syn_HsTokensRoot = usedLocals
-                                    , usedFields_Syn_HsTokensRoot = usedFields
-                                    }  -> let extraAttrs = [ (src,attr)
-                                                           | (fld,attr) <- usedAttrs, let mbMerged = Map.lookup fld @lhs.mergeMap, isJust mbMerged
-                                                           , let (Just (_, srcs)) = mbMerged, src <- srcs ]
-                                              usedAttrs' = usedAttrs ++ extraAttrs
-                                          in (textLines,usedAttrs',usedLocals,usedFields)
-
-                lhs.errors = Seq.empty
-                lhs.allRhsVars = Set.fromList @loc.usedAttrs
-                                 `Set.union`
-                                 Set.fromList [ (_LOC, l) | l <- @loc.usedLocals]
-                                 `Set.union`
-                                 Set.fromList [ (_FIELD, fld) | fld <- @loc.usedFields]
-
-
--------------------------------------
--- NT-Attributes
--------------------------------------
-ATTR  Nonterminals Nonterminal
-      [ | acount : Int |  ntattrs USE {Seq.><} {Seq.empty} : {Seq (Vertex,NTAttr)}
-                          aranges  USE {Seq.><} {Seq.empty} : {Seq (Int,Int,Int)}]
-
-SEM Grammar
-  | Grammar nonts.acount = 0
-
-SEM Nonterminal
-  | Nonterminal loc.ntattrs =  [ NTAInh @nt inh tp | (inh,tp) <- Map.assocs @inh ]
-                               ++ [NTASyn @nt syn tp | (syn,tp) <- Map.assocs @syn ]
-                lhs.ntattrs = Seq.fromList (zip [@lhs.acount ..] @ntattrs)
-                lhs.acount  = @lhs.acount + Map.size @inh + Map.size @syn
-                lhs.aranges =  Seq.singleton
-                                (@lhs.acount
-                                ,@lhs.acount + Map.size @inh
-                                ,@lhs.acount + Map.size @syn + Map.size @inh - 1)
-------------------------------------------------------------------
--- Pass structure up
-------------------------------------------------------------------
-ATTR Nonterminals Nonterminal [ | | nonts USE {++} {[]} : {[(NontermIdent,[ConstructorIdent])]} ]
-SEM  Nonterminal
-  |  Nonterminal  lhs.nonts = [(@nt,@prods.cons)]
-ATTR Productions Production [ | | cons USE {++} {[]} : {[ConstructorIdent]} ]
-SEM  Production
-  |  Production  lhs.cons = [@con]
-
-------------------------------------------------------------------
--- Collect type signatures
-------------------------------------------------------------------
-ATTR TypeSigs TypeSig [ | typeSigs : {Map Identifier Type} | ]
-SEM Production
-  | Production typeSigs.typeSigs = Map.empty
-SEM TypeSig
-  | TypeSig lhs.typeSigs = Map.insert @name @tp @lhs.typeSigs
-
-ATTR Rules Rule Patterns Pattern [ allTypeSigs : {Map Identifier Type} | | ]
-SEM  Production
-  |  Production rules.allTypeSigs = @typeSigs.typeSigs
-
-------------------------------------------------------------------
--- Invoking sequential computation
-------------------------------------------------------------------
-SEM Grammar
-  | Grammar loc.ruleTable = Array.array (0,@nonts.vcount-1) (toList @nonts.rules)
-            loc.attrTable = Array.array (0,@nonts.acount-1) (toList @nonts.ntattrs)
-            loc.attrVertex = Map.fromList (map swap (toList @nonts.ntattrs))
-            loc.tdpToTds  = [ (s, maybe (-1) (\v -> findWithErr1 "Grammar.tdpToTds" v @attrVertex) (ntattr cr))
-                            | (s,cr) <- toList @nonts.rules]
-            loc.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)
-            loc.directDep = toList (@nonts.directDep Seq.>< @nonts.additionalDep)
-            loc.instDep   = toList @nonts.instDep
-            loc.aroundDep = toList @nonts.aroundDep
-            loc.mergeDep  = toList @nonts.mergeDep
-            loc.info      = let def [] = -1
-                                def (v:vs) = v
-                             in Info { tdsToTdp   = Array.array (0,@nonts.acount-1) @tdsToTdp
-                                     , tdpToTds   = Array.array (0,@nonts.vcount-1) @tdpToTds
-                                     , attrTable  = @attrTable
-                                     , ruleTable  = @ruleTable
-                                     , lmh        = toList @nonts.aranges
-                                     , nonts      = @nonts.nonts
-                                     , wraps      = @wrappers
-                                     }
-
-            loc.(cInterfaceMap,cVisitsMap,cyclesErrors) =
-                              case computeSequential @info @directDep (@instDep ++ @aroundDep ++ @loc.mergeDep) 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 @lhs.options)) 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 @lhs.options)) 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 @lhs.options) errs
-                                                                     )
-                                           InducedCycle cim errs ->  ( cim
-                                                                     , error "No visit sub-sequences for AG with induced cycles"
-                                                                     , inducedCycleErrs @attrTable @ruleTable cim errs
-                                                                     )
-            lhs.errors = (if withCycle @lhs.options then Seq.fromList @cyclesErrors else Seq.empty)
-                          Seq.>< @nonts.errors
-
-------------------------------------------------------------------
--- Generate CGrammar
-------------------------------------------------------------------
--- Pass InterfaceMap down and select the Interface in the Nonterminal
-ATTR Nonterminals Nonterminal [ cInterfaceMap : CInterfaceMap | | ]
-SEM  Nonterminal
-  |  Nonterminal  loc.cInter = if  @lhs.o_dovisit
-                                      then findWithErr1 "Nonterminal.cInter" @nt @lhs.cInterfaceMap
-                                      else CInterface [CSegment @inh @syn]
-
--- Pass VisitMap down and select the CVisits in the Production
-ATTR Nonterminals Nonterminal Productions Production [ cVisitsMap : CVisitsMap | | ]
-SEM  Production
-  |  Production loc.cVisits = if  @lhs.o_dovisit
-                                   then let prodsVisitsMap = findWithErr1 "Production.cVisits.nt" @lhs.nt @lhs.cVisitsMap
-                                            visits = findWithErr1 "Production.cVisits.con" @con prodsVisitsMap
-                                         in visits
-                                   else  let  vss = nubBy eqCRuleDefines @gathRules ++ @children.singlevisits
-                                         in  [CVisit @lhs.inh @lhs.syn vss [] False]
-
--- Declarations for single visits
-ATTR Child Children [ | | singlevisits USE {++} {[]}: {[CRule]}]
-SEM Child
-  | Child lhs.singlevisits  =  if  @maptolocal
-                                   then []
-                                   else [CChildVisit @name (getNtName @tp) 0 @loc.inh @loc.syn True]
-
--- Now just build the CGrammar
-SEM  Grammar [ | | output : CGrammar ]
-  |  Grammar  lhs.output = CGrammar @typeSyns @derivings @wrappers @nonts.cNonterminals @pragmas @paramMap @contextMap @quantMap @loc.aroundMap @loc.mergeMap @loc.o_dovisit
-SEM  Nonterminals [ | | cNonterminals : CNonterminals ]
-  |  Cons  lhs.cNonterminals = @hd.cNonterminal : @tl.cNonterminals
-  |  Nil   lhs.cNonterminals = []
-SEM  Nonterminal [ | | cNonterminal : CNonterminal ]
-  |  Nonterminal  lhs.cNonterminal = CNonterminal @nt @params @inh @syn @prods.cProductions @cInter
-SEM  Productions [ | | cProductions : CProductions ]
-  |  Cons  lhs.cProductions = @hd.cProduction : @tl.cProductions
-  |  Nil   lhs.cProductions = []
-SEM  Production [ | | cProduction : CProduction ]
-  |  Production  lhs.cProduction = CProduction @con @cVisits @children.fields @children.terminals
-
-SEM Grammar
-  | Grammar  loc.aroundMap = Map.map (Map.map Map.keysSet) @aroundsMap
-             loc.mergeMap  = Map.map (Map.map (Map.map (\(nt,srcs,_) -> (nt,srcs)))) @mergeMap
-
--- Collect terminals
-ATTR Children Child  [ | | terminals USE {++} {[]} : {[Identifier]} ]
-SEM Child
-  | Child lhs.terminals = if @maptolocal
-                          then [@name]
-                          else []
-
-
--- Collecting nts
-ATTR Nonterminal Nonterminals
-     Production Productions
-     Rule Rules
-     Child Children [allnts:{[Identifier]} | | ]
-
-SEM Grammar
-  | Grammar nonts.allnts = map fst (@nonts.nonts)
-
--- Collecting fields
-ATTR Rule Rules
-     Child Children [allfields:{[(Identifier,Type,ChildKind)]} attrs:{[(Identifier,Identifier)]} | | ]
-
-SEM Production
-  | Production loc.allfields  = @children.fields
-                   .attrs      = map ((,) _LOC)  @rules.locVars ++
-                                 map ((,) _INST) @rules.instVars ++
-                                 map ((,) _LHS)  @inhnames ++
-                                 concat [map ((,) nm) (Map.keys as) | (nm,_,as) <- @children.attributes]
-                   .inhnames   = Map.keys @lhs.inh
-                   .synnames   = Map.keys @lhs.syn
-
-ATTR Children [ | | attributes USE {++} {[]} : {[(Identifier,Attributes,Attributes)]} ]
-SEM Child [ | | attributes:{[(Identifier,Attributes,Attributes)]} ]
-  | Child lhs.attributes = [(@name, @loc.inh, @loc.syn)]
-
-
-SEM Child [ | | field : {(Identifier,Type,ChildKind)} ]
-  | Child lhs.field = (@name, @tp, @kind)
-
-SEM Children [ | | fields : {[(Identifier,Type,ChildKind)]} ]
-  | Cons  lhs.fields = @hd.field : @tl.fields
-  | Nil   lhs.fields = []
-
-ATTR Rules Rule Patterns Pattern [ | | locVars USE {++} {[]}:{[Identifier]} instVars USE {++} {[]} : {[Identifier]} ]
-
-SEM Pattern
-  | Alias    lhs.locVars   = if @field == _LOC
-                                then [@attr]
-                                else []
-             lhs.instVars  = if @field == _INST
-                                then [@attr]
-                                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<n       = xs ++ replicate (n-k) ' '
-            | otherwise = xs
-              where k = length xs
-
-alignR n xs | k<n       = replicate (n-k) ' ' ++ xs
-            | otherwise = xs
-              where k = length xs
-
-localCycleErr :: Table CRule -> 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)
-}
+PRAGMA strictdata+PRAGMA strictwrap++INCLUDE "Patterns.ag"+INCLUDE "Expression.ag"+INCLUDE "AbstractSyntax.ag"+INCLUDE "DistChildAttr.ag"++imports+{+-- 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 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 Data.Sequence as Seq+import Data.Map(Map)+import Data.Set(Set)+import Data.Sequence(Seq, (><))+import UU.Util.Utils+import UU.Scanner.Position(Pos(..),initPos)+import Data.Foldable(toList)++-- 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 Data.Maybe+}++{+-- 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+}++--+-- Some statistics, count number of attributes+--++ATTR Grammar Nonterminals Nonterminal Productions Production Rules Rule [ | | nAutoRules,nExplicitRules USE {+} {0} : {Int} ]++SEM Rule+  | Rule  lhs.nExplicitRules = if @explicit+                               then 1+                               else 0+          lhs.nAutoRules = if startsWith "use rule" @origin || startsWith "copy rule" @origin+                           then 1+                           else 0++{+startsWith :: String -> String -> Bool+startsWith k h = k == take (length k) h+}+++-------------------------------------------------------------------------------+--         Errors+-------------------------------------------------------------------------------+-- Everyone that wants to report an error can do this by adding an error message to the+-- stream of errors++ATTR Nonterminals Nonterminal Productions Production+     Child Children Rule Rules Pattern Patterns Grammar [ | | errors USE {Seq.><} {Seq.empty}:{Seq Error} ]++-------------------------------------------------------------------------------+--         Distributing name of nonterminal and names of attributes+-------------------------------------------------------------------------------+ATTR Productions Production Child Children Rules Rule Patterns Pattern [ nt : {Identifier} inh,syn : {Attributes} | | ]+ATTR Child Children Rules Rule Patterns Pattern [ con : {Identifier} | | ]++SEM Production+  | Production children . con = @con+SEM Production+  | Production rules . con = @con+SEM Nonterminal+  | Nonterminal prods . nt = @nt++SEM Nonterminal+  | Nonterminal prods.inh  = @inh+                prods.syn  = @syn+++-------------------------------------------------------------------------------+--         Distributing options+-------------------------------------------------------------------------------++ATTR Grammar          [ options:{Options} | | ]+ATTR Nonterminals Nonterminal Productions Production Rules Rule+   [ o_newtypes+   , o_cata+   , o_sig+   , o_sem+   , o_rename+   , o_wantvisit -- True if the option for visit functions has been specified+   , o_dovisit   -- True if o_wantvisit and it is possible to generate visit functions (no cycles)+   , o_case:{Bool}+   prefix : {String} | | ]+ATTR Nonterminals Nonterminal Productions Production Children Child [ o_unbox:{Bool} | | ]+ATTR Nonterminals Nonterminal [ o_data:{Bool} | | ]++SEM Grammar+  | Grammar     loc.o_dovisit   = visit     @lhs.options && null @cyclesErrors+                nonts.o_cata    = folds     @lhs.options+                     .o_data    = dataTypes @lhs.options+                     .o_sig     = typeSigs  @lhs.options+                     .o_sem     = semfuns   @lhs.options+                     .o_rename  = rename    @lhs.options+                     .o_newtypes= newtypes  @lhs.options+                     .o_wantvisit = visit   @lhs.options+                     .o_unbox   = unbox     @lhs.options+                     .o_case    = cases     @lhs.options+                     .prefix    = prefix    @lhs.options++------------------------------------------------------------------+-- Building a mapping from Vertices to Ints+------------------------------------------------------------------+{+getNtName :: Type -> NontermIdent+getNtName (NT nt _ _) = nt+getNtName _           = nullIdent+}++------------------------------------------------------------------+-- Collect attribute occurrences+--+-- All attribute occurences in an alternative are gathered.+-- This is done by joining various sublists:+--  1.  inherited attributes for _LHS+--  2a. synthesized attributes for children+--  2b. children that are a trivial field+--  3a. inherited attributes for children+--  3b. synthesized attributes for _LHS+--  3c. local attributes+--+-- Sublist 3 is exactly the targets for ATTR definitions, and+-- thus can be obtained by traversing all rules.+--+-- The (field,attr) combination is not enough to uniquely identify+-- an attribute occurence, because threaded attributes occur twice.+-- Therefore, in the AltAttr structures, a boolean is added,+-- that is False in sublists 3a and 3b, i.e. the non-local output fields.+--+-- Each AltAttr, that is eacht attribute occurence, is mapped to a number+-- in the altAttrs Map, starting at vcount+{+data AltAttr = AltAttr Identifier Identifier Bool+               deriving (Eq, Ord, Show)+}+ATTR  Rules Rule Production Productions Nonterminal Nonterminals+  [ options : {Options} | | ]++ATTR Children Child Rules Rule Patterns Pattern [ | | gathAltAttrs USE {++} {[]} : {[AltAttr]} ]+SEM  Production+  |  Production  loc.gathAltAttrs =  [ AltAttr _LHS inh True | inh <- Map.keys @lhs.inh ]   -- sublist 1+                                      ++ @children.gathAltAttrs                              -- sublist 2+                                      ++ @rules.gathAltAttrs                                 -- sublist 3++SEM  Child+  |  Child  loc.maptolocal =  case @tp of+                                NT nt _ _ -> Map.null @syn+                                _         -> True+            lhs.gathAltAttrs = if  @maptolocal+                                   then [ AltAttr _LOC @name True ]                          -- sublist 2b+                                   else [ AltAttr @name syn True | syn <- Map.keys @loc.syn ]    -- sublist 2a+SEM  Pattern+  |  Alias lhs.gathAltAttrs = [AltAttr @field @attr (@field == _LOC || @field == _INST)]     -- sublist 3++ATTR Rules Rule Patterns Pattern [ altAttrs : {Map AltAttr Vertex} | | ]+SEM  Production+  |  Production loc.altAttrs = Map.fromList (zip @gathAltAttrs [@lhs.vcount..])++-- Information passed to Pattern+ATTR  Children Child+      [  | |  nts USE {Seq.><} {Seq.empty} : {Seq (Identifier,NontermIdent)}+              inhs USE {Seq.><} {Seq.empty} : {Seq (Identifier,Attributes)} ]+SEM  Child+  |  Child  lhs.nts = Seq.singleton (@name,getNtName @tp)+            lhs.inhs = Seq.singleton (@name,@loc.inh)+ATTR  Rules Rule+      [  childNts : {Map Identifier NontermIdent}+         childInhs : {Map Identifier Attributes} | | ]+SEM  Production+  |  Production  rules.childNts = Map.fromList (toList @children.nts)+                  rules.childInhs = Map.fromList (toList @children.inhs)++-- Collect CRules+ATTR  Children Child Rules Rule+      [ | | gathRules USE {Seq.><} {Seq.empty} : {Seq CRule} ]+SEM  Production+  |  Production  loc.inhRules = [ cRuleLhsInh inh @lhs.nt @con tp | (inh,tp) <- Map.assocs @lhs.inh ]+                  loc.gathRules = @inhRules ++ toList (@children.gathRules Seq.>< @rules.gathRules)++SEM  Child+  |  Child  loc.gathRules = if  @maptolocal+                                then Seq.singleton (cRuleTerminal @name @lhs.nt @lhs.con @tp)+                                else Seq.fromList [ cRuleRhsSyn syn @lhs.nt @lhs.con tp @name (getNtName @tp) | (syn,tp) <- Map.assocs @loc.syn]++SEM  Rule+  |  Rule  loc.defines = let  tp field attr      | field == _LOC || field == _INST+                                                                  = Map.lookup attr @lhs.allTypeSigs+                                                  | field == _LHS = Map.lookup attr @lhs.syn+                                                  | otherwise     = Map.lookup attr (findWithErr1 "Rule.defines.tp" field @lhs.childInhs)+                              typ :: Pattern -> Maybe Type+                              typ (Alias field attr _)       = tp field attr+                              typ (Underscore _)             = Nothing+                              -- typ (Product _ pats)           = tp _LOC undefined pats+                              typ _                          = Nothing++                         in Map.fromList  [ (findWithErr1 "Rule.defines" aa @lhs.altAttrs, (field,attr,(tp field attr)))+                                          | (field,attr,isLocalOrInst) <- @pattern.patternAttrs+                                          , let aa = AltAttr field attr isLocalOrInst+                                          ]+           loc.gathRules =  let childnt field = Map.lookup field @lhs.childNts+                            in Seq.fromList [ CRule attr False True @lhs.nt @lhs.con field (childnt field) tp @pattern.copy @rhs.textLines @defines @owrt @origin @rhs.allRhsVars @explicit @mbName+                                            | (field,attr,tp) <- Map.elems @defines+                                            ]++{+substSelf nt tp+  = case tp of+      NT n tps defor | n == _SELF -> NT nt tps defor+      _                           -> tp++haskellTupel :: [Type] -> Maybe Type+haskellTupel ts =  Just ( Haskell ( '(' : (concat (intersperse "," (map show ts))) ++ ")" ))+}+++ATTR Patterns Pattern [ | | patternAttrs USE {++} {[]} : {[(Identifier,Identifier,Bool)]} ]++SEM  Pattern+  |  Alias lhs.patternAttrs = [(@field,@attr,(@field == _LOC || @field == _INST))]++++-- Giving them a number+ATTR  Nonterminals Nonterminal Productions Production+      [  | vcount : Int+         | rules USE {Seq.><} {Seq.empty} : {Seq (Vertex,CRule)}]+SEM  Grammar+  |  Grammar  nonts.vcount = 0+SEM  Production+  |  Production  lhs.rules = Seq.fromList (zip [@lhs.vcount..] @gathRules)+                  lhs.vcount = @lhs.vcount + length @gathRules++-- Direct dependencies+ATTR Nonterminals Nonterminal+     Productions Production+     Rules Rule [ | | directDep USE {Seq.><} {Seq.empty} : {Seq Edge} ]+SEM  Rule+  |  Rule  lhs.directDep+             = let  defined = Map.keys @defines+                    used =  [ Map.lookup (AltAttr field attr True) @lhs.altAttrs | (field,attr) <- @rhs.usedAttrs]+                            ++ [ Map.lookup (AltAttr _LOC attr True) @lhs.altAttrs | attr <- @rhs.usedLocals ++ @rhs.usedFields ]+               in Seq.fromList [ (x,y) | Just x <- used, y <- defined ]++-- Manual depdendencies (provided by the programmer)+--+-- a dependency f1.a1 < f2.a2 is translated to+-- the edge (vertex(f1.a1), vertex(f2.a2))+ATTR Nonterminals Nonterminal+     Productions Production+     [ manualAttrDepMap : {AttrOrderMap} | | additionalDep USE {Seq.><} {Seq.empty} : {Seq Edge} ]++SEM Grammar+  | Grammar+      nonts.manualAttrDepMap = @manualAttrOrderMap++SEM Production+  | Production+      loc.manualDeps+        = Set.toList $ Map.findWithDefault Set.empty @con $ Map.findWithDefault Map.empty @lhs.nt @lhs.manualAttrDepMap++      lhs.additionalDep+        = Seq.fromList [ (vertex True occA, vertex False occB)+                       | Dependency occA occB <- @loc.manualDeps+                       , let vertex inout (OccAttr child nm)+                               | child == _LOC = findWithErr2 (AltAttr _LOC nm True) @loc.altAttrs+                               | otherwise     = findWithErr2 (AltAttr child nm inout) @loc.altAttrs+                             vertex _ (OccRule nm)+                               = findWithErr2 (AltAttr _LOC (Ident ("_rule_" ++ show nm) (getPos nm)) True) @loc.altAttrs+                       ]++-- Inst dependencies+--+-- For each inst attribute x of nt N, add the dependency+--  (inst.x,x.y) for each synthesized attribute of N+--++ATTR Nonterminals Nonterminal+     Productions Production+     Rules Rule [ | | instDep USE {Seq.><} {Seq.empty} : {Seq Edge} ]+SEM Rule+  | Rule+     loc.instDep1+        = Seq.fromList $+            [ (instVert, synVert)+            | (field,instNm,_) <- Map.elems @defines+            , field == _INST+            , synNm <- Map.keys (findWithErr2 instNm @lhs.synsOfChildren)+            , let instAttr = AltAttr _INST instNm True+                  synAttr  = AltAttr instNm synNm True+                  instVert = findWithErr2 instAttr @lhs.altAttrs+                  synVert  = findWithErr2 synAttr @lhs.altAttrs+            ]+     loc.instDep2+        = Seq.fromList $+            [ (instVert, inhVert)+            | (field,instNm,_) <- Map.elems @defines+            , field == _INST+            , inhNm <- Map.keys (findWithErr2 instNm @lhs.inhsOfChildren)+            , let instAttr = AltAttr _INST instNm True+                  inhAttr  = AltAttr instNm inhNm False+                  instVert = findWithErr2 instAttr @lhs.altAttrs+                  inhVert  = findWithErr2 inhAttr @lhs.altAttrs+            ]+     lhs.instDep = @loc.instDep1 Seq.>< @loc.instDep2++ATTR Rules Rule [ synsOfChildren, inhsOfChildren : {Map Identifier Attributes} | | ]+SEM Production+  | Production  rules.synsOfChildren = @children.collectChildrenSyns+                rules.inhsOfChildren = @children.collectChildrenInhs++ATTR Children Child [ | | collectChildrenSyns, collectChildrenInhs USE {`Map.union`} {Map.empty} : {Map Identifier Attributes } ]+SEM Child+  | Child  lhs.collectChildrenSyns = Map.singleton @name @loc.syn+           lhs.collectChildrenInhs = Map.singleton @name @loc.inh++--+-- Merge stuff+--++ATTR Nonterminals Nonterminal+  [ mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))} | | ]++ATTR Productions Production+  [ mergeMap : {Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))} | | ]++SEM Nonterminal | Nonterminal  loc.mergeMap = Map.findWithDefault Map.empty @nt @lhs.mergeMap+SEM Production  | Production   loc.mergeMap = Map.findWithDefault Map.empty @con @lhs.mergeMap++ATTR Rules Rule Children Child Expression [ mergeMap : {Map Identifier (Identifier,[Identifier])} | | ]++-- for a child c : N, with merged children cs, add dependencies between synthesized attrs of+-- c to synthesized attrs of cs, and to the merge-attribute+ATTR Nonterminals Nonterminal Productions Production+  [ | | mergeDep USE {Seq.><} {Seq.empty} : {Seq Edge} ]++SEM Production+  | Production+      lhs.mergeDep = @loc.mergeDep1 Seq.>< @loc.mergeDep2+      loc.mergeDep1+        = Seq.fromList $+             [ (childVert, synVert)+             | childNm <- Map.keys @loc.mergeMap+             , synNm <- Map.keys (findWithErr2 childNm @children.collectChildrenSyns)+             , let childNm' = Ident (show childNm ++ "_merge") (getPos childNm)+                   childAttr = AltAttr _LOC childNm' True+                   synAttr  = AltAttr childNm synNm True+                   childVert = findWithErr2 childAttr @loc.altAttrs+                   synVert  = findWithErr2 synAttr @loc.altAttrs+             ]+      loc.mergeDep2+        = Seq.fromList $+             [ (mergedVert, sourceVert)+             | (childNm, (_,cs)) <- Map.assocs @loc.mergeMap+             , c <- cs+             , synNm <- Map.keys (findWithErr2 childNm @children.collectChildrenSyns)+             , let sourceAttr = AltAttr childNm synNm True+                   mergedAttr = AltAttr c synNm True+                   sourceVert = findWithErr2 sourceAttr @loc.altAttrs+                   mergedVert = findWithErr2 mergedAttr @loc.altAttrs+             ]+++-- Around dependencies+--+-- For each around x_around on x of nt N, add the dependency+-- (x_around, x.y) for each synthesized attribute y of N+--++ATTR Nonterminals Nonterminal+     Productions Production+       [ | | aroundDep USE {Seq.><} {Seq.empty} : {Seq Edge} ]++ATTR Nonterminals Nonterminal+  [ aroundMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} || ]++ATTR Productions Production+  [ aroundMap : {Map ConstructorIdent (Map Identifier [Expression])} || ]++SEM Nonterminal | Nonterminal  loc.aroundMap = Map.findWithDefault Map.empty @nt @lhs.aroundMap+SEM Production | Production    loc.aroundMap = Map.findWithDefault Map.empty @con @lhs.aroundMap++SEM Grammar+  | Grammar  nonts.aroundMap = @aroundsMap++SEM Production+ | Production+     loc.aroundDep1+       = Seq.fromList $+           [ (childVert, synVert)+           | childNm <- Map.keys @loc.aroundMap+           , synNm <- Map.keys (findWithErr2 childNm @children.collectChildrenSyns)+           , let childNm' = Ident (show childNm ++ "_around") (getPos childNm)+                 childAttr = AltAttr _LOC childNm' True+                 synAttr  = AltAttr childNm synNm True+                 childVert = findWithErr2 childAttr @loc.altAttrs+                 synVert  = findWithErr2 synAttr @loc.altAttrs+           ]+     loc.aroundDep2+        = Seq.fromList $+            [ (childVert, inhVert)+            | childNm <- Map.keys @loc.aroundMap+            , inhNm <- Map.keys (findWithErr2 childNm @children.collectChildrenInhs)+            , let childNm'  = Ident (show childNm ++ "_around") (getPos childNm)+                  childAttr = AltAttr _LOC childNm' True+                  inhAttr   = AltAttr childNm inhNm False+                  childVert = findWithErr2 childAttr @loc.altAttrs+                  inhVert   = findWithErr2 inhAttr @loc.altAttrs+            ]+     lhs.aroundDep = @loc.aroundDep1 Seq.>< @loc.aroundDep2+++-- Wrapping an Expression++ATTR Expression [ nt,con   :{Identifier}+                  allfields:{[(Identifier,Type,ChildKind)]}+                  allnts   :{[Identifier]}+                  attrs    :{[(Identifier,Identifier)]}+                  options  :{Options}+                ||+                  errors   :{Seq Error}+                  usedLocals:{[Identifier]}+                  usedAttrs :{[(Identifier,Identifier)]}+                  usedFields:{[Identifier]}+                  textLines :{[String]}+                  copy : SELF+                  allRhsVars : {Set (Identifier,Identifier)}+                ]++-- appendum: filter out the syn attrs of merged children in the input attr list.+--           add the merged children to the used attr list+-- appendum: ignored the error reporting on expressions. These are already+--           reported by the separate 'ResolveLocals' pass.+SEM Expression+  | Expression  loc.(textLines,usedAttrs,usedLocals,usedFields)+                            = let mergedChildren = [ x | (_,xs) <- Map.elems @lhs.mergeMap, x <- xs ]+                                  attrsIn = filter (\(fld,_) -> not (fld `elem` mergedChildren)) @lhs.attrs+                                  inherited = Inh_HsTokensRoot+                                              { attrs_Inh_HsTokensRoot      = attrsIn+                                              , con_Inh_HsTokensRoot        = @lhs.con+                                              , allfields_Inh_HsTokensRoot  = @lhs.allfields+                                              , allnts_Inh_HsTokensRoot     = @lhs.allnts+                                              , nt_Inh_HsTokensRoot         = @lhs.nt+                                              , options_Inh_HsTokensRoot    = @lhs.options+                                              }+                                  synthesized = wrap_HsTokensRoot (sem_HsTokensRoot (HsTokensRoot @tks)) inherited+                              in case synthesized of+                                   Syn_HsTokensRoot+                                    { textLines_Syn_HsTokensRoot  = textLines+                                    , usedAttrs_Syn_HsTokensRoot  = usedAttrs+                                    , usedLocals_Syn_HsTokensRoot = usedLocals+                                    , usedFields_Syn_HsTokensRoot = usedFields+                                    }  -> let extraAttrs = [ (src,attr)+                                                           | (fld,attr) <- usedAttrs, let mbMerged = Map.lookup fld @lhs.mergeMap, isJust mbMerged+                                                           , let (Just (_, srcs)) = mbMerged, src <- srcs ]+                                              usedAttrs' = usedAttrs ++ extraAttrs+                                          in (textLines,usedAttrs',usedLocals,usedFields)++                lhs.errors = Seq.empty+                lhs.allRhsVars = Set.fromList @loc.usedAttrs+                                 `Set.union`+                                 Set.fromList [ (_LOC, l) | l <- @loc.usedLocals]+                                 `Set.union`+                                 Set.fromList [ (_FIELD, fld) | fld <- @loc.usedFields]+++-------------------------------------+-- NT-Attributes+-------------------------------------+ATTR  Nonterminals Nonterminal+      [ | acount : Int |  ntattrs USE {Seq.><} {Seq.empty} : {Seq (Vertex,NTAttr)}+                          aranges  USE {Seq.><} {Seq.empty} : {Seq (Int,Int,Int)}]++SEM Grammar+  | Grammar nonts.acount = 0++SEM Nonterminal+  | Nonterminal loc.ntattrs =  [ NTAInh @nt inh tp | (inh,tp) <- Map.assocs @inh ]+                               ++ [NTASyn @nt syn tp | (syn,tp) <- Map.assocs @syn ]+                lhs.ntattrs = Seq.fromList (zip [@lhs.acount ..] @ntattrs)+                lhs.acount  = @lhs.acount + Map.size @inh + Map.size @syn+                lhs.aranges =  Seq.singleton+                                (@lhs.acount+                                ,@lhs.acount + Map.size @inh+                                ,@lhs.acount + Map.size @syn + Map.size @inh - 1)+------------------------------------------------------------------+-- Pass structure up+------------------------------------------------------------------+ATTR Nonterminals Nonterminal [ | | nonts USE {++} {[]} : {[(NontermIdent,[ConstructorIdent])]} ]+SEM  Nonterminal+  |  Nonterminal  lhs.nonts = [(@nt,@prods.cons)]+ATTR Productions Production [ | | cons USE {++} {[]} : {[ConstructorIdent]} ]+SEM  Production+  |  Production  lhs.cons = [@con]++------------------------------------------------------------------+-- Collect type signatures+------------------------------------------------------------------+ATTR TypeSigs TypeSig [ | typeSigs : {Map Identifier Type} | ]+SEM Production+  | Production typeSigs.typeSigs = Map.empty+SEM TypeSig+  | TypeSig lhs.typeSigs = Map.insert @name @tp @lhs.typeSigs++ATTR Rules Rule Patterns Pattern [ allTypeSigs : {Map Identifier Type} | | ]+SEM  Production+  |  Production rules.allTypeSigs = @typeSigs.typeSigs++------------------------------------------------------------------+-- Invoking sequential computation+------------------------------------------------------------------+SEM Grammar+  | Grammar loc.ruleTable = Array.array (0,@nonts.vcount-1) (toList @nonts.rules)+            loc.attrTable = Array.array (0,@nonts.acount-1) (toList @nonts.ntattrs)+            loc.attrVertex = Map.fromList (map swap (toList @nonts.ntattrs))+            loc.tdpToTds  = [ (s, maybe (-1) (\v -> findWithErr1 "Grammar.tdpToTds" v @attrVertex) (ntattr cr))+                            | (s,cr) <- toList @nonts.rules]+            loc.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)+            loc.directDep = toList (@nonts.directDep Seq.>< @nonts.additionalDep)+            loc.instDep   = toList @nonts.instDep+            loc.aroundDep = toList @nonts.aroundDep+            loc.mergeDep  = toList @nonts.mergeDep+            loc.info      = let def [] = -1+                                def (v:vs) = v+                             in Info { tdsToTdp   = Array.array (0,@nonts.acount-1) @tdsToTdp+                                     , tdpToTds   = Array.array (0,@nonts.vcount-1) @tdpToTds+                                     , attrTable  = @attrTable+                                     , ruleTable  = @ruleTable+                                     , lmh        = toList @nonts.aranges+                                     , nonts      = @nonts.nonts+                                     , wraps      = @wrappers+                                     }++            loc.(cInterfaceMap,cVisitsMap,cyclesErrors) =+                              case computeSequential @info @directDep (@instDep ++ @aroundDep ++ @loc.mergeDep) 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 @lhs.options)) 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 @lhs.options)) 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 @lhs.options) errs+                                                                     )+                                           InducedCycle cim errs ->  ( cim+                                                                     , error "No visit sub-sequences for AG with induced cycles"+                                                                     , inducedCycleErrs @attrTable @ruleTable cim errs+                                                                     )+            lhs.errors = (if withCycle @lhs.options then Seq.fromList @cyclesErrors else Seq.empty)+                          Seq.>< @nonts.errors++------------------------------------------------------------------+-- Generate CGrammar+------------------------------------------------------------------+-- Pass InterfaceMap down and select the Interface in the Nonterminal+ATTR Nonterminals Nonterminal [ cInterfaceMap : CInterfaceMap | | ]+SEM  Nonterminal+  |  Nonterminal  loc.cInter = if  @lhs.o_dovisit+                                      then findWithErr1 "Nonterminal.cInter" @nt @lhs.cInterfaceMap+                                      else CInterface [CSegment @inh @syn]++-- Pass VisitMap down and select the CVisits in the Production+ATTR Nonterminals Nonterminal Productions Production [ cVisitsMap : CVisitsMap | | ]+SEM  Production+  |  Production loc.cVisits = if  @lhs.o_dovisit+                                   then let prodsVisitsMap = findWithErr1 "Production.cVisits.nt" @lhs.nt @lhs.cVisitsMap+                                            visits = findWithErr1 "Production.cVisits.con" @con prodsVisitsMap+                                         in visits+                                   else  let  vss = nubBy eqCRuleDefines @gathRules ++ @children.singlevisits+                                         in  [CVisit @lhs.inh @lhs.syn vss [] False]++-- Declarations for single visits+ATTR Child Children [ | | singlevisits USE {++} {[]}: {[CRule]}]+SEM Child+  | Child lhs.singlevisits  =  if  @maptolocal+                                   then []+                                   else [CChildVisit @name (getNtName @tp) 0 @loc.inh @loc.syn True]++-- Now just build the CGrammar+SEM  Grammar [ | | output : CGrammar ]+  |  Grammar  lhs.output = CGrammar @typeSyns @derivings @wrappers @nonts.cNonterminals @pragmas @paramMap @contextMap @quantMap @loc.aroundMap @loc.mergeMap @loc.o_dovisit+SEM  Nonterminals [ | | cNonterminals : CNonterminals ]+  |  Cons  lhs.cNonterminals = @hd.cNonterminal : @tl.cNonterminals+  |  Nil   lhs.cNonterminals = []+SEM  Nonterminal [ | | cNonterminal : CNonterminal ]+  |  Nonterminal  lhs.cNonterminal = CNonterminal @nt @params @inh @syn @prods.cProductions @cInter+SEM  Productions [ | | cProductions : CProductions ]+  |  Cons  lhs.cProductions = @hd.cProduction : @tl.cProductions+  |  Nil   lhs.cProductions = []+SEM  Production [ | | cProduction : CProduction ]+  |  Production  lhs.cProduction = CProduction @con @cVisits @children.fields @children.terminals++SEM Grammar+  | Grammar  loc.aroundMap = Map.map (Map.map Map.keysSet) @aroundsMap+             loc.mergeMap  = Map.map (Map.map (Map.map (\(nt,srcs,_) -> (nt,srcs)))) @mergeMap++-- Collect terminals+ATTR Children Child  [ | | terminals USE {++} {[]} : {[Identifier]} ]+SEM Child+  | Child lhs.terminals = if @maptolocal+                          then [@name]+                          else []+++-- Collecting nts+ATTR Nonterminal Nonterminals+     Production Productions+     Rule Rules+     Child Children [allnts:{[Identifier]} | | ]++SEM Grammar+  | Grammar nonts.allnts = map fst (@nonts.nonts)++-- Collecting fields+ATTR Rule Rules+     Child Children [allfields:{[(Identifier,Type,ChildKind)]} attrs:{[(Identifier,Identifier)]} | | ]++SEM Production+  | Production loc.allfields  = @children.fields+                   .attrs      = map ((,) _LOC)  @rules.locVars +++                                 map ((,) _INST) @rules.instVars +++                                 map ((,) _LHS)  @inhnames +++                                 concat [map ((,) nm) (Map.keys as) | (nm,_,as) <- @children.attributes]+                   .inhnames   = Map.keys @lhs.inh+                   .synnames   = Map.keys @lhs.syn++ATTR Children [ | | attributes USE {++} {[]} : {[(Identifier,Attributes,Attributes)]} ]+SEM Child [ | | attributes:{[(Identifier,Attributes,Attributes)]} ]+  | Child lhs.attributes = [(@name, @loc.inh, @loc.syn)]+++SEM Child [ | | field : {(Identifier,Type,ChildKind)} ]+  | Child lhs.field = (@name, @tp, @kind)++SEM Children [ | | fields : {[(Identifier,Type,ChildKind)]} ]+  | Cons  lhs.fields = @hd.field : @tl.fields+  | Nil   lhs.fields = []++ATTR Rules Rule Patterns Pattern [ | | locVars USE {++} {[]}:{[Identifier]} instVars USE {++} {[]} : {[Identifier]} ]++SEM Pattern+  | Alias    lhs.locVars   = if @field == _LOC+                                then [@attr]+                                else []+             lhs.instVars  = if @field == _INST+                                then [@attr]+                                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<n       = xs ++ replicate (n-k) ' '+            | otherwise = xs+              where k = length xs++alignR n xs | k<n       = replicate (n-k) ' ' ++ xs+            | otherwise = xs+              where k = length xs++localCycleErr :: Table CRule -> 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)+}
src-ag/Patterns.ag view
@@ -1,25 +1,25 @@-imports
-{
--- Patterns.ag imports
-import UU.Scanner.Position(Pos)
-import CommonTypes (ConstructorIdent,Identifier)
-}
-
-TYPE Patterns   = [Pattern]
-
-DATA Pattern    | Constr      name  : {ConstructorIdent}
-                              pats  : Patterns
-                | Product     pos   : {Pos}
-                              pats  : Patterns
-                | Alias       field : {Identifier}
-                              attr  : {Identifier}
-                              pat   : Pattern
-                | Irrefutable pat   : Pattern
-                | Underscore  pos   : {Pos}
-
-DERIVING Pattern:Show
-
-ATTR AllPattern [ | | copy : SELF ]
-
-SET AllPattern
-  = Pattern Patterns
+imports+{+-- Patterns.ag imports+import UU.Scanner.Position(Pos)+import CommonTypes (ConstructorIdent,Identifier)+}++TYPE Patterns   = [Pattern]++DATA Pattern    | Constr      name  : {ConstructorIdent}+                              pats  : Patterns+                | Product     pos   : {Pos}+                              pats  : Patterns+                | Alias       field : {Identifier}+                              attr  : {Identifier}+                              pat   : Pattern+                | Irrefutable pat   : Pattern+                | Underscore  pos   : {Pos}++DERIVING Pattern:Show++ATTR AllPattern [ | | copy : SELF ]++SET AllPattern+  = Pattern Patterns
src-ag/PrintCleanCode.ag view
@@ -1,563 +1,563 @@-PRAGMA strictdata
-PRAGMA optimize
-PRAGMA bangpats
-PRAGMA strictwrap
-
-INCLUDE "Code.ag"
-INCLUDE "Patterns.ag"
-
-imports
-{
-import Data.Char (isAlphaNum)
-import Pretty
-import Code
-import Options
-import CommonTypes (attrname, _LOC, nullIdent)
-import Data.List(intersperse)
-import System.IO
-import System.Directory
-import System.FilePath
-import CommonTypes(BlockInfo, BlockKind(..))
-}
-
-{
-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
-}
-
-ATTR Expr Exprs Decl Decls CaseAlt CaseAlts Lhs [ outputfile : {String} | | ]
-
-SEM Chunk
-  | Chunk
-      loc.outputfile = if sepSemMods @lhs.options
-                       then replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_" ++ @name)
-                       else @lhs.mainFile
-
-ATTR Program                            [ options:{Options} | | output:{PP_Docs} ]
-
-ATTR Expr Exprs Decl Decls Chunk Chunks CaseAlts CaseAlt Lhs Pattern Patterns [ options:{Options} | | ]
-
-ATTR Expr Decl DataAlt Type NamedType Lhs [ nested:{Bool} | | pp:{PP_Doc} ]
-ATTR Decl DataAlt NamedType [ | | ppa USE {>-<} {empty} : {PP_Doc}]
-
-ATTR Exprs DataAlts Types NamedTypes Decls Chunk Chunks [ nested:{Bool} | | pps : {PP_Docs} ]
-ATTR DataAlts NamedTypes [ | | ppas : {PP_Docs} ]
-
-ATTR CaseAlt CaseAlts                   [ nested:{Bool} | | pps: {PP_Docs} ]
-
-ATTR Type Types [ | | copy : SELF]
-
-SEM Program | Program
-  loc.options = @lhs.options { breadthFirst = breadthFirst @lhs.options && visit @lhs.options && cases @lhs.options && @ordered }
-
-SEM Program
-  | Program chunks.nested = nest @lhs.options
-
-SEM Exprs
-  | Cons lhs.pps = @hd.pp : @tl.pps
-  | Nil  lhs.pps = []
-
-SEM CaseAlts
-  | Cons lhs.pps = @hd.pps ++ @tl.pps
-  | Nil  lhs.pps = []
-
-SEM DataAlts
-  | Cons lhs.pps  = @hd.pp : @tl.pps
-         lhs.ppas = @hd.ppa : @tl.ppas
-  | Nil  lhs.pps  = []
-         lhs.ppas = []
-
-SEM Types
-  | Cons lhs.pps = @hd.pp : @tl.pps
-  | Nil  lhs.pps = []
-
-SEM NamedTypes
-  | Cons lhs.pps  = @hd.pp : @tl.pps
-         lhs.ppas = @hd.ppa : @tl.ppas
-  | Nil  lhs.pps  = []
-         lhs.ppas = []
-
-SEM Decls
-  | Cons lhs.pps = @hd.pp : @tl.pps
-  | Nil  lhs.pps = []
-
-SEM Chunks
-  | Cons lhs.pps = @hd.pps ++ @tl.pps
-  | Nil  lhs.pps = []
-
-
-SEM Program
-  | Program    lhs.output  = @chunks.pps
-
-SEM Chunk
-  | Chunk      lhs.pps     =  @comment.pp
-                              :  @info.pps
-                              ++ @dataDef.pps
-                              ++ @cataFun.pps
-                              ++ @semDom.pps
-                              ++ @semWrapper.pps
-                              ++ @semFunctions.pps
-                              ++ [Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap]
-
-SEM Decl
-  | Decl       lhs.pp      = @left.pp >#< "="
-                             >-< indent 4 @rhs.pp
-  | Bind       lhs.pp      = @left.pp >#< "<-" >#< @rhs.pp
-  | BindLet    lhs.pp      = "let" >#< @left.pp >#< "=" >#< @rhs.pp
-  | Data       lhs.pp      = "::" >#< hv_sp (@name : @params)
-                             >#<  ( case @alts.pps of
-                                          [] -> empty
-                                          (x:xs) ->              "=" >#<  x
-                                                 >-< vlist (map ("|" >#<) xs)
-                                     >-< if null @derivings
-                                            then empty
-                                            else "deriving" >#< ppTuple False (map text @derivings)
-                                  )
-                             >-< foldr (>-<) empty @alts.ppas
-
-  | NewType    lhs.pp      = "::" >#< hv_sp (@name : @params) >#< "=" >#< @con >#< pp_parens @tp.pp
-  | Type       lhs.pp      = "::" >#< hv_sp (@name : @params) >#< ":==" >#<  @tp.pp
-  | TSig       lhs.pp      = @name >#< "::" >#< @tp.pp
-  | Comment    lhs.pp      = if '\n' `elem` @txt
-                               then "/*" >-< vlist (lines @txt) >-< "*/"
-                               else "//" >#< @txt
-  | PragmaDecl lhs.pp      = "/*#" >#< text @txt >#< "#*/" -- Not used in Clean
-  | Resume     lhs.pp      = if @monadic
-                             then @left.pp >#< "<-" >#< @rhs.pp
-                             else @left.pp >#< "=" >-< indent 4 @rhs.pp
-  | EvalDecl   loc.strat   = if breadthFirstStrict @lhs.options
-                             then "stepwiseEval"
-                             else "lazyEval"
-               lhs.pp      = if breadthFirst @lhs.options
-                             then @left.pp >#< "=" >#< "case" >#< @loc.strat >#< pp_parens @rhs.pp >#< "of"
-                                  >-< indent 4 (
-                                    pp_parens (@nt >|< "_Syn" >#< "_val") >#< "-> _val"
-                                  )
-                             else @left.pp >#< "=" >#< @rhs.pp
-
-SEM Expr
-  | Let        lhs.pp      = pp_parens (    "let" >#< (vlist @decls.pps)
-                                       >-< "in " >#< @body.pp
-                                       )
-  | Case       lhs.pp      = pp_parens (    "case" >#< pp_parens @expr.pp >#< "of"
-                                       >-< (vlist @alts.pps)
-                                       )
-  | Do         lhs.pp      = pp_parens ( "do" >#< (   vlist @stmts.pps
-                                                  >-< ("return" >#< @body.pp))
-                                       )
-  | Lambda     loc.strictParams = if strictSems @lhs.options
-                                  then @args.pps
-                                  else []
-               loc.addBang = if bangpats @lhs.options
-                             then \p -> pp_parens ("!" >|< p)
-                             else id
-               lhs.pp      = pp_parens (    "\\" >#< (vlist (map @loc.addBang @args.pps)) >#< "->"
-                                       >-< indent 4 (@loc.strictParams `ppMultiSeqV` @body.pp)
-                                       )
-  | TupleExpr  lhs.pp      = ppTuple @lhs.nested @exprs.pps
-  | UnboxedTupleExpr  lhs.pp      = ppUnboxedTuple @lhs.nested @exprs.pps
-  | App        lhs.pp      = pp_parens $ @name >#< hv_sp @args.pps
-  | SimpleExpr lhs.pp      = text @txt
-  | TextExpr   lhs.pp      = vlist (map text @lns)
-  | Trace      lhs.pp      = "trace" >#< (   pp_parens ("\"" >|< text @txt >|< "\"")
-                                         >-< pp_parens @expr.pp
-                                         )
-  | PragmaExpr lhs.pp      = let pragmaDoc = "/*#" >#< @txt >#< "#*/" -- Not used in Clean
-                                 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 pp_parens (pragmaDoc `leftOp` @expr.pp `rightOp` pragmaDoc)
-  | LineExpr   lhs.pp      = @expr.pp >-< "/*# LINE" >#< ppWithLineNr (\n -> pp $ show $ n + 1) >#< show @lhs.outputfile >#< "#*/"
-                                      >-< ""
-  | TypedExpr  lhs.pp      = pp_parens (@expr.pp >#< "::" >#< @tp.pp)
-  | ResultExpr lhs.pp      = if breadthFirst @lhs.options
-                             then "final" >#<
-                                  pp_parens (@nt >|< "_Syn" >#< pp_parens @expr.pp)
-                             else @expr.pp
-  | InvokeExpr lhs.pp      = if breadthFirst @lhs.options
-                             then "invoke" >#< pp_parens @expr.pp >#< pp_parens (
-                                   @nt >|< "_Inh" >#< pp_parens (ppTuple False @args.pps))
-                             else @expr.pp >#< hv_sp @args.pps
-  | ResumeExpr lhs.pp      = if breadthFirst @lhs.options
-                             then pp_parens ("resume" >#< pp_parens @expr.pp
-                                            >-< indent 2 (pp_parens ( "\\" >|<
-                                                  pp_parens ("~" >|< pp_parens (@nt >|< "_Syn" >#< "_inh_arg"))
-                                                    >#< "->"
-                                            >-< indent 2 ( "let" >#< @left.pp >#< "= _inh_arg"
-                                            >-< indent 2 ("in" >#< @rhs.pp)
-                                            ))))
-                             else pp_parens ( "case" >#< pp_parens @expr.pp >#< "of"
-                                            >-< ("{" >#< @left.pp >#< "->")
-                                            >-< indent 4 (@rhs.pp >#< "}")
-                                            )
-  | SemFun     loc.strictParams = if strictSems @lhs.options
-                                  then @args.pps
-                                  else []
-               loc.addBang = if bangpats @lhs.options
-                             then \p -> pp_parens ("!" >|< p)
-                             else id
-               lhs.pp      = if breadthFirst @lhs.options
-                             then "Child" >#< pp_parens ( "\\" >|<
-                                      pp_parens (@nt >|< "_Inh" >#<
-                                        ppTuple False (map @loc.addBang @args.pps)) >#< "->"
-                                  >-< indent 2 (@loc.strictParams `ppMultiSeqV` @body.pp))
-                             else if null @args.pps
-                                  then @body.pp
-                                  else pp_parens (    "\\" >#< (vlist (map @loc.addBang @args.pps)) >#< "->"
-                                                 >-< indent 4 (@loc.strictParams `ppMultiSeqV` @body.pp)
-                                                 )
-
-SEM CaseAlt
-  | CaseAlt    lhs.pps     = ["{" >#< @left.pp >#< "->", @expr.pp >#< "}"]
-
-SEM DataAlt
-  | DataAlt    lhs.pp      = @name >#< hv_sp (map ((@lhs.strictPre >|<) . pp_parens) @args.pps)
-               lhs.ppa     = empty
-  | Record     lhs.pp      = @name >#< hv_sp (map ((@lhs.strictPre >|<) . pp_parens) @args.pps) -- @name >#< pp_block "{" "}" "," @args.pps
-               lhs.ppa     = let f n d = d >#< (pp_block ("(" ++ @name) ")" "" $ map pp (ppat n))
-                                         >#< pp "=" >#< pp "x"
-                                 ppat n = replicate (length @args.ppas - n - 1) (pp " _") ++ [pp " x"] ++ replicate n (pp " _")
-                             in  snd $ foldr (\x (n, xs) -> (n + 1, f n x >-< xs)) (0, empty) @args.ppas
-
-SEM NamedType
-  | Named      lhs.pp      = -- @name >#< "::" >#< 
-                             if @strict
-                               then "!" >|< pp_parens @tp.pp
-                               else @tp.pp
-               lhs.ppa     = pp @name
-
-SEM Lhs
-  | Pattern3 TupleLhs UnboxedTupleLhs
-      loc.addStrictGuard = if strictCases @lhs.options && @loc.hasStrictVars then \v -> v >#< "|" >#< @loc.strictGuard else id
-  | Pattern3
-      loc.strictGuard = @pat3.strictVars `ppMultiSeqH` (pp "True")
-      loc.hasStrictVars = not (null @pat3.strictVars)
-  | TupleLhs UnboxedTupleLhs
-      loc.strictGuard = if stricterCases @lhs.options && not @lhs.isDeclOfLet
-                        then map text @comps `ppMultiSeqH` (pp "True")
-                        else pp "True"
-      loc.hasStrictVars = not (null @comps)
-
-  | Fun
-      loc.addStrictGuard = if strictSems @lhs.options && @loc.hasStrictVars then \v -> v >#< "|" >#< @loc.strictGuard else id
-      loc.hasStrictVars  = not (null @args.pps)
-      loc.strictGuard    = @args.pps `ppMultiSeqH` (pp "True")
-
-  | TupleLhs UnboxedTupleLhs Fun
-      loc.addBang = if bangpats @lhs.options
-                             then \p -> "!" >|< p
-                             else id
-
-  | Pattern3   lhs.pp      = @loc.addStrictGuard @pat3.pp
-  | Pattern3SM lhs.pp      = @pat3.pp'
-  | TupleLhs   lhs.pp      = @loc.addStrictGuard $ ppTuple @lhs.nested (map (@loc.addBang . text) @comps)
-  | UnboxedTupleLhs   lhs.pp      = @loc.addStrictGuard $ ppUnboxedTuple @lhs.nested (map (@loc.addBang . text) @comps)
-  | Fun        lhs.pp      = @loc.addStrictGuard (@name >#< hv_sp (map @loc.addBang @args.pps))
-  | Unwrap     lhs.pp      = pp_parens (@name >#< @sub.pp)
-
-SEM Type  [ | | prec:Int ]
-  | Arr        lhs.prec    = 2
-                  .pp      = case @right.copy of
-                               Arr{} -> @loc.l >-< @loc.r
-                               _     -> @loc.l >#< "->" >-< @loc.r
-               loc.l       = if @left.prec  <= 2 then pp_parens @left.pp  else @left.pp
-                  .r       = if @right.prec <  2 then pp_parens @right.pp else @right.pp
-
-  | TypeApp
-      lhs.pp = pp "(" >#< hv_sp (@func.pp : @args.pps) >#< pp ")"-- TODO: Check
-
-  | CtxApp
-      lhs.pp = @right.pp >#< " | " >#< (pp_block "" "" "&" $ map (\(n,ns) -> hv_sp $ map pp (n:ns)) @left)
-  | QuantApp
-      lhs.pp = @left >#< @right.pp
-
-  | TupleType  lhs.prec    = 5
-                  .pp      = ppTuple @lhs.nested @tps.pps
-
-  | UnboxedTupleType  lhs.prec    = 5
-                         .pp      = ppUnboxedTuple @lhs.nested @tps.pps
-
-  | List       lhs.prec    = 5
-                  .pp      = "[" >|< @tp.pp >|< "]"
-
-  | SimpleType lhs.prec    = 5
-                  .pp      = if reallySimple @txt then text @txt else pp_parens (text @txt)
-
-  | NontermType  lhs.prec  = 5
-                 lhs.pp    = @loc.prefix >|< text @name >#< hv_sp @params
-                 loc.prefix = if @deforested
-                              then text "T_"
-                              else empty
-  | TMaybe       lhs.prec  = 5
-                 lhs.pp    = text "Maybe" >#< pp_parens @tp.pp
-  | TEither      lhs.prec  = 5
-                 lhs.pp    = text "Either" >#< pp_parens @left.pp >#< pp_parens @right.pp
-  | TMap         lhs.prec  = 5
-                 lhs.pp    = text "'Data.Map'.Map" >#< pp_parens @key.pp >#< pp_parens @value.pp
-  | TIntMap      lhs.prec  = 5
-                 lhs.pp    = text "'Data.IntMap'.IntMap" >#< pp_parens @value.pp
-  | TSet         lhs.prec  = 5
-                 lhs.pp    = text "'Data.Set'.Set" >#< pp_parens @tp.pp
-  | TIntSet      lhs.prec  = 5
-                 lhs.pp    = text "'Data.IntSet'.IntSet"
-
-
-{
-
-reallySimple :: String -> Bool
-reallySimple = and . map (\x -> isAlphaNum x || x=='_')
-
-ppTuple :: Bool -> [PP_Doc] -> PP_Doc
-ppTuple _     [x] = pp x
-ppTuple True  pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps
-ppTuple False pps = "(" >|< pp_block " " ")" "," pps
-ppUnboxedTuple :: Bool -> [PP_Doc] -> PP_Doc
-ppUnboxedTuple = ppTuple
---ppUnboxedTuple True pps  = "(# " >|< pp_block " " (concat $ replicate (length pps `max` 1) " #)") ",(# " pps
---ppUnboxedTuple False pps = "(# " >|< pp_block " " " #)" "," pps
-
-}
-
-
--------------------------------------------------------------------------------
---         Strict data fields
--------------------------------------------------------------------------------
-
-ATTR DataAlt DataAlts [ strictPre: PP_Doc | | ]
-
-SEM Decl
-  | Data alts.strictPre = if @strict then pp "!" else empty
-
--------------------------------------------------------------------------------
---         Strict variables
--------------------------------------------------------------------------------
-
-ATTR Pattern Patterns [ | | strictVars USE {++} {[]} : {[PP_Doc]} ]
-SEM Pattern
-  | Alias
-      loc.strictVar
-        = if strictCases @lhs.options && not @lhs.isDeclOfLet
-          then [@loc.ppVar]
-          else []
-      loc.strictPatVars
-        = if stricterCases @lhs.options && not @lhs.isDeclOfLet
-          then @pat.strictVars
-          else []
-      lhs.strictVars
-        = @loc.strictVar ++ @loc.strictPatVars
-  | Irrefutable
-      lhs.strictVars = []
-
--------------------------------------------------------------------------------
---         Pretty printing patterns
--------------------------------------------------------------------------------
-
-SEM Patterns [ | | pps : {[PP_Doc]} ]
-  | Cons lhs.pps = @hd.pp : @tl.pps
-  | Nil  lhs.pps = []
-
-SEM Pattern
-  | Constr Product Alias
-      loc.addBang = if bangpats @lhs.options && not @lhs.isDeclOfLet && not @lhs.belowIrrefutable
-                    then \p -> "!" >|< p
-                    else id
-
-SEM Pattern [ | | pp:PP_Doc ]
-  | Constr  lhs.pp     = @loc.addBang $ pp_parens $ @name >#< hv_sp @pats.pps
-  | Product lhs.pp     = @loc.addBang $ pp_block "(" ")" "," @pats.pps
-  | Alias   loc.ppVar  = pp (attrname @lhs.options False @field @attr)
-            loc.ppVarBang = @loc.addBang $ @loc.ppVar
-            lhs.pp     = if @pat.isUnderscore
-                          then @loc.ppVarBang
-                          else @loc.ppVarBang >|< "@" >|< @pat.pp
-  | Irrefutable lhs.pp = text "~" >|< pp_parens @pat.pp
-  | Underscore lhs.pp  = text "_"
-
-SEM Pattern [ | | isUnderscore:{Bool}]
- | Constr      lhs.isUnderscore = False
- | Product     lhs.isUnderscore = False
- | Alias       lhs.isUnderscore = False
- | Underscore  lhs.isUnderscore = True
-
-ATTR Pattern Patterns [ belowIrrefutable : Bool | | ]
-SEM Pattern
-  | Irrefutable
-      pat.belowIrrefutable = True
-
-SEM Lhs
-  | Pattern3 Pattern3SM
-      pat3.belowIrrefutable = False
-
--------------------------------------------------------------------------------
---         Pretty printing patterns for SM
--------------------------------------------------------------------------------
-
-SEM Patterns [ | | pps' : {[PP_Doc]} ]
-  | Cons lhs.pps' = @hd.pp' : @tl.pps'
-  | Nil  lhs.pps' = []
-
-SEM Pattern [ | | pp':PP_Doc ]
-  | Constr  lhs.pp'     = pp_parens $ @name >#< hv_sp (map pp_parens @pats.pps')
-  | Product lhs.pp'     = pp_block "(" ")" "," @pats.pps'
-  | Alias   lhs.pp'     = let attribute | @field == _LOC || @field == nullIdent = locname' @attr
-                                        | otherwise                             = attrname @lhs.options False @field @attr
-                          in attribute >|< "@" >|< @pat.pp'
-  | Irrefutable lhs.pp' = text "~" >|< pp_parens @pat.pp
-  | Underscore lhs.pp'  = text "_"
-
-{
-locname' :: Identifier -> [Char]
-locname' n = "_loc_" ++ getName n
-}
-
--------------------------------------------------------------------------------
---         Determine if inside a Let
--------------------------------------------------------------------------------
-
-ATTR Chunks Chunk Decls Decl Lhs Pattern Patterns [ isDeclOfLet : Bool | | ]
-SEM Program
-  | Program
-      chunks.isDeclOfLet = False
-
-SEM Expr
-  | Let
-      decls.isDeclOfLet = True
-  | Do
-      stmts.isDeclOfLet = False
-  | ResumeExpr
-      left.isDeclOfLet = False
-
-SEM CaseAlt
-  | CaseAlt
-      left.isDeclOfLet = False
-
-
-
--------------------------------------------------------------------------------
---         Alternative code printing to separate modules
--------------------------------------------------------------------------------
-
-ATTR Program [ mainBlocksDoc : PP_Doc | | genIO : {IO ()} ]
-ATTR Program Chunks Chunk
-  [ importBlocks : PP_Doc
-    pragmaBlocks : String
-    textBlocks : PP_Doc
-    textBlockMap : {Map BlockInfo PP_Doc}
-    optionsLine : String
-    mainFile : String
-    mainName : String
-    moduleHeader : {String -> String -> String -> Bool -> String}
-     | | ]
-
-SEM Program
-  | Program
-      loc.mainModuleFile = @lhs.mainFile
-      loc.genMainModule
-        = writeModule @loc.mainModuleFile
-            ( [ pp $ @lhs.pragmaBlocks
-              , pp $ @lhs.optionsLine
-              , pp $ @lhs.moduleHeader @lhs.mainName "" "" False
-              , pp $ ("import " ++ @lhs.mainName ++ "_common\n")
-              ]
-              ++ map pp @chunks.imports
-              ++ map vlist @chunks.appendMain
-              ++ [@lhs.mainBlocksDoc]
-            )
-
-      loc.commonFile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_common")
-      loc.genCommonModule
-        = writeModule @loc.commonFile
-              ( [ pp $ @lhs.pragmaBlocks
-                , pp $ @lhs.optionsLine
-                , pp $ @lhs.moduleHeader @lhs.mainName "_common" "" True
-                , @lhs.importBlocks
-                , @lhs.textBlocks
-                ]
-                ++ map vlist @chunks.appendCommon
-              )
-
-      lhs.genIO = do @loc.genMainModule
-                     @loc.genCommonModule
-                     @chunks.genSems
-
-{
-renderDocs :: [PP_Doc] -> String
-renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) ""
-}
-
-ATTR Chunk Chunks [ | | imports USE {++} {[]} : {[String]} ]
-SEM Chunk
-  | Chunk
-      lhs.imports = ["import " ++ @lhs.mainName ++ "_" ++ @name ++ "\n"]
-
-ATTR Chunk Chunks [ | | appendCommon, appendMain USE {++} {[]} : {[[PP_Doc]]} ]
-
-SEM Chunk
-  | Chunk
-      lhs.appendCommon
-        = [ [@comment.pp]
-          , @dataDef.pps
-          , @semDom.pps
-          , if reference @lhs.options then @semWrapper.pps else []
-          ]
-      lhs.appendMain
-        = [ [@comment.pp]
-          , @cataFun.pps
-          , if reference @lhs.options then [] else @semWrapper.pps
-          ]
-
-ATTR Chunk Chunks [ | | genSems USE {>>} {return ()} : {IO ()} ]
-
-SEM Chunk
-  | Chunk
-      lhs.genSems
-        = writeModule @loc.outputfile
-            [ pp $ @lhs.pragmaBlocks
-            , pp $ Map.findWithDefault empty (BlockPragma, Just $ identifier @name) @lhs.textBlockMap
-            , pp $ @lhs.optionsLine
-            , pp $ @lhs.moduleHeader @lhs.mainName ("_" ++ @name) @loc.exports True
-            , pp $ ("import " ++ @lhs.mainName ++ "_common\n")
-            , pp $ Map.findWithDefault empty (BlockImport, Just $ identifier @name) @lhs.textBlockMap
-            , @comment.pp
-            , vlist_sep "" @info.pps
-            , vlist_sep "" @semFunctions.pps
-            , Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap
-            ]
-
-SEM Chunk
-  | Chunk
-      loc.exports = concat $ intersperse "," @semNames
-
-{
-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
-}
-
+PRAGMA strictdata+PRAGMA optimize+PRAGMA bangpats+PRAGMA strictwrap++INCLUDE "Code.ag"+INCLUDE "Patterns.ag"++imports+{+import Data.Char (isAlphaNum)+import Pretty+import Code+import Options+import CommonTypes (attrname, _LOC, nullIdent)+import Data.List(intersperse)+import System.IO+import System.Directory+import System.FilePath+import CommonTypes(BlockInfo, BlockKind(..))+}++{+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+}++ATTR Expr Exprs Decl Decls CaseAlt CaseAlts Lhs [ outputfile : {String} | | ]++SEM Chunk+  | Chunk+      loc.outputfile = if sepSemMods @lhs.options+                       then replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_" ++ @name)+                       else @lhs.mainFile++ATTR Program                            [ options:{Options} | | output:{PP_Docs} ]++ATTR Expr Exprs Decl Decls Chunk Chunks CaseAlts CaseAlt Lhs Pattern Patterns [ options:{Options} | | ]++ATTR Expr Decl DataAlt Type NamedType Lhs [ nested:{Bool} | | pp:{PP_Doc} ]+ATTR Decl DataAlt NamedType [ | | ppa USE {>-<} {empty} : {PP_Doc}]++ATTR Exprs DataAlts Types NamedTypes Decls Chunk Chunks [ nested:{Bool} | | pps : {PP_Docs} ]+ATTR DataAlts NamedTypes [ | | ppas : {PP_Docs} ]++ATTR CaseAlt CaseAlts                   [ nested:{Bool} | | pps: {PP_Docs} ]++ATTR Type Types [ | | copy : SELF]++SEM Program | Program+  loc.options = @lhs.options { breadthFirst = breadthFirst @lhs.options && visit @lhs.options && cases @lhs.options && @ordered }++SEM Program+  | Program chunks.nested = nest @lhs.options++SEM Exprs+  | Cons lhs.pps = @hd.pp : @tl.pps+  | Nil  lhs.pps = []++SEM CaseAlts+  | Cons lhs.pps = @hd.pps ++ @tl.pps+  | Nil  lhs.pps = []++SEM DataAlts+  | Cons lhs.pps  = @hd.pp : @tl.pps+         lhs.ppas = @hd.ppa : @tl.ppas+  | Nil  lhs.pps  = []+         lhs.ppas = []++SEM Types+  | Cons lhs.pps = @hd.pp : @tl.pps+  | Nil  lhs.pps = []++SEM NamedTypes+  | Cons lhs.pps  = @hd.pp : @tl.pps+         lhs.ppas = @hd.ppa : @tl.ppas+  | Nil  lhs.pps  = []+         lhs.ppas = []++SEM Decls+  | Cons lhs.pps = @hd.pp : @tl.pps+  | Nil  lhs.pps = []++SEM Chunks+  | Cons lhs.pps = @hd.pps ++ @tl.pps+  | Nil  lhs.pps = []+++SEM Program+  | Program    lhs.output  = @chunks.pps++SEM Chunk+  | Chunk      lhs.pps     =  @comment.pp+                              :  @info.pps+                              ++ @dataDef.pps+                              ++ @cataFun.pps+                              ++ @semDom.pps+                              ++ @semWrapper.pps+                              ++ @semFunctions.pps+                              ++ [Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap]++SEM Decl+  | Decl       lhs.pp      = @left.pp >#< "="+                             >-< indent 4 @rhs.pp+  | Bind       lhs.pp      = @left.pp >#< "<-" >#< @rhs.pp+  | BindLet    lhs.pp      = "let" >#< @left.pp >#< "=" >#< @rhs.pp+  | Data       lhs.pp      = "::" >#< hv_sp (@name : @params)+                             >#<  ( case @alts.pps of+                                          [] -> empty+                                          (x:xs) ->              "=" >#<  x+                                                 >-< vlist (map ("|" >#<) xs)+                                     >-< if null @derivings+                                            then empty+                                            else "deriving" >#< ppTuple False (map text @derivings)+                                  )+                             >-< foldr (>-<) empty @alts.ppas++  | NewType    lhs.pp      = "::" >#< hv_sp (@name : @params) >#< "=" >#< @con >#< pp_parens @tp.pp+  | Type       lhs.pp      = "::" >#< hv_sp (@name : @params) >#< ":==" >#<  @tp.pp+  | TSig       lhs.pp      = @name >#< "::" >#< @tp.pp+  | Comment    lhs.pp      = if '\n' `elem` @txt+                               then "/*" >-< vlist (lines @txt) >-< "*/"+                               else "//" >#< @txt+  | PragmaDecl lhs.pp      = "/*#" >#< text @txt >#< "#*/" -- Not used in Clean+  | Resume     lhs.pp      = if @monadic+                             then @left.pp >#< "<-" >#< @rhs.pp+                             else @left.pp >#< "=" >-< indent 4 @rhs.pp+  | EvalDecl   loc.strat   = if breadthFirstStrict @lhs.options+                             then "stepwiseEval"+                             else "lazyEval"+               lhs.pp      = if breadthFirst @lhs.options+                             then @left.pp >#< "=" >#< "case" >#< @loc.strat >#< pp_parens @rhs.pp >#< "of"+                                  >-< indent 4 (+                                    pp_parens (@nt >|< "_Syn" >#< "_val") >#< "-> _val"+                                  )+                             else @left.pp >#< "=" >#< @rhs.pp++SEM Expr+  | Let        lhs.pp      = pp_parens (    "let" >#< (vlist @decls.pps)+                                       >-< "in " >#< @body.pp+                                       )+  | Case       lhs.pp      = pp_parens (    "case" >#< pp_parens @expr.pp >#< "of"+                                       >-< (vlist @alts.pps)+                                       )+  | Do         lhs.pp      = pp_parens ( "do" >#< (   vlist @stmts.pps+                                                  >-< ("return" >#< @body.pp))+                                       )+  | Lambda     loc.strictParams = if strictSems @lhs.options+                                  then @args.pps+                                  else []+               loc.addBang = if bangpats @lhs.options+                             then \p -> pp_parens ("!" >|< p)+                             else id+               lhs.pp      = pp_parens (    "\\" >#< (vlist (map @loc.addBang @args.pps)) >#< "->"+                                       >-< indent 4 (@loc.strictParams `ppMultiSeqV` @body.pp)+                                       )+  | TupleExpr  lhs.pp      = ppTuple @lhs.nested @exprs.pps+  | UnboxedTupleExpr  lhs.pp      = ppUnboxedTuple @lhs.nested @exprs.pps+  | App        lhs.pp      = pp_parens $ @name >#< hv_sp @args.pps+  | SimpleExpr lhs.pp      = text @txt+  | TextExpr   lhs.pp      = vlist (map text @lns)+  | Trace      lhs.pp      = "trace" >#< (   pp_parens ("\"" >|< text @txt >|< "\"")+                                         >-< pp_parens @expr.pp+                                         )+  | PragmaExpr lhs.pp      = let pragmaDoc = "/*#" >#< @txt >#< "#*/" -- Not used in Clean+                                 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 pp_parens (pragmaDoc `leftOp` @expr.pp `rightOp` pragmaDoc)+  | LineExpr   lhs.pp      = @expr.pp >-< "/*# LINE" >#< ppWithLineNr (\n -> pp $ show $ n + 1) >#< show @lhs.outputfile >#< "#*/"+                                      >-< ""+  | TypedExpr  lhs.pp      = pp_parens (@expr.pp >#< "::" >#< @tp.pp)+  | ResultExpr lhs.pp      = if breadthFirst @lhs.options+                             then "final" >#<+                                  pp_parens (@nt >|< "_Syn" >#< pp_parens @expr.pp)+                             else @expr.pp+  | InvokeExpr lhs.pp      = if breadthFirst @lhs.options+                             then "invoke" >#< pp_parens @expr.pp >#< pp_parens (+                                   @nt >|< "_Inh" >#< pp_parens (ppTuple False @args.pps))+                             else @expr.pp >#< hv_sp @args.pps+  | ResumeExpr lhs.pp      = if breadthFirst @lhs.options+                             then pp_parens ("resume" >#< pp_parens @expr.pp+                                            >-< indent 2 (pp_parens ( "\\" >|<+                                                  pp_parens ("~" >|< pp_parens (@nt >|< "_Syn" >#< "_inh_arg"))+                                                    >#< "->"+                                            >-< indent 2 ( "let" >#< @left.pp >#< "= _inh_arg"+                                            >-< indent 2 ("in" >#< @rhs.pp)+                                            ))))+                             else pp_parens ( "case" >#< pp_parens @expr.pp >#< "of"+                                            >-< ("{" >#< @left.pp >#< "->")+                                            >-< indent 4 (@rhs.pp >#< "}")+                                            )+  | SemFun     loc.strictParams = if strictSems @lhs.options+                                  then @args.pps+                                  else []+               loc.addBang = if bangpats @lhs.options+                             then \p -> pp_parens ("!" >|< p)+                             else id+               lhs.pp      = if breadthFirst @lhs.options+                             then "Child" >#< pp_parens ( "\\" >|<+                                      pp_parens (@nt >|< "_Inh" >#<+                                        ppTuple False (map @loc.addBang @args.pps)) >#< "->"+                                  >-< indent 2 (@loc.strictParams `ppMultiSeqV` @body.pp))+                             else if null @args.pps+                                  then @body.pp+                                  else pp_parens (    "\\" >#< (vlist (map @loc.addBang @args.pps)) >#< "->"+                                                 >-< indent 4 (@loc.strictParams `ppMultiSeqV` @body.pp)+                                                 )++SEM CaseAlt+  | CaseAlt    lhs.pps     = ["{" >#< @left.pp >#< "->", @expr.pp >#< "}"]++SEM DataAlt+  | DataAlt    lhs.pp      = @name >#< hv_sp (map ((@lhs.strictPre >|<) . pp_parens) @args.pps)+               lhs.ppa     = empty+  | Record     lhs.pp      = @name >#< hv_sp (map ((@lhs.strictPre >|<) . pp_parens) @args.pps) -- @name >#< pp_block "{" "}" "," @args.pps+               lhs.ppa     = let f n d = d >#< (pp_block ("(" ++ @name) ")" "" $ map pp (ppat n))+                                         >#< pp "=" >#< pp "x"+                                 ppat n = replicate (length @args.ppas - n - 1) (pp " _") ++ [pp " x"] ++ replicate n (pp " _")+                             in  snd $ foldr (\x (n, xs) -> (n + 1, f n x >-< xs)) (0, empty) @args.ppas++SEM NamedType+  | Named      lhs.pp      = -- @name >#< "::" >#< +                             if @strict+                               then "!" >|< pp_parens @tp.pp+                               else @tp.pp+               lhs.ppa     = pp @name++SEM Lhs+  | Pattern3 TupleLhs UnboxedTupleLhs+      loc.addStrictGuard = if strictCases @lhs.options && @loc.hasStrictVars then \v -> v >#< "|" >#< @loc.strictGuard else id+  | Pattern3+      loc.strictGuard = @pat3.strictVars `ppMultiSeqH` (pp "True")+      loc.hasStrictVars = not (null @pat3.strictVars)+  | TupleLhs UnboxedTupleLhs+      loc.strictGuard = if stricterCases @lhs.options && not @lhs.isDeclOfLet+                        then map text @comps `ppMultiSeqH` (pp "True")+                        else pp "True"+      loc.hasStrictVars = not (null @comps)++  | Fun+      loc.addStrictGuard = if strictSems @lhs.options && @loc.hasStrictVars then \v -> v >#< "|" >#< @loc.strictGuard else id+      loc.hasStrictVars  = not (null @args.pps)+      loc.strictGuard    = @args.pps `ppMultiSeqH` (pp "True")++  | TupleLhs UnboxedTupleLhs Fun+      loc.addBang = if bangpats @lhs.options+                             then \p -> "!" >|< p+                             else id++  | Pattern3   lhs.pp      = @loc.addStrictGuard @pat3.pp+  | Pattern3SM lhs.pp      = @pat3.pp'+  | TupleLhs   lhs.pp      = @loc.addStrictGuard $ ppTuple @lhs.nested (map (@loc.addBang . text) @comps)+  | UnboxedTupleLhs   lhs.pp      = @loc.addStrictGuard $ ppUnboxedTuple @lhs.nested (map (@loc.addBang . text) @comps)+  | Fun        lhs.pp      = @loc.addStrictGuard (@name >#< hv_sp (map @loc.addBang @args.pps))+  | Unwrap     lhs.pp      = pp_parens (@name >#< @sub.pp)++SEM Type  [ | | prec:Int ]+  | Arr        lhs.prec    = 2+                  .pp      = case @right.copy of+                               Arr{} -> @loc.l >-< @loc.r+                               _     -> @loc.l >#< "->" >-< @loc.r+               loc.l       = if @left.prec  <= 2 then pp_parens @left.pp  else @left.pp+                  .r       = if @right.prec <  2 then pp_parens @right.pp else @right.pp++  | TypeApp+      lhs.pp = pp "(" >#< hv_sp (@func.pp : @args.pps) >#< pp ")"-- TODO: Check++  | CtxApp+      lhs.pp = @right.pp >#< " | " >#< (pp_block "" "" "&" $ map (\(n,ns) -> hv_sp $ map pp (n:ns)) @left)+  | QuantApp+      lhs.pp = @left >#< @right.pp++  | TupleType  lhs.prec    = 5+                  .pp      = ppTuple @lhs.nested @tps.pps++  | UnboxedTupleType  lhs.prec    = 5+                         .pp      = ppUnboxedTuple @lhs.nested @tps.pps++  | List       lhs.prec    = 5+                  .pp      = "[" >|< @tp.pp >|< "]"++  | SimpleType lhs.prec    = 5+                  .pp      = if reallySimple @txt then text @txt else pp_parens (text @txt)++  | NontermType  lhs.prec  = 5+                 lhs.pp    = @loc.prefix >|< text @name >#< hv_sp @params+                 loc.prefix = if @deforested+                              then text "T_"+                              else empty+  | TMaybe       lhs.prec  = 5+                 lhs.pp    = text "Maybe" >#< pp_parens @tp.pp+  | TEither      lhs.prec  = 5+                 lhs.pp    = text "Either" >#< pp_parens @left.pp >#< pp_parens @right.pp+  | TMap         lhs.prec  = 5+                 lhs.pp    = text "'Data.Map'.Map" >#< pp_parens @key.pp >#< pp_parens @value.pp+  | TIntMap      lhs.prec  = 5+                 lhs.pp    = text "'Data.IntMap'.IntMap" >#< pp_parens @value.pp+  | TSet         lhs.prec  = 5+                 lhs.pp    = text "'Data.Set'.Set" >#< pp_parens @tp.pp+  | TIntSet      lhs.prec  = 5+                 lhs.pp    = text "'Data.IntSet'.IntSet"+++{++reallySimple :: String -> Bool+reallySimple = and . map (\x -> isAlphaNum x || x=='_')++ppTuple :: Bool -> [PP_Doc] -> PP_Doc+ppTuple _     [x] = pp x+ppTuple True  pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps+ppTuple False pps = "(" >|< pp_block " " ")" "," pps+ppUnboxedTuple :: Bool -> [PP_Doc] -> PP_Doc+ppUnboxedTuple = ppTuple+--ppUnboxedTuple True pps  = "(# " >|< pp_block " " (concat $ replicate (length pps `max` 1) " #)") ",(# " pps+--ppUnboxedTuple False pps = "(# " >|< pp_block " " " #)" "," pps++}+++-------------------------------------------------------------------------------+--         Strict data fields+-------------------------------------------------------------------------------++ATTR DataAlt DataAlts [ strictPre: PP_Doc | | ]++SEM Decl+  | Data alts.strictPre = if @strict then pp "!" else empty++-------------------------------------------------------------------------------+--         Strict variables+-------------------------------------------------------------------------------++ATTR Pattern Patterns [ | | strictVars USE {++} {[]} : {[PP_Doc]} ]+SEM Pattern+  | Alias+      loc.strictVar+        = if strictCases @lhs.options && not @lhs.isDeclOfLet+          then [@loc.ppVar]+          else []+      loc.strictPatVars+        = if stricterCases @lhs.options && not @lhs.isDeclOfLet+          then @pat.strictVars+          else []+      lhs.strictVars+        = @loc.strictVar ++ @loc.strictPatVars+  | Irrefutable+      lhs.strictVars = []++-------------------------------------------------------------------------------+--         Pretty printing patterns+-------------------------------------------------------------------------------++SEM Patterns [ | | pps : {[PP_Doc]} ]+  | Cons lhs.pps = @hd.pp : @tl.pps+  | Nil  lhs.pps = []++SEM Pattern+  | Constr Product Alias+      loc.addBang = if bangpats @lhs.options && not @lhs.isDeclOfLet && not @lhs.belowIrrefutable+                    then \p -> "!" >|< p+                    else id++SEM Pattern [ | | pp:PP_Doc ]+  | Constr  lhs.pp     = @loc.addBang $ pp_parens $ @name >#< hv_sp @pats.pps+  | Product lhs.pp     = @loc.addBang $ pp_block "(" ")" "," @pats.pps+  | Alias   loc.ppVar  = pp (attrname @lhs.options False @field @attr)+            loc.ppVarBang = @loc.addBang $ @loc.ppVar+            lhs.pp     = if @pat.isUnderscore+                          then @loc.ppVarBang+                          else @loc.ppVarBang >|< "@" >|< @pat.pp+  | Irrefutable lhs.pp = text "~" >|< pp_parens @pat.pp+  | Underscore lhs.pp  = text "_"++SEM Pattern [ | | isUnderscore:{Bool}]+ | Constr      lhs.isUnderscore = False+ | Product     lhs.isUnderscore = False+ | Alias       lhs.isUnderscore = False+ | Underscore  lhs.isUnderscore = True++ATTR Pattern Patterns [ belowIrrefutable : Bool | | ]+SEM Pattern+  | Irrefutable+      pat.belowIrrefutable = True++SEM Lhs+  | Pattern3 Pattern3SM+      pat3.belowIrrefutable = False++-------------------------------------------------------------------------------+--         Pretty printing patterns for SM+-------------------------------------------------------------------------------++SEM Patterns [ | | pps' : {[PP_Doc]} ]+  | Cons lhs.pps' = @hd.pp' : @tl.pps'+  | Nil  lhs.pps' = []++SEM Pattern [ | | pp':PP_Doc ]+  | Constr  lhs.pp'     = pp_parens $ @name >#< hv_sp (map pp_parens @pats.pps')+  | Product lhs.pp'     = pp_block "(" ")" "," @pats.pps'+  | Alias   lhs.pp'     = let attribute | @field == _LOC || @field == nullIdent = locname' @attr+                                        | otherwise                             = attrname @lhs.options False @field @attr+                          in attribute >|< "@" >|< @pat.pp'+  | Irrefutable lhs.pp' = text "~" >|< pp_parens @pat.pp+  | Underscore lhs.pp'  = text "_"++{+locname' :: Identifier -> [Char]+locname' n = "_loc_" ++ getName n+}++-------------------------------------------------------------------------------+--         Determine if inside a Let+-------------------------------------------------------------------------------++ATTR Chunks Chunk Decls Decl Lhs Pattern Patterns [ isDeclOfLet : Bool | | ]+SEM Program+  | Program+      chunks.isDeclOfLet = False++SEM Expr+  | Let+      decls.isDeclOfLet = True+  | Do+      stmts.isDeclOfLet = False+  | ResumeExpr+      left.isDeclOfLet = False++SEM CaseAlt+  | CaseAlt+      left.isDeclOfLet = False++++-------------------------------------------------------------------------------+--         Alternative code printing to separate modules+-------------------------------------------------------------------------------++ATTR Program [ mainBlocksDoc : PP_Doc | | genIO : {IO ()} ]+ATTR Program Chunks Chunk+  [ importBlocks : PP_Doc+    pragmaBlocks : String+    textBlocks : PP_Doc+    textBlockMap : {Map BlockInfo PP_Doc}+    optionsLine : String+    mainFile : String+    mainName : String+    moduleHeader : {String -> String -> String -> Bool -> String}+     | | ]++SEM Program+  | Program+      loc.mainModuleFile = @lhs.mainFile+      loc.genMainModule+        = writeModule @loc.mainModuleFile+            ( [ pp $ @lhs.pragmaBlocks+              , pp $ @lhs.optionsLine+              , pp $ @lhs.moduleHeader @lhs.mainName "" "" False+              , pp $ ("import " ++ @lhs.mainName ++ "_common\n")+              ]+              ++ map pp @chunks.imports+              ++ map vlist @chunks.appendMain+              ++ [@lhs.mainBlocksDoc]+            )++      loc.commonFile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_common")+      loc.genCommonModule+        = writeModule @loc.commonFile+              ( [ pp $ @lhs.pragmaBlocks+                , pp $ @lhs.optionsLine+                , pp $ @lhs.moduleHeader @lhs.mainName "_common" "" True+                , @lhs.importBlocks+                , @lhs.textBlocks+                ]+                ++ map vlist @chunks.appendCommon+              )++      lhs.genIO = do @loc.genMainModule+                     @loc.genCommonModule+                     @chunks.genSems++{+renderDocs :: [PP_Doc] -> String+renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) ""+}++ATTR Chunk Chunks [ | | imports USE {++} {[]} : {[String]} ]+SEM Chunk+  | Chunk+      lhs.imports = ["import " ++ @lhs.mainName ++ "_" ++ @name ++ "\n"]++ATTR Chunk Chunks [ | | appendCommon, appendMain USE {++} {[]} : {[[PP_Doc]]} ]++SEM Chunk+  | Chunk+      lhs.appendCommon+        = [ [@comment.pp]+          , @dataDef.pps+          , @semDom.pps+          , if reference @lhs.options then @semWrapper.pps else []+          ]+      lhs.appendMain+        = [ [@comment.pp]+          , @cataFun.pps+          , if reference @lhs.options then [] else @semWrapper.pps+          ]++ATTR Chunk Chunks [ | | genSems USE {>>} {return ()} : {IO ()} ]++SEM Chunk+  | Chunk+      lhs.genSems+        = writeModule @loc.outputfile+            [ pp $ @lhs.pragmaBlocks+            , pp $ Map.findWithDefault empty (BlockPragma, Just $ identifier @name) @lhs.textBlockMap+            , pp $ @lhs.optionsLine+            , pp $ @lhs.moduleHeader @lhs.mainName ("_" ++ @name) @loc.exports True+            , pp $ ("import " ++ @lhs.mainName ++ "_common\n")+            , pp $ Map.findWithDefault empty (BlockImport, Just $ identifier @name) @lhs.textBlockMap+            , @comment.pp+            , vlist_sep "" @info.pps+            , vlist_sep "" @semFunctions.pps+            , Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap+            ]++SEM Chunk+  | Chunk+      loc.exports = concat $ intersperse "," @semNames++{+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+}+
src-ag/PrintCode.ag view
@@ -1,542 +1,542 @@-PRAGMA strictdata
-PRAGMA optimize
-PRAGMA bangpats
-PRAGMA strictwrap
-
-INCLUDE "Code.ag"
-INCLUDE "Patterns.ag"
-
-imports
-{
-import Data.Char (isAlphaNum)
-import Pretty
-import Code
-import Options
-import CommonTypes (attrname, _LOC, nullIdent)
-import Data.List(intersperse)
-import System.IO
-import System.Directory
-import System.FilePath
-import CommonTypes(BlockInfo, BlockKind(..))
-}
-
-{
-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
-}
-
-ATTR Expr Exprs Decl Decls CaseAlt CaseAlts Lhs [ outputfile : {String} | | ]
-
-SEM Chunk
-  | Chunk
-      loc.outputfile = if sepSemMods @lhs.options
-                       then replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_" ++ @name)
-                       else @lhs.mainFile
-
-ATTR Program                            [ options:{Options} | | output:{PP_Docs} ]
-
-ATTR Expr Exprs Decl Decls Chunk Chunks CaseAlts CaseAlt Lhs Pattern Patterns [ options:{Options} | | ]
-
-ATTR Expr Decl DataAlt Type NamedType Lhs [ nested:{Bool} | | pp:{PP_Doc} ]
-
-ATTR Exprs DataAlts Types NamedTypes Decls Chunk Chunks [ nested:{Bool} | | pps : {PP_Docs} ]
-
-ATTR CaseAlt CaseAlts                   [ nested:{Bool} | | pps: {PP_Docs} ]
-
-SEM Program | Program
-  loc.options = @lhs.options { breadthFirst = breadthFirst @lhs.options && visit @lhs.options && cases @lhs.options && @ordered }
-
-SEM Program
-  | Program chunks.nested = nest @lhs.options
-
-SEM Exprs
-  | Cons lhs.pps = @hd.pp : @tl.pps
-  | Nil  lhs.pps = []
-
-SEM CaseAlts
-  | Cons lhs.pps = @hd.pps ++ @tl.pps
-  | Nil  lhs.pps = []
-
-SEM DataAlts
-  | Cons lhs.pps = @hd.pp : @tl.pps
-  | Nil  lhs.pps = []
-
-SEM Types
-  | Cons lhs.pps = @hd.pp : @tl.pps
-  | Nil  lhs.pps = []
-
-SEM NamedTypes
-  | Cons lhs.pps = @hd.pp : @tl.pps
-  | Nil  lhs.pps = []
-
-SEM Decls
-  | Cons lhs.pps = @hd.pp : @tl.pps
-  | Nil  lhs.pps = []
-
-SEM Chunks
-  | Cons lhs.pps = @hd.pps ++ @tl.pps
-  | Nil  lhs.pps = []
-
-
-SEM Program
-  | Program    lhs.output  = @chunks.pps
-
-SEM Chunk
-  | Chunk      lhs.pps     =  @comment.pp
-                              :  @info.pps
-                              ++ @dataDef.pps
-                              ++ @cataFun.pps
-                              ++ @semDom.pps
-                              ++ @semWrapper.pps
-                              ++ @semFunctions.pps
-                              ++ [Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap]
-
-SEM Decl
-  | Decl       lhs.pp      = @left.pp >#< "="
-                             >-< indent 4 @rhs.pp
-  | Bind       lhs.pp      = @left.pp >#< "<-" >#< @rhs.pp
-  | BindLet    lhs.pp      = "let" >#< @left.pp >#< "=" >#< @rhs.pp
-  | Data       lhs.pp      = "data" >#< hv_sp (@name : @params)
-                             >#<  ( case @alts.pps of
-                                          [] -> empty
-                                          (x:xs) ->              "=" >#<  x
-                                                 >-< vlist (map ("|" >#<) xs)
-                                     >-< if null @derivings
-                                            then empty
-                                            else "deriving" >#< ppTuple False (map text @derivings)
-                                  )
-  | NewType    lhs.pp      = "newtype" >#< hv_sp (@name : @params) >#< "=" >#< @con >#< pp_parens @tp.pp
-  | Type       lhs.pp      = "type" >#< hv_sp (@name : @params) >#< "=" >#<  @tp.pp
-  | TSig       lhs.pp      = @name >#< "::" >#< @tp.pp
-  | Comment    lhs.pp      = if '\n' `elem` @txt
-                               then "{-" >-< vlist (lines @txt) >-< "-}"
-                               else "--" >#< @txt
-  | PragmaDecl lhs.pp      = "{-#" >#< text @txt >#< "#-}"
-  | Resume     lhs.pp      = if @monadic
-                             then @left.pp >#< "<-" >#< @rhs.pp
-                             else @left.pp >#< "=" >-< indent 4 @rhs.pp
-  | EvalDecl   loc.strat   = if breadthFirstStrict @lhs.options
-                             then "stepwiseEval"
-                             else "lazyEval"
-               lhs.pp      = if breadthFirst @lhs.options
-                             then @left.pp >#< "=" >#< "case" >#< @loc.strat >#< pp_parens @rhs.pp >#< "of"
-                                  >-< indent 4 (
-                                    pp_parens (@nt >|< "_Syn" >#< "_val") >#< "-> _val"
-                                  )
-                             else @left.pp >#< "=" >#< @rhs.pp
-
-SEM Expr
-  | Let        lhs.pp      = pp_parens (    "let" >#< (vlist @decls.pps)
-                                       >-< "in " >#< @body.pp
-                                       )
-  | Case       lhs.pp      = pp_parens (    "case" >#< pp_parens @expr.pp >#< "of"
-                                       >-< (vlist @alts.pps)
-                                       )
-  | Do         lhs.pp      = pp_parens ( "do" >#< (   vlist @stmts.pps
-                                                  >-< ("return" >#< @body.pp))
-                                       )
-  | Lambda     loc.strictParams = if strictSems @lhs.options
-                                  then @args.pps
-                                  else []
-               loc.addBang = if bangpats @lhs.options
-                             then \p -> pp_parens ("!" >|< p)
-                             else id
-               lhs.pp      = pp_parens (    "\\" >#< (vlist (map @loc.addBang @args.pps)) >#< "->"
-                                       >-< indent 4 (@loc.strictParams `ppMultiSeqV` @body.pp)
-                                       )
-  | TupleExpr  lhs.pp      = ppTuple @lhs.nested @exprs.pps
-  | UnboxedTupleExpr  lhs.pp      = ppUnboxedTuple @lhs.nested @exprs.pps
-  | App        lhs.pp      = pp_parens $ @name >#< hv_sp @args.pps
-  | SimpleExpr lhs.pp      = text @txt
-  | TextExpr   lhs.pp      = vlist (map text @lns)
-  | Trace      lhs.pp      = "trace" >#< (   pp_parens ("\"" >|< text @txt >|< "\"")
-                                         >-< pp_parens @expr.pp
-                                         )
-  | PragmaExpr lhs.pp      = 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 pp_parens (pragmaDoc `leftOp` @expr.pp `rightOp` pragmaDoc)
-  | LineExpr   lhs.pp      = @expr.pp >-< "{-# LINE" >#< ppWithLineNr (\n -> pp $ show $ n + 1) >#< show @lhs.outputfile >#< "#-}"
-                                      >-< ""
-  | TypedExpr  lhs.pp      = pp_parens (@expr.pp >#< "::" >#< @tp.pp)
-  | ResultExpr lhs.pp      = if breadthFirst @lhs.options
-                             then "final" >#<
-                                  pp_parens (@nt >|< "_Syn" >#< pp_parens @expr.pp)
-                             else @expr.pp
-  | InvokeExpr lhs.pp      = if breadthFirst @lhs.options
-                             then "invoke" >#< pp_parens @expr.pp >#< pp_parens (
-                                   @nt >|< "_Inh" >#< pp_parens (ppTuple False @args.pps))
-                             else @expr.pp >#< hv_sp @args.pps
-  | ResumeExpr lhs.pp      = if breadthFirst @lhs.options
-                             then pp_parens ("resume" >#< pp_parens @expr.pp
-                                            >-< indent 2 (pp_parens ( "\\" >|<
-                                                  pp_parens ("~" >|< pp_parens (@nt >|< "_Syn" >#< "_inh_arg"))
-                                                    >#< "->"
-                                            >-< indent 2 ( "let" >#< @left.pp >#< "= _inh_arg"
-                                            >-< indent 2 ("in" >#< @rhs.pp)
-                                            ))))
-                             else pp_parens ( "case" >#< pp_parens @expr.pp >#< "of"
-                                            >-< ("{" >#< @left.pp >#< "->")
-                                            >-< indent 4 (@rhs.pp >#< "}")
-                                            )
-  | SemFun     loc.strictParams = if strictSems @lhs.options
-                                  then @args.pps
-                                  else []
-               loc.addBang = if bangpats @lhs.options
-                             then \p -> pp_parens ("!" >|< p)
-                             else id
-               lhs.pp      = if breadthFirst @lhs.options
-                             then "Child" >#< pp_parens ( "\\" >|<
-                                      pp_parens (@nt >|< "_Inh" >#<
-                                        ppTuple False (map @loc.addBang @args.pps)) >#< "->"
-                                  >-< indent 2 (@loc.strictParams `ppMultiSeqV` @body.pp))
-                             else if null @args.pps
-                                  then @body.pp
-                                  else pp_parens (    "\\" >#< (vlist (map @loc.addBang @args.pps)) >#< "->"
-                                                 >-< indent 4 (@loc.strictParams `ppMultiSeqV` @body.pp)
-                                                 )
-
-SEM CaseAlt
-  | CaseAlt    lhs.pps     = ["{" >#< @left.pp >#< "->", @expr.pp >#< "}"]
-
-SEM DataAlt
-  | DataAlt    lhs.pp      = @name >#< hv_sp (map ((@lhs.strictPre >|<) . pp_parens) @args.pps)
-  | Record     lhs.pp      = @name >#< pp_block "{" "}" "," @args.pps
-
-SEM NamedType
-  | Named      lhs.pp      = if @strict
-                             then @name >#< "::" >#< "!" >|< pp_parens @tp.pp
-                             else @name >#< "::" >#< @tp.pp
-
-SEM Lhs
-  | Pattern3 TupleLhs UnboxedTupleLhs
-      loc.addStrictGuard = if strictCases @lhs.options && @loc.hasStrictVars then \v -> v >#< "|" >#< @loc.strictGuard else id
-  | Pattern3
-      loc.strictGuard = @pat3.strictVars `ppMultiSeqH` (pp "True")
-      loc.hasStrictVars = not (null @pat3.strictVars)
-  | TupleLhs UnboxedTupleLhs
-      loc.strictGuard = if stricterCases @lhs.options && not @lhs.isDeclOfLet
-                        then map text @comps `ppMultiSeqH` (pp "True")
-                        else pp "True"
-      loc.hasStrictVars = not (null @comps)
-
-  | Fun
-      loc.addStrictGuard = if strictSems @lhs.options && @loc.hasStrictVars then \v -> v >#< "|" >#< @loc.strictGuard else id
-      loc.hasStrictVars  = not (null @args.pps)
-      loc.strictGuard    = @args.pps `ppMultiSeqH` (pp "True")
-
-  | TupleLhs UnboxedTupleLhs Fun
-      loc.addBang = if bangpats @lhs.options
-                             then \p -> "!" >|< p
-                             else id
-
-  | Pattern3   lhs.pp      = @loc.addStrictGuard @pat3.pp
-  | Pattern3SM lhs.pp      = @pat3.pp'
-  | TupleLhs   lhs.pp      = @loc.addStrictGuard $ ppTuple @lhs.nested (map (@loc.addBang . text) @comps)
-  | UnboxedTupleLhs   lhs.pp      = @loc.addStrictGuard $ ppUnboxedTuple @lhs.nested (map (@loc.addBang . text) @comps)
-  | Fun        lhs.pp      = @loc.addStrictGuard (@name >#< hv_sp (map @loc.addBang @args.pps))
-  | Unwrap     lhs.pp      = pp_parens (@name >#< @sub.pp)
-
-SEM Type  [ | | prec:Int ]
-  | Arr        lhs.prec    = 2
-                  .pp      = @loc.l >#< "->" >-< @loc.r
-               loc.l       = if @left.prec  <= 2 then pp_parens @left.pp  else @left.pp
-                  .r       = if @right.prec <  2 then pp_parens @right.pp else @right.pp
-
-  | TypeApp
-      lhs.pp = hv_sp (@func.pp : @args.pps)
-
-  | CtxApp
-      lhs.pp = (pp_block "(" ")" "," $ map (\(n,ns) -> hv_sp $ map pp (n:ns)) @left) >#< "=>" >#< @right.pp
-  | QuantApp
-      lhs.pp = @left >#< @right.pp
-
-  | TupleType  lhs.prec    = 5
-                  .pp      = ppTuple @lhs.nested @tps.pps
-
-  | UnboxedTupleType  lhs.prec    = 5
-                         .pp      = ppUnboxedTuple @lhs.nested @tps.pps
-
-  | List       lhs.prec    = 5
-                  .pp      = "[" >|< @tp.pp >|< "]"
-
-  | SimpleType lhs.prec    = 5
-                  .pp      = if reallySimple @txt then text @txt else pp_parens (text @txt)
-
-  | NontermType  lhs.prec  = 5
-                 lhs.pp    = @loc.prefix >|< text @name >#< hv_sp @params
-                 loc.prefix = if @deforested
-                              then text "T_"
-                              else empty
-  | TMaybe       lhs.prec  = 5
-                 lhs.pp    = text "Maybe" >#< pp_parens @tp.pp
-  | TEither      lhs.prec  = 5
-                 lhs.pp    = text "Either" >#< pp_parens @left.pp >#< pp_parens @right.pp
-  | TMap         lhs.prec  = 5
-                 lhs.pp    = text "Data.Map.Map" >#< pp_parens @key.pp >#< pp_parens @value.pp
-  | TIntMap      lhs.prec  = 5
-                 lhs.pp    = text "Data.IntMap.IntMap" >#< pp_parens @value.pp
-  | TSet         lhs.prec  = 5
-                 lhs.pp    = text "Data.Set.Set" >#< pp_parens @tp.pp
-  | TIntSet      lhs.prec  = 5
-                 lhs.pp    = text "Data.IntSet.IntSet"
-
-
-{
-
-reallySimple :: String -> Bool
-reallySimple = and . map (\x -> isAlphaNum x || x=='_')
-
-ppTuple :: Bool -> [PP_Doc] -> PP_Doc
-ppTuple True  pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps
-ppTuple False pps = "(" >|< pp_block " " ")" "," pps
-ppUnboxedTuple :: Bool -> [PP_Doc] -> PP_Doc
-ppUnboxedTuple True pps  = "(# " >|< pp_block " " (concat $ replicate (length pps `max` 1) " #)") ",(# " pps
-ppUnboxedTuple False pps = "(# " >|< pp_block " " " #)" "," pps
-
-}
-
-
--------------------------------------------------------------------------------
---         Strict data fields
--------------------------------------------------------------------------------
-
-ATTR DataAlt DataAlts [ strictPre: PP_Doc | | ]
-
-SEM Decl
-  | Data alts.strictPre = if @strict then pp "!" else empty
-
--------------------------------------------------------------------------------
---         Strict variables
--------------------------------------------------------------------------------
-
-ATTR Pattern Patterns [ | | strictVars USE {++} {[]} : {[PP_Doc]} ]
-SEM Pattern
-  | Alias
-      loc.strictVar
-        = if strictCases @lhs.options && not @lhs.isDeclOfLet
-          then [@loc.ppVar]
-          else []
-      loc.strictPatVars
-        = if stricterCases @lhs.options && not @lhs.isDeclOfLet
-          then @pat.strictVars
-          else []
-      lhs.strictVars
-        = @loc.strictVar ++ @loc.strictPatVars
-  | Irrefutable
-      lhs.strictVars = []
-
--------------------------------------------------------------------------------
---         Pretty printing patterns
--------------------------------------------------------------------------------
-
-SEM Patterns [ | | pps : {[PP_Doc]} ]
-  | Cons lhs.pps = @hd.pp : @tl.pps
-  | Nil  lhs.pps = []
-
-SEM Pattern
-  | Constr Product Alias
-      loc.addBang = if bangpats @lhs.options && not @lhs.isDeclOfLet && not @lhs.belowIrrefutable
-                    then \p -> "!" >|< p
-                    else id
-
-SEM Pattern [ | | pp:PP_Doc ]
-  | Constr  lhs.pp     = @loc.addBang $ pp_parens $ @name >#< hv_sp @pats.pps
-  | Product lhs.pp     = @loc.addBang $ pp_block "(" ")" "," @pats.pps
-  | Alias   loc.ppVar  = pp (attrname @lhs.options False @field @attr)
-            loc.ppVarBang = @loc.addBang $ @loc.ppVar
-            lhs.pp     = if @pat.isUnderscore
-                          then @loc.ppVarBang
-                          else @loc.ppVarBang >|< "@" >|< @pat.pp
-  | Irrefutable lhs.pp = text "~" >|< pp_parens @pat.pp
-  | Underscore lhs.pp  = text "_"
-
-SEM Pattern [ | | isUnderscore:{Bool}]
- | Constr      lhs.isUnderscore = False
- | Product     lhs.isUnderscore = False
- | Alias       lhs.isUnderscore = False
- | Underscore  lhs.isUnderscore = True
-
-ATTR Pattern Patterns [ belowIrrefutable : Bool | | ]
-SEM Pattern
-  | Irrefutable
-      pat.belowIrrefutable = True
-
-SEM Lhs
-  | Pattern3 Pattern3SM
-      pat3.belowIrrefutable = False
-
--------------------------------------------------------------------------------
---         Pretty printing patterns for SM
--------------------------------------------------------------------------------
-
-SEM Patterns [ | | pps' : {[PP_Doc]} ]
-  | Cons lhs.pps' = @hd.pp' : @tl.pps'
-  | Nil  lhs.pps' = []
-
-SEM Pattern [ | | pp':PP_Doc ]
-  | Constr  lhs.pp'     = pp_parens $ @name >#< hv_sp (map pp_parens @pats.pps')
-  | Product lhs.pp'     = pp_block "(" ")" "," @pats.pps'
-  | Alias   lhs.pp'     = let attribute | @field == _LOC || @field == nullIdent = locname' @attr
-                                        | otherwise                             = attrname @lhs.options False @field @attr
-                          in attribute >|< "@" >|< @pat.pp'
-  | Irrefutable lhs.pp' = text "~" >|< pp_parens @pat.pp
-  | Underscore lhs.pp'  = text "_"
-
-{
-locname' :: Identifier -> [Char]
-locname' n = "_loc_" ++ getName n
-}
-
--------------------------------------------------------------------------------
---         Determine if inside a Let
--------------------------------------------------------------------------------
-
-ATTR Chunks Chunk Decls Decl Lhs Pattern Patterns [ isDeclOfLet : Bool | | ]
-SEM Program
-  | Program
-      chunks.isDeclOfLet = False
-
-SEM Expr
-  | Let
-      decls.isDeclOfLet = True
-  | Do
-      stmts.isDeclOfLet = False
-  | ResumeExpr
-      left.isDeclOfLet = False
-
-SEM CaseAlt
-  | CaseAlt
-      left.isDeclOfLet = False
-
-
-
--------------------------------------------------------------------------------
---         Alternative code printing to separate modules
--------------------------------------------------------------------------------
-
-ATTR Program [ mainBlocksDoc : PP_Doc | | genIO : {IO ()} ]
-ATTR Program Chunks Chunk
-  [ importBlocks : PP_Doc
-    pragmaBlocks : String
-    textBlocks : PP_Doc
-    textBlockMap : {Map BlockInfo PP_Doc}
-    optionsLine : String
-    mainFile : String
-    mainName : String
-    moduleHeader : {String -> String -> String -> Bool -> String}
-     | | ]
-
-SEM Program
-  | Program
-      loc.mainModuleFile = @lhs.mainFile
-      loc.genMainModule
-        = writeModule @loc.mainModuleFile
-            ( [ pp $ @lhs.pragmaBlocks
-              , pp $ @lhs.optionsLine
-              , pp $ @lhs.moduleHeader @lhs.mainName "" "" False
-              , pp $ ("import " ++ @lhs.mainName ++ "_common\n")
-              ]
-              ++ map pp @chunks.imports
-              ++ map vlist @chunks.appendMain
-              ++ [@lhs.mainBlocksDoc]
-            )
-
-      loc.commonFile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_common")
-      loc.genCommonModule
-        = writeModule @loc.commonFile
-              ( [ pp $ @lhs.pragmaBlocks
-                , pp $ @lhs.optionsLine
-                , pp $ @lhs.moduleHeader @lhs.mainName "_common" "" True
-                , @lhs.importBlocks
-                , @lhs.textBlocks
-                ]
-                ++ map vlist @chunks.appendCommon
-              )
-
-      lhs.genIO = do @loc.genMainModule
-                     @loc.genCommonModule
-                     @chunks.genSems
-
-{
-renderDocs :: [PP_Doc] -> String
-renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) ""
-}
-
-ATTR Chunk Chunks [ | | imports USE {++} {[]} : {[String]} ]
-SEM Chunk
-  | Chunk
-      lhs.imports = ["import " ++ @lhs.mainName ++ "_" ++ @name ++ "\n"]
-
-ATTR Chunk Chunks [ | | appendCommon, appendMain USE {++} {[]} : {[[PP_Doc]]} ]
-
-SEM Chunk
-  | Chunk
-      lhs.appendCommon
-        = [ [@comment.pp]
-          , @dataDef.pps
-          , @semDom.pps
-          , if reference @lhs.options then @semWrapper.pps else []
-          ]
-      lhs.appendMain
-        = [ [@comment.pp]
-          , @cataFun.pps
-          , if reference @lhs.options then [] else @semWrapper.pps
-          ]
-
-ATTR Chunk Chunks [ | | genSems USE {>>} {return ()} : {IO ()} ]
-
-SEM Chunk
-  | Chunk
-      lhs.genSems
-        = writeModule @loc.outputfile
-            [ pp $ @lhs.pragmaBlocks
-            , pp $ Map.findWithDefault empty (BlockPragma, Just $ identifier @name) @lhs.textBlockMap
-            , pp $ @lhs.optionsLine
-            , pp $ @lhs.moduleHeader @lhs.mainName ("_" ++ @name) @loc.exports True
-            , pp $ ("import " ++ @lhs.mainName ++ "_common\n")
-            , pp $ Map.findWithDefault empty (BlockImport, Just $ identifier @name) @lhs.textBlockMap
-            , @comment.pp
-            , vlist_sep "" @info.pps
-            , vlist_sep "" @semFunctions.pps
-            , Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap
-            ]
-
-SEM Chunk
-  | Chunk
-      loc.exports = concat $ intersperse "," @semNames
-
-{
-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
-}
-
+PRAGMA strictdata+PRAGMA optimize+PRAGMA bangpats+PRAGMA strictwrap++INCLUDE "Code.ag"+INCLUDE "Patterns.ag"++imports+{+import Data.Char (isAlphaNum)+import Pretty+import Code+import Options+import CommonTypes (attrname, _LOC, nullIdent)+import Data.List(intersperse)+import System.IO+import System.Directory+import System.FilePath+import CommonTypes(BlockInfo, BlockKind(..))+}++{+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+}++ATTR Expr Exprs Decl Decls CaseAlt CaseAlts Lhs [ outputfile : {String} | | ]++SEM Chunk+  | Chunk+      loc.outputfile = if sepSemMods @lhs.options+                       then replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_" ++ @name)+                       else @lhs.mainFile++ATTR Program                            [ options:{Options} | | output:{PP_Docs} ]++ATTR Expr Exprs Decl Decls Chunk Chunks CaseAlts CaseAlt Lhs Pattern Patterns [ options:{Options} | | ]++ATTR Expr Decl DataAlt Type NamedType Lhs [ nested:{Bool} | | pp:{PP_Doc} ]++ATTR Exprs DataAlts Types NamedTypes Decls Chunk Chunks [ nested:{Bool} | | pps : {PP_Docs} ]++ATTR CaseAlt CaseAlts                   [ nested:{Bool} | | pps: {PP_Docs} ]++SEM Program | Program+  loc.options = @lhs.options { breadthFirst = breadthFirst @lhs.options && visit @lhs.options && cases @lhs.options && @ordered }++SEM Program+  | Program chunks.nested = nest @lhs.options++SEM Exprs+  | Cons lhs.pps = @hd.pp : @tl.pps+  | Nil  lhs.pps = []++SEM CaseAlts+  | Cons lhs.pps = @hd.pps ++ @tl.pps+  | Nil  lhs.pps = []++SEM DataAlts+  | Cons lhs.pps = @hd.pp : @tl.pps+  | Nil  lhs.pps = []++SEM Types+  | Cons lhs.pps = @hd.pp : @tl.pps+  | Nil  lhs.pps = []++SEM NamedTypes+  | Cons lhs.pps = @hd.pp : @tl.pps+  | Nil  lhs.pps = []++SEM Decls+  | Cons lhs.pps = @hd.pp : @tl.pps+  | Nil  lhs.pps = []++SEM Chunks+  | Cons lhs.pps = @hd.pps ++ @tl.pps+  | Nil  lhs.pps = []+++SEM Program+  | Program    lhs.output  = @chunks.pps++SEM Chunk+  | Chunk      lhs.pps     =  @comment.pp+                              :  @info.pps+                              ++ @dataDef.pps+                              ++ @cataFun.pps+                              ++ @semDom.pps+                              ++ @semWrapper.pps+                              ++ @semFunctions.pps+                              ++ [Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap]++SEM Decl+  | Decl       lhs.pp      = @left.pp >#< "="+                             >-< indent 4 @rhs.pp+  | Bind       lhs.pp      = @left.pp >#< "<-" >#< @rhs.pp+  | BindLet    lhs.pp      = "let" >#< @left.pp >#< "=" >#< @rhs.pp+  | Data       lhs.pp      = "data" >#< hv_sp (@name : @params)+                             >#<  ( case @alts.pps of+                                          [] -> empty+                                          (x:xs) ->              "=" >#<  x+                                                 >-< vlist (map ("|" >#<) xs)+                                     >-< if null @derivings+                                            then empty+                                            else "deriving" >#< ppTuple False (map text @derivings)+                                  )+  | NewType    lhs.pp      = "newtype" >#< hv_sp (@name : @params) >#< "=" >#< @con >#< pp_parens @tp.pp+  | Type       lhs.pp      = "type" >#< hv_sp (@name : @params) >#< "=" >#<  @tp.pp+  | TSig       lhs.pp      = @name >#< "::" >#< @tp.pp+  | Comment    lhs.pp      = if '\n' `elem` @txt+                               then "{-" >-< vlist (lines @txt) >-< "-}"+                               else "--" >#< @txt+  | PragmaDecl lhs.pp      = "{-#" >#< text @txt >#< "#-}"+  | Resume     lhs.pp      = if @monadic+                             then @left.pp >#< "<-" >#< @rhs.pp+                             else @left.pp >#< "=" >-< indent 4 @rhs.pp+  | EvalDecl   loc.strat   = if breadthFirstStrict @lhs.options+                             then "stepwiseEval"+                             else "lazyEval"+               lhs.pp      = if breadthFirst @lhs.options+                             then @left.pp >#< "=" >#< "case" >#< @loc.strat >#< pp_parens @rhs.pp >#< "of"+                                  >-< indent 4 (+                                    pp_parens (@nt >|< "_Syn" >#< "_val") >#< "-> _val"+                                  )+                             else @left.pp >#< "=" >#< @rhs.pp++SEM Expr+  | Let        lhs.pp      = pp_parens (    "let" >#< (vlist @decls.pps)+                                       >-< "in " >#< @body.pp+                                       )+  | Case       lhs.pp      = pp_parens (    "case" >#< pp_parens @expr.pp >#< "of"+                                       >-< (vlist @alts.pps)+                                       )+  | Do         lhs.pp      = pp_parens ( "do" >#< (   vlist @stmts.pps+                                                  >-< ("return" >#< @body.pp))+                                       )+  | Lambda     loc.strictParams = if strictSems @lhs.options+                                  then @args.pps+                                  else []+               loc.addBang = if bangpats @lhs.options+                             then \p -> pp_parens ("!" >|< p)+                             else id+               lhs.pp      = pp_parens (    "\\" >#< (vlist (map @loc.addBang @args.pps)) >#< "->"+                                       >-< indent 4 (@loc.strictParams `ppMultiSeqV` @body.pp)+                                       )+  | TupleExpr  lhs.pp      = ppTuple @lhs.nested @exprs.pps+  | UnboxedTupleExpr  lhs.pp      = ppUnboxedTuple @lhs.nested @exprs.pps+  | App        lhs.pp      = pp_parens $ @name >#< hv_sp @args.pps+  | SimpleExpr lhs.pp      = text @txt+  | TextExpr   lhs.pp      = vlist (map text @lns)+  | Trace      lhs.pp      = "trace" >#< (   pp_parens ("\"" >|< text @txt >|< "\"")+                                         >-< pp_parens @expr.pp+                                         )+  | PragmaExpr lhs.pp      = 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 pp_parens (pragmaDoc `leftOp` @expr.pp `rightOp` pragmaDoc)+  | LineExpr   lhs.pp      = @expr.pp >-< "{-# LINE" >#< ppWithLineNr (\n -> pp $ show $ n + 1) >#< show @lhs.outputfile >#< "#-}"+                                      >-< ""+  | TypedExpr  lhs.pp      = pp_parens (@expr.pp >#< "::" >#< @tp.pp)+  | ResultExpr lhs.pp      = if breadthFirst @lhs.options+                             then "final" >#<+                                  pp_parens (@nt >|< "_Syn" >#< pp_parens @expr.pp)+                             else @expr.pp+  | InvokeExpr lhs.pp      = if breadthFirst @lhs.options+                             then "invoke" >#< pp_parens @expr.pp >#< pp_parens (+                                   @nt >|< "_Inh" >#< pp_parens (ppTuple False @args.pps))+                             else @expr.pp >#< hv_sp @args.pps+  | ResumeExpr lhs.pp      = if breadthFirst @lhs.options+                             then pp_parens ("resume" >#< pp_parens @expr.pp+                                            >-< indent 2 (pp_parens ( "\\" >|<+                                                  pp_parens ("~" >|< pp_parens (@nt >|< "_Syn" >#< "_inh_arg"))+                                                    >#< "->"+                                            >-< indent 2 ( "let" >#< @left.pp >#< "= _inh_arg"+                                            >-< indent 2 ("in" >#< @rhs.pp)+                                            ))))+                             else pp_parens ( "case" >#< pp_parens @expr.pp >#< "of"+                                            >-< ("{" >#< @left.pp >#< "->")+                                            >-< indent 4 (@rhs.pp >#< "}")+                                            )+  | SemFun     loc.strictParams = if strictSems @lhs.options+                                  then @args.pps+                                  else []+               loc.addBang = if bangpats @lhs.options+                             then \p -> pp_parens ("!" >|< p)+                             else id+               lhs.pp      = if breadthFirst @lhs.options+                             then "Child" >#< pp_parens ( "\\" >|<+                                      pp_parens (@nt >|< "_Inh" >#<+                                        ppTuple False (map @loc.addBang @args.pps)) >#< "->"+                                  >-< indent 2 (@loc.strictParams `ppMultiSeqV` @body.pp))+                             else if null @args.pps+                                  then @body.pp+                                  else pp_parens (    "\\" >#< (vlist (map @loc.addBang @args.pps)) >#< "->"+                                                 >-< indent 4 (@loc.strictParams `ppMultiSeqV` @body.pp)+                                                 )++SEM CaseAlt+  | CaseAlt    lhs.pps     = ["{" >#< @left.pp >#< "->", @expr.pp >#< "}"]++SEM DataAlt+  | DataAlt    lhs.pp      = @name >#< hv_sp (map ((@lhs.strictPre >|<) . pp_parens) @args.pps)+  | Record     lhs.pp      = @name >#< pp_block "{" "}" "," @args.pps++SEM NamedType+  | Named      lhs.pp      = if @strict+                             then @name >#< "::" >#< "!" >|< pp_parens @tp.pp+                             else @name >#< "::" >#< @tp.pp++SEM Lhs+  | Pattern3 TupleLhs UnboxedTupleLhs+      loc.addStrictGuard = if strictCases @lhs.options && @loc.hasStrictVars then \v -> v >#< "|" >#< @loc.strictGuard else id+  | Pattern3+      loc.strictGuard = @pat3.strictVars `ppMultiSeqH` (pp "True")+      loc.hasStrictVars = not (null @pat3.strictVars)+  | TupleLhs UnboxedTupleLhs+      loc.strictGuard = if stricterCases @lhs.options && not @lhs.isDeclOfLet+                        then map text @comps `ppMultiSeqH` (pp "True")+                        else pp "True"+      loc.hasStrictVars = not (null @comps)++  | Fun+      loc.addStrictGuard = if strictSems @lhs.options && @loc.hasStrictVars then \v -> v >#< "|" >#< @loc.strictGuard else id+      loc.hasStrictVars  = not (null @args.pps)+      loc.strictGuard    = @args.pps `ppMultiSeqH` (pp "True")++  | TupleLhs UnboxedTupleLhs Fun+      loc.addBang = if bangpats @lhs.options+                             then \p -> "!" >|< p+                             else id++  | Pattern3   lhs.pp      = @loc.addStrictGuard @pat3.pp+  | Pattern3SM lhs.pp      = @pat3.pp'+  | TupleLhs   lhs.pp      = @loc.addStrictGuard $ ppTuple @lhs.nested (map (@loc.addBang . text) @comps)+  | UnboxedTupleLhs   lhs.pp      = @loc.addStrictGuard $ ppUnboxedTuple @lhs.nested (map (@loc.addBang . text) @comps)+  | Fun        lhs.pp      = @loc.addStrictGuard (@name >#< hv_sp (map @loc.addBang @args.pps))+  | Unwrap     lhs.pp      = pp_parens (@name >#< @sub.pp)++SEM Type  [ | | prec:Int ]+  | Arr        lhs.prec    = 2+                  .pp      = @loc.l >#< "->" >-< @loc.r+               loc.l       = if @left.prec  <= 2 then pp_parens @left.pp  else @left.pp+                  .r       = if @right.prec <  2 then pp_parens @right.pp else @right.pp++  | TypeApp+      lhs.pp = hv_sp (@func.pp : @args.pps)++  | CtxApp+      lhs.pp = (pp_block "(" ")" "," $ map (\(n,ns) -> hv_sp $ map pp (n:ns)) @left) >#< "=>" >#< @right.pp+  | QuantApp+      lhs.pp = @left >#< @right.pp++  | TupleType  lhs.prec    = 5+                  .pp      = ppTuple @lhs.nested @tps.pps++  | UnboxedTupleType  lhs.prec    = 5+                         .pp      = ppUnboxedTuple @lhs.nested @tps.pps++  | List       lhs.prec    = 5+                  .pp      = "[" >|< @tp.pp >|< "]"++  | SimpleType lhs.prec    = 5+                  .pp      = if reallySimple @txt then text @txt else pp_parens (text @txt)++  | NontermType  lhs.prec  = 5+                 lhs.pp    = @loc.prefix >|< text @name >#< hv_sp @params+                 loc.prefix = if @deforested+                              then text "T_"+                              else empty+  | TMaybe       lhs.prec  = 5+                 lhs.pp    = text "Maybe" >#< pp_parens @tp.pp+  | TEither      lhs.prec  = 5+                 lhs.pp    = text "Either" >#< pp_parens @left.pp >#< pp_parens @right.pp+  | TMap         lhs.prec  = 5+                 lhs.pp    = text "Data.Map.Map" >#< pp_parens @key.pp >#< pp_parens @value.pp+  | TIntMap      lhs.prec  = 5+                 lhs.pp    = text "Data.IntMap.IntMap" >#< pp_parens @value.pp+  | TSet         lhs.prec  = 5+                 lhs.pp    = text "Data.Set.Set" >#< pp_parens @tp.pp+  | TIntSet      lhs.prec  = 5+                 lhs.pp    = text "Data.IntSet.IntSet"+++{++reallySimple :: String -> Bool+reallySimple = and . map (\x -> isAlphaNum x || x=='_')++ppTuple :: Bool -> [PP_Doc] -> PP_Doc+ppTuple True  pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps+ppTuple False pps = "(" >|< pp_block " " ")" "," pps+ppUnboxedTuple :: Bool -> [PP_Doc] -> PP_Doc+ppUnboxedTuple True pps  = "(# " >|< pp_block " " (concat $ replicate (length pps `max` 1) " #)") ",(# " pps+ppUnboxedTuple False pps = "(# " >|< pp_block " " " #)" "," pps++}+++-------------------------------------------------------------------------------+--         Strict data fields+-------------------------------------------------------------------------------++ATTR DataAlt DataAlts [ strictPre: PP_Doc | | ]++SEM Decl+  | Data alts.strictPre = if @strict then pp "!" else empty++-------------------------------------------------------------------------------+--         Strict variables+-------------------------------------------------------------------------------++ATTR Pattern Patterns [ | | strictVars USE {++} {[]} : {[PP_Doc]} ]+SEM Pattern+  | Alias+      loc.strictVar+        = if strictCases @lhs.options && not @lhs.isDeclOfLet+          then [@loc.ppVar]+          else []+      loc.strictPatVars+        = if stricterCases @lhs.options && not @lhs.isDeclOfLet+          then @pat.strictVars+          else []+      lhs.strictVars+        = @loc.strictVar ++ @loc.strictPatVars+  | Irrefutable+      lhs.strictVars = []++-------------------------------------------------------------------------------+--         Pretty printing patterns+-------------------------------------------------------------------------------++SEM Patterns [ | | pps : {[PP_Doc]} ]+  | Cons lhs.pps = @hd.pp : @tl.pps+  | Nil  lhs.pps = []++SEM Pattern+  | Constr Product Alias+      loc.addBang = if bangpats @lhs.options && not @lhs.isDeclOfLet && not @lhs.belowIrrefutable+                    then \p -> "!" >|< p+                    else id++SEM Pattern [ | | pp:PP_Doc ]+  | Constr  lhs.pp     = @loc.addBang $ pp_parens $ @name >#< hv_sp @pats.pps+  | Product lhs.pp     = @loc.addBang $ pp_block "(" ")" "," @pats.pps+  | Alias   loc.ppVar  = pp (attrname @lhs.options False @field @attr)+            loc.ppVarBang = @loc.addBang $ @loc.ppVar+            lhs.pp     = if @pat.isUnderscore+                          then @loc.ppVarBang+                          else @loc.ppVarBang >|< "@" >|< @pat.pp+  | Irrefutable lhs.pp = text "~" >|< pp_parens @pat.pp+  | Underscore lhs.pp  = text "_"++SEM Pattern [ | | isUnderscore:{Bool}]+ | Constr      lhs.isUnderscore = False+ | Product     lhs.isUnderscore = False+ | Alias       lhs.isUnderscore = False+ | Underscore  lhs.isUnderscore = True++ATTR Pattern Patterns [ belowIrrefutable : Bool | | ]+SEM Pattern+  | Irrefutable+      pat.belowIrrefutable = True++SEM Lhs+  | Pattern3 Pattern3SM+      pat3.belowIrrefutable = False++-------------------------------------------------------------------------------+--         Pretty printing patterns for SM+-------------------------------------------------------------------------------++SEM Patterns [ | | pps' : {[PP_Doc]} ]+  | Cons lhs.pps' = @hd.pp' : @tl.pps'+  | Nil  lhs.pps' = []++SEM Pattern [ | | pp':PP_Doc ]+  | Constr  lhs.pp'     = pp_parens $ @name >#< hv_sp (map pp_parens @pats.pps')+  | Product lhs.pp'     = pp_block "(" ")" "," @pats.pps'+  | Alias   lhs.pp'     = let attribute | @field == _LOC || @field == nullIdent = locname' @attr+                                        | otherwise                             = attrname @lhs.options False @field @attr+                          in attribute >|< "@" >|< @pat.pp'+  | Irrefutable lhs.pp' = text "~" >|< pp_parens @pat.pp+  | Underscore lhs.pp'  = text "_"++{+locname' :: Identifier -> [Char]+locname' n = "_loc_" ++ getName n+}++-------------------------------------------------------------------------------+--         Determine if inside a Let+-------------------------------------------------------------------------------++ATTR Chunks Chunk Decls Decl Lhs Pattern Patterns [ isDeclOfLet : Bool | | ]+SEM Program+  | Program+      chunks.isDeclOfLet = False++SEM Expr+  | Let+      decls.isDeclOfLet = True+  | Do+      stmts.isDeclOfLet = False+  | ResumeExpr+      left.isDeclOfLet = False++SEM CaseAlt+  | CaseAlt+      left.isDeclOfLet = False++++-------------------------------------------------------------------------------+--         Alternative code printing to separate modules+-------------------------------------------------------------------------------++ATTR Program [ mainBlocksDoc : PP_Doc | | genIO : {IO ()} ]+ATTR Program Chunks Chunk+  [ importBlocks : PP_Doc+    pragmaBlocks : String+    textBlocks : PP_Doc+    textBlockMap : {Map BlockInfo PP_Doc}+    optionsLine : String+    mainFile : String+    mainName : String+    moduleHeader : {String -> String -> String -> Bool -> String}+     | | ]++SEM Program+  | Program+      loc.mainModuleFile = @lhs.mainFile+      loc.genMainModule+        = writeModule @loc.mainModuleFile+            ( [ pp $ @lhs.pragmaBlocks+              , pp $ @lhs.optionsLine+              , pp $ @lhs.moduleHeader @lhs.mainName "" "" False+              , pp $ ("import " ++ @lhs.mainName ++ "_common\n")+              ]+              ++ map pp @chunks.imports+              ++ map vlist @chunks.appendMain+              ++ [@lhs.mainBlocksDoc]+            )++      loc.commonFile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_common")+      loc.genCommonModule+        = writeModule @loc.commonFile+              ( [ pp $ @lhs.pragmaBlocks+                , pp $ @lhs.optionsLine+                , pp $ @lhs.moduleHeader @lhs.mainName "_common" "" True+                , @lhs.importBlocks+                , @lhs.textBlocks+                ]+                ++ map vlist @chunks.appendCommon+              )++      lhs.genIO = do @loc.genMainModule+                     @loc.genCommonModule+                     @chunks.genSems++{+renderDocs :: [PP_Doc] -> String+renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) ""+}++ATTR Chunk Chunks [ | | imports USE {++} {[]} : {[String]} ]+SEM Chunk+  | Chunk+      lhs.imports = ["import " ++ @lhs.mainName ++ "_" ++ @name ++ "\n"]++ATTR Chunk Chunks [ | | appendCommon, appendMain USE {++} {[]} : {[[PP_Doc]]} ]++SEM Chunk+  | Chunk+      lhs.appendCommon+        = [ [@comment.pp]+          , @dataDef.pps+          , @semDom.pps+          , if reference @lhs.options then @semWrapper.pps else []+          ]+      lhs.appendMain+        = [ [@comment.pp]+          , @cataFun.pps+          , if reference @lhs.options then [] else @semWrapper.pps+          ]++ATTR Chunk Chunks [ | | genSems USE {>>} {return ()} : {IO ()} ]++SEM Chunk+  | Chunk+      lhs.genSems+        = writeModule @loc.outputfile+            [ pp $ @lhs.pragmaBlocks+            , pp $ Map.findWithDefault empty (BlockPragma, Just $ identifier @name) @lhs.textBlockMap+            , pp $ @lhs.optionsLine+            , pp $ @lhs.moduleHeader @lhs.mainName ("_" ++ @name) @loc.exports True+            , pp $ ("import " ++ @lhs.mainName ++ "_common\n")+            , pp $ Map.findWithDefault empty (BlockImport, Just $ identifier @name) @lhs.textBlockMap+            , @comment.pp+            , vlist_sep "" @info.pps+            , vlist_sep "" @semFunctions.pps+            , Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap+            ]++SEM Chunk+  | Chunk+      loc.exports = concat $ intersperse "," @semNames++{+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+}+
src-ag/PrintErrorMessages.ag view
@@ -1,656 +1,656 @@-INCLUDE "ErrorMessages.ag"
-
-imports
-{
-import UU.Scanner.Position(Pos(..), noPos)
-import ErrorMessages
-import Data.List(mapAccumL)
-import GrammarInfo
-import qualified Control.Monad.Error.Class as Err
-}
-
-
-{
-instance Err.Error Error where
-  noMsg  = Err.strMsg "error"
-  strMsg = CustomError False noPos . pp
-}
-
-
-{
-isError :: Options -> 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          _ _ _    ) = False
-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 opts (LocalCirc       _ _ _ _ _) = cycleIsDangerous opts
-isError opts (InstCirc        _ _ _ _ _) = cycleIsDangerous opts
-isError opts (DirectCirc      _ _ _    ) = cycleIsDangerous opts
-isError opts (InducedCirc     _ _ _    ) = cycleIsDangerous opts
-isError _ (MissingTypeSig  _ _ _    ) = False
-isError _ (MissingInstSig  _ _ _    ) = True
-isError _ (DupUnique       _ _ _    ) = False
-isError _ (MissingUnique   _ _      ) = True
-isError _ (MissingSyn      _ _      ) = True
-isError _ (MissingNamedRule _ _ _)    = True
-isError _ (DupRuleName _ _ _)         = True
-isError _ (HsParseError _ _)          = True
-isError _ (Cyclic _ _ _)              = True
-isError _ (IncompatibleVisitKind _ _ _ _) = True
-isError _ (IncompatibleRuleKind _ _)      = True
-isError _ (IncompatibleAttachKind _ _)    = True
-
-cycleIsDangerous :: Options -> Bool
-cycleIsDangerous opts
-  = any ($ opts) [ wignore, bangpats, cases, strictCases, stricterCases, strictSems, withCycle ]
-}
-
-
-
-
-
-
-ATTR Error   [ options:{Options} verbose:{Bool}    | | pp           :{PP_Doc}
-                                     me                             :SELF
-             ]
-
-ATTR Errors  [ options:{Options}  dups : {[String]} | | pp         USE {>-<} {text ""} : {PP_Doc}
-             ]
-
-SEM Errors
-  | *  loc.verbose = verbose @lhs.options
-  | Cons  loc.str = disp @hd.pp 5000 ""
-
-          lhs.pp = if @loc.str `elem` @lhs.dups
-                   then @tl.pp
-                   else @hd.pp >-< @tl.pp
-          tl.dups = @loc.str : @lhs.dups
-  | Nil   lhs.pp = text ""
-
-
-SEM Error
-  | ParserError     lhs.pp = let mesg = text ("parser expecting " ++ @problem)
-                                 pat  = text ""
-                                 help = text ""
-                                 act  = text @action
-                              in ppError (isError @lhs.options @me) @pos mesg pat help act @lhs.verbose
-
-  | HsParseError    lhs.pp = ppError True @pos (text @msg) (text "") (text "") (text "Correct the syntax of the Haskell code.") @lhs.verbose
-
-  | DupAlt          lhs.pp = let mesg  = wfill ["Repeated definition for alternative", getName @con
-                                               ,"of nonterminal", getName @nt, "."
-                                               ] >-<
-                                         wfill ["First definition:", (showPos @occ1),"."] >-<
-                                         wfill ["Other definition:", (showPos @con),"."]
-                                 pat =     "DATA" >#< getName @nt
-                                       >-< indent 2 ("|" >#< getName @con >#< "...")
-                                       >-< indent 2 ("|" >#< getName @con >#< "...")
-
-                                 help =  wfill ["The nonterminal",getName @nt,"has more than one alternative that"
-                                               ,"is labelled with the constructor name",getName @con,"."
-                                               ,"You should either rename or remove enough of them to make all"
-                                               ,"constructors of",getName @nt,"uniquely named."
-                                               ]
-
-                                 act  = wfill [ "The first alternative of name",getName @con
-                                              ,"you have given for nonterminal",getName @nt
-                                              ,"is considered valid. All other alternatives have been discarded."
-                                              ]
-
-                             in ppError (isError @lhs.options @me) (getPos @con) mesg pat help act @lhs.verbose
-
-  | DupSynonym      lhs.pp = let mesg  = wfill ["Definition of type synonym", getName @nt, "clashes with another"
-                                               ,"type synonym."
-                                               ] >-<
-                                         wfill ["First definition:", (showPos @occ1),"."] >-<
-                                         wfill ["Type synonym :"   , (showPos @nt),"."]
-                                 pat =     "DATA" >#< getName @nt
-                                       >-< indent 2 ("|" >#< "...")
-                                       >-< "TYPE" >#< getName @nt >#< "=" >#<  "..."
-                                 help =  wfill ["A type synonym with name", getName  @nt
-                                               ,"has been given while there already is TYPE"
-                                               ,"definition with the same name."
-                                               ,"You should either rename or remove the type synonym."
-                                               ]
-                                 act  = wfill [ "The clashing type synonym will be ignored."
-                                              ]
-                             in ppError (isError @lhs.options @me)  (getPos @nt) mesg pat help act @lhs.verbose
-
-  | DupSet          lhs.pp = let mesg  = wfill ["Definition of nonterminal set", getName @name, "clashes with another"
-                                               ,"set, a type synonym or a data definition."
-                                               ] >-<
-                                         wfill ["First definition:", (showPos @occ1),"."] >-<
-                                         wfill ["Set definition:"   , (showPos @name),"."]
-                                 pat =     "SET" >#< getName @name >#< "=" >#<  "..."
-                                       >-< "SET" >#< getName @name >#< "=" >#<  "..."
-                                 help =  wfill ["A nonterminal set with name", getName  @name
-                                               ,"has been given while there already is a SET, DATA, or TYPE"
-                                               ,"definition with the same name."
-                                               ,"You should either rename or remove the nonterminal set."
-                                               ]
-                                 act  = wfill [ "The clashing nonterminal set will be ignored."
-                                              ]
-                             in ppError (isError @lhs.options @me)  (getPos @name) mesg pat help act @lhs.verbose
-
-  | DupInhAttr      lhs.pp = let mesg  = wfill ["Repeated declaration of inherited attribute", getName @attr
-                                               , "of nonterminal", getName @nt, "."
-                                               ] >-<
-                                         wfill ["First definition:", (showPos @occ1),"."] >-<
-                                         wfill ["Other definition:", (showPos @attr),"."]
-                                 pat  = "ATTR" >#< getName @nt >#< "[" >#< getName @attr >|< ":...,"
-                                                               >#< getName @attr >|< ":... | | ]"
-
-                                 help =  wfill ["The identifier" , getName @attr ,"has been declared"
-                                               ,"as an inherited (or chained) attribute for nonterminal"
-                                               ,getName @nt , "more than once, with possibly different types."
-                                               ,"Delete all but one or rename them to make them unique."
-                                               ]
-                                 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 @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose
-
-  | DupSynAttr      lhs.pp = let mesg  = wfill ["Repeated declaration of synthesized attribute", getName @attr
-                                               , "of nonterminal", getName @nt, "."
-                                               ] >-<
-                                         wfill ["First definition:", (showPos @occ1),"."] >-<
-                                         wfill ["Other definition:", (showPos @attr),"."]
-                                 pat  = "ATTR" >#< getName @nt >#< "[ | |" >#< getName @attr >|< ":...,"
-                                                                   >#< getName @attr >|< ":... ]"
-
-                                 help =  wfill ["The identifier" , getName @attr ,"has been declared"
-                                               ,"as a synthesized (or chained) attribute for nonterminal"
-                                               ,getName @nt , "more than once, with possibly different types."
-                                               ,"Delete all but one or rename them to make them unique."
-                                               ]
-                                 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 @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose
-
-  | DupChild        lhs.pp = let mesg  = wfill ["Repeated declaration for field", getName @name, "of alternative"
-                                               ,getName @con, "of nonterminal", getName @nt, "."
-                                               ] >-<
-                                         wfill ["First definition:", (showPos @occ1),"."] >-<
-                                         wfill ["Other definition:", (showPos @name),"."]
-                                 pat   =   "DATA" >#< getName @nt
-                                       >-< indent 2 ("|" >#< getName @con >#< (getName @name >|< ":..." >-< getName @name >|< ":..."))
-
-
-                                 help =  wfill ["The alternative" ,getName @con , "of nonterminal" ,getName @nt
-                                               ,"has more than one field that is named"
-                                               , getName @name ++ ". Possibly they have different types."
-                                               ,"You should either rename or remove enough of them to make all fields of"
-                                               ,getName @con , "for nonterminal " , getName @nt , "uniquely named."
-                                               ]
-                                 act  = wfill ["The last declaration with its corresponding type is considered valid."
-                                              ,"All others have been discarded."
-                                              ]
-                             in ppError (isError @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose
-
-  | DupRule         lhs.pp = let mesg  = wfill ["At constructor",getName @con, "of nonterminal", getName @nt, "there are two or more rules for"
-                                               ,showAttrDef @field @attr,"."
-                                               ]  >-<
-                                         wfill ["First rule:", (showPos @occ1),"."] >-<
-                                         wfill ["Other rule:", (showPos @attr),"."]
-
-                                 pat   =   "SEM" >#< getName @nt
-                                       >-< indent 2 ("|" >#< getName @con >#< ppAttr @field @attr >#< "= ...")
-                                       >-< indent 2 ("|" >#< getName @con >#< ppAttr @field @attr >#< "= ...")
-
-                                 help =  wfill ["In the rules for alternative" , getName @con , "of nonterminal" , getName @nt
-                                                       ,", there is more than one rule for the" , showAttrDef @field @attr
-                                                       ,". You should either rename or remove enough of them to make all rules for alternative"
-                                                       ,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 @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose
-
-  | DupRuleName     lhs.pp = let mesg  = wfill ["At constructor",getName @con, "of nonterminal", getName @nt, "there are two or more rule names for"
-                                               ,show @nm,"."
-                                               ]
-
-                                 pat   =   "SEM" >#< getName @nt
-                                       >-< indent 2 ("|" >#< getName @con >#< show @nm >#< ": ... = ...")
-                                       >-< indent 2 ("|" >#< getName @con >#< show @nm >#< ": ... = ...")
-
-                                 help =  wfill ["In the rules for alternative" , getName @con , "of nonterminal" , getName @nt
-                                                       ,", there is more than one rule name " , show @nm
-                                                       ,". You should either rename or remove enough of them."
-                                                       ]
-                                 act  = wfill ["Compilation cannot continue."]
-                             in ppError (isError @lhs.options @me) (getPos @nm) mesg pat help act @lhs.verbose
-
-  | DupSig          lhs.pp = let mesg  = wfill ["At constructor",getName @con, "of nonterminal", getName @nt, "there are two or more typesignatures for"
-                                               ,showAttrDef _LOC @attr,"."
-                                               ]  >-<
-                                         wfill ["First signature:", (showPos @attr),"."]
-
-                                 pat   =   "SEM" >#< getName @nt
-                                       >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< "= ...")
-                                       >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< "= ...")
-
-                                 help =  wfill ["In the rules for alternative" , getName @con , "of nonterminal" , getName @nt
-                                                       ,", there is more than one rule for the" , showAttrDef _LOC @attr
-                                                       ,". You should remove enough of them to make all typesignatures for alternative"
-                                                       ,getName @con , "of nonterminal " ,getName  @nt , "unique."
-                                                       ]
-                                 act  = wfill ["The last typesignature given is considered valid. All others have been discarded."]
-                             in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose
-
-  | UndefNont       lhs.pp = let mesg  = wfill ["Nonterminal", getName @nt, "is not defined."
-                                               ]
-                                 pat   = "DATA" >#< getName @nt >#< "..."
-
-                                 help =  wfill ["There are attributes and/or rules for nonterminal" , getName @nt  ,", but there is no definition"
-                                                       , "for" ,getName  @nt, ". Maybe you misspelled it? Otherwise insert a definition."
-                                                       ]
-                                 act  = wfill ["Everything regarding the unknown nonterminal has been ignored."]
-                             in ppError (isError @lhs.options @me) (getPos @nt) mesg pat help act @lhs.verbose
-
-  | UndefAlt        lhs.pp = let mesg  = wfill ["Constructor", getName @con, "of nonterminal" ,getName @nt, "is  not defined."
-                                               ]
-                                 pat   =   "DATA" >#< getName @nt
-                                       >-< indent 2 ("|" >#< getName @con >#< "...")
-
-                                 help =  wfill ["There are rules for alternative", getName @con , "of nonterminal" ,getName @nt
-                                                       ,", but there is no definition for this alternative in the definitions of the"
-                                                       ,"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 @lhs.options @me) (getPos @con) mesg pat help act @lhs.verbose
-
-  | UndefChild      lhs.pp = let mesg  = wfill ["Constructor", getName @con, "of nonterminal" ,getName @nt
-                                               , "does not have a nontrivial field named", getName @name , "."
-                                               ]
-                                 pat   =   "SEM" >#< @nt
-                                       >-< indent 2 ("|" >#< getName @con >#< ppAttr @name (identifier "<attr>") >#< "= ...")
-
-                                 help =  wfill ["There are rules that define or use attributes of field" , getName @name
-                                                       ,"in alternative" , getName @con , "of nonterminal" , getName @nt
-                                                       ,", but there is no field with AG-type in the definition of the alternative."
-                                                       ,"Maybe you misspelled it? Otherwise insert the field into the definition,"
-                                                       ,"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 @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose
-
-  | MissingRule     lhs.pp = let mesg  = wfill ["Missing rule for", showAttrDef @field @attr , "in alternative"
-                                               , getName @con , "of nonterminal",getName @nt ,"."
-                                               ]
-                                 pat   =   "SEM" >#< @nt
-                                       >-< indent 2 ("|" >#< getName @con >#< ppAttr @field @attr >#< "= ...")
-
-                                 help  = wfill ["The", showAttrDef @field @attr, "in alternative", getName @con
-                                               , "of nonterminal", getName @nt, "is missing and cannot be inferred"
-                                               ,"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 @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose
-
-  | MissingNamedRule  lhs.pp =  let mesg  = wfill ["Missing rule name ", show @name , "in alternative"
-                                                  , getName @con , "of nonterminal",getName @nt ,"."
-                                                  ]
-                                    pat   =   "SEM" >#< @nt
-                                          >-< indent 2 ("|" >#< getName @con >#< show @name >#< ": ... = ...")
-
-                                    help  = wfill ["There is a dependency on a rule with name ", show @name , "in alternative"
-                                                  , getName @con , "of nonterminal",getName @nt ,", but no rule has been defined with this name. Maybe you misspelled it?"
-                                                  ]
-                                    act  = wfill ["Compilation cannot continue."]
-                                in ppError (isError @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose
-
-  | SuperfluousRule lhs.pp = let mesg  = wfill ["Rule for non-existing", showAttrDef @field @attr , "at alternative"
-                                               , getName @con , "of nonterminal",getName @nt, "."
-                                               ]
-                                 pat   =   "SEM" >#< getName @nt
-                                       >-< indent 2 ("|" >#< getName @con >#< ppAttr @field @attr >#< "= ...")
-
-
-                                 help =  wfill ["There is a rule for" , showAttrDef @field @attr , "in the definitions for alternative" , getName @con
-                                               ,"of nonterminal" , getName @nt,  ", but this attribute does not exist. Maybe you misspelled it?"
-                                               ,"Otherwise either remove the rule or add an appropriate attribute definition."
-                                               ]
-                                 act  = wfill ["The rule has been ignored."]
-                             in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose
-
-  | UndefLocal      lhs.pp = let mesg  = wfill ["Undefined local variable or field",getName @var, "at constructor"
-                                               , getName @con , "of nonterminal",getName @nt, "."
-                                               ]
-                                 pat   = "SEM" >#< getName @nt
-                                       >-< indent 2 ("|" >#< getName @con >#< "<field>.<attr> = "
-                                                         >#< "..." >#< "@" >|< 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. "
-                                               ,"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 @lhs.options @me) (getPos @var) mesg pat help act @lhs.verbose
-
-  | ChildAsLocal    lhs.pp = let mesg  = wfill ["Nontrivial field ",getName @var, "is used as local at constructor"
-                                               , getName @con , "of nonterminal",getName @nt, "."
-                                               ]
-                                 pat   = "SEM" >#< getName @nt
-                                       >-< indent 2 ("|" >#< getName @con >#< "... = "
-                                                         >#< "..." >#< "@" >|< getName @var >#< "..." )
-
-                                 help =  wfill ["A rule in the definitions for alternative" , getName @con ,"of nonterminal"
-                                               , getName @nt , "contains a nontrivial field name", getName @var, "."
-                                               ,"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 @lhs.options @me) (getPos @var) mesg pat help act @lhs.verbose
-
-  | UndefAttr       lhs.pp = 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
-                                       >-< indent 2 ("|" >#< getName @con >#< "<field>.<attr> = "
-                                                         >#< "..." >#< ppAttrUse @field @attr >#< "...")
-
-                                 help =  wfill ["A rule in the definitions for alternative" , getName @con ,"of nonterminal"
-                                               ,getName  @nt , "contains an attribute that is not defined"
-                                               ,"Maybe you misspelled it?"
-                                               ,"Otherwise either remove the rule or add an appropriate attribute definition."
-                                               ]
-                                 act  = wfill ["The generated program will not run."]
-                             in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose
-
-  | CyclicSet       lhs.pp = let mesg  = wfill ["Cyclic definition for nonterminal set", getName @name]
-                                 pat   = "SET" >#< getName @name >#< "=" >#< "..." >#< getName @name >#< "..."
-                                 help =  wfill ["The defintion for a nonterminal set named" , getName @name
-                                               ,"directly or indirectly refers to itself."
-                                               ,"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 @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose
-
-  | Cyclic          lhs.pp = let pos  = getPos @nt
-                                 mesg = text "Circular dependency for nonterminal" >#< getName @nt
-                                        >#< ( case @mbCon of
-                                                Nothing  -> empty
-                                                Just con -> text "and constructor" >#< con
-                                            )
-                                        >#< ( case @verts of
-                                                  v : _ -> text "including vertex" >#< text v
-                                                  _     -> empty
-                                            )
-                                 pat  = text "cyclic rule definition"
-                                 help = hlist (text "The following attributes are all cyclic: " : map text @verts)
-                                 act  = wfill ["code cannot be generated until the cycle is removed."]
-                             in ppError (isError @lhs.options @me) pos mesg pat help act False
-
-  | CustomError     lhs.pp = let pat   =  text "unknown"
-                                 help = wfill ["not available."]
-                                 act  = wfill ["unknown"]
-                             in ppError (isError @lhs.options @me) @pos @mesg pat help act False
-
-  | LocalCirc       lhs.pp = let mesg  = wfill ["Circular dependency for local attribute", getName @attr
-                                               , "of alternative", getName @con, "of nonterminal", getName @nt]
-                                 pat   = "SEM" >#< getName @nt
-                                         >-< indent 2 ("|" >#< getName @con >#< "loc." >|< getName @attr >#< "="
-                                                           >#< "..." >#< "@loc." >|< getName @attr >#< "...")
-                                 help  = if null @path
-                                         then text "the definition is directly circular"
-                                         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 @lhs.options @me) (getPos (@attr)) mesg pat help act @lhs.verbose
-
-  | InstCirc        lhs.pp = let mesg  = wfill ["Circular dependency for inst attribute", getName @attr
-                                               , "of alternative", getName @con, "of nonterminal", getName @nt]
-                                 pat   = "SEM" >#< getName @nt
-                                         >-< indent 2 ("|" >#< getName @con >#< "inst." >|< getName @attr >#< "="
-                                                           >#< "..." >#< "@s.<some attribte>" >#< "...")
-                                 help  = if null @path
-                                         then text "the definition is directly circular"
-                                         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 @lhs.options @me) (getPos (@attr)) mesg pat help act @lhs.verbose
-
-  | DirectCirc      lhs.pp = let mesg  = wfill ["In nonterminal", getName @nt, "synthesized and inherited attributes are mutually dependent" ]
-                                         >-< vlist (map showEdge @cyclic)
-                                 pat   = text ""
-                                 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 @lhs.options @me) noPos mesg pat help act @lhs.verbose
-
-  | InducedCirc     lhs.pp = let mesg  = wfill ["After scheduling, in nonterminal", getName @nt, "synthesized and inherited attributes have an INDUCED mutual dependency" ]
-                                         >-< vlist (map showEdge @cyclic)
-                                 pat   = text ""
-                                 showInter (CInterface segs) = concat (snd (mapAccumL (\i c -> (succ i :: Integer,("visit " ++ show i) : map ind (showsSegment c))) 0 segs))
-                                 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 @lhs.options @me) noPos mesg pat help act @lhs.verbose
-
-  | MissingTypeSig  lhs.pp = let mesg = wfill ["Type signature needed, but not found for", showAttrDef _LOC @attr , "in alternative"
-                                               , getName @con , "of nonterminal",getName @nt ,"."
-                                               ]>-<
-                                         wfill ["Location:", (showPos @attr),"."]
-                                 pat   =   "SEM" >#< @nt
-                                       >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< ": ...")
-                                 help  = wfill ["The", showAttrDef _LOC @attr, "in alternative", getName @con
-                                               ,"of nonterminal", getName @nt, "is needed in two separate visits to", getName @nt
-                                               ,"so its type is needed to generate type signatures."
-                                               ,"Please supply its type."
-                                               ]
-                                 act  = wfill ["The type signatures of semantic functions are not generated."]
-                             in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose
-
-  | MissingInstSig  lhs.pp = let mesg = wfill ["Type signature needed, but not found for", showAttrDef _INST @attr , "in alternative"
-                                               , getName @con , "of nonterminal",getName @nt ,"."
-                                               ]>-<
-                                         wfill ["Location:", (showPos @attr),"."]
-                                 pat   = "SEM" >#< @nt
-                                           >-< indent 2 ("|" >#< getName @con >#< ppAttr _INST @attr >#< ": ...")
-                                 help  = wfill ["The", showAttrDef _INST @attr, "in alternative", getName @con
-                                               ,"of nonterminal", getName @nt, "is a non-terminal attribute, so "
-                                               ,"its type is needed to attribute its value."
-                                               ,"Please supply its type."
-                                               ]
-                                 act  = wfill ["It is not possible to proceed without this signature."]
-                             in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose
-
-  | MissingUnique   lhs.pp = let mesg  = wfill ["Missing unique counter (chained attribute)"
-                                               , getName @attr
-                                               , "at nonterminal"
-                                               , getName @nt, "."
-                                               ]
-                                 pat   = "ATTR" >#< getName @nt >#< "[ |" >#< getName @attr >#< " : ... | ]"
-
-                                 help =  wfill ["A unique attribute signature in a constructor for nonterminal" , getName @nt
-                                               , "refers to an unique counter (chained attribute) named "
-                                               , getName @attr
-                                               ,"Maybe you misspelled it?"
-                                               ,"Otherwise either remove the signature or add an appropriate attribute definition."
-                                               ]
-                                 act  = wfill ["It is not possible to proceed without this declaration."]
-                             in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose
-
-  | DupUnique       lhs.pp = let mesg  = wfill ["At constructor",getName @con, "of nonterminal", getName @nt, "there are two or more unique-attribute signatures for"
-                                               ,showAttrDef _LOC @attr,"."
-                                               ]  >-<
-                                         wfill ["First signature:", (showPos @attr),"."]
-
-                                 pat   =   "SEM" >#< getName @nt
-                                       >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< " : UNIQUEREF ...")
-                                       >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< " : UNIQUEREF ...")
-
-                                 help =  wfill ["In the rules for alternative" , getName @con , "of nonterminal" , getName @nt
-                                                       ,", there is more than one unique-attribute signature for the" , showAttrDef _LOC @attr
-                                                       ,". You should remove enough of them to make all unique-signatures for alternative"
-                                                       ,getName @con , "of nonterminal " ,getName  @nt , "unique."
-                                                       ]
-                                 act  = wfill ["Unpredicatable sharing of unique numbers may occur."]
-                             in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose
-
- | MissingSyn      lhs.pp = let mesg  = wfill ["Missing synthesized attribute"
-                                              , getName @attr
-                                              , "at nonterminal"
-                                              , getName @nt, "."
-                                              ]
-                                pat   = "ATTR" >#< getName @nt >#< "[ | | " >#< getName @attr >#< " : ... ]"
-
-                                help =  wfill ["An augment rule for a constructor for nonterminal" , getName @nt
-                                              , "refers to a synthesized attribute named "
-                                              , getName @attr
-                                              ,"Maybe you misspelled it?"
-                                              ,"Otherwise add an appropriate attribute definition."
-                                              ]
-                                act  = wfill ["It is not possible to proceed without this declaration."]
-                            in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose
-  | IncompatibleVisitKind
-                   lhs.pp = let mesg  = "visit" >#< @vis >#< "of child" >#< @child >#< " with kind" >#< show @to >#< " cannot be called from a visit with kind " >#< show @from
-                                pat   = empty
-                                help  = empty
-                                act   = text "It is not possible to proceed without fixing this kind error."
-                            in ppError (isError @lhs.options @me) (getPos @child) mesg pat help act @lhs.verbose
-  | IncompatibleRuleKind
-                   lhs.pp = let mesg  = "rule" >#< @rule >#< "cannot be called from a visit with kind " >#< show @kind
-                                pat   = empty
-                                help  = empty
-                                act   = text "It is not possible to proceed without fixing this kind error."
-                            in ppError (isError @lhs.options @me) (getPos @rule) mesg pat help act @lhs.verbose
-
-  | IncompatibleAttachKind
-                   lhs.pp = let mesg  = "child" >#< @child >#< "cannot be called from a visit with kind " >#< show @kind
-                                pat   = empty
-                                help  = empty
-                                act   = text "It is not possible to proceed without fixing this kind error."
-                            in ppError (isError @lhs.options @me) (getPos @child) mesg pat help act @lhs.verbose
-
-{
-toWidth :: Int -> String -> String
-toWidth n xs | k<n       = xs ++ replicate (n-k) ' '
-             | otherwise = xs
-               where k = length xs
-
-showEdge :: ((Identifier,Identifier),[String],[String]) -> PP_Doc
-showEdge ((inh,syn),_,_)
-  = text ("inherited attribute " ++ toWidth 20 (getName inh) ++ " with synthesized attribute " ++  getName syn)
-
-showEdgeLong :: ((Identifier,Identifier),[String],[String]) -> PP_Doc
-showEdgeLong ((inh,syn),path1,path2)
-  = text ("inherited attribute " ++ getName inh ++ " is needed for " ++  "synthesized attribute " ++ getName syn)
-    >-< indent 4 (vlist (map text path2))
-    >-< text "and back: "
-    >-< indent 4 (vlist (map text path1))
-
-attrText :: Identifier -> Identifier -> String
-attrText inh syn
- =  if   inh == syn
-    then "threaded attribute " ++ getName inh
-    else "inherited attribute " ++ getName inh ++ " and synthesized attribute " ++getName syn
-
-showLineNr :: Int -> String
-showLineNr i | i==(-1) = "CR"
-             | otherwise = show i
-
-showAttrDef :: Identifier -> Identifier -> String
-showAttrDef f a | f == _LHS  = "synthesized attribute " ++ getName a
-                | f == _LOC  = "local attribute " ++ getName a
-                | f == _INST = "inst attribute " ++ getName a
-                | otherwise  = "inherited attribute " ++ getName a ++ " of field " ++ getName f
-
-showAttrUse :: Identifier -> Identifier -> String
-showAttrUse f a | f == _LHS  = "inherited attribute " ++ getName a
-                | f == _LOC  = "local attribute " ++ getName a
-                | f == _INST = "inst attribute " ++ getName a
-                | otherwise  = "synthesized attribute " ++ getName a ++ " of field " ++ getName f
-
-ppAttr :: Identifier -> Identifier -> PP_Doc
-ppAttr f a = text (getName f++"."++getName a)
-ppAttrUse :: Identifier -> Identifier -> PP_Doc
-ppAttrUse f a = "@" >|< ppAttr f a
-}
--- Printing of error messages
-
-{
-infixr 5 +#+
-(+#+) :: String -> String -> String
-(+#+) s t = s ++ " " ++ t
-
-infixr 5 +.+
-(+.+) :: Identifier -> Identifier -> String
-(+.+) s t = getName s ++ "." ++ getName t
-
-wfill :: [String] -> PP_Doc
-wfill = fill . addSpaces. concat . map words
-  where addSpaces (x:xs) = x:map addSpace xs
-        addSpaces []     = []
-        addSpace  [x]    | x `elem` ".,;:!?" = [x]
-        addSpace  xs     = ' ':xs
-
-ppError :: Bool           -- class of the error, True:error False:warning
-        -> Pos      -- source position
-        -> PP_Doc         -- error message
-        -> PP_Doc         -- pattern
-        -> PP_Doc         -- help, more info
-        -> PP_Doc         -- action taken by AG
-        -> Bool           -- verbose? show help and action?
-        -> PP_Doc
-ppError isErr pos mesg pat hlp act verb
-  = let position = case pos of
-                     Pos l c f | l >= 0    -> f >|< ":" >|< show l >|< ":" >|< show c
-                               | otherwise -> pp "uuagc"
-        tp      = if isErr then "error" else "warning"
-        header  = position >|< ":" >#< tp >|< ":" >#< mesg
-        pattern = "pattern  :" >#< pat
-        help    = "help     :" >#< hlp
-        action  = "action   :" >#< act
-    in if verb
-         then vlist [text "",header,pattern,help,action]
-         else header
-
-{-
--- old error reporting code
-  = let
-      cl = if isError then "ERROR" else "Warning"
-      position   = case pos of
-                         (Pos l c f) | l >= 0    -> f >|< ": line " >|< show l >|< ", column " >|< show c
-                                     | otherwise -> empty
-      header     = "*** UU.AG" >#< cl >#< position >#< "***"
-      message    = "problem  :" >#< mesg
-      pattern    = "pattern  :" >#< pat
-      help       = "help     :" >#< hlp
-      action     = "action   :" >#< act
-    in
-      if verbose
-         then vlist [text "",header,message,pattern,help,action]
-         else vlist [text "",header,message]
--}
-
-showPos :: Identifier -> String
-showPos = show . getPos
-
-ppInterface :: Show a => a -> PP_Doc
-ppInterface inter = wfill ["interface:", show inter]
-
-}
-
+INCLUDE "ErrorMessages.ag"++imports+{+import UU.Scanner.Position(Pos(..), noPos)+import ErrorMessages+import Data.List(mapAccumL)+import GrammarInfo+import qualified Control.Monad.Error.Class as Err+}+++{+instance Err.Error Error where+  noMsg  = Err.strMsg "error"+  strMsg = CustomError False noPos . pp+}+++{+isError :: Options -> 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          _ _ _    ) = False+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 opts (LocalCirc       _ _ _ _ _) = cycleIsDangerous opts+isError opts (InstCirc        _ _ _ _ _) = cycleIsDangerous opts+isError opts (DirectCirc      _ _ _    ) = cycleIsDangerous opts+isError opts (InducedCirc     _ _ _    ) = cycleIsDangerous opts+isError _ (MissingTypeSig  _ _ _    ) = False+isError _ (MissingInstSig  _ _ _    ) = True+isError _ (DupUnique       _ _ _    ) = False+isError _ (MissingUnique   _ _      ) = True+isError _ (MissingSyn      _ _      ) = True+isError _ (MissingNamedRule _ _ _)    = True+isError _ (DupRuleName _ _ _)         = True+isError _ (HsParseError _ _)          = True+isError _ (Cyclic _ _ _)              = True+isError _ (IncompatibleVisitKind _ _ _ _) = True+isError _ (IncompatibleRuleKind _ _)      = True+isError _ (IncompatibleAttachKind _ _)    = True++cycleIsDangerous :: Options -> Bool+cycleIsDangerous opts+  = any ($ opts) [ wignore, bangpats, cases, strictCases, stricterCases, strictSems, withCycle ]+}+++++++ATTR Error   [ options:{Options} verbose:{Bool}    | | pp           :{PP_Doc}+                                     me                             :SELF+             ]++ATTR Errors  [ options:{Options}  dups : {[String]} | | pp         USE {>-<} {text ""} : {PP_Doc}+             ]++SEM Errors+  | *  loc.verbose = verbose @lhs.options+  | Cons  loc.str = disp @hd.pp 5000 ""++          lhs.pp = if @loc.str `elem` @lhs.dups+                   then @tl.pp+                   else @hd.pp >-< @tl.pp+          tl.dups = @loc.str : @lhs.dups+  | Nil   lhs.pp = text ""+++SEM Error+  | ParserError     lhs.pp = let mesg = text ("parser expecting " ++ @problem)+                                 pat  = text ""+                                 help = text ""+                                 act  = text @action+                              in ppError (isError @lhs.options @me) @pos mesg pat help act @lhs.verbose++  | HsParseError    lhs.pp = ppError True @pos (text @msg) (text "") (text "") (text "Correct the syntax of the Haskell code.") @lhs.verbose++  | DupAlt          lhs.pp = let mesg  = wfill ["Repeated definition for alternative", getName @con+                                               ,"of nonterminal", getName @nt, "."+                                               ] >-<+                                         wfill ["First definition:", (showPos @occ1),"."] >-<+                                         wfill ["Other definition:", (showPos @con),"."]+                                 pat =     "DATA" >#< getName @nt+                                       >-< indent 2 ("|" >#< getName @con >#< "...")+                                       >-< indent 2 ("|" >#< getName @con >#< "...")++                                 help =  wfill ["The nonterminal",getName @nt,"has more than one alternative that"+                                               ,"is labelled with the constructor name",getName @con,"."+                                               ,"You should either rename or remove enough of them to make all"+                                               ,"constructors of",getName @nt,"uniquely named."+                                               ]++                                 act  = wfill [ "The first alternative of name",getName @con+                                              ,"you have given for nonterminal",getName @nt+                                              ,"is considered valid. All other alternatives have been discarded."+                                              ]++                             in ppError (isError @lhs.options @me) (getPos @con) mesg pat help act @lhs.verbose++  | DupSynonym      lhs.pp = let mesg  = wfill ["Definition of type synonym", getName @nt, "clashes with another"+                                               ,"type synonym."+                                               ] >-<+                                         wfill ["First definition:", (showPos @occ1),"."] >-<+                                         wfill ["Type synonym :"   , (showPos @nt),"."]+                                 pat =     "DATA" >#< getName @nt+                                       >-< indent 2 ("|" >#< "...")+                                       >-< "TYPE" >#< getName @nt >#< "=" >#<  "..."+                                 help =  wfill ["A type synonym with name", getName  @nt+                                               ,"has been given while there already is TYPE"+                                               ,"definition with the same name."+                                               ,"You should either rename or remove the type synonym."+                                               ]+                                 act  = wfill [ "The clashing type synonym will be ignored."+                                              ]+                             in ppError (isError @lhs.options @me)  (getPos @nt) mesg pat help act @lhs.verbose++  | DupSet          lhs.pp = let mesg  = wfill ["Definition of nonterminal set", getName @name, "clashes with another"+                                               ,"set, a type synonym or a data definition."+                                               ] >-<+                                         wfill ["First definition:", (showPos @occ1),"."] >-<+                                         wfill ["Set definition:"   , (showPos @name),"."]+                                 pat =     "SET" >#< getName @name >#< "=" >#<  "..."+                                       >-< "SET" >#< getName @name >#< "=" >#<  "..."+                                 help =  wfill ["A nonterminal set with name", getName  @name+                                               ,"has been given while there already is a SET, DATA, or TYPE"+                                               ,"definition with the same name."+                                               ,"You should either rename or remove the nonterminal set."+                                               ]+                                 act  = wfill [ "The clashing nonterminal set will be ignored."+                                              ]+                             in ppError (isError @lhs.options @me)  (getPos @name) mesg pat help act @lhs.verbose++  | DupInhAttr      lhs.pp = let mesg  = wfill ["Repeated declaration of inherited attribute", getName @attr+                                               , "of nonterminal", getName @nt, "."+                                               ] >-<+                                         wfill ["First definition:", (showPos @occ1),"."] >-<+                                         wfill ["Other definition:", (showPos @attr),"."]+                                 pat  = "ATTR" >#< getName @nt >#< "[" >#< getName @attr >|< ":...,"+                                                               >#< getName @attr >|< ":... | | ]"++                                 help =  wfill ["The identifier" , getName @attr ,"has been declared"+                                               ,"as an inherited (or chained) attribute for nonterminal"+                                               ,getName @nt , "more than once, with possibly different types."+                                               ,"Delete all but one or rename them to make them unique."+                                               ]+                                 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 @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose++  | DupSynAttr      lhs.pp = let mesg  = wfill ["Repeated declaration of synthesized attribute", getName @attr+                                               , "of nonterminal", getName @nt, "."+                                               ] >-<+                                         wfill ["First definition:", (showPos @occ1),"."] >-<+                                         wfill ["Other definition:", (showPos @attr),"."]+                                 pat  = "ATTR" >#< getName @nt >#< "[ | |" >#< getName @attr >|< ":...,"+                                                                   >#< getName @attr >|< ":... ]"++                                 help =  wfill ["The identifier" , getName @attr ,"has been declared"+                                               ,"as a synthesized (or chained) attribute for nonterminal"+                                               ,getName @nt , "more than once, with possibly different types."+                                               ,"Delete all but one or rename them to make them unique."+                                               ]+                                 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 @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose++  | DupChild        lhs.pp = let mesg  = wfill ["Repeated declaration for field", getName @name, "of alternative"+                                               ,getName @con, "of nonterminal", getName @nt, "."+                                               ] >-<+                                         wfill ["First definition:", (showPos @occ1),"."] >-<+                                         wfill ["Other definition:", (showPos @name),"."]+                                 pat   =   "DATA" >#< getName @nt+                                       >-< indent 2 ("|" >#< getName @con >#< (getName @name >|< ":..." >-< getName @name >|< ":..."))+++                                 help =  wfill ["The alternative" ,getName @con , "of nonterminal" ,getName @nt+                                               ,"has more than one field that is named"+                                               , getName @name ++ ". Possibly they have different types."+                                               ,"You should either rename or remove enough of them to make all fields of"+                                               ,getName @con , "for nonterminal " , getName @nt , "uniquely named."+                                               ]+                                 act  = wfill ["The last declaration with its corresponding type is considered valid."+                                              ,"All others have been discarded."+                                              ]+                             in ppError (isError @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose++  | DupRule         lhs.pp = let mesg  = wfill ["At constructor",getName @con, "of nonterminal", getName @nt, "there are two or more rules for"+                                               ,showAttrDef @field @attr,"."+                                               ]  >-<+                                         wfill ["First rule:", (showPos @occ1),"."] >-<+                                         wfill ["Other rule:", (showPos @attr),"."]++                                 pat   =   "SEM" >#< getName @nt+                                       >-< indent 2 ("|" >#< getName @con >#< ppAttr @field @attr >#< "= ...")+                                       >-< indent 2 ("|" >#< getName @con >#< ppAttr @field @attr >#< "= ...")++                                 help =  wfill ["In the rules for alternative" , getName @con , "of nonterminal" , getName @nt+                                                       ,", there is more than one rule for the" , showAttrDef @field @attr+                                                       ,". You should either rename or remove enough of them to make all rules for alternative"+                                                       ,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 @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose++  | DupRuleName     lhs.pp = let mesg  = wfill ["At constructor",getName @con, "of nonterminal", getName @nt, "there are two or more rule names for"+                                               ,show @nm,"."+                                               ]++                                 pat   =   "SEM" >#< getName @nt+                                       >-< indent 2 ("|" >#< getName @con >#< show @nm >#< ": ... = ...")+                                       >-< indent 2 ("|" >#< getName @con >#< show @nm >#< ": ... = ...")++                                 help =  wfill ["In the rules for alternative" , getName @con , "of nonterminal" , getName @nt+                                                       ,", there is more than one rule name " , show @nm+                                                       ,". You should either rename or remove enough of them."+                                                       ]+                                 act  = wfill ["Compilation cannot continue."]+                             in ppError (isError @lhs.options @me) (getPos @nm) mesg pat help act @lhs.verbose++  | DupSig          lhs.pp = let mesg  = wfill ["At constructor",getName @con, "of nonterminal", getName @nt, "there are two or more typesignatures for"+                                               ,showAttrDef _LOC @attr,"."+                                               ]  >-<+                                         wfill ["First signature:", (showPos @attr),"."]++                                 pat   =   "SEM" >#< getName @nt+                                       >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< "= ...")+                                       >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< "= ...")++                                 help =  wfill ["In the rules for alternative" , getName @con , "of nonterminal" , getName @nt+                                                       ,", there is more than one rule for the" , showAttrDef _LOC @attr+                                                       ,". You should remove enough of them to make all typesignatures for alternative"+                                                       ,getName @con , "of nonterminal " ,getName  @nt , "unique."+                                                       ]+                                 act  = wfill ["The last typesignature given is considered valid. All others have been discarded."]+                             in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose++  | UndefNont       lhs.pp = let mesg  = wfill ["Nonterminal", getName @nt, "is not defined."+                                               ]+                                 pat   = "DATA" >#< getName @nt >#< "..."++                                 help =  wfill ["There are attributes and/or rules for nonterminal" , getName @nt  ,", but there is no definition"+                                                       , "for" ,getName  @nt, ". Maybe you misspelled it? Otherwise insert a definition."+                                                       ]+                                 act  = wfill ["Everything regarding the unknown nonterminal has been ignored."]+                             in ppError (isError @lhs.options @me) (getPos @nt) mesg pat help act @lhs.verbose++  | UndefAlt        lhs.pp = let mesg  = wfill ["Constructor", getName @con, "of nonterminal" ,getName @nt, "is  not defined."+                                               ]+                                 pat   =   "DATA" >#< getName @nt+                                       >-< indent 2 ("|" >#< getName @con >#< "...")++                                 help =  wfill ["There are rules for alternative", getName @con , "of nonterminal" ,getName @nt+                                                       ,", but there is no definition for this alternative in the definitions of the"+                                                       ,"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 @lhs.options @me) (getPos @con) mesg pat help act @lhs.verbose++  | UndefChild      lhs.pp = let mesg  = wfill ["Constructor", getName @con, "of nonterminal" ,getName @nt+                                               , "does not have a nontrivial field named", getName @name , "."+                                               ]+                                 pat   =   "SEM" >#< @nt+                                       >-< indent 2 ("|" >#< getName @con >#< ppAttr @name (identifier "<attr>") >#< "= ...")++                                 help =  wfill ["There are rules that define or use attributes of field" , getName @name+                                                       ,"in alternative" , getName @con , "of nonterminal" , getName @nt+                                                       ,", but there is no field with AG-type in the definition of the alternative."+                                                       ,"Maybe you misspelled it? Otherwise insert the field into the definition,"+                                                       ,"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 @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose++  | MissingRule     lhs.pp = let mesg  = wfill ["Missing rule for", showAttrDef @field @attr , "in alternative"+                                               , getName @con , "of nonterminal",getName @nt ,"."+                                               ]+                                 pat   =   "SEM" >#< @nt+                                       >-< indent 2 ("|" >#< getName @con >#< ppAttr @field @attr >#< "= ...")++                                 help  = wfill ["The", showAttrDef @field @attr, "in alternative", getName @con+                                               , "of nonterminal", getName @nt, "is missing and cannot be inferred"+                                               ,"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 @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose++  | MissingNamedRule  lhs.pp =  let mesg  = wfill ["Missing rule name ", show @name , "in alternative"+                                                  , getName @con , "of nonterminal",getName @nt ,"."+                                                  ]+                                    pat   =   "SEM" >#< @nt+                                          >-< indent 2 ("|" >#< getName @con >#< show @name >#< ": ... = ...")++                                    help  = wfill ["There is a dependency on a rule with name ", show @name , "in alternative"+                                                  , getName @con , "of nonterminal",getName @nt ,", but no rule has been defined with this name. Maybe you misspelled it?"+                                                  ]+                                    act  = wfill ["Compilation cannot continue."]+                                in ppError (isError @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose++  | SuperfluousRule lhs.pp = let mesg  = wfill ["Rule for non-existing", showAttrDef @field @attr , "at alternative"+                                               , getName @con , "of nonterminal",getName @nt, "."+                                               ]+                                 pat   =   "SEM" >#< getName @nt+                                       >-< indent 2 ("|" >#< getName @con >#< ppAttr @field @attr >#< "= ...")+++                                 help =  wfill ["There is a rule for" , showAttrDef @field @attr , "in the definitions for alternative" , getName @con+                                               ,"of nonterminal" , getName @nt,  ", but this attribute does not exist. Maybe you misspelled it?"+                                               ,"Otherwise either remove the rule or add an appropriate attribute definition."+                                               ]+                                 act  = wfill ["The rule has been ignored."]+                             in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose++  | UndefLocal      lhs.pp = let mesg  = wfill ["Undefined local variable or field",getName @var, "at constructor"+                                               , getName @con , "of nonterminal",getName @nt, "."+                                               ]+                                 pat   = "SEM" >#< getName @nt+                                       >-< indent 2 ("|" >#< getName @con >#< "<field>.<attr> = "+                                                         >#< "..." >#< "@" >|< 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. "+                                               ,"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 @lhs.options @me) (getPos @var) mesg pat help act @lhs.verbose++  | ChildAsLocal    lhs.pp = let mesg  = wfill ["Nontrivial field ",getName @var, "is used as local at constructor"+                                               , getName @con , "of nonterminal",getName @nt, "."+                                               ]+                                 pat   = "SEM" >#< getName @nt+                                       >-< indent 2 ("|" >#< getName @con >#< "... = "+                                                         >#< "..." >#< "@" >|< getName @var >#< "..." )++                                 help =  wfill ["A rule in the definitions for alternative" , getName @con ,"of nonterminal"+                                               , getName @nt , "contains a nontrivial field name", getName @var, "."+                                               ,"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 @lhs.options @me) (getPos @var) mesg pat help act @lhs.verbose++  | UndefAttr       lhs.pp = 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+                                       >-< indent 2 ("|" >#< getName @con >#< "<field>.<attr> = "+                                                         >#< "..." >#< ppAttrUse @field @attr >#< "...")++                                 help =  wfill ["A rule in the definitions for alternative" , getName @con ,"of nonterminal"+                                               ,getName  @nt , "contains an attribute that is not defined"+                                               ,"Maybe you misspelled it?"+                                               ,"Otherwise either remove the rule or add an appropriate attribute definition."+                                               ]+                                 act  = wfill ["The generated program will not run."]+                             in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose++  | CyclicSet       lhs.pp = let mesg  = wfill ["Cyclic definition for nonterminal set", getName @name]+                                 pat   = "SET" >#< getName @name >#< "=" >#< "..." >#< getName @name >#< "..."+                                 help =  wfill ["The defintion for a nonterminal set named" , getName @name+                                               ,"directly or indirectly refers to itself."+                                               ,"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 @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose++  | Cyclic          lhs.pp = let pos  = getPos @nt+                                 mesg = text "Circular dependency for nonterminal" >#< getName @nt+                                        >#< ( case @mbCon of+                                                Nothing  -> empty+                                                Just con -> text "and constructor" >#< con+                                            )+                                        >#< ( case @verts of+                                                  v : _ -> text "including vertex" >#< text v+                                                  _     -> empty+                                            )+                                 pat  = text "cyclic rule definition"+                                 help = hlist (text "The following attributes are all cyclic: " : map text @verts)+                                 act  = wfill ["code cannot be generated until the cycle is removed."]+                             in ppError (isError @lhs.options @me) pos mesg pat help act False++  | CustomError     lhs.pp = let pat   =  text "unknown"+                                 help = wfill ["not available."]+                                 act  = wfill ["unknown"]+                             in ppError (isError @lhs.options @me) @pos @mesg pat help act False++  | LocalCirc       lhs.pp = let mesg  = wfill ["Circular dependency for local attribute", getName @attr+                                               , "of alternative", getName @con, "of nonterminal", getName @nt]+                                 pat   = "SEM" >#< getName @nt+                                         >-< indent 2 ("|" >#< getName @con >#< "loc." >|< getName @attr >#< "="+                                                           >#< "..." >#< "@loc." >|< getName @attr >#< "...")+                                 help  = if null @path+                                         then text "the definition is directly circular"+                                         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 @lhs.options @me) (getPos (@attr)) mesg pat help act @lhs.verbose++  | InstCirc        lhs.pp = let mesg  = wfill ["Circular dependency for inst attribute", getName @attr+                                               , "of alternative", getName @con, "of nonterminal", getName @nt]+                                 pat   = "SEM" >#< getName @nt+                                         >-< indent 2 ("|" >#< getName @con >#< "inst." >|< getName @attr >#< "="+                                                           >#< "..." >#< "@s.<some attribte>" >#< "...")+                                 help  = if null @path+                                         then text "the definition is directly circular"+                                         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 @lhs.options @me) (getPos (@attr)) mesg pat help act @lhs.verbose++  | DirectCirc      lhs.pp = let mesg  = wfill ["In nonterminal", getName @nt, "synthesized and inherited attributes are mutually dependent" ]+                                         >-< vlist (map showEdge @cyclic)+                                 pat   = text ""+                                 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 @lhs.options @me) noPos mesg pat help act @lhs.verbose++  | InducedCirc     lhs.pp = let mesg  = wfill ["After scheduling, in nonterminal", getName @nt, "synthesized and inherited attributes have an INDUCED mutual dependency" ]+                                         >-< vlist (map showEdge @cyclic)+                                 pat   = text ""+                                 showInter (CInterface segs) = concat (snd (mapAccumL (\i c -> (succ i :: Integer,("visit " ++ show i) : map ind (showsSegment c))) 0 segs))+                                 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 @lhs.options @me) noPos mesg pat help act @lhs.verbose++  | MissingTypeSig  lhs.pp = let mesg = wfill ["Type signature needed, but not found for", showAttrDef _LOC @attr , "in alternative"+                                               , getName @con , "of nonterminal",getName @nt ,"."+                                               ]>-<+                                         wfill ["Location:", (showPos @attr),"."]+                                 pat   =   "SEM" >#< @nt+                                       >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< ": ...")+                                 help  = wfill ["The", showAttrDef _LOC @attr, "in alternative", getName @con+                                               ,"of nonterminal", getName @nt, "is needed in two separate visits to", getName @nt+                                               ,"so its type is needed to generate type signatures."+                                               ,"Please supply its type."+                                               ]+                                 act  = wfill ["The type signatures of semantic functions are not generated."]+                             in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose++  | MissingInstSig  lhs.pp = let mesg = wfill ["Type signature needed, but not found for", showAttrDef _INST @attr , "in alternative"+                                               , getName @con , "of nonterminal",getName @nt ,"."+                                               ]>-<+                                         wfill ["Location:", (showPos @attr),"."]+                                 pat   = "SEM" >#< @nt+                                           >-< indent 2 ("|" >#< getName @con >#< ppAttr _INST @attr >#< ": ...")+                                 help  = wfill ["The", showAttrDef _INST @attr, "in alternative", getName @con+                                               ,"of nonterminal", getName @nt, "is a non-terminal attribute, so "+                                               ,"its type is needed to attribute its value."+                                               ,"Please supply its type."+                                               ]+                                 act  = wfill ["It is not possible to proceed without this signature."]+                             in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose++  | MissingUnique   lhs.pp = let mesg  = wfill ["Missing unique counter (chained attribute)"+                                               , getName @attr+                                               , "at nonterminal"+                                               , getName @nt, "."+                                               ]+                                 pat   = "ATTR" >#< getName @nt >#< "[ |" >#< getName @attr >#< " : ... | ]"++                                 help =  wfill ["A unique attribute signature in a constructor for nonterminal" , getName @nt+                                               , "refers to an unique counter (chained attribute) named "+                                               , getName @attr+                                               ,"Maybe you misspelled it?"+                                               ,"Otherwise either remove the signature or add an appropriate attribute definition."+                                               ]+                                 act  = wfill ["It is not possible to proceed without this declaration."]+                             in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose++  | DupUnique       lhs.pp = let mesg  = wfill ["At constructor",getName @con, "of nonterminal", getName @nt, "there are two or more unique-attribute signatures for"+                                               ,showAttrDef _LOC @attr,"."+                                               ]  >-<+                                         wfill ["First signature:", (showPos @attr),"."]++                                 pat   =   "SEM" >#< getName @nt+                                       >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< " : UNIQUEREF ...")+                                       >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< " : UNIQUEREF ...")++                                 help =  wfill ["In the rules for alternative" , getName @con , "of nonterminal" , getName @nt+                                                       ,", there is more than one unique-attribute signature for the" , showAttrDef _LOC @attr+                                                       ,". You should remove enough of them to make all unique-signatures for alternative"+                                                       ,getName @con , "of nonterminal " ,getName  @nt , "unique."+                                                       ]+                                 act  = wfill ["Unpredicatable sharing of unique numbers may occur."]+                             in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose++ | MissingSyn      lhs.pp = let mesg  = wfill ["Missing synthesized attribute"+                                              , getName @attr+                                              , "at nonterminal"+                                              , getName @nt, "."+                                              ]+                                pat   = "ATTR" >#< getName @nt >#< "[ | | " >#< getName @attr >#< " : ... ]"++                                help =  wfill ["An augment rule for a constructor for nonterminal" , getName @nt+                                              , "refers to a synthesized attribute named "+                                              , getName @attr+                                              ,"Maybe you misspelled it?"+                                              ,"Otherwise add an appropriate attribute definition."+                                              ]+                                act  = wfill ["It is not possible to proceed without this declaration."]+                            in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose+  | IncompatibleVisitKind+                   lhs.pp = let mesg  = "visit" >#< @vis >#< "of child" >#< @child >#< " with kind" >#< show @to >#< " cannot be called from a visit with kind " >#< show @from+                                pat   = empty+                                help  = empty+                                act   = text "It is not possible to proceed without fixing this kind error."+                            in ppError (isError @lhs.options @me) (getPos @child) mesg pat help act @lhs.verbose+  | IncompatibleRuleKind+                   lhs.pp = let mesg  = "rule" >#< @rule >#< "cannot be called from a visit with kind " >#< show @kind+                                pat   = empty+                                help  = empty+                                act   = text "It is not possible to proceed without fixing this kind error."+                            in ppError (isError @lhs.options @me) (getPos @rule) mesg pat help act @lhs.verbose++  | IncompatibleAttachKind+                   lhs.pp = let mesg  = "child" >#< @child >#< "cannot be called from a visit with kind " >#< show @kind+                                pat   = empty+                                help  = empty+                                act   = text "It is not possible to proceed without fixing this kind error."+                            in ppError (isError @lhs.options @me) (getPos @child) mesg pat help act @lhs.verbose++{+toWidth :: Int -> String -> String+toWidth n xs | k<n       = xs ++ replicate (n-k) ' '+             | otherwise = xs+               where k = length xs++showEdge :: ((Identifier,Identifier),[String],[String]) -> PP_Doc+showEdge ((inh,syn),_,_)+  = text ("inherited attribute " ++ toWidth 20 (getName inh) ++ " with synthesized attribute " ++  getName syn)++showEdgeLong :: ((Identifier,Identifier),[String],[String]) -> PP_Doc+showEdgeLong ((inh,syn),path1,path2)+  = text ("inherited attribute " ++ getName inh ++ " is needed for " ++  "synthesized attribute " ++ getName syn)+    >-< indent 4 (vlist (map text path2))+    >-< text "and back: "+    >-< indent 4 (vlist (map text path1))++attrText :: Identifier -> Identifier -> String+attrText inh syn+ =  if   inh == syn+    then "threaded attribute " ++ getName inh+    else "inherited attribute " ++ getName inh ++ " and synthesized attribute " ++getName syn++showLineNr :: Int -> String+showLineNr i | i==(-1) = "CR"+             | otherwise = show i++showAttrDef :: Identifier -> Identifier -> String+showAttrDef f a | f == _LHS  = "synthesized attribute " ++ getName a+                | f == _LOC  = "local attribute " ++ getName a+                | f == _INST = "inst attribute " ++ getName a+                | otherwise  = "inherited attribute " ++ getName a ++ " of field " ++ getName f++showAttrUse :: Identifier -> Identifier -> String+showAttrUse f a | f == _LHS  = "inherited attribute " ++ getName a+                | f == _LOC  = "local attribute " ++ getName a+                | f == _INST = "inst attribute " ++ getName a+                | otherwise  = "synthesized attribute " ++ getName a ++ " of field " ++ getName f++ppAttr :: Identifier -> Identifier -> PP_Doc+ppAttr f a = text (getName f++"."++getName a)+ppAttrUse :: Identifier -> Identifier -> PP_Doc+ppAttrUse f a = "@" >|< ppAttr f a+}+-- Printing of error messages++{+infixr 5 +#++(+#+) :: String -> String -> String+(+#+) s t = s ++ " " ++ t++infixr 5 +.++(+.+) :: Identifier -> Identifier -> String+(+.+) s t = getName s ++ "." ++ getName t++wfill :: [String] -> PP_Doc+wfill = fill . addSpaces. concat . map words+  where addSpaces (x:xs) = x:map addSpace xs+        addSpaces []     = []+        addSpace  [x]    | x `elem` ".,;:!?" = [x]+        addSpace  xs     = ' ':xs++ppError :: Bool           -- class of the error, True:error False:warning+        -> Pos      -- source position+        -> PP_Doc         -- error message+        -> PP_Doc         -- pattern+        -> PP_Doc         -- help, more info+        -> PP_Doc         -- action taken by AG+        -> Bool           -- verbose? show help and action?+        -> PP_Doc+ppError isErr pos mesg pat hlp act verb+  = let position = case pos of+                     Pos l c f | l >= 0    -> f >|< ":" >|< show l >|< ":" >|< show c+                               | otherwise -> pp "uuagc"+        tp      = if isErr then "error" else "warning"+        header  = position >|< ":" >#< tp >|< ":" >#< mesg+        pattern = "pattern  :" >#< pat+        help    = "help     :" >#< hlp+        action  = "action   :" >#< act+    in if verb+         then vlist [text "",header,pattern,help,action]+         else header++{-+-- old error reporting code+  = let+      cl = if isError then "ERROR" else "Warning"+      position   = case pos of+                         (Pos l c f) | l >= 0    -> f >|< ": line " >|< show l >|< ", column " >|< show c+                                     | otherwise -> empty+      header     = "*** UU.AG" >#< cl >#< position >#< "***"+      message    = "problem  :" >#< mesg+      pattern    = "pattern  :" >#< pat+      help       = "help     :" >#< hlp+      action     = "action   :" >#< act+    in+      if verbose+         then vlist [text "",header,message,pattern,help,action]+         else vlist [text "",header,message]+-}++showPos :: Identifier -> String+showPos = show . getPos++ppInterface :: Show a => a -> PP_Doc+ppInterface inter = wfill ["interface:", show inter]++}+
src-ag/PrintOcamlCode.ag view
@@ -1,222 +1,222 @@-PRAGMA strictdata
-PRAGMA optimize
-PRAGMA bangpats
-PRAGMA strictwrap
-
-INCLUDE "Code.ag"
-INCLUDE "Patterns.ag"
-
-imports
-{
-import Pretty
-import Code
-import Patterns
-import Options
-import CommonTypes hiding (List,Type,Map,Maybe,IntMap,Either)
-import Data.List(intersperse,intercalate)
-import Data.Char(toLower)
-}
-
-
-{
-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
-
-ppTuple :: Bool -> [PP_Doc] -> PP_Doc
-ppTuple True  pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps
-ppTuple False pps = "(" >|< pp_block " " ")" "," pps
-}
-
-
---
--- Pass options down
---
-
-ATTR Program Expr Exprs Decl Decls Chunk Chunks CaseAlts CaseAlt Lhs Pattern Patterns [ options:{Options} | | ]
-
-ATTR Program Chunks Chunk [ textBlockMap : {Map BlockInfo PP_Doc} | | ]
-
-
---
--- Collect outputs
---
-
-ATTR Program                                                              [ | | output:{PP_Docs} ]
-ATTR Expr Decl DataAlt CaseAlt Type NamedType Lhs Pattern                 [ | | pp:{PP_Doc} ]
-ATTR Exprs DataAlts CaseAlts Types NamedTypes Decls Chunk Chunks Patterns [ | | pps : {PP_Docs} ]
-
-SEM Program
-  | Program    lhs.output  = @chunks.pps
-
-SEM Exprs
-  | Cons lhs.pps = @hd.pp : @tl.pps
-  | Nil  lhs.pps = []
-
-SEM CaseAlts
-  | Cons lhs.pps = @hd.pp : @tl.pps
-  | Nil  lhs.pps = []
-
-SEM DataAlts
-  | Cons lhs.pps = @hd.pp : @tl.pps
-  | Nil  lhs.pps = []
-
-SEM Types
-  | Cons lhs.pps = @hd.pp : @tl.pps
-  | Nil  lhs.pps = []
-
-SEM NamedTypes
-  | Cons lhs.pps = @hd.pp : @tl.pps
-  | Nil  lhs.pps = []
-
-SEM Decls
-  | Cons lhs.pps = @hd.pp : @tl.pps
-  | Nil  lhs.pps = []
-
-SEM Chunks
-  | Cons lhs.pps = @hd.pps ++ @tl.pps
-  | Nil  lhs.pps = []
-
-SEM Patterns
-  | Cons lhs.pps = @hd.pp : @tl.pps
-  | Nil  lhs.pps = []
-
---
--- Individual cases
---
-
-SEM Chunk
-  | Chunk      lhs.pps     =  @comment.pp
-                              :  @info.pps
-                              ++ @dataDef.pps
-                              ++ @semDom.pps
-                              ++ @semFunctions.pps
-                              ++ @semWrapper.pps
-                              ++ @cataFun.pps
-                              ++ [Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap]
-
-SEM Decl
-  | Decl       lhs.pp      = if @lhs.isToplevel
-                             then "let" >#< @left.pp >#< "="
-                                  >-< indent 4 @rhs.pp >#< ";;"
-                             else "let" >#< @left.pp >#< "="
-                                  >-< indent 4 @rhs.pp >#< "in"
-  | Bind       lhs.pp      = error "pp of Decl.Bind not supported"
-  | BindLet    lhs.pp      = error "pp of Decl.BindLet not supported"
-  | Data       lhs.pp      = "type" >#< hv_sp (map (\p -> "'" >|< p) @params ++ [text $ toOcamlTC @name])
-                             >#<  ( case @alts.pps of
-                                          [] -> empty
-                                          (x:xs) ->              "=" >#<  x
-                                                 >-< vlist (map ("|" >#<) xs)
-                                  )
-                             >#< ";;"
-  | NewType    lhs.pp      = error "pp of Decl.NewType not supported"
-  | Type       lhs.pp      = "type" >#< hv_sp (map (\p -> "'" >|< p) @params ++ [text $ toOcamlTC @name]) >#< "=" >#<  @tp.pp >#< ";;"
-  | TSig       lhs.pp      = "(*" >#< @name >#< ":" >#< @tp.pp >#< "*)"
-  | Comment    lhs.pp      = if '\n' `elem` @txt
-                               then "(* " >-< vlist (lines @txt) >-< "*)"
-                               else "(*" >#< @txt >#< "*)"
-  | PragmaDecl lhs.pp      = error "pp of Decl.PragmaDecl not supported"
-
-
-  SEM Expr
-    | Let        lhs.pp      = pp_parens $ vlist (@decls.pps ++ [@body.pp])
-    | Case       lhs.pp      = pp_parens ( "match" >#< @expr.pp >#< "with"
-                                         >-< indent 2 ( case @alts.pps of
-                                                          [] -> empty
-                                                          (x:xs) -> " " >#<  x
-                                                                    >-< vlist (map ("|" >#<) xs)
-                                                      )
-                                         )
-    | Do         lhs.pp      = error "pp of Expr.Do not supported"
-    | Lambda     lhs.pp      = pp_parens ( pp "fun" >#< hv_sp @args.pps >#< "->"
-                                         >-< indent 2 @body.pp )
-    | TupleExpr  lhs.pp      = ppTuple False @exprs.pps
-    | UnboxedTupleExpr  lhs.pp = error "pp of Expr.UnboxedTupleExpr not supported"
-    | App        lhs.pp      = pp_parens $ @name >#< hv_sp @args.pps
-    | SimpleExpr lhs.pp      = text @txt
-    | TextExpr   lhs.pp      = vlist (map text @lns)
-    | Trace      lhs.pp      = @expr.pp
-    | PragmaExpr lhs.pp      = @expr.pp
-    | LineExpr   lhs.pp      = @expr.pp
-    | TypedExpr  lhs.pp      = @expr.pp
-
-SEM Lhs
-  | Pattern3   lhs.pp      = @pat3.pp
-  | Pattern3SM lhs.pp      = error "pp of Lhs.Pattern3SM not supported"
-  | TupleLhs   lhs.pp      = ppTuple False (map text @comps)
-  | UnboxedTupleLhs   lhs.pp      = error "pp of Lhs.UnboxedTupleLhs not supported"
-  | Fun        lhs.pp      = @name >#< hv_sp @args.pps
-  | Unwrap     lhs.pp      = pp_parens (@name >#< @sub.pp)
-
-SEM Type
-  | Arr        lhs.pp = pp_parens (@left.pp >#< "->" >#< @right.pp)
-  | CtxApp     lhs.pp = error "pp of Type.CtxApp not supported"
-  | TypeApp    lhs.pp = pp_parens (hv_sp (@args.pps ++ [@func.pp]))
-  | TupleType  lhs.pp = pp_block "(" ")" "," @tps.pps
-  | UnboxedTupleType
-               lhs.pp = error "pp of Type.UnboxedTupleType is not supported"
-  | List       lhs.pp = @tp.pp >#< "list"
-  | SimpleType lhs.pp = text @txt
-  | NontermType lhs.pp = pp_block "(" ")" " " (map text @params ++ [text $ toOcamlTC @name])
-  | TMaybe     lhs.pp = @tp.pp >#< "opt"
-  | TEither    lhs.pp = error "pp of Type.TEither is not supported"
-  | TMap       lhs.pp = error "pp of Type.TMap is not supported"
-  | TIntMap    lhs.pp = error "pp of Type.TIntMap is not supported"
-  | TSet       lhs.pp = error "pp of Type.TSet is not supported"
-  | TIntSet    lhs.pp = error "pp of Type.TIntSet is not supported"
-
-{
-toOcamlTC :: String -> String
-toOcamlTC (c:cs) = toLower c : cs
-toOcamlTC xs = xs
-}
-
-SEM CaseAlt
-  | CaseAlt    lhs.pp      = @left.pp >#< "->" >#< @expr.pp
-
-SEM DataAlt
-  | DataAlt    lhs.pp      = @name >#< "of" >#< pp_block "" "" " * " (map pp_parens @args.pps)
-  | Record     lhs.pp      = pp_block "{" "}" ";" @args.pps
-
-SEM NamedType
-  | Named      lhs.pp      = @name >#< ":" >#< @tp.pp
-
-SEM Pattern
-  | Constr  lhs.pp     = pp_parens $ @name >#< hv_sp @pats.pps
-  | Product lhs.pp     = pp_block "(" ")" "," @pats.pps
-  | Alias   -- assuming here that there is only an underscore under an alias
-            lhs.pp     = if @pat.isUnderscore
-                          then pp (attrname @lhs.options False @field @attr)
-                          else error "pp of Pattern.Alias is only supported in the form (x@_)"
-  | Irrefutable lhs.pp = error "pp of Pattern.Irrefutable not supported"
-  | Underscore lhs.pp  = text "_"
-
-SEM Pattern [ | | isUnderscore:{Bool}]
- | Constr      lhs.isUnderscore = False
- | Product     lhs.isUnderscore = False
- | Alias       lhs.isUnderscore = False
- | Underscore  lhs.isUnderscore = True
-
---
--- Determine if a declaration is toplevel
---
-
-ATTR Chunks Chunk Decls Decl [ isToplevel : Bool | | ]
-SEM Program
-  | Program
-      chunks.isToplevel = True
-
-SEM Expr
-  | Let
-      decls.isToplevel = False
-  | Do
-      stmts.isToplevel = False
+PRAGMA strictdata+PRAGMA optimize+PRAGMA bangpats+PRAGMA strictwrap++INCLUDE "Code.ag"+INCLUDE "Patterns.ag"++imports+{+import Pretty+import Code+import Patterns+import Options+import CommonTypes hiding (List,Type,Map,Maybe,IntMap,Either)+import Data.List(intersperse,intercalate)+import Data.Char(toLower)+}+++{+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++ppTuple :: Bool -> [PP_Doc] -> PP_Doc+ppTuple True  pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps+ppTuple False pps = "(" >|< pp_block " " ")" "," pps+}+++--+-- Pass options down+--++ATTR Program Expr Exprs Decl Decls Chunk Chunks CaseAlts CaseAlt Lhs Pattern Patterns [ options:{Options} | | ]++ATTR Program Chunks Chunk [ textBlockMap : {Map BlockInfo PP_Doc} | | ]+++--+-- Collect outputs+--++ATTR Program                                                              [ | | output:{PP_Docs} ]+ATTR Expr Decl DataAlt CaseAlt Type NamedType Lhs Pattern                 [ | | pp:{PP_Doc} ]+ATTR Exprs DataAlts CaseAlts Types NamedTypes Decls Chunk Chunks Patterns [ | | pps : {PP_Docs} ]++SEM Program+  | Program    lhs.output  = @chunks.pps++SEM Exprs+  | Cons lhs.pps = @hd.pp : @tl.pps+  | Nil  lhs.pps = []++SEM CaseAlts+  | Cons lhs.pps = @hd.pp : @tl.pps+  | Nil  lhs.pps = []++SEM DataAlts+  | Cons lhs.pps = @hd.pp : @tl.pps+  | Nil  lhs.pps = []++SEM Types+  | Cons lhs.pps = @hd.pp : @tl.pps+  | Nil  lhs.pps = []++SEM NamedTypes+  | Cons lhs.pps = @hd.pp : @tl.pps+  | Nil  lhs.pps = []++SEM Decls+  | Cons lhs.pps = @hd.pp : @tl.pps+  | Nil  lhs.pps = []++SEM Chunks+  | Cons lhs.pps = @hd.pps ++ @tl.pps+  | Nil  lhs.pps = []++SEM Patterns+  | Cons lhs.pps = @hd.pp : @tl.pps+  | Nil  lhs.pps = []++--+-- Individual cases+--++SEM Chunk+  | Chunk      lhs.pps     =  @comment.pp+                              :  @info.pps+                              ++ @dataDef.pps+                              ++ @semDom.pps+                              ++ @semFunctions.pps+                              ++ @semWrapper.pps+                              ++ @cataFun.pps+                              ++ [Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap]++SEM Decl+  | Decl       lhs.pp      = if @lhs.isToplevel+                             then "let" >#< @left.pp >#< "="+                                  >-< indent 4 @rhs.pp >#< ";;"+                             else "let" >#< @left.pp >#< "="+                                  >-< indent 4 @rhs.pp >#< "in"+  | Bind       lhs.pp      = error "pp of Decl.Bind not supported"+  | BindLet    lhs.pp      = error "pp of Decl.BindLet not supported"+  | Data       lhs.pp      = "type" >#< hv_sp (map (\p -> "'" >|< p) @params ++ [text $ toOcamlTC @name])+                             >#<  ( case @alts.pps of+                                          [] -> empty+                                          (x:xs) ->              "=" >#<  x+                                                 >-< vlist (map ("|" >#<) xs)+                                  )+                             >#< ";;"+  | NewType    lhs.pp      = error "pp of Decl.NewType not supported"+  | Type       lhs.pp      = "type" >#< hv_sp (map (\p -> "'" >|< p) @params ++ [text $ toOcamlTC @name]) >#< "=" >#<  @tp.pp >#< ";;"+  | TSig       lhs.pp      = "(*" >#< @name >#< ":" >#< @tp.pp >#< "*)"+  | Comment    lhs.pp      = if '\n' `elem` @txt+                               then "(* " >-< vlist (lines @txt) >-< "*)"+                               else "(*" >#< @txt >#< "*)"+  | PragmaDecl lhs.pp      = error "pp of Decl.PragmaDecl not supported"+++  SEM Expr+    | Let        lhs.pp      = pp_parens $ vlist (@decls.pps ++ [@body.pp])+    | Case       lhs.pp      = pp_parens ( "match" >#< @expr.pp >#< "with"+                                         >-< indent 2 ( case @alts.pps of+                                                          [] -> empty+                                                          (x:xs) -> " " >#<  x+                                                                    >-< vlist (map ("|" >#<) xs)+                                                      )+                                         )+    | Do         lhs.pp      = error "pp of Expr.Do not supported"+    | Lambda     lhs.pp      = pp_parens ( pp "fun" >#< hv_sp @args.pps >#< "->"+                                         >-< indent 2 @body.pp )+    | TupleExpr  lhs.pp      = ppTuple False @exprs.pps+    | UnboxedTupleExpr  lhs.pp = error "pp of Expr.UnboxedTupleExpr not supported"+    | App        lhs.pp      = pp_parens $ @name >#< hv_sp @args.pps+    | SimpleExpr lhs.pp      = text @txt+    | TextExpr   lhs.pp      = vlist (map text @lns)+    | Trace      lhs.pp      = @expr.pp+    | PragmaExpr lhs.pp      = @expr.pp+    | LineExpr   lhs.pp      = @expr.pp+    | TypedExpr  lhs.pp      = @expr.pp++SEM Lhs+  | Pattern3   lhs.pp      = @pat3.pp+  | Pattern3SM lhs.pp      = error "pp of Lhs.Pattern3SM not supported"+  | TupleLhs   lhs.pp      = ppTuple False (map text @comps)+  | UnboxedTupleLhs   lhs.pp      = error "pp of Lhs.UnboxedTupleLhs not supported"+  | Fun        lhs.pp      = @name >#< hv_sp @args.pps+  | Unwrap     lhs.pp      = pp_parens (@name >#< @sub.pp)++SEM Type+  | Arr        lhs.pp = pp_parens (@left.pp >#< "->" >#< @right.pp)+  | CtxApp     lhs.pp = error "pp of Type.CtxApp not supported"+  | TypeApp    lhs.pp = pp_parens (hv_sp (@args.pps ++ [@func.pp]))+  | TupleType  lhs.pp = pp_block "(" ")" "," @tps.pps+  | UnboxedTupleType+               lhs.pp = error "pp of Type.UnboxedTupleType is not supported"+  | List       lhs.pp = @tp.pp >#< "list"+  | SimpleType lhs.pp = text @txt+  | NontermType lhs.pp = pp_block "(" ")" " " (map text @params ++ [text $ toOcamlTC @name])+  | TMaybe     lhs.pp = @tp.pp >#< "opt"+  | TEither    lhs.pp = error "pp of Type.TEither is not supported"+  | TMap       lhs.pp = error "pp of Type.TMap is not supported"+  | TIntMap    lhs.pp = error "pp of Type.TIntMap is not supported"+  | TSet       lhs.pp = error "pp of Type.TSet is not supported"+  | TIntSet    lhs.pp = error "pp of Type.TIntSet is not supported"++{+toOcamlTC :: String -> String+toOcamlTC (c:cs) = toLower c : cs+toOcamlTC xs = xs+}++SEM CaseAlt+  | CaseAlt    lhs.pp      = @left.pp >#< "->" >#< @expr.pp++SEM DataAlt+  | DataAlt    lhs.pp      = @name >#< "of" >#< pp_block "" "" " * " (map pp_parens @args.pps)+  | Record     lhs.pp      = pp_block "{" "}" ";" @args.pps++SEM NamedType+  | Named      lhs.pp      = @name >#< ":" >#< @tp.pp++SEM Pattern+  | Constr  lhs.pp     = pp_parens $ @name >#< hv_sp @pats.pps+  | Product lhs.pp     = pp_block "(" ")" "," @pats.pps+  | Alias   -- assuming here that there is only an underscore under an alias+            lhs.pp     = if @pat.isUnderscore+                          then pp (attrname @lhs.options False @field @attr)+                          else error "pp of Pattern.Alias is only supported in the form (x@_)"+  | Irrefutable lhs.pp = error "pp of Pattern.Irrefutable not supported"+  | Underscore lhs.pp  = text "_"++SEM Pattern [ | | isUnderscore:{Bool}]+ | Constr      lhs.isUnderscore = False+ | Product     lhs.isUnderscore = False+ | Alias       lhs.isUnderscore = False+ | Underscore  lhs.isUnderscore = True++--+-- Determine if a declaration is toplevel+--++ATTR Chunks Chunk Decls Decl [ isToplevel : Bool | | ]+SEM Program+  | Program+      chunks.isToplevel = True++SEM Expr+  | Let+      decls.isToplevel = False+  | Do+      stmts.isToplevel = False
src-ag/PrintVisitCode.ag view
@@ -1,53 +1,53 @@-PRAGMA strictwrap
-PRAGMA strictdata
-PRAGMA optimize
-
-INCLUDE "CodeSyntax.ag"
-INCLUDE "Patterns.ag"
-INCLUDE "DeclBlocks.ag"
-
-imports
-{
-import CommonTypes
-import SequentialTypes
-import Options
-import CodeSyntax
-import ErrorMessages
-import GrammarInfo
-import DeclBlocks
-import Pretty
-
-import qualified Data.Map as Map
-import Data.Map(Map)
-import qualified Data.Set as Set
-import Data.Set(Set)
-import qualified Data.Sequence as Seq
-import Data.Sequence(Seq)
-import UU.Scanner.Position
-
-import Data.List(partition,intersperse,intersect,(\\))
-import Data.Maybe(fromJust,isJust)
-}
-
-{
-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
-}
-
-
-WRAPPER CGrammar
-
-ATTR CGrammar [ options:{Options} | | output:{PP_Docs} ]
-
-SEM CGrammar
-  | CGrammar
-      lhs.output = []
+PRAGMA strictwrap+PRAGMA strictdata+PRAGMA optimize++INCLUDE "CodeSyntax.ag"+INCLUDE "Patterns.ag"+INCLUDE "DeclBlocks.ag"++imports+{+import CommonTypes+import SequentialTypes+import Options+import CodeSyntax+import ErrorMessages+import GrammarInfo+import DeclBlocks+import Pretty++import qualified Data.Map as Map+import Data.Map(Map)+import qualified Data.Set as Set+import Data.Set(Set)+import qualified Data.Sequence as Seq+import Data.Sequence(Seq)+import UU.Scanner.Position++import Data.List(partition,intersperse,intersect,(\\))+import Data.Maybe(fromJust,isJust)+}++{+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+}+++WRAPPER CGrammar++ATTR CGrammar [ options:{Options} | | output:{PP_Docs} ]++SEM CGrammar+  | CGrammar+      lhs.output = []
src-ag/ResolveLocals.ag view
@@ -1,157 +1,157 @@-INCLUDE "AbstractSyntax.ag"
-INCLUDE "Patterns.ag"
-INCLUDE "Expression.ag"
-INCLUDE "DistChildAttr.ag"
-
-
---
--- Checks right-hand sides for missing attributes.
--- Attribute references @xxx are now explicitly mapped to @loc.xxx if there is such
--- an attribute in scope and there is no terminal @xxx.
---
-
-
-imports
-{
-import qualified Data.Set as Set
-import qualified Data.Map as Map
-import Data.Map(Map)
-import qualified Data.Sequence as Seq
-import Data.Sequence(Seq,(><))
-import CommonTypes
-import Patterns
-import ErrorMessages
-import AbstractSyntax
-import Expression
-import Options
-import HsToken(HsTokensRoot(HsTokensRoot))
-import SemHsTokens(sem_HsTokensRoot,wrap_HsTokensRoot, Syn_HsTokensRoot(..),Inh_HsTokensRoot(..))
-import Data.Maybe
-}
-
-WRAPPER Grammar
-
-
---
--- Main attributes
---
-
-ATTR Grammar Nonterminals Nonterminal Productions Production Rule Rules Expression
-  [ options:{Options} | | ]
-
-ATTR Grammar Nonterminals Nonterminal Productions Production Rule Rules Pattern Patterns Expression
-  [ | | errors USE {Seq.><} {Seq.empty} : {Seq Error} ]
-
-ATTR Grammar Nonterminals Nonterminal Productions Production Child Children Rule Rules Pattern Patterns TypeSig TypeSigs Expression
-  [ | | output : SELF ]
-
---
--- Collect inputs to expressions
---
-
--- Collecting nts
-ATTR Nonterminal Nonterminals
-     Production Productions
-     Rule Rules
-     Child Children [allnts:{[Identifier]} | | ]
-
-SEM Grammar
-  | Grammar nonts.allnts = map fst (@nonts.nonts)
-
-ATTR Nonterminals Nonterminal [ | | nonts USE {++} {[]} : {[(NontermIdent,[ConstructorIdent])]} ]
-SEM  Nonterminal
-  |  Nonterminal  lhs.nonts = [(@nt,@prods.cons)]
-ATTR Productions Production [ | | cons USE {++} {[]} : {[ConstructorIdent]} ]
-SEM  Production
-  |  Production  lhs.cons = [@con]
-
--- Collecting fields
-ATTR Rule Rules
-     Child Children [allfields:{[(Identifier,Type,ChildKind)]} attrs:{[(Identifier,Identifier)]} | | ]
-
-SEM Production
-  | Production loc.allfields  = @children.fields
-                   .attrs      = map ((,) _LOC)  @rules.locVars ++
-                                 map ((,) _INST) @rules.instVars ++
-                                 map ((,) _LHS)  @inhnames ++
-                                 concat [map ((,) nm) (Map.keys as) | (nm,_,as) <- @children.attributes]
-                   .inhnames   = Map.keys @lhs.inh
-                   .synnames   = Map.keys @lhs.syn
-
-ATTR Children [ | | attributes USE {++} {[]} : {[(Identifier,Attributes,Attributes)]} ]
-SEM Child [ | | attributes:{[(Identifier,Attributes,Attributes)]} ]
-  | Child lhs.attributes = [(@name, @loc.inh, @loc.syn)]
-
-SEM Child [ | | field : {(Identifier,Type,ChildKind)} ]
-  | Child lhs.field = (@name, @tp, @kind)
-
-SEM Children [ | | fields : {[(Identifier,Type,ChildKind)]} ]
-  | Cons  lhs.fields = @hd.field : @tl.fields
-  | Nil   lhs.fields = []
-
-ATTR Rules Rule Patterns Pattern [ | | locVars USE {++} {[]}:{[Identifier]} instVars USE {++} {[]} : {[Identifier]} ]
-
-SEM Pattern
-  | Alias    lhs.locVars   = if @field == _LOC
-                                then [@attr]
-                                else []
-             lhs.instVars  = if @field == _INST
-                                then [@attr]
-                                else []
-
---         Distributing name of nonterminal and names of attributes
-ATTR Productions Production Child Children Rules Rule Patterns Pattern [ nt : {Identifier} inh,syn : {Attributes} | | ]
-ATTR Child Children Rules Rule Patterns Pattern [ con : {Identifier} | | ]
-
-SEM Production
-  | Production children . con = @con
-SEM Production
-  | Production rules . con = @con
-SEM Nonterminal
-  | Nonterminal prods . nt = @nt
-
-SEM Nonterminal
-  | Nonterminal prods.inh  = @inh
-                prods.syn  = @syn
-
--- merge map
-SEM Grammar
-  | Grammar  nonts.mergeMap  = Map.map (Map.map (Map.map (\(nt,srcs,_) -> (nt,srcs)))) @mergeMap
-
-ATTR Nonterminals Nonterminal
-  [ mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))} | | ]
-
-ATTR Productions Production
-  [ mergeMap : {Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))} | | ]
-
-SEM Nonterminal | Nonterminal  loc.mergeMap = Map.findWithDefault Map.empty @nt @lhs.mergeMap
-SEM Production  | Production   loc.mergeMap = Map.findWithDefault Map.empty @con @lhs.mergeMap
-
-ATTR Rules Rule Children Child Expression [ mergeMap : {Map Identifier (Identifier,[Identifier])} | | ]
-
-
---
--- Handling Expressions
---
-
-ATTR Expression [ nt,con   :{Identifier}
-                  allfields:{[(Identifier,Type,ChildKind)]}
-                  allnts   :{[Identifier]}
-                  attrs    :{[(Identifier,Identifier)]}
-                || ]
-
-SEM Expression
-  | Expression  loc.(errors,newTks)
-                            = let mergedChildren = [ x | (_,xs) <- Map.elems @lhs.mergeMap, x <- xs ]
-                                  attrsIn = filter (\(fld,_) -> not (fld `elem` mergedChildren)) @lhs.attrs
-                                  inherited = Inh_HsTokensRoot
-                                              { attrs_Inh_HsTokensRoot      = attrsIn
-                                              , con_Inh_HsTokensRoot        = @lhs.con
-                                              , allfields_Inh_HsTokensRoot  = @lhs.allfields
-                                              , allnts_Inh_HsTokensRoot     = @lhs.allnts
-                                              , nt_Inh_HsTokensRoot         = @lhs.nt
-                                              , options_Inh_HsTokensRoot    = @lhs.options
-                                              }
-                                  synthesized = wrap_HsTokensRoot (sem_HsTokensRoot (HsTokensRoot @tks)) inherited
-                              in (errors_Syn_HsTokensRoot synthesized, output_Syn_HsTokensRoot synthesized)
-                lhs.output = Expression @pos @loc.newTks
+INCLUDE "AbstractSyntax.ag"+INCLUDE "Patterns.ag"+INCLUDE "Expression.ag"+INCLUDE "DistChildAttr.ag"+++--+-- Checks right-hand sides for missing attributes.+-- Attribute references @xxx are now explicitly mapped to @loc.xxx if there is such+-- an attribute in scope and there is no terminal @xxx.+--+++imports+{+import qualified Data.Set as Set+import qualified Data.Map as Map+import Data.Map(Map)+import qualified Data.Sequence as Seq+import Data.Sequence(Seq,(><))+import CommonTypes+import Patterns+import ErrorMessages+import AbstractSyntax+import Expression+import Options+import HsToken(HsTokensRoot(HsTokensRoot))+import SemHsTokens(sem_HsTokensRoot,wrap_HsTokensRoot, Syn_HsTokensRoot(..),Inh_HsTokensRoot(..))+import Data.Maybe+}++WRAPPER Grammar+++--+-- Main attributes+--++ATTR Grammar Nonterminals Nonterminal Productions Production Rule Rules Expression+  [ options:{Options} | | ]++ATTR Grammar Nonterminals Nonterminal Productions Production Rule Rules Pattern Patterns Expression+  [ | | errors USE {Seq.><} {Seq.empty} : {Seq Error} ]++ATTR Grammar Nonterminals Nonterminal Productions Production Child Children Rule Rules Pattern Patterns TypeSig TypeSigs Expression+  [ | | output : SELF ]++--+-- Collect inputs to expressions+--++-- Collecting nts+ATTR Nonterminal Nonterminals+     Production Productions+     Rule Rules+     Child Children [allnts:{[Identifier]} | | ]++SEM Grammar+  | Grammar nonts.allnts = map fst (@nonts.nonts)++ATTR Nonterminals Nonterminal [ | | nonts USE {++} {[]} : {[(NontermIdent,[ConstructorIdent])]} ]+SEM  Nonterminal+  |  Nonterminal  lhs.nonts = [(@nt,@prods.cons)]+ATTR Productions Production [ | | cons USE {++} {[]} : {[ConstructorIdent]} ]+SEM  Production+  |  Production  lhs.cons = [@con]++-- Collecting fields+ATTR Rule Rules+     Child Children [allfields:{[(Identifier,Type,ChildKind)]} attrs:{[(Identifier,Identifier)]} | | ]++SEM Production+  | Production loc.allfields  = @children.fields+                   .attrs      = map ((,) _LOC)  @rules.locVars +++                                 map ((,) _INST) @rules.instVars +++                                 map ((,) _LHS)  @inhnames +++                                 concat [map ((,) nm) (Map.keys as) | (nm,_,as) <- @children.attributes]+                   .inhnames   = Map.keys @lhs.inh+                   .synnames   = Map.keys @lhs.syn++ATTR Children [ | | attributes USE {++} {[]} : {[(Identifier,Attributes,Attributes)]} ]+SEM Child [ | | attributes:{[(Identifier,Attributes,Attributes)]} ]+  | Child lhs.attributes = [(@name, @loc.inh, @loc.syn)]++SEM Child [ | | field : {(Identifier,Type,ChildKind)} ]+  | Child lhs.field = (@name, @tp, @kind)++SEM Children [ | | fields : {[(Identifier,Type,ChildKind)]} ]+  | Cons  lhs.fields = @hd.field : @tl.fields+  | Nil   lhs.fields = []++ATTR Rules Rule Patterns Pattern [ | | locVars USE {++} {[]}:{[Identifier]} instVars USE {++} {[]} : {[Identifier]} ]++SEM Pattern+  | Alias    lhs.locVars   = if @field == _LOC+                                then [@attr]+                                else []+             lhs.instVars  = if @field == _INST+                                then [@attr]+                                else []++--         Distributing name of nonterminal and names of attributes+ATTR Productions Production Child Children Rules Rule Patterns Pattern [ nt : {Identifier} inh,syn : {Attributes} | | ]+ATTR Child Children Rules Rule Patterns Pattern [ con : {Identifier} | | ]++SEM Production+  | Production children . con = @con+SEM Production+  | Production rules . con = @con+SEM Nonterminal+  | Nonterminal prods . nt = @nt++SEM Nonterminal+  | Nonterminal prods.inh  = @inh+                prods.syn  = @syn++-- merge map+SEM Grammar+  | Grammar  nonts.mergeMap  = Map.map (Map.map (Map.map (\(nt,srcs,_) -> (nt,srcs)))) @mergeMap++ATTR Nonterminals Nonterminal+  [ mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))} | | ]++ATTR Productions Production+  [ mergeMap : {Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))} | | ]++SEM Nonterminal | Nonterminal  loc.mergeMap = Map.findWithDefault Map.empty @nt @lhs.mergeMap+SEM Production  | Production   loc.mergeMap = Map.findWithDefault Map.empty @con @lhs.mergeMap++ATTR Rules Rule Children Child Expression [ mergeMap : {Map Identifier (Identifier,[Identifier])} | | ]+++--+-- Handling Expressions+--++ATTR Expression [ nt,con   :{Identifier}+                  allfields:{[(Identifier,Type,ChildKind)]}+                  allnts   :{[Identifier]}+                  attrs    :{[(Identifier,Identifier)]}+                || ]++SEM Expression+  | Expression  loc.(errors,newTks)+                            = let mergedChildren = [ x | (_,xs) <- Map.elems @lhs.mergeMap, x <- xs ]+                                  attrsIn = filter (\(fld,_) -> not (fld `elem` mergedChildren)) @lhs.attrs+                                  inherited = Inh_HsTokensRoot+                                              { attrs_Inh_HsTokensRoot      = attrsIn+                                              , con_Inh_HsTokensRoot        = @lhs.con+                                              , allfields_Inh_HsTokensRoot  = @lhs.allfields+                                              , allnts_Inh_HsTokensRoot     = @lhs.allnts+                                              , nt_Inh_HsTokensRoot         = @lhs.nt+                                              , options_Inh_HsTokensRoot    = @lhs.options+                                              }+                                  synthesized = wrap_HsTokensRoot (sem_HsTokensRoot (HsTokensRoot @tks)) inherited+                              in (errors_Syn_HsTokensRoot synthesized, output_Syn_HsTokensRoot synthesized)+                lhs.output = Expression @pos @loc.newTks
src-ag/SemHsTokens.ag view
@@ -1,144 +1,144 @@-INCLUDE "HsToken.ag"
-
-imports
-{
-import qualified Data.Sequence as Seq
-import Data.Sequence(Seq,empty,singleton,(><))
-import Data.Foldable(toList)
-import Pretty
-
-import TokenDef
-import HsToken
-import ErrorMessages
-}
-
-ATTR HsTokensRoot
-     [
-     | |
-       errors    USE {Seq.><} {Seq.empty}:{Seq Error}
-       usedLocals:{[Identifier]}
-       usedAttrs :{[(Identifier,Identifier)]}
-       textLines  :{[String]}
-       usedFields:{[Identifier]}
-     ]
-
--------------------------------------------------------------------------------
---  Context information
--------------------------------------------------------------------------------
-ATTR HsTokensRoot
-     HsTokens HsToken [ nt,con    : {Identifier}
-                        allfields : {[(Identifier,Type,ChildKind)]}
-                        allnts    : {[Identifier]}
-                        attrs     : {[(Identifier,Identifier)]}
-                        options   : {Options}
-                      ||
-                      ]
-
-ATTR HsTokens HsToken [ fieldnames : {[Identifier]} | | ]
-SEM HsTokensRoot
-  | HsTokensRoot tokens.fieldnames = map (\(n,_,_) -> n) @lhs.allfields
-
--------------------------------------------------------------------------------
---  Errors
--------------------------------------------------------------------------------
-ATTR HsTokens HsToken [ | |  errors USE {Seq.><} {Seq.empty}:{Seq Error}  ]
-
--------------------------------------------------------------------------------
--- Syntax errors
--------------------------------------------------------------------------------
-
-SEM HsToken
-  | Err lhs.errors = let m = text @mesg
-                     in Seq.singleton (CustomError False @pos m)
-
--------------------------------------------------------------------------------
---  Undefined variables
--------------------------------------------------------------------------------
-
-{
-isNTname allnts (Just (NT nt _ _)) = nt `elem` allnts
-isNTname allnts _                  = False
-}
-
-
--- An AGLocal is either a local variable or a terminal
-SEM HsToken
-  | AGLocal   loc.tkAsLocal = AGLocal @var @pos @rdesc        -- refers to the terminal
-              loc.tkAsField = AGField _LOC @var @pos @rdesc   -- refers to the (local) attribute
-              loc.(errors,output,tok,usedLocals) =
-                     if @var `elem` @lhs.fieldnames   -- check if @var occurs as a terminal
-                     then if  isNTname @lhs.allnts (lookup @var (map (\(n,t,_) -> (n,t)) @lhs.allfields))
-                          then (Seq.singleton(ChildAsLocal @lhs.nt @lhs.con @var), @loc.tkAsLocal,(@pos,fieldname @var), []    )
-                          else (Seq.empty, @loc.tkAsLocal, (@pos,fieldname @var), []    )
-                     else if (_LOC,@var) `elem` @lhs.attrs
-                          then (Seq.empty                                      , @loc.tkAsField, (@pos,locname @lhs.options @var), [@var])
-                          else (Seq.singleton(UndefLocal @lhs.nt @lhs.con @var), @loc.tkAsField, (@pos,locname @lhs.options @var), []    )
-
-SEM HsToken
-  | AGField   lhs.errors = if (@field,@attr) `elem` @lhs.attrs
-                           then Seq.empty
-                           else if not(@field `elem` (_LHS : _LOC: @lhs.fieldnames))
-                                then Seq.singleton (UndefChild @lhs.nt @lhs.con @field)
-                                else Seq.singleton (UndefAttr @lhs.nt @lhs.con @field @attr False)
-
--------------------------------------------------------------------------------
---         Used variables
--------------------------------------------------------------------------------
-
-ATTR HsTokens HsToken [ | | usedLocals USE {++} {[]} : {[Identifier]}
-                            usedAttrs  USE {++} {[]} : {[(Identifier,Identifier)]} ]
-
-SEM HsToken
-  | AGField (lhs.usedAttrs,lhs.usedLocals)
-              = if @field == _LOC
-                then ([], [@attr])
-                else ([(@field,@attr)], [])
-
-
--------------------------------------------------------------------------------
---         Used fields
--------------------------------------------------------------------------------
-ATTR HsTokens HsToken [ | | usedFields USE {Seq.><} {Seq.empty} : {Seq Identifier} ]
-
-SEM HsToken
-  | AGLocal lhs.usedFields = if @var `elem` @lhs.fieldnames
-                              then Seq.singleton @var
-                              else Seq.empty
-SEM HsTokensRoot
-  | HsTokensRoot lhs.usedFields = toList @tokens.usedFields
-
--------------------------------------------------------------------------------
---  Pretty printing
--------------------------------------------------------------------------------
-
-SEM HsTokensRoot
-  | HsTokensRoot lhs.textLines = showTokens @tokens.tks
-
-SEM HsTokens [ || tks : {[(Pos,String)]} ]
-  | Cons lhs.tks = @hd.tok : @tl.tks
-  | Nil  lhs.tks = []
-
-SEM HsToken [ || tok:{(Pos,String)}]
-   | AGField
-       loc.addTrace = case @rdesc of
-                        Just d  -> \x -> "(trace " ++ show (d ++ " -> " ++ show @field ++ "." ++ show @attr) ++ " (" ++ x ++ "))"
-                        Nothing -> id
-       lhs.tok = (@pos, @loc.addTrace $ attrname @lhs.options True @field @attr)
-
-   | HsToken lhs.tok = (@pos, @value)
-
-   | CharToken lhs.tok = (@pos, if null @value
-                                   then ""
-                                   else showCharShort (head @value)
-                         )
-
-   | StrToken  lhs.tok = (@pos, showStrShort @value)
-   | Err       lhs.tok = (@pos, "")
-
--------------------------------------------------------------------------------
---  Desugar (resolve AGLocals to explicit AGFields)
--------------------------------------------------------------------------------
-
-ATTR HsTokensRoot [ | | output : {[HsToken]} ]
-ATTR HsTokens HsToken [ | | output : SELF ]
-
+INCLUDE "HsToken.ag"++imports+{+import qualified Data.Sequence as Seq+import Data.Sequence(Seq,empty,singleton,(><))+import Data.Foldable(toList)+import Pretty++import TokenDef+import HsToken+import ErrorMessages+}++ATTR HsTokensRoot+     [+     | |+       errors    USE {Seq.><} {Seq.empty}:{Seq Error}+       usedLocals:{[Identifier]}+       usedAttrs :{[(Identifier,Identifier)]}+       textLines  :{[String]}+       usedFields:{[Identifier]}+     ]++-------------------------------------------------------------------------------+--  Context information+-------------------------------------------------------------------------------+ATTR HsTokensRoot+     HsTokens HsToken [ nt,con    : {Identifier}+                        allfields : {[(Identifier,Type,ChildKind)]}+                        allnts    : {[Identifier]}+                        attrs     : {[(Identifier,Identifier)]}+                        options   : {Options}+                      ||+                      ]++ATTR HsTokens HsToken [ fieldnames : {[Identifier]} | | ]+SEM HsTokensRoot+  | HsTokensRoot tokens.fieldnames = map (\(n,_,_) -> n) @lhs.allfields++-------------------------------------------------------------------------------+--  Errors+-------------------------------------------------------------------------------+ATTR HsTokens HsToken [ | |  errors USE {Seq.><} {Seq.empty}:{Seq Error}  ]++-------------------------------------------------------------------------------+-- Syntax errors+-------------------------------------------------------------------------------++SEM HsToken+  | Err lhs.errors = let m = text @mesg+                     in Seq.singleton (CustomError False @pos m)++-------------------------------------------------------------------------------+--  Undefined variables+-------------------------------------------------------------------------------++{+isNTname allnts (Just (NT nt _ _)) = nt `elem` allnts+isNTname allnts _                  = False+}+++-- An AGLocal is either a local variable or a terminal+SEM HsToken+  | AGLocal   loc.tkAsLocal = AGLocal @var @pos @rdesc        -- refers to the terminal+              loc.tkAsField = AGField _LOC @var @pos @rdesc   -- refers to the (local) attribute+              loc.(errors,output,tok,usedLocals) =+                     if @var `elem` @lhs.fieldnames   -- check if @var occurs as a terminal+                     then if  isNTname @lhs.allnts (lookup @var (map (\(n,t,_) -> (n,t)) @lhs.allfields))+                          then (Seq.singleton(ChildAsLocal @lhs.nt @lhs.con @var), @loc.tkAsLocal,(@pos,fieldname @var), []    )+                          else (Seq.empty, @loc.tkAsLocal, (@pos,fieldname @var), []    )+                     else if (_LOC,@var) `elem` @lhs.attrs+                          then (Seq.empty                                      , @loc.tkAsField, (@pos,locname @lhs.options @var), [@var])+                          else (Seq.singleton(UndefLocal @lhs.nt @lhs.con @var), @loc.tkAsField, (@pos,locname @lhs.options @var), []    )++SEM HsToken+  | AGField   lhs.errors = if (@field,@attr) `elem` @lhs.attrs+                           then Seq.empty+                           else if not(@field `elem` (_LHS : _LOC: @lhs.fieldnames))+                                then Seq.singleton (UndefChild @lhs.nt @lhs.con @field)+                                else Seq.singleton (UndefAttr @lhs.nt @lhs.con @field @attr False)++-------------------------------------------------------------------------------+--         Used variables+-------------------------------------------------------------------------------++ATTR HsTokens HsToken [ | | usedLocals USE {++} {[]} : {[Identifier]}+                            usedAttrs  USE {++} {[]} : {[(Identifier,Identifier)]} ]++SEM HsToken+  | AGField (lhs.usedAttrs,lhs.usedLocals)+              = if @field == _LOC+                then ([], [@attr])+                else ([(@field,@attr)], [])+++-------------------------------------------------------------------------------+--         Used fields+-------------------------------------------------------------------------------+ATTR HsTokens HsToken [ | | usedFields USE {Seq.><} {Seq.empty} : {Seq Identifier} ]++SEM HsToken+  | AGLocal lhs.usedFields = if @var `elem` @lhs.fieldnames+                              then Seq.singleton @var+                              else Seq.empty+SEM HsTokensRoot+  | HsTokensRoot lhs.usedFields = toList @tokens.usedFields++-------------------------------------------------------------------------------+--  Pretty printing+-------------------------------------------------------------------------------++SEM HsTokensRoot+  | HsTokensRoot lhs.textLines = showTokens @tokens.tks++SEM HsTokens [ || tks : {[(Pos,String)]} ]+  | Cons lhs.tks = @hd.tok : @tl.tks+  | Nil  lhs.tks = []++SEM HsToken [ || tok:{(Pos,String)}]+   | AGField+       loc.addTrace = case @rdesc of+                        Just d  -> \x -> "(trace " ++ show (d ++ " -> " ++ show @field ++ "." ++ show @attr) ++ " (" ++ x ++ "))"+                        Nothing -> id+       lhs.tok = (@pos, @loc.addTrace $ attrname @lhs.options True @field @attr)++   | HsToken lhs.tok = (@pos, @value)++   | CharToken lhs.tok = (@pos, if null @value+                                   then ""+                                   else showCharShort (head @value)+                         )++   | StrToken  lhs.tok = (@pos, showStrShort @value)+   | Err       lhs.tok = (@pos, "")++-------------------------------------------------------------------------------+--  Desugar (resolve AGLocals to explicit AGFields)+-------------------------------------------------------------------------------++ATTR HsTokensRoot [ | | output : {[HsToken]} ]+ATTR HsTokens HsToken [ | | output : SELF ]+
+ src-ag/TfmToMirage.ag view
@@ -0,0 +1,100 @@+INCLUDE "AbstractSyntax.ag"+INCLUDE "Expression.ag"+INCLUDE "Order.ag" -- for dependencies++imports {+import AbstractSyntax+import qualified Data.Map as Map+import Pretty+import TokenDef+import qualified MirageSyntax as Mirage+}++{+typeToMirage :: Type -> Mirage.Type+typeToMirage x = case x of+  Haskell y -> Mirage.Haskell y+  NT y ys _ -> Mirage.NT (getName y) ys+  Self      -> Mirage.Self+}++SEM Grammar [ || mirage:{Mirage.Grammar} ]+  | Grammar lhs.mirage = Mirage.Grammar @nonts.mirages++SEM Nonterminals [ || mirages:{[Mirage.Nonterminal]} ]+  | Cons lhs.mirages = @hd.mirage : @tl.mirages+  | Nil  lhs.mirages = []++SEM Nonterminal [ || mirage:{Mirage.Nonterminal} ]+  | Nonterminal lhs.mirage+      = Mirage.Nonterminal+          (getName @nt)+          (map getName @params)+          (Map.foldrWithKey (\k x xs -> Mirage.Attribute (getName k) (typeToMirage x) : xs) [] @inh)+          (Map.foldrWithKey (\k x xs -> Mirage.Attribute (getName k) (typeToMirage x) : xs) [] @syn)+          @prods.mirages++SEM Productions [ || mirages:{[Mirage.Production]} ]+  | Cons lhs.mirages = @hd.mirage : @tl.mirages+  | Nil  lhs.mirages = []++SEM Production [ || mirage:{Mirage.Production} ]+  | Production lhs.mirage+      = Mirage.Production (getName @con) @children.mirages @rules.mirages++SEM Children [ || mirages:{[Mirage.Child]} ]+  | Cons lhs.mirages = @hd.mirage : @tl.mirages+  | Nil  lhs.mirages = []++SEM Child [ || mirage:{Mirage.Child} ]+  | Child lhs.mirage = Mirage.Child (getName @name) (typeToMirage @tp)++SEM Rules [ || mirages:{[Mirage.Rule]} ]+  | Cons lhs.mirages = @hd.mirage : @tl.mirages+  | Nil  lhs.mirages = []++-- Partly from Order++SEM Rule [ || mirage:{Mirage.Rule} ]+  | Rule lhs.mirage+      = Mirage.Rule+          [Mirage.Address (getName field) (getName attr) | (field,attr,_) <- @pattern.patternAttrs]+          ([Mirage.Address (getName field) (getName attr) | (field,attr) <- @rhs.usedAttrs]+            ++ [ Mirage.Address (getName _LOC) (getName attr) | attr <- @rhs.usedLocals ++ @rhs.usedFields])+          @explicit+          @origin+          (disp (@pattern.pp >-< indent 1 (text "= " >|< vlist @rhs.lns)) 0 "")++-- Partly from Visage++SEM Expression [ | | lns : {[String]} ]+  | Expression  lhs.lns = showTokens . tokensToStrings $ @tks++-- From PrintCode++SEM Patterns [ | | pps : {[PP_Doc]} ]+  | Cons lhs.pps = @hd.pp : @tl.pps+  | Nil  lhs.pps = []++SEM Pattern [ | | pp:PP_Doc ]+  | Constr  lhs.pp     = pp_parens $ @name >#< hv_sp @pats.pps+  | Product lhs.pp     = pp_block "(" ")" "," @pats.pps+  | Alias   loc.ppVar  = pp @field >|< "." >|< pp @attr+            loc.ppVarBang = @loc.ppVar+            lhs.pp     = if @pat.isUnderscore+                          then @loc.ppVarBang+                          else @loc.ppVarBang >|< "@" >|< @pat.pp+  | Irrefutable lhs.pp = text "~" >|< pp_parens @pat.pp+  | Underscore lhs.pp  = text "_"++SEM Pattern [ | | isUnderscore:{Bool}]+ | Constr      lhs.isUnderscore = False+ | Product     lhs.isUnderscore = False+ | Alias       lhs.isUnderscore = False+ | Underscore  lhs.isUnderscore = True++ATTR Pattern Patterns [ belowIrrefutable : Bool | | ]+SEM Rule+  | Rule pattern.belowIrrefutable = False+SEM Pattern+  | Irrefutable pat.belowIrrefutable = True
src-ag/TfmToVisage.ag view
@@ -1,147 +1,147 @@--- !!!! The Visage AST does not support nonterminals with type variables!
--- !!!! Type variables in data type declarations are ignored.
-
-INCLUDE "AbstractSyntax.ag"
-INCLUDE "Patterns.ag"
-INCLUDE "Expression.ag"
-INCLUDE "DistChildAttr.ag"
-
-imports {
-import AbstractSyntax
-import VisagePatterns
-import VisageSyntax
-import qualified Data.Map as Map
-import Data.Map (Map)
-}
-
-{
--- 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
-
--}
-}
-
-
-ATTR Expression Pattern Patterns [ | | self : SELF ]
-
-ATTR Grammar  [ || visage:{VisageGrammar} ]
-ATTR Nonterminal  [ || vnont:{VisageNonterminal} ]
-ATTR Nonterminals  [ || vnonts:{[VisageNonterminal]} ]
-ATTR Production  [ || vprod:{VisageProduction} ]
-ATTR Productions  [ || vprods:{[VisageProduction]} ]
-ATTR Rule [ || vrule : {VisageRule} ]
-ATTR Rules [ || vrules : {[VisageRule]} ]
-ATTR Child    [ rulemap : {VisageRuleMap} || vchild:{VisageChild} ]
-ATTR Children [ rulemap : {VisageRuleMap} || vchildren:{[VisageChild]} ]
-ATTR Pattern [ || vpat:{VisagePattern} ]
-ATTR Patterns [ || vpats: {[VisagePattern]} ]
-
-SEM Grammar
-  | Grammar
-      lhs.visage = VGrammar @nonts.vnonts
-
-SEM Nonterminals
-  | Cons
-      lhs.vnonts = @hd.vnont : @tl.vnonts
-  | Nil
-      lhs.vnonts = []
-
-SEM Nonterminal
-  | Nonterminal
-      lhs.vnont = VNonterminal @nt @inh @syn @prods.vprods
-
-SEM Productions
-  | Cons
-      lhs.vprods = @hd.vprod : @tl.vprods
-  | Nil
-      lhs.vprods = []
-
-SEM Production
-  | Production
-      lhs.vprod        = VProduction @con @children.vchildren @lhsrules @locrules
-      loc.splitVRules  = splitVRules @rules.vrules
-      loc.locrules     = getForField "loc" @splitVRules
-      loc.lhsrules     = getForField "lhs" @splitVRules
-      children.rulemap = @splitVRules
-
-SEM Children
-  | Cons        lhs.vchildren = @hd.vchild : @tl.vchildren
-  | Nil         lhs.vchildren = []
-
-SEM Child
-  | Child lhs.vchild = VChild @name @tp @loc.inh @loc.syn (getForField (getName @name) @lhs.rulemap)
-
-SEM Rules
-  | Cons        lhs.vrules = @hd.vrule : @tl.vrules
-  | Nil         lhs.vrules = []
-
--- The undefined may seem strange, but it really belongs there.
-SEM Rule
-  | Rule  lhs.vrule  = VRule @pattern.fieldattrs undefined @pattern.vpat @rhs.self @owrt
-
-SEM Patterns
-  | Cons        lhs.vpats = @hd.vpat : @tl.vpats
-  | Nil         lhs.vpats = []
-
-SEM Pattern
-  | Constr      lhs.vpat = VConstr @name @pats.vpats
-  | Product     lhs.vpat = VProduct @pos @pats.vpats
-  | Alias       lhs.vpat = if (isVar @self)
-                           then VVar @field @attr
-                           else VAlias @field @attr @pat.vpat
-  | Underscore  lhs.vpat = VUnderscore @pos
-
--- All (field,attrs) in a pattern
-ATTR Patterns -> Pattern [ | | fieldattrs USE { ++ } { [] } : { [(Identifier,Identifier)] } ]
-
-SEM Pattern
-  | Alias       lhs.fieldattrs = [(@field, @attr)]
+-- !!!! The Visage AST does not support nonterminals with type variables!+-- !!!! Type variables in data type declarations are ignored.++INCLUDE "AbstractSyntax.ag"+INCLUDE "Patterns.ag"+INCLUDE "Expression.ag"+INCLUDE "DistChildAttr.ag"++imports {+import AbstractSyntax+import VisagePatterns+import VisageSyntax+import qualified Data.Map as Map+import Data.Map (Map)+}++{+-- 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++-}+}+++ATTR Expression Pattern Patterns [ | | self : SELF ]++ATTR Grammar  [ || visage:{VisageGrammar} ]+ATTR Nonterminal  [ || vnont:{VisageNonterminal} ]+ATTR Nonterminals  [ || vnonts:{[VisageNonterminal]} ]+ATTR Production  [ || vprod:{VisageProduction} ]+ATTR Productions  [ || vprods:{[VisageProduction]} ]+ATTR Rule [ || vrule : {VisageRule} ]+ATTR Rules [ || vrules : {[VisageRule]} ]+ATTR Child    [ rulemap : {VisageRuleMap} || vchild:{VisageChild} ]+ATTR Children [ rulemap : {VisageRuleMap} || vchildren:{[VisageChild]} ]+ATTR Pattern [ || vpat:{VisagePattern} ]+ATTR Patterns [ || vpats: {[VisagePattern]} ]++SEM Grammar+  | Grammar+      lhs.visage = VGrammar @nonts.vnonts++SEM Nonterminals+  | Cons+      lhs.vnonts = @hd.vnont : @tl.vnonts+  | Nil+      lhs.vnonts = []++SEM Nonterminal+  | Nonterminal+      lhs.vnont = VNonterminal @nt @inh @syn @prods.vprods++SEM Productions+  | Cons+      lhs.vprods = @hd.vprod : @tl.vprods+  | Nil+      lhs.vprods = []++SEM Production+  | Production+      lhs.vprod        = VProduction @con @children.vchildren @lhsrules @locrules+      loc.splitVRules  = splitVRules @rules.vrules+      loc.locrules     = getForField "loc" @splitVRules+      loc.lhsrules     = getForField "lhs" @splitVRules+      children.rulemap = @splitVRules++SEM Children+  | Cons        lhs.vchildren = @hd.vchild : @tl.vchildren+  | Nil         lhs.vchildren = []++SEM Child+  | Child lhs.vchild = VChild @name @tp @loc.inh @loc.syn (getForField (getName @name) @lhs.rulemap)++SEM Rules+  | Cons        lhs.vrules = @hd.vrule : @tl.vrules+  | Nil         lhs.vrules = []++-- The undefined may seem strange, but it really belongs there.+SEM Rule+  | Rule  lhs.vrule  = VRule @pattern.fieldattrs undefined @pattern.vpat @rhs.self @owrt++SEM Patterns+  | Cons        lhs.vpats = @hd.vpat : @tl.vpats+  | Nil         lhs.vpats = []++SEM Pattern+  | Constr      lhs.vpat = VConstr @name @pats.vpats+  | Product     lhs.vpat = VProduct @pos @pats.vpats+  | Alias       lhs.vpat = if (isVar @self)+                           then VVar @field @attr+                           else VAlias @field @attr @pat.vpat+  | Underscore  lhs.vpat = VUnderscore @pos++-- All (field,attrs) in a pattern+ATTR Patterns -> Pattern [ | | fieldattrs USE { ++ } { [] } : { [(Identifier,Identifier)] } ]++SEM Pattern+  | Alias       lhs.fieldattrs = [(@field, @attr)]
src-ag/Transform.ag view
@@ -1,1371 +1,1371 @@-PRAGMA strictdata
-PRAGMA strictwrap
-
-INCLUDE "ConcreteSyntax.ag"
-INCLUDE "Patterns.ag"
-
-imports
-{
-import Control.Monad(mplus,mzero)
-import Data.List (partition, nub,intersperse, union)
-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, elems)
-import qualified Data.Sequence as Seq
-import Data.Sequence(Seq, (><))
-import UU.Scanner.Position(noPos)
-
-import ConcreteSyntax
-import AbstractSyntax
-import ErrorMessages
-import Patterns (Patterns,Pattern(..))
-import Expression (Expression(..))
-import HsToken
-
-import RhsCheck
-import Debug.Trace
-}
-
-
--------------------------------------------------------------------------------
---  Main goal
--------------------------------------------------------------------------------
-
--- Given some options, we want to construct a Grammar, that is, a structure that conforms to AbstractSyntax
-ATTR AG [ | | output : Grammar ]
-ATTR AG Elems Elem SemAlts SemAlt SemDefs SemDef Attrs [ options : Options | | ]
-
--- as a side effect, we generate error messages and Haskell code blocks that need to be embedded in the final code
-ATTR AG Elems Elem SemAlts SemAlt Attrs NontSet ConstructorSet SemDefs SemDef
-     [ | | errors USE {Seq.><}{Seq.empty}:{Seq Error} ]
-ATTR AG Elems Elem
-     [ | | blocks USE {`mapUnionWithPlusPlus`} {Map.empty}: {Blocks} ]
-
-
--- The output is produced by calling a function that constructs the Grammar,
--- given various datastructures that are collected from the concrete AG.
-
-SEM AG
-  | AG lhs.output = constructGrammar @loc.allNonterminals
-                                     @elems.paramsCollect
-                                     @loc.allConParams
-                                     @loc.allFields
-                                     @loc.prodOrder
-                                     @loc.allConstraints
-                                     @loc.allAttrDecls
-                                     @elems.useMap
-                                     @elems.derivings
-                                     (if wrappers @lhs.options then @loc.allNonterminals else @elems.wrappers)
-                                     @loc.checkedRules
-                                     @loc.checkedSigs
-                                     @loc.checkedInsts
-                                     @elems.typeSyns
-                                     @elems.semPragmasCollect
-                                     @elems.attrOrderCollect
-                                     @elems.ctxCollect
-                                     @elems.quantCollect
-                                     @loc.checkedUniques
-                                     @loc.checkedAugments
-                                     @loc.checkedArounds
-                                     @loc.checkedMerges
-                                     @loc.allMacros
-
-
--------------------------------------------------------------------------------
---  Main data flow
--------------------------------------------------------------------------------
-
-{- Information is collected bottom-up (in multiple phases)
-   After checking for consistency, datastructures are createad from it,
-   which are passed down for the other phases.
--}
-
-
--- Names that are in use
-
-  -- bottom-up collection
-ATTR Elem Elems          [ | | collectedSetNames USE {`Set.union`} {Set.empty} : {Set Identifier} ]
-ATTR Elem Elems NontSet  [ | | collectedNames    USE {`Set.union`} {Set.empty} : {Set Identifier} ]
-  -- top-down distribution
-ATTR Elem Elems Attrs Alts Alt Fields Field NontSet [ allNonterminals : {Set NontermIdent} | | ]
-
-
--- Constructors that are in use
-  -- bottom-up collection
-ATTR Alt Alts ConstructorSet [ | | collectedConstructorNames USE {`Set.union`} {Set.empty} : {Set ConstructorIdent} ]
-ATTR Elem Elems [ | | collectedConstructorsMap USE {`mapUnionWithSetUnion`} {Map.empty} : {Map NontermIdent (Set ConstructorIdent)} ]
-  -- top-down distribution
-ATTR Elem Elems Alts Alt [ allConstructors : {Map NontermIdent (Set ConstructorIdent)} | | ]
-
-
-
--- Nonterminal sets that are defined
-{type DefinedSets = Map Identifier (Set NontermIdent) }
-  -- bottom-up collection
-ATTR Elem Elems
-     [ | defSets:{Map Identifier (Set NontermIdent,Set Identifier)} | ]
-  -- top-down distribution
-ATTR Elem Elems NontSet
-     [ definedSets:{DefinedSets} | | ]
-
-
-
--- Interpreting nonterminal sets
-ATTR NontSet [ | | nontSet   : {Set NontermIdent} ]
-
-
--- Interpreting constructor sets
-ATTR ConstructorSet  [ | | constructors : {(Set ConstructorIdent->Set ConstructorIdent)} ]
-
-
-
--- Contextfree structure
-{type FieldMap  = [(Identifier, Type)] }
-{type DataTypes = Map.Map NontermIdent (Map.Map ConstructorIdent FieldMap) }
-  -- bottom-up collection
-ATTR Alt Alts Elem Elems
-     [ | | collectedFields USE {++} {[]} : {[(NontermIdent, ConstructorIdent, FieldMap)]}
-           collectedConstraints USE {++} {[]} : {[(NontermIdent, ConstructorIdent, [Type])]}
-           collectedConParams USE {++} {[]} : {[(NontermIdent, ConstructorIdent, Set Identifier)]}
-     ]
-  -- top-down distribution
-ATTR Elem Elems Attrs SemAlt SemAlts NontSet
-     [  allFields : {DataTypes} | | ]
-
-
-
--- Attribute declarations
-  -- bottom-up collection
-ATTR Elems Elem Attrs
-     [
-     | attrDecls:{Map NontermIdent (Attributes, Attributes)}
-     | useMap USE {`merge`} {Map.empty}:{Map NontermIdent (Map Identifier (String,String,String))}
-     ]
-
-
--- Attribute definitions
-{type AttrName   = (Identifier,Identifier) }
-{type RuleInfo   = (Maybe Identifier, [AttrName]->Pattern, Expression, [AttrName], Bool, String, Bool, Bool) }
-{type SigInfo    = (Identifier,Type) }
-{type UniqueInfo = (Identifier,Identifier) }
-{type AugmentInfo = (Identifier,Expression)}
-{type AroundInfo  = (Identifier,Expression)}
-{type MergeInfo   = (Identifier, Identifier, [Identifier], Expression)}
-  -- bottom-up collection
-ATTR Elem Elems SemAlt SemAlts
-     [ | |   collectedRules    USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, RuleInfo)]}
-             collectedSigs     USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, SigInfo) ]}
-             collectedInsts    USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, [Identifier]) ]}
-             collectedUniques  USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, [UniqueInfo]) ]}
-             collectedAugments USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, [AugmentInfo]) ]}
-             collectedArounds  USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, [AroundInfo])  ]}
-             collectedMerges   USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, [MergeInfo])   ]}
-     ]
-
-
-
--------------------------------------------------------------------------------
---         Passing nonterminals
--------------------------------------------------------------------------------
-
--- Pass the name of the associated nonterminal to everyone
-ATTR Alt Alts SemAlt SemAlts [ nts:{Set NontermIdent} | | ]
-
-SEM Elem
-  | Data alts.nts = @names.nontSet
-  | Sem  alts.nts = @names.nontSet
-
-
-
--------------------------------------------------------------------------------
---         Calculation of code blocks                                        --
--------------------------------------------------------------------------------
-
-SEM Elem
-  | Txt  loc.blockInfo  = ( @kind
-                          , @mbNt
-                          )
-         loc.blockValue = [(@lines, @pos)]
-         lhs.blocks     = Map.singleton @loc.blockInfo @loc.blockValue
-         lhs.errors     = if checkParseBlock @lhs.options
-                          then let ex  = Expression @pos tks
-                                   tks = [tk]
-                                   tk  = HsToken (unlines @lines) @pos
-                               in Seq.fromList $ checkBlock $ ex
-                          else Seq.empty
-
-
--------------------------------------------------------------------------------
---         Check for duplicates and report error
--------------------------------------------------------------------------------
-
-{
-
-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.singleton (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 :: (b -> t -> (t, Seq Error)) -> t -> [b] -> (t, Seq Error)
-foldErrors f n xs = foldl g (n,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 _ [] = []
-checkForDuplicates err (x:xs) = let (same,other) = partition (equalId x) xs
-                                in  map (err x) same ++ checkForDuplicates err other
-
-equalId :: Identifier -> Identifier -> Bool
-equalId x y = getName x == getName y
-
-}
-
--------------------------------------------------------------------------------
---         Collecting DATA's and type synonyms
--------------------------------------------------------------------------------
-
-
-SEM Alt
-  | Alt  lhs.collectedFields  =       [ (nt, con, @fields.collectedFields)
-                                      | nt  <- Set.toList @lhs.nts
-                                      , con <- Set.toList (@names.constructors (Map.findWithDefault Set.empty nt @lhs.allConstructors))
-                                      ]
-         lhs.collectedConstraints =   [ (nt, con, @fields.collectedConstraints)
-                                      | nt  <- Set.toList @lhs.nts
-                                      , con <- Set.toList (@names.constructors (Map.findWithDefault Set.empty nt @lhs.allConstructors))
-                                      ]
-         lhs.collectedConParams   =   [ (nt, con, Set.fromList @tyvars)
-                                      | nt  <- Set.toList @lhs.nts
-                                      , con <- Set.toList (@names.constructors (Map.findWithDefault Set.empty nt @lhs.allConstructors))
-                                      ]
-
-SEM Elem
-  | Type lhs.collectedFields = map (\(x,y)->(@name, x, y)) @loc.expanded
-
-SEM AG
-  | AG
-         loc.prodOrder   = let f (nt,con,_) = Map.insertWith g nt [con]
-                               g [con] lst | con `elem` lst = lst
-                                           | otherwise      = con : lst
-                               g _ _ = error "This is not possible"
-                           in  foldr f Map.empty @elems.collectedFields
-         loc.allFields   = let f (nt,con,fm) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con fm)
-                           in  foldr f (Map.empty) @elems.collectedFields
-
-         loc.allConstraints = let f (nt,con,fm) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con fm)
-                              in  foldr f (Map.empty) @elems.collectedConstraints
-
-         loc.allConParams   = let f (nt,con,fm) = Map.insertWith (Map.unionWith Set.union) nt (Map.singleton con fm)
-                              in  foldr f (Map.empty) @elems.collectedConParams
-
-         loc.allConstrs  = let f (nt,con,_) = Map.insertWith (++) nt [con]
-                           in  foldr f (Map.empty) @elems.collectedFields
-
-         loc.allRules    = let f (nt,con,r) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con [r])
-                           in  foldr f (Map.empty) @elems.collectedRules
-
-         loc.allSigs     = let f (nt,con,t) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con [t])
-                               typeof nt r = Map.findWithDefault (Haskell "<unknown>") r $ fst $ Map.findWithDefault (Map.empty,Map.empty) nt @loc.allAttrDecls
-                           in  foldr f (Map.empty) ( @elems.collectedSigs
-                                                   ++ [ (nt, con, (ident,typeof nt ref))  | (nt, con, us) <- @elems.collectedUniques, (ident,ref) <- us ]
-                                                   )
-
-         loc.allInsts    = let f (nt,con,is) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con is)
-                           in  foldr f (Map.empty) @elems.collectedInsts
-
-         loc.allUniques  = let f (nt,con,us) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con us)
-                           in foldr f (Map.empty) @elems.collectedUniques
-         loc.allAugments = let f (nt,con,as) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con as)
-                           in foldr f Map.empty @elems.collectedAugments
-         loc.allArounds  =  let f (nt,con,as) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con as)
-                            in foldr f Map.empty @elems.collectedArounds
-         loc.allMerges   =  let f (nt,con,as) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con as)
-                             in foldr f Map.empty @elems.collectedMerges
-
-         loc.augmentSigs    = let gen _ = []  -- TODO: generate type signatures here for the augments
-                              in Map.map (Map.map gen) @loc.allAugments
-
-         loc.allRulesErrs   = Map.mapWithKey (Map.mapWithKey . (checkRules @allAttrDecls @allFields @allInsts @loc.allSigs @loc.allMerges)) @loc.allRules
-         loc.allNamesErrs   = Map.mapWithKey (Map.mapWithKey . checkRuleNames) @loc.allRules
-         loc.allSigsErrs    = Map.mapWithKey (Map.mapWithKey . (checkSigs                                                 )) @loc.allSigs
-         loc.allInstsErrs   = Map.mapWithKey (Map.mapWithKey . (checkInsts @loc.allNonterminals @loc.allSigs @allFields   )) @loc.allInsts
-         loc.allUniquesErrs = Map.mapWithKey (Map.mapWithKey . (checkUniques @allAttrDecls                                )) @loc.allUniques
-         loc.allAugmentErrs = Map.mapWithKey (Map.mapWithKey . (checkAugments @allAttrDecls                               )) @loc.allAugments
-         loc.allAroundsErrs = Map.mapWithKey (Map.mapWithKey . (checkArounds @loc.allFields)) @loc.allArounds
-         loc.allMergesErrs  = Map.mapWithKey (Map.mapWithKey . (checkMerges @loc.allNonterminals @loc.allInsts @loc.allFields)) @loc.allMerges
-
-         loc.checkedRulesPre = Map.map (Map.map fst) @loc.allRulesErrs
-         loc.checkedSigs     = Map.map (Map.map fst) @loc.allSigsErrs `unionunionplusplus` @loc.augmentSigs
-         loc.checkedInsts    = Map.map (Map.map fst) @loc.allInstsErrs
-         loc.checkedUniques  = Map.map (Map.map fst) @loc.allUniquesErrs
-         loc.checkedAugments = Map.map (Map.map fst) @loc.allAugmentErrs
-         loc.checkedArounds  = Map.map (Map.map fst) @loc.allAroundsErrs
-         loc.checkedRules    = Map.unionWith (Map.unionWith (++)) @loc.checkedRulesPre (Map.mapWithKey (Map.mapWithKey . (mkUniqueRules @lhs.options @loc.allRules @loc.allFields @loc.checkedInsts @loc.allAttrDecls)) @loc.checkedUniques)
-         loc.checkedMerges   = Map.map (Map.map fst) @loc.allMergesErrs
-
-         loc.errs1       = let f = checkForDuplicates (DupSynonym)
-                           in  Seq.fromList . f . map fst $ @elems.typeSyns  -- forbid duplicate type synonyms
-
-         loc.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    -- forbid duplicate fields
-
-         loc.errs3       = let -- f (nt,cons) = checkForDuplicates (DupAlt nt) cons
-                           in   Seq.empty                                                 -- allow duplicate constructors, merging their fields
-                             -- Seq.fromList . concat . map f . Map.toList $ @allConstrs  -- forbid duplicate constructors
-
-         loc.errs4       = let  f m s = Map.foldr ((><) . snd) s m
-                           in Map.foldr f Seq.empty @loc.allRulesErrs
-
-         loc.errs5       = let  f m s = Map.foldr ((><) . snd) s m
-                           in Map.foldr f Seq.empty @loc.allSigsErrs
-
-         loc.errs6       = let  f m s = Map.foldr ((><) . snd) s m
-                           in Map.foldr f Seq.empty @loc.allInstsErrs
-
-         loc.errs7       = let  f m s = Map.foldr ((><) . snd) s m
-                           in Map.foldr f Seq.empty @loc.allUniquesErrs
-
-         loc.errs8       = let  f m s = Map.foldr ((><) . snd) s m
-                           in Map.foldr f Seq.empty @loc.allAugmentErrs
-
-         loc.errs9       = let  f m s = Map.foldr ((><) . snd) s m
-                           in Map.foldr f Seq.empty @loc.allAroundsErrs
-
-         loc.errs10      =  let  f m s = Map.foldr ((><)) s m
-                            in Map.foldr f Seq.empty @loc.allNamesErrs
-
-         loc.errs11      =  let f m s = Map.foldr ((><) . snd) s m
-                            in Map.foldr f Seq.empty @loc.allMergesErrs
-
-         lhs.errors      = @elems.errors >< @errs1 >< @errs2 >< @errs3 >< @errs4 >< @errs5 >< @errs6 >< @errs7 >< @errs8 >< @errs9 >< @errs10 >< @errs11
-
-{
-type RulesAndErrors = ([Rule], Seq Error)
-type SigsAndErrors  = ([TypeSig], Seq Error)
-type InstsAndErrors = ([(Identifier, Type)], Seq Error)
-type UniquesAndErrors = (Map Identifier Identifier, Seq Error)
-type AugmentsAndErrors = (Map Identifier [Expression], Seq Error)
-type AroundsAndErrors = (Map Identifier [Expression], Seq Error)
-type MergesAndErrors  = (Map Identifier (Identifier, [Identifier], Expression), Seq Error)
-type AttrOverwrite  = Map AttrName Bool
-type AccumRuleCheck = (RulesAndErrors, AttrOverwrite)
-type AccumDefiCheck = (Seq Error, AttrOverwrite, [AttrName], [AttrName])
-
-checkRules :: Map NontermIdent (Attributes, Attributes) -> DataTypes ->
-              Map NontermIdent (Map ConstructorIdent [Identifier]) -> Map NontermIdent (Map ConstructorIdent [SigInfo]) ->
-              Map NontermIdent (Map ConstructorIdent [MergeInfo]) ->
-              NontermIdent -> ConstructorIdent -> [RuleInfo] -> RulesAndErrors
-checkRules attributes fields allinsts allsigs _ nt con rs
-  = let fieldmap :: FieldMap
-        fieldmap = (_LHS, NT nt [] False) : (_LOC, NT nullIdent [] False) : (_INST, NT nullIdent [] False) : (_FIRST, NT nullIdent [] False) : (_LAST, NT nullIdent [] False)
-                 : 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))
-                 --   merged children are not allowed to have any inherited attrs defined: do not include
-
-        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 (mbNm, pat,ex,as,owrt,str, pur, eager) ((r1,e1),m1)
-          = let (e2,m2,u2,_) = foldr (checkDefi owrt) (e1,m1,[],[]) as
-            in  ( (Rule mbNm (pat u2) ex owrt str True pur False Nothing eager : 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 _ _) ->
-                  let tp' = maybe tp id (deforestedNt tp)
-                  in              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.<|)) (DupRule nt con field attr2 attr)   e,                    m, fa:u,    bs)
-                                           Nothing ->           (                                             e, Map.insert fa owrt m,    u, fa:bs)
-                                  else                          (((Seq.<|)) (SuperfluousRule nt con field attr) e,                    m, fa:u,    bs)
-                _              ->                               (((Seq.<|)) (UndefChild nt con field)           e,                    m, fa:u,    bs )
-
-    in  fst (foldr checkRule (([],Seq.empty),Map.empty) rs)
-
-checkRuleNames :: NontermIdent -> ConstructorIdent -> [RuleInfo] -> Seq Error
-checkRuleNames nt con
-  = fst . foldr checkRule (Seq.empty, Set.empty)
-  where
-    checkRule (Just nm,_,_,_,_,_,_,_) (errs, nms)
-      | nm `Set.member` nms = (DupRuleName nt con nm Seq.<| errs, nms)
-      | otherwise           = (errs, Set.insert nm nms)
-    checkRule (Nothing,_,_,_,_,_,_,_) inp = inp
-
-checkSigs :: NontermIdent -> ConstructorIdent -> [SigInfo] -> SigsAndErrors
-checkSigs nt con sis
-  = let checkSig (ide,typ) (sigs,errs)
-         = if   ide `elem` map (\(TypeSig n _)-> n) sigs
-           then (sigs, ((Seq.<|)) (DupSig nt con ide) errs)
-           -- else if not (ide `elem` locattrdefs)
-           -- then (sigs, ((Seq.<|)) (SupSig nt con ide) errs)
-           else (TypeSig ide typ:sigs, errs)
-    in  foldr checkSig ([],Seq.empty) sis
-
-checkInsts :: Set NontermIdent -> Map NontermIdent (Map ConstructorIdent [SigInfo]) -> DataTypes -> NontermIdent -> ConstructorIdent -> [Identifier] -> InstsAndErrors
-checkInsts allNts sigMap _ nt con
-  = foldr (\inst (insts, errs) ->
-              maybe (insts, Seq.singleton (MissingInstSig nt con inst) >< errs)
-                    (\info@(k, NT nm args _) ->
-                      case findInst k insts of
-                        Just k' -> (insts, Seq.singleton (DupChild nt con k k') >< errs)
-                        Nothing -> case nm `Set.member` allNts of
-                                             True  -> (info : insts, errs)
-                                             False | take 2 (getName nm) == "T_" -> let nm'   = Ident (drop 2 (getName nm)) (getPos nm)
-                                                                                        info' = (k, NT nm' args True)   -- this should be the only place at which 'for' with value True can be generated
-                                                                                    in case nm' `Set.member` allNts of
-                                                                                         True  -> (info' : insts, errs)
-                                                                                         False -> (insts, Seq.singleton (UndefNont nm') >< errs)
-                                                   | otherwise                   -> (insts, Seq.singleton (UndefNont nm) >< 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)
-
-    findInst _ [] = Nothing
-    findInst k ((k', _): r)
-      | k == k'   = Just k'
-      | otherwise = findInst k r
-
-checkUniques :: Map NontermIdent (Attributes, Attributes) -> NontermIdent -> ConstructorIdent -> [UniqueInfo] -> UniquesAndErrors
-checkUniques allAttrs nt con uniques
-  = let checkUnique (ident,ref) (us,errs)
-          = if ident `Map.member` us
-            then (us, ((Seq.<|)) (DupUnique nt con ident) errs)
-            else if Map.member ref inhs && Map.member ref syns
-                 then (Map.insert ident ref us, errs)
-                 else (us, ((Seq.<|)) (MissingUnique nt ref) errs)
-
-        (inhs,syns) = Map.findWithDefault (Map.empty,Map.empty) nt allAttrs
-    in foldr checkUnique (Map.empty, Seq.empty) uniques
-
-checkAugments :: Map NontermIdent (Attributes, Attributes) -> NontermIdent -> ConstructorIdent -> [AugmentInfo] -> AugmentsAndErrors
-checkAugments allAttrs nt _ augments
-  = let checkAugment (ident,expr) (as,errs)
-          = if ident `Map.member` as
-            then (Map.update (\vs -> Just (vs ++ [expr])) ident as, errs)
-            else if Map.member ident syns
-                 then (Map.insert ident [expr] as, errs)
-                 else (as, ((Seq.<|)) (MissingSyn nt ident) errs)
-
-        (_,syns) = Map.findWithDefault (Map.empty,Map.empty) nt allAttrs
-    in foldr checkAugment (Map.empty, Seq.empty) augments
-
-checkArounds :: DataTypes -> NontermIdent -> ConstructorIdent -> [AroundInfo] -> AroundsAndErrors
-checkArounds fieldMap nt con arounds
-  = let checkAround (ident,expr) (as,errs)
-          = if ident `Map.member` as
-            then (Map.update (\vs -> Just (vs ++ [expr])) ident as, errs)
-            else case lookup ident fields of
-                   Just (NT _ _ _) -> (Map.insert ident [expr] as, errs)
-                   _               -> (as, ((Seq.<|)) (UndefChild nt con ident) errs)
-        fields = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt fieldMap)
-    in foldr checkAround (Map.empty, Seq.empty) arounds
-
-checkMerges :: Set NontermIdent -> Map NontermIdent (Map ConstructorIdent [Identifier]) -> DataTypes -> NontermIdent -> ConstructorIdent -> [MergeInfo] -> MergesAndErrors
-checkMerges allNts allInsts fieldMap _ con merges
-  = let checkMerge (target,nt,sources,expr) (m,errs)
-          = let fields = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt fieldMap)
-                insts  = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allInsts)
-                allFields = insts ++ map fst fields   -- note: sources of merge may not contain a target (for simplicity)
-            in if target `Map.member` m   -- check for duplicate with self
-               then (m, DupChild nt con target (fst $ Map.elemAt (Map.findIndex target m) m) Seq.<| errs)
-               else if target `elem` allFields
-                     then (m, DupChild nt con target (head $ filter (== target) allFields) Seq.<| errs)
-                     else let missing = filter (\s -> not (s `elem` allFields)) sources
-                          in if null missing
-                             then if nt `Set.member` allNts   -- check if the nonterm is defined
-                                  then (Map.insert target (nt, sources, expr) m, errs) -- all ok..
-                                  else (m, UndefNont nt Seq.<| errs)
-                             else (m, (Seq.fromList $ map (UndefChild nt con) missing) Seq.>< errs)
-    in foldr checkMerge (Map.empty, Seq.empty) merges
-
-unionunionplusplus :: Map NontermIdent (Map ConstructorIdent [a]) -> Map NontermIdent (Map ConstructorIdent [a]) -> Map NontermIdent (Map ConstructorIdent [a])
-unionunionplusplus = Map.unionWith (Map.unionWith (++))
-}
-
-
-{
-mkUniqueRules :: Options -> Map NontermIdent (Map ConstructorIdent [RuleInfo]) -> DataTypes -> Map NontermIdent (Map ConstructorIdent [(Identifier, Type)]) -> Map NontermIdent (Attributes,Attributes) -> NontermIdent -> ConstructorIdent -> Map Identifier Identifier -> [Rule]
-mkUniqueRules opts allRules allFields allInsts allAttrDecls nt con usMap
-  = map apply groups
-  where
-    fields = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allFields)
-             ++ Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allInsts)
-             -- may have duplicates
-
-    attrDefs = let projectDefs (_,_,_,defs,_,_,_,_) = defs
-               in concatMap projectDefs $ Map.findWithDefault [] con $ Map.findWithDefault Map.empty nt allRules
-
-    groups = Map.assocs $ Map.foldrWithKey (\i r m -> Map.insertWith (++) r [i] m) Map.empty usMap
-    apply (ref,us) = mkRule ref (findOutField ref) us
-    findOutField ref = case [ chld | (chld, NT tp _ _) <- fields, tp `hasSyn` ref] of
-                         []    -> _LHS
-                         (x:_) -> x
-    hasSyn tp ref = Map.member ref $ snd $ Map.findWithDefault (Map.empty,Map.empty) tp allAttrDecls
-    mkRule ref outFld locAttrs
-      = let locs = filter (not . existsLoc) locAttrs
-            outAttr = attr outFld ref
-            defs = (if hasOut then [] else [outAttr]) ++ [attr _LOC u | u <- locs ]
-            pat = Product noPos defs
-            rhs = Expression noPos $ wrap ref $ foldr gencase (finalout hasOut locs) locs
-                     -- [HsToken ("mkUniques" ++ show (length locAttrs) ++ " ") noPos, AGField _LHS ref noPos Nothing]
-            rul = Rule Nothing pat rhs False "-- generated by the unique rule mechanism." False True False Nothing False
-            hasOut = exists outAttr
-            exists (Alias fld a _) = (fld,a) `elem` attrDefs
-            exists _ = False
-            existsLoc nm = exists (attr _LOC nm)
-        in rul
-    attr fld a = Alias fld a (Underscore noPos)
-    gencase nm outp
-      = h ("case " ++ uniqueDispenser opts ++ " __cont of { (__cont, " ++ getName nm ++ ") -> ") ++ outp ++ h "}"
-    h s = [HsToken s noPos]
-    finalout noGenCont us = h ("(" ++ concat (intersperse "," ( (if noGenCont then [] else ["__cont"]) ++ map getName us)) ++ ")")
-    wrap ref inp = h "let __cont = " ++ [AGField _LHS ref noPos Nothing] ++ h " in seq __cont ( " ++ inp ++ h " )"
-}
-
-
--------------------------------------------------------------------------------
---         Checking RHSs of rules (optional)
--------------------------------------------------------------------------------
-
-SEM SemDef | Def MergeDef
-  lhs.errors = if checkParseRhs @lhs.options
-               then Seq.fromList $ checkRhs @rhs
-               else Seq.empty
-
--- type of a type signature
-
-SEM SemDef | TypeDef
-  lhs.errors = if checkParseTy @lhs.options
-               then case @tp of
-                      Haskell s -> let ex  = Expression @pos tks
-                                       tks = [tk]
-                                       tk  = HsToken s @pos
-                                   in Seq.fromList $ checkTy ex
-                      _ -> Seq.empty
-               else Seq.empty
-
--------------------------------------------------------------------------------
---         Collecting fields
--------------------------------------------------------------------------------
-
-ATTR Fields Field [ | | collectedFields USE {++} {[]} : {[(Identifier, Type)]} ]
-
-SEM Field | FChild
-  lhs.collectedFields = [(@name, makeType @lhs.allNonterminals @tp)]
-
--------------------------------------------------------------------------------
---         Collecting constraints
--------------------------------------------------------------------------------
-
-ATTR Fields Field [ | | collectedConstraints USE {++} {[]} : {[Type]} ]
-
-SEM Field | FCtx
-  lhs.collectedConstraints = @tps
-
--------------------------------------------------------------------------------
---         Collecting Set names and Nonterminal names
--------------------------------------------------------------------------------
-
-
-
-SEM Elem
-  | Set  lhs.collectedSetNames = Set.singleton @name
-
-SEM Elem
-  | Type  lhs.collectedNames = Set.singleton @name
-
-SEM NontSet
-  | NamedSet lhs.collectedNames = Set.singleton @name
-
-SEM AG
-  | AG   loc.allNonterminals = @elems.collectedNames `Set.difference` @elems.collectedSetNames
-
-
-
-
-
-
-SEM ConstructorSet
-  | CName lhs.collectedConstructorNames = Set.singleton @name
-
---SEM Alt
---  | Alt lhs.collectedConstructorNames = Set.singleton @name
-
-SEM Elem
-  | Data  lhs.collectedConstructorsMap = Map.fromList
-                                         [ (n, @alts.collectedConstructorNames)
-                                         | n <- Set.toList @names.nontSet
-                                         ]
-
-SEM AG
-  | AG elems.allConstructors = @elems.collectedConstructorsMap
-
-
-
--------------------------------------------------------------------------------
---          Type synonyms
--------------------------------------------------------------------------------
-
-{- At the moment type synonyms are only supported for list types
-   This means that only synonyms of the form:
-      TYPE <NT> = [ <TP> ]
-   are allowed
--}
-
-
-ATTR Elem Elems [ | | typeSyns USE {++} {[]} : {TypeSyns} ]
-
-{- Put this synonym in the typeSyns list and
-   add the implicit Cons and Nil productions for the type synonym
-
-   A synonym of the form:
-        TYPE <NT> = [ <TP> ]
-   is translated into:
-       DATA <NT> | Cons hd:<TP> tl:<NT>
-                 | Nil
--}
-
-SEM Elem
-  | Type  loc.expanded       = case @argType of
-                                       List tp -> [(Ident "Cons" @pos, [(Ident "hd" @pos, tp)
-                                                                       ,(Ident "tl" @pos, NT @name (map getName @params) False)
-                                                                       ]
-                                                   )
-                                                  ,(Ident "Nil" @pos,  [])
-                                                  ]
-                                       Maybe tp -> [(Ident "Just" @pos, [(Ident "just" @pos, tp)
-                                                                       ]
-                                                   )
-                                                  ,(Ident "Nothing" @pos,  [])
-                                                  ]
-                                       Either tp1 tp2 -> [
-                                                    (Ident "Left"    @pos,  [(Ident "left"  @pos, tp1) ])
-                                                  , (Ident "Right"   @pos,  [(Ident "right" @pos, tp2) ])
-                                                  ]
-                                       Map tp1 tp2 -> [ (Ident "Entry" @pos, [ (Ident "key" @pos, tp1)
-                                                                             , (Ident "val" @pos, tp2)
-                                                                             , (Ident "tl" @pos, NT @name (map getName @params) False)
-                                                                             ])
-                                                      , (Ident "Nil" @pos, [])
-                                                      ]
-                                       IntMap tp   -> [ (Ident "Entry" @pos, [ (Ident "key" @pos, Haskell "Int")
-                                                                             , (Ident "val" @pos, tp)
-                                                                             , (Ident "tl" @pos, NT @name (map getName @params) False)
-                                                                             ])
-                                                      , (Ident "Nil" @pos, [])
-                                                      ]
-                                       OrdSet tp   -> [ (Ident "Entry" @pos, [ (Ident "val" @pos, tp)
-                                                                             , (Ident "tl" @pos, NT @name (map getName @params) False) ])
-                                                      , (Ident "Nil" @pos, [])
-                                                      ]
-                                       IntSet      -> [ (Ident "Entry" @pos, [ (Ident "val" @pos, Haskell "Int")
-                                                                             , (Ident "tl" @pos, NT @name (map getName @params) False) ])
-                                                      , (Ident "Nil" @pos, [])
-                                                      ]
-                                       Tuple xs -> [(Ident "Tuple" @pos, xs)]
-          loc.argType        = case @type of
-                                Maybe tp       -> Maybe  (  makeType @lhs.allNonterminals tp)
-                                Either tp1 tp2 -> Either (  makeType @lhs.allNonterminals tp1) (makeType @lhs.allNonterminals tp2)
-                                List tp        -> List   (  makeType @lhs.allNonterminals tp)
-                                Tuple xs       -> Tuple [(f,makeType @lhs.allNonterminals tp) | (f,tp) <- xs]
-                                Map tp1 tp2    -> Map    (  makeType @lhs.allNonterminals tp1) (makeType @lhs.allNonterminals tp2)
-                                IntMap tp      -> IntMap (  makeType @lhs.allNonterminals tp)
-                                OrdSet tp      -> OrdSet (  makeType @lhs.allNonterminals tp)
-                                IntSet         -> IntSet
-          lhs.typeSyns       = [(@name,@argType)]
-
--------------------------------------------------------------------------------
---         Interpreting Nonterminal sets
--------------------------------------------------------------------------------
-
-
-SEM AG
-  | AG
-       elems.defSets     = Map.fromList (map (\x->(x,(Set.singleton x, Set.empty))) (Set.toList @loc.allNonterminals))
-       elems.definedSets = Map.map fst @elems.defSets
-
-
-SEM Elem
-  | Set loc.(defSets2,errs) = let allUsedNames = Set.unions [ maybe (Set.singleton n)
-                                                                    snd
-                                                                    (Map.lookup n @lhs.defSets)
-                                                            | n <- Set.toList @set.collectedNames
-                                                            ]
-                                  (nontSet,e1) | Set.member @name allUsedNames
-                                                           = (Set.empty, Seq.singleton(CyclicSet @name))
-                                               | otherwise = (@set.nontSet, Seq.empty)
-                                  (res, e2) = let toAdd = (nontSet,Set.insert @name allUsedNames)
-                                                  un (a,b) (c,d) = (a `Set.union` c, b `Set.union` d)
-                                              in if Set.member @name @lhs.allNonterminals || not @merge
-                                                 then checkDuplicate DupSet @name toAdd @lhs.defSets
-                                                 else (Map.insertWith un @name toAdd @lhs.defSets, Seq.empty)
-                              in (res, e1 Seq.>< e2)
-        lhs.defSets         = @defSets2
-           .errors          = @errs >< @set.errors
-
-SEM NontSet
-  | All        lhs.nontSet = @lhs.allNonterminals
-  | NamedSet   loc.(nontSet,errors) = case Map.lookup @name @lhs.definedSets of
-                                                   Nothing  -> (Set.empty, Seq.singleton (UndefNont @name))
-                                                   Just set -> (set, Seq.empty)
-  | Union      lhs.nontSet = Set.union         @set1.nontSet @set2.nontSet
-  | Intersect  lhs.nontSet = Set.intersection  @set1.nontSet @set2.nontSet
-  | Difference lhs.nontSet = Set.difference    @set1.nontSet @set2.nontSet
-  | Path       lhs.nontSet = let table = flattenDatas @lhs.allFields
-                             in path table @from @to
-               lhs.errors = let check name | Set.member name @lhs.allNonterminals
-                                                       = Seq.empty
-                                           | otherwise = Seq.singleton (UndefNont name)
-                            in check @from >< check @to
-
-
-{
-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 = reach
-  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 = foldr inv Map.empty . Map.toList
-  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
-}
-
--------------------------------------------------------------------------------
---   Interpreting Constructor Sets
--------------------------------------------------------------------------------
-
-
-SEM ConstructorSet
-  | CName       lhs.constructors = \_  -> Set.singleton @name
-  | CUnion      lhs.constructors = \ds -> @set1.constructors ds `Set.union`      @set2.constructors ds
-  | CDifference lhs.constructors = \ds -> @set1.constructors ds `Set.difference` @set2.constructors ds
-  | CAll        lhs.constructors = \ds -> ds
-
--------------------------------------------------------------------------------
---         Collecting wrappers
--------------------------------------------------------------------------------
-
-ATTR Elem Elems [ | | wrappers USE {`Set.union`} {Set.empty} :{Set NontermIdent}]
-
-SEM Elem
-  | Wrapper lhs.wrappers = @set.nontSet
-
--------------------------------------------------------------------------------
---         Collecting nocatas
--------------------------------------------------------------------------------
-
-SEM Elem
-  | Nocatas  lhs.pragmas = \o -> o { nocatas = @set.nontSet `Set.union` nocatas o }
-
--------------------------------------------------------------------------------
---         Collecting pragmas
--------------------------------------------------------------------------------
-
-ATTR AG Elem Elems [ | | pragmas USE {.} {id} :{Options -> Options}]
-
-SEM Elem
-  | Pragma  lhs.pragmas = let mk n o = case getName n of
-                                         "gencatas"     -> o { folds       = True  }
-                                         "nogencatas"   -> o { folds       = False }
-                                         "gendatas"     -> o { dataTypes   = True  }
-                                         "datarecords"  -> o { dataRecords = True  }
-                                         "nogendatas"   -> o { dataTypes   = False }
-                                         "gensems"      -> o { semfuns     = True  }
-                                         "nogensems"    -> o { semfuns     = False }
-                                         "gentypesigs"  -> o { typeSigs    = True  }
-                                         "nogentypesigs"-> o { typeSigs    = False }
-                                         "nocycle"      -> o { withCycle   = False, loag = 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, loag = 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  }
-                                         "breadthfirst" -> o { breadthFirst = True }
-                                         "breadthfirstStrict" -> o { breadthFirstStrict = 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"   -> sepSemModsOpt o
-                                         "genlinepragmas" -> o { genLinePragmas = True }
-                                         "newtypes"       -> o { newtypes = True }
-                                         "nonewtypes"     -> o { newtypes = False }
-                                         "nooptimizations" -> o { noOptimizations = True }
-                                         "kennedywarren"   -> o { kennedyWarren = True }
-                                         "aspectag"        -> o { genAspectAG = True }
-                                         'n':'o':'g':'r':'o':'u':'p':'_':atts
-                                                           -> o { noGroup =  extract atts  ++ noGroup o }
-                                         "rename"          -> o { rename = True }
-                                         "parallel"        -> o { parallelInvoke = True }
-                                         "monadicwrappers" -> o { monadicWrappers = True }
-
-                                         "dummytokenvisit" -> o { dummyTokenVisit = True }
-                                         "tupleasdummytoken" -> o { tupleAsDummyToken = True }
-                                         "stateasdummytoken" -> o { tupleAsDummyToken = False }
-                                         "strictdummytoken" -> o { strictDummyToken = True }
-                                         "noperruletypesigs" -> o { noPerRuleTypeSigs = True }
-                                         "noperstatetypesigs" -> o { noPerStateTypeSigs = True }
-                                         "noeagerblackholing" -> o { noEagerBlackholing = True }
-                                         "noperrulecostcentres" -> o { noPerRuleCostCentres = True }
-                                         "nopervisitcostcentres" -> o { noPerVisitCostCentres = True }
-                                         "helpinlining" -> o { helpInlining = True }
-                                         "noinlinepragmas" -> o { noInlinePragmas = True }
-                                         "aggressiveinlinepragmas" -> o { aggressiveInlinePragmas = True }
-                                         "latehigherorderbindings" -> o { lateHigherOrderBinding = True }
-                                         "ocaml"                   -> ocamlOpt o
-                                         "cleanlang"               -> cleanOpt o
-
-                                         s              -> trace ("uuagc: ignoring unknown pragma: " ++ s) o
-                          in \o -> foldr mk o @names
-
-{
-extract :: String -> [String]
-extract s = case dropWhile isSeparator s of
-                                "" -> []
-                                s' -> w : extract s''
-                                      where (w, s'') = break isSeparator  s'
-isSeparator :: Char -> Bool
-isSeparator x = x == '_'
-}
-
-ATTR Elem Elems SemAlts SemAlt [ | | semPragmasCollect USE {`pragmaMapUnion`} {Map.empty} : {PragmaMap} ]
-
-SEM SemAlt
-  | SemAlt
-      loc.pragmaNames       = Set.fromList @rules.pragmaNamesCollect
-      lhs.semPragmasCollect = foldr pragmaMapUnion Map.empty [ pragmaMapSingle nt con @loc.pragmaNames
-                                                             | (nt, conset, _) <- @loc.coninfo
-                                                             , con <- Set.toList conset
-                                                             ]
-
-ATTR SemDefs SemDef [ | | pragmaNamesCollect USE {++} {[]} : {[Identifier]} ]
-
-SEM SemDef
-  | SemPragma
-      lhs.pragmaNamesCollect = @names
-
-{
-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)
-}
-
--------------------------------------------------------------------------------
---         Collecting attribute orders
--------------------------------------------------------------------------------
-
-ATTR Elem Elems SemAlts SemAlt [ | | attrOrderCollect USE {`orderMapUnion`} {Map.empty} : {AttrOrderMap} ]
-ATTR Elem Elems SemAlts SemAlt [ allAttrDecls : {Map NontermIdent (Attributes, Attributes)} | | ]
-
-SEM SemAlt
-  | SemAlt
-      loc.attrOrders
-        = [ orderMapSingle nt con @rules.orderDepsCollect
-          | (nt, conset, _) <- @loc.coninfo
-          , con <- Set.toList conset
-          ]
-
-      lhs.attrOrderCollect = foldr orderMapUnion Map.empty @loc.attrOrders
-
-ATTR SemDefs SemDef [ | | orderDepsCollect USE {`Set.union`} {Set.empty} : {Set Dependency} ]
-
-SEM SemDef
-  | AttrOrderBefore
-      loc.dependency       = [ Dependency b a | b <- @before, a <- @after ]
-      lhs.orderDepsCollect = Set.fromList @loc.dependency
-
-{
-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)
-}
-
--------------------------------------------------------------------------------
---         Collecting nonterminal type parameters
--------------------------------------------------------------------------------
-
-ATTR Elem Elems [ | | paramsCollect USE {`mergeParams`} {Map.empty} : {ParamMap}]
-
-SEM Elem
-  | Data
-      lhs.paramsCollect = if null @params
-                          then Map.empty
-                          else Map.fromList [(nt, @params) | nt <- Set.toList @names.nontSet]
-
-SEM Elem
-  | Type
-      lhs.paramsCollect = if null @params
-                          then Map.empty
-                          else Map.singleton @name @params
-
-{
-mergeParams :: ParamMap -> ParamMap -> ParamMap
-mergeParams = Map.unionWith (++)
-}
-
--------------------------------------------------------------------------------
---         Collecting class contexts of semantic functions
--------------------------------------------------------------------------------
-
-ATTR Elem Elems [ | | ctxCollect USE {`mergeCtx`} {Map.empty} : {ContextMap}]
-
-SEM Elem
-  | Sem Data Attr
-      lhs.ctxCollect = if null @ctx
-                       then Map.empty
-                       else Map.fromList [(nt, @ctx) | nt <- Set.toList @names.nontSet]
-
-SEM Elem
-  | Type
-      lhs.ctxCollect = if null @ctx
-                       then Map.empty
-                       else Map.singleton @name @ctx
-
-{
-mergeCtx :: ContextMap -> ContextMap -> ContextMap
-mergeCtx
-  = Map.unionWith nubconcat
-  where nubconcat a b = nub (a ++ b)
-}
-
--------------------------------------------------------------------------------
---         Collecting quantifiers of semantic functions
--------------------------------------------------------------------------------
-
-ATTR Elem Elems [ | | quantCollect USE {`mergeQuant`} {Map.empty} : {QuantMap}]
-
-SEM Elem
-  | Sem Attr
-      lhs.quantCollect = if null @quants
-                         then Map.empty
-                         else Map.fromList [(nt, @quants) | nt <- Set.toList @names.nontSet]
-
-{
-mergeQuant :: QuantMap -> QuantMap -> QuantMap
-mergeQuant = Map.unionWith (++)
-}
-
--------------------------------------------------------------------------------
---         Collecting derivings
--------------------------------------------------------------------------------
-
-ATTR Elem Elems [ | | derivings USE {`mergeDerivings`} {Map.empty} :{Derivings}]
-
-{
-mergeDerivings :: Derivings -> Derivings -> Derivings
-mergeDerivings m1 m2 = foldr (\(n,cs) m -> Map.insertWith Set.union n cs m) m2 (Map.toList m1)
-}
-
-SEM Elem
-  | Deriving lhs.derivings = Map.fromList [(nt,Set.fromList @classes) | nt <- Set.toList @set.nontSet]
-
--------------------------------------------------------------------------------
---         Collecting ATTR declarations
--------------------------------------------------------------------------------
-
-{
-merge ::(Ord k, Ord k1) => Map k (Map k1 a) -> Map k (Map k1 a) -> Map k (Map k1 a)
-merge x y = foldr f y (Map.toList x)
- where f ~(k,v) m = Map.insertWith (Map.union) k v m
-}
-
-SEM AG
-  | AG elems.attrDecls = Map.empty
-
-SEM Elem
-  | Data attrs.nts = @names.nontSet
-  | Attr attrs.nts = @names.nontSet
-  | Sem  attrs.nts = @names.nontSet
-
-
-SEM Attrs [ nts:{Set NontermIdent} | | ]
-  | Attrs loc.(attrDecls,errors) = checkAttrs @lhs.allFields (Set.toList @lhs.nts) @inherited @synthesized @lhs.attrDecls
-
-             .(inherited,synthesized,useMap) = let splitAttrs xs = unzip [ ((n,makeType @lhs.allNonterminals t),(n,ud))
-                                                                         | (n,t,ud) <- xs
-                                                                         ]
-                                                   (inh,_)     = splitAttrs @inh
-                                                   (chn,uses1) = splitAttrs @chn
-                                                   (syn,uses2) = splitAttrs @syn
-                                                   isUse (_,(e1,e2,_)) = not (null e1 || null e2)
-                                               in (inh++chn,chn++syn, Map.fromList (Prelude.filter isUse (uses1++uses2)))
-          lhs.useMap = Map.fromList (zip (Set.toList @lhs.nts) (repeat @useMap))
-
-          loc.errors1 = if checkParseTy @lhs.options
-                        then let attrs  = @inh ++ @syn ++ @chn
-                                 items = map (\(ident,tp,_) -> (getPos ident, tp)) attrs
-                                 errs  = map check items
-                                 check (pos,Haskell s) =
-                                   let ex  = Expression pos tks
-                                       tks = [tk]
-                                       tk  = HsToken s pos
-                                   in Seq.fromList $ checkTy ex
-                                 check _ = Seq.empty
-                             in foldr (Seq.><) Seq.empty errs
-                        else Seq.empty
-          lhs.errors = @loc.errors Seq.>< @loc.errors1
-
-
-{
-checkAttrs :: DataTypes -> [NontermIdent] -> [(Identifier, a)] -> [(Identifier, b)] -> Map NontermIdent (Map Identifier a, Map Identifier b) -> (Map NontermIdent (Map Identifier a, Map Identifier b), Seq Error)
-checkAttrs allFields nts inherited synthesized decls' = foldErrors check decls' nts where
-  check nt decls | not (nt `Map.member` allFields) = (decls,Seq.singleton(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)
-}
-
-
--- Add declaration of self-attribute for each nonterminal: ATTR <nt> [ | | self:SELF]
-{
-addSelf :: Ord k1 => k1 -> Map k1 (Map k a, Attributes) -> Map k1 (Map k a, Attributes)
-addSelf name atMap = let (eInh,eSyn) = Map.findWithDefault(Map.empty,Map.empty) name atMap
-                     in  Map.insert name (eInh, Map.insert (Ident "self" noPos) Self eSyn)atMap
-}
-
-
-SEM AG
-  | AG  loc.allAttrDecls = if withSelf @lhs.options
-                            then foldr addSelf @elems.attrDecls (Set.toList @loc.allNonterminals)
-                            else               @elems.attrDecls
-
--------------------------------------------------------------------------------
---         Collecting rules
--------------------------------------------------------------------------------
-
-
-ATTR SemDef SemDefs [ | | ruleInfos    USE {++} {[]} : {[RuleInfo]}
-                          sigInfos     USE {++} {[]} : {[SigInfo]}
-                          uniqueInfos  USE {++} {[]} : {[UniqueInfo]}
-                          augmentInfos USE {++} {[]} : {[AugmentInfo]}
-                          aroundInfos  USE {++} {[]} : {[AroundInfo]}
-                          mergeInfos   USE {++} {[]} : {[MergeInfo]}
-                    ]
-
-
-SEM SemAlt
-  | SemAlt loc.coninfo = [ (nt, conset, conkeys)
-                         | nt  <- Set.toList @lhs.nts
-                         , let conmap = Map.findWithDefault Map.empty nt @lhs.allFields
-                         , let conkeys = Set.fromList (Map.keys conmap)
-                         , let conset  = @constructorSet.constructors conkeys
-                         ]
-
-           lhs.errors = Seq.fromList
-                           [ UndefAlt nt con
-                           | (nt, conset, conkeys) <- @loc.coninfo
-                           , con <- Set.toList (Set.difference conset conkeys)
-                           ]
-                        Seq.>< @rules.errors
-           lhs.collectedRules
-               =       [ (nt,con,r)
-                       | (nt, conset, _) <- @loc.coninfo
-                       , con <- Set.toList conset
-                       , r <- @rules.ruleInfos
-                       ]
-           lhs.collectedSigs
-               =       [ (nt,con,ts)
-                       | (nt, conset, _) <- @loc.coninfo
-                       , con <- Set.toList conset
-                       , ts <- @rules.sigInfos
-                       ]
-
-           lhs.collectedInsts
-               =       [ (nt,con,@rules.definedInsts)
-                       | (nt, conset, _) <- @loc.coninfo
-                       , con <- Set.toList conset
-                       ]
-
-           lhs.collectedUniques
-               =       [ (nt,con,@rules.uniqueInfos)
-                       | (nt, conset, _) <- @loc.coninfo
-                       , con <- Set.toList conset
-                       ]
-
-           lhs.collectedAugments
-              =        [ (nt, con, @rules.augmentInfos)
-                       | (nt, conset, _) <- @loc.coninfo
-                       , con <- Set.toList conset
-                       ]
-
-           lhs.collectedArounds
-              =        [ (nt, con, @rules.aroundInfos)
-                       | (nt, conset, _) <- @loc.coninfo
-                       , con <- Set.toList conset
-                       ]
-
-           lhs.collectedMerges
-             =         [ (nt, con, @rules.mergeInfos)
-                       | (nt, conset, _) <- @loc.coninfo
-                       , con <- Set.toList conset
-                       ]
-
-SEM SemDef
-  | Def  lhs.ruleInfos = [ (@mbName, @pattern.patunder, @rhs, @pattern.definedAttrs, @owrt, show @pattern.stpos, @pure, @eager) ]
-
-SEM SemDef
-  | TypeDef  lhs.sigInfos = [ (@ident, @tp) ]
-
-SEM SemDef
-  | UniqueDef  lhs.uniqueInfos = [ (@ident, @ref) ]
-
-SEM SemDef
-  | AugmentDef  lhs.augmentInfos = [ (@ident, @rhs) ]
-
-SEM SemDef
-  | AroundDef   lhs.aroundInfos = [ (@ident, @rhs) ]
-
-SEM SemDef
-  | MergeDef    lhs.mergeInfos = [ (@target, @nt, @sources, @rhs) ]
-
-
-ATTR SemDef SemDefs Pattern Patterns [|| definedInsts USE {++} {[]} : {[Identifier]} ]
-ATTR Pattern Patterns [ | | definedAttrs USE {++} {[]} : {[AttrName]} ]
-ATTR Pattern [ | | patunder : {[AttrName]->Pattern} ]
-ATTR Patterns [ | | patunder : {[AttrName]->Patterns} ]
-
-SEM Pattern
-  | Alias lhs.definedAttrs = (@field, @attr) : @pat.definedAttrs
-          lhs.patunder     = \us -> if ((@field,@attr) `elem` us) then Underscore noPos else @copy
-          lhs.definedInsts = (if @field == _INST then [@attr] else []) ++ @pat.definedInsts
-  | Underscore lhs.patunder = \_ -> @copy
-  | Constr lhs.patunder    = \us -> Constr @name (@pats.patunder us)
-  | Product lhs.patunder    = \us -> Product @pos (@pats.patunder us)
-  | Irrefutable lhs.patunder = \us -> Irrefutable (@pat.patunder us)
-
-SEM Patterns
-  | Nil lhs.patunder = \_ ->  []
-  | Cons lhs.patunder = \us -> (@hd.patunder us) : (@tl.patunder us)
-
-ATTR Pattern [ | | stpos : Pos ]
-
-SEM Pattern
-  | Constr     lhs.stpos = getPos @name
-  | Product    lhs.stpos = @pos
-  | Alias      lhs.stpos = getPos @field
-  | Underscore lhs.stpos = @pos
-
--------------------------------------------------------------------------------
---         Collect module declaration
--------------------------------------------------------------------------------
-
-ATTR AG Elems Elem [ | | moduleDecl USE {`flipmplus`} {mzero} : {Maybe (String,String,String)} ]
-
-SEM Elem
-  | Module
-      lhs.moduleDecl = Just (@name, @exports, @imports)
-
-{
--- We want the last Just in the list
-flipmplus = flip mplus
-}
-
--------------------------------------------------------------------------------
---         Constructing transformed syntax tree
--------------------------------------------------------------------------------
-{
-makeType :: Set NontermIdent -> Type -> Type
-makeType nts tp@(NT x _ _)   | Set.member x nts = tp
-                             | otherwise        = Haskell (typeToHaskellString Nothing [] tp)
-makeType _   tp                                 = tp
-}
-{
-constructGrammar ::    Set NontermIdent
-                    -> ParamMap
-                    -> Map NontermIdent (Map ConstructorIdent (Set Identifier))
-                    -> DataTypes
-                    -> Map NontermIdent [ConstructorIdent]
-                    -> Map NontermIdent (Map ConstructorIdent [Type])
-                    -> 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
-                    -> 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)))
-                    -> Map NontermIdent (Map ConstructorIdent MaybeMacro)
-                    -> Grammar
-
-constructGrammar _ ntParams prodParams gram prodOrder constraints attrs uses derivings wrap allrules tsigs allinsts tsyns pragmaMap orderMap contextMap quantMap uniqueMap augmentsMap aroundsMap mergeMap macros =
-   let gr = [ (nt,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
-                             mergemap  = Map.findWithDefault Map.empty             nt mergeMap
-                             macromap  = Map.findWithDefault Map.empty             nt macros
-                             csmap     = Map.findWithDefault Map.empty             nt constraints
-                             psmap     = Map.findWithDefault Map.empty             nt prodParams
-                             prs       = Map.findWithDefault []                    nt prodOrder
-                             alt con   =
-                                   let flds    = Map.findWithDefault [] con alts
-                                       rules   = Map.findWithDefault [] con rmap
-                                       tsigs'  = Map.findWithDefault [] con tsmap
-                                       insts   = Map.findWithDefault [] con instsmap
-                                       merges  = [ (n, NT t [] False) | (n, (t, _, _)) <- Map.assocs $ maybe Map.empty id (Map.lookup con mergemap) ]
-                                       cs      = Map.findWithDefault [] con csmap
-                                       ps      = Set.elems $ Map.findWithDefault Set.empty con psmap
-                                       mbMacro = Map.findWithDefault Nothing con macromap
-
-                                       -- important: keep order of children
-                                       cldrn = map child (flds ++ filter (not . existsAsField) insts ++ merges)
-                                       child (nm, tp) =
-                                          let tpI = if existsAsInst nm
-                                                    then fromJust $ lookup nm insts
-                                                    else tp
-                                              virt = if existsAsInst nm
-                                                     then case lookup nm flds of
-                                                            Just tp' -> ChildReplace tp'
-                                                            Nothing  -> ChildAttr
-                                                     else if existsAsMerge nm
-                                                          then ChildAttr
-                                                          else ChildSyntax
-                                          in Child nm tpI virt
-                                       existsAsInst nm = maybe False (const True) (lookup nm insts)
-                                       existsAsField (nm,_) = maybe False (const True) (lookup nm flds)
-                                       existsAsMerge nm = maybe False (const True) (lookup nm merges)
-                                   in Production con ps cs cldrn rules tsigs' mbMacro
-                            in Nonterminal nt params inh syn (map alt prs)
-   in Grammar tsyns uses derivings wrap nonts pragmaMap orderMap ntParams contextMap quantMap uniqueMap augmentsMap aroundsMap mergeMap
-}
-
-{
-mapUnionWithSetUnion :: Map NontermIdent (Set ConstructorIdent) -> Map NontermIdent (Set ConstructorIdent) -> Map NontermIdent (Set ConstructorIdent)
-mapUnionWithSetUnion = Map.unionWith Set.union
-mapUnionWithPlusPlus :: Map BlockInfo [a] -> Map BlockInfo [a] -> Map BlockInfo [a]
-mapUnionWithPlusPlus = Map.unionWith (++)
-}
-
-
---marcos
--------------------------------------------------------------------------------
---         Collecting Macro information
--------------------------------------------------------------------------------
-
-ATTR Alt Alts Elem Elems
-     [ | | collectedMacros USE {++} {[]} : {[(NontermIdent, ConstructorIdent, MaybeMacro)]}]
-
-
-SEM Alt
-  | Alt  lhs.collectedMacros  =       [ (nt, con, @macro)
-                                      | nt  <- Set.toList @lhs.nts
-                                      , con <- Set.toList (@names.constructors (Map.findWithDefault Set.empty nt @lhs.allConstructors))
-                                      ]
-
-
-SEM AG
-  | AG
-
-         loc.allMacros   = let f (nt,con,m) = Map.insertWith (Map.union) nt (Map.singleton con m)
-                           in  foldr f (Map.empty) @elems.collectedMacros
-
-
--------------------------------------------------------------------------------
---         Collecting the AGI information
--------------------------------------------------------------------------------
-
-ATTR AG [ | | agi : {(Set NontermIdent, DataTypes, Map NontermIdent (Attributes, Attributes))} ]
-
-ATTR Elem Elems SemAlts SemAlt [ allAttrs : {Map NontermIdent (Attributes, Attributes)} | | ]
-
-SEM AG
-  | AG lhs.agi      = (@loc.allNonterminals,@loc.allFields,@loc.allAttrs)
-
-       loc.allAttrs =  if withSelf @lhs.options
-                            then foldr addSelf @elems.attrs (Set.toList @loc.allNonterminals)
-                            else               @elems.attrs
-
-ATTR Elems Elem Attrs
-     [ | attrs : {Map NontermIdent (Attributes, Attributes)} | ]
-
-SEM AG
-  | AG  elems.attrs = Map.empty
-
-
-SEM Attrs
-  | Attrs lhs.attrs =   let ins decls nt = if Map.member nt decls
-                                           then  Map.update (\(inh,syn) -> Just ( Map.union inh $ Map.fromList @inherited
-                                                                                     , Map.union syn $ Map.fromList @synthesized)) nt decls
-                                           else  Map.insert nt (Map.fromList @inherited, Map.fromList @synthesized) decls
-
-                        in  foldl ins @lhs.attrs (Set.toList @lhs.nts)
-
-
--------------------------------------------------------------------------------
---         Collecting the data type information
--------------------------------------------------------------------------------
-
-ATTR AG Elems Elem
-  [ | | constructorTypeMap USE {`Map.union`} {Map.empty} : {Map NontermIdent ConstructorType} ]
-  
-SEM Elem
-  | Data lhs.constructorTypeMap = Set.fold (\nm mp -> Map.insert nm @contype mp) Map.empty @names.collectedNames
+PRAGMA strictdata+PRAGMA strictwrap++INCLUDE "ConcreteSyntax.ag"+INCLUDE "Patterns.ag"++imports+{+import Control.Monad(mplus,mzero)+import Data.List (partition, nub,intersperse, union)+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, elems)+import qualified Data.Sequence as Seq+import Data.Sequence(Seq, (><))+import UU.Scanner.Position(noPos)++import ConcreteSyntax+import AbstractSyntax+import ErrorMessages+import Patterns (Patterns,Pattern(..))+import Expression (Expression(..))+import HsToken++import RhsCheck+import Debug.Trace+}+++-------------------------------------------------------------------------------+--  Main goal+-------------------------------------------------------------------------------++-- Given some options, we want to construct a Grammar, that is, a structure that conforms to AbstractSyntax+ATTR AG [ | | output : Grammar ]+ATTR AG Elems Elem SemAlts SemAlt SemDefs SemDef Attrs [ options : Options | | ]++-- as a side effect, we generate error messages and Haskell code blocks that need to be embedded in the final code+ATTR AG Elems Elem SemAlts SemAlt Attrs NontSet ConstructorSet SemDefs SemDef+     [ | | errors USE {Seq.><}{Seq.empty}:{Seq Error} ]+ATTR AG Elems Elem+     [ | | blocks USE {`mapUnionWithPlusPlus`} {Map.empty}: {Blocks} ]+++-- The output is produced by calling a function that constructs the Grammar,+-- given various datastructures that are collected from the concrete AG.++SEM AG+  | AG lhs.output = constructGrammar @loc.allNonterminals+                                     @elems.paramsCollect+                                     @loc.allConParams+                                     @loc.allFields+                                     @loc.prodOrder+                                     @loc.allConstraints+                                     @loc.allAttrDecls+                                     @elems.useMap+                                     @elems.derivings+                                     (if wrappers @lhs.options then @loc.allNonterminals else @elems.wrappers)+                                     @loc.checkedRules+                                     @loc.checkedSigs+                                     @loc.checkedInsts+                                     @elems.typeSyns+                                     @elems.semPragmasCollect+                                     @elems.attrOrderCollect+                                     @elems.ctxCollect+                                     @elems.quantCollect+                                     @loc.checkedUniques+                                     @loc.checkedAugments+                                     @loc.checkedArounds+                                     @loc.checkedMerges+                                     @loc.allMacros+++-------------------------------------------------------------------------------+--  Main data flow+-------------------------------------------------------------------------------++{- Information is collected bottom-up (in multiple phases)+   After checking for consistency, datastructures are createad from it,+   which are passed down for the other phases.+-}+++-- Names that are in use++  -- bottom-up collection+ATTR Elem Elems          [ | | collectedSetNames USE {`Set.union`} {Set.empty} : {Set Identifier} ]+ATTR Elem Elems NontSet  [ | | collectedNames    USE {`Set.union`} {Set.empty} : {Set Identifier} ]+  -- top-down distribution+ATTR Elem Elems Attrs Alts Alt Fields Field NontSet [ allNonterminals : {Set NontermIdent} | | ]+++-- Constructors that are in use+  -- bottom-up collection+ATTR Alt Alts ConstructorSet [ | | collectedConstructorNames USE {`Set.union`} {Set.empty} : {Set ConstructorIdent} ]+ATTR Elem Elems [ | | collectedConstructorsMap USE {`mapUnionWithSetUnion`} {Map.empty} : {Map NontermIdent (Set ConstructorIdent)} ]+  -- top-down distribution+ATTR Elem Elems Alts Alt [ allConstructors : {Map NontermIdent (Set ConstructorIdent)} | | ]++++-- Nonterminal sets that are defined+{type DefinedSets = Map Identifier (Set NontermIdent) }+  -- bottom-up collection+ATTR Elem Elems+     [ | defSets:{Map Identifier (Set NontermIdent,Set Identifier)} | ]+  -- top-down distribution+ATTR Elem Elems NontSet+     [ definedSets:{DefinedSets} | | ]++++-- Interpreting nonterminal sets+ATTR NontSet [ | | nontSet   : {Set NontermIdent} ]+++-- Interpreting constructor sets+ATTR ConstructorSet  [ | | constructors : {(Set ConstructorIdent->Set ConstructorIdent)} ]++++-- Contextfree structure+{type FieldMap  = [(Identifier, Type)] }+{type DataTypes = Map.Map NontermIdent (Map.Map ConstructorIdent FieldMap) }+  -- bottom-up collection+ATTR Alt Alts Elem Elems+     [ | | collectedFields USE {++} {[]} : {[(NontermIdent, ConstructorIdent, FieldMap)]}+           collectedConstraints USE {++} {[]} : {[(NontermIdent, ConstructorIdent, [Type])]}+           collectedConParams USE {++} {[]} : {[(NontermIdent, ConstructorIdent, Set Identifier)]}+     ]+  -- top-down distribution+ATTR Elem Elems Attrs SemAlt SemAlts NontSet+     [  allFields : {DataTypes} | | ]++++-- Attribute declarations+  -- bottom-up collection+ATTR Elems Elem Attrs+     [+     | attrDecls:{Map NontermIdent (Attributes, Attributes)}+     | useMap USE {`merge`} {Map.empty}:{Map NontermIdent (Map Identifier (String,String,String))}+     ]+++-- Attribute definitions+{type AttrName   = (Identifier,Identifier) }+{type RuleInfo   = (Maybe Identifier, [AttrName]->Pattern, Expression, [AttrName], Bool, String, Bool, Bool) }+{type SigInfo    = (Identifier,Type) }+{type UniqueInfo = (Identifier,Identifier) }+{type AugmentInfo = (Identifier,Expression)}+{type AroundInfo  = (Identifier,Expression)}+{type MergeInfo   = (Identifier, Identifier, [Identifier], Expression)}+  -- bottom-up collection+ATTR Elem Elems SemAlt SemAlts+     [ | |   collectedRules    USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, RuleInfo)]}+             collectedSigs     USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, SigInfo) ]}+             collectedInsts    USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, [Identifier]) ]}+             collectedUniques  USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, [UniqueInfo]) ]}+             collectedAugments USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, [AugmentInfo]) ]}+             collectedArounds  USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, [AroundInfo])  ]}+             collectedMerges   USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, [MergeInfo])   ]}+     ]++++-------------------------------------------------------------------------------+--         Passing nonterminals+-------------------------------------------------------------------------------++-- Pass the name of the associated nonterminal to everyone+ATTR Alt Alts SemAlt SemAlts [ nts:{Set NontermIdent} | | ]++SEM Elem+  | Data alts.nts = @names.nontSet+  | Sem  alts.nts = @names.nontSet++++-------------------------------------------------------------------------------+--         Calculation of code blocks                                        --+-------------------------------------------------------------------------------++SEM Elem+  | Txt  loc.blockInfo  = ( @kind+                          , @mbNt+                          )+         loc.blockValue = [(@lines, @pos)]+         lhs.blocks     = Map.singleton @loc.blockInfo @loc.blockValue+         lhs.errors     = if checkParseBlock @lhs.options+                          then let ex  = Expression @pos tks+                                   tks = [tk]+                                   tk  = HsToken (unlines @lines) @pos+                               in Seq.fromList $ checkBlock $ ex+                          else Seq.empty+++-------------------------------------------------------------------------------+--         Check for duplicates and report error+-------------------------------------------------------------------------------++{++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.singleton (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 :: (b -> t -> (t, Seq Error)) -> t -> [b] -> (t, Seq Error)+foldErrors f n xs = foldl g (n,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 _ [] = []+checkForDuplicates err (x:xs) = let (same,other) = partition (equalId x) xs+                                in  map (err x) same ++ checkForDuplicates err other++equalId :: Identifier -> Identifier -> Bool+equalId x y = getName x == getName y++}++-------------------------------------------------------------------------------+--         Collecting DATA's and type synonyms+-------------------------------------------------------------------------------+++SEM Alt+  | Alt  lhs.collectedFields  =       [ (nt, con, @fields.collectedFields)+                                      | nt  <- Set.toList @lhs.nts+                                      , con <- Set.toList (@names.constructors (Map.findWithDefault Set.empty nt @lhs.allConstructors))+                                      ]+         lhs.collectedConstraints =   [ (nt, con, @fields.collectedConstraints)+                                      | nt  <- Set.toList @lhs.nts+                                      , con <- Set.toList (@names.constructors (Map.findWithDefault Set.empty nt @lhs.allConstructors))+                                      ]+         lhs.collectedConParams   =   [ (nt, con, Set.fromList @tyvars)+                                      | nt  <- Set.toList @lhs.nts+                                      , con <- Set.toList (@names.constructors (Map.findWithDefault Set.empty nt @lhs.allConstructors))+                                      ]++SEM Elem+  | Type lhs.collectedFields = map (\(x,y)->(@name, x, y)) @loc.expanded++SEM AG+  | AG+         loc.prodOrder   = let f (nt,con,_) = Map.insertWith g nt [con]+                               g [con] lst | con `elem` lst = lst+                                           | otherwise      = con : lst+                               g _ _ = error "This is not possible"+                           in  foldr f Map.empty @elems.collectedFields+         loc.allFields   = let f (nt,con,fm) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con fm)+                           in  foldr f (Map.empty) @elems.collectedFields++         loc.allConstraints = let f (nt,con,fm) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con fm)+                              in  foldr f (Map.empty) @elems.collectedConstraints++         loc.allConParams   = let f (nt,con,fm) = Map.insertWith (Map.unionWith Set.union) nt (Map.singleton con fm)+                              in  foldr f (Map.empty) @elems.collectedConParams++         loc.allConstrs  = let f (nt,con,_) = Map.insertWith (++) nt [con]+                           in  foldr f (Map.empty) @elems.collectedFields++         loc.allRules    = let f (nt,con,r) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con [r])+                           in  foldr f (Map.empty) @elems.collectedRules++         loc.allSigs     = let f (nt,con,t) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con [t])+                               typeof nt r = Map.findWithDefault (Haskell "<unknown>") r $ fst $ Map.findWithDefault (Map.empty,Map.empty) nt @loc.allAttrDecls+                           in  foldr f (Map.empty) ( @elems.collectedSigs+                                                   ++ [ (nt, con, (ident,typeof nt ref))  | (nt, con, us) <- @elems.collectedUniques, (ident,ref) <- us ]+                                                   )++         loc.allInsts    = let f (nt,con,is) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con is)+                           in  foldr f (Map.empty) @elems.collectedInsts++         loc.allUniques  = let f (nt,con,us) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con us)+                           in foldr f (Map.empty) @elems.collectedUniques+         loc.allAugments = let f (nt,con,as) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con as)+                           in foldr f Map.empty @elems.collectedAugments+         loc.allArounds  =  let f (nt,con,as) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con as)+                            in foldr f Map.empty @elems.collectedArounds+         loc.allMerges   =  let f (nt,con,as) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con as)+                             in foldr f Map.empty @elems.collectedMerges++         loc.augmentSigs    = let gen _ = []  -- TODO: generate type signatures here for the augments+                              in Map.map (Map.map gen) @loc.allAugments++         loc.allRulesErrs   = Map.mapWithKey (Map.mapWithKey . (checkRules @allAttrDecls @allFields @allInsts @loc.allSigs @loc.allMerges)) @loc.allRules+         loc.allNamesErrs   = Map.mapWithKey (Map.mapWithKey . checkRuleNames) @loc.allRules+         loc.allSigsErrs    = Map.mapWithKey (Map.mapWithKey . (checkSigs                                                 )) @loc.allSigs+         loc.allInstsErrs   = Map.mapWithKey (Map.mapWithKey . (checkInsts @loc.allNonterminals @loc.allSigs @allFields   )) @loc.allInsts+         loc.allUniquesErrs = Map.mapWithKey (Map.mapWithKey . (checkUniques @allAttrDecls                                )) @loc.allUniques+         loc.allAugmentErrs = Map.mapWithKey (Map.mapWithKey . (checkAugments @allAttrDecls                               )) @loc.allAugments+         loc.allAroundsErrs = Map.mapWithKey (Map.mapWithKey . (checkArounds @loc.allFields)) @loc.allArounds+         loc.allMergesErrs  = Map.mapWithKey (Map.mapWithKey . (checkMerges @loc.allNonterminals @loc.allInsts @loc.allFields)) @loc.allMerges++         loc.checkedRulesPre = Map.map (Map.map fst) @loc.allRulesErrs+         loc.checkedSigs     = Map.map (Map.map fst) @loc.allSigsErrs `unionunionplusplus` @loc.augmentSigs+         loc.checkedInsts    = Map.map (Map.map fst) @loc.allInstsErrs+         loc.checkedUniques  = Map.map (Map.map fst) @loc.allUniquesErrs+         loc.checkedAugments = Map.map (Map.map fst) @loc.allAugmentErrs+         loc.checkedArounds  = Map.map (Map.map fst) @loc.allAroundsErrs+         loc.checkedRules    = Map.unionWith (Map.unionWith (++)) @loc.checkedRulesPre (Map.mapWithKey (Map.mapWithKey . (mkUniqueRules @lhs.options @loc.allRules @loc.allFields @loc.checkedInsts @loc.allAttrDecls)) @loc.checkedUniques)+         loc.checkedMerges   = Map.map (Map.map fst) @loc.allMergesErrs++         loc.errs1       = let f = checkForDuplicates (DupSynonym)+                           in  Seq.fromList . f . map fst $ @elems.typeSyns  -- forbid duplicate type synonyms++         loc.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    -- forbid duplicate fields++         loc.errs3       = let -- f (nt,cons) = checkForDuplicates (DupAlt nt) cons+                           in   Seq.empty                                                 -- allow duplicate constructors, merging their fields+                             -- Seq.fromList . concat . map f . Map.toList $ @allConstrs  -- forbid duplicate constructors++         loc.errs4       = let  f m s = Map.foldr ((><) . snd) s m+                           in Map.foldr f Seq.empty @loc.allRulesErrs++         loc.errs5       = let  f m s = Map.foldr ((><) . snd) s m+                           in Map.foldr f Seq.empty @loc.allSigsErrs++         loc.errs6       = let  f m s = Map.foldr ((><) . snd) s m+                           in Map.foldr f Seq.empty @loc.allInstsErrs++         loc.errs7       = let  f m s = Map.foldr ((><) . snd) s m+                           in Map.foldr f Seq.empty @loc.allUniquesErrs++         loc.errs8       = let  f m s = Map.foldr ((><) . snd) s m+                           in Map.foldr f Seq.empty @loc.allAugmentErrs++         loc.errs9       = let  f m s = Map.foldr ((><) . snd) s m+                           in Map.foldr f Seq.empty @loc.allAroundsErrs++         loc.errs10      =  let  f m s = Map.foldr ((><)) s m+                            in Map.foldr f Seq.empty @loc.allNamesErrs++         loc.errs11      =  let f m s = Map.foldr ((><) . snd) s m+                            in Map.foldr f Seq.empty @loc.allMergesErrs++         lhs.errors      = @elems.errors >< @errs1 >< @errs2 >< @errs3 >< @errs4 >< @errs5 >< @errs6 >< @errs7 >< @errs8 >< @errs9 >< @errs10 >< @errs11++{+type RulesAndErrors = ([Rule], Seq Error)+type SigsAndErrors  = ([TypeSig], Seq Error)+type InstsAndErrors = ([(Identifier, Type)], Seq Error)+type UniquesAndErrors = (Map Identifier Identifier, Seq Error)+type AugmentsAndErrors = (Map Identifier [Expression], Seq Error)+type AroundsAndErrors = (Map Identifier [Expression], Seq Error)+type MergesAndErrors  = (Map Identifier (Identifier, [Identifier], Expression), Seq Error)+type AttrOverwrite  = Map AttrName Bool+type AccumRuleCheck = (RulesAndErrors, AttrOverwrite)+type AccumDefiCheck = (Seq Error, AttrOverwrite, [AttrName], [AttrName])++checkRules :: Map NontermIdent (Attributes, Attributes) -> DataTypes ->+              Map NontermIdent (Map ConstructorIdent [Identifier]) -> Map NontermIdent (Map ConstructorIdent [SigInfo]) ->+              Map NontermIdent (Map ConstructorIdent [MergeInfo]) ->+              NontermIdent -> ConstructorIdent -> [RuleInfo] -> RulesAndErrors+checkRules attributes fields allinsts allsigs _ nt con rs+  = let fieldmap :: FieldMap+        fieldmap = (_LHS, NT nt [] False) : (_LOC, NT nullIdent [] False) : (_INST, NT nullIdent [] False) : (_FIRST, NT nullIdent [] False) : (_LAST, NT nullIdent [] False)+                 : 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))+                 --   merged children are not allowed to have any inherited attrs defined: do not include++        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 (mbNm, pat,ex,as,owrt,str, pur, eager) ((r1,e1),m1)+          = let (e2,m2,u2,_) = foldr (checkDefi owrt) (e1,m1,[],[]) as+            in  ( (Rule mbNm (pat u2) ex owrt str True pur False Nothing eager : 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 _ _) ->+                  let tp' = maybe tp id (deforestedNt tp)+                  in              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.<|)) (DupRule nt con field attr2 attr)   e,                    m, fa:u,    bs)+                                           Nothing ->           (                                             e, Map.insert fa owrt m,    u, fa:bs)+                                  else                          (((Seq.<|)) (SuperfluousRule nt con field attr) e,                    m, fa:u,    bs)+                _              ->                               (((Seq.<|)) (UndefChild nt con field)           e,                    m, fa:u,    bs )++    in  fst (foldr checkRule (([],Seq.empty),Map.empty) rs)++checkRuleNames :: NontermIdent -> ConstructorIdent -> [RuleInfo] -> Seq Error+checkRuleNames nt con+  = fst . foldr checkRule (Seq.empty, Set.empty)+  where+    checkRule (Just nm,_,_,_,_,_,_,_) (errs, nms)+      | nm `Set.member` nms = (DupRuleName nt con nm Seq.<| errs, nms)+      | otherwise           = (errs, Set.insert nm nms)+    checkRule (Nothing,_,_,_,_,_,_,_) inp = inp++checkSigs :: NontermIdent -> ConstructorIdent -> [SigInfo] -> SigsAndErrors+checkSigs nt con sis+  = let checkSig (ide,typ) (sigs,errs)+         = if   ide `elem` map (\(TypeSig n _)-> n) sigs+           then (sigs, ((Seq.<|)) (DupSig nt con ide) errs)+           -- else if not (ide `elem` locattrdefs)+           -- then (sigs, ((Seq.<|)) (SupSig nt con ide) errs)+           else (TypeSig ide typ:sigs, errs)+    in  foldr checkSig ([],Seq.empty) sis++checkInsts :: Set NontermIdent -> Map NontermIdent (Map ConstructorIdent [SigInfo]) -> DataTypes -> NontermIdent -> ConstructorIdent -> [Identifier] -> InstsAndErrors+checkInsts allNts sigMap _ nt con+  = foldr (\inst (insts, errs) ->+              maybe (insts, Seq.singleton (MissingInstSig nt con inst) >< errs)+                    (\info@(k, NT nm args _) ->+                      case findInst k insts of+                        Just k' -> (insts, Seq.singleton (DupChild nt con k k') >< errs)+                        Nothing -> case nm `Set.member` allNts of+                                             True  -> (info : insts, errs)+                                             False | take 2 (getName nm) == "T_" -> let nm'   = Ident (drop 2 (getName nm)) (getPos nm)+                                                                                        info' = (k, NT nm' args True)   -- this should be the only place at which 'for' with value True can be generated+                                                                                    in case nm' `Set.member` allNts of+                                                                                         True  -> (info' : insts, errs)+                                                                                         False -> (insts, Seq.singleton (UndefNont nm') >< errs)+                                                   | otherwise                   -> (insts, Seq.singleton (UndefNont nm) >< 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)++    findInst _ [] = Nothing+    findInst k ((k', _): r)+      | k == k'   = Just k'+      | otherwise = findInst k r++checkUniques :: Map NontermIdent (Attributes, Attributes) -> NontermIdent -> ConstructorIdent -> [UniqueInfo] -> UniquesAndErrors+checkUniques allAttrs nt con uniques+  = let checkUnique (ident,ref) (us,errs)+          = if ident `Map.member` us+            then (us, ((Seq.<|)) (DupUnique nt con ident) errs)+            else if Map.member ref inhs && Map.member ref syns+                 then (Map.insert ident ref us, errs)+                 else (us, ((Seq.<|)) (MissingUnique nt ref) errs)++        (inhs,syns) = Map.findWithDefault (Map.empty,Map.empty) nt allAttrs+    in foldr checkUnique (Map.empty, Seq.empty) uniques++checkAugments :: Map NontermIdent (Attributes, Attributes) -> NontermIdent -> ConstructorIdent -> [AugmentInfo] -> AugmentsAndErrors+checkAugments allAttrs nt _ augments+  = let checkAugment (ident,expr) (as,errs)+          = if ident `Map.member` as+            then (Map.update (\vs -> Just (vs ++ [expr])) ident as, errs)+            else if Map.member ident syns+                 then (Map.insert ident [expr] as, errs)+                 else (as, ((Seq.<|)) (MissingSyn nt ident) errs)++        (_,syns) = Map.findWithDefault (Map.empty,Map.empty) nt allAttrs+    in foldr checkAugment (Map.empty, Seq.empty) augments++checkArounds :: DataTypes -> NontermIdent -> ConstructorIdent -> [AroundInfo] -> AroundsAndErrors+checkArounds fieldMap nt con arounds+  = let checkAround (ident,expr) (as,errs)+          = if ident `Map.member` as+            then (Map.update (\vs -> Just (vs ++ [expr])) ident as, errs)+            else case lookup ident fields of+                   Just (NT _ _ _) -> (Map.insert ident [expr] as, errs)+                   _               -> (as, ((Seq.<|)) (UndefChild nt con ident) errs)+        fields = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt fieldMap)+    in foldr checkAround (Map.empty, Seq.empty) arounds++checkMerges :: Set NontermIdent -> Map NontermIdent (Map ConstructorIdent [Identifier]) -> DataTypes -> NontermIdent -> ConstructorIdent -> [MergeInfo] -> MergesAndErrors+checkMerges allNts allInsts fieldMap _ con merges+  = let checkMerge (target,nt,sources,expr) (m,errs)+          = let fields = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt fieldMap)+                insts  = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allInsts)+                allFields = insts ++ map fst fields   -- note: sources of merge may not contain a target (for simplicity)+            in if target `Map.member` m   -- check for duplicate with self+               then (m, DupChild nt con target (fst $ Map.elemAt (Map.findIndex target m) m) Seq.<| errs)+               else if target `elem` allFields+                     then (m, DupChild nt con target (head $ filter (== target) allFields) Seq.<| errs)+                     else let missing = filter (\s -> not (s `elem` allFields)) sources+                          in if null missing+                             then if nt `Set.member` allNts   -- check if the nonterm is defined+                                  then (Map.insert target (nt, sources, expr) m, errs) -- all ok..+                                  else (m, UndefNont nt Seq.<| errs)+                             else (m, (Seq.fromList $ map (UndefChild nt con) missing) Seq.>< errs)+    in foldr checkMerge (Map.empty, Seq.empty) merges++unionunionplusplus :: Map NontermIdent (Map ConstructorIdent [a]) -> Map NontermIdent (Map ConstructorIdent [a]) -> Map NontermIdent (Map ConstructorIdent [a])+unionunionplusplus = Map.unionWith (Map.unionWith (++))+}+++{+mkUniqueRules :: Options -> Map NontermIdent (Map ConstructorIdent [RuleInfo]) -> DataTypes -> Map NontermIdent (Map ConstructorIdent [(Identifier, Type)]) -> Map NontermIdent (Attributes,Attributes) -> NontermIdent -> ConstructorIdent -> Map Identifier Identifier -> [Rule]+mkUniqueRules opts allRules allFields allInsts allAttrDecls nt con usMap+  = map apply groups+  where+    fields = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allFields)+             ++ Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allInsts)+             -- may have duplicates++    attrDefs = let projectDefs (_,_,_,defs,_,_,_,_) = defs+               in concatMap projectDefs $ Map.findWithDefault [] con $ Map.findWithDefault Map.empty nt allRules++    groups = Map.assocs $ Map.foldrWithKey (\i r m -> Map.insertWith (++) r [i] m) Map.empty usMap+    apply (ref,us) = mkRule ref (findOutField ref) us+    findOutField ref = case [ chld | (chld, NT tp _ _) <- fields, tp `hasSyn` ref] of+                         []    -> _LHS+                         (x:_) -> x+    hasSyn tp ref = Map.member ref $ snd $ Map.findWithDefault (Map.empty,Map.empty) tp allAttrDecls+    mkRule ref outFld locAttrs+      = let locs = filter (not . existsLoc) locAttrs+            outAttr = attr outFld ref+            defs = (if hasOut then [] else [outAttr]) ++ [attr _LOC u | u <- locs ]+            pat = Product noPos defs+            rhs = Expression noPos $ wrap ref $ foldr gencase (finalout hasOut locs) locs+                     -- [HsToken ("mkUniques" ++ show (length locAttrs) ++ " ") noPos, AGField _LHS ref noPos Nothing]+            rul = Rule Nothing pat rhs False "-- generated by the unique rule mechanism." False True False Nothing False+            hasOut = exists outAttr+            exists (Alias fld a _) = (fld,a) `elem` attrDefs+            exists _ = False+            existsLoc nm = exists (attr _LOC nm)+        in rul+    attr fld a = Alias fld a (Underscore noPos)+    gencase nm outp+      = h ("case " ++ uniqueDispenser opts ++ " __cont of { (__cont, " ++ getName nm ++ ") -> ") ++ outp ++ h "}"+    h s = [HsToken s noPos]+    finalout noGenCont us = h ("(" ++ concat (intersperse "," ( (if noGenCont then [] else ["__cont"]) ++ map getName us)) ++ ")")+    wrap ref inp = h "let __cont = " ++ [AGField _LHS ref noPos Nothing] ++ h " in seq __cont ( " ++ inp ++ h " )"+}+++-------------------------------------------------------------------------------+--         Checking RHSs of rules (optional)+-------------------------------------------------------------------------------++SEM SemDef | Def MergeDef+  lhs.errors = if checkParseRhs @lhs.options+               then Seq.fromList $ checkRhs @rhs+               else Seq.empty++-- type of a type signature++SEM SemDef | TypeDef+  lhs.errors = if checkParseTy @lhs.options+               then case @tp of+                      Haskell s -> let ex  = Expression @pos tks+                                       tks = [tk]+                                       tk  = HsToken s @pos+                                   in Seq.fromList $ checkTy ex+                      _ -> Seq.empty+               else Seq.empty++-------------------------------------------------------------------------------+--         Collecting fields+-------------------------------------------------------------------------------++ATTR Fields Field [ | | collectedFields USE {++} {[]} : {[(Identifier, Type)]} ]++SEM Field | FChild+  lhs.collectedFields = [(@name, makeType @lhs.allNonterminals @tp)]++-------------------------------------------------------------------------------+--         Collecting constraints+-------------------------------------------------------------------------------++ATTR Fields Field [ | | collectedConstraints USE {++} {[]} : {[Type]} ]++SEM Field | FCtx+  lhs.collectedConstraints = @tps++-------------------------------------------------------------------------------+--         Collecting Set names and Nonterminal names+-------------------------------------------------------------------------------++++SEM Elem+  | Set  lhs.collectedSetNames = Set.singleton @name++SEM Elem+  | Type  lhs.collectedNames = Set.singleton @name++SEM NontSet+  | NamedSet lhs.collectedNames = Set.singleton @name++SEM AG+  | AG   loc.allNonterminals = @elems.collectedNames `Set.difference` @elems.collectedSetNames+++++++SEM ConstructorSet+  | CName lhs.collectedConstructorNames = Set.singleton @name++--SEM Alt+--  | Alt lhs.collectedConstructorNames = Set.singleton @name++SEM Elem+  | Data  lhs.collectedConstructorsMap = Map.fromList+                                         [ (n, @alts.collectedConstructorNames)+                                         | n <- Set.toList @names.nontSet+                                         ]++SEM AG+  | AG elems.allConstructors = @elems.collectedConstructorsMap++++-------------------------------------------------------------------------------+--          Type synonyms+-------------------------------------------------------------------------------++{- At the moment type synonyms are only supported for list types+   This means that only synonyms of the form:+      TYPE <NT> = [ <TP> ]+   are allowed+-}+++ATTR Elem Elems [ | | typeSyns USE {++} {[]} : {TypeSyns} ]++{- Put this synonym in the typeSyns list and+   add the implicit Cons and Nil productions for the type synonym++   A synonym of the form:+        TYPE <NT> = [ <TP> ]+   is translated into:+       DATA <NT> | Cons hd:<TP> tl:<NT>+                 | Nil+-}++SEM Elem+  | Type  loc.expanded       = case @argType of+                                       List tp -> [(Ident "Cons" @pos, [(Ident "hd" @pos, tp)+                                                                       ,(Ident "tl" @pos, NT @name (map getName @params) False)+                                                                       ]+                                                   )+                                                  ,(Ident "Nil" @pos,  [])+                                                  ]+                                       Maybe tp -> [(Ident "Just" @pos, [(Ident "just" @pos, tp)+                                                                       ]+                                                   )+                                                  ,(Ident "Nothing" @pos,  [])+                                                  ]+                                       Either tp1 tp2 -> [+                                                    (Ident "Left"    @pos,  [(Ident "left"  @pos, tp1) ])+                                                  , (Ident "Right"   @pos,  [(Ident "right" @pos, tp2) ])+                                                  ]+                                       Map tp1 tp2 -> [ (Ident "Entry" @pos, [ (Ident "key" @pos, tp1)+                                                                             , (Ident "val" @pos, tp2)+                                                                             , (Ident "tl" @pos, NT @name (map getName @params) False)+                                                                             ])+                                                      , (Ident "Nil" @pos, [])+                                                      ]+                                       IntMap tp   -> [ (Ident "Entry" @pos, [ (Ident "key" @pos, Haskell "Int")+                                                                             , (Ident "val" @pos, tp)+                                                                             , (Ident "tl" @pos, NT @name (map getName @params) False)+                                                                             ])+                                                      , (Ident "Nil" @pos, [])+                                                      ]+                                       OrdSet tp   -> [ (Ident "Entry" @pos, [ (Ident "val" @pos, tp)+                                                                             , (Ident "tl" @pos, NT @name (map getName @params) False) ])+                                                      , (Ident "Nil" @pos, [])+                                                      ]+                                       IntSet      -> [ (Ident "Entry" @pos, [ (Ident "val" @pos, Haskell "Int")+                                                                             , (Ident "tl" @pos, NT @name (map getName @params) False) ])+                                                      , (Ident "Nil" @pos, [])+                                                      ]+                                       Tuple xs -> [(Ident "Tuple" @pos, xs)]+          loc.argType        = case @type of+                                Maybe tp       -> Maybe  (  makeType @lhs.allNonterminals tp)+                                Either tp1 tp2 -> Either (  makeType @lhs.allNonterminals tp1) (makeType @lhs.allNonterminals tp2)+                                List tp        -> List   (  makeType @lhs.allNonterminals tp)+                                Tuple xs       -> Tuple [(f,makeType @lhs.allNonterminals tp) | (f,tp) <- xs]+                                Map tp1 tp2    -> Map    (  makeType @lhs.allNonterminals tp1) (makeType @lhs.allNonterminals tp2)+                                IntMap tp      -> IntMap (  makeType @lhs.allNonterminals tp)+                                OrdSet tp      -> OrdSet (  makeType @lhs.allNonterminals tp)+                                IntSet         -> IntSet+          lhs.typeSyns       = [(@name,@argType)]++-------------------------------------------------------------------------------+--         Interpreting Nonterminal sets+-------------------------------------------------------------------------------+++SEM AG+  | AG+       elems.defSets     = Map.fromList (map (\x->(x,(Set.singleton x, Set.empty))) (Set.toList @loc.allNonterminals))+       elems.definedSets = Map.map fst @elems.defSets+++SEM Elem+  | Set loc.(defSets2,errs) = let allUsedNames = Set.unions [ maybe (Set.singleton n)+                                                                    snd+                                                                    (Map.lookup n @lhs.defSets)+                                                            | n <- Set.toList @set.collectedNames+                                                            ]+                                  (nontSet,e1) | Set.member @name allUsedNames+                                                           = (Set.empty, Seq.singleton(CyclicSet @name))+                                               | otherwise = (@set.nontSet, Seq.empty)+                                  (res, e2) = let toAdd = (nontSet,Set.insert @name allUsedNames)+                                                  un (a,b) (c,d) = (a `Set.union` c, b `Set.union` d)+                                              in if Set.member @name @lhs.allNonterminals || not @merge+                                                 then checkDuplicate DupSet @name toAdd @lhs.defSets+                                                 else (Map.insertWith un @name toAdd @lhs.defSets, Seq.empty)+                              in (res, e1 Seq.>< e2)+        lhs.defSets         = @defSets2+           .errors          = @errs >< @set.errors++SEM NontSet+  | All        lhs.nontSet = @lhs.allNonterminals+  | NamedSet   loc.(nontSet,errors) = case Map.lookup @name @lhs.definedSets of+                                                   Nothing  -> (Set.empty, Seq.singleton (UndefNont @name))+                                                   Just set -> (set, Seq.empty)+  | Union      lhs.nontSet = Set.union         @set1.nontSet @set2.nontSet+  | Intersect  lhs.nontSet = Set.intersection  @set1.nontSet @set2.nontSet+  | Difference lhs.nontSet = Set.difference    @set1.nontSet @set2.nontSet+  | Path       lhs.nontSet = let table = flattenDatas @lhs.allFields+                             in path table @from @to+               lhs.errors = let check name | Set.member name @lhs.allNonterminals+                                                       = Seq.empty+                                           | otherwise = Seq.singleton (UndefNont name)+                            in check @from >< check @to+++{+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 = reach+  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 = foldr inv Map.empty . Map.toList+  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+}++-------------------------------------------------------------------------------+--   Interpreting Constructor Sets+-------------------------------------------------------------------------------+++SEM ConstructorSet+  | CName       lhs.constructors = \_  -> Set.singleton @name+  | CUnion      lhs.constructors = \ds -> @set1.constructors ds `Set.union`      @set2.constructors ds+  | CDifference lhs.constructors = \ds -> @set1.constructors ds `Set.difference` @set2.constructors ds+  | CAll        lhs.constructors = \ds -> ds++-------------------------------------------------------------------------------+--         Collecting wrappers+-------------------------------------------------------------------------------++ATTR Elem Elems [ | | wrappers USE {`Set.union`} {Set.empty} :{Set NontermIdent}]++SEM Elem+  | Wrapper lhs.wrappers = @set.nontSet++-------------------------------------------------------------------------------+--         Collecting nocatas+-------------------------------------------------------------------------------++SEM Elem+  | Nocatas  lhs.pragmas = \o -> o { nocatas = @set.nontSet `Set.union` nocatas o }++-------------------------------------------------------------------------------+--         Collecting pragmas+-------------------------------------------------------------------------------++ATTR AG Elem Elems [ | | pragmas USE {.} {id} :{Options -> Options}]++SEM Elem+  | Pragma  lhs.pragmas = let mk n o = case getName n of+                                         "gencatas"     -> o { folds       = True  }+                                         "nogencatas"   -> o { folds       = False }+                                         "gendatas"     -> o { dataTypes   = True  }+                                         "datarecords"  -> o { dataRecords = True  }+                                         "nogendatas"   -> o { dataTypes   = False }+                                         "gensems"      -> o { semfuns     = True  }+                                         "nogensems"    -> o { semfuns     = False }+                                         "gentypesigs"  -> o { typeSigs    = True  }+                                         "nogentypesigs"-> o { typeSigs    = False }+                                         "nocycle"      -> o { withCycle   = False, loag = 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, loag = 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  }+                                         "breadthfirst" -> o { breadthFirst = True }+                                         "breadthfirstStrict" -> o { breadthFirstStrict = 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"   -> sepSemModsOpt o+                                         "genlinepragmas" -> o { genLinePragmas = True }+                                         "newtypes"       -> o { newtypes = True }+                                         "nonewtypes"     -> o { newtypes = False }+                                         "nooptimizations" -> o { noOptimizations = True }+                                         "kennedywarren"   -> o { kennedyWarren = True }+                                         "aspectag"        -> o { genAspectAG = True }+                                         'n':'o':'g':'r':'o':'u':'p':'_':atts+                                                           -> o { noGroup =  extract atts  ++ noGroup o }+                                         "rename"          -> o { rename = True }+                                         "parallel"        -> o { parallelInvoke = True }+                                         "monadicwrappers" -> o { monadicWrappers = True }++                                         "dummytokenvisit" -> o { dummyTokenVisit = True }+                                         "tupleasdummytoken" -> o { tupleAsDummyToken = True }+                                         "stateasdummytoken" -> o { tupleAsDummyToken = False }+                                         "strictdummytoken" -> o { strictDummyToken = True }+                                         "noperruletypesigs" -> o { noPerRuleTypeSigs = True }+                                         "noperstatetypesigs" -> o { noPerStateTypeSigs = True }+                                         "noeagerblackholing" -> o { noEagerBlackholing = True }+                                         "noperrulecostcentres" -> o { noPerRuleCostCentres = True }+                                         "nopervisitcostcentres" -> o { noPerVisitCostCentres = True }+                                         "helpinlining" -> o { helpInlining = True }+                                         "noinlinepragmas" -> o { noInlinePragmas = True }+                                         "aggressiveinlinepragmas" -> o { aggressiveInlinePragmas = True }+                                         "latehigherorderbindings" -> o { lateHigherOrderBinding = True }+                                         "ocaml"                   -> ocamlOpt o+                                         "cleanlang"               -> cleanOpt o++                                         s              -> trace ("uuagc: ignoring unknown pragma: " ++ s) o+                          in \o -> foldr mk o @names++{+extract :: String -> [String]+extract s = case dropWhile isSeparator s of+                                "" -> []+                                s' -> w : extract s''+                                      where (w, s'') = break isSeparator  s'+isSeparator :: Char -> Bool+isSeparator x = x == '_'+}++ATTR Elem Elems SemAlts SemAlt [ | | semPragmasCollect USE {`pragmaMapUnion`} {Map.empty} : {PragmaMap} ]++SEM SemAlt+  | SemAlt+      loc.pragmaNames       = Set.fromList @rules.pragmaNamesCollect+      lhs.semPragmasCollect = foldr pragmaMapUnion Map.empty [ pragmaMapSingle nt con @loc.pragmaNames+                                                             | (nt, conset, _) <- @loc.coninfo+                                                             , con <- Set.toList conset+                                                             ]++ATTR SemDefs SemDef [ | | pragmaNamesCollect USE {++} {[]} : {[Identifier]} ]++SEM SemDef+  | SemPragma+      lhs.pragmaNamesCollect = @names++{+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)+}++-------------------------------------------------------------------------------+--         Collecting attribute orders+-------------------------------------------------------------------------------++ATTR Elem Elems SemAlts SemAlt [ | | attrOrderCollect USE {`orderMapUnion`} {Map.empty} : {AttrOrderMap} ]+ATTR Elem Elems SemAlts SemAlt [ allAttrDecls : {Map NontermIdent (Attributes, Attributes)} | | ]++SEM SemAlt+  | SemAlt+      loc.attrOrders+        = [ orderMapSingle nt con @rules.orderDepsCollect+          | (nt, conset, _) <- @loc.coninfo+          , con <- Set.toList conset+          ]++      lhs.attrOrderCollect = foldr orderMapUnion Map.empty @loc.attrOrders++ATTR SemDefs SemDef [ | | orderDepsCollect USE {`Set.union`} {Set.empty} : {Set Dependency} ]++SEM SemDef+  | AttrOrderBefore+      loc.dependency       = [ Dependency b a | b <- @before, a <- @after ]+      lhs.orderDepsCollect = Set.fromList @loc.dependency++{+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)+}++-------------------------------------------------------------------------------+--         Collecting nonterminal type parameters+-------------------------------------------------------------------------------++ATTR Elem Elems [ | | paramsCollect USE {`mergeParams`} {Map.empty} : {ParamMap}]++SEM Elem+  | Data+      lhs.paramsCollect = if null @params+                          then Map.empty+                          else Map.fromList [(nt, @params) | nt <- Set.toList @names.nontSet]++SEM Elem+  | Type+      lhs.paramsCollect = if null @params+                          then Map.empty+                          else Map.singleton @name @params++{+mergeParams :: ParamMap -> ParamMap -> ParamMap+mergeParams = Map.unionWith (++)+}++-------------------------------------------------------------------------------+--         Collecting class contexts of semantic functions+-------------------------------------------------------------------------------++ATTR Elem Elems [ | | ctxCollect USE {`mergeCtx`} {Map.empty} : {ContextMap}]++SEM Elem+  | Sem Data Attr+      lhs.ctxCollect = if null @ctx+                       then Map.empty+                       else Map.fromList [(nt, @ctx) | nt <- Set.toList @names.nontSet]++SEM Elem+  | Type+      lhs.ctxCollect = if null @ctx+                       then Map.empty+                       else Map.singleton @name @ctx++{+mergeCtx :: ContextMap -> ContextMap -> ContextMap+mergeCtx+  = Map.unionWith nubconcat+  where nubconcat a b = nub (a ++ b)+}++-------------------------------------------------------------------------------+--         Collecting quantifiers of semantic functions+-------------------------------------------------------------------------------++ATTR Elem Elems [ | | quantCollect USE {`mergeQuant`} {Map.empty} : {QuantMap}]++SEM Elem+  | Sem Attr+      lhs.quantCollect = if null @quants+                         then Map.empty+                         else Map.fromList [(nt, @quants) | nt <- Set.toList @names.nontSet]++{+mergeQuant :: QuantMap -> QuantMap -> QuantMap+mergeQuant = Map.unionWith (++)+}++-------------------------------------------------------------------------------+--         Collecting derivings+-------------------------------------------------------------------------------++ATTR Elem Elems [ | | derivings USE {`mergeDerivings`} {Map.empty} :{Derivings}]++{+mergeDerivings :: Derivings -> Derivings -> Derivings+mergeDerivings m1 m2 = foldr (\(n,cs) m -> Map.insertWith Set.union n cs m) m2 (Map.toList m1)+}++SEM Elem+  | Deriving lhs.derivings = Map.fromList [(nt,Set.fromList @classes) | nt <- Set.toList @set.nontSet]++-------------------------------------------------------------------------------+--         Collecting ATTR declarations+-------------------------------------------------------------------------------++{+merge ::(Ord k, Ord k1) => Map k (Map k1 a) -> Map k (Map k1 a) -> Map k (Map k1 a)+merge x y = foldr f y (Map.toList x)+ where f ~(k,v) m = Map.insertWith (Map.union) k v m+}++SEM AG+  | AG elems.attrDecls = Map.empty++SEM Elem+  | Data attrs.nts = @names.nontSet+  | Attr attrs.nts = @names.nontSet+  | Sem  attrs.nts = @names.nontSet+++SEM Attrs [ nts:{Set NontermIdent} | | ]+  | Attrs loc.(attrDecls,errors) = checkAttrs @lhs.allFields (Set.toList @lhs.nts) @inherited @synthesized @lhs.attrDecls++             .(inherited,synthesized,useMap) = let splitAttrs xs = unzip [ ((n,makeType @lhs.allNonterminals t),(n,ud))+                                                                         | (n,t,ud) <- xs+                                                                         ]+                                                   (inh,_)     = splitAttrs @inh+                                                   (chn,uses1) = splitAttrs @chn+                                                   (syn,uses2) = splitAttrs @syn+                                                   isUse (_,(e1,e2,_)) = not (null e1 || null e2)+                                               in (inh++chn,chn++syn, Map.fromList (Prelude.filter isUse (uses1++uses2)))+          lhs.useMap = Map.fromList (zip (Set.toList @lhs.nts) (repeat @useMap))++          loc.errors1 = if checkParseTy @lhs.options+                        then let attrs  = @inh ++ @syn ++ @chn+                                 items = map (\(ident,tp,_) -> (getPos ident, tp)) attrs+                                 errs  = map check items+                                 check (pos,Haskell s) =+                                   let ex  = Expression pos tks+                                       tks = [tk]+                                       tk  = HsToken s pos+                                   in Seq.fromList $ checkTy ex+                                 check _ = Seq.empty+                             in foldr (Seq.><) Seq.empty errs+                        else Seq.empty+          lhs.errors = @loc.errors Seq.>< @loc.errors1+++{+checkAttrs :: DataTypes -> [NontermIdent] -> [(Identifier, a)] -> [(Identifier, b)] -> Map NontermIdent (Map Identifier a, Map Identifier b) -> (Map NontermIdent (Map Identifier a, Map Identifier b), Seq Error)+checkAttrs allFields nts inherited synthesized decls' = foldErrors check decls' nts where+  check nt decls | not (nt `Map.member` allFields) = (decls,Seq.singleton(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)+}+++-- Add declaration of self-attribute for each nonterminal: ATTR <nt> [ | | self:SELF]+{+addSelf :: Ord k1 => k1 -> Map k1 (Map k a, Attributes) -> Map k1 (Map k a, Attributes)+addSelf name atMap = let (eInh,eSyn) = Map.findWithDefault(Map.empty,Map.empty) name atMap+                     in  Map.insert name (eInh, Map.insert (Ident "self" noPos) Self eSyn)atMap+}+++SEM AG+  | AG  loc.allAttrDecls = if withSelf @lhs.options+                            then foldr addSelf @elems.attrDecls (Set.toList @loc.allNonterminals)+                            else               @elems.attrDecls++-------------------------------------------------------------------------------+--         Collecting rules+-------------------------------------------------------------------------------+++ATTR SemDef SemDefs [ | | ruleInfos    USE {++} {[]} : {[RuleInfo]}+                          sigInfos     USE {++} {[]} : {[SigInfo]}+                          uniqueInfos  USE {++} {[]} : {[UniqueInfo]}+                          augmentInfos USE {++} {[]} : {[AugmentInfo]}+                          aroundInfos  USE {++} {[]} : {[AroundInfo]}+                          mergeInfos   USE {++} {[]} : {[MergeInfo]}+                    ]+++SEM SemAlt+  | SemAlt loc.coninfo = [ (nt, conset, conkeys)+                         | nt  <- Set.toList @lhs.nts+                         , let conmap = Map.findWithDefault Map.empty nt @lhs.allFields+                         , let conkeys = Set.fromList (Map.keys conmap)+                         , let conset  = @constructorSet.constructors conkeys+                         ]++           lhs.errors = Seq.fromList+                           [ UndefAlt nt con+                           | (nt, conset, conkeys) <- @loc.coninfo+                           , con <- Set.toList (Set.difference conset conkeys)+                           ]+                        Seq.>< @rules.errors+           lhs.collectedRules+               =       [ (nt,con,r)+                       | (nt, conset, _) <- @loc.coninfo+                       , con <- Set.toList conset+                       , r <- @rules.ruleInfos+                       ]+           lhs.collectedSigs+               =       [ (nt,con,ts)+                       | (nt, conset, _) <- @loc.coninfo+                       , con <- Set.toList conset+                       , ts <- @rules.sigInfos+                       ]++           lhs.collectedInsts+               =       [ (nt,con,@rules.definedInsts)+                       | (nt, conset, _) <- @loc.coninfo+                       , con <- Set.toList conset+                       ]++           lhs.collectedUniques+               =       [ (nt,con,@rules.uniqueInfos)+                       | (nt, conset, _) <- @loc.coninfo+                       , con <- Set.toList conset+                       ]++           lhs.collectedAugments+              =        [ (nt, con, @rules.augmentInfos)+                       | (nt, conset, _) <- @loc.coninfo+                       , con <- Set.toList conset+                       ]++           lhs.collectedArounds+              =        [ (nt, con, @rules.aroundInfos)+                       | (nt, conset, _) <- @loc.coninfo+                       , con <- Set.toList conset+                       ]++           lhs.collectedMerges+             =         [ (nt, con, @rules.mergeInfos)+                       | (nt, conset, _) <- @loc.coninfo+                       , con <- Set.toList conset+                       ]++SEM SemDef+  | Def  lhs.ruleInfos = [ (@mbName, @pattern.patunder, @rhs, @pattern.definedAttrs, @owrt, show @pattern.stpos, @pure, @eager) ]++SEM SemDef+  | TypeDef  lhs.sigInfos = [ (@ident, @tp) ]++SEM SemDef+  | UniqueDef  lhs.uniqueInfos = [ (@ident, @ref) ]++SEM SemDef+  | AugmentDef  lhs.augmentInfos = [ (@ident, @rhs) ]++SEM SemDef+  | AroundDef   lhs.aroundInfos = [ (@ident, @rhs) ]++SEM SemDef+  | MergeDef    lhs.mergeInfos = [ (@target, @nt, @sources, @rhs) ]+++ATTR SemDef SemDefs Pattern Patterns [|| definedInsts USE {++} {[]} : {[Identifier]} ]+ATTR Pattern Patterns [ | | definedAttrs USE {++} {[]} : {[AttrName]} ]+ATTR Pattern [ | | patunder : {[AttrName]->Pattern} ]+ATTR Patterns [ | | patunder : {[AttrName]->Patterns} ]++SEM Pattern+  | Alias lhs.definedAttrs = (@field, @attr) : @pat.definedAttrs+          lhs.patunder     = \us -> if ((@field,@attr) `elem` us) then Underscore noPos else @copy+          lhs.definedInsts = (if @field == _INST then [@attr] else []) ++ @pat.definedInsts+  | Underscore lhs.patunder = \_ -> @copy+  | Constr lhs.patunder    = \us -> Constr @name (@pats.patunder us)+  | Product lhs.patunder    = \us -> Product @pos (@pats.patunder us)+  | Irrefutable lhs.patunder = \us -> Irrefutable (@pat.patunder us)++SEM Patterns+  | Nil lhs.patunder = \_ ->  []+  | Cons lhs.patunder = \us -> (@hd.patunder us) : (@tl.patunder us)++ATTR Pattern [ | | stpos : Pos ]++SEM Pattern+  | Constr     lhs.stpos = getPos @name+  | Product    lhs.stpos = @pos+  | Alias      lhs.stpos = getPos @field+  | Underscore lhs.stpos = @pos++-------------------------------------------------------------------------------+--         Collect module declaration+-------------------------------------------------------------------------------++ATTR AG Elems Elem [ | | moduleDecl USE {`flipmplus`} {mzero} : {Maybe (String,String,String)} ]++SEM Elem+  | Module+      lhs.moduleDecl = Just (@name, @exports, @imports)++{+-- We want the last Just in the list+flipmplus = flip mplus+}++-------------------------------------------------------------------------------+--         Constructing transformed syntax tree+-------------------------------------------------------------------------------+{+makeType :: Set NontermIdent -> Type -> Type+makeType nts tp@(NT x _ _)   | Set.member x nts = tp+                             | otherwise        = Haskell (typeToHaskellString Nothing [] tp)+makeType _   tp                                 = tp+}+{+constructGrammar ::    Set NontermIdent+                    -> ParamMap+                    -> Map NontermIdent (Map ConstructorIdent (Set Identifier))+                    -> DataTypes+                    -> Map NontermIdent [ConstructorIdent]+                    -> Map NontermIdent (Map ConstructorIdent [Type])+                    -> 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+                    -> 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)))+                    -> Map NontermIdent (Map ConstructorIdent MaybeMacro)+                    -> Grammar++constructGrammar _ ntParams prodParams gram prodOrder constraints attrs uses derivings wrap allrules tsigs allinsts tsyns pragmaMap orderMap contextMap quantMap uniqueMap augmentsMap aroundsMap mergeMap macros =+   let gr = [ (nt,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+                             mergemap  = Map.findWithDefault Map.empty             nt mergeMap+                             macromap  = Map.findWithDefault Map.empty             nt macros+                             csmap     = Map.findWithDefault Map.empty             nt constraints+                             psmap     = Map.findWithDefault Map.empty             nt prodParams+                             prs       = Map.findWithDefault []                    nt prodOrder+                             alt con   =+                                   let flds    = Map.findWithDefault [] con alts+                                       rules   = Map.findWithDefault [] con rmap+                                       tsigs'  = Map.findWithDefault [] con tsmap+                                       insts   = Map.findWithDefault [] con instsmap+                                       merges  = [ (n, NT t [] False) | (n, (t, _, _)) <- Map.assocs $ maybe Map.empty id (Map.lookup con mergemap) ]+                                       cs      = Map.findWithDefault [] con csmap+                                       ps      = Set.elems $ Map.findWithDefault Set.empty con psmap+                                       mbMacro = Map.findWithDefault Nothing con macromap++                                       -- important: keep order of children+                                       cldrn = map child (flds ++ filter (not . existsAsField) insts ++ merges)+                                       child (nm, tp) =+                                          let tpI = if existsAsInst nm+                                                    then fromJust $ lookup nm insts+                                                    else tp+                                              virt = if existsAsInst nm+                                                     then case lookup nm flds of+                                                            Just tp' -> ChildReplace tp'+                                                            Nothing  -> ChildAttr+                                                     else if existsAsMerge nm+                                                          then ChildAttr+                                                          else ChildSyntax+                                          in Child nm tpI virt+                                       existsAsInst nm = maybe False (const True) (lookup nm insts)+                                       existsAsField (nm,_) = maybe False (const True) (lookup nm flds)+                                       existsAsMerge nm = maybe False (const True) (lookup nm merges)+                                   in Production con ps cs cldrn rules tsigs' mbMacro+                            in Nonterminal nt params inh syn (map alt prs)+   in Grammar tsyns uses derivings wrap nonts pragmaMap orderMap ntParams contextMap quantMap uniqueMap augmentsMap aroundsMap mergeMap+}++{+mapUnionWithSetUnion :: Map NontermIdent (Set ConstructorIdent) -> Map NontermIdent (Set ConstructorIdent) -> Map NontermIdent (Set ConstructorIdent)+mapUnionWithSetUnion = Map.unionWith Set.union+mapUnionWithPlusPlus :: Map BlockInfo [a] -> Map BlockInfo [a] -> Map BlockInfo [a]+mapUnionWithPlusPlus = Map.unionWith (++)+}+++--marcos+-------------------------------------------------------------------------------+--         Collecting Macro information+-------------------------------------------------------------------------------++ATTR Alt Alts Elem Elems+     [ | | collectedMacros USE {++} {[]} : {[(NontermIdent, ConstructorIdent, MaybeMacro)]}]+++SEM Alt+  | Alt  lhs.collectedMacros  =       [ (nt, con, @macro)+                                      | nt  <- Set.toList @lhs.nts+                                      , con <- Set.toList (@names.constructors (Map.findWithDefault Set.empty nt @lhs.allConstructors))+                                      ]+++SEM AG+  | AG++         loc.allMacros   = let f (nt,con,m) = Map.insertWith (Map.union) nt (Map.singleton con m)+                           in  foldr f (Map.empty) @elems.collectedMacros+++-------------------------------------------------------------------------------+--         Collecting the AGI information+-------------------------------------------------------------------------------++ATTR AG [ | | agi : {(Set NontermIdent, DataTypes, Map NontermIdent (Attributes, Attributes))} ]++ATTR Elem Elems SemAlts SemAlt [ allAttrs : {Map NontermIdent (Attributes, Attributes)} | | ]++SEM AG+  | AG lhs.agi      = (@loc.allNonterminals,@loc.allFields,@loc.allAttrs)++       loc.allAttrs =  if withSelf @lhs.options+                            then foldr addSelf @elems.attrs (Set.toList @loc.allNonterminals)+                            else               @elems.attrs++ATTR Elems Elem Attrs+     [ | attrs : {Map NontermIdent (Attributes, Attributes)} | ]++SEM AG+  | AG  elems.attrs = Map.empty+++SEM Attrs+  | Attrs lhs.attrs =   let ins decls nt = if Map.member nt decls+                                           then  Map.update (\(inh,syn) -> Just ( Map.union inh $ Map.fromList @inherited+                                                                                     , Map.union syn $ Map.fromList @synthesized)) nt decls+                                           else  Map.insert nt (Map.fromList @inherited, Map.fromList @synthesized) decls++                        in  foldl ins @lhs.attrs (Set.toList @lhs.nts)+++-------------------------------------------------------------------------------+--         Collecting the data type information+-------------------------------------------------------------------------------++ATTR AG Elems Elem+  [ | | constructorTypeMap USE {`Map.union`} {Map.empty} : {Map NontermIdent ConstructorType} ]+  +SEM Elem+  | Data lhs.constructorTypeMap = Set.fold (\nm mp -> Map.insert nm @contype mp) Map.empty @names.collectedNames
src-ag/Visage.ag view
@@ -1,122 +1,122 @@-INCLUDE "VisageSyntax.ag"
-INCLUDE "VisagePatterns.ag"
-INCLUDE "Expression.ag"
-
-
-imports {
-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
-}
-
-{
-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
-}
-
-WRAPPER VisageGrammar
-
-ATTR VisageGrammar VisageNonterminal VisageProduction 
-     VisageChild VisageRule Expression VisagePattern [ || aterm:{ATerm} ]
-ATTR VisageNonterminals VisageProductions VisageChildren 
-     VisageRules VisagePatterns [ || aterms:{[ATerm]} ]
-ATTR VisageRules -> VisageRule [ isLoc : Bool | | ]
-
-SEM VisageGrammar
-  | VGrammar     lhs.aterm = AAppl "Productions" @nonts.aterms
-
-
-SEM VisageNonterminals
-  | Cons        lhs.aterms = @hd.aterm : @tl.aterms
-  | Nil         lhs.aterms = []
-
-
-SEM VisageNonterminal
-  | VNonterminal  lhs.aterm = AAppl "Production" [AString (sQ (getName @nt)), AString (sQ(showMap @inh)), 
-                                                 AString (sQ(showMap @syn)), AAppl "Alternatives" @alts.aterms]
-
-
-SEM VisageProductions
-  | Cons        lhs.aterms = @hd.aterm : @tl.aterms
-  | Nil         lhs.aterms = []
-
-
-SEM VisageProduction
-  | VProduction lhs.aterm = AAppl "Alternative" [AString (sQ (getName @con)), AAppl "Children" @children.aterms, 
-                                                  AAppl "Rules" @rules.aterms, 
-                                                  AAppl "LocRules" @locrules.aterms] 
-                 locrules.isLoc = True
-                 rules.isLoc    = False
-                                  
-SEM VisageChildren
-  | Cons        lhs.aterms = @hd.aterm : @tl.aterms
-  | Nil         lhs.aterms = [] 
-
-
-SEM VisageChild
-  | VChild       lhs.aterm = AAppl "Child" [AString (sQ (getName @name)), AString (sQ (show @tp)), 
-                                            AString (sQ (showMap @inh)), 
-                                            AString (sQ (showMap @syn)), 
-                                            AAppl "Rules" @rules.aterms]
-                 rules.isLoc = False
-                 
-SEM VisageRules
-  | Cons        lhs.aterms = @hd.aterm : @tl.aterms
-  | Nil         lhs.aterms = []
-
-
-SEM VisageRule
-  | VRule        lhs.aterm = AAppl (if @lhs.isLoc then "LocRule" else "Rule") 
-                                   ([AString (sQ (getName @attr)), @pat.aterm, @rhs.aterm] ++ if @lhs.isLoc then [AString (sQ (show @owrt))] else [])
-  
-
-
-SEM Expression
-  | Expression  lhs.aterm = AAppl "Expression" [AString (sQ (showAGPos @pos)), AString (sQ (unlines . showTokens . tokensToStrings $ @tks))]
-
-
-SEM VisagePatterns
-  | Cons        lhs.aterms = @hd.aterm : @tl.aterms
-  | Nil         lhs.aterms = []
-
-
-SEM VisagePattern
-  | VConstr      lhs.aterm = AAppl "Pattern" [AAppl "Constr" [AString (sQ (showAGPos (getPos @name))), 
-                                              AString (sQ (getName @name)), 
-                                              AAppl "Patterns" @pats.aterms]]
-  | VProduct     lhs.aterm = AAppl "Pattern" [AAppl "Product" [AString (sQ (showAGPos @pos)), 
-                                                               AAppl "Patterns" @pats.aterms]]
-  | VVar         lhs.aterm = AAppl "Pattern" [AAppl "Var" [AString (sQ (showAGPos (getPos @field))), 
-                                                           AString (sQ (getName @field ++ "." ++ getName @attr))]]
-  | VAlias       lhs.aterm = AAppl "Pattern" [AAppl "Alias" [AString (sQ (showAGPos (getPos @field))), 
-                                                             AString (sQ (getName @field ++ "." ++ getName @attr)), @pat.aterm]]
-  | VUnderscore  lhs.aterm = AAppl "Pattern" [AAppl "Underscore" [AString (sQ (showAGPos @pos))]]
-
+INCLUDE "VisageSyntax.ag"+INCLUDE "VisagePatterns.ag"+INCLUDE "Expression.ag"+++imports {+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+}++{+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+}++WRAPPER VisageGrammar++ATTR VisageGrammar VisageNonterminal VisageProduction +     VisageChild VisageRule Expression VisagePattern [ || aterm:{ATerm} ]+ATTR VisageNonterminals VisageProductions VisageChildren +     VisageRules VisagePatterns [ || aterms:{[ATerm]} ]+ATTR VisageRules -> VisageRule [ isLoc : Bool | | ]++SEM VisageGrammar+  | VGrammar     lhs.aterm = AAppl "Productions" @nonts.aterms+++SEM VisageNonterminals+  | Cons        lhs.aterms = @hd.aterm : @tl.aterms+  | Nil         lhs.aterms = []+++SEM VisageNonterminal+  | VNonterminal  lhs.aterm = AAppl "Production" [AString (sQ (getName @nt)), AString (sQ(showMap @inh)), +                                                 AString (sQ(showMap @syn)), AAppl "Alternatives" @alts.aterms]+++SEM VisageProductions+  | Cons        lhs.aterms = @hd.aterm : @tl.aterms+  | Nil         lhs.aterms = []+++SEM VisageProduction+  | VProduction lhs.aterm = AAppl "Alternative" [AString (sQ (getName @con)), AAppl "Children" @children.aterms, +                                                  AAppl "Rules" @rules.aterms, +                                                  AAppl "LocRules" @locrules.aterms] +                 locrules.isLoc = True+                 rules.isLoc    = False+                                  +SEM VisageChildren+  | Cons        lhs.aterms = @hd.aterm : @tl.aterms+  | Nil         lhs.aterms = [] +++SEM VisageChild+  | VChild       lhs.aterm = AAppl "Child" [AString (sQ (getName @name)), AString (sQ (show @tp)), +                                            AString (sQ (showMap @inh)), +                                            AString (sQ (showMap @syn)), +                                            AAppl "Rules" @rules.aterms]+                 rules.isLoc = False+                 +SEM VisageRules+  | Cons        lhs.aterms = @hd.aterm : @tl.aterms+  | Nil         lhs.aterms = []+++SEM VisageRule+  | VRule        lhs.aterm = AAppl (if @lhs.isLoc then "LocRule" else "Rule") +                                   ([AString (sQ (getName @attr)), @pat.aterm, @rhs.aterm] ++ if @lhs.isLoc then [AString (sQ (show @owrt))] else [])+  +++SEM Expression+  | Expression  lhs.aterm = AAppl "Expression" [AString (sQ (showAGPos @pos)), AString (sQ (unlines . showTokens . tokensToStrings $ @tks))]+++SEM VisagePatterns+  | Cons        lhs.aterms = @hd.aterm : @tl.aterms+  | Nil         lhs.aterms = []+++SEM VisagePattern+  | VConstr      lhs.aterm = AAppl "Pattern" [AAppl "Constr" [AString (sQ (showAGPos (getPos @name))), +                                              AString (sQ (getName @name)), +                                              AAppl "Patterns" @pats.aterms]]+  | VProduct     lhs.aterm = AAppl "Pattern" [AAppl "Product" [AString (sQ (showAGPos @pos)), +                                                               AAppl "Patterns" @pats.aterms]]+  | VVar         lhs.aterm = AAppl "Pattern" [AAppl "Var" [AString (sQ (showAGPos (getPos @field))), +                                                           AString (sQ (getName @field ++ "." ++ getName @attr))]]+  | VAlias       lhs.aterm = AAppl "Pattern" [AAppl "Alias" [AString (sQ (showAGPos (getPos @field))), +                                                             AString (sQ (getName @field ++ "." ++ getName @attr)), @pat.aterm]]+  | VUnderscore  lhs.aterm = AAppl "Pattern" [AAppl "Underscore" [AString (sQ (showAGPos @pos))]]+
src-ag/VisagePatterns.ag view
@@ -1,19 +1,19 @@-imports
-{
-import UU.Scanner.Position(Pos)
-import CommonTypes
-}
-
-TYPE VisagePatterns   = [VisagePattern]
-
-DATA VisagePattern    | VConstr     name  : {ConstructorIdent}
-                                    pats  : VisagePatterns
-                      | VProduct    pos   : {Pos}
-                                    pats  : VisagePatterns
-                      | VVar        field : {Identifier}             
-                                    attr  : {Identifier}
-                      | VAlias      field : {Identifier}
-                                    attr  : {Identifier}
-                                    pat   : VisagePattern
-                      | VUnderscore pos   : {Pos}
-
+imports+{+import UU.Scanner.Position(Pos)+import CommonTypes+}++TYPE VisagePatterns   = [VisagePattern]++DATA VisagePattern    | VConstr     name  : {ConstructorIdent}+                                    pats  : VisagePatterns+                      | VProduct    pos   : {Pos}+                                    pats  : VisagePatterns+                      | VVar        field : {Identifier}             +                                    attr  : {Identifier}+                      | VAlias      field : {Identifier}+                                    attr  : {Identifier}+                                    pat   : VisagePattern+                      | VUnderscore pos   : {Pos}+
src-ag/VisageSyntax.ag view
@@ -1,42 +1,42 @@-imports
-{
-import CommonTypes
-import UU.Pretty
-import AbstractSyntax
-import VisagePatterns
-import Expression
-}
-
-DATA VisageGrammar      | VGrammar nonts : VisageNonterminals
-
-TYPE VisageNonterminals  = [VisageNonterminal]
-
-TYPE VisageProductions = [VisageProduction]
-
-TYPE VisageChildren     = [VisageChild]
-
-TYPE VisageRules        = [VisageRule]
-
-DATA VisageNonterminal   | VNonterminal nt   : {NontermIdent}
-                                        inh  : {Attributes}
-                                        syn  : {Attributes}
-                                        alts : VisageProductions
-
-DATA VisageProduction  | VProduction   con      : {ConstructorIdent}
-                                       children : VisageChildren
-                                       rules    : VisageRules
-                                       locrules : VisageRules
-
-
-DATA VisageChild        | VChild   name  : {Identifier}
-                                   tp    : {Type}
-                                   inh   : {Attributes}
-                                   syn   : {Attributes}
-                                   rules : VisageRules
-
-DATA VisageRule         | VRule    fieldattrs : {[(Identifier,Identifier)]}
-                                   attr       : {Identifier}
-                                   pat        : VisagePattern
-                                   rhs        : Expression
-                                   owrt       : {Bool}
-
+imports+{+import CommonTypes+import UU.Pretty+import AbstractSyntax+import VisagePatterns+import Expression+}++DATA VisageGrammar      | VGrammar nonts : VisageNonterminals++TYPE VisageNonterminals  = [VisageNonterminal]++TYPE VisageProductions = [VisageProduction]++TYPE VisageChildren     = [VisageChild]++TYPE VisageRules        = [VisageRule]++DATA VisageNonterminal   | VNonterminal nt   : {NontermIdent}+                                        inh  : {Attributes}+                                        syn  : {Attributes}+                                        alts : VisageProductions++DATA VisageProduction  | VProduction   con      : {ConstructorIdent}+                                       children : VisageChildren+                                       rules    : VisageRules+                                       locrules : VisageRules+++DATA VisageChild        | VChild   name  : {Identifier}+                                   tp    : {Type}+                                   inh   : {Attributes}+                                   syn   : {Attributes}+                                   rules : VisageRules++DATA VisageRule         | VRule    fieldattrs : {[(Identifier,Identifier)]}+                                   attr       : {Identifier}+                                   pat        : VisagePattern+                                   rhs        : Expression+                                   owrt       : {Bool}+
src-generated/AG2AspectAG.hs view
@@ -3,380 +3,380 @@  module AG2AspectAG where {-# LINE 2 "src-ag/HsToken.ag" #-}-
-import CommonTypes
-import UU.Scanner.Position(Pos)
++import CommonTypes+import UU.Scanner.Position(Pos) {-# LINE 10 "src-generated/AG2AspectAG.hs" #-}  {-# LINE 2 "src-ag/Expression.ag" #-}-
-import UU.Scanner.Position(Pos)
-import HsToken
++import UU.Scanner.Position(Pos)+import HsToken {-# LINE 16 "src-generated/AG2AspectAG.hs" #-}  {-# LINE 2 "src-ag/Patterns.ag" #-}-
--- Patterns.ag imports
-import UU.Scanner.Position(Pos)
-import CommonTypes (ConstructorIdent,Identifier)
++-- Patterns.ag imports+import UU.Scanner.Position(Pos)+import CommonTypes (ConstructorIdent,Identifier) {-# LINE 23 "src-generated/AG2AspectAG.hs" #-}  {-# LINE 2 "src-ag/AbstractSyntax.ag" #-}-
--- AbstractSyntax.ag imports
-import Data.Set(Set)
-import Data.Map(Map)
-import Patterns    (Pattern(..),Patterns)
-import Expression  (Expression(..))
-import Macro --marcos
-import CommonTypes
-import ErrorMessages
++-- AbstractSyntax.ag imports+import Data.Set(Set)+import Data.Map(Map)+import Patterns    (Pattern(..),Patterns)+import Expression  (Expression(..))+import Macro --marcos+import CommonTypes+import ErrorMessages {-# LINE 35 "src-generated/AG2AspectAG.hs" #-}  {-# LINE 8 "src-ag/AG2AspectAG.ag" #-}-
-import Options
-
-import Data.Char
-import Data.List
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import Data.Maybe
-
-import Pretty
-import PPUtil
-import UU.Scanner.Position
-
-import AbstractSyntax
-import TokenDef
-import CommonTypes
-
--- import Debug.Trace
++import Options++import Data.Char+import Data.List+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Maybe++import Pretty+import PPUtil+import UU.Scanner.Position++import AbstractSyntax+import TokenDef+import CommonTypes++-- import Debug.Trace {-# LINE 56 "src-generated/AG2AspectAG.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 28 "src-ag/AG2AspectAG.ag" #-}-
-pragmaAspectAG =  pp  "{-# LANGUAGE EmptyDataDecls, NoMonomorphismRestriction , TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-}"
-
++pragmaAspectAG =  pp  "{-# LANGUAGE EmptyDataDecls, NoMonomorphismRestriction , TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-}"+ {-# LINE 63 "src-generated/AG2AspectAG.hs" #-}  {-# LINE 33 "src-ag/AG2AspectAG.ag" #-}-
-ppName l = ppListSep "" "" "_" l
++ppName l = ppListSep "" "" "_" l {-# LINE 68 "src-generated/AG2AspectAG.hs" #-}  {-# LINE 70 "src-ag/AG2AspectAG.ag" #-}-
-type FieldMap  = [(Identifier, Type)]
-type DataTypes = Map.Map NontermIdent (Map.Map ConstructorIdent FieldMap)
++type FieldMap  = [(Identifier, Type)]+type DataTypes = Map.Map NontermIdent (Map.Map ConstructorIdent FieldMap) {-# LINE 74 "src-generated/AG2AspectAG.hs" #-}  {-# LINE 342 "src-ag/AG2AspectAG.ag" #-}-
-filterAtts newAtts = filter (\att -> Map.member (identifier att) newAtts)
-filterNotAtts newAtts = filter (\att -> not (Map.member (identifier att) newAtts))
-
-defAtt  att = "data " >|< attTName att >|< "; " >|< attName att >|< " = proxy :: Proxy " >|< attTName att
-attName att = pp $ "att_" ++ att
-attTName att = pp $ "Att_" ++ att
-
-
-defAttRec  recPref ppNt atts noGroup  =
-           let     recName    = ppName [recPref, ppNt]
-                   fields     = ppCommas (map (\(a,t) -> ppName [pp a, recName ] >|< " ::" >|< ppShow t) (groupAtts atts noGroup))
-           in
-                   "data " >|<  recName >|< " = " >|< recName >|< " { " >|<   fields  >|< " }"
-
-groupAtts atts noGroup = (Map.toAscList . Map.difference atts) noGroup
-
--- it defines selectors with the form:
--- l1_nt_prod(x, _, .., _) = x
--- ln_nt_prod(_, .., _, x) = x
-defLocalAtts prodName total actual (l:ls) =  ppName [pp l, prodName] >|<
-                                             ppListSep "(" ")" ","  (replicate (actual-1) "_" ++ "x" : replicate (total-actual) "_") >|<
-                                             pp " = x" >-<
-                                             defLocalAtts prodName total (actual+1) ls
-defLocalAtts _        _     _      []     =  empty
-
++filterAtts newAtts = filter (\att -> Map.member (identifier att) newAtts)+filterNotAtts newAtts = filter (\att -> not (Map.member (identifier att) newAtts))++defAtt  att = "data " >|< attTName att >|< "; " >|< attName att >|< " = proxy :: Proxy " >|< attTName att+attName att = pp $ "att_" ++ att+attTName att = pp $ "Att_" ++ att+++defAttRec  recPref ppNt atts noGroup  =+           let     recName    = ppName [recPref, ppNt]+                   fields     = ppCommas (map (\(a,t) -> ppName [pp a, recName ] >|< " ::" >|< ppShow t) (groupAtts atts noGroup))+           in+                   "data " >|<  recName >|< " = " >|< recName >|< " { " >|<   fields  >|< " }"++groupAtts atts noGroup = (Map.toAscList . Map.difference atts) noGroup++-- it defines selectors with the form:+-- l1_nt_prod(x, _, .., _) = x+-- ln_nt_prod(_, .., _, x) = x+defLocalAtts prodName total actual (l:ls) =  ppName [pp l, prodName] >|<+                                             ppListSep "(" ")" ","  (replicate (actual-1) "_" ++ "x" : replicate (total-actual) "_") >|<+                                             pp " = x" >-<+                                             defLocalAtts prodName total (actual+1) ls+defLocalAtts _        _     _      []     =  empty+ {-# LINE 103 "src-generated/AG2AspectAG.hs" #-}  {-# LINE 397 "src-ag/AG2AspectAG.ag" #-}-
-ntsList att ppNtL = "nts_" ++ att ++ " = " >|<  ppListSep "" "" " .*. " ((map fst ppNtL) ++ [pp "hNil"])
-
-filterNts att = filter ( Map.member (identifier att) . snd )
++ntsList att ppNtL = "nts_" ++ att ++ " = " >|<  ppListSep "" "" " .*. " ((map fst ppNtL) ++ [pp "hNil"])++filterNts att = filter ( Map.member (identifier att) . snd ) {-# LINE 110 "src-generated/AG2AspectAG.hs" #-}  {-# LINE 455 "src-ag/AG2AspectAG.ag" #-}-
-data PPRule = PPRule Identifier Identifier Bool ([(Identifier,Type)] -> [Identifier] -> PP_Doc)
-
-ppRule (field,attr) owrt def = PPRule field attr owrt def
-ruleField (PPRule field  _     _     _  ) = field
-ruleAttr  (PPRule _      attr  _     _  ) = attr
-ruleOwrt  (PPRule _      _     owrt  _  ) = owrt
-ruleDef   (PPRule _      _     _     def) = def
-
++data PPRule = PPRule Identifier Identifier Bool ([(Identifier,Type)] -> [Identifier] -> PP_Doc)++ppRule (field,attr) owrt def = PPRule field attr owrt def+ruleField (PPRule field  _     _     _  ) = field+ruleAttr  (PPRule _      attr  _     _  ) = attr+ruleOwrt  (PPRule _      _     owrt  _  ) = owrt+ruleDef   (PPRule _      _     _     def) = def+ {-# LINE 122 "src-generated/AG2AspectAG.hs" #-}  {-# LINE 494 "src-ag/AG2AspectAG.ag" #-}-
-
-defInhGRule ppNt prodName newNT newProd ch rules inhNoGroup synNoGroup chids locals =
-                       let  ppAtt = ppName [pp "inh", prodName]
-                            ppR =  ppAtt >|< pp " = inhdefM att_inh nts_group $" >-<
-                                   indent 4  "do " >-<
-                                   indent 5  "loc <- at loc" >-<
-                                   indent 5  "lhs <- at lhs" >-<
-                                   indent 5  ch >-<
-                                   indent 5  "return $"  >-<
-                                   indent 6  (foldr (>-<) (pp "emptyRecord") (map (chGRule ppNt prodName rules inhNoGroup synNoGroup chids locals) chids))
-                       in  if (newNT || (not newNT && newProd))
-                           then (ppR, [ ppAtt ])
-                           else (empty, [])
-
-chGRule ppNt prodName rules inhNoGroup synNoGroup chids locals (idCh,tp) =
-                       let  chName = ppName [pp "ch", pp idCh, prodName]
-                            ppTp   = ppShow tp
-                            chRules = ppCommas $ mapGRuleDefs (== idCh)  rules inhNoGroup synNoGroup chids locals
-                       in   if (isNonterminal tp)
-                             then   chName >|< ".=." >-<
-                                    indent 1 "InhG_" >|< ppShow tp >|< pp " {"  >-<
-                                    indent 2 chRules >-<
-                                    indent 1 "} .*. "
-                             else   empty
-
-
-defSynGRule ppNt prod newNT newProd ch rules inhNoGroup synNoGroup chids locals =
-                       let  ppAtt = ppName [pp "syn", ppNt, pp prod]
-                            ppTAtt = "SynG_" >|< ppNt
-                            ppR =  ppAtt >|< pp " = syndefM att_syn $" >-<
-                                   indent 4  "do " >-<
-                                   indent 5  "loc <- at loc" >-<
-                                   indent 5  "lhs <- at lhs" >-<
-                                   indent 5  ch >-<
-                                   indent 5  "return $"  >-<
-                                   indent 6  ppTAtt >|< pp " {"  >-<
-                                   indent 7  (ppCommas $ mapGRuleDefs ((== "lhs") . show)  rules inhNoGroup synNoGroup chids locals) >-<
-                                   indent 6  "}"
-                       in  if (newNT || (not newNT && newProd))
-                           then (ppR, [ ppAtt ])
-                           else (empty, [])
-
-defLocRule ppNt prod newNT newProd ch rules inhNoGroup synNoGroup chids locals =
-                       let  ppAtt  = ppName [pp "loc", ppNt, pp prod]
-                            ppTAtt = ppName [pp "Loc", ppNt, pp prod]
-                            ppR =    ppAtt >|< pp " = locdefM att_loc $" >-<
-                                     indent 4  "do " >-<
-                                     indent 5  "loc <- at loc" >-<
-                                     indent 5  "lhs <- at lhs" >-<
-                                     indent 5  ch >-<
-                                     indent 5  "return $"  >-<
-                                     indent 6  (ppListSep "(" ")" "," $ mapLRuleDefs rules inhNoGroup synNoGroup chids locals)
-                       in  (ppR, [ ppAtt ])
-
-defInstRules ppNt prod newNT newProd ch rules chids locals
-                                             = let  ppAsp     = ppName [pp "inst", ppNt, pp prod]
-                                                    instRules = filter ((=="inst") . show . ruleField) rules
-                                                    ppAtt att = ppListSep "`ext` " "" "_" [pp "inst_ch", pp att, ppNt, pp prod]
-                                               in   (  ppAsp >|< pp " = emptyRule " >|< (map (ppAtt . ruleAttr) instRules) >-<
-                                                       (vlist $ map (defInstRule  ppNt prod ch chids locals) instRules)
-                                                    ,  [ ppAsp ])
-
-
-defInstRule  ppNt prod ch chids locals rule =
-                       let  ppAtt  = ppName [pp "ch", pp (ruleAttr rule), ppNt, pp prod]
-                       in   pp "inst_" >|< ppAtt >|< pp " = instdefM " >|< ppAtt >|< pp " $" >-<
-                            indent 4  "do " >-<
-                            indent 5  "loc <- at loc" >-<
-                            indent 5  "lhs <- at lhs" >-<
-                            indent 5  ch >-<
-                            indent 5  "return $"  >-<
-                            indent 6  ((ruleDef rule) chids locals)
-
-
-defSynRules ppNt prod newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals
-                                             = let  synRules     = filter ( (=="lhs") . show . ruleField)  rules
-                                                    ngRules      = filter ((flip elem synNoGroup) . getName . ruleAttr) synRules
-                                                    (ppR, ppRA)  = unzip $  map (defSynRule True ppNt prod newNT newProd newAtts ch chids locals) ngRules
-                                               in   (vlist ppR, concat ppRA )
-
-modSynRules ppNt prod newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals
-                                             = let  synRules     = filter ( (=="lhs") . show . ruleField)  rules
-                                                    ngRules      = filter ((flip elem synNoGroup) . getName . ruleAttr) synRules
-                                                    (ppR, ppRA)  = unzip $  map (defSynRule False ppNt prod newNT newProd newAtts ch chids locals) ngRules
-                                               in   (vlist ppR, concat ppRA )
-
-defSynRule  new ppNt prod newNT newProd newAtts ch chids locals rule =
-                       let  att    = ruleAttr rule
-                            newAtt = Map.member att newAtts
-                            owrt   = ruleOwrt rule
-                            ppAtt  = ppName [pp att, pp (if new then "syn" else "synM"), ppNt, pp prod]
-                            ppR def =   ppAtt >|< pp (" = " ++ def ++ " ") >|< attName (show att) >|< pp " $" >-<
-                                        indent 4  "do " >-<
-                                        indent 5  "loc <- at loc" >-<
-                                        indent 5  "lhs <- at lhs" >-<
-                                        indent 5  ch >-<
-                                        indent 5  "return $"  >-<
-                                        indent 6  ((ruleDef rule) chids locals)
-                       in   
-                           if new
-                           then  if (not owrt && (newNT || (not newNT && newProd) || newAtt))
-                                 then  (ppR "syndefM", [ ppAtt ])
-                                 else  (empty,         [])
-                           else  if owrt
-                                 then  (ppR "synmodM", [ ppAtt ])
-                                 else  (empty,         [])
-
-
-
-defInhRules ppNt prodName newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals
-                                             = let  ngRules      = filter ((flip elem inhNoGroup) . getName . ruleAttr) rules
-                                                    (ppR, ppRA)  = unzip $ map (defInhRule True  ppNt prodName newNT newProd newAtts ch ngRules inhNoGroup synNoGroup chids locals) inhNoGroup
-                                               in   (vlist ppR, concat ppRA)
-
-modInhRules ppNt prodName newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals
-                                             = let  ngRules      = filter ((flip elem inhNoGroup) . getName . ruleAttr) rules
-                                                    (ppR, ppRA)  = unzip $ map (defInhRule  False ppNt prodName newNT newProd newAtts ch ngRules inhNoGroup synNoGroup chids locals) inhNoGroup
-                                               in   (vlist ppR, concat ppRA)
-
-
-defInhRule new ppNt prodName newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals att =
-                       let  ppAtt       =  ppName [pp att, pp (if new then "inh" else "inhM"),prodName]
-                            newAtt      =  Map.member (identifier att) newAtts
-                            chRMaybe    =  map (chRule new ppNt prodName att rules inhNoGroup synNoGroup chids locals) chids
-                            chR         =  [ x | (Just x) <- chRMaybe ]
-                            ppR def  =  ppAtt >|< pp (" = " ++ def ++ " ") >|< attName att >|< " nts_" >|< att >|< " $" >-<
-                                        indent 4  "do " >-<
-                                        indent 5  "loc <- at loc" >-<
-                                        indent 5  "lhs <- at lhs" >-<
-                                        indent 5  ch >-<
-                                        indent 5  "return $"  >-<
-                                        indent 6  (foldr (>-<) (pp "emptyRecord") chR)
-                       in
-                           if new
-                           then  if (newNT || (not newNT && newProd) || newAtt)
-                                 then  (ppR "inhdefM", [ ppAtt ])
-                                 else  (empty,         [])
-                           else  if (not . null) chR
-                                 then  (ppR "inhmodM", [ ppAtt ])
-                                 else  (empty,         [])
-
-
-chRule new ppNt prodName att rules inhNoGroup synNoGroup chids locals (idCh,tp) =
-                       let  chName = ppName [pp "ch", pp idCh, prodName]
-                            ppTp   = ppShow tp
-                            chRule = inhRuleDef new (== idCh) (== att) rules inhNoGroup synNoGroup chids locals  -- it's supposed to be only one
-                       in   if (isNonterminal tp && (not . null) chRule)
-                             then   Just $ chName >|< ".=. (" >|< chRule >|< ") .*. "
-                             else   Nothing
-
-
-mapLRuleDefs rules inhNoGroup synNoGroup chids locals
-                 = map appSnd $ sortBy cmpField $ filter ((== "loc") . show . ruleField)  rules
-                                      where cmpField r1 r2 = compare (ruleField r1) (ruleField r2)
-                                            appSnd rule = (ruleDef rule)  chids locals
-
-
-mapGRuleDefs filt rules inhNoGroup synNoGroup chids locals
-                 = map appSnd $ sortBy cmpField $ filter (not . (flip elem inhNoGroup) . getName . ruleAttr)
-                                                $ filter (not . (flip elem synNoGroup) . getName . ruleAttr)
-                                                $ filter ( filt . ruleField)  rules
-                                      where cmpField r1 r2 = compare (ruleField r1) (ruleField r2)
-                                            appSnd rule = (ruleDef rule)  chids locals
-
-inhRuleDef new filt1 filt2 rules inhNoGroup synNoGroup chids locals
-                 = map appSnd $ sortBy cmpField $ filter ( (== not new) . ruleOwrt)
-                                                $ filter ((flip elem inhNoGroup) . getName . ruleAttr)
-                                                $ filter ( filt2 . getName . ruleAttr)
-                                                $ filter ( filt1 . ruleField)  rules
-                                      where cmpField r1 r2 = compare (ruleField r1) (ruleField r2)
-                                            appSnd rule = (ruleDef rule)  chids locals
-
-defRule ppNt (field,att) noGroup rhs = \chids locals ->
-                                     let ppAtt = if (elem (getName att) noGroup)
-                                                  then empty
-                                                  else case (show field) of
-                                                        "lhs"     -> att >|< "_" >|< pp "SynG" >|< pp "_" >|< ppNt  >|< " = "
-                                                        "loc"     -> empty
-                                                        "inst"    -> empty
-                                                        otherwise -> att >|< "_" >|< pp "InhG" >|< pp "_" >|<
-                                                                     (maybe (error $ "lhs field " ++ show field ++" is not a child")
-                                                                            ppShow (lookup field chids))
-                                                                     >|< " = "
-                                     in  ppAtt >|< (rhs noGroup field chids locals)
-
-
-rhsRule ppNt ppProd tks noGroup field chids locals  =  vlist . lines2PP . (map (token2PP ppNt ppProd field chids locals noGroup )) $ tks
-
-
-lines2PP [] = []
-lines2PP xs = map line2PP . shiftLeft . getLines $ xs
-
-
-token2PP ppNt ppProd field chids locals noGroup  tk
-  = case tk of
-      AGLocal var pos _        -> (pos, if (elem var locals)
-                                        then  (ppListSep "(" "" "_" [pp var, ppNt, ppProd]) >|< pp " (loc # att_loc)) "
-                                        else  pp var)
-      AGField field attr pos _ -> let ppChT =    maybe (error $ "rhs field " ++ show field ++ " is not a child") ppShow (lookup field chids)
-                                      ppAtt =    case (show field) of
-                                                 "lhs"      ->  attName "inh"
-                                                 "loc"      ->  attName "loc"
-                                                 otherwise  ->  attName "syn"
-                                      ppSubAtt = case (show field) of
-                                                 "lhs"      -> ppName [pp (getName attr), pp "InhG", ppNt]
-                                                 "loc"      -> ppName [pp (getName attr), ppNt, ppProd]
-                                                 otherwise  -> ppName [pp (getName attr), pp "SynG", ppChT]
-                                  in  (pos, if ((elem (getName attr) noGroup) && ((show field) /= "loc"))
-                                             then pp "(" >|< pp (getName field)  >|< " # " >|< attName (getName attr) >|< pp ")"
-                                             else pp "(" >|< ppSubAtt >|< " (" >|< pp (getName field) >|< " # " >|< ppAtt >|< ")) ")
-      HsToken value pos        -> (pos, pp value)
-      CharToken value pos      -> (pos, pp (show value))
-      StrToken value pos       -> (pos, pp (show value))
-      Err mesg pos             -> (pos, pp $ " ***" ++ mesg ++ "*** ")
-
-line2PP ts =         let f (p,t) r = let ct = column p
-                                     in \c -> pp (spaces (ct-c)) >|< t >|< r (length (show t) +ct)
-                         spaces x | x < 0 = ""
-                                  | otherwise = replicate x ' '
-                     in foldr f (pp . const "") ts 1
-
+++defInhGRule ppNt prodName newNT newProd ch rules inhNoGroup synNoGroup chids locals =+                       let  ppAtt = ppName [pp "inh", prodName]+                            ppR =  ppAtt >|< pp " = inhdefM att_inh nts_group $" >-<+                                   indent 4  "do " >-<+                                   indent 5  "loc <- at loc" >-<+                                   indent 5  "lhs <- at lhs" >-<+                                   indent 5  ch >-<+                                   indent 5  "return $"  >-<+                                   indent 6  (foldr (>-<) (pp "emptyRecord") (map (chGRule ppNt prodName rules inhNoGroup synNoGroup chids locals) chids))+                       in  if (newNT || (not newNT && newProd))+                           then (ppR, [ ppAtt ])+                           else (empty, [])++chGRule ppNt prodName rules inhNoGroup synNoGroup chids locals (idCh,tp) =+                       let  chName = ppName [pp "ch", pp idCh, prodName]+                            ppTp   = ppShow tp+                            chRules = ppCommas $ mapGRuleDefs (== idCh)  rules inhNoGroup synNoGroup chids locals+                       in   if (isNonterminal tp)+                             then   chName >|< ".=." >-<+                                    indent 1 "InhG_" >|< ppShow tp >|< pp " {"  >-<+                                    indent 2 chRules >-<+                                    indent 1 "} .*. "+                             else   empty+++defSynGRule ppNt prod newNT newProd ch rules inhNoGroup synNoGroup chids locals =+                       let  ppAtt = ppName [pp "syn", ppNt, pp prod]+                            ppTAtt = "SynG_" >|< ppNt+                            ppR =  ppAtt >|< pp " = syndefM att_syn $" >-<+                                   indent 4  "do " >-<+                                   indent 5  "loc <- at loc" >-<+                                   indent 5  "lhs <- at lhs" >-<+                                   indent 5  ch >-<+                                   indent 5  "return $"  >-<+                                   indent 6  ppTAtt >|< pp " {"  >-<+                                   indent 7  (ppCommas $ mapGRuleDefs ((== "lhs") . show)  rules inhNoGroup synNoGroup chids locals) >-<+                                   indent 6  "}"+                       in  if (newNT || (not newNT && newProd))+                           then (ppR, [ ppAtt ])+                           else (empty, [])++defLocRule ppNt prod newNT newProd ch rules inhNoGroup synNoGroup chids locals =+                       let  ppAtt  = ppName [pp "loc", ppNt, pp prod]+                            ppTAtt = ppName [pp "Loc", ppNt, pp prod]+                            ppR =    ppAtt >|< pp " = locdefM att_loc $" >-<+                                     indent 4  "do " >-<+                                     indent 5  "loc <- at loc" >-<+                                     indent 5  "lhs <- at lhs" >-<+                                     indent 5  ch >-<+                                     indent 5  "return $"  >-<+                                     indent 6  (ppListSep "(" ")" "," $ mapLRuleDefs rules inhNoGroup synNoGroup chids locals)+                       in  (ppR, [ ppAtt ])++defInstRules ppNt prod newNT newProd ch rules chids locals+                                             = let  ppAsp     = ppName [pp "inst", ppNt, pp prod]+                                                    instRules = filter ((=="inst") . show . ruleField) rules+                                                    ppAtt att = ppListSep "`ext` " "" "_" [pp "inst_ch", pp att, ppNt, pp prod]+                                               in   (  ppAsp >|< pp " = emptyRule " >|< (map (ppAtt . ruleAttr) instRules) >-<+                                                       (vlist $ map (defInstRule  ppNt prod ch chids locals) instRules)+                                                    ,  [ ppAsp ])+++defInstRule  ppNt prod ch chids locals rule =+                       let  ppAtt  = ppName [pp "ch", pp (ruleAttr rule), ppNt, pp prod]+                       in   pp "inst_" >|< ppAtt >|< pp " = instdefM " >|< ppAtt >|< pp " $" >-<+                            indent 4  "do " >-<+                            indent 5  "loc <- at loc" >-<+                            indent 5  "lhs <- at lhs" >-<+                            indent 5  ch >-<+                            indent 5  "return $"  >-<+                            indent 6  ((ruleDef rule) chids locals)+++defSynRules ppNt prod newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals+                                             = let  synRules     = filter ( (=="lhs") . show . ruleField)  rules+                                                    ngRules      = filter ((flip elem synNoGroup) . getName . ruleAttr) synRules+                                                    (ppR, ppRA)  = unzip $  map (defSynRule True ppNt prod newNT newProd newAtts ch chids locals) ngRules+                                               in   (vlist ppR, concat ppRA )++modSynRules ppNt prod newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals+                                             = let  synRules     = filter ( (=="lhs") . show . ruleField)  rules+                                                    ngRules      = filter ((flip elem synNoGroup) . getName . ruleAttr) synRules+                                                    (ppR, ppRA)  = unzip $  map (defSynRule False ppNt prod newNT newProd newAtts ch chids locals) ngRules+                                               in   (vlist ppR, concat ppRA )++defSynRule  new ppNt prod newNT newProd newAtts ch chids locals rule =+                       let  att    = ruleAttr rule+                            newAtt = Map.member att newAtts+                            owrt   = ruleOwrt rule+                            ppAtt  = ppName [pp att, pp (if new then "syn" else "synM"), ppNt, pp prod]+                            ppR def =   ppAtt >|< pp (" = " ++ def ++ " ") >|< attName (show att) >|< pp " $" >-<+                                        indent 4  "do " >-<+                                        indent 5  "loc <- at loc" >-<+                                        indent 5  "lhs <- at lhs" >-<+                                        indent 5  ch >-<+                                        indent 5  "return $"  >-<+                                        indent 6  ((ruleDef rule) chids locals)+                       in   +                           if new+                           then  if (not owrt && (newNT || (not newNT && newProd) || newAtt))+                                 then  (ppR "syndefM", [ ppAtt ])+                                 else  (empty,         [])+                           else  if owrt+                                 then  (ppR "synmodM", [ ppAtt ])+                                 else  (empty,         [])++++defInhRules ppNt prodName newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals+                                             = let  ngRules      = filter ((flip elem inhNoGroup) . getName . ruleAttr) rules+                                                    (ppR, ppRA)  = unzip $ map (defInhRule True  ppNt prodName newNT newProd newAtts ch ngRules inhNoGroup synNoGroup chids locals) inhNoGroup+                                               in   (vlist ppR, concat ppRA)++modInhRules ppNt prodName newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals+                                             = let  ngRules      = filter ((flip elem inhNoGroup) . getName . ruleAttr) rules+                                                    (ppR, ppRA)  = unzip $ map (defInhRule  False ppNt prodName newNT newProd newAtts ch ngRules inhNoGroup synNoGroup chids locals) inhNoGroup+                                               in   (vlist ppR, concat ppRA)+++defInhRule new ppNt prodName newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals att =+                       let  ppAtt       =  ppName [pp att, pp (if new then "inh" else "inhM"),prodName]+                            newAtt      =  Map.member (identifier att) newAtts+                            chRMaybe    =  map (chRule new ppNt prodName att rules inhNoGroup synNoGroup chids locals) chids+                            chR         =  [ x | (Just x) <- chRMaybe ]+                            ppR def  =  ppAtt >|< pp (" = " ++ def ++ " ") >|< attName att >|< " nts_" >|< att >|< " $" >-<+                                        indent 4  "do " >-<+                                        indent 5  "loc <- at loc" >-<+                                        indent 5  "lhs <- at lhs" >-<+                                        indent 5  ch >-<+                                        indent 5  "return $"  >-<+                                        indent 6  (foldr (>-<) (pp "emptyRecord") chR)+                       in+                           if new+                           then  if (newNT || (not newNT && newProd) || newAtt)+                                 then  (ppR "inhdefM", [ ppAtt ])+                                 else  (empty,         [])+                           else  if (not . null) chR+                                 then  (ppR "inhmodM", [ ppAtt ])+                                 else  (empty,         [])+++chRule new ppNt prodName att rules inhNoGroup synNoGroup chids locals (idCh,tp) =+                       let  chName = ppName [pp "ch", pp idCh, prodName]+                            ppTp   = ppShow tp+                            chRule = inhRuleDef new (== idCh) (== att) rules inhNoGroup synNoGroup chids locals  -- it's supposed to be only one+                       in   if (isNonterminal tp && (not . null) chRule)+                             then   Just $ chName >|< ".=. (" >|< chRule >|< ") .*. "+                             else   Nothing+++mapLRuleDefs rules inhNoGroup synNoGroup chids locals+                 = map appSnd $ sortBy cmpField $ filter ((== "loc") . show . ruleField)  rules+                                      where cmpField r1 r2 = compare (ruleField r1) (ruleField r2)+                                            appSnd rule = (ruleDef rule)  chids locals+++mapGRuleDefs filt rules inhNoGroup synNoGroup chids locals+                 = map appSnd $ sortBy cmpField $ filter (not . (flip elem inhNoGroup) . getName . ruleAttr)+                                                $ filter (not . (flip elem synNoGroup) . getName . ruleAttr)+                                                $ filter ( filt . ruleField)  rules+                                      where cmpField r1 r2 = compare (ruleField r1) (ruleField r2)+                                            appSnd rule = (ruleDef rule)  chids locals++inhRuleDef new filt1 filt2 rules inhNoGroup synNoGroup chids locals+                 = map appSnd $ sortBy cmpField $ filter ( (== not new) . ruleOwrt)+                                                $ filter ((flip elem inhNoGroup) . getName . ruleAttr)+                                                $ filter ( filt2 . getName . ruleAttr)+                                                $ filter ( filt1 . ruleField)  rules+                                      where cmpField r1 r2 = compare (ruleField r1) (ruleField r2)+                                            appSnd rule = (ruleDef rule)  chids locals++defRule ppNt (field,att) noGroup rhs = \chids locals ->+                                     let ppAtt = if (elem (getName att) noGroup)+                                                  then empty+                                                  else case (show field) of+                                                        "lhs"     -> att >|< "_" >|< pp "SynG" >|< pp "_" >|< ppNt  >|< " = "+                                                        "loc"     -> empty+                                                        "inst"    -> empty+                                                        otherwise -> att >|< "_" >|< pp "InhG" >|< pp "_" >|<+                                                                     (maybe (error $ "lhs field " ++ show field ++" is not a child")+                                                                            ppShow (lookup field chids))+                                                                     >|< " = "+                                     in  ppAtt >|< (rhs noGroup field chids locals)+++rhsRule ppNt ppProd tks noGroup field chids locals  =  vlist . lines2PP . (map (token2PP ppNt ppProd field chids locals noGroup )) $ tks+++lines2PP [] = []+lines2PP xs = map line2PP . shiftLeft . getLines $ xs+++token2PP ppNt ppProd field chids locals noGroup  tk+  = case tk of+      AGLocal var pos _        -> (pos, if (elem var locals)+                                        then  (ppListSep "(" "" "_" [pp var, ppNt, ppProd]) >|< pp " (loc # att_loc)) "+                                        else  pp var)+      AGField field attr pos _ -> let ppChT =    maybe (error $ "rhs field " ++ show field ++ " is not a child") ppShow (lookup field chids)+                                      ppAtt =    case (show field) of+                                                 "lhs"      ->  attName "inh"+                                                 "loc"      ->  attName "loc"+                                                 otherwise  ->  attName "syn"+                                      ppSubAtt = case (show field) of+                                                 "lhs"      -> ppName [pp (getName attr), pp "InhG", ppNt]+                                                 "loc"      -> ppName [pp (getName attr), ppNt, ppProd]+                                                 otherwise  -> ppName [pp (getName attr), pp "SynG", ppChT]+                                  in  (pos, if ((elem (getName attr) noGroup) && ((show field) /= "loc"))+                                             then pp "(" >|< pp (getName field)  >|< " # " >|< attName (getName attr) >|< pp ")"+                                             else pp "(" >|< ppSubAtt >|< " (" >|< pp (getName field) >|< " # " >|< ppAtt >|< ")) ")+      HsToken value pos        -> (pos, pp value)+      CharToken value pos      -> (pos, pp (show value))+      StrToken value pos       -> (pos, pp (show value))+      Err mesg pos             -> (pos, pp $ " ***" ++ mesg ++ "*** ")++line2PP ts =         let f (p,t) r = let ct = column p+                                     in \c -> pp (spaces (ct-c)) >|< t >|< r (length (show t) +ct)+                         spaces x | x < 0 = ""+                                  | otherwise = replicate x ' '+                     in foldr f (pp . const "") ts 1+ {-# LINE 347 "src-generated/AG2AspectAG.hs" #-}  {-# LINE 721 "src-ag/AG2AspectAG.ag" #-}-
-ppMacro (Macro con children) = "( atts_" >|< show con >|< ", " >|<  ppListSep "" "" " <.> " ppChildren  >|<")"
-                where   ppChildren = map  ppChild children
-                        ppChild (RuleChild  ch n) = chName ch >|< " ==> " >|< ppMacro n
-                        ppChild (ChildChild ch n) = chName ch >|< " --> " >|< n
-                        ppChild (ValueChild ch n) = chName ch >|< " ~~> " >|< n
-                        chName ch = ppName [pp "ch", pp ch, pp con]
++ppMacro (Macro con children) = "( atts_" >|< show con >|< ", " >|<  ppListSep "" "" " <.> " ppChildren  >|<")"+                where   ppChildren = map  ppChild children+                        ppChild (RuleChild  ch n) = chName ch >|< " ==> " >|< ppMacro n+                        ppChild (ChildChild ch n) = chName ch >|< " --> " >|< n+                        ppChild (ValueChild ch n) = chName ch >|< " ~~> " >|< n+                        chName ch = ppName [pp "ch", pp ch, pp con] {-# LINE 357 "src-generated/AG2AspectAG.hs" #-}  {-# LINE 754 "src-ag/AG2AspectAG.ag" #-}-
-ppNoGroupAtts syn noGroup = let synatts = Map.keys $ Map.filterWithKey (\att _ -> elem (getName att) noGroup) syn
-                            in  map (flip (>|<) "_inh") noGroup ++  map (flip (>|<) "_syn") synatts
-
-ruleName att prodName = ppName [att,prodName]
-
-elemNT a b = False
++ppNoGroupAtts syn noGroup = let synatts = Map.keys $ Map.filterWithKey (\att _ -> elem (getName att) noGroup) syn+                            in  map (flip (>|<) "_inh") noGroup ++  map (flip (>|<) "_syn") synatts++ruleName att prodName = ppName [att,prodName]++elemNT a b = False {-# LINE 367 "src-generated/AG2AspectAG.hs" #-}  {-# LINE 797 "src-ag/AG2AspectAG.ag" #-}-
-attTypes atts = map (\(a,t) -> "(HCons (LVPair (Proxy Att_" >|< a >|< ") " >|< ppShow t >|< ") ") $ Map.toAscList atts
++attTypes atts = map (\(a,t) -> "(HCons (LVPair (Proxy Att_" >|< a >|< ") " >|< ppShow t >|< ") ") $ Map.toAscList atts {-# LINE 372 "src-generated/AG2AspectAG.hs" #-}  {-# LINE 851 "src-ag/AG2AspectAG.ag" #-}-
-attVars atts = map (\(a,_) -> "_" >|< a >|< " ") $ Map.toAscList atts
-attFields atts noGroup ppNt =
-     let ng = map (\(a,_) -> attName (getName a) >|< " .=. _" >|< a >|< " .*. ") $ Map.toAscList noGroup
-         g  = ppCommas $ map (\(a,_) -> ppName [pp a, pp "InhG",ppNt]  >|< "= _" >|< a) $ Map.toAscList $ Map.difference atts noGroup
-     in "(" >|< ng >|< "att_inh .=. " >|< ppName [pp "InhG", ppNt] >|< " { " >|< g >|< " } .*. emptyRecord)"
++attVars atts = map (\(a,_) -> "_" >|< a >|< " ") $ Map.toAscList atts+attFields atts noGroup ppNt =+     let ng = map (\(a,_) -> attName (getName a) >|< " .=. _" >|< a >|< " .*. ") $ Map.toAscList noGroup+         g  = ppCommas $ map (\(a,_) -> ppName [pp a, pp "InhG",ppNt]  >|< "= _" >|< a) $ Map.toAscList $ Map.difference atts noGroup+     in "(" >|< ng >|< "att_inh .=. " >|< ppName [pp "InhG", ppNt] >|< " { " >|< g >|< " } .*. emptyRecord)" {-# LINE 381 "src-generated/AG2AspectAG.hs" #-} -- Child ------------------------------------------------------- -- wrapper
src-generated/AbstractSyntax.hs view
@@ -3,15 +3,15 @@ -- UUAGC 0.9.53 (src-ag/AbstractSyntax.ag) module AbstractSyntax where {-# LINE 2 "src-ag/AbstractSyntax.ag" #-}-
--- AbstractSyntax.ag imports
-import Data.Set(Set)
-import Data.Map(Map)
-import Patterns    (Pattern(..),Patterns)
-import Expression  (Expression(..))
-import Macro --marcos
-import CommonTypes
-import ErrorMessages
++-- AbstractSyntax.ag imports+import Data.Set(Set)+import Data.Map(Map)+import Patterns    (Pattern(..),Patterns)+import Expression  (Expression(..))+import Macro --marcos+import CommonTypes+import ErrorMessages {-# LINE 16 "src-generated/AbstractSyntax.hs" #-} -- Child ------------------------------------------------------- {-
src-generated/AbstractSyntaxDump.hs view
@@ -3,40 +3,40 @@  module AbstractSyntaxDump where {-# LINE 2 "src-ag/Expression.ag" #-}-
-import UU.Scanner.Position(Pos)
-import HsToken
++import UU.Scanner.Position(Pos)+import HsToken {-# LINE 10 "src-generated/AbstractSyntaxDump.hs" #-}  {-# LINE 2 "src-ag/Patterns.ag" #-}-
--- Patterns.ag imports
-import UU.Scanner.Position(Pos)
-import CommonTypes (ConstructorIdent,Identifier)
++-- Patterns.ag imports+import UU.Scanner.Position(Pos)+import CommonTypes (ConstructorIdent,Identifier) {-# LINE 17 "src-generated/AbstractSyntaxDump.hs" #-}  {-# LINE 2 "src-ag/AbstractSyntax.ag" #-}-
--- AbstractSyntax.ag imports
-import Data.Set(Set)
-import Data.Map(Map)
-import Patterns    (Pattern(..),Patterns)
-import Expression  (Expression(..))
-import Macro --marcos
-import CommonTypes
-import ErrorMessages
++-- AbstractSyntax.ag imports+import Data.Set(Set)+import Data.Map(Map)+import Patterns    (Pattern(..),Patterns)+import Expression  (Expression(..))+import Macro --marcos+import CommonTypes+import ErrorMessages {-# LINE 29 "src-generated/AbstractSyntaxDump.hs" #-}  {-# LINE 6 "src-ag/AbstractSyntaxDump.ag" #-}-
-import Data.List
-import qualified Data.Map as Map
-
-import Pretty
-import PPUtil
-
-import AbstractSyntax
-import TokenDef
++import Data.List+import qualified Data.Map as Map++import Pretty+import PPUtil++import AbstractSyntax+import TokenDef {-# LINE 41 "src-generated/AbstractSyntaxDump.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity
src-generated/Code.hs view
@@ -3,30 +3,30 @@ -- UUAGC 0.9.53 (src-ag/Code.ag) module Code where {-# LINE 2 "src-ag/Code.ag" #-}-
-import Patterns
-import Data.Set(Set)
-import qualified Data.Set as Set
-import Data.Map(Map)
-import qualified Data.Map as Map
++import Patterns+import Data.Set(Set)+import qualified Data.Set as Set+import Data.Map(Map)+import qualified Data.Map as Map {-# LINE 13 "src-generated/Code.hs" #-} {-# LINE 146 "src-ag/Code.ag" #-}-
--- 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
++-- 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 {-# LINE 31 "src-generated/Code.hs" #-} -- CaseAlt ----------------------------------------------------- {-
src-generated/CodeSyntax.hs view
@@ -3,11 +3,11 @@ -- UUAGC 0.9.53 (src-ag/CodeSyntax.ag) module CodeSyntax where {-# LINE 2 "src-ag/CodeSyntax.ag" #-}-
-import Patterns
-import CommonTypes
-import Data.Map(Map)
-import Data.Set(Set)
++import Patterns+import CommonTypes+import Data.Map(Map)+import Data.Set(Set) {-# LINE 12 "src-generated/CodeSyntax.hs" #-} -- CGrammar ---------------------------------------------------- {-
src-generated/CodeSyntaxDump.hs view
@@ -3,59 +3,59 @@  module CodeSyntaxDump where {-# LINE 2 "src-ag/Patterns.ag" #-}-
--- Patterns.ag imports
-import UU.Scanner.Position(Pos)
-import CommonTypes (ConstructorIdent,Identifier)
++-- Patterns.ag imports+import UU.Scanner.Position(Pos)+import CommonTypes (ConstructorIdent,Identifier) {-# LINE 11 "src-generated/CodeSyntaxDump.hs" #-}  {-# LINE 2 "src-ag/CodeSyntax.ag" #-}-
-import Patterns
-import CommonTypes
-import Data.Map(Map)
-import Data.Set(Set)
++import Patterns+import CommonTypes+import Data.Map(Map)+import Data.Set(Set) {-# LINE 19 "src-generated/CodeSyntaxDump.hs" #-}  {-# LINE 5 "src-ag/CodeSyntaxDump.ag" #-}-
-import Data.List
-import qualified Data.Map as Map
-
-import Pretty
-import PPUtil
-
-import CodeSyntax
++import Data.List+import qualified Data.Map as Map++import Pretty+import PPUtil++import CodeSyntax {-# LINE 30 "src-generated/CodeSyntaxDump.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 15 "src-ag/CodeSyntaxDump.ag" #-}-
-ppChild :: (Identifier,Type,ChildKind) -> PP_Doc
-ppChild (nm,tp,_)
-  = pp nm >#< "::" >#< pp (show tp)
-
-ppVertexMap :: Map Int (Identifier,Identifier,Maybe Type) -> PP_Doc
-ppVertexMap m
-  = ppVList [ ppF (show k) $ ppAttr v | (k,v) <- Map.toList m ]
-
-ppAttr :: (Identifier,Identifier,Maybe Type) -> PP_Doc
-ppAttr (fld,nm,mTp)
-  = pp fld >|< "." >|< pp nm >#<
-    case mTp of
-      Just tp -> pp "::" >#< show tp
-      Nothing -> empty
-
-ppBool :: Bool -> PP_Doc
-ppBool True  = pp "T"
-ppBool False = pp "F"
-
-ppMaybeShow :: Show a => Maybe a -> PP_Doc
-ppMaybeShow (Just x) = pp (show x)
-ppMaybeShow Nothing  = pp "_"
-
-ppStrings :: [String] -> PP_Doc
-ppStrings = vlist
++ppChild :: (Identifier,Type,ChildKind) -> PP_Doc+ppChild (nm,tp,_)+  = pp nm >#< "::" >#< pp (show tp)++ppVertexMap :: Map Int (Identifier,Identifier,Maybe Type) -> PP_Doc+ppVertexMap m+  = ppVList [ ppF (show k) $ ppAttr v | (k,v) <- Map.toList m ]++ppAttr :: (Identifier,Identifier,Maybe Type) -> PP_Doc+ppAttr (fld,nm,mTp)+  = pp fld >|< "." >|< pp nm >#<+    case mTp of+      Just tp -> pp "::" >#< show tp+      Nothing -> empty++ppBool :: Bool -> PP_Doc+ppBool True  = pp "T"+ppBool False = pp "F"++ppMaybeShow :: Show a => Maybe a -> PP_Doc+ppMaybeShow (Just x) = pp (show x)+ppMaybeShow Nothing  = pp "_"++ppStrings :: [String] -> PP_Doc+ppStrings = vlist {-# LINE 60 "src-generated/CodeSyntaxDump.hs" #-} -- CGrammar ---------------------------------------------------- -- wrapper
src-generated/ConcreteSyntax.hs view
@@ -3,12 +3,12 @@ -- UUAGC 0.9.53 (src-ag/ConcreteSyntax.ag) module ConcreteSyntax where {-# LINE 2 "src-ag/ConcreteSyntax.ag" #-}-
-import UU.Scanner.Position (Pos)
-import Patterns   (Pattern)
-import Expression (Expression)
-import CommonTypes
-import Macro --marcos
++import UU.Scanner.Position (Pos)+import Patterns   (Pattern)+import Expression (Expression)+import CommonTypes+import Macro --marcos {-# LINE 13 "src-generated/ConcreteSyntax.hs" #-} -- AG ---------------------------------------------------------- {-
src-generated/DeclBlocks.hs view
@@ -3,8 +3,8 @@ -- UUAGC 0.9.53 (src-ag/DeclBlocks.ag) module DeclBlocks where {-# LINE 2 "src-ag/DeclBlocks.ag" #-}-
-import Code (Decl,Expr)
++import Code (Decl,Expr) {-# LINE 9 "src-generated/DeclBlocks.hs" #-} -- DeclBlocks -------------------------------------------------- {-
src-generated/DefaultRules.hs view
@@ -4,460 +4,460 @@  module DefaultRules where {-# LINE 2 "src-ag/Patterns.ag" #-}-
--- Patterns.ag imports
-import UU.Scanner.Position(Pos)
-import CommonTypes (ConstructorIdent,Identifier)
++-- Patterns.ag imports+import UU.Scanner.Position(Pos)+import CommonTypes (ConstructorIdent,Identifier) {-# LINE 12 "src-generated/DefaultRules.hs" #-}  {-# LINE 2 "src-ag/AbstractSyntax.ag" #-}-
--- AbstractSyntax.ag imports
-import Data.Set(Set)
-import Data.Map(Map)
-import Patterns    (Pattern(..),Patterns)
-import Expression  (Expression(..))
-import Macro --marcos
-import CommonTypes
-import ErrorMessages
++-- AbstractSyntax.ag imports+import Data.Set(Set)+import Data.Map(Map)+import Patterns    (Pattern(..),Patterns)+import Expression  (Expression(..))+import Macro --marcos+import CommonTypes+import ErrorMessages {-# LINE 24 "src-generated/DefaultRules.hs" #-}  {-# LINE 15 "src-ag/DefaultRules.ag" #-}-
-import qualified Data.List
-import qualified Data.Set as Set
-import qualified Data.Map as Map
-import Data.Map(Map)
-import qualified Data.Sequence as Seq
-import Data.Sequence(Seq,(><))
-import UU.Scanner.Position(noPos)
-import Pretty
-import Data.Maybe
-import HsToken
-import HsTokenScanner
-import Data.List(intersperse)
-import Data.Char
-
-import AbstractSyntax
-import ErrorMessages
-
-import Options
++import qualified Data.List+import qualified Data.Set as Set+import qualified Data.Map as Map+import Data.Map(Map)+import qualified Data.Sequence as Seq+import Data.Sequence(Seq,(><))+import UU.Scanner.Position(noPos)+import Pretty+import Data.Maybe+import HsToken+import HsTokenScanner+import Data.List(intersperse)+import Data.Char++import AbstractSyntax+import ErrorMessages++import Options {-# LINE 46 "src-generated/DefaultRules.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 80 "src-ag/DefaultRules.ag" #-}-
-fieldName n       = '@' : getName n
-
-locName n         = "@loc." ++ getName n
-
-attrName fld attr
- | fld == _LOC    = locName attr
- | fld == _FIELD  = fieldName attr
- | otherwise      = '@' : getName fld ++ "." ++ getName attr
-
-_ACHILD = Ident "(" noPos -- hack
-
-mkLocVar = AGField _LOC
-
-isRecordConstructor :: NontermIdent -> Map NontermIdent ConstructorType -> Bool
-isRecordConstructor nt ctm = Map.lookup nt ctm == Just RecordConstructor
-
-buildConExpr ocaml clean conmap typeSyns rename nt con1 fs'
- | nt `elem` map fst typeSyns  =  if ocaml then synonymMl
-                                           else if clean then synonymClean
-                                                         else synonymHs
- | otherwise                   = normalExpr
- where fs                      = map fst fs'
-       con                     = getName con1
-       tup                     = " " ++ buildTuple fs
-       args                    = " " ++ unwords fs
-       normalExpr              = if clean && isRecordConstructor nt conmap
-                                   then "{" ++ con ++ "|" ++
-                                        unwords (intersperse "," $ map (\(new, old) -> getName old ++ " = " ++ new) fs')
-                                        ++ "}"
-                                   else conname' ++ args
-
-       conname' | rename    = getName nt ++ "_" ++ getName con1
-                | otherwise = getName con1
-
-       synonymHs  | con == "Tuple"    = buildTuple fs
-                  | con == "Cons"     = "(:)" ++ args
-                  | con == "Nil"      = case lookup nt typeSyns of
-                                          Just (Map _ _)  -> "Data.Map.empty"
-                                          Just (IntMap _) -> "Data.IntMap.empty"
-                                          Just (OrdSet _) -> "Data.Set.empty"
-                                          Just IntSet     -> "Data.IntSet.empty"
-                                          _               -> "[]"
-                  | con == "Just"     = "Just" ++ args
-                  | con == "Nothing"  = "Nothing"
-                  | con == "Entry"    = ( case lookup nt typeSyns of
-                                            Just (Map _ _)  -> "Data.Map.insert"
-                                            Just (IntMap _) -> "Data.IntMap.insert"
-                                            Just (OrdSet _) -> "Data.Set.insert"
-                                            Just IntSet     -> "Data.IntSet.insert" ) ++ args
-                  | otherwise         = normalExpr
-
-       synonymMl  | con == "Tuple"    = buildTuple fs
-                  | con == "Cons"     = "(::)" ++ tup
-                  | con == "Nil"      = case lookup nt typeSyns of
-                                          Just (Map _ _)  -> prefixMod nt "empty"
-                                          Just (IntMap _) -> prefixMod nt "empty"
-                                          Just (OrdSet _) -> prefixMod nt "empty"
-                                          Just IntSet     -> prefixMod nt "empty"
-                                          _               -> "[]"
-                  | con == "Just"     = "Some" ++ tup
-                  | con == "Nothing"  = "None"
-                  | con == "Entry"    = ( case lookup nt typeSyns of
-                                            Just (Map _ _)  -> prefixMod nt "add"
-                                            Just (IntMap _) -> prefixMod nt "add"
-                                            Just (OrdSet _) -> prefixMod nt "add"
-                                            Just IntSet     -> prefixMod nt "add" ) ++ args
-                  | otherwise         = normalExpr
-
-       synonymClean  | con == "Tuple"    = buildTuple fs
-                     | con == "Cons"     = "(\\x xs -> [x:xs])" ++ args
-                     | con == "Nil"      = case lookup nt typeSyns of
-                                             Just (Map _ _)  -> "Data.Map.empty"
-                                             Just (IntMap _) -> "Data.IntMap.empty"
-                                             Just (OrdSet _) -> "Data.Set.empty"
-                                             Just IntSet     -> "Data.IntSet.empty"
-                                             _               -> "[]"
-                     | con == "Just"     = "Just" ++ args
-                     | con == "Nothing"  = "Nothing"
-                     | con == "Entry"    = ( case lookup nt typeSyns of
-                                               Just (Map _ _)  -> "Data.Map.insert"
-                                               Just (IntMap _) -> "Data.IntMap.insert"
-                                               Just (OrdSet _) -> "Data.Set.insert"
-                                               Just IntSet     -> "Data.IntSet.insert" ) ++ args
-                     | otherwise         = normalExpr
-
-
-       prefixMod nt nm = "M_" ++ getName nt ++ "." ++ nm
-
-concatSeq = foldr (Seq.><) 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)
-      ]
-    )
-
++fieldName n       = '@' : getName n++locName n         = "@loc." ++ getName n++attrName fld attr+ | fld == _LOC    = locName attr+ | fld == _FIELD  = fieldName attr+ | otherwise      = '@' : getName fld ++ "." ++ getName attr++_ACHILD = Ident "(" noPos -- hack++mkLocVar = AGField _LOC++isRecordConstructor :: NontermIdent -> Map NontermIdent ConstructorType -> Bool+isRecordConstructor nt ctm = Map.lookup nt ctm == Just RecordConstructor++buildConExpr ocaml clean conmap typeSyns rename nt con1 fs'+ | nt `elem` map fst typeSyns  =  if ocaml then synonymMl+                                           else if clean then synonymClean+                                                         else synonymHs+ | otherwise                   = normalExpr+ where fs                      = map fst fs'+       con                     = getName con1+       tup                     = " " ++ buildTuple fs+       args                    = " " ++ unwords fs+       normalExpr              = if clean && isRecordConstructor nt conmap+                                   then "{" ++ con ++ "|" +++                                        unwords (intersperse "," $ map (\(new, old) -> getName old ++ " = " ++ new) fs')+                                        ++ "}"+                                   else conname' ++ args++       conname' | rename    = getName nt ++ "_" ++ getName con1+                | otherwise = getName con1++       synonymHs  | con == "Tuple"    = buildTuple fs+                  | con == "Cons"     = "(:)" ++ args+                  | con == "Nil"      = case lookup nt typeSyns of+                                          Just (Map _ _)  -> "Data.Map.empty"+                                          Just (IntMap _) -> "Data.IntMap.empty"+                                          Just (OrdSet _) -> "Data.Set.empty"+                                          Just IntSet     -> "Data.IntSet.empty"+                                          _               -> "[]"+                  | con == "Just"     = "Just" ++ args+                  | con == "Nothing"  = "Nothing"+                  | con == "Entry"    = ( case lookup nt typeSyns of+                                            Just (Map _ _)  -> "Data.Map.insert"+                                            Just (IntMap _) -> "Data.IntMap.insert"+                                            Just (OrdSet _) -> "Data.Set.insert"+                                            Just IntSet     -> "Data.IntSet.insert" ) ++ args+                  | otherwise         = normalExpr++       synonymMl  | con == "Tuple"    = buildTuple fs+                  | con == "Cons"     = "(::)" ++ tup+                  | con == "Nil"      = case lookup nt typeSyns of+                                          Just (Map _ _)  -> prefixMod nt "empty"+                                          Just (IntMap _) -> prefixMod nt "empty"+                                          Just (OrdSet _) -> prefixMod nt "empty"+                                          Just IntSet     -> prefixMod nt "empty"+                                          _               -> "[]"+                  | con == "Just"     = "Some" ++ tup+                  | con == "Nothing"  = "None"+                  | con == "Entry"    = ( case lookup nt typeSyns of+                                            Just (Map _ _)  -> prefixMod nt "add"+                                            Just (IntMap _) -> prefixMod nt "add"+                                            Just (OrdSet _) -> prefixMod nt "add"+                                            Just IntSet     -> prefixMod nt "add" ) ++ args+                  | otherwise         = normalExpr++       synonymClean  | con == "Tuple"    = buildTuple fs+                     | con == "Cons"     = "(\\x xs -> [x:xs])" ++ args+                     | con == "Nil"      = case lookup nt typeSyns of+                                             Just (Map _ _)  -> "Data.Map.empty"+                                             Just (IntMap _) -> "Data.IntMap.empty"+                                             Just (OrdSet _) -> "Data.Set.empty"+                                             Just IntSet     -> "Data.IntSet.empty"+                                             _               -> "[]"+                     | con == "Just"     = "Just" ++ args+                     | con == "Nothing"  = "Nothing"+                     | con == "Entry"    = ( case lookup nt typeSyns of+                                               Just (Map _ _)  -> "Data.Map.insert"+                                               Just (IntMap _) -> "Data.IntMap.insert"+                                               Just (OrdSet _) -> "Data.Set.insert"+                                               Just IntSet     -> "Data.IntSet.insert" ) ++ args+                     | otherwise         = normalExpr+++       prefixMod nt nm = "M_" ++ getName nt ++ "." ++ nm++concatSeq = foldr (Seq.><) 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)+      ]+    )+ {-# LINE 159 "src-generated/DefaultRules.hs" #-}  {-# LINE 255 "src-ag/DefaultRules.ag" #-}-
-
-
-
-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 clean nt con fld a
- = (if clean then "abort" else "error")
-   ++ " \"missing rule: "
-   ++ show nt  ++ "." ++ show con ++ "."
-   ++ show fld ++ "." ++ show a   ++ "\""
-
-makeRule :: (Identifier,Identifier) -> Expression -> String -> Bool -> Maybe Error -> Rule
-makeRule (f1,a1) expr origin identity mbDelayedError
- = Rule Nothing
-        (Alias f1 a1 (Underscore noPos))
-        expr
-        False
-        origin
-        False
-        True
-        identity
-        mbDelayedError
-        False
-
-
-useRule :: Options -> Set Identifier -> [(Identifier,Attributes)] -> (Identifier,(String,String,String)) -> Rule
-useRule opts locals ch_outs (n,(op,e,pos))
- =  let elems = [ fld
-                | (fld,as) <- ch_outs
-                , Map.member n as
-                ]
-
-        isOp [] = False
-        isOp (c:cs)
-          | isSpace c = isOp cs
-          | isAlpha c = case dropWhile isAlpha cs of
-                       ('.':cs2) -> isOp cs2 -- fully qualified name, drop prefix
-                       _         -> False
-          | c == '('  = False
-          | otherwise = True
-
-        tks | Set.member n locals  =  [mkLocVar n noPos Nothing]
-            | null elems           =  lexTokens opts noPos e
-            | otherwise            =  lexTokens opts noPos str
-                                      where
-                                        opExpr l r
-                                          | isOp op   = l ++ " " ++ op ++ " " ++ r         -- takes the associativity of the operator
-                                          | otherwise = "(" ++ op ++ " " ++ l ++ " " ++ r ++ ")"  -- associates to the right
-                                        str = foldr1 opExpr (map (flip attrName n) elems)
-
-    in makeRule (_LHS,n)
-                (Expression noPos tks)
-                ("use rule " ++ pos)
-                False
-                Nothing
-
-
-selfRule :: Bool -> Identifier -> [HsToken] -> Rule
-selfRule lhsNecLoc attr tks
- = makeRule (if lhsNecLoc then _LHS else _LOC,attr)
-               (Expression noPos tks)
-               "self rule"
-               False
-               Nothing
-
-
-
-
-concatRE rsess = let (rss,ess) = unzip rsess
-                 in (concat rss, concatSeq ess)
-
-
-copyRule :: Options -> Set NontermIdent -> Identifier -> Identifier -> Bool -> Set Identifier -> (Map Identifier Identifier, (Identifier,[Identifier])) -> ([Rule], Seq Error)
-copyRule options wrappers nt con modcopy locals (env,(fld,as))
- = concatRE (map copyRu as)
-
- where
-       copyRu a
-           = ( [ makeRule (fld,a)
-                          (Expression noPos tks)
-                          (cruletxt sel)
-                          True
-                          mbDelayedErr
-               ]
-             , err
-             )
-
-        where
-              sel
-               |    not modcopy
-                 && Set.member a locals  =  Just _LOC
-               | otherwise               =  Map.lookup a env
-
-              (tks,err,mbDelayedErr)
-               = case sel of
-                  Nothing         -> let tks = [HsToken (missingRuleErrorExpr (clean options) nt con fld a) noPos]
-                                         err = MissingRule nt con fld a
-                                     in if nt `Set.member` wrappers && kennedyWarren options
-                                        then (tks, Seq.empty, Just err)  -- yield error only if the rule is actually scheduled; for kennedyWarren code gen only
-                                        else (tks, Seq.singleton err, Nothing)
-                  Just f
-                   | f == _ACHILD -> ( [AGLocal a noPos Nothing]
-                                     , Seq.singleton (deprecatedCopyRuleError nt con fld a)
-                                     , Nothing
-                                     )
-                   | otherwise    -> ( [AGField f a noPos Nothing]
-                                     , Seq.empty
-                                     , Nothing
-                                     )
-
-              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
+++++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 clean nt con fld a+ = (if clean then "abort" else "error")+   ++ " \"missing rule: "+   ++ show nt  ++ "." ++ show con ++ "."+   ++ show fld ++ "." ++ show a   ++ "\""++makeRule :: (Identifier,Identifier) -> Expression -> String -> Bool -> Maybe Error -> Rule+makeRule (f1,a1) expr origin identity mbDelayedError+ = Rule Nothing+        (Alias f1 a1 (Underscore noPos))+        expr+        False+        origin+        False+        True+        identity+        mbDelayedError+        False+++useRule :: Options -> Set Identifier -> [(Identifier,Attributes)] -> (Identifier,(String,String,String)) -> Rule+useRule opts locals ch_outs (n,(op,e,pos))+ =  let elems = [ fld+                | (fld,as) <- ch_outs+                , Map.member n as+                ]++        isOp [] = False+        isOp (c:cs)+          | isSpace c = isOp cs+          | isAlpha c = case dropWhile isAlpha cs of+                       ('.':cs2) -> isOp cs2 -- fully qualified name, drop prefix+                       _         -> False+          | c == '('  = False+          | otherwise = True++        tks | Set.member n locals  =  [mkLocVar n noPos Nothing]+            | null elems           =  lexTokens opts noPos e+            | otherwise            =  lexTokens opts noPos str+                                      where+                                        opExpr l r+                                          | isOp op   = l ++ " " ++ op ++ " " ++ r         -- takes the associativity of the operator+                                          | otherwise = "(" ++ op ++ " " ++ l ++ " " ++ r ++ ")"  -- associates to the right+                                        str = foldr1 opExpr (map (flip attrName n) elems)++    in makeRule (_LHS,n)+                (Expression noPos tks)+                ("use rule " ++ pos)+                False+                Nothing+++selfRule :: Bool -> Identifier -> [HsToken] -> Rule+selfRule lhsNecLoc attr tks+ = makeRule (if lhsNecLoc then _LHS else _LOC,attr)+               (Expression noPos tks)+               "self rule"+               False+               Nothing+++++concatRE rsess = let (rss,ess) = unzip rsess+                 in (concat rss, concatSeq ess)+++copyRule :: Options -> Set NontermIdent -> Identifier -> Identifier -> Bool -> Set Identifier -> (Map Identifier Identifier, (Identifier,[Identifier])) -> ([Rule], Seq Error)+copyRule options wrappers nt con modcopy locals (env,(fld,as))+ = concatRE (map copyRu as)++ where+       copyRu a+           = ( [ makeRule (fld,a)+                          (Expression noPos tks)+                          (cruletxt sel)+                          True+                          mbDelayedErr+               ]+             , err+             )++        where+              sel+               |    not modcopy+                 && Set.member a locals  =  Just _LOC+               | otherwise               =  Map.lookup a env++              (tks,err,mbDelayedErr)+               = case sel of+                  Nothing         -> let tks = [HsToken (missingRuleErrorExpr (clean options) nt con fld a) noPos]+                                         err = MissingRule nt con fld a+                                     in if nt `Set.member` wrappers && kennedyWarren options+                                        then (tks, Seq.empty, Just err)  -- yield error only if the rule is actually scheduled; for kennedyWarren code gen only+                                        else (tks, Seq.singleton err, Nothing)+                  Just f+                   | f == _ACHILD -> ( [AGLocal a noPos Nothing]+                                     , Seq.singleton (deprecatedCopyRuleError nt con fld a)+                                     , Nothing+                                     )+                   | otherwise    -> ( [AGField f a noPos Nothing]+                                     , Seq.empty+                                     , Nothing+                                     )++              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 {-# LINE 311 "src-generated/DefaultRules.hs" #-}  {-# LINE 488 "src-ag/DefaultRules.ag" #-}-
-buildTuple fs = "(" ++ concat (intersperse "," fs) ++ ")"
-
-addAugments :: (Identifier, [Expression]) -> [Rule] -> [Rule]
-addAugments (_, exprs) rules
-  | null exprs = rules
-addAugments (syn, exprs) rules
-  = [rule] ++ funRules ++ map modify rules
-  where
-    rule = Rule Nothing (Alias _LHS syn (Underscore noPos)) rhs False "augmented rule" False True False Nothing False
-    rhs  = Expression noPos tks
-    tks  = [ HsToken "foldr ($) " noPos, mkLocVar substSyn noPos Nothing, HsToken " [" noPos] ++ funs ++ [HsToken "]" noPos]
-    funs = intersperse (HsToken ", " noPos) (map (\n -> mkLocVar n noPos Nothing) funNames)
-
-    substSyn = Ident (show syn ++ "_augmented_syn") (getPos syn)
-    funNames = zipWith (\i _ -> Ident (show syn ++ "_augmented_f" ++ show i) (getPos syn)) [1..] exprs
-    funRules = zipWith (\name expr -> Rule Nothing (Alias _LOC name (Underscore noPos)) expr False "augment function" False True False Nothing False) funNames exprs
-
-    modify (Rule mbNm pat rhs owrt origin expl pure identity mbErr eager)
-      | containsSyn pat = Rule mbNm (modifyPat pat) rhs owrt origin expl pure identity mbErr eager
-    modify r = r
-
-    containsSyn (Constr _ pats)   = any containsSyn pats
-    containsSyn (Product _ pats)  = any containsSyn pats
-    containsSyn (Irrefutable pat) = containsSyn pat
-    containsSyn (Alias field attr pat) = (field == _LHS && attr == syn) || containsSyn pat
-    containsSyn _ = False
-
-    modifyPat (Constr name pats) = Constr name (map modifyPat pats)
-    modifyPat (Product pos pats) = Product pos (map modifyPat pats)
-    modifyPat (Irrefutable pat)  = Irrefutable (modifyPat pat)
-    modifyPat (Alias field attr pat)
-      | field == _LHS && attr == syn = Alias _LOC substSyn (modifyPat pat)
-      | otherwise                    = Alias field attr (modifyPat pat)
-    modifyPat p = p
-
--- adds the additional rules needed for around, which creates a sequence of
--- rules that form a function that each transforms the semantics of a child
--- before attaching the child.
--- The rule defines a local attribute "<child>_around" and <child> is dependent
--- on this attribute.
-addArounds :: (Identifier, [Expression]) -> [Rule] -> [Rule]
-addArounds (_, exprs) rules | null exprs = rules
-addArounds (child, exprs) rules
-  = [rule] ++ funRules ++ rules
-  where
-    rule = Rule Nothing (Alias _LOC childLoc (Underscore noPos)) rhs False "around rule" False True False Nothing False
-    rhs  = Expression noPos tks
-    tks  = [ HsToken "\\s -> foldr ($) s " noPos, HsToken " [" noPos] ++ funs ++ [HsToken "]" noPos]
-    funs = intersperse (HsToken ", " noPos) (map (\n -> mkLocVar n noPos Nothing) funNames)
-
-    childLoc = Ident (show child ++ "_around") (getPos child)
-    funNames = zipWith (\i _ -> Ident (show child ++ "_around_f" ++ show i) (getPos child)) [1..] exprs
-    funRules = zipWith (\name expr -> Rule Nothing (Alias _LOC name (Underscore noPos)) expr False "around function" False True False Nothing False) funNames exprs
-
--- adds the additional rules needed for merging.
--- It produces for each merging child a rule with local attribute: "<child>_merged".
--- this rules takes the semantics of the first children and feeds it to the function
--- represented by this attribute. This attribute then defines the semantics for
--- the merging child.
-addMerges :: (Identifier, (Identifier,[Identifier],Expression)) -> [Rule] -> [Rule]
-addMerges (target,(_,_,expr)) rules
-  = rule : rules
-  where
-    rule = Rule Nothing (Alias _LOC childLoc (Underscore noPos)) expr False "merge rule" False True False Nothing False
-    childLoc = Ident (show target ++ "_merge") (getPos target)
++buildTuple fs = "(" ++ concat (intersperse "," fs) ++ ")"++addAugments :: (Identifier, [Expression]) -> [Rule] -> [Rule]+addAugments (_, exprs) rules+  | null exprs = rules+addAugments (syn, exprs) rules+  = [rule] ++ funRules ++ map modify rules+  where+    rule = Rule Nothing (Alias _LHS syn (Underscore noPos)) rhs False "augmented rule" False True False Nothing False+    rhs  = Expression noPos tks+    tks  = [ HsToken "foldr ($) " noPos, mkLocVar substSyn noPos Nothing, HsToken " [" noPos] ++ funs ++ [HsToken "]" noPos]+    funs = intersperse (HsToken ", " noPos) (map (\n -> mkLocVar n noPos Nothing) funNames)++    substSyn = Ident (show syn ++ "_augmented_syn") (getPos syn)+    funNames = zipWith (\i _ -> Ident (show syn ++ "_augmented_f" ++ show i) (getPos syn)) [1..] exprs+    funRules = zipWith (\name expr -> Rule Nothing (Alias _LOC name (Underscore noPos)) expr False "augment function" False True False Nothing False) funNames exprs++    modify (Rule mbNm pat rhs owrt origin expl pure identity mbErr eager)+      | containsSyn pat = Rule mbNm (modifyPat pat) rhs owrt origin expl pure identity mbErr eager+    modify r = r++    containsSyn (Constr _ pats)   = any containsSyn pats+    containsSyn (Product _ pats)  = any containsSyn pats+    containsSyn (Irrefutable pat) = containsSyn pat+    containsSyn (Alias field attr pat) = (field == _LHS && attr == syn) || containsSyn pat+    containsSyn _ = False++    modifyPat (Constr name pats) = Constr name (map modifyPat pats)+    modifyPat (Product pos pats) = Product pos (map modifyPat pats)+    modifyPat (Irrefutable pat)  = Irrefutable (modifyPat pat)+    modifyPat (Alias field attr pat)+      | field == _LHS && attr == syn = Alias _LOC substSyn (modifyPat pat)+      | otherwise                    = Alias field attr (modifyPat pat)+    modifyPat p = p++-- adds the additional rules needed for around, which creates a sequence of+-- rules that form a function that each transforms the semantics of a child+-- before attaching the child.+-- The rule defines a local attribute "<child>_around" and <child> is dependent+-- on this attribute.+addArounds :: (Identifier, [Expression]) -> [Rule] -> [Rule]+addArounds (_, exprs) rules | null exprs = rules+addArounds (child, exprs) rules+  = [rule] ++ funRules ++ rules+  where+    rule = Rule Nothing (Alias _LOC childLoc (Underscore noPos)) rhs False "around rule" False True False Nothing False+    rhs  = Expression noPos tks+    tks  = [ HsToken "\\s -> foldr ($) s " noPos, HsToken " [" noPos] ++ funs ++ [HsToken "]" noPos]+    funs = intersperse (HsToken ", " noPos) (map (\n -> mkLocVar n noPos Nothing) funNames)++    childLoc = Ident (show child ++ "_around") (getPos child)+    funNames = zipWith (\i _ -> Ident (show child ++ "_around_f" ++ show i) (getPos child)) [1..] exprs+    funRules = zipWith (\name expr -> Rule Nothing (Alias _LOC name (Underscore noPos)) expr False "around function" False True False Nothing False) funNames exprs++-- adds the additional rules needed for merging.+-- It produces for each merging child a rule with local attribute: "<child>_merged".+-- this rules takes the semantics of the first children and feeds it to the function+-- represented by this attribute. This attribute then defines the semantics for+-- the merging child.+addMerges :: (Identifier, (Identifier,[Identifier],Expression)) -> [Rule] -> [Rule]+addMerges (target,(_,_,expr)) rules+  = rule : rules+  where+    rule = Rule Nothing (Alias _LOC childLoc (Underscore noPos)) expr False "merge rule" False True False Nothing False+    childLoc = Ident (show target ++ "_merge") (getPos target) {-# LINE 380 "src-generated/DefaultRules.hs" #-}  {-# LINE 606 "src-ag/DefaultRules.ag" #-}-
-elimSelfId :: NontermIdent -> [Identifier] -> Type -> Type
-elimSelfId nt args Self = NT nt (map getName args) False
-elimSelfId _ _ tp = tp
-
-elimSelfStr :: NontermIdent -> [String] -> Type -> Type
-elimSelfStr nt args Self = NT nt args False
-elimSelfStr _ _ tp = tp
++elimSelfId :: NontermIdent -> [Identifier] -> Type -> Type+elimSelfId nt args Self = NT nt (map getName args) False+elimSelfId _ _ tp = tp++elimSelfStr :: NontermIdent -> [String] -> Type -> Type+elimSelfStr nt args Self = NT nt args False+elimSelfStr _ _ tp = tp {-# LINE 391 "src-generated/DefaultRules.hs" #-}  {-# LINE 658 "src-ag/DefaultRules.ag" #-}-
--- When a rule has a name, create an alias for a rule
--- and a modified rule that refers to the alias
--- Thus it removes rule names from rules
-mkRuleAlias :: Rule -> (Rule, Maybe Rule)
-mkRuleAlias r@(Rule Nothing _ _ _ _ _ _ _ _ _) = (r, Nothing)
-mkRuleAlias (Rule (Just nm) pat expr owrt origin expl pure identity mbErr eager) = (r', Just alias) where
-  alias = Rule Nothing (Alias _LOC (Ident ("_rule_" ++ show nm) pos) (Underscore pos)) expr owrt origin expl pure identity mbErr eager
-  pos   = getPos nm
-  expr' = Expression pos tks
-  tks   = [mkLocVar (Ident ("_rule_" ++ show nm) pos) pos (Just ("Indirection to rule " ++ show nm))]
-  r'    = Rule Nothing pat expr' owrt origin False True identity Nothing False
++-- When a rule has a name, create an alias for a rule+-- and a modified rule that refers to the alias+-- Thus it removes rule names from rules+mkRuleAlias :: Rule -> (Rule, Maybe Rule)+mkRuleAlias r@(Rule Nothing _ _ _ _ _ _ _ _ _) = (r, Nothing)+mkRuleAlias (Rule (Just nm) pat expr owrt origin expl pure identity mbErr eager) = (r', Just alias) where+  alias = Rule Nothing (Alias _LOC (Ident ("_rule_" ++ show nm) pos) (Underscore pos)) expr owrt origin expl pure identity mbErr eager+  pos   = getPos nm+  expr' = Expression pos tks+  tks   = [mkLocVar (Ident ("_rule_" ++ show nm) pos) pos (Just ("Indirection to rule " ++ show nm))]+  r'    = Rule Nothing pat expr' owrt origin False True identity Nothing False {-# LINE 406 "src-generated/DefaultRules.hs" #-}  {-# LINE 675 "src-ag/DefaultRules.ag" #-}-
-needsMultiRules :: Options -> Bool
-needsMultiRules opts = (visit opts || withCycle opts) && not (kennedyWarren opts)
++needsMultiRules :: Options -> Bool+needsMultiRules opts = (visit opts || withCycle opts) && not (kennedyWarren opts) {-# LINE 412 "src-generated/DefaultRules.hs" #-}  {-# LINE 680 "src-ag/DefaultRules.ag" #-}-
-{-
-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 expl pure identity mbErr eager) uniq
-  =  let f :: Bool -> (Pattern->Pattern) -> Expression -> Pattern -> Int -> (Pattern, ([Rule], Int))
-         f expl' 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)
-                 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 False (us (length xs1)) freshExpr p n1
-                                      in  (x2:xs1, rs2++rs1, n2)
-                 (xs9,rs9,n9) = foldr g ([], [], n+1) pats
-             in  ( freshPat
-                 , ( Rule Nothing (w freshPat) e owrt origin expl' True False mbErr eager : rs9
-                   , n9
-                   )
-                 )
-         f expl' w e p n
-           = ( p
-             , ( [Rule Nothing (w p) e owrt origin expl' True False mbErr eager]
-               , n
-               )
-             )
-     in snd (f expl id expr pat uniq)
-
++{-+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 expl pure identity mbErr eager) uniq+  =  let f :: Bool -> (Pattern->Pattern) -> Expression -> Pattern -> Int -> (Pattern, ([Rule], Int))+         f expl' 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)+                 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 False (us (length xs1)) freshExpr p n1+                                      in  (x2:xs1, rs2++rs1, n2)+                 (xs9,rs9,n9) = foldr g ([], [], n+1) pats+             in  ( freshPat+                 , ( Rule Nothing (w freshPat) e owrt origin expl' True False mbErr eager : rs9+                   , n9+                   )+                 )+         f expl' w e p n+           = ( p+             , ( [Rule Nothing (w p) e owrt origin expl' True False mbErr eager]+               , n+               )+             )+     in snd (f expl id expr pat uniq)+ {-# LINE 462 "src-generated/DefaultRules.hs" #-} -- Child ------------------------------------------------------- -- wrapper
src-generated/Desugar.hs view
@@ -4,118 +4,118 @@  module Desugar where {-# LINE 2 "src-ag/HsToken.ag" #-}-
-import CommonTypes
-import UU.Scanner.Position(Pos)
++import CommonTypes+import UU.Scanner.Position(Pos) {-# LINE 11 "src-generated/Desugar.hs" #-}  {-# LINE 2 "src-ag/Expression.ag" #-}-
-import UU.Scanner.Position(Pos)
-import HsToken
++import UU.Scanner.Position(Pos)+import HsToken {-# LINE 17 "src-generated/Desugar.hs" #-}  {-# LINE 2 "src-ag/Patterns.ag" #-}-
--- Patterns.ag imports
-import UU.Scanner.Position(Pos)
-import CommonTypes (ConstructorIdent,Identifier)
++-- Patterns.ag imports+import UU.Scanner.Position(Pos)+import CommonTypes (ConstructorIdent,Identifier) {-# LINE 24 "src-generated/Desugar.hs" #-}  {-# LINE 2 "src-ag/AbstractSyntax.ag" #-}-
--- AbstractSyntax.ag imports
-import Data.Set(Set)
-import Data.Map(Map)
-import Patterns    (Pattern(..),Patterns)
-import Expression  (Expression(..))
-import Macro --marcos
-import CommonTypes
-import ErrorMessages
++-- AbstractSyntax.ag imports+import Data.Set(Set)+import Data.Map(Map)+import Patterns    (Pattern(..),Patterns)+import Expression  (Expression(..))+import Macro --marcos+import CommonTypes+import ErrorMessages {-# LINE 36 "src-generated/Desugar.hs" #-}  {-# LINE 14 "src-ag/Desugar.ag" #-}-
-import qualified Data.Set as Set
-import qualified Data.Map as Map
-import Data.Map(Map)
-import qualified Data.Sequence as Seq
-import Data.Sequence(Seq,(><))
-import UU.Scanner.Position(Pos(..))
-import Data.Maybe
-import Data.List(intersperse)
-
-import AbstractSyntax
-import ErrorMessages
-import Options
-import HsToken
-import HsTokenScanner
-import TokenDef
-import CommonTypes
++import qualified Data.Set as Set+import qualified Data.Map as Map+import Data.Map(Map)+import qualified Data.Sequence as Seq+import Data.Sequence(Seq,(><))+import UU.Scanner.Position(Pos(..))+import Data.Maybe+import Data.List(intersperse)++import AbstractSyntax+import ErrorMessages+import Options+import HsToken+import HsTokenScanner+import TokenDef+import CommonTypes {-# LINE 56 "src-generated/Desugar.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 98 "src-ag/Desugar.ag" #-}-
-addl :: Int -> Pos -> Pos
-addl n (Pos l c f) = Pos (l+n) c f
++addl :: Int -> Pos -> Pos+addl n (Pos l c f) = Pos (l+n) c f {-# LINE 63 "src-generated/Desugar.hs" #-}  {-# LINE 133 "src-ag/Desugar.ag" #-}-
-maybeError :: a -> Error -> Maybe a -> (a, Seq Error)
-maybeError def err mb
-  = maybe (def, Seq.singleton 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
++maybeError :: a -> Error -> Maybe a -> (a, Seq Error)+maybeError def err mb+  = maybe (def, Seq.singleton 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 {-# LINE 78 "src-generated/Desugar.hs" #-}  {-# LINE 204 "src-ag/Desugar.ag" #-}-
-mergeAttributes :: AttrMap -> AttrMap -> AttrMap
-mergeAttributes = Map.unionWith $ Map.unionWith $ Set.union
++mergeAttributes :: AttrMap -> AttrMap -> AttrMap+mergeAttributes = Map.unionWith $ Map.unionWith $ Set.union {-# LINE 84 "src-generated/Desugar.hs" #-}  {-# LINE 251 "src-ag/Desugar.ag" #-}-
-desugarExprs :: Options -> NontermIdent -> ConstructorIdent ->
-                [(Identifier, Identifier)] -> [(Identifier, Identifier)] ->
-                Seq Error -> [Expression] -> (Seq Error, [Expression])
-desugarExprs options nt con childInhs childSyns
-  = mapAccum (desugarExpr options nt con childInhs childSyns)
-  where mapAccum f e = foldr (\x (e0,xs) -> let (e1,x') = f e0 x in (e1, x:xs)) (e, [])
-
-desugarExpr :: Options -> NontermIdent -> ConstructorIdent ->
-               [(Identifier, Identifier)] -> [(Identifier, Identifier)] ->
-               Seq Error -> Expression -> (Seq Error, Expression)
-desugarExpr options nt con childInhs childSyns errs expr
-  = (errs Seq.>< errors_Syn_Expression syn, output_Syn_Expression syn)
-  where
-    inh = Inh_Expression { childInhs_Inh_Expression = childInhs
-                         , childSyns_Inh_Expression = childSyns
-                         , con_Inh_Expression       = con
-                         , nt_Inh_Expression        = nt
-                         , options_Inh_Expression   = options
-                         , ruleDescr_Inh_Expression = "augment-rule"
-                         }
-    sem = sem_Expression expr
-    syn = wrap_Expression sem inh
++desugarExprs :: Options -> NontermIdent -> ConstructorIdent ->+                [(Identifier, Identifier)] -> [(Identifier, Identifier)] ->+                Seq Error -> [Expression] -> (Seq Error, [Expression])+desugarExprs options nt con childInhs childSyns+  = mapAccum (desugarExpr options nt con childInhs childSyns)+  where mapAccum f e = foldr (\x (e0,xs) -> let (e1,x') = f e0 x in (e1, x:xs)) (e, [])++desugarExpr :: Options -> NontermIdent -> ConstructorIdent ->+               [(Identifier, Identifier)] -> [(Identifier, Identifier)] ->+               Seq Error -> Expression -> (Seq Error, Expression)+desugarExpr options nt con childInhs childSyns errs expr+  = (errs Seq.>< errors_Syn_Expression syn, output_Syn_Expression syn)+  where+    inh = Inh_Expression { childInhs_Inh_Expression = childInhs+                         , childSyns_Inh_Expression = childSyns+                         , con_Inh_Expression       = con+                         , nt_Inh_Expression        = nt+                         , options_Inh_Expression   = options+                         , ruleDescr_Inh_Expression = "augment-rule"+                         }+    sem = sem_Expression expr+    syn = wrap_Expression sem inh {-# LINE 110 "src-generated/Desugar.hs" #-}  {-# LINE 294 "src-ag/Desugar.ag" #-}-
-addLateAttr :: Options -> String -> Attributes
-addLateAttr options mainName
-  | kennedyWarren options && lateHigherOrderBinding options =
-      let tp = lateBindingType mainName
-      in Map.singleton idLateBindingAttr tp
-  | otherwise = Map.empty
++addLateAttr :: Options -> String -> Attributes+addLateAttr options mainName+  | kennedyWarren options && lateHigherOrderBinding options =+      let tp = lateBindingType mainName+      in Map.singleton idLateBindingAttr tp+  | otherwise = Map.empty {-# LINE 120 "src-generated/Desugar.hs" #-} -- Child ------------------------------------------------------- -- wrapper
src-generated/ErrorMessages.hs view
@@ -3,11 +3,11 @@ -- UUAGC 0.9.53 (src-ag/ErrorMessages.ag) module ErrorMessages where {-# LINE 2 "src-ag/ErrorMessages.ag" #-}-
-import UU.Scanner.Position(Pos)
-import Pretty
-import CodeSyntax
-import CommonTypes
++import UU.Scanner.Position(Pos)+import Pretty+import CodeSyntax+import CommonTypes {-# LINE 12 "src-generated/ErrorMessages.hs" #-} -- Error ------------------------------------------------------- {-
src-generated/ExecutionPlan.hs view
@@ -3,17 +3,17 @@ -- UUAGC 0.9.53 (src-ag/ExecutionPlan.ag) module ExecutionPlan where {-# LINE 2 "src-ag/ExecutionPlan.ag" #-}-
--- VisitSyntax.ag imports
-import Patterns    (Pattern(..),Patterns)
-import Expression  (Expression(..))
-import CommonTypes
-import ErrorMessages
-
-import qualified Data.Set as Set
-import Data.Set(Set)
-import qualified Data.Map as Map
-import Data.Map(Map)
++-- VisitSyntax.ag imports+import Patterns    (Pattern(..),Patterns)+import Expression  (Expression(..))+import CommonTypes+import ErrorMessages++import qualified Data.Set as Set+import Data.Set(Set)+import qualified Data.Map as Map+import Data.Map(Map) {-# LINE 18 "src-generated/ExecutionPlan.hs" #-} -- EChild ------------------------------------------------------ {-
src-generated/ExecutionPlan2Caml.hs view
@@ -3,134 +3,134 @@  module ExecutionPlan2Caml where {-# LINE 2 "src-ag/HsToken.ag" #-}-
-import CommonTypes
-import UU.Scanner.Position(Pos)
++import CommonTypes+import UU.Scanner.Position(Pos) {-# LINE 10 "src-generated/ExecutionPlan2Caml.hs" #-}  {-# LINE 2 "src-ag/Expression.ag" #-}-
-import UU.Scanner.Position(Pos)
-import HsToken
++import UU.Scanner.Position(Pos)+import HsToken {-# LINE 16 "src-generated/ExecutionPlan2Caml.hs" #-}  {-# LINE 2 "src-ag/Patterns.ag" #-}-
--- Patterns.ag imports
-import UU.Scanner.Position(Pos)
-import CommonTypes (ConstructorIdent,Identifier)
++-- Patterns.ag imports+import UU.Scanner.Position(Pos)+import CommonTypes (ConstructorIdent,Identifier) {-# LINE 23 "src-generated/ExecutionPlan2Caml.hs" #-}  {-# LINE 2 "src-ag/ExecutionPlan.ag" #-}-
--- VisitSyntax.ag imports
-import Patterns    (Pattern(..),Patterns)
-import Expression  (Expression(..))
-import CommonTypes
-import ErrorMessages
-
-import qualified Data.Set as Set
-import Data.Set(Set)
-import qualified Data.Map as Map
-import Data.Map(Map)
++-- VisitSyntax.ag imports+import Patterns    (Pattern(..),Patterns)+import Expression  (Expression(..))+import CommonTypes+import ErrorMessages++import qualified Data.Set as Set+import Data.Set(Set)+import qualified Data.Map as Map+import Data.Map(Map) {-# LINE 37 "src-generated/ExecutionPlan2Caml.hs" #-}  {-# LINE 32 "src-ag/ExecutionPlan2Caml.ag" #-}-
-import ExecutionPlan
-import Pretty
-import PPUtil
-import Options
-import Data.Monoid(mappend,mempty)
-import Data.Maybe
-import Data.Graph
-import Debug.Trace
-import System.IO
-import System.Directory
-import System.FilePath
-import UU.Scanner.Position
-
-import TokenDef
-import HsToken
-import ErrorMessages
-
-import Data.Set (Set)
-import qualified Data.Set as Set
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Data.Sequence(Seq)
-import qualified Data.Sequence as Seq
-import Data.Foldable(toList)
++import ExecutionPlan+import Pretty+import PPUtil+import Options+import Data.Monoid(mappend,mempty)+import Data.Maybe+import Data.Graph+import Debug.Trace+import System.IO+import System.Directory+import System.FilePath+import UU.Scanner.Position++import TokenDef+import HsToken+import ErrorMessages++import Data.Set (Set)+import qualified Data.Set as Set+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Sequence(Seq)+import qualified Data.Sequence as Seq+import Data.Foldable(toList) {-# LINE 65 "src-generated/ExecutionPlan2Caml.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 175 "src-ag/ExecutionPlan2Caml.ag" #-}-
-ppRecordTp :: PP a => [a] -> PP_Doc
-ppRecordTp es
-  | null es   = text "unit"
-  | otherwise = pp_block "{" "}" "; " (map pp es)
-
-ppRecordVal :: PP a => [a] -> PP_Doc
-ppRecordVal es
-  | null es   = text "()"
-  | otherwise = pp_block "{" "}" "; " (map pp es)
-
-ppFieldsVal :: Bool -> [(PP_Doc,PP_Doc,PP_Doc,PP_Doc)] -> PP_Doc
-ppFieldsVal record fields
-  | null fields = text "()"
-  | record      = ppRecordVal [ r >#< "=" >#< x | (r,x,_,_) <- fields ]
-  | otherwise   = pp_block "(" ")" "," [ x | (_,x,_,_) <- fields ]
-
-ppFieldsType :: Bool -> Bool -> [(PP_Doc,PP_Doc,PP_Doc,PP_Doc)] -> PP_Doc
-ppFieldsType record defor fields
-  | null fields = text "unit"
-  | record      = ppRecordTp [ r >#< ":" >#< (if defor then d else f) | (r,_,d,f) <- fields ]
-  | otherwise   = pp_block "(" ")" "*" [ if defor then d else f | (_,_,d,f) <- fields ]
++ppRecordTp :: PP a => [a] -> PP_Doc+ppRecordTp es+  | null es   = text "unit"+  | otherwise = pp_block "{" "}" "; " (map pp es)++ppRecordVal :: PP a => [a] -> PP_Doc+ppRecordVal es+  | null es   = text "()"+  | otherwise = pp_block "{" "}" "; " (map pp es)++ppFieldsVal :: Bool -> [(PP_Doc,PP_Doc,PP_Doc,PP_Doc)] -> PP_Doc+ppFieldsVal record fields+  | null fields = text "()"+  | record      = ppRecordVal [ r >#< "=" >#< x | (r,x,_,_) <- fields ]+  | otherwise   = pp_block "(" ")" "," [ x | (_,x,_,_) <- fields ]++ppFieldsType :: Bool -> Bool -> [(PP_Doc,PP_Doc,PP_Doc,PP_Doc)] -> PP_Doc+ppFieldsType record defor fields+  | null fields = text "unit"+  | record      = ppRecordTp [ r >#< ":" >#< (if defor then d else f) | (r,_,d,f) <- fields ]+  | otherwise   = pp_block "(" ")" "*" [ if defor then d else f | (_,_,d,f) <- fields ] {-# LINE 91 "src-generated/ExecutionPlan2Caml.hs" #-}  {-# LINE 288 "src-ag/ExecutionPlan2Caml.ag" #-}-
-ppTp :: Type -> PP_Doc
-ppTp tp = case tp of
-  Haskell t -> pp t   -- ocaml type
-  NT nt tps deforested
-    | nt == _SELF -> pp "?SELF?"
-    | null tps    -> ppNontTp nt deforested
-    | otherwise   -> pp_parens (ppSpaced (map pp_parens tps) >#< ppNontTp nt deforested)
-  Self -> pp "?SELF?"
-
-ppNontTp :: NontermIdent -> Bool -> PP_Doc
-ppNontTp nt True  = pp "t_" >|< pp nt
-ppNontTp nt False = pp nt
-
--- multiple type parameters go into a tuple
-ppTypeParams :: PP a => [a] -> PP_Doc
-ppTypeParams []  = empty
-ppTypeParams [x] = pp x
-ppTypeParams xs  = pp_block "(" ")" "," (map pp xs)
++ppTp :: Type -> PP_Doc+ppTp tp = case tp of+  Haskell t -> pp t   -- ocaml type+  NT nt tps deforested+    | nt == _SELF -> pp "?SELF?"+    | null tps    -> ppNontTp nt deforested+    | otherwise   -> pp_parens (ppSpaced (map pp_parens tps) >#< ppNontTp nt deforested)+  Self -> pp "?SELF?"++ppNontTp :: NontermIdent -> Bool -> PP_Doc+ppNontTp nt True  = pp "t_" >|< pp nt+ppNontTp nt False = pp nt++-- multiple type parameters go into a tuple+ppTypeParams :: PP a => [a] -> PP_Doc+ppTypeParams []  = empty+ppTypeParams [x] = pp x+ppTypeParams xs  = pp_block "(" ")" "," (map pp xs) {-# LINE 113 "src-generated/ExecutionPlan2Caml.hs" #-}  {-# LINE 361 "src-ag/ExecutionPlan2Caml.ag" #-}-
--- convention for nonterminals to module names
-modName :: NontermIdent -> PP_Doc
-modName nt = pp "M_" >|< pp nt
-
-ppFunDecl :: Bool -> PP_Doc -> [(PP_Doc,PP_Doc)] -> PP_Doc -> PP_Doc -> PP_Doc
-ppFunDecl gensigs nm args resSig expr = body where
-  body = nm >#< ppSpaced (map arg args) >#< ppRes >#< "="
-         >-< indent 2 expr
-  arg (arg,tp) = ppArg gensigs arg tp
-  ppRes
-    | gensigs  = ":" >#< resSig
-    | otherwise = empty
-
-ppArg :: Bool -> PP_Doc -> PP_Doc -> PP_Doc
-ppArg gensigs arg tp
-  | gensigs   = pp_parens (arg >#< ":" >#< tp)
-  | otherwise = arg
-
++-- convention for nonterminals to module names+modName :: NontermIdent -> PP_Doc+modName nt = pp "M_" >|< pp nt++ppFunDecl :: Bool -> PP_Doc -> [(PP_Doc,PP_Doc)] -> PP_Doc -> PP_Doc -> PP_Doc+ppFunDecl gensigs nm args resSig expr = body where+  body = nm >#< ppSpaced (map arg args) >#< ppRes >#< "="+         >-< indent 2 expr+  arg (arg,tp) = ppArg gensigs arg tp+  ppRes+    | gensigs  = ":" >#< resSig+    | otherwise = empty++ppArg :: Bool -> PP_Doc -> PP_Doc -> PP_Doc+ppArg gensigs arg tp+  | gensigs   = pp_parens (arg >#< ":" >#< tp)+  | otherwise = arg+ {-# LINE 135 "src-generated/ExecutionPlan2Caml.hs" #-}  {-# LINE 428 "src-ag/ExecutionPlan2Caml.ag" #-}@@ -138,182 +138,182 @@ {-# LINE 139 "src-generated/ExecutionPlan2Caml.hs" #-}  {-# LINE 464 "src-ag/ExecutionPlan2Caml.ag" #-}-
---
--- conventions
---
-
--- type of the state of a node: a closure containing the children states and attributes,
--- with code of type 'type_nt_sem' that represents the subsequent visits to successor states.
-type_nt_state nt st = "s_" >|< nt >|< "_" >|< st
-
--- type of a visit to a node (the initial, and when in a given state)
--- an instance of this type is called the "semantics"
-type_nt_sem_top nt = "t_" >|< nt
-type_nt_sem nt st = type_nt_sem_top nt >|< "_s" >|< st
-
--- type of a caller (contains visit selection + inputs + continuation)
-type_caller nt st = "c_" >|< nt >|< "_s" >|< st
-
--- names of records
-nm_attach nt = "attach_">|< nt
-nm_invoke nt st = "inv_" >|< nt >|< "_s" >|< st
-
--- name of the type variable representing the result type of the continuation
-cont_tvar = text "'cont__"
-
-
--- order states in reverse topological order so that successor states are
--- earlier in the resulting list.
-orderStates :: StateIdentifier -> [VisitStateState] -> [StateIdentifier]
-orderStates initial edges = res where
-  source  = Map.singleton initial Set.empty  -- ensures that the initial state is in graph even when there are no edges
-  targets = [ Map.singleton t Set.empty | (_,_,t) <- edges ]
-  deps    = [ Map.singleton f (Set.singleton t) | (_,f,t) <- edges ]
-
-  mp  = Map.unionsWith Set.union (source : (targets ++ deps))
-  es  = [ (f,f,Set.toList ts) | (f,ts) <- Map.toList mp ]
-  cps = stronglyConnComp es
-  res = flattenSCCs cps
++--+-- conventions+--++-- type of the state of a node: a closure containing the children states and attributes,+-- with code of type 'type_nt_sem' that represents the subsequent visits to successor states.+type_nt_state nt st = "s_" >|< nt >|< "_" >|< st++-- type of a visit to a node (the initial, and when in a given state)+-- an instance of this type is called the "semantics"+type_nt_sem_top nt = "t_" >|< nt+type_nt_sem nt st = type_nt_sem_top nt >|< "_s" >|< st++-- type of a caller (contains visit selection + inputs + continuation)+type_caller nt st = "c_" >|< nt >|< "_s" >|< st++-- names of records+nm_attach nt = "attach_">|< nt+nm_invoke nt st = "inv_" >|< nt >|< "_s" >|< st++-- name of the type variable representing the result type of the continuation+cont_tvar = text "'cont__"+++-- order states in reverse topological order so that successor states are+-- earlier in the resulting list.+orderStates :: StateIdentifier -> [VisitStateState] -> [StateIdentifier]+orderStates initial edges = res where+  source  = Map.singleton initial Set.empty  -- ensures that the initial state is in graph even when there are no edges+  targets = [ Map.singleton t Set.empty | (_,_,t) <- edges ]+  deps    = [ Map.singleton f (Set.singleton t) | (_,f,t) <- edges ]++  mp  = Map.unionsWith Set.union (source : (targets ++ deps))+  es  = [ (f,f,Set.toList ts) | (f,ts) <- Map.toList mp ]+  cps = stronglyConnComp es+  res = flattenSCCs cps {-# LINE 179 "src-generated/ExecutionPlan2Caml.hs" #-}  {-# LINE 521 "src-ag/ExecutionPlan2Caml.ag" #-}-
-type_caller_visit nt v = "c_" >|< nt >|< "_v" >|< v
-con_visit nt v = "C_" >|< nt >|< "_v" >|< v
-
--- field names
-nm_inh nt v  = "inh_" >|< nt >|< "_v" >|< v
-nm_cont nt v = "cont_" >|< nt >|< "_v" >|< v
++type_caller_visit nt v = "c_" >|< nt >|< "_v" >|< v+con_visit nt v = "C_" >|< nt >|< "_v" >|< v++-- field names+nm_inh nt v  = "inh_" >|< nt >|< "_v" >|< v+nm_cont nt v = "cont_" >|< nt >|< "_v" >|< v {-# LINE 189 "src-generated/ExecutionPlan2Caml.hs" #-}  {-# LINE 567 "src-ag/ExecutionPlan2Caml.ag" #-}-
--- more naming conventions
-nm_inarg nm nt v = "i_" >|< nm >|< "_" >|< nt >|< "_v" >|< v
-nm_outarg nm nt v = "o_" >|< nm >|< "_" >|< nt >|< "_v" >|< v
-nm_outarg_cont = nm_outarg "_cont"
-
-conNmTVisit nt vId      = "t_" >|< nt >|< "_v"    >|< vId
-conNmTVisitIn nt vId    = "t_" >|< nt >|< "_vIn"  >|< vId
-conNmTVisitOut nt vId   = "t_" >|< nt >|< "_vOut" >|< vId
-
--- todo: remove ppMonadType
-ppMonadType :: Options -> PP_Doc
-ppMonadType opts
-  | parallelInvoke opts = text "IO"
-  | otherwise           = text "Identity"
++-- more naming conventions+nm_inarg nm nt v = "i_" >|< nm >|< "_" >|< nt >|< "_v" >|< v+nm_outarg nm nt v = "o_" >|< nm >|< "_" >|< nt >|< "_v" >|< v+nm_outarg_cont = nm_outarg "_cont"++conNmTVisit nt vId      = "t_" >|< nt >|< "_v"    >|< vId+conNmTVisitIn nt vId    = "t_" >|< nt >|< "_vIn"  >|< vId+conNmTVisitOut nt vId   = "t_" >|< nt >|< "_vOut" >|< vId++-- todo: remove ppMonadType+ppMonadType :: Options -> PP_Doc+ppMonadType opts+  | parallelInvoke opts = text "IO"+  | otherwise           = text "Identity" {-# LINE 207 "src-generated/ExecutionPlan2Caml.hs" #-}  {-# LINE 780 "src-ag/ExecutionPlan2Caml.ag" #-}-
-nm_visit v = "__v" >|< v
-nm_k st = "__k" >|< st
-nm_st st = "__st" >|< st
-
-mklets :: (PP b, PP c) => [b] -> c -> PP_Doc
-mklets defs body = res where
-  ppLet def = "let" >#< def >#< "in"
-  res = vlist (map ppLet defs) >-< body
++nm_visit v = "__v" >|< v+nm_k st = "__k" >|< st+nm_st st = "__st" >|< st++mklets :: (PP b, PP c) => [b] -> c -> PP_Doc+mklets defs body = res where+  ppLet def = "let" >#< def >#< "in"+  res = vlist (map ppLet defs) >-< body {-# LINE 219 "src-generated/ExecutionPlan2Caml.hs" #-}  {-# LINE 822 "src-ag/ExecutionPlan2Caml.ag" #-}-
-resultValName :: String
-resultValName = "__result_"
-
-nextStName :: String
-nextStName = "__st_"
++resultValName :: String+resultValName = "__result_"++nextStName :: String+nextStName = "__st_" {-# LINE 228 "src-generated/ExecutionPlan2Caml.hs" #-}  {-# LINE 963 "src-ag/ExecutionPlan2Caml.ag" #-}-
-stname :: Identifier -> Int -> String
-stname child st = "_" ++ getName child ++ "X" ++ show st
-
--- should actually return some conversion info
-compatibleAttach :: VisitKind -> NontermIdent -> Options -> Bool
-compatibleAttach _ _ _ = True
++stname :: Identifier -> Int -> String+stname child st = "_" ++ getName child ++ "X" ++ show st++-- should actually return some conversion info+compatibleAttach :: VisitKind -> NontermIdent -> Options -> Bool+compatibleAttach _ _ _ = True {-# LINE 238 "src-generated/ExecutionPlan2Caml.hs" #-}  {-# LINE 1030 "src-ag/ExecutionPlan2Caml.ag" #-}-
-dummyPat :: Options -> Bool -> PP_Doc
-dummyPat opts noArgs
-  | not noArgs            = empty
-  | strictDummyToken opts = text "()"
-  | otherwise             = text "(_ : unit)"
-
-dummyArg :: Options -> Bool -> PP_Doc
-dummyArg opts noArgs
-  | not noArgs            = empty
-  | otherwise             = text "()"
-
-dummyType :: Options -> Bool -> PP_Doc
-dummyType opts noArgs
-  | not noArgs            = empty
-  | otherwise             = text "unit"
++dummyPat :: Options -> Bool -> PP_Doc+dummyPat opts noArgs+  | not noArgs            = empty+  | strictDummyToken opts = text "()"+  | otherwise             = text "(_ : unit)"++dummyArg :: Options -> Bool -> PP_Doc+dummyArg opts noArgs+  | not noArgs            = empty+  | otherwise             = text "()"++dummyType :: Options -> Bool -> PP_Doc+dummyType opts noArgs+  | not noArgs            = empty+  | otherwise             = text "unit" {-# LINE 257 "src-generated/ExecutionPlan2Caml.hs" #-}  {-# LINE 1106 "src-ag/ExecutionPlan2Caml.ag" #-}-
-data NonLocalAttr
-  = AttrInh Identifier Identifier
-  | AttrSyn Identifier Identifier deriving Show
-
-mkNonLocalAttr :: Bool -> Identifier -> Identifier -> NonLocalAttr
-mkNonLocalAttr True  = AttrInh  -- True: inherited attr
-mkNonLocalAttr False = AttrSyn
-
-lookupAttrType :: NonLocalAttr -> Map Identifier Attributes -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc
-lookupAttrType (AttrInh child name) inhs _ = lookupType child name inhs
-lookupAttrType (AttrSyn child name) _ syns = lookupType child name syns
-
--- Note: if the child takes type parameters, the type of an attribute of this child may refer to these parameters. This means that
--- the actual type of the attribute needs to have its type parameters substituted with the actual type argument of the child.
--- However, for now we simply decide to return Nothing in this case, which skips the type annotation.
-lookupType :: Identifier -> Identifier -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc
-lookupType child name attrMp childMp
-  | noParameters childTp = Just ppDoc
-  | otherwise            = Nothing
-  where
-    attrTp     = Map.findWithDefault (error "lookupType: the attribute is not in the attrs of the child") name childAttrs
-    childAttrs = Map.findWithDefault (error "lookupType: the attributes of the nonterm are not in the map") nonterm attrMp
-    nonterm    = extractNonterminal childTp
-    childTp    = Map.findWithDefault (error ("lookupType: the child " ++ show child ++ "is not in the appropriate map")) child childMp
-    ppDoc      = ppTp attrTp
-
-noParameters :: Type -> Bool
-noParameters (Haskell _)   = True
-noParameters (NT _ args _) = null args
++data NonLocalAttr+  = AttrInh Identifier Identifier+  | AttrSyn Identifier Identifier deriving Show++mkNonLocalAttr :: Bool -> Identifier -> Identifier -> NonLocalAttr+mkNonLocalAttr True  = AttrInh  -- True: inherited attr+mkNonLocalAttr False = AttrSyn++lookupAttrType :: NonLocalAttr -> Map Identifier Attributes -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc+lookupAttrType (AttrInh child name) inhs _ = lookupType child name inhs+lookupAttrType (AttrSyn child name) _ syns = lookupType child name syns++-- Note: if the child takes type parameters, the type of an attribute of this child may refer to these parameters. This means that+-- the actual type of the attribute needs to have its type parameters substituted with the actual type argument of the child.+-- However, for now we simply decide to return Nothing in this case, which skips the type annotation.+lookupType :: Identifier -> Identifier -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc+lookupType child name attrMp childMp+  | noParameters childTp = Just ppDoc+  | otherwise            = Nothing+  where+    attrTp     = Map.findWithDefault (error "lookupType: the attribute is not in the attrs of the child") name childAttrs+    childAttrs = Map.findWithDefault (error "lookupType: the attributes of the nonterm are not in the map") nonterm attrMp+    nonterm    = extractNonterminal childTp+    childTp    = Map.findWithDefault (error ("lookupType: the child " ++ show child ++ "is not in the appropriate map")) child childMp+    ppDoc      = ppTp attrTp++noParameters :: Type -> Bool+noParameters (Haskell _)   = True+noParameters (NT _ args _) = null args {-# LINE 290 "src-generated/ExecutionPlan2Caml.hs" #-}  {-# LINE 1204 "src-ag/ExecutionPlan2Caml.ag" #-}-
-contNm = text "__cont_"
-inpsNm = text "__inps_"
-
--- a `compatibleKind` b  means: can kind b be invoked from a
-compatibleKind :: VisitKind -> VisitKind -> Bool
-compatibleKind _              _             = True
-
-compatibleRule :: VisitKind -> Bool -> Bool
-compatibleRule (VisitPure _) False = False
-compatibleRule _             _     = True
++contNm = text "__cont_"+inpsNm = text "__inps_"++-- a `compatibleKind` b  means: can kind b be invoked from a+compatibleKind :: VisitKind -> VisitKind -> Bool+compatibleKind _              _             = True++compatibleRule :: VisitKind -> Bool -> Bool+compatibleRule (VisitPure _) False = False+compatibleRule _             _     = True {-# LINE 304 "src-generated/ExecutionPlan2Caml.hs" #-}  {-# LINE 1229 "src-ag/ExecutionPlan2Caml.ag" #-}-
-unionWithSum = Map.unionWith (+)
++unionWithSum = Map.unionWith (+) {-# LINE 309 "src-generated/ExecutionPlan2Caml.hs" #-}  {-# LINE 1252 "src-ag/ExecutionPlan2Caml.ag" #-}-
-uwSetUnion :: (Ord a, Ord b) => Map a (Set b) -> Map a (Set b) -> Map a (Set b)
-uwSetUnion = Map.unionWith Set.union
-
-uwMapUnion :: (Ord a, Ord b) => Map a (Map b c) -> Map a (Map b c) -> Map a (Map b c)
-uwMapUnion = Map.unionWith Map.union
++uwSetUnion :: (Ord a, Ord b) => Map a (Set b) -> Map a (Set b) -> Map a (Set b)+uwSetUnion = Map.unionWith Set.union++uwMapUnion :: (Ord a, Ord b) => Map a (Map b c) -> Map a (Map b c) -> Map a (Map b c)+uwMapUnion = Map.unionWith Map.union {-# LINE 318 "src-generated/ExecutionPlan2Caml.hs" #-} -- EChild ------------------------------------------------------ -- wrapper
src-generated/ExecutionPlan2Clean.hs view
@@ -3,102 +3,102 @@  module ExecutionPlan2Clean where {-# LINE 2 "src-ag/HsToken.ag" #-}-
-import CommonTypes
-import UU.Scanner.Position(Pos)
++import CommonTypes+import UU.Scanner.Position(Pos) {-# LINE 10 "src-generated/ExecutionPlan2Clean.hs" #-}  {-# LINE 2 "src-ag/Expression.ag" #-}-
-import UU.Scanner.Position(Pos)
-import HsToken
++import UU.Scanner.Position(Pos)+import HsToken {-# LINE 16 "src-generated/ExecutionPlan2Clean.hs" #-}  {-# LINE 2 "src-ag/Patterns.ag" #-}-
--- Patterns.ag imports
-import UU.Scanner.Position(Pos)
-import CommonTypes (ConstructorIdent,Identifier)
++-- Patterns.ag imports+import UU.Scanner.Position(Pos)+import CommonTypes (ConstructorIdent,Identifier) {-# LINE 23 "src-generated/ExecutionPlan2Clean.hs" #-}  {-# LINE 2 "src-ag/ExecutionPlan.ag" #-}-
--- VisitSyntax.ag imports
-import Patterns    (Pattern(..),Patterns)
-import Expression  (Expression(..))
-import CommonTypes
-import ErrorMessages
-
-import qualified Data.Set as Set
-import Data.Set(Set)
-import qualified Data.Map as Map
-import Data.Map(Map)
++-- VisitSyntax.ag imports+import Patterns    (Pattern(..),Patterns)+import Expression  (Expression(..))+import CommonTypes+import ErrorMessages++import qualified Data.Set as Set+import Data.Set(Set)+import qualified Data.Map as Map+import Data.Map(Map) {-# LINE 37 "src-generated/ExecutionPlan2Clean.hs" #-}  {-# LINE 7 "src-ag/ExecutionPlan2Clean.ag" #-}-
-import ExecutionPlan
-import Pretty
-import PPUtil
-import Options
-import Data.Monoid(mappend,mempty)
-import Data.Maybe
-import Debug.Trace
-import System.IO
-import System.Directory
-import System.FilePath
-import UU.Scanner.Position
-
-import TokenDef
-import HsToken
-import ErrorMessages
-
-import Data.Set (Set)
-import qualified Data.Set as Set
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Data.Sequence(Seq)
-import qualified Data.Sequence as Seq
-import Data.Foldable(toList)
++import ExecutionPlan+import Pretty+import PPUtil+import Options+import Data.Monoid(mappend,mempty)+import Data.Maybe+import Debug.Trace+import System.IO+import System.Directory+import System.FilePath+import UU.Scanner.Position++import TokenDef+import HsToken+import ErrorMessages++import Data.Set (Set)+import qualified Data.Set as Set+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Sequence(Seq)+import qualified Data.Sequence as Seq+import Data.Foldable(toList) {-# LINE 64 "src-generated/ExecutionPlan2Clean.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 190 "src-ag/ExecutionPlan2Clean.ag" #-}-
-classCtxsToDocs :: ClassContext -> [PP_Doc]
-classCtxsToDocs = map toDoc where
-  toDoc (ident,args) = (ident >#< ppSpaced (map pp_parens args))
-
-classConstrsToDocs :: [Type] -> [PP_Doc]
-classConstrsToDocs = map ppTp
-
-ppClasses :: [PP_Doc] -> PP_Doc
-ppClasses [] = empty
-ppClasses xs = "|" >#< pp_block "" "" "&" xs
-
-ppQuants :: [Identifier] -> PP_Doc
-ppQuants [] = empty
-ppQuants ps = "E." >#< ppSpaced ps >#< ":"
++classCtxsToDocs :: ClassContext -> [PP_Doc]+classCtxsToDocs = map toDoc where+  toDoc (ident,args) = (ident >#< ppSpaced (map pp_parens args))++classConstrsToDocs :: [Type] -> [PP_Doc]+classConstrsToDocs = map ppTp++ppClasses :: [PP_Doc] -> PP_Doc+ppClasses [] = empty+ppClasses xs = "|" >#< pp_block "" "" "&" xs++ppQuants :: [Identifier] -> PP_Doc+ppQuants [] = empty+ppQuants ps = "E." >#< ppSpaced ps >#< ":" {-# LINE 83 "src-generated/ExecutionPlan2Clean.hs" #-}  {-# LINE 227 "src-ag/ExecutionPlan2Clean.ag" #-}-
--- first parameter indicates: generate a record or not
-ppConFields :: Bool -> [PP_Doc] -> PP_Doc
-ppConFields True  flds = ppListSep "{" "}" ", " flds
-ppConFields False flds = ppSpaced flds
++-- first parameter indicates: generate a record or not+ppConFields :: Bool -> [PP_Doc] -> PP_Doc+ppConFields True  flds = ppListSep "{" "}" ", " flds+ppConFields False flds = ppSpaced flds {-# LINE 91 "src-generated/ExecutionPlan2Clean.hs" #-}  {-# LINE 260 "src-ag/ExecutionPlan2Clean.ag" #-}-
-ppTp :: Type -> PP_Doc
-ppTp = text . typeToHaskellString Nothing []
++ppTp :: Type -> PP_Doc+ppTp = text . typeToHaskellString Nothing [] {-# LINE 97 "src-generated/ExecutionPlan2Clean.hs" #-}  {-# LINE 333 "src-ag/ExecutionPlan2Clean.ag" #-}-
-isRecordConstructor :: NontermIdent -> Map NontermIdent ConstructorType -> Bool
-isRecordConstructor nt ctm = Map.lookup nt ctm == Just RecordConstructor
++isRecordConstructor :: NontermIdent -> Map NontermIdent ConstructorType -> Bool+isRecordConstructor nt ctm = Map.lookup nt ctm == Just RecordConstructor {-# LINE 103 "src-generated/ExecutionPlan2Clean.hs" #-}  {-# LINE 374 "src-ag/ExecutionPlan2Clean.ag" #-}@@ -106,232 +106,232 @@ {-# LINE 107 "src-generated/ExecutionPlan2Clean.hs" #-}  {-# LINE 483 "src-ag/ExecutionPlan2Clean.ag" #-}-
-conNmTVisit nt vId      = "T_" >|< nt >|< "_v"    >|< vId
-conNmTVisitIn nt vId    = "T_" >|< nt >|< "_vIn"  >|< vId
-conNmTVisitOut nt vId   = "T_" >|< nt >|< "_vOut" >|< vId
-conNmTNextVisit nt stId = "T_" >|< nt >|< "_s"    >|< stId
-
-ppMonadType :: Options -> PP_Doc
-ppMonadType opts
-  | parallelInvoke opts = text "IO"
-  | otherwise           = text "Identity"
++conNmTVisit nt vId      = "T_" >|< nt >|< "_v"    >|< vId+conNmTVisitIn nt vId    = "T_" >|< nt >|< "_vIn"  >|< vId+conNmTVisitOut nt vId   = "T_" >|< nt >|< "_vOut" >|< vId+conNmTNextVisit nt stId = "T_" >|< nt >|< "_s"    >|< stId++ppMonadType :: Options -> PP_Doc+ppMonadType opts+  | parallelInvoke opts = text "IO"+  | otherwise           = text "Identity" {-# LINE 120 "src-generated/ExecutionPlan2Clean.hs" #-}  {-# LINE 652 "src-ag/ExecutionPlan2Clean.ag" #-}-
-ppDefor :: Type -> PP_Doc
-ppDefor (NT nt args _) = "T_" >|< nt >#< ppSpaced (map pp_parens args)
-ppDefor (Haskell s)    = text s
++ppDefor :: Type -> PP_Doc+ppDefor (NT nt args _) = "T_" >|< nt >#< ppSpaced (map pp_parens args)+ppDefor (Haskell s)    = text s {-# LINE 127 "src-generated/ExecutionPlan2Clean.hs" #-}  {-# LINE 756 "src-ag/ExecutionPlan2Clean.ag" #-}-
-mklet :: (PP a, PP b, PP c) => a -> b -> c -> PP_Doc
-mklet prefix defs body =
-  prefix
-  >-< indent (length (show prefix))
-    ("let"
-     >-< indent 4 defs
-     >-< "in" >#< body)
++mklet :: (PP a, PP b, PP c) => a -> b -> c -> PP_Doc+mklet prefix defs body =+  prefix+  >-< indent (length (show prefix))+    ("let"+     >-< indent 4 defs+     >-< "in" >#< body) {-# LINE 138 "src-generated/ExecutionPlan2Clean.hs" #-}  {-# LINE 817 "src-ag/ExecutionPlan2Clean.ag" #-}-
-resultValName :: String
-resultValName = "ag__result_"
-
-nextStName :: String
-nextStName = "ag__st_"
++resultValName :: String+resultValName = "ag__result_"++nextStName :: String+nextStName = "ag__st_" {-# LINE 147 "src-generated/ExecutionPlan2Clean.hs" #-}  {-# LINE 878 "src-ag/ExecutionPlan2Clean.ag" #-}-
-parResultName :: String
-parResultName = "__outcome_"
-
-fmtDecl :: PP a => Bool -> FormatMode -> a -> PP_Doc
-fmtDecl declPure fmt decl = case fmt of
-  FormatLetDecl -> pp decl
-  FormatLetLine -> "let" >#< decl >#< "in"
-  FormatDo | declPure  -> "let" >#< decl >#< "in"
-           | otherwise -> pp decl
++parResultName :: String+parResultName = "__outcome_"++fmtDecl :: PP a => Bool -> FormatMode -> a -> PP_Doc+fmtDecl declPure fmt decl = case fmt of+  FormatLetDecl -> pp decl+  FormatLetLine -> "let" >#< decl >#< "in"+  FormatDo | declPure  -> "let" >#< decl >#< "in"+           | otherwise -> pp decl {-# LINE 160 "src-generated/ExecutionPlan2Clean.hs" #-}  {-# LINE 992 "src-ag/ExecutionPlan2Clean.ag" #-}-
-stname :: Identifier -> Int -> String
-stname child st = "st_" ++ getName child ++ "X" ++ show st
-
--- should actually return some conversion info
-compatibleAttach :: VisitKind -> NontermIdent -> Options -> Bool
-compatibleAttach _ _ _ = True
-
-unMon :: Options -> PP_Doc
-unMon options
-  | parallelInvoke options = text "'System.IO.Unsafe'.unsafePerformIO"    -- IO monad
-  | otherwise              = text "'Control.Monad.Identity'.runIdentity"  -- identity monad
++stname :: Identifier -> Int -> String+stname child st = "st_" ++ getName child ++ "X" ++ show st++-- should actually return some conversion info+compatibleAttach :: VisitKind -> NontermIdent -> Options -> Bool+compatibleAttach _ _ _ = True++unMon :: Options -> PP_Doc+unMon options+  | parallelInvoke options = text "'System.IO.Unsafe'.unsafePerformIO"    -- IO monad+  | otherwise              = text "'Control.Monad.Identity'.runIdentity"  -- identity monad {-# LINE 175 "src-generated/ExecutionPlan2Clean.hs" #-}  {-# LINE 1079 "src-ag/ExecutionPlan2Clean.ag" #-}-
-dummyPat :: Options -> Bool -> PP_Doc
-dummyPat opts noArgs
-  | not noArgs && tupleAsDummyToken opts = empty  -- no unnecessary tuples
-  | tupleAsDummyToken opts = if strictDummyToken opts
-                             then text "Void"
-                             else text "(_)"
-  | otherwise              = let match | strictDummyToken opts = "!_"
-                                       | otherwise             = "_"
-                             in pp_parens (match >#< "::" >#< dummyType opts noArgs)
-  where match | strictDummyToken opts = "(!_)"
-              | otherwise             = "_"
-
-dummyArg :: Options -> Bool -> PP_Doc
-dummyArg opts noArgs
-  | not noArgs && tupleAsDummyToken opts = empty    -- no unnecessary tuples
-  | tupleAsDummyToken opts = text "Void"
-  | otherwise              = text "GHC.Prim.realWorld#"
-
-dummyType :: Options -> Bool -> PP_Doc
-dummyType opts noArgs
-  | not noArgs && tupleAsDummyToken opts = empty     -- no unnecessary tuples
-  | tupleAsDummyToken opts = text "Void"
-  | otherwise              = text "(GHC.Prim.State# GHC.Prim.RealWorld)"
++dummyPat :: Options -> Bool -> PP_Doc+dummyPat opts noArgs+  | not noArgs && tupleAsDummyToken opts = empty  -- no unnecessary tuples+  | tupleAsDummyToken opts = if strictDummyToken opts+                             then text "Void"+                             else text "(_)"+  | otherwise              = let match | strictDummyToken opts = "!_"+                                       | otherwise             = "_"+                             in pp_parens (match >#< "::" >#< dummyType opts noArgs)+  where match | strictDummyToken opts = "(!_)"+              | otherwise             = "_"++dummyArg :: Options -> Bool -> PP_Doc+dummyArg opts noArgs+  | not noArgs && tupleAsDummyToken opts = empty    -- no unnecessary tuples+  | tupleAsDummyToken opts = text "Void"+  | otherwise              = text "GHC.Prim.realWorld#"++dummyType :: Options -> Bool -> PP_Doc+dummyType opts noArgs+  | not noArgs && tupleAsDummyToken opts = empty     -- no unnecessary tuples+  | tupleAsDummyToken opts = text "Void"+  | otherwise              = text "(GHC.Prim.State# GHC.Prim.RealWorld)" {-# LINE 202 "src-generated/ExecutionPlan2Clean.hs" #-}  {-# LINE 1105 "src-ag/ExecutionPlan2Clean.ag" #-}-
--- rules are "deinlined" to prevent needless code duplication.
--- if there is only a bit of duplication, we allow ghc to decide if it is worth it.
--- if the duplication crosses this threshold, however, we tell ghc definitely not to inline it.
-ruleInlineThresholdSoft :: Int
-ruleInlineThresholdSoft = 3
-
-ruleInlineThresholdHard :: Int
-ruleInlineThresholdHard = 5
-
-reallyOftenUsedThreshold :: Int
-reallyOftenUsedThreshold = 12
++-- rules are "deinlined" to prevent needless code duplication.+-- if there is only a bit of duplication, we allow ghc to decide if it is worth it.+-- if the duplication crosses this threshold, however, we tell ghc definitely not to inline it.+ruleInlineThresholdSoft :: Int+ruleInlineThresholdSoft = 3++ruleInlineThresholdHard :: Int+ruleInlineThresholdHard = 5++reallyOftenUsedThreshold :: Int+reallyOftenUsedThreshold = 12 {-# LINE 217 "src-generated/ExecutionPlan2Clean.hs" #-}  {-# LINE 1172 "src-ag/ExecutionPlan2Clean.ag" #-}-
-data NonLocalAttr
-  = AttrInh Identifier Identifier
-  | AttrSyn Identifier Identifier deriving Show
-
-mkNonLocalAttr :: Bool -> Identifier -> Identifier -> NonLocalAttr
-mkNonLocalAttr True  = AttrInh  -- True: inherited attr
-mkNonLocalAttr False = AttrSyn
-
-lookupAttrType :: NonLocalAttr -> Map Identifier Attributes -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc
-lookupAttrType (AttrInh child name) inhs _ = lookupType child name inhs
-lookupAttrType (AttrSyn child name) _ syns = lookupType child name syns
-
--- Note: if the child takes type parameters, the type of an attribute of this child may refer to these parameters. This means that
--- the actual type of the attribute needs to have its type parameters substituted with the actual type argument of the child.
--- However, for now we simply decide to return Nothing in this case, which skips the type annotation.
-lookupType :: Identifier -> Identifier -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc
-lookupType child name attrMp childMp
-  | noParameters childTp = Just ppDoc
-  | otherwise            = Nothing
-  where
-    attrTp     = Map.findWithDefault (error "lookupType: the attribute is not in the attrs of the child") name childAttrs
-    childAttrs = Map.findWithDefault (error "lookupType: the attributes of the nonterm are not in the map") nonterm attrMp
-    nonterm    = extractNonterminal childTp
-    childTp    = Map.findWithDefault (error ("lookupType: the child " ++ show child ++ "is not in the appropriate map")) child childMp
-    ppDoc      = ppTp attrTp
-
-noParameters :: Type -> Bool
-noParameters (Haskell _)   = True
-noParameters (NT _ args _) = null args
++data NonLocalAttr+  = AttrInh Identifier Identifier+  | AttrSyn Identifier Identifier deriving Show++mkNonLocalAttr :: Bool -> Identifier -> Identifier -> NonLocalAttr+mkNonLocalAttr True  = AttrInh  -- True: inherited attr+mkNonLocalAttr False = AttrSyn++lookupAttrType :: NonLocalAttr -> Map Identifier Attributes -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc+lookupAttrType (AttrInh child name) inhs _ = lookupType child name inhs+lookupAttrType (AttrSyn child name) _ syns = lookupType child name syns++-- Note: if the child takes type parameters, the type of an attribute of this child may refer to these parameters. This means that+-- the actual type of the attribute needs to have its type parameters substituted with the actual type argument of the child.+-- However, for now we simply decide to return Nothing in this case, which skips the type annotation.+lookupType :: Identifier -> Identifier -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc+lookupType child name attrMp childMp+  | noParameters childTp = Just ppDoc+  | otherwise            = Nothing+  where+    attrTp     = Map.findWithDefault (error "lookupType: the attribute is not in the attrs of the child") name childAttrs+    childAttrs = Map.findWithDefault (error "lookupType: the attributes of the nonterm are not in the map") nonterm attrMp+    nonterm    = extractNonterminal childTp+    childTp    = Map.findWithDefault (error ("lookupType: the child " ++ show child ++ "is not in the appropriate map")) child childMp+    ppDoc      = ppTp attrTp++noParameters :: Type -> Bool+noParameters (Haskell _)   = True+noParameters (NT _ args _) = null args {-# LINE 250 "src-generated/ExecutionPlan2Clean.hs" #-}  {-# LINE 1259 "src-ag/ExecutionPlan2Clean.ag" #-}-
--- a `compatibleKind` b  means: can kind b be invoked from a
-compatibleKind :: VisitKind -> VisitKind -> Bool
-compatibleKind _              _             = True
-
-compatibleRule :: VisitKind -> Bool -> Bool
-compatibleRule (VisitPure _) False = False
-compatibleRule _             _     = True
++-- a `compatibleKind` b  means: can kind b be invoked from a+compatibleKind :: VisitKind -> VisitKind -> Bool+compatibleKind _              _             = True++compatibleRule :: VisitKind -> Bool -> Bool+compatibleRule (VisitPure _) False = False+compatibleRule _             _     = True {-# LINE 261 "src-generated/ExecutionPlan2Clean.hs" #-}  {-# LINE 1281 "src-ag/ExecutionPlan2Clean.ag" #-}-
-unionWithSum = Map.unionWith (+)
++unionWithSum = Map.unionWith (+) {-# LINE 266 "src-generated/ExecutionPlan2Clean.hs" #-}  {-# LINE 1304 "src-ag/ExecutionPlan2Clean.ag" #-}-
-uwSetUnion :: (Ord a, Ord b) => Map a (Set b) -> Map a (Set b) -> Map a (Set b)
-uwSetUnion = Map.unionWith Set.union
-
-uwMapUnion :: (Ord a, Ord b) => Map a (Map b c) -> Map a (Map b c) -> Map a (Map b c)
-uwMapUnion = Map.unionWith Map.union
++uwSetUnion :: (Ord a, Ord b) => Map a (Set b) -> Map a (Set b) -> Map a (Set b)+uwSetUnion = Map.unionWith Set.union++uwMapUnion :: (Ord a, Ord b) => Map a (Map b c) -> Map a (Map b c) -> Map a (Map b c)+uwMapUnion = Map.unionWith Map.union {-# LINE 275 "src-generated/ExecutionPlan2Clean.hs" #-}  {-# LINE 1499 "src-ag/ExecutionPlan2Clean.ag" #-}-
-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
-
-cleanIclModuleHeader :: Options -> String -> String
-cleanIclModuleHeader flags input
- = case moduleName flags
-   of Name nm -> genMod nm
-      Default -> genMod (defaultModuleName input)
-      NoName  -> ""
-   where genMod x = "implementation module " ++ x 
-
-cleanDclModuleHeader :: Options -> String -> Maybe String -> String
-cleanDclModuleHeader flags input export
- = case moduleName flags
-   of Name nm -> genMod nm
-      Default -> genMod (defaultModuleName input)
-      NoName  -> ""
-   where genMod x = "definition module " ++ x ++ genExp export x
-         genExp Nothing _ = ""
-         genExp (Just e) x = "(module " ++ x ++ ", module " ++ e ++ ")"
-
-defaultModuleName :: String -> String
-defaultModuleName = dropExtension
-
-mkIclModuleHeader :: Maybe (String,String,String) -> String -> String -> String -> Bool -> String
-mkIclModuleHeader Nothing defaultName suffix _ _
-  = "implementation module " ++ defaultName ++ suffix
-mkIclModuleHeader (Just (name, exports, imports)) _ suffix addExports replaceExports
-  = "implementation module " ++ name ++ suffix ++ "\n" ++ imports ++ "\n"
-
-mkDclModuleHeader :: Maybe (String,String,String) -> String -> String -> String -> Bool -> String
-mkDclModuleHeader Nothing defaultName suffix _ _
-  = "definition module " ++ defaultName ++ suffix
-mkDclModuleHeader (Just (name, exports, _)) _ suffix addExports replaceExports
-  = "definition module " ++ name ++ suffix ++ ex ++ "\n"
-  where
-    ex  = if null exports || (replaceExports && null addExports)
-          then ""
-          else if null addExports
-               then exports
-               else if replaceExports
-                    then addExports
-                    else exports ++ "," ++ addExports
++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++cleanIclModuleHeader :: Options -> String -> String+cleanIclModuleHeader flags input+ = case moduleName flags+   of Name nm -> genMod nm+      Default -> genMod (defaultModuleName input)+      NoName  -> ""+   where genMod x = "implementation module " ++ x ++cleanDclModuleHeader :: Options -> String -> Maybe String -> String+cleanDclModuleHeader flags input export+ = case moduleName flags+   of Name nm -> genMod nm+      Default -> genMod (defaultModuleName input)+      NoName  -> ""+   where genMod x = "definition module " ++ x ++ genExp export x+         genExp Nothing _ = ""+         genExp (Just e) x = "(module " ++ x ++ ", module " ++ e ++ ")"++defaultModuleName :: String -> String+defaultModuleName = dropExtension++mkIclModuleHeader :: Maybe (String,String,String) -> String -> String -> String -> Bool -> String+mkIclModuleHeader Nothing defaultName suffix _ _+  = "implementation module " ++ defaultName ++ suffix+mkIclModuleHeader (Just (name, exports, imports)) _ suffix addExports replaceExports+  = "implementation module " ++ name ++ suffix ++ "\n" ++ imports ++ "\n"++mkDclModuleHeader :: Maybe (String,String,String) -> String -> String -> String -> Bool -> String+mkDclModuleHeader Nothing defaultName suffix _ _+  = "definition module " ++ defaultName ++ suffix+mkDclModuleHeader (Just (name, exports, _)) _ suffix addExports replaceExports+  = "definition module " ++ name ++ suffix ++ ex ++ "\n"+  where+    ex  = if null exports || (replaceExports && null addExports)+          then ""+          else if null addExports+               then exports+               else if replaceExports+                    then addExports+                    else exports ++ "," ++ addExports {-# LINE 336 "src-generated/ExecutionPlan2Clean.hs" #-} -- EChild ------------------------------------------------------ -- wrapper
src-generated/ExecutionPlan2Hs.hs view
@@ -3,96 +3,96 @@  module ExecutionPlan2Hs where {-# LINE 2 "src-ag/HsToken.ag" #-}-
-import CommonTypes
-import UU.Scanner.Position(Pos)
++import CommonTypes+import UU.Scanner.Position(Pos) {-# LINE 10 "src-generated/ExecutionPlan2Hs.hs" #-}  {-# LINE 2 "src-ag/Expression.ag" #-}-
-import UU.Scanner.Position(Pos)
-import HsToken
++import UU.Scanner.Position(Pos)+import HsToken {-# LINE 16 "src-generated/ExecutionPlan2Hs.hs" #-}  {-# LINE 2 "src-ag/Patterns.ag" #-}-
--- Patterns.ag imports
-import UU.Scanner.Position(Pos)
-import CommonTypes (ConstructorIdent,Identifier)
++-- Patterns.ag imports+import UU.Scanner.Position(Pos)+import CommonTypes (ConstructorIdent,Identifier) {-# LINE 23 "src-generated/ExecutionPlan2Hs.hs" #-}  {-# LINE 2 "src-ag/ExecutionPlan.ag" #-}-
--- VisitSyntax.ag imports
-import Patterns    (Pattern(..),Patterns)
-import Expression  (Expression(..))
-import CommonTypes
-import ErrorMessages
-
-import qualified Data.Set as Set
-import Data.Set(Set)
-import qualified Data.Map as Map
-import Data.Map(Map)
++-- VisitSyntax.ag imports+import Patterns    (Pattern(..),Patterns)+import Expression  (Expression(..))+import CommonTypes+import ErrorMessages++import qualified Data.Set as Set+import Data.Set(Set)+import qualified Data.Map as Map+import Data.Map(Map) {-# LINE 37 "src-generated/ExecutionPlan2Hs.hs" #-}  {-# LINE 7 "src-ag/ExecutionPlan2Hs.ag" #-}-
-import ExecutionPlan
-import Pretty
-import PPUtil
-import Options
-import Data.Monoid(mappend,mempty)
-import Data.Maybe
-import Debug.Trace
-import System.IO
-import System.Directory
-import System.FilePath
-import UU.Scanner.Position
-
-import TokenDef
-import HsToken
-import ErrorMessages
-
-import Data.Set (Set)
-import qualified Data.Set as Set
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Data.Sequence(Seq)
-import qualified Data.Sequence as Seq
-import Data.Foldable(toList)
++import ExecutionPlan+import Pretty+import PPUtil+import Options+import Data.Monoid(mappend,mempty)+import Data.Maybe+import Debug.Trace+import System.IO+import System.Directory+import System.FilePath+import UU.Scanner.Position++import TokenDef+import HsToken+import ErrorMessages++import Data.Set (Set)+import qualified Data.Set as Set+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Sequence(Seq)+import qualified Data.Sequence as Seq+import Data.Foldable(toList) {-# LINE 64 "src-generated/ExecutionPlan2Hs.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 163 "src-ag/ExecutionPlan2Hs.ag" #-}-
-classCtxsToDocs :: ClassContext -> [PP_Doc]
-classCtxsToDocs = map toDoc where
-  toDoc (ident,args) = (ident >#< ppSpaced (map pp_parens args))
-
-classConstrsToDocs :: [Type] -> [PP_Doc]
-classConstrsToDocs = map ppTp
-
-ppClasses :: [PP_Doc] -> PP_Doc
-ppClasses [] = empty
-ppClasses xs = pp_block "(" ")" "," xs >#< "=>"
-
-ppQuants :: [Identifier] -> PP_Doc
-ppQuants [] = empty
-ppQuants ps = "forall" >#< ppSpaced ps >#< "."
++classCtxsToDocs :: ClassContext -> [PP_Doc]+classCtxsToDocs = map toDoc where+  toDoc (ident,args) = (ident >#< ppSpaced (map pp_parens args))++classConstrsToDocs :: [Type] -> [PP_Doc]+classConstrsToDocs = map ppTp++ppClasses :: [PP_Doc] -> PP_Doc+ppClasses [] = empty+ppClasses xs = pp_block "(" ")" "," xs >#< "=>"++ppQuants :: [Identifier] -> PP_Doc+ppQuants [] = empty+ppQuants ps = "forall" >#< ppSpaced ps >#< "." {-# LINE 83 "src-generated/ExecutionPlan2Hs.hs" #-}  {-# LINE 192 "src-ag/ExecutionPlan2Hs.ag" #-}-
--- first parameter indicates: generate a record or not
-ppConFields :: Bool -> [PP_Doc] -> PP_Doc
-ppConFields True  flds = ppListSep "{" "}" ", " $ filter (not . isEmpty) flds
-ppConFields False flds = ppSpaced flds
++-- first parameter indicates: generate a record or not+ppConFields :: Bool -> [PP_Doc] -> PP_Doc+ppConFields True  flds = ppListSep "{" "}" ", " $ filter (not . isEmpty) flds+ppConFields False flds = ppSpaced flds {-# LINE 91 "src-generated/ExecutionPlan2Hs.hs" #-}  {-# LINE 218 "src-ag/ExecutionPlan2Hs.ag" #-}-
-ppTp :: Type -> PP_Doc
-ppTp = text . typeToHaskellString Nothing []
++ppTp :: Type -> PP_Doc+ppTp = text . typeToHaskellString Nothing [] {-# LINE 97 "src-generated/ExecutionPlan2Hs.hs" #-}  {-# LINE 332 "src-ag/ExecutionPlan2Hs.ag" #-}@@ -100,231 +100,231 @@ {-# LINE 101 "src-generated/ExecutionPlan2Hs.hs" #-}  {-# LINE 428 "src-ag/ExecutionPlan2Hs.ag" #-}-
-conNmTVisit nt vId      = "T_" >|< nt >|< "_v"    >|< vId
-conNmTVisitIn nt vId    = "T_" >|< nt >|< "_vIn"  >|< vId
-conNmTVisitOut nt vId   = "T_" >|< nt >|< "_vOut" >|< vId
-conNmTNextVisit nt stId = "T_" >|< nt >|< "_s"    >|< stId
-
-ppMonadType :: Options -> PP_Doc
-ppMonadType opts
-  | parallelInvoke opts = text "IO"
-  | otherwise           = text "Identity"
++conNmTVisit nt vId      = "T_" >|< nt >|< "_v"    >|< vId+conNmTVisitIn nt vId    = "T_" >|< nt >|< "_vIn"  >|< vId+conNmTVisitOut nt vId   = "T_" >|< nt >|< "_vOut" >|< vId+conNmTNextVisit nt stId = "T_" >|< nt >|< "_s"    >|< stId++ppMonadType :: Options -> PP_Doc+ppMonadType opts+  | parallelInvoke opts = text "IO"+  | otherwise           = text "Identity" {-# LINE 114 "src-generated/ExecutionPlan2Hs.hs" #-}  {-# LINE 589 "src-ag/ExecutionPlan2Hs.ag" #-}-
-ppDefor :: Type -> PP_Doc
-ppDefor (NT nt args _) = "T_" >|< nt >#< ppSpaced (map pp_parens args)
-ppDefor (Haskell s)    = text s
++ppDefor :: Type -> PP_Doc+ppDefor (NT nt args _) = "T_" >|< nt >#< ppSpaced (map pp_parens args)+ppDefor (Haskell s)    = text s {-# LINE 121 "src-generated/ExecutionPlan2Hs.hs" #-}  {-# LINE 713 "src-ag/ExecutionPlan2Hs.ag" #-}-
-mklet :: (PP a, PP b, PP c) => a -> b -> c -> PP_Doc
-mklet prefix defs body =
-  prefix >#< "let"
-  >-< indent 3 defs
-  >-< indent 2 "in" >#< body
++mklet :: (PP a, PP b, PP c) => a -> b -> c -> PP_Doc+mklet prefix defs body =+  prefix >#< "let"+  >-< indent 3 defs+  >-< indent 2 "in" >#< body {-# LINE 130 "src-generated/ExecutionPlan2Hs.hs" #-}  {-# LINE 779 "src-ag/ExecutionPlan2Hs.ag" #-}-
-resultValName :: String
-resultValName = "__result_"
-
-nextStName :: String
-nextStName = "__st_"
++resultValName :: String+resultValName = "__result_"++nextStName :: String+nextStName = "__st_" {-# LINE 139 "src-generated/ExecutionPlan2Hs.hs" #-}  {-# LINE 850 "src-ag/ExecutionPlan2Hs.ag" #-}-
-parResultName :: String
-parResultName = "__outcome_"
-
-fmtDecl :: PP a => Bool -> FormatMode -> a -> PP_Doc
-fmtDecl declPure fmt decl = case fmt of
-  FormatLetDecl -> pp decl
-  FormatLetLine -> "let" >#< decl >#< "in"
-  FormatDo | declPure  -> "let" >#< decl
-           | otherwise -> pp decl
++parResultName :: String+parResultName = "__outcome_"++fmtDecl :: PP a => Bool -> FormatMode -> a -> PP_Doc+fmtDecl declPure fmt decl = case fmt of+  FormatLetDecl -> pp decl+  FormatLetLine -> "let" >#< decl >#< "in"+  FormatDo | declPure  -> "let" >#< decl+           | otherwise -> pp decl {-# LINE 152 "src-generated/ExecutionPlan2Hs.hs" #-}  {-# LINE 976 "src-ag/ExecutionPlan2Hs.ag" #-}-
-stname :: Identifier -> Int -> String
-stname child st = "_" ++ getName child ++ "X" ++ show st
-
--- should actually return some conversion info
-compatibleAttach :: VisitKind -> NontermIdent -> Options -> Bool
-compatibleAttach _ _ _ = True
-
-unMon :: Options -> PP_Doc
-unMon options
-  | parallelInvoke options = text "System.IO.Unsafe.unsafePerformIO"    -- IO monad
-  | otherwise              = text "Control.Monad.Identity.runIdentity"  -- identity monad
++stname :: Identifier -> Int -> String+stname child st = "_" ++ getName child ++ "X" ++ show st++-- should actually return some conversion info+compatibleAttach :: VisitKind -> NontermIdent -> Options -> Bool+compatibleAttach _ _ _ = True++unMon :: Options -> PP_Doc+unMon options+  | parallelInvoke options = text "System.IO.Unsafe.unsafePerformIO"    -- IO monad+  | otherwise              = text "Control.Monad.Identity.runIdentity"  -- identity monad {-# LINE 167 "src-generated/ExecutionPlan2Hs.hs" #-}  {-# LINE 1084 "src-ag/ExecutionPlan2Hs.ag" #-}-
-dummyPat :: Options -> Bool -> PP_Doc
-dummyPat opts noArgs
-  | not noArgs && tupleAsDummyToken opts = empty  -- no unnecessary tuples
-  | tupleAsDummyToken opts = if strictDummyToken opts
-                             then text "()"
-                             else text "(_ :: ())"
-  | otherwise              = let match | strictDummyToken opts = "!_"
-                                       | otherwise             = "_"
-                             in pp_parens (match >#< "::" >#< dummyType opts noArgs)
-  where match | strictDummyToken opts = "(!_)"
-              | otherwise             = "_"
-
-dummyArg :: Options -> Bool -> PP_Doc
-dummyArg opts noArgs
-  | not noArgs && tupleAsDummyToken opts = empty    -- no unnecessary tuples
-  | tupleAsDummyToken opts = text "()"
-  | otherwise              = text "GHC.Prim.realWorld#"
-
-dummyType :: Options -> Bool -> PP_Doc
-dummyType opts noArgs
-  | not noArgs && tupleAsDummyToken opts = empty     -- no unnecessary tuples
-  | tupleAsDummyToken opts = text "()"
-  | otherwise              = text "(GHC.Prim.State# GHC.Prim.RealWorld)"
++dummyPat :: Options -> Bool -> PP_Doc+dummyPat opts noArgs+  | not noArgs && tupleAsDummyToken opts = empty  -- no unnecessary tuples+  | tupleAsDummyToken opts = if strictDummyToken opts+                             then text "()"+                             else text "(_ :: ())"+  | otherwise              = let match | strictDummyToken opts = "!_"+                                       | otherwise             = "_"+                             in pp_parens (match >#< "::" >#< dummyType opts noArgs)+  where match | strictDummyToken opts = "(!_)"+              | otherwise             = "_"++dummyArg :: Options -> Bool -> PP_Doc+dummyArg opts noArgs+  | not noArgs && tupleAsDummyToken opts = empty    -- no unnecessary tuples+  | tupleAsDummyToken opts = text "()"+  | otherwise              = text "GHC.Prim.realWorld#"++dummyType :: Options -> Bool -> PP_Doc+dummyType opts noArgs+  | not noArgs && tupleAsDummyToken opts = empty     -- no unnecessary tuples+  | tupleAsDummyToken opts = text "()"+  | otherwise              = text "(GHC.Prim.State# GHC.Prim.RealWorld)" {-# LINE 194 "src-generated/ExecutionPlan2Hs.hs" #-}  {-# LINE 1110 "src-ag/ExecutionPlan2Hs.ag" #-}-
--- rules are "deinlined" to prevent needless code duplication.
--- if there is only a bit of duplication, we allow ghc to decide if it is worth it.
--- if the duplication crosses this threshold, however, we tell ghc definitely not to inline it.
-ruleInlineThresholdSoft :: Int
-ruleInlineThresholdSoft = 3
-
-ruleInlineThresholdHard :: Int
-ruleInlineThresholdHard = 5
-
-reallyOftenUsedThreshold :: Int
-reallyOftenUsedThreshold = 12
++-- rules are "deinlined" to prevent needless code duplication.+-- if there is only a bit of duplication, we allow ghc to decide if it is worth it.+-- if the duplication crosses this threshold, however, we tell ghc definitely not to inline it.+ruleInlineThresholdSoft :: Int+ruleInlineThresholdSoft = 3++ruleInlineThresholdHard :: Int+ruleInlineThresholdHard = 5++reallyOftenUsedThreshold :: Int+reallyOftenUsedThreshold = 12 {-# LINE 209 "src-generated/ExecutionPlan2Hs.hs" #-}  {-# LINE 1176 "src-ag/ExecutionPlan2Hs.ag" #-}-
-data NonLocalAttr
-  = AttrInh Identifier Identifier
-  | AttrSyn Identifier Identifier deriving Show
-
-mkNonLocalAttr :: Bool -> Identifier -> Identifier -> NonLocalAttr
-mkNonLocalAttr True  = AttrInh  -- True: inherited attr
-mkNonLocalAttr False = AttrSyn
-
-lookupAttrType :: NonLocalAttr -> Map Identifier Attributes -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc
-lookupAttrType (AttrInh child name) inhs _ = lookupType child name inhs
-lookupAttrType (AttrSyn child name) _ syns = lookupType child name syns
-
--- Note: if the child takes type parameters, the type of an attribute of this child may refer to these parameters. This means that
--- the actual type of the attribute needs to have its type parameters substituted with the actual type argument of the child.
--- However, for now we simply decide to return Nothing in this case, which skips the type annotation.
-lookupType :: Identifier -> Identifier -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc
-lookupType child name attrMp childMp
-  | noParameters childTp = Just ppDoc
-  | otherwise            = Nothing
-  where
-    attrTp     = Map.findWithDefault (error "lookupType: the attribute is not in the attrs of the child") name childAttrs
-    childAttrs = Map.findWithDefault (error "lookupType: the attributes of the nonterm are not in the map") nonterm attrMp
-    nonterm    = extractNonterminal childTp
-    childTp    = Map.findWithDefault (error ("lookupType: the child " ++ show child ++ "is not in the appropriate map")) child childMp
-    ppDoc      = ppTp attrTp
-
-noParameters :: Type -> Bool
-noParameters (Haskell _)   = True
-noParameters (NT _ args _) = null args
++data NonLocalAttr+  = AttrInh Identifier Identifier+  | AttrSyn Identifier Identifier deriving Show++mkNonLocalAttr :: Bool -> Identifier -> Identifier -> NonLocalAttr+mkNonLocalAttr True  = AttrInh  -- True: inherited attr+mkNonLocalAttr False = AttrSyn++lookupAttrType :: NonLocalAttr -> Map Identifier Attributes -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc+lookupAttrType (AttrInh child name) inhs _ = lookupType child name inhs+lookupAttrType (AttrSyn child name) _ syns = lookupType child name syns++-- Note: if the child takes type parameters, the type of an attribute of this child may refer to these parameters. This means that+-- the actual type of the attribute needs to have its type parameters substituted with the actual type argument of the child.+-- However, for now we simply decide to return Nothing in this case, which skips the type annotation.+lookupType :: Identifier -> Identifier -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc+lookupType child name attrMp childMp+  | noParameters childTp = Just ppDoc+  | otherwise            = Nothing+  where+    attrTp     = Map.findWithDefault (error "lookupType: the attribute is not in the attrs of the child") name childAttrs+    childAttrs = Map.findWithDefault (error "lookupType: the attributes of the nonterm are not in the map") nonterm attrMp+    nonterm    = extractNonterminal childTp+    childTp    = Map.findWithDefault (error ("lookupType: the child " ++ show child ++ "is not in the appropriate map")) child childMp+    ppDoc      = ppTp attrTp++noParameters :: Type -> Bool+noParameters (Haskell _)   = True+noParameters (NT _ args _) = null args {-# LINE 242 "src-generated/ExecutionPlan2Hs.hs" #-}  {-# LINE 1263 "src-ag/ExecutionPlan2Hs.ag" #-}-
--- a `compatibleKind` b  means: can kind b be invoked from a
-compatibleKind :: VisitKind -> VisitKind -> Bool
-compatibleKind _              _             = True
-
-compatibleRule :: VisitKind -> Bool -> Bool
-compatibleRule (VisitPure _) False = False
-compatibleRule _             _     = True
++-- a `compatibleKind` b  means: can kind b be invoked from a+compatibleKind :: VisitKind -> VisitKind -> Bool+compatibleKind _              _             = True++compatibleRule :: VisitKind -> Bool -> Bool+compatibleRule (VisitPure _) False = False+compatibleRule _             _     = True {-# LINE 253 "src-generated/ExecutionPlan2Hs.hs" #-}  {-# LINE 1285 "src-ag/ExecutionPlan2Hs.ag" #-}-
-unionWithSum = Map.unionWith (+)
++unionWithSum = Map.unionWith (+) {-# LINE 258 "src-generated/ExecutionPlan2Hs.hs" #-}  {-# LINE 1308 "src-ag/ExecutionPlan2Hs.ag" #-}-
-uwSetUnion :: (Ord a, Ord b) => Map a (Set b) -> Map a (Set b) -> Map a (Set b)
-uwSetUnion = Map.unionWith Set.union
-
-uwMapUnion :: (Ord a, Ord b) => Map a (Map b c) -> Map a (Map b c) -> Map a (Map b c)
-uwMapUnion = Map.unionWith Map.union
++uwSetUnion :: (Ord a, Ord b) => Map a (Set b) -> Map a (Set b) -> Map a (Set b)+uwSetUnion = Map.unionWith Set.union++uwMapUnion :: (Ord a, Ord b) => Map a (Map b c) -> Map a (Map b c) -> Map a (Map b c)+uwMapUnion = Map.unionWith Map.union {-# LINE 267 "src-generated/ExecutionPlan2Hs.hs" #-}  {-# LINE 1525 "src-ag/ExecutionPlan2Hs.ag" #-}-
-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
++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 {-# LINE 287 "src-generated/ExecutionPlan2Hs.hs" #-}  {-# LINE 1672 "src-ag/ExecutionPlan2Hs.ag" #-}-
-ppNoInline :: PP a => a -> PP_Doc
-ppNoInline = ppPragmaBinding "NOINLINE"
-
-ppInline :: PP a => a -> PP_Doc
-ppInline = ppPragmaBinding "INLINE"
-
-ppInlinable :: PP a => a -> PP_Doc
-ppInlinable = ppPragmaBinding "INLINABLE"
-
-ppPragmaBinding :: (PP a, PP b) => a -> b -> PP_Doc
-ppPragmaBinding pragma nm = "{-#" >#< pragma >#< nm >#< "#-}"
-
-ppCostCentre :: PP a => a -> PP_Doc
-ppCostCentre nm = "{-#" >#< "SCC" >#< "\"" >|< nm >|< "\"" >#< "#-}"
-
-warrenFlagsPP :: Options -> PP_Doc
-warrenFlagsPP options = vlist
-  [ pp "{-# LANGUAGE Rank2Types, GADTs #-}"
-  , if bangpats options
-    then pp "{-# LANGUAGE BangPatterns #-}"
-    else empty
-  , if noPerRuleTypeSigs options && noPerStateTypeSigs options
-    then empty
-    else pp "{-# LANGUAGE ScopedTypeVariables #-}"
-  , if tupleAsDummyToken options
-    then empty
-    else pp "{-# LANGUAGE ScopedTypeVariables, MagicHash #-}"
-  , -- not that the meaning of "unbox" is here that strict fields in data types may be
-    -- unboxed if possible. This may affect user-defined data types declared in the module.
-    -- Unfortunately, we cannot turn it on for only the AG generated data types without
-    -- causing a zillion of warnings.
-    if unbox options && bangpats options
-        then pp $ "{-# OPTIONS_GHC -funbox-strict-fields -fstrictness #-}"
-        else empty
-  , if parallelInvoke options && not (noEagerBlackholing options)
-    then pp $ "{-# OPTIONS_GHC -feager-blackholing #-}"
-    else empty
-  ]
++ppNoInline :: PP a => a -> PP_Doc+ppNoInline = ppPragmaBinding "NOINLINE"++ppInline :: PP a => a -> PP_Doc+ppInline = ppPragmaBinding "INLINE"++ppInlinable :: PP a => a -> PP_Doc+ppInlinable = ppPragmaBinding "INLINABLE"++ppPragmaBinding :: (PP a, PP b) => a -> b -> PP_Doc+ppPragmaBinding pragma nm = "{-#" >#< pragma >#< nm >#< "#-}"++ppCostCentre :: PP a => a -> PP_Doc+ppCostCentre nm = "{-#" >#< "SCC" >#< "\"" >|< nm >|< "\"" >#< "#-}"++warrenFlagsPP :: Options -> PP_Doc+warrenFlagsPP options = vlist+  [ pp "{-# LANGUAGE Rank2Types, GADTs #-}"+  , if bangpats options+    then pp "{-# LANGUAGE BangPatterns #-}"+    else empty+  , if noPerRuleTypeSigs options && noPerStateTypeSigs options+    then empty+    else pp "{-# LANGUAGE ScopedTypeVariables #-}"+  , if tupleAsDummyToken options+    then empty+    else pp "{-# LANGUAGE ScopedTypeVariables, MagicHash #-}"+  , -- not that the meaning of "unbox" is here that strict fields in data types may be+    -- unboxed if possible. This may affect user-defined data types declared in the module.+    -- Unfortunately, we cannot turn it on for only the AG generated data types without+    -- causing a zillion of warnings.+    if unbox options && bangpats options+        then pp $ "{-# OPTIONS_GHC -funbox-strict-fields -fstrictness #-}"+        else empty+  , if parallelInvoke options && not (noEagerBlackholing options)+    then pp $ "{-# OPTIONS_GHC -feager-blackholing #-}"+    else empty+  ] {-# LINE 329 "src-generated/ExecutionPlan2Hs.hs" #-} -- EChild ------------------------------------------------------ -- wrapper
src-generated/Expression.hs view
@@ -3,9 +3,9 @@ -- UUAGC 0.9.53 (src-ag/Expression.ag) module Expression where {-# LINE 2 "src-ag/Expression.ag" #-}-
-import UU.Scanner.Position(Pos)
-import HsToken
++import UU.Scanner.Position(Pos)+import HsToken {-# LINE 10 "src-generated/Expression.hs" #-} -- Expression -------------------------------------------------- {-
src-generated/GenerateCode.hs view
@@ -3,265 +3,265 @@  module GenerateCode where {-# LINE 2 "src-ag/DeclBlocks.ag" #-}-
-import Code (Decl,Expr)
++import Code (Decl,Expr) {-# LINE 9 "src-generated/GenerateCode.hs" #-}  {-# LINE 2 "src-ag/Patterns.ag" #-}-
--- Patterns.ag imports
-import UU.Scanner.Position(Pos)
-import CommonTypes (ConstructorIdent,Identifier)
++-- Patterns.ag imports+import UU.Scanner.Position(Pos)+import CommonTypes (ConstructorIdent,Identifier) {-# LINE 16 "src-generated/GenerateCode.hs" #-}  {-# LINE 2 "src-ag/CodeSyntax.ag" #-}-
-import Patterns
-import CommonTypes
-import Data.Map(Map)
-import Data.Set(Set)
++import Patterns+import CommonTypes+import Data.Map(Map)+import Data.Set(Set) {-# LINE 24 "src-generated/GenerateCode.hs" #-}  {-# LINE 9 "src-ag/GenerateCode.ag" #-}-
-import CommonTypes
-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 Data.Sequence as Seq
-import Data.Sequence(Seq)
-import UU.Scanner.Position
-import TokenDef
-import HsToken
-import HsTokenScanner
-
-import Data.List(partition,intersperse)
-import Data.Maybe(fromJust,isJust)
-
++import CommonTypes+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 Data.Sequence as Seq+import Data.Sequence(Seq)+import UU.Scanner.Position+import TokenDef+import HsToken+import HsTokenScanner++import Data.List(partition,intersperse)+import Data.Maybe(fromJust,isJust)+ {-# LINE 52 "src-generated/GenerateCode.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 107 "src-ag/GenerateCode.ag" #-}-
--- remove possible @v references in the types of a data type.
-cleanupArg :: Options -> String -> String
-cleanupArg opts s
-  = case idEvalType opts (SimpleType s) of
-      SimpleType s' -> s'
-      _             -> error "Only SimpleType supported"
++-- remove possible @v references in the types of a data type.+cleanupArg :: Options -> String -> String+cleanupArg opts s+  = case idEvalType opts (SimpleType s) of+      SimpleType s' -> s'+      _             -> error "Only SimpleType supported" {-# LINE 63 "src-generated/GenerateCode.hs" #-}  {-# LINE 123 "src-ag/GenerateCode.ag" #-}-
-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
-
-appQuant :: QuantMap -> NontermIdent -> Code.Type -> Code.Type
-appQuant mp nt tp
-  = foldr QuantApp tp $ Map.findWithDefault [] nt mp
++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++appQuant :: QuantMap -> NontermIdent -> Code.Type -> Code.Type+appQuant mp nt tp+  = foldr QuantApp tp $ Map.findWithDefault [] nt mp {-# LINE 74 "src-generated/GenerateCode.hs" #-}  {-# LINE 249 "src-ag/GenerateCode.ag" #-}-
-mkDecl :: Bool -> Lhs -> Expr -> Set String -> Set String -> Decl
-mkDecl True  lhs rhs _ _   = Bind lhs rhs
-mkDecl False lhs rhs s1 s2 = Decl lhs rhs s1 s2
-
-unwrapSem :: Bool -> NontermIdent -> Expr -> Expr
-unwrapSem False _ e = e
-unwrapSem True nm e = Case e alts
-  where alts  = [CaseAlt left right]
-        left  = Fun (typeName nm 0) [SimpleExpr "x"]
-        right = SimpleExpr "x"
++mkDecl :: Bool -> Lhs -> Expr -> Set String -> Set String -> Decl+mkDecl True  lhs rhs _ _   = Bind lhs rhs+mkDecl False lhs rhs s1 s2 = Decl lhs rhs s1 s2++unwrapSem :: Bool -> NontermIdent -> Expr -> Expr+unwrapSem False _ e = e+unwrapSem True nm e = Case e alts+  where alts  = [CaseAlt left right]+        left  = Fun (typeName nm 0) [SimpleExpr "x"]+        right = SimpleExpr "x" {-# LINE 88 "src-generated/GenerateCode.hs" #-}  {-# LINE 545 "src-ag/GenerateCode.ag" #-}-
-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
-
-mkSemFun :: Identifier -> Int -> Exprs -> Expr -> Expr
-mkSemFun nt nr xs e = SemFun (typeName nt nr) xs e
-
-typeAppStrs :: String -> [String] -> Code.Type
-typeAppStrs nm params = TypeApp (SimpleType nm) (map SimpleType params)
-
-isHigherOrder :: ChildKind -> Bool
-isHigherOrder ChildAttr = True
-isHigherOrder _         = False
-
-pickOrigType :: (Identifier, Type, ChildKind) -> (Identifier, Type, ChildKind)
-pickOrigType (nm, _, virt@(ChildReplace x)) = (nm, x, virt)
-pickOrigType x = x
++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++mkSemFun :: Identifier -> Int -> Exprs -> Expr -> Expr+mkSemFun nt nr xs e = SemFun (typeName nt nr) xs e++typeAppStrs :: String -> [String] -> Code.Type+typeAppStrs nm params = TypeApp (SimpleType nm) (map SimpleType params)++isHigherOrder :: ChildKind -> Bool+isHigherOrder ChildAttr = True+isHigherOrder _         = False++pickOrigType :: (Identifier, Type, ChildKind) -> (Identifier, Type, ChildKind)+pickOrigType (nm, _, virt@(ChildReplace x)) = (nm, x, virt)+pickOrigType x = x {-# LINE 113 "src-generated/GenerateCode.hs" #-}  {-# LINE 642 "src-ag/GenerateCode.ag" #-}-
-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)
++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) {-# LINE 127 "src-generated/GenerateCode.hs" #-}  {-# LINE 692 "src-ag/GenerateCode.ag" #-}-
-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
++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 {-# LINE 150 "src-generated/GenerateCode.hs" #-}  {-# LINE 770 "src-ag/GenerateCode.ag" #-}-
-typeToCodeType :: Maybe NontermIdent -> [String] -> Type -> Code.Type
-typeToCodeType _ _ tp
-  = case tp of
-      NT nt tps defor -> NontermType (getName nt) tps defor
-      Haskell t       -> SimpleType t
-      Self            -> error "Self type not allowed here."
-
-evalType :: Options -> (String -> String) -> Code.Type -> Code.Type
-evalType opts 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 opts (initPos txt) txt
-                                      tks' = map replaceTok tks
-                                      txt' = unlines . showTokens . tokensToStrings $ tks'
-                                  in SimpleType txt'
-          TMaybe m             -> TMaybe (chase m)
-          TEither l r          -> TEither (chase l) (chase r)
-          TMap k v             -> TMap (chase k) (chase v)
-          TIntMap v            -> TIntMap (chase v)
-          TSet m               -> TSet (chase m)
-          _                    -> t
-
-    replaceTok t
-      = case t of
-          AGLocal v p _ -> HsToken (replf $ getName v) p
-          _             -> t
-
-idEvalType :: Options -> Code.Type -> Code.Type
-idEvalType options = evalType options id
++typeToCodeType :: Maybe NontermIdent -> [String] -> Type -> Code.Type+typeToCodeType _ _ tp+  = case tp of+      NT nt tps defor -> NontermType (getName nt) tps defor+      Haskell t       -> SimpleType t+      Self            -> error "Self type not allowed here."++evalType :: Options -> (String -> String) -> Code.Type -> Code.Type+evalType opts 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 opts (initPos txt) txt+                                      tks' = map replaceTok tks+                                      txt' = unlines . showTokens . tokensToStrings $ tks'+                                  in SimpleType txt'+          TMaybe m             -> TMaybe (chase m)+          TEither l r          -> TEither (chase l) (chase r)+          TMap k v             -> TMap (chase k) (chase v)+          TIntMap v            -> TIntMap (chase v)+          TSet m               -> TSet (chase m)+          _                    -> t++    replaceTok t+      = case t of+          AGLocal v p _ -> HsToken (replf $ getName v) p+          _             -> t++idEvalType :: Options -> Code.Type -> Code.Type+idEvalType options = evalType options id {-# LINE 190 "src-generated/GenerateCode.hs" #-}  {-# LINE 896 "src-ag/GenerateCode.ag" #-}-
--- for a virtual child that already existed as a child, returns
-isFirstOrder :: ChildKind -> Type -> Maybe Type
-isFirstOrder ChildSyntax       tp = Just tp
-isFirstOrder ChildAttr         _  = Nothing
-isFirstOrder (ChildReplace tp) _  = Just tp
++-- for a virtual child that already existed as a child, returns+isFirstOrder :: ChildKind -> Type -> Maybe Type+isFirstOrder ChildSyntax       tp = Just tp+isFirstOrder ChildAttr         _  = Nothing+isFirstOrder (ChildReplace tp) _  = Just tp {-# LINE 199 "src-generated/GenerateCode.hs" #-}  {-# LINE 917 "src-ag/GenerateCode.ag" #-}-
-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' ++ "}"
-                                                                   Self -> error "Self type not allowed here.") tp
-                                       in   ( what ++ " " ++ x ++ replicate ((width - length x) `max` 0) ' ' ++ " : " ++ y )
-
++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' ++ "}"+                                                                   Self -> error "Self type not allowed here.") tp+                                       in   ( what ++ " " ++ x ++ replicate ((width - length x) `max` 0) ' ' ++ " : " ++ y )+ {-# LINE 211 "src-generated/GenerateCode.hs" #-}  {-# LINE 951 "src-ag/GenerateCode.ag" #-}-
--- Lets or nested Cases?
--- or even a do-expression?
-
-data DeclsType = DeclsLet | DeclsCase | DeclsDo
-
-mkDecls :: DeclsType -> Decls -> Expr -> Expr
-mkDecls DeclsLet  = mkLet False
-mkDecls DeclsCase = mkLet True
-mkDecls DeclsDo   = \decls -> Do (map toBind decls)
-  where toBind (Decl lhs rhs _ _) = BindLet lhs rhs
-        toBind d                  = d
-
-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 _ _)      ex = Case rhs [CaseAlt left ex]
-oneCase (Resume _ nt left rhs)   ex = ResumeExpr nt rhs left ex
-oneCase _                        ex = ex
-
--- Gives the name of the visit function
-funname :: Show a => a -> Int -> String
-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
-
-ntOfVisit :: NontermIdent -> Int -> NontermIdent
-ntOfVisit nt 0 = nt
-ntOfVisit nt n = Ident (show nt ++ "_" ++ show n) (getPos nt)
-
--- Gives the name of a visit function
-visitname  ::  String -> NontermIdent -> Int -> String
-visitname pre nt n =  pre ++ getName nt ++ "_" ++ show n
++-- Lets or nested Cases?+-- or even a do-expression?++data DeclsType = DeclsLet | DeclsCase | DeclsDo++mkDecls :: DeclsType -> Decls -> Expr -> Expr+mkDecls DeclsLet  = mkLet False+mkDecls DeclsCase = mkLet True+mkDecls DeclsDo   = \decls -> Do (map toBind decls)+  where toBind (Decl lhs rhs _ _) = BindLet lhs rhs+        toBind d                  = d++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 _ _)      ex = Case rhs [CaseAlt left ex]+oneCase (Resume _ nt left rhs)   ex = ResumeExpr nt rhs left ex+oneCase _                        ex = ex++-- Gives the name of the visit function+funname :: Show a => a -> Int -> String+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++ntOfVisit :: NontermIdent -> Int -> NontermIdent+ntOfVisit nt 0 = nt+ntOfVisit nt n = Ident (show nt ++ "_" ++ show n) (getPos nt)++-- Gives the name of a visit function+visitname  ::  String -> NontermIdent -> Int -> String+visitname pre nt n =  pre ++ getName nt ++ "_" ++ show n {-# LINE 258 "src-generated/GenerateCode.hs" #-}  {-# LINE 1042 "src-ag/GenerateCode.ag" #-}-
-toNamedType :: Bool -> NontermIdent -> ConstructorIdent -> Identifier -> Code.Type -> Code.NamedType
-toNamedType genStrict nt con nm tp
-  = Code.Named genStrict strNm tp
-  where strNm = recordFieldname nt con nm
++toNamedType :: Bool -> NontermIdent -> ConstructorIdent -> Identifier -> Code.Type -> Code.NamedType+toNamedType genStrict nt con nm tp+  = Code.Named genStrict strNm tp+  where strNm = recordFieldname nt con nm {-# LINE 266 "src-generated/GenerateCode.hs" #-} -- CGrammar ---------------------------------------------------- -- wrapper
src-generated/HsToken.hs view
@@ -3,9 +3,9 @@ -- UUAGC 0.9.53 (src-ag/HsToken.ag) module HsToken where {-# LINE 2 "src-ag/HsToken.ag" #-}-
-import CommonTypes
-import UU.Scanner.Position(Pos)
++import CommonTypes+import UU.Scanner.Position(Pos) {-# LINE 10 "src-generated/HsToken.hs" #-} -- HsToken ----------------------------------------------------- {-
src-generated/Interfaces.hs view
@@ -3,9 +3,9 @@ -- UUAGC 0.9.53 (src-ag/Interfaces.ag) module Interfaces where {-# LINE 2 "src-ag/Interfaces.ag" #-}-
-import CommonTypes
-import SequentialTypes
++import CommonTypes+import SequentialTypes {-# LINE 10 "src-generated/Interfaces.hs" #-} -- IRoot ------------------------------------------------------- {-
src-generated/InterfacesRules.hs view
@@ -4,9 +4,9 @@  module InterfacesRules where {-# LINE 2 "src-ag/Interfaces.ag" #-}-
-import CommonTypes
-import SequentialTypes
++import CommonTypes+import SequentialTypes {-# LINE 11 "src-generated/InterfacesRules.hs" #-}  {-# LINE 10 "src-ag/InterfacesRules.lag" #-}
src-generated/KWOrder.hs view
@@ -3,77 +3,77 @@  module KWOrder where {-# LINE 2 "src-ag/Patterns.ag" #-}-
--- Patterns.ag imports
-import UU.Scanner.Position(Pos)
-import CommonTypes (ConstructorIdent,Identifier)
++-- Patterns.ag imports+import UU.Scanner.Position(Pos)+import CommonTypes (ConstructorIdent,Identifier) {-# LINE 11 "src-generated/KWOrder.hs" #-}  {-# LINE 2 "src-ag/Expression.ag" #-}-
-import UU.Scanner.Position(Pos)
-import HsToken
++import UU.Scanner.Position(Pos)+import HsToken {-# LINE 17 "src-generated/KWOrder.hs" #-}  {-# LINE 2 "src-ag/HsToken.ag" #-}-
-import CommonTypes
-import UU.Scanner.Position(Pos)
++import CommonTypes+import UU.Scanner.Position(Pos) {-# LINE 23 "src-generated/KWOrder.hs" #-}  {-# LINE 2 "src-ag/AbstractSyntax.ag" #-}-
--- AbstractSyntax.ag imports
-import Data.Set(Set)
-import Data.Map(Map)
-import Patterns    (Pattern(..),Patterns)
-import Expression  (Expression(..))
-import Macro --marcos
-import CommonTypes
-import ErrorMessages
++-- AbstractSyntax.ag imports+import Data.Set(Set)+import Data.Map(Map)+import Patterns    (Pattern(..),Patterns)+import Expression  (Expression(..))+import Macro --marcos+import CommonTypes+import ErrorMessages {-# LINE 35 "src-generated/KWOrder.hs" #-}  {-# LINE 10 "src-ag/KWOrder.ag" #-}-
-import AbstractSyntax
-import HsToken
-import Expression
-import Patterns
-import Options
-import PPUtil
-import Pretty
-import Knuth1
-import KennedyWarren
-import ExecutionPlan
-import Data.Maybe
-import Debug.Trace
-import Data.Set(Set)
-import Data.Map(Map)
-import Data.Sequence(Seq)
-import qualified Data.Set as Set
-import qualified Data.Map as Map
-import qualified Data.Sequence as Seq
-import Data.Monoid(mappend,mempty)
++import AbstractSyntax+import HsToken+import Expression+import Patterns+import Options+import PPUtil+import Pretty+import Knuth1+import KennedyWarren+import ExecutionPlan+import Data.Maybe+import Debug.Trace+import Data.Set(Set)+import Data.Map(Map)+import Data.Sequence(Seq)+import qualified Data.Set as Set+import qualified Data.Map as Map+import qualified Data.Sequence as Seq+import Data.Monoid(mappend,mempty) {-# LINE 58 "src-generated/KWOrder.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 125 "src-ag/KWOrder.ag" #-}-
--- a depends on b, thus a is a successor of b
-depToEdge :: Dependency -> Edge
-depToEdge (Dependency a b) = (occToVertex False b, occToVertex True a)
-
-occToVertex :: Bool -> Occurrence -> Vertex
-occToVertex _ (OccRule nm) = VRule nm
-occToVertex isDependency (OccAttr c a)
-  | c == _LOC  = VAttr Syn c a   -- local attributes are treated as synthesized attrs of 'loc'
-  | c == _INST = VChild a        -- higher-order attributes are treated as children
-  | otherwise  = VAttr kind c a where
-      kind | isDependency && c == _LHS     = Inh     -- these dependencies have the property that
-           | isDependency && c /= _LHS     = Syn     -- they can all be faked by writing a 'const' rule
-           | not isDependency && c == _LHS = Syn     -- Perhaps we should also allow other forms of dependencies
-           | not isDependency && c /= _LHS = Inh     -- as well, such as two inherited attributes, which would
-                                                     -- force them in different visits
++-- a depends on b, thus a is a successor of b+depToEdge :: Dependency -> Edge+depToEdge (Dependency a b) = (occToVertex False b, occToVertex True a)++occToVertex :: Bool -> Occurrence -> Vertex+occToVertex _ (OccRule nm) = VRule nm+occToVertex isDependency (OccAttr c a)+  | c == _LOC  = VAttr Syn c a   -- local attributes are treated as synthesized attrs of 'loc'+  | c == _INST = VChild a        -- higher-order attributes are treated as children+  | otherwise  = VAttr kind c a where+      kind | isDependency && c == _LHS     = Inh     -- these dependencies have the property that+           | isDependency && c /= _LHS     = Syn     -- they can all be faked by writing a 'const' rule+           | not isDependency && c == _LHS = Syn     -- Perhaps we should also allow other forms of dependencies+           | not isDependency && c /= _LHS = Inh     -- as well, such as two inherited attributes, which would+                                                     -- force them in different visits {-# LINE 78 "src-generated/KWOrder.hs" #-} -- Child ------------------------------------------------------- -- wrapper
src-generated/LOAG/Order.hs view
@@ -4,328 +4,328 @@ module LOAG.Order where  {-# LINE 10 "src-ag/LOAG/Rep.ag" #-}-
-import Data.List (intercalate, foldl', nub)
-import Data.Tuple (swap)
-import Control.Arrow
++import Data.List (intercalate, foldl', nub)+import Data.Tuple (swap)+import Control.Arrow {-# LINE 12 "src-generated/LOAG/Order.hs" #-}  {-# LINE 2 "src-ag/HsToken.ag" #-}-
-import CommonTypes
-import UU.Scanner.Position(Pos)
++import CommonTypes+import UU.Scanner.Position(Pos) {-# LINE 18 "src-generated/LOAG/Order.hs" #-}  {-# LINE 2 "src-ag/Expression.ag" #-}-
-import UU.Scanner.Position(Pos)
-import HsToken
++import UU.Scanner.Position(Pos)+import HsToken {-# LINE 24 "src-generated/LOAG/Order.hs" #-}  {-# LINE 2 "src-ag/CodeSyntax.ag" #-}-
-import Patterns
-import CommonTypes
-import Data.Map(Map)
-import Data.Set(Set)
++import Patterns+import CommonTypes+import Data.Map(Map)+import Data.Set(Set) {-# LINE 32 "src-generated/LOAG/Order.hs" #-}  {-# LINE 2 "src-ag/Patterns.ag" #-}-
--- Patterns.ag imports
-import UU.Scanner.Position(Pos)
-import CommonTypes (ConstructorIdent,Identifier)
++-- Patterns.ag imports+import UU.Scanner.Position(Pos)+import CommonTypes (ConstructorIdent,Identifier) {-# LINE 39 "src-generated/LOAG/Order.hs" #-}  {-# LINE 2 "src-ag/AbstractSyntax.ag" #-}-
--- AbstractSyntax.ag imports
-import Data.Set(Set)
-import Data.Map(Map)
-import Patterns    (Pattern(..),Patterns)
-import Expression  (Expression(..))
-import Macro --marcos
-import CommonTypes
-import ErrorMessages
++-- AbstractSyntax.ag imports+import Data.Set(Set)+import Data.Map(Map)+import Patterns    (Pattern(..),Patterns)+import Expression  (Expression(..))+import Macro --marcos+import CommonTypes+import ErrorMessages {-# LINE 51 "src-generated/LOAG/Order.hs" #-}  {-# LINE 13 "src-ag/LOAG/Order.ag" #-}-
-import qualified Data.Array as A
-import qualified Data.Map as Map
-import qualified Data.IntMap as IMap
-import qualified Data.Set as Set
-import qualified Data.IntSet as IS
-import qualified Data.Sequence as Seq
-import qualified CommonTypes as CT
-import Control.Monad (forM,when)
-import Control.Monad.ST
-import Data.Maybe(catMaybes)
-import Data.Monoid(mappend,mempty)
-import Data.STRef
-import AbstractSyntax
-import qualified LOAG.AOAG as   AOAG
-import LOAG.Common
-import LOAG.Chordal
-import LOAG.Rep
-import LOAG.Graphs
-import CodeSyntax
-import Data.Maybe (isJust, fromJust)
-import ExecutionPlan
-import GrammarInfo
-import HsToken (HsToken(..))
-import Pretty
-import qualified System.IO as IO
-import           System.IO.Unsafe
++import qualified Data.Array as A+import qualified Data.Map as Map+import qualified Data.IntMap as IMap+import qualified Data.Set as Set+import qualified Data.IntSet as IS+import qualified Data.Sequence as Seq+import qualified CommonTypes as CT+import Control.Monad (forM,when)+import Control.Monad.ST+import Data.Maybe(catMaybes)+import Data.Monoid(mappend,mempty)+import Data.STRef+import AbstractSyntax+import qualified LOAG.AOAG as   AOAG+import LOAG.Common+import LOAG.Chordal+import LOAG.Rep+import LOAG.Graphs+import CodeSyntax+import Data.Maybe (isJust, fromJust)+import ExecutionPlan+import GrammarInfo+import HsToken (HsToken(..))+import Pretty+import qualified System.IO as IO+import           System.IO.Unsafe {-# LINE 81 "src-generated/LOAG/Order.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 13 "src-ag/LOAG/Prepare.ag" #-}-
--- | Translating UUAGC types to MyTypes
-drhs f | f == _LHS               = Inh
-       | f == _LOC               = AnyDir
-       | f == _INST              = AnyDir
-       | otherwise               = Syn
-dlhs f | f == _LHS               = Syn
-       | f == _LOC               = AnyDir
-       | f == _INST              = AnyDir
-       | otherwise               = Inh 
-
-depToEdge :: PMP_R -> PLabel -> Dependency -> Edge
-depToEdge pmpr p e = 
-    (findWithErr pmpr "depToEdge" $ MyOccurrence (p,getName f1) (getName i1, drhs f1),
-     findWithErr pmpr "depToEdge" $ MyOccurrence (p,getName f2) (getName i2, dlhs f2))
-    where Dependency (OccAttr f1 i1) (OccAttr f2 i2) = e
-
-vertexToAttr :: NMP -> Vertex -> Attributes
-vertexToAttr nmp v = Map.singleton (identifier a) (fromMyTy ty)
-    where (MyAttribute ty (a,_)) = findWithErr nmp "vertexToAttr" v
-
++-- | Translating UUAGC types to MyTypes+drhs f | f == _LHS               = Inh+       | f == _LOC               = AnyDir+       | f == _INST              = AnyDir+       | otherwise               = Syn+dlhs f | f == _LHS               = Syn+       | f == _LOC               = AnyDir+       | f == _INST              = AnyDir+       | otherwise               = Inh ++depToEdge :: PMP_R -> PLabel -> Dependency -> Edge+depToEdge pmpr p e = +    (findWithErr pmpr "depToEdge" $ MyOccurrence (p,getName f1) (getName i1, drhs f1),+     findWithErr pmpr "depToEdge" $ MyOccurrence (p,getName f2) (getName i2, dlhs f2))+    where Dependency (OccAttr f1 i1) (OccAttr f2 i2) = e++vertexToAttr :: NMP -> Vertex -> Attributes+vertexToAttr nmp v = Map.singleton (identifier a) (fromMyTy ty)+    where (MyAttribute ty (a,_)) = findWithErr nmp "vertexToAttr" v+ {-# LINE 106 "src-generated/LOAG/Order.hs" #-}  {-# LINE 292 "src-ag/LOAG/Prepare.ag" #-}-
--- | Replace the references to local attributes, by his attrs dependencies,
--- |    rendering the local attributes 'transparent'.
-repLocRefs :: SF_P -> SF_P -> SF_P
-repLocRefs lfp sfp =
-    Map.map (setConcatMap $ rep Set.empty) sfp
-    where rep :: Set.Set MyOccurrence -> MyOccurrence -> Set.Set MyOccurrence 
-          rep done occ | occ `Set.member` done = Set.empty
-                       | isLoc occ   = setConcatMap (rep $ Set.insert occ done) $ 
-                                       findWithErr lfp "repping locals" occ
-                       | otherwise   = Set.singleton occ
-
--- | Add dependencies from a higher order child to all its attributes
-addHigherOrders :: SF_P -> SF_P -> SF_P
-addHigherOrders lfp sfp = 
-   Map.mapWithKey f $ Map.map (setConcatMap (\mo -> f mo (Set.singleton mo))) sfp
-   where f :: MyOccurrence -> Set.Set MyOccurrence -> Set.Set MyOccurrence
-         f mo@(MyOccurrence (p,f) _) deps =
-           let ho = ((p,"inst") >.< (f,AnyDir))
-           in  if ho `Map.member` lfp
-               then ho `Set.insert` deps
-               else deps
++-- | Replace the references to local attributes, by his attrs dependencies,+-- |    rendering the local attributes 'transparent'.+repLocRefs :: SF_P -> SF_P -> SF_P+repLocRefs lfp sfp =+    Map.map (setConcatMap $ rep Set.empty) sfp+    where rep :: Set.Set MyOccurrence -> MyOccurrence -> Set.Set MyOccurrence +          rep done occ | occ `Set.member` done = Set.empty+                       | isLoc occ   = setConcatMap (rep $ Set.insert occ done) $ +                                       findWithErr lfp "repping locals" occ+                       | otherwise   = Set.singleton occ++-- | Add dependencies from a higher order child to all its attributes+addHigherOrders :: SF_P -> SF_P -> SF_P+addHigherOrders lfp sfp = +   Map.mapWithKey f $ Map.map (setConcatMap (\mo -> f mo (Set.singleton mo))) sfp+   where f :: MyOccurrence -> Set.Set MyOccurrence -> Set.Set MyOccurrence+         f mo@(MyOccurrence (p,f) _) deps =+           let ho = ((p,"inst") >.< (f,AnyDir))+           in  if ho `Map.member` lfp+               then ho `Set.insert` deps+               else deps {-# LINE 131 "src-generated/LOAG/Order.hs" #-}  {-# LINE 42 "src-ag/LOAG/Order.ag" #-}-
-fst' (a,_,_) = a
-snd' (_,b,_) = b
-trd' (_,_,c) = c
++fst' (a,_,_) = a+snd' (_,b,_) = b+trd' (_,_,c) = c {-# LINE 138 "src-generated/LOAG/Order.hs" #-}  {-# LINE 95 "src-ag/LOAG/Order.ag" #-}-
-data AltAttr = AltAttr Identifier Identifier Bool
-               deriving (Eq, Ord, Show)
-
-edgeToDep :: PMP -> Edge -> Dependency
-edgeToDep pmp (f,t) = 
-    Dependency (OccAttr (identifier f1) (identifier i1)) 
-               (OccAttr (identifier f2) (identifier i2))
-    where (MyOccurrence (_,f1) (i1,_),MyOccurrence (_,f2) (i2,_))
-            = (findWithErr pmp "edgeToDep" f, 
-               findWithErr pmp "edgeToDep" t) 
-
-ppAds :: Options -> PMP -> [Edge] -> PP_Doc
-ppAds opts pmp = foldr ((>-<) . ppEdge opts pmp) empty
-
-ppEdge :: Options -> PMP -> Edge -> PP_Doc
-ppEdge opts pmp (f,t) = 
-    text sem    >#< text (show ty) >|< " | " >|< text p >|< "   "
-                >|< ppOcc pmp f >|< text " < " >|< ppOcc pmp t
- where (MyOccurrence ((ty,p),_) _) = pmp Map.! f
-       sem | lcKeywords opts = "sem"
-           | otherwise       = "SEM"
-   
-ppOcc :: PMP -> Vertex -> PP_Doc
-ppOcc pmp v = text f >|< text "." >|< fst a
- where (MyOccurrence ((t,p),f) a) = findWithErr pmp "ppOcc" v
-
++data AltAttr = AltAttr Identifier Identifier Bool+               deriving (Eq, Ord, Show)++edgeToDep :: PMP -> Edge -> Dependency+edgeToDep pmp (f,t) = +    Dependency (OccAttr (identifier f1) (identifier i1)) +               (OccAttr (identifier f2) (identifier i2))+    where (MyOccurrence (_,f1) (i1,_),MyOccurrence (_,f2) (i2,_))+            = (findWithErr pmp "edgeToDep" f, +               findWithErr pmp "edgeToDep" t) ++ppAds :: Options -> PMP -> [Edge] -> PP_Doc+ppAds opts pmp = foldr ((>-<) . ppEdge opts pmp) empty++ppEdge :: Options -> PMP -> Edge -> PP_Doc+ppEdge opts pmp (f,t) = +    text sem    >#< text (show ty) >|< " | " >|< text p >|< "   "+                >|< ppOcc pmp f >|< text " < " >|< ppOcc pmp t+ where (MyOccurrence ((ty,p),_) _) = pmp Map.! f+       sem | lcKeywords opts = "sem"+           | otherwise       = "SEM"+   +ppOcc :: PMP -> Vertex -> PP_Doc+ppOcc pmp v = text f >|< text "." >|< fst a+ where (MyOccurrence ((t,p),f) a) = findWithErr pmp "ppOcc" v+ {-# LINE 168 "src-generated/LOAG/Order.hs" #-}  {-# LINE 239 "src-ag/LOAG/Order.ag" #-}-
-getVss (done,intros,rules,vnrs) ps tdp synsO lfp nmpr pmp pmpr fty visMap ruleMap hoMap = do
-    ref   <- newSTRef done
-    introed   <- newSTRef intros
-    ruleref   <- newSTRef rules 
-    vnrsref   <- newSTRef vnrs
-    lists <- forM synsO (visit ref introed ruleref vnrsref . (pmp Map.!))
-    done  <- readSTRef ref
-    intros  <- readSTRef introed
-    rules  <- readSTRef ruleref
-    vnrs  <- readSTRef vnrsref 
-    return (concat lists, (done, intros, rules, vnrs))
- where 
-    hochildren = maybe Set.empty id $ Map.lookup ps hoMap
-    visit ref introed ruleref vnrsref o@(MyOccurrence (_,f) (_,d)) = do
-        visited <- readSTRef ref
-        if (o `Set.member` visited) 
-         then return [] -- already visited
-         else do        -- prevent doubles
-          modifySTRef ref (Set.insert o)
-          if inOutput
-           then do -- has to be calculated in this sequence
-                rest' <- rest
-                locs' <- locs
-                sem'  <- sem o
-                return $ (rest' ++ locs' ++ sem')
-           else if "lhs" == (snd $ argsOf o)
-                 then return [] -- inherited of parent, nothing todo
-                 else do   -- other input occurrence, perform visit
-                    locs' <- locs
-                    rest' <- rest
-                    visit'<- toVisit o
-                    return (rest' ++ locs' ++ visit')
-     where preds  = maybe [] (IS.toList . (tdp A.!)) $ Map.lookup o pmpr
-           rest   = forM preds (visit ref introed ruleref vnrsref. (pmp Map.!)) 
-                        >>= (return . concat)
-           free   = maybe [] (Set.toList) $ Map.lookup o lfp
-           locs   = forM free (visit ref introed ruleref vnrsref)
-                        >>= (return . concat)
-           sem o  = do  rules <- readSTRef ruleref 
-                        if r `Set.member` rules
-                          then return []
-                          else do   writeSTRef ruleref (r `Set.insert` rules) 
-                                    return [Sem r]
-            where r = maybe (error "ruleMap") id $ Map.lookup o ruleMap
-           inOutput = f == "lhs" && d == Syn || f /= "lhs" && d == Inh
-           toVisit o = do
-             vnrs <- readSTRef vnrsref 
-             if (child,visnr) `Set.member` vnrs
-              then return []
-              else writeSTRef vnrsref ((child,visnr) `Set.insert` vnrs) >>
-                   if child `Set.member` hochildren 
-                   then do intros <- readSTRef introed
-                           case child `Set.member` intros of
-                            True    -> return [cvisit]
-                            False   -> do
-                                writeSTRef introed (Set.insert child intros)
-                                let occ = (ps,"inst") >.< (child, AnyDir)
-                                    preds = Set.toList $ setConcatMap rep $ 
-                                                        lfp Map.! occ
-                                    rep :: MyOccurrence -> Set.Set MyOccurrence 
-                                    rep occ | isLoc occ   = Set.insert occ $ 
-                                                setConcatMap rep $ lfp Map.! occ
-                                            | otherwise   = Set.singleton occ
-                                rest <- forM preds 
-                                            (visit ref introed ruleref vnrsref)
-                                sem' <- sem occ
-                                return $ (concat rest) ++
-                                         sem' ++
-                                         [ChildIntro (identifier child)] ++
-                                         [cvisit]
-                   else return [cvisit]
-             where  cvisit= ChildVisit (identifier child) ntid visnr
-                    child = snd $ argsOf o
-                    ntid  = ((\(NT name _ _ )-> name) . fromMyTy) nt 
-                    visnr = (\x-> visMap IMap.! x) (nmpr Map.! (nt <.> attr o))
-                    nt    = fty Map.! (ps,child)
++getVss (done,intros,rules,vnrs) ps tdp synsO lfp nmpr pmp pmpr fty visMap ruleMap hoMap = do+    ref   <- newSTRef done+    introed   <- newSTRef intros+    ruleref   <- newSTRef rules +    vnrsref   <- newSTRef vnrs+    lists <- forM synsO (visit ref introed ruleref vnrsref . (pmp Map.!))+    done  <- readSTRef ref+    intros  <- readSTRef introed+    rules  <- readSTRef ruleref+    vnrs  <- readSTRef vnrsref +    return (concat lists, (done, intros, rules, vnrs))+ where +    hochildren = maybe Set.empty id $ Map.lookup ps hoMap+    visit ref introed ruleref vnrsref o@(MyOccurrence (_,f) (_,d)) = do+        visited <- readSTRef ref+        if (o `Set.member` visited) +         then return [] -- already visited+         else do        -- prevent doubles+          modifySTRef ref (Set.insert o)+          if inOutput+           then do -- has to be calculated in this sequence+                rest' <- rest+                locs' <- locs+                sem'  <- sem o+                return $ (rest' ++ locs' ++ sem')+           else if "lhs" == (snd $ argsOf o)+                 then return [] -- inherited of parent, nothing todo+                 else do   -- other input occurrence, perform visit+                    locs' <- locs+                    rest' <- rest+                    visit'<- toVisit o+                    return (rest' ++ locs' ++ visit')+     where preds  = maybe [] (IS.toList . (tdp A.!)) $ Map.lookup o pmpr+           rest   = forM preds (visit ref introed ruleref vnrsref. (pmp Map.!)) +                        >>= (return . concat)+           free   = maybe [] (Set.toList) $ Map.lookup o lfp+           locs   = forM free (visit ref introed ruleref vnrsref)+                        >>= (return . concat)+           sem o  = do  rules <- readSTRef ruleref +                        if r `Set.member` rules+                          then return []+                          else do   writeSTRef ruleref (r `Set.insert` rules) +                                    return [Sem r]+            where r = maybe (error "ruleMap") id $ Map.lookup o ruleMap+           inOutput = f == "lhs" && d == Syn || f /= "lhs" && d == Inh+           toVisit o = do+             vnrs <- readSTRef vnrsref +             if (child,visnr) `Set.member` vnrs+              then return []+              else writeSTRef vnrsref ((child,visnr) `Set.insert` vnrs) >>+                   if child `Set.member` hochildren +                   then do intros <- readSTRef introed+                           case child `Set.member` intros of+                            True    -> return [cvisit]+                            False   -> do+                                writeSTRef introed (Set.insert child intros)+                                let occ = (ps,"inst") >.< (child, AnyDir)+                                    preds = Set.toList $ setConcatMap rep $ +                                                        lfp Map.! occ+                                    rep :: MyOccurrence -> Set.Set MyOccurrence +                                    rep occ | isLoc occ   = Set.insert occ $ +                                                setConcatMap rep $ lfp Map.! occ+                                            | otherwise   = Set.singleton occ+                                rest <- forM preds +                                            (visit ref introed ruleref vnrsref)+                                sem' <- sem occ+                                return $ (concat rest) +++                                         sem' +++                                         [ChildIntro (identifier child)] +++                                         [cvisit]+                   else return [cvisit]+             where  cvisit= ChildVisit (identifier child) ntid visnr+                    child = snd $ argsOf o+                    ntid  = ((\(NT name _ _ )-> name) . fromMyTy) nt +                    visnr = (\x-> visMap IMap.! x) (nmpr Map.! (nt <.> attr o))+                    nt    = fty Map.! (ps,child) {-# LINE 248 "src-generated/LOAG/Order.hs" #-}  {-# LINE 356 "src-ag/LOAG/Order.ag" #-}-
-repToAg :: LOAGRep -> Grammar -> Ag
-repToAg sem (Grammar _ _ _ _ dats _ _ _ _ _ _ _ _ _) = 
-    Ag bounds_s bounds_p de (map toNt dats)
- where
-    pmp  = (pmp_LOAGRep_LOAGRep  sem)
-    pmpr = (pmpr_LOAGRep_LOAGRep sem)
-    nmp  = (nmp_LOAGRep_LOAGRep  sem)
-    nmpr = (nmpr_LOAGRep_LOAGRep sem)
-    genA = gen_LOAGRep_LOAGRep sem
-    fieldM  = fieldMap_LOAGRep_LOAGRep sem
-    genEdge (f,t) = (gen f, gen t)
-    fsInP  = map2F (fsInP_LOAGRep_LOAGRep sem)
-    siblings (f, t) = ofld A.! f == ofld A.! t
-    ofld = (ofld_LOAGRep_LOAGRep sem)
-    sfp  = map2F' (sfp_LOAGRep_LOAGRep sem)
-    afp  = filter inOutput . ap
-    ap   = map (findWithErr pmpr "building ap") . map2F (ap_LOAGRep_LOAGRep  sem)
-    inss = inss_LOAGRep_LOAGRep sem 
-    gen v = genA A.! v
-    ain  = map (findWithErr nmpr "building an") . map2F (ain_LOAGRep_LOAGRep sem)
-    asn  = map (findWithErr nmpr "building an") . map2F (asn_LOAGRep_LOAGRep sem)
-    inOutput = not . inContext 
-    inContext f = (f1 == "lhs" && d1 == Inh || f1 /= "lhs" && d1 == Syn) 
-        where (MyOccurrence (_,f1) (_,d1)) = pmp Map.! f
-    de    = [ e      | p <- ps,   e <- dpe p ]
-    dpe p = [ (findWithErr pmpr "building dpe" a, b) 
-            | b <- ap p, a <- Set.toList $ sfp (findWithErr pmp "fetching sfp" b) ]
-    ps   = ps_LOAGRep_LOAGRep   sem
-    bounds_p = if Map.null pmp then (0,-1) 
-                else (fst $ Map.findMin pmp, fst $ Map.findMax pmp)
-    bounds_s = if Map.null nmp then (0,-1) 
-                else (fst $ Map.findMin nmp, fst $ Map.findMax nmp)
- 
-
-
-    toNt :: Nonterminal -> Nt
-    toNt (Nonterminal ntid _ _ _ prods) = Nt nt dpf dpt 
-            (addD Inh $ ain ty) (addD Syn $ asn ty) (map (toPr ty) prods)
-     where nt  = getName ntid
-           ty  = TyData nt
-           dpt =  [ (as, ai) | ai <- ain ty
-                   , as <- nub$ [ gen s |
-                                  i <- inss A.! ai
-                                , s <- map (pmpr Map.!) $ 
-                                    Set.toList (sfp $ pmp Map.! i)
-                                , siblings (s,i)]]
-           dpf =  [ (ai, as) | as <- asn ty
-                   , ai <- nub$ [ gen i |
-                                  s <- inss A.! as
-                                , i <- map (pmpr Map.!) $
-                                    Set.toList (sfp $ pmp Map.! s)
-                                , siblings (i,s)]]
-           addD d = map (\i -> (i,inss A.! i,d))
-    toPr :: MyType -> Production -> Pr
-    toPr ty (Production con _ _ _ _ _ _) = 
-                Pr p dpp fc_occs (map toFd $ fsInP p)
-     where p = (ty, getName con)
-           dpp = [ (f',t)
-                    | t <- afp p, f <- (Set.toList $ sfp (pmp Map.! t))
-                    , let f' = pmpr Map.! f
-                    , not (siblings (f',t))]
-           fc_occs = foldl' match [] fss
-            where fss = fsInP p
-           match s fs = [ ready (inp, out) lhs | inp <- Set.toList inhs
-                                           , out <- Set.toList syns] ++ s
-            where ((inhs, syns), lhs)
-                               | (snd fs) /= "lhs" = 
-                                    (swap (fieldM Map.! fs),False)
-                               | otherwise = (fieldM Map.! fs, True)
-                  ready e@(f,t) b = (e', genEdge e', b)
-                   where e' = (pmpr Map.! f, pmpr Map.! t)
-    toFd :: (PLabel, FLabel) -> Fd
-    toFd fs@((TyData ty, pr), fd) = Fd fd ty inhs syns
-     where (is,ss) = fieldM Map.! fs
-           inhs = map (((genA A.!) &&& id).(pmpr Map.!))$ Set.toList is
-           syns = map (((genA A.!) &&& id).(pmpr Map.!))$ Set.toList ss
-
-
++repToAg :: LOAGRep -> Grammar -> Ag+repToAg sem (Grammar _ _ _ _ dats _ _ _ _ _ _ _ _ _) = +    Ag bounds_s bounds_p de (map toNt dats)+ where+    pmp  = (pmp_LOAGRep_LOAGRep  sem)+    pmpr = (pmpr_LOAGRep_LOAGRep sem)+    nmp  = (nmp_LOAGRep_LOAGRep  sem)+    nmpr = (nmpr_LOAGRep_LOAGRep sem)+    genA = gen_LOAGRep_LOAGRep sem+    fieldM  = fieldMap_LOAGRep_LOAGRep sem+    genEdge (f,t) = (gen f, gen t)+    fsInP  = map2F (fsInP_LOAGRep_LOAGRep sem)+    siblings (f, t) = ofld A.! f == ofld A.! t+    ofld = (ofld_LOAGRep_LOAGRep sem)+    sfp  = map2F' (sfp_LOAGRep_LOAGRep sem)+    afp  = filter inOutput . ap+    ap   = map (findWithErr pmpr "building ap") . map2F (ap_LOAGRep_LOAGRep  sem)+    inss = inss_LOAGRep_LOAGRep sem +    gen v = genA A.! v+    ain  = map (findWithErr nmpr "building an") . map2F (ain_LOAGRep_LOAGRep sem)+    asn  = map (findWithErr nmpr "building an") . map2F (asn_LOAGRep_LOAGRep sem)+    inOutput = not . inContext +    inContext f = (f1 == "lhs" && d1 == Inh || f1 /= "lhs" && d1 == Syn) +        where (MyOccurrence (_,f1) (_,d1)) = pmp Map.! f+    de    = [ e      | p <- ps,   e <- dpe p ]+    dpe p = [ (findWithErr pmpr "building dpe" a, b) +            | b <- ap p, a <- Set.toList $ sfp (findWithErr pmp "fetching sfp" b) ]+    ps   = ps_LOAGRep_LOAGRep   sem+    bounds_p = if Map.null pmp then (0,-1) +                else (fst $ Map.findMin pmp, fst $ Map.findMax pmp)+    bounds_s = if Map.null nmp then (0,-1) +                else (fst $ Map.findMin nmp, fst $ Map.findMax nmp)+ +++    toNt :: Nonterminal -> Nt+    toNt (Nonterminal ntid _ _ _ prods) = Nt nt dpf dpt +            (addD Inh $ ain ty) (addD Syn $ asn ty) (map (toPr ty) prods)+     where nt  = getName ntid+           ty  = TyData nt+           dpt =  [ (as, ai) | ai <- ain ty+                   , as <- nub$ [ gen s |+                                  i <- inss A.! ai+                                , s <- map (pmpr Map.!) $ +                                    Set.toList (sfp $ pmp Map.! i)+                                , siblings (s,i)]]+           dpf =  [ (ai, as) | as <- asn ty+                   , ai <- nub$ [ gen i |+                                  s <- inss A.! as+                                , i <- map (pmpr Map.!) $+                                    Set.toList (sfp $ pmp Map.! s)+                                , siblings (i,s)]]+           addD d = map (\i -> (i,inss A.! i,d))+    toPr :: MyType -> Production -> Pr+    toPr ty (Production con _ _ _ _ _ _) = +                Pr p dpp fc_occs (map toFd $ fsInP p)+     where p = (ty, getName con)+           dpp = [ (f',t)+                    | t <- afp p, f <- (Set.toList $ sfp (pmp Map.! t))+                    , let f' = pmpr Map.! f+                    , not (siblings (f',t))]+           fc_occs = foldl' match [] fss+            where fss = fsInP p+           match s fs = [ ready (inp, out) lhs | inp <- Set.toList inhs+                                           , out <- Set.toList syns] ++ s+            where ((inhs, syns), lhs)+                               | (snd fs) /= "lhs" = +                                    (swap (fieldM Map.! fs),False)+                               | otherwise = (fieldM Map.! fs, True)+                  ready e@(f,t) b = (e', genEdge e', b)+                   where e' = (pmpr Map.! f, pmpr Map.! t)+    toFd :: (PLabel, FLabel) -> Fd+    toFd fs@((TyData ty, pr), fd) = Fd fd ty inhs syns+     where (is,ss) = fieldM Map.! fs+           inhs = map (((genA A.!) &&& id).(pmpr Map.!))$ Set.toList is+           syns = map (((genA A.!) &&& id).(pmpr Map.!))$ Set.toList ss++ {-# LINE 330 "src-generated/LOAG/Order.hs" #-} -- CGrammar ---------------------------------------------------- -- wrapper@@ -2964,9 +2964,9 @@  -- MySegment --------------------------------------------------- -- wrapper-data Inh_MySegment  = Inh_MySegment { ain_Inh_MySegment :: (MyType -> MyAttributes), asn_Inh_MySegment :: (MyType -> MyAttributes), done_Inh_MySegment :: ( (Set.Set MyOccurrence, Set.Set FLabel
+data Inh_MySegment  = Inh_MySegment { ain_Inh_MySegment :: (MyType -> MyAttributes), asn_Inh_MySegment :: (MyType -> MyAttributes), done_Inh_MySegment :: ( (Set.Set MyOccurrence, Set.Set FLabel                                                                                                                                                                            , Set.Set Identifier, Set.Set (FLabel,Int))), fty_Inh_MySegment :: (FTY), hoMapf_Inh_MySegment :: (HOMap), lfpf_Inh_MySegment :: (SF_P), nmp_Inh_MySegment :: (NMP), nmprf_Inh_MySegment :: (NMP_R), options_Inh_MySegment :: (Options), pmpf_Inh_MySegment :: (PMP), pmprf_Inh_MySegment :: (PMP_R), ps_Inh_MySegment :: (PLabel), ruleMap_Inh_MySegment :: (Map.Map MyOccurrence Identifier), tdp_Inh_MySegment :: (TDPRes), visMapf_Inh_MySegment :: (IMap.IntMap Int), visitnum_Inh_MySegment :: (Int) }-data Syn_MySegment  = Syn_MySegment { done_Syn_MySegment :: ( (Set.Set MyOccurrence, Set.Set FLabel
+data Syn_MySegment  = Syn_MySegment { done_Syn_MySegment :: ( (Set.Set MyOccurrence, Set.Set FLabel                                                                              ,Set.Set Identifier, Set.Set (FLabel,Int))), evisits_Syn_MySegment :: (Visit), self_Syn_MySegment :: (MySegment), synsO_Syn_MySegment :: ([Int]), visitnum_Syn_MySegment :: (Int), visnr_Syn_MySegment :: (Int) } {-# INLINABLE wrap_MySegment #-} wrap_MySegment :: T_MySegment  -> Inh_MySegment  -> (Syn_MySegment )@@ -2992,9 +2992,9 @@                                            } data T_MySegment_s66  = C_MySegment_s66 type T_MySegment_v64  = (T_MySegment_vIn64 ) -> (T_MySegment_vOut64 )-data T_MySegment_vIn64  = T_MySegment_vIn64 (MyType -> MyAttributes) (MyType -> MyAttributes) ( (Set.Set MyOccurrence, Set.Set FLabel
+data T_MySegment_vIn64  = T_MySegment_vIn64 (MyType -> MyAttributes) (MyType -> MyAttributes) ( (Set.Set MyOccurrence, Set.Set FLabel                                                                                                                , Set.Set Identifier, Set.Set (FLabel,Int))) (FTY) (HOMap) (SF_P) (NMP) (NMP_R) (Options) (PMP) (PMP_R) (PLabel) (Map.Map MyOccurrence Identifier) (TDPRes) (IMap.IntMap Int) (Int)-data T_MySegment_vOut64  = T_MySegment_vOut64 ( (Set.Set MyOccurrence, Set.Set FLabel
+data T_MySegment_vOut64  = T_MySegment_vOut64 ( (Set.Set MyOccurrence, Set.Set FLabel                                                                ,Set.Set Identifier, Set.Set (FLabel,Int))) (Visit) (MySegment) ([Int]) (Int) (Int) {-# NOINLINE sem_MySegment_MySegment #-} sem_MySegment_MySegment :: (Int) -> ([Int]) -> ([Int]) -> (Maybe [Int]) -> (Maybe [Int]) -> T_MySegment @@ -3016,7 +3016,7 @@          _lhsOevisits :: Visit          _lhsOevisits = rule300 _inhs _kind _lhsIvisitnum _steps _syns          _steps = rule301 _lhsIoptions _vss-         _lhsOdone ::  (Set.Set MyOccurrence, Set.Set FLabel
+         _lhsOdone ::  (Set.Set MyOccurrence, Set.Set FLabel                                       ,Set.Set Identifier, Set.Set (FLabel,Int))          (_vss,_lhsOdone) = rule302 _lhsIdone _lhsIfty _lhsIhoMapf _lhsIlfpf _lhsInmprf _lhsIpmpf _lhsIpmprf _lhsIps _lhsIruleMap _lhsItdp _lhsIvisMapf _synsO          _self = rule303 arg_inhAttr_ arg_inhOccs_ arg_synAttr_ arg_synOccs_ arg_visnr_@@ -3086,7 +3086,7 @@                       {-# LINE 3087 "src-generated/LOAG/Order.hs" #-}    {-# INLINE rule302 #-}    {-# LINE 235 "src-ag/LOAG/Order.ag" #-}-   rule302 = \ ((_lhsIdone) ::  (Set.Set MyOccurrence, Set.Set FLabel
+   rule302 = \ ((_lhsIdone) ::  (Set.Set MyOccurrence, Set.Set FLabel                                                , Set.Set Identifier, Set.Set (FLabel,Int))) ((_lhsIfty) :: FTY) ((_lhsIhoMapf) :: HOMap) ((_lhsIlfpf) :: SF_P) ((_lhsInmprf) :: NMP_R) ((_lhsIpmpf) :: PMP) ((_lhsIpmprf) :: PMP_R) ((_lhsIps) :: PLabel) ((_lhsIruleMap) :: Map.Map MyOccurrence Identifier) ((_lhsItdp) :: TDPRes) ((_lhsIvisMapf) :: IMap.IntMap Int) _synsO ->                              {-# LINE 235 "src-ag/LOAG/Order.ag" #-}                              (runST $ getVss _lhsIdone _lhsIps _lhsItdp _synsO@@ -3108,7 +3108,7 @@  -- MySegments -------------------------------------------------- -- wrapper-data Inh_MySegments  = Inh_MySegments { ain_Inh_MySegments :: (MyType -> MyAttributes), asn_Inh_MySegments :: (MyType -> MyAttributes), done_Inh_MySegments :: ( (Set.Set MyOccurrence, Set.Set FLabel
+data Inh_MySegments  = Inh_MySegments { ain_Inh_MySegments :: (MyType -> MyAttributes), asn_Inh_MySegments :: (MyType -> MyAttributes), done_Inh_MySegments :: ( (Set.Set MyOccurrence, Set.Set FLabel                                                                                                                                                                                 , Set.Set Identifier, Set.Set (FLabel,Int))), fty_Inh_MySegments :: (FTY), hoMapf_Inh_MySegments :: (HOMap), lfpf_Inh_MySegments :: (SF_P), nmp_Inh_MySegments :: (NMP), nmprf_Inh_MySegments :: (NMP_R), options_Inh_MySegments :: (Options), pmpf_Inh_MySegments :: (PMP), pmprf_Inh_MySegments :: (PMP_R), ps_Inh_MySegments :: (PLabel), ruleMap_Inh_MySegments :: (Map.Map MyOccurrence Identifier), tdp_Inh_MySegments :: (TDPRes), visMapf_Inh_MySegments :: (IMap.IntMap Int), visitnum_Inh_MySegments :: (Int) } data Syn_MySegments  = Syn_MySegments { evisits_Syn_MySegments :: (Visits), self_Syn_MySegments :: (MySegments), visitnum_Syn_MySegments :: (Int) } {-# INLINABLE wrap_MySegments #-}@@ -3135,7 +3135,7 @@                                              } data T_MySegments_s69  = C_MySegments_s69 type T_MySegments_v67  = (T_MySegments_vIn67 ) -> (T_MySegments_vOut67 )-data T_MySegments_vIn67  = T_MySegments_vIn67 (MyType -> MyAttributes) (MyType -> MyAttributes) ( (Set.Set MyOccurrence, Set.Set FLabel
+data T_MySegments_vIn67  = T_MySegments_vIn67 (MyType -> MyAttributes) (MyType -> MyAttributes) ( (Set.Set MyOccurrence, Set.Set FLabel                                                                                                                  , Set.Set Identifier, Set.Set (FLabel,Int))) (FTY) (HOMap) (SF_P) (NMP) (NMP_R) (Options) (PMP) (PMP_R) (PLabel) (Map.Map MyOccurrence Identifier) (TDPRes) (IMap.IntMap Int) (Int) data T_MySegments_vOut67  = T_MySegments_vOut67 (Visits) (MySegments) (Int) {-# NOINLINE sem_MySegments_Cons #-}@@ -3193,14 +3193,14 @@      in C_MySegments_s68 v67    {-# INLINE rule307 #-}    {-# LINE 220 "src-ag/LOAG/Order.ag" #-}-   rule307 = \ ((_lhsIdone) ::  (Set.Set MyOccurrence, Set.Set FLabel
+   rule307 = \ ((_lhsIdone) ::  (Set.Set MyOccurrence, Set.Set FLabel                                                , Set.Set Identifier, Set.Set (FLabel,Int))) ->                         {-# LINE 220 "src-ag/LOAG/Order.ag" #-}                         _lhsIdone                         {-# LINE 3201 "src-generated/LOAG/Order.hs" #-}    {-# INLINE rule308 #-}    {-# LINE 221 "src-ag/LOAG/Order.ag" #-}-   rule308 = \ ((_hdIdone) ::  (Set.Set MyOccurrence, Set.Set FLabel
+   rule308 = \ ((_hdIdone) ::  (Set.Set MyOccurrence, Set.Set FLabel                                               ,Set.Set Identifier, Set.Set (FLabel,Int))) ->                         {-# LINE 221 "src-ag/LOAG/Order.ag" #-}                         _hdIdone
src-generated/LOAG/Rep.hs view
@@ -2,18 +2,18 @@  -- UUAGC 0.9.53 (src-ag/LOAG/Rep.ag) module LOAG.Rep where-
-import CommonTypes
-import AbstractSyntax
-import LOAG.Common
-import qualified Data.Array as A
-import qualified Data.Map   as Map
-import qualified Data.Set   as Set
 -
-import Data.List (intercalate, foldl', nub)
-import Data.Tuple (swap)
-import Control.Arrow
+import CommonTypes+import AbstractSyntax+import LOAG.Common+import qualified Data.Array as A+import qualified Data.Map   as Map+import qualified Data.Set   as Set+++import Data.List (intercalate, foldl', nub)+import Data.Tuple (swap)+import Control.Arrow -- FieldAtt ---------------------------------------------------- {-    visit 0:
src-generated/Macro.hs view
@@ -3,8 +3,8 @@ -- UUAGC 0.9.53 (src-ag/Macro.ag) module Macro where {-# LINE 4 "src-ag/Macro.ag" #-}-
-import CommonTypes
++import CommonTypes {-# LINE 9 "src-generated/Macro.hs" #-} -- Macro ------------------------------------------------------- {-
src-generated/Order.hs view
@@ -3,228 +3,228 @@  module Order where {-# LINE 2 "src-ag/AbstractSyntax.ag" #-}-
--- AbstractSyntax.ag imports
-import Data.Set(Set)
-import Data.Map(Map)
-import Patterns    (Pattern(..),Patterns)
-import Expression  (Expression(..))
-import Macro --marcos
-import CommonTypes
-import ErrorMessages
++-- AbstractSyntax.ag imports+import Data.Set(Set)+import Data.Map(Map)+import Patterns    (Pattern(..),Patterns)+import Expression  (Expression(..))+import Macro --marcos+import CommonTypes+import ErrorMessages {-# LINE 16 "src-generated/Order.hs" #-}  {-# LINE 2 "src-ag/Expression.ag" #-}-
-import UU.Scanner.Position(Pos)
-import HsToken
++import UU.Scanner.Position(Pos)+import HsToken {-# LINE 22 "src-generated/Order.hs" #-}  {-# LINE 2 "src-ag/Patterns.ag" #-}-
--- Patterns.ag imports
-import UU.Scanner.Position(Pos)
-import CommonTypes (ConstructorIdent,Identifier)
++-- Patterns.ag imports+import UU.Scanner.Position(Pos)+import CommonTypes (ConstructorIdent,Identifier) {-# LINE 29 "src-generated/Order.hs" #-}  {-# LINE 10 "src-ag/Order.ag" #-}-
--- 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 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 Data.Sequence as Seq
-import Data.Map(Map)
-import Data.Set(Set)
-import Data.Sequence(Seq, (><))
-import UU.Util.Utils
-import UU.Scanner.Position(Pos(..),initPos)
-import Data.Foldable(toList)
-
--- 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 Data.Maybe
++-- 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 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 Data.Sequence as Seq+import Data.Map(Map)+import Data.Set(Set)+import Data.Sequence(Seq, (><))+import UU.Util.Utils+import UU.Scanner.Position(Pos(..),initPos)+import Data.Foldable(toList)++-- 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 Data.Maybe {-# LINE 66 "src-generated/Order.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 46 "src-ag/Order.ag" #-}-
--- 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
++-- 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 {-# LINE 79 "src-generated/Order.hs" #-}  {-# LINE 71 "src-ag/Order.ag" #-}-
-startsWith :: String -> String -> Bool
-startsWith k h = k == take (length k) h
++startsWith :: String -> String -> Bool+startsWith k h = k == take (length k) h {-# LINE 85 "src-generated/Order.hs" #-}  {-# LINE 138 "src-ag/Order.ag" #-}-
-getNtName :: Type -> NontermIdent
-getNtName (NT nt _ _) = nt
-getNtName _           = nullIdent
++getNtName :: Type -> NontermIdent+getNtName (NT nt _ _) = nt+getNtName _           = nullIdent {-# LINE 92 "src-generated/Order.hs" #-}  {-# LINE 166 "src-ag/Order.ag" #-}-
-data AltAttr = AltAttr Identifier Identifier Bool
-               deriving (Eq, Ord, Show)
++data AltAttr = AltAttr Identifier Identifier Bool+               deriving (Eq, Ord, Show) {-# LINE 98 "src-generated/Order.hs" #-}  {-# LINE 239 "src-ag/Order.ag" #-}-
-substSelf nt tp
-  = case tp of
-      NT n tps defor | n == _SELF -> NT nt tps defor
-      _                           -> tp
-
-haskellTupel :: [Type] -> Maybe Type
-haskellTupel ts =  Just ( Haskell ( '(' : (concat (intersperse "," (map show ts))) ++ ")" ))
++substSelf nt tp+  = case tp of+      NT n tps defor | n == _SELF -> NT nt tps defor+      _                           -> tp++haskellTupel :: [Type] -> Maybe Type+haskellTupel ts =  Just ( Haskell ( '(' : (concat (intersperse "," (map show ts))) ++ ")" )) {-# LINE 109 "src-generated/Order.hs" #-}  {-# LINE 692 "src-ag/Order.ag" #-}-
-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<n       = xs ++ replicate (n-k) ' '
-            | otherwise = xs
-              where k = length xs
-
-alignR n xs | k<n       = replicate (n-k) ' ' ++ xs
-            | otherwise = xs
-              where k = length xs
-
-localCycleErr :: Table CRule -> 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)
++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<n       = xs ++ replicate (n-k) ' '+            | otherwise = xs+              where k = length xs++alignR n xs | k<n       = replicate (n-k) ' ' ++ xs+            | otherwise = xs+              where k = length xs++localCycleErr :: Table CRule -> 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) {-# LINE 229 "src-generated/Order.hs" #-} -- Child ------------------------------------------------------- -- wrapper
src-generated/Patterns.hs view
@@ -3,10 +3,10 @@ -- UUAGC 0.9.53 (src-ag/Patterns.ag) module Patterns where {-# LINE 2 "src-ag/Patterns.ag" #-}-
--- Patterns.ag imports
-import UU.Scanner.Position(Pos)
-import CommonTypes (ConstructorIdent,Identifier)
++-- Patterns.ag imports+import UU.Scanner.Position(Pos)+import CommonTypes (ConstructorIdent,Identifier) {-# LINE 11 "src-generated/Patterns.hs" #-} -- Pattern ----------------------------------------------------- {-
src-generated/PrintCleanCode.hs view
@@ -4,117 +4,117 @@  module PrintCleanCode where {-# LINE 2 "src-ag/Patterns.ag" #-}-
--- Patterns.ag imports
-import UU.Scanner.Position(Pos)
-import CommonTypes (ConstructorIdent,Identifier)
++-- Patterns.ag imports+import UU.Scanner.Position(Pos)+import CommonTypes (ConstructorIdent,Identifier) {-# LINE 12 "src-generated/PrintCleanCode.hs" #-}  {-# LINE 2 "src-ag/Code.ag" #-}-
-import Patterns
-import Data.Set(Set)
-import qualified Data.Set as Set
-import Data.Map(Map)
-import qualified Data.Map as Map
++import Patterns+import Data.Set(Set)+import qualified Data.Set as Set+import Data.Map(Map)+import qualified Data.Map as Map {-# LINE 21 "src-generated/PrintCleanCode.hs" #-}  {-# LINE 10 "src-ag/PrintCleanCode.ag" #-}-
-import Data.Char (isAlphaNum)
-import Pretty
-import Code
-import Options
-import CommonTypes (attrname, _LOC, nullIdent)
-import Data.List(intersperse)
-import System.IO
-import System.Directory
-import System.FilePath
-import CommonTypes(BlockInfo, BlockKind(..))
++import Data.Char (isAlphaNum)+import Pretty+import Code+import Options+import CommonTypes (attrname, _LOC, nullIdent)+import Data.List(intersperse)+import System.IO+import System.Directory+import System.FilePath+import CommonTypes(BlockInfo, BlockKind(..)) {-# LINE 35 "src-generated/PrintCleanCode.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 146 "src-ag/Code.ag" #-}-
--- 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
++-- 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 {-# LINE 55 "src-generated/PrintCleanCode.hs" #-}  {-# LINE 23 "src-ag/PrintCleanCode.ag" #-}-
-type PP_Docs = [PP_Doc]
++type PP_Docs = [PP_Doc] {-# LINE 60 "src-generated/PrintCleanCode.hs" #-}  {-# LINE 27 "src-ag/PrintCleanCode.ag" #-}-
-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
++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 {-# LINE 73 "src-generated/PrintCleanCode.hs" #-}  {-# LINE 322 "src-ag/PrintCleanCode.ag" #-}-
-
-reallySimple :: String -> Bool
-reallySimple = and . map (\x -> isAlphaNum x || x=='_')
-
-ppTuple :: Bool -> [PP_Doc] -> PP_Doc
-ppTuple _     [x] = pp x
-ppTuple True  pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps
-ppTuple False pps = "(" >|< pp_block " " ")" "," pps
-ppUnboxedTuple :: Bool -> [PP_Doc] -> PP_Doc
-ppUnboxedTuple = ppTuple
---ppUnboxedTuple True pps  = "(# " >|< pp_block " " (concat $ replicate (length pps `max` 1) " #)") ",(# " pps
---ppUnboxedTuple False pps = "(# " >|< pp_block " " " #)" "," pps
-
+++reallySimple :: String -> Bool+reallySimple = and . map (\x -> isAlphaNum x || x=='_')++ppTuple :: Bool -> [PP_Doc] -> PP_Doc+ppTuple _     [x] = pp x+ppTuple True  pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps+ppTuple False pps = "(" >|< pp_block " " ")" "," pps+ppUnboxedTuple :: Bool -> [PP_Doc] -> PP_Doc+ppUnboxedTuple = ppTuple+--ppUnboxedTuple True pps  = "(# " >|< pp_block " " (concat $ replicate (length pps `max` 1) " #)") ",(# " pps+--ppUnboxedTuple False pps = "(# " >|< pp_block " " " #)" "," pps+ {-# LINE 90 "src-generated/PrintCleanCode.hs" #-}  {-# LINE 425 "src-ag/PrintCleanCode.ag" #-}-
-locname' :: Identifier -> [Char]
-locname' n = "_loc_" ++ getName n
++locname' :: Identifier -> [Char]+locname' n = "_loc_" ++ getName n {-# LINE 96 "src-generated/PrintCleanCode.hs" #-}  {-# LINE 500 "src-ag/PrintCleanCode.ag" #-}-
-renderDocs :: [PP_Doc] -> String
-renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) ""
++renderDocs :: [PP_Doc] -> String+renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) "" {-# LINE 102 "src-generated/PrintCleanCode.hs" #-}  {-# LINE 548 "src-ag/PrintCleanCode.ag" #-}-
-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
++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 {-# LINE 119 "src-generated/PrintCleanCode.hs" #-} -- CaseAlt ----------------------------------------------------- -- wrapper
src-generated/PrintCode.hs view
@@ -4,115 +4,115 @@  module PrintCode where {-# LINE 2 "src-ag/Patterns.ag" #-}-
--- Patterns.ag imports
-import UU.Scanner.Position(Pos)
-import CommonTypes (ConstructorIdent,Identifier)
++-- Patterns.ag imports+import UU.Scanner.Position(Pos)+import CommonTypes (ConstructorIdent,Identifier) {-# LINE 12 "src-generated/PrintCode.hs" #-}  {-# LINE 2 "src-ag/Code.ag" #-}-
-import Patterns
-import Data.Set(Set)
-import qualified Data.Set as Set
-import Data.Map(Map)
-import qualified Data.Map as Map
++import Patterns+import Data.Set(Set)+import qualified Data.Set as Set+import Data.Map(Map)+import qualified Data.Map as Map {-# LINE 21 "src-generated/PrintCode.hs" #-}  {-# LINE 10 "src-ag/PrintCode.ag" #-}-
-import Data.Char (isAlphaNum)
-import Pretty
-import Code
-import Options
-import CommonTypes (attrname, _LOC, nullIdent)
-import Data.List(intersperse)
-import System.IO
-import System.Directory
-import System.FilePath
-import CommonTypes(BlockInfo, BlockKind(..))
++import Data.Char (isAlphaNum)+import Pretty+import Code+import Options+import CommonTypes (attrname, _LOC, nullIdent)+import Data.List(intersperse)+import System.IO+import System.Directory+import System.FilePath+import CommonTypes(BlockInfo, BlockKind(..)) {-# LINE 35 "src-generated/PrintCode.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 146 "src-ag/Code.ag" #-}-
--- 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
++-- 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 {-# LINE 55 "src-generated/PrintCode.hs" #-}  {-# LINE 23 "src-ag/PrintCode.ag" #-}-
-type PP_Docs = [PP_Doc]
++type PP_Docs = [PP_Doc] {-# LINE 60 "src-generated/PrintCode.hs" #-}  {-# LINE 27 "src-ag/PrintCode.ag" #-}-
-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
++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 {-# LINE 73 "src-generated/PrintCode.hs" #-}  {-# LINE 303 "src-ag/PrintCode.ag" #-}-
-
-reallySimple :: String -> Bool
-reallySimple = and . map (\x -> isAlphaNum x || x=='_')
-
-ppTuple :: Bool -> [PP_Doc] -> PP_Doc
-ppTuple True  pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps
-ppTuple False pps = "(" >|< pp_block " " ")" "," pps
-ppUnboxedTuple :: Bool -> [PP_Doc] -> PP_Doc
-ppUnboxedTuple True pps  = "(# " >|< pp_block " " (concat $ replicate (length pps `max` 1) " #)") ",(# " pps
-ppUnboxedTuple False pps = "(# " >|< pp_block " " " #)" "," pps
-
+++reallySimple :: String -> Bool+reallySimple = and . map (\x -> isAlphaNum x || x=='_')++ppTuple :: Bool -> [PP_Doc] -> PP_Doc+ppTuple True  pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps+ppTuple False pps = "(" >|< pp_block " " ")" "," pps+ppUnboxedTuple :: Bool -> [PP_Doc] -> PP_Doc+ppUnboxedTuple True pps  = "(# " >|< pp_block " " (concat $ replicate (length pps `max` 1) " #)") ",(# " pps+ppUnboxedTuple False pps = "(# " >|< pp_block " " " #)" "," pps+ {-# LINE 88 "src-generated/PrintCode.hs" #-}  {-# LINE 404 "src-ag/PrintCode.ag" #-}-
-locname' :: Identifier -> [Char]
-locname' n = "_loc_" ++ getName n
++locname' :: Identifier -> [Char]+locname' n = "_loc_" ++ getName n {-# LINE 94 "src-generated/PrintCode.hs" #-}  {-# LINE 479 "src-ag/PrintCode.ag" #-}-
-renderDocs :: [PP_Doc] -> String
-renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) ""
++renderDocs :: [PP_Doc] -> String+renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) "" {-# LINE 100 "src-generated/PrintCode.hs" #-}  {-# LINE 527 "src-ag/PrintCode.ag" #-}-
-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
++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 {-# LINE 117 "src-generated/PrintCode.hs" #-} -- CaseAlt ----------------------------------------------------- -- wrapper
src-generated/PrintErrorMessages.hs view
@@ -3,182 +3,182 @@  module PrintErrorMessages where {-# LINE 2 "src-ag/ErrorMessages.ag" #-}-
-import UU.Scanner.Position(Pos)
-import Pretty
-import CodeSyntax
-import CommonTypes
++import UU.Scanner.Position(Pos)+import Pretty+import CodeSyntax+import CommonTypes {-# LINE 12 "src-generated/PrintErrorMessages.hs" #-}  {-# LINE 4 "src-ag/PrintErrorMessages.ag" #-}-
-import UU.Scanner.Position(Pos(..), noPos)
-import ErrorMessages
-import Data.List(mapAccumL)
-import GrammarInfo
-import qualified Control.Monad.Error.Class as Err
++import UU.Scanner.Position(Pos(..), noPos)+import ErrorMessages+import Data.List(mapAccumL)+import GrammarInfo+import qualified Control.Monad.Error.Class as Err {-# LINE 21 "src-generated/PrintErrorMessages.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 13 "src-ag/PrintErrorMessages.ag" #-}-
-instance Err.Error Error where
-  noMsg  = Err.strMsg "error"
-  strMsg = CustomError False noPos . pp
++instance Err.Error Error where+  noMsg  = Err.strMsg "error"+  strMsg = CustomError False noPos . pp {-# LINE 29 "src-generated/PrintErrorMessages.hs" #-}  {-# LINE 20 "src-ag/PrintErrorMessages.ag" #-}-
-isError :: Options -> 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          _ _ _    ) = False
-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 opts (LocalCirc       _ _ _ _ _) = cycleIsDangerous opts
-isError opts (InstCirc        _ _ _ _ _) = cycleIsDangerous opts
-isError opts (DirectCirc      _ _ _    ) = cycleIsDangerous opts
-isError opts (InducedCirc     _ _ _    ) = cycleIsDangerous opts
-isError _ (MissingTypeSig  _ _ _    ) = False
-isError _ (MissingInstSig  _ _ _    ) = True
-isError _ (DupUnique       _ _ _    ) = False
-isError _ (MissingUnique   _ _      ) = True
-isError _ (MissingSyn      _ _      ) = True
-isError _ (MissingNamedRule _ _ _)    = True
-isError _ (DupRuleName _ _ _)         = True
-isError _ (HsParseError _ _)          = True
-isError _ (Cyclic _ _ _)              = True
-isError _ (IncompatibleVisitKind _ _ _ _) = True
-isError _ (IncompatibleRuleKind _ _)      = True
-isError _ (IncompatibleAttachKind _ _)    = True
-
-cycleIsDangerous :: Options -> Bool
-cycleIsDangerous opts
-  = any ($ opts) [ wignore, bangpats, cases, strictCases, stricterCases, strictSems, withCycle ]
++isError :: Options -> 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          _ _ _    ) = False+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 opts (LocalCirc       _ _ _ _ _) = cycleIsDangerous opts+isError opts (InstCirc        _ _ _ _ _) = cycleIsDangerous opts+isError opts (DirectCirc      _ _ _    ) = cycleIsDangerous opts+isError opts (InducedCirc     _ _ _    ) = cycleIsDangerous opts+isError _ (MissingTypeSig  _ _ _    ) = False+isError _ (MissingInstSig  _ _ _    ) = True+isError _ (DupUnique       _ _ _    ) = False+isError _ (MissingUnique   _ _      ) = True+isError _ (MissingSyn      _ _      ) = True+isError _ (MissingNamedRule _ _ _)    = True+isError _ (DupRuleName _ _ _)         = True+isError _ (HsParseError _ _)          = True+isError _ (Cyclic _ _ _)              = True+isError _ (IncompatibleVisitKind _ _ _ _) = True+isError _ (IncompatibleRuleKind _ _)      = True+isError _ (IncompatibleAttachKind _ _)    = True++cycleIsDangerous :: Options -> Bool+cycleIsDangerous opts+  = any ($ opts) [ wignore, bangpats, cases, strictCases, stricterCases, strictSems, withCycle ] {-# LINE 73 "src-generated/PrintErrorMessages.hs" #-}  {-# LINE 548 "src-ag/PrintErrorMessages.ag" #-}-
-toWidth :: Int -> String -> String
-toWidth n xs | k<n       = xs ++ replicate (n-k) ' '
-             | otherwise = xs
-               where k = length xs
-
-showEdge :: ((Identifier,Identifier),[String],[String]) -> PP_Doc
-showEdge ((inh,syn),_,_)
-  = text ("inherited attribute " ++ toWidth 20 (getName inh) ++ " with synthesized attribute " ++  getName syn)
-
-showEdgeLong :: ((Identifier,Identifier),[String],[String]) -> PP_Doc
-showEdgeLong ((inh,syn),path1,path2)
-  = text ("inherited attribute " ++ getName inh ++ " is needed for " ++  "synthesized attribute " ++ getName syn)
-    >-< indent 4 (vlist (map text path2))
-    >-< text "and back: "
-    >-< indent 4 (vlist (map text path1))
-
-attrText :: Identifier -> Identifier -> String
-attrText inh syn
- =  if   inh == syn
-    then "threaded attribute " ++ getName inh
-    else "inherited attribute " ++ getName inh ++ " and synthesized attribute " ++getName syn
-
-showLineNr :: Int -> String
-showLineNr i | i==(-1) = "CR"
-             | otherwise = show i
-
-showAttrDef :: Identifier -> Identifier -> String
-showAttrDef f a | f == _LHS  = "synthesized attribute " ++ getName a
-                | f == _LOC  = "local attribute " ++ getName a
-                | f == _INST = "inst attribute " ++ getName a
-                | otherwise  = "inherited attribute " ++ getName a ++ " of field " ++ getName f
-
-showAttrUse :: Identifier -> Identifier -> String
-showAttrUse f a | f == _LHS  = "inherited attribute " ++ getName a
-                | f == _LOC  = "local attribute " ++ getName a
-                | f == _INST = "inst attribute " ++ getName a
-                | otherwise  = "synthesized attribute " ++ getName a ++ " of field " ++ getName f
-
-ppAttr :: Identifier -> Identifier -> PP_Doc
-ppAttr f a = text (getName f++"."++getName a)
-ppAttrUse :: Identifier -> Identifier -> PP_Doc
-ppAttrUse f a = "@" >|< ppAttr f a
++toWidth :: Int -> String -> String+toWidth n xs | k<n       = xs ++ replicate (n-k) ' '+             | otherwise = xs+               where k = length xs++showEdge :: ((Identifier,Identifier),[String],[String]) -> PP_Doc+showEdge ((inh,syn),_,_)+  = text ("inherited attribute " ++ toWidth 20 (getName inh) ++ " with synthesized attribute " ++  getName syn)++showEdgeLong :: ((Identifier,Identifier),[String],[String]) -> PP_Doc+showEdgeLong ((inh,syn),path1,path2)+  = text ("inherited attribute " ++ getName inh ++ " is needed for " ++  "synthesized attribute " ++ getName syn)+    >-< indent 4 (vlist (map text path2))+    >-< text "and back: "+    >-< indent 4 (vlist (map text path1))++attrText :: Identifier -> Identifier -> String+attrText inh syn+ =  if   inh == syn+    then "threaded attribute " ++ getName inh+    else "inherited attribute " ++ getName inh ++ " and synthesized attribute " ++getName syn++showLineNr :: Int -> String+showLineNr i | i==(-1) = "CR"+             | otherwise = show i++showAttrDef :: Identifier -> Identifier -> String+showAttrDef f a | f == _LHS  = "synthesized attribute " ++ getName a+                | f == _LOC  = "local attribute " ++ getName a+                | f == _INST = "inst attribute " ++ getName a+                | otherwise  = "inherited attribute " ++ getName a ++ " of field " ++ getName f++showAttrUse :: Identifier -> Identifier -> String+showAttrUse f a | f == _LHS  = "inherited attribute " ++ getName a+                | f == _LOC  = "local attribute " ++ getName a+                | f == _INST = "inst attribute " ++ getName a+                | otherwise  = "synthesized attribute " ++ getName a ++ " of field " ++ getName f++ppAttr :: Identifier -> Identifier -> PP_Doc+ppAttr f a = text (getName f++"."++getName a)+ppAttrUse :: Identifier -> Identifier -> PP_Doc+ppAttrUse f a = "@" >|< ppAttr f a {-# LINE 119 "src-generated/PrintErrorMessages.hs" #-}  {-# LINE 594 "src-ag/PrintErrorMessages.ag" #-}-
-infixr 5 +#+
-(+#+) :: String -> String -> String
-(+#+) s t = s ++ " " ++ t
-
-infixr 5 +.+
-(+.+) :: Identifier -> Identifier -> String
-(+.+) s t = getName s ++ "." ++ getName t
-
-wfill :: [String] -> PP_Doc
-wfill = fill . addSpaces. concat . map words
-  where addSpaces (x:xs) = x:map addSpace xs
-        addSpaces []     = []
-        addSpace  [x]    | x `elem` ".,;:!?" = [x]
-        addSpace  xs     = ' ':xs
-
-ppError :: Bool           -- class of the error, True:error False:warning
-        -> Pos      -- source position
-        -> PP_Doc         -- error message
-        -> PP_Doc         -- pattern
-        -> PP_Doc         -- help, more info
-        -> PP_Doc         -- action taken by AG
-        -> Bool           -- verbose? show help and action?
-        -> PP_Doc
-ppError isErr pos mesg pat hlp act verb
-  = let position = case pos of
-                     Pos l c f | l >= 0    -> f >|< ":" >|< show l >|< ":" >|< show c
-                               | otherwise -> pp "uuagc"
-        tp      = if isErr then "error" else "warning"
-        header  = position >|< ":" >#< tp >|< ":" >#< mesg
-        pattern = "pattern  :" >#< pat
-        help    = "help     :" >#< hlp
-        action  = "action   :" >#< act
-    in if verb
-         then vlist [text "",header,pattern,help,action]
-         else header
-
-{-
--- old error reporting code
-  = let
-      cl = if isError then "ERROR" else "Warning"
-      position   = case pos of
-                         (Pos l c f) | l >= 0    -> f >|< ": line " >|< show l >|< ", column " >|< show c
-                                     | otherwise -> empty
-      header     = "*** UU.AG" >#< cl >#< position >#< "***"
-      message    = "problem  :" >#< mesg
-      pattern    = "pattern  :" >#< pat
-      help       = "help     :" >#< hlp
-      action     = "action   :" >#< act
-    in
-      if verbose
-         then vlist [text "",header,message,pattern,help,action]
-         else vlist [text "",header,message]
--}
-
-showPos :: Identifier -> String
-showPos = show . getPos
-
-ppInterface :: Show a => a -> PP_Doc
-ppInterface inter = wfill ["interface:", show inter]
-
++infixr 5 +#++(+#+) :: String -> String -> String+(+#+) s t = s ++ " " ++ t++infixr 5 +.++(+.+) :: Identifier -> Identifier -> String+(+.+) s t = getName s ++ "." ++ getName t++wfill :: [String] -> PP_Doc+wfill = fill . addSpaces. concat . map words+  where addSpaces (x:xs) = x:map addSpace xs+        addSpaces []     = []+        addSpace  [x]    | x `elem` ".,;:!?" = [x]+        addSpace  xs     = ' ':xs++ppError :: Bool           -- class of the error, True:error False:warning+        -> Pos      -- source position+        -> PP_Doc         -- error message+        -> PP_Doc         -- pattern+        -> PP_Doc         -- help, more info+        -> PP_Doc         -- action taken by AG+        -> Bool           -- verbose? show help and action?+        -> PP_Doc+ppError isErr pos mesg pat hlp act verb+  = let position = case pos of+                     Pos l c f | l >= 0    -> f >|< ":" >|< show l >|< ":" >|< show c+                               | otherwise -> pp "uuagc"+        tp      = if isErr then "error" else "warning"+        header  = position >|< ":" >#< tp >|< ":" >#< mesg+        pattern = "pattern  :" >#< pat+        help    = "help     :" >#< hlp+        action  = "action   :" >#< act+    in if verb+         then vlist [text "",header,pattern,help,action]+         else header++{-+-- old error reporting code+  = let+      cl = if isError then "ERROR" else "Warning"+      position   = case pos of+                         (Pos l c f) | l >= 0    -> f >|< ": line " >|< show l >|< ", column " >|< show c+                                     | otherwise -> empty+      header     = "*** UU.AG" >#< cl >#< position >#< "***"+      message    = "problem  :" >#< mesg+      pattern    = "pattern  :" >#< pat+      help       = "help     :" >#< hlp+      action     = "action   :" >#< act+    in+      if verbose+         then vlist [text "",header,message,pattern,help,action]+         else vlist [text "",header,message]+-}++showPos :: Identifier -> String+showPos = show . getPos++ppInterface :: Show a => a -> PP_Doc+ppInterface inter = wfill ["interface:", show inter]+ {-# LINE 183 "src-generated/PrintErrorMessages.hs" #-} -- Error ------------------------------------------------------- -- wrapper
src-generated/PrintOcamlCode.hs view
@@ -4,76 +4,76 @@  module PrintOcamlCode where {-# LINE 2 "src-ag/Patterns.ag" #-}-
--- Patterns.ag imports
-import UU.Scanner.Position(Pos)
-import CommonTypes (ConstructorIdent,Identifier)
++-- Patterns.ag imports+import UU.Scanner.Position(Pos)+import CommonTypes (ConstructorIdent,Identifier) {-# LINE 12 "src-generated/PrintOcamlCode.hs" #-}  {-# LINE 2 "src-ag/Code.ag" #-}-
-import Patterns
-import Data.Set(Set)
-import qualified Data.Set as Set
-import Data.Map(Map)
-import qualified Data.Map as Map
++import Patterns+import Data.Set(Set)+import qualified Data.Set as Set+import Data.Map(Map)+import qualified Data.Map as Map {-# LINE 21 "src-generated/PrintOcamlCode.hs" #-}  {-# LINE 10 "src-ag/PrintOcamlCode.ag" #-}-
-import Pretty
-import Code
-import Patterns
-import Options
-import CommonTypes hiding (List,Type,Map,Maybe,IntMap,Either)
-import Data.List(intersperse,intercalate)
-import Data.Char(toLower)
++import Pretty+import Code+import Patterns+import Options+import CommonTypes hiding (List,Type,Map,Maybe,IntMap,Either)+import Data.List(intersperse,intercalate)+import Data.Char(toLower) {-# LINE 32 "src-generated/PrintOcamlCode.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 146 "src-ag/Code.ag" #-}-
--- 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
++-- 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 {-# LINE 52 "src-generated/PrintOcamlCode.hs" #-}  {-# LINE 21 "src-ag/PrintOcamlCode.ag" #-}-
-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
-
-ppTuple :: Bool -> [PP_Doc] -> PP_Doc
-ppTuple True  pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps
-ppTuple False pps = "(" >|< pp_block " " ")" "," pps
++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++ppTuple :: Bool -> [PP_Doc] -> PP_Doc+ppTuple True  pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps+ppTuple False pps = "(" >|< pp_block " " ")" "," pps {-# LINE 71 "src-generated/PrintOcamlCode.hs" #-}  {-# LINE 177 "src-ag/PrintOcamlCode.ag" #-}-
-toOcamlTC :: String -> String
-toOcamlTC (c:cs) = toLower c : cs
-toOcamlTC xs = xs
++toOcamlTC :: String -> String+toOcamlTC (c:cs) = toLower c : cs+toOcamlTC xs = xs {-# LINE 78 "src-generated/PrintOcamlCode.hs" #-} -- CaseAlt ----------------------------------------------------- -- wrapper
src-generated/PrintVisitCode.hs view
@@ -3,62 +3,62 @@  module PrintVisitCode where {-# LINE 2 "src-ag/DeclBlocks.ag" #-}-
-import Code (Decl,Expr)
++import Code (Decl,Expr) {-# LINE 9 "src-generated/PrintVisitCode.hs" #-}  {-# LINE 2 "src-ag/Patterns.ag" #-}-
--- Patterns.ag imports
-import UU.Scanner.Position(Pos)
-import CommonTypes (ConstructorIdent,Identifier)
++-- Patterns.ag imports+import UU.Scanner.Position(Pos)+import CommonTypes (ConstructorIdent,Identifier) {-# LINE 16 "src-generated/PrintVisitCode.hs" #-}  {-# LINE 2 "src-ag/CodeSyntax.ag" #-}-
-import Patterns
-import CommonTypes
-import Data.Map(Map)
-import Data.Set(Set)
++import Patterns+import CommonTypes+import Data.Map(Map)+import Data.Set(Set) {-# LINE 24 "src-generated/PrintVisitCode.hs" #-}  {-# LINE 10 "src-ag/PrintVisitCode.ag" #-}-
-import CommonTypes
-import SequentialTypes
-import Options
-import CodeSyntax
-import ErrorMessages
-import GrammarInfo
-import DeclBlocks
-import Pretty
-
-import qualified Data.Map as Map
-import Data.Map(Map)
-import qualified Data.Set as Set
-import Data.Set(Set)
-import qualified Data.Sequence as Seq
-import Data.Sequence(Seq)
-import UU.Scanner.Position
-
-import Data.List(partition,intersperse,intersect,(\\))
-import Data.Maybe(fromJust,isJust)
++import CommonTypes+import SequentialTypes+import Options+import CodeSyntax+import ErrorMessages+import GrammarInfo+import DeclBlocks+import Pretty++import qualified Data.Map as Map+import Data.Map(Map)+import qualified Data.Set as Set+import Data.Set(Set)+import qualified Data.Sequence as Seq+import Data.Sequence(Seq)+import UU.Scanner.Position++import Data.List(partition,intersperse,intersect,(\\))+import Data.Maybe(fromJust,isJust) {-# LINE 47 "src-generated/PrintVisitCode.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 32 "src-ag/PrintVisitCode.ag" #-}-
-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
++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 {-# LINE 63 "src-generated/PrintVisitCode.hs" #-} -- CGrammar ---------------------------------------------------- -- wrapper
src-generated/ResolveLocals.hs view
@@ -3,46 +3,46 @@  module ResolveLocals where {-# LINE 2 "src-ag/Expression.ag" #-}-
-import UU.Scanner.Position(Pos)
-import HsToken
++import UU.Scanner.Position(Pos)+import HsToken {-# LINE 10 "src-generated/ResolveLocals.hs" #-}  {-# LINE 2 "src-ag/Patterns.ag" #-}-
--- Patterns.ag imports
-import UU.Scanner.Position(Pos)
-import CommonTypes (ConstructorIdent,Identifier)
++-- Patterns.ag imports+import UU.Scanner.Position(Pos)+import CommonTypes (ConstructorIdent,Identifier) {-# LINE 17 "src-generated/ResolveLocals.hs" #-}  {-# LINE 2 "src-ag/AbstractSyntax.ag" #-}-
--- AbstractSyntax.ag imports
-import Data.Set(Set)
-import Data.Map(Map)
-import Patterns    (Pattern(..),Patterns)
-import Expression  (Expression(..))
-import Macro --marcos
-import CommonTypes
-import ErrorMessages
++-- AbstractSyntax.ag imports+import Data.Set(Set)+import Data.Map(Map)+import Patterns    (Pattern(..),Patterns)+import Expression  (Expression(..))+import Macro --marcos+import CommonTypes+import ErrorMessages {-# LINE 29 "src-generated/ResolveLocals.hs" #-}  {-# LINE 15 "src-ag/ResolveLocals.ag" #-}-
-import qualified Data.Set as Set
-import qualified Data.Map as Map
-import Data.Map(Map)
-import qualified Data.Sequence as Seq
-import Data.Sequence(Seq,(><))
-import CommonTypes
-import Patterns
-import ErrorMessages
-import AbstractSyntax
-import Expression
-import Options
-import HsToken(HsTokensRoot(HsTokensRoot))
-import SemHsTokens(sem_HsTokensRoot,wrap_HsTokensRoot, Syn_HsTokensRoot(..),Inh_HsTokensRoot(..))
-import Data.Maybe
++import qualified Data.Set as Set+import qualified Data.Map as Map+import Data.Map(Map)+import qualified Data.Sequence as Seq+import Data.Sequence(Seq,(><))+import CommonTypes+import Patterns+import ErrorMessages+import AbstractSyntax+import Expression+import Options+import HsToken(HsTokensRoot(HsTokensRoot))+import SemHsTokens(sem_HsTokensRoot,wrap_HsTokensRoot, Syn_HsTokensRoot(..),Inh_HsTokensRoot(..))+import Data.Maybe {-# LINE 47 "src-generated/ResolveLocals.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity
src-generated/SemHsTokens.hs view
@@ -3,28 +3,28 @@  module SemHsTokens where {-# LINE 2 "src-ag/HsToken.ag" #-}-
-import CommonTypes
-import UU.Scanner.Position(Pos)
++import CommonTypes+import UU.Scanner.Position(Pos) {-# LINE 10 "src-generated/SemHsTokens.hs" #-}  {-# LINE 4 "src-ag/SemHsTokens.ag" #-}-
-import qualified Data.Sequence as Seq
-import Data.Sequence(Seq,empty,singleton,(><))
-import Data.Foldable(toList)
-import Pretty
-
-import TokenDef
-import HsToken
-import ErrorMessages
++import qualified Data.Sequence as Seq+import Data.Sequence(Seq,empty,singleton,(><))+import Data.Foldable(toList)+import Pretty++import TokenDef+import HsToken+import ErrorMessages {-# LINE 22 "src-generated/SemHsTokens.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 58 "src-ag/SemHsTokens.ag" #-}-
-isNTname allnts (Just (NT nt _ _)) = nt `elem` allnts
-isNTname allnts _                  = False
++isNTname allnts (Just (NT nt _ _)) = nt `elem` allnts+isNTname allnts _                  = False {-# LINE 29 "src-generated/SemHsTokens.hs" #-} -- HsToken ----------------------------------------------------- -- wrapper
+ src-generated/TfmToMirage.hs view
@@ -0,0 +1,4130 @@+{-# LANGUAGE Rank2Types, GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}++module TfmToMirage where+{-# LINE 2 "src-ag/Patterns.ag" #-}++-- Patterns.ag imports+import UU.Scanner.Position(Pos)+import CommonTypes (ConstructorIdent,Identifier)+{-# LINE 11 "src-generated/TfmToMirage.hs" #-}++{-# LINE 10 "src-ag/Order.ag" #-}++-- 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 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 Data.Sequence as Seq+import Data.Map(Map)+import Data.Set(Set)+import Data.Sequence(Seq, (><))+import UU.Util.Utils+import UU.Scanner.Position(Pos(..),initPos)+import Data.Foldable(toList)++-- 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 Data.Maybe+{-# LINE 48 "src-generated/TfmToMirage.hs" #-}++{-# LINE 2 "src-ag/Expression.ag" #-}++import UU.Scanner.Position(Pos)+import HsToken+{-# LINE 54 "src-generated/TfmToMirage.hs" #-}++{-# LINE 2 "src-ag/AbstractSyntax.ag" #-}++-- AbstractSyntax.ag imports+import Data.Set(Set)+import Data.Map(Map)+import Patterns    (Pattern(..),Patterns)+import Expression  (Expression(..))+import Macro --marcos+import CommonTypes+import ErrorMessages+{-# LINE 66 "src-generated/TfmToMirage.hs" #-}++{-# LINE 5 "src-ag/TfmToMirage.ag" #-}++import AbstractSyntax+import qualified Data.Map as Map+import Pretty+import TokenDef+import qualified MirageSyntax as Mirage+{-# LINE 75 "src-generated/TfmToMirage.hs" #-}+import Control.Monad.Identity (Identity)+import qualified Control.Monad.Identity+{-# LINE 46 "src-ag/Order.ag" #-}++-- 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+{-# LINE 88 "src-generated/TfmToMirage.hs" #-}++{-# LINE 71 "src-ag/Order.ag" #-}++startsWith :: String -> String -> Bool+startsWith k h = k == take (length k) h+{-# LINE 94 "src-generated/TfmToMirage.hs" #-}++{-# LINE 138 "src-ag/Order.ag" #-}++getNtName :: Type -> NontermIdent+getNtName (NT nt _ _) = nt+getNtName _           = nullIdent+{-# LINE 101 "src-generated/TfmToMirage.hs" #-}++{-# LINE 166 "src-ag/Order.ag" #-}++data AltAttr = AltAttr Identifier Identifier Bool+               deriving (Eq, Ord, Show)+{-# LINE 107 "src-generated/TfmToMirage.hs" #-}++{-# LINE 239 "src-ag/Order.ag" #-}++substSelf nt tp+  = case tp of+      NT n tps defor | n == _SELF -> NT nt tps defor+      _                           -> tp++haskellTupel :: [Type] -> Maybe Type+haskellTupel ts =  Just ( Haskell ( '(' : (concat (intersperse "," (map show ts))) ++ ")" ))+{-# LINE 118 "src-generated/TfmToMirage.hs" #-}++{-# LINE 692 "src-ag/Order.ag" #-}++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<n       = xs ++ replicate (n-k) ' '+            | otherwise = xs+              where k = length xs++alignR n xs | k<n       = replicate (n-k) ' ' ++ xs+            | otherwise = xs+              where k = length xs++localCycleErr :: Table CRule -> 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)+{-# LINE 238 "src-generated/TfmToMirage.hs" #-}++{-# LINE 13 "src-ag/TfmToMirage.ag" #-}++typeToMirage :: Type -> Mirage.Type+typeToMirage x = case x of+  Haskell y -> Mirage.Haskell y+  NT y ys _ -> Mirage.NT (getName y) ys+  Self      -> Mirage.Self+{-# LINE 247 "src-generated/TfmToMirage.hs" #-}+-- Child -------------------------------------------------------+-- wrapper+data Inh_Child  = Inh_Child { allfields_Inh_Child :: ([(Identifier,Type,ChildKind)]), allnts_Inh_Child :: ([Identifier]), attrs_Inh_Child :: ([(Identifier,Identifier)]), con_Inh_Child :: (Identifier), inh_Inh_Child :: (Attributes), inhMap_Inh_Child :: (Map Identifier Attributes), mergeMap_Inh_Child :: (Map Identifier (Identifier,[Identifier])), nt_Inh_Child :: (Identifier), o_unbox_Inh_Child :: (Bool), syn_Inh_Child :: (Attributes), synMap_Inh_Child :: (Map Identifier Attributes) }+data Syn_Child  = Syn_Child { attributes_Syn_Child :: ([(Identifier,Attributes,Attributes)]), collectChildrenInhs_Syn_Child :: (Map Identifier Attributes ), collectChildrenSyns_Syn_Child :: (Map Identifier Attributes ), errors_Syn_Child :: (Seq Error), field_Syn_Child :: ((Identifier,Type,ChildKind)), gathAltAttrs_Syn_Child :: ([AltAttr]), gathRules_Syn_Child :: (Seq CRule), inhs_Syn_Child :: (Seq (Identifier,Attributes)), mirage_Syn_Child :: (Mirage.Child), nts_Syn_Child :: (Seq (Identifier,NontermIdent)), singlevisits_Syn_Child :: ([CRule]), terminals_Syn_Child :: ([Identifier]) }+{-# INLINABLE wrap_Child #-}+wrap_Child :: T_Child  -> Inh_Child  -> (Syn_Child )+wrap_Child (T_Child act) (Inh_Child _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIo_unbox _lhsIsyn _lhsIsynMap) =+   Control.Monad.Identity.runIdentity (+     do sem <- act+        let arg1 = T_Child_vIn1 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIo_unbox _lhsIsyn _lhsIsynMap+        (T_Child_vOut1 _lhsOattributes _lhsOcollectChildrenInhs _lhsOcollectChildrenSyns _lhsOerrors _lhsOfield _lhsOgathAltAttrs _lhsOgathRules _lhsOinhs _lhsOmirage _lhsOnts _lhsOsinglevisits _lhsOterminals) <- return (inv_Child_s2 sem arg1)+        return (Syn_Child _lhsOattributes _lhsOcollectChildrenInhs _lhsOcollectChildrenSyns _lhsOerrors _lhsOfield _lhsOgathAltAttrs _lhsOgathRules _lhsOinhs _lhsOmirage _lhsOnts _lhsOsinglevisits _lhsOterminals)+   )++-- cata+{-# INLINE sem_Child #-}+sem_Child :: Child  -> T_Child +sem_Child ( Child name_ tp_ kind_ ) = sem_Child_Child name_ tp_ kind_++-- semantic domain+newtype T_Child  = T_Child {+                           attach_T_Child :: Identity (T_Child_s2 )+                           }+newtype T_Child_s2  = C_Child_s2 {+                                 inv_Child_s2 :: (T_Child_v1 )+                                 }+data T_Child_s3  = C_Child_s3+type T_Child_v1  = (T_Child_vIn1 ) -> (T_Child_vOut1 )+data T_Child_vIn1  = T_Child_vIn1 ([(Identifier,Type,ChildKind)]) ([Identifier]) ([(Identifier,Identifier)]) (Identifier) (Attributes) (Map Identifier Attributes) (Map Identifier (Identifier,[Identifier])) (Identifier) (Bool) (Attributes) (Map Identifier Attributes)+data T_Child_vOut1  = T_Child_vOut1 ([(Identifier,Attributes,Attributes)]) (Map Identifier Attributes ) (Map Identifier Attributes ) (Seq Error) ((Identifier,Type,ChildKind)) ([AltAttr]) (Seq CRule) (Seq (Identifier,Attributes)) (Mirage.Child) (Seq (Identifier,NontermIdent)) ([CRule]) ([Identifier])+{-# NOINLINE sem_Child_Child #-}+sem_Child_Child :: (Identifier) -> (Type) -> (ChildKind) -> T_Child +sem_Child_Child arg_name_ arg_tp_ arg_kind_ = T_Child (return st2) where+   {-# NOINLINE st2 #-}+   st2 = let+      v1 :: T_Child_v1 +      v1 = \ (T_Child_vIn1 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIo_unbox _lhsIsyn _lhsIsynMap) -> ( let+         _chnt = rule0 arg_name_ arg_tp_+         _inh = rule1 _chnt _lhsIinhMap+         _syn = rule2 _chnt _lhsIsynMap+         _maptolocal = rule3 _syn arg_tp_+         _lhsOgathAltAttrs :: [AltAttr]+         _lhsOgathAltAttrs = rule4 _maptolocal _syn arg_name_+         _lhsOnts :: Seq (Identifier,NontermIdent)+         _lhsOnts = rule5 arg_name_ arg_tp_+         _lhsOinhs :: Seq (Identifier,Attributes)+         _lhsOinhs = rule6 _inh arg_name_+         _gathRules = rule7 _lhsIcon _lhsInt _maptolocal _syn arg_name_ arg_tp_+         _lhsOcollectChildrenSyns :: Map Identifier Attributes +         _lhsOcollectChildrenSyns = rule8 _syn arg_name_+         _lhsOcollectChildrenInhs :: Map Identifier Attributes +         _lhsOcollectChildrenInhs = rule9 _inh arg_name_+         _lhsOsinglevisits :: [CRule]+         _lhsOsinglevisits = rule10 _inh _maptolocal _syn arg_name_ arg_tp_+         _lhsOterminals :: [Identifier]+         _lhsOterminals = rule11 _maptolocal arg_name_+         _lhsOattributes :: [(Identifier,Attributes,Attributes)]+         _lhsOattributes = rule12 _inh _syn arg_name_+         _lhsOfield :: (Identifier,Type,ChildKind)+         _lhsOfield = rule13 arg_kind_ arg_name_ arg_tp_+         _lhsOmirage :: Mirage.Child+         _lhsOmirage = rule14 arg_name_ arg_tp_+         _lhsOerrors :: Seq Error+         _lhsOerrors = rule15  ()+         _lhsOgathRules :: Seq CRule+         _lhsOgathRules = rule16 _gathRules+         __result_ = T_Child_vOut1 _lhsOattributes _lhsOcollectChildrenInhs _lhsOcollectChildrenSyns _lhsOerrors _lhsOfield _lhsOgathAltAttrs _lhsOgathRules _lhsOinhs _lhsOmirage _lhsOnts _lhsOsinglevisits _lhsOterminals+         in __result_ )+     in C_Child_s2 v1+   {-# INLINE rule0 #-}+   {-# LINE 19 "src-ag/DistChildAttr.ag" #-}+   rule0 = \ name_ tp_ ->+                       {-# LINE 19 "src-ag/DistChildAttr.ag" #-}+                       case tp_ of+                         NT nt _ _ -> nt+                         Self      -> error ("The type of child " ++ show name_ ++ " should not be a Self type.")+                         Haskell t -> identifier ""+                       {-# LINE 325 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule1 #-}+   {-# LINE 23 "src-ag/DistChildAttr.ag" #-}+   rule1 = \ _chnt ((_lhsIinhMap) :: Map Identifier Attributes) ->+                      {-# LINE 23 "src-ag/DistChildAttr.ag" #-}+                      Map.findWithDefault Map.empty _chnt     _lhsIinhMap+                      {-# LINE 331 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule2 #-}+   {-# LINE 24 "src-ag/DistChildAttr.ag" #-}+   rule2 = \ _chnt ((_lhsIsynMap) :: Map Identifier Attributes) ->+                      {-# LINE 24 "src-ag/DistChildAttr.ag" #-}+                      Map.findWithDefault Map.empty _chnt     _lhsIsynMap+                      {-# LINE 337 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule3 #-}+   {-# LINE 180 "src-ag/Order.ag" #-}+   rule3 = \ _syn tp_ ->+                                {-# LINE 180 "src-ag/Order.ag" #-}+                                case tp_ of+                                  NT nt _ _ -> Map.null _syn+                                  _         -> True+                                {-# LINE 345 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule4 #-}+   {-# LINE 183 "src-ag/Order.ag" #-}+   rule4 = \ _maptolocal _syn name_ ->+                                 {-# LINE 183 "src-ag/Order.ag" #-}+                                 if  _maptolocal+                                     then [ AltAttr _LOC name_ True ]+                                     else [ AltAttr name_ syn True | syn <- Map.keys _syn     ]+                                 {-# LINE 353 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule5 #-}+   {-# LINE 198 "src-ag/Order.ag" #-}+   rule5 = \ name_ tp_ ->+                        {-# LINE 198 "src-ag/Order.ag" #-}+                        Seq.singleton (name_,getNtName tp_)+                        {-# LINE 359 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule6 #-}+   {-# LINE 199 "src-ag/Order.ag" #-}+   rule6 = \ _inh name_ ->+                         {-# LINE 199 "src-ag/Order.ag" #-}+                         Seq.singleton (name_,_inh    )+                         {-# LINE 365 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule7 #-}+   {-# LINE 215 "src-ag/Order.ag" #-}+   rule7 = \ ((_lhsIcon) :: Identifier) ((_lhsInt) :: Identifier) _maptolocal _syn name_ tp_ ->+                              {-# LINE 215 "src-ag/Order.ag" #-}+                              if  _maptolocal+                                  then Seq.singleton (cRuleTerminal name_ _lhsInt _lhsIcon tp_)+                                  else Seq.fromList [ cRuleRhsSyn syn _lhsInt _lhsIcon tp name_ (getNtName tp_) | (syn,tp) <- Map.assocs _syn    ]+                              {-# LINE 373 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule8 #-}+   {-# LINE 347 "src-ag/Order.ag" #-}+   rule8 = \ _syn name_ ->+                                       {-# LINE 347 "src-ag/Order.ag" #-}+                                       Map.singleton name_ _syn+                                       {-# LINE 379 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule9 #-}+   {-# LINE 348 "src-ag/Order.ag" #-}+   rule9 = \ _inh name_ ->+                                       {-# LINE 348 "src-ag/Order.ag" #-}+                                       Map.singleton name_ _inh+                                       {-# LINE 385 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule10 #-}+   {-# LINE 618 "src-ag/Order.ag" #-}+   rule10 = \ _inh _maptolocal _syn name_ tp_ ->+                                 {-# LINE 618 "src-ag/Order.ag" #-}+                                 if  _maptolocal+                                     then []+                                     else [CChildVisit name_ (getNtName tp_) 0 _inh     _syn     True]+                                 {-# LINE 393 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule11 #-}+   {-# LINE 643 "src-ag/Order.ag" #-}+   rule11 = \ _maptolocal name_ ->+                            {-# LINE 643 "src-ag/Order.ag" #-}+                            if _maptolocal+                            then [name_]+                            else []+                            {-# LINE 401 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule12 #-}+   {-# LINE 672 "src-ag/Order.ag" #-}+   rule12 = \ _inh _syn name_ ->+                             {-# LINE 672 "src-ag/Order.ag" #-}+                             [(name_, _inh    , _syn    )]+                             {-# LINE 407 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule13 #-}+   {-# LINE 676 "src-ag/Order.ag" #-}+   rule13 = \ kind_ name_ tp_ ->+                        {-# LINE 676 "src-ag/Order.ag" #-}+                        (name_, tp_, kind_)+                        {-# LINE 413 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule14 #-}+   {-# LINE 50 "src-ag/TfmToMirage.ag" #-}+   rule14 = \ name_ tp_ ->+                         {-# LINE 50 "src-ag/TfmToMirage.ag" #-}+                         Mirage.Child (getName name_) (typeToMirage tp_)+                         {-# LINE 419 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule15 #-}+   rule15 = \  (_ :: ()) ->+     Seq.empty+   {-# INLINE rule16 #-}+   rule16 = \ _gathRules ->+     _gathRules++-- Children ----------------------------------------------------+-- wrapper+data Inh_Children  = Inh_Children { allfields_Inh_Children :: ([(Identifier,Type,ChildKind)]), allnts_Inh_Children :: ([Identifier]), attrs_Inh_Children :: ([(Identifier,Identifier)]), con_Inh_Children :: (Identifier), inh_Inh_Children :: (Attributes), inhMap_Inh_Children :: (Map Identifier Attributes), mergeMap_Inh_Children :: (Map Identifier (Identifier,[Identifier])), nt_Inh_Children :: (Identifier), o_unbox_Inh_Children :: (Bool), syn_Inh_Children :: (Attributes), synMap_Inh_Children :: (Map Identifier Attributes) }+data Syn_Children  = Syn_Children { attributes_Syn_Children :: ([(Identifier,Attributes,Attributes)]), collectChildrenInhs_Syn_Children :: (Map Identifier Attributes ), collectChildrenSyns_Syn_Children :: (Map Identifier Attributes ), errors_Syn_Children :: (Seq Error), fields_Syn_Children :: ([(Identifier,Type,ChildKind)]), gathAltAttrs_Syn_Children :: ([AltAttr]), gathRules_Syn_Children :: (Seq CRule), inhs_Syn_Children :: (Seq (Identifier,Attributes)), mirages_Syn_Children :: ([Mirage.Child]), nts_Syn_Children :: (Seq (Identifier,NontermIdent)), singlevisits_Syn_Children :: ([CRule]), terminals_Syn_Children :: ([Identifier]) }+{-# INLINABLE wrap_Children #-}+wrap_Children :: T_Children  -> Inh_Children  -> (Syn_Children )+wrap_Children (T_Children act) (Inh_Children _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIo_unbox _lhsIsyn _lhsIsynMap) =+   Control.Monad.Identity.runIdentity (+     do sem <- act+        let arg4 = T_Children_vIn4 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIo_unbox _lhsIsyn _lhsIsynMap+        (T_Children_vOut4 _lhsOattributes _lhsOcollectChildrenInhs _lhsOcollectChildrenSyns _lhsOerrors _lhsOfields _lhsOgathAltAttrs _lhsOgathRules _lhsOinhs _lhsOmirages _lhsOnts _lhsOsinglevisits _lhsOterminals) <- return (inv_Children_s5 sem arg4)+        return (Syn_Children _lhsOattributes _lhsOcollectChildrenInhs _lhsOcollectChildrenSyns _lhsOerrors _lhsOfields _lhsOgathAltAttrs _lhsOgathRules _lhsOinhs _lhsOmirages _lhsOnts _lhsOsinglevisits _lhsOterminals)+   )++-- cata+{-# NOINLINE sem_Children #-}+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 {+                                 attach_T_Children :: Identity (T_Children_s5 )+                                 }+newtype T_Children_s5  = C_Children_s5 {+                                       inv_Children_s5 :: (T_Children_v4 )+                                       }+data T_Children_s6  = C_Children_s6+type T_Children_v4  = (T_Children_vIn4 ) -> (T_Children_vOut4 )+data T_Children_vIn4  = T_Children_vIn4 ([(Identifier,Type,ChildKind)]) ([Identifier]) ([(Identifier,Identifier)]) (Identifier) (Attributes) (Map Identifier Attributes) (Map Identifier (Identifier,[Identifier])) (Identifier) (Bool) (Attributes) (Map Identifier Attributes)+data T_Children_vOut4  = T_Children_vOut4 ([(Identifier,Attributes,Attributes)]) (Map Identifier Attributes ) (Map Identifier Attributes ) (Seq Error) ([(Identifier,Type,ChildKind)]) ([AltAttr]) (Seq CRule) (Seq (Identifier,Attributes)) ([Mirage.Child]) (Seq (Identifier,NontermIdent)) ([CRule]) ([Identifier])+{-# NOINLINE sem_Children_Cons #-}+sem_Children_Cons :: T_Child  -> T_Children  -> T_Children +sem_Children_Cons arg_hd_ arg_tl_ = T_Children (return st5) where+   {-# NOINLINE st5 #-}+   st5 = let+      v4 :: T_Children_v4 +      v4 = \ (T_Children_vIn4 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIo_unbox _lhsIsyn _lhsIsynMap) -> ( let+         _hdX2 = Control.Monad.Identity.runIdentity (attach_T_Child (arg_hd_))+         _tlX5 = Control.Monad.Identity.runIdentity (attach_T_Children (arg_tl_))+         (T_Child_vOut1 _hdIattributes _hdIcollectChildrenInhs _hdIcollectChildrenSyns _hdIerrors _hdIfield _hdIgathAltAttrs _hdIgathRules _hdIinhs _hdImirage _hdInts _hdIsinglevisits _hdIterminals) = inv_Child_s2 _hdX2 (T_Child_vIn1 _hdOallfields _hdOallnts _hdOattrs _hdOcon _hdOinh _hdOinhMap _hdOmergeMap _hdOnt _hdOo_unbox _hdOsyn _hdOsynMap)+         (T_Children_vOut4 _tlIattributes _tlIcollectChildrenInhs _tlIcollectChildrenSyns _tlIerrors _tlIfields _tlIgathAltAttrs _tlIgathRules _tlIinhs _tlImirages _tlInts _tlIsinglevisits _tlIterminals) = inv_Children_s5 _tlX5 (T_Children_vIn4 _tlOallfields _tlOallnts _tlOattrs _tlOcon _tlOinh _tlOinhMap _tlOmergeMap _tlOnt _tlOo_unbox _tlOsyn _tlOsynMap)+         _lhsOfields :: [(Identifier,Type,ChildKind)]+         _lhsOfields = rule17 _hdIfield _tlIfields+         _lhsOmirages :: [Mirage.Child]+         _lhsOmirages = rule18 _hdImirage _tlImirages+         _lhsOattributes :: [(Identifier,Attributes,Attributes)]+         _lhsOattributes = rule19 _hdIattributes _tlIattributes+         _lhsOcollectChildrenInhs :: Map Identifier Attributes +         _lhsOcollectChildrenInhs = rule20 _hdIcollectChildrenInhs _tlIcollectChildrenInhs+         _lhsOcollectChildrenSyns :: Map Identifier Attributes +         _lhsOcollectChildrenSyns = rule21 _hdIcollectChildrenSyns _tlIcollectChildrenSyns+         _lhsOerrors :: Seq Error+         _lhsOerrors = rule22 _hdIerrors _tlIerrors+         _lhsOgathAltAttrs :: [AltAttr]+         _lhsOgathAltAttrs = rule23 _hdIgathAltAttrs _tlIgathAltAttrs+         _lhsOgathRules :: Seq CRule+         _lhsOgathRules = rule24 _hdIgathRules _tlIgathRules+         _lhsOinhs :: Seq (Identifier,Attributes)+         _lhsOinhs = rule25 _hdIinhs _tlIinhs+         _lhsOnts :: Seq (Identifier,NontermIdent)+         _lhsOnts = rule26 _hdInts _tlInts+         _lhsOsinglevisits :: [CRule]+         _lhsOsinglevisits = rule27 _hdIsinglevisits _tlIsinglevisits+         _lhsOterminals :: [Identifier]+         _lhsOterminals = rule28 _hdIterminals _tlIterminals+         _hdOallfields = rule29 _lhsIallfields+         _hdOallnts = rule30 _lhsIallnts+         _hdOattrs = rule31 _lhsIattrs+         _hdOcon = rule32 _lhsIcon+         _hdOinh = rule33 _lhsIinh+         _hdOinhMap = rule34 _lhsIinhMap+         _hdOmergeMap = rule35 _lhsImergeMap+         _hdOnt = rule36 _lhsInt+         _hdOo_unbox = rule37 _lhsIo_unbox+         _hdOsyn = rule38 _lhsIsyn+         _hdOsynMap = rule39 _lhsIsynMap+         _tlOallfields = rule40 _lhsIallfields+         _tlOallnts = rule41 _lhsIallnts+         _tlOattrs = rule42 _lhsIattrs+         _tlOcon = rule43 _lhsIcon+         _tlOinh = rule44 _lhsIinh+         _tlOinhMap = rule45 _lhsIinhMap+         _tlOmergeMap = rule46 _lhsImergeMap+         _tlOnt = rule47 _lhsInt+         _tlOo_unbox = rule48 _lhsIo_unbox+         _tlOsyn = rule49 _lhsIsyn+         _tlOsynMap = rule50 _lhsIsynMap+         __result_ = T_Children_vOut4 _lhsOattributes _lhsOcollectChildrenInhs _lhsOcollectChildrenSyns _lhsOerrors _lhsOfields _lhsOgathAltAttrs _lhsOgathRules _lhsOinhs _lhsOmirages _lhsOnts _lhsOsinglevisits _lhsOterminals+         in __result_ )+     in C_Children_s5 v4+   {-# INLINE rule17 #-}+   {-# LINE 679 "src-ag/Order.ag" #-}+   rule17 = \ ((_hdIfield) :: (Identifier,Type,ChildKind)) ((_tlIfields) :: [(Identifier,Type,ChildKind)]) ->+                         {-# LINE 679 "src-ag/Order.ag" #-}+                         _hdIfield : _tlIfields+                         {-# LINE 522 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule18 #-}+   {-# LINE 46 "src-ag/TfmToMirage.ag" #-}+   rule18 = \ ((_hdImirage) :: Mirage.Child) ((_tlImirages) :: [Mirage.Child]) ->+                         {-# LINE 46 "src-ag/TfmToMirage.ag" #-}+                         _hdImirage : _tlImirages+                         {-# LINE 528 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule19 #-}+   rule19 = \ ((_hdIattributes) :: [(Identifier,Attributes,Attributes)]) ((_tlIattributes) :: [(Identifier,Attributes,Attributes)]) ->+     _hdIattributes ++ _tlIattributes+   {-# INLINE rule20 #-}+   rule20 = \ ((_hdIcollectChildrenInhs) :: Map Identifier Attributes ) ((_tlIcollectChildrenInhs) :: Map Identifier Attributes ) ->+     _hdIcollectChildrenInhs `Map.union` _tlIcollectChildrenInhs+   {-# INLINE rule21 #-}+   rule21 = \ ((_hdIcollectChildrenSyns) :: Map Identifier Attributes ) ((_tlIcollectChildrenSyns) :: Map Identifier Attributes ) ->+     _hdIcollectChildrenSyns `Map.union` _tlIcollectChildrenSyns+   {-# INLINE rule22 #-}+   rule22 = \ ((_hdIerrors) :: Seq Error) ((_tlIerrors) :: Seq Error) ->+     _hdIerrors Seq.>< _tlIerrors+   {-# INLINE rule23 #-}+   rule23 = \ ((_hdIgathAltAttrs) :: [AltAttr]) ((_tlIgathAltAttrs) :: [AltAttr]) ->+     _hdIgathAltAttrs ++ _tlIgathAltAttrs+   {-# INLINE rule24 #-}+   rule24 = \ ((_hdIgathRules) :: Seq CRule) ((_tlIgathRules) :: Seq CRule) ->+     _hdIgathRules Seq.>< _tlIgathRules+   {-# INLINE rule25 #-}+   rule25 = \ ((_hdIinhs) :: Seq (Identifier,Attributes)) ((_tlIinhs) :: Seq (Identifier,Attributes)) ->+     _hdIinhs Seq.>< _tlIinhs+   {-# INLINE rule26 #-}+   rule26 = \ ((_hdInts) :: Seq (Identifier,NontermIdent)) ((_tlInts) :: Seq (Identifier,NontermIdent)) ->+     _hdInts Seq.>< _tlInts+   {-# INLINE rule27 #-}+   rule27 = \ ((_hdIsinglevisits) :: [CRule]) ((_tlIsinglevisits) :: [CRule]) ->+     _hdIsinglevisits ++ _tlIsinglevisits+   {-# INLINE rule28 #-}+   rule28 = \ ((_hdIterminals) :: [Identifier]) ((_tlIterminals) :: [Identifier]) ->+     _hdIterminals ++ _tlIterminals+   {-# INLINE rule29 #-}+   rule29 = \ ((_lhsIallfields) :: [(Identifier,Type,ChildKind)]) ->+     _lhsIallfields+   {-# INLINE rule30 #-}+   rule30 = \ ((_lhsIallnts) :: [Identifier]) ->+     _lhsIallnts+   {-# INLINE rule31 #-}+   rule31 = \ ((_lhsIattrs) :: [(Identifier,Identifier)]) ->+     _lhsIattrs+   {-# INLINE rule32 #-}+   rule32 = \ ((_lhsIcon) :: Identifier) ->+     _lhsIcon+   {-# INLINE rule33 #-}+   rule33 = \ ((_lhsIinh) :: Attributes) ->+     _lhsIinh+   {-# INLINE rule34 #-}+   rule34 = \ ((_lhsIinhMap) :: Map Identifier Attributes) ->+     _lhsIinhMap+   {-# INLINE rule35 #-}+   rule35 = \ ((_lhsImergeMap) :: Map Identifier (Identifier,[Identifier])) ->+     _lhsImergeMap+   {-# INLINE rule36 #-}+   rule36 = \ ((_lhsInt) :: Identifier) ->+     _lhsInt+   {-# INLINE rule37 #-}+   rule37 = \ ((_lhsIo_unbox) :: Bool) ->+     _lhsIo_unbox+   {-# INLINE rule38 #-}+   rule38 = \ ((_lhsIsyn) :: Attributes) ->+     _lhsIsyn+   {-# INLINE rule39 #-}+   rule39 = \ ((_lhsIsynMap) :: Map Identifier Attributes) ->+     _lhsIsynMap+   {-# INLINE rule40 #-}+   rule40 = \ ((_lhsIallfields) :: [(Identifier,Type,ChildKind)]) ->+     _lhsIallfields+   {-# INLINE rule41 #-}+   rule41 = \ ((_lhsIallnts) :: [Identifier]) ->+     _lhsIallnts+   {-# INLINE rule42 #-}+   rule42 = \ ((_lhsIattrs) :: [(Identifier,Identifier)]) ->+     _lhsIattrs+   {-# INLINE rule43 #-}+   rule43 = \ ((_lhsIcon) :: Identifier) ->+     _lhsIcon+   {-# INLINE rule44 #-}+   rule44 = \ ((_lhsIinh) :: Attributes) ->+     _lhsIinh+   {-# INLINE rule45 #-}+   rule45 = \ ((_lhsIinhMap) :: Map Identifier Attributes) ->+     _lhsIinhMap+   {-# INLINE rule46 #-}+   rule46 = \ ((_lhsImergeMap) :: Map Identifier (Identifier,[Identifier])) ->+     _lhsImergeMap+   {-# INLINE rule47 #-}+   rule47 = \ ((_lhsInt) :: Identifier) ->+     _lhsInt+   {-# INLINE rule48 #-}+   rule48 = \ ((_lhsIo_unbox) :: Bool) ->+     _lhsIo_unbox+   {-# INLINE rule49 #-}+   rule49 = \ ((_lhsIsyn) :: Attributes) ->+     _lhsIsyn+   {-# INLINE rule50 #-}+   rule50 = \ ((_lhsIsynMap) :: Map Identifier Attributes) ->+     _lhsIsynMap+{-# NOINLINE sem_Children_Nil #-}+sem_Children_Nil ::  T_Children +sem_Children_Nil  = T_Children (return st5) where+   {-# NOINLINE st5 #-}+   st5 = let+      v4 :: T_Children_v4 +      v4 = \ (T_Children_vIn4 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIo_unbox _lhsIsyn _lhsIsynMap) -> ( let+         _lhsOfields :: [(Identifier,Type,ChildKind)]+         _lhsOfields = rule51  ()+         _lhsOmirages :: [Mirage.Child]+         _lhsOmirages = rule52  ()+         _lhsOattributes :: [(Identifier,Attributes,Attributes)]+         _lhsOattributes = rule53  ()+         _lhsOcollectChildrenInhs :: Map Identifier Attributes +         _lhsOcollectChildrenInhs = rule54  ()+         _lhsOcollectChildrenSyns :: Map Identifier Attributes +         _lhsOcollectChildrenSyns = rule55  ()+         _lhsOerrors :: Seq Error+         _lhsOerrors = rule56  ()+         _lhsOgathAltAttrs :: [AltAttr]+         _lhsOgathAltAttrs = rule57  ()+         _lhsOgathRules :: Seq CRule+         _lhsOgathRules = rule58  ()+         _lhsOinhs :: Seq (Identifier,Attributes)+         _lhsOinhs = rule59  ()+         _lhsOnts :: Seq (Identifier,NontermIdent)+         _lhsOnts = rule60  ()+         _lhsOsinglevisits :: [CRule]+         _lhsOsinglevisits = rule61  ()+         _lhsOterminals :: [Identifier]+         _lhsOterminals = rule62  ()+         __result_ = T_Children_vOut4 _lhsOattributes _lhsOcollectChildrenInhs _lhsOcollectChildrenSyns _lhsOerrors _lhsOfields _lhsOgathAltAttrs _lhsOgathRules _lhsOinhs _lhsOmirages _lhsOnts _lhsOsinglevisits _lhsOterminals+         in __result_ )+     in C_Children_s5 v4+   {-# INLINE rule51 #-}+   {-# LINE 680 "src-ag/Order.ag" #-}+   rule51 = \  (_ :: ()) ->+                         {-# LINE 680 "src-ag/Order.ag" #-}+                         []+                         {-# LINE 664 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule52 #-}+   {-# LINE 47 "src-ag/TfmToMirage.ag" #-}+   rule52 = \  (_ :: ()) ->+                         {-# LINE 47 "src-ag/TfmToMirage.ag" #-}+                         []+                         {-# LINE 670 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule53 #-}+   rule53 = \  (_ :: ()) ->+     []+   {-# INLINE rule54 #-}+   rule54 = \  (_ :: ()) ->+     Map.empty+   {-# INLINE rule55 #-}+   rule55 = \  (_ :: ()) ->+     Map.empty+   {-# INLINE rule56 #-}+   rule56 = \  (_ :: ()) ->+     Seq.empty+   {-# INLINE rule57 #-}+   rule57 = \  (_ :: ()) ->+     []+   {-# INLINE rule58 #-}+   rule58 = \  (_ :: ()) ->+     Seq.empty+   {-# INLINE rule59 #-}+   rule59 = \  (_ :: ()) ->+     Seq.empty+   {-# INLINE rule60 #-}+   rule60 = \  (_ :: ()) ->+     Seq.empty+   {-# INLINE rule61 #-}+   rule61 = \  (_ :: ()) ->+     []+   {-# INLINE rule62 #-}+   rule62 = \  (_ :: ()) ->+     []++-- Expression --------------------------------------------------+-- wrapper+data Inh_Expression  = Inh_Expression { allfields_Inh_Expression :: ([(Identifier,Type,ChildKind)]), allnts_Inh_Expression :: ([Identifier]), attrs_Inh_Expression :: ([(Identifier,Identifier)]), con_Inh_Expression :: (Identifier), mergeMap_Inh_Expression :: (Map Identifier (Identifier,[Identifier])), nt_Inh_Expression :: (Identifier), options_Inh_Expression :: (Options) }+data Syn_Expression  = Syn_Expression { allRhsVars_Syn_Expression :: (Set (Identifier,Identifier)), copy_Syn_Expression :: (Expression), errors_Syn_Expression :: (Seq Error), lns_Syn_Expression :: ([String]), textLines_Syn_Expression :: ([String]), usedAttrs_Syn_Expression :: ([(Identifier,Identifier)]), usedFields_Syn_Expression :: ([Identifier]), usedLocals_Syn_Expression :: ([Identifier]) }+{-# INLINABLE wrap_Expression #-}+wrap_Expression :: T_Expression  -> Inh_Expression  -> (Syn_Expression )+wrap_Expression (T_Expression act) (Inh_Expression _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsImergeMap _lhsInt _lhsIoptions) =+   Control.Monad.Identity.runIdentity (+     do sem <- act+        let arg7 = T_Expression_vIn7 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsImergeMap _lhsInt _lhsIoptions+        (T_Expression_vOut7 _lhsOallRhsVars _lhsOcopy _lhsOerrors _lhsOlns _lhsOtextLines _lhsOusedAttrs _lhsOusedFields _lhsOusedLocals) <- return (inv_Expression_s8 sem arg7)+        return (Syn_Expression _lhsOallRhsVars _lhsOcopy _lhsOerrors _lhsOlns _lhsOtextLines _lhsOusedAttrs _lhsOusedFields _lhsOusedLocals)+   )++-- cata+{-# INLINE sem_Expression #-}+sem_Expression :: Expression  -> T_Expression +sem_Expression ( Expression pos_ tks_ ) = sem_Expression_Expression pos_ tks_++-- semantic domain+newtype T_Expression  = T_Expression {+                                     attach_T_Expression :: Identity (T_Expression_s8 )+                                     }+newtype T_Expression_s8  = C_Expression_s8 {+                                           inv_Expression_s8 :: (T_Expression_v7 )+                                           }+data T_Expression_s9  = C_Expression_s9+type T_Expression_v7  = (T_Expression_vIn7 ) -> (T_Expression_vOut7 )+data T_Expression_vIn7  = T_Expression_vIn7 ([(Identifier,Type,ChildKind)]) ([Identifier]) ([(Identifier,Identifier)]) (Identifier) (Map Identifier (Identifier,[Identifier])) (Identifier) (Options)+data T_Expression_vOut7  = T_Expression_vOut7 (Set (Identifier,Identifier)) (Expression) (Seq Error) ([String]) ([String]) ([(Identifier,Identifier)]) ([Identifier]) ([Identifier])+{-# NOINLINE sem_Expression_Expression #-}+sem_Expression_Expression :: (Pos) -> ([HsToken]) -> T_Expression +sem_Expression_Expression arg_pos_ arg_tks_ = T_Expression (return st8) where+   {-# NOINLINE st8 #-}+   st8 = let+      v7 :: T_Expression_v7 +      v7 = \ (T_Expression_vIn7 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsImergeMap _lhsInt _lhsIoptions) -> ( let+         (_textLines,_usedAttrs,_usedLocals,_usedFields) = rule63 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsImergeMap _lhsInt _lhsIoptions arg_tks_+         _lhsOerrors :: Seq Error+         _lhsOerrors = rule64  ()+         _lhsOallRhsVars :: Set (Identifier,Identifier)+         _lhsOallRhsVars = rule65 _usedAttrs _usedFields _usedLocals+         _lhsOlns :: [String]+         _lhsOlns = rule66 arg_tks_+         _copy = rule67 arg_pos_ arg_tks_+         _lhsOcopy :: Expression+         _lhsOcopy = rule68 _copy+         _lhsOtextLines :: [String]+         _lhsOtextLines = rule69 _textLines+         _lhsOusedAttrs :: [(Identifier,Identifier)]+         _lhsOusedAttrs = rule70 _usedAttrs+         _lhsOusedFields :: [Identifier]+         _lhsOusedFields = rule71 _usedFields+         _lhsOusedLocals :: [Identifier]+         _lhsOusedLocals = rule72 _usedLocals+         __result_ = T_Expression_vOut7 _lhsOallRhsVars _lhsOcopy _lhsOerrors _lhsOlns _lhsOtextLines _lhsOusedAttrs _lhsOusedFields _lhsOusedLocals+         in __result_ )+     in C_Expression_s8 v7+   {-# INLINE rule63 #-}+   {-# LINE 469 "src-ag/Order.ag" #-}+   rule63 = \ ((_lhsIallfields) :: [(Identifier,Type,ChildKind)]) ((_lhsIallnts) :: [Identifier]) ((_lhsIattrs) :: [(Identifier,Identifier)]) ((_lhsIcon) :: Identifier) ((_lhsImergeMap) :: Map Identifier (Identifier,[Identifier])) ((_lhsInt) :: Identifier) ((_lhsIoptions) :: Options) tks_ ->+                                {-# LINE 469 "src-ag/Order.ag" #-}+                                let mergedChildren = [ x | (_,xs) <- Map.elems _lhsImergeMap, x <- xs ]+                                    attrsIn = filter (\(fld,_) -> not (fld `elem` mergedChildren)) _lhsIattrs+                                    inherited = Inh_HsTokensRoot+                                                { attrs_Inh_HsTokensRoot      = attrsIn+                                                , con_Inh_HsTokensRoot        = _lhsIcon+                                                , allfields_Inh_HsTokensRoot  = _lhsIallfields+                                                , allnts_Inh_HsTokensRoot     = _lhsIallnts+                                                , nt_Inh_HsTokensRoot         = _lhsInt+                                                , options_Inh_HsTokensRoot    = _lhsIoptions+                                                }+                                    synthesized = wrap_HsTokensRoot (sem_HsTokensRoot (HsTokensRoot tks_)) inherited+                                in case synthesized of+                                     Syn_HsTokensRoot+                                      { textLines_Syn_HsTokensRoot  = textLines+                                      , usedAttrs_Syn_HsTokensRoot  = usedAttrs+                                      , usedLocals_Syn_HsTokensRoot = usedLocals+                                      , usedFields_Syn_HsTokensRoot = usedFields+                                      }  -> let extraAttrs = [ (src,attr)+                                                             | (fld,attr) <- usedAttrs, let mbMerged = Map.lookup fld _lhsImergeMap, isJust mbMerged+                                                             , let (Just (_, srcs)) = mbMerged, src <- srcs ]+                                                usedAttrs' = usedAttrs ++ extraAttrs+                                            in (textLines,usedAttrs',usedLocals,usedFields)+                                {-# LINE 786 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule64 #-}+   {-# LINE 492 "src-ag/Order.ag" #-}+   rule64 = \  (_ :: ()) ->+                               {-# LINE 492 "src-ag/Order.ag" #-}+                               Seq.empty+                               {-# LINE 792 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule65 #-}+   {-# LINE 493 "src-ag/Order.ag" #-}+   rule65 = \ _usedAttrs _usedFields _usedLocals ->+                                   {-# LINE 493 "src-ag/Order.ag" #-}+                                   Set.fromList _usedAttrs+                                   `Set.union`+                                   Set.fromList [ (_LOC, l) | l <- _usedLocals    ]+                                   `Set.union`+                                   Set.fromList [ (_FIELD, fld) | fld <- _usedFields    ]+                                   {-# LINE 802 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule66 #-}+   {-# LINE 71 "src-ag/TfmToMirage.ag" #-}+   rule66 = \ tks_ ->+                            {-# LINE 71 "src-ag/TfmToMirage.ag" #-}+                            showTokens . tokensToStrings $ tks_+                            {-# LINE 808 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule67 #-}+   rule67 = \ pos_ tks_ ->+     Expression pos_ tks_+   {-# INLINE rule68 #-}+   rule68 = \ _copy ->+     _copy+   {-# INLINE rule69 #-}+   rule69 = \ _textLines ->+     _textLines+   {-# INLINE rule70 #-}+   rule70 = \ _usedAttrs ->+     _usedAttrs+   {-# INLINE rule71 #-}+   rule71 = \ _usedFields ->+     _usedFields+   {-# INLINE rule72 #-}+   rule72 = \ _usedLocals ->+     _usedLocals++-- Grammar -----------------------------------------------------+-- wrapper+data Inh_Grammar  = Inh_Grammar { options_Inh_Grammar :: (Options) }+data Syn_Grammar  = Syn_Grammar { errors_Syn_Grammar :: (Seq Error), mirage_Syn_Grammar :: (Mirage.Grammar), nAutoRules_Syn_Grammar :: (Int), nExplicitRules_Syn_Grammar :: (Int), output_Syn_Grammar :: (CGrammar) }+{-# INLINABLE wrap_Grammar #-}+wrap_Grammar :: T_Grammar  -> Inh_Grammar  -> (Syn_Grammar )+wrap_Grammar (T_Grammar act) (Inh_Grammar _lhsIoptions) =+   Control.Monad.Identity.runIdentity (+     do sem <- act+        let arg10 = T_Grammar_vIn10 _lhsIoptions+        (T_Grammar_vOut10 _lhsOerrors _lhsOmirage _lhsOnAutoRules _lhsOnExplicitRules _lhsOoutput) <- return (inv_Grammar_s11 sem arg10)+        return (Syn_Grammar _lhsOerrors _lhsOmirage _lhsOnAutoRules _lhsOnExplicitRules _lhsOoutput)+   )++-- cata+{-# INLINE sem_Grammar #-}+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 {+                               attach_T_Grammar :: Identity (T_Grammar_s11 )+                               }+newtype T_Grammar_s11  = C_Grammar_s11 {+                                       inv_Grammar_s11 :: (T_Grammar_v10 )+                                       }+data T_Grammar_s12  = C_Grammar_s12+type T_Grammar_v10  = (T_Grammar_vIn10 ) -> (T_Grammar_vOut10 )+data T_Grammar_vIn10  = T_Grammar_vIn10 (Options)+data T_Grammar_vOut10  = T_Grammar_vOut10 (Seq Error) (Mirage.Grammar) (Int) (Int) (CGrammar)+{-# NOINLINE sem_Grammar_Grammar #-}+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 arg_typeSyns_ _ arg_derivings_ arg_wrappers_ arg_nonts_ arg_pragmas_ arg_manualAttrOrderMap_ arg_paramMap_ arg_contextMap_ arg_quantMap_ _ _ arg_aroundsMap_ arg_mergeMap_ = T_Grammar (return st11) where+   {-# NOINLINE st11 #-}+   st11 = let+      v10 :: T_Grammar_v10 +      v10 = \ (T_Grammar_vIn10 _lhsIoptions) -> ( let+         _nontsX17 = Control.Monad.Identity.runIdentity (attach_T_Nonterminals (arg_nonts_))+         (T_Nonterminals_vOut16 _nontsIacount _nontsIadditionalDep _nontsIaranges _nontsIaroundDep _nontsIcNonterminals _nontsIdirectDep _nontsIerrors _nontsIinhMap' _nontsIinstDep _nontsImergeDep _nontsImirages _nontsInAutoRules _nontsInExplicitRules _nontsInonts _nontsIntattrs _nontsIrules _nontsIsynMap' _nontsIvcount) = inv_Nonterminals_s17 _nontsX17 (T_Nonterminals_vIn16 _nontsOacount _nontsOallnts _nontsOaroundMap _nontsOcInterfaceMap _nontsOcVisitsMap _nontsOinhMap _nontsOmanualAttrDepMap _nontsOmergeMap _nontsOo_case _nontsOo_cata _nontsOo_data _nontsOo_dovisit _nontsOo_newtypes _nontsOo_rename _nontsOo_sem _nontsOo_sig _nontsOo_unbox _nontsOo_wantvisit _nontsOoptions _nontsOprefix _nontsOsynMap _nontsOvcount)+         _nontsOinhMap = rule73 _nontsIinhMap'+         _nontsOsynMap = rule74 _nontsIsynMap'+         _o_dovisit = rule75 _cyclesErrors _lhsIoptions+         _nontsOo_cata = rule76 _lhsIoptions+         _nontsOo_data = rule77 _lhsIoptions+         _nontsOo_sig = rule78 _lhsIoptions+         _nontsOo_sem = rule79 _lhsIoptions+         _nontsOo_rename = rule80 _lhsIoptions+         _nontsOo_newtypes = rule81 _lhsIoptions+         _nontsOo_wantvisit = rule82 _lhsIoptions+         _nontsOo_unbox = rule83 _lhsIoptions+         _nontsOo_case = rule84 _lhsIoptions+         _nontsOprefix = rule85 _lhsIoptions+         _nontsOvcount = rule86  ()+         _nontsOmanualAttrDepMap = rule87 arg_manualAttrOrderMap_+         _nontsOaroundMap = rule88 arg_aroundsMap_+         _nontsOacount = rule89  ()+         _ruleTable = rule90 _nontsIrules _nontsIvcount+         _attrTable = rule91 _nontsIacount _nontsIntattrs+         _attrVertex = rule92 _nontsIntattrs+         _tdpToTds = rule93 _attrVertex _nontsIrules+         _tdsToTdp = rule94 _tdpToTds+         _directDep = rule95 _nontsIadditionalDep _nontsIdirectDep+         _instDep = rule96 _nontsIinstDep+         _aroundDep = rule97 _nontsIaroundDep+         _mergeDep = rule98 _nontsImergeDep+         _info = rule99 _attrTable _nontsIacount _nontsIaranges _nontsInonts _nontsIvcount _ruleTable _tdpToTds _tdsToTdp arg_wrappers_+         (_cInterfaceMap,_cVisitsMap,_cyclesErrors) = rule100 _aroundDep _attrTable _directDep _info _instDep _lhsIoptions _mergeDep _ruleTable+         _lhsOerrors :: Seq Error+         _lhsOerrors = rule101 _cyclesErrors _lhsIoptions _nontsIerrors+         _lhsOoutput :: CGrammar+         _lhsOoutput = rule102 _aroundMap _mergeMap _nontsIcNonterminals _o_dovisit arg_contextMap_ arg_derivings_ arg_paramMap_ arg_pragmas_ arg_quantMap_ arg_typeSyns_ arg_wrappers_+         _aroundMap = rule103 arg_aroundsMap_+         _mergeMap = rule104 arg_mergeMap_+         _nontsOallnts = rule105 _nontsInonts+         _lhsOmirage :: Mirage.Grammar+         _lhsOmirage = rule106 _nontsImirages+         _lhsOnAutoRules :: Int+         _lhsOnAutoRules = rule107 _nontsInAutoRules+         _lhsOnExplicitRules :: Int+         _lhsOnExplicitRules = rule108 _nontsInExplicitRules+         _nontsOcInterfaceMap = rule109 _cInterfaceMap+         _nontsOcVisitsMap = rule110 _cVisitsMap+         _nontsOmergeMap = rule111 _mergeMap+         _nontsOo_dovisit = rule112 _o_dovisit+         _nontsOoptions = rule113 _lhsIoptions+         __result_ = T_Grammar_vOut10 _lhsOerrors _lhsOmirage _lhsOnAutoRules _lhsOnExplicitRules _lhsOoutput+         in __result_ )+     in C_Grammar_s11 v10+   {-# INLINE rule73 #-}+   {-# LINE 15 "src-ag/DistChildAttr.ag" #-}+   rule73 = \ ((_nontsIinhMap') :: Map Identifier Attributes) ->+                             {-# LINE 15 "src-ag/DistChildAttr.ag" #-}+                             _nontsIinhMap'+                             {-# LINE 921 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule74 #-}+   {-# LINE 16 "src-ag/DistChildAttr.ag" #-}+   rule74 = \ ((_nontsIsynMap') :: Map Identifier Attributes) ->+                             {-# LINE 16 "src-ag/DistChildAttr.ag" #-}+                             _nontsIsynMap'+                             {-# LINE 927 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule75 #-}+   {-# LINE 123 "src-ag/Order.ag" #-}+   rule75 = \ _cyclesErrors ((_lhsIoptions) :: Options) ->+                                    {-# LINE 123 "src-ag/Order.ag" #-}+                                    visit     _lhsIoptions && null _cyclesErrors+                                    {-# LINE 933 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule76 #-}+   {-# LINE 124 "src-ag/Order.ag" #-}+   rule76 = \ ((_lhsIoptions) :: Options) ->+                                    {-# LINE 124 "src-ag/Order.ag" #-}+                                    folds     _lhsIoptions+                                    {-# LINE 939 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule77 #-}+   {-# LINE 125 "src-ag/Order.ag" #-}+   rule77 = \ ((_lhsIoptions) :: Options) ->+                                    {-# LINE 125 "src-ag/Order.ag" #-}+                                    dataTypes _lhsIoptions+                                    {-# LINE 945 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule78 #-}+   {-# LINE 126 "src-ag/Order.ag" #-}+   rule78 = \ ((_lhsIoptions) :: Options) ->+                                    {-# LINE 126 "src-ag/Order.ag" #-}+                                    typeSigs  _lhsIoptions+                                    {-# LINE 951 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule79 #-}+   {-# LINE 127 "src-ag/Order.ag" #-}+   rule79 = \ ((_lhsIoptions) :: Options) ->+                                    {-# LINE 127 "src-ag/Order.ag" #-}+                                    semfuns   _lhsIoptions+                                    {-# LINE 957 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule80 #-}+   {-# LINE 128 "src-ag/Order.ag" #-}+   rule80 = \ ((_lhsIoptions) :: Options) ->+                                    {-# LINE 128 "src-ag/Order.ag" #-}+                                    rename    _lhsIoptions+                                    {-# LINE 963 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule81 #-}+   {-# LINE 129 "src-ag/Order.ag" #-}+   rule81 = \ ((_lhsIoptions) :: Options) ->+                                    {-# LINE 129 "src-ag/Order.ag" #-}+                                    newtypes  _lhsIoptions+                                    {-# LINE 969 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule82 #-}+   {-# LINE 130 "src-ag/Order.ag" #-}+   rule82 = \ ((_lhsIoptions) :: Options) ->+                                      {-# LINE 130 "src-ag/Order.ag" #-}+                                      visit   _lhsIoptions+                                      {-# LINE 975 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule83 #-}+   {-# LINE 131 "src-ag/Order.ag" #-}+   rule83 = \ ((_lhsIoptions) :: Options) ->+                                    {-# LINE 131 "src-ag/Order.ag" #-}+                                    unbox     _lhsIoptions+                                    {-# LINE 981 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule84 #-}+   {-# LINE 132 "src-ag/Order.ag" #-}+   rule84 = \ ((_lhsIoptions) :: Options) ->+                                    {-# LINE 132 "src-ag/Order.ag" #-}+                                    cases     _lhsIoptions+                                    {-# LINE 987 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule85 #-}+   {-# LINE 133 "src-ag/Order.ag" #-}+   rule85 = \ ((_lhsIoptions) :: Options) ->+                                    {-# LINE 133 "src-ag/Order.ag" #-}+                                    prefix    _lhsIoptions+                                    {-# LINE 993 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule86 #-}+   {-# LINE 262 "src-ag/Order.ag" #-}+   rule86 = \  (_ :: ()) ->+                               {-# LINE 262 "src-ag/Order.ag" #-}+                               0+                               {-# LINE 999 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule87 #-}+   {-# LINE 288 "src-ag/Order.ag" #-}+   rule87 = \ manualAttrOrderMap_ ->+                                 {-# LINE 288 "src-ag/Order.ag" #-}+                                 manualAttrOrderMap_+                                 {-# LINE 1005 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule88 #-}+   {-# LINE 417 "src-ag/Order.ag" #-}+   rule88 = \ aroundsMap_ ->+                                 {-# LINE 417 "src-ag/Order.ag" #-}+                                 aroundsMap_+                                 {-# LINE 1011 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule89 #-}+   {-# LINE 508 "src-ag/Order.ag" #-}+   rule89 = \  (_ :: ()) ->+                             {-# LINE 508 "src-ag/Order.ag" #-}+                             0+                             {-# LINE 1017 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule90 #-}+   {-# LINE 546 "src-ag/Order.ag" #-}+   rule90 = \ ((_nontsIrules) :: Seq (Vertex,CRule)) ((_nontsIvcount) :: Int) ->+                              {-# LINE 546 "src-ag/Order.ag" #-}+                              Array.array (0,_nontsIvcount-1) (toList _nontsIrules)+                              {-# LINE 1023 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule91 #-}+   {-# LINE 547 "src-ag/Order.ag" #-}+   rule91 = \ ((_nontsIacount) :: Int) ((_nontsIntattrs) :: Seq (Vertex,NTAttr)) ->+                              {-# LINE 547 "src-ag/Order.ag" #-}+                              Array.array (0,_nontsIacount-1) (toList _nontsIntattrs)+                              {-# LINE 1029 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule92 #-}+   {-# LINE 548 "src-ag/Order.ag" #-}+   rule92 = \ ((_nontsIntattrs) :: Seq (Vertex,NTAttr)) ->+                               {-# LINE 548 "src-ag/Order.ag" #-}+                               Map.fromList (map swap (toList _nontsIntattrs))+                               {-# LINE 1035 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule93 #-}+   {-# LINE 549 "src-ag/Order.ag" #-}+   rule93 = \ _attrVertex ((_nontsIrules) :: Seq (Vertex,CRule)) ->+                              {-# LINE 549 "src-ag/Order.ag" #-}+                              [ (s, maybe (-1) (\v -> findWithErr1 "Grammar.tdpToTds" v _attrVertex) (ntattr cr))+                              | (s,cr) <- toList _nontsIrules]+                              {-# LINE 1042 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule94 #-}+   {-# LINE 551 "src-ag/Order.ag" #-}+   rule94 = \ _tdpToTds ->+                               {-# LINE 551 "src-ag/Order.ag" #-}+                               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)+                               {-# LINE 1051 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule95 #-}+   {-# LINE 555 "src-ag/Order.ag" #-}+   rule95 = \ ((_nontsIadditionalDep) :: Seq Edge) ((_nontsIdirectDep) :: Seq Edge) ->+                              {-# LINE 555 "src-ag/Order.ag" #-}+                              toList (_nontsIdirectDep Seq.>< _nontsIadditionalDep)+                              {-# LINE 1057 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule96 #-}+   {-# LINE 556 "src-ag/Order.ag" #-}+   rule96 = \ ((_nontsIinstDep) :: Seq Edge) ->+                              {-# LINE 556 "src-ag/Order.ag" #-}+                              toList _nontsIinstDep+                              {-# LINE 1063 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule97 #-}+   {-# LINE 557 "src-ag/Order.ag" #-}+   rule97 = \ ((_nontsIaroundDep) :: Seq Edge) ->+                              {-# LINE 557 "src-ag/Order.ag" #-}+                              toList _nontsIaroundDep+                              {-# LINE 1069 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule98 #-}+   {-# LINE 558 "src-ag/Order.ag" #-}+   rule98 = \ ((_nontsImergeDep) :: Seq Edge) ->+                              {-# LINE 558 "src-ag/Order.ag" #-}+                              toList _nontsImergeDep+                              {-# LINE 1075 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule99 #-}+   {-# LINE 559 "src-ag/Order.ag" #-}+   rule99 = \ _attrTable ((_nontsIacount) :: Int) ((_nontsIaranges) :: Seq (Int,Int,Int)) ((_nontsInonts) :: [(NontermIdent,[ConstructorIdent])]) ((_nontsIvcount) :: Int) _ruleTable _tdpToTds _tdsToTdp wrappers_ ->+                              {-# LINE 559 "src-ag/Order.ag" #-}+                              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        = toList _nontsIaranges+                                       , nonts      = _nontsInonts+                                       , wraps      = wrappers_+                                       }+                              {-# LINE 1090 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule100 #-}+   {-# LINE 571 "src-ag/Order.ag" #-}+   rule100 = \ _aroundDep _attrTable _directDep _info _instDep ((_lhsIoptions) :: Options) _mergeDep _ruleTable ->+                                {-# LINE 571 "src-ag/Order.ag" #-}+                                case computeSequential _info _directDep (_instDep ++ _aroundDep ++ _mergeDep    ) 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+                                                                       )+                                {-# LINE 1116 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule101 #-}+   {-# LINE 592 "src-ag/Order.ag" #-}+   rule101 = \ _cyclesErrors ((_lhsIoptions) :: Options) ((_nontsIerrors) :: Seq Error) ->+                           {-# LINE 592 "src-ag/Order.ag" #-}+                           (if withCycle _lhsIoptions then Seq.fromList _cyclesErrors else Seq.empty)+                            Seq.>< _nontsIerrors+                           {-# LINE 1123 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule102 #-}+   {-# LINE 624 "src-ag/Order.ag" #-}+   rule102 = \ _aroundMap _mergeMap ((_nontsIcNonterminals) :: CNonterminals) _o_dovisit contextMap_ derivings_ paramMap_ pragmas_ quantMap_ typeSyns_ wrappers_ ->+                             {-# LINE 624 "src-ag/Order.ag" #-}+                             CGrammar typeSyns_ derivings_ wrappers_ _nontsIcNonterminals pragmas_ paramMap_ contextMap_ quantMap_ _aroundMap     _mergeMap     _o_dovisit+                             {-# LINE 1129 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule103 #-}+   {-# LINE 637 "src-ag/Order.ag" #-}+   rule103 = \ aroundsMap_ ->+                               {-# LINE 637 "src-ag/Order.ag" #-}+                               Map.map (Map.map Map.keysSet) aroundsMap_+                               {-# LINE 1135 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule104 #-}+   {-# LINE 638 "src-ag/Order.ag" #-}+   rule104 = \ mergeMap_ ->+                               {-# LINE 638 "src-ag/Order.ag" #-}+                               Map.map (Map.map (Map.map (\(nt,srcs,_) -> (nt,srcs)))) mergeMap_+                               {-# LINE 1141 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule105 #-}+   {-# LINE 655 "src-ag/Order.ag" #-}+   rule105 = \ ((_nontsInonts) :: [(NontermIdent,[ConstructorIdent])]) ->+                             {-# LINE 655 "src-ag/Order.ag" #-}+                             map fst (_nontsInonts)+                             {-# LINE 1147 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule106 #-}+   {-# LINE 22 "src-ag/TfmToMirage.ag" #-}+   rule106 = \ ((_nontsImirages) :: [Mirage.Nonterminal]) ->+                           {-# LINE 22 "src-ag/TfmToMirage.ag" #-}+                           Mirage.Grammar _nontsImirages+                           {-# LINE 1153 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule107 #-}+   rule107 = \ ((_nontsInAutoRules) :: Int) ->+     _nontsInAutoRules+   {-# INLINE rule108 #-}+   rule108 = \ ((_nontsInExplicitRules) :: Int) ->+     _nontsInExplicitRules+   {-# INLINE rule109 #-}+   rule109 = \ _cInterfaceMap ->+     _cInterfaceMap+   {-# INLINE rule110 #-}+   rule110 = \ _cVisitsMap ->+     _cVisitsMap+   {-# INLINE rule111 #-}+   rule111 = \ _mergeMap ->+     _mergeMap+   {-# INLINE rule112 #-}+   rule112 = \ _o_dovisit ->+     _o_dovisit+   {-# INLINE rule113 #-}+   rule113 = \ ((_lhsIoptions) :: Options) ->+     _lhsIoptions++-- Nonterminal -------------------------------------------------+-- wrapper+data Inh_Nonterminal  = Inh_Nonterminal { acount_Inh_Nonterminal :: (Int), allnts_Inh_Nonterminal :: ([Identifier]), aroundMap_Inh_Nonterminal :: (Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))), cInterfaceMap_Inh_Nonterminal :: (CInterfaceMap), cVisitsMap_Inh_Nonterminal :: (CVisitsMap), inhMap_Inh_Nonterminal :: (Map Identifier Attributes), manualAttrDepMap_Inh_Nonterminal :: (AttrOrderMap), mergeMap_Inh_Nonterminal :: (Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))), 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), options_Inh_Nonterminal :: (Options), prefix_Inh_Nonterminal :: (String), synMap_Inh_Nonterminal :: (Map Identifier Attributes), 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)), aroundDep_Syn_Nonterminal :: (Seq Edge), cNonterminal_Syn_Nonterminal :: (CNonterminal), directDep_Syn_Nonterminal :: (Seq Edge), errors_Syn_Nonterminal :: (Seq Error), inhMap'_Syn_Nonterminal :: (Map Identifier Attributes), instDep_Syn_Nonterminal :: (Seq Edge), mergeDep_Syn_Nonterminal :: (Seq Edge), mirage_Syn_Nonterminal :: (Mirage.Nonterminal), nAutoRules_Syn_Nonterminal :: (Int), nExplicitRules_Syn_Nonterminal :: (Int), nonts_Syn_Nonterminal :: ([(NontermIdent,[ConstructorIdent])]), ntattrs_Syn_Nonterminal :: (Seq (Vertex,NTAttr)), rules_Syn_Nonterminal :: (Seq (Vertex,CRule)), synMap'_Syn_Nonterminal :: (Map Identifier Attributes), vcount_Syn_Nonterminal :: (Int) }+{-# INLINABLE wrap_Nonterminal #-}+wrap_Nonterminal :: T_Nonterminal  -> Inh_Nonterminal  -> (Syn_Nonterminal )+wrap_Nonterminal (T_Nonterminal act) (Inh_Nonterminal _lhsIacount _lhsIallnts _lhsIaroundMap _lhsIcInterfaceMap _lhsIcVisitsMap _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsIo_case _lhsIo_cata _lhsIo_data _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsynMap _lhsIvcount) =+   Control.Monad.Identity.runIdentity (+     do sem <- act+        let arg13 = T_Nonterminal_vIn13 _lhsIacount _lhsIallnts _lhsIaroundMap _lhsIcInterfaceMap _lhsIcVisitsMap _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsIo_case _lhsIo_cata _lhsIo_data _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsynMap _lhsIvcount+        (T_Nonterminal_vOut13 _lhsOacount _lhsOadditionalDep _lhsOaranges _lhsOaroundDep _lhsOcNonterminal _lhsOdirectDep _lhsOerrors _lhsOinhMap' _lhsOinstDep _lhsOmergeDep _lhsOmirage _lhsOnAutoRules _lhsOnExplicitRules _lhsOnonts _lhsOntattrs _lhsOrules _lhsOsynMap' _lhsOvcount) <- return (inv_Nonterminal_s14 sem arg13)+        return (Syn_Nonterminal _lhsOacount _lhsOadditionalDep _lhsOaranges _lhsOaroundDep _lhsOcNonterminal _lhsOdirectDep _lhsOerrors _lhsOinhMap' _lhsOinstDep _lhsOmergeDep _lhsOmirage _lhsOnAutoRules _lhsOnExplicitRules _lhsOnonts _lhsOntattrs _lhsOrules _lhsOsynMap' _lhsOvcount)+   )++-- cata+{-# INLINE sem_Nonterminal #-}+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 {+                                       attach_T_Nonterminal :: Identity (T_Nonterminal_s14 )+                                       }+newtype T_Nonterminal_s14  = C_Nonterminal_s14 {+                                               inv_Nonterminal_s14 :: (T_Nonterminal_v13 )+                                               }+data T_Nonterminal_s15  = C_Nonterminal_s15+type T_Nonterminal_v13  = (T_Nonterminal_vIn13 ) -> (T_Nonterminal_vOut13 )+data T_Nonterminal_vIn13  = T_Nonterminal_vIn13 (Int) ([Identifier]) (Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) (CInterfaceMap) (CVisitsMap) (Map Identifier Attributes) (AttrOrderMap) (Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Options) (String) (Map Identifier Attributes) (Int)+data T_Nonterminal_vOut13  = T_Nonterminal_vOut13 (Int) (Seq Edge) (Seq (Int,Int,Int)) (Seq Edge) (CNonterminal) (Seq Edge) (Seq Error) (Map Identifier Attributes) (Seq Edge) (Seq Edge) (Mirage.Nonterminal) (Int) (Int) ([(NontermIdent,[ConstructorIdent])]) (Seq (Vertex,NTAttr)) (Seq (Vertex,CRule)) (Map Identifier Attributes) (Int)+{-# NOINLINE sem_Nonterminal_Nonterminal #-}+sem_Nonterminal_Nonterminal :: (NontermIdent) -> ([Identifier]) -> (Attributes) -> (Attributes) -> T_Productions  -> T_Nonterminal +sem_Nonterminal_Nonterminal arg_nt_ arg_params_ arg_inh_ arg_syn_ arg_prods_ = T_Nonterminal (return st14) where+   {-# NOINLINE st14 #-}+   st14 = let+      v13 :: T_Nonterminal_v13 +      v13 = \ (T_Nonterminal_vIn13 _lhsIacount _lhsIallnts _lhsIaroundMap _lhsIcInterfaceMap _lhsIcVisitsMap _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsIo_case _lhsIo_cata _lhsIo_data _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsynMap _lhsIvcount) -> ( let+         _prodsX29 = Control.Monad.Identity.runIdentity (attach_T_Productions (arg_prods_))+         (T_Productions_vOut28 _prodsIadditionalDep _prodsIaroundDep _prodsIcProductions _prodsIcons _prodsIdirectDep _prodsIerrors _prodsIinstDep _prodsImergeDep _prodsImirages _prodsInAutoRules _prodsInExplicitRules _prodsIrules _prodsIvcount) = inv_Productions_s29 _prodsX29 (T_Productions_vIn28 _prodsOallnts _prodsOaroundMap _prodsOcVisitsMap _prodsOinh _prodsOinhMap _prodsOmanualAttrDepMap _prodsOmergeMap _prodsOnt _prodsOo_case _prodsOo_cata _prodsOo_dovisit _prodsOo_newtypes _prodsOo_rename _prodsOo_sem _prodsOo_sig _prodsOo_unbox _prodsOo_wantvisit _prodsOoptions _prodsOprefix _prodsOsyn _prodsOsynMap _prodsOvcount)+         _lhsOinhMap' :: Map Identifier Attributes+         _lhsOinhMap' = rule114 arg_inh_ arg_nt_+         _lhsOsynMap' :: Map Identifier Attributes+         _lhsOsynMap' = rule115 arg_nt_ arg_syn_+         _prodsOnt = rule116 arg_nt_+         _prodsOinh = rule117 arg_inh_+         _prodsOsyn = rule118 arg_syn_+         _mergeMap = rule119 _lhsImergeMap arg_nt_+         _aroundMap = rule120 _lhsIaroundMap arg_nt_+         _ntattrs = rule121 arg_inh_ arg_nt_ arg_syn_+         _lhsOntattrs :: Seq (Vertex,NTAttr)+         _lhsOntattrs = rule122 _lhsIacount _ntattrs+         _lhsOacount :: Int+         _lhsOacount = rule123 _lhsIacount arg_inh_ arg_syn_+         _lhsOaranges :: Seq (Int,Int,Int)+         _lhsOaranges = rule124 _lhsIacount arg_inh_ arg_syn_+         _lhsOnonts :: [(NontermIdent,[ConstructorIdent])]+         _lhsOnonts = rule125 _prodsIcons arg_nt_+         _cInter = rule126 _lhsIcInterfaceMap _lhsIo_dovisit arg_inh_ arg_nt_ arg_syn_+         _lhsOcNonterminal :: CNonterminal+         _lhsOcNonterminal = rule127 _cInter _prodsIcProductions arg_inh_ arg_nt_ arg_params_ arg_syn_+         _lhsOmirage :: Mirage.Nonterminal+         _lhsOmirage = rule128 _prodsImirages arg_inh_ arg_nt_ arg_params_ arg_syn_+         _lhsOadditionalDep :: Seq Edge+         _lhsOadditionalDep = rule129 _prodsIadditionalDep+         _lhsOaroundDep :: Seq Edge+         _lhsOaroundDep = rule130 _prodsIaroundDep+         _lhsOdirectDep :: Seq Edge+         _lhsOdirectDep = rule131 _prodsIdirectDep+         _lhsOerrors :: Seq Error+         _lhsOerrors = rule132 _prodsIerrors+         _lhsOinstDep :: Seq Edge+         _lhsOinstDep = rule133 _prodsIinstDep+         _lhsOmergeDep :: Seq Edge+         _lhsOmergeDep = rule134 _prodsImergeDep+         _lhsOnAutoRules :: Int+         _lhsOnAutoRules = rule135 _prodsInAutoRules+         _lhsOnExplicitRules :: Int+         _lhsOnExplicitRules = rule136 _prodsInExplicitRules+         _lhsOrules :: Seq (Vertex,CRule)+         _lhsOrules = rule137 _prodsIrules+         _lhsOvcount :: Int+         _lhsOvcount = rule138 _prodsIvcount+         _prodsOallnts = rule139 _lhsIallnts+         _prodsOaroundMap = rule140 _aroundMap+         _prodsOcVisitsMap = rule141 _lhsIcVisitsMap+         _prodsOinhMap = rule142 _lhsIinhMap+         _prodsOmanualAttrDepMap = rule143 _lhsImanualAttrDepMap+         _prodsOmergeMap = rule144 _mergeMap+         _prodsOo_case = rule145 _lhsIo_case+         _prodsOo_cata = rule146 _lhsIo_cata+         _prodsOo_dovisit = rule147 _lhsIo_dovisit+         _prodsOo_newtypes = rule148 _lhsIo_newtypes+         _prodsOo_rename = rule149 _lhsIo_rename+         _prodsOo_sem = rule150 _lhsIo_sem+         _prodsOo_sig = rule151 _lhsIo_sig+         _prodsOo_unbox = rule152 _lhsIo_unbox+         _prodsOo_wantvisit = rule153 _lhsIo_wantvisit+         _prodsOoptions = rule154 _lhsIoptions+         _prodsOprefix = rule155 _lhsIprefix+         _prodsOsynMap = rule156 _lhsIsynMap+         _prodsOvcount = rule157 _lhsIvcount+         __result_ = T_Nonterminal_vOut13 _lhsOacount _lhsOadditionalDep _lhsOaranges _lhsOaroundDep _lhsOcNonterminal _lhsOdirectDep _lhsOerrors _lhsOinhMap' _lhsOinstDep _lhsOmergeDep _lhsOmirage _lhsOnAutoRules _lhsOnExplicitRules _lhsOnonts _lhsOntattrs _lhsOrules _lhsOsynMap' _lhsOvcount+         in __result_ )+     in C_Nonterminal_s14 v13+   {-# INLINE rule114 #-}+   {-# LINE 7 "src-ag/DistChildAttr.ag" #-}+   rule114 = \ inh_ nt_ ->+                                 {-# LINE 7 "src-ag/DistChildAttr.ag" #-}+                                 Map.singleton nt_ inh_+                                 {-# LINE 1285 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule115 #-}+   {-# LINE 8 "src-ag/DistChildAttr.ag" #-}+   rule115 = \ nt_ syn_ ->+                                 {-# LINE 8 "src-ag/DistChildAttr.ag" #-}+                                 Map.singleton nt_ syn_+                                 {-# LINE 1291 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule116 #-}+   {-# LINE 97 "src-ag/Order.ag" #-}+   rule116 = \ nt_ ->+                               {-# LINE 97 "src-ag/Order.ag" #-}+                               nt_+                               {-# LINE 1297 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule117 #-}+   {-# LINE 100 "src-ag/Order.ag" #-}+   rule117 = \ inh_ ->+                               {-# LINE 100 "src-ag/Order.ag" #-}+                               inh_+                               {-# LINE 1303 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule118 #-}+   {-# LINE 101 "src-ag/Order.ag" #-}+   rule118 = \ syn_ ->+                               {-# LINE 101 "src-ag/Order.ag" #-}+                               syn_+                               {-# LINE 1309 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule119 #-}+   {-# LINE 360 "src-ag/Order.ag" #-}+   rule119 = \ ((_lhsImergeMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))) nt_ ->+                                                {-# LINE 360 "src-ag/Order.ag" #-}+                                                Map.findWithDefault Map.empty nt_ _lhsImergeMap+                                                {-# LINE 1315 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule120 #-}+   {-# LINE 413 "src-ag/Order.ag" #-}+   rule120 = \ ((_lhsIaroundMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) nt_ ->+                                                 {-# LINE 413 "src-ag/Order.ag" #-}+                                                 Map.findWithDefault Map.empty nt_ _lhsIaroundMap+                                                 {-# LINE 1321 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule121 #-}+   {-# LINE 511 "src-ag/Order.ag" #-}+   rule121 = \ inh_ nt_ syn_ ->+                                 {-# LINE 511 "src-ag/Order.ag" #-}+                                 [ NTAInh nt_ inh tp | (inh,tp) <- Map.assocs inh_ ]+                                 ++ [NTASyn nt_ syn tp | (syn,tp) <- Map.assocs syn_ ]+                                 {-# LINE 1328 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule122 #-}+   {-# LINE 513 "src-ag/Order.ag" #-}+   rule122 = \ ((_lhsIacount) :: Int) _ntattrs ->+                                {-# LINE 513 "src-ag/Order.ag" #-}+                                Seq.fromList (zip [_lhsIacount ..] _ntattrs)+                                {-# LINE 1334 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule123 #-}+   {-# LINE 514 "src-ag/Order.ag" #-}+   rule123 = \ ((_lhsIacount) :: Int) inh_ syn_ ->+                                {-# LINE 514 "src-ag/Order.ag" #-}+                                _lhsIacount + Map.size inh_ + Map.size syn_+                                {-# LINE 1340 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule124 #-}+   {-# LINE 515 "src-ag/Order.ag" #-}+   rule124 = \ ((_lhsIacount) :: Int) inh_ syn_ ->+                                 {-# LINE 515 "src-ag/Order.ag" #-}+                                 Seq.singleton+                                  (_lhsIacount+                                  ,_lhsIacount + Map.size inh_+                                  ,_lhsIacount + Map.size syn_ + Map.size inh_ - 1)+                                 {-# LINE 1349 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule125 #-}+   {-# LINE 524 "src-ag/Order.ag" #-}+   rule125 = \ ((_prodsIcons) :: [ConstructorIdent]) nt_ ->+                                {-# LINE 524 "src-ag/Order.ag" #-}+                                [(nt_,_prodsIcons)]+                                {-# LINE 1355 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule126 #-}+   {-# LINE 601 "src-ag/Order.ag" #-}+   rule126 = \ ((_lhsIcInterfaceMap) :: CInterfaceMap) ((_lhsIo_dovisit) :: Bool) inh_ nt_ syn_ ->+                                 {-# LINE 601 "src-ag/Order.ag" #-}+                                 if  _lhsIo_dovisit+                                        then findWithErr1 "Nonterminal.cInter" nt_ _lhsIcInterfaceMap+                                        else CInterface [CSegment inh_ syn_]+                                 {-# LINE 1363 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule127 #-}+   {-# LINE 629 "src-ag/Order.ag" #-}+   rule127 = \ _cInter ((_prodsIcProductions) :: CProductions) inh_ nt_ params_ syn_ ->+                                       {-# LINE 629 "src-ag/Order.ag" #-}+                                       CNonterminal nt_ params_ inh_ syn_ _prodsIcProductions _cInter+                                       {-# LINE 1369 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule128 #-}+   {-# LINE 30 "src-ag/TfmToMirage.ag" #-}+   rule128 = \ ((_prodsImirages) :: [Mirage.Production]) inh_ nt_ params_ syn_ ->+          {-# LINE 30 "src-ag/TfmToMirage.ag" #-}+          Mirage.Nonterminal+            (getName nt_)+            (map getName params_)+            (Map.foldrWithKey (\k x xs -> Mirage.Attribute (getName k) (typeToMirage x) : xs) [] inh_)+            (Map.foldrWithKey (\k x xs -> Mirage.Attribute (getName k) (typeToMirage x) : xs) [] syn_)+            _prodsImirages+          {-# LINE 1380 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule129 #-}+   rule129 = \ ((_prodsIadditionalDep) :: Seq Edge) ->+     _prodsIadditionalDep+   {-# INLINE rule130 #-}+   rule130 = \ ((_prodsIaroundDep) :: Seq Edge) ->+     _prodsIaroundDep+   {-# INLINE rule131 #-}+   rule131 = \ ((_prodsIdirectDep) :: Seq Edge) ->+     _prodsIdirectDep+   {-# INLINE rule132 #-}+   rule132 = \ ((_prodsIerrors) :: Seq Error) ->+     _prodsIerrors+   {-# INLINE rule133 #-}+   rule133 = \ ((_prodsIinstDep) :: Seq Edge) ->+     _prodsIinstDep+   {-# INLINE rule134 #-}+   rule134 = \ ((_prodsImergeDep) :: Seq Edge) ->+     _prodsImergeDep+   {-# INLINE rule135 #-}+   rule135 = \ ((_prodsInAutoRules) :: Int) ->+     _prodsInAutoRules+   {-# INLINE rule136 #-}+   rule136 = \ ((_prodsInExplicitRules) :: Int) ->+     _prodsInExplicitRules+   {-# INLINE rule137 #-}+   rule137 = \ ((_prodsIrules) :: Seq (Vertex,CRule)) ->+     _prodsIrules+   {-# INLINE rule138 #-}+   rule138 = \ ((_prodsIvcount) :: Int) ->+     _prodsIvcount+   {-# INLINE rule139 #-}+   rule139 = \ ((_lhsIallnts) :: [Identifier]) ->+     _lhsIallnts+   {-# INLINE rule140 #-}+   rule140 = \ _aroundMap ->+     _aroundMap+   {-# INLINE rule141 #-}+   rule141 = \ ((_lhsIcVisitsMap) :: CVisitsMap) ->+     _lhsIcVisitsMap+   {-# INLINE rule142 #-}+   rule142 = \ ((_lhsIinhMap) :: Map Identifier Attributes) ->+     _lhsIinhMap+   {-# INLINE rule143 #-}+   rule143 = \ ((_lhsImanualAttrDepMap) :: AttrOrderMap) ->+     _lhsImanualAttrDepMap+   {-# INLINE rule144 #-}+   rule144 = \ _mergeMap ->+     _mergeMap+   {-# INLINE rule145 #-}+   rule145 = \ ((_lhsIo_case) :: Bool) ->+     _lhsIo_case+   {-# INLINE rule146 #-}+   rule146 = \ ((_lhsIo_cata) :: Bool) ->+     _lhsIo_cata+   {-# INLINE rule147 #-}+   rule147 = \ ((_lhsIo_dovisit) :: Bool) ->+     _lhsIo_dovisit+   {-# INLINE rule148 #-}+   rule148 = \ ((_lhsIo_newtypes) :: Bool) ->+     _lhsIo_newtypes+   {-# INLINE rule149 #-}+   rule149 = \ ((_lhsIo_rename) :: Bool) ->+     _lhsIo_rename+   {-# INLINE rule150 #-}+   rule150 = \ ((_lhsIo_sem) :: Bool) ->+     _lhsIo_sem+   {-# INLINE rule151 #-}+   rule151 = \ ((_lhsIo_sig) :: Bool) ->+     _lhsIo_sig+   {-# INLINE rule152 #-}+   rule152 = \ ((_lhsIo_unbox) :: Bool) ->+     _lhsIo_unbox+   {-# INLINE rule153 #-}+   rule153 = \ ((_lhsIo_wantvisit) :: Bool) ->+     _lhsIo_wantvisit+   {-# INLINE rule154 #-}+   rule154 = \ ((_lhsIoptions) :: Options) ->+     _lhsIoptions+   {-# INLINE rule155 #-}+   rule155 = \ ((_lhsIprefix) :: String) ->+     _lhsIprefix+   {-# INLINE rule156 #-}+   rule156 = \ ((_lhsIsynMap) :: Map Identifier Attributes) ->+     _lhsIsynMap+   {-# INLINE rule157 #-}+   rule157 = \ ((_lhsIvcount) :: Int) ->+     _lhsIvcount++-- Nonterminals ------------------------------------------------+-- wrapper+data Inh_Nonterminals  = Inh_Nonterminals { acount_Inh_Nonterminals :: (Int), allnts_Inh_Nonterminals :: ([Identifier]), aroundMap_Inh_Nonterminals :: (Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))), cInterfaceMap_Inh_Nonterminals :: (CInterfaceMap), cVisitsMap_Inh_Nonterminals :: (CVisitsMap), inhMap_Inh_Nonterminals :: (Map Identifier Attributes), manualAttrDepMap_Inh_Nonterminals :: (AttrOrderMap), mergeMap_Inh_Nonterminals :: (Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))), 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), options_Inh_Nonterminals :: (Options), prefix_Inh_Nonterminals :: (String), synMap_Inh_Nonterminals :: (Map Identifier Attributes), 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)), aroundDep_Syn_Nonterminals :: (Seq Edge), cNonterminals_Syn_Nonterminals :: (CNonterminals), directDep_Syn_Nonterminals :: (Seq Edge), errors_Syn_Nonterminals :: (Seq Error), inhMap'_Syn_Nonterminals :: (Map Identifier Attributes), instDep_Syn_Nonterminals :: (Seq Edge), mergeDep_Syn_Nonterminals :: (Seq Edge), mirages_Syn_Nonterminals :: ([Mirage.Nonterminal]), nAutoRules_Syn_Nonterminals :: (Int), nExplicitRules_Syn_Nonterminals :: (Int), nonts_Syn_Nonterminals :: ([(NontermIdent,[ConstructorIdent])]), ntattrs_Syn_Nonterminals :: (Seq (Vertex,NTAttr)), rules_Syn_Nonterminals :: (Seq (Vertex,CRule)), synMap'_Syn_Nonterminals :: (Map Identifier Attributes), vcount_Syn_Nonterminals :: (Int) }+{-# INLINABLE wrap_Nonterminals #-}+wrap_Nonterminals :: T_Nonterminals  -> Inh_Nonterminals  -> (Syn_Nonterminals )+wrap_Nonterminals (T_Nonterminals act) (Inh_Nonterminals _lhsIacount _lhsIallnts _lhsIaroundMap _lhsIcInterfaceMap _lhsIcVisitsMap _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsIo_case _lhsIo_cata _lhsIo_data _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsynMap _lhsIvcount) =+   Control.Monad.Identity.runIdentity (+     do sem <- act+        let arg16 = T_Nonterminals_vIn16 _lhsIacount _lhsIallnts _lhsIaroundMap _lhsIcInterfaceMap _lhsIcVisitsMap _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsIo_case _lhsIo_cata _lhsIo_data _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsynMap _lhsIvcount+        (T_Nonterminals_vOut16 _lhsOacount _lhsOadditionalDep _lhsOaranges _lhsOaroundDep _lhsOcNonterminals _lhsOdirectDep _lhsOerrors _lhsOinhMap' _lhsOinstDep _lhsOmergeDep _lhsOmirages _lhsOnAutoRules _lhsOnExplicitRules _lhsOnonts _lhsOntattrs _lhsOrules _lhsOsynMap' _lhsOvcount) <- return (inv_Nonterminals_s17 sem arg16)+        return (Syn_Nonterminals _lhsOacount _lhsOadditionalDep _lhsOaranges _lhsOaroundDep _lhsOcNonterminals _lhsOdirectDep _lhsOerrors _lhsOinhMap' _lhsOinstDep _lhsOmergeDep _lhsOmirages _lhsOnAutoRules _lhsOnExplicitRules _lhsOnonts _lhsOntattrs _lhsOrules _lhsOsynMap' _lhsOvcount)+   )++-- cata+{-# NOINLINE sem_Nonterminals #-}+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 {+                                         attach_T_Nonterminals :: Identity (T_Nonterminals_s17 )+                                         }+newtype T_Nonterminals_s17  = C_Nonterminals_s17 {+                                                 inv_Nonterminals_s17 :: (T_Nonterminals_v16 )+                                                 }+data T_Nonterminals_s18  = C_Nonterminals_s18+type T_Nonterminals_v16  = (T_Nonterminals_vIn16 ) -> (T_Nonterminals_vOut16 )+data T_Nonterminals_vIn16  = T_Nonterminals_vIn16 (Int) ([Identifier]) (Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) (CInterfaceMap) (CVisitsMap) (Map Identifier Attributes) (AttrOrderMap) (Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Options) (String) (Map Identifier Attributes) (Int)+data T_Nonterminals_vOut16  = T_Nonterminals_vOut16 (Int) (Seq Edge) (Seq (Int,Int,Int)) (Seq Edge) (CNonterminals) (Seq Edge) (Seq Error) (Map Identifier Attributes) (Seq Edge) (Seq Edge) ([Mirage.Nonterminal]) (Int) (Int) ([(NontermIdent,[ConstructorIdent])]) (Seq (Vertex,NTAttr)) (Seq (Vertex,CRule)) (Map Identifier Attributes) (Int)+{-# NOINLINE sem_Nonterminals_Cons #-}+sem_Nonterminals_Cons :: T_Nonterminal  -> T_Nonterminals  -> T_Nonterminals +sem_Nonterminals_Cons arg_hd_ arg_tl_ = T_Nonterminals (return st17) where+   {-# NOINLINE st17 #-}+   st17 = let+      v16 :: T_Nonterminals_v16 +      v16 = \ (T_Nonterminals_vIn16 _lhsIacount _lhsIallnts _lhsIaroundMap _lhsIcInterfaceMap _lhsIcVisitsMap _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsIo_case _lhsIo_cata _lhsIo_data _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsynMap _lhsIvcount) -> ( let+         _hdX14 = Control.Monad.Identity.runIdentity (attach_T_Nonterminal (arg_hd_))+         _tlX17 = Control.Monad.Identity.runIdentity (attach_T_Nonterminals (arg_tl_))+         (T_Nonterminal_vOut13 _hdIacount _hdIadditionalDep _hdIaranges _hdIaroundDep _hdIcNonterminal _hdIdirectDep _hdIerrors _hdIinhMap' _hdIinstDep _hdImergeDep _hdImirage _hdInAutoRules _hdInExplicitRules _hdInonts _hdIntattrs _hdIrules _hdIsynMap' _hdIvcount) = inv_Nonterminal_s14 _hdX14 (T_Nonterminal_vIn13 _hdOacount _hdOallnts _hdOaroundMap _hdOcInterfaceMap _hdOcVisitsMap _hdOinhMap _hdOmanualAttrDepMap _hdOmergeMap _hdOo_case _hdOo_cata _hdOo_data _hdOo_dovisit _hdOo_newtypes _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_unbox _hdOo_wantvisit _hdOoptions _hdOprefix _hdOsynMap _hdOvcount)+         (T_Nonterminals_vOut16 _tlIacount _tlIadditionalDep _tlIaranges _tlIaroundDep _tlIcNonterminals _tlIdirectDep _tlIerrors _tlIinhMap' _tlIinstDep _tlImergeDep _tlImirages _tlInAutoRules _tlInExplicitRules _tlInonts _tlIntattrs _tlIrules _tlIsynMap' _tlIvcount) = inv_Nonterminals_s17 _tlX17 (T_Nonterminals_vIn16 _tlOacount _tlOallnts _tlOaroundMap _tlOcInterfaceMap _tlOcVisitsMap _tlOinhMap _tlOmanualAttrDepMap _tlOmergeMap _tlOo_case _tlOo_cata _tlOo_data _tlOo_dovisit _tlOo_newtypes _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_unbox _tlOo_wantvisit _tlOoptions _tlOprefix _tlOsynMap _tlOvcount)+         _lhsOcNonterminals :: CNonterminals+         _lhsOcNonterminals = rule158 _hdIcNonterminal _tlIcNonterminals+         _lhsOmirages :: [Mirage.Nonterminal]+         _lhsOmirages = rule159 _hdImirage _tlImirages+         _lhsOadditionalDep :: Seq Edge+         _lhsOadditionalDep = rule160 _hdIadditionalDep _tlIadditionalDep+         _lhsOaranges :: Seq (Int,Int,Int)+         _lhsOaranges = rule161 _hdIaranges _tlIaranges+         _lhsOaroundDep :: Seq Edge+         _lhsOaroundDep = rule162 _hdIaroundDep _tlIaroundDep+         _lhsOdirectDep :: Seq Edge+         _lhsOdirectDep = rule163 _hdIdirectDep _tlIdirectDep+         _lhsOerrors :: Seq Error+         _lhsOerrors = rule164 _hdIerrors _tlIerrors+         _lhsOinhMap' :: Map Identifier Attributes+         _lhsOinhMap' = rule165 _hdIinhMap' _tlIinhMap'+         _lhsOinstDep :: Seq Edge+         _lhsOinstDep = rule166 _hdIinstDep _tlIinstDep+         _lhsOmergeDep :: Seq Edge+         _lhsOmergeDep = rule167 _hdImergeDep _tlImergeDep+         _lhsOnAutoRules :: Int+         _lhsOnAutoRules = rule168 _hdInAutoRules _tlInAutoRules+         _lhsOnExplicitRules :: Int+         _lhsOnExplicitRules = rule169 _hdInExplicitRules _tlInExplicitRules+         _lhsOnonts :: [(NontermIdent,[ConstructorIdent])]+         _lhsOnonts = rule170 _hdInonts _tlInonts+         _lhsOntattrs :: Seq (Vertex,NTAttr)+         _lhsOntattrs = rule171 _hdIntattrs _tlIntattrs+         _lhsOrules :: Seq (Vertex,CRule)+         _lhsOrules = rule172 _hdIrules _tlIrules+         _lhsOsynMap' :: Map Identifier Attributes+         _lhsOsynMap' = rule173 _hdIsynMap' _tlIsynMap'+         _lhsOacount :: Int+         _lhsOacount = rule174 _tlIacount+         _lhsOvcount :: Int+         _lhsOvcount = rule175 _tlIvcount+         _hdOacount = rule176 _lhsIacount+         _hdOallnts = rule177 _lhsIallnts+         _hdOaroundMap = rule178 _lhsIaroundMap+         _hdOcInterfaceMap = rule179 _lhsIcInterfaceMap+         _hdOcVisitsMap = rule180 _lhsIcVisitsMap+         _hdOinhMap = rule181 _lhsIinhMap+         _hdOmanualAttrDepMap = rule182 _lhsImanualAttrDepMap+         _hdOmergeMap = rule183 _lhsImergeMap+         _hdOo_case = rule184 _lhsIo_case+         _hdOo_cata = rule185 _lhsIo_cata+         _hdOo_data = rule186 _lhsIo_data+         _hdOo_dovisit = rule187 _lhsIo_dovisit+         _hdOo_newtypes = rule188 _lhsIo_newtypes+         _hdOo_rename = rule189 _lhsIo_rename+         _hdOo_sem = rule190 _lhsIo_sem+         _hdOo_sig = rule191 _lhsIo_sig+         _hdOo_unbox = rule192 _lhsIo_unbox+         _hdOo_wantvisit = rule193 _lhsIo_wantvisit+         _hdOoptions = rule194 _lhsIoptions+         _hdOprefix = rule195 _lhsIprefix+         _hdOsynMap = rule196 _lhsIsynMap+         _hdOvcount = rule197 _lhsIvcount+         _tlOacount = rule198 _hdIacount+         _tlOallnts = rule199 _lhsIallnts+         _tlOaroundMap = rule200 _lhsIaroundMap+         _tlOcInterfaceMap = rule201 _lhsIcInterfaceMap+         _tlOcVisitsMap = rule202 _lhsIcVisitsMap+         _tlOinhMap = rule203 _lhsIinhMap+         _tlOmanualAttrDepMap = rule204 _lhsImanualAttrDepMap+         _tlOmergeMap = rule205 _lhsImergeMap+         _tlOo_case = rule206 _lhsIo_case+         _tlOo_cata = rule207 _lhsIo_cata+         _tlOo_data = rule208 _lhsIo_data+         _tlOo_dovisit = rule209 _lhsIo_dovisit+         _tlOo_newtypes = rule210 _lhsIo_newtypes+         _tlOo_rename = rule211 _lhsIo_rename+         _tlOo_sem = rule212 _lhsIo_sem+         _tlOo_sig = rule213 _lhsIo_sig+         _tlOo_unbox = rule214 _lhsIo_unbox+         _tlOo_wantvisit = rule215 _lhsIo_wantvisit+         _tlOoptions = rule216 _lhsIoptions+         _tlOprefix = rule217 _lhsIprefix+         _tlOsynMap = rule218 _lhsIsynMap+         _tlOvcount = rule219 _hdIvcount+         __result_ = T_Nonterminals_vOut16 _lhsOacount _lhsOadditionalDep _lhsOaranges _lhsOaroundDep _lhsOcNonterminals _lhsOdirectDep _lhsOerrors _lhsOinhMap' _lhsOinstDep _lhsOmergeDep _lhsOmirages _lhsOnAutoRules _lhsOnExplicitRules _lhsOnonts _lhsOntattrs _lhsOrules _lhsOsynMap' _lhsOvcount+         in __result_ )+     in C_Nonterminals_s17 v16+   {-# INLINE rule158 #-}+   {-# LINE 626 "src-ag/Order.ag" #-}+   rule158 = \ ((_hdIcNonterminal) :: CNonterminal) ((_tlIcNonterminals) :: CNonterminals) ->+                                 {-# LINE 626 "src-ag/Order.ag" #-}+                                 _hdIcNonterminal : _tlIcNonterminals+                                 {-# LINE 1598 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule159 #-}+   {-# LINE 25 "src-ag/TfmToMirage.ag" #-}+   rule159 = \ ((_hdImirage) :: Mirage.Nonterminal) ((_tlImirages) :: [Mirage.Nonterminal]) ->+                         {-# LINE 25 "src-ag/TfmToMirage.ag" #-}+                         _hdImirage : _tlImirages+                         {-# LINE 1604 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule160 #-}+   rule160 = \ ((_hdIadditionalDep) :: Seq Edge) ((_tlIadditionalDep) :: Seq Edge) ->+     _hdIadditionalDep Seq.>< _tlIadditionalDep+   {-# INLINE rule161 #-}+   rule161 = \ ((_hdIaranges) :: Seq (Int,Int,Int)) ((_tlIaranges) :: Seq (Int,Int,Int)) ->+     _hdIaranges Seq.>< _tlIaranges+   {-# INLINE rule162 #-}+   rule162 = \ ((_hdIaroundDep) :: Seq Edge) ((_tlIaroundDep) :: Seq Edge) ->+     _hdIaroundDep Seq.>< _tlIaroundDep+   {-# INLINE rule163 #-}+   rule163 = \ ((_hdIdirectDep) :: Seq Edge) ((_tlIdirectDep) :: Seq Edge) ->+     _hdIdirectDep Seq.>< _tlIdirectDep+   {-# INLINE rule164 #-}+   rule164 = \ ((_hdIerrors) :: Seq Error) ((_tlIerrors) :: Seq Error) ->+     _hdIerrors Seq.>< _tlIerrors+   {-# INLINE rule165 #-}+   rule165 = \ ((_hdIinhMap') :: Map Identifier Attributes) ((_tlIinhMap') :: Map Identifier Attributes) ->+     _hdIinhMap' `Map.union` _tlIinhMap'+   {-# INLINE rule166 #-}+   rule166 = \ ((_hdIinstDep) :: Seq Edge) ((_tlIinstDep) :: Seq Edge) ->+     _hdIinstDep Seq.>< _tlIinstDep+   {-# INLINE rule167 #-}+   rule167 = \ ((_hdImergeDep) :: Seq Edge) ((_tlImergeDep) :: Seq Edge) ->+     _hdImergeDep Seq.>< _tlImergeDep+   {-# INLINE rule168 #-}+   rule168 = \ ((_hdInAutoRules) :: Int) ((_tlInAutoRules) :: Int) ->+     _hdInAutoRules + _tlInAutoRules+   {-# INLINE rule169 #-}+   rule169 = \ ((_hdInExplicitRules) :: Int) ((_tlInExplicitRules) :: Int) ->+     _hdInExplicitRules + _tlInExplicitRules+   {-# INLINE rule170 #-}+   rule170 = \ ((_hdInonts) :: [(NontermIdent,[ConstructorIdent])]) ((_tlInonts) :: [(NontermIdent,[ConstructorIdent])]) ->+     _hdInonts ++ _tlInonts+   {-# INLINE rule171 #-}+   rule171 = \ ((_hdIntattrs) :: Seq (Vertex,NTAttr)) ((_tlIntattrs) :: Seq (Vertex,NTAttr)) ->+     _hdIntattrs Seq.>< _tlIntattrs+   {-# INLINE rule172 #-}+   rule172 = \ ((_hdIrules) :: Seq (Vertex,CRule)) ((_tlIrules) :: Seq (Vertex,CRule)) ->+     _hdIrules Seq.>< _tlIrules+   {-# INLINE rule173 #-}+   rule173 = \ ((_hdIsynMap') :: Map Identifier Attributes) ((_tlIsynMap') :: Map Identifier Attributes) ->+     _hdIsynMap' `Map.union` _tlIsynMap'+   {-# INLINE rule174 #-}+   rule174 = \ ((_tlIacount) :: Int) ->+     _tlIacount+   {-# INLINE rule175 #-}+   rule175 = \ ((_tlIvcount) :: Int) ->+     _tlIvcount+   {-# INLINE rule176 #-}+   rule176 = \ ((_lhsIacount) :: Int) ->+     _lhsIacount+   {-# INLINE rule177 #-}+   rule177 = \ ((_lhsIallnts) :: [Identifier]) ->+     _lhsIallnts+   {-# INLINE rule178 #-}+   rule178 = \ ((_lhsIaroundMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) ->+     _lhsIaroundMap+   {-# INLINE rule179 #-}+   rule179 = \ ((_lhsIcInterfaceMap) :: CInterfaceMap) ->+     _lhsIcInterfaceMap+   {-# INLINE rule180 #-}+   rule180 = \ ((_lhsIcVisitsMap) :: CVisitsMap) ->+     _lhsIcVisitsMap+   {-# INLINE rule181 #-}+   rule181 = \ ((_lhsIinhMap) :: Map Identifier Attributes) ->+     _lhsIinhMap+   {-# INLINE rule182 #-}+   rule182 = \ ((_lhsImanualAttrDepMap) :: AttrOrderMap) ->+     _lhsImanualAttrDepMap+   {-# INLINE rule183 #-}+   rule183 = \ ((_lhsImergeMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))) ->+     _lhsImergeMap+   {-# INLINE rule184 #-}+   rule184 = \ ((_lhsIo_case) :: Bool) ->+     _lhsIo_case+   {-# INLINE rule185 #-}+   rule185 = \ ((_lhsIo_cata) :: Bool) ->+     _lhsIo_cata+   {-# INLINE rule186 #-}+   rule186 = \ ((_lhsIo_data) :: Bool) ->+     _lhsIo_data+   {-# INLINE rule187 #-}+   rule187 = \ ((_lhsIo_dovisit) :: Bool) ->+     _lhsIo_dovisit+   {-# INLINE rule188 #-}+   rule188 = \ ((_lhsIo_newtypes) :: Bool) ->+     _lhsIo_newtypes+   {-# INLINE rule189 #-}+   rule189 = \ ((_lhsIo_rename) :: Bool) ->+     _lhsIo_rename+   {-# INLINE rule190 #-}+   rule190 = \ ((_lhsIo_sem) :: Bool) ->+     _lhsIo_sem+   {-# INLINE rule191 #-}+   rule191 = \ ((_lhsIo_sig) :: Bool) ->+     _lhsIo_sig+   {-# INLINE rule192 #-}+   rule192 = \ ((_lhsIo_unbox) :: Bool) ->+     _lhsIo_unbox+   {-# INLINE rule193 #-}+   rule193 = \ ((_lhsIo_wantvisit) :: Bool) ->+     _lhsIo_wantvisit+   {-# INLINE rule194 #-}+   rule194 = \ ((_lhsIoptions) :: Options) ->+     _lhsIoptions+   {-# INLINE rule195 #-}+   rule195 = \ ((_lhsIprefix) :: String) ->+     _lhsIprefix+   {-# INLINE rule196 #-}+   rule196 = \ ((_lhsIsynMap) :: Map Identifier Attributes) ->+     _lhsIsynMap+   {-# INLINE rule197 #-}+   rule197 = \ ((_lhsIvcount) :: Int) ->+     _lhsIvcount+   {-# INLINE rule198 #-}+   rule198 = \ ((_hdIacount) :: Int) ->+     _hdIacount+   {-# INLINE rule199 #-}+   rule199 = \ ((_lhsIallnts) :: [Identifier]) ->+     _lhsIallnts+   {-# INLINE rule200 #-}+   rule200 = \ ((_lhsIaroundMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) ->+     _lhsIaroundMap+   {-# INLINE rule201 #-}+   rule201 = \ ((_lhsIcInterfaceMap) :: CInterfaceMap) ->+     _lhsIcInterfaceMap+   {-# INLINE rule202 #-}+   rule202 = \ ((_lhsIcVisitsMap) :: CVisitsMap) ->+     _lhsIcVisitsMap+   {-# INLINE rule203 #-}+   rule203 = \ ((_lhsIinhMap) :: Map Identifier Attributes) ->+     _lhsIinhMap+   {-# INLINE rule204 #-}+   rule204 = \ ((_lhsImanualAttrDepMap) :: AttrOrderMap) ->+     _lhsImanualAttrDepMap+   {-# INLINE rule205 #-}+   rule205 = \ ((_lhsImergeMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))) ->+     _lhsImergeMap+   {-# INLINE rule206 #-}+   rule206 = \ ((_lhsIo_case) :: Bool) ->+     _lhsIo_case+   {-# INLINE rule207 #-}+   rule207 = \ ((_lhsIo_cata) :: Bool) ->+     _lhsIo_cata+   {-# INLINE rule208 #-}+   rule208 = \ ((_lhsIo_data) :: Bool) ->+     _lhsIo_data+   {-# INLINE rule209 #-}+   rule209 = \ ((_lhsIo_dovisit) :: Bool) ->+     _lhsIo_dovisit+   {-# INLINE rule210 #-}+   rule210 = \ ((_lhsIo_newtypes) :: Bool) ->+     _lhsIo_newtypes+   {-# INLINE rule211 #-}+   rule211 = \ ((_lhsIo_rename) :: Bool) ->+     _lhsIo_rename+   {-# INLINE rule212 #-}+   rule212 = \ ((_lhsIo_sem) :: Bool) ->+     _lhsIo_sem+   {-# INLINE rule213 #-}+   rule213 = \ ((_lhsIo_sig) :: Bool) ->+     _lhsIo_sig+   {-# INLINE rule214 #-}+   rule214 = \ ((_lhsIo_unbox) :: Bool) ->+     _lhsIo_unbox+   {-# INLINE rule215 #-}+   rule215 = \ ((_lhsIo_wantvisit) :: Bool) ->+     _lhsIo_wantvisit+   {-# INLINE rule216 #-}+   rule216 = \ ((_lhsIoptions) :: Options) ->+     _lhsIoptions+   {-# INLINE rule217 #-}+   rule217 = \ ((_lhsIprefix) :: String) ->+     _lhsIprefix+   {-# INLINE rule218 #-}+   rule218 = \ ((_lhsIsynMap) :: Map Identifier Attributes) ->+     _lhsIsynMap+   {-# INLINE rule219 #-}+   rule219 = \ ((_hdIvcount) :: Int) ->+     _hdIvcount+{-# NOINLINE sem_Nonterminals_Nil #-}+sem_Nonterminals_Nil ::  T_Nonterminals +sem_Nonterminals_Nil  = T_Nonterminals (return st17) where+   {-# NOINLINE st17 #-}+   st17 = let+      v16 :: T_Nonterminals_v16 +      v16 = \ (T_Nonterminals_vIn16 _lhsIacount _lhsIallnts _lhsIaroundMap _lhsIcInterfaceMap _lhsIcVisitsMap _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsIo_case _lhsIo_cata _lhsIo_data _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsynMap _lhsIvcount) -> ( let+         _lhsOcNonterminals :: CNonterminals+         _lhsOcNonterminals = rule220  ()+         _lhsOmirages :: [Mirage.Nonterminal]+         _lhsOmirages = rule221  ()+         _lhsOadditionalDep :: Seq Edge+         _lhsOadditionalDep = rule222  ()+         _lhsOaranges :: Seq (Int,Int,Int)+         _lhsOaranges = rule223  ()+         _lhsOaroundDep :: Seq Edge+         _lhsOaroundDep = rule224  ()+         _lhsOdirectDep :: Seq Edge+         _lhsOdirectDep = rule225  ()+         _lhsOerrors :: Seq Error+         _lhsOerrors = rule226  ()+         _lhsOinhMap' :: Map Identifier Attributes+         _lhsOinhMap' = rule227  ()+         _lhsOinstDep :: Seq Edge+         _lhsOinstDep = rule228  ()+         _lhsOmergeDep :: Seq Edge+         _lhsOmergeDep = rule229  ()+         _lhsOnAutoRules :: Int+         _lhsOnAutoRules = rule230  ()+         _lhsOnExplicitRules :: Int+         _lhsOnExplicitRules = rule231  ()+         _lhsOnonts :: [(NontermIdent,[ConstructorIdent])]+         _lhsOnonts = rule232  ()+         _lhsOntattrs :: Seq (Vertex,NTAttr)+         _lhsOntattrs = rule233  ()+         _lhsOrules :: Seq (Vertex,CRule)+         _lhsOrules = rule234  ()+         _lhsOsynMap' :: Map Identifier Attributes+         _lhsOsynMap' = rule235  ()+         _lhsOacount :: Int+         _lhsOacount = rule236 _lhsIacount+         _lhsOvcount :: Int+         _lhsOvcount = rule237 _lhsIvcount+         __result_ = T_Nonterminals_vOut16 _lhsOacount _lhsOadditionalDep _lhsOaranges _lhsOaroundDep _lhsOcNonterminals _lhsOdirectDep _lhsOerrors _lhsOinhMap' _lhsOinstDep _lhsOmergeDep _lhsOmirages _lhsOnAutoRules _lhsOnExplicitRules _lhsOnonts _lhsOntattrs _lhsOrules _lhsOsynMap' _lhsOvcount+         in __result_ )+     in C_Nonterminals_s17 v16+   {-# INLINE rule220 #-}+   {-# LINE 627 "src-ag/Order.ag" #-}+   rule220 = \  (_ :: ()) ->+                                 {-# LINE 627 "src-ag/Order.ag" #-}+                                 []+                                 {-# LINE 1836 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule221 #-}+   {-# LINE 26 "src-ag/TfmToMirage.ag" #-}+   rule221 = \  (_ :: ()) ->+                         {-# LINE 26 "src-ag/TfmToMirage.ag" #-}+                         []+                         {-# LINE 1842 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule222 #-}+   rule222 = \  (_ :: ()) ->+     Seq.empty+   {-# INLINE rule223 #-}+   rule223 = \  (_ :: ()) ->+     Seq.empty+   {-# INLINE rule224 #-}+   rule224 = \  (_ :: ()) ->+     Seq.empty+   {-# INLINE rule225 #-}+   rule225 = \  (_ :: ()) ->+     Seq.empty+   {-# INLINE rule226 #-}+   rule226 = \  (_ :: ()) ->+     Seq.empty+   {-# INLINE rule227 #-}+   rule227 = \  (_ :: ()) ->+     Map.empty+   {-# INLINE rule228 #-}+   rule228 = \  (_ :: ()) ->+     Seq.empty+   {-# INLINE rule229 #-}+   rule229 = \  (_ :: ()) ->+     Seq.empty+   {-# INLINE rule230 #-}+   rule230 = \  (_ :: ()) ->+     0+   {-# INLINE rule231 #-}+   rule231 = \  (_ :: ()) ->+     0+   {-# INLINE rule232 #-}+   rule232 = \  (_ :: ()) ->+     []+   {-# INLINE rule233 #-}+   rule233 = \  (_ :: ()) ->+     Seq.empty+   {-# INLINE rule234 #-}+   rule234 = \  (_ :: ()) ->+     Seq.empty+   {-# INLINE rule235 #-}+   rule235 = \  (_ :: ()) ->+     Map.empty+   {-# INLINE rule236 #-}+   rule236 = \ ((_lhsIacount) :: Int) ->+     _lhsIacount+   {-# INLINE rule237 #-}+   rule237 = \ ((_lhsIvcount) :: Int) ->+     _lhsIvcount++-- Pattern -----------------------------------------------------+-- wrapper+data Inh_Pattern  = Inh_Pattern { allTypeSigs_Inh_Pattern :: (Map Identifier Type), altAttrs_Inh_Pattern :: (Map AltAttr Vertex), belowIrrefutable_Inh_Pattern :: (Bool), 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]), isUnderscore_Syn_Pattern :: (Bool), locVars_Syn_Pattern :: ([Identifier]), patternAttrs_Syn_Pattern :: ([(Identifier,Identifier,Bool)]), pp_Syn_Pattern :: (PP_Doc) }+{-# INLINABLE wrap_Pattern #-}+wrap_Pattern :: T_Pattern  -> Inh_Pattern  -> (Syn_Pattern )+wrap_Pattern (T_Pattern act) (Inh_Pattern _lhsIallTypeSigs _lhsIaltAttrs _lhsIbelowIrrefutable _lhsIcon _lhsIinh _lhsInt _lhsIsyn) =+   Control.Monad.Identity.runIdentity (+     do sem <- act+        let arg19 = T_Pattern_vIn19 _lhsIallTypeSigs _lhsIaltAttrs _lhsIbelowIrrefutable _lhsIcon _lhsIinh _lhsInt _lhsIsyn+        (T_Pattern_vOut19 _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOisUnderscore _lhsOlocVars _lhsOpatternAttrs _lhsOpp) <- return (inv_Pattern_s20 sem arg19)+        return (Syn_Pattern _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOisUnderscore _lhsOlocVars _lhsOpatternAttrs _lhsOpp)+   )++-- cata+{-# NOINLINE sem_Pattern #-}+sem_Pattern :: Pattern  -> T_Pattern +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 ( Alias field_ attr_ pat_ ) = sem_Pattern_Alias field_ attr_ ( sem_Pattern pat_ )+sem_Pattern ( Irrefutable pat_ ) = sem_Pattern_Irrefutable ( sem_Pattern pat_ )+sem_Pattern ( Underscore pos_ ) = sem_Pattern_Underscore pos_++-- semantic domain+newtype T_Pattern  = T_Pattern {+                               attach_T_Pattern :: Identity (T_Pattern_s20 )+                               }+newtype T_Pattern_s20  = C_Pattern_s20 {+                                       inv_Pattern_s20 :: (T_Pattern_v19 )+                                       }+data T_Pattern_s21  = C_Pattern_s21+type T_Pattern_v19  = (T_Pattern_vIn19 ) -> (T_Pattern_vOut19 )+data T_Pattern_vIn19  = T_Pattern_vIn19 (Map Identifier Type) (Map AltAttr Vertex) (Bool) (Identifier) (Attributes) (Identifier) (Attributes)+data T_Pattern_vOut19  = T_Pattern_vOut19 (Pattern) (Seq Error) ([AltAttr]) ([Identifier]) (Bool) ([Identifier]) ([(Identifier,Identifier,Bool)]) (PP_Doc)+{-# NOINLINE sem_Pattern_Constr #-}+sem_Pattern_Constr :: (ConstructorIdent) -> T_Patterns  -> T_Pattern +sem_Pattern_Constr arg_name_ arg_pats_ = T_Pattern (return st20) where+   {-# NOINLINE st20 #-}+   st20 = let+      v19 :: T_Pattern_v19 +      v19 = \ (T_Pattern_vIn19 _lhsIallTypeSigs _lhsIaltAttrs _lhsIbelowIrrefutable _lhsIcon _lhsIinh _lhsInt _lhsIsyn) -> ( let+         _patsX23 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_))+         (T_Patterns_vOut22 _patsIcopy _patsIerrors _patsIgathAltAttrs _patsIinstVars _patsIlocVars _patsIpatternAttrs _patsIpps) = inv_Patterns_s23 _patsX23 (T_Patterns_vIn22 _patsOallTypeSigs _patsOaltAttrs _patsObelowIrrefutable _patsOcon _patsOinh _patsOnt _patsOsyn)+         _lhsOpp :: PP_Doc+         _lhsOpp = rule238 _patsIpps arg_name_+         _lhsOisUnderscore :: Bool+         _lhsOisUnderscore = rule239  ()+         _lhsOerrors :: Seq Error+         _lhsOerrors = rule240 _patsIerrors+         _lhsOgathAltAttrs :: [AltAttr]+         _lhsOgathAltAttrs = rule241 _patsIgathAltAttrs+         _lhsOinstVars :: [Identifier]+         _lhsOinstVars = rule242 _patsIinstVars+         _lhsOlocVars :: [Identifier]+         _lhsOlocVars = rule243 _patsIlocVars+         _lhsOpatternAttrs :: [(Identifier,Identifier,Bool)]+         _lhsOpatternAttrs = rule244 _patsIpatternAttrs+         _copy = rule245 _patsIcopy arg_name_+         _lhsOcopy :: Pattern+         _lhsOcopy = rule246 _copy+         _patsOallTypeSigs = rule247 _lhsIallTypeSigs+         _patsOaltAttrs = rule248 _lhsIaltAttrs+         _patsObelowIrrefutable = rule249 _lhsIbelowIrrefutable+         _patsOcon = rule250 _lhsIcon+         _patsOinh = rule251 _lhsIinh+         _patsOnt = rule252 _lhsInt+         _patsOsyn = rule253 _lhsIsyn+         __result_ = T_Pattern_vOut19 _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOisUnderscore _lhsOlocVars _lhsOpatternAttrs _lhsOpp+         in __result_ )+     in C_Pattern_s20 v19+   {-# INLINE rule238 #-}+   {-# LINE 80 "src-ag/TfmToMirage.ag" #-}+   rule238 = \ ((_patsIpps) :: [PP_Doc]) name_ ->+                           {-# LINE 80 "src-ag/TfmToMirage.ag" #-}+                           pp_parens $ name_ >#< hv_sp _patsIpps+                           {-# LINE 1967 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule239 #-}+   {-# LINE 91 "src-ag/TfmToMirage.ag" #-}+   rule239 = \  (_ :: ()) ->+                                    {-# LINE 91 "src-ag/TfmToMirage.ag" #-}+                                    False+                                    {-# LINE 1973 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule240 #-}+   rule240 = \ ((_patsIerrors) :: Seq Error) ->+     _patsIerrors+   {-# INLINE rule241 #-}+   rule241 = \ ((_patsIgathAltAttrs) :: [AltAttr]) ->+     _patsIgathAltAttrs+   {-# INLINE rule242 #-}+   rule242 = \ ((_patsIinstVars) :: [Identifier]) ->+     _patsIinstVars+   {-# INLINE rule243 #-}+   rule243 = \ ((_patsIlocVars) :: [Identifier]) ->+     _patsIlocVars+   {-# INLINE rule244 #-}+   rule244 = \ ((_patsIpatternAttrs) :: [(Identifier,Identifier,Bool)]) ->+     _patsIpatternAttrs+   {-# INLINE rule245 #-}+   rule245 = \ ((_patsIcopy) :: Patterns) name_ ->+     Constr name_ _patsIcopy+   {-# INLINE rule246 #-}+   rule246 = \ _copy ->+     _copy+   {-# INLINE rule247 #-}+   rule247 = \ ((_lhsIallTypeSigs) :: Map Identifier Type) ->+     _lhsIallTypeSigs+   {-# INLINE rule248 #-}+   rule248 = \ ((_lhsIaltAttrs) :: Map AltAttr Vertex) ->+     _lhsIaltAttrs+   {-# INLINE rule249 #-}+   rule249 = \ ((_lhsIbelowIrrefutable) :: Bool) ->+     _lhsIbelowIrrefutable+   {-# INLINE rule250 #-}+   rule250 = \ ((_lhsIcon) :: Identifier) ->+     _lhsIcon+   {-# INLINE rule251 #-}+   rule251 = \ ((_lhsIinh) :: Attributes) ->+     _lhsIinh+   {-# INLINE rule252 #-}+   rule252 = \ ((_lhsInt) :: Identifier) ->+     _lhsInt+   {-# INLINE rule253 #-}+   rule253 = \ ((_lhsIsyn) :: Attributes) ->+     _lhsIsyn+{-# NOINLINE sem_Pattern_Product #-}+sem_Pattern_Product :: (Pos) -> T_Patterns  -> T_Pattern +sem_Pattern_Product arg_pos_ arg_pats_ = T_Pattern (return st20) where+   {-# NOINLINE st20 #-}+   st20 = let+      v19 :: T_Pattern_v19 +      v19 = \ (T_Pattern_vIn19 _lhsIallTypeSigs _lhsIaltAttrs _lhsIbelowIrrefutable _lhsIcon _lhsIinh _lhsInt _lhsIsyn) -> ( let+         _patsX23 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_))+         (T_Patterns_vOut22 _patsIcopy _patsIerrors _patsIgathAltAttrs _patsIinstVars _patsIlocVars _patsIpatternAttrs _patsIpps) = inv_Patterns_s23 _patsX23 (T_Patterns_vIn22 _patsOallTypeSigs _patsOaltAttrs _patsObelowIrrefutable _patsOcon _patsOinh _patsOnt _patsOsyn)+         _lhsOpp :: PP_Doc+         _lhsOpp = rule254 _patsIpps+         _lhsOisUnderscore :: Bool+         _lhsOisUnderscore = rule255  ()+         _lhsOerrors :: Seq Error+         _lhsOerrors = rule256 _patsIerrors+         _lhsOgathAltAttrs :: [AltAttr]+         _lhsOgathAltAttrs = rule257 _patsIgathAltAttrs+         _lhsOinstVars :: [Identifier]+         _lhsOinstVars = rule258 _patsIinstVars+         _lhsOlocVars :: [Identifier]+         _lhsOlocVars = rule259 _patsIlocVars+         _lhsOpatternAttrs :: [(Identifier,Identifier,Bool)]+         _lhsOpatternAttrs = rule260 _patsIpatternAttrs+         _copy = rule261 _patsIcopy arg_pos_+         _lhsOcopy :: Pattern+         _lhsOcopy = rule262 _copy+         _patsOallTypeSigs = rule263 _lhsIallTypeSigs+         _patsOaltAttrs = rule264 _lhsIaltAttrs+         _patsObelowIrrefutable = rule265 _lhsIbelowIrrefutable+         _patsOcon = rule266 _lhsIcon+         _patsOinh = rule267 _lhsIinh+         _patsOnt = rule268 _lhsInt+         _patsOsyn = rule269 _lhsIsyn+         __result_ = T_Pattern_vOut19 _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOisUnderscore _lhsOlocVars _lhsOpatternAttrs _lhsOpp+         in __result_ )+     in C_Pattern_s20 v19+   {-# INLINE rule254 #-}+   {-# LINE 81 "src-ag/TfmToMirage.ag" #-}+   rule254 = \ ((_patsIpps) :: [PP_Doc]) ->+                           {-# LINE 81 "src-ag/TfmToMirage.ag" #-}+                           pp_block "(" ")" "," _patsIpps+                           {-# LINE 2057 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule255 #-}+   {-# LINE 92 "src-ag/TfmToMirage.ag" #-}+   rule255 = \  (_ :: ()) ->+                                    {-# LINE 92 "src-ag/TfmToMirage.ag" #-}+                                    False+                                    {-# LINE 2063 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule256 #-}+   rule256 = \ ((_patsIerrors) :: Seq Error) ->+     _patsIerrors+   {-# INLINE rule257 #-}+   rule257 = \ ((_patsIgathAltAttrs) :: [AltAttr]) ->+     _patsIgathAltAttrs+   {-# INLINE rule258 #-}+   rule258 = \ ((_patsIinstVars) :: [Identifier]) ->+     _patsIinstVars+   {-# INLINE rule259 #-}+   rule259 = \ ((_patsIlocVars) :: [Identifier]) ->+     _patsIlocVars+   {-# INLINE rule260 #-}+   rule260 = \ ((_patsIpatternAttrs) :: [(Identifier,Identifier,Bool)]) ->+     _patsIpatternAttrs+   {-# INLINE rule261 #-}+   rule261 = \ ((_patsIcopy) :: Patterns) pos_ ->+     Product pos_ _patsIcopy+   {-# INLINE rule262 #-}+   rule262 = \ _copy ->+     _copy+   {-# INLINE rule263 #-}+   rule263 = \ ((_lhsIallTypeSigs) :: Map Identifier Type) ->+     _lhsIallTypeSigs+   {-# INLINE rule264 #-}+   rule264 = \ ((_lhsIaltAttrs) :: Map AltAttr Vertex) ->+     _lhsIaltAttrs+   {-# INLINE rule265 #-}+   rule265 = \ ((_lhsIbelowIrrefutable) :: Bool) ->+     _lhsIbelowIrrefutable+   {-# INLINE rule266 #-}+   rule266 = \ ((_lhsIcon) :: Identifier) ->+     _lhsIcon+   {-# INLINE rule267 #-}+   rule267 = \ ((_lhsIinh) :: Attributes) ->+     _lhsIinh+   {-# INLINE rule268 #-}+   rule268 = \ ((_lhsInt) :: Identifier) ->+     _lhsInt+   {-# INLINE rule269 #-}+   rule269 = \ ((_lhsIsyn) :: Attributes) ->+     _lhsIsyn+{-# NOINLINE sem_Pattern_Alias #-}+sem_Pattern_Alias :: (Identifier) -> (Identifier) -> T_Pattern  -> T_Pattern +sem_Pattern_Alias arg_field_ arg_attr_ arg_pat_ = T_Pattern (return st20) where+   {-# NOINLINE st20 #-}+   st20 = let+      v19 :: T_Pattern_v19 +      v19 = \ (T_Pattern_vIn19 _lhsIallTypeSigs _lhsIaltAttrs _lhsIbelowIrrefutable _lhsIcon _lhsIinh _lhsInt _lhsIsyn) -> ( let+         _patX20 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_))+         (T_Pattern_vOut19 _patIcopy _patIerrors _patIgathAltAttrs _patIinstVars _patIisUnderscore _patIlocVars _patIpatternAttrs _patIpp) = inv_Pattern_s20 _patX20 (T_Pattern_vIn19 _patOallTypeSigs _patOaltAttrs _patObelowIrrefutable _patOcon _patOinh _patOnt _patOsyn)+         _lhsOgathAltAttrs :: [AltAttr]+         _lhsOgathAltAttrs = rule270 arg_attr_ arg_field_+         _lhsOpatternAttrs :: [(Identifier,Identifier,Bool)]+         _lhsOpatternAttrs = rule271 arg_attr_ arg_field_+         _lhsOlocVars :: [Identifier]+         _lhsOlocVars = rule272 arg_attr_ arg_field_+         _lhsOinstVars :: [Identifier]+         _lhsOinstVars = rule273 arg_attr_ arg_field_+         _ppVar = rule274 arg_attr_ arg_field_+         _ppVarBang = rule275 _ppVar+         _lhsOpp :: PP_Doc+         _lhsOpp = rule276 _patIisUnderscore _patIpp _ppVarBang+         _lhsOisUnderscore :: Bool+         _lhsOisUnderscore = rule277  ()+         _lhsOerrors :: Seq Error+         _lhsOerrors = rule278 _patIerrors+         _copy = rule279 _patIcopy arg_attr_ arg_field_+         _lhsOcopy :: Pattern+         _lhsOcopy = rule280 _copy+         _patOallTypeSigs = rule281 _lhsIallTypeSigs+         _patOaltAttrs = rule282 _lhsIaltAttrs+         _patObelowIrrefutable = rule283 _lhsIbelowIrrefutable+         _patOcon = rule284 _lhsIcon+         _patOinh = rule285 _lhsIinh+         _patOnt = rule286 _lhsInt+         _patOsyn = rule287 _lhsIsyn+         __result_ = T_Pattern_vOut19 _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOisUnderscore _lhsOlocVars _lhsOpatternAttrs _lhsOpp+         in __result_ )+     in C_Pattern_s20 v19+   {-# INLINE rule270 #-}+   {-# LINE 187 "src-ag/Order.ag" #-}+   rule270 = \ attr_ field_ ->+                                {-# LINE 187 "src-ag/Order.ag" #-}+                                [AltAttr field_ attr_ (field_ == _LOC || field_ == _INST)]+                                {-# LINE 2149 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule271 #-}+   {-# LINE 253 "src-ag/Order.ag" #-}+   rule271 = \ attr_ field_ ->+                                {-# LINE 253 "src-ag/Order.ag" #-}+                                [(field_,attr_,(field_ == _LOC || field_ == _INST))]+                                {-# LINE 2155 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule272 #-}+   {-# LINE 685 "src-ag/Order.ag" #-}+   rule272 = \ attr_ field_ ->+                               {-# LINE 685 "src-ag/Order.ag" #-}+                               if field_ == _LOC+                                  then [attr_]+                                  else []+                               {-# LINE 2163 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule273 #-}+   {-# LINE 688 "src-ag/Order.ag" #-}+   rule273 = \ attr_ field_ ->+                               {-# LINE 688 "src-ag/Order.ag" #-}+                               if field_ == _INST+                                  then [attr_]+                                  else []+                               {-# LINE 2171 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule274 #-}+   {-# LINE 82 "src-ag/TfmToMirage.ag" #-}+   rule274 = \ attr_ field_ ->+                           {-# LINE 82 "src-ag/TfmToMirage.ag" #-}+                           pp field_ >|< "." >|< pp attr_+                           {-# LINE 2177 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule275 #-}+   {-# LINE 83 "src-ag/TfmToMirage.ag" #-}+   rule275 = \ _ppVar ->+                              {-# LINE 83 "src-ag/TfmToMirage.ag" #-}+                              _ppVar+                              {-# LINE 2183 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule276 #-}+   {-# LINE 84 "src-ag/TfmToMirage.ag" #-}+   rule276 = \ ((_patIisUnderscore) :: Bool) ((_patIpp) :: PP_Doc) _ppVarBang ->+                           {-# LINE 84 "src-ag/TfmToMirage.ag" #-}+                           if _patIisUnderscore+                            then _ppVarBang+                            else _ppVarBang     >|< "@" >|< _patIpp+                           {-# LINE 2191 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule277 #-}+   {-# LINE 93 "src-ag/TfmToMirage.ag" #-}+   rule277 = \  (_ :: ()) ->+                                    {-# LINE 93 "src-ag/TfmToMirage.ag" #-}+                                    False+                                    {-# LINE 2197 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule278 #-}+   rule278 = \ ((_patIerrors) :: Seq Error) ->+     _patIerrors+   {-# INLINE rule279 #-}+   rule279 = \ ((_patIcopy) :: Pattern) attr_ field_ ->+     Alias field_ attr_ _patIcopy+   {-# INLINE rule280 #-}+   rule280 = \ _copy ->+     _copy+   {-# INLINE rule281 #-}+   rule281 = \ ((_lhsIallTypeSigs) :: Map Identifier Type) ->+     _lhsIallTypeSigs+   {-# INLINE rule282 #-}+   rule282 = \ ((_lhsIaltAttrs) :: Map AltAttr Vertex) ->+     _lhsIaltAttrs+   {-# INLINE rule283 #-}+   rule283 = \ ((_lhsIbelowIrrefutable) :: Bool) ->+     _lhsIbelowIrrefutable+   {-# INLINE rule284 #-}+   rule284 = \ ((_lhsIcon) :: Identifier) ->+     _lhsIcon+   {-# INLINE rule285 #-}+   rule285 = \ ((_lhsIinh) :: Attributes) ->+     _lhsIinh+   {-# INLINE rule286 #-}+   rule286 = \ ((_lhsInt) :: Identifier) ->+     _lhsInt+   {-# INLINE rule287 #-}+   rule287 = \ ((_lhsIsyn) :: Attributes) ->+     _lhsIsyn+{-# NOINLINE sem_Pattern_Irrefutable #-}+sem_Pattern_Irrefutable :: T_Pattern  -> T_Pattern +sem_Pattern_Irrefutable arg_pat_ = T_Pattern (return st20) where+   {-# NOINLINE st20 #-}+   st20 = let+      v19 :: T_Pattern_v19 +      v19 = \ (T_Pattern_vIn19 _lhsIallTypeSigs _lhsIaltAttrs _lhsIbelowIrrefutable _lhsIcon _lhsIinh _lhsInt _lhsIsyn) -> ( let+         _patX20 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_))+         (T_Pattern_vOut19 _patIcopy _patIerrors _patIgathAltAttrs _patIinstVars _patIisUnderscore _patIlocVars _patIpatternAttrs _patIpp) = inv_Pattern_s20 _patX20 (T_Pattern_vIn19 _patOallTypeSigs _patOaltAttrs _patObelowIrrefutable _patOcon _patOinh _patOnt _patOsyn)+         _lhsOpp :: PP_Doc+         _lhsOpp = rule288 _patIpp+         _patObelowIrrefutable = rule289  ()+         _lhsOerrors :: Seq Error+         _lhsOerrors = rule290 _patIerrors+         _lhsOgathAltAttrs :: [AltAttr]+         _lhsOgathAltAttrs = rule291 _patIgathAltAttrs+         _lhsOinstVars :: [Identifier]+         _lhsOinstVars = rule292 _patIinstVars+         _lhsOlocVars :: [Identifier]+         _lhsOlocVars = rule293 _patIlocVars+         _lhsOpatternAttrs :: [(Identifier,Identifier,Bool)]+         _lhsOpatternAttrs = rule294 _patIpatternAttrs+         _copy = rule295 _patIcopy+         _lhsOcopy :: Pattern+         _lhsOcopy = rule296 _copy+         _lhsOisUnderscore :: Bool+         _lhsOisUnderscore = rule297 _patIisUnderscore+         _patOallTypeSigs = rule298 _lhsIallTypeSigs+         _patOaltAttrs = rule299 _lhsIaltAttrs+         _patOcon = rule300 _lhsIcon+         _patOinh = rule301 _lhsIinh+         _patOnt = rule302 _lhsInt+         _patOsyn = rule303 _lhsIsyn+         __result_ = T_Pattern_vOut19 _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOisUnderscore _lhsOlocVars _lhsOpatternAttrs _lhsOpp+         in __result_ )+     in C_Pattern_s20 v19+   {-# INLINE rule288 #-}+   {-# LINE 87 "src-ag/TfmToMirage.ag" #-}+   rule288 = \ ((_patIpp) :: PP_Doc) ->+                           {-# LINE 87 "src-ag/TfmToMirage.ag" #-}+                           text "~" >|< pp_parens _patIpp+                           {-# LINE 2269 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule289 #-}+   {-# LINE 100 "src-ag/TfmToMirage.ag" #-}+   rule289 = \  (_ :: ()) ->+                                         {-# LINE 100 "src-ag/TfmToMirage.ag" #-}+                                         True+                                         {-# LINE 2275 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule290 #-}+   rule290 = \ ((_patIerrors) :: Seq Error) ->+     _patIerrors+   {-# INLINE rule291 #-}+   rule291 = \ ((_patIgathAltAttrs) :: [AltAttr]) ->+     _patIgathAltAttrs+   {-# INLINE rule292 #-}+   rule292 = \ ((_patIinstVars) :: [Identifier]) ->+     _patIinstVars+   {-# INLINE rule293 #-}+   rule293 = \ ((_patIlocVars) :: [Identifier]) ->+     _patIlocVars+   {-# INLINE rule294 #-}+   rule294 = \ ((_patIpatternAttrs) :: [(Identifier,Identifier,Bool)]) ->+     _patIpatternAttrs+   {-# INLINE rule295 #-}+   rule295 = \ ((_patIcopy) :: Pattern) ->+     Irrefutable _patIcopy+   {-# INLINE rule296 #-}+   rule296 = \ _copy ->+     _copy+   {-# INLINE rule297 #-}+   rule297 = \ ((_patIisUnderscore) :: Bool) ->+     _patIisUnderscore+   {-# INLINE rule298 #-}+   rule298 = \ ((_lhsIallTypeSigs) :: Map Identifier Type) ->+     _lhsIallTypeSigs+   {-# INLINE rule299 #-}+   rule299 = \ ((_lhsIaltAttrs) :: Map AltAttr Vertex) ->+     _lhsIaltAttrs+   {-# INLINE rule300 #-}+   rule300 = \ ((_lhsIcon) :: Identifier) ->+     _lhsIcon+   {-# INLINE rule301 #-}+   rule301 = \ ((_lhsIinh) :: Attributes) ->+     _lhsIinh+   {-# INLINE rule302 #-}+   rule302 = \ ((_lhsInt) :: Identifier) ->+     _lhsInt+   {-# INLINE rule303 #-}+   rule303 = \ ((_lhsIsyn) :: Attributes) ->+     _lhsIsyn+{-# NOINLINE sem_Pattern_Underscore #-}+sem_Pattern_Underscore :: (Pos) -> T_Pattern +sem_Pattern_Underscore arg_pos_ = T_Pattern (return st20) where+   {-# NOINLINE st20 #-}+   st20 = let+      v19 :: T_Pattern_v19 +      v19 = \ (T_Pattern_vIn19 _lhsIallTypeSigs _lhsIaltAttrs _lhsIbelowIrrefutable _lhsIcon _lhsIinh _lhsInt _lhsIsyn) -> ( let+         _lhsOpp :: PP_Doc+         _lhsOpp = rule304  ()+         _lhsOisUnderscore :: Bool+         _lhsOisUnderscore = rule305  ()+         _lhsOerrors :: Seq Error+         _lhsOerrors = rule306  ()+         _lhsOgathAltAttrs :: [AltAttr]+         _lhsOgathAltAttrs = rule307  ()+         _lhsOinstVars :: [Identifier]+         _lhsOinstVars = rule308  ()+         _lhsOlocVars :: [Identifier]+         _lhsOlocVars = rule309  ()+         _lhsOpatternAttrs :: [(Identifier,Identifier,Bool)]+         _lhsOpatternAttrs = rule310  ()+         _copy = rule311 arg_pos_+         _lhsOcopy :: Pattern+         _lhsOcopy = rule312 _copy+         __result_ = T_Pattern_vOut19 _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOisUnderscore _lhsOlocVars _lhsOpatternAttrs _lhsOpp+         in __result_ )+     in C_Pattern_s20 v19+   {-# INLINE rule304 #-}+   {-# LINE 88 "src-ag/TfmToMirage.ag" #-}+   rule304 = \  (_ :: ()) ->+                           {-# LINE 88 "src-ag/TfmToMirage.ag" #-}+                           text "_"+                           {-# LINE 2350 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule305 #-}+   {-# LINE 94 "src-ag/TfmToMirage.ag" #-}+   rule305 = \  (_ :: ()) ->+                                    {-# LINE 94 "src-ag/TfmToMirage.ag" #-}+                                    True+                                    {-# LINE 2356 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule306 #-}+   rule306 = \  (_ :: ()) ->+     Seq.empty+   {-# INLINE rule307 #-}+   rule307 = \  (_ :: ()) ->+     []+   {-# INLINE rule308 #-}+   rule308 = \  (_ :: ()) ->+     []+   {-# INLINE rule309 #-}+   rule309 = \  (_ :: ()) ->+     []+   {-# INLINE rule310 #-}+   rule310 = \  (_ :: ()) ->+     []+   {-# INLINE rule311 #-}+   rule311 = \ pos_ ->+     Underscore pos_+   {-# INLINE rule312 #-}+   rule312 = \ _copy ->+     _copy++-- Patterns ----------------------------------------------------+-- wrapper+data Inh_Patterns  = Inh_Patterns { allTypeSigs_Inh_Patterns :: (Map Identifier Type), altAttrs_Inh_Patterns :: (Map AltAttr Vertex), belowIrrefutable_Inh_Patterns :: (Bool), 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)]), pps_Syn_Patterns :: ([PP_Doc]) }+{-# INLINABLE wrap_Patterns #-}+wrap_Patterns :: T_Patterns  -> Inh_Patterns  -> (Syn_Patterns )+wrap_Patterns (T_Patterns act) (Inh_Patterns _lhsIallTypeSigs _lhsIaltAttrs _lhsIbelowIrrefutable _lhsIcon _lhsIinh _lhsInt _lhsIsyn) =+   Control.Monad.Identity.runIdentity (+     do sem <- act+        let arg22 = T_Patterns_vIn22 _lhsIallTypeSigs _lhsIaltAttrs _lhsIbelowIrrefutable _lhsIcon _lhsIinh _lhsInt _lhsIsyn+        (T_Patterns_vOut22 _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOlocVars _lhsOpatternAttrs _lhsOpps) <- return (inv_Patterns_s23 sem arg22)+        return (Syn_Patterns _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOlocVars _lhsOpatternAttrs _lhsOpps)+   )++-- cata+{-# NOINLINE sem_Patterns #-}+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 {+                                 attach_T_Patterns :: Identity (T_Patterns_s23 )+                                 }+newtype T_Patterns_s23  = C_Patterns_s23 {+                                         inv_Patterns_s23 :: (T_Patterns_v22 )+                                         }+data T_Patterns_s24  = C_Patterns_s24+type T_Patterns_v22  = (T_Patterns_vIn22 ) -> (T_Patterns_vOut22 )+data T_Patterns_vIn22  = T_Patterns_vIn22 (Map Identifier Type) (Map AltAttr Vertex) (Bool) (Identifier) (Attributes) (Identifier) (Attributes)+data T_Patterns_vOut22  = T_Patterns_vOut22 (Patterns) (Seq Error) ([AltAttr]) ([Identifier]) ([Identifier]) ([(Identifier,Identifier,Bool)]) ([PP_Doc])+{-# NOINLINE sem_Patterns_Cons #-}+sem_Patterns_Cons :: T_Pattern  -> T_Patterns  -> T_Patterns +sem_Patterns_Cons arg_hd_ arg_tl_ = T_Patterns (return st23) where+   {-# NOINLINE st23 #-}+   st23 = let+      v22 :: T_Patterns_v22 +      v22 = \ (T_Patterns_vIn22 _lhsIallTypeSigs _lhsIaltAttrs _lhsIbelowIrrefutable _lhsIcon _lhsIinh _lhsInt _lhsIsyn) -> ( let+         _hdX20 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_hd_))+         _tlX23 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_tl_))+         (T_Pattern_vOut19 _hdIcopy _hdIerrors _hdIgathAltAttrs _hdIinstVars _hdIisUnderscore _hdIlocVars _hdIpatternAttrs _hdIpp) = inv_Pattern_s20 _hdX20 (T_Pattern_vIn19 _hdOallTypeSigs _hdOaltAttrs _hdObelowIrrefutable _hdOcon _hdOinh _hdOnt _hdOsyn)+         (T_Patterns_vOut22 _tlIcopy _tlIerrors _tlIgathAltAttrs _tlIinstVars _tlIlocVars _tlIpatternAttrs _tlIpps) = inv_Patterns_s23 _tlX23 (T_Patterns_vIn22 _tlOallTypeSigs _tlOaltAttrs _tlObelowIrrefutable _tlOcon _tlOinh _tlOnt _tlOsyn)+         _lhsOpps :: [PP_Doc]+         _lhsOpps = rule313 _hdIpp _tlIpps+         _lhsOerrors :: Seq Error+         _lhsOerrors = rule314 _hdIerrors _tlIerrors+         _lhsOgathAltAttrs :: [AltAttr]+         _lhsOgathAltAttrs = rule315 _hdIgathAltAttrs _tlIgathAltAttrs+         _lhsOinstVars :: [Identifier]+         _lhsOinstVars = rule316 _hdIinstVars _tlIinstVars+         _lhsOlocVars :: [Identifier]+         _lhsOlocVars = rule317 _hdIlocVars _tlIlocVars+         _lhsOpatternAttrs :: [(Identifier,Identifier,Bool)]+         _lhsOpatternAttrs = rule318 _hdIpatternAttrs _tlIpatternAttrs+         _copy = rule319 _hdIcopy _tlIcopy+         _lhsOcopy :: Patterns+         _lhsOcopy = rule320 _copy+         _hdOallTypeSigs = rule321 _lhsIallTypeSigs+         _hdOaltAttrs = rule322 _lhsIaltAttrs+         _hdObelowIrrefutable = rule323 _lhsIbelowIrrefutable+         _hdOcon = rule324 _lhsIcon+         _hdOinh = rule325 _lhsIinh+         _hdOnt = rule326 _lhsInt+         _hdOsyn = rule327 _lhsIsyn+         _tlOallTypeSigs = rule328 _lhsIallTypeSigs+         _tlOaltAttrs = rule329 _lhsIaltAttrs+         _tlObelowIrrefutable = rule330 _lhsIbelowIrrefutable+         _tlOcon = rule331 _lhsIcon+         _tlOinh = rule332 _lhsIinh+         _tlOnt = rule333 _lhsInt+         _tlOsyn = rule334 _lhsIsyn+         __result_ = T_Patterns_vOut22 _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOlocVars _lhsOpatternAttrs _lhsOpps+         in __result_ )+     in C_Patterns_s23 v22+   {-# INLINE rule313 #-}+   {-# LINE 76 "src-ag/TfmToMirage.ag" #-}+   rule313 = \ ((_hdIpp) :: PP_Doc) ((_tlIpps) :: [PP_Doc]) ->+                     {-# LINE 76 "src-ag/TfmToMirage.ag" #-}+                     _hdIpp : _tlIpps+                     {-# LINE 2457 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule314 #-}+   rule314 = \ ((_hdIerrors) :: Seq Error) ((_tlIerrors) :: Seq Error) ->+     _hdIerrors Seq.>< _tlIerrors+   {-# INLINE rule315 #-}+   rule315 = \ ((_hdIgathAltAttrs) :: [AltAttr]) ((_tlIgathAltAttrs) :: [AltAttr]) ->+     _hdIgathAltAttrs ++ _tlIgathAltAttrs+   {-# INLINE rule316 #-}+   rule316 = \ ((_hdIinstVars) :: [Identifier]) ((_tlIinstVars) :: [Identifier]) ->+     _hdIinstVars ++ _tlIinstVars+   {-# INLINE rule317 #-}+   rule317 = \ ((_hdIlocVars) :: [Identifier]) ((_tlIlocVars) :: [Identifier]) ->+     _hdIlocVars ++ _tlIlocVars+   {-# INLINE rule318 #-}+   rule318 = \ ((_hdIpatternAttrs) :: [(Identifier,Identifier,Bool)]) ((_tlIpatternAttrs) :: [(Identifier,Identifier,Bool)]) ->+     _hdIpatternAttrs ++ _tlIpatternAttrs+   {-# INLINE rule319 #-}+   rule319 = \ ((_hdIcopy) :: Pattern) ((_tlIcopy) :: Patterns) ->+     (:) _hdIcopy _tlIcopy+   {-# INLINE rule320 #-}+   rule320 = \ _copy ->+     _copy+   {-# INLINE rule321 #-}+   rule321 = \ ((_lhsIallTypeSigs) :: Map Identifier Type) ->+     _lhsIallTypeSigs+   {-# INLINE rule322 #-}+   rule322 = \ ((_lhsIaltAttrs) :: Map AltAttr Vertex) ->+     _lhsIaltAttrs+   {-# INLINE rule323 #-}+   rule323 = \ ((_lhsIbelowIrrefutable) :: Bool) ->+     _lhsIbelowIrrefutable+   {-# INLINE rule324 #-}+   rule324 = \ ((_lhsIcon) :: Identifier) ->+     _lhsIcon+   {-# INLINE rule325 #-}+   rule325 = \ ((_lhsIinh) :: Attributes) ->+     _lhsIinh+   {-# INLINE rule326 #-}+   rule326 = \ ((_lhsInt) :: Identifier) ->+     _lhsInt+   {-# INLINE rule327 #-}+   rule327 = \ ((_lhsIsyn) :: Attributes) ->+     _lhsIsyn+   {-# INLINE rule328 #-}+   rule328 = \ ((_lhsIallTypeSigs) :: Map Identifier Type) ->+     _lhsIallTypeSigs+   {-# INLINE rule329 #-}+   rule329 = \ ((_lhsIaltAttrs) :: Map AltAttr Vertex) ->+     _lhsIaltAttrs+   {-# INLINE rule330 #-}+   rule330 = \ ((_lhsIbelowIrrefutable) :: Bool) ->+     _lhsIbelowIrrefutable+   {-# INLINE rule331 #-}+   rule331 = \ ((_lhsIcon) :: Identifier) ->+     _lhsIcon+   {-# INLINE rule332 #-}+   rule332 = \ ((_lhsIinh) :: Attributes) ->+     _lhsIinh+   {-# INLINE rule333 #-}+   rule333 = \ ((_lhsInt) :: Identifier) ->+     _lhsInt+   {-# INLINE rule334 #-}+   rule334 = \ ((_lhsIsyn) :: Attributes) ->+     _lhsIsyn+{-# NOINLINE sem_Patterns_Nil #-}+sem_Patterns_Nil ::  T_Patterns +sem_Patterns_Nil  = T_Patterns (return st23) where+   {-# NOINLINE st23 #-}+   st23 = let+      v22 :: T_Patterns_v22 +      v22 = \ (T_Patterns_vIn22 _lhsIallTypeSigs _lhsIaltAttrs _lhsIbelowIrrefutable _lhsIcon _lhsIinh _lhsInt _lhsIsyn) -> ( let+         _lhsOpps :: [PP_Doc]+         _lhsOpps = rule335  ()+         _lhsOerrors :: Seq Error+         _lhsOerrors = rule336  ()+         _lhsOgathAltAttrs :: [AltAttr]+         _lhsOgathAltAttrs = rule337  ()+         _lhsOinstVars :: [Identifier]+         _lhsOinstVars = rule338  ()+         _lhsOlocVars :: [Identifier]+         _lhsOlocVars = rule339  ()+         _lhsOpatternAttrs :: [(Identifier,Identifier,Bool)]+         _lhsOpatternAttrs = rule340  ()+         _copy = rule341  ()+         _lhsOcopy :: Patterns+         _lhsOcopy = rule342 _copy+         __result_ = T_Patterns_vOut22 _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOlocVars _lhsOpatternAttrs _lhsOpps+         in __result_ )+     in C_Patterns_s23 v22+   {-# INLINE rule335 #-}+   {-# LINE 77 "src-ag/TfmToMirage.ag" #-}+   rule335 = \  (_ :: ()) ->+                     {-# LINE 77 "src-ag/TfmToMirage.ag" #-}+                     []+                     {-# LINE 2551 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule336 #-}+   rule336 = \  (_ :: ()) ->+     Seq.empty+   {-# INLINE rule337 #-}+   rule337 = \  (_ :: ()) ->+     []+   {-# INLINE rule338 #-}+   rule338 = \  (_ :: ()) ->+     []+   {-# INLINE rule339 #-}+   rule339 = \  (_ :: ()) ->+     []+   {-# INLINE rule340 #-}+   rule340 = \  (_ :: ()) ->+     []+   {-# INLINE rule341 #-}+   rule341 = \  (_ :: ()) ->+     []+   {-# INLINE rule342 #-}+   rule342 = \ _copy ->+     _copy++-- Production --------------------------------------------------+-- wrapper+data Inh_Production  = Inh_Production { allnts_Inh_Production :: ([Identifier]), aroundMap_Inh_Production :: (Map ConstructorIdent (Map Identifier [Expression])), cVisitsMap_Inh_Production :: (CVisitsMap), inh_Inh_Production :: (Attributes), inhMap_Inh_Production :: (Map Identifier Attributes), manualAttrDepMap_Inh_Production :: (AttrOrderMap), mergeMap_Inh_Production :: (Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))), 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), options_Inh_Production :: (Options), prefix_Inh_Production :: (String), syn_Inh_Production :: (Attributes), synMap_Inh_Production :: (Map Identifier Attributes), vcount_Inh_Production :: (Int) }+data Syn_Production  = Syn_Production { additionalDep_Syn_Production :: (Seq Edge), aroundDep_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), mergeDep_Syn_Production :: (Seq Edge), mirage_Syn_Production :: (Mirage.Production), nAutoRules_Syn_Production :: (Int), nExplicitRules_Syn_Production :: (Int), rules_Syn_Production :: (Seq (Vertex,CRule)), vcount_Syn_Production :: (Int) }+{-# INLINABLE wrap_Production #-}+wrap_Production :: T_Production  -> Inh_Production  -> (Syn_Production )+wrap_Production (T_Production act) (Inh_Production _lhsIallnts _lhsIaroundMap _lhsIcVisitsMap _lhsIinh _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsyn _lhsIsynMap _lhsIvcount) =+   Control.Monad.Identity.runIdentity (+     do sem <- act+        let arg25 = T_Production_vIn25 _lhsIallnts _lhsIaroundMap _lhsIcVisitsMap _lhsIinh _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsyn _lhsIsynMap _lhsIvcount+        (T_Production_vOut25 _lhsOadditionalDep _lhsOaroundDep _lhsOcProduction _lhsOcons _lhsOdirectDep _lhsOerrors _lhsOinstDep _lhsOmergeDep _lhsOmirage _lhsOnAutoRules _lhsOnExplicitRules _lhsOrules _lhsOvcount) <- return (inv_Production_s26 sem arg25)+        return (Syn_Production _lhsOadditionalDep _lhsOaroundDep _lhsOcProduction _lhsOcons _lhsOdirectDep _lhsOerrors _lhsOinstDep _lhsOmergeDep _lhsOmirage _lhsOnAutoRules _lhsOnExplicitRules _lhsOrules _lhsOvcount)+   )++-- cata+{-# INLINE sem_Production #-}+sem_Production :: Production  -> T_Production +sem_Production ( Production con_ params_ constraints_ children_ rules_ typeSigs_ macro_ ) = sem_Production_Production con_ params_ constraints_ ( sem_Children children_ ) ( sem_Rules rules_ ) ( sem_TypeSigs typeSigs_ ) macro_++-- semantic domain+newtype T_Production  = T_Production {+                                     attach_T_Production :: Identity (T_Production_s26 )+                                     }+newtype T_Production_s26  = C_Production_s26 {+                                             inv_Production_s26 :: (T_Production_v25 )+                                             }+data T_Production_s27  = C_Production_s27+type T_Production_v25  = (T_Production_vIn25 ) -> (T_Production_vOut25 )+data T_Production_vIn25  = T_Production_vIn25 ([Identifier]) (Map ConstructorIdent (Map Identifier [Expression])) (CVisitsMap) (Attributes) (Map Identifier Attributes) (AttrOrderMap) (Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))) (Identifier) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Options) (String) (Attributes) (Map Identifier Attributes) (Int)+data T_Production_vOut25  = T_Production_vOut25 (Seq Edge) (Seq Edge) (CProduction) ([ConstructorIdent]) (Seq Edge) (Seq Error) (Seq Edge) (Seq Edge) (Mirage.Production) (Int) (Int) (Seq (Vertex,CRule)) (Int)+{-# NOINLINE sem_Production_Production #-}+sem_Production_Production :: (ConstructorIdent) -> ([Identifier]) -> ([Type]) -> T_Children  -> T_Rules  -> T_TypeSigs  -> (MaybeMacro) -> T_Production +sem_Production_Production arg_con_ _ _ arg_children_ arg_rules_ arg_typeSigs_ _ = T_Production (return st26) where+   {-# NOINLINE st26 #-}+   st26 = let+      v25 :: T_Production_v25 +      v25 = \ (T_Production_vIn25 _lhsIallnts _lhsIaroundMap _lhsIcVisitsMap _lhsIinh _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsyn _lhsIsynMap _lhsIvcount) -> ( let+         _childrenX5 = Control.Monad.Identity.runIdentity (attach_T_Children (arg_children_))+         _rulesX35 = Control.Monad.Identity.runIdentity (attach_T_Rules (arg_rules_))+         _typeSigsX41 = Control.Monad.Identity.runIdentity (attach_T_TypeSigs (arg_typeSigs_))+         (T_Children_vOut4 _childrenIattributes _childrenIcollectChildrenInhs _childrenIcollectChildrenSyns _childrenIerrors _childrenIfields _childrenIgathAltAttrs _childrenIgathRules _childrenIinhs _childrenImirages _childrenInts _childrenIsinglevisits _childrenIterminals) = inv_Children_s5 _childrenX5 (T_Children_vIn4 _childrenOallfields _childrenOallnts _childrenOattrs _childrenOcon _childrenOinh _childrenOinhMap _childrenOmergeMap _childrenOnt _childrenOo_unbox _childrenOsyn _childrenOsynMap)+         (T_Rules_vOut34 _rulesIdirectDep _rulesIerrors _rulesIgathAltAttrs _rulesIgathRules _rulesIinstDep _rulesIinstVars _rulesIlocVars _rulesImirages _rulesInAutoRules _rulesInExplicitRules) = inv_Rules_s35 _rulesX35 (T_Rules_vIn34 _rulesOallTypeSigs _rulesOallfields _rulesOallnts _rulesOaltAttrs _rulesOattrs _rulesOchildInhs _rulesOchildNts _rulesOcon _rulesOinh _rulesOinhsOfChildren _rulesOmergeMap _rulesOnt _rulesOo_case _rulesOo_cata _rulesOo_dovisit _rulesOo_newtypes _rulesOo_rename _rulesOo_sem _rulesOo_sig _rulesOo_wantvisit _rulesOoptions _rulesOprefix _rulesOsyn _rulesOsynsOfChildren)+         (T_TypeSigs_vOut40 _typeSigsItypeSigs) = inv_TypeSigs_s41 _typeSigsX41 (T_TypeSigs_vIn40 _typeSigsOtypeSigs)+         _childrenOcon = rule343 arg_con_+         _rulesOcon = rule344 arg_con_+         _gathAltAttrs = rule345 _childrenIgathAltAttrs _lhsIinh _rulesIgathAltAttrs+         _altAttrs = rule346 _gathAltAttrs _lhsIvcount+         _rulesOchildNts = rule347 _childrenInts+         _rulesOchildInhs = rule348 _childrenIinhs+         _inhRules = rule349 _lhsIinh _lhsInt arg_con_+         _gathRules = rule350 _childrenIgathRules _inhRules _rulesIgathRules+         _lhsOrules :: Seq (Vertex,CRule)+         _lhsOrules = rule351 _gathRules _lhsIvcount+         _lhsOvcount :: Int+         _lhsOvcount = rule352 _gathRules _lhsIvcount+         _manualDeps = rule353 _lhsImanualAttrDepMap _lhsInt arg_con_+         _lhsOadditionalDep :: Seq Edge+         _lhsOadditionalDep = rule354 _altAttrs _manualDeps+         _rulesOsynsOfChildren = rule355 _childrenIcollectChildrenSyns+         _rulesOinhsOfChildren = rule356 _childrenIcollectChildrenInhs+         _mergeMap = rule357 _lhsImergeMap arg_con_+         _lhsOmergeDep :: Seq Edge+         _lhsOmergeDep = rule358 _mergeDep1 _mergeDep2+         _mergeDep1 = rule359 _altAttrs _childrenIcollectChildrenSyns _mergeMap+         _mergeDep2 = rule360 _altAttrs _childrenIcollectChildrenSyns _mergeMap+         _aroundMap = rule361 _lhsIaroundMap arg_con_+         _aroundDep1 = rule362 _altAttrs _aroundMap _childrenIcollectChildrenSyns+         _aroundDep2 = rule363 _altAttrs _aroundMap _childrenIcollectChildrenInhs+         _lhsOaroundDep :: Seq Edge+         _lhsOaroundDep = rule364 _aroundDep1 _aroundDep2+         _lhsOcons :: [ConstructorIdent]+         _lhsOcons = rule365 arg_con_+         _typeSigsOtypeSigs = rule366  ()+         _rulesOallTypeSigs = rule367 _typeSigsItypeSigs+         _cVisits = rule368 _childrenIsinglevisits _gathRules _lhsIcVisitsMap _lhsIinh _lhsInt _lhsIo_dovisit _lhsIsyn arg_con_+         _lhsOcProduction :: CProduction+         _lhsOcProduction = rule369 _cVisits _childrenIfields _childrenIterminals arg_con_+         _allfields = rule370 _childrenIfields+         _attrs = rule371 _childrenIattributes _inhnames _rulesIinstVars _rulesIlocVars+         _inhnames = rule372 _lhsIinh+         _synnames = rule373 _lhsIsyn+         _lhsOmirage :: Mirage.Production+         _lhsOmirage = rule374 _childrenImirages _rulesImirages arg_con_+         _lhsOdirectDep :: Seq Edge+         _lhsOdirectDep = rule375 _rulesIdirectDep+         _lhsOerrors :: Seq Error+         _lhsOerrors = rule376 _childrenIerrors _rulesIerrors+         _lhsOinstDep :: Seq Edge+         _lhsOinstDep = rule377 _rulesIinstDep+         _lhsOnAutoRules :: Int+         _lhsOnAutoRules = rule378 _rulesInAutoRules+         _lhsOnExplicitRules :: Int+         _lhsOnExplicitRules = rule379 _rulesInExplicitRules+         _childrenOallfields = rule380 _allfields+         _childrenOallnts = rule381 _lhsIallnts+         _childrenOattrs = rule382 _attrs+         _childrenOinh = rule383 _lhsIinh+         _childrenOinhMap = rule384 _lhsIinhMap+         _childrenOmergeMap = rule385 _mergeMap+         _childrenOnt = rule386 _lhsInt+         _childrenOo_unbox = rule387 _lhsIo_unbox+         _childrenOsyn = rule388 _lhsIsyn+         _childrenOsynMap = rule389 _lhsIsynMap+         _rulesOallfields = rule390 _allfields+         _rulesOallnts = rule391 _lhsIallnts+         _rulesOaltAttrs = rule392 _altAttrs+         _rulesOattrs = rule393 _attrs+         _rulesOinh = rule394 _lhsIinh+         _rulesOmergeMap = rule395 _mergeMap+         _rulesOnt = rule396 _lhsInt+         _rulesOo_case = rule397 _lhsIo_case+         _rulesOo_cata = rule398 _lhsIo_cata+         _rulesOo_dovisit = rule399 _lhsIo_dovisit+         _rulesOo_newtypes = rule400 _lhsIo_newtypes+         _rulesOo_rename = rule401 _lhsIo_rename+         _rulesOo_sem = rule402 _lhsIo_sem+         _rulesOo_sig = rule403 _lhsIo_sig+         _rulesOo_wantvisit = rule404 _lhsIo_wantvisit+         _rulesOoptions = rule405 _lhsIoptions+         _rulesOprefix = rule406 _lhsIprefix+         _rulesOsyn = rule407 _lhsIsyn+         __result_ = T_Production_vOut25 _lhsOadditionalDep _lhsOaroundDep _lhsOcProduction _lhsOcons _lhsOdirectDep _lhsOerrors _lhsOinstDep _lhsOmergeDep _lhsOmirage _lhsOnAutoRules _lhsOnExplicitRules _lhsOrules _lhsOvcount+         in __result_ )+     in C_Production_s26 v25+   {-# INLINE rule343 #-}+   {-# LINE 93 "src-ag/Order.ag" #-}+   rule343 = \ con_ ->+                                  {-# LINE 93 "src-ag/Order.ag" #-}+                                  con_+                                  {-# LINE 2703 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule344 #-}+   {-# LINE 95 "src-ag/Order.ag" #-}+   rule344 = \ con_ ->+                               {-# LINE 95 "src-ag/Order.ag" #-}+                               con_+                               {-# LINE 2709 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule345 #-}+   {-# LINE 175 "src-ag/Order.ag" #-}+   rule345 = \ ((_childrenIgathAltAttrs) :: [AltAttr]) ((_lhsIinh) :: Attributes) ((_rulesIgathAltAttrs) :: [AltAttr]) ->+                                       {-# LINE 175 "src-ag/Order.ag" #-}+                                       [ AltAttr _LHS inh True | inh <- Map.keys _lhsIinh ]+                                        ++ _childrenIgathAltAttrs+                                        ++ _rulesIgathAltAttrs+                                       {-# LINE 2717 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule346 #-}+   {-# LINE 191 "src-ag/Order.ag" #-}+   rule346 = \ _gathAltAttrs ((_lhsIvcount) :: Int) ->+                                 {-# LINE 191 "src-ag/Order.ag" #-}+                                 Map.fromList (zip _gathAltAttrs [_lhsIvcount..])+                                 {-# LINE 2723 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule347 #-}+   {-# LINE 204 "src-ag/Order.ag" #-}+   rule347 = \ ((_childrenInts) :: Seq (Identifier,NontermIdent)) ->+                                    {-# LINE 204 "src-ag/Order.ag" #-}+                                    Map.fromList (toList _childrenInts)+                                    {-# LINE 2729 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule348 #-}+   {-# LINE 205 "src-ag/Order.ag" #-}+   rule348 = \ ((_childrenIinhs) :: Seq (Identifier,Attributes)) ->+                                      {-# LINE 205 "src-ag/Order.ag" #-}+                                      Map.fromList (toList _childrenIinhs)+                                      {-# LINE 2735 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule349 #-}+   {-# LINE 211 "src-ag/Order.ag" #-}+   rule349 = \ ((_lhsIinh) :: Attributes) ((_lhsInt) :: Identifier) con_ ->+                                  {-# LINE 211 "src-ag/Order.ag" #-}+                                  [ cRuleLhsInh inh _lhsInt con_ tp | (inh,tp) <- Map.assocs _lhsIinh ]+                                  {-# LINE 2741 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule350 #-}+   {-# LINE 212 "src-ag/Order.ag" #-}+   rule350 = \ ((_childrenIgathRules) :: Seq CRule) _inhRules ((_rulesIgathRules) :: Seq CRule) ->+                                    {-# LINE 212 "src-ag/Order.ag" #-}+                                    _inhRules ++ toList (_childrenIgathRules Seq.>< _rulesIgathRules)+                                    {-# LINE 2747 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule351 #-}+   {-# LINE 264 "src-ag/Order.ag" #-}+   rule351 = \ _gathRules ((_lhsIvcount) :: Int) ->+                               {-# LINE 264 "src-ag/Order.ag" #-}+                               Seq.fromList (zip [_lhsIvcount..] _gathRules)+                               {-# LINE 2753 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule352 #-}+   {-# LINE 265 "src-ag/Order.ag" #-}+   rule352 = \ _gathRules ((_lhsIvcount) :: Int) ->+                                 {-# LINE 265 "src-ag/Order.ag" #-}+                                 _lhsIvcount + length _gathRules+                                 {-# LINE 2759 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule353 #-}+   {-# LINE 293 "src-ag/Order.ag" #-}+   rule353 = \ ((_lhsImanualAttrDepMap) :: AttrOrderMap) ((_lhsInt) :: Identifier) con_ ->+            {-# LINE 293 "src-ag/Order.ag" #-}+            Set.toList $ Map.findWithDefault Set.empty con_ $ Map.findWithDefault Map.empty _lhsInt _lhsImanualAttrDepMap+            {-# LINE 2765 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule354 #-}+   {-# LINE 296 "src-ag/Order.ag" #-}+   rule354 = \ _altAttrs _manualDeps ->+            {-# LINE 296 "src-ag/Order.ag" #-}+            Seq.fromList [ (vertex True occA, vertex False occB)+                         | Dependency occA occB <- _manualDeps+                         , let vertex inout (OccAttr child nm)+                                 | child == _LOC = findWithErr2 (AltAttr _LOC nm True) _altAttrs+                                 | otherwise     = findWithErr2 (AltAttr child nm inout) _altAttrs+                               vertex _ (OccRule nm)+                                 = findWithErr2 (AltAttr _LOC (Ident ("_rule_" ++ show nm) (getPos nm)) True) _altAttrs+                         ]+            {-# LINE 2778 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule355 #-}+   {-# LINE 342 "src-ag/Order.ag" #-}+   rule355 = \ ((_childrenIcollectChildrenSyns) :: Map Identifier Attributes ) ->+                                         {-# LINE 342 "src-ag/Order.ag" #-}+                                         _childrenIcollectChildrenSyns+                                         {-# LINE 2784 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule356 #-}+   {-# LINE 343 "src-ag/Order.ag" #-}+   rule356 = \ ((_childrenIcollectChildrenInhs) :: Map Identifier Attributes ) ->+                                         {-# LINE 343 "src-ag/Order.ag" #-}+                                         _childrenIcollectChildrenInhs+                                         {-# LINE 2790 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule357 #-}+   {-# LINE 361 "src-ag/Order.ag" #-}+   rule357 = \ ((_lhsImergeMap) :: Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))) con_ ->+                                                {-# LINE 361 "src-ag/Order.ag" #-}+                                                Map.findWithDefault Map.empty con_ _lhsImergeMap+                                                {-# LINE 2796 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule358 #-}+   {-# LINE 372 "src-ag/Order.ag" #-}+   rule358 = \ _mergeDep1 _mergeDep2 ->+                       {-# LINE 372 "src-ag/Order.ag" #-}+                       _mergeDep1     Seq.>< _mergeDep2+                       {-# LINE 2802 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule359 #-}+   {-# LINE 374 "src-ag/Order.ag" #-}+   rule359 = \ _altAttrs ((_childrenIcollectChildrenSyns) :: Map Identifier Attributes ) _mergeMap ->+            {-# LINE 374 "src-ag/Order.ag" #-}+            Seq.fromList $+               [ (childVert, synVert)+               | childNm <- Map.keys _mergeMap+               , synNm <- Map.keys (findWithErr2 childNm _childrenIcollectChildrenSyns)+               , let childNm' = Ident (show childNm ++ "_merge") (getPos childNm)+                     childAttr = AltAttr _LOC childNm' True+                     synAttr  = AltAttr childNm synNm True+                     childVert = findWithErr2 childAttr _altAttrs+                     synVert  = findWithErr2 synAttr _altAttrs+               ]+            {-# LINE 2817 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule360 #-}+   {-# LINE 385 "src-ag/Order.ag" #-}+   rule360 = \ _altAttrs ((_childrenIcollectChildrenSyns) :: Map Identifier Attributes ) _mergeMap ->+            {-# LINE 385 "src-ag/Order.ag" #-}+            Seq.fromList $+               [ (mergedVert, sourceVert)+               | (childNm, (_,cs)) <- Map.assocs _mergeMap+               , c <- cs+               , synNm <- Map.keys (findWithErr2 childNm _childrenIcollectChildrenSyns)+               , let sourceAttr = AltAttr childNm synNm True+                     mergedAttr = AltAttr c synNm True+                     sourceVert = findWithErr2 sourceAttr _altAttrs+                     mergedVert = findWithErr2 mergedAttr _altAttrs+               ]+            {-# LINE 2832 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule361 #-}+   {-# LINE 414 "src-ag/Order.ag" #-}+   rule361 = \ ((_lhsIaroundMap) :: Map ConstructorIdent (Map Identifier [Expression])) con_ ->+                                                 {-# LINE 414 "src-ag/Order.ag" #-}+                                                 Map.findWithDefault Map.empty con_ _lhsIaroundMap+                                                 {-# LINE 2838 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule362 #-}+   {-# LINE 422 "src-ag/Order.ag" #-}+   rule362 = \ _altAttrs _aroundMap ((_childrenIcollectChildrenSyns) :: Map Identifier Attributes ) ->+           {-# LINE 422 "src-ag/Order.ag" #-}+           Seq.fromList $+             [ (childVert, synVert)+             | childNm <- Map.keys _aroundMap+             , synNm <- Map.keys (findWithErr2 childNm _childrenIcollectChildrenSyns)+             , let childNm' = Ident (show childNm ++ "_around") (getPos childNm)+                   childAttr = AltAttr _LOC childNm' True+                   synAttr  = AltAttr childNm synNm True+                   childVert = findWithErr2 childAttr _altAttrs+                   synVert  = findWithErr2 synAttr _altAttrs+             ]+           {-# LINE 2853 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule363 #-}+   {-# LINE 433 "src-ag/Order.ag" #-}+   rule363 = \ _altAttrs _aroundMap ((_childrenIcollectChildrenInhs) :: Map Identifier Attributes ) ->+            {-# LINE 433 "src-ag/Order.ag" #-}+            Seq.fromList $+              [ (childVert, inhVert)+              | childNm <- Map.keys _aroundMap+              , inhNm <- Map.keys (findWithErr2 childNm _childrenIcollectChildrenInhs)+              , let childNm'  = Ident (show childNm ++ "_around") (getPos childNm)+                    childAttr = AltAttr _LOC childNm' True+                    inhAttr   = AltAttr childNm inhNm False+                    childVert = findWithErr2 childAttr _altAttrs+                    inhVert   = findWithErr2 inhAttr _altAttrs+              ]+            {-# LINE 2868 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule364 #-}+   {-# LINE 443 "src-ag/Order.ag" #-}+   rule364 = \ _aroundDep1 _aroundDep2 ->+                       {-# LINE 443 "src-ag/Order.ag" #-}+                       _aroundDep1     Seq.>< _aroundDep2+                       {-# LINE 2874 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule365 #-}+   {-# LINE 527 "src-ag/Order.ag" #-}+   rule365 = \ con_ ->+                              {-# LINE 527 "src-ag/Order.ag" #-}+                              [con_]+                              {-# LINE 2880 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule366 #-}+   {-# LINE 534 "src-ag/Order.ag" #-}+   rule366 = \  (_ :: ()) ->+                                     {-# LINE 534 "src-ag/Order.ag" #-}+                                     Map.empty+                                     {-# LINE 2886 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule367 #-}+   {-# LINE 540 "src-ag/Order.ag" #-}+   rule367 = \ ((_typeSigsItypeSigs) :: Map Identifier Type) ->+                                      {-# LINE 540 "src-ag/Order.ag" #-}+                                      _typeSigsItypeSigs+                                      {-# LINE 2892 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule368 #-}+   {-# LINE 608 "src-ag/Order.ag" #-}+   rule368 = \ ((_childrenIsinglevisits) :: [CRule]) _gathRules ((_lhsIcVisitsMap) :: CVisitsMap) ((_lhsIinh) :: Attributes) ((_lhsInt) :: Identifier) ((_lhsIo_dovisit) :: Bool) ((_lhsIsyn) :: Attributes) con_ ->+                                {-# LINE 608 "src-ag/Order.ag" #-}+                                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]+                                {-# LINE 2903 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule369 #-}+   {-# LINE 634 "src-ag/Order.ag" #-}+   rule369 = \ _cVisits ((_childrenIfields) :: [(Identifier,Type,ChildKind)]) ((_childrenIterminals) :: [Identifier]) con_ ->+                                     {-# LINE 634 "src-ag/Order.ag" #-}+                                     CProduction con_ _cVisits _childrenIfields _childrenIterminals+                                     {-# LINE 2909 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule370 #-}+   {-# LINE 662 "src-ag/Order.ag" #-}+   rule370 = \ ((_childrenIfields) :: [(Identifier,Type,ChildKind)]) ->+                                  {-# LINE 662 "src-ag/Order.ag" #-}+                                  _childrenIfields+                                  {-# LINE 2915 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule371 #-}+   {-# LINE 663 "src-ag/Order.ag" #-}+   rule371 = \ ((_childrenIattributes) :: [(Identifier,Attributes,Attributes)]) _inhnames ((_rulesIinstVars) :: [Identifier]) ((_rulesIlocVars) :: [Identifier]) ->+                                   {-# LINE 663 "src-ag/Order.ag" #-}+                                   map ((,) _LOC)  _rulesIlocVars +++                                   map ((,) _INST) _rulesIinstVars +++                                   map ((,) _LHS)  _inhnames +++                                   concat [map ((,) nm) (Map.keys as) | (nm,_,as) <- _childrenIattributes]+                                   {-# LINE 2924 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule372 #-}+   {-# LINE 667 "src-ag/Order.ag" #-}+   rule372 = \ ((_lhsIinh) :: Attributes) ->+                                   {-# LINE 667 "src-ag/Order.ag" #-}+                                   Map.keys _lhsIinh+                                   {-# LINE 2930 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule373 #-}+   {-# LINE 668 "src-ag/Order.ag" #-}+   rule373 = \ ((_lhsIsyn) :: Attributes) ->+                                   {-# LINE 668 "src-ag/Order.ag" #-}+                                   Map.keys _lhsIsyn+                                   {-# LINE 2936 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule374 #-}+   {-# LINE 43 "src-ag/TfmToMirage.ag" #-}+   rule374 = \ ((_childrenImirages) :: [Mirage.Child]) ((_rulesImirages) :: [Mirage.Rule]) con_ ->+          {-# LINE 43 "src-ag/TfmToMirage.ag" #-}+          Mirage.Production (getName con_) _childrenImirages _rulesImirages+          {-# LINE 2942 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule375 #-}+   rule375 = \ ((_rulesIdirectDep) :: Seq Edge) ->+     _rulesIdirectDep+   {-# INLINE rule376 #-}+   rule376 = \ ((_childrenIerrors) :: Seq Error) ((_rulesIerrors) :: Seq Error) ->+     _childrenIerrors Seq.>< _rulesIerrors+   {-# INLINE rule377 #-}+   rule377 = \ ((_rulesIinstDep) :: Seq Edge) ->+     _rulesIinstDep+   {-# INLINE rule378 #-}+   rule378 = \ ((_rulesInAutoRules) :: Int) ->+     _rulesInAutoRules+   {-# INLINE rule379 #-}+   rule379 = \ ((_rulesInExplicitRules) :: Int) ->+     _rulesInExplicitRules+   {-# INLINE rule380 #-}+   rule380 = \ _allfields ->+     _allfields+   {-# INLINE rule381 #-}+   rule381 = \ ((_lhsIallnts) :: [Identifier]) ->+     _lhsIallnts+   {-# INLINE rule382 #-}+   rule382 = \ _attrs ->+     _attrs+   {-# INLINE rule383 #-}+   rule383 = \ ((_lhsIinh) :: Attributes) ->+     _lhsIinh+   {-# INLINE rule384 #-}+   rule384 = \ ((_lhsIinhMap) :: Map Identifier Attributes) ->+     _lhsIinhMap+   {-# INLINE rule385 #-}+   rule385 = \ _mergeMap ->+     _mergeMap+   {-# INLINE rule386 #-}+   rule386 = \ ((_lhsInt) :: Identifier) ->+     _lhsInt+   {-# INLINE rule387 #-}+   rule387 = \ ((_lhsIo_unbox) :: Bool) ->+     _lhsIo_unbox+   {-# INLINE rule388 #-}+   rule388 = \ ((_lhsIsyn) :: Attributes) ->+     _lhsIsyn+   {-# INLINE rule389 #-}+   rule389 = \ ((_lhsIsynMap) :: Map Identifier Attributes) ->+     _lhsIsynMap+   {-# INLINE rule390 #-}+   rule390 = \ _allfields ->+     _allfields+   {-# INLINE rule391 #-}+   rule391 = \ ((_lhsIallnts) :: [Identifier]) ->+     _lhsIallnts+   {-# INLINE rule392 #-}+   rule392 = \ _altAttrs ->+     _altAttrs+   {-# INLINE rule393 #-}+   rule393 = \ _attrs ->+     _attrs+   {-# INLINE rule394 #-}+   rule394 = \ ((_lhsIinh) :: Attributes) ->+     _lhsIinh+   {-# INLINE rule395 #-}+   rule395 = \ _mergeMap ->+     _mergeMap+   {-# INLINE rule396 #-}+   rule396 = \ ((_lhsInt) :: Identifier) ->+     _lhsInt+   {-# INLINE rule397 #-}+   rule397 = \ ((_lhsIo_case) :: Bool) ->+     _lhsIo_case+   {-# INLINE rule398 #-}+   rule398 = \ ((_lhsIo_cata) :: Bool) ->+     _lhsIo_cata+   {-# INLINE rule399 #-}+   rule399 = \ ((_lhsIo_dovisit) :: Bool) ->+     _lhsIo_dovisit+   {-# INLINE rule400 #-}+   rule400 = \ ((_lhsIo_newtypes) :: Bool) ->+     _lhsIo_newtypes+   {-# INLINE rule401 #-}+   rule401 = \ ((_lhsIo_rename) :: Bool) ->+     _lhsIo_rename+   {-# INLINE rule402 #-}+   rule402 = \ ((_lhsIo_sem) :: Bool) ->+     _lhsIo_sem+   {-# INLINE rule403 #-}+   rule403 = \ ((_lhsIo_sig) :: Bool) ->+     _lhsIo_sig+   {-# INLINE rule404 #-}+   rule404 = \ ((_lhsIo_wantvisit) :: Bool) ->+     _lhsIo_wantvisit+   {-# INLINE rule405 #-}+   rule405 = \ ((_lhsIoptions) :: Options) ->+     _lhsIoptions+   {-# INLINE rule406 #-}+   rule406 = \ ((_lhsIprefix) :: String) ->+     _lhsIprefix+   {-# INLINE rule407 #-}+   rule407 = \ ((_lhsIsyn) :: Attributes) ->+     _lhsIsyn++-- Productions -------------------------------------------------+-- wrapper+data Inh_Productions  = Inh_Productions { allnts_Inh_Productions :: ([Identifier]), aroundMap_Inh_Productions :: (Map ConstructorIdent (Map Identifier [Expression])), cVisitsMap_Inh_Productions :: (CVisitsMap), inh_Inh_Productions :: (Attributes), inhMap_Inh_Productions :: (Map Identifier Attributes), manualAttrDepMap_Inh_Productions :: (AttrOrderMap), mergeMap_Inh_Productions :: (Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))), 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), options_Inh_Productions :: (Options), prefix_Inh_Productions :: (String), syn_Inh_Productions :: (Attributes), synMap_Inh_Productions :: (Map Identifier Attributes), vcount_Inh_Productions :: (Int) }+data Syn_Productions  = Syn_Productions { additionalDep_Syn_Productions :: (Seq Edge), aroundDep_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), mergeDep_Syn_Productions :: (Seq Edge), mirages_Syn_Productions :: ([Mirage.Production]), nAutoRules_Syn_Productions :: (Int), nExplicitRules_Syn_Productions :: (Int), rules_Syn_Productions :: (Seq (Vertex,CRule)), vcount_Syn_Productions :: (Int) }+{-# INLINABLE wrap_Productions #-}+wrap_Productions :: T_Productions  -> Inh_Productions  -> (Syn_Productions )+wrap_Productions (T_Productions act) (Inh_Productions _lhsIallnts _lhsIaroundMap _lhsIcVisitsMap _lhsIinh _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsyn _lhsIsynMap _lhsIvcount) =+   Control.Monad.Identity.runIdentity (+     do sem <- act+        let arg28 = T_Productions_vIn28 _lhsIallnts _lhsIaroundMap _lhsIcVisitsMap _lhsIinh _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsyn _lhsIsynMap _lhsIvcount+        (T_Productions_vOut28 _lhsOadditionalDep _lhsOaroundDep _lhsOcProductions _lhsOcons _lhsOdirectDep _lhsOerrors _lhsOinstDep _lhsOmergeDep _lhsOmirages _lhsOnAutoRules _lhsOnExplicitRules _lhsOrules _lhsOvcount) <- return (inv_Productions_s29 sem arg28)+        return (Syn_Productions _lhsOadditionalDep _lhsOaroundDep _lhsOcProductions _lhsOcons _lhsOdirectDep _lhsOerrors _lhsOinstDep _lhsOmergeDep _lhsOmirages _lhsOnAutoRules _lhsOnExplicitRules _lhsOrules _lhsOvcount)+   )++-- cata+{-# NOINLINE sem_Productions #-}+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 {+                                       attach_T_Productions :: Identity (T_Productions_s29 )+                                       }+newtype T_Productions_s29  = C_Productions_s29 {+                                               inv_Productions_s29 :: (T_Productions_v28 )+                                               }+data T_Productions_s30  = C_Productions_s30+type T_Productions_v28  = (T_Productions_vIn28 ) -> (T_Productions_vOut28 )+data T_Productions_vIn28  = T_Productions_vIn28 ([Identifier]) (Map ConstructorIdent (Map Identifier [Expression])) (CVisitsMap) (Attributes) (Map Identifier Attributes) (AttrOrderMap) (Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))) (Identifier) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Options) (String) (Attributes) (Map Identifier Attributes) (Int)+data T_Productions_vOut28  = T_Productions_vOut28 (Seq Edge) (Seq Edge) (CProductions) ([ConstructorIdent]) (Seq Edge) (Seq Error) (Seq Edge) (Seq Edge) ([Mirage.Production]) (Int) (Int) (Seq (Vertex,CRule)) (Int)+{-# NOINLINE sem_Productions_Cons #-}+sem_Productions_Cons :: T_Production  -> T_Productions  -> T_Productions +sem_Productions_Cons arg_hd_ arg_tl_ = T_Productions (return st29) where+   {-# NOINLINE st29 #-}+   st29 = let+      v28 :: T_Productions_v28 +      v28 = \ (T_Productions_vIn28 _lhsIallnts _lhsIaroundMap _lhsIcVisitsMap _lhsIinh _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsyn _lhsIsynMap _lhsIvcount) -> ( let+         _hdX26 = Control.Monad.Identity.runIdentity (attach_T_Production (arg_hd_))+         _tlX29 = Control.Monad.Identity.runIdentity (attach_T_Productions (arg_tl_))+         (T_Production_vOut25 _hdIadditionalDep _hdIaroundDep _hdIcProduction _hdIcons _hdIdirectDep _hdIerrors _hdIinstDep _hdImergeDep _hdImirage _hdInAutoRules _hdInExplicitRules _hdIrules _hdIvcount) = inv_Production_s26 _hdX26 (T_Production_vIn25 _hdOallnts _hdOaroundMap _hdOcVisitsMap _hdOinh _hdOinhMap _hdOmanualAttrDepMap _hdOmergeMap _hdOnt _hdOo_case _hdOo_cata _hdOo_dovisit _hdOo_newtypes _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_unbox _hdOo_wantvisit _hdOoptions _hdOprefix _hdOsyn _hdOsynMap _hdOvcount)+         (T_Productions_vOut28 _tlIadditionalDep _tlIaroundDep _tlIcProductions _tlIcons _tlIdirectDep _tlIerrors _tlIinstDep _tlImergeDep _tlImirages _tlInAutoRules _tlInExplicitRules _tlIrules _tlIvcount) = inv_Productions_s29 _tlX29 (T_Productions_vIn28 _tlOallnts _tlOaroundMap _tlOcVisitsMap _tlOinh _tlOinhMap _tlOmanualAttrDepMap _tlOmergeMap _tlOnt _tlOo_case _tlOo_cata _tlOo_dovisit _tlOo_newtypes _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_unbox _tlOo_wantvisit _tlOoptions _tlOprefix _tlOsyn _tlOsynMap _tlOvcount)+         _lhsOcProductions :: CProductions+         _lhsOcProductions = rule408 _hdIcProduction _tlIcProductions+         _lhsOmirages :: [Mirage.Production]+         _lhsOmirages = rule409 _hdImirage _tlImirages+         _lhsOadditionalDep :: Seq Edge+         _lhsOadditionalDep = rule410 _hdIadditionalDep _tlIadditionalDep+         _lhsOaroundDep :: Seq Edge+         _lhsOaroundDep = rule411 _hdIaroundDep _tlIaroundDep+         _lhsOcons :: [ConstructorIdent]+         _lhsOcons = rule412 _hdIcons _tlIcons+         _lhsOdirectDep :: Seq Edge+         _lhsOdirectDep = rule413 _hdIdirectDep _tlIdirectDep+         _lhsOerrors :: Seq Error+         _lhsOerrors = rule414 _hdIerrors _tlIerrors+         _lhsOinstDep :: Seq Edge+         _lhsOinstDep = rule415 _hdIinstDep _tlIinstDep+         _lhsOmergeDep :: Seq Edge+         _lhsOmergeDep = rule416 _hdImergeDep _tlImergeDep+         _lhsOnAutoRules :: Int+         _lhsOnAutoRules = rule417 _hdInAutoRules _tlInAutoRules+         _lhsOnExplicitRules :: Int+         _lhsOnExplicitRules = rule418 _hdInExplicitRules _tlInExplicitRules+         _lhsOrules :: Seq (Vertex,CRule)+         _lhsOrules = rule419 _hdIrules _tlIrules+         _lhsOvcount :: Int+         _lhsOvcount = rule420 _tlIvcount+         _hdOallnts = rule421 _lhsIallnts+         _hdOaroundMap = rule422 _lhsIaroundMap+         _hdOcVisitsMap = rule423 _lhsIcVisitsMap+         _hdOinh = rule424 _lhsIinh+         _hdOinhMap = rule425 _lhsIinhMap+         _hdOmanualAttrDepMap = rule426 _lhsImanualAttrDepMap+         _hdOmergeMap = rule427 _lhsImergeMap+         _hdOnt = rule428 _lhsInt+         _hdOo_case = rule429 _lhsIo_case+         _hdOo_cata = rule430 _lhsIo_cata+         _hdOo_dovisit = rule431 _lhsIo_dovisit+         _hdOo_newtypes = rule432 _lhsIo_newtypes+         _hdOo_rename = rule433 _lhsIo_rename+         _hdOo_sem = rule434 _lhsIo_sem+         _hdOo_sig = rule435 _lhsIo_sig+         _hdOo_unbox = rule436 _lhsIo_unbox+         _hdOo_wantvisit = rule437 _lhsIo_wantvisit+         _hdOoptions = rule438 _lhsIoptions+         _hdOprefix = rule439 _lhsIprefix+         _hdOsyn = rule440 _lhsIsyn+         _hdOsynMap = rule441 _lhsIsynMap+         _hdOvcount = rule442 _lhsIvcount+         _tlOallnts = rule443 _lhsIallnts+         _tlOaroundMap = rule444 _lhsIaroundMap+         _tlOcVisitsMap = rule445 _lhsIcVisitsMap+         _tlOinh = rule446 _lhsIinh+         _tlOinhMap = rule447 _lhsIinhMap+         _tlOmanualAttrDepMap = rule448 _lhsImanualAttrDepMap+         _tlOmergeMap = rule449 _lhsImergeMap+         _tlOnt = rule450 _lhsInt+         _tlOo_case = rule451 _lhsIo_case+         _tlOo_cata = rule452 _lhsIo_cata+         _tlOo_dovisit = rule453 _lhsIo_dovisit+         _tlOo_newtypes = rule454 _lhsIo_newtypes+         _tlOo_rename = rule455 _lhsIo_rename+         _tlOo_sem = rule456 _lhsIo_sem+         _tlOo_sig = rule457 _lhsIo_sig+         _tlOo_unbox = rule458 _lhsIo_unbox+         _tlOo_wantvisit = rule459 _lhsIo_wantvisit+         _tlOoptions = rule460 _lhsIoptions+         _tlOprefix = rule461 _lhsIprefix+         _tlOsyn = rule462 _lhsIsyn+         _tlOsynMap = rule463 _lhsIsynMap+         _tlOvcount = rule464 _hdIvcount+         __result_ = T_Productions_vOut28 _lhsOadditionalDep _lhsOaroundDep _lhsOcProductions _lhsOcons _lhsOdirectDep _lhsOerrors _lhsOinstDep _lhsOmergeDep _lhsOmirages _lhsOnAutoRules _lhsOnExplicitRules _lhsOrules _lhsOvcount+         in __result_ )+     in C_Productions_s29 v28+   {-# INLINE rule408 #-}+   {-# LINE 631 "src-ag/Order.ag" #-}+   rule408 = \ ((_hdIcProduction) :: CProduction) ((_tlIcProductions) :: CProductions) ->+                                {-# LINE 631 "src-ag/Order.ag" #-}+                                _hdIcProduction : _tlIcProductions+                                {-# LINE 3162 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule409 #-}+   {-# LINE 38 "src-ag/TfmToMirage.ag" #-}+   rule409 = \ ((_hdImirage) :: Mirage.Production) ((_tlImirages) :: [Mirage.Production]) ->+                         {-# LINE 38 "src-ag/TfmToMirage.ag" #-}+                         _hdImirage : _tlImirages+                         {-# LINE 3168 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule410 #-}+   rule410 = \ ((_hdIadditionalDep) :: Seq Edge) ((_tlIadditionalDep) :: Seq Edge) ->+     _hdIadditionalDep Seq.>< _tlIadditionalDep+   {-# INLINE rule411 #-}+   rule411 = \ ((_hdIaroundDep) :: Seq Edge) ((_tlIaroundDep) :: Seq Edge) ->+     _hdIaroundDep Seq.>< _tlIaroundDep+   {-# INLINE rule412 #-}+   rule412 = \ ((_hdIcons) :: [ConstructorIdent]) ((_tlIcons) :: [ConstructorIdent]) ->+     _hdIcons ++ _tlIcons+   {-# INLINE rule413 #-}+   rule413 = \ ((_hdIdirectDep) :: Seq Edge) ((_tlIdirectDep) :: Seq Edge) ->+     _hdIdirectDep Seq.>< _tlIdirectDep+   {-# INLINE rule414 #-}+   rule414 = \ ((_hdIerrors) :: Seq Error) ((_tlIerrors) :: Seq Error) ->+     _hdIerrors Seq.>< _tlIerrors+   {-# INLINE rule415 #-}+   rule415 = \ ((_hdIinstDep) :: Seq Edge) ((_tlIinstDep) :: Seq Edge) ->+     _hdIinstDep Seq.>< _tlIinstDep+   {-# INLINE rule416 #-}+   rule416 = \ ((_hdImergeDep) :: Seq Edge) ((_tlImergeDep) :: Seq Edge) ->+     _hdImergeDep Seq.>< _tlImergeDep+   {-# INLINE rule417 #-}+   rule417 = \ ((_hdInAutoRules) :: Int) ((_tlInAutoRules) :: Int) ->+     _hdInAutoRules + _tlInAutoRules+   {-# INLINE rule418 #-}+   rule418 = \ ((_hdInExplicitRules) :: Int) ((_tlInExplicitRules) :: Int) ->+     _hdInExplicitRules + _tlInExplicitRules+   {-# INLINE rule419 #-}+   rule419 = \ ((_hdIrules) :: Seq (Vertex,CRule)) ((_tlIrules) :: Seq (Vertex,CRule)) ->+     _hdIrules Seq.>< _tlIrules+   {-# INLINE rule420 #-}+   rule420 = \ ((_tlIvcount) :: Int) ->+     _tlIvcount+   {-# INLINE rule421 #-}+   rule421 = \ ((_lhsIallnts) :: [Identifier]) ->+     _lhsIallnts+   {-# INLINE rule422 #-}+   rule422 = \ ((_lhsIaroundMap) :: Map ConstructorIdent (Map Identifier [Expression])) ->+     _lhsIaroundMap+   {-# INLINE rule423 #-}+   rule423 = \ ((_lhsIcVisitsMap) :: CVisitsMap) ->+     _lhsIcVisitsMap+   {-# INLINE rule424 #-}+   rule424 = \ ((_lhsIinh) :: Attributes) ->+     _lhsIinh+   {-# INLINE rule425 #-}+   rule425 = \ ((_lhsIinhMap) :: Map Identifier Attributes) ->+     _lhsIinhMap+   {-# INLINE rule426 #-}+   rule426 = \ ((_lhsImanualAttrDepMap) :: AttrOrderMap) ->+     _lhsImanualAttrDepMap+   {-# INLINE rule427 #-}+   rule427 = \ ((_lhsImergeMap) :: Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))) ->+     _lhsImergeMap+   {-# INLINE rule428 #-}+   rule428 = \ ((_lhsInt) :: Identifier) ->+     _lhsInt+   {-# INLINE rule429 #-}+   rule429 = \ ((_lhsIo_case) :: Bool) ->+     _lhsIo_case+   {-# INLINE rule430 #-}+   rule430 = \ ((_lhsIo_cata) :: Bool) ->+     _lhsIo_cata+   {-# INLINE rule431 #-}+   rule431 = \ ((_lhsIo_dovisit) :: Bool) ->+     _lhsIo_dovisit+   {-# INLINE rule432 #-}+   rule432 = \ ((_lhsIo_newtypes) :: Bool) ->+     _lhsIo_newtypes+   {-# INLINE rule433 #-}+   rule433 = \ ((_lhsIo_rename) :: Bool) ->+     _lhsIo_rename+   {-# INLINE rule434 #-}+   rule434 = \ ((_lhsIo_sem) :: Bool) ->+     _lhsIo_sem+   {-# INLINE rule435 #-}+   rule435 = \ ((_lhsIo_sig) :: Bool) ->+     _lhsIo_sig+   {-# INLINE rule436 #-}+   rule436 = \ ((_lhsIo_unbox) :: Bool) ->+     _lhsIo_unbox+   {-# INLINE rule437 #-}+   rule437 = \ ((_lhsIo_wantvisit) :: Bool) ->+     _lhsIo_wantvisit+   {-# INLINE rule438 #-}+   rule438 = \ ((_lhsIoptions) :: Options) ->+     _lhsIoptions+   {-# INLINE rule439 #-}+   rule439 = \ ((_lhsIprefix) :: String) ->+     _lhsIprefix+   {-# INLINE rule440 #-}+   rule440 = \ ((_lhsIsyn) :: Attributes) ->+     _lhsIsyn+   {-# INLINE rule441 #-}+   rule441 = \ ((_lhsIsynMap) :: Map Identifier Attributes) ->+     _lhsIsynMap+   {-# INLINE rule442 #-}+   rule442 = \ ((_lhsIvcount) :: Int) ->+     _lhsIvcount+   {-# INLINE rule443 #-}+   rule443 = \ ((_lhsIallnts) :: [Identifier]) ->+     _lhsIallnts+   {-# INLINE rule444 #-}+   rule444 = \ ((_lhsIaroundMap) :: Map ConstructorIdent (Map Identifier [Expression])) ->+     _lhsIaroundMap+   {-# INLINE rule445 #-}+   rule445 = \ ((_lhsIcVisitsMap) :: CVisitsMap) ->+     _lhsIcVisitsMap+   {-# INLINE rule446 #-}+   rule446 = \ ((_lhsIinh) :: Attributes) ->+     _lhsIinh+   {-# INLINE rule447 #-}+   rule447 = \ ((_lhsIinhMap) :: Map Identifier Attributes) ->+     _lhsIinhMap+   {-# INLINE rule448 #-}+   rule448 = \ ((_lhsImanualAttrDepMap) :: AttrOrderMap) ->+     _lhsImanualAttrDepMap+   {-# INLINE rule449 #-}+   rule449 = \ ((_lhsImergeMap) :: Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))) ->+     _lhsImergeMap+   {-# INLINE rule450 #-}+   rule450 = \ ((_lhsInt) :: Identifier) ->+     _lhsInt+   {-# INLINE rule451 #-}+   rule451 = \ ((_lhsIo_case) :: Bool) ->+     _lhsIo_case+   {-# INLINE rule452 #-}+   rule452 = \ ((_lhsIo_cata) :: Bool) ->+     _lhsIo_cata+   {-# INLINE rule453 #-}+   rule453 = \ ((_lhsIo_dovisit) :: Bool) ->+     _lhsIo_dovisit+   {-# INLINE rule454 #-}+   rule454 = \ ((_lhsIo_newtypes) :: Bool) ->+     _lhsIo_newtypes+   {-# INLINE rule455 #-}+   rule455 = \ ((_lhsIo_rename) :: Bool) ->+     _lhsIo_rename+   {-# INLINE rule456 #-}+   rule456 = \ ((_lhsIo_sem) :: Bool) ->+     _lhsIo_sem+   {-# INLINE rule457 #-}+   rule457 = \ ((_lhsIo_sig) :: Bool) ->+     _lhsIo_sig+   {-# INLINE rule458 #-}+   rule458 = \ ((_lhsIo_unbox) :: Bool) ->+     _lhsIo_unbox+   {-# INLINE rule459 #-}+   rule459 = \ ((_lhsIo_wantvisit) :: Bool) ->+     _lhsIo_wantvisit+   {-# INLINE rule460 #-}+   rule460 = \ ((_lhsIoptions) :: Options) ->+     _lhsIoptions+   {-# INLINE rule461 #-}+   rule461 = \ ((_lhsIprefix) :: String) ->+     _lhsIprefix+   {-# INLINE rule462 #-}+   rule462 = \ ((_lhsIsyn) :: Attributes) ->+     _lhsIsyn+   {-# INLINE rule463 #-}+   rule463 = \ ((_lhsIsynMap) :: Map Identifier Attributes) ->+     _lhsIsynMap+   {-# INLINE rule464 #-}+   rule464 = \ ((_hdIvcount) :: Int) ->+     _hdIvcount+{-# NOINLINE sem_Productions_Nil #-}+sem_Productions_Nil ::  T_Productions +sem_Productions_Nil  = T_Productions (return st29) where+   {-# NOINLINE st29 #-}+   st29 = let+      v28 :: T_Productions_v28 +      v28 = \ (T_Productions_vIn28 _lhsIallnts _lhsIaroundMap _lhsIcVisitsMap _lhsIinh _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsyn _lhsIsynMap _lhsIvcount) -> ( let+         _lhsOcProductions :: CProductions+         _lhsOcProductions = rule465  ()+         _lhsOmirages :: [Mirage.Production]+         _lhsOmirages = rule466  ()+         _lhsOadditionalDep :: Seq Edge+         _lhsOadditionalDep = rule467  ()+         _lhsOaroundDep :: Seq Edge+         _lhsOaroundDep = rule468  ()+         _lhsOcons :: [ConstructorIdent]+         _lhsOcons = rule469  ()+         _lhsOdirectDep :: Seq Edge+         _lhsOdirectDep = rule470  ()+         _lhsOerrors :: Seq Error+         _lhsOerrors = rule471  ()+         _lhsOinstDep :: Seq Edge+         _lhsOinstDep = rule472  ()+         _lhsOmergeDep :: Seq Edge+         _lhsOmergeDep = rule473  ()+         _lhsOnAutoRules :: Int+         _lhsOnAutoRules = rule474  ()+         _lhsOnExplicitRules :: Int+         _lhsOnExplicitRules = rule475  ()+         _lhsOrules :: Seq (Vertex,CRule)+         _lhsOrules = rule476  ()+         _lhsOvcount :: Int+         _lhsOvcount = rule477 _lhsIvcount+         __result_ = T_Productions_vOut28 _lhsOadditionalDep _lhsOaroundDep _lhsOcProductions _lhsOcons _lhsOdirectDep _lhsOerrors _lhsOinstDep _lhsOmergeDep _lhsOmirages _lhsOnAutoRules _lhsOnExplicitRules _lhsOrules _lhsOvcount+         in __result_ )+     in C_Productions_s29 v28+   {-# INLINE rule465 #-}+   {-# LINE 632 "src-ag/Order.ag" #-}+   rule465 = \  (_ :: ()) ->+                                {-# LINE 632 "src-ag/Order.ag" #-}+                                []+                                {-# LINE 3375 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule466 #-}+   {-# LINE 39 "src-ag/TfmToMirage.ag" #-}+   rule466 = \  (_ :: ()) ->+                         {-# LINE 39 "src-ag/TfmToMirage.ag" #-}+                         []+                         {-# LINE 3381 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule467 #-}+   rule467 = \  (_ :: ()) ->+     Seq.empty+   {-# INLINE rule468 #-}+   rule468 = \  (_ :: ()) ->+     Seq.empty+   {-# INLINE rule469 #-}+   rule469 = \  (_ :: ()) ->+     []+   {-# INLINE rule470 #-}+   rule470 = \  (_ :: ()) ->+     Seq.empty+   {-# INLINE rule471 #-}+   rule471 = \  (_ :: ()) ->+     Seq.empty+   {-# INLINE rule472 #-}+   rule472 = \  (_ :: ()) ->+     Seq.empty+   {-# INLINE rule473 #-}+   rule473 = \  (_ :: ()) ->+     Seq.empty+   {-# INLINE rule474 #-}+   rule474 = \  (_ :: ()) ->+     0+   {-# INLINE rule475 #-}+   rule475 = \  (_ :: ()) ->+     0+   {-# INLINE rule476 #-}+   rule476 = \  (_ :: ()) ->+     Seq.empty+   {-# INLINE rule477 #-}+   rule477 = \ ((_lhsIvcount) :: Int) ->+     _lhsIvcount++-- Rule --------------------------------------------------------+-- wrapper+data Inh_Rule  = Inh_Rule { allTypeSigs_Inh_Rule :: (Map Identifier Type), allfields_Inh_Rule :: ([(Identifier,Type,ChildKind)]), 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), inhsOfChildren_Inh_Rule :: (Map Identifier Attributes), mergeMap_Inh_Rule :: (Map Identifier (Identifier,[Identifier])), 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), options_Inh_Rule :: (Options), prefix_Inh_Rule :: (String), syn_Inh_Rule :: (Attributes), synsOfChildren_Inh_Rule :: (Map Identifier Attributes) }+data Syn_Rule  = Syn_Rule { 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]), mirage_Syn_Rule :: (Mirage.Rule), nAutoRules_Syn_Rule :: (Int), nExplicitRules_Syn_Rule :: (Int) }+{-# INLINABLE wrap_Rule #-}+wrap_Rule :: T_Rule  -> Inh_Rule  -> (Syn_Rule )+wrap_Rule (T_Rule act) (Inh_Rule _lhsIallTypeSigs _lhsIallfields _lhsIallnts _lhsIaltAttrs _lhsIattrs _lhsIchildInhs _lhsIchildNts _lhsIcon _lhsIinh _lhsIinhsOfChildren _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsyn _lhsIsynsOfChildren) =+   Control.Monad.Identity.runIdentity (+     do sem <- act+        let arg31 = T_Rule_vIn31 _lhsIallTypeSigs _lhsIallfields _lhsIallnts _lhsIaltAttrs _lhsIattrs _lhsIchildInhs _lhsIchildNts _lhsIcon _lhsIinh _lhsIinhsOfChildren _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsyn _lhsIsynsOfChildren+        (T_Rule_vOut31 _lhsOdirectDep _lhsOerrors _lhsOgathAltAttrs _lhsOgathRules _lhsOinstDep _lhsOinstVars _lhsOlocVars _lhsOmirage _lhsOnAutoRules _lhsOnExplicitRules) <- return (inv_Rule_s32 sem arg31)+        return (Syn_Rule _lhsOdirectDep _lhsOerrors _lhsOgathAltAttrs _lhsOgathRules _lhsOinstDep _lhsOinstVars _lhsOlocVars _lhsOmirage _lhsOnAutoRules _lhsOnExplicitRules)+   )++-- cata+{-# INLINE sem_Rule #-}+sem_Rule :: Rule  -> T_Rule +sem_Rule ( Rule mbName_ pattern_ rhs_ owrt_ origin_ explicit_ pure_ identity_ mbError_ eager_ ) = sem_Rule_Rule mbName_ ( sem_Pattern pattern_ ) ( sem_Expression rhs_ ) owrt_ origin_ explicit_ pure_ identity_ mbError_ eager_++-- semantic domain+newtype T_Rule  = T_Rule {+                         attach_T_Rule :: Identity (T_Rule_s32 )+                         }+newtype T_Rule_s32  = C_Rule_s32 {+                                 inv_Rule_s32 :: (T_Rule_v31 )+                                 }+data T_Rule_s33  = C_Rule_s33+type T_Rule_v31  = (T_Rule_vIn31 ) -> (T_Rule_vOut31 )+data T_Rule_vIn31  = T_Rule_vIn31 (Map Identifier Type) ([(Identifier,Type,ChildKind)]) ([Identifier]) (Map AltAttr Vertex) ([(Identifier,Identifier)]) (Map Identifier Attributes) (Map Identifier NontermIdent) (Identifier) (Attributes) (Map Identifier Attributes) (Map Identifier (Identifier,[Identifier])) (Identifier) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Options) (String) (Attributes) (Map Identifier Attributes)+data T_Rule_vOut31  = T_Rule_vOut31 (Seq Edge) (Seq Error) ([AltAttr]) (Seq CRule) (Seq Edge) ([Identifier]) ([Identifier]) (Mirage.Rule) (Int) (Int)+{-# NOINLINE sem_Rule_Rule #-}+sem_Rule_Rule :: (Maybe Identifier) -> T_Pattern  -> T_Expression  -> (Bool) -> (String) -> (Bool) -> (Bool) -> (Bool) -> (Maybe Error) -> (Bool) -> T_Rule +sem_Rule_Rule arg_mbName_ arg_pattern_ arg_rhs_ arg_owrt_ arg_origin_ arg_explicit_ _ _ _ _ = T_Rule (return st32) where+   {-# NOINLINE st32 #-}+   st32 = let+      v31 :: T_Rule_v31 +      v31 = \ (T_Rule_vIn31 _lhsIallTypeSigs _lhsIallfields _lhsIallnts _lhsIaltAttrs _lhsIattrs _lhsIchildInhs _lhsIchildNts _lhsIcon _lhsIinh _lhsIinhsOfChildren _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsyn _lhsIsynsOfChildren) -> ( let+         _patternX20 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pattern_))+         _rhsX8 = Control.Monad.Identity.runIdentity (attach_T_Expression (arg_rhs_))+         (T_Pattern_vOut19 _patternIcopy _patternIerrors _patternIgathAltAttrs _patternIinstVars _patternIisUnderscore _patternIlocVars _patternIpatternAttrs _patternIpp) = inv_Pattern_s20 _patternX20 (T_Pattern_vIn19 _patternOallTypeSigs _patternOaltAttrs _patternObelowIrrefutable _patternOcon _patternOinh _patternOnt _patternOsyn)+         (T_Expression_vOut7 _rhsIallRhsVars _rhsIcopy _rhsIerrors _rhsIlns _rhsItextLines _rhsIusedAttrs _rhsIusedFields _rhsIusedLocals) = inv_Expression_s8 _rhsX8 (T_Expression_vIn7 _rhsOallfields _rhsOallnts _rhsOattrs _rhsOcon _rhsOmergeMap _rhsOnt _rhsOoptions)+         _lhsOnExplicitRules :: Int+         _lhsOnExplicitRules = rule478 arg_explicit_+         _lhsOnAutoRules :: Int+         _lhsOnAutoRules = rule479 arg_origin_+         _defines = rule480 _lhsIallTypeSigs _lhsIaltAttrs _lhsIchildInhs _lhsIsyn _patternIpatternAttrs+         _gathRules = rule481 _defines _lhsIchildNts _lhsIcon _lhsInt _patternIcopy _rhsIallRhsVars _rhsItextLines arg_explicit_ arg_mbName_ arg_origin_ arg_owrt_+         _lhsOdirectDep :: Seq Edge+         _lhsOdirectDep = rule482 _defines _lhsIaltAttrs _rhsIusedAttrs _rhsIusedFields _rhsIusedLocals+         _instDep1 = rule483 _defines _lhsIaltAttrs _lhsIsynsOfChildren+         _instDep2 = rule484 _defines _lhsIaltAttrs _lhsIinhsOfChildren+         _lhsOinstDep :: Seq Edge+         _lhsOinstDep = rule485 _instDep1 _instDep2+         _lhsOmirage :: Mirage.Rule+         _lhsOmirage = rule486 _patternIpatternAttrs _patternIpp _rhsIlns _rhsIusedAttrs _rhsIusedFields _rhsIusedLocals arg_explicit_ arg_origin_+         _patternObelowIrrefutable = rule487  ()+         _lhsOerrors :: Seq Error+         _lhsOerrors = rule488 _patternIerrors _rhsIerrors+         _lhsOgathAltAttrs :: [AltAttr]+         _lhsOgathAltAttrs = rule489 _patternIgathAltAttrs+         _lhsOgathRules :: Seq CRule+         _lhsOgathRules = rule490 _gathRules+         _lhsOinstVars :: [Identifier]+         _lhsOinstVars = rule491 _patternIinstVars+         _lhsOlocVars :: [Identifier]+         _lhsOlocVars = rule492 _patternIlocVars+         _patternOallTypeSigs = rule493 _lhsIallTypeSigs+         _patternOaltAttrs = rule494 _lhsIaltAttrs+         _patternOcon = rule495 _lhsIcon+         _patternOinh = rule496 _lhsIinh+         _patternOnt = rule497 _lhsInt+         _patternOsyn = rule498 _lhsIsyn+         _rhsOallfields = rule499 _lhsIallfields+         _rhsOallnts = rule500 _lhsIallnts+         _rhsOattrs = rule501 _lhsIattrs+         _rhsOcon = rule502 _lhsIcon+         _rhsOmergeMap = rule503 _lhsImergeMap+         _rhsOnt = rule504 _lhsInt+         _rhsOoptions = rule505 _lhsIoptions+         __result_ = T_Rule_vOut31 _lhsOdirectDep _lhsOerrors _lhsOgathAltAttrs _lhsOgathRules _lhsOinstDep _lhsOinstVars _lhsOlocVars _lhsOmirage _lhsOnAutoRules _lhsOnExplicitRules+         in __result_ )+     in C_Rule_s32 v31+   {-# INLINE rule478 #-}+   {-# LINE 64 "src-ag/Order.ag" #-}+   rule478 = \ explicit_ ->+                                 {-# LINE 64 "src-ag/Order.ag" #-}+                                 if explicit_+                                 then 1+                                 else 0+                                 {-# LINE 3505 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule479 #-}+   {-# LINE 67 "src-ag/Order.ag" #-}+   rule479 = \ origin_ ->+                             {-# LINE 67 "src-ag/Order.ag" #-}+                             if startsWith "use rule" origin_ || startsWith "copy rule" origin_+                             then 1+                             else 0+                             {-# LINE 3513 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule480 #-}+   {-# LINE 220 "src-ag/Order.ag" #-}+   rule480 = \ ((_lhsIallTypeSigs) :: Map Identifier Type) ((_lhsIaltAttrs) :: Map AltAttr Vertex) ((_lhsIchildInhs) :: Map Identifier Attributes) ((_lhsIsyn) :: Attributes) ((_patternIpatternAttrs) :: [(Identifier,Identifier,Bool)]) ->+                           {-# LINE 220 "src-ag/Order.ag" #-}+                           let  tp field attr      | field == _LOC || field == _INST+                                                                    = Map.lookup attr _lhsIallTypeSigs+                                                    | field == _LHS = Map.lookup attr _lhsIsyn+                                                    | otherwise     = Map.lookup attr (findWithErr1 "Rule.defines.tp" field _lhsIchildInhs)+                                typ :: Pattern -> Maybe Type+                                typ (Alias field attr _)       = tp field attr+                                typ (Underscore _)             = Nothing+                                typ _                          = Nothing+                           in Map.fromList  [ (findWithErr1 "Rule.defines" aa _lhsIaltAttrs, (field,attr,(tp field attr)))+                                            | (field,attr,isLocalOrInst) <- _patternIpatternAttrs+                                            , let aa = AltAttr field attr isLocalOrInst+                                            ]+                           {-# LINE 3530 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule481 #-}+   {-# LINE 234 "src-ag/Order.ag" #-}+   rule481 = \ _defines ((_lhsIchildNts) :: Map Identifier NontermIdent) ((_lhsIcon) :: Identifier) ((_lhsInt) :: Identifier) ((_patternIcopy) :: Pattern) ((_rhsIallRhsVars) :: Set (Identifier,Identifier)) ((_rhsItextLines) :: [String]) explicit_ mbName_ origin_ owrt_ ->+                              {-# LINE 234 "src-ag/Order.ag" #-}+                              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 explicit_ mbName_+                                              | (field,attr,tp) <- Map.elems _defines+                                              ]+                              {-# LINE 3539 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule482 #-}+   {-# LINE 273 "src-ag/Order.ag" #-}+   rule482 = \ _defines ((_lhsIaltAttrs) :: Map AltAttr Vertex) ((_rhsIusedAttrs) :: [(Identifier,Identifier)]) ((_rhsIusedFields) :: [Identifier]) ((_rhsIusedLocals) :: [Identifier]) ->+                 {-# LINE 273 "src-ag/Order.ag" #-}+                 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 ]+                 {-# LINE 3548 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule483 #-}+   {-# LINE 317 "src-ag/Order.ag" #-}+   rule483 = \ _defines ((_lhsIaltAttrs) :: Map AltAttr Vertex) ((_lhsIsynsOfChildren) :: Map Identifier Attributes) ->+            {-# LINE 317 "src-ag/Order.ag" #-}+            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+              ]+            {-# LINE 3563 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule484 #-}+   {-# LINE 328 "src-ag/Order.ag" #-}+   rule484 = \ _defines ((_lhsIaltAttrs) :: Map AltAttr Vertex) ((_lhsIinhsOfChildren) :: Map Identifier Attributes) ->+            {-# LINE 328 "src-ag/Order.ag" #-}+            Seq.fromList $+              [ (instVert, inhVert)+              | (field,instNm,_) <- Map.elems _defines+              , field == _INST+              , inhNm <- Map.keys (findWithErr2 instNm _lhsIinhsOfChildren)+              , let instAttr = AltAttr _INST instNm True+                    inhAttr  = AltAttr instNm inhNm False+                    instVert = findWithErr2 instAttr _lhsIaltAttrs+                    inhVert  = findWithErr2 inhAttr _lhsIaltAttrs+              ]+            {-# LINE 3578 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule485 #-}+   {-# LINE 338 "src-ag/Order.ag" #-}+   rule485 = \ _instDep1 _instDep2 ->+                     {-# LINE 338 "src-ag/Order.ag" #-}+                     _instDep1     Seq.>< _instDep2+                     {-# LINE 3584 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule486 #-}+   {-# LINE 60 "src-ag/TfmToMirage.ag" #-}+   rule486 = \ ((_patternIpatternAttrs) :: [(Identifier,Identifier,Bool)]) ((_patternIpp) :: PP_Doc) ((_rhsIlns) :: [String]) ((_rhsIusedAttrs) :: [(Identifier,Identifier)]) ((_rhsIusedFields) :: [Identifier]) ((_rhsIusedLocals) :: [Identifier]) explicit_ origin_ ->+          {-# LINE 60 "src-ag/TfmToMirage.ag" #-}+          Mirage.Rule+            [Mirage.Address (getName field) (getName attr) | (field,attr,_) <- _patternIpatternAttrs]+            ([Mirage.Address (getName field) (getName attr) | (field,attr) <- _rhsIusedAttrs]+              ++ [ Mirage.Address (getName _LOC) (getName attr) | attr <- _rhsIusedLocals ++ _rhsIusedFields])+            explicit_+            origin_+            (disp (_patternIpp >-< indent 1 (text "= " >|< vlist _rhsIlns)) 0 "")+          {-# LINE 3596 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule487 #-}+   {-# LINE 98 "src-ag/TfmToMirage.ag" #-}+   rule487 = \  (_ :: ()) ->+                                      {-# LINE 98 "src-ag/TfmToMirage.ag" #-}+                                      False+                                      {-# LINE 3602 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule488 #-}+   rule488 = \ ((_patternIerrors) :: Seq Error) ((_rhsIerrors) :: Seq Error) ->+     _patternIerrors Seq.>< _rhsIerrors+   {-# INLINE rule489 #-}+   rule489 = \ ((_patternIgathAltAttrs) :: [AltAttr]) ->+     _patternIgathAltAttrs+   {-# INLINE rule490 #-}+   rule490 = \ _gathRules ->+     _gathRules+   {-# INLINE rule491 #-}+   rule491 = \ ((_patternIinstVars) :: [Identifier]) ->+     _patternIinstVars+   {-# INLINE rule492 #-}+   rule492 = \ ((_patternIlocVars) :: [Identifier]) ->+     _patternIlocVars+   {-# INLINE rule493 #-}+   rule493 = \ ((_lhsIallTypeSigs) :: Map Identifier Type) ->+     _lhsIallTypeSigs+   {-# INLINE rule494 #-}+   rule494 = \ ((_lhsIaltAttrs) :: Map AltAttr Vertex) ->+     _lhsIaltAttrs+   {-# INLINE rule495 #-}+   rule495 = \ ((_lhsIcon) :: Identifier) ->+     _lhsIcon+   {-# INLINE rule496 #-}+   rule496 = \ ((_lhsIinh) :: Attributes) ->+     _lhsIinh+   {-# INLINE rule497 #-}+   rule497 = \ ((_lhsInt) :: Identifier) ->+     _lhsInt+   {-# INLINE rule498 #-}+   rule498 = \ ((_lhsIsyn) :: Attributes) ->+     _lhsIsyn+   {-# INLINE rule499 #-}+   rule499 = \ ((_lhsIallfields) :: [(Identifier,Type,ChildKind)]) ->+     _lhsIallfields+   {-# INLINE rule500 #-}+   rule500 = \ ((_lhsIallnts) :: [Identifier]) ->+     _lhsIallnts+   {-# INLINE rule501 #-}+   rule501 = \ ((_lhsIattrs) :: [(Identifier,Identifier)]) ->+     _lhsIattrs+   {-# INLINE rule502 #-}+   rule502 = \ ((_lhsIcon) :: Identifier) ->+     _lhsIcon+   {-# INLINE rule503 #-}+   rule503 = \ ((_lhsImergeMap) :: Map Identifier (Identifier,[Identifier])) ->+     _lhsImergeMap+   {-# INLINE rule504 #-}+   rule504 = \ ((_lhsInt) :: Identifier) ->+     _lhsInt+   {-# INLINE rule505 #-}+   rule505 = \ ((_lhsIoptions) :: Options) ->+     _lhsIoptions++-- Rules -------------------------------------------------------+-- wrapper+data Inh_Rules  = Inh_Rules { allTypeSigs_Inh_Rules :: (Map Identifier Type), allfields_Inh_Rules :: ([(Identifier,Type,ChildKind)]), 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), inhsOfChildren_Inh_Rules :: (Map Identifier Attributes), mergeMap_Inh_Rules :: (Map Identifier (Identifier,[Identifier])), 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), options_Inh_Rules :: (Options), prefix_Inh_Rules :: (String), syn_Inh_Rules :: (Attributes), synsOfChildren_Inh_Rules :: (Map Identifier Attributes) }+data Syn_Rules  = Syn_Rules { 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]), mirages_Syn_Rules :: ([Mirage.Rule]), nAutoRules_Syn_Rules :: (Int), nExplicitRules_Syn_Rules :: (Int) }+{-# INLINABLE wrap_Rules #-}+wrap_Rules :: T_Rules  -> Inh_Rules  -> (Syn_Rules )+wrap_Rules (T_Rules act) (Inh_Rules _lhsIallTypeSigs _lhsIallfields _lhsIallnts _lhsIaltAttrs _lhsIattrs _lhsIchildInhs _lhsIchildNts _lhsIcon _lhsIinh _lhsIinhsOfChildren _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsyn _lhsIsynsOfChildren) =+   Control.Monad.Identity.runIdentity (+     do sem <- act+        let arg34 = T_Rules_vIn34 _lhsIallTypeSigs _lhsIallfields _lhsIallnts _lhsIaltAttrs _lhsIattrs _lhsIchildInhs _lhsIchildNts _lhsIcon _lhsIinh _lhsIinhsOfChildren _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsyn _lhsIsynsOfChildren+        (T_Rules_vOut34 _lhsOdirectDep _lhsOerrors _lhsOgathAltAttrs _lhsOgathRules _lhsOinstDep _lhsOinstVars _lhsOlocVars _lhsOmirages _lhsOnAutoRules _lhsOnExplicitRules) <- return (inv_Rules_s35 sem arg34)+        return (Syn_Rules _lhsOdirectDep _lhsOerrors _lhsOgathAltAttrs _lhsOgathRules _lhsOinstDep _lhsOinstVars _lhsOlocVars _lhsOmirages _lhsOnAutoRules _lhsOnExplicitRules)+   )++-- cata+{-# NOINLINE sem_Rules #-}+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 {+                           attach_T_Rules :: Identity (T_Rules_s35 )+                           }+newtype T_Rules_s35  = C_Rules_s35 {+                                   inv_Rules_s35 :: (T_Rules_v34 )+                                   }+data T_Rules_s36  = C_Rules_s36+type T_Rules_v34  = (T_Rules_vIn34 ) -> (T_Rules_vOut34 )+data T_Rules_vIn34  = T_Rules_vIn34 (Map Identifier Type) ([(Identifier,Type,ChildKind)]) ([Identifier]) (Map AltAttr Vertex) ([(Identifier,Identifier)]) (Map Identifier Attributes) (Map Identifier NontermIdent) (Identifier) (Attributes) (Map Identifier Attributes) (Map Identifier (Identifier,[Identifier])) (Identifier) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Options) (String) (Attributes) (Map Identifier Attributes)+data T_Rules_vOut34  = T_Rules_vOut34 (Seq Edge) (Seq Error) ([AltAttr]) (Seq CRule) (Seq Edge) ([Identifier]) ([Identifier]) ([Mirage.Rule]) (Int) (Int)+{-# NOINLINE sem_Rules_Cons #-}+sem_Rules_Cons :: T_Rule  -> T_Rules  -> T_Rules +sem_Rules_Cons arg_hd_ arg_tl_ = T_Rules (return st35) where+   {-# NOINLINE st35 #-}+   st35 = let+      v34 :: T_Rules_v34 +      v34 = \ (T_Rules_vIn34 _lhsIallTypeSigs _lhsIallfields _lhsIallnts _lhsIaltAttrs _lhsIattrs _lhsIchildInhs _lhsIchildNts _lhsIcon _lhsIinh _lhsIinhsOfChildren _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsyn _lhsIsynsOfChildren) -> ( let+         _hdX32 = Control.Monad.Identity.runIdentity (attach_T_Rule (arg_hd_))+         _tlX35 = Control.Monad.Identity.runIdentity (attach_T_Rules (arg_tl_))+         (T_Rule_vOut31 _hdIdirectDep _hdIerrors _hdIgathAltAttrs _hdIgathRules _hdIinstDep _hdIinstVars _hdIlocVars _hdImirage _hdInAutoRules _hdInExplicitRules) = inv_Rule_s32 _hdX32 (T_Rule_vIn31 _hdOallTypeSigs _hdOallfields _hdOallnts _hdOaltAttrs _hdOattrs _hdOchildInhs _hdOchildNts _hdOcon _hdOinh _hdOinhsOfChildren _hdOmergeMap _hdOnt _hdOo_case _hdOo_cata _hdOo_dovisit _hdOo_newtypes _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_wantvisit _hdOoptions _hdOprefix _hdOsyn _hdOsynsOfChildren)+         (T_Rules_vOut34 _tlIdirectDep _tlIerrors _tlIgathAltAttrs _tlIgathRules _tlIinstDep _tlIinstVars _tlIlocVars _tlImirages _tlInAutoRules _tlInExplicitRules) = inv_Rules_s35 _tlX35 (T_Rules_vIn34 _tlOallTypeSigs _tlOallfields _tlOallnts _tlOaltAttrs _tlOattrs _tlOchildInhs _tlOchildNts _tlOcon _tlOinh _tlOinhsOfChildren _tlOmergeMap _tlOnt _tlOo_case _tlOo_cata _tlOo_dovisit _tlOo_newtypes _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_wantvisit _tlOoptions _tlOprefix _tlOsyn _tlOsynsOfChildren)+         _lhsOmirages :: [Mirage.Rule]+         _lhsOmirages = rule506 _hdImirage _tlImirages+         _lhsOdirectDep :: Seq Edge+         _lhsOdirectDep = rule507 _hdIdirectDep _tlIdirectDep+         _lhsOerrors :: Seq Error+         _lhsOerrors = rule508 _hdIerrors _tlIerrors+         _lhsOgathAltAttrs :: [AltAttr]+         _lhsOgathAltAttrs = rule509 _hdIgathAltAttrs _tlIgathAltAttrs+         _lhsOgathRules :: Seq CRule+         _lhsOgathRules = rule510 _hdIgathRules _tlIgathRules+         _lhsOinstDep :: Seq Edge+         _lhsOinstDep = rule511 _hdIinstDep _tlIinstDep+         _lhsOinstVars :: [Identifier]+         _lhsOinstVars = rule512 _hdIinstVars _tlIinstVars+         _lhsOlocVars :: [Identifier]+         _lhsOlocVars = rule513 _hdIlocVars _tlIlocVars+         _lhsOnAutoRules :: Int+         _lhsOnAutoRules = rule514 _hdInAutoRules _tlInAutoRules+         _lhsOnExplicitRules :: Int+         _lhsOnExplicitRules = rule515 _hdInExplicitRules _tlInExplicitRules+         _hdOallTypeSigs = rule516 _lhsIallTypeSigs+         _hdOallfields = rule517 _lhsIallfields+         _hdOallnts = rule518 _lhsIallnts+         _hdOaltAttrs = rule519 _lhsIaltAttrs+         _hdOattrs = rule520 _lhsIattrs+         _hdOchildInhs = rule521 _lhsIchildInhs+         _hdOchildNts = rule522 _lhsIchildNts+         _hdOcon = rule523 _lhsIcon+         _hdOinh = rule524 _lhsIinh+         _hdOinhsOfChildren = rule525 _lhsIinhsOfChildren+         _hdOmergeMap = rule526 _lhsImergeMap+         _hdOnt = rule527 _lhsInt+         _hdOo_case = rule528 _lhsIo_case+         _hdOo_cata = rule529 _lhsIo_cata+         _hdOo_dovisit = rule530 _lhsIo_dovisit+         _hdOo_newtypes = rule531 _lhsIo_newtypes+         _hdOo_rename = rule532 _lhsIo_rename+         _hdOo_sem = rule533 _lhsIo_sem+         _hdOo_sig = rule534 _lhsIo_sig+         _hdOo_wantvisit = rule535 _lhsIo_wantvisit+         _hdOoptions = rule536 _lhsIoptions+         _hdOprefix = rule537 _lhsIprefix+         _hdOsyn = rule538 _lhsIsyn+         _hdOsynsOfChildren = rule539 _lhsIsynsOfChildren+         _tlOallTypeSigs = rule540 _lhsIallTypeSigs+         _tlOallfields = rule541 _lhsIallfields+         _tlOallnts = rule542 _lhsIallnts+         _tlOaltAttrs = rule543 _lhsIaltAttrs+         _tlOattrs = rule544 _lhsIattrs+         _tlOchildInhs = rule545 _lhsIchildInhs+         _tlOchildNts = rule546 _lhsIchildNts+         _tlOcon = rule547 _lhsIcon+         _tlOinh = rule548 _lhsIinh+         _tlOinhsOfChildren = rule549 _lhsIinhsOfChildren+         _tlOmergeMap = rule550 _lhsImergeMap+         _tlOnt = rule551 _lhsInt+         _tlOo_case = rule552 _lhsIo_case+         _tlOo_cata = rule553 _lhsIo_cata+         _tlOo_dovisit = rule554 _lhsIo_dovisit+         _tlOo_newtypes = rule555 _lhsIo_newtypes+         _tlOo_rename = rule556 _lhsIo_rename+         _tlOo_sem = rule557 _lhsIo_sem+         _tlOo_sig = rule558 _lhsIo_sig+         _tlOo_wantvisit = rule559 _lhsIo_wantvisit+         _tlOoptions = rule560 _lhsIoptions+         _tlOprefix = rule561 _lhsIprefix+         _tlOsyn = rule562 _lhsIsyn+         _tlOsynsOfChildren = rule563 _lhsIsynsOfChildren+         __result_ = T_Rules_vOut34 _lhsOdirectDep _lhsOerrors _lhsOgathAltAttrs _lhsOgathRules _lhsOinstDep _lhsOinstVars _lhsOlocVars _lhsOmirages _lhsOnAutoRules _lhsOnExplicitRules+         in __result_ )+     in C_Rules_s35 v34+   {-# INLINE rule506 #-}+   {-# LINE 53 "src-ag/TfmToMirage.ag" #-}+   rule506 = \ ((_hdImirage) :: Mirage.Rule) ((_tlImirages) :: [Mirage.Rule]) ->+                         {-# LINE 53 "src-ag/TfmToMirage.ag" #-}+                         _hdImirage : _tlImirages+                         {-# LINE 3775 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule507 #-}+   rule507 = \ ((_hdIdirectDep) :: Seq Edge) ((_tlIdirectDep) :: Seq Edge) ->+     _hdIdirectDep Seq.>< _tlIdirectDep+   {-# INLINE rule508 #-}+   rule508 = \ ((_hdIerrors) :: Seq Error) ((_tlIerrors) :: Seq Error) ->+     _hdIerrors Seq.>< _tlIerrors+   {-# INLINE rule509 #-}+   rule509 = \ ((_hdIgathAltAttrs) :: [AltAttr]) ((_tlIgathAltAttrs) :: [AltAttr]) ->+     _hdIgathAltAttrs ++ _tlIgathAltAttrs+   {-# INLINE rule510 #-}+   rule510 = \ ((_hdIgathRules) :: Seq CRule) ((_tlIgathRules) :: Seq CRule) ->+     _hdIgathRules Seq.>< _tlIgathRules+   {-# INLINE rule511 #-}+   rule511 = \ ((_hdIinstDep) :: Seq Edge) ((_tlIinstDep) :: Seq Edge) ->+     _hdIinstDep Seq.>< _tlIinstDep+   {-# INLINE rule512 #-}+   rule512 = \ ((_hdIinstVars) :: [Identifier]) ((_tlIinstVars) :: [Identifier]) ->+     _hdIinstVars ++ _tlIinstVars+   {-# INLINE rule513 #-}+   rule513 = \ ((_hdIlocVars) :: [Identifier]) ((_tlIlocVars) :: [Identifier]) ->+     _hdIlocVars ++ _tlIlocVars+   {-# INLINE rule514 #-}+   rule514 = \ ((_hdInAutoRules) :: Int) ((_tlInAutoRules) :: Int) ->+     _hdInAutoRules + _tlInAutoRules+   {-# INLINE rule515 #-}+   rule515 = \ ((_hdInExplicitRules) :: Int) ((_tlInExplicitRules) :: Int) ->+     _hdInExplicitRules + _tlInExplicitRules+   {-# INLINE rule516 #-}+   rule516 = \ ((_lhsIallTypeSigs) :: Map Identifier Type) ->+     _lhsIallTypeSigs+   {-# INLINE rule517 #-}+   rule517 = \ ((_lhsIallfields) :: [(Identifier,Type,ChildKind)]) ->+     _lhsIallfields+   {-# INLINE rule518 #-}+   rule518 = \ ((_lhsIallnts) :: [Identifier]) ->+     _lhsIallnts+   {-# INLINE rule519 #-}+   rule519 = \ ((_lhsIaltAttrs) :: Map AltAttr Vertex) ->+     _lhsIaltAttrs+   {-# INLINE rule520 #-}+   rule520 = \ ((_lhsIattrs) :: [(Identifier,Identifier)]) ->+     _lhsIattrs+   {-# INLINE rule521 #-}+   rule521 = \ ((_lhsIchildInhs) :: Map Identifier Attributes) ->+     _lhsIchildInhs+   {-# INLINE rule522 #-}+   rule522 = \ ((_lhsIchildNts) :: Map Identifier NontermIdent) ->+     _lhsIchildNts+   {-# INLINE rule523 #-}+   rule523 = \ ((_lhsIcon) :: Identifier) ->+     _lhsIcon+   {-# INLINE rule524 #-}+   rule524 = \ ((_lhsIinh) :: Attributes) ->+     _lhsIinh+   {-# INLINE rule525 #-}+   rule525 = \ ((_lhsIinhsOfChildren) :: Map Identifier Attributes) ->+     _lhsIinhsOfChildren+   {-# INLINE rule526 #-}+   rule526 = \ ((_lhsImergeMap) :: Map Identifier (Identifier,[Identifier])) ->+     _lhsImergeMap+   {-# INLINE rule527 #-}+   rule527 = \ ((_lhsInt) :: Identifier) ->+     _lhsInt+   {-# INLINE rule528 #-}+   rule528 = \ ((_lhsIo_case) :: Bool) ->+     _lhsIo_case+   {-# INLINE rule529 #-}+   rule529 = \ ((_lhsIo_cata) :: Bool) ->+     _lhsIo_cata+   {-# INLINE rule530 #-}+   rule530 = \ ((_lhsIo_dovisit) :: Bool) ->+     _lhsIo_dovisit+   {-# INLINE rule531 #-}+   rule531 = \ ((_lhsIo_newtypes) :: Bool) ->+     _lhsIo_newtypes+   {-# INLINE rule532 #-}+   rule532 = \ ((_lhsIo_rename) :: Bool) ->+     _lhsIo_rename+   {-# INLINE rule533 #-}+   rule533 = \ ((_lhsIo_sem) :: Bool) ->+     _lhsIo_sem+   {-# INLINE rule534 #-}+   rule534 = \ ((_lhsIo_sig) :: Bool) ->+     _lhsIo_sig+   {-# INLINE rule535 #-}+   rule535 = \ ((_lhsIo_wantvisit) :: Bool) ->+     _lhsIo_wantvisit+   {-# INLINE rule536 #-}+   rule536 = \ ((_lhsIoptions) :: Options) ->+     _lhsIoptions+   {-# INLINE rule537 #-}+   rule537 = \ ((_lhsIprefix) :: String) ->+     _lhsIprefix+   {-# INLINE rule538 #-}+   rule538 = \ ((_lhsIsyn) :: Attributes) ->+     _lhsIsyn+   {-# INLINE rule539 #-}+   rule539 = \ ((_lhsIsynsOfChildren) :: Map Identifier Attributes) ->+     _lhsIsynsOfChildren+   {-# INLINE rule540 #-}+   rule540 = \ ((_lhsIallTypeSigs) :: Map Identifier Type) ->+     _lhsIallTypeSigs+   {-# INLINE rule541 #-}+   rule541 = \ ((_lhsIallfields) :: [(Identifier,Type,ChildKind)]) ->+     _lhsIallfields+   {-# INLINE rule542 #-}+   rule542 = \ ((_lhsIallnts) :: [Identifier]) ->+     _lhsIallnts+   {-# INLINE rule543 #-}+   rule543 = \ ((_lhsIaltAttrs) :: Map AltAttr Vertex) ->+     _lhsIaltAttrs+   {-# INLINE rule544 #-}+   rule544 = \ ((_lhsIattrs) :: [(Identifier,Identifier)]) ->+     _lhsIattrs+   {-# INLINE rule545 #-}+   rule545 = \ ((_lhsIchildInhs) :: Map Identifier Attributes) ->+     _lhsIchildInhs+   {-# INLINE rule546 #-}+   rule546 = \ ((_lhsIchildNts) :: Map Identifier NontermIdent) ->+     _lhsIchildNts+   {-# INLINE rule547 #-}+   rule547 = \ ((_lhsIcon) :: Identifier) ->+     _lhsIcon+   {-# INLINE rule548 #-}+   rule548 = \ ((_lhsIinh) :: Attributes) ->+     _lhsIinh+   {-# INLINE rule549 #-}+   rule549 = \ ((_lhsIinhsOfChildren) :: Map Identifier Attributes) ->+     _lhsIinhsOfChildren+   {-# INLINE rule550 #-}+   rule550 = \ ((_lhsImergeMap) :: Map Identifier (Identifier,[Identifier])) ->+     _lhsImergeMap+   {-# INLINE rule551 #-}+   rule551 = \ ((_lhsInt) :: Identifier) ->+     _lhsInt+   {-# INLINE rule552 #-}+   rule552 = \ ((_lhsIo_case) :: Bool) ->+     _lhsIo_case+   {-# INLINE rule553 #-}+   rule553 = \ ((_lhsIo_cata) :: Bool) ->+     _lhsIo_cata+   {-# INLINE rule554 #-}+   rule554 = \ ((_lhsIo_dovisit) :: Bool) ->+     _lhsIo_dovisit+   {-# INLINE rule555 #-}+   rule555 = \ ((_lhsIo_newtypes) :: Bool) ->+     _lhsIo_newtypes+   {-# INLINE rule556 #-}+   rule556 = \ ((_lhsIo_rename) :: Bool) ->+     _lhsIo_rename+   {-# INLINE rule557 #-}+   rule557 = \ ((_lhsIo_sem) :: Bool) ->+     _lhsIo_sem+   {-# INLINE rule558 #-}+   rule558 = \ ((_lhsIo_sig) :: Bool) ->+     _lhsIo_sig+   {-# INLINE rule559 #-}+   rule559 = \ ((_lhsIo_wantvisit) :: Bool) ->+     _lhsIo_wantvisit+   {-# INLINE rule560 #-}+   rule560 = \ ((_lhsIoptions) :: Options) ->+     _lhsIoptions+   {-# INLINE rule561 #-}+   rule561 = \ ((_lhsIprefix) :: String) ->+     _lhsIprefix+   {-# INLINE rule562 #-}+   rule562 = \ ((_lhsIsyn) :: Attributes) ->+     _lhsIsyn+   {-# INLINE rule563 #-}+   rule563 = \ ((_lhsIsynsOfChildren) :: Map Identifier Attributes) ->+     _lhsIsynsOfChildren+{-# NOINLINE sem_Rules_Nil #-}+sem_Rules_Nil ::  T_Rules +sem_Rules_Nil  = T_Rules (return st35) where+   {-# NOINLINE st35 #-}+   st35 = let+      v34 :: T_Rules_v34 +      v34 = \ (T_Rules_vIn34 _lhsIallTypeSigs _lhsIallfields _lhsIallnts _lhsIaltAttrs _lhsIattrs _lhsIchildInhs _lhsIchildNts _lhsIcon _lhsIinh _lhsIinhsOfChildren _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsyn _lhsIsynsOfChildren) -> ( let+         _lhsOmirages :: [Mirage.Rule]+         _lhsOmirages = rule564  ()+         _lhsOdirectDep :: Seq Edge+         _lhsOdirectDep = rule565  ()+         _lhsOerrors :: Seq Error+         _lhsOerrors = rule566  ()+         _lhsOgathAltAttrs :: [AltAttr]+         _lhsOgathAltAttrs = rule567  ()+         _lhsOgathRules :: Seq CRule+         _lhsOgathRules = rule568  ()+         _lhsOinstDep :: Seq Edge+         _lhsOinstDep = rule569  ()+         _lhsOinstVars :: [Identifier]+         _lhsOinstVars = rule570  ()+         _lhsOlocVars :: [Identifier]+         _lhsOlocVars = rule571  ()+         _lhsOnAutoRules :: Int+         _lhsOnAutoRules = rule572  ()+         _lhsOnExplicitRules :: Int+         _lhsOnExplicitRules = rule573  ()+         __result_ = T_Rules_vOut34 _lhsOdirectDep _lhsOerrors _lhsOgathAltAttrs _lhsOgathRules _lhsOinstDep _lhsOinstVars _lhsOlocVars _lhsOmirages _lhsOnAutoRules _lhsOnExplicitRules+         in __result_ )+     in C_Rules_s35 v34+   {-# INLINE rule564 #-}+   {-# LINE 54 "src-ag/TfmToMirage.ag" #-}+   rule564 = \  (_ :: ()) ->+                         {-# LINE 54 "src-ag/TfmToMirage.ag" #-}+                         []+                         {-# LINE 3982 "src-generated/TfmToMirage.hs" #-}+   {-# INLINE rule565 #-}+   rule565 = \  (_ :: ()) ->+     Seq.empty+   {-# INLINE rule566 #-}+   rule566 = \  (_ :: ()) ->+     Seq.empty+   {-# INLINE rule567 #-}+   rule567 = \  (_ :: ()) ->+     []+   {-# INLINE rule568 #-}+   rule568 = \  (_ :: ()) ->+     Seq.empty+   {-# INLINE rule569 #-}+   rule569 = \  (_ :: ()) ->+     Seq.empty+   {-# INLINE rule570 #-}+   rule570 = \  (_ :: ()) ->+     []+   {-# INLINE rule571 #-}+   rule571 = \  (_ :: ()) ->+     []+   {-# INLINE rule572 #-}+   rule572 = \  (_ :: ()) ->+     0+   {-# INLINE rule573 #-}+   rule573 = \  (_ :: ()) ->+     0++-- TypeSig -----------------------------------------------------+-- wrapper+data Inh_TypeSig  = Inh_TypeSig { typeSigs_Inh_TypeSig :: (Map Identifier Type) }+data Syn_TypeSig  = Syn_TypeSig { typeSigs_Syn_TypeSig :: (Map Identifier Type) }+{-# INLINABLE wrap_TypeSig #-}+wrap_TypeSig :: T_TypeSig  -> Inh_TypeSig  -> (Syn_TypeSig )+wrap_TypeSig (T_TypeSig act) (Inh_TypeSig _lhsItypeSigs) =+   Control.Monad.Identity.runIdentity (+     do sem <- act+        let arg37 = T_TypeSig_vIn37 _lhsItypeSigs+        (T_TypeSig_vOut37 _lhsOtypeSigs) <- return (inv_TypeSig_s38 sem arg37)+        return (Syn_TypeSig _lhsOtypeSigs)+   )++-- cata+{-# INLINE sem_TypeSig #-}+sem_TypeSig :: TypeSig  -> T_TypeSig +sem_TypeSig ( TypeSig name_ tp_ ) = sem_TypeSig_TypeSig name_ tp_++-- semantic domain+newtype T_TypeSig  = T_TypeSig {+                               attach_T_TypeSig :: Identity (T_TypeSig_s38 )+                               }+newtype T_TypeSig_s38  = C_TypeSig_s38 {+                                       inv_TypeSig_s38 :: (T_TypeSig_v37 )+                                       }+data T_TypeSig_s39  = C_TypeSig_s39+type T_TypeSig_v37  = (T_TypeSig_vIn37 ) -> (T_TypeSig_vOut37 )+data T_TypeSig_vIn37  = T_TypeSig_vIn37 (Map Identifier Type)+data T_TypeSig_vOut37  = T_TypeSig_vOut37 (Map Identifier Type)+{-# NOINLINE sem_TypeSig_TypeSig #-}+sem_TypeSig_TypeSig :: (Identifier) -> (Type) -> T_TypeSig +sem_TypeSig_TypeSig arg_name_ arg_tp_ = T_TypeSig (return st38) where+   {-# NOINLINE st38 #-}+   st38 = let+      v37 :: T_TypeSig_v37 +      v37 = \ (T_TypeSig_vIn37 _lhsItypeSigs) -> ( let+         _lhsOtypeSigs :: Map Identifier Type+         _lhsOtypeSigs = rule574 _lhsItypeSigs arg_name_ arg_tp_+         __result_ = T_TypeSig_vOut37 _lhsOtypeSigs+         in __result_ )+     in C_TypeSig_s38 v37+   {-# INLINE rule574 #-}+   {-# LINE 536 "src-ag/Order.ag" #-}+   rule574 = \ ((_lhsItypeSigs) :: Map Identifier Type) name_ tp_ ->+                             {-# LINE 536 "src-ag/Order.ag" #-}+                             Map.insert name_ tp_ _lhsItypeSigs+                             {-# LINE 4058 "src-generated/TfmToMirage.hs" #-}++-- TypeSigs ----------------------------------------------------+-- wrapper+data Inh_TypeSigs  = Inh_TypeSigs { typeSigs_Inh_TypeSigs :: (Map Identifier Type) }+data Syn_TypeSigs  = Syn_TypeSigs { typeSigs_Syn_TypeSigs :: (Map Identifier Type) }+{-# INLINABLE wrap_TypeSigs #-}+wrap_TypeSigs :: T_TypeSigs  -> Inh_TypeSigs  -> (Syn_TypeSigs )+wrap_TypeSigs (T_TypeSigs act) (Inh_TypeSigs _lhsItypeSigs) =+   Control.Monad.Identity.runIdentity (+     do sem <- act+        let arg40 = T_TypeSigs_vIn40 _lhsItypeSigs+        (T_TypeSigs_vOut40 _lhsOtypeSigs) <- return (inv_TypeSigs_s41 sem arg40)+        return (Syn_TypeSigs _lhsOtypeSigs)+   )++-- cata+{-# NOINLINE sem_TypeSigs #-}+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 {+                                 attach_T_TypeSigs :: Identity (T_TypeSigs_s41 )+                                 }+newtype T_TypeSigs_s41  = C_TypeSigs_s41 {+                                         inv_TypeSigs_s41 :: (T_TypeSigs_v40 )+                                         }+data T_TypeSigs_s42  = C_TypeSigs_s42+type T_TypeSigs_v40  = (T_TypeSigs_vIn40 ) -> (T_TypeSigs_vOut40 )+data T_TypeSigs_vIn40  = T_TypeSigs_vIn40 (Map Identifier Type)+data T_TypeSigs_vOut40  = T_TypeSigs_vOut40 (Map Identifier Type)+{-# NOINLINE sem_TypeSigs_Cons #-}+sem_TypeSigs_Cons :: T_TypeSig  -> T_TypeSigs  -> T_TypeSigs +sem_TypeSigs_Cons arg_hd_ arg_tl_ = T_TypeSigs (return st41) where+   {-# NOINLINE st41 #-}+   st41 = let+      v40 :: T_TypeSigs_v40 +      v40 = \ (T_TypeSigs_vIn40 _lhsItypeSigs) -> ( let+         _hdX38 = Control.Monad.Identity.runIdentity (attach_T_TypeSig (arg_hd_))+         _tlX41 = Control.Monad.Identity.runIdentity (attach_T_TypeSigs (arg_tl_))+         (T_TypeSig_vOut37 _hdItypeSigs) = inv_TypeSig_s38 _hdX38 (T_TypeSig_vIn37 _hdOtypeSigs)+         (T_TypeSigs_vOut40 _tlItypeSigs) = inv_TypeSigs_s41 _tlX41 (T_TypeSigs_vIn40 _tlOtypeSigs)+         _lhsOtypeSigs :: Map Identifier Type+         _lhsOtypeSigs = rule575 _tlItypeSigs+         _hdOtypeSigs = rule576 _lhsItypeSigs+         _tlOtypeSigs = rule577 _hdItypeSigs+         __result_ = T_TypeSigs_vOut40 _lhsOtypeSigs+         in __result_ )+     in C_TypeSigs_s41 v40+   {-# INLINE rule575 #-}+   rule575 = \ ((_tlItypeSigs) :: Map Identifier Type) ->+     _tlItypeSigs+   {-# INLINE rule576 #-}+   rule576 = \ ((_lhsItypeSigs) :: Map Identifier Type) ->+     _lhsItypeSigs+   {-# INLINE rule577 #-}+   rule577 = \ ((_hdItypeSigs) :: Map Identifier Type) ->+     _hdItypeSigs+{-# NOINLINE sem_TypeSigs_Nil #-}+sem_TypeSigs_Nil ::  T_TypeSigs +sem_TypeSigs_Nil  = T_TypeSigs (return st41) where+   {-# NOINLINE st41 #-}+   st41 = let+      v40 :: T_TypeSigs_v40 +      v40 = \ (T_TypeSigs_vIn40 _lhsItypeSigs) -> ( let+         _lhsOtypeSigs :: Map Identifier Type+         _lhsOtypeSigs = rule578 _lhsItypeSigs+         __result_ = T_TypeSigs_vOut40 _lhsOtypeSigs+         in __result_ )+     in C_TypeSigs_s41 v40+   {-# INLINE rule578 #-}+   rule578 = \ ((_lhsItypeSigs) :: Map Identifier Type) ->+     _lhsItypeSigs
src-generated/TfmToVisage.hs view
@@ -3,95 +3,95 @@  module TfmToVisage where {-# LINE 2 "src-ag/Expression.ag" #-}-
-import UU.Scanner.Position(Pos)
-import HsToken
++import UU.Scanner.Position(Pos)+import HsToken {-# LINE 10 "src-generated/TfmToVisage.hs" #-}  {-# LINE 2 "src-ag/Patterns.ag" #-}-
--- Patterns.ag imports
-import UU.Scanner.Position(Pos)
-import CommonTypes (ConstructorIdent,Identifier)
++-- Patterns.ag imports+import UU.Scanner.Position(Pos)+import CommonTypes (ConstructorIdent,Identifier) {-# LINE 17 "src-generated/TfmToVisage.hs" #-}  {-# LINE 2 "src-ag/AbstractSyntax.ag" #-}-
--- AbstractSyntax.ag imports
-import Data.Set(Set)
-import Data.Map(Map)
-import Patterns    (Pattern(..),Patterns)
-import Expression  (Expression(..))
-import Macro --marcos
-import CommonTypes
-import ErrorMessages
++-- AbstractSyntax.ag imports+import Data.Set(Set)+import Data.Map(Map)+import Patterns    (Pattern(..),Patterns)+import Expression  (Expression(..))+import Macro --marcos+import CommonTypes+import ErrorMessages {-# LINE 29 "src-generated/TfmToVisage.hs" #-}  {-# LINE 9 "src-ag/TfmToVisage.ag" #-}-
-import AbstractSyntax
-import VisagePatterns
-import VisageSyntax
-import qualified Data.Map as Map
-import Data.Map (Map)
++import AbstractSyntax+import VisagePatterns+import VisageSyntax+import qualified Data.Map as Map+import Data.Map (Map) {-# LINE 38 "src-generated/TfmToVisage.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 17 "src-ag/TfmToVisage.ag" #-}-
--- 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
-
--}
++-- 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++-} {-# LINE 96 "src-generated/TfmToVisage.hs" #-} -- Child ------------------------------------------------------- -- wrapper
src-generated/Transform.hs view
@@ -3,42 +3,42 @@  module Transform where {-# LINE 2 "src-ag/Patterns.ag" #-}-
--- Patterns.ag imports
-import UU.Scanner.Position(Pos)
-import CommonTypes (ConstructorIdent,Identifier)
++-- Patterns.ag imports+import UU.Scanner.Position(Pos)+import CommonTypes (ConstructorIdent,Identifier) {-# LINE 11 "src-generated/Transform.hs" #-}  {-# LINE 2 "src-ag/ConcreteSyntax.ag" #-}-
-import UU.Scanner.Position (Pos)
-import Patterns   (Pattern)
-import Expression (Expression)
-import CommonTypes
-import Macro --marcos
++import UU.Scanner.Position (Pos)+import Patterns   (Pattern)+import Expression (Expression)+import CommonTypes+import Macro --marcos {-# LINE 20 "src-generated/Transform.hs" #-}  {-# LINE 8 "src-ag/Transform.ag" #-}-
-import Control.Monad(mplus,mzero)
-import Data.List (partition, nub,intersperse, union)
-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, elems)
-import qualified Data.Sequence as Seq
-import Data.Sequence(Seq, (><))
-import UU.Scanner.Position(noPos)
-
-import ConcreteSyntax
-import AbstractSyntax
-import ErrorMessages
-import Patterns (Patterns,Pattern(..))
-import Expression (Expression(..))
-import HsToken
-
-import RhsCheck
-import Debug.Trace
++import Control.Monad(mplus,mzero)+import Data.List (partition, nub,intersperse, union)+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, elems)+import qualified Data.Sequence as Seq+import Data.Sequence(Seq, (><))+import UU.Scanner.Position(noPos)++import ConcreteSyntax+import AbstractSyntax+import ErrorMessages+import Patterns (Patterns,Pattern(..))+import Expression (Expression(..))+import HsToken++import RhsCheck+import Debug.Trace {-# LINE 43 "src-generated/Transform.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity@@ -83,431 +83,431 @@ {-# LINE 84 "src-generated/Transform.hs" #-}  {-# LINE 203 "src-ag/Transform.ag" #-}-
-
-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.singleton (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 :: (b -> t -> (t, Seq Error)) -> t -> [b] -> (t, Seq Error)
-foldErrors f n xs = foldl g (n,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 _ [] = []
-checkForDuplicates err (x:xs) = let (same,other) = partition (equalId x) xs
-                                in  map (err x) same ++ checkForDuplicates err other
-
-equalId :: Identifier -> Identifier -> Bool
-equalId x y = getName x == getName y
-
+++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.singleton (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 :: (b -> t -> (t, Seq Error)) -> t -> [b] -> (t, Seq Error)+foldErrors f n xs = foldl g (n,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 _ [] = []+checkForDuplicates err (x:xs) = let (same,other) = partition (equalId x) xs+                                in  map (err x) same ++ checkForDuplicates err other++equalId :: Identifier -> Identifier -> Bool+equalId x y = getName x == getName y+ {-# LINE 116 "src-generated/Transform.hs" #-}  {-# LINE 354 "src-ag/Transform.ag" #-}-
-type RulesAndErrors = ([Rule], Seq Error)
-type SigsAndErrors  = ([TypeSig], Seq Error)
-type InstsAndErrors = ([(Identifier, Type)], Seq Error)
-type UniquesAndErrors = (Map Identifier Identifier, Seq Error)
-type AugmentsAndErrors = (Map Identifier [Expression], Seq Error)
-type AroundsAndErrors = (Map Identifier [Expression], Seq Error)
-type MergesAndErrors  = (Map Identifier (Identifier, [Identifier], Expression), Seq Error)
-type AttrOverwrite  = Map AttrName Bool
-type AccumRuleCheck = (RulesAndErrors, AttrOverwrite)
-type AccumDefiCheck = (Seq Error, AttrOverwrite, [AttrName], [AttrName])
-
-checkRules :: Map NontermIdent (Attributes, Attributes) -> DataTypes ->
-              Map NontermIdent (Map ConstructorIdent [Identifier]) -> Map NontermIdent (Map ConstructorIdent [SigInfo]) ->
-              Map NontermIdent (Map ConstructorIdent [MergeInfo]) ->
-              NontermIdent -> ConstructorIdent -> [RuleInfo] -> RulesAndErrors
-checkRules attributes fields allinsts allsigs _ nt con rs
-  = let fieldmap :: FieldMap
-        fieldmap = (_LHS, NT nt [] False) : (_LOC, NT nullIdent [] False) : (_INST, NT nullIdent [] False) : (_FIRST, NT nullIdent [] False) : (_LAST, NT nullIdent [] False)
-                 : 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))
-                 --   merged children are not allowed to have any inherited attrs defined: do not include
-
-        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 (mbNm, pat,ex,as,owrt,str, pur, eager) ((r1,e1),m1)
-          = let (e2,m2,u2,_) = foldr (checkDefi owrt) (e1,m1,[],[]) as
-            in  ( (Rule mbNm (pat u2) ex owrt str True pur False Nothing eager : 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 _ _) ->
-                  let tp' = maybe tp id (deforestedNt tp)
-                  in              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.<|)) (DupRule nt con field attr2 attr)   e,                    m, fa:u,    bs)
-                                           Nothing ->           (                                             e, Map.insert fa owrt m,    u, fa:bs)
-                                  else                          (((Seq.<|)) (SuperfluousRule nt con field attr) e,                    m, fa:u,    bs)
-                _              ->                               (((Seq.<|)) (UndefChild nt con field)           e,                    m, fa:u,    bs )
-
-    in  fst (foldr checkRule (([],Seq.empty),Map.empty) rs)
-
-checkRuleNames :: NontermIdent -> ConstructorIdent -> [RuleInfo] -> Seq Error
-checkRuleNames nt con
-  = fst . foldr checkRule (Seq.empty, Set.empty)
-  where
-    checkRule (Just nm,_,_,_,_,_,_,_) (errs, nms)
-      | nm `Set.member` nms = (DupRuleName nt con nm Seq.<| errs, nms)
-      | otherwise           = (errs, Set.insert nm nms)
-    checkRule (Nothing,_,_,_,_,_,_,_) inp = inp
-
-checkSigs :: NontermIdent -> ConstructorIdent -> [SigInfo] -> SigsAndErrors
-checkSigs nt con sis
-  = let checkSig (ide,typ) (sigs,errs)
-         = if   ide `elem` map (\(TypeSig n _)-> n) sigs
-           then (sigs, ((Seq.<|)) (DupSig nt con ide) errs)
-           -- else if not (ide `elem` locattrdefs)
-           -- then (sigs, ((Seq.<|)) (SupSig nt con ide) errs)
-           else (TypeSig ide typ:sigs, errs)
-    in  foldr checkSig ([],Seq.empty) sis
-
-checkInsts :: Set NontermIdent -> Map NontermIdent (Map ConstructorIdent [SigInfo]) -> DataTypes -> NontermIdent -> ConstructorIdent -> [Identifier] -> InstsAndErrors
-checkInsts allNts sigMap _ nt con
-  = foldr (\inst (insts, errs) ->
-              maybe (insts, Seq.singleton (MissingInstSig nt con inst) >< errs)
-                    (\info@(k, NT nm args _) ->
-                      case findInst k insts of
-                        Just k' -> (insts, Seq.singleton (DupChild nt con k k') >< errs)
-                        Nothing -> case nm `Set.member` allNts of
-                                             True  -> (info : insts, errs)
-                                             False | take 2 (getName nm) == "T_" -> let nm'   = Ident (drop 2 (getName nm)) (getPos nm)
-                                                                                        info' = (k, NT nm' args True)   -- this should be the only place at which 'for' with value True can be generated
-                                                                                    in case nm' `Set.member` allNts of
-                                                                                         True  -> (info' : insts, errs)
-                                                                                         False -> (insts, Seq.singleton (UndefNont nm') >< errs)
-                                                   | otherwise                   -> (insts, Seq.singleton (UndefNont nm) >< 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)
-
-    findInst _ [] = Nothing
-    findInst k ((k', _): r)
-      | k == k'   = Just k'
-      | otherwise = findInst k r
-
-checkUniques :: Map NontermIdent (Attributes, Attributes) -> NontermIdent -> ConstructorIdent -> [UniqueInfo] -> UniquesAndErrors
-checkUniques allAttrs nt con uniques
-  = let checkUnique (ident,ref) (us,errs)
-          = if ident `Map.member` us
-            then (us, ((Seq.<|)) (DupUnique nt con ident) errs)
-            else if Map.member ref inhs && Map.member ref syns
-                 then (Map.insert ident ref us, errs)
-                 else (us, ((Seq.<|)) (MissingUnique nt ref) errs)
-
-        (inhs,syns) = Map.findWithDefault (Map.empty,Map.empty) nt allAttrs
-    in foldr checkUnique (Map.empty, Seq.empty) uniques
-
-checkAugments :: Map NontermIdent (Attributes, Attributes) -> NontermIdent -> ConstructorIdent -> [AugmentInfo] -> AugmentsAndErrors
-checkAugments allAttrs nt _ augments
-  = let checkAugment (ident,expr) (as,errs)
-          = if ident `Map.member` as
-            then (Map.update (\vs -> Just (vs ++ [expr])) ident as, errs)
-            else if Map.member ident syns
-                 then (Map.insert ident [expr] as, errs)
-                 else (as, ((Seq.<|)) (MissingSyn nt ident) errs)
-
-        (_,syns) = Map.findWithDefault (Map.empty,Map.empty) nt allAttrs
-    in foldr checkAugment (Map.empty, Seq.empty) augments
-
-checkArounds :: DataTypes -> NontermIdent -> ConstructorIdent -> [AroundInfo] -> AroundsAndErrors
-checkArounds fieldMap nt con arounds
-  = let checkAround (ident,expr) (as,errs)
-          = if ident `Map.member` as
-            then (Map.update (\vs -> Just (vs ++ [expr])) ident as, errs)
-            else case lookup ident fields of
-                   Just (NT _ _ _) -> (Map.insert ident [expr] as, errs)
-                   _               -> (as, ((Seq.<|)) (UndefChild nt con ident) errs)
-        fields = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt fieldMap)
-    in foldr checkAround (Map.empty, Seq.empty) arounds
-
-checkMerges :: Set NontermIdent -> Map NontermIdent (Map ConstructorIdent [Identifier]) -> DataTypes -> NontermIdent -> ConstructorIdent -> [MergeInfo] -> MergesAndErrors
-checkMerges allNts allInsts fieldMap _ con merges
-  = let checkMerge (target,nt,sources,expr) (m,errs)
-          = let fields = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt fieldMap)
-                insts  = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allInsts)
-                allFields = insts ++ map fst fields   -- note: sources of merge may not contain a target (for simplicity)
-            in if target `Map.member` m   -- check for duplicate with self
-               then (m, DupChild nt con target (fst $ Map.elemAt (Map.findIndex target m) m) Seq.<| errs)
-               else if target `elem` allFields
-                     then (m, DupChild nt con target (head $ filter (== target) allFields) Seq.<| errs)
-                     else let missing = filter (\s -> not (s `elem` allFields)) sources
-                          in if null missing
-                             then if nt `Set.member` allNts   -- check if the nonterm is defined
-                                  then (Map.insert target (nt, sources, expr) m, errs) -- all ok..
-                                  else (m, UndefNont nt Seq.<| errs)
-                             else (m, (Seq.fromList $ map (UndefChild nt con) missing) Seq.>< errs)
-    in foldr checkMerge (Map.empty, Seq.empty) merges
-
-unionunionplusplus :: Map NontermIdent (Map ConstructorIdent [a]) -> Map NontermIdent (Map ConstructorIdent [a]) -> Map NontermIdent (Map ConstructorIdent [a])
-unionunionplusplus = Map.unionWith (Map.unionWith (++))
++type RulesAndErrors = ([Rule], Seq Error)+type SigsAndErrors  = ([TypeSig], Seq Error)+type InstsAndErrors = ([(Identifier, Type)], Seq Error)+type UniquesAndErrors = (Map Identifier Identifier, Seq Error)+type AugmentsAndErrors = (Map Identifier [Expression], Seq Error)+type AroundsAndErrors = (Map Identifier [Expression], Seq Error)+type MergesAndErrors  = (Map Identifier (Identifier, [Identifier], Expression), Seq Error)+type AttrOverwrite  = Map AttrName Bool+type AccumRuleCheck = (RulesAndErrors, AttrOverwrite)+type AccumDefiCheck = (Seq Error, AttrOverwrite, [AttrName], [AttrName])++checkRules :: Map NontermIdent (Attributes, Attributes) -> DataTypes ->+              Map NontermIdent (Map ConstructorIdent [Identifier]) -> Map NontermIdent (Map ConstructorIdent [SigInfo]) ->+              Map NontermIdent (Map ConstructorIdent [MergeInfo]) ->+              NontermIdent -> ConstructorIdent -> [RuleInfo] -> RulesAndErrors+checkRules attributes fields allinsts allsigs _ nt con rs+  = let fieldmap :: FieldMap+        fieldmap = (_LHS, NT nt [] False) : (_LOC, NT nullIdent [] False) : (_INST, NT nullIdent [] False) : (_FIRST, NT nullIdent [] False) : (_LAST, NT nullIdent [] False)+                 : 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))+                 --   merged children are not allowed to have any inherited attrs defined: do not include++        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 (mbNm, pat,ex,as,owrt,str, pur, eager) ((r1,e1),m1)+          = let (e2,m2,u2,_) = foldr (checkDefi owrt) (e1,m1,[],[]) as+            in  ( (Rule mbNm (pat u2) ex owrt str True pur False Nothing eager : 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 _ _) ->+                  let tp' = maybe tp id (deforestedNt tp)+                  in              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.<|)) (DupRule nt con field attr2 attr)   e,                    m, fa:u,    bs)+                                           Nothing ->           (                                             e, Map.insert fa owrt m,    u, fa:bs)+                                  else                          (((Seq.<|)) (SuperfluousRule nt con field attr) e,                    m, fa:u,    bs)+                _              ->                               (((Seq.<|)) (UndefChild nt con field)           e,                    m, fa:u,    bs )++    in  fst (foldr checkRule (([],Seq.empty),Map.empty) rs)++checkRuleNames :: NontermIdent -> ConstructorIdent -> [RuleInfo] -> Seq Error+checkRuleNames nt con+  = fst . foldr checkRule (Seq.empty, Set.empty)+  where+    checkRule (Just nm,_,_,_,_,_,_,_) (errs, nms)+      | nm `Set.member` nms = (DupRuleName nt con nm Seq.<| errs, nms)+      | otherwise           = (errs, Set.insert nm nms)+    checkRule (Nothing,_,_,_,_,_,_,_) inp = inp++checkSigs :: NontermIdent -> ConstructorIdent -> [SigInfo] -> SigsAndErrors+checkSigs nt con sis+  = let checkSig (ide,typ) (sigs,errs)+         = if   ide `elem` map (\(TypeSig n _)-> n) sigs+           then (sigs, ((Seq.<|)) (DupSig nt con ide) errs)+           -- else if not (ide `elem` locattrdefs)+           -- then (sigs, ((Seq.<|)) (SupSig nt con ide) errs)+           else (TypeSig ide typ:sigs, errs)+    in  foldr checkSig ([],Seq.empty) sis++checkInsts :: Set NontermIdent -> Map NontermIdent (Map ConstructorIdent [SigInfo]) -> DataTypes -> NontermIdent -> ConstructorIdent -> [Identifier] -> InstsAndErrors+checkInsts allNts sigMap _ nt con+  = foldr (\inst (insts, errs) ->+              maybe (insts, Seq.singleton (MissingInstSig nt con inst) >< errs)+                    (\info@(k, NT nm args _) ->+                      case findInst k insts of+                        Just k' -> (insts, Seq.singleton (DupChild nt con k k') >< errs)+                        Nothing -> case nm `Set.member` allNts of+                                             True  -> (info : insts, errs)+                                             False | take 2 (getName nm) == "T_" -> let nm'   = Ident (drop 2 (getName nm)) (getPos nm)+                                                                                        info' = (k, NT nm' args True)   -- this should be the only place at which 'for' with value True can be generated+                                                                                    in case nm' `Set.member` allNts of+                                                                                         True  -> (info' : insts, errs)+                                                                                         False -> (insts, Seq.singleton (UndefNont nm') >< errs)+                                                   | otherwise                   -> (insts, Seq.singleton (UndefNont nm) >< 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)++    findInst _ [] = Nothing+    findInst k ((k', _): r)+      | k == k'   = Just k'+      | otherwise = findInst k r++checkUniques :: Map NontermIdent (Attributes, Attributes) -> NontermIdent -> ConstructorIdent -> [UniqueInfo] -> UniquesAndErrors+checkUniques allAttrs nt con uniques+  = let checkUnique (ident,ref) (us,errs)+          = if ident `Map.member` us+            then (us, ((Seq.<|)) (DupUnique nt con ident) errs)+            else if Map.member ref inhs && Map.member ref syns+                 then (Map.insert ident ref us, errs)+                 else (us, ((Seq.<|)) (MissingUnique nt ref) errs)++        (inhs,syns) = Map.findWithDefault (Map.empty,Map.empty) nt allAttrs+    in foldr checkUnique (Map.empty, Seq.empty) uniques++checkAugments :: Map NontermIdent (Attributes, Attributes) -> NontermIdent -> ConstructorIdent -> [AugmentInfo] -> AugmentsAndErrors+checkAugments allAttrs nt _ augments+  = let checkAugment (ident,expr) (as,errs)+          = if ident `Map.member` as+            then (Map.update (\vs -> Just (vs ++ [expr])) ident as, errs)+            else if Map.member ident syns+                 then (Map.insert ident [expr] as, errs)+                 else (as, ((Seq.<|)) (MissingSyn nt ident) errs)++        (_,syns) = Map.findWithDefault (Map.empty,Map.empty) nt allAttrs+    in foldr checkAugment (Map.empty, Seq.empty) augments++checkArounds :: DataTypes -> NontermIdent -> ConstructorIdent -> [AroundInfo] -> AroundsAndErrors+checkArounds fieldMap nt con arounds+  = let checkAround (ident,expr) (as,errs)+          = if ident `Map.member` as+            then (Map.update (\vs -> Just (vs ++ [expr])) ident as, errs)+            else case lookup ident fields of+                   Just (NT _ _ _) -> (Map.insert ident [expr] as, errs)+                   _               -> (as, ((Seq.<|)) (UndefChild nt con ident) errs)+        fields = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt fieldMap)+    in foldr checkAround (Map.empty, Seq.empty) arounds++checkMerges :: Set NontermIdent -> Map NontermIdent (Map ConstructorIdent [Identifier]) -> DataTypes -> NontermIdent -> ConstructorIdent -> [MergeInfo] -> MergesAndErrors+checkMerges allNts allInsts fieldMap _ con merges+  = let checkMerge (target,nt,sources,expr) (m,errs)+          = let fields = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt fieldMap)+                insts  = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allInsts)+                allFields = insts ++ map fst fields   -- note: sources of merge may not contain a target (for simplicity)+            in if target `Map.member` m   -- check for duplicate with self+               then (m, DupChild nt con target (fst $ Map.elemAt (Map.findIndex target m) m) Seq.<| errs)+               else if target `elem` allFields+                     then (m, DupChild nt con target (head $ filter (== target) allFields) Seq.<| errs)+                     else let missing = filter (\s -> not (s `elem` allFields)) sources+                          in if null missing+                             then if nt `Set.member` allNts   -- check if the nonterm is defined+                                  then (Map.insert target (nt, sources, expr) m, errs) -- all ok..+                                  else (m, UndefNont nt Seq.<| errs)+                             else (m, (Seq.fromList $ map (UndefChild nt con) missing) Seq.>< errs)+    in foldr checkMerge (Map.empty, Seq.empty) merges++unionunionplusplus :: Map NontermIdent (Map ConstructorIdent [a]) -> Map NontermIdent (Map ConstructorIdent [a]) -> Map NontermIdent (Map ConstructorIdent [a])+unionunionplusplus = Map.unionWith (Map.unionWith (++)) {-# LINE 273 "src-generated/Transform.hs" #-}  {-# LINE 511 "src-ag/Transform.ag" #-}-
-mkUniqueRules :: Options -> Map NontermIdent (Map ConstructorIdent [RuleInfo]) -> DataTypes -> Map NontermIdent (Map ConstructorIdent [(Identifier, Type)]) -> Map NontermIdent (Attributes,Attributes) -> NontermIdent -> ConstructorIdent -> Map Identifier Identifier -> [Rule]
-mkUniqueRules opts allRules allFields allInsts allAttrDecls nt con usMap
-  = map apply groups
-  where
-    fields = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allFields)
-             ++ Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allInsts)
-             -- may have duplicates
-
-    attrDefs = let projectDefs (_,_,_,defs,_,_,_,_) = defs
-               in concatMap projectDefs $ Map.findWithDefault [] con $ Map.findWithDefault Map.empty nt allRules
-
-    groups = Map.assocs $ Map.foldrWithKey (\i r m -> Map.insertWith (++) r [i] m) Map.empty usMap
-    apply (ref,us) = mkRule ref (findOutField ref) us
-    findOutField ref = case [ chld | (chld, NT tp _ _) <- fields, tp `hasSyn` ref] of
-                         []    -> _LHS
-                         (x:_) -> x
-    hasSyn tp ref = Map.member ref $ snd $ Map.findWithDefault (Map.empty,Map.empty) tp allAttrDecls
-    mkRule ref outFld locAttrs
-      = let locs = filter (not . existsLoc) locAttrs
-            outAttr = attr outFld ref
-            defs = (if hasOut then [] else [outAttr]) ++ [attr _LOC u | u <- locs ]
-            pat = Product noPos defs
-            rhs = Expression noPos $ wrap ref $ foldr gencase (finalout hasOut locs) locs
-                     -- [HsToken ("mkUniques" ++ show (length locAttrs) ++ " ") noPos, AGField _LHS ref noPos Nothing]
-            rul = Rule Nothing pat rhs False "-- generated by the unique rule mechanism." False True False Nothing False
-            hasOut = exists outAttr
-            exists (Alias fld a _) = (fld,a) `elem` attrDefs
-            exists _ = False
-            existsLoc nm = exists (attr _LOC nm)
-        in rul
-    attr fld a = Alias fld a (Underscore noPos)
-    gencase nm outp
-      = h ("case " ++ uniqueDispenser opts ++ " __cont of { (__cont, " ++ getName nm ++ ") -> ") ++ outp ++ h "}"
-    h s = [HsToken s noPos]
-    finalout noGenCont us = h ("(" ++ concat (intersperse "," ( (if noGenCont then [] else ["__cont"]) ++ map getName us)) ++ ")")
-    wrap ref inp = h "let __cont = " ++ [AGField _LHS ref noPos Nothing] ++ h " in seq __cont ( " ++ inp ++ h " )"
++mkUniqueRules :: Options -> Map NontermIdent (Map ConstructorIdent [RuleInfo]) -> DataTypes -> Map NontermIdent (Map ConstructorIdent [(Identifier, Type)]) -> Map NontermIdent (Attributes,Attributes) -> NontermIdent -> ConstructorIdent -> Map Identifier Identifier -> [Rule]+mkUniqueRules opts allRules allFields allInsts allAttrDecls nt con usMap+  = map apply groups+  where+    fields = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allFields)+             ++ Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allInsts)+             -- may have duplicates++    attrDefs = let projectDefs (_,_,_,defs,_,_,_,_) = defs+               in concatMap projectDefs $ Map.findWithDefault [] con $ Map.findWithDefault Map.empty nt allRules++    groups = Map.assocs $ Map.foldrWithKey (\i r m -> Map.insertWith (++) r [i] m) Map.empty usMap+    apply (ref,us) = mkRule ref (findOutField ref) us+    findOutField ref = case [ chld | (chld, NT tp _ _) <- fields, tp `hasSyn` ref] of+                         []    -> _LHS+                         (x:_) -> x+    hasSyn tp ref = Map.member ref $ snd $ Map.findWithDefault (Map.empty,Map.empty) tp allAttrDecls+    mkRule ref outFld locAttrs+      = let locs = filter (not . existsLoc) locAttrs+            outAttr = attr outFld ref+            defs = (if hasOut then [] else [outAttr]) ++ [attr _LOC u | u <- locs ]+            pat = Product noPos defs+            rhs = Expression noPos $ wrap ref $ foldr gencase (finalout hasOut locs) locs+                     -- [HsToken ("mkUniques" ++ show (length locAttrs) ++ " ") noPos, AGField _LHS ref noPos Nothing]+            rul = Rule Nothing pat rhs False "-- generated by the unique rule mechanism." False True False Nothing False+            hasOut = exists outAttr+            exists (Alias fld a _) = (fld,a) `elem` attrDefs+            exists _ = False+            existsLoc nm = exists (attr _LOC nm)+        in rul+    attr fld a = Alias fld a (Underscore noPos)+    gencase nm outp+      = h ("case " ++ uniqueDispenser opts ++ " __cont of { (__cont, " ++ getName nm ++ ") -> ") ++ outp ++ h "}"+    h s = [HsToken s noPos]+    finalout noGenCont us = h ("(" ++ concat (intersperse "," ( (if noGenCont then [] else ["__cont"]) ++ map getName us)) ++ ")")+    wrap ref inp = h "let __cont = " ++ [AGField _LHS ref noPos Nothing] ++ h " in seq __cont ( " ++ inp ++ h " )" {-# LINE 313 "src-generated/Transform.hs" #-}  {-# LINE 747 "src-ag/Transform.ag" #-}-
-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 = reach
-  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 = foldr inv Map.empty . Map.toList
-  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
++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 = reach+  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 = foldr inv Map.empty . Map.toList+  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 {-# LINE 338 "src-generated/Transform.hs" #-}  {-# LINE 874 "src-ag/Transform.ag" #-}-
-extract :: String -> [String]
-extract s = case dropWhile isSeparator s of
-                                "" -> []
-                                s' -> w : extract s''
-                                      where (w, s'') = break isSeparator  s'
-isSeparator :: Char -> Bool
-isSeparator x = x == '_'
++extract :: String -> [String]+extract s = case dropWhile isSeparator s of+                                "" -> []+                                s' -> w : extract s''+                                      where (w, s'') = break isSeparator  s'+isSeparator :: Char -> Bool+isSeparator x = x == '_' {-# LINE 349 "src-generated/Transform.hs" #-}  {-# LINE 900 "src-ag/Transform.ag" #-}-
-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)
++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) {-# LINE 358 "src-generated/Transform.hs" #-}  {-# LINE 932 "src-ag/Transform.ag" #-}-
-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)
++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) {-# LINE 367 "src-generated/Transform.hs" #-}  {-# LINE 958 "src-ag/Transform.ag" #-}-
-mergeParams :: ParamMap -> ParamMap -> ParamMap
-mergeParams = Map.unionWith (++)
++mergeParams :: ParamMap -> ParamMap -> ParamMap+mergeParams = Map.unionWith (++) {-# LINE 373 "src-generated/Transform.hs" #-}  {-# LINE 981 "src-ag/Transform.ag" #-}-
-mergeCtx :: ContextMap -> ContextMap -> ContextMap
-mergeCtx
-  = Map.unionWith nubconcat
-  where nubconcat a b = nub (a ++ b)
++mergeCtx :: ContextMap -> ContextMap -> ContextMap+mergeCtx+  = Map.unionWith nubconcat+  where nubconcat a b = nub (a ++ b) {-# LINE 381 "src-generated/Transform.hs" #-}  {-# LINE 1000 "src-ag/Transform.ag" #-}-
-mergeQuant :: QuantMap -> QuantMap -> QuantMap
-mergeQuant = Map.unionWith (++)
++mergeQuant :: QuantMap -> QuantMap -> QuantMap+mergeQuant = Map.unionWith (++) {-# LINE 387 "src-generated/Transform.hs" #-}  {-# LINE 1011 "src-ag/Transform.ag" #-}-
-mergeDerivings :: Derivings -> Derivings -> Derivings
-mergeDerivings m1 m2 = foldr (\(n,cs) m -> Map.insertWith Set.union n cs m) m2 (Map.toList m1)
++mergeDerivings :: Derivings -> Derivings -> Derivings+mergeDerivings m1 m2 = foldr (\(n,cs) m -> Map.insertWith Set.union n cs m) m2 (Map.toList m1) {-# LINE 393 "src-generated/Transform.hs" #-}  {-# LINE 1023 "src-ag/Transform.ag" #-}-
-merge ::(Ord k, Ord k1) => Map k (Map k1 a) -> Map k (Map k1 a) -> Map k (Map k1 a)
-merge x y = foldr f y (Map.toList x)
- where f ~(k,v) m = Map.insertWith (Map.union) k v m
++merge ::(Ord k, Ord k1) => Map k (Map k1 a) -> Map k (Map k1 a) -> Map k (Map k1 a)+merge x y = foldr f y (Map.toList x)+ where f ~(k,v) m = Map.insertWith (Map.union) k v m {-# LINE 400 "src-generated/Transform.hs" #-}  {-# LINE 1066 "src-ag/Transform.ag" #-}-
-checkAttrs :: DataTypes -> [NontermIdent] -> [(Identifier, a)] -> [(Identifier, b)] -> Map NontermIdent (Map Identifier a, Map Identifier b) -> (Map NontermIdent (Map Identifier a, Map Identifier b), Seq Error)
-checkAttrs allFields nts inherited synthesized decls' = foldErrors check decls' nts where
-  check nt decls | not (nt `Map.member` allFields) = (decls,Seq.singleton(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)
++checkAttrs :: DataTypes -> [NontermIdent] -> [(Identifier, a)] -> [(Identifier, b)] -> Map NontermIdent (Map Identifier a, Map Identifier b) -> (Map NontermIdent (Map Identifier a, Map Identifier b), Seq Error)+checkAttrs allFields nts inherited synthesized decls' = foldErrors check decls' nts where+  check nt decls | not (nt `Map.member` allFields) = (decls,Seq.singleton(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) {-# LINE 411 "src-generated/Transform.hs" #-}  {-# LINE 1078 "src-ag/Transform.ag" #-}-
-addSelf :: Ord k1 => k1 -> Map k1 (Map k a, Attributes) -> Map k1 (Map k a, Attributes)
-addSelf name atMap = let (eInh,eSyn) = Map.findWithDefault(Map.empty,Map.empty) name atMap
-                     in  Map.insert name (eInh, Map.insert (Ident "self" noPos) Self eSyn)atMap
++addSelf :: Ord k1 => k1 -> Map k1 (Map k a, Attributes) -> Map k1 (Map k a, Attributes)+addSelf name atMap = let (eInh,eSyn) = Map.findWithDefault(Map.empty,Map.empty) name atMap+                     in  Map.insert name (eInh, Map.insert (Ident "self" noPos) Self eSyn)atMap {-# LINE 418 "src-generated/Transform.hs" #-}  {-# LINE 1216 "src-ag/Transform.ag" #-}-
--- We want the last Just in the list
-flipmplus = flip mplus
++-- We want the last Just in the list+flipmplus = flip mplus {-# LINE 424 "src-generated/Transform.hs" #-}  {-# LINE 1224 "src-ag/Transform.ag" #-}-
-makeType :: Set NontermIdent -> Type -> Type
-makeType nts tp@(NT x _ _)   | Set.member x nts = tp
-                             | otherwise        = Haskell (typeToHaskellString Nothing [] tp)
-makeType _   tp                                 = tp
++makeType :: Set NontermIdent -> Type -> Type+makeType nts tp@(NT x _ _)   | Set.member x nts = tp+                             | otherwise        = Haskell (typeToHaskellString Nothing [] tp)+makeType _   tp                                 = tp {-# LINE 432 "src-generated/Transform.hs" #-}  {-# LINE 1230 "src-ag/Transform.ag" #-}-
-constructGrammar ::    Set NontermIdent
-                    -> ParamMap
-                    -> Map NontermIdent (Map ConstructorIdent (Set Identifier))
-                    -> DataTypes
-                    -> Map NontermIdent [ConstructorIdent]
-                    -> Map NontermIdent (Map ConstructorIdent [Type])
-                    -> 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
-                    -> 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)))
-                    -> Map NontermIdent (Map ConstructorIdent MaybeMacro)
-                    -> Grammar
-
-constructGrammar _ ntParams prodParams gram prodOrder constraints attrs uses derivings wrap allrules tsigs allinsts tsyns pragmaMap orderMap contextMap quantMap uniqueMap augmentsMap aroundsMap mergeMap macros =
-   let gr = [ (nt,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
-                             mergemap  = Map.findWithDefault Map.empty             nt mergeMap
-                             macromap  = Map.findWithDefault Map.empty             nt macros
-                             csmap     = Map.findWithDefault Map.empty             nt constraints
-                             psmap     = Map.findWithDefault Map.empty             nt prodParams
-                             prs       = Map.findWithDefault []                    nt prodOrder
-                             alt con   =
-                                   let flds    = Map.findWithDefault [] con alts
-                                       rules   = Map.findWithDefault [] con rmap
-                                       tsigs'  = Map.findWithDefault [] con tsmap
-                                       insts   = Map.findWithDefault [] con instsmap
-                                       merges  = [ (n, NT t [] False) | (n, (t, _, _)) <- Map.assocs $ maybe Map.empty id (Map.lookup con mergemap) ]
-                                       cs      = Map.findWithDefault [] con csmap
-                                       ps      = Set.elems $ Map.findWithDefault Set.empty con psmap
-                                       mbMacro = Map.findWithDefault Nothing con macromap
-
-                                       -- important: keep order of children
-                                       cldrn = map child (flds ++ filter (not . existsAsField) insts ++ merges)
-                                       child (nm, tp) =
-                                          let tpI = if existsAsInst nm
-                                                    then fromJust $ lookup nm insts
-                                                    else tp
-                                              virt = if existsAsInst nm
-                                                     then case lookup nm flds of
-                                                            Just tp' -> ChildReplace tp'
-                                                            Nothing  -> ChildAttr
-                                                     else if existsAsMerge nm
-                                                          then ChildAttr
-                                                          else ChildSyntax
-                                          in Child nm tpI virt
-                                       existsAsInst nm = maybe False (const True) (lookup nm insts)
-                                       existsAsField (nm,_) = maybe False (const True) (lookup nm flds)
-                                       existsAsMerge nm = maybe False (const True) (lookup nm merges)
-                                   in Production con ps cs cldrn rules tsigs' mbMacro
-                            in Nonterminal nt params inh syn (map alt prs)
-   in Grammar tsyns uses derivings wrap nonts pragmaMap orderMap ntParams contextMap quantMap uniqueMap augmentsMap aroundsMap mergeMap
++constructGrammar ::    Set NontermIdent+                    -> ParamMap+                    -> Map NontermIdent (Map ConstructorIdent (Set Identifier))+                    -> DataTypes+                    -> Map NontermIdent [ConstructorIdent]+                    -> Map NontermIdent (Map ConstructorIdent [Type])+                    -> 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+                    -> 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)))+                    -> Map NontermIdent (Map ConstructorIdent MaybeMacro)+                    -> Grammar++constructGrammar _ ntParams prodParams gram prodOrder constraints attrs uses derivings wrap allrules tsigs allinsts tsyns pragmaMap orderMap contextMap quantMap uniqueMap augmentsMap aroundsMap mergeMap macros =+   let gr = [ (nt,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+                             mergemap  = Map.findWithDefault Map.empty             nt mergeMap+                             macromap  = Map.findWithDefault Map.empty             nt macros+                             csmap     = Map.findWithDefault Map.empty             nt constraints+                             psmap     = Map.findWithDefault Map.empty             nt prodParams+                             prs       = Map.findWithDefault []                    nt prodOrder+                             alt con   =+                                   let flds    = Map.findWithDefault [] con alts+                                       rules   = Map.findWithDefault [] con rmap+                                       tsigs'  = Map.findWithDefault [] con tsmap+                                       insts   = Map.findWithDefault [] con instsmap+                                       merges  = [ (n, NT t [] False) | (n, (t, _, _)) <- Map.assocs $ maybe Map.empty id (Map.lookup con mergemap) ]+                                       cs      = Map.findWithDefault [] con csmap+                                       ps      = Set.elems $ Map.findWithDefault Set.empty con psmap+                                       mbMacro = Map.findWithDefault Nothing con macromap++                                       -- important: keep order of children+                                       cldrn = map child (flds ++ filter (not . existsAsField) insts ++ merges)+                                       child (nm, tp) =+                                          let tpI = if existsAsInst nm+                                                    then fromJust $ lookup nm insts+                                                    else tp+                                              virt = if existsAsInst nm+                                                     then case lookup nm flds of+                                                            Just tp' -> ChildReplace tp'+                                                            Nothing  -> ChildAttr+                                                     else if existsAsMerge nm+                                                          then ChildAttr+                                                          else ChildSyntax+                                          in Child nm tpI virt+                                       existsAsInst nm = maybe False (const True) (lookup nm insts)+                                       existsAsField (nm,_) = maybe False (const True) (lookup nm flds)+                                       existsAsMerge nm = maybe False (const True) (lookup nm merges)+                                   in Production con ps cs cldrn rules tsigs' mbMacro+                            in Nonterminal nt params inh syn (map alt prs)+   in Grammar tsyns uses derivings wrap nonts pragmaMap orderMap ntParams contextMap quantMap uniqueMap augmentsMap aroundsMap mergeMap {-# LINE 504 "src-generated/Transform.hs" #-}  {-# LINE 1301 "src-ag/Transform.ag" #-}-
-mapUnionWithSetUnion :: Map NontermIdent (Set ConstructorIdent) -> Map NontermIdent (Set ConstructorIdent) -> Map NontermIdent (Set ConstructorIdent)
-mapUnionWithSetUnion = Map.unionWith Set.union
-mapUnionWithPlusPlus :: Map BlockInfo [a] -> Map BlockInfo [a] -> Map BlockInfo [a]
-mapUnionWithPlusPlus = Map.unionWith (++)
++mapUnionWithSetUnion :: Map NontermIdent (Set ConstructorIdent) -> Map NontermIdent (Set ConstructorIdent) -> Map NontermIdent (Set ConstructorIdent)+mapUnionWithSetUnion = Map.unionWith Set.union+mapUnionWithPlusPlus :: Map BlockInfo [a] -> Map BlockInfo [a] -> Map BlockInfo [a]+mapUnionWithPlusPlus = Map.unionWith (++) {-# LINE 512 "src-generated/Transform.hs" #-} -- AG ---------------------------------------------------------- -- wrapper
src-generated/Visage.hs view
@@ -3,66 +3,66 @@  module Visage where {-# LINE 2 "src-ag/Expression.ag" #-}-
-import UU.Scanner.Position(Pos)
-import HsToken
++import UU.Scanner.Position(Pos)+import HsToken {-# LINE 10 "src-generated/Visage.hs" #-}  {-# LINE 2 "src-ag/VisagePatterns.ag" #-}-
-import UU.Scanner.Position(Pos)
-import CommonTypes
++import UU.Scanner.Position(Pos)+import CommonTypes {-# LINE 16 "src-generated/Visage.hs" #-}  {-# LINE 2 "src-ag/VisageSyntax.ag" #-}-
-import CommonTypes
-import UU.Pretty
-import AbstractSyntax
-import VisagePatterns
-import Expression
++import CommonTypes+import UU.Pretty+import AbstractSyntax+import VisagePatterns+import Expression {-# LINE 25 "src-generated/Visage.hs" #-}  {-# LINE 6 "src-ag/Visage.ag" #-}-
-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 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 {-# LINE 39 "src-generated/Visage.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 19 "src-ag/Visage.ag" #-}-
-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
++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 {-# LINE 67 "src-generated/Visage.hs" #-} -- Expression -------------------------------------------------- -- wrapper
src-generated/VisagePatterns.hs view
@@ -3,9 +3,9 @@ -- UUAGC 0.9.53 (src-ag/VisagePatterns.ag) module VisagePatterns where {-# LINE 2 "src-ag/VisagePatterns.ag" #-}-
-import UU.Scanner.Position(Pos)
-import CommonTypes
++import UU.Scanner.Position(Pos)+import CommonTypes {-# LINE 10 "src-generated/VisagePatterns.hs" #-} -- VisagePattern ----------------------------------------------- {-
src-generated/VisageSyntax.hs view
@@ -3,12 +3,12 @@ -- UUAGC 0.9.53 (src-ag/VisageSyntax.ag) module VisageSyntax where {-# LINE 2 "src-ag/VisageSyntax.ag" #-}-
-import CommonTypes
-import UU.Pretty
-import AbstractSyntax
-import VisagePatterns
-import Expression
++import CommonTypes+import UU.Pretty+import AbstractSyntax+import VisagePatterns+import Expression {-# LINE 13 "src-generated/VisageSyntax.hs" #-} -- VisageChild ------------------------------------------------- {-
src-main/Main.hs view
@@ -1,6 +1,6 @@-module Main where
-
-import UU.UUAGC (uuagcMain)
-
-main :: IO ()
+module Main where++import UU.UUAGC (uuagcMain)++main :: IO () main = uuagcMain
src-options/Options.hs view
@@ -1,553 +1,557 @@-module Options where
-
-import System.Console.GetOpt
-import Data.Set(Set)
-import UU.Scanner.Position(Pos,noPos)
-import Data.List(intercalate)
-import qualified Data.Set as Set
-import System.IO
-import System.Exit
-
--- From CommonTypes
-data Identifier   = Ident { getName::String, getPos::Pos }
-type NontermIdent = Identifier
-identifier :: String -> Identifier
-identifier x      = Ident x noPos
-
-instance Eq Identifier where
- Ident x _ == Ident y _ = x == y
-
-instance Ord Identifier where
- compare (Ident x _) (Ident y _) = compare x y
-
-instance Show Identifier where
-  show ident = getName ident
-  
--- Make options serializable
-data MyOptDescr = MyOpt [Char] [String] (ArgDescr (Options -> Options)) (Options -> String -> [String]) String
-
-fromMyOpt :: MyOptDescr -> OptDescr (Options -> Options)
-fromMyOpt (MyOpt sh ln desc _ s) = Option sh ln desc s
-
-noOpt :: Options -> String -> [String]
-noOpt _ _ = []
-
-boolOpt :: (Options -> Bool) -> Options -> String -> [String]
-boolOpt get opt strArg = let oldVal = get noOptions
-                             newVal = get opt
-                         in  if   oldVal /= newVal
-                             then [strArg]
-                             else []
-
-stringOpt :: (Options -> String) -> Options -> String -> [String]
-stringOpt get opt strArg = let oldVal = get noOptions
-                               newVal = get opt
-                           in  if   oldVal /= newVal
-                               then [strArg, newVal]
-                               else []
-
-mbStringOpt :: (Options -> Maybe String) -> Options -> String -> [String]
-mbStringOpt get opts nm = maybe [] (\s -> [nm++"="++s]) (get opts)
-
-serializeOption :: Options -> MyOptDescr -> [String]
-serializeOption opt (MyOpt sh ln _ get _) = get opt strArg
-  where
-    strArg = if null sh
-             then '-' : '-' : head ln
-             else '-' : head sh : []
-
--- All options
-allOptions :: [MyOptDescr]
-allOptions =  
-  [ MyOpt ['m']     []                (NoArg (moduleOpt Nothing)) noOpt                 "generate default module header"
-  , MyOpt []        ["module"]        (OptArg moduleOpt "name")   moduleOptGet          "generate module header, specify module name"
-  , MyOpt ['d']     ["data"]          (NoArg dataOpt)             (boolOpt dataTypes)   "generate data type definition"
-  , MyOpt []        ["datarecords"]   (NoArg dataRecOpt)          (boolOpt dataRecords) "generate record data types"
-  , MyOpt []        ["strictdata"]    (NoArg strictDataOpt)       (boolOpt strictData)  "generate strict data fields (when data is generated)"
-  , MyOpt []        ["strictwrap"]    (NoArg strictWrapOpt)       (boolOpt strictWrap)  "generate strict wrap fields for WRAPPER generated data"
-  , MyOpt ['c']     ["catas"]         (NoArg cataOpt)             (boolOpt folds)       "generate catamorphisms"
-  , MyOpt ['f']     ["semfuns"]       (NoArg semfunsOpt)          (boolOpt semfuns)     "generate semantic functions"
-  , MyOpt ['s']     ["signatures"]    (NoArg signaturesOpt)       (boolOpt typeSigs)    "generate signatures for semantic functions"
-  , MyOpt []        ["newtypes"]      (NoArg newtypesOpt)         (boolOpt newtypes)    "use newtypes instead of type synonyms"
-  , MyOpt ['p']     ["pretty"]        (NoArg prettyOpt)           (boolOpt attrInfo)    "generate pretty printed list of attributes"
-  , MyOpt ['w']     ["wrappers"]      (NoArg wrappersOpt)         (boolOpt wrappers)    "generate wappers for semantic domains"
-  , MyOpt ['r']     ["rename"]        (NoArg renameOpt)           (boolOpt rename)      "rename data constructors"
-  , MyOpt []        ["modcopy"]       (NoArg modcopyOpt)          (boolOpt modcopy)     "use modified copy rule"
-  , MyOpt []        ["nest"]          (NoArg nestOpt)             (boolOpt nest)        "use nested tuples"
-  , MyOpt []        ["syntaxmacro"]   (NoArg smacroOpt)           (boolOpt smacro)      "experimental: generate syntax macro code (using knit catas)"
-  , MyOpt ['o']     ["output"]        (ReqArg outputOpt "file")   outputOptGet          "specify output file"
-  , MyOpt ['v']     ["verbose"]       (NoArg verboseOpt)          (boolOpt verbose)     "verbose error message format"
-  , MyOpt ['h','?'] ["help"]          (NoArg helpOpt)             (boolOpt showHelp)    "get (this) usage information"
-  , MyOpt ['a']     ["all"]           (NoArg allOpt)              noOpt                ("do everything (-" ++ allc ++ ")")
-  , MyOpt ['P']     [""]              (ReqArg searchPathOpt "search path") searchPathOptGet ("specify seach path")
-  , MyOpt []        ["prefix"]        (ReqArg prefixOpt "prefix") (stringOpt prefix)    "set prefix for semantic functions"
-  , MyOpt []        ["self"]          (NoArg selfOpt)             (boolOpt withSelf)    "generate self attribute"
-  , MyOpt []        ["cycle"]         (NoArg cycleOpt)            (boolOpt withCycle)   "check for cyclic definitions"
-  , MyOpt []        ["version"]       (NoArg versionOpt)          (boolOpt showVersion) "get version information"
-  , MyOpt ['O']     ["optimize"]      (NoArg optimizeOpt)         noOpt                 "optimize generated code (--visit --case)"
-  , MyOpt []        ["visit"]         (NoArg visitOpt)            (boolOpt visit)       "try generating visit functions"
-  , MyOpt []        ["loag"]          (OptArg loagOpt "Bool")     (boolOpt loag)        "recognises all linear ordered attribute grammars by generting a SAT problem, uses --verbose to print out numbers of clauses and variables"
-  , MyOpt []        ["aoag"]          (NoArg aoagOpt)             (boolOpt aoag)        "recognises all linear ordered attribute grammars by finding fake dependencies, uses --verbose to print out the selected fake dependencies"
-  , MyOpt []        ["seq"]           (NoArg seqOpt)              (boolOpt withSeq)     "force evaluation using function seq (visit functions only)"
-  , MyOpt []        ["unbox"]         (NoArg unboxOpt)            (boolOpt unbox)       "use unboxed tuples"
-  , MyOpt []        ["bangpats"]      (NoArg bangpatsOpt)         (boolOpt bangpats)    "use bang patterns (visit functions only)"
-  , MyOpt []        ["case"]          (NoArg casesOpt)            (boolOpt cases)       "Use nested cases instead of let (visit functions only)"
-  , MyOpt []        ["strictcase"]    (NoArg strictCasesOpt)      (boolOpt strictCases) "Force evaluation of the scrutinee of cases (in generated code, visit functions only)"
-  , MyOpt []        ["strictercase"]  (NoArg stricterCasesOpt)    (boolOpt stricterCases) "Force evaluation of all variables bound by a case statement (in generated code)"
-  , MyOpt []        ["strictsem"]     (NoArg strictSemOpt)        (boolOpt strictSems)  "Force evaluation of sem-function arguments (in generated code)"
-  , MyOpt []        ["localcps"]      (NoArg localCpsOpt)         (boolOpt localCps)    "Apply a local CPS transformation (in generated code, visit functions only)"
-  , MyOpt []        ["splitsems"]     (NoArg splitSemsOpt)        (boolOpt splitSems)   "Split semantic functions into smaller pieces"
-  , MyOpt []        ["Werrors"]       (NoArg werrorsOpt)          (boolOpt werrors)     "Turn warnings into fatal errors"
-  , MyOpt []        ["Wignore"]       (NoArg wignoreOpt)          (boolOpt wignore)     "Ignore warnings"
-  , MyOpt []        ["Wmax"]          (ReqArg wmaxErrsOpt "<max errs reported>") wmaxErrsOptGet "Sets the maximum number of errors that are reported"
-  , MyOpt []        ["dumpgrammar"]   (NoArg dumpgrammarOpt)      (boolOpt dumpgrammar) "Dump internal grammar representation (in generated code)"
-  , MyOpt []        ["dumpcgrammar"]  (NoArg dumpcgrammarOpt)     (boolOpt dumpcgrammar)"Dump internal cgrammar representation (in generated code)"
-  , MyOpt []        ["gentraces"]     (NoArg genTracesOpt)        (boolOpt genTraces)   "Generate trace expressions (in generated code)"
-  , MyOpt []        ["genusetraces"]  (NoArg genUseTracesOpt)     (boolOpt genUseTraces)"Generate trace expressions at attribute use sites (in generated code)"
-  , MyOpt []        ["gencostcentres"] (NoArg genCostCentresOpt)  (boolOpt genCostCentres) "Generate cost centre pragmas (in generated code)"
-  , MyOpt []        ["genlinepragmas"] (NoArg genLinePragmasOpt)  (boolOpt genLinePragmas) "Generate GHC LINE pragmas (in generated code)"
-  , MyOpt []        ["sepsemmods"]    (NoArg sepSemModsOpt)       (boolOpt sepSemMods)  "Generate separate modules for semantic functions (in generated code)"
-  , MyOpt ['M']     ["genfiledeps"]   (NoArg genFileDepsOpt)      (boolOpt genFileDeps) "Generate a list of dependencies on the input AG files"
-  , MyOpt []        ["genvisage"]     (NoArg genVisageOpt)        (boolOpt genvisage)   "Generate output for the AG visualizer Visage"
-  , MyOpt []        ["aspectag"]      (NoArg genAspectAGOpt)      (boolOpt genAspectAG) "Generate AspectAG file"
-  , MyOpt []        ["nogroup"]       (ReqArg noGroupOpt "attributes") noGroupOptGet    "specify the attributes that won't be grouped in AspectAG"
-  , MyOpt []        ["extends"]       (ReqArg extendsOpt "module") (mbStringOpt extends)        "specify a module to be extended"
-  , MyOpt []        ["genattrlist"]   (NoArg genAttrListOpt)      (boolOpt genAttributeList) "Generate a list of all explicitly defined attributes (outside irrefutable patterns)"
-  , MyOpt []        ["forceirrefutable"] (OptArg forceIrrefutableOpt "file") (mbStringOpt forceIrrefutables) "Force a set of explicitly defined attributes to be irrefutable, specify file containing the attribute set"
-  , MyOpt []        ["uniquedispenser"] (ReqArg uniqueDispenserOpt "name") (stringOpt uniqueDispenser) "The Haskell function to call in the generated code"
-  , MyOpt []        ["lckeywords"]    (NoArg lcKeywordsOpt)       (boolOpt lcKeywords)  "Use lowercase keywords (sem, attr) instead of the uppercase ones (SEM, ATTR)"
-  , MyOpt []        ["doublecolons"]  (NoArg doubleColonsOpt)     (boolOpt doubleColons)"Use double colons for type signatures instead of single colons"
-  , MyOpt ['H']     ["haskellsyntax"] (NoArg haskellSyntaxOpt)    noOpt                 "Use Haskell like syntax (equivalent to --lckeywords and --doublecolons --genlinepragmas)"
-  , MyOpt []        ["reference"]     (NoArg referenceOpt)        (boolOpt reference)   "Use reference attributes"
-  , MyOpt []        ["monadic"]       (NoArg monadicOpt)          (boolOpt monadic)     "Experimental: generate monadic code"
-  , MyOpt []        ["ocaml"]         (NoArg ocamlOpt)            (boolOpt ocaml)       "Generate Ocaml code"
-  , MyOpt []        ["cleanlang"]     (NoArg cleanOpt)            (boolOpt clean)       "Generate Clean code"
-  , MyOpt []        ["breadthfirst"]  (NoArg breadthfirstOpt)     (boolOpt breadthFirst)"Experimental: generate breadth-first code"
-  , MyOpt []        ["breadthfirst-strict"] (NoArg breadthfirstStrictOpt) (boolOpt breadthFirstStrict) "Experimental: outermost breadth-first evaluator is strict instead of lazy"
-  , MyOpt []        ["visitcode"]     (NoArg visitorsOutputOpt)   (boolOpt visitorsOutput) "Experimental: generate visitors code"
-  , MyOpt []        ["kennedywarren"] (NoArg kennedyWarrenOpt)    (boolOpt kennedyWarren) "Use Kennedy-Warren's algorithm for ordering"
-  , MyOpt []        ["statistics"]    (ReqArg statisticsOpt "FILE to append to") (mbStringOpt statsFile) "Append statistics to FILE"
-  , MyOpt []        ["checkParseRhs"]           (NoArg parseHsRhsOpt)              (boolOpt checkParseRhs)         "Parse RHS of rules with Haskell parser"
-  , MyOpt []        ["checkParseTys"]           (NoArg parseHsTpOpt)               (boolOpt checkParseTy)          "Parse types of attrs with Haskell parser"
-  , MyOpt []        ["checkParseBlocks"]        (NoArg parseHsBlockOpt)            (boolOpt checkParseBlock)       "Parse blocks with Haskell parser"
-  , MyOpt []        ["checkParseHaskell"]       (NoArg parseHsOpt)                 noOpt                           "Parse Haskell code (recognizer)"
-  , MyOpt []        ["nocatas"]                 (ReqArg nocatasOpt "list of nonterms") nocatasOptGet               "Nonterminals not to generate catas for"
-  , MyOpt []        ["nooptimize"]              (NoArg noOptimizeOpt)              (boolOpt noOptimizations)       "Disable optimizations"
-  , MyOpt []        ["parallel"]                (NoArg parallelOpt)                (boolOpt parallelInvoke)        "Generate a parallel evaluator (if possible)"
-  , MyOpt []        ["monadicwrapper"]          (NoArg monadicWrappersOpt)         (boolOpt monadicWrappers)       "Generate monadic wrappers"
-  , MyOpt []        ["helpinlining"]            (NoArg helpInliningOpt)            (boolOpt helpInlining)          "Generate inline directives for GHC"
-  , MyOpt []        ["dummytokenvisit"]         (NoArg dummyTokenVisitOpt)         (boolOpt dummyTokenVisit)       "Add an additional dummy parameter to visit functions"
-  , MyOpt []        ["tupleasdummytoken"]       (NoArg tupleAsDummyTokenOpt)       (boolOpt tupleAsDummyToken)     "Use conventional tuples as dummy parameter instead of a RealWorld state token"
-  , MyOpt []        ["stateasdummytoken"]       (NoArg stateAsDummyTokenOpt)       noOpt                           "Use RealWorld state token as dummy parameter instead of conventional tuples (default)"
-  , MyOpt []        ["strictdummytoken"]        (NoArg strictDummyTokenOpt)        (boolOpt strictDummyToken)      "Strictify the dummy token that makes states and rules functions"
-  , MyOpt []        ["noperruletypesigs"]       (NoArg noPerRuleTypeSigsOpt)       (boolOpt noPerRuleTypeSigs)     "Do not generate type sigs for attrs passed to rules"
-  , MyOpt []        ["noperstatetypesigs"]      (NoArg noPerStateTypeSigsOpt)      (boolOpt noPerStateTypeSigs)    "Do not generate type sigs for attrs saved in node states"
-  , MyOpt []        ["noeagerblackholing"]      (NoArg noEagerBlackholingOpt)      (boolOpt noEagerBlackholing)    "Do not automatically add the eager blackholing feature for parallel programs"
-  , MyOpt []        ["noperrulecostcentres"]    (NoArg noPerRuleCostCentresOpt)    (boolOpt noPerRuleCostCentres)  "Do not generate cost centres for rules"
-  , MyOpt []        ["nopervisitcostcentres"]   (NoArg noPerVisitCostCentresOpt)   (boolOpt noPerVisitCostCentres) "Do not generate cost centres for visits"
-  , MyOpt []        ["noinlinepragmas"]         (NoArg noInlinePragmasOpt)         (boolOpt noInlinePragmas)       "Definitely not generate inline directives"
-  , MyOpt []        ["aggressiveinlinepragmas"] (NoArg aggressiveInlinePragmasOpt) (boolOpt aggressiveInlinePragmas) "Generate more aggressive inline directives"
-  , MyOpt []        ["latehigherorderbinding"]  (NoArg lateHigherOrderBindingOpt)  (boolOpt lateHigherOrderBinding) "Generate an attribute and wrapper for late binding of higher-order attributes"
-  , MyOpt []        ["noincludes"]              (NoArg noIncludesOpt)              (boolOpt noIncludes)             "Ignore include directives in .ag files"
-  , MyOpt []        ["quiet"]                   (NoArg beQuietOpt)                 (boolOpt beQuiet)                "Dont print some compilation information"
-  ]
-
--- For compatibility
-options     :: [OptDescr (Options -> Options)]
-options     = map fromMyOpt allOptions
-
-allc :: String
-allc = "dcfsprm"
-
-data ModuleHeader  = NoName
-                   | Name String
-                   | Default deriving (Eq, Show)
-
-data Options = Options{ moduleName :: ModuleHeader
-                      , dataTypes :: Bool
-                      , dataRecords :: Bool
-                      , strictData :: Bool
-                      , strictWrap :: Bool
-                      , folds :: Bool
-                      , semfuns :: Bool
-                      , typeSigs :: Bool
-                      , attrInfo :: Bool
-                      , rename :: Bool
-                      , wrappers :: Bool
-                      , modcopy :: Bool
-                      , newtypes :: Bool
-                      , nest :: Bool
-                      , smacro :: Bool
-                      , outputFiles :: [String]
-                      , searchPath :: [String]
-                      , verbose :: Bool
-                      , prefix :: String
-                      , withSelf :: Bool
-                      , withCycle :: Bool
-                      , showHelp :: Bool
-                      , showVersion :: Bool
-                      , visit :: Bool
-                      , loag  :: Bool
-                      , minvisits  :: Bool
-                      , aoag  :: Bool
-                      , withSeq :: Bool
-                      , unbox :: Bool
-                      , bangpats :: Bool
-                      , cases :: Bool
-                      , strictCases :: Bool
-                      , stricterCases :: Bool
-                      , strictSems :: Bool
-                      , localCps :: Bool
-                      , splitSems :: Bool
-                      , werrors :: Bool
-                      , wignore :: Bool
-                      , wmaxerrs :: Int
-                      , dumpgrammar :: Bool
-                      , dumpcgrammar :: Bool
-                      , sepSemMods :: Bool
-                      , allowSepSemMods :: Bool
-                      , genFileDeps :: Bool
-                      , genLinePragmas :: Bool
-                      , genvisage :: Bool
-                      , genAspectAG :: Bool
-                      , noGroup :: [String]
-                      , extends :: Maybe String
-                      , genAttributeList :: Bool
-                      , forceIrrefutables :: Maybe String
-                      , uniqueDispenser :: String
-                      , lcKeywords :: Bool
-                      , doubleColons :: Bool
-                      , monadic :: Bool
-                      , ocaml :: Bool
-                      , clean :: Bool
-                      , visitorsOutput :: Bool
-                      , statsFile :: Maybe String
-                      , breadthFirst :: Bool
-                      , breadthFirstStrict :: Bool
-                      , checkParseRhs :: Bool
-                      , checkParseTy :: Bool
-                      , checkParseBlock :: Bool
-                      , nocatas :: Set NontermIdent
-                      , noOptimizations :: Bool
-                      , reference :: Bool
-                      , noIncludes :: Bool
-                      , outputStr :: String -> IO ()
-                      , failWithCode :: Int -> IO ()
-                      , mainFilename :: Maybe String
-                      , beQuiet :: Bool
-
-                      -- KW code path
-                      , kennedyWarren       :: Bool
-                      , parallelInvoke      :: Bool
-                      , tupleAsDummyToken   :: Bool  -- use the empty tuple as dummy token instead of State# RealWorld (Lambda State Hack GHC?)
-                      , dummyTokenVisit     :: Bool  -- add a dummy argument/pass dummy extra token to visits (should not really have an effect ... Lambda State Hack GHC?)
-                      , strictDummyToken    :: Bool  -- make the dummy token strict (to prevent its removal -- should not really have an effect)
-                      , noPerRuleTypeSigs   :: Bool  -- do not print type signatures for attributes of rules
-                      , noPerStateTypeSigs  :: Bool  -- do not print type signatures for attributes contained in the state
-                      , noEagerBlackholing  :: Bool  -- disable the use of eager black holing in the parallel evaluator code
-                      , lateHigherOrderBinding :: Bool  -- generate code to allow late binding of higher-order children semantics
-                      , monadicWrappers        :: Bool
-
-                      -- tracing
-                      , genTraces :: Bool
-                      , genUseTraces :: Bool
-                      , genCostCentres :: Bool
-                      , noPerRuleCostCentres :: Bool
-                      , noPerVisitCostCentres :: Bool
-
-                      -- inline pragma generation
-                      , helpInlining :: Bool
-                      , noInlinePragmas :: Bool
-                      , aggressiveInlinePragmas :: Bool
-                      } -- deriving (Eq, Show)
-
-noOptions :: Options
-noOptions = Options { moduleName    = NoName
-                    , dataTypes     = False
-                    , dataRecords   = False
-                    , strictData    = False
-                    , strictWrap    = False
-                    , folds         = False
-                    , semfuns       = False
-                    , typeSigs      = False
-                    , attrInfo      = False
-                    , rename        = False
-                    , wrappers      = False
-                    , modcopy       = False
-                    , newtypes      = False
-                    , nest          = False
-                    , smacro        = False
-                    , outputFiles   = []
-                    , searchPath    = []
-                    , verbose       = False
-                    , showHelp      = False
-                    , showVersion   = False
-                    , prefix        = "sem_"
-                    , withSelf      = False
-                    , withCycle     = False
-                    , visit         = False
-                    , loag          = False
-                    , minvisits     = False
-                    , aoag          = False
-                    , withSeq       = False
-                    , unbox         = False
-                    , bangpats      = False
-                    , cases         = False
-                    , strictCases   = False
-                    , stricterCases = False
-                    , strictSems    = False
-                    , localCps      = False
-                    , splitSems     = False
-                    , werrors       = False
-                    , wignore       = False
-                    , wmaxerrs      = 99999
-                    , dumpgrammar   = False
-                    , dumpcgrammar  = False
-                    , sepSemMods     = False
-                    , allowSepSemMods = True
-                    , genFileDeps    = False
-                    , genLinePragmas = False
-                    , genvisage      = False
-                    , genAspectAG    = False
-                    , noGroup        = []
-                    , extends        = Nothing
-                    , genAttributeList = False
-                    , forceIrrefutables = Nothing
-                    , uniqueDispenser = "nextUnique"
-                    , lcKeywords      = False
-                    , doubleColons    = False
-                    , monadic         = False
-                    , ocaml           = False
-                    , clean           = False
-                    , visitorsOutput  = False
-                    , statsFile       = Nothing
-                    , breadthFirst     = False
-                    , breadthFirstStrict = False
-                    , checkParseRhs = False
-                    , checkParseTy  = False
-                    , checkParseBlock = False
-                    , nocatas         = Set.empty
-                    , noOptimizations = False
-                    , reference       = False
-                    , noIncludes      = False
-                    , outputStr       = hPutStr stderr
-                    , failWithCode    = exitWith . ExitFailure
-                    , mainFilename    = Nothing
-                    , beQuiet         = False
-
-                    -- defaults for the KW-code path
-                    , kennedyWarren       = False
-                    , parallelInvoke      = False
-                    , tupleAsDummyToken   = True
-                    , dummyTokenVisit     = False
-                    , strictDummyToken    = False
-                    , noPerRuleTypeSigs   = False
-                    , noPerStateTypeSigs  = False
-                    , noEagerBlackholing  = False
-                    , lateHigherOrderBinding = False
-                    , monadicWrappers        = False
-
-                    -- defaults for tracing
-                    , genTraces     = False
-                    , genUseTraces  = False
-                    , genCostCentres = False
-                    , noPerRuleCostCentres  = False
-                    , noPerVisitCostCentres = False
-
-                    -- defaults for inline pragma generation
-                    , helpInlining    = False
-                    , noInlinePragmas = False
-                    , aggressiveInlinePragmas = False
-                    }
-
-loagOpt :: (Maybe String) -> Options -> Options
-loagOpt mstr opts = 
-    case mstr of
-        Nothing     -> opts'
-        Just "0"    -> opts'
-        Just _      -> opts' {minvisits = True}
-
- where  opts'=opts{loag = True, visit = True}
-
-aoagOpt :: Options -> Options
-aoagOpt opts = 
-    opts{loag = True, visit = True, aoag = True}
-
---Options -> String -> [String]
-moduleOpt :: Maybe String -> Options -> Options
-moduleOpt  nm   opts = opts{moduleName   = maybe Default Name nm}
-moduleOptGet :: Options -> String -> [String]
-moduleOptGet opts nm = case moduleName opts of
-  NoName -> []
-  Name s -> [nm++"="++s]
-  Default -> [nm]
-
-dataOpt, dataRecOpt, strictDataOpt, strictWrapOpt, cataOpt, semfunsOpt, signaturesOpt, prettyOpt,renameOpt, wrappersOpt, modcopyOpt, newtypesOpt, nestOpt, smacroOpt, verboseOpt, helpOpt, versionOpt, selfOpt, cycleOpt, visitOpt, seqOpt, unboxOpt, bangpatsOpt, casesOpt, strictCasesOpt, stricterCasesOpt, strictSemOpt, localCpsOpt, splitSemsOpt, werrorsOpt, wignoreOpt, dumpgrammarOpt, dumpcgrammarOpt, genTracesOpt, genUseTracesOpt, genCostCentresOpt, sepSemModsOpt, genFileDepsOpt, genLinePragmasOpt, genVisageOpt, genAspectAGOpt, dummyTokenVisitOpt, tupleAsDummyTokenOpt, stateAsDummyTokenOpt, strictDummyTokenOpt, noPerRuleTypeSigsOpt, noPerStateTypeSigsOpt, noEagerBlackholingOpt, noPerRuleCostCentresOpt, noPerVisitCostCentresOpt, helpInliningOpt, noInlinePragmasOpt, aggressiveInlinePragmasOpt, lateHigherOrderBindingOpt, monadicWrappersOpt, referenceOpt, genAttrListOpt, lcKeywordsOpt, doubleColonsOpt, haskellSyntaxOpt, monadicOpt, parallelOpt, ocamlOpt, cleanOpt, visitorsOutputOpt, breadthfirstOpt, breadthfirstStrictOpt, parseHsRhsOpt, parseHsTpOpt, parseHsBlockOpt, parseHsOpt, kennedyWarrenOpt, noOptimizeOpt, allOpt, optimizeOpt, noIncludesOpt, beQuietOpt, condDisableOptimizations :: Options -> Options
-
-dataOpt         opts = opts{dataTypes    = True}
-dataRecOpt      opts = opts{dataRecords  = True}
-strictDataOpt   opts = opts{strictData   = True}
-strictWrapOpt   opts = opts{strictWrap   = True}
-cataOpt         opts = opts{folds        = True}
-semfunsOpt      opts = opts{semfuns      = True}
-signaturesOpt   opts = opts{typeSigs     = True}
-prettyOpt       opts = opts{attrInfo     = True}
-renameOpt       opts = opts{rename       = True}
-wrappersOpt     opts = opts{wrappers     = True}
-modcopyOpt      opts = opts{modcopy      = True}
-newtypesOpt     opts = opts{newtypes     = True}
-nestOpt         opts = opts{nest         = True}
-smacroOpt       opts = opts{smacro       = True}
-verboseOpt      opts = opts{verbose      = True}
-helpOpt         opts = opts{showHelp     = True}
-versionOpt      opts = opts{showVersion  = True}
-prefixOpt :: String -> Options -> Options
-prefixOpt pre   opts = opts{prefix       = pre }
-selfOpt         opts = opts{withSelf     = True}
-cycleOpt        opts = opts{withCycle    = True}
-visitOpt        opts = opts{visit        = True, withCycle = True}
-seqOpt          opts = opts{withSeq      = True}
-unboxOpt        opts = opts{unbox        = True}
-bangpatsOpt     opts = opts{bangpats     = True}
-casesOpt        opts = opts{cases        = True}
-strictCasesOpt  opts = opts{strictCases  = True}
-stricterCasesOpt opts = opts{strictCases = True, stricterCases = True}
-strictSemOpt    opts = opts{strictSems   = True}
-localCpsOpt     opts = opts{localCps     = True}
-splitSemsOpt    opts = opts{splitSems    = True}
-werrorsOpt      opts = opts{werrors      = True}
-wignoreOpt      opts = opts{wignore      = True}
-wmaxErrsOpt :: String -> Options -> Options
-wmaxErrsOpt n   opts = opts{wmaxerrs     = read n}
-wmaxErrsOptGet :: Options -> String -> [String]
-wmaxErrsOptGet opts nm = if wmaxerrs opts /= wmaxerrs noOptions
-                         then [nm,show (wmaxerrs opts)]
-                         else []
-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 = allowSepSemMods opts}
-genFileDepsOpt opts = opts{genFileDeps = True}
-genLinePragmasOpt opts = opts{genLinePragmas = True}
-genVisageOpt opts = opts{genvisage = True }
-genAspectAGOpt opts = opts{genAspectAG = True}
-
-dummyTokenVisitOpt opts         = opts { dummyTokenVisit = True }
-tupleAsDummyTokenOpt opts       = opts { tupleAsDummyToken = True }
-stateAsDummyTokenOpt opts       = opts { tupleAsDummyToken = False }
-strictDummyTokenOpt opts        = opts { strictDummyToken = True }
-noPerRuleTypeSigsOpt opts       = opts { noPerRuleTypeSigs = True }
-noPerStateTypeSigsOpt opts      = opts { noPerStateTypeSigs = True }
-noEagerBlackholingOpt opts      = opts { noEagerBlackholing = True }
-noPerRuleCostCentresOpt opts    = opts { noPerRuleCostCentres = True }
-noPerVisitCostCentresOpt opts   = opts { noPerVisitCostCentres = True }
-helpInliningOpt opts            = opts { helpInlining = True }
-noInlinePragmasOpt opts         = opts { noInlinePragmas = True }
-aggressiveInlinePragmasOpt opts = opts { aggressiveInlinePragmas = True }
-lateHigherOrderBindingOpt opts  = opts { lateHigherOrderBinding = True }
-monadicWrappersOpt opts         = opts { monadicWrappers = True }
-referenceOpt opts               = opts { reference = True }
-
-noGroupOpt :: String -> Options -> Options
-noGroupOpt  att  opts = opts{noGroup  = wordsBy (== ':') att  ++ noGroup opts}
-noGroupOptGet :: Options -> String -> [String]
-noGroupOptGet opts nm = if null (noGroup opts)
-                        then []
-                        else [nm, intercalate ":" (noGroup opts)]
-extendsOpt :: String -> Options -> Options
-extendsOpt  m  opts = opts{extends  = Just m }
-
-genAttrListOpt opts = opts { genAttributeList = True }
-forceIrrefutableOpt :: Maybe String -> Options -> Options
-forceIrrefutableOpt mbNm opts = opts { forceIrrefutables = mbNm }
-uniqueDispenserOpt :: String -> Options -> Options
-uniqueDispenserOpt nm opts = opts { uniqueDispenser = nm }
-lcKeywordsOpt opts = opts { lcKeywords = True }
-doubleColonsOpt opts = opts { doubleColons = True }
-haskellSyntaxOpt = lcKeywordsOpt . doubleColonsOpt . genLinePragmasOpt
-monadicOpt opts = opts { monadic = True }
-parallelOpt opts = opts { parallelInvoke = True }
-ocamlOpt opts = opts { ocaml = True, kennedyWarren = True, withCycle = True, visit = True }
-cleanOpt opts = opts { clean = True } --TODO: More?
-visitorsOutputOpt opts = opts { visitorsOutput = True }
-statisticsOpt :: String -> Options -> Options
-statisticsOpt nm opts = opts { statsFile = Just nm }
-breadthfirstOpt opts = opts { breadthFirst = True }
-breadthfirstStrictOpt opts = opts { breadthFirstStrict = True }
-parseHsRhsOpt opts = opts { checkParseRhs = True }
-parseHsTpOpt opts = opts { checkParseTy = True }
-parseHsBlockOpt opts = opts { checkParseBlock = True }
-parseHsOpt = parseHsRhsOpt . parseHsTpOpt . parseHsBlockOpt
-kennedyWarrenOpt opts = opts { kennedyWarren = True }
-noOptimizeOpt opts = opts { noOptimizations = True }
-nocatasOpt :: String -> Options -> Options
-nocatasOpt str opts = opts { nocatas = set `Set.union` nocatas opts } where
-  set = Set.fromList ids
-  ids = map identifier lst
-  lst = wordsBy (== ',') str
-nocatasOptGet :: Options -> String -> [String]
-nocatasOptGet opts nm = if Set.null (nocatas opts)
-                        then []
-                        else [nm,intercalate "," . map getName . Set.toList . nocatas $ opts]
-outputOpt :: String -> Options -> Options
-outputOpt  file  opts = opts{outputFiles  = file : outputFiles opts}
-outputOptGet :: Options -> String -> [String]
-outputOptGet opts nm  = concat [ [nm, file] | file <- outputFiles opts]
-searchPathOpt :: String -> Options -> Options
-searchPathOpt  path  opts = opts{searchPath  = wordsBy (\x -> x == ';' || x == ':') path ++ searchPath opts}
-searchPathOptGet :: Options -> String -> [String]
-searchPathOptGet opts nm = if null (searchPath opts)
-                           then []
-                           else [nm, intercalate ":" (searchPath opts)]
-allOpt = moduleOpt Nothing . dataOpt . cataOpt . semfunsOpt . signaturesOpt . prettyOpt . renameOpt . dataRecOpt
-optimizeOpt   = visitOpt . casesOpt
-noIncludesOpt opts = opts { noIncludes = True }
-beQuietOpt opts = opts { beQuiet = True }
-
-condDisableOptimizations opts
-  | noOptimizations opts =
-      opts { strictData         = False
-           , strictWrap         = False
-           , withSeq            = False
-           , unbox              = False
-           , bangpats           = False
-           , cases              = False
-           , strictCases        = False
-           , stricterCases      = False
-           , strictSems         = False
-           , localCps           = False
-           , splitSems          = False
-           , breadthFirstStrict = False
-           }
-  | otherwise = opts
-                
--- | Inverse of intercalate
-wordsBy :: (Char -> Bool) -> String -> [String]
-wordsBy p = f
-  where
-    f s = let (x,xs) = break p s
-          in  if null x then [] else x : f (drop 1 xs)
-                
--- | Use all parsed options to generate real options
-constructOptions :: [Options -> Options] -> Options
-constructOptions = foldl (flip ($)) noOptions
-
--- | Create Options type from string arguments
-getOptions :: [String] -> (Options,[String],[String])
-getOptions args = let (flags,files,errors) = getOpt Permute options args
-                      appliedOpts = constructOptions flags
-                      finOpts = condDisableOptimizations appliedOpts
-                  in (finOpts,files,errors)
-
--- | Convert options back to commandline string
-optionsToString :: Options -> [String]
-optionsToString opt = concatMap (serializeOption opt) allOptions
-
--- | Combine 2 sets of options
-combineOptions :: Options -> Options -> Options
-combineOptions o1 o2 = let str1      = optionsToString o1
-                           str2      = optionsToString o2
-                           (opt,_,_) = getOptions (str1 ++ str2)
-                       in  opt
+module Options where++import System.Console.GetOpt+import Data.Set(Set)+import UU.Scanner.Position(Pos,noPos)+import Data.List(intercalate)+import qualified Data.Set as Set+import System.IO+import System.Exit++-- From CommonTypes+data Identifier   = Ident { getName::String, getPos::Pos }+type NontermIdent = Identifier+identifier :: String -> Identifier+identifier x      = Ident x noPos++instance Eq Identifier where+ Ident x _ == Ident y _ = x == y++instance Ord Identifier where+ compare (Ident x _) (Ident y _) = compare x y++instance Show Identifier where+  show ident = getName ident+  +-- Make options serializable+data MyOptDescr = MyOpt [Char] [String] (ArgDescr (Options -> Options)) (Options -> String -> [String]) String++fromMyOpt :: MyOptDescr -> OptDescr (Options -> Options)+fromMyOpt (MyOpt sh ln desc _ s) = Option sh ln desc s++noOpt :: Options -> String -> [String]+noOpt _ _ = []++boolOpt :: (Options -> Bool) -> Options -> String -> [String]+boolOpt get opt strArg = let oldVal = get noOptions+                             newVal = get opt+                         in  if   oldVal /= newVal+                             then [strArg]+                             else []++stringOpt :: (Options -> String) -> Options -> String -> [String]+stringOpt get opt strArg = let oldVal = get noOptions+                               newVal = get opt+                           in  if   oldVal /= newVal+                               then [strArg, newVal]+                               else []++mbStringOpt :: (Options -> Maybe String) -> Options -> String -> [String]+mbStringOpt get opts nm = maybe [] (\s -> [nm++"="++s]) (get opts)++serializeOption :: Options -> MyOptDescr -> [String]+serializeOption opt (MyOpt sh ln _ get _) = get opt strArg+  where+    strArg = if null sh+             then '-' : '-' : head ln+             else '-' : head sh : []++-- All options+allOptions :: [MyOptDescr]+allOptions =  +  [ MyOpt ['m']     []                (NoArg (moduleOpt Nothing)) noOpt                 "generate default module header"+  , MyOpt []        ["module"]        (OptArg moduleOpt "name")   moduleOptGet          "generate module header, specify module name"+  , MyOpt ['d']     ["data"]          (NoArg dataOpt)             (boolOpt dataTypes)   "generate data type definition"+  , MyOpt []        ["datarecords"]   (NoArg dataRecOpt)          (boolOpt dataRecords) "generate record data types"+  , MyOpt []        ["strictdata"]    (NoArg strictDataOpt)       (boolOpt strictData)  "generate strict data fields (when data is generated)"+  , MyOpt []        ["strictwrap"]    (NoArg strictWrapOpt)       (boolOpt strictWrap)  "generate strict wrap fields for WRAPPER generated data"+  , MyOpt ['c']     ["catas"]         (NoArg cataOpt)             (boolOpt folds)       "generate catamorphisms"+  , MyOpt ['f']     ["semfuns"]       (NoArg semfunsOpt)          (boolOpt semfuns)     "generate semantic functions"+  , MyOpt ['s']     ["signatures"]    (NoArg signaturesOpt)       (boolOpt typeSigs)    "generate signatures for semantic functions"+  , MyOpt []        ["newtypes"]      (NoArg newtypesOpt)         (boolOpt newtypes)    "use newtypes instead of type synonyms"+  , MyOpt ['p']     ["pretty"]        (NoArg prettyOpt)           (boolOpt attrInfo)    "generate pretty printed list of attributes"+  , MyOpt ['w']     ["wrappers"]      (NoArg wrappersOpt)         (boolOpt wrappers)    "generate wappers for semantic domains"+  , MyOpt ['r']     ["rename"]        (NoArg renameOpt)           (boolOpt rename)      "rename data constructors"+  , MyOpt []        ["modcopy"]       (NoArg modcopyOpt)          (boolOpt modcopy)     "use modified copy rule"+  , MyOpt []        ["nest"]          (NoArg nestOpt)             (boolOpt nest)        "use nested tuples"+  , MyOpt []        ["syntaxmacro"]   (NoArg smacroOpt)           (boolOpt smacro)      "experimental: generate syntax macro code (using knit catas)"+  , MyOpt ['o']     ["output"]        (ReqArg outputOpt "file")   outputOptGet          "specify output file"+  , MyOpt ['v']     ["verbose"]       (NoArg verboseOpt)          (boolOpt verbose)     "verbose error message format"+  , MyOpt ['h','?'] ["help"]          (NoArg helpOpt)             (boolOpt showHelp)    "get (this) usage information"+  , MyOpt ['a']     ["all"]           (NoArg allOpt)              noOpt                ("do everything (-" ++ allc ++ ")")+  , MyOpt ['P']     [""]              (ReqArg searchPathOpt "search path") searchPathOptGet ("specify seach path")+  , MyOpt []        ["prefix"]        (ReqArg prefixOpt "prefix") (stringOpt prefix)    "set prefix for semantic functions"+  , MyOpt []        ["self"]          (NoArg selfOpt)             (boolOpt withSelf)    "generate self attribute"+  , MyOpt []        ["cycle"]         (NoArg cycleOpt)            (boolOpt withCycle)   "check for cyclic definitions"+  , MyOpt []        ["version"]       (NoArg versionOpt)          (boolOpt showVersion) "get version information"+  , MyOpt ['O']     ["optimize"]      (NoArg optimizeOpt)         noOpt                 "optimize generated code (--visit --case)"+  , MyOpt []        ["visit"]         (NoArg visitOpt)            (boolOpt visit)       "try generating visit functions"+  , MyOpt []        ["loag"]          (OptArg loagOpt "Bool")     (boolOpt loag)        "recognises all linear ordered attribute grammars by generting a SAT problem, uses --verbose to print out numbers of clauses and variables"+  , MyOpt []        ["aoag"]          (NoArg aoagOpt)             (boolOpt aoag)        "recognises all linear ordered attribute grammars by finding fake dependencies, uses --verbose to print out the selected fake dependencies"+  , MyOpt []        ["seq"]           (NoArg seqOpt)              (boolOpt withSeq)     "force evaluation using function seq (visit functions only)"+  , MyOpt []        ["unbox"]         (NoArg unboxOpt)            (boolOpt unbox)       "use unboxed tuples"+  , MyOpt []        ["bangpats"]      (NoArg bangpatsOpt)         (boolOpt bangpats)    "use bang patterns (visit functions only)"+  , MyOpt []        ["case"]          (NoArg casesOpt)            (boolOpt cases)       "Use nested cases instead of let (visit functions only)"+  , MyOpt []        ["strictcase"]    (NoArg strictCasesOpt)      (boolOpt strictCases) "Force evaluation of the scrutinee of cases (in generated code, visit functions only)"+  , MyOpt []        ["strictercase"]  (NoArg stricterCasesOpt)    (boolOpt stricterCases) "Force evaluation of all variables bound by a case statement (in generated code)"+  , MyOpt []        ["strictsem"]     (NoArg strictSemOpt)        (boolOpt strictSems)  "Force evaluation of sem-function arguments (in generated code)"+  , MyOpt []        ["localcps"]      (NoArg localCpsOpt)         (boolOpt localCps)    "Apply a local CPS transformation (in generated code, visit functions only)"+  , MyOpt []        ["splitsems"]     (NoArg splitSemsOpt)        (boolOpt splitSems)   "Split semantic functions into smaller pieces"+  , MyOpt []        ["Werrors"]       (NoArg werrorsOpt)          (boolOpt werrors)     "Turn warnings into fatal errors"+  , MyOpt []        ["Wignore"]       (NoArg wignoreOpt)          (boolOpt wignore)     "Ignore warnings"+  , MyOpt []        ["Wmax"]          (ReqArg wmaxErrsOpt "<max errs reported>") wmaxErrsOptGet "Sets the maximum number of errors that are reported"+  , MyOpt []        ["dumpgrammar"]   (NoArg dumpgrammarOpt)      (boolOpt dumpgrammar) "Dump internal grammar representation (in generated code)"+  , MyOpt []        ["dumpcgrammar"]  (NoArg dumpcgrammarOpt)     (boolOpt dumpcgrammar)"Dump internal cgrammar representation (in generated code)"+  , MyOpt []        ["gentraces"]     (NoArg genTracesOpt)        (boolOpt genTraces)   "Generate trace expressions (in generated code)"+  , MyOpt []        ["genusetraces"]  (NoArg genUseTracesOpt)     (boolOpt genUseTraces)"Generate trace expressions at attribute use sites (in generated code)"+  , MyOpt []        ["gencostcentres"] (NoArg genCostCentresOpt)  (boolOpt genCostCentres) "Generate cost centre pragmas (in generated code)"+  , MyOpt []        ["genlinepragmas"] (NoArg genLinePragmasOpt)  (boolOpt genLinePragmas) "Generate GHC LINE pragmas (in generated code)"+  , MyOpt []        ["sepsemmods"]    (NoArg sepSemModsOpt)       (boolOpt sepSemMods)  "Generate separate modules for semantic functions (in generated code)"+  , MyOpt ['M']     ["genfiledeps"]   (NoArg genFileDepsOpt)      (boolOpt genFileDeps) "Generate a list of dependencies on the input AG files"+  , MyOpt []        ["genvisage"]     (NoArg genVisageOpt)        (boolOpt genvisage)   "Generate output for the AG visualizer Visage"+  , MyOpt []        ["genmirage"]     (NoArg genMirageOpt)        (boolOpt genmirage)   "Generate output for the AG visualizer Mirage"+  , MyOpt []        ["aspectag"]      (NoArg genAspectAGOpt)      (boolOpt genAspectAG) "Generate AspectAG file"+  , MyOpt []        ["nogroup"]       (ReqArg noGroupOpt "attributes") noGroupOptGet    "specify the attributes that won't be grouped in AspectAG"+  , MyOpt []        ["extends"]       (ReqArg extendsOpt "module") (mbStringOpt extends)        "specify a module to be extended"+  , MyOpt []        ["genattrlist"]   (NoArg genAttrListOpt)      (boolOpt genAttributeList) "Generate a list of all explicitly defined attributes (outside irrefutable patterns)"+  , MyOpt []        ["forceirrefutable"] (OptArg forceIrrefutableOpt "file") (mbStringOpt forceIrrefutables) "Force a set of explicitly defined attributes to be irrefutable, specify file containing the attribute set"+  , MyOpt []        ["uniquedispenser"] (ReqArg uniqueDispenserOpt "name") (stringOpt uniqueDispenser) "The Haskell function to call in the generated code"+  , MyOpt []        ["lckeywords"]    (NoArg lcKeywordsOpt)       (boolOpt lcKeywords)  "Use lowercase keywords (sem, attr) instead of the uppercase ones (SEM, ATTR)"+  , MyOpt []        ["doublecolons"]  (NoArg doubleColonsOpt)     (boolOpt doubleColons)"Use double colons for type signatures instead of single colons"+  , MyOpt ['H']     ["haskellsyntax"] (NoArg haskellSyntaxOpt)    noOpt                 "Use Haskell like syntax (equivalent to --lckeywords and --doublecolons --genlinepragmas)"+  , MyOpt []        ["reference"]     (NoArg referenceOpt)        (boolOpt reference)   "Use reference attributes"+  , MyOpt []        ["monadic"]       (NoArg monadicOpt)          (boolOpt monadic)     "Experimental: generate monadic code"+  , MyOpt []        ["ocaml"]         (NoArg ocamlOpt)            (boolOpt ocaml)       "Generate Ocaml code"+  , MyOpt []        ["cleanlang"]     (NoArg cleanOpt)            (boolOpt clean)       "Generate Clean code"+  , MyOpt []        ["breadthfirst"]  (NoArg breadthfirstOpt)     (boolOpt breadthFirst)"Experimental: generate breadth-first code"+  , MyOpt []        ["breadthfirst-strict"] (NoArg breadthfirstStrictOpt) (boolOpt breadthFirstStrict) "Experimental: outermost breadth-first evaluator is strict instead of lazy"+  , MyOpt []        ["visitcode"]     (NoArg visitorsOutputOpt)   (boolOpt visitorsOutput) "Experimental: generate visitors code"+  , MyOpt []        ["kennedywarren"] (NoArg kennedyWarrenOpt)    (boolOpt kennedyWarren) "Use Kennedy-Warren's algorithm for ordering"+  , MyOpt []        ["statistics"]    (ReqArg statisticsOpt "FILE to append to") (mbStringOpt statsFile) "Append statistics to FILE"+  , MyOpt []        ["checkParseRhs"]           (NoArg parseHsRhsOpt)              (boolOpt checkParseRhs)         "Parse RHS of rules with Haskell parser"+  , MyOpt []        ["checkParseTys"]           (NoArg parseHsTpOpt)               (boolOpt checkParseTy)          "Parse types of attrs with Haskell parser"+  , MyOpt []        ["checkParseBlocks"]        (NoArg parseHsBlockOpt)            (boolOpt checkParseBlock)       "Parse blocks with Haskell parser"+  , MyOpt []        ["checkParseHaskell"]       (NoArg parseHsOpt)                 noOpt                           "Parse Haskell code (recognizer)"+  , MyOpt []        ["nocatas"]                 (ReqArg nocatasOpt "list of nonterms") nocatasOptGet               "Nonterminals not to generate catas for"+  , MyOpt []        ["nooptimize"]              (NoArg noOptimizeOpt)              (boolOpt noOptimizations)       "Disable optimizations"+  , MyOpt []        ["parallel"]                (NoArg parallelOpt)                (boolOpt parallelInvoke)        "Generate a parallel evaluator (if possible)"+  , MyOpt []        ["monadicwrapper"]          (NoArg monadicWrappersOpt)         (boolOpt monadicWrappers)       "Generate monadic wrappers"+  , MyOpt []        ["helpinlining"]            (NoArg helpInliningOpt)            (boolOpt helpInlining)          "Generate inline directives for GHC"+  , MyOpt []        ["dummytokenvisit"]         (NoArg dummyTokenVisitOpt)         (boolOpt dummyTokenVisit)       "Add an additional dummy parameter to visit functions"+  , MyOpt []        ["tupleasdummytoken"]       (NoArg tupleAsDummyTokenOpt)       (boolOpt tupleAsDummyToken)     "Use conventional tuples as dummy parameter instead of a RealWorld state token"+  , MyOpt []        ["stateasdummytoken"]       (NoArg stateAsDummyTokenOpt)       noOpt                           "Use RealWorld state token as dummy parameter instead of conventional tuples (default)"+  , MyOpt []        ["strictdummytoken"]        (NoArg strictDummyTokenOpt)        (boolOpt strictDummyToken)      "Strictify the dummy token that makes states and rules functions"+  , MyOpt []        ["noperruletypesigs"]       (NoArg noPerRuleTypeSigsOpt)       (boolOpt noPerRuleTypeSigs)     "Do not generate type sigs for attrs passed to rules"+  , MyOpt []        ["noperstatetypesigs"]      (NoArg noPerStateTypeSigsOpt)      (boolOpt noPerStateTypeSigs)    "Do not generate type sigs for attrs saved in node states"+  , MyOpt []        ["noeagerblackholing"]      (NoArg noEagerBlackholingOpt)      (boolOpt noEagerBlackholing)    "Do not automatically add the eager blackholing feature for parallel programs"+  , MyOpt []        ["noperrulecostcentres"]    (NoArg noPerRuleCostCentresOpt)    (boolOpt noPerRuleCostCentres)  "Do not generate cost centres for rules"+  , MyOpt []        ["nopervisitcostcentres"]   (NoArg noPerVisitCostCentresOpt)   (boolOpt noPerVisitCostCentres) "Do not generate cost centres for visits"+  , MyOpt []        ["noinlinepragmas"]         (NoArg noInlinePragmasOpt)         (boolOpt noInlinePragmas)       "Definitely not generate inline directives"+  , MyOpt []        ["aggressiveinlinepragmas"] (NoArg aggressiveInlinePragmasOpt) (boolOpt aggressiveInlinePragmas) "Generate more aggressive inline directives"+  , MyOpt []        ["latehigherorderbinding"]  (NoArg lateHigherOrderBindingOpt)  (boolOpt lateHigherOrderBinding) "Generate an attribute and wrapper for late binding of higher-order attributes"+  , MyOpt []        ["noincludes"]              (NoArg noIncludesOpt)              (boolOpt noIncludes)             "Ignore include directives in .ag files"+  , MyOpt []        ["quiet"]                   (NoArg beQuietOpt)                 (boolOpt beQuiet)                "Dont print some compilation information"+  ]++-- For compatibility+options     :: [OptDescr (Options -> Options)]+options     = map fromMyOpt allOptions++allc :: String+allc = "dcfsprm"++data ModuleHeader  = NoName+                   | Name String+                   | Default deriving (Eq, Show)++data Options = Options{ moduleName :: ModuleHeader+                      , dataTypes :: Bool+                      , dataRecords :: Bool+                      , strictData :: Bool+                      , strictWrap :: Bool+                      , folds :: Bool+                      , semfuns :: Bool+                      , typeSigs :: Bool+                      , attrInfo :: Bool+                      , rename :: Bool+                      , wrappers :: Bool+                      , modcopy :: Bool+                      , newtypes :: Bool+                      , nest :: Bool+                      , smacro :: Bool+                      , outputFiles :: [String]+                      , searchPath :: [String]+                      , verbose :: Bool+                      , prefix :: String+                      , withSelf :: Bool+                      , withCycle :: Bool+                      , showHelp :: Bool+                      , showVersion :: Bool+                      , visit :: Bool+                      , loag  :: Bool+                      , minvisits  :: Bool+                      , aoag  :: Bool+                      , withSeq :: Bool+                      , unbox :: Bool+                      , bangpats :: Bool+                      , cases :: Bool+                      , strictCases :: Bool+                      , stricterCases :: Bool+                      , strictSems :: Bool+                      , localCps :: Bool+                      , splitSems :: Bool+                      , werrors :: Bool+                      , wignore :: Bool+                      , wmaxerrs :: Int+                      , dumpgrammar :: Bool+                      , dumpcgrammar :: Bool+                      , sepSemMods :: Bool+                      , allowSepSemMods :: Bool+                      , genFileDeps :: Bool+                      , genLinePragmas :: Bool+                      , genvisage :: Bool+                      , genmirage :: Bool+                      , genAspectAG :: Bool+                      , noGroup :: [String]+                      , extends :: Maybe String+                      , genAttributeList :: Bool+                      , forceIrrefutables :: Maybe String+                      , uniqueDispenser :: String+                      , lcKeywords :: Bool+                      , doubleColons :: Bool+                      , monadic :: Bool+                      , ocaml :: Bool+                      , clean :: Bool+                      , visitorsOutput :: Bool+                      , statsFile :: Maybe String+                      , breadthFirst :: Bool+                      , breadthFirstStrict :: Bool+                      , checkParseRhs :: Bool+                      , checkParseTy :: Bool+                      , checkParseBlock :: Bool+                      , nocatas :: Set NontermIdent+                      , noOptimizations :: Bool+                      , reference :: Bool+                      , noIncludes :: Bool+                      , outputStr :: String -> IO ()+                      , failWithCode :: Int -> IO ()+                      , mainFilename :: Maybe String+                      , beQuiet :: Bool++                      -- KW code path+                      , kennedyWarren       :: Bool+                      , parallelInvoke      :: Bool+                      , tupleAsDummyToken   :: Bool  -- use the empty tuple as dummy token instead of State# RealWorld (Lambda State Hack GHC?)+                      , dummyTokenVisit     :: Bool  -- add a dummy argument/pass dummy extra token to visits (should not really have an effect ... Lambda State Hack GHC?)+                      , strictDummyToken    :: Bool  -- make the dummy token strict (to prevent its removal -- should not really have an effect)+                      , noPerRuleTypeSigs   :: Bool  -- do not print type signatures for attributes of rules+                      , noPerStateTypeSigs  :: Bool  -- do not print type signatures for attributes contained in the state+                      , noEagerBlackholing  :: Bool  -- disable the use of eager black holing in the parallel evaluator code+                      , lateHigherOrderBinding :: Bool  -- generate code to allow late binding of higher-order children semantics+                      , monadicWrappers        :: Bool++                      -- tracing+                      , genTraces :: Bool+                      , genUseTraces :: Bool+                      , genCostCentres :: Bool+                      , noPerRuleCostCentres :: Bool+                      , noPerVisitCostCentres :: Bool++                      -- inline pragma generation+                      , helpInlining :: Bool+                      , noInlinePragmas :: Bool+                      , aggressiveInlinePragmas :: Bool+                      } -- deriving (Eq, Show)++noOptions :: Options+noOptions = Options { moduleName    = NoName+                    , dataTypes     = False+                    , dataRecords   = False+                    , strictData    = False+                    , strictWrap    = False+                    , folds         = False+                    , semfuns       = False+                    , typeSigs      = False+                    , attrInfo      = False+                    , rename        = False+                    , wrappers      = False+                    , modcopy       = False+                    , newtypes      = False+                    , nest          = False+                    , smacro        = False+                    , outputFiles   = []+                    , searchPath    = []+                    , verbose       = False+                    , showHelp      = False+                    , showVersion   = False+                    , prefix        = "sem_"+                    , withSelf      = False+                    , withCycle     = False+                    , visit         = False+                    , loag          = False+                    , minvisits     = False+                    , aoag          = False+                    , withSeq       = False+                    , unbox         = False+                    , bangpats      = False+                    , cases         = False+                    , strictCases   = False+                    , stricterCases = False+                    , strictSems    = False+                    , localCps      = False+                    , splitSems     = False+                    , werrors       = False+                    , wignore       = False+                    , wmaxerrs      = 99999+                    , dumpgrammar   = False+                    , dumpcgrammar  = False+                    , sepSemMods     = False+                    , allowSepSemMods = True+                    , genFileDeps    = False+                    , genLinePragmas = False+                    , genvisage      = False+                    , genmirage      = False+                    , genAspectAG    = False+                    , noGroup        = []+                    , extends        = Nothing+                    , genAttributeList = False+                    , forceIrrefutables = Nothing+                    , uniqueDispenser = "nextUnique"+                    , lcKeywords      = False+                    , doubleColons    = False+                    , monadic         = False+                    , ocaml           = False+                    , clean           = False+                    , visitorsOutput  = False+                    , statsFile       = Nothing+                    , breadthFirst     = False+                    , breadthFirstStrict = False+                    , checkParseRhs = False+                    , checkParseTy  = False+                    , checkParseBlock = False+                    , nocatas         = Set.empty+                    , noOptimizations = False+                    , reference       = False+                    , noIncludes      = False+                    , outputStr       = hPutStr stderr+                    , failWithCode    = exitWith . ExitFailure+                    , mainFilename    = Nothing+                    , beQuiet         = False++                    -- defaults for the KW-code path+                    , kennedyWarren       = False+                    , parallelInvoke      = False+                    , tupleAsDummyToken   = True+                    , dummyTokenVisit     = False+                    , strictDummyToken    = False+                    , noPerRuleTypeSigs   = False+                    , noPerStateTypeSigs  = False+                    , noEagerBlackholing  = False+                    , lateHigherOrderBinding = False+                    , monadicWrappers        = False++                    -- defaults for tracing+                    , genTraces     = False+                    , genUseTraces  = False+                    , genCostCentres = False+                    , noPerRuleCostCentres  = False+                    , noPerVisitCostCentres = False++                    -- defaults for inline pragma generation+                    , helpInlining    = False+                    , noInlinePragmas = False+                    , aggressiveInlinePragmas = False+                    }++loagOpt :: (Maybe String) -> Options -> Options+loagOpt mstr opts = +    case mstr of+        Nothing     -> opts'+        Just "0"    -> opts'+        Just _      -> opts' {minvisits = True}++ where  opts'=opts{loag = True, visit = True}++aoagOpt :: Options -> Options+aoagOpt opts = +    opts{loag = True, visit = True, aoag = True}++--Options -> String -> [String]+moduleOpt :: Maybe String -> Options -> Options+moduleOpt  nm   opts = opts{moduleName   = maybe Default Name nm}+moduleOptGet :: Options -> String -> [String]+moduleOptGet opts nm = case moduleName opts of+  NoName -> []+  Name s -> [nm++"="++s]+  Default -> [nm]++dataOpt, dataRecOpt, strictDataOpt, strictWrapOpt, cataOpt, semfunsOpt, signaturesOpt, prettyOpt,renameOpt, wrappersOpt, modcopyOpt, newtypesOpt, nestOpt, smacroOpt, verboseOpt, helpOpt, versionOpt, selfOpt, cycleOpt, visitOpt, seqOpt, unboxOpt, bangpatsOpt, casesOpt, strictCasesOpt, stricterCasesOpt, strictSemOpt, localCpsOpt, splitSemsOpt, werrorsOpt, wignoreOpt, dumpgrammarOpt, dumpcgrammarOpt, genTracesOpt, genUseTracesOpt, genCostCentresOpt, sepSemModsOpt, genFileDepsOpt, genLinePragmasOpt, genVisageOpt, genMirageOpt, genAspectAGOpt, dummyTokenVisitOpt, tupleAsDummyTokenOpt, stateAsDummyTokenOpt, strictDummyTokenOpt, noPerRuleTypeSigsOpt, noPerStateTypeSigsOpt, noEagerBlackholingOpt, noPerRuleCostCentresOpt, noPerVisitCostCentresOpt, helpInliningOpt, noInlinePragmasOpt, aggressiveInlinePragmasOpt, lateHigherOrderBindingOpt, monadicWrappersOpt, referenceOpt, genAttrListOpt, lcKeywordsOpt, doubleColonsOpt, haskellSyntaxOpt, monadicOpt, parallelOpt, ocamlOpt, cleanOpt, visitorsOutputOpt, breadthfirstOpt, breadthfirstStrictOpt, parseHsRhsOpt, parseHsTpOpt, parseHsBlockOpt, parseHsOpt, kennedyWarrenOpt, noOptimizeOpt, allOpt, optimizeOpt, noIncludesOpt, beQuietOpt, condDisableOptimizations :: Options -> Options++dataOpt         opts = opts{dataTypes    = True}+dataRecOpt      opts = opts{dataRecords  = True}+strictDataOpt   opts = opts{strictData   = True}+strictWrapOpt   opts = opts{strictWrap   = True}+cataOpt         opts = opts{folds        = True}+semfunsOpt      opts = opts{semfuns      = True}+signaturesOpt   opts = opts{typeSigs     = True}+prettyOpt       opts = opts{attrInfo     = True}+renameOpt       opts = opts{rename       = True}+wrappersOpt     opts = opts{wrappers     = True}+modcopyOpt      opts = opts{modcopy      = True}+newtypesOpt     opts = opts{newtypes     = True}+nestOpt         opts = opts{nest         = True}+smacroOpt       opts = opts{smacro       = True}+verboseOpt      opts = opts{verbose      = True}+helpOpt         opts = opts{showHelp     = True}+versionOpt      opts = opts{showVersion  = True}+prefixOpt :: String -> Options -> Options+prefixOpt pre   opts = opts{prefix       = pre }+selfOpt         opts = opts{withSelf     = True}+cycleOpt        opts = opts{withCycle    = True}+visitOpt        opts = opts{visit        = True, withCycle = True}+seqOpt          opts = opts{withSeq      = True}+unboxOpt        opts = opts{unbox        = True}+bangpatsOpt     opts = opts{bangpats     = True}+casesOpt        opts = opts{cases        = True}+strictCasesOpt  opts = opts{strictCases  = True}+stricterCasesOpt opts = opts{strictCases = True, stricterCases = True}+strictSemOpt    opts = opts{strictSems   = True}+localCpsOpt     opts = opts{localCps     = True}+splitSemsOpt    opts = opts{splitSems    = True}+werrorsOpt      opts = opts{werrors      = True}+wignoreOpt      opts = opts{wignore      = True}+wmaxErrsOpt :: String -> Options -> Options+wmaxErrsOpt n   opts = opts{wmaxerrs     = read n}+wmaxErrsOptGet :: Options -> String -> [String]+wmaxErrsOptGet opts nm = if wmaxerrs opts /= wmaxerrs noOptions+                         then [nm,show (wmaxerrs opts)]+                         else []+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 = allowSepSemMods opts}+genFileDepsOpt opts = opts{genFileDeps = True}+genLinePragmasOpt opts = opts{genLinePragmas = True}+genVisageOpt opts = opts{genvisage = True }+genMirageOpt opts = opts{genmirage = True }+genAspectAGOpt opts = opts{genAspectAG = True}++dummyTokenVisitOpt opts         = opts { dummyTokenVisit = True }+tupleAsDummyTokenOpt opts       = opts { tupleAsDummyToken = True }+stateAsDummyTokenOpt opts       = opts { tupleAsDummyToken = False }+strictDummyTokenOpt opts        = opts { strictDummyToken = True }+noPerRuleTypeSigsOpt opts       = opts { noPerRuleTypeSigs = True }+noPerStateTypeSigsOpt opts      = opts { noPerStateTypeSigs = True }+noEagerBlackholingOpt opts      = opts { noEagerBlackholing = True }+noPerRuleCostCentresOpt opts    = opts { noPerRuleCostCentres = True }+noPerVisitCostCentresOpt opts   = opts { noPerVisitCostCentres = True }+helpInliningOpt opts            = opts { helpInlining = True }+noInlinePragmasOpt opts         = opts { noInlinePragmas = True }+aggressiveInlinePragmasOpt opts = opts { aggressiveInlinePragmas = True }+lateHigherOrderBindingOpt opts  = opts { lateHigherOrderBinding = True }+monadicWrappersOpt opts         = opts { monadicWrappers = True }+referenceOpt opts               = opts { reference = True }++noGroupOpt :: String -> Options -> Options+noGroupOpt  att  opts = opts{noGroup  = wordsBy (== ':') att  ++ noGroup opts}+noGroupOptGet :: Options -> String -> [String]+noGroupOptGet opts nm = if null (noGroup opts)+                        then []+                        else [nm, intercalate ":" (noGroup opts)]+extendsOpt :: String -> Options -> Options+extendsOpt  m  opts = opts{extends  = Just m }++genAttrListOpt opts = opts { genAttributeList = True }+forceIrrefutableOpt :: Maybe String -> Options -> Options+forceIrrefutableOpt mbNm opts = opts { forceIrrefutables = mbNm }+uniqueDispenserOpt :: String -> Options -> Options+uniqueDispenserOpt nm opts = opts { uniqueDispenser = nm }+lcKeywordsOpt opts = opts { lcKeywords = True }+doubleColonsOpt opts = opts { doubleColons = True }+haskellSyntaxOpt = lcKeywordsOpt . doubleColonsOpt . genLinePragmasOpt+monadicOpt opts = opts { monadic = True }+parallelOpt opts = opts { parallelInvoke = True }+ocamlOpt opts = opts { ocaml = True, kennedyWarren = True, withCycle = True, visit = True }+cleanOpt opts = opts { clean = True } --TODO: More?+visitorsOutputOpt opts = opts { visitorsOutput = True }+statisticsOpt :: String -> Options -> Options+statisticsOpt nm opts = opts { statsFile = Just nm }+breadthfirstOpt opts = opts { breadthFirst = True }+breadthfirstStrictOpt opts = opts { breadthFirstStrict = True }+parseHsRhsOpt opts = opts { checkParseRhs = True }+parseHsTpOpt opts = opts { checkParseTy = True }+parseHsBlockOpt opts = opts { checkParseBlock = True }+parseHsOpt = parseHsRhsOpt . parseHsTpOpt . parseHsBlockOpt+kennedyWarrenOpt opts = opts { kennedyWarren = True }+noOptimizeOpt opts = opts { noOptimizations = True }+nocatasOpt :: String -> Options -> Options+nocatasOpt str opts = opts { nocatas = set `Set.union` nocatas opts } where+  set = Set.fromList ids+  ids = map identifier lst+  lst = wordsBy (== ',') str+nocatasOptGet :: Options -> String -> [String]+nocatasOptGet opts nm = if Set.null (nocatas opts)+                        then []+                        else [nm,intercalate "," . map getName . Set.toList . nocatas $ opts]+outputOpt :: String -> Options -> Options+outputOpt  file  opts = opts{outputFiles  = file : outputFiles opts}+outputOptGet :: Options -> String -> [String]+outputOptGet opts nm  = concat [ [nm, file] | file <- outputFiles opts]+searchPathOpt :: String -> Options -> Options+searchPathOpt  path  opts = opts{searchPath  = wordsBy (\x -> x == ';' || x == ':') path ++ searchPath opts}+searchPathOptGet :: Options -> String -> [String]+searchPathOptGet opts nm = if null (searchPath opts)+                           then []+                           else [nm, intercalate ":" (searchPath opts)]+allOpt = moduleOpt Nothing . dataOpt . cataOpt . semfunsOpt . signaturesOpt . prettyOpt . renameOpt . dataRecOpt+optimizeOpt   = visitOpt . casesOpt+noIncludesOpt opts = opts { noIncludes = True }+beQuietOpt opts = opts { beQuiet = True }++condDisableOptimizations opts+  | noOptimizations opts =+      opts { strictData         = False+           , strictWrap         = False+           , withSeq            = False+           , unbox              = False+           , bangpats           = False+           , cases              = False+           , strictCases        = False+           , stricterCases      = False+           , strictSems         = False+           , localCps           = False+           , splitSems          = False+           , breadthFirstStrict = False+           }+  | otherwise = opts+                +-- | Inverse of intercalate+wordsBy :: (Char -> Bool) -> String -> [String]+wordsBy p = f+  where+    f s = let (x,xs) = break p s+          in  if null x then [] else x : f (drop 1 xs)+                +-- | Use all parsed options to generate real options+constructOptions :: [Options -> Options] -> Options+constructOptions = foldl (flip ($)) noOptions++-- | Create Options type from string arguments+getOptions :: [String] -> (Options,[String],[String])+getOptions args = let (flags,files,errors) = getOpt Permute options args+                      appliedOpts = constructOptions flags+                      finOpts = condDisableOptimizations appliedOpts+                  in (finOpts,files,errors)++-- | Convert options back to commandline string+optionsToString :: Options -> [String]+optionsToString opt = concatMap (serializeOption opt) allOptions++-- | Combine 2 sets of options+combineOptions :: Options -> Options -> Options+combineOptions o1 o2 = let str1      = optionsToString o1+                           str2      = optionsToString o2+                           (opt,_,_) = getOptions (str1 ++ str2)+                       in  opt
src/ATermAbstractSyntax.hs view
@@ -1,23 +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)
-
-------------------------------------------------------------------------------
+{-----------------------------------------------------------------------------++        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)++------------------------------------------------------------------------------
src/Ag.hs view
@@ -1,558 +1,568 @@--- Todo: we should make a nicer pipeline. Perhaps use Atze's "compile run" combinators.
-module Ag (uuagcLib, uuagcExe,compile) where
-
-import System.Environment            (getArgs, getProgName)
-import System.Console.GetOpt         (usageInfo)
-import Data.List                     (partition)
-import Control.Monad                 (zipWithM_,when)
-import Data.Maybe
-import System.FilePath
-import System.IO
-
-import qualified Data.Set as Set
-import qualified Data.Map as Map
-import qualified Data.Sequence as Seq ((><),null)
-import Data.Foldable(toList)
-import Pretty
-import PPUtil
-
-import UU.Parsing                    (Message(..), Action(..))
-import UU.Scanner.Position           (Pos, line, file)
-import UU.Scanner.Token              (Token)
-
-import qualified Transform           as Pass1  (sem_AG     ,  wrap_AG     ,  Syn_AG      (..), Inh_AG      (..))
-import qualified Desugar             as Pass1a (sem_Grammar,  wrap_Grammar,  Syn_Grammar (..), Inh_Grammar (..))
-import qualified DefaultRules        as Pass2  (sem_Grammar,  wrap_Grammar,  Syn_Grammar (..), Inh_Grammar (..))
-import qualified ResolveLocals       as Pass2a (sem_Grammar,  wrap_Grammar,  Syn_Grammar (..), Inh_Grammar (..))
-import qualified Order               as Pass3  (sem_Grammar,  wrap_Grammar,  Syn_Grammar (..), Inh_Grammar (..))
-import qualified LOAG.Order          as Pass3b (sem_Grammar,  wrap_Grammar,  Syn_Grammar (..), Inh_Grammar (..))
-import qualified KWOrder             as Pass3a (sem_Grammar,  wrap_Grammar,  Syn_Grammar (..), Inh_Grammar (..))
-import qualified GenerateCode        as Pass4  (sem_CGrammar, wrap_CGrammar, Syn_CGrammar(..), Inh_CGrammar(..))
-import qualified PrintVisitCode      as Pass4a (sem_CGrammar, wrap_CGrammar, Syn_CGrammar(..), Inh_CGrammar(..))
-import qualified ExecutionPlan2Hs    as Pass4b (sem_ExecutionPlan, wrap_ExecutionPlan, Syn_ExecutionPlan(..), Inh_ExecutionPlan(..), warrenFlagsPP)
-import qualified ExecutionPlan2Caml  as Pass4c (sem_ExecutionPlan, wrap_ExecutionPlan, Syn_ExecutionPlan(..), Inh_ExecutionPlan(..))
-import qualified ExecutionPlan2Clean as Pass4d (sem_ExecutionPlan, wrap_ExecutionPlan, Syn_ExecutionPlan(..), Inh_ExecutionPlan(..), mkIclModuleHeader, mkDclModuleHeader, cleanIclModuleHeader, cleanDclModuleHeader)
-import qualified PrintCode           as Pass5  (sem_Program,  wrap_Program,  Syn_Program (..), Inh_Program (..))
-import qualified PrintOcamlCode      as Pass5a (sem_Program,  wrap_Program,  Syn_Program (..), Inh_Program (..))
-import qualified PrintCleanCode      as Pass5b (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 qualified AG2AspectAG as AspectAGDump (pragmaAspectAG, sem_Grammar,  wrap_Grammar,  Syn_Grammar (..), Inh_Grammar (..)) --marcos
-
-import Options
-import Version       (banner)
-import Parser        (parseAG, depsAG, parseAGI)
-import ErrorMessages (Error(ParserError))
-import CommonTypes
-import ATermWrite
-
--- Library version
-import System.Exit (ExitCode(..), exitWith)
-
-uuagcLib :: [String] -> FilePath -> IO (ExitCode, [FilePath])
-uuagcLib args fileP
-  = do let (flags,_,errs) = getOptions args
-       if showVersion flags || showHelp flags
-         then do putStrLn "Cannot display help or version in library mode."
-                 return (ExitFailure 1, [])
-         else if (not.null) errs
-              then do putStrLn "One or more errors occured:"
-                      mapM_ putStrLn errs
-                      return (ExitFailure 2, [])
-              else if genFileDeps flags
-                   then do deps <- getDeps flags [fileP]
-                           return (ExitSuccess, deps)
-                   else do compile flags fileP (head $ outputFiles flags++repeat "")
-                           return (ExitSuccess, [])
-
--- Executable version
-uuagcExe :: IO ()
-uuagcExe
- = do args     <- getArgs
-      progName <- getProgName
-
-      let usageheader = "Usage info:\n " ++ progName ++ " options file ...\n\nList of options:"
-          (flags,files,errs) = getOptions args
-
-      if showVersion flags
-        then putStrLn banner
-        else if showHelp flags
-             then putStrLn (usageInfo usageheader options)
-             else if null files || (not.null) errs
-                  then do mapM_ putStrLn (usageInfo usageheader options : errs)
-                          exitWith (ExitFailure 2)
-                  else if genFileDeps flags
-                       then reportDeps flags files
-                       else zipWithM_ (compile flags) files (outputFiles flags++repeat "")
-
-
-compile :: Options -> FilePath -> FilePath -> IO ()
-compile flags input output
- = do (output0,parseErrors) <- parseAG flags (searchPath flags) input
-      irrefutableMap <- readIrrefutableMap flags
-      let printStr  = outputStr flags
-          failWith  = failWithCode flags
-          inputfile = maybe input id (mainFilename flags)
-      let output1   = Pass1.wrap_AG              (Pass1.sem_AG                                 output0 ) Pass1.Inh_AG       {Pass1.options_Inh_AG       = flags}
-          flags'    = condDisableOptimizations (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', Pass1a.forcedIrrefutables_Inh_Grammar = irrefutableMap, Pass1a.mainName_Inh_Grammar = mainName }
-          grammar1a = Pass1a.output_Syn_Grammar  output1a
-          output2   = Pass2.wrap_Grammar         (Pass2.sem_Grammar grammar1a                          ) Pass2.Inh_Grammar  {Pass2.options_Inh_Grammar  = flags', Pass2.constructorTypeMap_Inh_Grammar = Pass1.constructorTypeMap_Syn_AG output1}
-          grammar2  = Pass2.output_Syn_Grammar   output2
-          outputV   = PassV.wrap_Grammar         (PassV.sem_Grammar grammar2                           ) PassV.Inh_Grammar  {}
-          grammarV  = PassV.visage_Syn_Grammar   outputV
-          output2a  = Pass2a.wrap_Grammar        (Pass2a.sem_Grammar grammar2                          ) Pass2a.Inh_Grammar {Pass2a.options_Inh_Grammar = flags'}
-          grammar2a = Pass2a.output_Syn_Grammar  output2a
-          output3   = Pass3.wrap_Grammar         (Pass3.sem_Grammar grammar2a                          ) Pass3.Inh_Grammar  {Pass3.options_Inh_Grammar  = flags'}
-          grammar3  = Pass3.output_Syn_Grammar   output3
-          output3a  = Pass3a.wrap_Grammar        (Pass3a.sem_Grammar grammar2a                         ) Pass3a.Inh_Grammar  {Pass3a.options_Inh_Grammar  = flags'}
-          output3b  = Pass3b.wrap_Grammar        (Pass3b.sem_Grammar grammar2a                         ) Pass3b.Inh_Grammar  {Pass3b.options_Inh_Grammar  = flags'}
-          grammar3a | loag flags' = Pass3b.output_Syn_Grammar output3b
-                    | otherwise   = Pass3a.output_Syn_Grammar output3a
-          output4   = Pass4.wrap_CGrammar        (Pass4.sem_CGrammar(Pass3.output_Syn_Grammar  output3)) Pass4.Inh_CGrammar {Pass4.options_Inh_CGrammar = flags'}
-          output4a  = Pass4a.wrap_CGrammar       (Pass4a.sem_CGrammar(Pass3.output_Syn_Grammar output3)) Pass4a.Inh_CGrammar {Pass4a.options_Inh_CGrammar = flags'}
-          output4b  = Pass4b.wrap_ExecutionPlan  (Pass4b.sem_ExecutionPlan grammar3a) Pass4b.Inh_ExecutionPlan {Pass4b.options_Inh_ExecutionPlan = flags', Pass4b.inhmap_Inh_ExecutionPlan = Pass3a.inhmap_Syn_Grammar output3a, Pass4b.synmap_Inh_ExecutionPlan = Pass3a.synmap_Syn_Grammar output3a, Pass4b.pragmaBlocks_Inh_ExecutionPlan = pragmaBlocksTxt, Pass4b.importBlocks_Inh_ExecutionPlan = importBlocksTxt, Pass4b.textBlocks_Inh_ExecutionPlan = textBlocksDoc, Pass4b.moduleHeader_Inh_ExecutionPlan = mkModuleHeader $ Pass1.moduleDecl_Syn_AG output1, Pass4b.mainName_Inh_ExecutionPlan = mkMainName mainName $ Pass1.moduleDecl_Syn_AG output1, Pass4b.mainFile_Inh_ExecutionPlan = mainFile, Pass4b.textBlockMap_Inh_ExecutionPlan = textBlockMap, Pass4b.mainBlocksDoc_Inh_ExecutionPlan = mainBlocksDoc,Pass4b.localAttrTypes_Inh_ExecutionPlan = Pass3a.localSigMap_Syn_Grammar output3a}
-          output4c  = Pass4c.wrap_ExecutionPlan  (Pass4c.sem_ExecutionPlan grammar3a) Pass4c.Inh_ExecutionPlan {Pass4c.options_Inh_ExecutionPlan = flags', Pass4c.inhmap_Inh_ExecutionPlan = Pass3a.inhmap_Syn_Grammar output3a, Pass4c.synmap_Inh_ExecutionPlan = Pass3a.synmap_Syn_Grammar output3a, Pass4c.mainName_Inh_ExecutionPlan = mkMainName mainName $ Pass1.moduleDecl_Syn_AG output1, Pass4c.mainFile_Inh_ExecutionPlan = mainFile, Pass4c.localAttrTypes_Inh_ExecutionPlan = Pass3a.localSigMap_Syn_Grammar output3a}
-          output4d  = Pass4d.wrap_ExecutionPlan  (Pass4d.sem_ExecutionPlan grammar3a) Pass4d.Inh_ExecutionPlan {Pass4d.options_Inh_ExecutionPlan = flags', Pass4d.inhmap_Inh_ExecutionPlan = Pass3a.inhmap_Syn_Grammar output3a, Pass4d.synmap_Inh_ExecutionPlan = Pass3a.synmap_Syn_Grammar output3a, Pass4d.importBlocks_Inh_ExecutionPlan = importBlocksTxt, Pass4d.textBlocks_Inh_ExecutionPlan = textBlocksDoc, Pass4d.iclModuleHeader_Inh_ExecutionPlan = Pass4d.mkIclModuleHeader $ Pass1.moduleDecl_Syn_AG output1, Pass4d.dclModuleHeader_Inh_ExecutionPlan = Pass4d.mkDclModuleHeader $ Pass1.moduleDecl_Syn_AG output1, Pass4d.mainName_Inh_ExecutionPlan = mkMainName mainName $ Pass1.moduleDecl_Syn_AG output1, Pass4d.mainFile_Inh_ExecutionPlan = mainFile, Pass4d.textBlockMap_Inh_ExecutionPlan = textBlockMap, Pass4d.mainBlocksDoc_Inh_ExecutionPlan = mainBlocksDoc,Pass4d.localAttrTypes_Inh_ExecutionPlan = Pass3a.localSigMap_Syn_Grammar output3a, Pass4d.constructorTypeMap_Inh_ExecutionPlan = Pass1.constructorTypeMap_Syn_AG output1}
-          output5   = Pass5.wrap_Program         (Pass5.sem_Program (Pass4.output_Syn_CGrammar output4)) Pass5.Inh_Program  {Pass5.options_Inh_Program  = flags', Pass5.pragmaBlocks_Inh_Program = pragmaBlocksTxt, Pass5.importBlocks_Inh_Program = importBlocksTxt, Pass5.textBlocks_Inh_Program = textBlocksDoc, Pass5.textBlockMap_Inh_Program = textBlockMap, Pass5.mainBlocksDoc_Inh_Program = mainBlocksDoc, Pass5.optionsLine_Inh_Program = optionsLine, Pass5.mainFile_Inh_Program = mainFile, Pass5.moduleHeader_Inh_Program = mkModuleHeader $ Pass1.moduleDecl_Syn_AG output1, Pass5.mainName_Inh_Program = mkMainName mainName $ Pass1.moduleDecl_Syn_AG output1}
-          output5a  = Pass5a.wrap_Program        (Pass5a.sem_Program (Pass4.output_Syn_CGrammar output4)) Pass5a.Inh_Program { Pass5a.options_Inh_Program  = flags', Pass5a.textBlockMap_Inh_Program = textBlockMap }
-          output5b  = Pass5b.wrap_Program        (Pass5b.sem_Program (Pass4.output_Syn_CGrammar output4)) Pass5b.Inh_Program  {Pass5b.options_Inh_Program  = flags', Pass5b.pragmaBlocks_Inh_Program = pragmaBlocksTxt, Pass5b.importBlocks_Inh_Program = importBlocksTxt, Pass5b.textBlocks_Inh_Program = textBlocksDoc, Pass5b.textBlockMap_Inh_Program = textBlockMap, Pass5b.mainBlocksDoc_Inh_Program = mainBlocksDoc, Pass5b.optionsLine_Inh_Program = optionsLine, Pass5b.mainFile_Inh_Program = mainFile, Pass5b.moduleHeader_Inh_Program = mkModuleHeader $ Pass1.moduleDecl_Syn_AG output1, Pass5b.mainName_Inh_Program = mkMainName mainName $ Pass1.moduleDecl_Syn_AG output1}
-          output6   = PrErr.wrap_Errors          (PrErr.sem_Errors                       errorsToReport) PrErr.Inh_Errors   {PrErr.options_Inh_Errors   = flags', PrErr.dups_Inh_Errors = [] }
-
-          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)
-          mainErrors       = toList ( Pass1.errors_Syn_AG       output1
-                               Seq.>< Pass1a.errors_Syn_Grammar output1a
-                               Seq.>< Pass2.errors_Syn_Grammar  output2
-                               Seq.>< Pass2a.errors_Syn_Grammar output2a)
-          furtherErrors    = if loag flags'
-                             then toList (Pass3b.errors_Syn_Grammar output3b)
-                             else if kennedyWarren flags'
-                                  then let errs3a = Pass3a.errors_Syn_Grammar output3a
-                                       in if Seq.null errs3a
-                                          then if ocaml flags'
-                                               then toList ( Pass4c.errors_Syn_ExecutionPlan output4c )
-                                               else if clean flags'
-                                                    then toList ( Pass4d.errors_Syn_ExecutionPlan output4d )
-                                                    else toList ( Pass4b.errors_Syn_ExecutionPlan output4b )
-                                          else toList errs3a
-                                  else toList ( Pass3.errors_Syn_Grammar  output3
-                                                Seq.>< Pass4.errors_Syn_CGrammar output4)
-
-          errorList        = if null parseErrorList
-                             then mainErrors
-                                  ++ if null (filter (PrErr.isError flags') mainErrors)
-                                     then furtherErrors
-                                     else []
-                             else [head parseErrorList]
-
-          fatalErrorList = filter (PrErr.isError flags') errorList
-
-          allErrors = if wignore flags'
-                      then fatalErrorList
-                      else errorsToFront flags' errorList
-
-          errorsToReport = take (wmaxerrs flags') allErrors
-
-          errorsToStopOn = if werrors flags'
-                            then errorList
-                            else fatalErrorList
-
-          blocks1                    = (Pass1.blocks_Syn_AG output1) {-SM `Map.unionWith (++)` (Pass3.blocks_Syn_Grammar output3)-}
-          (pragmaBlocks, blocks2)    = Map.partitionWithKey (\(k, at) _->k==BlockPragma && at == Nothing) blocks1
-          (importBlocks, textBlocks) = Map.partitionWithKey (\(k, at) _->k==BlockImport && at == Nothing) blocks2
-
-          importBlocksTxt = vlist_sep "" . map addLocationPragma . concat . Map.elems $ importBlocks
-          textBlocksDoc   = vlist_sep "" . map addLocationPragma . Map.findWithDefault [] (BlockOther, Nothing) $ textBlocks
-          mainBlocksDoc   = vlist_sep "" . map addLocationPragma . Map.findWithDefault [] (BlockMain, Nothing) $ textBlocks
-          dataBlocksDoc   = vlist_sep "" . map addLocationPragma . Map.findWithDefault [] (BlockData, Nothing) $ textBlocks
-          recBlocksDoc    = vlist_sep "" . map addLocationPragma . Map.findWithDefault [] (BlockRec, Nothing) $ textBlocks
-          pragmaBlocksTxt = unlines . concat . map fst  . concat . Map.elems $ pragmaBlocks
-          textBlockMap    = Map.map (vlist_sep "" . map addLocationPragma) . Map.filterWithKey (\(_, at) _ -> at /= Nothing) $ textBlocks
-
-          outputfile = if null output then outputFile flags' inputfile else output
-          mainFile | null output = outputFile flags' inputfile
-                   | otherwise   = output
-          mainName = dropExtension $ takeFileName inputfile
-
-          addLocationPragma :: ([String], Pos) -> PP_Doc
-          addLocationPragma (strs, p)
-            | genLinePragmas flags' =
-                ppLinePragma flags' (line p) (file p) >-< vlist (map pp strs)
-                >-< ppWithLineNr (\l -> ppLinePragma flags' (l+1) outputfile)
-            | otherwise = vlist (map pp strs)
-
-          optionsGHC = option (unbox flags') "-fglasgow-exts" ++ option (bangpats flags') "-XBangPatterns"
-          option True s  = [s]
-          option False _ = []
-          optionsLine | null optionsGHC = ""
-                      | otherwise       = "{-# OPTIONS_GHC " ++ unwords optionsGHC ++ " #-}"
-
-          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"
-
-      (outAgi, ext) <-  --marcos
-                     if genAspectAG flags'
-                     then parseAGI flags (searchPath flags) (agiFile input)
-                     else return (undefined, undefined)
-
-      let ext'      = fmap remAgi ext
-          outAgi1   = Pass1.wrap_AG             (Pass1.sem_AG               outAgi ) Pass1.Inh_AG             {Pass1.options_Inh_AG       = flags'}
-          agi       = Pass1.agi_Syn_AG          outAgi1
-          aspectAG  = AspectAGDump.wrap_Grammar (AspectAGDump.sem_Grammar grammar2  ) AspectAGDump.Inh_Grammar { AspectAGDump.options_Inh_Grammar  = flags'
-                                                                                                               , AspectAGDump.agi_Inh_Grammar      = agi
-                                                                                                               , AspectAGDump.ext_Inh_Grammar      = ext' } --marcos
-
-      printStr . formatErrors $ PrErr.pp_Syn_Errors output6
-
-      if additionalErrors > 0
-       then printStr $ "\nPlus " ++ show additionalErrors ++ " more error" ++ pluralS additionalErrors ++
-                     if additionalWarnings > 0
-                     then " and " ++ show additionalWarnings ++ " more warning" ++ pluralS additionalWarnings ++ ".\n"
-                     else ".\n"
-       else if additionalWarnings > 0
-            then printStr $ "\nPlus " ++ show additionalWarnings ++ " more warning" ++ pluralS additionalWarnings ++ ".\n"
-            else return ()
-
-      -- show fake dependencies when found with --aoag
-      when (aoag flags' && verbose flags' && 
-            isJust (Pass3b.ads_Syn_Grammar output3b)) $
-        putStrLn (show $ fromJust $ Pass3b.ads_Syn_Grammar output3b)
-
-      if not (null errorsToStopOn)  -- note: this may already run quite a part of the compilation...
-       then failWith 1
-       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
-                    if loag flags || kennedyWarren flags'
-                      then if ocaml flags' 
-                           then error "sepsemmods is not implemented for the ocaml output generation"
-                           else Pass4b.genIO_Syn_ExecutionPlan output4b
-                      else Pass5.genIO_Syn_Program output5
-                    if not (null errorsToStopOn) then failWith 1 else return ()
-            else do -- conventional module gen
-                    let doc
-                         | visitorsOutput flags'
-                            = vlist [ pp_braces importBlocksTxt
-                                    , pp_braces textBlocksDoc
-                                    , vlist $ Pass4a.output_Syn_CGrammar output4a
-                                    ]
-                         -- marcos AspectAG gen
-                         | genAspectAG flags'
-                            = vlist [ AspectAGDump.pragmaAspectAG
-                                    , pp optionsLine
-                                    , pp pragmaBlocksTxt
-                                    , pp $ take 70 ("-- UUAGC2AspectAG " ++ drop 50 banner ++ " (" ++ input) ++ ")"
-                                    , pp $ if isNothing $ Pass1.moduleDecl_Syn_AG output1
-                                           then moduleHeader flags' mainName ext'
-                                           else mkModuleHeader (Pass1.moduleDecl_Syn_AG output1) mainName "" "" False
-                                    , pp importBlocksTxt
-                                    , AspectAGDump.imp_Syn_Grammar aspectAG
-                                    , pp "\n\n{-- AspectAG Code --}\n\n"
-                                    , AspectAGDump.pp_Syn_Grammar aspectAG
-                                    , dataBlocksDoc
-                                    , mainBlocksDoc
-                                    , textBlocksDoc
-                                    , if dumpgrammar flags'
-                                      then vlist [ pp "{- Dump of AGI"
-                                                 , pp (show agi)
-                                                 , pp "-}"
-                                                 , pp "{- Dump of grammar with default rules"
-                                                 , GrammarDump.pp_Syn_Grammar dump2
-                                                 , pp "-}"
-                                                 ]
-                                      else empty]
-                         | loag flags' || kennedyWarren flags'
-                            = if ocaml flags'
-                              then vlist
-                                    [ text "(* generated by UUAG from" >#< mainFile >#< "*)"
-                                    , pp pragmaBlocksTxt
-                                    , text "(* module imports *)"
-                                    , pp importBlocksTxt
-                                    , Pass4c.modules_Syn_ExecutionPlan output4c
-                                    , text ""
-                                    , text "(* generated data types *)"
-                                    , text "module Data__ = struct"
-                                    , indent 2 $ vlist
-                                      [ text "type __generated_by_uuagc__ = Generated_by_uuagc__"
-                                      , Pass4c.datas_Syn_ExecutionPlan output4c
-                                      ]
-                                    , text "end"
-                                    , text "open Data__"
-                                    , text ""
-                                    , text "(* embedded data types *)"
-                                    , dataBlocksDoc
-                                    , text ""
-                                    , text "(* embedded utilty functions *)"
-                                    , textBlocksDoc
-                                    , text "(* generated evaluationcode *)"
-                                    , text "module Code__ = struct"
-                                    , indent 2 $ vlist
-                                      [ text "let rec __generated_by_uuagc__ = Generated_by_uuagc__"
-                                      , Pass4c.code_Syn_ExecutionPlan output4c
-                                      , recBlocksDoc
-                                      ]
-                                    , text "end"
-                                    , text "open Code__"
-                                    , text ""
-                                    , text "(* main code *)"
-                                    , mainBlocksDoc
-                                    ]
-                              else if clean flags'
-                                   then vlist
-                                    [ pp $ if isNothing $ Pass1.moduleDecl_Syn_AG output1
-                                           then Pass4d.cleanIclModuleHeader flags' mainName
-                                           else Pass4d.mkIclModuleHeader (Pass1.moduleDecl_Syn_AG output1) mainName "" "" False
-                                    , pp importBlocksTxt
-                                    , dataBlocksDoc
-                                    , vlist [ pp $ "from Control.Monad.Identity import :: Identity"
-                                            , pp $ "import qualified Control.Monad.Identity as Control.Monad.Identity"
-                                            , pp $ "import Control.Monad.Identity"
-                                            , pp $ "from Control.Applicative import lift"
-                                            , pp $ "from Control.Monad import class Monad (..)"
-                                            ]
-                                    , mainBlocksDoc
-                                    , textBlocksDoc
-                                    , recBlocksDoc
-                                    --, pp $ "{-"
-                                    --, Pass3a.depgraphs_Syn_Grammar output3a
-                                    --, Pass3a.visitgraph_Syn_Grammar output3a
-                                    --, pp $ "-}"
-                                    , Pass4d.output_Syn_ExecutionPlan output4d
-                                    , if dumpgrammar flags'
-                                      then vlist [ pp "/* Dump of grammar with default rules"
-                                                 , GrammarDump.pp_Syn_Grammar dump2
-                                                 , pp "*/"
-                                                 ]
-                                      else empty]
-
-                                   else vlist
-                                    [ Pass4b.warrenFlagsPP flags'
-                                    , pp pragmaBlocksTxt
-                                    , pp $ if isNothing $ Pass1.moduleDecl_Syn_AG output1
-                                           then moduleHeader flags' mainName Nothing
-                                           else mkModuleHeader (Pass1.moduleDecl_Syn_AG output1) mainName "" "" False
-                                    , pp importBlocksTxt
-                                    , ( if tupleAsDummyToken flags'
-                                          then empty
-                                          else pp "import GHC.Prim"  -- need it to pass State#
-                                      )
-                                    , if parallelInvoke flags'
-                                      then vlist [ pp $ "import qualified System.IO.Unsafe(unsafePerformIO)"
-                                                 , pp $ "import System.IO(IO)"
-                                                 , pp $ "import Control.Concurrent(newEmptyMVar,forkIO,putMVar,takeMVar)"]
-                                      else vlist [ pp $ "import Control.Monad.Identity (Identity)"
-                                                 , pp $ "import qualified Control.Monad.Identity" ]
-                                    , dataBlocksDoc
-                                    , mainBlocksDoc
-                                    , textBlocksDoc
-                                    , recBlocksDoc
-                                    --, pp $ "{-"
-                                    --, Pass3a.depgraphs_Syn_Grammar output3a
-                                    --, Pass3a.visitgraph_Syn_Grammar output3a
-                                    --, pp $ "-}"
-                                    , Pass4b.output_Syn_ExecutionPlan output4b
-                                    , if dumpgrammar flags'
-                                      then vlist [ pp "{- Dump of grammar with default rules"
-                                                 , GrammarDump.pp_Syn_Grammar dump2
-                                                 , pp "-}"
-                                                 ]
-                                      else empty]
-                         | otherwise
-                            = vlist [ vlist ( if (ocaml flags' || clean flags')
-                                              then []
-                                              else [ pp optionsLine
-                                                   , pp pragmaBlocksTxt
-                                                   , pp $ take 70 ("-- UUAGC " ++ drop 50 banner ++ " (" ++ input) ++ ")"
-                                                   , pp $ if isNothing $ Pass1.moduleDecl_Syn_AG output1
-                                                          then moduleHeader flags' mainName Nothing
-                                                          else mkModuleHeader (Pass1.moduleDecl_Syn_AG output1) mainName "" "" False
-                                                   ]
-                                            )
-                                    , pp importBlocksTxt
-                                    , dataBlocksDoc
-                                    , mainBlocksDoc
-                                    , textBlocksDoc
-                                    , vlist $ if (ocaml flags')
-                                                then Pass5a.output_Syn_Program output5a
-                                                else if (clean flags')
-                                                       then Pass5b.output_Syn_Program  output5b
-                                                       else Pass5.output_Syn_Program  output5
-                                    , if dumpgrammar flags'
-                                      then vlist [ pp "{- Dump of grammar without default rules"
-                                                 , GrammarDump.pp_Syn_Grammar dump1
-                                                 , pp "-}"
-                                                 , pp "{- Dump of grammar with default rules"
-                                                 , GrammarDump.pp_Syn_Grammar dump2
-                                                 , pp "-}"
-                                                 ]
-                                      else empty
-                                    , if dumpcgrammar flags'
-                                      then vlist [ pp "{- Dump of cgrammar"
-                                                 , CGrammarDump.pp_Syn_CGrammar dump3
-                                                 , pp "-}"
-                                                 ]
-                                      else empty
-                                    ]
-
-                    let docTxt = disp doc 50000 ""
-                    writeFile outputfile docTxt
-
-                    -- HACK: write Clean DCL file
-                    if clean flags'
-                      then do let dclDoc =
-                                    vlist
-                                    [ pp $ if isNothing $ Pass1.moduleDecl_Syn_AG output1
-                                           then Pass4d.cleanDclModuleHeader flags' mainName Nothing -- TODO: What should be there instead of Nothing?
-                                           else Pass4d.mkDclModuleHeader (Pass1.moduleDecl_Syn_AG output1) mainName "" "" False
-                                    , vlist [ pp $ "from Control.Monad.Identity import :: Identity"
-                                            , pp $ "import qualified Control.Monad.Identity as Control.Monad.Identity"
-                                            , pp $ "import Control.Monad.Identity"
-                                            , pp $ "from Control.Applicative import lift"
-                                            , pp $ "from Control.Monad import class Monad (..)"
-                                            ]
-                                    , Pass4d.output_dcl_Syn_ExecutionPlan output4d
-                                    ]
-                              writeFile (replaceExtension outputfile ".dcl") (disp dclDoc 50000 "")
-                      else return ()
-
-                    -- HACK: write statistics
-                    let nAuto = Pass3.nAutoRules_Syn_Grammar output3
-                        nExpl = Pass3.nExplicitRules_Syn_Grammar output3
-                        line' = inputfile ++ "," ++ show nAuto ++ "," ++ show nExpl ++ "\r\n"
-                    case statsFile flags' of
-                      Nothing -> return ()
-                      Just f  -> appendFile f line'
-                    if not (null errorsToStopOn) then failWith 1 else return ()
-
-
-
-formatErrors :: PP_Doc -> String
-formatErrors doc = disp doc 5000 ""
-
-
-message2error :: Message Token Pos -> Error
-message2error (Msg expect pos action) = ParserError pos (show expect) actionString
- where actionString
-        =  case action
-           of Insert s -> "inserting: " ++ show s
-
-              Delete s -> "deleting: "  ++ show s
-
-              Other ms -> ms
-
-errorsToFront :: Options -> [Error] -> [Error]
-errorsToFront flags mesgs = errs ++ warnings
-  where (errs,warnings) = partition (PrErr.isError flags) mesgs
-
-moduleHeader :: Options -> String -> Maybe String -> String
-moduleHeader flags input export
- = case moduleName flags
-   of Name nm -> genMod nm
-      Default -> genMod (defaultModuleName input)
-      NoName  -> ""
-   where genMod x = "module " ++ x ++ genExp export x ++ " where"
-         genExp Nothing _ = ""
-         genExp (Just e) x = "(module " ++ x ++ ", module " ++ e ++ ")"
-
---marcos
-agiFile :: String -> String
-agiFile name = replaceExtension name "agi"
-
-remAgi :: String -> String
-remAgi = dropExtension
-
-outputFile :: Options -> String -> String
-outputFile opts name
-  | ocaml opts = replaceExtension name "ml"
-  | clean opts = replaceExtension name "icl"
-  | otherwise  = replaceExtension name "hs"
-
-defaultModuleName :: String -> String
-defaultModuleName = dropExtension
-
-mkMainName :: String -> Maybe (String, String,String) -> String
-mkMainName defaultName Nothing
-  = defaultName
-mkMainName _ (Just (name, _, _))
-  = name
-
-mkModuleHeader :: Maybe (String,String,String) -> String -> String -> String -> Bool -> String
-mkModuleHeader Nothing defaultName suffix _ _
-  = "module " ++ defaultName ++ suffix ++ " where"
-mkModuleHeader (Just (name, exports, imports)) _ suffix addExports replaceExports
-  = "module " ++ name ++ suffix ++ ex ++ " where\n" ++ imports ++ "\n"
-  where
-    ex  = if null exports || (replaceExports && null addExports)
-          then ""
-          else if null addExports
-               then "(" ++ exports ++ ")"
-               else if replaceExports
-                    then "(" ++ addExports ++ ")"
-                    else "(" ++ exports ++ "," ++ addExports ++ ")"
-
-reportDeps :: Options -> [String] -> IO ()
-reportDeps flags files
-  = do deps <- getDeps flags files
-       mapM_ putStrLn deps
-
-getDeps :: Options -> [String] -> IO [String]
-getDeps flags files
-  = do results <- mapM (depsAG flags (searchPath flags)) files
-       let (fs, mesgs) = foldr comb ([],[]) results
-       let errs = take (min 1 (wmaxerrs flags)) (map message2error mesgs)
-       let ppErrs = PrErr.wrap_Errors (PrErr.sem_Errors errs) PrErr.Inh_Errors {PrErr.options_Inh_Errors = flags, PrErr.dups_Inh_Errors = []}
-       if null errs
-        then return fs
-        else do hPutStrLn stderr . formatErrors $ PrErr.pp_Syn_Errors ppErrs
-                failWithCode flags 1
-                return []
-  where
-    comb :: ([a],[b]) -> ([a], [b]) -> ([a], [b])
-    comb (fs, mesgs) (fsr, mesgsr)
-      = (fs ++ fsr, mesgs ++ mesgsr)
-
-
-writeAttributeList :: String -> AttrMap -> IO ()
-writeAttributeList fileP mp
-  = writeFile fileP 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 fileP -> do s <- readFile fileP
-                       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
-
-
+-- Todo: we should make a nicer pipeline. Perhaps use Atze's "compile run" combinators.+module Ag (uuagcLib, uuagcExe,compile) where++import System.Environment            (getArgs, getProgName)+import System.Console.GetOpt         (usageInfo)+import Data.List                     (partition)+import Control.Monad                 (zipWithM_,when)+import Data.Maybe+import System.FilePath+import System.IO++import qualified Data.Set as Set+import qualified Data.Map as Map+import qualified Data.Sequence as Seq ((><),null)+import Data.Foldable(toList)+import Pretty+import PPUtil++import UU.Parsing                    (Message(..), Action(..))+import UU.Scanner.Position           (Pos, line, file)+import UU.Scanner.Token              (Token)++import qualified Transform           as Pass1  (sem_AG     ,  wrap_AG     ,  Syn_AG      (..), Inh_AG      (..))+import qualified Desugar             as Pass1a (sem_Grammar,  wrap_Grammar,  Syn_Grammar (..), Inh_Grammar (..))+import qualified DefaultRules        as Pass2  (sem_Grammar,  wrap_Grammar,  Syn_Grammar (..), Inh_Grammar (..))+import qualified ResolveLocals       as Pass2a (sem_Grammar,  wrap_Grammar,  Syn_Grammar (..), Inh_Grammar (..))+import qualified Order               as Pass3  (sem_Grammar,  wrap_Grammar,  Syn_Grammar (..), Inh_Grammar (..))+import qualified LOAG.Order          as Pass3b (sem_Grammar,  wrap_Grammar,  Syn_Grammar (..), Inh_Grammar (..))+import qualified KWOrder             as Pass3a (sem_Grammar,  wrap_Grammar,  Syn_Grammar (..), Inh_Grammar (..))+import qualified GenerateCode        as Pass4  (sem_CGrammar, wrap_CGrammar, Syn_CGrammar(..), Inh_CGrammar(..))+import qualified PrintVisitCode      as Pass4a (sem_CGrammar, wrap_CGrammar, Syn_CGrammar(..), Inh_CGrammar(..))+import qualified ExecutionPlan2Hs    as Pass4b (sem_ExecutionPlan, wrap_ExecutionPlan, Syn_ExecutionPlan(..), Inh_ExecutionPlan(..), warrenFlagsPP)+import qualified ExecutionPlan2Caml  as Pass4c (sem_ExecutionPlan, wrap_ExecutionPlan, Syn_ExecutionPlan(..), Inh_ExecutionPlan(..))+import qualified ExecutionPlan2Clean as Pass4d (sem_ExecutionPlan, wrap_ExecutionPlan, Syn_ExecutionPlan(..), Inh_ExecutionPlan(..), mkIclModuleHeader, mkDclModuleHeader, cleanIclModuleHeader, cleanDclModuleHeader)+import qualified PrintCode           as Pass5  (sem_Program,  wrap_Program,  Syn_Program (..), Inh_Program (..))+import qualified PrintOcamlCode      as Pass5a (sem_Program,  wrap_Program,  Syn_Program (..), Inh_Program (..))+import qualified PrintCleanCode      as Pass5b (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 TfmToMirage         as PassM  (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 qualified AG2AspectAG as AspectAGDump (pragmaAspectAG, sem_Grammar,  wrap_Grammar,  Syn_Grammar (..), Inh_Grammar (..)) --marcos++import Options+import Version       (banner)+import Parser        (parseAG, depsAG, parseAGI)+import ErrorMessages (Error(ParserError))+import CommonTypes+import ATermWrite+import Data.Aeson (encode)+import qualified Data.ByteString.Lazy as ByteString++-- Library version+import System.Exit (ExitCode(..), exitWith)++uuagcLib :: [String] -> FilePath -> IO (ExitCode, [FilePath])+uuagcLib args fileP+  = do let (flags,_,errs) = getOptions args+       if showVersion flags || showHelp flags+         then do putStrLn "Cannot display help or version in library mode."+                 return (ExitFailure 1, [])+         else if (not.null) errs+              then do putStrLn "One or more errors occured:"+                      mapM_ putStrLn errs+                      return (ExitFailure 2, [])+              else if genFileDeps flags+                   then do deps <- getDeps flags [fileP]+                           return (ExitSuccess, deps)+                   else do compile flags fileP (head $ outputFiles flags++repeat "")+                           return (ExitSuccess, [])++-- Executable version+uuagcExe :: IO ()+uuagcExe+ = do args     <- getArgs+      progName <- getProgName++      let usageheader = "Usage info:\n " ++ progName ++ " options file ...\n\nList of options:"+          (flags,files,errs) = getOptions args++      if showVersion flags+        then putStrLn banner+        else if showHelp flags+             then putStrLn (usageInfo usageheader options)+             else if null files || (not.null) errs+                  then do mapM_ putStrLn (usageInfo usageheader options : errs)+                          exitWith (ExitFailure 2)+                  else if genFileDeps flags+                       then reportDeps flags files+                       else zipWithM_ (compile flags) files (outputFiles flags++repeat "")+++compile :: Options -> FilePath -> FilePath -> IO ()+compile flags input output+ = do (output0,parseErrors) <- parseAG flags (searchPath flags) input+      irrefutableMap <- readIrrefutableMap flags+      let printStr  = outputStr flags+          failWith  = failWithCode flags+          inputfile = maybe input id (mainFilename flags)+      let output1   = Pass1.wrap_AG              (Pass1.sem_AG                                 output0 ) Pass1.Inh_AG       {Pass1.options_Inh_AG       = flags}+          flags'    = condDisableOptimizations (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', Pass1a.forcedIrrefutables_Inh_Grammar = irrefutableMap, Pass1a.mainName_Inh_Grammar = mainName }+          grammar1a = Pass1a.output_Syn_Grammar  output1a+          output2   = Pass2.wrap_Grammar         (Pass2.sem_Grammar grammar1a                          ) Pass2.Inh_Grammar  {Pass2.options_Inh_Grammar  = flags', Pass2.constructorTypeMap_Inh_Grammar = Pass1.constructorTypeMap_Syn_AG output1}+          grammar2  = Pass2.output_Syn_Grammar   output2+          outputV   = PassV.wrap_Grammar         (PassV.sem_Grammar grammar2                           ) PassV.Inh_Grammar  {}+          grammarV  = PassV.visage_Syn_Grammar   outputV+          outputM   = PassM.wrap_Grammar         (PassM.sem_Grammar grammar2                           ) PassM.Inh_Grammar  {PassM.options_Inh_Grammar = flags'}+          output2a  = Pass2a.wrap_Grammar        (Pass2a.sem_Grammar grammar2                          ) Pass2a.Inh_Grammar {Pass2a.options_Inh_Grammar = flags'}+          grammar2a = Pass2a.output_Syn_Grammar  output2a+          output3   = Pass3.wrap_Grammar         (Pass3.sem_Grammar grammar2a                          ) Pass3.Inh_Grammar  {Pass3.options_Inh_Grammar  = flags'}+          grammar3  = Pass3.output_Syn_Grammar   output3+          output3a  = Pass3a.wrap_Grammar        (Pass3a.sem_Grammar grammar2a                         ) Pass3a.Inh_Grammar  {Pass3a.options_Inh_Grammar  = flags'}+          output3b  = Pass3b.wrap_Grammar        (Pass3b.sem_Grammar grammar2a                         ) Pass3b.Inh_Grammar  {Pass3b.options_Inh_Grammar  = flags'}+          grammar3a | loag flags' = Pass3b.output_Syn_Grammar output3b+                    | otherwise   = Pass3a.output_Syn_Grammar output3a+          output4   = Pass4.wrap_CGrammar        (Pass4.sem_CGrammar(Pass3.output_Syn_Grammar  output3)) Pass4.Inh_CGrammar {Pass4.options_Inh_CGrammar = flags'}+          output4a  = Pass4a.wrap_CGrammar       (Pass4a.sem_CGrammar(Pass3.output_Syn_Grammar output3)) Pass4a.Inh_CGrammar {Pass4a.options_Inh_CGrammar = flags'}+          output4b  = Pass4b.wrap_ExecutionPlan  (Pass4b.sem_ExecutionPlan grammar3a) Pass4b.Inh_ExecutionPlan {Pass4b.options_Inh_ExecutionPlan = flags', Pass4b.inhmap_Inh_ExecutionPlan = Pass3a.inhmap_Syn_Grammar output3a, Pass4b.synmap_Inh_ExecutionPlan = Pass3a.synmap_Syn_Grammar output3a, Pass4b.pragmaBlocks_Inh_ExecutionPlan = pragmaBlocksTxt, Pass4b.importBlocks_Inh_ExecutionPlan = importBlocksTxt, Pass4b.textBlocks_Inh_ExecutionPlan = textBlocksDoc, Pass4b.moduleHeader_Inh_ExecutionPlan = mkModuleHeader $ Pass1.moduleDecl_Syn_AG output1, Pass4b.mainName_Inh_ExecutionPlan = mkMainName mainName $ Pass1.moduleDecl_Syn_AG output1, Pass4b.mainFile_Inh_ExecutionPlan = mainFile, Pass4b.textBlockMap_Inh_ExecutionPlan = textBlockMap, Pass4b.mainBlocksDoc_Inh_ExecutionPlan = mainBlocksDoc,Pass4b.localAttrTypes_Inh_ExecutionPlan = Pass3a.localSigMap_Syn_Grammar output3a}+          output4c  = Pass4c.wrap_ExecutionPlan  (Pass4c.sem_ExecutionPlan grammar3a) Pass4c.Inh_ExecutionPlan {Pass4c.options_Inh_ExecutionPlan = flags', Pass4c.inhmap_Inh_ExecutionPlan = Pass3a.inhmap_Syn_Grammar output3a, Pass4c.synmap_Inh_ExecutionPlan = Pass3a.synmap_Syn_Grammar output3a, Pass4c.mainName_Inh_ExecutionPlan = mkMainName mainName $ Pass1.moduleDecl_Syn_AG output1, Pass4c.mainFile_Inh_ExecutionPlan = mainFile, Pass4c.localAttrTypes_Inh_ExecutionPlan = Pass3a.localSigMap_Syn_Grammar output3a}+          output4d  = Pass4d.wrap_ExecutionPlan  (Pass4d.sem_ExecutionPlan grammar3a) Pass4d.Inh_ExecutionPlan {Pass4d.options_Inh_ExecutionPlan = flags', Pass4d.inhmap_Inh_ExecutionPlan = Pass3a.inhmap_Syn_Grammar output3a, Pass4d.synmap_Inh_ExecutionPlan = Pass3a.synmap_Syn_Grammar output3a, Pass4d.importBlocks_Inh_ExecutionPlan = importBlocksTxt, Pass4d.textBlocks_Inh_ExecutionPlan = textBlocksDoc, Pass4d.iclModuleHeader_Inh_ExecutionPlan = Pass4d.mkIclModuleHeader $ Pass1.moduleDecl_Syn_AG output1, Pass4d.dclModuleHeader_Inh_ExecutionPlan = Pass4d.mkDclModuleHeader $ Pass1.moduleDecl_Syn_AG output1, Pass4d.mainName_Inh_ExecutionPlan = mkMainName mainName $ Pass1.moduleDecl_Syn_AG output1, Pass4d.mainFile_Inh_ExecutionPlan = mainFile, Pass4d.textBlockMap_Inh_ExecutionPlan = textBlockMap, Pass4d.mainBlocksDoc_Inh_ExecutionPlan = mainBlocksDoc,Pass4d.localAttrTypes_Inh_ExecutionPlan = Pass3a.localSigMap_Syn_Grammar output3a, Pass4d.constructorTypeMap_Inh_ExecutionPlan = Pass1.constructorTypeMap_Syn_AG output1}+          output5   = Pass5.wrap_Program         (Pass5.sem_Program (Pass4.output_Syn_CGrammar output4)) Pass5.Inh_Program  {Pass5.options_Inh_Program  = flags', Pass5.pragmaBlocks_Inh_Program = pragmaBlocksTxt, Pass5.importBlocks_Inh_Program = importBlocksTxt, Pass5.textBlocks_Inh_Program = textBlocksDoc, Pass5.textBlockMap_Inh_Program = textBlockMap, Pass5.mainBlocksDoc_Inh_Program = mainBlocksDoc, Pass5.optionsLine_Inh_Program = optionsLine, Pass5.mainFile_Inh_Program = mainFile, Pass5.moduleHeader_Inh_Program = mkModuleHeader $ Pass1.moduleDecl_Syn_AG output1, Pass5.mainName_Inh_Program = mkMainName mainName $ Pass1.moduleDecl_Syn_AG output1}+          output5a  = Pass5a.wrap_Program        (Pass5a.sem_Program (Pass4.output_Syn_CGrammar output4)) Pass5a.Inh_Program { Pass5a.options_Inh_Program  = flags', Pass5a.textBlockMap_Inh_Program = textBlockMap }+          output5b  = Pass5b.wrap_Program        (Pass5b.sem_Program (Pass4.output_Syn_CGrammar output4)) Pass5b.Inh_Program  {Pass5b.options_Inh_Program  = flags', Pass5b.pragmaBlocks_Inh_Program = pragmaBlocksTxt, Pass5b.importBlocks_Inh_Program = importBlocksTxt, Pass5b.textBlocks_Inh_Program = textBlocksDoc, Pass5b.textBlockMap_Inh_Program = textBlockMap, Pass5b.mainBlocksDoc_Inh_Program = mainBlocksDoc, Pass5b.optionsLine_Inh_Program = optionsLine, Pass5b.mainFile_Inh_Program = mainFile, Pass5b.moduleHeader_Inh_Program = mkModuleHeader $ Pass1.moduleDecl_Syn_AG output1, Pass5b.mainName_Inh_Program = mkMainName mainName $ Pass1.moduleDecl_Syn_AG output1}+          output6   = PrErr.wrap_Errors          (PrErr.sem_Errors                       errorsToReport) PrErr.Inh_Errors   {PrErr.options_Inh_Errors   = flags', PrErr.dups_Inh_Errors = [] }++          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+          +          mirage = PassM.mirage_Syn_Grammar outputM++          parseErrorList   = map message2error (parseErrors)+          mainErrors       = toList ( Pass1.errors_Syn_AG       output1+                               Seq.>< Pass1a.errors_Syn_Grammar output1a+                               Seq.>< Pass2.errors_Syn_Grammar  output2+                               Seq.>< Pass2a.errors_Syn_Grammar output2a)+          furtherErrors    = if loag flags'+                             then toList (Pass3b.errors_Syn_Grammar output3b)+                             else if kennedyWarren flags'+                                  then let errs3a = Pass3a.errors_Syn_Grammar output3a+                                       in if Seq.null errs3a+                                          then if ocaml flags'+                                               then toList ( Pass4c.errors_Syn_ExecutionPlan output4c )+                                               else if clean flags'+                                                    then toList ( Pass4d.errors_Syn_ExecutionPlan output4d )+                                                    else toList ( Pass4b.errors_Syn_ExecutionPlan output4b )+                                          else toList errs3a+                                  else toList ( Pass3.errors_Syn_Grammar  output3+                                                Seq.>< Pass4.errors_Syn_CGrammar output4)++          errorList        = if null parseErrorList+                             then mainErrors+                                  ++ if null (filter (PrErr.isError flags') mainErrors)+                                     then furtherErrors+                                     else []+                             else [head parseErrorList]++          fatalErrorList = filter (PrErr.isError flags') errorList++          allErrors = if wignore flags'+                      then fatalErrorList+                      else errorsToFront flags' errorList++          errorsToReport = take (wmaxerrs flags') allErrors++          errorsToStopOn = if werrors flags'+                            then errorList+                            else fatalErrorList++          blocks1                    = (Pass1.blocks_Syn_AG output1) {-SM `Map.unionWith (++)` (Pass3.blocks_Syn_Grammar output3)-}+          (pragmaBlocks, blocks2)    = Map.partitionWithKey (\(k, at) _->k==BlockPragma && at == Nothing) blocks1+          (importBlocks, textBlocks) = Map.partitionWithKey (\(k, at) _->k==BlockImport && at == Nothing) blocks2++          importBlocksTxt = vlist_sep "" . map addLocationPragma . concat . Map.elems $ importBlocks+          textBlocksDoc   = vlist_sep "" . map addLocationPragma . Map.findWithDefault [] (BlockOther, Nothing) $ textBlocks+          mainBlocksDoc   = vlist_sep "" . map addLocationPragma . Map.findWithDefault [] (BlockMain, Nothing) $ textBlocks+          dataBlocksDoc   = vlist_sep "" . map addLocationPragma . Map.findWithDefault [] (BlockData, Nothing) $ textBlocks+          recBlocksDoc    = vlist_sep "" . map addLocationPragma . Map.findWithDefault [] (BlockRec, Nothing) $ textBlocks+          pragmaBlocksTxt = unlines . concat . map fst  . concat . Map.elems $ pragmaBlocks+          textBlockMap    = Map.map (vlist_sep "" . map addLocationPragma) . Map.filterWithKey (\(_, at) _ -> at /= Nothing) $ textBlocks++          outputfile = if null output then outputFile flags' inputfile else output+          mainFile | null output = outputFile flags' inputfile+                   | otherwise   = output+          mainName = dropExtension $ takeFileName inputfile++          addLocationPragma :: ([String], Pos) -> PP_Doc+          addLocationPragma (strs, p)+            | genLinePragmas flags' =+                ppLinePragma flags' (line p) (file p) >-< vlist (map pp strs)+                >-< ppWithLineNr (\l -> ppLinePragma flags' (l+1) outputfile)+            | otherwise = vlist (map pp strs)++          optionsGHC = option (unbox flags') "-fglasgow-exts" ++ option (bangpats flags') "-XBangPatterns"+          option True s  = [s]+          option False _ = []+          optionsLine | null optionsGHC = ""+                      | otherwise       = "{-# OPTIONS_GHC " ++ unwords optionsGHC ++ " #-}"++          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"++      (outAgi, ext) <-  --marcos+                     if genAspectAG flags'+                     then parseAGI flags (searchPath flags) (agiFile input)+                     else return (undefined, undefined)++      let ext'      = fmap remAgi ext+          outAgi1   = Pass1.wrap_AG             (Pass1.sem_AG               outAgi ) Pass1.Inh_AG             {Pass1.options_Inh_AG       = flags'}+          agi       = Pass1.agi_Syn_AG          outAgi1+          aspectAG  = AspectAGDump.wrap_Grammar (AspectAGDump.sem_Grammar grammar2  ) AspectAGDump.Inh_Grammar { AspectAGDump.options_Inh_Grammar  = flags'+                                                                                                               , AspectAGDump.agi_Inh_Grammar      = agi+                                                                                                               , AspectAGDump.ext_Inh_Grammar      = ext' } --marcos++      printStr . formatErrors $ PrErr.pp_Syn_Errors output6++      if additionalErrors > 0+       then printStr $ "\nPlus " ++ show additionalErrors ++ " more error" ++ pluralS additionalErrors +++                     if additionalWarnings > 0+                     then " and " ++ show additionalWarnings ++ " more warning" ++ pluralS additionalWarnings ++ ".\n"+                     else ".\n"+       else if additionalWarnings > 0+            then printStr $ "\nPlus " ++ show additionalWarnings ++ " more warning" ++ pluralS additionalWarnings ++ ".\n"+            else return ()++      -- show fake dependencies when found with --aoag+      when (aoag flags' && verbose flags' && +            isJust (Pass3b.ads_Syn_Grammar output3b)) $+        putStrLn (show $ fromJust $ Pass3b.ads_Syn_Grammar output3b)++      if not (null errorsToStopOn)  -- note: this may already run quite a part of the compilation...+       then failWith 1+       else+        do+           if genvisage flags'+            then writeFile (outputfile++".visage") (writeATerm aterm)+            else return ()++           if genmirage flags'+            then ByteString.writeFile (outputfile++".mirage") (encode mirage)+            else return ()++           if genAttributeList flags'+            then writeAttributeList (outputfile++".attrs") (Pass1a.allAttributes_Syn_Grammar output1a)+            else return ()++           if sepSemMods flags'+            then do -- alternative module gen+                    if loag flags || kennedyWarren flags'+                      then if ocaml flags' +                           then error "sepsemmods is not implemented for the ocaml output generation"+                           else Pass4b.genIO_Syn_ExecutionPlan output4b+                      else Pass5.genIO_Syn_Program output5+                    if not (null errorsToStopOn) then failWith 1 else return ()+            else do -- conventional module gen+                    let doc+                         | visitorsOutput flags'+                            = vlist [ pp_braces importBlocksTxt+                                    , pp_braces textBlocksDoc+                                    , vlist $ Pass4a.output_Syn_CGrammar output4a+                                    ]+                         -- marcos AspectAG gen+                         | genAspectAG flags'+                            = vlist [ AspectAGDump.pragmaAspectAG+                                    , pp optionsLine+                                    , pp pragmaBlocksTxt+                                    , pp $ take 70 ("-- UUAGC2AspectAG " ++ drop 50 banner ++ " (" ++ input) ++ ")"+                                    , pp $ if isNothing $ Pass1.moduleDecl_Syn_AG output1+                                           then moduleHeader flags' mainName ext'+                                           else mkModuleHeader (Pass1.moduleDecl_Syn_AG output1) mainName "" "" False+                                    , pp importBlocksTxt+                                    , AspectAGDump.imp_Syn_Grammar aspectAG+                                    , pp "\n\n{-- AspectAG Code --}\n\n"+                                    , AspectAGDump.pp_Syn_Grammar aspectAG+                                    , dataBlocksDoc+                                    , mainBlocksDoc+                                    , textBlocksDoc+                                    , if dumpgrammar flags'+                                      then vlist [ pp "{- Dump of AGI"+                                                 , pp (show agi)+                                                 , pp "-}"+                                                 , pp "{- Dump of grammar with default rules"+                                                 , GrammarDump.pp_Syn_Grammar dump2+                                                 , pp "-}"+                                                 ]+                                      else empty]+                         | loag flags' || kennedyWarren flags'+                            = if ocaml flags'+                              then vlist+                                    [ text "(* generated by UUAG from" >#< mainFile >#< "*)"+                                    , pp pragmaBlocksTxt+                                    , text "(* module imports *)"+                                    , pp importBlocksTxt+                                    , Pass4c.modules_Syn_ExecutionPlan output4c+                                    , text ""+                                    , text "(* generated data types *)"+                                    , text "module Data__ = struct"+                                    , indent 2 $ vlist+                                      [ text "type __generated_by_uuagc__ = Generated_by_uuagc__"+                                      , Pass4c.datas_Syn_ExecutionPlan output4c+                                      ]+                                    , text "end"+                                    , text "open Data__"+                                    , text ""+                                    , text "(* embedded data types *)"+                                    , dataBlocksDoc+                                    , text ""+                                    , text "(* embedded utilty functions *)"+                                    , textBlocksDoc+                                    , text "(* generated evaluationcode *)"+                                    , text "module Code__ = struct"+                                    , indent 2 $ vlist+                                      [ text "let rec __generated_by_uuagc__ = Generated_by_uuagc__"+                                      , Pass4c.code_Syn_ExecutionPlan output4c+                                      , recBlocksDoc+                                      ]+                                    , text "end"+                                    , text "open Code__"+                                    , text ""+                                    , text "(* main code *)"+                                    , mainBlocksDoc+                                    ]+                              else if clean flags'+                                   then vlist+                                    [ pp $ if isNothing $ Pass1.moduleDecl_Syn_AG output1+                                           then Pass4d.cleanIclModuleHeader flags' mainName+                                           else Pass4d.mkIclModuleHeader (Pass1.moduleDecl_Syn_AG output1) mainName "" "" False+                                    , pp importBlocksTxt+                                    , dataBlocksDoc+                                    , vlist [ pp $ "from Control.Monad.Identity import :: Identity"+                                            , pp $ "import qualified Control.Monad.Identity as Control.Monad.Identity"+                                            , pp $ "import Control.Monad.Identity"+                                            , pp $ "from Control.Applicative import lift"+                                            , pp $ "from Control.Monad import class Monad (..)"+                                            ]+                                    , mainBlocksDoc+                                    , textBlocksDoc+                                    , recBlocksDoc+                                    --, pp $ "{-"+                                    --, Pass3a.depgraphs_Syn_Grammar output3a+                                    --, Pass3a.visitgraph_Syn_Grammar output3a+                                    --, pp $ "-}"+                                    , Pass4d.output_Syn_ExecutionPlan output4d+                                    , if dumpgrammar flags'+                                      then vlist [ pp "/* Dump of grammar with default rules"+                                                 , GrammarDump.pp_Syn_Grammar dump2+                                                 , pp "*/"+                                                 ]+                                      else empty]++                                   else vlist+                                    [ Pass4b.warrenFlagsPP flags'+                                    , pp pragmaBlocksTxt+                                    , pp $ if isNothing $ Pass1.moduleDecl_Syn_AG output1+                                           then moduleHeader flags' mainName Nothing+                                           else mkModuleHeader (Pass1.moduleDecl_Syn_AG output1) mainName "" "" False+                                    , pp importBlocksTxt+                                    , ( if tupleAsDummyToken flags'+                                          then empty+                                          else pp "import GHC.Prim"  -- need it to pass State#+                                      )+                                    , if parallelInvoke flags'+                                      then vlist [ pp $ "import qualified System.IO.Unsafe(unsafePerformIO)"+                                                 , pp $ "import System.IO(IO)"+                                                 , pp $ "import Control.Concurrent(newEmptyMVar,forkIO,putMVar,takeMVar)"]+                                      else vlist [ pp $ "import Control.Monad.Identity (Identity)"+                                                 , pp $ "import qualified Control.Monad.Identity" ]+                                    , dataBlocksDoc+                                    , mainBlocksDoc+                                    , textBlocksDoc+                                    , recBlocksDoc+                                    --, pp $ "{-"+                                    --, Pass3a.depgraphs_Syn_Grammar output3a+                                    --, Pass3a.visitgraph_Syn_Grammar output3a+                                    --, pp $ "-}"+                                    , Pass4b.output_Syn_ExecutionPlan output4b+                                    , if dumpgrammar flags'+                                      then vlist [ pp "{- Dump of grammar with default rules"+                                                 , GrammarDump.pp_Syn_Grammar dump2+                                                 , pp "-}"+                                                 ]+                                      else empty]+                         | otherwise+                            = vlist [ vlist ( if (ocaml flags' || clean flags')+                                              then []+                                              else [ pp optionsLine+                                                   , pp pragmaBlocksTxt+                                                   , pp $ take 70 ("-- UUAGC " ++ drop 50 banner ++ " (" ++ input) ++ ")"+                                                   , pp $ if isNothing $ Pass1.moduleDecl_Syn_AG output1+                                                          then moduleHeader flags' mainName Nothing+                                                          else mkModuleHeader (Pass1.moduleDecl_Syn_AG output1) mainName "" "" False+                                                   ]+                                            )+                                    , pp importBlocksTxt+                                    , dataBlocksDoc+                                    , mainBlocksDoc+                                    , textBlocksDoc+                                    , vlist $ if (ocaml flags')+                                                then Pass5a.output_Syn_Program output5a+                                                else if (clean flags')+                                                       then Pass5b.output_Syn_Program  output5b+                                                       else Pass5.output_Syn_Program  output5+                                    , if dumpgrammar flags'+                                      then vlist [ pp "{- Dump of grammar without default rules"+                                                 , GrammarDump.pp_Syn_Grammar dump1+                                                 , pp "-}"+                                                 , pp "{- Dump of grammar with default rules"+                                                 , GrammarDump.pp_Syn_Grammar dump2+                                                 , pp "-}"+                                                 ]+                                      else empty+                                    , if dumpcgrammar flags'+                                      then vlist [ pp "{- Dump of cgrammar"+                                                 , CGrammarDump.pp_Syn_CGrammar dump3+                                                 , pp "-}"+                                                 ]+                                      else empty+                                    ]++                    let docTxt = disp doc 50000 ""+                    writeFile outputfile docTxt++                    -- HACK: write Clean DCL file+                    if clean flags'+                      then do let dclDoc =+                                    vlist+                                    [ pp $ if isNothing $ Pass1.moduleDecl_Syn_AG output1+                                           then Pass4d.cleanDclModuleHeader flags' mainName Nothing -- TODO: What should be there instead of Nothing?+                                           else Pass4d.mkDclModuleHeader (Pass1.moduleDecl_Syn_AG output1) mainName "" "" False+                                    , vlist [ pp $ "from Control.Monad.Identity import :: Identity"+                                            , pp $ "import qualified Control.Monad.Identity as Control.Monad.Identity"+                                            , pp $ "import Control.Monad.Identity"+                                            , pp $ "from Control.Applicative import lift"+                                            , pp $ "from Control.Monad import class Monad (..)"+                                            ]+                                    , Pass4d.output_dcl_Syn_ExecutionPlan output4d+                                    ]+                              writeFile (replaceExtension outputfile ".dcl") (disp dclDoc 50000 "")+                      else return ()++                    -- HACK: write statistics+                    let nAuto = Pass3.nAutoRules_Syn_Grammar output3+                        nExpl = Pass3.nExplicitRules_Syn_Grammar output3+                        line' = inputfile ++ "," ++ show nAuto ++ "," ++ show nExpl ++ "\r\n"+                    case statsFile flags' of+                      Nothing -> return ()+                      Just f  -> appendFile f line'+                    if not (null errorsToStopOn) then failWith 1 else return ()++++formatErrors :: PP_Doc -> String+formatErrors doc = disp doc 5000 ""+++message2error :: Message Token Pos -> Error+message2error (Msg expect pos action) = ParserError pos (show expect) actionString+ where actionString+        =  case action+           of Insert s -> "inserting: " ++ show s++              Delete s -> "deleting: "  ++ show s++              Other ms -> ms++errorsToFront :: Options -> [Error] -> [Error]+errorsToFront flags mesgs = errs ++ warnings+  where (errs,warnings) = partition (PrErr.isError flags) mesgs++moduleHeader :: Options -> String -> Maybe String -> String+moduleHeader flags input export+ = case moduleName flags+   of Name nm -> genMod nm+      Default -> genMod (defaultModuleName input)+      NoName  -> ""+   where genMod x = "module " ++ x ++ genExp export x ++ " where"+         genExp Nothing _ = ""+         genExp (Just e) x = "(module " ++ x ++ ", module " ++ e ++ ")"++--marcos+agiFile :: String -> String+agiFile name = replaceExtension name "agi"++remAgi :: String -> String+remAgi = dropExtension++outputFile :: Options -> String -> String+outputFile opts name+  | ocaml opts = replaceExtension name "ml"+  | clean opts = replaceExtension name "icl"+  | otherwise  = replaceExtension name "hs"++defaultModuleName :: String -> String+defaultModuleName = dropExtension++mkMainName :: String -> Maybe (String, String,String) -> String+mkMainName defaultName Nothing+  = defaultName+mkMainName _ (Just (name, _, _))+  = name++mkModuleHeader :: Maybe (String,String,String) -> String -> String -> String -> Bool -> String+mkModuleHeader Nothing defaultName suffix _ _+  = "module " ++ defaultName ++ suffix ++ " where"+mkModuleHeader (Just (name, exports, imports)) _ suffix addExports replaceExports+  = "module " ++ name ++ suffix ++ ex ++ " where\n" ++ imports ++ "\n"+  where+    ex  = if null exports || (replaceExports && null addExports)+          then ""+          else if null addExports+               then "(" ++ exports ++ ")"+               else if replaceExports+                    then "(" ++ addExports ++ ")"+                    else "(" ++ exports ++ "," ++ addExports ++ ")"++reportDeps :: Options -> [String] -> IO ()+reportDeps flags files+  = do deps <- getDeps flags files+       mapM_ putStrLn deps++getDeps :: Options -> [String] -> IO [String]+getDeps flags files+  = do results <- mapM (depsAG flags (searchPath flags)) files+       let (fs, mesgs) = foldr comb ([],[]) results+       let errs = take (min 1 (wmaxerrs flags)) (map message2error mesgs)+       let ppErrs = PrErr.wrap_Errors (PrErr.sem_Errors errs) PrErr.Inh_Errors {PrErr.options_Inh_Errors = flags, PrErr.dups_Inh_Errors = []}+       if null errs+        then return fs+        else do hPutStrLn stderr . formatErrors $ PrErr.pp_Syn_Errors ppErrs+                failWithCode flags 1+                return []+  where+    comb :: ([a],[b]) -> ([a], [b]) -> ([a], [b])+    comb (fs, mesgs) (fsr, mesgsr)+      = (fs ++ fsr, mesgs ++ mesgsr)+++writeAttributeList :: String -> AttrMap -> IO ()+writeAttributeList fileP mp+  = writeFile fileP 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 fileP -> do s <- readFile fileP+                       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++
src/CommonTypes.hs view
@@ -1,287 +1,287 @@-module CommonTypes (module Options, module CommonTypes) where
-
-import Options
-import UU.Scanner.Position(Pos)
-import qualified Data.Map as Map
-import Data.Map(Map)
-import Data.Set(Set)
-import qualified Data.Set as Set
-import Data.Monoid(mappend,Monoid)
-import Data.Char
-import Pretty
-
-type Blocks = Map BlockInfo [([String], Pos)]
-type BlockInfo = (BlockKind, Maybe NontermIdent)
-data BlockKind
-  = BlockImport
-  | BlockPragma
-  | BlockMain
-  | BlockData
-  | BlockRec
-  | BlockOther
-  deriving (Eq, Ord, Show)
-
-instance PP Identifier where
-  pp = text . getName
-
-data Type = Haskell String
-          | NT Identifier [String]
-               Bool  -- True: deforested nonterminal, False: nonterminal type
-          | Self     -- reference to the enclosing nonterminal type
-          deriving (Eq)
-
-data ComplexType = List Type
-                 | Tuple [(Identifier, Type)]
-                 | Maybe Type
-                 | Either Type Type
-                 | Map Type Type
-                 | IntMap Type
-                 | OrdSet Type
-                 | IntSet
-
-instance Show ComplexType where
-  show (List  t )     = "[" ++ show t ++ "]"
-  show (Tuple ts)     = "(" ++ showList [ show n ++ ": " ++ show t | (n,t) <- ts ] "" ++ ")"
-  show (Maybe t )     = "Maybe " ++ show t
-  show (Either t1 t2) = "Either " ++ show t1 ++ " " ++ show t2
-  show (Map t1 t2)    = "Map " ++ show t1 ++ " " ++ show t2
-  show (IntMap t1)    = "IntMap " ++ show t1
-  show (OrdSet t1)    = "Set" ++ show t1
-  show IntSet         = "IntSet"
-
-instance Show Type where
-  show = typeToHaskellString Nothing []
-
-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 UniqueMap   = Map NontermIdent (Map ConstructorIdent (Map Identifier Identifier))
-type Derivings   = Map NontermIdent (Set Identifier)
-type ClassContext = [(Identifier, [String])]
-type ContextMap  = Map NontermIdent ClassContext
-type QuantMap    = Map NontermIdent [String]
-type Strings     = [String]
-type ConstructorIdent = Identifier
-type AttrOrderMap = Map NontermIdent (Map ConstructorIdent (Set Dependency))
-type VisitIdentifier = Int
-type StateIdentifier = Int
-data Dependency = Dependency Occurrence Occurrence deriving (Eq,Ord,Show)
-data Occurrence
-  = OccAttr Identifier Identifier
-  | OccRule Identifier
-  deriving (Eq,Ord,Show)
-data ConstructorType
-  = DataConstructor
-  | RecordConstructor
-  deriving (Eq,Ord,Show)
-
-type AttrEnv = ( [Identifier]
-               , [(Identifier,Identifier)]
-               )
-
-nullIdent, _LHS, _SELF, _LOC, _INST, _INST', _FIELD, _FIRST, _LAST :: Identifier
-nullIdent = identifier ""
-_LHS   = identifier "lhs"
-_SELF  = identifier "SELF"
-_LOC   = identifier "loc"
-_INST  = identifier "inst"
-_INST' = identifier "inst'"
-_FIELD = identifier "field"
-_FIRST = identifier "first__"
-_LAST  = identifier "last__"
-
-idLateBindingAttr :: Identifier
-idLateBindingAttr = identifier "lateSemDict"
-
-lateBindingTypeNm :: String -> String
-lateBindingTypeNm modNm = "Late_" ++ modNm ++ "_"
-
-lateBindingFieldNm :: String -> String
-lateBindingFieldNm modNm = "late_" ++ modNm ++ "_"
-
-lateBindingType :: String -> Type
-lateBindingType modNm = Haskell (lateBindingTypeNm modNm)
-
-lateSemNtLabel :: NontermIdent -> String
-lateSemNtLabel nt = "mk_" ++ getName nt
-
-lateSemConLabel :: NontermIdent -> ConstructorIdent -> String
-lateSemConLabel nt con = "mk_" ++ getName nt ++ "_" ++ getName con
-
-sdtype :: NontermIdent -> String
-sdtype nt = "T_"++getName nt
-
-mkNtType :: Identifier -> [String] -> Type
-mkNtType nt args
-  | take 2 (getName nt) == "T_" = let nt' = Ident (drop 2 (getName nt)) (getPos nt)
-                                  in  NT nt' args True
-  | otherwise                   = NT nt args False
-
-cataname ::  String -> Identifier -> String
-cataname pre name = pre++getName name
-
-conname :: Bool -> NontermIdent -> ConstructorIdent -> String
-conname ren nt con | ren =  capitalize (getName nt) ++ "_" ++ getName con
-                   | otherwise = getName con
-
-capitalize        :: String -> String
-capitalize []     = []
-capitalize (c:cs) = toUpper c : cs
-
-semname  ::  String -> NontermIdent -> ConstructorIdent -> String
-semname pre nt con =  pre ++ (getName nt ++ "_" ++ getName con)
-
-recordFieldname :: NontermIdent -> ConstructorIdent -> Identifier -> String
-recordFieldname nt con nm = getName nm ++ "_" ++ getName nt ++ "_" ++ getName con
-
-lhsname :: Options -> Bool -> Identifier -> String
-lhsname opts isIn = attrname opts isIn _LHS
-
-attrname :: Options -> Bool -> Identifier -> Identifier -> String
-attrname opts isIn field attr
-  | field == _LOC   = locname opts attr
-  | field == _INST  = instname attr
-  | field == _INST' = inst'name attr
-  | field == _FIELD = fieldname attr
-  | otherwise       = let direction | isIn      = "I"
-                                    | otherwise = "O"
-                          pref = if clean opts then 'a' else '_'
-                      in  pref : getName field ++ direction ++ getName attr
-
-locname :: Options -> Identifier -> String
-locname opts v   = (if clean opts then 'l' else '_') : getName v
-
-instname, inst'name, fieldname :: Identifier -> String
-instname v  = getName v ++ "_val_"
-inst'name v = getName v ++ "_inst_"
-fieldname v =  getName v++"_"
-
-typeToAGString :: Type -> String
-typeToAGString tp
-  = case tp of
-      Haskell t     -> t
-      NT nt tps for -> formatNonterminalToHaskell for (getName nt) (map (\s -> "{" ++ s ++ "}") tps)
-      Self          -> error "Self type is not allowed here."
-
-removeDeforested :: Type -> Type
-removeDeforested (NT nt args _) = NT nt args False
-removeDeforested tp             = tp
-
-forceDeforested :: Type -> Type
-forceDeforested (NT nt args _) = NT nt args True
-forceDeforested tp             = tp
-
-typeToHaskellString :: Maybe NontermIdent -> [String] -> Type -> String
-typeToHaskellString mbNt params tp
-  = case tp of
-      Haskell t -> filter (/= '@') t -- Apparently haskell types can contain @ to refer to
-                                     -- a type parameter, removing @ makes it backwards compatible
-      NT nt tps for | nt == _SELF -> formatNonterminalToHaskell for (maybe "?SELF?" getName mbNt) params
-                    | otherwise   -> formatNonterminalToHaskell for (getName nt) tps
-      Self -> maybe "?SELF?" getName mbNt
-
-formatNonterminalToHaskell :: Bool -> String -> [String] -> String
-formatNonterminalToHaskell for nt tps
-  = unwords ((pref ++ nt) : tps)
-  where pref | for       = "T_"
-             | otherwise = ""
-
-ind :: String -> String
-ind s = replicate 3 ' ' ++ s
-
-_NOCASE :: Identifier
-_NOCASE = identifier "nocase"
-
-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
-
-isSELFNonterminal :: Type -> Bool
--- isSELFNonterminal (NT nt _ _) | nt == _SELF = True
-isSELFNonterminal Self                      = True
-isSELFNonterminal _                         = False
-
-extractNonterminal :: Type -> NontermIdent
-extractNonterminal (NT n _ _) = n
-extractNonterminal _          = error "Must be NT"
-
-nontermArgs :: Type -> [String]
-nontermArgs tp
-  = case tp of
-      NT _ args _ -> args
-      _           -> []
-
-deforestedNt :: Identifier -> Maybe Identifier
-deforestedNt nm
-  | take 2 (getName nm) == "T_" = Just (Ident (drop 2 (getName nm)) (getPos nm))
-  | otherwise = Nothing
-
-data StateCtx
-  = NoneVis
-  | OneVis !Int
-  | ManyVis
-  deriving (Eq, Show, Ord)
-
-data ChildKind
-  = ChildSyntax        -- This child is defined by syntax
-  | ChildAttr          -- This child is defined by an attribute
-  | ChildReplace Type  -- This child replaces a child with type Type
-  deriving (Eq, Show)
-
--- Given a map that represents a relation, returns the transitive closure of this relation
-closeMap :: Ord a => Map a (Set a) -> Map a (Set a)
-closeMap mp0 = close (Map.keysSet mp0) mp0 where
-  rev = revDeps mp0
-  close todo mp0' = case Set.minView todo of
-    Nothing         -> mp0'
-    Just (k, todo1) -> let find x = Map.findWithDefault Set.empty x mp0'
-                           vals0  = find k
-                           valsL  = Set.toList vals0
-                           vals1  = foldr Set.union vals0 $ map find valsL
-                       in if Set.size vals0 == Set.size vals1
-                          then close todo1 mp0'  -- note: monotonically increasing set
-                          else let mp1   = Map.insert k vals1 mp0'
-                                   refs  = Map.findWithDefault Set.empty k rev
-                                   todo2 = Set.union refs todo1
-                               in close todo2 mp1
-
-revDeps :: Ord a => Map a (Set a) -> Map a (Set a)
-revDeps mp = Map.fromListWith Set.union [ (a,Set.singleton k) | (k,s) <- Map.assocs mp, a <- Set.toList s ]
-
-data HigherOrderInfo = HigherOrderInfo
-  { hoNtDeps     :: Set NontermIdent
-  , hoNtRevDeps  :: Set NontermIdent
-  , hoAcyclic    :: Bool
-  }
-
-data VisitKind
-  = VisitPure Bool  -- ordered or not
-  | VisitMonadic
-  deriving (Eq,Ord)
-
-isLazyKind :: VisitKind -> Bool
-isLazyKind (VisitPure False) = True
-isLazyKind _                 = False
-
-instance Show VisitKind where
-  show (VisitPure False) = "Lazy"
-  show (VisitPure True)  = "Ordered"
-  show VisitMonadic      = "Monadic"
-
-unionWithMappend :: (Monoid a, Ord k) => Map k a -> Map k a -> Map k a
-unionWithMappend = Map.unionWith mappend
-
-
-data FormatMode
-  = FormatDo
-  | FormatLetDecl
-  | FormatLetLine
-  deriving (Eq, Ord, Show)
+module CommonTypes (module Options, module CommonTypes) where++import Options+import UU.Scanner.Position(Pos)+import qualified Data.Map as Map+import Data.Map(Map)+import Data.Set(Set)+import qualified Data.Set as Set+import Data.Monoid(mappend,Monoid)+import Data.Char+import Pretty++type Blocks = Map BlockInfo [([String], Pos)]+type BlockInfo = (BlockKind, Maybe NontermIdent)+data BlockKind+  = BlockImport+  | BlockPragma+  | BlockMain+  | BlockData+  | BlockRec+  | BlockOther+  deriving (Eq, Ord, Show)++instance PP Identifier where+  pp = text . getName++data Type = Haskell String+          | NT Identifier [String]+               Bool  -- True: deforested nonterminal, False: nonterminal type+          | Self     -- reference to the enclosing nonterminal type+          deriving (Eq)++data ComplexType = List Type+                 | Tuple [(Identifier, Type)]+                 | Maybe Type+                 | Either Type Type+                 | Map Type Type+                 | IntMap Type+                 | OrdSet Type+                 | IntSet++instance Show ComplexType where+  show (List  t )     = "[" ++ show t ++ "]"+  show (Tuple ts)     = "(" ++ showList [ show n ++ ": " ++ show t | (n,t) <- ts ] "" ++ ")"+  show (Maybe t )     = "Maybe " ++ show t+  show (Either t1 t2) = "Either " ++ show t1 ++ " " ++ show t2+  show (Map t1 t2)    = "Map " ++ show t1 ++ " " ++ show t2+  show (IntMap t1)    = "IntMap " ++ show t1+  show (OrdSet t1)    = "Set" ++ show t1+  show IntSet         = "IntSet"++instance Show Type where+  show = typeToHaskellString Nothing []++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 UniqueMap   = Map NontermIdent (Map ConstructorIdent (Map Identifier Identifier))+type Derivings   = Map NontermIdent (Set Identifier)+type ClassContext = [(Identifier, [String])]+type ContextMap  = Map NontermIdent ClassContext+type QuantMap    = Map NontermIdent [String]+type Strings     = [String]+type ConstructorIdent = Identifier+type AttrOrderMap = Map NontermIdent (Map ConstructorIdent (Set Dependency))+type VisitIdentifier = Int+type StateIdentifier = Int+data Dependency = Dependency Occurrence Occurrence deriving (Eq,Ord,Show)+data Occurrence+  = OccAttr Identifier Identifier+  | OccRule Identifier+  deriving (Eq,Ord,Show)+data ConstructorType+  = DataConstructor+  | RecordConstructor+  deriving (Eq,Ord,Show)++type AttrEnv = ( [Identifier]+               , [(Identifier,Identifier)]+               )++nullIdent, _LHS, _SELF, _LOC, _INST, _INST', _FIELD, _FIRST, _LAST :: Identifier+nullIdent = identifier ""+_LHS   = identifier "lhs"+_SELF  = identifier "SELF"+_LOC   = identifier "loc"+_INST  = identifier "inst"+_INST' = identifier "inst'"+_FIELD = identifier "field"+_FIRST = identifier "first__"+_LAST  = identifier "last__"++idLateBindingAttr :: Identifier+idLateBindingAttr = identifier "lateSemDict"++lateBindingTypeNm :: String -> String+lateBindingTypeNm modNm = "Late_" ++ modNm ++ "_"++lateBindingFieldNm :: String -> String+lateBindingFieldNm modNm = "late_" ++ modNm ++ "_"++lateBindingType :: String -> Type+lateBindingType modNm = Haskell (lateBindingTypeNm modNm)++lateSemNtLabel :: NontermIdent -> String+lateSemNtLabel nt = "mk_" ++ getName nt++lateSemConLabel :: NontermIdent -> ConstructorIdent -> String+lateSemConLabel nt con = "mk_" ++ getName nt ++ "_" ++ getName con++sdtype :: NontermIdent -> String+sdtype nt = "T_"++getName nt++mkNtType :: Identifier -> [String] -> Type+mkNtType nt args+  | take 2 (getName nt) == "T_" = let nt' = Ident (drop 2 (getName nt)) (getPos nt)+                                  in  NT nt' args True+  | otherwise                   = NT nt args False++cataname ::  String -> Identifier -> String+cataname pre name = pre++getName name++conname :: Bool -> NontermIdent -> ConstructorIdent -> String+conname ren nt con | ren =  capitalize (getName nt) ++ "_" ++ getName con+                   | otherwise = getName con++capitalize        :: String -> String+capitalize []     = []+capitalize (c:cs) = toUpper c : cs++semname  ::  String -> NontermIdent -> ConstructorIdent -> String+semname pre nt con =  pre ++ (getName nt ++ "_" ++ getName con)++recordFieldname :: NontermIdent -> ConstructorIdent -> Identifier -> String+recordFieldname nt con nm = getName nm ++ "_" ++ getName nt ++ "_" ++ getName con++lhsname :: Options -> Bool -> Identifier -> String+lhsname opts isIn = attrname opts isIn _LHS++attrname :: Options -> Bool -> Identifier -> Identifier -> String+attrname opts isIn field attr+  | field == _LOC   = locname opts attr+  | field == _INST  = instname attr+  | field == _INST' = inst'name attr+  | field == _FIELD = fieldname attr+  | otherwise       = let direction | isIn      = "I"+                                    | otherwise = "O"+                          pref = if clean opts then 'a' else '_'+                      in  pref : getName field ++ direction ++ getName attr++locname :: Options -> Identifier -> String+locname opts v   = (if clean opts then 'l' else '_') : getName v++instname, inst'name, fieldname :: Identifier -> String+instname v  = getName v ++ "_val_"+inst'name v = getName v ++ "_inst_"+fieldname v =  getName v++"_"++typeToAGString :: Type -> String+typeToAGString tp+  = case tp of+      Haskell t     -> t+      NT nt tps for -> formatNonterminalToHaskell for (getName nt) (map (\s -> "{" ++ s ++ "}") tps)+      Self          -> error "Self type is not allowed here."++removeDeforested :: Type -> Type+removeDeforested (NT nt args _) = NT nt args False+removeDeforested tp             = tp++forceDeforested :: Type -> Type+forceDeforested (NT nt args _) = NT nt args True+forceDeforested tp             = tp++typeToHaskellString :: Maybe NontermIdent -> [String] -> Type -> String+typeToHaskellString mbNt params tp+  = case tp of+      Haskell t -> filter (/= '@') t -- Apparently haskell types can contain @ to refer to+                                     -- a type parameter, removing @ makes it backwards compatible+      NT nt tps for | nt == _SELF -> formatNonterminalToHaskell for (maybe "?SELF?" getName mbNt) params+                    | otherwise   -> formatNonterminalToHaskell for (getName nt) tps+      Self -> maybe "?SELF?" getName mbNt++formatNonterminalToHaskell :: Bool -> String -> [String] -> String+formatNonterminalToHaskell for nt tps+  = unwords ((pref ++ nt) : tps)+  where pref | for       = "T_"+             | otherwise = ""++ind :: String -> String+ind s = replicate 3 ' ' ++ s++_NOCASE :: Identifier+_NOCASE = identifier "nocase"++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++isSELFNonterminal :: Type -> Bool+-- isSELFNonterminal (NT nt _ _) | nt == _SELF = True+isSELFNonterminal Self                      = True+isSELFNonterminal _                         = False++extractNonterminal :: Type -> NontermIdent+extractNonterminal (NT n _ _) = n+extractNonterminal _          = error "Must be NT"++nontermArgs :: Type -> [String]+nontermArgs tp+  = case tp of+      NT _ args _ -> args+      _           -> []++deforestedNt :: Identifier -> Maybe Identifier+deforestedNt nm+  | take 2 (getName nm) == "T_" = Just (Ident (drop 2 (getName nm)) (getPos nm))+  | otherwise = Nothing++data StateCtx+  = NoneVis+  | OneVis !Int+  | ManyVis+  deriving (Eq, Show, Ord)++data ChildKind+  = ChildSyntax        -- This child is defined by syntax+  | ChildAttr          -- This child is defined by an attribute+  | ChildReplace Type  -- This child replaces a child with type Type+  deriving (Eq, Show)++-- Given a map that represents a relation, returns the transitive closure of this relation+closeMap :: Ord a => Map a (Set a) -> Map a (Set a)+closeMap mp0 = close (Map.keysSet mp0) mp0 where+  rev = revDeps mp0+  close todo mp0' = case Set.minView todo of+    Nothing         -> mp0'+    Just (k, todo1) -> let find x = Map.findWithDefault Set.empty x mp0'+                           vals0  = find k+                           valsL  = Set.toList vals0+                           vals1  = foldr Set.union vals0 $ map find valsL+                       in if Set.size vals0 == Set.size vals1+                          then close todo1 mp0'  -- note: monotonically increasing set+                          else let mp1   = Map.insert k vals1 mp0'+                                   refs  = Map.findWithDefault Set.empty k rev+                                   todo2 = Set.union refs todo1+                               in close todo2 mp1++revDeps :: Ord a => Map a (Set a) -> Map a (Set a)+revDeps mp = Map.fromListWith Set.union [ (a,Set.singleton k) | (k,s) <- Map.assocs mp, a <- Set.toList s ]++data HigherOrderInfo = HigherOrderInfo+  { hoNtDeps     :: Set NontermIdent+  , hoNtRevDeps  :: Set NontermIdent+  , hoAcyclic    :: Bool+  }++data VisitKind+  = VisitPure Bool  -- ordered or not+  | VisitMonadic+  deriving (Eq,Ord)++isLazyKind :: VisitKind -> Bool+isLazyKind (VisitPure False) = True+isLazyKind _                 = False++instance Show VisitKind where+  show (VisitPure False) = "Lazy"+  show (VisitPure True)  = "Ordered"+  show VisitMonadic      = "Monadic"++unionWithMappend :: (Monoid a, Ord k) => Map k a -> Map k a -> Map k a+unionWithMappend = Map.unionWith mappend+++data FormatMode+  = FormatDo+  | FormatLetDecl+  | FormatLetLine+  deriving (Eq, Ord, Show)
src/GrammarInfo.hs view
@@ -1,54 +1,54 @@-module GrammarInfo where
-
-import SequentialTypes
-import CodeSyntax
-import Data.Map(Map)
-import qualified Data.Map as Map
-import Data.Set(Set)
-import qualified Data.Set as Set
-import CommonTypes
-import Data.List(intersect,(\\))
-import Options
-
-type LMH = (Vertex,Vertex,Vertex)
-data Info = Info  {  tdpToTds    ::  Table Vertex
-                  ,  tdsToTdp    ::  Table [Vertex]
-                  ,  attrTable   ::  Table NTAttr
-                  ,  ruleTable   ::  Table CRule
-                  ,  lmh         ::  [LMH]
-                  ,  nonts       ::  [(NontermIdent,[ConstructorIdent])]
-                  ,  wraps       ::  Set NontermIdent
-                  }
-                  deriving Show
-
-instance Show CRule
- where show (CRule name _ _ nt con field childnt _ _ rhs _ _ _ uses _ _)
-         = "CRule " ++ show name ++ " nt: " ++ show nt ++ " con: " ++ show con ++ " field: " ++ show field
-         ++ " childnt: " ++ show childnt ++ " rhs: " ++ concat rhs ++ " uses: " ++ show [ attrname noOptions True fld nm | (fld,nm) <- Set.toList uses ]
-       show _ = error "Only CRule is supported"
-
-type CInterfaceMap = Map NontermIdent CInterface
-type CVisitsMap = Map NontermIdent (Map ConstructorIdent CVisits)
-
-data CycleStatus
-  = CycleFree     CInterfaceMap CVisitsMap
-  | LocalCycle    [Route]
-  | InstCycle     [Route]
-  | DirectCycle   [EdgeRoutes]
-  | InducedCycle  CInterfaceMap [EdgeRoutes]
-
-showsSegment :: CSegment -> [String]
-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 tps _) -> getName nt ++ " " ++ unwords tps; Haskell t' -> t'; Self -> error "Self type not supported.")
-         chnn     = inh' `intersect` syn'
-         inhn     = inh' \\ chnn
-         synn     = syn' \\ chnn
-         disp _ [] = []
-         disp name as =  (name ++ if length as == 1 then " attribute:" else " attributes:") :
-                         map (\(x,y) -> ind x ++ replicate ((20 - length x) `max` 0) ' ' ++ " : " ++ y) as
-     in  disp "inherited" inhn
-         ++ disp "chained" chnn
-         ++ disp "synthesized" synn
-
+module GrammarInfo where++import SequentialTypes+import CodeSyntax+import Data.Map(Map)+import qualified Data.Map as Map+import Data.Set(Set)+import qualified Data.Set as Set+import CommonTypes+import Data.List(intersect,(\\))+import Options++type LMH = (Vertex,Vertex,Vertex)+data Info = Info  {  tdpToTds    ::  Table Vertex+                  ,  tdsToTdp    ::  Table [Vertex]+                  ,  attrTable   ::  Table NTAttr+                  ,  ruleTable   ::  Table CRule+                  ,  lmh         ::  [LMH]+                  ,  nonts       ::  [(NontermIdent,[ConstructorIdent])]+                  ,  wraps       ::  Set NontermIdent+                  }+                  deriving Show++instance Show CRule+ where show (CRule name _ _ nt con field childnt _ _ rhs _ _ _ uses _ _)+         = "CRule " ++ show name ++ " nt: " ++ show nt ++ " con: " ++ show con ++ " field: " ++ show field+         ++ " childnt: " ++ show childnt ++ " rhs: " ++ concat rhs ++ " uses: " ++ show [ attrname noOptions True fld nm | (fld,nm) <- Set.toList uses ]+       show _ = error "Only CRule is supported"++type CInterfaceMap = Map NontermIdent CInterface+type CVisitsMap = Map NontermIdent (Map ConstructorIdent CVisits)++data CycleStatus+  = CycleFree     CInterfaceMap CVisitsMap+  | LocalCycle    [Route]+  | InstCycle     [Route]+  | DirectCycle   [EdgeRoutes]+  | InducedCycle  CInterfaceMap [EdgeRoutes]++showsSegment :: CSegment -> [String]+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 tps _) -> getName nt ++ " " ++ unwords tps; Haskell t' -> t'; Self -> error "Self type not supported.")+         chnn     = inh' `intersect` syn'+         inhn     = inh' \\ chnn+         synn     = syn' \\ chnn+         disp _ [] = []+         disp name as =  (name ++ if length as == 1 then " attribute:" else " attributes:") :+                         map (\(x,y) -> ind x ++ replicate ((20 - length x) `max` 0) ' ' ++ " : " ++ y) as+     in  disp "inherited" inhn+         ++ disp "chained" chnn+         ++ disp "synthesized" synn+
src/HsTokenScanner.hs view
@@ -1,194 +1,194 @@-
-module HsTokenScanner where
-import HsToken
-import UU.Scanner.Position
-import Data.List(sort)
-import UU.Util.BinaryTrees
-import CommonTypes
-import Data.Maybe
-import Data.Char
-
-isAGesc :: Char -> Bool
-isAGesc c = c == '@'
-
-lexTokens :: Options -> Pos -> String -> [HsToken]
-lexTokens = scanTokens keywordstxt keywordsops specialchars opchars
-  where keywordstxt   =  []
-        keywordsops   =  [".","=", ":=", ":","|","@"]
-        specialchars  =  ";()[],_{}`"
-        opchars       =  "!#$%&*+./<=>?@\\^|-~:"
-
-
-scanTokens :: [String] -> [String] -> String -> String -> Options -> Pos -> String -> [HsToken]
-scanTokens keywordstxt keywordsops specchars opchars opts pos input
-  = doScan pos input
-
- where
-   locatein :: Ord a => [a] -> a -> Bool
-   locatein es = isJust . btLocateIn compare (tab2tree (sort es))
-   iskw     = locatein keywordstxt
-   isop     = locatein keywordsops
-   isSymb   = locatein specchars
-   -- See http://stackoverflow.com/questions/10548170/what-characters-are-permitted-for-haskell-operators
-   isOpsym  c = locatein opchars c
-                -- For unicode operators
-                || (not (isAscii c) && (isSymbol c || isPunctuation c))
-
-   isIdStart c = isLower c || c == '_'
-
-   isIdChar c =  isAlphaNum c
-              || c == '\''
-              || c == '_'
-
-   scanIdent p s = let (name,rest) = span isIdChar s
-                   in (name,advc (length name) p,rest)
-
-   doScan _ []      = []
-   doScan p (c:s)   | isSpace c = let (sp,next) = span isSpace s
-                                 in  doScan (foldl (flip updPos)  p (c:sp)) next
-   doScan p (c:d:s) | isAGesc c && isIdStart d =
-                                 let (fld,p2,rest) = scanIdent (advc 2 p) s
-                                     field = d:fld
-                                 in case rest of
-                                      ('.':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 Nothing : doScan p3 rest2
-                                      _                 -> AGLocal (Ident field p) p Nothing : doScan p2 rest
-
-   doScan p ('/':'/':s) | clean opts  = doScan p (dropWhile (/= '\n') s)
-   doScan p ('/':'*':s) | clean opts  = advc' 2 p (lexCleanNest doScan) s   -- }
-   doScan p ('-':'-':s)  = doScan p (dropWhile (/= '\n') s)
-   doScan p ('{':'-':s)  = advc' 2 p (lexNest doScan) s   -- }
-   doScan p ('"':ss)
-     = let (s,swidth,rest) = scanString ss
-       in if null rest || head rest /= '"'
-             then Err "Unterminated string literal" p : advc' swidth p doScan rest
-             else StrToken s p : advc' (swidth+2) p doScan (tail rest)
-
-   doScan p ('\'':ss)
-     | clean opts = let (str,nswidth,rest) = scanQualName ss
-                    in  HsToken ('\'' : str ++ "'") p : advc' (nswidth + 2) p doScan (tail rest)
-     | otherwise
-     = let (mc,cwidth,rest) = scanChar ss
-       in case mc of
-            Nothing -> Err "Error in character literal" p : advc' cwidth p doScan rest
-            Just c  -> if null rest || head rest /= '\''
-                          then Err "Unterminated character literal" p : advc' (cwidth+1) p doScan rest
-                          else CharToken  [c] p : advc' (cwidth+2) p doScan (tail rest)
-   doScan p cs@(c:s)
-
-     | isIdStart c || isUpper c
-         = let (name', p', s')    = scanIdent (advc 1 p) s
-               name               = c:name'
-               tok                = if iskw name
-                                    then HsToken name p               -- keyword
-                                    else if null name' && isSymb c
-                                    then HsToken [c] p                -- '_'
-                                    else HsToken name p               -- varid / conid
-           in tok : doScan p' s'
-     | isOpsym c = let (name, s') = span isOpsym cs
-                       tok | isop name = HsToken name p
-                           | otherwise = HsToken name p
-                   in tok : doScan (foldl (flip updPos)  p name)  s'
-     | isDigit c = let (base,digs,width,s') = getNumber cs
-                       number = case base of
-                          8  -> "0o"++digs
-                          10 -> digs
-                          16 -> "0x"++digs
-                          _  -> error $ "Base " ++ show base ++ " is not supported."
-                   in  HsToken number p : advc' width p doScan s'
-     | isSymb c = HsToken [c] p : advc' 1 p doScan s
-     | otherwise = Err ("Unexpected character " ++ show c) p : updPos'  c p doScan s
-
-lexNest :: (Pos -> String -> [HsToken]) -> Pos -> String -> [HsToken]
-lexNest cont pos inp = lexNest' cont pos inp
- where lexNest' c p ('{':'-':s) = lexNest' (lexNest' c) (advc 2 p) s
-       lexNest' c p ('-':'}':s) = c (advc 2 p) s
-       lexNest' c p (x:s)       = lexNest' c (updPos  x p) s
-       lexNest' _ _ []          = [Err "Unterminated nested comment" pos]
-
-lexCleanNest :: (Pos -> String -> [HsToken]) -> Pos -> String -> [HsToken]
-lexCleanNest cont pos inp = lexNest' cont pos inp
- where lexNest' c p ('/':'*':s) = lexNest' (lexNest' c) (advc 2 p) s
-       lexNest' c p ('*':'/':s) = c (advc 2 p) s
-       lexNest' c p (x:s)       = lexNest' c (updPos  x p) s
-       lexNest' _ _ []          = [Err "Unterminated nested comment" pos]
-
-scanString :: String -> (String, Int, String)
-scanString []            = ("",0,[])
-scanString ('\\':'&':xs) = let (str,w,r) = scanString xs
-                           in (str,w+2,r)
-scanString ('\'':xs)     = let (str,w,r) = scanString xs
-                           in ('\'': str,w+1,r)
-scanString xs = let (ch,cw,cr) = getchar xs
-                    (str,w,r)  = scanString cr
---                    str' = maybe "" (:str) ch
-                in maybe ("",0,xs) (\c -> (c:str,cw+w,r)) ch
-
-scanQualName :: String -> (String, Int, String)
-scanQualName []          = ("",0,[])
-scanQualName r@('\'':_)  = ("",0,r)
-scanQualName xs          = let (ch,cw,cr) = getchar xs
-                               (str,w,r)  = scanQualName cr
-                           in  maybe ("",0,xs) (\c -> (c:str,cw+w,r)) ch
-
-scanChar :: String -> (Maybe Char, Int, String)
-scanChar ('"' :xs) = (Just '"',1,xs)
-scanChar xs        = getchar xs
-
-getchar :: String -> (Maybe Char, Int, String)
-getchar []          = (Nothing,0,[])
-getchar s@('\n':_ ) = (Nothing,0,s )
-getchar s@('\t':_ ) = (Nothing,0,s)
-getchar s@('\'':_ ) = (Nothing,0,s)
-getchar s@('"' :_ ) = (Nothing,0,s)
-getchar   ('\\':xs) = let (c,l,r) = getEscChar xs
-                      in (c,l+1,r)
-getchar (x:xs)      = (Just x,1,xs)
-
-getEscChar :: String -> (Maybe Char, Int, String)
-getEscChar [] = (Nothing,0,[])
-getEscChar s@(x:xs) | isDigit x = let (base,n,len,rest) = getNumber s
-                                      val = readn base  n
-                                  in  if val >= 0 && val <= 255
-                                         then (Just (chr val),len, rest)
-                                         else (Nothing,1,rest)
-                    | otherwise = case x `lookup` cntrChars of
-                                 Nothing -> (Nothing,0,s)
-                                 Just c  -> (Just c,1,xs)
-  where cntrChars = [('a','\a'),('b','\b'),('f','\f'),('n','\n'),('r','\r'),('t','\t')
-                    ,('v','\v'),('\\','\\'),('"','\"'),('\'','\'')]
-
-readn :: Int -> String -> Int
-readn base n = foldl (\r x  -> value x + base * r) 0 n
-
-getNumber :: String -> (Int,String,Int,String)
-getNumber [] = error "Empty string"
-getNumber cs@(c:s)
-  | c /= '0'               = num10
-  | null s                 = const0
-  | hs == 'x' || hs == 'X' = num16
-  | hs == 'o' || hs == 'O' = num8
-  | otherwise              = num10
-  where (hs:ts) = s
-        const0 = (10, "0",1,s)
-        num10  = let (n,r) = span isDigit cs
-                 in (10,n,length n,r)
-        num16   = readNum isHexaDigit  ts 16
-        num8    = readNum isOctalDigit ts 8
-        readNum p ts' tk
-          = let (n,rs) = span p ts'
-            in  if null n then const0
-                          else (tk, n, 2+length n,rs)
-
-isHexaDigit :: Char -> Bool
-isHexaDigit  d = isDigit d || (d >= 'A' && d <= 'F') || (d >= 'a' && d <= 'f')
-isOctalDigit :: Char -> Bool
-isOctalDigit d = d >= '0' && d <= '7'
-
-value :: Char -> Int
-value c | isDigit c = ord c - ord '0'
-        | isUpper c = ord c - ord 'A' + 10
-        | isLower c = ord c - ord 'a' + 10
-value _ = error "Not a valid value"
++module HsTokenScanner where+import HsToken+import UU.Scanner.Position+import Data.List(sort)+import UU.Util.BinaryTrees+import CommonTypes+import Data.Maybe+import Data.Char++isAGesc :: Char -> Bool+isAGesc c = c == '@'++lexTokens :: Options -> Pos -> String -> [HsToken]+lexTokens = scanTokens keywordstxt keywordsops specialchars opchars+  where keywordstxt   =  []+        keywordsops   =  [".","=", ":=", ":","|","@"]+        specialchars  =  ";()[],_{}`"+        opchars       =  "!#$%&*+./<=>?@\\^|-~:"+++scanTokens :: [String] -> [String] -> String -> String -> Options -> Pos -> String -> [HsToken]+scanTokens keywordstxt keywordsops specchars opchars opts pos input+  = doScan pos input++ where+   locatein :: Ord a => [a] -> a -> Bool+   locatein es = isJust . btLocateIn compare (tab2tree (sort es))+   iskw     = locatein keywordstxt+   isop     = locatein keywordsops+   isSymb   = locatein specchars+   -- See http://stackoverflow.com/questions/10548170/what-characters-are-permitted-for-haskell-operators+   isOpsym  c = locatein opchars c+                -- For unicode operators+                || (not (isAscii c) && (isSymbol c || isPunctuation c))++   isIdStart c = isLower c || c == '_'++   isIdChar c =  isAlphaNum c+              || c == '\''+              || c == '_'++   scanIdent p s = let (name,rest) = span isIdChar s+                   in (name,advc (length name) p,rest)++   doScan _ []      = []+   doScan p (c:s)   | isSpace c = let (sp,next) = span isSpace s+                                 in  doScan (foldl (flip updPos)  p (c:sp)) next+   doScan p (c:d:s) | isAGesc c && isIdStart d =+                                 let (fld,p2,rest) = scanIdent (advc 2 p) s+                                     field = d:fld+                                 in case rest of+                                      ('.':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 Nothing : doScan p3 rest2+                                      _                 -> AGLocal (Ident field p) p Nothing : doScan p2 rest++   doScan p ('/':'/':s) | clean opts  = doScan p (dropWhile (/= '\n') s)+   doScan p ('/':'*':s) | clean opts  = advc' 2 p (lexCleanNest doScan) s   -- }+   doScan p ('-':'-':s)  = doScan p (dropWhile (/= '\n') s)+   doScan p ('{':'-':s)  = advc' 2 p (lexNest doScan) s   -- }+   doScan p ('"':ss)+     = let (s,swidth,rest) = scanString ss+       in if null rest || head rest /= '"'+             then Err "Unterminated string literal" p : advc' swidth p doScan rest+             else StrToken s p : advc' (swidth+2) p doScan (tail rest)++   doScan p ('\'':ss)+     | clean opts = let (str,nswidth,rest) = scanQualName ss+                    in  HsToken ('\'' : str ++ "'") p : advc' (nswidth + 2) p doScan (tail rest)+     | otherwise+     = let (mc,cwidth,rest) = scanChar ss+       in case mc of+            Nothing -> Err "Error in character literal" p : advc' cwidth p doScan rest+            Just c  -> if null rest || head rest /= '\''+                          then Err "Unterminated character literal" p : advc' (cwidth+1) p doScan rest+                          else CharToken  [c] p : advc' (cwidth+2) p doScan (tail rest)+   doScan p cs@(c:s)++     | isIdStart c || isUpper c+         = let (name', p', s')    = scanIdent (advc 1 p) s+               name               = c:name'+               tok                = if iskw name+                                    then HsToken name p               -- keyword+                                    else if null name' && isSymb c+                                    then HsToken [c] p                -- '_'+                                    else HsToken name p               -- varid / conid+           in tok : doScan p' s'+     | isOpsym c = let (name, s') = span isOpsym cs+                       tok | isop name = HsToken name p+                           | otherwise = HsToken name p+                   in tok : doScan (foldl (flip updPos)  p name)  s'+     | isDigit c = let (base,digs,width,s') = getNumber cs+                       number = case base of+                          8  -> "0o"++digs+                          10 -> digs+                          16 -> "0x"++digs+                          _  -> error $ "Base " ++ show base ++ " is not supported."+                   in  HsToken number p : advc' width p doScan s'+     | isSymb c = HsToken [c] p : advc' 1 p doScan s+     | otherwise = Err ("Unexpected character " ++ show c) p : updPos'  c p doScan s++lexNest :: (Pos -> String -> [HsToken]) -> Pos -> String -> [HsToken]+lexNest cont pos inp = lexNest' cont pos inp+ where lexNest' c p ('{':'-':s) = lexNest' (lexNest' c) (advc 2 p) s+       lexNest' c p ('-':'}':s) = c (advc 2 p) s+       lexNest' c p (x:s)       = lexNest' c (updPos  x p) s+       lexNest' _ _ []          = [Err "Unterminated nested comment" pos]++lexCleanNest :: (Pos -> String -> [HsToken]) -> Pos -> String -> [HsToken]+lexCleanNest cont pos inp = lexNest' cont pos inp+ where lexNest' c p ('/':'*':s) = lexNest' (lexNest' c) (advc 2 p) s+       lexNest' c p ('*':'/':s) = c (advc 2 p) s+       lexNest' c p (x:s)       = lexNest' c (updPos  x p) s+       lexNest' _ _ []          = [Err "Unterminated nested comment" pos]++scanString :: String -> (String, Int, String)+scanString []            = ("",0,[])+scanString ('\\':'&':xs) = let (str,w,r) = scanString xs+                           in (str,w+2,r)+scanString ('\'':xs)     = let (str,w,r) = scanString xs+                           in ('\'': str,w+1,r)+scanString xs = let (ch,cw,cr) = getchar xs+                    (str,w,r)  = scanString cr+--                    str' = maybe "" (:str) ch+                in maybe ("",0,xs) (\c -> (c:str,cw+w,r)) ch++scanQualName :: String -> (String, Int, String)+scanQualName []          = ("",0,[])+scanQualName r@('\'':_)  = ("",0,r)+scanQualName xs          = let (ch,cw,cr) = getchar xs+                               (str,w,r)  = scanQualName cr+                           in  maybe ("",0,xs) (\c -> (c:str,cw+w,r)) ch++scanChar :: String -> (Maybe Char, Int, String)+scanChar ('"' :xs) = (Just '"',1,xs)+scanChar xs        = getchar xs++getchar :: String -> (Maybe Char, Int, String)+getchar []          = (Nothing,0,[])+getchar s@('\n':_ ) = (Nothing,0,s )+getchar s@('\t':_ ) = (Nothing,0,s)+getchar s@('\'':_ ) = (Nothing,0,s)+getchar s@('"' :_ ) = (Nothing,0,s)+getchar   ('\\':xs) = let (c,l,r) = getEscChar xs+                      in (c,l+1,r)+getchar (x:xs)      = (Just x,1,xs)++getEscChar :: String -> (Maybe Char, Int, String)+getEscChar [] = (Nothing,0,[])+getEscChar s@(x:xs) | isDigit x = let (base,n,len,rest) = getNumber s+                                      val = readn base  n+                                  in  if val >= 0 && val <= 255+                                         then (Just (chr val),len, rest)+                                         else (Nothing,1,rest)+                    | otherwise = case x `lookup` cntrChars of+                                 Nothing -> (Nothing,0,s)+                                 Just c  -> (Just c,1,xs)+  where cntrChars = [('a','\a'),('b','\b'),('f','\f'),('n','\n'),('r','\r'),('t','\t')+                    ,('v','\v'),('\\','\\'),('"','\"'),('\'','\'')]++readn :: Int -> String -> Int+readn base n = foldl (\r x  -> value x + base * r) 0 n++getNumber :: String -> (Int,String,Int,String)+getNumber [] = error "Empty string"+getNumber cs@(c:s)+  | c /= '0'               = num10+  | null s                 = const0+  | hs == 'x' || hs == 'X' = num16+  | hs == 'o' || hs == 'O' = num8+  | otherwise              = num10+  where (hs:ts) = s+        const0 = (10, "0",1,s)+        num10  = let (n,r) = span isDigit cs+                 in (10,n,length n,r)+        num16   = readNum isHexaDigit  ts 16+        num8    = readNum isOctalDigit ts 8+        readNum p ts' tk+          = let (n,rs) = span p ts'+            in  if null n then const0+                          else (tk, n, 2+length n,rs)++isHexaDigit :: Char -> Bool+isHexaDigit  d = isDigit d || (d >= 'A' && d <= 'F') || (d >= 'a' && d <= 'f')+isOctalDigit :: Char -> Bool+isOctalDigit d = d >= '0' && d <= '7'++value :: Char -> Int+value c | isDigit c = ord c - ord '0'+        | isUpper c = ord c - ord 'A' + 10+        | isLower c = ord c - ord 'a' + 10+value _ = error "Not a valid value"
src/KennedyWarren.hs view
@@ -1,850 +1,851 @@-module KennedyWarren where
-
-import Prelude hiding (init, succ)
-import CommonTypes
-import Pretty
-import Knuth1
-import ExecutionPlan
-import Debug.Trace
-import Control.Monad.ST
-import Control.Monad.State
-import Control.Monad.Error
-import Data.STRef
-import Data.Maybe
-import Data.List (intersperse, groupBy, partition, sortBy)
-import Data.Ord
-import qualified ErrorMessages as Err
-import PrintErrorMessages ()
-
-import Data.Set (Set)
-import qualified Data.Set as Set
-import Data.Map (Map)
-import qualified Data.Map as Map
-import qualified Data.Map.Strict as MapStrict
-import Data.IntMap (IntMap)
-import qualified Data.IntMap as IntMap
-import Data.IntSet (IntSet)
-import qualified Data.IntSet as IntSet
-
--- lazy version (does not return errors)
--- FIXME: construct map from nonterminal to intial visit (or state?) and use it in the generation of invokes
-kennedyWarrenLazy :: Options -> Set NontermIdent -> [NontDependencyInformation] -> TypeSyns -> Derivings -> ExecutionPlan
-kennedyWarrenLazy _ wr ndis typesyns derivings = plan where
-  plan  = ExecutionPlan nonts typesyns wr derivings
-  nonts = zipWith mkNont ndis nontIds
-  nontIds = enumFromThen 1 4
-  initvMap = Map.fromList $ zipWith (\ndi initv -> (ndiNonterminal ndi, initv)) ndis nontIds
-
-  mkNont ndi initv = nont where
-    nont = ENonterminal
-                 (ndiNonterminal ndi)
-                 (ndiParams ndi)
-                 (ndiClassCtxs ndi)
-                 initst
-                 [initv]
-                 nextMap
-                 prevMap
-                 prods
-                 (ndiRecursive ndi)
-                 (ndiHoInfo ndi)
-    initst  = initv + 1
-    finals  = initv + 2
-    nextMap = Map.fromList [(initst, OneVis initv), (finals, NoneVis)]
-    prevMap = Map.fromList [(initst, NoneVis), (finals, OneVis initv)]
-    prods   = map mkProd (ndiProds ndi)
-
-    mkProd pdi = prod where
-      prod = EProduction
-               (pdgProduction pdi)
-               (pdgParams pdi)
-               (pdgConstraints pdi)
-               (pdgRules pdi)
-               (pdgChilds pdi)
-               visits
-      visits = [vis]
-      vis    = Visit initv initst finals inh syn steps kind
-      inh    = Set.fromList $ ndiInh ndi
-      syn    = Set.fromList $ ndiSyn ndi
-      kind   = VisitPure False
-      steps  = childSteps ++ invokeSteps ++ ruleSteps
-
-      childSteps  = [ ChildIntro nm | EChild nm _ _ _ _ _ <- pdgChilds pdi ]
-      invokeSteps = [ ChildVisit nm nt v
-                    | EChild nm tp _ _ _ _ <- pdgChilds pdi
-                    , let nt = extractNonterminal tp
-                          v  = Map.findWithDefault (error "child not in initv-map") nt initvMap
-                    ]
-      ruleSteps   = [ Sem nm | (ERule nm _ _ _ _ _ _ _) <- pdgRules pdi ]
-
-
--- ordered version (may return errors)
-kennedyWarrenOrder :: Options -> Set NontermIdent -> [NontDependencyInformation] -> TypeSyns -> Derivings -> Either Err.Error (ExecutionPlan, PP_Doc, PP_Doc)
-kennedyWarrenOrder opts wr ndis typesyns derivings = runST $ runErrorT $ do
-  indi <- lift $ mapM mkNontDependencyInformationM ndis
-  lift $ 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
-    -- Topological sort
-    --tsedg <- graphTopSort g
-    -- Cyclicity check
-    ntCycVerts <- lift $ graphCyclicVerticesExt g
-    when (not $ null ntCycVerts) $ do
-      throwError $ Err.Cyclic nont Nothing (map show ntCycVerts)
---      let msg = "Nonterminal graph " ++ show nont ++ " is cylic!"
---      fail msg
-    -- Transtive closure check
-    trc <- lift $ graphIsTRC g
-    when (not trc) $ do
-      let msg = "Nonterminal graph " ++ show nont ++ " is not transitively closed!"
-      fail msg
-    -- Consistency check
-    cons <- lift $ graphCheckConsistency g
-    when (not cons) $ do
-      let msg = "Nonterminal graph " ++ show nont ++ " is not consistent!"
-      fail msg
-
-    -- Loop trough all productions
-    forM_ (ndimProds ndi) $ \prod -> do
-      let pr = pdgProduction $ pdgmOrig prod
-      let g' = pdgmDepGraph $ prod
-      -- Topsort
-      --addTopSortEdges tsedg prod
-      -- Check for cyclicity
-      pdCycVerts <- lift $ graphCyclicVerticesExt g'
-      when (not $ null pdCycVerts) $ do
-        throwError $ Err.Cyclic nont (Just pr) (map show pdCycVerts)
-        -- let msg = "Production graph " ++ show pr ++ " of nonterminal "
-        --                               ++ show nont ++ " is cylic!"
-        -- fail msg
-      -- Transtive closure check
-      trc' <- lift $ graphIsTRC g'
-      when (not trc') $ do
-        lift $ traceST $ "Production graph " ++ show pr ++ " of nonterminal "
-                                             ++ show nont ++ " is not transitively closed!"
-        fail "Production graph is not transitively closed."
-      -- Check consistency
-      consistent <- lift $ graphCheckConsistency g'
-      when (not consistent) $ do
-        let msg =  "Production graph " ++ show pr ++ " of nonterminal "
-                                       ++ show nont ++ " is not consistent!"
-        fail msg
-  -- reachable when everything is ok
-  lift $ do
-        -- Create non-transitive closed graph for efficiency
-        indi' <- undoTransitiveClosure indi
-        -- Graphviz output of dependency graphs
-        gvs <- mapM toGVNontDependencyInfo indi'
-        -- Doing kennedywarren
-        (ret, visitg) <- runVG $ do
-         -- traceVG $ "Running kennedy-warren..."
-         initvs <- kennedyWarrenVisitM wr indi'
-         -- Print some debug info
-         nodes <- gets vgNodeNum
-         edges <- gets vgEdgeNum
-         when (not $ beQuiet opts) $ do
-           traceVG $ "Number of nodes = " ++ show nodes
-           traceVG $ "Number of edges = " ++ show edges
-         -- Generate execution plan
-         ex <- kennedyWarrenExecutionPlan opts indi' initvs wr typesyns derivings
-         -- Get visit graph
-         visitg <- toGVVisitGraph
-         return (ex,visitg)
-        -- Return the result
-        return (ret, vlist gvs, visitg)
-
--------------------------------------------------------------------------------
---         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 "")
-
-toGVVisitGraph :: VG s PP_Doc
-toGVVisitGraph = do
-  ndis <- gets vgNDI
-  noded <- forM (IntMap.toList ndis) $ \(n,rndi) -> do
-    ndi <- vgInST $ readSTRef rndi
-    return $ "node_" >|< n >#< "[label=\"" >|< ndiNonterminal (ndimOrig ndi) >|< "_" >|< n >|< "\"];"
-  edges <- gets vgEdges
-  edged <- forM (IntMap.toList edges) $ \(edg,(VGNode from,VGNode to)) -> do
-    inh <- getInherited (VGEdge edg)
-    syn <- getSynthesized (VGEdge edg)
-    return $ "node_" >|< from >#< "-> node_" >|< to >#< "[label=\"visit v" >|< edg
-      >|< "\\ninh:" >#< (concat $ intersperse ", " $ map show $ Set.toList inh) >|< "\\nsyn: " >|< (concat $ intersperse ", " $ map show $ Set.toList syn) >|< "\"];"
-  return $ "digraph visitgraph { " >-< vlist noded >-< vlist edged >-< "}"
-
--------------------------------------------------------------------------------
---         Kennedy-Warren in monadic style
--------------------------------------------------------------------------------
-{-
-runVG                    :: VG s a -> ST s a
-insertInitialNode        :: NontDependencyInformationM s -> VG s VGNode
-createPending            :: VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge
-selectPending            :: VG s VGEdge
-getInherited             :: VGEdge -> VG s (Set Identifier)
-getSynthesized           :: VGEdge -> VG s (Set Identifier)
-markFinal                :: VGEdge -> VG s ()
-getProductions           :: VGEdge -> VG s [VGProd]
-onMarkedDepGraph         :: (ProdDependencyGraphM s -> ST s a) -> VGProd -> VG s a
-isDepGraphVertexFinal    :: VGProd -> Vertex -> VG s Bool
-setDepGraphVerticesFinal :: VGProd -> [Vertex] -> VG s ()
-getChildState            :: VGProd -> Identifier -> VG s VGNode
-addChildVisit            :: VGProd -> Identifier -> VGEdge -> VG s VisitStep
-addVisitStep             :: VGProd -> VisitStep -> VG s ()
-repeatM                  :: VG s () -> VG s ()
--}
-
-newtype VGNode = VGNode Int deriving (Show,Eq,Ord)
-newtype VGEdge = VGEdge Int deriving (Show,Eq,Ord)
-newtype VGProd = VGProd (VGEdge,Int) deriving (Show,Eq,Ord)
-
-data VGState s = VGState { vgNodeNum       :: Int
-                         , vgEdgeNum       :: Int
-                           -- Node maps
-                         , vgOutgoing      :: IntMap (STRef s (Set VGEdge))
-                         , vgIncoming      :: IntMap (Maybe VGEdge)
-                         , vgNDI           :: IntMap (STRef s (NontDependencyInformationM s))
-                         , vgInhSynNode    :: Map (Identifier, Set Identifier, Set Identifier) VGNode
-                         , vgNodeInhSyn    :: IntMap (Set Identifier, Set Identifier)
-                         , vgInitial       :: Map Identifier VGNode
-                           -- Edge maps
-                         , vgEdges         :: IntMap (VGNode, VGNode)
-                         , vgEdgesR        :: Map (VGNode,VGNode) VGEdge
-                         , vgInherited     :: IntMap (Set Identifier)
-                         , vgSynthesized   :: IntMap (Set Identifier)
-                         , vgPending       :: IntSet
-                         , vgChildVisits   :: IntMap (STRef s (Map (Identifier,Int) [VGNode]))
-                           -- Final vertices in production graphs
-                         , vgFinalVertices :: IntMap (STRef s (Set (Vertex,Int)))
-                           -- Construction of execution plan (Nonterminal,Production,Visit)
-                         , vgProdVisits    :: Map (Identifier,Identifier,VGEdge) (STRef s [VisitStep])
-                         }
-
-type VG s a = ErrorT String (StateT (VGState s) (ST s)) a
-
-------------------------------------------------------------
----              Public functions                        ---
-------------------------------------------------------------
--- | Run the VG monad in the ST monad
-runVG :: VG s a -> ST s a
-runVG vg = do (Right a,_) <- runStateT (runErrorT vg) vgEmptyState
-              return a
-
--- | Insert an initial node for this nonterminal into the visit graph
-insertInitialNode :: NontDependencyInformationM s -> VG s VGNode
-insertInitialNode ndi = do
-  rndi          <- vgInST $ newSTRef ndi
-  (VGNode node) <- vgCreateNode rndi Set.empty Set.empty
-  initial       <- gets vgInitial
-  incoming      <- gets vgIncoming
-  modify $ \st -> st { vgInitial  = Map.insert (ndiNonterminal $ ndimOrig ndi) (VGNode node) initial
-                     , vgIncoming = IntMap.insert node Nothing incoming }
-  return (VGNode node)
-
--- | Create a pending edge from this node with a set of inherited and synthesized attributes
-createPending :: VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge
-createPending vgn@(VGNode n) inh syn = do
-  -- Check if target node already exists
-  ninhsyn <- gets vgNodeInhSyn
-  let (pinh,psyn) = imLookup n ninhsyn
-  let ninh        = Set.union pinh inh
-  let nsyn        = Set.union psyn syn
-  mndi    <- gets vgNDI
-  let rndi = imLookup n mndi
-  ndi     <- vgInST $ readSTRef rndi
-  inhsynn <- gets vgInhSynNode
-  case Map.lookup (ndiNonterminal $ ndimOrig ndi, ninh, nsyn) inhsynn of
-    Just tn -> do
-      when (tn == vgn) $ do traceVG $ "Source and target nodes are the same!"
-                            traceVG $ "Maybe there is a wrapper with no inherited or synthesized attributes."
-                            traceVG $ "Inh: " ++ show inh
-                            traceVG $ "Syn: " ++ show syn
-                            traceVG $ "PInh: " ++ show pinh
-                            traceVG $ "PSyn: " ++ show psyn
-      -- tn is target node, now check if edge exists and create if not
-      edgesr <- gets vgEdgesR
-      case Map.lookup (vgn,tn) edgesr of
-        Just e  -> return e
-        Nothing -> vgCreatePendingEdge vgn tn inh syn
-    Nothing -> do
-      -- target node does not exist, create it and then create the new edge
-      tn <- vgCreateNode rndi ninh nsyn
-      vgCreatePendingEdge vgn tn inh syn
-
--- | Return an arbitrary pending edge of which the from node is ready
-selectPending :: VG s VGEdge
-selectPending = do
-  pending  <- gets vgPending
-  incoming <- gets vgIncoming
-  edges    <- gets vgEdges
-  let readyPend = filter (\p -> let (VGNode fr,_) = imLookup p edges
-                                in  isJust $ IntMap.lookup fr incoming) $ IntSet.toList pending
-  guard $ not $ null readyPend
-  return $ VGEdge $ head $ readyPend
-
--- | Get the inherited attributes of an edge
-getInherited :: VGEdge -> VG s (Set Identifier)
-getInherited (VGEdge edg) = do
-  inhs <- gets vgInherited
-  return $ imLookup edg inhs
-
--- | Get the synthesized attributes of an edge
-getSynthesized :: VGEdge -> VG s (Set Identifier)
-getSynthesized (VGEdge edg) = do
-  syns <- gets vgSynthesized
-  return $ imLookup edg syns
-
--- | Mark an edge as final
-markFinal :: VGEdge -> VG s ()
-markFinal vgedg@(VGEdge edg) = do
-  incoming <- gets vgIncoming
-  edges    <- gets vgEdges
-  pending  <- gets vgPending
-  let (_,VGNode to) = imLookup edg edges
-  modify $ \st -> st { vgIncoming = IntMap.insert to (Just vgedg) incoming
-                     , vgPending  = IntSet.delete edg pending }
-
--- | Get all productions for an edge
-getProductions :: VGEdge -> VG s [VGProd]
-getProductions vedg@(VGEdge edg) = do
-  edges <- gets vgEdges
-  let (VGNode fr,_) = imLookup edg edges
-  ndis <- gets vgNDI
-  let rndi = imLookup fr ndis
-  ndi <- vgInST $ readSTRef rndi
-  return $ map (\x -> VGProd (vedg,x)) [0..(length $ ndimProds ndi)-1]
-
--- | Execute a function on the dependency graph for this production
-onMarkedDepGraph :: (ProdDependencyGraphM s -> ST s a) -> VGProd -> VG s a
-onMarkedDepGraph f (VGProd (VGEdge edg, n)) = do
-  edges <- gets vgEdges
-  let (VGNode fr,_) = imLookup edg edges
-  ndis <- gets vgNDI
-  let rndi = imLookup fr ndis
-  ndi <- vgInST $ readSTRef rndi
-  vgInST $ f $ (ndimProds ndi) !! n -- not efficient, but lists are usually short
-
--- | Check whether this vertex has been marked as final
-isDepGraphVertexFinal :: VGProd -> Vertex -> VG s Bool
-isDepGraphVertexFinal (VGProd (VGEdge edg, p)) v = do
-  edges <- gets vgEdges
-  let (from,_) = imLookup edg edges
-  vgDepGraphVertexFinal from p v
-
--- | Mark these vertices final in this production
-setDepGraphVerticesFinal :: VGProd -> [Vertex] -> VG s ()
-setDepGraphVerticesFinal (VGProd (VGEdge edg, p)) vs = do
-  edges   <- gets vgEdges
-  let (_,VGNode to) = imLookup edg edges
-  finalv <- gets vgFinalVertices
-  let rfinalv       = imLookup to finalv
-  vgInST $ modifySTRef rfinalv $ Set.union (Set.fromList $ map (\v -> (v,p)) vs)
-
--- | Add a child visit to this production and return the step for the execution plan
-addChildVisit :: VGProd -> Identifier -> VGEdge -> VG s VisitStep
-addChildVisit (VGProd (VGEdge edg, p)) ide (VGEdge vs) = do
-  edges   <- gets vgEdges
-  let (VGNode from,vgto) = imLookup vs edges -- from must be equal to the current state
-  childvs <- gets vgChildVisits
-  let rchildv = imLookup edg childvs
-  vgInST $ modifySTRef rchildv $ MapStrict.insertWith (++) (ide,p) [vgto]
-  ndis <- gets vgNDI
-  let rndi = imLookup from ndis
-  ndi <- vgInST $ readSTRef rndi
-  let nt = ndiNonterminal $ ndimOrig ndi
-  return $ ChildVisit ide nt vs
-
--- | Add a step to the execution plan of this visit
-addVisitStep :: VGProd -> VisitStep -> VG s ()
-addVisitStep (VGProd (VGEdge edg, p)) st = do
-  edges <- gets vgEdges
-  let (VGNode fr,_) = imLookup edg edges
-  ndis <- gets vgNDI
-  let rndi = imLookup fr ndis
-  ndi <- vgInST $ readSTRef rndi
-  prodvs <- gets vgProdVisits
-  let nont = ndiNonterminal $ ndimOrig ndi
-  let prod = pdgProduction $ pdgmOrig $ ndimProds ndi !! p
-  let Just rprodv = Map.lookup (nont, prod, VGEdge edg) prodvs
-  vgInST $ modifySTRef rprodv (++ [st])
-
--- | Get the state of a child in a certain production
-getChildState :: VGProd -> Identifier -> VG s VGNode
-getChildState (VGProd (VGEdge edg,p)) ide = do
-  childvs <- gets vgChildVisits
-  let rchildv = imLookup edg childvs
-  childv  <- vgInST $ readSTRef rchildv
-  case Map.lookup (ide,p) childv of
-    Just (n:_) -> return n
-    _          -> do
-      -- Look for previous edge
-      edges <- gets vgEdges
-      let (VGNode from,_) = imLookup edg edges
-      incoming <- gets vgIncoming
-      case IntMap.lookup from incoming of
-        Just (Just iedg) -> getChildState (VGProd (iedg,p)) ide
-        Just Nothing     -> do
-          -- Lookup initial state
-          ndis <- gets vgNDI
-          let rndi = imLookup from ndis
-          ndi  <- vgInST $ readSTRef rndi
-          let Just nt = lookup ide $ pdgChildMap $ pdgmOrig $ (ndimProds ndi) !! p
-          vgFindInitial nt
-        Nothing          -> error "getChildState"
-
--- | Repeat action untill mzero is encountered
-repeatM :: VG s () -> VG s ()
-repeatM m = catchError (m >> repeatM m) (const $ return ())
-
-------------------------------------------------------------
----              Internal functions                      ---
-------------------------------------------------------------
--- | Execute a ST action inside the VG monad
-vgInST :: ST s a -> VG s a
-vgInST = lift . lift
-
-vgEmptyState :: VGState s
-vgEmptyState = VGState { vgNodeNum       = 0
-                       , vgEdgeNum       = 0
-                       , vgOutgoing      = IntMap.empty
-                       , vgIncoming      = IntMap.empty
-                       , vgNDI           = IntMap.empty
-                       , vgInhSynNode    = Map.empty
-                       , vgNodeInhSyn    = IntMap.empty
-                       , vgInitial       = Map.empty
-                       , vgEdges         = IntMap.empty
-                       , vgEdgesR        = Map.empty
-                       , vgInherited     = IntMap.empty
-                       , vgSynthesized   = IntMap.empty
-                       , vgPending       = IntSet.empty
-                       , vgChildVisits   = IntMap.empty
-                       , vgFinalVertices = IntMap.empty
-                       , vgProdVisits    = Map.empty
-                       }
--- | Create a new node
-vgCreateNode :: STRef s (NontDependencyInformationM s) -> Set Identifier -> Set Identifier -> VG s VGNode
-vgCreateNode rndi inh syn = do
-  num      <- gets vgNodeNum
-  outgoing <- gets vgOutgoing
-  inhsyn   <- gets vgInhSynNode
-  ninhsyn  <- gets vgNodeInhSyn
-  ndi      <- gets vgNDI
-  finalv   <- gets vgFinalVertices
-  rout     <- vgInST $ newSTRef Set.empty
-  rfinalv  <- vgInST $ newSTRef Set.empty
-  nndi     <- vgInST $ readSTRef rndi
-  modify $ \st -> st { vgNodeNum       = num + 1
-                     , vgOutgoing      = IntMap.insert num rout outgoing
-                     , vgInhSynNode    = Map.insert (ndiNonterminal $ ndimOrig nndi,inh,syn) (VGNode num) inhsyn
-                     , vgNodeInhSyn    = IntMap.insert num (inh,syn) ninhsyn
-                     , vgNDI           = IntMap.insert num rndi ndi
-                     , vgFinalVertices = IntMap.insert num rfinalv finalv }
-  return $ VGNode num
-
--- | Create a new pending edge
-vgCreatePendingEdge :: VGNode -> VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge
-vgCreatePendingEdge vgn1@(VGNode n1) vgn2 inh syn = do
-  num      <- gets vgEdgeNum
-  edges    <- gets vgEdges
-  edgesr   <- gets vgEdgesR
-  inhs     <- gets vgInherited
-  syns     <- gets vgSynthesized
-  outgoing <- gets vgOutgoing
-  pend     <- gets vgPending
-  childv   <- gets vgChildVisits
-  rchildv  <- vgInST $ newSTRef Map.empty
-  let outr    = imLookup n1 outgoing
-  let ret     = VGEdge num
-  vgInST $ modifySTRef outr (Set.insert ret)
-  modify $ \st -> st { vgEdgeNum     = num + 1
-                     , vgEdges       = IntMap.insert num (vgn1,vgn2) edges
-                     , vgEdgesR      = Map.insert (vgn1,vgn2) ret edgesr
-                     , vgPending     = IntSet.insert num pend
-                     , vgInherited   = IntMap.insert num inh inhs
-                     , vgSynthesized = IntMap.insert num syn syns
-                     , vgChildVisits = IntMap.insert num rchildv childv }
-  -- Add prod visits (for constructing an execution plan)
-  ndis <- gets vgNDI
-  let rndi = imLookup n1 ndis
-  ndi <- vgInST $ readSTRef rndi
-  prodv  <- gets vgProdVisits
-  refs   <- forM (ndimProds ndi) $ \prod -> do
-    rprod <- vgInST $ newSTRef []
-    return ((ndiNonterminal $ ndimOrig ndi, pdgProduction $ pdgmOrig prod, ret),rprod)
-  modify $ \st -> st { vgProdVisits = Map.union (Map.fromList refs) prodv }
-  return $ ret
-
--- | Check whether a vertex is marked final on this node in this production
-vgDepGraphVertexFinal :: VGNode -> Int -> Vertex -> VG s Bool
-vgDepGraphVertexFinal (VGNode n) p v = do
-  finalv <- gets vgFinalVertices
-  let rfinalv = imLookup n finalv
-  curset <- vgInST $ readSTRef rfinalv
-  if Set.member (v,p) curset
-    then return True
-    else do
-      incoming <- gets vgIncoming
-      case IntMap.lookup n incoming of
-        Just (Just (VGEdge edg)) -> do
-          edges <- gets vgEdges
-          let (fr,_) = imLookup edg edges
-          vgDepGraphVertexFinal fr p v
-        Just Nothing -> return False
-        Nothing      -> error "This can never happen"
-
--- | Find the initial node for a nonterminal
-vgFindInitial :: Identifier -> VG s VGNode
-vgFindInitial nt = do
-  initial <- gets vgInitial
-  let Just r = Map.lookup nt initial
-  return r
-
--- | Always succeeding IntMap lookup
-imLookup :: Int -> IntMap a -> a
-imLookup k m = let Just r = IntMap.lookup k m in r
-
--- | Trace inside the vg monad
-traceVG :: String -> VG s ()
-traceVG s = trace s (return ())
-
-------------------------------------------------------------
----         The kennedy warren algorithm                 ---
-------------------------------------------------------------
-{-
-runVG                    :: VG s a -> ST s a
-insertInitialNode        :: NontDependencyInformationM s -> VG s VGNode
-createPending            :: VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge
-selectPending            :: VG s VGEdge
-getInherited             :: VGEdge -> VG s (Set Identifier)
-getSynthesized           :: VGEdge -> VG s (Set Identifier)
-markFinal                :: VGEdge -> VG s ()
-getProductions           :: VGEdge -> VG s [VGProd]
-onMarkedDepGraph         :: (ProdDependencyGraphM s -> ST s a) -> VGProd -> VG s a
-isDepGraphVertexFinal    :: VGProd -> Vertex -> VG s Bool
-setDepGraphVerticesFinal :: VGProd -> [Vertex] -> VG s ()
-getChildState            :: VGProd -> Identifier -> VG s VGNode
-addChildVisit            :: VGProd -> Identifier -> VGEdge -> VG s VisitStep
-addVisitStep             :: VGProd -> VisitStep -> VG s ()
-repeatM                  :: VG s () -> VG s ()
--}
-
-kennedyWarrenVisitM :: Set NontermIdent -> [NontDependencyInformationM s] -> VG s [[VisitIdentifier]]
-kennedyWarrenVisitM wr ndis = do
-  -- Create initial nodes and edges (edges only for wrapper nodes)
-  initvs <- forM ndis $ \ndi -> do
-    nd <- insertInitialNode ndi
-    let inh = Set.fromList $ ndiInh $ ndimOrig ndi
-    let syn = Set.fromList $ ndiSyn $ ndimOrig ndi
-    if (Set.member (ndiNonterminal $ ndimOrig $ ndi) wr) && (not (Set.null inh) || not (Set.null syn))
-      then do
-        VGEdge initv <- createPending nd inh syn
-        return [initv]
-      else return []
-  -- Handle all pending edges while there are any
-  repeatM $ do
-    pend  <- selectPending
-    prods <- getProductions pend
-    inhs  <- getInherited pend
-    syns  <- getSynthesized pend
-    -- Handle each production for this edge
-    forM_ prods $ \prod -> do
-      -- Mark all inherited attributes as final
-      setDepGraphVerticesFinal prod (map createLhsInh . Set.toList $ inhs)
-      -- Find depth of all synthesized child visits
-      (vis,_) <- foldM (foldChildVisits prod) ([],0) (map createLhsSyn . Set.toList $ syns)
-      -- Mark them as final
-      setDepGraphVerticesFinal prod (map fst vis)
-      -- Change the inherited child visits
-      vis2 <- correctInhChilds prod vis
-      -- Add all synthesized attributes that are also ready but are not needed
-      extravis <- extraChildSyn prod vis2
-      setDepGraphVerticesFinal prod (map fst extravis)
-      -- Group by visit number and do visit for every num
-      let gvis = groupSortBy (comparing snd) $ vis2 ++ extravis
-      forM_ gvis $ \vis3 -> do
-        -- Split child visits from rules
-        let (chattrs, rules) = partition isChildAttr $ map fst vis3
-        -- Evaluate all rules
-        forM_ (reverse $ rules) $ \rule ->
-          case rule of
-            VRule r  -> addVisitStep prod $ Sem r
-            VChild c -> addVisitStep prod $ ChildIntro c
-            _        -> return ()
-        -- Now group by child, and do a visit for each child
-        let chs = groupSortBy (comparing getAttrChildName) $ chattrs
-        chvs <- forM chs $ \childvs -> do -- childs :: [Vertex]
-          let cinhs = map getAttrName $ filter isChildInh childvs
-          let csyns = map getAttrName $ filter isChildSyn childvs
-          let cname = getAttrChildName $ head childvs
-          -- Insert a new pending edge for this visit
-          curstate <- getChildState prod cname
-          target   <- createPending curstate (Set.fromList cinhs) (Set.fromList csyns)
-          addChildVisit prod cname target
-        -- Add child visits as simultanuous step
-        when (not $ null chvs) $
-          if (length chvs == 1)
-          then addVisitStep prod $ head chvs
-          else addVisitStep prod $ Sim chvs
-
-    -- Mark this edge as final
-    markFinal pend
-  -- We are done
-  -- traceVG "Done."
-  return initvs
-
--- | groupBy that groups all equal (according to the function) elements instead of consequtive equal elements
-groupSortBy :: (a -> a -> Ordering) -> [a] -> [[a]]
-groupSortBy f = groupBy (\x y -> f x y == EQ) . sortBy f
-
-type ChildVisits = [(Vertex,Int)]
-
--- | Helper function for folding over child visits
-foldChildVisits :: VGProd -> (ChildVisits, Int) -> Vertex -> VG s (ChildVisits, Int)
-foldChildVisits prod (vis,i) v = do
-  (nvis,ni) <- findChildVisits prod v vis
-  return (nvis, ni `max` i)
-
--- | Recursively find all visits to childs
-findChildVisits :: VGProd -> Vertex -> ChildVisits -> VG s (ChildVisits, Int)
-findChildVisits prod v vis = do
-  case lookup v vis of
-    Just i  -> return (vis,i)
-    Nothing -> do
-      final <- isDepGraphVertexFinal prod v
-      if final
-        then return (vis,0)
-        else do
-          succs <- onMarkedDepGraph (liftM Set.toList . flip graphSuccessors v . pdgmDepGraph) prod
-          (nvis,ni)  <- foldM (foldChildVisits prod) (vis,0) succs
-          if isChildSyn v
-            then return ((v,ni + 1) : nvis, ni + 1)
-            else return ((v,ni) : nvis, ni)
-
--- | Correct inherited child visits after foldChildVisits
-correctInhChilds :: VGProd -> ChildVisits -> VG s ChildVisits
-correctInhChilds prod vis =
-  forM vis $ \(v,i) -> do
-    if isChildInh v
-     then do
-      preds <- onMarkedDepGraph (liftM Set.toList . flip graphPredecessors v . pdgmDepGraph) prod
-      let ni = foldl min 99999999 $ mapMaybe (`lookup` vis) preds
-      return (v,ni)
-     else if not $ isChildSyn v
-           then do
-            succs <- onMarkedDepGraph (liftM Set.toList . flip graphSuccessors v . pdgmDepGraph) prod
-            let ni = foldl max (-1) $ mapMaybe (`lookup` vis) succs
-            return (v,ni+1)
-           else return (v,i)
-
--- | Synthesized attributes that can also be evaluated
-extraChildSyn :: VGProd -> ChildVisits -> VG s ChildVisits
-extraChildSyn prod vis = do
-  allpreds <- forM vis $ \(v,_) -> do
-    if isChildInh v
-     then do
-      preds <- onMarkedDepGraph (liftM Set.toList . flip graphPredecessors v . pdgmDepGraph) prod
-      return $ Set.fromList $ filter isChildSyn preds
-     else return Set.empty
-  lextravis <- forM (Set.toList $ Set.unions allpreds) $ \v -> do
-    ready <- isReadyVertex prod vis v
-    return $ maybe Nothing (\i -> Just (v,i)) ready
-  return $ catMaybes lextravis
-
--- | Check if a vertex can be marked final in this step (and is not final yet) and return the visit num
-isReadyVertex :: VGProd -> ChildVisits -> Vertex -> VG s (Maybe Int)
-isReadyVertex prod vis v = do
-  final <- isDepGraphVertexFinal prod v
-  if v `elem` (map fst vis) || final
-    then return Nothing
-    else do
-      succ <- onMarkedDepGraph (flip graphSuccessors v . pdgmDepGraph) prod
-      rd <- mapM (\x -> do case lookup x vis of
-                             Just i  -> return $ Just i
-                             Nothing -> do fin <- isDepGraphVertexFinal prod x
-                                           return $ if fin then Just 1 else Nothing) (Set.toList succ)
-      if all isJust rd
-        then return $ Just $ foldl1 max $ catMaybes rd
-        else return $ Nothing
-
--- | Check if this vertex is a synthesized attribute of a child
-isChildSyn :: Vertex -> Bool
-isChildSyn v = isChildAttr v && getAttrType v == Syn
-
--- | Check if this vertex is an inherited attribute of a child
-isChildInh :: Vertex -> Bool
-isChildInh v = isChildAttr v && getAttrType v == Inh
-
--- | Check if this vertex is an attribute of a child
-isChildAttr :: Vertex -> Bool
-isChildAttr v = isVertexAttr v && getAttrChildName v /= _LHS && getAttrType v /= Loc
-
--- | Create lhs.inh vertex
-createLhsInh :: Identifier -> Vertex
-createLhsInh = VAttr Inh _LHS
-
--- | Create lhs.inh vertex
-createLhsSyn :: Identifier -> Vertex
-createLhsSyn = VAttr Syn _LHS
-
-------------------------------------------------------------
----         Construction of the execution plan           ---
-------------------------------------------------------------
-kennedyWarrenExecutionPlan :: Options -> [NontDependencyInformationM s] -> [[VisitIdentifier]] ->
-                              Set NontermIdent -> TypeSyns -> Derivings -> VG s ExecutionPlan
-kennedyWarrenExecutionPlan opts ndis initvs wr typesyns derivings = do
-  -- Loop over all nonterminals
-  nonts <- forM (zip ndis initvs) $ \(ndi, initv) -> do
-    -- Loop over all productions of this nonterminal
-    prods <- forM (ndimProds ndi) $ \prod -> do
-      -- Construct the visits for this production
-      let inont = ndiNonterminal $ ndimOrig ndi
-      let iprod = pdgProduction $ pdgmOrig prod
-      prodvs <- gets vgProdVisits
-      let thisvisits = filter (\((int,ipr,_),_) -> int == inont && ipr == iprod) $ Map.toList prodvs
-      visits <- forM thisvisits $ \((_,_,vgedg@(VGEdge edg)),rprodvs) -> do
-        edges <- gets vgEdges
-        let (VGNode fr, VGNode to) = imLookup edg edges
-        steps <- vgInST $ readSTRef rprodvs
-        inh   <- getInherited vgedg
-        syn   <- getSynthesized vgedg
-        let kind | monadic opts = VisitMonadic
-                 | otherwise    = VisitPure True
-        return $ Visit edg fr to inh syn steps kind
-      -- Return execution plan for this production
-      return $ EProduction (pdgProduction $ pdgmOrig prod)
-                           (pdgParams     $ pdgmOrig prod)
-               (pdgConstraints $ pdgmOrig prod)
-                           (pdgRules      $ pdgmOrig prod)
-                           (pdgChilds     $ pdgmOrig prod)
-               visits
-    -- Find initial state for this nonterminal
-    VGNode init <- vgFindInitial $ ndiNonterminal $ ndimOrig ndi
-    -- Construct an environment that specifies the next visit of the states that have exactly one
-    nextMap <- mkNextMap init
-    prevMap <- mkPrevMap init
-    -- Return execution plan for this nonterminal
-    return $  ENonterminal (ndiNonterminal $ ndimOrig ndi)
-                           (ndiParams      $ ndimOrig ndi)
-                           (ndiClassCtxs $ ndimOrig ndi)
-                           init
-                           initv
-                           nextMap
-                           prevMap
-                           prods
-                           (ndiRecursive $ ndimOrig ndi)
-                           (ndiHoInfo    $ ndimOrig ndi)
-
-  -- Return complete execution plan
-  return $ ExecutionPlan nonts typesyns wr derivings
-
-------------------------------------------------------------
----         Construction of the single-exit states map   ---
-------------------------------------------------------------
-
--- depth-first traversal over the graph that starts at 'init' and maintains a state 'a'
--- the function 'f' can inspect the prev/next edges per state
-exploreGraph :: (VGNode -> Set VGEdge -> Set VGEdge -> a -> VG s a) -> VGNode -> a -> VG s a
-exploreGraph f (VGNode init) a0 = do
-  exploredRef <- vgInST $ newSTRef IntSet.empty
-  pendingRef  <- vgInST $ newSTRef [init]
-  resRef      <- vgInST $ newSTRef a0
-  outgoingMap <- gets vgOutgoing
-  edgesInfo   <- gets vgEdges
-  let explore = do
-        pending <- vgInST $ readSTRef pendingRef
-        case pending of
-          []     -> return ()
-          (p:ps) -> do
-            vgInST $ writeSTRef pendingRef ps
-            explored <- vgInST $ readSTRef exploredRef
-            if IntSet.member p explored
-              then return ()
-              else do
-                vgInST $ writeSTRef exploredRef (IntSet.insert p explored)
-                case IntMap.lookup p outgoingMap of
-                  Nothing -> return ()
-                  Just outRef -> case IntMap.lookup p outgoingMap of
-                    Nothing -> return ()
-                    Just inRef -> do
-                            outSet  <- vgInST $ readSTRef outRef
-                            inSet   <- vgInST $ readSTRef inRef
-                            sol0    <- vgInST $ readSTRef resRef
-                            sol1    <- f (VGNode p) inSet outSet sol0
-                            vgInST $ writeSTRef resRef sol1
-                            forM_ (Set.elems outSet) $ \(VGEdge edge) ->
-                              case IntMap.lookup edge edgesInfo of
-                                Nothing            -> return ()
-                                Just (_,VGNode to) -> vgInST $ modifySTRef pendingRef (to :)
-            explore
-  explore
-  vgInST $ readSTRef resRef
-
-mkNextMap :: Int -> VG s (Map Int StateCtx)
-mkNextMap start = exploreGraph f (VGNode start) Map.empty where
-  f (VGNode nd) _ edges = updateCountMap nd edges
-
-mkPrevMap :: Int -> VG s (Map Int StateCtx)
-mkPrevMap start = exploreGraph f (VGNode start) Map.empty where
-  f (VGNode nd) edges _ = updateCountMap nd edges
-
-updateCountMap :: Int -> Set VGEdge -> Map Int StateCtx -> VG s (Map Int StateCtx)
-updateCountMap nd edges mp = return $ Map.insert nd v mp where
-    s = Set.size edges
-    v | s == 0    = NoneVis
-      | s == 1    = let [VGEdge v'] = Set.elems edges
-                    in OneVis v'
-      | otherwise = ManyVis
+module KennedyWarren where++import Prelude hiding (init, succ)+import CommonTypes+import Pretty+import Knuth1+import ExecutionPlan+import Debug.Trace+import Control.Monad.ST+import Control.Monad.State+import Control.Monad.Error+import Data.STRef+import Data.Maybe+import Data.List (intersperse, groupBy, partition, sortBy)+import Data.Ord+import qualified ErrorMessages as Err+import PrintErrorMessages ()++import Data.Set (Set)+import qualified Data.Set as Set+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Map.Strict as MapStrict+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet++-- lazy version (does not return errors)+-- FIXME: construct map from nonterminal to intial visit (or state?) and use it in the generation of invokes+kennedyWarrenLazy :: Options -> Set NontermIdent -> [NontDependencyInformation] -> TypeSyns -> Derivings -> ExecutionPlan+kennedyWarrenLazy _ wr ndis typesyns derivings = plan where+  plan  = ExecutionPlan nonts typesyns wr derivings+  nonts = zipWith mkNont ndis nontIds+  nontIds = enumFromThen 1 4+  initvMap = Map.fromList $ zipWith (\ndi initv -> (ndiNonterminal ndi, initv)) ndis nontIds++  mkNont ndi initv = nont where+    nont = ENonterminal+                 (ndiNonterminal ndi)+                 (ndiParams ndi)+                 (ndiClassCtxs ndi)+                 initst+                 [initv]+                 nextMap+                 prevMap+                 prods+                 (ndiRecursive ndi)+                 (ndiHoInfo ndi)+    initst  = initv + 1+    finals  = initv + 2+    nextMap = Map.fromList [(initst, OneVis initv), (finals, NoneVis)]+    prevMap = Map.fromList [(initst, NoneVis), (finals, OneVis initv)]+    prods   = map mkProd (ndiProds ndi)++    mkProd pdi = prod where+      prod = EProduction+               (pdgProduction pdi)+               (pdgParams pdi)+               (pdgConstraints pdi)+               (pdgRules pdi)+               (pdgChilds pdi)+               visits+      visits = [vis]+      vis    = Visit initv initst finals inh syn steps kind+      inh    = Set.fromList $ ndiInh ndi+      syn    = Set.fromList $ ndiSyn ndi+      kind   = VisitPure False+      steps  = childSteps ++ invokeSteps ++ ruleSteps++      childSteps  = [ ChildIntro nm | EChild nm _ _ _ _ _ <- pdgChilds pdi ]+      invokeSteps = [ ChildVisit nm nt v+                    | EChild nm tp _ _ _ _ <- pdgChilds pdi+                    , let nt = extractNonterminal tp+                          v  = Map.findWithDefault (error "child not in initv-map") nt initvMap+                    ]+      ruleSteps   = [ Sem nm | (ERule nm _ _ _ _ _ _ _) <- pdgRules pdi ]+++-- ordered version (may return errors)+kennedyWarrenOrder :: Options -> Set NontermIdent -> [NontDependencyInformation] -> TypeSyns -> Derivings -> Either Err.Error (ExecutionPlan, PP_Doc, PP_Doc)+kennedyWarrenOrder opts wr ndis typesyns derivings = runST $ runErrorT $ do+  indi <- lift $ mapM mkNontDependencyInformationM ndis+  lift $ 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+    -- Topological sort+    --tsedg <- graphTopSort g+    -- Cyclicity check+    ntCycVerts <- lift $ graphCyclicVerticesExt g+    when (not $ null ntCycVerts) $ do+      throwError $ Err.Cyclic nont Nothing (map show ntCycVerts)+--      let msg = "Nonterminal graph " ++ show nont ++ " is cylic!"+--      fail msg+    -- Transtive closure check+    trc <- lift $ graphIsTRC g+    when (not trc) $ do+      let msg = "Nonterminal graph " ++ show nont ++ " is not transitively closed!"+      fail msg+    -- Consistency check+    cons <- lift $ graphCheckConsistency g+    when (not cons) $ do+      let msg = "Nonterminal graph " ++ show nont ++ " is not consistent!"+      fail msg++    -- Loop trough all productions+    forM_ (ndimProds ndi) $ \prod -> do+      let pr = pdgProduction $ pdgmOrig prod+      let g' = pdgmDepGraph $ prod+      -- Topsort+      --addTopSortEdges tsedg prod+      -- Check for cyclicity+      pdCycVerts <- lift $ graphCyclicVerticesExt g'+      when (not $ null pdCycVerts) $ do+        throwError $ Err.Cyclic nont (Just pr) (map show pdCycVerts)+        -- let msg = "Production graph " ++ show pr ++ " of nonterminal "+        --                               ++ show nont ++ " is cylic!"+        -- fail msg+      -- Transtive closure check+      trc' <- lift $ graphIsTRC g'+      when (not trc') $ do+        lift $ traceST $ "Production graph " ++ show pr ++ " of nonterminal "+                                             ++ show nont ++ " is not transitively closed!"+        fail "Production graph is not transitively closed."+      -- Check consistency+      consistent <- lift $ graphCheckConsistency g'+      when (not consistent) $ do+        let msg =  "Production graph " ++ show pr ++ " of nonterminal "+                                       ++ show nont ++ " is not consistent!"+        fail msg+  -- reachable when everything is ok+  lift $ do+        -- Create non-transitive closed graph for efficiency+        indi' <- undoTransitiveClosure indi+        -- Graphviz output of dependency graphs+        gvs <- mapM toGVNontDependencyInfo indi'+        -- Doing kennedywarren+        (ret, visitg) <- runVG $ do+         -- traceVG $ "Running kennedy-warren..."+         initvs <- kennedyWarrenVisitM wr indi'+         -- Print some debug info+         nodes <- gets vgNodeNum+         edges <- gets vgEdgeNum+         when (not $ beQuiet opts) $ do+           traceVG $ "Number of nodes = " ++ show nodes+           traceVG $ "Number of edges = " ++ show edges+         -- Generate execution plan+         ex <- kennedyWarrenExecutionPlan opts indi' initvs wr typesyns derivings+         -- Get visit graph+         visitg <- toGVVisitGraph+         return (ex,visitg)+        -- Return the result+        return (ret, vlist gvs, visitg)++-------------------------------------------------------------------------------+--         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 "")++toGVVisitGraph :: VG s PP_Doc+toGVVisitGraph = do+  ndis <- gets vgNDI+  noded <- forM (IntMap.toList ndis) $ \(n,rndi) -> do+    ndi <- vgInST $ readSTRef rndi+    return $ "node_" >|< n >#< "[label=\"" >|< ndiNonterminal (ndimOrig ndi) >|< "_" >|< n >|< "\"];"+  edges <- gets vgEdges+  edged <- forM (IntMap.toList edges) $ \(edg,(VGNode from,VGNode to)) -> do+    inh <- getInherited (VGEdge edg)+    syn <- getSynthesized (VGEdge edg)+    return $ "node_" >|< from >#< "-> node_" >|< to >#< "[label=\"visit v" >|< edg+      >|< "\\ninh:" >#< (concat $ intersperse ", " $ map show $ Set.toList inh) >|< "\\nsyn: " >|< (concat $ intersperse ", " $ map show $ Set.toList syn) >|< "\"];"+  return $ "digraph visitgraph { " >-< vlist noded >-< vlist edged >-< "}"++-------------------------------------------------------------------------------+--         Kennedy-Warren in monadic style+-------------------------------------------------------------------------------+{-+runVG                    :: VG s a -> ST s a+insertInitialNode        :: NontDependencyInformationM s -> VG s VGNode+createPending            :: VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge+selectPending            :: VG s VGEdge+getInherited             :: VGEdge -> VG s (Set Identifier)+getSynthesized           :: VGEdge -> VG s (Set Identifier)+markFinal                :: VGEdge -> VG s ()+getProductions           :: VGEdge -> VG s [VGProd]+onMarkedDepGraph         :: (ProdDependencyGraphM s -> ST s a) -> VGProd -> VG s a+isDepGraphVertexFinal    :: VGProd -> Vertex -> VG s Bool+setDepGraphVerticesFinal :: VGProd -> [Vertex] -> VG s ()+getChildState            :: VGProd -> Identifier -> VG s VGNode+addChildVisit            :: VGProd -> Identifier -> VGEdge -> VG s VisitStep+addVisitStep             :: VGProd -> VisitStep -> VG s ()+repeatM                  :: VG s () -> VG s ()+-}++newtype VGNode = VGNode Int deriving (Show,Eq,Ord)+newtype VGEdge = VGEdge Int deriving (Show,Eq,Ord)+newtype VGProd = VGProd (VGEdge,Int) deriving (Show,Eq,Ord)++data VGState s = VGState { vgNodeNum       :: Int+                         , vgEdgeNum       :: Int+                           -- Node maps+                         , vgOutgoing      :: IntMap (STRef s (Set VGEdge))+                         , vgIncoming      :: IntMap (Maybe VGEdge)+                         , vgNDI           :: IntMap (STRef s (NontDependencyInformationM s))+                         , vgInhSynNode    :: Map (Identifier, Set Identifier, Set Identifier) VGNode+                         , vgNodeInhSyn    :: IntMap (Set Identifier, Set Identifier)+                         , vgInitial       :: Map Identifier VGNode+                           -- Edge maps+                         , vgEdges         :: IntMap (VGNode, VGNode)+                         , vgEdgesR        :: Map (VGNode,VGNode) VGEdge+                         , vgInherited     :: IntMap (Set Identifier)+                         , vgSynthesized   :: IntMap (Set Identifier)+                         , vgPending       :: IntSet+                         , vgChildVisits   :: IntMap (STRef s (Map (Identifier,Int) [VGNode]))+                           -- Final vertices in production graphs+                         , vgFinalVertices :: IntMap (STRef s (Set (Vertex,Int)))+                           -- Construction of execution plan (Nonterminal,Production,Visit)+                         , vgProdVisits    :: Map (Identifier,Identifier,VGEdge) (STRef s [VisitStep])+                         }++type VG s a = ErrorT String (StateT (VGState s) (ST s)) a++------------------------------------------------------------+---              Public functions                        ---+------------------------------------------------------------+-- | Run the VG monad in the ST monad+runVG :: VG s a -> ST s a+runVG vg = do result <- runStateT (runErrorT vg) vgEmptyState+              let (Right a,_) = result+              return a++-- | Insert an initial node for this nonterminal into the visit graph+insertInitialNode :: NontDependencyInformationM s -> VG s VGNode+insertInitialNode ndi = do+  rndi          <- vgInST $ newSTRef ndi+  (VGNode node) <- vgCreateNode rndi Set.empty Set.empty+  initial       <- gets vgInitial+  incoming      <- gets vgIncoming+  modify $ \st -> st { vgInitial  = Map.insert (ndiNonterminal $ ndimOrig ndi) (VGNode node) initial+                     , vgIncoming = IntMap.insert node Nothing incoming }+  return (VGNode node)++-- | Create a pending edge from this node with a set of inherited and synthesized attributes+createPending :: VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge+createPending vgn@(VGNode n) inh syn = do+  -- Check if target node already exists+  ninhsyn <- gets vgNodeInhSyn+  let (pinh,psyn) = imLookup n ninhsyn+  let ninh        = Set.union pinh inh+  let nsyn        = Set.union psyn syn+  mndi    <- gets vgNDI+  let rndi = imLookup n mndi+  ndi     <- vgInST $ readSTRef rndi+  inhsynn <- gets vgInhSynNode+  case Map.lookup (ndiNonterminal $ ndimOrig ndi, ninh, nsyn) inhsynn of+    Just tn -> do+      when (tn == vgn) $ do traceVG $ "Source and target nodes are the same!"+                            traceVG $ "Maybe there is a wrapper with no inherited or synthesized attributes."+                            traceVG $ "Inh: " ++ show inh+                            traceVG $ "Syn: " ++ show syn+                            traceVG $ "PInh: " ++ show pinh+                            traceVG $ "PSyn: " ++ show psyn+      -- tn is target node, now check if edge exists and create if not+      edgesr <- gets vgEdgesR+      case Map.lookup (vgn,tn) edgesr of+        Just e  -> return e+        Nothing -> vgCreatePendingEdge vgn tn inh syn+    Nothing -> do+      -- target node does not exist, create it and then create the new edge+      tn <- vgCreateNode rndi ninh nsyn+      vgCreatePendingEdge vgn tn inh syn++-- | Return an arbitrary pending edge of which the from node is ready+selectPending :: VG s VGEdge+selectPending = do+  pending  <- gets vgPending+  incoming <- gets vgIncoming+  edges    <- gets vgEdges+  let readyPend = filter (\p -> let (VGNode fr,_) = imLookup p edges+                                in  isJust $ IntMap.lookup fr incoming) $ IntSet.toList pending+  guard $ not $ null readyPend+  return $ VGEdge $ head $ readyPend++-- | Get the inherited attributes of an edge+getInherited :: VGEdge -> VG s (Set Identifier)+getInherited (VGEdge edg) = do+  inhs <- gets vgInherited+  return $ imLookup edg inhs++-- | Get the synthesized attributes of an edge+getSynthesized :: VGEdge -> VG s (Set Identifier)+getSynthesized (VGEdge edg) = do+  syns <- gets vgSynthesized+  return $ imLookup edg syns++-- | Mark an edge as final+markFinal :: VGEdge -> VG s ()+markFinal vgedg@(VGEdge edg) = do+  incoming <- gets vgIncoming+  edges    <- gets vgEdges+  pending  <- gets vgPending+  let (_,VGNode to) = imLookup edg edges+  modify $ \st -> st { vgIncoming = IntMap.insert to (Just vgedg) incoming+                     , vgPending  = IntSet.delete edg pending }++-- | Get all productions for an edge+getProductions :: VGEdge -> VG s [VGProd]+getProductions vedg@(VGEdge edg) = do+  edges <- gets vgEdges+  let (VGNode fr,_) = imLookup edg edges+  ndis <- gets vgNDI+  let rndi = imLookup fr ndis+  ndi <- vgInST $ readSTRef rndi+  return $ map (\x -> VGProd (vedg,x)) [0..(length $ ndimProds ndi)-1]++-- | Execute a function on the dependency graph for this production+onMarkedDepGraph :: (ProdDependencyGraphM s -> ST s a) -> VGProd -> VG s a+onMarkedDepGraph f (VGProd (VGEdge edg, n)) = do+  edges <- gets vgEdges+  let (VGNode fr,_) = imLookup edg edges+  ndis <- gets vgNDI+  let rndi = imLookup fr ndis+  ndi <- vgInST $ readSTRef rndi+  vgInST $ f $ (ndimProds ndi) !! n -- not efficient, but lists are usually short++-- | Check whether this vertex has been marked as final+isDepGraphVertexFinal :: VGProd -> Vertex -> VG s Bool+isDepGraphVertexFinal (VGProd (VGEdge edg, p)) v = do+  edges <- gets vgEdges+  let (from,_) = imLookup edg edges+  vgDepGraphVertexFinal from p v++-- | Mark these vertices final in this production+setDepGraphVerticesFinal :: VGProd -> [Vertex] -> VG s ()+setDepGraphVerticesFinal (VGProd (VGEdge edg, p)) vs = do+  edges   <- gets vgEdges+  let (_,VGNode to) = imLookup edg edges+  finalv <- gets vgFinalVertices+  let rfinalv       = imLookup to finalv+  vgInST $ modifySTRef rfinalv $ Set.union (Set.fromList $ map (\v -> (v,p)) vs)++-- | Add a child visit to this production and return the step for the execution plan+addChildVisit :: VGProd -> Identifier -> VGEdge -> VG s VisitStep+addChildVisit (VGProd (VGEdge edg, p)) ide (VGEdge vs) = do+  edges   <- gets vgEdges+  let (VGNode from,vgto) = imLookup vs edges -- from must be equal to the current state+  childvs <- gets vgChildVisits+  let rchildv = imLookup edg childvs+  vgInST $ modifySTRef rchildv $ MapStrict.insertWith (++) (ide,p) [vgto]+  ndis <- gets vgNDI+  let rndi = imLookup from ndis+  ndi <- vgInST $ readSTRef rndi+  let nt = ndiNonterminal $ ndimOrig ndi+  return $ ChildVisit ide nt vs++-- | Add a step to the execution plan of this visit+addVisitStep :: VGProd -> VisitStep -> VG s ()+addVisitStep (VGProd (VGEdge edg, p)) st = do+  edges <- gets vgEdges+  let (VGNode fr,_) = imLookup edg edges+  ndis <- gets vgNDI+  let rndi = imLookup fr ndis+  ndi <- vgInST $ readSTRef rndi+  prodvs <- gets vgProdVisits+  let nont = ndiNonterminal $ ndimOrig ndi+  let prod = pdgProduction $ pdgmOrig $ ndimProds ndi !! p+  let Just rprodv = Map.lookup (nont, prod, VGEdge edg) prodvs+  vgInST $ modifySTRef rprodv (++ [st])++-- | Get the state of a child in a certain production+getChildState :: VGProd -> Identifier -> VG s VGNode+getChildState (VGProd (VGEdge edg,p)) ide = do+  childvs <- gets vgChildVisits+  let rchildv = imLookup edg childvs+  childv  <- vgInST $ readSTRef rchildv+  case Map.lookup (ide,p) childv of+    Just (n:_) -> return n+    _          -> do+      -- Look for previous edge+      edges <- gets vgEdges+      let (VGNode from,_) = imLookup edg edges+      incoming <- gets vgIncoming+      case IntMap.lookup from incoming of+        Just (Just iedg) -> getChildState (VGProd (iedg,p)) ide+        Just Nothing     -> do+          -- Lookup initial state+          ndis <- gets vgNDI+          let rndi = imLookup from ndis+          ndi  <- vgInST $ readSTRef rndi+          let Just nt = lookup ide $ pdgChildMap $ pdgmOrig $ (ndimProds ndi) !! p+          vgFindInitial nt+        Nothing          -> error "getChildState"++-- | Repeat action untill mzero is encountered+repeatM :: VG s () -> VG s ()+repeatM m = catchError (m >> repeatM m) (const $ return ())++------------------------------------------------------------+---              Internal functions                      ---+------------------------------------------------------------+-- | Execute a ST action inside the VG monad+vgInST :: ST s a -> VG s a+vgInST = lift . lift++vgEmptyState :: VGState s+vgEmptyState = VGState { vgNodeNum       = 0+                       , vgEdgeNum       = 0+                       , vgOutgoing      = IntMap.empty+                       , vgIncoming      = IntMap.empty+                       , vgNDI           = IntMap.empty+                       , vgInhSynNode    = Map.empty+                       , vgNodeInhSyn    = IntMap.empty+                       , vgInitial       = Map.empty+                       , vgEdges         = IntMap.empty+                       , vgEdgesR        = Map.empty+                       , vgInherited     = IntMap.empty+                       , vgSynthesized   = IntMap.empty+                       , vgPending       = IntSet.empty+                       , vgChildVisits   = IntMap.empty+                       , vgFinalVertices = IntMap.empty+                       , vgProdVisits    = Map.empty+                       }+-- | Create a new node+vgCreateNode :: STRef s (NontDependencyInformationM s) -> Set Identifier -> Set Identifier -> VG s VGNode+vgCreateNode rndi inh syn = do+  num      <- gets vgNodeNum+  outgoing <- gets vgOutgoing+  inhsyn   <- gets vgInhSynNode+  ninhsyn  <- gets vgNodeInhSyn+  ndi      <- gets vgNDI+  finalv   <- gets vgFinalVertices+  rout     <- vgInST $ newSTRef Set.empty+  rfinalv  <- vgInST $ newSTRef Set.empty+  nndi     <- vgInST $ readSTRef rndi+  modify $ \st -> st { vgNodeNum       = num + 1+                     , vgOutgoing      = IntMap.insert num rout outgoing+                     , vgInhSynNode    = Map.insert (ndiNonterminal $ ndimOrig nndi,inh,syn) (VGNode num) inhsyn+                     , vgNodeInhSyn    = IntMap.insert num (inh,syn) ninhsyn+                     , vgNDI           = IntMap.insert num rndi ndi+                     , vgFinalVertices = IntMap.insert num rfinalv finalv }+  return $ VGNode num++-- | Create a new pending edge+vgCreatePendingEdge :: VGNode -> VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge+vgCreatePendingEdge vgn1@(VGNode n1) vgn2 inh syn = do+  num      <- gets vgEdgeNum+  edges    <- gets vgEdges+  edgesr   <- gets vgEdgesR+  inhs     <- gets vgInherited+  syns     <- gets vgSynthesized+  outgoing <- gets vgOutgoing+  pend     <- gets vgPending+  childv   <- gets vgChildVisits+  rchildv  <- vgInST $ newSTRef Map.empty+  let outr    = imLookup n1 outgoing+  let ret     = VGEdge num+  vgInST $ modifySTRef outr (Set.insert ret)+  modify $ \st -> st { vgEdgeNum     = num + 1+                     , vgEdges       = IntMap.insert num (vgn1,vgn2) edges+                     , vgEdgesR      = Map.insert (vgn1,vgn2) ret edgesr+                     , vgPending     = IntSet.insert num pend+                     , vgInherited   = IntMap.insert num inh inhs+                     , vgSynthesized = IntMap.insert num syn syns+                     , vgChildVisits = IntMap.insert num rchildv childv }+  -- Add prod visits (for constructing an execution plan)+  ndis <- gets vgNDI+  let rndi = imLookup n1 ndis+  ndi <- vgInST $ readSTRef rndi+  prodv  <- gets vgProdVisits+  refs   <- forM (ndimProds ndi) $ \prod -> do+    rprod <- vgInST $ newSTRef []+    return ((ndiNonterminal $ ndimOrig ndi, pdgProduction $ pdgmOrig prod, ret),rprod)+  modify $ \st -> st { vgProdVisits = Map.union (Map.fromList refs) prodv }+  return $ ret++-- | Check whether a vertex is marked final on this node in this production+vgDepGraphVertexFinal :: VGNode -> Int -> Vertex -> VG s Bool+vgDepGraphVertexFinal (VGNode n) p v = do+  finalv <- gets vgFinalVertices+  let rfinalv = imLookup n finalv+  curset <- vgInST $ readSTRef rfinalv+  if Set.member (v,p) curset+    then return True+    else do+      incoming <- gets vgIncoming+      case IntMap.lookup n incoming of+        Just (Just (VGEdge edg)) -> do+          edges <- gets vgEdges+          let (fr,_) = imLookup edg edges+          vgDepGraphVertexFinal fr p v+        Just Nothing -> return False+        Nothing      -> error "This can never happen"++-- | Find the initial node for a nonterminal+vgFindInitial :: Identifier -> VG s VGNode+vgFindInitial nt = do+  initial <- gets vgInitial+  let Just r = Map.lookup nt initial+  return r++-- | Always succeeding IntMap lookup+imLookup :: Int -> IntMap a -> a+imLookup k m = let Just r = IntMap.lookup k m in r++-- | Trace inside the vg monad+traceVG :: String -> VG s ()+traceVG s = trace s (return ())++------------------------------------------------------------+---         The kennedy warren algorithm                 ---+------------------------------------------------------------+{-+runVG                    :: VG s a -> ST s a+insertInitialNode        :: NontDependencyInformationM s -> VG s VGNode+createPending            :: VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge+selectPending            :: VG s VGEdge+getInherited             :: VGEdge -> VG s (Set Identifier)+getSynthesized           :: VGEdge -> VG s (Set Identifier)+markFinal                :: VGEdge -> VG s ()+getProductions           :: VGEdge -> VG s [VGProd]+onMarkedDepGraph         :: (ProdDependencyGraphM s -> ST s a) -> VGProd -> VG s a+isDepGraphVertexFinal    :: VGProd -> Vertex -> VG s Bool+setDepGraphVerticesFinal :: VGProd -> [Vertex] -> VG s ()+getChildState            :: VGProd -> Identifier -> VG s VGNode+addChildVisit            :: VGProd -> Identifier -> VGEdge -> VG s VisitStep+addVisitStep             :: VGProd -> VisitStep -> VG s ()+repeatM                  :: VG s () -> VG s ()+-}++kennedyWarrenVisitM :: Set NontermIdent -> [NontDependencyInformationM s] -> VG s [[VisitIdentifier]]+kennedyWarrenVisitM wr ndis = do+  -- Create initial nodes and edges (edges only for wrapper nodes)+  initvs <- forM ndis $ \ndi -> do+    nd <- insertInitialNode ndi+    let inh = Set.fromList $ ndiInh $ ndimOrig ndi+    let syn = Set.fromList $ ndiSyn $ ndimOrig ndi+    if (Set.member (ndiNonterminal $ ndimOrig $ ndi) wr) && (not (Set.null inh) || not (Set.null syn))+      then do+        VGEdge initv <- createPending nd inh syn+        return [initv]+      else return []+  -- Handle all pending edges while there are any+  repeatM $ do+    pend  <- selectPending+    prods <- getProductions pend+    inhs  <- getInherited pend+    syns  <- getSynthesized pend+    -- Handle each production for this edge+    forM_ prods $ \prod -> do+      -- Mark all inherited attributes as final+      setDepGraphVerticesFinal prod (map createLhsInh . Set.toList $ inhs)+      -- Find depth of all synthesized child visits+      (vis,_) <- foldM (foldChildVisits prod) ([],0) (map createLhsSyn . Set.toList $ syns)+      -- Mark them as final+      setDepGraphVerticesFinal prod (map fst vis)+      -- Change the inherited child visits+      vis2 <- correctInhChilds prod vis+      -- Add all synthesized attributes that are also ready but are not needed+      extravis <- extraChildSyn prod vis2+      setDepGraphVerticesFinal prod (map fst extravis)+      -- Group by visit number and do visit for every num+      let gvis = groupSortBy (comparing snd) $ vis2 ++ extravis+      forM_ gvis $ \vis3 -> do+        -- Split child visits from rules+        let (chattrs, rules) = partition isChildAttr $ map fst vis3+        -- Evaluate all rules+        forM_ (reverse $ rules) $ \rule ->+          case rule of+            VRule r  -> addVisitStep prod $ Sem r+            VChild c -> addVisitStep prod $ ChildIntro c+            _        -> return ()+        -- Now group by child, and do a visit for each child+        let chs = groupSortBy (comparing getAttrChildName) $ chattrs+        chvs <- forM chs $ \childvs -> do -- childs :: [Vertex]+          let cinhs = map getAttrName $ filter isChildInh childvs+          let csyns = map getAttrName $ filter isChildSyn childvs+          let cname = getAttrChildName $ head childvs+          -- Insert a new pending edge for this visit+          curstate <- getChildState prod cname+          target   <- createPending curstate (Set.fromList cinhs) (Set.fromList csyns)+          addChildVisit prod cname target+        -- Add child visits as simultanuous step+        when (not $ null chvs) $+          if (length chvs == 1)+          then addVisitStep prod $ head chvs+          else addVisitStep prod $ Sim chvs++    -- Mark this edge as final+    markFinal pend+  -- We are done+  -- traceVG "Done."+  return initvs++-- | groupBy that groups all equal (according to the function) elements instead of consequtive equal elements+groupSortBy :: (a -> a -> Ordering) -> [a] -> [[a]]+groupSortBy f = groupBy (\x y -> f x y == EQ) . sortBy f++type ChildVisits = [(Vertex,Int)]++-- | Helper function for folding over child visits+foldChildVisits :: VGProd -> (ChildVisits, Int) -> Vertex -> VG s (ChildVisits, Int)+foldChildVisits prod (vis,i) v = do+  (nvis,ni) <- findChildVisits prod v vis+  return (nvis, ni `max` i)++-- | Recursively find all visits to childs+findChildVisits :: VGProd -> Vertex -> ChildVisits -> VG s (ChildVisits, Int)+findChildVisits prod v vis = do+  case lookup v vis of+    Just i  -> return (vis,i)+    Nothing -> do+      final <- isDepGraphVertexFinal prod v+      if final+        then return (vis,0)+        else do+          succs <- onMarkedDepGraph (liftM Set.toList . flip graphSuccessors v . pdgmDepGraph) prod+          (nvis,ni)  <- foldM (foldChildVisits prod) (vis,0) succs+          if isChildSyn v+            then return ((v,ni + 1) : nvis, ni + 1)+            else return ((v,ni) : nvis, ni)++-- | Correct inherited child visits after foldChildVisits+correctInhChilds :: VGProd -> ChildVisits -> VG s ChildVisits+correctInhChilds prod vis =+  forM vis $ \(v,i) -> do+    if isChildInh v+     then do+      preds <- onMarkedDepGraph (liftM Set.toList . flip graphPredecessors v . pdgmDepGraph) prod+      let ni = foldl min 99999999 $ mapMaybe (`lookup` vis) preds+      return (v,ni)+     else if not $ isChildSyn v+           then do+            succs <- onMarkedDepGraph (liftM Set.toList . flip graphSuccessors v . pdgmDepGraph) prod+            let ni = foldl max (-1) $ mapMaybe (`lookup` vis) succs+            return (v,ni+1)+           else return (v,i)++-- | Synthesized attributes that can also be evaluated+extraChildSyn :: VGProd -> ChildVisits -> VG s ChildVisits+extraChildSyn prod vis = do+  allpreds <- forM vis $ \(v,_) -> do+    if isChildInh v+     then do+      preds <- onMarkedDepGraph (liftM Set.toList . flip graphPredecessors v . pdgmDepGraph) prod+      return $ Set.fromList $ filter isChildSyn preds+     else return Set.empty+  lextravis <- forM (Set.toList $ Set.unions allpreds) $ \v -> do+    ready <- isReadyVertex prod vis v+    return $ maybe Nothing (\i -> Just (v,i)) ready+  return $ catMaybes lextravis++-- | Check if a vertex can be marked final in this step (and is not final yet) and return the visit num+isReadyVertex :: VGProd -> ChildVisits -> Vertex -> VG s (Maybe Int)+isReadyVertex prod vis v = do+  final <- isDepGraphVertexFinal prod v+  if v `elem` (map fst vis) || final+    then return Nothing+    else do+      succ <- onMarkedDepGraph (flip graphSuccessors v . pdgmDepGraph) prod+      rd <- mapM (\x -> do case lookup x vis of+                             Just i  -> return $ Just i+                             Nothing -> do fin <- isDepGraphVertexFinal prod x+                                           return $ if fin then Just 1 else Nothing) (Set.toList succ)+      if all isJust rd+        then return $ Just $ foldl1 max $ catMaybes rd+        else return $ Nothing++-- | Check if this vertex is a synthesized attribute of a child+isChildSyn :: Vertex -> Bool+isChildSyn v = isChildAttr v && getAttrType v == Syn++-- | Check if this vertex is an inherited attribute of a child+isChildInh :: Vertex -> Bool+isChildInh v = isChildAttr v && getAttrType v == Inh++-- | Check if this vertex is an attribute of a child+isChildAttr :: Vertex -> Bool+isChildAttr v = isVertexAttr v && getAttrChildName v /= _LHS && getAttrType v /= Loc++-- | Create lhs.inh vertex+createLhsInh :: Identifier -> Vertex+createLhsInh = VAttr Inh _LHS++-- | Create lhs.inh vertex+createLhsSyn :: Identifier -> Vertex+createLhsSyn = VAttr Syn _LHS++------------------------------------------------------------+---         Construction of the execution plan           ---+------------------------------------------------------------+kennedyWarrenExecutionPlan :: Options -> [NontDependencyInformationM s] -> [[VisitIdentifier]] ->+                              Set NontermIdent -> TypeSyns -> Derivings -> VG s ExecutionPlan+kennedyWarrenExecutionPlan opts ndis initvs wr typesyns derivings = do+  -- Loop over all nonterminals+  nonts <- forM (zip ndis initvs) $ \(ndi, initv) -> do+    -- Loop over all productions of this nonterminal+    prods <- forM (ndimProds ndi) $ \prod -> do+      -- Construct the visits for this production+      let inont = ndiNonterminal $ ndimOrig ndi+      let iprod = pdgProduction $ pdgmOrig prod+      prodvs <- gets vgProdVisits+      let thisvisits = filter (\((int,ipr,_),_) -> int == inont && ipr == iprod) $ Map.toList prodvs+      visits <- forM thisvisits $ \((_,_,vgedg@(VGEdge edg)),rprodvs) -> do+        edges <- gets vgEdges+        let (VGNode fr, VGNode to) = imLookup edg edges+        steps <- vgInST $ readSTRef rprodvs+        inh   <- getInherited vgedg+        syn   <- getSynthesized vgedg+        let kind | monadic opts = VisitMonadic+                 | otherwise    = VisitPure True+        return $ Visit edg fr to inh syn steps kind+      -- Return execution plan for this production+      return $ EProduction (pdgProduction $ pdgmOrig prod)+                           (pdgParams     $ pdgmOrig prod)+               (pdgConstraints $ pdgmOrig prod)+                           (pdgRules      $ pdgmOrig prod)+                           (pdgChilds     $ pdgmOrig prod)+               visits+    -- Find initial state for this nonterminal+    VGNode init <- vgFindInitial $ ndiNonterminal $ ndimOrig ndi+    -- Construct an environment that specifies the next visit of the states that have exactly one+    nextMap <- mkNextMap init+    prevMap <- mkPrevMap init+    -- Return execution plan for this nonterminal+    return $  ENonterminal (ndiNonterminal $ ndimOrig ndi)+                           (ndiParams      $ ndimOrig ndi)+                           (ndiClassCtxs $ ndimOrig ndi)+                           init+                           initv+                           nextMap+                           prevMap+                           prods+                           (ndiRecursive $ ndimOrig ndi)+                           (ndiHoInfo    $ ndimOrig ndi)++  -- Return complete execution plan+  return $ ExecutionPlan nonts typesyns wr derivings++------------------------------------------------------------+---         Construction of the single-exit states map   ---+------------------------------------------------------------++-- depth-first traversal over the graph that starts at 'init' and maintains a state 'a'+-- the function 'f' can inspect the prev/next edges per state+exploreGraph :: (VGNode -> Set VGEdge -> Set VGEdge -> a -> VG s a) -> VGNode -> a -> VG s a+exploreGraph f (VGNode init) a0 = do+  exploredRef <- vgInST $ newSTRef IntSet.empty+  pendingRef  <- vgInST $ newSTRef [init]+  resRef      <- vgInST $ newSTRef a0+  outgoingMap <- gets vgOutgoing+  edgesInfo   <- gets vgEdges+  let explore = do+        pending <- vgInST $ readSTRef pendingRef+        case pending of+          []     -> return ()+          (p:ps) -> do+            vgInST $ writeSTRef pendingRef ps+            explored <- vgInST $ readSTRef exploredRef+            if IntSet.member p explored+              then return ()+              else do+                vgInST $ writeSTRef exploredRef (IntSet.insert p explored)+                case IntMap.lookup p outgoingMap of+                  Nothing -> return ()+                  Just outRef -> case IntMap.lookup p outgoingMap of+                    Nothing -> return ()+                    Just inRef -> do+                            outSet  <- vgInST $ readSTRef outRef+                            inSet   <- vgInST $ readSTRef inRef+                            sol0    <- vgInST $ readSTRef resRef+                            sol1    <- f (VGNode p) inSet outSet sol0+                            vgInST $ writeSTRef resRef sol1+                            forM_ (Set.elems outSet) $ \(VGEdge edge) ->+                              case IntMap.lookup edge edgesInfo of+                                Nothing            -> return ()+                                Just (_,VGNode to) -> vgInST $ modifySTRef pendingRef (to :)+            explore+  explore+  vgInST $ readSTRef resRef++mkNextMap :: Int -> VG s (Map Int StateCtx)+mkNextMap start = exploreGraph f (VGNode start) Map.empty where+  f (VGNode nd) _ edges = updateCountMap nd edges++mkPrevMap :: Int -> VG s (Map Int StateCtx)+mkPrevMap start = exploreGraph f (VGNode start) Map.empty where+  f (VGNode nd) edges _ = updateCountMap nd edges++updateCountMap :: Int -> Set VGEdge -> Map Int StateCtx -> VG s (Map Int StateCtx)+updateCountMap nd edges mp = return $ Map.insert nd v mp where+    s = Set.size edges+    v | s == 0    = NoneVis+      | s == 1    = let [VGEdge v'] = Set.elems edges+                    in OneVis v'+      | otherwise = ManyVis
src/Knuth1.hs view
@@ -1,532 +1,532 @@-module Knuth1 where
-
-import Pretty
-import ExecutionPlan
-import CommonTypes
-import Control.Monad
-import Control.Monad.ST
-import Data.Maybe
-import Data.List
-import Data.STRef
-import Debug.Trace
-
-import Data.Array (Array)
-import qualified Data.Array as Array
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Data.Set (Set)
-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   Vertex  IVertex
-                                         , vertexOMap   :: Array IVertex Vertex
-                                         , successors   :: Array IVertex (STRef s (Set IVertex))
-                                         , predecessors :: Array IVertex (STRef s (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 Vertex)
-graphSuccessors g v = do sucs <- readSTRef $ (successors g) Array.! (graphGetIVertex g v)
-                         return $ Set.map (graphGetVertex g) sucs
-
--- | Return all predecessors of a vertex
-graphPredecessors :: DependencyGraph s -> Vertex -> ST s (Set Vertex)
-graphPredecessors g v = do sucs <- readSTRef $ (predecessors 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 the graph
-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 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
-graphInsertEdges :: DependencyGraph s -> [Edge] -> ST s ()
-graphInsertEdges g ed = mapM_ (graphInsert g) ed
-
--- | 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 IVertex)]]
-                              rets <- mapM (graphInsertTRC g) ed
-                              -- Combine all successor sets
-                              let f    :: (IVertex, (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
-  s <- graphCyclicVertices g
-  return $ not $ Set.null s
-
-graphCyclicVertices :: DependencyGraph s -> ST s (Set IVertex)
-graphCyclicVertices g = do
-  vs <- return $ Array.indices $ vertexOMap g
-  sets <- forM vs $ \v -> do
-            sucs <- readSTRef $ (successors g) Array.! v
-            let res | v `Set.member` sucs = Set.singleton v
-                    | otherwise           = Set.empty
-            return res
-  return (Set.unions sets)
-
-graphCyclicVerticesExt :: DependencyGraph s -> ST s [Vertex]
-graphCyclicVerticesExt g = (map (graphGetVertex g) . Set.elems) `fmap` graphCyclicVertices g
-
--- | 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
-
--- | Add edges to the graph so that it is topologically sorted (this will not work if graph is cyclic)
-graphTopSort :: DependencyGraph s -> ST s [Edge]
-graphTopSort g = do let vs = Array.indices $ vertexOMap g
-                    order <- foldM (graphTopSort' g) [] vs
-                    mb <- forM (zip order (tail order)) $ \(v1,v2) -> do
-                      let edg = graphGetEdge g (v2,v1) -- order is actually reverse order
-                      ce <- graphContainsEdge g edg
-                      if ce
-                        then return Nothing
-                        else do graphInsert g edg
-                                return $ Just edg
-                    return $ catMaybes mb
-
--- | Helper function for graphTopSort
-graphTopSort' :: DependencyGraph s -> [IVertex] -> IVertex -> ST s [IVertex]
-graphTopSort' g prev cur | cur `elem` prev = return prev
-                         | otherwise       = do pred <- readSTRef $ (predecessors g) Array.! cur
-                                                order <- foldM  (graphTopSort' g) prev $ Set.toList pred
-                                                return $ cur : order
-
--------------------------------------------------------------------------------
---         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]
-                                               , pdgRules       :: ERules
-                                               , pdgChilds      :: EChildren
-                                               , pdgProduction  :: Identifier
-                                               , pdgChildMap    :: [(Identifier, Identifier)]
-                                               , pdgConstraints :: [Type]
-                                               , pdgParams      :: [Identifier] }
-
-
--- | Represent all information from the dependency graphs for a nonterminal
-data NontDependencyInformation = NontDependencyInformation { ndiNonterminal :: Identifier
-                                                           , ndiParams      :: [Identifier]
-                                                           , ndiInh         :: [Identifier]
-                                                           , ndiSyn         :: [Identifier]
-                                                           , ndiDepGraph    :: NontDependencyGraph
-                                                           , ndiProds       :: [ProdDependencyGraph]
-                                                           , ndiRecursive   :: Bool
-                                                           , ndiHoInfo      :: HigherOrderInfo
-                                                           , ndiClassCtxs   :: ClassContext
-                                                           }
-
---- 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 transitivelly closed graphs
-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)
-                                  forM_ (zip prods (ndimProds ndi)) $ \(nprod,oprod) -> do
-                                    -- All possible edges
-                                    let possa = do (v1,v2) <- edges
-                                                   -- Take a child of this nonterminal type
-                                                   guard $ isVertexAttr v1
-                                                   guard $ isVertexAttr v2
-                                                   let tp = getAttrChildName v1
-                                                   (ch,chtp) <- pdgChildMap $ pdgmOrig nprod
-                                                   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)
-                                    toadd <- filterM (graphContainsEdge (pdgmDepGraph oprod)) possa
-                                    graphInsertEdges (pdgmDepGraph nprod) toadd
-                                  return $ NontDependencyInformationM { ndimOrig     = ndimOrig ndi
-                                                                      , ndimDepGraph = ndimDepGraph ndi
-                                                                      , ndimProds    = prods }
-
-
--------------------------------------------------------------------------------
---         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 per production (initially all prod edges)
---               pndis :: [([[Edge]], NontDependencyInformation)]
-                 pndis <- forM ndis $ \ndi -> do
-                   ipend <- mapM (graphEdges . pdgmDepGraph) . ndimProds $ ndi
-                   return (ipend, ndi)
-                 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' :: [[Edge]]
-                  ndis' <- mapM addProdNont ndis
-                  -- List of all newly added edges
---                ntedge :: [Edge]
-                  let pntedge = concat ndis'
-                  -- Add backedges
-                  --bedges <- addBackEdges ndis
-                  -- All added nonterminal edges
-                  let ntedge = pntedge -- ++ bedges
-                  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'' :: [[[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 (me, ndi)) ndis ndis''
-                            if any (not . null) 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
---   and return the list of newly added nonterminal edges
-addProdNont :: ([[Edge]], NontDependencyInformationM s) -> ST s [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) <- concat 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
-                                when (not $ null toadd) $ do
-                                   graphInsertEdgesTRC nontGraph toadd
-                                   return ()
-                                return toadd
-
--- | Add edges from the nonterminal graphs to the production graphs
---   and return the list of newly added production edges and the updated graph
-addNontProd :: Bool -> ([Edge], NontDependencyInformationM s) -> ST s [[Edge]]
-addNontProd trc (pending, ndi) = do -- Just call the helper function for each nonterminal
-                                    mapM (addNontProd' trc pending) (ndimProds ndi)
-
--- | Helper function for |addNontProd| for a single production
-addNontProd' :: Bool -> [Edge] -> ProdDependencyGraphM s -> ST s [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 []
-                                 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 ret
-
--- | Add the "back edges" to the nonterminal graphs for creating a global ordering
-addBackEdges :: [([[Edge]], NontDependencyInformationM s)] -> ST s [Edge]
-addBackEdges ndis = do -- gather all backedges
-                       lBackEdges <- forM ndis $ \(aedg,ndi) -> do
-                         -- For every production
-                         bs <- forM (zip aedg (ndimProds ndi)) $ \(edg,prod) -> do
-                           -- Filter out the backedges
-                           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 $ foldl' union [] bs
-                       -- Concatenate all lists of backedges
-                       let backedges = foldl' union [] lBackEdges
-                       -- Add backedges to every nonterminal graph
-                       ret <- 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
-                       return $ backedges ++ concat ret
-
-
--- | Add all resulting edges from a topsort on the nonterminal graph to the production graph
---   this will ignore edges that will make the graph cyclic
-addTopSortEdges :: [Edge] -> ProdDependencyGraphM s -> ST s ()
-addTopSortEdges 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
-                              forM_ possa $ \(v1,v2) -> do e1 <- graphContainsEdge prodGraph (v1,v2)
-                                                           e2 <- graphContainsEdge prodGraph (v2,v1)
-                                                           when (not $ e1 || e2) $ do
-                                                             graphInsertTRC prodGraph (v1,v2)
-                                                             return ()
+module Knuth1 where++import Pretty+import ExecutionPlan+import CommonTypes+import Control.Monad+import Control.Monad.ST+import Data.Maybe+import Data.List+import Data.STRef+import Debug.Trace++import Data.Array (Array)+import qualified Data.Array as Array+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+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   Vertex  IVertex+                                         , vertexOMap   :: Array IVertex Vertex+                                         , successors   :: Array IVertex (STRef s (Set IVertex))+                                         , predecessors :: Array IVertex (STRef s (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 Vertex)+graphSuccessors g v = do sucs <- readSTRef $ (successors g) Array.! (graphGetIVertex g v)+                         return $ Set.map (graphGetVertex g) sucs++-- | Return all predecessors of a vertex+graphPredecessors :: DependencyGraph s -> Vertex -> ST s (Set Vertex)+graphPredecessors g v = do sucs <- readSTRef $ (predecessors 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 the graph+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 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+graphInsertEdges :: DependencyGraph s -> [Edge] -> ST s ()+graphInsertEdges g ed = mapM_ (graphInsert g) ed++-- | 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 IVertex)]]+                              rets <- mapM (graphInsertTRC g) ed+                              -- Combine all successor sets+                              let f    :: (IVertex, (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+  s <- graphCyclicVertices g+  return $ not $ Set.null s++graphCyclicVertices :: DependencyGraph s -> ST s (Set IVertex)+graphCyclicVertices g = do+  vs <- return $ Array.indices $ vertexOMap g+  sets <- forM vs $ \v -> do+            sucs <- readSTRef $ (successors g) Array.! v+            let res | v `Set.member` sucs = Set.singleton v+                    | otherwise           = Set.empty+            return res+  return (Set.unions sets)++graphCyclicVerticesExt :: DependencyGraph s -> ST s [Vertex]+graphCyclicVerticesExt g = (map (graphGetVertex g) . Set.elems) `fmap` graphCyclicVertices g++-- | 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++-- | Add edges to the graph so that it is topologically sorted (this will not work if graph is cyclic)+graphTopSort :: DependencyGraph s -> ST s [Edge]+graphTopSort g = do let vs = Array.indices $ vertexOMap g+                    order <- foldM (graphTopSort' g) [] vs+                    mb <- forM (zip order (tail order)) $ \(v1,v2) -> do+                      let edg = graphGetEdge g (v2,v1) -- order is actually reverse order+                      ce <- graphContainsEdge g edg+                      if ce+                        then return Nothing+                        else do graphInsert g edg+                                return $ Just edg+                    return $ catMaybes mb++-- | Helper function for graphTopSort+graphTopSort' :: DependencyGraph s -> [IVertex] -> IVertex -> ST s [IVertex]+graphTopSort' g prev cur | cur `elem` prev = return prev+                         | otherwise       = do pred <- readSTRef $ (predecessors g) Array.! cur+                                                order <- foldM  (graphTopSort' g) prev $ Set.toList pred+                                                return $ cur : order++-------------------------------------------------------------------------------+--         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]+                                               , pdgRules       :: ERules+                                               , pdgChilds      :: EChildren+                                               , pdgProduction  :: Identifier+                                               , pdgChildMap    :: [(Identifier, Identifier)]+                                               , pdgConstraints :: [Type]+                                               , pdgParams      :: [Identifier] }+++-- | Represent all information from the dependency graphs for a nonterminal+data NontDependencyInformation = NontDependencyInformation { ndiNonterminal :: Identifier+                                                           , ndiParams      :: [Identifier]+                                                           , ndiInh         :: [Identifier]+                                                           , ndiSyn         :: [Identifier]+                                                           , ndiDepGraph    :: NontDependencyGraph+                                                           , ndiProds       :: [ProdDependencyGraph]+                                                           , ndiRecursive   :: Bool+                                                           , ndiHoInfo      :: HigherOrderInfo+                                                           , ndiClassCtxs   :: ClassContext+                                                           }++--- 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 transitivelly closed graphs+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)+                                  forM_ (zip prods (ndimProds ndi)) $ \(nprod,oprod) -> do+                                    -- All possible edges+                                    let possa = do (v1,v2) <- edges+                                                   -- Take a child of this nonterminal type+                                                   guard $ isVertexAttr v1+                                                   guard $ isVertexAttr v2+                                                   let tp = getAttrChildName v1+                                                   (ch,chtp) <- pdgChildMap $ pdgmOrig nprod+                                                   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)+                                    toadd <- filterM (graphContainsEdge (pdgmDepGraph oprod)) possa+                                    graphInsertEdges (pdgmDepGraph nprod) toadd+                                  return $ NontDependencyInformationM { ndimOrig     = ndimOrig ndi+                                                                      , ndimDepGraph = ndimDepGraph ndi+                                                                      , ndimProds    = prods }+++-------------------------------------------------------------------------------+--         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 per production (initially all prod edges)+--               pndis :: [([[Edge]], NontDependencyInformation)]+                 pndis <- forM ndis $ \ndi -> do+                   ipend <- mapM (graphEdges . pdgmDepGraph) . ndimProds $ ndi+                   return (ipend, ndi)+                 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' :: [[Edge]]+                  ndis' <- mapM addProdNont ndis+                  -- List of all newly added edges+--                ntedge :: [Edge]+                  let pntedge = concat ndis'+                  -- Add backedges+                  --bedges <- addBackEdges ndis+                  -- All added nonterminal edges+                  let ntedge = pntedge -- ++ bedges+                  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'' :: [[[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 (me, ndi)) ndis ndis''+                            if any (not . null) 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+--   and return the list of newly added nonterminal edges+addProdNont :: ([[Edge]], NontDependencyInformationM s) -> ST s [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) <- concat 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+                                when (not $ null toadd) $ do+                                   graphInsertEdgesTRC nontGraph toadd+                                   return ()+                                return toadd++-- | Add edges from the nonterminal graphs to the production graphs+--   and return the list of newly added production edges and the updated graph+addNontProd :: Bool -> ([Edge], NontDependencyInformationM s) -> ST s [[Edge]]+addNontProd trc (pending, ndi) = do -- Just call the helper function for each nonterminal+                                    mapM (addNontProd' trc pending) (ndimProds ndi)++-- | Helper function for |addNontProd| for a single production+addNontProd' :: Bool -> [Edge] -> ProdDependencyGraphM s -> ST s [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 []+                                 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 ret++-- | Add the "back edges" to the nonterminal graphs for creating a global ordering+addBackEdges :: [([[Edge]], NontDependencyInformationM s)] -> ST s [Edge]+addBackEdges ndis = do -- gather all backedges+                       lBackEdges <- forM ndis $ \(aedg,ndi) -> do+                         -- For every production+                         bs <- forM (zip aedg (ndimProds ndi)) $ \(edg,prod) -> do+                           -- Filter out the backedges+                           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 $ foldl' union [] bs+                       -- Concatenate all lists of backedges+                       let backedges = foldl' union [] lBackEdges+                       -- Add backedges to every nonterminal graph+                       ret <- 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+                       return $ backedges ++ concat ret+++-- | Add all resulting edges from a topsort on the nonterminal graph to the production graph+--   this will ignore edges that will make the graph cyclic+addTopSortEdges :: [Edge] -> ProdDependencyGraphM s -> ST s ()+addTopSortEdges 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+                              forM_ possa $ \(v1,v2) -> do e1 <- graphContainsEdge prodGraph (v1,v2)+                                                           e2 <- graphContainsEdge prodGraph (v2,v1)+                                                           when (not $ e1 || e2) $ do+                                                             graphInsertTRC prodGraph (v1,v2)+                                                             return ()
src/LOAG/AOAG.hs view
@@ -1,282 +1,282 @@-{-# LANGUAGE Rank2Types #-}
-
-module LOAG.AOAG where
-
-import LOAG.Common
-import LOAG.Graphs
-import LOAG.Rep
-
-import AbstractSyntax
-import CommonTypes
-import Control.Arrow ((&&&), (***))
-import Control.Monad (forM, forM_, MonadPlus(..), when, unless)
-import Control.Monad.ST
-import Control.Monad.Error (ErrorT(..))
-import Control.Monad.State (MonadState(..))
-import Data.Maybe (fromMaybe, catMaybes, fromJust, isNothing)
-import Data.List (elemIndex, foldl', delete, (\\), insert, nub)
-import Data.STRef
-import Data.Tuple (swap)
-import qualified Data.Set as S
-import qualified Data.IntSet as IS
-import qualified Data.IntMap as IM
-import qualified Data.Map as M
-import           Data.Array.MArray
-import qualified Data.Array as A
-import Data.Array.ST
-import ErrorMessages as Err
-import Pretty
-import UU.Scanner.Position
-
-data Settings = Settings  
-                { -- current minimum ads size
-                  prune_val  :: Int 
-                  -- whether to minimize the number of fake dependencies
-                  -- could be very costly
-                , min_ads :: Bool
-                }
-default_settings = Settings 999 False
-
-type AOAG s a = ST s a
-
--- | Catch a type 3 cycle-error made by a given constructor
--- |  two alternatives are given to proceed
-type ADS = [Edge]
-type AOAGRes =  Either Error LOAGRes
--- | Calculate a total order if the semantics given 
---    originate from a linearly-ordered AG
-
-type2error,limiterror,aoagerror :: Error
-type2error = Err.CustomError False noPos $ text "Type 2 cycle"
-limiterror = Err.CustomError False noPos $ text "Limit reached"
-aoagerror  = Err.CustomError False noPos $ text "Not an LOAG/AOAG"
-
-schedule :: LOAGRep -> Grammar -> Ag -> [Edge] -> AOAGRes
-schedule sem gram@(Grammar _ _ _ _ dats _ _ _ _ _ _ _ _ _) 
-                ag@(Ag bounds_s bounds_p de nts) ads 
-    = runST $ aoag default_settings ads
- where
-    -- get the maps from semantics and translate them to functions    
-    nmp  = (nmp_LOAGRep_LOAGRep  sem)     
-    ofld = (ofld_LOAGRep_LOAGRep sem)       
-    genA = gen_LOAGRep_LOAGRep sem             
-    inss = inss_LOAGRep_LOAGRep sem        
- 
-    -- select candidates, using the edge that caused the cycle
-    -- from the list of intra-thread dependencies 
-    -- (intra-visit dependencies without edges in ids)
-    candidates :: Edge -> Cycle -> [Edge] -> [Edge]
-    candidates _ c = foldr (\(f,t) acc -> 
-                                if f `IS.member` c &&t `IS.member` c
-                                    then (t,f):acc else acc) []
-    -- | Move occurrence to its corresponding attribute 
-    gen :: Vertex -> Vertex
-    gen v = genA A.! v
-
-    genEdge :: Edge -> Edge
-    genEdge (f,t) = (gen f, gen t)
-
-    -- | Decide for a given production edge whether the vertices 
-    --      belong to the same field
-    siblings :: Edge -> Bool
-    siblings (f, t) = ofld A.! f == ofld A.! t
-
-    -- | Given an nonterminal-edge, instantiate it
-    --   assumes that the occurrences of fields are added in the same order
-    instEdge :: Edge -> [Edge]
-    instEdge (f, t) = zip (inss A.! f) (inss A.! t)
- 
-    aoag :: Settings -> [Edge] -> AOAG s AOAGRes
-    aoag cfg init_ads = run
-        where
-            run :: AOAG s AOAGRes
-            run = induced ads >>= detect
-
-            detect (Left err) = return $ Left err
-            detect (Right (dp,idp,ids@(idsf,idst))) = do
-                -- Attribute -> TimeSlot
-                schedA <- mapArray (const Nothing) idsf
-                -- map TimeSlot -> [Attribute]
-                schedS <- newSTRef $ 
-                    foldr (\(Nonterminal nt _ _ _ _) -> M.insert (getName nt) 
-                                (IM.singleton 1 [])) M.empty dats
-                fr_ids <- freeze_graph ids
-                threads <- completing fr_ids (schedA, schedS) nts
-                let (ivd, comp) = fetchEdges fr_ids threads nts
-                eRoC <- m_edp dp init_ads ivd comp (schedA, schedS)
-                case eRoC of
-                    Left res -> return $ Right res
-                    Right (e,c,T3 cs) -> find_ads dp idp ids (schedA, schedS) e c cs
-
-            find_ads :: Graph s -> Graph s -> Graph s -> SchedRef s -> 
-                         Edge -> Cycle -> [Edge] -> AOAG s AOAGRes
-            find_ads dp idp ids sched e cycle comp = do
-                pruner <- newSTRef 999
-                explore dp idp ids sched init_ads pruner e cycle comp
- 
-            explore :: Graph s -> Graph s -> Graph s -> SchedRef s -> 
-                        [Edge] -> STRef s Int -> Edge -> Cycle -> [Edge] ->
-                            AOAG s AOAGRes
-            explore dp idp ids sched@(schedA, schedS) ads pruner e c comp =
-                explore' dp idp ids sched ads (candidates e c comp) pruner
-             where
-              explore' :: Graph s -> Graph s -> Graph s -> SchedRef s -> 
-                          [Edge] -> [Edge] -> STRef s Int -> 
-                            AOAG s AOAGRes
-              explore' _  _   _   _  _   [] _ = return $ Left aoagerror
-              explore' dp idp ids sched@(schedA,schedS) ads (fd:cs) pruner = do
-                  p_val <- readSTRef pruner
-                  if length ads >= p_val -1
-                   then return $ Left limiterror 
-                   else do 
-                    idpf_clone <- mapArray id (fst idp)
-                    idpt_clone <- mapArray id (snd idp)
-                    let idp_c  =  (idpf_clone, idpt_clone)
-                    idsf_clone <- mapArray id (fst ids)
-                    idst_clone <- mapArray id (snd ids)
-                    let ids_c  =  (idsf_clone, idst_clone)
-                    schedA_c   <- mapArray id schedA
-                    schedS_v   <- readSTRef schedS
-                    schedS_c   <- newSTRef schedS_v
-                    let sched_c = (schedA_c, schedS_c)
-    
-                    let runM = reschedule dp idp ids sched 
-                                                (fd:ads) fd pruner
-                    let backtrack = explore' dp idp_c ids_c sched_c ads cs 
-                                        pruner
-                    maoag <- runM
-                    case maoag of 
-                      Left _                 -> backtrack
-                      Right (tdp1,inf1,ads1) -> 
-                            if LOAG.AOAG.min_ads cfg 
-                             then do
-                              writeSTRef pruner (length ads1)
-                              maoag' <- backtrack
-                              case maoag' of
-                                Right (tdp2,inf2,ads2)
-                                          -> return $ Right (tdp2,inf2,ads2)
-                                otherwise -> return $ Right (tdp1,inf1,ads1)
-                             else return $ Right (tdp1,inf1,ads1)
-
-            -- step 1, 2 and 3
-            induced :: [Edge] -> AOAG s (Either Error (Graph s, Graph s, Graph s))
-            induced ads = do
-                dpf  <- newArray bounds_p IS.empty
-                dpt  <- newArray bounds_p IS.empty
-                idpf <- newArray bounds_p IS.empty
-                idpt <- newArray bounds_p IS.empty
-                idsf <- newArray bounds_s IS.empty
-                idst <- newArray bounds_s IS.empty
-                let ids = (idsf,idst)
-                let idp = (idpf,idpt)
-                let dp  = (dpf ,dpt)
-                inducing dp idp ids (de ++ ads) 
-
-            inducing :: Graph s -> Graph s -> Graph s -> [Edge] 
-                            -> AOAG s (Either Error (Graph s, Graph s, Graph s))
-            inducing dp idp ids es = do
-                res <- adds (addD dp idp ids) [] es
-                case res of 
-                    Left _ -> return $ Left $ type2error
-                    Right _  -> return $ Right (dp, idp, ids)
-            addD :: Graph s -> Graph s -> Graph s -> Edge -> AOAG s (Either Error [Edge])
-            addD dp' idp' ids' e = do
-                resd <- e `insErt` dp'
-                resdp <- e `inserT` idp'
-                case resdp of 
-                  Right es  -> adds (addN idp' ids') [] (e:es)
-                  Left c    -> return $ Left $ type2error
-
-            addI :: Graph s -> Graph s -> Edge -> AOAG s (Either Error [Edge])
-            addI idp' ids' e = do
-                exists <- member e idp'
-                if not exists then do
-                    res <- e `inserT` idp'
-                    case res of
-                        Right es -> adds (addN idp' ids') [] es
-                        Left c   -> return $ Left $ type2error
-                 else return $ Right []
-
-            adds f acc [] = return $ Right acc
-            adds f acc (e:es) = do
-                mes <- f e
-                case mes of 
-                    Left err -> return $ Left err
-                    Right news -> adds f (acc++news) es
-
-            addN :: Graph s -> Graph s -> Edge -> AOAG s (Either Error [Edge])
-            addN idp' ids' e = do
-                    if (siblings e) then do
-                        let s_edge = genEdge e
-                        exists <- member s_edge ids'
-                        if not exists then do
-                            _ <- inserT s_edge ids'
-                            let es = instEdge s_edge
-                            addedEx <- adds (addI idp' ids') [] es
-                            case addedEx of
-                                Right news -> return $ Right (s_edge : news)
-                                Left err   -> return $ Left err
-                         else return $ Right []
-                     else return $ Right []            
-
-            
-            -- step 6, 7
-            m_edp :: Graph s -> [Edge] -> [Edge] -> [Edge] -> SchedRef s ->
-                        AOAG s (Either LOAGRes (Edge,Cycle,CType))
-            m_edp (dpf, dpt) ads ivd comp sched = do
-                edpf <- mapArray id dpf
-                edpt <- mapArray id dpt
-                mc   <- addEDs (edpf,edpt) (concatMap instEdge ivd) 
-                case mc of
-                  Just (e, c) -> return $ Right (e,c,T3 $ concatMap instEdge comp)
-                  Nothing     -> do 
-                        tdp  <- freeze edpt
-                        infs <- readSTRef (snd sched)
-                        return $ Left (Just tdp,infs,ads)
-
-            reschedule :: Graph s -> Graph s -> Graph s -> SchedRef s -> 
-                           [Edge] -> Edge -> STRef s Int 
-                            -> AOAG s AOAGRes
-            reschedule dp idp ids sched@(_,threadRef) ads e pruner = do
-                extra <- addN idp ids e
-                case extra of 
-                    Left err -> return $ Left err
-                    Right extra -> do
-                        forM_ extra $ swap_ivd ids sched
-                        fr_ids <- freeze_graph ids
-                        threads <- readSTRef threadRef
-                        let (ivd, comp) = fetchEdges fr_ids threads nts 
-                        eRoC <- m_edp dp ads ivd comp sched
-                        case eRoC of
-                            Left res -> return $ Right res 
-                            Right (e,c,(T3 cs)) -> explore dp idp ids sched ads pruner e c cs
-             where 
-              swap_ivd :: Graph s -> SchedRef s -> Edge -> AOAG s ()
-              swap_ivd ids@(idsf, idst) sr@(schedA, schedS) (f,t) = do
-                --the edge should point from higher to lower timeslot
-                assigned <- freeze schedA
-                let oldf = maybe (error "unassigned f") id $ assigned A.! f
-                    oldt = maybe (error "unassigned t") id $ assigned A.! t
-                    dirf = snd $ alab $ nmp M.! f
-                    dirt = snd $ alab $ nmp M.! t
-                    newf | oldf < oldt = oldt + (if dirf /= dirt then 1 else 0)
-                         | otherwise   = oldf
-                    nt   = show $ typeOf $ nmp M.! f
-
-                -- the edge was pointing in wrong direction so we moved 
-                -- the attribute to a new interaction, now some of its
-                -- predecessors/ancestors might need to be moved too
-                unless (oldf == newf) $ do
-                    writeArray schedA f (Just newf)
-                    modifySTRef schedS 
-                            (M.adjust (IM.update (Just . delete f) oldf) nt)
-                    modifySTRef schedS 
-                        (M.adjust(IM.alter(Just. maybe [f] (insert f))newf)nt)
-                    predsf <- readArray idst f
-                    succsf <- readArray idsf f
-                    let rest = (map (flip (,) f) $ IS.toList predsf) ++ 
-                               (map ((,) f)      $ IS.toList succsf)
-                     in mapM_ (swap_ivd ids sr) rest
-                        
-                        
-
+{-# LANGUAGE Rank2Types #-}++module LOAG.AOAG where++import LOAG.Common+import LOAG.Graphs+import LOAG.Rep++import AbstractSyntax+import CommonTypes+import Control.Arrow ((&&&), (***))+import Control.Monad (forM, forM_, MonadPlus(..), when, unless)+import Control.Monad.ST+import Control.Monad.Error (ErrorT(..))+import Control.Monad.State (MonadState(..))+import Data.Maybe (fromMaybe, catMaybes, fromJust, isNothing)+import Data.List (elemIndex, foldl', delete, (\\), insert, nub)+import Data.STRef+import Data.Tuple (swap)+import qualified Data.Set as S+import qualified Data.IntSet as IS+import qualified Data.IntMap as IM+import qualified Data.Map as M+import           Data.Array.MArray+import qualified Data.Array as A+import Data.Array.ST+import ErrorMessages as Err+import Pretty+import UU.Scanner.Position++data Settings = Settings  +                { -- current minimum ads size+                  prune_val  :: Int +                  -- whether to minimize the number of fake dependencies+                  -- could be very costly+                , min_ads :: Bool+                }+default_settings = Settings 999 False++type AOAG s a = ST s a++-- | Catch a type 3 cycle-error made by a given constructor+-- |  two alternatives are given to proceed+type ADS = [Edge]+type AOAGRes =  Either Error LOAGRes+-- | Calculate a total order if the semantics given +--    originate from a linearly-ordered AG++type2error,limiterror,aoagerror :: Error+type2error = Err.CustomError False noPos $ text "Type 2 cycle"+limiterror = Err.CustomError False noPos $ text "Limit reached"+aoagerror  = Err.CustomError False noPos $ text "Not an LOAG/AOAG"++schedule :: LOAGRep -> Grammar -> Ag -> [Edge] -> AOAGRes+schedule sem gram@(Grammar _ _ _ _ dats _ _ _ _ _ _ _ _ _) +                ag@(Ag bounds_s bounds_p de nts) ads +    = runST $ aoag default_settings ads+ where+    -- get the maps from semantics and translate them to functions    +    nmp  = (nmp_LOAGRep_LOAGRep  sem)     +    ofld = (ofld_LOAGRep_LOAGRep sem)       +    genA = gen_LOAGRep_LOAGRep sem             +    inss = inss_LOAGRep_LOAGRep sem        + +    -- select candidates, using the edge that caused the cycle+    -- from the list of intra-thread dependencies +    -- (intra-visit dependencies without edges in ids)+    candidates :: Edge -> Cycle -> [Edge] -> [Edge]+    candidates _ c = foldr (\(f,t) acc -> +                                if f `IS.member` c &&t `IS.member` c+                                    then (t,f):acc else acc) []+    -- | Move occurrence to its corresponding attribute +    gen :: Vertex -> Vertex+    gen v = genA A.! v++    genEdge :: Edge -> Edge+    genEdge (f,t) = (gen f, gen t)++    -- | Decide for a given production edge whether the vertices +    --      belong to the same field+    siblings :: Edge -> Bool+    siblings (f, t) = ofld A.! f == ofld A.! t++    -- | Given an nonterminal-edge, instantiate it+    --   assumes that the occurrences of fields are added in the same order+    instEdge :: Edge -> [Edge]+    instEdge (f, t) = zip (inss A.! f) (inss A.! t)+ +    aoag :: Settings -> [Edge] -> AOAG s AOAGRes+    aoag cfg init_ads = run+        where+            run :: AOAG s AOAGRes+            run = induced ads >>= detect++            detect (Left err) = return $ Left err+            detect (Right (dp,idp,ids@(idsf,idst))) = do+                -- Attribute -> TimeSlot+                schedA <- mapArray (const Nothing) idsf+                -- map TimeSlot -> [Attribute]+                schedS <- newSTRef $ +                    foldr (\(Nonterminal nt _ _ _ _) -> M.insert (getName nt) +                                (IM.singleton 1 [])) M.empty dats+                fr_ids <- freeze_graph ids+                threads <- completing fr_ids (schedA, schedS) nts+                let (ivd, comp) = fetchEdges fr_ids threads nts+                eRoC <- m_edp dp init_ads ivd comp (schedA, schedS)+                case eRoC of+                    Left res -> return $ Right res+                    Right (e,c,T3 cs) -> find_ads dp idp ids (schedA, schedS) e c cs++            find_ads :: Graph s -> Graph s -> Graph s -> SchedRef s -> +                         Edge -> Cycle -> [Edge] -> AOAG s AOAGRes+            find_ads dp idp ids sched e cycle comp = do+                pruner <- newSTRef 999+                explore dp idp ids sched init_ads pruner e cycle comp+ +            explore :: Graph s -> Graph s -> Graph s -> SchedRef s -> +                        [Edge] -> STRef s Int -> Edge -> Cycle -> [Edge] ->+                            AOAG s AOAGRes+            explore dp idp ids sched@(schedA, schedS) ads pruner e c comp =+                explore' dp idp ids sched ads (candidates e c comp) pruner+             where+              explore' :: Graph s -> Graph s -> Graph s -> SchedRef s -> +                          [Edge] -> [Edge] -> STRef s Int -> +                            AOAG s AOAGRes+              explore' _  _   _   _  _   [] _ = return $ Left aoagerror+              explore' dp idp ids sched@(schedA,schedS) ads (fd:cs) pruner = do+                  p_val <- readSTRef pruner+                  if length ads >= p_val -1+                   then return $ Left limiterror +                   else do +                    idpf_clone <- mapArray id (fst idp)+                    idpt_clone <- mapArray id (snd idp)+                    let idp_c  =  (idpf_clone, idpt_clone)+                    idsf_clone <- mapArray id (fst ids)+                    idst_clone <- mapArray id (snd ids)+                    let ids_c  =  (idsf_clone, idst_clone)+                    schedA_c   <- mapArray id schedA+                    schedS_v   <- readSTRef schedS+                    schedS_c   <- newSTRef schedS_v+                    let sched_c = (schedA_c, schedS_c)+    +                    let runM = reschedule dp idp ids sched +                                                (fd:ads) fd pruner+                    let backtrack = explore' dp idp_c ids_c sched_c ads cs +                                        pruner+                    maoag <- runM+                    case maoag of +                      Left _                 -> backtrack+                      Right (tdp1,inf1,ads1) -> +                            if LOAG.AOAG.min_ads cfg +                             then do+                              writeSTRef pruner (length ads1)+                              maoag' <- backtrack+                              case maoag' of+                                Right (tdp2,inf2,ads2)+                                          -> return $ Right (tdp2,inf2,ads2)+                                otherwise -> return $ Right (tdp1,inf1,ads1)+                             else return $ Right (tdp1,inf1,ads1)++            -- step 1, 2 and 3+            induced :: [Edge] -> AOAG s (Either Error (Graph s, Graph s, Graph s))+            induced ads = do+                dpf  <- newArray bounds_p IS.empty+                dpt  <- newArray bounds_p IS.empty+                idpf <- newArray bounds_p IS.empty+                idpt <- newArray bounds_p IS.empty+                idsf <- newArray bounds_s IS.empty+                idst <- newArray bounds_s IS.empty+                let ids = (idsf,idst)+                let idp = (idpf,idpt)+                let dp  = (dpf ,dpt)+                inducing dp idp ids (de ++ ads) ++            inducing :: Graph s -> Graph s -> Graph s -> [Edge] +                            -> AOAG s (Either Error (Graph s, Graph s, Graph s))+            inducing dp idp ids es = do+                res <- adds (addD dp idp ids) [] es+                case res of +                    Left _ -> return $ Left $ type2error+                    Right _  -> return $ Right (dp, idp, ids)+            addD :: Graph s -> Graph s -> Graph s -> Edge -> AOAG s (Either Error [Edge])+            addD dp' idp' ids' e = do+                resd <- e `insErt` dp'+                resdp <- e `inserT` idp'+                case resdp of +                  Right es  -> adds (addN idp' ids') [] (e:es)+                  Left c    -> return $ Left $ type2error++            addI :: Graph s -> Graph s -> Edge -> AOAG s (Either Error [Edge])+            addI idp' ids' e = do+                exists <- member e idp'+                if not exists then do+                    res <- e `inserT` idp'+                    case res of+                        Right es -> adds (addN idp' ids') [] es+                        Left c   -> return $ Left $ type2error+                 else return $ Right []++            adds f acc [] = return $ Right acc+            adds f acc (e:es) = do+                mes <- f e+                case mes of +                    Left err -> return $ Left err+                    Right news -> adds f (acc++news) es++            addN :: Graph s -> Graph s -> Edge -> AOAG s (Either Error [Edge])+            addN idp' ids' e = do+                    if (siblings e) then do+                        let s_edge = genEdge e+                        exists <- member s_edge ids'+                        if not exists then do+                            _ <- inserT s_edge ids'+                            let es = instEdge s_edge+                            addedEx <- adds (addI idp' ids') [] es+                            case addedEx of+                                Right news -> return $ Right (s_edge : news)+                                Left err   -> return $ Left err+                         else return $ Right []+                     else return $ Right []            ++            +            -- step 6, 7+            m_edp :: Graph s -> [Edge] -> [Edge] -> [Edge] -> SchedRef s ->+                        AOAG s (Either LOAGRes (Edge,Cycle,CType))+            m_edp (dpf, dpt) ads ivd comp sched = do+                edpf <- mapArray id dpf+                edpt <- mapArray id dpt+                mc   <- addEDs (edpf,edpt) (concatMap instEdge ivd) +                case mc of+                  Just (e, c) -> return $ Right (e,c,T3 $ concatMap instEdge comp)+                  Nothing     -> do +                        tdp  <- freeze edpt+                        infs <- readSTRef (snd sched)+                        return $ Left (Just tdp,infs,ads)++            reschedule :: Graph s -> Graph s -> Graph s -> SchedRef s -> +                           [Edge] -> Edge -> STRef s Int +                            -> AOAG s AOAGRes+            reschedule dp idp ids sched@(_,threadRef) ads e pruner = do+                extra <- addN idp ids e+                case extra of +                    Left err -> return $ Left err+                    Right extra -> do+                        forM_ extra $ swap_ivd ids sched+                        fr_ids <- freeze_graph ids+                        threads <- readSTRef threadRef+                        let (ivd, comp) = fetchEdges fr_ids threads nts +                        eRoC <- m_edp dp ads ivd comp sched+                        case eRoC of+                            Left res -> return $ Right res +                            Right (e,c,(T3 cs)) -> explore dp idp ids sched ads pruner e c cs+             where +              swap_ivd :: Graph s -> SchedRef s -> Edge -> AOAG s ()+              swap_ivd ids@(idsf, idst) sr@(schedA, schedS) (f,t) = do+                --the edge should point from higher to lower timeslot+                assigned <- freeze schedA+                let oldf = maybe (error "unassigned f") id $ assigned A.! f+                    oldt = maybe (error "unassigned t") id $ assigned A.! t+                    dirf = snd $ alab $ nmp M.! f+                    dirt = snd $ alab $ nmp M.! t+                    newf | oldf < oldt = oldt + (if dirf /= dirt then 1 else 0)+                         | otherwise   = oldf+                    nt   = show $ typeOf $ nmp M.! f++                -- the edge was pointing in wrong direction so we moved +                -- the attribute to a new interaction, now some of its+                -- predecessors/ancestors might need to be moved too+                unless (oldf == newf) $ do+                    writeArray schedA f (Just newf)+                    modifySTRef schedS +                            (M.adjust (IM.update (Just . delete f) oldf) nt)+                    modifySTRef schedS +                        (M.adjust(IM.alter(Just. maybe [f] (insert f))newf)nt)+                    predsf <- readArray idst f+                    succsf <- readArray idsf f+                    let rest = (map (flip (,) f) $ IS.toList predsf) ++ +                               (map ((,) f)      $ IS.toList succsf)+                     in mapM_ (swap_ivd ids sr) rest+                        +                        +
src/LOAG/Chordal.hs view
@@ -1,271 +1,271 @@-{-# LANGUAGE CPP #-}
-
-module LOAG.Chordal where
-
-#ifdef WITH_LOAG
-
-import LOAG.Common
-import LOAG.Graphs
-import LOAG.Optimise
-import LOAG.Solver.MiniSat
-import Options
-
-import              Control.Monad (unless, forM, when, foldM)
-import              Control.Monad.ST
-import qualified    Data.Array as A
-import              Data.Array.IO
-import              Data.Array.ST as ST
-import qualified    Data.IntMap as IM
-import qualified    Data.IntSet as IS
-import qualified    Data.Map as M
-import              Data.Maybe (isNothing, catMaybes)
-import qualified    Data.Set as S
-import              Data.STRef
-
-type Neigh     = (Vertex, EdgeType)
-data EdgeType  = Sib    MyVar   -- Edge between siblings 
-               | Any    MyVar   -- Unknown
-               | NSib   MyVar   -- Edge between non-siblings
-    deriving (Show)
-
-extract (Sib l) = l
-extract (Any l) = l
-extract (NSib l)= l
-
-neg :: EdgeType -> EdgeType
-neg (Sib p)  = Sib  $ varnot p
-neg (NSib p) = NSib $ varnot p
-neg (Any p)  = Any  $ varnot p
-
-
-type NtGraph   = IM.IntMap [(Vertex,MyVar)]
-type ToChordal = IM.IntMap [Neigh]
-type SatEdge = (Vertex, Neigh)
-
-addClauses :: Sat -> [[EdgeType]] -> IO ()
-addClauses sat = mapM_ (addClause sat . map extract) 
-
-toChordal :: [(Edge,EdgeType)] -> IO ToChordal
-toChordal es = 
-    let edges = concatMap (\((a,b),c) -> [(a,[(b,c)]),(b,[(a,neg c)])]) es
-      in return $ IM.fromListWith (++) edges
-
-toNtGraph :: [(Edge,MyVar)] -> IO NtGraph
-toNtGraph es = 
-    let edges = concatMap (\((a,b),c) -> [(a,[(b,c)]),(b,[(a,varnot c)])]) es
-      in return $ IM.fromListWith (++) edges
-
-
-remove :: Vertex -> [Neigh] -> ToChordal -> ToChordal
-remove v ns g = foldr (IM.adjust remN . fst) (IM.delete v g) ns 
- where remN ns = filter ((/= v).fst) ns
-
-adds :: ToChordal -> [SatEdge] -> ToChordal
-adds g = foldl add g
-
-add :: ToChordal -> SatEdge -> ToChordal
-add g (v,n@(v2,c)) = IM.adjust (n:)          v
-                   $ IM.adjust ((v,neg c):)  v2 g
-
-removeNt :: Vertex -> [(Vertex,MyVar)] -> NtGraph -> NtGraph
-removeNt v ns g = foldr (IM.adjust remN . fst) (IM.delete v g) ns 
- where remN ns = filter ((/= v).fst) ns
-
-addsNt g = foldl addNt g
-
-addNt g (v,n@(v2,c)) = IM.adjust (n:)          v
-                     $ IM.adjust ((v,varnot c):)  v2 g
-
-scheduleLOAG :: Ag -> (String -> IO ()) -> Options -> IO LOAGRes
-scheduleLOAG ag@(Ag nbounds pbounds dps nts) putStrLn opts = do
-    let optim | minvisits opts = [MinVisits] -- todo: allow specification of more optimisations
-              | otherwise      = []
-    putStrLn "--- Starting ---"
-    sat <- newSolvable 
-    varMap <- noNtCycles sat nts putStrLn
-    noPrCycles sat prs varMap putStrLn 
-    (v,p) <- satValues sat
-    putStrLn $ "nr. of variables: " ++ show v 
-    putStrLn $ "nr. of clauses: "   ++ show p
-    putStrLn "--- Solving ---"
-    b <- satsolve sat []
-    if not b then error "Not LOAG" 
-      else do   putStrLn "--- Constructing Interfaces ---"
-                (ids,edp,interfaces) <- loagRes sat varMap dps
-                let oldct = getVisCount nts interfaces
-                when (minvisits opts) $ 
-                    putStrLn "--- Minimising #Visit"
-                optimise sat varMap optim nbounds nts interfaces 
-                (ids',edp',interfaces') <- loagRes sat varMap dps
-                let visC@newct = getVisCount nts interfaces'
-                when (minvisits opts) $ do
-                    putStrLn ("--- #Visits (max,sum,avg) " ++(show oldct)
-                                ++" --> " ++(show newct))
-                putStrLn "--- Code Generation ---"
-                return (Just edp',interfaces',[])
- where  loagRes sat varMap dps = do    
-            (ids,edp) <- mkGraphs sat varMap dps
-            interfaces <- mkInterfaces ids
-            return (ids,edp,interfaces)
-        prs =  [ p | (Nt _ _ _ _ _ ps) <- nts, p <- ps]
-        mkInterfaces ids = return $ runST $ do
-                schedA <- newArray nbounds Nothing
-                schedS <- newSTRef $ foldr (\(Nt nt _ _ _ _ _) -> 
-                                M.insert nt (IM.singleton 1 [])) 
-                                M.empty nts
-                completing ids (schedA, schedS) nts
-
-        mkGraphs :: Sat -> M.Map Edge MyVar -> [Edge] ->
-                        IO (FrGraph,TDPRes)
-        mkGraphs sat varMap dps = do
-            idsf <- newArray nbounds IS.empty :: IO (IOArray Vertex Vertices)
-            idst <- newArray nbounds IS.empty :: IO (IOArray Vertex Vertices)
-            edp  <- newArray pbounds IS.empty :: IO (IOArray Vertex Vertices)
-            let (ids) = (idsf,idst)
-            sequence_ [ do  v <- value sat pred
-                            case v of
-                              Nothing -> error "no val"
-                              Just True -> addEdges (i,s) (zip ios sos) ids edp
-                              Just False-> addEdges (s,i) (zip sos ios) ids edp
-                    | Nt _ _ _ inhs outs _ <- nts
-                    , (i,ios,_) <- inhs
-                    , (s,sos,_) <- outs
-                    , let pred = varMap M.! (i,s)
-                    ]
-            forM dps $ \(f,t) -> do
-                modifyArray edp t (f `IS.insert`)
-            f_idsf <- freeze idsf
-            f_idst <- freeze idst
-            f_edp  <- freeze edp
-            return ((f_idsf,f_idst),f_edp)
-         where  addEdges
-                  :: (Vertex, Vertex)
-                  -> [(Vertex, Vertex)]
-                  -> (IOArray Vertex Vertices, IOArray Vertex Vertices)
-                  -> IOArray Vertex Vertices
-                  -> IO [()]
-                addEdges (f,t) es (idsf,idst) edp = do
-                    modifyArray idsf f (t `IS.insert`)
-                    modifyArray idst t (f `IS.insert`)
-                    forM es $ \(f,t) -> do --edp does not reflect flow
-                        modifyArray edp t (f `IS.insert`)                
-
-noCyclesNt :: Sat -> NtGraph -> IO ()
-noCyclesNt sat g  | IM.null g  = return ()
-                  | otherwise = do
-    news <- sequence [ noTriangleNt sat g p q | (p,q) <- pairs neighs]
-    let g' = addsNt (removeNt node neighs g) (concat news)
-    noCyclesNt sat g'
-    where   
-        node = snd $ minimum   [ (length xs, a) | (a,xs) <- IM.toList g ]
-        Just neighs = IM.lookup node g
-
-noTriangleNt :: Sat -> NtGraph -> (Vertex, MyVar) -> 
-                          (Vertex, MyVar) -> IO [(Vertex,(Vertex,MyVar))]
-noTriangleNt sat g e1@(t1,c1) e2@(t2,c2) = 
-    case IM.lookup t1 g of
-      Just ns -> 
-        case [ c | (t2',c) <- ns, t2' == t2 ] of
-          [] -> do  c3 <- newLit sat
-                    ruleOut c1 c2 c3
-                    return [(t1,(t2,c3))]
-          [c3] -> ruleOut c1 c2 c3 >> return []
-          _   -> error "multiple edges between two nodes"
-      Nothing -> error "pointer outside of graph"
- where 
-        ruleOut ea eb ab= do addClause sat [ea, ab, varnot eb]
-                             addClause sat [varnot ea,varnot ab,eb]
-
-noCyclesPr :: Sat -> ToChordal -> IO ()
-noCyclesPr sat g  | IM.null g  = return ()
-                  | otherwise = do
-    news <- sequence [ noTriangle sat g p q | (p,q) <- validPairs neighs]
-    let g' = adds (remove node neighs g) (concat news)
-    noCyclesPr sat g'
-    where   
-        node = snd $ minimum   [ (weight xs, a) 
-                               | (a,xs) <- IM.toList g ]
-        Just neighs = IM.lookup node g
-        validPairs ns = [ (p,q)  | p <- sibs,  q <- nsibs ] ++
-                        [ (p,q)  | p <- nsibs, q <- anys  ] ++
-                        [ (p,q)  | p <- sibs,  q <- anys  ]
-                      ++  (pairs anys)
-         where sibs = [ n | n@(_,Sib _)  <- ns ]
-               nsibs= [ n | n@(_,NSib _) <- ns ]
-               anys = [ n | n@(_,Any _)  <- ns ]
-        weight :: [Neigh] -> Int
-        weight xs = ss*3 * (ds + cs) + (ds + cs)^2
-         where
-          ss = length [ x | x@(_,Sib _)  <- xs ]
-          ds = length [ x | x@(_,NSib _) <- xs ]
-          cs = length [ x | x@(_,Any _)  <- xs ]
-
-noTriangle :: Sat -> ToChordal -> Neigh -> Neigh -> IO [SatEdge]
-noTriangle sat g e1@(t1,c1) e2@(t2,c2) = 
-    case IM.lookup t1 g of
-      Just ns -> 
-        case [ c | (t2',c) <- ns, t2' == t2 ] of
-          [] -> do  p <- newLit sat
-                    ruleOut c1 c2 (Any p)
-                    return [(t1,(t2,(Any p)))]
-          [c3] -> ruleOut c1 c2 c3 >> return [] 
-          _   -> error "multiple edges between two nodes"
-      Nothing -> error "pointer outside of graph"
- where  ruleOut ea eb ab= addClauses sat [[ea, ab, neg eb],[neg ea,neg ab,eb]] 
-noNtCycles :: Sat -> [Nt] -> (String -> IO ()) -> IO VarMap 
-noNtCycles sat tps putStrLn = do
-    putStrLn "--- Non-Terminals ---"
-    maps <- mapM forNt tps
-    return $ M.unions maps
- where  -- at non-terminal level, all cycles are between siblings
-        -- that is why we force all the edges to be the same
-        -- (not filtered by validPairs) 
-        forNt tp@(Nt tid dpf dpt inhs syns _) = do
-            vars <- satValues sat
-            putStrLn ("nt : " ++ tid ++ " ... " ++ 
-                        show vars ++ " ...")
-            when (not $ S.null $ S.fromList dpf `S.intersection`
-                     S.fromList (map (\(a,b) -> (b,a)) dpt)) $
-               error "Type 2 cycle of length 2"
-            ass <- sequence $
-                    [ return ((i,s),VarTrue) | ((i,s)) <- dpf ]++
-                    [ return ((i,s),VarFalse)| ((s,i)) <- dpt ] 
-            let assM = M.fromList ass
-            mvars<- sequence   
-                    [ if new then do
-                        p <- newLit sat
-                        return $ Just ((i,s),p) else return Nothing
-                    | (i,_,_) <- inhs
-                    , (s,_,_) <- syns
-                    , let mmv = maybe (M.lookup (s,i) assM) Just 
-                                      (M.lookup (i,s) assM)
-                          new = isNothing mmv ]
-            let vars = ass ++ catMaybes mvars
-            g <- toNtGraph vars 
-            noCyclesNt sat g
-            return $ M.fromList vars
-
-
-noPrCycles :: Sat -> [Pr] -> VarMap -> (String -> IO ()) -> IO ()
-noPrCycles sat prods varMap putStrLn = do
-    putStrLn "--- Productions ---"
-    mapM_ forProd prods
- where  forProd (Pr prod es ses fs) | length fs ==1 = return () --taken care of
-                                    | otherwise =  do 
-            vars <- satValues sat
-            putStrLn ("prod: " ++ show prod ++ " ... " ++ 
-                           show vars ++ " ...") 
-            g <- toChordal (sibs ++ dps) 
-            noCyclesPr sat g
-         where sibs= [ ((f,t),Sib c) | (e@(f,t),ge,_) <- ses
-                     , let c = case M.lookup ge varMap of
-                                      Just p  -> p
-                                      Nothing -> error "no var found"]
-               dps = [ (e,NSib VarTrue) | e <- es ]
-
-
-#else
-
-scheduleLOAG = error "You need to install uuagc with the -fwith-loag flag in order to use the --loag option."
-
-#endif
+{-# LANGUAGE CPP #-}++module LOAG.Chordal where++#ifdef WITH_LOAG++import LOAG.Common+import LOAG.Graphs+import LOAG.Optimise+import LOAG.Solver.MiniSat+import Options++import              Control.Monad (unless, forM, when, foldM)+import              Control.Monad.ST+import qualified    Data.Array as A+import              Data.Array.IO+import              Data.Array.ST as ST+import qualified    Data.IntMap as IM+import qualified    Data.IntSet as IS+import qualified    Data.Map as M+import              Data.Maybe (isNothing, catMaybes)+import qualified    Data.Set as S+import              Data.STRef++type Neigh     = (Vertex, EdgeType)+data EdgeType  = Sib    MyVar   -- Edge between siblings +               | Any    MyVar   -- Unknown+               | NSib   MyVar   -- Edge between non-siblings+    deriving (Show)++extract (Sib l) = l+extract (Any l) = l+extract (NSib l)= l++neg :: EdgeType -> EdgeType+neg (Sib p)  = Sib  $ varnot p+neg (NSib p) = NSib $ varnot p+neg (Any p)  = Any  $ varnot p+++type NtGraph   = IM.IntMap [(Vertex,MyVar)]+type ToChordal = IM.IntMap [Neigh]+type SatEdge = (Vertex, Neigh)++addClauses :: Sat -> [[EdgeType]] -> IO ()+addClauses sat = mapM_ (addClause sat . map extract) ++toChordal :: [(Edge,EdgeType)] -> IO ToChordal+toChordal es = +    let edges = concatMap (\((a,b),c) -> [(a,[(b,c)]),(b,[(a,neg c)])]) es+      in return $ IM.fromListWith (++) edges++toNtGraph :: [(Edge,MyVar)] -> IO NtGraph+toNtGraph es = +    let edges = concatMap (\((a,b),c) -> [(a,[(b,c)]),(b,[(a,varnot c)])]) es+      in return $ IM.fromListWith (++) edges+++remove :: Vertex -> [Neigh] -> ToChordal -> ToChordal+remove v ns g = foldr (IM.adjust remN . fst) (IM.delete v g) ns + where remN ns = filter ((/= v).fst) ns++adds :: ToChordal -> [SatEdge] -> ToChordal+adds g = foldl add g++add :: ToChordal -> SatEdge -> ToChordal+add g (v,n@(v2,c)) = IM.adjust (n:)          v+                   $ IM.adjust ((v,neg c):)  v2 g++removeNt :: Vertex -> [(Vertex,MyVar)] -> NtGraph -> NtGraph+removeNt v ns g = foldr (IM.adjust remN . fst) (IM.delete v g) ns + where remN ns = filter ((/= v).fst) ns++addsNt g = foldl addNt g++addNt g (v,n@(v2,c)) = IM.adjust (n:)          v+                     $ IM.adjust ((v,varnot c):)  v2 g++scheduleLOAG :: Ag -> (String -> IO ()) -> Options -> IO LOAGRes+scheduleLOAG ag@(Ag nbounds pbounds dps nts) putStrLn opts = do+    let optim | minvisits opts = [MinVisits] -- todo: allow specification of more optimisations+              | otherwise      = []+    putStrLn "--- Starting ---"+    sat <- newSolvable +    varMap <- noNtCycles sat nts putStrLn+    noPrCycles sat prs varMap putStrLn +    (v,p) <- satValues sat+    putStrLn $ "nr. of variables: " ++ show v +    putStrLn $ "nr. of clauses: "   ++ show p+    putStrLn "--- Solving ---"+    b <- satsolve sat []+    if not b then error "Not LOAG" +      else do   putStrLn "--- Constructing Interfaces ---"+                (ids,edp,interfaces) <- loagRes sat varMap dps+                let oldct = getVisCount nts interfaces+                when (minvisits opts) $ +                    putStrLn "--- Minimising #Visit"+                optimise sat varMap optim nbounds nts interfaces +                (ids',edp',interfaces') <- loagRes sat varMap dps+                let visC@newct = getVisCount nts interfaces'+                when (minvisits opts) $ do+                    putStrLn ("--- #Visits (max,sum,avg) " ++(show oldct)+                                ++" --> " ++(show newct))+                putStrLn "--- Code Generation ---"+                return (Just edp',interfaces',[])+ where  loagRes sat varMap dps = do    +            (ids,edp) <- mkGraphs sat varMap dps+            interfaces <- mkInterfaces ids+            return (ids,edp,interfaces)+        prs =  [ p | (Nt _ _ _ _ _ ps) <- nts, p <- ps]+        mkInterfaces ids = return $ runST $ do+                schedA <- newArray nbounds Nothing+                schedS <- newSTRef $ foldr (\(Nt nt _ _ _ _ _) -> +                                M.insert nt (IM.singleton 1 [])) +                                M.empty nts+                completing ids (schedA, schedS) nts++        mkGraphs :: Sat -> M.Map Edge MyVar -> [Edge] ->+                        IO (FrGraph,TDPRes)+        mkGraphs sat varMap dps = do+            idsf <- newArray nbounds IS.empty :: IO (IOArray Vertex Vertices)+            idst <- newArray nbounds IS.empty :: IO (IOArray Vertex Vertices)+            edp  <- newArray pbounds IS.empty :: IO (IOArray Vertex Vertices)+            let (ids) = (idsf,idst)+            sequence_ [ do  v <- value sat pred+                            case v of+                              Nothing -> error "no val"+                              Just True -> addEdges (i,s) (zip ios sos) ids edp+                              Just False-> addEdges (s,i) (zip sos ios) ids edp+                    | Nt _ _ _ inhs outs _ <- nts+                    , (i,ios,_) <- inhs+                    , (s,sos,_) <- outs+                    , let pred = varMap M.! (i,s)+                    ]+            forM dps $ \(f,t) -> do+                modifyArray edp t (f `IS.insert`)+            f_idsf <- freeze idsf+            f_idst <- freeze idst+            f_edp  <- freeze edp+            return ((f_idsf,f_idst),f_edp)+         where  addEdges+                  :: (Vertex, Vertex)+                  -> [(Vertex, Vertex)]+                  -> (IOArray Vertex Vertices, IOArray Vertex Vertices)+                  -> IOArray Vertex Vertices+                  -> IO [()]+                addEdges (f,t) es (idsf,idst) edp = do+                    modifyArray idsf f (t `IS.insert`)+                    modifyArray idst t (f `IS.insert`)+                    forM es $ \(f,t) -> do --edp does not reflect flow+                        modifyArray edp t (f `IS.insert`)                ++noCyclesNt :: Sat -> NtGraph -> IO ()+noCyclesNt sat g  | IM.null g  = return ()+                  | otherwise = do+    news <- sequence [ noTriangleNt sat g p q | (p,q) <- pairs neighs]+    let g' = addsNt (removeNt node neighs g) (concat news)+    noCyclesNt sat g'+    where   +        node = snd $ minimum   [ (length xs, a) | (a,xs) <- IM.toList g ]+        Just neighs = IM.lookup node g++noTriangleNt :: Sat -> NtGraph -> (Vertex, MyVar) -> +                          (Vertex, MyVar) -> IO [(Vertex,(Vertex,MyVar))]+noTriangleNt sat g e1@(t1,c1) e2@(t2,c2) = +    case IM.lookup t1 g of+      Just ns -> +        case [ c | (t2',c) <- ns, t2' == t2 ] of+          [] -> do  c3 <- newLit sat+                    ruleOut c1 c2 c3+                    return [(t1,(t2,c3))]+          [c3] -> ruleOut c1 c2 c3 >> return []+          _   -> error "multiple edges between two nodes"+      Nothing -> error "pointer outside of graph"+ where +        ruleOut ea eb ab= do addClause sat [ea, ab, varnot eb]+                             addClause sat [varnot ea,varnot ab,eb]++noCyclesPr :: Sat -> ToChordal -> IO ()+noCyclesPr sat g  | IM.null g  = return ()+                  | otherwise = do+    news <- sequence [ noTriangle sat g p q | (p,q) <- validPairs neighs]+    let g' = adds (remove node neighs g) (concat news)+    noCyclesPr sat g'+    where   +        node = snd $ minimum   [ (weight xs, a) +                               | (a,xs) <- IM.toList g ]+        Just neighs = IM.lookup node g+        validPairs ns = [ (p,q)  | p <- sibs,  q <- nsibs ] +++                        [ (p,q)  | p <- nsibs, q <- anys  ] +++                        [ (p,q)  | p <- sibs,  q <- anys  ]+                      ++  (pairs anys)+         where sibs = [ n | n@(_,Sib _)  <- ns ]+               nsibs= [ n | n@(_,NSib _) <- ns ]+               anys = [ n | n@(_,Any _)  <- ns ]+        weight :: [Neigh] -> Int+        weight xs = ss*3 * (ds + cs) + (ds + cs)^2+         where+          ss = length [ x | x@(_,Sib _)  <- xs ]+          ds = length [ x | x@(_,NSib _) <- xs ]+          cs = length [ x | x@(_,Any _)  <- xs ]++noTriangle :: Sat -> ToChordal -> Neigh -> Neigh -> IO [SatEdge]+noTriangle sat g e1@(t1,c1) e2@(t2,c2) = +    case IM.lookup t1 g of+      Just ns -> +        case [ c | (t2',c) <- ns, t2' == t2 ] of+          [] -> do  p <- newLit sat+                    ruleOut c1 c2 (Any p)+                    return [(t1,(t2,(Any p)))]+          [c3] -> ruleOut c1 c2 c3 >> return [] +          _   -> error "multiple edges between two nodes"+      Nothing -> error "pointer outside of graph"+ where  ruleOut ea eb ab= addClauses sat [[ea, ab, neg eb],[neg ea,neg ab,eb]] +noNtCycles :: Sat -> [Nt] -> (String -> IO ()) -> IO VarMap +noNtCycles sat tps putStrLn = do+    putStrLn "--- Non-Terminals ---"+    maps <- mapM forNt tps+    return $ M.unions maps+ where  -- at non-terminal level, all cycles are between siblings+        -- that is why we force all the edges to be the same+        -- (not filtered by validPairs) +        forNt tp@(Nt tid dpf dpt inhs syns _) = do+            vars <- satValues sat+            putStrLn ("nt : " ++ tid ++ " ... " ++ +                        show vars ++ " ...")+            when (not $ S.null $ S.fromList dpf `S.intersection`+                     S.fromList (map (\(a,b) -> (b,a)) dpt)) $+               error "Type 2 cycle of length 2"+            ass <- sequence $+                    [ return ((i,s),VarTrue) | ((i,s)) <- dpf ]+++                    [ return ((i,s),VarFalse)| ((s,i)) <- dpt ] +            let assM = M.fromList ass+            mvars<- sequence   +                    [ if new then do+                        p <- newLit sat+                        return $ Just ((i,s),p) else return Nothing+                    | (i,_,_) <- inhs+                    , (s,_,_) <- syns+                    , let mmv = maybe (M.lookup (s,i) assM) Just +                                      (M.lookup (i,s) assM)+                          new = isNothing mmv ]+            let vars = ass ++ catMaybes mvars+            g <- toNtGraph vars +            noCyclesNt sat g+            return $ M.fromList vars+++noPrCycles :: Sat -> [Pr] -> VarMap -> (String -> IO ()) -> IO ()+noPrCycles sat prods varMap putStrLn = do+    putStrLn "--- Productions ---"+    mapM_ forProd prods+ where  forProd (Pr prod es ses fs) | length fs ==1 = return () --taken care of+                                    | otherwise =  do +            vars <- satValues sat+            putStrLn ("prod: " ++ show prod ++ " ... " ++ +                           show vars ++ " ...") +            g <- toChordal (sibs ++ dps) +            noCyclesPr sat g+         where sibs= [ ((f,t),Sib c) | (e@(f,t),ge,_) <- ses+                     , let c = case M.lookup ge varMap of+                                      Just p  -> p+                                      Nothing -> error "no var found"]+               dps = [ (e,NSib VarTrue) | e <- es ]+++#else++scheduleLOAG = error "You need to install uuagc with the -fwith-loag flag in order to use the --loag option."++#endif
src/LOAG/Common.hs view
@@ -1,298 +1,298 @@-
-module LOAG.Common where
-
-import qualified Data.Array as A
-import qualified Data.Map as M
-import qualified Data.IntMap as IM
-import qualified Data.IntSet as IS
-import qualified Data.Set as S
-import qualified Data.Sequence as Seq
-import Data.Maybe (isNothing)
-import Data.STRef
-import Data.Array.ST
-import Data.List (intercalate, foldl', nub)
-import CommonTypes
-import Control.Arrow
-import Control.Monad.ST
-import Control.Monad (forM, when, forM_, forM_, foldM)
-
-import LOAG.Graphs
-
-data Ag = Ag    (Int,Int)   -- attribute  range
-                (Int,Int)   -- occurrence range
-                [Edge]      -- direct dependencies
-                [Nt]        -- non-terminals
-data Nt = Nt String 
-                [Edge] -- direct dps from inh -> syn
-                [Edge] -- direct dps from syn -> inh 
-                -- inh attributes with direction and instances
-                [(Vertex,[Vertex],Direction)]
-                -- syn attributes with direction and instances
-                [(Vertex,[Vertex],Direction)]
-                [Pr]            -- productions of this Nt
-    deriving (Show)
-data Pr = Pr    PLabel
-                [Edge]          -- direct dependencies between fields
-                [(Edge,Edge,Bool)] -- all siblings pairs, with generalised version, and boolean that denotes whether if it is an edge of LHS
-                [Fd]            -- the fields of this production, including lhs
-    deriving (Show)
-data Fd = Fd    String          -- field name
-                String          -- type of the field
-                [(Vertex,Vertex)]        -- inherited atts (gen, inst)
-                [(Vertex,Vertex)]        -- synthesized atts (gen, inst)
-    deriving (Show)
-
-type Attrs = [Attr]
-data Attr  = Attr String Direction MyType
-    deriving (Show, Eq, Ord)
-data Direction = Inh | AnyDir | Syn
-    deriving (Show, Ord, Enum)
-
-
-foldM' :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a
-foldM' _ a [] = return a
-foldM' f a (x:xs) = f a x >>= \fax -> fax `seq` foldM f fax xs
-
-modifyArray r k f = do
-    v <- readArray r k
-    writeArray r k (f v)
-
-setConcatMap f = S.foldr (S.union . f) S.empty
-isLoc (MyOccurrence (_,f) _) = f == "loc" || f == "inst" -- transparent occr ? 
-
-instance Eq Direction where
-    Inh == Syn = False
-    Syn == Inh = False
-    _ == _     = True
-
-data MyType = TyInt
-            | TyBool
-            | TyString
-            | TyData String
-            | TyLit String
-            | TyArr MyType MyType
-            | NoType  -- the empty set of values (no members)
-            | AnyType -- the set of all values (union of all types)
-
-type SchedRef s = (STArray s Vertex (Maybe Int),ThreadRef s)
-type AttrAssRef s = STArray s Vertex (Maybe Int)
-type ThreadRef s = STRef s InterfaceRes
--- production is identified by its name and its parent non-terminal
-type PLabel = (MyType,String) 
-type FLabel = String -- field label
--- attribute is identified by its name and its direction
-type ALabel = (String, Direction)
-type AI_N   = M.Map MyType MyAttributes
-type AS_N   = M.Map MyType MyAttributes
-type A_N    = M.Map MyType MyAttributes
-type A_P    = M.Map PLabel MyOccurrences
--- Get the (data)type of a certain child at a certain production
-type FTY    = M.Map (PLabel, FLabel) MyType
--- Get the fields corresponding to a certain type
-type TYFS   = M.Map MyType [(PLabel, FLabel)]
--- the definition of given occ uses these occs
-type SF_P   = M.Map MyOccurrence (S.Set MyOccurrence) 
-type PMP    = M.Map Int MyOccurrence
-type PMP_R  = M.Map MyOccurrence Int
-type NMP    = M.Map Int MyAttribute
-type NMP_R  = M.Map MyAttribute Int
-type FMap   = M.Map (PLabel,FLabel) (S.Set MyOccurrence, S.Set MyOccurrence)
-type FsInP  = M.Map PLabel [(PLabel, FLabel)]
-type LOAGRes =  ( Maybe TDPRes 
-                , InterfaceRes
-                , ADSRes)
-type VisCount= (Int, Int, Float)
-type ADSRes  = [Edge]
-type TDPRes  = A.Array Vertex Vertices --M.Map PLabel TDPGraph
-type TDPGraph = (IM.IntMap Vertices, IM.IntMap Vertices) 
-type InterfaceRes = M.Map String (IM.IntMap [Vertex])
-type HOMap   = M.Map PLabel (S.Set FLabel) 
-data CType = T1 | T2 
-           | T3 [Edge] -- completing edges from which to select candidates
-    deriving (Show)
-
-findWithErr :: (Ord k, Show k, Show a) => M.Map k a -> String -> k -> a
-findWithErr m err k = maybe (error err) id $ M.lookup k m
-findWithErr' m err k= maybe (error err) id $ IM.lookup k m
-
--- Defining the MyAttribute (attribute at non-terimal
--- and the MyOccurrences (attribute at a production)
-type MyAttributes = [MyAttribute]
-data MyAttribute  = MyAttribute {typeOf :: MyType, alab :: ALabel}
-    deriving (Ord, Eq)
-(<.>)         = MyAttribute
-infixl 7 <.>
-instance Show MyAttribute where
-    show (MyAttribute t a) = show t ++ "<.>" ++ show a
-
-type MyOccurrences = [MyOccurrence]
-data MyOccurrence = MyOccurrence {argsOf :: (PLabel, FLabel), attr :: ALabel}
-    deriving (Ord, Eq)
-(>.<)         = MyOccurrence
-infixl 8 >.<
-instance Show MyOccurrence where
-    show (MyOccurrence ((t,p),f) a) = 
-        intercalate "." [show t,p,f] ++ "."++ show a
-
-dirOfOcc :: MyOccurrence -> Direction
-dirOfOcc = snd . attr
-
-handOut :: (PLabel, FLabel) -> MyAttribute -> MyOccurrence
-handOut p = (p >.<) . alab
-
-handAllOut :: (PLabel, FLabel) -> MyAttributes -> MyOccurrences
-handAllOut p os = map (handOut p) os
-
-map2F  :: (Ord a)        => M.Map a [b] -> a -> [b]
-map2F m a = case M.lookup a m of
-              Nothing -> []
-              Just bs -> bs
-
-map2F'  :: (Ord a)        => M.Map a (S.Set b) -> a -> (S.Set b)
-map2F' m a = case M.lookup a m of
-               Nothing -> S.empty
-               Just bs -> bs
-
-flipDir :: Direction -> Direction
-flipDir Syn = Inh
-flipDir Inh = Syn
-
--- creates all pairs of elements such that no equal elements end up in a pair
--- and considering only one direction
-pairs :: [a] -> [(a,a)]
-pairs [] = []
-pairs (x:xs) = map ((,) x) xs ++ pairs xs
-
-toMyTy :: Type -> MyType
-toMyTy (Haskell str) = TyLit str
-toMyTy (NT id _ _ )  = TyData $ getName id
-toMyTy Self          = error "Type Self in phase 3"
-
-fromMyTy :: MyType -> Type
-fromMyTy (TyLit str) = (Haskell str)
-fromMyTy (TyData id) = NT (identifier id) [] False
-
-toMyAttr :: Direction -> MyType -> Attributes -> MyAttributes
-toMyAttr d dty = M.foldrWithKey 
-                    (\ident ty as -> dty <.> (getName ident,d):as) []
-
-completing :: FrGraph -> SchedRef s -> [Nt] -> ST s InterfaceRes
-completing ids sched nts = do   
-    ims <- forM nts $ completingN ids (fst sched)
-    let threads = (M.fromList ims)
-    writeSTRef (snd sched) threads
-    return $ threads 
-
-completingN :: FrGraph -> AttrAssRef s -> Nt -> 
-                    ST s ((String, IM.IntMap [Vertex]))
-completingN ids@(idsf, idst) schedA
-                (Nt nt_id _ _ inhs syns _) = do
-    schedS <- newSTRef IM.empty
-    let attrs = inhs ++ syns
-        dty = TyData nt_id
-        assign (attr,_,dAttr) = do
-         let succs = idsf A.! attr
-         assigned <- freeze schedA
-         when (isNothing $ assigned A.! attr) $ do
-           case IS.toList succs of 
-             [] ->wrap_up attr(if Syn==dAttr then 1 else 2)
-             ss ->case selMax $ map (id&&&(assigned A.!)) ss of
-                      Nothing -> return ()
-                      Just (a,mx) -> do
-                          let dA | even mx   = Inh
-                                 | otherwise = Syn
-                          wrap_up attr (if dA == dAttr 
-                                          then mx else mx+1)
-        wrap_up attr k = do
-         modifySTRef schedS (IM.insertWith (++) k [attr])
-         writeArray schedA attr (Just k)
-         forM_ attrs assign
-        selMax :: [(Vertex, Maybe Int)] -> Maybe (Vertex, Int)
-        selMax [(v,mi)] = fmap ((,) v) mi
-        selMax (x:xs)  = case x of 
-                          (a', Nothing) -> Nothing
-                          (a', Just i') -> 
-                            case selMax xs of 
-                             Nothing -> Nothing
-                             Just (a,i)  -> 
-                                case compare i i' of
-                                 LT -> Just (a',i')
-                                 _  -> Just (a,i)
-    --make sure all are assigned
-    case attrs of
-      [] -> return (nt_id, IM.fromList [(1,[]),(2,[])])
-      as -> forM_ as assign >> readSTRef schedS >>= return . ((,) nt_id)
-
-fetchEdges :: FrGraph -> InterfaceRes -> [Nt] -> ([Edge],[Edge])
-fetchEdges ids threads nts =
-    let ivdNs = map (fetchEdgesN ids threads) nts
-    in (concat *** concat) $ unzip ivdNs
-
-fetchEdgesN :: FrGraph -> InterfaceRes -> Nt
-                    -> ([Edge],[Edge])
-fetchEdgesN (idsf, idst) threads 
-        (Nt nt_id _ _ _ _ _) =
-    let sched = findWithErr threads "schedule err" nt_id
-        mx    = if IM.null sched then 0 else fst $ IM.findMax sched
-        findK 0 = []
-        findK k = (maybe [] id $ IM.lookup k sched) ++ findK (k-1)
-        ivd =  [ (f,t) | k <- [2..mx]
-                   , f <- maybe [] id $ IM.lookup k sched
-                   , t <- findK (k-1)]
-     in (ivd, [ (f, t) | (f, t) <- ivd
-                          , not $ IS.member t (idsf A.! f) ])
-
-instance Show MyType where
-    show TyInt        = "Int"
-    show TyBool       = "Bool"
-    show TyString     = "String"
-    show (TyData t)   = t
-    show (TyLit t)    = show t
-    show (TyArr a b)  = show a ++ " -> (" ++ show b ++ ")" 
-    show NoType       = error "Trying to show NoType"
-    show AnyType      = "AnyType"
-
--- | Instance for Eq and Ord are required to make sure that AnyType
--- | Equals every other type in every other situation
-instance Eq MyType where
-    TyInt       == TyInt        = True
-    TyBool      == TyBool       = True
-    TyString    == TyString     = True
-    TyData n    == TyData n'    = n == n'
-    TyLit ty    == TyLit ty'    = ty == ty'
-    TyArr l r   == TyArr l' r'  = l == l' && r == r'
-    NoType      == _            = False
-    _           == NoType       = False
-    AnyType     == _            = True
-    _           == AnyType      = True
-    _           == _            = False
-
-instance Ord MyType where
-    NoType `compare` _          = LT
-    _   `compare` NoType        = GT
-    AnyType `compare` _         = EQ
-    _   `compare` AnyType       = EQ
-    TyInt `compare` TyInt       = EQ
-    TyInt `compare` _           = LT
-    TyBool `compare` TyInt      = GT
-    TyBool `compare` TyBool     = EQ
-    TyBool `compare` _          = LT
-    TyString `compare` TyInt    = GT
-    TyString `compare` TyBool   = GT
-    TyString `compare` TyString = EQ
-    TyString `compare` _        = LT
-    TyData _ `compare` TyInt    = GT
-    TyData _ `compare` TyBool   = GT
-    TyData _ `compare` TyString = GT
-    TyData a `compare` TyData b = compare a b
-    TyData _ `compare` _        = LT
-    TyLit  a `compare` TyLit b  = compare a b
-    TyLit  _ `compare` TyArr _ _= LT    
-    TyLit  _ `compare` _        = GT
-    TyArr a a' `compare` TyArr b b' = 
-        case compare a b of
-            LT -> LT
-            GT -> GT
-            EQ -> compare a' b'
-    TyArr _ _ `compare` _       = GT
-
++module LOAG.Common where++import qualified Data.Array as A+import qualified Data.Map as M+import qualified Data.IntMap as IM+import qualified Data.IntSet as IS+import qualified Data.Set as S+import qualified Data.Sequence as Seq+import Data.Maybe (isNothing)+import Data.STRef+import Data.Array.ST+import Data.List (intercalate, foldl', nub)+import CommonTypes+import Control.Arrow+import Control.Monad.ST+import Control.Monad (forM, when, forM_, forM_, foldM)++import LOAG.Graphs++data Ag = Ag    (Int,Int)   -- attribute  range+                (Int,Int)   -- occurrence range+                [Edge]      -- direct dependencies+                [Nt]        -- non-terminals+data Nt = Nt String +                [Edge] -- direct dps from inh -> syn+                [Edge] -- direct dps from syn -> inh +                -- inh attributes with direction and instances+                [(Vertex,[Vertex],Direction)]+                -- syn attributes with direction and instances+                [(Vertex,[Vertex],Direction)]+                [Pr]            -- productions of this Nt+    deriving (Show)+data Pr = Pr    PLabel+                [Edge]          -- direct dependencies between fields+                [(Edge,Edge,Bool)] -- all siblings pairs, with generalised version, and boolean that denotes whether if it is an edge of LHS+                [Fd]            -- the fields of this production, including lhs+    deriving (Show)+data Fd = Fd    String          -- field name+                String          -- type of the field+                [(Vertex,Vertex)]        -- inherited atts (gen, inst)+                [(Vertex,Vertex)]        -- synthesized atts (gen, inst)+    deriving (Show)++type Attrs = [Attr]+data Attr  = Attr String Direction MyType+    deriving (Show, Eq, Ord)+data Direction = Inh | AnyDir | Syn+    deriving (Show, Ord, Enum)+++foldM' :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a+foldM' _ a [] = return a+foldM' f a (x:xs) = f a x >>= \fax -> fax `seq` foldM f fax xs++modifyArray r k f = do+    v <- readArray r k+    writeArray r k (f v)++setConcatMap f = S.foldr (S.union . f) S.empty+isLoc (MyOccurrence (_,f) _) = f == "loc" || f == "inst" -- transparent occr ? ++instance Eq Direction where+    Inh == Syn = False+    Syn == Inh = False+    _ == _     = True++data MyType = TyInt+            | TyBool+            | TyString+            | TyData String+            | TyLit String+            | TyArr MyType MyType+            | NoType  -- the empty set of values (no members)+            | AnyType -- the set of all values (union of all types)++type SchedRef s = (STArray s Vertex (Maybe Int),ThreadRef s)+type AttrAssRef s = STArray s Vertex (Maybe Int)+type ThreadRef s = STRef s InterfaceRes+-- production is identified by its name and its parent non-terminal+type PLabel = (MyType,String) +type FLabel = String -- field label+-- attribute is identified by its name and its direction+type ALabel = (String, Direction)+type AI_N   = M.Map MyType MyAttributes+type AS_N   = M.Map MyType MyAttributes+type A_N    = M.Map MyType MyAttributes+type A_P    = M.Map PLabel MyOccurrences+-- Get the (data)type of a certain child at a certain production+type FTY    = M.Map (PLabel, FLabel) MyType+-- Get the fields corresponding to a certain type+type TYFS   = M.Map MyType [(PLabel, FLabel)]+-- the definition of given occ uses these occs+type SF_P   = M.Map MyOccurrence (S.Set MyOccurrence) +type PMP    = M.Map Int MyOccurrence+type PMP_R  = M.Map MyOccurrence Int+type NMP    = M.Map Int MyAttribute+type NMP_R  = M.Map MyAttribute Int+type FMap   = M.Map (PLabel,FLabel) (S.Set MyOccurrence, S.Set MyOccurrence)+type FsInP  = M.Map PLabel [(PLabel, FLabel)]+type LOAGRes =  ( Maybe TDPRes +                , InterfaceRes+                , ADSRes)+type VisCount= (Int, Int, Float)+type ADSRes  = [Edge]+type TDPRes  = A.Array Vertex Vertices --M.Map PLabel TDPGraph+type TDPGraph = (IM.IntMap Vertices, IM.IntMap Vertices) +type InterfaceRes = M.Map String (IM.IntMap [Vertex])+type HOMap   = M.Map PLabel (S.Set FLabel) +data CType = T1 | T2 +           | T3 [Edge] -- completing edges from which to select candidates+    deriving (Show)++findWithErr :: (Ord k, Show k, Show a) => M.Map k a -> String -> k -> a+findWithErr m err k = maybe (error err) id $ M.lookup k m+findWithErr' m err k= maybe (error err) id $ IM.lookup k m++-- Defining the MyAttribute (attribute at non-terimal+-- and the MyOccurrences (attribute at a production)+type MyAttributes = [MyAttribute]+data MyAttribute  = MyAttribute {typeOf :: MyType, alab :: ALabel}+    deriving (Ord, Eq)+(<.>)         = MyAttribute+infixl 7 <.>+instance Show MyAttribute where+    show (MyAttribute t a) = show t ++ "<.>" ++ show a++type MyOccurrences = [MyOccurrence]+data MyOccurrence = MyOccurrence {argsOf :: (PLabel, FLabel), attr :: ALabel}+    deriving (Ord, Eq)+(>.<)         = MyOccurrence+infixl 8 >.<+instance Show MyOccurrence where+    show (MyOccurrence ((t,p),f) a) = +        intercalate "." [show t,p,f] ++ "."++ show a++dirOfOcc :: MyOccurrence -> Direction+dirOfOcc = snd . attr++handOut :: (PLabel, FLabel) -> MyAttribute -> MyOccurrence+handOut p = (p >.<) . alab++handAllOut :: (PLabel, FLabel) -> MyAttributes -> MyOccurrences+handAllOut p os = map (handOut p) os++map2F  :: (Ord a)        => M.Map a [b] -> a -> [b]+map2F m a = case M.lookup a m of+              Nothing -> []+              Just bs -> bs++map2F'  :: (Ord a)        => M.Map a (S.Set b) -> a -> (S.Set b)+map2F' m a = case M.lookup a m of+               Nothing -> S.empty+               Just bs -> bs++flipDir :: Direction -> Direction+flipDir Syn = Inh+flipDir Inh = Syn++-- creates all pairs of elements such that no equal elements end up in a pair+-- and considering only one direction+pairs :: [a] -> [(a,a)]+pairs [] = []+pairs (x:xs) = map ((,) x) xs ++ pairs xs++toMyTy :: Type -> MyType+toMyTy (Haskell str) = TyLit str+toMyTy (NT id _ _ )  = TyData $ getName id+toMyTy Self          = error "Type Self in phase 3"++fromMyTy :: MyType -> Type+fromMyTy (TyLit str) = (Haskell str)+fromMyTy (TyData id) = NT (identifier id) [] False++toMyAttr :: Direction -> MyType -> Attributes -> MyAttributes+toMyAttr d dty = M.foldrWithKey +                    (\ident ty as -> dty <.> (getName ident,d):as) []++completing :: FrGraph -> SchedRef s -> [Nt] -> ST s InterfaceRes+completing ids sched nts = do   +    ims <- forM nts $ completingN ids (fst sched)+    let threads = (M.fromList ims)+    writeSTRef (snd sched) threads+    return $ threads ++completingN :: FrGraph -> AttrAssRef s -> Nt -> +                    ST s ((String, IM.IntMap [Vertex]))+completingN ids@(idsf, idst) schedA+                (Nt nt_id _ _ inhs syns _) = do+    schedS <- newSTRef IM.empty+    let attrs = inhs ++ syns+        dty = TyData nt_id+        assign (attr,_,dAttr) = do+         let succs = idsf A.! attr+         assigned <- freeze schedA+         when (isNothing $ assigned A.! attr) $ do+           case IS.toList succs of +             [] ->wrap_up attr(if Syn==dAttr then 1 else 2)+             ss ->case selMax $ map (id&&&(assigned A.!)) ss of+                      Nothing -> return ()+                      Just (a,mx) -> do+                          let dA | even mx   = Inh+                                 | otherwise = Syn+                          wrap_up attr (if dA == dAttr +                                          then mx else mx+1)+        wrap_up attr k = do+         modifySTRef schedS (IM.insertWith (++) k [attr])+         writeArray schedA attr (Just k)+         forM_ attrs assign+        selMax :: [(Vertex, Maybe Int)] -> Maybe (Vertex, Int)+        selMax [(v,mi)] = fmap ((,) v) mi+        selMax (x:xs)  = case x of +                          (a', Nothing) -> Nothing+                          (a', Just i') -> +                            case selMax xs of +                             Nothing -> Nothing+                             Just (a,i)  -> +                                case compare i i' of+                                 LT -> Just (a',i')+                                 _  -> Just (a,i)+    --make sure all are assigned+    case attrs of+      [] -> return (nt_id, IM.fromList [(1,[]),(2,[])])+      as -> forM_ as assign >> readSTRef schedS >>= return . ((,) nt_id)++fetchEdges :: FrGraph -> InterfaceRes -> [Nt] -> ([Edge],[Edge])+fetchEdges ids threads nts =+    let ivdNs = map (fetchEdgesN ids threads) nts+    in (concat *** concat) $ unzip ivdNs++fetchEdgesN :: FrGraph -> InterfaceRes -> Nt+                    -> ([Edge],[Edge])+fetchEdgesN (idsf, idst) threads +        (Nt nt_id _ _ _ _ _) =+    let sched = findWithErr threads "schedule err" nt_id+        mx    = if IM.null sched then 0 else fst $ IM.findMax sched+        findK 0 = []+        findK k = (maybe [] id $ IM.lookup k sched) ++ findK (k-1)+        ivd =  [ (f,t) | k <- [2..mx]+                   , f <- maybe [] id $ IM.lookup k sched+                   , t <- findK (k-1)]+     in (ivd, [ (f, t) | (f, t) <- ivd+                          , not $ IS.member t (idsf A.! f) ])++instance Show MyType where+    show TyInt        = "Int"+    show TyBool       = "Bool"+    show TyString     = "String"+    show (TyData t)   = t+    show (TyLit t)    = show t+    show (TyArr a b)  = show a ++ " -> (" ++ show b ++ ")" +    show NoType       = error "Trying to show NoType"+    show AnyType      = "AnyType"++-- | Instance for Eq and Ord are required to make sure that AnyType+-- | Equals every other type in every other situation+instance Eq MyType where+    TyInt       == TyInt        = True+    TyBool      == TyBool       = True+    TyString    == TyString     = True+    TyData n    == TyData n'    = n == n'+    TyLit ty    == TyLit ty'    = ty == ty'+    TyArr l r   == TyArr l' r'  = l == l' && r == r'+    NoType      == _            = False+    _           == NoType       = False+    AnyType     == _            = True+    _           == AnyType      = True+    _           == _            = False++instance Ord MyType where+    NoType `compare` _          = LT+    _   `compare` NoType        = GT+    AnyType `compare` _         = EQ+    _   `compare` AnyType       = EQ+    TyInt `compare` TyInt       = EQ+    TyInt `compare` _           = LT+    TyBool `compare` TyInt      = GT+    TyBool `compare` TyBool     = EQ+    TyBool `compare` _          = LT+    TyString `compare` TyInt    = GT+    TyString `compare` TyBool   = GT+    TyString `compare` TyString = EQ+    TyString `compare` _        = LT+    TyData _ `compare` TyInt    = GT+    TyData _ `compare` TyBool   = GT+    TyData _ `compare` TyString = GT+    TyData a `compare` TyData b = compare a b+    TyData _ `compare` _        = LT+    TyLit  a `compare` TyLit b  = compare a b+    TyLit  _ `compare` TyArr _ _= LT    +    TyLit  _ `compare` _        = GT+    TyArr a a' `compare` TyArr b b' = +        case compare a b of+            LT -> LT+            GT -> GT+            EQ -> compare a' b'+    TyArr _ _ `compare` _       = GT+
src/LOAG/Graphs.hs view
@@ -1,155 +1,155 @@-module LOAG.Graphs where
-
-import Control.Monad (forM, forM_)
-import Control.Monad.ST
-import Control.Monad.State
-import CommonTypes
-import Data.STRef
-import Data.Maybe (catMaybes, isNothing, fromJust)
-import Data.Tuple (swap)
-import qualified Data.Array as A
-import           Data.Array.IArray (amap)
-import qualified Data.IntMap as IM
-import qualified Data.IntSet as IS
-import qualified Data.Map as M
-import qualified Data.Set as S
-import Data.Array.MArray (mapArray)
-import Data.Array.ST
-
-type Schedule   = (A.Array Vertex (Maybe Int), A.Array Int [Vertex])
-type Vertex     = Int
-type Cycle      = IS.IntSet
-type Vertices   = IS.IntSet
-type Edge       = (Vertex, Vertex)
-type Edges      = S.Set Edge
--- Maps that are suitable for Graphs (from 1 node to a set of nodes)
-type Graph s    = (DirGraphRef s, DirGraphRef s)
--- | Frozen version of a graph
-type FrGraph    = (DirGraph, DirGraph)
-type DirGraph   = A.Array Vertex Vertices
-type DirGraphRef s = STArray s Vertex Vertices
-
--- |----------------------------------------------------------------------
--- | Functions for changing the state within AOAG
--- |  possibly catching errors from creating cycles
-
-addEDs :: Graph s -> [Edge] -> (ST s) (Maybe (Edge, Cycle))
-addEDs _ [] = return Nothing
-addEDs edp (e:es) = do
-    res <- e `inserT` edp
-    case res of
-        Right _ -> addEDs edp es
-        Left c  -> return $ Just (e,c)
-       
--- | Draws an edge from one node to another, by adding the latter to the
---    node set of the first
-insErt :: Edge -> Graph s -> (ST s) ()
-insErt (f, t) g@(ft,tf) = do 
-    ts <- readArray ft f
-    fs <- readArray tf t
-    writeArray ft f (t `IS.insert` ts)
-    writeArray tf t (f `IS.insert` fs)
-
-removE :: Edge -> Graph s -> (ST s) ()
-removE e@(f,t) g@(ft,tf) = do 
-    ts <- readArray ft f
-    fs <- readArray tf t
-    writeArray ft f (t `IS.delete` ts)
-    writeArray tf t (f `IS.delete` fs)
-
-
--- | Revert an edge in the graph
-revErt :: Edge -> Graph s -> (ST s) ()
-revErt e g = do
-    present <- member e g
-    when present $ removE e g >> insErt (swap e) g
-
--- | Assuming the given graph is already transitively closed, and
--- |    not cyclic, insert an 
--- |    edge such that the graph maintains transitively closed.
--- |    returns the cycle if this results in a cycle or returns a pair
--- |    (graph, edges) if not. Where graph is the new Graph and 
--- |    edges represent the edges that were required for transitively
--- |    closing the graph.
-inserT :: Edge -> Graph s -> (ST s) (Either Cycle [Edge])
-inserT e@(f, t) g@(gft,gtf)
-    | f == t     = return $ Left $ IS.singleton f
-    | otherwise  = do
-        present <- member e g
-        if present 
-         then (return $ Right [])
-         else do
-          rs <- readArray gtf f
-          us <- readArray gft t
-          pointsToF <- readArray gtf f
-          pointsToT <- readArray gtf t
-          tPointsTo <- readArray gft t
-          let new2t = pointsToF IS.\\ pointsToT
-          -- extras from f connects all new nodes pointing to f with t
-          let extraF = IS.foldl' (\acc tf -> (tf,t) : acc) [] new2t
-          -- extras of t connects all nodes that will be pointing to t
-          -- in the new graph, with all the nodes t points to in the
-          -- current graph
-          all2tPointsTo <- newSTRef []
-          forM_ (IS.toList tPointsTo) $ \ft -> do
-            current  <- readSTRef all2tPointsTo
-            existing <- readArray gtf ft
-            let new4ft = map (flip (,) ft) $ IS.toList $ 
-                            -- removing existing here matters a lot
-                            (f `IS.insert` pointsToF) IS.\\ existing
-            writeSTRef all2tPointsTo $ current ++ new4ft
-                  
-          extraT <- readSTRef all2tPointsTo
-        -- the extras consists of extras from f and extras from t
-        -- both these extra sets dont contain edges if they are already 
-        -- present in the old graph
-          let extra  = extraF ++ extraT
-          mapM_ (`insErt` g) (e : extra) 
-        -- the new graph contains a cycle if there is a self-edge
-        -- this cycle will contain both f and t
-          cyclic <- member (f,f) g
-          if cyclic
-           then do
-            cycle <- getCycle gft
-            return $ Left cycle
-           else return $ Right extra
-        
-       where
-        -- given that there is a cycle,all elements of this cycle are being
-        -- pointed at by f. However, not all elements that f points to are 
-        -- part of the cycle. Only those that point back to f.
-        getCycle :: STArray s Vertex Vertices -> (ST s) Cycle
-        getCycle gft = do
-            ts <- readArray gft f
-            mnodes <- forM (IS.toList ts) $ \t' -> do
-                fs' <- readArray gft t'
-                if f `IS.member` fs'
-                 then return $ Just t'
-                 else return $ Nothing
-            return $ IS.fromList $ catMaybes mnodes
-
--- | Check if a certain edge is part of a graph which means that,
--- |  the receiving node must be in the node set of the sending
-member :: Edge -> Graph s -> (ST s) Bool
-member (f, t) (ft, tf) = do
-    ts <- readArray ft f
-    return $ IS.member t ts
-
--- | Check whether an edge is part of a frozen graph
-fr_member :: FrGraph -> Edge -> Bool
-fr_member (ft, tf) (f, t) = IS.member t (ft A.! f)
-
--- | Flatten a graph, meaning that we transform this graph to 
--- |  a set of Edges by combining a sending node with all the
--- |  receiving nodes in its node set
-flatten :: Graph s -> (ST s) Edges 
-flatten (gft, _) = do
-    list <- getAssocs gft
-    return $ S.fromList $ concatMap 
-                (\(f, ts) -> map ((,) f) $ IS.toList ts) list
-
-freeze_graph :: Graph s -> (ST s) FrGraph
-freeze_graph (mf, mt) = do
-    fr_f <- freeze mf
-    fr_t <- freeze mt
-    return (fr_f, fr_t)
+module LOAG.Graphs where++import Control.Monad (forM, forM_)+import Control.Monad.ST+import Control.Monad.State+import CommonTypes+import Data.STRef+import Data.Maybe (catMaybes, isNothing, fromJust)+import Data.Tuple (swap)+import qualified Data.Array as A+import           Data.Array.IArray (amap)+import qualified Data.IntMap as IM+import qualified Data.IntSet as IS+import qualified Data.Map as M+import qualified Data.Set as S+import Data.Array.MArray (mapArray)+import Data.Array.ST++type Schedule   = (A.Array Vertex (Maybe Int), A.Array Int [Vertex])+type Vertex     = Int+type Cycle      = IS.IntSet+type Vertices   = IS.IntSet+type Edge       = (Vertex, Vertex)+type Edges      = S.Set Edge+-- Maps that are suitable for Graphs (from 1 node to a set of nodes)+type Graph s    = (DirGraphRef s, DirGraphRef s)+-- | Frozen version of a graph+type FrGraph    = (DirGraph, DirGraph)+type DirGraph   = A.Array Vertex Vertices+type DirGraphRef s = STArray s Vertex Vertices++-- |----------------------------------------------------------------------+-- | Functions for changing the state within AOAG+-- |  possibly catching errors from creating cycles++addEDs :: Graph s -> [Edge] -> (ST s) (Maybe (Edge, Cycle))+addEDs _ [] = return Nothing+addEDs edp (e:es) = do+    res <- e `inserT` edp+    case res of+        Right _ -> addEDs edp es+        Left c  -> return $ Just (e,c)+       +-- | Draws an edge from one node to another, by adding the latter to the+--    node set of the first+insErt :: Edge -> Graph s -> (ST s) ()+insErt (f, t) g@(ft,tf) = do +    ts <- readArray ft f+    fs <- readArray tf t+    writeArray ft f (t `IS.insert` ts)+    writeArray tf t (f `IS.insert` fs)++removE :: Edge -> Graph s -> (ST s) ()+removE e@(f,t) g@(ft,tf) = do +    ts <- readArray ft f+    fs <- readArray tf t+    writeArray ft f (t `IS.delete` ts)+    writeArray tf t (f `IS.delete` fs)+++-- | Revert an edge in the graph+revErt :: Edge -> Graph s -> (ST s) ()+revErt e g = do+    present <- member e g+    when present $ removE e g >> insErt (swap e) g++-- | Assuming the given graph is already transitively closed, and+-- |    not cyclic, insert an +-- |    edge such that the graph maintains transitively closed.+-- |    returns the cycle if this results in a cycle or returns a pair+-- |    (graph, edges) if not. Where graph is the new Graph and +-- |    edges represent the edges that were required for transitively+-- |    closing the graph.+inserT :: Edge -> Graph s -> (ST s) (Either Cycle [Edge])+inserT e@(f, t) g@(gft,gtf)+    | f == t     = return $ Left $ IS.singleton f+    | otherwise  = do+        present <- member e g+        if present +         then (return $ Right [])+         else do+          rs <- readArray gtf f+          us <- readArray gft t+          pointsToF <- readArray gtf f+          pointsToT <- readArray gtf t+          tPointsTo <- readArray gft t+          let new2t = pointsToF IS.\\ pointsToT+          -- extras from f connects all new nodes pointing to f with t+          let extraF = IS.foldl' (\acc tf -> (tf,t) : acc) [] new2t+          -- extras of t connects all nodes that will be pointing to t+          -- in the new graph, with all the nodes t points to in the+          -- current graph+          all2tPointsTo <- newSTRef []+          forM_ (IS.toList tPointsTo) $ \ft -> do+            current  <- readSTRef all2tPointsTo+            existing <- readArray gtf ft+            let new4ft = map (flip (,) ft) $ IS.toList $ +                            -- removing existing here matters a lot+                            (f `IS.insert` pointsToF) IS.\\ existing+            writeSTRef all2tPointsTo $ current ++ new4ft+                  +          extraT <- readSTRef all2tPointsTo+        -- the extras consists of extras from f and extras from t+        -- both these extra sets dont contain edges if they are already +        -- present in the old graph+          let extra  = extraF ++ extraT+          mapM_ (`insErt` g) (e : extra) +        -- the new graph contains a cycle if there is a self-edge+        -- this cycle will contain both f and t+          cyclic <- member (f,f) g+          if cyclic+           then do+            cycle <- getCycle gft+            return $ Left cycle+           else return $ Right extra+        +       where+        -- given that there is a cycle,all elements of this cycle are being+        -- pointed at by f. However, not all elements that f points to are +        -- part of the cycle. Only those that point back to f.+        getCycle :: STArray s Vertex Vertices -> (ST s) Cycle+        getCycle gft = do+            ts <- readArray gft f+            mnodes <- forM (IS.toList ts) $ \t' -> do+                fs' <- readArray gft t'+                if f `IS.member` fs'+                 then return $ Just t'+                 else return $ Nothing+            return $ IS.fromList $ catMaybes mnodes++-- | Check if a certain edge is part of a graph which means that,+-- |  the receiving node must be in the node set of the sending+member :: Edge -> Graph s -> (ST s) Bool+member (f, t) (ft, tf) = do+    ts <- readArray ft f+    return $ IS.member t ts++-- | Check whether an edge is part of a frozen graph+fr_member :: FrGraph -> Edge -> Bool+fr_member (ft, tf) (f, t) = IS.member t (ft A.! f)++-- | Flatten a graph, meaning that we transform this graph to +-- |  a set of Edges by combining a sending node with all the+-- |  receiving nodes in its node set+flatten :: Graph s -> (ST s) Edges +flatten (gft, _) = do+    list <- getAssocs gft+    return $ S.fromList $ concatMap +                (\(f, ts) -> map ((,) f) $ IS.toList ts) list++freeze_graph :: Graph s -> (ST s) FrGraph+freeze_graph (mf, mt) = do+    fr_f <- freeze mf+    fr_t <- freeze mt+    return (fr_f, fr_t)
src/LOAG/Optimise.hs view
@@ -1,304 +1,304 @@-
-module LOAG.Optimise where
-
-import LOAG.Common
-import LOAG.Graphs
-import LOAG.Solver.MiniSat
-
-import              Control.Arrow ((&&&))
-import              Control.Monad (forM, forM_, when, foldM)
-import              Control.Monad.ST
-import              Data.Array.MArray
-import              Data.Array.IO
-import              Data.Function (on)
-import qualified    Data.IntMap as IM
-import qualified    Data.IntSet as IS
-import qualified    Data.Map    as M
-import              Data.Maybe  (fromJust, isJust)
-import              Data.List   (intercalate, sort, sortBy)
-
-type Opts = [Opt]
-data Opt= Smaller    (Vertex) (Vertex) -- x < y 
-        | Greater    (Vertex) (Vertex) -- x > y
-        | AllSmaller (Vertex) Direction          -- _ < x
-        | AllGreater (Vertex) Direction          -- _ > x
-        | MinVisits
-  deriving (Ord, Eq)
-
-instance Show Opt where
-    show (Smaller f t)      = show f ++ " --> " ++ show t
-    show (Greater f t)      = show f ++ " <-- " ++ show t
-    show (AllSmaller f _)   = " _ --> " ++ show f
-    show (AllGreater f _)   = " _ <-- " ++ show f
-    show MinVisits          = " Minimising #visits "
-
-
-optimise :: Sat -> VarMap -> Opts -> (Int,Int) -> [Nt] -> InterfaceRes -> IO ()
-optimise sat varMap opts nbounds nts interfaces = do 
-    let scheduler = newSchedule sat varMap nbounds
-    mapM_ (singleOpt sat varMap scheduler nts interfaces) (sort opts)
-    b <- satsolve sat []
-    return ()
-
--- | Given a non-terminal and a current best schedule
---     return a new best schedule and whether the new schedule is truely new
-type SchedulerNt = Nt -> IM.IntMap [Vertex] -> IO (Bool, IM.IntMap [Vertex])
-type Scheduler   = IM.IntMap [Vertex] -> IO (Bool, IM.IntMap [Vertex])
-
-singleOpt :: Sat -> VarMap -> SchedulerNt -> [Nt] -> InterfaceRes -> Opt -> 
-                IO ()
-singleOpt sat varMap scheduler nts interfaces opt = do
-    success <- 
-      case opt of 
-        Smaller f t     -> tryPair sat $ varOf f t 
-        Greater f t     -> tryPair sat $ varOf t f
-        AllSmaller f d  -> trySingle sat False f d varMap
-        AllGreater f d  -> trySingle sat True f d varMap
-        MinVisits -> do mapM_ (minPaths sat varMap scheduler interfaces) $ 
-                          sortNfilter weigh nts
-                        return True
-    return ()
- where weigh (Nt _ _ _ is ss _) = size
-        where size = length is + length ss
-       varOf f t = case M.lookup (f,t) varMap of
-                    Just v  -> v
-                    Nothing -> case M.lookup (t,f) varMap of
-                                Just v  -> varnot v
-                                Nothing -> error "invalid optimisation.."
-
-sortNfilter :: (a -> Int) -> [a] -> [a]
-sortNfilter f = 
-    map fst . sortBy (on compare snd) . 
-                  filter (((/=) 0) . snd) . map (id &&& f)
-
-minPaths :: Sat -> VarMap -> SchedulerNt -> InterfaceRes -> Nt -> IO Bool 
-minPaths sat varMap scheduler interfaces tp@(Nt nt _ _ is ss _) = do
-    forM_ neckCs $ attemptGroup sat (scheduler tp) mym . map varnot
-    return True 
- where  neckCs= map (\(_,es,b) -> map (uncurry (mvar b)) es) $ 
-                    bottlenecks mx mym
-        mvar b f t | b       = varMap M.! (f,t)
-                   | not b   = varnot $ varMap M.! (t,f)
-        mym   = interfaces M.! nt
-        mx    | IM.null mym = 0
-              | otherwise   = fst $ IM.findMax mym
-
-bottlenecks :: Int -> IM.IntMap [Vertex] -> 
-                [(((Int,[Vertex]),(Int,[Vertex])),[Edge],Bool)]
-bottlenecks x shd = 
-    sortNfilter cost $ pairs x
- where  pairs x | x <= 1 = []
-                | x >  1 = let pair = ((x,maybe [] id $ IM.lookup x shd)
-                                      ,(x-1,maybe [] id$IM.lookup (x-1) shd))
-                           in (pair,edges pair,even x) : pairs (x-1)
-        cost (((p1,p1s),(p2,p2s)),es,_) = size 
-         where size = length es 
-        edges ((p1,p1s),(p2,p2s)) = [ (f,t) | f <- p1s, t <- p2s ] 
-
--- | get all combinations of partitions from different `directions'
---      ordered by distance (shortest paths first)
-edgeCombs :: Int -> IM.IntMap [Vertex] -> [(Int,Int)]
-edgeCombs x shd = 
-    sortBy (on compare cost) $
-        concat $
-        takeWhile (not . null) $
-        map (\(n,es) -> filter ((>0) . snd) 
-            (map (\(f,t) -> (f+n,t+n)) es)) $
-        zip [-0,-1..] $
-        repeat (map ((,) x) [x-1,x-3..1])
- where cost (x1,x2) = length $ findK (x1 -1)
-        where findK n | n < x2  = []
-                      | n >= x2 = (shd IM.! n) ++ findK (n-2)
-
-tryPair :: Sat -> MyVar -> IO Bool 
-tryPair sat p = do
-    b  <- satsolve sat [p]
-    if b then addClause sat [p]
-         else return False
-
-attemptGroup :: Sat -> Scheduler -> IM.IntMap [Vertex] -> [MyVar] -> 
-                        IO (IM.IntMap [Vertex])
-attemptGroup sat scheduler interfaces = 
-    tryGroup sat scheduler interfaces . filter notSet 
- where  notSet (Var _)      = True
-        notSet (VarNot v)   = notSet v
-        notSet _            = False
-
-tryGroup :: Sat -> Scheduler -> IM.IntMap [Vertex] -> [MyVar] -> 
-                IO (IM.IntMap [Vertex])
-tryGroup _ _ interfaces []           = return interfaces
-tryGroup sat scheduler interfaces ps = do
-    xs  <- mapM (const (newLit sat)) ps
-    mapM (\(a,r) -> addClause sat [varnot a, r]) $ zip xs ps
-    b  <- satsolve sat xs
-    let success = assertVars sat xs
-        fail    = assertVars sat (map varnot (xs++ps)) >> satsolve sat []
-    if b then do    (improved, sched) <- scheduler interfaces
-                    if improved 
-                        then success >> return sched
-                        else fail    >> return interfaces 
-         else fail >> return interfaces
-
-assertVars :: Sat -> [MyVar] -> IO ()
-assertVars sat vars = do    bs <- mapM (addClause sat . (:[])) vars
-                            return ()
- 
-trySingle :: Sat -> Bool -> Vertex -> Direction -> VarMap -> IO Bool
-trySingle sat des f dir varMap = do
-        vars <- tryExtreme sat des literals
-        assertVars sat vars
-        return True
- where  literals = M.foldrWithKey select [] varMap
-        select k a b | fst k == f = a : b --inh
-                     | snd k == f = varnot a : b --syn
-                     | otherwise  = b
-
-tryExtreme :: Sat -> Bool -> [MyVar] -> IO [MyVar]
-tryExtreme sat des xs =
-  do a <- newLit sat
-     switch <- newLit sat
-     let try xs =
-           do --putStrLn ("currently, " ++ show (length xs) ++ " literals")
-              let assertOne | des       = map varnot (a : xs)
-                            | otherwise = varnot a : xs
-              addClause sat assertOne --"if a, then one of xs must be ~des"
-              b <- satsolve sat [a]
-              if b then
-                do xbs <- sequence [ do v <- value sat x
-                                        return (x,v)
-                                   | x <- xs
-                                   ]
-                   sequence_ [ do let desx | des        = x
-                                           | otherwise  = varnot x
-                                  addClause sat [varnot a, desx] 
-                                  addClause sat [varnot switch, desx]
-                             | (x,b) <- xbs, b /= Just des ]
-                   try [ x | (x,Just des) <- xbs ]
-               else do  addClause sat [varnot a]
-                        return [switch]
-      in try xs
-
--- | Recalculate interface based on SAT and compare with a given one
-newSchedule :: Sat -> VarMap -> (Int,Int) -> Nt -> IM.IntMap [Vertex] ->
-                IO (Bool, IM.IntMap [Vertex])
-newSchedule sat varMap nbounds tp@(Nt nt _ _ inhs outs _ ) sched = do
-    idsf <- newArray nbounds IS.empty :: IO (IOArray Vertex Vertices)
-    idst <- newArray nbounds IS.empty :: IO (IOArray Vertex Vertices)
-    let ids = (idsf,idst)
-    sequence_ [ do  v <- value sat pred
-                    case v of
-                      Nothing -> error "no val"
-                      Just True -> addEdges (i,s) ids 
-                      Just False-> addEdges (s,i) ids
-            | (i,ios,_) <- inhs
-            , (s,sos,_) <- outs
-            , let pred = varMap M.! (i,s)
-            ]
-    f_idsf <- freeze idsf
-    f_idst <- freeze idst
-    let (_,newinterface) = runST $ do   schedA <- newArray nbounds Nothing
-                                        completingN (f_idsf,f_idst) schedA tp
-        newmx | IM.null newinterface = 0
-              | otherwise            = fst $ IM.findMax newinterface
-        oldmx | IM.null sched        = 0
-              | otherwise            = fst $ IM.findMax sched 
-        newsched | newmx < oldmx = newinterface
-                 | otherwise     = sched
-    return $ (newmx < oldmx, newsched)
- where  addEdges
-          :: (Vertex, Vertex)
-          -> (IOArray Vertex Vertices, IOArray Vertex Vertices)
-          -> IO ()
-        addEdges (f,t) (idsf,idst) = do
-            modifyArray idsf f (t `IS.insert`)
-            modifyArray idst t (f `IS.insert`)
- 
--- | count the (max, avg, total) number of visits
-getVisCount :: [Nt] -> InterfaceRes -> VisCount
-getVisCount nts interfaces = 
-    (mx, tot, (fromIntegral tot) / (fromIntegral $ length nts))
- where  count (mx,tot) (Nt nt _ _ _ _ _) = (max mx k,tot + k)
-         where m = interfaces M.! nt
-               k | IM.null m = 0
-                 | otherwise = ((fst $ IM.findMax m) + 1) `div` 2
-        (mx, tot) = foldl count (0,0) nts
---- minimisation functions
--------------------------------------------------------------------------------
-
-globalMinimum :: Sat -> Bool -> [MyVar] -> IO [MyVar]
-globalMinimum sat des xs =
-  do ys <- sort sat xs
-     let mini (i,j) | i >= j = return []
-         mini (i,j) = do    putStrLn ("trying " ++ show (i,j))
-                            b <- satsolve sat [varnot (ys !! k)]
-                            if b then mini (k+1,j)
-                                 else mini (i,k)
-          where
-           k = (i+j) `div` 2
-      in mini (0,length ys)
-     xbs <- sequence [ do v <- value sat x
-                          return (x,v)
-                     | x <- xs
-                     ]
-     return [ x | (x,Just True) <- xbs ]
- where
-  sort sat []  = do return []
-  sort sat [x] = do return [x]
-  sort sat xs  = do as <- sort sat (take k xs)
-                    bs <- sort sat (drop k xs)
-                    map fromJust `fmap` merge (map Just as) (map Just bs)
-   where
-    k = length xs `div` 2
-
-  merge2 Nothing b = return (b, Nothing)
-  merge2 a Nothing = return (a, Nothing)
-  merge2 (Just x) (Just y) =
-    do a <- newLit sat
-       b <- newLit sat
-       addClause sat [varnot x, b]         -- x => b
-       addClause sat [varnot y, b]         -- y => b
-       addClause sat [varnot x, varnot y, a]  -- x => ~y || a
-       addClause sat [x, varnot a]         -- ~x => ~a
-       addClause sat [y, varnot a]         -- ~y => ~a
-       addClause sat [x, y, varnot b]      -- ~x => y || ~b
-       return (Just a,Just b)
-  
-  merge []  bs  = return bs
-  merge as  []  = return as
-  merge [a] [b] = (\(a,b) -> [a,b]) `fmap` merge2 a b
-  merge as  bs  = take (a+b) `fmap` merge' (as ++ xas) (bs ++ xbs)
-   where
-    a   = length as
-    b   = length bs
-    m   = a `max` b
-    n   = if even m then m else m+1
-    xas = replicate (n-a) Nothing
-    xbs = replicate (n-b) Nothing
-  
-  -- pre: as and bs have the same, even length
-  merge' as bs =
-    do xs <- merge eas ebs
-       ys <- merge oas obs
-       let x:xys = weave xs ys
-       xys' <- sequence [ merge2 a b | (a,b) <- pairs xys ]
-       return (x : unpairs xys' ++ [last xys])
-   where
-    (eas,oas) = evenOdds as
-    (ebs,obs) = evenOdds bs
-
-  evenOdds []       = ([], [])
-  evenOdds [x]      = ([x], [])
-  evenOdds (x:y:xs) = (x:es,y:os)
-   where
-    (es,os) = evenOdds xs
-
-  pairs (x:y:xs) = (x,y) : pairs xs
-  pairs _        = []
-  
-  unpairs ((x,y):xys) = x : y : unpairs xys
-  unpairs []          = []
-  
-  weave (x:xs) (y:ys) = x : y : weave xs ys
-  weave xs     ys     = xs ++ ys
-
-------------------------------------------------------------------------------
++module LOAG.Optimise where++import LOAG.Common+import LOAG.Graphs+import LOAG.Solver.MiniSat++import              Control.Arrow ((&&&))+import              Control.Monad (forM, forM_, when, foldM)+import              Control.Monad.ST+import              Data.Array.MArray+import              Data.Array.IO+import              Data.Function (on)+import qualified    Data.IntMap as IM+import qualified    Data.IntSet as IS+import qualified    Data.Map    as M+import              Data.Maybe  (fromJust, isJust)+import              Data.List   (intercalate, sort, sortBy)++type Opts = [Opt]+data Opt= Smaller    (Vertex) (Vertex) -- x < y +        | Greater    (Vertex) (Vertex) -- x > y+        | AllSmaller (Vertex) Direction          -- _ < x+        | AllGreater (Vertex) Direction          -- _ > x+        | MinVisits+  deriving (Ord, Eq)++instance Show Opt where+    show (Smaller f t)      = show f ++ " --> " ++ show t+    show (Greater f t)      = show f ++ " <-- " ++ show t+    show (AllSmaller f _)   = " _ --> " ++ show f+    show (AllGreater f _)   = " _ <-- " ++ show f+    show MinVisits          = " Minimising #visits "+++optimise :: Sat -> VarMap -> Opts -> (Int,Int) -> [Nt] -> InterfaceRes -> IO ()+optimise sat varMap opts nbounds nts interfaces = do +    let scheduler = newSchedule sat varMap nbounds+    mapM_ (singleOpt sat varMap scheduler nts interfaces) (sort opts)+    b <- satsolve sat []+    return ()++-- | Given a non-terminal and a current best schedule+--     return a new best schedule and whether the new schedule is truely new+type SchedulerNt = Nt -> IM.IntMap [Vertex] -> IO (Bool, IM.IntMap [Vertex])+type Scheduler   = IM.IntMap [Vertex] -> IO (Bool, IM.IntMap [Vertex])++singleOpt :: Sat -> VarMap -> SchedulerNt -> [Nt] -> InterfaceRes -> Opt -> +                IO ()+singleOpt sat varMap scheduler nts interfaces opt = do+    success <- +      case opt of +        Smaller f t     -> tryPair sat $ varOf f t +        Greater f t     -> tryPair sat $ varOf t f+        AllSmaller f d  -> trySingle sat False f d varMap+        AllGreater f d  -> trySingle sat True f d varMap+        MinVisits -> do mapM_ (minPaths sat varMap scheduler interfaces) $ +                          sortNfilter weigh nts+                        return True+    return ()+ where weigh (Nt _ _ _ is ss _) = size+        where size = length is + length ss+       varOf f t = case M.lookup (f,t) varMap of+                    Just v  -> v+                    Nothing -> case M.lookup (t,f) varMap of+                                Just v  -> varnot v+                                Nothing -> error "invalid optimisation.."++sortNfilter :: (a -> Int) -> [a] -> [a]+sortNfilter f = +    map fst . sortBy (on compare snd) . +                  filter (((/=) 0) . snd) . map (id &&& f)++minPaths :: Sat -> VarMap -> SchedulerNt -> InterfaceRes -> Nt -> IO Bool +minPaths sat varMap scheduler interfaces tp@(Nt nt _ _ is ss _) = do+    forM_ neckCs $ attemptGroup sat (scheduler tp) mym . map varnot+    return True + where  neckCs= map (\(_,es,b) -> map (uncurry (mvar b)) es) $ +                    bottlenecks mx mym+        mvar b f t | b       = varMap M.! (f,t)+                   | not b   = varnot $ varMap M.! (t,f)+        mym   = interfaces M.! nt+        mx    | IM.null mym = 0+              | otherwise   = fst $ IM.findMax mym++bottlenecks :: Int -> IM.IntMap [Vertex] -> +                [(((Int,[Vertex]),(Int,[Vertex])),[Edge],Bool)]+bottlenecks x shd = +    sortNfilter cost $ pairs x+ where  pairs x | x <= 1 = []+                | x >  1 = let pair = ((x,maybe [] id $ IM.lookup x shd)+                                      ,(x-1,maybe [] id$IM.lookup (x-1) shd))+                           in (pair,edges pair,even x) : pairs (x-1)+        cost (((p1,p1s),(p2,p2s)),es,_) = size +         where size = length es +        edges ((p1,p1s),(p2,p2s)) = [ (f,t) | f <- p1s, t <- p2s ] ++-- | get all combinations of partitions from different `directions'+--      ordered by distance (shortest paths first)+edgeCombs :: Int -> IM.IntMap [Vertex] -> [(Int,Int)]+edgeCombs x shd = +    sortBy (on compare cost) $+        concat $+        takeWhile (not . null) $+        map (\(n,es) -> filter ((>0) . snd) +            (map (\(f,t) -> (f+n,t+n)) es)) $+        zip [-0,-1..] $+        repeat (map ((,) x) [x-1,x-3..1])+ where cost (x1,x2) = length $ findK (x1 -1)+        where findK n | n < x2  = []+                      | n >= x2 = (shd IM.! n) ++ findK (n-2)++tryPair :: Sat -> MyVar -> IO Bool +tryPair sat p = do+    b  <- satsolve sat [p]+    if b then addClause sat [p]+         else return False++attemptGroup :: Sat -> Scheduler -> IM.IntMap [Vertex] -> [MyVar] -> +                        IO (IM.IntMap [Vertex])+attemptGroup sat scheduler interfaces = +    tryGroup sat scheduler interfaces . filter notSet + where  notSet (Var _)      = True+        notSet (VarNot v)   = notSet v+        notSet _            = False++tryGroup :: Sat -> Scheduler -> IM.IntMap [Vertex] -> [MyVar] -> +                IO (IM.IntMap [Vertex])+tryGroup _ _ interfaces []           = return interfaces+tryGroup sat scheduler interfaces ps = do+    xs  <- mapM (const (newLit sat)) ps+    mapM (\(a,r) -> addClause sat [varnot a, r]) $ zip xs ps+    b  <- satsolve sat xs+    let success = assertVars sat xs+        fail    = assertVars sat (map varnot (xs++ps)) >> satsolve sat []+    if b then do    (improved, sched) <- scheduler interfaces+                    if improved +                        then success >> return sched+                        else fail    >> return interfaces +         else fail >> return interfaces++assertVars :: Sat -> [MyVar] -> IO ()+assertVars sat vars = do    bs <- mapM (addClause sat . (:[])) vars+                            return ()+ +trySingle :: Sat -> Bool -> Vertex -> Direction -> VarMap -> IO Bool+trySingle sat des f dir varMap = do+        vars <- tryExtreme sat des literals+        assertVars sat vars+        return True+ where  literals = M.foldrWithKey select [] varMap+        select k a b | fst k == f = a : b --inh+                     | snd k == f = varnot a : b --syn+                     | otherwise  = b++tryExtreme :: Sat -> Bool -> [MyVar] -> IO [MyVar]+tryExtreme sat des xs =+  do a <- newLit sat+     switch <- newLit sat+     let try xs =+           do --putStrLn ("currently, " ++ show (length xs) ++ " literals")+              let assertOne | des       = map varnot (a : xs)+                            | otherwise = varnot a : xs+              addClause sat assertOne --"if a, then one of xs must be ~des"+              b <- satsolve sat [a]+              if b then+                do xbs <- sequence [ do v <- value sat x+                                        return (x,v)+                                   | x <- xs+                                   ]+                   sequence_ [ do let desx | des        = x+                                           | otherwise  = varnot x+                                  addClause sat [varnot a, desx] +                                  addClause sat [varnot switch, desx]+                             | (x,b) <- xbs, b /= Just des ]+                   try [ x | (x,Just des) <- xbs ]+               else do  addClause sat [varnot a]+                        return [switch]+      in try xs++-- | Recalculate interface based on SAT and compare with a given one+newSchedule :: Sat -> VarMap -> (Int,Int) -> Nt -> IM.IntMap [Vertex] ->+                IO (Bool, IM.IntMap [Vertex])+newSchedule sat varMap nbounds tp@(Nt nt _ _ inhs outs _ ) sched = do+    idsf <- newArray nbounds IS.empty :: IO (IOArray Vertex Vertices)+    idst <- newArray nbounds IS.empty :: IO (IOArray Vertex Vertices)+    let ids = (idsf,idst)+    sequence_ [ do  v <- value sat pred+                    case v of+                      Nothing -> error "no val"+                      Just True -> addEdges (i,s) ids +                      Just False-> addEdges (s,i) ids+            | (i,ios,_) <- inhs+            , (s,sos,_) <- outs+            , let pred = varMap M.! (i,s)+            ]+    f_idsf <- freeze idsf+    f_idst <- freeze idst+    let (_,newinterface) = runST $ do   schedA <- newArray nbounds Nothing+                                        completingN (f_idsf,f_idst) schedA tp+        newmx | IM.null newinterface = 0+              | otherwise            = fst $ IM.findMax newinterface+        oldmx | IM.null sched        = 0+              | otherwise            = fst $ IM.findMax sched +        newsched | newmx < oldmx = newinterface+                 | otherwise     = sched+    return $ (newmx < oldmx, newsched)+ where  addEdges+          :: (Vertex, Vertex)+          -> (IOArray Vertex Vertices, IOArray Vertex Vertices)+          -> IO ()+        addEdges (f,t) (idsf,idst) = do+            modifyArray idsf f (t `IS.insert`)+            modifyArray idst t (f `IS.insert`)+ +-- | count the (max, avg, total) number of visits+getVisCount :: [Nt] -> InterfaceRes -> VisCount+getVisCount nts interfaces = +    (mx, tot, (fromIntegral tot) / (fromIntegral $ length nts))+ where  count (mx,tot) (Nt nt _ _ _ _ _) = (max mx k,tot + k)+         where m = interfaces M.! nt+               k | IM.null m = 0+                 | otherwise = ((fst $ IM.findMax m) + 1) `div` 2+        (mx, tot) = foldl count (0,0) nts+--- minimisation functions+-------------------------------------------------------------------------------++globalMinimum :: Sat -> Bool -> [MyVar] -> IO [MyVar]+globalMinimum sat des xs =+  do ys <- sort sat xs+     let mini (i,j) | i >= j = return []+         mini (i,j) = do    putStrLn ("trying " ++ show (i,j))+                            b <- satsolve sat [varnot (ys !! k)]+                            if b then mini (k+1,j)+                                 else mini (i,k)+          where+           k = (i+j) `div` 2+      in mini (0,length ys)+     xbs <- sequence [ do v <- value sat x+                          return (x,v)+                     | x <- xs+                     ]+     return [ x | (x,Just True) <- xbs ]+ where+  sort sat []  = do return []+  sort sat [x] = do return [x]+  sort sat xs  = do as <- sort sat (take k xs)+                    bs <- sort sat (drop k xs)+                    map fromJust `fmap` merge (map Just as) (map Just bs)+   where+    k = length xs `div` 2++  merge2 Nothing b = return (b, Nothing)+  merge2 a Nothing = return (a, Nothing)+  merge2 (Just x) (Just y) =+    do a <- newLit sat+       b <- newLit sat+       addClause sat [varnot x, b]         -- x => b+       addClause sat [varnot y, b]         -- y => b+       addClause sat [varnot x, varnot y, a]  -- x => ~y || a+       addClause sat [x, varnot a]         -- ~x => ~a+       addClause sat [y, varnot a]         -- ~y => ~a+       addClause sat [x, y, varnot b]      -- ~x => y || ~b+       return (Just a,Just b)+  +  merge []  bs  = return bs+  merge as  []  = return as+  merge [a] [b] = (\(a,b) -> [a,b]) `fmap` merge2 a b+  merge as  bs  = take (a+b) `fmap` merge' (as ++ xas) (bs ++ xbs)+   where+    a   = length as+    b   = length bs+    m   = a `max` b+    n   = if even m then m else m+1+    xas = replicate (n-a) Nothing+    xbs = replicate (n-b) Nothing+  +  -- pre: as and bs have the same, even length+  merge' as bs =+    do xs <- merge eas ebs+       ys <- merge oas obs+       let x:xys = weave xs ys+       xys' <- sequence [ merge2 a b | (a,b) <- pairs xys ]+       return (x : unpairs xys' ++ [last xys])+   where+    (eas,oas) = evenOdds as+    (ebs,obs) = evenOdds bs++  evenOdds []       = ([], [])+  evenOdds [x]      = ([x], [])+  evenOdds (x:y:xs) = (x:es,y:os)+   where+    (es,os) = evenOdds xs++  pairs (x:y:xs) = (x,y) : pairs xs+  pairs _        = []+  +  unpairs ((x,y):xys) = x : y : unpairs xys+  unpairs []          = []+  +  weave (x:xs) (y:ys) = x : y : weave xs ys+  weave xs     ys     = xs ++ ys++------------------------------------------------------------------------------
src/LOAG/Solver/MiniSat.hs view
@@ -1,94 +1,94 @@-
-module LOAG.Solver.MiniSat ( 
-    newSolvable,-- IO SatContainer 
-    newLit,     -- Sat -> IO MyVar
-    satValues,  -- Sat -> IO (Int, Int)
-    addClause,  -- Sat -> [MyVar] -> IO ()
-    satsolve,   -- Sat -> IO Bool
-    value,      -- Sat -> IO (Maybe Bool)
-    fixed,       -- Sat -> IO Bool
-    MyVar(..),
-    Sat,
-    varnot,
-    VarMap,
-    Mini.conflict
-    ) where
-
-import LOAG.Graphs
-import Control.Monad
-import Data.Maybe
-import qualified Data.Map as M
-import qualified MiniSat as Mini
-
-type Sat = Mini.Solver
-type VarMap = M.Map Edge MyVar
-
-data MyVar = Var Mini.Lit 
-           | VarTrue
-           | VarFalse
-           | VarNot MyVar
-    deriving (Show, Eq)
-
-varnot :: MyVar -> MyVar
-varnot v@(Var i) = Var (Mini.neg i)
-varnot (VarNot v)= v
-varnot VarFalse  = VarTrue
-varnot VarTrue   = VarFalse
-
-
-newSolvable :: IO Mini.Solver
-newSolvable = do    sat <-  Mini.newSolver
-                    Mini.eliminate sat True
-                    return sat
-
-newLit      :: Sat -> IO MyVar
-newLit sat =
- do p <- Mini.newLit sat
-    return (Var (Mini.neg p))
-
-satValues   :: Sat -> IO (Int,Int)
-satValues sat = 
-    do  v <- Mini.minisat_num_vars sat
-        p <- Mini.minisat_num_clauses sat
-        return (v,p)
-
-addClause   :: Sat -> [MyVar] -> IO Bool
-addClause sat [] = return True 
-addClause sat es = do
-    if satisfied
-      then return True
-      else case fes of
-             []  -> error "unsatisfiable"
-             fes -> Mini.addClause sat $ map toMini fes
- where  
-        satisfied = any (True ==?) es
-        fes       = filter (not . (False ==?)) es
-        b ==? v = case v of 
-                    VarTrue  -> b
-                    VarFalse -> not b
-                    _       -> False
-        toMini :: MyVar -> Mini.Lit
-        toMini (Var v)    = v
-        toMini (VarNot v) = Mini.neg (toMini v)
-        _                 = error "incorrect clause filtering"
-
-satsolve :: Sat -> [MyVar] -> IO Bool
-satsolve sat = Mini.solve sat . map extract
-
-extract :: MyVar -> Mini.Lit
-extract VarTrue     = error "cannot extract True"
-extract VarFalse    = error "cannot extract False"
-extract (VarNot v)  = Mini.neg (extract v)
-extract (Var l)     = l
-
-value :: Sat -> MyVar -> IO (Maybe Bool)
-value _ VarTrue     = return $ Just True
-value _ VarFalse    = return $ Just False
-value sat (VarNot v)  = value sat v >>= return . fmap not
-value sat (Var v)     = Mini.modelValue sat v
-
-fixed :: Sat -> MyVar -> IO Bool
-fixed _ VarTrue     = return $ True
-fixed _ VarFalse    = return $ True 
-fixed sat (VarNot v)= fixed sat v
-fixed sat (Var l)   = Mini.value sat l >>= return . isJust
++module LOAG.Solver.MiniSat ( +    newSolvable,-- IO SatContainer +    newLit,     -- Sat -> IO MyVar+    satValues,  -- Sat -> IO (Int, Int)+    addClause,  -- Sat -> [MyVar] -> IO ()+    satsolve,   -- Sat -> IO Bool+    value,      -- Sat -> IO (Maybe Bool)+    fixed,       -- Sat -> IO Bool+    MyVar(..),+    Sat,+    varnot,+    VarMap,+    Mini.conflict+    ) where++import LOAG.Graphs+import Control.Monad+import Data.Maybe+import qualified Data.Map as M+import qualified MiniSat as Mini++type Sat = Mini.Solver+type VarMap = M.Map Edge MyVar++data MyVar = Var Mini.Lit +           | VarTrue+           | VarFalse+           | VarNot MyVar+    deriving (Show, Eq)++varnot :: MyVar -> MyVar+varnot v@(Var i) = Var (Mini.neg i)+varnot (VarNot v)= v+varnot VarFalse  = VarTrue+varnot VarTrue   = VarFalse+++newSolvable :: IO Mini.Solver+newSolvable = do    sat <-  Mini.newSolver+                    Mini.eliminate sat True+                    return sat++newLit      :: Sat -> IO MyVar+newLit sat =+ do p <- Mini.newLit sat+    return (Var (Mini.neg p))++satValues   :: Sat -> IO (Int,Int)+satValues sat = +    do  v <- Mini.minisat_num_vars sat+        p <- Mini.minisat_num_clauses sat+        return (v,p)++addClause   :: Sat -> [MyVar] -> IO Bool+addClause sat [] = return True +addClause sat es = do+    if satisfied+      then return True+      else case fes of+             []  -> error "unsatisfiable"+             fes -> Mini.addClause sat $ map toMini fes+ where  +        satisfied = any (True ==?) es+        fes       = filter (not . (False ==?)) es+        b ==? v = case v of +                    VarTrue  -> b+                    VarFalse -> not b+                    _       -> False+        toMini :: MyVar -> Mini.Lit+        toMini (Var v)    = v+        toMini (VarNot v) = Mini.neg (toMini v)+        _                 = error "incorrect clause filtering"++satsolve :: Sat -> [MyVar] -> IO Bool+satsolve sat = Mini.solve sat . map extract++extract :: MyVar -> Mini.Lit+extract VarTrue     = error "cannot extract True"+extract VarFalse    = error "cannot extract False"+extract (VarNot v)  = Mini.neg (extract v)+extract (Var l)     = l++value :: Sat -> MyVar -> IO (Maybe Bool)+value _ VarTrue     = return $ Just True+value _ VarFalse    = return $ Just False+value sat (VarNot v)  = value sat v >>= return . fmap not+value sat (Var v)     = Mini.modelValue sat v++fixed :: Sat -> MyVar -> IO Bool+fixed _ VarTrue     = return $ True+fixed _ VarFalse    = return $ True +fixed sat (VarNot v)= fixed sat v+fixed sat (Var l)   = Mini.value sat l >>= return . isJust
+ src/MirageSyntax.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE DeriveGeneric #-}++module MirageSyntax where++import Data.Aeson (ToJSON)+import GHC.Generics (Generic)++data Grammar = Grammar [Nonterminal] deriving Generic++instance ToJSON Grammar++data Nonterminal = Nonterminal+  String       -- ^ The name of this nonterminal.+  [String]     -- ^ The names of the parameters.+  [Attribute]  -- ^ The inherited attributes.+  [Attribute]  -- ^ The synthesized attributes.+  [Production] -- ^ The production rules with this nonterminal on the left hand side.+  deriving Generic++instance ToJSON Nonterminal++data Attribute = Attribute+  String -- ^ The name of this attribute.+  Type   -- ^ The type of this attribute.+  deriving Generic++instance ToJSON Attribute++data Production = Production+  String  -- ^ The name of this production rule.+  [Child] -- ^ The children of this rule; the right hand side.+  [Rule]  -- ^ The attribute rules of this production.+  deriving Generic++instance ToJSON Production++data Child = Child+  String -- ^ The name of this child.+  Type   -- ^ The type of this child.+  deriving Generic++instance ToJSON Child++data Rule = Rule+  [Address] -- ^ Targets of this rule; the left hand side.+  [Address] -- ^ Sources of this rule; the right hand side.+  Bool      -- ^ Whether this rule is defined explicitly by the user.+  String    -- ^ The origin of this rule; which source file contains this rule?+  String    -- ^ A pretty printed representation of this rule.+  deriving Generic++instance ToJSON Rule++data Type+  = Haskell String -- ^ A plain Haskell type.+  | NT             -- ^ An attribute grammar nonterminal+      String       -- ^ The name of the nonterminal+      [String]     -- ^ The arguments of this nonterminal; must always be plain Haskell values.+  | Self           -- ^ Refers to the nonterminal in which this type is used.+  deriving Generic++instance ToJSON Type++data Address = Address+  String -- ^ The part before the dot: 'lhs', 'loc', or the name of a child.+  String -- ^ The attribute name+  deriving Generic++instance ToJSON Address+
src/PPUtil.hs view
@@ -1,59 +1,59 @@-module PPUtil where
-
---
--- Some additional pretty-print functions
--- for pretty-printing abstract syntax trees.
---
-
-import Data.List
-import qualified Data.Map as Map
-import Pretty
-import Options
-
-ppListSep :: (PP s, PP c, PP o, PP a) => o -> c -> s -> [a] -> PP_Doc
-ppListSep o c s pps = o >|< hlist (intersperse (pp s) (map pp pps)) >|< c
-
-ppSpaced :: PP a => [a] -> PP_Doc
-ppSpaced = ppListSep "" "" " "
-
-ppCommas :: PP a => [a] -> PP_Doc
-ppCommas = ppListSep "" "" ", "
-
-ppVList :: PP a => [a] -> PP_Doc
-ppVList []     = "[" >#< "]"
-ppVList (x:xs) = vlist (("[" >#< pp x) : (map (\y -> "," >#< pp y) xs)) >#< "]"
-
-ppMap :: (Show a, Show b) => Map.Map a b -> PP_Doc
-ppMap m = ppVList [ ppF (show k) $ ppShow v | (k,v) <- Map.toList m ]
-
-ppAssocL :: (Show a, Show b) => [(a,b)] -> PP_Doc
-ppAssocL m = ppVList [ ppF (show k) $ ppShow v | (k,v) <- m ]
-
-ppF :: String -> PP_Doc -> PP_Doc
-ppF s x = s >|< ":" >#< x
-
-ppNest :: PP a => [a] -> [PP_Doc] -> [PP_Doc] -> PP_Doc
-ppNest nms attrs ps = ppNestInfo {- defaultEHCOpts -} nms attrs ps []
-
-ppNestInfo :: PP a => {- EHCOpts -> -} [a] -> [PP_Doc] -> [PP_Doc] -> [(String,PP_Doc)] -> PP_Doc
-ppNestInfo {- opts -} nms attrs ps infos
-  = ppListSep "" "" "_" nms
-    >#< (   (if null attrs then empty else ppSpaced attrs)
-        >-< (if False {- ehcOptDebug opts -} then vlist (map (\(i,p) -> pp i >|< ":" >#< p) infos) else empty)
-        )
-    >-< indent 2 (vlist ps)
-
-ppNm :: String -> PP_Doc
-ppNm = text . show
-
-ppShow :: Show x => x -> PP_Doc
-ppShow x = pp $ show x
-
-mkInfo1 :: String -> PP_Doc -> (String,PP_Doc)
-mkInfo1 = (,)
-
-ppLinePragma :: Options -> Int -> String -> PP_Doc
-ppLinePragma opts ln fl
-  | ocaml opts = "#" >#< show ln >#< show fl
-  | clean opts = "//" >#< show ln >#< show fl
-  | otherwise  = "{-# LINE" >#< show ln >#< show fl >#< "#-}"
+module PPUtil where++--+-- Some additional pretty-print functions+-- for pretty-printing abstract syntax trees.+--++import Data.List+import qualified Data.Map as Map+import Pretty+import Options++ppListSep :: (PP s, PP c, PP o, PP a) => o -> c -> s -> [a] -> PP_Doc+ppListSep o c s pps = o >|< hlist (intersperse (pp s) (map pp pps)) >|< c++ppSpaced :: PP a => [a] -> PP_Doc+ppSpaced = ppListSep "" "" " "++ppCommas :: PP a => [a] -> PP_Doc+ppCommas = ppListSep "" "" ", "++ppVList :: PP a => [a] -> PP_Doc+ppVList []     = "[" >#< "]"+ppVList (x:xs) = vlist (("[" >#< pp x) : (map (\y -> "," >#< pp y) xs)) >#< "]"++ppMap :: (Show a, Show b) => Map.Map a b -> PP_Doc+ppMap m = ppVList [ ppF (show k) $ ppShow v | (k,v) <- Map.toList m ]++ppAssocL :: (Show a, Show b) => [(a,b)] -> PP_Doc+ppAssocL m = ppVList [ ppF (show k) $ ppShow v | (k,v) <- m ]++ppF :: String -> PP_Doc -> PP_Doc+ppF s x = s >|< ":" >#< x++ppNest :: PP a => [a] -> [PP_Doc] -> [PP_Doc] -> PP_Doc+ppNest nms attrs ps = ppNestInfo {- defaultEHCOpts -} nms attrs ps []++ppNestInfo :: PP a => {- EHCOpts -> -} [a] -> [PP_Doc] -> [PP_Doc] -> [(String,PP_Doc)] -> PP_Doc+ppNestInfo {- opts -} nms attrs ps infos+  = ppListSep "" "" "_" nms+    >#< (   (if null attrs then empty else ppSpaced attrs)+        >-< (if False {- ehcOptDebug opts -} then vlist (map (\(i,p) -> pp i >|< ":" >#< p) infos) else empty)+        )+    >-< indent 2 (vlist ps)++ppNm :: String -> PP_Doc+ppNm = text . show++ppShow :: Show x => x -> PP_Doc+ppShow x = pp $ show x++mkInfo1 :: String -> PP_Doc -> (String,PP_Doc)+mkInfo1 = (,)++ppLinePragma :: Options -> Int -> String -> PP_Doc+ppLinePragma opts ln fl+  | ocaml opts = "#" >#< show ln >#< show fl+  | clean opts = "//" >#< show ln >#< show fl+  | otherwise  = "{-# LINE" >#< show ln >#< show fl >#< "#-}"
src/Parser.hs view
@@ -1,613 +1,613 @@-module Parser
-where
-import Data.Maybe
-import UU.Parsing
-import UU.Parsing.Machine(RealParser(..),RealRecogn(..),anaDynE,mkPR)
-import ConcreteSyntax
-import CommonTypes
-import Patterns
-import UU.Pretty(text,PP_Doc,empty,(>-<))
-import TokenDef
-import Data.List (intersperse)
-import Data.Char
-import Scanner (Input(..),scanLit,input)
-import System.FilePath
-import Data.List
-import Expression
-import Macro --marcos
-import UU.Scanner.Token
-import UU.Scanner.TokenParser
-import UU.Scanner.GenToken
-import UU.Scanner.GenTokenOrd
-import UU.Scanner.GenTokenParser
-import UU.Scanner.Position
-import UU.Scanner.TokenShow()
-import System.Directory
-import System.FilePath
-import HsTokenScanner
-import Options
-import Scanner(lowercaseKeywords)
-
-
-type AGParser = AnaParser Input  Pair Token Pos
-
-pIdentifier, pIdentifierU, pIdentifierExcl :: AGParser Identifier
-pIdentifierU = uncurry Ident <$> pConidPos
-
--- Jeroen (3-10-2012): for some reason using pKeywordAsIdent
--- drastically slows down parsing of some of my AG files, as
--- in: I thought there was some infinite loop in there, but I
--- guess that eventually it could have given an answer. So
--- probably this does generate a lot of ambiguity.
-pIdentifier = pIdentifierExcl -- <|> pKeywordAsIdent
-pIdentifierExcl = uncurry Ident <$> pVaridPos
-
--- see Scanner.lowercaseKeywords for the list of keywords that may
--- be used as an identifier. To prevent ambiguities, it's probably
--- sufficient when the keyword is always followed by a token that
--- can never follow an identifier for any possible prefix.
-pKeywordAsIdent :: AGParser Identifier
-pKeywordAsIdent = pAny (\nm -> Ident nm <$> pKeyPos nm) lowercaseKeywords
-
-parseAG :: Options -> [FilePath] -> String -> IO (AG,[Message Token Pos])
-parseAG opts searchPath file = do
-  (es,_,_,_,mesg) <- parseFile False opts searchPath file
-  return (AG es, mesg)
-
---marcos
-parseAGI :: Options -> [FilePath] -> String -> IO (AG, Maybe String)
-parseAGI opts searchPath file
-              = do (es,_,_,ext,_) <- parseFile True opts searchPath file
-                   return (AG es, ext)
-
-
-depsAG :: Options -> [FilePath] -> String -> IO ([String], [Message Token Pos])
-depsAG opts searchPath file
-  = do let fn = normalise file
-       (_,_,fs,_,mesgs) <- parseFile False opts searchPath fn
-       return (filter (/= fn) fs, mesgs)
-
--- marcos: added the parameter 'agi' and the 'ext' part
-parseFile :: Bool -> Options -> [FilePath] -> String -> IO  ([Elem],[String],[String], Maybe String,[Message Token Pos ])
-parseFile = parseFile' []
-
-parseFile' :: [String] -> Bool -> Options -> [FilePath] -> String -> IO  ([Elem],[String],[String], Maybe String,[Message Token Pos ])
-parseFile' parsedfiles agi opts searchPath filename
- = do file <- normalise `fmap` resolveFile opts searchPath filename
-      if file `elem` parsedfiles 
-        then return ([], [], parsedfiles, Nothing, [])
-        else do
-        txt <- readFile file
-        let searchPath' = takeDirectory file : searchPath  -- search first relative to the including file
-            litMode = ".lag" `isSuffixOf` file
-            (files,text) = if litMode then scanLit txt
-                           else ([],txt)
-            tokens       = input opts (initPos file) text
-
-            steps = parse (pElemsFiles agi) tokens
-            stop (_,fs,_,_,_) = null fs
-            cont (es,f:fs,allfs,ext,msg)
-              = do (ess,fss,allfss,_, msgs) <- parseFile' allfs agi opts searchPath' f
-                   return (ess ++ es, fss ++ fs, allfss, ext, msg ++ msgs)
-        let (Pair (es,fls,ext) _ ,mesg) = evalStepsMessages steps
-        loopp stop cont (es,files ++ fls,file : parsedfiles, ext,mesg)
- where
-
-    --
-    -- Option dependent AG Parsers inlined here
-    -- to have access to the opts
-    -- while retaining sharing
-    --
-
-    pElemsFiles :: Bool -> AGParser ([Elem],[String],Maybe String)
-    pElemsFiles agi = pFoldr (($),([],[],Nothing)) pElem'
-       where pElem' =  addElem <$> pElem
-                   <|> pINCLUDE *> (addInc <$> pStringPos)
-                   <|> pEXTENDS *> (addExt <$> pStringPos)
-             addElem e      (es,fs,ext) = (e:es,   fs, ext)
-             addInc  (fn,_) (es,fs,ext) 
-               | noIncludes opts = (es, fs, ext)  -- skip includes
-               | otherwise       = (es,normalise fn:fs, ext)
-             addExt  (fn,_) (es,fs,ext)
-               | noIncludes opts = (es, fs, ext)  -- skip includes
-               | otherwise       = if agi then (es,fs, Just fn') else (es,fn':fs, ext) --marcos
-               where fn' = normalise fn
-
-    pCodescrapL = (\(ValToken _ str pos) -> (str, pos))<$>
-                        parseScrapL <?> "a code block"
-
-    parseScrapL :: AGParser Token
-    parseScrapL
-               = let p acc =  (\k (Input pos str next) ->
-                               let (sc,rest) = case next of
-                                     Just (t@(ValToken TkTextln _ _), rs) -> (t,rs)
-                                     _ -> let (tok,p2,inp2) = codescrapL pos str
-                                          in (tok, input opts p2 inp2)
-                                   steps   = k ( rest)
-                               in  (val (acc sc)  steps)
-                          )
-                 in anaDynE  (mkPR (P (p  ), R (p (const id))))
-
-    pElems :: AGParser Elems
-    pElems = pList_ng pElem
-
-    pComplexType =  List   <$> pBracks pTypeEncapsulated
-               <|> Maybe  <$ pMAYBE <*> pType
-               <|> Either <$ pEITHER <*> pType <*> pType
-               <|> Map    <$ pMAP <*> pTypePrimitive <*> pType
-               <|> IntMap <$ pINTMAP <*> pType
-               <|> OrdSet <$ pSET <*> pType
-               <|> IntSet <$ pINTSET
-               <|> tuple  <$> pParens (pListSep pComma field)
-      where field = (,) <$> ((Just <$> pIdentifier <* pTypeColon) `opt` Nothing) <*> pTypeEncapsulated
-            tuple xs = Tuple [(fromMaybe (Ident ("x"++show n) noPos) f, t)
-                             | (n,(f,t)) <- zip [1..] xs
-                             ]
-
-    pOptClassContext' :: AGParser ClassContext
-    pOptClassContext'
-      | ocaml opts = pSucceed []
-      | otherwise  = pOptClassContext
-
-    pTyVars :: AGParser [Identifier]
-    pTyVars
-      | ocaml opts = return <$> pTypeVar
-                     <|> pSucceed []
-                     <|> pParens (pListSep pComma pTypeVar)
-      | otherwise  = pList pIdentifier
-
-    pElem :: AGParser Elem
-    pElem
-         =  (\(pos, ct) -> Data pos ct)
-                 <$> (    (\x -> (x, DataConstructor))   <$> (pDATA <|> pTYPE)
-                     <|>  (\x -> (x, RecordConstructor)) <$> pRECORD
-                     )
-                 <*> pOptClassContext'
-                 <*> pNontSet
-                 <*> pTyVars
-                 <*> pOptAttrs
-                 <*> pAlts
-                 <*> pSucceed False
-        <|> Attr <$> pATTR
-                 <*> pOptClassContext'
-                 <*> pNontSet
-                 <*> pOptQuantifiers
-                 <*> pAttrs
-        <|> Type <$> pTYPE
-                 <*> pOptClassContext'
-                 <*> pTypeCon
-                 <*> pTyVars
-                 <*  pEquals
-                 <*> pComplexType
-        <|> Sem  <$> pSEM
-                 <*> pOptClassContext'
-                 <*> pNontSet
-                 <*> pOptAttrs
-                 <*> pOptQuantifiers
-                 <*> pSemAlts
-        <|> Set  <$> pSET
-                 <*> pTypeCon
-                 <*> (   False <$ pEquals
-                     <|> True  <$ pColon
-                     )
-                 <*> pNontSet
-        <|> Deriving
-                 <$> pDERIVING
-                 <*> pNontSet
-                 <*  pColon
-                 <*> pListSep pComma pIdentifierU
-        <|> Wrapper
-                 <$> pWRAPPER
-                 <*> pNontSet
-        <|> Nocatas
-                 <$> pNOCATAS
-                 <*> pNontSet
-        <|> Pragma
-                 <$> pPRAGMA
-                 <*> pList1 pIdentifier
-        <|> Module
-                 <$> pMODULE
-                 <*> pCodescrap'
-                 <*> pCodescrap'
-                 <*> pCodescrap'
-        <|> codeBlock <$> pBlockKind <*> ((Just <$ pATTACH <*> pTypeCon) <|> pSucceed Nothing) <*> pCodeBlock <?> "a statement"
-              where codeBlock knd mbNt (txt,pos) = Txt pos knd mbNt (lines txt)                 
-
-    pBlockKind :: AGParser BlockKind
-    pBlockKind =
-          BlockPragma <$ pOPTPRAGMAS
-      <|> BlockImport <$ pIMPORTS
-      <|> BlockMain   <$ pTOPLEVEL   -- block is moved to the toplevel ("main") module when "sepsemmods" is used
-      <|> BlockData   <$ pDATABLOCK
-      <|> BlockRec    <$ pRECBLOCK
-      <|> pSucceed BlockOther
-
-    pAttrs :: AGParser Attrs
-    pAttrs
-        = Attrs <$> pOBrackPos <*> (concat <$> pList pInhAttrNames <?> "inherited attribute declarations")
-                                  <* pBar    <*> (concat <$> pList pAttrNames <?> "chained attribute declarations"  )
-                                  <* pBar    <*> (concat <$> pList pAttrNames <?> "synthesised attribute declarations"  )
-                   <*  pCBrack
-           <|> (\ds -> Attrs (fst $ head ds) [n | (_,(nms,_,_)) <- ds, n <- nms] [n | (_,(_,nms,_)) <- ds, n <- nms] [n | (_,(_,_,nms)) <- ds, n <- nms]) <$> pList1 pSingleAttrDefs
-
-    pSingleAttrDefs :: AGParser (Pos, (AttrNames, AttrNames, AttrNames))
-    pSingleAttrDefs
-      =    (\p is -> (p, (is,[],[]))) <$> pINH <*> pList1Sep pComma pSingleInhAttrDef
-      <|>  (\p is -> (p, ([],[],is))) <$> pSYN <*> pList1Sep pComma pSingleSynAttrDef
-      <|>  (\p is -> (p, ([],is,[]))) <$> pCHN <*> pList1Sep pComma pSingleChnAttrDef
-
-    pSingleInhAttrDef :: AGParser (Identifier,Type,(String,String,String))
-    pSingleInhAttrDef
-      = (\v tp -> (v,tp,("","",""))) <$> pAttrIdentifier <* pTypeColon <*> pTypeOrSelf <?> "inh attribute declaration"
-
-    pSingleSynAttrDef :: AGParser (Identifier,Type,(String,String,String))
-    pSingleSynAttrDef
-      = (\v u tp -> (v,tp,u)) <$> pAttrIdentifier <*> pUse <* pTypeColon <*> pTypeOrSelf <?> "syn attribute declaration"
-
-    pSingleChnAttrDef :: AGParser (Identifier,Type,(String,String,String))
-    pSingleChnAttrDef
-      = (\v tp -> (v,tp,("","",""))) <$> pAttrIdentifier <* pTypeColon <*> pTypeOrSelf <?> "chn attribute declaration"
-
-    pOptAttrs :: AGParser Attrs
-    pOptAttrs = pAttrs `opt` Attrs noPos [] [] []
-
-    pInhAttrNames :: AGParser AttrNames
-    pInhAttrNames
-                   = (\vs tp -> map (\v -> (v,tp,("","",""))) vs)
-                      <$> pAttrIdentifiers <*  pTypeColon <*> pTypeOrSelf <?> "attribute declarations"
-
-    pAttrNames :: AGParser AttrNames
-    pAttrNames
-             = (\vs use tp -> map (\v -> (v,tp,use)) vs)
-                 <$> pAttrIdentifiers <*> pUse <* pTypeColon <*> pTypeOrSelf <?> "attribute declarations"
-
-    pAlt :: AGParser Alt
-    pAlt =   (Alt <$> pBar <*> pSimpleConstructorSet <*> (pList1_ng pTypeVar <* pDot <|> pSucceed []) <*> pFields <*> pMaybeMacro <?> "a datatype alternative")
-
-    pAlts :: AGParser Alts
-    pAlts =  pList_ng pAlt <?> "datatype alternatives"
-
-    pFields :: AGParser Fields
-    pFields = concat <$> pList_ng pField <?> "fields"
-
-    pField :: AGParser Fields
-    pField
-           =   (\nms tp -> map (\nm -> FChild nm tp) nms) <$> pAttrIdentifiers <* pTypeColon <*> pType
-           <|> (\s   -> [FChild (Ident (mklower $ getName s) (getPos s)) (NT s [] False)]) <$> pIdentifierU
-           <|> (\t   -> [FCtx [t]]) <$ pSmallerEqual <*> pTypePrimitive
-    
-    pSemAlt :: AGParser SemAlt
-    pSemAlt = SemAlt <$> pBar <*> pConstructorSet <*> pSemDefs <?> "SEM alternative"
-
-    pSemAlts :: AGParser SemAlts
-    pSemAlts =  pList pSemAlt <?> "SEM alternatives"
-
-    pSemDef :: AGParser [SemDef]
-    pSemDef
-          =   (\x y fs -> map (\f -> f x y) fs) <$> pMaybeRuleName <*> pFieldIdentifier <*> pList1 pAttrDef
-          <|>                            pLOC              *> pList1 pLocDecl
-          <|>                            pINST             *> pList1 pInstDecl
-          <|>  pSEMPRAGMA *> pList1 (SemPragma <$> pNames)
-          <|> (\n e -> [AugmentDef n e]) <$ pAugmentToken <*> pAttrIdentifier <* pAssign <*> pExpr
-          <|> (\n e -> [AroundDef n e]) <$ pAROUND <*> pAttrIdentifier <* pAssign <*> pExpr
-          <|> (\a b -> [AttrOrderBefore a [b]]) <$> pList1 pAttrOrIdent <* pSmaller <*> pAttrOrIdent
-          <|> (\sources target nt expr -> [MergeDef target nt sources expr]) <$ pMERGE <*> (pList1_ng pIdentifier <* pAS <|> pSucceed []) <*> pIdentifier <* pTypeColon <*> pIdentifierU <* pAssign <*> pExpr
-          <|> (\mbNm pat (owrt,pos,pur,eager) exp -> [Def pos mbNm (pat ()) exp owrt pur eager]) <$> pMaybeRuleName <*> pPattern (const <$> pAttr) <*> pRuleSym <*> pExpr
-
-    pMaybeRuleName :: AGParser (Maybe Identifier)
-    pMaybeRuleName
-      =   (Just <$> pIdentifier <* pColon <?> "rule name")
-      <|> pSucceed Nothing
-
-    pAttrDef :: AGParser (Maybe Identifier -> Identifier -> SemDef)
-    pAttrDef
-      = (\pat (owrt,pos,pur,eager) exp mbNm fld -> Def pos mbNm (pat fld) exp owrt pur eager)
-               <$ pDot <*> pattern <*> pRuleSym <*> pExpr
-      where pattern =  pPattern pVar
-                   <|> (\ir a fld -> ir $ Alias fld a (Underscore noPos)) <$> ((Irrefutable <$ pTilde) `opt` id) <*> pAttrIdentifier
-
-    pLocDecl :: AGParser SemDef
-    pLocDecl = pDot <**> (pIdentifier <**> (pTypeColon <**> (   (\(tp,pos) _ ident _  -> TypeDef pos ident tp) <$> pLocType
-                                                            <|> (\ref _ ident _ -> UniqueDef ident ref) <$ pUNIQUEREF <*> pIdentifier )))
-
-    pLocType :: AGParser (Type, Pos)
-    pLocType = (\u -> (Haskell $ getName u, getPos u)) <$> pTypeCon
-       <|> (\(s,p) -> (Haskell s,p)) <$> pCodescrap  <?> "a type"
-
-    pInstDecl :: AGParser SemDef
-    pInstDecl = (\ident tp -> TypeDef (getPos ident) ident tp)
-                  <$ pDot <*> pIdentifier <* pTypeColon <*> pTypeNt
-
-    pSemDefs :: AGParser SemDefs
-    pSemDefs =  concat <$> pList_ng pSemDef <?> "attribute rules"
-
-    pExpr :: AGParser Expression
-    pExpr = (\(str,pos) ->  Expression pos (lexTokens opts pos str)) <$> pCodescrapL <?> "an expression"
-
-    pTypeColon :: AGParser Pos
-    pTypeColon
-      = if doubleColons opts
-        then pDoubleColon
-        else pColon
-
-    --marcos
-    pMaybeMacro :: AGParser MaybeMacro
-    pMaybeMacro  =  Just <$ pDoubleArrow <*>  pMacro
-                <|> pSucceed Nothing
-
-    pMacro :: AGParser Macro
-    pMacro
-          =  Macro <$> pIdentifierU
-                   <*> pList1 pMacroChild
-                   <?> "macro"
-
-    pMacroChild :: AGParser MacroChild
-    pMacroChild
-          =  (pIdentifier <* pEquals) <**>
-             (flip RuleChild   <$> pMacro       <|>
-              flip ChildChild  <$> pIdentifier  <|>
-              flip ValueChild  <$> pCodescrap' )
-
-    pTypeNt :: AGParser Type
-    pTypeNt
-      =   ((\nt -> mkNtType nt []) <$> pTypeCon <?> "nonterminal name (no brackets)")
-      <|> (pParens (mkNtType <$> pTypeCon <*> pList pTypeHaskellAnyAsString) <?> "nonterminal name with parameters (using parenthesis)")
-
-    pTypeCon :: AGParser Identifier
-    pTypeCon
-      | ocaml opts = pIdentifierExcl
-      | otherwise  = pIdentifierU
-
-    pTypeVar :: AGParser Identifier
-    pTypeVar
-      | ocaml opts = (\(nm, pos) -> Ident nm pos) <$> pTextnmPos
-      | otherwise  = pIdentifier
-
-    pTypeHaskellAnyAsString :: AGParser String
-    pTypeHaskellAnyAsString
-      =   getName <$> pTypeVar
-      <|> getName <$> pTypeCon
-      <|> 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
-      <|> mkNtType <$> pTypeCon <*> pList pTypeHaskellAnyAsString
-      <|> (Haskell . getName) <$> pTypeVar
-      <|> pTypePrimitive
-
-    pTypePrimitive :: AGParser Type
-    pTypePrimitive
-      = Haskell <$> pCodescrap'  <?> "a type"
-
-    pType :: AGParser Type
-    pType =  pTypeNt
-          <|> pTypePrimitive
-
-    pTypeOrSelf :: AGParser Type
-    pTypeOrSelf = pType <|> Self <$ pSELF
-
-    pOptClassContext :: AGParser ClassContext
-    pOptClassContext
-      =   pClassContext <* pDoubleArrow
-      <|> pSucceed []
-
-    pClassContext :: AGParser ClassContext
-    pClassContext
-      = pListSep pComma ((,) <$> pIdentifierU <*> pList pTypeHaskellAnyAsString)
-
-    pNontSet = set0 where
-        set0 = pChainr (Intersect <$ pIntersect) set1
-        set1 = pChainl (Difference <$ pMinus) set2
-        set2 = pChainr (pSucceed Union) set3
-        set3 = pTypeCon <**> opt (flip Path <$ pArrow <*> pTypeCon) NamedSet
-            <|> All <$ pStar
-            <|> pParens set0
-
-    --
-    -- End of AG Parser
-    --
-
-resolveFile :: Options -> [FilePath] -> FilePath -> IO FilePath
-resolveFile opts path fname = search (path ++ ["."])
- where search (p:ps) = do let filename = joinPath [p, fname]
-                          fExists <- doesFileExist filename
-                          if fExists
-                            then return filename
-                            else do let filename' = joinPath [p, replaceExtension fname "ag"]
-                                    fExists' <- doesFileExist filename'
-                                    if fExists'
-                                      then return filename'
-                                      else search ps
-       search []     = do
-         outputStr opts ("File: " ++ show fname ++ " not found in search path: " ++ show (concat (intersperse ";" (path ++ ["."]))) ++ "\n")
-         failWithCode opts 1
-         return (error "resolveFile: file not found")
-
-evalStepsMessages :: (Eq s, Show s, Show p) => Steps a s p -> (a,[Message s p])
-evalStepsMessages steps = case steps of
-  OkVal v        rest -> let (arg,ms) = evalStepsMessages rest
-                         in (v arg,ms)
-  Ok             rest -> evalStepsMessages rest
-  Cost  _        rest -> evalStepsMessages rest
-  StRepair _ msg rest -> let (v,ms) = evalStepsMessages rest
-                         in (v, msg:ms)
-  Best _   rest   _   -> evalStepsMessages rest
-  NoMoreSteps v       -> (v,[])
-
-loopp ::(a->Bool) -> (a->IO a) -> a ->  IO a
-loopp pred cont x | pred x = return x
-                  | otherwise = do x' <- cont x
-                                   loopp pred cont x'
-
-codescrapL p []                 = (valueToken TkTextln "" p,p,[])
-codescrapL p (x:xs) | isSpace x = (updPos'  x p)  codescrapL xs
-                    | otherwise = let refcol = column p
-                                      (p',sc,rest) = scrapL refcol p  (x:xs)
-                                  in (valueToken TkTextln sc p,p',rest)
-
-scrapL ref p (x:xs) | isSpace x || column p >= ref =
-                          let (p'',sc,inp) = updPos'  x p (scrapL ref)  xs
-                          in  (p'',x:sc,inp)
-                    | otherwise       =(p,[],x:xs)
-scrapL ref p []     = (p,[],[])
-
-pNames :: AGParser [Identifier]
-pNames = pIdentifiers
-
-
--- Insertion is expensive for pCodeBlock in order to prevent infinite inserts.
-pCodeBlock ::  AGParser (String,Pos)
-pCodeBlock   = pCostValToken 90 TkTextln "" <?> "a code block"
-
-pOptQuantifiers :: AGParser [String]
-pOptQuantifiers = (return <$ pDoubleColon <*> pCodescrap') `opt` []
-
-pIdentifiers :: AGParser [Identifier]
-pIdentifiers =  pList1Sep pComma pIdentifier <?> "lowercase identifiers"
-
-pAttrIdentifier :: AGParser Identifier
-pAttrIdentifier = pIdentifier
-                  <|> (\pos -> Ident "imports" pos) <$> pIMPORTS
-                  <|> (\pos -> Ident "toplevel" pos) <$> pTOPLEVEL
-
-pAttrIdentifiers :: AGParser [Identifier]
-pAttrIdentifiers = pList1Sep pComma pAttrIdentifier <?> "lowercase identifiers"
-
-pUse :: AGParser (String,String,String)
-pUse = (  (\u x y->(x,y,show u)) <$> pUSE <*> pCodescrap'  <*> pCodescrap') `opt` ("","","") <?> "USE declaration"
-
-mklower :: String -> String
-mklower (x:xs) = toLower x : xs
-mklower []     = []
-
-pSimpleConstructorSet :: AGParser ConstructorSet
-pSimpleConstructorSet =  CName <$> pIdentifierU
-                     <|> CAll  <$  pStar
-                     <|> pParens pConstructorSet
-
-pConstructorSet :: AGParser ConstructorSet
-pConstructorSet =  pChainl (CDifference <$ pMinus) term2
-  where term2 =  pChainr (pSucceed CUnion) term1
-        term1 =  CName <$> pIdentifierU
-             <|> CAll  <$  pStar
-
-pFieldIdentifier :: AGParser Identifier
-pFieldIdentifier =  pIdentifier
-                <|> Ident "lhs"  <$> pLHS
-                <|> Ident "loc"  <$> pLOC
-                <|> Ident "inst" <$> pINST
-
-pAugmentToken :: AGParser ()
-pAugmentToken = () <$ (pAUGMENT <|> pPlus)
-
-pAttr = (,) <$> pFieldIdentifier <* pDot <*> pAttrIdentifier
-
-pAttrOrIdent
-  = OccAttr <$> pFieldIdentifier <* pDot <*> pAttrIdentifier
-  <|> OccRule <$> pIdentifier
-
-nl2sp :: Char -> Char
-nl2sp '\n' = ' '
-nl2sp '\r' = ' '
-nl2sp x = x
-
-pVar :: AGParser (Identifier -> (Identifier, Identifier))
-pVar = (\att fld -> (fld,att)) <$> pAttrIdentifier
-
-pAssign :: AGParser Bool
-pAssign =  False <$ pReserved "="
-       <|> True  <$ pReserved ":="
-
-pRuleSym :: AGParser (Bool, Pos, Bool, Bool)
-pRuleSym  =     (\p -> (False, p, True, False)) <$> pReserved "="
-            <|> (\p -> (True,  p, True, False)) <$> pReserved ":="
-            <|> (\p -> (False, p, True, False)) <$> pReserved "<-"
-            <|> (\p -> (False, p, True, True))  <$> pReserved "<<-"
-
-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
-           <|> pPattern2
-  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"
-    where mkTuple _ [x] a = x a
-          mkTuple p xs  a = Product p (map ($ a) xs)
-
-pCostSym' c t = pCostSym c t t
-
-pCodescrap' ::  AGParser String
-pCodescrap' = fst <$> pCodescrap
-
-pCodescrap ::  AGParser (String,Pos)
-pCodescrap   = pCodeBlock
-
-pSEM, pATTR, pDATA, pRECORD, pUSE, pLOC,pINCLUDE, pTYPE, pEquals, pColonEquals, pTilde,
-      pEXTENDS, --marcos
-      pBar, pColon, pLHS,pINST,pSET,pDERIVING,pMinus,pIntersect,pDoubleArrow,pArrow,
-      pDot, pUScore, pEXT,pAt,pStar, pSmaller, pWRAPPER, pNOCATAS, pPRAGMA, pMAYBE, pEITHER, pMAP, pINTMAP,
-      pMODULE, pATTACH, pUNIQUEREF, pINH, pSYN, pAUGMENT, pPlus, pAROUND, pSEMPRAGMA, pMERGE, pAS, pSELF,
-      pIMPORTS, pOPTPRAGMAS, pSmallerEqual, pINTSET, pDATABLOCK, pRECBLOCK
-      :: AGParser Pos
-pSET         = pCostReserved 90 "SET"     <?> "SET"
-pDERIVING    = pCostReserved 90 "DERIVING"<?> "DERIVING"
-pWRAPPER     = pCostReserved 90 "WRAPPER" <?> "WRAPPER"
-pNOCATAS     = pCostReserved 90 "NOCATAS" <?> "NOCATAS"
-pPRAGMA      = pCostReserved 90 "PRAGMA"  <?> "PRAGMA"
-pSEMPRAGMA   = pCostReserved 90 "SEMPRAGMA" <?> "SEMPRAGMA"
-pATTACH      = pCostReserved 90 "ATTACH"  <?> "ATTACH"
-pDATA        = pCostReserved 90 "DATA"    <?> "DATA"
-pRECORD      = pCostReserved 90 "RECORD"  <?> "RECORD"
-pEXT         = pCostReserved 90 "EXT"     <?> "EXT"
-pATTR        = pCostReserved 90 "ATTR"    <?> "ATTR"
-pSEM         = pCostReserved 90 "SEM"     <?> "SEM"
-pINCLUDE     = pCostReserved 90 "INCLUDE" <?> "INCLUDE"
-pEXTENDS     = pCostReserved 90 "EXTENDS" <?> "EXTENDS" --marcos
-pTYPE        = pCostReserved 90 "TYPE"    <?> "TYPE"
-pINH         = pCostReserved 90 "INH"     <?> "INH"
-pSYN         = pCostReserved 90 "SYN"     <?> "SYN"
-pCHN         = pCostReserved 90 "CHN"     <?> "CHN"
-pMAYBE       = pCostReserved 5  "MAYBE"   <?> "MAYBE"
-pEITHER      = pCostReserved 5  "EITHER"  <?> "EITHER"
-pMAP         = pCostReserved 5  "MAP"     <?> "MAP"
-pINTMAP      = pCostReserved 5  "INTMAP"  <?> "INTMAP"
-pINTSET      = pCostReserved 5  "INTSET"  <?> "INTSET"
-pUSE         = pCostReserved 5  "USE"     <?> "USE"
-pLOC         = pCostReserved 5  "loc"     <?> "loc"
-pLHS         = pCostReserved 5  "lhs"     <?> "loc"
-pINST        = pCostReserved 5  "inst"    <?> "inst"
-pAt          = pCostReserved 5  "@"       <?> "@"
-pDot         = pCostReserved 5  "."       <?> "."
-pUScore      = pCostReserved 5  "_"       <?> "_"
-pColon       = pCostReserved 5  ":"       <?> ":"
-pDoubleColon = pCostReserved 5  "::"      <?> "::"
-pEquals      = pCostReserved 5  "="       <?> "="
-pColonEquals = pCostReserved 5  ":="      <?> ":="
-pTilde       = pCostReserved 5  "~"       <?> "~"
-pPlus        = pCostReserved 5  "+"       <?> "+"
-pBar         = pCostReserved 5  "|"       <?> "|"
-pIntersect   = pCostReserved 5  "/\\"     <?> "/\\"
-pMinus       = pCostReserved 5  "-"       <?> "-"
-pDoubleArrow = pCostReserved 5  "=>"      <?> "=>"
-pSmallerEqual= pCostReserved 5  "<="      <?> "<="
-pArrow       = pCostReserved 5  "->"      <?> "->"
-pStar        = pCostReserved 5  "*"       <?> "*"
-pSmaller     = pCostReserved 5  "<"       <?> "<"
-pMODULE      = pCostReserved 5  "MODULE"  <?> "MODULE"
-pUNIQUEREF   = pCostReserved 5  "UNIQUEREF" <?> "UNIQUEREF"
-pAUGMENT     = pCostReserved 5  "AUGMENT" <?> "AUGMENT"
-pAROUND      = pCostReserved 5  "AROUND" <?> "AROUND"
-pMERGE       = pCostReserved 5  "MERGE" <?> "MERGE"
-pAS          = pCostReserved 5  "AS" <?> "AS"
-pSELF        = pCostReserved 5  "SELF" <?> "SELF"
-pIMPORTS     = pCostReserved 5  "imports" <?> "imports"
-pOPTPRAGMAS  = pCostReserved 5  "optpragmas" <?> "optpragmas"
-pTOPLEVEL    = pCostReserved 5  "toplevel" <?> "toplevel"
-pDATABLOCK   = pCostReserved 5  "datablock" <?> "datadecl block"
-pRECBLOCK    = pCostReserved 5  "recblock" <?> "recursive block"
+module Parser+where+import Data.Maybe+import UU.Parsing+import UU.Parsing.Machine(RealParser(..),RealRecogn(..),anaDynE,mkPR)+import ConcreteSyntax+import CommonTypes+import Patterns+import UU.Pretty(text,PP_Doc,empty,(>-<))+import TokenDef+import Data.List (intersperse)+import Data.Char+import Scanner (Input(..),scanLit,input)+import System.FilePath+import Data.List+import Expression+import Macro --marcos+import UU.Scanner.Token+import UU.Scanner.TokenParser+import UU.Scanner.GenToken+import UU.Scanner.GenTokenOrd+import UU.Scanner.GenTokenParser+import UU.Scanner.Position+import UU.Scanner.TokenShow()+import System.Directory+import System.FilePath+import HsTokenScanner+import Options+import Scanner(lowercaseKeywords)+++type AGParser = AnaParser Input  Pair Token Pos++pIdentifier, pIdentifierU, pIdentifierExcl :: AGParser Identifier+pIdentifierU = uncurry Ident <$> pConidPos++-- Jeroen (3-10-2012): for some reason using pKeywordAsIdent+-- drastically slows down parsing of some of my AG files, as+-- in: I thought there was some infinite loop in there, but I+-- guess that eventually it could have given an answer. So+-- probably this does generate a lot of ambiguity.+pIdentifier = pIdentifierExcl -- <|> pKeywordAsIdent+pIdentifierExcl = uncurry Ident <$> pVaridPos++-- see Scanner.lowercaseKeywords for the list of keywords that may+-- be used as an identifier. To prevent ambiguities, it's probably+-- sufficient when the keyword is always followed by a token that+-- can never follow an identifier for any possible prefix.+pKeywordAsIdent :: AGParser Identifier+pKeywordAsIdent = pAny (\nm -> Ident nm <$> pKeyPos nm) lowercaseKeywords++parseAG :: Options -> [FilePath] -> String -> IO (AG,[Message Token Pos])+parseAG opts searchPath file = do+  (es,_,_,_,mesg) <- parseFile False opts searchPath file+  return (AG es, mesg)++--marcos+parseAGI :: Options -> [FilePath] -> String -> IO (AG, Maybe String)+parseAGI opts searchPath file+              = do (es,_,_,ext,_) <- parseFile True opts searchPath file+                   return (AG es, ext)+++depsAG :: Options -> [FilePath] -> String -> IO ([String], [Message Token Pos])+depsAG opts searchPath file+  = do let fn = normalise file+       (_,_,fs,_,mesgs) <- parseFile False opts searchPath fn+       return (filter (/= fn) fs, mesgs)++-- marcos: added the parameter 'agi' and the 'ext' part+parseFile :: Bool -> Options -> [FilePath] -> String -> IO  ([Elem],[String],[String], Maybe String,[Message Token Pos ])+parseFile = parseFile' []++parseFile' :: [String] -> Bool -> Options -> [FilePath] -> String -> IO  ([Elem],[String],[String], Maybe String,[Message Token Pos ])+parseFile' parsedfiles agi opts searchPath filename+ = do file <- normalise `fmap` resolveFile opts searchPath filename+      if file `elem` parsedfiles +        then return ([], [], parsedfiles, Nothing, [])+        else do+        txt <- readFile file+        let searchPath' = takeDirectory file : searchPath  -- search first relative to the including file+            litMode = ".lag" `isSuffixOf` file+            (files,text) = if litMode then scanLit txt+                           else ([],txt)+            tokens       = input opts (initPos file) text++            steps = parse (pElemsFiles agi) tokens+            stop (_,fs,_,_,_) = null fs+            cont (es,f:fs,allfs,ext,msg)+              = do (ess,fss,allfss,_, msgs) <- parseFile' allfs agi opts searchPath' f+                   return (ess ++ es, fss ++ fs, allfss, ext, msg ++ msgs)+        let (Pair (es,fls,ext) _ ,mesg) = evalStepsMessages steps+        loopp stop cont (es,files ++ fls,file : parsedfiles, ext,mesg)+ where++    --+    -- Option dependent AG Parsers inlined here+    -- to have access to the opts+    -- while retaining sharing+    --++    pElemsFiles :: Bool -> AGParser ([Elem],[String],Maybe String)+    pElemsFiles agi = pFoldr (($),([],[],Nothing)) pElem'+       where pElem' =  addElem <$> pElem+                   <|> pINCLUDE *> (addInc <$> pStringPos)+                   <|> pEXTENDS *> (addExt <$> pStringPos)+             addElem e      (es,fs,ext) = (e:es,   fs, ext)+             addInc  (fn,_) (es,fs,ext) +               | noIncludes opts = (es, fs, ext)  -- skip includes+               | otherwise       = (es,normalise fn:fs, ext)+             addExt  (fn,_) (es,fs,ext)+               | noIncludes opts = (es, fs, ext)  -- skip includes+               | otherwise       = if agi then (es,fs, Just fn') else (es,fn':fs, ext) --marcos+               where fn' = normalise fn++    pCodescrapL = (\(ValToken _ str pos) -> (str, pos))<$>+                        parseScrapL <?> "a code block"++    parseScrapL :: AGParser Token+    parseScrapL+               = let p acc =  (\k (Input pos str next) ->+                               let (sc,rest) = case next of+                                     Just (t@(ValToken TkTextln _ _), rs) -> (t,rs)+                                     _ -> let (tok,p2,inp2) = codescrapL pos str+                                          in (tok, input opts p2 inp2)+                                   steps   = k ( rest)+                               in  (val (acc sc)  steps)+                          )+                 in anaDynE  (mkPR (P (p  ), R (p (const id))))++    pElems :: AGParser Elems+    pElems = pList_ng pElem++    pComplexType =  List   <$> pBracks pTypeEncapsulated+               <|> Maybe  <$ pMAYBE <*> pType+               <|> Either <$ pEITHER <*> pType <*> pType+               <|> Map    <$ pMAP <*> pTypePrimitive <*> pType+               <|> IntMap <$ pINTMAP <*> pType+               <|> OrdSet <$ pSET <*> pType+               <|> IntSet <$ pINTSET+               <|> tuple  <$> pParens (pListSep pComma field)+      where field = (,) <$> ((Just <$> pIdentifier <* pTypeColon) `opt` Nothing) <*> pTypeEncapsulated+            tuple xs = Tuple [(fromMaybe (Ident ("x"++show n) noPos) f, t)+                             | (n,(f,t)) <- zip [1..] xs+                             ]++    pOptClassContext' :: AGParser ClassContext+    pOptClassContext'+      | ocaml opts = pSucceed []+      | otherwise  = pOptClassContext++    pTyVars :: AGParser [Identifier]+    pTyVars+      | ocaml opts = return <$> pTypeVar+                     <|> pSucceed []+                     <|> pParens (pListSep pComma pTypeVar)+      | otherwise  = pList pIdentifier++    pElem :: AGParser Elem+    pElem+         =  (\(pos, ct) -> Data pos ct)+                 <$> (    (\x -> (x, DataConstructor))   <$> (pDATA <|> pTYPE)+                     <|>  (\x -> (x, RecordConstructor)) <$> pRECORD+                     )+                 <*> pOptClassContext'+                 <*> pNontSet+                 <*> pTyVars+                 <*> pOptAttrs+                 <*> pAlts+                 <*> pSucceed False+        <|> Attr <$> pATTR+                 <*> pOptClassContext'+                 <*> pNontSet+                 <*> pOptQuantifiers+                 <*> pAttrs+        <|> Type <$> pTYPE+                 <*> pOptClassContext'+                 <*> pTypeCon+                 <*> pTyVars+                 <*  pEquals+                 <*> pComplexType+        <|> Sem  <$> pSEM+                 <*> pOptClassContext'+                 <*> pNontSet+                 <*> pOptAttrs+                 <*> pOptQuantifiers+                 <*> pSemAlts+        <|> Set  <$> pSET+                 <*> pTypeCon+                 <*> (   False <$ pEquals+                     <|> True  <$ pColon+                     )+                 <*> pNontSet+        <|> Deriving+                 <$> pDERIVING+                 <*> pNontSet+                 <*  pColon+                 <*> pListSep pComma pIdentifierU+        <|> Wrapper+                 <$> pWRAPPER+                 <*> pNontSet+        <|> Nocatas+                 <$> pNOCATAS+                 <*> pNontSet+        <|> Pragma+                 <$> pPRAGMA+                 <*> pList1 pIdentifier+        <|> Module+                 <$> pMODULE+                 <*> pCodescrap'+                 <*> pCodescrap'+                 <*> pCodescrap'+        <|> codeBlock <$> pBlockKind <*> ((Just <$ pATTACH <*> pTypeCon) <|> pSucceed Nothing) <*> pCodeBlock <?> "a statement"+              where codeBlock knd mbNt (txt,pos) = Txt pos knd mbNt (lines txt)                 ++    pBlockKind :: AGParser BlockKind+    pBlockKind =+          BlockPragma <$ pOPTPRAGMAS+      <|> BlockImport <$ pIMPORTS+      <|> BlockMain   <$ pTOPLEVEL   -- block is moved to the toplevel ("main") module when "sepsemmods" is used+      <|> BlockData   <$ pDATABLOCK+      <|> BlockRec    <$ pRECBLOCK+      <|> pSucceed BlockOther++    pAttrs :: AGParser Attrs+    pAttrs+        = Attrs <$> pOBrackPos <*> (concat <$> pList pInhAttrNames <?> "inherited attribute declarations")+                                  <* pBar    <*> (concat <$> pList pAttrNames <?> "chained attribute declarations"  )+                                  <* pBar    <*> (concat <$> pList pAttrNames <?> "synthesised attribute declarations"  )+                   <*  pCBrack+           <|> (\ds -> Attrs (fst $ head ds) [n | (_,(nms,_,_)) <- ds, n <- nms] [n | (_,(_,nms,_)) <- ds, n <- nms] [n | (_,(_,_,nms)) <- ds, n <- nms]) <$> pList1 pSingleAttrDefs++    pSingleAttrDefs :: AGParser (Pos, (AttrNames, AttrNames, AttrNames))+    pSingleAttrDefs+      =    (\p is -> (p, (is,[],[]))) <$> pINH <*> pList1Sep pComma pSingleInhAttrDef+      <|>  (\p is -> (p, ([],[],is))) <$> pSYN <*> pList1Sep pComma pSingleSynAttrDef+      <|>  (\p is -> (p, ([],is,[]))) <$> pCHN <*> pList1Sep pComma pSingleChnAttrDef++    pSingleInhAttrDef :: AGParser (Identifier,Type,(String,String,String))+    pSingleInhAttrDef+      = (\v tp -> (v,tp,("","",""))) <$> pAttrIdentifier <* pTypeColon <*> pTypeOrSelf <?> "inh attribute declaration"++    pSingleSynAttrDef :: AGParser (Identifier,Type,(String,String,String))+    pSingleSynAttrDef+      = (\v u tp -> (v,tp,u)) <$> pAttrIdentifier <*> pUse <* pTypeColon <*> pTypeOrSelf <?> "syn attribute declaration"++    pSingleChnAttrDef :: AGParser (Identifier,Type,(String,String,String))+    pSingleChnAttrDef+      = (\v tp -> (v,tp,("","",""))) <$> pAttrIdentifier <* pTypeColon <*> pTypeOrSelf <?> "chn attribute declaration"++    pOptAttrs :: AGParser Attrs+    pOptAttrs = pAttrs `opt` Attrs noPos [] [] []++    pInhAttrNames :: AGParser AttrNames+    pInhAttrNames+                   = (\vs tp -> map (\v -> (v,tp,("","",""))) vs)+                      <$> pAttrIdentifiers <*  pTypeColon <*> pTypeOrSelf <?> "attribute declarations"++    pAttrNames :: AGParser AttrNames+    pAttrNames+             = (\vs use tp -> map (\v -> (v,tp,use)) vs)+                 <$> pAttrIdentifiers <*> pUse <* pTypeColon <*> pTypeOrSelf <?> "attribute declarations"++    pAlt :: AGParser Alt+    pAlt =   (Alt <$> pBar <*> pSimpleConstructorSet <*> (pList1_ng pTypeVar <* pDot <|> pSucceed []) <*> pFields <*> pMaybeMacro <?> "a datatype alternative")++    pAlts :: AGParser Alts+    pAlts =  pList_ng pAlt <?> "datatype alternatives"++    pFields :: AGParser Fields+    pFields = concat <$> pList_ng pField <?> "fields"++    pField :: AGParser Fields+    pField+           =   (\nms tp -> map (\nm -> FChild nm tp) nms) <$> pAttrIdentifiers <* pTypeColon <*> pType+           <|> (\s   -> [FChild (Ident (mklower $ getName s) (getPos s)) (NT s [] False)]) <$> pIdentifierU+           <|> (\t   -> [FCtx [t]]) <$ pSmallerEqual <*> pTypePrimitive+    +    pSemAlt :: AGParser SemAlt+    pSemAlt = SemAlt <$> pBar <*> pConstructorSet <*> pSemDefs <?> "SEM alternative"++    pSemAlts :: AGParser SemAlts+    pSemAlts =  pList pSemAlt <?> "SEM alternatives"++    pSemDef :: AGParser [SemDef]+    pSemDef+          =   (\x y fs -> map (\f -> f x y) fs) <$> pMaybeRuleName <*> pFieldIdentifier <*> pList1 pAttrDef+          <|>                            pLOC              *> pList1 pLocDecl+          <|>                            pINST             *> pList1 pInstDecl+          <|>  pSEMPRAGMA *> pList1 (SemPragma <$> pNames)+          <|> (\n e -> [AugmentDef n e]) <$ pAugmentToken <*> pAttrIdentifier <* pAssign <*> pExpr+          <|> (\n e -> [AroundDef n e]) <$ pAROUND <*> pAttrIdentifier <* pAssign <*> pExpr+          <|> (\a b -> [AttrOrderBefore a [b]]) <$> pList1 pAttrOrIdent <* pSmaller <*> pAttrOrIdent+          <|> (\sources target nt expr -> [MergeDef target nt sources expr]) <$ pMERGE <*> (pList1_ng pIdentifier <* pAS <|> pSucceed []) <*> pIdentifier <* pTypeColon <*> pIdentifierU <* pAssign <*> pExpr+          <|> (\mbNm pat (owrt,pos,pur,eager) exp -> [Def pos mbNm (pat ()) exp owrt pur eager]) <$> pMaybeRuleName <*> pPattern (const <$> pAttr) <*> pRuleSym <*> pExpr++    pMaybeRuleName :: AGParser (Maybe Identifier)+    pMaybeRuleName+      =   (Just <$> pIdentifier <* pColon <?> "rule name")+      <|> pSucceed Nothing++    pAttrDef :: AGParser (Maybe Identifier -> Identifier -> SemDef)+    pAttrDef+      = (\pat (owrt,pos,pur,eager) exp mbNm fld -> Def pos mbNm (pat fld) exp owrt pur eager)+               <$ pDot <*> pattern <*> pRuleSym <*> pExpr+      where pattern =  pPattern pVar+                   <|> (\ir a fld -> ir $ Alias fld a (Underscore noPos)) <$> ((Irrefutable <$ pTilde) `opt` id) <*> pAttrIdentifier++    pLocDecl :: AGParser SemDef+    pLocDecl = pDot <**> (pIdentifier <**> (pTypeColon <**> (   (\(tp,pos) _ ident _  -> TypeDef pos ident tp) <$> pLocType+                                                            <|> (\ref _ ident _ -> UniqueDef ident ref) <$ pUNIQUEREF <*> pIdentifier )))++    pLocType :: AGParser (Type, Pos)+    pLocType = (\u -> (Haskell $ getName u, getPos u)) <$> pTypeCon+       <|> (\(s,p) -> (Haskell s,p)) <$> pCodescrap  <?> "a type"++    pInstDecl :: AGParser SemDef+    pInstDecl = (\ident tp -> TypeDef (getPos ident) ident tp)+                  <$ pDot <*> pIdentifier <* pTypeColon <*> pTypeNt++    pSemDefs :: AGParser SemDefs+    pSemDefs =  concat <$> pList_ng pSemDef <?> "attribute rules"++    pExpr :: AGParser Expression+    pExpr = (\(str,pos) ->  Expression pos (lexTokens opts pos str)) <$> pCodescrapL <?> "an expression"++    pTypeColon :: AGParser Pos+    pTypeColon+      = if doubleColons opts+        then pDoubleColon+        else pColon++    --marcos+    pMaybeMacro :: AGParser MaybeMacro+    pMaybeMacro  =  Just <$ pDoubleArrow <*>  pMacro+                <|> pSucceed Nothing++    pMacro :: AGParser Macro+    pMacro+          =  Macro <$> pIdentifierU+                   <*> pList1 pMacroChild+                   <?> "macro"++    pMacroChild :: AGParser MacroChild+    pMacroChild+          =  (pIdentifier <* pEquals) <**>+             (flip RuleChild   <$> pMacro       <|>+              flip ChildChild  <$> pIdentifier  <|>+              flip ValueChild  <$> pCodescrap' )++    pTypeNt :: AGParser Type+    pTypeNt+      =   ((\nt -> mkNtType nt []) <$> pTypeCon <?> "nonterminal name (no brackets)")+      <|> (pParens (mkNtType <$> pTypeCon <*> pList pTypeHaskellAnyAsString) <?> "nonterminal name with parameters (using parenthesis)")++    pTypeCon :: AGParser Identifier+    pTypeCon+      | ocaml opts = pIdentifierExcl+      | otherwise  = pIdentifierU++    pTypeVar :: AGParser Identifier+    pTypeVar+      | ocaml opts = (\(nm, pos) -> Ident nm pos) <$> pTextnmPos+      | otherwise  = pIdentifier++    pTypeHaskellAnyAsString :: AGParser String+    pTypeHaskellAnyAsString+      =   getName <$> pTypeVar+      <|> getName <$> pTypeCon+      <|> 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+      <|> mkNtType <$> pTypeCon <*> pList pTypeHaskellAnyAsString+      <|> (Haskell . getName) <$> pTypeVar+      <|> pTypePrimitive++    pTypePrimitive :: AGParser Type+    pTypePrimitive+      = Haskell <$> pCodescrap'  <?> "a type"++    pType :: AGParser Type+    pType =  pTypeNt+          <|> pTypePrimitive++    pTypeOrSelf :: AGParser Type+    pTypeOrSelf = pType <|> Self <$ pSELF++    pOptClassContext :: AGParser ClassContext+    pOptClassContext+      =   pClassContext <* pDoubleArrow+      <|> pSucceed []++    pClassContext :: AGParser ClassContext+    pClassContext+      = pListSep pComma ((,) <$> pIdentifierU <*> pList pTypeHaskellAnyAsString)++    pNontSet = set0 where+        set0 = pChainr (Intersect <$ pIntersect) set1+        set1 = pChainl (Difference <$ pMinus) set2+        set2 = pChainr (pSucceed Union) set3+        set3 = pTypeCon <**> opt (flip Path <$ pArrow <*> pTypeCon) NamedSet+            <|> All <$ pStar+            <|> pParens set0++    --+    -- End of AG Parser+    --++resolveFile :: Options -> [FilePath] -> FilePath -> IO FilePath+resolveFile opts path fname = search (path ++ ["."])+ where search (p:ps) = do let filename = joinPath [p, fname]+                          fExists <- doesFileExist filename+                          if fExists+                            then return filename+                            else do let filename' = joinPath [p, replaceExtension fname "ag"]+                                    fExists' <- doesFileExist filename'+                                    if fExists'+                                      then return filename'+                                      else search ps+       search []     = do+         outputStr opts ("File: " ++ show fname ++ " not found in search path: " ++ show (concat (intersperse ";" (path ++ ["."]))) ++ "\n")+         failWithCode opts 1+         return (error "resolveFile: file not found")++evalStepsMessages :: (Eq s, Show s, Show p) => Steps a s p -> (a,[Message s p])+evalStepsMessages steps = case steps of+  OkVal v        rest -> let (arg,ms) = evalStepsMessages rest+                         in (v arg,ms)+  Ok             rest -> evalStepsMessages rest+  Cost  _        rest -> evalStepsMessages rest+  StRepair _ msg rest -> let (v,ms) = evalStepsMessages rest+                         in (v, msg:ms)+  Best _   rest   _   -> evalStepsMessages rest+  NoMoreSteps v       -> (v,[])++loopp ::(a->Bool) -> (a->IO a) -> a ->  IO a+loopp pred cont x | pred x = return x+                  | otherwise = do x' <- cont x+                                   loopp pred cont x'++codescrapL p []                 = (valueToken TkTextln "" p,p,[])+codescrapL p (x:xs) | isSpace x = (updPos'  x p)  codescrapL xs+                    | otherwise = let refcol = column p+                                      (p',sc,rest) = scrapL refcol p  (x:xs)+                                  in (valueToken TkTextln sc p,p',rest)++scrapL ref p (x:xs) | isSpace x || column p >= ref =+                          let (p'',sc,inp) = updPos'  x p (scrapL ref)  xs+                          in  (p'',x:sc,inp)+                    | otherwise       =(p,[],x:xs)+scrapL ref p []     = (p,[],[])++pNames :: AGParser [Identifier]+pNames = pIdentifiers+++-- Insertion is expensive for pCodeBlock in order to prevent infinite inserts.+pCodeBlock ::  AGParser (String,Pos)+pCodeBlock   = pCostValToken 90 TkTextln "" <?> "a code block"++pOptQuantifiers :: AGParser [String]+pOptQuantifiers = (return <$ pDoubleColon <*> pCodescrap') `opt` []++pIdentifiers :: AGParser [Identifier]+pIdentifiers =  pList1Sep pComma pIdentifier <?> "lowercase identifiers"++pAttrIdentifier :: AGParser Identifier+pAttrIdentifier = pIdentifier+                  <|> (\pos -> Ident "imports" pos) <$> pIMPORTS+                  <|> (\pos -> Ident "toplevel" pos) <$> pTOPLEVEL++pAttrIdentifiers :: AGParser [Identifier]+pAttrIdentifiers = pList1Sep pComma pAttrIdentifier <?> "lowercase identifiers"++pUse :: AGParser (String,String,String)+pUse = (  (\u x y->(x,y,show u)) <$> pUSE <*> pCodescrap'  <*> pCodescrap') `opt` ("","","") <?> "USE declaration"++mklower :: String -> String+mklower (x:xs) = toLower x : xs+mklower []     = []++pSimpleConstructorSet :: AGParser ConstructorSet+pSimpleConstructorSet =  CName <$> pIdentifierU+                     <|> CAll  <$  pStar+                     <|> pParens pConstructorSet++pConstructorSet :: AGParser ConstructorSet+pConstructorSet =  pChainl (CDifference <$ pMinus) term2+  where term2 =  pChainr (pSucceed CUnion) term1+        term1 =  CName <$> pIdentifierU+             <|> CAll  <$  pStar++pFieldIdentifier :: AGParser Identifier+pFieldIdentifier =  pIdentifier+                <|> Ident "lhs"  <$> pLHS+                <|> Ident "loc"  <$> pLOC+                <|> Ident "inst" <$> pINST++pAugmentToken :: AGParser ()+pAugmentToken = () <$ (pAUGMENT <|> pPlus)++pAttr = (,) <$> pFieldIdentifier <* pDot <*> pAttrIdentifier++pAttrOrIdent+  = OccAttr <$> pFieldIdentifier <* pDot <*> pAttrIdentifier+  <|> OccRule <$> pIdentifier++nl2sp :: Char -> Char+nl2sp '\n' = ' '+nl2sp '\r' = ' '+nl2sp x = x++pVar :: AGParser (Identifier -> (Identifier, Identifier))+pVar = (\att fld -> (fld,att)) <$> pAttrIdentifier++pAssign :: AGParser Bool+pAssign =  False <$ pReserved "="+       <|> True  <$ pReserved ":="++pRuleSym :: AGParser (Bool, Pos, Bool, Bool)+pRuleSym  =     (\p -> (False, p, True, False)) <$> pReserved "="+            <|> (\p -> (True,  p, True, False)) <$> pReserved ":="+            <|> (\p -> (False, p, True, False)) <$> pReserved "<-"+            <|> (\p -> (False, p, True, True))  <$> pReserved "<<-"++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+           <|> pPattern2+  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"+    where mkTuple _ [x] a = x a+          mkTuple p xs  a = Product p (map ($ a) xs)++pCostSym' c t = pCostSym c t t++pCodescrap' ::  AGParser String+pCodescrap' = fst <$> pCodescrap++pCodescrap ::  AGParser (String,Pos)+pCodescrap   = pCodeBlock++pSEM, pATTR, pDATA, pRECORD, pUSE, pLOC,pINCLUDE, pTYPE, pEquals, pColonEquals, pTilde,+      pEXTENDS, --marcos+      pBar, pColon, pLHS,pINST,pSET,pDERIVING,pMinus,pIntersect,pDoubleArrow,pArrow,+      pDot, pUScore, pEXT,pAt,pStar, pSmaller, pWRAPPER, pNOCATAS, pPRAGMA, pMAYBE, pEITHER, pMAP, pINTMAP,+      pMODULE, pATTACH, pUNIQUEREF, pINH, pSYN, pAUGMENT, pPlus, pAROUND, pSEMPRAGMA, pMERGE, pAS, pSELF,+      pIMPORTS, pOPTPRAGMAS, pSmallerEqual, pINTSET, pDATABLOCK, pRECBLOCK+      :: AGParser Pos+pSET         = pCostReserved 90 "SET"     <?> "SET"+pDERIVING    = pCostReserved 90 "DERIVING"<?> "DERIVING"+pWRAPPER     = pCostReserved 90 "WRAPPER" <?> "WRAPPER"+pNOCATAS     = pCostReserved 90 "NOCATAS" <?> "NOCATAS"+pPRAGMA      = pCostReserved 90 "PRAGMA"  <?> "PRAGMA"+pSEMPRAGMA   = pCostReserved 90 "SEMPRAGMA" <?> "SEMPRAGMA"+pATTACH      = pCostReserved 90 "ATTACH"  <?> "ATTACH"+pDATA        = pCostReserved 90 "DATA"    <?> "DATA"+pRECORD      = pCostReserved 90 "RECORD"  <?> "RECORD"+pEXT         = pCostReserved 90 "EXT"     <?> "EXT"+pATTR        = pCostReserved 90 "ATTR"    <?> "ATTR"+pSEM         = pCostReserved 90 "SEM"     <?> "SEM"+pINCLUDE     = pCostReserved 90 "INCLUDE" <?> "INCLUDE"+pEXTENDS     = pCostReserved 90 "EXTENDS" <?> "EXTENDS" --marcos+pTYPE        = pCostReserved 90 "TYPE"    <?> "TYPE"+pINH         = pCostReserved 90 "INH"     <?> "INH"+pSYN         = pCostReserved 90 "SYN"     <?> "SYN"+pCHN         = pCostReserved 90 "CHN"     <?> "CHN"+pMAYBE       = pCostReserved 5  "MAYBE"   <?> "MAYBE"+pEITHER      = pCostReserved 5  "EITHER"  <?> "EITHER"+pMAP         = pCostReserved 5  "MAP"     <?> "MAP"+pINTMAP      = pCostReserved 5  "INTMAP"  <?> "INTMAP"+pINTSET      = pCostReserved 5  "INTSET"  <?> "INTSET"+pUSE         = pCostReserved 5  "USE"     <?> "USE"+pLOC         = pCostReserved 5  "loc"     <?> "loc"+pLHS         = pCostReserved 5  "lhs"     <?> "loc"+pINST        = pCostReserved 5  "inst"    <?> "inst"+pAt          = pCostReserved 5  "@"       <?> "@"+pDot         = pCostReserved 5  "."       <?> "."+pUScore      = pCostReserved 5  "_"       <?> "_"+pColon       = pCostReserved 5  ":"       <?> ":"+pDoubleColon = pCostReserved 5  "::"      <?> "::"+pEquals      = pCostReserved 5  "="       <?> "="+pColonEquals = pCostReserved 5  ":="      <?> ":="+pTilde       = pCostReserved 5  "~"       <?> "~"+pPlus        = pCostReserved 5  "+"       <?> "+"+pBar         = pCostReserved 5  "|"       <?> "|"+pIntersect   = pCostReserved 5  "/\\"     <?> "/\\"+pMinus       = pCostReserved 5  "-"       <?> "-"+pDoubleArrow = pCostReserved 5  "=>"      <?> "=>"+pSmallerEqual= pCostReserved 5  "<="      <?> "<="+pArrow       = pCostReserved 5  "->"      <?> "->"+pStar        = pCostReserved 5  "*"       <?> "*"+pSmaller     = pCostReserved 5  "<"       <?> "<"+pMODULE      = pCostReserved 5  "MODULE"  <?> "MODULE"+pUNIQUEREF   = pCostReserved 5  "UNIQUEREF" <?> "UNIQUEREF"+pAUGMENT     = pCostReserved 5  "AUGMENT" <?> "AUGMENT"+pAROUND      = pCostReserved 5  "AROUND" <?> "AROUND"+pMERGE       = pCostReserved 5  "MERGE" <?> "MERGE"+pAS          = pCostReserved 5  "AS" <?> "AS"+pSELF        = pCostReserved 5  "SELF" <?> "SELF"+pIMPORTS     = pCostReserved 5  "imports" <?> "imports"+pOPTPRAGMAS  = pCostReserved 5  "optpragmas" <?> "optpragmas"+pTOPLEVEL    = pCostReserved 5  "toplevel" <?> "toplevel"+pDATABLOCK   = pCostReserved 5  "datablock" <?> "datadecl block"+pRECBLOCK    = pCostReserved 5  "recblock" <?> "recursive block"
src/Pretty.hs view
@@ -1,191 +1,191 @@--------------------------------------------------------------------------
--- Subset of UU.Pretty, based on very simple pretty printing
--- Extended with line-nr tracking
--------------------------------------------------------------------------
-
-module Pretty
-  ( PP_Doc, PP(..)
-  , disp
-
-  , (>|<), (>-<)
-  , (>#<)
-  , ppWithLineNr
-  , hlist, vlist, hv
-  , fill
-  , indent
-
-  , pp_block
-  , vlist_sep
-  , pp_parens
-  , pp_braces
-  , hv_sp
-
-  , empty, empty1, text
-  , isEmpty
-  )
-  where
-
-import Data.List(intersperse)
-
--------------------------------------------------------------------------
--- Doc structure
--------------------------------------------------------------------------
-
-data Doc
-  = Emp
-  | Emp1
-  | Str         !String                 -- basic string
-  | Hor         Doc  !Doc               -- horizontal positioning
-  | Ver         Doc  !Doc               -- vertical positioning
-  | Ind         !Int Doc                -- indent
-  | Line        (Int -> Doc)            -- line nr
-
-type PP_Doc = Doc
-
--------------------------------------------------------------------------
--- Basic combinators
--------------------------------------------------------------------------
-
-infixr 3 >|<, >#<
-infixr 2 >-<
-
-(>|<) :: (PP a, PP b) => a -> b -> PP_Doc
-l >|< r = pp l `Hor` pp r
-
-(>-<) :: (PP a, PP b) => a -> b -> PP_Doc
-l >-< r  | isEmpty a = b
-         | isEmpty b = a
-         | otherwise = a `Ver` b
-         where a = pp l
-               b = pp r
-
-(>#<) :: (PP a, PP b) => a -> b -> PP_Doc
-l >#< r  | isEmpty a = b
-         | isEmpty b = a
-         | otherwise = a >|< " " >|< b
-         where a = pp l
-               b = pp r
-
-indent :: PP a => Int -> a -> PP_Doc
-indent i d = Ind i $ pp d
-
-text :: String -> PP_Doc
-text s
-  = let ls = lines s
-        ls' | null ls   = [""]
-            | otherwise = ls
-    in vlist (map Str ls')
-
-empty :: PP_Doc
-empty = Emp
-
--- empty1 is not a zero for >#<
-empty1 :: PP_Doc
-empty1 = Emp1
-
-ppWithLineNr :: PP a => (Int -> a) -> PP_Doc
-ppWithLineNr f = Line (pp . f)
-
--------------------------------------------------------------------------
--- Derived combinators
--------------------------------------------------------------------------
-
-hlist, vlist :: PP a => [a] -> PP_Doc
-vlist [] = empty
-vlist as = foldr  (>-<) empty as
-hlist [] = empty
-hlist as = foldr  (>|<) empty as
-
-hv :: PP a => [a] -> PP_Doc
-hv = vlist
-
-hv_sp :: PP a => [a] -> PP_Doc
-hv_sp = foldr (>#<) empty
-
-fill :: PP a => [a] -> PP_Doc
-fill = hlist
-
-pp_block:: (PP a, PP b, PP c) => a -> b -> c -> [PP_Doc] -> PP_Doc
-pp_block o c s as = pp o >|< hlist (intersperse (pp s) as) >|< pp c
-
-pp_parens :: PP a => a -> PP_Doc
-pp_parens p = '(' >|< p >|< ')'
-
-pp_braces :: PP a => a -> PP_Doc
-pp_braces p = '{' >-< p >-< '}'
-
-vlist_sep :: (PP a, PP b) => a -> [b] -> PP_Doc
-vlist_sep sep lst
-  = vlist (intersperse (pp sep) (map pp lst))
-
--------------------------------------------------------------------------
--- PP class
--------------------------------------------------------------------------
-
-class Show a => PP a where
-  pp     :: a   -> PP_Doc
-  pp       = text . show
-
-  ppList :: [a] -> PP_Doc
-  ppList as = hlist as
-
-instance PP Doc where
-  pp     = id
-
-instance PP Char where
-  pp c   = text [c]
-  ppList = text
-
-instance PP a => PP [a] where
-  pp = ppList
-
-instance Show Doc where
-  show p = disp p 200 ""
-
-instance PP Int where
-  pp = text . show
-
-instance PP Float where
-  pp = text . show
-
--------------------------------------------------------------------------
--- Observation
--------------------------------------------------------------------------
-
-isEmpty :: PP_Doc -> Bool
-isEmpty Emp         = True
-isEmpty Emp1        = False
-isEmpty (Ver d1 d2) = isEmpty d1 && isEmpty d2
-isEmpty (Hor d1 d2) = isEmpty d1 && isEmpty d2
-isEmpty (Ind _  d ) = isEmpty d
-isEmpty _           = False
-
--------------------------------------------------------------------------
--- Rendering
--------------------------------------------------------------------------
-
-disp  ::  PP_Doc -> Int -> ShowS
-disp d0 _ s0
-  = r
-  where (r,_,_) = put 0 1 d0 s0
-        put p l d s
-          = case d of
-              Emp              -> (s,p,l)
-              Emp1             -> (s,p,l)
-              Str s'           -> (s' ++ s,p + length s',l)
-              Ind i  d1        -> (ind ++ r',p', l')
-                               where (r',p',l') = put (p+i) l d1 s
-                                     ind = replicate i ' '
-              Hor d1 d2        -> (r1,p2,l2)
-                               where (r1,p1,l1) = put p  l  d1 r2
-                                     (r2,p2,l2) = put p1 l1 d2 s
-              Ver d1 d2 | isEmpty d1
-                               -> put p l d2 s
-              Ver d1 d2 | isEmpty d2
-                               -> put p l d1 s
-              Ver d1 d2        -> (r1,p2,l2)
-                               where (r1,_ ,l1) = put p l d1 $ "\n" ++ ind ++ r2
-                                     (r2,p2,l2) = put p (l1+1) d2 s
-                                     ind = replicate p ' '
-              Line f           -> (r',p',l')
-                               where (r',p',l') = put p l (f l) s
+-------------------------------------------------------------------------+-- Subset of UU.Pretty, based on very simple pretty printing+-- Extended with line-nr tracking+-------------------------------------------------------------------------++module Pretty+  ( PP_Doc, PP(..)+  , disp++  , (>|<), (>-<)+  , (>#<)+  , ppWithLineNr+  , hlist, vlist, hv+  , fill+  , indent++  , pp_block+  , vlist_sep+  , pp_parens+  , pp_braces+  , hv_sp++  , empty, empty1, text+  , isEmpty+  )+  where++import Data.List(intersperse)++-------------------------------------------------------------------------+-- Doc structure+-------------------------------------------------------------------------++data Doc+  = Emp+  | Emp1+  | Str         !String                 -- basic string+  | Hor         Doc  !Doc               -- horizontal positioning+  | Ver         Doc  !Doc               -- vertical positioning+  | Ind         !Int Doc                -- indent+  | Line        (Int -> Doc)            -- line nr++type PP_Doc = Doc++-------------------------------------------------------------------------+-- Basic combinators+-------------------------------------------------------------------------++infixr 3 >|<, >#<+infixr 2 >-<++(>|<) :: (PP a, PP b) => a -> b -> PP_Doc+l >|< r = pp l `Hor` pp r++(>-<) :: (PP a, PP b) => a -> b -> PP_Doc+l >-< r  | isEmpty a = b+         | isEmpty b = a+         | otherwise = a `Ver` b+         where a = pp l+               b = pp r++(>#<) :: (PP a, PP b) => a -> b -> PP_Doc+l >#< r  | isEmpty a = b+         | isEmpty b = a+         | otherwise = a >|< " " >|< b+         where a = pp l+               b = pp r++indent :: PP a => Int -> a -> PP_Doc+indent i d = Ind i $ pp d++text :: String -> PP_Doc+text s+  = let ls = lines s+        ls' | null ls   = [""]+            | otherwise = ls+    in vlist (map Str ls')++empty :: PP_Doc+empty = Emp++-- empty1 is not a zero for >#<+empty1 :: PP_Doc+empty1 = Emp1++ppWithLineNr :: PP a => (Int -> a) -> PP_Doc+ppWithLineNr f = Line (pp . f)++-------------------------------------------------------------------------+-- Derived combinators+-------------------------------------------------------------------------++hlist, vlist :: PP a => [a] -> PP_Doc+vlist [] = empty+vlist as = foldr  (>-<) empty as+hlist [] = empty+hlist as = foldr  (>|<) empty as++hv :: PP a => [a] -> PP_Doc+hv = vlist++hv_sp :: PP a => [a] -> PP_Doc+hv_sp = foldr (>#<) empty++fill :: PP a => [a] -> PP_Doc+fill = hlist++pp_block:: (PP a, PP b, PP c) => a -> b -> c -> [PP_Doc] -> PP_Doc+pp_block o c s as = pp o >|< hlist (intersperse (pp s) as) >|< pp c++pp_parens :: PP a => a -> PP_Doc+pp_parens p = '(' >|< p >|< ')'++pp_braces :: PP a => a -> PP_Doc+pp_braces p = '{' >-< p >-< '}'++vlist_sep :: (PP a, PP b) => a -> [b] -> PP_Doc+vlist_sep sep lst+  = vlist (intersperse (pp sep) (map pp lst))++-------------------------------------------------------------------------+-- PP class+-------------------------------------------------------------------------++class Show a => PP a where+  pp     :: a   -> PP_Doc+  pp       = text . show++  ppList :: [a] -> PP_Doc+  ppList as = hlist as++instance PP Doc where+  pp     = id++instance PP Char where+  pp c   = text [c]+  ppList = text++instance PP a => PP [a] where+  pp = ppList++instance Show Doc where+  show p = disp p 200 ""++instance PP Int where+  pp = text . show++instance PP Float where+  pp = text . show++-------------------------------------------------------------------------+-- Observation+-------------------------------------------------------------------------++isEmpty :: PP_Doc -> Bool+isEmpty Emp         = True+isEmpty Emp1        = False+isEmpty (Ver d1 d2) = isEmpty d1 && isEmpty d2+isEmpty (Hor d1 d2) = isEmpty d1 && isEmpty d2+isEmpty (Ind _  d ) = isEmpty d+isEmpty _           = False++-------------------------------------------------------------------------+-- Rendering+-------------------------------------------------------------------------++disp  ::  PP_Doc -> Int -> ShowS+disp d0 _ s0+  = r+  where (r,_,_) = put 0 1 d0 s0+        put p l d s+          = case d of+              Emp              -> (s,p,l)+              Emp1             -> (s,p,l)+              Str s'           -> (s' ++ s,p + length s',l)+              Ind i  d1        -> (ind ++ r',p', l')+                               where (r',p',l') = put (p+i) l d1 s+                                     ind = replicate i ' '+              Hor d1 d2        -> (r1,p2,l2)+                               where (r1,p1,l1) = put p  l  d1 r2+                                     (r2,p2,l2) = put p1 l1 d2 s+              Ver d1 d2 | isEmpty d1+                               -> put p l d2 s+              Ver d1 d2 | isEmpty d2+                               -> put p l d1 s+              Ver d1 d2        -> (r1,p2,l2)+                               where (r1,_ ,l1) = put p l d1 $ "\n" ++ ind ++ r2+                                     (r2,p2,l2) = put p (l1+1) d2 s+                                     ind = replicate p ' '+              Line f           -> (r',p',l')+                               where (r',p',l') = put p l (f l) s
src/RhsCheck.hs view
@@ -1,65 +1,65 @@-module RhsCheck(checkRhs,checkBlock,checkTy) where
-
-import Language.Haskell.Exts (parseExpWithMode, parseModuleWithMode, parseTypeWithMode, srcLine, srcColumn, srcFilename, baseFixities, glasgowExts, ParseMode (..), defaultParseMode, ParseResult (..), Extension (..))
-import ErrorMessages
-import Expression
-import HsToken
-import UU.Scanner.Position
-
-checkRhs,checkBlock,checkTy :: Expression -> Errors
-checkRhs   = check parseExpWithMode
-checkBlock = check parseModuleWithMode
-checkTy    = check parseTypeWithMode
-
-check :: (ParseMode -> String -> ParseResult a) -> Expression -> Errors
-check p (Expression pos tks) = case res of
-   ParseOk _           -> []
-   ParseFailed loc msg -> let pos' = Pos (srcLine loc + line pos - 1) (srcColumn loc) (srcFilename loc)
-                          in [HsParseError pos' msg]
- where
-  pos0 = Pos (line pos) 1 (file pos)
-  str  = toString pos0 tks
-  res  = p mode str
-  bf   = case baseFixities of
-           [] -> Nothing
-           xs -> Just xs
-  mode = defaultParseMode { parseFilename = file pos, ignoreLanguagePragmas = False, extensions = exts
-                          , ignoreLinePragmas = False, fixities = bf }
-
-exts :: [Extension]
-exts = glasgowExts
-
-toString :: Pos -> HsTokens -> String
-toString _    []       = ""
-toString cPos (tk:tks) = move ++ current ++ next
-  where
-    tkPos   = getPos tk
-    move    = addSpacing (line tkPos - line cPos) (column cPos) (column tkPos)
-    current = fmt tk
-    nPos    = upd tkPos current
-    next    = toString nPos tks
-
-getPos :: HsToken -> Pos
-getPos (AGLocal _ pos _)    = pos
-getPos (AGField _ _ pos _)  = pos
-getPos (HsToken _ pos)      = pos
-getPos (CharToken _ pos)    = pos
-getPos (StrToken _ pos)     = pos
-getPos (Err _ pos)          = pos
-
-fmt :: HsToken -> String
-fmt (AGLocal var _ _)         = "_" ++ show var
-fmt (AGField field attr _ _)  = "_" ++ show field ++ "_" ++ show attr
-fmt (HsToken val _)           = val
-fmt (CharToken val _)         = show val
-fmt (StrToken val _)          = show val
-fmt (Err val _)               = val
-
-upd :: Pos -> String -> Pos
-upd p s = foldl adv p s
-
-addSpacing :: Int -> Int -> Int -> String
-addSpacing l c1 c2 = replicate l '\n' ++ replicate c ' '
-  where
-    c  | l == 0 = c2 - c1
-       | otherwise = c2 - 1
+module RhsCheck(checkRhs,checkBlock,checkTy) where++import Language.Haskell.Exts (parseExpWithMode, parseModuleWithMode, parseTypeWithMode, srcLine, srcColumn, srcFilename, baseFixities, glasgowExts, ParseMode (..), defaultParseMode, ParseResult (..), Extension (..))+import ErrorMessages+import Expression+import HsToken+import UU.Scanner.Position++checkRhs,checkBlock,checkTy :: Expression -> Errors+checkRhs   = check parseExpWithMode+checkBlock = check parseModuleWithMode+checkTy    = check parseTypeWithMode++check :: (ParseMode -> String -> ParseResult a) -> Expression -> Errors+check p (Expression pos tks) = case res of+   ParseOk _           -> []+   ParseFailed loc msg -> let pos' = Pos (srcLine loc + line pos - 1) (srcColumn loc) (srcFilename loc)+                          in [HsParseError pos' msg]+ where+  pos0 = Pos (line pos) 1 (file pos)+  str  = toString pos0 tks+  res  = p mode str+  bf   = case baseFixities of+           [] -> Nothing+           xs -> Just xs+  mode = defaultParseMode { parseFilename = file pos, ignoreLanguagePragmas = False, extensions = exts+                          , ignoreLinePragmas = False, fixities = bf }++exts :: [Extension]+exts = glasgowExts++toString :: Pos -> HsTokens -> String+toString _    []       = ""+toString cPos (tk:tks) = move ++ current ++ next+  where+    tkPos   = getPos tk+    move    = addSpacing (line tkPos - line cPos) (column cPos) (column tkPos)+    current = fmt tk+    nPos    = upd tkPos current+    next    = toString nPos tks++getPos :: HsToken -> Pos+getPos (AGLocal _ pos _)    = pos+getPos (AGField _ _ pos _)  = pos+getPos (HsToken _ pos)      = pos+getPos (CharToken _ pos)    = pos+getPos (StrToken _ pos)     = pos+getPos (Err _ pos)          = pos++fmt :: HsToken -> String+fmt (AGLocal var _ _)         = "_" ++ show var+fmt (AGField field attr _ _)  = "_" ++ show field ++ "_" ++ show attr+fmt (HsToken val _)           = val+fmt (CharToken val _)         = show val+fmt (StrToken val _)          = show val+fmt (Err val _)               = val++upd :: Pos -> String -> Pos+upd p s = foldl adv p s++addSpacing :: Int -> Int -> Int -> String+addSpacing l c1 c2 = replicate l '\n' ++ replicate c ' '+  where+    c  | l == 0 = c2 - c1+       | otherwise = c2 - 1
src/Scanner.hs view
@@ -1,234 +1,234 @@-{-# LANGUAGE MagicHash, UnboxedTuples, FlexibleInstances #-}
-module Scanner where
-import GHC.Prim
-import TokenDef
-import UU.Scanner.Position
-import UU.Scanner.Token
-import UU.Parsing(InputState(..),Either'(..))
-import Data.Maybe
-import Data.List
-import Data.Char
-import UU.Scanner.GenToken
-import Options (Options (..))
-
-data Input = Input !Pos String (Maybe (Token, Input))
-
-instance InputState Input Token Pos where
- splitStateE input@(Input _ _ next) =
-                case next of
-                     Nothing         -> Right' input
-                     Just (s, rest)  -> Left' s rest
- splitState (Input _ _ next) =
-                case next of
-                     Nothing         -> error "splitState on empty input"
-                     Just (s, rest)  -> (# s, rest #)
- getPosition (Input pos _ next) =  case next of
-                                    Just (s,_) -> position s
-                                    Nothing    -> pos -- end of file
-
-
-input :: Options -> Pos -> String -> Input
-input opts pos inp = Input pos
-                      inp
-                      (case scan opts pos inp of
-                             Nothing      -> Nothing
-                             Just (s,p,r) -> Just (s, input opts p r)
-                      )
-
-type Lexer s = Pos -> String -> Maybe (s,Pos,String)
-
-scan :: Options -> Lexer Token
-scan opts p0
-  | column p0 == 1 = scanBeginOfLine p0
-  | otherwise      = scan p0
-  where
-    keywords' = if lcKeywords opts
-                then map (map toLower) keywords
-                else keywords
-    mkKeyword s | s `elem` lowercaseKeywords = s
-                | otherwise                  = map toUpper s
-
-    scan :: Lexer Token
-    scan p []                        = Nothing
-    scan p ('/':'/':xs)
-      | clean opts
-                                     = let (com,rest) = span (/= '\n') xs
-                                       in advc' (2+length com) p scan rest
-    scan p ('-':'-':xs) | null xs || not (head xs `elem` "<>!?#@:%$^&")
-                                     = let (com,rest) = span (/= '\n') xs
-                                       in advc' (2+length com) p scan rest
-    scan p ('{':'-':xs)              = advc' 2 p (ncomment scan) xs
-    scan p ('/':'*':xs) | clean opts = advc' 2 p (cleancomment scan) xs
-    scan p ('{'    :xs)              = advc' 1 p codescrap xs
-    scan p ('\CR':xs)                = case xs of
-                                        '\LF':ys -> newl' p scanBeginOfLine ys --ms newline
-                                        _        -> newl' p scanBeginOfLine xs --mac newline
-    scan p ('\LF':xs)                =  newl' p scanBeginOfLine xs             --unix newline
-    scan p (x:xs) | isSpace x        = updPos'  x p scan  xs
-    scan p xs = Just (scan' xs)
-      where 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 2 p, rs)
-            scan' ('<' : '=' : rs)   = (reserved "<=" p, advc 2 p, rs)
-            scan' ('<' : '<' : '-' : rs) = (reserved "<<-" p, advc 3 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)       = (OBrace      p, advc 1 p, rs)
-    --        scan' ('}'    :rs)       = (CBrace      p, advc 1 p, rs)
-
-            scan' ('\"' :rs)         = let isOk c = c /= '"' && c /= '\n'
-                                           (str,rest) = span isOk rs
-                                       in if null rest || head rest /= '"'
-                                              then (errToken "unterminated string literal"   p
-                                                   , 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)
-            scan' (':':':':rs)       = (reserved "::" p, advc 2 p, rs)
-            scan' ('∷':rs)           = (reserved "::" p, advc 1 p, rs)  -- recognize unicode double colons too
-            scan' (':' :rs)                           = (reserved ":" p, advc 1 p, rs)
-            scan' ('|' :rs)          = (reserved "|" p, advc 1 p, rs)
-
-            scan' ('/':'\\':rs)      = (reserved "/\\" p, advc 2 p, rs)
-            scan' ('-':'>' :rs)      = (reserved "->" p, advc 2 p, rs)
-            scan' ('-'     :rs)      = (reserved "-" p, advc 1 p, rs)
-            scan' ('*'     :rs)      = (reserved "*" p, advc 1 p, rs)
-
-            scan' ('\''    :rs) | ocaml opts =  -- note: ocaml type variables are encoded as 'TkTextnm' tokens
-              let (var,rest) = ident opts rs
-                  str = '\'' : var
-              in (valueToken TkTextnm str p, advc (length str) p, rest)
-
-            scan' (x:rs) | isLower x = let (var,rest) = ident opts rs
-                                           str        = (x:var)
-                                           tok | str `elem` keywords' = reserved (mkKeyword str)
-                                               | otherwise            = valueToken TkVarid str
-                                       in (tok p, advc (length var+1) p, rest)
-                         | isUpper x = let (var,rest) = ident opts rs
-                                           str        = (x:var)
-                                           tok | str `elem` keywords' = reserved (mkKeyword str)
-                                               | otherwise            = valueToken TkConid str
-                                       in (tok p, advc (length var+1) p,rest)
-                         | otherwise = (errToken ("unexpected character " ++ show x) p, advc 1 p, rs)
-
-    scanBeginOfLine :: Lexer Token
-    scanBeginOfLine p ('{' : '-' : ' ' : 'L' : 'I' : 'N' : 'E' : ' ' : xs)
-      | isOkBegin rs && isOkEnd rs'
-          = scan (advc (8 + length r + 2 + length s + 4) p') (drop 4 rs')
-      | otherwise
-          = Just (errToken ("Invalid LINE pragma: " ++ show r) p, advc 8 p, xs)
-      where
-        (r,rs)   = span isDigit xs
-        (s, rs') = span (/= '"') (drop 2 rs)
-        p' = Pos (read r - 1) (column p) s    -- LINE pragma indicates the line number of the /next/ line!
-
-        isOkBegin (' ' : '"' : _) = True
-        isOkBegin _               = False
-
-        isOkEnd ('"' : ' ' : '-' : '}' : _) = True
-        isOkEnd _         = False
-    scanBeginOfLine p xs
-      = scan p xs
-
-
-ident opts = span isValid
- where isValid x = isAlphaNum x || x == '_' ||
-                   (not (clean opts) && x == '\'') || (clean opts && x == '`')
-
-lowercaseKeywords = ["loc","lhs", "inst", "optpragmas", "imports", "toplevel", "datablock", "recblock"]
-keywords = lowercaseKeywords ++
-           [ "DATA", "RECORD", "EXT", "ATTR", "SEM","TYPE", "USE", "INCLUDE"
-           , "EXTENDS" -- marcos
-           , "SET","DERIVING","FOR", "WRAPPER", "NOCATAS", "MAYBE", "EITHER", "MAP", "INTMAP"
-           , "PRAGMA", "SEMPRAGMA", "MODULE", "ATTACH", "UNIQUEREF", "INH", "SYN", "CHN"
-           , "AUGMENT", "AROUND", "MERGE", "AS", "SELF", "INTSET"
-           ]
-
-ncomment c p ('-':'}':xs) = advc' 2 p c  xs
-ncomment c p ('{':'-':xs) = advc' 2 p (ncomment (ncomment c)) xs
-ncomment c p (x:xs)       = updPos' x p (ncomment c)  xs
-ncomment c p []           = Just (errToken "unterminated nested comment" p, p,[])
-
-cleancomment c p ('*':'/':xs) = advc' 2 p c  xs
-cleancomment c p ('/':'*':xs) = advc' 2 p (cleancomment (cleancomment c)) xs
-cleancomment c p (x:xs)       = updPos' x p (cleancomment c)  xs
-cleancomment c p []           = Just (errToken "unterminated nested comment" p, p,[])
-
-codescrap p xs = let (p2,xs2,sc) = codescrap' 1 p xs
-                 in case xs2 of
-                         ('}':rest) -> Just (valueToken TkTextln sc p,advc 1 p2,rest)
-                         _          -> Just (errToken "unterminated codescrap" p,p2,xs2)
-
-
-codescrap' d p [] = (p,[],[])
-{-
-codescrap' d p ('{':'{':xs) = let (p2,xs2,sc) = advc' 2 p (codescrap' d) xs
-                              in (p2,xs2,'{':' ':sc)
-codescrap' d p ('}':'}':xs) = let (p2,xs2,sc) = advc' 2 p (codescrap' d) xs
-                              in (p2,xs2,'}':' ':sc)
--}
-codescrap' d p ('{':xs)     = let (p2,xs2,sc) = advc' 1 p (codescrap' (d+1)) xs
-                              in (p2,xs2,'{' : sc)
-codescrap' d p ('}':xs)     | d == 1 = (p,'}':xs,[])
-                            | otherwise = let (p2,xs2,sc) = advc' 1 p (codescrap' (d-1)) xs
-                                          in (p2,xs2,'}' : sc)
-codescrap' d p (x  :xs)     = let (p2,xs2,sc) = updPos' x p (codescrap' d) xs
-                              in (p2,xs2,x:sc)
---Literate Mode
-scanLit xs = (fs, foldr insNL (const "") codeLns 1)
-  where insNL (n,line) r = \n1 -> replicate (n-n1) '\n' ++ line ++ r n
-        (fs,codeLns,_) = getBlocks ([1..] `zip`  toLines xs)
-        getBlocks [] = ([],[],[])
-        getBlocks xs = let (files1,txt1,r1) = getBlock xs
-                           (files2,txt2,r2) = getBlocks r1
-                       in (files1++files2, txt1++txt2, r2)
-
-
-        getBlock = getLines . dropWhile comment
-        getLines [] = ([],[],[])
-        getLines ((n,l):ls) | "\\begin{code}" `isPrefixOf` l = let (lns,rest) = codelines ls
-                                                               in ([],lns,rest)
-                            | "\\begin{Code}" `isPrefixOf` l = let (lns,rest) = codeLines ls
-                                                               in ([],lns,rest)
-                            | "\\IN{" `isPrefixOf` l        =
-                                     let name = getName l
-                                     in  ([name],[],ls)
-                            | otherwise = getBlock ls
-        comment = not . ("\\" `isPrefixOf`) .snd
-
-toLines     :: String -> [String]
-toLines ""   = []
-toLines s    = let (l,s') = breakLine s
-               in l :  toLines s'
-breakLine xs = case xs of
-                '\CR' : ys -> case ys of
-                                '\LF' : zs -> ([],zs)
-                                _          -> ([],ys)
-                '\LF' : ys -> ([], ys)
-                x     : ys -> let (l,s) = breakLine ys
-                              in (x:l,s)
-                []         -> ([],[])
-
-codelines [] = error "Unterminated literate code block"
-codelines ((n,l):ls) | "\\end{code}" `isPrefixOf` l = ([],ls)
-                     | otherwise                    = let (lns,r) = codelines ls
-                                                      in ((n,l):lns,r)
-
-codeLines [] = error "Unterminated literate Code block"
-codeLines ((n,l):ls) | "\\end{Code}" `isPrefixOf` l = ([],ls)
-                     | otherwise                    = let (lns,r) = codeLines ls
-                                                      in ((n,l):lns,r)
-
-getName l = case r of
-   ('}':_) -> nm
-   _       -> error $ "missing '}' in \\IN"
- where (nm,r) = span (/='}') (drop 4 l)
+{-# LANGUAGE MagicHash, UnboxedTuples, FlexibleInstances #-}+module Scanner where+import GHC.Prim+import TokenDef+import UU.Scanner.Position+import UU.Scanner.Token+import UU.Parsing(InputState(..),Either'(..))+import Data.Maybe+import Data.List+import Data.Char+import UU.Scanner.GenToken+import Options (Options (..))++data Input = Input !Pos String (Maybe (Token, Input))++instance InputState Input Token Pos where+ splitStateE input@(Input _ _ next) =+                case next of+                     Nothing         -> Right' input+                     Just (s, rest)  -> Left' s rest+ splitState (Input _ _ next) =+                case next of+                     Nothing         -> error "splitState on empty input"+                     Just (s, rest)  -> (# s, rest #)+ getPosition (Input pos _ next) =  case next of+                                    Just (s,_) -> position s+                                    Nothing    -> pos -- end of file+++input :: Options -> Pos -> String -> Input+input opts pos inp = Input pos+                      inp+                      (case scan opts pos inp of+                             Nothing      -> Nothing+                             Just (s,p,r) -> Just (s, input opts p r)+                      )++type Lexer s = Pos -> String -> Maybe (s,Pos,String)++scan :: Options -> Lexer Token+scan opts p0+  | column p0 == 1 = scanBeginOfLine p0+  | otherwise      = scan p0+  where+    keywords' = if lcKeywords opts+                then map (map toLower) keywords+                else keywords+    mkKeyword s | s `elem` lowercaseKeywords = s+                | otherwise                  = map toUpper s++    scan :: Lexer Token+    scan p []                        = Nothing+    scan p ('/':'/':xs)+      | clean opts+                                     = let (com,rest) = span (/= '\n') xs+                                       in advc' (2+length com) p scan rest+    scan p ('-':'-':xs) | null xs || not (head xs `elem` "<>!?#@:%$^&")+                                     = let (com,rest) = span (/= '\n') xs+                                       in advc' (2+length com) p scan rest+    scan p ('{':'-':xs)              = advc' 2 p (ncomment scan) xs+    scan p ('/':'*':xs) | clean opts = advc' 2 p (cleancomment scan) xs+    scan p ('{'    :xs)              = advc' 1 p codescrap xs+    scan p ('\CR':xs)                = case xs of+                                        '\LF':ys -> newl' p scanBeginOfLine ys --ms newline+                                        _        -> newl' p scanBeginOfLine xs --mac newline+    scan p ('\LF':xs)                =  newl' p scanBeginOfLine xs             --unix newline+    scan p (x:xs) | isSpace x        = updPos'  x p scan  xs+    scan p xs = Just (scan' xs)+      where 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 2 p, rs)+            scan' ('<' : '=' : rs)   = (reserved "<=" p, advc 2 p, rs)+            scan' ('<' : '<' : '-' : rs) = (reserved "<<-" p, advc 3 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)       = (OBrace      p, advc 1 p, rs)+    --        scan' ('}'    :rs)       = (CBrace      p, advc 1 p, rs)++            scan' ('\"' :rs)         = let isOk c = c /= '"' && c /= '\n'+                                           (str,rest) = span isOk rs+                                       in if null rest || head rest /= '"'+                                              then (errToken "unterminated string literal"   p+                                                   , 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)+            scan' (':':':':rs)       = (reserved "::" p, advc 2 p, rs)+            scan' ('∷':rs)           = (reserved "::" p, advc 1 p, rs)  -- recognize unicode double colons too+            scan' (':' :rs)                           = (reserved ":" p, advc 1 p, rs)+            scan' ('|' :rs)          = (reserved "|" p, advc 1 p, rs)++            scan' ('/':'\\':rs)      = (reserved "/\\" p, advc 2 p, rs)+            scan' ('-':'>' :rs)      = (reserved "->" p, advc 2 p, rs)+            scan' ('-'     :rs)      = (reserved "-" p, advc 1 p, rs)+            scan' ('*'     :rs)      = (reserved "*" p, advc 1 p, rs)++            scan' ('\''    :rs) | ocaml opts =  -- note: ocaml type variables are encoded as 'TkTextnm' tokens+              let (var,rest) = ident opts rs+                  str = '\'' : var+              in (valueToken TkTextnm str p, advc (length str) p, rest)++            scan' (x:rs) | isLower x = let (var,rest) = ident opts rs+                                           str        = (x:var)+                                           tok | str `elem` keywords' = reserved (mkKeyword str)+                                               | otherwise            = valueToken TkVarid str+                                       in (tok p, advc (length var+1) p, rest)+                         | isUpper x = let (var,rest) = ident opts rs+                                           str        = (x:var)+                                           tok | str `elem` keywords' = reserved (mkKeyword str)+                                               | otherwise            = valueToken TkConid str+                                       in (tok p, advc (length var+1) p,rest)+                         | otherwise = (errToken ("unexpected character " ++ show x) p, advc 1 p, rs)++    scanBeginOfLine :: Lexer Token+    scanBeginOfLine p ('{' : '-' : ' ' : 'L' : 'I' : 'N' : 'E' : ' ' : xs)+      | isOkBegin rs && isOkEnd rs'+          = scan (advc (8 + length r + 2 + length s + 4) p') (drop 4 rs')+      | otherwise+          = Just (errToken ("Invalid LINE pragma: " ++ show r) p, advc 8 p, xs)+      where+        (r,rs)   = span isDigit xs+        (s, rs') = span (/= '"') (drop 2 rs)+        p' = Pos (read r - 1) (column p) s    -- LINE pragma indicates the line number of the /next/ line!++        isOkBegin (' ' : '"' : _) = True+        isOkBegin _               = False++        isOkEnd ('"' : ' ' : '-' : '}' : _) = True+        isOkEnd _         = False+    scanBeginOfLine p xs+      = scan p xs+++ident opts = span isValid+ where isValid x = isAlphaNum x || x == '_' ||+                   (not (clean opts) && x == '\'') || (clean opts && x == '`')++lowercaseKeywords = ["loc","lhs", "inst", "optpragmas", "imports", "toplevel", "datablock", "recblock"]+keywords = lowercaseKeywords +++           [ "DATA", "RECORD", "EXT", "ATTR", "SEM","TYPE", "USE", "INCLUDE"+           , "EXTENDS" -- marcos+           , "SET","DERIVING","FOR", "WRAPPER", "NOCATAS", "MAYBE", "EITHER", "MAP", "INTMAP"+           , "PRAGMA", "SEMPRAGMA", "MODULE", "ATTACH", "UNIQUEREF", "INH", "SYN", "CHN"+           , "AUGMENT", "AROUND", "MERGE", "AS", "SELF", "INTSET"+           ]++ncomment c p ('-':'}':xs) = advc' 2 p c  xs+ncomment c p ('{':'-':xs) = advc' 2 p (ncomment (ncomment c)) xs+ncomment c p (x:xs)       = updPos' x p (ncomment c)  xs+ncomment c p []           = Just (errToken "unterminated nested comment" p, p,[])++cleancomment c p ('*':'/':xs) = advc' 2 p c  xs+cleancomment c p ('/':'*':xs) = advc' 2 p (cleancomment (cleancomment c)) xs+cleancomment c p (x:xs)       = updPos' x p (cleancomment c)  xs+cleancomment c p []           = Just (errToken "unterminated nested comment" p, p,[])++codescrap p xs = let (p2,xs2,sc) = codescrap' 1 p xs+                 in case xs2 of+                         ('}':rest) -> Just (valueToken TkTextln sc p,advc 1 p2,rest)+                         _          -> Just (errToken "unterminated codescrap" p,p2,xs2)+++codescrap' d p [] = (p,[],[])+{-+codescrap' d p ('{':'{':xs) = let (p2,xs2,sc) = advc' 2 p (codescrap' d) xs+                              in (p2,xs2,'{':' ':sc)+codescrap' d p ('}':'}':xs) = let (p2,xs2,sc) = advc' 2 p (codescrap' d) xs+                              in (p2,xs2,'}':' ':sc)+-}+codescrap' d p ('{':xs)     = let (p2,xs2,sc) = advc' 1 p (codescrap' (d+1)) xs+                              in (p2,xs2,'{' : sc)+codescrap' d p ('}':xs)     | d == 1 = (p,'}':xs,[])+                            | otherwise = let (p2,xs2,sc) = advc' 1 p (codescrap' (d-1)) xs+                                          in (p2,xs2,'}' : sc)+codescrap' d p (x  :xs)     = let (p2,xs2,sc) = updPos' x p (codescrap' d) xs+                              in (p2,xs2,x:sc)+--Literate Mode+scanLit xs = (fs, foldr insNL (const "") codeLns 1)+  where insNL (n,line) r = \n1 -> replicate (n-n1) '\n' ++ line ++ r n+        (fs,codeLns,_) = getBlocks ([1..] `zip`  toLines xs)+        getBlocks [] = ([],[],[])+        getBlocks xs = let (files1,txt1,r1) = getBlock xs+                           (files2,txt2,r2) = getBlocks r1+                       in (files1++files2, txt1++txt2, r2)+++        getBlock = getLines . dropWhile comment+        getLines [] = ([],[],[])+        getLines ((n,l):ls) | "\\begin{code}" `isPrefixOf` l = let (lns,rest) = codelines ls+                                                               in ([],lns,rest)+                            | "\\begin{Code}" `isPrefixOf` l = let (lns,rest) = codeLines ls+                                                               in ([],lns,rest)+                            | "\\IN{" `isPrefixOf` l        =+                                     let name = getName l+                                     in  ([name],[],ls)+                            | otherwise = getBlock ls+        comment = not . ("\\" `isPrefixOf`) .snd++toLines     :: String -> [String]+toLines ""   = []+toLines s    = let (l,s') = breakLine s+               in l :  toLines s'+breakLine xs = case xs of+                '\CR' : ys -> case ys of+                                '\LF' : zs -> ([],zs)+                                _          -> ([],ys)+                '\LF' : ys -> ([], ys)+                x     : ys -> let (l,s) = breakLine ys+                              in (x:l,s)+                []         -> ([],[])++codelines [] = error "Unterminated literate code block"+codelines ((n,l):ls) | "\\end{code}" `isPrefixOf` l = ([],ls)+                     | otherwise                    = let (lns,r) = codelines ls+                                                      in ((n,l):lns,r)++codeLines [] = error "Unterminated literate Code block"+codeLines ((n,l):ls) | "\\end{Code}" `isPrefixOf` l = ([],ls)+                     | otherwise                    = let (lns,r) = codeLines ls+                                                      in ((n,l):lns,r)++getName l = case r of+   ('}':_) -> nm+   _       -> error $ "missing '}' in \\IN"+ where (nm,r) = span (/='}') (drop 4 l)
src/SequentialComputation.lhs view
@@ -1,391 +1,391 @@-\begin{code}
-module SequentialComputation (computeSequential,Vertex,Edge,Table) where
-import SequentialTypes
-import InterfacesRules
-import CodeSyntax
-import GrammarInfo
-
-import Control.Monad(when,unless)
-import Control.Monad.ST(ST, runST)
-import Data.Array(Array,(!),bounds)
-import Data.Array.ST(STArray, newArray, readArray, writeArray, freeze)
-import Data.Maybe(isJust,fromJust)
-import Data.List(partition,(\\))
-import qualified Data.Set as Set
-import qualified Data.Map as Map
-
-\end{code}
-
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-\section{Collecting information}
-
-In the Data.Graph library,
-a graph is represented as |Array Vertex [Vertex]|,
-mapping each vertex to a list of adjacent vertices.
-A |Vertex| is simply encoded by an |Int|.
-So to test whether an edge |(x,y)| belongs to |g|
-we can evaluate |y `elem` g!x|
-
-For more efficiency, we use Maps instead of lists.
-Sets would also have done, but we also want to each edge to have a path as a witness.
-
-Moreover, as we will mostly be adding edges to the graph,
-we use a mutable array.
-If we want to use any of the library
-functions, we can convert our representation by |fmap Map.keys . freeze|.
-
-\begin{code}
-type Graph     = Array     Vertex [Vertex]
-type MGraph    = Array     Vertex (Map.Map Vertex Path)
-type MMGraph s = STArray s Vertex (Map.Map Vertex Path)
-
-singleStep :: (Vertex->Vertex->PathStep) -> Edge -> EdgePath
-singleStep f e@(s,t) = (e, [f s t])
-
-\end{code}
-
-We can add an edge to a graph, or remove it. These functions return
-whether they did something (resp. addition or removal) or not. hasEdge
-only checks whether a graph contains an edge or not.
-
-\begin{code}
-addEdge :: MMGraph s -> EdgePath -> ST s Bool
-addEdge graph ((s,t),p)
- = do m <- readArray graph s
-      let b = not (Map.member t m)
-      when b (writeArray graph s (Map.insert t p m))
-      return b 
-
-hasEdge :: MMGraph s -> EdgePath -> ST s Bool
-hasEdge graph ((s,t),_)
- = do m <- readArray graph s
-      return (Map.member t m)
-\end{code}
-
-The first step is to assign a number to all attributes, and a
-different one to all attribute occurrences. We create an array mapping
-the numbers to the information about the attribute occurrences
-(|ruleTable|), so we can look up this information in $O(1)$ time. We
-also build mappings from attributes to their occurrences (|tdsToTdp|)
-and vice versa (|tdpToTds|). |LMH| indicates the division of the
-attributes - an element |(l,m,h) `elem` LMH| means that vertices |i, l
-<= i <= h| are attributes of the same nonterminal, with vertices |j, l
-<= j < m| being inherited and |k, m <= k <= h| being synthesized
-attributes.
-
-See the |SequentialTypes.Info| and |SequentialTypes.LMH|
-
-Then we collect the direct dependencies, using the integer
-representations. This list of tuples (edges in the dependency graph)
-all information that is collected is passed to a function that will
-compute the interfaces and visit sub-sequences. We cannot do this
-computation in AG, because mutable arrays require the ST monad, which
-cannot be used inside AG.
-
-Now we can build a graph for attributes, and a graph for ao's, and add
-the direct dependencies to the ao graph. Like Pennings we will call
-the attribte graph Tds (transitive dependencies of symbols), and the
-ao-graph Tdp (transitive dependencies of productions). Unlike him, we
-will have only one Tds and one Tdp graph. In |STGraph|, we can lookup
-outgoing edges in |O(1)| time, but looking up incoming edges will take
-|O(e)| time, where |e| is the number of edges in the graph. As we will
-be doing this quite often it is worthwhile to keep both Tdp and its
-transposed version. The computation will involve both Tds and Tdp. It
-treats specially. TODO elaborate on that.
-
-\begin{code}
-type Tdp s = (MMGraph s, MMGraph s)
-type Tds s = MMGraph s
-type Comp s = (Tds s, Tdp s)
-\end{code}
-
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-\section{Generating IDS}
-
-As we insert edges into Tdp we keep it transitively closed, so every
-time we add the edge $(s,t)$ to V, we also add the edges
-$\{ (r,t) || (r,s) \in V \}$ and
-$\{ (s,u) || (t,u) \in V \}$.
-
-\begin{code}
-insertTdp :: Info -> Comp s -> EdgePath -> ST s ()
-insertTdp info comp@(_,(tdpN,tdpT)) e@((s,t),ee)                -- how to insert an edge (s,t):
-  = do b <- hasEdge tdpN e                                      -- if it's not yet present
-       unless b 
-              (do  rs <- readArray tdpT s                       -- find all sources r for an edge to s
-                   us <- readArray tdpN t                       -- find all targets u for an edge from t
-                   let edges = e :[ ((r,t),er++ee    ) | (r,er) <- Map.toList rs ]
-                               ++ [ ((s,u),    ee++eu) | (u,eu) <- Map.toList us ]
-                               ++ [ ((r,u),er++ee++eu) | (r,er) <- Map.toList rs, (u,eu) <- Map.toList us ]
-                   mapM_ (addTdpEdge info comp) edges           -- and add all of them, without having to bother about transitive closure anymore
-              )
-\end{code}
-
-Edges in |Tdp| can induce edges in |Tds|, so whenever we add
-an edge, we also add the induced edge if necessary
-
-\begin{code}
-addTdpEdge :: Info -> Comp s -> EdgePath -> ST s ()         -- how to add an edge (s,t) when not having to bother about the transitive closure:
-addTdpEdge info comp@(_,(tdpN,tdpT)) e@((s,t),ee)
-  = do b <- addEdge tdpN e                                  -- add it to the normal graph
-       when b                                               -- if it was a new edge
-           (do  addEdge tdpT ((t,s),ee)                     --   also add it to the transposed graph
-                let  u = tdpToTds info ! s                  --   find the corresponding attributes...
-                     v = tdpToTds info ! t
-                     nonlocal = u /= -1 && v /= -1
-                     equalfield = isEqualField (ruleTable info ! s) (ruleTable info ! t)
-                when (nonlocal && equalfield)               -- ...and when necessary...
-                     (insertTds info comp ((u,v),ee))       -- ...insert it to the Tds graph
-           )
-\end{code}
-
-Inserting edges into |Tds| will insert edges between the occurrences
-of the attributes into |Tdp|.
-
-\begin{code}
-insertTds :: Info -> Comp s -> EdgePath -> ST s ()
-insertTds info comp@(tds,_) e@((u,v),ee)
-  =  do b <- addEdge tds e
-        when b
-             (mapM_ (insertTdp info comp) [ ( (s,t), [AttrStep u v] )
-                                          | s <- tdsToTdp info ! u
-                                          , not (getIsIn (ruleTable info ! s))    -- inherited at LHS, or synthesized at RHS
-                                          , t <- tdsToTdp info ! v
-                                          , getIsIn (ruleTable info ! t)          -- synthesized at LHS, or inherited at RHS
-                                          , isEqualField (ruleTable info ! s) (ruleTable info ! t)
-                                          ]
-             )
-
-\end{code}
-
-If we add the direct dependencies to the Tdp graph in the way above, the
-Tds graph is filled with IDS.
-Below is a way to only build up the Tdp graph, without reflect the changes in the Tds graph.
-
-\begin{code}
-simpleInsert :: Tdp s -> EdgePath -> ST s ()
-simpleInsert tdp@(tdpN,tdpT) e@((s,t),ee)
-  = do b <- hasEdge tdpT ((t,s),undefined)
-       unless b (do  rs <- readArray tdpT s
-                     us <- readArray tdpN t
-                     let edges = e :[ ((r,t),er++ee    ) | (r,er) <- Map.toList rs ]
-                                 ++ [ ((s,u),    ee++eu) | (u,eu) <- Map.toList us ]
-                                 ++ [ ((r,u),er++ee++eu) | (r,er) <- Map.toList rs, (u,eu) <- Map.toList us ]
-                     mapM_ (addSimpleEdge tdp) edges
-                )
-
-addSimpleEdge :: Tdp s -> EdgePath -> ST s ()
-addSimpleEdge (tdpN,tdpT) e@((s,t),ee)
-  = do b <- addEdge tdpN e
-       when b (do addEdge tdpT ((t,s),ee)
-                  return ()
-              )
-\end{code}
-
-
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-\section{Interfaces}
-
-In absence of cycles we can find the interfaces. We only take
-attributes that are used.
-
-When an attribute has no incoming edges it can be computed. As the
-emphasis is on incoming edges, we will work with the transposed Tds
-graph. The funtion |used| indicates which vertices are included in the
-interfaces.
-
-See modules Interfaces and InterfacesRules for more information.
-
-%format sem_IRoot_IRoot = "sem_{IRoot}"
-%format sem_Interface_Interface = "sem_{Interface}"
-%format sem_Interfaces_Cons = ":_{Interfaces}"
-%format sem_Interfaces_Nil = "[]_{Interfaces}"
-%format sem_Segments_Cons = ":_{Segments}"
-%format sem_Segments_Nil = "[]_{Segments}"
-
-\begin{code}
-makeInterfaces :: Info -> Graph -> T_IRoot
-makeInterfaces info tds
-  =  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 (nonts info) (lmh info))
-     in sem_IRoot_IRoot inters
-\end{code}
-
-The sinks of a graph are those vertices that have no outgoing
-edges. We define a function that determines whether a vertex is a sink
-if a set |del| of vertices had been removed from the graph. This means
-that the attribute can be computed if all attributes in |del| have
-been computed.
-
-\begin{code}
-isSink :: Graph -> [Vertex] -> Vertex -> Bool
-isSink graph del v = null (graph ! v \\ del)
-\end{code}
-
-Now we can make interfaces by taking inherited sinks and synthesized
-sinks alternatively. If there are no synthesized attributes at all,
-generate an interface with one visit computing nothing.
-
-\begin{code}
-makeInterface :: Graph -> [Vertex] -> LMH -> [([Vertex],[Vertex])]
-makeInterface tds del (l,m,h)
-  | m > h = [([],[])]
-  | otherwise = let  syn = filter (isSink tds del) ([m..h] \\ del)
-                     del' = del ++ syn
-                     inh = filter (isSink tds del') ([l..(m-1)] \\ del')
-                     del'' = del' ++ inh
-                     rest = makeInterface tds del'' (l,m,h)
-                in if  null inh && null syn
-                       then []
-                       else (inh,syn) : rest
-\end{code}
-
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-\section{Detecting of cycles}
-
-We only want to return s2i edges.
-
-\begin{code}
-findCycles :: Info -> MGraph -> [EdgePaths]
-findCycles info tds
-  = [ ((u,v),p1,p2)
-    | (l,m,h) <- lmh info                    -- for every nonterminal: [l..m-1] are inherited, [m..h] are synthesized
-    , v <- [m..h]                            -- for every synthesized attribute
-    , (u,p1) <- Map.toList (tds ! v)         -- find dependent attributes...
-    , l <= u, u < m                          -- ...that are inherited...
-    , let mbp2 = Map.lookup v (tds ! u)      -- ...and have a cycle back
-    , isJust mbp2
-    , let p2 = fromJust mbp2
-    ]
-
-findLocCycles :: MGraph -> [EdgePath]
-findLocCycles tdp
-  = let (low, high) = bounds tdp
-    in  [ ((u,u),p)
-        | u <- [low..high]
-        , (v,p) <- Map.toList (tdp ! u)
-        , v==u
-        ]
-
-findInstCycles :: [Edge] -> MGraph -> [EdgePath]
-findInstCycles instToSynEdges tdp
-  = [ ((i,s), fromJust mbp)
-    | (i, s) <- instToSynEdges
-    , let mbp = Map.lookup i (tdp ! s)
-    , isJust mbp
-    ]
-\end{code}
-
-
-
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-\section{Tying it together}
-
-\begin{code}
-generateVisits :: Info -> MGraph -> MGraph -> [Edge] -> (CInterfaceMap, CVisitsMap, [Edge])
-generateVisits info tds tdp dpr
-  = let  inters = makeInterfaces info (fmap Map.keys tds)
-         inhs = Inh_IRoot{ info_Inh_IRoot = info
-                         , tdp_Inh_IRoot  = fmap Map.keys tdp
-                         , dpr_Inh_IRoot  = dpr
-                         }
-         iroot = wrap_IRoot inters inhs
-    in (inters_Syn_IRoot iroot, visits_Syn_IRoot iroot, edp_Syn_IRoot iroot)
-
-reportLocalCycle :: MGraph -> [EdgePath] -> [[Vertex]]
-reportLocalCycle tds cyc
-  = fst (foldr f ([],Set.empty) (map (edgePathToEdgeRoute tds) cyc))
-    where f ((x,_),p) res@(paths,syms) | Set.member x syms = res    -- don't report a cyclic vertex if it appears on a path of an earlier reported one
-                                       | otherwise         = (p:paths, Set.union syms (Set.fromList p))
-
-reportCycle :: Info -> MGraph -> [EdgePaths] -> [EdgeRoutes]
-reportCycle info tds cyc
-  = fst (foldr f ([],Set.empty) (map (edgePathsToEdgeRoutes tds) cyc))
-    where f epp@((x,y),p1,p2) res@(paths,syms) | Set.member x syms && 
-                                                 Set.member y syms    = res    -- don't report mutually dependent vertices if both appear on paths reported earlier
-                                               | otherwise            = (epp:paths, Set.union syms (Set.fromList (map tdp2tds (p1++p2))))
-          tdp2tds (-2) = -2
-          tdp2tds v = tdpToTds info ! v
-
-edgePathsToEdgeRoutes :: MGraph -> EdgePaths -> EdgeRoutes
-edgePathsToEdgeRoutes tds (e,p1,p2) = ( e, pathToRoute tds p1, pathToRoute tds p2 )
-
-edgePathToEdgeRoute :: MGraph -> EdgePath -> EdgeRoute
-edgePathToEdgeRoute tds (e,p) = ( e, pathToRoute tds p )
-
-pathToRoute :: MGraph -> Path -> Route
-pathToRoute tds p = convertPath (expandAll p)
- where expandAll :: Path -> Path
-       expandAll p | hasAttrStep p  = expandAll (expandOne p)
-                   | otherwise      = p
-       expandOne :: Path -> Path
-       expandOne p = shortcut (concatMap expandStep p)
-       expandStep :: PathStep -> Path
-       expandStep (AttrStep u v) = fromJust (Map.lookup v (tds!u))
-       expandStep x              = [x]
-       convertPath :: Path -> Route
-       convertPath p = concatMap convertStep p
-       convertStep :: PathStep -> Route
-       convertStep (AtOcStep s t) = [s,t]
-       convertStep (AttrIndu s t) = [-2,-2]
-
-hasAttrStep :: Path -> Bool
-hasAttrStep []                  = False
-hasAttrStep (AttrStep _ _ : _ ) = True
-hasAttrStep (_            : xs) = hasAttrStep xs     
-
-shortcut :: Eq a => [a] -> [a]
-shortcut []     = []
-shortcut (x:xs) = x : shortcut (removeBefore x xs)
-
-removeBefore :: Eq a => a -> [a] -> [a]
-removeBefore x ys = reverse (takeWhile (/=x) (reverse ys))
-
-
-isLocLoc :: Table CRule -> EdgePath -> Bool
-isLocLoc rt ((s,t),_) = isLocal (rt ! s) && isLocal (rt ! t)
-                        --  || (isInst (rt ! s) && isInst (rt ! t))
-
-computeSequential :: Info -> [Edge] -> [Edge] -> CycleStatus
-computeSequential info dpr instToSynEdges
-  = runST
-    (do let bigBounds   = bounds (tdpToTds info)
-            smallBounds = bounds (tdsToTdp info)
-            (ll,es) = partition (isLocLoc (ruleTable info)) (map (singleStep AtOcStep) (dpr ++ instToSynEdges))
-        tds  <- newArray smallBounds Map.empty
-        tdpN <- newArray bigBounds   Map.empty
-        tdpT <- newArray bigBounds   Map.empty
-        let tdp = (tdpN,tdpT)
-            comp = (tds,tdp)
-        mapM_ (simpleInsert tdp) ll                                                        -- insert the local dependencies
-        tdp1 <- freeze tdpN
-        let cyc1 = findLocCycles tdp1
-        if  not (null cyc1)                                                                -- are they cyclic?
-            then do return (LocalCycle (reportLocalCycle undefined cyc1))                  -- then report an error.
-            else do  mapM_ (insertTdp info comp) es                                        -- insert the other dependencies
-                     tds2 <- freeze tds
-                     let cyc2 = findCycles info tds2
-                     if  not (null cyc2)                                                   -- are they cyclic?
-                         then do  return (DirectCycle (reportCycle info tds2 cyc2))        -- then report an error.
-                         else do  tdp2 <- freeze tdpN
-                                  let cyc4 = findInstCycles instToSynEdges tdp2
-                                  if  not (null cyc4)
-                                      then do return (InstCycle (reportLocalCycle tds2 cyc4))              -- then report an error.
-                                      else do let  (cim,cvm,edp) = generateVisits info tds2 tdp2 dpr
-                                              mapM_ (insertTds info comp) (map (singleStep AttrIndu) edp) -- insert dependencies induced by visit scheduling
-                                              tds3 <- freeze tds
-                                              let cyc3 = findCycles info tds3
-                                              if  not (null cyc3)                                      -- are they cyclic?
-                                                  then return (InducedCycle cim (reportCycle info tds3 cyc3)) -- then report an error.
-                                                  else do tdp3 <- freeze tdpN
-                                                          let cyc5 = findInstCycles instToSynEdges tdp3
-                                                          if  not (null cyc5)
-                                                              then do return (InstCycle (reportLocalCycle tds3 cyc5))     -- then report an error.
-                                                              else do return (CycleFree cim cvm)                      -- otherwise we succeed.
-    )
-\end{code}
-
-
-\end{document}
+\begin{code}+module SequentialComputation (computeSequential,Vertex,Edge,Table) where+import SequentialTypes+import InterfacesRules+import CodeSyntax+import GrammarInfo++import Control.Monad(when,unless)+import Control.Monad.ST(ST, runST)+import Data.Array(Array,(!),bounds)+import Data.Array.ST(STArray, newArray, readArray, writeArray, freeze)+import Data.Maybe(isJust,fromJust)+import Data.List(partition,(\\))+import qualified Data.Set as Set+import qualified Data.Map as Map++\end{code}++%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+\section{Collecting information}++In the Data.Graph library,+a graph is represented as |Array Vertex [Vertex]|,+mapping each vertex to a list of adjacent vertices.+A |Vertex| is simply encoded by an |Int|.+So to test whether an edge |(x,y)| belongs to |g|+we can evaluate |y `elem` g!x|++For more efficiency, we use Maps instead of lists.+Sets would also have done, but we also want to each edge to have a path as a witness.++Moreover, as we will mostly be adding edges to the graph,+we use a mutable array.+If we want to use any of the library+functions, we can convert our representation by |fmap Map.keys . freeze|.++\begin{code}+type Graph     = Array     Vertex [Vertex]+type MGraph    = Array     Vertex (Map.Map Vertex Path)+type MMGraph s = STArray s Vertex (Map.Map Vertex Path)++singleStep :: (Vertex->Vertex->PathStep) -> Edge -> EdgePath+singleStep f e@(s,t) = (e, [f s t])++\end{code}++We can add an edge to a graph, or remove it. These functions return+whether they did something (resp. addition or removal) or not. hasEdge+only checks whether a graph contains an edge or not.++\begin{code}+addEdge :: MMGraph s -> EdgePath -> ST s Bool+addEdge graph ((s,t),p)+ = do m <- readArray graph s+      let b = not (Map.member t m)+      when b (writeArray graph s (Map.insert t p m))+      return b ++hasEdge :: MMGraph s -> EdgePath -> ST s Bool+hasEdge graph ((s,t),_)+ = do m <- readArray graph s+      return (Map.member t m)+\end{code}++The first step is to assign a number to all attributes, and a+different one to all attribute occurrences. We create an array mapping+the numbers to the information about the attribute occurrences+(|ruleTable|), so we can look up this information in $O(1)$ time. We+also build mappings from attributes to their occurrences (|tdsToTdp|)+and vice versa (|tdpToTds|). |LMH| indicates the division of the+attributes - an element |(l,m,h) `elem` LMH| means that vertices |i, l+<= i <= h| are attributes of the same nonterminal, with vertices |j, l+<= j < m| being inherited and |k, m <= k <= h| being synthesized+attributes.++See the |SequentialTypes.Info| and |SequentialTypes.LMH|++Then we collect the direct dependencies, using the integer+representations. This list of tuples (edges in the dependency graph)+all information that is collected is passed to a function that will+compute the interfaces and visit sub-sequences. We cannot do this+computation in AG, because mutable arrays require the ST monad, which+cannot be used inside AG.++Now we can build a graph for attributes, and a graph for ao's, and add+the direct dependencies to the ao graph. Like Pennings we will call+the attribte graph Tds (transitive dependencies of symbols), and the+ao-graph Tdp (transitive dependencies of productions). Unlike him, we+will have only one Tds and one Tdp graph. In |STGraph|, we can lookup+outgoing edges in |O(1)| time, but looking up incoming edges will take+|O(e)| time, where |e| is the number of edges in the graph. As we will+be doing this quite often it is worthwhile to keep both Tdp and its+transposed version. The computation will involve both Tds and Tdp. It+treats specially. TODO elaborate on that.++\begin{code}+type Tdp s = (MMGraph s, MMGraph s)+type Tds s = MMGraph s+type Comp s = (Tds s, Tdp s)+\end{code}++%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+\section{Generating IDS}++As we insert edges into Tdp we keep it transitively closed, so every+time we add the edge $(s,t)$ to V, we also add the edges+$\{ (r,t) || (r,s) \in V \}$ and+$\{ (s,u) || (t,u) \in V \}$.++\begin{code}+insertTdp :: Info -> Comp s -> EdgePath -> ST s ()+insertTdp info comp@(_,(tdpN,tdpT)) e@((s,t),ee)                -- how to insert an edge (s,t):+  = do b <- hasEdge tdpN e                                      -- if it's not yet present+       unless b +              (do  rs <- readArray tdpT s                       -- find all sources r for an edge to s+                   us <- readArray tdpN t                       -- find all targets u for an edge from t+                   let edges = e :[ ((r,t),er++ee    ) | (r,er) <- Map.toList rs ]+                               ++ [ ((s,u),    ee++eu) | (u,eu) <- Map.toList us ]+                               ++ [ ((r,u),er++ee++eu) | (r,er) <- Map.toList rs, (u,eu) <- Map.toList us ]+                   mapM_ (addTdpEdge info comp) edges           -- and add all of them, without having to bother about transitive closure anymore+              )+\end{code}++Edges in |Tdp| can induce edges in |Tds|, so whenever we add+an edge, we also add the induced edge if necessary++\begin{code}+addTdpEdge :: Info -> Comp s -> EdgePath -> ST s ()         -- how to add an edge (s,t) when not having to bother about the transitive closure:+addTdpEdge info comp@(_,(tdpN,tdpT)) e@((s,t),ee)+  = do b <- addEdge tdpN e                                  -- add it to the normal graph+       when b                                               -- if it was a new edge+           (do  addEdge tdpT ((t,s),ee)                     --   also add it to the transposed graph+                let  u = tdpToTds info ! s                  --   find the corresponding attributes...+                     v = tdpToTds info ! t+                     nonlocal = u /= -1 && v /= -1+                     equalfield = isEqualField (ruleTable info ! s) (ruleTable info ! t)+                when (nonlocal && equalfield)               -- ...and when necessary...+                     (insertTds info comp ((u,v),ee))       -- ...insert it to the Tds graph+           )+\end{code}++Inserting edges into |Tds| will insert edges between the occurrences+of the attributes into |Tdp|.++\begin{code}+insertTds :: Info -> Comp s -> EdgePath -> ST s ()+insertTds info comp@(tds,_) e@((u,v),ee)+  =  do b <- addEdge tds e+        when b+             (mapM_ (insertTdp info comp) [ ( (s,t), [AttrStep u v] )+                                          | s <- tdsToTdp info ! u+                                          , not (getIsIn (ruleTable info ! s))    -- inherited at LHS, or synthesized at RHS+                                          , t <- tdsToTdp info ! v+                                          , getIsIn (ruleTable info ! t)          -- synthesized at LHS, or inherited at RHS+                                          , isEqualField (ruleTable info ! s) (ruleTable info ! t)+                                          ]+             )++\end{code}++If we add the direct dependencies to the Tdp graph in the way above, the+Tds graph is filled with IDS.+Below is a way to only build up the Tdp graph, without reflect the changes in the Tds graph.++\begin{code}+simpleInsert :: Tdp s -> EdgePath -> ST s ()+simpleInsert tdp@(tdpN,tdpT) e@((s,t),ee)+  = do b <- hasEdge tdpT ((t,s),undefined)+       unless b (do  rs <- readArray tdpT s+                     us <- readArray tdpN t+                     let edges = e :[ ((r,t),er++ee    ) | (r,er) <- Map.toList rs ]+                                 ++ [ ((s,u),    ee++eu) | (u,eu) <- Map.toList us ]+                                 ++ [ ((r,u),er++ee++eu) | (r,er) <- Map.toList rs, (u,eu) <- Map.toList us ]+                     mapM_ (addSimpleEdge tdp) edges+                )++addSimpleEdge :: Tdp s -> EdgePath -> ST s ()+addSimpleEdge (tdpN,tdpT) e@((s,t),ee)+  = do b <- addEdge tdpN e+       when b (do addEdge tdpT ((t,s),ee)+                  return ()+              )+\end{code}+++%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+\section{Interfaces}++In absence of cycles we can find the interfaces. We only take+attributes that are used.++When an attribute has no incoming edges it can be computed. As the+emphasis is on incoming edges, we will work with the transposed Tds+graph. The funtion |used| indicates which vertices are included in the+interfaces.++See modules Interfaces and InterfacesRules for more information.++%format sem_IRoot_IRoot = "sem_{IRoot}"+%format sem_Interface_Interface = "sem_{Interface}"+%format sem_Interfaces_Cons = ":_{Interfaces}"+%format sem_Interfaces_Nil = "[]_{Interfaces}"+%format sem_Segments_Cons = ":_{Segments}"+%format sem_Segments_Nil = "[]_{Segments}"++\begin{code}+makeInterfaces :: Info -> Graph -> T_IRoot+makeInterfaces info tds+  =  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 (nonts info) (lmh info))+     in sem_IRoot_IRoot inters+\end{code}++The sinks of a graph are those vertices that have no outgoing+edges. We define a function that determines whether a vertex is a sink+if a set |del| of vertices had been removed from the graph. This means+that the attribute can be computed if all attributes in |del| have+been computed.++\begin{code}+isSink :: Graph -> [Vertex] -> Vertex -> Bool+isSink graph del v = null (graph ! v \\ del)+\end{code}++Now we can make interfaces by taking inherited sinks and synthesized+sinks alternatively. If there are no synthesized attributes at all,+generate an interface with one visit computing nothing.++\begin{code}+makeInterface :: Graph -> [Vertex] -> LMH -> [([Vertex],[Vertex])]+makeInterface tds del (l,m,h)+  | m > h = [([],[])]+  | otherwise = let  syn = filter (isSink tds del) ([m..h] \\ del)+                     del' = del ++ syn+                     inh = filter (isSink tds del') ([l..(m-1)] \\ del')+                     del'' = del' ++ inh+                     rest = makeInterface tds del'' (l,m,h)+                in if  null inh && null syn+                       then []+                       else (inh,syn) : rest+\end{code}++%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+\section{Detecting of cycles}++We only want to return s2i edges.++\begin{code}+findCycles :: Info -> MGraph -> [EdgePaths]+findCycles info tds+  = [ ((u,v),p1,p2)+    | (l,m,h) <- lmh info                    -- for every nonterminal: [l..m-1] are inherited, [m..h] are synthesized+    , v <- [m..h]                            -- for every synthesized attribute+    , (u,p1) <- Map.toList (tds ! v)         -- find dependent attributes...+    , l <= u, u < m                          -- ...that are inherited...+    , let mbp2 = Map.lookup v (tds ! u)      -- ...and have a cycle back+    , isJust mbp2+    , let p2 = fromJust mbp2+    ]++findLocCycles :: MGraph -> [EdgePath]+findLocCycles tdp+  = let (low, high) = bounds tdp+    in  [ ((u,u),p)+        | u <- [low..high]+        , (v,p) <- Map.toList (tdp ! u)+        , v==u+        ]++findInstCycles :: [Edge] -> MGraph -> [EdgePath]+findInstCycles instToSynEdges tdp+  = [ ((i,s), fromJust mbp)+    | (i, s) <- instToSynEdges+    , let mbp = Map.lookup i (tdp ! s)+    , isJust mbp+    ]+\end{code}++++%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+\section{Tying it together}++\begin{code}+generateVisits :: Info -> MGraph -> MGraph -> [Edge] -> (CInterfaceMap, CVisitsMap, [Edge])+generateVisits info tds tdp dpr+  = let  inters = makeInterfaces info (fmap Map.keys tds)+         inhs = Inh_IRoot{ info_Inh_IRoot = info+                         , tdp_Inh_IRoot  = fmap Map.keys tdp+                         , dpr_Inh_IRoot  = dpr+                         }+         iroot = wrap_IRoot inters inhs+    in (inters_Syn_IRoot iroot, visits_Syn_IRoot iroot, edp_Syn_IRoot iroot)++reportLocalCycle :: MGraph -> [EdgePath] -> [[Vertex]]+reportLocalCycle tds cyc+  = fst (foldr f ([],Set.empty) (map (edgePathToEdgeRoute tds) cyc))+    where f ((x,_),p) res@(paths,syms) | Set.member x syms = res    -- don't report a cyclic vertex if it appears on a path of an earlier reported one+                                       | otherwise         = (p:paths, Set.union syms (Set.fromList p))++reportCycle :: Info -> MGraph -> [EdgePaths] -> [EdgeRoutes]+reportCycle info tds cyc+  = fst (foldr f ([],Set.empty) (map (edgePathsToEdgeRoutes tds) cyc))+    where f epp@((x,y),p1,p2) res@(paths,syms) | Set.member x syms && +                                                 Set.member y syms    = res    -- don't report mutually dependent vertices if both appear on paths reported earlier+                                               | otherwise            = (epp:paths, Set.union syms (Set.fromList (map tdp2tds (p1++p2))))+          tdp2tds (-2) = -2+          tdp2tds v = tdpToTds info ! v++edgePathsToEdgeRoutes :: MGraph -> EdgePaths -> EdgeRoutes+edgePathsToEdgeRoutes tds (e,p1,p2) = ( e, pathToRoute tds p1, pathToRoute tds p2 )++edgePathToEdgeRoute :: MGraph -> EdgePath -> EdgeRoute+edgePathToEdgeRoute tds (e,p) = ( e, pathToRoute tds p )++pathToRoute :: MGraph -> Path -> Route+pathToRoute tds p = convertPath (expandAll p)+ where expandAll :: Path -> Path+       expandAll p | hasAttrStep p  = expandAll (expandOne p)+                   | otherwise      = p+       expandOne :: Path -> Path+       expandOne p = shortcut (concatMap expandStep p)+       expandStep :: PathStep -> Path+       expandStep (AttrStep u v) = fromJust (Map.lookup v (tds!u))+       expandStep x              = [x]+       convertPath :: Path -> Route+       convertPath p = concatMap convertStep p+       convertStep :: PathStep -> Route+       convertStep (AtOcStep s t) = [s,t]+       convertStep (AttrIndu s t) = [-2,-2]++hasAttrStep :: Path -> Bool+hasAttrStep []                  = False+hasAttrStep (AttrStep _ _ : _ ) = True+hasAttrStep (_            : xs) = hasAttrStep xs     ++shortcut :: Eq a => [a] -> [a]+shortcut []     = []+shortcut (x:xs) = x : shortcut (removeBefore x xs)++removeBefore :: Eq a => a -> [a] -> [a]+removeBefore x ys = reverse (takeWhile (/=x) (reverse ys))+++isLocLoc :: Table CRule -> EdgePath -> Bool+isLocLoc rt ((s,t),_) = isLocal (rt ! s) && isLocal (rt ! t)+                        --  || (isInst (rt ! s) && isInst (rt ! t))++computeSequential :: Info -> [Edge] -> [Edge] -> CycleStatus+computeSequential info dpr instToSynEdges+  = runST+    (do let bigBounds   = bounds (tdpToTds info)+            smallBounds = bounds (tdsToTdp info)+            (ll,es) = partition (isLocLoc (ruleTable info)) (map (singleStep AtOcStep) (dpr ++ instToSynEdges))+        tds  <- newArray smallBounds Map.empty+        tdpN <- newArray bigBounds   Map.empty+        tdpT <- newArray bigBounds   Map.empty+        let tdp = (tdpN,tdpT)+            comp = (tds,tdp)+        mapM_ (simpleInsert tdp) ll                                                        -- insert the local dependencies+        tdp1 <- freeze tdpN+        let cyc1 = findLocCycles tdp1+        if  not (null cyc1)                                                                -- are they cyclic?+            then do return (LocalCycle (reportLocalCycle undefined cyc1))                  -- then report an error.+            else do  mapM_ (insertTdp info comp) es                                        -- insert the other dependencies+                     tds2 <- freeze tds+                     let cyc2 = findCycles info tds2+                     if  not (null cyc2)                                                   -- are they cyclic?+                         then do  return (DirectCycle (reportCycle info tds2 cyc2))        -- then report an error.+                         else do  tdp2 <- freeze tdpN+                                  let cyc4 = findInstCycles instToSynEdges tdp2+                                  if  not (null cyc4)+                                      then do return (InstCycle (reportLocalCycle tds2 cyc4))              -- then report an error.+                                      else do let  (cim,cvm,edp) = generateVisits info tds2 tdp2 dpr+                                              mapM_ (insertTds info comp) (map (singleStep AttrIndu) edp) -- insert dependencies induced by visit scheduling+                                              tds3 <- freeze tds+                                              let cyc3 = findCycles info tds3+                                              if  not (null cyc3)                                      -- are they cyclic?+                                                  then return (InducedCycle cim (reportCycle info tds3 cyc3)) -- then report an error.+                                                  else do tdp3 <- freeze tdpN+                                                          let cyc5 = findInstCycles instToSynEdges tdp3+                                                          if  not (null cyc5)+                                                              then do return (InstCycle (reportLocalCycle tds3 cyc5))     -- then report an error.+                                                              else do return (CycleFree cim cvm)                      -- otherwise we succeed.+    )+\end{code}+++\end{document}
src/SequentialTypes.hs view
@@ -1,164 +1,164 @@-module SequentialTypes where
-
-import CodeSyntax
-import CommonTypes
-import Data.Array(Array)
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Data.Set (Set)
-import qualified Data.Set as Set
-import Data.Maybe(fromJust)
-import Data.List(partition)
-
-type Vertex    = Int
-data PathStep  = AttrStep Vertex Vertex
-               | AtOcStep Vertex Vertex
-               | AttrIndu Vertex Vertex
-               deriving (Show, Eq)
-               
-type Path      = [PathStep]
-type Route     = [Vertex]
-            
-type Edge      = (Int,Int)
-type EdgePath  = (Edge,Path)
-type EdgePaths = (Edge,Path,Path)
-type EdgeRoute = (Edge,Route)
-type EdgeRoutes= (Edge,Route,Route)
-
-type Table a   = Array     Vertex a
-
-
-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 :: NTAttr -> (Identifier, Type)
-getNtaNameType (NTAInh _ name tp) = (name,tp)
-getNtaNameType (NTASyn _ name tp) = (name,tp)
-
-getAttr :: CRule -> Identifier
-getAttr     (CRule name _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) = name
-getAttr     _ = error "Only defined for CRule"
-getIsIn :: CRule -> Bool
-getIsIn     (CRule _ ii _ _ _ _ _ _ _ _ _ _ _ _ _ _) = ii
-getIsIn     _ = error "Only defined for CRule"
-getHasCode :: CRule -> Bool
-getHasCode  (CRule _ _ hc _ _ _ _ _ _ _ _ _ _ _ _ _) = hc
-getHasCode  _ = error "Only defined for CRule"
-getLhsNt :: CRule -> NontermIdent
-getLhsNt    (CRule _ _ _ nt _ _ _ _ _ _ _ _ _ _ _ _) = nt
-getLhsNt    _ = error "Only defined for CRule"
-getCon :: CRule -> ConstructorIdent
-getCon      (CRule _ _ _ _ con _ _ _ _ _ _ _ _ _ _ _) = con
-getCon      _ = error "Only defined for CRule"
-getField :: CRule -> Identifier
-getField    (CRule _ _ _ _ _ field _ _ _ _ _ _ _ _ _ _) = field
-getField    _ = error "Only defined for CRule"
-getRhsNt :: CRule -> Maybe NontermIdent
-getRhsNt    (CRule _ _ _ _ _ _ childnt _ _ _ _ _ _ _ _ _) = childnt
-getRhsNt    _ = error "Only defined for CRule"
-getType :: CRule -> Maybe Type
-getType     (CRule _ _ _ _ _ _ _ tp _ _ _ _ _ _ _ _) = tp
-getType     _ = error "Only defined for CRule"
-getDefines :: CRule -> Map Int (Identifier, Identifier, Maybe Type)
-getDefines  (CRule _ _ _ _ _ _ _ _ _ _ defines _ _ _ _ _) = defines
-getDefines  _ = error "Only defined for CRule"
-getUses :: CRule -> Set (Identifier, Identifier)
-getUses     (CRule _ _ _ _ _ _ _ _ _ _ _ _ _ uses _ _) = uses
-getUses     _ = error "Only defined for CRule"
-getExplicit :: CRule -> Bool
-getExplicit (CRule _ _ _ _ _ _ _ _ _ _ _ _ _ _ expl _) = expl
-getExplicit _ = error "Only defined for CRule"
-
-isLocal, isInst, isLhs, isRhs, isSyn, isInh, hasCode :: CRule -> Bool
-isLocal = (_LOC==) . getField
-isInst = (_INST==) . getField
-isLhs = (_LHS==) . getField
-isRhs cr = not (isLhs cr || isLocal cr)
-isSyn cr | isLocal cr  = False
-         | getIsIn cr  = isRhs cr
-         | otherwise   = isLhs cr
-isInh = not . isSyn
-hasCode cr = isLocal cr || (isLhs cr && isInh cr) || (isRhs cr && isSyn cr)
-
-isEqualField, isDifferentField, isEqualCon, isRhsOfSameCon :: CRule -> CRule -> Bool
-isEqualField      a b = isEqualCon a b && getField a == getField b
-isDifferentField  a b = isEqualCon a b && getField a /= getField b 
-isEqualCon        a b = getLhsNt a == getLhsNt b && getCon a == getCon b
-isRhsOfSameCon    a b = isEqualCon a b && isRhs a && isRhs b
-
-isSynAttr, isInhAttr :: NTAttr -> Bool
-isSynAttr (NTAInh _ _ _) = False
-isSynAttr (NTASyn _ _ _) = True
-isInhAttr = not . isSynAttr
-
-ntattr :: CRule -> Maybe NTAttr
-ntattr cr  | isLocal cr =  Nothing
-           | isInst  cr =  Nothing -- an inst definition is just considered as a local attribute definition
-           | otherwise  =  let  at = if isSyn cr then NTASyn else NTAInh
-                                getNt cr' = if isRhs cr' then fromJust (getRhsNt cr') else getLhsNt cr'
-                           in Just (at (getNt cr) (getAttr cr) (fromJust (getType cr)))
-
-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 False Nothing
-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 False Nothing
-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 False Nothing
-
-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) False Nothing
-                                 where er :: Int -> a
-                                       er i = error ("Default rule has no code " ++ show i)
-
-instance Eq CRule where
-  a == b = getAttr a == getAttr b && isEqualField a b
-instance Ord CRule where
-  compare a b =  compare (getLhsNt a) (getLhsNt b) 
-                 >/< compare (getCon a) (getCon b)
-                 >/< compare (getField a) (getField b)
-                 >/< compare (getAttr a) (getAttr b)
-instance Eq NTAttr where
-  (NTAInh _ _ _) == (NTASyn _ _ _) = False
-  (NTASyn _ _ _) == (NTAInh _ _ _) = False
-  (NTAInh nt name _) == (NTAInh nt' name' _) = nt == nt' && name == name'
-  (NTASyn nt name _) == (NTASyn nt' name' _) = nt == nt' && name == name'
-instance Ord NTAttr where
-  compare (NTAInh _ _ _) (NTASyn _ _ _) = LT
-  compare (NTASyn _ _ _) (NTAInh _ _ _) = GT
-  compare (NTAInh nt name _) (NTAInh nt' name' _) = compare nt nt' >/< compare name name'
-  compare (NTASyn nt name _) (NTASyn nt' name' _) = compare nt nt' >/< compare name name'
-
-eqCRuleDefines :: CRule -> CRule -> Bool
-eqCRuleDefines a b
-  = Map.keys (getDefines a) == Map.keys (getDefines b)
-
-(>/<) :: Ordering -> Ordering -> Ordering
-EQ >/< b = b
-a >/< _ = a
-
-
-eqClasses :: (a -> a -> Bool) -> [a] -> [[a]]
-eqClasses _ [] = []
-eqClasses p (a:as) = let (isA,rest) = partition (p a) as
-                     in (a:isA):eqClasses p rest
-
-lhsshow :: Options -> NTAttr -> String
-lhsshow opts (NTAInh _ attr _) = lhsname opts True attr
-lhsshow opts (NTASyn _ attr _) = lhsname opts False attr 
-
-rhsshow :: Options -> Identifier -> NTAttr -> String
-rhsshow opts field (NTAInh _ attr _) = attrname opts False field attr
-rhsshow opts field (NTASyn _ attr _) = attrname opts True field attr 
-
-prettyCRule :: CRule -> String
-prettyCRule cr 
-   =  let descr | isLocal cr = "local attribute " ++ show (getAttr cr)
-                | otherwise =     (if isSyn cr then "synthesized " else "inherited ")
-                               ++ "attribute "
-                               ++ (if isRhs cr then show (getField cr) ++ "." else "")
-                               ++ (if isLhs cr then "lhs." else "")
-                               ++ (show (getAttr cr))
-      in show (getLhsNt cr) ++ "." ++ show (getCon cr) ++ ", " ++ descr
-
+module SequentialTypes where++import CodeSyntax+import CommonTypes+import Data.Array(Array)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Maybe(fromJust)+import Data.List(partition)++type Vertex    = Int+data PathStep  = AttrStep Vertex Vertex+               | AtOcStep Vertex Vertex+               | AttrIndu Vertex Vertex+               deriving (Show, Eq)+               +type Path      = [PathStep]+type Route     = [Vertex]+            +type Edge      = (Int,Int)+type EdgePath  = (Edge,Path)+type EdgePaths = (Edge,Path,Path)+type EdgeRoute = (Edge,Route)+type EdgeRoutes= (Edge,Route,Route)++type Table a   = Array     Vertex a+++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 :: NTAttr -> (Identifier, Type)+getNtaNameType (NTAInh _ name tp) = (name,tp)+getNtaNameType (NTASyn _ name tp) = (name,tp)++getAttr :: CRule -> Identifier+getAttr     (CRule name _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) = name+getAttr     _ = error "Only defined for CRule"+getIsIn :: CRule -> Bool+getIsIn     (CRule _ ii _ _ _ _ _ _ _ _ _ _ _ _ _ _) = ii+getIsIn     _ = error "Only defined for CRule"+getHasCode :: CRule -> Bool+getHasCode  (CRule _ _ hc _ _ _ _ _ _ _ _ _ _ _ _ _) = hc+getHasCode  _ = error "Only defined for CRule"+getLhsNt :: CRule -> NontermIdent+getLhsNt    (CRule _ _ _ nt _ _ _ _ _ _ _ _ _ _ _ _) = nt+getLhsNt    _ = error "Only defined for CRule"+getCon :: CRule -> ConstructorIdent+getCon      (CRule _ _ _ _ con _ _ _ _ _ _ _ _ _ _ _) = con+getCon      _ = error "Only defined for CRule"+getField :: CRule -> Identifier+getField    (CRule _ _ _ _ _ field _ _ _ _ _ _ _ _ _ _) = field+getField    _ = error "Only defined for CRule"+getRhsNt :: CRule -> Maybe NontermIdent+getRhsNt    (CRule _ _ _ _ _ _ childnt _ _ _ _ _ _ _ _ _) = childnt+getRhsNt    _ = error "Only defined for CRule"+getType :: CRule -> Maybe Type+getType     (CRule _ _ _ _ _ _ _ tp _ _ _ _ _ _ _ _) = tp+getType     _ = error "Only defined for CRule"+getDefines :: CRule -> Map Int (Identifier, Identifier, Maybe Type)+getDefines  (CRule _ _ _ _ _ _ _ _ _ _ defines _ _ _ _ _) = defines+getDefines  _ = error "Only defined for CRule"+getUses :: CRule -> Set (Identifier, Identifier)+getUses     (CRule _ _ _ _ _ _ _ _ _ _ _ _ _ uses _ _) = uses+getUses     _ = error "Only defined for CRule"+getExplicit :: CRule -> Bool+getExplicit (CRule _ _ _ _ _ _ _ _ _ _ _ _ _ _ expl _) = expl+getExplicit _ = error "Only defined for CRule"++isLocal, isInst, isLhs, isRhs, isSyn, isInh, hasCode :: CRule -> Bool+isLocal = (_LOC==) . getField+isInst = (_INST==) . getField+isLhs = (_LHS==) . getField+isRhs cr = not (isLhs cr || isLocal cr)+isSyn cr | isLocal cr  = False+         | getIsIn cr  = isRhs cr+         | otherwise   = isLhs cr+isInh = not . isSyn+hasCode cr = isLocal cr || (isLhs cr && isInh cr) || (isRhs cr && isSyn cr)++isEqualField, isDifferentField, isEqualCon, isRhsOfSameCon :: CRule -> CRule -> Bool+isEqualField      a b = isEqualCon a b && getField a == getField b+isDifferentField  a b = isEqualCon a b && getField a /= getField b +isEqualCon        a b = getLhsNt a == getLhsNt b && getCon a == getCon b+isRhsOfSameCon    a b = isEqualCon a b && isRhs a && isRhs b++isSynAttr, isInhAttr :: NTAttr -> Bool+isSynAttr (NTAInh _ _ _) = False+isSynAttr (NTASyn _ _ _) = True+isInhAttr = not . isSynAttr++ntattr :: CRule -> Maybe NTAttr+ntattr cr  | isLocal cr =  Nothing+           | isInst  cr =  Nothing -- an inst definition is just considered as a local attribute definition+           | otherwise  =  let  at = if isSyn cr then NTASyn else NTAInh+                                getNt cr' = if isRhs cr' then fromJust (getRhsNt cr') else getLhsNt cr'+                           in Just (at (getNt cr) (getAttr cr) (fromJust (getType cr)))++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 False Nothing+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 False Nothing+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 False Nothing++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) False Nothing+                                 where er :: Int -> a+                                       er i = error ("Default rule has no code " ++ show i)++instance Eq CRule where+  a == b = getAttr a == getAttr b && isEqualField a b+instance Ord CRule where+  compare a b =  compare (getLhsNt a) (getLhsNt b) +                 >/< compare (getCon a) (getCon b)+                 >/< compare (getField a) (getField b)+                 >/< compare (getAttr a) (getAttr b)+instance Eq NTAttr where+  (NTAInh _ _ _) == (NTASyn _ _ _) = False+  (NTASyn _ _ _) == (NTAInh _ _ _) = False+  (NTAInh nt name _) == (NTAInh nt' name' _) = nt == nt' && name == name'+  (NTASyn nt name _) == (NTASyn nt' name' _) = nt == nt' && name == name'+instance Ord NTAttr where+  compare (NTAInh _ _ _) (NTASyn _ _ _) = LT+  compare (NTASyn _ _ _) (NTAInh _ _ _) = GT+  compare (NTAInh nt name _) (NTAInh nt' name' _) = compare nt nt' >/< compare name name'+  compare (NTASyn nt name _) (NTASyn nt' name' _) = compare nt nt' >/< compare name name'++eqCRuleDefines :: CRule -> CRule -> Bool+eqCRuleDefines a b+  = Map.keys (getDefines a) == Map.keys (getDefines b)++(>/<) :: Ordering -> Ordering -> Ordering+EQ >/< b = b+a >/< _ = a+++eqClasses :: (a -> a -> Bool) -> [a] -> [[a]]+eqClasses _ [] = []+eqClasses p (a:as) = let (isA,rest) = partition (p a) as+                     in (a:isA):eqClasses p rest++lhsshow :: Options -> NTAttr -> String+lhsshow opts (NTAInh _ attr _) = lhsname opts True attr+lhsshow opts (NTASyn _ attr _) = lhsname opts False attr ++rhsshow :: Options -> Identifier -> NTAttr -> String+rhsshow opts field (NTAInh _ attr _) = attrname opts False field attr+rhsshow opts field (NTASyn _ attr _) = attrname opts True field attr ++prettyCRule :: CRule -> String+prettyCRule cr +   =  let descr | isLocal cr = "local attribute " ++ show (getAttr cr)+                | otherwise =     (if isSyn cr then "synthesized " else "inherited ")+                               ++ "attribute "+                               ++ (if isRhs cr then show (getField cr) ++ "." else "")+                               ++ (if isLhs cr then "lhs." else "")+                               ++ (show (getAttr cr))+      in show (getLhsNt cr) ++ "." ++ show (getCon cr) ++ ", " ++ descr+
src/TokenDef.hs view
@@ -1,86 +1,86 @@-{-# LANGUAGE MagicHash,
-             UnboxedTuples, FlexibleInstances #-}
-
-module TokenDef where
-
-import UU.Scanner.Token
-import UU.Scanner.GenToken
-import UU.Scanner.Position
-import UU.Parsing.MachineInterface(Symbol(..))
-import Data.Char(isPrint,ord)
-import HsToken
-import CommonTypes
-
-instance Symbol Token  where
- deleteCost (Reserved key _) = case key of
-                "DATA"         -> 7#
-                "EXT"          -> 7#
-                "ATTR"         -> 7#
-                "SEM"          -> 7#
-                "USE"          -> 7#
-                "INCLUDE"      -> 7#
-                _              -> 5#
- deleteCost (ValToken v _  _) = case v of
-                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 [] = []
-showTokens xs = map showLine . shiftLeft . getLines $ xs
-
-getLines :: [(Pos, a)] -> [[(Pos, a)]]
-getLines []         = []
-getLines ((p,t):xs) =       let (txs,rest)     = span sameLine xs
-                                sameLine (q,_) = line p == line q
-                            in ((p,t):txs) : getLines rest
-
-shiftLeft :: [[(Pos, a)]] -> [[(Pos, a)]]
-shiftLeft lns =        let sh = let m = minimum . checkEmpty . filter (>=1) . map (column.fst.head) $ lns
-                                    checkEmpty [] = [1]
-                                    checkEmpty x  = x
-                                in if m >= 1 then m-1 else 0
-                           shift (p,t) = (if column p >= 1 then case p of (Pos l c f) -> Pos l (c - sh) f else p, t)
-                       in map (map shift) lns
-
-showLine :: [(Pos, [Char])] -> [Char]
-showLine ts =        let f (p,t) r = let ct = column p
-                                     in \c -> spaces (ct-c) ++ t ++ r (length t+ct)
-                         spaces x | x < 0 = ""
-                                  | otherwise = replicate x ' '
-                     in foldr f (const "") ts 1
-
-showStrShort :: String -> String
-showStrShort xs = "\"" ++ concatMap f xs ++ "\""
-  where f '"' = "\\\""
-        f x   = showCharShort' x
-
-showCharShort :: Char -> String
-showCharShort '\'' = "'" ++ "\\'" ++ "'"
-showCharShort c    = "'" ++ showCharShort' c ++ "'"
-
-showCharShort' :: Char -> String
-showCharShort' '\a'  = "\\a"
-showCharShort' '\b'  = "\\b"
-showCharShort' '\t'  = "\\t"
-showCharShort' '\n'  = "\\n"
-showCharShort' '\r'  = "\\r"
-showCharShort' '\f'  = "\\f"
-showCharShort' '\v'  = "\\v"
-showCharShort' '\\'  = "\\\\"
-showCharShort' x | isPrint x = [x]
-                 | otherwise = '\\' : show (ord x)
-
+{-# LANGUAGE MagicHash,+             UnboxedTuples, FlexibleInstances #-}++module TokenDef where++import UU.Scanner.Token+import UU.Scanner.GenToken+import UU.Scanner.Position+import UU.Parsing.MachineInterface(Symbol(..))+import Data.Char(isPrint,ord)+import HsToken+import CommonTypes++instance Symbol Token  where+ deleteCost (Reserved key _) = case key of+                "DATA"         -> 7#+                "EXT"          -> 7#+                "ATTR"         -> 7#+                "SEM"          -> 7#+                "USE"          -> 7#+                "INCLUDE"      -> 7#+                _              -> 5#+ deleteCost (ValToken v _  _) = case v of+                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 [] = []+showTokens xs = map showLine . shiftLeft . getLines $ xs++getLines :: [(Pos, a)] -> [[(Pos, a)]]+getLines []         = []+getLines ((p,t):xs) =       let (txs,rest)     = span sameLine xs+                                sameLine (q,_) = line p == line q+                            in ((p,t):txs) : getLines rest++shiftLeft :: [[(Pos, a)]] -> [[(Pos, a)]]+shiftLeft lns =        let sh = let m = minimum . checkEmpty . filter (>=1) . map (column.fst.head) $ lns+                                    checkEmpty [] = [1]+                                    checkEmpty x  = x+                                in if m >= 1 then m-1 else 0+                           shift (p,t) = (if column p >= 1 then case p of (Pos l c f) -> Pos l (c - sh) f else p, t)+                       in map (map shift) lns++showLine :: [(Pos, [Char])] -> [Char]+showLine ts =        let f (p,t) r = let ct = column p+                                     in \c -> spaces (ct-c) ++ t ++ r (length t+ct)+                         spaces x | x < 0 = ""+                                  | otherwise = replicate x ' '+                     in foldr f (const "") ts 1++showStrShort :: String -> String+showStrShort xs = "\"" ++ concatMap f xs ++ "\""+  where f '"' = "\\\""+        f x   = showCharShort' x++showCharShort :: Char -> String+showCharShort '\'' = "'" ++ "\\'" ++ "'"+showCharShort c    = "'" ++ showCharShort' c ++ "'"++showCharShort' :: Char -> String+showCharShort' '\a'  = "\\a"+showCharShort' '\b'  = "\\b"+showCharShort' '\t'  = "\\t"+showCharShort' '\n'  = "\\n"+showCharShort' '\r'  = "\\r"+showCharShort' '\f'  = "\\f"+showCharShort' '\v'  = "\\v"+showCharShort' '\\'  = "\\\\"+showCharShort' x | isPrint x = [x]+                 | otherwise = '\\' : show (ord x)+
src/UU/UUAGC.hs view
@@ -1,12 +1,12 @@-module UU.UUAGC (uuagc, uuagcMain, compile, module Options) where
-
-import Ag (uuagcLib, uuagcExe, compile)
-import Options
-
-import System.Exit (ExitCode(..))
-
-uuagc :: [String] -> FilePath -> IO (ExitCode, [FilePath])
-uuagc = uuagcLib
-
-uuagcMain :: IO ()
+module UU.UUAGC (uuagc, uuagcMain, compile, module Options) where++import Ag (uuagcLib, uuagcExe, compile)+import Options++import System.Exit (ExitCode(..))++uuagc :: [String] -> FilePath -> IO (ExitCode, [FilePath])+uuagc = uuagcLib++uuagcMain :: IO () uuagcMain = uuagcExe
src/UU/UUAGC/Version.hs view
@@ -1,4 +1,4 @@--- | Get current version of UUAGC
-module UU.UUAGC.Version(version) where
-
-import Paths_uuagc(version)
+-- | Get current version of UUAGC+module UU.UUAGC.Version(version) where++import Paths_uuagc(version)
uuagc.cabal view
@@ -1,124 +1,127 @@-cabal-version: >= 1.10
-build-type: Custom
-name: uuagc
-version: 0.9.53.1
-license: BSD3
-license-file: LICENSE
-maintainer: Jeroen Bransen <J.Bransen@uu.nl>
-homepage: http://www.cs.uu.nl/wiki/HUT/WebHome
-description: Generates Haskell files from an attribute grammar specification
-synopsis: Attribute Grammar System of Universiteit Utrecht
-category: Development
-stability: Stable
-copyright: Universiteit Utrecht
-author: Software Technology at Universiteit Utrecht
-bug-reports: hut-developers@cs.uu.nl
-tested-with: GHC >= 6.12
-extra-source-files: README
-extra-source-files: uuagc_options
-extra-source-files: src-ag/*.ag
-extra-source-files: src-ag/LOAG/*.ag
-
--- This flag will be set by Setup.hs, use
--- cabal configure --ghc-options="-DEXTERNAL_UUAGC"
-flag bootstrap_external
-   description: Use an external uuagc executable for bootstrapping
-   default: False
-   manual: True
-
-flag with-loag
-   description: Use MiniSat as external SAT-solver to schedule all Linear Ordered AGs
-   default: False
-   manual: True
-
-custom-setup
-  setup-depends: base, Cabal, uuagc-cabal
-
-executable uuagc
-   build-depends: uuagc-cabal >= 1.0.2.0
-   build-depends: base >= 4, base < 5
-   -- Self dependency, depend on library below
-   build-depends: uuagc
-   default-language: Haskell2010
-   main-is: Main.hs
-   hs-source-dirs: src-main
-
-library
-   build-depends: uuagc-cabal >= 1.0.2.0
-   build-depends: base >= 4, base < 5, ghc-prim >= 0.2.0.0
-   if flag(with-loag)
-      build-depends: minisat
-      cpp-options: -DWITH_LOAG
-   build-depends: containers >= 0.3, directory >= 1.0.1.1, array >= 0.3.0.1
-   build-depends: uulib >= 0.9.14, mtl >= 1.1.1.1
-   build-depends: haskell-src-exts >= 1.11.1
-   build-depends: filepath >= 1.1.0.4
-   hs-source-dirs: src, src-version, src-ag, src-options
-   if !flag(bootstrap_external)
-      hs-source-dirs: src-generated
-   exposed-modules: UU.UUAGC, UU.UUAGC.Version
-   default-extensions: TypeSynonymInstances, MultiParamTypeClasses
-   default-language: Haskell2010
-   other-modules: Paths_uuagc
-    , Ag
-    , CommonTypes
-    , GrammarInfo
-    , HsTokenScanner
-    , Options
-    , PPUtil
-    , Parser
-    , Pretty
-    , Scanner
-    , SequentialComputation
-    , SequentialTypes
-    , TokenDef
-    , Version
-    , AbstractSyntax
-    , AbstractSyntaxDump
-    , Code
-    , CodeSyntax
-    , CodeSyntaxDump
-    , ConcreteSyntax
-    , DeclBlocks
-    , DefaultRules
-    , Desugar
-    , ErrorMessages
-    , Expression
-    , GenerateCode
-    , HsToken
-    , Interfaces
-    , InterfacesRules
-    , Order
-    , Patterns
-    , PrintCode
-    , PrintOcamlCode
-    , PrintCleanCode
-    , PrintVisitCode
-    , PrintErrorMessages
-    , SemHsTokens
-    , Transform
-    , ATermWrite
-    , ATermAbstractSyntax
-    , TfmToVisage
-    , Visage
-    , VisageSyntax
-    , VisagePatterns
-    , AG2AspectAG
-    , Macro
-    , RhsCheck
-    , ResolveLocals
-    , Knuth1
-    , KennedyWarren
-    , KWOrder
-    , ExecutionPlan
-    , ExecutionPlan2Hs
-    , ExecutionPlan2Clean
-    , ExecutionPlan2Caml
-    , LOAG.AOAG
-    , LOAG.Chordal
-    , LOAG.Common
-    , LOAG.Graphs
-    , LOAG.Order
-    , LOAG.Rep
-   if flag(with-loag)
-      other-modules: LOAG.Solver.MiniSat, LOAG.Optimise
+cabal-version: >= 1.10+build-type: Custom+name: uuagc+version: 0.9.54+license: BSD3+license-file: LICENSE+maintainer: Jeroen Bransen <J.Bransen@uu.nl>+homepage: http://www.cs.uu.nl/wiki/HUT/WebHome+description: Generates Haskell files from an attribute grammar specification+synopsis: Attribute Grammar System of Universiteit Utrecht+category: Development+stability: Stable+copyright: Universiteit Utrecht+author: Software Technology at Universiteit Utrecht+bug-reports: hut-developers@cs.uu.nl+tested-with: GHC >= 6.12+extra-source-files: README+extra-source-files: uuagc_options+extra-source-files: src-ag/*.ag+extra-source-files: src-ag/LOAG/*.ag++-- This flag will be set by Setup.hs, use+-- cabal configure --ghc-options="-DEXTERNAL_UUAGC"+flag bootstrap_external+   description: Use an external uuagc executable for bootstrapping+   default: False+   manual: True++flag with-loag+   description: Use MiniSat as external SAT-solver to schedule all Linear Ordered AGs+   default: False+   manual: True++custom-setup+  setup-depends: base >= 4 && < 5, Cabal >= 1.24 && < 3.11, uuagc-cabal >= 1.0++executable uuagc+   build-depends: uuagc-cabal >= 1.0.3.0+   build-depends: base >= 4, base < 5+   -- Self dependency, depend on library below+   build-depends: uuagc+   default-language: Haskell2010+   main-is: Main.hs+   hs-source-dirs: src-main++library+   build-depends: uuagc-cabal >= 1.0.3.0+   build-depends: base >= 4, base < 5, ghc-prim >= 0.2.0.0+   if flag(with-loag)+      build-depends: minisat+      cpp-options: -DWITH_LOAG+   build-depends: containers >= 0.3, directory >= 1.0.1.1, array >= 0.3.0.1+   build-depends: uulib >= 0.9.14, mtl >= 1.1.1.1+   build-depends: haskell-src-exts >= 1.11.1+   build-depends: filepath >= 1.1.0.4+   build-depends: aeson >= 1.4.7.1, bytestring >= 0.9.2.1+   hs-source-dirs: src, src-version, src-ag, src-options+   if !flag(bootstrap_external)+      hs-source-dirs: src-generated+   exposed-modules: UU.UUAGC, UU.UUAGC.Version+   default-extensions: TypeSynonymInstances, MultiParamTypeClasses+   default-language: Haskell2010+   other-modules: Paths_uuagc+    , Ag+    , CommonTypes+    , GrammarInfo+    , HsTokenScanner+    , Options+    , PPUtil+    , Parser+    , Pretty+    , Scanner+    , SequentialComputation+    , SequentialTypes+    , TokenDef+    , Version+    , AbstractSyntax+    , AbstractSyntaxDump+    , Code+    , CodeSyntax+    , CodeSyntaxDump+    , ConcreteSyntax+    , DeclBlocks+    , DefaultRules+    , Desugar+    , ErrorMessages+    , Expression+    , GenerateCode+    , HsToken+    , Interfaces+    , InterfacesRules+    , Order+    , Patterns+    , PrintCode+    , PrintOcamlCode+    , PrintCleanCode+    , PrintVisitCode+    , PrintErrorMessages+    , SemHsTokens+    , Transform+    , ATermWrite+    , ATermAbstractSyntax+    , TfmToVisage+    , Visage+    , VisageSyntax+    , VisagePatterns+    , MirageSyntax+    , TfmToMirage+    , AG2AspectAG+    , Macro+    , RhsCheck+    , ResolveLocals+    , Knuth1+    , KennedyWarren+    , KWOrder+    , ExecutionPlan+    , ExecutionPlan2Hs+    , ExecutionPlan2Clean+    , ExecutionPlan2Caml+    , LOAG.AOAG+    , LOAG.Chordal+    , LOAG.Common+    , LOAG.Graphs+    , LOAG.Order+    , LOAG.Rep+   if flag(with-loag)+      other-modules: LOAG.Solver.MiniSat, LOAG.Optimise
uuagc_options view
@@ -1,117 +1,120 @@-file: "src-ag/AbstractSyntax.ag"
-options: module, pretty, data, genlinepragmas, checkParseHaskell
-
-file: "src-ag/ConcreteSyntax.ag"
-options: module, pretty, data, genlinepragmas, checkParseHaskell
-
-file: "src-ag/ErrorMessages.ag"
-options: module, pretty, data, genlinepragmas, checkParseHaskell
-
-file: "src-ag/HsToken.ag"
-options: module, pretty, data, genlinepragmas, checkParseHaskell
-
-file: "src-ag/Code.ag"
-options: module, pretty, data, genlinepragmas, checkParseHaskell
-
-file: "src-ag/Expression.ag"
-options: module, pretty, data, genlinepragmas, checkParseHaskell
-
-file: "src-ag/Patterns.ag"
-options: module, pretty, data, genlinepragmas, checkParseHaskell
-
-file: "src-ag/Interfaces.ag"
-options: module, pretty, data, genlinepragmas, checkParseHaskell
-
-file: "src-ag/CodeSyntax.ag"
-options: module, pretty, data, genlinepragmas, checkParseHaskell
-
-file: "src-ag/DeclBlocks.ag"
-options: module, pretty, data, genlinepragmas, checkParseHaskell
-
-file: "src-ag/VisageSyntax.ag"
-options: module, pretty, data, genlinepragmas, checkParseHaskell
-
-file: "src-ag/VisagePatterns.ag"
-options: module, pretty, data, genlinepragmas, checkParseHaskell
-
-file: "src-ag/ExecutionPlan.ag"
-options: module, pretty, data, genlinepragmas, checkParseHaskell
-
-file: "src-ag/LOAG/Order.ag"
-options: module, pretty, checkParseHaskell, self, wrappers, signatures, catas, semfuns, genlinepragmas, kennedywarren 
-
-file: "src-ag/LOAG/Prepare.ag"
-options: module, pretty, checkParseHaskell, self, wrappers, signatures, catas, semfuns, genlinepragmas, kennedywarren 
-
-file: "src-ag/LOAG/Rep.ag"
-options: module, pretty, checkParseHaskell, self, datarecords, data, optimize
-
-file: "src-ag/Macro.ag"
-options: module, pretty, data, genlinepragmas, checkParseHaskell
-
-
-file: "src-ag/Desugar.ag"
-options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren, visit
-
-file: "src-ag/DefaultRules.ag"
-options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren, visit
-
-file: "src-ag/GenerateCode.ag"
-options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren
-
-file: "src-ag/PrintCleanCode.ag"
-options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren
-
-file: "src-ag/PrintOcamlCode.ag"
-options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren
-
-file: "src-ag/PrintCode.ag"
-options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren
-
-file: "src-ag/PrintVisitCode.ag"
-options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren
-
-file: "src-ag/PrintErrorMessages.ag"
-options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren
-
-file: "src-ag/SemHsTokens.ag"
-options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren
-
-file: "src-ag/Transform.ag"
-options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren
-
-file: "src-ag/Order.ag"
-options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren
-
-file: "src-ag/KWOrder.ag"
-options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren
-
-file: "src-ag/ResolveLocals.ag"
-options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren
-
-file: "src-ag/AbstractSyntaxDump.ag"
-options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren
-
-file: "src-ag/CodeSyntaxDump.ag"
-options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren
-
-file: "src-ag/Visage.ag"
-options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren
-
-file: "src-ag/TfmToVisage.ag"
-options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren
-
-file: "src-ag/AG2AspectAG.ag"
-options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren
-
-file: "src-ag/ExecutionPlan2Hs.ag"
-options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren
-
-file: "src-ag/ExecutionPlan2Clean.ag"
-options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren
-
-file: "src-ag/ExecutionPlan2Caml.ag"
-options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren
-
-file: "src-ag/InterfacesRules.lag"
-options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren
+file: "src-ag/AbstractSyntax.ag"+options: module, pretty, data, genlinepragmas, checkParseHaskell++file: "src-ag/ConcreteSyntax.ag"+options: module, pretty, data, genlinepragmas, checkParseHaskell++file: "src-ag/ErrorMessages.ag"+options: module, pretty, data, genlinepragmas, checkParseHaskell++file: "src-ag/HsToken.ag"+options: module, pretty, data, genlinepragmas, checkParseHaskell++file: "src-ag/Code.ag"+options: module, pretty, data, genlinepragmas, checkParseHaskell++file: "src-ag/Expression.ag"+options: module, pretty, data, genlinepragmas, checkParseHaskell++file: "src-ag/Patterns.ag"+options: module, pretty, data, genlinepragmas, checkParseHaskell++file: "src-ag/Interfaces.ag"+options: module, pretty, data, genlinepragmas, checkParseHaskell++file: "src-ag/CodeSyntax.ag"+options: module, pretty, data, genlinepragmas, checkParseHaskell++file: "src-ag/DeclBlocks.ag"+options: module, pretty, data, genlinepragmas, checkParseHaskell++file: "src-ag/VisageSyntax.ag"+options: module, pretty, data, genlinepragmas, checkParseHaskell++file: "src-ag/VisagePatterns.ag"+options: module, pretty, data, genlinepragmas, checkParseHaskell++file: "src-ag/ExecutionPlan.ag"+options: module, pretty, data, genlinepragmas, checkParseHaskell++file: "src-ag/LOAG/Order.ag"+options: module, pretty, checkParseHaskell, self, wrappers, signatures, catas, semfuns, genlinepragmas, kennedywarren ++file: "src-ag/LOAG/Prepare.ag"+options: module, pretty, checkParseHaskell, self, wrappers, signatures, catas, semfuns, genlinepragmas, kennedywarren ++file: "src-ag/LOAG/Rep.ag"+options: module, pretty, checkParseHaskell, self, datarecords, data, optimize++file: "src-ag/Macro.ag"+options: module, pretty, data, genlinepragmas, checkParseHaskell+++file: "src-ag/Desugar.ag"+options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren, visit++file: "src-ag/DefaultRules.ag"+options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren, visit++file: "src-ag/GenerateCode.ag"+options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren++file: "src-ag/PrintCleanCode.ag"+options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren++file: "src-ag/PrintOcamlCode.ag"+options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren++file: "src-ag/PrintCode.ag"+options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren++file: "src-ag/PrintVisitCode.ag"+options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren++file: "src-ag/PrintErrorMessages.ag"+options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren++file: "src-ag/SemHsTokens.ag"+options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren++file: "src-ag/Transform.ag"+options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren++file: "src-ag/Order.ag"+options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren++file: "src-ag/KWOrder.ag"+options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren++file: "src-ag/ResolveLocals.ag"+options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren++file: "src-ag/AbstractSyntaxDump.ag"+options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren++file: "src-ag/CodeSyntaxDump.ag"+options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren++file: "src-ag/Visage.ag"+options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren++file: "src-ag/TfmToVisage.ag"+options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren++file: "src-ag/TfmToMirage.ag"+options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren++file: "src-ag/AG2AspectAG.ag"+options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren++file: "src-ag/ExecutionPlan2Hs.ag"+options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren++file: "src-ag/ExecutionPlan2Clean.ag"+options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren++file: "src-ag/ExecutionPlan2Caml.ag"+options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren++file: "src-ag/InterfacesRules.lag"+options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren