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 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) }