uuagc-0.9.50: src-ag/Order.ag
PRAGMA strictdata
PRAGMA strictwrap
INCLUDE "Patterns.ag"
INCLUDE "Expression.ag"
INCLUDE "AbstractSyntax.ag"
INCLUDE "DistChildAttr.ag"
imports
{
-- From uuagc
import CommonTypes
import Patterns
import ErrorMessages
import AbstractSyntax
import Code hiding (Type)
import qualified Code
import Expression
import Options
import SequentialComputation
import SequentialTypes
import CodeSyntax
import GrammarInfo
import HsToken(HsTokensRoot(HsTokensRoot))
import SemHsTokens(sem_HsTokensRoot,wrap_HsTokensRoot, Syn_HsTokensRoot(..),Inh_HsTokensRoot(..))
-- From uulib
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Sequence as Seq
import Data.Map(Map)
import Data.Set(Set)
import Data.Sequence(Seq, (><))
import UU.Util.Utils
import UU.Scanner.Position(Pos(..),initPos)
import Data.Foldable(toList)
-- From haskell libraries
import Control.Monad(liftM)
import qualified Data.Array as Array
import Data.Array((!),bounds,inRange)
import Data.List(elemIndex,partition,sort,mapAccumL,find,nubBy,intersperse,groupBy,transpose)
import qualified Data.Tree as Tree
import Data.Maybe
}
{
-- Terminates with an error if the key is not in the map
findWithErr1 :: (Ord k, Show k) => String -> k -> Map k a -> a
findWithErr1 s k
= Map.findWithDefault (error ("findWithErr1 " ++ s ++ ": key " ++ show k ++ " not in map.")) k
findWithErr2 :: (Ord k, Show k, Show a) => k -> Map k a -> a
findWithErr2 k m
= Map.findWithDefault (error ("findWithErr2: key " ++ show k ++ " not in map: " ++ show m)) k m
}
--
-- Some statistics, count number of attributes
--
ATTR Grammar Nonterminals Nonterminal Productions Production Rules Rule [ | | nAutoRules,nExplicitRules USE {+} {0} : {Int} ]
SEM Rule
| Rule lhs.nExplicitRules = if @explicit
then 1
else 0
lhs.nAutoRules = if startsWith "use rule" @origin || startsWith "copy rule" @origin
then 1
else 0
{
startsWith :: String -> String -> Bool
startsWith k h = k == take (length k) h
}
-------------------------------------------------------------------------------
-- Errors
-------------------------------------------------------------------------------
-- Everyone that wants to report an error can do this by adding an error message to the
-- stream of errors
ATTR Nonterminals Nonterminal Productions Production
Child Children Rule Rules Pattern Patterns Grammar [ | | errors USE {Seq.><} {Seq.empty}:{Seq Error} ]
-------------------------------------------------------------------------------
-- Distributing name of nonterminal and names of attributes
-------------------------------------------------------------------------------
ATTR Productions Production Child Children Rules Rule Patterns Pattern [ nt : {Identifier} inh,syn : {Attributes} | | ]
ATTR Child Children Rules Rule Patterns Pattern [ con : {Identifier} | | ]
SEM Production
| Production children . con = @con
SEM Production
| Production rules . con = @con
SEM Nonterminal
| Nonterminal prods . nt = @nt
SEM Nonterminal
| Nonterminal prods.inh = @inh
prods.syn = @syn
-------------------------------------------------------------------------------
-- Distributing options
-------------------------------------------------------------------------------
ATTR Grammar [ options:{Options} | | ]
ATTR Nonterminals Nonterminal Productions Production Rules Rule
[ o_newtypes
, o_cata
, o_sig
, o_sem
, o_rename
, o_wantvisit -- True if the option for visit functions has been specified
, o_dovisit -- True if o_wantvisit and it is possible to generate visit functions (no cycles)
, o_case:{Bool}
prefix : {String} | | ]
ATTR Nonterminals Nonterminal Productions Production Children Child [ o_unbox:{Bool} | | ]
ATTR Nonterminals Nonterminal [ o_data:{Bool} | | ]
SEM Grammar
| Grammar loc.o_dovisit = visit @lhs.options && null @cyclesErrors
nonts.o_cata = folds @lhs.options
.o_data = dataTypes @lhs.options
.o_sig = typeSigs @lhs.options
.o_sem = semfuns @lhs.options
.o_rename = rename @lhs.options
.o_newtypes= newtypes @lhs.options
.o_wantvisit = visit @lhs.options
.o_unbox = unbox @lhs.options
.o_case = cases @lhs.options
.prefix = prefix @lhs.options
------------------------------------------------------------------
-- Building a mapping from Vertices to Ints
------------------------------------------------------------------
{
getNtName :: Type -> NontermIdent
getNtName (NT nt _ _) = nt
getNtName _ = nullIdent
}
------------------------------------------------------------------
-- Collect attribute occurrences
--
-- All attribute occurences in an alternative are gathered.
-- This is done by joining various sublists:
-- 1. inherited attributes for _LHS
-- 2a. synthesized attributes for children
-- 2b. children that are a trivial field
-- 3a. inherited attributes for children
-- 3b. synthesized attributes for _LHS
-- 3c. local attributes
--
-- Sublist 3 is exactly the targets for ATTR definitions, and
-- thus can be obtained by traversing all rules.
--
-- The (field,attr) combination is not enough to uniquely identify
-- an attribute occurence, because threaded attributes occur twice.
-- Therefore, in the AltAttr structures, a boolean is added,
-- that is False in sublists 3a and 3b, i.e. the non-local output fields.
--
-- Each AltAttr, that is eacht attribute occurence, is mapped to a number
-- in the altAttrs Map, starting at vcount
{
data AltAttr = AltAttr Identifier Identifier Bool
deriving (Eq, Ord, Show)
}
ATTR Rules Rule Production Productions Nonterminal Nonterminals
[ options : {Options} | | ]
ATTR Children Child Rules Rule Patterns Pattern [ | | gathAltAttrs USE {++} {[]} : {[AltAttr]} ]
SEM Production
| Production loc.gathAltAttrs = [ AltAttr _LHS inh True | inh <- Map.keys @lhs.inh ] -- sublist 1
++ @children.gathAltAttrs -- sublist 2
++ @rules.gathAltAttrs -- sublist 3
SEM Child
| Child loc.maptolocal = case @tp of
NT nt _ _ -> Map.null @syn
_ -> True
lhs.gathAltAttrs = if @maptolocal
then [ AltAttr _LOC @name True ] -- sublist 2b
else [ AltAttr @name syn True | syn <- Map.keys @loc.syn ] -- sublist 2a
SEM Pattern
| Alias lhs.gathAltAttrs = [AltAttr @field @attr (@field == _LOC || @field == _INST)] -- sublist 3
ATTR Rules Rule Patterns Pattern [ altAttrs : {Map AltAttr Vertex} | | ]
SEM Production
| Production loc.altAttrs = Map.fromList (zip @gathAltAttrs [@lhs.vcount..])
-- Information passed to Pattern
ATTR Children Child
[ | | nts USE {Seq.><} {Seq.empty} : {Seq (Identifier,NontermIdent)}
inhs USE {Seq.><} {Seq.empty} : {Seq (Identifier,Attributes)} ]
SEM Child
| Child lhs.nts = Seq.singleton (@name,getNtName @tp)
lhs.inhs = Seq.singleton (@name,@loc.inh)
ATTR Rules Rule
[ childNts : {Map Identifier NontermIdent}
childInhs : {Map Identifier Attributes} | | ]
SEM Production
| Production rules.childNts = Map.fromList (toList @children.nts)
rules.childInhs = Map.fromList (toList @children.inhs)
-- Collect CRules
ATTR Children Child Rules Rule
[ | | gathRules USE {Seq.><} {Seq.empty} : {Seq CRule} ]
SEM Production
| Production loc.inhRules = [ cRuleLhsInh inh @lhs.nt @con tp | (inh,tp) <- Map.assocs @lhs.inh ]
loc.gathRules = @inhRules ++ toList (@children.gathRules Seq.>< @rules.gathRules)
SEM Child
| Child loc.gathRules = if @maptolocal
then Seq.singleton (cRuleTerminal @name @lhs.nt @lhs.con @tp)
else Seq.fromList [ cRuleRhsSyn syn @lhs.nt @lhs.con tp @name (getNtName @tp) | (syn,tp) <- Map.assocs @loc.syn]
SEM Rule
| Rule loc.defines = let tp field attr | field == _LOC || field == _INST
= Map.lookup attr @lhs.allTypeSigs
| field == _LHS = Map.lookup attr @lhs.syn
| otherwise = Map.lookup attr (findWithErr1 "Rule.defines.tp" field @lhs.childInhs)
typ :: Pattern -> Maybe Type
typ (Alias field attr _) = tp field attr
typ (Underscore _) = Nothing
-- typ (Product _ pats) = tp _LOC undefined pats
typ _ = Nothing
in Map.fromList [ (findWithErr1 "Rule.defines" aa @lhs.altAttrs, (field,attr,(tp field attr)))
| (field,attr,isLocalOrInst) <- @pattern.patternAttrs
, let aa = AltAttr field attr isLocalOrInst
]
loc.gathRules = let childnt field = Map.lookup field @lhs.childNts
in Seq.fromList [ CRule attr False True @lhs.nt @lhs.con field (childnt field) tp @pattern.copy @rhs.textLines @defines @owrt @origin @rhs.allRhsVars @explicit @mbName
| (field,attr,tp) <- Map.elems @defines
]
{
substSelf nt tp
= case tp of
NT n tps defor | n == _SELF -> NT nt tps defor
_ -> tp
haskellTupel :: [Type] -> Maybe Type
haskellTupel ts = Just ( Haskell ( '(' : (concat (intersperse "," (map show ts))) ++ ")" ))
}
ATTR Patterns Pattern [ | | patternAttrs USE {++} {[]} : {[(Identifier,Identifier,Bool)]} ]
SEM Pattern
| Alias lhs.patternAttrs = [(@field,@attr,(@field == _LOC || @field == _INST))]
-- Giving them a number
ATTR Nonterminals Nonterminal Productions Production
[ | vcount : Int
| rules USE {Seq.><} {Seq.empty} : {Seq (Vertex,CRule)}]
SEM Grammar
| Grammar nonts.vcount = 0
SEM Production
| Production lhs.rules = Seq.fromList (zip [@lhs.vcount..] @gathRules)
lhs.vcount = @lhs.vcount + length @gathRules
-- Direct dependencies
ATTR Nonterminals Nonterminal
Productions Production
Rules Rule [ | | directDep USE {Seq.><} {Seq.empty} : {Seq Edge} ]
SEM Rule
| Rule lhs.directDep
= let defined = Map.keys @defines
used = [ Map.lookup (AltAttr field attr True) @lhs.altAttrs | (field,attr) <- @rhs.usedAttrs]
++ [ Map.lookup (AltAttr _LOC attr True) @lhs.altAttrs | attr <- @rhs.usedLocals ++ @rhs.usedFields ]
in Seq.fromList [ (x,y) | Just x <- used, y <- defined ]
-- Manual depdendencies (provided by the programmer)
--
-- a dependency f1.a1 < f2.a2 is translated to
-- the edge (vertex(f1.a1), vertex(f2.a2))
ATTR Nonterminals Nonterminal
Productions Production
[ manualAttrDepMap : {AttrOrderMap} | | additionalDep USE {Seq.><} {Seq.empty} : {Seq Edge} ]
SEM Grammar
| Grammar
nonts.manualAttrDepMap = @manualAttrOrderMap
SEM Production
| Production
loc.manualDeps
= Set.toList $ Map.findWithDefault Set.empty @con $ Map.findWithDefault Map.empty @lhs.nt @lhs.manualAttrDepMap
lhs.additionalDep
= Seq.fromList [ (vertex True occA, vertex False occB)
| Dependency occA occB <- @loc.manualDeps
, let vertex inout (OccAttr child nm)
| child == _LOC = findWithErr2 (AltAttr _LOC nm True) @loc.altAttrs
| otherwise = findWithErr2 (AltAttr child nm inout) @loc.altAttrs
vertex _ (OccRule nm)
= findWithErr2 (AltAttr _LOC (Ident ("_rule_" ++ show nm) (getPos nm)) True) @loc.altAttrs
]
-- Inst dependencies
--
-- For each inst attribute x of nt N, add the dependency
-- (inst.x,x.y) for each synthesized attribute of N
--
ATTR Nonterminals Nonterminal
Productions Production
Rules Rule [ | | instDep USE {Seq.><} {Seq.empty} : {Seq Edge} ]
SEM Rule
| Rule
loc.instDep1
= Seq.fromList $
[ (instVert, synVert)
| (field,instNm,_) <- Map.elems @defines
, field == _INST
, synNm <- Map.keys (findWithErr2 instNm @lhs.synsOfChildren)
, let instAttr = AltAttr _INST instNm True
synAttr = AltAttr instNm synNm True
instVert = findWithErr2 instAttr @lhs.altAttrs
synVert = findWithErr2 synAttr @lhs.altAttrs
]
loc.instDep2
= Seq.fromList $
[ (instVert, inhVert)
| (field,instNm,_) <- Map.elems @defines
, field == _INST
, inhNm <- Map.keys (findWithErr2 instNm @lhs.inhsOfChildren)
, let instAttr = AltAttr _INST instNm True
inhAttr = AltAttr instNm inhNm False
instVert = findWithErr2 instAttr @lhs.altAttrs
inhVert = findWithErr2 inhAttr @lhs.altAttrs
]
lhs.instDep = @loc.instDep1 Seq.>< @loc.instDep2
ATTR Rules Rule [ synsOfChildren, inhsOfChildren : {Map Identifier Attributes} | | ]
SEM Production
| Production rules.synsOfChildren = @children.collectChildrenSyns
rules.inhsOfChildren = @children.collectChildrenInhs
ATTR Children Child [ | | collectChildrenSyns, collectChildrenInhs USE {`Map.union`} {Map.empty} : {Map Identifier Attributes } ]
SEM Child
| Child lhs.collectChildrenSyns = Map.singleton @name @loc.syn
lhs.collectChildrenInhs = Map.singleton @name @loc.inh
--
-- Merge stuff
--
ATTR Nonterminals Nonterminal
[ mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))} | | ]
ATTR Productions Production
[ mergeMap : {Map ConstructorIdent (Map Identifier (Identifier,[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
ATTR Rules Rule Children Child Expression [ mergeMap : {Map Identifier (Identifier,[Identifier])} | | ]
-- for a child c : N, with merged children cs, add dependencies between synthesized attrs of
-- c to synthesized attrs of cs, and to the merge-attribute
ATTR Nonterminals Nonterminal Productions Production
[ | | mergeDep USE {Seq.><} {Seq.empty} : {Seq Edge} ]
SEM Production
| Production
lhs.mergeDep = @loc.mergeDep1 Seq.>< @loc.mergeDep2
loc.mergeDep1
= Seq.fromList $
[ (childVert, synVert)
| childNm <- Map.keys @loc.mergeMap
, synNm <- Map.keys (findWithErr2 childNm @children.collectChildrenSyns)
, let childNm' = Ident (show childNm ++ "_merge") (getPos childNm)
childAttr = AltAttr _LOC childNm' True
synAttr = AltAttr childNm synNm True
childVert = findWithErr2 childAttr @loc.altAttrs
synVert = findWithErr2 synAttr @loc.altAttrs
]
loc.mergeDep2
= Seq.fromList $
[ (mergedVert, sourceVert)
| (childNm, (_,cs)) <- Map.assocs @loc.mergeMap
, c <- cs
, synNm <- Map.keys (findWithErr2 childNm @children.collectChildrenSyns)
, let sourceAttr = AltAttr childNm synNm True
mergedAttr = AltAttr c synNm True
sourceVert = findWithErr2 sourceAttr @loc.altAttrs
mergedVert = findWithErr2 mergedAttr @loc.altAttrs
]
-- Around dependencies
--
-- For each around x_around on x of nt N, add the dependency
-- (x_around, x.y) for each synthesized attribute y of N
--
ATTR Nonterminals Nonterminal
Productions Production
[ | | aroundDep USE {Seq.><} {Seq.empty} : {Seq Edge} ]
ATTR Nonterminals Nonterminal
[ aroundMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} || ]
ATTR Productions Production
[ aroundMap : {Map ConstructorIdent (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 Production
| Production
loc.aroundDep1
= Seq.fromList $
[ (childVert, synVert)
| childNm <- Map.keys @loc.aroundMap
, synNm <- Map.keys (findWithErr2 childNm @children.collectChildrenSyns)
, let childNm' = Ident (show childNm ++ "_around") (getPos childNm)
childAttr = AltAttr _LOC childNm' True
synAttr = AltAttr childNm synNm True
childVert = findWithErr2 childAttr @loc.altAttrs
synVert = findWithErr2 synAttr @loc.altAttrs
]
loc.aroundDep2
= Seq.fromList $
[ (childVert, inhVert)
| childNm <- Map.keys @loc.aroundMap
, inhNm <- Map.keys (findWithErr2 childNm @children.collectChildrenInhs)
, let childNm' = Ident (show childNm ++ "_around") (getPos childNm)
childAttr = AltAttr _LOC childNm' True
inhAttr = AltAttr childNm inhNm False
childVert = findWithErr2 childAttr @loc.altAttrs
inhVert = findWithErr2 inhAttr @loc.altAttrs
]
lhs.aroundDep = @loc.aroundDep1 Seq.>< @loc.aroundDep2
-- Wrapping an Expression
ATTR Expression [ nt,con :{Identifier}
allfields:{[(Identifier,Type,ChildKind)]}
allnts :{[Identifier]}
attrs :{[(Identifier,Identifier)]}
options :{Options}
||
errors :{Seq Error}
usedLocals:{[Identifier]}
usedAttrs :{[(Identifier,Identifier)]}
usedFields:{[Identifier]}
textLines :{[String]}
copy : SELF
allRhsVars : {Set (Identifier,Identifier)}
]
-- appendum: filter out the syn attrs of merged children in the input attr list.
-- add the merged children to the used attr list
-- appendum: ignored the error reporting on expressions. These are already
-- reported by the separate 'ResolveLocals' pass.
SEM Expression
| Expression loc.(textLines,usedAttrs,usedLocals,usedFields)
= let mergedChildren = [ x | (_,xs) <- Map.elems @lhs.mergeMap, x <- xs ]
attrsIn = filter (\(fld,_) -> not (fld `elem` mergedChildren)) @lhs.attrs
inherited = Inh_HsTokensRoot
{ attrs_Inh_HsTokensRoot = attrsIn
, con_Inh_HsTokensRoot = @lhs.con
, allfields_Inh_HsTokensRoot = @lhs.allfields
, allnts_Inh_HsTokensRoot = @lhs.allnts
, nt_Inh_HsTokensRoot = @lhs.nt
, options_Inh_HsTokensRoot = @lhs.options
}
synthesized = wrap_HsTokensRoot (sem_HsTokensRoot (HsTokensRoot @tks)) inherited
in case synthesized of
Syn_HsTokensRoot
{ textLines_Syn_HsTokensRoot = textLines
, usedAttrs_Syn_HsTokensRoot = usedAttrs
, usedLocals_Syn_HsTokensRoot = usedLocals
, usedFields_Syn_HsTokensRoot = usedFields
} -> let extraAttrs = [ (src,attr)
| (fld,attr) <- usedAttrs, let mbMerged = Map.lookup fld @lhs.mergeMap, isJust mbMerged
, let (Just (_, srcs)) = mbMerged, src <- srcs ]
usedAttrs' = usedAttrs ++ extraAttrs
in (textLines,usedAttrs',usedLocals,usedFields)
lhs.errors = Seq.empty
lhs.allRhsVars = Set.fromList @loc.usedAttrs
`Set.union`
Set.fromList [ (_LOC, l) | l <- @loc.usedLocals]
`Set.union`
Set.fromList [ (_FIELD, fld) | fld <- @loc.usedFields]
-------------------------------------
-- NT-Attributes
-------------------------------------
ATTR Nonterminals Nonterminal
[ | acount : Int | ntattrs USE {Seq.><} {Seq.empty} : {Seq (Vertex,NTAttr)}
aranges USE {Seq.><} {Seq.empty} : {Seq (Int,Int,Int)}]
SEM Grammar
| Grammar nonts.acount = 0
SEM Nonterminal
| Nonterminal loc.ntattrs = [ NTAInh @nt inh tp | (inh,tp) <- Map.assocs @inh ]
++ [NTASyn @nt syn tp | (syn,tp) <- Map.assocs @syn ]
lhs.ntattrs = Seq.fromList (zip [@lhs.acount ..] @ntattrs)
lhs.acount = @lhs.acount + Map.size @inh + Map.size @syn
lhs.aranges = Seq.singleton
(@lhs.acount
,@lhs.acount + Map.size @inh
,@lhs.acount + Map.size @syn + Map.size @inh - 1)
------------------------------------------------------------------
-- Pass structure up
------------------------------------------------------------------
ATTR Nonterminals Nonterminal [ | | nonts USE {++} {[]} : {[(NontermIdent,[ConstructorIdent])]} ]
SEM Nonterminal
| Nonterminal lhs.nonts = [(@nt,@prods.cons)]
ATTR Productions Production [ | | cons USE {++} {[]} : {[ConstructorIdent]} ]
SEM Production
| Production lhs.cons = [@con]
------------------------------------------------------------------
-- Collect type signatures
------------------------------------------------------------------
ATTR TypeSigs TypeSig [ | typeSigs : {Map Identifier Type} | ]
SEM Production
| Production typeSigs.typeSigs = Map.empty
SEM TypeSig
| TypeSig lhs.typeSigs = Map.insert @name @tp @lhs.typeSigs
ATTR Rules Rule Patterns Pattern [ allTypeSigs : {Map Identifier Type} | | ]
SEM Production
| Production rules.allTypeSigs = @typeSigs.typeSigs
------------------------------------------------------------------
-- Invoking sequential computation
------------------------------------------------------------------
SEM Grammar
| Grammar loc.ruleTable = Array.array (0,@nonts.vcount-1) (toList @nonts.rules)
loc.attrTable = Array.array (0,@nonts.acount-1) (toList @nonts.ntattrs)
loc.attrVertex = Map.fromList (map swap (toList @nonts.ntattrs))
loc.tdpToTds = [ (s, maybe (-1) (\v -> findWithErr1 "Grammar.tdpToTds" v @attrVertex) (ntattr cr))
| (s,cr) <- toList @nonts.rules]
loc.tdsToTdp = let eq (_,v) (_,v') = v == v'
conv ((s,v):svs) | v == -1 = Nothing
| otherwise = Just (v,s:map fst svs)
in mapMaybe conv (eqClasses eq @tdpToTds)
loc.directDep = toList (@nonts.directDep Seq.>< @nonts.additionalDep)
loc.instDep = toList @nonts.instDep
loc.aroundDep = toList @nonts.aroundDep
loc.mergeDep = toList @nonts.mergeDep
loc.info = let def [] = -1
def (v:vs) = v
in Info { tdsToTdp = Array.array (0,@nonts.acount-1) @tdsToTdp
, tdpToTds = Array.array (0,@nonts.vcount-1) @tdpToTds
, attrTable = @attrTable
, ruleTable = @ruleTable
, lmh = toList @nonts.aranges
, nonts = @nonts.nonts
, wraps = @wrappers
}
loc.(cInterfaceMap,cVisitsMap,cyclesErrors) =
case computeSequential @info @directDep (@instDep ++ @aroundDep ++ @loc.mergeDep) of
CycleFree cim cvm -> ( cim
, cvm
, []
)
LocalCycle errs -> ( error "No interfaces for AG with local cycles"
, error "No visit sub-sequences for AG with local cycles"
, map (localCycleErr @ruleTable (visit @lhs.options)) errs
)
InstCycle errs -> ( error "No interfaces for AG with cycles through insts"
, error "No visit sub-sequences for AG with cycles through insts"
, map (instCycleErr @ruleTable (visit @lhs.options)) errs
)
DirectCycle errs -> ( error "No interfaces for AG with direct cycles"
, error "No visit sub-sequences for AG with direct cycles"
, directCycleErrs @attrTable @ruleTable (visit @lhs.options) errs
)
InducedCycle cim errs -> ( cim
, error "No visit sub-sequences for AG with induced cycles"
, inducedCycleErrs @attrTable @ruleTable cim errs
)
lhs.errors = (if withCycle @lhs.options then Seq.fromList @cyclesErrors else Seq.empty)
Seq.>< @nonts.errors
------------------------------------------------------------------
-- Generate CGrammar
------------------------------------------------------------------
-- Pass InterfaceMap down and select the Interface in the Nonterminal
ATTR Nonterminals Nonterminal [ cInterfaceMap : CInterfaceMap | | ]
SEM Nonterminal
| Nonterminal loc.cInter = if @lhs.o_dovisit
then findWithErr1 "Nonterminal.cInter" @nt @lhs.cInterfaceMap
else CInterface [CSegment @inh @syn]
-- Pass VisitMap down and select the CVisits in the Production
ATTR Nonterminals Nonterminal Productions Production [ cVisitsMap : CVisitsMap | | ]
SEM Production
| Production loc.cVisits = if @lhs.o_dovisit
then let prodsVisitsMap = findWithErr1 "Production.cVisits.nt" @lhs.nt @lhs.cVisitsMap
visits = findWithErr1 "Production.cVisits.con" @con prodsVisitsMap
in visits
else let vss = nubBy eqCRuleDefines @gathRules ++ @children.singlevisits
in [CVisit @lhs.inh @lhs.syn vss [] False]
-- Declarations for single visits
ATTR Child Children [ | | singlevisits USE {++} {[]}: {[CRule]}]
SEM Child
| Child lhs.singlevisits = if @maptolocal
then []
else [CChildVisit @name (getNtName @tp) 0 @loc.inh @loc.syn True]
-- Now just build the CGrammar
SEM Grammar [ | | output : CGrammar ]
| Grammar lhs.output = CGrammar @typeSyns @derivings @wrappers @nonts.cNonterminals @pragmas @paramMap @contextMap @quantMap @loc.aroundMap @loc.mergeMap @loc.o_dovisit
SEM Nonterminals [ | | cNonterminals : CNonterminals ]
| Cons lhs.cNonterminals = @hd.cNonterminal : @tl.cNonterminals
| Nil lhs.cNonterminals = []
SEM Nonterminal [ | | cNonterminal : CNonterminal ]
| Nonterminal lhs.cNonterminal = CNonterminal @nt @params @inh @syn @prods.cProductions @cInter
SEM Productions [ | | cProductions : CProductions ]
| Cons lhs.cProductions = @hd.cProduction : @tl.cProductions
| Nil lhs.cProductions = []
SEM Production [ | | cProduction : CProduction ]
| Production lhs.cProduction = CProduction @con @cVisits @children.fields @children.terminals
SEM Grammar
| Grammar loc.aroundMap = Map.map (Map.map Map.keysSet) @aroundsMap
loc.mergeMap = Map.map (Map.map (Map.map (\(nt,srcs,_) -> (nt,srcs)))) @mergeMap
-- Collect terminals
ATTR Children Child [ | | terminals USE {++} {[]} : {[Identifier]} ]
SEM Child
| Child lhs.terminals = if @maptolocal
then [@name]
else []
-- Collecting nts
ATTR Nonterminal Nonterminals
Production Productions
Rule Rules
Child Children [allnts:{[Identifier]} | | ]
SEM Grammar
| Grammar nonts.allnts = map fst (@nonts.nonts)
-- Collecting fields
ATTR Rule Rules
Child Children [allfields:{[(Identifier,Type,ChildKind)]} attrs:{[(Identifier,Identifier)]} | | ]
SEM Production
| Production loc.allfields = @children.fields
.attrs = map ((,) _LOC) @rules.locVars ++
map ((,) _INST) @rules.instVars ++
map ((,) _LHS) @inhnames ++
concat [map ((,) nm) (Map.keys as) | (nm,_,as) <- @children.attributes]
.inhnames = Map.keys @lhs.inh
.synnames = Map.keys @lhs.syn
ATTR Children [ | | attributes USE {++} {[]} : {[(Identifier,Attributes,Attributes)]} ]
SEM Child [ | | attributes:{[(Identifier,Attributes,Attributes)]} ]
| Child lhs.attributes = [(@name, @loc.inh, @loc.syn)]
SEM Child [ | | field : {(Identifier,Type,ChildKind)} ]
| Child lhs.field = (@name, @tp, @kind)
SEM Children [ | | fields : {[(Identifier,Type,ChildKind)]} ]
| Cons lhs.fields = @hd.field : @tl.fields
| Nil lhs.fields = []
ATTR Rules Rule Patterns Pattern [ | | locVars USE {++} {[]}:{[Identifier]} instVars USE {++} {[]} : {[Identifier]} ]
SEM Pattern
| Alias lhs.locVars = if @field == _LOC
then [@attr]
else []
lhs.instVars = if @field == _INST
then [@attr]
else []
{
swap (a,b) = (b,a)
showPath :: Table CRule -> [Vertex] -> [String]
showPath ruleTable path
= let look a | inRange (bounds ruleTable) a = [showOrigin (ruleTable ! a)]
| otherwise = ["Vertex " ++ show a]
showOrigin cr | getHasCode cr && getName (getAttr cr) /= "self" = prettyCRule cr ++ " (" ++ show (getPos (getAttr cr)) ++ ")"
| otherwise = prettyCRule cr
in concatMap look path
showPathLocal :: Table CRule -> [Vertex] -> [String]
showPathLocal _ [] = []
showPathLocal ruleTable xs = showP (xs++[-1])
where showP [] = []
showP (v1:v2:vs) = let line = step v1 v2
lines = showP vs
in line:lines
step v1 v2 = " - " ++ a1
where r1 = ruleTable ! v1
a1 = show (getAttr r1)
limitTo :: Int -> [String] -> [String]
limitTo _ [] = []
limitTo 0 _ = ["....etcetera, etcetera...."]
limitTo n (x:xs) = x : limitTo (n-1) xs
showPathNice :: Table CRule -> [Vertex] -> [String]
showPathNice _ [] = []
showPathNice ruleTable xs = limitTo 100 (showP ((-1):xs++[-1]))
where [maxf, maxa, maxn, maxc] = maxWidths ruleTable (take 100 xs)
showP [] = []
showP (v1:v2:vs) = let line = step v1 v2
lines = showP vs
in if null line then lines else line:lines
step v1 v2 | last && first = induced
| last && isSyn r1 = "pass up " ++ alignR maxf "" ++ " " ++ alignL maxa a1 ++ " in " ++ alignR maxn n1 ++ "|" ++ c1 ++ induced
| first&& not(isSyn r2) = "get from above " ++ alignR maxf "" ++ " " ++ alignL maxa a2 ++ " in " ++ alignR maxn n2 ++ "|" ++ c2
| last = "pass down " ++ alignR maxf f1 ++ "." ++ a1 ++ induced
| isSyn r2 = "get from below " ++ alignR maxf f2 ++ "." ++ alignL maxa a2 ++ " in " ++ alignR maxn n2 ++ "|" ++ c2
| isLocal r1 = if head a1 == '_'
then ""
else "calculate " ++ alignR maxf "loc" ++ "." ++ a1
| otherwise = "pass down " ++ alignR maxf f1 ++ "." ++ alignL maxa a1 ++ " to " ++ alignR maxn n2 ++ "|" ++ c2
where
first = v1<0
last = v2<0
r1 = ruleTable ! v1
r2 = ruleTable ! v2
a1 = show (getAttr r1)
a2 = show (getAttr r2)
f1 = show (getField r1)
f2 = show (getField r2)
n1 = show (getLhsNt r1)
n2 = show (getLhsNt r2)
c1 = show (getCon r1)
c2 = show (getCon r2)
induced | v2== -2 = " INDUCED dependency to "
| otherwise = ""
maxWidths ruleTable vs
= map maximum (transpose (map getWidth vs))
where getWidth v | v<0 = [0,0,0,0]
| otherwise = map (length . show . ($ (ruleTable!v))) [getField, getAttr, getLhsNt, getCon]
alignL n xs | k<n = xs ++ replicate (n-k) ' '
| otherwise = xs
where k = length xs
alignR n xs | k<n = replicate (n-k) ' ' ++ xs
| otherwise = xs
where k = length xs
localCycleErr :: Table CRule -> Bool -> Route -> Error
localCycleErr ruleTable o_visit (s:path)
= let cr = ruleTable ! s
attr = getAttr cr
nt = getLhsNt cr
con = getCon cr
in LocalCirc nt con attr o_visit (showPathLocal ruleTable path)
instCycleErr :: Table CRule -> Bool -> Route -> Error
instCycleErr ruleTable o_visit (s:path)
= let cr = ruleTable ! s
attr = getAttr cr
nt = getLhsNt cr
con = getCon cr
in InstCirc nt con attr o_visit (showPathLocal ruleTable path)
directCycleErrs :: Table NTAttr -> Table CRule -> Bool -> [EdgeRoutes] -> [Error]
directCycleErrs attrTable ruleTable o_visit xs
= let getNont v = case attrTable ! v of
NTASyn nt _ _ -> nt
NTAInh nt _ _ -> nt
getAttr v = case attrTable ! v of
NTASyn _ a _ -> a
NTAInh _ a _ -> a
sameNont ((v1,_),_,_) ((v2,_),_,_) = getNont v1 == getNont v2
procCycle ((v1,v2),p1,p2) = ((getAttr v1, getAttr v2), showPathNice ruleTable p1, showPathNice ruleTable p2)
wrapGroup gr@(((v1,_),_,_):_) = DirectCirc (getNont v1) o_visit (map procCycle gr)
in map wrapGroup (groupBy sameNont xs)
inducedCycleErrs :: Table NTAttr -> Table CRule -> CInterfaceMap -> [EdgeRoutes] -> [Error]
inducedCycleErrs attrTable ruleTable cim xs
= let getNont v = case attrTable ! v of
NTASyn nt _ _ -> nt
NTAInh nt _ _ -> nt
getAttr v = case attrTable ! v of
NTASyn _ a _ -> a
NTAInh _ a _ -> a
sameNont ((v1,_),_,_) ((v2,_),_,_) = getNont v1 == getNont v2
procCycle ((v1,v2),p1,p2) = ((getAttr v1, getAttr v2), showPathNice ruleTable p1, showPathNice ruleTable p2)
wrapGroup gr@(((v1,_),_,_):_) = InducedCirc (getNont v1) (findWithErr1 "inducedCycleErr.cinter" (getNont v1) cim) (map procCycle gr)
in map wrapGroup (groupBy sameNont xs)
}