uuagc 0.9.39.1 → 0.9.39.3
raw patch · 39 files changed
+3515/−1481 lines, 39 files
Files
- README +1/−0
- src-ag/AG2AspectAG.ag +214/−184
- src-ag/AbstractSyntax.ag +20/−13
- src-ag/AbstractSyntaxDump.ag +1/−1
- src-ag/Code.ag +1/−0
- src-ag/CodeSyntax.ag +1/−1
- src-ag/CodeSyntaxDump.ag +3/−3
- src-ag/ConcreteSyntax.ag +14/−2
- src-ag/DefaultRules.ag +163/−72
- src-ag/Desugar.ag +35/−6
- src-ag/DistChildAttr.ag +24/−0
- src-ag/ErrorMessages.ag +16/−0
- src-ag/ExecutionPlan.ag +52/−31
- src-ag/ExecutionPlan2Hs.ag +1645/−651
- src-ag/GenerateCode.ag +94/−79
- src-ag/InterfacesRules.lag +19/−19
- src-ag/KWOrder.ag +204/−20
- src-ag/Macro.ag +24/−0
- src-ag/Order.ag +27/−28
- src-ag/Patterns.ag +0/−1
- src-ag/PrintCode.ag +12/−7
- src-ag/PrintErrorMessages.ag +45/−0
- src-ag/ResolveLocals.ag +7/−6
- src-ag/SemHsTokens.ag +3/−3
- src-ag/TfmToVisage.ag +14/−11
- src-ag/Transform.ag +152/−55
- src/Ag.hs +56/−58
- src/CommonTypes.hs +120/−18
- src/GrammarInfo.hs +4/−4
- src/KennedyWarren.hs +278/−104
- src/Knuth1.hs +63/−50
- src/Options.hs +91/−13
- src/PPUtil.hs +2/−1
- src/Parser.hs +77/−30
- src/Pretty.hs +19/−4
- src/Scanner.hs +6/−3
- src/SequentialComputation.lhs +1/−1
- uuagc.cabal +4/−2
- uuagc_options +3/−0
README view
@@ -12,6 +12,7 @@ Note: to produce a source release, you'll need to use the Setup.hs because cabal-install at the time is not able to do this in combination with the cabal plugin:+ -- cabal clean # remove possible junk ghc --make Setup.hs -o setup
src-ag/AG2AspectAG.ag view
@@ -2,6 +2,7 @@ INCLUDE "Patterns.ag" INCLUDE "Expression.ag" INCLUDE "HsToken.ag"+INCLUDE "DistChildAttr.ag" imports {@@ -20,15 +21,16 @@ import AbstractSyntax import TokenDef import CommonTypes+ } {-pragmaAspectAG = pp "{-# LANGUAGE EmptyDataDecls, NoMonomorphismRestriction , TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts #-}"+pragmaAspectAG = pp "{-# LANGUAGE EmptyDataDecls, NoMonomorphismRestriction , TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-}" } {-ppName l = ppListSep "" "" "_" l +ppName l = ppListSep "" "" "_" l } @@ -39,25 +41,34 @@ SEM Grammar | Grammar nonts.o_rename = rename @lhs.options -ATTR Nonterminals Nonterminal {- Productions Production Children Child Rules Rule -} [ o_noGroup : {[String]} | | ]+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) @inh+ | 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]} | | ]+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) +type FieldMap = [(Identifier, Type)]+type DataTypes = Map.Map NontermIdent (Map.Map ConstructorIdent FieldMap) } ATTR Grammar [ agi : {(Set NontermIdent, DataTypes, Map NontermIdent (Attributes, Attributes))} | | ]@@ -78,7 +89,7 @@ nonts.newProds = @loc.newProds -SEM Nonterminal +SEM Nonterminal | Nonterminal prods.newProds = case Map.lookup @nt @lhs.newProds of Just prds -> prds Nothing -> Map.empty@@ -92,7 +103,7 @@ ATTR Nonterminals Nonterminal [ | | extendedNTs USE {`Set.union`} {Set.empty} : {Set NontermIdent} ] -SEM Nonterminal | Nonterminal lhs.extendedNTs = if @prods.hasMoreProds +SEM Nonterminal | Nonterminal lhs.extendedNTs = if @prods.hasMoreProds then Set.singleton @nt else Set.empty @@ -116,7 +127,7 @@ "import Language.Grammars.AspectAG.Derive" >-< "import Data.HList.Label4" >-< "import Data.HList.TypeEqGeneric1" >-<- "import Data.HList.TypeCastGeneric1" >-< + "import Data.HList.TypeCastGeneric1" >-< maybe empty ("import qualified" >#<) @lhs.ext >-< maybe empty (\ext -> "import" >#< ext >#< ppListSep "(" ")" "," (@nonts.ppDI ++ @nonts.ppLI ++ @loc.ppAI)) @lhs.ext @@ -126,16 +137,16 @@ SEM Grammar | Grammar lhs . pp = (if dataTypes @lhs.options- then "-- datatypes" >-< @nonts.ppD >-< - "-- labels" >-< @nonts.ppL + then "-- datatypes" >-< @nonts.ppD >-<+ "-- labels" >-< @nonts.ppL else empty) >-< (if folds @lhs.options- then "-- attributes" >-< @loc.ppA >-< - "-- rules" >-< @loc.ppR >-< - "-- catas" >-< @nonts.ppCata + then "-- attributes" >-< @loc.ppA >-<+ "-- rules" >-< @loc.ppR >-<+ "-- catas" >-< @nonts.ppCata else empty) @@ -143,7 +154,7 @@ (if semfuns @lhs.options- then "-- semantic functions" >-< @nonts.ppSF + then "-- semantic functions" >-< @nonts.ppSF else empty) @@ -152,9 +163,9 @@ (if wrappers @lhs.options then "-- wrappers" >-< @nonts.ppW else empty)- + -- data definitions SEM Nonterminal@@ -163,13 +174,13 @@ SEM Production | Production loc . ppProd = pp @con loc . prodName = ppName [@lhs.ppNt, @loc.ppProd]- loc . conName = if @lhs.o_rename + 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] + loc . chName = ppName [@loc.ppCh, @lhs.ppNt, @lhs.ppProd] ATTR Productions Production Rules Rule Children Child Expression [ ppNt : PP_Doc | | ]@@ -187,18 +198,18 @@ ATTR Nonterminals Nonterminal [ derivs : {Derivings} | | ] SEM Grammar- | Grammar nonts . derivs = @derivings + | Grammar nonts . derivs = @derivings ATTR Nonterminals Nonterminal [ | | ppD USE {>-<} {empty} : {PP_Doc} ppDI USE {++} {[]} : {[PP_Doc]} ] SEM Nonterminal- | Nonterminal lhs . ppD = - if (Set.member @nt @lhs.newNTs) + | 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 >-< + 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 -}@@ -206,13 +217,13 @@ Just tp -> "type " >|< @loc.ppNt >|< " = " >|< ppShow tp else empty - lhs . ppDI = - if (not $ Set.member @nt @lhs.newNTs) + lhs . ppDI =+ if (not $ Set.member @nt @lhs.newNTs) then [ @loc.ppNt ] else [ ] {- SEM Production- | Production lhs . ppD = @loc.conName >|< ppListSep " {" "}" ", " @children.ppDL + | Production lhs . ppD = @loc.conName >|< ppListSep " {" "}" ", " @children.ppDL ATTR Productions Children Child [ | | ppDL : {[PP_Doc]} ]@@ -226,9 +237,9 @@ | Nil lhs . ppDL = [] SEM Child- | Child lhs . ppDL = case @virtual of - Nothing -> [ @loc.chName >|< pp " :: " >|< @loc.ppTCh ]- otherwise -> []+ | Child lhs . ppDL = case @kind of+ ChildSyntax -> [ @loc.chName >|< pp " :: " >|< @loc.ppTCh ]+ _ -> [] -} @@ -248,22 +259,22 @@ SEM Nonterminal | Nonterminal loc . ntLabel = "nt_" >|< @loc.ppNt - lhs . ppL = ( if (Set.member @nt @lhs.newNTs) - then @loc.ntLabel >|< " = proxy :: Proxy " >|< @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) + 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 + | Production lhs . ppL = if (Map.member @con @lhs.newProds)+ then @children.ppL else empty - lhs . ppLI = if (not $ Map.member @con @lhs.newProds) + lhs . ppLI = if (not $ Map.member @con @lhs.newProds) then @children.ppLI else [] @@ -272,11 +283,11 @@ | Child loc . chLabel = "ch_" >|< @loc.chName loc . chTLabel = "Ch_" >|< @loc.chName lhs . ppL = "data " >|< @loc.chTLabel >|< "; " >|< @loc.chLabel >|< pp " = proxy :: " >|<- case @virtual of - Nothing -> "Proxy " >|< "(" >|< @loc.chTLabel >|< ", " >|< @loc.ppTCh >|< ")"- otherwise -> "SemType " >|< @loc.ppTCh >|< pp " nt => Proxy " >|< - "(" >|< @loc.chTLabel >|< ", nt)"- + case @kind of+ ChildSyntax -> "Proxy " >|< "(" >|< @loc.chTLabel >|< ", " >|< @loc.ppTCh >|< ")"+ _ -> "SemType " >|< @loc.ppTCh >|< pp " nt => Proxy " >|<+ "(" >|< @loc.chTLabel >|< ", nt)"+ lhs . ppLI = [ @loc.chLabel, @loc.chTLabel ] @@ -284,32 +295,32 @@ SEM Grammar- | Grammar loc . ppA = vlist (map defAtt (filterAtts @loc.newAtts @loc.o_noGroup)) >-< -- not grouped + | 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 + 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" ]) ++ + otherwise -> [ attName "inh", attName "syn", attTName "inh", attTName "syn" ]) ++ @nonts.ppAI- + ATTR Nonterminals Nonterminal Productions Production [ | | ppA USE {>-<} {empty} : PP_Doc ] SEM Nonterminal- | Nonterminal lhs . ppA = ( if (Set.member @nt @lhs.newNTs) + | 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 + 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 @@ -317,20 +328,20 @@ ATTR Nonterminals Nonterminal [ | | ppAI USE {++} {[]} : {[PP_Doc]} ] SEM Nonterminal- | Nonterminal lhs . ppAI = if (not $ Set.member @nt @lhs.newNTs) + | 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)) +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 +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 = +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@@ -341,9 +352,9 @@ -- 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] >|< +defLocalAtts prodName total actual (l:ls) = ppName [pp l, prodName] >|< ppListSep "(" ")" "," (replicate (actual-1) "_" ++ "x" : replicate (total-actual) "_") >|<- pp " = x" >-< + pp " = x" >-< defLocalAtts prodName total (actual+1) ls defLocalAtts _ _ _ [] = empty @@ -357,9 +368,9 @@ | Rule lhs . locals = if (show (fst @pattern.info) == "loc") then [ snd @pattern.info ] else [ ]- -ATTR Pattern [ || info : {(Identifier, Identifier)} ] ++ATTR Pattern [ || info : {(Identifier, Identifier)} ] SEM Pattern | Alias lhs . info = (@field, @attr) | Constr lhs . info = error "Pattern Constr undefined!!"@@ -373,7 +384,7 @@ 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)) >-< + vlist (map (\att -> ntsList att (filterNts att @loc.ppNtL)) (filterAtts @newAtts @loc.o_noGroup)) >-< @nonts.ppR {@@ -385,15 +396,13 @@ 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) ] + | Nonterminal lhs . ppNtL = [ ("nt_" >|< @nt, Map.union @inh @syn) ] --------------------------------------------------------------------------------------------------------------------------------------------------TODO: use inhNoGroup and synNoGroup. rewrite this (horrible) code - ATTR Productions Production [ newNT : {Bool} | | ]+ATTR Rules Rule [ newProd : {Bool} | | ] SEM Nonterminal | Nonterminal prods . newNT = Set.member @nt @lhs.newNTs@@ -402,37 +411,37 @@ 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 + 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 + (locR, locRA) = defLocRule @lhs.ppNt @con @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 + (inhGR, inhGRA) = defInhGRule @lhs.ppNt @loc.prodName @lhs.newNT @loc.newProd @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals- (synR, synRA) = defSynRules @lhs.ppNt @con @lhs.newNT @loc.newProd @lhs.newAtts + (synGR, synGRA) = defSynGRule @lhs.ppNt @con @lhs.newNT @loc.newProd @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 + (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- (synMR, synMRA) = modSynRules @lhs.ppNt @con @lhs.newNT @loc.newProd @lhs.newAtts + (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] + | Child lhs . ppR = let chName = ppListSep "" "" "_" [pp @name, @lhs.ppNt, @lhs.ppProd] in pp @name >|< " <- at ch_" >|< chName @@ -453,106 +462,110 @@ | Nil lhs . ppRL = [] SEM Rule- | Rule lhs . ppRL = [ ppRule @pattern.info @owrt (defRule @lhs.ppNt @pattern.info @lhs.inhNoGroup @lhs.synNoGroup @rhs.ppRE) ]+ | Rule lhs . ppRL = if (not @explicit && not @lhs.newProd)+ 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 + | 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)]} ] +ATTR Children Child [ || idCL USE {++} {[]} : {[(Identifier,Type)]} ] SEM Child- | Child lhs . idCL = [ (@name, case (stripPrefix "T_" (show @tp)) of -- harcoded => higher order atts of type T_- Nothing -> @tp- Just t -> NT (Ident t undefined) []- ) ]+ | 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 " >-< +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)) + 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] +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 1 "InhG_" >|< ppShow tp >|< pp " {" >-< indent 2 chRules >-<- indent 1 "} .*. " + indent 1 "} .*. " else empty -defSynGRule ppNt prod newNT newProd ch rules inhNoGroup synNoGroup chids locals = - let ppAtt = ppName [pp "syn", ppNt, pp prod] +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 " >-< + 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 6 ppTAtt >|< pp " {" >-< indent 7 (ppCommas $ mapGRuleDefs ((== "lhs") . show) rules inhNoGroup synNoGroup chids locals) >-<- indent 6 "}" - in if (newNT || (not newNT && newProd)) + 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 " >-< +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 "(" ")" "," $ mapGRuleDefs ((== "loc") . show) rules inhNoGroup synNoGroup chids locals)- in (ppR, [ ppAtt ]) + 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] +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] + 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 " >-< + 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) + indent 6 ((ruleDef rule) chids locals) -defSynRules ppNt prod newNT newProd newAtts ch rules inhNoGroup synNoGroup 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 +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@@ -563,59 +576,59 @@ 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 " >-< + 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 + indent 6 ((ruleDef rule) chids locals)+ in if new- then if (not owrt && (newNT || (not newNT && newProd) || newAtt)) + then if (not owrt && (newNT || (not newNT && newProd) || newAtt)) then (ppR "syndefM", [ ppAtt ]) else (empty, [])- else if owrt + else if owrt then (ppR "synmodM", [ ppAtt ]) else (empty, [])- -defInhRules ppNt prodName newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals ++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 +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] +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 " >-< + 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 + in if new then if (newNT || (not newNT && newProd) || newAtt) then (ppR "inhdefM", [ ppAtt ]) else (empty, [])- else if (not . null) chR + 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] +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)@@ -623,47 +636,52 @@ 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) ++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 +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 ((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) inhNoGroup synNoGroup rhs = \chids locals -> - let ppAtt = if (elem (getName att) inhNoGroup || elem (getName att) synNoGroup) ++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)) + otherwise -> att >|< "_" >|< pp "InhG" >|< pp "_" >|<+ (maybe (error $ "lhs field " ++ show field ++" is not a child")+ ppShow (lookup field chids)) >|< " = "- in ppAtt >|< (rhs field inhNoGroup synNoGroup chids locals)+ in ppAtt >|< (rhs noGroup field chids locals) - -rhsRule ppNt ppProd tks field inhNoGroup synNoGroup chids locals = vlist . lines2PP . (map (token2PP ppNt ppProd field chids locals inhNoGroup synNoGroup )) $ tks +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 inhNoGroup synNoGroup tk+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)) " + 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@@ -674,8 +692,8 @@ "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) inhNoGroup || elem (getName attr) synNoGroup )- then pp "(" >|< pp (getName field) >|< " # " >|< attName (getName attr) >|< pp ")" + in (pos, if (elem (getName attr) noGroup )+ 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))@@ -693,34 +711,46 @@ ---------------------------------------------------------------------------------------------------------------------------------------------- -+{+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 + | 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 [] + | Production lhs . ppCata =+ let extend = maybe []+ ( \ext -> if (@lhs.newNT || (not @lhs.newNT && @loc.newProd))+ then [] else [ ext >|< ".atts_" >|< @loc.prodName ])- @lhs.ext - in "atts_" >|< @loc.prodName >|< " = " >|< - ppListSep "" "" " `ext` " - (@loc.ppRA ++ extend ) >-<- "sem_" >|< @loc.prodName >|< pp " = knit 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 +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] +ruleName att prodName = ppName [att,prodName] -elemNT a b = False +elemNT a b = False } ATTR Productions Production [ syn, inh : { Attributes } | | ]@@ -738,14 +768,14 @@ SEM Nonterminal- | Nonterminal lhs . ppSF = + | Nonterminal lhs . ppSF = let inhAtts = attTypes @loc.inhNoGroup synAtts = attTypes @loc.synNoGroup in- "----" >|< @loc.ppNt >-< + "----" >|< @loc.ppNt >-< "type T_" >|< @loc.ppNt >|< " = " >|< "(Record " >|<- inhAtts >|< + inhAtts >|< "(HCons (LVPair (Proxy Att_inh) InhG_" >|< @loc.ppNt >|< ") HNil))" >|< replicate (length inhAtts) ")" >|< " -> " >|< "(Record " >|<@@ -755,15 +785,15 @@ "instance SemType T_" >|< @loc.ppNt >|< " " >|< @loc.ppNt >-< "-- sem_" >|< @loc.ppNt >|< " :: " >|< @loc.ppNt >|< " -> T_" >|< @loc.ppNt >-< @prods.ppSPF -- >-<- -- @prods.ppSF - + -- @prods.ppSF+ { attTypes atts = map (\(a,t) -> "(HCons (LVPair (Proxy Att_" >|< a >|< ") " >|< ppShow t >|< ") ") $ Map.toAscList atts } SEM Production- | Production lhs . ppSF = + | Production lhs . ppSF = let chi = @children.ppCSF ppPattern = case (show @con) of -- hardcoded list support@@ -775,10 +805,10 @@ ppParams f = f $ map (((>|<) (pp "_")) . fst) chi in "sem_" >|< @lhs.ppNt >|< " (" >|< ppPattern >|< ") = sem_" >|< @loc.prodName >|< " (" >|< map (fst . snd) chi >|< "emptyRecord)"- lhs . ppSPF = + lhs . ppSPF = let chi = @children.ppCSF ppParams f = f $ map (((>|<) (pp "_")) . fst) chi- in "semP_" >|< @lhs.ppNt >|< "_" >|< @con >#< ppParams ppSpaced >|< " = sem_" >|< @loc.prodName >|<+ in "sem_" >|< @lhs.ppNt >|< "_" >|< @con >#< ppParams ppSpaced >|< " = semP_" >|< @loc.prodName >|< " (" >|< map (snd . snd) chi >|< "emptyRecord)" @@ -786,15 +816,15 @@ SEM Child- | Child lhs . ppCSF = - let + | Child lhs . ppCSF =+ let semC = if (isNonterminal @tp) then "sem_" >|< ppShow @tp >|< " _" >|< @name else "sem_Lit _" >|< @name- in case @virtual of - Nothing -> [(@name, ( @loc.chLabel >|< " .=. (" >|< semC >|< ") .*. "+ in case @kind of+ ChildSyntax -> [(@name, ( @loc.chLabel >|< " .=. (" >|< semC >|< ") .*. " , @loc.chLabel >|< " .=. _" >|< @name >|< " .*. "))]- otherwise -> []+ _ -> [] @@ -806,14 +836,14 @@ 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 - + | 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 = +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)"
src-ag/AbstractSyntax.ag view
@@ -5,7 +5,9 @@ import Data.Map(Map) import Patterns (Pattern(..),Patterns) import Expression (Expression(..))+import Macro --marcos import CommonTypes+import ErrorMessages } DATA Grammar | Grammar typeSyns : {TypeSyns}@@ -39,23 +41,28 @@ syn : {Attributes} prods : Productions -DATA Production | Production con : {ConstructorIdent}- children : Children- rules : Rules- typeSigs : TypeSigs+DATA Production | Production con : {ConstructorIdent}+ params : {[Identifier]}+ constraints : {[Type]}+ children : Children+ rules : Rules+ typeSigs : TypeSigs+ macro : MaybeMacro --marcos DATA Child | Child name : {Identifier} tp : {Type}- inh : {Attributes}- syn : {Attributes}- virtual : {Maybe (Maybe Type)} -- first maybe: is child virtual, second maybe: did child already exist+ kind : {ChildKind} -DATA Rule | Rule mbName : {Maybe Identifier}- pattern : Pattern- rhs : Expression- owrt : {Bool}- origin : String -- just for documentation (and maybe errors)- explicit : Bool -- True if this rule defined in the source code+DATA Rule | Rule mbName : {Maybe Identifier}+ pattern : Pattern+ rhs : Expression+ owrt : {Bool}+ origin : String -- just for documentation (and maybe errors)+ explicit : Bool -- True if this rule defined in the source code+ pure : Bool -- True if this rule is pure (does not have side effects)+ identity : Bool -- True if this rule is an identity rule+ mbError : {Maybe Error} -- scheduling this rule yields the given error, if present+ eager : Bool -- for ordered scheduling: use an eager semantics DATA TypeSig | TypeSig name : {Identifier} tp : {Type}
src-ag/AbstractSyntaxDump.ag view
@@ -32,7 +32,7 @@ | Production lhs . pp = ppNestInfo ["Production","Production"] [pp @con] [ppF "children" $ ppVList @children.ppL,ppF "rules" $ ppVList @rules.ppL,ppF "typeSigs" $ ppVList @typeSigs.ppL] [] SEM Child- | Child lhs . pp = ppNestInfo ["Child","Child"] [pp @name, ppShow @tp] [ppF "inh" $ ppMap @inh, ppF "syn" $ ppMap @syn] []+ | Child lhs . pp = ppNestInfo ["Child","Child"] [pp @name, ppShow @tp] [ppF "kind" $ ppShow @kind] [] SEM Rule | Rule lhs . pp = ppNestInfo ["Rule","Rule"] [ppShow @owrt, pp @origin] [ppF "pattern" $ @pattern.pp, ppF "rhs" $ @rhs.pp] []
src-ag/Code.ag view
@@ -125,6 +125,7 @@ | SimpleType txt : {String} | NontermType name : String params : {[String]}+ deforested : Bool | TMaybe tp : Type | TEither left : Type right : Type
src-ag/CodeSyntax.ag view
@@ -43,7 +43,7 @@ DATA CProduction | CProduction con : ConstructorIdent visits : CVisits- children : {[(Identifier,Type,Maybe (Maybe Type))]}+ children : {[(Identifier,Type,ChildKind)]} terminals : {[Identifier]} TYPE CVisits = [CVisit]
src-ag/CodeSyntaxDump.ag view
@@ -13,10 +13,10 @@ } {-ppChild :: (Identifier,Type,Maybe (Maybe Type)) -> PP_Doc+ppChild :: (Identifier,Type,ChildKind) -> PP_Doc ppChild (nm,tp,b) = pp nm >#< "::" >#< pp (show tp)- + ppVertexMap :: Map Int (Identifier,Identifier,Maybe Type) -> PP_Doc ppVertexMap m = ppVList [ ppF (show k) $ ppAttr v | (k,v) <- Map.toList m ]@@ -97,7 +97,7 @@ SEM CSegments | Cons lhs . ppL = @hd.pp : @tl.ppL | Nil lhs . ppL = []- + SEM CNonterminals | Cons lhs . ppL = @hd.pp : @tl.ppL | Nil lhs . ppL = []
src-ag/ConcreteSyntax.ag view
@@ -4,6 +4,7 @@ import Patterns (Pattern) import Expression (Expression) import CommonTypes+import Macro --marcos } @@ -11,6 +12,8 @@ TYPE Alts = [Alt] +TYPE Fields = [Field]+ TYPE SemAlts = [SemAlt] TYPE SemDefs = [SemDef]@@ -45,7 +48,7 @@ alts : SemAlts | Txt pos : {Pos}- name : {Identifier}+ kind : {BlockKind} mbNt : {Maybe NontermIdent} lines : {[String]} @@ -77,8 +80,14 @@ DATA Alt | Alt pos : {Pos} names : ConstructorSet- fields : {Fields}+ tyvars : {[Identifier]}+ fields : Fields+ macro : MaybeMacro --marcos: macro extension +DATA Field | FChild name : Identifier+ tp : Type+ | FCtx tps : {[Type]}+ DATA SemAlt | SemAlt pos : {Pos} constructorSet : ConstructorSet rules : SemDefs@@ -88,6 +97,8 @@ pattern: Pattern rhs : {Expression} owrt : {Bool}+ pure : Bool+ eager : Bool | TypeDef pos : {Pos} ident : {Identifier} tp : Type@@ -116,4 +127,5 @@ | Intersect set1,set2 : NontSet | Difference set1,set2 : NontSet | Path from,to : {NontermIdent}+
src-ag/DefaultRules.ag view
@@ -1,3 +1,7 @@+-- 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@@ -5,6 +9,7 @@ INCLUDE "AbstractSyntax.ag" INCLUDE "Patterns.ag"+INCLUDE "DistChildAttr.ag" imports {@@ -24,21 +29,25 @@ import AbstractSyntax import ErrorMessages -import Options(Options,modcopy,rename)+import Options } ------------------------------------------------------------------------------- -- Passing down corresponding nonterminal and constructor names --------------------------------------------------------------------------------ATTR Rule Rules Child Children Production Productions Pattern Patterns [ nt:NontermIdent | | ]+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 [ options:{Options} | | ]+ATTR Grammar Nonterminals Nonterminal Productions Production Rules Rule [ options:{Options} | | ] ATTR Nonterminals Nonterminal Productions Production [ o_rename:{Bool} cr:Bool {- copy rule -} | | ]@@ -49,6 +58,14 @@ 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} | | ]@@ -79,12 +96,16 @@ | 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" | 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" | otherwise = normalName concatSeq = foldr (Seq.><) Seq.empty@@ -128,22 +149,23 @@ 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 ------------------------------------------------------------------------------- --- 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)}|| ]+ATTR Productions Production [ inh, syn, inhOrig, synOrig : {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+ | 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+ | Production rules.con = @con children.con = @con SEM Child | Child lhs . name = @name@@ -155,10 +177,10 @@ | Nonterminal prods . nt = @nt SEM Child [ | | name:{Identifier} inherited,synthesized:{Attributes} ]- | Child lhs.inherited = @inh+ | Child lhs.inherited = @loc.inh1 lhs.synthesized = if @name `Set.member` @lhs.merged then Map.empty- else @syn+ else @loc.syn1 SEM Children [ | | inputs,outputs:{[(Identifier, Attributes)]} ] | Cons lhs.inputs = (@hd.name, @hd.inherited) : @tl.inputs@@ -210,14 +232,18 @@ -makeRule :: (Identifier,Identifier) -> Expression -> String -> Rule-makeRule (f1,a1) expr origin+makeRule :: (Identifier,Identifier) -> Expression -> String -> Bool -> Maybe Error -> Rule+makeRule (f1,a1) expr origin identity mbDelayedError = Rule Nothing- (Alias f1 a1 (Underscore noPos) [])+ (Alias f1 a1 (Underscore noPos)) expr False origin False+ True+ identity+ mbDelayedError+ False useRule :: Set Identifier -> [(Identifier,Attributes)] -> (Identifier,(String,String,String)) -> Rule@@ -242,6 +268,8 @@ in makeRule (_LHS,n) (Expression noPos tks) ("use rule " ++ pos)+ False+ Nothing @@ -256,6 +284,8 @@ in makeRule (if lhsNecLoc then _LHS else _LOC,attr) (Expression noPos tks) "self rule"+ False+ Nothing @@ -264,8 +294,8 @@ 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))+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@@ -273,6 +303,8 @@ = ( [ makeRule (fld,a) (Expression noPos tks) (cruletxt sel)+ True+ mbDelayedErr ] , err )@@ -283,30 +315,21 @@ && 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')+ (tks,err,mbDelayedErr) = case sel of- Nothing -> ( [HsToken (missingRuleErrorExpr nt con fld a) noPos]- , Seq.singleton (MissingRule nt con fld a)- )+ Nothing -> let tks = [HsToken (missingRuleErrorExpr 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@@ -354,7 +377,7 @@ lhs_env = last envs (selfAttrs, normalAttrs)- = Map.partition isSELFNonterminal @lhs.syn+ = Map.partitionWithKey (\k _ -> maybe False isSELFNonterminal $ Map.lookup k @lhs.synOrig) @lhs.syn (_,undefAttrs) = removeDefined @rules.definedAttrs (_LHS, normalAttrs)@@ -363,7 +386,7 @@ = splitAttrs @lhs.useMap undefAttrs (rules1, errors1)- = concatRE $ map (copyRule @lhs.nt @con @lhs.cr locals)+ = concatRE $ map (copyRule @lhs.options @lhs.wrappers @lhs.nt @con @lhs.cr locals) (zip envs (map (removeDefined @rules.definedAttrs) @children.inputs)) uRules@@ -376,7 +399,7 @@ ] where childSelf self nm tp- = case tp of NT nt _ -> attrName nm self+ = case tp of NT nt _ _ -> attrName nm self _ | nm `Set.member` locals -> locname nm | otherwise -> fieldName nm constructor fs@@ -385,9 +408,8 @@ | otherwise = getConName @lhs.typeSyns @lhs.o_rename @lhs.nt @con ++ " " ++ unwords fs - childExists Nothing = True- childExists (Just (Just _)) = True- childExists (Just Nothing) = False+ childExists ChildAttr = False+ childExists _ = True selfRules = [ selfRule True attr undefined@@ -396,7 +418,9 @@ ] (rules5, errs5)- = copyRule @lhs.nt+ = copyRule @lhs.options+ @lhs.wrappers+ @lhs.nt @con @lhs.cr locals@@ -410,52 +434,62 @@ addAugments (syn, exprs) rules = [rule] ++ funRules ++ map modify rules where- rule = Rule Nothing (Alias _LHS syn (Underscore noPos) []) rhs False "augmented rule" False+ 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, 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+ 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)- | containsSyn pat = Rule mbNm (modifyPat pat) rhs owrt origin expl+ 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 parts) = (field == _LHS && attr == syn) || containsSyn pat || any containsSyn parts+ 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 parts)- | field == _LHS && attr == syn = Alias _LOC substSyn (modifyPat pat) (map modifyPat parts)- | otherwise = Alias field attr (modifyPat pat) (map modifyPat parts)+ 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+ 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 -> 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+ 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+ rule = Rule Nothing (Alias _LOC childLoc (Underscore noPos)) expr False "merge rule" False True False Nothing False childLoc = Ident (show target ++ "_merge") (getPos target) } @@ -472,12 +506,12 @@ then Set.insert @attr @pat.locals else @pat.locals -SEM Children [ | | fields : {[(Identifier,Type,Maybe (Maybe Type))]} ]+SEM Children [ | | fields : {[(Identifier,Type,ChildKind)]} ] | Cons lhs.fields = @hd.field : @tl.fields | Nil lhs.fields = [] -SEM Child [ | | field : { (Identifier,Type,Maybe (Maybe Type)) } ]- | Child lhs.field = (@name,@tp,@virtual)+SEM Child [ | | field : { (Identifier,Type,ChildKind) } ]+ | Child lhs.field = (@name,@tp,@kind) ------------------------------------------------------------------------------- --@@ -487,7 +521,39 @@ 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 locname args) False+elimSelfId _ _ tp = tp++elimSelfStr :: NontermIdent -> [String] -> Type -> Type+elimSelfStr nt args Self = NT nt args False+elimSelfStr _ _ tp = tp+}++------------------------------------------------------------------------------- -- Reconstructing the tree ------------------------------------------------------------------------------- @@ -502,23 +568,56 @@ 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 @children.output @loc.extra3 @typeSigs.output+ 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 then @hd.outputs ++ @tl.output else @tl.output- -- remove rules that define nothing+ | 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 (lhs.outputs, lhs.uniq) = multiRule @loc.output @lhs.uniq+ | 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 = [AGLocal (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@@ -539,21 +638,13 @@ -} 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+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) pats+ 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)@@ -561,13 +652,13 @@ 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+ , ( 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']+ , ( [Rule Nothing (w p) e owrt origin expl' True False mbErr eager] , n ) )
src-ag/Desugar.ag view
@@ -7,6 +7,7 @@ INCLUDE "Patterns.ag" INCLUDE "Expression.ag" INCLUDE "HsToken.ag"+INCLUDE "DistChildAttr.ag" imports@@ -32,7 +33,7 @@ WRAPPER HsTokensRoot -ATTR Grammar Nonterminals Nonterminal Productions Production Rule Rules Expression [ options:{Options} | | ]+ATTR Grammar Nonterminals Nonterminal Productions Production Children Child Rule Rules Expression [ options:{Options} | | ] ATTR Grammar Nonterminals Nonterminal Productions Production Rule Rules Pattern Patterns Expression HsTokensRoot HsToken HsTokens [ | | errors USE {Seq.><} {Seq.empty} : {Seq Error} ] @@ -113,8 +114,8 @@ else if (@loc.field', @attr) `Set.member` @lhs.defs then Seq.singleton $ DupRule @lhs.nt @lhs.con @field @attr @loc.field' else Seq.empty- lhs.errors = @loc.err1 Seq.>< @loc.err2 Seq.>< @pat.errors Seq.>< @parts.errors- loc.output = Alias @loc.field' @attr @pat.output @parts.output+ lhs.errors = @loc.err1 Seq.>< @loc.err2 Seq.>< @pat.errors+ loc.output = Alias @loc.field' @attr @pat.output -------------------------------------------------------------------------------@@ -126,8 +127,8 @@ SEM Child | Child- lhs.childInhs = [(i, @name) | i <- Map.keys @inh ]- lhs.childSyns = [(s, @name) | s <- Map.keys @syn ]+ lhs.childInhs = [(i, @name) | i <- Map.keys @loc.inh ]+ lhs.childSyns = [(s, @name) | s <- Map.keys @loc.syn ] { maybeError :: a -> Error -> Maybe a -> (a, Seq Error)@@ -179,7 +180,7 @@ SEM Pattern | Alias loc.def = Set.singleton (@field, @attr)- lhs.defsCollect = @loc.def `Set.union` @pat.defsCollect `Set.union` @parts.defsCollect+ lhs.defsCollect = @loc.def `Set.union` @pat.defsCollect ATTR Rule Rules Pattern Patterns [ defs : {Set (Identifier, Identifier)} | | ] SEM Production@@ -282,8 +283,36 @@ lhs.errors = @rules.errors Seq.>< @loc.augmentErrs -------------------------------------------------------------------------------+-- Support for late binding of higher order children+-------------------------------------------------------------------------------++ATTR Grammar Nonterminals Nonterminal Productions Production Children Child [ mainName : {String} | | ]++SEM Nonterminal | Nonterminal+ loc.extraInh = addLateAttr @lhs.options @lhs.mainName++{+addLateAttr :: Options -> String -> Attributes+addLateAttr options mainName+ | kennedyWarren options && lateHigherOrderBinding options =+ let tp = lateBindingType mainName+ in Map.singleton idLateBindingAttr tp+ | otherwise = Map.empty+}++------------------------------------------------------------------------------- -- Reconstruct the grammar -------------------------------------------------------------------------------++SEM Nonterminal | Nonterminal+ lhs.output = Nonterminal+ @nt @params+ (@loc.extraInh `Map.union` @inh)+ @syn+ @prods.output++SEM Child | Child+ lhs.output = Child @name @tp @kind SEM Grammar | Grammar
+ src-ag/DistChildAttr.ag view
@@ -0,0 +1,24 @@+-------------------------------------------------------------------------------+-- Map of all inherited and synthesized attributes per nonterminal+-------------------------------------------------------------------------------+ATTR Nonterminals Nonterminal [ || inhMap', synMap' USE {`Map.union`} {Map.empty} : {Map Identifier Attributes} ]++SEM Nonterminal+ | Nonterminal lhs.inhMap' = Map.singleton @nt @inh+ lhs.synMap' = Map.singleton @nt @syn++ATTR Nonterminals Nonterminal+ Productions Production+ Children Child [ inhMap, synMap : {Map Identifier Attributes} | | ]++SEM Grammar+ | Grammar nonts.inhMap = @nonts.inhMap'+ nonts.synMap = @nonts.synMap'++SEM Child+ | Child loc.chnt = case @tp of+ NT nt _ _ -> nt+ 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.inh = Map.findWithDefault Map.empty @loc.chnt @lhs.inhMap+ loc.syn = Map.findWithDefault Map.empty @loc.chnt @lhs.synMap
src-ag/ErrorMessages.ag view
@@ -87,6 +87,10 @@ attr : {Identifier} isOut : {Bool} + | Cyclic nt : {NontermIdent}+ mbCon : {Maybe ConstructorIdent}+ verts : {[String]}+ | CyclicSet name:{Identifier} | CustomError isWarning : {Bool}@@ -130,3 +134,15 @@ | MissingSyn nt : {NontermIdent} attr : {Identifier}++ | IncompatibleVisitKind+ child : {Identifier}+ vis : {VisitIdentifier}+ from : {VisitKind}+ to : {VisitKind}+ | IncompatibleRuleKind+ rule : {Identifier}+ kind : {VisitKind}+ | IncompatibleAttachKind+ child : {Identifier}+ kind : {VisitKind}
src-ag/ExecutionPlan.ag view
@@ -4,13 +4,17 @@ import Patterns (Pattern(..),Patterns) import Expression (Expression(..)) import CommonTypes+import ErrorMessages import qualified Data.Set as Set+import Data.Set(Set)+import qualified Data.Map as Map+import Data.Map(Map) } DATA ExecutionPlan | ExecutionPlan nonts : ENonterminals typeSyns : {TypeSyns}- wrappers : {Set.Set NontermIdent}+ wrappers : {Set NontermIdent} derivings : {Derivings} TYPE ENonterminals = [ENonterminal]@@ -25,38 +29,55 @@ TYPE Visits = [Visit] -DATA ENonterminal | ENonterminal nt : {NontermIdent}- params : {[Identifier]}- initial : {StateIdentifier}- initialv : {Maybe VisitIdentifier}- prods : EProductions+DATA ENonterminal | ENonterminal nt : {NontermIdent}+ params : {[Identifier]}+ classCtxs : {ClassContext} -- class context at the datatype level+ initial : {StateIdentifier}+ initialv : {Maybe VisitIdentifier}+ nextVisits : {Map StateIdentifier StateCtx} -- info about the next visits from a given state+ prevVisits : {Map StateIdentifier StateCtx} -- info about the previous visits to a given state+ prods : EProductions+ recursive : {Bool}+ hoInfo : {HigherOrderInfo} -DATA EProduction | EProduction con : {ConstructorIdent}- rules : ERules- children : EChildren- visits : Visits+DATA EProduction | EProduction con : {ConstructorIdent}+ params : {[Identifier]}+ constraints : {[Type]} -- (class/equality) constraints on types (requires GADTs)+ rules : ERules+ children : EChildren+ visits : Visits -DATA EChild | EChild name : {Identifier}- tp : {Type}- virtual : {Maybe (Maybe Type)} -- first maybe: is child virtual, second maybe: did child already exist+DATA EChild | EChild name : {Identifier}+ tp : {Type}+ kind : {ChildKind}+ hasAround : {Bool} -- if there exists a rule <name>_around that transforms the child's sem+ merges : {Maybe [Identifier]} -- Nothing: not the result of a merge of other children (ignored for now)+ isMerged : {Bool} -- False: not being used to merge other children (ignored for now)+ | ETerm name : {Identifier}+ tp : {Type} -DATA ERule | ERule name : {Identifier}- pattern : Pattern - rhs : Expression- owrt : {Bool}- origin : String -- just for documentation (and maybe errors)- explicit : Bool -- True if this rule defined in the source code+DATA ERule | ERule name : {Identifier}+ pattern : Pattern+ rhs : Expression+ owrt : {Bool}+ origin : String -- just for documentation (and maybe errors)+ explicit : Bool -- True if this rule defined in the source code+ pure : Bool -- True if this rule is pure (not monadic/no side effect)+ mbError : {Maybe Error} -- the rule may contain an error that is yielded when the rule is scheduled -DATA Visit | Visit ident : {VisitIdentifier}- from : {StateIdentifier}- to : {StateIdentifier}- inh : {Set.Set Identifier}- syn : {Set.Set Identifier}- steps : VisitSteps+DATA Visit | Visit ident : {VisitIdentifier}+ from : {StateIdentifier}+ to : {StateIdentifier}+ inh : {Set Identifier}+ syn : {Set Identifier}+ steps : VisitSteps+ kind : {VisitKind} -DATA VisitStep | Sem name : {Identifier}- | ChildVisit child : {Identifier}- nonterm : {NontermIdent}- visit : {VisitIdentifier}- | Sim steps : VisitSteps- | ChildIntro child : {Identifier}+DATA VisitStep | Sem name : {Identifier}+ | ChildVisit child : {Identifier}+ nonterm : {NontermIdent}+ visit : {VisitIdentifier}+ | PureGroup steps : VisitSteps -- A group of steps that should be executed purely+ ordered : {Bool}+ | Sim steps : VisitSteps+ | ChildIntro child : {Identifier}
src-ag/ExecutionPlan2Hs.ag view
@@ -9,654 +9,1648 @@ import Pretty import PPUtil import Options-import Data.Maybe-import Debug.Trace-import System.IO-import System.Directory--import TokenDef-import HsToken--import qualified Data.Set as Set-import qualified Data.Map as Map-}--ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction- [ importBlocks : PP_Doc- pragmaBlocks : String- textBlocks : PP_Doc- moduleHeader : {String -> String -> String -> Bool -> String}- mainFile : String- optionsLine : String- mainName : String | | ]------------------------------------------------------------------------------------ Options---------------------------------------------------------------------------------ATTR ExecutionPlan - ENonterminals ENonterminal - EProductions EProduction - ERules ERule- EChildren EChild- Visits Visit [ options : {Options} | | ]-ATTR EProductions EProduction [ rename : {Bool} | | ]--SEM ENonterminal- | ENonterminal prods.rename = rename @lhs.options------------------------------------------------------------------------------------ Default output---------------------------------------------------------------------------------ATTR ExecutionPlan [ | | output : {PP_Doc} ]--SEM ExecutionPlan- | ExecutionPlan lhs.output = @nonts.output--ATTR ENonterminal ENonterminals [ wrappers : {Set.Set NontermIdent}- | | output USE {>-<} {empty} : {PP_Doc} ]--SEM ExecutionPlan- | ExecutionPlan nonts.wrappers = @wrappers--SEM ENonterminal- | ENonterminal lhs.output = ("-- " ++ getName @nt ++ " " ++ replicate (60 - length (getName @nt)) '-')- >-< (if dataTypes @lhs.options- then "-- data"- >-< @loc.datatype- >-< ""- else empty)- >-< (if @nt `Set.member` @lhs.wrappers- then "-- wrapper"- >-< @loc.wr_inh- >-< @loc.wr_syn- >-< @loc.wrapper- >-< ""- else empty)- >-< (if folds @lhs.options- then "-- cata"- >-< @loc.sem_nt- >-< ""- else empty)- >-< (if semfuns @lhs.options- then "-- semantic domain"- >-< @loc.t_init- >-< @loc.t_states- >-< @loc.k_states- >-< @prods.t_visits- >-< @prods.sem_prod- >-< ""- else empty)------------------------------------------------------------------------------------ Nonterminal datatype---------------------------------------------------------------------------------ATTR ENonterminal ENonterminals [ typeSyns : {TypeSyns}- derivings : {Derivings} | | ]--SEM ExecutionPlan- | ExecutionPlan nonts.typeSyns = @typeSyns- nonts.derivings = @derivings--SEM ENonterminal- | ENonterminal loc.datatype = case lookup @nt @lhs.typeSyns of- Nothing -> "data" >#< @nt >#< (vlist $ ("=" >#< head @prods.datatype)- : (map ("|" >#<) $ tail @prods.datatype)) >#< @loc.derivings- Just (List t) -> "type" >#< @nt >#< "=" >#< "[" >#< show t >#< "]"- Just (Maybe t) -> "type" >#< @nt >#< "=" >#< "Maybe" >#< show t- Just (Tuple ts) -> "type" >#< @nt >#< "=" >#< pp_parens (ppCommas $ map (show . snd) ts)- Just (Either l r) -> "type" >#< @nt >#< "=" >#< "Either" >#< show l >#< show r- Just (Map k v) -> "type" >#< @nt >#< "=" >#< "Data.Map.Map" >#< pp_parens (show k) >#< show v- Just (IntMap t) -> "type" >#< @nt >#< "=" >#< "Data.IntMap.IntMap" >#< show t--- Just x -> error $ "Type " ++ show x ++ " is not supported"- loc.derivings = case Map.lookup @nt @lhs.derivings of- Nothing -> empty- Just s -> if Set.null s- then empty- else "deriving" >#< (pp_parens $ ppCommas $ map pp $ Set.toList s)--ATTR EProduction [ | | datatype : {PP_Doc} ]-ATTR EProductions [ | | datatype USE {:} {[]} : {[PP_Doc]} ]--SEM EProduction- | EProduction lhs.datatype = conname @lhs.rename @lhs.nt @con >#< ppSpaced @children.datatype--ATTR EChild [ nt : {NontermIdent} | | datatype : {PP_Doc} ]-ATTR EChildren [ nt : {NontermIdent} | | datatype USE {:} {[]} : {[PP_Doc]} ] --SEM EChild- | EChild lhs.datatype = if isJust @virtual- then empty- else @loc.addStrict $ pp_parens $ typeToHaskellString (Just @lhs.nt) [] @tp- loc.addStrict = \x -> if strictData @lhs.options then "!" >|< x else x------------------------------------------------------------------------------------ Nonterminal semantic function---------------------------------------------------------------------------------SEM ENonterminal- | ENonterminal loc.fsemname = \x -> "sem_" ++ show x- loc.semname = @loc.fsemname @nt- loc.frecarg = \t x -> case t of- NT nt _ -> pp_parens (@fsemname nt >#< x)- _ -> pp x- loc.sem_nt = @loc.semname >#< "::" >#< @nt >#< "->" >#< @loc.t_type- >-< case lookup @nt @lhs.typeSyns of- Nothing -> @prods.sem_nt- Just (List t) -> @loc.semname >#< "list" >#< "=" >#< "Prelude.foldr" >#< @loc.semname >|< "_Cons"- >#< @loc.semname >|< "_Nil"- >#< case t of- NT nt _ -> pp_parens ("Prelude.map" >#< @fsemname nt >#< "list")- _ -> pp "list"- Just (Maybe t) -> @loc.semname >#< "Prelude.Nothing" >#< "=" >#< @loc.semname >|< "_Nothing"- >-< @loc.semname >#< pp_parens ("Prelude.Just just") >#< "="- >#< @loc.semname >|< "_Just" >#< @frecarg t "just"- Just (Tuple ts) -> @loc.semname >#< pp_parens (ppCommas $ map fst ts) >#< "="- >#< @loc.semname >|< "_Tuple" >#< ppSpaced (map (\t -> @frecarg (snd t) (show $ fst t)) ts)- Just (Either l r) -> @loc.semname >#< "(Prelude.Left left)" >#< "=" >#< @loc.semname >|< "_Left" >#< @frecarg l "left"- >-< @loc.semname >#< "(Prelude.Right right)" >#< "=" >#< @loc.semname >|< "_Right" >#< @frecarg r "right"- Just (Map k v) -> @loc.semname >#< "m" >#< "=" >#< "Data.Map.foldrWithKey"- >#< @loc.semname >|< "_Entry" >#< @loc.semname >|< "_Nil"- >#< case v of - NT nt _ -> pp_parens ("Data.Map.map" >#< @fsemname nt >#< "m")- _ -> pp "m"- Just (IntMap v) -> @loc.semname >#< "m" >#< "=" >#< "Data.IntMap.foldWithKey"- >#< @loc.semname >|< "_Entry" >#< @loc.semname >|< "_Nil"- >#< case v of - NT nt _ -> pp_parens ("Data.IntMap.map" >#< @fsemname nt >#< "m")- _ -> pp "m"--- Just x -> error $ "Type " ++ show x ++ " is not supported yet" -- TODO: other typeSyns--ATTR EProduction EProductions [ | | sem_nt USE {>-<} {empty} : {PP_Doc} ]-SEM EProduction- | EProduction lhs.sem_nt = "sem_" >|< @lhs.nt >#< "(" >#< conname @lhs.rename @lhs.nt @con >#< ppSpaced @children.argnames >#< ")"- >#< "=" >#< "sem_" >|< @lhs.nt >|< "_" >|< @con >#< ppSpaced @children.argnamesw--ATTR EChild [ | | argnamesw : { PP_Doc } ] -ATTR EChildren [ | | argnamesw USE {:} {[]} : {[PP_Doc]} ]--SEM EChild- | EChild lhs.argnamesw = if isJust @virtual- then empty- else if isNonterminal @tp- then "(" >#< "sem_" >|< extractNonterminal @tp >#< "field_" >|< @name >#< ")"- else text $ locname @name- ----------------------------------------------------------------------------------- Types of attributes---------------------------------------------------------------------------------ATTR ExecutionPlan- ENonterminals- ENonterminal [ inhmap : {Map.Map NontermIdent Attributes}- synmap : {Map.Map NontermIdent Attributes} | | ]--ATTR EProductions- EProduction- Visits- Visit [ inhmap : {Attributes}- synmap : {Attributes} | | ]--SEM ENonterminal- | ENonterminal (Just prods.inhmap) = Map.lookup @nt @lhs.inhmap- (Just prods.synmap) = Map.lookup @nt @lhs.synmap------------------------------------------------------------------------------------ State datatypes---------------------------------------------------------------------------------{type VisitStateState = (VisitIdentifier,StateIdentifier, StateIdentifier)}--ATTR Visit [ | | allvisits : { VisitStateState }]-ATTR Visits [ | | allvisits USE {:} {[]} : {[VisitStateState]}]-ATTR EProduction- EProductions [ | | allvisits: {[VisitStateState]}]--SEM Visit- | Visit lhs.allvisits = (@ident, @from, @to)--SEM EProductions- | Cons lhs.allvisits = @hd.allvisits -- just pick the first production- | Nil lhs.allvisits = error "Every nonterminal should have at least 1 production"---- type of tree in a given state s-SEM ENonterminal- | ENonterminal loc.outedges = Set.fromList $ map (\(_,f,_) -> f) @prods.allvisits- loc.inedges = Set.fromList $ map (\(_,_,t) -> t) @prods.allvisits- loc.allstates = Set.insert @initial $ @loc.inedges `Set.union` @loc.outedges- loc.t_type = "T_" ++ show @nt- loc.t_init = "type" >#< @loc.t_type >#< "=" >#< @loc.t_type >|< "_s" >|< @initial- loc.t_states = vlist $ map (\st ->- let nt_st = @nt >|< "_s" >|< st- t_st = "T_" >|< nt_st- k_st = "K_" >|< nt_st- c_st = "C_" >|< nt_st- inv_st = "inv_" >|< nt_st- in "data" >#< t_st >#< "where" >#< c_st >#< "::" >#< "{" >#< inv_st >#< "::"- >#< "!" >|< pp_parens ("forall t." >#< k_st >#< "t" >#< "->" >#< "t") >#< "}"- >#< "->" >#< t_st- ) $ Set.toList @loc.allstates---- type of a key which identifies a visit v from state s-SEM ENonterminal- | ENonterminal loc.k_type = "K_" ++ show @nt- loc.k_states = vlist $ map (\st ->- let nt_st = @nt >|< "_s" >|< st- k_st = "K_" >|< nt_st- outg = filter (\(v,f,t) -> f == st) @prods.allvisits- visitlist = vlist $ map (\(v,f,t) ->- @loc.k_type >|< "_v" >|< v >#< "::" >#< k_st >#< @loc.t_type >|< "_v" >|< v- ) outg- in "data" >#< k_st >#< "k" >#< "where"- >-< indent 3 visitlist) $ Set.toList @loc.allstates---- type of a visit v, with continuation as new state s-ATTR Visit- Visits- EProduction- EProductions [ nt : {NontermIdent} | | t_visits USE {>-<} {empty} : {PP_Doc} ]--SEM EProductions- | Cons lhs.t_visits = @hd.t_visits -- just pick the first production--SEM ENonterminal- | ENonterminal prods.nt = @nt--SEM Visit- | Visit lhs.t_visits = "type" >#< "T_" >|< @lhs.nt >|< "_v" >|< @ident >#< "=" >#< @loc.inhpart >#<- "Identity" >#< "(" >#< @loc.synpart >#< "T_" >|< @lhs.nt >|< "_s" >|< @to >#< ")"- loc.inhpart = if Set.null @inh- then empty- else (ppSpaced $ map (\i -> (\x -> pp_parens x >#< "->") $ typeToHaskellString (Just @lhs.nt) []- $ fromJust $ Map.lookup i @lhs.inhmap) $ Set.toList @inh)- loc.synpart = if Set.null @syn- then empty- else (ppCommas $ map (\i -> typeToHaskellString (Just @lhs.nt) [] $ fromJust $ Map.lookup i @lhs.synmap) $ Set.toList @syn) >#< ","------------------------------------------------------------------------------------ Inh and Syn wrappers---------------------------------------------------------------------------------SEM ENonterminal- | ENonterminal loc.wr_inh = @loc.genwrap "Inh" @loc.wr_inhs- loc.wr_syn = @loc.genwrap "Syn" @loc.wr_syns- loc.genwrap = \nm attr -> "data" >#< nm >|< "_" >|< @nt >#< "=" >#< nm >|< "_" >|< @nt >#< "{"- >#< (ppCommas $ map (\(i,t) -> i >|< "_" >|< nm >|< "_" >|< @nt >#< "::"- >#< typeToHaskellString (Just @nt) [] t) attr) >#< "}"- loc.wr_inhs = Map.toList $ fromJust $ Map.lookup @nt @lhs.inhmap- loc.wr_syns = Map.toList $ fromJust $ Map.lookup @nt @lhs.synmap- loc.inhlist = map (lhsname True . fst) @loc.wr_inhs- loc.synlist = map (lhsname False . fst) @loc.wr_syns- loc.wrapname = "wrap_" ++ show @nt- loc.inhname = "Inh_" ++ show @nt- loc.synname = "Syn_" ++ show @nt- loc.wrapper = (@loc.wrapname >#< "::" >#< @loc.t_type >#< "->"- >#< @loc.inhname >#< "->" >#< @loc.synname)- >-<- (@loc.wrapname >#< "sem" >#< "(" >#< @loc.inhname- >#< ppSpaced @loc.inhlist >#< ")" >#< "=")- >-<- indent 3 (case @initialv of- -- case where there are no inherited or synthesized attributes- Nothing -> @loc.synname >#< " { }"- Just initv ->- "let" >#< "(" >#< ppCommas @loc.synlist >#< "," >#< "_" >#< ")" >#< "="- >#< "Control.Monad.Identity.runIdentity"- >#< pp_parens ("inv_" >|< @nt >|< "_s" >|< @initial- >#< "sem" >#< @loc.k_type >|< "_v" >|< initv- >#< ppSpaced @loc.inhlist)- >-<- "in " >#< "(" >#< @loc.synname >#< ppSpaced @loc.synlist >#< ")")------------------------------------------------------------------------------------ Production semantic functions---------------------------------------------------------------------------------ATTR EProduction [ | | sem_prod : {PP_Doc} ]-ATTR EProductions [ | | sem_prod USE {>-<} {empty} : {PP_Doc} ]--ATTR EProduction EProductions [ initial : {StateIdentifier}- allstates : {Set.Set StateIdentifier} | | ]-SEM ENonterminal- | ENonterminal prods.initial = @initial- prods.allstates = @loc.allstates--ATTR EChild [ | | argtps : { PP_Doc }- argnames : { PP_Doc } ]-ATTR EChildren [ | | argtps USE {:} {[]} : { [PP_Doc] }- argnames USE {:} {[]} : { [PP_Doc] } ]--SEM EChild- | EChild lhs.argtps = if isJust @virtual- then empty- else if isNonterminal @tp- then ("T_" >|< extractNonterminal @tp) >#< "->"- else (text $ show @tp) >#< "->"- loc.argnames = if isJust @virtual- then empty- else if isNonterminal @tp- then "field_" >|< @name- else text $ locname @name--SEM EProduction- | EProduction loc.args = @children.argnames- loc.semname = "sem_" ++ show @lhs.nt ++ "_" ++ show @con- loc.sem_prod = @loc.semname >#< "::" >#< ppSpaced @children.argtps >#< "T_" >|< @lhs.nt- >-< @loc.semname >#< ppSpaced @loc.args >#< "="- >#< "st" >|< @lhs.initial >#< "where"- >-< (indent 3 $ vlist @loc.statefns >-< @rules.sem_rules)- loc.statefns = map (\st -> "st" >|< st >#< @loc.stargs st >#< "=" >#<- "C_" >|< @lhs.nt >|< "_s" >|< st >#< "k" >|< st >#< "where"- >-< indent 3 (@loc.stks st >-< @loc.stvs st)- ) $ Set.toList @lhs.allstates- loc.stargs = \st -> ppSpaced $ Set.toList $ maybe Set.empty id $ Map.lookup st @visits.intramap- loc.stks = \st -> "k" >|< st >#< "::" >#< "K_" >|< @lhs.nt >|< "_s" >|< st >#< "t" >#< "->" >#< "t"- >-< vlist (map (\(v,f,t) -> "k" >|< st >#< "K_" >|< @lhs.nt >|< "_v" >|< v >#< "="- >#< "v" >|< v) $ @loc.stvisits st)- >-< if null (@loc.stvisits st)- then "k" >|< st >#< "_" >#< "=" >#< "error \"unreachable\""- else empty- loc.stvisits = \st -> filter (\(v,f,t) -> f == st) @visits.allvisits- loc.stvs = \st -> vlist $ map snd $ filter (\(f,pp) -> f == st) @visits.sem_visit- visits.mrules = @rules.mrules------------------------------------------------------------------------------------ Visit semantic functions---------------------------------------------------------------------------------ATTR Visit [ | | sem_visit : { (StateIdentifier,PP_Doc) } ]-ATTR Visits [ | | sem_visit USE {:} {[]} : { [(StateIdentifier,PP_Doc)] } ]--SEM Visit- | Visit lhs.sem_visit = (@from, "v" >|< @ident >#< "::" >#< "T_" >|< @lhs.nt >|< "_v" >|< @ident- >-< "v" >|< @ident >#< (@loc.inhargs _LHS True) >#< "=" >#< "do"- >-< indent 3 @loc.sem_steps)- loc.inhargs = \chn inh -> ppSpaced $ map (\arg -> attrname inh chn arg) $ Set.toList @inh- loc.synargs = ppSpaced $ map (\arg -> attrname False _LHS arg >#< ",") $ Set.toList @syn- loc.nextargs = ppSpaced $ Set.toList $ maybe Set.empty id $ Map.lookup @to @lhs.allintramap- loc.sem_steps = @steps.sem_steps- >-< "return" >#< "(" >#< @loc.synargs >#< "st" >|< @to >#< @loc.nextargs >#< ")"--ATTR Visits Visit VisitStep VisitSteps [ mrules : {Map.Map Identifier PP_Doc} | | ]-ATTR VisitStep VisitSteps [ | | sem_steps USE {>-<} {empty} : {PP_Doc} ]-SEM VisitStep- | Sem lhs.sem_steps = maybe (error $ "Rule " ++ show @name ++ " not found") id $ Map.lookup @name @lhs.mrules- | ChildIntro lhs.sem_steps = maybe (error $ "Child " ++ show @child ++ " not found") id $ Map.lookup @child @lhs.childintros- | ChildVisit lhs.sem_steps = (maybe (error $ "Visit " ++ show @visit ++ " not found") id $ Map.lookup @visit @lhs.allchildvisit) $ @child---- Child introduction-ATTR EChild EChildren [ | | childintros USE {`Map.union`} {Map.empty} : {Map.Map Identifier PP_Doc} ]--ATTR Visits Visit- VisitSteps VisitStep [ childintros : {Map.Map Identifier PP_Doc} | | ]--SEM EProduction- | EProduction visits.childintros = @children.childintros--SEM EChild- | EChild lhs.childintros = Map.singleton @name $ locname @name >#< "<-" >#< "return" >#< "$" >#<- if isJust @virtual- then "sem_" >|< extractNonterminal @tp >#< instname @name- else "field_" >|< @name---- keep a list of all rules that are used-ATTR Visit Visits VisitSteps VisitStep [ | | usedrules USE {`Set.union`} {Set.empty} : {Set.Set Identifier} ]-ATTR ERules ERule [ usedrules : {Set.Set Identifier} | | ]--SEM VisitStep- | Sem lhs.usedrules = Set.singleton @name--SEM EProduction- | EProduction rules.usedrules = @visits.usedrules---- rules-ATTR ERules ERule [ | | sem_rules USE {>-<} {empty} : {PP_Doc}- mrules USE {`Map.union`} {Map.empty} : {Map.Map Identifier PP_Doc} ]--SEM ERule- | ERule lhs.sem_rules = if Set.member @name @lhs.usedrules- then (@name >#< "=" >#< - (if Set.null @rhs.attrs- then empty- else "\\" >|< @loc.attrlst >#< "->")- >#< @rhs.semfunc)- else empty- loc.attrlst = ppSpaced $ Set.toList @rhs.attrs- lhs.mrules = Map.singleton @name $ @loc.addbang @pattern.sem_lhs >#< "<-" >#< "return" >#< "$" >#< @name >#< @loc.attrlst- pattern.addtilde = \x -> if cases @lhs.options then x else "~" >|< x- loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x---- pattern and expression semantics-ATTR Pattern [ | | sem_lhs : { PP_Doc } ]-ATTR Patterns [ | | sem_lhs USE {:} {[]} : {[PP_Doc]} ]-ATTR Pattern Patterns [ addtilde : {PP_Doc -> PP_Doc} | | ]--ATTR Pattern Patterns [ | | attrs USE {`Set.union`} {Set.empty} : {Set.Set String} ]--SEM Pattern- | Alias lhs.sem_lhs = text $ attrname False @field @attr -- todo: alias- lhs.attrs = Set.singleton $ attrname False @field @attr- | Product lhs.sem_lhs = @lhs.addtilde $ pp_block "(" ")" "," @pats.sem_lhs- pats.addtilde = id- | Constr lhs.sem_lhs = @lhs.addtilde $ pp_parens $ @name >#< hv_sp @pats.sem_lhs- pats.addtilde = id- | Underscore lhs.sem_lhs = text "_"- | Irrefutable lhs.sem_lhs = text "~" >|< pp_parens @pat.sem_lhs- pat.addtilde = id--ATTR HsToken Expression [ | | attrs USE {`Set.union`} {Set.empty} : {Set.Set String} ]-SEM HsToken- | AGLocal lhs.attrs = Set.singleton $ locname @var- | AGField lhs.attrs = Set.singleton $ attrname True @field @attr--ATTR Expression [ | | semfunc : {PP_Doc} ]--SEM Expression- | Expression lhs.attrs = Set.unions $ map (\tok -> attrs_Syn_HsToken (wrap_HsToken (sem_HsToken tok) Inh_HsToken)) @tks- lhs.semfunc = vlist $ showTokens $ map (\tok -> tok_Syn_HsToken (wrap_HsToken (sem_HsToken tok) Inh_HsToken)) @tks---- child visit map-ATTR Visit- Visits- EProduction- EProductions- ENonterminal- ENonterminals [ allchildvisit : {Map.Map VisitIdentifier (Identifier -> PP_Doc)}- | | childvisit USE {`Map.union`} {Map.empty} : {Map.Map VisitIdentifier (Identifier -> PP_Doc)} ]--ATTR VisitSteps VisitStep [ allchildvisit : {Map.Map VisitIdentifier (Identifier -> PP_Doc)} | | ]--SEM ExecutionPlan- | ExecutionPlan nonts.allchildvisit = @nonts.childvisit--SEM Visit- | Visit lhs.childvisit = Map.singleton @ident $ \chn -> @loc.addbang ("(" >#< ppSpaced (- map (\x -> attrname True chn x >#< ",") $ Set.toList @syn) >#< locname chn - >#< ")") >#< "<-" >#< "inv_" >|< @lhs.nt >|< "_s" >|< @from >#< locname chn- >#< "K_" >|< @lhs.nt >|< "_v" >|< @ident >#< @loc.inhargs chn False- loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x------------------------------------------------------------------------------------ Intra attributes---------------------------------------------------------------------------------{-uwSetUnion :: (Ord a, Ord b) => Map.Map a (Set.Set b) -> Map.Map a (Set.Set b) -> Map.Map a (Set.Set b)-uwSetUnion = Map.unionWith Set.union-}-ATTR Visit Visits [ allintramap : {Map.Map StateIdentifier (Set.Set String)}- | | intramap USE {`uwSetUnion`} {Map.empty} : {Map.Map StateIdentifier (Set.Set String)} ] --ATTR Visit Visits [ terminaldefs : {Set.Set String} | | ]-ATTR EChild EChildren [ | | terminaldefs USE {`Set.union`} {Set.empty} : {Set.Set String} ]--SEM EChild- | EChild lhs.terminaldefs = if isJust @virtual || isNonterminal @tp- then Set.empty- else Set.singleton $ locname @name--SEM EProduction- | EProduction visits.allintramap = @visits.intramap- visits.terminaldefs = @children.terminaldefs--SEM Visit- | Visit lhs.intramap = Map.singleton @from $ (@loc.uses `Set.union` @loc.nextintra) `Set.difference` @loc.defs- loc.nextintra = maybe Set.empty id $ Map.lookup @to @lhs.allintramap- loc.uses = @steps.uses- loc.defs = @steps.defs `Set.union` (Set.map (lhsname True) @inh) `Set.union` @lhs.terminaldefs--ATTR ERule ERules [ | | ruledefs USE {`uwSetUnion`} {Map.empty} : {Map.Map Identifier (Set.Set String)}- ruleuses USE {`uwSetUnion`} {Map.empty} : {Map.Map Identifier (Set.Set String)} ]-ATTR Visit Visits- VisitSteps VisitStep [ ruledefs : {Map.Map Identifier (Set.Set String)}- ruleuses : {Map.Map Identifier (Set.Set String)} | | ]--SEM ERule- | ERule lhs.ruledefs = Map.singleton @name @pattern.attrs- lhs.ruleuses = Map.singleton @name @rhs.attrs--SEM EProduction- | EProduction visits.ruledefs = @rules.ruledefs- visits.ruleuses = @rules.ruleuses--ATTR Visit Visits- EProduction- EProductions- ENonterminal- ENonterminals [ | | visitdefs USE {`uwSetUnion`} {Map.empty} : {Map.Map VisitIdentifier (Set.Set Identifier)}- visituses USE {`uwSetUnion`} {Map.empty} : {Map.Map VisitIdentifier (Set.Set Identifier)} ]--SEM Visit- | Visit lhs.visitdefs = Map.singleton @ident @syn- lhs.visituses = Map.singleton @ident @inh--ATTR Visit Visits- VisitSteps VisitStep- EProduction EProductions- ENonterminal ENonterminals [ avisitdefs : {Map.Map VisitIdentifier (Set.Set Identifier)}- avisituses : {Map.Map VisitIdentifier (Set.Set Identifier)} | | ]--SEM ExecutionPlan- | ExecutionPlan nonts.avisitdefs = @nonts.visitdefs- nonts.avisituses = @nonts.visituses--ATTR VisitSteps VisitStep [ | | defs USE {`Set.union`} {Set.empty} : {Set.Set String}- uses USE {`Set.union`} {Set.empty} : {Set.Set String} ]-SEM VisitStep- | Sem lhs.defs = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruledefs- lhs.uses = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruleuses- | ChildIntro lhs.defs = Set.singleton $ locname @child- | ChildVisit lhs.defs = maybe (error "Visit not found") (Set.map $ attrname True @child) $ Map.lookup @visit @lhs.avisitdefs- lhs.uses = Set.insert (locname @child) $- maybe (error "Visit not found") (Set.map $ attrname False @child) $ Map.lookup @visit @lhs.avisituses------------------------------------------------------------------------------------- Pretty printing of haskell code----------------------------------------------------------------------------------SEM HsTokens [ || tks : {[(Pos,String)]} ]- | Cons lhs.tks = @hd.tok : @tl.tks- | Nil lhs.tks = []--SEM HsToken- | AGLocal loc.tok = (@pos,locname @var)--SEM HsToken [ || tok:{(Pos,String)}]- | AGField- loc.addTrace = case @rdesc of- Just d -> \x -> "(trace " ++ show (d ++ " -> " ++ show @field ++ "." ++ show @attr) ++ " (" ++ x ++ "))"- Nothing -> id- lhs.tok = (@pos, @loc.addTrace $ attrname True @field @attr)-- | HsToken lhs.tok = (@pos, @value)-- | CharToken lhs.tok = (@pos, if null @value- then ""- else showCharShort (head @value)- )-- | StrToken lhs.tok = (@pos, showStrShort @value)- | Err lhs.tok = (@pos, "")------------------------------------------------------------------------------------ Alternative code generation (sepsemmods)----------------------------------------------------------------------------------ATTR ExecutionPlan [ | | genIO : {IO ()} ]--SEM ExecutionPlan- | ExecutionPlan lhs.genIO = do @loc.genMainModule- @loc.genCommonModule- @nonts.genProdIO- loc.mainModuleFile = @lhs.mainFile ++ ".hs"- loc.genMainModule = writeModule @loc.mainModuleFile- ( [ pp $ "{-# LANGUAGE Rank2Types, GADTs, EmptyDataDecls #-}"- , pp $ @lhs.pragmaBlocks- , pp $ @lhs.optionsLine- , pp $ @lhs.moduleHeader @lhs.mainName "" "" False- , pp $ "import Control.Monad.Identity"- , pp $ "import " ++ @lhs.mainName ++ "_common"- ]- ++ @nonts.imports- ++ @nonts.appendMain- )- loc.commonFile = @lhs.mainFile ++ "_common.hs"- loc.genCommonModule = writeModule @loc.commonFile- ( [ pp $ "{-# LANGUAGE Rank2Types, GADTs, EmptyDataDecls #-}"- , pp $ @lhs.pragmaBlocks- , pp $ @lhs.optionsLine- , pp $ @lhs.moduleHeader @lhs.mainName "_common" "" True- , pp $ "import Control.Monad.Identity"- , @lhs.importBlocks- , @lhs.textBlocks- ]- ++ @nonts.appendCommon- )--ATTR ENonterminal [ | | appendCommon, appendMain : { PP_Doc } ]-ATTR ENonterminals [ | | appendCommon, appendMain USE {:} {[]} : {[PP_Doc]} ]--SEM ENonterminal- | ENonterminal lhs.appendMain = (if @nt `Set.member` @lhs.wrappers- then @loc.wr_inh- >-< @loc.wr_syn- >-< @loc.wrapper- else empty)- >-< @loc.sem_nt- lhs.appendCommon = (if dataTypes @lhs.options then @loc.datatype else empty)- >-< @loc.t_init - >-< @loc.t_states- >-< @loc.k_states- >-< @prods.t_visits--ATTR EProduction EProductions- ENonterminal ENonterminals [ | | imports USE {++} {[]} : {[PP_Doc]}- genProdIO USE {>>} {return ()} : {IO ()} ]--SEM EProduction- | EProduction lhs.imports = [pp $ "import " ++ @loc.moduleName]- loc.moduleName = @lhs.mainName ++ @loc.suffix- loc.suffix = "_" ++ show @lhs.nt ++ "_" ++ show @con- loc.outputfile = @lhs.mainFile ++ @loc.suffix ++ ".hs"- lhs.genProdIO = writeModule @loc.outputfile- [ pp "{-# LANGUAGE Rank2Types, GADTs, EmptyDataDecls #-}"- , pp $ @lhs.pragmaBlocks- , pp $ @lhs.optionsLine- , pp $ @lhs.moduleHeader @lhs.mainName @loc.suffix @loc.semname True- , pp $ "import Control.Monad.Identity"- , pp $ "import " ++ @lhs.mainName ++ "_common"- , @loc.sem_prod- ]--{-renderDocs :: [PP_Doc] -> String-renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) ""--writeModule :: FilePath -> [PP_Doc] -> IO ()-writeModule path docs- = do bExists <- doesFileExist path- if bExists- then do input <- readFile path- seq (length input) (return ())- if input /= output- then dumpIt- else return ()- else dumpIt- where- output = renderDocs docs- dumpIt = writeFile path output-}-+import Data.Monoid(mappend,mempty)+import Data.Maybe+import Debug.Trace+import System.IO+import System.Directory+import System.FilePath+import UU.Scanner.Position++import TokenDef+import HsToken+import ErrorMessages++import Data.Set (Set)+import qualified Data.Set as Set+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Sequence(Seq)+import qualified Data.Sequence as Seq+import Data.Foldable(toList)+}++ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule EChildren EChild+ [ importBlocks : PP_Doc+ pragmaBlocks : String+ textBlocks : PP_Doc+ moduleHeader : {String -> String -> String -> Bool -> String}+ mainFile : String+ mainName : String | | ]++-------------------------------------------------------------------------------+-- Options+-------------------------------------------------------------------------------+ATTR ExecutionPlan+ ENonterminals ENonterminal+ EProductions EProduction+ ERules ERule+ Pattern Patterns+ EChildren EChild+ Visits Visit+ VisitSteps VisitStep [ options : {Options} | | ]+ATTR EProductions EProduction [ rename : {Bool} | | ]++SEM ENonterminal+ | ENonterminal prods.rename = rename @lhs.options++-------------------------------------------------------------------------------+-- Context info (nonterminal ident, constructor ident, nonterm params, etc.)+-------------------------------------------------------------------------------++ATTR Visit Visits EProduction EProductions EChildren EChild ERules ERule [ nt : NontermIdent | | ]+SEM ENonterminal+ | ENonterminal prods.nt = @nt++ATTR EChildren EChild ERules ERule Visits Visit+ [ con : ConstructorIdent | | ]++SEM EProduction+ | EProduction children.con = @con+ rules.con = @con+ visits.con = @con++ATTR EProductions EProduction Visits Visit [ params : {[Identifier]} | | ]+SEM ENonterminal | ENonterminal+ prods.params = @params++ATTR EProductions EProduction [ classCtxs : ClassContext | | ]+SEM ENonterminal | ENonterminal+ prods.classCtxs = @classCtxs++-------------------------------------------------------------------------------+-- Default output+-------------------------------------------------------------------------------+ATTR ExecutionPlan [ | | output : {PP_Doc} ]++SEM ExecutionPlan+ | ExecutionPlan lhs.output = @nonts.output >-< @loc.commonExtra >-< @loc.wrappersExtra++ATTR ENonterminal ENonterminals [ wrappers : {Set NontermIdent}+ | | output USE {>-<} {empty} : {PP_Doc} ]++SEM ExecutionPlan+ | ExecutionPlan nonts.wrappers = @wrappers++SEM ENonterminal+ | ENonterminal lhs.output = ("-- " ++ getName @nt ++ " " ++ replicate (60 - length (getName @nt)) '-')+ >-< (if dataTypes @lhs.options+ then "-- data"+ >-< @loc.datatype+ >-< ""+ else empty)+ >-< (if @loc.hasWrapper+ then "-- wrapper"+ >-< @loc.wr_inh+ >-< @loc.wr_syn+ >-< @loc.wrapper+ >-< ""+ else empty)+ >-< (if folds @lhs.options+ then "-- cata"+ >-< @loc.sem_nt+ >-< ""+ else empty)+ >-< (if semfuns @lhs.options+ then "-- semantic domain"+ >-< @loc.t_init+ >-< @loc.t_states+ >-< @loc.k_states+ >-< @prods.t_visits+ >-< @prods.sem_prod+ >-< ""+ else empty)+ loc.hasWrapper = @nt `Set.member` @lhs.wrappers++-------------------------------------------------------------------------------+-- Nonterminal datatype+-------------------------------------------------------------------------------+ATTR ENonterminal ENonterminals [ typeSyns : {TypeSyns}+ derivings : {Derivings} | | ]++SEM ExecutionPlan+ | ExecutionPlan nonts.typeSyns = @typeSyns+ nonts.derivings = @derivings++SEM ENonterminal+ | ENonterminal loc.classPP = ppClasses $ classCtxsToDocs @classCtxs+ loc.aliasPre = "type" >#< @loc.classPP >#< @nt >#< @loc.t_params >#< "="+ loc.datatype = case lookup @nt @lhs.typeSyns of+ Nothing -> "data" >#< @loc.classPP >#< @nt >#< @loc.t_params+ >-< ( if null @prods.datatype+ then empty+ else indent 2 $ vlist $ ( ("=" >#< head @prods.datatype)+ : (map ("|" >#<) $ tail @prods.datatype))+ )+ >-< indent 2 @loc.derivings+ Just (List t) -> @loc.aliasPre >#< "[" >#< show t >#< "]"+ Just (Maybe t) -> @loc.aliasPre >#< "Maybe" >#< show t+ Just (Tuple ts) -> @loc.aliasPre >#< pp_parens (ppCommas $ map (show . snd) ts)+ Just (Either l r) -> @loc.aliasPre >#< "Either" >#< show l >#< show r+ Just (Map k v) -> @loc.aliasPre >#< "Data.Map" >#< pp_parens (show k) >#< show v+ Just (IntMap t) -> @loc.aliasPre >#< "Data.IntMap.IntMap" >#< show t+ Just (OrdSet t) -> @loc.aliasPre >#< "Data.Set.Set" >#< show t+ Just IntSet -> @loc.aliasPre >#< "Data.IntSet.IntSet"+-- Just x -> error $ "Type " ++ show x ++ " is not supported"+ loc.derivings = case Map.lookup @nt @lhs.derivings of+ Nothing -> empty+ Just s -> if Set.null s+ then empty+ else "deriving" >#< (pp_parens $ ppCommas $ map pp $ Set.toList s)++{+classCtxsToDocs :: ClassContext -> [PP_Doc]+classCtxsToDocs = map toDoc where+ toDoc (ident,args) = (ident >#< ppSpaced (map pp_parens args))++classConstrsToDocs :: [Type] -> [PP_Doc]+classConstrsToDocs = map ppTp++ppClasses :: [PP_Doc] -> PP_Doc+ppClasses [] = empty+ppClasses xs = pp_block "(" ")" "," xs >#< "=>"++ppQuants :: [Identifier] -> PP_Doc+ppQuants [] = empty+ppQuants ps = "forall" >#< ppSpaced ps >#< "."+}++ATTR EProduction [ | | datatype : {PP_Doc} ]+ATTR EProductions [ | | datatype USE {:} {[]} : {[PP_Doc]} ]++-- we generate the data type in the type-class style instead of the GADT style+-- the GADT extension may be required if equality constraints are used+SEM EProduction+ | EProduction lhs.datatype = @loc.quantPP1 >#< @loc.classPP1+ >#< conname @lhs.rename @lhs.nt @con+ >#< ppConFields (dataRecords @lhs.options) @children.datatype+ loc.classPP1 = ppClasses (classConstrsToDocs @constraints)+ loc.quantPP1 = ppQuants @params++{+-- first parameter indicates: generate a record or not+ppConFields :: Bool -> [PP_Doc] -> PP_Doc+ppConFields True flds = ppListSep "{" "}" ", " flds+ppConFields False flds = ppSpaced flds+}+++ATTR EChild [ | | datatype : {PP_Doc} ]+ATTR EChildren [ | | datatype USE {:} {[]} : {[PP_Doc]} ]++-- Note: the child may be a higher-order attribute, and its semantics may be deforested+SEM EChild+ | EChild ETerm+ loc.tpDoc = @loc.addStrict $ pp_parens $ ppTp $ removeDeforested @tp+ loc.strNm = recordFieldname @lhs.nt @lhs.con @name+ loc.field = if dataRecords @lhs.options+ then @loc.strNm >#< "::" >#< @loc.tpDoc+ else @loc.tpDoc+ loc.addStrict = \x -> if strictData @lhs.options then "!" >|< x else x+ | EChild lhs.datatype = case @kind of+ ChildAttr -> empty -- higher order attributes are not part of the data type+ _ -> @loc.field++ | ETerm lhs.datatype = @loc.field++{+ppTp :: Type -> PP_Doc+ppTp (Haskell s) = text s+ppTp (NT nt args for) = prefix >|< nt >#< ppSpaced (map pp_parens args) where+ prefix | for = text "T_"+ | otherwise = empty+}++-------------------------------------------------------------------------------+-- Nonterminal semantic function+-------------------------------------------------------------------------------+SEM ENonterminal+ | ENonterminal loc.fsemname = \x -> "sem_" ++ show x+ loc.semname = @loc.fsemname @nt+ loc.frecarg = \t x -> case t of+ NT nt _ _ -> pp_parens (@fsemname nt >#< x)+ _ -> pp x++ -- The sem_NT function is lazy in the AST: it depends on the application of "child"+ -- rules to which extend the AST needs to be constructed.+ loc.sem_tp = @loc.quantPP >#< @loc.classPP >#< @nt >#< @loc.t_params >#< "->" >#< @loc.t_type >#< @loc.t_params+ loc.quantPP = ppQuants @params+ loc.sem_nt = @loc.semPragma+ >-< @loc.semname >#< "::" >#< @loc.sem_tp+ >-< case lookup @nt @lhs.typeSyns of+ Nothing -> @prods.sem_nt+ Just (List t) -> @loc.semname >#< "list" >#< "=" >#< "Prelude.foldr" >#< @loc.semname >|< "_Cons"+ >#< @loc.semname >|< "_Nil"+ >#< case t of+ NT nt _ _ -> pp_parens ("Prelude.map" >#< @fsemname nt >#< "list")+ _ -> pp "list"+ Just (Maybe t) -> @loc.semname >#< "Prelude.Nothing" >#< "=" >#< @loc.semname >|< "_Nothing"+ >-< @loc.semname >#< pp_parens ("Prelude.Just just") >#< "="+ >#< @loc.semname >|< "_Just" >#< @frecarg t "just"+ Just (Tuple ts) -> @loc.semname >#< pp_parens (ppCommas $ map fst ts) >#< "="+ >#< @loc.semname >|< "_Tuple" >#< ppSpaced (map (\t -> @frecarg (snd t) (show $ fst t)) ts)+ Just (Either l r) -> @loc.semname >#< "(Prelude.Left left)" >#< "=" >#< @loc.semname >|< "_Left" >#< @frecarg l "left"+ >-< @loc.semname >#< "(Prelude.Right right)" >#< "=" >#< @loc.semname >|< "_Right" >#< @frecarg r "right"+ Just (Map k v) -> @loc.semname >#< "m" >#< "=" >#< "Data.Map.foldrWithKey"+ >#< @loc.semname >|< "_Entry" >#< @loc.semname >|< "_Nil"+ >#< case v of+ NT nt _ _ -> pp_parens ("Data.Map.map" >#< @fsemname nt >#< "m")+ _ -> pp "m"+ Just (IntMap v) -> @loc.semname >#< "m" >#< "=" >#< "Data.IntMap.foldWithKey"+ >#< @loc.semname >|< "_Entry" >#< @loc.semname >|< "_Nil"+ >#< case v of+ NT nt _ _ -> pp_parens ("Data.IntMap.map" >#< @fsemname nt >#< "m")+ _ -> pp "m"+ Just (OrdSet t) -> @loc.semname >#< "s" >#< "=" >#< "Prelude.foldr" >#< @loc.semname >|< "_Entry"+ >#< @loc.semname >|< "_Nil"+ >#< pp_parens (+ ( case t of+ NT nt _ _ -> pp_parens ("Prelude.map" >#< @fsemname nt)+ _ -> empty+ ) >#< pp_parens ("Data.IntSet.elems" >#< "s")+ )+ Just IntSet -> @loc.semname >#< "s" >#< "=" >#< "Prelude.foldr" >#< @loc.semname >|< "_Entry"+ >#< @loc.semname >|< "_Nil"+ >#< pp_parens ("Data.IntSet.elems" >#< "s")+-- Just x -> error $ "Type " ++ show x ++ " is not supported yet" -- TODO: other typeSyns++ -- precise inlining strategies for inlining+ loc.inlineNt = not (lateHigherOrderBinding @lhs.options) && not @recursive && (@prods.count == 1 || (aggressiveInlinePragmas @lhs.options && not @loc.hasWrapper)) -- lucrative for inlining+ loc.semPragma = if noInlinePragmas @lhs.options+ then empty+ else if @loc.inlineNt+ then ppInline @loc.semname+ else if helpInlining @lhs.options && not (lateHigherOrderBinding @lhs.options)+ then ppInlinable @loc.semname+ else ppNoInline @loc.semname++-- The number of productions+ATTR EProductions EProduction [ | | count USE {+} {0} : {Int} ]+SEM EProduction | EProduction lhs.count = {1}++-- The per-production cases for the sem_NT function+ATTR EProduction EProductions [ | | sem_nt USE {>-<} {empty} : {PP_Doc} ]+SEM EProduction+ | EProduction lhs.sem_nt = "sem_" >|< @lhs.nt >#< "(" >#< conname @lhs.rename @lhs.nt @con >#< ppSpaced @children.argpats >#< ")"+ >#< "=" >#< "sem_" >|< @lhs.nt >|< "_" >|< @con >#< ppSpaced @children.argnamesw++ATTR EChild [ | | argnamesw : { PP_Doc } ]+ATTR EChildren [ | | argnamesw USE {:} {[]} : {[PP_Doc]} ]++SEM EChild+ | EChild lhs.argnamesw = case @kind of+ ChildSyntax -> "(" >#< "sem_" >|< @loc.nt >#< "field_" >|< @name >#< ")"+ ChildAttr -> empty -- no sem-case for a higher-order child+ ChildReplace tp -> "(" >#< "sem_" >|< extractNonterminal tp >#< "field_" >|< @name >#< ")"+ | ETerm lhs.argnamesw = text $ locname @name++-------------------------------------------------------------------------------+-- Types of attributes+-------------------------------------------------------------------------------+ATTR ExecutionPlan+ ENonterminals+ ENonterminal [ inhmap : {Map NontermIdent Attributes}+ synmap : {Map NontermIdent Attributes} | | ]++ATTR EProductions EProduction+ ERules ERule+ Visits+ Visit [ inhmap : {Attributes}+ synmap : {Attributes}+ allInhmap : {Map NontermIdent Attributes}+ allSynmap : {Map NontermIdent Attributes} | | ]++SEM ENonterminal+ | ENonterminal (Just prods.inhmap) = Map.lookup @nt @lhs.inhmap+ (Just prods.synmap) = Map.lookup @nt @lhs.synmap+ prods.allInhmap = @lhs.inhmap+ prods.allSynmap = @lhs.synmap++-------------------------------------------------------------------------------+-- State datatypes+-------------------------------------------------------------------------------+{type VisitStateState = (VisitIdentifier,StateIdentifier, StateIdentifier)}++ATTR Visit [ | | allvisits : { VisitStateState }]+ATTR Visits [ | | allvisits USE {:} {[]} : {[VisitStateState]}]+ATTR EProduction+ EProductions [ | | allvisits: {[VisitStateState]}]++SEM Visit+ | Visit lhs.allvisits = (@ident, @from, @to)++SEM EProductions+ | Cons lhs.allvisits = @hd.allvisits -- just pick the first production+ | Nil lhs.allvisits = error "Every nonterminal should have at least 1 production"++-- type of tree in a given state s+SEM ENonterminal+ | ENonterminal loc.outedges = Set.fromList $ map (\(_,f,_) -> f) @prods.allvisits+ loc.inedges = Set.fromList $ map (\(_,_,t) -> t) @prods.allvisits+ loc.allstates = Set.insert @initial $ @loc.inedges `Set.union` @loc.outedges+ loc.stvisits = \st -> filter (\(v,f,t) -> f == st) @prods.allvisits+ loc.t_type = "T_" >|< @nt+ loc.t_params = ppSpaced @params+ loc.t_init = "newtype" >#< @loc.t_type >#< @loc.t_params >#< "=" >#< @loc.t_type >#<+ pp_braces (+ "attach_">|< @loc.t_type >#< "::"+ >#< ppMonadType @lhs.options >#< pp_parens (@loc.t_type >|< "_s" >|< @initial >#< @loc.t_params))+ loc.t_states = vlist $ map (\st ->+ let nt_st = @nt >|< "_s" >|< st+ t_st = "T_" >|< nt_st+ k_st = "K_" >|< nt_st+ c_st = "C_" >|< nt_st+ inv_st = "inv_" >|< nt_st+ nextVisit = Map.findWithDefault ManyVis st @nextVisits+ in case nextVisit of+ NoneVis -> "data" >#< t_st >#< @loc.t_params >#< "=" >#< c_st -- empty semantics+ OneVis vId -> "newtype" >#< t_st >#< @loc.t_params >#< "=" >#< c_st+ >#< (pp_braces $ inv_st >#< "::" >#< pp_parens (conNmTVisit @nt vId >#< @loc.t_params))+ ManyVis -> "data" >#< t_st >#< @loc.t_params >#< "where" >#< c_st >#< "::"+ >#< (pp_braces $ inv_st >#< "::" >#< "!" >|< pp_parens ("forall t." >#< k_st >#< @loc.t_params >#< "t" >#< "->" >#< "t"))+ >#< "->" >#< t_st >#< @loc.t_params -- this is a conventional data type, but declared with GADT syntax+ ) $ Set.toList @loc.allstates++-- type of a key which identifies a visit v from state s+SEM ENonterminal+ | ENonterminal loc.k_type = "K_" ++ show @nt+ loc.k_states = vlist $ map (\st ->+ let nt_st = @nt >|< "_s" >|< st+ k_st = "K_" >|< nt_st+ outg = filter (\(v,f,t) -> f == st) @prods.allvisits+ visitlist = vlist $ map (\(v,f,t) ->+ @loc.k_type >|< "_v" >|< v >#< "::" >#< k_st >#< @loc.t_params >#< pp_parens (@loc.t_type >|< "_v" >|< v >#< @loc.t_params)+ ) outg+ nextVisit = Map.findWithDefault ManyVis st @nextVisits+ decl = "data" >#< k_st >#< "k" >#< @loc.t_params >#< "where" >-< indent 3 visitlist+ in case nextVisit of+ NoneVis -> empty+ OneVis _ -> empty+ ManyVis -> decl+ ) $ Set.toList @loc.allstates++-- type of a visit v, with continuation as new state s+ATTR Visit Visits EProduction EProductions [ | | t_visits USE {>-<} {empty} : {PP_Doc} ]++SEM EProductions+ | Cons lhs.t_visits = @hd.t_visits -- just pick the first production++SEM Visit+ | Visit loc.nameT_visit = conNmTVisit @lhs.nt @ident+ loc.nameTIn_visit = conNmTVisitIn @lhs.nt @ident+ loc.nameTOut_visit = conNmTVisitOut @lhs.nt @ident+ loc.nameTNext_visit = conNmTNextVisit @lhs.nt @to++ loc.nextVisitInfo = Map.findWithDefault ManyVis @to @lhs.nextVisits -- which visits can we do after we reach the @to state?+ loc.typecon = case @kind of+ VisitPure _ -> empty+ VisitMonadic -> ppMonadType @lhs.options++ loc.t_params = ppSpaced @lhs.params+ lhs.t_visits = "type" >#< @loc.nameT_visit >#< @loc.t_params >#< "=" >#<+ pp_parens (@loc.nameTIn_visit >#< @loc.t_params)+ >#< ( if dummyTokenVisit @lhs.options+ then "->" >#< dummyType @lhs.options True -- Additional (unused though) argument+ else empty+ )+ >#< "->" >#< @loc.typecon >#< pp_parens (@loc.nameTOut_visit >#< @loc.t_params)+ >-< "data" >#< @loc.nameTIn_visit >#< @loc.t_params >#< "=" >#< @loc.nameTIn_visit >#<+ @loc.inhpart+ >-< "data" >#< @loc.nameTOut_visit >#< @loc.t_params >#< "=" >#< @loc.nameTOut_visit >#<+ @loc.synpart >#< case @loc.nextVisitInfo of+ NoneVis -> empty -- don't return a continuation at all+ _ -> @loc.addbang1 $ pp_parens (@loc.nameTNext_visit >#< @loc.t_params) -- normal route: select the next semantics+ loc.inhpart = @loc.ppTypeList @inh @lhs.inhmap+ loc.synpart = @loc.ppTypeList @syn @lhs.synmap+ loc.ppTypeList = \s m -> ppSpaced $ map (\i -> @loc.addbang1 $ pp_parens $ case Map.lookup i m of+ Just tp -> ppTp tp ) $ Set.toList s++{+conNmTVisit nt vId = "T_" >|< nt >|< "_v" >|< vId+conNmTVisitIn nt vId = "T_" >|< nt >|< "_vIn" >|< vId+conNmTVisitOut nt vId = "T_" >|< nt >|< "_vOut" >|< vId+conNmTNextVisit nt stId = "T_" >|< nt >|< "_s" >|< stId++ppMonadType :: Options -> PP_Doc+ppMonadType opts+ | parallelInvoke opts = text "IO"+ | otherwise = text "Identity"+}++-------------------------------------------------------------------------------+-- Inh and Syn wrappers+-------------------------------------------------------------------------------+SEM ENonterminal+ | ENonterminal loc.wr_inh = @loc.genwrap "Inh" @loc.wr_inhs+ loc.wr_syn = @loc.genwrap "Syn" @loc.wr_syns+ loc.genwrap = \nm attr -> "data" >#< nm >|< "_" >|< @nt >#< @loc.t_params >#< "=" >#< nm >|< "_" >|< @nt >#< "{"+ >#< (ppCommas $ map (\(i,t) -> i >|< "_" >|< nm >|< "_" >|< @nt >#< "::"+ >#< (@loc.addbang $ pp_parens $ typeToHaskellString (Just @nt) [] t)) attr) >#< "}"+ loc.synAttrs = fromJust $ Map.lookup @nt @lhs.inhmap+ loc.wr_inhs = Map.toList $ @loc.wr_filter $ @loc.synAttrs+ loc.wr_inhs1 = Map.toList @loc.synAttrs+ loc.wr_filter = if kennedyWarren @lhs.options && lateHigherOrderBinding @lhs.options+ then Map.delete idLateBindingAttr+ else id+ loc.wr_syns = Map.toList $ fromJust $ Map.lookup @nt @lhs.synmap+ loc.inhlist = map (lhsname True . fst) @loc.wr_inhs+ loc.inhlist1 = map (lhsname True . fst) @loc.wr_inhs1+ loc.synlist = map (lhsname False . fst) @loc.wr_syns+ loc.wrapname = "wrap_" ++ show @nt+ loc.inhname = "Inh_" ++ show @nt+ loc.synname = "Syn_" ++ show @nt+ loc.firstVisitInfo = Map.findWithDefault ManyVis @initial @nextVisits+ loc.wrapper = @loc.wrapPragma+ >-< (@loc.wrapname >#< "::" >#< @loc.quantPP >#< @loc.classPP >#< @loc.t_type >#< @loc.t_params >#< "->"+ >#< @loc.inhname >#< @loc.t_params >#< "->" >#< ( if monadicWrappers @lhs.options then ppMonadType @lhs.options else empty) >#< pp_parens (@loc.synname >#< @loc.t_params))+ >-< (@loc.wrapname >#< (@loc.addbang $ pp_parens (@loc.t_type >#< pp "act"))+ >#< (@loc.addbang $ pp_parens (@loc.inhname+ >#< (ppSpaced $ map (@loc.addbangWrap . pp) @loc.inhlist)) >#< "="))+ >-<+ indent 3 (case @initialv of+ -- case where there are no inherited or synthesized attributes+ Nothing -> @loc.synname >#< " { }"+ Just initv ->+ let inCon = conNmTVisitIn @nt initv+ outCon = conNmTVisitOut @nt initv+ pat = @loc.addbang $ pp_parens $ pat0+ pat0 = outCon >#< ppSpaced @loc.synlist -- should be an "end" state, thus no continuation expected here+ arg = inCon >#< ppSpaced @loc.inhlist1+ ind = case @loc.firstVisitInfo of+ NoneVis -> error "wrapper: initial state should have a next visit but it has none"+ OneVis _ -> empty+ ManyVis -> @loc.k_type >|< "_v" >|< initv+ extra = if dummyTokenVisit @lhs.options+ then pp $ dummyArg @lhs.options True+ else empty+ convert = case Map.lookup initv @lhs.allVisitKinds of+ Just kind -> case kind of+ VisitPure _ -> text "return"+ VisitMonadic -> empty+ unMonad | monadicWrappers @lhs.options = empty+ | otherwise = unMon @lhs.options+ in unMonad >#< "("+ >-< indent 2 (+ "do" >#< ( @loc.addbang (pp "sem") >#< "<-" >#< "act" -- run the per-node monadic code to get the initial state (of the root)+ >-< "let" >#< @loc.addbangWrap (pp "arg") >#< "=" >#< arg+ >-< pat >#< "<-" >#< convert >#< pp_parens ("inv_" >|< @nt >|< "_s" >|< @initial >#< "sem" >#< ind >#< "arg" >#< extra) -- invoke initial state (of the root)+ >-< "return" >#< pp_parens (@loc.synname >#< ppSpaced @loc.synlist)+ )+ )+ >-< ")" )+ >-< if kennedyWarren @lhs.options && lateHigherOrderBinding @lhs.options+ then indent 2 ("where" >#< lhsname True idLateBindingAttr >#< "=" >#< lateBindingFieldNm @lhs.mainName)+ else empty+ loc.wrapPragma = if parallelInvoke @lhs.options && not (monadicWrappers @lhs.options)+ then ppNoInline @loc.wrapname -- required for the use of unsafePerformIO in case of the IO monad+ else if noInlinePragmas @lhs.options+ then empty+ else ppInlinable @loc.wrapname -- ensure that the wrapper is exposed as inlinable++-------------------------------------------------------------------------------+-- Collection of NT / Production sem funs references+-------------------------------------------------------------------------------++ATTR ENonterminals ENonterminal EProductions EProduction [ | | semFunBndDefs, semFunBndTps USE {Seq.><} {Seq.empty} : {Seq PP_Doc} ]+SEM ENonterminal | ENonterminal+ lhs.semFunBndDefs = @loc.semFunBndDef Seq.<| @prods.semFunBndDefs+ lhs.semFunBndTps = @loc.semFunBndTp Seq.<| @prods.semFunBndTps+ loc.semFunBndDef = @loc.semFunBndNm >#< "=" >#< @loc.semname+ loc.semFunBndTp = @loc.semFunBndNm >#< "::" >#< @loc.sem_tp+ loc.semFunBndNm = lateSemNtLabel @nt++SEM EProduction | EProduction+ lhs.semFunBndDefs = Seq.singleton @loc.semFunBndDef+ lhs.semFunBndTps = Seq.singleton @loc.semFunBndTp+ loc.semFunBndDef = @loc.semFunBndNm >#< "=" >#< @loc.semname+ loc.semFunBndTp = @loc.semFunBndNm >#< "::" >#< @loc.sem_tp+ loc.semFunBndNm = lateSemConLabel @lhs.nt @con++-- Generate a dictionary that contains the semantics of all semantic functions+SEM ExecutionPlan | ExecutionPlan+ loc.wrappersExtra = if kennedyWarren @lhs.options && lateHigherOrderBinding @lhs.options+ then @loc.lateSemBndDef+ else empty+ loc.commonExtra = if kennedyWarren @lhs.options && lateHigherOrderBinding @lhs.options+ then @loc.lateSemBndTp+ else empty+ loc.lateSemBndTp = "data" >#< lateBindingTypeNm @lhs.mainName >#< "=" >#< lateBindingTypeNm @lhs.mainName+ >-< (indent 2 $ pp_block "{" "}" "," $ toList @nonts.semFunBndTps)+ loc.lateSemBndDef = ( if noInlinePragmas @lhs.options+ then empty+ else if helpInlining @lhs.options && Set.size @wrappers == 1+ then ppInline $ lateBindingFieldNm @lhs.mainName -- inline in the single wrapper+ else ppNoInline $ lateBindingFieldNm @lhs.mainName+ )+ >-< lateBindingFieldNm @lhs.mainName >#< "::" >#< lateBindingTypeNm @lhs.mainName+ >-< lateBindingFieldNm @lhs.mainName >#< "=" >#< lateBindingTypeNm @lhs.mainName+ >-< (indent 2 $ pp_block "{" "}" "," $ toList @nonts.semFunBndDefs )++-------------------------------------------------------------------------------+-- Production semantic functions+-------------------------------------------------------------------------------+ATTR EProduction [ | | sem_prod : {PP_Doc} ]+ATTR EProductions [ | | sem_prod USE {>-<} {empty} : {PP_Doc} ]++ATTR EProduction EProductions [ initial : {StateIdentifier}+ allstates : {Set StateIdentifier} | | ]+SEM ENonterminal+ | ENonterminal prods.initial = @initial+ prods.allstates = @loc.allstates++ATTR EChild [ | | argtps : { PP_Doc }+ argpats : { PP_Doc } ]+ATTR EChildren [ | | argtps USE {:} {[]} : { [PP_Doc] }+ argpats USE {:} {[]} : { [PP_Doc] } ]++SEM EChild+ | EChild lhs.argtps = case @kind of+ ChildSyntax -> ppDefor @tp >#< "->"+ ChildReplace tp -> ppDefor tp >#< "->"+ _ -> empty -- higher order attribute+ loc.argpats = case @kind of+ ChildSyntax -> "field_" >|< @name -- no strictification of children semantics to allow infinite trees+ ChildReplace _ -> "field_" >|< @name+ _ -> empty+ | ETerm lhs.argtps = (pp_parens $ show @tp) >#< "->"+ loc.argpats = @loc.addbang $ text $ locname @name -- terminals may be strict (perhaps this should become an option)++{+ppDefor :: Type -> PP_Doc+ppDefor (NT nt args _) = "T_" >|< nt >#< ppSpaced (map pp_parens args)+ppDefor (Haskell s) = text s+}++SEM EProduction+ | EProduction loc.t_type = "T_" >|< @lhs.nt+ loc.t_params = ppSpaced @lhs.params+ loc.args = @children.argpats+ loc.semname = "sem_" ++ show @lhs.nt ++ "_" ++ show @con+ loc.sem_tp = @loc.quantPP2 >#< @loc.classPP2 >#< ppSpaced @children.argtps >#< @loc.t_type >#< @loc.t_params+ loc.classPP2 = ppClasses (classCtxsToDocs @lhs.classCtxs ++ classConstrsToDocs @constraints)+ loc.quantPP2 = ppQuants (@lhs.params ++ @params)+ loc.sem_prod = @loc.semInlinePragma+ >-< @loc.semname >#< "::" >#< @loc.sem_tp+ >-< @loc.mkSemBody (@loc.semname >#< ppSpaced @loc.args >#< "=" >#< @loc.scc >#< @loc.t_type)+ @loc.mbInitializer @loc.outerlet ("return" >#< "st" >|< @lhs.initial)+ loc.mkSemBody = \prefix mbInit outerlet ret ->+ case mbInit of+ Nothing -> prefix >#< pp_parens ret >#< "where"+ >-< indent 3 outerlet -- code for states and visits+ Just m -> prefix >#< "(" >#< "do"+ >-< indent 1 (+ m+ >-< "let"+ >-< indent 2 outerlet -- code for the states and visits+ >-< ret )+ >-< indent 1 ")"++ loc.mbInitializer = --some monadic actions, performed upon attaching a child, can+ -- be specified here. The resulting bindings of these actions are+ -- in scope of the rules of the production+ if parallelInvoke @lhs.options+ then (Nothing :: Maybe PP_Doc) -- perhaps do some per-node registation, etc. For now: nothing+ else Nothing -- nothing special here+ loc.scc = if genCostCentres @lhs.options+ then ppCostCentre @loc.semname+ else empty+ loc.semInlinePragma = if noInlinePragmas @lhs.options+ then empty+ else ppNoInline @loc.semname -- prevent the semantic functions of constructors to be inlined (e.g. in the nt sem-funs)+ loc.outerlet = vlist @loc.statefns >-< @rules.sem_rules+ loc.statefns = map @loc.genstfn $ Set.toList @lhs.allstates+ loc.genstfn = \st -> let nextVisitInfo = Map.findWithDefault ManyVis st @lhs.nextVisits+ prevVisitInfo = Map.findWithDefault ManyVis st @lhs.prevVisits+ stNm = "st" >|< st+ lhs = pragma >-< bang stNm >#< "=" >#<+ ( -- generating a lambda for the same reasons as generating+ -- a lambda for rules: to ensure that overloading is+ -- resolved for all visit functions and rules together.+ if st == @lhs.initial+ then empty+ else "\\" >#< @loc.stargs st >#< "->"+ )++ pragma = if noInlinePragmas @lhs.options+ then empty+ else if helpInlining @lhs.options+ then case prevVisitInfo of+ ManyVis -> ppNoInline stNm+ OneVis _ -> if aggressiveInlinePragmas @lhs.options+ then ppInline stNm+ else ppInlinable stNm+ NoneVis -> if st /= @lhs.initial+ then error ("State " ++ show st ++ " is not reachable from the initial state.")+ else if aggressiveInlinePragmas @lhs.options+ then ppInline stNm -- first state can be inlined+ else ppInlinable stNm+ else ppNoInline stNm+ cCon = "C_" >|< @lhs.nt >|< "_s" >|< st+ bang | st == @lhs.initial = @loc.addbang -- initial state is not parameterized+ | otherwise = id++ -- note about the initial state: the initial state should be the only+ -- state-binding that is not a function. It is non-recursive and not needed+ -- anywhere except delivered as initial result. This binding therefore does+ -- not end up needlessly in any closure.+ in case nextVisitInfo of+ NoneVis -> -- the (empty) closure of a (non-initial) end state is not referenced+ -- thus generating it is not needed (and omitting it may catch some small mistakes).+ if st == @lhs.initial+ then lhs >#< cCon -- empty state+ else empty -- no state generated+ OneVis vId -> mklet lhs (@loc.stvs st False) (cCon >#< "v" >|< vId)+ ManyVis -> mklet lhs (@loc.stks st >-< @loc.stvs st True) (cCon >#< "k" >|< st)+ loc.stargs = \st -> let attrs = maybe Map.empty id $ Map.lookup st @visits.intramap+ in ppSpaced [ let match | str `Set.member` @loc.lazyIntras = pp str+ | otherwise = @loc.addbang (pp str)+ in case mbAttr of+ Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) ->+ case Map.lookup nm @loc.localAttrTypes of+ Just tp -> pp_parens (pp_parens match >#< "::" >#< ppTp tp)+ Nothing -> match+ Just attr | not (noPerStateTypeSigs @lhs.options) ->+ case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @loc.childTypes of+ Just tpDoc -> pp_parens (pp_parens match >#< "::" >#< tpDoc)+ Nothing -> match+ _ -> match+ | (str,mbAttr) <- Map.assocs attrs+ ] >#< dummyPat @lhs.options (Map.null attrs)++ loc.stks = \st -> if null (@loc.stvisits st)+ then empty+ else ( if not (noInlinePragmas @lhs.options) && helpInlining @lhs.options+ then ppNoInline ("k" >|< st)+ else empty+ )+ >-< "k" >|< st >#< "::" >#< "K_" >|< @lhs.nt >|< "_s" >|< st >#< "t" >#< "->" >#< "t"+ >-< vlist (map (\(v,f,t) -> "k" >|< st >#< "K_" >|< @lhs.nt >|< "_v" >|< v >#< "="+ >#< "v" >|< v) $ @loc.stvisits st)+ loc.stvisits = \st -> filter (\(v,f,t) -> f == st) @visits.allvisits+ loc.stvs = \st inlinePragma -> vlist [ppf inlinePragma | (f,ppf) <- @visits.sem_visit, f == st]+ visits.mrules = @rules.mrules++{+mklet :: (PP a, PP b, PP c) => a -> b -> c -> PP_Doc+mklet prefix defs body =+ prefix >#< "let"+ >-< indent 3 defs+ >-< indent 2 "in" >#< body+}++-------------------------------------------------------------------------------+-- Visit semantic functions+-------------------------------------------------------------------------------+ATTR Visit [ | | sem_visit : { (StateIdentifier,Bool -> PP_Doc) } ]+ATTR Visits [ | | sem_visit USE {:} {[]} : { [(StateIdentifier,Bool -> PP_Doc)] } ]++SEM Visit+ | Visit lhs.sem_visit = ( @from+ , \addInlinePragma ->+ ( if noInlinePragmas @lhs.options+ then empty+ else if addInlinePragma && aggressiveInlinePragmas @lhs.options+ then ppInline @loc.vname+ else if helpInlining @lhs.options+ then ppNoInline @loc.vname+ else empty+ )+ >-< "v" >|< @ident >#< "::" >#< @loc.nameT_visit >#< @loc.t_params++ -- generate a lambda here as well instead of a function definition+ >-< "v" >|< @ident >#< "=" >#< "\\" >#< (@loc.addbang $ pp_parens (@loc.nameTIn_visit >#< @loc.inhpats))+ >#< ( if dummyTokenVisit @lhs.options+ then pp $ dummyPat @lhs.options True -- extra (but unused) argument+ else empty+ )+ >#< "->"+ >#< ( if genCostCentres @lhs.options+ then ppCostCentre (@loc.vname >|< "_" >|< @lhs.nt >|< "_" >|< @lhs.con)+ else empty+ ) >#< "(" >#< @loc.stepsInitial+ >-< indent 3 (@steps.sem_steps >-< @loc.stepsClosing >#< ")")+ )+ loc.stepsInitial = case @kind of+ VisitPure False -> text "let"+ VisitPure True -> empty+ VisitMonadic -> text "do"+ loc.stepsClosing = let decls = @loc.nextStBuild+ >-< @loc.addbang (pp resultValName) >#< "=" >#< @loc.resultval+ in case @kind of+ VisitPure False -> decls+ >-< "in" >#< resultValName+ VisitPure True -> "let" >#< decls+ >-< indent 1 ("in" >#< resultValName)+ VisitMonadic -> "let" >#< decls+ >-< "return" >#< resultValName+ loc.vname = "v" >|< @ident+ loc.inhpats = ppSpaced $ map (\arg -> @loc.addbang $ pp $ attrname True _LHS arg) $ Set.toList @inh+ loc.inhargs = \chn -> ppSpaced $ map (attrname False chn) $ Set.toList @inh+ loc.synargs = ppSpaced $ map (\arg -> attrname False _LHS arg) $ Set.toList @syn+ loc.nextargsMp = maybe Map.empty id $ Map.lookup @to @lhs.allintramap+ loc.nextargs = ppSpaced $ Map.keys $ @loc.nextargsMp+ loc.nextst = "st" >|< @to >#< @loc.nextargs >#< dummyArg @lhs.options (Map.null @loc.nextargsMp)+ loc.resultval = @loc.nameTOut_visit >#< @loc.synargs >#< @loc.nextStRef+ (loc.nextStBuild, loc.nextStRef)+ = case @loc.nextVisitInfo of+ NoneVis -> (empty, empty)+ _ -> (@loc.addbang (pp nextStName) >#< "=" >#< @loc.nextst, pp nextStName)++{+resultValName :: String+resultValName = "__result_"++nextStName :: String+nextStName = "__st_"+}++-- Propagate the visit kind to the steps+ATTR VisitStep VisitSteps [ kind : VisitKind | | ]+SEM Visit | Visit steps.kind = @kind++-- the steps in this group should be executed in a pure fashion+SEM VisitStep | PureGroup+ steps.kind = VisitPure @ordered++ATTR Visits Visit VisitStep VisitSteps [ mrules : {Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)} | | ]+ATTR VisitStep VisitSteps [ | | sem_steps USE {>-<} {empty} : {PP_Doc} ]+SEM VisitStep+ | Sem loc.ruleItf = Map.findWithDefault (error $ "Rule " ++ show @name ++ " not found") @name @lhs.mrules+ (lhs.errors, loc.sem_steps) = case @loc.ruleItf @lhs.kind @lhs.fmtMode of+ Left e -> (Seq.singleton e, empty)+ Right stmt -> (Seq.empty, stmt)+ | ChildIntro loc.attachItf = Map.findWithDefault (error $ "Child " ++ show @child ++ " not found") @child @lhs.childintros+ (lhs.errors,lhs.sem_steps,lhs.defs,lhs.uses)+ = case @loc.attachItf @lhs.kind @lhs.fmtMode of+ Left e -> (Seq.singleton e, empty, Set.empty, Map.empty)+ Right (code, defs, uses) -> (Seq.empty, code, defs, uses)+ | ChildVisit loc.visitItf = Map.findWithDefault (error $ "Visit " ++ show @visit ++ " not found") @visit @lhs.allchildvisit+ (lhs.errors, loc.patPP, loc.exprPP) = case @loc.visitItf @child @lhs.kind of+ Left e -> (Seq.singleton e, empty, empty)+ Right (pat,expr) -> (Seq.empty, pat, expr)++ loc.useParallel = @lhs.useParallel && not @lhs.isLast+ lhs.sem_steps = if @loc.useParallel -- assumes to be in a monadic do-expression+ then @loc.addbang ("sync_" >|< @lhs.index) >#< "<- newEmptyMVar"+ >-< "forkIO" >#< pp_parens (@loc.convToMonad >#< pp_parens @loc.exprPP >#< ">>= \\" >#< @loc.addbang (pp parResultName) >#< " -> putMVar sync_" >|< @lhs.index >#< parResultName) -- parResultName is guaranteed to be evaluated+ else let decl = case @lhs.kind of+ VisitPure _ -> @loc.patPP >#< "=" >#< @loc.exprPP+ VisitMonadic -> @loc.patPP >#< "<-" >#< @loc.exprPP+ in fmtDecl False @lhs.fmtMode decl+ loc.convToMonad = case @loc.callKind of+ VisitPure _ -> text "return"+ VisitMonadic -> empty+ loc.callKind = Map.findWithDefault (error "visit kind should be in the map") @visit @lhs.allVisitKinds+ | Sim lhs.sem_steps = @steps.sem_steps >-< @steps.sync_steps+ | PureGroup lhs.sem_steps = case @lhs.fmtMode of+ FormatDo -> "let" >#< @steps.sem_steps -- formatted as a let-block (not a line-let)+ _ -> @steps.sem_steps++ATTR VisitSteps VisitStep [ | | sync_steps USE {>-<} {empty} : {PP_Doc} ]+SEM VisitStep | ChildVisit+ lhs.sync_steps = if @loc.useParallel+ then @loc.patPP >#< "<-" >#< "takeMVar sync_" >|< @lhs.index+ else empty++-- The fmtMode indicates in what kind of expression (do/let/line-lets) we are printing+-- declarations, because that determines how we need to wrap declarations+-- Invariant: @lhs.kind == VisitMonadic ---> @lhs.fmtMode == FormatDo+ATTR VisitSteps VisitStep [ fmtMode : FormatMode | | ]+SEM Visit | Visit+ steps.fmtMode = case @kind of+ VisitPure False -> FormatLetDecl+ VisitPure True -> FormatLetLine+ VisitMonadic -> FormatDo++SEM VisitStep | PureGroup+ steps.fmtMode = case @lhs.fmtMode of+ FormatDo -> FormatLetDecl+ mode -> mode++{+parResultName :: String+parResultName = "__outcome_"++fmtDecl :: PP a => Bool -> FormatMode -> a -> PP_Doc+fmtDecl declPure fmt decl = case fmt of+ FormatLetDecl -> pp decl+ FormatLetLine -> "let" >#< decl >#< "in"+ FormatDo | declPure -> "let" >#< decl+ | otherwise -> pp decl+}++--+-- Some properties of VisitStep(s)+--++-- Number of steps in a 'Sim' block+ATTR VisitSteps [ | | size : Int ]+SEM VisitSteps+ | Nil lhs.size = 0+ | Cons lhs.size = 1 + @tl.size++-- Number the steps in a 'Sim' block+ATTR VisitSteps VisitStep [ | index : Int | ]+SEM VisitSteps | Cons+ hd.index = @lhs.index -- copy rule+ tl.index = 1 + @lhs.index+ lhs.index = @tl.index -- copy rule+SEM Visit | Visit steps.index = 0+SEM VisitStep | Sim steps.index = 0+ lhs.index = @lhs.index -- needed for if we ever allow nested Sims++-- Biggest number of steps in previous blocks that used parallel invocation+-- This number - 1 (minimum 0) is the number of references for parallel invocation created+ATTR VisitSteps VisitStep [ | prevMaxSimRefs : Int | ]+SEM Visit | Visit steps.prevMaxSimRefs = 0+SEM VisitStep | Sim+ lhs.prevMaxSimRefs = if @loc.useParallel+ then @lhs.prevMaxSimRefs `max` (@steps.index - 1) -- possibly new references made+ else @lhs.prevMaxSimRefs -- no references created++-- Is this the last step?+ATTR VisitSteps VisitStep [ | | isLast : Bool ]+ATTR VisitStep [ isLast : Bool | | ]+SEM VisitSteps+ | Nil lhs.isLast = True+ | Cons lhs.isLast = False+ hd.isLast = @tl.isLast++-- Use parallel invocation: only when option enabled and there is more than one visit to a child+SEM VisitSteps VisitStep [ useParallel : Bool | | ]+SEM Visit | Visit steps.useParallel = False+SEM VisitStep | Sim loc.useParallel = parallelInvoke @lhs.options && @steps.size > 1 && @loc.isMonadic+ loc.isMonadic = case @lhs.kind of+ VisitMonadic -> True+ _ -> False+++-- Child introduction+ATTR EChild EChildren [ | | childintros USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} ]++ATTR Visits Visit+ VisitSteps VisitStep [ childintros : {Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} | | ]++SEM EProduction+ | EProduction visits.childintros = @children.childintros++SEM EChild+ | EChild lhs.childintros = Map.singleton @name @loc.introcode+ loc.isDefor = case @tp of+ NT _ _ defor -> defor+ _ -> False+ loc.valcode = case @kind of+ ChildSyntax -> "field_" >|< @name+ ChildAttr -> -- decide if we need to invoke the sem-function under the hood+ let prefix | not @loc.isDefor = if lateHigherOrderBinding @lhs.options -- && sepsemmods @lhs.options -- when sepsemmods is not enabled, the indirection can be optimized away+ then lateSemNtLabel @loc.nt >#< lhsname True idLateBindingAttr+ else "sem_" >|< @loc.nt+ | otherwise = empty -- no need to intro a terminal+ in pp_parens (prefix >#< instname @name)+ ChildReplace _ -> -- the higher-order attribute is actually a function that transforms+ -- the semantics of the child (always deforested)+ pp_parens (instname @name >#< "field_" >|< @name)+ loc.aroundcode = if @hasAround+ then locname @name >|< "_around"+ else empty+ loc.introcode = \kind fmtMode ->+ let pat = text $ stname @name @loc.initSt+ patStrict = @loc.addbang pat+ attach = "attach_T_" >|< @loc.nt >#< pp_parens (@loc.aroundcode >#< @loc.valcode)+ runAttach = unMon @lhs.options >#< pp_parens attach+ decl = case kind of+ VisitPure False -> pat >#< "=" >#< runAttach+ VisitPure True -> patStrict >#< "=" >#< runAttach+ VisitMonadic -> patStrict >#< "<-" >#< attach+ in if compatibleAttach kind @loc.nt @lhs.options+ then Right ( fmtDecl False fmtMode decl+ , Set.singleton (stname @name @loc.initSt) -- variables defined by the child intro+ , case @kind of -- variables used by the child introduction+ ChildAttr -> Map.insert (instname @name) Nothing $ -- the sem attr+ ( if @loc.isDefor || not (lateHigherOrderBinding @lhs.options)+ then id -- the sem dictionary attr is not used+ else Map.insert (lhsname True idLateBindingAttr) (Just $ AttrInh _LHS idLateBindingAttr)+ ) $+ ( if @hasAround+ then Map.insert (locname (@name) ++ "_around") Nothing+ else id+ ) $ Map.empty+ ChildReplace _ -> Map.singleton (instname @name) Nothing -- uses the transformation function+ ChildSyntax -> Map.empty+ )+ else Left $ IncompatibleAttachKind @name kind+ loc.nt = extractNonterminal @tp++{+stname :: Identifier -> Int -> String+stname child st = "_" ++ getName child ++ "X" ++ show st++-- should actually return some conversion info+compatibleAttach :: VisitKind -> NontermIdent -> Options -> Bool+compatibleAttach _ _ _ = True++unMon :: Options -> PP_Doc+unMon options+ | parallelInvoke options = text "System.IO.Unsafe.unsafePerformIO" -- IO monad+ | otherwise = text "Control.Monad.Identity.runIdentity" -- identity monad+}++-- rules+ATTR ERules ERule [ | | sem_rules USE {>-<} {empty} : {PP_Doc}+ mrules USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)} ]++SEM ERule | ERule+ lhs.sem_rules = if @loc.used == 0+ then empty+ else @loc.rulePragma >-< @loc.rulecode+ loc.rulecode = ( if @loc.genpragma+ then @loc.pragma -- this additional pragma *may* help to give some AG source location in the presence of+ -- type errors in the rule. It will definitely not be precise, and may take some additional+ -- source space, but let's see if it's worth it in practice.+ else empty+ )+ >-< @loc.lambda >#< @loc.scc+ >-< indent ((column @rhs.pos - 2) `max` 2)+ ( if @loc.genpragma+ then @loc.pragma >-< @rhs.semfunc >-< @loc.endpragma+ else @rhs.semfunc+ )+ loc.rulePragma = ( let reallyInlineStr = "INLINE"+ reallyNoInlineStr = "NOINLINE"+ in if noInlinePragmas @lhs.options+ then empty+ else if @loc.used == 1+ then ppPragmaBinding reallyInlineStr @name -- always inline if used exactly once+ else if helpInlining @lhs.options+ then if not @explicit && @loc.used <= reallyOftenUsedThreshold+ then ppPragmaBinding "INLINE[1]" @name -- inline if copy rule+ else if @loc.used > ruleInlineThresholdSoft && @explicit -- noinline if it passes the threshold and is not a copy rule+ then if @loc.used > ruleInlineThresholdHard+ then ppPragmaBinding reallyNoInlineStr @name -- used too often: force ghc not to inline it+ else if aggressiveInlinePragmas @lhs.options+ then ppPragmaBinding "NOINLINE[2]" @name -- allow inlining but only late in the process+ else ppNoInline @name+ else if aggressiveInlinePragmas @lhs.options+ then ppPragmaBinding "NOINLINE[1]" @name -- otherwise, let GHC decide (but do other inlining first)+ else ppNoInline @name+ else if not @explicit || @loc.used <= ruleInlineThresholdSoft+ then ppPragmaBinding "NOINLINE[1]" @name -- otherwise, let GHC decide (but do other inlining first)+ else ppNoInline @name+ )+ loc.scc = if genCostCentres @lhs.options && @explicit && @pure && not (noPerRuleCostCentres @lhs.options)+ then ppCostCentre (@name >|< "_" >|< line @rhs.pos >|< "_" >|< @lhs.nt >|< "_" >|< @lhs.con)+ else empty+ loc.pragma = "{-# LINE" >#< show (line @rhs.pos) >#< show (file @rhs.pos) >#< "#-}"+ loc.endpragma = ppWithLineNr (\ln -> "{-# LINE " ++ show (ln+1) ++ " " ++ show @lhs.mainFile ++ "#-}")+ loc.genpragma = genLinePragmas @lhs.options && @explicit && @loc.haspos+ loc.haspos = line @rhs.pos > 0 && column @rhs.pos >= 0 && not (null (file @rhs.pos))++ -- we generate a simple pattern binding because of overloading-resolving during the type inference process.+ -- The types of the rules are not generalized (nor do we want that - rules are used in a single typing-context).+ -- If overloading is resolved separately, it may not be clear which dictionaries to use. For that all rules have+ -- to be considered together, which is done when we use simple pattern bindings with a lambda expression instead+ -- of a function definition.+ -- Note: we also ensure that all rules are lambda expressions, so that they are not made part of any closures+ -- but are lambda-lifted instead.+ loc.lambda = @name >#< "=" >#< "\\" >#< @loc.argPats >#< dummyPat @lhs.options (Map.null @rhs.attrs) >#< "->"++ loc.argPats = ppSpaced [ let match | str `Set.member` @lhs.lazyIntras = pp str+ | otherwise = @loc.addbang1 (pp str)+ in case mbAttr of+ Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) ->+ case Map.lookup nm @lhs.localAttrTypes of+ Just tp -> pp_parens (pp_parens match >#< "::" >#< ppTp tp)+ Nothing -> match+ Just attr | not (noPerRuleTypeSigs @lhs.options) ->+ case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @lhs.childTypes of+ Just tpDoc -> pp_parens (pp_parens match >#< "::" >#< tpDoc)+ Nothing -> match+ _ -> match+ | (str,mbAttr) <- Map.assocs @rhs.attrs+ ]+ loc.argExprs = ppSpaced $ Map.keys @rhs.attrs+ loc.stepcode = \kind fmtMode -> if kind `compatibleRule` @pure+ then Right $ let oper | @pure = "="+ | otherwise = "<-"+ decl = @pattern.sem_lhs >#< oper >#< @name >#< @loc.argExprs >#< dummyArg @lhs.options (Map.null @rhs.attrs)+ in fmtDecl @pure fmtMode decl+ else Left $ IncompatibleRuleKind @name kind++ lhs.mrules = Map.singleton @name @loc.stepcode++{+dummyPat :: Options -> Bool -> PP_Doc+dummyPat opts noArgs+ | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples+ | tupleAsDummyToken opts = if strictDummyToken opts+ then text "()"+ else text "(_ :: ())"+ | otherwise = let match | strictDummyToken opts = "!_"+ | otherwise = "_"+ in pp_parens (match >#< "::" >#< dummyType opts noArgs)+ where match | strictDummyToken opts = "(!_)"+ | otherwise = "_"++dummyArg :: Options -> Bool -> PP_Doc+dummyArg opts noArgs+ | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples+ | tupleAsDummyToken opts = text "()"+ | otherwise = text "GHC.Prim.realWorld#"++dummyType :: Options -> Bool -> PP_Doc+dummyType opts noArgs+ | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples+ | tupleAsDummyToken opts = text "()"+ | otherwise = text "(GHC.Prim.State# GHC.Prim.RealWorld)"+}++{+-- rules are "deinlined" to prevent needless code duplication.+-- if there is only a bit of duplication, we allow ghc to decide if it is worth it.+-- if the duplication crosses this threshold, however, we tell ghc definitely not to inline it.+ruleInlineThresholdSoft :: Int+ruleInlineThresholdSoft = 3++ruleInlineThresholdHard :: Int+ruleInlineThresholdHard = 5++reallyOftenUsedThreshold :: Int+reallyOftenUsedThreshold = 12+}++ATTR Expression [ | | pos : {Pos} ]+SEM Expression | Expression lhs.pos = @pos++-- pattern and expression semantics+ATTR Pattern [ | | sem_lhs : { PP_Doc } ]+ATTR Patterns [ | | sem_lhs USE {:} {[]} : {[PP_Doc]} ]+ATTR Pattern Patterns [ | | ]++SEM Pattern+ | Alias loc.varPat = text $ attrname False @field @attr+ loc.patExpr = if @pat.isUnderscore+ then @loc.varPat+ else @loc.varPat >|< "@" >|< @pat.sem_lhs+ lhs.sem_lhs = @loc.addbang1 @loc.patExpr+ | Product lhs.sem_lhs = @loc.addbang1 $ pp_block "(" ")" "," @pats.sem_lhs+ | Constr lhs.sem_lhs = @loc.addbang1 $ pp_parens $ @name >#< hv_sp @pats.sem_lhs+ | Underscore lhs.sem_lhs = text "_"+ | Irrefutable lhs.sem_lhs = text "~" >|< pp_parens @pat.sem_lhs++-- Check if a pattern is just an underscore+ATTR Pattern [ | | isUnderscore:{Bool}]+SEM Pattern+ | Constr lhs.isUnderscore = False+ | Product lhs.isUnderscore = False+ | Alias lhs.isUnderscore = False+ | Underscore lhs.isUnderscore = True++-- Collect the attributes defined by a pattern+ATTR Pattern Patterns [ | | attrs USE {`Set.union`} {Set.empty} : {Set String} ]+SEM Pattern | Alias+ lhs.attrs = Set.insert (attrname False @field @attr) @pat.attrs++-- Collect the attributes used by the right-hand side+ATTR HsToken Expression [ | | attrs USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ]+SEM HsToken+ | AGLocal lhs.attrs = Map.singleton (locname @var) Nothing+ | AGField loc.mbAttr = if @field == _INST || @field == _FIELD || @field == _INST'+ then Nothing -- should not be used in the first place+ else Just $ mkNonLocalAttr (@field == _LHS) @field @attr+ lhs.attrs = Map.singleton (attrname True @field @attr) @loc.mbAttr++{+data NonLocalAttr+ = AttrInh Identifier Identifier+ | AttrSyn Identifier Identifier++mkNonLocalAttr :: Bool -> Identifier -> Identifier -> NonLocalAttr+mkNonLocalAttr True = AttrInh -- True: inherited attr+mkNonLocalAttr False = AttrSyn++lookupAttrType :: NonLocalAttr -> Map Identifier Attributes -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc+lookupAttrType (AttrInh child name) inhs _ = lookupType child name inhs+lookupAttrType (AttrSyn child name) _ syns = lookupType child name syns++-- Note: if the child takes type parameters, the type of an attribute of this child may refer to these parameters. This means that+-- the actual type of the attribute needs to have its type parameters substituted with the actual type argument of the child.+-- However, for now we simply decide to return Nothing in this case, which skips the type annotation.+lookupType :: Identifier -> Identifier -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc+lookupType child name attrMp childMp+ | noParameters childTp = Just ppDoc+ | otherwise = Nothing+ where+ attrTp = Map.findWithDefault (error "lookupType: the attribute is not in the attrs of the child") name childAttrs+ childAttrs = Map.findWithDefault (error "lookupType: the attributes of the nonterm are not in the map") nonterm attrMp+ nonterm = extractNonterminal childTp+ childTp = Map.findWithDefault (error ("lookupType: the child " ++ show child ++ "is not in the appropriate map")) child childMp+ ppDoc = ppTp attrTp++noParameters :: Type -> Bool+noParameters (Haskell _) = True+noParameters (NT _ args _) = null args+}++ATTR Expression [ | | semfunc : {PP_Doc} ]++SEM Expression+ | Expression lhs.attrs = Map.unions $ map (\tok -> attrs_Syn_HsToken (wrap_HsToken (sem_HsToken tok) Inh_HsToken)) @tks+ lhs.semfunc = vlist $ showTokens $ map (\tok -> tok_Syn_HsToken (wrap_HsToken (sem_HsToken tok) Inh_HsToken)) @tks++-- child visit map+ATTR Visit+ Visits+ EProduction+ EProductions+ ENonterminal+ ENonterminals [ allchildvisit : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))}+ | | childvisit USE {`Map.union`} {Map.empty} : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} ]++ATTR VisitSteps VisitStep [ allchildvisit : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} | | ]++SEM ExecutionPlan+ | ExecutionPlan nonts.allchildvisit = @nonts.childvisit++SEM Visit+ | Visit+ loc.prevVisitInfo = Map.findWithDefault ManyVis @from @lhs.nextVisits+ lhs.childvisit = Map.singleton @ident @loc.invokecode+ loc.invokecode = \chn kind -> -- "chn" is the name of the child at the place of invocation, and "kind" the kind of the calling visit+ if kind `compatibleKind` @kind+ then Right $+ let pat | isLazyKind @kind = pat0+ | otherwise = @loc.addbang pat0+ pat0 = pp_parens pat1+ pat1 = @loc.nameTOut_visit >#< (ppSpaced $ map (attrname True chn) $ Set.toList @syn)+ >#< cont+ cont = case @loc.nextVisitInfo of+ NoneVis -> empty+ _ -> ch1+ ch0 = text $ stname chn @from+ ch1 = text $ stname chn @to+ expr = case (kind, @kind) of+ (VisitPure _, VisitPure _) -> expr0+ (VisitPure _, VisitMonadic) -> unMon @lhs.options >#< expr0+ (VisitMonadic, VisitPure _) -> "return" >#< expr0+ (VisitMonadic, VisitMonadic) -> expr0+ expr0 = case @loc.prevVisitInfo of+ NoneVis -> error "error: invocation of a visit from a state that has no next visits"+ OneVis _ -> "inv_" >|< @lhs.nt >|< "_s" >|< @from >#< ch0 >#< args+ ManyVis -> "inv_" >|< @lhs.nt >|< "_s" >|< @from >#< ch0+ >#< "K_" >|< @lhs.nt >|< "_v" >|< @ident >#< args+ args = pp_parens args0 >#< args1+ args0 = @loc.nameTIn_visit >#< @loc.inhargs chn+ args1 | dummyTokenVisit @lhs.options = pp $ dummyArg @lhs.options True+ | otherwise = empty+ in (pat, expr) -- pretty print of the pattern and the expression part+ else Left $ IncompatibleVisitKind chn @ident kind @kind++{+-- a `compatibleKind` b means: can kind b be invoked from a+compatibleKind :: VisitKind -> VisitKind -> Bool+compatibleKind _ _ = True++compatibleRule :: VisitKind -> Bool -> Bool+compatibleRule (VisitPure _) False = False+compatibleRule _ _ = True+}++-------------------------------------------------------------------------------+-- Properties of rules+-------------------------------------------------------------------------------++-- Construct an environment that counts how often certain rules are used+ATTR Visits Visit VisitSteps VisitStep [ | | ruleUsage USE {`unionWithSum`} {Map.empty} : {Map Identifier Int} ]+ATTR ERules ERule [ usageInfo : {Map Identifier Int} | | ]++SEM EProduction | EProduction rules.usageInfo = @visits.ruleUsage+SEM VisitStep | Sem lhs.ruleUsage = Map.singleton @name 1+SEM ERule | ERule loc.used = Map.findWithDefault 0 @name @lhs.usageInfo++{+unionWithSum = Map.unionWith (+)+}++-- Collect in what visit-kinds a rule is used+ATTR Visits Visit VisitSteps VisitStep [ | | ruleKinds USE {`unionWithMappend`} {Map.empty} : {Map Identifier (Set VisitKind)} ]+SEM VisitStep | Sem+ lhs.ruleKinds = Map.singleton @name (Set.singleton @lhs.kind)++ATTR ERules ERule [ ruleKinds : {Map Identifier (Set VisitKind)} | | ]+SEM EProduction | EProduction+ rules.ruleKinds = @visits.ruleKinds++SEM ERule | ERule+ loc.kinds = Map.findWithDefault Set.empty @name @lhs.ruleKinds+ loc.anyLazyKind = Set.fold (\k r -> isLazyKind k || r) False @loc.kinds++ATTR Pattern Patterns [ anyLazyKind : Bool | | ]+++-------------------------------------------------------------------------------+-- Intra attributes+-------------------------------------------------------------------------------+{+uwSetUnion :: (Ord a, Ord b) => Map a (Set b) -> Map a (Set b) -> Map a (Set b)+uwSetUnion = Map.unionWith Set.union++uwMapUnion :: (Ord a, Ord b) => Map a (Map b c) -> Map a (Map b c) -> Map a (Map b c)+uwMapUnion = Map.unionWith Map.union+}+ATTR Visit Visits [ allintramap : {Map StateIdentifier (Map String (Maybe NonLocalAttr))}+ | | intramap USE {`uwMapUnion`} {Map.empty} : {Map StateIdentifier (Map String (Maybe NonLocalAttr))} ]++ATTR Visit Visits [ terminaldefs : {Set String} | | ]+ATTR EChild EChildren [ | | terminaldefs USE {`Set.union`} {Set.empty} : {Set String} ]++SEM EChild | ETerm+ lhs.terminaldefs = Set.singleton $ locname @name++SEM EProduction | EProduction+ visits.allintramap = @visits.intramap+ visits.terminaldefs = @children.terminaldefs++SEM Visit+ | Visit loc.thisintra = (@loc.uses `Map.union` @loc.nextintra) `Map.difference` @loc.defsAsMap+ lhs.intramap = Map.singleton @from @loc.thisintra+ loc.nextintra = maybe Map.empty id $ Map.lookup @to @lhs.allintramap+ loc.uses = let mp1 = @steps.uses+ mp2 = Map.fromList [ (lhsname False i, Just (AttrSyn _LHS i)) | i <- Set.elems @syn ]+ in mp1 `Map.union` mp2+ loc.inhVarNms = Set.map (lhsname True) @inh+ loc.defs = @steps.defs `Set.union` @loc.inhVarNms `Set.union` @lhs.terminaldefs+ loc.defsAsMap = Map.fromList [ (a, Nothing) | a <- Set.elems @loc.defs ]++ATTR ERule ERules [ | | ruledefs USE {`uwSetUnion`} {Map.empty} : {Map Identifier (Set String)}+ ruleuses USE {`uwMapUnion`} {Map.empty} : {Map Identifier (Map String (Maybe NonLocalAttr))} ]+ATTR Visit Visits+ VisitSteps VisitStep [ ruledefs : {Map Identifier (Set String)}+ ruleuses : {Map Identifier (Map String (Maybe NonLocalAttr))} | | ]++SEM ERule+ | ERule lhs.ruledefs = Map.singleton @name @pattern.attrs+ lhs.ruleuses = Map.singleton @name @rhs.attrs++SEM EProduction+ | EProduction visits.ruledefs = @rules.ruledefs+ visits.ruleuses = @rules.ruleuses++ATTR Visit Visits+ EProduction+ EProductions+ ENonterminal+ ENonterminals [ | | visitdefs USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (Set Identifier)}+ visituses USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (Set Identifier)} ]++SEM Visit+ | Visit lhs.visitdefs = Map.singleton @ident @syn+ lhs.visituses = Map.singleton @ident @inh++ATTR Visit Visits+ VisitSteps VisitStep+ EProduction EProductions+ ENonterminal ENonterminals [ avisitdefs : {Map VisitIdentifier (Set Identifier)}+ avisituses : {Map VisitIdentifier (Set Identifier)} | | ]++SEM ExecutionPlan+ | ExecutionPlan nonts.avisitdefs = @nonts.visitdefs+ nonts.avisituses = @nonts.visituses++ATTR VisitSteps VisitStep [ | | defs USE {`Set.union`} {Set.empty} : {Set String}+ uses USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ]+SEM VisitStep+ | Sem lhs.defs = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruledefs+ lhs.uses = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruleuses+ | ChildVisit lhs.defs = Set.insert (stname @child @to) $ maybe (error "Visit not found") (Set.map $ attrname True @child) $ Map.lookup @visit @lhs.avisitdefs+ lhs.uses = let convert attrs = Map.fromList [ (attrname False @child attr, Just $ mkNonLocalAttr True @child attr) | attr <- Set.elems attrs ]+ in Map.insert (stname @child @from) Nothing $ convert $+ maybe (error "Visit not found") id $ Map.lookup @visit @lhs.avisituses++-------------------------------------------------------------------------------+-- Identification of lazy intra defs within a production+--+-- These identifiers will not be marked as strict in rules and state closures+-------------------------------------------------------------------------------++ATTR Visits Visit VisitSteps VisitStep [ | | lazyIntras USE {`Set.union`} {Set.empty} : {Set String} ]+ATTR ERules ERule [ lazyIntras : {Set String} | | ]++SEM Visit | Visit+ loc.lazyIntrasInh = case @kind of+ VisitPure False -> @loc.inhVarNms `Set.union` @steps.defs+ _ -> Set.empty+ lhs.lazyIntras = @loc.lazyIntrasInh `Set.union` @steps.lazyIntras++SEM VisitStep | PureGroup+ lhs.lazyIntras = if @ordered+ then @steps.lazyIntras+ else @steps.defs++SEM EProduction | EProduction+ loc.lazyIntras = @visits.lazyIntras++-------------------------------------------------------------------------------+-- Pretty printing of haskell code+-------------------------------------------------------------------------------++SEM HsTokens [ || tks : {[(Pos,String)]} ]+ | Cons lhs.tks = @hd.tok : @tl.tks+ | Nil lhs.tks = []++SEM HsToken+ | AGLocal loc.tok = (@pos,locname @var)++SEM HsToken [ || tok:{(Pos,String)}]+ | AGField+ loc.addTrace = case @rdesc of+ Just d -> \x -> "(trace " ++ show (d ++ " -> " ++ show @field ++ "." ++ show @attr) ++ " (" ++ x ++ "))"+ Nothing -> id+ lhs.tok = (@pos, @loc.addTrace $ attrname True @field @attr)++ | HsToken lhs.tok = (@pos, @value)++ | CharToken lhs.tok = (@pos, if null @value+ then ""+ else showCharShort (head @value)+ )++ | StrToken lhs.tok = (@pos, showStrShort @value)+ | Err lhs.tok = (@pos, "")++-------------------------------------------------------------------------------+-- Alternative code generation (sepsemmods)+-------------------------------------------------------------------------------++ATTR ExecutionPlan [ mainBlocksDoc : PP_Doc textBlockMap : {Map BlockInfo PP_Doc}+ | | genIO : {IO ()} ]++SEM ExecutionPlan+ | ExecutionPlan lhs.genIO = do @loc.genMainModule+ @loc.genCommonModule+ @nonts.genProdIO+ loc.mainModuleFile = @lhs.mainFile+ loc.ppMonadImports = ( if tupleAsDummyToken @lhs.options+ then empty+ else pp "import GHC.Prim"+ )+ >-< if parallelInvoke @lhs.options+ then pp "import qualified System.IO.Unsafe(unsafePerformIO)"+ >-< pp "import System.IO(IO)"+ >-< pp "import Control.Concurrent(newEmptyMVar,forkIO,putMVar,takeMVar)"+ else pp "import Control.Monad.Identity"+ loc.genMainModule = writeModule @loc.mainModuleFile+ ( [ warrenFlagsPP @lhs.options+ , pp $ @lhs.pragmaBlocks+ , pp $ @lhs.moduleHeader @lhs.mainName "" "" False+ , @loc.ppMonadImports+ , pp $ "import " ++ @lhs.mainName ++ "_common"+ ]+ ++ @nonts.imports+ ++ [@lhs.mainBlocksDoc]+ ++ [@loc.wrappersExtra]+ ++ @nonts.appendMain+ )+ loc.commonFile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_common")+ loc.genCommonModule = writeModule @loc.commonFile+ ( [ pp $ "{-# LANGUAGE GADTs #-}" -- the common module only needs GADTs+ , pp $ @lhs.pragmaBlocks+ , pp $ @lhs.moduleHeader @lhs.mainName "_common" "" True+ , @loc.ppMonadImports+ , @lhs.importBlocks+ , @lhs.textBlocks+ , @loc.commonExtra+ ]+ ++ @nonts.appendCommon+ )++ATTR ENonterminal [ | | appendCommon, appendMain : { PP_Doc } ]+ATTR ENonterminals [ | | appendCommon, appendMain USE {:} {[]} : {[PP_Doc]} ]++SEM ENonterminal+ | ENonterminal lhs.appendMain = (if @nt `Set.member` @lhs.wrappers+ then @loc.wr_inh+ >-< @loc.wr_syn+ >-< @loc.wrapper+ else empty)+ >-< @loc.sem_nt+ lhs.appendCommon = (if dataTypes @lhs.options then @loc.datatype else empty)+ >-< @loc.t_init+ >-< @loc.t_states+ >-< @loc.k_states+ >-< @prods.t_visits++ATTR EProduction EProductions+ ENonterminal ENonterminals [ | | imports USE {++} {[]} : {[PP_Doc]}+ genProdIO USE {>>} {return ()} : {IO ()} ]++SEM EProduction+ | EProduction lhs.imports = [pp $ "import " ++ @loc.moduleName]+ loc.moduleName = @lhs.mainName ++ @loc.suffix+ loc.suffix = "_" ++ show @lhs.nt ++ "_" ++ show @con+ loc.outputfile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ @loc.suffix)+ loc.ppMonadImports = if parallelInvoke @lhs.options+ then pp "import qualified System.IO.Unsafe(unsafePerformIO)"+ >-< pp "import System.IO(IO)"+ >-< pp "import Control.Concurrent(newEmptyMVar,forkIO,putMVar,takeMVar)"+ else pp "import Control.Monad.Identity"+ lhs.genProdIO = writeModule @loc.outputfile+ [ warrenFlagsPP @lhs.options+ , pp $ @lhs.pragmaBlocks+ , pp $ @lhs.moduleHeader @lhs.mainName @loc.suffix @loc.semname True+ , @lhs.importBlocks+ , @loc.ppMonadImports+ , ( if tupleAsDummyToken @lhs.options+ then empty+ else pp "import GHC.Prim" -- need it to pass State#+ )+ , pp $ "import " ++ @lhs.mainName ++ "_common"+ , @loc.sem_prod+ ]++{+renderDocs :: [PP_Doc] -> String+renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) ""++writeModule :: FilePath -> [PP_Doc] -> IO ()+writeModule path docs+ = do bExists <- doesFileExist path+ if bExists+ then do input <- readFile path+ seq (length input) (return ())+ if input /= output+ then dumpIt+ else return ()+ else dumpIt+ where+ output = renderDocs docs+ dumpIt = writeFile path output+}+++--+-- Bang pattern usage+--++SEM ERule | ERule loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x+SEM Visit | Visit loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x+SEM ENonterminal | ENonterminal loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x+SEM EProduction | EProduction loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x+SEM EChild | EChild loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x+SEM EChild | ETerm loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x+SEM VisitStep | ChildVisit loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x+SEM Pattern | Alias Constr Product loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x++SEM Visit | Visit loc.addbang1 = if isLazyKind @kind then id else @loc.addbang+SEM ENonterminal | ENonterminal loc.addbangWrap = if strictWrap @lhs.options then @loc.addbang else id+SEM ERule | ERule loc.addbang1 = if @loc.anyLazyKind then id else @loc.addbang+SEM Pattern | Alias Constr Product loc.addbang1 = if @lhs.anyLazyKind then id else @loc.addbang++--+-- Distribute single-visit-next map downward+--++ATTR EProductions EProduction Visits Visit+ [ prevVisits, nextVisits : {Map StateIdentifier StateCtx} | | ]++SEM ENonterminal | ENonterminal+ prods.nextVisits = @nextVisits+ prods.prevVisits = @prevVisits++--+-- Collect and distribute the from/to states of a visit+--++ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit+ [ | | fromToStates USE {`mappend`} {mempty} : {Map VisitIdentifier (Int,Int)} ]++ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep+ [ allFromToStates : {Map VisitIdentifier (Int,Int)} | | ]++SEM Visit | Visit+ lhs.fromToStates = Map.singleton @ident (@from, @to)++SEM ExecutionPlan | ExecutionPlan+ nonts.allFromToStates = @nonts.fromToStates++SEM VisitStep | ChildVisit+ (loc.from, loc.to) = Map.findWithDefault (error "visit not in allFromToStates") @visit @lhs.allFromToStates+++--+-- Collect and distribute the actual types of children of productions+--++ATTR EChildren EChild [ | | childTypes USE {`mappend`} {mempty} : {Map Identifier Type} ]+ATTR ERules ERule Visits Visit VisitSteps VisitStep [ childTypes : {Map Identifier Type} | | ]++SEM EProduction | EProduction+ loc.childTypes = Map.singleton _LHS @lhs.ntType `Map.union` @children.childTypes++SEM EChild | EChild ETerm+ lhs.childTypes = Map.singleton @name @tp++--+-- Distribute types of local attributes+--++ATTR ExecutionPlan ENonterminals ENonterminal [ localAttrTypes : {Map NontermIdent (Map ConstructorIdent (Map Identifier Type))} | | ]+ATTR EProductions EProduction [ localAttrTypes : {Map ConstructorIdent (Map Identifier Type)} | | ]+ATTR ERules ERule [ localAttrTypes : {Map Identifier Type} | | ]++SEM ENonterminal | ENonterminal+ prods.localAttrTypes = Map.findWithDefault Map.empty @nt @lhs.localAttrTypes++SEM EProduction | EProduction+ loc.localAttrTypes = Map.findWithDefault Map.empty @con @lhs.localAttrTypes++--+-- Collect and distribute visit kinds+--++ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep+ [ allVisitKinds : {Map VisitIdentifier VisitKind} | | visitKinds USE {`mappend`} {mempty} : {Map VisitIdentifier VisitKind} ]++SEM Visit | Visit+ lhs.visitKinds = Map.singleton @ident @kind++SEM ExecutionPlan | ExecutionPlan+ nonts.allVisitKinds = @nonts.visitKinds++--+-- Collect and distribute the initial state of nonterminals+--++ATTR ENonterminals ENonterminal [ | | initStates USE {`mappend`} {mempty} : {Map NontermIdent Int} ]+ATTR ENonterminals ENonterminal EProductions EProduction EChildren EChild Visits Visit VisitSteps VisitStep+ [ allInitStates : {Map NontermIdent Int} | | ]++SEM ENonterminal | ENonterminal+ lhs.initStates = Map.singleton @nt @initial++SEM ExecutionPlan | ExecutionPlan+ nonts.allInitStates = @nonts.initStates++SEM EChild | EChild+ loc.initSt = Map.findWithDefault (error "nonterminal not in allInitStates map") @loc.nt @lhs.allInitStates++--+-- Push the nonterminal type downward+--++ATTR EProductions EProduction [ ntType : Type | | ]+SEM ENonterminal | ENonterminal+ loc.ntType = NT @nt (map show @params) False++--+-- Collect errors contained in rules that should be yielded when the+-- rules are scheduled.+--++ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule Visits Visit VisitSteps VisitStep [ | | errors USE {Seq.><} {Seq.empty} : {Seq Error} ]+SEM ERule | ERule+ lhs.errors = case @mbError of+ Just e | @loc.used > 0 -> Seq.singleton e+ _ -> Seq.empty+++-- Some pretty printing utility functions+{+ppNoInline :: PP a => a -> PP_Doc+ppNoInline = ppPragmaBinding "NOINLINE"++ppInline :: PP a => a -> PP_Doc+ppInline = ppPragmaBinding "INLINE"++ppInlinable :: PP a => a -> PP_Doc+ppInlinable = ppPragmaBinding "INLINABLE"++ppPragmaBinding :: (PP a, PP b) => a -> b -> PP_Doc+ppPragmaBinding pragma nm = "{-#" >#< pragma >#< nm >#< "#-}"++ppCostCentre :: PP a => a -> PP_Doc+ppCostCentre nm = "{-#" >#< "SCC" >#< "\"" >|< nm >|< "\"" >#< "#-}"++warrenFlagsPP :: Options -> PP_Doc+warrenFlagsPP options = vlist+ [ pp "{-# LANGUAGE Rank2Types, GADTs #-}"+ , if bangpats options+ then pp "{-# LANGUAGE BangPatterns #-}"+ else empty+ , if noPerRuleTypeSigs options && noPerStateTypeSigs options+ then empty+ else pp "{-# LANGUAGE ScopedTypeVariables #-}"+ , if tupleAsDummyToken options+ then empty+ else pp "{-# LANGUAGE ScopedTypeVariables, MagicHash #-}"+ , -- not that the meaning of "unbox" is here that strict fields in data types may be+ -- unboxed if possible. This may affect user-defined data types declared in the module.+ -- Unfortunately, we cannot turn it on for only the AG generated data types without+ -- causing a zillion of warnings.+ if unbox options && bangpats options+ then pp $ "{-# OPTIONS_GHC -funbox-strict-fields -fstrictness #-}"+ else empty+ , if parallelInvoke options && not (noEagerBlackholing options)+ then pp $ "{-# OPTIONS_GHC -feager-blackholing #-}"+ else empty+ ]+}
src-ag/GenerateCode.ag view
@@ -154,20 +154,20 @@ ATTR Sequence CRule [ | | decls USE {++} {[]} : {Decls} ] SEM CRule- | CRule loc.instTypes = [ (n, (t, mb)) | (n, NT t _, mb) <- @lhs.children ]+ | CRule loc.instTypes = [ (n, (t, mb, for)) | (n, NT t _ for, mb) <- @lhs.children ] loc.originComment = if @lhs.o_pretty then (Comment @origin:) else id- loc.instDecls = [ mkDecl @lhs.o_monadic (Pattern3 (Alias _INST' inst (Underscore (getPos inst)) []))- ( let (nm,mb) = fromJust $ inst `lookup` @loc.instTypes- in unwrapSem @lhs.o_newtypes (maybe nm id (deforestedNt nm))+ loc.instDecls = [ mkDecl @lhs.o_monadic (Pattern3 (Alias _INST' inst (Underscore (getPos inst))))+ ( let (nm,mb,defor) = fromJust $ inst `lookup` @loc.instTypes+ in unwrapSem @lhs.o_newtypes nm $ case mb of- Just (Just tp') -> App instLocFieldName [SimpleExpr $ fieldname inst]- _ ->- case nm `Set.member` @lhs.allNts of -- if it is not a member of the Nts, it must be the T_ variant- True -> App (cataname @lhs.prefix nm)+ ChildReplace tp' -> App instLocFieldName [SimpleExpr $ fieldname inst]+ _ ->+ if defor+ then SimpleExpr instLocFieldName+ else App (cataname @lhs.prefix nm) [SimpleExpr instLocFieldName]- False -> SimpleExpr instLocFieldName ) (Set.singleton instSemFieldName) (Set.singleton instLocFieldName)@@ -212,8 +212,10 @@ | otherwise = mkTupleLhs @lhs.o_unbox (null $ Map.keys @inh) lhsVars rhs = @loc.addCostCentre $ Code.InvokeExpr (typeName @nt @nr) (SimpleExpr fun) (map SimpleExpr rhsVars) isVirtual _ [] = False- isVirtual nm ((n,t,mb) : r)- | nm == n = isJust mb+ isVirtual nm ((n,t,kind) : r)+ | nm == n = case kind of+ ChildAttr -> True+ _ -> False | otherwise = isVirtual nm r isMerged = @name `Map.member` @lhs.mergeMap isMerging = @name `elem` concatMap (\(_,cs) -> cs) (Map.elems @lhs.mergeMap)@@ -254,7 +256,7 @@ right = SimpleExpr "x" } -ATTR Sequence CRule [ children : {[(Identifier,Type,Maybe (Maybe Type))]} ||]+ATTR Sequence CRule [ children : {[(Identifier,Type,ChildKind)]} ||] ATTR Sequence CRule Pattern Patterns [|| definedInsts USE {++} {[]} : {[Identifier]} ] SEM Pattern@@ -266,7 +268,7 @@ ATTR Pattern Patterns [ | | patternAttributes USE {++} {[]} : {[(Identifier, Identifier)]} ] SEM Pattern | Alias- lhs.patternAttributes = (@field,@attr) : (@pat.patternAttributes ++ @parts.patternAttributes)+ lhs.patternAttributes = (@field,@attr) : @pat.patternAttributes ------------------------------------------------------------------------------- -- Numbering the visits@@ -365,17 +367,14 @@ | (field,attr,tp) <- Map.elems @defines, isJust tp , let tp1 = @loc.evalTp field $ @mkTp (fromJust tp) tp' = case findOrigType attr @lhs.children of- Just tp' -> let tp'' = case tp' of- NT n params -> NT (Ident ("T_" ++ show n) (getPos n)) params- _ -> tp'- tp2 = @loc.evalTp field $ @mkTp tp''+ Just tp' -> let tp2 = @loc.evalTp field $ @mkTp tp' in Arr tp2 tp1 Nothing -> tp1 findOrigType nm [] = Nothing- findOrigType nm ((n,_,mb) : r)- | nm == n = case mb of- Just (Just orig) -> Just orig- _ -> Nothing+ findOrigType nm ((n,_,kind) : r)+ | nm == n = case kind of+ ChildReplace orig -> Just orig+ _ -> Nothing | otherwise = findOrigType nm r ] @@ -391,7 +390,7 @@ else idEvalType tp else evalType replace tp - | CChildVisit loc.mkTp = @loc.evalTp . typeToCodeType (Just @nt) @loc.orgParams+ | CChildVisit loc.mkTp = @loc.evalTp . typeToCodeType (Just @nt) @loc.orgParams . removeDeforested loc.definedTps = [ TSig (attrname True @name a) (@mkTp tp) | (a,tp) <- Map.toList @syn ] loc.nextTp = typeName @nt (@nr+1) lhs.tSigs = (if @isLast then id else (TSig (funname @name (@nr+1)) (TypeApp (SimpleType @nextTp) (map SimpleType @loc.instParams)) :)) @definedTps@@ -408,13 +407,7 @@ -- semantic function. ------------------------------------------------------------------------------- -{-substSelf nt tp = case tp of- NT t tps | t == _SELF -> Haskell (getName nt ++ " " ++ unwords tps)- _ -> tp-}--ATTR CVisits CVisit [ children : {[(Identifier,Type, Maybe (Maybe Type))]} | | ]+ATTR CVisits CVisit [ children : {[(Identifier,Type, ChildKind)]} | | ] SEM CProduction | CProduction visits.children = @children @@ -422,10 +415,10 @@ ATTR Sequence CRule [ | | tps USE {++} {[]} : {[Type]} allTpsFound USE {&&} {True} : Bool ] SEM CRule- | CRule lhs.(tps,allTpsFound) = maybe ([],False) (\tp -> ([substSelf (fromJust @childnt) tp],True)) @tp+ | CRule lhs.(tps,allTpsFound) = maybe ([],False) (\tp -> ([tp],True)) @tp | CChildVisit lhs.tps = if @loc.isSuperfluousHigherOrderIntra then []- else [NT (ntOfVisit @nt (@nr+1)) @loc.instParams]+ else [NT (ntOfVisit @nt (@nr+1)) @loc.instParams False] ------------------------------------------------------------------------------- -- Each visit has its semantic function@@ -456,7 +449,17 @@ in if @lhs.isLast then [] else [Decl lhs rhs (Set.fromList @nextVisitName) @lhs.nextIntraVars]- loc.decls = @typeSigs ++ @vss.decls ++ @nextVisitDecl+ loc.isOneVisit = @lhs.isLast && @lhs.nr == 0+ loc.hasWrappers = @lhs.nt `Set.member` @lhs.wrappers+ loc.refDecls = if @loc.isOneVisit && @loc.hasWrappers+ then let synAttrs = Map.toList @syn+ synNT = "Syn" ++ "_" ++ getName @lhs.nt+ synVars = [ SimpleExpr (attrname False _LHS a) | (a,_) <- synAttrs ]+ rhs = App synNT synVars+ lhs = Fun "___node" []+ in [Decl lhs rhs Set.empty Set.empty]+ else []+ loc.decls = @typeSigs ++ @vss.decls ++ @nextVisitDecl ++ @loc.refDecls vss.lastExpr = mkTupleExpr @lhs.o_unbox (null $ Map.keys @inh) $ map (SimpleExpr . lhsname False) (Map.keys @syn) ++ map SimpleExpr @nextVisitName intra.lastExpr = error "lastExpr: not used here" loc.lastExprVars = map (lhsname False) (Map.keys @syn) ++ @loc.nextVisitName@@ -471,23 +474,23 @@ loc.semFun = let lhs = Fun @funcname lhs_args lhs_args = if @lhs.nr == 0 then map field @loc.firstOrderOrig else [] -- @intra.exprs - field (name,NT tp tps,_) = let unwrap | @lhs.o_newtypes = \x -> App (sdtype tp) [x]- | otherwise = id+ field (name,NT tp tps _,_) = let unwrap | @lhs.o_newtypes = \x -> App (sdtype tp) [x]+ | otherwise = id - addType expr | null tps = expr- | otherwise = TypedExpr expr (@lhs.unfoldSemDom tp 0 tps)+ addType expr | null tps = expr+ | otherwise = TypedExpr expr (@lhs.unfoldSemDom tp 0 tps) - in unwrap $ addType $ SimpleExpr $ funname name 0+ in unwrap $ addType $ SimpleExpr $ funname name 0 field (name,tp,_) = let expr = SimpleExpr (funname name 0) in if null @loc.params then expr- else TypedExpr expr (idEvalType $ typeToCodeType (Just @lhs.nt) @loc.params tp)+ else TypedExpr expr (idEvalType $ typeToCodeType (Just @lhs.nt) @loc.params $ removeDeforested tp) mbEvalTp | null @loc.params = const Nothing | otherwise = Just . idEvalType rhs = wrap- . mkSemFun @lhs.nt @lhs.nr [mkLambdaArg (lhsname True nm) (mbEvalTp $ typeToCodeType (Just @lhs.nt) @loc.params tp) | (nm,tp) <- Map.assocs @inh]+ . mkSemFun @lhs.nt @lhs.nr [mkLambdaArg (lhsname True nm) (mbEvalTp $ typeToCodeType (Just @lhs.nt) @loc.params $ removeDeforested tp) | (nm,tp) <- Map.assocs @inh] $ @loc.addCostCentre $ if @ordered && @loc.o_splitsems then @loc.blockFirstFunCall@@ -500,7 +503,7 @@ else id in Decl lhs rhs Set.empty Set.empty loc.tsig = TSig @funcname @semType- loc.semType = let argType (NT tp tps) r | tp /= _SELF = typeAppStrs (sdtype tp) tps `Arr` r+ loc.semType = let argType (NT tp tps _) r | tp /= _SELF = typeAppStrs (sdtype tp) tps `Arr` r | tp == _SELF = error "GenerateCode: found an intra-type with type SELF, which should have been prevented by CRule.tps" argType (Haskell tp) r = SimpleType tp `Arr` r @@ -545,12 +548,12 @@ typeAppStrs nm params = TypeApp (SimpleType nm) (map SimpleType params) -isHigherOrder :: Maybe (Maybe Type) -> Bool-isHigherOrder (Just Nothing) = True-isHigherOrder _ = False+isHigherOrder :: ChildKind -> Bool+isHigherOrder ChildAttr = True+isHigherOrder _ = False -pickOrigType :: (Identifier, Type, Maybe (Maybe Type)) -> (Identifier, Type, Maybe (Maybe Type))-pickOrigType (nm, tp, virt@(Just (Just x))) = (nm, x, virt)+pickOrigType :: (Identifier, Type, ChildKind) -> (Identifier, Type, ChildKind)+pickOrigType (nm, _, virt@(ChildReplace x)) = (nm, x, virt) pickOrigType x = x } @@ -759,9 +762,8 @@ typeToCodeType :: Maybe NontermIdent -> [String] -> Type -> Code.Type typeToCodeType mbNt params tp = case tp of- NT nt tps | nt == _SELF -> NontermType (maybe "Unknown" getName mbNt) params- | otherwise -> NontermType (getName nt) tps- Haskell t -> SimpleType t+ NT nt tps defor -> NontermType (getName nt) tps defor+ Haskell t -> SimpleType t evalType :: (String -> String) -> Code.Type -> Code.Type evalType replf t@@ -816,7 +818,7 @@ appParams nm = TypeApp (SimpleType nm) (map SimpleType params') typeSig = TSig wrapNT (evalTp $ appParams (sdtype @nt) `Arr` (appParams inhNT `Arr` appParams synNT)) mkstrict = Named @lhs.o_strictwrap- mkdata n attrs = Data n params' [Record n [mkstrict (getName f++"_"++n) $ evalTp $ typeToCodeType (Just @nt) params' t | (f,t) <- attrs]] False []+ mkdata n attrs = Data n params' [Record n [mkstrict (getName f++"_"++n) $ evalTp $ typeToCodeType (Just @nt) params' $ removeDeforested t | (f,t) <- attrs]] False [] datas = [mkdata inhNT inhAttrs, mkdata synNT synAttrs] in datas ++ [ typeSig , Decl (Fun wrapNT [varPat, App inhNT inhVars])@@ -882,9 +884,10 @@ { -- for a virtual child that already existed as a child, returns-isFirstOrder :: Maybe (Maybe Type) -> Type -> Maybe Type-isFirstOrder Nothing tp = Just tp-isFirstOrder (Just x) _ = x+isFirstOrder :: ChildKind -> Type -> Maybe Type+isFirstOrder ChildSyntax tp = Just tp+isFirstOrder ChildAttr _ = Nothing+isFirstOrder (ChildReplace tp) _ = Just tp } SEM CVisit@@ -903,7 +906,7 @@ { makeLocalComment :: Int -> String -> Identifier -> Maybe Type -> String makeLocalComment width what name tp = let x = getName name- y = maybe "_" (\t -> case t of (NT nt tps) -> getName nt ++ " " ++ unwords tps; Haskell t -> '{':t++"}") tp+ y = maybe "_" (\t -> case t of (NT nt tps _) -> getName nt ++ " " ++ unwords tps; Haskell t -> '{':t++"}") tp in ( what ++ " " ++ x ++ replicate ((width - length x) `max` 0) ' ' ++ " : " ++ y ) }@@ -980,7 +983,9 @@ -- Datatypes were already present ------------------------------------------------------------------------------- -ATTR CNonterminals CNonterminal [ wrappers:{Set NontermIdent} derivings: {Derivings} typeSyns : {TypeSyns} | | ]+ATTR CNonterminals CNonterminal [ derivings: {Derivings} typeSyns : {TypeSyns} | | ]+ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit [ wrappers:{Set NontermIdent} | | ]+ SEM CGrammar | CGrammar nonts . typeSyns = @typeSyns . derivings = @derivings@@ -1011,9 +1016,20 @@ | Nil lhs.dataAlts = [] SEM CProduction- | CProduction loc.params = map getName $ Map.findWithDefault [] @lhs.nt @lhs.paramMap- lhs.dataAlt = DataAlt (conname @lhs.o_rename @lhs.nt @con) (map (\(_,t,_) -> typeToCodeType (Just @lhs.nt) @loc.params t) @loc.firstOrderChildren)+ | CProduction loc.params = map getName $ Map.findWithDefault [] @lhs.nt @lhs.paramMap+ lhs.dataAlt = let conNm = conname @lhs.o_rename @lhs.nt @con+ mkFields f = map (\(nm,t,_) -> f @lhs.nt @con nm (typeToCodeType (Just @lhs.nt) @loc.params $ removeDeforested t)) @loc.firstOrderChildren+ in if dataRecords @lhs.options+ then Record conNm $ mkFields $ toNamedType (strictData @lhs.options)+ else DataAlt conNm $ mkFields $ \_ _ _ t -> t +{+toNamedType :: Bool -> NontermIdent -> ConstructorIdent -> Identifier -> Code.Type -> Code.NamedType+toNamedType genStrict nt con nm tp+ = Code.Named genStrict strNm tp+ where strNm = recordFieldname nt con nm+}+ ------------------------------------------------------------------------------- -- Catamorphism were already present -------------------------------------------------------------------------------@@ -1031,9 +1047,9 @@ nil = SimpleExpr (semname @lhs.prefix @nt (identifier "Nil" )) arg = SimpleExpr "list" rarg = case tp of- NT t _ -> let t' = maybe t id (deforestedNt t)- in SimpleExpr ("(Prelude.map " ++ (cataname @lhs.prefix t') ++ " list)")- _ -> arg+ NT t _ _ -> let t' = maybe t id (deforestedNt t)+ in SimpleExpr ("(Prelude.map " ++ (cataname @lhs.prefix t') ++ " list)")+ _ -> arg lhs = Fun (cataname @lhs.prefix @nt) [arg] rhs = (App "Prelude.foldr" [cons,nil,rarg]) in [Decl lhs rhs Set.empty Set.empty]@@ -1042,9 +1058,9 @@ nothing = semname @lhs.prefix @nt (identifier "Nothing" ) arg = SimpleExpr "x" rarg = case tp of- NT t _ -> let t' = maybe t id (deforestedNt t)- in App (cataname @lhs.prefix t') [arg]- _ -> arg+ NT t _ _ -> let t' = maybe t id (deforestedNt t)+ in App (cataname @lhs.prefix t') [arg]+ _ -> arg lhs a = Fun (cataname @lhs.prefix @nt) [a] in [Decl (lhs (App "Prelude.Just" [arg])) (App just [rarg]) Set.empty Set.empty ,Decl (lhs (SimpleExpr "Prelude.Nothing")) (SimpleExpr nothing) Set.empty Set.empty@@ -1054,13 +1070,13 @@ right = semname @lhs.prefix @nt (identifier "Right" ) arg = SimpleExpr "x" rarg0 = case tp1 of- NT t _ -> let t' = maybe t id (deforestedNt t)- in App (cataname @lhs.prefix t') [arg]- _ -> arg+ NT t _ _ -> let t' = maybe t id (deforestedNt t)+ in App (cataname @lhs.prefix t') [arg]+ _ -> arg rarg1 = case tp2 of- NT t _ -> let t' = maybe t id (deforestedNt t)- in App (cataname @lhs.prefix t') [arg]- _ -> arg+ NT t _ _ -> let t' = maybe t id (deforestedNt t)+ in App (cataname @lhs.prefix t') [arg]+ _ -> arg lhs a = Fun (cataname @lhs.prefix @nt) [a] in [Decl (lhs (App "Prelude.Left" [arg])) (App left [rarg0]) Set.empty Set.empty ,Decl (lhs (App "Prelude.Right" [arg])) (App right [rarg1]) Set.empty Set.empty@@ -1070,9 +1086,9 @@ nil = SimpleExpr (semname @lhs.prefix @nt (identifier "Nil")) arg = SimpleExpr "m" rarg = case tp of- NT t _ -> let t' = maybe t id (deforestedNt t)- in App "Data.Map.map" [SimpleExpr $ cataname @lhs.prefix t', arg]- _ -> arg+ NT t _ _ -> let t' = maybe t id (deforestedNt t)+ in App "Data.Map.map" [SimpleExpr $ cataname @lhs.prefix t', arg]+ _ -> arg lhs = Fun (cataname @lhs.prefix @nt) [arg] rhs = App "Data.Map.foldrWithKey" [entry,nil,rarg] in [Decl lhs rhs Set.empty Set.empty]@@ -1081,9 +1097,9 @@ nil = SimpleExpr (semname @lhs.prefix @nt (identifier "Nil")) arg = SimpleExpr "m" rarg = case tp of- NT t _ -> let t' = maybe t id (deforestedNt t)- in App "Data.IntMap.map" [SimpleExpr $ cataname @lhs.prefix t', arg]- _ -> arg+ NT t _ _ -> let t' = maybe t id (deforestedNt t)+ in App "Data.IntMap.map" [SimpleExpr $ cataname @lhs.prefix t', arg]+ _ -> arg lhs = Fun (cataname @lhs.prefix @nt) [arg] rhs = App "Data.IntMap.foldWithKey" [entry,nil,rarg] in [Decl lhs rhs Set.empty Set.empty]@@ -1092,9 +1108,9 @@ tps' = [ (SimpleExpr (getName x),y) | (x,y) <- tps] rargs = map rarg tps' rarg (n, tp) = case tp of- NT t _ -> let t' = maybe t id (deforestedNt t)- in App (cataname @lhs.prefix t') [n]- _ -> n+ NT t _ _ -> let t' = maybe t id (deforestedNt t)+ in App (cataname @lhs.prefix t') [n]+ _ -> n lhs = Fun (cataname @lhs.prefix @nt) [TupleExpr (map fst tps')] rhs = App con rargs@@ -1117,8 +1133,7 @@ (map (\(n,_,_) -> SimpleExpr $ locname $ n) @loc.firstOrderChildren) rhs = App (semname @lhs.prefix @lhs.nt @con) (map argument @loc.firstOrderChildren)- argument (nm,NT tp _,_) = let tp' = maybe tp id (deforestedNt tp)- in App (cataname @lhs.prefix tp')+ argument (nm,NT tp _ _,_) = App (cataname @lhs.prefix tp) [SimpleExpr (locname nm)] argument (nm, _,_) = SimpleExpr (locname nm) in Decl lhs rhs Set.empty Set.empty
src-ag/InterfacesRules.lag view
@@ -35,7 +35,7 @@ Visit sub-sequences can be generated from the |Tdp| by a topological sort. To that end we add vertices to |Tdp|. For each production, for-each child, for each visit to that child, we add a vertex $v$. +each child, for each visit to that child, we add a vertex $v$. We add the following edges: @@ -52,7 +52,7 @@ \end{enumerate} -Now we can define a visit sub-sequence as a list of vertices: +Now we can define a visit sub-sequence as a list of vertices: \begin{Code} {@@ -67,7 +67,7 @@ \begin{Code} ATTR IRoot [ tdp : Graph | | ]-SEM IRoot +SEM IRoot | IRoot loc.newedges = toList @inters.newedges loc.visitssGraph = let graph = buildG (0,@inters.v-1) es es = @newedges ++ edges @lhs.tdp@@ -81,7 +81,7 @@ \begin{Code} ATTR Interfaces Interface Segments Segment [ | v : Vertex | ] ATTR IRoot Interfaces Interface Segments Segment [ info : Info | | ]-SEM IRoot +SEM IRoot | IRoot inters.v = snd (bounds @lhs.tdp) + 1 \end{Code} @@ -101,10 +101,10 @@ syntesized attributes of a |Segment|, we find the new vertices. \begin{Code}-SEM Segment +SEM Segment | Segment loc.look : {Vertex -> CRule} loc.look = \a -> ruleTable @lhs.info ! a- + loc.occurAs : {(CRule -> Bool) -> [Vertex] -> [Vertex]} loc.occurAs = \p us -> [ a | u <- us , a <- tdsToTdp @lhs.info ! u@@ -121,12 +121,12 @@ of an attribute occurrence \begin{Code}-ATTR Interfaces Interface Segments Segment +ATTR Interfaces Interface Segments Segment [ visitDescr : {Map Vertex ChildVisit} | | ] SEM IRoot | IRoot inters.visitDescr = Map.fromList @descr ATTR Interfaces Interface Segments Segment- [ | | newedges USE {Seq.><} {Seq.empty} : {Seq Edge } + [ | | newedges USE {Seq.><} {Seq.empty} : {Seq Edge } descr USE {Seq.><} {Seq.empty} : {Seq (Vertex,ChildVisit)} ] SEM Segment | Segment lhs.descr = Seq.fromList $ zipWith (cv @look @lhs.n) @newvertices @groups {-$-}@@ -190,7 +190,7 @@ loc.firstvisitvertices = [@seg.v .. @v-1] loc.newedges = zip @firstvisitvertices @seg.newvertices lhs.newedges = @seg.newedges Seq.>< Seq.fromList @newedges- + loc.look : {Vertex -> CRule} loc.look = \a -> ruleTable @lhs.info ! a loc.descr = zipWith (cv @look (-1)) @firstvisitvertices @seg.groups@@ -283,15 +283,15 @@ | Segment loc.visitss : {[[Vertex]]} loc.visitss = let rem :: [(Identifier,Identifier,Maybe Type)] -> [Vertex] -> [Vertex] rem prev [] = []- rem prev (v:vs) - | inRange (bounds table) v + rem prev (v:vs)+ | inRange (bounds table) v = let cr = table ! v addV = case findIndex cmp prev of Just _ -> id _ -> (v:) cmp (fld,attr,tp) = getField cr == fld && getAttr cr == attr && sameNT (getType cr) tp- sameNT (Just (NT ntA _)) (Just (NT ntB _)) = ntA == ntB- sameNT _ _ = False+ sameNT (Just (NT ntA _ _)) (Just (NT ntB _ _)) = ntA == ntB+ sameNT _ _ = False def = Map.elems (getDefines cr) in addV (rem (def ++ prev) vs) | otherwise = v:rem prev vs@@ -318,7 +318,7 @@ We declare an attribute intravisit which gives the intra-visit dependencies. We pass the intravisit of the next visit to this-one. +one. \begin{Code} { type IntraVisit = [Vertex]@@ -352,14 +352,14 @@ SEM Segments | Cons hd.fromLhs = @lhs.fromLhs tl.fromLhs = []-SEM Segment +SEM Segment | Segment loc.fromLhs = @occurAs isLhs @inh ++ @lhs.fromLhs loc.computed = let computes v = case Map.lookup v @lhs.visitDescr of Nothing -> Map.keys (getDefines (ruleTable @lhs.info ! v)) Just (ChildVisit _ _ _ _ syn) -> v:syn in concatMap (concatMap computes) @visitss loc.intravisits = zipWith @iv @visitss @lhs.nextIntravisits- loc.iv = \vs next -> + loc.iv = \vs next -> let needed = concatMap (@lhs.ddp !) vs in nub (needed ++ next) \\ (@fromLhs ++ @computed) \end{Code}@@ -379,7 +379,7 @@ SEM IRoot | IRoot inters.allInters = @inters.inters -ATTR IRoot Interfaces [ | | inters : {CInterfaceMap} +ATTR IRoot Interfaces [ | | inters : {CInterfaceMap} visits : {CVisitsMap} ] SEM Interfaces | Cons lhs.inters = Map.insert @hd.nt @hd.inter @tl.inters@@ -390,7 +390,7 @@ SEM Interface [ | | nt : NontermIdent ] | Interface lhs.nt = @nt -SEM Interface [ | | inter : CInterface +SEM Interface [ | | inter : CInterface visits : {Map ConstructorIdent CVisits} ] | Interface lhs.inter = CInterface @seg.segs lhs.visits = Map.fromList (zip @cons (transpose @seg.cvisits))@@ -422,7 +422,7 @@ = CChildVisit name nt n inh syn last where CInterface segs = Map.findWithDefault (error ("InterfacesRules::ccv::interfaces not in table for nt: " ++ show nt)) nt table (seg:remain) = drop n segs- CSegment inh syn = seg + CSegment inh syn = seg last = null remain } \end{Code}
src-ag/KWOrder.ag view
@@ -2,6 +2,8 @@ INCLUDE "HsToken.ag" INCLUDE "Expression.ag" INCLUDE "Patterns.ag"+INCLUDE "DistChildAttr.ag"+ imports { import AbstractSyntax@@ -16,14 +18,20 @@ import ExecutionPlan import Data.Maybe import Debug.Trace+import Data.Set(Set)+import Data.Map(Map)+import Data.Sequence(Seq) import qualified Data.Set as Set import qualified Data.Map as Map+import qualified Data.Sequence as Seq+import Data.Monoid(mappend,mempty) } ------------------------------------------------------------------------------- -- Distributing options --------------------------------------------------------------------------------ATTR Grammar [ options : {Options} | | ]+ATTR Grammar Nonterminals Nonterminal Productions Production Children Child+ [ options : {Options} | | ] ------------------------------------------------------------------------------- -- Give unique names to rules@@ -37,9 +45,110 @@ SEM Rule | Rule lhs.rulenumber = @lhs.rulenumber + 1- loc.rulename = maybe (identifier $ "rule" ++ show @lhs.rulenumber) id @mbName + loc.rulename = maybe (identifier $ "rule" ++ show @lhs.rulenumber) id @mbName -------------------------------------------------------------------------------+-- Find out which nonterminals are recursive+-------------------------------------------------------------------------------++ATTR Nonterminals Nonterminal [ | | ntDeps, ntHoDeps USE {`mappend`} {mempty} : {Map NontermIdent (Set NontermIdent)} ]+ATTR Nonterminals Nonterminal [ closedNtDeps, closedHoNtDeps, closedHoNtRevDeps : {Map NontermIdent (Set NontermIdent)} | | ]+ATTR Productions Production Children Child [ | | refNts, refHoNts USE {`mappend`} {mempty} : {Set NontermIdent} ]++SEM Nonterminal | Nonterminal+ lhs.ntDeps = Map.singleton @nt @prods.refNts+ lhs.ntHoDeps = Map.singleton @nt @prods.refHoNts++ loc.closedNtDeps = Map.findWithDefault Set.empty @nt @lhs.closedNtDeps+ loc.closedHoNtDeps = Map.findWithDefault Set.empty @nt @lhs.closedHoNtDeps+ loc.closedHoNtRevDeps = Map.findWithDefault Set.empty @nt @lhs.closedHoNtRevDeps++ loc.recursive = @nt `Set.member` @loc.closedNtDeps+ loc.nontrivAcyc = @nt `Set.member` @loc.closedHoNtDeps+ loc.hoInfo = HigherOrderInfo { hoNtDeps = @loc.closedHoNtDeps+ , hoNtRevDeps = @loc.closedHoNtRevDeps+ , hoAcyclic = @loc.nontrivAcyc+ }++SEM Child | Child+ loc.refNts = case @tp of+ NT nt _ _ -> Set.singleton nt+ _ -> mempty+ loc.refHoNts = if @loc.isHigherOrder then @loc.refNts else mempty+ loc.isHigherOrder = case @kind of+ ChildSyntax -> False+ _ -> True++SEM Grammar | Grammar+ loc.closedNtDeps = closeMap @nonts.ntDeps+ loc.closedHoNtDeps = closeMap @nonts.ntHoDeps+ loc.closedHoNtRevDeps = revDeps @loc.closedHoNtDeps++-------------------------------------------------------------------------------+-- Determine which children have an around-rule+-------------------------------------------------------------------------------++-- Propagate the around-map downward+ATTR Nonterminals Nonterminal+ [ aroundMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} || ]++ATTR Productions Production+ [ aroundMap : {Map ConstructorIdent (Map Identifier [Expression])} || ]++ATTR Children Child+ [ aroundMap : {Map Identifier [Expression]} | | ]++SEM Nonterminal | Nonterminal loc.aroundMap = Map.findWithDefault Map.empty @nt @lhs.aroundMap+SEM Production | Production loc.aroundMap = Map.findWithDefault Map.empty @con @lhs.aroundMap++SEM Grammar | Grammar+ nonts.aroundMap = @aroundsMap++SEM Child | Child+ loc.hasArounds = case Map.lookup @name @lhs.aroundMap of+ Nothing -> False+ Just as -> not (null as)++-------------------------------------------------------------------------------+-- Determine which children are used by merges+-------------------------------------------------------------------------------++-- Propagate the around-map downward+ATTR Nonterminals Nonterminal+ [ mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression)))} || ]++ATTR Productions Production+ [ mergeMap : {Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression))} || ]++ATTR Children Child+ [ mergeMap : {Map Identifier (Identifier, [Identifier], Expression)} mergedChildren : {Set Identifier} | | ]++SEM Nonterminal | Nonterminal loc.mergeMap = Map.findWithDefault Map.empty @nt @lhs.mergeMap+SEM Production | Production loc.mergeMap = Map.findWithDefault Map.empty @con @lhs.mergeMap++SEM Grammar | Grammar+ nonts.mergeMap = @mergeMap++SEM Production | Production+ loc.mergedChildren = Set.unions [ Set.fromList ms | (_,ms,_) <- Map.elems @loc.mergeMap ]++SEM Child | Child+ loc.merges = maybe Nothing (\(_,ms,_) -> Just ms) $ Map.lookup @name @lhs.mergeMap+ loc.isMerged = @name `Set.member` @lhs.mergedChildren++-------------------------------------------------------------------------------+-- Distribute the ContextMap to nonterminals+-------------------------------------------------------------------------------++ATTR Nonterminals Nonterminal [ classContexts : ContextMap | | ]++SEM Grammar | Grammar+ nonts.classContexts = @contextMap++SEM Nonterminal | Nonterminal+ loc.classContexts = Map.findWithDefault [] @nt @lhs.classContexts++------------------------------------------------------------------------------- -- Gather all rules per production for the execution plan ------------------------------------------------------------------------------- ATTR Expression [ | | copy : SELF ]@@ -54,6 +163,8 @@ @owrt @origin @explicit+ @pure+ @mbError -------------------------------------------------------------------------------@@ -64,7 +175,9 @@ ATTR Children [ | | echilds USE {:} {[]} : EChildren ] SEM Child- | Child lhs.echilds = EChild @name @tp @virtual+ | Child lhs.echilds = case @tp of+ NT _ _ _ -> EChild @name @tp @kind @loc.hasArounds @loc.merges @loc.isMerged+ _ -> ETerm @name @tp ------------------------------------------------------------------------------- -- Dependency graph per production@@ -79,30 +192,32 @@ SEM HsToken | AGLocal lhs.vertices = Set.singleton $ VAttr Loc _LOC @var | AGField lhs.vertices = Set.singleton $ VAttr (if @field == _LHS then Inh- else if @field == _LOC then Loc + else if @field == _LOC then Loc else Syn) @field @attr -- Gather vertices for an expression (make a higher order child) SEM Expression- | Expression lhs.vertices = Set.unions $ map (\tok -> vertices_Syn_HsToken + | Expression lhs.vertices = Set.unions $ map (\tok -> vertices_Syn_HsToken (wrap_HsToken (sem_HsToken tok) Inh_HsToken)) @tks -- Gather vertices at patterns SEM Pattern | Alias loc.vertex = if @field == _INST then VChild @attr else VAttr (if @field == _LHS then Syn- else if @field == _LOC then Loc + else if @field == _LOC then Loc else Inh) @field @attr- lhs.vertices = Set.insert @loc.vertex $ @parts.vertices `Set.union` @pat.vertices+ lhs.vertices = Set.insert @loc.vertex @pat.vertices -- Gather vertices for children+--+-- The behavior for merged children is a bit more complicated (and ignored for now) SEM Child | Child loc.vertex = VChild @name- loc.synvertices = map (VAttr Syn @name) . Map.keys $ @syn- loc.inhvertices = map (VAttr Inh @name) . Map.keys $ @inh+ loc.synvertices = map (VAttr Syn @name) . Map.keys $ @loc.syn+ loc.inhvertices = map (VAttr Inh @name) . Map.keys $ @loc.inh lhs.vertices = case @tp of -- only Nonterminal children need to be in dependency graph- NT _ _ -> Set.insert @loc.vertex (Set.fromList $ @loc.synvertices ++ @loc.inhvertices)- _ -> Set.empty+ NT _ _ _ -> Set.insert @loc.vertex $ Set.fromList (@loc.synvertices ++ @loc.inhvertices)+ _ -> Set.empty -- Add extra vertex for a rule SEM Rule@@ -123,12 +238,58 @@ loc.edgesin = map (flip (,) @loc.vertex) (Set.toList @pattern.vertices) lhs.edges = Set.fromList $ @loc.edgesout ++ @loc.edgesin +-- When a child is defined by a higher order attribute and the late binding option+-- is enabled, we refer to the additional inherited attribute under the hood, hence+-- we need to tell the dependency analysis about this in order to actually have the+-- attribute available when we attach the child.+-- Note that the dependencies on the rule that creates the semantics of the child+-- is handled elsewhere by mapping an "inst"-attribute to the right child vertex.+SEM Child | Child+ loc.childIsDeforested = case @tp of+ NT _ _ defor -> defor+ _ -> False+ loc.higherOrderEdges = case @kind of+ ChildAttr | lateHigherOrderBinding @lhs.options && not @loc.childIsDeforested+ -> [(@loc.vertex, VAttr Inh _LHS idLateBindingAttr)]+ _ -> [] -- attribute is not referenced implicitly+ loc.aroundEdges = if @loc.hasArounds+ then [(@loc.vertex, VAttr Syn _LOC (Ident (getName @name ++ "_around") (getPos @name)))]+ else []+ -- Gather edges for a child SEM Child- | Child loc.edgesout = []+ | Child loc.edgesout = @loc.higherOrderEdges loc.edgesin = map (flip (,) @loc.vertex) @loc.synvertices- lhs.edges = Set.fromList $ @loc.edgesout ++ @loc.edgesin+ lhs.edges = Set.fromList (@loc.edgesout ++ @loc.edgesin) +-- Add manual attribute dependencies+ATTR Nonterminals Nonterminal [ manualDeps : AttrOrderMap | | ]+ATTR Productions Production [ manualDeps : {Map ConstructorIdent (Set Dependency)} | | ]++SEM Grammar | Grammar nonts.manualDeps = @manualAttrOrderMap+SEM Nonterminal | Nonterminal prods.manualDeps = Map.findWithDefault Map.empty @nt @lhs.manualDeps+SEM Production | Production+ loc.manualDeps = Map.findWithDefault Set.empty @con @lhs.manualDeps+ loc.manualEdges = Set.map depToEdge @loc.manualDeps++{+-- a depends on b, thus a is a successor of b+depToEdge :: Dependency -> Edge+depToEdge (Dependency a b) = (occToVertex False b, occToVertex True a)++occToVertex :: Bool -> Occurrence -> Vertex+occToVertex _ (OccRule nm) = VRule nm+occToVertex isDependency (OccAttr c a)+ | c == _LOC = VAttr Syn c a -- local attributes are treated as synthesized attrs of 'loc'+ | c == _INST = VChild a -- higher-order attributes are treated as children+ | otherwise = VAttr kind c a where+ kind | isDependency && c == _LHS = Inh -- these dependencies have the property that+ | isDependency && c /= _LHS = Syn -- they can all be faked by writing a 'const' rule+ | not isDependency && c == _LHS = Syn -- Perhaps we should also allow other forms of dependencies+ | not isDependency && c /= _LHS = Inh -- as well, such as two inherited attributes, which would+ -- force them in different visits+}+ -- Combine all edges for a production SEM Production | Production loc.edges = @rules.edges `Set.union` @children.edges@@ -138,8 +299,8 @@ SEM Child | Child lhs.nontnames = case @tp of- NT nont _ -> [(@name, nont)]- _ -> []+ NT nont _ _ -> [(@name, nont)]+ _ -> [] -- Return a dependency graph for each production ATTR Production [ | | depgraph : {ProdDependencyGraph} ]@@ -151,7 +312,9 @@ , pdgRules = @rules.erules , pdgChilds = @children.echilds , pdgProduction = @con- , pdgChildMap = @children.nontnames }+ , pdgChildMap = @children.nontnames+ , pdgConstraints = @constraints+ , pdgParams = @params } ------------------------------------------------------------------------------- -- Dependency graph per nonterminal@@ -178,18 +341,28 @@ , ndiInh = Map.keys @inh , ndiSyn = Map.keys @syn , ndiDepGraph = @loc.nontgraph- , ndiProds = @prods.depgraph }+ , ndiProds = @prods.depgraph+ , ndiRecursive = @loc.recursive+ , ndiHoInfo = @loc.hoInfo+ , ndiClassCtxs = @loc.classContexts+ } ------------------------------------------------------------------------------- -- Call the kennedy-warren algorithm ------------------------------------------------------------------------------- ATTR Grammar [ | | output : {ExecutionPlan} depgraphs : {PP_Doc}- visitgraph : {PP_Doc} ]+ visitgraph : {PP_Doc}+ errors : {Seq Error} ] SEM Grammar- | Grammar (Just (lhs.output, lhs.depgraphs, lhs.visitgraph)) = kennedyWarrenOrder @wrappers @nonts.depinfo @typeSyns @derivings-+ | Grammar (lhs.output, lhs.depgraphs, lhs.visitgraph, lhs.errors)+ = let lazyPlan = kennedyWarrenLazy @lhs.options @wrappers @nonts.depinfo @typeSyns @derivings+ in if visit @lhs.options+ then case kennedyWarrenOrder @lhs.options @wrappers @nonts.depinfo @typeSyns @derivings of+ Left e -> (lazyPlan,empty,empty,Seq.singleton e)+ Right (o,d,v) -> (o,d,v,Seq.empty)+ else (lazyPlan,empty,empty,Seq.empty) ------------------------------------------------------------------------------- -- Output nonterminal type mappings@@ -203,3 +376,14 @@ SEM Nonterminal | Nonterminal lhs.inhmap = Map.singleton @nt @inh lhs.synmap = Map.singleton @nt @syn++-------------------------------------------------------------------------------+-- Output nonterminal type mappings+-------------------------------------------------------------------------------+ATTR Grammar Nonterminals Nonterminal [ | | localSigMap USE {`Map.union`} {Map.empty} : {Map.Map NontermIdent (Map.Map ConstructorIdent (Map.Map Identifier Type))} ]+ATTR Productions Production [ | | localSigMap USE {`Map.union`} {Map.empty} : {Map.Map ConstructorIdent (Map.Map Identifier Type)} ]+ATTR TypeSigs TypeSig [ | | localSigMap USE {`Map.union`} {Map.empty} : {Map Identifier Type} ]++SEM Nonterminal | Nonterminal lhs.localSigMap = Map.singleton @nt @prods.localSigMap+SEM Production | Production lhs.localSigMap = Map.singleton @con @typeSigs.localSigMap+SEM TypeSig | TypeSig lhs.localSigMap = Map.singleton @name @tp
+ src-ag/Macro.ag view
@@ -0,0 +1,24 @@+--marcos: macros extension++imports+{+import CommonTypes+}++TYPE MaybeMacro = MAYBE Macro++DATA Macro | Macro con : {ConstructorIdent}+ children : MacroChildren+ | None++TYPE MacroChildren = [MacroChild]++DATA MacroChild | RuleChild name : {Identifier}+ macro : Macro+ | ChildChild name : {Identifier}+ child : {Identifier}++ | ValueChild name : {Identifier}+ value : {String}++DERIVING MaybeMacro Macro MacroChildren MacroChild : Show
src-ag/Order.ag view
@@ -1,10 +1,11 @@ PRAGMA strictdata PRAGMA strictwrap ---REMOVED SM INCLUDE "GenerateCodeSM.ag" INCLUDE "Patterns.ag" INCLUDE "Expression.ag" INCLUDE "AbstractSyntax.ag"+INCLUDE "DistChildAttr.ag"+ imports { -- From uuagc@@ -137,8 +138,8 @@ ------------------------------------------------------------------ { getNtName :: Type -> NontermIdent-getNtName (NT nt _) = maybe nt id (deforestedNt nt)-getNtName _ = nullIdent+getNtName (NT nt _ _) = nt+getNtName _ = nullIdent } ------------------------------------------------------------------@@ -175,11 +176,11 @@ SEM Child | Child loc.maptolocal = case @tp of- NT nt _ -> Map.null @syn- _ -> True+ NT nt _ _ -> Map.null @syn+ _ -> True lhs.gathAltAttrs = if @maptolocal then [ AltAttr _LOC @name True ] -- sublist 2b- else [ AltAttr @name syn True | syn <- Map.keys @syn ] -- sublist 2a+ else [ AltAttr @name syn True | syn <- Map.keys @loc.syn ] -- sublist 2a SEM Pattern | Alias lhs.gathAltAttrs = [AltAttr @field @attr (@field == _LOC || @field == _INST)] -- sublist 3 @@ -193,7 +194,7 @@ inhs USE {Seq.><} {Seq.empty} : {Seq (Identifier,Attributes)} ] SEM Child | Child lhs.nts = Seq.singleton (@name,getNtName @tp)- lhs.inhs = Seq.singleton (@name,@inh)+ lhs.inhs = Seq.singleton (@name,@loc.inh) ATTR Rules Rule [ childNts : {Map Identifier NontermIdent} childInhs : {Map Identifier Attributes} | | ]@@ -211,23 +212,21 @@ SEM Child | Child loc.gathRules = if @maptolocal then Seq.singleton (cRuleTerminal @name @lhs.nt @lhs.con @tp)- else Seq.fromList [ cRuleRhsSyn syn @lhs.nt @lhs.con tp @name (getNtName @tp) | (syn,tp) <- Map.assocs @syn]+ else Seq.fromList [ cRuleRhsSyn syn @lhs.nt @lhs.con tp @name (getNtName @tp) | (syn,tp) <- Map.assocs @loc.syn] SEM Rule- | Rule loc.defines = let tp field attr parts | field == _LOC || field == _INST- = case parts of- [] -> Map.lookup attr @lhs.allTypeSigs- _ -> (sequence (map typ parts)) >>= (haskellTupel . map (substSelf @lhs.nt))+ | Rule loc.defines = let tp field attr | field == _LOC || field == _INST+ = Map.lookup attr @lhs.allTypeSigs | field == _LHS = Map.lookup attr @lhs.syn | otherwise = Map.lookup attr (findWithErr1 "Rule.defines.tp" field @lhs.childInhs) typ :: Pattern -> Maybe Type- typ (Alias field attr _ parts) = tp field attr parts+ typ (Alias field attr _) = tp field attr typ (Underscore _) = Nothing -- typ (Product _ pats) = tp _LOC undefined pats typ _ = Nothing - in Map.fromList [ (findWithErr1 "Rule.defines" aa @lhs.altAttrs, (field,attr,(tp field attr parts)))- | (field,attr,isLocalOrInst,parts) <- @pattern.patternAttrs+ in Map.fromList [ (findWithErr1 "Rule.defines" aa @lhs.altAttrs, (field,attr,(tp field attr)))+ | (field,attr,isLocalOrInst) <- @pattern.patternAttrs , let aa = AltAttr field attr isLocalOrInst ] loc.gathRules = let childnt field = Map.lookup field @lhs.childNts@@ -238,18 +237,18 @@ { substSelf nt tp = case tp of- NT n tps | n == _SELF -> NT nt tps- _ -> tp+ NT n tps defor | n == _SELF -> NT nt tps defor+ _ -> tp haskellTupel :: [Type] -> Maybe Type haskellTupel ts = Just ( Haskell ( '(' : (concat (intersperse "," (map show ts))) ++ ")" )) } -ATTR Patterns Pattern [ | | patternAttrs USE {++} {[]} : {[(Identifier,Identifier,Bool,Patterns)]} ]+ATTR Patterns Pattern [ | | patternAttrs USE {++} {[]} : {[(Identifier,Identifier,Bool)]} ] SEM Pattern- | Alias lhs.patternAttrs = [(@field,@attr,(@field == _LOC || @field == _INST),@parts.copy)]+ | Alias lhs.patternAttrs = [(@field,@attr,(@field == _LOC || @field == _INST))] @@ -343,8 +342,8 @@ ATTR Children Child [ | | collectChildrenSyns, collectChildrenInhs USE {`Map.union`} {Map.empty} : {Map Identifier Attributes } ] SEM Child- | Child lhs.collectChildrenSyns = Map.singleton @name @syn- lhs.collectChildrenInhs = Map.singleton @name @inh+ | Child lhs.collectChildrenSyns = Map.singleton @name @loc.syn+ lhs.collectChildrenInhs = Map.singleton @name @loc.inh -- -- Merge stuff@@ -445,7 +444,7 @@ -- Wrapping an Expression ATTR Expression [ nt,con :{Identifier}- allfields:{[(Identifier,Type,Maybe (Maybe Type))]}+ allfields:{[(Identifier,Type,ChildKind)]} allnts :{[Identifier]} attrs :{[(Identifier,Identifier)]} ||@@ -614,7 +613,7 @@ SEM Child | Child lhs.singlevisits = if @maptolocal then []- else [CChildVisit @name (getNtName @tp) 0 @inh @syn True]+ else [CChildVisit @name (getNtName @tp) 0 @loc.inh @loc.syn True] -- Now just build the CGrammar SEM Grammar [ | | output : CGrammar ]@@ -653,7 +652,7 @@ -- Collecting fields ATTR Rule Rules- Child Children [allfields:{[(Identifier,Type,Maybe (Maybe Type))]} attrs:{[(Identifier,Identifier)]} | | ]+ Child Children [allfields:{[(Identifier,Type,ChildKind)]} attrs:{[(Identifier,Identifier)]} | | ] SEM Production | Production loc.allfields = @children.fields@@ -666,13 +665,13 @@ ATTR Children [ | | attributes USE {++} {[]} : {[(Identifier,Attributes,Attributes)]} ] SEM Child [ | | attributes:{[(Identifier,Attributes,Attributes)]} ]- | Child lhs.attributes = [(@name, @inh, @syn)]+ | Child lhs.attributes = [(@name, @loc.inh, @loc.syn)] -SEM Child [ | | field : {(Identifier,Type,Maybe (Maybe Type))} ]- | Child lhs.field = (@name, @tp, @virtual)+SEM Child [ | | field : {(Identifier,Type,ChildKind)} ]+ | Child lhs.field = (@name, @tp, @kind) -SEM Children [ | | fields : {[(Identifier,Type,Maybe (Maybe Type))]} ]+SEM Children [ | | fields : {[(Identifier,Type,ChildKind)]} ] | Cons lhs.fields = @hd.field : @tl.fields | Nil lhs.fields = []
src-ag/Patterns.ag view
@@ -14,7 +14,6 @@ | Alias field : {Identifier} attr : {Identifier} pat : Pattern- parts : Patterns | Irrefutable pat : Pattern | Underscore pos : {Pos}
src-ag/PrintCode.ag view
@@ -17,7 +17,8 @@ import Data.List(intersperse) import System.IO import System.Directory-import CommonTypes(BlockInfo, BlockType(..), identifier)+import System.FilePath+import CommonTypes(BlockInfo, BlockKind(..), identifier) } {@@ -41,8 +42,8 @@ SEM Chunk | Chunk loc.outputfile = if sepSemMods @lhs.options- then @lhs.mainFile ++ "_" ++ @name ++ ".hs"- else @lhs.mainFile ++ ".hs"+ then replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_" ++ @name)+ else @lhs.mainFile ATTR Program [ options:{Options} | | output:{PP_Docs} ] @@ -282,7 +283,10 @@ .pp = if reallySimple @txt then text @txt else pp_parens (text @txt) | NontermType lhs.prec = 5- lhs.pp = text @name >#< hv_sp @params+ lhs.pp = @loc.prefix >|< text @name >#< hv_sp @params+ loc.prefix = if @deforested+ then text "T_"+ else empty | TMaybe lhs.prec = 5 lhs.pp = text "Maybe" >#< @tp.pp | TEither lhs.prec = 5@@ -423,7 +427,7 @@ -- Alternative code printing to separate modules ------------------------------------------------------------------------------- -ATTR Program [ | | genIO : {IO ()} ]+ATTR Program [ mainBlocksDoc : PP_Doc | | genIO : {IO ()} ] ATTR Program Chunks Chunk [ importBlocks : PP_Doc pragmaBlocks : String@@ -437,7 +441,7 @@ SEM Program | Program- loc.mainModuleFile = @lhs.mainFile ++ ".hs"+ loc.mainModuleFile = @lhs.mainFile loc.genMainModule = writeModule @loc.mainModuleFile ( [ pp $ @lhs.pragmaBlocks@@ -447,9 +451,10 @@ ] ++ map pp @chunks.imports ++ map vlist @chunks.appendMain+ ++ [@lhs.mainBlocksDoc] ) - loc.commonFile = @lhs.mainFile ++ "_common.hs"+ loc.commonFile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_common") loc.genCommonModule = writeModule @loc.commonFile ( [ pp $ @lhs.pragmaBlocks
src-ag/PrintErrorMessages.ag view
@@ -8,10 +8,17 @@ import Options import Data.List(mapAccumL,intersect,(\\)) import GrammarInfo+import qualified Control.Monad.Error.Class as Err } +{+instance Err.Error Error where+ noMsg = Err.strMsg "error"+ strMsg = CustomError False noPos . pp+} + { isError :: Options -> Error -> Bool isError opts (ParserError _ _ _ ) = True@@ -45,6 +52,10 @@ isError opts (MissingNamedRule _ _ _) = True isError opts (DupRuleName _ _ _) = True isError opts (HsParseError _ _) = True+isError opts (Cyclic _ _ _) = True+isError opts (IncompatibleVisitKind _ _ _ _) = True+isError opts (IncompatibleRuleKind _ _) = True+isError opts (IncompatibleAttachKind _ _) = True cycleIsDangerous :: Options -> Bool cycleIsDangerous opts@@ -379,6 +390,21 @@ act = wfill ["The nonterminal set", getName @name, "is considered to be empty."] in ppError (isError @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose + | Cyclic lhs.pp = let pos = getPos @nt+ mesg = text "Circular dependency for nonterminal" >#< getName @nt+ >#< ( case @mbCon of+ Nothing -> empty+ Just con -> text "and constructor" >#< con+ )+ >#< ( case @verts of+ v : _ -> text "including vertex" >#< text v+ _ -> empty+ )+ pat = text "cyclic rule definition"+ help = hlist (text "The following attributes are all cyclic: " : map text @verts)+ act = wfill ["code cannot be generated until the cycle is removed."]+ in ppError (isError @lhs.options @me) pos mesg pat help act False+ | CustomError lhs.pp = let pat = text "unknown" help = wfill ["not available."] act = wfill ["unknown"]@@ -501,6 +527,25 @@ ] act = wfill ["It is not possible to proceed without this declaration."] in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose+ | IncompatibleVisitKind+ lhs.pp = let mesg = "visit" >#< @vis >#< "of child" >#< @child >#< " with kind" >#< show @to >#< " cannot be called from a visit with kind " >#< show @from+ pat = empty+ help = empty+ act = text "It is not possible to proceed without fixing this kind error."+ in ppError (isError @lhs.options @me) (getPos @child) mesg pat help act @lhs.verbose+ | IncompatibleRuleKind+ lhs.pp = let mesg = "rule" >#< @rule >#< "cannot be called from a visit with kind " >#< show @kind+ pat = empty+ help = empty+ act = text "It is not possible to proceed without fixing this kind error."+ in ppError (isError @lhs.options @me) (getPos @rule) mesg pat help act @lhs.verbose++ | IncompatibleAttachKind+ lhs.pp = let mesg = "child" >#< @child >#< "cannot be called from a visit with kind " >#< show @kind+ pat = empty+ help = empty+ act = text "It is not possible to proceed without fixing this kind error."+ in ppError (isError @lhs.options @me) (getPos @child) mesg pat help act @lhs.verbose { toWidth n xs | k<n = xs ++ replicate (n-k) ' '
src-ag/ResolveLocals.ag view
@@ -1,6 +1,7 @@ INCLUDE "AbstractSyntax.ag" INCLUDE "Patterns.ag" INCLUDE "Expression.ag"+INCLUDE "DistChildAttr.ag" --@@ -67,7 +68,7 @@ -- Collecting fields ATTR Rule Rules- Child Children [allfields:{[(Identifier,Type,Maybe (Maybe Type))]} attrs:{[(Identifier,Identifier)]} | | ]+ Child Children [allfields:{[(Identifier,Type,ChildKind)]} attrs:{[(Identifier,Identifier)]} | | ] SEM Production | Production loc.allfields = @children.fields@@ -80,12 +81,12 @@ ATTR Children [ | | attributes USE {++} {[]} : {[(Identifier,Attributes,Attributes)]} ] SEM Child [ | | attributes:{[(Identifier,Attributes,Attributes)]} ]- | Child lhs.attributes = [(@name, @inh, @syn)]+ | Child lhs.attributes = [(@name, @loc.inh, @loc.syn)] -SEM Child [ | | field : {(Identifier,Type,Maybe (Maybe Type))} ]- | Child lhs.field = (@name, @tp, @virtual)+SEM Child [ | | field : {(Identifier,Type,ChildKind)} ]+ | Child lhs.field = (@name, @tp, @kind) -SEM Children [ | | fields : {[(Identifier,Type,Maybe (Maybe Type))]} ]+SEM Children [ | | fields : {[(Identifier,Type,ChildKind)]} ] | Cons lhs.fields = @hd.field : @tl.fields | Nil lhs.fields = [] @@ -135,7 +136,7 @@ -- ATTR Expression [ nt,con :{Identifier}- allfields:{[(Identifier,Type,Maybe (Maybe Type))]}+ allfields:{[(Identifier,Type,ChildKind)]} allnts :{[Identifier]} attrs :{[(Identifier,Identifier)]} || ]
src-ag/SemHsTokens.ag view
@@ -27,7 +27,7 @@ ------------------------------------------------------------------------------- ATTR HsTokensRoot HsTokens HsToken [ nt,con : {Identifier}- allfields : {[(Identifier,Type,Maybe (Maybe Type))]}+ allfields : {[(Identifier,Type,ChildKind)]} allnts : {[Identifier]} attrs : {[(Identifier,Identifier)]} ||@@ -55,8 +55,8 @@ ------------------------------------------------------------------------------- {-isNTname allnts (Just (NT nt _)) = nt `elem` allnts-isNTname allnts _ = False+isNTname allnts (Just (NT nt _ _)) = nt `elem` allnts+isNTname allnts _ = False }
src-ag/TfmToVisage.ag view
@@ -4,20 +4,23 @@ INCLUDE "AbstractSyntax.ag" INCLUDE "Patterns.ag" INCLUDE "Expression.ag"+INCLUDE "DistChildAttr.ag" imports { import AbstractSyntax import VisagePatterns import VisageSyntax+import qualified Data.Map as Map+import Data.Map (Map) } {--- Maps a rule to a pair +-- Maps a rule to a pair -- Later, I expect to map to a list of rules, because we might need to unfold. -- Checks that a certain alias is in fact a Var in the old representation of the AG system-isVar (Alias _ _ (Underscore _) _) = True+isVar (Alias _ _ (Underscore _)) = True isVar _ = False type VisageRuleMap = [(String, VisageRule)]@@ -40,7 +43,7 @@ [("lhs", (lhs.x,_,_) = (0,1,2) At this point, we do not use this anymore.- + allways :: VisageRule -> VisageRuleMap allways vr@(VRule vrfields _ _ _ _) = zip vrfields (map (underScoreRule vr) (nub vrfields)) @@ -51,19 +54,19 @@ underScoreRule (VRule fields pat expr owrt rule) s = VRule fields (underScore s pat) expr owrt rule underScore :: String -> VisagePattern -> VisagePattern-underScore field (VConstr name pats) = VConstr name (map (underScore field) pats) +underScore field (VConstr name pats) = VConstr name (map (underScore field) pats) underScore field (VProduct pos pats) = VProduct pos (map (underScore field) pats)-underScore field vp@(VVar vfield attr) = - if (field == getName vfield) +underScore field vp@(VVar vfield attr) =+ if (field == getName vfield) then vp else (VUnderscore (getPos vfield)) -- Should I recurse into the pat of VAlias? underScore field vp@(VAlias afield attr pat) =- if (field == getName afield) + if (field == getName afield) then vp else (VUnderscore (getPos afield)) underScore field vp@(VUnderscore pos) = vp- + -} } @@ -115,7 +118,7 @@ | Nil lhs.vchildren = [] SEM Child- | Child lhs.vchild = VChild @name @tp @inh @syn (getForField (getName @name) @lhs.rulemap)+ | Child lhs.vchild = VChild @name @tp @loc.inh @loc.syn (getForField (getName @name) @lhs.rulemap) SEM Rules | Cons lhs.vrules = @hd.vrule : @tl.vrules@@ -132,13 +135,13 @@ SEM Pattern | Constr lhs.vpat = VConstr @name @pats.vpats | Product lhs.vpat = VProduct @pos @pats.vpats- | Alias lhs.vpat = if (isVar @self) + | Alias lhs.vpat = if (isVar @self) then VVar @field @attr else VAlias @field @attr @pat.vpat | Underscore lhs.vpat = VUnderscore @pos -- All (field,attrs) in a pattern-ATTR Patterns -> Pattern [ | | fieldattrs USE { ++ } { [] } : { [(Identifier,Identifier)] } ] +ATTR Patterns -> Pattern [ | | fieldattrs USE { ++ } { [] } : { [(Identifier,Identifier)] } ] SEM Pattern | Alias lhs.fieldattrs = [(@field, @attr)]
src-ag/Transform.ag view
@@ -11,7 +11,7 @@ import Data.Maybe import qualified Data.Map as Map import Data.Map (Map)-import Data.Set as Set (Set, member, union, toList, fromList, empty, singleton, member, unions, size, fold, intersection, difference, insert)+import Data.Set as Set (Set, member, union, toList, fromList, empty, singleton, member, unions, size, fold, intersection, difference, insert, elems) import qualified Data.Sequence as Seq import Data.Sequence(Seq, empty, (><),fromList) import Data.Foldable(toList)@@ -27,6 +27,7 @@ import Options import CommonTypes import RhsCheck+import Debug.Trace } @@ -51,7 +52,9 @@ SEM AG | AG lhs.output = constructGrammar @loc.allNonterminals @elems.paramsCollect+ @loc.allConParams @loc.allFields+ @loc.allConstraints @loc.allAttrDecls @elems.useMap @elems.derivings@@ -68,6 +71,7 @@ @loc.checkedAugments @loc.checkedArounds @loc.checkedMerges+ @loc.allMacros -------------------------------------------------------------------------------@@ -86,7 +90,7 @@ ATTR Elem Elems [ | | collectedSetNames USE {`Set.union`} {Set.empty} : {Set Identifier} ] ATTR Elem Elems NontSet [ | | collectedNames USE {`Set.union`} {Set.empty} : {Set Identifier} ] -- top-down distribution-ATTR Elem Elems Attrs Alts Alt NontSet [ allNonterminals : {Set NontermIdent} | | ]+ATTR Elem Elems Attrs Alts Alt Fields Field NontSet [ allNonterminals : {Set NontermIdent} | | ] -- Constructors that are in use@@ -123,7 +127,10 @@ {type DataTypes = Map.Map NontermIdent (Map.Map ConstructorIdent FieldMap) } -- bottom-up collection ATTR Alt Alts Elem Elems- [ | | collectedFields USE {++} {[]} : {[(NontermIdent, ConstructorIdent, FieldMap)]}]+ [ | | collectedFields USE {++} {[]} : {[(NontermIdent, ConstructorIdent, FieldMap)]}+ collectedConstraints USE {++} {[]} : {[(NontermIdent, ConstructorIdent, [Type])]}+ collectedConParams USE {++} {[]} : {[(NontermIdent, ConstructorIdent, Set Identifier)]}+ ] -- top-down distribution ATTR Elem Elems Attrs SemAlt SemAlts NontSet [ allFields : {DataTypes} | | ]@@ -141,7 +148,7 @@ -- Attribute definitions {type AttrName = (Identifier,Identifier) }-{type RuleInfo = (Maybe Identifier, [AttrName]->Pattern, Expression, [AttrName], Bool, String) }+{type RuleInfo = (Maybe Identifier, [AttrName]->Pattern, Expression, [AttrName], Bool, String, Bool, Bool) } {type SigInfo = (Identifier,Type) } {type UniqueInfo = (Identifier,Identifier) } {type AugmentInfo = (Identifier,Expression)}@@ -178,12 +185,7 @@ ------------------------------------------------------------------------------- SEM Elem- | Txt loc.blockInfo = ( let nm = getName @name- in if nm == "imports"- then BlockImport- else if nm == "optpragmas"- then BlockPragma- else BlockOther+ | Txt loc.blockInfo = ( @kind , @mbNt ) loc.blockValue = [(@lines, @pos)]@@ -236,14 +238,18 @@ SEM Alt- | Alt lhs.collectedFields = let fieldTable =- [ (attr, makeType @lhs.allNonterminals tp)- | (attr, tp) <- @fields+ | Alt lhs.collectedFields = [ (nt, con, @fields.collectedFields)+ | nt <- Set.toList @lhs.nts+ , con <- Set.toList (@names.constructors (Map.findWithDefault Set.empty nt @lhs.allConstructors)) ]- in [ (nt, con, fieldTable)+ lhs.collectedConstraints = [ (nt, con, @fields.collectedConstraints) | nt <- Set.toList @lhs.nts , con <- Set.toList (@names.constructors (Map.findWithDefault Set.empty nt @lhs.allConstructors)) ]+ lhs.collectedConParams = [ (nt, con, Set.fromList @tyvars)+ | nt <- Set.toList @lhs.nts+ , con <- Set.toList (@names.constructors (Map.findWithDefault Set.empty nt @lhs.allConstructors))+ ] SEM Elem | Type lhs.collectedFields = map (\(x,y)->(@name, x, y)) @loc.expanded@@ -254,6 +260,12 @@ loc.allFields = let f (nt,con,fm) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con fm) in foldr f (Map.empty) @elems.collectedFields + loc.allConstraints = let f (nt,con,fm) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con fm)+ in foldr f (Map.empty) @elems.collectedConstraints++ loc.allConParams = let f (nt,con,fm) = Map.insertWith (Map.unionWith Set.union) nt (Map.singleton con fm)+ in foldr f (Map.empty) @elems.collectedConParams+ loc.allConstrs = let f (nt,con,_) = Map.insertWith (++) nt [con] in foldr f (Map.empty) @elems.collectedFields @@ -354,7 +366,7 @@ NontermIdent -> ConstructorIdent -> [RuleInfo] -> RulesAndErrors checkRules attributes fields allinsts allsigs allmerges nt con rs = let fieldmap :: FieldMap- fieldmap = (_LHS,NT nt undefined) : (_LOC,NT undefined undefined) : (_INST, NT undefined undefined) : (_FIRST, NT undefined undefined) : (_LAST, NT undefined undefined)+ fieldmap = (_LHS, NT nt [] False) : (_LOC, NT nullIdent [] False) : (_INST, NT nullIdent [] False) : (_FIRST, NT nullIdent [] False) : (_LAST, NT nullIdent [] False) : Map.findWithDefault [] con (Map.findWithDefault Map.empty nt fields) ++ mapMaybe (\instNm -> lookup instNm sigs >>= \tp -> return (instNm, tp)) (Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allinsts)) -- merged children are not allowed to have any inherited attrs defined: do not include@@ -364,14 +376,14 @@ hasAttrib f tp attr = Map.member attr (f (Map.findWithDefault (Map.empty,Map.empty) tp attributes)) checkRule :: RuleInfo -> AccumRuleCheck -> AccumRuleCheck- checkRule (mbNm, pat,exp,as,owrt,str) ((r1,e1),m1)+ checkRule (mbNm, pat,exp,as,owrt,str, pur, eager) ((r1,e1),m1) = let (e2,m2,u2,b2) = foldr (checkDefi owrt) (e1,m1,[],[]) as- in ( (Rule mbNm (pat u2) exp owrt str True : r1, e2), m2)+ in ( (Rule mbNm (pat u2) exp owrt str True pur False Nothing eager : r1, e2), m2) checkDefi :: Bool -> AttrName -> AccumDefiCheck -> AccumDefiCheck checkDefi owrt fa@(field,attr) (e,m,u,bs) = case lookup field fieldmap- of Just (NT tp _) ->+ of Just (NT tp _ _) -> let tp' = maybe tp id (deforestedNt tp) in if field == _LOC || field == _INST || field == _FIRST || field == _LAST || hasAttrib (if getName field==getName _LHS then snd else fst) tp' attr@@ -390,10 +402,10 @@ checkRuleNames nt con = fst . foldr checkRule (Seq.empty, Set.empty) where- checkRule (Just nm,_,_,_,_,_) (errs, nms)+ checkRule (Just nm,_,_,_,_,_,_,_) (errs, nms) | nm `Set.member` nms = (DupRuleName nt con nm Seq.<| errs, nms) | otherwise = (errs, Set.insert nm nms)- checkRule (Nothing,_,_,_,_,_) inp = inp+ checkRule (Nothing,_,_,_,_,_,_,_) inp = inp checkSigs :: NontermIdent -> ConstructorIdent -> [SigInfo] -> SigsAndErrors checkSigs nt con sis@@ -409,14 +421,15 @@ checkInsts allNts sigMap fieldMap nt con = foldr (\inst (insts, errs) -> maybe (insts, Seq.singleton (MissingInstSig nt con inst) >< errs)- (\info@(k, NT nm _) ->+ (\info@(k, NT nm args _) -> case findInst k insts of Just k' -> (insts, Seq.singleton (DupChild nt con k k') >< errs) Nothing -> case nm `Set.member` allNts of True -> (info : insts, errs)- False | take 2 (getName nm) == "T_" -> let nm' = Ident (drop 2 (getName nm)) (getPos nm)+ False | take 2 (getName nm) == "T_" -> let nm' = Ident (drop 2 (getName nm)) (getPos nm)+ info' = (k, NT nm' args True) -- this should be the only place at which 'for' with value True can be generated in case nm' `Set.member` allNts of- True -> (info : insts, errs)+ True -> (info' : insts, errs) False -> (insts, Seq.singleton (UndefNont nm') >< errs) | otherwise -> (insts, Seq.singleton (UndefNont nm) >< errs) )@@ -426,7 +439,7 @@ sigs = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt sigMap) findSig name- = do tp@(NT _ _) <- lookup name sigs+ = do tp@(NT _ _ _) <- lookup name sigs return (name, tp) findInst _ [] = Nothing@@ -464,8 +477,8 @@ = if ident `Map.member` as then (Map.update (\vs -> Just (vs ++ [expr])) ident as, errs) else case lookup ident fields of- Just (NT _ _) -> (Map.insert ident [expr] as, errs)- _ -> (as, ((Seq.<|)) (UndefChild nt con ident) errs)+ Just (NT _ _ _) -> (Map.insert ident [expr] as, errs)+ _ -> (as, ((Seq.<|)) (UndefChild nt con ident) errs) fields = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt fieldMap) in foldr checkAround (Map.empty, Seq.empty) arounds @@ -502,7 +515,7 @@ groups = Map.assocs $ Map.foldrWithKey (\i r m -> Map.insertWith (++) r [i] m) Map.empty usMap apply (ref,us) = mkRule ref (findOutField ref) us- findOutField ref = case [ chld | (chld,NT tp _) <- fields, tp `hasSyn` ref] of+ findOutField ref = case [ chld | (chld, NT tp _ _) <- fields, tp `hasSyn` ref] of [] -> _LHS (x:_) -> x hasSyn tp ref = Map.member ref $ snd $ Map.findWithDefault (Map.empty,Map.empty) tp allAttrDecls@@ -510,8 +523,8 @@ = let pat = Product noPos (attr outFld ref : [attr _LOC u | u <- locAttrs ]) rhs = Expression noPos $ wrap ref $ foldr gencase (finalout locAttrs) locAttrs -- [HsToken ("mkUniques" ++ show (length locAttrs) ++ " ") noPos, AGField _LHS ref noPos Nothing]- in Rule Nothing pat rhs False "-- generated by the unique rule mechanism." False- attr fld a = Alias fld a (Underscore noPos) []+ in Rule Nothing pat rhs False "-- generated by the unique rule mechanism." False True False Nothing False+ attr fld a = Alias fld a (Underscore noPos) gencase nm outp = h ("case " ++ uniqueDispenser opts ++ " __cont of { (__cont, " ++ getName nm ++ ") -> ") ++ outp ++ h "}" h s = [HsToken s noPos]@@ -541,8 +554,25 @@ _ -> Seq.empty else Seq.empty +-------------------------------------------------------------------------------+-- Collecting fields+------------------------------------------------------------------------------- +ATTR Fields Field [ | | collectedFields USE {++} {[]} : {[(Identifier, Type)]} ]++SEM Field | FChild+ lhs.collectedFields = [(@name, makeType @lhs.allNonterminals @tp)]+ -------------------------------------------------------------------------------+-- Collecting constraints+-------------------------------------------------------------------------------++ATTR Fields Field [ | | collectedConstraints USE {++} {[]} : {[Type]} ]++SEM Field | FCtx+ lhs.collectedConstraints = @tps++------------------------------------------------------------------------------- -- Collecting Set names and Nonterminal names ------------------------------------------------------------------------------- @@ -608,7 +638,7 @@ SEM Elem | Type loc.expanded = case @argType of List tp -> [(Ident "Cons" @pos, [(Ident "hd" @pos, tp)- ,(Ident "tl" @pos, NT @name (map getName @params))+ ,(Ident "tl" @pos, NT @name (map getName @params) False) ] ) ,(Ident "Nil" @pos, [])@@ -624,16 +654,24 @@ ] Map tp1 tp2 -> [ (Ident "Entry" @pos, [ (Ident "key" @pos, tp1) , (Ident "val" @pos, tp2)- , (Ident "tl" @pos, NT @name (map getName @params))+ , (Ident "tl" @pos, NT @name (map getName @params) False) ]) , (Ident "Nil" @pos, []) ] IntMap tp -> [ (Ident "Entry" @pos, [ (Ident "key" @pos, Haskell "Int") , (Ident "val" @pos, tp)- , (Ident "tl" @pos, NT @name (map getName @params))+ , (Ident "tl" @pos, NT @name (map getName @params) False) ]) , (Ident "Nil" @pos, []) ]+ OrdSet tp -> [ (Ident "Entry" @pos, [ (Ident "val" @pos, tp)+ , (Ident "tl" @pos, NT @name (map getName @params) False) ])+ , (Ident "Nil" @pos, [])+ ]+ IntSet -> [ (Ident "Entry" @pos, [ (Ident "val" @pos, Haskell "Int")+ , (Ident "tl" @pos, NT @name (map getName @params) False) ])+ , (Ident "Nil" @pos, [])+ ] Tuple xs -> [(Ident "Tuple" @pos, xs)] loc.argType = case @type of Maybe tp -> Maybe ( makeType @lhs.allNonterminals tp)@@ -642,6 +680,8 @@ Tuple xs -> Tuple [(f,makeType @lhs.allNonterminals tp) | (f,tp) <- xs] Map tp1 tp2 -> Map ( makeType @lhs.allNonterminals tp1) (makeType @lhs.allNonterminals tp2) IntMap tp -> IntMap ( makeType @lhs.allNonterminals tp)+ OrdSet tp -> OrdSet ( makeType @lhs.allNonterminals tp)+ IntSet -> IntSet lhs.typeSyns = [(@name,@argType)] -------------------------------------------------------------------------------@@ -692,7 +732,7 @@ { flattenDatas :: DataTypes -> Map NontermIdent (Set NontermIdent) flattenDatas ds = Map.map flatten ds- where flatten cs = Set.fromList [ nt | (_,NT nt _) <- concatMap snd (Map.toList cs)]+ where flatten cs = Set.fromList [ nt | (_, NT nt _ _) <- concatMap snd (Map.toList cs)] reachableFrom :: Map NontermIdent (Set NontermIdent) -> Set NontermIdent -> Set NontermIdent reachableFrom table nts = reach nts@@ -751,6 +791,7 @@ "gencatas" -> o { folds = True } "nogencatas" -> o { folds = False } "gendatas" -> o { dataTypes = True }+ "datarecords" -> o { dataRecords = True } "nogendatas" -> o { dataTypes = False } "gensems" -> o { semfuns = True } "nogensems" -> o { semfuns = False }@@ -789,10 +830,38 @@ "nonewtypes" -> o { newtypes = False } "nooptimizations" -> o { noOptimizations = True } "kennedywarren" -> o { kennedyWarren = True }+ "aspectag" -> o { genAspectAG = True }+ 'n':'o':'g':'r':'o':'u':'p':'_':atts+ -> o { noGroup = extract atts ++ noGroup o } "rename" -> o { rename = True }- _ -> o+ "parallel" -> o { parallelInvoke = True }+ "monadicwrappers" -> o { monadicWrappers = True }++ "dummytokenvisit" -> o { dummyTokenVisit = True }+ "tupleasdummytoken" -> o { tupleAsDummyToken = True }+ "stateasdummytoken" -> o { tupleAsDummyToken = False }+ "strictdummytoken" -> o { strictDummyToken = True }+ "noperruletypesigs" -> o { noPerRuleTypeSigs = True }+ "noperstatetypesigs" -> o { noPerStateTypeSigs = True }+ "noeagerblackholing" -> o { noEagerBlackholing = True }+ "noperrulecostcentres" -> o { noPerRuleCostCentres = True }+ "nopervisitcostcentres" -> o { noPerVisitCostCentres = True }+ "helpinlining" -> o { helpInlining = True }+ "noinlinepragmas" -> o { noInlinePragmas = True }+ "aggressiveinlinepragmas" -> o { aggressiveInlinePragmas = True }+ "latehigherorderbindings" -> o { lateHigherOrderBinding = True }++ s -> trace ("uuagc: ignoring unknown pragma: " ++ s) o in \o -> foldr mk o @names +{+extract s = case dropWhile isSeparator s of+ "" -> []+ s' -> w : extract s''+ where (w, s'') = break isSeparator s'+isSeparator x = x == '_'+}+ ATTR Elem Elems SemAlts SemAlt [ | | semPragmasCollect USE {`pragmaMapUnion`} {Map.empty} : {PragmaMap} ] SEM SemAlt@@ -986,7 +1055,7 @@ -- Add declaration of self-attribute for each nonterminal: ATTR <nt> [ | | self:SELF] { addSelf name atMap = let (eInh,eSyn) = Map.findWithDefault(Map.empty,Map.empty) name atMap- in Map.insert name (eInh, Map.insert (Ident "self" noPos) (NT _SELF []) eSyn)atMap+ in Map.insert name (eInh, Map.insert (Ident "self" noPos) Self eSyn)atMap } @@ -1067,7 +1136,7 @@ ] SEM SemDef- | Def lhs.ruleInfos = [ (@mbName, @pattern.patunder, @rhs, @pattern.definedAttrs, @owrt, show @pattern.stpos) ]+ | Def lhs.ruleInfos = [ (@mbName, @pattern.patunder, @rhs, @pattern.definedAttrs, @owrt, show @pattern.stpos, @pure, @eager) ] SEM SemDef | TypeDef lhs.sigInfos = [ (@ident, @tp) ]@@ -1127,15 +1196,16 @@ ------------------------------------------------------------------------------- { makeType :: Set NontermIdent -> Type -> Type-makeType nts tp@(NT x _) | x == _SELF = tp- | Set.member x nts = tp- | otherwise = Haskell (typeToHaskellString Nothing [] tp)-makeType _ tp = tp+makeType nts tp@(NT x _ _) | Set.member x nts = tp+ | otherwise = Haskell (typeToHaskellString Nothing [] tp)+makeType _ tp = tp } { constructGrammar :: Set NontermIdent -> ParamMap+ -> Map NontermIdent (Map ConstructorIdent (Set Identifier)) -> DataTypes+ -> Map NontermIdent (Map ConstructorIdent [Type]) -> Map NontermIdent (Attributes, Attributes) -> Map NontermIdent (Map Identifier (String, String, String)) -> Derivings@@ -1152,9 +1222,10 @@ -> Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression])) -> Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression])) -> Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression)))+ -> Map NontermIdent (Map ConstructorIdent MaybeMacro) -> Grammar -constructGrammar nts ntParams gram attrs uses derivings wrappers allrules tsigs allinsts tsyns pragmaMap orderMap contextMap quantMap uniqueMap augmentsMap aroundsMap mergeMap =+constructGrammar nts ntParams prodParams gram constraints attrs uses derivings wrappers allrules tsigs allinsts tsyns pragmaMap orderMap contextMap quantMap uniqueMap augmentsMap aroundsMap mergeMap macros = let gr = [ (nt,Map.toList alts) | (nt,alts) <- Map.toList gram] nonts = map nont gr nont (nt,alts) = let (inh,syn) = Map.findWithDefault (Map.empty,Map.empty) nt attrs@@ -1163,11 +1234,17 @@ instsmap = Map.findWithDefault Map.empty nt allinsts params = Map.findWithDefault [] nt ntParams mergemap = Map.findWithDefault Map.empty nt mergeMap+ macromap = Map.findWithDefault Map.empty nt macros+ csmap = Map.findWithDefault Map.empty nt constraints+ psmap = Map.findWithDefault Map.empty nt prodParams alt (con,flds) =- let rules = maybe [] id (Map.lookup con rmap)- tsigs = maybe [] id (Map.lookup con tsmap)- insts = maybe [] id (Map.lookup con instsmap)- merges = [ (n, NT t []) | (n, (t, _, _)) <- Map.assocs $ maybe Map.empty id (Map.lookup con mergemap) ]+ let rules = Map.findWithDefault [] con rmap+ tsigs = Map.findWithDefault [] con tsmap+ insts = Map.findWithDefault [] con instsmap+ merges = [ (n, NT t [] False) | (n, (t, _, _)) <- Map.assocs $ maybe Map.empty id (Map.lookup con mergemap) ]+ cs = Map.findWithDefault [] con csmap+ ps = Set.elems $ Map.findWithDefault Set.empty con psmap+ mbMacro = Map.findWithDefault Nothing con macromap -- important: keep order of children cldrn = map child (flds ++ filter (not . existsAsField) insts ++ merges)@@ -1175,22 +1252,18 @@ let tpI = if existsAsInst nm then fromJust $ lookup nm insts else tp- (inh,syn) = case tpI of- NT nt _ -> let nt' = maybe nt id (deforestedNt nt)- in Map.findWithDefault (Map.empty,Map.empty) nt' attrs- _ -> (Map.empty,Map.empty) virt = if existsAsInst nm then case lookup nm flds of- Just tp' -> Just (Just tp')- Nothing -> Just Nothing+ Just tp' -> ChildReplace tp'+ Nothing -> ChildAttr else if existsAsMerge nm- then (Just Nothing)- else Nothing- in Child nm tpI inh syn virt+ then ChildAttr+ else ChildSyntax+ in Child nm tpI virt existsAsInst nm = maybe False (const True) (lookup nm insts) existsAsField (nm,_) = maybe False (const True) (lookup nm flds) existsAsMerge nm = maybe False (const True) (lookup nm merges)- in Production con cldrn rules tsigs+ in Production con ps cs cldrn rules tsigs mbMacro in Nonterminal nt params inh syn (map alt alts) in Grammar tsyns uses derivings wrappers nonts pragmaMap orderMap ntParams contextMap quantMap uniqueMap augmentsMap aroundsMap mergeMap }@@ -1200,8 +1273,31 @@ mapUnionWithPlusPlus = Map.unionWith (++) } + --marcos -------------------------------------------------------------------------------+-- Collecting Macro information+-------------------------------------------------------------------------------++ATTR Alt Alts Elem Elems+ [ | | collectedMacros USE {++} {[]} : {[(NontermIdent, ConstructorIdent, MaybeMacro)]}]+++SEM Alt+ | Alt lhs.collectedMacros = [ (nt, con, @macro)+ | nt <- Set.toList @lhs.nts+ , con <- Set.toList (@names.constructors (Map.findWithDefault Set.empty nt @lhs.allConstructors))+ ]+++SEM AG+ | AG++ loc.allMacros = let f (nt,con,m) = Map.insertWith (Map.union) nt (Map.singleton con m)+ in foldr f (Map.empty) @elems.collectedMacros+++------------------------------------------------------------------------------- -- Collecting the AGI information ------------------------------------------------------------------------------- @@ -1230,4 +1326,5 @@ else Map.insert nt (Map.fromList @inherited, Map.fromList @synthesized) decls in foldl insert @lhs.attrs (Set.toList @lhs.nts)+
src/Ag.hs view
@@ -6,10 +6,11 @@ import Data.List (isSuffixOf,nub) import Control.Monad (zipWithM_) import Data.Maybe+import System.FilePath import qualified Data.Set as Set import qualified Data.Map as Map-import qualified Data.Sequence as Seq ((><))+import qualified Data.Sequence as Seq ((><),null) import Data.Foldable(toList) import Pretty @@ -25,7 +26,7 @@ import qualified KWOrder as Pass3a (sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) import qualified GenerateCode as Pass4 (sem_CGrammar, wrap_CGrammar, Syn_CGrammar(..), Inh_CGrammar(..)) import qualified PrintVisitCode as Pass4a (sem_CGrammar, wrap_CGrammar, Syn_CGrammar(..), Inh_CGrammar(..))-import qualified ExecutionPlan2Hs as Pass4b (sem_ExecutionPlan, wrap_ExecutionPlan, Syn_ExecutionPlan(..), Inh_ExecutionPlan(..))+import qualified ExecutionPlan2Hs as Pass4b (sem_ExecutionPlan, wrap_ExecutionPlan, Syn_ExecutionPlan(..), Inh_ExecutionPlan(..), warrenFlagsPP) import qualified PrintCode as Pass5 (sem_Program, wrap_Program, Syn_Program (..), Inh_Program (..)) import qualified PrintOcamlCode as Pass5a (sem_Program, wrap_Program, Syn_Program (..), Inh_Program (..)) import qualified PrintErrorMessages as PrErr (sem_Errors , wrap_Errors , Syn_Errors (..), Inh_Errors (..), isError)@@ -35,7 +36,6 @@ import qualified CodeSyntaxDump as CGrammarDump (sem_CGrammar, wrap_CGrammar, Syn_CGrammar (..), Inh_CGrammar (..)) import qualified Visage as VisageDump (sem_VisageGrammar, wrap_VisageGrammar, Syn_VisageGrammar(..), Inh_VisageGrammar(..)) import qualified AG2AspectAG as AspectAGDump (pragmaAspectAG, sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) --marcos--- import qualified AgiDump as AgiDump (sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) --marcos import Options import Version (banner)@@ -67,15 +67,10 @@ = do (output0,parseErrors) <- parseAG flags (searchPath flags) (inputFile input) irrefutableMap <- readIrrefutableMap flags - (outAgi, ext) <- --marcos- if genAspectAG flags - then parseAGI flags (searchPath flags) (agiFile input) - else return (undefined,undefined)- let output1 = Pass1.wrap_AG (Pass1.sem_AG output0 ) Pass1.Inh_AG {Pass1.options_Inh_AG = flags} flags' = condDisableOptimizations (Pass1.pragmas_Syn_AG output1 flags) grammar1 = Pass1.output_Syn_AG output1- output1a = Pass1a.wrap_Grammar (Pass1a.sem_Grammar grammar1 ) Pass1a.Inh_Grammar {Pass1a.options_Inh_Grammar = flags', Pass1a.forcedIrrefutables_Inh_Grammar = irrefutableMap }+ output1a = Pass1a.wrap_Grammar (Pass1a.sem_Grammar grammar1 ) Pass1a.Inh_Grammar {Pass1a.options_Inh_Grammar = flags', Pass1a.forcedIrrefutables_Inh_Grammar = irrefutableMap, Pass1a.mainName_Inh_Grammar = mainName } grammar1a =Pass1a.output_Syn_Grammar output1a output2 = Pass2.wrap_Grammar (Pass2.sem_Grammar grammar1a ) Pass2.Inh_Grammar {Pass2.options_Inh_Grammar = flags'} grammar2 = Pass2.output_Syn_Grammar output2@@ -89,8 +84,8 @@ grammar3a = Pass3a.output_Syn_Grammar output3a output4 = Pass4.wrap_CGrammar (Pass4.sem_CGrammar(Pass3.output_Syn_Grammar output3)) Pass4.Inh_CGrammar {Pass4.options_Inh_CGrammar = flags'} output4a = Pass4a.wrap_CGrammar (Pass4a.sem_CGrammar(Pass3.output_Syn_Grammar output3)) Pass4a.Inh_CGrammar {Pass4a.options_Inh_CGrammar = flags'}- output4b = Pass4b.wrap_ExecutionPlan (Pass4b.sem_ExecutionPlan grammar3a) Pass4b.Inh_ExecutionPlan {Pass4b.options_Inh_ExecutionPlan = flags', Pass4b.inhmap_Inh_ExecutionPlan = Pass3a.inhmap_Syn_Grammar output3a, Pass4b.synmap_Inh_ExecutionPlan = Pass3a.synmap_Syn_Grammar output3a, Pass4b.pragmaBlocks_Inh_ExecutionPlan = pragmaBlocksTxt, Pass4b.importBlocks_Inh_ExecutionPlan = importBlocksTxt, Pass4b.textBlocks_Inh_ExecutionPlan = textBlocksDoc, Pass4b.moduleHeader_Inh_ExecutionPlan = mkModuleHeader $ Pass1.moduleDecl_Syn_AG output1, Pass4b.mainName_Inh_ExecutionPlan = mkMainName mainName $ Pass1.moduleDecl_Syn_AG output1, Pass4b.mainFile_Inh_ExecutionPlan = mainFile, Pass4b.optionsLine_Inh_ExecutionPlan = optionsLine}- output5 = Pass5.wrap_Program (Pass5.sem_Program (Pass4.output_Syn_CGrammar output4)) Pass5.Inh_Program {Pass5.options_Inh_Program = flags', Pass5.pragmaBlocks_Inh_Program = pragmaBlocksTxt, Pass5.importBlocks_Inh_Program = importBlocksTxt, Pass5.textBlocks_Inh_Program = textBlocksDoc, Pass5.textBlockMap_Inh_Program = textBlockMap, Pass5.optionsLine_Inh_Program = optionsLine, Pass5.mainFile_Inh_Program = mainFile, Pass5.moduleHeader_Inh_Program = mkModuleHeader $ Pass1.moduleDecl_Syn_AG output1, Pass5.mainName_Inh_Program = mkMainName mainName $ Pass1.moduleDecl_Syn_AG output1}+ output4b = Pass4b.wrap_ExecutionPlan (Pass4b.sem_ExecutionPlan grammar3a) Pass4b.Inh_ExecutionPlan {Pass4b.options_Inh_ExecutionPlan = flags', Pass4b.inhmap_Inh_ExecutionPlan = Pass3a.inhmap_Syn_Grammar output3a, Pass4b.synmap_Inh_ExecutionPlan = Pass3a.synmap_Syn_Grammar output3a, Pass4b.pragmaBlocks_Inh_ExecutionPlan = pragmaBlocksTxt, Pass4b.importBlocks_Inh_ExecutionPlan = importBlocksTxt, Pass4b.textBlocks_Inh_ExecutionPlan = textBlocksDoc, Pass4b.moduleHeader_Inh_ExecutionPlan = mkModuleHeader $ Pass1.moduleDecl_Syn_AG output1, Pass4b.mainName_Inh_ExecutionPlan = mkMainName mainName $ Pass1.moduleDecl_Syn_AG output1, Pass4b.mainFile_Inh_ExecutionPlan = mainFile, Pass4b.textBlockMap_Inh_ExecutionPlan = textBlockMap, Pass4b.mainBlocksDoc_Inh_ExecutionPlan = mainBlocksDoc,Pass4b.localAttrTypes_Inh_ExecutionPlan = Pass3a.localSigMap_Syn_Grammar output3a}+ output5 = Pass5.wrap_Program (Pass5.sem_Program (Pass4.output_Syn_CGrammar output4)) Pass5.Inh_Program {Pass5.options_Inh_Program = flags', Pass5.pragmaBlocks_Inh_Program = pragmaBlocksTxt, Pass5.importBlocks_Inh_Program = importBlocksTxt, Pass5.textBlocks_Inh_Program = textBlocksDoc, Pass5.textBlockMap_Inh_Program = textBlockMap, Pass5.mainBlocksDoc_Inh_Program = mainBlocksDoc, Pass5.optionsLine_Inh_Program = optionsLine, Pass5.mainFile_Inh_Program = mainFile, Pass5.moduleHeader_Inh_Program = mkModuleHeader $ Pass1.moduleDecl_Syn_AG output1, Pass5.mainName_Inh_Program = mkMainName mainName $ Pass1.moduleDecl_Syn_AG output1} output5a = Pass5a.wrap_Program (Pass5a.sem_Program (Pass4.output_Syn_CGrammar output4)) Pass5a.Inh_Program { Pass5a.options_Inh_Program = flags', Pass5a.textBlockMap_Inh_Program = textBlockMap } output6 = PrErr.wrap_Errors (PrErr.sem_Errors errorsToReport) PrErr.Inh_Errors {PrErr.options_Inh_Errors = flags', PrErr.dups_Inh_Errors = [] } @@ -99,16 +94,6 @@ dump3 = CGrammarDump.wrap_CGrammar (CGrammarDump.sem_CGrammar grammar3 ) CGrammarDump.Inh_CGrammar - ext' = case ext of- Nothing -> Nothing- Just e -> Just (remAgi e)-- outAgi1 = Pass1.wrap_AG (Pass1.sem_AG outAgi ) Pass1.Inh_AG {Pass1.options_Inh_AG = flags'}- agi = Pass1.agi_Syn_AG outAgi1- aspectAG = AspectAGDump.wrap_Grammar (AspectAGDump.sem_Grammar grammar2 ) AspectAGDump.Inh_Grammar { AspectAGDump.options_Inh_Grammar = flags'- , AspectAGDump.agi_Inh_Grammar = agi- , AspectAGDump.ext_Inh_Grammar = ext' } --marcos- outputVisage = VisageDump.wrap_VisageGrammar (VisageDump.sem_VisageGrammar grammarV) VisageDump.Inh_VisageGrammar aterm = VisageDump.aterm_Syn_VisageGrammar outputVisage @@ -117,7 +102,11 @@ Seq.>< Pass1a.errors_Syn_Grammar output1a Seq.>< Pass2.errors_Syn_Grammar output2 Seq.>< Pass2a.errors_Syn_Grammar output2a)- furtherErrors = if kennedyWarren flags' then []+ furtherErrors = if kennedyWarren flags'+ then let errs3a = Pass3a.errors_Syn_Grammar output3a+ in if Seq.null errs3a+ then toList ( Pass4b.errors_Syn_ExecutionPlan output4b )+ else toList errs3a else toList ( Pass3.errors_Syn_Grammar output3 Seq.>< Pass4.errors_Syn_CGrammar output4) @@ -146,10 +135,14 @@ importBlocksTxt = vlist_sep "" . map addLocationPragma . concat . Map.elems $ importBlocks textBlocksDoc = vlist_sep "" . map addLocationPragma . Map.findWithDefault [] (BlockOther, Nothing) $ textBlocks+ mainBlocksDoc = vlist_sep "" . map addLocationPragma . Map.findWithDefault [] (BlockMain, Nothing) $ textBlocks pragmaBlocksTxt = unlines . concat . map fst . concat . Map.elems $ pragmaBlocks textBlockMap = Map.map (vlist_sep "" . map addLocationPragma) . Map.filterWithKey (\(_, at) _ -> at /= Nothing) $ textBlocks outputfile = if null output then outputFile input else output+ mainFile | null output = outputFile input+ | otherwise = dropExtension output+ mainName = dropExtension $ takeFileName input addLocationPragma :: ([String], Pos) -> PP_Doc addLocationPragma (strs, p)@@ -164,9 +157,6 @@ optionsLine | null optionsGHC = "" | otherwise = "{-# OPTIONS_GHC " ++ unwords optionsGHC ++ " #-}" - mainName = stripPath $ defaultModuleName input- mainFile = defaultModuleName input- nrOfErrorsToReport = length $ filter (PrErr.isError flags') errorsToReport nrOfWarningsToReport = length $ filter (not.(PrErr.isError flags')) errorsToReport totalNrOfErrors = length $ filter (PrErr.isError flags') allErrors@@ -176,7 +166,22 @@ pluralS n = if n == 1 then "" else "s" + (outAgi, ext) <- --marcos+ if genAspectAG flags'+ then parseAGI flags (searchPath flags) (agiFile input)+ else return (undefined, undefined) + let ext' = case ext of+ Nothing -> Nothing+ Just e -> Just (remAgi e)++ outAgi1 = Pass1.wrap_AG (Pass1.sem_AG outAgi ) Pass1.Inh_AG {Pass1.options_Inh_AG = flags'}+ agi = Pass1.agi_Syn_AG outAgi1+ aspectAG = AspectAGDump.wrap_Grammar (AspectAGDump.sem_Grammar grammar2 ) AspectAGDump.Inh_Grammar { AspectAGDump.options_Inh_Grammar = flags'+ , AspectAGDump.agi_Inh_Grammar = agi+ , AspectAGDump.ext_Inh_Grammar = ext' } --marcos++ putStr . formatErrors $ PrErr.pp_Syn_Errors output6 if additionalErrors > 0@@ -200,11 +205,6 @@ then writeAttributeList (outputfile++".attrs") (Pass1a.allAttributes_Syn_Grammar output1a) else return () -{-- if genAspectAG flags' -- marcos- then writeFile (outputfile++".agi") $ disp (AgiDump.ppAgi_Syn_Grammar agi) 50000 ""- else return ()--} if sepSemMods flags' then do -- alternative module gen if kennedyWarren flags'@@ -223,7 +223,6 @@ = vlist [ AspectAGDump.pragmaAspectAG , pp optionsLine , pp pragmaBlocksTxt- , pp $ take 70 ("-- UUAGC2AspectAG " ++ drop 50 banner ++ " (" ++ input) ++ ")" , pp $ if isNothing $ Pass1.moduleDecl_Syn_AG output1 then moduleHeader flags' mainName@@ -233,17 +232,32 @@ , pp "\n\n{-- AspectAG Code --}\n\n" , AspectAGDump.pp_Syn_Grammar aspectAG , textBlocksDoc- ]+ , if dumpgrammar flags'+ then vlist [ pp "{- Dump of AGI"+ , pp (show agi)+ , pp "-}"+ , pp "{- Dump of grammar with default rules"+ , GrammarDump.pp_Syn_Grammar dump2+ , pp "-}"+ ]+ else empty] | kennedyWarren flags'- = vlist [ pp optionsLine- , pp $ "{-# LANGUAGE Rank2Types, GADTs, EmptyDataDecls #-}"+ = vlist [ Pass4b.warrenFlagsPP flags' , pp pragmaBlocksTxt , pp $ if isNothing $ Pass1.moduleDecl_Syn_AG output1 then moduleHeader flags' mainName else mkModuleHeader (Pass1.moduleDecl_Syn_AG output1) mainName "" "" False , pp importBlocksTxt- , pp $ "import Control.Monad.Identity (Identity)"- , pp $ "import qualified Control.Monad.Identity"+ , ( if tupleAsDummyToken flags'+ then empty+ else pp "import GHC.Prim" -- need it to pass State#+ )+ , if parallelInvoke flags'+ then vlist [ pp $ "import qualified System.IO.Unsafe(unsafePerformIO)"+ , pp $ "import System.IO(IO)"+ , pp $ "import Control.Concurrent(newEmptyMVar,forkIO,putMVar,takeMVar)"]+ else vlist [ pp $ "import Control.Monad.Identity (Identity)"+ , pp $ "import qualified Control.Monad.Identity" ] , textBlocksDoc --, pp $ "{-" --, Pass3a.depgraphs_Syn_Grammar output3a@@ -330,37 +344,21 @@ inputFile :: String -> String inputFile name- = if ".ag" `isSuffixOf` name || ".lag" `isSuffixOf` name- then name- else name ++ ".ag"+ | takeExtension name == ".ag" || takeExtension name == ".lag" = name+ | otherwise = replaceExtension name "ag" --marcos agiFile :: String -> String-agiFile name- = if ".ag" `isSuffixOf` name || ".lag" `isSuffixOf` name- then name ++ "i"- else name ++ ".agi"+agiFile name = replaceExtension name "agi" remAgi :: String -> String-remAgi name- = takeWhile (/= '.') name-+remAgi = dropExtension outputFile :: String -> String-outputFile name- = defaultModuleName name ++ ".hs"+outputFile name = replaceExtension name "hs" defaultModuleName :: String -> String-defaultModuleName name- = if ".ag" `isSuffixOf` name- then take (length name - 3) name- else if ".lag" `isSuffixOf` name- then take (length name - 4) name- else name--stripPath :: String -> String-stripPath- = reverse . takeWhile (\c -> c /= '/' && c /= '\\') . reverse+defaultModuleName = dropExtension mkMainName :: String -> Maybe (String, String,String) -> String mkMainName defaultName Nothing
src/CommonTypes.hs view
@@ -6,13 +6,15 @@ import Data.Map(Map) import Data.Set(Set) import qualified Data.Set as Set+import Data.Monoid(mappend,mempty,Monoid) type Blocks = Map BlockInfo [([String], Pos)]-type BlockInfo = (BlockType, Maybe NontermIdent)-data BlockType+type BlockInfo = (BlockKind, Maybe NontermIdent)+data BlockKind = BlockImport | BlockPragma+ | BlockMain | BlockOther deriving (Eq, Ord, Show) @@ -32,6 +34,9 @@ data Type = Haskell String | NT Identifier [String]+ Bool -- True: deforested nonterminal, False: nonterminal type+ | Self -- reference to the enclosing nonterminal type+ deriving (Eq) data ComplexType = List Type | Tuple [(Identifier, Type)]@@ -39,6 +44,8 @@ | Either Type Type | Map Type Type | IntMap Type+ | OrdSet Type+ | IntSet instance Show ComplexType where show (List t ) = "[" ++ show t ++ "]"@@ -47,6 +54,8 @@ show (Either t1 t2) = "Either " ++ show t1 ++ " " ++ show t2 show (Map t1 t2) = "Map " ++ show t1 ++ " " ++ show t2 show (IntMap t1) = "IntMap " ++ show t1+ show (OrdSet t1) = "Set" ++ show t1+ show IntSet = "IntSet" instance Show Type where show = typeToHaskellString Nothing []@@ -59,7 +68,6 @@ type PragmaMap = Map NontermIdent (Map ConstructorIdent (Set Identifier)) type AttrMap = Map NontermIdent (Map ConstructorIdent (Set (Identifier,Identifier))) type UniqueMap = Map NontermIdent (Map ConstructorIdent (Map Identifier Identifier))-type Fields = [(Identifier,Type)] type Derivings = Map NontermIdent (Set Identifier) type ClassContext = [(Identifier, [String])] type ContextMap = Map NontermIdent ClassContext@@ -91,9 +99,32 @@ _FIRST = identifier "first__" _LAST = identifier "last__" +idLateBindingAttr :: Identifier+idLateBindingAttr = identifier "lateSemDict"++lateBindingTypeNm :: String -> String+lateBindingTypeNm modNm = "Late_" ++ modNm ++ "_"++lateBindingFieldNm :: String -> String+lateBindingFieldNm modNm = "late_" ++ modNm ++ "_"++lateBindingType :: String -> Type+lateBindingType modNm = Haskell (lateBindingTypeNm modNm)++lateSemNtLabel :: NontermIdent -> String+lateSemNtLabel nt = "mk_" ++ getName nt++lateSemConLabel :: NontermIdent -> ConstructorIdent -> String+lateSemConLabel nt con = "mk_" ++ getName nt ++ "_" ++ getName con+ sdtype :: NontermIdent -> String sdtype nt = "T_"++getName nt +mkNtType :: Identifier -> [String] -> Type+mkNtType nt args+ | take 2 (getName nt) == "T_" = NT nt args True+ | otherwise = NT nt args False+ cataname :: String -> Identifier -> String cataname pre name = pre++getName name @@ -104,6 +135,9 @@ semname :: String -> NontermIdent -> ConstructorIdent -> String semname pre nt con = pre ++ (getName nt ++ "_" ++ getName con) +recordFieldname :: NontermIdent -> ConstructorIdent -> Identifier -> String+recordFieldname nt con nm = getName nm ++ "_" ++ getName nt ++ "_" ++ getName con+ lhsname :: Bool -> Identifier -> String lhsname isIn = attrname isIn _LHS @@ -124,19 +158,25 @@ typeToAGString :: Type -> String typeToAGString tp = case tp of- Haskell t -> t- NT nt tps -> formatNonterminalToHaskell (getName nt) (map (\s -> "{" ++ s ++ "}") tps)+ Haskell t -> t+ NT nt tps for -> formatNonterminalToHaskell for (getName nt) (map (\s -> "{" ++ s ++ "}") tps) +removeDeforested :: Type -> Type+removeDeforested (NT nt args _) = NT nt args False+removeDeforested tp = tp+ typeToHaskellString :: Maybe NontermIdent -> [String] -> Type -> String typeToHaskellString mbNt params tp = case tp of Haskell t -> t- NT nt tps | nt == _SELF -> formatNonterminalToHaskell (maybe "Unknown" getName mbNt) params- | otherwise -> formatNonterminalToHaskell (getName nt) tps+ NT nt tps for | nt == _SELF -> formatNonterminalToHaskell for (maybe "?SELF?" getName mbNt) params+ | otherwise -> formatNonterminalToHaskell for (getName nt) tps -formatNonterminalToHaskell :: String -> [String] -> String-formatNonterminalToHaskell nt tps- = unwords (nt:tps)+formatNonterminalToHaskell :: Bool -> String -> [String] -> String+formatNonterminalToHaskell for nt tps+ = unwords ((prefix ++ nt) : tps)+ where prefix | for = "T_"+ | otherwise = "" ind :: String -> String ind s = replicate 3 ' ' ++ s@@ -149,24 +189,86 @@ = nm `Set.member` Map.findWithDefault Set.empty con (Map.findWithDefault Map.empty nt mp) isNonterminal :: Type -> Bool-isNonterminal (NT _ _) = True-isNonterminal _ = False+isNonterminal (NT _ _ _) = True+isNonterminal _ = False isSELFNonterminal :: Type -> Bool-isSELFNonterminal (NT nt _) | nt == _SELF = True-isSELFNonterminal _ = False+-- isSELFNonterminal (NT nt _ _) | nt == _SELF = True+isSELFNonterminal Self = True+isSELFNonterminal _ = False --- TODO: check if the name needs to be converted if the name is T_ extractNonterminal :: Type -> NontermIdent-extractNonterminal (NT n _) = maybe n id (deforestedNt n)+extractNonterminal (NT n _ _) = n nontermArgs :: Type -> [String] nontermArgs tp = case tp of- NT _ args -> args- _ -> []+ NT _ args _ -> args+ _ -> [] deforestedNt :: Identifier -> Maybe Identifier deforestedNt nm | take 2 (getName nm) == "T_" = Just (Ident (drop 2 (getName nm)) (getPos nm)) | otherwise = Nothing++data StateCtx+ = NoneVis+ | OneVis !Int+ | ManyVis+ deriving (Eq, Show, Ord)++data ChildKind+ = ChildSyntax -- This child is defined by syntax+ | ChildAttr -- This child is defined by an attribute+ | ChildReplace Type -- This child replaces a child with type Type+ deriving (Eq, Show)++-- Given a map that represents a relation, returns the transitive closure of this relation+closeMap :: Ord a => Map a (Set a) -> Map a (Set a)+closeMap mp0 = close (Map.keysSet mp0) mp0 where+ rev = revDeps mp0+ close todo mp0 = case Set.minView todo of+ Nothing -> mp0+ Just (k, todo1) -> let find x = Map.findWithDefault Set.empty x mp0+ vals0 = find k+ valsL = Set.toList vals0+ vals1 = foldr Set.union vals0 $ map find valsL+ in if Set.size vals0 == Set.size vals1+ then close todo1 mp0 -- note: monotonically increasing set+ else let mp1 = Map.insert k vals1 mp0+ refs = Map.findWithDefault Set.empty k rev+ todo2 = Set.union refs todo1+ in close todo2 mp1++revDeps :: Ord a => Map a (Set a) -> Map a (Set a)+revDeps mp = Map.fromListWith Set.union [ (a,Set.singleton k) | (k,s) <- Map.assocs mp, a <- Set.toList s ]++data HigherOrderInfo = HigherOrderInfo+ { hoNtDeps :: Set NontermIdent+ , hoNtRevDeps :: Set NontermIdent+ , hoAcyclic :: Bool+ }++data VisitKind+ = VisitPure Bool -- ordered or not+ | VisitMonadic+ deriving (Eq,Ord)++isLazyKind :: VisitKind -> Bool+isLazyKind (VisitPure False) = True+isLazyKind _ = False++instance Show VisitKind where+ show (VisitPure False) = "Lazy"+ show (VisitPure True) = "Ordered"+ show VisitMonadic = "Monadic"++unionWithMappend :: (Monoid a, Ord k) => Map k a -> Map k a -> Map k a+unionWithMappend = Map.unionWith mappend+++data FormatMode+ = FormatDo+ | FormatLetDecl+ | FormatLetLine+ deriving (Eq, Ord, Show)
src/GrammarInfo.hs view
@@ -28,25 +28,25 @@ type CInterfaceMap = Map NontermIdent CInterface type CVisitsMap = Map NontermIdent (Map ConstructorIdent CVisits) -data CycleStatus +data CycleStatus = CycleFree CInterfaceMap CVisitsMap | LocalCycle [Route] | InstCycle [Route] | DirectCycle [EdgeRoutes]- | InducedCycle CInterfaceMap [EdgeRoutes] + | InducedCycle CInterfaceMap [EdgeRoutes] showsSegment :: CSegment -> [String] showsSegment (CSegment inh syn) = let syn' = map toString (Map.toList syn) inh' = map toString (Map.toList inh)- toString (a,t) = (getName a, case t of (NT nt tps) -> getName nt ++ " " ++ unwords tps; Haskell t -> t)+ toString (a,t) = (getName a, case t of (NT nt tps _) -> getName nt ++ " " ++ unwords tps; Haskell t -> t) chnn = inh' `intersect` syn' inhn = inh' \\ chnn synn = syn' \\ chnn disp name [] = [] disp name as = (name ++ if length as == 1 then " attribute:" else " attributes:") : map (\(x,y) -> ind x ++ replicate ((20 - length x) `max` 0) ' ' ++ " : " ++ y) as- in disp "inherited" inhn + in disp "inherited" inhn ++ disp "chained" chnn ++ disp "synthesized" synn
src/KennedyWarren.hs view
@@ -1,6 +1,7 @@ module KennedyWarren where import CommonTypes+import Options import Pretty import Knuth1 import ExecutionPlan@@ -8,74 +9,152 @@ import Control.Monad.ST import Control.Monad.State import Control.Monad.Error+import Control.Monad.Trans import Data.STRef import Data.Maybe import Data.List import Data.Ord+import qualified ErrorMessages as Err+import PrintErrorMessages +import Data.Set (Set) import qualified Data.Set as Set+import Data.Map (Map) import qualified Data.Map as Map+import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap+import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet+import Data.Sequence(Seq)+import qualified Data.Sequence as Seq -kennedyWarrenOrder :: Set.Set NontermIdent -> [NontDependencyInformation] -> TypeSyns -> Derivings -> Maybe (ExecutionPlan, PP_Doc, PP_Doc)-kennedyWarrenOrder wr ndis typesyns derivings = runST $ do- indi <- mapM mkNontDependencyInformationM ndis- knuth1 indi+-- lazy version (does not return errors)+-- FIXME: construct map from nonterminal to intial visit (or state?) and use it in the generation of invokes+kennedyWarrenLazy :: Options -> Set NontermIdent -> [NontDependencyInformation] -> TypeSyns -> Derivings -> ExecutionPlan+kennedyWarrenLazy opts wr ndis typesyns derivings = plan where+ plan = ExecutionPlan nonts typesyns wr derivings+ nonts = zipWith mkNont ndis nontIds+ nontIds = enumFromThen 1 4+ initvMap = Map.fromList $ zipWith (\ndi initv -> (ndiNonterminal ndi, initv)) ndis nontIds++ mkNont ndi initv = nont where+ nont = ENonterminal+ (ndiNonterminal ndi)+ (ndiParams ndi)+ (ndiClassCtxs ndi)+ inits+ (Just initv)+ nextMap+ prevMap+ prods+ (ndiRecursive ndi)+ (ndiHoInfo ndi)+ inits = initv + 1+ finals = initv + 2+ nextMap = Map.fromList [(inits, OneVis initv), (finals, NoneVis)]+ prevMap = Map.fromList [(inits, NoneVis), (finals, OneVis initv)]+ prods = map mkProd (ndiProds ndi)++ mkProd pdi = prod where+ prod = EProduction+ (pdgProduction pdi)+ (pdgParams pdi)+ (pdgConstraints pdi)+ (pdgRules pdi)+ (pdgChilds pdi)+ visits+ visits = [visit]+ visit = Visit initv inits finals inh syn steps kind+ inh = Set.fromList $ ndiInh ndi+ syn = Set.fromList $ ndiSyn ndi+ kind = VisitPure False+ steps = childSteps ++ invokeSteps ++ ruleSteps++ childSteps = [ ChildIntro nm | EChild nm _ _ _ _ _ <- pdgChilds pdi ]+ invokeSteps = [ ChildVisit nm nt v+ | EChild nm tp _ _ _ _ <- pdgChilds pdi+ , let nt = extractNonterminal tp+ v = Map.findWithDefault (error "child not in initv-map") nt initvMap+ ]+ ruleSteps = [ Sem nm | (ERule nm _ _ _ _ _ _ _) <- pdgRules pdi ]+++-- ordered version (may return errors)+kennedyWarrenOrder :: Options -> Set NontermIdent -> [NontDependencyInformation] -> TypeSyns -> Derivings -> Either Err.Error (ExecutionPlan, PP_Doc, PP_Doc)+kennedyWarrenOrder opts wr ndis typesyns derivings = runST $ runErrorT $ do+ indi <- lift $ mapM mkNontDependencyInformationM ndis+ lift $ knuth1 indi -- Check all graphs for cyclicity, transitive closure and consistency- traceST $ "Checking graphs..."- allok <- forM indi $ \ndi -> do+ -- traceST $ "Checking graphs..."+ forM_ indi $ \ndi -> do let nont = ndiNonterminal . ndimOrig $ ndi let g = ndgmDepGraph . ndimDepGraph $ ndi -- Topological sort --tsedg <- graphTopSort g -- Cyclicity check- c1 <- graphIsCyclic g- when c1 $ traceST $ "Nonterminal graph " ++ show nont ++ " is cylic!"+ ntCycVerts <- lift $ graphCyclicVerticesExt g+ when (not $ null ntCycVerts) $ do+ throwError $ Err.Cyclic nont Nothing (map show ntCycVerts)+-- let msg = "Nonterminal graph " ++ show nont ++ " is cylic!"+-- fail msg -- Transtive closure check- --trc <- graphIsTRC g- --when (not trc) $ traceST $ "Nonterminal graph " ++ show nont ++ " is not transitively closed!"+ trc <- lift $ graphIsTRC g+ when (not trc) $ do+ let msg = "Nonterminal graph " ++ show nont ++ " is not transitively closed!"+ fail msg -- Consistency check- cons <- graphCheckConsistency g- when (not cons) $ traceST $ "Nonterminal graph " ++ show nont ++ " is not consistent!"+ cons <- lift $ graphCheckConsistency g+ when (not cons) $ do+ let msg = "Nonterminal graph " ++ show nont ++ " is not consistent!"+ fail msg+ -- Loop trough all productions- allok <- forM (ndimProds ndi) $ \prod -> do+ forM_ (ndimProds ndi) $ \prod -> do let pr = pdgProduction $ pdgmOrig prod let g = pdgmDepGraph $ prod -- Topsort- --addTopSortEdges tsedg prod + --addTopSortEdges tsedg prod -- Check for cyclicity- c2 <- graphIsCyclic g - when c2 $ traceST $ "Production graph " ++ show pr ++ " of nonterminal "- ++ show nont ++ " is cylic!"+ pdCycVerts <- lift $ graphCyclicVerticesExt g+ when (not $ null pdCycVerts) $ do+ throwError $ Err.Cyclic nont (Just pr) (map show pdCycVerts)+ -- let msg = "Production graph " ++ show pr ++ " of nonterminal "+ -- ++ show nont ++ " is cylic!"+ -- fail msg -- Transtive closure check- trc <- graphIsTRC g- when (not trc) $ traceST $ "Production graph " ++ show pr ++ " of nonterminal " - ++ show nont ++ " is not transitively closed!"+ trc <- lift $ graphIsTRC g+ when (not trc) $ do+ lift $ traceST $ "Production graph " ++ show pr ++ " of nonterminal "+ ++ show nont ++ " is not transitively closed!"+ fail "Production graph is not transitively closed." -- Check consistency- cons <- graphCheckConsistency g- when (not cons) $ traceST $ "Production graph " ++ show pr ++ " of nonterminal " - ++ show nont ++ " is not consistent!"- return $ (not c2) && trc && cons- return $ (and allok) && (not c1) && cons- if (and allok) - then do- -- Create non-transitive closed graph for efficiency- indi <- undoTransitiveClosure indi- -- Graphviz output of dependency graphs- gvs <- mapM toGVNontDependencyInfo indi- -- Doing kennedywarren- (ret, visitg) <- runVG $ do- traceVG $ "Running kennedy-warren..."+ cons <- lift $ graphCheckConsistency g+ when (not cons) $ do+ let msg = "Production graph " ++ show pr ++ " of nonterminal "+ ++ show nont ++ " is not consistent!"+ fail msg+ -- reachable whe neverything is ok+ lift $ do+ -- Create non-transitive closed graph for efficiency+ indi <- undoTransitiveClosure indi+ -- Graphviz output of dependency graphs+ gvs <- mapM toGVNontDependencyInfo indi+ -- Doing kennedywarren+ (ret, visitg) <- runVG $ do+ -- traceVG $ "Running kennedy-warren..." initvs <- kennedyWarrenVisitM wr indi+ -- Print some debug info+ nodes <- gets vgNodeNum+ edges <- gets vgEdgeNum+ traceVG $ "Number of nodes = " ++ show nodes+ traceVG $ "Number of edges = " ++ show edges -- Generate execution plan- ex <- kennedyWarrenExecutionPlan indi initvs wr typesyns derivings+ ex <- kennedyWarrenExecutionPlan opts indi initvs wr typesyns derivings -- Get visit graph visitg <- toGVVisitGraph return (ex,visitg)- -- Return the result- return $ Just (ret, vlist gvs, visitg)- else return Nothing+ -- Return the result+ return (ret, vlist gvs, visitg) ------------------------------------------------------------------------------- -- Debugging functionality@@ -92,7 +171,7 @@ -- | Pretty print an edge in GraphViz format toGVEdge :: Edge -> ST s PP_Doc-toGVEdge (v1, v2) = do r1 <- toGVVertex False v1 +toGVEdge (v1, v2) = do r1 <- toGVVertex False v1 r2 <- toGVVertex False v2 return $ r1 >|< text "->" >#< r2 @@ -145,7 +224,7 @@ edged <- forM (IntMap.toList edges) $ \(edg,(VGNode from,VGNode to)) -> do inh <- getInherited (VGEdge edg) syn <- getSynthesized (VGEdge edg)- return $ "node_" >|< from >#< "-> node_" >|< to >#< "[label=\"visit v" >|< edg + return $ "node_" >|< from >#< "-> node_" >|< to >#< "[label=\"visit v" >|< edg >|< "\\ninh:" >#< (concat $ intersperse ", " $ map show $ Set.toList inh) >|< "\\nsyn: " >|< (concat $ intersperse ", " $ map show $ Set.toList syn) >|< "\"];" return $ "digraph visitgraph { " >-< vlist noded >-< vlist edged >-< "}" @@ -155,10 +234,10 @@ {- runVG :: VG s a -> ST s a insertInitialNode :: NontDependencyInformationM s -> VG s VGNode-createPending :: VGNode -> Set.Set Identifier -> Set.Set Identifier -> VG s VGEdge+createPending :: VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge selectPending :: VG s VGEdge-getInherited :: VGEdge -> VG s (Set.Set Identifier)-getSynthesized :: VGEdge -> VG s (Set.Set Identifier)+getInherited :: VGEdge -> VG s (Set Identifier)+getSynthesized :: VGEdge -> VG s (Set Identifier) markFinal :: VGEdge -> VG s () getProductions :: VGEdge -> VG s [VGProd] onMarkedDepGraph :: (ProdDependencyGraphM s -> ST s a) -> VGProd -> VG s a@@ -177,23 +256,23 @@ data VGState s = VGState { vgNodeNum :: Int , vgEdgeNum :: Int -- Node maps- , vgOutgoing :: IntMap.IntMap (STRef s (Set.Set VGEdge))- , vgIncoming :: IntMap.IntMap (Maybe VGEdge)- , vgNDI :: IntMap.IntMap (STRef s (NontDependencyInformationM s))- , vgInhSynNode :: Map.Map (Identifier, Set.Set Identifier, Set.Set Identifier) VGNode- , vgNodeInhSyn :: IntMap.IntMap (Set.Set Identifier, Set.Set Identifier)- , vgInitial :: Map.Map Identifier VGNode+ , vgOutgoing :: IntMap (STRef s (Set VGEdge))+ , vgIncoming :: IntMap (Maybe VGEdge)+ , vgNDI :: IntMap (STRef s (NontDependencyInformationM s))+ , vgInhSynNode :: Map (Identifier, Set Identifier, Set Identifier) VGNode+ , vgNodeInhSyn :: IntMap (Set Identifier, Set Identifier)+ , vgInitial :: Map Identifier VGNode -- Edge maps- , vgEdges :: IntMap.IntMap (VGNode, VGNode)- , vgEdgesR :: Map.Map (VGNode,VGNode) VGEdge- , vgInherited :: IntMap.IntMap (Set.Set Identifier)- , vgSynthesized :: IntMap.IntMap (Set.Set Identifier)- , vgPending :: IntSet.IntSet- , vgChildVisits :: IntMap.IntMap (STRef s (Map.Map (Identifier,Int) [VGNode]))+ , vgEdges :: IntMap (VGNode, VGNode)+ , vgEdgesR :: Map (VGNode,VGNode) VGEdge+ , vgInherited :: IntMap (Set Identifier)+ , vgSynthesized :: IntMap (Set Identifier)+ , vgPending :: IntSet+ , vgChildVisits :: IntMap (STRef s (Map (Identifier,Int) [VGNode])) -- Final vertices in production graphs- , vgFinalVertices :: IntMap.IntMap (STRef s (Set.Set (Vertex,Int)))+ , vgFinalVertices :: IntMap (STRef s (Set (Vertex,Int))) -- Construction of execution plan (Nonterminal,Production,Visit)- , vgProdVisits :: Map.Map (Identifier,Identifier,VGEdge) (STRef s [VisitStep])+ , vgProdVisits :: Map (Identifier,Identifier,VGEdge) (STRef s [VisitStep]) } type VG s a = ErrorT String (StateT (VGState s) (ST s)) a@@ -213,12 +292,12 @@ (VGNode node) <- vgCreateNode rndi Set.empty Set.empty initial <- gets vgInitial incoming <- gets vgIncoming- modify $ \st -> st { vgInitial = Map.insert (ndiNonterminal $ ndimOrig ndi) (VGNode node) initial + modify $ \st -> st { vgInitial = Map.insert (ndiNonterminal $ ndimOrig ndi) (VGNode node) initial , vgIncoming = IntMap.insert node Nothing incoming } return (VGNode node) -- | Create a pending edge from this node with a set of inherited and synthesized attributes-createPending :: VGNode -> Set.Set Identifier -> Set.Set Identifier -> VG s VGEdge+createPending :: VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge createPending vgn@(VGNode n) inh syn = do -- Check if target node already exists ninhsyn <- gets vgNodeInhSyn@@ -259,13 +338,13 @@ return $ VGEdge $ head $ readyPend -- | Get the inherited attributes of an edge-getInherited :: VGEdge -> VG s (Set.Set Identifier)+getInherited :: VGEdge -> VG s (Set Identifier) getInherited (VGEdge edg) = do inhs <- gets vgInherited return $ imLookup edg inhs -- | Get the synthesized attributes of an edge-getSynthesized :: VGEdge -> VG s (Set.Set Identifier)+getSynthesized :: VGEdge -> VG s (Set Identifier) getSynthesized (VGEdge edg) = do syns <- gets vgSynthesized return $ imLookup edg syns@@ -398,7 +477,7 @@ , vgProdVisits = Map.empty } -- | Create a new node-vgCreateNode :: STRef s (NontDependencyInformationM s) -> Set.Set Identifier -> Set.Set Identifier -> VG s VGNode+vgCreateNode :: STRef s (NontDependencyInformationM s) -> Set Identifier -> Set Identifier -> VG s VGNode vgCreateNode rndi inh syn = do num <- gets vgNodeNum outgoing <- gets vgOutgoing@@ -413,13 +492,13 @@ , vgOutgoing = IntMap.insert num rout outgoing , vgInhSynNode = Map.insert (ndiNonterminal $ ndimOrig nndi,inh,syn) (VGNode num) inhsyn , vgNodeInhSyn = IntMap.insert num (inh,syn) ninhsyn- , vgNDI = IntMap.insert num rndi ndi + , vgNDI = IntMap.insert num rndi ndi , vgFinalVertices = IntMap.insert num rfinalv finalv } return $ VGNode num -- | Create a new pending edge-vgCreatePendingEdge :: VGNode -> VGNode -> Set.Set Identifier -> Set.Set Identifier -> VG s VGEdge-vgCreatePendingEdge vgn1@(VGNode n1) vgn2@(VGNode n2) inh syn = do +vgCreatePendingEdge :: VGNode -> VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge+vgCreatePendingEdge vgn1@(VGNode n1) vgn2@(VGNode n2) inh syn = do num <- gets vgEdgeNum edges <- gets vgEdges edgesr <- gets vgEdgesR@@ -437,7 +516,7 @@ , vgEdgesR = Map.insert (vgn1,vgn2) ret edgesr , vgPending = IntSet.insert num pend , vgInherited = IntMap.insert num inh inhs- , vgSynthesized = IntMap.insert num syn syns + , vgSynthesized = IntMap.insert num syn syns , vgChildVisits = IntMap.insert num rchildv childv } -- Add prod visits (for constructing an execution plan) ndis <- gets vgNDI@@ -476,7 +555,7 @@ return r -- | Always succeeding IntMap lookup-imLookup :: Int -> IntMap.IntMap a -> a+imLookup :: Int -> IntMap a -> a imLookup k m = let Just r = IntMap.lookup k m in r -- | Trace inside the vg monad@@ -489,10 +568,10 @@ {- runVG :: VG s a -> ST s a insertInitialNode :: NontDependencyInformationM s -> VG s VGNode-createPending :: VGNode -> Set.Set Identifier -> Set.Set Identifier -> VG s VGEdge+createPending :: VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge selectPending :: VG s VGEdge-getInherited :: VGEdge -> VG s (Set.Set Identifier)-getSynthesized :: VGEdge -> VG s (Set.Set Identifier)+getInherited :: VGEdge -> VG s (Set Identifier)+getSynthesized :: VGEdge -> VG s (Set Identifier) markFinal :: VGEdge -> VG s () getProductions :: VGEdge -> VG s [VGProd] onMarkedDepGraph :: (ProdDependencyGraphM s -> ST s a) -> VGProd -> VG s a@@ -504,7 +583,7 @@ repeatM :: VG s () -> VG s () -} -kennedyWarrenVisitM :: Set.Set NontermIdent -> [NontDependencyInformationM s] -> VG s [Maybe Int]+kennedyWarrenVisitM :: Set NontermIdent -> [NontDependencyInformationM s] -> VG s [Maybe Int] kennedyWarrenVisitM wr ndis = do -- Create initial nodes and edges (edges only for wrapper nodes) initvs <- forM ndis $ \ndi -> do@@ -524,34 +603,16 @@ syns <- getSynthesized pend -- Handle each production for this edge forM_ prods $ \prod -> do+ -- Mark all inherited attributes as final+ setDepGraphVerticesFinal prod (map createLhsInh . Set.toList $ inhs) -- Find depth of all synthesized child visits- (vis,i) <- foldM (foldChildVisits prod) ([],0) (map (VAttr Syn _LHS) . Set.toList $ syns)+ (vis,i) <- foldM (foldChildVisits prod) ([],0) (map createLhsSyn . Set.toList $ syns) -- Mark them as final setDepGraphVerticesFinal prod (map fst vis) -- Change the inherited child visits- vis2 <- forM vis $ \(v,i) -> do- if isChildInh v- then do- preds <- onMarkedDepGraph (liftM Set.toList . flip graphPredecessors v . pdgmDepGraph) prod- let ni = foldl1 min $ map (\x -> case x `lookup` vis of { Just i -> i; Nothing -> 99999999 }) preds- return (v,ni)- else if not $ isChildSyn v- then do- succs <- onMarkedDepGraph (liftM Set.toList . flip graphSuccessors v . pdgmDepGraph) prod- let ni = foldl max 0 $ map (\x -> case x `lookup` vis of { Just i -> i + 1; Nothing -> 0 }) succs- return (v,ni)- else return (v,i)+ vis2 <- correctInhChilds prod vis -- Add all synthesized attributes that are also ready but are not needed- allpreds <- forM vis2 $ \(v,i) -> do- if isChildInh v- then do- preds <- onMarkedDepGraph (liftM Set.toList . flip graphPredecessors v . pdgmDepGraph) prod- return $ Set.fromList $ filter isChildSyn preds- else return Set.empty- lextravis <- mapM (\v -> do ready <- isReadyVertex prod vis2 v- return $ do i <- ready- return (v,i)) $ Set.toList $ Set.unions allpreds- let extravis = catMaybes lextravis+ extravis <- extraChildSyn prod vis2 setDepGraphVerticesFinal prod (map fst extravis) -- Group by visit number and do visit for every num let gvis = groupSortBy (comparing snd) $ vis2 ++ extravis@@ -560,7 +621,7 @@ let (chattrs, rules) = partition isChildAttr $ map fst visit -- Evaluate all rules forM_ (reverse $ rules) $ \rule ->- case rule of + case rule of VRule r -> addVisitStep prod $ Sem r VChild c -> addVisitStep prod $ ChildIntro c _ -> return ()@@ -575,12 +636,15 @@ target <- createPending curstate (Set.fromList cinhs) (Set.fromList csyns) addChildVisit prod cname target -- Add child visits as simultanuous step- when (length chvs > 0) $ do- addVisitStep prod $ Sim chvs+ when (not $ null chvs) $+ if (length chvs == 1)+ then addVisitStep prod $ head chvs+ else addVisitStep prod $ Sim chvs+ -- Mark this edge as final markFinal pend -- We are done- traceVG "Done."+ -- traceVG "Done." return initvs -- | groupBy that groups all equal (according to the function) elements instead of consequtive equal elements@@ -611,15 +675,45 @@ then return ((v,ni + 1) : nvis, ni + 1) else return ((v,ni) : nvis, ni) +-- | Correct inherited child visits after foldChildVisits+correctInhChilds :: VGProd -> ChildVisits -> VG s ChildVisits+correctInhChilds prod vis =+ forM vis $ \(v,i) -> do+ if isChildInh v+ then do+ preds <- onMarkedDepGraph (liftM Set.toList . flip graphPredecessors v . pdgmDepGraph) prod+ let ni = foldl min 99999999 $ mapMaybe (`lookup` vis) preds+ return (v,ni)+ else if not $ isChildSyn v+ then do+ succs <- onMarkedDepGraph (liftM Set.toList . flip graphSuccessors v . pdgmDepGraph) prod+ let ni = foldl max (-1) $ mapMaybe (`lookup` vis) succs+ return (v,ni+1)+ else return (v,i)++-- | Synthesized attributes that can also be evaluated+extraChildSyn :: VGProd -> ChildVisits -> VG s ChildVisits+extraChildSyn prod vis = do+ allpreds <- forM vis $ \(v,i) -> do+ if isChildInh v+ then do+ preds <- onMarkedDepGraph (liftM Set.toList . flip graphPredecessors v . pdgmDepGraph) prod+ return $ Set.fromList $ filter isChildSyn preds+ else return Set.empty+ lextravis <- forM (Set.toList $ Set.unions allpreds) $ \v -> do+ ready <- isReadyVertex prod vis v+ return $ maybe Nothing (\i -> Just (v,i)) ready+ return $ catMaybes lextravis+ -- | Check if a vertex can be marked final in this step (and is not final yet) and return the visit num isReadyVertex :: VGProd -> ChildVisits -> Vertex -> VG s (Maybe Int)-isReadyVertex prod vis v = do +isReadyVertex prod vis v = do final <- isDepGraphVertexFinal prod v if v `elem` (map fst vis) || final then return Nothing else do succ <- onMarkedDepGraph (flip graphSuccessors v . pdgmDepGraph) prod- rd <- mapM (\x -> do case lookup x vis of + rd <- mapM (\x -> do case lookup x vis of Just i -> return $ Just i Nothing -> do fin <- isDepGraphVertexFinal prod x return $ if fin then Just 1 else Nothing) (Set.toList succ)@@ -639,12 +733,20 @@ isChildAttr :: Vertex -> Bool isChildAttr v = isVertexAttr v && getAttrChildName v /= _LHS && getAttrType v /= Loc +-- | Create lhs.inh vertex+createLhsInh :: Identifier -> Vertex+createLhsInh = VAttr Inh _LHS++-- | Create lhs.inh vertex+createLhsSyn :: Identifier -> Vertex+createLhsSyn = VAttr Syn _LHS+ ------------------------------------------------------------ --- Construction of the execution plan --- -------------------------------------------------------------kennedyWarrenExecutionPlan :: [NontDependencyInformationM s] -> [Maybe Int] -> Set.Set NontermIdent- -> TypeSyns -> Derivings -> VG s ExecutionPlan-kennedyWarrenExecutionPlan ndis initvs wr typesyns derivings = do+kennedyWarrenExecutionPlan :: Options -> [NontDependencyInformationM s] -> [Maybe Int] ->+ Set NontermIdent -> TypeSyns -> Derivings -> VG s ExecutionPlan+kennedyWarrenExecutionPlan opts ndis initvs wr typesyns derivings = do -- Loop over all nonterminals nonts <- forM (zip ndis initvs) $ \(ndi, initv) -> do -- Loop over all productions of this nonterminal@@ -660,19 +762,91 @@ steps <- vgInST $ readSTRef rprodvs inh <- getInherited vgedg syn <- getSynthesized vgedg- return $ Visit edg fr to inh syn steps+ let kind | monadic opts = VisitMonadic+ | otherwise = VisitPure True+ return $ Visit edg fr to inh syn steps kind -- Return execution plan for this production return $ EProduction (pdgProduction $ pdgmOrig prod)+ (pdgParams $ pdgmOrig prod)+ (pdgConstraints $ pdgmOrig prod) (pdgRules $ pdgmOrig prod) (pdgChilds $ pdgmOrig prod) visits -- Find initial state for this nonterminal VGNode init <- vgFindInitial $ ndiNonterminal $ ndimOrig ndi+ -- Construct an environment that specifies the next visit of the states that have exactly one+ nextMap <- mkNextMap init+ prevMap <- mkPrevMap init -- Return execution plan for this nonterminal return $ ENonterminal (ndiNonterminal $ ndimOrig ndi) (ndiParams $ ndimOrig ndi)+ (ndiClassCtxs $ ndimOrig ndi) init initv+ nextMap+ prevMap prods+ (ndiRecursive $ ndimOrig ndi)+ (ndiHoInfo $ ndimOrig ndi)+ -- Return complete execution plan return $ ExecutionPlan nonts typesyns wr derivings++------------------------------------------------------------+--- Construction of the single-exit states map ---+------------------------------------------------------------++-- depth-first traversal over the graph that starts at 'init' and maintains a state 'a'+-- the function 'f' can inspect the prev/next edges per state+exploreGraph :: (VGNode -> Set VGEdge -> Set VGEdge -> a -> VG s a) -> VGNode -> a -> VG s a+exploreGraph f (VGNode init) a0 = do+ exploredRef <- vgInST $ newSTRef IntSet.empty+ pendingRef <- vgInST $ newSTRef [init]+ resRef <- vgInST $ newSTRef a0+ outgoingMap <- gets vgOutgoing+ incomingMap <- gets vgIncoming+ edgesInfo <- gets vgEdges+ let explore = do+ pending <- vgInST $ readSTRef pendingRef+ case pending of+ [] -> return ()+ (p:ps) -> do+ vgInST $ writeSTRef pendingRef ps+ explored <- vgInST $ readSTRef exploredRef+ if IntSet.member p explored+ then return ()+ else do+ vgInST $ writeSTRef exploredRef (IntSet.insert p explored)+ case IntMap.lookup p outgoingMap of+ Nothing -> return ()+ Just outRef -> case IntMap.lookup p outgoingMap of+ Nothing -> return ()+ Just inRef -> do+ outSet <- vgInST $ readSTRef outRef+ inSet <- vgInST $ readSTRef inRef+ sol0 <- vgInST $ readSTRef resRef+ sol1 <- f (VGNode p) inSet outSet sol0+ vgInST $ writeSTRef resRef sol1+ forM_ (Set.elems outSet) $ \(VGEdge edge) ->+ case IntMap.lookup edge edgesInfo of+ Nothing -> return ()+ Just (_,VGNode to) -> vgInST $ modifySTRef pendingRef (to :)+ explore+ explore+ vgInST $ readSTRef resRef++mkNextMap :: Int -> VG s (Map Int StateCtx)+mkNextMap start = exploreGraph f (VGNode start) Map.empty where+ f (VGNode nd) _ edges = updateCountMap nd edges++mkPrevMap :: Int -> VG s (Map Int StateCtx)+mkPrevMap start = exploreGraph f (VGNode start) Map.empty where+ f (VGNode nd) edges _ = updateCountMap nd edges++updateCountMap :: Int -> Set VGEdge -> Map Int StateCtx -> VG s (Map Int StateCtx)+updateCountMap nd edges mp = return $ Map.insert nd v mp where+ s = Set.size edges+ v | s == 0 = NoneVis+ | s == 1 = let [VGEdge v] = Set.elems edges+ in OneVis v+ | otherwise = ManyVis
src/Knuth1.hs view
@@ -10,8 +10,11 @@ import Data.STRef import Debug.Trace +import Data.Array (Array) import qualified Data.Array as Array+import Data.Map (Map) import qualified Data.Map as Map+import Data.Set (Set) import qualified Data.Set as Set -- | Trace a message in the ST monad@@ -62,10 +65,10 @@ type IEdge = (IVertex, IVertex) -- Representation of the graph-data DependencyGraph s = DependencyGraph { vertexIMap :: Map.Map Vertex IVertex- , vertexOMap :: Array.Array IVertex Vertex - , successors :: Array.Array IVertex (STRef s (Set.Set IVertex))- , predecessors :: Array.Array IVertex (STRef s (Set.Set IVertex)) }+data DependencyGraph s = DependencyGraph { vertexIMap :: Map Vertex IVertex+ , vertexOMap :: Array IVertex Vertex+ , successors :: Array IVertex (STRef s (Set IVertex))+ , predecessors :: Array IVertex (STRef s (Set IVertex)) } ------------------------------------------------------------------------------- -- Dependency graph fuctions@@ -96,12 +99,12 @@ return g -- | Return all successors of a vertex-graphSuccessors :: DependencyGraph s -> Vertex -> ST s (Set.Set Vertex)+graphSuccessors :: DependencyGraph s -> Vertex -> ST s (Set Vertex) graphSuccessors g v = do sucs <- readSTRef $ (successors g) Array.! (graphGetIVertex g v) return $ Set.map (graphGetVertex g) sucs -- | Return all predecessors of a vertex-graphPredecessors :: DependencyGraph s -> Vertex -> ST s (Set.Set Vertex)+graphPredecessors :: DependencyGraph s -> Vertex -> ST s (Set Vertex) graphPredecessors g v = do sucs <- readSTRef $ (predecessors g) Array.! (graphGetIVertex g v) return $ Set.map (graphGetVertex g) sucs @@ -122,7 +125,7 @@ -- | Insert an edge in a transtive closed graph and return all other edges that were -- added due to transtivity-graphInsertTRC :: DependencyGraph s -> Edge -> ST s [(IVertex, Set.Set IVertex)]+graphInsertTRC :: DependencyGraph s -> Edge -> ST s [(IVertex, Set IVertex)] graphInsertTRC g (v1,v2) = do let iv1 = graphGetIVertex g v1 let iv2 = graphGetIVertex g v2 -- Read predecessors of v1 and successors of v2@@ -175,10 +178,10 @@ -- | Insert a list of edges in the graph and return all other edges that -- were added due to transitivity graphInsertEdgesTRC :: DependencyGraph s -> [Edge] -> ST s [Edge]-graphInsertEdgesTRC g ed = do -- rets :: [[(IVertex, Set.Set IVertex)]]+graphInsertEdgesTRC g ed = do -- rets :: [[(IVertex, Set IVertex)]] rets <- mapM (graphInsertTRC g) ed -- Combine all successor sets- let f :: (IVertex, (Set.Set IVertex)) -> [(IVertex, IVertex)]+ let f :: (IVertex, (Set IVertex)) -> [(IVertex, IVertex)] f (v,s) = map ((,) v) (Set.toList s) let comb :: [(IVertex, IVertex)] comb = concatMap (concatMap f) rets@@ -187,12 +190,23 @@ -- | Check whether the graph is cyclic graphIsCyclic :: DependencyGraph s -> ST s Bool-graphIsCyclic g = do vs <- return $ Array.indices $ vertexOMap g- selfcyc <- forM vs $ \v -> do- sucs <- readSTRef $ (successors g) Array.! v- return $ v `Set.member` sucs- return $ or selfcyc+graphIsCyclic g = do+ s <- graphCyclicVertices g+ return $ not $ Set.null s +graphCyclicVertices :: DependencyGraph s -> ST s (Set IVertex)+graphCyclicVertices g = do+ vs <- return $ Array.indices $ vertexOMap g+ sets <- forM vs $ \v -> do+ sucs <- readSTRef $ (successors g) Array.! v+ let res | v `Set.member` sucs = Set.singleton v+ | otherwise = Set.empty+ return res+ return (Set.unions sets)++graphCyclicVerticesExt :: DependencyGraph s -> ST s [Vertex]+graphCyclicVerticesExt g = (map (graphGetVertex g) . Set.elems) `fmap` graphCyclicVertices g+ -- | Get internal representation of a vertex graphGetIVertex :: DependencyGraph s -> Vertex -> IVertex graphGetIVertex g v = vertexIMap g Map.! v@@ -241,7 +255,7 @@ let edg = graphGetEdge g (v2,v1) -- order is actually reverse order ce <- graphContainsEdge g edg if ce- then return Nothing + then return Nothing else do graphInsert g edg return $ Just edg return $ catMaybes mb@@ -258,7 +272,7 @@ ------------------------------------------------------------------------------- -- | Special wrapper for nonterminal dependency graphs (so that we can easily add other meta-information)-data NontDependencyGraph = NontDependencyGraph { ndgVertices :: [Vertex] +data NontDependencyGraph = NontDependencyGraph { ndgVertices :: [Vertex] , ndgEdges :: [Edge] } -- | Special wrapper for production dependency graphs, including mapping between child names and nonterminals@@ -267,7 +281,9 @@ , pdgRules :: ERules , pdgChilds :: EChildren , pdgProduction :: Identifier- , pdgChildMap :: [(Identifier, Identifier)] }+ , pdgChildMap :: [(Identifier, Identifier)]+ , pdgConstraints :: [Type]+ , pdgParams :: [Identifier] } -- | Represent all information from the dependency graphs for a nonterminal@@ -276,12 +292,16 @@ , ndiInh :: [Identifier] , ndiSyn :: [Identifier] , ndiDepGraph :: NontDependencyGraph- , ndiProds :: [ProdDependencyGraph] }+ , ndiProds :: [ProdDependencyGraph]+ , ndiRecursive :: Bool+ , ndiHoInfo :: HigherOrderInfo+ , ndiClassCtxs :: ClassContext+ } --- Monadic versions of these records, for use with the ST monad -- | Monadic wrapper of NontDependencyGraph-data NontDependencyGraphM s = NontDependencyGraphM { ndgmDepGraph :: DependencyGraph s +data NontDependencyGraphM s = NontDependencyGraphM { ndgmDepGraph :: DependencyGraph s , ndgmOrig :: NontDependencyGraph } -- | Monadic wrapper of ProdDependencyGraph@@ -298,7 +318,7 @@ -- | Convert a NontDependencyGraph to the corresponding monadic version mkNontDependencyGraphM :: NontDependencyGraph -> ST s (NontDependencyGraphM s) mkNontDependencyGraphM ndg = do g <- graphConstructTRC (ndgVertices ndg) (ndgEdges ndg)- return $ NontDependencyGraphM { ndgmDepGraph = g + return $ NontDependencyGraphM { ndgmDepGraph = g , ndgmOrig = ndg } @@ -354,20 +374,20 @@ -- this function assumes that the nonterminal graphs initially contains no edges knuth1 :: [NontDependencyInformationM s] -> ST s () knuth1 ndis = do -- Create initial list of pending edges for each ndi per production (initially all prod edges)- let ipending :: NontDependencyInformationM s -> ST s [[Edge]]- ipending = mapM (graphEdges . pdgmDepGraph) . ndimProds -- pndis :: [([[Edge]], NontDependencyInformation)]- pndis <- mapM (\ndi -> liftM2 (,) (ipending ndi) (return ndi)) ndis+ pndis <- forM ndis $ \ndi -> do+ ipend <- mapM (graphEdges . pdgmDepGraph) . ndimProds $ ndi+ return (ipend, ndi) knuth1' pndis -- | Helper function for |knuth1| which repeats the process until we are done knuth1' :: [([[Edge]], NontDependencyInformationM s)] -> ST s () knuth1' ndis = do -- Add edges from the production graphs to the nonterminal graph--- ndis' :: [Maybe [Edge]]+-- ndis' :: [[Edge]] ndis' <- mapM addProdNont ndis -- List of all newly added edges -- ntedge :: [Edge]- let pntedge = concatMap (maybe [] id) ndis'+ let pntedge = concat ndis' -- Add backedges --bedges <- addBackEdges ndis -- All added nonterminal edges@@ -376,20 +396,20 @@ -- When no new edges have been added we are done then return () else do -- Otherwise, the next step is to add edges from nonterminal to production graphs--- ndis'' :: [Maybe [[Edge]]]+-- ndis'' :: [[[Edge]]] ndis'' <- mapM (\(_,x) -> addNontProd True (ntedge, x)) ndis -- List of new states (production edges + dependency graphs) -- nndis' :: [([[Edge]], NontDependencyInformation)]- nndis' <- zipWithM (\(_,ndi) me -> return (maybe [] id me, ndi)) ndis ndis''- if any isJust ndis''+ nndis' <- zipWithM (\(_,ndi) me -> return (me, ndi)) ndis ndis''+ if any (not . null) ndis'' -- We have added some edges, so continue the process then knuth1' nndis' -- No new edges added, we are done else return () --- | Add pending edges from the production graphs to the nonterminal graph, return Nothing if none were added--- otherwise, return the list of newly added nonterminal edges-addProdNont :: ([[Edge]], NontDependencyInformationM s) -> ST s (Maybe [Edge])+-- | Add pending edges from the production graphs to the nonterminal graph+-- and return the list of newly added nonterminal edges+addProdNont :: ([[Edge]], NontDependencyInformationM s) -> ST s [Edge] addProdNont (pending, ndi) = do -- Unwrapping of the records let nontDepGraph = ndimDepGraph ndi let nontGraph = ndgmDepGraph nontDepGraph@@ -409,26 +429,19 @@ -- Edges that are not in the nonterminal graph yet toadd <- filterM (\e -> return not `ap` graphContainsEdge nontGraph e) possa -- Check whether new edges are to be added and return the added edges- if null toadd- then return Nothing- else do graphInsertEdgesTRC nontGraph toadd- -- Debug output- --mapM_ (\edge -> traceST $ "Adding nonterminal edge " ++ show edge) toadd- return $ Just toadd+ when (not $ null toadd) $ do+ graphInsertEdgesTRC nontGraph toadd+ return ()+ return toadd --- | Add edges from the nonterminal graphs to the production graphs, return Nothing if none were added--- otherwise, return the list of newly added production edges and the updated graph-addNontProd :: Bool -> ([Edge], NontDependencyInformationM s) -> ST s (Maybe [[Edge]])-addNontProd trc (pending, ndi) = do -- Call the helper function for each nonterminal- prods' <- mapM (addNontProd' trc pending) (ndimProds ndi)- -- Check if any edges were added- if any isJust prods'- then -- Return list of newly created edges- return $ Just $ map (maybe [] id) prods'- else return Nothing+-- | Add edges from the nonterminal graphs to the production graphs+-- and return the list of newly added production edges and the updated graph+addNontProd :: Bool -> ([Edge], NontDependencyInformationM s) -> ST s [[Edge]]+addNontProd trc (pending, ndi) = do -- Just call the helper function for each nonterminal+ mapM (addNontProd' trc pending) (ndimProds ndi) -- | Helper function for |addNontProd| for a single production-addNontProd' :: Bool -> [Edge] -> ProdDependencyGraphM s -> ST s (Maybe [Edge])+addNontProd' :: Bool -> [Edge] -> ProdDependencyGraphM s -> ST s [Edge] addNontProd' trc pend pdg = do -- Unwrapping of the records prodGraph <- return $ pdgmDepGraph pdg -- Construct all possible new edges@@ -447,7 +460,7 @@ toadd <- filterM (\e -> return not `ap` graphContainsEdge prodGraph e) possa -- Check whether new edges are to be added and return the result if null toadd- then return Nothing+ then return [] else do -- Insert all edges and return transitive edges that are added in this process ret <- if trc then graphInsertEdgesTRC prodGraph toadd@@ -455,7 +468,7 @@ return [] -- Debug output --mapM_ (\edge -> traceST $ "Adding production edge " ++ show edge) toadd- return $ Just ret+ return ret -- | Add the "back edges" to the nonterminal graphs for creating a global ordering addBackEdges :: [([[Edge]], NontDependencyInformationM s)] -> ST s [Edge]
src/Options.hs view
@@ -9,6 +9,7 @@ options = [ Option ['m'] [] (NoArg (moduleOpt Nothing)) "generate default module header" , Option [] ["module"] (OptArg moduleOpt "name") "generate module header, specify module name" , Option ['d'] ["data"] (NoArg dataOpt) "generate data type definition"+ , Option [] ["datarecords"] (NoArg dataRecOpt) "generate record data types" , Option [] ["strictdata"] (NoArg strictDataOpt) "generate strict data fields (when data is generated)" , Option [] ["strictwrap"] (NoArg strictWrapOpt) "generate strict wrap fields for WRAPPER generated data" , Option ['c'] ["catas"] (NoArg cataOpt) "generate catamorphisms"@@ -53,8 +54,8 @@ , Option [] ["sepsemmods"] (NoArg sepSemModsOpt) "Generate separate modules for semantic functions (in generated code)" , Option ['M'] ["genfiledeps"] (NoArg genFileDepsOpt) "Generate a list of dependencies on the input AG files" , Option [] ["genvisage"] (NoArg genVisageOpt) "Generate output for the AG visualizer Visage"- , Option [] ["genAspectAG"] (NoArg genAspectAGOpt) "Generate AspectAG file"- , Option [] ["nogroup"] (ReqArg noGroupOpt "attributes") "specify the attributes that won't be grouped in genAspectAG"+ , Option [] ["aspectag"] (NoArg genAspectAGOpt) "Generate AspectAG file"+ , Option [] ["nogroup"] (ReqArg noGroupOpt "attributes") "specify the attributes that won't be grouped in AspectAG" , Option [] ["extends"] (ReqArg extendsOpt "module") "specify a module to be extended" , Option [] ["genattrlist"] (NoArg genAttrListOpt) "Generate a list of all explicitly defined attributes (outside irrefutable patterns)" , Option [] ["forceirrefutable"] (OptArg forceIrrefutableOpt "file") "Force a set of explicitly defined attributes to be irrefutable, specify file containing the attribute set"@@ -75,12 +76,29 @@ , Option [] ["checkParseHaskell"] (NoArg parseHsOpt) "Parse Haskell code (recognizer)" , Option [] ["nocatas"] (ReqArg nocatasOpt "list of nonterms") "Nonterminals not to generate catas for" , Option [] ["nooptimize"] (NoArg noOptimizeOpt) "Disable optimizations"+ , Option [] ["parallel"] (NoArg parallelOpt) "Generate a parallel evaluator (if possible)"+ , Option [] ["monadicwrapper"] (NoArg monadicWrappersOpt) "Generate monadic wrappers"++ , Option [] ["helpinlining"] (NoArg helpInliningOpt) "Generate inline directives for GHC"+ , Option [] ["dummytokenvisit"] (NoArg dummyTokenVisitOpt) "Add an additional dummy parameter to visit functions"+ , Option [] ["tupleasdummytoken"] (NoArg tupleAsDummyTokenOpt) "Use conventional tuples as dummy parameter instead of a RealWorld state token"+ , Option [] ["stateasdummytoken"] (NoArg stateAsDummyTokenOpt) "Use RealWorld state token as dummy parameter instead of conventional tuples (default)"+ , Option [] ["strictdummytoken"] (NoArg strictDummyTokenOpt) "Strictify the dummy token that makes states and rules functions"+ , Option [] ["noperruletypesigs"] (NoArg noPerRuleTypeSigsOpt) "Do not generate type sigs for attrs passed to rules"+ , Option [] ["noperstatetypesigs"] (NoArg noPerStateTypeSigsOpt) "Do not generate type sigs for attrs saved in node states"+ , Option [] ["noeagerblackholing"] (NoArg noEagerBlackholingOpt) "Do not automatically add the eager blackholing feature for parallel programs"+ , Option [] ["noperrulecostcentres"] (NoArg noPerRuleCostCentresOpt) "Do not generate cost centres for rules"+ , Option [] ["nopervisitcostcentres"] (NoArg noPerVisitCostCentresOpt) "Do not generate cost centres for visits"+ , Option [] ["noinlinepragmas"] (NoArg noInlinePragmasOpt) "Definitely not generate inline directives"+ , Option [] ["aggressiveinlinepragmas"] (NoArg aggressiveInlinePragmasOpt) "Generate more aggressive inline directives"+ , Option [] ["latehigherorderbinding"] (NoArg lateHigherOrderBindingOpt) "Generate an attribute and wrapper for late binding of higher-order attributes" ] allc = "dcfsprm" data Options = Options{ moduleName :: ModuleHeader , dataTypes :: Bool+ , dataRecords :: Bool , strictData :: Bool , strictWrap :: Bool , folds :: Bool@@ -116,9 +134,6 @@ , wmaxerrs :: Int , dumpgrammar :: Bool , dumpcgrammar :: Bool- , genTraces :: Bool- , genUseTraces :: Bool- , genCostCentres :: Bool , sepSemMods :: Bool , genFileDeps :: Bool , genLinePragmas :: Bool@@ -141,11 +156,36 @@ , checkParseTy :: Bool , checkParseBlock :: Bool , nocatas :: Set NontermIdent- , kennedyWarren :: Bool+ , noOptimizations :: Bool++ -- KW code path+ , kennedyWarren :: Bool+ , parallelInvoke :: Bool+ , tupleAsDummyToken :: Bool -- use the empty tuple as dummy token instead of State# RealWorld (Lambda State Hack GHC?)+ , dummyTokenVisit :: Bool -- add a dummy argument/pass dummy extra token to visits (should not really have an effect ... Lambda State Hack GHC?)+ , strictDummyToken :: Bool -- make the dummy token strict (to prevent its removal -- should not really have an effect)+ , noPerRuleTypeSigs :: Bool -- do not print type signatures for attributes of rules+ , noPerStateTypeSigs :: Bool -- do not print type signatures for attributes contained in the state+ , noEagerBlackholing :: Bool -- disable the use of eager black holing in the parallel evaluator code+ , lateHigherOrderBinding :: Bool -- generate code to allow late binding of higher-order children semantics+ , monadicWrappers :: Bool++ -- tracing+ , genTraces :: Bool+ , genUseTraces :: Bool+ , genCostCentres :: Bool+ , noPerRuleCostCentres :: Bool+ , noPerVisitCostCentres :: Bool++ -- inline pragma generation+ , helpInlining :: Bool+ , noInlinePragmas :: Bool+ , aggressiveInlinePragmas :: Bool } deriving Show noOptions = Options { moduleName = NoName , dataTypes = False+ , dataRecords = False , strictData = False , strictWrap = False , folds = False@@ -181,9 +221,6 @@ , wmaxerrs = 99999 , dumpgrammar = False , dumpcgrammar = False- , genTraces = False- , genUseTraces = False- , genCostCentres = False , sepSemMods = False , genFileDeps = False , genLinePragmas = False@@ -206,12 +243,36 @@ , checkParseTy = False , checkParseBlock = False , nocatas = Set.empty- , kennedyWarren = False , noOptimizations = False++ -- defaults for the KW-code path+ , kennedyWarren = False+ , parallelInvoke = False+ , tupleAsDummyToken = True+ , dummyTokenVisit = False+ , strictDummyToken = False+ , noPerRuleTypeSigs = False+ , noPerStateTypeSigs = False+ , noEagerBlackholing = False+ , lateHigherOrderBinding = False+ , monadicWrappers = False++ -- defaults for tracing+ , genTraces = False+ , genUseTraces = False+ , genCostCentres = False+ , noPerRuleCostCentres = False+ , noPerVisitCostCentres = False++ -- defaults for inline pragma generation+ , helpInlining = False+ , noInlinePragmas = False+ , aggressiveInlinePragmas = False } moduleOpt nm opts = opts{moduleName = maybe Default Name nm} dataOpt opts = opts{dataTypes = True}+dataRecOpt opts = opts{dataRecords = True} strictDataOpt opts = opts{strictData = True} strictWrapOpt opts = opts{strictWrap = True} cataOpt opts = opts{folds = True}@@ -253,7 +314,23 @@ genLinePragmasOpt opts = opts{genLinePragmas = True} genVisageOpt opts = opts{genvisage = True } genAspectAGOpt opts = opts{genAspectAG = True}-noGroupOpt att opts = opts{noGroup = extract att ++ noGroup opts} ++dummyTokenVisitOpt opts = opts { dummyTokenVisit = True }+tupleAsDummyTokenOpt opts = opts { tupleAsDummyToken = True }+stateAsDummyTokenOpt opts = opts { tupleAsDummyToken = False }+strictDummyTokenOpt opts = opts { strictDummyToken = True }+noPerRuleTypeSigsOpt opts = opts { noPerRuleTypeSigs = True }+noPerStateTypeSigsOpt opts = opts { noPerStateTypeSigs = True }+noEagerBlackholingOpt opts = opts { noEagerBlackholing = True }+noPerRuleCostCentresOpt opts = opts { noPerRuleCostCentres = True }+noPerVisitCostCentresOpt opts = opts { noPerVisitCostCentres = True }+helpInliningOpt opts = opts { helpInlining = True }+noInlinePragmasOpt opts = opts { noInlinePragmas = True }+aggressiveInlinePragmasOpt opts = opts { aggressiveInlinePragmas = True }+lateHigherOrderBindingOpt opts = opts { lateHigherOrderBinding = True }+monadicWrappersOpt opts = opts { monadicWrappers = True }++noGroupOpt att opts = opts{noGroup = extract att ++ noGroup opts} where extract s = case dropWhile isSeparator s of "" -> [] s' -> w : extract s''@@ -261,7 +338,7 @@ break isSeparator s' isSeparator x = x == ':' -extendsOpt m opts = opts{extends = Just m } +extendsOpt m opts = opts{extends = Just m } genAttrListOpt opts = opts { genAttributeList = True } forceIrrefutableOpt mbNm opts = opts { forceIrrefutables = mbNm }@@ -270,6 +347,7 @@ doubleColonsOpt opts = opts { doubleColons = True } haskellSyntaxOpt = lcKeywordsOpt . doubleColonsOpt . genLinePragmasOpt monadicOpt opts = opts { monadic = True }+parallelOpt opts = opts { parallelInvoke = True } ocamlOpt opts = opts { ocaml = True } visitorsOutputOpt opts = opts { visitorsOutput = True } statisticsOpt nm opts = opts { statsFile = Just nm }@@ -294,7 +372,7 @@ searchPathOpt path opts = opts{searchPath = extract path ++ searchPath opts} where extract xs = let (p,ps) = break (\x -> x == ';' || x == ':') xs in if null p then [] else p : extract ps-allOpt = moduleOpt Nothing . dataOpt . cataOpt . semfunsOpt . signaturesOpt . prettyOpt . renameOpt+allOpt = moduleOpt Nothing . dataOpt . cataOpt . semfunsOpt . signaturesOpt . prettyOpt . renameOpt . dataRecOpt optimizeOpt = visitOpt . casesOpt condDisableOptimizations opts
src/PPUtil.hs view
@@ -19,7 +19,8 @@ ppCommas = ppListSep "" "" ", " ppVList :: PP a => [a] -> PP_Doc-ppVList = pp_block "[ " "] " ", " . map pp+ppVList [] = "[" >#< "]"+ppVList (x:xs) = vlist (("[" >#< pp x) : (map (\y -> "," >#< pp y) xs)) >#< "]" ppMap :: (Show a, Show b) => Map.Map a b -> PP_Doc ppMap m = ppVList [ ppF (show k) $ ppShow v | (k,v) <- Map.toList m ]
src/Parser.hs view
@@ -13,6 +13,7 @@ import Scanner (Input(..),scanLit,input) import Data.List import Expression+import Macro --marcos import UU.Scanner.Token import UU.Scanner.TokenParser import UU.Scanner.GenToken@@ -108,6 +109,8 @@ <|> Either <$ pEITHER <*> pType <*> pType <|> Map <$ pMAP <*> pTypePrimitive <*> pType <|> IntMap <$ pINTMAP <*> pType+ <|> OrdSet <$ pSET <*> pType+ <|> IntSet <$ pINTSET <|> tuple <$> pParens (pListSep pComma field) where field = (,) <$> ((Just <$> pIdentifier <* pTypeColon) `opt` Nothing) <*> pTypeEncapsulated tuple xs = Tuple [(fromMaybe (Ident ("x"++show n) noPos) f, t)@@ -165,9 +168,15 @@ <*> pCodescrap' <*> pCodescrap' <*> pCodescrap'- <|> codeBlock <$> (pIdentifier <|> pSucceed (Ident "" noPos)) <*> ((Just <$ pATTACH <*> pIdentifierU) <|> pSucceed Nothing) <*> pCodeBlock <?> "a statement"- where codeBlock nm mbNt (txt,pos) = Txt pos nm mbNt (lines txt)+ <|> codeBlock <$> pBlockKind <*> ((Just <$ pATTACH <*> pIdentifierU) <|> pSucceed Nothing) <*> pCodeBlock <?> "a statement"+ where codeBlock knd mbNt (txt,pos) = Txt pos knd mbNt (lines txt) + pBlockKind :: AGParser BlockKind+ pBlockKind =+ BlockPragma <$ pOPTPRAGMAS+ <|> BlockImport <$ pIMPORTS+ <|> BlockMain <$ pTOPLEVEL -- block is moved to the toplevel ("main") module when "sepsemmods" is used+ <|> pSucceed BlockOther pAttrs :: AGParser Attrs pAttrs@@ -185,15 +194,15 @@ pSingleInhAttrDef :: AGParser (Identifier,Type,(String,String,String)) pSingleInhAttrDef- = (\v tp -> (v,tp,("","",""))) <$> pIdentifier <* pTypeColon <*> pType <?> "inh attribute declaration"+ = (\v tp -> (v,tp,("","",""))) <$> pAttrIdentifier <* pTypeColon <*> pTypeOrSelf <?> "inh attribute declaration" pSingleSynAttrDef :: AGParser (Identifier,Type,(String,String,String)) pSingleSynAttrDef- = (\v u tp -> (v,tp,u)) <$> pIdentifier <*> pUse <* pTypeColon <*> pType <?> "syn attribute declaration"+ = (\v u tp -> (v,tp,u)) <$> pAttrIdentifier <*> pUse <* pTypeColon <*> pTypeOrSelf <?> "syn attribute declaration" pSingleChnAttrDef :: AGParser (Identifier,Type,(String,String,String)) pSingleChnAttrDef- = (\v tp -> (v,tp,("","",""))) <$> pIdentifier <* pTypeColon <*> pType <?> "chn attribute declaration"+ = (\v tp -> (v,tp,("","",""))) <$> pAttrIdentifier <* pTypeColon <*> pTypeOrSelf <?> "chn attribute declaration" pOptAttrs :: AGParser Attrs pOptAttrs = pAttrs `opt` Attrs noPos [] [] []@@ -201,15 +210,15 @@ pInhAttrNames :: AGParser AttrNames pInhAttrNames = (\vs tp -> map (\v -> (v,tp,("","",""))) vs)- <$> pIdentifiers <* pTypeColon <*> pType <?> "attribute declarations"+ <$> pAttrIdentifiers <* pTypeColon <*> pTypeOrSelf <?> "attribute declarations" pAttrNames :: AGParser AttrNames pAttrNames = (\vs use tp -> map (\v -> (v,tp,use)) vs)- <$> pIdentifiers <*> pUse <* pTypeColon <*> pType <?> "attribute declarations"+ <$> pAttrIdentifiers <*> pUse <* pTypeColon <*> pTypeOrSelf <?> "attribute declarations" pAlt :: AGParser Alt- pAlt = Alt <$> pBar <*> pSimpleConstructorSet <*> pFields <?> "a datatype alternative"+ pAlt = (Alt <$> pBar <*> pSimpleConstructorSet <*> pList_ng pIdentifier <*> pFields <*> pMaybeMacro <?> "a datatype alternative") pAlts :: AGParser Alts pAlts = pList_ng pAlt <?> "datatype alternatives"@@ -219,10 +228,10 @@ pField :: AGParser Fields pField- = (\nms tp -> map (flip (,) tp) nms)- <$> pIdentifiers <* pTypeColon <*> pType- <|> (\s -> [(Ident (mklower (getName s)) (getPos s) ,NT s [])]) <$> pIdentifierU-+ = (\nms tp -> map (\nm -> FChild nm tp) nms) <$> pAttrIdentifiers <* pTypeColon <*> pType+ <|> (\s -> [FChild (Ident (mklower $ getName s) (getPos s)) (NT s [] False)]) <$> pIdentifierU+ <|> (\t -> [FCtx [t]]) <$ pSmallerEqual <*> pTypePrimitive+ pSemAlt :: AGParser SemAlt pSemAlt = SemAlt <$> pBar <*> pConstructorSet <*> pSemDefs <?> "SEM alternative" @@ -235,11 +244,11 @@ <|> pLOC *> pList1 pLocDecl <|> pINST *> pList1 pInstDecl <|> pSEMPRAGMA *> pList1 (SemPragma <$> pNames)- <|> (\n e -> [AugmentDef n e]) <$ pAugmentToken <*> pIdentifier <* pAssign <*> pExpr- <|> (\n e -> [AroundDef n e]) <$ pAROUND <*> pIdentifier <* pAssign <*> pExpr+ <|> (\n e -> [AugmentDef n e]) <$ pAugmentToken <*> pAttrIdentifier <* pAssign <*> pExpr+ <|> (\n e -> [AroundDef n e]) <$ pAROUND <*> pAttrIdentifier <* pAssign <*> pExpr <|> (\a b -> [AttrOrderBefore a [b]]) <$> pList1 pAttrOrIdent <* pSmaller <*> pAttrOrIdent <|> (\sources target nt expr -> [MergeDef target nt sources expr]) <$ pMERGE <*> (pList1_ng pIdentifier <* pAS <|> pSucceed []) <*> pIdentifier <* pTypeColon <*> pIdentifierU <* pAssign <*> pExpr- <|> (\mbNm pat (owrt,pos) exp -> [Def pos mbNm (pat ()) exp owrt]) <$> pMaybeRuleName <*> pPattern (const <$> pAttr) <*> pAssignPos <*> pExpr+ <|> (\mbNm pat (owrt,pos,pur,eager) exp -> [Def pos mbNm (pat ()) exp owrt pur eager]) <$> pMaybeRuleName <*> pPattern (const <$> pAttr) <*> pRuleSym <*> pExpr pMaybeRuleName :: AGParser (Maybe Identifier) pMaybeRuleName@@ -248,10 +257,10 @@ pAttrDef :: AGParser (Maybe Identifier -> Identifier -> SemDef) pAttrDef- = (\pat (owrt,pos) exp mbNm fld -> Def pos mbNm (pat fld) exp owrt)- <$ pDot <*> pattern <*> pAssignPos <*> pExpr+ = (\pat (owrt,pos,pur,eager) exp mbNm fld -> Def pos mbNm (pat fld) exp owrt pur eager)+ <$ pDot <*> pattern <*> pRuleSym <*> pExpr where pattern = pPattern pVar- <|> (\ir a fld -> ir $ Alias fld a (Underscore noPos) []) <$> ((Irrefutable <$ pTilde) `opt` id) <*> pIdentifier+ <|> (\ir a fld -> ir $ Alias fld a (Underscore noPos)) <$> ((Irrefutable <$ pTilde) `opt` id) <*> pAttrIdentifier pLocDecl :: AGParser SemDef pLocDecl = pDot <**> (pIdentifier <**> (pTypeColon <**> ( (\(tp,pos) _ ident _ -> TypeDef pos ident tp) <$> pLocType@@ -274,6 +283,24 @@ then pDoubleColon else pColon + --marcos+ pMaybeMacro :: AGParser MaybeMacro+ pMaybeMacro = Just <$ pDoubleArrow <*> pMacro+ <|> pSucceed Nothing++ pMacro :: AGParser Macro+ pMacro+ = Macro <$> pIdentifierU+ <*> pList1 pMacroChild+ <?> "macro"++ pMacroChild :: AGParser MacroChild+ pMacroChild+ = (pIdentifier <* pEquals) <**>+ (flip RuleChild <$> pMacro <|>+ flip ChildChild <$> pIdentifier <|>+ flip ValueChild <$> pCodescrap' )+ -- -- End of AG Parser --@@ -349,8 +376,8 @@ pTypeNt :: AGParser Type pTypeNt- = ((\nt -> NT nt []) <$> pIdentifierU <?> "nonterminal name (no brackets)")- <|> (pParens (NT <$> pIdentifierU <*> pList pTypeHaskellAnyAsString) <?> "nonterminal name with parameters (using parenthesis)")+ = ((\nt -> mkNtType nt []) <$> pIdentifierU <?> "nonterminal name (no brackets)")+ <|> (pParens (mkNtType <$> pIdentifierU <*> pList pTypeHaskellAnyAsString) <?> "nonterminal name with parameters (using parenthesis)") pTypeHaskellAnyAsString :: AGParser String pTypeHaskellAnyAsString@@ -362,7 +389,7 @@ pTypeEncapsulated :: AGParser Type pTypeEncapsulated = pParens pTypeEncapsulated- <|> NT <$> pIdentifierU <*> pList pTypeHaskellAnyAsString+ <|> mkNtType <$> pIdentifierU <*> pList pTypeHaskellAnyAsString <|> (Haskell . getName) <$> pIdentifier <|> pTypePrimitive @@ -374,9 +401,20 @@ pType = pTypeNt <|> pTypePrimitive +pTypeOrSelf :: AGParser Type+pTypeOrSelf = pType <|> Self <$ pSELF+ pIdentifiers :: AGParser [Identifier] pIdentifiers = pList1Sep pComma pIdentifier <?> "lowercase identifiers" +pAttrIdentifier :: AGParser Identifier+pAttrIdentifier = pIdentifier+ <|> (\pos -> Ident "imports" pos) <$> pIMPORTS+ <|> (\pos -> Ident "toplevel" pos) <$> pTOPLEVEL++pAttrIdentifiers :: AGParser [Identifier]+pAttrIdentifiers = pList1Sep pComma pAttrIdentifier <?> "lowercase identifiers"+ pUse :: AGParser (String,String,String) pUse = ( (\u x y->(x,y,show u)) <$> pUSE <*> pCodescrap' <*> pCodescrap') `opt` ("","","") <?> "USE declaration" @@ -404,10 +442,10 @@ pAugmentToken :: AGParser () pAugmentToken = () <$ (pAUGMENT <|> pPlus) -pAttr = (,) <$> pFieldIdentifier <* pDot <*> pIdentifier+pAttr = (,) <$> pFieldIdentifier <* pDot <*> pAttrIdentifier pAttrOrIdent- = OccAttr <$> pFieldIdentifier <* pDot <*> pIdentifier+ = OccAttr <$> pFieldIdentifier <* pDot <*> pAttrIdentifier <|> OccRule <$> pIdentifier nl2sp :: Char -> Char@@ -420,15 +458,17 @@ <|> (\(s,p) -> (Haskell s,p)) <$> pCodescrap <?> "a type" pVar :: AGParser (Identifier -> (Identifier, Identifier))-pVar = (\att fld -> (fld,att)) <$> pIdentifier+pVar = (\att fld -> (fld,att)) <$> pAttrIdentifier pAssign :: AGParser Bool pAssign = False <$ pReserved "=" <|> True <$ pReserved ":=" -pAssignPos :: AGParser (Bool, Pos)-pAssignPos = (\p -> (False,p)) <$> pReserved "="- <|> (\p -> (True,p)) <$> pReserved ":="+pRuleSym :: AGParser (Bool, Pos, Bool, Bool)+pRuleSym = (\p -> (False, p, True, False)) <$> pReserved "="+ <|> (\p -> (True, p, True, False)) <$> pReserved ":="+ <|> (\p -> (False, p, True, False)) <$> pReserved "<-"+ <|> (\p -> (False, p, True, True)) <$> pReserved "<<-" pPattern :: AGParser (a -> (Identifier,Identifier)) -> AGParser (a -> Pattern) pPattern pvar = pPattern2 where@@ -437,7 +477,7 @@ <|> pPattern1 <?> "a pattern" pPattern1 = pvariable <|> pPattern2- pvariable = (\ir var pat a -> case var a of (fld,att) -> ir $ Alias fld att (pat a) [])+ pvariable = (\ir var pat a -> case var a of (fld,att) -> ir $ Alias fld att (pat a)) <$> ((Irrefutable <$ pTilde) `opt` id) <*> pvar <*> ((pAt *> pPattern1) `opt` const (Underscore noPos)) pPattern2 = (mkTuple <$> pOParenPos <*> pListSep pComma pPattern0 <* pCParen ) <|> (const . Underscore) <$> pUScore <?> "a pattern"@@ -453,10 +493,11 @@ pCodescrap = pCodeBlock pSEM, pATTR, pDATA, pUSE, pLOC,pINCLUDE, pTYPE, pEquals, pColonEquals, pTilde,- pEXTENDS, -- marcos+ pEXTENDS, --marcos pBar, pColon, pLHS,pINST,pSET,pDERIVING,pMinus,pIntersect,pDoubleArrow,pArrow, pDot, pUScore, pEXT,pAt,pStar, pSmaller, pWRAPPER, pNOCATAS, pPRAGMA, pMAYBE, pEITHER, pMAP, pINTMAP,- pMODULE, pATTACH, pUNIQUEREF, pINH, pSYN, pAUGMENT, pPlus, pAROUND, pSEMPRAGMA, pMERGE, pAS+ pMODULE, pATTACH, pUNIQUEREF, pINH, pSYN, pAUGMENT, pPlus, pAROUND, pSEMPRAGMA, pMERGE, pAS, pSELF,+ pIMPORTS, pOPTPRAGMAS, pSmallerEqual, pINTSET :: AGParser Pos pSET = pCostReserved 90 "SET" <?> "SET" pDERIVING = pCostReserved 90 "DERIVING"<?> "DERIVING"@@ -479,6 +520,7 @@ pEITHER = pCostReserved 5 "EITHER" <?> "EITHER" pMAP = pCostReserved 5 "MAP" <?> "MAP" pINTMAP = pCostReserved 5 "INTMAP" <?> "INTMAP"+pINTSET = pCostReserved 5 "INTSET" <?> "INTSET" pUSE = pCostReserved 5 "USE" <?> "USE" pLOC = pCostReserved 5 "loc" <?> "loc" pLHS = pCostReserved 5 "lhs" <?> "loc"@@ -496,6 +538,7 @@ pIntersect = pCostReserved 5 "/\\" <?> "/\\" pMinus = pCostReserved 5 "-" <?> "-" pDoubleArrow = pCostReserved 5 "=>" <?> "=>"+pSmallerEqual= pCostReserved 5 "<=" <?> "<=" pArrow = pCostReserved 5 "->" <?> "->" pStar = pCostReserved 5 "*" <?> "*" pSmaller = pCostReserved 5 "<" <?> "<"@@ -505,3 +548,7 @@ pAROUND = pCostReserved 5 "AROUND" <?> "AROUND" pMERGE = pCostReserved 5 "MERGE" <?> "MERGE" pAS = pCostReserved 5 "AS" <?> "AS"+pSELF = pCostReserved 5 "SELF" <?> "SELF"+pIMPORTS = pCostReserved 5 "imports" <?> "imports"+pOPTPRAGMAS = pCostReserved 5 "optpragmas" <?> "optpragmas"+pTOPLEVEL = pCostReserved 5 "toplevel" <?> "toplevel"
src/Pretty.hs view
@@ -25,13 +25,14 @@ where import Data.List(intersperse)- + ------------------------------------------------------------------------- -- Doc structure ------------------------------------------------------------------------- data Doc = Emp+ | Emp1 | Str !String -- basic string | Hor Doc !Doc -- horizontal positioning | Ver Doc !Doc -- vertical positioning@@ -45,16 +46,24 @@ ------------------------------------------------------------------------- infixr 3 >|<, >#<-infixr 2 >-< +infixr 2 >-< (>|<) :: (PP a, PP b) => a -> b -> PP_Doc l >|< r = pp l `Hor` pp r (>-<) :: (PP a, PP b) => a -> b -> PP_Doc-l >-< r = pp l `Ver` pp r+l >-< r | isEmpty a = b+ | isEmpty b = a+ | otherwise = a `Ver` b+ where a = pp l+ b = pp r (>#<) :: (PP a, PP b) => a -> b -> PP_Doc-l >#< r = l >|< " " >|< r+l >#< r | isEmpty a = b+ | isEmpty b = a+ | otherwise = a >|< " " >|< b+ where a = pp l+ b = pp r indent :: PP a => Int -> a -> PP_Doc indent i d = Ind i $ pp d@@ -69,6 +78,10 @@ empty :: PP_Doc empty = Emp +-- empty1 is not a zero for >#<+empty1 :: PP_Doc+empty1 = Emp1+ ppWithLineNr :: PP a => (Int -> a) -> PP_Doc ppWithLineNr f = Line (pp . f) @@ -140,6 +153,7 @@ isEmpty :: PP_Doc -> Bool isEmpty Emp = True+isEmpty Emp1 = False isEmpty (Ver d1 d2) = isEmpty d1 && isEmpty d2 isEmpty (Hor d1 d2) = isEmpty d1 && isEmpty d2 isEmpty (Ind _ d ) = isEmpty d@@ -156,6 +170,7 @@ put p l d s = case d of Emp -> (s,p,l)+ Emp1 -> (s,p,l) Str s' -> (s' ++ s,p + length s',l) Ind i d -> (ind ++ r,p', l') where (r,p',l') = put (p+i) l d s
src/Scanner.hs view
@@ -67,6 +67,9 @@ scan' ('_' :rs) = (reserved "_" p, advc 1 p, rs) scan' ('~' :rs) = (reserved "~" p, advc 1 p, rs) scan' ('+' :rs) = (reserved "+" p, advc 1 p, rs) + scan' ('<' : '-' : rs) = (reserved "<-" p, advc 2 p, rs) + scan' ('<' : '=' : rs) = (reserved "<=" p, advc 2 p, rs) + scan' ('<' : '<' : '-' : rs) = (reserved "<<-" p, advc 3 p, rs) scan' ('<' :rs) = (reserved "<" p, advc 1 p, rs) scan' ('[' :rs) = (reserved "[" p, advc 1 p, rs) scan' (']' :rs) = (reserved "]" p, advc 1 p, rs) @@ -86,7 +89,7 @@ scan' ('=' :rs) = (reserved "=" p, advc 1 p, rs) scan' (':':'=':rs) = (reserved ":=" p, advc 2 p, rs) - scan' (':':':':rs) {- | doubleColons opts -} = (reserved "::" p, advc 1 p, rs) -- recognize double colons too + scan' (':':':':rs) {- | doubleColons opts -} = (reserved "::" p, advc 1 p, rs) -- recognize double colons too scan' (':' :rs) = (reserved ":" p, advc 1 p, rs) scan' ('|' :rs) = (reserved "|" p, advc 1 p, rs) @@ -129,13 +132,13 @@ ident = span isValid where isValid x = isAlphaNum x || x =='_' || x == '\'' -lowercaseKeywords = ["loc","lhs", "inst"] +lowercaseKeywords = ["loc","lhs", "inst", "optpragmas", "imports", "toplevel"] keywords = lowercaseKeywords ++ [ "DATA", "EXT", "ATTR", "SEM","TYPE", "USE", "INCLUDE" , "EXTENDS" -- marcos , "SET","DERIVING","FOR", "WRAPPER", "NOCATAS", "MAYBE", "EITHER", "MAP", "INTMAP" , "PRAGMA", "SEMPRAGMA", "MODULE", "ATTACH", "UNIQUEREF", "INH", "SYN", "CHN" - , "AUGMENT", "AROUND", "MERGE", "AS" + , "AUGMENT", "AROUND", "MERGE", "AS", "SELF", "INTSET" ] ncomment c p ('-':'}':xs) = advc' 2 p c xs
src/SequentialComputation.lhs view
@@ -349,7 +349,7 @@ isLocLoc :: Table CRule -> EdgePath -> Bool isLocLoc rt ((s,t),_) = isLocal (rt ! s) && isLocal (rt ! t)- -- || (isInst (rt ! s) && isInst (rt ! t))+ -- || (isInst (rt ! s) && isInst (rt ! t)) computeSequential :: Info -> [Edge] -> [Edge] -> CycleStatus computeSequential info dpr instToSynEdges
uuagc.cabal view
@@ -3,8 +3,8 @@ x-bootstrap-build-type: Simple name: uuagc x-bootstrap-name: uuagc-bootstrap-version: 0.9.39.1-x-bootstrap-version: 0.9.39.1.0+version: 0.9.39.3+x-bootstrap-version: 0.9.39.3.0 license: BSD3 license-file: LICENSE maintainer: Arie Middelkoop <ariem@cs.uu.nl>@@ -19,6 +19,7 @@ tested-with: GHC >= 6.12 extra-source-files: README extra-source-files: uuagc_options+extra-source-files: src-ag/DistChildAttr.ag executable uuagc build-depends: uuagc-bootstrap >= 0.9.39.1.0@@ -72,6 +73,7 @@ , VisageSyntax , VisagePatterns , AG2AspectAG+ , Macro , RhsCheck , ResolveLocals , Knuth1
uuagc_options view
@@ -90,6 +90,9 @@ file: "src-ag/AG2AspectAG.ag" options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell +file: "src-ag/Macro.ag"+options: module, pretty, data, genlinepragmas, checkParseHaskell+ file: "src-ag/ExecutionPlan2Hs.ag" options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell