ruler-core-1.0: src/Transform.ag
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 "<root>"]
| Item item.nonterm = [ident "<root>"]
| DataSem sem.nonterm = [ident "<root>"]
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 "<root>"]
loc.coItf = ident "<root>"
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 "<unknown>" @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 "<undefined>"
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 "<unknownvisit>") (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 "<root>"]
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 "<root>")
blocks.scopeDep = DepVisStart [ident "<root>"]
blocks.visitBeginDep = DepVisStart [ident "<root>"]
blocks.visitEndDep = DepVisEnd [ident "<root>"]
blocks.visitEndReason = ReasonScopeEnd (ident "<root>")
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 = []