INCLUDE "AbstractSyntax.ag" INCLUDE "Patterns.ag" INCLUDE "Expression.ag" INCLUDE "HsToken.ag" INCLUDE "DistChildAttr.ag" imports { import Options import Data.Char import Data.List import qualified Data.Map as Map import qualified Data.Set as Set import Data.Maybe import Pretty import PPUtil import UU.Scanner.Position import AbstractSyntax import TokenDef import CommonTypes -- import Debug.Trace } { pragmaAspectAG = pp "{-# LANGUAGE EmptyDataDecls, NoMonomorphismRestriction , TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-}" } { ppName l = ppListSep "" "" "_" l } ATTR Grammar [ options : Options | | ] ATTR Nonterminals Nonterminal Productions Production Children Child [ o_rename : Bool | | ] SEM Grammar | Grammar nonts.o_rename = rename @lhs.options ATTR Nonterminals Nonterminal Productions Production Children Child Rules Rule [ o_noGroup : {[String]} | | ] SEM Grammar | Grammar loc.o_noGroup = sort $ noGroup @lhs.options nonts.o_noGroup = @loc.o_noGroup SEM Nonterminal | Nonterminal loc.inhNoGroup = Map.filterWithKey (\att _ -> elem (getName att) @lhs.o_noGroup) @prods.prdInh | Nonterminal loc.synNoGroup = Map.filterWithKey (\att _ -> elem (getName att) @lhs.o_noGroup) @syn ATTR Productions Production Children Child Rules Rule [ inhNoGroup, synNoGroup : {[String]} | | ] SEM Nonterminal | Nonterminal prods.inhNoGroup = map show $ Map.keys @loc.inhNoGroup | Nonterminal prods.synNoGroup = map show $ Map.keys @loc.synNoGroup SEM Productions | Cons hd.inhNoGroup = filter (flip Map.member @hd.prdInh . identifier) @lhs.inhNoGroup ATTR Productions Production Children Child [ | | prdInh USE {`Map.union`} {Map.empty} : {Attributes} ] SEM Child | Child lhs.prdInh = @loc.inh { type FieldMap = [(Identifier, Type)] type DataTypes = Map.Map NontermIdent (Map.Map ConstructorIdent FieldMap) } ATTR Grammar [ agi : {(Set NontermIdent, DataTypes, Map NontermIdent (Attributes, Attributes))} | | ] ATTR Nonterminals Nonterminal Productions Production Children Child Rules Rule [ newAtts : { Attributes } | | ] SEM Grammar | Grammar loc.newAtts = case @lhs.agi of (_,_,atts) -> ( Map.unions . (\(a,b) -> a++b) . unzip . Map.elems) atts nonts.newAtts = @loc.newAtts ATTR Nonterminals Nonterminal [ newProds : { DataTypes } | | ] ATTR Productions Production [ newProds : { Map.Map ConstructorIdent FieldMap } | | ] SEM Grammar | Grammar loc.newProds = case @lhs.agi of (_,prods,_) -> prods nonts.newProds = @loc.newProds SEM Nonterminal | Nonterminal prods.newProds = case Map.lookup @nt @lhs.newProds of Just prds -> prds Nothing -> Map.empty ATTR Nonterminals Nonterminal [ newNTs : {Set NontermIdent} | | ] ATTR Productions Production [ | | hasMoreProds USE { || } {False} : { Bool } ] SEM Production | Production lhs.hasMoreProds = not $ Map.member @con @lhs.newProds ATTR Nonterminals Nonterminal [ | | extendedNTs USE {`Set.union`} {Set.empty} : {Set NontermIdent} ] SEM Nonterminal | Nonterminal lhs.extendedNTs = if @prods.hasMoreProds then Set.singleton @nt else Set.empty SEM Grammar | Grammar nonts.newNTs = case @lhs.agi of (newNTs,_,_) -> Set.difference newNTs @nonts.extendedNTs ATTR Grammar Nonterminals Nonterminal Productions Production Children Child Rules Rule [ ext : {Maybe String} | | ] -- IMPORT ATTR Grammar [ | | imp USE {>-<} {empty} : PP_Doc ] SEM Grammar | Grammar lhs . imp = "import Language.Grammars.AspectAG" >-< "import Language.Grammars.AspectAG.Derive" >-< "import Data.HList.Label4" >-< "import Data.HList.TypeEqGeneric1" >-< "import Data.HList.TypeCastGeneric1" >-< maybe empty ("import qualified" >#<) @lhs.ext >-< maybe empty (\ext -> "import" >#< ext >#< ppListSep "(" ")" "," (@nonts.ppDI ++ @nonts.ppLI ++ @loc.ppAI ++ @loc.ppANT)) @lhs.ext -- CODE ATTR Grammar [ | | pp USE {>-<} {empty} : PP_Doc ] SEM Grammar | Grammar lhs . pp = (if dataTypes @lhs.options then "-- datatypes" >-< @nonts.ppD >-< "-- labels" >-< @nonts.ppL else empty) >-< (if folds @lhs.options then "-- attributes" >-< @loc.ppA >-< "-- rules" >-< @loc.ppR >-< "-- catas" >-< @nonts.ppCata else empty) >-< (if semfuns @lhs.options then "-- semantic functions" >-< @nonts.ppSF else empty) >-< (if wrappers @lhs.options then "-- wrappers" >-< @nonts.ppW else empty) -- data definitions SEM Nonterminal | Nonterminal loc . ppNt = pp @nt SEM Production | Production loc . ppProd = pp @con loc . prodName = ppName [@lhs.ppNt, @loc.ppProd] loc . conName = if @lhs.o_rename then @loc.prodName else @loc.ppProd SEM Child | Child loc . ppCh = pp @name loc . ppTCh = ppShow @tp loc . chName = ppName [@loc.ppCh, @lhs.ppNt, @lhs.ppProd] ATTR Productions Production Rules Rule Children Child Expression [ ppNt : PP_Doc | | ] SEM Nonterminal | Nonterminal prods . ppNt = @loc.ppNt ATTR Rules Rule Children Child Expression [ ppProd : PP_Doc | | ] SEM Production | Production children . ppProd = @loc.ppProd rules . ppProd = @loc.ppProd ATTR Nonterminals Nonterminal [ derivs : {Derivings} | | ] SEM Grammar | Grammar nonts . derivs = @derivings ATTR Nonterminals Nonterminal Production [ | | ppD USE {>-<} {empty} : {PP_Doc} ppDI USE {++} {[]} : {[PP_Doc]} ] SEM Nonterminal | Nonterminal lhs . ppD = if (Set.member @nt @lhs.newNTs) then case (lookup @nt @lhs.tSyns) of -- if it's a data type Nothing -> "data " >|< @loc.ppNt >|< " = " >|< vlist_sep " | " @prods.ppDL >-< case (Map.lookup @nt @lhs.derivs) of Just ntds -> pp " deriving " >|< (ppListSep "(" ")" ", " $ Set.elems ntds) Nothing -> empty -- uncommented for testing purposes -- if it's a type synonym Just tp -> "type " >|< @loc.ppNt >|< " = " >|< ppShow tp else empty lhs . ppDI = if (not $ Set.member @nt @lhs.newNTs) then [ @loc.ppNt ] else [ ] -- uncommented for testing purposes SEM Production | Production lhs . ppD = @loc.conName >|< ppListSep " {" "}" ", " @children.ppDL ATTR Productions Children Child [ | | ppDL : {[PP_Doc]} ] SEM Productions | Cons lhs . ppDL = @hd.ppD : @tl.ppDL | Nil lhs . ppDL = [] SEM Children | Cons lhs . ppDL = @hd.ppDL ++ @tl.ppDL | Nil lhs . ppDL = [] SEM Child | Child lhs . ppDL = case @kind of ChildSyntax -> [ @loc.chName >|< pp " :: " >|< @loc.ppTCh ] _ -> [] ATTR Nonterminals Nonterminal [ tSyns : {TypeSyns} | | ] SEM Grammar | Grammar nonts . tSyns = @typeSyns -- grammar labels ATTR Nonterminals Nonterminal Productions Production Children Child [ | | ppL USE {>-<} {empty} : PP_Doc ppLI USE {++} {[]} : {[PP_Doc]} ] SEM Nonterminal | Nonterminal loc . ntLabel = "nt_" >|< @loc.ppNt lhs . ppL = ( if (Set.member @nt @lhs.newNTs) then @loc.ntLabel >|< " = proxy :: Proxy " >|< @loc.ppNt else empty) >-< @prods.ppL lhs . ppLI = ( if (not $ Set.member @nt @lhs.newNTs) then [ @loc.ntLabel ] else [ ]) ++ @prods.ppLI SEM Production | Production lhs . ppL = if (Map.member @con @lhs.newProds) then @children.ppL else empty lhs . ppLI = if (not $ Map.member @con @lhs.newProds) then @children.ppLI else [] SEM Child | Child loc . chLabel = "ch_" >|< @loc.chName loc . chTLabel = "Ch_" >|< @loc.chName lhs . ppL = "data " >|< @loc.chTLabel >|< "; " >|< @loc.chLabel >|< pp " = proxy :: " >|< case @kind of ChildSyntax -> "Proxy " >|< "(" >|< @loc.chTLabel >|< ", " >|< @loc.ppTCh >|< ")" _ -> "SemType " >|< @loc.ppTCh >|< pp " nt => Proxy " >|< "(" >|< @loc.chTLabel >|< ", nt)" lhs . ppLI = [ @loc.chLabel, @loc.chTLabel ] -- attributes SEM Grammar | Grammar loc . ppA = vlist (map defAtt (filterAtts @loc.newAtts @loc.o_noGroup)) >-< -- not grouped defAtt "loc" >-< -- local (case @lhs.ext of Nothing -> defAtt "inh" >-< defAtt "syn" -- grouped otherwise -> empty) >-< @nonts.ppA -- record definitions loc . ppAI = let atts = filterNotAtts @loc.newAtts @loc.o_noGroup in (foldr (\a as -> attName a : as) [] atts) ++ (foldr (\a as -> attTName a : as) [] atts) ++ (case @lhs.ext of Nothing -> [] otherwise -> [ attName "inh", attName "syn", attTName "inh", attTName "syn" ]) ++ @nonts.ppAI loc . ppANT = let atts = filterNotAtts @loc.newAtts @loc.o_noGroup in (foldr (\a as -> ("nts_" >|< a) : as) [] atts) ATTR Nonterminals Nonterminal Productions Production [ | | ppA USE {>-<} {empty} : PP_Doc ] SEM Nonterminal | Nonterminal lhs . ppA = ( if (Set.member @nt @lhs.newNTs) then defAttRec (pp "InhG") @loc.ppNt @inh @loc.inhNoGroup >-< defAttRec (pp "SynG") @loc.ppNt @syn @loc.synNoGroup else empty) >-< @prods.ppA SEM Production | Production lhs . ppA = defLocalAtts @loc.prodName (length @rules.locals) 1 $ sort @rules.locals ATTR Nonterminals Nonterminal [ | | ppAI USE {++} {[]} : {[PP_Doc]} ] SEM Nonterminal | Nonterminal lhs . ppAI = if (not $ Set.member @nt @lhs.newNTs) then [ ppName [(pp "InhG"), @loc.ppNt ] >#< pp "(..)", ppName [(pp "SynG"), @loc.ppNt ] >#< pp "(..)" ] else [ ] { filterAtts newAtts = filter (\att -> Map.member (identifier att) newAtts) filterNotAtts newAtts = filter (\att -> not (Map.member (identifier att) newAtts)) defAtt att = "data " >|< attTName att >|< "; " >|< attName att >|< " = proxy :: Proxy " >|< attTName att attName att = pp $ "att_" ++ att attTName att = pp $ "Att_" ++ att defAttRec recPref ppNt atts noGroup = let recName = ppName [recPref, ppNt] fields = ppCommas (map (\(a,t) -> ppName [pp a, recName ] >|< " ::" >|< ppShow t) (groupAtts atts noGroup)) in "data " >|< recName >|< " = " >|< recName >|< " { " >|< fields >|< " }" groupAtts atts noGroup = (Map.toAscList . Map.difference atts) noGroup -- it defines selectors with the form: -- l1_nt_prod(x, _, .., _) = x -- ln_nt_prod(_, .., _, x) = x defLocalAtts prodName total actual (l:ls) = ppName [pp l, prodName] >|< ppListSep "(" ")" "," (replicate (actual-1) "_" ++ "x" : replicate (total-actual) "_") >|< pp " = x" >-< defLocalAtts prodName total (actual+1) ls defLocalAtts _ _ _ [] = empty } ATTR Rules Rule [ | | locals USE {++} {[]} : {[Identifier]} ] SEM Rule | Rule lhs . locals = if (show (fst @pattern.info) == "loc") then [ snd @pattern.info ] else [ ] ATTR Pattern [ || info : {(Identifier, Identifier)} ] SEM Pattern | Alias lhs . info = (@field, @attr) | Constr lhs . info = error "Pattern Constr undefined!!" | Product lhs . info = error "Pattern Product undefined!!" | Underscore lhs . info = error "Pattern Underscore undefined!!" -- rules SEM Grammar | Grammar loc . ppNtL = @nonts.ppNtL loc . ppR = ntsList "group" @loc.ppNtL >-< vlist (map (\att -> ntsList att (filterNts att @loc.ppNtL)) (filterAtts @newAtts @loc.o_noGroup)) >-< @nonts.ppR { ntsList att ppNtL = "nts_" ++ att ++ " = " >|< ppListSep "" "" " .*. " ((map fst ppNtL) ++ [pp "hNil"]) filterNts att = filter ( Map.member (identifier att) . snd ) } ATTR Nonterminals Nonterminal [ | | ppNtL USE {++} {[]} : {[(PP_Doc, Attributes)]} ] -- list of nonterminals and its attributes SEM Nonterminal | Nonterminal lhs . ppNtL = [ ("nt_" >|< @nt, Map.union @inh @syn) ] ATTR Productions Production [ newNT : {Bool} | | ] ATTR Rules Rule [ newProd : {Bool} | | ] SEM Nonterminal | Nonterminal prods . newNT = Set.member @nt @lhs.newNTs ATTR Nonterminals Nonterminal Productions Production Children Child [ | | ppR USE {>-<} {empty} : PP_Doc ] ATTR Productions Production [ | | ppRA USE {++} {[]} : {[PP_Doc]} ] SEM Nonterminal | Nonterminal lhs . ppR = pp "----" >|< pp @nt >-< @prods.ppR SEM Production | Production loc . newProd = Map.member @con @lhs.newProds loc . (ppR,ppRA) = let (instR, instRA) = defInstRules @lhs.ppNt @con @lhs.newNT @loc.newProd @children.ppR @rules.ppRL @children.idCL @rules.locals (locR, locRA) = defLocRule @lhs.ppNt @con @lhs.newNT @loc.newProd @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals (inhGR, inhGRA) = defInhGRule @lhs.ppNt @loc.prodName @lhs.newNT @loc.newProd @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals (synGR, synGRA) = defSynGRule @lhs.ppNt @con @lhs.newNT @loc.newProd @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals (inhR, inhRA) = defInhRules @lhs.ppNt @loc.prodName @lhs.newNT @loc.newProd @lhs.newAtts @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals (synR, synRA) = defSynRules @lhs.ppNt @con @lhs.newNT @loc.newProd @lhs.newAtts @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals (inhMR, inhMRA) = modInhRules @lhs.ppNt @loc.prodName @lhs.newNT @loc.newProd @lhs.newAtts @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals (synMR, synMRA) = modSynRules @lhs.ppNt @con @lhs.newNT @loc.newProd @lhs.newAtts @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals in ( vlist [instR,locR,inhGR,synGR,inhR,synR,inhMR,synMR] , instRA ++ locRA ++ inhGRA ++ synGRA ++ inhMRA ++ synMRA ++ inhRA ++ synRA) SEM Child | Child lhs . ppR = let chName = ppListSep "" "" "_" [pp @name, @lhs.ppNt, @lhs.ppProd] in pp @name >|< " <- at ch_" >|< chName { data PPRule = PPRule Identifier Identifier Bool ([(Identifier,Type)] -> [Identifier] -> PP_Doc) ppRule (field,attr) owrt def = PPRule field attr owrt def ruleField (PPRule field _ _ _ ) = field ruleAttr (PPRule _ attr _ _ ) = attr ruleOwrt (PPRule _ _ owrt _ ) = owrt ruleDef (PPRule _ _ _ def) = def } ATTR Rules Rule [ | | ppRL : {[ PPRule ]} ] SEM Rules | Cons lhs . ppRL = @hd.ppRL ++ @tl.ppRL | Nil lhs . ppRL = [] SEM Rule | Rule lhs . ppRL = if (not @explicit && not @lhs.newProd && not (Map.member (snd @pattern.info) @lhs.newAtts) ) then [] else [ ppRule @pattern.info @owrt (defRule @lhs.ppNt @pattern.info @lhs.o_noGroup @rhs.ppRE) ] {- ATTR Expression [ | | ppRE : {Identifier -> [String] -> [String] -> [(Identifier,Type)] -> [Identifier] -> PP_Doc} ] SEM Expression | Expression lhs . ppRE = rhsRule @lhs.ppNt @lhs.ppProd @tks -} ATTR Expression [ | | ppRE : {[String] -> Identifier -> [(Identifier,Type)] -> [Identifier] -> PP_Doc} ] SEM Expression | Expression lhs . ppRE = rhsRule @lhs.ppNt @lhs.ppProd @tks ATTR Children Child [ || idCL USE {++} {[]} : {[(Identifier,Type)]} ] SEM Child | Child lhs . idCL = [ (@name, removeDeforested @tp ) ] { defInhGRule ppNt prodName newNT newProd ch rules inhNoGroup synNoGroup chids locals = let ppAtt = ppName [pp "inh", prodName] ppR = ppAtt >|< pp " = inhdefM att_inh nts_group $" >-< indent 4 "do " >-< indent 5 "loc <- at loc" >-< indent 5 "lhs <- at lhs" >-< indent 5 ch >-< indent 5 "return $" >-< indent 6 (foldr (>-<) (pp "emptyRecord") (map (chGRule ppNt prodName rules inhNoGroup synNoGroup chids locals) chids)) in if (newNT || (not newNT && newProd)) then (ppR, [ ppAtt ]) else (empty, []) chGRule ppNt prodName rules inhNoGroup synNoGroup chids locals (idCh,tp) = let chName = ppName [pp "ch", pp idCh, prodName] ppTp = ppShow tp chRules = ppCommas $ mapGRuleDefs (== idCh) rules inhNoGroup synNoGroup chids locals in if (isNonterminal tp) then chName >|< ".=." >-< indent 1 "InhG_" >|< ppShow tp >|< pp " {" >-< indent 2 chRules >-< indent 1 "} .*. " else empty defSynGRule ppNt prod newNT newProd ch rules inhNoGroup synNoGroup chids locals = let ppAtt = ppName [pp "syn", ppNt, pp prod] ppTAtt = "SynG_" >|< ppNt ppR = ppAtt >|< pp " = syndefM att_syn $" >-< indent 4 "do " >-< indent 5 "loc <- at loc" >-< indent 5 "lhs <- at lhs" >-< indent 5 ch >-< indent 5 "return $" >-< indent 6 ppTAtt >|< pp " {" >-< indent 7 (ppCommas $ mapGRuleDefs ((== "lhs") . show) rules inhNoGroup synNoGroup chids locals) >-< indent 6 "}" in if (newNT || (not newNT && newProd)) then (ppR, [ ppAtt ]) else (empty, []) defLocRule ppNt prod newNT newProd ch rules inhNoGroup synNoGroup chids locals = let ppAtt = ppName [pp "loc", ppNt, pp prod] ppTAtt = ppName [pp "Loc", ppNt, pp prod] ppR = ppAtt >|< pp " = locdefM att_loc $" >-< indent 4 "do " >-< indent 5 "loc <- at loc" >-< indent 5 "lhs <- at lhs" >-< indent 5 ch >-< indent 5 "return $" >-< indent 6 (ppListSep "(" ")" "," $ mapLRuleDefs rules inhNoGroup synNoGroup chids locals) in (ppR, [ ppAtt ]) defInstRules ppNt prod newNT newProd ch rules chids locals = let ppAsp = ppName [pp "inst", ppNt, pp prod] instRules = filter ((=="inst") . show . ruleField) rules ppAtt att = ppListSep "`ext` " "" "_" [pp "inst_ch", pp att, ppNt, pp prod] in ( ppAsp >|< pp " = emptyRule " >|< (map (ppAtt . ruleAttr) instRules) >-< (vlist $ map (defInstRule ppNt prod ch chids locals) instRules) , [ ppAsp ]) defInstRule ppNt prod ch chids locals rule = let ppAtt = ppName [pp "ch", pp (ruleAttr rule), ppNt, pp prod] in pp "inst_" >|< ppAtt >|< pp " = instdefM " >|< ppAtt >|< pp " $" >-< indent 4 "do " >-< indent 5 "loc <- at loc" >-< indent 5 "lhs <- at lhs" >-< indent 5 ch >-< indent 5 "return $" >-< indent 6 ((ruleDef rule) chids locals) defSynRules ppNt prod newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals = let synRules = filter ( (=="lhs") . show . ruleField) rules ngRules = filter ((flip elem synNoGroup) . getName . ruleAttr) synRules (ppR, ppRA) = unzip $ map (defSynRule True ppNt prod newNT newProd newAtts ch chids locals) ngRules in (vlist ppR, concat ppRA ) modSynRules ppNt prod newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals = let synRules = filter ( (=="lhs") . show . ruleField) rules ngRules = filter ((flip elem synNoGroup) . getName . ruleAttr) synRules (ppR, ppRA) = unzip $ map (defSynRule False ppNt prod newNT newProd newAtts ch chids locals) ngRules in (vlist ppR, concat ppRA ) defSynRule new ppNt prod newNT newProd newAtts ch chids locals rule = let att = ruleAttr rule newAtt = Map.member att newAtts owrt = ruleOwrt rule ppAtt = ppName [pp att, pp (if new then "syn" else "synM"), ppNt, pp prod] ppR def = ppAtt >|< pp (" = " ++ def ++ " ") >|< attName (show att) >|< pp " $" >-< indent 4 "do " >-< indent 5 "loc <- at loc" >-< indent 5 "lhs <- at lhs" >-< indent 5 ch >-< indent 5 "return $" >-< indent 6 ((ruleDef rule) chids locals) in if new then if (not owrt && (newNT || (not newNT && newProd) || newAtt)) then (ppR "syndefM", [ ppAtt ]) else (empty, []) else if owrt then (ppR "synmodM", [ ppAtt ]) else (empty, []) defInhRules ppNt prodName newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals = let ngRules = filter ((flip elem inhNoGroup) . getName . ruleAttr) rules (ppR, ppRA) = unzip $ map (defInhRule True ppNt prodName newNT newProd newAtts ch ngRules inhNoGroup synNoGroup chids locals) inhNoGroup in (vlist ppR, concat ppRA) modInhRules ppNt prodName newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals = let ngRules = filter ((flip elem inhNoGroup) . getName . ruleAttr) rules (ppR, ppRA) = unzip $ map (defInhRule False ppNt prodName newNT newProd newAtts ch ngRules inhNoGroup synNoGroup chids locals) inhNoGroup in (vlist ppR, concat ppRA) defInhRule new ppNt prodName newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals att = let ppAtt = ppName [pp att, pp (if new then "inh" else "inhM"),prodName] newAtt = Map.member (identifier att) newAtts chRMaybe = map (chRule new ppNt prodName att rules inhNoGroup synNoGroup chids locals) chids chR = [ x | (Just x) <- chRMaybe ] ppR def = ppAtt >|< pp (" = " ++ def ++ " ") >|< attName att >|< " nts_" >|< att >|< " $" >-< indent 4 "do " >-< indent 5 "loc <- at loc" >-< indent 5 "lhs <- at lhs" >-< indent 5 ch >-< indent 5 "return $" >-< indent 6 (foldr (>-<) (pp "emptyRecord") chR) in if new then if (newNT || (not newNT && newProd) || newAtt) then (ppR "inhdefM", [ ppAtt ]) else (empty, []) else if (not . null) chR then (ppR "inhmodM", [ ppAtt ]) else (empty, []) chRule new ppNt prodName att rules inhNoGroup synNoGroup chids locals (idCh,tp) = let chName = ppName [pp "ch", pp idCh, prodName] ppTp = ppShow tp chRule = inhRuleDef new (== idCh) (== att) rules inhNoGroup synNoGroup chids locals -- it's supposed to be only one in if (isNonterminal tp && (not . null) chRule) then Just $ chName >|< ".=. (" >|< chRule >|< ") .*. " else Nothing mapLRuleDefs rules inhNoGroup synNoGroup chids locals = map appSnd $ sortBy cmpField $ filter ((== "loc") . show . ruleField) rules where cmpField r1 r2 = compare (ruleField r1) (ruleField r2) appSnd rule = (ruleDef rule) chids locals mapGRuleDefs filt rules inhNoGroup synNoGroup chids locals = map appSnd $ sortBy cmpField $ filter (not . (flip elem inhNoGroup) . getName . ruleAttr) $ filter (not . (flip elem synNoGroup) . getName . ruleAttr) $ filter ( filt . ruleField) rules where cmpField r1 r2 = compare (ruleField r1) (ruleField r2) appSnd rule = (ruleDef rule) chids locals inhRuleDef new filt1 filt2 rules inhNoGroup synNoGroup chids locals = map appSnd $ sortBy cmpField $ filter ( (== not new) . ruleOwrt) $ filter ((flip elem inhNoGroup) . getName . ruleAttr) $ filter ( filt2 . getName . ruleAttr) $ filter ( filt1 . ruleField) rules where cmpField r1 r2 = compare (ruleField r1) (ruleField r2) appSnd rule = (ruleDef rule) chids locals defRule ppNt (field,att) noGroup rhs = \chids locals -> let ppAtt = if (elem (getName att) noGroup) then empty else case (show field) of "lhs" -> att >|< "_" >|< pp "SynG" >|< pp "_" >|< ppNt >|< " = " "loc" -> empty "inst" -> empty otherwise -> att >|< "_" >|< pp "InhG" >|< pp "_" >|< (maybe (error $ "lhs field " ++ show field ++" is not a child") ppShow (lookup field chids)) >|< " = " in ppAtt >|< (rhs noGroup field chids locals) rhsRule ppNt ppProd tks noGroup field chids locals = vlist . lines2PP . (map (token2PP ppNt ppProd field chids locals noGroup )) $ tks lines2PP [] = [] lines2PP xs = map line2PP . shiftLeft . getLines $ xs token2PP ppNt ppProd field chids locals noGroup tk = case tk of AGLocal var pos _ -> (pos, if (elem var locals) then (ppListSep "(" "" "_" [pp var, ppNt, ppProd]) >|< pp " (loc # att_loc)) " else pp var) AGField field attr pos _ -> let ppChT = maybe (error $ "rhs field " ++ show field ++ " is not a child") ppShow (lookup field chids) ppAtt = case (show field) of "lhs" -> attName "inh" "loc" -> attName "loc" otherwise -> attName "syn" ppSubAtt = case (show field) of "lhs" -> ppName [pp (getName attr), pp "InhG", ppNt] "loc" -> ppName [pp (getName attr), ppNt, ppProd] otherwise -> ppName [pp (getName attr), pp "SynG", ppChT] in (pos, if ((elem (getName attr) noGroup) && ((show field) /= "loc")) then pp "(" >|< pp (getName field) >|< " # " >|< attName (getName attr) >|< pp ")" else pp "(" >|< ppSubAtt >|< " (" >|< pp (getName field) >|< " # " >|< ppAtt >|< ")) ") HsToken value pos -> (pos, pp value) CharToken value pos -> (pos, pp (show value)) StrToken value pos -> (pos, pp (show value)) Err mesg pos -> (pos, pp $ " ***" ++ mesg ++ "*** ") line2PP ts = let f (p,t) r = let ct = column p in \c -> pp (spaces (ct-c)) >|< t >|< r (length (show t) +ct) spaces x | x < 0 = "" | otherwise = replicate x ' ' in foldr f (pp . const "") ts 1 } ---------------------------------------------------------------------------------------------------------------------------------------------- { ppMacro (Macro con children) = "( atts_" >|< show con >|< ", " >|< ppListSep "" "" " <.> " ppChildren >|<")" where ppChildren = map ppChild children ppChild (RuleChild ch n) = chName ch >|< " ==> " >|< ppMacro n ppChild (ChildChild ch n) = chName ch >|< " --> " >|< n ppChild (ValueChild ch n) = chName ch >|< " ~~> " >|< n chName ch = ppName [pp "ch", pp ch, pp con] } -- catamorphisms ATTR Nonterminals Nonterminal Productions Production [ | | ppCata USE {>-<} {empty} : PP_Doc ] SEM Nonterminal | Nonterminal lhs . ppCata = "----" >|< @loc.ppNt >-< @prods.ppCata SEM Production | Production lhs . ppCata = let extend = maybe [] ( \ext -> if (@lhs.newNT || (not @lhs.newNT && @loc.newProd)) then [] else [ ext >|< ".atts_" >|< @loc.prodName ]) @lhs.ext macro = case @macro of Nothing -> [] Just macro -> [ "agMacro " >|< ppMacro macro ] atts = sortBy (\a b -> compare (show a) (show b)) @loc.ppRA in "atts_" >|< @loc.prodName >|< " = " >|< ppListSep "" "" " `ext` " (atts ++ macro ++ extend ) >-< "semP_" >|< @loc.prodName >|< pp " = knit atts_" >|< @loc.prodName { ppNoGroupAtts syn noGroup = let synatts = Map.keys $ Map.filterWithKey (\att _ -> elem (getName att) noGroup) syn in map (flip (>|<) "_inh") noGroup ++ map (flip (>|<) "_syn") synatts ruleName att prodName = ppName [att,prodName] elemNT a b = False } ATTR Productions Production [ syn, inh : { Attributes } | | ] SEM Nonterminal | Nonterminal prods . syn = @syn prods . inh = @inh -- semantic functions ATTR Nonterminals Nonterminal Productions Production [ | | ppSF USE {>-<} {empty} : PP_Doc ] ATTR Productions Production [ | | ppSPF USE {>-<} {empty} : PP_Doc ] SEM Nonterminal | Nonterminal lhs . ppSF = let inhAtts = attTypes @loc.inhNoGroup synAtts = attTypes @loc.synNoGroup in "----" >|< @loc.ppNt >-< "type T_" >|< @loc.ppNt >|< " = " >|< "(Record " >|< inhAtts >|< "(HCons (LVPair (Proxy Att_inh) InhG_" >|< @loc.ppNt >|< ") HNil))" >|< replicate (length inhAtts) ")" >|< " -> " >|< "(Record " >|< synAtts >|< "(HCons (LVPair (Proxy Att_syn) SynG_" >|< @loc.ppNt >|< ") HNil))" >|< replicate (length synAtts) ")" >-< "-- instance SemType T_" >|< @loc.ppNt >|< " " >|< @loc.ppNt >-< "-- sem_" >|< @loc.ppNt >|< " :: " >|< @loc.ppNt >|< " -> T_" >|< @loc.ppNt >-< @prods.ppSPF -- >-< -- @prods.ppSF { attTypes atts = map (\(a,t) -> "(HCons (LVPair (Proxy Att_" >|< a >|< ") " >|< ppShow t >|< ") ") $ Map.toAscList atts } SEM Production | Production lhs . ppSF = let chi = @children.ppCSF ppPattern = case (show @con) of -- hardcoded list support "Cons" -> ppParams (ppListSep "" "" " : ") "Nil" -> pp "[]" -- general case otherwise -> @loc.conName >|< " " >|< (ppParams ppSpaced) ppParams f = f $ map (((>|<) (pp "_")) . fst) chi in "sem_" >|< @lhs.ppNt >|< " (" >|< ppPattern >|< ") = sem_" >|< @loc.prodName >|< " (" >|< map (fst . snd) chi >|< "emptyRecord)" lhs . ppSPF = let chi = @children.ppCSF ppParams f = f $ map (((>|<) (pp "_")) . fst) chi in "sem_" >|< @lhs.ppNt >|< "_" >|< @con >#< ppParams ppSpaced >|< " = semP_" >|< @loc.prodName >|< " (" >|< map (snd . snd) chi >|< "emptyRecord)" ATTR Children Child [ | | ppCSF USE {++} {[]} : {[(Identifier,(PP_Doc,PP_Doc))]} ] SEM Child | Child lhs . ppCSF = let semC = if (isNonterminal @tp) then "sem_" >|< ppShow @tp >|< " _" >|< @name else "sem_Lit _" >|< @name in case @kind of ChildSyntax -> [(@name, ( @loc.chLabel >|< " .=. (" >|< semC >|< ") .*. " , @loc.chLabel >|< " .=. _" >|< @name >|< " .*. "))] _ -> [] -- wrappers --TODO: create the records Inh_nt and Syn_nt to wrap the attributes ATTR Nonterminals Nonterminal [ | | ppW USE {>-<} {empty} : PP_Doc ] SEM Nonterminal | Nonterminal lhs . ppW = ppName [pp "wrap", @loc.ppNt] >|< " sem " >|< attVars @inh >|< " = " >-< " sem " >|< attFields @inh @loc.inhNoGroup @loc.ppNt { attVars atts = map (\(a,_) -> "_" >|< a >|< " ") $ Map.toAscList atts attFields atts noGroup ppNt = let ng = map (\(a,_) -> attName (getName a) >|< " .=. _" >|< a >|< " .*. ") $ Map.toAscList noGroup g = ppCommas $ map (\(a,_) -> ppName [pp a, pp "InhG",ppNt] >|< "= _" >|< a) $ Map.toAscList $ Map.difference atts noGroup in "(" >|< ng >|< "att_inh .=. " >|< ppName [pp "InhG", ppNt] >|< " { " >|< g >|< " } .*. emptyRecord)" }