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