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> [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 ]