imports
{
import qualified UU.DData.Map as Map
import UU.Pretty
import UU.DData.Set as Set
import UU.DData.Seq as Seq
import UU.DData.Map (Map)
import ConcreteSyntax
import AbstractSyntax
import Patterns
import ErrorMessages
import List (partition)
import Maybe
import UU.Scanner.Position(noPos)
import Options
import Rules
import Patterns
}

INCLUDE "Patterns.ag"
INCLUDE "Rules.ag"
{
type DefinedAttrs = Map (Name,Name) Bool -- defined with := or =
type FieldMap  = [(Name, Type)]

checkDef nt con owrt field attr fieldMap attributes defAttrs 
     | field == _LOC = checkDup
     | field == _LHS = check snd nt
     | otherwise     = case lookup field fieldMap of 
                         Just (NT tp) -> check fst tp
                         _              -> (True,defAttrs,Seq.single(UndefChild nt con field))        
  where check f nont | hasAttr f nont attr attributes = checkDup
                     | otherwise                      = (True,defAttrs,Seq.single(SuperfluousRule nt con field attr))
        checkDup = case Map.lookupIndex (field,attr) defAttrs of
                    Just ix -> let ((_,attr2),b) = Map.elemAt ix defAttrs
                               in if b 
                                    then (True,Map.insert (field,attr) owrt defAttrs, Seq.empty)
                                    else (True,defAttrs,Seq.single(DupRule nt con field attr2 attr))
                    Nothing -> (False,Map.insert (field,attr) owrt defAttrs, Seq.empty)

hasAttr f tp attr attributes = case Map.lookup tp attributes of
                                Just attrs -> Map.member attr (f attrs)
                                Nothing    -> False                               
}
ATTR SemDef SemDefs Pattern Patterns [ nt:{Nonterminal} | | ]
 
-- Pass the name of the constructor to semantic rules and patterns
ATTR SemDef SemDefs Pattern Patterns [ con:{Constructor} | | ]
ATTR  SemDef SemDefs  Pattern Patterns [ | | errors USE {Seq.<>}{Seq.empty}:{Seq Error} ]
ATTR  SemDef SemDefs  Pattern Patterns 
    [  attributes:{Map Nonterminal (Attributes, Attributes)}  | | ]
ATTR SemDef SemDefs  [| rules:{(Rules,DefinedAttrs)} |]
ATTR Pattern Patterns SemDef SemDefs  [ fieldMap:{FieldMap}|  |]
ATTR Pattern Patterns [ | defAttrs:{DefinedAttrs} | ]
ATTR Pattern Patterns [ owrt:{Bool} | | copy:SELF ]

SEM SemDef
  | Def loc.(rules1,defAttrs) = @lhs.rules
        lhs.rules             = (Rule @pattern.copy @rhs @owrt (show @pattern.stpos): @rules1, @pattern.defAttrs)
        pattern.owrt          = @owrt

ATTR Pattern [ | | stpos : Pos ]

SEM Pattern
  | Constr     lhs.stpos = getPos @name
  | Product    lhs.stpos = @pos
  | Alias      lhs.stpos = getPos @field
  | Underscore lhs.stpos = @pos

SEM Pattern 
  | Alias loc.(underscore, defAttrs, errs) = checkDef @lhs.nt @lhs.con @lhs.owrt @field @attr @lhs.fieldMap @lhs.attributes @pat.defAttrs 
          lhs.defAttrs = @defAttrs
          pat.defAttrs = @lhs.defAttrs
          lhs.copy = if @underscore then Underscore noPos else @copy
          lhs.errors = @errs <> @pat.errors

SEM Patterns
  | Cons lhs.defAttrs = @hd.defAttrs
         hd.defAttrs  = @tl.defAttrs
         tl.defAttrs  = @lhs.defAttrs