PRAGMA strictdata
PRAGMA optimize
PRAGMA bangpats
PRAGMA strictwrap

INCLUDE "AbstractSyntax.ag"
INCLUDE "Patterns.ag"
INCLUDE "Expression.ag"
INCLUDE "HsToken.ag"
INCLUDE "DistChildAttr.ag"


imports
{
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Map(Map)
import qualified Data.Sequence as Seq
import Data.Sequence(Seq,(><))
import UU.Scanner.Position(Pos(..))
import Data.Maybe
import Data.List(intersperse)

import AbstractSyntax
import ErrorMessages
import Options
import HsToken
import HsTokenScanner
import TokenDef
import CommonTypes
}

WRAPPER HsTokensRoot


ATTR Grammar Nonterminals Nonterminal Productions Production Children Child Rule Rules Expression [ options:{Options} | | ]

ATTR Grammar Nonterminals Nonterminal Productions Production Rule Rules Pattern Patterns Expression HsTokensRoot HsToken HsTokens [ | | errors USE {Seq.><} {Seq.empty} : {Seq Error} ]

ATTR Grammar Nonterminals Nonterminal Productions Production Child Children Rule Rules Pattern Patterns TypeSig TypeSigs Expression [ | | output : SELF ]


-------------------------------------------------------------------------------
--         Deal with RHS
-------------------------------------------------------------------------------

SEM Expression
  | Expression
      (loc.tks', lhs.errors) = let inh = Inh_HsTokensRoot { childInhs_Inh_HsTokensRoot     = @lhs.childInhs
                                                          , childSyns_Inh_HsTokensRoot     = @lhs.childSyns
                                                          , nt_Inh_HsTokensRoot            = @lhs.nt
                                                          , con_Inh_HsTokensRoot           = @lhs.con
                                                          , ruleDescr_Inh_HsTokensRoot     = @lhs.ruleDescr
                                                          , useFieldIdent_Inh_HsTokensRoot = genUseTraces @lhs.options
                                                          }
                                   sem = sem_HsTokensRoot (HsTokensRoot @tks)
                                   syn = wrap_HsTokensRoot sem inh
                               in (tks_Syn_HsTokensRoot syn, errors_Syn_HsTokensRoot syn)
      lhs.output = Expression @pos @tks'


ATTR HsTokensRoot HsTokens HsToken [ useFieldIdent : Bool | | ]

ATTR HsToken HsTokens [ | addLines : Int | ]
SEM HsTokensRoot
  | HsTokensRoot
      tokens.addLines = 0

ATTR HsTokensRoot [ | | tks : {[HsToken]} ]
ATTR HsToken HsTokens [ | | tks : SELF ]

SEM HsToken
  | AGLocal
      lhs.addLines = if @lhs.useFieldIdent
                     then @lhs.addLines + 1
                     else @lhs.addLines
      loc.tks = AGLocal @var (addl @lhs.addLines @pos) (if @lhs.useFieldIdent then Just @lhs.ruleDescr else Nothing)
  | AGField
      loc.mField = findField @field @attr @lhs.childSyns

      loc.field' = maybe @field id @loc.mField
      lhs.errors = maybe (Seq.singleton (UndefAttr @lhs.nt @lhs.con @field (Ident "<ANY>" (getPos @field)) False)) (const Seq.empty) @loc.mField

      lhs.addLines = if @lhs.useFieldIdent || length (getName @field) < length (getName @loc.field')
                     then @lhs.addLines + 1
                     else @lhs.addLines

      loc.tks = AGField @loc.field' @attr (addl @lhs.addLines @pos) (if @lhs.useFieldIdent then Just @lhs.ruleDescr else Nothing)
  | HsToken
      loc.tks = HsToken @value (addl @lhs.addLines @pos)
  | CharToken
      loc.tks = CharToken @value (addl @lhs.addLines @pos)
  | StrToken
      loc.tks = StrToken @value (addl @lhs.addLines @pos)
  | Err
      loc.tks = Err @mesg (addl @lhs.addLines @pos)

{
addl :: Int -> Pos -> Pos
addl n (Pos l c f) = Pos (l+n) c f
}


-------------------------------------------------------------------------------
--         Deal with LHS
-------------------------------------------------------------------------------

SEM Pattern
  | Alias
      (loc.field', loc.err1) = maybeError @field (UndefAttr @lhs.nt @lhs.con (Ident "<ANY>" (getPos @field)) @attr True) $
                                 findField @field @attr @lhs.childInhs
      loc.err2 = if @loc.field' == @field
                 then Seq.empty
                 else if (@loc.field', @attr) `Set.member` @lhs.defs
                      then Seq.singleton $ DupRule @lhs.nt @lhs.con @field @attr @loc.field'
                      else Seq.empty
      lhs.errors = @loc.err1 Seq.>< @loc.err2 Seq.>< @pat.errors
      loc.output = Alias @loc.field' @attr @pat.output


-------------------------------------------------------------------------------
--         Distribute attributes of children
-------------------------------------------------------------------------------

ATTR Children Child [ | | childInhs, childSyns USE {++} {[]} : {[(Identifier, Identifier)]} ]
ATTR Rules Rule Pattern Patterns Expression HsTokensRoot HsToken HsTokens [ childInhs, childSyns : {[(Identifier, Identifier)]} | | ]

SEM Child
  | Child
      lhs.childInhs = [(i, @name) | i <- Map.keys @loc.inh ]
      lhs.childSyns = [(s, @name) | s <- Map.keys @loc.syn ]

{
maybeError :: a -> Error -> Maybe a -> (a, Seq Error)
maybeError def err mb
  = maybe (def, Seq.singleton err) (\r -> (r, Seq.empty)) mb

findField :: Identifier -> Identifier -> [(Identifier,Identifier)] -> Maybe Identifier
findField fld attr list
  | fld == _FIRST = f list
  | fld == _LAST  = f (reverse list)
  | otherwise     = Just fld
  where
    f = lookup attr
}


-------------------------------------------------------------------------------
--         Distribute nt and con
-------------------------------------------------------------------------------

ATTR Productions Production Rule Rules Pattern Patterns Expression HsTokensRoot HsToken HsTokens [ nt : NontermIdent | | ]
ATTR Rule Rules Pattern Patterns Expression HsTokensRoot HsToken HsTokens [ con : ConstructorIdent | | ]

SEM Nonterminal
  | Nonterminal
      prods.nt = @nt

SEM Production
  | Production
      rules.con = @con


-------------------------------------------------------------------------------
--         Distribute a pattern description
-------------------------------------------------------------------------------

ATTR Expression HsTokensRoot HsToken HsTokens [ ruleDescr : String | | ]

SEM Rule
  | Rule
      loc.ruleDescr = show @lhs.nt ++ " :: " ++ show @lhs.con ++ " :: " ++ (concat $ intersperse "," $ map (\(f,a) -> show f ++ "." ++ show a) $ Set.toList @pattern.defsCollect)


-------------------------------------------------------------------------------
--         Distribute all defined attributes
-------------------------------------------------------------------------------

ATTR Rule Rules Pattern Patterns [ | | defsCollect USE {`Set.union`} {Set.empty} : {Set (Identifier, Identifier)} ]
SEM Pattern
  | Alias
      loc.def = Set.singleton (@field, @attr)
      lhs.defsCollect = @loc.def `Set.union` @pat.defsCollect

ATTR Rule Rules Pattern Patterns [ defs : {Set (Identifier, Identifier)} | | ]
SEM Production
  | Production
      rules.defs = @rules.defsCollect


-------------------------------------------------------------------------------
--         Collect a list of all attributes (that are not irrefutable)
-------------------------------------------------------------------------------

ATTR Grammar Nonterminals Nonterminal Productions Production Rule Rules Pattern Patterns
  [ | | allAttributes USE {`mergeAttributes`} {Map.empty} : {AttrMap} ]

SEM Pattern
  | Alias
      lhs.allAttributes = (Map.singleton @lhs.nt $ Map.singleton @lhs.con $ Set.singleton (@field, @attr)) `mergeAttributes` @pat.allAttributes
  | Irrefutable
      lhs.allAttributes = Map.empty

{
mergeAttributes :: AttrMap -> AttrMap -> AttrMap
mergeAttributes = Map.unionWith $ Map.unionWith $ Set.union
}


-------------------------------------------------------------------------------
--         Distribute a list of attributes forced to irrefutables
-------------------------------------------------------------------------------

ATTR Grammar Nonterminals Nonterminal Productions Production Rule Rules Pattern Patterns
  [ forcedIrrefutables : {AttrMap} | | ]

SEM Pattern
  | Alias
      lhs.output = if Set.member (@field, @attr) $ Map.findWithDefault Set.empty @lhs.con $ Map.findWithDefault Map.empty @lhs.nt $ @lhs.forcedIrrefutables
                   then Irrefutable @loc.output
                   else @loc.output


-------------------------------------------------------------------------------
--         Decompose augment map and rebuild it
-------------------------------------------------------------------------------

ATTR Nonterminals Nonterminal [ augmentsIn : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))}
                              | | augmentsOut USE {`Map.union`} {Map.empty} : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} ]
ATTR Productions Production [ augmentsIn : {Map ConstructorIdent (Map Identifier [Expression])}
                            | | augmentsOut USE {`Map.union`} {Map.empty} : {Map ConstructorIdent (Map Identifier [Expression])} ]

SEM Grammar
  | Grammar
      nonts.augmentsIn = @augmentsMap

SEM Nonterminal
  | Nonterminal
      loc.augmentsIn = Map.findWithDefault Map.empty @nt @lhs.augmentsIn
      loc.augmentsOut = Map.singleton @nt @prods.augmentsOut

SEM Production
  | Production
      loc.augmentsIn = Map.findWithDefault Map.empty @con @lhs.augmentsIn
      loc.augmentsOut = Map.singleton @con @loc.augmentsOut1

      (loc.augmentErrs, loc.augmentsOut1) = Map.mapAccum (desugarExprs @lhs.options @lhs.nt @con @children.childInhs @children.childSyns) Seq.empty @loc.augmentsIn

WRAPPER Expression

{
desugarExprs :: Options -> NontermIdent -> ConstructorIdent ->
                [(Identifier, Identifier)] -> [(Identifier, Identifier)] ->
                Seq Error -> [Expression] -> (Seq Error, [Expression])
desugarExprs options nt con childInhs childSyns
  = mapAccum (desugarExpr options nt con childInhs childSyns)
  where mapAccum f e = foldr (\x (e0,xs) -> let (e1,x') = f e0 x in (e1, x:xs)) (e, [])

desugarExpr :: Options -> NontermIdent -> ConstructorIdent ->
               [(Identifier, Identifier)] -> [(Identifier, Identifier)] ->
               Seq Error -> Expression -> (Seq Error, Expression)
desugarExpr options nt con childInhs childSyns errs expr
  = (errs Seq.>< errors_Syn_Expression syn, output_Syn_Expression syn)
  where
    inh = Inh_Expression { childInhs_Inh_Expression = childInhs
                         , childSyns_Inh_Expression = childSyns
                         , con_Inh_Expression       = con
                         , nt_Inh_Expression        = nt
                         , options_Inh_Expression   = options
                         , ruleDescr_Inh_Expression = "augment-rule"
                         }
    sem = sem_Expression expr
    syn = wrap_Expression sem inh
}


-------------------------------------------------------------------------------
--         Errors of a production
-------------------------------------------------------------------------------

SEM Production
  | Production
      lhs.errors = @rules.errors Seq.>< @loc.augmentErrs

-------------------------------------------------------------------------------
--         Support for late binding of higher order children
-------------------------------------------------------------------------------

ATTR Grammar Nonterminals Nonterminal Productions Production Children Child [ mainName : {String} | | ]

SEM Nonterminal | Nonterminal
  loc.extraInh = addLateAttr @lhs.options @lhs.mainName

{
addLateAttr :: Options -> String -> Attributes
addLateAttr options mainName
  | kennedyWarren options && lateHigherOrderBinding options =
      let tp = lateBindingType mainName
      in Map.singleton idLateBindingAttr tp
  | otherwise = Map.empty
}

-------------------------------------------------------------------------------
--         Reconstruct the grammar
-------------------------------------------------------------------------------

SEM Nonterminal | Nonterminal
  lhs.output = Nonterminal
                 @nt @params
                 (@loc.extraInh `Map.union` @inh)
                 @syn
                 @prods.output

SEM Child | Child
  lhs.output = Child @name @tp @kind

SEM Grammar
  | Grammar
      lhs.output = Grammar @typeSyns
                           @useMap
                           @derivings
                           @wrappers
                           @nonts.output
                           @pragmas
                           @manualAttrOrderMap
                           @paramMap
                           @contextMap
                           @quantMap
                           @uniqueMap
                           @nonts.augmentsOut
                           @aroundsMap
                           @mergeMap