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

imports
{
import AbstractSyntax
import HsToken
import Expression
import Patterns
import Options
import PPUtil
import Pretty
import Knuth1
import KennedyWarren
import ExecutionPlan
import Data.Maybe
import Debug.Trace
import Data.Set(Set)
import Data.Map(Map)
import Data.Sequence(Seq)
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.Sequence as Seq
import Data.Monoid(mappend,mempty)
}

-------------------------------------------------------------------------------
--         Dependency graph per production
-------------------------------------------------------------------------------
-- Gather vertices
ATTR HsToken Expression
     Rule Rules
     Pattern Patterns
     Child Children [ | | vertices USE {`Set.union`} {Set.empty} : {Set.Set Vertex} ]

-- All vertices from the righthandside of a rule
SEM  HsToken
  |  AGLocal lhs.vertices = Set.singleton $ VChild @var
  |  AGField lhs.vertices = Set.singleton $ VAttr (if      @field == _LHS then Inh
                                                   else if @field == _LOC then Loc
                                                   else                        Syn) @field @attr

-- Gather vertices for an expression (make a higher order child)
SEM  Expression
  |  Expression lhs.vertices = Set.unions $ map (\tok -> vertices_Syn_HsToken
                                            (wrap_HsToken (sem_HsToken tok) Inh_HsToken)) @tks

-- Gather vertices at patterns
SEM  Pattern
  |  Alias loc.vertex   = if                  @field == _INST then VChild @attr
                          else VAttr (if      @field == _LHS  then Syn
                                      else if @field == _LOC  then Loc
                                      else                         Inh) @field @attr
           lhs.vertices = Set.insert @loc.vertex @pat.vertices

-- Gather vertices for children
--
-- The behavior for merged children is a bit more complicated (and ignored for now)
SEM  Child
  |  Child loc.vertex      = VChild @name
           loc.synvertices = map (VAttr Syn @name) . Map.keys $ @loc.syn
           loc.inhvertices = map (VAttr Inh @name) . Map.keys $ @loc.inh
           lhs.vertices    = case @tp of -- only Nonterminal children need to be in dependency graph
                                NT _ _ _ -> Set.insert @loc.vertex $ Set.fromList (@loc.synvertices ++ @loc.inhvertices)
                                _        -> Set.empty

-- Add extra vertex for a rule
SEM  Rule
  |  Rule loc.vertex   = VRule @loc.rulename
          lhs.vertices = Set.insert @loc.vertex $ @pattern.vertices `Set.union` @rhs.vertices

-- Combine all vertices for a production
SEM  Production
  |  Production loc.vertices = @rules.vertices `Set.union` @children.vertices

-- Gather edges
ATTR Rule Rules
     Child Children [ | | edges USE {`Set.union`} {Set.empty} : {Set.Set Edge} ]

-- Gather edges for a rule
SEM  Rule
  |  Rule loc.edgesout = map ((,) @loc.vertex) (Set.toList @rhs.vertices)
          loc.edgesin  = map (flip (,) @loc.vertex) (Set.toList @pattern.vertices)
          lhs.edges    = Set.fromList $ @loc.edgesout ++ @loc.edgesin

-- When a child is defined by a higher order attribute and the late binding option
-- is enabled, we refer to the additional inherited attribute under the hood, hence
-- we need to tell the dependency analysis about this in order to actually have the
-- attribute available when we attach the child.
-- Note that the dependencies on the rule that creates the semantics of the child
-- is handled elsewhere by mapping an "inst"-attribute to the right child vertex.
SEM Child | Child
  loc.childIsDeforested = case @tp of
                            NT _ _ defor -> defor
                            _            -> False
  loc.higherOrderEdges = case @kind of
                           ChildAttr | lateHigherOrderBinding @lhs.options && not @loc.childIsDeforested
                                        -> [(@loc.vertex, VAttr Inh _LHS idLateBindingAttr)]
                           _            -> []  -- attribute is not referenced implicitly
  loc.aroundEdges      = if @loc.hasArounds
                         then [(@loc.vertex, VAttr Syn _LOC (Ident (getName @name ++ "_around") (getPos @name)))]
                         else []

-- Gather edges for a child
SEM  Child
  |  Child loc.edgesout = @loc.higherOrderEdges
           loc.edgesin  = map (flip (,) @loc.vertex) @loc.synvertices
           lhs.edges    = Set.fromList (@loc.edgesout ++ @loc.edgesin)

-- Add manual attribute dependencies
ATTR Nonterminals Nonterminal [ manualDeps : AttrOrderMap | | ]
ATTR Productions Production [ manualDeps : {Map ConstructorIdent (Set Dependency)} | | ]

SEM Grammar | Grammar         nonts.manualDeps = @manualAttrOrderMap
SEM Nonterminal | Nonterminal prods.manualDeps = Map.findWithDefault Map.empty @nt @lhs.manualDeps
SEM Production | Production
  loc.manualDeps   = Map.findWithDefault Set.empty @con @lhs.manualDeps
  loc.manualEdges  = Set.map depToEdge @loc.manualDeps

{
-- a depends on b, thus a is a successor of b
depToEdge :: Dependency -> Edge
depToEdge (Dependency a b) = (occToVertex False b, occToVertex True a)

occToVertex :: Bool -> Occurrence -> Vertex
occToVertex _ (OccRule nm) = VRule nm
occToVertex isDependency (OccAttr c a)
  | c == _LOC  = VAttr Syn c a   -- local attributes are treated as synthesized attrs of 'loc'
  | c == _INST = VChild a        -- higher-order attributes are treated as children
  | otherwise  = VAttr kind c a where
      kind | isDependency && c == _LHS     = Inh     -- these dependencies have the property that
           | isDependency && c /= _LHS     = Syn     -- they can all be faked by writing a 'const' rule
           | not isDependency && c == _LHS = Syn     -- Perhaps we should also allow other forms of dependencies
           | not isDependency && c /= _LHS = Inh     -- as well, such as two inherited attributes, which would
                                                     -- force them in different visits
}

-- Combine all edges for a production
SEM  Production
  |  Production loc.edges = @rules.edges `Set.union` @children.edges

-- Find all child nonterminal names for a production
ATTR Child Children [ | | nontnames USE {++} {[]} : {[(Identifier, Identifier)]}]

SEM  Child
  |  Child lhs.nontnames = case @tp of
                             NT nont _ _ -> [(@name, nont)]
                             _           -> []

-- Return a dependency graph for each production
ATTR Production  [ | | depgraph : {ProdDependencyGraph} ]
ATTR Productions [ | | depgraph USE {:} {[]} : {[ProdDependencyGraph]} ]

SEM  Production
  |  Production lhs.depgraph  = ProdDependencyGraph { pdgVertices    = Set.toList @loc.vertices
                                                    , pdgEdges       = Set.toList @loc.edges
                                                    , pdgRules       = @rules.erules
                                                    , pdgChilds      = @children.echilds
                                                    , pdgProduction  = @con
                                                    , pdgChildMap    = @children.nontnames
                                                    , pdgConstraints = @constraints
                                                    , pdgParams      = @params }

-------------------------------------------------------------------------------
--         Dependency graph per nonterminal
-------------------------------------------------------------------------------

-- Vertices are just all inherited and syntesized attributes
SEM  Nonterminal
  |  Nonterminal loc.synvertices = map (VAttr Syn @nt) . Map.keys $ @syn
                 loc.inhvertices = map (VAttr Inh @nt) . Map.keys $ @inh
                 loc.vertices    = @loc.synvertices ++ @loc.inhvertices

-- Construct nonterminal dependency graph for production
SEM  Nonterminal
  |  Nonterminal loc.nontgraph = NontDependencyGraph { ndgVertices = @loc.vertices
                                                     , ndgEdges    = [] }

-- Create dependency information for nonterminal and pass it upwards
ATTR Nonterminal  [ | | depinfo : {NontDependencyInformation} ]
ATTR Nonterminals [ | | depinfo USE {:} {[]} : {[NontDependencyInformation]} ]

SEM  Nonterminal
  |  Nonterminal lhs.depinfo = NontDependencyInformation { ndiNonterminal = @nt
                                                         , ndiParams      = @params
                                                         , ndiInh         = Map.keys @inh
                                                         , ndiSyn         = Map.keys @syn
                                                         , ndiDepGraph    = @loc.nontgraph
                                                         , ndiProds       = @prods.depgraph
                                                         , ndiRecursive   = @loc.recursive
                                                         , ndiHoInfo      = @loc.hoInfo
                                                         , ndiClassCtxs   = @loc.classContexts
                                                         }

-------------------------------------------------------------------------------
--         Call the kennedy-warren algorithm
-------------------------------------------------------------------------------
ATTR Grammar [ | | output : {ExecutionPlan}
                   depgraphs : {PP_Doc}
                   visitgraph : {PP_Doc}
                   errors : {Seq Error} ]

SEM  Grammar
  |  Grammar  (lhs.output, lhs.depgraphs, lhs.visitgraph, lhs.errors)
                = let lazyPlan = kennedyWarrenLazy @lhs.options @wrappers @nonts.depinfo @typeSyns @derivings
                  in if visit @lhs.options && withCycle @lhs.options
                     then case kennedyWarrenOrder @lhs.options @wrappers @nonts.depinfo @typeSyns @derivings of
                            Left e        -> (lazyPlan,empty,empty,Seq.singleton e)
                            Right (o,d,v) -> (o,d,v,Seq.empty)
                     else (lazyPlan,empty,empty,Seq.empty)