uuagc 0.9.52.1 → 0.9.52.2
raw patch · 60 files changed
+224/−15315 lines, 60 filesdep ~uuagcPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: uuagc
API changes (from Hackage documentation)
- UU.UUAGC: aggressiveInlinePragmas :: Options -> Bool
- UU.UUAGC: allowSepSemMods :: Options -> Bool
- UU.UUAGC: aoag :: Options -> Bool
- UU.UUAGC: attrInfo :: Options -> Bool
- UU.UUAGC: bangpats :: Options -> Bool
- UU.UUAGC: beQuiet :: Options -> Bool
- UU.UUAGC: breadthFirst :: Options -> Bool
- UU.UUAGC: breadthFirstStrict :: Options -> Bool
- UU.UUAGC: cases :: Options -> Bool
- UU.UUAGC: checkParseBlock :: Options -> Bool
- UU.UUAGC: checkParseRhs :: Options -> Bool
- UU.UUAGC: checkParseTy :: Options -> Bool
- UU.UUAGC: clean :: Options -> Bool
- UU.UUAGC: dataRecords :: Options -> Bool
- UU.UUAGC: dataTypes :: Options -> Bool
- UU.UUAGC: doubleColons :: Options -> Bool
- UU.UUAGC: dummyTokenVisit :: Options -> Bool
- UU.UUAGC: dumpcgrammar :: Options -> Bool
- UU.UUAGC: dumpgrammar :: Options -> Bool
- UU.UUAGC: extends :: Options -> Maybe String
- UU.UUAGC: failWithCode :: Options -> Int -> IO ()
- UU.UUAGC: folds :: Options -> Bool
- UU.UUAGC: forceIrrefutables :: Options -> Maybe String
- UU.UUAGC: genAspectAG :: Options -> Bool
- UU.UUAGC: genAttributeList :: Options -> Bool
- UU.UUAGC: genCostCentres :: Options -> Bool
- UU.UUAGC: genFileDeps :: Options -> Bool
- UU.UUAGC: genLinePragmas :: Options -> Bool
- UU.UUAGC: genTraces :: Options -> Bool
- UU.UUAGC: genUseTraces :: Options -> Bool
- UU.UUAGC: genvisage :: Options -> Bool
- UU.UUAGC: getName :: Identifier -> String
- UU.UUAGC: getPos :: Identifier -> Pos
- UU.UUAGC: helpInlining :: Options -> Bool
- UU.UUAGC: kennedyWarren :: Options -> Bool
- UU.UUAGC: lateHigherOrderBinding :: Options -> Bool
- UU.UUAGC: lcKeywords :: Options -> Bool
- UU.UUAGC: loag :: Options -> Bool
- UU.UUAGC: localCps :: Options -> Bool
- UU.UUAGC: mainFilename :: Options -> Maybe String
- UU.UUAGC: minvisits :: Options -> Bool
- UU.UUAGC: modcopy :: Options -> Bool
- UU.UUAGC: moduleName :: Options -> ModuleHeader
- UU.UUAGC: monadic :: Options -> Bool
- UU.UUAGC: monadicWrappers :: Options -> Bool
- UU.UUAGC: nest :: Options -> Bool
- UU.UUAGC: newtypes :: Options -> Bool
- UU.UUAGC: noEagerBlackholing :: Options -> Bool
- UU.UUAGC: noGroup :: Options -> [String]
- UU.UUAGC: noIncludes :: Options -> Bool
- UU.UUAGC: noInlinePragmas :: Options -> Bool
- UU.UUAGC: noOptimizations :: Options -> Bool
- UU.UUAGC: noPerRuleCostCentres :: Options -> Bool
- UU.UUAGC: noPerRuleTypeSigs :: Options -> Bool
- UU.UUAGC: noPerStateTypeSigs :: Options -> Bool
- UU.UUAGC: noPerVisitCostCentres :: Options -> Bool
- UU.UUAGC: nocatas :: Options -> Set NontermIdent
- UU.UUAGC: ocaml :: Options -> Bool
- UU.UUAGC: outputFiles :: Options -> [String]
- UU.UUAGC: outputStr :: Options -> String -> IO ()
- UU.UUAGC: parallelInvoke :: Options -> Bool
- UU.UUAGC: prefix :: Options -> String
- UU.UUAGC: reference :: Options -> Bool
- UU.UUAGC: rename :: Options -> Bool
- UU.UUAGC: searchPath :: Options -> [String]
- UU.UUAGC: semfuns :: Options -> Bool
- UU.UUAGC: sepSemMods :: Options -> Bool
- UU.UUAGC: showHelp :: Options -> Bool
- UU.UUAGC: showVersion :: Options -> Bool
- UU.UUAGC: smacro :: Options -> Bool
- UU.UUAGC: splitSems :: Options -> Bool
- UU.UUAGC: statsFile :: Options -> Maybe String
- UU.UUAGC: strictCases :: Options -> Bool
- UU.UUAGC: strictData :: Options -> Bool
- UU.UUAGC: strictDummyToken :: Options -> Bool
- UU.UUAGC: strictSems :: Options -> Bool
- UU.UUAGC: strictWrap :: Options -> Bool
- UU.UUAGC: stricterCases :: Options -> Bool
- UU.UUAGC: tupleAsDummyToken :: Options -> Bool
- UU.UUAGC: typeSigs :: Options -> Bool
- UU.UUAGC: unbox :: Options -> Bool
- UU.UUAGC: uniqueDispenser :: Options -> String
- UU.UUAGC: verbose :: Options -> Bool
- UU.UUAGC: visit :: Options -> Bool
- UU.UUAGC: visitorsOutput :: Options -> Bool
- UU.UUAGC: werrors :: Options -> Bool
- UU.UUAGC: wignore :: Options -> Bool
- UU.UUAGC: withCycle :: Options -> Bool
- UU.UUAGC: withSelf :: Options -> Bool
- UU.UUAGC: withSeq :: Options -> Bool
- UU.UUAGC: wmaxerrs :: Options -> Int
- UU.UUAGC: wrappers :: Options -> Bool
+ UU.UUAGC: [aggressiveInlinePragmas] :: Options -> Bool
+ UU.UUAGC: [allowSepSemMods] :: Options -> Bool
+ UU.UUAGC: [aoag] :: Options -> Bool
+ UU.UUAGC: [attrInfo] :: Options -> Bool
+ UU.UUAGC: [bangpats] :: Options -> Bool
+ UU.UUAGC: [beQuiet] :: Options -> Bool
+ UU.UUAGC: [breadthFirstStrict] :: Options -> Bool
+ UU.UUAGC: [breadthFirst] :: Options -> Bool
+ UU.UUAGC: [cases] :: Options -> Bool
+ UU.UUAGC: [checkParseBlock] :: Options -> Bool
+ UU.UUAGC: [checkParseRhs] :: Options -> Bool
+ UU.UUAGC: [checkParseTy] :: Options -> Bool
+ UU.UUAGC: [clean] :: Options -> Bool
+ UU.UUAGC: [dataRecords] :: Options -> Bool
+ UU.UUAGC: [dataTypes] :: Options -> Bool
+ UU.UUAGC: [doubleColons] :: Options -> Bool
+ UU.UUAGC: [dummyTokenVisit] :: Options -> Bool
+ UU.UUAGC: [dumpcgrammar] :: Options -> Bool
+ UU.UUAGC: [dumpgrammar] :: Options -> Bool
+ UU.UUAGC: [extends] :: Options -> Maybe String
+ UU.UUAGC: [failWithCode] :: Options -> Int -> IO ()
+ UU.UUAGC: [folds] :: Options -> Bool
+ UU.UUAGC: [forceIrrefutables] :: Options -> Maybe String
+ UU.UUAGC: [genAspectAG] :: Options -> Bool
+ UU.UUAGC: [genAttributeList] :: Options -> Bool
+ UU.UUAGC: [genCostCentres] :: Options -> Bool
+ UU.UUAGC: [genFileDeps] :: Options -> Bool
+ UU.UUAGC: [genLinePragmas] :: Options -> Bool
+ UU.UUAGC: [genTraces] :: Options -> Bool
+ UU.UUAGC: [genUseTraces] :: Options -> Bool
+ UU.UUAGC: [genvisage] :: Options -> Bool
+ UU.UUAGC: [getName] :: Identifier -> String
+ UU.UUAGC: [getPos] :: Identifier -> Pos
+ UU.UUAGC: [helpInlining] :: Options -> Bool
+ UU.UUAGC: [kennedyWarren] :: Options -> Bool
+ UU.UUAGC: [lateHigherOrderBinding] :: Options -> Bool
+ UU.UUAGC: [lcKeywords] :: Options -> Bool
+ UU.UUAGC: [loag] :: Options -> Bool
+ UU.UUAGC: [localCps] :: Options -> Bool
+ UU.UUAGC: [mainFilename] :: Options -> Maybe String
+ UU.UUAGC: [minvisits] :: Options -> Bool
+ UU.UUAGC: [modcopy] :: Options -> Bool
+ UU.UUAGC: [moduleName] :: Options -> ModuleHeader
+ UU.UUAGC: [monadicWrappers] :: Options -> Bool
+ UU.UUAGC: [monadic] :: Options -> Bool
+ UU.UUAGC: [nest] :: Options -> Bool
+ UU.UUAGC: [newtypes] :: Options -> Bool
+ UU.UUAGC: [noEagerBlackholing] :: Options -> Bool
+ UU.UUAGC: [noGroup] :: Options -> [String]
+ UU.UUAGC: [noIncludes] :: Options -> Bool
+ UU.UUAGC: [noInlinePragmas] :: Options -> Bool
+ UU.UUAGC: [noOptimizations] :: Options -> Bool
+ UU.UUAGC: [noPerRuleCostCentres] :: Options -> Bool
+ UU.UUAGC: [noPerRuleTypeSigs] :: Options -> Bool
+ UU.UUAGC: [noPerStateTypeSigs] :: Options -> Bool
+ UU.UUAGC: [noPerVisitCostCentres] :: Options -> Bool
+ UU.UUAGC: [nocatas] :: Options -> Set NontermIdent
+ UU.UUAGC: [ocaml] :: Options -> Bool
+ UU.UUAGC: [outputFiles] :: Options -> [String]
+ UU.UUAGC: [outputStr] :: Options -> String -> IO ()
+ UU.UUAGC: [parallelInvoke] :: Options -> Bool
+ UU.UUAGC: [prefix] :: Options -> String
+ UU.UUAGC: [reference] :: Options -> Bool
+ UU.UUAGC: [rename] :: Options -> Bool
+ UU.UUAGC: [searchPath] :: Options -> [String]
+ UU.UUAGC: [semfuns] :: Options -> Bool
+ UU.UUAGC: [sepSemMods] :: Options -> Bool
+ UU.UUAGC: [showHelp] :: Options -> Bool
+ UU.UUAGC: [showVersion] :: Options -> Bool
+ UU.UUAGC: [smacro] :: Options -> Bool
+ UU.UUAGC: [splitSems] :: Options -> Bool
+ UU.UUAGC: [statsFile] :: Options -> Maybe String
+ UU.UUAGC: [strictCases] :: Options -> Bool
+ UU.UUAGC: [strictData] :: Options -> Bool
+ UU.UUAGC: [strictDummyToken] :: Options -> Bool
+ UU.UUAGC: [strictSems] :: Options -> Bool
+ UU.UUAGC: [strictWrap] :: Options -> Bool
+ UU.UUAGC: [stricterCases] :: Options -> Bool
+ UU.UUAGC: [tupleAsDummyToken] :: Options -> Bool
+ UU.UUAGC: [typeSigs] :: Options -> Bool
+ UU.UUAGC: [unbox] :: Options -> Bool
+ UU.UUAGC: [uniqueDispenser] :: Options -> String
+ UU.UUAGC: [verbose] :: Options -> Bool
+ UU.UUAGC: [visit] :: Options -> Bool
+ UU.UUAGC: [visitorsOutput] :: Options -> Bool
+ UU.UUAGC: [werrors] :: Options -> Bool
+ UU.UUAGC: [wignore] :: Options -> Bool
+ UU.UUAGC: [withCycle] :: Options -> Bool
+ UU.UUAGC: [withSelf] :: Options -> Bool
+ UU.UUAGC: [withSeq] :: Options -> Bool
+ UU.UUAGC: [wmaxerrs] :: Options -> Int
+ UU.UUAGC: [wrappers] :: Options -> Bool
- UU.UUAGC: MyOpt :: [Char] -> [String] -> (ArgDescr (Options -> Options)) -> (Options -> String -> [String]) -> String -> MyOptDescr
+ UU.UUAGC: MyOpt :: [Char] -> [String] -> ArgDescr (Options -> Options) -> (Options -> String -> [String]) -> String -> MyOptDescr
- UU.UUAGC: loagOpt :: (Maybe String) -> Options -> Options
+ UU.UUAGC: loagOpt :: Maybe String -> Options -> Options
Files
- src-ag/AG2AspectAG.ag +0/−857
- src-ag/AbstractSyntax.ag +0/−76
- src-ag/AbstractSyntaxDump.ag +0/−76
- src-ag/Code.ag +0/−163
- src-ag/CodeSyntax.ag +0/−90
- src-ag/CodeSyntaxDump.ag +0/−103
- src-ag/ConcreteSyntax.ag +0/−132
- src-ag/DeclBlocks.ag +0/−20
- src-ag/DefaultRules.ag +0/−821
- src-ag/Desugar.ag +0/−332
- src-ag/ErrorMessages.ag +0/−148
- src-ag/ExecutionPlan.ag +0/−83
- src-ag/ExecutionPlan2Caml.ag +0/−1487
- src-ag/ExecutionPlan2Clean.ag +0/−1684
- src-ag/ExecutionPlan2Hs.ag +0/−1711
- src-ag/Expression.ag +0/−12
- src-ag/GenerateCode.ag +0/−1187
- src-ag/HsToken.ag +0/−33
- src-ag/Interfaces.ag +0/−16
- src-ag/InterfacesRules.lag +0/−451
- src-ag/KWOrder.ag +0/−217
- src-ag/LOAG/Order.ag +0/−435
- src-ag/LOAG/Rep.ag +0/−49
- src-ag/Macro.ag +0/−24
- src-ag/Order.ag +0/−809
- src-ag/Patterns.ag +0/−25
- src-ag/PrintCleanCode.ag +0/−563
- src-ag/PrintCode.ag +0/−542
- src-ag/PrintErrorMessages.ag +0/−656
- src-ag/PrintOcamlCode.ag +0/−222
- src-ag/PrintVisitCode.ag +0/−53
- src-ag/ResolveLocals.ag +0/−157
- src-ag/SemHsTokens.ag +0/−144
- src-ag/TfmToVisage.ag +0/−147
- src-ag/Transform.ag +0/−1371
- src-ag/Visage.ag +0/−122
- src-ag/VisagePatterns.ag +0/−19
- src-ag/VisageSyntax.ag +0/−42
- src-generated/AbstractSyntax.hs +1/−1
- src-generated/Code.hs +1/−1
- src-generated/CodeSyntax.hs +1/−1
- src-generated/ConcreteSyntax.hs +1/−1
- src-generated/DeclBlocks.hs +1/−1
- src-generated/ErrorMessages.hs +1/−1
- src-generated/ExecutionPlan.hs +1/−1
- src-generated/Expression.hs +1/−1
- src-generated/HsToken.hs +1/−1
- src-generated/Interfaces.hs +1/−1
- src-generated/LOAG/Order.hs +170/−183
- src-generated/LOAG/Rep.hs +1/−1
- src-generated/Macro.hs +1/−1
- src-generated/Patterns.hs +1/−1
- src-generated/Transform.hs +16/−16
- src-generated/VisagePatterns.hs +1/−1
- src-generated/VisageSyntax.hs +1/−1
- src/ATermWrite.hs +7/−7
- src/KennedyWarren.hs +7/−6
- src/Knuth1.hs +3/−3
- src/Pretty.hs +4/−4
- uuagc.cabal +2/−2
− src-ag/AG2AspectAG.ag
@@ -1,857 +0,0 @@-INCLUDE "AbstractSyntax.ag"-INCLUDE "Patterns.ag"-INCLUDE "Expression.ag"-INCLUDE "HsToken.ag"-INCLUDE "DistChildAttr.ag"--imports-{-import Options--import Data.Char-import Data.List-import qualified Data.Map as Map-import qualified Data.Set as Set-import Data.Maybe--import Pretty-import PPUtil-import UU.Scanner.Position--import AbstractSyntax-import TokenDef-import CommonTypes---- import Debug.Trace-}--{-pragmaAspectAG = pp "{-# LANGUAGE EmptyDataDecls, NoMonomorphismRestriction , TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-}"--}--{-ppName l = ppListSep "" "" "_" l-}---ATTR Grammar [ options : Options | | ]---ATTR Nonterminals Nonterminal Productions Production Children Child [ o_rename : Bool | | ]-SEM Grammar- | Grammar nonts.o_rename = rename @lhs.options--ATTR Nonterminals Nonterminal Productions Production Children Child Rules Rule [ o_noGroup : {[String]} | | ]-SEM Grammar- | Grammar loc.o_noGroup = sort $ noGroup @lhs.options- nonts.o_noGroup = @loc.o_noGroup--SEM Nonterminal- | Nonterminal loc.inhNoGroup = Map.filterWithKey (\att _ -> elem (getName att) @lhs.o_noGroup) @prods.prdInh- | Nonterminal loc.synNoGroup = Map.filterWithKey (\att _ -> elem (getName att) @lhs.o_noGroup) @syn---ATTR Productions Production Children Child Rules Rule [ inhNoGroup, synNoGroup : {[String]} | | ]-SEM Nonterminal- | Nonterminal prods.inhNoGroup = map show $ Map.keys @loc.inhNoGroup- | Nonterminal prods.synNoGroup = map show $ Map.keys @loc.synNoGroup---SEM Productions- | Cons hd.inhNoGroup = filter (flip Map.member @hd.prdInh . identifier) @lhs.inhNoGroup---ATTR Productions Production Children Child [ | | prdInh USE {`Map.union`} {Map.empty} : {Attributes} ]-SEM Child- | Child lhs.prdInh = @loc.inh---{-type FieldMap = [(Identifier, Type)]-type DataTypes = Map.Map NontermIdent (Map.Map ConstructorIdent FieldMap)-}--ATTR Grammar [ agi : {(Set NontermIdent, DataTypes, Map NontermIdent (Attributes, Attributes))} | | ]---ATTR Nonterminals Nonterminal Productions Production Children Child Rules Rule [ newAtts : { Attributes } | | ]--SEM Grammar | Grammar loc.newAtts = case @lhs.agi of- (_,_,atts) -> ( Map.unions . (\(a,b) -> a++b) . unzip . Map.elems) atts- nonts.newAtts = @loc.newAtts---ATTR Nonterminals Nonterminal [ newProds : { DataTypes } | | ]-ATTR Productions Production [ newProds : { Map.Map ConstructorIdent FieldMap } | | ]--SEM Grammar | Grammar loc.newProds = case @lhs.agi of- (_,prods,_) -> prods- nonts.newProds = @loc.newProds---SEM Nonterminal- | Nonterminal prods.newProds = case Map.lookup @nt @lhs.newProds of- Just prds -> prds- Nothing -> Map.empty---ATTR Nonterminals Nonterminal [ newNTs : {Set NontermIdent} | | ]--ATTR Productions Production [ | | hasMoreProds USE { || } {False} : { Bool } ]--SEM Production | Production lhs.hasMoreProds = not $ Map.member @con @lhs.newProds--ATTR Nonterminals Nonterminal [ | | extendedNTs USE {`Set.union`} {Set.empty} : {Set NontermIdent} ]--SEM Nonterminal | Nonterminal lhs.extendedNTs = if @prods.hasMoreProds- then Set.singleton @nt- else Set.empty---SEM Grammar | Grammar nonts.newNTs = case @lhs.agi of- (newNTs,_,_) -> Set.difference newNTs @nonts.extendedNTs------ATTR Grammar Nonterminals Nonterminal Productions Production Children Child Rules Rule [ ext : {Maybe String} | | ]----- IMPORT--ATTR Grammar [ | | imp USE {>-<} {empty} : PP_Doc ]--SEM Grammar- | Grammar lhs . imp = "import Language.Grammars.AspectAG" >-<- "import Language.Grammars.AspectAG.Derive" >-<- "import Data.HList.Label4" >-<- "import Data.HList.TypeEqGeneric1" >-<- "import Data.HList.TypeCastGeneric1" >-<- maybe empty ("import qualified" >#<) @lhs.ext >-<- maybe empty (\ext -> "import" >#< ext >#< ppListSep "(" ")" "," (@nonts.ppDI ++ @nonts.ppLI ++ @loc.ppAI ++ @loc.ppANT)) @lhs.ext---- CODE--ATTR Grammar [ | | pp USE {>-<} {empty} : PP_Doc ]--SEM Grammar- | Grammar lhs . pp = (if dataTypes @lhs.options- then "-- datatypes" >-< @nonts.ppD >-<- "-- labels" >-< @nonts.ppL- else empty)-- >-<-- (if folds @lhs.options- then "-- attributes" >-< @loc.ppA >-<- "-- rules" >-< @loc.ppR >-<- "-- catas" >-< @nonts.ppCata-- else empty)-- >-<--- (if semfuns @lhs.options- then "-- semantic functions" >-< @nonts.ppSF- else empty)--- >-<-- (if wrappers @lhs.options- then "-- wrappers" >-< @nonts.ppW- else empty)------ data definitions--SEM Nonterminal- | Nonterminal loc . ppNt = pp @nt--SEM Production- | Production loc . ppProd = pp @con- loc . prodName = ppName [@lhs.ppNt, @loc.ppProd]- loc . conName = if @lhs.o_rename- then @loc.prodName- else @loc.ppProd-SEM Child- | Child loc . ppCh = pp @name- loc . ppTCh = ppShow @tp- loc . chName = ppName [@loc.ppCh, @lhs.ppNt, @lhs.ppProd]---ATTR Productions Production Rules Rule Children Child Expression [ ppNt : PP_Doc | | ]--SEM Nonterminal- | Nonterminal prods . ppNt = @loc.ppNt--ATTR Rules Rule Children Child Expression [ ppProd : PP_Doc | | ]--SEM Production- | Production children . ppProd = @loc.ppProd- rules . ppProd = @loc.ppProd---ATTR Nonterminals Nonterminal [ derivs : {Derivings} | | ]--SEM Grammar- | Grammar nonts . derivs = @derivings---ATTR Nonterminals Nonterminal Production [ | | ppD USE {>-<} {empty} : {PP_Doc} ppDI USE {++} {[]} : {[PP_Doc]} ]--SEM Nonterminal- | Nonterminal lhs . ppD =- if (Set.member @nt @lhs.newNTs)- then case (lookup @nt @lhs.tSyns) of- -- if it's a data type- Nothing -> "data " >|< @loc.ppNt- >|< " = " >|< vlist_sep " | " @prods.ppDL >-<- case (Map.lookup @nt @lhs.derivs) of- Just ntds -> pp " deriving " >|< (ppListSep "(" ")" ", " $ Set.elems ntds)- Nothing -> empty -- uncommented for testing purposes - -- if it's a type synonym- Just tp -> "type " >|< @loc.ppNt >|< " = " >|< ppShow tp- else empty-- lhs . ppDI =- if (not $ Set.member @nt @lhs.newNTs)- then [ @loc.ppNt ]- else [ ]--- uncommented for testing purposes--SEM Production- | Production lhs . ppD = @loc.conName >|< ppListSep " {" "}" ", " @children.ppDL---ATTR Productions Children Child [ | | ppDL : {[PP_Doc]} ]--SEM Productions- | Cons lhs . ppDL = @hd.ppD : @tl.ppDL- | Nil lhs . ppDL = []--SEM Children- | Cons lhs . ppDL = @hd.ppDL ++ @tl.ppDL- | Nil lhs . ppDL = []--SEM Child- | Child lhs . ppDL = case @kind of- ChildSyntax -> [ @loc.chName >|< pp " :: " >|< @loc.ppTCh ]- _ -> []----ATTR Nonterminals Nonterminal [ tSyns : {TypeSyns} | | ]--SEM Grammar- | Grammar nonts . tSyns = @typeSyns------- grammar labels---ATTR Nonterminals Nonterminal Productions Production Children Child [ | | ppL USE {>-<} {empty} : PP_Doc ppLI USE {++} {[]} : {[PP_Doc]} ]--SEM Nonterminal- | Nonterminal loc . ntLabel = "nt_" >|< @loc.ppNt-- lhs . ppL = ( if (Set.member @nt @lhs.newNTs)- then @loc.ntLabel >|< " = proxy :: Proxy " >|< @loc.ppNt- else empty) >-<- @prods.ppL-- lhs . ppLI = ( if (not $ Set.member @nt @lhs.newNTs)- then [ @loc.ntLabel ]- else [ ]) ++- @prods.ppLI--SEM Production- | Production lhs . ppL = if (Map.member @con @lhs.newProds)- then @children.ppL- else empty-- lhs . ppLI = if (not $ Map.member @con @lhs.newProds)- then @children.ppLI- else []---SEM Child- | Child loc . chLabel = "ch_" >|< @loc.chName- loc . chTLabel = "Ch_" >|< @loc.chName- lhs . ppL = "data " >|< @loc.chTLabel >|< "; " >|< @loc.chLabel >|< pp " = proxy :: " >|<- case @kind of- ChildSyntax -> "Proxy " >|< "(" >|< @loc.chTLabel >|< ", " >|< @loc.ppTCh >|< ")"- _ -> "SemType " >|< @loc.ppTCh >|< pp " nt => Proxy " >|<- "(" >|< @loc.chTLabel >|< ", nt)"-- lhs . ppLI = [ @loc.chLabel, @loc.chTLabel ]----- attributes---SEM Grammar- | Grammar loc . ppA = vlist (map defAtt (filterAtts @loc.newAtts @loc.o_noGroup)) >-< -- not grouped- defAtt "loc" >-< -- local- (case @lhs.ext of- Nothing -> defAtt "inh" >-< defAtt "syn" -- grouped- otherwise -> empty) >-<- @nonts.ppA -- record definitions-- loc . ppAI =- let atts = filterNotAtts @loc.newAtts @loc.o_noGroup- in (foldr (\a as -> attName a : as) [] atts) ++- (foldr (\a as -> attTName a : as) [] atts) ++- (case @lhs.ext of- Nothing -> []- otherwise -> [ attName "inh", attName "syn", attTName "inh", attTName "syn" ]) ++- @nonts.ppAI--- loc . ppANT =- let atts = filterNotAtts @loc.newAtts @loc.o_noGroup- in (foldr (\a as -> ("nts_" >|< a) : as) [] atts)--ATTR Nonterminals Nonterminal Productions Production [ | | ppA USE {>-<} {empty} : PP_Doc ]--SEM Nonterminal- | Nonterminal lhs . ppA = ( if (Set.member @nt @lhs.newNTs)- then - defAttRec (pp "InhG") @loc.ppNt @inh @loc.inhNoGroup >-<- defAttRec (pp "SynG") @loc.ppNt @syn @loc.synNoGroup - else empty) >-<- @prods.ppA--SEM Production- | Production lhs . ppA = defLocalAtts @loc.prodName (length @rules.locals) 1 $ sort @rules.locals---ATTR Nonterminals Nonterminal [ | | ppAI USE {++} {[]} : {[PP_Doc]} ]--SEM Nonterminal- | Nonterminal lhs . ppAI = if (not $ Set.member @nt @lhs.newNTs)- then [ ppName [(pp "InhG"), @loc.ppNt ] >#< pp "(..)", ppName [(pp "SynG"), @loc.ppNt ] >#< pp "(..)" ]- else [ ]--{-filterAtts newAtts = filter (\att -> Map.member (identifier att) newAtts)-filterNotAtts newAtts = filter (\att -> not (Map.member (identifier att) newAtts))--defAtt att = "data " >|< attTName att >|< "; " >|< attName att >|< " = proxy :: Proxy " >|< attTName att-attName att = pp $ "att_" ++ att-attTName att = pp $ "Att_" ++ att---defAttRec recPref ppNt atts noGroup =- let recName = ppName [recPref, ppNt]- fields = ppCommas (map (\(a,t) -> ppName [pp a, recName ] >|< " ::" >|< ppShow t) (groupAtts atts noGroup))- in- "data " >|< recName >|< " = " >|< recName >|< " { " >|< fields >|< " }"--groupAtts atts noGroup = (Map.toAscList . Map.difference atts) noGroup---- it defines selectors with the form:--- l1_nt_prod(x, _, .., _) = x--- ln_nt_prod(_, .., _, x) = x-defLocalAtts prodName total actual (l:ls) = ppName [pp l, prodName] >|<- ppListSep "(" ")" "," (replicate (actual-1) "_" ++ "x" : replicate (total-actual) "_") >|<- pp " = x" >-<- defLocalAtts prodName total (actual+1) ls-defLocalAtts _ _ _ [] = empty--}---ATTR Rules Rule [ | | locals USE {++} {[]} : {[Identifier]} ]---SEM Rule- | Rule lhs . locals = if (show (fst @pattern.info) == "loc")- then [ snd @pattern.info ]- else [ ]---ATTR Pattern [ || info : {(Identifier, Identifier)} ]-SEM Pattern- | Alias lhs . info = (@field, @attr)- | Constr lhs . info = error "Pattern Constr undefined!!"- | Product lhs . info = error "Pattern Product undefined!!"- | Underscore lhs . info = error "Pattern Underscore undefined!!"------ rules--SEM Grammar- | Grammar loc . ppNtL = @nonts.ppNtL- loc . ppR = ntsList "group" @loc.ppNtL >-<- vlist (map (\att -> ntsList att (filterNts att @loc.ppNtL)) (filterAtts @newAtts @loc.o_noGroup)) >-<- @nonts.ppR--{-ntsList att ppNtL = "nts_" ++ att ++ " = " >|< ppListSep "" "" " .*. " ((map fst ppNtL) ++ [pp "hNil"])--filterNts att = filter ( Map.member (identifier att) . snd )-}--ATTR Nonterminals Nonterminal [ | | ppNtL USE {++} {[]} : {[(PP_Doc, Attributes)]} ] -- list of nonterminals and its attributes--SEM Nonterminal- | Nonterminal lhs . ppNtL = [ ("nt_" >|< @nt, Map.union @inh @syn) ]-----ATTR Productions Production [ newNT : {Bool} | | ]-ATTR Rules Rule [ newProd : {Bool} | | ]--SEM Nonterminal- | Nonterminal prods . newNT = Set.member @nt @lhs.newNTs---ATTR Nonterminals Nonterminal Productions Production Children Child [ | | ppR USE {>-<} {empty} : PP_Doc ]-ATTR Productions Production [ | | ppRA USE {++} {[]} : {[PP_Doc]} ]-----SEM Nonterminal- | Nonterminal lhs . ppR = pp "----" >|< pp @nt >-< @prods.ppR--SEM Production- | Production loc . newProd = Map.member @con @lhs.newProds- loc . (ppR,ppRA)- = let (instR, instRA) = defInstRules @lhs.ppNt @con @lhs.newNT @loc.newProd- @children.ppR @rules.ppRL @children.idCL @rules.locals- (locR, locRA) = defLocRule @lhs.ppNt @con @lhs.newNT @loc.newProd- @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals- (inhGR, inhGRA) = defInhGRule @lhs.ppNt @loc.prodName @lhs.newNT @loc.newProd- @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals- (synGR, synGRA) = defSynGRule @lhs.ppNt @con @lhs.newNT @loc.newProd- @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals- (inhR, inhRA) = defInhRules @lhs.ppNt @loc.prodName @lhs.newNT @loc.newProd @lhs.newAtts- @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals- (synR, synRA) = defSynRules @lhs.ppNt @con @lhs.newNT @loc.newProd @lhs.newAtts- @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals- (inhMR, inhMRA) = modInhRules @lhs.ppNt @loc.prodName @lhs.newNT @loc.newProd @lhs.newAtts- @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals- (synMR, synMRA) = modSynRules @lhs.ppNt @con @lhs.newNT @loc.newProd @lhs.newAtts- @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals- in ( vlist [instR,locR,inhGR,synGR,inhR,synR,inhMR,synMR]- , instRA ++ locRA ++ inhGRA ++ synGRA ++ inhMRA ++ synMRA ++ inhRA ++ synRA)---SEM Child- | Child lhs . ppR = let chName = ppListSep "" "" "_" [pp @name, @lhs.ppNt, @lhs.ppProd]- in pp @name >|< " <- at ch_" >|< chName---{-data PPRule = PPRule Identifier Identifier Bool ([(Identifier,Type)] -> [Identifier] -> PP_Doc)--ppRule (field,attr) owrt def = PPRule field attr owrt def-ruleField (PPRule field _ _ _ ) = field-ruleAttr (PPRule _ attr _ _ ) = attr-ruleOwrt (PPRule _ _ owrt _ ) = owrt-ruleDef (PPRule _ _ _ def) = def--}-ATTR Rules Rule [ | | ppRL : {[ PPRule ]} ]--SEM Rules- | Cons lhs . ppRL = @hd.ppRL ++ @tl.ppRL- | Nil lhs . ppRL = []--SEM Rule- | Rule lhs . ppRL = if (not @explicit && not @lhs.newProd && not (Map.member (snd @pattern.info) @lhs.newAtts) )- then []- else [ ppRule @pattern.info @owrt (defRule @lhs.ppNt @pattern.info @lhs.o_noGroup @rhs.ppRE) ]--{--ATTR Expression [ | | ppRE : {Identifier -> [String] -> [String] -> [(Identifier,Type)] -> [Identifier] -> PP_Doc} ]-SEM Expression- | Expression lhs . ppRE = rhsRule @lhs.ppNt @lhs.ppProd @tks--}--ATTR Expression [ | | ppRE : {[String] -> Identifier -> [(Identifier,Type)] -> [Identifier] -> PP_Doc} ]-SEM Expression- | Expression lhs . ppRE = rhsRule @lhs.ppNt @lhs.ppProd @tks---ATTR Children Child [ || idCL USE {++} {[]} : {[(Identifier,Type)]} ]-SEM Child- | Child lhs . idCL = [ (@name, removeDeforested @tp ) ]-----{--defInhGRule ppNt prodName newNT newProd ch rules inhNoGroup synNoGroup chids locals =- let ppAtt = ppName [pp "inh", prodName]- ppR = ppAtt >|< pp " = inhdefM att_inh nts_group $" >-<- indent 4 "do " >-<- indent 5 "loc <- at loc" >-<- indent 5 "lhs <- at lhs" >-<- indent 5 ch >-<- indent 5 "return $" >-<- indent 6 (foldr (>-<) (pp "emptyRecord") (map (chGRule ppNt prodName rules inhNoGroup synNoGroup chids locals) chids))- in if (newNT || (not newNT && newProd))- then (ppR, [ ppAtt ])- else (empty, [])--chGRule ppNt prodName rules inhNoGroup synNoGroup chids locals (idCh,tp) =- let chName = ppName [pp "ch", pp idCh, prodName]- ppTp = ppShow tp- chRules = ppCommas $ mapGRuleDefs (== idCh) rules inhNoGroup synNoGroup chids locals- in if (isNonterminal tp)- then chName >|< ".=." >-<- indent 1 "InhG_" >|< ppShow tp >|< pp " {" >-<- indent 2 chRules >-<- indent 1 "} .*. "- else empty---defSynGRule ppNt prod newNT newProd ch rules inhNoGroup synNoGroup chids locals =- let ppAtt = ppName [pp "syn", ppNt, pp prod]- ppTAtt = "SynG_" >|< ppNt- ppR = ppAtt >|< pp " = syndefM att_syn $" >-<- indent 4 "do " >-<- indent 5 "loc <- at loc" >-<- indent 5 "lhs <- at lhs" >-<- indent 5 ch >-<- indent 5 "return $" >-<- indent 6 ppTAtt >|< pp " {" >-<- indent 7 (ppCommas $ mapGRuleDefs ((== "lhs") . show) rules inhNoGroup synNoGroup chids locals) >-<- indent 6 "}"- in if (newNT || (not newNT && newProd))- then (ppR, [ ppAtt ])- else (empty, [])--defLocRule ppNt prod newNT newProd ch rules inhNoGroup synNoGroup chids locals =- let ppAtt = ppName [pp "loc", ppNt, pp prod]- ppTAtt = ppName [pp "Loc", ppNt, pp prod]- ppR = ppAtt >|< pp " = locdefM att_loc $" >-<- indent 4 "do " >-<- indent 5 "loc <- at loc" >-<- indent 5 "lhs <- at lhs" >-<- indent 5 ch >-<- indent 5 "return $" >-<- indent 6 (ppListSep "(" ")" "," $ mapLRuleDefs rules inhNoGroup synNoGroup chids locals)- in (ppR, [ ppAtt ])--defInstRules ppNt prod newNT newProd ch rules chids locals- = let ppAsp = ppName [pp "inst", ppNt, pp prod]- instRules = filter ((=="inst") . show . ruleField) rules- ppAtt att = ppListSep "`ext` " "" "_" [pp "inst_ch", pp att, ppNt, pp prod]- in ( ppAsp >|< pp " = emptyRule " >|< (map (ppAtt . ruleAttr) instRules) >-<- (vlist $ map (defInstRule ppNt prod ch chids locals) instRules)- , [ ppAsp ])---defInstRule ppNt prod ch chids locals rule =- let ppAtt = ppName [pp "ch", pp (ruleAttr rule), ppNt, pp prod]- in pp "inst_" >|< ppAtt >|< pp " = instdefM " >|< ppAtt >|< pp " $" >-<- indent 4 "do " >-<- indent 5 "loc <- at loc" >-<- indent 5 "lhs <- at lhs" >-<- indent 5 ch >-<- indent 5 "return $" >-<- indent 6 ((ruleDef rule) chids locals)---defSynRules ppNt prod newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals- = let synRules = filter ( (=="lhs") . show . ruleField) rules- ngRules = filter ((flip elem synNoGroup) . getName . ruleAttr) synRules- (ppR, ppRA) = unzip $ map (defSynRule True ppNt prod newNT newProd newAtts ch chids locals) ngRules- in (vlist ppR, concat ppRA )--modSynRules ppNt prod newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals- = let synRules = filter ( (=="lhs") . show . ruleField) rules- ngRules = filter ((flip elem synNoGroup) . getName . ruleAttr) synRules- (ppR, ppRA) = unzip $ map (defSynRule False ppNt prod newNT newProd newAtts ch chids locals) ngRules- in (vlist ppR, concat ppRA )--defSynRule new ppNt prod newNT newProd newAtts ch chids locals rule =- let att = ruleAttr rule- newAtt = Map.member att newAtts- owrt = ruleOwrt rule- ppAtt = ppName [pp att, pp (if new then "syn" else "synM"), ppNt, pp prod]- ppR def = ppAtt >|< pp (" = " ++ def ++ " ") >|< attName (show att) >|< pp " $" >-<- indent 4 "do " >-<- indent 5 "loc <- at loc" >-<- indent 5 "lhs <- at lhs" >-<- indent 5 ch >-<- indent 5 "return $" >-<- indent 6 ((ruleDef rule) chids locals)- in - if new- then if (not owrt && (newNT || (not newNT && newProd) || newAtt))- then (ppR "syndefM", [ ppAtt ])- else (empty, [])- else if owrt- then (ppR "synmodM", [ ppAtt ])- else (empty, [])----defInhRules ppNt prodName newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals- = let ngRules = filter ((flip elem inhNoGroup) . getName . ruleAttr) rules- (ppR, ppRA) = unzip $ map (defInhRule True ppNt prodName newNT newProd newAtts ch ngRules inhNoGroup synNoGroup chids locals) inhNoGroup- in (vlist ppR, concat ppRA)--modInhRules ppNt prodName newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals- = let ngRules = filter ((flip elem inhNoGroup) . getName . ruleAttr) rules- (ppR, ppRA) = unzip $ map (defInhRule False ppNt prodName newNT newProd newAtts ch ngRules inhNoGroup synNoGroup chids locals) inhNoGroup- in (vlist ppR, concat ppRA)---defInhRule new ppNt prodName newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals att =- let ppAtt = ppName [pp att, pp (if new then "inh" else "inhM"),prodName]- newAtt = Map.member (identifier att) newAtts- chRMaybe = map (chRule new ppNt prodName att rules inhNoGroup synNoGroup chids locals) chids- chR = [ x | (Just x) <- chRMaybe ]- ppR def = ppAtt >|< pp (" = " ++ def ++ " ") >|< attName att >|< " nts_" >|< att >|< " $" >-<- indent 4 "do " >-<- indent 5 "loc <- at loc" >-<- indent 5 "lhs <- at lhs" >-<- indent 5 ch >-<- indent 5 "return $" >-<- indent 6 (foldr (>-<) (pp "emptyRecord") chR)- in- if new- then if (newNT || (not newNT && newProd) || newAtt)- then (ppR "inhdefM", [ ppAtt ])- else (empty, [])- else if (not . null) chR- then (ppR "inhmodM", [ ppAtt ])- else (empty, [])---chRule new ppNt prodName att rules inhNoGroup synNoGroup chids locals (idCh,tp) =- let chName = ppName [pp "ch", pp idCh, prodName]- ppTp = ppShow tp- chRule = inhRuleDef new (== idCh) (== att) rules inhNoGroup synNoGroup chids locals -- it's supposed to be only one- in if (isNonterminal tp && (not . null) chRule)- then Just $ chName >|< ".=. (" >|< chRule >|< ") .*. "- else Nothing---mapLRuleDefs rules inhNoGroup synNoGroup chids locals- = map appSnd $ sortBy cmpField $ filter ((== "loc") . show . ruleField) rules- where cmpField r1 r2 = compare (ruleField r1) (ruleField r2)- appSnd rule = (ruleDef rule) chids locals---mapGRuleDefs filt rules inhNoGroup synNoGroup chids locals- = map appSnd $ sortBy cmpField $ filter (not . (flip elem inhNoGroup) . getName . ruleAttr)- $ filter (not . (flip elem synNoGroup) . getName . ruleAttr)- $ filter ( filt . ruleField) rules- where cmpField r1 r2 = compare (ruleField r1) (ruleField r2)- appSnd rule = (ruleDef rule) chids locals--inhRuleDef new filt1 filt2 rules inhNoGroup synNoGroup chids locals- = map appSnd $ sortBy cmpField $ filter ( (== not new) . ruleOwrt)- $ filter ((flip elem inhNoGroup) . getName . ruleAttr)- $ filter ( filt2 . getName . ruleAttr)- $ filter ( filt1 . ruleField) rules- where cmpField r1 r2 = compare (ruleField r1) (ruleField r2)- appSnd rule = (ruleDef rule) chids locals--defRule ppNt (field,att) noGroup rhs = \chids locals ->- let ppAtt = if (elem (getName att) noGroup)- then empty- else case (show field) of- "lhs" -> att >|< "_" >|< pp "SynG" >|< pp "_" >|< ppNt >|< " = "- "loc" -> empty- "inst" -> empty- otherwise -> att >|< "_" >|< pp "InhG" >|< pp "_" >|<- (maybe (error $ "lhs field " ++ show field ++" is not a child")- ppShow (lookup field chids))- >|< " = "- in ppAtt >|< (rhs noGroup field chids locals)---rhsRule ppNt ppProd tks noGroup field chids locals = vlist . lines2PP . (map (token2PP ppNt ppProd field chids locals noGroup )) $ tks---lines2PP [] = []-lines2PP xs = map line2PP . shiftLeft . getLines $ xs---token2PP ppNt ppProd field chids locals noGroup tk- = case tk of- AGLocal var pos _ -> (pos, if (elem var locals)- then (ppListSep "(" "" "_" [pp var, ppNt, ppProd]) >|< pp " (loc # att_loc)) "- else pp var)- AGField field attr pos _ -> let ppChT = maybe (error $ "rhs field " ++ show field ++ " is not a child") ppShow (lookup field chids)- ppAtt = case (show field) of- "lhs" -> attName "inh"- "loc" -> attName "loc"- otherwise -> attName "syn"- ppSubAtt = case (show field) of- "lhs" -> ppName [pp (getName attr), pp "InhG", ppNt]- "loc" -> ppName [pp (getName attr), ppNt, ppProd]- otherwise -> ppName [pp (getName attr), pp "SynG", ppChT]- in (pos, if ((elem (getName attr) noGroup) && ((show field) /= "loc"))- then pp "(" >|< pp (getName field) >|< " # " >|< attName (getName attr) >|< pp ")"- else pp "(" >|< ppSubAtt >|< " (" >|< pp (getName field) >|< " # " >|< ppAtt >|< ")) ")- HsToken value pos -> (pos, pp value)- CharToken value pos -> (pos, pp (show value))- StrToken value pos -> (pos, pp (show value))- Err mesg pos -> (pos, pp $ " ***" ++ mesg ++ "*** ")--line2PP ts = let f (p,t) r = let ct = column p- in \c -> pp (spaces (ct-c)) >|< t >|< r (length (show t) +ct)- spaces x | x < 0 = ""- | otherwise = replicate x ' '- in foldr f (pp . const "") ts 1--}---------------------------------------------------------------------------------------------------------------------------------------------------{-ppMacro (Macro con children) = "( atts_" >|< show con >|< ", " >|< ppListSep "" "" " <.> " ppChildren >|<")"- where ppChildren = map ppChild children- ppChild (RuleChild ch n) = chName ch >|< " ==> " >|< ppMacro n- ppChild (ChildChild ch n) = chName ch >|< " --> " >|< n- ppChild (ValueChild ch n) = chName ch >|< " ~~> " >|< n- chName ch = ppName [pp "ch", pp ch, pp con]-}---- catamorphisms--ATTR Nonterminals Nonterminal Productions Production [ | | ppCata USE {>-<} {empty} : PP_Doc ]--SEM Nonterminal- | Nonterminal lhs . ppCata = "----" >|< @loc.ppNt >-< @prods.ppCata---SEM Production- | Production lhs . ppCata =- let extend = maybe []- ( \ext -> if (@lhs.newNT || (not @lhs.newNT && @loc.newProd))- then []- else [ ext >|< ".atts_" >|< @loc.prodName ])- @lhs.ext- macro = case @macro of- Nothing -> []- Just macro -> [ "agMacro " >|< ppMacro macro ]- atts = sortBy (\a b -> compare (show a) (show b)) @loc.ppRA- in "atts_" >|< @loc.prodName >|< " = " >|<- ppListSep "" "" " `ext` "- (atts ++ macro ++ extend ) >-<- "semP_" >|< @loc.prodName >|< pp " = knit atts_" >|< @loc.prodName--{-ppNoGroupAtts syn noGroup = let synatts = Map.keys $ Map.filterWithKey (\att _ -> elem (getName att) noGroup) syn- in map (flip (>|<) "_inh") noGroup ++ map (flip (>|<) "_syn") synatts--ruleName att prodName = ppName [att,prodName]--elemNT a b = False-}--ATTR Productions Production [ syn, inh : { Attributes } | | ]--SEM Nonterminal- | Nonterminal prods . syn = @syn- prods . inh = @inh------ semantic functions--ATTR Nonterminals Nonterminal Productions Production [ | | ppSF USE {>-<} {empty} : PP_Doc ]-ATTR Productions Production [ | | ppSPF USE {>-<} {empty} : PP_Doc ]---SEM Nonterminal- | Nonterminal lhs . ppSF =- let inhAtts = attTypes @loc.inhNoGroup- synAtts = attTypes @loc.synNoGroup- in- "----" >|< @loc.ppNt >-<- "type T_" >|< @loc.ppNt >|< " = " >|<- "(Record " >|<- inhAtts >|<- "(HCons (LVPair (Proxy Att_inh) InhG_" >|< @loc.ppNt >|< ") HNil))" >|<- replicate (length inhAtts) ")" >|< " -> " >|<- "(Record " >|<- synAtts >|<- "(HCons (LVPair (Proxy Att_syn) SynG_" >|< @loc.ppNt >|< ") HNil))" >|<- replicate (length synAtts) ")" >-<- "-- instance SemType T_" >|< @loc.ppNt >|< " " >|< @loc.ppNt >-<- "-- sem_" >|< @loc.ppNt >|< " :: " >|< @loc.ppNt >|< " -> T_" >|< @loc.ppNt >-<- @prods.ppSPF -- >-<- -- @prods.ppSF--{-attTypes atts = map (\(a,t) -> "(HCons (LVPair (Proxy Att_" >|< a >|< ") " >|< ppShow t >|< ") ") $ Map.toAscList atts-}---SEM Production- | Production lhs . ppSF =- let chi = @children.ppCSF- ppPattern = case (show @con) of- -- hardcoded list support- "Cons" -> ppParams (ppListSep "" "" " : ")- "Nil" -> pp "[]"- -- general case- otherwise -> @loc.conName >|< " " >|< (ppParams ppSpaced)-- ppParams f = f $ map (((>|<) (pp "_")) . fst) chi- in "sem_" >|< @lhs.ppNt >|< " (" >|< ppPattern >|< ") = sem_" >|< @loc.prodName >|<- " (" >|< map (fst . snd) chi >|< "emptyRecord)"- lhs . ppSPF =- let chi = @children.ppCSF- ppParams f = f $ map (((>|<) (pp "_")) . fst) chi- in "sem_" >|< @lhs.ppNt >|< "_" >|< @con >#< ppParams ppSpaced >|< " = semP_" >|< @loc.prodName >|<- " (" >|< map (snd . snd) chi >|< "emptyRecord)"---ATTR Children Child [ | | ppCSF USE {++} {[]} : {[(Identifier,(PP_Doc,PP_Doc))]} ]---SEM Child- | Child lhs . ppCSF =- let- semC = if (isNonterminal @tp)- then "sem_" >|< ppShow @tp >|< " _" >|< @name- else "sem_Lit _" >|< @name- in case @kind of- ChildSyntax -> [(@name, ( @loc.chLabel >|< " .=. (" >|< semC >|< ") .*. "- , @loc.chLabel >|< " .=. _" >|< @name >|< " .*. "))]- _ -> []------- wrappers----TODO: create the records Inh_nt and Syn_nt to wrap the attributes--ATTR Nonterminals Nonterminal [ | | ppW USE {>-<} {empty} : PP_Doc ]--SEM Nonterminal- | Nonterminal lhs . ppW =- ppName [pp "wrap", @loc.ppNt] >|< " sem " >|< attVars @inh >|< " = " >-<- " sem " >|< attFields @inh @loc.inhNoGroup @loc.ppNt---{-attVars atts = map (\(a,_) -> "_" >|< a >|< " ") $ Map.toAscList atts-attFields atts noGroup ppNt =- let ng = map (\(a,_) -> attName (getName a) >|< " .=. _" >|< a >|< " .*. ") $ Map.toAscList noGroup- g = ppCommas $ map (\(a,_) -> ppName [pp a, pp "InhG",ppNt] >|< "= _" >|< a) $ Map.toAscList $ Map.difference atts noGroup- in "(" >|< ng >|< "att_inh .=. " >|< ppName [pp "InhG", ppNt] >|< " { " >|< g >|< " } .*. emptyRecord)"-}
− src-ag/AbstractSyntax.ag
@@ -1,76 +0,0 @@-imports-{--- AbstractSyntax.ag imports-import Data.Set(Set)-import Data.Map(Map)-import Patterns (Pattern(..),Patterns)-import Expression (Expression(..))-import Macro --marcos-import CommonTypes-import ErrorMessages-}--DATA Grammar | Grammar typeSyns : {TypeSyns}- useMap : {UseMap}- derivings : {Derivings}- wrappers : {Set NontermIdent}- nonts : Nonterminals- pragmas : {PragmaMap} -- pragmas defined at a certain alternative- manualAttrOrderMap : {AttrOrderMap} -- manually enforced dependencies between attributes- paramMap : {ParamMap}- contextMap : {ContextMap}- quantMap : {QuantMap}- uniqueMap : {UniqueMap}- augmentsMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))}- aroundsMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))}- mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression)))}--TYPE Nonterminals = [Nonterminal]--TYPE Productions = [Production]--TYPE Children = [Child]--TYPE Rules = [Rule]--TYPE TypeSigs = [TypeSig]--DATA Nonterminal | Nonterminal nt : {NontermIdent}- params : {[Identifier]}- inh : {Attributes}- syn : {Attributes}- prods : Productions--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}- 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- 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}--SET AllAbstractSyntax- = Grammar- Nonterminal Nonterminals- Production Productions- Child Children- Rule Rules- TypeSig TypeSigs
− src-ag/AbstractSyntaxDump.ag
@@ -1,76 +0,0 @@-INCLUDE "AbstractSyntax.ag"-INCLUDE "Patterns.ag"-INCLUDE "Expression.ag"--imports-{-import Data.List-import qualified Data.Map as Map--import Pretty-import PPUtil--import AbstractSyntax-import TokenDef-}--ATTR AllPattern AllAbstractSyntax AllExpression [ | | pp USE {>-<} {empty} : PP_Doc ]--SEM Grammar- | Grammar lhs . pp = ppNestInfo ["Grammar","Grammar"] []- [ ppF "typeSyns" $ ppAssocL @typeSyns- , ppF "useMap" $ ppMap $ Map.map ppMap $ @useMap- , ppF "derivings" $ ppMap $ @derivings- , ppF "wrappers" $ ppShow $ @wrappers- , ppF "nonts" $ ppVList @nonts.ppL- ] []--SEM Nonterminal- | Nonterminal lhs . pp = ppNestInfo ["Nonterminal","Nonterminal"] (pp @nt : map pp @params) [ppF "inh" $ ppMap @inh, ppF "syn" $ ppMap @syn, ppF "prods" $ ppVList @prods.ppL] []--SEM Production- | 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 "kind" $ ppShow @kind] []--SEM Rule- | Rule lhs . pp = ppNestInfo ["Rule","Rule"] [ppShow @owrt, pp @origin] [ppF "pattern" $ @pattern.pp, ppF "rhs" $ @rhs.pp] []--SEM TypeSig- | TypeSig lhs . pp = ppNestInfo ["TypeSig","TypeSig"] [pp @name, ppShow @tp] [] []--SEM Pattern- | Constr lhs . pp = ppNestInfo ["Pattern","Constr"] [pp @name] [ppF "pats" $ ppVList @pats.ppL] []- | Product lhs . pp = ppNestInfo ["Pattern","Product"] [ppShow @pos] [ppF "pats" $ ppVList @pats.ppL] []- | Alias lhs . pp = ppNestInfo ["Pattern","Alias"] [pp @field, pp @attr] [ppF "pat" $ @pat.pp] []- | Underscore lhs . pp = ppNestInfo ["Pattern","Underscore"] [ppShow @pos] [] []--SEM Expression- | Expression lhs . pp = ppNestInfo ["Expression","Expression"] [ppShow @pos] [ppF "txt" $ vlist . showTokens . tokensToStrings $ @tks] []--ATTR Productions Nonterminals Children Rules TypeSigs Patterns [ | | ppL: {[PP_Doc]} ]--SEM Patterns- | Cons lhs . ppL = @hd.pp : @tl.ppL- | Nil lhs . ppL = []--SEM TypeSigs- | Cons lhs . ppL = @hd.pp : @tl.ppL- | Nil lhs . ppL = []--SEM Rules- | Cons lhs . ppL = @hd.pp : @tl.ppL- | Nil lhs . ppL = []--SEM Children- | Cons lhs . ppL = @hd.pp : @tl.ppL- | Nil lhs . ppL = []--SEM Productions- | Cons lhs . ppL = @hd.pp : @tl.ppL- | Nil lhs . ppL = []--SEM Nonterminals- | Cons lhs . ppL = @hd.pp : @tl.ppL- | Nil lhs . ppL = []
− src-ag/Code.ag
@@ -1,163 +0,0 @@-imports-{-import Patterns-import Data.Set(Set)-import qualified Data.Set as Set-import Data.Map(Map)-import qualified Data.Map as Map-}--TYPE Exprs = [Expr]-TYPE Decls = [Decl]-TYPE Chunks = [Chunk]-TYPE DataAlts = [DataAlt]-TYPE CaseAlts = [CaseAlt]-TYPE Types = [Type]-TYPE NamedTypes = [NamedType]--DATA Program | Program chunks : Chunks- ordered : Bool--DATA Chunk | Chunk name : String- comment : Decl- info : Decls- dataDef : Decls- cataFun : Decls- semDom : Decls- semWrapper : Decls- semFunctions : Decls- semNames : {[String]}--DATA Expr | Let decls : Decls- body : Expr- | Case expr : Expr- alts : CaseAlts- | Do stmts : Decls- body : Expr- | Lambda args : Exprs- body : Expr- | TupleExpr exprs : Exprs- | UnboxedTupleExpr exprs : Exprs- | App name : {String}- args : Exprs- | SimpleExpr txt : {String}- | TextExpr lns : {[String]}- | Trace txt : {String}- expr : Expr- | PragmaExpr onLeftSide : {Bool}- onNewLine : {Bool}- txt : {String}- expr : Expr- | LineExpr expr : Expr- | TypedExpr expr : Expr- tp : Type- | ResultExpr nt : String- expr : Expr- | InvokeExpr nt : String- expr : Expr- args : Exprs- | ResumeExpr nt : String- expr : Expr- left : Lhs- rhs : Expr- | SemFun nt : {String}- args : Exprs- body : Expr--DATA CaseAlt | CaseAlt left : Lhs- expr : Expr--DATA Decl | Decl left : Lhs- rhs : Expr- binds : {Set String} -- set of variable names bound by the left-hand side- uses : {Set String} -- set of variable names used by the right-hand side- | Bind left : Lhs- rhs : Expr- | BindLet left : Lhs- rhs : Expr- | Data name : {String}- params: {[String]}- alts : DataAlts- strict: Bool- derivings : {[String]}- | NewType name : {String}- params: {[String]}- con : {String}- tp : Type- | Type name : {String}- params: {[String]}- tp : Type- | TSig name : {String}- tp : Type- | Comment txt : {String}- | PragmaDecl txt : {String}-- | Resume monadic : {Bool}- nt : String- left : Lhs- rhs : Expr- | EvalDecl nt : String- left : Lhs- rhs : Expr--DATA DataAlt | DataAlt name : {String}- args : Types- | Record name : {String}- args : NamedTypes--DATA NamedType | Named strict: {Bool}- name : {String}- tp : Type--DATA Type | Arr left : Type- right : Type- | CtxApp left : {[(String, [String])]}- right : Type- | QuantApp left : String- right : Type- | TypeApp func : Type- args : Types- | TupleType tps : Types- | UnboxedTupleType tps : Types- | List tp : Type- | SimpleType txt : {String}- | NontermType name : String- params : {[String]}- deforested : Bool- | TMaybe tp : Type- | TEither left : Type- right : Type- | TMap key : Type- value : Type- | TIntMap value : Type- | TSet tp : Type- | TIntSet--DATA Lhs | Pattern3 pat3 : Pattern- | Pattern3SM pat3 : Pattern- | TupleLhs comps : {[String]} -- \ [Lhs] appears to be more sensible- | UnboxedTupleLhs comps : {[String]} -- /- | Fun name : {String}- args : Exprs- | Unwrap name : {String} sub : Lhs--DERIVING Type : Show--{--- Unboxed tuples--- unbox Whether unboxed tuples are wanted or not--- inh The inherited attributes.--- If there are none, no unboxing can take place,--- because in that case the semantic function (a top-level identifier) would have an unboxed type.--- Of course we can't have an unboxed 1-tuple-mkTupleExpr :: Bool -> Bool -> Exprs -> Expr-mkTupleExpr unbox' noInh exprs | not unbox' || noInh || length exprs == 1 = TupleExpr exprs- | otherwise = UnboxedTupleExpr exprs-mkTupleType :: Bool -> Bool -> Types -> Type-mkTupleType unbox' noInh tps | not unbox' || noInh || length tps == 1 = TupleType tps- | otherwise = UnboxedTupleType tps-mkTupleLhs :: Bool -> Bool -> [String] -> Lhs-mkTupleLhs unbox' noInh comps | not unbox' || noInh || length comps == 1 = TupleLhs comps- | otherwise = UnboxedTupleLhs comps-}-
− src-ag/CodeSyntax.ag
@@ -1,90 +0,0 @@-imports-{-import Patterns-import CommonTypes-import Data.Map(Map)-import Data.Set(Set)-}--DATA CGrammar- | CGrammar typeSyns : {TypeSyns}- derivings : {Derivings}- wrappers : {Set NontermIdent}- nonts : CNonterminals- pragmas : {PragmaMap}- paramMap : {ParamMap}- contextMap: {ContextMap}- quantMap : {QuantMap}- aroundsMap: {Map NontermIdent (Map ConstructorIdent (Set Identifier))}- mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))}- multivisit : {Bool}--TYPE CNonterminals = [CNonterminal]--DATA CNonterminal- | CNonterminal nt : NontermIdent- params : {[Identifier]}- inh : Attributes- syn : Attributes- prods : CProductions- inter : CInterface--DATA CInterface- | CInterface seg:CSegments--TYPE CSegments = [CSegment]--DATA CSegment- | CSegment inh : Attributes- syn : Attributes--TYPE CProductions = [CProduction]--DATA CProduction- | CProduction con : ConstructorIdent- visits : CVisits- children : {[(Identifier,Type,ChildKind)]}- terminals : {[Identifier]}--TYPE CVisits = [CVisit]--DATA CVisit- | CVisit inh : Attributes- syn : Attributes- vss : Sequence -- sequence of "steps", where each "step" is either an attribute definition or a child visit- intra : Sequence -- how to glue the visits together (child visits are child-intra's, attr-defs are attr-intra's)- ordered : Bool -- indicates that vss is ordered--TYPE Sequence = [CRule]--DATA CRule- | CRule name : Identifier- isIn : Bool -- True iff there is a definition for an inherited attribute- hasCode : Bool -- True iff there is an RHS- nt : NontermIdent- con : ConstructorIdent- field : Identifier- childnt : {Maybe NontermIdent} -- Just n: 'field' of 'nt' and 'con' is a nonterminal 'n', Nothing: it is a terminal- tp : {Maybe Type} -- type of the attribute- pattern : Pattern -- only defined if 'isIn' is False- rhs : {[String]} -- empty string if 'hasCode' is False- defines : {Map Int (Identifier,Identifier,Maybe Type)} -- the attributes defined by this rule- owrt : {Bool}- origin : String -- just for documentation (and maybe errors)- uses : {Set (Identifier, Identifier)}- explicit : Bool -- True if this an explicit rule found in the source file- mbNamed : {Maybe Identifier}- | CChildVisit name : Identifier -- corresponding to the name of the child- nt : NontermIdent- nr : Int -- visit number- inh : Attributes- syn : Attributes- isLast : Bool -- indicates whether this is the last visit to this child--SET AllCodeSyntax- = CGrammar- CNonterminal CNonterminals- CInterface CSegments CSegment- CProduction CProductions- CVisits CVisit- CRule
− src-ag/CodeSyntaxDump.ag
@@ -1,103 +0,0 @@-INCLUDE "CodeSyntax.ag"-INCLUDE "Patterns.ag"--imports-{-import Data.List-import qualified Data.Map as Map--import Pretty-import PPUtil--import CodeSyntax-}--{-ppChild :: (Identifier,Type,ChildKind) -> PP_Doc-ppChild (nm,tp,_)- = 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 ]--ppAttr :: (Identifier,Identifier,Maybe Type) -> PP_Doc-ppAttr (fld,nm,mTp)- = pp fld >|< "." >|< pp nm >#<- case mTp of- Just tp -> pp "::" >#< show tp- Nothing -> empty--ppBool :: Bool -> PP_Doc-ppBool True = pp "T"-ppBool False = pp "F"--ppMaybeShow :: Show a => Maybe a -> PP_Doc-ppMaybeShow (Just x) = pp (show x)-ppMaybeShow Nothing = pp "_"--ppStrings :: [String] -> PP_Doc-ppStrings = vlist-}---ATTR AllPattern AllCodeSyntax [ | | pp USE {>-<} {empty} : PP_Doc ]--SEM CGrammar- | CGrammar lhs . pp = ppNestInfo ["CGrammar","CGrammar"] []- [ ppF "typeSyns" $ ppAssocL @typeSyns- , ppF "derivings" $ ppMap $ @derivings- , ppF "nonts" $ ppVList @nonts.ppL- ] []--SEM CNonterminal- | CNonterminal lhs . pp = ppNestInfo ["CNonterminal","CNonterminal"] (pp @nt : map pp @params) [ppF "inh" $ ppMap @inh, ppF "syn" $ ppMap @syn, ppF "prods" $ ppVList @prods.ppL, ppF "inter" @inter.pp] []--SEM CInterface- | CInterface lhs . pp = ppNestInfo ["CInterface","CInterface"] [] [ppF "seg" $ ppVList @seg.ppL] []--SEM CSegment- | CSegment lhs . pp = ppNestInfo ["CSegment","CSegment"] [] [ppF "inh" $ ppMap @inh, ppF "syn" $ ppMap @syn] []--SEM CProduction- | CProduction lhs . pp = ppNestInfo ["CProduction","CProduction"] [pp @con] [ppF "visits" $ ppVList @visits.ppL, ppF "children" $ ppVList (map ppChild @children),ppF "terminals" $ ppVList (map ppShow @terminals)] []--SEM CVisit- | CVisit lhs . pp = ppNestInfo ["CVisit","CVisit"] [] [ppF "inh" $ ppMap @inh, ppF "syn" $ ppMap @syn, ppF "sequence" $ ppVList @vss.ppL, ppF "intra" $ ppVList @intra.ppL, ppF "ordered" $ ppBool @ordered] []--SEM CRule- | CRule lhs . pp = ppNestInfo ["CRule","CRule"] [pp @name] [ppF "isIn" $ ppBool @isIn, ppF "hasCode" $ ppBool @hasCode, ppF "nt" $ pp @nt, ppF "con" $ pp @con, ppF "field" $ pp @field, ppF "childnt" $ ppMaybeShow @childnt, ppF "tp" $ ppMaybeShow @tp, ppF "pattern" $ if @isIn then pp "<no pat because In>" else @pattern.pp, ppF "rhs" $ ppStrings @rhs, ppF "defines" $ ppVertexMap @defines, ppF "owrt" $ ppBool @owrt, ppF "origin" $ pp @origin] []- | CChildVisit lhs . pp = ppNestInfo ["CRule","CChildVisit"] [pp @name] [ppF "nt" $ pp @nt, ppF "nr" $ ppShow @nr, ppF "inh" $ ppMap @inh, ppF "syn" $ ppMap @syn, ppF "last" $ ppBool @isLast] []--SEM Pattern- | Constr lhs . pp = ppNestInfo ["Pattern","Constr"] [pp @name] [ppF "pats" $ ppVList @pats.ppL] []- | Product lhs . pp = ppNestInfo ["Pattern","Product"] [ppShow @pos] [ppF "pats" $ ppVList @pats.ppL] []- | Alias lhs . pp = ppNestInfo ["Pattern","Alias"] [pp @field, pp @attr] [ppF "pat" $ @pat.pp] []- | Underscore lhs . pp = ppNestInfo ["Pattern","Underscore"] [ppShow @pos] [] []---ATTR CNonterminals CSegments CProductions CVisits Sequence Patterns [ | | ppL: {[PP_Doc]} ]--SEM Patterns- | Cons lhs . ppL = @hd.pp : @tl.ppL- | Nil lhs . ppL = []--SEM Sequence- | Cons lhs . ppL = @hd.pp : @tl.ppL- | Nil lhs . ppL = []--SEM CVisits- | Cons lhs . ppL = @hd.pp : @tl.ppL- | Nil lhs . ppL = []--SEM CProductions- | Cons lhs . ppL = @hd.pp : @tl.ppL- | Nil lhs . ppL = []--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
@@ -1,132 +0,0 @@-imports-{-import UU.Scanner.Position (Pos)-import Patterns (Pattern)-import Expression (Expression)-import CommonTypes-import Macro --marcos-}---TYPE Elems = [Elem]--TYPE Alts = [Alt]--TYPE Fields = [Field]--TYPE SemAlts = [SemAlt]--TYPE SemDefs = [SemDef]--DATA AG | AG elems : Elems--DATA Elem | Data pos : {Pos}- contype : {ConstructorType}- ctx : {ClassContext}- names : NontSet- params : {[Identifier]}- attrs : Attrs- alts : Alts- ext : {Bool}-- | Type pos : {Pos}- ctx : {ClassContext}- name : {NontermIdent}- params : {[Identifier]}- type : {ComplexType}-- | Attr pos : {Pos}- ctx : {ClassContext}- names : NontSet- quants : {[String]}- attrs : Attrs-- | Sem pos : {Pos}- ctx : {ClassContext}- names : NontSet- attrs : Attrs- quants : {[String]}- alts : SemAlts-- | Txt pos : {Pos}- kind : {BlockKind}- mbNt : {Maybe NontermIdent}- lines : {[String]}-- | Set pos : {Pos}- name : {NontermIdent}- merge : Bool- set : NontSet-- | Deriving pos : {Pos}- set : NontSet- classes : {[NontermIdent]}-- | Wrapper pos : {Pos}- set : NontSet-- | Nocatas pos : {Pos}- set : NontSet-- | Pragma pos : {Pos}- names: {[NontermIdent]}-- | Module pos : {Pos}- name : {String} -- name of the haskell module- exports : {String} -- exports of the haskell module- imports : {String} -- imports to replicate to generated haskell modules--DATA Attrs | Attrs pos : {Pos}- inh,chn,syn : {AttrNames}--DATA Alt | Alt pos : {Pos}- names : ConstructorSet- 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--DATA SemDef | Def pos : Pos- mbName : {Maybe Identifier}- pattern: Pattern- rhs : {Expression}- owrt : {Bool}- pure : Bool- eager : Bool- | TypeDef pos : {Pos}- ident : {Identifier}- tp : Type- | UniqueDef ident : {Identifier}- ref : {Identifier}- | AugmentDef ident : {Identifier}- rhs : {Expression}- | AroundDef ident : {Identifier}- rhs : {Expression}- | MergeDef target : {Identifier}- nt : {Identifier}- sources : {[Identifier]}- rhs : {Expression}- | SemPragma names : {[NontermIdent]}- | AttrOrderBefore before : {[Occurrence]}- after : {[Occurrence]}--DATA ConstructorSet | CName name : {ConstructorIdent}- | CUnion set1,set2 : ConstructorSet- | CDifference set1,set2 : ConstructorSet- | CAll--DATA NontSet | NamedSet name : {NontermIdent}- | All- | Union set1,set2 : NontSet- | Intersect set1,set2 : NontSet- | Difference set1,set2 : NontSet- | Path from,to : {NontermIdent}--
− src-ag/DeclBlocks.ag
@@ -1,20 +0,0 @@-imports-{-import Code (Decl,Expr)-}---DATA DeclBlocksRoot- | DeclBlocksRoot- blocks : DeclBlocks---DATA DeclBlocks- | DeclBlock- defs : {[Decl]}- visit : {Decl}- next : DeclBlocks- | DeclTerminator- defs : {[Decl]}- result : {Expr}-
− src-ag/DefaultRules.ag
@@ -1,821 +0,0 @@--- 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-PRAGMA strictwrap--INCLUDE "AbstractSyntax.ag"-INCLUDE "Patterns.ag"-INCLUDE "DistChildAttr.ag"--imports-{-import qualified Data.List-import qualified Data.Set as Set-import qualified Data.Map as Map-import Data.Map(Map)-import qualified Data.Sequence as Seq-import Data.Sequence(Seq,(><))-import UU.Scanner.Position(noPos)-import Pretty-import Data.Maybe-import HsToken-import HsTokenScanner-import Data.List(intersperse)-import Data.Char--import AbstractSyntax-import ErrorMessages--import Options-}------------------------------------------------------------------------------------ Passing down corresponding nonterminal and constructor names---------------------------------------------------------------------------------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 Nonterminals Nonterminal Productions Production Rules Rule- [ options:{Options}- constructorTypeMap : {Map NontermIdent ConstructorType} | | ]-ATTR Nonterminals Nonterminal Productions Production [ o_rename:{Bool}- cr:Bool {- copy rule -}- | | ]--ATTR Children Child [ cr:Bool {- copy rule -} | | ]-SEM Grammar- | Grammar nonts.o_rename = rename @lhs.options- nonts.cr = modcopy @lhs.options------------------------------------------------------------------------------------ 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} | | ]------------------------------------------------------------------------------------- some auxiliary functions---------------------------------------------------------------------------------{-fieldName n = '@' : getName n--locName n = "@loc." ++ getName n--attrName fld attr- | fld == _LOC = locName attr- | fld == _FIELD = fieldName attr- | otherwise = '@' : getName fld ++ "." ++ getName attr--_ACHILD = Ident "(" noPos -- hack--mkLocVar = AGField _LOC--isRecordConstructor :: NontermIdent -> Map NontermIdent ConstructorType -> Bool-isRecordConstructor nt ctm = Map.lookup nt ctm == Just RecordConstructor--buildConExpr ocaml clean conmap typeSyns rename nt con1 fs'- | nt `elem` map fst typeSyns = if ocaml then synonymMl- else if clean then synonymClean- else synonymHs- | otherwise = normalExpr- where fs = map fst fs'- con = getName con1- tup = " " ++ buildTuple fs- args = " " ++ unwords fs- normalExpr = if clean && isRecordConstructor nt conmap- then "{" ++ con ++ "|" ++- unwords (intersperse "," $ map (\(new, old) -> getName old ++ " = " ++ new) fs')- ++ "}"- else conname' ++ args-- conname' | rename = getName nt ++ "_" ++ getName con1- | otherwise = getName con1-- synonymHs | con == "Tuple" = buildTuple fs- | con == "Cons" = "(:)" ++ args- | 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" ++ args- | 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" ) ++ args- | otherwise = normalExpr-- synonymMl | con == "Tuple" = buildTuple fs- | con == "Cons" = "(::)" ++ tup- | con == "Nil" = case lookup nt typeSyns of- Just (Map _ _) -> prefixMod nt "empty"- Just (IntMap _) -> prefixMod nt "empty"- Just (OrdSet _) -> prefixMod nt "empty"- Just IntSet -> prefixMod nt "empty"- _ -> "[]"- | con == "Just" = "Some" ++ tup- | con == "Nothing" = "None"- | con == "Entry" = ( case lookup nt typeSyns of- Just (Map _ _) -> prefixMod nt "add"- Just (IntMap _) -> prefixMod nt "add"- Just (OrdSet _) -> prefixMod nt "add"- Just IntSet -> prefixMod nt "add" ) ++ args- | otherwise = normalExpr-- synonymClean | con == "Tuple" = buildTuple fs- | con == "Cons" = "(\\x xs -> [x:xs])" ++ args- | 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" ++ args- | 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" ) ++ args- | otherwise = normalExpr--- prefixMod nt nm = "M_" ++ getName nt ++ "." ++ nm--concatSeq = foldr (Seq.><) Seq.empty--splitAttrs :: Map Identifier a -> [Identifier] -> ([(Identifier,a)],[Identifier]) -- a used as (String,String)-splitAttrs _ []- = ([],[])-splitAttrs useMap (n:rest)- = let (uses,normals) = splitAttrs useMap rest- in case Map.lookup n useMap of- Just x -> ((n,x):uses , normals )- Nothing -> ( uses , n:normals )--removeDefined :: Set (Identifier,Identifier) -> (Identifier,Attributes) -> (Identifier,[Identifier])-removeDefined defined (fld,as)- = ( fld- , [ a- | a <- Map.keys as- , not (Set.member (fld,a) defined)- ]- )--}------------------------------------------------------------------------------------ Errors----------------------------------------------------------------------------------ATTR Grammar Nonterminals Nonterminal Productions Production- Child Children Rule Rules Pattern Patterns- [ | | errors USE {Seq.><} {Seq.empty}:{Seq Error} ]------------------------------------------------------------------------------------ Set of all defined nonterminals----------------------------------------------------------------------------------ATTR Nonterminals Nonterminal [ || collect_nts USE {`Set.union`} {Set.empty} : {Set NontermIdent} ]-SEM Nonterminal- | Nonterminal lhs.collect_nts = Set.singleton @nt--ATTR Nonterminals Nonterminal Productions Production [ nonterminals : {Set NontermIdent} || ]-SEM Grammar- | Grammar nonts.nonterminals = @nonts.collect_nts------------------------------------------------------------------------------------ Pass down the lhs-attributes and the USE's to each alternative of a nonterminal----------------------------------------------------------------------------------ATTR Nonterminals Nonterminal [ useMap : {UseMap} || ]-ATTR Productions Production [ inh, syn, inhOrig, synOrig : {Attributes} useMap : {Map Identifier (String,String,String)}|| ]--SEM Nonterminal- | 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- children.con = @con-SEM Child- | Child lhs . name = @name-SEM Grammar- | Grammar nonts . useMap = @useMap-SEM Grammar- | Grammar nonts . typeSyns = @typeSyns-SEM Nonterminal- | Nonterminal prods . nt = @nt--SEM Child [ | | name:{Identifier} inherited,synthesized:{Attributes} ]- | Child lhs.inherited = @loc.inh1- lhs.synthesized = if @name `Set.member` @lhs.merged- then Map.empty- else @loc.syn1--SEM Children [ | | inputs,outputs:{[(Identifier, Attributes)]} ]- | Cons lhs.inputs = (@hd.name, @hd.inherited) : @tl.inputs- .outputs = (@hd.name, @hd.synthesized) : @tl.outputs- | Nil lhs.inputs = []- .outputs = []-------------------------------------------------------------------------------------- Implementation of Use-rule and Copy-rule----------------------------------------------------------------------------------{----deprecatedCopyRuleError nt con fld a- = let mesg =- "In the definitions for alternative"- >#< getName con- >#< "of nonterminal"- >#< getName nt- >|< ","- >-< "the value of field"- >#< getName a- >#< "is copied by a copy-rule."- >-< "Copying the value of a field using a copy-rule is deprecated"- >-< "Please add the following lines to your code:"- >-< ( "SEM"- >#< getName nt- >-< indent 2 ( "|"- >#< getName con- >#< getName fld- >#< "."- >#< a- >#< "="- >#< "@"- >|< a- )- )- in CustomError True (getPos a) mesg---missingRuleErrorExpr clean nt con fld a- = (if clean then "abort" else "error")- ++ " \"missing rule: "- ++ show nt ++ "." ++ show con ++ "."- ++ show fld ++ "." ++ show a ++ "\""--makeRule :: (Identifier,Identifier) -> Expression -> String -> Bool -> Maybe Error -> Rule-makeRule (f1,a1) expr origin identity mbDelayedError- = Rule Nothing- (Alias f1 a1 (Underscore noPos))- expr- False- origin- False- True- identity- mbDelayedError- False---useRule :: Options -> Set Identifier -> [(Identifier,Attributes)] -> (Identifier,(String,String,String)) -> Rule-useRule opts locals ch_outs (n,(op,e,pos))- = let elems = [ fld- | (fld,as) <- ch_outs- , Map.member n as- ]-- isOp [] = False- isOp (c:cs)- | isSpace c = isOp cs- | isAlpha c = case dropWhile isAlpha cs of- ('.':cs2) -> isOp cs2 -- fully qualified name, drop prefix- _ -> False- | c == '(' = False- | otherwise = True-- tks | Set.member n locals = [mkLocVar n noPos Nothing]- | null elems = lexTokens opts noPos e- | otherwise = lexTokens opts noPos str- where- opExpr l r- | isOp op = l ++ " " ++ op ++ " " ++ r -- takes the associativity of the operator- | otherwise = "(" ++ op ++ " " ++ l ++ " " ++ r ++ ")" -- associates to the right- str = foldr1 opExpr (map (flip attrName n) elems)-- in makeRule (_LHS,n)- (Expression noPos tks)- ("use rule " ++ pos)- False- Nothing---selfRule :: Bool -> Identifier -> [HsToken] -> Rule-selfRule lhsNecLoc attr tks- = makeRule (if lhsNecLoc then _LHS else _LOC,attr)- (Expression noPos tks)- "self rule"- False- Nothing-----concatRE rsess = let (rss,ess) = unzip rsess- in (concat rss, concatSeq ess)---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- copyRu a- = ( [ makeRule (fld,a)- (Expression noPos tks)- (cruletxt sel)- True- mbDelayedErr- ]- , err- )-- where- sel- | not modcopy- && Set.member a locals = Just _LOC- | otherwise = Map.lookup a env-- (tks,err,mbDelayedErr)- = case sel of- Nothing -> let tks = [HsToken (missingRuleErrorExpr (clean options) 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- | local = "copy rule (from local)"- | deprChild = "deprecated child copy"- | Set.member a locals && nonlocal = "modified copy rule"- | incoming && outgoing = "copy rule (chain)"- | incoming = "copy rule (down)"- | outgoing = "copy rule (up)"- | otherwise = "copy rule (chain)"- where outgoing = fld == _LHS- incoming = maybe False (== _LHS) sel- nonlocal = maybe False (/= _LOC) sel- local = maybe False (== _LOC) sel- deprChild = maybe False (== _ACHILD) sel-}-----SEM Production- | Production-- lhs.errors = @children.errors >< @errs >< @rules.errors >< @loc.orderErrs-- loc.(newRls, errs)- =- let locals = @rules.locals- initenv = Map.fromList ( [ (a,_ACHILD) -- _ACHILD is used to mark identifiers in the environment that are terminals- | (a,_,_) <- @children.fields- ]- ++ attrs(_LHS, @lhs.inh)- ++ [ (a,_LOC)- | a <- Set.toList locals- ]- )-- attrs (n,as) = [ (a,n) | a <- Map.keys as ]-- envs = scanl (flip Map.union)- initenv- (map (Map.fromList . attrs ) @children.outputs)-- child_envs = init envs- lhs_env = last envs-- (selfAttrs, normalAttrs)- = Map.partitionWithKey (\k _ -> maybe False isSELFNonterminal $ Map.lookup k @lhs.synOrig) @lhs.syn-- (_,undefAttrs)- = removeDefined @rules.definedAttrs (_LHS, normalAttrs)-- (useAttrs,others)- = splitAttrs @lhs.useMap undefAttrs-- (rules1, errors1)- = concatRE $ map (copyRule @lhs.options @lhs.wrappers @lhs.nt @con @lhs.cr locals)- (zip envs (map (removeDefined @rules.definedAttrs) @children.inputs))-- uRules- = map (useRule @lhs.options locals @children.outputs) useAttrs-- -- creates a loc.xxx if there is a synthesized attr xxx of type SELF and no- -- loc.xxx exists yet. If there exists a terminal yyy and a local loc.yyy, then- -- the local is chosen as value for the terminal.- selfLocRules- = [ selfRule False attr $- lexTokens @lhs.options noPos $ -- building a string and lexing it again is not so nice... but practical here- constructor [(childSelf attr nm tp, nm) | (nm,tp,virt) <- @children.fields, childExists virt]- | attr <- Map.keys selfAttrs- , not (Set.member attr locals)- ]- where- childSelf self nm tp- = case tp of NT nt _ _ -> attrName nm self- _ | nm `Set.member` locals -> locName nm- | otherwise -> fieldName nm- constructor fs- = buildConExpr (ocaml @lhs.options) (clean @lhs.options) @lhs.constructorTypeMap @lhs.typeSyns @lhs.o_rename @lhs.nt @con fs-- childExists ChildAttr = False- childExists _ = True-- selfRules- = [ selfRule True attr [mkLocVar attr noPos Nothing]- | attr <- Map.keys selfAttrs- , not (Set.member (_LHS,attr) @rules.definedAttrs)- ]-- (rules5, errs5)- = copyRule @lhs.options- @lhs.wrappers- @lhs.nt- @con- @lhs.cr- locals- (lhs_env, (_LHS, others))- in (uRules++selfLocRules++selfRules++rules5++rules1, errors1><errs5)--{-buildTuple fs = "(" ++ concat (intersperse "," fs) ++ ")"--addAugments :: (Identifier, [Expression]) -> [Rule] -> [Rule]-addAugments (_, exprs) rules- | null exprs = rules-addAugments (syn, exprs) rules- = [rule] ++ funRules ++ map modify rules- where- rule = Rule Nothing (Alias _LHS syn (Underscore noPos)) rhs False "augmented rule" False True False Nothing False- rhs = Expression noPos tks- tks = [ HsToken "foldr ($) " noPos, mkLocVar substSyn noPos Nothing, HsToken " [" noPos] ++ funs ++ [HsToken "]" noPos]- funs = intersperse (HsToken ", " noPos) (map (\n -> mkLocVar 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 True False Nothing False) funNames exprs-- 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) = (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)- | 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 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 -> mkLocVar 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 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 True False Nothing False- childLoc = Ident (show target ++ "_merge") (getPos target)-}---ATTR Rule Rules Pattern Patterns- [ | | locals USE {`Set.union`} {Set.empty} : {Set Identifier}- definedAttrs USE {`Set.union`} {Set.empty} : {Set (Identifier,Identifier)}- ]---SEM Pattern- | Alias lhs.definedAttrs = Set.insert (@field,@attr) @pat.definedAttrs- .locals = if @field == _LOC- then Set.insert @attr @pat.locals- else @pat.locals--SEM Children [ | | fields : {[(Identifier,Type,ChildKind)]} ]- | Cons lhs.fields = @hd.field : @tl.fields- | Nil lhs.fields = []--SEM Child [ | | field : { (Identifier,Type,ChildKind) } ]- | Child lhs.field = (@name,@tp,@kind)---------------------------------------------------------------------------------------------------------------------------------------------------------------------ATTR Rule Pattern Patterns [ || containsVars USE {||} {False} : Bool ]--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 getName args) False-elimSelfId _ _ tp = tp--elimSelfStr :: NontermIdent -> [String] -> Type -> Type-elimSelfStr nt args Self = NT nt args False-elimSelfStr _ _ tp = tp-}------------------------------------------------------------------------------------ Reconstructing the tree----------------------------------------------------------------------------------ATTR Nonterminals Nonterminal Productions Production Rules Rule [ | uniq:Int | ]--SEM Grammar- | Grammar nonts.uniq = 1--ATTR Grammar Nonterminals Nonterminal Productions- Production Children Child Rules Rule Pattern Patterns TypeSigs TypeSig- [ | | output:SELF ]--ATTR Rule [ | | outputs:Rules ]--SEM 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 @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 && @hd.isPure then @hd.outputs ++ @tl.output else @tl.output- -- remove rules that define nothing and do not have side effects--SEM Rule- | 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 = [mkLocVar (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-by- loc.tup1 = e- loc.(a,_) = @loc.tup1- loc.(_,b) = @loc.tup1-It needs to thread a unique number for inventing names for the tuples.--It also works for nested tuples:- loc.(a,(b,c)) = e-becomes- loc.tup1 = e- loc.(a,_) = @loc.tup1- loc.(_,tup2) = @loc.tup1- loc.(b,_) = @loc.tup2- loc.(_,c) = @loc.tup2--}--multiRule :: Rule -> Int -> ([Rule], Int)-multiRule (Rule _ 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)- a = length pats - 1- us b p = Product pos (replicate (a-b) (Underscore pos) ++ [p] ++ replicate b (Underscore pos))- g :: Pattern -> ([Pattern],[Rule],Int) -> ([Pattern],[Rule],Int)- g p (xs1,rs1,n1) = let (x2,(rs2,n2)) = f False (us (length xs1)) freshExpr p n1- in (x2:xs1, rs2++rs1, n2)- (xs9,rs9,n9) = foldr g ([], [], n+1) pats- in ( freshPat- , ( Rule Nothing (w freshPat) e owrt origin expl' True False mbErr eager : rs9- , n9- )- )- f expl' w e p n- = ( p- , ( [Rule Nothing (w p) e owrt origin expl' True False mbErr eager]- , n- )- )- in snd (f expl id expr pat uniq)--}------------------------------------------------------------------------------------ Check the order definitions----------------------------------------------------------------------------------ATTR Nonterminals Nonterminal Productions Production [ manualAttrOrderMap : {AttrOrderMap} | | ]--SEM Grammar- | Grammar- nonts.manualAttrOrderMap = @manualAttrOrderMap--ATTR Rules Rule [ | | ruleNames USE {`Set.union`} {Set.empty} : {Set Identifier} ]--SEM Rule | Rule lhs.ruleNames = case @mbName of- Nothing -> Set.empty- Just nm -> Set.singleton nm--SEM Production- | Production- loc.orderDeps = Set.toList $ Map.findWithDefault Set.empty @con $ Map.findWithDefault Map.empty @lhs.nt @lhs.manualAttrOrderMap-- loc.orderErrs- = let chldOutMap = Map.fromList [ (k, Map.keysSet s) | (k,s) <- @children.outputs ]- chldInMap = Map.fromList [ (k, Map.keysSet s) | (k,s) <- @children.inputs ]-- -- a local attribute- -- or an inherited attribute of the production- -- or an out-attribute of a child- isInAttribute :: Identifier -> Identifier -> [Error]- isInAttribute fld nm- | fld == _LOC = if nm `Set.member` @rules.locals- then []- else [UndefAttr @lhs.nt @con fld nm False]- | fld == _LHS = if nm `Map.member` @lhs.inh- then []- else [UndefAttr @lhs.nt @con fld nm False]- | otherwise = if nm `Set.member` (Map.findWithDefault Set.empty fld chldOutMap)- then []- else [UndefAttr @lhs.nt @con fld nm False]-- -- a local attribute- -- or a synthesized attribute of the production- -- or an in-attribute of a child- isOutAttribute :: Identifier -> Identifier -> [Error]- isOutAttribute fld nm- | fld == _LOC = if nm `Set.member` @rules.locals- then []- else [UndefAttr @lhs.nt @con fld nm True]- | fld == _LHS = if nm `Map.member` @lhs.syn- then []- else [UndefAttr @lhs.nt @con fld nm True]- | otherwise = if nm `Set.member` (Map.findWithDefault Set.empty fld chldInMap)- then []- else [UndefAttr @lhs.nt @con fld nm True]-- existsRule nm = if nm `Set.member` @rules.ruleNames- then []- else [MissingNamedRule @lhs.nt @con nm]-- checkIn (OccAttr fld nm) = isInAttribute fld nm- checkIn (OccRule nm) = existsRule nm- checkOut (OccAttr fld nm) = isOutAttribute fld nm- checkOut (OccRule nm) = existsRule nm- in Seq.fromList . concat $- [ checkIn occA ++ checkOut occB- | (Dependency occA occB) <- @loc.orderDeps- ]------------------------------------------------------------------------------------ Decompose augment----------------------------------------------------------------------------------ATTR Nonterminals Nonterminal [ augmentsIn : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} | | ]-ATTR Productions Production [ augmentsIn : {Map ConstructorIdent (Map Identifier [Expression])} | | ]--SEM Grammar | Grammar nonts.augmentsIn = @augmentsMap-SEM Nonterminal | Nonterminal loc.augmentsIn = Map.findWithDefault Map.empty @nt @lhs.augmentsIn-SEM Production | Production loc.augmentsIn = Map.findWithDefault Map.empty @con @lhs.augmentsIn--ATTR Nonterminals Nonterminal [ aroundsIn : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} | | ]-ATTR Productions Production [ aroundsIn : {Map ConstructorIdent (Map Identifier [Expression])} | | ]--SEM Grammar | Grammar nonts.aroundsIn = @aroundsMap-SEM Nonterminal | Nonterminal loc.aroundsIn = Map.findWithDefault Map.empty @nt @lhs.aroundsIn-SEM Production | Production loc.aroundsIn = Map.findWithDefault Map.empty @con @lhs.aroundsIn--ATTR Nonterminals Nonterminal [ mergesIn : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression)))} | | ]-ATTR Productions Production [ mergesIn : {Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression))} | | ]-ATTR Children Child [ merged : {Set Identifier} | | ]--SEM Grammar | Grammar nonts.mergesIn = @mergeMap-SEM Nonterminal | Nonterminal loc.mergesIn = Map.findWithDefault Map.empty @nt @lhs.mergesIn-SEM Production | Production loc.mergesIn = Map.findWithDefault Map.empty @con @lhs.mergesIn- loc.merged = Set.fromList [ c | (_,cs,_) <- Map.elems @loc.mergesIn, c <- cs ]
− src-ag/Desugar.ag
@@ -1,332 +0,0 @@-PRAGMA strictdata-PRAGMA optimize-PRAGMA bangpats-PRAGMA strictwrap--INCLUDE "AbstractSyntax.ag"-INCLUDE "Patterns.ag"-INCLUDE "Expression.ag"-INCLUDE "HsToken.ag"-INCLUDE "DistChildAttr.ag"---imports-{-import qualified Data.Set as Set-import qualified Data.Map as Map-import Data.Map(Map)-import qualified Data.Sequence as Seq-import Data.Sequence(Seq,(><))-import UU.Scanner.Position(Pos(..))-import Data.Maybe-import Data.List(intersperse)--import AbstractSyntax-import ErrorMessages-import Options-import HsToken-import HsTokenScanner-import TokenDef-import CommonTypes-}--WRAPPER HsTokensRoot---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} ]--ATTR Grammar Nonterminals Nonterminal Productions Production Child Children Rule Rules Pattern Patterns TypeSig TypeSigs Expression [ | | output : SELF ]------------------------------------------------------------------------------------- Deal with RHS----------------------------------------------------------------------------------SEM Expression- | Expression- (loc.tks', lhs.errors) = let inh = Inh_HsTokensRoot { childInhs_Inh_HsTokensRoot = @lhs.childInhs- , childSyns_Inh_HsTokensRoot = @lhs.childSyns- , nt_Inh_HsTokensRoot = @lhs.nt- , con_Inh_HsTokensRoot = @lhs.con- , ruleDescr_Inh_HsTokensRoot = @lhs.ruleDescr- , useFieldIdent_Inh_HsTokensRoot = genUseTraces @lhs.options- }- sem = sem_HsTokensRoot (HsTokensRoot @tks)- syn = wrap_HsTokensRoot sem inh- in (tks_Syn_HsTokensRoot syn, errors_Syn_HsTokensRoot syn)- lhs.output = Expression @pos @tks'---ATTR HsTokensRoot HsTokens HsToken [ useFieldIdent : Bool | | ]--ATTR HsToken HsTokens [ | addLines : Int | ]-SEM HsTokensRoot- | HsTokensRoot- tokens.addLines = 0--ATTR HsTokensRoot [ | | tks : {[HsToken]} ]-ATTR HsToken HsTokens [ | | tks : SELF ]--SEM HsToken- | AGLocal- lhs.addLines = if @lhs.useFieldIdent- then @lhs.addLines + 1- else @lhs.addLines- loc.tks = AGLocal @var (addl @lhs.addLines @pos) (if @lhs.useFieldIdent then Just @lhs.ruleDescr else Nothing)- | AGField- loc.mField = findField @field @attr @lhs.childSyns-- loc.field' = maybe @field id @loc.mField- lhs.errors = maybe (Seq.singleton (UndefAttr @lhs.nt @lhs.con @field (Ident "<ANY>" (getPos @field)) False)) (const Seq.empty) @loc.mField-- lhs.addLines = if @lhs.useFieldIdent || length (getName @field) < length (getName @loc.field')- then @lhs.addLines + 1- else @lhs.addLines-- loc.tks = AGField @loc.field' @attr (addl @lhs.addLines @pos) (if @lhs.useFieldIdent then Just @lhs.ruleDescr else Nothing)- | HsToken- loc.tks = HsToken @value (addl @lhs.addLines @pos)- | CharToken- loc.tks = CharToken @value (addl @lhs.addLines @pos)- | StrToken- loc.tks = StrToken @value (addl @lhs.addLines @pos)- | Err- loc.tks = Err @mesg (addl @lhs.addLines @pos)--{-addl :: Int -> Pos -> Pos-addl n (Pos l c f) = Pos (l+n) c f-}------------------------------------------------------------------------------------- Deal with LHS----------------------------------------------------------------------------------SEM Pattern- | Alias- (loc.field', loc.err1) = maybeError @field (UndefAttr @lhs.nt @lhs.con (Ident "<ANY>" (getPos @field)) @attr True) $- findField @field @attr @lhs.childInhs- loc.err2 = if @loc.field' == @field- then Seq.empty- 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- loc.output = Alias @loc.field' @attr @pat.output------------------------------------------------------------------------------------- Distribute attributes of children----------------------------------------------------------------------------------ATTR Children Child [ | | childInhs, childSyns USE {++} {[]} : {[(Identifier, Identifier)]} ]-ATTR Rules Rule Pattern Patterns Expression HsTokensRoot HsToken HsTokens [ childInhs, childSyns : {[(Identifier, Identifier)]} | | ]--SEM Child- | Child- 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)-maybeError def err mb- = maybe (def, Seq.singleton err) (\r -> (r, Seq.empty)) mb--findField :: Identifier -> Identifier -> [(Identifier,Identifier)] -> Maybe Identifier-findField fld attr list- | fld == _FIRST = f list- | fld == _LAST = f (reverse list)- | otherwise = Just fld- where- f = lookup attr-}------------------------------------------------------------------------------------- Distribute nt and con----------------------------------------------------------------------------------ATTR Productions Production Rule Rules Pattern Patterns Expression HsTokensRoot HsToken HsTokens [ nt : NontermIdent | | ]-ATTR Rule Rules Pattern Patterns Expression HsTokensRoot HsToken HsTokens [ con : ConstructorIdent | | ]--SEM Nonterminal- | Nonterminal- prods.nt = @nt--SEM Production- | Production- rules.con = @con------------------------------------------------------------------------------------- Distribute a pattern description----------------------------------------------------------------------------------ATTR Expression HsTokensRoot HsToken HsTokens [ ruleDescr : String | | ]--SEM Rule- | Rule- loc.ruleDescr = show @lhs.nt ++ " :: " ++ show @lhs.con ++ " :: " ++ (concat $ intersperse "," $ map (\(f,a) -> show f ++ "." ++ show a) $ Set.toList @pattern.defsCollect)------------------------------------------------------------------------------------- Distribute all defined attributes----------------------------------------------------------------------------------ATTR Rule Rules Pattern Patterns [ | | defsCollect USE {`Set.union`} {Set.empty} : {Set (Identifier, Identifier)} ]-SEM Pattern- | Alias- loc.def = Set.singleton (@field, @attr)- lhs.defsCollect = @loc.def `Set.union` @pat.defsCollect--ATTR Rule Rules Pattern Patterns [ defs : {Set (Identifier, Identifier)} | | ]-SEM Production- | Production- rules.defs = @rules.defsCollect------------------------------------------------------------------------------------- Collect a list of all attributes (that are not irrefutable)----------------------------------------------------------------------------------ATTR Grammar Nonterminals Nonterminal Productions Production Rule Rules Pattern Patterns- [ | | allAttributes USE {`mergeAttributes`} {Map.empty} : {AttrMap} ]--SEM Pattern- | Alias- lhs.allAttributes = (Map.singleton @lhs.nt $ Map.singleton @lhs.con $ Set.singleton (@field, @attr)) `mergeAttributes` @pat.allAttributes- | Irrefutable- lhs.allAttributes = Map.empty--{-mergeAttributes :: AttrMap -> AttrMap -> AttrMap-mergeAttributes = Map.unionWith $ Map.unionWith $ Set.union-}------------------------------------------------------------------------------------- Distribute a list of attributes forced to irrefutables----------------------------------------------------------------------------------ATTR Grammar Nonterminals Nonterminal Productions Production Rule Rules Pattern Patterns- [ forcedIrrefutables : {AttrMap} | | ]--SEM Pattern- | Alias- lhs.output = if Set.member (@field, @attr) $ Map.findWithDefault Set.empty @lhs.con $ Map.findWithDefault Map.empty @lhs.nt $ @lhs.forcedIrrefutables- then Irrefutable @loc.output- else @loc.output------------------------------------------------------------------------------------- Decompose augment map and rebuild it----------------------------------------------------------------------------------ATTR Nonterminals Nonterminal [ augmentsIn : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))}- | | augmentsOut USE {`Map.union`} {Map.empty} : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} ]-ATTR Productions Production [ augmentsIn : {Map ConstructorIdent (Map Identifier [Expression])}- | | augmentsOut USE {`Map.union`} {Map.empty} : {Map ConstructorIdent (Map Identifier [Expression])} ]--SEM Grammar- | Grammar- nonts.augmentsIn = @augmentsMap--SEM Nonterminal- | Nonterminal- loc.augmentsIn = Map.findWithDefault Map.empty @nt @lhs.augmentsIn- loc.augmentsOut = Map.singleton @nt @prods.augmentsOut--SEM Production- | Production- loc.augmentsIn = Map.findWithDefault Map.empty @con @lhs.augmentsIn- loc.augmentsOut = Map.singleton @con @loc.augmentsOut1-- (loc.augmentErrs, loc.augmentsOut1) = Map.mapAccum (desugarExprs @lhs.options @lhs.nt @con @children.childInhs @children.childSyns) Seq.empty @loc.augmentsIn--WRAPPER Expression--{-desugarExprs :: Options -> NontermIdent -> ConstructorIdent ->- [(Identifier, Identifier)] -> [(Identifier, Identifier)] ->- Seq Error -> [Expression] -> (Seq Error, [Expression])-desugarExprs options nt con childInhs childSyns- = mapAccum (desugarExpr options nt con childInhs childSyns)- where mapAccum f e = foldr (\x (e0,xs) -> let (e1,x') = f e0 x in (e1, x:xs)) (e, [])--desugarExpr :: Options -> NontermIdent -> ConstructorIdent ->- [(Identifier, Identifier)] -> [(Identifier, Identifier)] ->- Seq Error -> Expression -> (Seq Error, Expression)-desugarExpr options nt con childInhs childSyns errs expr- = (errs Seq.>< errors_Syn_Expression syn, output_Syn_Expression syn)- where- inh = Inh_Expression { childInhs_Inh_Expression = childInhs- , childSyns_Inh_Expression = childSyns- , con_Inh_Expression = con- , nt_Inh_Expression = nt- , options_Inh_Expression = options- , ruleDescr_Inh_Expression = "augment-rule"- }- sem = sem_Expression expr- syn = wrap_Expression sem inh-}------------------------------------------------------------------------------------- Errors of a production----------------------------------------------------------------------------------SEM Production- | Production- 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- lhs.output = Grammar @typeSyns- @useMap- @derivings- @wrappers- @nonts.output- @pragmas- @manualAttrOrderMap- @paramMap- @contextMap- @quantMap- @uniqueMap- @nonts.augmentsOut- @aroundsMap- @mergeMap
− src-ag/ErrorMessages.ag
@@ -1,148 +0,0 @@-imports-{-import UU.Scanner.Position(Pos)-import Pretty-import CodeSyntax-import CommonTypes-}--TYPE Errors = [Error]--DATA Error | ParserError pos : {Pos}- problem : {String}- action : {String}-- | HsParseError pos : {Pos}- msg : {String}-- | DupAlt nt : {NontermIdent}- con,occ1 : {ConstructorIdent}-- | DupSynonym nt,occ1 : {NontermIdent}-- | DupSet name,occ1 : {NontermIdent}-- | DupInhAttr nt : {NontermIdent}- attr,occ1 :{Identifier}-- | DupSynAttr nt : {NontermIdent}- attr,occ1 : {Identifier}-- | DupChild nt : {NontermIdent}- con : {ConstructorIdent}- name,occ1 : {Identifier}-- | DupRule nt : {NontermIdent}- con : {ConstructorIdent}- field : {Identifier}- attr,occ1 : {Identifier}-- | DupRuleName nt : {NontermIdent}- con : {ConstructorIdent}- nm : {Identifier}-- | DupSig nt : {NontermIdent}- con : {ConstructorIdent}- attr : {Identifier}-- | UndefNont nt : {NontermIdent}-- | UndefAlt nt : {NontermIdent}- con : {ConstructorIdent}-- | UndefChild nt : {NontermIdent}- con : {ConstructorIdent}- name : {Identifier}-- | MissingRule --pos : {Pos}- nt : {NontermIdent}- con : {ConstructorIdent}- field : {Identifier}- attr : {Identifier}-- | MissingNamedRule nt : {NontermIdent}- con : {Identifier}- name : {Identifier}-- | SuperfluousRule nt : {NontermIdent}- con : {ConstructorIdent}- field : {Identifier}- attr : {Identifier}---- | SuperfluousSig nt : {NontermIdent}--- con : {ConstructorIdent}--- attr : {Identifier}-- | UndefLocal nt : {NontermIdent}- con : {ConstructorIdent}- var : {Identifier}-- | ChildAsLocal nt : {NontermIdent}- con : {ConstructorIdent}- var : {Identifier}-- | UndefAttr nt : {NontermIdent}- con : {ConstructorIdent}- field : {Identifier}- attr : {Identifier}- isOut : {Bool}-- | Cyclic nt : {NontermIdent}- mbCon : {Maybe ConstructorIdent}- verts : {[String]}-- | CyclicSet name:{Identifier}-- | CustomError isWarning : {Bool}- pos : {Pos}- mesg : {PP_Doc}-- | LocalCirc nt : {NontermIdent}- con : {ConstructorIdent}- attr : {Identifier}- o_visit : {Bool}- path : {[String]}-- | InstCirc nt : {NontermIdent}- con : {ConstructorIdent}- attr : {Identifier}- o_visit : {Bool}- path : {[String]}-- | DirectCirc nt : {NontermIdent}- o_visit : {Bool}- cyclic : {[((Identifier,Identifier),[String],[String])]}-- | InducedCirc nt : {NontermIdent}- cinter : {CInterface}- cyclic : {[((Identifier,Identifier),[String],[String])]}-- | MissingTypeSig nt : {NontermIdent}- con : {ConstructorIdent}- attr : {Identifier}-- | MissingInstSig nt : {NontermIdent}- con : {ConstructorIdent}- attr : {Identifier}-- | DupUnique nt : {NontermIdent}- con : {ConstructorIdent}- attr : {Identifier}-- | MissingUnique nt : {NontermIdent}- attr : {Identifier}-- | 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
@@ -1,83 +0,0 @@-imports-{--- VisitSyntax.ag imports-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 NontermIdent}- derivings : {Derivings}--TYPE ENonterminals = [ENonterminal]--TYPE EProductions = [EProduction]--TYPE ERules = [ERule]--TYPE EChildren = [EChild]--TYPE VisitSteps = [VisitStep]--TYPE Visits = [Visit]--DATA ENonterminal | ENonterminal nt : {NontermIdent}- params : {[Identifier]}- classCtxs : {ClassContext} -- class context at the datatype level- initial : {StateIdentifier}- initialv : {[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}- params : {[Identifier]}- constraints : {[Type]} -- (class/equality) constraints on types (requires GADTs)- rules : ERules- children : EChildren- visits : Visits--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- 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 Identifier}- syn : {Set Identifier}- steps : VisitSteps- kind : {VisitKind}--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/ExecutionPlan2Caml.ag
@@ -1,1487 +0,0 @@--- As expected, the code generation for ML resembles the code generation for Haskell quite a bit.--- However, there are several differences:--- * no inline pragmas--- * no strictness annotations (not needed)--- * separating data types from code------ Generator conventions:--- * we generate functions definitions with an 'and' binding and a match statement--- * for some type aliasses, we'll introduce module decls in addition to a type------ Future work:--- * abuse the module system more?--- * parse ocaml blocks?--- * lazy evaluation?------ Other comments:--- * Empty records are not allowed in Ocaml. Mapping them to units.--- * line pragmas. There are now line pragmas around the body of rules.--- There cannot be syntactical mistakes in the patterns. However, there can be--- type errors if a function returns a value with a type that differs from what--- is expected. It's then not clear which location is reported.--- Also, errors in type signatures are not caught.--- However, usually, the problematic cases are syntax errors, and these are--- prevented by parsing the definitions first.--INCLUDE "ExecutionPlan.ag"-INCLUDE "Patterns.ag"-INCLUDE "Expression.ag"-INCLUDE "HsToken.ag"--imports-{-import ExecutionPlan-import Pretty-import PPUtil-import Options-import Data.Monoid(mappend,mempty)-import Data.Maybe-import Data.Graph-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- [ mainFile, mainName : String | | ]------------------------------------------------------------------------------------ Options---------------------------------------------------------------------------------ATTR ExecutionPlan- ENonterminals ENonterminal- EProductions EProduction- ERules ERule- EChildren EChild- Expression- HsToken HsTokens HsTokensRoot- Pattern Patterns- 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------------------------------------------------------------------------------------ output attributes: we make a distinction between data declarations--- and code---------------------------------------------------------------------------------ATTR ExecutionPlan [ | | datas, code, modules : {PP_Doc} ]--SEM ExecutionPlan | ExecutionPlan- lhs.code = @nonts.code >-< @loc.wrappersExtra- lhs.datas = @nonts.datas >-< @loc.commonExtra--ATTR ENonterminal ENonterminals- [ wrappers : {Set NontermIdent} | | datas,code,modules USE {>-<} {empty} : {PP_Doc} ]--SEM ExecutionPlan | ExecutionPlan- nonts.wrappers = @wrappers--SEM ENonterminal | ENonterminal- lhs.datas = ( text ""- >-< "(* *** " ++ getName @nt ++ " *** [data] *)")- >-< (if dataTypes @lhs.options- then pp "(* data *)"- >-< @loc.datatypeNt- >-< @loc.datatypeProds- >-< ""- else empty)- >-< (if @loc.hasWrapper- then pp "(* wrapper *)"- >-< @loc.wr_inh- >-< @loc.wr_syn- >-< ""- else empty)- >-< (if semfuns @lhs.options- then pp "(* semantic domain *)"- >-< @loc.t_init- >-< @loc.t_states- >-< @loc.c_states- >-< @prods.t_visits- >-< ""- else empty)-- lhs.code = ( text ""- >-< "(* *** " ++ getName @nt ++ " *** [code] *)")- >-< (if dataTypes @lhs.options- then pp "(* constructor functions *)"- >-< @loc.datatypeCon- else empty)- >-< (if @loc.hasWrapper- then pp "(* wrapper *)"- >-< @loc.wrapper- >-< ""- else empty)- >-< (if folds @lhs.options- then "(* cata *)"- >-< @loc.sem_nt- >-< ""- else empty)- >-< (if semfuns @lhs.options- then "(* semantic domain *)"- >-< @prods.sem_prod- >-< ""- else empty)-- -- note: we assume that these module declarations are not recursive, and- -- that their parameters do not depends on types generated by AG in the- -- same file.- lhs.modules = @loc.moduleDecl-- loc.hasWrapper = @nt `Set.member` @lhs.wrappers------------------------------------------------------------------------------------ Nonterminal datatype---------------------------------------------------------------------------------ATTR ENonterminal ENonterminals [ typeSyns : {TypeSyns} | | ]--SEM ExecutionPlan | ExecutionPlan- nonts.typeSyns = @typeSyns--{-ppRecordTp :: PP a => [a] -> PP_Doc-ppRecordTp es- | null es = text "unit"- | otherwise = pp_block "{" "}" "; " (map pp es)--ppRecordVal :: PP a => [a] -> PP_Doc-ppRecordVal es- | null es = text "()"- | otherwise = pp_block "{" "}" "; " (map pp es)--ppFieldsVal :: Bool -> [(PP_Doc,PP_Doc,PP_Doc,PP_Doc)] -> PP_Doc-ppFieldsVal record fields- | null fields = text "()"- | record = ppRecordVal [ r >#< "=" >#< x | (r,x,_,_) <- fields ]- | otherwise = pp_block "(" ")" "," [ x | (_,x,_,_) <- fields ]--ppFieldsType :: Bool -> Bool -> [(PP_Doc,PP_Doc,PP_Doc,PP_Doc)] -> PP_Doc-ppFieldsType record defor fields- | null fields = text "unit"- | record = ppRecordTp [ r >#< ":" >#< (if defor then d else f) | (r,_,d,f) <- fields ]- | otherwise = pp_block "(" ")" "*" [ if defor then d else f | (_,_,d,f) <- fields ]-}----- for each nonterminal, the following data types in ocmal:--- * data type for the nonterminal, with a constructor for--- each production. The constructor takes a single field--- with the type explained below.--- * for each production, a record type comprising the--- children of the production.------ * class contexts are ignored--- * at most one type variable------ aliasses: lists, tuples--- *** think about maps, sets, etc. Perhaps the name of--- the alias should become a local module name.-----SEM ENonterminal | ENonterminal- loc.t_params = ppTypeParams @params- loc.aliasPre = "and" >#< @loc.t_params >#< @nt >#< "="- loc.aliasMod = @loc.aliasPre >#< modName @nt >|< ".t"- loc.datatypeNt- = case lookup @nt @lhs.typeSyns of- -- generate special code for certain type aliasses- Just (List t) -> @loc.aliasPre >#< ppTp t >#< "list"- Just (Maybe t) -> @loc.aliasPre >#< ppTp t >#< "option"- Just (Tuple ts) -> @loc.aliasPre >#< (pp_block "(" ")" " * " $ map (ppTp . snd) ts)-- Just (Map k v) -> @loc.aliasMod- Just (IntMap t) -> @loc.aliasMod- Just (OrdSet t) -> @loc.aliasMod- Just IntSet -> @loc.aliasMod-- -- use the constructor-based data-type generation for all other types- _ -> "and" >#< @loc.t_params >#< @nt >#< "="- >-< ( if null @prods.datatype- then pp "unit"- else indent 2 $ vlist @prods.datatype_call- )-- loc.datatypeCon- = case lookup @nt @lhs.typeSyns of- Just _ -> empty -- no constructor funs for type aliasses- Nothing -> vlist @prods.datatype_con-- loc.moduleDecl- = let ppModule :: PP a => a -> PP_Doc- ppModule expr = "module" >#< modName @nt >#< "="- in case lookup @nt @lhs.typeSyns of- Just (Map k _) -> ppModule ("Map.Make" >#< pp_parens (ppTp k))- Just (IntMap _) -> ppModule ("Map.Make ()")- Just (OrdSet t) -> ppModule ("Set.Make" >#< pp_parens (ppTp t))- Just IntSet -> ppModule ("Set.Make (struct type t = int let compare = Pervasives.compare end)")- _ -> empty-- loc.datatypeProds = vlist @prods.datatype--ATTR EProduction [ | | datatype, datatype_call, datatype_con : {PP_Doc} ]-ATTR EProductions [ | | datatype, datatype_call, datatype_con USE {:} {[]} : {[PP_Doc]} ]--SEM EProduction | EProduction- loc.o_records = dataRecords @lhs.options- loc.t_params = ppTypeParams @lhs.params- loc.t_c_params = ppTypeParams (cont_tvar : map pp @params)- loc.conname = conname @lhs.rename @lhs.nt @con- loc.recname = pp "fields_" >|< @loc.conname- lhs.datatype = "and" >#< @loc.t_params >#< @loc.recname >#< "="- >#< ppFieldsType @loc.o_records False @children.sigs- lhs.datatype_call = pp "|" >#< @loc.conname >#< "of" >#< pp_parens (@loc.t_params >#< @loc.recname)- lhs.datatype_con- = let funNm = @lhs.nt >|< "_" >|< @con- decl = "and" >#< ppFunDecl @loc.o_sigs funNm params (@loc.t_params >#< @lhs.nt) body- params = [ (x, t) | (_,x,_,t) <- @children.sigs ]- body = @loc.conname >#< ppFieldsVal @loc.o_records @children.sigs- in decl- -ATTR EChild EChildren [ | | sigs USE {++} {[]} : {[(PP_Doc,PP_Doc,PP_Doc,PP_Doc)]} ]--SEM EChild- | EChild ETerm- loc.tpDocFor = ppTp $ removeDeforested @tp- loc.tpDocDefor = ppTp $ forceDeforested @tp- loc.fieldNm = text $ recordFieldname @lhs.nt @lhs.con @name- loc.childNm = text (fieldname @name)- loc.field = (@loc.fieldNm, @loc.childNm, @loc.tpDocDefor, @loc.tpDocFor)- | EChild lhs.sigs = case @kind of- ChildAttr -> [] -- higher order attributes are not part of the data type- _ -> [@loc.field]- | ETerm lhs.sigs = [@loc.field]--{-ppTp :: Type -> PP_Doc-ppTp tp = case tp of- Haskell t -> pp t -- ocaml type- NT nt tps deforested- | nt == _SELF -> pp "?SELF?"- | null tps -> ppNontTp nt deforested- | otherwise -> pp_parens (ppSpaced (map pp_parens tps) >#< ppNontTp nt deforested)- Self -> pp "?SELF?"--ppNontTp :: NontermIdent -> Bool -> PP_Doc-ppNontTp nt True = pp "t_" >|< pp nt-ppNontTp nt False = pp nt---- multiple type parameters go into a tuple-ppTypeParams :: PP a => [a] -> PP_Doc-ppTypeParams [] = empty-ppTypeParams [x] = pp x-ppTypeParams xs = pp_block "(" ")" "," (map pp xs)-}------------------------------------------------------------------------------------ Nonterminal semantic function---------------------------------------------------------------------------------SEM ENonterminal | ENonterminal- loc.fsemname = \x -> prefix @lhs.options ++ show x- loc.semname = @loc.fsemname @nt- loc.frecarg = \t x -> case t of- NT nt _ _ -> pp_parens (@fsemname nt >#< x)- _ -> x-- loc.sem_param_tp = @loc.t_params >#< @nt- loc.sem_res_tp = @loc.t_params >#< @loc.t_type- loc.sem_tp = @loc.sem_param_tp >#< "->" >#< @loc.sem_res_tp-- loc.o_sigs = typeSigs @lhs.options- loc.sem_nt_body = "match arg with" >-< (indent 2 $ @prods.sem_nt)- loc.sem_nt = let genSem :: PP a => a -> PP_Doc -> PP_Doc- genSem nm body = "and" >#< ppFunDecl @loc.o_sigs (pp @loc.semname) [(pp nm, @loc.sem_param_tp)] @loc.sem_res_tp body- genAlias alts = genSem (pp "arg") (pp "match arg with" >-< (indent 2 $ vlist $ map (pp "|" >#<) alts))- genMap v = let body = modName @nt >|< ".fold" >#< @loc.semname >|< "_Entry" >#< @loc.semname >|< "_Nil" >#< els- els = case v of- NT nt _ _ -> pp_parens (modName @nt >|< ".map" >#< @loc.fsemname nt >#< "m")- _ -> pp "m"- in genSem "m" body- genSet mbNt = let body = "List.fold_right" >#< @loc.semname >|< "_Entry" >#<- els (pp_parens (modName @nt >|< ".elements" >#< "s")) >#< @loc.semname >|< "_Nil"- els r = maybe r (\nt -> pp_parens ("List.map" >#< @loc.fsemname nt >#< r)) mbNt- in genSem "s" body- in case lookup @nt @lhs.typeSyns of- -- generate special code for some aliasses- Just (List t) -> let body = "List.fold_right" >#< @loc.semname >|< "_Cons" >#< els >#< @loc.semname >|< "_Nil"- els = case t of- NT nt _ _ -> pp_parens ("List.map" >#< @loc.fsemname nt >#< "list")- _ -> pp "list"- in genSem "list" body- Just (Tuple ts) -> let pat = pp_parens (ppCommas $ map fst ts)- body = @loc.semname >|< "_Tuple" >#< ppSpaced (map (\t -> @loc.frecarg (snd t) (pp $ fst t)) ts)- in genSem pat body- Just (Map _ v) -> genMap v- Just (IntMap v) -> genMap v- Just (Maybe t) -> genAlias- [ "None" >#< "->" >#< "=" >#< @loc.semname >|< "_Nothing"- , "Some" >#< "just" >#< "->" >#< @loc.semname >|< "_Just" >#< @frecarg t (pp "just")- ]- Just (OrdSet t) -> genSet $ case t of- NT nt _ _ -> Just nt- _ -> Nothing- Just (IntSet) -> genSet Nothing-- -- structural fold for the remaining cases- _ -> genSem "arg" @loc.sem_nt_body--{--- convention for nonterminals to module names-modName :: NontermIdent -> PP_Doc-modName nt = pp "M_" >|< pp nt--ppFunDecl :: Bool -> PP_Doc -> [(PP_Doc,PP_Doc)] -> PP_Doc -> PP_Doc -> PP_Doc-ppFunDecl gensigs nm args resSig expr = body where- body = nm >#< ppSpaced (map arg args) >#< ppRes >#< "="- >-< indent 2 expr- arg (arg,tp) = ppArg gensigs arg tp- ppRes- | gensigs = ":" >#< resSig- | otherwise = empty--ppArg :: Bool -> PP_Doc -> PP_Doc -> PP_Doc-ppArg gensigs arg tp- | gensigs = pp_parens (arg >#< ":" >#< tp)- | otherwise = arg--}---- The number of productions-ATTR EProductions EProduction [ | | count USE {+} {0} : {Int} ]-SEM EProduction | EProduction lhs.count = {1}---- The per-production match-expr cases for the sem_NT function-ATTR EProduction EProductions [ | | sem_nt USE {>-<} {empty} : {PP_Doc} ]-SEM EProduction | EProduction- lhs.sem_nt = "|" >#< conname @lhs.rename @lhs.nt @con >#< ppFieldsVal @loc.o_records @children.sigs >#< "->" >#<- prefix @lhs.options >|< @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 -> "(" >#< prefix @lhs.options >|< @loc.nt >#< @name >|< "_" >#< ")"- ChildAttr -> empty -- no sem-case for a higher-order child- ChildReplace tp -> "(" >#< prefix @lhs.options >|< extractNonterminal tp >#< @name >|< "_" >#< ")"- | ETerm lhs.argnamesw = text $ fieldname @name------------------------------------------------------------------------------------ Types of attributes---------------------------------------------------------------------------------ATTR ExecutionPlan- ENonterminals- ENonterminal [ inhmap : {Map NontermIdent Attributes}- synmap : {Map NontermIdent Attributes} | | ]--ATTR EProductions EProduction- ERules ERule- Patterns Pattern- 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.allstates = orderStates @initial @prods.allvisits- loc.stvisits = \st -> filter (\(v,f,t) -> f == st) @prods.allvisits- loc.t_type = type_nt_sem_top @nt- loc.t_c_params = ppTypeParams (cont_tvar : map pp @params)-- -- the initial "s" type: contains the "attach" function that delivers the initial st- loc.t_init = "and" >#< @loc.t_params >#< @loc.t_type >#< "=" >#< pp_braces ( nm_attach @nt >#< ":" >#< "unit" >#< "->" >#< @loc.t_params >#< type_nt_sem @nt @initial)-- -- the "s" type in a given state: contains the invoke function to go to a next state- loc.t_states = vlist $ map (\st ->- let s_st = type_nt_state @nt st- t_st = type_nt_sem @nt st- c_st = type_caller @nt st- nextVisits = Map.findWithDefault ManyVis st @nextVisits- decl = "and" >#< @loc.t_params >#< t_st >#< "="- in case nextVisits of- NoneVis -> decl >#< "unit" -- final state: no more subsequent visits- _ -> decl >#< ppRecordVal [ nm_invoke @nt st >#< ":" >#< cont_tvar >#< "." >#< @loc.t_c_params >#< c_st >#< "->" >#< cont_tvar ]- ) @loc.allstates--{------ conventions------- type of the state of a node: a closure containing the children states and attributes,--- with code of type 'type_nt_sem' that represents the subsequent visits to successor states.-type_nt_state nt st = "s_" >|< nt >|< "_" >|< st---- type of a visit to a node (the initial, and when in a given state)--- an instance of this type is called the "semantics"-type_nt_sem_top nt = "t_" >|< nt-type_nt_sem nt st = type_nt_sem_top nt >|< "_s" >|< st---- type of a caller (contains visit selection + inputs + continuation)-type_caller nt st = "c_" >|< nt >|< "_s" >|< st---- names of records-nm_attach nt = "attach_">|< nt-nm_invoke nt st = "inv_" >|< nt >|< "_s" >|< st---- name of the type variable representing the result type of the continuation-cont_tvar = text "'cont__"----- order states in reverse topological order so that successor states are--- earlier in the resulting list.-orderStates :: StateIdentifier -> [VisitStateState] -> [StateIdentifier]-orderStates initial edges = res where- source = Map.singleton initial Set.empty -- ensures that the initial state is in graph even when there are no edges- targets = [ Map.singleton t Set.empty | (_,_,t) <- edges ]- deps = [ Map.singleton f (Set.singleton t) | (_,f,t) <- edges ]-- mp = Map.unionsWith Set.union (source : (targets ++ deps))- es = [ (f,f,Set.toList ts) | (f,ts) <- Map.toList mp ]- cps = stronglyConnComp es- res = flattenSCCs cps-}---- type of a caller that selects a visit v from state s of the child, and--- provides a continuation of the caller after the visit to the child-SEM ENonterminal | ENonterminal- loc.c_states = vlist $ map (\st ->- let nt_st = type_nt_state @nt st- c_st = type_caller @nt st- outg = filter (\(_,f,_) -> f == st) @prods.allvisits- nextVisits = Map.findWithDefault ManyVis st @nextVisits- declHead = "and" >#< @loc.t_c_params >#< c_st >#< "="- visitcons = vlist $ map (\(v,_,_) ->- "|" >#< con_visit @nt v >#< "of" >#< @loc.t_c_params >#< type_caller_visit @nt v- ) outg- in case nextVisits of -- slight optimization for when there is only one visit- NoneVis -> empty -- st is final state, no subsequent visits, thus no more caller info- OneVis v -> declHead >#< @loc.t_c_params >#< type_caller_visit @nt v- ManyVis -> declHead >-< indent 3 visitcons- ) @loc.allstates--{-type_caller_visit nt v = "c_" >|< nt >|< "_v" >|< v-con_visit nt v = "C_" >|< nt >|< "_v" >|< v---- field names-nm_inh nt v = "inh_" >|< nt >|< "_v" >|< v-nm_cont nt v = "cont_" >|< nt >|< "_v" >|< v-}---- type t_visit of a call to a visit v (inputs to the visit + continuation of the parents that gets the output + new state of the child)-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 (these results are the same for all of them)- -- todo: that means we should actually represent visit declarations in the AST...--SEM Visit | Visit- loc.nameTIn_visit = conNmTVisitIn @lhs.nt @ident- loc.nameTOut_visit = conNmTVisitOut @lhs.nt @ident- loc.nameNextState = type_nt_sem @lhs.nt @to- loc.nameCaller_visit = type_caller_visit @lhs.nt @ident-- loc.nextVisitInfo = Map.findWithDefault ManyVis @to @lhs.nextVisits -- which visits can we do after we reach the @to state?-- loc.t_params = ppTypeParams @lhs.params- loc.t_c_params = ppTypeParams (cont_tvar : map pp @lhs.params)-- -- data type decls for the t_visit type- -- we generate a type for the caller of a visit, the arguments of the visit and the result of the visit- lhs.t_visits = "and" >#< @loc.t_c_params >#< @loc.nameCaller_visit >#< "=" >#< ppRecordTp- [ nm_inh @lhs.nt @ident >#< ":" >#< @loc.t_params >#< conNmTVisitIn @lhs.nt @ident- , nm_cont @lhs.nt @ident >#< ":" >#< @loc.t_params >#< conNmTVisitOut @lhs.nt @ident >#< "->" >#< cont_tvar- ]- >-< "and" >#< @loc.t_params >#< @loc.nameTIn_visit >#< "=" >#< ppRecordTp @loc.inhpart- >-< "and" >#< @loc.t_params >#< @loc.nameTOut_visit >#< "=" >#< ppRecordTp (@loc.synpart ++ @loc.contpart)-- loc.contpart = case @loc.nextVisitInfo of- NoneVis -> [] -- don't provide a continuation at all- _ -> [ nm_outarg_cont @lhs.nt @ident >#< ":" >#< @loc.t_params >#< @loc.nameNextState ] -- normal route: select the next semantics-- loc.inhpart = @loc.ppTypeList nm_inarg @inh @lhs.inhmap- loc.synpart = @loc.ppTypeList nm_outarg @syn @lhs.synmap- loc.ppTypeList = \f s m -> map (\i -> case Map.lookup i m of- Just tp -> f i @lhs.nt @ident >#< ":" >#< ppTp tp ) $ Set.toList s--{--- more naming conventions-nm_inarg nm nt v = "i_" >|< nm >|< "_" >|< nt >|< "_v" >|< v-nm_outarg nm nt v = "o_" >|< nm >|< "_" >|< nt >|< "_v" >|< v-nm_outarg_cont = nm_outarg "_cont"--conNmTVisit nt vId = "t_" >|< nt >|< "_v" >|< vId-conNmTVisitIn nt vId = "t_" >|< nt >|< "_vIn" >|< vId-conNmTVisitOut nt vId = "t_" >|< nt >|< "_vOut" >|< vId---- todo: remove ppMonadType-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_inhs1 -- todo: is perhaps a mistake in 2hs- loc.wr_syn = @loc.genwrap "syn" @loc.wr_syns- loc.genwrap = \nm attrs ->- "and" >#< @loc.t_params >#< nm >|< "_" >|< @nt >#< "=" >#< ppRecordTp- [ i >|< "_" >|< nm >|< "_" >|< @nt >#< ":" >#< ppTp t | (i,t) <- attrs ]-- loc.inhAttrs = fromJust $ Map.lookup @nt @lhs.inhmap- loc.wr_inhs = Map.toList $ @loc.wr_filter $ @loc.inhAttrs- loc.wr_inhs1 = Map.toList @loc.inhAttrs- 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.wrapname = text ("wrap_" ++ show @nt)- loc.inhname = text ("inh_" ++ show @nt)- loc.synname = text ("syn_" ++ show @nt)- loc.firstVisitInfo = Map.findWithDefault ManyVis @initial @nextVisits-- loc.wrapArgSemTp = @loc.t_params >#< @loc.t_type- loc.wrapArgInhTp = @loc.t_params >#< @loc.inhname- loc.wrapArgPats = ppRecordVal [ i >|< "_inh_" >|< @nt >#< "=" >#< lhsname @lhs.options True i | (i,_) <- @loc.wr_inhs1 ]- loc.wrapResTp = @loc.t_params >#< @loc.synname- loc.wrapper = "and" >#< ppFunDecl @loc.o_sigs @loc.wrapname [(pp "act", @loc.wrapArgSemTp), (@loc.wrapArgPats, @loc.wrapArgInhTp)] @loc.wrapResTp @loc.wrapperPreamble- loc.wrapperPreamble- = ( if lateHigherOrderBinding @lhs.options- then "let" >#< lhsname @lhs.options True idLateBindingAttr >#< "=" >#< lateBindingFieldNm @lhs.mainName >#< "in"- else empty- ) -- initial attribute for late binding- >-< @loc.wrapperBody- loc.wrapperBody- = case @initialv of- [] -> text "{ }" -- case where there are no inherited or synthesized attributes- (initv:_) -> -- TODO: take care of multiple visits- let attach = "let" >#< "sem" >#< "=" >#< "act." >|< nm_attach @nt >#< "()" >#< "in" -- run attach code-- -- result transformer to wrapper output record- pat = ppRecordVal [ nm_outarg i @nt initv >#< "=" >#< lhsname @lhs.options False i | (i,_) <- @loc.wr_syns ]- bld = ppRecordVal [ i >|< "_syn_" >|< @nt >#< "=" >#< lhsname @lhs.options False i | (i,_) <- @loc.wr_syns ]- res = "let res = function" >#< pat >#< "->" >#< bld >#< "in"-- -- input to the visit (inh attrs + continuation)- inps = "let" >#< "inps" >#< "=" >#< ppRecordVal [ nm_inarg i @nt initv >#< "=" >#< lhsname @lhs.options True i | (i,_) <- @loc.wr_inhs ] >#< "in"- arg = "let" >#< "arg" >#< "=" >#< argcon >#< argrec >#< "in"- argcon = case @loc.firstVisitInfo of- ManyVis -> con_visit @nt initv- _ -> empty- argrec = ppRecordVal- [ nm_inh @nt initv >#< "=" >#< "inps"- , nm_cont @nt initv >#< "=" >#< "res"- ]- invoke = "sem." >|< nm_invoke @nt @initial >#< "arg" -- invoke the visit- in attach >-< res >-< inps >-< arg >-< invoke------------------------------------------------------------------------------------ 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 lateHigherOrderBinding @lhs.options- then @loc.lateSemBndDef- else empty- loc.commonExtra = if lateHigherOrderBinding @lhs.options- then @loc.lateSemBndTp- else empty- loc.lateSemBndTp = "and" >#< lateBindingTypeNm @lhs.mainName >#< "=" >#< ppRecordTp (toList @nonts.semFunBndTps)- loc.lateSemBndDef = "and" >#< lateBindingFieldNm @lhs.mainName >#< ":" >#< lateBindingTypeNm @lhs.mainName >#< "="- >-< (indent 2 $ ppRecordVal $ 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 : {[StateIdentifier]} | | ]-SEM ENonterminal | ENonterminal- prods.initial = @initial- prods.allstates = @loc.allstates--SEM EProduction | EProduction- loc.o_sigs = typeSigs @lhs.options- loc.t_type = type_nt_sem_top @lhs.nt- loc.semname = prefix @lhs.options >|< @lhs.nt >|< "_" >|< @con- loc.sem_res_tp = @loc.t_params >#< @loc.t_type- loc.sem_tp = pp_block "" "" "->" [ d | (_,_,d,_) <- @children.sigs ] >#< "->" >#< @loc.sem_res_tp-- loc.initializer- = -- some actions, performed upon attaching a child, can- -- be specified here in the form of a let-expression.- -- The resulting bindings of these actions are- -- in scope of the rules of the production- empty -- nothing for now-- loc.sem_prod = "and" >#< ppFunDecl @loc.o_sigs @loc.semname [ (x,d) | (_,x,d,_) <- @children.sigs ] @loc.sem_res_tp @loc.prod_body- loc.prod_body- = @loc.initializer- >-< "{" >#< nm_attach @lhs.nt >#< "=" >#< "function () ->"- >-< indent 2 - ( "(* rules of production" >#< @con >#< "*)"- >-< @rules.sem_rules- >-< "(* states of production" >#< @con >#< "*)"- >-< vlist @loc.statefuns- >-< nm_st @lhs.initial- )- >#< "}"-- -- the semantic function of a production: defines a series of states and- -- their transitions. Two sorts of functions are important:- -- k-functions: inspect the caller_type to find out which visit the- -- caller wants and then dispatches that visit and continuation.- -- v-functions: the actual code of the visit.- loc.statefuns = map @loc.genstfn @lhs.allstates- loc.genstfn- = \st -> let nextVisitInfo = Map.findWithDefault ManyVis st @lhs.nextVisits- stNm = nm_st st-- -- note about the initial state: the initial state should be the only- -- state-binding that is not a function. It is non-recursive, its definition does- -- not involve side effect, and its not needed- -- anywhere except to be delivered as initial result.- stDef body = "let" >#< stNm >#< (if st == @lhs.initial then empty else @loc.stargs st) >#< "="- >-< indent 2 body >#< "in"-- 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 stDef (pp "unit") -- empty state- else empty -- no state generated- _ -> stDef $ mklets (@loc.stvs st ++ @loc.stks st) $ ppRecordVal- [ nm_invoke @lhs.nt st >#< "=" >#< nm_k st ]-- loc.stargs- = \st -> let attrs = maybe Map.empty id $ Map.lookup st @visits.intramap in ppSpaced- [ case mbAttr of- Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) ->- case Map.lookup nm @loc.localAttrTypes of- Just tp -> pp_parens (strNm >#< ":" >#< ppTp tp)- Nothing -> pp strNm- Just attr | not (noPerStateTypeSigs @lhs.options) ->- case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @loc.childTypes of- Just tpDoc -> pp_parens (strNm >#< ":" >#< tpDoc)- Nothing -> pp strNm- _ -> pp strNm- | (strNm, mbAttr) <- Map.assocs attrs- ] >#< dummyPat @lhs.options (Map.null attrs)-- -- produces the "k" function that inspect the caller argument to dispatch a visit- loc.stvisits = \st -> filter (\(_,f,_) -> f == st) @visits.allvisits- loc.stks- = \st -> let stvisits = @loc.stvisits st- def = ppFunDecl False {- @loc.o_sigs -} (pp $ nm_k st)- [(pp "arg", @loc.t_c_params >#< type_caller @lhs.nt st)] (pp cont_tvar) body-- nextVisitInfo = Map.findWithDefault ManyVis st @lhs.nextVisits- body = case nextVisitInfo of- NoneVis -> text "?no next visit?"- OneVis v -> dispatch "arg" v- ManyVis -> let alt (v,_,_) = "|" >#< con_visit @lhs.nt v >#< "chosen" >#< "->" >-< indent 2 (dispatch "chosen" v)- in "match arg with" >-< (indent 2 $ vlist $ map alt stvisits)-- dispatch nm v = "let" >#< ppRecordVal- [ nm_inh @lhs.nt v >#< "=" >#< "inp"- , nm_cont @lhs.nt v >#< "=" >#< "cont" ]- >#< "=" >#< pp nm- >-< "in" >#< "cont" >#< pp_parens (nm_visit v >#< "inp") -- call cont with res of visit-- in if null stvisits- then []- else [ "(* k-function for production" >#< @con >#< " *)" >-< def ]-- loc.stvs = \st -> [ppf | (f,ppf) <- @visits.sem_visit, f == st]- visits.mrules = @rules.mrules--{-nm_visit v = "__v" >|< v-nm_k st = "__k" >|< st-nm_st st = "__st" >|< st--mklets :: (PP b, PP c) => [b] -> c -> PP_Doc-mklets defs body = res where- ppLet def = "let" >#< def >#< "in"- res = vlist (map ppLet defs) >-< body-}------------------------------------------------------------------------------------ Visit semantic functions---------------------------------------------------------------------------------ATTR Visit [ | | sem_visit : { (StateIdentifier,PP_Doc) } ]-ATTR Visits [ | | sem_visit USE {:} {[]} : { [(StateIdentifier,PP_Doc)] } ]--SEM Visit | Visit- loc.o_sigs = typeSigs @lhs.options- lhs.sem_visit = ( @from- , let resTp = @loc.t_params >#< @loc.nameTOut_visit- argTp = @loc.t_params >#< @loc.nameTIn_visit- argMatch = ppRecordVal [ nm_inarg i @lhs.nt @ident >#< "=" >#< lhsname @lhs.options True i | i <- Set.toList @inh ]- in ppFunDecl @loc.o_sigs (nm_visit @ident) [(argMatch, argTp)] resTp @steps.sem_steps- )-- steps.follow = @loc.nextStBuild >-< @loc.resultval-- loc.nextArgsMp = maybe Map.empty id $ Map.lookup @to @lhs.allintramap- loc.nextArgs = ppSpaced $ Map.keys $ @loc.nextArgsMp- loc.nextStExp = nm_st @to >#< @loc.nextArgs >#< dummyArg @lhs.options (Map.null @loc.nextArgsMp)-- loc.resultval = ppRecordVal- ( [ nm_outarg i @lhs.nt @ident >#< "=" >#< lhsname @lhs.options False i | i <- Set.toList @syn ]- ++ [ @loc.nextStRefExp ])-- (loc.nextStBuild, loc.nextStRefExp)- = case @loc.nextVisitInfo of- NoneVis -> (empty, empty)- _ -> ( "let" >#< nextStName >#< "=" >#< @loc.nextStExp >#< "in"- , nm_outarg_cont @lhs.nt @ident >#< "=" >#< 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---- follow: the code of steps that follows after the VisitStep-ATTR Visits Visit VisitStep VisitSteps [ mrules : {Map Identifier (VisitKind -> Either Error PP_Doc)} | | ]-ATTR VisitStep VisitSteps [ follow : PP_Doc | | sem_steps USE {>-<} {empty} : PP_Doc ]---- continuation flow (passing the right steps as left follow steps)-SEM VisitSteps- | Cons hd.follow = @tl.sem_steps- lhs.sem_steps = @hd.sem_steps- | Nil lhs.sem_steps = @lhs.follow--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 of- Left e -> (Seq.singleton e, empty)- Right stmt -> (Seq.empty, stmt)- lhs.sem_steps = @loc.sem_steps >-< @lhs.follow- | ChildIntro loc.attachItf = Map.findWithDefault (error $ "Child " ++ show @child ++ " not found") @child @lhs.childintros- (lhs.errors,loc.sem_steps,lhs.defs,lhs.uses)- = case @loc.attachItf @lhs.kind of- Left e -> (Seq.singleton e, empty, Set.empty, Map.empty)- Right (code, defs, uses) -> (Seq.empty, code, defs, uses)- lhs.sem_steps = @loc.sem_steps >-< @lhs.follow- | ChildVisit loc.visitItf = Map.findWithDefault (error $ "Visit " ++ show @visit ++ " not found") @visit @lhs.allchildvisit- loc.childType = Map.findWithDefault (error ("type of child " ++ show @child ++ " is not in the childTypes map! " ++ show @lhs.childTypes)) @child @lhs.childTypes- (lhs.errors, lhs.sem_steps) = case @loc.visitItf @child @loc.childType @lhs.kind @lhs.follow of- Left e -> (Seq.singleton e, empty)- Right steps -> (Seq.empty, steps)- | Sim -- simply propagates- | PureGroup -- simply propagates------- 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--- Todo: implement a parallel evaluator-SEM VisitSteps VisitStep [ useParallel : Bool | | ]-SEM Visit | Visit steps.useParallel = False-SEM VisitStep | Sim loc.useParallel = parallelInvoke @lhs.options && @steps.size > 1---- Child introduction-ATTR EChild EChildren- [ | | childintros USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} ]--ATTR Visits Visit VisitSteps VisitStep- [ childintros : {Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} | | ]--SEM EProduction | EProduction- visits.childintros = @children.childintros--SEM EChild- | ETerm lhs.childintros = Map.singleton @name (\_ -> Right (empty, Set.empty, Map.empty))- | EChild lhs.childintros = Map.singleton @name @loc.introcode- loc.isDefor = case @tp of- NT _ _ defor -> defor- _ -> False- loc.valcode = case @kind of- ChildSyntax -> @name >|< "_"- ChildAttr -> -- decide if we need to invoke the sem-function under the hood- let head | not @loc.isDefor = if lateHigherOrderBinding @lhs.options- then lateSemNtLabel @loc.nt >#< lhsname @lhs.options True idLateBindingAttr- else prefix @lhs.options >|< @loc.nt- | otherwise = empty -- no need to intro a terminal- in pp_parens (head >#< instname @name)- ChildReplace _ -> -- the higher-order attribute is actually a function that transforms- -- the semantics of the child (always deforested)- pp_parens (instname @name >#< @name >|< "_")- loc.aroundcode = if @hasAround- then locname @lhs.options @name >|< "_around"- else empty- loc.introcode = \kind -> let pat = text $ stname @name @loc.initSt- attach = pp_parens (@loc.aroundcode >#< @loc.valcode) >|< "." >|< nm_attach @loc.nt >#< "()"- decl = pat >#< "=" >#< attach- in if compatibleAttach kind @loc.nt @lhs.options- then Right ( "let" >#< decl >#< "in"- , 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 @lhs.options True idLateBindingAttr) (Just $ AttrInh _LHS idLateBindingAttr)- ) $- ( if @hasAround- then Map.insert (locname @lhs.options (@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-}---- rules-ATTR ERules ERule [ | | sem_rules USE {>-<} {empty} : {PP_Doc}- mrules USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> Either Error PP_Doc)} ]--SEM ERule | ERule- lhs.sem_rules = if @loc.used == 0- then empty- else @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.declHead- >-< indent ((column @rhs.pos - 2) `max` 2)- ( if @loc.genpragma- then @loc.pragma >-< @rhs.semfunc >-< @loc.endpragma- else @rhs.semfunc- )- >#< "in"- loc.pragma = ppLinePragma @lhs.options (line @rhs.pos) (file @rhs.pos)- loc.endpragma = ppWithLineNr (\ln -> ppLinePragma @lhs.options (ln+1) @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))-- -- Note: we also ensure that all rules are functions, so that they are not made part of any closures- -- but are lambda-lifted instead.- loc.declHead = "let" >#< @name >#< @loc.argPats >#< dummyPat @lhs.options (Map.null @rhs.attrs) >#< "="- loc.argPats- = ppSpaced- [ case mbAttr of- Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) ->- case Map.lookup nm @lhs.localAttrTypes of- Just tp -> pp_parens (strNm >#< ":" >#< ppTp tp)- Nothing -> pp strNm- Just attr | not (noPerStateTypeSigs @lhs.options) ->- case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @lhs.childTypes of- Just tpDoc -> pp_parens (strNm >#< ":" >#< tpDoc)- Nothing -> pp strNm- _ -> pp strNm- | (strNm, mbAttr) <- Map.assocs @rhs.attrs- ]-- loc.argExprs = ppSpaced $ Map.keys @rhs.attrs- loc.stepcode = \kind ->- let mkBind (pat,expr) = "let" >#< pat >#< "=" >#< expr >#< "in"- in if kind `compatibleRule` @pure- then Right $ mkBind (@pattern.sem_lhs, @name >#< @loc.argExprs >#< dummyArg @lhs.options (Map.null @rhs.attrs))- >-< vlist (map mkBind @pattern.extraDefs)- else Left $ IncompatibleRuleKind @name kind-- lhs.mrules = Map.singleton @name @loc.stepcode--ATTR Expression [ | | tks : {[HsToken]} ]-SEM Expression- | Expression lhs.tks = @tks--{-dummyPat :: Options -> Bool -> PP_Doc-dummyPat opts noArgs- | not noArgs = empty- | strictDummyToken opts = text "()"- | otherwise = text "(_ : unit)"--dummyArg :: Options -> Bool -> PP_Doc-dummyArg opts noArgs- | not noArgs = empty- | otherwise = text "()"--dummyType :: Options -> Bool -> PP_Doc-dummyType opts noArgs- | not noArgs = empty- | otherwise = text "unit"-}--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 [ | | extraDefs USE {++} {[]} : {[(PP_Doc,PP_Doc)]} ]--SEM Pattern- | Alias loc.var = text $ attrname @lhs.options False @field @attr- loc.hasTp = isJust @loc.mbTp- loc.o_sigs = typeSigs @lhs.options-- lhs.sem_lhs = ppArg (@loc.hasTp && @loc.o_sigs) @loc.var (maybe (text "?no type?") ppTp @loc.mbTp)- lhs.extraDefs = if @pat.isUnderscore- then []- else [ (@pat.sem_lhs, @loc.var) ]- | Product lhs.sem_lhs = pp_block "(" ")" "," @pats.sem_lhs- | Constr lhs.sem_lhs = pp_parens $ @name >#< pp_block "(" ")" "," @pats.sem_lhs- | Underscore lhs.sem_lhs = text "_"- | Irrefutable lhs.sem_lhs = pp_parens (text "lazy" >#< @pat.sem_lhs)- -- note that the above has the inverse meaning compared to Haskell:- -- the above forces the evaluation of a lazy value. It seems appropriate though.---- 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 @lhs.options False @field @attr) @pat.attrs---- All attribute types of this pattern--- Todo: if possible, make attribute types part of the pattern-ATTR Pattern Patterns [ | | attrTypes USE {>-<} {empty} : {PP_Doc} ]-SEM Pattern | Alias- loc.mbTp = if @field == _LHS- then Map.lookup @attr @lhs.synmap- else if @field == _LOC- then Map.lookup @attr @lhs.localAttrTypes- else Nothing- lhs.attrTypes = maybe empty (\tp -> (attrname @lhs.options False @field @attr) >#< "::" >#< ppTp tp) @loc.mbTp- >-< @pat.attrTypes---- 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 (fieldname @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 @lhs.options True @field @attr) @loc.mbAttr--{-data NonLocalAttr- = AttrInh Identifier Identifier- | AttrSyn Identifier Identifier deriving Show--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) @loc.inhhstoken)) @tks- lhs.semfunc = vlist $ showTokens $ map (\tok -> tok_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks- loc.inhhstoken = Inh_HsToken @lhs.options---- child visit map-ATTR Visit- Visits- EProduction- EProductions- ENonterminal- ENonterminals [ allchildvisit : {Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)}- | | childvisit USE {`Map.union`} {Map.empty} : {Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)} ]--ATTR VisitSteps VisitStep [ allchildvisit : {Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)} | | ]--SEM ExecutionPlan- | ExecutionPlan nonts.allchildvisit = @nonts.childvisit---- code for the invocation of the visit:--- * "follow" is the pretty print of the code that follows this step, and is thus the code that comprises the continuation.--- * the child state contain a field which is the operation to invoke--- * we create a parameter with the inputs to the visit and the continuation--- * the continuation obtains the resulting outputs plus the updated state-SEM Visit | Visit- loc.prevVisitInfo = Map.findWithDefault ManyVis @from @lhs.nextVisits- lhs.childvisit = Map.singleton @ident @loc.invokecode- loc.invokecode- = \chld childTp kind follow -> -- "chld" is the name of the child at the place of invocation, and "kind" the kind of the calling visit- let code = cont >-< inps >-< call-- childNmTo = text $ stname chld @to- childNmFrom = text $ stname chld @from- childTpArgs = case childTp of- NT _ args _ -> args- _ -> error "generate visit call: type of the child is not a nonterminal!"-- -- cont is parameterized with the outputs of the child and brings them in scope- cont = "let" >#< contNm >#< ppArg @loc.o_sigs (ppRecordVal cont_in) cont_in_tp >#< "="- >-< indent 2 follow -- the continuation-code- >#< "in"- cont_in = [ nm_outarg i @lhs.nt @ident >#< "=" >#< attrname @lhs.options True chld i | i <- Set.toList @syn ]- ++ case @loc.nextVisitInfo of- NoneVis -> []- _ -> [ nm_outarg_cont @lhs.nt @ident >#< "=" >#< childNmTo ]- cont_in_tp = ppTypeParams childTpArgs >#< @loc.nameTOut_visit-- -- defines the input records to the visit function- inps = "let" >#< inpsNm >#< "=" >#< ppRecordVal- [ nm_inh @lhs.nt @ident >#< "=" >#< ppRecordVal inps_in- , nm_cont @lhs.nt @ident >#< "=" >#< contNm- ] >#< "in"- inps_in = [ nm_inarg i @lhs.nt @ident >#< "=" >#< attrname @lhs.options False chld i | i <- Set.toList @inh ]-- -- the call to the visit function, with possible the need to specify which visit function to dispatch to- call = childNmFrom >|< "." >|< nm_invoke @lhs.nt @from >#< arg- arg = case @loc.prevVisitInfo of- NoneVis -> error "error: invocation of a visit from a state that has no next visits"- OneVis _ -> pp inpsNm- ManyVis -> pp_parens (con_visit @lhs.nt @ident >#< inpsNm)- in if kind `compatibleKind` @kind- then Right code- else Left $ IncompatibleVisitKind chld @ident kind @kind--{-contNm = text "__cont_"-inpsNm = text "__inps_"---- 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 $ fieldname @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 @lhs.options False i, Just (AttrSyn _LHS i)) | i <- Set.elems @syn ]- in mp1 `Map.union` mp2- loc.inhVarNms = Set.map (lhsname @lhs.options 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 @lhs.options True @child) $ Map.lookup @visit @lhs.avisitdefs- lhs.uses = let convert attrs = Map.fromList [ (attrname @lhs.options 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------------------------------------------------------------------------------------ note: this function produces strings, which are passed to showTokens which--- preserves layout.--- note: this may not be that important for ocaml code in comparison to Haskell-SEM HsTokens [ || tks : {[(Pos,String)]} ]- | Cons lhs.tks = @hd.tok : @tl.tks- | Nil lhs.tks = []--SEM HsToken- | AGLocal loc.tok = (@pos,fieldname @var)--SEM HsToken [ || tok:{(Pos,String)}]- | AGField- loc.addTrace = case @rdesc of- Just d -> \x -> "(prerr_endline " ++ show (d ++ " -> " ++ show @field ++ "." ++ show @attr) ++ "; " ++ x ++ ")"- Nothing -> id- lhs.tok = (@pos, @loc.addTrace $ attrname @lhs.options 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, "")------- 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 Pattern Patterns [ 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
− src-ag/ExecutionPlan2Clean.ag
@@ -1,1684 +0,0 @@-INCLUDE "ExecutionPlan.ag"-INCLUDE "Patterns.ag"-INCLUDE "Expression.ag"-INCLUDE "HsToken.ag"--imports-{-import ExecutionPlan-import Pretty-import PPUtil-import Options-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- textBlocks : PP_Doc- iclModuleHeader : {String -> String -> String -> Bool -> String}- dclModuleHeader : {String -> String -> String -> Bool -> String}- mainFile : String- mainName : String- constructorTypeMap : {Map NontermIdent ConstructorType} | | ]------------------------------------------------------------------------------------ Options---------------------------------------------------------------------------------ATTR ExecutionPlan- ENonterminals ENonterminal- EProductions EProduction- ERules ERule- EChildren EChild- Expression- HsToken HsTokens HsTokensRoot- Pattern Patterns- 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}- output_dcl : {PP_Doc} ]--SEM ExecutionPlan- | ExecutionPlan lhs.output = @nonts.output >-< @loc.commonExtra >-< @loc.wrappersExtra- lhs.output_dcl = @nonts.output_dcl--ATTR ENonterminal ENonterminals [ wrappers : {Set NontermIdent}- | | output USE {>-<} {empty} : {PP_Doc}- output_dcl USE {>-<} {empty} : {PP_Doc}]--SEM ExecutionPlan- | ExecutionPlan nonts.wrappers = @wrappers--SEM ENonterminal- | ENonterminal lhs.output = ("// " ++ getName @nt ++ " " ++ replicate (60 - length (getName @nt)) '-')- >-< (if @loc.hasWrapper- then "// wrapper"- >-< @loc.wr_inh_icl- >-< @loc.wr_syn_icl- >-< @loc.wrapper_icl- >-< ""- else empty)- >-< (if folds @lhs.options- then "// cata"- >-< @loc.sem_nt- >-< ""- else empty)- >-< (if semfuns @lhs.options- then "// semantic domain"- >-< @loc.t_init_icl- >-< @loc.t_states_icl- >-< @loc.k_states- >-< @prods.sem_prod- >-< ""- else empty)- loc.hasWrapper = @nt `Set.member` @lhs.wrappers- - lhs.output_dcl = ("// " ++ 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_dcl- >-< @loc.wr_syn_dcl- >-< @loc.wrapper_dcl- >-< ""- else empty)- >-< (if folds @lhs.options- then "// cata"- >-< @loc.semname >#< "::" >#< @loc.sem_tp- >-< ""- else empty)- >-< (if semfuns @lhs.options- then "// semantic domain"- >-< @loc.t_init_dcl- >-< @loc.t_states_dcl- >-< @prods.t_visits- >-< @prods.sem_prod_tys- >-< ""- else empty)------------------------------------------------------------------------------------ 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 = "::" >#< @loc.classPP >#< @nt >#< @loc.t_params >#< ":=="- loc.datatype = case lookup @nt @lhs.typeSyns of- Nothing -> "::" >#< @loc.classPP >#< @nt >#< @loc.t_params- >-< ( if null @prods.datatype- then empty- else if isRecordConstructor @nt @lhs.constructorTypeMap- then indent 2 $ "=" >#< @prods.recordtype- 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 >#< "Data.Maybe" >#< pp_parens (show t)- Just (Tuple ts) -> @loc.aliasPre >#< pp_parens (ppCommas $ map (show . snd) ts)- Just (Either l r) -> @loc.aliasPre >#< "Data.Either" >#< pp_parens (show l) >#< pp_parens (show r)- Just (Map k v) -> @loc.aliasPre >#< "Data.Map" >#< pp_parens (show k) >#< pp_parens (show v)- Just (IntMap t) -> @loc.aliasPre >#< "Data.IntMap.IntMap" >#< pp_parens (show t)- Just (OrdSet t) -> @loc.aliasPre >#< "Data.Set.Set" >#< pp_parens (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 = "E." >#< ppSpaced ps >#< ":"-}--ATTR EProduction [ | | datatype : {PP_Doc}- recordtype : {PP_Doc} ]-ATTR EProductions [ | | datatype USE {:} {[]} : {[PP_Doc]}- recordtype : {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- lhs.recordtype = @loc.quantPP1 >#< @loc.classPP1- >#< ppConFields True @children.recordtype- loc.classPP1 = ppClasses (classConstrsToDocs @constraints)- loc.quantPP1 = ppQuants @params--SEM EProductions- | Cons lhs.recordtype = @hd.recordtype- | Nil lhs.recordtype = empty--{--- 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}- recordtype : {PP_Doc} ]-ATTR EChildren [ | | datatype USE {:} {[]} : {[PP_Doc]}- recordtype 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.recordfield = @loc.strNm >#< "::" >#< @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-- lhs.recordtype = case @kind of- ChildAttr -> empty -- higher order attributes are not part of the data type- _ -> @loc.recordfield- | ETerm lhs.datatype = @loc.field- lhs.recordtype = @loc.recordfield--{-ppTp :: Type -> PP_Doc-ppTp = text . typeToHaskellString Nothing []-}------------------------------------------------------------------------------------ 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.semname >#< "::" >#< @loc.sem_tp- >-< case lookup @nt @lhs.typeSyns of- Nothing -> @prods.sem_nt- Just (List t) -> @loc.semname >#< "list" >#< "=" >#< "foldr" >#< @loc.semname >|< "_Cons"- >#< @loc.semname >|< "_Nil"- >#< case t of- NT nt _ _ -> pp_parens ("map" >#< @fsemname nt >#< "list")- _ -> pp "list"- Just (Maybe t) -> @loc.semname >#< "'Data.Maybe'.Nothing" >#< "=" >#< @loc.semname >|< "_Nothing"- >-< @loc.semname >#< pp_parens ("'Data.Maybe'.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 >#< "('Data.Either'.Left left)" >#< "=" >#< @loc.semname >|< "_Left" >#< @frecarg l "left"- >-< @loc.semname >#< "('Data.Either'.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" >#< "=" >#< "foldr" >#< @loc.semname >|< "_Entry"- >#< @loc.semname >|< "_Nil"- >#< pp_parens (- ( case t of- NT nt _ _ -> pp_parens ("map" >#< @fsemname nt)- _ -> empty- ) >#< pp_parens ("'Data.IntSet'.elems" >#< "s")- )- Just IntSet -> @loc.semname >#< "s" >#< "=" >#< "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---- 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 = let lhs = "sem_" >|< @lhs.nt- rhs = "=" >#< "sem_" >|< @lhs.nt >|< "_" >|< @con >#< ppSpaced @children.argnamesw- cnnm = conname @lhs.rename @lhs.nt @con- in if isRecordConstructor @lhs.nt @lhs.constructorTypeMap- then lhs >#< "{" >#< cnnm >#< "|" >#<- pp_block "" "" "," (zipWith (\l r -> l >#< "=" >#< r) @children.recfields @children.argpats) >#< "}" >#< rhs- else lhs >#< "(" >#< cnnm >#< ppSpaced @children.argpats >#< ")" >#< rhs--{-isRecordConstructor :: NontermIdent -> Map NontermIdent ConstructorType -> Bool-isRecordConstructor nt ctm = Map.lookup nt ctm == Just RecordConstructor-}--ATTR EChild [ | | argnamesw : { PP_Doc } ]-ATTR EChildren [ | | argnamesw USE {:} {[]} : {[PP_Doc]} ]--SEM EChild- | EChild lhs.argnamesw = case @kind of- ChildSyntax -> "(" >#< "sem_" >|< @loc.nt >#< @name >|< "_" >#< ")"- ChildAttr -> empty -- no sem-case for a higher-order child- ChildReplace tp -> "(" >#< "sem_" >|< extractNonterminal tp >#< @name >|< "_" >#< ")"- | ETerm lhs.argnamesw = text $ fieldname @name------------------------------------------------------------------------------------ Types of attributes---------------------------------------------------------------------------------ATTR ExecutionPlan- ENonterminals- ENonterminal [ inhmap : {Map NontermIdent Attributes}- synmap : {Map NontermIdent Attributes} | | ]--ATTR EProductions EProduction- ERules ERule- Patterns Pattern- 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.lt_type = "t_" >|< @nt- loc.t_params = ppSpaced @params- loc.t_init_icl = @loc.t_init_dcl >-<- "attach_" >|< @loc.t_type >#< pp_parens (@loc.t_type >#< @loc.lt_type) >#< "=" >#< @loc.lt_type- loc.t_init_dcl = "::" >#< @loc.t_type >#< @loc.t_params >#< "=" >#< @loc.t_type- >#<- pp_parens (- ppMonadType @lhs.options >#< pp_parens (@loc.t_type >|< "_s" >|< @initial >#< @loc.t_params))- loc.t_states_icl = vlist $ map (\st ->- let nt_st = @nt >|< "_s" >|< st- c_st = "C_" >|< nt_st- inv_st = "inv_" >|< nt_st- nextVisit = Map.findWithDefault ManyVis st @nextVisits- in case nextVisit of- NoneVis -> empty -- empty semantics- OneVis vId -> inv_st >#< pp_parens (c_st >#< "x") >#< "=" >#< "x"- ManyVis -> empty- ) $ Set.toList @loc.allstates- loc.t_states_dcl = 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 -> "::" >#< t_st >#< @loc.t_params >#< "=" >#< c_st -- empty semantics- OneVis vId -> "::" >#< t_st >#< @loc.t_params >#< "=" >#< c_st >#< (pp_parens (conNmTVisit @nt vId >#< @loc.t_params))- ManyVis -> "::" >#< t_st >#< @loc.t_params >#< "where" >#< c_st >#< "::" -- TODO : Cleanify- >#< (pp_braces $ inv_st >#< "::" >#< "!" >|< pp_parens ("E.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 = "::" >#< 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 = "::" >#< @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)- >-< "::" >#< @loc.nameTIn_visit >#< @loc.t_params >#< "=" >#< @loc.nameTIn_visit >#<- @loc.inhpart- >-< "::" >#< @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_icl = @loc.genwrap_icl "Inh" @loc.wr_inhs- loc.wr_syn_icl = @loc.genwrap_icl "Syn" @loc.wr_syns- loc.genwrap_icl = \nm attr ->- let tyConName = nm >|< "_" >|< @nt- in (let (d, _, _) = foldr (\(i, t) (d, c, n) -> (d >-<- i >|< "_" >|< tyConName >#< "::" >#< tyConName >#< "->" >#< (@loc.addbang $ pp_parens $ typeToHaskellString (Just @nt) [] t)- >-< i >|< "_" >|< tyConName >#< pp_parens (tyConName >#< unwords (replicate (n - c - 1) "_" ++ ["x"] ++ replicate c "_")) >#< "= x"- , c + 1, n)- ) (empty, 0, length attr) attr- in d)- loc.wr_inh_dcl = @loc.genwrap_dcl "Inh" @loc.wr_inhs- loc.wr_syn_dcl = @loc.genwrap_dcl "Syn" @loc.wr_syns- loc.genwrap_dcl = \nm attr ->- let tyConName = nm >|< "_" >|< @nt- in "::" >#< tyConName >#< @loc.t_params >#< "=" >#< tyConName -- >#< "{"- >#< (ppSpaced $ map (\(_,t) -> @loc.addbang $ pp_parens $ typeToHaskellString (Just @nt) [] t) attr) -- >#< "}"- >-<- (let (d, _, _) = foldr (\(i, t) (d, c, n) -> (d >-<- i >|< "_" >|< tyConName >#< "::" >#< tyConName >#< "->" >#< (@loc.addbang $ pp_parens $ typeToHaskellString (Just @nt) [] t)- , c + 1, n)- ) (empty, 0, length attr) attr- in d)- 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 lateHigherOrderBinding @lhs.options- then Map.delete idLateBindingAttr- else id- loc.wr_syns = Map.toList $ fromJust $ Map.lookup @nt @lhs.synmap- loc.inhlist = map (lhsname @lhs.options True . fst) @loc.wr_inhs- loc.inhlist1 = map (lhsname @lhs.options True . fst) @loc.wr_inhs1- loc.synlist = map (lhsname @lhs.options 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_icl = (@loc.wrapname >#< "::" >#< @loc.quantPP >#< @loc.classPP >#< @loc.t_type >#< @loc.t_params -- TODO : Remove ? >#< "->"- >#< @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- [] -> text @loc.synname -- TODO : Remove? >#< " { }"- (initv:_) -> -- TODO: take care of multiple visits- 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 "lift"- VisitMonadic -> empty- _ -> empty- unMonad | monadicWrappers @lhs.options = empty- | otherwise = unMon @lhs.options- in unMonad >#< "("- >-< indent 2- ("act >>= \\" >#< @loc.addbang (pp "sem") >#< "->" -- run the per-node monadic code to get the initial state (of the root)- >-< "lift" >#< pp_parens arg >#< ">>= \\" >#< @loc.addbangWrap (pp "arg") >#< "->"- >-< convert >#< pp_parens ("inv_" >|< @nt >|< "_s" >|< @initial >#< "sem" >#< ind >#< "arg" >#< extra) >#< ">>= \\" >#< pat >#< "->" -- invoke initial state (of the root)- >-< "lift" >#< pp_parens (@loc.synname >#< ppSpaced @loc.synlist)- )- >-< ")" )- >-< if lateHigherOrderBinding @lhs.options- then indent 2 ("where" >#< lhsname @lhs.options True idLateBindingAttr >#< "=" >#< lateBindingFieldNm @lhs.mainName)- else empty- loc.wrapper_dcl = (@loc.wrapname >#< "::" >#< @loc.quantPP >#< @loc.classPP >#< @loc.t_type >#< @loc.t_params -- TODO : Remove ? >#< "->"- >#< @loc.inhname >#< @loc.t_params >#< "->" >#< ( if monadicWrappers @lhs.options then ppMonadType @lhs.options else empty) >#< pp_parens (@loc.synname >#< @loc.t_params))------------------------------------------------------------------------------------ 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 lateHigherOrderBinding @lhs.options- then @loc.lateSemBndDef- else empty- loc.commonExtra = if lateHigherOrderBinding @lhs.options- then @loc.lateSemBndTp- else empty- loc.lateSemBndTp = "::" >#< lateBindingTypeNm @lhs.mainName >#< "=" >#< lateBindingTypeNm @lhs.mainName- >-< (indent 2 $ pp_block "{" "}" "," $ toList @nonts.semFunBndTps)- loc.lateSemBndDef = 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}- sem_prod_tys : {PP_Doc} ]-ATTR EProductions [ | | sem_prod USE {>-<} {empty} : {PP_Doc}- sem_prod_tys 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 }- recfields USE {++} {[]} : { [Identifier] }]-ATTR EChildren [ | | argtps USE {:} {[]} : { [PP_Doc] }- argpats USE {:} {[]} : { [PP_Doc] }- recfields USE {++} {[]} : { [Identifier] }]--SEM EChild- | EChild lhs.argtps = case @kind of- ChildSyntax -> pp_parens $ ppDefor @tp -- TODO Remove? >#< "->"- ChildReplace tp -> pp_parens $ ppDefor tp -- TODO Remove? >#< "->"- _ -> empty -- higher order attribute- loc.argpats = case @kind of- ChildSyntax -> @name >|< "_" -- no strictification of children semantics to allow infinite trees- ChildReplace _ -> @name >|< "_"- _ -> empty- - lhs.recfields = case @kind of- ChildSyntax -> [@name] -- no strictification of children semantics to allow infinite trees- ChildReplace _ -> [@name]- _ -> []- - -- | ETerm lhs.argtps = (pp_parens $ show @tp) >#< "572->" -- TODO Remove?- | ETerm lhs.argtps = pp_parens $ show @tp- loc.argpats = @loc.addbang $ text $ fieldname @name -- terminals may be strict (perhaps this should become an option)- lhs.recfields = [@name]--{-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.usedArgs = @children.usedArgs `Set.union` @visits.usedArgs `Set.union` @rules.usedArgs- -- A bit ugly, but this code renames arguments and puts an underscore when the argument- -- is never used. This avoids compiler warnings of unused variables.- loc.args = map (\x -> let (name,arg) = case show x of - "" -> ("", empty)- '!':name -> ("arg_" ++ name, "!arg_" >|< name)- name -> ("arg_" ++ name, "arg_" >|< name)- in if null name || name `Set.member` @loc.usedArgs- then arg- else text "_") @children.argpats- loc.semname = "sem_" ++ show @lhs.nt ++ "_" ++ show @con- loc.sem_tp = @loc.quantPP2 >#< @loc.classPP2 >#< ppSpaced @children.argtps- >#< (if length @children.argtps > 0 then "->" else "")- >#< @loc.t_type >#< @loc.t_params -- TODO Keep -> here?- loc.classPP2 = ppClasses (classCtxsToDocs @lhs.classCtxs ++ classConstrsToDocs @constraints)- loc.quantPP2 = ppQuants (@lhs.params ++ @params)- - lhs.sem_prod_tys = @loc.semname >#< " ::" >#< @loc.sem_tp- - loc.sem_prod = @loc.semname >#< " ::" >#< @loc.sem_tp- >-< @loc.mkSemBody (@loc.semname >#< ppSpaced @loc.args >#< "=" >#< @loc.t_type)- @loc.mbInitializer @loc.outerlet ("lift" >#< "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" -- TODO: desugar- >-< 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.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 = 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 >#< "->"- )-- 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 "k" >|< st >#< "::" >#< "K_" >|< @lhs.nt >|< "_s" >|< st >#< @loc.t_params >#< "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- >-< indent (length (show prefix))- ("let"- >-< indent 4 defs- >-< "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- , \_ ->- -- TODO: Generate type signature "v" >|< @ident >#< "::" >#< @loc.nameTIn_visit >#< "->" >#< @loc.nameT_visit >#< @loc.t_params >-< -- -- Haskell: generate a lambda here as well instead of a function definition- -- >-< "v" >|< @ident >#< "=" >#< "\\" >#< (@loc.addbang $ pp_parens (@loc.nameTIn_visit >#< @loc.inhpats))- -- Clean: generate a function- "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- )- -- >#< "->"- -- >#< "("- >-< indent 10 (@loc.stepsInitial- >-< indent 4 @steps.sem_steps) >-< indent 10 @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 -> indent 4 decls- >-< "in" >#< resultValName- VisitPure True -> "let" >#< decls- >-< indent 1 ("in" >#< resultValName)- VisitMonadic -> "let" >#< decls- >-< "lift" >#< resultValName- loc.vname = "v" >|< @ident- loc.inhpats = ppSpaced $ map (\arg -> pp $ attrname @lhs.options True _LHS arg) $ Set.toList @inh- loc.inhargs = \chn -> ppSpaced $ map (attrname @lhs.options False chn) $ Set.toList @inh- loc.synargs = ppSpaced $ map (\arg -> attrname @lhs.options 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 = "ag__result_"--nextStName :: String-nextStName = "ag__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)-- lhs.sem_steps = let decl = case @lhs.kind of- VisitPure _ -> @loc.patPP >#< "=" >#< @loc.exprPP- VisitMonadic -> @loc.exprPP >#< ">>= \\" >#< @loc.patPP >#< "->"- in fmtDecl False @lhs.fmtMode decl- loc.convToMonad = case @loc.callKind of- VisitPure _ -> text "lift"- VisitMonadic -> empty- loc.callKind = Map.findWithDefault (error "visit kind should be in the map") @visit @lhs.allVisitKinds- | Sim lhs.sem_steps = @steps.sem_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---- 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 >#< "in"- | otherwise -> pp decl-}------- Some properties of VisitStep(s)------- Used arguments-ATTR VisitSteps VisitStep Visit Visits EChild EChildren ERule ERules [ | | usedArgs USE {`Set.union`} {Set.empty} : {Set String} ]-SEM ERule- | ERule +usedArgs = Set.union $ Map.keysSet $ Map.mapKeys (\a -> "arg_" ++ a) $ Map.filter isNothing @rhs.attrs--SEM EChild- | EChild +usedArgs = \s -> case @kind of- ChildSyntax -> Set.insert ("arg_" ++ show @name ++ "_") s- _ -> 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---- 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--SEM VisitStep | Sim- 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- | ETerm lhs.childintros = Map.singleton @name (\_ _ -> Right (empty, Set.empty, Map.empty))- | EChild lhs.childintros = Map.singleton @name @loc.introcode- loc.isDefor = case @tp of- NT _ _ defor -> defor- _ -> False- loc.valcode = case @kind of- ChildSyntax -> "arg_" >|< @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 @lhs.options 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 >#< @name >|< "_")- loc.aroundcode = if @hasAround- then locname @lhs.options @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 -> attach >#< ">>= \\" >#< patStrict >#< "->"- 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 @lhs.options True idLateBindingAttr) (Just $ AttrInh _LHS idLateBindingAttr)- ) $- ( if @hasAround- then Map.insert (locname @lhs.options (@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 = "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.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- >-< indent ((column @rhs.pos - 2) `max` 2)- ( if @loc.genpragma- then @loc.pragma >-< @rhs.semfunc >-< @loc.endpragma- else @rhs.semfunc- )- 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))-- -- This comment describes the Haskell rationale for lambdas- -- 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) >#< "->"- - -- For Clean, we do not want to generate lambdas, but functions 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) -- TODO Remove? >#< "::" >#< 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) -- TODO Remove? >#< "::" >#< tpDoc)- Nothing -> match- _ -> match- | (str,mbAttr) <- Map.assocs @rhs.attrs- ]- loc.argExprs = ppSpaced [ case mbAttr of- Nothing -> "arg_" >|< str- _ -> text str- | (str,mbAttr) <- Map.assocs @rhs.attrs- ]- loc.stepcode = \kind fmtMode -> if kind `compatibleRule` @pure- then Right $ let oper | @pure = "="- | otherwise = "<-" -- TODO Desugar- decl = @pattern.sem_lhs >#< oper >#< @name >#< @loc.argExprs >#< dummyArg @lhs.options (Map.null @rhs.attrs)- tp = if @pure && not (noPerRuleTypeSigs @lhs.options)- then @pattern.attrTypes- else empty- in fmtDecl @pure fmtMode (tp >-< decl)- else Left $ IncompatibleRuleKind @name kind-- lhs.mrules = Map.singleton @name @loc.stepcode--ATTR Expression [ | | tks : {[HsToken]} ]-SEM Expression- | Expression lhs.tks = @tks--{-dummyPat :: Options -> Bool -> PP_Doc-dummyPat opts noArgs- | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples- | tupleAsDummyToken opts = if strictDummyToken opts- then text "Void"- 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 "Void"- | otherwise = text "GHC.Prim.realWorld#"--dummyType :: Options -> Bool -> PP_Doc-dummyType opts noArgs- | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples- | tupleAsDummyToken opts = text "Void"- | 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 @lhs.options 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 @lhs.options False @field @attr) @pat.attrs---- All attribute types of this pattern-ATTR Pattern Patterns [ | | attrTypes USE {>-<} {empty} : {PP_Doc} ]-SEM Pattern | Alias- loc.mbTp = if @field == _LHS- then Map.lookup @attr @lhs.synmap- else if @field == _LOC- then Map.lookup @attr @lhs.localAttrTypes- else Nothing- lhs.attrTypes = empty -- Don't generate these type signatures; increases performance in Clean- -- maybe empty (\tp -> (attrname @lhs.options False @field @attr) >#< "::" >#< ppTp tp) @loc.mbTp- -- >-< @pat.attrTypes---- 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 (fieldname @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 @lhs.options True @field @attr) @loc.mbAttr--{-data NonLocalAttr- = AttrInh Identifier Identifier- | AttrSyn Identifier Identifier deriving Show--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) @loc.inhhstoken)) @tks- lhs.semfunc = vlist $ showTokens $ map (\tok -> tok_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks- loc.inhhstoken = Inh_HsToken @lhs.options---- 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 @lhs.options 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 _) -> "lift" >#< 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 $ fieldname @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 @lhs.options False i, Just (AttrSyn _LHS i)) | i <- Set.elems @syn ]- in mp1 `Map.union` mp2- loc.inhVarNms = Set.map (lhsname @lhs.options 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 @lhs.options True @child) $ Map.lookup @visit @lhs.avisitdefs- lhs.uses = let convert attrs = Map.fromList [ (attrname @lhs.options 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,fieldname @var)--SEM HsToken [ || tok:{(Pos,String)}]- | AGField- loc.addTrace = case @rdesc of- Just d -> \x -> "(trace_n " ++ show (d ++ " -> " ++ show @field ++ "." ++ show @attr) ++ " (" ++ x ++ "))"- Nothing -> id- lhs.tok = (@pos, @loc.addTrace $ attrname @lhs.options 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 = pp "import qualified Control.Monad.Identity"- loc.genMainModule = writeModule @loc.mainModuleFile- ( [ pp $ @lhs.iclModuleHeader @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 $ @lhs.iclModuleHeader @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_icl- >-< @loc.wr_syn_icl- >-< @loc.wrapper_icl- else empty)- >-< @loc.sem_nt- lhs.appendCommon = (if dataTypes @lhs.options then @loc.datatype else empty)- >-< @loc.t_init_icl- >-< @loc.t_states_icl- >-< @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 = pp "import qualified Control.Monad.Identity"- lhs.genProdIO = writeModule @loc.outputfile- [ pp $ @lhs.iclModuleHeader @lhs.mainName @loc.suffix @loc.semname True- , @lhs.importBlocks- , @loc.ppMonadImports- , 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--cleanIclModuleHeader :: Options -> String -> String-cleanIclModuleHeader flags input- = case moduleName flags- of Name nm -> genMod nm- Default -> genMod (defaultModuleName input)- NoName -> ""- where genMod x = "implementation module " ++ x --cleanDclModuleHeader :: Options -> String -> Maybe String -> String-cleanDclModuleHeader flags input export- = case moduleName flags- of Name nm -> genMod nm- Default -> genMod (defaultModuleName input)- NoName -> ""- where genMod x = "definition module " ++ x ++ genExp export x- genExp Nothing _ = ""- genExp (Just e) x = "(module " ++ x ++ ", module " ++ e ++ ")"--defaultModuleName :: String -> String-defaultModuleName = dropExtension--mkIclModuleHeader :: Maybe (String,String,String) -> String -> String -> String -> Bool -> String-mkIclModuleHeader Nothing defaultName suffix _ _- = "implementation module " ++ defaultName ++ suffix-mkIclModuleHeader (Just (name, exports, imports)) _ suffix addExports replaceExports- = "implementation module " ++ name ++ suffix ++ "\n" ++ imports ++ "\n"--mkDclModuleHeader :: Maybe (String,String,String) -> String -> String -> String -> Bool -> String-mkDclModuleHeader Nothing defaultName suffix _ _- = "definition module " ++ defaultName ++ suffix-mkDclModuleHeader (Just (name, exports, _)) _ suffix addExports replaceExports- = "definition module " ++ name ++ suffix ++ ex ++ "\n"- where- ex = if null exports || (replaceExports && null addExports)- then ""- else if null addExports- then exports- else if replaceExports- then addExports- else exports ++ "," ++ addExports-}-------- 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 = id --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 Pattern Patterns [ 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-
− src-ag/ExecutionPlan2Hs.ag
@@ -1,1711 +0,0 @@-INCLUDE "ExecutionPlan.ag"-INCLUDE "Patterns.ag"-INCLUDE "Expression.ag"-INCLUDE "HsToken.ag"--imports-{-import ExecutionPlan-import Pretty-import PPUtil-import Options-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- EChildren EChild- Expression- HsToken HsTokens HsTokensRoot- Pattern Patterns- 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" >#< pp_parens (show t)- Just (Tuple ts) -> @loc.aliasPre >#< pp_parens (ppCommas $ map (show . snd) ts)- Just (Either l r) -> @loc.aliasPre >#< "Either" >#< pp_parens (show l) >#< pp_parens (show r)- Just (Map k v) -> @loc.aliasPre >#< "Data.Map" >#< pp_parens (show k) >#< pp_parens (show v)- Just (IntMap t) -> @loc.aliasPre >#< "Data.IntMap.IntMap" >#< pp_parens (show t)- Just (OrdSet t) -> @loc.aliasPre >#< "Data.Set.Set" >#< pp_parens (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 "{" "}" ", " $ filter (not . isEmpty) 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 = text . typeToHaskellString Nothing []-}------------------------------------------------------------------------------------ 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 >#< @name >|< "_" >#< ")"- ChildAttr -> empty -- no sem-case for a higher-order child- ChildReplace tp -> "(" >#< "sem_" >|< extractNonterminal tp >#< @name >|< "_" >#< ")"- | ETerm lhs.argnamesw = text $ fieldname @name------------------------------------------------------------------------------------ Types of attributes---------------------------------------------------------------------------------ATTR ExecutionPlan- ENonterminals- ENonterminal [ inhmap : {Map NontermIdent Attributes}- synmap : {Map NontermIdent Attributes} | | ]--ATTR EProductions EProduction- ERules ERule- Patterns Pattern- 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 lateHigherOrderBinding @lhs.options- then Map.delete idLateBindingAttr- else id- loc.wr_syns = Map.toList $ fromJust $ Map.lookup @nt @lhs.synmap- loc.inhlist = map (lhsname @lhs.options True . fst) @loc.wr_inhs- loc.inhlist1 = map (lhsname @lhs.options True . fst) @loc.wr_inhs1- loc.synlist = map (lhsname @lhs.options 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- [] -> @loc.synname >#< " { }"- initvs@(initv:_) ->- let extra = if dummyTokenVisit @lhs.options- then pp $ dummyArg @lhs.options True- else empty- unMonad | monadicWrappers @lhs.options = empty- | otherwise = unMon @lhs.options- genSteps _ [] = []- genSteps curst (curv:nextvs) = setarg : dovis : genSteps nextst nextvs where- inCon = conNmTVisitIn @nt curv- outCon = conNmTVisitOut @nt curv- pat = @loc.addbang $ pp_parens $ pat0- pat0 = outCon >#< ppSpaced (map (lhsname @lhs.options False) syns) >#< cont- cont | null nextvs = empty- | otherwise = pp "sem"- inhs = Set.toList $ Map.findWithDefault Set.empty curv @prods.visituses- syns = Set.toList $ Map.findWithDefault Set.empty curv @prods.visitdefs- arg = inCon >#< ppSpaced (map (lhsname @lhs.options True) inhs)- setarg = "let" >#< @loc.addbangWrap (pp "arg" >|< curv) >#< "=" >#< arg- ind = case Map.findWithDefault ManyVis curst @nextVisits of- NoneVis -> error "wrapper: initial state should have a next visit but it has none"- OneVis _ -> empty- ManyVis -> @loc.k_type >|< "_v" >|< initv- nextst = curst + 1 -- This is not correct, but works both for KW and AOAG- -- Should be lookup up based on visit- convert = case Map.lookup curv @lhs.allVisitKinds of- Just kind -> case kind of- VisitPure _ -> text "return"- VisitMonadic -> empty- dovis = pat >#< "<-" >#< convert >#< pp_parens - ("inv_" >|< @nt >|< "_s" >|< curst >#< "sem" >#< ind - >#< "arg" >|< curv >#< extra)- in unMonad >#< "("- >-< indent 2 (- "do" >#< ( @loc.addbang (pp "sem") >#< "<-" >#< "act" -- run the per-node monadic code to get the initial state (of the root)- >-< vlist (genSteps @initial initvs)- >-< "return" >#< pp_parens (@loc.synname >#< ppSpaced @loc.synlist)- )- )- >-< ")" )- >-< if lateHigherOrderBinding @lhs.options- then indent 2 ("where" >#< lhsname @lhs.options 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 lateHigherOrderBinding @lhs.options- then @loc.lateSemBndDef- else empty- loc.commonExtra = if 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 -> @name >|< "_" -- no strictification of children semantics to allow infinite trees- ChildReplace _ -> @name >|< "_"- _ -> empty- | ETerm lhs.argtps = (pp_parens $ show @tp) >#< "->"- loc.argpats = @loc.addbang $ text $ fieldname @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.usedArgs = @children.usedArgs `Set.union` @visits.usedArgs `Set.union` @rules.usedArgs- -- A bit ugly, but this code renames arguments and puts an underscore when the argument- -- is never used. This avoids compiler warnings of unused variables.- loc.args = map (\x -> let (name,arg) = case show x of - "" -> ("", empty)- '!':name -> ("arg_" ++ name, "!arg_" >|< name)- name -> ("arg_" ++ name, "arg_" >|< name)- in if null name || name `Set.member` @loc.usedArgs- then arg- else text "_") @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 >#< @loc.t_params >#< "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 @lhs.options True _LHS arg) $ Set.toList @inh- loc.inhargs = \chn -> ppSpaced $ map (attrname @lhs.options False chn) $ Set.toList @inh- loc.synargs = ppSpaced $ map (\arg -> attrname @lhs.options 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)------- Used arguments-ATTR VisitSteps VisitStep Visit Visits EChild EChildren ERule ERules [ | | usedArgs USE {`Set.union`} {Set.empty} : {Set String} ]-SEM ERule- | ERule +usedArgs = Set.union $ Map.keysSet $ Map.mapKeys (\a -> "arg_" ++ a) $ Map.filter isNothing @rhs.attrs--SEM EChild- | EChild +usedArgs = \s -> case @kind of- ChildSyntax -> Set.insert ("arg_" ++ show @name ++ "_") s- _ -> 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- | ETerm lhs.childintros = Map.singleton @name (\_ _ -> Right (empty, Set.empty, Map.empty))- | EChild lhs.childintros = Map.singleton @name @loc.introcode- loc.isDefor = case @tp of- NT _ _ defor -> defor- _ -> False- loc.valcode = case @kind of- ChildSyntax -> "arg_" >|< @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 @lhs.options 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 >#< @name >|< "_")- loc.aroundcode = if @hasAround- then locname @lhs.options @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 @lhs.options True idLateBindingAttr) (Just $ AttrInh _LHS idLateBindingAttr)- ) $- ( if @hasAround- then Map.insert (locname @lhs.options (@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 [ case mbAttr of- Nothing -> "arg_" >|< str- _ -> text str- | (str,mbAttr) <- Map.assocs @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)- tp = if @pure && not (noPerRuleTypeSigs @lhs.options)- then @pattern.attrTypes- else empty- in fmtDecl @pure fmtMode (tp >-< decl)- else Left $ IncompatibleRuleKind @name kind-- lhs.mrules = Map.singleton @name @loc.stepcode--ATTR Expression [ | | tks : {[HsToken]} ]-SEM Expression- | Expression lhs.tks = @tks--{-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 @lhs.options 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 @lhs.options False @field @attr) @pat.attrs---- All attribute types of this pattern-ATTR Pattern Patterns [ | | attrTypes USE {>-<} {empty} : {PP_Doc} ]-SEM Pattern | Alias- loc.mbTp = if @field == _LHS- then Map.lookup @attr @lhs.synmap- else if @field == _LOC- then Map.lookup @attr @lhs.localAttrTypes- else Nothing- lhs.attrTypes = maybe empty (\tp -> (attrname @lhs.options False @field @attr) >#< "::" >#< ppTp tp) @loc.mbTp- >-< @pat.attrTypes---- 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 (fieldname @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 @lhs.options True @field @attr) @loc.mbAttr--{-data NonLocalAttr- = AttrInh Identifier Identifier- | AttrSyn Identifier Identifier deriving Show--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) @loc.inhhstoken)) @tks- lhs.semfunc = vlist $ showTokens $ map (\tok -> tok_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks- loc.inhhstoken = Inh_HsToken @lhs.options---- 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 @lhs.options 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 $ fieldname @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 @lhs.options False i, Just (AttrSyn _LHS i)) | i <- Set.elems @syn ]- in mp1 `Map.union` mp2- loc.inhVarNms = Set.map (lhsname @lhs.options 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 @lhs.options True @child) $ Map.lookup @visit @lhs.avisitdefs- lhs.uses = let convert attrs = Map.fromList [ (attrname @lhs.options 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,fieldname @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 @lhs.options 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 Rank2Types, GADTs #-}" -- the common module only needs GADTs and Rank2Types- , 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 = id --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 Pattern Patterns [ 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/Expression.ag
@@ -1,12 +0,0 @@-imports-{-import UU.Scanner.Position(Pos)-import HsToken-}--DATA Expression- | Expression pos:{Pos}- tks:{[HsToken]}--SET AllExpression- = Expression
− src-ag/GenerateCode.ag
@@ -1,1187 +0,0 @@-PRAGMA strictwrap-PRAGMA strictdata--INCLUDE "CodeSyntax.ag"-INCLUDE "Patterns.ag"-INCLUDE "DeclBlocks.ag"--imports-{-import CommonTypes-import SequentialTypes-import Code hiding (Type)-import qualified Code-import Options-import CodeSyntax-import ErrorMessages-import GrammarInfo-import DeclBlocks--import qualified Data.Map as Map-import Data.Map(Map)-import qualified Data.Set as Set-import Data.Set(Set)-import qualified Data.Sequence as Seq-import Data.Sequence(Seq)-import UU.Scanner.Position-import TokenDef-import HsToken-import HsTokenScanner--import Data.List(partition,intersperse)-import Data.Maybe(fromJust,isJust)--}------------------------------------------------------------------------------------- Options----------------------------------------------------------------------------------ATTR CNonterminals CNonterminal- CProductions CProduction- CVisits CVisit- Sequence CRule- CInterface CSegments CSegment- [ o_unbox,o_sig,o_sem,o_newtypes,o_case,o_pretty,o_rename,o_cata,o_strictwrap,o_splitsems,o_traces,o_costcentre,o_linePragmas,o_monadic,o_clean : Bool- o_data : {Maybe Bool}- prefix : String- options : Options- | | ]-SEM CGrammar [ options : Options | | ]- | CGrammar nonts.o_sig = typeSigs @lhs.options- .o_cata = folds @lhs.options- .o_sem = semfuns @lhs.options- .o_newtypes = newtypes @lhs.options- .o_unbox = unbox @lhs.options- .o_case = cases @lhs.options- .o_pretty = attrInfo @lhs.options- .o_rename = rename @lhs.options- .o_strictwrap = strictWrap @lhs.options- .o_splitsems = splitSems @lhs.options- .o_data = if dataTypes @lhs.options then Just (strictData @lhs.options) else Nothing- .prefix = prefix @lhs.options- .o_traces = genTraces @lhs.options- .o_costcentre = genCostCentres @lhs.options- .o_linePragmas = genLinePragmas @lhs.options- .o_monadic = monadic @lhs.options- .o_clean = clean @lhs.options--SEM CGrammar | CGrammar- loc.options = @lhs.options { breadthFirst = breadthFirst @lhs.options && visit @lhs.options && cases @lhs.options && @multivisit }--ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit [ allPragmas : PragmaMap | | ]--SEM CGrammar- | CGrammar nonts.allPragmas = @pragmas------------------------------------------------------------------------------------ Passing information about nonterminal and constructor down----------------------------------------------------------------------------------ATTR CProductions CProduction CVisits- CVisit Sequence CRule CInterface- CSegments CSegment [ nt:NontermIdent inh,syn:Attributes | | ]-SEM CNonterminal- | CNonterminal inter.(inh,syn,nt) = (@inh,@syn,@nt)- prods.(inh,syn,nt) = (@inh,@syn,@nt)--ATTR CVisits CVisit Sequence CRule [ con:ConstructorIdent- terminals : {[Identifier]} | | ]-SEM CProduction- | CProduction visits.con = @con- visits.terminals = @terminals--ATTR CNonterminals CNonterminal CSegments CSegment CInterface CProductions CProduction CVisits CVisit Sequence CRule [ paramMap : ParamMap | | ]--SEM CGrammar- | CGrammar nonts.paramMap = @paramMap---ATTR CVisits CVisit Sequence CRule [ paramInstMap : {Map Identifier (NontermIdent, [String])} | | ]--SEM CProduction- | CProduction- loc.paramInstMap = Map.fromList [(nm, (extractNonterminal tp, tps)) | (nm,tp,_) <- @children, let tps = map (cleanupArg @lhs.options) $ nontermArgs tp, not (null tps) ]--{--- remove possible @v references in the types of a data type.-cleanupArg :: Options -> String -> String-cleanupArg opts s- = case idEvalType opts (SimpleType s) of- SimpleType s' -> s'- _ -> error "Only SimpleType supported"-}--ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit [ contextMap : {ContextMap} quantMap : QuantMap | | ]--SEM CGrammar- | CGrammar- nonts.contextMap = @contextMap- nonts.quantMap = @quantMap--{-appContext :: ContextMap -> NontermIdent -> Code.Type -> Code.Type-appContext mp nt tp- = maybe tp (\ctx -> CtxApp (map (\(n,ns) -> (getName n, ns)) ctx) tp) $ Map.lookup nt mp--appQuant :: QuantMap -> NontermIdent -> Code.Type -> Code.Type-appQuant mp nt tp- = foldr QuantApp tp $ Map.findWithDefault [] nt mp-}--ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit Sequence CRule [ allNts : {Set NontermIdent} | | ]--SEM CGrammar- | CGrammar- nonts.allNts = @nonts.gathNts--ATTR CNonterminals CNonterminal [ | | gathNts USE {`Set.union`} {Set.empty} : {Set NontermIdent} ]--SEM CNonterminal- | CNonterminal- lhs.gathNts = Set.singleton @nt---- keep track of which children have had their first visit-ATTR CVisits CVisit Sequence CRule [ | visitedSet : {Set Identifier} | ]-SEM CProduction | CProduction visits.visitedSet = Set.empty-SEM CRule | CChildVisit loc.visitedSet = Set.insert @name @lhs.visitedSet------------------------------------------------------------------------------------ Generating declarations from the sequence. We generate the origin--- comment if pretty printing is requested. A childvisit takes inherited--- attributes and returns synthesized attributes and the next visit.----------------------------------------------------------------------------------ATTR Sequence CRule [ | | decls USE {++} {[]} : {Decls} ]-SEM CRule- | 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,defor) = fromJust $ inst `lookup` @loc.instTypes- in unwrapSem @lhs.o_newtypes nm- $ case mb of- ChildReplace _ -> App instLocFieldName [SimpleExpr $ fieldname inst]- _ ->- if defor- then SimpleExpr instLocFieldName- else App (cataname @lhs.prefix nm)- [SimpleExpr instLocFieldName]- )- (Set.singleton instSemFieldName)- (Set.singleton instLocFieldName)- | inst <- @loc.definedInsts- , let instLocFieldName = attrname @lhs.options True _INST inst- instSemFieldName = attrname @lhs.options False _INST' inst- ]- loc.patDescr = if @isIn- then "_"- else concat $ intersperse "," (map (\(f,a) -> show f ++ "." ++ show a) @pattern.patternAttributes)- loc.traceDescr = (maybe "" (\nm -> show nm ++ ":") @mbNamed) ++ show @nt ++ " :: " ++ show @con ++ " :: " ++ @loc.patDescr-- loc.addTrace = \v -> if @lhs.o_traces- then Trace @loc.traceDescr v- else v- loc.costCentreDescr = show @nt ++ ":" ++ show @con ++ ":" ++ @loc.patDescr- loc.addCostCentre = \v -> if @lhs.o_costcentre- then PragmaExpr True False ("SCC \"" ++ @loc.costCentreDescr ++ "\"") v- else v- loc.addLinePragma = \v -> let p = getPos @name- hasPos = line p > 0 && column p >= 0 && not (null (file p))- in if @lhs.o_linePragmas && hasPos- then PragmaExpr True True ("LINE " ++ show (line p) ++ " " ++ show (file p))- $ LineExpr- $ v- else v- loc.decls = if @hasCode- then @originComment ( mkDecl (@lhs.o_monadic && @explicit) (Pattern3 @pattern.copy) (@loc.addTrace $ @loc.addCostCentre $ @loc.addLinePragma $ (TextExpr @rhs))- (Set.fromList [attrname @lhs.options False fld nm | (fld,nm,_) <- Map.elems @defines])- (Set.fromList [attrname @lhs.options True fld nm | (fld,nm) <- Set.toList @uses])- : @loc.instDecls)- else @loc.instDecls- | CChildVisit loc.costCentreDescr = show @lhs.nt ++ ":" ++ show @lhs.con ++ ":" ++ show @name ++ ":" ++ show @nt ++ ":" ++ show @nr- loc.addCostCentre = \v -> if @lhs.o_costcentre- then PragmaExpr True False ("SCC \"" ++ @loc.costCentreDescr ++ "\"") v- else v- loc.decls = let lhsVars = map (attrname @lhs.options True @name) (Map.keys @syn)- ++ if @isLast then [] else [unwrap ++ funname @name (@nr+1)]- rhsVars = map (attrname @lhs.options False @name) (Map.keys @inh)- unwrap = if @lhs.o_newtypes then typeName @nt (@nr + 1) ++ " " else ""- tuple | isMerging = TupleLhs [locname @lhs.options @name ++ "_comp"]- | 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,_,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)- merges = [ (c,cs) | (c,(_,cs)) <- Map.assocs @lhs.mergeMap, all (`Set.member` @loc.visitedSet) cs, @name `elem` (c:cs) ]-- baseNm = if @nr == 0 && isVirtual @name @lhs.children- then Ident (getName @name ++ "_inst") (getPos @name)- else @name- fun | @nr == 0 && Set.member @name @lhs.aroundMap- = locname @lhs.options @name ++ "_around " ++ funname baseNm 0- | otherwise = funname baseNm @nr- outDecls | isMerged = [] -- merged variant is only produced after the last visit of the merged children- | otherwise = -- [mkDecl @lhs.o_monadic tuple rhs (Set.fromList lhsVars) (Set.fromList (funname baseNm @nr : rhsVars))]- if isMerging- then [mkDecl @lhs.o_monadic tuple rhs Set.empty Set.empty]- else [Resume @lhs.o_monadic (typeName @nt @nr) tuple rhs]- outMerged | null merges || @nr /= 0 = [] -- no merged child to produce- | otherwise = let (c,cs) = head merges- tuple' = mkTupleLhs @lhs.o_unbox (null $ Map.keys @inh) lhsVars'- lhsVars' = map (attrname @lhs.options True c) (Map.keys @syn)- ++ if @isLast then [] else [unwrap ++ funname c (@nr+1)]- rhsVars' = [ locname @lhs.options c' ++ "_comp" | c' <- cs ]- fun' = locname @lhs.options c ++ "_merge"- rhs' = App fun' (map SimpleExpr rhsVars')- in [Resume @lhs.o_monadic (typeName @nt @nr) tuple' rhs']- in -- trace (show @name ++ " # " ++ show @loc.visitedSet ++ " # " ++ show (Map.assocs @lhs.mergeMap) ++ " # " ++ show merges ++ " # " ++ show @nr ++ " # " ++ show (length outMerged)) $- (outDecls ++ outMerged)--{-mkDecl :: Bool -> Lhs -> Expr -> Set String -> Set String -> Decl-mkDecl True lhs rhs _ _ = Bind lhs rhs-mkDecl False lhs rhs s1 s2 = Decl lhs rhs s1 s2--unwrapSem :: Bool -> NontermIdent -> Expr -> Expr-unwrapSem False _ e = e-unwrapSem True nm e = Case e alts- where alts = [CaseAlt left right]- left = Fun (typeName nm 0) [SimpleExpr "x"]- right = SimpleExpr "x"-}--ATTR Sequence CRule [ children : {[(Identifier,Type,ChildKind)]} ||]--ATTR Sequence CRule Pattern Patterns [|| definedInsts USE {++} {[]} : {[Identifier]} ]-SEM Pattern- | Alias lhs.definedInsts = (if @field == _INST then [@attr] else []) ++ @pat.definedInsts--SEM CRule- | CRule loc.definedInsts = if @isIn then [] else @pattern.definedInsts--ATTR Pattern Patterns [ | | patternAttributes USE {++} {[]} : {[(Identifier, Identifier)]} ]-SEM Pattern- | Alias- lhs.patternAttributes = (@field,@attr) : @pat.patternAttributes------------------------------------------------------------------------------------ Numbering the visits----------------------------------------------------------------------------------ATTR CVisits CVisit Sequence CRule- CSegments CSegment [ nr : Int | | ]-SEM CProduction- | CProduction visits.nr = 0-SEM CVisits- | Cons tl.nr = @lhs.nr + 1-SEM CInterface- | CInterface seg.nr = 0-SEM CSegments- | Cons tl.nr = @lhs.nr + 1------------------------------------------------------------------------------------ Checking last visit----------------------------------------------------------------------------------ATTR CVisit CSegment [ isLast : Bool | | ]-ATTR CVisits CSegments [ | | isNil : Bool ]-SEM CVisits- | Cons lhs.isNil = False- hd.isLast = @tl.isNil- | Nil lhs.isNil = True-SEM CSegments- | Cons lhs.isNil = False- hd.isLast = @tl.isNil- | Nil lhs.isNil = True------------------------------------------------------------------------------------ Getting the next intra-visit dependencies----------------------------------------------------------------------------------ATTR CVisit [ nextIntra : {Exprs} nextIntraVars : {Set String} | | ]-ATTR CVisits CVisit [ | | intra : {Exprs} intraVars : {Set String} ]-SEM CVisit- | CVisit lhs.intra = @intra.exprs- lhs.intraVars = @intra.usedVars-SEM CVisits- | Cons hd.nextIntra = @tl.intra- hd.nextIntraVars = @tl.intraVars- lhs.intra = @hd.intra- lhs.intraVars = @hd.intraVars- | Nil lhs.intra = []- lhs.intraVars = Set.empty------------------------------------------------------------------------------------ Superfluous intra-visit dependencies due to higher-order children--- (higher-order children can only be passed from their moment of creation)----------------------------------------------------------------------------------SEM CRule- | CChildVisit- loc.isSuperfluousHigherOrderIntra- = @lhs.nr <= Map.findWithDefault (-1) @name @lhs.instVisitNrs------------------------------------------------------------------------------------ Intra-visit dependencies are expressions that need to be passed----------------------------------------------------------------------------------ATTR Sequence CRule [ | | exprs USE {++} {[]} : {Exprs} ]-SEM CRule- | CRule loc.rulename = if @field == _LOC && @name `elem` @lhs.terminals- then funname @name 0- else attrname @lhs.options @isIn @field @name- lhs.exprs = [SimpleExpr @loc.rulename]- | CChildVisit- loc.names = -- do not pass inst-childs as parameter if they are not defined yet- if @loc.isSuperfluousHigherOrderIntra- then []- else [funname @name (@nr+1)]- lhs.exprs = let wrap = if @lhs.o_newtypes then \x -> App (typeName @nt (@nr + 1)) [x] else id-- addType expr | null @loc.instParams = expr- | otherwise = TypedExpr expr (@lhs.unfoldSemDom @nt (@nr+1) @loc.instParams)-- in map (wrap . addType . SimpleExpr) @loc.names--ATTR Sequence CRule [ | | usedVars USE {`Set.union`} {Set.empty} : {Set String} ]-SEM CRule- | CRule- lhs.usedVars = Set.singleton @loc.rulename- | CChildVisit- lhs.usedVars = Set.fromList @loc.names------------------------------------------------------------------------------------ Type signatures are added to the declarations.----------------------------------------------------------------------------------ATTR Sequence CRule [ | | tSigs USE {++} {[]} : {[Decl]} ]-SEM CRule- | CRule loc.mkTp = typeToCodeType (Just @lhs.nt) @loc.orgParams- lhs.tSigs = [ TSig (attrname @lhs.options False field attr) tp'- | (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 tp2 = @loc.evalTp field $ @mkTp tp''- in Arr tp2 tp1- Nothing -> tp1- findOrigType _ [] = Nothing- findOrigType nm ((n,_,kind) : r)- | nm == n = case kind of- ChildReplace orig -> Just orig- _ -> Nothing- | otherwise = findOrigType nm r- ]-- loc.orgParams = map getName $ Map.findWithDefault [] @lhs.nt @lhs.paramMap- loc.evalTp =- \field tp -> let orgFldParams = map getName $ Map.findWithDefault [] childNt @lhs.paramMap- (childNt,instParams) = Map.findWithDefault (@lhs.nt,[]) field @lhs.paramInstMap- replMap = Map.fromList (zip orgFldParams instParams)- replace k = Map.findWithDefault ('@':k) k replMap- in if null instParams- then if null @orgParams- then tp- else idEvalType @lhs.options tp- else evalType @lhs.options replace tp-- | CChildVisit loc.mkTp = @loc.evalTp . typeToCodeType (Just @nt) @loc.orgParams- loc.definedTps = [ TSig (attrname @lhs.options 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-- loc.orgParams = map getName $ Map.findWithDefault [] @nt @lhs.paramMap- loc.instParams = snd $ Map.findWithDefault (@nt,[]) @name @lhs.paramInstMap- loc.replParamMap = Map.fromList (zip @loc.orgParams @loc.instParams)- loc.replace = \k -> Map.findWithDefault k k @loc.replParamMap- loc.evalTp = if null @loc.orgParams then id else evalType @lhs.options @loc.replace------------------------------------------------------------------------------------- Types of intra-visit dependencies are needed in the type of the--- semantic function.----------------------------------------------------------------------------------ATTR CVisits CVisit [ children : {[(Identifier,Type, ChildKind)]} | | ]-SEM CProduction- | CProduction visits.children = @children---ATTR Sequence CRule [ | | tps USE {++} {[]} : {[Type]}- allTpsFound USE {&&} {True} : Bool ]-SEM CRule- | 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 False]------------------------------------------------------------------------------------ Each visit has its semantic function----------------------------------------------------------------------------------ATTR CVisits [ | | decls : {Decls} ]-ATTR CVisit [ | decls : {Decls} | ]-SEM CVisits- | Nil lhs.decls = []- | Cons lhs.decls = @hd.decls- hd.decls = @tl.decls---- Note: lhs.decls are the decls related to the next visit function. We pass it--- chained from right to left in order to build the next visit function inside--- the previous one.--- Note: intra decls are ignored. The intra-visit variables are not passed on--- explicitly, but handled automatically due to nesting level.--SEM CVisit- | CVisit (loc.higherOrderChildren,loc.firstOrderChildren) = partition (\(_,_,virt) -> isHigherOrder virt) @lhs.children- loc.firstOrderOrig = map pickOrigType @loc.firstOrderChildren- loc.funcname = seqSemname @lhs.prefix @lhs.nt @lhs.con @lhs.nr- loc.nextVisitName = if @lhs.isLast then [] else [visitname @lhs.prefix @lhs.nt (@lhs.nr+1)]- loc.nextVisitDecl = let lhs = TupleLhs @nextVisitName- -- rhs = App fun @lhs.nextIntra- rhs = Let @lhs.decls (SimpleExpr fun)- fun = seqSemname @lhs.prefix @lhs.nt @lhs.con (@lhs.nr+1)- in if @lhs.isLast- then []- else [Decl lhs rhs (Set.fromList @nextVisitName) @lhs.nextIntraVars]- loc.isOneVisit = @lhs.isLast && @lhs.nr == 0- loc.hasWrappers = @lhs.nt `Set.member` @lhs.wrappers- loc.refDecls = if @loc.isOneVisit && @loc.hasWrappers && reference @lhs.options- then let synAttrs = Map.toList @syn- synNT = "Syn" ++ "_" ++ getName @lhs.nt- synVars = [ SimpleExpr (attrname @lhs.options False _LHS a) | (a,_) <- synAttrs ]- rhs = App synNT synVars- lhs = Fun "___node" []- in [Decl lhs rhs Set.empty Set.empty]- else []- loc.decls = if @lhs.o_clean- then @vss.decls ++ @nextVisitDecl ++ @loc.refDecls -- Don't generate type signatures for Clean, they will cause the compiler to generate functions, even for constants- else @typeSigs ++ @vss.decls ++ @nextVisitDecl ++ @loc.refDecls- vss.lastExpr = mkTupleExpr @lhs.o_unbox (null $ Map.keys @inh) $ map (SimpleExpr . lhsname @lhs.options False) (Map.keys @syn) ++ map SimpleExpr @nextVisitName- intra.lastExpr = error "lastExpr: not used here"- loc.lastExprVars = map (lhsname @lhs.options False) (Map.keys @syn) ++ @loc.nextVisitName- (loc.blockFunDecls, loc.blockFirstFunCall) = mkPartitionedFunction @loc.funcname @loc.o_case @loc.nextVisitDecl @loc.lastExprVars @vss.blockDecls-- loc.costCentreDescr = "b" ++ ":" ++ show @lhs.nt ++ ":" ++ show @lhs.con ++ ":" ++ show @lhs.nr- loc.addCostCentre = \v -> if @lhs.o_costcentre- then PragmaExpr True False ("SCC \"" ++ @loc.costCentreDescr ++ "\"") v- else v-- loc.params = map getName $ Map.findWithDefault [] @lhs.nt @lhs.paramMap- 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-- addType expr | null tps = expr- | otherwise = TypedExpr expr (@lhs.unfoldSemDom tp 0 tps)-- 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 @lhs.options $ typeToCodeType (Just @lhs.nt) @loc.params $ removeDeforested tp)-- mbEvalTp | null @loc.params = const Nothing- | otherwise = Just . (idEvalType @lhs.options)-- rhs = wrap- . mkSemFun @lhs.nt @lhs.nr [mkLambdaArg (lhsname @lhs.options 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- else mkDecls @loc.declsType @decls- . ResultExpr (typeName @lhs.nt @lhs.nr)- . mkTupleExpr @lhs.o_unbox (null $ Map.keys @inh)- $ map (SimpleExpr . lhsname @lhs.options False) (Map.keys @syn) ++ map SimpleExpr @nextVisitName- wrap = if @lhs.o_newtypes- then \x -> App (typeName @lhs.nt @lhs.nr) [x]- 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- | 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- argType _ _ = error "Self type not allowed here"- evalTp | null @loc.params = id- | otherwise = idEvalType @lhs.options-- in appQuant @lhs.quantMap @lhs.nt $ appContext @lhs.contextMap @lhs.nt $ evalTp $- if @lhs.nr == 0- then foldr argType (typeAppStrs (sdtype @lhs.nt ) @loc.params) (map (\(_,t,_) -> t) @loc.firstOrderOrig)- else foldr argType (typeAppStrs (typeName @lhs.nt @lhs.nr) @loc.params) [] -- @intra.tps- lhs.decls = ( if @lhs.with_sig- then [@tsig, @semFun]- else [@semFun]- ) ++- ( if @ordered && @loc.o_splitsems- then @loc.blockFunDecls- else []- )- loc.typeSigs = if @lhs.o_sig && not @o_case- then @vss.tSigs- else []- loc.o_do = @ordered && @lhs.o_monadic- loc.o_case = not @loc.o_do && @lhs.o_case && @ordered && not (hasPragma @lhs.allPragmas @lhs.nt @lhs.con _NOCASE)- loc.declsType = if @loc.o_do- then DeclsDo- else if @loc.o_case- then DeclsCase- else DeclsLet- loc.o_splitsems = @ordered && @lhs.o_splitsems--{-mkLambdaArg :: String -> Maybe Code.Type -> Expr-mkLambdaArg nm Nothing = SimpleExpr nm-mkLambdaArg nm (Just tp) = TypedExpr (SimpleExpr nm) tp--mkLambda :: Exprs -> Expr -> Expr-mkLambda [] e = e-mkLambda xs e = Lambda xs e--mkSemFun :: Identifier -> Int -> Exprs -> Expr -> Expr-mkSemFun nt nr xs e = SemFun (typeName nt nr) xs e--typeAppStrs :: String -> [String] -> Code.Type-typeAppStrs nm params = TypeApp (SimpleType nm) (map SimpleType params)--isHigherOrder :: ChildKind -> Bool-isHigherOrder ChildAttr = True-isHigherOrder _ = False--pickOrigType :: (Identifier, Type, ChildKind) -> (Identifier, Type, ChildKind)-pickOrigType (nm, _, virt@(ChildReplace x)) = (nm, x, virt)-pickOrigType x = x-}--ATTR CVisits CVisit Sequence CRule [ instVisitNrs : {Map Identifier Int} || ]-ATTR CVisits CVisit [|| gatherInstVisitNrs USE {`Map.union`} {Map.empty} : {Map Identifier Int} ]-SEM CProduction- | CProduction- visits.instVisitNrs = @visits.gatherInstVisitNrs--SEM CVisit- | CVisit- lhs.gatherInstVisitNrs = Map.fromList [(i,@lhs.nr) | i <- @vss.definedInsts]------------------------------------------------------------------------------------ Push aroundsMap downward----------------------------------------------------------------------------------ATTR CNonterminals CNonterminal- [ aroundMap : {Map NontermIdent (Map ConstructorIdent (Set Identifier))} || ]--ATTR CProductions CProduction- [ aroundMap : {Map ConstructorIdent (Set Identifier)} || ]--ATTR CVisits CVisit Sequence CRule [ aroundMap : {Set Identifier} | | ]--SEM CGrammar | CGrammar loc.aroundMap = @aroundsMap-SEM CNonterminal | CNonterminal loc.aroundMap = Map.findWithDefault Map.empty @nt @lhs.aroundMap-SEM CProduction | CProduction loc.aroundMap = Map.findWithDefault Set.empty @con @lhs.aroundMap------------------------------------------------------------------------------------ Push mergeMap downward----------------------------------------------------------------------------------ATTR CNonterminals CNonterminal- [ mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier])))} || ]--ATTR CProductions CProduction- [ mergeMap : {Map ConstructorIdent (Map Identifier (Identifier, [Identifier]))} || ]--ATTR CVisits CVisit Sequence CRule [ mergeMap : {Map Identifier (Identifier, [Identifier])} | | ]--SEM CGrammar | CGrammar loc.mergeMap = @mergeMap-SEM CNonterminal | CNonterminal loc.mergeMap = Map.findWithDefault Map.empty @nt @lhs.mergeMap-SEM CProduction | CProduction loc.mergeMap = Map.findWithDefault Map.empty @con @lhs.mergeMap------------------------------------------------------------------------------------ Generate a partitioned version of the sequence of rules----------------------------------------------------------------------------------ATTR Sequence [ lastExpr : Expr | | blockDecls : DeclBlocks ]--ATTR Sequence CRule [ | declsAbove : {[Decl]} | ]-SEM CVisit- | CVisit- vss.declsAbove = []- intra.declsAbove = error "declsAbove: not used here"--SEM CRule- | CRule- lhs.declsAbove = @lhs.declsAbove ++ @loc.decls- | CChildVisit- lhs.declsAbove = []--SEM Sequence- | Cons- lhs.blockDecls = @hd.bldBlocksFun @tl.blockDecls- | Nil- lhs.blockDecls = DeclTerminator @lhs.declsAbove @lhs.lastExpr--ATTR CRule [ | | bldBlocksFun : {DeclBlocks -> DeclBlocks} ]-SEM CRule- | CRule- lhs.bldBlocksFun = id- | CChildVisit- lhs.bldBlocksFun = DeclBlock @lhs.declsAbove (head @loc.decls)--{-mkPartitionedFunction :: String -> Bool -> [Decl] -> [String] -> DeclBlocks -> ([Decl], Expr)-mkPartitionedFunction prefix' optCase nextVisitDecls lastExprVars cpsTree- = let inh = Inh_DeclBlocksRoot { prefix_Inh_DeclBlocksRoot = prefix'- , optCase_Inh_DeclBlocksRoot = optCase- , nextVisitDecls_Inh_DeclBlocksRoot = nextVisitDecls- , lastExprVars_Inh_DeclBlocksRoot = lastExprVars- }- sem = sem_DeclBlocksRoot (DeclBlocksRoot cpsTree)- syn = wrap_DeclBlocksRoot sem inh- in (lambdas_Syn_DeclBlocksRoot syn, firstCall_Syn_DeclBlocksRoot syn)-}--WRAPPER DeclBlocksRoot--ATTR DeclBlocksRoot DeclBlocks [ prefix : String optCase : Bool nextVisitDecls : {[Decl]} lastExprVars : {[String]} | | ]-ATTR DeclBlocksRoot [ | | lambdas : {[Decl]} firstCall : Expr ]--SEM DeclBlocksRoot- | DeclBlocksRoot- lhs.lambdas = @blocks.decls- lhs.firstCall = @blocks.callExpr--ATTR DeclBlocks [ blockNr : Int | | ]-SEM DeclBlocksRoot- | DeclBlocksRoot- blocks.blockNr = 1-SEM DeclBlocks- | DeclBlock- next.blockNr = @lhs.blockNr + 1--ATTR DeclBlocks [ | | callExpr : Expr freeVars : {[String]} ]-SEM DeclBlocks- | DeclBlock DeclTerminator- loc.lambdaName = @lhs.prefix ++ "_block" ++ show @lhs.blockNr- loc.pragmaDecl = PragmaDecl ("NOINLINE " ++ @loc.lambdaName)- lhs.callExpr = App @loc.lambdaName (map SimpleExpr @loc.freeVars)- | DeclTerminator- loc.freeVars = freevars @lhs.lastExprVars (@defs ++ @lhs.nextVisitDecls)- | DeclBlock- loc.freeVars = freevars @next.freeVars (@visit : @defs)--ATTR DeclBlocks [ | | decls : {[Decl]} ]-SEM DeclBlocks- | DeclTerminator- lhs.decls = [ mkBlockLambda @lhs.optCase @loc.lambdaName @loc.freeVars (@defs ++ @lhs.nextVisitDecls) @result ]- | DeclBlock- loc.decl = mkBlockLambda @lhs.optCase @loc.lambdaName @loc.freeVars (@defs ++ [@visit]) @next.callExpr- lhs.decls = (if @lhs.blockNr > 1 then [@loc.pragmaDecl] else []) ++ [@loc.decl] ++ @next.decls--{-freevars :: [String] -> [Decl] -> [String]-freevars additional decls- = Set.toList (allused `Set.difference` alldefined)- where- allused = Set.unions (Set.fromList additional : map usedvars decls)- alldefined = Set.unions (map definedvars decls)-- usedvars (Decl _ _ _ uses) = uses- usedvars _ = Set.empty-- definedvars (Decl _ _ defs _) = defs- definedvars _ = Set.empty--mkBlockLambda :: Bool -> String -> [String] -> [Decl] -> Expr -> Decl-mkBlockLambda optCase name args decls expr- = Decl lhs rhs Set.empty Set.empty- where- lhs = Fun name (map SimpleExpr args)- rhs = mkLet optCase decls expr-}------------------------------------------------------------------------------------- The semantic domain is generated from the interface.----------------------------------------------------------------------------------ATTR CInterface CSegments CSegment [ | | semDom USE {++} {[]} : {[Decl]} ]-SEM CInterface- | CInterface lhs.semDom = Comment "semantic domain" : @seg.semDom--SEM CSegment- | CSegment loc.altSemForm = breadthFirst @lhs.options- loc.tp = if @loc.altSemForm- then TypeApp (SimpleType "Child") [SimpleType "EvalInfo", @loc.indexExpr ]- else foldr Arr @loc.synTps @loc.inhTps- loc.inhTps = [typeToCodeType (Just @lhs.nt) @loc.params tp | tp <- Map.elems @inh]- loc.inhTup = mkTupleType @lhs.o_unbox (null @loc.inhTps) @loc.inhTps- loc.synTps = mkTupleType @lhs.o_unbox (null @loc.inhTps) ([typeToCodeType (Just @lhs.nt) @loc.params tp | tp <- Map.elems @syn] ++ @loc.continuation)- loc.curTypeName = typeName @lhs.nt @lhs.nr- loc.nextTypeName = typeName @lhs.nt (@lhs.nr + 1)- loc.indexName = "I_" ++ @loc.curTypeName- loc.dataIndex = Code.Data @loc.indexName @loc.params [DataAlt @loc.indexName []] False []- loc.indexExpr = TypeApp (SimpleType @loc.indexName) (map (SimpleType . ('@':)) @loc.params)- loc.indexStr = "(" ++ @loc.indexName ++ concatMap (\p -> " " ++ p) @loc.params ++ ")"- loc.inhInstance = Code.Data "instance Inh" [@loc.indexStr] [DataAlt (typeName @lhs.nt @lhs.nr ++ "_Inh") [@loc.inhTup] ] False []- loc.synInstance = Code.Data "instance Syn" [@loc.indexStr] [DataAlt (typeName @lhs.nt @lhs.nr ++ "_Syn") [@loc.synTps] ] False []- loc.continuation = if @lhs.isLast- then []- else [TypeApp (SimpleType @loc.nextTypeName) (map (SimpleType . ('@':)) @loc.params)]- loc.params = map getName $ Map.findWithDefault [] @lhs.nt @lhs.paramMap- lhs.semDom = let name = typeName @lhs.nt @lhs.nr- evalTp | null @loc.params = id- | otherwise = idEvalType @lhs.options- in ( if @lhs.o_newtypes- then [ Code.NewType name @loc.params name (evalTp @loc.tp) ]- else [ Code.Type name @loc.params (evalTp @loc.tp) ] )- ++ ( if @loc.altSemForm- then [@loc.dataIndex, @loc.inhInstance, @loc.synInstance]- else [] )--ATTR CNonterminals CNonterminal CInterface CSegments CSegment [ | | semDomUnfoldGath USE {`Map.union`} {Map.empty} : {Map (NontermIdent, Int) ([String], Code.Type)} ]--SEM CSegment- | CSegment- lhs.semDomUnfoldGath = Map.singleton (@lhs.nt, @lhs.nr) (@loc.params, @loc.tp)--ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit Sequence CRule [ unfoldSemDom : {NontermIdent -> Int -> [String] -> Code.Type} | | ]--SEM CGrammar- | CGrammar- loc.unfoldSemDom =- \nt nr repl ->- let (params, tp) = Map.findWithDefault (error ("No such semantic domain: " ++ show nt)) (nt, nr) @nonts.semDomUnfoldGath- replMap = Map.fromList (zip params repl)- replace k = Map.findWithDefault ('@':k) k replMap- in evalType @lhs.options replace tp--{-typeToCodeType :: Maybe NontermIdent -> [String] -> Type -> Code.Type-typeToCodeType _ _ tp- = case tp of- NT nt tps defor -> NontermType (getName nt) tps defor- Haskell t -> SimpleType t- Self -> error "Self type not allowed here."--evalType :: Options -> (String -> String) -> Code.Type -> Code.Type-evalType opts replf t'- = chase t'- where- chase t- = case t of- Arr l r -> Arr (chase l) (chase r)- TypeApp f as -> TypeApp (chase f) (map chase as)- TupleType tps -> TupleType (map chase tps)- UnboxedTupleType tps -> UnboxedTupleType (map chase tps)- Code.List tp -> Code.List (chase tp)- SimpleType txt -> let tks = lexTokens opts (initPos txt) txt- tks' = map replaceTok tks- txt' = unlines . showTokens . tokensToStrings $ tks'- in SimpleType txt'- TMaybe m -> TMaybe (chase m)- TEither l r -> TEither (chase l) (chase r)- TMap k v -> TMap (chase k) (chase v)- TIntMap v -> TIntMap (chase v)- TSet m -> TSet (chase m)- _ -> t-- replaceTok t- = case t of- AGLocal v p _ -> HsToken (replf $ getName v) p- _ -> t--idEvalType :: Options -> Code.Type -> Code.Type-idEvalType options = evalType options id-}------------------------------------------------------------------------------------ Wrapper functions----------------------------------------------------------------------------------SEM CNonterminal- | CNonterminal loc.semWrapper = let params' = map getName @params- inhAttrs = Map.toList @inh- synAttrs = Map.toList @syn- inhVars = [ SimpleExpr (attrname @lhs.options True _LHS a) | (a,_) <- inhAttrs ]- synVars = [ SimpleExpr (attrname @lhs.options False _LHS a) | (a,_) <- synAttrs ]- var = "sem"- wrapNT = "wrap" ++ "_" ++ getName @nt- inhNT = "Inh" ++ "_" ++ getName @nt- synNT = "Syn" ++ "_" ++ getName @nt- varPat = if @lhs.o_newtypes- then App (sdtype @nt) [SimpleExpr var]- else SimpleExpr var-- evalTp | null params' = id- | otherwise = idEvalType @lhs.options- 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 []- datas = [mkdata inhNT inhAttrs, mkdata synNT synAttrs]- in datas ++ [ typeSig- , Decl (Fun wrapNT [varPat, App inhNT inhVars])- (Let @inter.wrapDecls (App synNT synVars))- Set.empty Set.empty- ]--ATTR CInterface CSegments CSegment [ | | wrapDecls USE {++} {[]}: {Decls} ]-SEM CSegment- | CSegment lhs.wrapDecls = let lhsVars = map (lhsname @lhs.options False) (Map.keys @syn)- ++ if @lhs.isLast then [] else [unwrap ++ sem (@lhs.nr+1)]- rhsVars = map (lhsname @lhs.options True) (Map.keys @inh)- rhs = map SimpleExpr rhsVars- unwrap = if @lhs.o_newtypes then typeName @lhs.nt (@lhs.nr + 1) ++ " " else ""- var = "sem"- sem 0 = var- sem n = var ++ "_" ++ show n- ntt = typeName @lhs.nt @lhs.nr- in [ EvalDecl ntt (mkTupleLhs @lhs.o_unbox (null $ Map.keys @inh) lhsVars) (InvokeExpr ntt (SimpleExpr $ sem @lhs.nr) rhs) ]- -- [ Decl (mkTupleLhs @lhs.o_unbox (null $ Map.keys @inh) lhsVars) (App (sem @lhs.nr) rhs) (Set.fromList lhsVars) (Set.fromList rhsVars) ]------------------------------------------------------------------------------------ Errors for missing type signatures. It's an error when one of the--- attributes in the intra-visit dependencies does not have a type.--- UPDATE: it is not an error anymore...----------------------------------------------------------------------------------ATTR CNonterminals CNonterminal- CProductions CProduction- CVisits CVisit [ with_sig : Bool | | ]--SEM CGrammar- | CGrammar nonts.with_sig = typeSigs @lhs.options--SEM CGrammar [ | | errors : {Seq Error} ]- | CGrammar lhs.errors = Seq.empty------------------------------------------------------------------------------------ Provide a description of the interfaces as comments----------------------------------------------------------------------------------SEM CNonterminal- | CNonterminal loc.comment = Comment . unlines . map ind $ ( @inter.comments ++ ("alternatives:" : map ind @prods.comments) )--ATTR CInterface CSegments CSegment- CProductions CProduction- CVisits CVisit Sequence CRule [ | | comments USE {++} {[]}: {[String]} ]--ATTR Sequence CRule [ what:String | | ]--SEM CSegment- | CSegment lhs.comments = let body = map ind (showsSegment (CSegment @inh @syn))- in if null body- then []- else ("visit " ++ show @lhs.nr ++ ":") : body--SEM CProduction- | CProduction loc.firstOrderChildren = [ (nm,fromJust mb,virt) | (nm,tp,virt) <- @children, let mb = isFirstOrder virt tp, isJust mb ]- lhs.comments = ("alternative " ++ getName @con ++ ":")- : map ind ( map (\(x,y,_) -> makeLocalComment 14 "child" x (Just y)) @loc.firstOrderChildren- ++ @visits.comments- )--{--- for a virtual child that already existed as a child, returns-isFirstOrder :: ChildKind -> Type -> Maybe Type-isFirstOrder ChildSyntax tp = Just tp-isFirstOrder ChildAttr _ = Nothing-isFirstOrder (ChildReplace tp) _ = Just tp-}--SEM CVisit- | CVisit lhs.comments = let body = map ind (@vss.comments ++ @intra.comments)- in if null body- then []- else ("visit " ++ show @lhs.nr ++ ":") : body- vss.what = "local"- intra.what = "intra"---SEM CRule- | CRule lhs.comments = [ makeLocalComment 11 @lhs.what name tp | (field,name,tp) <- Map.elems @defines, field == _LOC ]- ++ [ makeLocalComment 11 "inst " name tp | (field,name,tp) <- Map.elems @defines, field == _INST ]--{-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' ++ "}"- Self -> error "Self type not allowed here.") tp- in ( what ++ " " ++ x ++ replicate ((width - length x) `max` 0) ' ' ++ " : " ++ y )--}------------------------------------------------------------------------------------ And tie it all together----------------------------------------------------------------------------------ATTR CNonterminals CNonterminal [ | | chunks USE {++} {[]} : {Chunks} ]-ATTR CProductions CProduction [ | | decls USE {++} {[]} : {Decls} ]-ATTR CGrammar [ | | output : Program ]--SEM CGrammar- | CGrammar lhs.output = Program @nonts.chunks @multivisit--SEM CNonterminal- | CNonterminal lhs.chunks = [ Chunk (getName @nt)- (Comment (getName @nt ++ " " ++ replicate (60 - length (getName @nt)) '-'))- (if @lhs.o_pretty then [@loc.comment] else [])- (if isJust @lhs.o_data then [@loc.dataDef] else [])- (if @lhs.o_cata && @loc.genCata then @loc.cataFun else [])- (if @lhs.o_sig then @inter.semDom else [])- (if @nt `Set.member` @lhs.wrappers then @loc.semWrapper else [])- (if @lhs.o_sem then @prods.decls else [])- (if @lhs.o_sem then @prods.semNames else [])- ]--{--- Lets or nested Cases?--- or even a do-expression?--data DeclsType = DeclsLet | DeclsCase | DeclsDo--mkDecls :: DeclsType -> Decls -> Expr -> Expr-mkDecls DeclsLet = mkLet False-mkDecls DeclsCase = mkLet True-mkDecls DeclsDo = \decls -> Do (map toBind decls)- where toBind (Decl lhs rhs _ _) = BindLet lhs rhs- toBind d = d--mkLet :: Bool -> Decls -> Expr -> Expr-mkLet False decls body = Let decls body-mkLet True decls body = foldr oneCase body decls--oneCase :: Decl -> Expr -> Expr-oneCase (Decl left rhs _ _) ex = Case rhs [CaseAlt left ex]-oneCase (Resume _ nt left rhs) ex = ResumeExpr nt rhs left ex-oneCase _ ex = ex---- Gives the name of the visit function-funname :: Show a => a -> Int -> String-funname field 0 = show field ++ "_"-funname field nr = show field ++ "_" ++ show nr---- Gives the name of a semantic function-seqSemname :: String -> NontermIdent -> ConstructorIdent -> Int -> String-seqSemname pre nt con 0 = semname pre nt con-seqSemname pre nt con nr = semname pre nt con ++ "_" ++ show nr---- Gives the name of a type-typeName :: NontermIdent -> Int -> String-typeName nt 0 = "T_" ++ show nt-typeName nt n = "T_" ++ show nt ++ "_" ++ show n--ntOfVisit :: NontermIdent -> Int -> NontermIdent-ntOfVisit nt 0 = nt-ntOfVisit nt n = Ident (show nt ++ "_" ++ show n) (getPos nt)---- Gives the name of a visit function-visitname :: String -> NontermIdent -> Int -> String-visitname pre nt n = pre ++ getName nt ++ "_" ++ show n-}------------------------------------------------------------------------------------ Datatypes were already present----------------------------------------------------------------------------------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- . wrappers = @wrappers--SEM CNonterminal- | CNonterminal loc.dataDef = let params' = map getName @params- typeSyn tp = let theType =- case tp of- CommonTypes.Maybe t -> TMaybe $ typeToCodeType (Just @nt) params' t- CommonTypes.Either t1 t2 -> TEither (typeToCodeType (Just @nt) params' t1) (typeToCodeType (Just @nt) params' t2)- CommonTypes.Map t1 t2 -> TMap (typeToCodeType (Just @nt) params' t1) (typeToCodeType (Just @nt) params' t2)- CommonTypes.IntMap t -> TIntMap $ typeToCodeType (Just @nt) params' t- CommonTypes.List t -> Code.List $ typeToCodeType (Just @nt) params' t- CommonTypes.Tuple ts -> Code.TupleType [typeToCodeType (Just @nt) params' t | (_,t) <- ts ]- CommonTypes.OrdSet t -> TSet $ typeToCodeType (Just @nt) params' t- CommonTypes.IntSet -> TIntSet- in Code.Type (getName @nt) params' (idEvalType @lhs.options theType)- derivings = maybe [] (map getName . Set.toList) (Map.lookup @nt @lhs.derivings)- dataDef = Data (getName @nt) (map getName @params) @prods.dataAlts (maybe False id @lhs.o_data) derivings- in maybe dataDef typeSyn $ lookup @nt @lhs.typeSyns--ATTR CProductions [ | | dataAlts : {DataAlts} ]-ATTR CProduction [ | | dataAlt : {DataAlt} ]--SEM CProductions- | Cons lhs.dataAlts = @hd.dataAlt : @tl.dataAlts- | Nil lhs.dataAlts = []--SEM CProduction- | CProduction loc.params = map getName $ Map.findWithDefault [] @lhs.nt @lhs.paramMap- lhs.dataAlt = let conNm = conname @lhs.o_rename @lhs.nt @con- mkFields :: (NontermIdent -> ConstructorIdent -> Identifier -> Code.Type -> a) -> [a]- 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----------------------------------------------------------------------------------SEM CNonterminal- | CNonterminal loc.genCata = not (@nt `Set.member` nocatas @lhs.options)- loc.cataFun = let appParams nm = TypeApp (SimpleType nm) (map SimpleType (map getName @params))- evalTp | null @params = id- | otherwise = idEvalType @lhs.options- tSig = TSig (cataname @lhs.prefix @nt)- (appQuant @lhs.quantMap @nt $ appContext @lhs.contextMap @nt $ evalTp $ appParams (getName @nt) `Arr` appParams (sdtype @nt))- special typ = case typ of- CommonTypes.List tp ->- let cons = SimpleExpr (semname @lhs.prefix @nt (identifier "Cons"))- 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- lhs = Fun (cataname @lhs.prefix @nt) [arg]- rhs = (App "Prelude.foldr" [cons,nil,rarg])- in [Decl lhs rhs Set.empty Set.empty]- CommonTypes.Maybe tp ->- let just = semname @lhs.prefix @nt (identifier "Just")- 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- 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- ]- CommonTypes.Either tp1 tp2 ->- let left = semname @lhs.prefix @nt (identifier "Left")- 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- rarg1 = case tp2 of- 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- ]- CommonTypes.Map _ tp ->- let entry = SimpleExpr (semname @lhs.prefix @nt (identifier "Entry"))- 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- lhs = Fun (cataname @lhs.prefix @nt) [arg]- rhs = App "Data.Map.foldrWithKey" [entry,nil,rarg]- in [Decl lhs rhs Set.empty Set.empty]- CommonTypes.IntMap tp ->- let entry = SimpleExpr (semname @lhs.prefix @nt (identifier "Entry"))- 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- lhs = Fun (cataname @lhs.prefix @nt) [arg]- rhs = App "Data.IntMap.foldWithKey" [entry,nil,rarg]- in [Decl lhs rhs Set.empty Set.empty]- CommonTypes.Tuple tps ->- let con = semname @lhs.prefix @nt (identifier "Tuple")- 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-- lhs = Fun (cataname @lhs.prefix @nt) [TupleExpr (map fst tps')]- rhs = App con rargs- in [Decl lhs rhs Set.empty Set.empty] - CommonTypes.OrdSet tp ->- let entry = SimpleExpr (semname @lhs.prefix @nt (identifier "Entry"))- nil = SimpleExpr (semname @lhs.prefix @nt (identifier "Nil" ))- arg = SimpleExpr "set"- rentry = case tp of- NT t _ _ -> let t' = maybe t id (deforestedNt t)- in App "(.)" [entry, SimpleExpr $ cataname @lhs.prefix t']- _ -> entry- lhs = Fun (cataname @lhs.prefix @nt) [arg]- rhs = (App "Data.Set.foldr" [rentry,nil,arg])- in [Decl lhs rhs Set.empty Set.empty]- CommonTypes.IntSet ->- let entry = SimpleExpr (semname @lhs.prefix @nt (identifier "Entry"))- nil = SimpleExpr (semname @lhs.prefix @nt (identifier "Nil" ))- arg = SimpleExpr "set"- lhs = Fun (cataname @lhs.prefix @nt) [arg]- rhs = (App "Data.IntSet.foldr" [entry,nil,arg])- in [Decl lhs rhs Set.empty Set.empty]- in Comment "cata" :- (if @lhs.o_sig then [tSig] else []) ++- maybe @prods.cataAlts special (lookup @nt @lhs.typeSyns)--ATTR CProductions [ | | cataAlts : {Decls} ]-ATTR CProduction [ | | cataAlt : {Decl} ]---SEM CProductions- | Cons lhs.cataAlts = @hd.cataAlt : @tl.cataAlts- | Nil lhs.cataAlts = []--SEM CProduction- | CProduction lhs.cataAlt = let lhs = Fun (cataname @lhs.prefix @lhs.nt) [lhs_pat]- lhs_pat = App (conname @lhs.o_rename @lhs.nt @con)- (map (\(n,_,_) -> SimpleExpr $ locname @lhs.options $ n) @loc.firstOrderChildren)- rhs = App (semname @lhs.prefix @lhs.nt @con)- (map argument @loc.firstOrderChildren)- argument (nm,NT tp _ _,_) = App (cataname @lhs.prefix tp)- [SimpleExpr (locname @lhs.options nm)]- argument (nm, _,_) = SimpleExpr (locname @lhs.options nm)- in Decl lhs rhs Set.empty Set.empty------------------------------------------------------------------------------------- Collect names of generated stuff----------------------------------------------------------------------------------ATTR CProductions CProduction CVisits CVisit [ | | semNames USE {++} {[]} : {[String]} ]--{--SEM CProduction- | CProduction- lhs.semNames = [cataname @lhs.prefix @lhs.nt] ++ @visits.semNames--}--SEM CVisit- | CVisit- lhs.semNames = [@loc.funcname]-
− src-ag/HsToken.ag
@@ -1,33 +0,0 @@-imports-{-import CommonTypes-import UU.Scanner.Position(Pos)-}--DATA HsTokensRoot- | HsTokensRoot tokens : HsTokens--TYPE HsTokens = [HsToken]--DATA HsToken- | AGLocal var : {Identifier} -- either a local or a terminal- pos : {Pos}- rdesc : {Maybe String} -- description of the rule the local reference appears in-- | AGField field : {Identifier} -- Misnomer: this is actually a reference to an attribute, not a terminal!- attr : {Identifier}- pos : {Pos}- rdesc : {Maybe String} -- description of the rule the attribute reference appears in-- | HsToken value : {String}- pos : {Pos}- | CharToken value : {String}- pos : {Pos}- | StrToken value : {String}- pos : {Pos}- | Err mesg : {String}- pos : {Pos}----DERIVING HsToken : Show
− src-ag/Interfaces.ag
@@ -1,16 +0,0 @@-imports-{-import CommonTypes-import SequentialTypes-}--DATA IRoot | IRoot inters:Interfaces-TYPE Interfaces = [Interface]-DATA Interface | Interface nt:NontermIdent- cons:{[ConstructorIdent]}- seg:Segments-TYPE Segments = [Segment]-DATA Segment | Segment inh:{[Vertex]}- syn:{[Vertex]}- -
− src-ag/InterfacesRules.lag
@@ -1,451 +0,0 @@-\begin{Code}-PRAGMA strictdata-PRAGMA optimize-PRAGMA bangpats-PRAGMA strictwrap--INCLUDE "Interfaces.ag"--imports-{-import Interfaces-import CodeSyntax-import GrammarInfo--import qualified Data.Sequence as Seq-import Data.Sequence(Seq)-import qualified Data.Map as Map-import Data.Map(Map)-import Data.Tree(Tree(Node), Forest)-import Data.Graph(Graph, dfs, edges, buildG, transposeG)-import Data.Maybe (fromJust)-import Data.List (partition,transpose,(\\),nub,findIndex)-import Data.Array ((!),inRange,bounds,assocs)-import Data.Foldable(toList)-}-\end{Code}--%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%-\section{Visit sub-sequence-graph}--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$.--We add the following edges:--\begin{enumerate}-- \item From the inherited attributes passed to the visit to $v$,- because these attributes need to be computed before visiting $v$.-- \item From the synthesized attributes computed by the visit to- $v$, because a visit to $v$ computes these attributes.-- \item From the previous visit to $v$, because we can only visit- $c$ for the $i$-th time if we have visited it the $(i-1)$-th time.--\end{enumerate}--Now we can define a visit sub-sequence as a list of vertices:--\begin{Code}-{-type VisitSS = [Vertex]-}-\end{Code}--We define a function that generates the visit-subsequences-graph and a-description of the newly added vertices. We do this using an attribute-grammar. The visit subsequences graph has transposed edges, so we can-use |topSort'|.--\begin{Code}-ATTR IRoot [ tdp : Graph | | ]-SEM IRoot- | IRoot loc.newedges = toList @inters.newedges- loc.visitssGraph = let graph = buildG (0,@inters.v-1) es- es = @newedges ++ edges @lhs.tdp- in transposeG graph-\end{Code}--As we will need to look up information, we pass |info| down. An-attribute v stores a fresh vertex. We start counting from the hightest-vertex in |tdp|.--\begin{Code}-ATTR Interfaces Interface Segments Segment [ | v : Vertex | ]-ATTR IRoot Interfaces Interface Segments Segment [ info : Info | | ]-SEM IRoot- | IRoot inters.v = snd (bounds @lhs.tdp) + 1-\end{Code}--The actual generation of edges takes place in |Segment|. We group the-attribute occurrences. |isEqualField| checks are at the same position-(either lhs of the same child).--\begin{Code}-{-gather :: Info -> [Vertex] -> [[Vertex]]-gather info = eqClasses comp- where comp a b = isEqualField (ruleTable info ! a) (ruleTable info ! b)-}-\end{Code}--When we do this for right-hand side occurrences of the inherited and-syntesized attributes of a |Segment|, we find the new vertices.--\begin{Code}-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- , p (@look a)]- loc.groups : {[([Vertex],[Vertex])]}- loc.groups = let group as = gather @lhs.info (@occurAs isRhs as)- in map (partition (isInh . @look)) (group (@inh ++ @syn))- loc.v : {Int}- loc.v = @lhs.v + length @groups- loc.newvertices = [@lhs.v .. @loc.v-1]-\end{Code}--A description of the new vertices van be found by looking up the field-of an attribute occurrence--\begin{Code}-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 }- descr USE {Seq.><} {Seq.empty} : {Seq (Vertex,ChildVisit)} ]-SEM Segment- | Segment lhs.descr = Seq.fromList $ zipWith (cv @look @lhs.n) @newvertices @groups {-$-}--{--- Only non-empty syn will ever be forced, because visits with empty syn are never performed--- Right hand side synthesized attributes always have a field-cv :: (Vertex -> CRule) -> Int -> Vertex -> ([Vertex],[Vertex]) -> (Vertex,ChildVisit)-cv look n v (inh,syn) = let fld = getField (look (head syn))- rnt = fromJust (getRhsNt (look (head syn)))- d = ChildVisit fld rnt n inh syn- in (v,d)-}-\end{Code}--\begin{Code}-SEM IRoot- | IRoot loc.descr = toList @inters.descr-\end{Code}--The edges between attributes occurrences and their corresponding-visits can be found as follows:--\begin{Code}-SEM Segment- | Segment loc.attredges = concat (zipWith ed @newvertices @groups)--{-ed :: Vertex -> ([Vertex], [Vertex]) -> [(Vertex, Vertex)]-ed v (inh,syn) = map (\i -> (i,v)) inh ++ map (\s -> (v,s)) syn-}-\end{Code}--For edges between visits we simpy |zip| the current vertices with the-next ones.--\begin{Code}-ATTR Segment [ nextNewvertices : {[Vertex]} | | newvertices : {[Vertex]} ]-ATTR Segments [ | | newvertices : {[Vertex]} ]-SEM Segments- | Cons hd.nextNewvertices = @tl.newvertices- lhs.newvertices = @hd.newvertices- | Nil lhs.newvertices = []--SEM Segment- | Segment loc.visitedges = zip @newvertices @lhs.nextNewvertices- lhs.newedges = Seq.fromList @attredges Seq.>< Seq.fromList @visitedges-\end{Code}--The first visit to a child is passed to the first visit of the parent,-so we add edges for this, too.--\begin{Code}-ATTR Segments Segment [ | | groups : {[([Vertex],[Vertex])]} ]-SEM Segments- | Cons lhs.groups = @hd.groups- | Nil lhs.groups = []-SEM Interface- | Interface seg.v = @lhs.v- loc.v = @seg.v + length @seg.newvertices- lhs.v = @loc.v- 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- lhs.descr = @seg.descr Seq.>< Seq.fromList @descr-\end{Code}--The visit number can simply be counted--\begin{Code}-ATTR Segments Segment [ n : Int | | ]-SEM Interface- | Interface seg.n = 0-SEM Segments- | Cons tl.n = @lhs.n + 1-\end{Code}--%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%-\subsection{Visit sub-sequences}--To compute the visit subsequences, we pass the visit-subsequence graph down--\begin{Code}-ATTR Interfaces Interface Segments Segment [ vssGraph : Graph | | ]-SEM IRoot- | IRoot inters.vssGraph = @visitssGraph-\end{Code}--Each segment computes subsequences for each production of the-nonterminal. We group the occurrences of the synthesized attributes,-and perform a topological sort on it. In the absence of synthesized-attributes, nothing needs to be computed, so the visit subsequence-is empty.--\begin{Code}-SEM Segment- | Segment loc.synOccur = gather @lhs.info (@occurAs isLhs @syn)- loc.vss = let hasCode' v | inRange (bounds (ruleTable @lhs.info)) v = getHasCode (ruleTable @lhs.info ! v)- | otherwise = True- in if null @syn- then replicate (length @lhs.cons) []- else map (filter hasCode' . topSort' @lhs.vssGraph) @synOccur-ATTR Segments Segment [ cons : {[ConstructorIdent]} | | ]-SEM Interface- | Interface seg.cons = @cons-\end{Code}--We adapt the topological sort to take a list of vertices to start-sorting.--\begin{Code}-{-postorder :: Tree a -> [a]-postorder (Node a ts) = postorderF ts ++ [a]-postorderF :: Forest a -> [a]-postorderF = concatMap postorder-postOrd :: Graph -> [Vertex] -> [Vertex]-postOrd g = postorderF . dfs g-topSort' :: Graph -> [Vertex] -> [Vertex]-topSort' g = postOrd g-}-\end{Code}--This gives us the subsequence required to compute the synthesized-attributes. However, a part of this subsequence has already been-computed in previous visits. We thread this part through. It starts-with all first visits to children.--\begin{Code}-ATTR Interfaces Interface [ prev : {[Vertex]} | | firstvisitvertices USE {++} {[]} : {[Vertex]} ]-SEM IRoot- | IRoot inters.prev = let terminals = [ v | (v,cr) <- assocs (ruleTable @lhs.info), not (getHasCode cr), isLocal cr ]- in @inters.firstvisitvertices ++ terminals--ATTR Segments Segment [ | prev : {[Vertex]} | ]-\end{Code}--and we remove this part from the subsequence--\begin{Code}-SEM Segment [ | | visitss : {[VisitSS]} ]- | Segment loc.visitss' = map (\\ @lhs.prev) @vss- loc.defined = let defines v = case Map.lookup v @lhs.visitDescr of- Nothing -> [v]- Just (ChildVisit _ _ _ inh _) -> v:inh- in concatMap (concatMap defines) @visitss- lhs.prev = @lhs.prev ++ @defined-\end{Code}--When more that one attribute is defined in the same rule, this rule is-repeated in the visit subsequence. We do not want this.--\begin{Code}-SEM Segment- | Segment loc.visitss : {[[Vertex]]}- loc.visitss = let rem' :: [(Identifier,Identifier,Maybe Type)] -> [Vertex] -> [Vertex]- rem' _ [] = []- 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- def = Map.elems (getDefines cr)- in addV (rem' (def ++ prev) vs)- | otherwise = v:rem' prev vs- table = ruleTable @lhs.info- in map (rem' []) @visitss'-\end{Code}--%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%-\subsection{Intra-visit dependencies}--We ignore terminals, they need to be passed from the first visit up to-where they are needed. Intra-visit dependencies descibe what a visit-needs from its previous visits. The first visit does not have-intra-visit dependencies, because there are no previous visits. We add-an attribute that indicates whether it's the first visit.--\begin{Code}-ATTR Segment Segments [ isFirst : {Bool} | | ]-SEM Interface- | Interface seg.isFirst = True-SEM Segments- | Cons tl.isFirst = False-\end{Code}--We declare an attribute intravisit which gives the intra-visit-dependencies. We pass the intravisit of the next visit to this-one.-\begin{Code}-{-type IntraVisit = [Vertex]-}--ATTR Segment [ nextIntravisits : {[IntraVisit]} | | intravisits : {[IntraVisit]} ]-SEM Segments [ | | hdIntravisits : {[IntraVisit]} ]- | Cons hd.nextIntravisits = @tl.hdIntravisits- lhs.hdIntravisits = @hd.intravisits- | Nil lhs.hdIntravisits = repeat []-\end{Code}--The first visit does not have intra-visit dependencies. A later visit-need all attributes that it's subsequence depends on, and the-intra-visit dependecies of the next visit, except for those attributes-that are compted in this visit.--\begin{Code}-ATTR IRoot [ dpr : {[Edge]} | | ]-ATTR Interfaces Interface Segments Segment [ ddp : Graph | | ]-SEM IRoot- | IRoot inters.ddp = buildG (0,@inters.v-1) (map swap (@lhs.dpr ++ @newedges))--{-swap :: (a,b) -> (b,a)-swap (a,b) = (b,a)-}--ATTR Segments Segment [ fromLhs : {[Vertex]} | | ]-SEM Interface- | Interface seg.fromLhs = @lhs.prev-SEM Segments- | Cons hd.fromLhs = @lhs.fromLhs- tl.fromLhs = []-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 ->- let needed = concatMap (@lhs.ddp !) vs- in nub (needed ++ next) \\ (@fromLhs ++ @computed)-\end{Code}--%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%-\subsection{Result}--Our resulting datastructure is:--Now we pass the visit sub-sequences up. In |Interface|, |@seg.visitss|-gives us for each segment, for each production a subsequence. What we-want is for each production, for each visit a subsequence, which is-accomplished by |transpose|. The same is done for intravisits.--\begin{Code}-ATTR Interfaces Interface Segments Segment [ allInters : {CInterfaceMap} | | ]-SEM IRoot- | IRoot inters.allInters = @inters.inters--ATTR IRoot Interfaces [ | | inters : {CInterfaceMap}- visits : {CVisitsMap} ]-SEM Interfaces- | Cons lhs.inters = Map.insert @hd.nt @hd.inter @tl.inters- lhs.visits = Map.insert @hd.nt @hd.visits @tl.visits- | Nil lhs.inters = Map.empty- lhs.visits = Map.empty--SEM Interface [ | | nt : NontermIdent ]- | Interface lhs.nt = @nt--SEM Interface [ | | inter : CInterface- visits : {Map ConstructorIdent CVisits} ]- | Interface lhs.inter = CInterface @seg.segs- lhs.visits = Map.fromList (zip @cons (transpose @seg.cvisits))--SEM Segments [ | | segs : CSegments- cvisits USE {:} {[]} : {[[CVisit]]} ] -- For each visit, for each constructor the CVisit- | Cons lhs.segs = @hd.seg : @tl.segs- | Nil lhs.segs = []--SEM Segment [ | | seg : CSegment- cvisits : {[CVisit]} ] -- For this visit, for each constructor the CVisit- | Segment lhs.seg = -- A fake dependency fixes a type-3 cycle- if False then undefined @lhs.vssGraph @lhs.visitDescr @lhs.prev else CSegment @inhmap @synmap- loc.inhmap : {Map Identifier Type}- loc.synmap : {Map Identifier Type}- loc.(inhmap,synmap) = let makemap = Map.fromList . map findType- findType v = getNtaNameType (attrTable @lhs.info ! v)- in (makemap @inh,makemap @syn)- lhs.cvisits = let mkVisit vss intra = CVisit @inhmap @synmap (mkSequence vss) (mkSequence intra) True- mkSequence = map mkRule- mkRule v = case Map.lookup v @lhs.visitDescr of- Nothing -> ruleTable @lhs.info ! v- Just (ChildVisit name nt n _ _) -> ccv name nt n @lhs.allInters- in zipWith mkVisit @visitss @intravisits--{-ccv :: Identifier -> NontermIdent -> Int -> CInterfaceMap -> CRule-ccv name nt n table- = CChildVisit name nt n inh syn lst- 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- lst = null remain-}-\end{Code}--%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%-\subsection{EDP}--To find a type-3 cycle we need to know the dependencies that the-interfaces generate.--\begin{Code}-ATTR Interfaces Interface Segments Segment [ | | edp USE {Seq.><} {Seq.empty} : {Seq Edge} ]-SEM Segment- | Segment lhs.edp = Seq.fromList [(i,s) | i <- @inh, s <- @syn]- Seq.>< Seq.fromList [(s,i) | s <- @syn, i <- @lhs.nextInh ]-SEM IRoot [ | | edp : {[Edge]} ]- | IRoot lhs.edp = toList @inters.edp-SEM Segment [ nextInh : {[Vertex]} | | inh : {[Vertex]} ]- | Segment lhs.inh = @inh-SEM Segments [ | | firstInh : {[Vertex]} ]- | Cons hd.nextInh = @tl.firstInh- lhs.firstInh = @hd.inh- | Nil lhs.firstInh = []-\end{Code}-
− src-ag/KWOrder.ag
@@ -1,217 +0,0 @@-INCLUDE "AbstractSyntax.ag"-INCLUDE "HsToken.ag"-INCLUDE "Expression.ag"-INCLUDE "Patterns.ag"-INCLUDE "DistChildAttr.ag"-INCLUDE "ExecutionPlanPre.ag"-INCLUDE "ExecutionPlanCommon.ag"--imports-{-import AbstractSyntax-import HsToken-import Expression-import Patterns-import Options-import PPUtil-import Pretty-import Knuth1-import KennedyWarren-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)-}------------------------------------------------------------------------------------ Dependency graph per production----------------------------------------------------------------------------------- Gather vertices-ATTR HsToken Expression- Rule Rules- Pattern Patterns- Child Children [ | | vertices USE {`Set.union`} {Set.empty} : {Set.Set Vertex} ]---- All vertices from the righthandside of a rule-SEM HsToken- | AGLocal lhs.vertices = Set.singleton $ VChild @var- | AGField lhs.vertices = Set.singleton $ VAttr (if @field == _LHS then Inh- 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- (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 Inh) @field @attr- 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 $ @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---- Add extra vertex for a rule-SEM Rule- | Rule loc.vertex = VRule @loc.rulename- lhs.vertices = Set.insert @loc.vertex $ @pattern.vertices `Set.union` @rhs.vertices---- Combine all vertices for a production-SEM Production- | Production loc.vertices = @rules.vertices `Set.union` @children.vertices---- Gather edges-ATTR Rule Rules- Child Children [ | | edges USE {`Set.union`} {Set.empty} : {Set.Set Edge} ]---- Gather edges for a rule-SEM Rule- | Rule loc.edgesout = map ((,) @loc.vertex) (Set.toList @rhs.vertices)- 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 = @loc.higherOrderEdges- loc.edgesin = map (flip (,) @loc.vertex) @loc.synvertices- 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---- Find all child nonterminal names for a production-ATTR Child Children [ | | nontnames USE {++} {[]} : {[(Identifier, Identifier)]}]--SEM Child- | Child lhs.nontnames = case @tp of- NT nont _ _ -> [(@name, nont)]- _ -> []---- Return a dependency graph for each production-ATTR Production [ | | depgraph : {ProdDependencyGraph} ]-ATTR Productions [ | | depgraph USE {:} {[]} : {[ProdDependencyGraph]} ]--SEM Production- | Production lhs.depgraph = ProdDependencyGraph { pdgVertices = Set.toList @loc.vertices- , pdgEdges = Set.toList @loc.edges- , pdgRules = @rules.erules- , pdgChilds = @children.echilds- , pdgProduction = @con- , pdgChildMap = @children.nontnames- , pdgConstraints = @constraints- , pdgParams = @params }------------------------------------------------------------------------------------ Dependency graph per nonterminal------------------------------------------------------------------------------------ Vertices are just all inherited and syntesized attributes-SEM Nonterminal- | Nonterminal loc.synvertices = map (VAttr Syn @nt) . Map.keys $ @syn- loc.inhvertices = map (VAttr Inh @nt) . Map.keys $ @inh- loc.vertices = @loc.synvertices ++ @loc.inhvertices---- Construct nonterminal dependency graph for production-SEM Nonterminal- | Nonterminal loc.nontgraph = NontDependencyGraph { ndgVertices = @loc.vertices- , ndgEdges = [] }---- Create dependency information for nonterminal and pass it upwards-ATTR Nonterminal [ | | depinfo : {NontDependencyInformation} ]-ATTR Nonterminals [ | | depinfo USE {:} {[]} : {[NontDependencyInformation]} ]--SEM Nonterminal- | Nonterminal lhs.depinfo = NontDependencyInformation { ndiNonterminal = @nt- , ndiParams = @params- , ndiInh = Map.keys @inh- , ndiSyn = Map.keys @syn- , ndiDepGraph = @loc.nontgraph- , 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}- errors : {Seq Error} ]--SEM Grammar- | Grammar (lhs.output, lhs.depgraphs, lhs.visitgraph, lhs.errors)- = let lazyPlan = kennedyWarrenLazy @lhs.options @wrappers @nonts.depinfo @typeSyns @derivings- in if visit @lhs.options && withCycle @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)--
− src-ag/LOAG/Order.ag
@@ -1,435 +0,0 @@-INCLUDE "AbstractSyntax"-INCLUDE "Patterns"-INCLUDE "CodeSyntax"-INCLUDE "Expression"-INCLUDE "HsToken"-INCLUDE "LOAG/Rep"-INCLUDE "LOAG/Prepare"-INCLUDE "ExecutionPlanCommon"--MODULE {LOAG.Order}-{}-{}-imports{-import qualified Data.Array as A-import qualified Data.Map as Map-import qualified Data.IntMap as IMap-import qualified Data.Set as Set-import qualified Data.IntSet as IS-import qualified Data.Sequence as Seq-import qualified CommonTypes as CT-import Control.Monad (forM,when)-import Control.Monad.ST-import Data.Maybe(catMaybes)-import Data.Monoid(mappend,mempty)-import Data.STRef-import AbstractSyntax-import qualified LOAG.AOAG as AOAG-import LOAG.Common-import LOAG.Chordal-import LOAG.Rep-import LOAG.Graphs-import CodeSyntax-import Data.Maybe (isJust, fromJust)-import ExecutionPlan-import GrammarInfo-import HsToken (HsToken(..))-import Pretty-import qualified System.IO as IO-import System.IO.Unsafe-}--{-fst' (a,_,_) = a-snd' (_,b,_) = b-trd' (_,_,c) = c-}--ATTR Grammar [ | | - output : ExecutionPlan- ads : {Maybe PP_Doc}- errors : {Seq.Seq Error}]--SEM Grammar | Grammar- lhs.errors = either Seq.singleton (const Seq.empty) @loc.schedRes- lhs.ads = case either (const []) trd' @loc.schedRes of- [] -> Nothing - ads -> Just $ ppAds @lhs.options @nonts.pmp ads - lhs.output = ExecutionPlan @nonts.enonts @typeSyns @wrappers @derivings-- nonts.sched = either (const Map.empty) snd' @loc.schedRes- nonts.tdp = either (error "no tdp") (fromJust.fst') @loc.schedRes-- loc.schedRes = if CT.loag @lhs.options- then if CT.aoag @lhs.options- then AOAG.schedule @smf.self @self @loc.ag @nonts.ads- else @loc.loagRes- else Right (Nothing,Map.empty,[])- loc.loagRes = let putStrLn s = when (verbose @lhs.options) (IO.putStrLn s)- in Right $ unsafePerformIO $ scheduleLOAG @loc.ag putStrLn @lhs.options- loc.ag = repToAg @smf.self @self-- nonts.res_ads = either (const []) trd' @loc.schedRes---- Gather the fake dependencies from the ads result of AOAG--ATTR Nonterminals Nonterminal Productions Production- [ res_ads : {[Edge]} || ]-ATTR Nonterminals Nonterminal - [ || fdps USE {Map.union} {Map.empty} : AttrOrderMap ]--SEM Nonterminal | Nonterminal- lhs.fdps = Map.singleton @nt @prods.fdps--ATTR Productions Production [ || - fdps USE {Map.union} {Map.empty} : {Map.Map ConstructorIdent (Set Dependency)} ]--SEM Production | Production- lhs.fdps = - let op d@(f,t) ds- | fst (argsOf $ findWithErr @lhs.pmpf "fdps" f) == (@lhs.dty,getName @con)- = Set.insert (edgeToDep @lhs.pmpf d) ds- | otherwise - = ds- in Map.singleton @con $ foldr op Set.empty @lhs.res_ads-{-data AltAttr = AltAttr Identifier Identifier Bool- deriving (Eq, Ord, Show)--edgeToDep :: PMP -> Edge -> Dependency-edgeToDep pmp (f,t) = - Dependency (OccAttr (identifier f1) (identifier i1)) - (OccAttr (identifier f2) (identifier i2))- where (MyOccurrence (_,f1) (i1,_),MyOccurrence (_,f2) (i2,_))- = (findWithErr pmp "edgeToDep" f, - findWithErr pmp "edgeToDep" t) --ppAds :: Options -> PMP -> [Edge] -> PP_Doc-ppAds opts pmp = foldr ((>-<) . ppEdge opts pmp) empty--ppEdge :: Options -> PMP -> Edge -> PP_Doc-ppEdge opts pmp (f,t) = - text sem >#< text (show ty) >|< " | " >|< text p >|< " "- >|< ppOcc pmp f >|< text " < " >|< ppOcc pmp t- where (MyOccurrence ((ty,p),_) _) = pmp Map.! f- sem | lcKeywords opts = "sem"- | otherwise = "SEM"- -ppOcc :: PMP -> Vertex -> PP_Doc-ppOcc pmp v = text f >|< text "." >|< fst a- where (MyOccurrence ((t,p),f) a) = findWithErr pmp "ppOcc" v--}---- Construct Execution Plan--ATTR Nonterminals Nonterminal [ - visMapf : {IMap.IntMap Int}- tdp : TDPRes ||- enonts USE {(++)} {[]} : ENonterminals- visMap USE {IMap.union} {IMap.empty} : {IMap.IntMap Int}]--SEM Grammar- | Grammar nonts.visMapf = @nonts.visMap- nonts.visitnum = 0--SEM Nonterminal- | Nonterminal- loc.initial = @lhs.visitnum - loc.vnums = zipWith const [@loc.initial..] @segments- loc.initialVisit = @vnums- loc.nextVis = Map.fromList $ (@loc.initial + length @vnums, NoneVis)- : [(v, OneVis v) | v <- @vnums ]- loc.prevVis = Map.fromList $ (@loc.initial, NoneVis)- : [(v+1, OneVis v) | v <- @vnums ]- loc.visMap = let op vnr (MySegment visnr ins syns _ _) =- IMap.fromList $ zip syns (repeat vnr)- in IMap.unions $ zipWith op [@loc.initial..] @mysegments- lhs.enonts = [ENonterminal - @nt- @params - @loc.classContexts- @loc.initial- @loc.initialVisit- @loc.nextVis- @loc.prevVis- @prods.eprods- @loc.recursive- @loc.hoInfo ]--ATTR Productions Production [- visMapf : {IMap.IntMap Int} - tdp : TDPRes ||- eprods USE {(++)} {[]} : EProductions ]--SEM Production - | Production- segs.ruleMap = @rules.ruleMap- segs.done = (Set.empty, Set.empty, Set.empty, Set.empty)- loc.intros = let intro (Child nm _ kind)- | kind == ChildAttr = Nothing- | otherwise = Just $ ChildIntro nm- in catMaybes $ map intro @children.self- lhs.eprods = - let ((Visit ident from to inh syn steps kind):vss) = @segs.evisits- steps' = @loc.intros ++ steps- visits | null @segs.evisits = []- | otherwise = - ((Visit ident from to inh syn steps' kind):vss)- in [EProduction- @con- @params- @constraints- @rules.erules- @children.echilds- visits ]--ATTR Nonterminals Nonterminal Productions Production MySegments MySegment- [ | visitnum : Int | ]---- Visit nums should be the same for each production, but different globally-SEM Productions- | Cons tl.visitnum = @lhs.visitnum- lhs.visitnum = @hd.visitnum--SEM MySegment | MySegment +visitnum = (+1)-ATTR MySegments MySegment [- -- maps which attribute occurrence is calculated in which visit- visMapf : {IMap.IntMap Int} | | ]--ATTR MySegments MySegment [- ps : PLabel - ruleMap : {Map.Map MyOccurrence Identifier}- nmprf : NMP_R- options : {Options}- tdp : TDPRes- done : { (Set.Set MyOccurrence, Set.Set FLabel- , Set.Set Identifier, Set.Set (FLabel,Int))}- ||]--ATTR MySegments [|| evisits USE {:} {[]} : {Visits}]-ATTR MySegment [|| - evisits : {Visit}- -- synthesized attribute occurrences of this segment- synsO : {[Int]}- visnr : Int- done : { (Set.Set MyOccurrence, Set.Set FLabel- ,Set.Set Identifier, Set.Set (FLabel,Int))}]--SEM MySegments- | Cons hd.done = @lhs.done- tl.done = @hd.done--SEM MySegment - | MySegment - loc.inhs = Map.keysSet$ Map.unions $ map (vertexToAttr @lhs.nmp) @inhAttr- loc.syns = Map.keysSet$ Map.unions $ map (vertexToAttr @lhs.nmp) @synAttr- loc.inhsO= maybe (error "segment not instantiated") id @inhOccs- loc.synsO= maybe (error "segment not instantiated") id @synOccs- lhs.visnr= @visnr- loc.kind = if monadic @lhs.options then VisitMonadic else VisitPure True- lhs.evisits = Visit @lhs.visitnum @lhs.visitnum (@lhs.visitnum+1)- @loc.inhs @loc.syns @loc.steps @loc.kind- loc.steps = if monadic @lhs.options- then [Sim @loc.vss] else [PureGroup @loc.vss True]- (loc.vss,lhs.done) = (runST $ getVss @lhs.done @lhs.ps @lhs.tdp @synsO - @lhs.lfpf @lhs.nmprf @lhs.pmpf @lhs.pmprf @lhs.fty- @lhs.visMapf @lhs.ruleMap @lhs.hoMapf)--{-getVss (done,intros,rules,vnrs) ps tdp synsO lfp nmpr pmp pmpr fty visMap ruleMap hoMap = do- ref <- newSTRef done- introed <- newSTRef intros- ruleref <- newSTRef rules - vnrsref <- newSTRef vnrs- lists <- forM synsO (visit ref introed ruleref vnrsref . (pmp Map.!))- done <- readSTRef ref- intros <- readSTRef introed- rules <- readSTRef ruleref- vnrs <- readSTRef vnrsref - return (concat lists, (done, intros, rules, vnrs))- where - hochildren = maybe Set.empty id $ Map.lookup ps hoMap- visit ref introed ruleref vnrsref o@(MyOccurrence (_,f) (_,d)) = do- visited <- readSTRef ref- if (o `Set.member` visited) - then return [] -- already visited- else do -- prevent doubles- modifySTRef ref (Set.insert o)- if inOutput- then do -- has to be calculated in this sequence- rest' <- rest- locs' <- locs- sem' <- sem o- return $ (rest' ++ locs' ++ sem')- else if "lhs" == (snd $ argsOf o)- then return [] -- inherited of parent, nothing todo- else do -- other input occurrence, perform visit- locs' <- locs- rest' <- rest- visit'<- toVisit o- return (rest' ++ locs' ++ visit')- where preds = maybe [] (IS.toList . (tdp A.!)) $ Map.lookup o pmpr- rest = forM preds (visit ref introed ruleref vnrsref. (pmp Map.!)) - >>= (return . concat)- free = maybe [] (Set.toList) $ Map.lookup o lfp- locs = forM free (visit ref introed ruleref vnrsref)- >>= (return . concat)- sem o = do rules <- readSTRef ruleref - if r `Set.member` rules- then return []- else do writeSTRef ruleref (r `Set.insert` rules) - return [Sem r]- where r = maybe (error "ruleMap") id $ Map.lookup o ruleMap- inOutput = f == "lhs" && d == Syn || f /= "lhs" && d == Inh- toVisit o = do- vnrs <- readSTRef vnrsref - if (child,visnr) `Set.member` vnrs- then return []- else writeSTRef vnrsref ((child,visnr) `Set.insert` vnrs) >>- if child `Set.member` hochildren - then do intros <- readSTRef introed- case child `Set.member` intros of- True -> return [cvisit]- False -> do- writeSTRef introed (Set.insert child intros)- let occ = (ps,"inst") >.< (child, AnyDir)- preds = Set.toList $ setConcatMap rep $ - lfp Map.! occ- rep :: MyOccurrence -> Set.Set MyOccurrence - rep occ | isLoc occ = Set.insert occ $ - setConcatMap rep $ lfp Map.! occ- | otherwise = Set.singleton occ- rest <- forM preds - (visit ref introed ruleref vnrsref)- sem' <- sem occ- return $ (concat rest) ++- sem' ++- [ChildIntro (identifier child)] ++- [cvisit]- else return [cvisit]- where cvisit= ChildVisit (identifier child) ntid visnr- child = snd $ argsOf o- ntid = ((\(NT name _ _ )-> name) . fromMyTy) nt - visnr = (\x-> visMap IMap.! x) (nmpr Map.! (nt <.> attr o))- nt = fty Map.! (ps,child)-}--ATTR Nonterminals Nonterminal [ - sched : {InterfaceRes} ||]-SEM Nonterminal- | Nonterminal - loc.assigned = findWithErr @lhs.sched "could not const. interfaces" - (getName @nt)- loc.mx = if Map.null @lhs.sched- then 0 - else let mx = fst $ IMap.findMax @loc.assigned in- if even mx then mx else mx + 1 - loc.mysegments = - map (\i -> MySegment ((@loc.mx - i) `div` 2)- (maybe [] id $ IMap.lookup i @loc.assigned)- (maybe [] id $ IMap.lookup (i-1) @loc.assigned) - Nothing Nothing)- [@loc.mx,@loc.mx-2 .. 2]- loc.segments = - map (\(MySegment visnr is ss _ _) -> - CSegment (Map.unions $ map (vertexToAttr @lhs.nmp) is)- (Map.unions $ map (vertexToAttr @lhs.nmp) ss))- @loc.mysegments--ATTR Productions Production [ mysegments : MySegments || ]-SEM Production- | Production- inst.segs : MySegments- --translate from attribute to occurrences- inst.segs = - map (\(MySegment visnr inhs syns _ _) -> - MySegment visnr inhs syns - (Just $ map (@lhs.pmprf Map.!) $ - handAllOut (@loc.ps,"lhs") $ - map (@lhs.nmp Map.!) inhs)- (Just $ map (@lhs.pmprf Map.!) $ - handAllOut (@loc.ps,"lhs") $ - map (@lhs.nmp Map.!) syns)- ) @lhs.mysegments--{-repToAg :: LOAGRep -> Grammar -> Ag-repToAg sem (Grammar _ _ _ _ dats _ _ _ _ _ _ _ _ _) = - Ag bounds_s bounds_p de (map toNt dats)- where- pmp = (pmp_LOAGRep_LOAGRep sem)- pmpr = (pmpr_LOAGRep_LOAGRep sem)- nmp = (nmp_LOAGRep_LOAGRep sem)- nmpr = (nmpr_LOAGRep_LOAGRep sem)- genA = gen_LOAGRep_LOAGRep sem- fieldM = fieldMap_LOAGRep_LOAGRep sem- genEdge (f,t) = (gen f, gen t)- fsInP = map2F (fsInP_LOAGRep_LOAGRep sem)- siblings (f, t) = ofld A.! f == ofld A.! t- ofld = (ofld_LOAGRep_LOAGRep sem)- sfp = map2F' (sfp_LOAGRep_LOAGRep sem)- afp = filter inOutput . ap- ap = map (findWithErr pmpr "building ap") . map2F (ap_LOAGRep_LOAGRep sem)- inss = inss_LOAGRep_LOAGRep sem - gen v = genA A.! v- ain = map (findWithErr nmpr "building an") . map2F (ain_LOAGRep_LOAGRep sem)- asn = map (findWithErr nmpr "building an") . map2F (asn_LOAGRep_LOAGRep sem)- inOutput = not . inContext - inContext f = (f1 == "lhs" && d1 == Inh || f1 /= "lhs" && d1 == Syn) - where (MyOccurrence (_,f1) (_,d1)) = pmp Map.! f- de = [ e | p <- ps, e <- dpe p ]- dpe p = [ (findWithErr pmpr "building dpe" a, b) - | b <- ap p, a <- Set.toList $ sfp (findWithErr pmp "fetching sfp" b) ]- ps = ps_LOAGRep_LOAGRep sem- bounds_p = if Map.null pmp then (0,-1) - else (fst $ Map.findMin pmp, fst $ Map.findMax pmp)- bounds_s = if Map.null nmp then (0,-1) - else (fst $ Map.findMin nmp, fst $ Map.findMax nmp)- --- toNt :: Nonterminal -> Nt- toNt (Nonterminal ntid _ _ _ prods) = Nt nt dpf dpt - (addD Inh $ ain ty) (addD Syn $ asn ty) (map (toPr ty) prods)- where nt = getName ntid- ty = TyData nt- dpt = [ (as, ai) | ai <- ain ty- , as <- nub$ [ gen s |- i <- inss A.! ai- , s <- map (pmpr Map.!) $ - Set.toList (sfp $ pmp Map.! i)- , siblings (s,i)]]- dpf = [ (ai, as) | as <- asn ty- , ai <- nub$ [ gen i |- s <- inss A.! as- , i <- map (pmpr Map.!) $- Set.toList (sfp $ pmp Map.! s)- , siblings (i,s)]]- addD d = map (\i -> (i,inss A.! i,d))- toPr :: MyType -> Production -> Pr- toPr ty (Production con _ _ _ _ _ _) = - Pr p dpp fc_occs (map toFd $ fsInP p)- where p = (ty, getName con)- dpp = [ (f',t)- | t <- afp p, f <- (Set.toList $ sfp (pmp Map.! t))- , let f' = pmpr Map.! f- , not (siblings (f',t))]- fc_occs = foldl' match [] fss- where fss = fsInP p- match s fs = [ ready (inp, out) lhs | inp <- Set.toList inhs- , out <- Set.toList syns] ++ s- where ((inhs, syns), lhs)- | (snd fs) /= "lhs" = - (swap (fieldM Map.! fs),False)- | otherwise = (fieldM Map.! fs, True)- ready e@(f,t) b = (e', genEdge e', b)- where e' = (pmpr Map.! f, pmpr Map.! t)- toFd :: (PLabel, FLabel) -> Fd- toFd fs@((TyData ty, pr), fd) = Fd fd ty inhs syns- where (is,ss) = fieldM Map.! fs- inhs = map (((genA A.!) &&& id).(pmpr Map.!))$ Set.toList is- syns = map (((genA A.!) &&& id).(pmpr Map.!))$ Set.toList ss---}
− src-ag/LOAG/Rep.ag
@@ -1,49 +0,0 @@-MODULE {LOAG.Rep}-{}{-import CommonTypes-import AbstractSyntax-import LOAG.Common-import qualified Data.Array as A-import qualified Data.Map as Map-import qualified Data.Set as Set-}-imports{-import Data.List (intercalate, foldl', nub)-import Data.Tuple (swap)-import Control.Arrow-}--DATA LOAGRep | LOAGRep- ps : {[PLabel]}- ap : A_P- an : A_N- ain : AI_N- asn : AS_N- sfp : SF_P - pmp : PMP- pmpr : PMP_R- nmp : NMP- nmpr : NMP_R- gen : {A.Array Int Int}- inss : {A.Array Int [Int]}- ofld : {A.Array Int Int}- fty : FTY- fieldMap : FMap - fsInP: {Map.Map PLabel [(PLabel,FLabel)]}--TYPE FieldAtts = [FieldAtt]--- t is the type of the attribute this occurrence belongs to-DATA FieldAtt | FieldAtt t : {MyType} p : {PLabel} - f : {FLabel} a : {ALabel}--TYPE MySegments = [MySegment]-DATA MySegment | MySegment- visnr : Int - inhAttr : {[Int]}- synAttr : {[Int]}- inhOccs : {Maybe [Int]}- synOccs : {Maybe [Int]}--DERIVING MySegments MySegment : Show--
− src-ag/Macro.ag
@@ -1,24 +0,0 @@---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
@@ -1,809 +0,0 @@-PRAGMA strictdata-PRAGMA strictwrap--INCLUDE "Patterns.ag"-INCLUDE "Expression.ag"-INCLUDE "AbstractSyntax.ag"-INCLUDE "DistChildAttr.ag"--imports-{--- From uuagc-import CommonTypes-import Patterns-import ErrorMessages-import AbstractSyntax-import Code hiding (Type)-import qualified Code-import Expression-import Options-import SequentialComputation-import SequentialTypes-import CodeSyntax-import GrammarInfo-import HsToken(HsTokensRoot(HsTokensRoot))-import SemHsTokens(sem_HsTokensRoot,wrap_HsTokensRoot, Syn_HsTokensRoot(..),Inh_HsTokensRoot(..))--- From uulib-import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified Data.Sequence as Seq-import Data.Map(Map)-import Data.Set(Set)-import Data.Sequence(Seq, (><))-import UU.Util.Utils-import UU.Scanner.Position(Pos(..),initPos)-import Data.Foldable(toList)---- From haskell libraries-import Control.Monad(liftM)-import qualified Data.Array as Array-import Data.Array((!),bounds,inRange)-import Data.List(elemIndex,partition,sort,mapAccumL,find,nubBy,intersperse,groupBy,transpose)-import qualified Data.Tree as Tree-import Data.Maybe-}--{--- Terminates with an error if the key is not in the map-findWithErr1 :: (Ord k, Show k) => String -> k -> Map k a -> a-findWithErr1 s k- = Map.findWithDefault (error ("findWithErr1 " ++ s ++ ": key " ++ show k ++ " not in map.")) k--findWithErr2 :: (Ord k, Show k, Show a) => k -> Map k a -> a-findWithErr2 k m- = Map.findWithDefault (error ("findWithErr2: key " ++ show k ++ " not in map: " ++ show m)) k m-}------- Some statistics, count number of attributes-----ATTR Grammar Nonterminals Nonterminal Productions Production Rules Rule [ | | nAutoRules,nExplicitRules USE {+} {0} : {Int} ]--SEM Rule- | Rule lhs.nExplicitRules = if @explicit- then 1- else 0- lhs.nAutoRules = if startsWith "use rule" @origin || startsWith "copy rule" @origin- then 1- else 0--{-startsWith :: String -> String -> Bool-startsWith k h = k == take (length k) h-}------------------------------------------------------------------------------------- Errors----------------------------------------------------------------------------------- Everyone that wants to report an error can do this by adding an error message to the--- stream of errors--ATTR Nonterminals Nonterminal Productions Production- Child Children Rule Rules Pattern Patterns Grammar [ | | errors USE {Seq.><} {Seq.empty}:{Seq Error} ]------------------------------------------------------------------------------------ Distributing name of nonterminal and names of attributes---------------------------------------------------------------------------------ATTR Productions Production Child Children Rules Rule Patterns Pattern [ nt : {Identifier} inh,syn : {Attributes} | | ]-ATTR Child Children Rules Rule Patterns Pattern [ con : {Identifier} | | ]--SEM Production- | Production children . con = @con-SEM Production- | Production rules . con = @con-SEM Nonterminal- | Nonterminal prods . nt = @nt--SEM Nonterminal- | Nonterminal prods.inh = @inh- prods.syn = @syn------------------------------------------------------------------------------------- Distributing options----------------------------------------------------------------------------------ATTR Grammar [ options:{Options} | | ]-ATTR Nonterminals Nonterminal Productions Production Rules Rule- [ o_newtypes- , o_cata- , o_sig- , o_sem- , o_rename- , o_wantvisit -- True if the option for visit functions has been specified- , o_dovisit -- True if o_wantvisit and it is possible to generate visit functions (no cycles)- , o_case:{Bool}- prefix : {String} | | ]-ATTR Nonterminals Nonterminal Productions Production Children Child [ o_unbox:{Bool} | | ]-ATTR Nonterminals Nonterminal [ o_data:{Bool} | | ]--SEM Grammar- | Grammar loc.o_dovisit = visit @lhs.options && null @cyclesErrors- nonts.o_cata = folds @lhs.options- .o_data = dataTypes @lhs.options- .o_sig = typeSigs @lhs.options- .o_sem = semfuns @lhs.options- .o_rename = rename @lhs.options- .o_newtypes= newtypes @lhs.options- .o_wantvisit = visit @lhs.options- .o_unbox = unbox @lhs.options- .o_case = cases @lhs.options- .prefix = prefix @lhs.options----------------------------------------------------------------------- Building a mapping from Vertices to Ints--------------------------------------------------------------------{-getNtName :: Type -> NontermIdent-getNtName (NT nt _ _) = nt-getNtName _ = nullIdent-}----------------------------------------------------------------------- Collect attribute occurrences------ All attribute occurences in an alternative are gathered.--- This is done by joining various sublists:--- 1. inherited attributes for _LHS--- 2a. synthesized attributes for children--- 2b. children that are a trivial field--- 3a. inherited attributes for children--- 3b. synthesized attributes for _LHS--- 3c. local attributes------ Sublist 3 is exactly the targets for ATTR definitions, and--- thus can be obtained by traversing all rules.------ The (field,attr) combination is not enough to uniquely identify--- an attribute occurence, because threaded attributes occur twice.--- Therefore, in the AltAttr structures, a boolean is added,--- that is False in sublists 3a and 3b, i.e. the non-local output fields.------ Each AltAttr, that is eacht attribute occurence, is mapped to a number--- in the altAttrs Map, starting at vcount-{-data AltAttr = AltAttr Identifier Identifier Bool- deriving (Eq, Ord, Show)-}-ATTR Rules Rule Production Productions Nonterminal Nonterminals- [ options : {Options} | | ]--ATTR Children Child Rules Rule Patterns Pattern [ | | gathAltAttrs USE {++} {[]} : {[AltAttr]} ]-SEM Production- | Production loc.gathAltAttrs = [ AltAttr _LHS inh True | inh <- Map.keys @lhs.inh ] -- sublist 1- ++ @children.gathAltAttrs -- sublist 2- ++ @rules.gathAltAttrs -- sublist 3--SEM Child- | Child loc.maptolocal = case @tp of- 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 @loc.syn ] -- sublist 2a-SEM Pattern- | Alias lhs.gathAltAttrs = [AltAttr @field @attr (@field == _LOC || @field == _INST)] -- sublist 3--ATTR Rules Rule Patterns Pattern [ altAttrs : {Map AltAttr Vertex} | | ]-SEM Production- | Production loc.altAttrs = Map.fromList (zip @gathAltAttrs [@lhs.vcount..])---- Information passed to Pattern-ATTR Children Child- [ | | nts USE {Seq.><} {Seq.empty} : {Seq (Identifier,NontermIdent)}- inhs USE {Seq.><} {Seq.empty} : {Seq (Identifier,Attributes)} ]-SEM Child- | Child lhs.nts = Seq.singleton (@name,getNtName @tp)- lhs.inhs = Seq.singleton (@name,@loc.inh)-ATTR Rules Rule- [ childNts : {Map Identifier NontermIdent}- childInhs : {Map Identifier Attributes} | | ]-SEM Production- | Production rules.childNts = Map.fromList (toList @children.nts)- rules.childInhs = Map.fromList (toList @children.inhs)---- Collect CRules-ATTR Children Child Rules Rule- [ | | gathRules USE {Seq.><} {Seq.empty} : {Seq CRule} ]-SEM Production- | Production loc.inhRules = [ cRuleLhsInh inh @lhs.nt @con tp | (inh,tp) <- Map.assocs @lhs.inh ]- loc.gathRules = @inhRules ++ toList (@children.gathRules Seq.>< @rules.gathRules)--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 @loc.syn]--SEM Rule- | 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 _) = 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)))- | (field,attr,isLocalOrInst) <- @pattern.patternAttrs- , let aa = AltAttr field attr isLocalOrInst- ]- loc.gathRules = let childnt field = Map.lookup field @lhs.childNts- in Seq.fromList [ CRule attr False True @lhs.nt @lhs.con field (childnt field) tp @pattern.copy @rhs.textLines @defines @owrt @origin @rhs.allRhsVars @explicit @mbName- | (field,attr,tp) <- Map.elems @defines- ]--{-substSelf nt tp- = case tp of- 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)]} ]--SEM Pattern- | Alias lhs.patternAttrs = [(@field,@attr,(@field == _LOC || @field == _INST))]------ Giving them a number-ATTR Nonterminals Nonterminal Productions Production- [ | vcount : Int- | rules USE {Seq.><} {Seq.empty} : {Seq (Vertex,CRule)}]-SEM Grammar- | Grammar nonts.vcount = 0-SEM Production- | Production lhs.rules = Seq.fromList (zip [@lhs.vcount..] @gathRules)- lhs.vcount = @lhs.vcount + length @gathRules---- Direct dependencies-ATTR Nonterminals Nonterminal- Productions Production- Rules Rule [ | | directDep USE {Seq.><} {Seq.empty} : {Seq Edge} ]-SEM Rule- | Rule lhs.directDep- = let defined = Map.keys @defines- used = [ Map.lookup (AltAttr field attr True) @lhs.altAttrs | (field,attr) <- @rhs.usedAttrs]- ++ [ Map.lookup (AltAttr _LOC attr True) @lhs.altAttrs | attr <- @rhs.usedLocals ++ @rhs.usedFields ]- in Seq.fromList [ (x,y) | Just x <- used, y <- defined ]---- Manual depdendencies (provided by the programmer)------ a dependency f1.a1 < f2.a2 is translated to--- the edge (vertex(f1.a1), vertex(f2.a2))-ATTR Nonterminals Nonterminal- Productions Production- [ manualAttrDepMap : {AttrOrderMap} | | additionalDep USE {Seq.><} {Seq.empty} : {Seq Edge} ]--SEM Grammar- | Grammar- nonts.manualAttrDepMap = @manualAttrOrderMap--SEM Production- | Production- loc.manualDeps- = Set.toList $ Map.findWithDefault Set.empty @con $ Map.findWithDefault Map.empty @lhs.nt @lhs.manualAttrDepMap-- lhs.additionalDep- = Seq.fromList [ (vertex True occA, vertex False occB)- | Dependency occA occB <- @loc.manualDeps- , let vertex inout (OccAttr child nm)- | child == _LOC = findWithErr2 (AltAttr _LOC nm True) @loc.altAttrs- | otherwise = findWithErr2 (AltAttr child nm inout) @loc.altAttrs- vertex _ (OccRule nm)- = findWithErr2 (AltAttr _LOC (Ident ("_rule_" ++ show nm) (getPos nm)) True) @loc.altAttrs- ]---- Inst dependencies------ For each inst attribute x of nt N, add the dependency--- (inst.x,x.y) for each synthesized attribute of N-----ATTR Nonterminals Nonterminal- Productions Production- Rules Rule [ | | instDep USE {Seq.><} {Seq.empty} : {Seq Edge} ]-SEM Rule- | Rule- loc.instDep1- = Seq.fromList $- [ (instVert, synVert)- | (field,instNm,_) <- Map.elems @defines- , field == _INST- , synNm <- Map.keys (findWithErr2 instNm @lhs.synsOfChildren)- , let instAttr = AltAttr _INST instNm True- synAttr = AltAttr instNm synNm True- instVert = findWithErr2 instAttr @lhs.altAttrs- synVert = findWithErr2 synAttr @lhs.altAttrs- ]- loc.instDep2- = Seq.fromList $- [ (instVert, inhVert)- | (field,instNm,_) <- Map.elems @defines- , field == _INST- , inhNm <- Map.keys (findWithErr2 instNm @lhs.inhsOfChildren)- , let instAttr = AltAttr _INST instNm True- inhAttr = AltAttr instNm inhNm False- instVert = findWithErr2 instAttr @lhs.altAttrs- inhVert = findWithErr2 inhAttr @lhs.altAttrs- ]- lhs.instDep = @loc.instDep1 Seq.>< @loc.instDep2--ATTR Rules Rule [ synsOfChildren, inhsOfChildren : {Map Identifier Attributes} | | ]-SEM Production- | Production rules.synsOfChildren = @children.collectChildrenSyns- rules.inhsOfChildren = @children.collectChildrenInhs--ATTR Children Child [ | | collectChildrenSyns, collectChildrenInhs USE {`Map.union`} {Map.empty} : {Map Identifier Attributes } ]-SEM Child- | Child lhs.collectChildrenSyns = Map.singleton @name @loc.syn- lhs.collectChildrenInhs = Map.singleton @name @loc.inh------- Merge stuff-----ATTR Nonterminals Nonterminal- [ mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))} | | ]--ATTR Productions Production- [ mergeMap : {Map ConstructorIdent (Map Identifier (Identifier,[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--ATTR Rules Rule Children Child Expression [ mergeMap : {Map Identifier (Identifier,[Identifier])} | | ]---- for a child c : N, with merged children cs, add dependencies between synthesized attrs of--- c to synthesized attrs of cs, and to the merge-attribute-ATTR Nonterminals Nonterminal Productions Production- [ | | mergeDep USE {Seq.><} {Seq.empty} : {Seq Edge} ]--SEM Production- | Production- lhs.mergeDep = @loc.mergeDep1 Seq.>< @loc.mergeDep2- loc.mergeDep1- = Seq.fromList $- [ (childVert, synVert)- | childNm <- Map.keys @loc.mergeMap- , synNm <- Map.keys (findWithErr2 childNm @children.collectChildrenSyns)- , let childNm' = Ident (show childNm ++ "_merge") (getPos childNm)- childAttr = AltAttr _LOC childNm' True- synAttr = AltAttr childNm synNm True- childVert = findWithErr2 childAttr @loc.altAttrs- synVert = findWithErr2 synAttr @loc.altAttrs- ]- loc.mergeDep2- = Seq.fromList $- [ (mergedVert, sourceVert)- | (childNm, (_,cs)) <- Map.assocs @loc.mergeMap- , c <- cs- , synNm <- Map.keys (findWithErr2 childNm @children.collectChildrenSyns)- , let sourceAttr = AltAttr childNm synNm True- mergedAttr = AltAttr c synNm True- sourceVert = findWithErr2 sourceAttr @loc.altAttrs- mergedVert = findWithErr2 mergedAttr @loc.altAttrs- ]----- Around dependencies------ For each around x_around on x of nt N, add the dependency--- (x_around, x.y) for each synthesized attribute y of N-----ATTR Nonterminals Nonterminal- Productions Production- [ | | aroundDep USE {Seq.><} {Seq.empty} : {Seq Edge} ]--ATTR Nonterminals Nonterminal- [ aroundMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} || ]--ATTR Productions Production- [ aroundMap : {Map ConstructorIdent (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 Production- | Production- loc.aroundDep1- = Seq.fromList $- [ (childVert, synVert)- | childNm <- Map.keys @loc.aroundMap- , synNm <- Map.keys (findWithErr2 childNm @children.collectChildrenSyns)- , let childNm' = Ident (show childNm ++ "_around") (getPos childNm)- childAttr = AltAttr _LOC childNm' True- synAttr = AltAttr childNm synNm True- childVert = findWithErr2 childAttr @loc.altAttrs- synVert = findWithErr2 synAttr @loc.altAttrs- ]- loc.aroundDep2- = Seq.fromList $- [ (childVert, inhVert)- | childNm <- Map.keys @loc.aroundMap- , inhNm <- Map.keys (findWithErr2 childNm @children.collectChildrenInhs)- , let childNm' = Ident (show childNm ++ "_around") (getPos childNm)- childAttr = AltAttr _LOC childNm' True- inhAttr = AltAttr childNm inhNm False- childVert = findWithErr2 childAttr @loc.altAttrs- inhVert = findWithErr2 inhAttr @loc.altAttrs- ]- lhs.aroundDep = @loc.aroundDep1 Seq.>< @loc.aroundDep2----- Wrapping an Expression--ATTR Expression [ nt,con :{Identifier}- allfields:{[(Identifier,Type,ChildKind)]}- allnts :{[Identifier]}- attrs :{[(Identifier,Identifier)]}- options :{Options}- ||- errors :{Seq Error}- usedLocals:{[Identifier]}- usedAttrs :{[(Identifier,Identifier)]}- usedFields:{[Identifier]}- textLines :{[String]}- copy : SELF- allRhsVars : {Set (Identifier,Identifier)}- ]---- appendum: filter out the syn attrs of merged children in the input attr list.--- add the merged children to the used attr list--- appendum: ignored the error reporting on expressions. These are already--- reported by the separate 'ResolveLocals' pass.-SEM Expression- | Expression loc.(textLines,usedAttrs,usedLocals,usedFields)- = let mergedChildren = [ x | (_,xs) <- Map.elems @lhs.mergeMap, x <- xs ]- attrsIn = filter (\(fld,_) -> not (fld `elem` mergedChildren)) @lhs.attrs- inherited = Inh_HsTokensRoot- { attrs_Inh_HsTokensRoot = attrsIn- , con_Inh_HsTokensRoot = @lhs.con- , allfields_Inh_HsTokensRoot = @lhs.allfields- , allnts_Inh_HsTokensRoot = @lhs.allnts- , nt_Inh_HsTokensRoot = @lhs.nt- , options_Inh_HsTokensRoot = @lhs.options- }- synthesized = wrap_HsTokensRoot (sem_HsTokensRoot (HsTokensRoot @tks)) inherited- in case synthesized of- Syn_HsTokensRoot- { textLines_Syn_HsTokensRoot = textLines- , usedAttrs_Syn_HsTokensRoot = usedAttrs- , usedLocals_Syn_HsTokensRoot = usedLocals- , usedFields_Syn_HsTokensRoot = usedFields- } -> let extraAttrs = [ (src,attr)- | (fld,attr) <- usedAttrs, let mbMerged = Map.lookup fld @lhs.mergeMap, isJust mbMerged- , let (Just (_, srcs)) = mbMerged, src <- srcs ]- usedAttrs' = usedAttrs ++ extraAttrs- in (textLines,usedAttrs',usedLocals,usedFields)-- lhs.errors = Seq.empty- lhs.allRhsVars = Set.fromList @loc.usedAttrs- `Set.union`- Set.fromList [ (_LOC, l) | l <- @loc.usedLocals]- `Set.union`- Set.fromList [ (_FIELD, fld) | fld <- @loc.usedFields]------------------------------------------- NT-Attributes---------------------------------------ATTR Nonterminals Nonterminal- [ | acount : Int | ntattrs USE {Seq.><} {Seq.empty} : {Seq (Vertex,NTAttr)}- aranges USE {Seq.><} {Seq.empty} : {Seq (Int,Int,Int)}]--SEM Grammar- | Grammar nonts.acount = 0--SEM Nonterminal- | Nonterminal loc.ntattrs = [ NTAInh @nt inh tp | (inh,tp) <- Map.assocs @inh ]- ++ [NTASyn @nt syn tp | (syn,tp) <- Map.assocs @syn ]- lhs.ntattrs = Seq.fromList (zip [@lhs.acount ..] @ntattrs)- lhs.acount = @lhs.acount + Map.size @inh + Map.size @syn- lhs.aranges = Seq.singleton- (@lhs.acount- ,@lhs.acount + Map.size @inh- ,@lhs.acount + Map.size @syn + Map.size @inh - 1)---------------------------------------------------------------------- Pass structure up--------------------------------------------------------------------ATTR Nonterminals Nonterminal [ | | nonts USE {++} {[]} : {[(NontermIdent,[ConstructorIdent])]} ]-SEM Nonterminal- | Nonterminal lhs.nonts = [(@nt,@prods.cons)]-ATTR Productions Production [ | | cons USE {++} {[]} : {[ConstructorIdent]} ]-SEM Production- | Production lhs.cons = [@con]----------------------------------------------------------------------- Collect type signatures--------------------------------------------------------------------ATTR TypeSigs TypeSig [ | typeSigs : {Map Identifier Type} | ]-SEM Production- | Production typeSigs.typeSigs = Map.empty-SEM TypeSig- | TypeSig lhs.typeSigs = Map.insert @name @tp @lhs.typeSigs--ATTR Rules Rule Patterns Pattern [ allTypeSigs : {Map Identifier Type} | | ]-SEM Production- | Production rules.allTypeSigs = @typeSigs.typeSigs----------------------------------------------------------------------- Invoking sequential computation--------------------------------------------------------------------SEM Grammar- | Grammar loc.ruleTable = Array.array (0,@nonts.vcount-1) (toList @nonts.rules)- loc.attrTable = Array.array (0,@nonts.acount-1) (toList @nonts.ntattrs)- loc.attrVertex = Map.fromList (map swap (toList @nonts.ntattrs))- loc.tdpToTds = [ (s, maybe (-1) (\v -> findWithErr1 "Grammar.tdpToTds" v @attrVertex) (ntattr cr))- | (s,cr) <- toList @nonts.rules]- loc.tdsToTdp = let eq (_,v) (_,v') = v == v'- conv ((s,v):svs) | v == -1 = Nothing- | otherwise = Just (v,s:map fst svs)- in mapMaybe conv (eqClasses eq @tdpToTds)- loc.directDep = toList (@nonts.directDep Seq.>< @nonts.additionalDep)- loc.instDep = toList @nonts.instDep- loc.aroundDep = toList @nonts.aroundDep- loc.mergeDep = toList @nonts.mergeDep- loc.info = let def [] = -1- def (v:vs) = v- in Info { tdsToTdp = Array.array (0,@nonts.acount-1) @tdsToTdp- , tdpToTds = Array.array (0,@nonts.vcount-1) @tdpToTds- , attrTable = @attrTable- , ruleTable = @ruleTable- , lmh = toList @nonts.aranges- , nonts = @nonts.nonts- , wraps = @wrappers- }-- loc.(cInterfaceMap,cVisitsMap,cyclesErrors) =- case computeSequential @info @directDep (@instDep ++ @aroundDep ++ @loc.mergeDep) of- CycleFree cim cvm -> ( cim- , cvm- , []- )- LocalCycle errs -> ( error "No interfaces for AG with local cycles"- , error "No visit sub-sequences for AG with local cycles"- , map (localCycleErr @ruleTable (visit @lhs.options)) errs- )- InstCycle errs -> ( error "No interfaces for AG with cycles through insts"- , error "No visit sub-sequences for AG with cycles through insts"- , map (instCycleErr @ruleTable (visit @lhs.options)) errs- )- DirectCycle errs -> ( error "No interfaces for AG with direct cycles"- , error "No visit sub-sequences for AG with direct cycles"- , directCycleErrs @attrTable @ruleTable (visit @lhs.options) errs- )- InducedCycle cim errs -> ( cim- , error "No visit sub-sequences for AG with induced cycles"- , inducedCycleErrs @attrTable @ruleTable cim errs- )- lhs.errors = (if withCycle @lhs.options then Seq.fromList @cyclesErrors else Seq.empty)- Seq.>< @nonts.errors----------------------------------------------------------------------- Generate CGrammar---------------------------------------------------------------------- Pass InterfaceMap down and select the Interface in the Nonterminal-ATTR Nonterminals Nonterminal [ cInterfaceMap : CInterfaceMap | | ]-SEM Nonterminal- | Nonterminal loc.cInter = if @lhs.o_dovisit- then findWithErr1 "Nonterminal.cInter" @nt @lhs.cInterfaceMap- else CInterface [CSegment @inh @syn]---- Pass VisitMap down and select the CVisits in the Production-ATTR Nonterminals Nonterminal Productions Production [ cVisitsMap : CVisitsMap | | ]-SEM Production- | Production loc.cVisits = if @lhs.o_dovisit- then let prodsVisitsMap = findWithErr1 "Production.cVisits.nt" @lhs.nt @lhs.cVisitsMap- visits = findWithErr1 "Production.cVisits.con" @con prodsVisitsMap- in visits- else let vss = nubBy eqCRuleDefines @gathRules ++ @children.singlevisits- in [CVisit @lhs.inh @lhs.syn vss [] False]---- Declarations for single visits-ATTR Child Children [ | | singlevisits USE {++} {[]}: {[CRule]}]-SEM Child- | Child lhs.singlevisits = if @maptolocal- then []- else [CChildVisit @name (getNtName @tp) 0 @loc.inh @loc.syn True]---- Now just build the CGrammar-SEM Grammar [ | | output : CGrammar ]- | Grammar lhs.output = CGrammar @typeSyns @derivings @wrappers @nonts.cNonterminals @pragmas @paramMap @contextMap @quantMap @loc.aroundMap @loc.mergeMap @loc.o_dovisit-SEM Nonterminals [ | | cNonterminals : CNonterminals ]- | Cons lhs.cNonterminals = @hd.cNonterminal : @tl.cNonterminals- | Nil lhs.cNonterminals = []-SEM Nonterminal [ | | cNonterminal : CNonterminal ]- | Nonterminal lhs.cNonterminal = CNonterminal @nt @params @inh @syn @prods.cProductions @cInter-SEM Productions [ | | cProductions : CProductions ]- | Cons lhs.cProductions = @hd.cProduction : @tl.cProductions- | Nil lhs.cProductions = []-SEM Production [ | | cProduction : CProduction ]- | Production lhs.cProduction = CProduction @con @cVisits @children.fields @children.terminals--SEM Grammar- | Grammar loc.aroundMap = Map.map (Map.map Map.keysSet) @aroundsMap- loc.mergeMap = Map.map (Map.map (Map.map (\(nt,srcs,_) -> (nt,srcs)))) @mergeMap---- Collect terminals-ATTR Children Child [ | | terminals USE {++} {[]} : {[Identifier]} ]-SEM Child- | Child lhs.terminals = if @maptolocal- then [@name]- else []----- Collecting nts-ATTR Nonterminal Nonterminals- Production Productions- Rule Rules- Child Children [allnts:{[Identifier]} | | ]--SEM Grammar- | Grammar nonts.allnts = map fst (@nonts.nonts)---- Collecting fields-ATTR Rule Rules- Child Children [allfields:{[(Identifier,Type,ChildKind)]} attrs:{[(Identifier,Identifier)]} | | ]--SEM Production- | Production loc.allfields = @children.fields- .attrs = map ((,) _LOC) @rules.locVars ++- map ((,) _INST) @rules.instVars ++- map ((,) _LHS) @inhnames ++- concat [map ((,) nm) (Map.keys as) | (nm,_,as) <- @children.attributes]- .inhnames = Map.keys @lhs.inh- .synnames = Map.keys @lhs.syn--ATTR Children [ | | attributes USE {++} {[]} : {[(Identifier,Attributes,Attributes)]} ]-SEM Child [ | | attributes:{[(Identifier,Attributes,Attributes)]} ]- | Child lhs.attributes = [(@name, @loc.inh, @loc.syn)]---SEM Child [ | | field : {(Identifier,Type,ChildKind)} ]- | Child lhs.field = (@name, @tp, @kind)--SEM Children [ | | fields : {[(Identifier,Type,ChildKind)]} ]- | Cons lhs.fields = @hd.field : @tl.fields- | Nil lhs.fields = []--ATTR Rules Rule Patterns Pattern [ | | locVars USE {++} {[]}:{[Identifier]} instVars USE {++} {[]} : {[Identifier]} ]--SEM Pattern- | Alias lhs.locVars = if @field == _LOC- then [@attr]- else []- lhs.instVars = if @field == _INST- then [@attr]- else []--{-swap (a,b) = (b,a)--showPath :: Table CRule -> [Vertex] -> [String]-showPath ruleTable path- = let look a | inRange (bounds ruleTable) a = [showOrigin (ruleTable ! a)]- | otherwise = ["Vertex " ++ show a]- showOrigin cr | getHasCode cr && getName (getAttr cr) /= "self" = prettyCRule cr ++ " (" ++ show (getPos (getAttr cr)) ++ ")"- | otherwise = prettyCRule cr- in concatMap look path---showPathLocal :: Table CRule -> [Vertex] -> [String]-showPathLocal _ [] = []-showPathLocal ruleTable xs = showP (xs++[-1])- where showP [] = []- showP (v1:v2:vs) = let line = step v1 v2- lines = showP vs- in line:lines- step v1 v2 = " - " ++ a1- where r1 = ruleTable ! v1- a1 = show (getAttr r1)---limitTo :: Int -> [String] -> [String]-limitTo _ [] = []-limitTo 0 _ = ["....etcetera, etcetera...."]-limitTo n (x:xs) = x : limitTo (n-1) xs--showPathNice :: Table CRule -> [Vertex] -> [String]-showPathNice _ [] = []-showPathNice ruleTable xs = limitTo 100 (showP ((-1):xs++[-1]))- where [maxf, maxa, maxn, maxc] = maxWidths ruleTable (take 100 xs)- showP [] = []- showP (v1:v2:vs) = let line = step v1 v2- lines = showP vs- in if null line then lines else line:lines- step v1 v2 | last && first = induced- | last && isSyn r1 = "pass up " ++ alignR maxf "" ++ " " ++ alignL maxa a1 ++ " in " ++ alignR maxn n1 ++ "|" ++ c1 ++ induced- | first&& not(isSyn r2) = "get from above " ++ alignR maxf "" ++ " " ++ alignL maxa a2 ++ " in " ++ alignR maxn n2 ++ "|" ++ c2- | last = "pass down " ++ alignR maxf f1 ++ "." ++ a1 ++ induced- | isSyn r2 = "get from below " ++ alignR maxf f2 ++ "." ++ alignL maxa a2 ++ " in " ++ alignR maxn n2 ++ "|" ++ c2- | isLocal r1 = if head a1 == '_'- then ""- else "calculate " ++ alignR maxf "loc" ++ "." ++ a1- | otherwise = "pass down " ++ alignR maxf f1 ++ "." ++ alignL maxa a1 ++ " to " ++ alignR maxn n2 ++ "|" ++ c2- where- first = v1<0- last = v2<0- r1 = ruleTable ! v1- r2 = ruleTable ! v2- a1 = show (getAttr r1)- a2 = show (getAttr r2)- f1 = show (getField r1)- f2 = show (getField r2)- n1 = show (getLhsNt r1)- n2 = show (getLhsNt r2)- c1 = show (getCon r1)- c2 = show (getCon r2)- induced | v2== -2 = " INDUCED dependency to "- | otherwise = ""---maxWidths ruleTable vs- = map maximum (transpose (map getWidth vs))- where getWidth v | v<0 = [0,0,0,0]- | otherwise = map (length . show . ($ (ruleTable!v))) [getField, getAttr, getLhsNt, getCon]--alignL n xs | k<n = xs ++ replicate (n-k) ' '- | otherwise = xs- where k = length xs--alignR n xs | k<n = replicate (n-k) ' ' ++ xs- | otherwise = xs- where k = length xs--localCycleErr :: Table CRule -> Bool -> Route -> Error-localCycleErr ruleTable o_visit (s:path)- = let cr = ruleTable ! s- attr = getAttr cr- nt = getLhsNt cr- con = getCon cr- in LocalCirc nt con attr o_visit (showPathLocal ruleTable path)--instCycleErr :: Table CRule -> Bool -> Route -> Error-instCycleErr ruleTable o_visit (s:path)- = let cr = ruleTable ! s- attr = getAttr cr- nt = getLhsNt cr- con = getCon cr- in InstCirc nt con attr o_visit (showPathLocal ruleTable path)--directCycleErrs :: Table NTAttr -> Table CRule -> Bool -> [EdgeRoutes] -> [Error]-directCycleErrs attrTable ruleTable o_visit xs- = let getNont v = case attrTable ! v of- NTASyn nt _ _ -> nt- NTAInh nt _ _ -> nt- getAttr v = case attrTable ! v of- NTASyn _ a _ -> a- NTAInh _ a _ -> a- sameNont ((v1,_),_,_) ((v2,_),_,_) = getNont v1 == getNont v2- procCycle ((v1,v2),p1,p2) = ((getAttr v1, getAttr v2), showPathNice ruleTable p1, showPathNice ruleTable p2)- wrapGroup gr@(((v1,_),_,_):_) = DirectCirc (getNont v1) o_visit (map procCycle gr)- in map wrapGroup (groupBy sameNont xs)--inducedCycleErrs :: Table NTAttr -> Table CRule -> CInterfaceMap -> [EdgeRoutes] -> [Error]-inducedCycleErrs attrTable ruleTable cim xs- = let getNont v = case attrTable ! v of- NTASyn nt _ _ -> nt- NTAInh nt _ _ -> nt- getAttr v = case attrTable ! v of- NTASyn _ a _ -> a- NTAInh _ a _ -> a- sameNont ((v1,_),_,_) ((v2,_),_,_) = getNont v1 == getNont v2- procCycle ((v1,v2),p1,p2) = ((getAttr v1, getAttr v2), showPathNice ruleTable p1, showPathNice ruleTable p2)- wrapGroup gr@(((v1,_),_,_):_) = InducedCirc (getNont v1) (findWithErr1 "inducedCycleErr.cinter" (getNont v1) cim) (map procCycle gr)- in map wrapGroup (groupBy sameNont xs)-}
− src-ag/Patterns.ag
@@ -1,25 +0,0 @@-imports-{--- Patterns.ag imports-import UU.Scanner.Position(Pos)-import CommonTypes (ConstructorIdent,Identifier)-}--TYPE Patterns = [Pattern]--DATA Pattern | Constr name : {ConstructorIdent}- pats : Patterns- | Product pos : {Pos}- pats : Patterns- | Alias field : {Identifier}- attr : {Identifier}- pat : Pattern- | Irrefutable pat : Pattern- | Underscore pos : {Pos}--DERIVING Pattern:Show--ATTR AllPattern [ | | copy : SELF ]--SET AllPattern- = Pattern Patterns
− src-ag/PrintCleanCode.ag
@@ -1,563 +0,0 @@-PRAGMA strictdata-PRAGMA optimize-PRAGMA bangpats-PRAGMA strictwrap--INCLUDE "Code.ag"-INCLUDE "Patterns.ag"--imports-{-import Data.Char (isAlphaNum)-import Pretty-import Code-import Options-import CommonTypes (attrname, _LOC, nullIdent)-import Data.List(intersperse)-import System.IO-import System.Directory-import System.FilePath-import CommonTypes(BlockInfo, BlockKind(..))-}--{-type PP_Docs = [PP_Doc]-}--{-ppMultiSeqH :: [PP_Doc] -> PP_Doc -> PP_Doc-ppMultiSeqH = ppMultiSeq' (>#<)--ppMultiSeqV :: [PP_Doc] -> PP_Doc -> PP_Doc-ppMultiSeqV = ppMultiSeq' (>-<)--ppMultiSeq' :: (PP_Doc -> PP_Doc -> PP_Doc) -> [PP_Doc] -> PP_Doc -> PP_Doc-ppMultiSeq' next strictArgs expr- = foldr (\v r -> (v >#< "`seq`") `next` pp_parens r) expr strictArgs-}--ATTR Expr Exprs Decl Decls CaseAlt CaseAlts Lhs [ outputfile : {String} | | ]--SEM Chunk- | Chunk- loc.outputfile = if sepSemMods @lhs.options- then replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_" ++ @name)- else @lhs.mainFile--ATTR Program [ options:{Options} | | output:{PP_Docs} ]--ATTR Expr Exprs Decl Decls Chunk Chunks CaseAlts CaseAlt Lhs Pattern Patterns [ options:{Options} | | ]--ATTR Expr Decl DataAlt Type NamedType Lhs [ nested:{Bool} | | pp:{PP_Doc} ]-ATTR Decl DataAlt NamedType [ | | ppa USE {>-<} {empty} : {PP_Doc}]--ATTR Exprs DataAlts Types NamedTypes Decls Chunk Chunks [ nested:{Bool} | | pps : {PP_Docs} ]-ATTR DataAlts NamedTypes [ | | ppas : {PP_Docs} ]--ATTR CaseAlt CaseAlts [ nested:{Bool} | | pps: {PP_Docs} ]--ATTR Type Types [ | | copy : SELF]--SEM Program | Program- loc.options = @lhs.options { breadthFirst = breadthFirst @lhs.options && visit @lhs.options && cases @lhs.options && @ordered }--SEM Program- | Program chunks.nested = nest @lhs.options--SEM Exprs- | Cons lhs.pps = @hd.pp : @tl.pps- | Nil lhs.pps = []--SEM CaseAlts- | Cons lhs.pps = @hd.pps ++ @tl.pps- | Nil lhs.pps = []--SEM DataAlts- | Cons lhs.pps = @hd.pp : @tl.pps- lhs.ppas = @hd.ppa : @tl.ppas- | Nil lhs.pps = []- lhs.ppas = []--SEM Types- | Cons lhs.pps = @hd.pp : @tl.pps- | Nil lhs.pps = []--SEM NamedTypes- | Cons lhs.pps = @hd.pp : @tl.pps- lhs.ppas = @hd.ppa : @tl.ppas- | Nil lhs.pps = []- lhs.ppas = []--SEM Decls- | Cons lhs.pps = @hd.pp : @tl.pps- | Nil lhs.pps = []--SEM Chunks- | Cons lhs.pps = @hd.pps ++ @tl.pps- | Nil lhs.pps = []---SEM Program- | Program lhs.output = @chunks.pps--SEM Chunk- | Chunk lhs.pps = @comment.pp- : @info.pps- ++ @dataDef.pps- ++ @cataFun.pps- ++ @semDom.pps- ++ @semWrapper.pps- ++ @semFunctions.pps- ++ [Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap]--SEM Decl- | Decl lhs.pp = @left.pp >#< "="- >-< indent 4 @rhs.pp- | Bind lhs.pp = @left.pp >#< "<-" >#< @rhs.pp- | BindLet lhs.pp = "let" >#< @left.pp >#< "=" >#< @rhs.pp- | Data lhs.pp = "::" >#< hv_sp (@name : @params)- >#< ( case @alts.pps of- [] -> empty- (x:xs) -> "=" >#< x- >-< vlist (map ("|" >#<) xs)- >-< if null @derivings- then empty- else "deriving" >#< ppTuple False (map text @derivings)- )- >-< foldr (>-<) empty @alts.ppas-- | NewType lhs.pp = "::" >#< hv_sp (@name : @params) >#< "=" >#< @con >#< pp_parens @tp.pp- | Type lhs.pp = "::" >#< hv_sp (@name : @params) >#< ":==" >#< @tp.pp- | TSig lhs.pp = @name >#< "::" >#< @tp.pp- | Comment lhs.pp = if '\n' `elem` @txt- then "/*" >-< vlist (lines @txt) >-< "*/"- else "//" >#< @txt- | PragmaDecl lhs.pp = "/*#" >#< text @txt >#< "#*/" -- Not used in Clean- | Resume lhs.pp = if @monadic- then @left.pp >#< "<-" >#< @rhs.pp- else @left.pp >#< "=" >-< indent 4 @rhs.pp- | EvalDecl loc.strat = if breadthFirstStrict @lhs.options- then "stepwiseEval"- else "lazyEval"- lhs.pp = if breadthFirst @lhs.options- then @left.pp >#< "=" >#< "case" >#< @loc.strat >#< pp_parens @rhs.pp >#< "of"- >-< indent 4 (- pp_parens (@nt >|< "_Syn" >#< "_val") >#< "-> _val"- )- else @left.pp >#< "=" >#< @rhs.pp--SEM Expr- | Let lhs.pp = pp_parens ( "let" >#< (vlist @decls.pps)- >-< "in " >#< @body.pp- )- | Case lhs.pp = pp_parens ( "case" >#< pp_parens @expr.pp >#< "of"- >-< (vlist @alts.pps)- )- | Do lhs.pp = pp_parens ( "do" >#< ( vlist @stmts.pps- >-< ("return" >#< @body.pp))- )- | Lambda loc.strictParams = if strictSems @lhs.options- then @args.pps- else []- loc.addBang = if bangpats @lhs.options- then \p -> pp_parens ("!" >|< p)- else id- lhs.pp = pp_parens ( "\\" >#< (vlist (map @loc.addBang @args.pps)) >#< "->"- >-< indent 4 (@loc.strictParams `ppMultiSeqV` @body.pp)- )- | TupleExpr lhs.pp = ppTuple @lhs.nested @exprs.pps- | UnboxedTupleExpr lhs.pp = ppUnboxedTuple @lhs.nested @exprs.pps- | App lhs.pp = pp_parens $ @name >#< hv_sp @args.pps- | SimpleExpr lhs.pp = text @txt- | TextExpr lhs.pp = vlist (map text @lns)- | Trace lhs.pp = "trace" >#< ( pp_parens ("\"" >|< text @txt >|< "\"")- >-< pp_parens @expr.pp- )- | PragmaExpr lhs.pp = let pragmaDoc = "/*#" >#< @txt >#< "#*/" -- Not used in Clean- op = if @onNewLine- then (>-<)- else (>#<)- leftOp x y = if @onLeftSide- then x `op` y- else y- rightOp x y = if @onLeftSide- then x- else x `op` y- in pp_parens (pragmaDoc `leftOp` @expr.pp `rightOp` pragmaDoc)- | LineExpr lhs.pp = @expr.pp >-< "/*# LINE" >#< ppWithLineNr (\n -> pp $ show $ n + 1) >#< show @lhs.outputfile >#< "#*/"- >-< ""- | TypedExpr lhs.pp = pp_parens (@expr.pp >#< "::" >#< @tp.pp)- | ResultExpr lhs.pp = if breadthFirst @lhs.options- then "final" >#<- pp_parens (@nt >|< "_Syn" >#< pp_parens @expr.pp)- else @expr.pp- | InvokeExpr lhs.pp = if breadthFirst @lhs.options- then "invoke" >#< pp_parens @expr.pp >#< pp_parens (- @nt >|< "_Inh" >#< pp_parens (ppTuple False @args.pps))- else @expr.pp >#< hv_sp @args.pps- | ResumeExpr lhs.pp = if breadthFirst @lhs.options- then pp_parens ("resume" >#< pp_parens @expr.pp- >-< indent 2 (pp_parens ( "\\" >|<- pp_parens ("~" >|< pp_parens (@nt >|< "_Syn" >#< "_inh_arg"))- >#< "->"- >-< indent 2 ( "let" >#< @left.pp >#< "= _inh_arg"- >-< indent 2 ("in" >#< @rhs.pp)- ))))- else pp_parens ( "case" >#< pp_parens @expr.pp >#< "of"- >-< ("{" >#< @left.pp >#< "->")- >-< indent 4 (@rhs.pp >#< "}")- )- | SemFun loc.strictParams = if strictSems @lhs.options- then @args.pps- else []- loc.addBang = if bangpats @lhs.options- then \p -> pp_parens ("!" >|< p)- else id- lhs.pp = if breadthFirst @lhs.options- then "Child" >#< pp_parens ( "\\" >|<- pp_parens (@nt >|< "_Inh" >#<- ppTuple False (map @loc.addBang @args.pps)) >#< "->"- >-< indent 2 (@loc.strictParams `ppMultiSeqV` @body.pp))- else if null @args.pps- then @body.pp- else pp_parens ( "\\" >#< (vlist (map @loc.addBang @args.pps)) >#< "->"- >-< indent 4 (@loc.strictParams `ppMultiSeqV` @body.pp)- )--SEM CaseAlt- | CaseAlt lhs.pps = ["{" >#< @left.pp >#< "->", @expr.pp >#< "}"]--SEM DataAlt- | DataAlt lhs.pp = @name >#< hv_sp (map ((@lhs.strictPre >|<) . pp_parens) @args.pps)- lhs.ppa = empty- | Record lhs.pp = @name >#< hv_sp (map ((@lhs.strictPre >|<) . pp_parens) @args.pps) -- @name >#< pp_block "{" "}" "," @args.pps- lhs.ppa = let f n d = d >#< (pp_block ("(" ++ @name) ")" "" $ map pp (ppat n))- >#< pp "=" >#< pp "x"- ppat n = replicate (length @args.ppas - n - 1) (pp " _") ++ [pp " x"] ++ replicate n (pp " _")- in snd $ foldr (\x (n, xs) -> (n + 1, f n x >-< xs)) (0, empty) @args.ppas--SEM NamedType- | Named lhs.pp = -- @name >#< "::" >#< - if @strict- then "!" >|< pp_parens @tp.pp- else @tp.pp- lhs.ppa = pp @name--SEM Lhs- | Pattern3 TupleLhs UnboxedTupleLhs- loc.addStrictGuard = if strictCases @lhs.options && @loc.hasStrictVars then \v -> v >#< "|" >#< @loc.strictGuard else id- | Pattern3- loc.strictGuard = @pat3.strictVars `ppMultiSeqH` (pp "True")- loc.hasStrictVars = not (null @pat3.strictVars)- | TupleLhs UnboxedTupleLhs- loc.strictGuard = if stricterCases @lhs.options && not @lhs.isDeclOfLet- then map text @comps `ppMultiSeqH` (pp "True")- else pp "True"- loc.hasStrictVars = not (null @comps)-- | Fun- loc.addStrictGuard = if strictSems @lhs.options && @loc.hasStrictVars then \v -> v >#< "|" >#< @loc.strictGuard else id- loc.hasStrictVars = not (null @args.pps)- loc.strictGuard = @args.pps `ppMultiSeqH` (pp "True")-- | TupleLhs UnboxedTupleLhs Fun- loc.addBang = if bangpats @lhs.options- then \p -> "!" >|< p- else id-- | Pattern3 lhs.pp = @loc.addStrictGuard @pat3.pp- | Pattern3SM lhs.pp = @pat3.pp'- | TupleLhs lhs.pp = @loc.addStrictGuard $ ppTuple @lhs.nested (map (@loc.addBang . text) @comps)- | UnboxedTupleLhs lhs.pp = @loc.addStrictGuard $ ppUnboxedTuple @lhs.nested (map (@loc.addBang . text) @comps)- | Fun lhs.pp = @loc.addStrictGuard (@name >#< hv_sp (map @loc.addBang @args.pps))- | Unwrap lhs.pp = pp_parens (@name >#< @sub.pp)--SEM Type [ | | prec:Int ]- | Arr lhs.prec = 2- .pp = case @right.copy of- Arr{} -> @loc.l >-< @loc.r- _ -> @loc.l >#< "->" >-< @loc.r- loc.l = if @left.prec <= 2 then pp_parens @left.pp else @left.pp- .r = if @right.prec < 2 then pp_parens @right.pp else @right.pp-- | TypeApp- lhs.pp = pp "(" >#< hv_sp (@func.pp : @args.pps) >#< pp ")"-- TODO: Check-- | CtxApp- lhs.pp = @right.pp >#< " | " >#< (pp_block "" "" "&" $ map (\(n,ns) -> hv_sp $ map pp (n:ns)) @left)- | QuantApp- lhs.pp = @left >#< @right.pp-- | TupleType lhs.prec = 5- .pp = ppTuple @lhs.nested @tps.pps-- | UnboxedTupleType lhs.prec = 5- .pp = ppUnboxedTuple @lhs.nested @tps.pps-- | List lhs.prec = 5- .pp = "[" >|< @tp.pp >|< "]"-- | SimpleType lhs.prec = 5- .pp = if reallySimple @txt then text @txt else pp_parens (text @txt)-- | NontermType lhs.prec = 5- 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" >#< pp_parens @tp.pp- | TEither lhs.prec = 5- lhs.pp = text "Either" >#< pp_parens @left.pp >#< pp_parens @right.pp- | TMap lhs.prec = 5- lhs.pp = text "'Data.Map'.Map" >#< pp_parens @key.pp >#< pp_parens @value.pp- | TIntMap lhs.prec = 5- lhs.pp = text "'Data.IntMap'.IntMap" >#< pp_parens @value.pp- | TSet lhs.prec = 5- lhs.pp = text "'Data.Set'.Set" >#< pp_parens @tp.pp- | TIntSet lhs.prec = 5- lhs.pp = text "'Data.IntSet'.IntSet"---{--reallySimple :: String -> Bool-reallySimple = and . map (\x -> isAlphaNum x || x=='_')--ppTuple :: Bool -> [PP_Doc] -> PP_Doc-ppTuple _ [x] = pp x-ppTuple True pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps-ppTuple False pps = "(" >|< pp_block " " ")" "," pps-ppUnboxedTuple :: Bool -> [PP_Doc] -> PP_Doc-ppUnboxedTuple = ppTuple---ppUnboxedTuple True pps = "(# " >|< pp_block " " (concat $ replicate (length pps `max` 1) " #)") ",(# " pps---ppUnboxedTuple False pps = "(# " >|< pp_block " " " #)" "," pps--}------------------------------------------------------------------------------------- Strict data fields----------------------------------------------------------------------------------ATTR DataAlt DataAlts [ strictPre: PP_Doc | | ]--SEM Decl- | Data alts.strictPre = if @strict then pp "!" else empty------------------------------------------------------------------------------------ Strict variables----------------------------------------------------------------------------------ATTR Pattern Patterns [ | | strictVars USE {++} {[]} : {[PP_Doc]} ]-SEM Pattern- | Alias- loc.strictVar- = if strictCases @lhs.options && not @lhs.isDeclOfLet- then [@loc.ppVar]- else []- loc.strictPatVars- = if stricterCases @lhs.options && not @lhs.isDeclOfLet- then @pat.strictVars- else []- lhs.strictVars- = @loc.strictVar ++ @loc.strictPatVars- | Irrefutable- lhs.strictVars = []------------------------------------------------------------------------------------ Pretty printing patterns----------------------------------------------------------------------------------SEM Patterns [ | | pps : {[PP_Doc]} ]- | Cons lhs.pps = @hd.pp : @tl.pps- | Nil lhs.pps = []--SEM Pattern- | Constr Product Alias- loc.addBang = if bangpats @lhs.options && not @lhs.isDeclOfLet && not @lhs.belowIrrefutable- then \p -> "!" >|< p- else id--SEM Pattern [ | | pp:PP_Doc ]- | Constr lhs.pp = @loc.addBang $ pp_parens $ @name >#< hv_sp @pats.pps- | Product lhs.pp = @loc.addBang $ pp_block "(" ")" "," @pats.pps- | Alias loc.ppVar = pp (attrname @lhs.options False @field @attr)- loc.ppVarBang = @loc.addBang $ @loc.ppVar- lhs.pp = if @pat.isUnderscore- then @loc.ppVarBang- else @loc.ppVarBang >|< "@" >|< @pat.pp- | Irrefutable lhs.pp = text "~" >|< pp_parens @pat.pp- | Underscore lhs.pp = text "_"--SEM Pattern [ | | isUnderscore:{Bool}]- | Constr lhs.isUnderscore = False- | Product lhs.isUnderscore = False- | Alias lhs.isUnderscore = False- | Underscore lhs.isUnderscore = True--ATTR Pattern Patterns [ belowIrrefutable : Bool | | ]-SEM Pattern- | Irrefutable- pat.belowIrrefutable = True--SEM Lhs- | Pattern3 Pattern3SM- pat3.belowIrrefutable = False------------------------------------------------------------------------------------ Pretty printing patterns for SM----------------------------------------------------------------------------------SEM Patterns [ | | pps' : {[PP_Doc]} ]- | Cons lhs.pps' = @hd.pp' : @tl.pps'- | Nil lhs.pps' = []--SEM Pattern [ | | pp':PP_Doc ]- | Constr lhs.pp' = pp_parens $ @name >#< hv_sp (map pp_parens @pats.pps')- | Product lhs.pp' = pp_block "(" ")" "," @pats.pps'- | Alias lhs.pp' = let attribute | @field == _LOC || @field == nullIdent = locname' @attr- | otherwise = attrname @lhs.options False @field @attr- in attribute >|< "@" >|< @pat.pp'- | Irrefutable lhs.pp' = text "~" >|< pp_parens @pat.pp- | Underscore lhs.pp' = text "_"--{-locname' :: Identifier -> [Char]-locname' n = "_loc_" ++ getName n-}------------------------------------------------------------------------------------ Determine if inside a Let----------------------------------------------------------------------------------ATTR Chunks Chunk Decls Decl Lhs Pattern Patterns [ isDeclOfLet : Bool | | ]-SEM Program- | Program- chunks.isDeclOfLet = False--SEM Expr- | Let- decls.isDeclOfLet = True- | Do- stmts.isDeclOfLet = False- | ResumeExpr- left.isDeclOfLet = False--SEM CaseAlt- | CaseAlt- left.isDeclOfLet = False-------------------------------------------------------------------------------------- Alternative code printing to separate modules----------------------------------------------------------------------------------ATTR Program [ mainBlocksDoc : PP_Doc | | genIO : {IO ()} ]-ATTR Program Chunks Chunk- [ importBlocks : PP_Doc- pragmaBlocks : String- textBlocks : PP_Doc- textBlockMap : {Map BlockInfo PP_Doc}- optionsLine : String- mainFile : String- mainName : String- moduleHeader : {String -> String -> String -> Bool -> String}- | | ]--SEM Program- | Program- loc.mainModuleFile = @lhs.mainFile- loc.genMainModule- = writeModule @loc.mainModuleFile- ( [ pp $ @lhs.pragmaBlocks- , pp $ @lhs.optionsLine- , pp $ @lhs.moduleHeader @lhs.mainName "" "" False- , pp $ ("import " ++ @lhs.mainName ++ "_common\n")- ]- ++ map pp @chunks.imports- ++ map vlist @chunks.appendMain- ++ [@lhs.mainBlocksDoc]- )-- loc.commonFile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_common")- loc.genCommonModule- = writeModule @loc.commonFile- ( [ pp $ @lhs.pragmaBlocks- , pp $ @lhs.optionsLine- , pp $ @lhs.moduleHeader @lhs.mainName "_common" "" True- , @lhs.importBlocks- , @lhs.textBlocks- ]- ++ map vlist @chunks.appendCommon- )-- lhs.genIO = do @loc.genMainModule- @loc.genCommonModule- @chunks.genSems--{-renderDocs :: [PP_Doc] -> String-renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) ""-}--ATTR Chunk Chunks [ | | imports USE {++} {[]} : {[String]} ]-SEM Chunk- | Chunk- lhs.imports = ["import " ++ @lhs.mainName ++ "_" ++ @name ++ "\n"]--ATTR Chunk Chunks [ | | appendCommon, appendMain USE {++} {[]} : {[[PP_Doc]]} ]--SEM Chunk- | Chunk- lhs.appendCommon- = [ [@comment.pp]- , @dataDef.pps- , @semDom.pps- , if reference @lhs.options then @semWrapper.pps else []- ]- lhs.appendMain- = [ [@comment.pp]- , @cataFun.pps- , if reference @lhs.options then [] else @semWrapper.pps- ]--ATTR Chunk Chunks [ | | genSems USE {>>} {return ()} : {IO ()} ]--SEM Chunk- | Chunk- lhs.genSems- = writeModule @loc.outputfile- [ pp $ @lhs.pragmaBlocks- , pp $ Map.findWithDefault empty (BlockPragma, Just $ identifier @name) @lhs.textBlockMap- , pp $ @lhs.optionsLine- , pp $ @lhs.moduleHeader @lhs.mainName ("_" ++ @name) @loc.exports True- , pp $ ("import " ++ @lhs.mainName ++ "_common\n")- , pp $ Map.findWithDefault empty (BlockImport, Just $ identifier @name) @lhs.textBlockMap- , @comment.pp- , vlist_sep "" @info.pps- , vlist_sep "" @semFunctions.pps- , Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap- ]--SEM Chunk- | Chunk- loc.exports = concat $ intersperse "," @semNames--{-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-}-
− src-ag/PrintCode.ag
@@ -1,542 +0,0 @@-PRAGMA strictdata-PRAGMA optimize-PRAGMA bangpats-PRAGMA strictwrap--INCLUDE "Code.ag"-INCLUDE "Patterns.ag"--imports-{-import Data.Char (isAlphaNum)-import Pretty-import Code-import Options-import CommonTypes (attrname, _LOC, nullIdent)-import Data.List(intersperse)-import System.IO-import System.Directory-import System.FilePath-import CommonTypes(BlockInfo, BlockKind(..))-}--{-type PP_Docs = [PP_Doc]-}--{-ppMultiSeqH :: [PP_Doc] -> PP_Doc -> PP_Doc-ppMultiSeqH = ppMultiSeq' (>#<)--ppMultiSeqV :: [PP_Doc] -> PP_Doc -> PP_Doc-ppMultiSeqV = ppMultiSeq' (>-<)--ppMultiSeq' :: (PP_Doc -> PP_Doc -> PP_Doc) -> [PP_Doc] -> PP_Doc -> PP_Doc-ppMultiSeq' next strictArgs expr- = foldr (\v r -> (v >#< "`seq`") `next` pp_parens r) expr strictArgs-}--ATTR Expr Exprs Decl Decls CaseAlt CaseAlts Lhs [ outputfile : {String} | | ]--SEM Chunk- | Chunk- loc.outputfile = if sepSemMods @lhs.options- then replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_" ++ @name)- else @lhs.mainFile--ATTR Program [ options:{Options} | | output:{PP_Docs} ]--ATTR Expr Exprs Decl Decls Chunk Chunks CaseAlts CaseAlt Lhs Pattern Patterns [ options:{Options} | | ]--ATTR Expr Decl DataAlt Type NamedType Lhs [ nested:{Bool} | | pp:{PP_Doc} ]--ATTR Exprs DataAlts Types NamedTypes Decls Chunk Chunks [ nested:{Bool} | | pps : {PP_Docs} ]--ATTR CaseAlt CaseAlts [ nested:{Bool} | | pps: {PP_Docs} ]--SEM Program | Program- loc.options = @lhs.options { breadthFirst = breadthFirst @lhs.options && visit @lhs.options && cases @lhs.options && @ordered }--SEM Program- | Program chunks.nested = nest @lhs.options--SEM Exprs- | Cons lhs.pps = @hd.pp : @tl.pps- | Nil lhs.pps = []--SEM CaseAlts- | Cons lhs.pps = @hd.pps ++ @tl.pps- | Nil lhs.pps = []--SEM DataAlts- | Cons lhs.pps = @hd.pp : @tl.pps- | Nil lhs.pps = []--SEM Types- | Cons lhs.pps = @hd.pp : @tl.pps- | Nil lhs.pps = []--SEM NamedTypes- | Cons lhs.pps = @hd.pp : @tl.pps- | Nil lhs.pps = []--SEM Decls- | Cons lhs.pps = @hd.pp : @tl.pps- | Nil lhs.pps = []--SEM Chunks- | Cons lhs.pps = @hd.pps ++ @tl.pps- | Nil lhs.pps = []---SEM Program- | Program lhs.output = @chunks.pps--SEM Chunk- | Chunk lhs.pps = @comment.pp- : @info.pps- ++ @dataDef.pps- ++ @cataFun.pps- ++ @semDom.pps- ++ @semWrapper.pps- ++ @semFunctions.pps- ++ [Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap]--SEM Decl- | Decl lhs.pp = @left.pp >#< "="- >-< indent 4 @rhs.pp- | Bind lhs.pp = @left.pp >#< "<-" >#< @rhs.pp- | BindLet lhs.pp = "let" >#< @left.pp >#< "=" >#< @rhs.pp- | Data lhs.pp = "data" >#< hv_sp (@name : @params)- >#< ( case @alts.pps of- [] -> empty- (x:xs) -> "=" >#< x- >-< vlist (map ("|" >#<) xs)- >-< if null @derivings- then empty- else "deriving" >#< ppTuple False (map text @derivings)- )- | NewType lhs.pp = "newtype" >#< hv_sp (@name : @params) >#< "=" >#< @con >#< pp_parens @tp.pp- | Type lhs.pp = "type" >#< hv_sp (@name : @params) >#< "=" >#< @tp.pp- | TSig lhs.pp = @name >#< "::" >#< @tp.pp- | Comment lhs.pp = if '\n' `elem` @txt- then "{-" >-< vlist (lines @txt) >-< "-}"- else "--" >#< @txt- | PragmaDecl lhs.pp = "{-#" >#< text @txt >#< "#-}"- | Resume lhs.pp = if @monadic- then @left.pp >#< "<-" >#< @rhs.pp- else @left.pp >#< "=" >-< indent 4 @rhs.pp- | EvalDecl loc.strat = if breadthFirstStrict @lhs.options- then "stepwiseEval"- else "lazyEval"- lhs.pp = if breadthFirst @lhs.options- then @left.pp >#< "=" >#< "case" >#< @loc.strat >#< pp_parens @rhs.pp >#< "of"- >-< indent 4 (- pp_parens (@nt >|< "_Syn" >#< "_val") >#< "-> _val"- )- else @left.pp >#< "=" >#< @rhs.pp--SEM Expr- | Let lhs.pp = pp_parens ( "let" >#< (vlist @decls.pps)- >-< "in " >#< @body.pp- )- | Case lhs.pp = pp_parens ( "case" >#< pp_parens @expr.pp >#< "of"- >-< (vlist @alts.pps)- )- | Do lhs.pp = pp_parens ( "do" >#< ( vlist @stmts.pps- >-< ("return" >#< @body.pp))- )- | Lambda loc.strictParams = if strictSems @lhs.options- then @args.pps- else []- loc.addBang = if bangpats @lhs.options- then \p -> pp_parens ("!" >|< p)- else id- lhs.pp = pp_parens ( "\\" >#< (vlist (map @loc.addBang @args.pps)) >#< "->"- >-< indent 4 (@loc.strictParams `ppMultiSeqV` @body.pp)- )- | TupleExpr lhs.pp = ppTuple @lhs.nested @exprs.pps- | UnboxedTupleExpr lhs.pp = ppUnboxedTuple @lhs.nested @exprs.pps- | App lhs.pp = pp_parens $ @name >#< hv_sp @args.pps- | SimpleExpr lhs.pp = text @txt- | TextExpr lhs.pp = vlist (map text @lns)- | Trace lhs.pp = "trace" >#< ( pp_parens ("\"" >|< text @txt >|< "\"")- >-< pp_parens @expr.pp- )- | PragmaExpr lhs.pp = let pragmaDoc = "{-#" >#< @txt >#< "#-}"- op = if @onNewLine- then (>-<)- else (>#<)- leftOp x y = if @onLeftSide- then x `op` y- else y- rightOp x y = if @onLeftSide- then x- else x `op` y- in pp_parens (pragmaDoc `leftOp` @expr.pp `rightOp` pragmaDoc)- | LineExpr lhs.pp = @expr.pp >-< "{-# LINE" >#< ppWithLineNr (\n -> pp $ show $ n + 1) >#< show @lhs.outputfile >#< "#-}"- >-< ""- | TypedExpr lhs.pp = pp_parens (@expr.pp >#< "::" >#< @tp.pp)- | ResultExpr lhs.pp = if breadthFirst @lhs.options- then "final" >#<- pp_parens (@nt >|< "_Syn" >#< pp_parens @expr.pp)- else @expr.pp- | InvokeExpr lhs.pp = if breadthFirst @lhs.options- then "invoke" >#< pp_parens @expr.pp >#< pp_parens (- @nt >|< "_Inh" >#< pp_parens (ppTuple False @args.pps))- else @expr.pp >#< hv_sp @args.pps- | ResumeExpr lhs.pp = if breadthFirst @lhs.options- then pp_parens ("resume" >#< pp_parens @expr.pp- >-< indent 2 (pp_parens ( "\\" >|<- pp_parens ("~" >|< pp_parens (@nt >|< "_Syn" >#< "_inh_arg"))- >#< "->"- >-< indent 2 ( "let" >#< @left.pp >#< "= _inh_arg"- >-< indent 2 ("in" >#< @rhs.pp)- ))))- else pp_parens ( "case" >#< pp_parens @expr.pp >#< "of"- >-< ("{" >#< @left.pp >#< "->")- >-< indent 4 (@rhs.pp >#< "}")- )- | SemFun loc.strictParams = if strictSems @lhs.options- then @args.pps- else []- loc.addBang = if bangpats @lhs.options- then \p -> pp_parens ("!" >|< p)- else id- lhs.pp = if breadthFirst @lhs.options- then "Child" >#< pp_parens ( "\\" >|<- pp_parens (@nt >|< "_Inh" >#<- ppTuple False (map @loc.addBang @args.pps)) >#< "->"- >-< indent 2 (@loc.strictParams `ppMultiSeqV` @body.pp))- else if null @args.pps- then @body.pp- else pp_parens ( "\\" >#< (vlist (map @loc.addBang @args.pps)) >#< "->"- >-< indent 4 (@loc.strictParams `ppMultiSeqV` @body.pp)- )--SEM CaseAlt- | CaseAlt lhs.pps = ["{" >#< @left.pp >#< "->", @expr.pp >#< "}"]--SEM DataAlt- | DataAlt lhs.pp = @name >#< hv_sp (map ((@lhs.strictPre >|<) . pp_parens) @args.pps)- | Record lhs.pp = @name >#< pp_block "{" "}" "," @args.pps--SEM NamedType- | Named lhs.pp = if @strict- then @name >#< "::" >#< "!" >|< pp_parens @tp.pp- else @name >#< "::" >#< @tp.pp--SEM Lhs- | Pattern3 TupleLhs UnboxedTupleLhs- loc.addStrictGuard = if strictCases @lhs.options && @loc.hasStrictVars then \v -> v >#< "|" >#< @loc.strictGuard else id- | Pattern3- loc.strictGuard = @pat3.strictVars `ppMultiSeqH` (pp "True")- loc.hasStrictVars = not (null @pat3.strictVars)- | TupleLhs UnboxedTupleLhs- loc.strictGuard = if stricterCases @lhs.options && not @lhs.isDeclOfLet- then map text @comps `ppMultiSeqH` (pp "True")- else pp "True"- loc.hasStrictVars = not (null @comps)-- | Fun- loc.addStrictGuard = if strictSems @lhs.options && @loc.hasStrictVars then \v -> v >#< "|" >#< @loc.strictGuard else id- loc.hasStrictVars = not (null @args.pps)- loc.strictGuard = @args.pps `ppMultiSeqH` (pp "True")-- | TupleLhs UnboxedTupleLhs Fun- loc.addBang = if bangpats @lhs.options- then \p -> "!" >|< p- else id-- | Pattern3 lhs.pp = @loc.addStrictGuard @pat3.pp- | Pattern3SM lhs.pp = @pat3.pp'- | TupleLhs lhs.pp = @loc.addStrictGuard $ ppTuple @lhs.nested (map (@loc.addBang . text) @comps)- | UnboxedTupleLhs lhs.pp = @loc.addStrictGuard $ ppUnboxedTuple @lhs.nested (map (@loc.addBang . text) @comps)- | Fun lhs.pp = @loc.addStrictGuard (@name >#< hv_sp (map @loc.addBang @args.pps))- | Unwrap lhs.pp = pp_parens (@name >#< @sub.pp)--SEM Type [ | | prec:Int ]- | Arr lhs.prec = 2- .pp = @loc.l >#< "->" >-< @loc.r- loc.l = if @left.prec <= 2 then pp_parens @left.pp else @left.pp- .r = if @right.prec < 2 then pp_parens @right.pp else @right.pp-- | TypeApp- lhs.pp = hv_sp (@func.pp : @args.pps)-- | CtxApp- lhs.pp = (pp_block "(" ")" "," $ map (\(n,ns) -> hv_sp $ map pp (n:ns)) @left) >#< "=>" >#< @right.pp- | QuantApp- lhs.pp = @left >#< @right.pp-- | TupleType lhs.prec = 5- .pp = ppTuple @lhs.nested @tps.pps-- | UnboxedTupleType lhs.prec = 5- .pp = ppUnboxedTuple @lhs.nested @tps.pps-- | List lhs.prec = 5- .pp = "[" >|< @tp.pp >|< "]"-- | SimpleType lhs.prec = 5- .pp = if reallySimple @txt then text @txt else pp_parens (text @txt)-- | NontermType lhs.prec = 5- 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" >#< pp_parens @tp.pp- | TEither lhs.prec = 5- lhs.pp = text "Either" >#< pp_parens @left.pp >#< pp_parens @right.pp- | TMap lhs.prec = 5- lhs.pp = text "Data.Map.Map" >#< pp_parens @key.pp >#< pp_parens @value.pp- | TIntMap lhs.prec = 5- lhs.pp = text "Data.IntMap.IntMap" >#< pp_parens @value.pp- | TSet lhs.prec = 5- lhs.pp = text "Data.Set.Set" >#< pp_parens @tp.pp- | TIntSet lhs.prec = 5- lhs.pp = text "Data.IntSet.IntSet"---{--reallySimple :: String -> Bool-reallySimple = and . map (\x -> isAlphaNum x || x=='_')--ppTuple :: Bool -> [PP_Doc] -> PP_Doc-ppTuple True pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps-ppTuple False pps = "(" >|< pp_block " " ")" "," pps-ppUnboxedTuple :: Bool -> [PP_Doc] -> PP_Doc-ppUnboxedTuple True pps = "(# " >|< pp_block " " (concat $ replicate (length pps `max` 1) " #)") ",(# " pps-ppUnboxedTuple False pps = "(# " >|< pp_block " " " #)" "," pps--}------------------------------------------------------------------------------------- Strict data fields----------------------------------------------------------------------------------ATTR DataAlt DataAlts [ strictPre: PP_Doc | | ]--SEM Decl- | Data alts.strictPre = if @strict then pp "!" else empty------------------------------------------------------------------------------------ Strict variables----------------------------------------------------------------------------------ATTR Pattern Patterns [ | | strictVars USE {++} {[]} : {[PP_Doc]} ]-SEM Pattern- | Alias- loc.strictVar- = if strictCases @lhs.options && not @lhs.isDeclOfLet- then [@loc.ppVar]- else []- loc.strictPatVars- = if stricterCases @lhs.options && not @lhs.isDeclOfLet- then @pat.strictVars- else []- lhs.strictVars- = @loc.strictVar ++ @loc.strictPatVars- | Irrefutable- lhs.strictVars = []------------------------------------------------------------------------------------ Pretty printing patterns----------------------------------------------------------------------------------SEM Patterns [ | | pps : {[PP_Doc]} ]- | Cons lhs.pps = @hd.pp : @tl.pps- | Nil lhs.pps = []--SEM Pattern- | Constr Product Alias- loc.addBang = if bangpats @lhs.options && not @lhs.isDeclOfLet && not @lhs.belowIrrefutable- then \p -> "!" >|< p- else id--SEM Pattern [ | | pp:PP_Doc ]- | Constr lhs.pp = @loc.addBang $ pp_parens $ @name >#< hv_sp @pats.pps- | Product lhs.pp = @loc.addBang $ pp_block "(" ")" "," @pats.pps- | Alias loc.ppVar = pp (attrname @lhs.options False @field @attr)- loc.ppVarBang = @loc.addBang $ @loc.ppVar- lhs.pp = if @pat.isUnderscore- then @loc.ppVarBang- else @loc.ppVarBang >|< "@" >|< @pat.pp- | Irrefutable lhs.pp = text "~" >|< pp_parens @pat.pp- | Underscore lhs.pp = text "_"--SEM Pattern [ | | isUnderscore:{Bool}]- | Constr lhs.isUnderscore = False- | Product lhs.isUnderscore = False- | Alias lhs.isUnderscore = False- | Underscore lhs.isUnderscore = True--ATTR Pattern Patterns [ belowIrrefutable : Bool | | ]-SEM Pattern- | Irrefutable- pat.belowIrrefutable = True--SEM Lhs- | Pattern3 Pattern3SM- pat3.belowIrrefutable = False------------------------------------------------------------------------------------ Pretty printing patterns for SM----------------------------------------------------------------------------------SEM Patterns [ | | pps' : {[PP_Doc]} ]- | Cons lhs.pps' = @hd.pp' : @tl.pps'- | Nil lhs.pps' = []--SEM Pattern [ | | pp':PP_Doc ]- | Constr lhs.pp' = pp_parens $ @name >#< hv_sp (map pp_parens @pats.pps')- | Product lhs.pp' = pp_block "(" ")" "," @pats.pps'- | Alias lhs.pp' = let attribute | @field == _LOC || @field == nullIdent = locname' @attr- | otherwise = attrname @lhs.options False @field @attr- in attribute >|< "@" >|< @pat.pp'- | Irrefutable lhs.pp' = text "~" >|< pp_parens @pat.pp- | Underscore lhs.pp' = text "_"--{-locname' :: Identifier -> [Char]-locname' n = "_loc_" ++ getName n-}------------------------------------------------------------------------------------ Determine if inside a Let----------------------------------------------------------------------------------ATTR Chunks Chunk Decls Decl Lhs Pattern Patterns [ isDeclOfLet : Bool | | ]-SEM Program- | Program- chunks.isDeclOfLet = False--SEM Expr- | Let- decls.isDeclOfLet = True- | Do- stmts.isDeclOfLet = False- | ResumeExpr- left.isDeclOfLet = False--SEM CaseAlt- | CaseAlt- left.isDeclOfLet = False-------------------------------------------------------------------------------------- Alternative code printing to separate modules----------------------------------------------------------------------------------ATTR Program [ mainBlocksDoc : PP_Doc | | genIO : {IO ()} ]-ATTR Program Chunks Chunk- [ importBlocks : PP_Doc- pragmaBlocks : String- textBlocks : PP_Doc- textBlockMap : {Map BlockInfo PP_Doc}- optionsLine : String- mainFile : String- mainName : String- moduleHeader : {String -> String -> String -> Bool -> String}- | | ]--SEM Program- | Program- loc.mainModuleFile = @lhs.mainFile- loc.genMainModule- = writeModule @loc.mainModuleFile- ( [ pp $ @lhs.pragmaBlocks- , pp $ @lhs.optionsLine- , pp $ @lhs.moduleHeader @lhs.mainName "" "" False- , pp $ ("import " ++ @lhs.mainName ++ "_common\n")- ]- ++ map pp @chunks.imports- ++ map vlist @chunks.appendMain- ++ [@lhs.mainBlocksDoc]- )-- loc.commonFile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_common")- loc.genCommonModule- = writeModule @loc.commonFile- ( [ pp $ @lhs.pragmaBlocks- , pp $ @lhs.optionsLine- , pp $ @lhs.moduleHeader @lhs.mainName "_common" "" True- , @lhs.importBlocks- , @lhs.textBlocks- ]- ++ map vlist @chunks.appendCommon- )-- lhs.genIO = do @loc.genMainModule- @loc.genCommonModule- @chunks.genSems--{-renderDocs :: [PP_Doc] -> String-renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) ""-}--ATTR Chunk Chunks [ | | imports USE {++} {[]} : {[String]} ]-SEM Chunk- | Chunk- lhs.imports = ["import " ++ @lhs.mainName ++ "_" ++ @name ++ "\n"]--ATTR Chunk Chunks [ | | appendCommon, appendMain USE {++} {[]} : {[[PP_Doc]]} ]--SEM Chunk- | Chunk- lhs.appendCommon- = [ [@comment.pp]- , @dataDef.pps- , @semDom.pps- , if reference @lhs.options then @semWrapper.pps else []- ]- lhs.appendMain- = [ [@comment.pp]- , @cataFun.pps- , if reference @lhs.options then [] else @semWrapper.pps- ]--ATTR Chunk Chunks [ | | genSems USE {>>} {return ()} : {IO ()} ]--SEM Chunk- | Chunk- lhs.genSems- = writeModule @loc.outputfile- [ pp $ @lhs.pragmaBlocks- , pp $ Map.findWithDefault empty (BlockPragma, Just $ identifier @name) @lhs.textBlockMap- , pp $ @lhs.optionsLine- , pp $ @lhs.moduleHeader @lhs.mainName ("_" ++ @name) @loc.exports True- , pp $ ("import " ++ @lhs.mainName ++ "_common\n")- , pp $ Map.findWithDefault empty (BlockImport, Just $ identifier @name) @lhs.textBlockMap- , @comment.pp- , vlist_sep "" @info.pps- , vlist_sep "" @semFunctions.pps- , Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap- ]--SEM Chunk- | Chunk- loc.exports = concat $ intersperse "," @semNames--{-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-}-
− src-ag/PrintErrorMessages.ag
@@ -1,656 +0,0 @@-INCLUDE "ErrorMessages.ag"--imports-{-import UU.Scanner.Position(Pos(..), noPos)-import ErrorMessages-import Data.List(mapAccumL)-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 _ (ParserError _ _ _ ) = True-isError _ (DupAlt _ _ _ ) = False-isError _ (DupSynonym _ _ ) = False-isError _ (DupSet _ _ ) = False-isError _ (DupInhAttr _ _ _ ) = True-isError _ (DupSynAttr _ _ _ ) = True-isError _ (DupChild _ _ _ _ ) = False-isError _ (DupRule _ _ _ _ _) = True-isError _ (DupSig _ _ _ ) = False-isError _ (UndefNont _ ) = True-isError _ (UndefAlt _ _ ) = True-isError _ (UndefChild _ _ _ ) = True-isError _ (MissingRule _ _ _ _ ) = False-isError _ (SuperfluousRule _ _ _ _ ) = False-isError _ (UndefLocal _ _ _ ) = True-isError _ (ChildAsLocal _ _ _ ) = False-isError _ (UndefAttr _ _ _ _ _) = True-isError _ (CyclicSet _ ) = True-isError _ (CustomError w _ _ ) = not w-isError opts (LocalCirc _ _ _ _ _) = cycleIsDangerous opts-isError opts (InstCirc _ _ _ _ _) = cycleIsDangerous opts-isError opts (DirectCirc _ _ _ ) = cycleIsDangerous opts-isError opts (InducedCirc _ _ _ ) = cycleIsDangerous opts-isError _ (MissingTypeSig _ _ _ ) = False-isError _ (MissingInstSig _ _ _ ) = True-isError _ (DupUnique _ _ _ ) = False-isError _ (MissingUnique _ _ ) = True-isError _ (MissingSyn _ _ ) = True-isError _ (MissingNamedRule _ _ _) = True-isError _ (DupRuleName _ _ _) = True-isError _ (HsParseError _ _) = True-isError _ (Cyclic _ _ _) = True-isError _ (IncompatibleVisitKind _ _ _ _) = True-isError _ (IncompatibleRuleKind _ _) = True-isError _ (IncompatibleAttachKind _ _) = True--cycleIsDangerous :: Options -> Bool-cycleIsDangerous opts- = any ($ opts) [ wignore, bangpats, cases, strictCases, stricterCases, strictSems, withCycle ]-}-------ATTR Error [ options:{Options} verbose:{Bool} | | pp :{PP_Doc}- me :SELF- ]--ATTR Errors [ options:{Options} dups : {[String]} | | pp USE {>-<} {text ""} : {PP_Doc}- ]--SEM Errors- | * loc.verbose = verbose @lhs.options- | Cons loc.str = disp @hd.pp 5000 ""-- lhs.pp = if @loc.str `elem` @lhs.dups- then @tl.pp- else @hd.pp >-< @tl.pp- tl.dups = @loc.str : @lhs.dups- | Nil lhs.pp = text ""---SEM Error- | ParserError lhs.pp = let mesg = text ("parser expecting " ++ @problem)- pat = text ""- help = text ""- act = text @action- in ppError (isError @lhs.options @me) @pos mesg pat help act @lhs.verbose-- | HsParseError lhs.pp = ppError True @pos (text @msg) (text "") (text "") (text "Correct the syntax of the Haskell code.") @lhs.verbose-- | DupAlt lhs.pp = let mesg = wfill ["Repeated definition for alternative", getName @con- ,"of nonterminal", getName @nt, "."- ] >-<- wfill ["First definition:", (showPos @occ1),"."] >-<- wfill ["Other definition:", (showPos @con),"."]- pat = "DATA" >#< getName @nt- >-< indent 2 ("|" >#< getName @con >#< "...")- >-< indent 2 ("|" >#< getName @con >#< "...")-- help = wfill ["The nonterminal",getName @nt,"has more than one alternative that"- ,"is labelled with the constructor name",getName @con,"."- ,"You should either rename or remove enough of them to make all"- ,"constructors of",getName @nt,"uniquely named."- ]-- act = wfill [ "The first alternative of name",getName @con- ,"you have given for nonterminal",getName @nt- ,"is considered valid. All other alternatives have been discarded."- ]-- in ppError (isError @lhs.options @me) (getPos @con) mesg pat help act @lhs.verbose-- | DupSynonym lhs.pp = let mesg = wfill ["Definition of type synonym", getName @nt, "clashes with another"- ,"type synonym."- ] >-<- wfill ["First definition:", (showPos @occ1),"."] >-<- wfill ["Type synonym :" , (showPos @nt),"."]- pat = "DATA" >#< getName @nt- >-< indent 2 ("|" >#< "...")- >-< "TYPE" >#< getName @nt >#< "=" >#< "..."- help = wfill ["A type synonym with name", getName @nt- ,"has been given while there already is TYPE"- ,"definition with the same name."- ,"You should either rename or remove the type synonym."- ]- act = wfill [ "The clashing type synonym will be ignored."- ]- in ppError (isError @lhs.options @me) (getPos @nt) mesg pat help act @lhs.verbose-- | DupSet lhs.pp = let mesg = wfill ["Definition of nonterminal set", getName @name, "clashes with another"- ,"set, a type synonym or a data definition."- ] >-<- wfill ["First definition:", (showPos @occ1),"."] >-<- wfill ["Set definition:" , (showPos @name),"."]- pat = "SET" >#< getName @name >#< "=" >#< "..."- >-< "SET" >#< getName @name >#< "=" >#< "..."- help = wfill ["A nonterminal set with name", getName @name- ,"has been given while there already is a SET, DATA, or TYPE"- ,"definition with the same name."- ,"You should either rename or remove the nonterminal set."- ]- act = wfill [ "The clashing nonterminal set will be ignored."- ]- in ppError (isError @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose-- | DupInhAttr lhs.pp = let mesg = wfill ["Repeated declaration of inherited attribute", getName @attr- , "of nonterminal", getName @nt, "."- ] >-<- wfill ["First definition:", (showPos @occ1),"."] >-<- wfill ["Other definition:", (showPos @attr),"."]- pat = "ATTR" >#< getName @nt >#< "[" >#< getName @attr >|< ":...,"- >#< getName @attr >|< ":... | | ]"-- help = wfill ["The identifier" , getName @attr ,"has been declared"- ,"as an inherited (or chained) attribute for nonterminal"- ,getName @nt , "more than once, with possibly different types."- ,"Delete all but one or rename them to make them unique."- ]- act = wfill ["One declaration with its corresponding type is considered valid."- ,"All others have been discarded. The generated program will probably not run."- ]-- in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose-- | DupSynAttr lhs.pp = let mesg = wfill ["Repeated declaration of synthesized attribute", getName @attr- , "of nonterminal", getName @nt, "."- ] >-<- wfill ["First definition:", (showPos @occ1),"."] >-<- wfill ["Other definition:", (showPos @attr),"."]- pat = "ATTR" >#< getName @nt >#< "[ | |" >#< getName @attr >|< ":...,"- >#< getName @attr >|< ":... ]"-- help = wfill ["The identifier" , getName @attr ,"has been declared"- ,"as a synthesized (or chained) attribute for nonterminal"- ,getName @nt , "more than once, with possibly different types."- ,"Delete all but one or rename them to make them unique."- ]- act = wfill ["One declaration with its corresponding type is considered valid."- ,"All others have been discarded. The generated program will probably not run."- ]-- in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose-- | DupChild lhs.pp = let mesg = wfill ["Repeated declaration for field", getName @name, "of alternative"- ,getName @con, "of nonterminal", getName @nt, "."- ] >-<- wfill ["First definition:", (showPos @occ1),"."] >-<- wfill ["Other definition:", (showPos @name),"."]- pat = "DATA" >#< getName @nt- >-< indent 2 ("|" >#< getName @con >#< (getName @name >|< ":..." >-< getName @name >|< ":..."))--- help = wfill ["The alternative" ,getName @con , "of nonterminal" ,getName @nt- ,"has more than one field that is named"- , getName @name ++ ". Possibly they have different types."- ,"You should either rename or remove enough of them to make all fields of"- ,getName @con , "for nonterminal " , getName @nt , "uniquely named."- ]- act = wfill ["The last declaration with its corresponding type is considered valid."- ,"All others have been discarded."- ]- in ppError (isError @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose-- | DupRule lhs.pp = let mesg = wfill ["At constructor",getName @con, "of nonterminal", getName @nt, "there are two or more rules for"- ,showAttrDef @field @attr,"."- ] >-<- wfill ["First rule:", (showPos @occ1),"."] >-<- wfill ["Other rule:", (showPos @attr),"."]-- pat = "SEM" >#< getName @nt- >-< indent 2 ("|" >#< getName @con >#< ppAttr @field @attr >#< "= ...")- >-< indent 2 ("|" >#< getName @con >#< ppAttr @field @attr >#< "= ...")-- help = wfill ["In the rules for alternative" , getName @con , "of nonterminal" , getName @nt- ,", there is more than one rule for the" , showAttrDef @field @attr- ,". You should either rename or remove enough of them to make all rules for alternative"- ,getName @con , "of nonterminal " ,getName @nt , "uniquely named."- ]- act = wfill ["The last rule given is considered valid. All others have been discarded."]- in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose-- | DupRuleName lhs.pp = let mesg = wfill ["At constructor",getName @con, "of nonterminal", getName @nt, "there are two or more rule names for"- ,show @nm,"."- ]-- pat = "SEM" >#< getName @nt- >-< indent 2 ("|" >#< getName @con >#< show @nm >#< ": ... = ...")- >-< indent 2 ("|" >#< getName @con >#< show @nm >#< ": ... = ...")-- help = wfill ["In the rules for alternative" , getName @con , "of nonterminal" , getName @nt- ,", there is more than one rule name " , show @nm- ,". You should either rename or remove enough of them."- ]- act = wfill ["Compilation cannot continue."]- in ppError (isError @lhs.options @me) (getPos @nm) mesg pat help act @lhs.verbose-- | DupSig lhs.pp = let mesg = wfill ["At constructor",getName @con, "of nonterminal", getName @nt, "there are two or more typesignatures for"- ,showAttrDef _LOC @attr,"."- ] >-<- wfill ["First signature:", (showPos @attr),"."]-- pat = "SEM" >#< getName @nt- >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< "= ...")- >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< "= ...")-- help = wfill ["In the rules for alternative" , getName @con , "of nonterminal" , getName @nt- ,", there is more than one rule for the" , showAttrDef _LOC @attr- ,". You should remove enough of them to make all typesignatures for alternative"- ,getName @con , "of nonterminal " ,getName @nt , "unique."- ]- act = wfill ["The last typesignature given is considered valid. All others have been discarded."]- in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose-- | UndefNont lhs.pp = let mesg = wfill ["Nonterminal", getName @nt, "is not defined."- ]- pat = "DATA" >#< getName @nt >#< "..."-- help = wfill ["There are attributes and/or rules for nonterminal" , getName @nt ,", but there is no definition"- , "for" ,getName @nt, ". Maybe you misspelled it? Otherwise insert a definition."- ]- act = wfill ["Everything regarding the unknown nonterminal has been ignored."]- in ppError (isError @lhs.options @me) (getPos @nt) mesg pat help act @lhs.verbose-- | UndefAlt lhs.pp = let mesg = wfill ["Constructor", getName @con, "of nonterminal" ,getName @nt, "is not defined."- ]- pat = "DATA" >#< getName @nt- >-< indent 2 ("|" >#< getName @con >#< "...")-- help = wfill ["There are rules for alternative", getName @con , "of nonterminal" ,getName @nt- ,", but there is no definition for this alternative in the definitions of the"- ,"nonterminal" , getName @nt, ". Maybe you misspelled it? Otherwise insert a definition."- ]- act = wfill ["All rules for the unknown alternative have been ignored."]- in ppError (isError @lhs.options @me) (getPos @con) mesg pat help act @lhs.verbose-- | UndefChild lhs.pp = let mesg = wfill ["Constructor", getName @con, "of nonterminal" ,getName @nt- , "does not have a nontrivial field named", getName @name , "."- ]- pat = "SEM" >#< @nt- >-< indent 2 ("|" >#< getName @con >#< ppAttr @name (identifier "<attr>") >#< "= ...")-- help = wfill ["There are rules that define or use attributes of field" , getName @name- ,"in alternative" , getName @con , "of nonterminal" , getName @nt- ,", but there is no field with AG-type in the definition of the alternative."- ,"Maybe you misspelled it? Otherwise insert the field into the definition,"- ,"or change its type from an HS-type to an AG-type."- ]- act = wfill ["All rules for the unknown field have been ignored."]- in ppError (isError @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose-- | MissingRule lhs.pp = let mesg = wfill ["Missing rule for", showAttrDef @field @attr , "in alternative"- , getName @con , "of nonterminal",getName @nt ,"."- ]- pat = "SEM" >#< @nt- >-< indent 2 ("|" >#< getName @con >#< ppAttr @field @attr >#< "= ...")-- help = wfill ["The", showAttrDef @field @attr, "in alternative", getName @con- , "of nonterminal", getName @nt, "is missing and cannot be inferred"- ,"by a copy rule, so you should add an appropriate rule."- ]- act = wfill ["The value of the attribute has been set to undefined."]- in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose-- | MissingNamedRule lhs.pp = let mesg = wfill ["Missing rule name ", show @name , "in alternative"- , getName @con , "of nonterminal",getName @nt ,"."- ]- pat = "SEM" >#< @nt- >-< indent 2 ("|" >#< getName @con >#< show @name >#< ": ... = ...")-- help = wfill ["There is a dependency on a rule with name ", show @name , "in alternative"- , getName @con , "of nonterminal",getName @nt ,", but no rule has been defined with this name. Maybe you misspelled it?"- ]- act = wfill ["Compilation cannot continue."]- in ppError (isError @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose-- | SuperfluousRule lhs.pp = let mesg = wfill ["Rule for non-existing", showAttrDef @field @attr , "at alternative"- , getName @con , "of nonterminal",getName @nt, "."- ]- pat = "SEM" >#< getName @nt- >-< indent 2 ("|" >#< getName @con >#< ppAttr @field @attr >#< "= ...")--- help = wfill ["There is a rule for" , showAttrDef @field @attr , "in the definitions for alternative" , getName @con- ,"of nonterminal" , getName @nt, ", but this attribute does not exist. Maybe you misspelled it?"- ,"Otherwise either remove the rule or add an appropriate attribute definition."- ]- act = wfill ["The rule has been ignored."]- in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose-- | UndefLocal lhs.pp = let mesg = wfill ["Undefined local variable or field",getName @var, "at constructor"- , getName @con , "of nonterminal",getName @nt, "."- ]- pat = "SEM" >#< getName @nt- >-< indent 2 ("|" >#< getName @con >#< "<field>.<attr> = "- >#< "..." >#< "@" >|< getName @var >#< "..." )-- help = wfill ["A rule in the definitions for alternative" , getName @con ,"of nonterminal"- , getName @nt , "contains a local variable or field name that is not defined. "- ,"Maybe you misspelled it?"- ,"Otherwise either remove the rule or add an appropriate definition."- ]- act = wfill ["The generated program will not run."]- in ppError (isError @lhs.options @me) (getPos @var) mesg pat help act @lhs.verbose-- | ChildAsLocal lhs.pp = let mesg = wfill ["Nontrivial field ",getName @var, "is used as local at constructor"- , getName @con , "of nonterminal",getName @nt, "."- ]- pat = "SEM" >#< getName @nt- >-< indent 2 ("|" >#< getName @con >#< "... = "- >#< "..." >#< "@" >|< getName @var >#< "..." )-- help = wfill ["A rule in the definitions for alternative" , getName @con ,"of nonterminal"- , getName @nt , "contains a nontrivial field name", getName @var, "."- ,"You should use @", getName @var, ".self instead, where self is a SELF-attribute."- ]- act = wfill ["The generated program probably contains a type error or has undefined variables."]- in ppError (isError @lhs.options @me) (getPos @var) mesg pat help act @lhs.verbose-- | UndefAttr lhs.pp = let mesg = wfill ["Undefined"- , if @isOut- then showAttrDef @field @attr- else showAttrUse @field @attr- , "at constructor"- , getName @con , "of nonterminal",getName @nt, "."- ]- pat = "SEM" >#< getName @nt- >-< indent 2 ("|" >#< getName @con >#< "<field>.<attr> = "- >#< "..." >#< ppAttrUse @field @attr >#< "...")-- help = wfill ["A rule in the definitions for alternative" , getName @con ,"of nonterminal"- ,getName @nt , "contains an attribute that is not defined"- ,"Maybe you misspelled it?"- ,"Otherwise either remove the rule or add an appropriate attribute definition."- ]- act = wfill ["The generated program will not run."]- in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose-- | CyclicSet lhs.pp = let mesg = wfill ["Cyclic definition for nonterminal set", getName @name]- pat = "SET" >#< getName @name >#< "=" >#< "..." >#< getName @name >#< "..."- help = wfill ["The defintion for a nonterminal set named" , getName @name- ,"directly or indirectly refers to itself."- ,"Adapt the definition of the nonterminal set, to remove the cyclic dependency."- ]- 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"]- in ppError (isError @lhs.options @me) @pos @mesg pat help act False-- | LocalCirc lhs.pp = let mesg = wfill ["Circular dependency for local attribute", getName @attr- , "of alternative", getName @con, "of nonterminal", getName @nt]- pat = "SEM" >#< getName @nt- >-< indent 2 ("|" >#< getName @con >#< "loc." >|< getName @attr >#< "="- >#< "..." >#< "@loc." >|< getName @attr >#< "...")- help = if null @path- then text "the definition is directly circular"- else hlist ("The following attributes are involved in the cycle:": @path)- act | @o_visit = text "An unoptimized version was generated. It might hang when run."- | otherwise = text "The generated program might hang when run."- in ppError (isError @lhs.options @me) (getPos (@attr)) mesg pat help act @lhs.verbose-- | InstCirc lhs.pp = let mesg = wfill ["Circular dependency for inst attribute", getName @attr- , "of alternative", getName @con, "of nonterminal", getName @nt]- pat = "SEM" >#< getName @nt- >-< indent 2 ("|" >#< getName @con >#< "inst." >|< getName @attr >#< "="- >#< "..." >#< "@s.<some attribte>" >#< "...")- help = if null @path- then text "the definition is directly circular"- else hlist ("The following attributes are involved in the cycle:": @path)- act | @o_visit = text "An unoptimized version was generated. It might hang when run."- | otherwise = text "The generated program might hang when run."- in ppError (isError @lhs.options @me) (getPos (@attr)) mesg pat help act @lhs.verbose-- | DirectCirc lhs.pp = let mesg = wfill ["In nonterminal", getName @nt, "synthesized and inherited attributes are mutually dependent" ]- >-< vlist (map showEdge @cyclic)- pat = text ""- help = vlist (map showEdgeLong @cyclic)- act | @o_visit = text "An unoptimized version was generated. It might hang when run."- | otherwise = text "The generated program might hang when run."- in ppError (isError @lhs.options @me) noPos mesg pat help act @lhs.verbose-- | InducedCirc lhs.pp = let mesg = wfill ["After scheduling, in nonterminal", getName @nt, "synthesized and inherited attributes have an INDUCED mutual dependency" ]- >-< vlist (map showEdge @cyclic)- pat = text ""- showInter (CInterface segs) = concat (snd (mapAccumL (\i c -> (succ i :: Integer,("visit " ++ show i) : map ind (showsSegment c))) 0 segs))- help = vlist (("Interface for nonterminal " ++ getName @nt ++ ":") : map ind (showInter @cinter))- >-< vlist (map showEdgeLong @cyclic)- act = text "An unoptimized version was generated. It might hang when run."- in ppError (isError @lhs.options @me) noPos mesg pat help act @lhs.verbose-- | MissingTypeSig lhs.pp = let mesg = wfill ["Type signature needed, but not found for", showAttrDef _LOC @attr , "in alternative"- , getName @con , "of nonterminal",getName @nt ,"."- ]>-<- wfill ["Location:", (showPos @attr),"."]- pat = "SEM" >#< @nt- >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< ": ...")- help = wfill ["The", showAttrDef _LOC @attr, "in alternative", getName @con- ,"of nonterminal", getName @nt, "is needed in two separate visits to", getName @nt- ,"so its type is needed to generate type signatures."- ,"Please supply its type."- ]- act = wfill ["The type signatures of semantic functions are not generated."]- in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose-- | MissingInstSig lhs.pp = let mesg = wfill ["Type signature needed, but not found for", showAttrDef _INST @attr , "in alternative"- , getName @con , "of nonterminal",getName @nt ,"."- ]>-<- wfill ["Location:", (showPos @attr),"."]- pat = "SEM" >#< @nt- >-< indent 2 ("|" >#< getName @con >#< ppAttr _INST @attr >#< ": ...")- help = wfill ["The", showAttrDef _INST @attr, "in alternative", getName @con- ,"of nonterminal", getName @nt, "is a non-terminal attribute, so "- ,"its type is needed to attribute its value."- ,"Please supply its type."- ]- act = wfill ["It is not possible to proceed without this signature."]- in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose-- | MissingUnique lhs.pp = let mesg = wfill ["Missing unique counter (chained attribute)"- , getName @attr- , "at nonterminal"- , getName @nt, "."- ]- pat = "ATTR" >#< getName @nt >#< "[ |" >#< getName @attr >#< " : ... | ]"-- help = wfill ["A unique attribute signature in a constructor for nonterminal" , getName @nt- , "refers to an unique counter (chained attribute) named "- , getName @attr- ,"Maybe you misspelled it?"- ,"Otherwise either remove the signature or add an appropriate attribute definition."- ]- 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-- | DupUnique lhs.pp = let mesg = wfill ["At constructor",getName @con, "of nonterminal", getName @nt, "there are two or more unique-attribute signatures for"- ,showAttrDef _LOC @attr,"."- ] >-<- wfill ["First signature:", (showPos @attr),"."]-- pat = "SEM" >#< getName @nt- >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< " : UNIQUEREF ...")- >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< " : UNIQUEREF ...")-- help = wfill ["In the rules for alternative" , getName @con , "of nonterminal" , getName @nt- ,", there is more than one unique-attribute signature for the" , showAttrDef _LOC @attr- ,". You should remove enough of them to make all unique-signatures for alternative"- ,getName @con , "of nonterminal " ,getName @nt , "unique."- ]- act = wfill ["Unpredicatable sharing of unique numbers may occur."]- in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose-- | MissingSyn lhs.pp = let mesg = wfill ["Missing synthesized attribute"- , getName @attr- , "at nonterminal"- , getName @nt, "."- ]- pat = "ATTR" >#< getName @nt >#< "[ | | " >#< getName @attr >#< " : ... ]"-- help = wfill ["An augment rule for a constructor for nonterminal" , getName @nt- , "refers to a synthesized attribute named "- , getName @attr- ,"Maybe you misspelled it?"- ,"Otherwise add an appropriate attribute definition."- ]- 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 :: Int -> String -> String-toWidth n xs | k<n = xs ++ replicate (n-k) ' '- | otherwise = xs- where k = length xs--showEdge :: ((Identifier,Identifier),[String],[String]) -> PP_Doc-showEdge ((inh,syn),_,_)- = text ("inherited attribute " ++ toWidth 20 (getName inh) ++ " with synthesized attribute " ++ getName syn)--showEdgeLong :: ((Identifier,Identifier),[String],[String]) -> PP_Doc-showEdgeLong ((inh,syn),path1,path2)- = text ("inherited attribute " ++ getName inh ++ " is needed for " ++ "synthesized attribute " ++ getName syn)- >-< indent 4 (vlist (map text path2))- >-< text "and back: "- >-< indent 4 (vlist (map text path1))--attrText :: Identifier -> Identifier -> String-attrText inh syn- = if inh == syn- then "threaded attribute " ++ getName inh- else "inherited attribute " ++ getName inh ++ " and synthesized attribute " ++getName syn--showLineNr :: Int -> String-showLineNr i | i==(-1) = "CR"- | otherwise = show i--showAttrDef :: Identifier -> Identifier -> String-showAttrDef f a | f == _LHS = "synthesized attribute " ++ getName a- | f == _LOC = "local attribute " ++ getName a- | f == _INST = "inst attribute " ++ getName a- | otherwise = "inherited attribute " ++ getName a ++ " of field " ++ getName f--showAttrUse :: Identifier -> Identifier -> String-showAttrUse f a | f == _LHS = "inherited attribute " ++ getName a- | f == _LOC = "local attribute " ++ getName a- | f == _INST = "inst attribute " ++ getName a- | otherwise = "synthesized attribute " ++ getName a ++ " of field " ++ getName f--ppAttr :: Identifier -> Identifier -> PP_Doc-ppAttr f a = text (getName f++"."++getName a)-ppAttrUse :: Identifier -> Identifier -> PP_Doc-ppAttrUse f a = "@" >|< ppAttr f a-}--- Printing of error messages--{-infixr 5 +#+-(+#+) :: String -> String -> String-(+#+) s t = s ++ " " ++ t--infixr 5 +.+-(+.+) :: Identifier -> Identifier -> String-(+.+) s t = getName s ++ "." ++ getName t--wfill :: [String] -> PP_Doc-wfill = fill . addSpaces. concat . map words- where addSpaces (x:xs) = x:map addSpace xs- addSpaces [] = []- addSpace [x] | x `elem` ".,;:!?" = [x]- addSpace xs = ' ':xs--ppError :: Bool -- class of the error, True:error False:warning- -> Pos -- source position- -> PP_Doc -- error message- -> PP_Doc -- pattern- -> PP_Doc -- help, more info- -> PP_Doc -- action taken by AG- -> Bool -- verbose? show help and action?- -> PP_Doc-ppError isErr pos mesg pat hlp act verb- = let position = case pos of- Pos l c f | l >= 0 -> f >|< ":" >|< show l >|< ":" >|< show c- | otherwise -> pp "uuagc"- tp = if isErr then "error" else "warning"- header = position >|< ":" >#< tp >|< ":" >#< mesg- pattern = "pattern :" >#< pat- help = "help :" >#< hlp- action = "action :" >#< act- in if verb- then vlist [text "",header,pattern,help,action]- else header--{---- old error reporting code- = let- cl = if isError then "ERROR" else "Warning"- position = case pos of- (Pos l c f) | l >= 0 -> f >|< ": line " >|< show l >|< ", column " >|< show c- | otherwise -> empty- header = "*** UU.AG" >#< cl >#< position >#< "***"- message = "problem :" >#< mesg- pattern = "pattern :" >#< pat- help = "help :" >#< hlp- action = "action :" >#< act- in- if verbose- then vlist [text "",header,message,pattern,help,action]- else vlist [text "",header,message]--}--showPos :: Identifier -> String-showPos = show . getPos--ppInterface :: Show a => a -> PP_Doc-ppInterface inter = wfill ["interface:", show inter]--}-
− src-ag/PrintOcamlCode.ag
@@ -1,222 +0,0 @@-PRAGMA strictdata-PRAGMA optimize-PRAGMA bangpats-PRAGMA strictwrap--INCLUDE "Code.ag"-INCLUDE "Patterns.ag"--imports-{-import Pretty-import Code-import Patterns-import Options-import CommonTypes hiding (List,Type,Map,Maybe,IntMap,Either)-import Data.List(intersperse,intercalate)-import Data.Char(toLower)-}---{-type PP_Docs = [PP_Doc]--ppMultiSeqH :: [PP_Doc] -> PP_Doc -> PP_Doc-ppMultiSeqH = ppMultiSeq' (>#<)--ppMultiSeqV :: [PP_Doc] -> PP_Doc -> PP_Doc-ppMultiSeqV = ppMultiSeq' (>-<)--ppMultiSeq' :: (PP_Doc -> PP_Doc -> PP_Doc) -> [PP_Doc] -> PP_Doc -> PP_Doc-ppMultiSeq' next strictArgs expr- = foldr (\v r -> (v >#< "`seq`") `next` pp_parens r) expr strictArgs--ppTuple :: Bool -> [PP_Doc] -> PP_Doc-ppTuple True pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps-ppTuple False pps = "(" >|< pp_block " " ")" "," pps-}-------- Pass options down-----ATTR Program Expr Exprs Decl Decls Chunk Chunks CaseAlts CaseAlt Lhs Pattern Patterns [ options:{Options} | | ]--ATTR Program Chunks Chunk [ textBlockMap : {Map BlockInfo PP_Doc} | | ]-------- Collect outputs-----ATTR Program [ | | output:{PP_Docs} ]-ATTR Expr Decl DataAlt CaseAlt Type NamedType Lhs Pattern [ | | pp:{PP_Doc} ]-ATTR Exprs DataAlts CaseAlts Types NamedTypes Decls Chunk Chunks Patterns [ | | pps : {PP_Docs} ]--SEM Program- | Program lhs.output = @chunks.pps--SEM Exprs- | Cons lhs.pps = @hd.pp : @tl.pps- | Nil lhs.pps = []--SEM CaseAlts- | Cons lhs.pps = @hd.pp : @tl.pps- | Nil lhs.pps = []--SEM DataAlts- | Cons lhs.pps = @hd.pp : @tl.pps- | Nil lhs.pps = []--SEM Types- | Cons lhs.pps = @hd.pp : @tl.pps- | Nil lhs.pps = []--SEM NamedTypes- | Cons lhs.pps = @hd.pp : @tl.pps- | Nil lhs.pps = []--SEM Decls- | Cons lhs.pps = @hd.pp : @tl.pps- | Nil lhs.pps = []--SEM Chunks- | Cons lhs.pps = @hd.pps ++ @tl.pps- | Nil lhs.pps = []--SEM Patterns- | Cons lhs.pps = @hd.pp : @tl.pps- | Nil lhs.pps = []------- Individual cases-----SEM Chunk- | Chunk lhs.pps = @comment.pp- : @info.pps- ++ @dataDef.pps- ++ @semDom.pps- ++ @semFunctions.pps- ++ @semWrapper.pps- ++ @cataFun.pps- ++ [Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap]--SEM Decl- | Decl lhs.pp = if @lhs.isToplevel- then "let" >#< @left.pp >#< "="- >-< indent 4 @rhs.pp >#< ";;"- else "let" >#< @left.pp >#< "="- >-< indent 4 @rhs.pp >#< "in"- | Bind lhs.pp = error "pp of Decl.Bind not supported"- | BindLet lhs.pp = error "pp of Decl.BindLet not supported"- | Data lhs.pp = "type" >#< hv_sp (map (\p -> "'" >|< p) @params ++ [text $ toOcamlTC @name])- >#< ( case @alts.pps of- [] -> empty- (x:xs) -> "=" >#< x- >-< vlist (map ("|" >#<) xs)- )- >#< ";;"- | NewType lhs.pp = error "pp of Decl.NewType not supported"- | Type lhs.pp = "type" >#< hv_sp (map (\p -> "'" >|< p) @params ++ [text $ toOcamlTC @name]) >#< "=" >#< @tp.pp >#< ";;"- | TSig lhs.pp = "(*" >#< @name >#< ":" >#< @tp.pp >#< "*)"- | Comment lhs.pp = if '\n' `elem` @txt- then "(* " >-< vlist (lines @txt) >-< "*)"- else "(*" >#< @txt >#< "*)"- | PragmaDecl lhs.pp = error "pp of Decl.PragmaDecl not supported"--- SEM Expr- | Let lhs.pp = pp_parens $ vlist (@decls.pps ++ [@body.pp])- | Case lhs.pp = pp_parens ( "match" >#< @expr.pp >#< "with"- >-< indent 2 ( case @alts.pps of- [] -> empty- (x:xs) -> " " >#< x- >-< vlist (map ("|" >#<) xs)- )- )- | Do lhs.pp = error "pp of Expr.Do not supported"- | Lambda lhs.pp = pp_parens ( pp "fun" >#< hv_sp @args.pps >#< "->"- >-< indent 2 @body.pp )- | TupleExpr lhs.pp = ppTuple False @exprs.pps- | UnboxedTupleExpr lhs.pp = error "pp of Expr.UnboxedTupleExpr not supported"- | App lhs.pp = pp_parens $ @name >#< hv_sp @args.pps- | SimpleExpr lhs.pp = text @txt- | TextExpr lhs.pp = vlist (map text @lns)- | Trace lhs.pp = @expr.pp- | PragmaExpr lhs.pp = @expr.pp- | LineExpr lhs.pp = @expr.pp- | TypedExpr lhs.pp = @expr.pp--SEM Lhs- | Pattern3 lhs.pp = @pat3.pp- | Pattern3SM lhs.pp = error "pp of Lhs.Pattern3SM not supported"- | TupleLhs lhs.pp = ppTuple False (map text @comps)- | UnboxedTupleLhs lhs.pp = error "pp of Lhs.UnboxedTupleLhs not supported"- | Fun lhs.pp = @name >#< hv_sp @args.pps- | Unwrap lhs.pp = pp_parens (@name >#< @sub.pp)--SEM Type- | Arr lhs.pp = pp_parens (@left.pp >#< "->" >#< @right.pp)- | CtxApp lhs.pp = error "pp of Type.CtxApp not supported"- | TypeApp lhs.pp = pp_parens (hv_sp (@args.pps ++ [@func.pp]))- | TupleType lhs.pp = pp_block "(" ")" "," @tps.pps- | UnboxedTupleType- lhs.pp = error "pp of Type.UnboxedTupleType is not supported"- | List lhs.pp = @tp.pp >#< "list"- | SimpleType lhs.pp = text @txt- | NontermType lhs.pp = pp_block "(" ")" " " (map text @params ++ [text $ toOcamlTC @name])- | TMaybe lhs.pp = @tp.pp >#< "opt"- | TEither lhs.pp = error "pp of Type.TEither is not supported"- | TMap lhs.pp = error "pp of Type.TMap is not supported"- | TIntMap lhs.pp = error "pp of Type.TIntMap is not supported"- | TSet lhs.pp = error "pp of Type.TSet is not supported"- | TIntSet lhs.pp = error "pp of Type.TIntSet is not supported"--{-toOcamlTC :: String -> String-toOcamlTC (c:cs) = toLower c : cs-toOcamlTC xs = xs-}--SEM CaseAlt- | CaseAlt lhs.pp = @left.pp >#< "->" >#< @expr.pp--SEM DataAlt- | DataAlt lhs.pp = @name >#< "of" >#< pp_block "" "" " * " (map pp_parens @args.pps)- | Record lhs.pp = pp_block "{" "}" ";" @args.pps--SEM NamedType- | Named lhs.pp = @name >#< ":" >#< @tp.pp--SEM Pattern- | Constr lhs.pp = pp_parens $ @name >#< hv_sp @pats.pps- | Product lhs.pp = pp_block "(" ")" "," @pats.pps- | Alias -- assuming here that there is only an underscore under an alias- lhs.pp = if @pat.isUnderscore- then pp (attrname @lhs.options False @field @attr)- else error "pp of Pattern.Alias is only supported in the form (x@_)"- | Irrefutable lhs.pp = error "pp of Pattern.Irrefutable not supported"- | Underscore lhs.pp = text "_"--SEM Pattern [ | | isUnderscore:{Bool}]- | Constr lhs.isUnderscore = False- | Product lhs.isUnderscore = False- | Alias lhs.isUnderscore = False- | Underscore lhs.isUnderscore = True------- Determine if a declaration is toplevel-----ATTR Chunks Chunk Decls Decl [ isToplevel : Bool | | ]-SEM Program- | Program- chunks.isToplevel = True--SEM Expr- | Let- decls.isToplevel = False- | Do- stmts.isToplevel = False
− src-ag/PrintVisitCode.ag
@@ -1,53 +0,0 @@-PRAGMA strictwrap-PRAGMA strictdata-PRAGMA optimize--INCLUDE "CodeSyntax.ag"-INCLUDE "Patterns.ag"-INCLUDE "DeclBlocks.ag"--imports-{-import CommonTypes-import SequentialTypes-import Options-import CodeSyntax-import ErrorMessages-import GrammarInfo-import DeclBlocks-import Pretty--import qualified Data.Map as Map-import Data.Map(Map)-import qualified Data.Set as Set-import Data.Set(Set)-import qualified Data.Sequence as Seq-import Data.Sequence(Seq)-import UU.Scanner.Position--import Data.List(partition,intersperse,intersect,(\\))-import Data.Maybe(fromJust,isJust)-}--{-type PP_Docs = [PP_Doc]--ppMultiSeqH :: [PP_Doc] -> PP_Doc -> PP_Doc-ppMultiSeqH = ppMultiSeq' (>#<)--ppMultiSeqV :: [PP_Doc] -> PP_Doc -> PP_Doc-ppMultiSeqV = ppMultiSeq' (>-<)--ppMultiSeq' :: (PP_Doc -> PP_Doc -> PP_Doc) -> [PP_Doc] -> PP_Doc -> PP_Doc-ppMultiSeq' next strictArgs expr- = foldr (\v r -> (v >#< "`seq`") `next` pp_parens r) expr strictArgs-}---WRAPPER CGrammar--ATTR CGrammar [ options:{Options} | | output:{PP_Docs} ]--SEM CGrammar- | CGrammar- lhs.output = []
− src-ag/ResolveLocals.ag
@@ -1,157 +0,0 @@-INCLUDE "AbstractSyntax.ag"-INCLUDE "Patterns.ag"-INCLUDE "Expression.ag"-INCLUDE "DistChildAttr.ag"-------- Checks right-hand sides for missing attributes.--- Attribute references @xxx are now explicitly mapped to @loc.xxx if there is such--- an attribute in scope and there is no terminal @xxx.------imports-{-import qualified Data.Set as Set-import qualified Data.Map as Map-import Data.Map(Map)-import qualified Data.Sequence as Seq-import Data.Sequence(Seq,(><))-import CommonTypes-import Patterns-import ErrorMessages-import AbstractSyntax-import Expression-import Options-import HsToken(HsTokensRoot(HsTokensRoot))-import SemHsTokens(sem_HsTokensRoot,wrap_HsTokensRoot, Syn_HsTokensRoot(..),Inh_HsTokensRoot(..))-import Data.Maybe-}--WRAPPER Grammar-------- Main attributes-----ATTR Grammar Nonterminals Nonterminal Productions Production Rule Rules Expression- [ options:{Options} | | ]--ATTR Grammar Nonterminals Nonterminal Productions Production Rule Rules Pattern Patterns Expression- [ | | errors USE {Seq.><} {Seq.empty} : {Seq Error} ]--ATTR Grammar Nonterminals Nonterminal Productions Production Child Children Rule Rules Pattern Patterns TypeSig TypeSigs Expression- [ | | output : SELF ]------- Collect inputs to expressions------- Collecting nts-ATTR Nonterminal Nonterminals- Production Productions- Rule Rules- Child Children [allnts:{[Identifier]} | | ]--SEM Grammar- | Grammar nonts.allnts = map fst (@nonts.nonts)--ATTR Nonterminals Nonterminal [ | | nonts USE {++} {[]} : {[(NontermIdent,[ConstructorIdent])]} ]-SEM Nonterminal- | Nonterminal lhs.nonts = [(@nt,@prods.cons)]-ATTR Productions Production [ | | cons USE {++} {[]} : {[ConstructorIdent]} ]-SEM Production- | Production lhs.cons = [@con]---- Collecting fields-ATTR Rule Rules- Child Children [allfields:{[(Identifier,Type,ChildKind)]} attrs:{[(Identifier,Identifier)]} | | ]--SEM Production- | Production loc.allfields = @children.fields- .attrs = map ((,) _LOC) @rules.locVars ++- map ((,) _INST) @rules.instVars ++- map ((,) _LHS) @inhnames ++- concat [map ((,) nm) (Map.keys as) | (nm,_,as) <- @children.attributes]- .inhnames = Map.keys @lhs.inh- .synnames = Map.keys @lhs.syn--ATTR Children [ | | attributes USE {++} {[]} : {[(Identifier,Attributes,Attributes)]} ]-SEM Child [ | | attributes:{[(Identifier,Attributes,Attributes)]} ]- | Child lhs.attributes = [(@name, @loc.inh, @loc.syn)]--SEM Child [ | | field : {(Identifier,Type,ChildKind)} ]- | Child lhs.field = (@name, @tp, @kind)--SEM Children [ | | fields : {[(Identifier,Type,ChildKind)]} ]- | Cons lhs.fields = @hd.field : @tl.fields- | Nil lhs.fields = []--ATTR Rules Rule Patterns Pattern [ | | locVars USE {++} {[]}:{[Identifier]} instVars USE {++} {[]} : {[Identifier]} ]--SEM Pattern- | Alias lhs.locVars = if @field == _LOC- then [@attr]- else []- lhs.instVars = if @field == _INST- then [@attr]- else []---- Distributing name of nonterminal and names of attributes-ATTR Productions Production Child Children Rules Rule Patterns Pattern [ nt : {Identifier} inh,syn : {Attributes} | | ]-ATTR Child Children Rules Rule Patterns Pattern [ con : {Identifier} | | ]--SEM Production- | Production children . con = @con-SEM Production- | Production rules . con = @con-SEM Nonterminal- | Nonterminal prods . nt = @nt--SEM Nonterminal- | Nonterminal prods.inh = @inh- prods.syn = @syn---- merge map-SEM Grammar- | Grammar nonts.mergeMap = Map.map (Map.map (Map.map (\(nt,srcs,_) -> (nt,srcs)))) @mergeMap--ATTR Nonterminals Nonterminal- [ mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))} | | ]--ATTR Productions Production- [ mergeMap : {Map ConstructorIdent (Map Identifier (Identifier,[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--ATTR Rules Rule Children Child Expression [ mergeMap : {Map Identifier (Identifier,[Identifier])} | | ]-------- Handling Expressions-----ATTR Expression [ nt,con :{Identifier}- allfields:{[(Identifier,Type,ChildKind)]}- allnts :{[Identifier]}- attrs :{[(Identifier,Identifier)]}- || ]--SEM Expression- | Expression loc.(errors,newTks)- = let mergedChildren = [ x | (_,xs) <- Map.elems @lhs.mergeMap, x <- xs ]- attrsIn = filter (\(fld,_) -> not (fld `elem` mergedChildren)) @lhs.attrs- inherited = Inh_HsTokensRoot- { attrs_Inh_HsTokensRoot = attrsIn- , con_Inh_HsTokensRoot = @lhs.con- , allfields_Inh_HsTokensRoot = @lhs.allfields- , allnts_Inh_HsTokensRoot = @lhs.allnts- , nt_Inh_HsTokensRoot = @lhs.nt- , options_Inh_HsTokensRoot = @lhs.options- }- synthesized = wrap_HsTokensRoot (sem_HsTokensRoot (HsTokensRoot @tks)) inherited- in (errors_Syn_HsTokensRoot synthesized, output_Syn_HsTokensRoot synthesized)- lhs.output = Expression @pos @loc.newTks
− src-ag/SemHsTokens.ag
@@ -1,144 +0,0 @@-INCLUDE "HsToken.ag"--imports-{-import qualified Data.Sequence as Seq-import Data.Sequence(Seq,empty,singleton,(><))-import Data.Foldable(toList)-import Pretty--import TokenDef-import HsToken-import ErrorMessages-}--ATTR HsTokensRoot- [- | |- errors USE {Seq.><} {Seq.empty}:{Seq Error}- usedLocals:{[Identifier]}- usedAttrs :{[(Identifier,Identifier)]}- textLines :{[String]}- usedFields:{[Identifier]}- ]------------------------------------------------------------------------------------ Context information---------------------------------------------------------------------------------ATTR HsTokensRoot- HsTokens HsToken [ nt,con : {Identifier}- allfields : {[(Identifier,Type,ChildKind)]}- allnts : {[Identifier]}- attrs : {[(Identifier,Identifier)]}- options : {Options}- ||- ]--ATTR HsTokens HsToken [ fieldnames : {[Identifier]} | | ]-SEM HsTokensRoot- | HsTokensRoot tokens.fieldnames = map (\(n,_,_) -> n) @lhs.allfields------------------------------------------------------------------------------------ Errors---------------------------------------------------------------------------------ATTR HsTokens HsToken [ | | errors USE {Seq.><} {Seq.empty}:{Seq Error} ]------------------------------------------------------------------------------------ Syntax errors----------------------------------------------------------------------------------SEM HsToken- | Err lhs.errors = let m = text @mesg- in Seq.singleton (CustomError False @pos m)------------------------------------------------------------------------------------ Undefined variables----------------------------------------------------------------------------------{-isNTname allnts (Just (NT nt _ _)) = nt `elem` allnts-isNTname allnts _ = False-}----- An AGLocal is either a local variable or a terminal-SEM HsToken- | AGLocal loc.tkAsLocal = AGLocal @var @pos @rdesc -- refers to the terminal- loc.tkAsField = AGField _LOC @var @pos @rdesc -- refers to the (local) attribute- loc.(errors,output,tok,usedLocals) =- if @var `elem` @lhs.fieldnames -- check if @var occurs as a terminal- then if isNTname @lhs.allnts (lookup @var (map (\(n,t,_) -> (n,t)) @lhs.allfields))- then (Seq.singleton(ChildAsLocal @lhs.nt @lhs.con @var), @loc.tkAsLocal,(@pos,fieldname @var), [] )- else (Seq.empty, @loc.tkAsLocal, (@pos,fieldname @var), [] )- else if (_LOC,@var) `elem` @lhs.attrs- then (Seq.empty , @loc.tkAsField, (@pos,locname @lhs.options @var), [@var])- else (Seq.singleton(UndefLocal @lhs.nt @lhs.con @var), @loc.tkAsField, (@pos,locname @lhs.options @var), [] )--SEM HsToken- | AGField lhs.errors = if (@field,@attr) `elem` @lhs.attrs- then Seq.empty- else if not(@field `elem` (_LHS : _LOC: @lhs.fieldnames))- then Seq.singleton (UndefChild @lhs.nt @lhs.con @field)- else Seq.singleton (UndefAttr @lhs.nt @lhs.con @field @attr False)------------------------------------------------------------------------------------ Used variables----------------------------------------------------------------------------------ATTR HsTokens HsToken [ | | usedLocals USE {++} {[]} : {[Identifier]}- usedAttrs USE {++} {[]} : {[(Identifier,Identifier)]} ]--SEM HsToken- | AGField (lhs.usedAttrs,lhs.usedLocals)- = if @field == _LOC- then ([], [@attr])- else ([(@field,@attr)], [])------------------------------------------------------------------------------------- Used fields---------------------------------------------------------------------------------ATTR HsTokens HsToken [ | | usedFields USE {Seq.><} {Seq.empty} : {Seq Identifier} ]--SEM HsToken- | AGLocal lhs.usedFields = if @var `elem` @lhs.fieldnames- then Seq.singleton @var- else Seq.empty-SEM HsTokensRoot- | HsTokensRoot lhs.usedFields = toList @tokens.usedFields------------------------------------------------------------------------------------ Pretty printing----------------------------------------------------------------------------------SEM HsTokensRoot- | HsTokensRoot lhs.textLines = showTokens @tokens.tks--SEM HsTokens [ || tks : {[(Pos,String)]} ]- | Cons lhs.tks = @hd.tok : @tl.tks- | Nil lhs.tks = []--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 @lhs.options 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, "")------------------------------------------------------------------------------------ Desugar (resolve AGLocals to explicit AGFields)----------------------------------------------------------------------------------ATTR HsTokensRoot [ | | output : {[HsToken]} ]-ATTR HsTokens HsToken [ | | output : SELF ]-
− src-ag/TfmToVisage.ag
@@ -1,147 +0,0 @@--- !!!! The Visage AST does not support nonterminals with type variables!--- !!!! Type variables in data type declarations are ignored.--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--- 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 _ = False--type VisageRuleMap = [(String, VisageRule)]--splitVRules :: [VisageRule] -> VisageRuleMap-splitVRules vrs = concat (map unfoldvrs vrs)--unfoldvrs :: VisageRule -> VisageRuleMap-unfoldvrs vr@(VRule attrfields _ _ _ _) = zip (map (getName . fst) attrfields) (map (copyRule vr) attrfields)--copyRule :: VisageRule -> (Identifier,Identifier) -> VisageRule-copyRule (VRule attrfields _ pat expr owrt) (field,attr) = VRule attrfields attr pat expr owrt--getForField :: String -> VisageRuleMap -> [VisageRule]-getForField field xs = map snd (filter ((field ==) . fst) xs)--{-- Delivers a map from fieldname to VisageRule with all references to others underscored.- So, (lhs.x, rt.y, loc.z) = (0,1,2) becomes something like- [("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))--splitVRules :: [VisageRule] -> VisageRuleMap-splitVRules vrs = concat (map allways vrs)--underScoreRule :: VisageRule -> String -> VisageRule-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 (VProduct pos pats) = VProduct pos (map (underScore field) pats)-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)- then vp- else (VUnderscore (getPos afield))-underScore field vp@(VUnderscore pos) = vp---}-}---ATTR Expression Pattern Patterns [ | | self : SELF ]--ATTR Grammar [ || visage:{VisageGrammar} ]-ATTR Nonterminal [ || vnont:{VisageNonterminal} ]-ATTR Nonterminals [ || vnonts:{[VisageNonterminal]} ]-ATTR Production [ || vprod:{VisageProduction} ]-ATTR Productions [ || vprods:{[VisageProduction]} ]-ATTR Rule [ || vrule : {VisageRule} ]-ATTR Rules [ || vrules : {[VisageRule]} ]-ATTR Child [ rulemap : {VisageRuleMap} || vchild:{VisageChild} ]-ATTR Children [ rulemap : {VisageRuleMap} || vchildren:{[VisageChild]} ]-ATTR Pattern [ || vpat:{VisagePattern} ]-ATTR Patterns [ || vpats: {[VisagePattern]} ]--SEM Grammar- | Grammar- lhs.visage = VGrammar @nonts.vnonts--SEM Nonterminals- | Cons- lhs.vnonts = @hd.vnont : @tl.vnonts- | Nil- lhs.vnonts = []--SEM Nonterminal- | Nonterminal- lhs.vnont = VNonterminal @nt @inh @syn @prods.vprods--SEM Productions- | Cons- lhs.vprods = @hd.vprod : @tl.vprods- | Nil- lhs.vprods = []--SEM Production- | Production- lhs.vprod = VProduction @con @children.vchildren @lhsrules @locrules- loc.splitVRules = splitVRules @rules.vrules- loc.locrules = getForField "loc" @splitVRules- loc.lhsrules = getForField "lhs" @splitVRules- children.rulemap = @splitVRules--SEM Children- | Cons lhs.vchildren = @hd.vchild : @tl.vchildren- | Nil lhs.vchildren = []--SEM Child- | Child lhs.vchild = VChild @name @tp @loc.inh @loc.syn (getForField (getName @name) @lhs.rulemap)--SEM Rules- | Cons lhs.vrules = @hd.vrule : @tl.vrules- | Nil lhs.vrules = []---- The undefined may seem strange, but it really belongs there.-SEM Rule- | Rule lhs.vrule = VRule @pattern.fieldattrs undefined @pattern.vpat @rhs.self @owrt--SEM Patterns- | Cons lhs.vpats = @hd.vpat : @tl.vpats- | Nil lhs.vpats = []--SEM Pattern- | Constr lhs.vpat = VConstr @name @pats.vpats- | Product lhs.vpat = VProduct @pos @pats.vpats- | 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)] } ]--SEM Pattern- | Alias lhs.fieldattrs = [(@field, @attr)]
− src-ag/Transform.ag
@@ -1,1371 +0,0 @@-PRAGMA strictdata-PRAGMA strictwrap--INCLUDE "ConcreteSyntax.ag"-INCLUDE "Patterns.ag"--imports-{-import Control.Monad(mplus,mzero)-import Data.List (partition, nub,intersperse, union)-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, elems)-import qualified Data.Sequence as Seq-import Data.Sequence(Seq, (><))-import UU.Scanner.Position(noPos)--import ConcreteSyntax-import AbstractSyntax-import ErrorMessages-import Patterns (Patterns,Pattern(..))-import Expression (Expression(..))-import HsToken--import RhsCheck-import Debug.Trace-}------------------------------------------------------------------------------------- Main goal------------------------------------------------------------------------------------ Given some options, we want to construct a Grammar, that is, a structure that conforms to AbstractSyntax-ATTR AG [ | | output : Grammar ]-ATTR AG Elems Elem SemAlts SemAlt SemDefs SemDef Attrs [ options : Options | | ]---- as a side effect, we generate error messages and Haskell code blocks that need to be embedded in the final code-ATTR AG Elems Elem SemAlts SemAlt Attrs NontSet ConstructorSet SemDefs SemDef- [ | | errors USE {Seq.><}{Seq.empty}:{Seq Error} ]-ATTR AG Elems Elem- [ | | blocks USE {`mapUnionWithPlusPlus`} {Map.empty}: {Blocks} ]----- The output is produced by calling a function that constructs the Grammar,--- given various datastructures that are collected from the concrete AG.--SEM AG- | AG lhs.output = constructGrammar @loc.allNonterminals- @elems.paramsCollect- @loc.allConParams- @loc.allFields- @loc.prodOrder- @loc.allConstraints- @loc.allAttrDecls- @elems.useMap- @elems.derivings- (if wrappers @lhs.options then @loc.allNonterminals else @elems.wrappers)- @loc.checkedRules- @loc.checkedSigs- @loc.checkedInsts- @elems.typeSyns- @elems.semPragmasCollect- @elems.attrOrderCollect- @elems.ctxCollect- @elems.quantCollect- @loc.checkedUniques- @loc.checkedAugments- @loc.checkedArounds- @loc.checkedMerges- @loc.allMacros------------------------------------------------------------------------------------- Main data flow----------------------------------------------------------------------------------{- Information is collected bottom-up (in multiple phases)- After checking for consistency, datastructures are createad from it,- which are passed down for the other phases.--}----- Names that are in use-- -- bottom-up collection-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 Fields Field NontSet [ allNonterminals : {Set NontermIdent} | | ]----- Constructors that are in use- -- bottom-up collection-ATTR Alt Alts ConstructorSet [ | | collectedConstructorNames USE {`Set.union`} {Set.empty} : {Set ConstructorIdent} ]-ATTR Elem Elems [ | | collectedConstructorsMap USE {`mapUnionWithSetUnion`} {Map.empty} : {Map NontermIdent (Set ConstructorIdent)} ]- -- top-down distribution-ATTR Elem Elems Alts Alt [ allConstructors : {Map NontermIdent (Set ConstructorIdent)} | | ]------ Nonterminal sets that are defined-{type DefinedSets = Map Identifier (Set NontermIdent) }- -- bottom-up collection-ATTR Elem Elems- [ | defSets:{Map Identifier (Set NontermIdent,Set Identifier)} | ]- -- top-down distribution-ATTR Elem Elems NontSet- [ definedSets:{DefinedSets} | | ]------ Interpreting nonterminal sets-ATTR NontSet [ | | nontSet : {Set NontermIdent} ]----- Interpreting constructor sets-ATTR ConstructorSet [ | | constructors : {(Set ConstructorIdent->Set ConstructorIdent)} ]------ Contextfree structure-{type FieldMap = [(Identifier, Type)] }-{type DataTypes = Map.Map NontermIdent (Map.Map ConstructorIdent FieldMap) }- -- bottom-up collection-ATTR Alt Alts Elem Elems- [ | | 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} | | ]------ Attribute declarations- -- bottom-up collection-ATTR Elems Elem Attrs- [- | attrDecls:{Map NontermIdent (Attributes, Attributes)}- | useMap USE {`merge`} {Map.empty}:{Map NontermIdent (Map Identifier (String,String,String))}- ]----- Attribute definitions-{type AttrName = (Identifier,Identifier) }-{type RuleInfo = (Maybe Identifier, [AttrName]->Pattern, Expression, [AttrName], Bool, String, Bool, Bool) }-{type SigInfo = (Identifier,Type) }-{type UniqueInfo = (Identifier,Identifier) }-{type AugmentInfo = (Identifier,Expression)}-{type AroundInfo = (Identifier,Expression)}-{type MergeInfo = (Identifier, Identifier, [Identifier], Expression)}- -- bottom-up collection-ATTR Elem Elems SemAlt SemAlts- [ | | collectedRules USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, RuleInfo)]}- collectedSigs USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, SigInfo) ]}- collectedInsts USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, [Identifier]) ]}- collectedUniques USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, [UniqueInfo]) ]}- collectedAugments USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, [AugmentInfo]) ]}- collectedArounds USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, [AroundInfo]) ]}- collectedMerges USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, [MergeInfo]) ]}- ]-------------------------------------------------------------------------------------- Passing nonterminals------------------------------------------------------------------------------------ Pass the name of the associated nonterminal to everyone-ATTR Alt Alts SemAlt SemAlts [ nts:{Set NontermIdent} | | ]--SEM Elem- | Data alts.nts = @names.nontSet- | Sem alts.nts = @names.nontSet-------------------------------------------------------------------------------------- Calculation of code blocks ------------------------------------------------------------------------------------SEM Elem- | Txt loc.blockInfo = ( @kind- , @mbNt- )- loc.blockValue = [(@lines, @pos)]- lhs.blocks = Map.singleton @loc.blockInfo @loc.blockValue- lhs.errors = if checkParseBlock @lhs.options- then let ex = Expression @pos tks- tks = [tk]- tk = HsToken (unlines @lines) @pos- in Seq.fromList $ checkBlock $ ex- else Seq.empty------------------------------------------------------------------------------------- Check for duplicates and report error----------------------------------------------------------------------------------{--checkDuplicate :: (Identifier -> Identifier -> Error)- -> Identifier -> val -> Map Identifier val -> (Map Identifier val,Seq Error)-checkDuplicate dupError key val m- = case Map.lookupIndex key m of- Just ix -> let (key',_) = Map.elemAt ix m- in (m,Seq.singleton (dupError key key'))- Nothing -> (Map.insert key val m,Seq.empty)--checkDuplicates :: (Identifier -> Identifier -> Error)- -> [(Identifier, val)] -> Map Identifier val -> (Map Identifier val,Seq Error)-checkDuplicates dupError new m = foldErrors check m new- where check = uncurry (checkDuplicate dupError)--foldErrors :: (b -> t -> (t, Seq Error)) -> t -> [b] -> (t, Seq Error)-foldErrors f n xs = foldl g (n,Seq.empty) xs- where g ~(e,es) x = let (e',es') = f x e- in (e', es >< es')---checkForDuplicates :: (Identifier -> Identifier -> Error) -> [Identifier] -> [Error]-checkForDuplicates _ [] = []-checkForDuplicates err (x:xs) = let (same,other) = partition (equalId x) xs- in map (err x) same ++ checkForDuplicates err other--equalId :: Identifier -> Identifier -> Bool-equalId x y = getName x == getName y--}------------------------------------------------------------------------------------ Collecting DATA's and type synonyms-----------------------------------------------------------------------------------SEM Alt- | Alt lhs.collectedFields = [ (nt, con, @fields.collectedFields)- | nt <- Set.toList @lhs.nts- , con <- Set.toList (@names.constructors (Map.findWithDefault Set.empty nt @lhs.allConstructors))- ]- 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--SEM AG- | AG- loc.prodOrder = let f (nt,con,_) = Map.insertWith g nt [con]- g [con] lst | con `elem` lst = lst- | otherwise = con : lst- g _ _ = error "This is not possible"- in foldr f Map.empty @elems.collectedFields- 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-- loc.allRules = let f (nt,con,r) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con [r])- in foldr f (Map.empty) @elems.collectedRules-- loc.allSigs = let f (nt,con,t) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con [t])- typeof nt r = Map.findWithDefault (Haskell "<unknown>") r $ fst $ Map.findWithDefault (Map.empty,Map.empty) nt @loc.allAttrDecls- in foldr f (Map.empty) ( @elems.collectedSigs- ++ [ (nt, con, (ident,typeof nt ref)) | (nt, con, us) <- @elems.collectedUniques, (ident,ref) <- us ]- )-- loc.allInsts = let f (nt,con,is) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con is)- in foldr f (Map.empty) @elems.collectedInsts-- loc.allUniques = let f (nt,con,us) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con us)- in foldr f (Map.empty) @elems.collectedUniques- loc.allAugments = let f (nt,con,as) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con as)- in foldr f Map.empty @elems.collectedAugments- loc.allArounds = let f (nt,con,as) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con as)- in foldr f Map.empty @elems.collectedArounds- loc.allMerges = let f (nt,con,as) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con as)- in foldr f Map.empty @elems.collectedMerges-- loc.augmentSigs = let gen _ = [] -- TODO: generate type signatures here for the augments- in Map.map (Map.map gen) @loc.allAugments-- loc.allRulesErrs = Map.mapWithKey (Map.mapWithKey . (checkRules @allAttrDecls @allFields @allInsts @loc.allSigs @loc.allMerges)) @loc.allRules- loc.allNamesErrs = Map.mapWithKey (Map.mapWithKey . checkRuleNames) @loc.allRules- loc.allSigsErrs = Map.mapWithKey (Map.mapWithKey . (checkSigs )) @loc.allSigs- loc.allInstsErrs = Map.mapWithKey (Map.mapWithKey . (checkInsts @loc.allNonterminals @loc.allSigs @allFields )) @loc.allInsts- loc.allUniquesErrs = Map.mapWithKey (Map.mapWithKey . (checkUniques @allAttrDecls )) @loc.allUniques- loc.allAugmentErrs = Map.mapWithKey (Map.mapWithKey . (checkAugments @allAttrDecls )) @loc.allAugments- loc.allAroundsErrs = Map.mapWithKey (Map.mapWithKey . (checkArounds @loc.allFields)) @loc.allArounds- loc.allMergesErrs = Map.mapWithKey (Map.mapWithKey . (checkMerges @loc.allNonterminals @loc.allInsts @loc.allFields)) @loc.allMerges-- loc.checkedRulesPre = Map.map (Map.map fst) @loc.allRulesErrs- loc.checkedSigs = Map.map (Map.map fst) @loc.allSigsErrs `unionunionplusplus` @loc.augmentSigs- loc.checkedInsts = Map.map (Map.map fst) @loc.allInstsErrs- 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.allRules @loc.allFields @loc.checkedInsts @loc.allAttrDecls)) @loc.checkedUniques)- loc.checkedMerges = Map.map (Map.map fst) @loc.allMergesErrs-- loc.errs1 = let f = checkForDuplicates (DupSynonym)- in Seq.fromList . f . map fst $ @elems.typeSyns -- forbid duplicate type synonyms-- loc.errs2 = let g nt (con,fm) = checkForDuplicates (DupChild nt con) (map fst fm)- f (nt,cfm) = concat . map (g nt) . Map.toList $ cfm- in Seq.fromList . concat . map f . Map.toList $ @allFields -- forbid duplicate fields-- loc.errs3 = let -- f (nt,cons) = checkForDuplicates (DupAlt nt) cons- in Seq.empty -- allow duplicate constructors, merging their fields- -- Seq.fromList . concat . map f . Map.toList $ @allConstrs -- forbid duplicate constructors-- loc.errs4 = let f m s = Map.fold ((><) . snd) s m- in Map.fold f Seq.empty @loc.allRulesErrs-- loc.errs5 = let f m s = Map.fold ((><) . snd) s m- in Map.fold f Seq.empty @loc.allSigsErrs-- loc.errs6 = let f m s = Map.fold ((><) . snd) s m- in Map.fold f Seq.empty @loc.allInstsErrs-- loc.errs7 = let f m s = Map.fold ((><) . snd) s m- in Map.fold f Seq.empty @loc.allUniquesErrs-- loc.errs8 = let f m s = Map.fold ((><) . snd) s m- in Map.fold f Seq.empty @loc.allAugmentErrs-- loc.errs9 = let f m s = Map.fold ((><) . snd) s m- in Map.fold f Seq.empty @loc.allAroundsErrs-- loc.errs10 = let f m s = Map.fold ((><)) s m- in Map.fold f Seq.empty @loc.allNamesErrs-- loc.errs11 = let f m s = Map.fold ((><) . snd) s m- in Map.fold f Seq.empty @loc.allMergesErrs-- lhs.errors = @elems.errors >< @errs1 >< @errs2 >< @errs3 >< @errs4 >< @errs5 >< @errs6 >< @errs7 >< @errs8 >< @errs9 >< @errs10 >< @errs11--{-type RulesAndErrors = ([Rule], Seq Error)-type SigsAndErrors = ([TypeSig], Seq Error)-type InstsAndErrors = ([(Identifier, Type)], Seq Error)-type UniquesAndErrors = (Map Identifier Identifier, Seq Error)-type AugmentsAndErrors = (Map Identifier [Expression], Seq Error)-type AroundsAndErrors = (Map Identifier [Expression], Seq Error)-type MergesAndErrors = (Map Identifier (Identifier, [Identifier], Expression), Seq Error)-type AttrOverwrite = Map AttrName Bool-type AccumRuleCheck = (RulesAndErrors, AttrOverwrite)-type AccumDefiCheck = (Seq Error, AttrOverwrite, [AttrName], [AttrName])--checkRules :: Map NontermIdent (Attributes, Attributes) -> DataTypes ->- Map NontermIdent (Map ConstructorIdent [Identifier]) -> Map NontermIdent (Map ConstructorIdent [SigInfo]) ->- Map NontermIdent (Map ConstructorIdent [MergeInfo]) ->- NontermIdent -> ConstructorIdent -> [RuleInfo] -> RulesAndErrors-checkRules attributes fields allinsts allsigs _ nt con rs- = let fieldmap :: FieldMap- 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-- sigs = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allsigs)-- hasAttrib f tp attr = Map.member attr (f (Map.findWithDefault (Map.empty,Map.empty) tp attributes))-- checkRule :: RuleInfo -> AccumRuleCheck -> AccumRuleCheck- checkRule (mbNm, pat,ex,as,owrt,str, pur, eager) ((r1,e1),m1)- = let (e2,m2,u2,_) = foldr (checkDefi owrt) (e1,m1,[],[]) as- in ( (Rule mbNm (pat u2) ex 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 _ _) ->- 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- then case Map.lookupIndex fa m of- Just ix -> let ((_,attr2),b) = Map.elemAt ix m- in if b && not (fa `elem` bs)- then ( e, Map.insert fa owrt m, fa:u, fa:bs)- else (((Seq.<|)) (DupRule nt con field attr2 attr) e, m, fa:u, bs)- Nothing -> ( e, Map.insert fa owrt m, u, fa:bs)- else (((Seq.<|)) (SuperfluousRule nt con field attr) e, m, fa:u, bs)- _ -> (((Seq.<|)) (UndefChild nt con field) e, m, fa:u, bs )-- in fst (foldr checkRule (([],Seq.empty),Map.empty) rs)--checkRuleNames :: NontermIdent -> ConstructorIdent -> [RuleInfo] -> Seq Error-checkRuleNames nt con- = fst . foldr checkRule (Seq.empty, Set.empty)- where- 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--checkSigs :: NontermIdent -> ConstructorIdent -> [SigInfo] -> SigsAndErrors-checkSigs nt con sis- = let checkSig (ide,typ) (sigs,errs)- = if ide `elem` map (\(TypeSig n _)-> n) sigs- then (sigs, ((Seq.<|)) (DupSig nt con ide) errs)- -- else if not (ide `elem` locattrdefs)- -- then (sigs, ((Seq.<|)) (SupSig nt con ide) errs)- else (TypeSig ide typ:sigs, errs)- in foldr checkSig ([],Seq.empty) sis--checkInsts :: Set NontermIdent -> Map NontermIdent (Map ConstructorIdent [SigInfo]) -> DataTypes -> NontermIdent -> ConstructorIdent -> [Identifier] -> InstsAndErrors-checkInsts allNts sigMap _ nt con- = foldr (\inst (insts, errs) ->- maybe (insts, Seq.singleton (MissingInstSig nt con inst) >< errs)- (\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)- 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)- False -> (insts, Seq.singleton (UndefNont nm') >< errs)- | otherwise -> (insts, Seq.singleton (UndefNont nm) >< errs)- )- $ findSig inst- ) ([], Seq.empty)- where- sigs = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt sigMap)-- findSig name- = do tp@(NT _ _ _) <- lookup name sigs- return (name, tp)-- findInst _ [] = Nothing- findInst k ((k', _): r)- | k == k' = Just k'- | otherwise = findInst k r--checkUniques :: Map NontermIdent (Attributes, Attributes) -> NontermIdent -> ConstructorIdent -> [UniqueInfo] -> UniquesAndErrors-checkUniques allAttrs nt con uniques- = let checkUnique (ident,ref) (us,errs)- = if ident `Map.member` us- then (us, ((Seq.<|)) (DupUnique nt con ident) errs)- else if Map.member ref inhs && Map.member ref syns- then (Map.insert ident ref us, errs)- else (us, ((Seq.<|)) (MissingUnique nt ref) errs)-- (inhs,syns) = Map.findWithDefault (Map.empty,Map.empty) nt allAttrs- in foldr checkUnique (Map.empty, Seq.empty) uniques--checkAugments :: Map NontermIdent (Attributes, Attributes) -> NontermIdent -> ConstructorIdent -> [AugmentInfo] -> AugmentsAndErrors-checkAugments allAttrs nt _ augments- = let checkAugment (ident,expr) (as,errs)- = if ident `Map.member` as- then (Map.update (\vs -> Just (vs ++ [expr])) ident as, errs)- else if Map.member ident syns- then (Map.insert ident [expr] as, errs)- else (as, ((Seq.<|)) (MissingSyn nt ident) errs)-- (_,syns) = Map.findWithDefault (Map.empty,Map.empty) nt allAttrs- in foldr checkAugment (Map.empty, Seq.empty) augments--checkArounds :: DataTypes -> NontermIdent -> ConstructorIdent -> [AroundInfo] -> AroundsAndErrors-checkArounds fieldMap nt con arounds- = let checkAround (ident,expr) (as,errs)- = 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)- fields = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt fieldMap)- in foldr checkAround (Map.empty, Seq.empty) arounds--checkMerges :: Set NontermIdent -> Map NontermIdent (Map ConstructorIdent [Identifier]) -> DataTypes -> NontermIdent -> ConstructorIdent -> [MergeInfo] -> MergesAndErrors-checkMerges allNts allInsts fieldMap _ con merges- = let checkMerge (target,nt,sources,expr) (m,errs)- = let fields = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt fieldMap)- insts = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allInsts)- allFields = insts ++ map fst fields -- note: sources of merge may not contain a target (for simplicity)- in if target `Map.member` m -- check for duplicate with self- then (m, DupChild nt con target (fst $ Map.elemAt (Map.findIndex target m) m) Seq.<| errs)- else if target `elem` allFields- then (m, DupChild nt con target (head $ filter (== target) allFields) Seq.<| errs)- else let missing = filter (\s -> not (s `elem` allFields)) sources- in if null missing- then if nt `Set.member` allNts -- check if the nonterm is defined- then (Map.insert target (nt, sources, expr) m, errs) -- all ok..- else (m, UndefNont nt Seq.<| errs)- else (m, (Seq.fromList $ map (UndefChild nt con) missing) Seq.>< errs)- in foldr checkMerge (Map.empty, Seq.empty) merges--unionunionplusplus :: Map NontermIdent (Map ConstructorIdent [a]) -> Map NontermIdent (Map ConstructorIdent [a]) -> Map NontermIdent (Map ConstructorIdent [a])-unionunionplusplus = Map.unionWith (Map.unionWith (++))-}---{-mkUniqueRules :: Options -> Map NontermIdent (Map ConstructorIdent [RuleInfo]) -> DataTypes -> 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- [] -> _LHS- (x:_) -> x- hasSyn tp ref = Map.member ref $ snd $ Map.findWithDefault (Map.empty,Map.empty) tp allAttrDecls- mkRule ref outFld 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]- 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- exists _ = False- 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 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 " )"-}------------------------------------------------------------------------------------- Checking RHSs of rules (optional)----------------------------------------------------------------------------------SEM SemDef | Def MergeDef- lhs.errors = if checkParseRhs @lhs.options- then Seq.fromList $ checkRhs @rhs- else Seq.empty---- type of a type signature--SEM SemDef | TypeDef- lhs.errors = if checkParseTy @lhs.options- then case @tp of- Haskell s -> let ex = Expression @pos tks- tks = [tk]- tk = HsToken s @pos- in Seq.fromList $ checkTy ex- _ -> 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------------------------------------------------------------------------------------SEM Elem- | Set lhs.collectedSetNames = Set.singleton @name--SEM Elem- | Type lhs.collectedNames = Set.singleton @name--SEM NontSet- | NamedSet lhs.collectedNames = Set.singleton @name--SEM AG- | AG loc.allNonterminals = @elems.collectedNames `Set.difference` @elems.collectedSetNames-------SEM ConstructorSet- | CName lhs.collectedConstructorNames = Set.singleton @name----SEM Alt--- | Alt lhs.collectedConstructorNames = Set.singleton @name--SEM Elem- | Data lhs.collectedConstructorsMap = Map.fromList- [ (n, @alts.collectedConstructorNames)- | n <- Set.toList @names.nontSet- ]--SEM AG- | AG elems.allConstructors = @elems.collectedConstructorsMap-------------------------------------------------------------------------------------- Type synonyms----------------------------------------------------------------------------------{- At the moment type synonyms are only supported for list types- This means that only synonyms of the form:- TYPE <NT> = [ <TP> ]- are allowed--}---ATTR Elem Elems [ | | typeSyns USE {++} {[]} : {TypeSyns} ]--{- Put this synonym in the typeSyns list and- add the implicit Cons and Nil productions for the type synonym-- A synonym of the form:- TYPE <NT> = [ <TP> ]- is translated into:- DATA <NT> | Cons hd:<TP> tl:<NT>- | Nil--}--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) False)- ]- )- ,(Ident "Nil" @pos, [])- ]- Maybe tp -> [(Ident "Just" @pos, [(Ident "just" @pos, tp)- ]- )- ,(Ident "Nothing" @pos, [])- ]- Either tp1 tp2 -> [- (Ident "Left" @pos, [(Ident "left" @pos, tp1) ])- , (Ident "Right" @pos, [(Ident "right" @pos, tp2) ])- ]- Map tp1 tp2 -> [ (Ident "Entry" @pos, [ (Ident "key" @pos, tp1)- , (Ident "val" @pos, tp2)- , (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) 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)- Either tp1 tp2 -> Either ( makeType @lhs.allNonterminals tp1) (makeType @lhs.allNonterminals tp2)- List tp -> List ( makeType @lhs.allNonterminals tp)- 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)]------------------------------------------------------------------------------------ Interpreting Nonterminal sets-----------------------------------------------------------------------------------SEM AG- | AG- elems.defSets = Map.fromList (map (\x->(x,(Set.singleton x, Set.empty))) (Set.toList @loc.allNonterminals))- elems.definedSets = Map.map fst @elems.defSets---SEM Elem- | Set loc.(defSets2,errs) = let allUsedNames = Set.unions [ maybe (Set.singleton n)- snd- (Map.lookup n @lhs.defSets)- | n <- Set.toList @set.collectedNames- ]- (nontSet,e1) | Set.member @name allUsedNames- = (Set.empty, Seq.singleton(CyclicSet @name))- | otherwise = (@set.nontSet, Seq.empty)- (res, e2) = let toAdd = (nontSet,Set.insert @name allUsedNames)- un (a,b) (c,d) = (a `Set.union` c, b `Set.union` d)- in if Set.member @name @lhs.allNonterminals || not @merge- then checkDuplicate DupSet @name toAdd @lhs.defSets- else (Map.insertWith un @name toAdd @lhs.defSets, Seq.empty)- in (res, e1 Seq.>< e2)- lhs.defSets = @defSets2- .errors = @errs >< @set.errors--SEM NontSet- | All lhs.nontSet = @lhs.allNonterminals- | NamedSet loc.(nontSet,errors) = case Map.lookup @name @lhs.definedSets of- Nothing -> (Set.empty, Seq.singleton (UndefNont @name))- Just set -> (set, Seq.empty)- | Union lhs.nontSet = Set.union @set1.nontSet @set2.nontSet- | Intersect lhs.nontSet = Set.intersection @set1.nontSet @set2.nontSet- | Difference lhs.nontSet = Set.difference @set1.nontSet @set2.nontSet- | Path lhs.nontSet = let table = flattenDatas @lhs.allFields- in path table @from @to- lhs.errors = let check name | Set.member name @lhs.allNonterminals- = Seq.empty- | otherwise = Seq.singleton (UndefNont name)- in check @from >< check @to---{-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)]--reachableFrom :: Map NontermIdent (Set NontermIdent) -> Set NontermIdent -> Set NontermIdent-reachableFrom table = reach- where reach nts = let nts' = Set.unions (nts : [ ns | nt <- Set.toList nts- , let ns = Map.findWithDefault Set.empty nt table ])- in if Set.size nts' > Set.size nts- then reach nts'- else nts-invert :: Map NontermIdent (Set NontermIdent) -> Map NontermIdent (Set NontermIdent)-invert = foldr inv Map.empty . Map.toList- where inv (x,ns) m = fold (\n m' -> Map.insertWith Set.union n (Set.singleton x) m') m ns--path :: Map NontermIdent (Set NontermIdent) -> NontermIdent -> NontermIdent -> Set NontermIdent-path table from to = let children = Map.findWithDefault Set.empty from table- forward = reachableFrom table children- backward = reachableFrom (invert table)- (Set.singleton to)- in Set.intersection forward backward-}------------------------------------------------------------------------------------ Interpreting Constructor Sets-----------------------------------------------------------------------------------SEM ConstructorSet- | CName lhs.constructors = \_ -> Set.singleton @name- | CUnion lhs.constructors = \ds -> @set1.constructors ds `Set.union` @set2.constructors ds- | CDifference lhs.constructors = \ds -> @set1.constructors ds `Set.difference` @set2.constructors ds- | CAll lhs.constructors = \ds -> ds------------------------------------------------------------------------------------ Collecting wrappers----------------------------------------------------------------------------------ATTR Elem Elems [ | | wrappers USE {`Set.union`} {Set.empty} :{Set NontermIdent}]--SEM Elem- | Wrapper lhs.wrappers = @set.nontSet------------------------------------------------------------------------------------ Collecting nocatas----------------------------------------------------------------------------------SEM Elem- | Nocatas lhs.pragmas = \o -> o { nocatas = @set.nontSet `Set.union` nocatas o }------------------------------------------------------------------------------------ Collecting pragmas----------------------------------------------------------------------------------ATTR AG Elem Elems [ | | pragmas USE {.} {id} :{Options -> Options}]--SEM Elem- | Pragma lhs.pragmas = let mk n o = case getName n of- "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 }- "gentypesigs" -> o { typeSigs = True }- "nogentypesigs"-> o { typeSigs = False }- "nocycle" -> o { withCycle = False, loag = False }- "cycle" -> o { withCycle = True }- "nostrictdata" -> o { strictData = False }- "strictdata" -> o { strictData = True }- "nostrictcase" -> o { strictCases = False }- "strictcase" -> o { strictCases = True }- "strictercase" -> o { strictCases = True, stricterCases = True }- "nostrictwrap" -> o { strictWrap = False }- "strictwrap" -> o { strictWrap = True }- "novisit" -> o { visit = False, loag = False }- "visit" -> o { visit = True }- "nocase" -> o { cases = False }- "case" -> o { cases = True }- "noseq" -> o { withSeq = False }- "seq" -> o { withSeq = True }- "nounbox" -> o { unbox = False }- "unbox" -> o { unbox = True }- "bangpats" -> o { bangpats = True }- "breadthfirst" -> o { breadthFirst = True }- "breadthfirstStrict" -> o { breadthFirstStrict = True }- "nooptimize" -> o { cases = False , visit = False }- "optimize" -> o { cases = True , visit = True }- "strictsem" -> o { strictSems = True }- "gentraces" -> o { genTraces = True }- "genusetraces" -> o { genUseTraces = True }- "splitsems" -> o { splitSems = True }- "gencostcentres" -> o { genCostCentres = True }- "sepsemmods" -> sepSemModsOpt o- "genlinepragmas" -> o { genLinePragmas = True }- "newtypes" -> o { newtypes = True }- "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 }- "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 }- "ocaml" -> ocamlOpt o- "cleanlang" -> cleanOpt o-- s -> trace ("uuagc: ignoring unknown pragma: " ++ s) o- in \o -> foldr mk o @names--{-extract :: String -> [String]-extract s = case dropWhile isSeparator s of- "" -> []- s' -> w : extract s''- where (w, s'') = break isSeparator s'-isSeparator :: Char -> Bool-isSeparator x = x == '_'-}--ATTR Elem Elems SemAlts SemAlt [ | | semPragmasCollect USE {`pragmaMapUnion`} {Map.empty} : {PragmaMap} ]--SEM SemAlt- | SemAlt- loc.pragmaNames = Set.fromList @rules.pragmaNamesCollect- lhs.semPragmasCollect = foldr pragmaMapUnion Map.empty [ pragmaMapSingle nt con @loc.pragmaNames- | (nt, conset, _) <- @loc.coninfo- , con <- Set.toList conset- ]--ATTR SemDefs SemDef [ | | pragmaNamesCollect USE {++} {[]} : {[Identifier]} ]--SEM SemDef- | SemPragma- lhs.pragmaNamesCollect = @names--{-pragmaMapUnion :: PragmaMap -> PragmaMap -> PragmaMap-pragmaMapUnion = Map.unionWith (Map.unionWith Set.union)--pragmaMapSingle :: NontermIdent -> ConstructorIdent -> Set Identifier -> PragmaMap-pragmaMapSingle nt con nms = Map.singleton nt (Map.singleton con nms)-}------------------------------------------------------------------------------------ Collecting attribute orders----------------------------------------------------------------------------------ATTR Elem Elems SemAlts SemAlt [ | | attrOrderCollect USE {`orderMapUnion`} {Map.empty} : {AttrOrderMap} ]-ATTR Elem Elems SemAlts SemAlt [ allAttrDecls : {Map NontermIdent (Attributes, Attributes)} | | ]--SEM SemAlt- | SemAlt- loc.attrOrders- = [ orderMapSingle nt con @rules.orderDepsCollect- | (nt, conset, _) <- @loc.coninfo- , con <- Set.toList conset- ]-- lhs.attrOrderCollect = foldr orderMapUnion Map.empty @loc.attrOrders--ATTR SemDefs SemDef [ | | orderDepsCollect USE {`Set.union`} {Set.empty} : {Set Dependency} ]--SEM SemDef- | AttrOrderBefore- loc.dependency = [ Dependency b a | b <- @before, a <- @after ]- lhs.orderDepsCollect = Set.fromList @loc.dependency--{-orderMapUnion :: AttrOrderMap -> AttrOrderMap -> AttrOrderMap-orderMapUnion = Map.unionWith (Map.unionWith Set.union)--orderMapSingle :: NontermIdent -> ConstructorIdent -> Set Dependency -> AttrOrderMap-orderMapSingle nt con deps = Map.singleton nt (Map.singleton con deps)-}------------------------------------------------------------------------------------ Collecting nonterminal type parameters----------------------------------------------------------------------------------ATTR Elem Elems [ | | paramsCollect USE {`mergeParams`} {Map.empty} : {ParamMap}]--SEM Elem- | Data- lhs.paramsCollect = if null @params- then Map.empty- else Map.fromList [(nt, @params) | nt <- Set.toList @names.nontSet]--SEM Elem- | Type- lhs.paramsCollect = if null @params- then Map.empty- else Map.singleton @name @params--{-mergeParams :: ParamMap -> ParamMap -> ParamMap-mergeParams = Map.unionWith (++)-}------------------------------------------------------------------------------------ Collecting class contexts of semantic functions----------------------------------------------------------------------------------ATTR Elem Elems [ | | ctxCollect USE {`mergeCtx`} {Map.empty} : {ContextMap}]--SEM Elem- | Sem Data Attr- lhs.ctxCollect = if null @ctx- then Map.empty- else Map.fromList [(nt, @ctx) | nt <- Set.toList @names.nontSet]--SEM Elem- | Type- lhs.ctxCollect = if null @ctx- then Map.empty- else Map.singleton @name @ctx--{-mergeCtx :: ContextMap -> ContextMap -> ContextMap-mergeCtx- = Map.unionWith nubconcat- where nubconcat a b = nub (a ++ b)-}------------------------------------------------------------------------------------ Collecting quantifiers of semantic functions----------------------------------------------------------------------------------ATTR Elem Elems [ | | quantCollect USE {`mergeQuant`} {Map.empty} : {QuantMap}]--SEM Elem- | Sem Attr- lhs.quantCollect = if null @quants- then Map.empty- else Map.fromList [(nt, @quants) | nt <- Set.toList @names.nontSet]--{-mergeQuant :: QuantMap -> QuantMap -> QuantMap-mergeQuant = Map.unionWith (++)-}------------------------------------------------------------------------------------ Collecting derivings----------------------------------------------------------------------------------ATTR Elem Elems [ | | derivings USE {`mergeDerivings`} {Map.empty} :{Derivings}]--{-mergeDerivings :: Derivings -> Derivings -> Derivings-mergeDerivings m1 m2 = foldr (\(n,cs) m -> Map.insertWith Set.union n cs m) m2 (Map.toList m1)-}--SEM Elem- | Deriving lhs.derivings = Map.fromList [(nt,Set.fromList @classes) | nt <- Set.toList @set.nontSet]------------------------------------------------------------------------------------ Collecting ATTR declarations----------------------------------------------------------------------------------{-merge ::(Ord k, Ord k1) => Map k (Map k1 a) -> Map k (Map k1 a) -> Map k (Map k1 a)-merge x y = foldr f y (Map.toList x)- where f ~(k,v) m = Map.insertWith (Map.union) k v m-}--SEM AG- | AG elems.attrDecls = Map.empty--SEM Elem- | Data attrs.nts = @names.nontSet- | Attr attrs.nts = @names.nontSet- | Sem attrs.nts = @names.nontSet---SEM Attrs [ nts:{Set NontermIdent} | | ]- | Attrs loc.(attrDecls,errors) = checkAttrs @lhs.allFields (Set.toList @lhs.nts) @inherited @synthesized @lhs.attrDecls-- .(inherited,synthesized,useMap) = let splitAttrs xs = unzip [ ((n,makeType @lhs.allNonterminals t),(n,ud))- | (n,t,ud) <- xs- ]- (inh,_) = splitAttrs @inh- (chn,uses1) = splitAttrs @chn- (syn,uses2) = splitAttrs @syn- isUse (_,(e1,e2,_)) = not (null e1 || null e2)- in (inh++chn,chn++syn, Map.fromList (Prelude.filter isUse (uses1++uses2)))- lhs.useMap = Map.fromList (zip (Set.toList @lhs.nts) (repeat @useMap))-- loc.errors1 = if checkParseTy @lhs.options- then let attrs = @inh ++ @syn ++ @chn- items = map (\(ident,tp,_) -> (getPos ident, tp)) attrs- errs = map check items- check (pos,Haskell s) =- let ex = Expression pos tks- tks = [tk]- tk = HsToken s pos- in Seq.fromList $ checkTy ex- check _ = Seq.empty- in foldr (Seq.><) Seq.empty errs- else Seq.empty- lhs.errors = @loc.errors Seq.>< @loc.errors1---{-checkAttrs :: DataTypes -> [NontermIdent] -> [(Identifier, a)] -> [(Identifier, b)] -> Map NontermIdent (Map Identifier a, Map Identifier b) -> (Map NontermIdent (Map Identifier a, Map Identifier b), Seq Error)-checkAttrs allFields nts inherited synthesized decls' = foldErrors check decls' nts where- check nt decls | not (nt `Map.member` allFields) = (decls,Seq.singleton(UndefNont nt))- | otherwise = let (inh,syn) = Map.findWithDefault (Map.empty,Map.empty) nt decls- (inh',einh) = checkDuplicates (DupInhAttr nt) inherited inh- (syn',esyn) = checkDuplicates (DupSynAttr nt) synthesized syn- in (Map.insert nt (inh',syn') decls,einh >< esyn)-}----- Add declaration of self-attribute for each nonterminal: ATTR <nt> [ | | self:SELF]-{-addSelf :: Ord k1 => k1 -> Map k1 (Map k a, Attributes) -> Map k1 (Map k a, Attributes)-addSelf name atMap = let (eInh,eSyn) = Map.findWithDefault(Map.empty,Map.empty) name atMap- in Map.insert name (eInh, Map.insert (Ident "self" noPos) Self eSyn)atMap-}---SEM AG- | AG loc.allAttrDecls = if withSelf @lhs.options- then foldr addSelf @elems.attrDecls (Set.toList @loc.allNonterminals)- else @elems.attrDecls------------------------------------------------------------------------------------ Collecting rules-----------------------------------------------------------------------------------ATTR SemDef SemDefs [ | | ruleInfos USE {++} {[]} : {[RuleInfo]}- sigInfos USE {++} {[]} : {[SigInfo]}- uniqueInfos USE {++} {[]} : {[UniqueInfo]}- augmentInfos USE {++} {[]} : {[AugmentInfo]}- aroundInfos USE {++} {[]} : {[AroundInfo]}- mergeInfos USE {++} {[]} : {[MergeInfo]}- ]---SEM SemAlt- | SemAlt loc.coninfo = [ (nt, conset, conkeys)- | nt <- Set.toList @lhs.nts- , let conmap = Map.findWithDefault Map.empty nt @lhs.allFields- , let conkeys = Set.fromList (Map.keys conmap)- , let conset = @constructorSet.constructors conkeys- ]-- lhs.errors = Seq.fromList- [ UndefAlt nt con- | (nt, conset, conkeys) <- @loc.coninfo- , con <- Set.toList (Set.difference conset conkeys)- ]- Seq.>< @rules.errors- lhs.collectedRules- = [ (nt,con,r)- | (nt, conset, _) <- @loc.coninfo- , con <- Set.toList conset- , r <- @rules.ruleInfos- ]- lhs.collectedSigs- = [ (nt,con,ts)- | (nt, conset, _) <- @loc.coninfo- , con <- Set.toList conset- , ts <- @rules.sigInfos- ]-- lhs.collectedInsts- = [ (nt,con,@rules.definedInsts)- | (nt, conset, _) <- @loc.coninfo- , con <- Set.toList conset- ]-- lhs.collectedUniques- = [ (nt,con,@rules.uniqueInfos)- | (nt, conset, _) <- @loc.coninfo- , con <- Set.toList conset- ]-- lhs.collectedAugments- = [ (nt, con, @rules.augmentInfos)- | (nt, conset, _) <- @loc.coninfo- , con <- Set.toList conset- ]-- lhs.collectedArounds- = [ (nt, con, @rules.aroundInfos)- | (nt, conset, _) <- @loc.coninfo- , con <- Set.toList conset- ]-- lhs.collectedMerges- = [ (nt, con, @rules.mergeInfos)- | (nt, conset, _) <- @loc.coninfo- , con <- Set.toList conset- ]--SEM SemDef- | Def lhs.ruleInfos = [ (@mbName, @pattern.patunder, @rhs, @pattern.definedAttrs, @owrt, show @pattern.stpos, @pure, @eager) ]--SEM SemDef- | TypeDef lhs.sigInfos = [ (@ident, @tp) ]--SEM SemDef- | UniqueDef lhs.uniqueInfos = [ (@ident, @ref) ]--SEM SemDef- | AugmentDef lhs.augmentInfos = [ (@ident, @rhs) ]--SEM SemDef- | AroundDef lhs.aroundInfos = [ (@ident, @rhs) ]--SEM SemDef- | MergeDef lhs.mergeInfos = [ (@target, @nt, @sources, @rhs) ]---ATTR SemDef SemDefs Pattern Patterns [|| definedInsts USE {++} {[]} : {[Identifier]} ]-ATTR Pattern Patterns [ | | definedAttrs USE {++} {[]} : {[AttrName]} ]-ATTR Pattern [ | | patunder : {[AttrName]->Pattern} ]-ATTR Patterns [ | | patunder : {[AttrName]->Patterns} ]--SEM Pattern- | Alias lhs.definedAttrs = (@field, @attr) : @pat.definedAttrs- lhs.patunder = \us -> if ((@field,@attr) `elem` us) then Underscore noPos else @copy- lhs.definedInsts = (if @field == _INST then [@attr] else []) ++ @pat.definedInsts- | Underscore lhs.patunder = \_ -> @copy- | Constr lhs.patunder = \us -> Constr @name (@pats.patunder us)- | Product lhs.patunder = \us -> Product @pos (@pats.patunder us)- | Irrefutable lhs.patunder = \us -> Irrefutable (@pat.patunder us)--SEM Patterns- | Nil lhs.patunder = \_ -> []- | Cons lhs.patunder = \us -> (@hd.patunder us) : (@tl.patunder us)--ATTR Pattern [ | | stpos : Pos ]--SEM Pattern- | Constr lhs.stpos = getPos @name- | Product lhs.stpos = @pos- | Alias lhs.stpos = getPos @field- | Underscore lhs.stpos = @pos------------------------------------------------------------------------------------ Collect module declaration----------------------------------------------------------------------------------ATTR AG Elems Elem [ | | moduleDecl USE {`flipmplus`} {mzero} : {Maybe (String,String,String)} ]--SEM Elem- | Module- lhs.moduleDecl = Just (@name, @exports, @imports)--{--- We want the last Just in the list-flipmplus = flip mplus-}------------------------------------------------------------------------------------ Constructing transformed syntax tree---------------------------------------------------------------------------------{-makeType :: Set NontermIdent -> Type -> Type-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 [ConstructorIdent]- -> Map NontermIdent (Map ConstructorIdent [Type])- -> Map NontermIdent (Attributes, Attributes)- -> Map NontermIdent (Map Identifier (String, String, String))- -> Derivings- -> Set NontermIdent- -> Map NontermIdent (Map ConstructorIdent [Rule])- -> Map NontermIdent (Map ConstructorIdent [TypeSig])- -> Map NontermIdent (Map ConstructorIdent [(Identifier, Type)])- -> TypeSyns- -> PragmaMap- -> AttrOrderMap- -> ContextMap- -> QuantMap- -> UniqueMap- -> 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 _ ntParams prodParams gram prodOrder constraints attrs uses derivings wrap allrules tsigs allinsts tsyns pragmaMap orderMap contextMap quantMap uniqueMap augmentsMap aroundsMap mergeMap macros =- let gr = [ (nt,alts) | (nt,alts) <- Map.toList gram]- nonts = map nont gr- nont (nt,alts) = let (inh,syn) = Map.findWithDefault (Map.empty,Map.empty) nt attrs- rmap = Map.findWithDefault Map.empty nt allrules- tsmap = Map.findWithDefault Map.empty nt tsigs- 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- prs = Map.findWithDefault [] nt prodOrder- alt con =- let flds = Map.findWithDefault [] con alts- 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)- child (nm, tp) =- let tpI = if existsAsInst nm- then fromJust $ lookup nm insts- else tp- virt = if existsAsInst nm- then case lookup nm flds of- Just tp' -> ChildReplace tp'- Nothing -> ChildAttr- else if existsAsMerge nm- 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 ps cs cldrn rules tsigs' mbMacro- in Nonterminal nt params inh syn (map alt prs)- in Grammar tsyns uses derivings wrap nonts pragmaMap orderMap ntParams contextMap quantMap uniqueMap augmentsMap aroundsMap mergeMap-}--{-mapUnionWithSetUnion :: Map NontermIdent (Set ConstructorIdent) -> Map NontermIdent (Set ConstructorIdent) -> Map NontermIdent (Set ConstructorIdent)-mapUnionWithSetUnion = Map.unionWith Set.union-mapUnionWithPlusPlus :: Map BlockInfo [a] -> Map BlockInfo [a] -> Map BlockInfo [a]-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----------------------------------------------------------------------------------ATTR AG [ | | agi : {(Set NontermIdent, DataTypes, Map NontermIdent (Attributes, Attributes))} ]--ATTR Elem Elems SemAlts SemAlt [ allAttrs : {Map NontermIdent (Attributes, Attributes)} | | ]--SEM AG- | AG lhs.agi = (@loc.allNonterminals,@loc.allFields,@loc.allAttrs)-- loc.allAttrs = if withSelf @lhs.options- then foldr addSelf @elems.attrs (Set.toList @loc.allNonterminals)- else @elems.attrs--ATTR Elems Elem Attrs- [ | attrs : {Map NontermIdent (Attributes, Attributes)} | ]--SEM AG- | AG elems.attrs = Map.empty---SEM Attrs- | Attrs lhs.attrs = let ins decls nt = if Map.member nt decls- then Map.update (\(inh,syn) -> Just ( Map.union inh $ Map.fromList @inherited- , Map.union syn $ Map.fromList @synthesized)) nt decls- else Map.insert nt (Map.fromList @inherited, Map.fromList @synthesized) decls-- in foldl ins @lhs.attrs (Set.toList @lhs.nts)------------------------------------------------------------------------------------- Collecting the data type information----------------------------------------------------------------------------------ATTR AG Elems Elem- [ | | constructorTypeMap USE {`Map.union`} {Map.empty} : {Map NontermIdent ConstructorType} ]- -SEM Elem- | Data lhs.constructorTypeMap = Set.fold (\nm mp -> Map.insert nm @contype mp) Map.empty @names.collectedNames
− src-ag/Visage.ag
@@ -1,122 +0,0 @@-INCLUDE "VisageSyntax.ag"-INCLUDE "VisagePatterns.ag"-INCLUDE "Expression.ag"---imports {-import UU.Scanner.Position(Pos(..))-import CommonTypes-import ATermAbstractSyntax-import Expression-import VisagePatterns-import VisageSyntax-import qualified Data.Map as Map-import Data.Map(Map)-import Data.List(intersperse)-import TokenDef-}--{-convert :: String -> String-convert [] = []-convert (c:ct) | c == '\n' = '\\' : 'n' : convert ct- | otherwise = c : convert ct- -sQ :: String -> String-sQ [] = []-sQ (x:xs) = if (x=='"') then rest else x:rest- where- rest = if not (null xs) && last xs == '"' then init xs else xs--showAGPos :: Pos -> String-showAGPos (Pos l c f) | l == (-1) = ""- | otherwise = let file = if null f then "" else f -- No show of f- lc = "(line " ++ show l ++ ", column " ++ show c ++")"- in file ++ lc--showMap :: (Show a, Show b) => Map a b -> String-showMap- = braces . concat . intersperse "," . map (uncurry assign) . Map.assocs- where- braces s = "{" ++ s ++ "}"- assign a b = show a ++ ":=" ++ show b-}--WRAPPER VisageGrammar--ATTR VisageGrammar VisageNonterminal VisageProduction - VisageChild VisageRule Expression VisagePattern [ || aterm:{ATerm} ]-ATTR VisageNonterminals VisageProductions VisageChildren - VisageRules VisagePatterns [ || aterms:{[ATerm]} ]-ATTR VisageRules -> VisageRule [ isLoc : Bool | | ]--SEM VisageGrammar- | VGrammar lhs.aterm = AAppl "Productions" @nonts.aterms---SEM VisageNonterminals- | Cons lhs.aterms = @hd.aterm : @tl.aterms- | Nil lhs.aterms = []---SEM VisageNonterminal- | VNonterminal lhs.aterm = AAppl "Production" [AString (sQ (getName @nt)), AString (sQ(showMap @inh)), - AString (sQ(showMap @syn)), AAppl "Alternatives" @alts.aterms]---SEM VisageProductions- | Cons lhs.aterms = @hd.aterm : @tl.aterms- | Nil lhs.aterms = []---SEM VisageProduction- | VProduction lhs.aterm = AAppl "Alternative" [AString (sQ (getName @con)), AAppl "Children" @children.aterms, - AAppl "Rules" @rules.aterms, - AAppl "LocRules" @locrules.aterms] - locrules.isLoc = True- rules.isLoc = False- -SEM VisageChildren- | Cons lhs.aterms = @hd.aterm : @tl.aterms- | Nil lhs.aterms = [] ---SEM VisageChild- | VChild lhs.aterm = AAppl "Child" [AString (sQ (getName @name)), AString (sQ (show @tp)), - AString (sQ (showMap @inh)), - AString (sQ (showMap @syn)), - AAppl "Rules" @rules.aterms]- rules.isLoc = False- -SEM VisageRules- | Cons lhs.aterms = @hd.aterm : @tl.aterms- | Nil lhs.aterms = []---SEM VisageRule- | VRule lhs.aterm = AAppl (if @lhs.isLoc then "LocRule" else "Rule") - ([AString (sQ (getName @attr)), @pat.aterm, @rhs.aterm] ++ if @lhs.isLoc then [AString (sQ (show @owrt))] else [])- ---SEM Expression- | Expression lhs.aterm = AAppl "Expression" [AString (sQ (showAGPos @pos)), AString (sQ (unlines . showTokens . tokensToStrings $ @tks))]---SEM VisagePatterns- | Cons lhs.aterms = @hd.aterm : @tl.aterms- | Nil lhs.aterms = []---SEM VisagePattern- | VConstr lhs.aterm = AAppl "Pattern" [AAppl "Constr" [AString (sQ (showAGPos (getPos @name))), - AString (sQ (getName @name)), - AAppl "Patterns" @pats.aterms]]- | VProduct lhs.aterm = AAppl "Pattern" [AAppl "Product" [AString (sQ (showAGPos @pos)), - AAppl "Patterns" @pats.aterms]]- | VVar lhs.aterm = AAppl "Pattern" [AAppl "Var" [AString (sQ (showAGPos (getPos @field))), - AString (sQ (getName @field ++ "." ++ getName @attr))]]- | VAlias lhs.aterm = AAppl "Pattern" [AAppl "Alias" [AString (sQ (showAGPos (getPos @field))), - AString (sQ (getName @field ++ "." ++ getName @attr)), @pat.aterm]]- | VUnderscore lhs.aterm = AAppl "Pattern" [AAppl "Underscore" [AString (sQ (showAGPos @pos))]]-
− src-ag/VisagePatterns.ag
@@ -1,19 +0,0 @@-imports-{-import UU.Scanner.Position(Pos)-import CommonTypes-}--TYPE VisagePatterns = [VisagePattern]--DATA VisagePattern | VConstr name : {ConstructorIdent}- pats : VisagePatterns- | VProduct pos : {Pos}- pats : VisagePatterns- | VVar field : {Identifier} - attr : {Identifier}- | VAlias field : {Identifier}- attr : {Identifier}- pat : VisagePattern- | VUnderscore pos : {Pos}-
− src-ag/VisageSyntax.ag
@@ -1,42 +0,0 @@-imports-{-import CommonTypes-import UU.Pretty-import AbstractSyntax-import VisagePatterns-import Expression-}--DATA VisageGrammar | VGrammar nonts : VisageNonterminals--TYPE VisageNonterminals = [VisageNonterminal]--TYPE VisageProductions = [VisageProduction]--TYPE VisageChildren = [VisageChild]--TYPE VisageRules = [VisageRule]--DATA VisageNonterminal | VNonterminal nt : {NontermIdent}- inh : {Attributes}- syn : {Attributes}- alts : VisageProductions--DATA VisageProduction | VProduction con : {ConstructorIdent}- children : VisageChildren- rules : VisageRules- locrules : VisageRules---DATA VisageChild | VChild name : {Identifier}- tp : {Type}- inh : {Attributes}- syn : {Attributes}- rules : VisageRules--DATA VisageRule | VRule fieldattrs : {[(Identifier,Identifier)]}- attr : {Identifier}- pat : VisagePattern- rhs : Expression- owrt : {Bool}-
src-generated/AbstractSyntax.hs view
@@ -1,6 +1,6 @@ --- UUAGC 0.9.51.1 (src-ag/AbstractSyntax.ag)+-- UUAGC 0.9.51 (src-ag/AbstractSyntax.ag) module AbstractSyntax where {-# LINE 2 "src-ag/AbstractSyntax.ag" #-}
src-generated/Code.hs view
@@ -1,6 +1,6 @@ --- UUAGC 0.9.51.1 (src-ag/Code.ag)+-- UUAGC 0.9.51 (src-ag/Code.ag) module Code where {-# LINE 2 "src-ag/Code.ag" #-}
src-generated/CodeSyntax.hs view
@@ -1,6 +1,6 @@ --- UUAGC 0.9.51.1 (src-ag/CodeSyntax.ag)+-- UUAGC 0.9.51 (src-ag/CodeSyntax.ag) module CodeSyntax where {-# LINE 2 "src-ag/CodeSyntax.ag" #-}
src-generated/ConcreteSyntax.hs view
@@ -1,6 +1,6 @@ --- UUAGC 0.9.51.1 (src-ag/ConcreteSyntax.ag)+-- UUAGC 0.9.51 (src-ag/ConcreteSyntax.ag) module ConcreteSyntax where {-# LINE 2 "src-ag/ConcreteSyntax.ag" #-}
src-generated/DeclBlocks.hs view
@@ -1,6 +1,6 @@ --- UUAGC 0.9.51.1 (src-ag/DeclBlocks.ag)+-- UUAGC 0.9.51 (src-ag/DeclBlocks.ag) module DeclBlocks where {-# LINE 2 "src-ag/DeclBlocks.ag" #-}
src-generated/ErrorMessages.hs view
@@ -1,6 +1,6 @@ --- UUAGC 0.9.51.1 (src-ag/ErrorMessages.ag)+-- UUAGC 0.9.51 (src-ag/ErrorMessages.ag) module ErrorMessages where {-# LINE 2 "src-ag/ErrorMessages.ag" #-}
src-generated/ExecutionPlan.hs view
@@ -1,6 +1,6 @@ --- UUAGC 0.9.51.1 (src-ag/ExecutionPlan.ag)+-- UUAGC 0.9.51 (src-ag/ExecutionPlan.ag) module ExecutionPlan where {-# LINE 2 "src-ag/ExecutionPlan.ag" #-}
src-generated/Expression.hs view
@@ -1,6 +1,6 @@ --- UUAGC 0.9.51.1 (src-ag/Expression.ag)+-- UUAGC 0.9.51 (src-ag/Expression.ag) module Expression where {-# LINE 2 "src-ag/Expression.ag" #-}
src-generated/HsToken.hs view
@@ -1,6 +1,6 @@ --- UUAGC 0.9.51.1 (src-ag/HsToken.ag)+-- UUAGC 0.9.51 (src-ag/HsToken.ag) module HsToken where {-# LINE 2 "src-ag/HsToken.ag" #-}
src-generated/Interfaces.hs view
@@ -1,6 +1,6 @@ --- UUAGC 0.9.51.1 (src-ag/Interfaces.ag)+-- UUAGC 0.9.51 (src-ag/Interfaces.ag) module Interfaces where {-# LINE 2 "src-ag/Interfaces.ag" #-}
src-generated/LOAG/Order.hs view
@@ -106,35 +106,22 @@ {-# LINE 292 "src-ag/LOAG/Prepare.ag" #-} --- | Replace the references to local attributes, by his attrs dependencies,--- | rendering the local attributes 'transparent'.+-- | Replace the references to local attributes, by his attrs dependencies repLocRefs :: SF_P -> SF_P -> SF_P repLocRefs lfp sfp =- Map.map (setConcatMap $ rep Set.empty) sfp- where rep :: Set.Set MyOccurrence -> MyOccurrence -> Set.Set MyOccurrence - rep done occ | occ `Set.member` done = Set.empty- | isLoc occ = setConcatMap (rep $ Set.insert occ done) $ - findWithErr lfp "repping locals" occ- | otherwise = Set.singleton occ---- | Add dependencies from a higher order child to all its attributes-addHigherOrders :: SF_P -> SF_P -> SF_P-addHigherOrders lfp sfp = - Map.mapWithKey f $ Map.map (setConcatMap (\mo -> f mo (Set.singleton mo))) sfp- where f :: MyOccurrence -> Set.Set MyOccurrence -> Set.Set MyOccurrence- f mo@(MyOccurrence (p,f) _) deps =- let ho = ((p,"inst") >.< (f,AnyDir))- in if ho `Map.member` lfp- then ho `Set.insert` deps- else deps-{-# LINE 131 "dist/build/LOAG/Order.hs" #-}+ Map.map (setConcatMap rep) sfp+ where rep :: MyOccurrence -> Set.Set MyOccurrence + rep occ | isLoc occ = setConcatMap rep $ + findWithErr lfp "repping locals" occ+ | otherwise = Set.singleton occ+{-# LINE 118 "dist/build/LOAG/Order.hs" #-} {-# LINE 42 "src-ag/LOAG/Order.ag" #-} fst' (a,_,_) = a snd' (_,b,_) = b trd' (_,_,c) = c-{-# LINE 138 "dist/build/LOAG/Order.hs" #-}+{-# LINE 125 "dist/build/LOAG/Order.hs" #-} {-# LINE 95 "src-ag/LOAG/Order.ag" #-} @@ -164,7 +151,7 @@ ppOcc pmp v = text f >|< text "." >|< fst a where (MyOccurrence ((t,p),f) a) = findWithErr pmp "ppOcc" v -{-# LINE 168 "dist/build/LOAG/Order.hs" #-}+{-# LINE 155 "dist/build/LOAG/Order.hs" #-} {-# LINE 239 "src-ag/LOAG/Order.ag" #-} @@ -226,10 +213,10 @@ writeSTRef introed (Set.insert child intros) let occ = (ps,"inst") >.< (child, AnyDir) preds = Set.toList $ setConcatMap rep $ - lfp Map.! occ+ findWithErr lfp "woot4" occ rep :: MyOccurrence -> Set.Set MyOccurrence rep occ | isLoc occ = Set.insert occ $ - setConcatMap rep $ lfp Map.! occ+ setConcatMap rep $ findWithErr lfp "woot3" occ | otherwise = Set.singleton occ rest <- forM preds (visit ref introed ruleref vnrsref)@@ -242,9 +229,9 @@ where cvisit= ChildVisit (identifier child) ntid visnr child = snd $ argsOf o ntid = ((\(NT name _ _ )-> name) . fromMyTy) nt - visnr = (\x-> visMap IMap.! x) (nmpr Map.! (nt <.> attr o))- nt = fty Map.! (ps,child)-{-# LINE 248 "dist/build/LOAG/Order.hs" #-}+ visnr = (\x-> findWithErr' visMap (show (inOutput,o,x)) x) (findWithErr nmpr "woot3" (nt <.> attr o))+ nt = findWithErr fty "woot" (ps,child)+{-# LINE 235 "dist/build/LOAG/Order.hs" #-} {-# LINE 356 "src-ag/LOAG/Order.ag" #-} @@ -326,7 +313,7 @@ syns = map (((genA A.!) &&& id).(pmpr Map.!))$ Set.toList ss -{-# LINE 330 "dist/build/LOAG/Order.hs" #-}+{-# LINE 317 "dist/build/LOAG/Order.hs" #-} -- CGrammar ---------------------------------------------------- -- wrapper data Inh_CGrammar = Inh_CGrammar { }@@ -1106,13 +1093,13 @@ case tp_ of NT nt _ _ -> Set.singleton nt _ -> mempty- {-# LINE 1110 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1097 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule33 #-} {-# LINE 34 "src-ag/ExecutionPlanCommon.ag" #-} rule33 = \ _isHigherOrder _refNts -> {-# LINE 34 "src-ag/ExecutionPlanCommon.ag" #-} if _isHigherOrder then _refNts else mempty- {-# LINE 1116 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1103 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule34 #-} {-# LINE 35 "src-ag/ExecutionPlanCommon.ag" #-} rule34 = \ kind_ ->@@ -1120,7 +1107,7 @@ case kind_ of ChildSyntax -> False _ -> True- {-# LINE 1124 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1111 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule35 #-} {-# LINE 95 "src-ag/ExecutionPlanCommon.ag" #-} rule35 = \ ((_lhsIaroundMap) :: Map Identifier [Expression]) name_ ->@@ -1128,19 +1115,19 @@ case Map.lookup name_ _lhsIaroundMap of Nothing -> False Just as -> not (null as)- {-# LINE 1132 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1119 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule36 #-} {-# LINE 123 "src-ag/ExecutionPlanCommon.ag" #-} rule36 = \ ((_lhsImergeMap) :: Map Identifier (Identifier, [Identifier], Expression)) name_ -> {-# LINE 123 "src-ag/ExecutionPlanCommon.ag" #-} maybe Nothing (\(_,ms,_) -> Just ms) $ Map.lookup name_ _lhsImergeMap- {-# LINE 1138 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1125 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule37 #-} {-# LINE 124 "src-ag/ExecutionPlanCommon.ag" #-} rule37 = \ ((_lhsImergedChildren) :: Set Identifier) name_ -> {-# LINE 124 "src-ag/ExecutionPlanCommon.ag" #-} name_ `Set.member` _lhsImergedChildren- {-# LINE 1144 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1131 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule38 #-} {-# LINE 135 "src-ag/ExecutionPlanCommon.ag" #-} rule38 = \ _hasArounds _isMerged _merges kind_ name_ tp_ ->@@ -1148,56 +1135,56 @@ case tp_ of NT _ _ _ -> EChild name_ tp_ kind_ _hasArounds _merges _isMerged _ -> ETerm name_ tp_- {-# LINE 1152 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1139 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule39 #-} {-# LINE 174 "src-ag/LOAG/Prepare.ag" #-} rule39 = \ ((_lhsIflab) :: Int) -> {-# LINE 174 "src-ag/LOAG/Prepare.ag" #-} _lhsIflab + 1- {-# LINE 1158 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1145 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule40 #-} {-# LINE 175 "src-ag/LOAG/Prepare.ag" #-} rule40 = \ tp_ -> {-# LINE 175 "src-ag/LOAG/Prepare.ag" #-} toMyTy tp_- {-# LINE 1164 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1151 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule41 #-} {-# LINE 177 "src-ag/LOAG/Prepare.ag" #-} rule41 = \ _atp ((_lhsIan) :: MyType -> MyAttributes) ((_lhsIpll) :: PLabel) name_ -> {-# LINE 177 "src-ag/LOAG/Prepare.ag" #-} map ((FieldAtt _atp _lhsIpll (getName name_)) . alab) $ _lhsIan _atp- {-# LINE 1171 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1158 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule42 #-} {-# LINE 179 "src-ag/LOAG/Prepare.ag" #-} rule42 = \ _flab -> {-# LINE 179 "src-ag/LOAG/Prepare.ag" #-} _flab- {-# LINE 1177 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1164 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule43 #-} {-# LINE 180 "src-ag/LOAG/Prepare.ag" #-} rule43 = \ name_ -> {-# LINE 180 "src-ag/LOAG/Prepare.ag" #-} getName name_- {-# LINE 1183 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1170 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule44 #-} {-# LINE 181 "src-ag/LOAG/Prepare.ag" #-} rule44 = \ _ident ((_lhsIpll) :: PLabel) -> {-# LINE 181 "src-ag/LOAG/Prepare.ag" #-} (_lhsIpll, _ident )- {-# LINE 1189 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1176 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule45 #-} {-# LINE 182 "src-ag/LOAG/Prepare.ag" #-} rule45 = \ _atp _label ((_lhsIain) :: MyType -> MyAttributes) -> {-# LINE 182 "src-ag/LOAG/Prepare.ag" #-} Set.fromList $ handAllOut _label $ _lhsIain _atp- {-# LINE 1195 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1182 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule46 #-} {-# LINE 183 "src-ag/LOAG/Prepare.ag" #-} rule46 = \ _atp _label ((_lhsIasn) :: MyType -> MyAttributes) -> {-# LINE 183 "src-ag/LOAG/Prepare.ag" #-} Set.fromList $ handAllOut _label $ _lhsIasn _atp- {-# LINE 1201 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1188 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule47 #-} {-# LINE 184 "src-ag/LOAG/Prepare.ag" #-} rule47 = \ _foccsI _foccsS _label ->@@ -1205,7 +1192,7 @@ if Set.null _foccsI && Set.null _foccsS then Map.empty else Map.singleton _label (_foccsS ,_foccsI )- {-# LINE 1209 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1196 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule48 #-} {-# LINE 187 "src-ag/LOAG/Prepare.ag" #-} rule48 = \ _ident ((_lhsIpll) :: PLabel) kind_ ->@@ -1213,19 +1200,19 @@ case kind_ of ChildAttr -> Map.singleton _lhsIpll (Set.singleton _ident ) _ -> Map.empty- {-# LINE 1217 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1204 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule49 #-} {-# LINE 190 "src-ag/LOAG/Prepare.ag" #-} rule49 = \ _atp ((_lhsIpll) :: PLabel) name_ -> {-# LINE 190 "src-ag/LOAG/Prepare.ag" #-} Map.singleton (_lhsIpll, getName name_) _atp- {-# LINE 1223 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1210 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule50 #-} {-# LINE 223 "src-ag/LOAG/Prepare.ag" #-} rule50 = \ name_ -> {-# LINE 223 "src-ag/LOAG/Prepare.ag" #-} Set.singleton $ getName name_- {-# LINE 1229 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1216 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule51 #-} rule51 = \ ((_fattsIap) :: A_P) -> _fattsIap@@ -1607,56 +1594,56 @@ rule120 = \ ((_lhsIflab) :: Int) -> {-# LINE 161 "src-ag/LOAG/Prepare.ag" #-} _lhsIflab + 1- {-# LINE 1611 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1598 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule121 #-} {-# LINE 162 "src-ag/LOAG/Prepare.ag" #-} rule121 = \ ((_lhsIpll) :: PLabel) -> {-# LINE 162 "src-ag/LOAG/Prepare.ag" #-} fst _lhsIpll- {-# LINE 1617 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1604 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule122 #-} {-# LINE 164 "src-ag/LOAG/Prepare.ag" #-} rule122 = \ _atp ((_lhsIan) :: MyType -> MyAttributes) ((_lhsIpll) :: PLabel) -> {-# LINE 164 "src-ag/LOAG/Prepare.ag" #-} map ((FieldAtt _atp _lhsIpll "lhs") . alab) $ _lhsIan _atp- {-# LINE 1624 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1611 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule123 #-} {-# LINE 166 "src-ag/LOAG/Prepare.ag" #-} rule123 = \ _flab -> {-# LINE 166 "src-ag/LOAG/Prepare.ag" #-} _flab- {-# LINE 1630 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1617 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule124 #-} {-# LINE 167 "src-ag/LOAG/Prepare.ag" #-} rule124 = \ ((_lhsIpll) :: PLabel) -> {-# LINE 167 "src-ag/LOAG/Prepare.ag" #-} (_lhsIpll, "lhs")- {-# LINE 1636 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1623 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule125 #-} {-# LINE 168 "src-ag/LOAG/Prepare.ag" #-} rule125 = \ _atp _label ((_lhsIain) :: MyType -> MyAttributes) -> {-# LINE 168 "src-ag/LOAG/Prepare.ag" #-} Set.fromList $ handAllOut _label $ _lhsIain _atp- {-# LINE 1642 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1629 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule126 #-} {-# LINE 169 "src-ag/LOAG/Prepare.ag" #-} rule126 = \ _atp _label ((_lhsIasn) :: MyType -> MyAttributes) -> {-# LINE 169 "src-ag/LOAG/Prepare.ag" #-} Set.fromList $ handAllOut _label $ _lhsIasn _atp- {-# LINE 1648 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1635 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule127 #-} {-# LINE 170 "src-ag/LOAG/Prepare.ag" #-} rule127 = \ _foccsI _foccsS _label -> {-# LINE 170 "src-ag/LOAG/Prepare.ag" #-} Map.singleton _label (_foccsI , _foccsS )- {-# LINE 1654 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1641 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule128 #-} {-# LINE 171 "src-ag/LOAG/Prepare.ag" #-} rule128 = \ _label ((_lhsIdty) :: MyType) -> {-# LINE 171 "src-ag/LOAG/Prepare.ag" #-} Map.singleton _label _lhsIdty- {-# LINE 1660 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1647 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule129 #-} rule129 = \ ((_fattsIap) :: A_P) -> _fattsIap@@ -1773,25 +1760,25 @@ rule148 = \ tks_ -> {-# LINE 273 "src-ag/LOAG/Prepare.ag" #-} HsTokensRoot tks_- {-# LINE 1777 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1764 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule149 #-} {-# LINE 274 "src-ag/LOAG/Prepare.ag" #-} rule149 = \ ((_lhsIpll) :: PLabel) -> {-# LINE 274 "src-ag/LOAG/Prepare.ag" #-} _lhsIpll- {-# LINE 1783 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1770 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule150 #-} {-# LINE 275 "src-ag/LOAG/Prepare.ag" #-} rule150 = \ ((_lhsIpts) :: Set.Set (FLabel)) -> {-# LINE 275 "src-ag/LOAG/Prepare.ag" #-} _lhsIpts- {-# LINE 1789 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1776 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule151 #-} {-# LINE 276 "src-ag/LOAG/Prepare.ag" #-} rule151 = \ ((_tokensIused) :: Set.Set MyOccurrence) -> {-# LINE 276 "src-ag/LOAG/Prepare.ag" #-} _tokensIused- {-# LINE 1795 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1782 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule152 #-} rule152 = \ pos_ tks_ -> Expression pos_ tks_@@ -1879,61 +1866,61 @@ rule156 = \ ((_lhsIolab) :: Int) -> {-# LINE 193 "src-ag/LOAG/Prepare.ag" #-} _lhsIolab + 1- {-# LINE 1883 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1870 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule157 #-} {-# LINE 194 "src-ag/LOAG/Prepare.ag" #-} rule157 = \ _att ((_lhsInmprf) :: NMP_R) -> {-# LINE 194 "src-ag/LOAG/Prepare.ag" #-} findWithErr _lhsInmprf "getting attr label" _att- {-# LINE 1889 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1876 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule158 #-} {-# LINE 195 "src-ag/LOAG/Prepare.ag" #-} rule158 = \ a_ t_ -> {-# LINE 195 "src-ag/LOAG/Prepare.ag" #-} t_ <.> a_- {-# LINE 1895 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1882 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule159 #-} {-# LINE 196 "src-ag/LOAG/Prepare.ag" #-} rule159 = \ a_ f_ p_ -> {-# LINE 196 "src-ag/LOAG/Prepare.ag" #-} (p_, f_) >.< a_- {-# LINE 1901 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1888 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule160 #-} {-# LINE 197 "src-ag/LOAG/Prepare.ag" #-} rule160 = \ _occ _olab -> {-# LINE 197 "src-ag/LOAG/Prepare.ag" #-} Map.singleton _olab _occ- {-# LINE 1907 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1894 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule161 #-} {-# LINE 198 "src-ag/LOAG/Prepare.ag" #-} rule161 = \ _occ _olab -> {-# LINE 198 "src-ag/LOAG/Prepare.ag" #-} Map.singleton _occ _olab- {-# LINE 1913 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1900 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule162 #-} {-# LINE 199 "src-ag/LOAG/Prepare.ag" #-} rule162 = \ _alab _olab -> {-# LINE 199 "src-ag/LOAG/Prepare.ag" #-} Map.singleton _alab [_olab ]- {-# LINE 1919 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1906 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule163 #-} {-# LINE 200 "src-ag/LOAG/Prepare.ag" #-} rule163 = \ _alab _olab -> {-# LINE 200 "src-ag/LOAG/Prepare.ag" #-} Map.singleton _olab _alab- {-# LINE 1925 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1912 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule164 #-} {-# LINE 201 "src-ag/LOAG/Prepare.ag" #-} rule164 = \ _occ p_ -> {-# LINE 201 "src-ag/LOAG/Prepare.ag" #-} Map.singleton p_ [_occ ]- {-# LINE 1931 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1918 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule165 #-} {-# LINE 202 "src-ag/LOAG/Prepare.ag" #-} rule165 = \ ((_lhsIflab) :: Int) _olab -> {-# LINE 202 "src-ag/LOAG/Prepare.ag" #-} [(_olab , _lhsIflab)]- {-# LINE 1937 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1924 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule166 #-} rule166 = \ (_ :: ()) -> Map.empty@@ -2265,49 +2252,49 @@ rule205 = \ ((_nontsIntDeps) :: Map NontermIdent (Set NontermIdent)) -> {-# LINE 40 "src-ag/ExecutionPlanCommon.ag" #-} closeMap _nontsIntDeps- {-# LINE 2269 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2256 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule206 #-} {-# LINE 41 "src-ag/ExecutionPlanCommon.ag" #-} rule206 = \ ((_nontsIntHoDeps) :: Map NontermIdent (Set NontermIdent)) -> {-# LINE 41 "src-ag/ExecutionPlanCommon.ag" #-} closeMap _nontsIntHoDeps- {-# LINE 2275 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2262 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule207 #-} {-# LINE 42 "src-ag/ExecutionPlanCommon.ag" #-} rule207 = \ _closedHoNtDeps -> {-# LINE 42 "src-ag/ExecutionPlanCommon.ag" #-} revDeps _closedHoNtDeps- {-# LINE 2281 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2268 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule208 #-} {-# LINE 51 "src-ag/ExecutionPlanCommon.ag" #-} rule208 = \ contextMap_ -> {-# LINE 51 "src-ag/ExecutionPlanCommon.ag" #-} contextMap_- {-# LINE 2287 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2274 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule209 #-} {-# LINE 92 "src-ag/ExecutionPlanCommon.ag" #-} rule209 = \ aroundsMap_ -> {-# LINE 92 "src-ag/ExecutionPlanCommon.ag" #-} aroundsMap_- {-# LINE 2293 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2280 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule210 #-} {-# LINE 117 "src-ag/ExecutionPlanCommon.ag" #-} rule210 = \ mergeMap_ -> {-# LINE 117 "src-ag/ExecutionPlanCommon.ag" #-} mergeMap_- {-# LINE 2299 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2286 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule211 #-} {-# LINE 9 "src-ag/ExecutionPlanPre.ag" #-} rule211 = \ (_ :: ()) -> {-# LINE 9 "src-ag/ExecutionPlanPre.ag" #-} 0- {-# LINE 2305 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2292 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule212 #-} {-# LINE 38 "src-ag/LOAG/Prepare.ag" #-} rule212 = \ ((_nontsIpmp) :: PMP) -> {-# LINE 38 "src-ag/LOAG/Prepare.ag" #-} if Map.null _nontsIpmp then 1 else fst $ Map.findMin _nontsIpmp- {-# LINE 2311 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2298 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule213 #-} {-# LINE 40 "src-ag/LOAG/Prepare.ag" #-} rule213 = \ _ain _an _asn _initO _nmp _nmpr ((_nontsIap) :: A_P) ((_nontsIfieldMap) :: FMap) ((_nontsIfsInP) :: FsInP) ((_nontsIfty) :: FTY) ((_nontsIgen) :: Map Int Int) ((_nontsIinss) :: Map Int [Int]) ((_nontsIofld) :: [(Int, Int)]) ((_nontsIpmp) :: PMP) ((_nontsIpmpr) :: PMP_R) ((_nontsIps) :: [PLabel]) _sfp ->@@ -2321,145 +2308,145 @@ Map.toList $ _nontsIinss) (A.array (_initO , _initO + length _nontsIofld) $ _nontsIofld) _nontsIfty _nontsIfieldMap _nontsIfsInP- {-# LINE 2325 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2312 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule214 #-} {-# LINE 49 "src-ag/LOAG/Prepare.ag" #-} rule214 = \ _atts -> {-# LINE 49 "src-ag/LOAG/Prepare.ag" #-} Map.fromList $ zip [1..] _atts- {-# LINE 2331 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2318 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule215 #-} {-# LINE 50 "src-ag/LOAG/Prepare.ag" #-} rule215 = \ _atts -> {-# LINE 50 "src-ag/LOAG/Prepare.ag" #-} Map.fromList $ zip _atts [1..]- {-# LINE 2337 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2324 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule216 #-} {-# LINE 51 "src-ag/LOAG/Prepare.ag" #-} rule216 = \ _ain _asn -> {-# LINE 51 "src-ag/LOAG/Prepare.ag" #-} Map.unionWith (++) _ain _asn- {-# LINE 2343 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2330 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule217 #-} {-# LINE 52 "src-ag/LOAG/Prepare.ag" #-} rule217 = \ ((_nontsIinhs) :: AI_N) -> {-# LINE 52 "src-ag/LOAG/Prepare.ag" #-} _nontsIinhs- {-# LINE 2349 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2336 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule218 #-} {-# LINE 53 "src-ag/LOAG/Prepare.ag" #-} rule218 = \ ((_nontsIsyns) :: AS_N) -> {-# LINE 53 "src-ag/LOAG/Prepare.ag" #-} _nontsIsyns- {-# LINE 2355 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2342 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule219 #-} {-# LINE 54 "src-ag/LOAG/Prepare.ag" #-} rule219 = \ _an -> {-# LINE 54 "src-ag/LOAG/Prepare.ag" #-} concat $ Map.elems _an- {-# LINE 2361 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2348 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule220 #-} {-# LINE 55 "src-ag/LOAG/Prepare.ag" #-} rule220 = \ ((_nontsIap) :: A_P) -> {-# LINE 55 "src-ag/LOAG/Prepare.ag" #-} concat $ Map.elems _nontsIap- {-# LINE 2367 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2354 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule221 #-} {-# LINE 56 "src-ag/LOAG/Prepare.ag" #-} rule221 = \ manualAttrOrderMap_ -> {-# LINE 56 "src-ag/LOAG/Prepare.ag" #-} manualAttrOrderMap_- {-# LINE 2373 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2360 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule222 #-} {-# LINE 87 "src-ag/LOAG/Prepare.ag" #-} rule222 = \ _ain -> {-# LINE 87 "src-ag/LOAG/Prepare.ag" #-} map2F _ain- {-# LINE 2379 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2366 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule223 #-} {-# LINE 88 "src-ag/LOAG/Prepare.ag" #-} rule223 = \ _asn -> {-# LINE 88 "src-ag/LOAG/Prepare.ag" #-} map2F _asn- {-# LINE 2385 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2372 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule224 #-} {-# LINE 89 "src-ag/LOAG/Prepare.ag" #-} rule224 = \ ((_nontsIpmp) :: PMP) -> {-# LINE 89 "src-ag/LOAG/Prepare.ag" #-} _nontsIpmp- {-# LINE 2391 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2378 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule225 #-} {-# LINE 90 "src-ag/LOAG/Prepare.ag" #-} rule225 = \ ((_nontsIpmpr) :: PMP_R) -> {-# LINE 90 "src-ag/LOAG/Prepare.ag" #-} _nontsIpmpr- {-# LINE 2397 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2384 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule226 #-} {-# LINE 91 "src-ag/LOAG/Prepare.ag" #-} rule226 = \ ((_nontsIlfp) :: SF_P) -> {-# LINE 91 "src-ag/LOAG/Prepare.ag" #-} _nontsIlfp- {-# LINE 2403 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2390 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule227 #-} {-# LINE 92 "src-ag/LOAG/Prepare.ag" #-} rule227 = \ ((_nontsIhoMap) :: HOMap) -> {-# LINE 92 "src-ag/LOAG/Prepare.ag" #-} _nontsIhoMap- {-# LINE 2409 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2396 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule228 #-} {-# LINE 93 "src-ag/LOAG/Prepare.ag" #-} rule228 = \ ((_nontsIfty) :: FTY) -> {-# LINE 93 "src-ag/LOAG/Prepare.ag" #-} _nontsIfty- {-# LINE 2415 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2402 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule229 #-} {-# LINE 94 "src-ag/LOAG/Prepare.ag" #-} rule229 = \ ((_nontsIfty) :: FTY) -> {-# LINE 94 "src-ag/LOAG/Prepare.ag" #-} _nontsIfty- {-# LINE 2421 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2408 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule230 #-} {-# LINE 103 "src-ag/LOAG/Prepare.ag" #-} rule230 = \ ((_nontsIps) :: [PLabel]) -> {-# LINE 103 "src-ag/LOAG/Prepare.ag" #-} _nontsIps- {-# LINE 2427 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2414 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule231 #-} {-# LINE 150 "src-ag/LOAG/Prepare.ag" #-} rule231 = \ _an -> {-# LINE 150 "src-ag/LOAG/Prepare.ag" #-} map2F _an- {-# LINE 2433 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2420 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule232 #-} {-# LINE 151 "src-ag/LOAG/Prepare.ag" #-} rule232 = \ _nmpr -> {-# LINE 151 "src-ag/LOAG/Prepare.ag" #-} _nmpr- {-# LINE 2439 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2426 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule233 #-} {-# LINE 152 "src-ag/LOAG/Prepare.ag" #-} rule233 = \ _nmp -> {-# LINE 152 "src-ag/LOAG/Prepare.ag" #-} if Map.null _nmp then 0 else (fst $ Map.findMax _nmp )- {-# LINE 2445 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2432 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule234 #-} {-# LINE 153 "src-ag/LOAG/Prepare.ag" #-} rule234 = \ (_ :: ()) -> {-# LINE 153 "src-ag/LOAG/Prepare.ag" #-} 0- {-# LINE 2451 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2438 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule235 #-} {-# LINE 207 "src-ag/LOAG/Prepare.ag" #-} rule235 = \ ((_nontsIlfp) :: SF_P) ((_nontsIsfp) :: SF_P) -> {-# LINE 207 "src-ag/LOAG/Prepare.ag" #-}- repLocRefs _nontsIlfp $ addHigherOrders _nontsIlfp _nontsIsfp- {-# LINE 2457 "dist/build/LOAG/Order.hs"#-}+ repLocRefs _nontsIlfp _nontsIsfp+ {-# LINE 2444 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule236 #-} {-# LINE 54 "src-ag/LOAG/Order.ag" #-} rule236 = \ _schedRes -> {-# LINE 54 "src-ag/LOAG/Order.ag" #-} either Seq.singleton (const Seq.empty) _schedRes- {-# LINE 2463 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2450 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule237 #-} {-# LINE 55 "src-ag/LOAG/Order.ag" #-} rule237 = \ ((_lhsIoptions) :: Options) ((_nontsIpmp) :: PMP) _schedRes ->@@ -2467,25 +2454,25 @@ case either (const []) trd' _schedRes of [] -> Nothing ads -> Just $ ppAds _lhsIoptions _nontsIpmp ads- {-# LINE 2471 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2458 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule238 #-} {-# LINE 58 "src-ag/LOAG/Order.ag" #-} rule238 = \ ((_nontsIenonts) :: ENonterminals) derivings_ typeSyns_ wrappers_ -> {-# LINE 58 "src-ag/LOAG/Order.ag" #-} ExecutionPlan _nontsIenonts typeSyns_ wrappers_ derivings_- {-# LINE 2477 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2464 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule239 #-} {-# LINE 60 "src-ag/LOAG/Order.ag" #-} rule239 = \ _schedRes -> {-# LINE 60 "src-ag/LOAG/Order.ag" #-} either (const Map.empty) snd' _schedRes- {-# LINE 2483 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2470 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule240 #-} {-# LINE 61 "src-ag/LOAG/Order.ag" #-} rule240 = \ _schedRes -> {-# LINE 61 "src-ag/LOAG/Order.ag" #-} either (error "no tdp") (fromJust.fst') _schedRes- {-# LINE 2489 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2476 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule241 #-} {-# LINE 63 "src-ag/LOAG/Order.ag" #-} rule241 = \ _ag ((_lhsIoptions) :: Options) _loagRes ((_nontsIads) :: [Edge]) _self ((_smfIself) :: LOAGRep) ->@@ -2495,38 +2482,38 @@ then AOAG.schedule _smfIself _self _ag _nontsIads else _loagRes else Right (Nothing,Map.empty,[])- {-# LINE 2499 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2486 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule242 #-} {-# LINE 68 "src-ag/LOAG/Order.ag" #-} rule242 = \ _ag ((_lhsIoptions) :: Options) -> {-# LINE 68 "src-ag/LOAG/Order.ag" #-} let putStrLn s = when (verbose _lhsIoptions) (IO.putStrLn s) in Right $ unsafePerformIO $ scheduleLOAG _ag putStrLn _lhsIoptions- {-# LINE 2506 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2493 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule243 #-} {-# LINE 70 "src-ag/LOAG/Order.ag" #-} rule243 = \ _self ((_smfIself) :: LOAGRep) -> {-# LINE 70 "src-ag/LOAG/Order.ag" #-} repToAg _smfIself _self- {-# LINE 2512 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2499 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule244 #-} {-# LINE 72 "src-ag/LOAG/Order.ag" #-} rule244 = \ _schedRes -> {-# LINE 72 "src-ag/LOAG/Order.ag" #-} either (const []) trd' _schedRes- {-# LINE 2518 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2505 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule245 #-} {-# LINE 133 "src-ag/LOAG/Order.ag" #-} rule245 = \ ((_nontsIvisMap) :: IMap.IntMap Int) -> {-# LINE 133 "src-ag/LOAG/Order.ag" #-} _nontsIvisMap- {-# LINE 2524 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2511 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule246 #-} {-# LINE 134 "src-ag/LOAG/Order.ag" #-} rule246 = \ (_ :: ()) -> {-# LINE 134 "src-ag/LOAG/Order.ag" #-} 0- {-# LINE 2530 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2517 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule247 #-} rule247 = \ ((_nontsIinhmap) :: Map.Map NontermIdent Attributes) -> _nontsIinhmap@@ -2616,7 +2603,7 @@ True -> Set.empty False -> Set.singleton $ (_lhsIpll, getName _LOC) >.< (getName var_, drhs _LOC)- {-# LINE 2620 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2607 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule258 #-} rule258 = \ pos_ rdesc_ var_ -> AGLocal var_ pos_ rdesc_@@ -2644,7 +2631,7 @@ {-# LINE 289 "src-ag/LOAG/Prepare.ag" #-} Set.singleton $ (_lhsIpll, getName field_) >.< (getName attr_, drhs field_)- {-# LINE 2648 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2635 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule261 #-} rule261 = \ attr_ field_ pos_ rdesc_ -> AGField field_ attr_ pos_ rdesc_@@ -3039,51 +3026,51 @@ rule294 = \ ((_lhsInmp) :: NMP) inhAttr_ -> {-# LINE 225 "src-ag/LOAG/Order.ag" #-} Map.keysSet$ Map.unions $ map (vertexToAttr _lhsInmp) inhAttr_- {-# LINE 3043 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3030 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule295 #-} {-# LINE 226 "src-ag/LOAG/Order.ag" #-} rule295 = \ ((_lhsInmp) :: NMP) synAttr_ -> {-# LINE 226 "src-ag/LOAG/Order.ag" #-} Map.keysSet$ Map.unions $ map (vertexToAttr _lhsInmp) synAttr_- {-# LINE 3049 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3036 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule296 #-} {-# LINE 227 "src-ag/LOAG/Order.ag" #-} rule296 = \ inhOccs_ -> {-# LINE 227 "src-ag/LOAG/Order.ag" #-} maybe (error "segment not instantiated") id inhOccs_- {-# LINE 3055 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3042 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule297 #-} {-# LINE 228 "src-ag/LOAG/Order.ag" #-} rule297 = \ synOccs_ -> {-# LINE 228 "src-ag/LOAG/Order.ag" #-} maybe (error "segment not instantiated") id synOccs_- {-# LINE 3061 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3048 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule298 #-} {-# LINE 229 "src-ag/LOAG/Order.ag" #-} rule298 = \ visnr_ -> {-# LINE 229 "src-ag/LOAG/Order.ag" #-} visnr_- {-# LINE 3067 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3054 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule299 #-} {-# LINE 230 "src-ag/LOAG/Order.ag" #-} rule299 = \ ((_lhsIoptions) :: Options) -> {-# LINE 230 "src-ag/LOAG/Order.ag" #-} if monadic _lhsIoptions then VisitMonadic else VisitPure True- {-# LINE 3073 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3060 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule300 #-} {-# LINE 231 "src-ag/LOAG/Order.ag" #-} rule300 = \ _inhs _kind ((_lhsIvisitnum) :: Int) _steps _syns -> {-# LINE 231 "src-ag/LOAG/Order.ag" #-} Visit _lhsIvisitnum _lhsIvisitnum (_lhsIvisitnum+1) _inhs _syns _steps _kind- {-# LINE 3080 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3067 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule301 #-} {-# LINE 233 "src-ag/LOAG/Order.ag" #-} rule301 = \ ((_lhsIoptions) :: Options) _vss -> {-# LINE 233 "src-ag/LOAG/Order.ag" #-} if monadic _lhsIoptions then [Sim _vss ] else [PureGroup _vss True]- {-# LINE 3087 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3074 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule302 #-} {-# LINE 235 "src-ag/LOAG/Order.ag" #-} rule302 = \ ((_lhsIdone) :: (Set.Set MyOccurrence, Set.Set FLabel@@ -3092,7 +3079,7 @@ (runST $ getVss _lhsIdone _lhsIps _lhsItdp _synsO _lhsIlfpf _lhsInmprf _lhsIpmpf _lhsIpmprf _lhsIfty _lhsIvisMapf _lhsIruleMap _lhsIhoMapf)- {-# LINE 3096 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3083 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule303 #-} rule303 = \ inhAttr_ inhOccs_ synAttr_ synOccs_ visnr_ -> MySegment visnr_ inhAttr_ synAttr_ inhOccs_ synOccs_@@ -3197,14 +3184,14 @@ , Set.Set Identifier, Set.Set (FLabel,Int))) -> {-# LINE 220 "src-ag/LOAG/Order.ag" #-} _lhsIdone- {-# LINE 3201 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3188 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule308 #-} {-# LINE 221 "src-ag/LOAG/Order.ag" #-} rule308 = \ ((_hdIdone) :: (Set.Set MyOccurrence, Set.Set FLabel ,Set.Set Identifier, Set.Set (FLabel,Int))) -> {-# LINE 221 "src-ag/LOAG/Order.ag" #-} _hdIdone- {-# LINE 3208 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3195 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule309 #-} rule309 = \ ((_hdIevisits) :: Visit) ((_tlIevisits) :: Visits) -> _hdIevisits : _tlIevisits@@ -3491,43 +3478,43 @@ rule347 = \ ((_prodsIrefNts) :: Set NontermIdent) nt_ -> {-# LINE 16 "src-ag/ExecutionPlanCommon.ag" #-} Map.singleton nt_ _prodsIrefNts- {-# LINE 3495 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3482 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule348 #-} {-# LINE 17 "src-ag/ExecutionPlanCommon.ag" #-} rule348 = \ ((_prodsIrefHoNts) :: Set NontermIdent) nt_ -> {-# LINE 17 "src-ag/ExecutionPlanCommon.ag" #-} Map.singleton nt_ _prodsIrefHoNts- {-# LINE 3501 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3488 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule349 #-} {-# LINE 19 "src-ag/ExecutionPlanCommon.ag" #-} rule349 = \ ((_lhsIclosedNtDeps) :: Map NontermIdent (Set NontermIdent)) nt_ -> {-# LINE 19 "src-ag/ExecutionPlanCommon.ag" #-} Map.findWithDefault Set.empty nt_ _lhsIclosedNtDeps- {-# LINE 3507 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3494 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule350 #-} {-# LINE 20 "src-ag/ExecutionPlanCommon.ag" #-} rule350 = \ ((_lhsIclosedHoNtDeps) :: Map NontermIdent (Set NontermIdent)) nt_ -> {-# LINE 20 "src-ag/ExecutionPlanCommon.ag" #-} Map.findWithDefault Set.empty nt_ _lhsIclosedHoNtDeps- {-# LINE 3513 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3500 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule351 #-} {-# LINE 21 "src-ag/ExecutionPlanCommon.ag" #-} rule351 = \ ((_lhsIclosedHoNtRevDeps) :: Map NontermIdent (Set NontermIdent)) nt_ -> {-# LINE 21 "src-ag/ExecutionPlanCommon.ag" #-} Map.findWithDefault Set.empty nt_ _lhsIclosedHoNtRevDeps- {-# LINE 3519 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3506 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule352 #-} {-# LINE 23 "src-ag/ExecutionPlanCommon.ag" #-} rule352 = \ _closedNtDeps nt_ -> {-# LINE 23 "src-ag/ExecutionPlanCommon.ag" #-} nt_ `Set.member` _closedNtDeps- {-# LINE 3525 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3512 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule353 #-} {-# LINE 24 "src-ag/ExecutionPlanCommon.ag" #-} rule353 = \ _closedHoNtDeps nt_ -> {-# LINE 24 "src-ag/ExecutionPlanCommon.ag" #-} nt_ `Set.member` _closedHoNtDeps- {-# LINE 3531 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3518 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule354 #-} {-# LINE 25 "src-ag/ExecutionPlanCommon.ag" #-} rule354 = \ _closedHoNtDeps _closedHoNtRevDeps _nontrivAcyc ->@@ -3536,57 +3523,57 @@ , hoNtRevDeps = _closedHoNtRevDeps , hoAcyclic = _nontrivAcyc }- {-# LINE 3540 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3527 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule355 #-} {-# LINE 54 "src-ag/ExecutionPlanCommon.ag" #-} rule355 = \ ((_lhsIclassContexts) :: ContextMap) nt_ -> {-# LINE 54 "src-ag/ExecutionPlanCommon.ag" #-} Map.findWithDefault [] nt_ _lhsIclassContexts- {-# LINE 3546 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3533 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule356 #-} {-# LINE 88 "src-ag/ExecutionPlanCommon.ag" #-} rule356 = \ ((_lhsIaroundMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) nt_ -> {-# LINE 88 "src-ag/ExecutionPlanCommon.ag" #-} Map.findWithDefault Map.empty nt_ _lhsIaroundMap- {-# LINE 3552 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3539 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule357 #-} {-# LINE 113 "src-ag/ExecutionPlanCommon.ag" #-} rule357 = \ ((_lhsImergeMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression)))) nt_ -> {-# LINE 113 "src-ag/ExecutionPlanCommon.ag" #-} Map.findWithDefault Map.empty nt_ _lhsImergeMap- {-# LINE 3558 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3545 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule358 #-} {-# LINE 149 "src-ag/ExecutionPlanCommon.ag" #-} rule358 = \ inh_ nt_ -> {-# LINE 149 "src-ag/ExecutionPlanCommon.ag" #-} Map.singleton nt_ inh_- {-# LINE 3564 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3551 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule359 #-} {-# LINE 150 "src-ag/ExecutionPlanCommon.ag" #-} rule359 = \ nt_ syn_ -> {-# LINE 150 "src-ag/ExecutionPlanCommon.ag" #-} Map.singleton nt_ syn_- {-# LINE 3570 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3557 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule360 #-} {-# LINE 159 "src-ag/ExecutionPlanCommon.ag" #-} rule360 = \ ((_prodsIlocalSigMap) :: Map.Map ConstructorIdent (Map.Map Identifier Type)) nt_ -> {-# LINE 159 "src-ag/ExecutionPlanCommon.ag" #-} Map.singleton nt_ _prodsIlocalSigMap- {-# LINE 3576 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3563 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule361 #-} {-# LINE 65 "src-ag/LOAG/Prepare.ag" #-} rule361 = \ inh_ nt_ -> {-# LINE 65 "src-ag/LOAG/Prepare.ag" #-} let dty = TyData (getName nt_) in Map.singleton dty (toMyAttr Inh dty inh_)- {-# LINE 3583 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3570 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule362 #-} {-# LINE 67 "src-ag/LOAG/Prepare.ag" #-} rule362 = \ nt_ syn_ -> {-# LINE 67 "src-ag/LOAG/Prepare.ag" #-} let dty = TyData (getName nt_) in Map.singleton dty (toMyAttr Syn dty syn_)- {-# LINE 3590 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3577 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule363 #-} {-# LINE 69 "src-ag/LOAG/Prepare.ag" #-} rule363 = \ ((_lhsIaugM) :: Map.Map Identifier (Map.Map Identifier (Set.Set Dependency))) nt_ ->@@ -3594,51 +3581,51 @@ case Map.lookup nt_ _lhsIaugM of Nothing -> Map.empty Just a -> a- {-# LINE 3598 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3585 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule364 #-} {-# LINE 131 "src-ag/LOAG/Prepare.ag" #-} rule364 = \ nt_ -> {-# LINE 131 "src-ag/LOAG/Prepare.ag" #-} TyData (getName nt_)- {-# LINE 3604 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3591 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule365 #-} {-# LINE 82 "src-ag/LOAG/Order.ag" #-} rule365 = \ ((_prodsIfdps) :: Map.Map ConstructorIdent (Set Dependency)) nt_ -> {-# LINE 82 "src-ag/LOAG/Order.ag" #-} Map.singleton nt_ _prodsIfdps- {-# LINE 3610 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3597 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule366 #-} {-# LINE 138 "src-ag/LOAG/Order.ag" #-} rule366 = \ ((_lhsIvisitnum) :: Int) -> {-# LINE 138 "src-ag/LOAG/Order.ag" #-} _lhsIvisitnum- {-# LINE 3616 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3603 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule367 #-} {-# LINE 139 "src-ag/LOAG/Order.ag" #-} rule367 = \ _initial _segments -> {-# LINE 139 "src-ag/LOAG/Order.ag" #-} zipWith const [_initial ..] _segments- {-# LINE 3622 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3609 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule368 #-} {-# LINE 140 "src-ag/LOAG/Order.ag" #-} rule368 = \ _vnums -> {-# LINE 140 "src-ag/LOAG/Order.ag" #-} _vnums- {-# LINE 3628 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3615 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule369 #-} {-# LINE 141 "src-ag/LOAG/Order.ag" #-} rule369 = \ _initial _vnums -> {-# LINE 141 "src-ag/LOAG/Order.ag" #-} Map.fromList $ (_initial + length _vnums, NoneVis) : [(v, OneVis v) | v <- _vnums ]- {-# LINE 3635 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3622 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule370 #-} {-# LINE 143 "src-ag/LOAG/Order.ag" #-} rule370 = \ _initial _vnums -> {-# LINE 143 "src-ag/LOAG/Order.ag" #-} Map.fromList $ (_initial , NoneVis) : [(v+1, OneVis v) | v <- _vnums ]- {-# LINE 3642 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3629 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule371 #-} {-# LINE 145 "src-ag/LOAG/Order.ag" #-} rule371 = \ _initial _mysegments ->@@ -3646,7 +3633,7 @@ let op vnr (MySegment visnr ins syns _ _) = IMap.fromList $ zip syns (repeat vnr) in IMap.unions $ zipWith op [_initial ..] _mysegments- {-# LINE 3650 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3637 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule372 #-} {-# LINE 148 "src-ag/LOAG/Order.ag" #-} rule372 = \ _classContexts _hoInfo _initial _initialVisit _nextVis _prevVis ((_prodsIeprods) :: EProductions) _recursive nt_ params_ ->@@ -3662,14 +3649,14 @@ _prodsIeprods _recursive _hoInfo ]- {-# LINE 3666 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3653 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule373 #-} {-# LINE 322 "src-ag/LOAG/Order.ag" #-} rule373 = \ ((_lhsIsched) :: InterfaceRes) nt_ -> {-# LINE 322 "src-ag/LOAG/Order.ag" #-} findWithErr _lhsIsched "could not const. interfaces" (getName nt_)- {-# LINE 3673 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3660 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule374 #-} {-# LINE 324 "src-ag/LOAG/Order.ag" #-} rule374 = \ _assigned ((_lhsIsched) :: InterfaceRes) ->@@ -3678,7 +3665,7 @@ then 0 else let mx = fst $ IMap.findMax _assigned in if even mx then mx else mx + 1- {-# LINE 3682 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3669 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule375 #-} {-# LINE 329 "src-ag/LOAG/Order.ag" #-} rule375 = \ _assigned _mx ->@@ -3688,7 +3675,7 @@ (maybe [] id $ IMap.lookup (i-1) _assigned ) Nothing Nothing) [_mx ,_mx -2 .. 2]- {-# LINE 3692 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3679 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule376 #-} {-# LINE 335 "src-ag/LOAG/Order.ag" #-} rule376 = \ ((_lhsInmp) :: NMP) _mysegments ->@@ -3697,7 +3684,7 @@ CSegment (Map.unions $ map (vertexToAttr _lhsInmp) is) (Map.unions $ map (vertexToAttr _lhsInmp) ss)) _mysegments- {-# LINE 3701 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3688 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule377 #-} rule377 = \ ((_prodsIads) :: [Edge]) -> _prodsIads@@ -4557,7 +4544,7 @@ let isLocal = (field_ == _LOC || field_ == _INST) in [(getName field_, (getName attr_, dlhs field_), isLocal)] ++ _patIafs- {-# LINE 4561 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 4548 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule552 #-} rule552 = \ ((_patIcopy) :: Pattern) attr_ field_ -> Alias field_ attr_ _patIcopy@@ -4892,31 +4879,31 @@ rule576 = \ ((_lhsIaroundMap) :: Map ConstructorIdent (Map Identifier [Expression])) con_ -> {-# LINE 89 "src-ag/ExecutionPlanCommon.ag" #-} Map.findWithDefault Map.empty con_ _lhsIaroundMap- {-# LINE 4896 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 4883 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule577 #-} {-# LINE 114 "src-ag/ExecutionPlanCommon.ag" #-} rule577 = \ ((_lhsImergeMap) :: Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression))) con_ -> {-# LINE 114 "src-ag/ExecutionPlanCommon.ag" #-} Map.findWithDefault Map.empty con_ _lhsImergeMap- {-# LINE 4902 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 4889 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule578 #-} {-# LINE 120 "src-ag/ExecutionPlanCommon.ag" #-} rule578 = \ _mergeMap -> {-# LINE 120 "src-ag/ExecutionPlanCommon.ag" #-} Set.unions [ Set.fromList ms | (_,ms,_) <- Map.elems _mergeMap ]- {-# LINE 4908 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 4895 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule579 #-} {-# LINE 160 "src-ag/ExecutionPlanCommon.ag" #-} rule579 = \ ((_typeSigsIlocalSigMap) :: Map Identifier Type) con_ -> {-# LINE 160 "src-ag/ExecutionPlanCommon.ag" #-} Map.singleton con_ _typeSigsIlocalSigMap- {-# LINE 4914 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 4901 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule580 #-} {-# LINE 115 "src-ag/LOAG/Prepare.ag" #-} rule580 = \ ((_lhsIdty) :: MyType) con_ -> {-# LINE 115 "src-ag/LOAG/Prepare.ag" #-} (_lhsIdty,getName con_)- {-# LINE 4920 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 4907 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule581 #-} {-# LINE 117 "src-ag/LOAG/Prepare.ag" #-} rule581 = \ ((_childrenIpmpr) :: PMP_R) ((_lhsIaugM) :: Map.Map Identifier (Set.Set Dependency)) _pll con_ ->@@ -4924,37 +4911,37 @@ case Map.lookup con_ _lhsIaugM of Nothing -> [] Just a -> Set.toList $ Set.map (depToEdge _childrenIpmpr _pll ) a- {-# LINE 4928 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 4915 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule582 #-} {-# LINE 120 "src-ag/LOAG/Prepare.ag" #-} rule582 = \ ((_lhsIdty) :: MyType) -> {-# LINE 120 "src-ag/LOAG/Prepare.ag" #-} _lhsIdty- {-# LINE 4934 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 4921 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule583 #-} {-# LINE 214 "src-ag/LOAG/Prepare.ag" #-} rule583 = \ ((_lhsIdty) :: MyType) con_ -> {-# LINE 214 "src-ag/LOAG/Prepare.ag" #-} (_lhsIdty,getName con_)- {-# LINE 4940 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 4927 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule584 #-} {-# LINE 215 "src-ag/LOAG/Prepare.ag" #-} rule584 = \ _pll -> {-# LINE 215 "src-ag/LOAG/Prepare.ag" #-} _pll- {-# LINE 4946 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 4933 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule585 #-} {-# LINE 216 "src-ag/LOAG/Prepare.ag" #-} rule585 = \ ((_childrenIpts) :: Set.Set FLabel) -> {-# LINE 216 "src-ag/LOAG/Prepare.ag" #-} _childrenIpts- {-# LINE 4952 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 4939 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule586 #-} {-# LINE 217 "src-ag/LOAG/Prepare.ag" #-} rule586 = \ ((_childrenIfieldMap) :: FMap) _pll -> {-# LINE 217 "src-ag/LOAG/Prepare.ag" #-} Map.singleton _pll $ Map.keys _childrenIfieldMap- {-# LINE 4958 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 4945 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule587 #-} {-# LINE 89 "src-ag/LOAG/Order.ag" #-} rule587 = \ ((_lhsIdty) :: MyType) ((_lhsIpmpf) :: PMP) ((_lhsIres_ads) :: [Edge]) con_ ->@@ -4965,19 +4952,19 @@ | otherwise = ds in Map.singleton con_ $ foldr op Set.empty _lhsIres_ads- {-# LINE 4969 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 4956 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule588 #-} {-# LINE 167 "src-ag/LOAG/Order.ag" #-} rule588 = \ ((_rulesIruleMap) :: Map.Map MyOccurrence Identifier) -> {-# LINE 167 "src-ag/LOAG/Order.ag" #-} _rulesIruleMap- {-# LINE 4975 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 4962 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule589 #-} {-# LINE 168 "src-ag/LOAG/Order.ag" #-} rule589 = \ (_ :: ()) -> {-# LINE 168 "src-ag/LOAG/Order.ag" #-} (Set.empty, Set.empty, Set.empty, Set.empty)- {-# LINE 4981 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 4968 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule590 #-} {-# LINE 169 "src-ag/LOAG/Order.ag" #-} rule590 = \ ((_childrenIself) :: Children) ->@@ -4986,7 +4973,7 @@ | kind == ChildAttr = Nothing | otherwise = Just $ ChildIntro nm in catMaybes $ map intro _childrenIself- {-# LINE 4990 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 4977 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule591 #-} {-# LINE 174 "src-ag/LOAG/Order.ag" #-} rule591 = \ ((_childrenIechilds) :: EChildren) _intros ((_rulesIerules) :: ERules) ((_segsIevisits) :: Visits) con_ constraints_ params_ ->@@ -5003,7 +4990,7 @@ _rulesIerules _childrenIechilds visits ]- {-# LINE 5007 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 4994 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule592 #-} {-# LINE 346 "src-ag/LOAG/Order.ag" #-} rule592 = \ ((_lhsImysegments) :: MySegments) ((_lhsInmp) :: NMP) ((_lhsIpmprf) :: PMP_R) _ps ->@@ -5017,7 +5004,7 @@ handAllOut (_ps ,"lhs") $ map (_lhsInmp Map.!) syns) ) _lhsImysegments- {-# LINE 5021 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 5008 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule593 #-} rule593 = \ ((_childrenIap) :: A_P) -> _childrenIap@@ -5337,13 +5324,13 @@ rule649 = \ ((_lhsIvisitnum) :: Int) -> {-# LINE 192 "src-ag/LOAG/Order.ag" #-} _lhsIvisitnum- {-# LINE 5341 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 5328 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule650 #-} {-# LINE 193 "src-ag/LOAG/Order.ag" #-} rule650 = \ ((_hdIvisitnum) :: Int) -> {-# LINE 193 "src-ag/LOAG/Order.ag" #-} _hdIvisitnum- {-# LINE 5347 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 5334 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule651 #-} rule651 = \ ((_hdIads) :: [Edge]) ((_tlIads) :: [Edge]) -> ((++) _hdIads _tlIads)@@ -5785,31 +5772,31 @@ explicit_ pure_ mbError_- {-# LINE 5789 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 5776 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule752 #-} {-# LINE 12 "src-ag/ExecutionPlanPre.ag" #-} rule752 = \ ((_lhsIrulenumber) :: Int) -> {-# LINE 12 "src-ag/ExecutionPlanPre.ag" #-} _lhsIrulenumber + 1- {-# LINE 5795 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 5782 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule753 #-} {-# LINE 13 "src-ag/ExecutionPlanPre.ag" #-} rule753 = \ ((_lhsIrulenumber) :: Int) mbName_ -> {-# LINE 13 "src-ag/ExecutionPlanPre.ag" #-} maybe (identifier $ "rule" ++ show _lhsIrulenumber) id mbName_- {-# LINE 5801 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 5788 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule754 #-} {-# LINE 230 "src-ag/LOAG/Prepare.ag" #-} rule754 = \ ((_rhsIused) :: Set.Set MyOccurrence) -> {-# LINE 230 "src-ag/LOAG/Prepare.ag" #-} Set.filter (\(MyOccurrence (_,f) _) -> f == "loc") _rhsIused- {-# LINE 5807 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 5794 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule755 #-} {-# LINE 231 "src-ag/LOAG/Prepare.ag" #-} rule755 = \ _usedLocals -> {-# LINE 231 "src-ag/LOAG/Prepare.ag" #-} not $ Set.null _usedLocals- {-# LINE 5813 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 5800 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule756 #-} {-# LINE 233 "src-ag/LOAG/Prepare.ag" #-} rule756 = \ ((_lhsIlfpf) :: SF_P) ((_lhsIpll) :: PLabel) ((_patternIafs) :: [(FLabel, ALabel, Bool)]) ((_rhsIused) :: Set.Set MyOccurrence) _rulename _usedLocals _usesLocals ->@@ -5833,7 +5820,7 @@ (Set.singleton att) m) lr _rhsIused) else (sfpins,rm,l,lr)) (Map.empty,Map.empty,Map.empty,Map.empty) _patternIafs- {-# LINE 5837 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 5824 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule757 #-} rule757 = \ ((_rhsIused) :: Set.Set MyOccurrence) -> _rhsIused@@ -6159,7 +6146,7 @@ rule795 = \ name_ tp_ -> {-# LINE 161 "src-ag/ExecutionPlanCommon.ag" #-} Map.singleton name_ tp_- {-# LINE 6163 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 6150 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule796 #-} rule796 = \ name_ tp_ -> TypeSig name_ tp_
src-generated/LOAG/Rep.hs view
@@ -1,6 +1,6 @@ --- UUAGC 0.9.51.1 (src-ag/LOAG/Rep.ag)+-- UUAGC 0.9.51 (src-ag/LOAG/Rep.ag) module LOAG.Rep where import CommonTypes
src-generated/Macro.hs view
@@ -1,6 +1,6 @@ --- UUAGC 0.9.51.1 (src-ag/Macro.ag)+-- UUAGC 0.9.51 (src-ag/Macro.ag) module Macro where {-# LINE 4 "src-ag/Macro.ag" #-}
src-generated/Patterns.hs view
@@ -1,6 +1,6 @@ --- UUAGC 0.9.51.1 (src-ag/Patterns.ag)+-- UUAGC 0.9.51 (src-ag/Patterns.ag) module Patterns where {-# LINE 2 "src-ag/Patterns.ag" #-}
src-generated/Transform.hs view
@@ -866,57 +866,57 @@ {-# LINE 328 "src-ag/Transform.ag" #-} rule33 = \ _allRulesErrs -> {-# LINE 328 "src-ag/Transform.ag" #-}- let f m s = Map.fold ((><) . snd) s m- in Map.fold f Seq.empty _allRulesErrs+ let f m s = Map.foldr ((><) . snd) s m+ in Map.foldr f Seq.empty _allRulesErrs {-# LINE 872 "dist/build/Transform.hs"#-} {-# INLINE rule34 #-} {-# LINE 331 "src-ag/Transform.ag" #-} rule34 = \ _allSigsErrs -> {-# LINE 331 "src-ag/Transform.ag" #-}- let f m s = Map.fold ((><) . snd) s m- in Map.fold f Seq.empty _allSigsErrs+ let f m s = Map.foldr ((><) . snd) s m+ in Map.foldr f Seq.empty _allSigsErrs {-# LINE 879 "dist/build/Transform.hs"#-} {-# INLINE rule35 #-} {-# LINE 334 "src-ag/Transform.ag" #-} rule35 = \ _allInstsErrs -> {-# LINE 334 "src-ag/Transform.ag" #-}- let f m s = Map.fold ((><) . snd) s m- in Map.fold f Seq.empty _allInstsErrs+ let f m s = Map.foldr ((><) . snd) s m+ in Map.foldr f Seq.empty _allInstsErrs {-# LINE 886 "dist/build/Transform.hs"#-} {-# INLINE rule36 #-} {-# LINE 337 "src-ag/Transform.ag" #-} rule36 = \ _allUniquesErrs -> {-# LINE 337 "src-ag/Transform.ag" #-}- let f m s = Map.fold ((><) . snd) s m- in Map.fold f Seq.empty _allUniquesErrs+ let f m s = Map.foldr ((><) . snd) s m+ in Map.foldr f Seq.empty _allUniquesErrs {-# LINE 893 "dist/build/Transform.hs"#-} {-# INLINE rule37 #-} {-# LINE 340 "src-ag/Transform.ag" #-} rule37 = \ _allAugmentErrs -> {-# LINE 340 "src-ag/Transform.ag" #-}- let f m s = Map.fold ((><) . snd) s m- in Map.fold f Seq.empty _allAugmentErrs+ let f m s = Map.foldr ((><) . snd) s m+ in Map.foldr f Seq.empty _allAugmentErrs {-# LINE 900 "dist/build/Transform.hs"#-} {-# INLINE rule38 #-} {-# LINE 343 "src-ag/Transform.ag" #-} rule38 = \ _allAroundsErrs -> {-# LINE 343 "src-ag/Transform.ag" #-}- let f m s = Map.fold ((><) . snd) s m- in Map.fold f Seq.empty _allAroundsErrs+ let f m s = Map.foldr ((><) . snd) s m+ in Map.foldr f Seq.empty _allAroundsErrs {-# LINE 907 "dist/build/Transform.hs"#-} {-# INLINE rule39 #-} {-# LINE 346 "src-ag/Transform.ag" #-} rule39 = \ _allNamesErrs -> {-# LINE 346 "src-ag/Transform.ag" #-}- let f m s = Map.fold ((><)) s m- in Map.fold f Seq.empty _allNamesErrs+ let f m s = Map.foldr ((><)) s m+ in Map.foldr f Seq.empty _allNamesErrs {-# LINE 914 "dist/build/Transform.hs"#-} {-# INLINE rule40 #-} {-# LINE 349 "src-ag/Transform.ag" #-} rule40 = \ _allMergesErrs -> {-# LINE 349 "src-ag/Transform.ag" #-}- let f m s = Map.fold ((><) . snd) s m- in Map.fold f Seq.empty _allMergesErrs+ let f m s = Map.foldr ((><) . snd) s m+ in Map.foldr f Seq.empty _allMergesErrs {-# LINE 921 "dist/build/Transform.hs"#-} {-# INLINE rule41 #-} {-# LINE 352 "src-ag/Transform.ag" #-}
src-generated/VisagePatterns.hs view
@@ -1,6 +1,6 @@ --- UUAGC 0.9.51.1 (src-ag/VisagePatterns.ag)+-- UUAGC 0.9.51 (src-ag/VisagePatterns.ag) module VisagePatterns where {-# LINE 2 "src-ag/VisagePatterns.ag" #-}
src-generated/VisageSyntax.hs view
@@ -1,6 +1,6 @@ --- UUAGC 0.9.51.1 (src-ag/VisageSyntax.ag)+-- UUAGC 0.9.51 (src-ag/VisageSyntax.ag) module VisageSyntax where {-# LINE 2 "src-ag/VisageSyntax.ag" #-}
src/ATermWrite.hs view
@@ -6,7 +6,7 @@ writeATerm :: ATerm -> String writeATerm t = writeAT 0 t -writeAT :: Int -> ATerm -> String +writeAT :: Int -> ATerm -> String writeAT n (AAppl c ts) = (if (n > 0) then "\n" else "") ++ replicate n ' ' ++ writeATermAux c (map (writeAT (n+2)) ts) @@ -15,14 +15,14 @@ writeAT _ (AString s) = quote s writeATermAux :: [Char] -> [[Char]] -> [Char] -writeATermAux c [] = c++(parenthesise "") -writeATermAux c ts = c++(parenthesise (commaSep ts)) +writeATermAux c [] = c++(parenthesise "") +writeATermAux c ts = c++(parenthesise (commaSep ts)) commaSep :: [[Char]] -> [Char] -commaSep strs = concat (intersperse "," strs) +commaSep strs = concat (intersperse "," strs) bracket :: [Char] -> [Char] -bracket str = "["++str++"]" +bracket str = "["++str++"]" parenthesise :: [Char] -> [Char] -parenthesise str = "("++str++")" +parenthesise str = "("++str++")" quote :: [Char] -> [Char] -quote str = "\""++str++"\""+quote str = "\""++str++"\""
src/KennedyWarren.hs view
@@ -20,6 +20,7 @@ import qualified Data.Set as Set import Data.Map (Map) import qualified Data.Map as Map+import qualified Data.Map.Strict as MapStrict import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.IntSet (IntSet)@@ -161,11 +162,11 @@ -- | Pretty print a vertex in GraphViz format toGVVertex :: Bool -> Vertex -> ST s PP_Doc toGVVertex l (VAttr t a b) = return $ (text $ "attr_" ++ show t ++ "_" ++ show a ++ "_" ++ show b) >#< if l- then text ("[shape=box,label=\"" ++ show t ++ " @" ++ show a ++ "." ++ show b ++ "\"]") else empty+ then text ("[shape=box,label=\"" ++ show t ++ " @" ++ show a ++ "." ++ show b ++ "\"]") else empty toGVVertex l (VChild c) = return $ (text $ "child_" ++ show c) >#< if l- then text ("[shape=ellipse,label=\"Child " ++ show c ++ "\"]") else empty+ then text ("[shape=ellipse,label=\"Child " ++ show c ++ "\"]") else empty toGVVertex l (VRule r) = return $ (text $ "rule_" ++ show r) >#< if l- then text ("[shape=diamond,label=\"" ++ show r ++ "\"]") else empty+ then text ("[shape=diamond,label=\"" ++ show r ++ "\"]") else empty -- | Pretty print an edge in GraphViz format toGVEdge :: Edge -> ST s PP_Doc@@ -400,7 +401,7 @@ let (VGNode from,vgto) = imLookup vs edges -- from must be equal to the current state childvs <- gets vgChildVisits let rchildv = imLookup edg childvs- vgInST $ modifySTRef rchildv $ Map.insertWith' (++) (ide,p) [vgto]+ vgInST $ modifySTRef rchildv $ MapStrict.insertWith (++) (ide,p) [vgto] ndis <- gets vgNDI let rndi = imLookup from ndis ndi <- vgInST $ readSTRef rndi@@ -766,10 +767,10 @@ -- Return execution plan for this production return $ EProduction (pdgProduction $ pdgmOrig prod) (pdgParams $ pdgmOrig prod)- (pdgConstraints $ pdgmOrig prod)+ (pdgConstraints $ pdgmOrig prod) (pdgRules $ pdgmOrig prod) (pdgChilds $ pdgmOrig prod)- visits+ 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
src/Knuth1.hs view
@@ -28,8 +28,8 @@ -- Vertices data AttrType = Inh | Syn | Loc deriving (Eq, Ord, Show) data Vertex = VAttr AttrType Identifier Identifier- | VChild Identifier- | VRule Identifier deriving (Eq, Ord)+ | VChild Identifier+ | VRule Identifier deriving (Eq, Ord) instance Show Vertex where show (VAttr ty ch at) = show ty ++ " @" ++ show ch ++ "." ++ show at@@ -39,7 +39,7 @@ -- | Check if a vertex is an attribute isVertexAttr :: Vertex -> Bool isVertexAttr (VAttr _ _ _) = True-isVertexAttr _ = False+isVertexAttr _ = False -- | Get the child name of an attribute getAttrChildName :: Vertex -> Identifier
src/Pretty.hs view
@@ -34,10 +34,10 @@ data Doc = Emp | Emp1- | Str !String -- basic string- | Hor Doc !Doc -- horizontal positioning- | Ver Doc !Doc -- vertical positioning- | Ind !Int Doc -- indent+ | Str !String -- basic string+ | Hor Doc !Doc -- horizontal positioning+ | Ver Doc !Doc -- vertical positioning+ | Ind !Int Doc -- indent | Line (Int -> Doc) -- line nr type PP_Doc = Doc
uuagc.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.8 build-type: Custom name: uuagc-version: 0.9.52.1+version: 0.9.52.2 license: BSD3 license-file: LICENSE maintainer: Jeroen Bransen <J.Bransen@uu.nl>@@ -38,7 +38,7 @@ build-depends: uuagc-cabal >= 1.0.2.0 build-depends: base >= 4, base < 5 -- Self dependency, depend on library below- build-depends: uuagc == 0.9.52.1+ build-depends: uuagc main-is: Main.hs hs-source-dirs: src-main