uuagc-0.9.40.1: src-ag/KWOrder.ag
INCLUDE "AbstractSyntax.ag"
INCLUDE "HsToken.ag"
INCLUDE "Expression.ag"
INCLUDE "Patterns.ag"
INCLUDE "DistChildAttr.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)
}
-------------------------------------------------------------------------------
-- Distributing options
-------------------------------------------------------------------------------
ATTR Grammar Nonterminals Nonterminal Productions Production Children Child
[ options : {Options} | | ]
-------------------------------------------------------------------------------
-- Give unique names to rules
-------------------------------------------------------------------------------
ATTR Nonterminal Nonterminals
Production Productions
Rule Rules [ | rulenumber : Int | ]
SEM Grammar
| Grammar nonts.rulenumber = 0
SEM Rule
| Rule lhs.rulenumber = @lhs.rulenumber + 1
loc.rulename = maybe (identifier $ "rule" ++ show @lhs.rulenumber) id @mbName
-------------------------------------------------------------------------------
-- Find out which nonterminals are recursive
-------------------------------------------------------------------------------
ATTR Nonterminals Nonterminal [ | | ntDeps, ntHoDeps USE {`mappend`} {mempty} : {Map NontermIdent (Set NontermIdent)} ]
ATTR Nonterminals Nonterminal [ closedNtDeps, closedHoNtDeps, closedHoNtRevDeps : {Map NontermIdent (Set NontermIdent)} | | ]
ATTR Productions Production Children Child [ | | refNts, refHoNts USE {`mappend`} {mempty} : {Set NontermIdent} ]
SEM Nonterminal | Nonterminal
lhs.ntDeps = Map.singleton @nt @prods.refNts
lhs.ntHoDeps = Map.singleton @nt @prods.refHoNts
loc.closedNtDeps = Map.findWithDefault Set.empty @nt @lhs.closedNtDeps
loc.closedHoNtDeps = Map.findWithDefault Set.empty @nt @lhs.closedHoNtDeps
loc.closedHoNtRevDeps = Map.findWithDefault Set.empty @nt @lhs.closedHoNtRevDeps
loc.recursive = @nt `Set.member` @loc.closedNtDeps
loc.nontrivAcyc = @nt `Set.member` @loc.closedHoNtDeps
loc.hoInfo = HigherOrderInfo { hoNtDeps = @loc.closedHoNtDeps
, hoNtRevDeps = @loc.closedHoNtRevDeps
, hoAcyclic = @loc.nontrivAcyc
}
SEM Child | Child
loc.refNts = case @tp of
NT nt _ _ -> Set.singleton nt
_ -> mempty
loc.refHoNts = if @loc.isHigherOrder then @loc.refNts else mempty
loc.isHigherOrder = case @kind of
ChildSyntax -> False
_ -> True
SEM Grammar | Grammar
loc.closedNtDeps = closeMap @nonts.ntDeps
loc.closedHoNtDeps = closeMap @nonts.ntHoDeps
loc.closedHoNtRevDeps = revDeps @loc.closedHoNtDeps
-------------------------------------------------------------------------------
-- Determine which children have an around-rule
-------------------------------------------------------------------------------
-- Propagate the around-map downward
ATTR Nonterminals Nonterminal
[ aroundMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} || ]
ATTR Productions Production
[ aroundMap : {Map ConstructorIdent (Map Identifier [Expression])} || ]
ATTR Children Child
[ aroundMap : {Map Identifier [Expression]} | | ]
SEM Nonterminal | Nonterminal loc.aroundMap = Map.findWithDefault Map.empty @nt @lhs.aroundMap
SEM Production | Production loc.aroundMap = Map.findWithDefault Map.empty @con @lhs.aroundMap
SEM Grammar | Grammar
nonts.aroundMap = @aroundsMap
SEM Child | Child
loc.hasArounds = case Map.lookup @name @lhs.aroundMap of
Nothing -> False
Just as -> not (null as)
-------------------------------------------------------------------------------
-- Determine which children are used by merges
-------------------------------------------------------------------------------
-- Propagate the around-map downward
ATTR Nonterminals Nonterminal
[ mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression)))} || ]
ATTR Productions Production
[ mergeMap : {Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression))} || ]
ATTR Children Child
[ mergeMap : {Map Identifier (Identifier, [Identifier], Expression)} mergedChildren : {Set Identifier} | | ]
SEM Nonterminal | Nonterminal loc.mergeMap = Map.findWithDefault Map.empty @nt @lhs.mergeMap
SEM Production | Production loc.mergeMap = Map.findWithDefault Map.empty @con @lhs.mergeMap
SEM Grammar | Grammar
nonts.mergeMap = @mergeMap
SEM Production | Production
loc.mergedChildren = Set.unions [ Set.fromList ms | (_,ms,_) <- Map.elems @loc.mergeMap ]
SEM Child | Child
loc.merges = maybe Nothing (\(_,ms,_) -> Just ms) $ Map.lookup @name @lhs.mergeMap
loc.isMerged = @name `Set.member` @lhs.mergedChildren
-------------------------------------------------------------------------------
-- Distribute the ContextMap to nonterminals
-------------------------------------------------------------------------------
ATTR Nonterminals Nonterminal [ classContexts : ContextMap | | ]
SEM Grammar | Grammar
nonts.classContexts = @contextMap
SEM Nonterminal | Nonterminal
loc.classContexts = Map.findWithDefault [] @nt @lhs.classContexts
-------------------------------------------------------------------------------
-- Gather all rules per production for the execution plan
-------------------------------------------------------------------------------
ATTR Expression [ | | copy : SELF ]
ATTR Rule [ | | erules : ERule ]
ATTR Rules [ | | erules USE {:} {[]} : ERules ]
SEM Rule
| Rule lhs.erules = ERule @loc.rulename
@pattern.copy
@rhs.copy
@owrt
@origin
@explicit
@pure
@mbError
-------------------------------------------------------------------------------
-- Gather all childs per production for the execution plan
-------------------------------------------------------------------------------
ATTR Child [ | | echilds : EChild ]
ATTR Children [ | | echilds USE {:} {[]} : EChildren ]
SEM Child
| Child lhs.echilds = case @tp of
NT _ _ _ -> EChild @name @tp @kind @loc.hasArounds @loc.merges @loc.isMerged
_ -> ETerm @name @tp
-------------------------------------------------------------------------------
-- 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)
-------------------------------------------------------------------------------
-- Output nonterminal type mappings
-------------------------------------------------------------------------------
ATTR Grammar
Nonterminals [ | | inhmap USE {`Map.union`} {Map.empty} : {Map.Map NontermIdent Attributes}
synmap USE {`Map.union`} {Map.empty} : {Map.Map NontermIdent Attributes} ]
ATTR Nonterminal [ | | inhmap : {Map.Map NontermIdent Attributes}
synmap : {Map.Map NontermIdent Attributes} ]
SEM Nonterminal
| Nonterminal lhs.inhmap = Map.singleton @nt @inh
lhs.synmap = Map.singleton @nt @syn
-------------------------------------------------------------------------------
-- Output nonterminal type mappings
-------------------------------------------------------------------------------
ATTR Grammar Nonterminals Nonterminal [ | | localSigMap USE {`Map.union`} {Map.empty} : {Map.Map NontermIdent (Map.Map ConstructorIdent (Map.Map Identifier Type))} ]
ATTR Productions Production [ | | localSigMap USE {`Map.union`} {Map.empty} : {Map.Map ConstructorIdent (Map.Map Identifier Type)} ]
ATTR TypeSigs TypeSig [ | | localSigMap USE {`Map.union`} {Map.empty} : {Map Identifier Type} ]
SEM Nonterminal | Nonterminal lhs.localSigMap = Map.singleton @nt @prods.localSigMap
SEM Production | Production lhs.localSigMap = Map.singleton @con @typeSigs.localSigMap
SEM TypeSig | TypeSig lhs.localSigMap = Map.singleton @name @tp