-- 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 ]