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