diff --git a/src-ag/AG2AspectAG.ag b/src-ag/AG2AspectAG.ag --- a/src-ag/AG2AspectAG.ag +++ b/src-ag/AG2AspectAG.ag @@ -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 diff --git a/src-ag/Transform.ag b/src-ag/Transform.ag --- a/src-ag/Transform.ag +++ b/src-ag/Transform.ag @@ -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 " )" } diff --git a/src/Ag.hs b/src/Ag.hs --- a/src/Ag.hs +++ b/src/Ag.hs @@ -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 diff --git a/uuagc.cabal b/uuagc.cabal --- a/uuagc.cabal +++ b/uuagc.cabal @@ -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