uuagc 0.9.40.2 → 0.9.40.3
raw patch · 4 files changed
+42/−24 lines, 4 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- src-ag/AG2AspectAG.ag +15/−9
- src-ag/Transform.ag +17/−7
- src/Ag.hs +8/−6
- uuagc.cabal +2/−2
src-ag/AG2AspectAG.ag view
@@ -22,6 +22,7 @@ import TokenDef import CommonTypes +-- import Debug.Trace } {@@ -74,7 +75,7 @@ ATTR Grammar [ agi : {(Set NontermIdent, DataTypes, Map NontermIdent (Attributes, Attributes))} | | ] -ATTR Nonterminals Nonterminal Productions Production [ newAtts : { Attributes } | | ]+ATTR Nonterminals Nonterminal Productions Production Children Child Rules Rule [ newAtts : { Attributes } | | ] SEM Grammar | Grammar loc.newAtts = case @lhs.agi of (_,_,atts) -> ( Map.unions . (\(a,b) -> a++b) . unzip . Map.elems) atts@@ -129,7 +130,7 @@ "import Data.HList.TypeEqGeneric1" >-< "import Data.HList.TypeCastGeneric1" >-< maybe empty ("import qualified" >#<) @lhs.ext >-<- maybe empty (\ext -> "import" >#< ext >#< ppListSep "(" ")" "," (@nonts.ppDI ++ @nonts.ppLI ++ @loc.ppAI)) @lhs.ext+ maybe empty (\ext -> "import" >#< ext >#< ppListSep "(" ")" "," (@nonts.ppDI ++ @nonts.ppLI ++ @loc.ppAI ++ @loc.ppANT)) @lhs.ext -- CODE @@ -313,12 +314,17 @@ @nonts.ppAI + loc . ppANT =+ let atts = filterNotAtts @loc.newAtts @loc.o_noGroup+ in (foldr (\a as -> ("nts_" >|< a) : as) [] atts)+ ATTR Nonterminals Nonterminal Productions Production [ | | ppA USE {>-<} {empty} : PP_Doc ] SEM Nonterminal | Nonterminal lhs . ppA = ( if (Set.member @nt @lhs.newNTs)- then defAttRec (pp "InhG") @loc.ppNt @inh @loc.inhNoGroup >-<- defAttRec (pp "SynG") @loc.ppNt @syn @loc.synNoGroup+ then + defAttRec (pp "InhG") @loc.ppNt @inh @loc.inhNoGroup >-<+ defAttRec (pp "SynG") @loc.ppNt @syn @loc.synNoGroup else empty) >-< @prods.ppA @@ -342,7 +348,7 @@ 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@@ -463,7 +469,7 @@ | Nil lhs . ppRL = [] SEM Rule- | Rule lhs . ppRL = if (not @explicit && not @lhs.newProd)+ | Rule lhs . ppRL = if (not @explicit && not @lhs.newProd && not (Map.member (snd @pattern.info) @lhs.newAtts) ) then [] else [ ppRule @pattern.info @owrt (defRule @lhs.ppNt @pattern.info @lhs.o_noGroup @rhs.ppRE) ] @@ -584,7 +590,7 @@ indent 5 ch >-< indent 5 "return $" >-< indent 6 ((ruleDef rule) chids locals)- in+ in if new then if (not owrt && (newNT || (not newNT && newProd) || newAtt)) then (ppR "syndefM", [ ppAtt ])@@ -693,7 +699,7 @@ "lhs" -> ppName [pp (getName attr), pp "InhG", ppNt] "loc" -> ppName [pp (getName attr), ppNt, ppProd] otherwise -> ppName [pp (getName attr), pp "SynG", ppChT]- in (pos, if (elem (getName attr) noGroup )+ in (pos, if ((elem (getName attr) noGroup) && ((show field) /= "loc")) then pp "(" >|< pp (getName field) >|< " # " >|< attName (getName attr) >|< pp ")" else pp "(" >|< ppSubAtt >|< " (" >|< pp (getName field) >|< " # " >|< ppAtt >|< ")) ") HsToken value pos -> (pos, pp value)@@ -783,7 +789,7 @@ synAtts >|< "(HCons (LVPair (Proxy Att_syn) SynG_" >|< @loc.ppNt >|< ") HNil))" >|< replicate (length synAtts) ")" >-<- "instance SemType T_" >|< @loc.ppNt >|< " " >|< @loc.ppNt >-<+ "-- instance SemType T_" >|< @loc.ppNt >|< " " >|< @loc.ppNt >-< "-- sem_" >|< @loc.ppNt >|< " :: " >|< @loc.ppNt >|< " -> T_" >|< @loc.ppNt >-< @prods.ppSPF -- >-< -- @prods.ppSF
src-ag/Transform.ag view
@@ -308,7 +308,7 @@ loc.checkedUniques = Map.map (Map.map fst) @loc.allUniquesErrs loc.checkedAugments = Map.map (Map.map fst) @loc.allAugmentErrs loc.checkedArounds = Map.map (Map.map fst) @loc.allAroundsErrs- loc.checkedRules = Map.unionWith (Map.unionWith (++)) @loc.checkedRulesPre (Map.mapWithKey (Map.mapWithKey . (mkUniqueRules @lhs.options @loc.allFields @loc.checkedInsts @loc.allAttrDecls)) @loc.checkedUniques)+ loc.checkedRules = Map.unionWith (Map.unionWith (++)) @loc.checkedRulesPre (Map.mapWithKey (Map.mapWithKey . (mkUniqueRules @lhs.options @loc.allRules @loc.allFields @loc.checkedInsts @loc.allAttrDecls)) @loc.checkedUniques) loc.checkedMerges = Map.map (Map.map fst) @loc.allMergesErrs loc.errs1 = let f = checkForDuplicates (DupSynonym)@@ -505,14 +505,17 @@ {-mkUniqueRules :: Options -> Map NontermIdent (Map ConstructorIdent [(Identifier, Type)]) -> Map NontermIdent (Map ConstructorIdent [(Identifier, Type)]) -> Map NontermIdent (Attributes,Attributes) -> NontermIdent -> ConstructorIdent -> Map Identifier Identifier -> [Rule]-mkUniqueRules opts allFields allInsts allAttrDecls nt con usMap+mkUniqueRules :: Options -> Map NontermIdent (Map ConstructorIdent [RuleInfo]) -> Map NontermIdent (Map ConstructorIdent [(Identifier, Type)]) -> Map NontermIdent (Map ConstructorIdent [(Identifier, Type)]) -> Map NontermIdent (Attributes,Attributes) -> NontermIdent -> ConstructorIdent -> Map Identifier Identifier -> [Rule]+mkUniqueRules opts allRules allFields allInsts allAttrDecls nt con usMap = map apply groups where fields = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allFields) ++ Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allInsts) -- may have duplicates + attrDefs = let projectDefs (_,_,_,defs,_,_,_,_) = defs+ in concatMap projectDefs $ Map.findWithDefault [] con $ Map.findWithDefault Map.empty nt allRules+ 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@@ -520,15 +523,22 @@ (x:_) -> x hasSyn tp ref = Map.member ref $ snd $ Map.findWithDefault (Map.empty,Map.empty) tp allAttrDecls mkRule ref outFld locAttrs- = let pat = Product noPos (attr outFld ref : [attr _LOC u | u <- locAttrs ])- rhs = Expression noPos $ wrap ref $ foldr gencase (finalout locAttrs) locAttrs+ = let locs = filter (not . existsLoc) locAttrs+ outAttr = attr outFld ref+ defs = (if hasOut then [] else [outAttr]) ++ [attr _LOC u | u <- locs ]+ pat = Product noPos defs+ rhs = Expression noPos $ wrap ref $ foldr gencase (finalout hasOut locs) locs -- [HsToken ("mkUniques" ++ show (length locAttrs) ++ " ") noPos, AGField _LHS ref noPos Nothing]- in Rule Nothing pat rhs False "-- generated by the unique rule mechanism." False True False Nothing False+ rul = Rule Nothing pat rhs False "-- generated by the unique rule mechanism." False True False Nothing False+ hasOut = exists outAttr+ exists (Alias fld a _) = (fld,a) `elem` attrDefs+ existsLoc nm = exists (attr _LOC nm)+ in rul 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]- finalout us = h ("(__cont, " ++ concat (intersperse "," (map getName us)) ++ ")")+ finalout noGenCont us = h ("(" ++ concat (intersperse "," ( (if noGenCont then [] else ["__cont"]) ++ map getName us)) ++ ")") wrap ref inp = h "let __cont = " ++ [AGField _LHS ref noPos Nothing] ++ h " in seq __cont ( " ++ inp ++ h " )" }
src/Ag.hs view
@@ -244,7 +244,7 @@ , pp pragmaBlocksTxt , pp $ take 70 ("-- UUAGC2AspectAG " ++ drop 50 banner ++ " (" ++ input) ++ ")" , pp $ if isNothing $ Pass1.moduleDecl_Syn_AG output1- then moduleHeader flags' mainName+ then moduleHeader flags' mainName ext' else mkModuleHeader (Pass1.moduleDecl_Syn_AG output1) mainName "" "" False , pp importBlocksTxt , AspectAGDump.imp_Syn_Grammar aspectAG@@ -264,7 +264,7 @@ = vlist [ Pass4b.warrenFlagsPP flags' , pp pragmaBlocksTxt , pp $ if isNothing $ Pass1.moduleDecl_Syn_AG output1- then moduleHeader flags' mainName+ then moduleHeader flags' mainName Nothing else mkModuleHeader (Pass1.moduleDecl_Syn_AG output1) mainName "" "" False , pp importBlocksTxt , ( if tupleAsDummyToken flags'@@ -295,7 +295,7 @@ , pp pragmaBlocksTxt , pp $ take 70 ("-- UUAGC " ++ drop 50 banner ++ " (" ++ input) ++ ")" , pp $ if isNothing $ Pass1.moduleDecl_Syn_AG output1- then moduleHeader flags' mainName+ then moduleHeader flags' mainName Nothing else mkModuleHeader (Pass1.moduleDecl_Syn_AG output1) mainName "" "" False ] else []@@ -353,13 +353,15 @@ errorsToFront flags mesgs = errs ++ warnings where (errs,warnings) = partition (PrErr.isError flags) mesgs -moduleHeader :: Options -> String -> String-moduleHeader flags input+moduleHeader :: Options -> String -> Maybe String -> String+moduleHeader flags input export = case moduleName flags of Name nm -> genMod nm Default -> genMod (defaultModuleName input) NoName -> ""- where genMod x = "module " ++ x ++ " where"+ where genMod x = "module " ++ x ++ genExp export x ++ " where"+ genExp Nothing _ = ""+ genExp (Just e) x = "(module " ++ x ++ ", module " ++ e ++ ")" inputFile :: String -> String inputFile name
uuagc.cabal view
@@ -3,8 +3,8 @@ x-bootstrap-build-type: Simple name: uuagc x-bootstrap-name: uuagc-bootstrap-version: 0.9.40.2-x-bootstrap-version: 0.9.40.2+version: 0.9.40.3+x-bootstrap-version: 0.9.40.3 license: BSD3 license-file: LICENSE maintainer: Arie Middelkoop <ariem@cs.uu.nl>