uuagc-0.9.50: src-ag/DefaultRules.ag
-- 13 okt 2011: eliminated the "multiRule" transformation for all but the Kastens-code
-- the SELF types are also eliminated in this phase: in a Type value, there should not be
-- a Self constructor anymore.
PRAGMA strictdata
PRAGMA optimize
PRAGMA bangpats
PRAGMA strictwrap
INCLUDE "AbstractSyntax.ag"
INCLUDE "Patterns.ag"
INCLUDE "DistChildAttr.ag"
imports
{
import qualified Data.List
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Map(Map)
import qualified Data.Sequence as Seq
import Data.Sequence(Seq,(><))
import UU.Scanner.Position(noPos)
import Pretty
import Data.Maybe
import HsToken
import HsTokenScanner
import Data.List(intersperse)
import Data.Char
import AbstractSyntax
import ErrorMessages
import Options
}
-------------------------------------------------------------------------------
-- Passing down corresponding nonterminal and constructor names
-------------------------------------------------------------------------------
ATTR Rule Rules Child Children Production Productions TypeSigs TypeSig Pattern Patterns [ nt:NontermIdent | | ]
ATTR Rule Rules Child Children Pattern Patterns [ con:ConstructorIdent | | ]
ATTR Productions Production Children Child TypeSigs TypeSig [ params : {[Identifier]} | | ]
SEM Nonterminal | Nonterminal
prods.params = @params
-------------------------------------------------------------------------------
-- Distributing options
-------------------------------------------------------------------------------
ATTR Grammar Nonterminals Nonterminal Productions Production Rules Rule
[ options:{Options}
constructorTypeMap : {Map NontermIdent ConstructorType} | | ]
ATTR Nonterminals Nonterminal Productions Production [ o_rename:{Bool}
cr:Bool {- copy rule -}
| | ]
ATTR Children Child [ cr:Bool {- copy rule -} | | ]
SEM Grammar
| Grammar nonts.o_rename = rename @lhs.options
nonts.cr = modcopy @lhs.options
-------------------------------------------------------------------------------
-- Passing down the set of wrapper names
-------------------------------------------------------------------------------
ATTR Nonterminals Nonterminal Productions Production [ wrappers : {Set NontermIdent} | | ]
SEM Grammar | Grammar
nonts.wrappers = @wrappers
-------------------------------------------------------------------------------
-- Type synonyms environment
-------------------------------------------------------------------------------
ATTR Nonterminals Nonterminal Productions Production [ typeSyns : {TypeSyns} | | ]
-------------------------------------------------------------------------------
-- some auxiliary functions
-------------------------------------------------------------------------------
{
fieldName n = '@' : getName n
locName n = "@loc." ++ getName n
attrName fld attr
| fld == _LOC = locName attr
| fld == _FIELD = fieldName attr
| otherwise = '@' : getName fld ++ "." ++ getName attr
_ACHILD = Ident "(" noPos -- hack
mkLocVar = AGField _LOC
isRecordConstructor :: NontermIdent -> Map NontermIdent ConstructorType -> Bool
isRecordConstructor nt ctm = Map.lookup nt ctm == Just RecordConstructor
buildConExpr ocaml clean conmap typeSyns rename nt con1 fs'
| nt `elem` map fst typeSyns = if ocaml then synonymMl
else if clean then synonymClean
else synonymHs
| otherwise = normalExpr
where fs = map fst fs'
con = getName con1
tup = " " ++ buildTuple fs
args = " " ++ unwords fs
normalExpr = if clean && isRecordConstructor nt conmap
then "{" ++ con ++ "|" ++
unwords (intersperse "," $ map (\(new, old) -> getName old ++ " = " ++ new) fs')
++ "}"
else conname' ++ args
conname' | rename = getName nt ++ "_" ++ getName con1
| otherwise = getName con1
synonymHs | con == "Tuple" = buildTuple fs
| con == "Cons" = "(:)" ++ args
| con == "Nil" = case lookup nt typeSyns of
Just (Map _ _) -> "Data.Map.empty"
Just (IntMap _) -> "Data.IntMap.empty"
Just (OrdSet _) -> "Data.Set.empty"
Just IntSet -> "Data.IntSet.empty"
_ -> "[]"
| con == "Just" = "Just" ++ args
| con == "Nothing" = "Nothing"
| con == "Entry" = ( case lookup nt typeSyns of
Just (Map _ _) -> "Data.Map.insert"
Just (IntMap _) -> "Data.IntMap.insert"
Just (OrdSet _) -> "Data.Set.insert"
Just IntSet -> "Data.IntSet.insert" ) ++ args
| otherwise = normalExpr
synonymMl | con == "Tuple" = buildTuple fs
| con == "Cons" = "(::)" ++ tup
| con == "Nil" = case lookup nt typeSyns of
Just (Map _ _) -> prefixMod nt "empty"
Just (IntMap _) -> prefixMod nt "empty"
Just (OrdSet _) -> prefixMod nt "empty"
Just IntSet -> prefixMod nt "empty"
_ -> "[]"
| con == "Just" = "Some" ++ tup
| con == "Nothing" = "None"
| con == "Entry" = ( case lookup nt typeSyns of
Just (Map _ _) -> prefixMod nt "add"
Just (IntMap _) -> prefixMod nt "add"
Just (OrdSet _) -> prefixMod nt "add"
Just IntSet -> prefixMod nt "add" ) ++ args
| otherwise = normalExpr
synonymClean | con == "Tuple" = buildTuple fs
| con == "Cons" = "(\\x xs -> [x:xs])" ++ args
| con == "Nil" = case lookup nt typeSyns of
Just (Map _ _) -> "Data.Map.empty"
Just (IntMap _) -> "Data.IntMap.empty"
Just (OrdSet _) -> "Data.Set.empty"
Just IntSet -> "Data.IntSet.empty"
_ -> "[]"
| con == "Just" = "Just" ++ args
| con == "Nothing" = "Nothing"
| con == "Entry" = ( case lookup nt typeSyns of
Just (Map _ _) -> "Data.Map.insert"
Just (IntMap _) -> "Data.IntMap.insert"
Just (OrdSet _) -> "Data.Set.insert"
Just IntSet -> "Data.IntSet.insert" ) ++ args
| otherwise = normalExpr
prefixMod nt nm = "M_" ++ getName nt ++ "." ++ nm
concatSeq = foldr (Seq.><) Seq.empty
splitAttrs :: Map Identifier a -> [Identifier] -> ([(Identifier,a)],[Identifier]) -- a used as (String,String)
splitAttrs _ []
= ([],[])
splitAttrs useMap (n:rest)
= let (uses,normals) = splitAttrs useMap rest
in case Map.lookup n useMap of
Just x -> ((n,x):uses , normals )
Nothing -> ( uses , n:normals )
removeDefined :: Set (Identifier,Identifier) -> (Identifier,Attributes) -> (Identifier,[Identifier])
removeDefined defined (fld,as)
= ( fld
, [ a
| a <- Map.keys as
, not (Set.member (fld,a) defined)
]
)
}
-------------------------------------------------------------------------------
-- Errors
-------------------------------------------------------------------------------
ATTR Grammar Nonterminals Nonterminal Productions Production
Child Children Rule Rules Pattern Patterns
[ | | errors USE {Seq.><} {Seq.empty}:{Seq Error} ]
-------------------------------------------------------------------------------
-- Set of all defined nonterminals
-------------------------------------------------------------------------------
ATTR Nonterminals Nonterminal [ || collect_nts USE {`Set.union`} {Set.empty} : {Set NontermIdent} ]
SEM Nonterminal
| Nonterminal lhs.collect_nts = Set.singleton @nt
ATTR Nonterminals Nonterminal Productions Production [ nonterminals : {Set NontermIdent} || ]
SEM Grammar
| Grammar nonts.nonterminals = @nonts.collect_nts
-------------------------------------------------------------------------------
-- Pass down the lhs-attributes and the USE's to each alternative of a nonterminal
-------------------------------------------------------------------------------
ATTR Nonterminals Nonterminal [ useMap : {UseMap} || ]
ATTR Productions Production [ inh, syn, inhOrig, synOrig : {Attributes} useMap : {Map Identifier (String,String,String)}|| ]
SEM Nonterminal
| Nonterminal prods.inh = @loc.inh1
prods.syn = @loc.syn1
prods.inhOrig = @inh
prods.synOrig = @syn
prods.useMap = Map.findWithDefault Map.empty @nt @lhs.useMap
SEM Production
| Production rules.con = @con
children.con = @con
SEM Child
| Child lhs . name = @name
SEM Grammar
| Grammar nonts . useMap = @useMap
SEM Grammar
| Grammar nonts . typeSyns = @typeSyns
SEM Nonterminal
| Nonterminal prods . nt = @nt
SEM Child [ | | name:{Identifier} inherited,synthesized:{Attributes} ]
| Child lhs.inherited = @loc.inh1
lhs.synthesized = if @name `Set.member` @lhs.merged
then Map.empty
else @loc.syn1
SEM Children [ | | inputs,outputs:{[(Identifier, Attributes)]} ]
| Cons lhs.inputs = (@hd.name, @hd.inherited) : @tl.inputs
.outputs = (@hd.name, @hd.synthesized) : @tl.outputs
| Nil lhs.inputs = []
.outputs = []
-------------------------------------------------------------------------------
-- Implementation of Use-rule and Copy-rule
-------------------------------------------------------------------------------
{
deprecatedCopyRuleError nt con fld a
= let mesg =
"In the definitions for alternative"
>#< getName con
>#< "of nonterminal"
>#< getName nt
>|< ","
>-< "the value of field"
>#< getName a
>#< "is copied by a copy-rule."
>-< "Copying the value of a field using a copy-rule is deprecated"
>-< "Please add the following lines to your code:"
>-< ( "SEM"
>#< getName nt
>-< indent 2 ( "|"
>#< getName con
>#< getName fld
>#< "."
>#< a
>#< "="
>#< "@"
>|< a
)
)
in CustomError True (getPos a) mesg
missingRuleErrorExpr clean nt con fld a
= (if clean then "abort" else "error")
++ " \"missing rule: "
++ show nt ++ "." ++ show con ++ "."
++ show fld ++ "." ++ show a ++ "\""
makeRule :: (Identifier,Identifier) -> Expression -> String -> Bool -> Maybe Error -> Rule
makeRule (f1,a1) expr origin identity mbDelayedError
= Rule Nothing
(Alias f1 a1 (Underscore noPos))
expr
False
origin
False
True
identity
mbDelayedError
False
useRule :: Options -> Set Identifier -> [(Identifier,Attributes)] -> (Identifier,(String,String,String)) -> Rule
useRule opts locals ch_outs (n,(op,e,pos))
= let elems = [ fld
| (fld,as) <- ch_outs
, Map.member n as
]
isOp [] = False
isOp (c:cs)
| isSpace c = isOp cs
| isAlpha c = case dropWhile isAlpha cs of
('.':cs2) -> isOp cs2 -- fully qualified name, drop prefix
_ -> False
| c == '(' = False
| otherwise = True
tks | Set.member n locals = [mkLocVar n noPos Nothing]
| null elems = lexTokens opts noPos e
| otherwise = lexTokens opts noPos str
where
opExpr l r
| isOp op = l ++ " " ++ op ++ " " ++ r -- takes the associativity of the operator
| otherwise = "(" ++ op ++ " " ++ l ++ " " ++ r ++ ")" -- associates to the right
str = foldr1 opExpr (map (flip attrName n) elems)
in makeRule (_LHS,n)
(Expression noPos tks)
("use rule " ++ pos)
False
Nothing
selfRule :: Bool -> Identifier -> [HsToken] -> Rule
selfRule lhsNecLoc attr tks
= makeRule (if lhsNecLoc then _LHS else _LOC,attr)
(Expression noPos tks)
"self rule"
False
Nothing
concatRE rsess = let (rss,ess) = unzip rsess
in (concat rss, concatSeq ess)
copyRule :: Options -> Set NontermIdent -> Identifier -> Identifier -> Bool -> Set Identifier -> (Map Identifier Identifier, (Identifier,[Identifier])) -> ([Rule], Seq Error)
copyRule options wrappers nt con modcopy locals (env,(fld,as))
= concatRE (map copyRu as)
where
copyRu a
= ( [ makeRule (fld,a)
(Expression noPos tks)
(cruletxt sel)
True
mbDelayedErr
]
, err
)
where
sel
| not modcopy
&& Set.member a locals = Just _LOC
| otherwise = Map.lookup a env
(tks,err,mbDelayedErr)
= case sel of
Nothing -> let tks = [HsToken (missingRuleErrorExpr (clean options) nt con fld a) noPos]
err = MissingRule nt con fld a
in if nt `Set.member` wrappers && kennedyWarren options
then (tks, Seq.empty, Just err) -- yield error only if the rule is actually scheduled; for kennedyWarren code gen only
else (tks, Seq.singleton err, Nothing)
Just f
| f == _ACHILD -> ( [AGLocal a noPos Nothing]
, Seq.singleton (deprecatedCopyRuleError nt con fld a)
, Nothing
)
| otherwise -> ( [AGField f a noPos Nothing]
, Seq.empty
, Nothing
)
cruletxt sel
| local = "copy rule (from local)"
| deprChild = "deprecated child copy"
| Set.member a locals && nonlocal = "modified copy rule"
| incoming && outgoing = "copy rule (chain)"
| incoming = "copy rule (down)"
| outgoing = "copy rule (up)"
| otherwise = "copy rule (chain)"
where outgoing = fld == _LHS
incoming = maybe False (== _LHS) sel
nonlocal = maybe False (/= _LOC) sel
local = maybe False (== _LOC) sel
deprChild = maybe False (== _ACHILD) sel
}
SEM Production
| Production
lhs.errors = @children.errors >< @errs >< @rules.errors >< @loc.orderErrs
loc.(newRls, errs)
=
let locals = @rules.locals
initenv = Map.fromList ( [ (a,_ACHILD) -- _ACHILD is used to mark identifiers in the environment that are terminals
| (a,_,_) <- @children.fields
]
++ attrs(_LHS, @lhs.inh)
++ [ (a,_LOC)
| a <- Set.toList locals
]
)
attrs (n,as) = [ (a,n) | a <- Map.keys as ]
envs = scanl (flip Map.union)
initenv
(map (Map.fromList . attrs ) @children.outputs)
child_envs = init envs
lhs_env = last envs
(selfAttrs, normalAttrs)
= Map.partitionWithKey (\k _ -> maybe False isSELFNonterminal $ Map.lookup k @lhs.synOrig) @lhs.syn
(_,undefAttrs)
= removeDefined @rules.definedAttrs (_LHS, normalAttrs)
(useAttrs,others)
= splitAttrs @lhs.useMap undefAttrs
(rules1, errors1)
= concatRE $ map (copyRule @lhs.options @lhs.wrappers @lhs.nt @con @lhs.cr locals)
(zip envs (map (removeDefined @rules.definedAttrs) @children.inputs))
uRules
= map (useRule @lhs.options locals @children.outputs) useAttrs
-- creates a loc.xxx if there is a synthesized attr xxx of type SELF and no
-- loc.xxx exists yet. If there exists a terminal yyy and a local loc.yyy, then
-- the local is chosen as value for the terminal.
selfLocRules
= [ selfRule False attr $
lexTokens @lhs.options noPos $ -- building a string and lexing it again is not so nice... but practical here
constructor [(childSelf attr nm tp, nm) | (nm,tp,virt) <- @children.fields, childExists virt]
| attr <- Map.keys selfAttrs
, not (Set.member attr locals)
]
where
childSelf self nm tp
= case tp of NT nt _ _ -> attrName nm self
_ | nm `Set.member` locals -> locName nm
| otherwise -> fieldName nm
constructor fs
= buildConExpr (ocaml @lhs.options) (clean @lhs.options) @lhs.constructorTypeMap @lhs.typeSyns @lhs.o_rename @lhs.nt @con fs
childExists ChildAttr = False
childExists _ = True
selfRules
= [ selfRule True attr [mkLocVar attr noPos Nothing]
| attr <- Map.keys selfAttrs
, not (Set.member (_LHS,attr) @rules.definedAttrs)
]
(rules5, errs5)
= copyRule @lhs.options
@lhs.wrappers
@lhs.nt
@con
@lhs.cr
locals
(lhs_env, (_LHS, others))
in (uRules++selfLocRules++selfRules++rules5++rules1, errors1><errs5)
{
buildTuple fs = "(" ++ concat (intersperse "," fs) ++ ")"
addAugments :: (Identifier, [Expression]) -> [Rule] -> [Rule]
addAugments (_, exprs) rules
| null exprs = rules
addAugments (syn, exprs) rules
= [rule] ++ funRules ++ map modify rules
where
rule = Rule Nothing (Alias _LHS syn (Underscore noPos)) rhs False "augmented rule" False True False Nothing False
rhs = Expression noPos tks
tks = [ HsToken "foldr ($) " noPos, mkLocVar substSyn noPos Nothing, HsToken " [" noPos] ++ funs ++ [HsToken "]" noPos]
funs = intersperse (HsToken ", " noPos) (map (\n -> mkLocVar n noPos Nothing) funNames)
substSyn = Ident (show syn ++ "_augmented_syn") (getPos syn)
funNames = zipWith (\i _ -> Ident (show syn ++ "_augmented_f" ++ show i) (getPos syn)) [1..] exprs
funRules = zipWith (\name expr -> Rule Nothing (Alias _LOC name (Underscore noPos)) expr False "augment function" False True False Nothing False) funNames exprs
modify (Rule mbNm pat rhs owrt origin expl pure identity mbErr eager)
| containsSyn pat = Rule mbNm (modifyPat pat) rhs owrt origin expl pure identity mbErr eager
modify r = r
containsSyn (Constr _ pats) = any containsSyn pats
containsSyn (Product _ pats) = any containsSyn pats
containsSyn (Irrefutable pat) = containsSyn pat
containsSyn (Alias field attr pat) = (field == _LHS && attr == syn) || containsSyn pat
containsSyn _ = False
modifyPat (Constr name pats) = Constr name (map modifyPat pats)
modifyPat (Product pos pats) = Product pos (map modifyPat pats)
modifyPat (Irrefutable pat) = Irrefutable (modifyPat pat)
modifyPat (Alias field attr pat)
| field == _LHS && attr == syn = Alias _LOC substSyn (modifyPat pat)
| otherwise = Alias field attr (modifyPat pat)
modifyPat p = p
-- adds the additional rules needed for around, which creates a sequence of
-- rules that form a function that each transforms the semantics of a child
-- before attaching the child.
-- The rule defines a local attribute "<child>_around" and <child> is dependent
-- on this attribute.
addArounds :: (Identifier, [Expression]) -> [Rule] -> [Rule]
addArounds (_, exprs) rules | null exprs = rules
addArounds (child, exprs) rules
= [rule] ++ funRules ++ rules
where
rule = Rule Nothing (Alias _LOC childLoc (Underscore noPos)) rhs False "around rule" False True False Nothing False
rhs = Expression noPos tks
tks = [ HsToken "\\s -> foldr ($) s " noPos, HsToken " [" noPos] ++ funs ++ [HsToken "]" noPos]
funs = intersperse (HsToken ", " noPos) (map (\n -> mkLocVar n noPos Nothing) funNames)
childLoc = Ident (show child ++ "_around") (getPos child)
funNames = zipWith (\i _ -> Ident (show child ++ "_around_f" ++ show i) (getPos child)) [1..] exprs
funRules = zipWith (\name expr -> Rule Nothing (Alias _LOC name (Underscore noPos)) expr False "around function" False True False Nothing False) funNames exprs
-- adds the additional rules needed for merging.
-- It produces for each merging child a rule with local attribute: "<child>_merged".
-- this rules takes the semantics of the first children and feeds it to the function
-- represented by this attribute. This attribute then defines the semantics for
-- the merging child.
addMerges :: (Identifier, (Identifier,[Identifier],Expression)) -> [Rule] -> [Rule]
addMerges (target,(_,_,expr)) rules
= rule : rules
where
rule = Rule Nothing (Alias _LOC childLoc (Underscore noPos)) expr False "merge rule" False True False Nothing False
childLoc = Ident (show target ++ "_merge") (getPos target)
}
ATTR Rule Rules Pattern Patterns
[ | | locals USE {`Set.union`} {Set.empty} : {Set Identifier}
definedAttrs USE {`Set.union`} {Set.empty} : {Set (Identifier,Identifier)}
]
SEM Pattern
| Alias lhs.definedAttrs = Set.insert (@field,@attr) @pat.definedAttrs
.locals = if @field == _LOC
then Set.insert @attr @pat.locals
else @pat.locals
SEM Children [ | | fields : {[(Identifier,Type,ChildKind)]} ]
| Cons lhs.fields = @hd.field : @tl.fields
| Nil lhs.fields = []
SEM Child [ | | field : { (Identifier,Type,ChildKind) } ]
| Child lhs.field = (@name,@tp,@kind)
-------------------------------------------------------------------------------
--
-------------------------------------------------------------------------------
ATTR Rule Pattern Patterns [ || containsVars USE {||} {False} : Bool ]
SEM Pattern
| Alias lhs.containsVars = True
ATTR Rule [ | | isPure : Bool ]
SEM Rule | Rule lhs.isPure = @pure
-------------------------------------------------------------------------------
-- Eliminate SELF types
-------------------------------------------------------------------------------
SEM Nonterminal | Nonterminal
loc.inh1 = Map.map (elimSelfId @nt @params) @inh
loc.syn1 = Map.map (elimSelfId @nt @params) @syn
SEM Child | Child
(loc.nt, loc.params) = case @tp of
NT nt params _ -> (nt, params)
Self -> error ("The type of child " ++ show @name ++ " should not be a Self type.")
Haskell t -> (identifier t, []) -- should be ignored because the child is a terminal
loc.inh1 = Map.map (elimSelfStr @loc.nt @loc.params) @loc.inh
loc.syn1 = Map.map (elimSelfStr @loc.nt @loc.params) @loc.syn
SEM TypeSig | TypeSig
loc.tp1 = elimSelfId @lhs.nt @lhs.params @tp
{
elimSelfId :: NontermIdent -> [Identifier] -> Type -> Type
elimSelfId nt args Self = NT nt (map getName args) False
elimSelfId _ _ tp = tp
elimSelfStr :: NontermIdent -> [String] -> Type -> Type
elimSelfStr nt args Self = NT nt args False
elimSelfStr _ _ tp = tp
}
-------------------------------------------------------------------------------
-- Reconstructing the tree
-------------------------------------------------------------------------------
ATTR Nonterminals Nonterminal Productions Production Rules Rule [ | uniq:Int | ]
SEM Grammar
| Grammar nonts.uniq = 1
ATTR Grammar Nonterminals Nonterminal Productions
Production Children Child Rules Rule Pattern Patterns TypeSigs TypeSig
[ | | output:SELF ]
ATTR Rule [ | | outputs:Rules ]
SEM Nonterminal | Nonterminal
lhs.output = Nonterminal @nt @params @loc.inh1 @loc.syn1 @prods.output
SEM Production
| Production
loc.extra1 = foldr addAugments (@rules.output ++ @newRls) (Map.assocs @loc.augmentsIn)
loc.extra2 = foldr addArounds @loc.extra1 (Map.assocs @loc.aroundsIn)
loc.extra3 = foldr addMerges @loc.extra2 (Map.assocs @loc.mergesIn)
lhs.output = Production @con @params @constraints @children.output @loc.extra3 @typeSigs.output @macro
SEM Child | Child
lhs.output = Child @name @tp @kind
SEM TypeSig | TypeSig
lhs.output = TypeSig @name @loc.tp1
SEM Rules
| Cons lhs.output = if @hd.containsVars && @hd.isPure then @hd.outputs ++ @tl.output else @tl.output
-- remove rules that define nothing and do not have side effects
SEM Rule
| Rule (loc.output1, loc.mbAlias) = mkRuleAlias @loc.output
(loc.outputs, lhs.uniq) = if needsMultiRules @lhs.options -- check if this works for UHC
then multiRule @loc.output1 @lhs.uniq
else ([@loc.output1], @lhs.uniq)
lhs.outputs = maybe [] return @loc.mbAlias ++ @loc.outputs
{
-- When a rule has a name, create an alias for a rule
-- and a modified rule that refers to the alias
-- Thus it removes rule names from rules
mkRuleAlias :: Rule -> (Rule, Maybe Rule)
mkRuleAlias r@(Rule Nothing _ _ _ _ _ _ _ _ _) = (r, Nothing)
mkRuleAlias (Rule (Just nm) pat expr owrt origin expl pure identity mbErr eager) = (r', Just alias) where
alias = Rule Nothing (Alias _LOC (Ident ("_rule_" ++ show nm) pos) (Underscore pos)) expr owrt origin expl pure identity mbErr eager
pos = getPos nm
expr' = Expression pos tks
tks = [mkLocVar (Ident ("_rule_" ++ show nm) pos) pos (Just ("Indirection to rule " ++ show nm))]
r' = Rule Nothing pat expr' owrt origin False True identity Nothing False
}
-- Work towards removing the need of the "multiRule".
-- It's currently only needed for the Kastens code generation
{
needsMultiRules :: Options -> Bool
needsMultiRules opts = (visit opts || withCycle opts) && not (kennedyWarren opts)
}
{
{-
multiRule replaces
loc.(a,b) = e
by
loc.tup1 = e
loc.(a,_) = @loc.tup1
loc.(_,b) = @loc.tup1
It needs to thread a unique number for inventing names for the tuples.
It also works for nested tuples:
loc.(a,(b,c)) = e
becomes
loc.tup1 = e
loc.(a,_) = @loc.tup1
loc.(_,tup2) = @loc.tup1
loc.(b,_) = @loc.tup2
loc.(_,c) = @loc.tup2
-}
multiRule :: Rule -> Int -> ([Rule], Int)
multiRule (Rule _ pat expr owrt origin expl pure identity mbErr eager) uniq
= let f :: Bool -> (Pattern->Pattern) -> Expression -> Pattern -> Int -> (Pattern, ([Rule], Int))
f expl' w e (Product pos pats) n
= let freshName = Ident ("_tup" ++ show n) pos
freshExpr = Expression pos freshTks
freshTks = [AGField _LOC freshName pos Nothing]
freshPat = Alias _LOC freshName (Underscore pos)
a = length pats - 1
us b p = Product pos (replicate (a-b) (Underscore pos) ++ [p] ++ replicate b (Underscore pos))
g :: Pattern -> ([Pattern],[Rule],Int) -> ([Pattern],[Rule],Int)
g p (xs1,rs1,n1) = let (x2,(rs2,n2)) = f False (us (length xs1)) freshExpr p n1
in (x2:xs1, rs2++rs1, n2)
(xs9,rs9,n9) = foldr g ([], [], n+1) pats
in ( freshPat
, ( Rule Nothing (w freshPat) e owrt origin expl' True False mbErr eager : rs9
, n9
)
)
f expl' w e p n
= ( p
, ( [Rule Nothing (w p) e owrt origin expl' True False mbErr eager]
, n
)
)
in snd (f expl id expr pat uniq)
}
-------------------------------------------------------------------------------
-- Check the order definitions
-------------------------------------------------------------------------------
ATTR Nonterminals Nonterminal Productions Production [ manualAttrOrderMap : {AttrOrderMap} | | ]
SEM Grammar
| Grammar
nonts.manualAttrOrderMap = @manualAttrOrderMap
ATTR Rules Rule [ | | ruleNames USE {`Set.union`} {Set.empty} : {Set Identifier} ]
SEM Rule | Rule lhs.ruleNames = case @mbName of
Nothing -> Set.empty
Just nm -> Set.singleton nm
SEM Production
| Production
loc.orderDeps = Set.toList $ Map.findWithDefault Set.empty @con $ Map.findWithDefault Map.empty @lhs.nt @lhs.manualAttrOrderMap
loc.orderErrs
= let chldOutMap = Map.fromList [ (k, Map.keysSet s) | (k,s) <- @children.outputs ]
chldInMap = Map.fromList [ (k, Map.keysSet s) | (k,s) <- @children.inputs ]
-- a local attribute
-- or an inherited attribute of the production
-- or an out-attribute of a child
isInAttribute :: Identifier -> Identifier -> [Error]
isInAttribute fld nm
| fld == _LOC = if nm `Set.member` @rules.locals
then []
else [UndefAttr @lhs.nt @con fld nm False]
| fld == _LHS = if nm `Map.member` @lhs.inh
then []
else [UndefAttr @lhs.nt @con fld nm False]
| otherwise = if nm `Set.member` (Map.findWithDefault Set.empty fld chldOutMap)
then []
else [UndefAttr @lhs.nt @con fld nm False]
-- a local attribute
-- or a synthesized attribute of the production
-- or an in-attribute of a child
isOutAttribute :: Identifier -> Identifier -> [Error]
isOutAttribute fld nm
| fld == _LOC = if nm `Set.member` @rules.locals
then []
else [UndefAttr @lhs.nt @con fld nm True]
| fld == _LHS = if nm `Map.member` @lhs.syn
then []
else [UndefAttr @lhs.nt @con fld nm True]
| otherwise = if nm `Set.member` (Map.findWithDefault Set.empty fld chldInMap)
then []
else [UndefAttr @lhs.nt @con fld nm True]
existsRule nm = if nm `Set.member` @rules.ruleNames
then []
else [MissingNamedRule @lhs.nt @con nm]
checkIn (OccAttr fld nm) = isInAttribute fld nm
checkIn (OccRule nm) = existsRule nm
checkOut (OccAttr fld nm) = isOutAttribute fld nm
checkOut (OccRule nm) = existsRule nm
in Seq.fromList . concat $
[ checkIn occA ++ checkOut occB
| (Dependency occA occB) <- @loc.orderDeps
]
-------------------------------------------------------------------------------
-- Decompose augment
-------------------------------------------------------------------------------
ATTR Nonterminals Nonterminal [ augmentsIn : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} | | ]
ATTR Productions Production [ augmentsIn : {Map ConstructorIdent (Map Identifier [Expression])} | | ]
SEM Grammar | Grammar nonts.augmentsIn = @augmentsMap
SEM Nonterminal | Nonterminal loc.augmentsIn = Map.findWithDefault Map.empty @nt @lhs.augmentsIn
SEM Production | Production loc.augmentsIn = Map.findWithDefault Map.empty @con @lhs.augmentsIn
ATTR Nonterminals Nonterminal [ aroundsIn : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} | | ]
ATTR Productions Production [ aroundsIn : {Map ConstructorIdent (Map Identifier [Expression])} | | ]
SEM Grammar | Grammar nonts.aroundsIn = @aroundsMap
SEM Nonterminal | Nonterminal loc.aroundsIn = Map.findWithDefault Map.empty @nt @lhs.aroundsIn
SEM Production | Production loc.aroundsIn = Map.findWithDefault Map.empty @con @lhs.aroundsIn
ATTR Nonterminals Nonterminal [ mergesIn : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression)))} | | ]
ATTR Productions Production [ mergesIn : {Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression))} | | ]
ATTR Children Child [ merged : {Set Identifier} | | ]
SEM Grammar | Grammar nonts.mergesIn = @mergeMap
SEM Nonterminal | Nonterminal loc.mergesIn = Map.findWithDefault Map.empty @nt @lhs.mergesIn
SEM Production | Production loc.mergesIn = Map.findWithDefault Map.empty @con @lhs.mergesIn
loc.merged = Set.fromList [ c | (_,cs,_) <- Map.elems @loc.mergesIn, c <- cs ]