MODULE {Transform} {transform} {} PRAGMA genlinepragmas INCLUDE "AstAG.ag" imports { import Common import Ast import Errs import Data.Sequence(Seq) import qualified Data.Sequence as Seq import Data.Map(Map) import qualified Data.Map as Map import Data.IntMap(IntMap) import qualified Data.IntMap as IntMap import Data.Set(Set) import qualified Data.Set as Set import Env import Data.Monoid import Data.List(nub, isPrefixOf, intersect, sortBy, partition, groupBy, sort) import Pretty import UU.Scanner.Position import Opts import Data.Maybe import Data.Char import Data.Graph import Data.Foldable(toList) import DepAnalysis import Debug.Trace(trace) } WRAPPER Program { transform :: Pos -> Opts -> Program -> (Errs, String, String, String) transform pos opts prog = (errs, txtPretty, txtTarget, txtGraph) where inh = Inh_Program { opts_Inh_Program = opts, pos_Inh_Program = pos } syn = wrap_Program sem inh sem = sem_Program prog errs = firstErrs [ errs0_Syn_Program syn , errs1_Syn_Program syn , errs2_Syn_Program syn , errs3_Syn_Program syn , errs4_Syn_Program syn , errs5_Syn_Program syn ] resPretty = pretty_Syn_Program syn txtPretty = disp resPretty 999999 "" resTarget = pp_Syn_Program syn txtTarget = disp resTarget 999999 "" resGraph = graph_Syn_Program syn txtGraph = disp resGraph 999999 "" firstErrs :: [Errs] -> Errs firstErrs [] = Seq.empty firstErrs (x:xs) = if Seq.null x then firstErrs xs else x } -- -- Transformations for various backends -- ATTR Program [ | | pp, pretty, graph : {PP_Doc} ] SEM Program | Program lhs.pp = empty -- add output for additional backends lhs.pretty = @loc.ppId lhs.graph = @loc.ppGraph INCLUDE "TargetHaskell.ag" INCLUDE "TargetJs.ag" INCLUDE "TargetGraph.ag" ATTR Program AllFinal AllDataFields Itf ItfVisits ItfVisit Attrs Attr Type [ opts : Opts | | ] ATTR Program [ pos : Pos | | ] -- -- Collect errors -- -- errs0: data-type/itf based checks -- errs1: rudamentary checks -- errs2: child checks -- errs3: attribute checks -- errs4: cycle checks SET AllDataFields = Data Cons Con Fields Field FieldType SET AllCode = AllCodeWithoutAttrs AttrTypePat AttrTypeCode SET AllCodeWithoutAttrs = Code Items Item DataSem AllVisitClauses Stmts Stmt MaybeBoundCode BoundCode Pats Pat ExprFields ExprField SemCons SemCon SemFields SemField SET AllCodeBlocksWithoutAttrs = BlocksTop Blocks Block AllCodeWithoutAttrs SET AllCodeBlocks = BlocksTop Blocks Block AllCode SET AllVisitClauses = SemVisit ClausesTop Clauses Clause SET AllFinal = AllCodeBlocks ImplStmts ImplStmt SET AllVisFinal = AllVisitClauses ImplStmts ImplStmt Stmts Stmt Pats Pat AttrTypePat AttrTypeCode ATTR Program AllCodeBlocks Data Type Cons Con Itf ItfVisits ItfVisit [ | | errs0,errs1,errs2,errs3,errs4,errs5 USE {Seq.><} {Seq.empty} : Errs ] ATTR ImplStmts ImplStmt [ | | errs2,errs3,errs4,errs5 USE {Seq.><} {Seq.empty} : Errs ] SEM Program | Program +errs0 = addDefErrs @blocks.gathItfs +errs0 = addDefErrs @blocks.gathVisits +errs0 = addDefErrs @blocks.gathInhs +errs0 = addDefErrs @blocks.gathSyns +errs1 = addDefErrs @blocks.gathNonterms +errs1 = addDefErrs @blocks.gathClauses +errs1 = addUseErrs @blocks.distItfs +errs1 = addUseErrs @blocks.distVisits +errs1 = addUseErrs @blocks.distChildDefs +errs0 = addDefErrs @blocks.gathDataCons +errs0 = addUseErrs @blocks.distDataCons +errs0 = addDefErrs' @blocks.gathDatas +errs0 = addUseErrs' @blocks.distDatas -- +errs0 = addDefErrs' @blocks.gathDataSems -- duplicate datasems allowed +errs1 = addUseErrs' @blocks.distDataSems +errs3 = addDefErrs'' @blocks.gathDefs +errs3 = addUseErrs'' @blocks.distDefs { addDefErrs :: Env QIdent v -> Errs -> Errs addDefErrs env es = Seq.fromList (map (Err_Dup . map head) ds) Seq.>< es where ds = map (map fst) (dups env) addUseErrs :: Env QIdent v -> Errs -> Errs addUseErrs env es = Seq.fromList (map (Err_Missing . map head) ms) Seq.>< es where ms = missing env addDefErrs' :: Env Ident v -> Errs -> Errs addDefErrs' env es = Seq.fromList (map Err_Dup ds) Seq.>< es where ds = map (map fst) (dups env) addUseErrs' :: Env Ident v -> Errs -> Errs addUseErrs' env es = Seq.fromList (map Err_Missing ms) Seq.>< es where ms = missing env addDefUseErrs' :: Env Ident v -> Errs -> Errs addDefUseErrs' env = addDefErrs' env . addUseErrs' env addDefErrs'' :: Env (Ident,Ident,Bool) v -> Errs -> Errs addDefErrs'' env es = Seq.fromList (map mkDupErr ds) Seq.>< es where ds = map (map fst) (dups env) mkDupErr ((c,n,b):_) = Err_DupAttr b c n addUseErrs'' :: Env (Ident,Ident,Bool) v -> Errs -> Errs addUseErrs'' env es = Seq.fromList (map mkMissErr ms) Seq.>< es where ms = missing env mkMissErr ((c,n,b):_) = Err_MissingAttr b c n addDefUseErrs'' :: Env (Ident,Ident,Bool) v -> Errs -> Errs addDefUseErrs'' env = addDefErrs'' env . addUseErrs'' env } -- -- Standard duplication checks -- { type ItfEnv = Env QIdent () } ATTR BlocksTop Blocks Block Itf ItfVisits ItfVisit [ | gathItfs : ItfEnv | ] SEM Program | Program blocks.gathItfs = emptyEnv SEM Itf | Itf +gathItfs = extend [@name] () SEM ItfVisit | Visit +gathItfs = extend @loc.coItf () ATTR ItfVisits ItfVisit Attrs Attr [ itf : {QIdent} | | ] SEM Itf | Itf visits.itf = [@name] { type VisitEnv = Env QIdent () } ATTR BlocksTop Blocks Block Itf ItfVisits ItfVisit [ | gathVisits : VisitEnv | ] SEM Program | Program blocks.gathVisits = emptyEnv SEM ItfVisit | Visit +gathVisits = extend (@name : @lhs.itf) () +gathVisits = extend (@name : @loc.coItf) () ATTR Attrs Attr [ visit : {QIdent} coItf : {QIdent} | | ] SEM ItfVisit | Visit attrs.visit = @name : @lhs.itf loc.coItf = [mkCoIdent (head @lhs.itf) @name] { mkCoIdent :: Ident -> Ident -> Ident mkCoIdent itf vis = Ident ("Co_" ++ show itf ++ "_" ++ show vis) (identPos itf) } { type AttrEnv = Env QIdent String } ATTR BlocksTop Blocks Block Itf ItfVisits ItfVisit Attrs Attr [ | gathInhs, gathSyns : AttrEnv | ] SEM Program | Program blocks.gathInhs = emptyEnv blocks.gathSyns = emptyEnv SEM Attr | Inh +gathInhs = extend (@name : @lhs.itf) @type +gathSyns = extend (@name : @lhs.coItf) @type | Syn +gathSyns = extend (@name : @lhs.itf) @type +gathInhs = extend (@name : @lhs.coItf) @type ATTR VisitAttrs VisitAttr [ | gathChns : AttrEnv | ] SEM SemVisit | Visit attrs.gathChns = emptyEnv +errs0 = addDefErrs @attrs.gathChns SEM VisitAttr | Chn +gathChns = extend [@name] @type { type NontermEnv = Env QIdent () type ClausesEnv = Env QIdent () type DataSemEnv = Env Ident () } ATTR AllCodeBlocks [ | gathNonterms : NontermEnv gathClauses : ClausesEnv | ] ATTR AllCode ImplStmts ImplStmt [ nonterm : {QIdent} | | ] ATTR ImplStmts ImplStmt [ gathNonterms : NontermEnv gathClauses : ClausesEnv | | ] SEM Block | Section code.nonterm = [ident ""] | Item item.nonterm = [ident ""] | DataSem sem.nonterm = [ident ""] SEM DataSem | Sem clauses.nonterm = [@tp] SEM Item | Sem CoSem first.nonterm = [@name] SEM Program | Program blocks.gathNonterms = emptyEnv blocks.gathClauses = emptyEnv SEM Item | Sem CoSem +gathNonterms = extend [@name] () SEM Clause | Clause +gathClauses = extend (@name : @lhs.nonterm) () ATTR ClausesTop Clauses Clause [ | | gathClauseNames USE {`Set.union`} {Set.empty} : {Set Ident} ] SEM Clause | Clause lhs.gathClauseNames = Set.singleton @name ATTR AllCodeBlocks [ | gathDataSems : DataSemEnv | ] ATTR AllCodeBlocks [ | distDataSems : DataSemEnv | ] ATTR ImplStmts ImplStmt [ distDataSems : DataEnv | | ] SEM Program | Program blocks.gathDataSems = emptyEnv blocks.distDataSems = @blocks.gathDataSems SEM DataSem | Sem +gathDataSems = extend @tp () ATTR AllCodeBlocks ImplStmts ImplStmt [ allVisits : {Set Ident} | | ] SEM Program | Program blocks.allVisits = Set.empty SEM Item | Sem CoSem first.allVisits = Set.union (Set.fromList @loc.nextVisits) @lhs.allVisits SEM DataSem | Sem clauses.allVisits = Set.union (Set.fromList @loc.nextVisits) @lhs.allVisits SEM Stmt | Attach -- check that visits and children have distinct names +errs1 = ( if @name `Set.member` @lhs.allVisits then Seq.singleton $ Err_NameClash @name else Seq.empty ) Seq.>< ATTR Cons Con Fields Field ExprFields ExprField [ data : Ident | | ] ATTR Fields Field ExprFields ExprField [ con : Ident | | ] SEM Data | Data cons.data = @name SEM Con | Con fields.con = @name SEM Item | Construct fields.data = @data SEM Item | Construct fields.con = @con { type DataEnv = Env Ident () type ConEnv = Env QIdent FieldEnv type FieldEnv = Env Ident (Int,Either Ident String) } ATTR BlocksTop Blocks Block Data Cons Con Type [ | gathDataCons : ConEnv | ] ATTR AllCodeBlocks [ | distDataCons : ConEnv | ] ATTR ImplStmts ImplStmt [ distDataCons : ConEnv | | ] SEM Program | Program blocks.gathDataCons = emptyEnv blocks.distDataCons = @blocks.gathDataCons SEM Con | Con +gathDataCons = extend [@name, @lhs.data] @fields.gathFields ATTR BlocksTop Blocks Block Data Type [ | gathDatas : DataEnv | ] SEM Program | Program blocks.gathDatas = emptyEnv SEM Data | Data +gathDatas = extend @name () ATTR Fields Field [ | gathFields : FieldEnv | ] SEM Con | Con fields.gathFields = emptyEnv +errs0 = addDefErrs' @fields.gathFields SEM Field | Field +gathFields = extend @name (@lhs.nr, @type.fldType) ATTR Cons Con Fields Field [ | nr : Int | ] SEM Data | Data cons.nr = 0 SEM Con | Con fields.nr = 1 + @lhs.nr SEM Field | Field lhs.nr = 1 + @lhs.nr ATTR FieldType [ | | fldType : {Either Ident String} ] SEM FieldType | Term lhs.fldType = Right @type | Nonterm lhs.fldType = Left @name ATTR ExprFields ExprField [ fieldOrder : {Map Ident Int} | gathFields : FieldEnv | ] SEM Item | Construct fields.gathFields = emptyEnv loc.gathFieldEnv = foldr (\(nm,_) -> snd . find nm (0,Right "")) @fields.gathFields @loc.fields +errs0 = addDefErrs' @loc.gathFieldEnv +errs0 = addUseErrs' @loc.gathFieldEnv fields.fieldOrder = Map.fromList (zip (map fst @loc.fields) [1..]) SEM ExprField | Field +gathFields = extend @name (0,Right "") loc.fieldIndex = Map.findWithDefault 0 @name @lhs.fieldOrder { type VarsEnv = Env Ident () } ATTR Vars Var Cons Con ItfVisits ItfVisit [ | gathVarsEnv : VarsEnv | ] SEM Var | Var +gathVarsEnv = extend @name () SEM Type | Alias vars.gathVarsEnv = emptyEnv +errs1 = addDefErrs' @vars.gathVarsEnv SEM Data | Data vars.gathVarsEnv = emptyEnv +errs1 = addDefErrs' @cons.gathVarsEnv SEM Cons | Cons (hd.gathVarsEnv, tl.gathVarsEnv) = split @lhs.gathVarsEnv (lhs.gathVarsEnv, loc.locGathVarsEnv) = merge @hd.gathVarsEnv @tl.gathVarsEnv +errs1 = addDefErrs' @loc.locGathVarsEnv SEM Itf | Itf vars.gathVarsEnv = emptyEnv +errs1 = addDefErrs' @visits.gathVarsEnv SEM ItfVisits | Cons (hd.gathVarsEnv, tl.gathVarsEnv) = split @lhs.gathVarsEnv (lhs.gathVarsEnv, loc.locGathVarsEnv) = merge @hd.gathVarsEnv @tl.gathVarsEnv +errs1 = addDefErrs' @loc.locGathVarsEnv SEM Item | Sem CoSem vars.gathVarsEnv = emptyEnv +errs1 = addDefErrs' @vars.gathVarsEnv SEM DataSem | Sem vars.gathVarsEnv = emptyEnv +errs1 = addDefErrs' @vars.gathVarsEnv -- -- Standard usage checks -- ATTR AllCodeBlocks [ | distItfs : ItfEnv | ] ATTR ImplStmts ImplStmt [ distItfs : ItfEnv | | ] SEM Program | Program blocks.distItfs = @blocks.gathItfs SEM Item | Sem CoSem +distItfs = snd . find [@tp] () SEM Stmt | Attach +distItfs = snd . find [@type] () SEM DataSem | Sem +distItfs = snd . find [@tp] () ATTR AllCode Pats Pat AttrTypePat AttrTypeCode ImplStmts ImplStmt [ itf : QIdent coItf : Ident | | ] SEM Block | Section Item DataSem loc.itf = [ident ""] loc.coItf = ident "" SEM DataSem | Sem clauses.itf = [@tp] SEM Item | Sem first.itf = [@tp] | CoSem first.itf = [@loc.coItf] loc.coItf = mkCoIdent @tp @visit first.coItf = @tp ATTR AllCodeBlocks [ | distVisits : VisitEnv | ] ATTR ImplStmts ImplStmt [ distVisits : VisitEnv | | ] SEM Program | Program blocks.distVisits = @blocks.gathVisits SEM SemVisit | Visit +distVisits = snd . find (@name : @lhs.itf) () SEM Stmt | Invoke loc.unqualChildItf = head @loc.childItf loc.childVisits = Map.findWithDefault [] @loc.unqualChildItf @lhs.distVisitOrder +errs1 = ( if null @loc.childVisits || @visit `elem` @loc.childVisits then Seq.empty else Seq.singleton (Err_UndefVisit @name @visit @loc.childVisits)) Seq.>< | Attach loc.childVisits = Map.findWithDefault [] @type @lhs.distVisitOrder loc.visit = case @mbVisit of Nothing -> if null @loc.childVisits then Ident "" @pos else head @loc.childVisits Just v -> v +errs1 = ( if null @loc.childVisits || @loc.visit `elem` @loc.childVisits then Seq.empty else Seq.singleton (Err_UndefVisit @name @loc.visit @loc.childVisits)) Seq.>< SEM ImplStmt | Invoke loc.childVisits = Map.findWithDefault [] @itf @lhs.distVisitOrder SEM Pat | AttrCon (loc.fieldEnv, lhs.distDataCons) = find [@con, @dt] emptyEnv @lhs.distDataCons loc.fields = sortAssocs $ assocs @loc.fieldEnv { sortAssocs :: [(Ident, (Int, a))] -> [(Ident, a)] sortAssocs = map (\(nm,(_,tp)) -> (nm,tp)) . sortBy (\(_,(n1,_)) (_,(n2,_)) -> compare n1 n2) } SEM Item | Construct (loc.fieldEnv, lhs.distDataCons) = find [@con, @data] emptyEnv @lhs.distDataCons loc.fields = sortAssocs $ assocs @loc.fieldEnv SEM Stmt | Attach +distDataSems = if @code.isJust then id else snd . find @type () ATTR AllCodeBlocks Type AliasType AllDataFields [ | distDatas : DataEnv | ] ATTR ImplStmts ImplStmt [ distDatas : DataEnv | | ] -- should perhaps turn into a changed attr SEM Program | Program blocks.distDatas = @blocks.gathDatas SEM DataSem | Sem +distDatas = snd . find @tp () +errs2 = if Map.member astIdent $ Map.findWithDefault Map.empty @loc.firstVisit $ Map.findWithDefault Map.empty @tp @lhs.distVisitInhAttrs then id else (Seq.singleton (Err_Missing [replPos @pos astIdent]) Seq.><) SEM AliasType | Prod +distDatas = \env -> foldr (\tp -> snd . find tp ()) env @fields | List +distDatas = snd . find @type () | Maybe +distDatas = snd . find @type () SEM FieldType | Nonterm +distDatas = snd . find @name () SEM Item | Construct +distDatas = snd . find @data () SEM Pat | AttrCon +distDatas = snd . find @dt () { astIdent :: Ident astIdent = Ident "ast" noPos } -- -- Children defined -- ATTR AllCodeBlocksWithoutAttrs [ | gathChildDefs : {Env QIdent (QIdent, QIdent)} | ] ATTR AllCodeBlocks [ | distChildDefs : {Env QIdent (QIdent,QIdent)} | ] ATTR ImplStmts ImplStmt [ gathChildDefs, distChildDefs : {Env QIdent (QIdent,QIdent)} | | ] -- inherit only SEM Program | Program blocks.gathChildDefs = emptyEnv blocks.distChildDefs = @blocks.gathChildDefs SEM Item | Sem CoSem loc.firstVisit = if null @loc.nextVisits then unknIdent else head @loc.nextVisits first.gathChildDefs = extend locQIdent (locQIdent, locQIdent) $ extend visQIdent (visQIdent, visQIdent) $ extend lhsQIdent ([@tp], [@loc.firstVisit, @tp]) $ enter @lhs.gathChildDefs (lhs.gathChildDefs, loc.localChildDefs) = leave @first.gathChildDefs -- don't addDefErrs on @loc.localChildDefs first.distChildDefs = enterWith @loc.localChildDefs @lhs.distChildDefs (lhs.distChildDefs, loc.localChildDefs') = leave @first.distChildDefs +errs1 = addUseErrs @loc.localChildDefs' | Attr ((loc.childItf, loc.startVisit), lhs.distChildDefs) = find [@child] (unknQIdent,unknQIdent) @lhs.distChildDefs | Detach ((loc.childItf, loc.startVisit), lhs.distChildDefs) = find [@name] (unknQIdent,unknQIdent) @lhs.distChildDefs SEM DataSem | Sem clauses.gathChildDefs = extend locQIdent (locQIdent, locQIdent) $ extend visQIdent (visQIdent, visQIdent) $ extend lhsQIdent ([@tp], [@loc.firstVisit, @tp]) $ enter @lhs.gathChildDefs (lhs.gathChildDefs, loc.localChildDefs) = leave @clauses.gathChildDefs -- don't addDefErrs on @loc.localChildDefs clauses.distChildDefs = enterWith @loc.localChildDefs @lhs.distChildDefs (lhs.distChildDefs, loc.localChildDefs') = leave @clauses.distChildDefs +errs1 = addUseErrs @loc.localChildDefs' SEM Clauses | Cons (hd.gathChildDefs, tl.gathChildDefs) = split @lhs.gathChildDefs (lhs.gathChildDefs, loc.gathLChildDefs) = merge @hd.gathChildDefs @tl.gathChildDefs (hd.distChildDefs, tl.distChildDefs) = splitWith @loc.gathLChildDefs @lhs.distChildDefs (lhs.distChildDefs, loc.distLChildDefs) = merge @hd.distChildDefs @tl.distChildDefs +errs1 = addUseErrs @loc.distLChildDefs SEM Stmt | Attach +gathChildDefs = extend [@name] ([@type],[@loc.visit,@type]) loc.allAttaches = findAll [@name] @lhs.distChildDefs loc.initType = head $ last ([@type] : map fst @loc.allAttaches) +errs1 = if @type /= @loc.initType then (Err_TypeConflict @type @loc.initType Seq.<|) else id | Invoke ((loc.childItf, loc.startVisit), code.distChildDefs) = find [@name] (unknQIdent,unknQIdent) @lhs.distChildDefs SEM Pat | Attr ((loc.childItf, loc.startVisit), lhs.distChildDefs) = find [@child] (unknQIdent,unknQIdent) @lhs.distChildDefs | AttrCon +gathChildDefs = extendTail [@name] (locQIdent,locQIdent) ((loc.childItf, loc.startVisit), lhs.distChildDefs) = find [@name] (unknQIdent,unknQIdent) @lhs.distChildDefs { unknIdent :: Ident unknIdent = ident "" unknQIdent :: QIdent unknQIdent = [unknIdent] locQIdent :: QIdent locQIdent = [locIdent] lhsQIdent :: QIdent lhsQIdent = [lhsIdent] visQIdent :: QIdent visQIdent = [visIdent] } -- -- Compute renames for each clause/visit -- -- unchecked: source name must be in interface of child -- unchecked: duplicate renames -- unchecked: new name not in interface of child -- { type RenameMap = Map Ident (Map Ident Ident) } ATTR Stmts Stmt [ | | gathRenames USE {`unionWithUnion`} {mempty} : RenameMap ] SEM Stmt | Rename lhs.gathRenames = Map.singleton @child @subst.gathRenames ATTR Renames Rename [ | | gathRenames USE {`mappend`} {mempty} : {Map Ident Ident} ] SEM Rename | Rename lhs.gathRenames = Map.fromList [ (@source, @dest), (@dest, @source) ] ATTR AllFinal [ distRenames : RenameMap | | ] SEM Program | Program blocks.distRenames = Map.empty SEM DataSem | Sem clauses.distRenames = Map.empty SEM Item | Sem CoSem first.distRenames = Map.empty SEM Clause | Clause loc.distRenames = @stmts.gathRenames `unionWithUnion` @lhs.distRenames SEM SemVisit | Visit loc.distRenames = @stmts.gathRenames `unionWithUnion` @lhs.distRenames SEM SemVisit | Internal loc.distRenames = @stmts.gathRenames `unionWithUnion` @lhs.distRenames { renameAttr :: RenameMap -> Ident -> Ident -> Ident renameAttr mp child nm = Map.findWithDefault nm nm $ Map.findWithDefault Map.empty child mp renameAttrFwd = renameAttr renameAttrBwd = renameAttr } SEM Item | Attr loc.origName = renameAttrBwd @lhs.distRenames @child @name SEM Pat | Attr loc.origName = renameAttrBwd @lhs.distRenames @child @name -- -- Add and check additional instructions (children, etc.) for clauses -- ATTR SemVisit ClausesTop Clauses Clause [ clauseExtras : {Map Ident Stmts} | | ] SEM Clause | Clause next.clauseExtras = Map.empty SEM Item | Sem CoSem first.clauseExtras = Map.empty SEM DataSem | Sem clauses.clauseExtras = @cons.clauseExtras loc.consMap = Map.findWithDefault Map.empty @tp @lhs.distDataMap inst.cons : SemCons inst.cons = [ SemCon_Con @pos (replPos @pos c) [ SemField_Field @pos (replPos @pos nm) tp | (nm,tp) <- sortAssocs $ Map.assocs fs ] | (c,fs) <- sortAssocs $ Map.assocs @loc.consMap ] cons.itf = [@tp] { trim :: String -> String trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace } -- (Ident (trim (either show id tp)) @pos ATTR SemCons SemCon [ | | clauseExtras USE {`Map.union`} {Map.empty} : {Map Ident Stmts} ] ATTR SemFields SemField [ | | clauseExtras USE {++} {[]} : Stmts ] SEM SemCon | Con lhs.clauseExtras = Map.singleton @name ( Stmt_Eval Mode_Match (Pat_AttrCon @name (replPos @pos locIdent) (head @lhs.itf)) (BoundCode_Code Bind_Fun @pos $ Code_Code [Item_Attr @pos (replPos @pos lhsIdent) (replPos @pos astIdent) ]) : @fields.clauseExtras ) SEM SemField | Field loc.isNonterm = case @type of Left nt -> Map.member nt @lhs.distDataMap Right _ -> False +distDataSems = case @type of Left nt | @loc.isNonterm -> snd . find nt () _ -> id lhs.clauseExtras = case @type of Left nt | @loc.isNonterm -> [ Stmt_Attach @pos Nothing @name nt Nothing , Stmt_Eval Mode_Assert (Pat_Attr @name (replPos @pos astIdent)) (BoundCode_Code Bind_Fun @pos (Code_Code [ Item_Attr @pos (replPos @pos locIdent) @name ])) ] _ -> [] -- -- Check clauses defined when having this extraMap -- SEM ClausesTop | Top +errs0 = if Map.null @lhs.clauseExtras then id else let reqKeys = Map.keysSet @lhs.clauseExtras impKeys = @clauses.gathClauseNames diffSet = (impKeys `Set.difference` reqKeys) `Set.union` (reqKeys `Set.difference` impKeys) diff = Set.elems diffSet errs = map (\nm -> Err_MissingClause (head @lhs.itf) nm) diff in (Seq.fromList errs Seq.><) -- NOTE: This *must* be before inst.impls, otherwise the copy rule for available attributes goes wrong SEM Clause | Clause inst.stmts : T_Stmts inst.stmts = \stmts -> foldr (\s r -> sem_Stmts_Cons (sem_Stmt s) r) stmts @loc.extraStmts loc.extraStmts = Map.findWithDefault [] @name @lhs.clauseExtras -- -- Count visits -- ATTR AllVisitClauses [ visitNr : Int | | ] SEM Item | Sem CoSem first.visitNr = 1 SEM DataSem | Sem clauses.visitNr = 1 SEM SemVisit | Visit loc.visitNr = @lhs.visitNr + 1 -- -- Visit order -- ATTR BlocksTop Blocks Block Itf ItfVisits ItfVisit [ | | gathVisitOrder USE {`mappend`} {mempty} : {Map Ident [Ident]} ] ATTR ItfVisits ItfVisit [ | | gathVisitsOrder USE {++} {[]} : {[Ident]} ] SEM Itf | Itf +gathVisitOrder = Map.insert @name @visits.gathVisitsOrder SEM ItfVisit | Visit lhs.gathVisitsOrder = [@name] lhs.gathVisitOrder = Map.singleton (head @loc.coItf) [@name] ATTR AllCodeBlocks ImplStmts ImplStmt [ distVisitOrder : {Map Ident [Ident]} doneVisits : {[Ident]} | | ] ATTR SemVisit ClausesTop Clauses Clause [ nextVisits : {[Ident]} | | ] SEM Program | Program blocks.distVisitOrder = @blocks.gathVisitOrder SEM Item | Sem loc.nextVisits = Map.findWithDefault [] @tp @lhs.distVisitOrder | CoSem loc.nextVisits = Map.findWithDefault [] @loc.coItf @lhs.distVisitOrder | Detach loc.visitOrder = Map.findWithDefault [] @loc.unqualChildItf @lhs.distVisitOrder SEM AttrTypePat | Child loc.visitOrder = Map.findWithDefault [] @lhs.childItf @lhs.distVisitOrder SEM AttrTypeCode | Child loc.visitOrder = Map.findWithDefault [] @lhs.childItf @lhs.distVisitOrder SEM DataSem | Sem loc.visits = Map.findWithDefault [] @tp @lhs.distVisitOrder loc.nextVisits = @loc.visits loc.firstVisit = case @loc.visits of [] -> Ident "unknown" @pos (x:_) -> x SEM Program | Program blocks.doneVisits = [] SEM Item | Sem loc.doneVisits = [] | CoSem loc.doneVisits = [] SEM DataSem | Sem loc.doneVisits = [] SEM SemVisit | Visit loc.doneVisits = @name : @lhs.doneVisits -- visits of the interface done -- Insert empty visits to match the visits actually in the AST SEM SemVisit | Visit loc.unqualItf = head @lhs.itf loc.itfVisits = Map.findWithDefault [] @loc.unqualItf @lhs.distVisitOrder (loc.sequenceErrs, clauses.nextVisits) = checkVisitSequence @pos @name @lhs.nextVisits +errs0 = if not (@name `elem` @loc.itfVisits) then (Err_UndeclVisit @pos @name @loc.unqualItf Seq.<|) else (@loc.sequenceErrs Seq.><) | Internal -- don't eat any of the expected visits loc.name = Ident (show @name ++ "_int" ++ show @loc.lexOrder) (identPos @name) loc.unqualItf = head @lhs.itf | Impl inst.actual : SemVisit inst.actual = prependEmptyVisits @lhs.basename @lhs.masterPos SemVisit_End @lhs.nextVisits | Prependable loc.missingVisits = if elem @name @lhs.nextVisits then takeWhile (/= @name) @lhs.nextVisits else [] loc.remainingVisits = drop (length @loc.missingVisits) @lhs.nextVisits inst.visits : SemVisit inst.visits = if null @loc.remainingVisits || @name `elem` @lhs.doneVisits then SemVisit_End else prependEmptyVisits @lhs.basename @pos @actual @loc.missingVisits +errs0 = if null @loc.remainingVisits && not (null @lhs.nextVisits) then (Err_ExpVisit @pos @name (head @lhs.nextVisits) Seq.<|) else if @name `elem` @lhs.doneVisits then (Err_Dup [@name] Seq.<|) else id | End +errs0 = (if null @lhs.nextVisits then Seq.empty else Seq.singleton (Err_VisitsNotImpl @lhs.nonterm @lhs.nextVisits)) Seq.>< ATTR AllVisitClauses [ masterPos : Pos | | ] SEM Item | Sem CoSem first.masterPos = @pos SEM DataSem | Sem clauses.masterPos = @pos SEM SemVisit | Visit Internal loc.masterPos = @pos SEM Clause | Clause loc.masterPos = @pos { prependEmptyVisits _ _ t [] = t prependEmptyVisits basename pos t (v:vs) = SemVisit_Visit pos v False [] [] (ClausesTop_Top [Clause_Clause pos (mkClauseName pos v basename) [] (prependEmptyVisits basename pos t vs) ]) mkClauseName :: Pos -> Ident -> QIdent -> Ident mkClauseName pos v vs = Ident (show v ++ concatMap (\v' -> "_" ++ show v') vs) pos checkVisitSequence :: Pos -> Ident -> [Ident] -> (Errs, [Ident]) checkVisitSequence _ _ [] = (Seq.empty, []) -- dont report more errors if already erroneous checkVisitSequence pos nm (nm' : nms) | nm == nm' = (Seq.empty, nms) | otherwise = (Seq.singleton $ Err_ExpVisit pos nm nm', []) -- mismatch } -- insert dummy clause if no clauses were given SEM ClausesTop | Impl loc.pos = @lhs.masterPos loc.name = mkClauseName @loc.pos (Ident "impl" @loc.pos) @lhs.basename inst.actual : ClausesTop inst.actual = if null @clauses then ClausesTop_Top [Clause_Clause @loc.pos @loc.name [] SemVisit_Impl ] else ClausesTop_Top @clauses { unionWithPlusplus :: Ord k => Map k [v] -> Map k [v] -> Map k [v] unionWithParallel, unionWithSequential :: (Ord k, Ord v) => Map k [[v]] -> Map k [[v]] -> Map k [[v]] unionWithPlusplus = Map.unionWith (++) unionWithParallel mp1 mp2 = Map.unionWith (++) mp1' mp2' where addleft = Map.map (const [[]]) (mp2 `Map.difference` mp1) addright = Map.map (const [[]]) (mp1 `Map.difference` mp2) mp1' = addleft `Map.union` mp1 mp2' = addright `Map.union` mp2 unionWithSequential = Map.unionWith (\[h] t -> map (h++) t) unionWithUnion :: (Ord k, Monoid v) => Map k v -> Map k v -> Map k v unionWithUnion = Map.unionWith mappend } SEM Item | Detach loc.unqualChildItf = head @loc.childItf loc.childVisits = Map.findWithDefault [] @loc.unqualChildItf @lhs.distVisitOrder { nextAfterInvoked :: [Ident] -> [Ident] -> Ident nextAfterInvoked (a:as) (b:bs) | a == b = nextAfterInvoked as bs | otherwise = b } -- -- Check if all visits are uniquely named -- ATTR AllVisitClauses [ | gathVisitNames : {Env Ident ()} | ] SEM SemVisit | Visit Internal +gathVisitNames = extend @name () SEM Item | Sem CoSem first.gathVisitNames = emptyEnv +errs0 = addDefErrs' @first.gathVisitNames SEM DataSem | Sem clauses.gathVisitNames = emptyEnv +errs0 = addDefErrs' @clauses.gathVisitNames SEM Clauses | Cons (hd.gathVisitNames, tl.gathVisitNames) = split @lhs.gathVisitNames (lhs.gathVisitNames, loc.gathLVisitNames) = merge @hd.gathVisitNames @tl.gathVisitNames +errs1 = addDefErrs' @loc.gathLVisitNames ATTR SemVisit [ | | isInternal : Bool ] SEM SemVisit | Visit lhs.isInternal = False | Internal lhs.isInternal = True | End lhs.isInternal = False SEM Clause | Clause loc.isDeepest = not @next.isInternal -- -- Attribute information: all syn/inh attrs per nonterm and per visit -- { type AttrMap = Map Ident (Map Ident String) type VisitAttrMap = Map Ident AttrMap } ATTR BlocksTop Blocks Block Itf ItfVisits ItfVisit [ | | gathInhAttrs, gathSynAttrs USE {`mappend`} {mempty} : AttrMap ] ATTR BlocksTop Blocks Block Itf ItfVisits ItfVisit [ | | gathVisitInhAttrs, gathVisitSynAttrs USE {`mappend`} {mempty} : VisitAttrMap ] ATTR ItfVisits ItfVisit [ | | gathVisitsInhAttrs, gathVisitsSynAttrs USE {`mappend`} {mempty} : AttrMap ] ATTR Attrs Attr [ | | gathVisitInhAttrs, gathVisitSynAttrs USE {`mappend`} {mempty} : {Map Ident String} ] SEM Attr | Inh lhs.gathVisitInhAttrs = Map.singleton @name @type | Syn lhs.gathVisitSynAttrs = Map.singleton @name @type SEM ItfVisit | Visit lhs.gathVisitsInhAttrs = Map.singleton @name @attrs.gathVisitInhAttrs lhs.gathVisitsSynAttrs = Map.singleton @name @attrs.gathVisitSynAttrs lhs.gathVisitInhAttrs = Map.singleton (head @loc.coItf) (Map.singleton @name @attrs.gathVisitSynAttrs) lhs.gathVisitSynAttrs = Map.singleton (head @loc.coItf) (Map.singleton @name @attrs.gathVisitInhAttrs) lhs.gathInhAttrs = Map.singleton (head @loc.coItf) @attrs.gathVisitSynAttrs lhs.gathSynAttrs = Map.singleton (head @loc.coItf) @attrs.gathVisitInhAttrs SEM Itf | Itf +gathVisitInhAttrs = Map.insert @name @visits.gathVisitsInhAttrs +gathVisitSynAttrs = Map.insert @name @visits.gathVisitsSynAttrs +gathInhAttrs = Map.insert @name $ Map.unions $ Map.elems @visits.gathVisitsInhAttrs +gathSynAttrs = Map.insert @name $ Map.unions $ Map.elems @visits.gathVisitsSynAttrs ATTR AllCodeBlocks ImplStmts ImplStmt [ distInhAttrs, distSynAttrs : AttrMap distVisitInhAttrs, distVisitSynAttrs : VisitAttrMap | | ] SEM Program | Program blocks.distInhAttrs = @blocks.gathInhAttrs blocks.distSynAttrs = @blocks.gathSynAttrs blocks.distVisitInhAttrs = @blocks.gathVisitInhAttrs blocks.distVisitSynAttrs = @blocks.gathVisitSynAttrs ATTR VisitAttrs VisitAttr [ | | gathVisitLocalAttrs USE {`mappend`} {mempty} : {Map Ident String} ] ATTR Clauses Clause ClausesTop SemVisit [ | | gathVisitAttrs USE {`mappend`} {mempty} : {Map Ident (Map Ident String)} ] ATTR AllCodeBlocks ImplStmts ImplStmt [ directVisitAttrs : {Map Ident (Map Ident String)} | | ] SEM SemVisit | Visit +gathVisitAttrs = Map.insert @name @attrs.gathVisitLocalAttrs SEM VisitAttr | Chn lhs.gathVisitLocalAttrs = Map.singleton @name @type SEM Program | Program blocks.directVisitAttrs = Map.empty SEM Item | Sem CoSem first.directVisitAttrs = @first.gathVisitAttrs ATTR AllCodeBlocks ImplStmts ImplStmt [ directVisitLocalAttrs : {Map Ident String} | | ] SEM Program | Program blocks.directVisitLocalAttrs = Map.empty SEM SemVisit | Visit stmts.directVisitLocalAttrs = @attrs.gathVisitLocalAttrs clauses.directVisitLocalAttrs = @attrs.gathVisitLocalAttrs -- -- Dispatch to AttrType -- ATTR AttrTypePat AttrTypeCode [ child, name, childItf : Ident | | ] SEM Pat | Attr inst.tp : AttrTypePat inst.tp = case identName @child of s | s == "loc" -> AttrTypePat_ProdLocal | s == "lhs" -> AttrTypePat_Lhs | s == "vis" -> AttrTypePat_VisLocal | @child `Set.member` @lhs.allVisits -> AttrTypePat_Visit | @loc.childItf == locQIdent -> AttrTypePat_ProdLocal | otherwise -> AttrTypePat_Child tp.child = @child tp.name = @loc.origName tp.childItf = head @loc.childItf SEM Item | Attr inst.tp : AttrTypeCode inst.tp = case identName @child of s | s == "loc" -> AttrTypeCode_ProdLocal | s == "lhs" -> AttrTypeCode_Lhs | s == "vis" -> AttrTypeCode_VisLocal | @child `Set.member` @lhs.allVisits -> AttrTypeCode_Visit | @loc.childItf == locQIdent -> AttrTypeCode_ProdLocal | otherwise -> AttrTypeCode_Child tp.child = @child tp.name = @loc.origName tp.childItf = head @loc.childItf -- computation of defineable attributes -- * all syn attrs of lhs -- * inh attrs of visits of children -- N.B. we may wish to check that we only define inherited attrs of -- actually invoked children. However, this is too restrictive for -- the programmer. -- We now allow inh attrs to be defined on all visits not invoked yet -- * any local attribute is defineable SEM AttrTypePat | Lhs -- check if @lhs.name is a syn attr of @lhs.childItf loc.allowedDefs = Map.findWithDefault Map.empty (head @lhs.itf) @lhs.distSynAttrs | Child loc.visits = Set.toList $ Map.findWithDefault Set.empty @lhs.child @lhs.distChildEffRanges loc.inhMap = Map.findWithDefault Map.empty @lhs.childItf @lhs.distVisitInhAttrs loc.allowedDefs = Map.unions (map (\v -> Map.findWithDefault Map.empty v @loc.inhMap) @loc.visits) | Visit loc.allowedDefs = Map.findWithDefault Map.empty @lhs.child @lhs.directVisitAttrs | VisLocal loc.allowedDefs = @lhs.directVisitLocalAttrs | Lhs Child Visit VisLocal +errs2 = ( if Map.member @lhs.name @loc.allowedDefs then Seq.empty else Seq.singleton (Err_UndeclAttr @lhs.child @lhs.name) ) Seq.>< { common :: [[Ident]] -> [Ident] common [] = [] common [x] = x common (x:xs) = x `intersect` common xs } -- -- computation of available attributes -- -- detect duplication + detect missing -- we can use a single environment to keep track of the various -- forms of attributes, because the "child"-name prevents overlap. -- However, since scoping of visit-local attrs is different, we -- put these in a separate environment -- { type At = (Ident,Ident,Bool) -- True: inherited attr, False: syn attr type DefsEnv = Env At (Maybe String) locIdent, lhsIdent, visIdent :: Ident locIdent = ident "loc" lhsIdent = ident "lhs" visIdent = ident "vis" } ATTR AllCodeBlocks ImplStmts ImplStmt [ | gathDefs, gathVisLocalDefs, distDefs, distVisLocalDefs : DefsEnv | ] SEM Program | Program blocks.gathDefs = emptyEnv blocks.gathVisLocalDefs = emptyEnv blocks.distDefs = @blocks.gathDefs blocks.distVisLocalDefs = @blocks.gathVisLocalDefs -- scoping SEM Item | Sem CoSem loc.gathDefsIn = enter @lhs.gathDefs first.gathDefs = @loc.gathDefsInh first.gathVisLocalDefs = enter @lhs.gathVisLocalDefs first.distDefs = enterWith @loc.localDefs @lhs.distDefs first.distVisLocalDefs = enterWith @loc.localVisLocalDefs @lhs.distVisLocalDefs loc.gathDefsInh = Map.fold (flip (Map.foldWithKey (\n t -> extend (replPos @pos lhsIdent,replPos @pos n,True) (Just t)))) @loc.gathDefsIn @loc.inhAttrMap -- add all inherited attrs of all visits (lhs.gathDefs, loc.localDefs) = leave @first.gathDefs (lhs.gathVisLocalDefs, loc.localVisLocalDefs) = leave @first.gathVisLocalDefs (lhs.distDefs, loc.localDefs') = leave @first.distDefs (lhs.distVisLocalDefs, loc.localVisLocalDefs') = leave @first.distVisLocalDefs +errs3 = addDefErrs'' @loc.localDefs +errs3 = addDefErrs'' @loc.localVisLocalDefs +errs3 = addUseErrs'' @loc.localDefs' +errs3 = addUseErrs'' @loc.localVisLocalDefs' SEM DataSem | Sem loc.gathDefsIn = enter @lhs.gathDefs clauses.gathDefs = @loc.gathDefsInh clauses.gathVisLocalDefs = enter @lhs.gathVisLocalDefs clauses.distDefs = enterWith @loc.localDefs @lhs.distDefs clauses.distVisLocalDefs = enterWith @loc.localVisLocalDefs @lhs.distVisLocalDefs loc.gathDefsInh = Map.fold (flip (Map.foldWithKey (\n t -> extend (replPos @pos lhsIdent,replPos @pos n,True) (Just t)))) @loc.gathDefsIn @loc.inhAttrMap -- add all inherited attrs of all visits (lhs.gathDefs, loc.localDefs) = leave @clauses.gathDefs (lhs.gathVisLocalDefs, loc.localVisLocalDefs) = leave @clauses.gathVisLocalDefs (lhs.distDefs, loc.localDefs') = leave @clauses.distDefs (lhs.distVisLocalDefs, loc.localVisLocalDefs') = leave @clauses.distVisLocalDefs +errs3 = addDefErrs'' @loc.localDefs +errs3 = addDefErrs'' @loc.localVisLocalDefs +errs3 = addUseErrs'' @loc.localDefs' +errs3 = addUseErrs'' @loc.localVisLocalDefs' SEM Clauses | Cons (hd.gathDefs, tl.gathDefs) = split @lhs.gathDefs (hd.gathVisLocalDefs, tl.gathVisLocalDefs) = split @lhs.gathVisLocalDefs (lhs.gathDefs, loc.gathLDefs) = merge @hd.gathDefs @tl.gathDefs (lhs.gathVisLocalDefs, loc.gathVisLocalLDefs) = merge @hd.gathVisLocalDefs @tl.gathVisLocalDefs hd.distDefs = enterWith @loc.gathLDefs @lhs.distDefs hd.distVisLocalDefs = enterWith @loc.gathVisLocalLDefs @lhs.distVisLocalDefs (tl.distDefs, loc.localDistDefs) = leave @hd.distDefs (tl.distVisLocalDefs, loc.localDistVisLocalDefs) = leave @hd.distVisLocalDefs +errs3 = addDefErrs'' @loc.gathLDefs +errs3 = addDefErrs'' @loc.gathVisLocalLDefs +errs3 = addUseErrs'' @loc.localDistDefs +errs3 = addUseErrs'' @loc.localDistVisLocalDefs SEM SemVisit | Visit loc.ldefs1 = enter @lhs.gathVisLocalDefs stmts.gathVisLocalDefs = @loc.ldefs2 (lhs.gathVisLocalDefs, loc.localVisLocalDefs) = leave @impls.gathVisLocalDefs stmts.distVisLocalDefs = enterWith @loc.localVisLocalDefs @lhs.distVisLocalDefs (lhs.distVisLocalDefs, loc.localVisLocalDefs') = leave @impls.distVisLocalDefs +errs3 = addDefErrs'' @loc.localVisLocalDefs +errs3 = addUseErrs'' @loc.localVisLocalDefs' -- a SemVisit | Internal is just invisible in this case (treated as a nested tree of clauses) -- collect the local additions to compute the intersection of them ATTR Clauses [ | | gathDefsAdds, gathVisLocalDefsAdds : {[DefsEnv]} ] SEM Clauses | Cons lhs.gathDefsAdds = @loc.gathLDefs : @tl.gathDefsAdds lhs.gathVisLocalDefsAdds = @loc.gathVisLocalLDefs : @tl.gathVisLocalDefsAdds | Nil lhs.gathDefsAdds = [] lhs.gathVisLocalDefsAdds = [] SEM ClausesTop | Top +gathDefs = push (strip $ intersection @clauses.gathDefsAdds) +gathVisLocalDefs = push (strip $ intersection @clauses.gathVisLocalDefsAdds) SEM Clause | Clause loc.enterF = if @loc.isDeepest then enter else id loc.leaveF = if @loc.isDeepest then leave else (\x -> (x, emptyEnv)) loc.enterWithF = if @loc.isDeepest then enterWith else (\_ x -> x) next.gathDefs = @loc.enterF @stmts.gathDefs (impls.gathDefs, loc.nextVisitLocDefs) = @loc.leaveF @next.gathDefs next.distDefs = @loc.enterWithF @loc.nextVisitLocDefs @stmts.distDefs (impls.distDefs, loc.nextVisitLocDefs') = @loc.leaveF @next.distDefs +errs3 = addDefErrs'' @loc.nextVisitLocDefs +errs3 = addUseErrs'' @loc.nextVisitLocDefs' lhs.gathDefs = @impls.gathDefs lhs.gathVisLocalDefs = @next.gathVisLocalDefs -- impls can't have gathVisLocalDefs -- Add chn attrs of visit and check that they are defined when we enter the next visit SEM SemVisit | Visit loc.ldefs2 = Map.foldWithKey (\n t -> extend (replPos @pos visIdent,replPos @pos n,True) (Just t)) @loc.ldefs1 @attrs.gathVisitLocalAttrs ATTR ClausesTop Clauses Clause SemVisit [ localAttrs : {Map Ident String} | | ] SEM Item | Sem CoSem first.localAttrs = Map.empty SEM DataSem | Sem clauses.localAttrs = Map.empty SEM SemVisit | Visit clauses.localAttrs = @attrs.gathVisitLocalAttrs -- lhs.localAttrs thus refers to the local attrs of the parent SEM Clause | Clause -- only when the clause is deepest. loc.missingLocalAttrMap = if @loc.isDeepest then Map.filterWithKey (\n _ -> not $ defined (replPos @pos visIdent,replPos @pos n,False) @next.distVisLocalDefs) @lhs.localAttrs else Map.empty -- no default rules, maybe in deeper clause loc.deflLocalAttrMap = @loc.missingLocalAttrMap loc.deflLocalAttrs = Map.keys @loc.deflLocalAttrMap -- always use default rules for local attributes SEM SemVisit | Visit loc.inhAttrMap = Map.findWithDefault Map.empty @name (Map.findWithDefault Map.empty (head @lhs.itf) @lhs.distVisitInhAttrs) ATTR SemVisit ClausesTop Clauses Clause [ visit : Ident | | ] SEM Item | Sem CoSem first.visit = @name -- some dummy value SEM DataSem | Sem clauses.visit = @tp -- some dummy value SEM SemVisit | Visit clauses.visit = @name -- internal visits are not passed as name SEM Clause | Clause -- only when clause is deepest. loc.synAttrMap = Map.findWithDefault Map.empty @lhs.visit (Map.findWithDefault Map.empty (head @lhs.itf) @lhs.distVisitSynAttrs) loc.missingAttrMap = if @loc.isDeepest then Map.filterWithKey (\n _ -> not $ defined (replPos @pos lhsIdent,n,False) @lhs.distDefs) @loc.synAttrMap else Map.empty (loc.deflAttrMap, loc.undefAttrMap) = Map.partitionWithKey (\n _ -> Map.member n @loc.distDeflStmts) @loc.missingAttrMap lhs.distDefs = Map.foldWithKey (\n _ -> snd . find (replPos @pos lhsIdent,replPos @pos n,False) Nothing) @impls.distDefs @loc.undefAttrMap -- bypass inst.dflts loc.deflAttrs = [ (a, Map.findWithDefault (False,Nothing) a @loc.distDeflStmts) | a <- Map.keys @loc.deflAttrMap ] -- +errs1 = (debugMsg ("pos: " ++ show @pos ++ "\nall: " ++ show @lhs.distDefs ++ "\nundef: " ++ show @loc.undefAttrMap ++ "\ndefl: " ++ show @loc.deflAttrMap ++ "\ndefs: " ++ show @loc.distDeflStmts) Seq.><) SEM AttrTypePat | VisLocal +gathVisLocalDefs = extend (@lhs.child, @lhs.name, False) Nothing | ProdLocal +gathDefs = extend (@lhs.child, @lhs.name, False) Nothing | Lhs +gathDefs = extend (@lhs.child, @lhs.name, False) Nothing | Child +gathDefs = extend (@lhs.child, @lhs.name, True) Nothing | Visit +gathDefs = extend (@lhs.child, @lhs.name, False) Nothing SEM Pat | AttrCon +gathDefs = \env -> foldr (\(nm,tp) -> extend (@name, nm, not @loc.isLoc) (Just (either show id tp))) env @loc.fields SEM AttrTypeCode | VisLocal +distVisLocalDefs = snd . find (@lhs.child, @lhs.name,True) Nothing | ProdLocal +distDefs = snd . find (@lhs.child, @lhs.name, False) Nothing | Lhs +distDefs = snd . find (@lhs.child, @lhs.name, True) Nothing | Child +distDefs = snd . find (@lhs.child, @lhs.name, False) Nothing | Visit +distDefs = snd . find (@lhs.child, @lhs.name, True) Nothing { replPos :: Pos -> Ident -> Ident replPos p i = Ident (identName i) p } -- Invoke: bring attrs in scope (but not in the scope of rhs) -- + compute attrs to "default" SEM Stmt | Invoke loc.inhAttrMap = Map.findWithDefault Map.empty @visit (Map.findWithDefault Map.empty @loc.unqualChildItf @lhs.distVisitInhAttrs) loc.synAttrMap = Map.findWithDefault Map.empty @visit (Map.findWithDefault Map.empty @loc.unqualChildItf @lhs.distVisitSynAttrs) loc.missingAttrMap = Map.filterWithKey (\n _ -> not $ defined (@name,n,True) @lhs.distDefs) @loc.inhAttrMap (loc.deflAttrMap, loc.undefAttrMap) = Map.partitionWithKey (\n _ -> Map.member n @lhs.distDeflStmts) @loc.missingAttrMap loc.deflAttrs = [ (a, Map.findWithDefault (False,Nothing) a @lhs.distDeflStmts) | a <- Map.keys @loc.deflAttrMap ] -- watch out: copy rule would take deflts.distDefs too, resulting in a loop. lhs.distDefs = Map.foldWithKey (\n _ -> snd . find (@name,replPos @pos n,True) Nothing) @code.distDefs @loc.undefAttrMap lhs.gathDefs = Map.foldWithKey (\n t -> extend (@name,replPos @pos n,False) (Just t)) @code.gathDefs @loc.synAttrMap -- Also in case of implicit invoke SEM ImplStmt | Invoke loc.inhAttrMap = Map.findWithDefault Map.empty @visit (Map.findWithDefault Map.empty @itf @lhs.distVisitInhAttrs) loc.synAttrMap = Map.findWithDefault Map.empty @visit (Map.findWithDefault Map.empty @itf @lhs.distVisitSynAttrs) loc.missingAttrMap = Map.filterWithKey (\n _ -> not $ defined (@child,n,True) @lhs.distDefs) @loc.inhAttrMap (loc.deflAttrMap, loc.undefAttrMap) = Map.partitionWithKey (\n _ -> Map.member n @lhs.distDeflStmts) @loc.missingAttrMap loc.deflAttrs = [ (a, Map.findWithDefault (False,Nothing) a @lhs.distDeflStmts) | a <- Map.keys @loc.deflAttrMap ] -- watch out: copy rule would take deflts.distDefs too, resulting in a loop. lhs.distDefs = Map.foldWithKey (\n _ -> snd . find (@child,replPos @pos n,True) Nothing) @lhs.distDefs @loc.undefAttrMap lhs.gathDefs = Map.foldWithKey (\n t -> extend (@child,replPos @pos n,False) (Just t)) @lhs.gathDefs @loc.synAttrMap -- +errs2 = debugMsg ("impl invoke: " ++ show @child ++ "." ++ show @visit ++ " base " ++ show @lhs.basename ++": " ++ show @loc.synAttrMap) Seq.>< -- -- Add implicit invokes. Watch out with assigning attributes to implicit statements. -- Must be before the inst.deflts! -- SEM Clause | Clause inst.impls : ImplStmts inst.impls = [ ImplStmt_Invoke @pos nm s (findChild nm @lhs.distChildDefs) | (nm,vs) <- Map.assocs @loc.implicitInvokes, s <- Set.toList vs ] SEM SemVisit | Visit Internal inst.impls : ImplStmts inst.impls = [ ImplStmt_Invoke @pos nm s (findChild nm @lhs.distChildDefs) | (nm,vs) <- Map.assocs @loc.implicitInvokes, s <- Set.toList vs ] { findChild nm env = itf where (([itf], _), _) = find [nm] (unknQIdent,unknQIdent) env } -- -- Deal with default rules -- SEM Clause | Clause inst.deflts : ImplStmts inst.deflts = map (\(nm,(_,mbCode)) -> ImplStmt_DefaultSyn @pos True nm mbCode) @loc.deflAttrs ++ map (ImplStmt_DefaultVisLocal @pos) @loc.deflLocalAttrs SEM Stmt | Invoke inst.deflts : ImplStmts inst.deflts = map (\(nm,(empty,mbCode)) -> ImplStmt_DefaultChild @pos empty @name nm mbCode) @loc.deflAttrs SEM ImplStmt | Invoke inst.deflts : ImplStmts inst.deflts = map (\(nm,(empty,mbCode)) -> ImplStmt_DefaultChild @pos empty @child nm mbCode) @loc.deflAttrs -- -- Determine children + input attributes for default rule -- SEM ImplStmt | DefaultChild DefaultSyn loc.childrenOrdered = map fst $ sortBy (\(_,a) (_,b) -> a `compare` b) (Map.assocs @lhs.distChildOcc) loc.availChildren = [ (c,itf, findVisitOfAttr nm itf @lhs.distAttrVisMap) | c <- @loc.childrenOrdered , let ([itf], _) = fst $ find [c] (unknQIdent,unknQIdent) @lhs.distChildDefs nm = renameAttrFwd @lhs.distRenames c @name , hasSynAttr nm itf @lhs.distSynAttrs ] SEM ImplStmt | DefaultChild loc.candidateChildren = takeWhile (\(nm,_,_) -> nm /= @child) @loc.availChildren SEM ImplStmt | DefaultSyn loc.candidateChildren = @loc.availChildren SEM ImplStmt | DefaultChild -- +errs2 = debugMsg ("child: " ++ show @child ++ ", attr: " ++ show @name ++ ", children: " ++ show @loc.children) Seq.>< SEM ImplStmt | DefaultChild DefaultSyn (loc.children, loc.errChildren) = partition (\(c,itf,vis) -> visAvailable c itf vis @lhs.availInvokes @lhs.distVisitOrder) @loc.candidateChildren loc.childAttrs = map (\(c,_,_) -> (c, renameAttrFwd @lhs.distRenames c @name)) @loc.children +errs2 = \es -> foldr (\(c,itf,vis) -> (Err_ChildSynUnav @pos c itf vis @name Seq.<|)) es @loc.errChildren SEM ImplStmt | DefaultChild +errs3 = if not @allowEmpty && null @loc.children && not @loc.lhsHasAttr then (Err_MissingAttr True @child (replPos @pos @name) Seq.<|) else id SEM ImplStmt | DefaultSyn +errs3 = if not @allowEmpty && null @loc.children && not @loc.lhsHasAttr then (Err_MissingAttr False (replPos @pos lhsIdent) @name Seq.<|) else id -- is there an lhs.name inh attribute? -- if the lhs inh attr is in a later visit, this results in a cycle SEM ImplStmt | DefaultChild DefaultSyn loc.unqualChildItf = head @lhs.itf loc.lhsHasAttr = isJust $ Map.lookup (True,@name) $ Map.findWithDefault Map.empty @loc.unqualChildItf @lhs.distAttrVisMap { visAvailable child itf vis invokeMap orderMap = any (\start -> vis `elem` dropWhile (/= start) order) invokes where invokes = Set.toList $ Map.findWithDefault Set.empty child invokeMap order = Map.findWithDefault [] itf orderMap hasSynAttr nm itf mp = Map.member nm $ Map.findWithDefault Map.empty itf mp findVisitOfAttr nm itf mp = Map.findWithDefault (ident "") (False,nm) (Map.findWithDefault Map.empty itf mp) } -- -- Lexical occurrence of statements -- ATTR AllFinal [ | lexCounter : Int | ] SEM Program | Program blocks.lexCounter = 1 SEM Stmt | * loc.lexOrder : UNIQUEREF lexCounter SEM ImplStmt | * loc.lexOrder : UNIQUEREF lexCounter SEM Clause | Clause loc.lexOrder : UNIQUEREF lexCounter SEM SemVisit | Visit Internal loc.lexOrder : UNIQUEREF lexCounter { nextUnique :: Int -> (Int, Int) nextUnique x = (x+1, x) } -- -- Lexical occurrence of children -- (direct children of a clause) ATTR Stmts Stmt [ | | gathChildOcc USE {`unionWithMin`} {Map.empty} : {Map Ident Int} ] ATTR AllCodeBlocks ImplStmts ImplStmt [ distChildOcc : {Map Ident Int} | | ] { unionWithMin :: Map Ident Int -> Map Ident Int -> Map Ident Int unionWithMin = Map.unionWith min } SEM Stmt | Attach lhs.gathChildOcc = Map.singleton @name @loc.lexOrder SEM Program | Program blocks.distChildOcc = Map.empty SEM Item | Sem CoSem first.distChildOcc = Map.empty SEM DataSem | Sem clauses.distChildOcc = Map.empty SEM SemVisit | Visit Internal loc.distChildOcc = @stmts.gathChildOcc `unionWithMin` @lhs.distChildOcc SEM Clause | Clause loc.distChildOcc = @stmts.gathChildOcc `unionWithMin` @lhs.distChildOcc -- -- Define clauses of DataSem in terms of a visit -- SEM DataSem | Sem inst.clauses : T_SemVisit inst.clauses = sem_SemVisit_Visit @pos @loc.firstVisit @cyclic (sem_VisitAttrs_Nil) (sem_Stmts @stmts) -- -- Some useful properties -- ATTR ItfVisits ItfVisit [ | | firstVisit : Ident ] SEM ItfVisit | Visit lhs.firstVisit = @name SEM ItfVisits | Cons lhs.firstVisit = @hd.firstVisit | Nil lhs.firstVisit = ident "nofirstvisit" SEM ItfVisit | Visit loc.itfNm = head @lhs.itf SEM Attr | Inh Syn loc.itfNm = head @lhs.itf loc.visNm = head @lhs.visit ATTR ItfVisit [ mbNextVisit : {Maybe Ident} | | ] ATTR ItfVisits [ | | mbNextVisit : {Maybe Ident} ] SEM ItfVisits | Cons hd.mbNextVisit = @tl.mbNextVisit lhs.mbNextVisit = Just @hd.firstVisit | Nil lhs.mbNextVisit = Nothing SEM SemVisit | Visit Internal loc.itfNm = head @lhs.itf SEM Clause | Clause loc.itfNm = head @lhs.itf ATTR SemVisit [ | | mbNextVisit : {Maybe Ident} ] SEM SemVisit | Visit Internal lhs.mbNextVisit = Just @name | End lhs.mbNextVisit = Nothing ATTR MaybeBoundCode [ | | isJust : Bool ] SEM MaybeBoundCode | Just lhs.isJust = True | Nothing lhs.isJust = False ATTR Exts Ext [ | | gathExts USE {`Set.union`} {Set.empty} : {Set Ident} ] SEM Ext | Ext lhs.gathExts = Set.singleton @name { type AttrVisMap = Map Ident (Map (Bool,Ident) Ident) } ATTR BlocksTop Blocks Block Itf [ | | gathAttrVisMap USE {`Map.union`} {Map.empty} : AttrVisMap ] ATTR ItfVisits ItfVisit Attrs Attr [ | | gathAttrVisMap USE {`Map.union`} {Map.empty} : {Map (Bool,Ident) Ident} ] SEM Itf | Itf lhs.gathAttrVisMap = Map.singleton @name @visits.gathAttrVisMap SEM Attr | Inh Syn lhs.gathAttrVisMap = Map.singleton (@loc.isInh, @name) (head @lhs.visit) SEM Attr | Inh loc.isInh = True | Syn loc.isInh = False ATTR AllCodeBlocks ImplStmts ImplStmt [ distAttrVisMap : AttrVisMap | | ] SEM Program | Program blocks.distAttrVisMap = @blocks.gathAttrVisMap { type DataMap = Map Ident ConMap type ConMap = Map Ident (Int, FieldMap) type FieldMap = Map Ident (Int, Either Ident String) } ATTR BlocksTop Blocks Block Data Type [ | | gathDataMap USE {`Map.union`} {Map.empty} : DataMap ] ATTR Cons Con [ | | gathConMap USE {`Map.union`} {Map.empty} : ConMap ] ATTR Fields Field [ | | gathFieldMap USE {`Map.union`} {Map.empty} : FieldMap ] SEM Data | Data lhs.gathDataMap = Map.singleton @name @cons.gathConMap SEM Con | Con lhs.gathConMap = Map.singleton @name (@lhs.nr, @fields.gathFieldMap) SEM Field | Field lhs.gathFieldMap = Map.singleton @name (@lhs.nr, @type.fldType) ATTR AllCodeBlocks ImplStmts ImplStmt [ distDataMap : DataMap | | ] SEM Program | Program blocks.distDataMap = @blocks.gathDataMap -- Basename: a unique name for the current clause. VisitNames are shared. ATTR AllFinal [ basename : QIdent | | ] ATTR AllVisitClauses [ semBasename : QIdent | | ] SEM Program | Program blocks.basename = [ident ""] SEM Item | Sem CoSem loc.basename = [@name] loc.semBasename = [@name] SEM DataSem | Sem loc.basename = [@tp] loc.semBasename = [@tp] SEM Clause | Clause loc.basename = @name : @lhs.basename -- within the context of a cosem or not ATTR AllVisitClauses [ withinCoSem : Bool | | ] SEM Item | Sem first.withinCoSem = False SEM Item | CoSem first.withinCoSem = True SEM DataSem | Sem clauses.withinCoSem = False -- mode of a Mode ATTR Mode [ | | isMatch : Bool ] SEM Mode | Match lhs.isMatch = True | Assert lhs.isMatch = False -- position of a DataSem ATTR DataSem [ | | pos : Pos ] SEM DataSem | Sem lhs.pos = @pos SEM Item | DataSem loc.pos = @sem.pos -- -- Convert type aliases to their structural representation -- ATTR AliasType [ | | alias : SELF ] ATTR BlocksTop Blocks Block Type [ | | gathAliasses USE {`Map.union`} {Map.empty} : {Map Ident AliasType} ] ATTR AllCodeBlocks ImplStmts ImplStmt Data Cons Con Fields Field FieldType Type [ distAliasses : {Map Ident AliasType} | | ] SEM Type | Alias lhs.gathAliasses = Map.singleton @name @type.alias SEM Program | Program blocks.distAliasses = @blocks.gathAliasses SEM Pat | AttrCon loc.mbAlias = Map.lookup @dt @lhs.distAliasses SEM Item | Construct loc.mbAlias = Map.lookup @data @lhs.distAliasses SEM FieldType | Nonterm loc.mbAlias = Map.lookup @name @lhs.distAliasses SEM Type | Alias inst.data : Data inst.data = @type.data ATTR AliasType [ pos : Pos name : Ident vars : Vars | | data : {Data} ] SEM Type | Alias type.pos = @pos type.name = @name type.vars = @vars.self SEM AliasType | Prod lhs.data = let mkFld i nm = Field_Field (Ident ("x" ++ show i) @lhs.pos) (FieldType_Nonterm nm) in Data_Data @lhs.pos @lhs.name @lhs.vars [Con_Con @lhs.pos (Ident "Prod" @lhs.pos) [] (zipWith mkFld [1..] @fields) ] [] | List lhs.data = Data_Data @lhs.pos @lhs.name @lhs.vars [ Con_Con @lhs.pos (Ident "Cons" @lhs.pos) [] [ Field_Field (Ident "hd" @lhs.pos) (FieldType_Nonterm @type) , Field_Field (Ident "tl" @lhs.pos) (FieldType_Nonterm @lhs.name) ] , Con_Con @lhs.pos (Ident "Nil" @lhs.pos) [] [] ] [] | Maybe lhs.data = Data_Data @lhs.pos @lhs.name @lhs.vars [ Con_Con @lhs.pos (Ident "Just" @lhs.pos) [] [ Field_Field (Ident "just" @lhs.pos) (FieldType_Nonterm @type) ] , Con_Con @lhs.pos (Ident "Nothing" @lhs.pos) [] [] ] [] ATTR Vars Var [ | | self : SELF vars USE {++} {[]} : {[Ident]} ] SEM Var | Var lhs.vars = [@name] -- -- Deal with type variables -- -- todo ATTR ItfVisits ItfVisit Cons Con [ vars : {[Ident]} | | ] -- -- Extra Interfaces and semantics -- ATTR Blocks Block Data Cons Con Itf ItfVisits ItfVisit [ | | extraBlocks USE {++} {[]} : {Blocks} ] SEM BlocksTop | Top inst.extra : BlocksTop inst.extra = if null @blocks.extraBlocks then BlocksTop_None else BlocksTop_Top @blocks.extraBlocks SEM Con | Con lhs.extraBlocks = if genConNonterms @lhs.opts then [@loc.constr, @loc.deconstr, @loc.constrSem, @loc.deconstrSem] else [] loc.conItfNm = conItf @lhs.data @name loc.deconItfNm = deconItf @lhs.data @name loc.allVarNms = sort (@lhs.vars ++ @vars.vars) loc.allVars = map Var_Var @loc.allVarNms loc.constr = Block_Itf $ Itf_Itf @pos @loc.conItfNm @loc.allVars [ItfVisit_Visit @pos (Ident "construct" @pos) False [] ( Attr_Syn (Ident "data" @pos) (show @lhs.data) : [ Attr_Inh k (either show id t) | (k,t) <- sortAssocs $ assocs @fields.gathFields ] )] loc.deconstr = Block_Itf $ Itf_Itf @pos @loc.deconItfNm @loc.allVars [ItfVisit_Visit @pos (Ident "deconstruct" @pos) False [] ( Attr_Inh (Ident "data" @pos) (show @lhs.data) : [ Attr_Syn k (either show id t) | (k,t) <- sortAssocs $ assocs @fields.gathFields ] )] loc.constrSem = Block_Item @loc.conItfNm $ Item_Sem @pos @loc.conItfNm @loc.conItfNm [] Nothing $ SemVisit_Visit @pos (Ident "construct" @pos) False [] [] $ ClausesTop_Top [ Clause_Clause @pos (Ident "dispatch" @pos) [ Stmt_Eval Mode_Assert (Pat_Attr (Ident "lhs" @pos) (Ident "data" @pos)) (BoundCode_Code Bind_Fun @pos $ Code_Code [ Item_Construct @pos @lhs.data @name [ ExprField_Field k $ Code_Code [ Item_Attr @pos (Ident "lhs" @pos) k ] | (k,_) <- assocs @fields.gathFields ] ] ) ] SemVisit_End ] loc.deconstrSem = Block_Item @loc.deconItfNm $ Item_Sem @pos @loc.deconItfNm @loc.deconItfNm [] Nothing $ SemVisit_Visit @pos (Ident "deconstruct" @pos) False [] [] $ ClausesTop_Top [ Clause_Clause @pos (Ident "dispatch" @pos) [ Stmt_Eval Mode_Match (Pat_AttrCon @name (Ident "lhs" @pos) @lhs.data) (BoundCode_Code Bind_Fun @pos $ Code_Code [ Item_Attr @pos (Ident "lhs" @pos) (Ident "data" @pos)]) ] SemVisit_End ] { conItf dt con = Ident ("Con_" ++ show dt ++ "_" ++ show con) (identPos con) deconItf dt con = Ident ("Decon_" ++ show dt ++ "_" ++ show con) (identPos con) noIterNm dt con = Ident ("NoIter_" ++ show dt ++ "_" ++ show con) (identPos con) } SEM ItfVisit | Visit lhs.extraBlocks = if genCoSems @lhs.opts then [@loc.noIterSem] else [] loc.unqualItf = head @lhs.itf loc.noIterNm = noIterNm @loc.unqualItf @name loc.noIterSem = Block_Item @loc.noIterNm $ Item_CoSem @pos @loc.noIterNm @loc.unqualItf @name [] Nothing $ SemVisit_Visit @pos @name False [] [] $ ClausesTop_Top [] -- -- Compute the next visit of the (needed) children in scope -- ATTR Stmts Stmt ImplStmts ImplStmt [ | gathNextVisits : {Map Ident (Maybe Ident)} | ] ATTR SemVisit ClausesTop Clauses Clause [ distNextVisits : {Map Ident (Maybe Ident)} | | ] SEM Item | Sem CoSem first.distNextVisits = Map.empty SEM DataSem | Sem clauses.distNextVisits = Map.empty SEM Stmt | Invoke loc.mbNextVisit = visitAfter @visit @loc.childVisits SEM ImplStmt | Invoke loc.mbNextVisit = visitAfter @visit @loc.childVisits SEM SemVisit | Visit Internal stmts.gathNextVisits = Map.empty clauses.distNextVisits = @impls.gathNextVisits `Map.union` @lhs.distNextVisits SEM Clause | Clause stmts.gathNextVisits = Map.empty next.distNextVisits = let ks = Map.keysSet @next.allReqInvokes in Map.filter (maybe False (`Set.member` ks)) (@impls.gathNextVisits `Map.union` @lhs.distNextVisits) SEM Stmt | Invoke +gathNextVisits = Map.insertWith (laterVisit @loc.childVisits) @name @loc.mbNextVisit SEM ImplStmt | Invoke +gathNextVisits = Map.insertWith (laterVisit @loc.childVisits) @child @loc.mbNextVisit { visitAfter :: Ident -> [Ident] -> Maybe Ident visitAfter nm (a : b : nms) | nm == a = Just b | otherwise = visitAfter nm (b : nms) visitAfter _ _ = Nothing laterVisit :: [Ident] -> Maybe Ident -> Maybe Ident -> Maybe Ident laterVisit _ Nothing Nothing = Nothing laterVisit _ Nothing (Just x) = Just x laterVisit _ (Just x) Nothing = Just x laterVisit xs (Just l) (Just r) = Just $ laterVisit' xs l r laterVisit' [] _ r = r laterVisit' (x:xs) l r | x == l = l | x == r = r | otherwise = laterVisit' xs l r } ATTR SemVisit ClausesTop Clauses Clause [ myNextVisits : {Map Ident (Maybe Ident)} | | ] SEM Item | Sem CoSem loc.myNextVisits = Map.empty SEM DataSem | Sem loc.myNextVisits = Map.empty SEM SemVisit | Visit loc.myNextVisits = Map.filter isJust @lhs.distNextVisits -- -- Computation of child ranges -- (note: allDistChildMinRanges is passed to nested sems) -- can be used to determine available children -- ATTR AllCodeBlocks ImplStmts ImplStmt [ distAllChildMinRanges, distChildMinRanges : {Map Ident [Ident]} | | ] ATTR AllCodeBlocks ImplStmts ImplStmt [ distChildEffRanges : {Map Ident (Set Ident)} | | ] ATTR Stmts Stmt [ | | gathChildMinRanges USE {`unionWithPlusplus`} {Map.empty} : {Map Ident [Ident]} ] ATTR Stmts Stmt [ | | gathChildEffRanges USE {`unionWithUnion`} {Map.empty} : {Map Ident (Set Ident)} ] SEM Program | Program blocks.distChildMinRanges = Map.empty blocks.distAllChildMinRanges = Map.empty blocks.distChildEffRanges = Map.empty SEM DataSem | Sem clauses.distChildMinRanges = Map.empty clauses.distChildEffRanges = Map.empty SEM Item | Sem CoSem first.distChildMinRanges = Map.empty first.distChildEffRanges = Map.empty SEM Clause | Clause loc.distChildMinRanges = @stmts.gathChildMinRanges `unionWithPlusplus` @lhs.distChildMinRanges loc.distAllChildMinRanges = @stmts.gathChildMinRanges `Map.union` @lhs.distAllChildMinRanges -- shadows loc.distChildEffRanges = @stmts.gathChildEffRanges `unionWithUnion` @lhs.distChildEffRanges next.distChildEffRanges = @loc.distChildEffRanges `diffInside` @loc.availInvokes loc.introChildren = Map.keysSet (Map.difference @stmts.gathChildMinRanges @lhs.distChildMinRanges) SEM SemVisit | Visit Internal loc.distChildMinRanges = @stmts.gathChildMinRanges `unionWithPlusplus` @lhs.distChildMinRanges loc.distAllChildMinRanges = @stmts.gathChildMinRanges `Map.union` @lhs.distChildMinRanges -- shadows loc.distChildEffRanges = @stmts.gathChildEffRanges `unionWithUnion` @lhs.distChildEffRanges loc.introChildren = Map.keysSet (Map.difference @stmts.gathChildMinRanges @lhs.distAllChildMinRanges) SEM Stmt | Attach lhs.gathChildMinRanges = Map.singleton @name [@visit] lhs.gathChildEffRanges = Map.singleton @name (Set.fromList $ dropWhile (/= @loc.visit) @loc.childVisits) -- detect ambiguous child attachments -- there may not be two attach-stmts in a scope simultaneously with the same start visit SEM Stmt | Attach +errs2 = if (length $ filter (== @visit) $ Map.findWithDefault [] @name @lhs.distChildMinRanges) > 1 then (Err_AmbAttach @name @visit Seq.<|) else id -- -- Computation of implicit invokes -- -- banned invokes: an invoke explicitly declared in some clause. May not be implicitly invoked higher-up ATTR AllVisitClauses Stmts Stmt [ | | bannedInvokes USE {`unionWithUnion`} {Map.empty} : {Map Ident (Set Ident)} ] ATTR Clauses Clause Stmts Stmt [ | | explInvokes USE {`unionWithUnion`} {Map.empty} : {Map Ident (Set Ident)} ] SEM Stmt | Invoke lhs.explInvokes = Map.singleton @name (Set.singleton @visit) SEM ClausesTop | Top +bannedInvokes = @clauses.explInvokes `unionWithUnion` SEM SemVisit | Visit Internal +bannedInvokes = @stmts.explInvokes `unionWithUnion` -- invokes needed on children ATTR AllCodeBlocks [ | | minReqInvokes, allReqInvokes USE {`unionWithUnion`} {Map.empty} : {Map Ident (Set Ident)} ] ATTR Clauses [ | | commonInvokes : {[Map Ident (Set Ident)]} ] SEM Clauses | Cons lhs.commonInvokes = @hd.allReqInvokes : @tl.commonInvokes | Nil lhs.commonInvokes = [] SEM ClausesTop | Top lhs.minReqInvokes = intersectionsInvoke (@clauses.minReqInvokes : @clauses.commonInvokes) { intersectionsInvoke [] = Map.empty intersectionsInvoke [x] = x intersectionsInvoke (x:xs) = Map.intersectionWith Set.intersection x (intersectionsInvoke xs) } SEM Clause | Clause loc.minReqInvokes1 = @stmts.minReqInvokes `unionWithUnion` @next.minReqInvokes -- all needed loc.allReqInvokes1 = @stmts.allReqInvokes `unionWithUnion` @next.allReqInvokes loc.minReqInvokes = Map.filterWithKey (\k _ -> not (Set.member k @loc.introChildren)) @loc.minReqInvokes1 loc.allReqInvokes = Map.filterWithKey (\k _ -> not (Set.member k @loc.introChildren)) @loc.allReqInvokes1 SEM SemVisit | Visit Internal loc.minReqInvokes1 = @stmts.minReqInvokes `unionWithUnion` @clauses.minReqInvokes loc.allReqInvokes1 = @stmts.allReqInvokes `unionWithUnion` @clauses.allReqInvokes loc.minReqInvokes = Map.filterWithKey (\k _ -> not (Set.member k @loc.introChildren)) @loc.minReqInvokes1 loc.allReqInvokes = Map.filterWithKey (\k _ -> not (Set.member k @loc.introChildren)) @loc.allReqInvokes1 -- register all needs for visits SEM Item | Detach loc.minRanges = Set.fromList $ Map.findWithDefault [] @name @lhs.distAllChildMinRanges loc.potentialReqs = drop 1 $ dropWhile (/= @visit) $ reverse @loc.visitOrder loc.actualReqs = take (1 + length (takeWhile (\x -> not $ Set.member x @loc.minRanges) @loc.potentialReqs)) @loc.potentialReqs loc.invokeReqs = Map.singleton @name $ Set.fromList @loc.actualReqs lhs.minReqInvokes = @loc.invokeReqs lhs.allReqInvokes = @loc.invokeReqs -- Introduces the need for all visits having the attribute -- specified by the default of all children in scope -- (iff not banned: checked higher up) SEM Stmt | Default -- enumerate direct children and their itfs -- enumerate visits with attr name (use attrVisMap) -- add to minReqInvokes and allReqInvokes loc.visitReqs = [ Map.singleton child $ Set.fromList $ rangeUpTo (fromJust mbVis) range | child <- Map.keys @lhs.distChildMinRanges , let itf = findChild child @lhs.distChildDefs attrVisits = Map.findWithDefault Map.empty itf @lhs.distAttrVisMap childVisits = Map.findWithDefault [] itf @lhs.distVisitOrder minRanges = Set.fromList $ Map.findWithDefault [] child @lhs.distChildMinRanges range = dropWhile (\v -> not (v `Set.member` minRanges)) childVisits mbVis = Map.lookup (False,nm) attrVisits nm = renameAttrFwd @lhs.distRenames child @name , isJust mbVis ] loc.invokeReqs = Map.unionsWith Set.union @loc.visitReqs lhs.minReqInvokes = @loc.invokeReqs lhs.allReqInvokes = @loc.invokeReqs SEM Stmt | Attach -- enumerate all defaults in scope -- lookup if syn attr exists for this child -- if yes, add a need on the visit loc.attrVisits = Map.findWithDefault Map.empty @type @lhs.distAttrVisMap loc.visitReqs = [ rangeUpTo (fromJust mbVis) $ dropWhile (/= @loc.visit) @loc.childVisits | attr <- Map.keys @lhs.distDeflStmts , let mbVis = Map.lookup (False,attr) @loc.attrVisits , isJust mbVis ] loc.invokeReqs = Map.singleton @name $ Set.fromList (concat @loc.visitReqs) lhs.minReqInvokes = @loc.invokeReqs lhs.allReqInvokes = @loc.invokeReqs { rangeUpTo :: Ident -> [Ident] -> [Ident] rangeUpTo _ [] = [] rangeUpTo vis (x:xs) | x == vis = [x] | otherwise = x : rangeUpTo vis xs } SEM AttrTypeCode | Child loc.visitOfAttr = Map.findWithDefault unknIdent (False,@lhs.name) (Map.findWithDefault Map.empty @lhs.childItf @lhs.distAttrVisMap) loc.minRanges = Set.fromList $ Map.findWithDefault [] @lhs.child @lhs.distAllChildMinRanges loc.potentialReqs = dropWhile (/= @loc.visitOfAttr) $ reverse @loc.visitOrder loc.actualReqs = take (1 + length (takeWhile (\x -> not $ Set.member x @loc.minRanges) @loc.potentialReqs)) @loc.potentialReqs loc.invokeReqs = Map.singleton @lhs.child $ Set.fromList @loc.actualReqs lhs.minReqInvokes = @loc.invokeReqs lhs.allReqInvokes = @loc.invokeReqs -- available invokes (two flavours: nested and not nested) ATTR AllCodeBlocks ImplStmts ImplStmt [ availInvokes, allAvailInvokes : {Map Ident (Set Ident)} | | ] SEM Program | Program blocks.availInvokes = Map.empty blocks.allAvailInvokes = Map.empty SEM DataSem | Sem clauses.availInvokes = Map.empty SEM Item | Sem CoSem first.availInvokes = Map.empty SEM SemVisit | Visit Internal loc.implicitInvokes = @loc.minReqInvokes1 `diffInside` @lhs.availInvokes `diffInside` @stmts.explInvokes `diffInside` @clauses.bannedInvokes loc.additionalInvokes = @loc.minReqInvokes1 `diffInside` @clauses.bannedInvokes `unionWithUnion` @stmts.explInvokes loc.availInvokes = @loc.additionalInvokes `unionWithUnion` @lhs.availInvokes loc.allAvailInvokes = @loc.additionalInvokes `unionWithUnion` ( Map.filterWithKey (notIn @loc.introChildren) @lhs.allAvailInvokes ) -- +errs1 = debugMsg ("visit: " ++ show @name ++ "\n impl: " ++ show @loc.implicitInvokes ++"\n banned: " ++ show @clauses.bannedInvokes) Seq.>< SEM Clause | Clause loc.implicitInvokes = @loc.minReqInvokes1 `diffInside` @lhs.availInvokes `diffInside` @stmts.explInvokes `diffInside` @next.bannedInvokes loc.additionalInvokes = @loc.minReqInvokes1 `diffInside` @next.bannedInvokes `unionWithUnion` @stmts.explInvokes loc.availInvokes = @loc.additionalInvokes `unionWithUnion` @lhs.availInvokes loc.allAvailInvokes = @loc.additionalInvokes `unionWithUnion` ( Map.filterWithKey (notIn @loc.introChildren) @lhs.allAvailInvokes ) -- +errs1 = debugMsg ("clause: " ++ show @name ++ "\n impl: " ++ show @loc.implicitInvokes ++"\n banned: " ++ show @next.bannedInvokes) Seq.>< { notIn :: Ord a => Set a -> a -> b -> Bool notIn s k _ = not (k `Set.member` s) diffInside :: Map Ident (Set Ident) -> Map Ident (Set Ident) -> Map Ident (Set Ident) diffInside = Map.differenceWith f where f a b = let r = Set.difference a b in if Set.null r then Nothing else Just r } -- Report errors for missing invokes ATTR Code Items Item AllVisitClauses Stmts Stmt MaybeBoundCode BoundCode AttrTypeCode [ | | gathMissingInvokes USE {`Set.union`} {Set.empty} : {Set (Ident,Ident)}] SEM Item | Detach lhs.gathMissingInvokes = Set.fromList [ (k, v) | (k,vs) <- Map.assocs (@loc.invokeReqs `diffInside` @lhs.allAvailInvokes) , v <- Set.toList vs ] SEM AttrTypeCode | Child lhs.gathMissingInvokes = Set.fromList [ (k, v) | (k,vs) <- Map.assocs (@loc.invokeReqs `diffInside` @lhs.allAvailInvokes) , v <- Set.toList vs ] SEM SemVisit | Visit Internal loc.missingInvokes = Set.toList (@stmts.gathMissingInvokes `Set.difference` @clauses.gathMissingInvokes) +errs2 = Seq.fromList (map (\(nm,vs) -> Err_MissingVisit @pos nm vs) @loc.missingInvokes) Seq.>< SEM Clause | Clause loc.missingInvokes = Set.toList (@stmts.gathMissingInvokes `Set.difference` @next.gathMissingInvokes) +errs2 = Seq.fromList (map (\(nm,vs) -> Err_MissingVisit @pos nm vs) @loc.missingInvokes) Seq.>< -- -- Propagate default-stmts in scope -- ATTR AllCodeBlocks ImplStmts ImplStmt [ distDeflStmts : {Map Ident (Bool,Maybe Int)} | | ] ATTR Stmts Stmt [ | | gathDeflStmts USE {`Map.union`} {Map.empty} : {Map Ident (Bool,Maybe Int)} ] SEM Program | Program blocks.distDeflStmts = Map.empty SEM Item | Sem CoSem first.distDeflStmts = Map.empty SEM DataSem | Sem clauses.distDeflStmts = Map.empty SEM Stmt | Default loc.codeId : UNIQUEREF codeIdCounter loc.mbCodeId = if @mbCode.isJust then Just @loc.codeId else Nothing lhs.gathDeflStmts = Map.singleton @name (@allowEmpty,@mbCodeId) SEM SemVisit | Visit Internal loc.distDeflStmts = @stmts.gathDeflStmts `Map.union` @lhs.distDeflStmts SEM Clause | Clause loc.distDeflStmts = @stmts.gathDeflStmts `Map.union` @lhs.distDeflStmts ATTR AllCodeBlocks [ | codeIdCounter : Int | ] SEM Program | Program blocks.codeIdCounter = 1 SEM Stmt | Default +errs1 = if Map.findWithDefault (@allowEmpty,@mbCodeId) @name @lhs.distDeflStmts /= (@allowEmpty,@mbCodeId) then (Err_AmbDefault @pos @name Seq.<|) else id -- -- Gather visit starts and ends in lexical order -- ATTR AllCodeBlocks [ | | gathVisitStarts, gathVisitEnds USE {Seq.><} {Seq.empty} : {Seq DepItem} ] SEM SemVisit | Visit Internal +gathVisitStarts = @loc.scopeDep Seq.<| +gathVisitEnds = @loc.visitEndDep Seq.<| -- -- Gather semantics starts and ends (in lexical order) -- ATTR AllCodeBlocks [ | | gathSemStarts USE {Seq.><} {Seq.empty} : {Seq DepItem} ] SEM SemVisit | Visit +gathSemStarts = if @lhs.visitNr == 1 then (@loc.scopeDep Seq.<|) else id -- -- Determine visit start rank -- ATTR AllVisitClauses [ | | gathVisRankMap USE {`mappend`} {mempty} : {IntMap Ident} ] ATTR AllVisitClauses Stmts Stmt ImplStmts ImplStmt [ distVisRankMap : {IntMap Ident} | | ] SEM SemVisit | Visit Internal +gathVisRankMap = IntMap.insert @loc.rank @name SEM Item | Sem CoSem first.distVisRankMap = @first.gathVisRankMap SEM DataSem | Sem clauses.distVisRankMap = @clauses.gathVisRankMap SEM Stmt | * loc.destVisit = getDestVisit @loc.rank @lhs.distVisRankMap SEM ImplStmt | * loc.destVisit = getDestVisit @loc.rank @lhs.distVisRankMap { getDestVisit :: Int -> IntMap Ident -> Ident getDestVisit rank ranks = maybe (ident "unknownDestVisit") fst mbMax where (smaller, _) = IntMap.split rank ranks mbMax = IntMap.maxView smaller } -- -- Cyclic visit information -- { type CycVisMap = Map Ident (Set Ident) } ATTR BlocksTop Blocks Block Itf [ | | gathCycVisMap USE {`Map.union`} {Map.empty} : CycVisMap ] ATTR ItfVisits ItfVisit [ | | gathCycVisits USE {`Set.union`} {Set.empty} : {Set Ident}] ATTR Attrs Attr [ visCyclic : Bool | | ] ATTR AllFinal [ distCycVisMap : CycVisMap | | ] SEM ItfVisit | Visit lhs.gathCycVisits = if @cyclic then Set.singleton @name else Set.empty loc.visCyclic = @cyclic SEM Itf | Itf lhs.gathCycVisMap = Map.singleton @name @visits.gathCycVisits SEM Program | Program blocks.distCycVisMap = @blocks.gathCycVisMap ATTR SemVisit ClausesTop Clauses Clause Stmts Stmt ImplStmts ImplStmt [ fullCyclicVisits : {Set Ident} | | ] ATTR SemVisit ClausesTop Clauses Clause [ fullCyclic : Bool | | ] SEM Item | Sem CoSem first.fullCyclicVisits = Map.findWithDefault Set.empty @tp @lhs.distCycVisMap first.fullCyclic = False SEM DataSem | Sem clauses.fullCyclicVisits = Map.findWithDefault Set.empty @tp @lhs.distCycVisMap clauses.fullCyclic = False SEM SemVisit | Visit loc.fullCyclic = Set.member @name @lhs.fullCyclicVisits loc.allowCycles = @cyclic || @lhs.fullCyclic SEM SemVisit | Internal -- may not occur in a full cyclic visit loc.fullCyclic = False loc.allowCycles = @cyclic +errs3 = if @lhs.fullCyclic then (Err_InternalInCyclic @pos @name Seq.<|) else id ATTR SemVisit ClausesTop Clauses Clause [ | | gathAllowCycVisits USE {`mappend`} {mempty} : {Set Ident} ] ATTR SemVisit ClausesTop Clauses Clause Stmts Stmt ImplStmts ImplStmt [ allowCycVisits : {Set Ident} | | ] SEM Item | Sem CoSem first.allowCycVisits = @first.gathAllowCycVisits SEM DataSem | Sem clauses.allowCycVisits = @clauses.gathAllowCycVisits SEM SemVisit | Visit +gathAllowCycVisits = if @loc.allowCycles then Set.insert @name else id | Internal +gathAllowCycVisits = if @loc.allowCycles then Set.insert @loc.name else id SEM Stmt | * loc.fullCyclic = Set.member @loc.destVisit @lhs.fullCyclicVisits loc.allowCycles = Set.member @loc.destVisit @lhs.allowCycVisits SEM ImplStmt | * loc.fullCyclic = Set.member @loc.destVisit @lhs.fullCyclicVisits loc.allowCycles = Set.member @loc.destVisit @lhs.allowCycVisits SEM Stmt | Invoke loc.visitCyclic = Set.member @visit (Map.findWithDefault Set.empty @loc.unqualChildItf @lhs.distCycVisMap) loc.behaveCyclic = @loc.fullCyclic || @loc.visitCyclic SEM ImplStmt | Invoke loc.visitCyclic = Set.member @visit (Map.findWithDefault Set.empty @itf @lhs.distCycVisMap) loc.behaveCyclic = @loc.fullCyclic || @loc.visitCyclic -- sanity check SEM Stmt | Eval +errs5 = if @loc.isCyclic && @mode.isMatch then (Err_MatchCyclic @loc.pos Seq.<|) else id +errs5 = if @loc.isCyclic && not @code.isFun then (Err_EffCyclic @loc.pos Seq.<|) else id | Attach +errs5 = if @loc.isCyclic && @code.isJust && not @code.isFun then (Err_EffCyclic @pos Seq.<|) else id | Invoke +errs5 = if @loc.isCyclic && @code.isJust && not @code.isFun then (Err_EffCyclic @pos Seq.<|) else id | Default +errs5 = if @loc.isCyclic && @mbCode.isJust && not @mbCode.isFun then (Err_EffCyclic @pos Seq.<|) else id SEM Stmt | Invoke +errs5 = if @loc.isCyclic && not @loc.visitCyclic then (Err_VisExpCyclic @visit @name Seq.<|) else id +errs5 = if @code.isJust && @loc.isCyclic then (Err_IterCyclic @pos Seq.<|) else id SEM ImplStmt | Invoke +errs5 = if @loc.isCyclic && not @loc.visitCyclic then (Err_VisExpCyclic @visit @child Seq.<|) else id SEM SemVisit | Visit Internal loc.nClauses = Set.size @clauses.gathClauseNames +errs1 = if @loc.fullCyclic && @loc.nClauses /= 1 && not @lhs.withinCoSem then (Err_ClausesCyclic @pos @name @loc.nClauses Seq.<|) else id ATTR ClausesTop Clauses [ | | nClauses : Int ] SEM Clauses | Cons +nClauses = (+1) | Nil lhs.nClauses = 0 ATTR MaybeBoundCode BoundCode Bind [ | | isFun : Bool ] SEM Bind | Fun lhs.isFun = True | Monadic lhs.isFun = False SEM MaybeBoundCode | Nothing lhs.isFun = False -- Visits to avoid ATTR AllCodeBlocks [ | | gathAvoidVisits USE {`Set.union`} {Set.empty} : {Set DepItem} ] SEM SemVisit | Visit +gathAvoidVisits = if @loc.fullCyclic then Set.insert @loc.visitEndDep else id -- What item belongs to what visit ATTR AllFinal [ | | gathItemVisits USE {`Map.union`} {Map.empty} : {Map DepItem DepItem} ] SEM SemVisit | Visit Internal +gathItemVisits = Map.insert @loc.scopeDep @loc.scopeDep SEM Clause | Clause +gathItemVisits = Map.insert @loc.scopeDep @lhs.visitBeginDep SEM Stmt | * +gathItemVisits = Map.insert @loc.stmtSource @lhs.visitBeginDep SEM ImplStmt | * +gathItemVisits = Map.insert @loc.stmtSource @lhs.visitBeginDep ATTR AllFinal [ | | gathLegalCycStmts USE {`Set.union`} {Set.empty} : {Set DepItem} ] SEM Stmt | * +gathLegalCycStmts = if @loc.allowCycles then Set.insert @loc.stmtSource else id SEM ImplStmt | * +gathLegalCycStmts = if @loc.allowCycles then Set.insert @loc.stmtSource else id -- -- Dependency analysis -- -- Dependable items and their ordening { unknDepItem :: DepItem unknDepItem = DepVisStart [ident "errorunknown"] } -- Pass down the source of a statement ATTR AllFinal [ stmtSource : DepItem | | ] SEM Program | Program blocks.stmtSource = DepMatch (-999) SEM Stmt | Eval loc.stmtSource = if @mode.isMatch then DepMatch @loc.lexOrder else DepAssert @loc.lexOrder | Default loc.stmtSource = DepDefault @loc.codeId | Attach loc.stmtSource = DepAttach @loc.lexOrder | Invoke loc.stmtSource = DepInvoke (@visit : @name : @lhs.basename) | Rename loc.stmtSource = DepAssert @loc.lexOrder SEM ImplStmt | Invoke loc.stmtSource = DepInvoke (@visit : @child : @lhs.basename) | DefaultChild DefaultSyn DefaultVisLocal loc.stmtSource = DepAssert @loc.lexOrder ATTR AllFinal [ | | gathStmtPosMap USE {`Map.union`} {Map.empty} : {Map DepItem Pos} ] SEM Stmt | Eval loc.pos = @code.pos SEM Stmt | * +gathStmtPosMap = Map.insert @loc.stmtSource @pos SEM ImplStmt | * +gathStmtPosMap = Map.insert @loc.stmtSource @pos ATTR Pats Pat BoundCode [ | | pos : Pos ] SEM Pat | Con lhs.pos = identPos @name | AttrCon lhs.pos = identPos @dt | Attr lhs.pos = identPos @child | Tup lhs.pos = @pats.pos | List lhs.pos = @pats.pos | Cons lhs.pos = @hd.pos | Underscore lhs.pos = @pos SEM Pats | Cons lhs.pos = @hd.pos | Nil lhs.pos = noPos SEM BoundCode | Code lhs.pos = @pos -- Determines: "Where is each attribute defined? What is its source?" { type AttrSourceMap = Map (Bool,Ident,Ident) DepItem -- Bool: True = inherited attr } ATTR AllFinal [ distAttrSource : AttrSourceMap | | ] ATTR AllVisFinal [ | | gathAttrSource USE {`Map.union`} {Map.empty} : AttrSourceMap ] ATTR AllVisitClauses [ | | gathSemAttrSource USE {`Map.union`} {Map.empty} : AttrSourceMap ] -- global to entire SEM SEM Program | Program blocks.distAttrSource = Map.empty SEM SemVisit | Visit loc.distAttrSource = Map.unions [ @loc.gathChnAttrSource , @stmts.gathAttrSource , @loc.gathVisAttrSource , @impls.gathAttrSource , @lhs.distAttrSource ] SEM SemVisit | Internal loc.distAttrSource = Map.unions [ @stmts.gathAttrSource , @impls.gathAttrSource , @lhs.distAttrSource ] SEM Clause | Clause loc.distAttrSource = Map.unions [ @stmts.gathAttrSource , @deflts.gathAttrSource , @impls.gathAttrSource , @lhs.distAttrSource ] SEM SemVisit | Visit loc.gathChnAttrSource = Map.fromList [ ((True,visIdent,attr), @loc.scopeDep) | attr <- Map.keys @attrs.gathVisitLocalAttrs ] loc.gathVisAttrSource = Map.fromList [ ((False,@name,attr), @loc.visitEndDep) | attr <- Map.keys @attrs.gathVisitLocalAttrs ] -- soures of lhs-inherited attributes SEM Item | Sem CoSem loc.inhAttrMap = Map.findWithDefault Map.empty @tp @lhs.distVisitInhAttrs loc.inhAttrSource = Map.fromList [ ((True,lhsIdent,attr), DepVisStart (visit : @loc.semBasename)) | (visit,mp) <- Map.assocs @loc.inhAttrMap, attr <- Map.keys mp ] first.distAttrSource = Map.union @loc.inhAttrSource @lhs.distAttrSource SEM DataSem | Sem loc.inhAttrMap = Map.findWithDefault Map.empty @tp @lhs.distVisitInhAttrs loc.inhAttrSource = Map.fromList [ ((True,lhsIdent,attr), DepVisStart (visit : @loc.semBasename)) | (visit,mp) <- Map.assocs @loc.inhAttrMap, attr <- Map.keys mp ] clauses.distAttrSource = Map.union @loc.inhAttrSource @lhs.distAttrSource SEM Stmt | Invoke -- child visit +gathAttrSource = Map.union $ Map.fromList [ ((False,@name,attr), @loc.stmtSource) | attr <- Map.keys @loc.synAttrMap ] SEM ImplStmt | Invoke -- child visit +gathAttrSource = Map.union $ Map.fromList [ ((False,@child,attr), @loc.stmtSource) | attr <- Map.keys @loc.synAttrMap ] SEM AttrTypePat | VisLocal ProdLocal Lhs +gathAttrSource = Map.insert (False,@lhs.child,@lhs.name) @lhs.stmtSource SEM AttrTypePat | Child Visit +gathAttrSource = Map.insert (True,@lhs.child,@lhs.name) @lhs.stmtSource SEM ImplStmt | DefaultSyn +gathAttrSource = Map.insert (False,lhsIdent,@name) @loc.stmtSource | DefaultChild +gathAttrSource = Map.insert (True,@child,@name) @loc.stmtSource | DefaultVisLocal +gathAttrSource = Map.insert (False,visIdent,@name) @loc.stmtSource SEM Pat | AttrCon loc.isLoc = @name == locIdent || @loc.childItf == locQIdent +gathAttrSource = Map.union (Map.fromList [ ((not @loc.isLoc, @name, nm), @lhs.stmtSource) | (nm,_) <- @loc.fields ]) -- Determines: "Where is each child defined. What is its start visit?" { type ChildSourceMap = Map Ident (Map Ident DepItem) } ATTR AllFinal [ distChildSource : ChildSourceMap | | ] ATTR AllVisFinal [ | | gathChildSource USE {`unionWithUnion`} {Map.empty} : ChildSourceMap ] SEM Program | Program blocks.distChildSource = Map.empty SEM SemVisit | Visit Internal loc.distChildSource = Map.unionsWith mappend [ @stmts.gathChildSource , Map.filterWithKey (notIn @loc.introChildren) @lhs.distChildSource ] SEM Clause | Clause loc.distChildSource = Map.unionsWith mappend [ @stmts.gathChildSource , Map.filterWithKey (notIn @loc.introChildren) @lhs.distChildSource ] SEM Stmt | Attach +gathChildSource = Map.insertWith mappend @name (Map.singleton @loc.visit @loc.stmtSource) -- Determines: "Where is each invoke defined?" { type VisitSourceMap = Map Ident (Map Ident DepItem) } ATTR AllFinal [ distVisitSource : VisitSourceMap | | ] ATTR AllVisFinal [ | | gathVisitSource USE {`unionWithUnion`} {Map.empty} : VisitSourceMap ] SEM Program | Program blocks.distVisitSource = Map.empty SEM SemVisit | Visit Internal loc.distVisitSource = Map.unionsWith mappend [ @stmts.gathVisitSource , Map.filterWithKey (notIn @loc.introChildren) @lhs.distVisitSource ] SEM Clause | Clause loc.distVisitSource = Map.unionsWith mappend [ @stmts.gathVisitSource , @impls.gathVisitSource , Map.filterWithKey (notIn @loc.introChildren) @lhs.distVisitSource ] SEM Stmt | Invoke +gathVisitSource = Map.insertWith mappend @name (Map.singleton @visit @loc.stmtSource) SEM ImplStmt | Invoke +gathVisitSource = Map.insertWith mappend @child (Map.singleton @visit @loc.stmtSource) -- Context: in what clause or visit are we in scope? ATTR AllFinal [ scopeReason, visitEndReason : Reason scopeDep, visitBeginDep, visitEndDep : DepItem | | ] SEM Program | Program blocks.scopeReason = ReasonScopeVisit (ident "") blocks.scopeDep = DepVisStart [ident ""] blocks.visitBeginDep = DepVisStart [ident ""] blocks.visitEndDep = DepVisEnd [ident ""] blocks.visitEndReason = ReasonScopeEnd (ident "") SEM SemVisit | Visit loc.scopeReason = ReasonScopeVisit @name loc.scopeDep = DepVisStart (@name : @lhs.semBasename) loc.visitBeginDep = DepVisStart (@name : @lhs.semBasename) loc.visitEndDep = DepVisEnd (@name : @lhs.semBasename) loc.visitEndReason = ReasonScopeEnd @name SEM SemVisit | Internal loc.scopeReason = ReasonScopeVisit @name loc.scopeDep = DepVisStart (@loc.name : @lhs.semBasename) loc.visitBeginDep = DepVisStart (@loc.name : @lhs.semBasename) loc.visitEndDep = DepVisEnd (@loc.name : @lhs.semBasename) loc.visitEndReason = ReasonScopeEnd @name SEM Clause | Clause loc.scopeReason = ReasonScopeClause @name loc.scopeDep = DepClause @loc.basename -- Gather dependencies { data Dep = Dep !DepItem !Reason !([DepItem]) deriving (Eq,Ord,Show) type Deps = Seq Dep addDep :: DepItem -> Reason -> [DepItem] -> Deps -> Deps addDep item reason deps = (Seq.<|) (Dep item reason deps) unknDep :: Dep unknDep = Dep unknDepItem ReasonError [unknDepItem] } ATTR AllFinal [ | | gathDeps USE {Seq.><} {Seq.empty} : Deps ] -- dependency on source of attr SEM AttrTypeCode | VisLocal ProdLocal Lhs Child Visit +gathDeps = addDep @lhs.stmtSource (ReasonAttrReq @lhs.child @lhs.name) [@loc.attrDep] loc.attrDep = Map.findWithDefault (mkUnknownDep @loc.depKey) @loc.depKey @lhs.distAttrSource SEM AttrTypeCode | VisLocal Lhs loc.depKey = (True,@lhs.child,@lhs.name) SEM AttrTypeCode | Child Visit ProdLocal loc.depKey = (False,@lhs.child,@lhs.name) { mkUnknownDep :: Show a => a -> DepItem mkUnknownDep s = DepVisStart [ident ("unknown" ++ show s)] } -- dependency on syn and vis attrs of visit. Must be defined before visit end. SEM Clause | Clause -- lhs.scopeDep is identifier of visit +gathDeps = if @loc.isDeepest then (Seq.fromList [ Dep @lhs.visitEndDep (ReasonAttrReq lhsIdent attr) [Map.findWithDefault (trace ("Clause.Clause.unknown.syn: " ++ show (attr, @loc.distAttrSource) ) unknDepItem) (False,lhsIdent,attr) @loc.distAttrSource] | attr <- Map.keys @loc.synAttrMap ] Seq.><) else id +gathDeps = if @loc.isDeepest then (Seq.fromList [ Dep @lhs.visitEndDep (ReasonAttrReq visIdent attr) [Map.findWithDefault (trace "Clause.Clause.unknown.loc" unknDepItem) (False,visIdent,attr) @loc.distAttrSource] | attr <- Map.keys @lhs.localAttrs ] Seq.><) else id SEM Stmt | * -- dependency on start of visit or clause +gathDeps = addDep @loc.stmtSource @lhs.scopeReason [@lhs.scopeDep] SEM ImplStmt | * -- dependency on start of visit or clause +gathDeps = addDep @loc.stmtSource @lhs.scopeReason [@lhs.scopeDep] SEM ImplStmt | DefaultChild DefaultSyn -- dependency on default stmt if reference to code +gathDeps = case @mbCodeRef of Nothing -> id Just ref -> addDep @loc.stmtSource (ReasonDefault @name) [DepDefault ref] SEM Stmt | Eval -- dependency: must be before end of visit for match statements +gathDeps = if @mode.isMatch then addDep @lhs.visitEndDep @lhs.visitEndReason [@loc.stmtSource] else id SEM Stmt | Invoke -- depends on: * previous invokes, nearest child, and defs for inh attrs loc.mbVisitSource = nearestVisitEntry False @visit @loc.childVisits $ Map.findWithDefault Map.empty @name @lhs.distVisitSource loc.mbChildSource = nearestVisitEntry True @visit @loc.childVisits $ Map.findWithDefault Map.empty @name @lhs.distChildSource +gathDeps = case @loc.mbVisitSource of Nothing -> id Just (_,d) -> addDep @loc.stmtSource (ReasonInvokeReq @visit) [d] +gathDeps = case @loc.mbChildSource of Nothing -> id Just (_,d) -> addDep @loc.stmtSource (ReasonChildReq @name) [d] +gathDeps = Seq.fromList [ Dep @loc.stmtSource (ReasonAttrReq @name attr) [Map.findWithDefault (trace "Stmt.Invoke.unknown.inh" unknDepItem) (True,@name,attr) @lhs.distAttrSource] | attr <- Map.keys @loc.inhAttrMap ] Seq.>< +gathDeps = addDep @lhs.visitEndDep @lhs.visitEndReason [@loc.stmtSource] SEM ImplStmt | Invoke -- depends on: * previous invokes, nearest child, and defs for inh attrs loc.mbVisitSource = nearestVisitEntry False @visit @loc.childVisits $ Map.findWithDefault Map.empty @child @lhs.distVisitSource loc.mbChildSource = nearestVisitEntry True @visit @loc.childVisits $ Map.findWithDefault Map.empty @child @lhs.distChildSource +gathDeps = case @loc.mbVisitSource of Nothing -> id Just (_,d) -> addDep @loc.stmtSource (ReasonInvokeReq @visit) [d] +gathDeps = case @loc.mbChildSource of Nothing -> id Just (_,d) -> addDep @loc.stmtSource (ReasonChildReq @child) [d] +gathDeps = Seq.fromList [ Dep @loc.stmtSource (ReasonAttrReq @child attr) [Map.findWithDefault (trace "ImplStmt.Invoke.unknown.inh" unknDepItem) (True,@child,attr) @lhs.distAttrSource] | attr <- Map.keys @loc.inhAttrMap ] Seq.>< -- +errs2 = debugMsg ("Impl invoke: " ++ show @child ++ ", visit: " ++ show @visit ++ ", inh attrs: " ++ show @loc.inhAttrMap ++ "\nsource: " ++ show @lhs.distAttrSource) Seq.>< { nearestVisitEntry :: Bool -> Ident -> [Ident] -> Map Ident DepItem -> Maybe (Ident,DepItem) nearestVisitEntry inclusive vis order mp = case [ (b, Map.findWithDefault (trace "nearestVisitEntry.unknown" unknDepItem) b mp) | b <- befores, Map.member b mp ] of [] -> Nothing (e:_) -> Just e where entries = Map.assocs mp befores = reverse $ (takeWhile (/= vis) order ++ (if inclusive then [vis] else [])) } -- deal with previous attach SEM Stmt | Attach loc.childSources = Map.findWithDefault Map.empty @name @lhs.distChildSource loc.mbPrevEntry = nearestVisitEntry False @loc.visit @loc.childVisits @loc.childSources +gathDeps = case @loc.mbPrevEntry of Nothing -> id Just (_,d) -> addDep @loc.stmtSource (ReasonAttach @name @loc.visit) [d] -- deal with detach SEM Item | Detach -- depends on: prev visits and children loc.mbVisitSource = nearestVisitEntry False @visit @loc.childVisits $ Map.findWithDefault Map.empty @name @lhs.distVisitSource loc.mbChildSource = nearestVisitEntry False @visit @loc.childVisits $ Map.findWithDefault Map.empty @name @lhs.distChildSource +gathDeps = case @loc.mbVisitSource of Nothing -> id Just (_,d) -> addDep @lhs.stmtSource (ReasonDetach @name @visit) [d] +gathDeps = case @loc.mbChildSource of Nothing -> id Just (_,d) -> addDep @lhs.stmtSource (ReasonDetach @name @visit) [d] SEM SemVisit | Visit -- depends on end of prev visit, end depends on begin +gathDeps = if null @lhs.doneVisits then id else addDep @loc.scopeDep @lhs.visitEndReason [@lhs.visitEndDep] +gathDeps = addDep @loc.visitEndDep (ReasonScopeVisit @name) [@loc.scopeDep] SEM SemVisit | Internal -- depends on end of prev visit, end depends on begin +gathDeps = addDep @loc.scopeDep @lhs.visitEndReason [@lhs.visitEndDep] +gathDeps = addDep @loc.visitEndDep (ReasonScopeVisit @name) [@loc.scopeDep] SEM Clause | Clause -- should be in between visit start and end +gathDeps = addDep @loc.scopeDep @lhs.scopeReason [@lhs.scopeDep] +gathDeps = addDep @lhs.visitEndDep @lhs.visitEndReason [@loc.scopeDep] SEM ImplStmt | DefaultChild DefaultSyn -- depend on generated stmt +gathDeps = case @mbCodeRef of Nothing -> id Just ref -> addDep @loc.stmtSource (ReasonDefault @name) [DepDefault ref] SEM ImplStmt | DefaultVisLocal -- may not escape visit +gathDeps = addDep @lhs.visitEndDep @lhs.visitEndReason [@loc.stmtSource] SEM ImplStmt -- depend on children + inh attrs | DefaultChild DefaultSyn +gathDeps = if @loc.lhsHasAttr then addDep @loc.stmtSource (ReasonAttrReq lhsIdent @name) [Map.findWithDefault (trace "ImplStmt.Default.lhsinh" unknDepItem) (True,lhsIdent,@name) @lhs.distAttrSource] else id +gathDeps = Seq.fromList [ Dep @loc.stmtSource (ReasonAttrReq c a) [Map.findWithDefault (trace "ImplStmt.Default.childsyn" unknDepItem) (False,c,a) @lhs.distAttrSource] | (c,a) <- @loc.childAttrs ] Seq.>< -- +errs2 = debugMsg ("dependencies: " ++ show @loc.stmtSource ++ ", attr: " ++ show @name ++ ", children: " ++ show @loc.children) Seq.>< ATTR AllFinal [ distRanks : {Map DepItem (Bool,Int)} | | ] SEM Program | Program loc.unqDeps = Map.fromListWith (\(r1,as) (r2,bs) -> (mostDescriptiveReason r1 r2,nub (as ++ bs))) [ (from, (reason,tos)) | (Dep from reason tos) <- toList @blocks.gathDeps ] `Map.union` (Map.fromList [ (i, (ReasonSink,[])) | i <- @loc.unqItems ]) loc.unqItems = Set.toList $ Set.fromList $ concatMap (\(Dep from _ tos) -> from : tos) $ toList @blocks.gathDeps loc.components = analyze (toList @blocks.gathSemStarts) (toList @blocks.gathVisitStarts) (toList @blocks.gathVisitEnds) @blocks.gathAvoidVisits $ map (\(from,(reason,tos)) -> (reason,from,tos)) $ Map.assocs @unqDeps loc.distRanks = let merge rank (AcyclicSCC d) = [(d,(False,rank))] merge rank (CyclicSCC ps) = zip ps (repeat (True,rank)) mp = Map.fromList $ concat $ zipWith merge [1..] @loc.components in mp loc.cyclicComps = let isCyclicSCC (CyclicSCC _) = True isCyclicSCC _ = False fromCyclicSCC (CyclicSCC xs) = xs in [ fromCyclicSCC c | c <- @loc.components, isCyclicSCC c ] loc.cyclicItems = Set.fromList $ concat @loc.cyclicComps loc.cyclicErrComps = let isLegalComp items = length vis <= 1 && all isLegal items && any isInvoke items where vis = nub [ Map.findWithDefault item item @blocks.gathItemVisits | item <- items ] isLegal (DepClause _) = True isLegal (DepVisStart _) = True isLegal (DepVisEnd _) = True isLegal item = Set.member item @blocks.gathLegalCycStmts isInvoke (DepInvoke _) = True isInvoke _ = False in filter (not . isLegalComp) @loc.cyclicComps +errs4 = Seq.fromList (map (Err_Cyclic @lhs.pos @blocks.gathStmtPosMap) @loc.cyclicErrComps) Seq.>< { mostDescriptiveReason r1 r2 = case r2 of ReasonAttrReq _ _ -> r2 _ -> r1 instance Show a => Show (SCC a) where show (CyclicSCC xs) = unwords (map show xs) show (AcyclicSCC x) = show x } ATTR Stmt ImplStmt [ | | rank : Int ] ATTR Pats Pat [ isCyclic : Bool | | ] SEM Stmt | * (loc.isOnCycle, loc.rank) = Map.findWithDefault (False,@loc.lexOrder) @loc.stmtSource @lhs.distRanks loc.isCyclic = @loc.fullCyclic || @loc.isOnCycle SEM ImplStmt | * (loc.isOnCycle, loc.rank) = Map.findWithDefault (False,@loc.lexOrder) @loc.stmtSource @lhs.distRanks loc.isCyclic = @loc.fullCyclic || @loc.isOnCycle SEM SemVisit | Visit Internal (loc.isOnCycle, loc.rank) = Map.findWithDefault (False,@loc.lexOrder) @loc.scopeDep @lhs.distRanks loc.isCyclic = @loc.fullCyclic || @loc.isOnCycle SEM Clause | Clause (loc.isOnCycle, loc.rank) = Map.findWithDefault (False,@loc.lexOrder) @loc.scopeDep @lhs.distRanks loc.isCyclic = @lhs.fullCyclic || @loc.isOnCycle -- Max rank of clauses ATTR AllVisitClauses [ | | minRank USE {`min`} {maxBound} : Int ] SEM Clause | Clause lhs.minRank = @loc.rank SEM SemVisit | Visit Internal lhs.minRank = @loc.rank -- -- Pretty-print of the AST -- { instance PP Ident where pp = text . identName } ATTR Block Itf ItfVisit Attr Data Type AliasType Con Field FieldType DataSem MaybeBoundCode BoundCode Code Item SemVisit VisitAttr Clause Stmt ImplStmt Mode Bind Pat ExprField [ | | pp : {PP_Doc} ] SEM Program | Program loc.ppId = vlist @blocks.pps SEM Block | Section lhs.pp = "{" >-< @code.pp >-< "}" | Itf lhs.pp = @itf.pp | Data lhs.pp = @data.pp | Type lhs.pp = @type.pp | Item lhs.pp = @name >#< "=" >-< indent 2 @item.pp | DataSem lhs.pp = @sem.pp SEM Itf | Itf lhs.pp = "itf" >#< @name >-< indent 2 (vlist @visits.pps) SEM ItfVisit | Visit lhs.pp = "visit" >#< @name >#< (if @cyclic then text "cyclic" else empty) >-< indent 2 (vlist @attrs.pps) SEM Attr | Inh lhs.pp = "inh" >#< @name >#< "::" >#< @type | Syn lhs.pp = "syn" >#< @name >#< "::" >#< @type SEM Data | Data lhs.pp = "data" >#< @name >-< indent 2 ( vlist @cons.pps ) SEM Con | Con lhs.pp = "con" >#< @name >-< indent 2 (vlist @fields.pps) SEM Field | Field lhs.pp = @name >#< @type.pp SEM FieldType | Term lhs.pp = "::" >#< @type | Nonterm lhs.pp = ":" >#< show @name SEM Type | Alias lhs.pp = "type" >#< show @name >#< ":" >#< @type.pp SEM AliasType | Prod lhs.pp = pp_block "(" ")" "," (map (text . show) @fields) | List lhs.pp = pp_brackets (text $ show @type) | Maybe lhs.pp = "Maybe" >#< show @type SEM DataSem | Sem lhs.pp = "datasem" >#< show @tp >-< indent 2 @clauses.pp SEM BoundCode | Code lhs.pp = @bind.pp >#< @code.pp SEM MaybeBoundCode | Nothing lhs.pp = empty SEM Code | Code lhs.pp = vlist @items.pps SEM Item | Plain loc.pp = vlist (modifySpacing @loc.diff @lhs.indent @txt) | Attr lhs.pp = addSpaces @loc.diff (@child >|< "." >|< @name) | Sem lhs.pp = addSpaces @loc.diff ("sem" >#< @name >#< ":" >#< @tp >-< indent 2 @first.pp) | CoSem lhs.pp = addSpaces @loc.diff ("cosem" >#< @name >#< ":" >#< @tp >#< @visit >-< indent 2 @first.pp) | Detach lhs.pp = addSpaces @loc.diff ("detach" >#< @name >#< "of" >#< @visit) | Brackets lhs.pp = addSpaces @loc.diff (text "{") >-< vlist @items.pps >-< addSpaces @loc.diff2 (text "}") | Construct lhs.pp = addSpaces @loc.diff (show @data >|< "." >|< show @con >#< pp_block "{" "}" "," @fields.pps) ATTR Code Items Item ExprFields ExprField DataSem SemVisit Stmts ClausesTop Clauses Clause Stmt [ indent : Int | | ] SEM Block | Section code.indent = 1 | Item item.indent = 1 | DataSem sem.indent = 1 SEM BoundCode | Code code.indent = column @pos + @bind.width SEM Item | * loc.diff = column @pos - @lhs.indent | Brackets loc.diff2 = column @posEnd - @lhs.indent { modifySpacing :: Int -> Int -> String -> [String] modifySpacing n m s = take (length ls) (r : rs) where ls = lines s (f : fs) = ls ++ [""] r = shift n f rs = map (drop (m-1)) fs shift :: Int -> String -> String shift n | n <= 0 = drop n | n > 0 = (replicate n ' ' ++) addSpaces :: Int -> PP_Doc -> PP_Doc addSpaces n d = text (replicate n ' ') >|< d } SEM SemVisit | Visit lhs.pp = "visit" >#< @name >-< indent 2 ( vlist @attrs.pps >-< vlist @stmts.pps >-< vlist @impls.pps >-< vlist @clauses.pps ) | Internal lhs.pp = "internal" >#< @name >-< indent 2 ( vlist @stmts.pps >-< vlist @clauses.pps ) | End lhs.pp = empty SEM VisitAttr | Chn lhs.pp = "chn" >#< @name >#< "::" >#< @type SEM Clause | Clause lhs.pp = "clause" >#< @name >-< indent 2 ( vlist @stmts.pps >-< vlist @impls.pps >-< vlist @deflts.pps >-< @next.pp ) SEM Stmt | Eval lhs.pp = @mode.pp >|< @pat.pp >#< @code.pp | Attach lhs.pp = "attach" >#< @loc.visit >#< "of" >#< @name >#< ":" >#< @type >#< @code.pp | Invoke lhs.pp = vlist @deflts.pps >-< "invoke" >#< @visit >#< "of" >#< @name >#< @code.pp | Default lhs.pp = "default" >#< @name >#< "..." | Rename lhs.pp = empty SEM ImplStmt | Invoke lhs.pp = vlist @deflts.pps >-< "invoke" >#< show @visit >#< "of" >#< show @child >#< "-- implicit" | DefaultChild lhs.pp = "default" >#< show @child >|< "." >|< show @name >#< pp_block "(" ")" "," (reverse @loc.ppInps) | DefaultSyn lhs.pp = "default lhs." >|< show @name >#< pp_block "(" ")" "," (reverse @loc.ppInps) | DefaultVisLocal lhs.pp = "default local." >|< show @name | DefaultChild DefaultSyn loc.ppInps = (if @loc.lhsHasAttr then [text "lhs"] else []) ++ map (\(c,_,_) -> text $ show c) @loc.children SEM Mode | Match lhs.pp = text "match " | Assert lhs.pp = empty SEM Bind | Fun lhs.pp = text "=" | Monadic lhs.pp = text "<-" ATTR Bind [ | | width : Int ] SEM Bind | Fun lhs.width = 1 | Monadic lhs.width = 2 SEM Pat | Con loc.needPar = needParens PrioCon @lhs.prio @lhs.isRight | Cons loc.needPar = needParens PrioCons @lhs.prio @lhs.isRight SEM Pat | Con lhs.pp = addParens @loc.needPar (@name >#< hlist_sp @pats.pps) | AttrCon lhs.pp = show @dt >|< "." >|< show @con >|< "@" >|< @name | Attr lhs.pp = @child >|< "." >|< @name | Tup lhs.pp = pp_block "(" ")" "," @pats.pps | List lhs.pp = pp_block "[" "]" "," @pats.pps | Cons lhs.pp = addParens @loc.needPar (@hd.pp >#< ":" >#< @tl.pp) | Underscore lhs.pp = text "_" ATTR Pat Pats [ prio : Prio | | ] ATTR Pat [ isRight : Bool | | ] SEM Stmt | Eval pat.prio = PrioTop pat.isRight = False SEM Pat | Con pats.prio = PrioCon | Tup pats.prio = PrioTop | List pats.prio = PrioTop | Cons hd.prio = PrioCons tl.prio = PrioCons SEM Pats | Cons hd.isRight = False SEM Pat | Cons hd.isRight = False tl.isRight = True { data Prio = PrioTop | PrioCons | PrioCon deriving (Eq, Ord) needParens :: Prio -> Prio -> Bool -> Bool needParens myPrio lhsPrio isRight = myPrio <= lhsPrio && (myPrio /= lhsPrio || isRight) addParens :: Bool -> PP_Doc -> PP_Doc addParens True = pp_parens addParens False = id } SEM ExprField | Field lhs.pp = @name >-< indent 2 ("=" >#< pp_parens @code.pp) ATTR BlocksTop Blocks ItfVisits Attrs Items VisitAttrs ClausesTop Clauses Stmts ImplStmts Pats Cons Fields ExprFields [ | | pps : {[PP_Doc]} ] SEM BlocksTop | Top lhs.pps = @blocks.pps ++ @extra.pps | None lhs.pps = [] SEM Blocks | Cons lhs.pps = @hd.pp : @tl.pps | Nil lhs.pps = [] SEM ItfVisits | Cons lhs.pps = @hd.pp : @tl.pps | Nil lhs.pps = [] SEM Attrs | Cons lhs.pps = @hd.pp : @tl.pps | Nil lhs.pps = [] SEM Cons | Cons lhs.pps = @hd.pp : @tl.pps | Nil lhs.pps = [] SEM Fields | Cons lhs.pps = @hd.pp : @tl.pps | Nil lhs.pps = [] SEM Items | Cons lhs.pps = @hd.pp : @tl.pps | Nil lhs.pps = [] SEM VisitAttrs | Cons lhs.pps = @hd.pp : @tl.pps | Nil lhs.pps = [] SEM Clauses | Cons lhs.pps = @hd.pp : @tl.pps | Nil lhs.pps = [] SEM Stmts | Cons lhs.pps = @hd.pp : @tl.pps | Nil lhs.pps = [] SEM ImplStmts | Cons lhs.pps = @hd.pp : @tl.pps | Nil lhs.pps = [] SEM Pats | Cons lhs.pps = @hd.pp : @tl.pps | Nil lhs.pps = [] SEM ExprFields | Cons lhs.pps = @hd.pp : @tl.pps | Nil lhs.pps = []