uuagc-0.9.39.0: src-ag/DefaultRules.ag
PRAGMA strictdata
PRAGMA optimize
PRAGMA bangpats
PRAGMA strictwrap
INCLUDE "AbstractSyntax.ag"
INCLUDE "Patterns.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 AbstractSyntax
import ErrorMessages
import Options(Options,modcopy,rename)
}
-------------------------------------------------------------------------------
-- Passing down corresponding nonterminal and constructor names
-------------------------------------------------------------------------------
ATTR Rule Rules Child Children Production Productions Pattern Patterns [ nt:NontermIdent | | ]
ATTR Rule Rules Child Children Pattern Patterns [ con:ConstructorIdent | | ]
-------------------------------------------------------------------------------
-- Distributing options
-------------------------------------------------------------------------------
ATTR Grammar [ options:{Options} | | ]
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
-------------------------------------------------------------------------------
-- Type synonyms environment
-------------------------------------------------------------------------------
ATTR Nonterminals Nonterminal Productions Production [ typeSyns : {TypeSyns} | | ]
-------------------------------------------------------------------------------
-- some auxiliary functions
-------------------------------------------------------------------------------
{
fieldName n = '@' : getName n
locName n = '@' : getName n
attrName fld attr
| fld == _LOC = '@' : getName attr
| otherwise = '@' : getName fld ++ "." ++ getName attr
_ACHILD = Ident "(" noPos -- hack
getConName typeSyns rename nt con1
| nt `elem` map fst typeSyns = synonym
| otherwise = normalName
where con = getName con1
normalName | rename = getName nt++"_"++ con
| otherwise = con
synonym | con == "Cons" = "(:)"
| con == "Nil" = case lookup nt typeSyns of
Just (Map _ _) -> "Data.Map.empty"
Just (IntMap _) -> "Data.IntMap.empty"
_ -> "[]"
| con == "Just" = "Just"
| con == "Nothing" = "Nothing"
| con == "Entry" = case lookup nt typeSyns of
Just (Map _ _) -> "Data.Map.insert"
Just (IntMap _) -> "Data.IntMap.insert"
| otherwise = normalName
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:{Attributes} useMap : {Map Identifier (String,String,String)}|| ]
SEM Nonterminal
| Nonterminal prods.inh = @inh
prods.syn = @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 = @inh
lhs.synthesized = if @name `Set.member` @lhs.merged
then Map.empty
else @syn
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 nt con fld a
= "error \"missing rule: "
++ show nt ++ "." ++ show con ++ "."
++ show fld ++ "." ++ show a ++ "\""
makeRule :: (Identifier,Identifier) -> Expression -> String -> Rule
makeRule (f1,a1) expr origin
= Rule Nothing
(Alias f1 a1 (Underscore noPos) [])
expr
False
origin
False
useRule :: Set Identifier -> [(Identifier,Attributes)] -> (Identifier,(String,String,String)) -> Rule
useRule locals ch_outs (n,(op,e,pos))
= let elems = [ fld
| (fld,as) <- ch_outs
, Map.member n as
]
expr | Set.member n locals = attrName _LOC n
| null elems = e
| otherwise = foldr1 (\x y -> x ++ " " ++ op ++ " " ++ y)
(map (flip attrName n) elems)
tks | Set.member n locals = [AGLocal n noPos Nothing]
| null elems = lexTokens noPos e
| otherwise = lexTokens noPos str
where
str = foldr1 (\x y -> x ++ " " ++ op ++ " " ++ y)
(map (flip attrName n) elems)
in makeRule (_LHS,n)
(Expression noPos tks)
("use rule " ++ pos)
selfRule lhsNecLoc attr x
= let expr | lhsNecLoc = locName attr
| otherwise = x
tks | lhsNecLoc = [AGLocal attr noPos Nothing]
| otherwise = lexTokens noPos x
in makeRule (if lhsNecLoc then _LHS else _LOC,attr)
(Expression noPos tks)
"self rule"
concatRE rsess = let (rss,ess) = unzip rsess
in (concat rss, concatSeq ess)
copyRule :: Identifier -> Identifier -> Bool -> Set Identifier -> (Map Identifier Identifier, (Identifier,[Identifier])) -> ([Rule], Seq Error)
copyRule nt con modcopy locals (env,(fld,as))
= concatRE (map copyRu as)
where
copyRu a
= ( [ makeRule (fld,a)
(Expression noPos tks)
(cruletxt sel)
]
, err
)
where
sel
| not modcopy
&& Set.member a locals = Just _LOC
| otherwise = Map.lookup a env
(expr,err)
= case sel of
Nothing -> ( missingRuleErrorExpr nt con fld a
, Seq.singleton (MissingRule nt con fld a)
)
Just f
| f == _ACHILD -> ( fieldName a
, Seq.singleton (deprecatedCopyRuleError nt con fld a)
)
| otherwise -> ( attrName f a
, Seq.empty
)
(tks,err')
= case sel of
Nothing -> ( [HsToken (missingRuleErrorExpr nt con fld a) noPos]
, Seq.singleton (MissingRule nt con fld a)
)
Just f
| f == _ACHILD -> ( [AGLocal a noPos Nothing]
, Seq.singleton (deprecatedCopyRuleError nt con fld a)
)
| otherwise -> ( [AGField f a noPos Nothing]
, Seq.empty
)
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)
| (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.partition isSELFNonterminal @lhs.syn
(_,undefAttrs)
= removeDefined @rules.definedAttrs (_LHS, normalAttrs)
(useAttrs,others)
= splitAttrs @lhs.useMap undefAttrs
(rules1, errors1)
= concatRE $ map (copyRule @lhs.nt @con @lhs.cr locals)
(zip envs (map (removeDefined @rules.definedAttrs) @children.inputs))
uRules
= map (useRule locals @children.outputs) useAttrs
selfLocRules
= [ selfRule False attr (constructor [childSelf attr nm tp | (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
| getName @con == "Tuple" && @lhs.nt `elem` map fst @lhs.typeSyns
= "(" ++ concat (intersperse "," fs) ++ ")"
| otherwise
= getConName @lhs.typeSyns @lhs.o_rename @lhs.nt @con ++ " " ++ unwords fs
childExists Nothing = True
childExists (Just (Just _)) = True
childExists (Just Nothing) = False
selfRules
= [ selfRule True attr undefined
| attr <- Map.keys selfAttrs
, not (Set.member (_LHS,attr) @rules.definedAttrs)
]
(rules5, errs5)
= copyRule @lhs.nt
@con
@lhs.cr
locals
(lhs_env, (_LHS, others))
in (uRules++selfLocRules++selfRules++rules5++rules1, errors1><errs5)
{
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
rhs = Expression noPos tks
tks = [ HsToken "foldr ($) " noPos, AGLocal substSyn noPos Nothing, HsToken " [" noPos] ++ funs ++ [HsToken "]" noPos]
funs = intersperse (HsToken ", " noPos) (map (\n -> AGLocal 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) funNames exprs
modify (Rule mbNm pat rhs owrt origin expl)
| containsSyn pat = Rule mbNm (modifyPat pat) rhs owrt origin expl
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 parts) = (field == _LHS && attr == syn) || containsSyn pat || any containsSyn parts
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 parts)
| field == _LHS && attr == syn = Alias _LOC substSyn (modifyPat pat) (map modifyPat parts)
| otherwise = Alias field attr (modifyPat pat) (map modifyPat parts)
modifyPat p = p
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
rhs = Expression noPos tks
tks = [ HsToken "\\s -> foldr ($) s " noPos, HsToken " [" noPos] ++ funs ++ [HsToken "]" noPos]
funs = intersperse (HsToken ", " noPos) (map (\n -> AGLocal 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) funNames exprs
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
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,Maybe (Maybe Type))]} ]
| Cons lhs.fields = @hd.field : @tl.fields
| Nil lhs.fields = []
SEM Child [ | | field : { (Identifier,Type,Maybe (Maybe Type)) } ]
| Child lhs.field = (@name,@tp,@virtual)
-------------------------------------------------------------------------------
--
-------------------------------------------------------------------------------
ATTR Rule Pattern Patterns [ || containsVars USE {||} {False} : Bool ]
SEM Pattern
| Alias lhs.containsVars = True
-------------------------------------------------------------------------------
-- 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 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 @children.output @loc.extra3 @typeSigs.output
SEM Rules
| Cons lhs.output = if @hd.containsVars then @hd.outputs ++ @tl.output else @tl.output
-- remove rules that define nothing
SEM Rule
| Rule (lhs.outputs, lhs.uniq) = multiRule @loc.output @lhs.uniq
{
{-
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 (Just nm) pat expr owrt origin expl) uniq
= let pos = getPos nm
r = Rule Nothing (Alias _LOC (Ident ("_rule_" ++ show nm) pos) (Underscore pos) []) expr owrt origin expl
expr' = Expression pos tks
tks = [AGLocal (Ident ("_rule_" ++ show nm) pos) pos (Just ("Indirection to rule " ++ show nm))]
(rs,uniq') = multiRule (Rule Nothing pat expr' owrt origin False) uniq
in (r:rs, uniq')
multiRule (Rule Nothing pat expr owrt origin expl) 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) pats
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' : rs9
, n9
)
)
f expl' w e p n
= ( p
, ( [Rule Nothing (w p) e owrt origin expl']
, 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 ]