uuagc-0.9.42.3/000755 000765 000024 00000000000 12127045231 015046 5ustar00jeroenbransenstaff000000 000000 uuagc-0.9.42.3/dist/000755 000765 000024 00000000000 12127045231 016011 5ustar00jeroenbransenstaff000000 000000 uuagc-0.9.42.3/LICENSE000644 000765 000024 00000002702 12127045231 016054 0ustar00jeroenbransenstaff000000 000000 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the Universiteit Utrecht nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UNIVERSITEIT UTRECHT BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. uuagc-0.9.42.3/README000644 000765 000024 00000001162 12127045231 015726 0ustar00jeroenbransenstaff000000 000000 To install UUAG, use cabal in combination with Setup.hs Note: you'll need the packages because UUAGC is bootstrapped: uuagc-cabal uuagc-bootstrap By default, UUAGC is bootstrapped with the tool 'uuagc-bootstrap' in the uuagc-bootstrap package. If you want to bootstrap with a different tool, change the compiler-variable in Setup.hs Note: to produce a source release, you'll need to use the Setup.hs because cabal-install at the time is not able to do this in combination with the cabal plugin: -- cabal clean # remove possible junk ghc --make Setup.hs -o setup ./setup configure --user ./setup build ./setup sdist -- uuagc-0.9.42.3/Setup.hs000644 000765 000024 00000002433 12127045231 016504 0ustar00jeroenbransenstaff000000 000000 -- Note: to bootstrap uuagc with a commandline uuagc, -- pass the -DEXTERNAL_UUAGC to GHC -- when building setup.hs. This can be accomplished using -- cabal install with --ghc-options="-DEXTERNAL_UUAGC". -- -- When this option is used, a cabal flag will be set so -- that the Haskell sources will be regenerated from -- the attribute grammar sources -- -- Note: it would be nicer if this behavior could be enabled -- with a configure flag. However, a compiled Setup.hs is -- required in order to perform 'configure', so configure -- flags are regarded too late in the process. -- Also note that this Setup.hs has conditional package -- requirements depending on what code is used. {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} {-# LANGUAGE CPP #-} module Main where #ifdef EXTERNAL_UUAGC import System.Environment (getArgs) import Distribution.Simple (defaultMainWithHooksArgs) import Distribution.Simple.UUAGC (uuagcUserHook) main :: IO () main = args >>= defaultMainWithHooksArgs uuagcUserHook args :: IO [String] args = do as <- getArgs let addFlags | "configure" `elem` as = ("--flags=bootstrap_external" :) | otherwise = id return (addFlags as) #else import Distribution.Simple (defaultMain, defaultMainWithHooksArgs) main :: IO () main = defaultMain #endif uuagc-0.9.42.3/src/000755 000765 000024 00000000000 12127045231 015635 5ustar00jeroenbransenstaff000000 000000 uuagc-0.9.42.3/src-ag/000755 000765 000024 00000000000 12127045231 016222 5ustar00jeroenbransenstaff000000 000000 uuagc-0.9.42.3/src-generated/000755 000765 000024 00000000000 12127045231 017571 5ustar00jeroenbransenstaff000000 000000 uuagc-0.9.42.3/src-main/000755 000765 000024 00000000000 12127045231 016557 5ustar00jeroenbransenstaff000000 000000 uuagc-0.9.42.3/src-options/000755 000765 000024 00000000000 12127045231 017326 5ustar00jeroenbransenstaff000000 000000 uuagc-0.9.42.3/src-version/000755 000765 000024 00000000000 12127045231 017320 5ustar00jeroenbransenstaff000000 000000 uuagc-0.9.42.3/uuagc.cabal000644 000765 000024 00000005022 12127045231 017135 0ustar00jeroenbransenstaff000000 000000 cabal-version: >= 1.8 build-type: Custom name: uuagc version: 0.9.42.3 license: BSD3 license-file: LICENSE maintainer: Jeroen Bransen homepage: http://www.cs.uu.nl/wiki/HUT/WebHome description: Generates Haskell files from an attribute grammar specification synopsis: Attribute Grammar System of Universiteit Utrecht category: Development stability: Stable copyright: Universiteit Utrecht author: Software Technology at Universiteit Utrecht bug-reports: hut-developers@cs.uu.nl tested-with: GHC >= 6.12 extra-source-files: README extra-source-files: uuagc_options extra-source-files: src-ag/DistChildAttr.ag -- This flag will be set by Setup.hs, use -- cabal configure --ghc-options="-DEXTERNAL_UUAGC" flag bootstrap_external description: Use an external uuagc executable for bootstrapping default: False manual: True executable uuagc 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.42.3 main-is: Main.hs hs-source-dirs: src-main library build-depends: uuagc-cabal >= 1.0.2.0 build-depends: base >= 4, base < 5, ghc-prim >= 0.2.0.0 build-depends: containers >= 0.3, directory >= 1.0.1.1, array >= 0.3.0.1 build-depends: uulib >= 0.9.14, mtl >= 1.1.1.1 build-depends: haskell-src-exts >= 1.11.1 build-depends: filepath >= 1.1.0.4 hs-source-dirs: src, src-version, src-ag, src-options if !flag(bootstrap_external) hs-source-dirs: src-generated exposed-modules: UU.UUAGC, UU.UUAGC.Version extensions: TypeSynonymInstances, MultiParamTypeClasses other-modules: Paths_uuagc , Ag , CommonTypes , GrammarInfo , HsTokenScanner , Options , PPUtil , Parser , Pretty , Scanner , SequentialComputation , SequentialTypes , TokenDef , Version , AbstractSyntax , AbstractSyntaxDump , Code , CodeSyntax , CodeSyntaxDump , ConcreteSyntax , DeclBlocks , DefaultRules , Desugar , ErrorMessages , Expression , GenerateCode , HsToken , Interfaces , InterfacesRules , Order , Patterns , PrintCode , PrintOcamlCode , PrintVisitCode , PrintErrorMessages , SemHsTokens , Transform , ATermWrite , ATermAbstractSyntax , TfmToVisage , Visage , VisageSyntax , VisagePatterns , AG2AspectAG , Macro , RhsCheck , ResolveLocals , Knuth1 , KennedyWarren , KWOrder , ExecutionPlan , ExecutionPlan2Hs , ExecutionPlan2Caml uuagc-0.9.42.3/uuagc_options000644 000765 000024 00000010516 12127045231 017653 0ustar00jeroenbransenstaff000000 000000 file: "src-ag/AbstractSyntax.ag" options: module, pretty, data, genlinepragmas, checkParseHaskell file: "src-ag/ConcreteSyntax.ag" options: module, pretty, data, genlinepragmas, checkParseHaskell file: "src-ag/ErrorMessages.ag" options: module, pretty, data, genlinepragmas, checkParseHaskell file: "src-ag/HsToken.ag" options: module, pretty, data, genlinepragmas, checkParseHaskell file: "src-ag/Code.ag" options: module, pretty, data, genlinepragmas, checkParseHaskell file: "src-ag/Expression.ag" options: module, pretty, data, genlinepragmas, checkParseHaskell file: "src-ag/Patterns.ag" options: module, pretty, data, genlinepragmas, checkParseHaskell file: "src-ag/Interfaces.ag" options: module, pretty, data, genlinepragmas, checkParseHaskell file: "src-ag/CodeSyntax.ag" options: module, pretty, data, genlinepragmas, checkParseHaskell file: "src-ag/DeclBlocks.ag" options: module, pretty, data, genlinepragmas, checkParseHaskell file: "src-ag/VisageSyntax.ag" options: module, pretty, data, genlinepragmas, checkParseHaskell file: "src-ag/VisagePatterns.ag" options: module, pretty, data, genlinepragmas, checkParseHaskell file: "src-ag/ExecutionPlan.ag" options: module, pretty, data, genlinepragmas, checkParseHaskell file: "src-ag/Macro.ag" options: module, pretty, data, genlinepragmas, checkParseHaskell file: "src-ag/Desugar.ag" options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren, visit file: "src-ag/DefaultRules.ag" options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren, visit file: "src-ag/GenerateCode.ag" options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren file: "src-ag/PrintOcamlCode.ag" options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren file: "src-ag/PrintCode.ag" options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren file: "src-ag/PrintVisitCode.ag" options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren file: "src-ag/PrintErrorMessages.ag" options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren file: "src-ag/SemHsTokens.ag" options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren file: "src-ag/Transform.ag" options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren file: "src-ag/Order.ag" options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren file: "src-ag/KWOrder.ag" options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren file: "src-ag/ResolveLocals.ag" options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren file: "src-ag/AbstractSyntaxDump.ag" options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren file: "src-ag/CodeSyntaxDump.ag" options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren file: "src-ag/Visage.ag" options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren file: "src-ag/TfmToVisage.ag" options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren file: "src-ag/AG2AspectAG.ag" options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren file: "src-ag/ExecutionPlan2Hs.ag" options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren file: "src-ag/ExecutionPlan2Caml.ag" options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren file: "src-ag/InterfacesRules.lag" options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren uuagc-0.9.42.3/src-version/Version.hs000644 000765 000024 00000000755 12127045231 021310 0ustar00jeroenbransenstaff000000 000000 -- | This module is a placeholder. It it installed in combination with the UUAGC application, -- so that the uuagc-package shows up as an explicit dependency. -- -- Note: this is the Version.hs of the bootstrapped UUAG compiler. module Version where import UU.UUAGC.Version import Data.Version -- | Description of the application including the application's version number banner :: String banner = ("Attribute Grammar compiler / HUT project. Version " ++ showVersion version) uuagc-0.9.42.3/src-options/Options.hs000644 000765 000024 00000101006 12127045231 021313 0ustar00jeroenbransenstaff000000 000000 module Options where import System.Console.GetOpt import Data.Set(Set) import UU.Scanner.Position(Pos,noPos) import Data.List(intercalate) import qualified Data.Set as Set import System.IO import System.Exit -- From CommonTypes data Identifier = Ident { getName::String, getPos::Pos } type NontermIdent = Identifier identifier :: String -> Identifier identifier x = Ident x noPos instance Eq Identifier where Ident x _ == Ident y _ = x == y instance Ord Identifier where compare (Ident x _) (Ident y _) = compare x y instance Show Identifier where show ident = getName ident -- Make options serializable data MyOptDescr = MyOpt [Char] [String] (ArgDescr (Options -> Options)) (Options -> String -> [String]) String fromMyOpt :: MyOptDescr -> OptDescr (Options -> Options) fromMyOpt (MyOpt sh ln desc _ s) = Option sh ln desc s noOpt :: Options -> String -> [String] noOpt _ _ = [] boolOpt :: (Options -> Bool) -> Options -> String -> [String] boolOpt get opt strArg = let oldVal = get noOptions newVal = get opt in if oldVal /= newVal then [strArg] else [] stringOpt :: (Options -> String) -> Options -> String -> [String] stringOpt get opt strArg = let oldVal = get noOptions newVal = get opt in if oldVal /= newVal then [strArg, newVal] else [] mbStringOpt :: (Options -> Maybe String) -> Options -> String -> [String] mbStringOpt get opts nm = maybe [] (\s -> [nm++"="++s]) (get opts) serializeOption :: Options -> MyOptDescr -> [String] serializeOption opt (MyOpt sh ln _ get _) = get opt strArg where strArg = if null sh then '-' : '-' : head ln else '-' : head sh : [] -- All options allOptions :: [MyOptDescr] allOptions = [ MyOpt ['m'] [] (NoArg (moduleOpt Nothing)) noOpt "generate default module header" , MyOpt [] ["module"] (OptArg moduleOpt "name") moduleOptGet "generate module header, specify module name" , MyOpt ['d'] ["data"] (NoArg dataOpt) (boolOpt dataTypes) "generate data type definition" , MyOpt [] ["datarecords"] (NoArg dataRecOpt) (boolOpt dataRecords) "generate record data types" , MyOpt [] ["strictdata"] (NoArg strictDataOpt) (boolOpt strictData) "generate strict data fields (when data is generated)" , MyOpt [] ["strictwrap"] (NoArg strictWrapOpt) (boolOpt strictWrap) "generate strict wrap fields for WRAPPER generated data" , MyOpt ['c'] ["catas"] (NoArg cataOpt) (boolOpt folds) "generate catamorphisms" , MyOpt ['f'] ["semfuns"] (NoArg semfunsOpt) (boolOpt semfuns) "generate semantic functions" , MyOpt ['s'] ["signatures"] (NoArg signaturesOpt) (boolOpt typeSigs) "generate signatures for semantic functions" , MyOpt [] ["newtypes"] (NoArg newtypesOpt) (boolOpt newtypes) "use newtypes instead of type synonyms" , MyOpt ['p'] ["pretty"] (NoArg prettyOpt) (boolOpt attrInfo) "generate pretty printed list of attributes" , MyOpt ['w'] ["wrappers"] (NoArg wrappersOpt) (boolOpt wrappers) "generate wappers for semantic domains" , MyOpt ['r'] ["rename"] (NoArg renameOpt) (boolOpt rename) "rename data constructors" , MyOpt [] ["modcopy"] (NoArg modcopyOpt) (boolOpt modcopy) "use modified copy rule" , MyOpt [] ["nest"] (NoArg nestOpt) (boolOpt nest) "use nested tuples" , MyOpt [] ["syntaxmacro"] (NoArg smacroOpt) (boolOpt smacro) "experimental: generate syntax macro code (using knit catas)" , MyOpt ['o'] ["output"] (ReqArg outputOpt "file") outputOptGet "specify output file" , MyOpt ['v'] ["verbose"] (NoArg verboseOpt) (boolOpt verbose) "verbose error message format" , MyOpt ['h','?'] ["help"] (NoArg helpOpt) (boolOpt showHelp) "get (this) usage information" , MyOpt ['a'] ["all"] (NoArg allOpt) noOpt ("do everything (-" ++ allc ++ ")") , MyOpt ['P'] [""] (ReqArg searchPathOpt "search path") searchPathOptGet ("specify seach path") , MyOpt [] ["prefix"] (ReqArg prefixOpt "prefix") (stringOpt prefix) "set prefix for semantic functions" , MyOpt [] ["self"] (NoArg selfOpt) (boolOpt withSelf) "generate self attribute" , MyOpt [] ["cycle"] (NoArg cycleOpt) (boolOpt withCycle) "check for cyclic definitions" , MyOpt [] ["version"] (NoArg versionOpt) (boolOpt showVersion) "get version information" , MyOpt ['O'] ["optimize"] (NoArg optimizeOpt) noOpt "optimize generated code (--visit --case)" , MyOpt [] ["visit"] (NoArg visitOpt) (boolOpt visit) "try generating visit functions" , MyOpt [] ["seq"] (NoArg seqOpt) (boolOpt withSeq) "force evaluation using function seq (visit functions only)" , MyOpt [] ["unbox"] (NoArg unboxOpt) (boolOpt unbox) "use unboxed tuples" , MyOpt [] ["bangpats"] (NoArg bangpatsOpt) (boolOpt bangpats) "use bang patterns (visit functions only)" , MyOpt [] ["case"] (NoArg casesOpt) (boolOpt cases) "Use nested cases instead of let (visit functions only)" , MyOpt [] ["strictcase"] (NoArg strictCasesOpt) (boolOpt strictCases) "Force evaluation of the scrutinee of cases (in generated code, visit functions only)" , MyOpt [] ["strictercase"] (NoArg stricterCasesOpt) (boolOpt stricterCases) "Force evaluation of all variables bound by a case statement (in generated code)" , MyOpt [] ["strictsem"] (NoArg strictSemOpt) (boolOpt strictSems) "Force evaluation of sem-function arguments (in generated code)" , MyOpt [] ["localcps"] (NoArg localCpsOpt) (boolOpt localCps) "Apply a local CPS transformation (in generated code, visit functions only)" , MyOpt [] ["splitsems"] (NoArg splitSemsOpt) (boolOpt splitSems) "Split semantic functions into smaller pieces" , MyOpt [] ["Werrors"] (NoArg werrorsOpt) (boolOpt werrors) "Turn warnings into fatal errors" , MyOpt [] ["Wignore"] (NoArg wignoreOpt) (boolOpt wignore) "Ignore warnings" , MyOpt [] ["Wmax"] (ReqArg wmaxErrsOpt "") wmaxErrsOptGet "Sets the maximum number of errors that are reported" , MyOpt [] ["dumpgrammar"] (NoArg dumpgrammarOpt) (boolOpt dumpgrammar) "Dump internal grammar representation (in generated code)" , MyOpt [] ["dumpcgrammar"] (NoArg dumpcgrammarOpt) (boolOpt dumpcgrammar)"Dump internal cgrammar representation (in generated code)" , MyOpt [] ["gentraces"] (NoArg genTracesOpt) (boolOpt genTraces) "Generate trace expressions (in generated code)" , MyOpt [] ["genusetraces"] (NoArg genUseTracesOpt) (boolOpt genUseTraces)"Generate trace expressions at attribute use sites (in generated code)" , MyOpt [] ["gencostcentres"] (NoArg genCostCentresOpt) (boolOpt genCostCentres) "Generate cost centre pragmas (in generated code)" , MyOpt [] ["genlinepragmas"] (NoArg genLinePragmasOpt) (boolOpt genLinePragmas) "Generate GHC LINE pragmas (in generated code)" , MyOpt [] ["sepsemmods"] (NoArg sepSemModsOpt) (boolOpt sepSemMods) "Generate separate modules for semantic functions (in generated code)" , MyOpt ['M'] ["genfiledeps"] (NoArg genFileDepsOpt) (boolOpt genFileDeps) "Generate a list of dependencies on the input AG files" , MyOpt [] ["genvisage"] (NoArg genVisageOpt) (boolOpt genvisage) "Generate output for the AG visualizer Visage" , MyOpt [] ["aspectag"] (NoArg genAspectAGOpt) (boolOpt genAspectAG) "Generate AspectAG file" , MyOpt [] ["nogroup"] (ReqArg noGroupOpt "attributes") noGroupOptGet "specify the attributes that won't be grouped in AspectAG" , MyOpt [] ["extends"] (ReqArg extendsOpt "module") (mbStringOpt extends) "specify a module to be extended" , MyOpt [] ["genattrlist"] (NoArg genAttrListOpt) (boolOpt genAttributeList) "Generate a list of all explicitly defined attributes (outside irrefutable patterns)" , MyOpt [] ["forceirrefutable"] (OptArg forceIrrefutableOpt "file") (mbStringOpt forceIrrefutables) "Force a set of explicitly defined attributes to be irrefutable, specify file containing the attribute set" , MyOpt [] ["uniquedispenser"] (ReqArg uniqueDispenserOpt "name") (stringOpt uniqueDispenser) "The Haskell function to call in the generated code" , MyOpt [] ["lckeywords"] (NoArg lcKeywordsOpt) (boolOpt lcKeywords) "Use lowercase keywords (sem, attr) instead of the uppercase ones (SEM, ATTR)" , MyOpt [] ["doublecolons"] (NoArg doubleColonsOpt) (boolOpt doubleColons)"Use double colons for type signatures instead of single colons" , MyOpt ['H'] ["haskellsyntax"] (NoArg haskellSyntaxOpt) noOpt "Use Haskell like syntax (equivalent to --lckeywords and --doublecolons --genlinepragmas)" , MyOpt [] ["reference"] (NoArg referenceOpt) (boolOpt reference) "Use reference attributes" , MyOpt [] ["monadic"] (NoArg monadicOpt) (boolOpt monadic) "Experimental: generate monadic code" , MyOpt [] ["ocaml"] (NoArg ocamlOpt) (boolOpt ocaml) "Generate Ocaml code" , MyOpt [] ["breadthfirst"] (NoArg breadthfirstOpt) (boolOpt breadthFirst)"Experimental: generate breadth-first code" , MyOpt [] ["breadthfirst-strict"] (NoArg breadthfirstStrictOpt) (boolOpt breadthFirstStrict) "Experimental: outermost breadth-first evaluator is strict instead of lazy" , MyOpt [] ["visitcode"] (NoArg visitorsOutputOpt) (boolOpt visitorsOutput) "Experimental: generate visitors code" , MyOpt [] ["kennedywarren"] (NoArg kennedyWarrenOpt) (boolOpt kennedyWarren) "Experimental: use Kennedy-Warren's algorithm for ordering" , MyOpt [] ["statistics"] (ReqArg statisticsOpt "FILE to append to") (mbStringOpt statsFile) "Append statistics to FILE" , MyOpt [] ["checkParseRhs"] (NoArg parseHsRhsOpt) (boolOpt checkParseRhs) "Parse RHS of rules with Haskell parser" , MyOpt [] ["checkParseTys"] (NoArg parseHsTpOpt) (boolOpt checkParseTy) "Parse types of attrs with Haskell parser" , MyOpt [] ["checkParseBlocks"] (NoArg parseHsBlockOpt) (boolOpt checkParseBlock) "Parse blocks with Haskell parser" , MyOpt [] ["checkParseHaskell"] (NoArg parseHsOpt) noOpt "Parse Haskell code (recognizer)" , MyOpt [] ["nocatas"] (ReqArg nocatasOpt "list of nonterms") nocatasOptGet "Nonterminals not to generate catas for" , MyOpt [] ["nooptimize"] (NoArg noOptimizeOpt) (boolOpt noOptimizations) "Disable optimizations" , MyOpt [] ["parallel"] (NoArg parallelOpt) (boolOpt parallelInvoke) "Generate a parallel evaluator (if possible)" , MyOpt [] ["monadicwrapper"] (NoArg monadicWrappersOpt) (boolOpt monadicWrappers) "Generate monadic wrappers" , MyOpt [] ["helpinlining"] (NoArg helpInliningOpt) (boolOpt helpInlining) "Generate inline directives for GHC" , MyOpt [] ["dummytokenvisit"] (NoArg dummyTokenVisitOpt) (boolOpt dummyTokenVisit) "Add an additional dummy parameter to visit functions" , MyOpt [] ["tupleasdummytoken"] (NoArg tupleAsDummyTokenOpt) (boolOpt tupleAsDummyToken) "Use conventional tuples as dummy parameter instead of a RealWorld state token" , MyOpt [] ["stateasdummytoken"] (NoArg stateAsDummyTokenOpt) noOpt "Use RealWorld state token as dummy parameter instead of conventional tuples (default)" , MyOpt [] ["strictdummytoken"] (NoArg strictDummyTokenOpt) (boolOpt strictDummyToken) "Strictify the dummy token that makes states and rules functions" , MyOpt [] ["noperruletypesigs"] (NoArg noPerRuleTypeSigsOpt) (boolOpt noPerRuleTypeSigs) "Do not generate type sigs for attrs passed to rules" , MyOpt [] ["noperstatetypesigs"] (NoArg noPerStateTypeSigsOpt) (boolOpt noPerStateTypeSigs) "Do not generate type sigs for attrs saved in node states" , MyOpt [] ["noeagerblackholing"] (NoArg noEagerBlackholingOpt) (boolOpt noEagerBlackholing) "Do not automatically add the eager blackholing feature for parallel programs" , MyOpt [] ["noperrulecostcentres"] (NoArg noPerRuleCostCentresOpt) (boolOpt noPerRuleCostCentres) "Do not generate cost centres for rules" , MyOpt [] ["nopervisitcostcentres"] (NoArg noPerVisitCostCentresOpt) (boolOpt noPerVisitCostCentres) "Do not generate cost centres for visits" , MyOpt [] ["noinlinepragmas"] (NoArg noInlinePragmasOpt) (boolOpt noInlinePragmas) "Definitely not generate inline directives" , MyOpt [] ["aggressiveinlinepragmas"] (NoArg aggressiveInlinePragmasOpt) (boolOpt aggressiveInlinePragmas) "Generate more aggressive inline directives" , MyOpt [] ["latehigherorderbinding"] (NoArg lateHigherOrderBindingOpt) (boolOpt lateHigherOrderBinding) "Generate an attribute and wrapper for late binding of higher-order attributes" , MyOpt [] ["noincludes"] (NoArg noIncludesOpt) (boolOpt noIncludes) "Ignore include directives in .ag files" , MyOpt [] ["quiet"] (NoArg beQuietOpt) (boolOpt beQuiet) "Dont print some compilation information" ] -- For compatibility options :: [OptDescr (Options -> Options)] options = map fromMyOpt allOptions allc :: String allc = "dcfsprm" data ModuleHeader = NoName | Name String | Default deriving (Eq, Show) data Options = Options{ moduleName :: ModuleHeader , dataTypes :: Bool , dataRecords :: Bool , strictData :: Bool , strictWrap :: Bool , folds :: Bool , semfuns :: Bool , typeSigs :: Bool , attrInfo :: Bool , rename :: Bool , wrappers :: Bool , modcopy :: Bool , newtypes :: Bool , nest :: Bool , smacro :: Bool , outputFiles :: [String] , searchPath :: [String] , verbose :: Bool , prefix :: String , withSelf :: Bool , withCycle :: Bool , showHelp :: Bool , showVersion :: Bool , visit :: Bool , withSeq :: Bool , unbox :: Bool , bangpats :: Bool , cases :: Bool , strictCases :: Bool , stricterCases :: Bool , strictSems :: Bool , localCps :: Bool , splitSems :: Bool , werrors :: Bool , wignore :: Bool , wmaxerrs :: Int , dumpgrammar :: Bool , dumpcgrammar :: Bool , sepSemMods :: Bool , allowSepSemMods :: Bool , genFileDeps :: Bool , genLinePragmas :: Bool , genvisage :: Bool , genAspectAG :: Bool , noGroup :: [String] , extends :: Maybe String , genAttributeList :: Bool , forceIrrefutables :: Maybe String , uniqueDispenser :: String , lcKeywords :: Bool , doubleColons :: Bool , monadic :: Bool , ocaml :: Bool , visitorsOutput :: Bool , statsFile :: Maybe String , breadthFirst :: Bool , breadthFirstStrict :: Bool , checkParseRhs :: Bool , checkParseTy :: Bool , checkParseBlock :: Bool , nocatas :: Set NontermIdent , noOptimizations :: Bool , reference :: Bool , noIncludes :: Bool , outputStr :: String -> IO () , failWithCode :: Int -> IO () , mainFilename :: Maybe String , beQuiet :: Bool -- KW code path , kennedyWarren :: Bool , parallelInvoke :: Bool , tupleAsDummyToken :: Bool -- use the empty tuple as dummy token instead of State# RealWorld (Lambda State Hack GHC?) , dummyTokenVisit :: Bool -- add a dummy argument/pass dummy extra token to visits (should not really have an effect ... Lambda State Hack GHC?) , strictDummyToken :: Bool -- make the dummy token strict (to prevent its removal -- should not really have an effect) , noPerRuleTypeSigs :: Bool -- do not print type signatures for attributes of rules , noPerStateTypeSigs :: Bool -- do not print type signatures for attributes contained in the state , noEagerBlackholing :: Bool -- disable the use of eager black holing in the parallel evaluator code , lateHigherOrderBinding :: Bool -- generate code to allow late binding of higher-order children semantics , monadicWrappers :: Bool -- tracing , genTraces :: Bool , genUseTraces :: Bool , genCostCentres :: Bool , noPerRuleCostCentres :: Bool , noPerVisitCostCentres :: Bool -- inline pragma generation , helpInlining :: Bool , noInlinePragmas :: Bool , aggressiveInlinePragmas :: Bool } -- deriving (Eq, Show) noOptions :: Options noOptions = Options { moduleName = NoName , dataTypes = False , dataRecords = False , strictData = False , strictWrap = False , folds = False , semfuns = False , typeSigs = False , attrInfo = False , rename = False , wrappers = False , modcopy = False , newtypes = False , nest = False , smacro = False , outputFiles = [] , searchPath = [] , verbose = False , showHelp = False , showVersion = False , prefix = "sem_" , withSelf = False , withCycle = False , visit = False , withSeq = False , unbox = False , bangpats = False , cases = False , strictCases = False , stricterCases = False , strictSems = False , localCps = False , splitSems = False , werrors = False , wignore = False , wmaxerrs = 99999 , dumpgrammar = False , dumpcgrammar = False , sepSemMods = False , allowSepSemMods = True , genFileDeps = False , genLinePragmas = False , genvisage = False , genAspectAG = False , noGroup = [] , extends = Nothing , genAttributeList = False , forceIrrefutables = Nothing , uniqueDispenser = "nextUnique" , lcKeywords = False , doubleColons = False , monadic = False , ocaml = False , visitorsOutput = False , statsFile = Nothing , breadthFirst = False , breadthFirstStrict = False , checkParseRhs = False , checkParseTy = False , checkParseBlock = False , nocatas = Set.empty , noOptimizations = False , reference = False , noIncludes = False , outputStr = hPutStr stderr , failWithCode = exitWith . ExitFailure , mainFilename = Nothing , beQuiet = False -- defaults for the KW-code path , kennedyWarren = False , parallelInvoke = False , tupleAsDummyToken = True , dummyTokenVisit = False , strictDummyToken = False , noPerRuleTypeSigs = False , noPerStateTypeSigs = False , noEagerBlackholing = False , lateHigherOrderBinding = False , monadicWrappers = False -- defaults for tracing , genTraces = False , genUseTraces = False , genCostCentres = False , noPerRuleCostCentres = False , noPerVisitCostCentres = False -- defaults for inline pragma generation , helpInlining = False , noInlinePragmas = False , aggressiveInlinePragmas = False } --Options -> String -> [String] moduleOpt :: Maybe String -> Options -> Options moduleOpt nm opts = opts{moduleName = maybe Default Name nm} moduleOptGet :: Options -> String -> [String] moduleOptGet opts nm = case moduleName opts of NoName -> [] Name s -> [nm++"="++s] Default -> [nm] dataOpt, dataRecOpt, strictDataOpt, strictWrapOpt, cataOpt, semfunsOpt, signaturesOpt, prettyOpt,renameOpt, wrappersOpt, modcopyOpt, newtypesOpt, nestOpt, smacroOpt, verboseOpt, helpOpt, versionOpt, selfOpt, cycleOpt, visitOpt, seqOpt, unboxOpt, bangpatsOpt, casesOpt, strictCasesOpt, stricterCasesOpt, strictSemOpt, localCpsOpt, splitSemsOpt, werrorsOpt, wignoreOpt, dumpgrammarOpt, dumpcgrammarOpt, genTracesOpt, genUseTracesOpt, genCostCentresOpt, sepSemModsOpt, genFileDepsOpt, genLinePragmasOpt, genVisageOpt, genAspectAGOpt, dummyTokenVisitOpt, tupleAsDummyTokenOpt, stateAsDummyTokenOpt, strictDummyTokenOpt, noPerRuleTypeSigsOpt, noPerStateTypeSigsOpt, noEagerBlackholingOpt, noPerRuleCostCentresOpt, noPerVisitCostCentresOpt, helpInliningOpt, noInlinePragmasOpt, aggressiveInlinePragmasOpt, lateHigherOrderBindingOpt, monadicWrappersOpt, referenceOpt, genAttrListOpt, lcKeywordsOpt, doubleColonsOpt, haskellSyntaxOpt, monadicOpt, parallelOpt, ocamlOpt, visitorsOutputOpt, breadthfirstOpt, breadthfirstStrictOpt, parseHsRhsOpt, parseHsTpOpt, parseHsBlockOpt, parseHsOpt, kennedyWarrenOpt, noOptimizeOpt, allOpt, optimizeOpt, noIncludesOpt, beQuietOpt, condDisableOptimizations :: Options -> Options dataOpt opts = opts{dataTypes = True} dataRecOpt opts = opts{dataRecords = True} strictDataOpt opts = opts{strictData = True} strictWrapOpt opts = opts{strictWrap = True} cataOpt opts = opts{folds = True} semfunsOpt opts = opts{semfuns = True} signaturesOpt opts = opts{typeSigs = True} prettyOpt opts = opts{attrInfo = True} renameOpt opts = opts{rename = True} wrappersOpt opts = opts{wrappers = True} modcopyOpt opts = opts{modcopy = True} newtypesOpt opts = opts{newtypes = True} nestOpt opts = opts{nest = True} smacroOpt opts = opts{smacro = True} verboseOpt opts = opts{verbose = True} helpOpt opts = opts{showHelp = True} versionOpt opts = opts{showVersion = True} prefixOpt :: String -> Options -> Options prefixOpt pre opts = opts{prefix = pre } selfOpt opts = opts{withSelf = True} cycleOpt opts = opts{withCycle = True} visitOpt opts = opts{visit = True, withCycle = True} seqOpt opts = opts{withSeq = True} unboxOpt opts = opts{unbox = True} bangpatsOpt opts = opts{bangpats = True} casesOpt opts = opts{cases = True} strictCasesOpt opts = opts{strictCases = True} stricterCasesOpt opts = opts{strictCases = True, stricterCases = True} strictSemOpt opts = opts{strictSems = True} localCpsOpt opts = opts{localCps = True} splitSemsOpt opts = opts{splitSems = True} werrorsOpt opts = opts{werrors = True} wignoreOpt opts = opts{wignore = True} wmaxErrsOpt :: String -> Options -> Options wmaxErrsOpt n opts = opts{wmaxerrs = read n} wmaxErrsOptGet :: Options -> String -> [String] wmaxErrsOptGet opts nm = if wmaxerrs opts /= wmaxerrs noOptions then [nm,show (wmaxerrs opts)] else [] dumpgrammarOpt opts = opts{dumpgrammar = True} dumpcgrammarOpt opts = opts{dumpcgrammar = True} genTracesOpt opts = opts{genTraces = True} genUseTracesOpt opts = opts{genUseTraces = True} genCostCentresOpt opts = opts{genCostCentres = True} sepSemModsOpt opts = opts{sepSemMods = allowSepSemMods opts} genFileDepsOpt opts = opts{genFileDeps = True} genLinePragmasOpt opts = opts{genLinePragmas = True} genVisageOpt opts = opts{genvisage = True } genAspectAGOpt opts = opts{genAspectAG = True} dummyTokenVisitOpt opts = opts { dummyTokenVisit = True } tupleAsDummyTokenOpt opts = opts { tupleAsDummyToken = True } stateAsDummyTokenOpt opts = opts { tupleAsDummyToken = False } strictDummyTokenOpt opts = opts { strictDummyToken = True } noPerRuleTypeSigsOpt opts = opts { noPerRuleTypeSigs = True } noPerStateTypeSigsOpt opts = opts { noPerStateTypeSigs = True } noEagerBlackholingOpt opts = opts { noEagerBlackholing = True } noPerRuleCostCentresOpt opts = opts { noPerRuleCostCentres = True } noPerVisitCostCentresOpt opts = opts { noPerVisitCostCentres = True } helpInliningOpt opts = opts { helpInlining = True } noInlinePragmasOpt opts = opts { noInlinePragmas = True } aggressiveInlinePragmasOpt opts = opts { aggressiveInlinePragmas = True } lateHigherOrderBindingOpt opts = opts { lateHigherOrderBinding = True } monadicWrappersOpt opts = opts { monadicWrappers = True } referenceOpt opts = opts { reference = True } noGroupOpt :: String -> Options -> Options noGroupOpt att opts = opts{noGroup = wordsBy (== ':') att ++ noGroup opts} noGroupOptGet :: Options -> String -> [String] noGroupOptGet opts nm = if null (noGroup opts) then [] else [nm, intercalate ":" (noGroup opts)] extendsOpt :: String -> Options -> Options extendsOpt m opts = opts{extends = Just m } genAttrListOpt opts = opts { genAttributeList = True } forceIrrefutableOpt :: Maybe String -> Options -> Options forceIrrefutableOpt mbNm opts = opts { forceIrrefutables = mbNm } uniqueDispenserOpt :: String -> Options -> Options uniqueDispenserOpt nm opts = opts { uniqueDispenser = nm } lcKeywordsOpt opts = opts { lcKeywords = True } doubleColonsOpt opts = opts { doubleColons = True } haskellSyntaxOpt = lcKeywordsOpt . doubleColonsOpt . genLinePragmasOpt monadicOpt opts = opts { monadic = True } parallelOpt opts = opts { parallelInvoke = True } ocamlOpt opts = opts { ocaml = True, kennedyWarren = True, withCycle = True, visit = True } visitorsOutputOpt opts = opts { visitorsOutput = True } statisticsOpt :: String -> Options -> Options statisticsOpt nm opts = opts { statsFile = Just nm } breadthfirstOpt opts = opts { breadthFirst = True } breadthfirstStrictOpt opts = opts { breadthFirstStrict = True } parseHsRhsOpt opts = opts { checkParseRhs = True } parseHsTpOpt opts = opts { checkParseTy = True } parseHsBlockOpt opts = opts { checkParseBlock = True } parseHsOpt = parseHsRhsOpt . parseHsTpOpt . parseHsBlockOpt kennedyWarrenOpt opts = opts { kennedyWarren = True } noOptimizeOpt opts = opts { noOptimizations = True } nocatasOpt :: String -> Options -> Options nocatasOpt str opts = opts { nocatas = set `Set.union` nocatas opts } where set = Set.fromList ids ids = map identifier lst lst = wordsBy (== ',') str nocatasOptGet :: Options -> String -> [String] nocatasOptGet opts nm = if Set.null (nocatas opts) then [] else [nm,intercalate "," . map getName . Set.toList . nocatas $ opts] outputOpt :: String -> Options -> Options outputOpt file opts = opts{outputFiles = file : outputFiles opts} outputOptGet :: Options -> String -> [String] outputOptGet opts nm = concat [ [nm, file] | file <- outputFiles opts] searchPathOpt :: String -> Options -> Options searchPathOpt path opts = opts{searchPath = wordsBy (\x -> x == ';' || x == ':') path ++ searchPath opts} searchPathOptGet :: Options -> String -> [String] searchPathOptGet opts nm = if null (searchPath opts) then [] else [nm, intercalate ":" (searchPath opts)] allOpt = moduleOpt Nothing . dataOpt . cataOpt . semfunsOpt . signaturesOpt . prettyOpt . renameOpt . dataRecOpt optimizeOpt = visitOpt . casesOpt noIncludesOpt opts = opts { noIncludes = True } beQuietOpt opts = opts { beQuiet = True } condDisableOptimizations opts | noOptimizations opts = opts { strictData = False , strictWrap = False , withSeq = False , unbox = False , bangpats = False , cases = False , strictCases = False , stricterCases = False , strictSems = False , localCps = False , splitSems = False , breadthFirstStrict = False } | otherwise = opts -- | Inverse of intercalate wordsBy :: (Char -> Bool) -> String -> [String] wordsBy p = f where f s = let (x,xs) = break p s in if null x then [] else x : f (drop 1 xs) -- | Use all parsed options to generate real options constructOptions :: [Options -> Options] -> Options constructOptions = foldl (flip ($)) noOptions -- | Create Options type from string arguments getOptions :: [String] -> (Options,[String],[String]) getOptions args = let (flags,files,errors) = getOpt Permute options args appliedOpts = constructOptions flags finOpts = condDisableOptimizations appliedOpts in (finOpts,files,errors) -- | Convert options back to commandline string optionsToString :: Options -> [String] optionsToString opt = concatMap (serializeOption opt) allOptions -- | Combine 2 sets of options combineOptions :: Options -> Options -> Options combineOptions o1 o2 = let str1 = optionsToString o1 str2 = optionsToString o2 (opt,_,_) = getOptions (str1 ++ str2) in optuuagc-0.9.42.3/src-main/Main.hs000644 000765 000024 00000000116 12127045231 017775 0ustar00jeroenbransenstaff000000 000000 module Main where import UU.UUAGC (uuagcMain) main :: IO () main = uuagcMainuuagc-0.9.42.3/src-generated/AbstractSyntax.hs000644 000765 000024 00000012040 12127045231 023074 0ustar00jeroenbransenstaff000000 000000 -- UUAGC 0.9.42.3 (src-ag/AbstractSyntax.ag) module AbstractSyntax where {-# LINE 2 "./src-ag/AbstractSyntax.ag" #-} -- 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 {-# LINE 16 "dist/build/AbstractSyntax.hs" #-} -- Child ------------------------------------------------------- {- alternatives: alternative Child: child name : {Identifier} child tp : {Type} child kind : {ChildKind} -} data Child = Child (Identifier) (Type) (ChildKind) -- Children ---------------------------------------------------- {- alternatives: alternative Cons: child hd : Child child tl : Children alternative Nil: -} type Children = [Child] -- Grammar ----------------------------------------------------- {- alternatives: alternative Grammar: child typeSyns : {TypeSyns} child useMap : {UseMap} child derivings : {Derivings} child wrappers : {Set NontermIdent} child nonts : Nonterminals child pragmas : {PragmaMap} child manualAttrOrderMap : {AttrOrderMap} child paramMap : {ParamMap} child contextMap : {ContextMap} child quantMap : {QuantMap} child uniqueMap : {UniqueMap} child augmentsMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} child aroundsMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} child mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression)))} -} data Grammar = Grammar (TypeSyns) (UseMap) (Derivings) ((Set NontermIdent)) (Nonterminals) (PragmaMap) (AttrOrderMap) (ParamMap) (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))))) -- Nonterminal ------------------------------------------------- {- alternatives: alternative Nonterminal: child nt : {NontermIdent} child params : {[Identifier]} child inh : {Attributes} child syn : {Attributes} child prods : Productions -} data Nonterminal = Nonterminal (NontermIdent) (([Identifier])) (Attributes) (Attributes) (Productions) -- Nonterminals ------------------------------------------------ {- alternatives: alternative Cons: child hd : Nonterminal child tl : Nonterminals alternative Nil: -} type Nonterminals = [Nonterminal] -- Production -------------------------------------------------- {- alternatives: alternative Production: child con : {ConstructorIdent} child params : {[Identifier]} child constraints : {[Type]} child children : Children child rules : Rules child typeSigs : TypeSigs child macro : {MaybeMacro} -} data Production = Production (ConstructorIdent) (([Identifier])) (([Type])) (Children) (Rules) (TypeSigs) (MaybeMacro) -- Productions ------------------------------------------------- {- alternatives: alternative Cons: child hd : Production child tl : Productions alternative Nil: -} type Productions = [Production] -- Rule -------------------------------------------------------- {- alternatives: alternative Rule: child mbName : {Maybe Identifier} child pattern : {Pattern} child rhs : {Expression} child owrt : {Bool} child origin : {String} child explicit : {Bool} child pure : {Bool} child identity : {Bool} child mbError : {Maybe Error} child eager : {Bool} -} data Rule = Rule ((Maybe Identifier)) (Pattern) (Expression) (Bool) (String) (Bool) (Bool) (Bool) ((Maybe Error)) (Bool) -- Rules ------------------------------------------------------- {- alternatives: alternative Cons: child hd : Rule child tl : Rules alternative Nil: -} type Rules = [Rule] -- TypeSig ----------------------------------------------------- {- alternatives: alternative TypeSig: child name : {Identifier} child tp : {Type} -} data TypeSig = TypeSig (Identifier) (Type) -- TypeSigs ---------------------------------------------------- {- alternatives: alternative Cons: child hd : TypeSig child tl : TypeSigs alternative Nil: -} type TypeSigs = [TypeSig]uuagc-0.9.42.3/src-generated/AbstractSyntaxDump.hs000644 000765 000024 00000143452 12127045231 023736 0ustar00jeroenbransenstaff000000 000000 {-# LANGUAGE Rank2Types, GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} module AbstractSyntaxDump where {-# LINE 2 "./src-ag/AbstractSyntax.ag" #-} -- 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 {-# LINE 16 "dist/build/AbstractSyntaxDump.hs" #-} {-# LINE 2 "./src-ag/Patterns.ag" #-} -- Patterns.ag imports import UU.Scanner.Position(Pos) import CommonTypes (ConstructorIdent,Identifier) {-# LINE 23 "dist/build/AbstractSyntaxDump.hs" #-} {-# LINE 2 "./src-ag/Expression.ag" #-} import UU.Scanner.Position(Pos) import HsToken {-# LINE 29 "dist/build/AbstractSyntaxDump.hs" #-} {-# LINE 6 "./src-ag/AbstractSyntaxDump.ag" #-} import Data.List import qualified Data.Map as Map import Pretty import PPUtil import AbstractSyntax import TokenDef {-# LINE 41 "dist/build/AbstractSyntaxDump.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity -- Child ------------------------------------------------------- -- wrapper data Inh_Child = Inh_Child { } data Syn_Child = Syn_Child { pp_Syn_Child :: (PP_Doc) } {-# INLINABLE wrap_Child #-} wrap_Child :: T_Child -> Inh_Child -> (Syn_Child ) wrap_Child (T_Child act) (Inh_Child ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Child_vIn1 (T_Child_vOut1 _lhsOpp) <- return (inv_Child_s2 sem arg) return (Syn_Child _lhsOpp) ) -- cata {-# INLINE sem_Child #-} sem_Child :: Child -> T_Child sem_Child ( Child name_ tp_ kind_ ) = sem_Child_Child name_ tp_ kind_ -- semantic domain newtype T_Child = T_Child { attach_T_Child :: Identity (T_Child_s2 ) } newtype T_Child_s2 = C_Child_s2 { inv_Child_s2 :: (T_Child_v1 ) } data T_Child_s3 = C_Child_s3 type T_Child_v1 = (T_Child_vIn1 ) -> (T_Child_vOut1 ) data T_Child_vIn1 = T_Child_vIn1 data T_Child_vOut1 = T_Child_vOut1 (PP_Doc) {-# NOINLINE sem_Child_Child #-} sem_Child_Child :: (Identifier) -> (Type) -> (ChildKind) -> T_Child sem_Child_Child arg_name_ arg_tp_ arg_kind_ = T_Child (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Child_v1 v1 = \ (T_Child_vIn1 ) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule0 arg_kind_ arg_name_ arg_tp_ __result_ = T_Child_vOut1 _lhsOpp in __result_ ) in C_Child_s2 v1 {-# INLINE rule0 #-} {-# LINE 35 "./src-ag/AbstractSyntaxDump.ag" #-} rule0 = \ kind_ name_ tp_ -> {-# LINE 35 "./src-ag/AbstractSyntaxDump.ag" #-} ppNestInfo ["Child","Child"] [pp name_, ppShow tp_] [ppF "kind" $ ppShow kind_] [] {-# LINE 91 "dist/build/AbstractSyntaxDump.hs"#-} -- Children ---------------------------------------------------- -- wrapper data Inh_Children = Inh_Children { } data Syn_Children = Syn_Children { pp_Syn_Children :: (PP_Doc), ppL_Syn_Children :: ([PP_Doc]) } {-# INLINABLE wrap_Children #-} wrap_Children :: T_Children -> Inh_Children -> (Syn_Children ) wrap_Children (T_Children act) (Inh_Children ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Children_vIn4 (T_Children_vOut4 _lhsOpp _lhsOppL) <- return (inv_Children_s5 sem arg) return (Syn_Children _lhsOpp _lhsOppL) ) -- cata {-# NOINLINE sem_Children #-} sem_Children :: Children -> T_Children sem_Children list = Prelude.foldr sem_Children_Cons sem_Children_Nil (Prelude.map sem_Child list) -- semantic domain newtype T_Children = T_Children { attach_T_Children :: Identity (T_Children_s5 ) } newtype T_Children_s5 = C_Children_s5 { inv_Children_s5 :: (T_Children_v4 ) } data T_Children_s6 = C_Children_s6 type T_Children_v4 = (T_Children_vIn4 ) -> (T_Children_vOut4 ) data T_Children_vIn4 = T_Children_vIn4 data T_Children_vOut4 = T_Children_vOut4 (PP_Doc) ([PP_Doc]) {-# NOINLINE sem_Children_Cons #-} sem_Children_Cons :: T_Child -> T_Children -> T_Children sem_Children_Cons arg_hd_ arg_tl_ = T_Children (return st5) where {-# NOINLINE st5 #-} st5 = let v4 :: T_Children_v4 v4 = \ (T_Children_vIn4 ) -> ( let _hdX2 = Control.Monad.Identity.runIdentity (attach_T_Child (arg_hd_)) _tlX5 = Control.Monad.Identity.runIdentity (attach_T_Children (arg_tl_)) (T_Child_vOut1 _hdIpp) = inv_Child_s2 _hdX2 (T_Child_vIn1 ) (T_Children_vOut4 _tlIpp _tlIppL) = inv_Children_s5 _tlX5 (T_Children_vIn4 ) _lhsOppL :: [PP_Doc] _lhsOppL = rule1 _hdIpp _tlIppL _lhsOpp :: PP_Doc _lhsOpp = rule2 _hdIpp _tlIpp __result_ = T_Children_vOut4 _lhsOpp _lhsOppL in __result_ ) in C_Children_s5 v4 {-# INLINE rule1 #-} {-# LINE 67 "./src-ag/AbstractSyntaxDump.ag" #-} rule1 = \ ((_hdIpp) :: PP_Doc) ((_tlIppL) :: [PP_Doc]) -> {-# LINE 67 "./src-ag/AbstractSyntaxDump.ag" #-} _hdIpp : _tlIppL {-# LINE 146 "dist/build/AbstractSyntaxDump.hs"#-} {-# INLINE rule2 #-} rule2 = \ ((_hdIpp) :: PP_Doc) ((_tlIpp) :: PP_Doc) -> _hdIpp >-< _tlIpp {-# NOINLINE sem_Children_Nil #-} sem_Children_Nil :: T_Children sem_Children_Nil = T_Children (return st5) where {-# NOINLINE st5 #-} st5 = let v4 :: T_Children_v4 v4 = \ (T_Children_vIn4 ) -> ( let _lhsOppL :: [PP_Doc] _lhsOppL = rule3 () _lhsOpp :: PP_Doc _lhsOpp = rule4 () __result_ = T_Children_vOut4 _lhsOpp _lhsOppL in __result_ ) in C_Children_s5 v4 {-# INLINE rule3 #-} {-# LINE 68 "./src-ag/AbstractSyntaxDump.ag" #-} rule3 = \ (_ :: ()) -> {-# LINE 68 "./src-ag/AbstractSyntaxDump.ag" #-} [] {-# LINE 169 "dist/build/AbstractSyntaxDump.hs"#-} {-# INLINE rule4 #-} rule4 = \ (_ :: ()) -> empty -- Expression -------------------------------------------------- -- wrapper data Inh_Expression = Inh_Expression { } data Syn_Expression = Syn_Expression { pp_Syn_Expression :: (PP_Doc) } {-# INLINABLE wrap_Expression #-} wrap_Expression :: T_Expression -> Inh_Expression -> (Syn_Expression ) wrap_Expression (T_Expression act) (Inh_Expression ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Expression_vIn7 (T_Expression_vOut7 _lhsOpp) <- return (inv_Expression_s8 sem arg) return (Syn_Expression _lhsOpp) ) -- cata {-# INLINE sem_Expression #-} sem_Expression :: Expression -> T_Expression sem_Expression ( Expression pos_ tks_ ) = sem_Expression_Expression pos_ tks_ -- semantic domain newtype T_Expression = T_Expression { attach_T_Expression :: Identity (T_Expression_s8 ) } newtype T_Expression_s8 = C_Expression_s8 { inv_Expression_s8 :: (T_Expression_v7 ) } data T_Expression_s9 = C_Expression_s9 type T_Expression_v7 = (T_Expression_vIn7 ) -> (T_Expression_vOut7 ) data T_Expression_vIn7 = T_Expression_vIn7 data T_Expression_vOut7 = T_Expression_vOut7 (PP_Doc) {-# NOINLINE sem_Expression_Expression #-} sem_Expression_Expression :: (Pos) -> ([HsToken]) -> T_Expression sem_Expression_Expression arg_pos_ arg_tks_ = T_Expression (return st8) where {-# NOINLINE st8 #-} st8 = let v7 :: T_Expression_v7 v7 = \ (T_Expression_vIn7 ) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule5 arg_pos_ arg_tks_ __result_ = T_Expression_vOut7 _lhsOpp in __result_ ) in C_Expression_s8 v7 {-# INLINE rule5 #-} {-# LINE 50 "./src-ag/AbstractSyntaxDump.ag" #-} rule5 = \ pos_ tks_ -> {-# LINE 50 "./src-ag/AbstractSyntaxDump.ag" #-} ppNestInfo ["Expression","Expression"] [ppShow pos_] [ppF "txt" $ vlist . showTokens . tokensToStrings $ tks_] [] {-# LINE 221 "dist/build/AbstractSyntaxDump.hs"#-} -- Grammar ----------------------------------------------------- -- wrapper data Inh_Grammar = Inh_Grammar { } data Syn_Grammar = Syn_Grammar { pp_Syn_Grammar :: (PP_Doc) } {-# INLINABLE wrap_Grammar #-} wrap_Grammar :: T_Grammar -> Inh_Grammar -> (Syn_Grammar ) wrap_Grammar (T_Grammar act) (Inh_Grammar ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Grammar_vIn10 (T_Grammar_vOut10 _lhsOpp) <- return (inv_Grammar_s11 sem arg) return (Syn_Grammar _lhsOpp) ) -- cata {-# INLINE sem_Grammar #-} sem_Grammar :: Grammar -> T_Grammar sem_Grammar ( Grammar typeSyns_ useMap_ derivings_ wrappers_ nonts_ pragmas_ manualAttrOrderMap_ paramMap_ contextMap_ quantMap_ uniqueMap_ augmentsMap_ aroundsMap_ mergeMap_ ) = sem_Grammar_Grammar typeSyns_ useMap_ derivings_ wrappers_ ( sem_Nonterminals nonts_ ) pragmas_ manualAttrOrderMap_ paramMap_ contextMap_ quantMap_ uniqueMap_ augmentsMap_ aroundsMap_ mergeMap_ -- semantic domain newtype T_Grammar = T_Grammar { attach_T_Grammar :: Identity (T_Grammar_s11 ) } newtype T_Grammar_s11 = C_Grammar_s11 { inv_Grammar_s11 :: (T_Grammar_v10 ) } data T_Grammar_s12 = C_Grammar_s12 type T_Grammar_v10 = (T_Grammar_vIn10 ) -> (T_Grammar_vOut10 ) data T_Grammar_vIn10 = T_Grammar_vIn10 data T_Grammar_vOut10 = T_Grammar_vOut10 (PP_Doc) {-# NOINLINE sem_Grammar_Grammar #-} sem_Grammar_Grammar :: (TypeSyns) -> (UseMap) -> (Derivings) -> (Set NontermIdent) -> T_Nonterminals -> (PragmaMap) -> (AttrOrderMap) -> (ParamMap) -> (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)))) -> T_Grammar sem_Grammar_Grammar arg_typeSyns_ arg_useMap_ arg_derivings_ arg_wrappers_ arg_nonts_ _ _ _ _ _ _ _ _ _ = T_Grammar (return st11) where {-# NOINLINE st11 #-} st11 = let v10 :: T_Grammar_v10 v10 = \ (T_Grammar_vIn10 ) -> ( let _nontsX17 = Control.Monad.Identity.runIdentity (attach_T_Nonterminals (arg_nonts_)) (T_Nonterminals_vOut16 _nontsIpp _nontsIppL) = inv_Nonterminals_s17 _nontsX17 (T_Nonterminals_vIn16 ) _lhsOpp :: PP_Doc _lhsOpp = rule6 _nontsIppL arg_derivings_ arg_typeSyns_ arg_useMap_ arg_wrappers_ __result_ = T_Grammar_vOut10 _lhsOpp in __result_ ) in C_Grammar_s11 v10 {-# INLINE rule6 #-} {-# LINE 20 "./src-ag/AbstractSyntaxDump.ag" #-} rule6 = \ ((_nontsIppL) :: [PP_Doc]) derivings_ typeSyns_ useMap_ wrappers_ -> {-# LINE 20 "./src-ag/AbstractSyntaxDump.ag" #-} 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 _nontsIppL ] [] {-# LINE 278 "dist/build/AbstractSyntaxDump.hs"#-} -- Nonterminal ------------------------------------------------- -- wrapper data Inh_Nonterminal = Inh_Nonterminal { } data Syn_Nonterminal = Syn_Nonterminal { pp_Syn_Nonterminal :: (PP_Doc) } {-# INLINABLE wrap_Nonterminal #-} wrap_Nonterminal :: T_Nonterminal -> Inh_Nonterminal -> (Syn_Nonterminal ) wrap_Nonterminal (T_Nonterminal act) (Inh_Nonterminal ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Nonterminal_vIn13 (T_Nonterminal_vOut13 _lhsOpp) <- return (inv_Nonterminal_s14 sem arg) return (Syn_Nonterminal _lhsOpp) ) -- cata {-# INLINE sem_Nonterminal #-} sem_Nonterminal :: Nonterminal -> T_Nonterminal sem_Nonterminal ( Nonterminal nt_ params_ inh_ syn_ prods_ ) = sem_Nonterminal_Nonterminal nt_ params_ inh_ syn_ ( sem_Productions prods_ ) -- semantic domain newtype T_Nonterminal = T_Nonterminal { attach_T_Nonterminal :: Identity (T_Nonterminal_s14 ) } newtype T_Nonterminal_s14 = C_Nonterminal_s14 { inv_Nonterminal_s14 :: (T_Nonterminal_v13 ) } data T_Nonterminal_s15 = C_Nonterminal_s15 type T_Nonterminal_v13 = (T_Nonterminal_vIn13 ) -> (T_Nonterminal_vOut13 ) data T_Nonterminal_vIn13 = T_Nonterminal_vIn13 data T_Nonterminal_vOut13 = T_Nonterminal_vOut13 (PP_Doc) {-# NOINLINE sem_Nonterminal_Nonterminal #-} sem_Nonterminal_Nonterminal :: (NontermIdent) -> ([Identifier]) -> (Attributes) -> (Attributes) -> T_Productions -> T_Nonterminal sem_Nonterminal_Nonterminal arg_nt_ arg_params_ arg_inh_ arg_syn_ arg_prods_ = T_Nonterminal (return st14) where {-# NOINLINE st14 #-} st14 = let v13 :: T_Nonterminal_v13 v13 = \ (T_Nonterminal_vIn13 ) -> ( let _prodsX29 = Control.Monad.Identity.runIdentity (attach_T_Productions (arg_prods_)) (T_Productions_vOut28 _prodsIpp _prodsIppL) = inv_Productions_s29 _prodsX29 (T_Productions_vIn28 ) _lhsOpp :: PP_Doc _lhsOpp = rule7 _prodsIppL arg_inh_ arg_nt_ arg_params_ arg_syn_ __result_ = T_Nonterminal_vOut13 _lhsOpp in __result_ ) in C_Nonterminal_s14 v13 {-# INLINE rule7 #-} {-# LINE 29 "./src-ag/AbstractSyntaxDump.ag" #-} rule7 = \ ((_prodsIppL) :: [PP_Doc]) inh_ nt_ params_ syn_ -> {-# LINE 29 "./src-ag/AbstractSyntaxDump.ag" #-} ppNestInfo ["Nonterminal","Nonterminal"] (pp nt_ : map pp params_) [ppF "inh" $ ppMap inh_, ppF "syn" $ ppMap syn_, ppF "prods" $ ppVList _prodsIppL] [] {-# LINE 329 "dist/build/AbstractSyntaxDump.hs"#-} -- Nonterminals ------------------------------------------------ -- wrapper data Inh_Nonterminals = Inh_Nonterminals { } data Syn_Nonterminals = Syn_Nonterminals { pp_Syn_Nonterminals :: (PP_Doc), ppL_Syn_Nonterminals :: ([PP_Doc]) } {-# INLINABLE wrap_Nonterminals #-} wrap_Nonterminals :: T_Nonterminals -> Inh_Nonterminals -> (Syn_Nonterminals ) wrap_Nonterminals (T_Nonterminals act) (Inh_Nonterminals ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Nonterminals_vIn16 (T_Nonterminals_vOut16 _lhsOpp _lhsOppL) <- return (inv_Nonterminals_s17 sem arg) return (Syn_Nonterminals _lhsOpp _lhsOppL) ) -- cata {-# NOINLINE sem_Nonterminals #-} sem_Nonterminals :: Nonterminals -> T_Nonterminals sem_Nonterminals list = Prelude.foldr sem_Nonterminals_Cons sem_Nonterminals_Nil (Prelude.map sem_Nonterminal list) -- semantic domain newtype T_Nonterminals = T_Nonterminals { attach_T_Nonterminals :: Identity (T_Nonterminals_s17 ) } newtype T_Nonterminals_s17 = C_Nonterminals_s17 { inv_Nonterminals_s17 :: (T_Nonterminals_v16 ) } data T_Nonterminals_s18 = C_Nonterminals_s18 type T_Nonterminals_v16 = (T_Nonterminals_vIn16 ) -> (T_Nonterminals_vOut16 ) data T_Nonterminals_vIn16 = T_Nonterminals_vIn16 data T_Nonterminals_vOut16 = T_Nonterminals_vOut16 (PP_Doc) ([PP_Doc]) {-# NOINLINE sem_Nonterminals_Cons #-} sem_Nonterminals_Cons :: T_Nonterminal -> T_Nonterminals -> T_Nonterminals sem_Nonterminals_Cons arg_hd_ arg_tl_ = T_Nonterminals (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_Nonterminals_v16 v16 = \ (T_Nonterminals_vIn16 ) -> ( let _hdX14 = Control.Monad.Identity.runIdentity (attach_T_Nonterminal (arg_hd_)) _tlX17 = Control.Monad.Identity.runIdentity (attach_T_Nonterminals (arg_tl_)) (T_Nonterminal_vOut13 _hdIpp) = inv_Nonterminal_s14 _hdX14 (T_Nonterminal_vIn13 ) (T_Nonterminals_vOut16 _tlIpp _tlIppL) = inv_Nonterminals_s17 _tlX17 (T_Nonterminals_vIn16 ) _lhsOppL :: [PP_Doc] _lhsOppL = rule8 _hdIpp _tlIppL _lhsOpp :: PP_Doc _lhsOpp = rule9 _hdIpp _tlIpp __result_ = T_Nonterminals_vOut16 _lhsOpp _lhsOppL in __result_ ) in C_Nonterminals_s17 v16 {-# INLINE rule8 #-} {-# LINE 75 "./src-ag/AbstractSyntaxDump.ag" #-} rule8 = \ ((_hdIpp) :: PP_Doc) ((_tlIppL) :: [PP_Doc]) -> {-# LINE 75 "./src-ag/AbstractSyntaxDump.ag" #-} _hdIpp : _tlIppL {-# LINE 384 "dist/build/AbstractSyntaxDump.hs"#-} {-# INLINE rule9 #-} rule9 = \ ((_hdIpp) :: PP_Doc) ((_tlIpp) :: PP_Doc) -> _hdIpp >-< _tlIpp {-# NOINLINE sem_Nonterminals_Nil #-} sem_Nonterminals_Nil :: T_Nonterminals sem_Nonterminals_Nil = T_Nonterminals (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_Nonterminals_v16 v16 = \ (T_Nonterminals_vIn16 ) -> ( let _lhsOppL :: [PP_Doc] _lhsOppL = rule10 () _lhsOpp :: PP_Doc _lhsOpp = rule11 () __result_ = T_Nonterminals_vOut16 _lhsOpp _lhsOppL in __result_ ) in C_Nonterminals_s17 v16 {-# INLINE rule10 #-} {-# LINE 76 "./src-ag/AbstractSyntaxDump.ag" #-} rule10 = \ (_ :: ()) -> {-# LINE 76 "./src-ag/AbstractSyntaxDump.ag" #-} [] {-# LINE 407 "dist/build/AbstractSyntaxDump.hs"#-} {-# INLINE rule11 #-} rule11 = \ (_ :: ()) -> empty -- Pattern ----------------------------------------------------- -- wrapper data Inh_Pattern = Inh_Pattern { } data Syn_Pattern = Syn_Pattern { copy_Syn_Pattern :: (Pattern), pp_Syn_Pattern :: (PP_Doc) } {-# INLINABLE wrap_Pattern #-} wrap_Pattern :: T_Pattern -> Inh_Pattern -> (Syn_Pattern ) wrap_Pattern (T_Pattern act) (Inh_Pattern ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Pattern_vIn19 (T_Pattern_vOut19 _lhsOcopy _lhsOpp) <- return (inv_Pattern_s20 sem arg) return (Syn_Pattern _lhsOcopy _lhsOpp) ) -- cata {-# NOINLINE sem_Pattern #-} sem_Pattern :: Pattern -> T_Pattern sem_Pattern ( Constr name_ pats_ ) = sem_Pattern_Constr name_ ( sem_Patterns pats_ ) sem_Pattern ( Product pos_ pats_ ) = sem_Pattern_Product pos_ ( sem_Patterns pats_ ) sem_Pattern ( Alias field_ attr_ pat_ ) = sem_Pattern_Alias field_ attr_ ( sem_Pattern pat_ ) sem_Pattern ( Irrefutable pat_ ) = sem_Pattern_Irrefutable ( sem_Pattern pat_ ) sem_Pattern ( Underscore pos_ ) = sem_Pattern_Underscore pos_ -- semantic domain newtype T_Pattern = T_Pattern { attach_T_Pattern :: Identity (T_Pattern_s20 ) } newtype T_Pattern_s20 = C_Pattern_s20 { inv_Pattern_s20 :: (T_Pattern_v19 ) } data T_Pattern_s21 = C_Pattern_s21 type T_Pattern_v19 = (T_Pattern_vIn19 ) -> (T_Pattern_vOut19 ) data T_Pattern_vIn19 = T_Pattern_vIn19 data T_Pattern_vOut19 = T_Pattern_vOut19 (Pattern) (PP_Doc) {-# NOINLINE sem_Pattern_Constr #-} sem_Pattern_Constr :: (ConstructorIdent) -> T_Patterns -> T_Pattern sem_Pattern_Constr arg_name_ arg_pats_ = T_Pattern (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_Pattern_v19 v19 = \ (T_Pattern_vIn19 ) -> ( let _patsX23 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) (T_Patterns_vOut22 _patsIcopy _patsIpp _patsIppL) = inv_Patterns_s23 _patsX23 (T_Patterns_vIn22 ) _lhsOpp :: PP_Doc _lhsOpp = rule12 _patsIppL arg_name_ _copy = rule13 _patsIcopy arg_name_ _lhsOcopy :: Pattern _lhsOcopy = rule14 _copy __result_ = T_Pattern_vOut19 _lhsOcopy _lhsOpp in __result_ ) in C_Pattern_s20 v19 {-# INLINE rule12 #-} {-# LINE 44 "./src-ag/AbstractSyntaxDump.ag" #-} rule12 = \ ((_patsIppL) :: [PP_Doc]) name_ -> {-# LINE 44 "./src-ag/AbstractSyntaxDump.ag" #-} ppNestInfo ["Pattern","Constr"] [pp name_] [ppF "pats" $ ppVList _patsIppL] [] {-# LINE 468 "dist/build/AbstractSyntaxDump.hs"#-} {-# INLINE rule13 #-} rule13 = \ ((_patsIcopy) :: Patterns) name_ -> Constr name_ _patsIcopy {-# INLINE rule14 #-} rule14 = \ _copy -> _copy {-# NOINLINE sem_Pattern_Product #-} sem_Pattern_Product :: (Pos) -> T_Patterns -> T_Pattern sem_Pattern_Product arg_pos_ arg_pats_ = T_Pattern (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_Pattern_v19 v19 = \ (T_Pattern_vIn19 ) -> ( let _patsX23 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) (T_Patterns_vOut22 _patsIcopy _patsIpp _patsIppL) = inv_Patterns_s23 _patsX23 (T_Patterns_vIn22 ) _lhsOpp :: PP_Doc _lhsOpp = rule15 _patsIppL arg_pos_ _copy = rule16 _patsIcopy arg_pos_ _lhsOcopy :: Pattern _lhsOcopy = rule17 _copy __result_ = T_Pattern_vOut19 _lhsOcopy _lhsOpp in __result_ ) in C_Pattern_s20 v19 {-# INLINE rule15 #-} {-# LINE 45 "./src-ag/AbstractSyntaxDump.ag" #-} rule15 = \ ((_patsIppL) :: [PP_Doc]) pos_ -> {-# LINE 45 "./src-ag/AbstractSyntaxDump.ag" #-} ppNestInfo ["Pattern","Product"] [ppShow pos_] [ppF "pats" $ ppVList _patsIppL] [] {-# LINE 497 "dist/build/AbstractSyntaxDump.hs"#-} {-# INLINE rule16 #-} rule16 = \ ((_patsIcopy) :: Patterns) pos_ -> Product pos_ _patsIcopy {-# INLINE rule17 #-} rule17 = \ _copy -> _copy {-# NOINLINE sem_Pattern_Alias #-} sem_Pattern_Alias :: (Identifier) -> (Identifier) -> T_Pattern -> T_Pattern sem_Pattern_Alias arg_field_ arg_attr_ arg_pat_ = T_Pattern (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_Pattern_v19 v19 = \ (T_Pattern_vIn19 ) -> ( let _patX20 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) (T_Pattern_vOut19 _patIcopy _patIpp) = inv_Pattern_s20 _patX20 (T_Pattern_vIn19 ) _lhsOpp :: PP_Doc _lhsOpp = rule18 _patIpp arg_attr_ arg_field_ _copy = rule19 _patIcopy arg_attr_ arg_field_ _lhsOcopy :: Pattern _lhsOcopy = rule20 _copy __result_ = T_Pattern_vOut19 _lhsOcopy _lhsOpp in __result_ ) in C_Pattern_s20 v19 {-# INLINE rule18 #-} {-# LINE 46 "./src-ag/AbstractSyntaxDump.ag" #-} rule18 = \ ((_patIpp) :: PP_Doc) attr_ field_ -> {-# LINE 46 "./src-ag/AbstractSyntaxDump.ag" #-} ppNestInfo ["Pattern","Alias"] [pp field_, pp attr_] [ppF "pat" $ _patIpp] [] {-# LINE 526 "dist/build/AbstractSyntaxDump.hs"#-} {-# INLINE rule19 #-} rule19 = \ ((_patIcopy) :: Pattern) attr_ field_ -> Alias field_ attr_ _patIcopy {-# INLINE rule20 #-} rule20 = \ _copy -> _copy {-# NOINLINE sem_Pattern_Irrefutable #-} sem_Pattern_Irrefutable :: T_Pattern -> T_Pattern sem_Pattern_Irrefutable arg_pat_ = T_Pattern (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_Pattern_v19 v19 = \ (T_Pattern_vIn19 ) -> ( let _patX20 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) (T_Pattern_vOut19 _patIcopy _patIpp) = inv_Pattern_s20 _patX20 (T_Pattern_vIn19 ) _lhsOpp :: PP_Doc _lhsOpp = rule21 _patIpp _copy = rule22 _patIcopy _lhsOcopy :: Pattern _lhsOcopy = rule23 _copy __result_ = T_Pattern_vOut19 _lhsOcopy _lhsOpp in __result_ ) in C_Pattern_s20 v19 {-# INLINE rule21 #-} rule21 = \ ((_patIpp) :: PP_Doc) -> _patIpp {-# INLINE rule22 #-} rule22 = \ ((_patIcopy) :: Pattern) -> Irrefutable _patIcopy {-# INLINE rule23 #-} rule23 = \ _copy -> _copy {-# NOINLINE sem_Pattern_Underscore #-} sem_Pattern_Underscore :: (Pos) -> T_Pattern sem_Pattern_Underscore arg_pos_ = T_Pattern (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_Pattern_v19 v19 = \ (T_Pattern_vIn19 ) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule24 arg_pos_ _copy = rule25 arg_pos_ _lhsOcopy :: Pattern _lhsOcopy = rule26 _copy __result_ = T_Pattern_vOut19 _lhsOcopy _lhsOpp in __result_ ) in C_Pattern_s20 v19 {-# INLINE rule24 #-} {-# LINE 47 "./src-ag/AbstractSyntaxDump.ag" #-} rule24 = \ pos_ -> {-# LINE 47 "./src-ag/AbstractSyntaxDump.ag" #-} ppNestInfo ["Pattern","Underscore"] [ppShow pos_] [] [] {-# LINE 579 "dist/build/AbstractSyntaxDump.hs"#-} {-# INLINE rule25 #-} rule25 = \ pos_ -> Underscore pos_ {-# INLINE rule26 #-} rule26 = \ _copy -> _copy -- Patterns ---------------------------------------------------- -- wrapper data Inh_Patterns = Inh_Patterns { } data Syn_Patterns = Syn_Patterns { copy_Syn_Patterns :: (Patterns), pp_Syn_Patterns :: (PP_Doc), ppL_Syn_Patterns :: ([PP_Doc]) } {-# INLINABLE wrap_Patterns #-} wrap_Patterns :: T_Patterns -> Inh_Patterns -> (Syn_Patterns ) wrap_Patterns (T_Patterns act) (Inh_Patterns ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Patterns_vIn22 (T_Patterns_vOut22 _lhsOcopy _lhsOpp _lhsOppL) <- return (inv_Patterns_s23 sem arg) return (Syn_Patterns _lhsOcopy _lhsOpp _lhsOppL) ) -- cata {-# NOINLINE sem_Patterns #-} sem_Patterns :: Patterns -> T_Patterns sem_Patterns list = Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list) -- semantic domain newtype T_Patterns = T_Patterns { attach_T_Patterns :: Identity (T_Patterns_s23 ) } newtype T_Patterns_s23 = C_Patterns_s23 { inv_Patterns_s23 :: (T_Patterns_v22 ) } data T_Patterns_s24 = C_Patterns_s24 type T_Patterns_v22 = (T_Patterns_vIn22 ) -> (T_Patterns_vOut22 ) data T_Patterns_vIn22 = T_Patterns_vIn22 data T_Patterns_vOut22 = T_Patterns_vOut22 (Patterns) (PP_Doc) ([PP_Doc]) {-# NOINLINE sem_Patterns_Cons #-} sem_Patterns_Cons :: T_Pattern -> T_Patterns -> T_Patterns sem_Patterns_Cons arg_hd_ arg_tl_ = T_Patterns (return st23) where {-# NOINLINE st23 #-} st23 = let v22 :: T_Patterns_v22 v22 = \ (T_Patterns_vIn22 ) -> ( let _hdX20 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_hd_)) _tlX23 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_tl_)) (T_Pattern_vOut19 _hdIcopy _hdIpp) = inv_Pattern_s20 _hdX20 (T_Pattern_vIn19 ) (T_Patterns_vOut22 _tlIcopy _tlIpp _tlIppL) = inv_Patterns_s23 _tlX23 (T_Patterns_vIn22 ) _lhsOppL :: [PP_Doc] _lhsOppL = rule27 _hdIpp _tlIppL _lhsOpp :: PP_Doc _lhsOpp = rule28 _hdIpp _tlIpp _copy = rule29 _hdIcopy _tlIcopy _lhsOcopy :: Patterns _lhsOcopy = rule30 _copy __result_ = T_Patterns_vOut22 _lhsOcopy _lhsOpp _lhsOppL in __result_ ) in C_Patterns_s23 v22 {-# INLINE rule27 #-} {-# LINE 55 "./src-ag/AbstractSyntaxDump.ag" #-} rule27 = \ ((_hdIpp) :: PP_Doc) ((_tlIppL) :: [PP_Doc]) -> {-# LINE 55 "./src-ag/AbstractSyntaxDump.ag" #-} _hdIpp : _tlIppL {-# LINE 643 "dist/build/AbstractSyntaxDump.hs"#-} {-# INLINE rule28 #-} rule28 = \ ((_hdIpp) :: PP_Doc) ((_tlIpp) :: PP_Doc) -> _hdIpp >-< _tlIpp {-# INLINE rule29 #-} rule29 = \ ((_hdIcopy) :: Pattern) ((_tlIcopy) :: Patterns) -> (:) _hdIcopy _tlIcopy {-# INLINE rule30 #-} rule30 = \ _copy -> _copy {-# NOINLINE sem_Patterns_Nil #-} sem_Patterns_Nil :: T_Patterns sem_Patterns_Nil = T_Patterns (return st23) where {-# NOINLINE st23 #-} st23 = let v22 :: T_Patterns_v22 v22 = \ (T_Patterns_vIn22 ) -> ( let _lhsOppL :: [PP_Doc] _lhsOppL = rule31 () _lhsOpp :: PP_Doc _lhsOpp = rule32 () _copy = rule33 () _lhsOcopy :: Patterns _lhsOcopy = rule34 _copy __result_ = T_Patterns_vOut22 _lhsOcopy _lhsOpp _lhsOppL in __result_ ) in C_Patterns_s23 v22 {-# INLINE rule31 #-} {-# LINE 56 "./src-ag/AbstractSyntaxDump.ag" #-} rule31 = \ (_ :: ()) -> {-# LINE 56 "./src-ag/AbstractSyntaxDump.ag" #-} [] {-# LINE 675 "dist/build/AbstractSyntaxDump.hs"#-} {-# INLINE rule32 #-} rule32 = \ (_ :: ()) -> empty {-# INLINE rule33 #-} rule33 = \ (_ :: ()) -> [] {-# INLINE rule34 #-} rule34 = \ _copy -> _copy -- Production -------------------------------------------------- -- wrapper data Inh_Production = Inh_Production { } data Syn_Production = Syn_Production { pp_Syn_Production :: (PP_Doc) } {-# INLINABLE wrap_Production #-} wrap_Production :: T_Production -> Inh_Production -> (Syn_Production ) wrap_Production (T_Production act) (Inh_Production ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Production_vIn25 (T_Production_vOut25 _lhsOpp) <- return (inv_Production_s26 sem arg) return (Syn_Production _lhsOpp) ) -- cata {-# INLINE sem_Production #-} sem_Production :: Production -> T_Production sem_Production ( Production con_ params_ constraints_ children_ rules_ typeSigs_ macro_ ) = sem_Production_Production con_ params_ constraints_ ( sem_Children children_ ) ( sem_Rules rules_ ) ( sem_TypeSigs typeSigs_ ) macro_ -- semantic domain newtype T_Production = T_Production { attach_T_Production :: Identity (T_Production_s26 ) } newtype T_Production_s26 = C_Production_s26 { inv_Production_s26 :: (T_Production_v25 ) } data T_Production_s27 = C_Production_s27 type T_Production_v25 = (T_Production_vIn25 ) -> (T_Production_vOut25 ) data T_Production_vIn25 = T_Production_vIn25 data T_Production_vOut25 = T_Production_vOut25 (PP_Doc) {-# NOINLINE sem_Production_Production #-} sem_Production_Production :: (ConstructorIdent) -> ([Identifier]) -> ([Type]) -> T_Children -> T_Rules -> T_TypeSigs -> (MaybeMacro) -> T_Production sem_Production_Production arg_con_ _ _ arg_children_ arg_rules_ arg_typeSigs_ _ = T_Production (return st26) where {-# NOINLINE st26 #-} st26 = let v25 :: T_Production_v25 v25 = \ (T_Production_vIn25 ) -> ( let _childrenX5 = Control.Monad.Identity.runIdentity (attach_T_Children (arg_children_)) _rulesX35 = Control.Monad.Identity.runIdentity (attach_T_Rules (arg_rules_)) _typeSigsX41 = Control.Monad.Identity.runIdentity (attach_T_TypeSigs (arg_typeSigs_)) (T_Children_vOut4 _childrenIpp _childrenIppL) = inv_Children_s5 _childrenX5 (T_Children_vIn4 ) (T_Rules_vOut34 _rulesIpp _rulesIppL) = inv_Rules_s35 _rulesX35 (T_Rules_vIn34 ) (T_TypeSigs_vOut40 _typeSigsIpp _typeSigsIppL) = inv_TypeSigs_s41 _typeSigsX41 (T_TypeSigs_vIn40 ) _lhsOpp :: PP_Doc _lhsOpp = rule35 _childrenIppL _rulesIppL _typeSigsIppL arg_con_ __result_ = T_Production_vOut25 _lhsOpp in __result_ ) in C_Production_s26 v25 {-# INLINE rule35 #-} {-# LINE 32 "./src-ag/AbstractSyntaxDump.ag" #-} rule35 = \ ((_childrenIppL) :: [PP_Doc]) ((_rulesIppL) :: [PP_Doc]) ((_typeSigsIppL) :: [PP_Doc]) con_ -> {-# LINE 32 "./src-ag/AbstractSyntaxDump.ag" #-} ppNestInfo ["Production","Production"] [pp con_] [ppF "children" $ ppVList _childrenIppL,ppF "rules" $ ppVList _rulesIppL,ppF "typeSigs" $ ppVList _typeSigsIppL] [] {-# LINE 739 "dist/build/AbstractSyntaxDump.hs"#-} -- Productions ------------------------------------------------- -- wrapper data Inh_Productions = Inh_Productions { } data Syn_Productions = Syn_Productions { pp_Syn_Productions :: (PP_Doc), ppL_Syn_Productions :: ([PP_Doc]) } {-# INLINABLE wrap_Productions #-} wrap_Productions :: T_Productions -> Inh_Productions -> (Syn_Productions ) wrap_Productions (T_Productions act) (Inh_Productions ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Productions_vIn28 (T_Productions_vOut28 _lhsOpp _lhsOppL) <- return (inv_Productions_s29 sem arg) return (Syn_Productions _lhsOpp _lhsOppL) ) -- cata {-# NOINLINE sem_Productions #-} sem_Productions :: Productions -> T_Productions sem_Productions list = Prelude.foldr sem_Productions_Cons sem_Productions_Nil (Prelude.map sem_Production list) -- semantic domain newtype T_Productions = T_Productions { attach_T_Productions :: Identity (T_Productions_s29 ) } newtype T_Productions_s29 = C_Productions_s29 { inv_Productions_s29 :: (T_Productions_v28 ) } data T_Productions_s30 = C_Productions_s30 type T_Productions_v28 = (T_Productions_vIn28 ) -> (T_Productions_vOut28 ) data T_Productions_vIn28 = T_Productions_vIn28 data T_Productions_vOut28 = T_Productions_vOut28 (PP_Doc) ([PP_Doc]) {-# NOINLINE sem_Productions_Cons #-} sem_Productions_Cons :: T_Production -> T_Productions -> T_Productions sem_Productions_Cons arg_hd_ arg_tl_ = T_Productions (return st29) where {-# NOINLINE st29 #-} st29 = let v28 :: T_Productions_v28 v28 = \ (T_Productions_vIn28 ) -> ( let _hdX26 = Control.Monad.Identity.runIdentity (attach_T_Production (arg_hd_)) _tlX29 = Control.Monad.Identity.runIdentity (attach_T_Productions (arg_tl_)) (T_Production_vOut25 _hdIpp) = inv_Production_s26 _hdX26 (T_Production_vIn25 ) (T_Productions_vOut28 _tlIpp _tlIppL) = inv_Productions_s29 _tlX29 (T_Productions_vIn28 ) _lhsOppL :: [PP_Doc] _lhsOppL = rule36 _hdIpp _tlIppL _lhsOpp :: PP_Doc _lhsOpp = rule37 _hdIpp _tlIpp __result_ = T_Productions_vOut28 _lhsOpp _lhsOppL in __result_ ) in C_Productions_s29 v28 {-# INLINE rule36 #-} {-# LINE 71 "./src-ag/AbstractSyntaxDump.ag" #-} rule36 = \ ((_hdIpp) :: PP_Doc) ((_tlIppL) :: [PP_Doc]) -> {-# LINE 71 "./src-ag/AbstractSyntaxDump.ag" #-} _hdIpp : _tlIppL {-# LINE 794 "dist/build/AbstractSyntaxDump.hs"#-} {-# INLINE rule37 #-} rule37 = \ ((_hdIpp) :: PP_Doc) ((_tlIpp) :: PP_Doc) -> _hdIpp >-< _tlIpp {-# NOINLINE sem_Productions_Nil #-} sem_Productions_Nil :: T_Productions sem_Productions_Nil = T_Productions (return st29) where {-# NOINLINE st29 #-} st29 = let v28 :: T_Productions_v28 v28 = \ (T_Productions_vIn28 ) -> ( let _lhsOppL :: [PP_Doc] _lhsOppL = rule38 () _lhsOpp :: PP_Doc _lhsOpp = rule39 () __result_ = T_Productions_vOut28 _lhsOpp _lhsOppL in __result_ ) in C_Productions_s29 v28 {-# INLINE rule38 #-} {-# LINE 72 "./src-ag/AbstractSyntaxDump.ag" #-} rule38 = \ (_ :: ()) -> {-# LINE 72 "./src-ag/AbstractSyntaxDump.ag" #-} [] {-# LINE 817 "dist/build/AbstractSyntaxDump.hs"#-} {-# INLINE rule39 #-} rule39 = \ (_ :: ()) -> empty -- Rule -------------------------------------------------------- -- wrapper data Inh_Rule = Inh_Rule { } data Syn_Rule = Syn_Rule { pp_Syn_Rule :: (PP_Doc) } {-# INLINABLE wrap_Rule #-} wrap_Rule :: T_Rule -> Inh_Rule -> (Syn_Rule ) wrap_Rule (T_Rule act) (Inh_Rule ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Rule_vIn31 (T_Rule_vOut31 _lhsOpp) <- return (inv_Rule_s32 sem arg) return (Syn_Rule _lhsOpp) ) -- cata {-# INLINE sem_Rule #-} sem_Rule :: Rule -> T_Rule sem_Rule ( Rule mbName_ pattern_ rhs_ owrt_ origin_ explicit_ pure_ identity_ mbError_ eager_ ) = sem_Rule_Rule mbName_ ( sem_Pattern pattern_ ) ( sem_Expression rhs_ ) owrt_ origin_ explicit_ pure_ identity_ mbError_ eager_ -- semantic domain newtype T_Rule = T_Rule { attach_T_Rule :: Identity (T_Rule_s32 ) } newtype T_Rule_s32 = C_Rule_s32 { inv_Rule_s32 :: (T_Rule_v31 ) } data T_Rule_s33 = C_Rule_s33 type T_Rule_v31 = (T_Rule_vIn31 ) -> (T_Rule_vOut31 ) data T_Rule_vIn31 = T_Rule_vIn31 data T_Rule_vOut31 = T_Rule_vOut31 (PP_Doc) {-# NOINLINE sem_Rule_Rule #-} sem_Rule_Rule :: (Maybe Identifier) -> T_Pattern -> T_Expression -> (Bool) -> (String) -> (Bool) -> (Bool) -> (Bool) -> (Maybe Error) -> (Bool) -> T_Rule sem_Rule_Rule _ arg_pattern_ arg_rhs_ arg_owrt_ arg_origin_ _ _ _ _ _ = T_Rule (return st32) where {-# NOINLINE st32 #-} st32 = let v31 :: T_Rule_v31 v31 = \ (T_Rule_vIn31 ) -> ( let _patternX20 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pattern_)) _rhsX8 = Control.Monad.Identity.runIdentity (attach_T_Expression (arg_rhs_)) (T_Pattern_vOut19 _patternIcopy _patternIpp) = inv_Pattern_s20 _patternX20 (T_Pattern_vIn19 ) (T_Expression_vOut7 _rhsIpp) = inv_Expression_s8 _rhsX8 (T_Expression_vIn7 ) _lhsOpp :: PP_Doc _lhsOpp = rule40 _patternIpp _rhsIpp arg_origin_ arg_owrt_ __result_ = T_Rule_vOut31 _lhsOpp in __result_ ) in C_Rule_s32 v31 {-# INLINE rule40 #-} {-# LINE 38 "./src-ag/AbstractSyntaxDump.ag" #-} rule40 = \ ((_patternIpp) :: PP_Doc) ((_rhsIpp) :: PP_Doc) origin_ owrt_ -> {-# LINE 38 "./src-ag/AbstractSyntaxDump.ag" #-} ppNestInfo ["Rule","Rule"] [ppShow owrt_, pp origin_] [ppF "pattern" $ _patternIpp, ppF "rhs" $ _rhsIpp] [] {-# LINE 873 "dist/build/AbstractSyntaxDump.hs"#-} -- Rules ------------------------------------------------------- -- wrapper data Inh_Rules = Inh_Rules { } data Syn_Rules = Syn_Rules { pp_Syn_Rules :: (PP_Doc), ppL_Syn_Rules :: ([PP_Doc]) } {-# INLINABLE wrap_Rules #-} wrap_Rules :: T_Rules -> Inh_Rules -> (Syn_Rules ) wrap_Rules (T_Rules act) (Inh_Rules ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Rules_vIn34 (T_Rules_vOut34 _lhsOpp _lhsOppL) <- return (inv_Rules_s35 sem arg) return (Syn_Rules _lhsOpp _lhsOppL) ) -- cata {-# NOINLINE sem_Rules #-} sem_Rules :: Rules -> T_Rules sem_Rules list = Prelude.foldr sem_Rules_Cons sem_Rules_Nil (Prelude.map sem_Rule list) -- semantic domain newtype T_Rules = T_Rules { attach_T_Rules :: Identity (T_Rules_s35 ) } newtype T_Rules_s35 = C_Rules_s35 { inv_Rules_s35 :: (T_Rules_v34 ) } data T_Rules_s36 = C_Rules_s36 type T_Rules_v34 = (T_Rules_vIn34 ) -> (T_Rules_vOut34 ) data T_Rules_vIn34 = T_Rules_vIn34 data T_Rules_vOut34 = T_Rules_vOut34 (PP_Doc) ([PP_Doc]) {-# NOINLINE sem_Rules_Cons #-} sem_Rules_Cons :: T_Rule -> T_Rules -> T_Rules sem_Rules_Cons arg_hd_ arg_tl_ = T_Rules (return st35) where {-# NOINLINE st35 #-} st35 = let v34 :: T_Rules_v34 v34 = \ (T_Rules_vIn34 ) -> ( let _hdX32 = Control.Monad.Identity.runIdentity (attach_T_Rule (arg_hd_)) _tlX35 = Control.Monad.Identity.runIdentity (attach_T_Rules (arg_tl_)) (T_Rule_vOut31 _hdIpp) = inv_Rule_s32 _hdX32 (T_Rule_vIn31 ) (T_Rules_vOut34 _tlIpp _tlIppL) = inv_Rules_s35 _tlX35 (T_Rules_vIn34 ) _lhsOppL :: [PP_Doc] _lhsOppL = rule41 _hdIpp _tlIppL _lhsOpp :: PP_Doc _lhsOpp = rule42 _hdIpp _tlIpp __result_ = T_Rules_vOut34 _lhsOpp _lhsOppL in __result_ ) in C_Rules_s35 v34 {-# INLINE rule41 #-} {-# LINE 63 "./src-ag/AbstractSyntaxDump.ag" #-} rule41 = \ ((_hdIpp) :: PP_Doc) ((_tlIppL) :: [PP_Doc]) -> {-# LINE 63 "./src-ag/AbstractSyntaxDump.ag" #-} _hdIpp : _tlIppL {-# LINE 928 "dist/build/AbstractSyntaxDump.hs"#-} {-# INLINE rule42 #-} rule42 = \ ((_hdIpp) :: PP_Doc) ((_tlIpp) :: PP_Doc) -> _hdIpp >-< _tlIpp {-# NOINLINE sem_Rules_Nil #-} sem_Rules_Nil :: T_Rules sem_Rules_Nil = T_Rules (return st35) where {-# NOINLINE st35 #-} st35 = let v34 :: T_Rules_v34 v34 = \ (T_Rules_vIn34 ) -> ( let _lhsOppL :: [PP_Doc] _lhsOppL = rule43 () _lhsOpp :: PP_Doc _lhsOpp = rule44 () __result_ = T_Rules_vOut34 _lhsOpp _lhsOppL in __result_ ) in C_Rules_s35 v34 {-# INLINE rule43 #-} {-# LINE 64 "./src-ag/AbstractSyntaxDump.ag" #-} rule43 = \ (_ :: ()) -> {-# LINE 64 "./src-ag/AbstractSyntaxDump.ag" #-} [] {-# LINE 951 "dist/build/AbstractSyntaxDump.hs"#-} {-# INLINE rule44 #-} rule44 = \ (_ :: ()) -> empty -- TypeSig ----------------------------------------------------- -- wrapper data Inh_TypeSig = Inh_TypeSig { } data Syn_TypeSig = Syn_TypeSig { pp_Syn_TypeSig :: (PP_Doc) } {-# INLINABLE wrap_TypeSig #-} wrap_TypeSig :: T_TypeSig -> Inh_TypeSig -> (Syn_TypeSig ) wrap_TypeSig (T_TypeSig act) (Inh_TypeSig ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_TypeSig_vIn37 (T_TypeSig_vOut37 _lhsOpp) <- return (inv_TypeSig_s38 sem arg) return (Syn_TypeSig _lhsOpp) ) -- cata {-# INLINE sem_TypeSig #-} sem_TypeSig :: TypeSig -> T_TypeSig sem_TypeSig ( TypeSig name_ tp_ ) = sem_TypeSig_TypeSig name_ tp_ -- semantic domain newtype T_TypeSig = T_TypeSig { attach_T_TypeSig :: Identity (T_TypeSig_s38 ) } newtype T_TypeSig_s38 = C_TypeSig_s38 { inv_TypeSig_s38 :: (T_TypeSig_v37 ) } data T_TypeSig_s39 = C_TypeSig_s39 type T_TypeSig_v37 = (T_TypeSig_vIn37 ) -> (T_TypeSig_vOut37 ) data T_TypeSig_vIn37 = T_TypeSig_vIn37 data T_TypeSig_vOut37 = T_TypeSig_vOut37 (PP_Doc) {-# NOINLINE sem_TypeSig_TypeSig #-} sem_TypeSig_TypeSig :: (Identifier) -> (Type) -> T_TypeSig sem_TypeSig_TypeSig arg_name_ arg_tp_ = T_TypeSig (return st38) where {-# NOINLINE st38 #-} st38 = let v37 :: T_TypeSig_v37 v37 = \ (T_TypeSig_vIn37 ) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule45 arg_name_ arg_tp_ __result_ = T_TypeSig_vOut37 _lhsOpp in __result_ ) in C_TypeSig_s38 v37 {-# INLINE rule45 #-} {-# LINE 41 "./src-ag/AbstractSyntaxDump.ag" #-} rule45 = \ name_ tp_ -> {-# LINE 41 "./src-ag/AbstractSyntaxDump.ag" #-} ppNestInfo ["TypeSig","TypeSig"] [pp name_, ppShow tp_] [] [] {-# LINE 1003 "dist/build/AbstractSyntaxDump.hs"#-} -- TypeSigs ---------------------------------------------------- -- wrapper data Inh_TypeSigs = Inh_TypeSigs { } data Syn_TypeSigs = Syn_TypeSigs { pp_Syn_TypeSigs :: (PP_Doc), ppL_Syn_TypeSigs :: ([PP_Doc]) } {-# INLINABLE wrap_TypeSigs #-} wrap_TypeSigs :: T_TypeSigs -> Inh_TypeSigs -> (Syn_TypeSigs ) wrap_TypeSigs (T_TypeSigs act) (Inh_TypeSigs ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_TypeSigs_vIn40 (T_TypeSigs_vOut40 _lhsOpp _lhsOppL) <- return (inv_TypeSigs_s41 sem arg) return (Syn_TypeSigs _lhsOpp _lhsOppL) ) -- cata {-# NOINLINE sem_TypeSigs #-} sem_TypeSigs :: TypeSigs -> T_TypeSigs sem_TypeSigs list = Prelude.foldr sem_TypeSigs_Cons sem_TypeSigs_Nil (Prelude.map sem_TypeSig list) -- semantic domain newtype T_TypeSigs = T_TypeSigs { attach_T_TypeSigs :: Identity (T_TypeSigs_s41 ) } newtype T_TypeSigs_s41 = C_TypeSigs_s41 { inv_TypeSigs_s41 :: (T_TypeSigs_v40 ) } data T_TypeSigs_s42 = C_TypeSigs_s42 type T_TypeSigs_v40 = (T_TypeSigs_vIn40 ) -> (T_TypeSigs_vOut40 ) data T_TypeSigs_vIn40 = T_TypeSigs_vIn40 data T_TypeSigs_vOut40 = T_TypeSigs_vOut40 (PP_Doc) ([PP_Doc]) {-# NOINLINE sem_TypeSigs_Cons #-} sem_TypeSigs_Cons :: T_TypeSig -> T_TypeSigs -> T_TypeSigs sem_TypeSigs_Cons arg_hd_ arg_tl_ = T_TypeSigs (return st41) where {-# NOINLINE st41 #-} st41 = let v40 :: T_TypeSigs_v40 v40 = \ (T_TypeSigs_vIn40 ) -> ( let _hdX38 = Control.Monad.Identity.runIdentity (attach_T_TypeSig (arg_hd_)) _tlX41 = Control.Monad.Identity.runIdentity (attach_T_TypeSigs (arg_tl_)) (T_TypeSig_vOut37 _hdIpp) = inv_TypeSig_s38 _hdX38 (T_TypeSig_vIn37 ) (T_TypeSigs_vOut40 _tlIpp _tlIppL) = inv_TypeSigs_s41 _tlX41 (T_TypeSigs_vIn40 ) _lhsOppL :: [PP_Doc] _lhsOppL = rule46 _hdIpp _tlIppL _lhsOpp :: PP_Doc _lhsOpp = rule47 _hdIpp _tlIpp __result_ = T_TypeSigs_vOut40 _lhsOpp _lhsOppL in __result_ ) in C_TypeSigs_s41 v40 {-# INLINE rule46 #-} {-# LINE 59 "./src-ag/AbstractSyntaxDump.ag" #-} rule46 = \ ((_hdIpp) :: PP_Doc) ((_tlIppL) :: [PP_Doc]) -> {-# LINE 59 "./src-ag/AbstractSyntaxDump.ag" #-} _hdIpp : _tlIppL {-# LINE 1058 "dist/build/AbstractSyntaxDump.hs"#-} {-# INLINE rule47 #-} rule47 = \ ((_hdIpp) :: PP_Doc) ((_tlIpp) :: PP_Doc) -> _hdIpp >-< _tlIpp {-# NOINLINE sem_TypeSigs_Nil #-} sem_TypeSigs_Nil :: T_TypeSigs sem_TypeSigs_Nil = T_TypeSigs (return st41) where {-# NOINLINE st41 #-} st41 = let v40 :: T_TypeSigs_v40 v40 = \ (T_TypeSigs_vIn40 ) -> ( let _lhsOppL :: [PP_Doc] _lhsOppL = rule48 () _lhsOpp :: PP_Doc _lhsOpp = rule49 () __result_ = T_TypeSigs_vOut40 _lhsOpp _lhsOppL in __result_ ) in C_TypeSigs_s41 v40 {-# INLINE rule48 #-} {-# LINE 60 "./src-ag/AbstractSyntaxDump.ag" #-} rule48 = \ (_ :: ()) -> {-# LINE 60 "./src-ag/AbstractSyntaxDump.ag" #-} [] {-# LINE 1081 "dist/build/AbstractSyntaxDump.hs"#-} {-# INLINE rule49 #-} rule49 = \ (_ :: ()) -> empty uuagc-0.9.42.3/src-generated/AG2AspectAG.hs000644 000765 000024 00000472106 12127045231 022060 0ustar00jeroenbransenstaff000000 000000 {-# LANGUAGE Rank2Types, GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} module AG2AspectAG where {-# LINE 2 "./src-ag/AbstractSyntax.ag" #-} -- 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 {-# LINE 16 "dist/build/AG2AspectAG.hs" #-} {-# LINE 2 "./src-ag/Patterns.ag" #-} -- Patterns.ag imports import UU.Scanner.Position(Pos) import CommonTypes (ConstructorIdent,Identifier) {-# LINE 23 "dist/build/AG2AspectAG.hs" #-} {-# LINE 2 "./src-ag/Expression.ag" #-} import UU.Scanner.Position(Pos) import HsToken {-# LINE 29 "dist/build/AG2AspectAG.hs" #-} {-# LINE 2 "./src-ag/HsToken.ag" #-} import CommonTypes import UU.Scanner.Position(Pos) {-# LINE 35 "dist/build/AG2AspectAG.hs" #-} {-# LINE 8 "./src-ag/AG2AspectAG.ag" #-} 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 {-# LINE 56 "dist/build/AG2AspectAG.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 28 "./src-ag/AG2AspectAG.ag" #-} pragmaAspectAG = pp "{-# LANGUAGE EmptyDataDecls, NoMonomorphismRestriction , TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-}" {-# LINE 63 "dist/build/AG2AspectAG.hs" #-} {-# LINE 33 "./src-ag/AG2AspectAG.ag" #-} ppName l = ppListSep "" "" "_" l {-# LINE 68 "dist/build/AG2AspectAG.hs" #-} {-# LINE 70 "./src-ag/AG2AspectAG.ag" #-} type FieldMap = [(Identifier, Type)] type DataTypes = Map.Map NontermIdent (Map.Map ConstructorIdent FieldMap) {-# LINE 74 "dist/build/AG2AspectAG.hs" #-} {-# LINE 342 "./src-ag/AG2AspectAG.ag" #-} 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 {-# LINE 103 "dist/build/AG2AspectAG.hs" #-} {-# LINE 397 "./src-ag/AG2AspectAG.ag" #-} ntsList att ppNtL = "nts_" ++ att ++ " = " >|< ppListSep "" "" " .*. " ((map fst ppNtL) ++ [pp "hNil"]) filterNts att = filter ( Map.member (identifier att) . snd ) {-# LINE 110 "dist/build/AG2AspectAG.hs" #-} {-# LINE 455 "./src-ag/AG2AspectAG.ag" #-} 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 {-# LINE 122 "dist/build/AG2AspectAG.hs" #-} {-# LINE 494 "./src-ag/AG2AspectAG.ag" #-} 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 {-# LINE 347 "dist/build/AG2AspectAG.hs" #-} {-# LINE 721 "./src-ag/AG2AspectAG.ag" #-} 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] {-# LINE 357 "dist/build/AG2AspectAG.hs" #-} {-# LINE 754 "./src-ag/AG2AspectAG.ag" #-} 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 {-# LINE 367 "dist/build/AG2AspectAG.hs" #-} {-# LINE 797 "./src-ag/AG2AspectAG.ag" #-} attTypes atts = map (\(a,t) -> "(HCons (LVPair (Proxy Att_" >|< a >|< ") " >|< ppShow t >|< ") ") $ Map.toAscList atts {-# LINE 372 "dist/build/AG2AspectAG.hs" #-} {-# LINE 851 "./src-ag/AG2AspectAG.ag" #-} 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)" {-# LINE 381 "dist/build/AG2AspectAG.hs" #-} -- Child ------------------------------------------------------- -- wrapper data Inh_Child = Inh_Child { ext_Inh_Child :: (Maybe String), inhMap_Inh_Child :: (Map Identifier Attributes), inhNoGroup_Inh_Child :: ([String]), newAtts_Inh_Child :: ( Attributes ), o_noGroup_Inh_Child :: ([String]), o_rename_Inh_Child :: (Bool), ppNt_Inh_Child :: (PP_Doc), ppProd_Inh_Child :: (PP_Doc), synMap_Inh_Child :: (Map Identifier Attributes), synNoGroup_Inh_Child :: ([String]) } data Syn_Child = Syn_Child { idCL_Syn_Child :: ([(Identifier,Type)]), ppCSF_Syn_Child :: ([(Identifier,(PP_Doc,PP_Doc))]), ppDL_Syn_Child :: ([PP_Doc]), ppL_Syn_Child :: (PP_Doc), ppLI_Syn_Child :: ([PP_Doc]), ppR_Syn_Child :: (PP_Doc), prdInh_Syn_Child :: (Attributes) } {-# INLINABLE wrap_Child #-} wrap_Child :: T_Child -> Inh_Child -> (Syn_Child ) wrap_Child (T_Child act) (Inh_Child _lhsIext _lhsIinhMap _lhsIinhNoGroup _lhsInewAtts _lhsIo_noGroup _lhsIo_rename _lhsIppNt _lhsIppProd _lhsIsynMap _lhsIsynNoGroup) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Child_vIn1 _lhsIext _lhsIinhMap _lhsIinhNoGroup _lhsInewAtts _lhsIo_noGroup _lhsIo_rename _lhsIppNt _lhsIppProd _lhsIsynMap _lhsIsynNoGroup (T_Child_vOut1 _lhsOidCL _lhsOppCSF _lhsOppDL _lhsOppL _lhsOppLI _lhsOppR _lhsOprdInh) <- return (inv_Child_s2 sem arg) return (Syn_Child _lhsOidCL _lhsOppCSF _lhsOppDL _lhsOppL _lhsOppLI _lhsOppR _lhsOprdInh) ) -- cata {-# INLINE sem_Child #-} sem_Child :: Child -> T_Child sem_Child ( Child name_ tp_ kind_ ) = sem_Child_Child name_ tp_ kind_ -- semantic domain newtype T_Child = T_Child { attach_T_Child :: Identity (T_Child_s2 ) } newtype T_Child_s2 = C_Child_s2 { inv_Child_s2 :: (T_Child_v1 ) } data T_Child_s3 = C_Child_s3 type T_Child_v1 = (T_Child_vIn1 ) -> (T_Child_vOut1 ) data T_Child_vIn1 = T_Child_vIn1 (Maybe String) (Map Identifier Attributes) ([String]) ( Attributes ) ([String]) (Bool) (PP_Doc) (PP_Doc) (Map Identifier Attributes) ([String]) data T_Child_vOut1 = T_Child_vOut1 ([(Identifier,Type)]) ([(Identifier,(PP_Doc,PP_Doc))]) ([PP_Doc]) (PP_Doc) ([PP_Doc]) (PP_Doc) (Attributes) {-# NOINLINE sem_Child_Child #-} sem_Child_Child :: (Identifier) -> (Type) -> (ChildKind) -> T_Child sem_Child_Child arg_name_ arg_tp_ arg_kind_ = T_Child (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Child_v1 v1 = \ (T_Child_vIn1 _lhsIext _lhsIinhMap _lhsIinhNoGroup _lhsInewAtts _lhsIo_noGroup _lhsIo_rename _lhsIppNt _lhsIppProd _lhsIsynMap _lhsIsynNoGroup) -> ( let _chnt = rule0 arg_name_ arg_tp_ _inh = rule1 _chnt _lhsIinhMap _syn = rule2 _chnt _lhsIsynMap _lhsOprdInh :: Attributes _lhsOprdInh = rule3 _inh _ppCh = rule4 arg_name_ _ppTCh = rule5 arg_tp_ _chName = rule6 _lhsIppNt _lhsIppProd _ppCh _lhsOppDL :: [PP_Doc] _lhsOppDL = rule7 _chName _ppTCh arg_kind_ _chLabel = rule8 _chName _chTLabel = rule9 _chName _lhsOppL :: PP_Doc _lhsOppL = rule10 _chLabel _chTLabel _ppTCh arg_kind_ _lhsOppLI :: [PP_Doc] _lhsOppLI = rule11 _chLabel _chTLabel _lhsOppR :: PP_Doc _lhsOppR = rule12 _lhsIppNt _lhsIppProd arg_name_ _lhsOidCL :: [(Identifier,Type)] _lhsOidCL = rule13 arg_name_ arg_tp_ _lhsOppCSF :: [(Identifier,(PP_Doc,PP_Doc))] _lhsOppCSF = rule14 _chLabel arg_kind_ arg_name_ arg_tp_ __result_ = T_Child_vOut1 _lhsOidCL _lhsOppCSF _lhsOppDL _lhsOppL _lhsOppLI _lhsOppR _lhsOprdInh in __result_ ) in C_Child_s2 v1 {-# INLINE rule0 #-} {-# LINE 19 "./src-ag/DistChildAttr.ag" #-} rule0 = \ name_ tp_ -> {-# LINE 19 "./src-ag/DistChildAttr.ag" #-} case tp_ of NT nt _ _ -> nt Self -> error ("The type of child " ++ show name_ ++ " should not be a Self type.") Haskell t -> identifier "" {-# LINE 452 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule1 #-} {-# LINE 23 "./src-ag/DistChildAttr.ag" #-} rule1 = \ _chnt ((_lhsIinhMap) :: Map Identifier Attributes) -> {-# LINE 23 "./src-ag/DistChildAttr.ag" #-} Map.findWithDefault Map.empty _chnt _lhsIinhMap {-# LINE 458 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule2 #-} {-# LINE 24 "./src-ag/DistChildAttr.ag" #-} rule2 = \ _chnt ((_lhsIsynMap) :: Map Identifier Attributes) -> {-# LINE 24 "./src-ag/DistChildAttr.ag" #-} Map.findWithDefault Map.empty _chnt _lhsIsynMap {-# LINE 464 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule3 #-} {-# LINE 67 "./src-ag/AG2AspectAG.ag" #-} rule3 = \ _inh -> {-# LINE 67 "./src-ag/AG2AspectAG.ag" #-} _inh {-# LINE 470 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule4 #-} {-# LINE 182 "./src-ag/AG2AspectAG.ag" #-} rule4 = \ name_ -> {-# LINE 182 "./src-ag/AG2AspectAG.ag" #-} pp name_ {-# LINE 476 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule5 #-} {-# LINE 183 "./src-ag/AG2AspectAG.ag" #-} rule5 = \ tp_ -> {-# LINE 183 "./src-ag/AG2AspectAG.ag" #-} ppShow tp_ {-# LINE 482 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule6 #-} {-# LINE 184 "./src-ag/AG2AspectAG.ag" #-} rule6 = \ ((_lhsIppNt) :: PP_Doc) ((_lhsIppProd) :: PP_Doc) _ppCh -> {-# LINE 184 "./src-ag/AG2AspectAG.ag" #-} ppName [_ppCh , _lhsIppNt, _lhsIppProd] {-# LINE 488 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule7 #-} {-# LINE 242 "./src-ag/AG2AspectAG.ag" #-} rule7 = \ _chName _ppTCh kind_ -> {-# LINE 242 "./src-ag/AG2AspectAG.ag" #-} case kind_ of ChildSyntax -> [ _chName >|< pp " :: " >|< _ppTCh ] _ -> [] {-# LINE 496 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule8 #-} {-# LINE 285 "./src-ag/AG2AspectAG.ag" #-} rule8 = \ _chName -> {-# LINE 285 "./src-ag/AG2AspectAG.ag" #-} "ch_" >|< _chName {-# LINE 502 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule9 #-} {-# LINE 286 "./src-ag/AG2AspectAG.ag" #-} rule9 = \ _chName -> {-# LINE 286 "./src-ag/AG2AspectAG.ag" #-} "Ch_" >|< _chName {-# LINE 508 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule10 #-} {-# LINE 287 "./src-ag/AG2AspectAG.ag" #-} rule10 = \ _chLabel _chTLabel _ppTCh kind_ -> {-# LINE 287 "./src-ag/AG2AspectAG.ag" #-} "data " >|< _chTLabel >|< "; " >|< _chLabel >|< pp " = proxy :: " >|< case kind_ of ChildSyntax -> "Proxy " >|< "(" >|< _chTLabel >|< ", " >|< _ppTCh >|< ")" _ -> "SemType " >|< _ppTCh >|< pp " nt => Proxy " >|< "(" >|< _chTLabel >|< ", nt)" {-# LINE 518 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule11 #-} {-# LINE 293 "./src-ag/AG2AspectAG.ag" #-} rule11 = \ _chLabel _chTLabel -> {-# LINE 293 "./src-ag/AG2AspectAG.ag" #-} [ _chLabel , _chTLabel ] {-# LINE 524 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule12 #-} {-# LINE 451 "./src-ag/AG2AspectAG.ag" #-} rule12 = \ ((_lhsIppNt) :: PP_Doc) ((_lhsIppProd) :: PP_Doc) name_ -> {-# LINE 451 "./src-ag/AG2AspectAG.ag" #-} let chName = ppListSep "" "" "_" [pp name_, _lhsIppNt, _lhsIppProd] in pp name_ >|< " <- at ch_" >|< chName {-# LINE 531 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule13 #-} {-# LINE 489 "./src-ag/AG2AspectAG.ag" #-} rule13 = \ name_ tp_ -> {-# LINE 489 "./src-ag/AG2AspectAG.ag" #-} [ (name_, removeDeforested tp_ ) ] {-# LINE 537 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule14 #-} {-# LINE 827 "./src-ag/AG2AspectAG.ag" #-} rule14 = \ _chLabel kind_ name_ tp_ -> {-# LINE 827 "./src-ag/AG2AspectAG.ag" #-} let semC = if (isNonterminal tp_) then "sem_" >|< ppShow tp_ >|< " _" >|< name_ else "sem_Lit _" >|< name_ in case kind_ of ChildSyntax -> [(name_, ( _chLabel >|< " .=. (" >|< semC >|< ") .*. " , _chLabel >|< " .=. _" >|< name_ >|< " .*. "))] _ -> [] {-# LINE 550 "dist/build/AG2AspectAG.hs"#-} -- Children ---------------------------------------------------- -- wrapper data Inh_Children = Inh_Children { ext_Inh_Children :: (Maybe String), inhMap_Inh_Children :: (Map Identifier Attributes), inhNoGroup_Inh_Children :: ([String]), newAtts_Inh_Children :: ( Attributes ), o_noGroup_Inh_Children :: ([String]), o_rename_Inh_Children :: (Bool), ppNt_Inh_Children :: (PP_Doc), ppProd_Inh_Children :: (PP_Doc), synMap_Inh_Children :: (Map Identifier Attributes), synNoGroup_Inh_Children :: ([String]) } data Syn_Children = Syn_Children { idCL_Syn_Children :: ([(Identifier,Type)]), ppCSF_Syn_Children :: ([(Identifier,(PP_Doc,PP_Doc))]), ppDL_Syn_Children :: ([PP_Doc]), ppL_Syn_Children :: (PP_Doc), ppLI_Syn_Children :: ([PP_Doc]), ppR_Syn_Children :: (PP_Doc), prdInh_Syn_Children :: (Attributes) } {-# INLINABLE wrap_Children #-} wrap_Children :: T_Children -> Inh_Children -> (Syn_Children ) wrap_Children (T_Children act) (Inh_Children _lhsIext _lhsIinhMap _lhsIinhNoGroup _lhsInewAtts _lhsIo_noGroup _lhsIo_rename _lhsIppNt _lhsIppProd _lhsIsynMap _lhsIsynNoGroup) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Children_vIn4 _lhsIext _lhsIinhMap _lhsIinhNoGroup _lhsInewAtts _lhsIo_noGroup _lhsIo_rename _lhsIppNt _lhsIppProd _lhsIsynMap _lhsIsynNoGroup (T_Children_vOut4 _lhsOidCL _lhsOppCSF _lhsOppDL _lhsOppL _lhsOppLI _lhsOppR _lhsOprdInh) <- return (inv_Children_s5 sem arg) return (Syn_Children _lhsOidCL _lhsOppCSF _lhsOppDL _lhsOppL _lhsOppLI _lhsOppR _lhsOprdInh) ) -- cata {-# NOINLINE sem_Children #-} sem_Children :: Children -> T_Children sem_Children list = Prelude.foldr sem_Children_Cons sem_Children_Nil (Prelude.map sem_Child list) -- semantic domain newtype T_Children = T_Children { attach_T_Children :: Identity (T_Children_s5 ) } newtype T_Children_s5 = C_Children_s5 { inv_Children_s5 :: (T_Children_v4 ) } data T_Children_s6 = C_Children_s6 type T_Children_v4 = (T_Children_vIn4 ) -> (T_Children_vOut4 ) data T_Children_vIn4 = T_Children_vIn4 (Maybe String) (Map Identifier Attributes) ([String]) ( Attributes ) ([String]) (Bool) (PP_Doc) (PP_Doc) (Map Identifier Attributes) ([String]) data T_Children_vOut4 = T_Children_vOut4 ([(Identifier,Type)]) ([(Identifier,(PP_Doc,PP_Doc))]) ([PP_Doc]) (PP_Doc) ([PP_Doc]) (PP_Doc) (Attributes) {-# NOINLINE sem_Children_Cons #-} sem_Children_Cons :: T_Child -> T_Children -> T_Children sem_Children_Cons arg_hd_ arg_tl_ = T_Children (return st5) where {-# NOINLINE st5 #-} st5 = let v4 :: T_Children_v4 v4 = \ (T_Children_vIn4 _lhsIext _lhsIinhMap _lhsIinhNoGroup _lhsInewAtts _lhsIo_noGroup _lhsIo_rename _lhsIppNt _lhsIppProd _lhsIsynMap _lhsIsynNoGroup) -> ( let _hdX2 = Control.Monad.Identity.runIdentity (attach_T_Child (arg_hd_)) _tlX5 = Control.Monad.Identity.runIdentity (attach_T_Children (arg_tl_)) (T_Child_vOut1 _hdIidCL _hdIppCSF _hdIppDL _hdIppL _hdIppLI _hdIppR _hdIprdInh) = inv_Child_s2 _hdX2 (T_Child_vIn1 _hdOext _hdOinhMap _hdOinhNoGroup _hdOnewAtts _hdOo_noGroup _hdOo_rename _hdOppNt _hdOppProd _hdOsynMap _hdOsynNoGroup) (T_Children_vOut4 _tlIidCL _tlIppCSF _tlIppDL _tlIppL _tlIppLI _tlIppR _tlIprdInh) = inv_Children_s5 _tlX5 (T_Children_vIn4 _tlOext _tlOinhMap _tlOinhNoGroup _tlOnewAtts _tlOo_noGroup _tlOo_rename _tlOppNt _tlOppProd _tlOsynMap _tlOsynNoGroup) _lhsOppDL :: [PP_Doc] _lhsOppDL = rule15 _hdIppDL _tlIppDL _lhsOidCL :: [(Identifier,Type)] _lhsOidCL = rule16 _hdIidCL _tlIidCL _lhsOppCSF :: [(Identifier,(PP_Doc,PP_Doc))] _lhsOppCSF = rule17 _hdIppCSF _tlIppCSF _lhsOppL :: PP_Doc _lhsOppL = rule18 _hdIppL _tlIppL _lhsOppLI :: [PP_Doc] _lhsOppLI = rule19 _hdIppLI _tlIppLI _lhsOppR :: PP_Doc _lhsOppR = rule20 _hdIppR _tlIppR _lhsOprdInh :: Attributes _lhsOprdInh = rule21 _hdIprdInh _tlIprdInh _hdOext = rule22 _lhsIext _hdOinhMap = rule23 _lhsIinhMap _hdOinhNoGroup = rule24 _lhsIinhNoGroup _hdOnewAtts = rule25 _lhsInewAtts _hdOo_noGroup = rule26 _lhsIo_noGroup _hdOo_rename = rule27 _lhsIo_rename _hdOppNt = rule28 _lhsIppNt _hdOppProd = rule29 _lhsIppProd _hdOsynMap = rule30 _lhsIsynMap _hdOsynNoGroup = rule31 _lhsIsynNoGroup _tlOext = rule32 _lhsIext _tlOinhMap = rule33 _lhsIinhMap _tlOinhNoGroup = rule34 _lhsIinhNoGroup _tlOnewAtts = rule35 _lhsInewAtts _tlOo_noGroup = rule36 _lhsIo_noGroup _tlOo_rename = rule37 _lhsIo_rename _tlOppNt = rule38 _lhsIppNt _tlOppProd = rule39 _lhsIppProd _tlOsynMap = rule40 _lhsIsynMap _tlOsynNoGroup = rule41 _lhsIsynNoGroup __result_ = T_Children_vOut4 _lhsOidCL _lhsOppCSF _lhsOppDL _lhsOppL _lhsOppLI _lhsOppR _lhsOprdInh in __result_ ) in C_Children_s5 v4 {-# INLINE rule15 #-} {-# LINE 238 "./src-ag/AG2AspectAG.ag" #-} rule15 = \ ((_hdIppDL) :: [PP_Doc]) ((_tlIppDL) :: [PP_Doc]) -> {-# LINE 238 "./src-ag/AG2AspectAG.ag" #-} _hdIppDL ++ _tlIppDL {-# LINE 635 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule16 #-} rule16 = \ ((_hdIidCL) :: [(Identifier,Type)]) ((_tlIidCL) :: [(Identifier,Type)]) -> _hdIidCL ++ _tlIidCL {-# INLINE rule17 #-} rule17 = \ ((_hdIppCSF) :: [(Identifier,(PP_Doc,PP_Doc))]) ((_tlIppCSF) :: [(Identifier,(PP_Doc,PP_Doc))]) -> _hdIppCSF ++ _tlIppCSF {-# INLINE rule18 #-} rule18 = \ ((_hdIppL) :: PP_Doc) ((_tlIppL) :: PP_Doc) -> _hdIppL >-< _tlIppL {-# INLINE rule19 #-} rule19 = \ ((_hdIppLI) :: [PP_Doc]) ((_tlIppLI) :: [PP_Doc]) -> _hdIppLI ++ _tlIppLI {-# INLINE rule20 #-} rule20 = \ ((_hdIppR) :: PP_Doc) ((_tlIppR) :: PP_Doc) -> _hdIppR >-< _tlIppR {-# INLINE rule21 #-} rule21 = \ ((_hdIprdInh) :: Attributes) ((_tlIprdInh) :: Attributes) -> _hdIprdInh `Map.union` _tlIprdInh {-# INLINE rule22 #-} rule22 = \ ((_lhsIext) :: Maybe String) -> _lhsIext {-# INLINE rule23 #-} rule23 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule24 #-} rule24 = \ ((_lhsIinhNoGroup) :: [String]) -> _lhsIinhNoGroup {-# INLINE rule25 #-} rule25 = \ ((_lhsInewAtts) :: Attributes ) -> _lhsInewAtts {-# INLINE rule26 #-} rule26 = \ ((_lhsIo_noGroup) :: [String]) -> _lhsIo_noGroup {-# INLINE rule27 #-} rule27 = \ ((_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# INLINE rule28 #-} rule28 = \ ((_lhsIppNt) :: PP_Doc) -> _lhsIppNt {-# INLINE rule29 #-} rule29 = \ ((_lhsIppProd) :: PP_Doc) -> _lhsIppProd {-# INLINE rule30 #-} rule30 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# INLINE rule31 #-} rule31 = \ ((_lhsIsynNoGroup) :: [String]) -> _lhsIsynNoGroup {-# INLINE rule32 #-} rule32 = \ ((_lhsIext) :: Maybe String) -> _lhsIext {-# INLINE rule33 #-} rule33 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule34 #-} rule34 = \ ((_lhsIinhNoGroup) :: [String]) -> _lhsIinhNoGroup {-# INLINE rule35 #-} rule35 = \ ((_lhsInewAtts) :: Attributes ) -> _lhsInewAtts {-# INLINE rule36 #-} rule36 = \ ((_lhsIo_noGroup) :: [String]) -> _lhsIo_noGroup {-# INLINE rule37 #-} rule37 = \ ((_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# INLINE rule38 #-} rule38 = \ ((_lhsIppNt) :: PP_Doc) -> _lhsIppNt {-# INLINE rule39 #-} rule39 = \ ((_lhsIppProd) :: PP_Doc) -> _lhsIppProd {-# INLINE rule40 #-} rule40 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# INLINE rule41 #-} rule41 = \ ((_lhsIsynNoGroup) :: [String]) -> _lhsIsynNoGroup {-# NOINLINE sem_Children_Nil #-} sem_Children_Nil :: T_Children sem_Children_Nil = T_Children (return st5) where {-# NOINLINE st5 #-} st5 = let v4 :: T_Children_v4 v4 = \ (T_Children_vIn4 _lhsIext _lhsIinhMap _lhsIinhNoGroup _lhsInewAtts _lhsIo_noGroup _lhsIo_rename _lhsIppNt _lhsIppProd _lhsIsynMap _lhsIsynNoGroup) -> ( let _lhsOppDL :: [PP_Doc] _lhsOppDL = rule42 () _lhsOidCL :: [(Identifier,Type)] _lhsOidCL = rule43 () _lhsOppCSF :: [(Identifier,(PP_Doc,PP_Doc))] _lhsOppCSF = rule44 () _lhsOppL :: PP_Doc _lhsOppL = rule45 () _lhsOppLI :: [PP_Doc] _lhsOppLI = rule46 () _lhsOppR :: PP_Doc _lhsOppR = rule47 () _lhsOprdInh :: Attributes _lhsOprdInh = rule48 () __result_ = T_Children_vOut4 _lhsOidCL _lhsOppCSF _lhsOppDL _lhsOppL _lhsOppLI _lhsOppR _lhsOprdInh in __result_ ) in C_Children_s5 v4 {-# INLINE rule42 #-} {-# LINE 239 "./src-ag/AG2AspectAG.ag" #-} rule42 = \ (_ :: ()) -> {-# LINE 239 "./src-ag/AG2AspectAG.ag" #-} [] {-# LINE 743 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule43 #-} rule43 = \ (_ :: ()) -> [] {-# INLINE rule44 #-} rule44 = \ (_ :: ()) -> [] {-# INLINE rule45 #-} rule45 = \ (_ :: ()) -> empty {-# INLINE rule46 #-} rule46 = \ (_ :: ()) -> [] {-# INLINE rule47 #-} rule47 = \ (_ :: ()) -> empty {-# INLINE rule48 #-} rule48 = \ (_ :: ()) -> Map.empty -- Expression -------------------------------------------------- -- wrapper data Inh_Expression = Inh_Expression { ppNt_Inh_Expression :: (PP_Doc), ppProd_Inh_Expression :: (PP_Doc) } data Syn_Expression = Syn_Expression { ppRE_Syn_Expression :: ([String] -> Identifier -> [(Identifier,Type)] -> [Identifier] -> PP_Doc) } {-# INLINABLE wrap_Expression #-} wrap_Expression :: T_Expression -> Inh_Expression -> (Syn_Expression ) wrap_Expression (T_Expression act) (Inh_Expression _lhsIppNt _lhsIppProd) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Expression_vIn7 _lhsIppNt _lhsIppProd (T_Expression_vOut7 _lhsOppRE) <- return (inv_Expression_s8 sem arg) return (Syn_Expression _lhsOppRE) ) -- cata {-# INLINE sem_Expression #-} sem_Expression :: Expression -> T_Expression sem_Expression ( Expression pos_ tks_ ) = sem_Expression_Expression pos_ tks_ -- semantic domain newtype T_Expression = T_Expression { attach_T_Expression :: Identity (T_Expression_s8 ) } newtype T_Expression_s8 = C_Expression_s8 { inv_Expression_s8 :: (T_Expression_v7 ) } data T_Expression_s9 = C_Expression_s9 type T_Expression_v7 = (T_Expression_vIn7 ) -> (T_Expression_vOut7 ) data T_Expression_vIn7 = T_Expression_vIn7 (PP_Doc) (PP_Doc) data T_Expression_vOut7 = T_Expression_vOut7 ([String] -> Identifier -> [(Identifier,Type)] -> [Identifier] -> PP_Doc) {-# NOINLINE sem_Expression_Expression #-} sem_Expression_Expression :: (Pos) -> ([HsToken]) -> T_Expression sem_Expression_Expression _ arg_tks_ = T_Expression (return st8) where {-# NOINLINE st8 #-} st8 = let v7 :: T_Expression_v7 v7 = \ (T_Expression_vIn7 _lhsIppNt _lhsIppProd) -> ( let _lhsOppRE :: [String] -> Identifier -> [(Identifier,Type)] -> [Identifier] -> PP_Doc _lhsOppRE = rule49 _lhsIppNt _lhsIppProd arg_tks_ __result_ = T_Expression_vOut7 _lhsOppRE in __result_ ) in C_Expression_s8 v7 {-# INLINE rule49 #-} {-# LINE 484 "./src-ag/AG2AspectAG.ag" #-} rule49 = \ ((_lhsIppNt) :: PP_Doc) ((_lhsIppProd) :: PP_Doc) tks_ -> {-# LINE 484 "./src-ag/AG2AspectAG.ag" #-} rhsRule _lhsIppNt _lhsIppProd tks_ {-# LINE 810 "dist/build/AG2AspectAG.hs"#-} -- Grammar ----------------------------------------------------- -- wrapper data Inh_Grammar = Inh_Grammar { agi_Inh_Grammar :: ((Set NontermIdent, DataTypes, Map NontermIdent (Attributes, Attributes))), ext_Inh_Grammar :: (Maybe String), options_Inh_Grammar :: (Options) } data Syn_Grammar = Syn_Grammar { imp_Syn_Grammar :: (PP_Doc), pp_Syn_Grammar :: (PP_Doc) } {-# INLINABLE wrap_Grammar #-} wrap_Grammar :: T_Grammar -> Inh_Grammar -> (Syn_Grammar ) wrap_Grammar (T_Grammar act) (Inh_Grammar _lhsIagi _lhsIext _lhsIoptions) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Grammar_vIn10 _lhsIagi _lhsIext _lhsIoptions (T_Grammar_vOut10 _lhsOimp _lhsOpp) <- return (inv_Grammar_s11 sem arg) return (Syn_Grammar _lhsOimp _lhsOpp) ) -- cata {-# INLINE sem_Grammar #-} sem_Grammar :: Grammar -> T_Grammar sem_Grammar ( Grammar typeSyns_ useMap_ derivings_ wrappers_ nonts_ pragmas_ manualAttrOrderMap_ paramMap_ contextMap_ quantMap_ uniqueMap_ augmentsMap_ aroundsMap_ mergeMap_ ) = sem_Grammar_Grammar typeSyns_ useMap_ derivings_ wrappers_ ( sem_Nonterminals nonts_ ) pragmas_ manualAttrOrderMap_ paramMap_ contextMap_ quantMap_ uniqueMap_ augmentsMap_ aroundsMap_ mergeMap_ -- semantic domain newtype T_Grammar = T_Grammar { attach_T_Grammar :: Identity (T_Grammar_s11 ) } newtype T_Grammar_s11 = C_Grammar_s11 { inv_Grammar_s11 :: (T_Grammar_v10 ) } data T_Grammar_s12 = C_Grammar_s12 type T_Grammar_v10 = (T_Grammar_vIn10 ) -> (T_Grammar_vOut10 ) data T_Grammar_vIn10 = T_Grammar_vIn10 ((Set NontermIdent, DataTypes, Map NontermIdent (Attributes, Attributes))) (Maybe String) (Options) data T_Grammar_vOut10 = T_Grammar_vOut10 (PP_Doc) (PP_Doc) {-# NOINLINE sem_Grammar_Grammar #-} sem_Grammar_Grammar :: (TypeSyns) -> (UseMap) -> (Derivings) -> (Set NontermIdent) -> T_Nonterminals -> (PragmaMap) -> (AttrOrderMap) -> (ParamMap) -> (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)))) -> T_Grammar sem_Grammar_Grammar arg_typeSyns_ _ arg_derivings_ _ arg_nonts_ _ _ _ _ _ _ _ _ _ = T_Grammar (return st11) where {-# NOINLINE st11 #-} st11 = let v10 :: T_Grammar_v10 v10 = \ (T_Grammar_vIn10 _lhsIagi _lhsIext _lhsIoptions) -> ( let _nontsX26 = Control.Monad.Identity.runIdentity (attach_T_Nonterminals (arg_nonts_)) (T_Nonterminals_vOut25 _nontsIextendedNTs _nontsIinhMap' _nontsIppA _nontsIppAI _nontsIppCata _nontsIppD _nontsIppDI _nontsIppL _nontsIppLI _nontsIppNtL _nontsIppR _nontsIppSF _nontsIppW _nontsIsynMap') = inv_Nonterminals_s26 _nontsX26 (T_Nonterminals_vIn25 _nontsOderivs _nontsOext _nontsOinhMap _nontsOnewAtts _nontsOnewNTs _nontsOnewProds _nontsOo_noGroup _nontsOo_rename _nontsOsynMap _nontsOtSyns) _nontsOinhMap = rule50 _nontsIinhMap' _nontsOsynMap = rule51 _nontsIsynMap' _nontsOo_rename = rule52 _lhsIoptions _o_noGroup = rule53 _lhsIoptions _nontsOo_noGroup = rule54 _o_noGroup _newAtts = rule55 _lhsIagi _nontsOnewAtts = rule56 _newAtts _newProds = rule57 _lhsIagi _nontsOnewProds = rule58 _newProds _nontsOnewNTs = rule59 _lhsIagi _nontsIextendedNTs _lhsOimp :: PP_Doc _lhsOimp = rule60 _lhsIext _nontsIppDI _nontsIppLI _ppAI _ppANT _lhsOpp :: PP_Doc _lhsOpp = rule61 _lhsIoptions _nontsIppCata _nontsIppD _nontsIppL _nontsIppSF _nontsIppW _ppA _ppR _nontsOderivs = rule62 arg_derivings_ _nontsOtSyns = rule63 arg_typeSyns_ _ppA = rule64 _lhsIext _newAtts _nontsIppA _o_noGroup _ppAI = rule65 _lhsIext _newAtts _nontsIppAI _o_noGroup _ppANT = rule66 _newAtts _o_noGroup _ppNtL = rule67 _nontsIppNtL _ppR = rule68 _newAtts _nontsIppR _o_noGroup _ppNtL _nontsOext = rule69 _lhsIext __result_ = T_Grammar_vOut10 _lhsOimp _lhsOpp in __result_ ) in C_Grammar_s11 v10 {-# INLINE rule50 #-} {-# LINE 15 "./src-ag/DistChildAttr.ag" #-} rule50 = \ ((_nontsIinhMap') :: Map Identifier Attributes) -> {-# LINE 15 "./src-ag/DistChildAttr.ag" #-} _nontsIinhMap' {-# LINE 881 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule51 #-} {-# LINE 16 "./src-ag/DistChildAttr.ag" #-} rule51 = \ ((_nontsIsynMap') :: Map Identifier Attributes) -> {-# LINE 16 "./src-ag/DistChildAttr.ag" #-} _nontsIsynMap' {-# LINE 887 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule52 #-} {-# LINE 43 "./src-ag/AG2AspectAG.ag" #-} rule52 = \ ((_lhsIoptions) :: Options) -> {-# LINE 43 "./src-ag/AG2AspectAG.ag" #-} rename _lhsIoptions {-# LINE 893 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule53 #-} {-# LINE 47 "./src-ag/AG2AspectAG.ag" #-} rule53 = \ ((_lhsIoptions) :: Options) -> {-# LINE 47 "./src-ag/AG2AspectAG.ag" #-} sort $ noGroup _lhsIoptions {-# LINE 899 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule54 #-} {-# LINE 48 "./src-ag/AG2AspectAG.ag" #-} rule54 = \ _o_noGroup -> {-# LINE 48 "./src-ag/AG2AspectAG.ag" #-} _o_noGroup {-# LINE 905 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule55 #-} {-# LINE 80 "./src-ag/AG2AspectAG.ag" #-} rule55 = \ ((_lhsIagi) :: (Set NontermIdent, DataTypes, Map NontermIdent (Attributes, Attributes))) -> {-# LINE 80 "./src-ag/AG2AspectAG.ag" #-} case _lhsIagi of (_,_,atts) -> ( Map.unions . (\(a,b) -> a++b) . unzip . Map.elems) atts {-# LINE 912 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule56 #-} {-# LINE 82 "./src-ag/AG2AspectAG.ag" #-} rule56 = \ _newAtts -> {-# LINE 82 "./src-ag/AG2AspectAG.ag" #-} _newAtts {-# LINE 918 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule57 #-} {-# LINE 88 "./src-ag/AG2AspectAG.ag" #-} rule57 = \ ((_lhsIagi) :: (Set NontermIdent, DataTypes, Map NontermIdent (Attributes, Attributes))) -> {-# LINE 88 "./src-ag/AG2AspectAG.ag" #-} case _lhsIagi of (_,prods,_) -> prods {-# LINE 925 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule58 #-} {-# LINE 90 "./src-ag/AG2AspectAG.ag" #-} rule58 = \ _newProds -> {-# LINE 90 "./src-ag/AG2AspectAG.ag" #-} _newProds {-# LINE 931 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule59 #-} {-# LINE 112 "./src-ag/AG2AspectAG.ag" #-} rule59 = \ ((_lhsIagi) :: (Set NontermIdent, DataTypes, Map NontermIdent (Attributes, Attributes))) ((_nontsIextendedNTs) :: Set NontermIdent) -> {-# LINE 112 "./src-ag/AG2AspectAG.ag" #-} case _lhsIagi of (newNTs,_,_) -> Set.difference newNTs _nontsIextendedNTs {-# LINE 938 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule60 #-} {-# LINE 127 "./src-ag/AG2AspectAG.ag" #-} rule60 = \ ((_lhsIext) :: Maybe String) ((_nontsIppDI) :: [PP_Doc]) ((_nontsIppLI) :: [PP_Doc]) _ppAI _ppANT -> {-# LINE 127 "./src-ag/AG2AspectAG.ag" #-} "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" >#<) _lhsIext >-< maybe empty (\ext -> "import" >#< ext >#< ppListSep "(" ")" "," (_nontsIppDI ++ _nontsIppLI ++ _ppAI ++ _ppANT )) _lhsIext {-# LINE 950 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule61 #-} {-# LINE 140 "./src-ag/AG2AspectAG.ag" #-} rule61 = \ ((_lhsIoptions) :: Options) ((_nontsIppCata) :: PP_Doc) ((_nontsIppD) :: PP_Doc) ((_nontsIppL) :: PP_Doc) ((_nontsIppSF) :: PP_Doc) ((_nontsIppW) :: PP_Doc) _ppA _ppR -> {-# LINE 140 "./src-ag/AG2AspectAG.ag" #-} (if dataTypes _lhsIoptions then "-- datatypes" >-< _nontsIppD >-< "-- labels" >-< _nontsIppL else empty) >-< (if folds _lhsIoptions then "-- attributes" >-< _ppA >-< "-- rules" >-< _ppR >-< "-- catas" >-< _nontsIppCata else empty) >-< (if semfuns _lhsIoptions then "-- semantic functions" >-< _nontsIppSF else empty) >-< (if wrappers _lhsIoptions then "-- wrappers" >-< _nontsIppW else empty) {-# LINE 973 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule62 #-} {-# LINE 202 "./src-ag/AG2AspectAG.ag" #-} rule62 = \ derivings_ -> {-# LINE 202 "./src-ag/AG2AspectAG.ag" #-} derivings_ {-# LINE 979 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule63 #-} {-# LINE 251 "./src-ag/AG2AspectAG.ag" #-} rule63 = \ typeSyns_ -> {-# LINE 251 "./src-ag/AG2AspectAG.ag" #-} typeSyns_ {-# LINE 985 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule64 #-} {-# LINE 300 "./src-ag/AG2AspectAG.ag" #-} rule64 = \ ((_lhsIext) :: Maybe String) _newAtts ((_nontsIppA) :: PP_Doc) _o_noGroup -> {-# LINE 300 "./src-ag/AG2AspectAG.ag" #-} vlist (map defAtt (filterAtts _newAtts _o_noGroup )) >-< defAtt "loc" >-< (case _lhsIext of Nothing -> defAtt "inh" >-< defAtt "syn" otherwise -> empty) >-< _nontsIppA {-# LINE 996 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule65 #-} {-# LINE 308 "./src-ag/AG2AspectAG.ag" #-} rule65 = \ ((_lhsIext) :: Maybe String) _newAtts ((_nontsIppAI) :: [PP_Doc]) _o_noGroup -> {-# LINE 308 "./src-ag/AG2AspectAG.ag" #-} let atts = filterNotAtts _newAtts _o_noGroup in (foldr (\a as -> attName a : as) [] atts) ++ (foldr (\a as -> attTName a : as) [] atts) ++ (case _lhsIext of Nothing -> [] otherwise -> [ attName "inh", attName "syn", attTName "inh", attTName "syn" ]) ++ _nontsIppAI {-# LINE 1008 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule66 #-} {-# LINE 318 "./src-ag/AG2AspectAG.ag" #-} rule66 = \ _newAtts _o_noGroup -> {-# LINE 318 "./src-ag/AG2AspectAG.ag" #-} let atts = filterNotAtts _newAtts _o_noGroup in (foldr (\a as -> ("nts_" >|< a) : as) [] atts) {-# LINE 1015 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule67 #-} {-# LINE 392 "./src-ag/AG2AspectAG.ag" #-} rule67 = \ ((_nontsIppNtL) :: [(PP_Doc, Attributes)]) -> {-# LINE 392 "./src-ag/AG2AspectAG.ag" #-} _nontsIppNtL {-# LINE 1021 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule68 #-} {-# LINE 393 "./src-ag/AG2AspectAG.ag" #-} rule68 = \ _newAtts ((_nontsIppR) :: PP_Doc) _o_noGroup _ppNtL -> {-# LINE 393 "./src-ag/AG2AspectAG.ag" #-} ntsList "group" _ppNtL >-< vlist (map (\att -> ntsList att (filterNts att _ppNtL )) (filterAtts _newAtts _o_noGroup )) >-< _nontsIppR {-# LINE 1029 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule69 #-} rule69 = \ ((_lhsIext) :: Maybe String) -> _lhsIext -- HsToken ----------------------------------------------------- -- wrapper data Inh_HsToken = Inh_HsToken { } data Syn_HsToken = Syn_HsToken { } {-# INLINABLE wrap_HsToken #-} wrap_HsToken :: T_HsToken -> Inh_HsToken -> (Syn_HsToken ) wrap_HsToken (T_HsToken act) (Inh_HsToken ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_HsToken_vIn13 (T_HsToken_vOut13 ) <- return (inv_HsToken_s14 sem arg) return (Syn_HsToken ) ) -- cata {-# NOINLINE sem_HsToken #-} sem_HsToken :: HsToken -> T_HsToken sem_HsToken ( AGLocal var_ pos_ rdesc_ ) = sem_HsToken_AGLocal var_ pos_ rdesc_ sem_HsToken ( AGField field_ attr_ pos_ rdesc_ ) = sem_HsToken_AGField field_ attr_ pos_ rdesc_ sem_HsToken ( HsToken value_ pos_ ) = sem_HsToken_HsToken value_ pos_ sem_HsToken ( CharToken value_ pos_ ) = sem_HsToken_CharToken value_ pos_ sem_HsToken ( StrToken value_ pos_ ) = sem_HsToken_StrToken value_ pos_ sem_HsToken ( Err mesg_ pos_ ) = sem_HsToken_Err mesg_ pos_ -- semantic domain newtype T_HsToken = T_HsToken { attach_T_HsToken :: Identity (T_HsToken_s14 ) } newtype T_HsToken_s14 = C_HsToken_s14 { inv_HsToken_s14 :: (T_HsToken_v13 ) } data T_HsToken_s15 = C_HsToken_s15 type T_HsToken_v13 = (T_HsToken_vIn13 ) -> (T_HsToken_vOut13 ) data T_HsToken_vIn13 = T_HsToken_vIn13 data T_HsToken_vOut13 = T_HsToken_vOut13 {-# NOINLINE sem_HsToken_AGLocal #-} sem_HsToken_AGLocal :: (Identifier) -> (Pos) -> (Maybe String) -> T_HsToken sem_HsToken_AGLocal _ _ _ = T_HsToken (return st14) where {-# NOINLINE st14 #-} st14 = let v13 :: T_HsToken_v13 v13 = \ (T_HsToken_vIn13 ) -> ( let __result_ = T_HsToken_vOut13 in __result_ ) in C_HsToken_s14 v13 {-# NOINLINE sem_HsToken_AGField #-} sem_HsToken_AGField :: (Identifier) -> (Identifier) -> (Pos) -> (Maybe String) -> T_HsToken sem_HsToken_AGField _ _ _ _ = T_HsToken (return st14) where {-# NOINLINE st14 #-} st14 = let v13 :: T_HsToken_v13 v13 = \ (T_HsToken_vIn13 ) -> ( let __result_ = T_HsToken_vOut13 in __result_ ) in C_HsToken_s14 v13 {-# NOINLINE sem_HsToken_HsToken #-} sem_HsToken_HsToken :: (String) -> (Pos) -> T_HsToken sem_HsToken_HsToken _ _ = T_HsToken (return st14) where {-# NOINLINE st14 #-} st14 = let v13 :: T_HsToken_v13 v13 = \ (T_HsToken_vIn13 ) -> ( let __result_ = T_HsToken_vOut13 in __result_ ) in C_HsToken_s14 v13 {-# NOINLINE sem_HsToken_CharToken #-} sem_HsToken_CharToken :: (String) -> (Pos) -> T_HsToken sem_HsToken_CharToken _ _ = T_HsToken (return st14) where {-# NOINLINE st14 #-} st14 = let v13 :: T_HsToken_v13 v13 = \ (T_HsToken_vIn13 ) -> ( let __result_ = T_HsToken_vOut13 in __result_ ) in C_HsToken_s14 v13 {-# NOINLINE sem_HsToken_StrToken #-} sem_HsToken_StrToken :: (String) -> (Pos) -> T_HsToken sem_HsToken_StrToken _ _ = T_HsToken (return st14) where {-# NOINLINE st14 #-} st14 = let v13 :: T_HsToken_v13 v13 = \ (T_HsToken_vIn13 ) -> ( let __result_ = T_HsToken_vOut13 in __result_ ) in C_HsToken_s14 v13 {-# NOINLINE sem_HsToken_Err #-} sem_HsToken_Err :: (String) -> (Pos) -> T_HsToken sem_HsToken_Err _ _ = T_HsToken (return st14) where {-# NOINLINE st14 #-} st14 = let v13 :: T_HsToken_v13 v13 = \ (T_HsToken_vIn13 ) -> ( let __result_ = T_HsToken_vOut13 in __result_ ) in C_HsToken_s14 v13 -- HsTokens ---------------------------------------------------- -- wrapper data Inh_HsTokens = Inh_HsTokens { } data Syn_HsTokens = Syn_HsTokens { } {-# INLINABLE wrap_HsTokens #-} wrap_HsTokens :: T_HsTokens -> Inh_HsTokens -> (Syn_HsTokens ) wrap_HsTokens (T_HsTokens act) (Inh_HsTokens ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_HsTokens_vIn16 (T_HsTokens_vOut16 ) <- return (inv_HsTokens_s17 sem arg) return (Syn_HsTokens ) ) -- cata {-# NOINLINE sem_HsTokens #-} sem_HsTokens :: HsTokens -> T_HsTokens sem_HsTokens list = Prelude.foldr sem_HsTokens_Cons sem_HsTokens_Nil (Prelude.map sem_HsToken list) -- semantic domain newtype T_HsTokens = T_HsTokens { attach_T_HsTokens :: Identity (T_HsTokens_s17 ) } newtype T_HsTokens_s17 = C_HsTokens_s17 { inv_HsTokens_s17 :: (T_HsTokens_v16 ) } data T_HsTokens_s18 = C_HsTokens_s18 type T_HsTokens_v16 = (T_HsTokens_vIn16 ) -> (T_HsTokens_vOut16 ) data T_HsTokens_vIn16 = T_HsTokens_vIn16 data T_HsTokens_vOut16 = T_HsTokens_vOut16 {-# NOINLINE sem_HsTokens_Cons #-} sem_HsTokens_Cons :: T_HsToken -> T_HsTokens -> T_HsTokens sem_HsTokens_Cons arg_hd_ arg_tl_ = T_HsTokens (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_HsTokens_v16 v16 = \ (T_HsTokens_vIn16 ) -> ( let _hdX14 = Control.Monad.Identity.runIdentity (attach_T_HsToken (arg_hd_)) _tlX17 = Control.Monad.Identity.runIdentity (attach_T_HsTokens (arg_tl_)) (T_HsToken_vOut13 ) = inv_HsToken_s14 _hdX14 (T_HsToken_vIn13 ) (T_HsTokens_vOut16 ) = inv_HsTokens_s17 _tlX17 (T_HsTokens_vIn16 ) __result_ = T_HsTokens_vOut16 in __result_ ) in C_HsTokens_s17 v16 {-# NOINLINE sem_HsTokens_Nil #-} sem_HsTokens_Nil :: T_HsTokens sem_HsTokens_Nil = T_HsTokens (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_HsTokens_v16 v16 = \ (T_HsTokens_vIn16 ) -> ( let __result_ = T_HsTokens_vOut16 in __result_ ) in C_HsTokens_s17 v16 -- HsTokensRoot ------------------------------------------------ -- wrapper data Inh_HsTokensRoot = Inh_HsTokensRoot { } data Syn_HsTokensRoot = Syn_HsTokensRoot { } {-# INLINABLE wrap_HsTokensRoot #-} wrap_HsTokensRoot :: T_HsTokensRoot -> Inh_HsTokensRoot -> (Syn_HsTokensRoot ) wrap_HsTokensRoot (T_HsTokensRoot act) (Inh_HsTokensRoot ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_HsTokensRoot_vIn19 (T_HsTokensRoot_vOut19 ) <- return (inv_HsTokensRoot_s20 sem arg) return (Syn_HsTokensRoot ) ) -- cata {-# INLINE sem_HsTokensRoot #-} sem_HsTokensRoot :: HsTokensRoot -> T_HsTokensRoot sem_HsTokensRoot ( HsTokensRoot tokens_ ) = sem_HsTokensRoot_HsTokensRoot ( sem_HsTokens tokens_ ) -- semantic domain newtype T_HsTokensRoot = T_HsTokensRoot { attach_T_HsTokensRoot :: Identity (T_HsTokensRoot_s20 ) } newtype T_HsTokensRoot_s20 = C_HsTokensRoot_s20 { inv_HsTokensRoot_s20 :: (T_HsTokensRoot_v19 ) } data T_HsTokensRoot_s21 = C_HsTokensRoot_s21 type T_HsTokensRoot_v19 = (T_HsTokensRoot_vIn19 ) -> (T_HsTokensRoot_vOut19 ) data T_HsTokensRoot_vIn19 = T_HsTokensRoot_vIn19 data T_HsTokensRoot_vOut19 = T_HsTokensRoot_vOut19 {-# NOINLINE sem_HsTokensRoot_HsTokensRoot #-} sem_HsTokensRoot_HsTokensRoot :: T_HsTokens -> T_HsTokensRoot sem_HsTokensRoot_HsTokensRoot arg_tokens_ = T_HsTokensRoot (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_HsTokensRoot_v19 v19 = \ (T_HsTokensRoot_vIn19 ) -> ( let _tokensX17 = Control.Monad.Identity.runIdentity (attach_T_HsTokens (arg_tokens_)) (T_HsTokens_vOut16 ) = inv_HsTokens_s17 _tokensX17 (T_HsTokens_vIn16 ) __result_ = T_HsTokensRoot_vOut19 in __result_ ) in C_HsTokensRoot_s20 v19 -- Nonterminal ------------------------------------------------- -- wrapper data Inh_Nonterminal = Inh_Nonterminal { derivs_Inh_Nonterminal :: (Derivings), ext_Inh_Nonterminal :: (Maybe String), inhMap_Inh_Nonterminal :: (Map Identifier Attributes), newAtts_Inh_Nonterminal :: ( Attributes ), newNTs_Inh_Nonterminal :: (Set NontermIdent), newProds_Inh_Nonterminal :: ( DataTypes ), o_noGroup_Inh_Nonterminal :: ([String]), o_rename_Inh_Nonterminal :: (Bool), synMap_Inh_Nonterminal :: (Map Identifier Attributes), tSyns_Inh_Nonterminal :: (TypeSyns) } data Syn_Nonterminal = Syn_Nonterminal { extendedNTs_Syn_Nonterminal :: (Set NontermIdent), inhMap'_Syn_Nonterminal :: (Map Identifier Attributes), ppA_Syn_Nonterminal :: (PP_Doc), ppAI_Syn_Nonterminal :: ([PP_Doc]), ppCata_Syn_Nonterminal :: (PP_Doc), ppD_Syn_Nonterminal :: (PP_Doc), ppDI_Syn_Nonterminal :: ([PP_Doc]), ppL_Syn_Nonterminal :: (PP_Doc), ppLI_Syn_Nonterminal :: ([PP_Doc]), ppNtL_Syn_Nonterminal :: ([(PP_Doc, Attributes)]), ppR_Syn_Nonterminal :: (PP_Doc), ppSF_Syn_Nonterminal :: (PP_Doc), ppW_Syn_Nonterminal :: (PP_Doc), synMap'_Syn_Nonterminal :: (Map Identifier Attributes) } {-# INLINABLE wrap_Nonterminal #-} wrap_Nonterminal :: T_Nonterminal -> Inh_Nonterminal -> (Syn_Nonterminal ) wrap_Nonterminal (T_Nonterminal act) (Inh_Nonterminal _lhsIderivs _lhsIext _lhsIinhMap _lhsInewAtts _lhsInewNTs _lhsInewProds _lhsIo_noGroup _lhsIo_rename _lhsIsynMap _lhsItSyns) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Nonterminal_vIn22 _lhsIderivs _lhsIext _lhsIinhMap _lhsInewAtts _lhsInewNTs _lhsInewProds _lhsIo_noGroup _lhsIo_rename _lhsIsynMap _lhsItSyns (T_Nonterminal_vOut22 _lhsOextendedNTs _lhsOinhMap' _lhsOppA _lhsOppAI _lhsOppCata _lhsOppD _lhsOppDI _lhsOppL _lhsOppLI _lhsOppNtL _lhsOppR _lhsOppSF _lhsOppW _lhsOsynMap') <- return (inv_Nonterminal_s23 sem arg) return (Syn_Nonterminal _lhsOextendedNTs _lhsOinhMap' _lhsOppA _lhsOppAI _lhsOppCata _lhsOppD _lhsOppDI _lhsOppL _lhsOppLI _lhsOppNtL _lhsOppR _lhsOppSF _lhsOppW _lhsOsynMap') ) -- cata {-# INLINE sem_Nonterminal #-} sem_Nonterminal :: Nonterminal -> T_Nonterminal sem_Nonterminal ( Nonterminal nt_ params_ inh_ syn_ prods_ ) = sem_Nonterminal_Nonterminal nt_ params_ inh_ syn_ ( sem_Productions prods_ ) -- semantic domain newtype T_Nonterminal = T_Nonterminal { attach_T_Nonterminal :: Identity (T_Nonterminal_s23 ) } newtype T_Nonterminal_s23 = C_Nonterminal_s23 { inv_Nonterminal_s23 :: (T_Nonterminal_v22 ) } data T_Nonterminal_s24 = C_Nonterminal_s24 type T_Nonterminal_v22 = (T_Nonterminal_vIn22 ) -> (T_Nonterminal_vOut22 ) data T_Nonterminal_vIn22 = T_Nonterminal_vIn22 (Derivings) (Maybe String) (Map Identifier Attributes) ( Attributes ) (Set NontermIdent) ( DataTypes ) ([String]) (Bool) (Map Identifier Attributes) (TypeSyns) data T_Nonterminal_vOut22 = T_Nonterminal_vOut22 (Set NontermIdent) (Map Identifier Attributes) (PP_Doc) ([PP_Doc]) (PP_Doc) (PP_Doc) ([PP_Doc]) (PP_Doc) ([PP_Doc]) ([(PP_Doc, Attributes)]) (PP_Doc) (PP_Doc) (PP_Doc) (Map Identifier Attributes) {-# NOINLINE sem_Nonterminal_Nonterminal #-} sem_Nonterminal_Nonterminal :: (NontermIdent) -> ([Identifier]) -> (Attributes) -> (Attributes) -> T_Productions -> T_Nonterminal sem_Nonterminal_Nonterminal arg_nt_ _ arg_inh_ arg_syn_ arg_prods_ = T_Nonterminal (return st23) where {-# NOINLINE st23 #-} st23 = let v22 :: T_Nonterminal_v22 v22 = \ (T_Nonterminal_vIn22 _lhsIderivs _lhsIext _lhsIinhMap _lhsInewAtts _lhsInewNTs _lhsInewProds _lhsIo_noGroup _lhsIo_rename _lhsIsynMap _lhsItSyns) -> ( let _prodsX38 = Control.Monad.Identity.runIdentity (attach_T_Productions (arg_prods_)) (T_Productions_vOut37 _prodsIhasMoreProds _prodsIppA _prodsIppCata _prodsIppDL _prodsIppL _prodsIppLI _prodsIppR _prodsIppRA _prodsIppSF _prodsIppSPF _prodsIprdInh) = inv_Productions_s38 _prodsX38 (T_Productions_vIn37 _prodsOext _prodsOinh _prodsOinhMap _prodsOinhNoGroup _prodsOnewAtts _prodsOnewNT _prodsOnewProds _prodsOo_noGroup _prodsOo_rename _prodsOppNt _prodsOsyn _prodsOsynMap _prodsOsynNoGroup) _lhsOinhMap' :: Map Identifier Attributes _lhsOinhMap' = rule70 arg_inh_ arg_nt_ _lhsOsynMap' :: Map Identifier Attributes _lhsOsynMap' = rule71 arg_nt_ arg_syn_ _inhNoGroup = rule72 _lhsIo_noGroup _prodsIprdInh _synNoGroup = rule73 _lhsIo_noGroup arg_syn_ _prodsOinhNoGroup = rule74 _inhNoGroup _prodsOsynNoGroup = rule75 _synNoGroup _prodsOnewProds = rule76 _lhsInewProds arg_nt_ _lhsOextendedNTs :: Set NontermIdent _lhsOextendedNTs = rule77 _prodsIhasMoreProds arg_nt_ _ppNt = rule78 arg_nt_ _prodsOppNt = rule79 _ppNt _lhsOppD :: PP_Doc _lhsOppD = rule80 _lhsIderivs _lhsInewNTs _lhsItSyns _ppNt _prodsIppDL arg_nt_ _lhsOppDI :: [PP_Doc] _lhsOppDI = rule81 _lhsInewNTs _ppNt arg_nt_ _ntLabel = rule82 _ppNt _lhsOppL :: PP_Doc _lhsOppL = rule83 _lhsInewNTs _ntLabel _ppNt _prodsIppL arg_nt_ _lhsOppLI :: [PP_Doc] _lhsOppLI = rule84 _lhsInewNTs _ntLabel _prodsIppLI arg_nt_ _lhsOppA :: PP_Doc _lhsOppA = rule85 _inhNoGroup _lhsInewNTs _ppNt _prodsIppA _synNoGroup arg_inh_ arg_nt_ arg_syn_ _lhsOppAI :: [PP_Doc] _lhsOppAI = rule86 _lhsInewNTs _ppNt arg_nt_ _lhsOppNtL :: [(PP_Doc, Attributes)] _lhsOppNtL = rule87 arg_inh_ arg_nt_ arg_syn_ _prodsOnewNT = rule88 _lhsInewNTs arg_nt_ _lhsOppR :: PP_Doc _lhsOppR = rule89 _prodsIppR arg_nt_ _lhsOppCata :: PP_Doc _lhsOppCata = rule90 _ppNt _prodsIppCata _prodsOsyn = rule91 arg_syn_ _prodsOinh = rule92 arg_inh_ _lhsOppSF :: PP_Doc _lhsOppSF = rule93 _inhNoGroup _ppNt _prodsIppSPF _synNoGroup _lhsOppW :: PP_Doc _lhsOppW = rule94 _inhNoGroup _ppNt arg_inh_ _prodsOext = rule95 _lhsIext _prodsOinhMap = rule96 _lhsIinhMap _prodsOnewAtts = rule97 _lhsInewAtts _prodsOo_noGroup = rule98 _lhsIo_noGroup _prodsOo_rename = rule99 _lhsIo_rename _prodsOsynMap = rule100 _lhsIsynMap __result_ = T_Nonterminal_vOut22 _lhsOextendedNTs _lhsOinhMap' _lhsOppA _lhsOppAI _lhsOppCata _lhsOppD _lhsOppDI _lhsOppL _lhsOppLI _lhsOppNtL _lhsOppR _lhsOppSF _lhsOppW _lhsOsynMap' in __result_ ) in C_Nonterminal_s23 v22 {-# INLINE rule70 #-} {-# LINE 7 "./src-ag/DistChildAttr.ag" #-} rule70 = \ inh_ nt_ -> {-# LINE 7 "./src-ag/DistChildAttr.ag" #-} Map.singleton nt_ inh_ {-# LINE 1320 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule71 #-} {-# LINE 8 "./src-ag/DistChildAttr.ag" #-} rule71 = \ nt_ syn_ -> {-# LINE 8 "./src-ag/DistChildAttr.ag" #-} Map.singleton nt_ syn_ {-# LINE 1326 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule72 #-} {-# LINE 51 "./src-ag/AG2AspectAG.ag" #-} rule72 = \ ((_lhsIo_noGroup) :: [String]) ((_prodsIprdInh) :: Attributes) -> {-# LINE 51 "./src-ag/AG2AspectAG.ag" #-} Map.filterWithKey (\att _ -> elem (getName att) _lhsIo_noGroup) _prodsIprdInh {-# LINE 1332 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule73 #-} {-# LINE 52 "./src-ag/AG2AspectAG.ag" #-} rule73 = \ ((_lhsIo_noGroup) :: [String]) syn_ -> {-# LINE 52 "./src-ag/AG2AspectAG.ag" #-} Map.filterWithKey (\att _ -> elem (getName att) _lhsIo_noGroup) syn_ {-# LINE 1338 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule74 #-} {-# LINE 57 "./src-ag/AG2AspectAG.ag" #-} rule74 = \ _inhNoGroup -> {-# LINE 57 "./src-ag/AG2AspectAG.ag" #-} map show $ Map.keys _inhNoGroup {-# LINE 1344 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule75 #-} {-# LINE 58 "./src-ag/AG2AspectAG.ag" #-} rule75 = \ _synNoGroup -> {-# LINE 58 "./src-ag/AG2AspectAG.ag" #-} map show $ Map.keys _synNoGroup {-# LINE 1350 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule76 #-} {-# LINE 94 "./src-ag/AG2AspectAG.ag" #-} rule76 = \ ((_lhsInewProds) :: DataTypes ) nt_ -> {-# LINE 94 "./src-ag/AG2AspectAG.ag" #-} case Map.lookup nt_ _lhsInewProds of Just prds -> prds Nothing -> Map.empty {-# LINE 1358 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule77 #-} {-# LINE 107 "./src-ag/AG2AspectAG.ag" #-} rule77 = \ ((_prodsIhasMoreProds) :: Bool ) nt_ -> {-# LINE 107 "./src-ag/AG2AspectAG.ag" #-} if _prodsIhasMoreProds then Set.singleton nt_ else Set.empty {-# LINE 1366 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule78 #-} {-# LINE 173 "./src-ag/AG2AspectAG.ag" #-} rule78 = \ nt_ -> {-# LINE 173 "./src-ag/AG2AspectAG.ag" #-} pp nt_ {-# LINE 1372 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule79 #-} {-# LINE 190 "./src-ag/AG2AspectAG.ag" #-} rule79 = \ _ppNt -> {-# LINE 190 "./src-ag/AG2AspectAG.ag" #-} _ppNt {-# LINE 1378 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule80 #-} {-# LINE 209 "./src-ag/AG2AspectAG.ag" #-} rule80 = \ ((_lhsIderivs) :: Derivings) ((_lhsInewNTs) :: Set NontermIdent) ((_lhsItSyns) :: TypeSyns) _ppNt ((_prodsIppDL) :: [PP_Doc]) nt_ -> {-# LINE 209 "./src-ag/AG2AspectAG.ag" #-} if (Set.member nt_ _lhsInewNTs) then case (lookup nt_ _lhsItSyns) of Nothing -> "data " >|< _ppNt >|< " = " >|< vlist_sep " | " _prodsIppDL >-< case (Map.lookup nt_ _lhsIderivs) of Just ntds -> pp " deriving " >|< (ppListSep "(" ")" ", " $ Set.elems ntds) Nothing -> empty Just tp -> "type " >|< _ppNt >|< " = " >|< ppShow tp else empty {-# LINE 1392 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule81 #-} {-# LINE 222 "./src-ag/AG2AspectAG.ag" #-} rule81 = \ ((_lhsInewNTs) :: Set NontermIdent) _ppNt nt_ -> {-# LINE 222 "./src-ag/AG2AspectAG.ag" #-} if (not $ Set.member nt_ _lhsInewNTs) then [ _ppNt ] else [ ] {-# LINE 1400 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule82 #-} {-# LINE 262 "./src-ag/AG2AspectAG.ag" #-} rule82 = \ _ppNt -> {-# LINE 262 "./src-ag/AG2AspectAG.ag" #-} "nt_" >|< _ppNt {-# LINE 1406 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule83 #-} {-# LINE 264 "./src-ag/AG2AspectAG.ag" #-} rule83 = \ ((_lhsInewNTs) :: Set NontermIdent) _ntLabel _ppNt ((_prodsIppL) :: PP_Doc) nt_ -> {-# LINE 264 "./src-ag/AG2AspectAG.ag" #-} ( if (Set.member nt_ _lhsInewNTs) then _ntLabel >|< " = proxy :: Proxy " >|< _ppNt else empty) >-< _prodsIppL {-# LINE 1415 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule84 #-} {-# LINE 269 "./src-ag/AG2AspectAG.ag" #-} rule84 = \ ((_lhsInewNTs) :: Set NontermIdent) _ntLabel ((_prodsIppLI) :: [PP_Doc]) nt_ -> {-# LINE 269 "./src-ag/AG2AspectAG.ag" #-} ( if (not $ Set.member nt_ _lhsInewNTs) then [ _ntLabel ] else [ ]) ++ _prodsIppLI {-# LINE 1424 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule85 #-} {-# LINE 324 "./src-ag/AG2AspectAG.ag" #-} rule85 = \ _inhNoGroup ((_lhsInewNTs) :: Set NontermIdent) _ppNt ((_prodsIppA) :: PP_Doc) _synNoGroup inh_ nt_ syn_ -> {-# LINE 324 "./src-ag/AG2AspectAG.ag" #-} ( if (Set.member nt_ _lhsInewNTs) then defAttRec (pp "InhG") _ppNt inh_ _inhNoGroup >-< defAttRec (pp "SynG") _ppNt syn_ _synNoGroup else empty) >-< _prodsIppA {-# LINE 1435 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule86 #-} {-# LINE 338 "./src-ag/AG2AspectAG.ag" #-} rule86 = \ ((_lhsInewNTs) :: Set NontermIdent) _ppNt nt_ -> {-# LINE 338 "./src-ag/AG2AspectAG.ag" #-} if (not $ Set.member nt_ _lhsInewNTs) then [ ppName [(pp "InhG"), _ppNt ] >#< pp "(..)", ppName [(pp "SynG"), _ppNt ] >#< pp "(..)" ] else [ ] {-# LINE 1443 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule87 #-} {-# LINE 406 "./src-ag/AG2AspectAG.ag" #-} rule87 = \ inh_ nt_ syn_ -> {-# LINE 406 "./src-ag/AG2AspectAG.ag" #-} [ ("nt_" >|< nt_, Map.union inh_ syn_) ] {-# LINE 1449 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule88 #-} {-# LINE 415 "./src-ag/AG2AspectAG.ag" #-} rule88 = \ ((_lhsInewNTs) :: Set NontermIdent) nt_ -> {-# LINE 415 "./src-ag/AG2AspectAG.ag" #-} Set.member nt_ _lhsInewNTs {-# LINE 1455 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule89 #-} {-# LINE 425 "./src-ag/AG2AspectAG.ag" #-} rule89 = \ ((_prodsIppR) :: PP_Doc) nt_ -> {-# LINE 425 "./src-ag/AG2AspectAG.ag" #-} pp "----" >|< pp nt_ >-< _prodsIppR {-# LINE 1461 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule90 #-} {-# LINE 735 "./src-ag/AG2AspectAG.ag" #-} rule90 = \ _ppNt ((_prodsIppCata) :: PP_Doc) -> {-# LINE 735 "./src-ag/AG2AspectAG.ag" #-} "----" >|< _ppNt >-< _prodsIppCata {-# LINE 1467 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule91 #-} {-# LINE 766 "./src-ag/AG2AspectAG.ag" #-} rule91 = \ syn_ -> {-# LINE 766 "./src-ag/AG2AspectAG.ag" #-} syn_ {-# LINE 1473 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule92 #-} {-# LINE 767 "./src-ag/AG2AspectAG.ag" #-} rule92 = \ inh_ -> {-# LINE 767 "./src-ag/AG2AspectAG.ag" #-} inh_ {-# LINE 1479 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule93 #-} {-# LINE 779 "./src-ag/AG2AspectAG.ag" #-} rule93 = \ _inhNoGroup _ppNt ((_prodsIppSPF) :: PP_Doc) _synNoGroup -> {-# LINE 779 "./src-ag/AG2AspectAG.ag" #-} let inhAtts = attTypes _inhNoGroup synAtts = attTypes _synNoGroup in "----" >|< _ppNt >-< "type T_" >|< _ppNt >|< " = " >|< "(Record " >|< inhAtts >|< "(HCons (LVPair (Proxy Att_inh) InhG_" >|< _ppNt >|< ") HNil))" >|< replicate (length inhAtts) ")" >|< " -> " >|< "(Record " >|< synAtts >|< "(HCons (LVPair (Proxy Att_syn) SynG_" >|< _ppNt >|< ") HNil))" >|< replicate (length synAtts) ")" >-< "-- instance SemType T_" >|< _ppNt >|< " " >|< _ppNt >-< "-- sem_" >|< _ppNt >|< " :: " >|< _ppNt >|< " -> T_" >|< _ppNt >-< _prodsIppSPF {-# LINE 1500 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule94 #-} {-# LINE 847 "./src-ag/AG2AspectAG.ag" #-} rule94 = \ _inhNoGroup _ppNt inh_ -> {-# LINE 847 "./src-ag/AG2AspectAG.ag" #-} ppName [pp "wrap", _ppNt ] >|< " sem " >|< attVars inh_ >|< " = " >-< " sem " >|< attFields inh_ _inhNoGroup _ppNt {-# LINE 1507 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule95 #-} rule95 = \ ((_lhsIext) :: Maybe String) -> _lhsIext {-# INLINE rule96 #-} rule96 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule97 #-} rule97 = \ ((_lhsInewAtts) :: Attributes ) -> _lhsInewAtts {-# INLINE rule98 #-} rule98 = \ ((_lhsIo_noGroup) :: [String]) -> _lhsIo_noGroup {-# INLINE rule99 #-} rule99 = \ ((_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# INLINE rule100 #-} rule100 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap -- Nonterminals ------------------------------------------------ -- wrapper data Inh_Nonterminals = Inh_Nonterminals { derivs_Inh_Nonterminals :: (Derivings), ext_Inh_Nonterminals :: (Maybe String), inhMap_Inh_Nonterminals :: (Map Identifier Attributes), newAtts_Inh_Nonterminals :: ( Attributes ), newNTs_Inh_Nonterminals :: (Set NontermIdent), newProds_Inh_Nonterminals :: ( DataTypes ), o_noGroup_Inh_Nonterminals :: ([String]), o_rename_Inh_Nonterminals :: (Bool), synMap_Inh_Nonterminals :: (Map Identifier Attributes), tSyns_Inh_Nonterminals :: (TypeSyns) } data Syn_Nonterminals = Syn_Nonterminals { extendedNTs_Syn_Nonterminals :: (Set NontermIdent), inhMap'_Syn_Nonterminals :: (Map Identifier Attributes), ppA_Syn_Nonterminals :: (PP_Doc), ppAI_Syn_Nonterminals :: ([PP_Doc]), ppCata_Syn_Nonterminals :: (PP_Doc), ppD_Syn_Nonterminals :: (PP_Doc), ppDI_Syn_Nonterminals :: ([PP_Doc]), ppL_Syn_Nonterminals :: (PP_Doc), ppLI_Syn_Nonterminals :: ([PP_Doc]), ppNtL_Syn_Nonterminals :: ([(PP_Doc, Attributes)]), ppR_Syn_Nonterminals :: (PP_Doc), ppSF_Syn_Nonterminals :: (PP_Doc), ppW_Syn_Nonterminals :: (PP_Doc), synMap'_Syn_Nonterminals :: (Map Identifier Attributes) } {-# INLINABLE wrap_Nonterminals #-} wrap_Nonterminals :: T_Nonterminals -> Inh_Nonterminals -> (Syn_Nonterminals ) wrap_Nonterminals (T_Nonterminals act) (Inh_Nonterminals _lhsIderivs _lhsIext _lhsIinhMap _lhsInewAtts _lhsInewNTs _lhsInewProds _lhsIo_noGroup _lhsIo_rename _lhsIsynMap _lhsItSyns) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Nonterminals_vIn25 _lhsIderivs _lhsIext _lhsIinhMap _lhsInewAtts _lhsInewNTs _lhsInewProds _lhsIo_noGroup _lhsIo_rename _lhsIsynMap _lhsItSyns (T_Nonterminals_vOut25 _lhsOextendedNTs _lhsOinhMap' _lhsOppA _lhsOppAI _lhsOppCata _lhsOppD _lhsOppDI _lhsOppL _lhsOppLI _lhsOppNtL _lhsOppR _lhsOppSF _lhsOppW _lhsOsynMap') <- return (inv_Nonterminals_s26 sem arg) return (Syn_Nonterminals _lhsOextendedNTs _lhsOinhMap' _lhsOppA _lhsOppAI _lhsOppCata _lhsOppD _lhsOppDI _lhsOppL _lhsOppLI _lhsOppNtL _lhsOppR _lhsOppSF _lhsOppW _lhsOsynMap') ) -- cata {-# NOINLINE sem_Nonterminals #-} sem_Nonterminals :: Nonterminals -> T_Nonterminals sem_Nonterminals list = Prelude.foldr sem_Nonterminals_Cons sem_Nonterminals_Nil (Prelude.map sem_Nonterminal list) -- semantic domain newtype T_Nonterminals = T_Nonterminals { attach_T_Nonterminals :: Identity (T_Nonterminals_s26 ) } newtype T_Nonterminals_s26 = C_Nonterminals_s26 { inv_Nonterminals_s26 :: (T_Nonterminals_v25 ) } data T_Nonterminals_s27 = C_Nonterminals_s27 type T_Nonterminals_v25 = (T_Nonterminals_vIn25 ) -> (T_Nonterminals_vOut25 ) data T_Nonterminals_vIn25 = T_Nonterminals_vIn25 (Derivings) (Maybe String) (Map Identifier Attributes) ( Attributes ) (Set NontermIdent) ( DataTypes ) ([String]) (Bool) (Map Identifier Attributes) (TypeSyns) data T_Nonterminals_vOut25 = T_Nonterminals_vOut25 (Set NontermIdent) (Map Identifier Attributes) (PP_Doc) ([PP_Doc]) (PP_Doc) (PP_Doc) ([PP_Doc]) (PP_Doc) ([PP_Doc]) ([(PP_Doc, Attributes)]) (PP_Doc) (PP_Doc) (PP_Doc) (Map Identifier Attributes) {-# NOINLINE sem_Nonterminals_Cons #-} sem_Nonterminals_Cons :: T_Nonterminal -> T_Nonterminals -> T_Nonterminals sem_Nonterminals_Cons arg_hd_ arg_tl_ = T_Nonterminals (return st26) where {-# NOINLINE st26 #-} st26 = let v25 :: T_Nonterminals_v25 v25 = \ (T_Nonterminals_vIn25 _lhsIderivs _lhsIext _lhsIinhMap _lhsInewAtts _lhsInewNTs _lhsInewProds _lhsIo_noGroup _lhsIo_rename _lhsIsynMap _lhsItSyns) -> ( let _hdX23 = Control.Monad.Identity.runIdentity (attach_T_Nonterminal (arg_hd_)) _tlX26 = Control.Monad.Identity.runIdentity (attach_T_Nonterminals (arg_tl_)) (T_Nonterminal_vOut22 _hdIextendedNTs _hdIinhMap' _hdIppA _hdIppAI _hdIppCata _hdIppD _hdIppDI _hdIppL _hdIppLI _hdIppNtL _hdIppR _hdIppSF _hdIppW _hdIsynMap') = inv_Nonterminal_s23 _hdX23 (T_Nonterminal_vIn22 _hdOderivs _hdOext _hdOinhMap _hdOnewAtts _hdOnewNTs _hdOnewProds _hdOo_noGroup _hdOo_rename _hdOsynMap _hdOtSyns) (T_Nonterminals_vOut25 _tlIextendedNTs _tlIinhMap' _tlIppA _tlIppAI _tlIppCata _tlIppD _tlIppDI _tlIppL _tlIppLI _tlIppNtL _tlIppR _tlIppSF _tlIppW _tlIsynMap') = inv_Nonterminals_s26 _tlX26 (T_Nonterminals_vIn25 _tlOderivs _tlOext _tlOinhMap _tlOnewAtts _tlOnewNTs _tlOnewProds _tlOo_noGroup _tlOo_rename _tlOsynMap _tlOtSyns) _lhsOextendedNTs :: Set NontermIdent _lhsOextendedNTs = rule101 _hdIextendedNTs _tlIextendedNTs _lhsOinhMap' :: Map Identifier Attributes _lhsOinhMap' = rule102 _hdIinhMap' _tlIinhMap' _lhsOppA :: PP_Doc _lhsOppA = rule103 _hdIppA _tlIppA _lhsOppAI :: [PP_Doc] _lhsOppAI = rule104 _hdIppAI _tlIppAI _lhsOppCata :: PP_Doc _lhsOppCata = rule105 _hdIppCata _tlIppCata _lhsOppD :: PP_Doc _lhsOppD = rule106 _hdIppD _tlIppD _lhsOppDI :: [PP_Doc] _lhsOppDI = rule107 _hdIppDI _tlIppDI _lhsOppL :: PP_Doc _lhsOppL = rule108 _hdIppL _tlIppL _lhsOppLI :: [PP_Doc] _lhsOppLI = rule109 _hdIppLI _tlIppLI _lhsOppNtL :: [(PP_Doc, Attributes)] _lhsOppNtL = rule110 _hdIppNtL _tlIppNtL _lhsOppR :: PP_Doc _lhsOppR = rule111 _hdIppR _tlIppR _lhsOppSF :: PP_Doc _lhsOppSF = rule112 _hdIppSF _tlIppSF _lhsOppW :: PP_Doc _lhsOppW = rule113 _hdIppW _tlIppW _lhsOsynMap' :: Map Identifier Attributes _lhsOsynMap' = rule114 _hdIsynMap' _tlIsynMap' _hdOderivs = rule115 _lhsIderivs _hdOext = rule116 _lhsIext _hdOinhMap = rule117 _lhsIinhMap _hdOnewAtts = rule118 _lhsInewAtts _hdOnewNTs = rule119 _lhsInewNTs _hdOnewProds = rule120 _lhsInewProds _hdOo_noGroup = rule121 _lhsIo_noGroup _hdOo_rename = rule122 _lhsIo_rename _hdOsynMap = rule123 _lhsIsynMap _hdOtSyns = rule124 _lhsItSyns _tlOderivs = rule125 _lhsIderivs _tlOext = rule126 _lhsIext _tlOinhMap = rule127 _lhsIinhMap _tlOnewAtts = rule128 _lhsInewAtts _tlOnewNTs = rule129 _lhsInewNTs _tlOnewProds = rule130 _lhsInewProds _tlOo_noGroup = rule131 _lhsIo_noGroup _tlOo_rename = rule132 _lhsIo_rename _tlOsynMap = rule133 _lhsIsynMap _tlOtSyns = rule134 _lhsItSyns __result_ = T_Nonterminals_vOut25 _lhsOextendedNTs _lhsOinhMap' _lhsOppA _lhsOppAI _lhsOppCata _lhsOppD _lhsOppDI _lhsOppL _lhsOppLI _lhsOppNtL _lhsOppR _lhsOppSF _lhsOppW _lhsOsynMap' in __result_ ) in C_Nonterminals_s26 v25 {-# INLINE rule101 #-} rule101 = \ ((_hdIextendedNTs) :: Set NontermIdent) ((_tlIextendedNTs) :: Set NontermIdent) -> _hdIextendedNTs `Set.union` _tlIextendedNTs {-# INLINE rule102 #-} rule102 = \ ((_hdIinhMap') :: Map Identifier Attributes) ((_tlIinhMap') :: Map Identifier Attributes) -> _hdIinhMap' `Map.union` _tlIinhMap' {-# INLINE rule103 #-} rule103 = \ ((_hdIppA) :: PP_Doc) ((_tlIppA) :: PP_Doc) -> _hdIppA >-< _tlIppA {-# INLINE rule104 #-} rule104 = \ ((_hdIppAI) :: [PP_Doc]) ((_tlIppAI) :: [PP_Doc]) -> _hdIppAI ++ _tlIppAI {-# INLINE rule105 #-} rule105 = \ ((_hdIppCata) :: PP_Doc) ((_tlIppCata) :: PP_Doc) -> _hdIppCata >-< _tlIppCata {-# INLINE rule106 #-} rule106 = \ ((_hdIppD) :: PP_Doc) ((_tlIppD) :: PP_Doc) -> _hdIppD >-< _tlIppD {-# INLINE rule107 #-} rule107 = \ ((_hdIppDI) :: [PP_Doc]) ((_tlIppDI) :: [PP_Doc]) -> _hdIppDI ++ _tlIppDI {-# INLINE rule108 #-} rule108 = \ ((_hdIppL) :: PP_Doc) ((_tlIppL) :: PP_Doc) -> _hdIppL >-< _tlIppL {-# INLINE rule109 #-} rule109 = \ ((_hdIppLI) :: [PP_Doc]) ((_tlIppLI) :: [PP_Doc]) -> _hdIppLI ++ _tlIppLI {-# INLINE rule110 #-} rule110 = \ ((_hdIppNtL) :: [(PP_Doc, Attributes)]) ((_tlIppNtL) :: [(PP_Doc, Attributes)]) -> _hdIppNtL ++ _tlIppNtL {-# INLINE rule111 #-} rule111 = \ ((_hdIppR) :: PP_Doc) ((_tlIppR) :: PP_Doc) -> _hdIppR >-< _tlIppR {-# INLINE rule112 #-} rule112 = \ ((_hdIppSF) :: PP_Doc) ((_tlIppSF) :: PP_Doc) -> _hdIppSF >-< _tlIppSF {-# INLINE rule113 #-} rule113 = \ ((_hdIppW) :: PP_Doc) ((_tlIppW) :: PP_Doc) -> _hdIppW >-< _tlIppW {-# INLINE rule114 #-} rule114 = \ ((_hdIsynMap') :: Map Identifier Attributes) ((_tlIsynMap') :: Map Identifier Attributes) -> _hdIsynMap' `Map.union` _tlIsynMap' {-# INLINE rule115 #-} rule115 = \ ((_lhsIderivs) :: Derivings) -> _lhsIderivs {-# INLINE rule116 #-} rule116 = \ ((_lhsIext) :: Maybe String) -> _lhsIext {-# INLINE rule117 #-} rule117 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule118 #-} rule118 = \ ((_lhsInewAtts) :: Attributes ) -> _lhsInewAtts {-# INLINE rule119 #-} rule119 = \ ((_lhsInewNTs) :: Set NontermIdent) -> _lhsInewNTs {-# INLINE rule120 #-} rule120 = \ ((_lhsInewProds) :: DataTypes ) -> _lhsInewProds {-# INLINE rule121 #-} rule121 = \ ((_lhsIo_noGroup) :: [String]) -> _lhsIo_noGroup {-# INLINE rule122 #-} rule122 = \ ((_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# INLINE rule123 #-} rule123 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# INLINE rule124 #-} rule124 = \ ((_lhsItSyns) :: TypeSyns) -> _lhsItSyns {-# INLINE rule125 #-} rule125 = \ ((_lhsIderivs) :: Derivings) -> _lhsIderivs {-# INLINE rule126 #-} rule126 = \ ((_lhsIext) :: Maybe String) -> _lhsIext {-# INLINE rule127 #-} rule127 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule128 #-} rule128 = \ ((_lhsInewAtts) :: Attributes ) -> _lhsInewAtts {-# INLINE rule129 #-} rule129 = \ ((_lhsInewNTs) :: Set NontermIdent) -> _lhsInewNTs {-# INLINE rule130 #-} rule130 = \ ((_lhsInewProds) :: DataTypes ) -> _lhsInewProds {-# INLINE rule131 #-} rule131 = \ ((_lhsIo_noGroup) :: [String]) -> _lhsIo_noGroup {-# INLINE rule132 #-} rule132 = \ ((_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# INLINE rule133 #-} rule133 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# INLINE rule134 #-} rule134 = \ ((_lhsItSyns) :: TypeSyns) -> _lhsItSyns {-# NOINLINE sem_Nonterminals_Nil #-} sem_Nonterminals_Nil :: T_Nonterminals sem_Nonterminals_Nil = T_Nonterminals (return st26) where {-# NOINLINE st26 #-} st26 = let v25 :: T_Nonterminals_v25 v25 = \ (T_Nonterminals_vIn25 _lhsIderivs _lhsIext _lhsIinhMap _lhsInewAtts _lhsInewNTs _lhsInewProds _lhsIo_noGroup _lhsIo_rename _lhsIsynMap _lhsItSyns) -> ( let _lhsOextendedNTs :: Set NontermIdent _lhsOextendedNTs = rule135 () _lhsOinhMap' :: Map Identifier Attributes _lhsOinhMap' = rule136 () _lhsOppA :: PP_Doc _lhsOppA = rule137 () _lhsOppAI :: [PP_Doc] _lhsOppAI = rule138 () _lhsOppCata :: PP_Doc _lhsOppCata = rule139 () _lhsOppD :: PP_Doc _lhsOppD = rule140 () _lhsOppDI :: [PP_Doc] _lhsOppDI = rule141 () _lhsOppL :: PP_Doc _lhsOppL = rule142 () _lhsOppLI :: [PP_Doc] _lhsOppLI = rule143 () _lhsOppNtL :: [(PP_Doc, Attributes)] _lhsOppNtL = rule144 () _lhsOppR :: PP_Doc _lhsOppR = rule145 () _lhsOppSF :: PP_Doc _lhsOppSF = rule146 () _lhsOppW :: PP_Doc _lhsOppW = rule147 () _lhsOsynMap' :: Map Identifier Attributes _lhsOsynMap' = rule148 () __result_ = T_Nonterminals_vOut25 _lhsOextendedNTs _lhsOinhMap' _lhsOppA _lhsOppAI _lhsOppCata _lhsOppD _lhsOppDI _lhsOppL _lhsOppLI _lhsOppNtL _lhsOppR _lhsOppSF _lhsOppW _lhsOsynMap' in __result_ ) in C_Nonterminals_s26 v25 {-# INLINE rule135 #-} rule135 = \ (_ :: ()) -> Set.empty {-# INLINE rule136 #-} rule136 = \ (_ :: ()) -> Map.empty {-# INLINE rule137 #-} rule137 = \ (_ :: ()) -> empty {-# INLINE rule138 #-} rule138 = \ (_ :: ()) -> [] {-# INLINE rule139 #-} rule139 = \ (_ :: ()) -> empty {-# INLINE rule140 #-} rule140 = \ (_ :: ()) -> empty {-# INLINE rule141 #-} rule141 = \ (_ :: ()) -> [] {-# INLINE rule142 #-} rule142 = \ (_ :: ()) -> empty {-# INLINE rule143 #-} rule143 = \ (_ :: ()) -> [] {-# INLINE rule144 #-} rule144 = \ (_ :: ()) -> [] {-# INLINE rule145 #-} rule145 = \ (_ :: ()) -> empty {-# INLINE rule146 #-} rule146 = \ (_ :: ()) -> empty {-# INLINE rule147 #-} rule147 = \ (_ :: ()) -> empty {-# INLINE rule148 #-} rule148 = \ (_ :: ()) -> Map.empty -- Pattern ----------------------------------------------------- -- wrapper data Inh_Pattern = Inh_Pattern { } data Syn_Pattern = Syn_Pattern { copy_Syn_Pattern :: (Pattern), info_Syn_Pattern :: ((Identifier, Identifier)) } {-# INLINABLE wrap_Pattern #-} wrap_Pattern :: T_Pattern -> Inh_Pattern -> (Syn_Pattern ) wrap_Pattern (T_Pattern act) (Inh_Pattern ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Pattern_vIn28 (T_Pattern_vOut28 _lhsOcopy _lhsOinfo) <- return (inv_Pattern_s29 sem arg) return (Syn_Pattern _lhsOcopy _lhsOinfo) ) -- cata {-# NOINLINE sem_Pattern #-} sem_Pattern :: Pattern -> T_Pattern sem_Pattern ( Constr name_ pats_ ) = sem_Pattern_Constr name_ ( sem_Patterns pats_ ) sem_Pattern ( Product pos_ pats_ ) = sem_Pattern_Product pos_ ( sem_Patterns pats_ ) sem_Pattern ( Alias field_ attr_ pat_ ) = sem_Pattern_Alias field_ attr_ ( sem_Pattern pat_ ) sem_Pattern ( Irrefutable pat_ ) = sem_Pattern_Irrefutable ( sem_Pattern pat_ ) sem_Pattern ( Underscore pos_ ) = sem_Pattern_Underscore pos_ -- semantic domain newtype T_Pattern = T_Pattern { attach_T_Pattern :: Identity (T_Pattern_s29 ) } newtype T_Pattern_s29 = C_Pattern_s29 { inv_Pattern_s29 :: (T_Pattern_v28 ) } data T_Pattern_s30 = C_Pattern_s30 type T_Pattern_v28 = (T_Pattern_vIn28 ) -> (T_Pattern_vOut28 ) data T_Pattern_vIn28 = T_Pattern_vIn28 data T_Pattern_vOut28 = T_Pattern_vOut28 (Pattern) ((Identifier, Identifier)) {-# NOINLINE sem_Pattern_Constr #-} sem_Pattern_Constr :: (ConstructorIdent) -> T_Patterns -> T_Pattern sem_Pattern_Constr arg_name_ arg_pats_ = T_Pattern (return st29) where {-# NOINLINE st29 #-} st29 = let v28 :: T_Pattern_v28 v28 = \ (T_Pattern_vIn28 ) -> ( let _patsX32 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) (T_Patterns_vOut31 _patsIcopy) = inv_Patterns_s32 _patsX32 (T_Patterns_vIn31 ) _lhsOinfo :: (Identifier, Identifier) _lhsOinfo = rule149 () _copy = rule150 _patsIcopy arg_name_ _lhsOcopy :: Pattern _lhsOcopy = rule151 _copy __result_ = T_Pattern_vOut28 _lhsOcopy _lhsOinfo in __result_ ) in C_Pattern_s29 v28 {-# INLINE rule149 #-} {-# LINE 383 "./src-ag/AG2AspectAG.ag" #-} rule149 = \ (_ :: ()) -> {-# LINE 383 "./src-ag/AG2AspectAG.ag" #-} error "Pattern Constr undefined!!" {-# LINE 1858 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule150 #-} rule150 = \ ((_patsIcopy) :: Patterns) name_ -> Constr name_ _patsIcopy {-# INLINE rule151 #-} rule151 = \ _copy -> _copy {-# NOINLINE sem_Pattern_Product #-} sem_Pattern_Product :: (Pos) -> T_Patterns -> T_Pattern sem_Pattern_Product arg_pos_ arg_pats_ = T_Pattern (return st29) where {-# NOINLINE st29 #-} st29 = let v28 :: T_Pattern_v28 v28 = \ (T_Pattern_vIn28 ) -> ( let _patsX32 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) (T_Patterns_vOut31 _patsIcopy) = inv_Patterns_s32 _patsX32 (T_Patterns_vIn31 ) _lhsOinfo :: (Identifier, Identifier) _lhsOinfo = rule152 () _copy = rule153 _patsIcopy arg_pos_ _lhsOcopy :: Pattern _lhsOcopy = rule154 _copy __result_ = T_Pattern_vOut28 _lhsOcopy _lhsOinfo in __result_ ) in C_Pattern_s29 v28 {-# INLINE rule152 #-} {-# LINE 384 "./src-ag/AG2AspectAG.ag" #-} rule152 = \ (_ :: ()) -> {-# LINE 384 "./src-ag/AG2AspectAG.ag" #-} error "Pattern Product undefined!!" {-# LINE 1887 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule153 #-} rule153 = \ ((_patsIcopy) :: Patterns) pos_ -> Product pos_ _patsIcopy {-# INLINE rule154 #-} rule154 = \ _copy -> _copy {-# NOINLINE sem_Pattern_Alias #-} sem_Pattern_Alias :: (Identifier) -> (Identifier) -> T_Pattern -> T_Pattern sem_Pattern_Alias arg_field_ arg_attr_ arg_pat_ = T_Pattern (return st29) where {-# NOINLINE st29 #-} st29 = let v28 :: T_Pattern_v28 v28 = \ (T_Pattern_vIn28 ) -> ( let _patX29 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) (T_Pattern_vOut28 _patIcopy _patIinfo) = inv_Pattern_s29 _patX29 (T_Pattern_vIn28 ) _lhsOinfo :: (Identifier, Identifier) _lhsOinfo = rule155 arg_attr_ arg_field_ _copy = rule156 _patIcopy arg_attr_ arg_field_ _lhsOcopy :: Pattern _lhsOcopy = rule157 _copy __result_ = T_Pattern_vOut28 _lhsOcopy _lhsOinfo in __result_ ) in C_Pattern_s29 v28 {-# INLINE rule155 #-} {-# LINE 382 "./src-ag/AG2AspectAG.ag" #-} rule155 = \ attr_ field_ -> {-# LINE 382 "./src-ag/AG2AspectAG.ag" #-} (field_, attr_) {-# LINE 1916 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule156 #-} rule156 = \ ((_patIcopy) :: Pattern) attr_ field_ -> Alias field_ attr_ _patIcopy {-# INLINE rule157 #-} rule157 = \ _copy -> _copy {-# NOINLINE sem_Pattern_Irrefutable #-} sem_Pattern_Irrefutable :: T_Pattern -> T_Pattern sem_Pattern_Irrefutable arg_pat_ = T_Pattern (return st29) where {-# NOINLINE st29 #-} st29 = let v28 :: T_Pattern_v28 v28 = \ (T_Pattern_vIn28 ) -> ( let _patX29 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) (T_Pattern_vOut28 _patIcopy _patIinfo) = inv_Pattern_s29 _patX29 (T_Pattern_vIn28 ) _copy = rule158 _patIcopy _lhsOcopy :: Pattern _lhsOcopy = rule159 _copy _lhsOinfo :: (Identifier, Identifier) _lhsOinfo = rule160 _patIinfo __result_ = T_Pattern_vOut28 _lhsOcopy _lhsOinfo in __result_ ) in C_Pattern_s29 v28 {-# INLINE rule158 #-} rule158 = \ ((_patIcopy) :: Pattern) -> Irrefutable _patIcopy {-# INLINE rule159 #-} rule159 = \ _copy -> _copy {-# INLINE rule160 #-} rule160 = \ ((_patIinfo) :: (Identifier, Identifier)) -> _patIinfo {-# NOINLINE sem_Pattern_Underscore #-} sem_Pattern_Underscore :: (Pos) -> T_Pattern sem_Pattern_Underscore arg_pos_ = T_Pattern (return st29) where {-# NOINLINE st29 #-} st29 = let v28 :: T_Pattern_v28 v28 = \ (T_Pattern_vIn28 ) -> ( let _lhsOinfo :: (Identifier, Identifier) _lhsOinfo = rule161 () _copy = rule162 arg_pos_ _lhsOcopy :: Pattern _lhsOcopy = rule163 _copy __result_ = T_Pattern_vOut28 _lhsOcopy _lhsOinfo in __result_ ) in C_Pattern_s29 v28 {-# INLINE rule161 #-} {-# LINE 385 "./src-ag/AG2AspectAG.ag" #-} rule161 = \ (_ :: ()) -> {-# LINE 385 "./src-ag/AG2AspectAG.ag" #-} error "Pattern Underscore undefined!!" {-# LINE 1969 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule162 #-} rule162 = \ pos_ -> Underscore pos_ {-# INLINE rule163 #-} rule163 = \ _copy -> _copy -- Patterns ---------------------------------------------------- -- wrapper data Inh_Patterns = Inh_Patterns { } data Syn_Patterns = Syn_Patterns { copy_Syn_Patterns :: (Patterns) } {-# INLINABLE wrap_Patterns #-} wrap_Patterns :: T_Patterns -> Inh_Patterns -> (Syn_Patterns ) wrap_Patterns (T_Patterns act) (Inh_Patterns ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Patterns_vIn31 (T_Patterns_vOut31 _lhsOcopy) <- return (inv_Patterns_s32 sem arg) return (Syn_Patterns _lhsOcopy) ) -- cata {-# NOINLINE sem_Patterns #-} sem_Patterns :: Patterns -> T_Patterns sem_Patterns list = Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list) -- semantic domain newtype T_Patterns = T_Patterns { attach_T_Patterns :: Identity (T_Patterns_s32 ) } newtype T_Patterns_s32 = C_Patterns_s32 { inv_Patterns_s32 :: (T_Patterns_v31 ) } data T_Patterns_s33 = C_Patterns_s33 type T_Patterns_v31 = (T_Patterns_vIn31 ) -> (T_Patterns_vOut31 ) data T_Patterns_vIn31 = T_Patterns_vIn31 data T_Patterns_vOut31 = T_Patterns_vOut31 (Patterns) {-# NOINLINE sem_Patterns_Cons #-} sem_Patterns_Cons :: T_Pattern -> T_Patterns -> T_Patterns sem_Patterns_Cons arg_hd_ arg_tl_ = T_Patterns (return st32) where {-# NOINLINE st32 #-} st32 = let v31 :: T_Patterns_v31 v31 = \ (T_Patterns_vIn31 ) -> ( let _hdX29 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_hd_)) _tlX32 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_tl_)) (T_Pattern_vOut28 _hdIcopy _hdIinfo) = inv_Pattern_s29 _hdX29 (T_Pattern_vIn28 ) (T_Patterns_vOut31 _tlIcopy) = inv_Patterns_s32 _tlX32 (T_Patterns_vIn31 ) _copy = rule164 _hdIcopy _tlIcopy _lhsOcopy :: Patterns _lhsOcopy = rule165 _copy __result_ = T_Patterns_vOut31 _lhsOcopy in __result_ ) in C_Patterns_s32 v31 {-# INLINE rule164 #-} rule164 = \ ((_hdIcopy) :: Pattern) ((_tlIcopy) :: Patterns) -> (:) _hdIcopy _tlIcopy {-# INLINE rule165 #-} rule165 = \ _copy -> _copy {-# NOINLINE sem_Patterns_Nil #-} sem_Patterns_Nil :: T_Patterns sem_Patterns_Nil = T_Patterns (return st32) where {-# NOINLINE st32 #-} st32 = let v31 :: T_Patterns_v31 v31 = \ (T_Patterns_vIn31 ) -> ( let _copy = rule166 () _lhsOcopy :: Patterns _lhsOcopy = rule167 _copy __result_ = T_Patterns_vOut31 _lhsOcopy in __result_ ) in C_Patterns_s32 v31 {-# INLINE rule166 #-} rule166 = \ (_ :: ()) -> [] {-# INLINE rule167 #-} rule167 = \ _copy -> _copy -- Production -------------------------------------------------- -- wrapper data Inh_Production = Inh_Production { ext_Inh_Production :: (Maybe String), inh_Inh_Production :: ( Attributes ), inhMap_Inh_Production :: (Map Identifier Attributes), inhNoGroup_Inh_Production :: ([String]), newAtts_Inh_Production :: ( Attributes ), newNT_Inh_Production :: (Bool), newProds_Inh_Production :: ( Map.Map ConstructorIdent FieldMap ), o_noGroup_Inh_Production :: ([String]), o_rename_Inh_Production :: (Bool), ppNt_Inh_Production :: (PP_Doc), syn_Inh_Production :: ( Attributes ), synMap_Inh_Production :: (Map Identifier Attributes), synNoGroup_Inh_Production :: ([String]) } data Syn_Production = Syn_Production { hasMoreProds_Syn_Production :: ( Bool ), ppA_Syn_Production :: (PP_Doc), ppCata_Syn_Production :: (PP_Doc), ppD_Syn_Production :: (PP_Doc), ppDI_Syn_Production :: ([PP_Doc]), ppL_Syn_Production :: (PP_Doc), ppLI_Syn_Production :: ([PP_Doc]), ppR_Syn_Production :: (PP_Doc), ppRA_Syn_Production :: ([PP_Doc]), ppSF_Syn_Production :: (PP_Doc), ppSPF_Syn_Production :: (PP_Doc), prdInh_Syn_Production :: (Attributes) } {-# INLINABLE wrap_Production #-} wrap_Production :: T_Production -> Inh_Production -> (Syn_Production ) wrap_Production (T_Production act) (Inh_Production _lhsIext _lhsIinh _lhsIinhMap _lhsIinhNoGroup _lhsInewAtts _lhsInewNT _lhsInewProds _lhsIo_noGroup _lhsIo_rename _lhsIppNt _lhsIsyn _lhsIsynMap _lhsIsynNoGroup) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Production_vIn34 _lhsIext _lhsIinh _lhsIinhMap _lhsIinhNoGroup _lhsInewAtts _lhsInewNT _lhsInewProds _lhsIo_noGroup _lhsIo_rename _lhsIppNt _lhsIsyn _lhsIsynMap _lhsIsynNoGroup (T_Production_vOut34 _lhsOhasMoreProds _lhsOppA _lhsOppCata _lhsOppD _lhsOppDI _lhsOppL _lhsOppLI _lhsOppR _lhsOppRA _lhsOppSF _lhsOppSPF _lhsOprdInh) <- return (inv_Production_s35 sem arg) return (Syn_Production _lhsOhasMoreProds _lhsOppA _lhsOppCata _lhsOppD _lhsOppDI _lhsOppL _lhsOppLI _lhsOppR _lhsOppRA _lhsOppSF _lhsOppSPF _lhsOprdInh) ) -- cata {-# INLINE sem_Production #-} sem_Production :: Production -> T_Production sem_Production ( Production con_ params_ constraints_ children_ rules_ typeSigs_ macro_ ) = sem_Production_Production con_ params_ constraints_ ( sem_Children children_ ) ( sem_Rules rules_ ) ( sem_TypeSigs typeSigs_ ) macro_ -- semantic domain newtype T_Production = T_Production { attach_T_Production :: Identity (T_Production_s35 ) } newtype T_Production_s35 = C_Production_s35 { inv_Production_s35 :: (T_Production_v34 ) } data T_Production_s36 = C_Production_s36 type T_Production_v34 = (T_Production_vIn34 ) -> (T_Production_vOut34 ) data T_Production_vIn34 = T_Production_vIn34 (Maybe String) ( Attributes ) (Map Identifier Attributes) ([String]) ( Attributes ) (Bool) ( Map.Map ConstructorIdent FieldMap ) ([String]) (Bool) (PP_Doc) ( Attributes ) (Map Identifier Attributes) ([String]) data T_Production_vOut34 = T_Production_vOut34 ( Bool ) (PP_Doc) (PP_Doc) (PP_Doc) ([PP_Doc]) (PP_Doc) ([PP_Doc]) (PP_Doc) ([PP_Doc]) (PP_Doc) (PP_Doc) (Attributes) {-# NOINLINE sem_Production_Production #-} sem_Production_Production :: (ConstructorIdent) -> ([Identifier]) -> ([Type]) -> T_Children -> T_Rules -> T_TypeSigs -> (MaybeMacro) -> T_Production sem_Production_Production arg_con_ _ _ arg_children_ arg_rules_ arg_typeSigs_ arg_macro_ = T_Production (return st35) where {-# NOINLINE st35 #-} st35 = let v34 :: T_Production_v34 v34 = \ (T_Production_vIn34 _lhsIext _lhsIinh _lhsIinhMap _lhsIinhNoGroup _lhsInewAtts _lhsInewNT _lhsInewProds _lhsIo_noGroup _lhsIo_rename _lhsIppNt _lhsIsyn _lhsIsynMap _lhsIsynNoGroup) -> ( let _childrenX5 = Control.Monad.Identity.runIdentity (attach_T_Children (arg_children_)) _rulesX44 = Control.Monad.Identity.runIdentity (attach_T_Rules (arg_rules_)) _typeSigsX50 = Control.Monad.Identity.runIdentity (attach_T_TypeSigs (arg_typeSigs_)) (T_Children_vOut4 _childrenIidCL _childrenIppCSF _childrenIppDL _childrenIppL _childrenIppLI _childrenIppR _childrenIprdInh) = inv_Children_s5 _childrenX5 (T_Children_vIn4 _childrenOext _childrenOinhMap _childrenOinhNoGroup _childrenOnewAtts _childrenOo_noGroup _childrenOo_rename _childrenOppNt _childrenOppProd _childrenOsynMap _childrenOsynNoGroup) (T_Rules_vOut43 _rulesIlocals _rulesIppRL) = inv_Rules_s44 _rulesX44 (T_Rules_vIn43 _rulesOext _rulesOinhNoGroup _rulesOnewAtts _rulesOnewProd _rulesOo_noGroup _rulesOppNt _rulesOppProd _rulesOsynNoGroup) (T_TypeSigs_vOut49 ) = inv_TypeSigs_s50 _typeSigsX50 (T_TypeSigs_vIn49 ) _lhsOhasMoreProds :: Bool _lhsOhasMoreProds = rule168 _lhsInewProds arg_con_ _ppProd = rule169 arg_con_ _prodName = rule170 _lhsIppNt _ppProd _conName = rule171 _lhsIo_rename _ppProd _prodName _childrenOppProd = rule172 _ppProd _rulesOppProd = rule173 _ppProd _lhsOppD :: PP_Doc _lhsOppD = rule174 _childrenIppDL _conName _lhsOppL :: PP_Doc _lhsOppL = rule175 _childrenIppL _lhsInewProds arg_con_ _lhsOppLI :: [PP_Doc] _lhsOppLI = rule176 _childrenIppLI _lhsInewProds arg_con_ _lhsOppA :: PP_Doc _lhsOppA = rule177 _prodName _rulesIlocals _newProd = rule178 _lhsInewProds arg_con_ (_ppR,_ppRA) = rule179 _childrenIidCL _childrenIppR _lhsIinhNoGroup _lhsInewAtts _lhsInewNT _lhsIppNt _lhsIsynNoGroup _newProd _prodName _rulesIlocals _rulesIppRL arg_con_ _lhsOppCata :: PP_Doc _lhsOppCata = rule180 _lhsIext _lhsInewNT _newProd _ppRA _prodName arg_macro_ _lhsOppSF :: PP_Doc _lhsOppSF = rule181 _childrenIppCSF _conName _lhsIppNt _prodName arg_con_ _lhsOppSPF :: PP_Doc _lhsOppSPF = rule182 _childrenIppCSF _lhsIppNt _prodName arg_con_ _lhsOppDI :: [PP_Doc] _lhsOppDI = rule183 () _lhsOppR :: PP_Doc _lhsOppR = rule184 _ppR _lhsOppRA :: [PP_Doc] _lhsOppRA = rule185 _ppRA _lhsOprdInh :: Attributes _lhsOprdInh = rule186 _childrenIprdInh _childrenOext = rule187 _lhsIext _childrenOinhMap = rule188 _lhsIinhMap _childrenOinhNoGroup = rule189 _lhsIinhNoGroup _childrenOnewAtts = rule190 _lhsInewAtts _childrenOo_noGroup = rule191 _lhsIo_noGroup _childrenOo_rename = rule192 _lhsIo_rename _childrenOppNt = rule193 _lhsIppNt _childrenOsynMap = rule194 _lhsIsynMap _childrenOsynNoGroup = rule195 _lhsIsynNoGroup _rulesOext = rule196 _lhsIext _rulesOinhNoGroup = rule197 _lhsIinhNoGroup _rulesOnewAtts = rule198 _lhsInewAtts _rulesOnewProd = rule199 _newProd _rulesOo_noGroup = rule200 _lhsIo_noGroup _rulesOppNt = rule201 _lhsIppNt _rulesOsynNoGroup = rule202 _lhsIsynNoGroup __result_ = T_Production_vOut34 _lhsOhasMoreProds _lhsOppA _lhsOppCata _lhsOppD _lhsOppDI _lhsOppL _lhsOppLI _lhsOppR _lhsOppRA _lhsOppSF _lhsOppSPF _lhsOprdInh in __result_ ) in C_Production_s35 v34 {-# INLINE rule168 #-} {-# LINE 103 "./src-ag/AG2AspectAG.ag" #-} rule168 = \ ((_lhsInewProds) :: Map.Map ConstructorIdent FieldMap ) con_ -> {-# LINE 103 "./src-ag/AG2AspectAG.ag" #-} not $ Map.member con_ _lhsInewProds {-# LINE 2148 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule169 #-} {-# LINE 176 "./src-ag/AG2AspectAG.ag" #-} rule169 = \ con_ -> {-# LINE 176 "./src-ag/AG2AspectAG.ag" #-} pp con_ {-# LINE 2154 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule170 #-} {-# LINE 177 "./src-ag/AG2AspectAG.ag" #-} rule170 = \ ((_lhsIppNt) :: PP_Doc) _ppProd -> {-# LINE 177 "./src-ag/AG2AspectAG.ag" #-} ppName [_lhsIppNt, _ppProd ] {-# LINE 2160 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule171 #-} {-# LINE 178 "./src-ag/AG2AspectAG.ag" #-} rule171 = \ ((_lhsIo_rename) :: Bool) _ppProd _prodName -> {-# LINE 178 "./src-ag/AG2AspectAG.ag" #-} if _lhsIo_rename then _prodName else _ppProd {-# LINE 2168 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule172 #-} {-# LINE 195 "./src-ag/AG2AspectAG.ag" #-} rule172 = \ _ppProd -> {-# LINE 195 "./src-ag/AG2AspectAG.ag" #-} _ppProd {-# LINE 2174 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule173 #-} {-# LINE 196 "./src-ag/AG2AspectAG.ag" #-} rule173 = \ _ppProd -> {-# LINE 196 "./src-ag/AG2AspectAG.ag" #-} _ppProd {-# LINE 2180 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule174 #-} {-# LINE 228 "./src-ag/AG2AspectAG.ag" #-} rule174 = \ ((_childrenIppDL) :: [PP_Doc]) _conName -> {-# LINE 228 "./src-ag/AG2AspectAG.ag" #-} _conName >|< ppListSep " {" "}" ", " _childrenIppDL {-# LINE 2186 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule175 #-} {-# LINE 275 "./src-ag/AG2AspectAG.ag" #-} rule175 = \ ((_childrenIppL) :: PP_Doc) ((_lhsInewProds) :: Map.Map ConstructorIdent FieldMap ) con_ -> {-# LINE 275 "./src-ag/AG2AspectAG.ag" #-} if (Map.member con_ _lhsInewProds) then _childrenIppL else empty {-# LINE 2194 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule176 #-} {-# LINE 279 "./src-ag/AG2AspectAG.ag" #-} rule176 = \ ((_childrenIppLI) :: [PP_Doc]) ((_lhsInewProds) :: Map.Map ConstructorIdent FieldMap ) con_ -> {-# LINE 279 "./src-ag/AG2AspectAG.ag" #-} if (not $ Map.member con_ _lhsInewProds) then _childrenIppLI else [] {-# LINE 2202 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule177 #-} {-# LINE 332 "./src-ag/AG2AspectAG.ag" #-} rule177 = \ _prodName ((_rulesIlocals) :: [Identifier]) -> {-# LINE 332 "./src-ag/AG2AspectAG.ag" #-} defLocalAtts _prodName (length _rulesIlocals) 1 $ sort _rulesIlocals {-# LINE 2208 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule178 #-} {-# LINE 428 "./src-ag/AG2AspectAG.ag" #-} rule178 = \ ((_lhsInewProds) :: Map.Map ConstructorIdent FieldMap ) con_ -> {-# LINE 428 "./src-ag/AG2AspectAG.ag" #-} Map.member con_ _lhsInewProds {-# LINE 2214 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule179 #-} {-# LINE 430 "./src-ag/AG2AspectAG.ag" #-} rule179 = \ ((_childrenIidCL) :: [(Identifier,Type)]) ((_childrenIppR) :: PP_Doc) ((_lhsIinhNoGroup) :: [String]) ((_lhsInewAtts) :: Attributes ) ((_lhsInewNT) :: Bool) ((_lhsIppNt) :: PP_Doc) ((_lhsIsynNoGroup) :: [String]) _newProd _prodName ((_rulesIlocals) :: [Identifier]) ((_rulesIppRL) :: [ PPRule ]) con_ -> {-# LINE 430 "./src-ag/AG2AspectAG.ag" #-} let (instR, instRA) = defInstRules _lhsIppNt con_ _lhsInewNT _newProd _childrenIppR _rulesIppRL _childrenIidCL _rulesIlocals (locR, locRA) = defLocRule _lhsIppNt con_ _lhsInewNT _newProd _childrenIppR _rulesIppRL _lhsIinhNoGroup _lhsIsynNoGroup _childrenIidCL _rulesIlocals (inhGR, inhGRA) = defInhGRule _lhsIppNt _prodName _lhsInewNT _newProd _childrenIppR _rulesIppRL _lhsIinhNoGroup _lhsIsynNoGroup _childrenIidCL _rulesIlocals (synGR, synGRA) = defSynGRule _lhsIppNt con_ _lhsInewNT _newProd _childrenIppR _rulesIppRL _lhsIinhNoGroup _lhsIsynNoGroup _childrenIidCL _rulesIlocals (inhR, inhRA) = defInhRules _lhsIppNt _prodName _lhsInewNT _newProd _lhsInewAtts _childrenIppR _rulesIppRL _lhsIinhNoGroup _lhsIsynNoGroup _childrenIidCL _rulesIlocals (synR, synRA) = defSynRules _lhsIppNt con_ _lhsInewNT _newProd _lhsInewAtts _childrenIppR _rulesIppRL _lhsIinhNoGroup _lhsIsynNoGroup _childrenIidCL _rulesIlocals (inhMR, inhMRA) = modInhRules _lhsIppNt _prodName _lhsInewNT _newProd _lhsInewAtts _childrenIppR _rulesIppRL _lhsIinhNoGroup _lhsIsynNoGroup _childrenIidCL _rulesIlocals (synMR, synMRA) = modSynRules _lhsIppNt con_ _lhsInewNT _newProd _lhsInewAtts _childrenIppR _rulesIppRL _lhsIinhNoGroup _lhsIsynNoGroup _childrenIidCL _rulesIlocals in ( vlist [instR,locR,inhGR,synGR,inhR,synR,inhMR,synMR] , instRA ++ locRA ++ inhGRA ++ synGRA ++ inhMRA ++ synMRA ++ inhRA ++ synRA) {-# LINE 2237 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule180 #-} {-# LINE 740 "./src-ag/AG2AspectAG.ag" #-} rule180 = \ ((_lhsIext) :: Maybe String) ((_lhsInewNT) :: Bool) _newProd _ppRA _prodName macro_ -> {-# LINE 740 "./src-ag/AG2AspectAG.ag" #-} let extend = maybe [] ( \ext -> if (_lhsInewNT || (not _lhsInewNT && _newProd )) then [] else [ ext >|< ".atts_" >|< _prodName ]) _lhsIext macro = case macro_ of Nothing -> [] Just macro -> [ "agMacro " >|< ppMacro macro ] atts = sortBy (\a b -> compare (show a) (show b)) _ppRA in "atts_" >|< _prodName >|< " = " >|< ppListSep "" "" " `ext` " (atts ++ macro ++ extend ) >-< "semP_" >|< _prodName >|< pp " = knit atts_" >|< _prodName {-# LINE 2255 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule181 #-} {-# LINE 804 "./src-ag/AG2AspectAG.ag" #-} rule181 = \ ((_childrenIppCSF) :: [(Identifier,(PP_Doc,PP_Doc))]) _conName ((_lhsIppNt) :: PP_Doc) _prodName con_ -> {-# LINE 804 "./src-ag/AG2AspectAG.ag" #-} let chi = _childrenIppCSF ppPattern = case (show con_) of "Cons" -> ppParams (ppListSep "" "" " : ") "Nil" -> pp "[]" otherwise -> _conName >|< " " >|< (ppParams ppSpaced) ppParams f = f $ map (((>|<) (pp "_")) . fst) chi in "sem_" >|< _lhsIppNt >|< " (" >|< ppPattern >|< ") = sem_" >|< _prodName >|< " (" >|< map (fst . snd) chi >|< "emptyRecord)" {-# LINE 2268 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule182 #-} {-# LINE 816 "./src-ag/AG2AspectAG.ag" #-} rule182 = \ ((_childrenIppCSF) :: [(Identifier,(PP_Doc,PP_Doc))]) ((_lhsIppNt) :: PP_Doc) _prodName con_ -> {-# LINE 816 "./src-ag/AG2AspectAG.ag" #-} let chi = _childrenIppCSF ppParams f = f $ map (((>|<) (pp "_")) . fst) chi in "sem_" >|< _lhsIppNt >|< "_" >|< con_ >#< ppParams ppSpaced >|< " = semP_" >|< _prodName >|< " (" >|< map (snd . snd) chi >|< "emptyRecord)" {-# LINE 2277 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule183 #-} rule183 = \ (_ :: ()) -> [] {-# INLINE rule184 #-} rule184 = \ _ppR -> _ppR {-# INLINE rule185 #-} rule185 = \ _ppRA -> _ppRA {-# INLINE rule186 #-} rule186 = \ ((_childrenIprdInh) :: Attributes) -> _childrenIprdInh {-# INLINE rule187 #-} rule187 = \ ((_lhsIext) :: Maybe String) -> _lhsIext {-# INLINE rule188 #-} rule188 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule189 #-} rule189 = \ ((_lhsIinhNoGroup) :: [String]) -> _lhsIinhNoGroup {-# INLINE rule190 #-} rule190 = \ ((_lhsInewAtts) :: Attributes ) -> _lhsInewAtts {-# INLINE rule191 #-} rule191 = \ ((_lhsIo_noGroup) :: [String]) -> _lhsIo_noGroup {-# INLINE rule192 #-} rule192 = \ ((_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# INLINE rule193 #-} rule193 = \ ((_lhsIppNt) :: PP_Doc) -> _lhsIppNt {-# INLINE rule194 #-} rule194 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# INLINE rule195 #-} rule195 = \ ((_lhsIsynNoGroup) :: [String]) -> _lhsIsynNoGroup {-# INLINE rule196 #-} rule196 = \ ((_lhsIext) :: Maybe String) -> _lhsIext {-# INLINE rule197 #-} rule197 = \ ((_lhsIinhNoGroup) :: [String]) -> _lhsIinhNoGroup {-# INLINE rule198 #-} rule198 = \ ((_lhsInewAtts) :: Attributes ) -> _lhsInewAtts {-# INLINE rule199 #-} rule199 = \ _newProd -> _newProd {-# INLINE rule200 #-} rule200 = \ ((_lhsIo_noGroup) :: [String]) -> _lhsIo_noGroup {-# INLINE rule201 #-} rule201 = \ ((_lhsIppNt) :: PP_Doc) -> _lhsIppNt {-# INLINE rule202 #-} rule202 = \ ((_lhsIsynNoGroup) :: [String]) -> _lhsIsynNoGroup -- Productions ------------------------------------------------- -- wrapper data Inh_Productions = Inh_Productions { ext_Inh_Productions :: (Maybe String), inh_Inh_Productions :: ( Attributes ), inhMap_Inh_Productions :: (Map Identifier Attributes), inhNoGroup_Inh_Productions :: ([String]), newAtts_Inh_Productions :: ( Attributes ), newNT_Inh_Productions :: (Bool), newProds_Inh_Productions :: ( Map.Map ConstructorIdent FieldMap ), o_noGroup_Inh_Productions :: ([String]), o_rename_Inh_Productions :: (Bool), ppNt_Inh_Productions :: (PP_Doc), syn_Inh_Productions :: ( Attributes ), synMap_Inh_Productions :: (Map Identifier Attributes), synNoGroup_Inh_Productions :: ([String]) } data Syn_Productions = Syn_Productions { hasMoreProds_Syn_Productions :: ( Bool ), ppA_Syn_Productions :: (PP_Doc), ppCata_Syn_Productions :: (PP_Doc), ppDL_Syn_Productions :: ([PP_Doc]), ppL_Syn_Productions :: (PP_Doc), ppLI_Syn_Productions :: ([PP_Doc]), ppR_Syn_Productions :: (PP_Doc), ppRA_Syn_Productions :: ([PP_Doc]), ppSF_Syn_Productions :: (PP_Doc), ppSPF_Syn_Productions :: (PP_Doc), prdInh_Syn_Productions :: (Attributes) } {-# INLINABLE wrap_Productions #-} wrap_Productions :: T_Productions -> Inh_Productions -> (Syn_Productions ) wrap_Productions (T_Productions act) (Inh_Productions _lhsIext _lhsIinh _lhsIinhMap _lhsIinhNoGroup _lhsInewAtts _lhsInewNT _lhsInewProds _lhsIo_noGroup _lhsIo_rename _lhsIppNt _lhsIsyn _lhsIsynMap _lhsIsynNoGroup) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Productions_vIn37 _lhsIext _lhsIinh _lhsIinhMap _lhsIinhNoGroup _lhsInewAtts _lhsInewNT _lhsInewProds _lhsIo_noGroup _lhsIo_rename _lhsIppNt _lhsIsyn _lhsIsynMap _lhsIsynNoGroup (T_Productions_vOut37 _lhsOhasMoreProds _lhsOppA _lhsOppCata _lhsOppDL _lhsOppL _lhsOppLI _lhsOppR _lhsOppRA _lhsOppSF _lhsOppSPF _lhsOprdInh) <- return (inv_Productions_s38 sem arg) return (Syn_Productions _lhsOhasMoreProds _lhsOppA _lhsOppCata _lhsOppDL _lhsOppL _lhsOppLI _lhsOppR _lhsOppRA _lhsOppSF _lhsOppSPF _lhsOprdInh) ) -- cata {-# NOINLINE sem_Productions #-} sem_Productions :: Productions -> T_Productions sem_Productions list = Prelude.foldr sem_Productions_Cons sem_Productions_Nil (Prelude.map sem_Production list) -- semantic domain newtype T_Productions = T_Productions { attach_T_Productions :: Identity (T_Productions_s38 ) } newtype T_Productions_s38 = C_Productions_s38 { inv_Productions_s38 :: (T_Productions_v37 ) } data T_Productions_s39 = C_Productions_s39 type T_Productions_v37 = (T_Productions_vIn37 ) -> (T_Productions_vOut37 ) data T_Productions_vIn37 = T_Productions_vIn37 (Maybe String) ( Attributes ) (Map Identifier Attributes) ([String]) ( Attributes ) (Bool) ( Map.Map ConstructorIdent FieldMap ) ([String]) (Bool) (PP_Doc) ( Attributes ) (Map Identifier Attributes) ([String]) data T_Productions_vOut37 = T_Productions_vOut37 ( Bool ) (PP_Doc) (PP_Doc) ([PP_Doc]) (PP_Doc) ([PP_Doc]) (PP_Doc) ([PP_Doc]) (PP_Doc) (PP_Doc) (Attributes) {-# NOINLINE sem_Productions_Cons #-} sem_Productions_Cons :: T_Production -> T_Productions -> T_Productions sem_Productions_Cons arg_hd_ arg_tl_ = T_Productions (return st38) where {-# NOINLINE st38 #-} st38 = let v37 :: T_Productions_v37 v37 = \ (T_Productions_vIn37 _lhsIext _lhsIinh _lhsIinhMap _lhsIinhNoGroup _lhsInewAtts _lhsInewNT _lhsInewProds _lhsIo_noGroup _lhsIo_rename _lhsIppNt _lhsIsyn _lhsIsynMap _lhsIsynNoGroup) -> ( let _hdX35 = Control.Monad.Identity.runIdentity (attach_T_Production (arg_hd_)) _tlX38 = Control.Monad.Identity.runIdentity (attach_T_Productions (arg_tl_)) (T_Production_vOut34 _hdIhasMoreProds _hdIppA _hdIppCata _hdIppD _hdIppDI _hdIppL _hdIppLI _hdIppR _hdIppRA _hdIppSF _hdIppSPF _hdIprdInh) = inv_Production_s35 _hdX35 (T_Production_vIn34 _hdOext _hdOinh _hdOinhMap _hdOinhNoGroup _hdOnewAtts _hdOnewNT _hdOnewProds _hdOo_noGroup _hdOo_rename _hdOppNt _hdOsyn _hdOsynMap _hdOsynNoGroup) (T_Productions_vOut37 _tlIhasMoreProds _tlIppA _tlIppCata _tlIppDL _tlIppL _tlIppLI _tlIppR _tlIppRA _tlIppSF _tlIppSPF _tlIprdInh) = inv_Productions_s38 _tlX38 (T_Productions_vIn37 _tlOext _tlOinh _tlOinhMap _tlOinhNoGroup _tlOnewAtts _tlOnewNT _tlOnewProds _tlOo_noGroup _tlOo_rename _tlOppNt _tlOsyn _tlOsynMap _tlOsynNoGroup) _hdOinhNoGroup = rule203 _hdIprdInh _lhsIinhNoGroup _lhsOppDL :: [PP_Doc] _lhsOppDL = rule204 _hdIppD _tlIppDL _lhsOhasMoreProds :: Bool _lhsOhasMoreProds = rule205 _hdIhasMoreProds _tlIhasMoreProds _lhsOppA :: PP_Doc _lhsOppA = rule206 _hdIppA _tlIppA _lhsOppCata :: PP_Doc _lhsOppCata = rule207 _hdIppCata _tlIppCata _lhsOppL :: PP_Doc _lhsOppL = rule208 _hdIppL _tlIppL _lhsOppLI :: [PP_Doc] _lhsOppLI = rule209 _hdIppLI _tlIppLI _lhsOppR :: PP_Doc _lhsOppR = rule210 _hdIppR _tlIppR _lhsOppRA :: [PP_Doc] _lhsOppRA = rule211 _hdIppRA _tlIppRA _lhsOppSF :: PP_Doc _lhsOppSF = rule212 _hdIppSF _tlIppSF _lhsOppSPF :: PP_Doc _lhsOppSPF = rule213 _hdIppSPF _tlIppSPF _lhsOprdInh :: Attributes _lhsOprdInh = rule214 _hdIprdInh _tlIprdInh _hdOext = rule215 _lhsIext _hdOinh = rule216 _lhsIinh _hdOinhMap = rule217 _lhsIinhMap _hdOnewAtts = rule218 _lhsInewAtts _hdOnewNT = rule219 _lhsInewNT _hdOnewProds = rule220 _lhsInewProds _hdOo_noGroup = rule221 _lhsIo_noGroup _hdOo_rename = rule222 _lhsIo_rename _hdOppNt = rule223 _lhsIppNt _hdOsyn = rule224 _lhsIsyn _hdOsynMap = rule225 _lhsIsynMap _hdOsynNoGroup = rule226 _lhsIsynNoGroup _tlOext = rule227 _lhsIext _tlOinh = rule228 _lhsIinh _tlOinhMap = rule229 _lhsIinhMap _tlOinhNoGroup = rule230 _lhsIinhNoGroup _tlOnewAtts = rule231 _lhsInewAtts _tlOnewNT = rule232 _lhsInewNT _tlOnewProds = rule233 _lhsInewProds _tlOo_noGroup = rule234 _lhsIo_noGroup _tlOo_rename = rule235 _lhsIo_rename _tlOppNt = rule236 _lhsIppNt _tlOsyn = rule237 _lhsIsyn _tlOsynMap = rule238 _lhsIsynMap _tlOsynNoGroup = rule239 _lhsIsynNoGroup __result_ = T_Productions_vOut37 _lhsOhasMoreProds _lhsOppA _lhsOppCata _lhsOppDL _lhsOppL _lhsOppLI _lhsOppR _lhsOppRA _lhsOppSF _lhsOppSPF _lhsOprdInh in __result_ ) in C_Productions_s38 v37 {-# INLINE rule203 #-} {-# LINE 62 "./src-ag/AG2AspectAG.ag" #-} rule203 = \ ((_hdIprdInh) :: Attributes) ((_lhsIinhNoGroup) :: [String]) -> {-# LINE 62 "./src-ag/AG2AspectAG.ag" #-} filter (flip Map.member _hdIprdInh . identifier) _lhsIinhNoGroup {-# LINE 2436 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule204 #-} {-# LINE 234 "./src-ag/AG2AspectAG.ag" #-} rule204 = \ ((_hdIppD) :: PP_Doc) ((_tlIppDL) :: [PP_Doc]) -> {-# LINE 234 "./src-ag/AG2AspectAG.ag" #-} _hdIppD : _tlIppDL {-# LINE 2442 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule205 #-} rule205 = \ ((_hdIhasMoreProds) :: Bool ) ((_tlIhasMoreProds) :: Bool ) -> _hdIhasMoreProds || _tlIhasMoreProds {-# INLINE rule206 #-} rule206 = \ ((_hdIppA) :: PP_Doc) ((_tlIppA) :: PP_Doc) -> _hdIppA >-< _tlIppA {-# INLINE rule207 #-} rule207 = \ ((_hdIppCata) :: PP_Doc) ((_tlIppCata) :: PP_Doc) -> _hdIppCata >-< _tlIppCata {-# INLINE rule208 #-} rule208 = \ ((_hdIppL) :: PP_Doc) ((_tlIppL) :: PP_Doc) -> _hdIppL >-< _tlIppL {-# INLINE rule209 #-} rule209 = \ ((_hdIppLI) :: [PP_Doc]) ((_tlIppLI) :: [PP_Doc]) -> _hdIppLI ++ _tlIppLI {-# INLINE rule210 #-} rule210 = \ ((_hdIppR) :: PP_Doc) ((_tlIppR) :: PP_Doc) -> _hdIppR >-< _tlIppR {-# INLINE rule211 #-} rule211 = \ ((_hdIppRA) :: [PP_Doc]) ((_tlIppRA) :: [PP_Doc]) -> _hdIppRA ++ _tlIppRA {-# INLINE rule212 #-} rule212 = \ ((_hdIppSF) :: PP_Doc) ((_tlIppSF) :: PP_Doc) -> _hdIppSF >-< _tlIppSF {-# INLINE rule213 #-} rule213 = \ ((_hdIppSPF) :: PP_Doc) ((_tlIppSPF) :: PP_Doc) -> _hdIppSPF >-< _tlIppSPF {-# INLINE rule214 #-} rule214 = \ ((_hdIprdInh) :: Attributes) ((_tlIprdInh) :: Attributes) -> _hdIprdInh `Map.union` _tlIprdInh {-# INLINE rule215 #-} rule215 = \ ((_lhsIext) :: Maybe String) -> _lhsIext {-# INLINE rule216 #-} rule216 = \ ((_lhsIinh) :: Attributes ) -> _lhsIinh {-# INLINE rule217 #-} rule217 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule218 #-} rule218 = \ ((_lhsInewAtts) :: Attributes ) -> _lhsInewAtts {-# INLINE rule219 #-} rule219 = \ ((_lhsInewNT) :: Bool) -> _lhsInewNT {-# INLINE rule220 #-} rule220 = \ ((_lhsInewProds) :: Map.Map ConstructorIdent FieldMap ) -> _lhsInewProds {-# INLINE rule221 #-} rule221 = \ ((_lhsIo_noGroup) :: [String]) -> _lhsIo_noGroup {-# INLINE rule222 #-} rule222 = \ ((_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# INLINE rule223 #-} rule223 = \ ((_lhsIppNt) :: PP_Doc) -> _lhsIppNt {-# INLINE rule224 #-} rule224 = \ ((_lhsIsyn) :: Attributes ) -> _lhsIsyn {-# INLINE rule225 #-} rule225 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# INLINE rule226 #-} rule226 = \ ((_lhsIsynNoGroup) :: [String]) -> _lhsIsynNoGroup {-# INLINE rule227 #-} rule227 = \ ((_lhsIext) :: Maybe String) -> _lhsIext {-# INLINE rule228 #-} rule228 = \ ((_lhsIinh) :: Attributes ) -> _lhsIinh {-# INLINE rule229 #-} rule229 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule230 #-} rule230 = \ ((_lhsIinhNoGroup) :: [String]) -> _lhsIinhNoGroup {-# INLINE rule231 #-} rule231 = \ ((_lhsInewAtts) :: Attributes ) -> _lhsInewAtts {-# INLINE rule232 #-} rule232 = \ ((_lhsInewNT) :: Bool) -> _lhsInewNT {-# INLINE rule233 #-} rule233 = \ ((_lhsInewProds) :: Map.Map ConstructorIdent FieldMap ) -> _lhsInewProds {-# INLINE rule234 #-} rule234 = \ ((_lhsIo_noGroup) :: [String]) -> _lhsIo_noGroup {-# INLINE rule235 #-} rule235 = \ ((_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# INLINE rule236 #-} rule236 = \ ((_lhsIppNt) :: PP_Doc) -> _lhsIppNt {-# INLINE rule237 #-} rule237 = \ ((_lhsIsyn) :: Attributes ) -> _lhsIsyn {-# INLINE rule238 #-} rule238 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# INLINE rule239 #-} rule239 = \ ((_lhsIsynNoGroup) :: [String]) -> _lhsIsynNoGroup {-# NOINLINE sem_Productions_Nil #-} sem_Productions_Nil :: T_Productions sem_Productions_Nil = T_Productions (return st38) where {-# NOINLINE st38 #-} st38 = let v37 :: T_Productions_v37 v37 = \ (T_Productions_vIn37 _lhsIext _lhsIinh _lhsIinhMap _lhsIinhNoGroup _lhsInewAtts _lhsInewNT _lhsInewProds _lhsIo_noGroup _lhsIo_rename _lhsIppNt _lhsIsyn _lhsIsynMap _lhsIsynNoGroup) -> ( let _lhsOppDL :: [PP_Doc] _lhsOppDL = rule240 () _lhsOhasMoreProds :: Bool _lhsOhasMoreProds = rule241 () _lhsOppA :: PP_Doc _lhsOppA = rule242 () _lhsOppCata :: PP_Doc _lhsOppCata = rule243 () _lhsOppL :: PP_Doc _lhsOppL = rule244 () _lhsOppLI :: [PP_Doc] _lhsOppLI = rule245 () _lhsOppR :: PP_Doc _lhsOppR = rule246 () _lhsOppRA :: [PP_Doc] _lhsOppRA = rule247 () _lhsOppSF :: PP_Doc _lhsOppSF = rule248 () _lhsOppSPF :: PP_Doc _lhsOppSPF = rule249 () _lhsOprdInh :: Attributes _lhsOprdInh = rule250 () __result_ = T_Productions_vOut37 _lhsOhasMoreProds _lhsOppA _lhsOppCata _lhsOppDL _lhsOppL _lhsOppLI _lhsOppR _lhsOppRA _lhsOppSF _lhsOppSPF _lhsOprdInh in __result_ ) in C_Productions_s38 v37 {-# INLINE rule240 #-} {-# LINE 235 "./src-ag/AG2AspectAG.ag" #-} rule240 = \ (_ :: ()) -> {-# LINE 235 "./src-ag/AG2AspectAG.ag" #-} [] {-# LINE 2585 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule241 #-} rule241 = \ (_ :: ()) -> False {-# INLINE rule242 #-} rule242 = \ (_ :: ()) -> empty {-# INLINE rule243 #-} rule243 = \ (_ :: ()) -> empty {-# INLINE rule244 #-} rule244 = \ (_ :: ()) -> empty {-# INLINE rule245 #-} rule245 = \ (_ :: ()) -> [] {-# INLINE rule246 #-} rule246 = \ (_ :: ()) -> empty {-# INLINE rule247 #-} rule247 = \ (_ :: ()) -> [] {-# INLINE rule248 #-} rule248 = \ (_ :: ()) -> empty {-# INLINE rule249 #-} rule249 = \ (_ :: ()) -> empty {-# INLINE rule250 #-} rule250 = \ (_ :: ()) -> Map.empty -- Rule -------------------------------------------------------- -- wrapper data Inh_Rule = Inh_Rule { ext_Inh_Rule :: (Maybe String), inhNoGroup_Inh_Rule :: ([String]), newAtts_Inh_Rule :: ( Attributes ), newProd_Inh_Rule :: (Bool), o_noGroup_Inh_Rule :: ([String]), ppNt_Inh_Rule :: (PP_Doc), ppProd_Inh_Rule :: (PP_Doc), synNoGroup_Inh_Rule :: ([String]) } data Syn_Rule = Syn_Rule { locals_Syn_Rule :: ([Identifier]), ppRL_Syn_Rule :: ([ PPRule ]) } {-# INLINABLE wrap_Rule #-} wrap_Rule :: T_Rule -> Inh_Rule -> (Syn_Rule ) wrap_Rule (T_Rule act) (Inh_Rule _lhsIext _lhsIinhNoGroup _lhsInewAtts _lhsInewProd _lhsIo_noGroup _lhsIppNt _lhsIppProd _lhsIsynNoGroup) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Rule_vIn40 _lhsIext _lhsIinhNoGroup _lhsInewAtts _lhsInewProd _lhsIo_noGroup _lhsIppNt _lhsIppProd _lhsIsynNoGroup (T_Rule_vOut40 _lhsOlocals _lhsOppRL) <- return (inv_Rule_s41 sem arg) return (Syn_Rule _lhsOlocals _lhsOppRL) ) -- cata {-# INLINE sem_Rule #-} sem_Rule :: Rule -> T_Rule sem_Rule ( Rule mbName_ pattern_ rhs_ owrt_ origin_ explicit_ pure_ identity_ mbError_ eager_ ) = sem_Rule_Rule mbName_ ( sem_Pattern pattern_ ) ( sem_Expression rhs_ ) owrt_ origin_ explicit_ pure_ identity_ mbError_ eager_ -- semantic domain newtype T_Rule = T_Rule { attach_T_Rule :: Identity (T_Rule_s41 ) } newtype T_Rule_s41 = C_Rule_s41 { inv_Rule_s41 :: (T_Rule_v40 ) } data T_Rule_s42 = C_Rule_s42 type T_Rule_v40 = (T_Rule_vIn40 ) -> (T_Rule_vOut40 ) data T_Rule_vIn40 = T_Rule_vIn40 (Maybe String) ([String]) ( Attributes ) (Bool) ([String]) (PP_Doc) (PP_Doc) ([String]) data T_Rule_vOut40 = T_Rule_vOut40 ([Identifier]) ([ PPRule ]) {-# NOINLINE sem_Rule_Rule #-} sem_Rule_Rule :: (Maybe Identifier) -> T_Pattern -> T_Expression -> (Bool) -> (String) -> (Bool) -> (Bool) -> (Bool) -> (Maybe Error) -> (Bool) -> T_Rule sem_Rule_Rule _ arg_pattern_ arg_rhs_ arg_owrt_ _ arg_explicit_ _ _ _ _ = T_Rule (return st41) where {-# NOINLINE st41 #-} st41 = let v40 :: T_Rule_v40 v40 = \ (T_Rule_vIn40 _lhsIext _lhsIinhNoGroup _lhsInewAtts _lhsInewProd _lhsIo_noGroup _lhsIppNt _lhsIppProd _lhsIsynNoGroup) -> ( let _patternX29 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pattern_)) _rhsX8 = Control.Monad.Identity.runIdentity (attach_T_Expression (arg_rhs_)) (T_Pattern_vOut28 _patternIcopy _patternIinfo) = inv_Pattern_s29 _patternX29 (T_Pattern_vIn28 ) (T_Expression_vOut7 _rhsIppRE) = inv_Expression_s8 _rhsX8 (T_Expression_vIn7 _rhsOppNt _rhsOppProd) _lhsOlocals :: [Identifier] _lhsOlocals = rule251 _patternIinfo _lhsOppRL :: [ PPRule ] _lhsOppRL = rule252 _lhsInewAtts _lhsInewProd _lhsIo_noGroup _lhsIppNt _patternIinfo _rhsIppRE arg_explicit_ arg_owrt_ _rhsOppNt = rule253 _lhsIppNt _rhsOppProd = rule254 _lhsIppProd __result_ = T_Rule_vOut40 _lhsOlocals _lhsOppRL in __result_ ) in C_Rule_s41 v40 {-# INLINE rule251 #-} {-# LINE 375 "./src-ag/AG2AspectAG.ag" #-} rule251 = \ ((_patternIinfo) :: (Identifier, Identifier)) -> {-# LINE 375 "./src-ag/AG2AspectAG.ag" #-} if (show (fst _patternIinfo) == "loc") then [ snd _patternIinfo ] else [ ] {-# LINE 2674 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule252 #-} {-# LINE 472 "./src-ag/AG2AspectAG.ag" #-} rule252 = \ ((_lhsInewAtts) :: Attributes ) ((_lhsInewProd) :: Bool) ((_lhsIo_noGroup) :: [String]) ((_lhsIppNt) :: PP_Doc) ((_patternIinfo) :: (Identifier, Identifier)) ((_rhsIppRE) :: [String] -> Identifier -> [(Identifier,Type)] -> [Identifier] -> PP_Doc) explicit_ owrt_ -> {-# LINE 472 "./src-ag/AG2AspectAG.ag" #-} if (not explicit_ && not _lhsInewProd && not (Map.member (snd _patternIinfo) _lhsInewAtts) ) then [] else [ ppRule _patternIinfo owrt_ (defRule _lhsIppNt _patternIinfo _lhsIo_noGroup _rhsIppRE) ] {-# LINE 2682 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule253 #-} rule253 = \ ((_lhsIppNt) :: PP_Doc) -> _lhsIppNt {-# INLINE rule254 #-} rule254 = \ ((_lhsIppProd) :: PP_Doc) -> _lhsIppProd -- Rules ------------------------------------------------------- -- wrapper data Inh_Rules = Inh_Rules { ext_Inh_Rules :: (Maybe String), inhNoGroup_Inh_Rules :: ([String]), newAtts_Inh_Rules :: ( Attributes ), newProd_Inh_Rules :: (Bool), o_noGroup_Inh_Rules :: ([String]), ppNt_Inh_Rules :: (PP_Doc), ppProd_Inh_Rules :: (PP_Doc), synNoGroup_Inh_Rules :: ([String]) } data Syn_Rules = Syn_Rules { locals_Syn_Rules :: ([Identifier]), ppRL_Syn_Rules :: ([ PPRule ]) } {-# INLINABLE wrap_Rules #-} wrap_Rules :: T_Rules -> Inh_Rules -> (Syn_Rules ) wrap_Rules (T_Rules act) (Inh_Rules _lhsIext _lhsIinhNoGroup _lhsInewAtts _lhsInewProd _lhsIo_noGroup _lhsIppNt _lhsIppProd _lhsIsynNoGroup) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Rules_vIn43 _lhsIext _lhsIinhNoGroup _lhsInewAtts _lhsInewProd _lhsIo_noGroup _lhsIppNt _lhsIppProd _lhsIsynNoGroup (T_Rules_vOut43 _lhsOlocals _lhsOppRL) <- return (inv_Rules_s44 sem arg) return (Syn_Rules _lhsOlocals _lhsOppRL) ) -- cata {-# NOINLINE sem_Rules #-} sem_Rules :: Rules -> T_Rules sem_Rules list = Prelude.foldr sem_Rules_Cons sem_Rules_Nil (Prelude.map sem_Rule list) -- semantic domain newtype T_Rules = T_Rules { attach_T_Rules :: Identity (T_Rules_s44 ) } newtype T_Rules_s44 = C_Rules_s44 { inv_Rules_s44 :: (T_Rules_v43 ) } data T_Rules_s45 = C_Rules_s45 type T_Rules_v43 = (T_Rules_vIn43 ) -> (T_Rules_vOut43 ) data T_Rules_vIn43 = T_Rules_vIn43 (Maybe String) ([String]) ( Attributes ) (Bool) ([String]) (PP_Doc) (PP_Doc) ([String]) data T_Rules_vOut43 = T_Rules_vOut43 ([Identifier]) ([ PPRule ]) {-# NOINLINE sem_Rules_Cons #-} sem_Rules_Cons :: T_Rule -> T_Rules -> T_Rules sem_Rules_Cons arg_hd_ arg_tl_ = T_Rules (return st44) where {-# NOINLINE st44 #-} st44 = let v43 :: T_Rules_v43 v43 = \ (T_Rules_vIn43 _lhsIext _lhsIinhNoGroup _lhsInewAtts _lhsInewProd _lhsIo_noGroup _lhsIppNt _lhsIppProd _lhsIsynNoGroup) -> ( let _hdX41 = Control.Monad.Identity.runIdentity (attach_T_Rule (arg_hd_)) _tlX44 = Control.Monad.Identity.runIdentity (attach_T_Rules (arg_tl_)) (T_Rule_vOut40 _hdIlocals _hdIppRL) = inv_Rule_s41 _hdX41 (T_Rule_vIn40 _hdOext _hdOinhNoGroup _hdOnewAtts _hdOnewProd _hdOo_noGroup _hdOppNt _hdOppProd _hdOsynNoGroup) (T_Rules_vOut43 _tlIlocals _tlIppRL) = inv_Rules_s44 _tlX44 (T_Rules_vIn43 _tlOext _tlOinhNoGroup _tlOnewAtts _tlOnewProd _tlOo_noGroup _tlOppNt _tlOppProd _tlOsynNoGroup) _lhsOppRL :: [ PPRule ] _lhsOppRL = rule255 _hdIppRL _tlIppRL _lhsOlocals :: [Identifier] _lhsOlocals = rule256 _hdIlocals _tlIlocals _hdOext = rule257 _lhsIext _hdOinhNoGroup = rule258 _lhsIinhNoGroup _hdOnewAtts = rule259 _lhsInewAtts _hdOnewProd = rule260 _lhsInewProd _hdOo_noGroup = rule261 _lhsIo_noGroup _hdOppNt = rule262 _lhsIppNt _hdOppProd = rule263 _lhsIppProd _hdOsynNoGroup = rule264 _lhsIsynNoGroup _tlOext = rule265 _lhsIext _tlOinhNoGroup = rule266 _lhsIinhNoGroup _tlOnewAtts = rule267 _lhsInewAtts _tlOnewProd = rule268 _lhsInewProd _tlOo_noGroup = rule269 _lhsIo_noGroup _tlOppNt = rule270 _lhsIppNt _tlOppProd = rule271 _lhsIppProd _tlOsynNoGroup = rule272 _lhsIsynNoGroup __result_ = T_Rules_vOut43 _lhsOlocals _lhsOppRL in __result_ ) in C_Rules_s44 v43 {-# INLINE rule255 #-} {-# LINE 468 "./src-ag/AG2AspectAG.ag" #-} rule255 = \ ((_hdIppRL) :: [ PPRule ]) ((_tlIppRL) :: [ PPRule ]) -> {-# LINE 468 "./src-ag/AG2AspectAG.ag" #-} _hdIppRL ++ _tlIppRL {-# LINE 2759 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule256 #-} rule256 = \ ((_hdIlocals) :: [Identifier]) ((_tlIlocals) :: [Identifier]) -> _hdIlocals ++ _tlIlocals {-# INLINE rule257 #-} rule257 = \ ((_lhsIext) :: Maybe String) -> _lhsIext {-# INLINE rule258 #-} rule258 = \ ((_lhsIinhNoGroup) :: [String]) -> _lhsIinhNoGroup {-# INLINE rule259 #-} rule259 = \ ((_lhsInewAtts) :: Attributes ) -> _lhsInewAtts {-# INLINE rule260 #-} rule260 = \ ((_lhsInewProd) :: Bool) -> _lhsInewProd {-# INLINE rule261 #-} rule261 = \ ((_lhsIo_noGroup) :: [String]) -> _lhsIo_noGroup {-# INLINE rule262 #-} rule262 = \ ((_lhsIppNt) :: PP_Doc) -> _lhsIppNt {-# INLINE rule263 #-} rule263 = \ ((_lhsIppProd) :: PP_Doc) -> _lhsIppProd {-# INLINE rule264 #-} rule264 = \ ((_lhsIsynNoGroup) :: [String]) -> _lhsIsynNoGroup {-# INLINE rule265 #-} rule265 = \ ((_lhsIext) :: Maybe String) -> _lhsIext {-# INLINE rule266 #-} rule266 = \ ((_lhsIinhNoGroup) :: [String]) -> _lhsIinhNoGroup {-# INLINE rule267 #-} rule267 = \ ((_lhsInewAtts) :: Attributes ) -> _lhsInewAtts {-# INLINE rule268 #-} rule268 = \ ((_lhsInewProd) :: Bool) -> _lhsInewProd {-# INLINE rule269 #-} rule269 = \ ((_lhsIo_noGroup) :: [String]) -> _lhsIo_noGroup {-# INLINE rule270 #-} rule270 = \ ((_lhsIppNt) :: PP_Doc) -> _lhsIppNt {-# INLINE rule271 #-} rule271 = \ ((_lhsIppProd) :: PP_Doc) -> _lhsIppProd {-# INLINE rule272 #-} rule272 = \ ((_lhsIsynNoGroup) :: [String]) -> _lhsIsynNoGroup {-# NOINLINE sem_Rules_Nil #-} sem_Rules_Nil :: T_Rules sem_Rules_Nil = T_Rules (return st44) where {-# NOINLINE st44 #-} st44 = let v43 :: T_Rules_v43 v43 = \ (T_Rules_vIn43 _lhsIext _lhsIinhNoGroup _lhsInewAtts _lhsInewProd _lhsIo_noGroup _lhsIppNt _lhsIppProd _lhsIsynNoGroup) -> ( let _lhsOppRL :: [ PPRule ] _lhsOppRL = rule273 () _lhsOlocals :: [Identifier] _lhsOlocals = rule274 () __result_ = T_Rules_vOut43 _lhsOlocals _lhsOppRL in __result_ ) in C_Rules_s44 v43 {-# INLINE rule273 #-} {-# LINE 469 "./src-ag/AG2AspectAG.ag" #-} rule273 = \ (_ :: ()) -> {-# LINE 469 "./src-ag/AG2AspectAG.ag" #-} [] {-# LINE 2830 "dist/build/AG2AspectAG.hs"#-} {-# INLINE rule274 #-} rule274 = \ (_ :: ()) -> [] -- TypeSig ----------------------------------------------------- -- wrapper data Inh_TypeSig = Inh_TypeSig { } data Syn_TypeSig = Syn_TypeSig { } {-# INLINABLE wrap_TypeSig #-} wrap_TypeSig :: T_TypeSig -> Inh_TypeSig -> (Syn_TypeSig ) wrap_TypeSig (T_TypeSig act) (Inh_TypeSig ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_TypeSig_vIn46 (T_TypeSig_vOut46 ) <- return (inv_TypeSig_s47 sem arg) return (Syn_TypeSig ) ) -- cata {-# INLINE sem_TypeSig #-} sem_TypeSig :: TypeSig -> T_TypeSig sem_TypeSig ( TypeSig name_ tp_ ) = sem_TypeSig_TypeSig name_ tp_ -- semantic domain newtype T_TypeSig = T_TypeSig { attach_T_TypeSig :: Identity (T_TypeSig_s47 ) } newtype T_TypeSig_s47 = C_TypeSig_s47 { inv_TypeSig_s47 :: (T_TypeSig_v46 ) } data T_TypeSig_s48 = C_TypeSig_s48 type T_TypeSig_v46 = (T_TypeSig_vIn46 ) -> (T_TypeSig_vOut46 ) data T_TypeSig_vIn46 = T_TypeSig_vIn46 data T_TypeSig_vOut46 = T_TypeSig_vOut46 {-# NOINLINE sem_TypeSig_TypeSig #-} sem_TypeSig_TypeSig :: (Identifier) -> (Type) -> T_TypeSig sem_TypeSig_TypeSig _ _ = T_TypeSig (return st47) where {-# NOINLINE st47 #-} st47 = let v46 :: T_TypeSig_v46 v46 = \ (T_TypeSig_vIn46 ) -> ( let __result_ = T_TypeSig_vOut46 in __result_ ) in C_TypeSig_s47 v46 -- TypeSigs ---------------------------------------------------- -- wrapper data Inh_TypeSigs = Inh_TypeSigs { } data Syn_TypeSigs = Syn_TypeSigs { } {-# INLINABLE wrap_TypeSigs #-} wrap_TypeSigs :: T_TypeSigs -> Inh_TypeSigs -> (Syn_TypeSigs ) wrap_TypeSigs (T_TypeSigs act) (Inh_TypeSigs ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_TypeSigs_vIn49 (T_TypeSigs_vOut49 ) <- return (inv_TypeSigs_s50 sem arg) return (Syn_TypeSigs ) ) -- cata {-# NOINLINE sem_TypeSigs #-} sem_TypeSigs :: TypeSigs -> T_TypeSigs sem_TypeSigs list = Prelude.foldr sem_TypeSigs_Cons sem_TypeSigs_Nil (Prelude.map sem_TypeSig list) -- semantic domain newtype T_TypeSigs = T_TypeSigs { attach_T_TypeSigs :: Identity (T_TypeSigs_s50 ) } newtype T_TypeSigs_s50 = C_TypeSigs_s50 { inv_TypeSigs_s50 :: (T_TypeSigs_v49 ) } data T_TypeSigs_s51 = C_TypeSigs_s51 type T_TypeSigs_v49 = (T_TypeSigs_vIn49 ) -> (T_TypeSigs_vOut49 ) data T_TypeSigs_vIn49 = T_TypeSigs_vIn49 data T_TypeSigs_vOut49 = T_TypeSigs_vOut49 {-# NOINLINE sem_TypeSigs_Cons #-} sem_TypeSigs_Cons :: T_TypeSig -> T_TypeSigs -> T_TypeSigs sem_TypeSigs_Cons arg_hd_ arg_tl_ = T_TypeSigs (return st50) where {-# NOINLINE st50 #-} st50 = let v49 :: T_TypeSigs_v49 v49 = \ (T_TypeSigs_vIn49 ) -> ( let _hdX47 = Control.Monad.Identity.runIdentity (attach_T_TypeSig (arg_hd_)) _tlX50 = Control.Monad.Identity.runIdentity (attach_T_TypeSigs (arg_tl_)) (T_TypeSig_vOut46 ) = inv_TypeSig_s47 _hdX47 (T_TypeSig_vIn46 ) (T_TypeSigs_vOut49 ) = inv_TypeSigs_s50 _tlX50 (T_TypeSigs_vIn49 ) __result_ = T_TypeSigs_vOut49 in __result_ ) in C_TypeSigs_s50 v49 {-# NOINLINE sem_TypeSigs_Nil #-} sem_TypeSigs_Nil :: T_TypeSigs sem_TypeSigs_Nil = T_TypeSigs (return st50) where {-# NOINLINE st50 #-} st50 = let v49 :: T_TypeSigs_v49 v49 = \ (T_TypeSigs_vIn49 ) -> ( let __result_ = T_TypeSigs_vOut49 in __result_ ) in C_TypeSigs_s50 v49 uuagc-0.9.42.3/src-generated/Code.hs000644 000765 000024 00000027167 12127045231 021014 0ustar00jeroenbransenstaff000000 000000 -- UUAGC 0.9.42.3 (src-ag/Code.ag) module Code where {-# LINE 2 "./src-ag/Code.ag" #-} import Patterns import Data.Set(Set) import qualified Data.Set as Set import Data.Map(Map) import qualified Data.Map as Map {-# LINE 13 "dist/build/Code.hs" #-} {-# LINE 144 "./src-ag/Code.ag" #-} -- 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 {-# LINE 31 "dist/build/Code.hs" #-} -- CaseAlt ----------------------------------------------------- {- alternatives: alternative CaseAlt: child left : Lhs child expr : Expr -} data CaseAlt = CaseAlt (Lhs) (Expr) -- CaseAlts ---------------------------------------------------- {- alternatives: alternative Cons: child hd : CaseAlt child tl : CaseAlts alternative Nil: -} type CaseAlts = [CaseAlt] -- Chunk ------------------------------------------------------- {- alternatives: alternative Chunk: child name : {String} child comment : Decl child info : Decls child dataDef : Decls child cataFun : Decls child semDom : Decls child semWrapper : Decls child semFunctions : Decls child semNames : {[String]} -} data Chunk = Chunk (String) (Decl) (Decls) (Decls) (Decls) (Decls) (Decls) (Decls) (([String])) -- Chunks ------------------------------------------------------ {- alternatives: alternative Cons: child hd : Chunk child tl : Chunks alternative Nil: -} type Chunks = [Chunk] -- DataAlt ----------------------------------------------------- {- alternatives: alternative DataAlt: child name : {String} child args : Types alternative Record: child name : {String} child args : NamedTypes -} data DataAlt = DataAlt (String) (Types) | Record (String) (NamedTypes) -- DataAlts ---------------------------------------------------- {- alternatives: alternative Cons: child hd : DataAlt child tl : DataAlts alternative Nil: -} type DataAlts = [DataAlt] -- Decl -------------------------------------------------------- {- alternatives: alternative Decl: child left : Lhs child rhs : Expr child binds : {Set String} child uses : {Set String} alternative Bind: child left : Lhs child rhs : Expr alternative BindLet: child left : Lhs child rhs : Expr alternative Data: child name : {String} child params : {[String]} child alts : DataAlts child strict : {Bool} child derivings : {[String]} alternative NewType: child name : {String} child params : {[String]} child con : {String} child tp : Type alternative Type: child name : {String} child params : {[String]} child tp : Type alternative TSig: child name : {String} child tp : Type alternative Comment: child txt : {String} alternative PragmaDecl: child txt : {String} alternative Resume: child monadic : {Bool} child nt : {String} child left : Lhs child rhs : Expr alternative EvalDecl: child nt : {String} child left : Lhs child rhs : Expr -} data Decl = Decl (Lhs) (Expr) ((Set String)) ((Set String)) | Bind (Lhs) (Expr) | BindLet (Lhs) (Expr) | Data (String) (([String])) (DataAlts) (Bool) (([String])) | NewType (String) (([String])) (String) (Type) | Type (String) (([String])) (Type) | TSig (String) (Type) | Comment (String) | PragmaDecl (String) | Resume (Bool) (String) (Lhs) (Expr) | EvalDecl (String) (Lhs) (Expr) -- Decls ------------------------------------------------------- {- alternatives: alternative Cons: child hd : Decl child tl : Decls alternative Nil: -} type Decls = [Decl] -- Expr -------------------------------------------------------- {- alternatives: alternative Let: child decls : Decls child body : Expr alternative Case: child expr : Expr child alts : CaseAlts alternative Do: child stmts : Decls child body : Expr alternative Lambda: child args : Exprs child body : Expr alternative TupleExpr: child exprs : Exprs alternative UnboxedTupleExpr: child exprs : Exprs alternative App: child name : {String} child args : Exprs alternative SimpleExpr: child txt : {String} alternative TextExpr: child lns : {[String]} alternative Trace: child txt : {String} child expr : Expr alternative PragmaExpr: child onLeftSide : {Bool} child onNewLine : {Bool} child txt : {String} child expr : Expr alternative LineExpr: child expr : Expr alternative TypedExpr: child expr : Expr child tp : Type alternative ResultExpr: child nt : {String} child expr : Expr alternative InvokeExpr: child nt : {String} child expr : Expr child args : Exprs alternative ResumeExpr: child nt : {String} child expr : Expr child left : Lhs child rhs : Expr alternative SemFun: child nt : {String} child args : Exprs child body : Expr -} data Expr = Let (Decls) (Expr) | Case (Expr) (CaseAlts) | Do (Decls) (Expr) | Lambda (Exprs) (Expr) | TupleExpr (Exprs) | UnboxedTupleExpr (Exprs) | App (String) (Exprs) | SimpleExpr (String) | TextExpr (([String])) | Trace (String) (Expr) | PragmaExpr (Bool) (Bool) (String) (Expr) | LineExpr (Expr) | TypedExpr (Expr) (Type) | ResultExpr (String) (Expr) | InvokeExpr (String) (Expr) (Exprs) | ResumeExpr (String) (Expr) (Lhs) (Expr) | SemFun (String) (Exprs) (Expr) -- Exprs ------------------------------------------------------- {- alternatives: alternative Cons: child hd : Expr child tl : Exprs alternative Nil: -} type Exprs = [Expr] -- Lhs --------------------------------------------------------- {- alternatives: alternative Pattern3: child pat3 : {Pattern} alternative Pattern3SM: child pat3 : {Pattern} alternative TupleLhs: child comps : {[String]} alternative UnboxedTupleLhs: child comps : {[String]} alternative Fun: child name : {String} child args : Exprs alternative Unwrap: child name : {String} child sub : Lhs -} data Lhs = Pattern3 (Pattern) | Pattern3SM (Pattern) | TupleLhs (([String])) | UnboxedTupleLhs (([String])) | Fun (String) (Exprs) | Unwrap (String) (Lhs) -- NamedType --------------------------------------------------- {- alternatives: alternative Named: child strict : {Bool} child name : {String} child tp : Type -} data NamedType = Named (Bool) (String) (Type) -- NamedTypes -------------------------------------------------- {- alternatives: alternative Cons: child hd : NamedType child tl : NamedTypes alternative Nil: -} type NamedTypes = [NamedType] -- Program ----------------------------------------------------- {- alternatives: alternative Program: child chunks : Chunks child ordered : {Bool} -} data Program = Program (Chunks) (Bool) -- Type -------------------------------------------------------- {- alternatives: alternative Arr: child left : Type child right : Type alternative CtxApp: child left : {[(String, [String])]} child right : Type alternative QuantApp: child left : {String} child right : Type alternative TypeApp: child func : Type child args : Types alternative TupleType: child tps : Types alternative UnboxedTupleType: child tps : Types alternative List: child tp : Type alternative SimpleType: child txt : {String} alternative NontermType: child name : {String} child params : {[String]} child deforested : {Bool} alternative TMaybe: child tp : Type alternative TEither: child left : Type child right : Type alternative TMap: child key : Type child value : Type alternative TIntMap: child value : Type -} data Type = Arr (Type) (Type) | CtxApp (([(String, [String])])) (Type) | QuantApp (String) (Type) | TypeApp (Type) (Types) | TupleType (Types) | UnboxedTupleType (Types) | List (Type) | SimpleType (String) | NontermType (String) (([String])) (Bool) | TMaybe (Type) | TEither (Type) (Type) | TMap (Type) (Type) | TIntMap (Type) deriving ( Show) -- Types ------------------------------------------------------- {- alternatives: alternative Cons: child hd : Type child tl : Types alternative Nil: -} type Types = [Type]uuagc-0.9.42.3/src-generated/CodeSyntax.hs000644 000765 000024 00000013305 12127045231 022210 0ustar00jeroenbransenstaff000000 000000 -- UUAGC 0.9.42.3 (src-ag/CodeSyntax.ag) module CodeSyntax where {-# LINE 2 "./src-ag/CodeSyntax.ag" #-} import Patterns import CommonTypes import Data.Map(Map) import Data.Set(Set) {-# LINE 12 "dist/build/CodeSyntax.hs" #-} -- CGrammar ---------------------------------------------------- {- alternatives: alternative CGrammar: child typeSyns : {TypeSyns} child derivings : {Derivings} child wrappers : {Set NontermIdent} child nonts : CNonterminals child pragmas : {PragmaMap} child paramMap : {ParamMap} child contextMap : {ContextMap} child quantMap : {QuantMap} child aroundsMap : {Map NontermIdent (Map ConstructorIdent (Set Identifier))} child mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))} child multivisit : {Bool} -} data CGrammar = CGrammar (TypeSyns) (Derivings) ((Set NontermIdent)) (CNonterminals) (PragmaMap) (ParamMap) (ContextMap) (QuantMap) ((Map NontermIdent (Map ConstructorIdent (Set Identifier)))) ((Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))))) (Bool) -- CInterface -------------------------------------------------- {- alternatives: alternative CInterface: child seg : CSegments -} data CInterface = CInterface (CSegments) -- CNonterminal ------------------------------------------------ {- alternatives: alternative CNonterminal: child nt : {NontermIdent} child params : {[Identifier]} child inh : {Attributes} child syn : {Attributes} child prods : CProductions child inter : CInterface -} data CNonterminal = CNonterminal (NontermIdent) (([Identifier])) (Attributes) (Attributes) (CProductions) (CInterface) -- CNonterminals ----------------------------------------------- {- alternatives: alternative Cons: child hd : CNonterminal child tl : CNonterminals alternative Nil: -} type CNonterminals = [CNonterminal] -- CProduction ------------------------------------------------- {- alternatives: alternative CProduction: child con : {ConstructorIdent} child visits : CVisits child children : {[(Identifier,Type,ChildKind)]} child terminals : {[Identifier]} -} data CProduction = CProduction (ConstructorIdent) (CVisits) (([(Identifier,Type,ChildKind)])) (([Identifier])) -- CProductions ------------------------------------------------ {- alternatives: alternative Cons: child hd : CProduction child tl : CProductions alternative Nil: -} type CProductions = [CProduction] -- CRule ------------------------------------------------------- {- alternatives: alternative CRule: child name : {Identifier} child isIn : {Bool} child hasCode : {Bool} child nt : {NontermIdent} child con : {ConstructorIdent} child field : {Identifier} child childnt : {Maybe NontermIdent} child tp : {Maybe Type} child pattern : {Pattern} child rhs : {[String]} child defines : {Map Int (Identifier,Identifier,Maybe Type)} child owrt : {Bool} child origin : {String} child uses : {Set (Identifier, Identifier)} child explicit : {Bool} child mbNamed : {Maybe Identifier} alternative CChildVisit: child name : {Identifier} child nt : {NontermIdent} child nr : {Int} child inh : {Attributes} child syn : {Attributes} child isLast : {Bool} -} data CRule = CRule (Identifier) (Bool) (Bool) (NontermIdent) (ConstructorIdent) (Identifier) ((Maybe NontermIdent)) ((Maybe Type)) (Pattern) (([String])) ((Map Int (Identifier,Identifier,Maybe Type))) (Bool) (String) ((Set (Identifier, Identifier))) (Bool) ((Maybe Identifier)) | CChildVisit (Identifier) (NontermIdent) (Int) (Attributes) (Attributes) (Bool) -- CSegment ---------------------------------------------------- {- alternatives: alternative CSegment: child inh : {Attributes} child syn : {Attributes} -} data CSegment = CSegment (Attributes) (Attributes) -- CSegments --------------------------------------------------- {- alternatives: alternative Cons: child hd : CSegment child tl : CSegments alternative Nil: -} type CSegments = [CSegment] -- CVisit ------------------------------------------------------ {- alternatives: alternative CVisit: child inh : {Attributes} child syn : {Attributes} child vss : Sequence child intra : Sequence child ordered : {Bool} -} data CVisit = CVisit (Attributes) (Attributes) (Sequence) (Sequence) (Bool) -- CVisits ----------------------------------------------------- {- alternatives: alternative Cons: child hd : CVisit child tl : CVisits alternative Nil: -} type CVisits = [CVisit] -- Sequence ---------------------------------------------------- {- alternatives: alternative Cons: child hd : CRule child tl : Sequence alternative Nil: -} type Sequence = [CRule]uuagc-0.9.42.3/src-generated/CodeSyntaxDump.hs000644 000765 000024 00000150165 12127045231 023044 0ustar00jeroenbransenstaff000000 000000 {-# LANGUAGE Rank2Types, GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} module CodeSyntaxDump where {-# LINE 2 "./src-ag/CodeSyntax.ag" #-} import Patterns import CommonTypes import Data.Map(Map) import Data.Set(Set) {-# LINE 12 "dist/build/CodeSyntaxDump.hs" #-} {-# LINE 2 "./src-ag/Patterns.ag" #-} -- Patterns.ag imports import UU.Scanner.Position(Pos) import CommonTypes (ConstructorIdent,Identifier) {-# LINE 19 "dist/build/CodeSyntaxDump.hs" #-} {-# LINE 5 "./src-ag/CodeSyntaxDump.ag" #-} import Data.List import qualified Data.Map as Map import Pretty import PPUtil import CodeSyntax {-# LINE 30 "dist/build/CodeSyntaxDump.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 15 "./src-ag/CodeSyntaxDump.ag" #-} 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 {-# LINE 60 "dist/build/CodeSyntaxDump.hs" #-} -- CGrammar ---------------------------------------------------- -- wrapper data Inh_CGrammar = Inh_CGrammar { } data Syn_CGrammar = Syn_CGrammar { pp_Syn_CGrammar :: (PP_Doc) } {-# INLINABLE wrap_CGrammar #-} wrap_CGrammar :: T_CGrammar -> Inh_CGrammar -> (Syn_CGrammar ) wrap_CGrammar (T_CGrammar act) (Inh_CGrammar ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_CGrammar_vIn1 (T_CGrammar_vOut1 _lhsOpp) <- return (inv_CGrammar_s2 sem arg) return (Syn_CGrammar _lhsOpp) ) -- cata {-# INLINE sem_CGrammar #-} sem_CGrammar :: CGrammar -> T_CGrammar sem_CGrammar ( CGrammar typeSyns_ derivings_ wrappers_ nonts_ pragmas_ paramMap_ contextMap_ quantMap_ aroundsMap_ mergeMap_ multivisit_ ) = sem_CGrammar_CGrammar typeSyns_ derivings_ wrappers_ ( sem_CNonterminals nonts_ ) pragmas_ paramMap_ contextMap_ quantMap_ aroundsMap_ mergeMap_ multivisit_ -- semantic domain newtype T_CGrammar = T_CGrammar { attach_T_CGrammar :: Identity (T_CGrammar_s2 ) } newtype T_CGrammar_s2 = C_CGrammar_s2 { inv_CGrammar_s2 :: (T_CGrammar_v1 ) } data T_CGrammar_s3 = C_CGrammar_s3 type T_CGrammar_v1 = (T_CGrammar_vIn1 ) -> (T_CGrammar_vOut1 ) data T_CGrammar_vIn1 = T_CGrammar_vIn1 data T_CGrammar_vOut1 = T_CGrammar_vOut1 (PP_Doc) {-# NOINLINE sem_CGrammar_CGrammar #-} sem_CGrammar_CGrammar :: (TypeSyns) -> (Derivings) -> (Set NontermIdent) -> T_CNonterminals -> (PragmaMap) -> (ParamMap) -> (ContextMap) -> (QuantMap) -> (Map NontermIdent (Map ConstructorIdent (Set Identifier))) -> (Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))) -> (Bool) -> T_CGrammar sem_CGrammar_CGrammar arg_typeSyns_ arg_derivings_ _ arg_nonts_ _ _ _ _ _ _ _ = T_CGrammar (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_CGrammar_v1 v1 = \ (T_CGrammar_vIn1 ) -> ( let _nontsX11 = Control.Monad.Identity.runIdentity (attach_T_CNonterminals (arg_nonts_)) (T_CNonterminals_vOut10 _nontsIpp _nontsIppL) = inv_CNonterminals_s11 _nontsX11 (T_CNonterminals_vIn10 ) _lhsOpp :: PP_Doc _lhsOpp = rule0 _nontsIppL arg_derivings_ arg_typeSyns_ __result_ = T_CGrammar_vOut1 _lhsOpp in __result_ ) in C_CGrammar_s2 v1 {-# INLINE rule0 #-} {-# LINE 47 "./src-ag/CodeSyntaxDump.ag" #-} rule0 = \ ((_nontsIppL) :: [PP_Doc]) derivings_ typeSyns_ -> {-# LINE 47 "./src-ag/CodeSyntaxDump.ag" #-} ppNestInfo ["CGrammar","CGrammar"] [] [ ppF "typeSyns" $ ppAssocL typeSyns_ , ppF "derivings" $ ppMap $ derivings_ , ppF "nonts" $ ppVList _nontsIppL ] [] {-# LINE 114 "dist/build/CodeSyntaxDump.hs"#-} -- CInterface -------------------------------------------------- -- wrapper data Inh_CInterface = Inh_CInterface { } data Syn_CInterface = Syn_CInterface { pp_Syn_CInterface :: (PP_Doc) } {-# INLINABLE wrap_CInterface #-} wrap_CInterface :: T_CInterface -> Inh_CInterface -> (Syn_CInterface ) wrap_CInterface (T_CInterface act) (Inh_CInterface ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_CInterface_vIn4 (T_CInterface_vOut4 _lhsOpp) <- return (inv_CInterface_s5 sem arg) return (Syn_CInterface _lhsOpp) ) -- cata {-# INLINE sem_CInterface #-} sem_CInterface :: CInterface -> T_CInterface sem_CInterface ( CInterface seg_ ) = sem_CInterface_CInterface ( sem_CSegments seg_ ) -- semantic domain newtype T_CInterface = T_CInterface { attach_T_CInterface :: Identity (T_CInterface_s5 ) } newtype T_CInterface_s5 = C_CInterface_s5 { inv_CInterface_s5 :: (T_CInterface_v4 ) } data T_CInterface_s6 = C_CInterface_s6 type T_CInterface_v4 = (T_CInterface_vIn4 ) -> (T_CInterface_vOut4 ) data T_CInterface_vIn4 = T_CInterface_vIn4 data T_CInterface_vOut4 = T_CInterface_vOut4 (PP_Doc) {-# NOINLINE sem_CInterface_CInterface #-} sem_CInterface_CInterface :: T_CSegments -> T_CInterface sem_CInterface_CInterface arg_seg_ = T_CInterface (return st5) where {-# NOINLINE st5 #-} st5 = let v4 :: T_CInterface_v4 v4 = \ (T_CInterface_vIn4 ) -> ( let _segX26 = Control.Monad.Identity.runIdentity (attach_T_CSegments (arg_seg_)) (T_CSegments_vOut25 _segIpp _segIppL) = inv_CSegments_s26 _segX26 (T_CSegments_vIn25 ) _lhsOpp :: PP_Doc _lhsOpp = rule1 _segIppL __result_ = T_CInterface_vOut4 _lhsOpp in __result_ ) in C_CInterface_s5 v4 {-# INLINE rule1 #-} {-# LINE 57 "./src-ag/CodeSyntaxDump.ag" #-} rule1 = \ ((_segIppL) :: [PP_Doc]) -> {-# LINE 57 "./src-ag/CodeSyntaxDump.ag" #-} ppNestInfo ["CInterface","CInterface"] [] [ppF "seg" $ ppVList _segIppL] [] {-# LINE 165 "dist/build/CodeSyntaxDump.hs"#-} -- CNonterminal ------------------------------------------------ -- wrapper data Inh_CNonterminal = Inh_CNonterminal { } data Syn_CNonterminal = Syn_CNonterminal { pp_Syn_CNonterminal :: (PP_Doc) } {-# INLINABLE wrap_CNonterminal #-} wrap_CNonterminal :: T_CNonterminal -> Inh_CNonterminal -> (Syn_CNonterminal ) wrap_CNonterminal (T_CNonterminal act) (Inh_CNonterminal ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_CNonterminal_vIn7 (T_CNonterminal_vOut7 _lhsOpp) <- return (inv_CNonterminal_s8 sem arg) return (Syn_CNonterminal _lhsOpp) ) -- cata {-# INLINE sem_CNonterminal #-} sem_CNonterminal :: CNonterminal -> T_CNonterminal sem_CNonterminal ( CNonterminal nt_ params_ inh_ syn_ prods_ inter_ ) = sem_CNonterminal_CNonterminal nt_ params_ inh_ syn_ ( sem_CProductions prods_ ) ( sem_CInterface inter_ ) -- semantic domain newtype T_CNonterminal = T_CNonterminal { attach_T_CNonterminal :: Identity (T_CNonterminal_s8 ) } newtype T_CNonterminal_s8 = C_CNonterminal_s8 { inv_CNonterminal_s8 :: (T_CNonterminal_v7 ) } data T_CNonterminal_s9 = C_CNonterminal_s9 type T_CNonterminal_v7 = (T_CNonterminal_vIn7 ) -> (T_CNonterminal_vOut7 ) data T_CNonterminal_vIn7 = T_CNonterminal_vIn7 data T_CNonterminal_vOut7 = T_CNonterminal_vOut7 (PP_Doc) {-# NOINLINE sem_CNonterminal_CNonterminal #-} sem_CNonterminal_CNonterminal :: (NontermIdent) -> ([Identifier]) -> (Attributes) -> (Attributes) -> T_CProductions -> T_CInterface -> T_CNonterminal sem_CNonterminal_CNonterminal arg_nt_ arg_params_ arg_inh_ arg_syn_ arg_prods_ arg_inter_ = T_CNonterminal (return st8) where {-# NOINLINE st8 #-} st8 = let v7 :: T_CNonterminal_v7 v7 = \ (T_CNonterminal_vIn7 ) -> ( let _prodsX17 = Control.Monad.Identity.runIdentity (attach_T_CProductions (arg_prods_)) _interX5 = Control.Monad.Identity.runIdentity (attach_T_CInterface (arg_inter_)) (T_CProductions_vOut16 _prodsIpp _prodsIppL) = inv_CProductions_s17 _prodsX17 (T_CProductions_vIn16 ) (T_CInterface_vOut4 _interIpp) = inv_CInterface_s5 _interX5 (T_CInterface_vIn4 ) _lhsOpp :: PP_Doc _lhsOpp = rule2 _interIpp _prodsIppL arg_inh_ arg_nt_ arg_params_ arg_syn_ __result_ = T_CNonterminal_vOut7 _lhsOpp in __result_ ) in C_CNonterminal_s8 v7 {-# INLINE rule2 #-} {-# LINE 54 "./src-ag/CodeSyntaxDump.ag" #-} rule2 = \ ((_interIpp) :: PP_Doc) ((_prodsIppL) :: [PP_Doc]) inh_ nt_ params_ syn_ -> {-# LINE 54 "./src-ag/CodeSyntaxDump.ag" #-} ppNestInfo ["CNonterminal","CNonterminal"] (pp nt_ : map pp params_) [ppF "inh" $ ppMap inh_, ppF "syn" $ ppMap syn_, ppF "prods" $ ppVList _prodsIppL, ppF "inter" _interIpp] [] {-# LINE 218 "dist/build/CodeSyntaxDump.hs"#-} -- CNonterminals ----------------------------------------------- -- wrapper data Inh_CNonterminals = Inh_CNonterminals { } data Syn_CNonterminals = Syn_CNonterminals { pp_Syn_CNonterminals :: (PP_Doc), ppL_Syn_CNonterminals :: ([PP_Doc]) } {-# INLINABLE wrap_CNonterminals #-} wrap_CNonterminals :: T_CNonterminals -> Inh_CNonterminals -> (Syn_CNonterminals ) wrap_CNonterminals (T_CNonterminals act) (Inh_CNonterminals ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_CNonterminals_vIn10 (T_CNonterminals_vOut10 _lhsOpp _lhsOppL) <- return (inv_CNonterminals_s11 sem arg) return (Syn_CNonterminals _lhsOpp _lhsOppL) ) -- cata {-# NOINLINE sem_CNonterminals #-} sem_CNonterminals :: CNonterminals -> T_CNonterminals sem_CNonterminals list = Prelude.foldr sem_CNonterminals_Cons sem_CNonterminals_Nil (Prelude.map sem_CNonterminal list) -- semantic domain newtype T_CNonterminals = T_CNonterminals { attach_T_CNonterminals :: Identity (T_CNonterminals_s11 ) } newtype T_CNonterminals_s11 = C_CNonterminals_s11 { inv_CNonterminals_s11 :: (T_CNonterminals_v10 ) } data T_CNonterminals_s12 = C_CNonterminals_s12 type T_CNonterminals_v10 = (T_CNonterminals_vIn10 ) -> (T_CNonterminals_vOut10 ) data T_CNonterminals_vIn10 = T_CNonterminals_vIn10 data T_CNonterminals_vOut10 = T_CNonterminals_vOut10 (PP_Doc) ([PP_Doc]) {-# NOINLINE sem_CNonterminals_Cons #-} sem_CNonterminals_Cons :: T_CNonterminal -> T_CNonterminals -> T_CNonterminals sem_CNonterminals_Cons arg_hd_ arg_tl_ = T_CNonterminals (return st11) where {-# NOINLINE st11 #-} st11 = let v10 :: T_CNonterminals_v10 v10 = \ (T_CNonterminals_vIn10 ) -> ( let _hdX8 = Control.Monad.Identity.runIdentity (attach_T_CNonterminal (arg_hd_)) _tlX11 = Control.Monad.Identity.runIdentity (attach_T_CNonterminals (arg_tl_)) (T_CNonterminal_vOut7 _hdIpp) = inv_CNonterminal_s8 _hdX8 (T_CNonterminal_vIn7 ) (T_CNonterminals_vOut10 _tlIpp _tlIppL) = inv_CNonterminals_s11 _tlX11 (T_CNonterminals_vIn10 ) _lhsOppL :: [PP_Doc] _lhsOppL = rule3 _hdIpp _tlIppL _lhsOpp :: PP_Doc _lhsOpp = rule4 _hdIpp _tlIpp __result_ = T_CNonterminals_vOut10 _lhsOpp _lhsOppL in __result_ ) in C_CNonterminals_s11 v10 {-# INLINE rule3 #-} {-# LINE 102 "./src-ag/CodeSyntaxDump.ag" #-} rule3 = \ ((_hdIpp) :: PP_Doc) ((_tlIppL) :: [PP_Doc]) -> {-# LINE 102 "./src-ag/CodeSyntaxDump.ag" #-} _hdIpp : _tlIppL {-# LINE 273 "dist/build/CodeSyntaxDump.hs"#-} {-# INLINE rule4 #-} rule4 = \ ((_hdIpp) :: PP_Doc) ((_tlIpp) :: PP_Doc) -> _hdIpp >-< _tlIpp {-# NOINLINE sem_CNonterminals_Nil #-} sem_CNonterminals_Nil :: T_CNonterminals sem_CNonterminals_Nil = T_CNonterminals (return st11) where {-# NOINLINE st11 #-} st11 = let v10 :: T_CNonterminals_v10 v10 = \ (T_CNonterminals_vIn10 ) -> ( let _lhsOppL :: [PP_Doc] _lhsOppL = rule5 () _lhsOpp :: PP_Doc _lhsOpp = rule6 () __result_ = T_CNonterminals_vOut10 _lhsOpp _lhsOppL in __result_ ) in C_CNonterminals_s11 v10 {-# INLINE rule5 #-} {-# LINE 103 "./src-ag/CodeSyntaxDump.ag" #-} rule5 = \ (_ :: ()) -> {-# LINE 103 "./src-ag/CodeSyntaxDump.ag" #-} [] {-# LINE 296 "dist/build/CodeSyntaxDump.hs"#-} {-# INLINE rule6 #-} rule6 = \ (_ :: ()) -> empty -- CProduction ------------------------------------------------- -- wrapper data Inh_CProduction = Inh_CProduction { } data Syn_CProduction = Syn_CProduction { pp_Syn_CProduction :: (PP_Doc) } {-# INLINABLE wrap_CProduction #-} wrap_CProduction :: T_CProduction -> Inh_CProduction -> (Syn_CProduction ) wrap_CProduction (T_CProduction act) (Inh_CProduction ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_CProduction_vIn13 (T_CProduction_vOut13 _lhsOpp) <- return (inv_CProduction_s14 sem arg) return (Syn_CProduction _lhsOpp) ) -- cata {-# INLINE sem_CProduction #-} sem_CProduction :: CProduction -> T_CProduction sem_CProduction ( CProduction con_ visits_ children_ terminals_ ) = sem_CProduction_CProduction con_ ( sem_CVisits visits_ ) children_ terminals_ -- semantic domain newtype T_CProduction = T_CProduction { attach_T_CProduction :: Identity (T_CProduction_s14 ) } newtype T_CProduction_s14 = C_CProduction_s14 { inv_CProduction_s14 :: (T_CProduction_v13 ) } data T_CProduction_s15 = C_CProduction_s15 type T_CProduction_v13 = (T_CProduction_vIn13 ) -> (T_CProduction_vOut13 ) data T_CProduction_vIn13 = T_CProduction_vIn13 data T_CProduction_vOut13 = T_CProduction_vOut13 (PP_Doc) {-# NOINLINE sem_CProduction_CProduction #-} sem_CProduction_CProduction :: (ConstructorIdent) -> T_CVisits -> ([(Identifier,Type,ChildKind)]) -> ([Identifier]) -> T_CProduction sem_CProduction_CProduction arg_con_ arg_visits_ arg_children_ arg_terminals_ = T_CProduction (return st14) where {-# NOINLINE st14 #-} st14 = let v13 :: T_CProduction_v13 v13 = \ (T_CProduction_vIn13 ) -> ( let _visitsX32 = Control.Monad.Identity.runIdentity (attach_T_CVisits (arg_visits_)) (T_CVisits_vOut31 _visitsIpp _visitsIppL) = inv_CVisits_s32 _visitsX32 (T_CVisits_vIn31 ) _lhsOpp :: PP_Doc _lhsOpp = rule7 _visitsIppL arg_children_ arg_con_ arg_terminals_ __result_ = T_CProduction_vOut13 _lhsOpp in __result_ ) in C_CProduction_s14 v13 {-# INLINE rule7 #-} {-# LINE 63 "./src-ag/CodeSyntaxDump.ag" #-} rule7 = \ ((_visitsIppL) :: [PP_Doc]) children_ con_ terminals_ -> {-# LINE 63 "./src-ag/CodeSyntaxDump.ag" #-} ppNestInfo ["CProduction","CProduction"] [pp con_] [ppF "visits" $ ppVList _visitsIppL, ppF "children" $ ppVList (map ppChild children_),ppF "terminals" $ ppVList (map ppShow terminals_)] [] {-# LINE 350 "dist/build/CodeSyntaxDump.hs"#-} -- CProductions ------------------------------------------------ -- wrapper data Inh_CProductions = Inh_CProductions { } data Syn_CProductions = Syn_CProductions { pp_Syn_CProductions :: (PP_Doc), ppL_Syn_CProductions :: ([PP_Doc]) } {-# INLINABLE wrap_CProductions #-} wrap_CProductions :: T_CProductions -> Inh_CProductions -> (Syn_CProductions ) wrap_CProductions (T_CProductions act) (Inh_CProductions ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_CProductions_vIn16 (T_CProductions_vOut16 _lhsOpp _lhsOppL) <- return (inv_CProductions_s17 sem arg) return (Syn_CProductions _lhsOpp _lhsOppL) ) -- cata {-# NOINLINE sem_CProductions #-} sem_CProductions :: CProductions -> T_CProductions sem_CProductions list = Prelude.foldr sem_CProductions_Cons sem_CProductions_Nil (Prelude.map sem_CProduction list) -- semantic domain newtype T_CProductions = T_CProductions { attach_T_CProductions :: Identity (T_CProductions_s17 ) } newtype T_CProductions_s17 = C_CProductions_s17 { inv_CProductions_s17 :: (T_CProductions_v16 ) } data T_CProductions_s18 = C_CProductions_s18 type T_CProductions_v16 = (T_CProductions_vIn16 ) -> (T_CProductions_vOut16 ) data T_CProductions_vIn16 = T_CProductions_vIn16 data T_CProductions_vOut16 = T_CProductions_vOut16 (PP_Doc) ([PP_Doc]) {-# NOINLINE sem_CProductions_Cons #-} sem_CProductions_Cons :: T_CProduction -> T_CProductions -> T_CProductions sem_CProductions_Cons arg_hd_ arg_tl_ = T_CProductions (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_CProductions_v16 v16 = \ (T_CProductions_vIn16 ) -> ( let _hdX14 = Control.Monad.Identity.runIdentity (attach_T_CProduction (arg_hd_)) _tlX17 = Control.Monad.Identity.runIdentity (attach_T_CProductions (arg_tl_)) (T_CProduction_vOut13 _hdIpp) = inv_CProduction_s14 _hdX14 (T_CProduction_vIn13 ) (T_CProductions_vOut16 _tlIpp _tlIppL) = inv_CProductions_s17 _tlX17 (T_CProductions_vIn16 ) _lhsOppL :: [PP_Doc] _lhsOppL = rule8 _hdIpp _tlIppL _lhsOpp :: PP_Doc _lhsOpp = rule9 _hdIpp _tlIpp __result_ = T_CProductions_vOut16 _lhsOpp _lhsOppL in __result_ ) in C_CProductions_s17 v16 {-# INLINE rule8 #-} {-# LINE 94 "./src-ag/CodeSyntaxDump.ag" #-} rule8 = \ ((_hdIpp) :: PP_Doc) ((_tlIppL) :: [PP_Doc]) -> {-# LINE 94 "./src-ag/CodeSyntaxDump.ag" #-} _hdIpp : _tlIppL {-# LINE 405 "dist/build/CodeSyntaxDump.hs"#-} {-# INLINE rule9 #-} rule9 = \ ((_hdIpp) :: PP_Doc) ((_tlIpp) :: PP_Doc) -> _hdIpp >-< _tlIpp {-# NOINLINE sem_CProductions_Nil #-} sem_CProductions_Nil :: T_CProductions sem_CProductions_Nil = T_CProductions (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_CProductions_v16 v16 = \ (T_CProductions_vIn16 ) -> ( let _lhsOppL :: [PP_Doc] _lhsOppL = rule10 () _lhsOpp :: PP_Doc _lhsOpp = rule11 () __result_ = T_CProductions_vOut16 _lhsOpp _lhsOppL in __result_ ) in C_CProductions_s17 v16 {-# INLINE rule10 #-} {-# LINE 95 "./src-ag/CodeSyntaxDump.ag" #-} rule10 = \ (_ :: ()) -> {-# LINE 95 "./src-ag/CodeSyntaxDump.ag" #-} [] {-# LINE 428 "dist/build/CodeSyntaxDump.hs"#-} {-# INLINE rule11 #-} rule11 = \ (_ :: ()) -> empty -- CRule ------------------------------------------------------- -- wrapper data Inh_CRule = Inh_CRule { } data Syn_CRule = Syn_CRule { pp_Syn_CRule :: (PP_Doc) } {-# INLINABLE wrap_CRule #-} wrap_CRule :: T_CRule -> Inh_CRule -> (Syn_CRule ) wrap_CRule (T_CRule act) (Inh_CRule ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_CRule_vIn19 (T_CRule_vOut19 _lhsOpp) <- return (inv_CRule_s20 sem arg) return (Syn_CRule _lhsOpp) ) -- cata {-# NOINLINE sem_CRule #-} sem_CRule :: CRule -> T_CRule sem_CRule ( CRule name_ isIn_ hasCode_ nt_ con_ field_ childnt_ tp_ pattern_ rhs_ defines_ owrt_ origin_ uses_ explicit_ mbNamed_ ) = sem_CRule_CRule name_ isIn_ hasCode_ nt_ con_ field_ childnt_ tp_ ( sem_Pattern pattern_ ) rhs_ defines_ owrt_ origin_ uses_ explicit_ mbNamed_ sem_CRule ( CChildVisit name_ nt_ nr_ inh_ syn_ isLast_ ) = sem_CRule_CChildVisit name_ nt_ nr_ inh_ syn_ isLast_ -- semantic domain newtype T_CRule = T_CRule { attach_T_CRule :: Identity (T_CRule_s20 ) } newtype T_CRule_s20 = C_CRule_s20 { inv_CRule_s20 :: (T_CRule_v19 ) } data T_CRule_s21 = C_CRule_s21 type T_CRule_v19 = (T_CRule_vIn19 ) -> (T_CRule_vOut19 ) data T_CRule_vIn19 = T_CRule_vIn19 data T_CRule_vOut19 = T_CRule_vOut19 (PP_Doc) {-# NOINLINE sem_CRule_CRule #-} sem_CRule_CRule :: (Identifier) -> (Bool) -> (Bool) -> (NontermIdent) -> (ConstructorIdent) -> (Identifier) -> (Maybe NontermIdent) -> (Maybe Type) -> T_Pattern -> ([String]) -> (Map Int (Identifier,Identifier,Maybe Type)) -> (Bool) -> (String) -> (Set (Identifier, Identifier)) -> (Bool) -> (Maybe Identifier) -> T_CRule sem_CRule_CRule arg_name_ arg_isIn_ arg_hasCode_ arg_nt_ arg_con_ arg_field_ arg_childnt_ arg_tp_ arg_pattern_ arg_rhs_ arg_defines_ arg_owrt_ arg_origin_ _ _ _ = T_CRule (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_CRule_v19 v19 = \ (T_CRule_vIn19 ) -> ( let _patternX35 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pattern_)) (T_Pattern_vOut34 _patternIcopy _patternIpp) = inv_Pattern_s35 _patternX35 (T_Pattern_vIn34 ) _lhsOpp :: PP_Doc _lhsOpp = rule12 _patternIpp arg_childnt_ arg_con_ arg_defines_ arg_field_ arg_hasCode_ arg_isIn_ arg_name_ arg_nt_ arg_origin_ arg_owrt_ arg_rhs_ arg_tp_ __result_ = T_CRule_vOut19 _lhsOpp in __result_ ) in C_CRule_s20 v19 {-# INLINE rule12 #-} {-# LINE 69 "./src-ag/CodeSyntaxDump.ag" #-} rule12 = \ ((_patternIpp) :: PP_Doc) childnt_ con_ defines_ field_ hasCode_ isIn_ name_ nt_ origin_ owrt_ rhs_ tp_ -> {-# LINE 69 "./src-ag/CodeSyntaxDump.ag" #-} 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 "" else _patternIpp, ppF "rhs" $ ppStrings rhs_, ppF "defines" $ ppVertexMap defines_, ppF "owrt" $ ppBool owrt_, ppF "origin" $ pp origin_] [] {-# LINE 483 "dist/build/CodeSyntaxDump.hs"#-} {-# NOINLINE sem_CRule_CChildVisit #-} sem_CRule_CChildVisit :: (Identifier) -> (NontermIdent) -> (Int) -> (Attributes) -> (Attributes) -> (Bool) -> T_CRule sem_CRule_CChildVisit arg_name_ arg_nt_ arg_nr_ arg_inh_ arg_syn_ arg_isLast_ = T_CRule (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_CRule_v19 v19 = \ (T_CRule_vIn19 ) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule13 arg_inh_ arg_isLast_ arg_name_ arg_nr_ arg_nt_ arg_syn_ __result_ = T_CRule_vOut19 _lhsOpp in __result_ ) in C_CRule_s20 v19 {-# INLINE rule13 #-} {-# LINE 70 "./src-ag/CodeSyntaxDump.ag" #-} rule13 = \ inh_ isLast_ name_ nr_ nt_ syn_ -> {-# LINE 70 "./src-ag/CodeSyntaxDump.ag" #-} 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_] [] {-# LINE 501 "dist/build/CodeSyntaxDump.hs"#-} -- CSegment ---------------------------------------------------- -- wrapper data Inh_CSegment = Inh_CSegment { } data Syn_CSegment = Syn_CSegment { pp_Syn_CSegment :: (PP_Doc) } {-# INLINABLE wrap_CSegment #-} wrap_CSegment :: T_CSegment -> Inh_CSegment -> (Syn_CSegment ) wrap_CSegment (T_CSegment act) (Inh_CSegment ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_CSegment_vIn22 (T_CSegment_vOut22 _lhsOpp) <- return (inv_CSegment_s23 sem arg) return (Syn_CSegment _lhsOpp) ) -- cata {-# INLINE sem_CSegment #-} sem_CSegment :: CSegment -> T_CSegment sem_CSegment ( CSegment inh_ syn_ ) = sem_CSegment_CSegment inh_ syn_ -- semantic domain newtype T_CSegment = T_CSegment { attach_T_CSegment :: Identity (T_CSegment_s23 ) } newtype T_CSegment_s23 = C_CSegment_s23 { inv_CSegment_s23 :: (T_CSegment_v22 ) } data T_CSegment_s24 = C_CSegment_s24 type T_CSegment_v22 = (T_CSegment_vIn22 ) -> (T_CSegment_vOut22 ) data T_CSegment_vIn22 = T_CSegment_vIn22 data T_CSegment_vOut22 = T_CSegment_vOut22 (PP_Doc) {-# NOINLINE sem_CSegment_CSegment #-} sem_CSegment_CSegment :: (Attributes) -> (Attributes) -> T_CSegment sem_CSegment_CSegment arg_inh_ arg_syn_ = T_CSegment (return st23) where {-# NOINLINE st23 #-} st23 = let v22 :: T_CSegment_v22 v22 = \ (T_CSegment_vIn22 ) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule14 arg_inh_ arg_syn_ __result_ = T_CSegment_vOut22 _lhsOpp in __result_ ) in C_CSegment_s23 v22 {-# INLINE rule14 #-} {-# LINE 60 "./src-ag/CodeSyntaxDump.ag" #-} rule14 = \ inh_ syn_ -> {-# LINE 60 "./src-ag/CodeSyntaxDump.ag" #-} ppNestInfo ["CSegment","CSegment"] [] [ppF "inh" $ ppMap inh_, ppF "syn" $ ppMap syn_] [] {-# LINE 550 "dist/build/CodeSyntaxDump.hs"#-} -- CSegments --------------------------------------------------- -- wrapper data Inh_CSegments = Inh_CSegments { } data Syn_CSegments = Syn_CSegments { pp_Syn_CSegments :: (PP_Doc), ppL_Syn_CSegments :: ([PP_Doc]) } {-# INLINABLE wrap_CSegments #-} wrap_CSegments :: T_CSegments -> Inh_CSegments -> (Syn_CSegments ) wrap_CSegments (T_CSegments act) (Inh_CSegments ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_CSegments_vIn25 (T_CSegments_vOut25 _lhsOpp _lhsOppL) <- return (inv_CSegments_s26 sem arg) return (Syn_CSegments _lhsOpp _lhsOppL) ) -- cata {-# NOINLINE sem_CSegments #-} sem_CSegments :: CSegments -> T_CSegments sem_CSegments list = Prelude.foldr sem_CSegments_Cons sem_CSegments_Nil (Prelude.map sem_CSegment list) -- semantic domain newtype T_CSegments = T_CSegments { attach_T_CSegments :: Identity (T_CSegments_s26 ) } newtype T_CSegments_s26 = C_CSegments_s26 { inv_CSegments_s26 :: (T_CSegments_v25 ) } data T_CSegments_s27 = C_CSegments_s27 type T_CSegments_v25 = (T_CSegments_vIn25 ) -> (T_CSegments_vOut25 ) data T_CSegments_vIn25 = T_CSegments_vIn25 data T_CSegments_vOut25 = T_CSegments_vOut25 (PP_Doc) ([PP_Doc]) {-# NOINLINE sem_CSegments_Cons #-} sem_CSegments_Cons :: T_CSegment -> T_CSegments -> T_CSegments sem_CSegments_Cons arg_hd_ arg_tl_ = T_CSegments (return st26) where {-# NOINLINE st26 #-} st26 = let v25 :: T_CSegments_v25 v25 = \ (T_CSegments_vIn25 ) -> ( let _hdX23 = Control.Monad.Identity.runIdentity (attach_T_CSegment (arg_hd_)) _tlX26 = Control.Monad.Identity.runIdentity (attach_T_CSegments (arg_tl_)) (T_CSegment_vOut22 _hdIpp) = inv_CSegment_s23 _hdX23 (T_CSegment_vIn22 ) (T_CSegments_vOut25 _tlIpp _tlIppL) = inv_CSegments_s26 _tlX26 (T_CSegments_vIn25 ) _lhsOppL :: [PP_Doc] _lhsOppL = rule15 _hdIpp _tlIppL _lhsOpp :: PP_Doc _lhsOpp = rule16 _hdIpp _tlIpp __result_ = T_CSegments_vOut25 _lhsOpp _lhsOppL in __result_ ) in C_CSegments_s26 v25 {-# INLINE rule15 #-} {-# LINE 98 "./src-ag/CodeSyntaxDump.ag" #-} rule15 = \ ((_hdIpp) :: PP_Doc) ((_tlIppL) :: [PP_Doc]) -> {-# LINE 98 "./src-ag/CodeSyntaxDump.ag" #-} _hdIpp : _tlIppL {-# LINE 605 "dist/build/CodeSyntaxDump.hs"#-} {-# INLINE rule16 #-} rule16 = \ ((_hdIpp) :: PP_Doc) ((_tlIpp) :: PP_Doc) -> _hdIpp >-< _tlIpp {-# NOINLINE sem_CSegments_Nil #-} sem_CSegments_Nil :: T_CSegments sem_CSegments_Nil = T_CSegments (return st26) where {-# NOINLINE st26 #-} st26 = let v25 :: T_CSegments_v25 v25 = \ (T_CSegments_vIn25 ) -> ( let _lhsOppL :: [PP_Doc] _lhsOppL = rule17 () _lhsOpp :: PP_Doc _lhsOpp = rule18 () __result_ = T_CSegments_vOut25 _lhsOpp _lhsOppL in __result_ ) in C_CSegments_s26 v25 {-# INLINE rule17 #-} {-# LINE 99 "./src-ag/CodeSyntaxDump.ag" #-} rule17 = \ (_ :: ()) -> {-# LINE 99 "./src-ag/CodeSyntaxDump.ag" #-} [] {-# LINE 628 "dist/build/CodeSyntaxDump.hs"#-} {-# INLINE rule18 #-} rule18 = \ (_ :: ()) -> empty -- CVisit ------------------------------------------------------ -- wrapper data Inh_CVisit = Inh_CVisit { } data Syn_CVisit = Syn_CVisit { pp_Syn_CVisit :: (PP_Doc) } {-# INLINABLE wrap_CVisit #-} wrap_CVisit :: T_CVisit -> Inh_CVisit -> (Syn_CVisit ) wrap_CVisit (T_CVisit act) (Inh_CVisit ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_CVisit_vIn28 (T_CVisit_vOut28 _lhsOpp) <- return (inv_CVisit_s29 sem arg) return (Syn_CVisit _lhsOpp) ) -- cata {-# INLINE sem_CVisit #-} sem_CVisit :: CVisit -> T_CVisit sem_CVisit ( CVisit inh_ syn_ vss_ intra_ ordered_ ) = sem_CVisit_CVisit inh_ syn_ ( sem_Sequence vss_ ) ( sem_Sequence intra_ ) ordered_ -- semantic domain newtype T_CVisit = T_CVisit { attach_T_CVisit :: Identity (T_CVisit_s29 ) } newtype T_CVisit_s29 = C_CVisit_s29 { inv_CVisit_s29 :: (T_CVisit_v28 ) } data T_CVisit_s30 = C_CVisit_s30 type T_CVisit_v28 = (T_CVisit_vIn28 ) -> (T_CVisit_vOut28 ) data T_CVisit_vIn28 = T_CVisit_vIn28 data T_CVisit_vOut28 = T_CVisit_vOut28 (PP_Doc) {-# NOINLINE sem_CVisit_CVisit #-} sem_CVisit_CVisit :: (Attributes) -> (Attributes) -> T_Sequence -> T_Sequence -> (Bool) -> T_CVisit sem_CVisit_CVisit arg_inh_ arg_syn_ arg_vss_ arg_intra_ arg_ordered_ = T_CVisit (return st29) where {-# NOINLINE st29 #-} st29 = let v28 :: T_CVisit_v28 v28 = \ (T_CVisit_vIn28 ) -> ( let _vssX41 = Control.Monad.Identity.runIdentity (attach_T_Sequence (arg_vss_)) _intraX41 = Control.Monad.Identity.runIdentity (attach_T_Sequence (arg_intra_)) (T_Sequence_vOut40 _vssIppL) = inv_Sequence_s41 _vssX41 (T_Sequence_vIn40 ) (T_Sequence_vOut40 _intraIppL) = inv_Sequence_s41 _intraX41 (T_Sequence_vIn40 ) _lhsOpp :: PP_Doc _lhsOpp = rule19 _intraIppL _vssIppL arg_inh_ arg_ordered_ arg_syn_ __result_ = T_CVisit_vOut28 _lhsOpp in __result_ ) in C_CVisit_s29 v28 {-# INLINE rule19 #-} {-# LINE 66 "./src-ag/CodeSyntaxDump.ag" #-} rule19 = \ ((_intraIppL) :: [PP_Doc]) ((_vssIppL) :: [PP_Doc]) inh_ ordered_ syn_ -> {-# LINE 66 "./src-ag/CodeSyntaxDump.ag" #-} ppNestInfo ["CVisit","CVisit"] [] [ppF "inh" $ ppMap inh_, ppF "syn" $ ppMap syn_, ppF "sequence" $ ppVList _vssIppL, ppF "intra" $ ppVList _intraIppL, ppF "ordered" $ ppBool ordered_] [] {-# LINE 684 "dist/build/CodeSyntaxDump.hs"#-} -- CVisits ----------------------------------------------------- -- wrapper data Inh_CVisits = Inh_CVisits { } data Syn_CVisits = Syn_CVisits { pp_Syn_CVisits :: (PP_Doc), ppL_Syn_CVisits :: ([PP_Doc]) } {-# INLINABLE wrap_CVisits #-} wrap_CVisits :: T_CVisits -> Inh_CVisits -> (Syn_CVisits ) wrap_CVisits (T_CVisits act) (Inh_CVisits ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_CVisits_vIn31 (T_CVisits_vOut31 _lhsOpp _lhsOppL) <- return (inv_CVisits_s32 sem arg) return (Syn_CVisits _lhsOpp _lhsOppL) ) -- cata {-# NOINLINE sem_CVisits #-} sem_CVisits :: CVisits -> T_CVisits sem_CVisits list = Prelude.foldr sem_CVisits_Cons sem_CVisits_Nil (Prelude.map sem_CVisit list) -- semantic domain newtype T_CVisits = T_CVisits { attach_T_CVisits :: Identity (T_CVisits_s32 ) } newtype T_CVisits_s32 = C_CVisits_s32 { inv_CVisits_s32 :: (T_CVisits_v31 ) } data T_CVisits_s33 = C_CVisits_s33 type T_CVisits_v31 = (T_CVisits_vIn31 ) -> (T_CVisits_vOut31 ) data T_CVisits_vIn31 = T_CVisits_vIn31 data T_CVisits_vOut31 = T_CVisits_vOut31 (PP_Doc) ([PP_Doc]) {-# NOINLINE sem_CVisits_Cons #-} sem_CVisits_Cons :: T_CVisit -> T_CVisits -> T_CVisits sem_CVisits_Cons arg_hd_ arg_tl_ = T_CVisits (return st32) where {-# NOINLINE st32 #-} st32 = let v31 :: T_CVisits_v31 v31 = \ (T_CVisits_vIn31 ) -> ( let _hdX29 = Control.Monad.Identity.runIdentity (attach_T_CVisit (arg_hd_)) _tlX32 = Control.Monad.Identity.runIdentity (attach_T_CVisits (arg_tl_)) (T_CVisit_vOut28 _hdIpp) = inv_CVisit_s29 _hdX29 (T_CVisit_vIn28 ) (T_CVisits_vOut31 _tlIpp _tlIppL) = inv_CVisits_s32 _tlX32 (T_CVisits_vIn31 ) _lhsOppL :: [PP_Doc] _lhsOppL = rule20 _hdIpp _tlIppL _lhsOpp :: PP_Doc _lhsOpp = rule21 _hdIpp _tlIpp __result_ = T_CVisits_vOut31 _lhsOpp _lhsOppL in __result_ ) in C_CVisits_s32 v31 {-# INLINE rule20 #-} {-# LINE 90 "./src-ag/CodeSyntaxDump.ag" #-} rule20 = \ ((_hdIpp) :: PP_Doc) ((_tlIppL) :: [PP_Doc]) -> {-# LINE 90 "./src-ag/CodeSyntaxDump.ag" #-} _hdIpp : _tlIppL {-# LINE 739 "dist/build/CodeSyntaxDump.hs"#-} {-# INLINE rule21 #-} rule21 = \ ((_hdIpp) :: PP_Doc) ((_tlIpp) :: PP_Doc) -> _hdIpp >-< _tlIpp {-# NOINLINE sem_CVisits_Nil #-} sem_CVisits_Nil :: T_CVisits sem_CVisits_Nil = T_CVisits (return st32) where {-# NOINLINE st32 #-} st32 = let v31 :: T_CVisits_v31 v31 = \ (T_CVisits_vIn31 ) -> ( let _lhsOppL :: [PP_Doc] _lhsOppL = rule22 () _lhsOpp :: PP_Doc _lhsOpp = rule23 () __result_ = T_CVisits_vOut31 _lhsOpp _lhsOppL in __result_ ) in C_CVisits_s32 v31 {-# INLINE rule22 #-} {-# LINE 91 "./src-ag/CodeSyntaxDump.ag" #-} rule22 = \ (_ :: ()) -> {-# LINE 91 "./src-ag/CodeSyntaxDump.ag" #-} [] {-# LINE 762 "dist/build/CodeSyntaxDump.hs"#-} {-# INLINE rule23 #-} rule23 = \ (_ :: ()) -> empty -- Pattern ----------------------------------------------------- -- wrapper data Inh_Pattern = Inh_Pattern { } data Syn_Pattern = Syn_Pattern { copy_Syn_Pattern :: (Pattern), pp_Syn_Pattern :: (PP_Doc) } {-# INLINABLE wrap_Pattern #-} wrap_Pattern :: T_Pattern -> Inh_Pattern -> (Syn_Pattern ) wrap_Pattern (T_Pattern act) (Inh_Pattern ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Pattern_vIn34 (T_Pattern_vOut34 _lhsOcopy _lhsOpp) <- return (inv_Pattern_s35 sem arg) return (Syn_Pattern _lhsOcopy _lhsOpp) ) -- cata {-# NOINLINE sem_Pattern #-} sem_Pattern :: Pattern -> T_Pattern sem_Pattern ( Constr name_ pats_ ) = sem_Pattern_Constr name_ ( sem_Patterns pats_ ) sem_Pattern ( Product pos_ pats_ ) = sem_Pattern_Product pos_ ( sem_Patterns pats_ ) sem_Pattern ( Alias field_ attr_ pat_ ) = sem_Pattern_Alias field_ attr_ ( sem_Pattern pat_ ) sem_Pattern ( Irrefutable pat_ ) = sem_Pattern_Irrefutable ( sem_Pattern pat_ ) sem_Pattern ( Underscore pos_ ) = sem_Pattern_Underscore pos_ -- semantic domain newtype T_Pattern = T_Pattern { attach_T_Pattern :: Identity (T_Pattern_s35 ) } newtype T_Pattern_s35 = C_Pattern_s35 { inv_Pattern_s35 :: (T_Pattern_v34 ) } data T_Pattern_s36 = C_Pattern_s36 type T_Pattern_v34 = (T_Pattern_vIn34 ) -> (T_Pattern_vOut34 ) data T_Pattern_vIn34 = T_Pattern_vIn34 data T_Pattern_vOut34 = T_Pattern_vOut34 (Pattern) (PP_Doc) {-# NOINLINE sem_Pattern_Constr #-} sem_Pattern_Constr :: (ConstructorIdent) -> T_Patterns -> T_Pattern sem_Pattern_Constr arg_name_ arg_pats_ = T_Pattern (return st35) where {-# NOINLINE st35 #-} st35 = let v34 :: T_Pattern_v34 v34 = \ (T_Pattern_vIn34 ) -> ( let _patsX38 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) (T_Patterns_vOut37 _patsIcopy _patsIpp _patsIppL) = inv_Patterns_s38 _patsX38 (T_Patterns_vIn37 ) _lhsOpp :: PP_Doc _lhsOpp = rule24 _patsIppL arg_name_ _copy = rule25 _patsIcopy arg_name_ _lhsOcopy :: Pattern _lhsOcopy = rule26 _copy __result_ = T_Pattern_vOut34 _lhsOcopy _lhsOpp in __result_ ) in C_Pattern_s35 v34 {-# INLINE rule24 #-} {-# LINE 73 "./src-ag/CodeSyntaxDump.ag" #-} rule24 = \ ((_patsIppL) :: [PP_Doc]) name_ -> {-# LINE 73 "./src-ag/CodeSyntaxDump.ag" #-} ppNestInfo ["Pattern","Constr"] [pp name_] [ppF "pats" $ ppVList _patsIppL] [] {-# LINE 823 "dist/build/CodeSyntaxDump.hs"#-} {-# INLINE rule25 #-} rule25 = \ ((_patsIcopy) :: Patterns) name_ -> Constr name_ _patsIcopy {-# INLINE rule26 #-} rule26 = \ _copy -> _copy {-# NOINLINE sem_Pattern_Product #-} sem_Pattern_Product :: (Pos) -> T_Patterns -> T_Pattern sem_Pattern_Product arg_pos_ arg_pats_ = T_Pattern (return st35) where {-# NOINLINE st35 #-} st35 = let v34 :: T_Pattern_v34 v34 = \ (T_Pattern_vIn34 ) -> ( let _patsX38 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) (T_Patterns_vOut37 _patsIcopy _patsIpp _patsIppL) = inv_Patterns_s38 _patsX38 (T_Patterns_vIn37 ) _lhsOpp :: PP_Doc _lhsOpp = rule27 _patsIppL arg_pos_ _copy = rule28 _patsIcopy arg_pos_ _lhsOcopy :: Pattern _lhsOcopy = rule29 _copy __result_ = T_Pattern_vOut34 _lhsOcopy _lhsOpp in __result_ ) in C_Pattern_s35 v34 {-# INLINE rule27 #-} {-# LINE 74 "./src-ag/CodeSyntaxDump.ag" #-} rule27 = \ ((_patsIppL) :: [PP_Doc]) pos_ -> {-# LINE 74 "./src-ag/CodeSyntaxDump.ag" #-} ppNestInfo ["Pattern","Product"] [ppShow pos_] [ppF "pats" $ ppVList _patsIppL] [] {-# LINE 852 "dist/build/CodeSyntaxDump.hs"#-} {-# INLINE rule28 #-} rule28 = \ ((_patsIcopy) :: Patterns) pos_ -> Product pos_ _patsIcopy {-# INLINE rule29 #-} rule29 = \ _copy -> _copy {-# NOINLINE sem_Pattern_Alias #-} sem_Pattern_Alias :: (Identifier) -> (Identifier) -> T_Pattern -> T_Pattern sem_Pattern_Alias arg_field_ arg_attr_ arg_pat_ = T_Pattern (return st35) where {-# NOINLINE st35 #-} st35 = let v34 :: T_Pattern_v34 v34 = \ (T_Pattern_vIn34 ) -> ( let _patX35 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) (T_Pattern_vOut34 _patIcopy _patIpp) = inv_Pattern_s35 _patX35 (T_Pattern_vIn34 ) _lhsOpp :: PP_Doc _lhsOpp = rule30 _patIpp arg_attr_ arg_field_ _copy = rule31 _patIcopy arg_attr_ arg_field_ _lhsOcopy :: Pattern _lhsOcopy = rule32 _copy __result_ = T_Pattern_vOut34 _lhsOcopy _lhsOpp in __result_ ) in C_Pattern_s35 v34 {-# INLINE rule30 #-} {-# LINE 75 "./src-ag/CodeSyntaxDump.ag" #-} rule30 = \ ((_patIpp) :: PP_Doc) attr_ field_ -> {-# LINE 75 "./src-ag/CodeSyntaxDump.ag" #-} ppNestInfo ["Pattern","Alias"] [pp field_, pp attr_] [ppF "pat" $ _patIpp] [] {-# LINE 881 "dist/build/CodeSyntaxDump.hs"#-} {-# INLINE rule31 #-} rule31 = \ ((_patIcopy) :: Pattern) attr_ field_ -> Alias field_ attr_ _patIcopy {-# INLINE rule32 #-} rule32 = \ _copy -> _copy {-# NOINLINE sem_Pattern_Irrefutable #-} sem_Pattern_Irrefutable :: T_Pattern -> T_Pattern sem_Pattern_Irrefutable arg_pat_ = T_Pattern (return st35) where {-# NOINLINE st35 #-} st35 = let v34 :: T_Pattern_v34 v34 = \ (T_Pattern_vIn34 ) -> ( let _patX35 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) (T_Pattern_vOut34 _patIcopy _patIpp) = inv_Pattern_s35 _patX35 (T_Pattern_vIn34 ) _lhsOpp :: PP_Doc _lhsOpp = rule33 _patIpp _copy = rule34 _patIcopy _lhsOcopy :: Pattern _lhsOcopy = rule35 _copy __result_ = T_Pattern_vOut34 _lhsOcopy _lhsOpp in __result_ ) in C_Pattern_s35 v34 {-# INLINE rule33 #-} rule33 = \ ((_patIpp) :: PP_Doc) -> _patIpp {-# INLINE rule34 #-} rule34 = \ ((_patIcopy) :: Pattern) -> Irrefutable _patIcopy {-# INLINE rule35 #-} rule35 = \ _copy -> _copy {-# NOINLINE sem_Pattern_Underscore #-} sem_Pattern_Underscore :: (Pos) -> T_Pattern sem_Pattern_Underscore arg_pos_ = T_Pattern (return st35) where {-# NOINLINE st35 #-} st35 = let v34 :: T_Pattern_v34 v34 = \ (T_Pattern_vIn34 ) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule36 arg_pos_ _copy = rule37 arg_pos_ _lhsOcopy :: Pattern _lhsOcopy = rule38 _copy __result_ = T_Pattern_vOut34 _lhsOcopy _lhsOpp in __result_ ) in C_Pattern_s35 v34 {-# INLINE rule36 #-} {-# LINE 76 "./src-ag/CodeSyntaxDump.ag" #-} rule36 = \ pos_ -> {-# LINE 76 "./src-ag/CodeSyntaxDump.ag" #-} ppNestInfo ["Pattern","Underscore"] [ppShow pos_] [] [] {-# LINE 934 "dist/build/CodeSyntaxDump.hs"#-} {-# INLINE rule37 #-} rule37 = \ pos_ -> Underscore pos_ {-# INLINE rule38 #-} rule38 = \ _copy -> _copy -- Patterns ---------------------------------------------------- -- wrapper data Inh_Patterns = Inh_Patterns { } data Syn_Patterns = Syn_Patterns { copy_Syn_Patterns :: (Patterns), pp_Syn_Patterns :: (PP_Doc), ppL_Syn_Patterns :: ([PP_Doc]) } {-# INLINABLE wrap_Patterns #-} wrap_Patterns :: T_Patterns -> Inh_Patterns -> (Syn_Patterns ) wrap_Patterns (T_Patterns act) (Inh_Patterns ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Patterns_vIn37 (T_Patterns_vOut37 _lhsOcopy _lhsOpp _lhsOppL) <- return (inv_Patterns_s38 sem arg) return (Syn_Patterns _lhsOcopy _lhsOpp _lhsOppL) ) -- cata {-# NOINLINE sem_Patterns #-} sem_Patterns :: Patterns -> T_Patterns sem_Patterns list = Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list) -- semantic domain newtype T_Patterns = T_Patterns { attach_T_Patterns :: Identity (T_Patterns_s38 ) } newtype T_Patterns_s38 = C_Patterns_s38 { inv_Patterns_s38 :: (T_Patterns_v37 ) } data T_Patterns_s39 = C_Patterns_s39 type T_Patterns_v37 = (T_Patterns_vIn37 ) -> (T_Patterns_vOut37 ) data T_Patterns_vIn37 = T_Patterns_vIn37 data T_Patterns_vOut37 = T_Patterns_vOut37 (Patterns) (PP_Doc) ([PP_Doc]) {-# NOINLINE sem_Patterns_Cons #-} sem_Patterns_Cons :: T_Pattern -> T_Patterns -> T_Patterns sem_Patterns_Cons arg_hd_ arg_tl_ = T_Patterns (return st38) where {-# NOINLINE st38 #-} st38 = let v37 :: T_Patterns_v37 v37 = \ (T_Patterns_vIn37 ) -> ( let _hdX35 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_hd_)) _tlX38 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_tl_)) (T_Pattern_vOut34 _hdIcopy _hdIpp) = inv_Pattern_s35 _hdX35 (T_Pattern_vIn34 ) (T_Patterns_vOut37 _tlIcopy _tlIpp _tlIppL) = inv_Patterns_s38 _tlX38 (T_Patterns_vIn37 ) _lhsOppL :: [PP_Doc] _lhsOppL = rule39 _hdIpp _tlIppL _lhsOpp :: PP_Doc _lhsOpp = rule40 _hdIpp _tlIpp _copy = rule41 _hdIcopy _tlIcopy _lhsOcopy :: Patterns _lhsOcopy = rule42 _copy __result_ = T_Patterns_vOut37 _lhsOcopy _lhsOpp _lhsOppL in __result_ ) in C_Patterns_s38 v37 {-# INLINE rule39 #-} {-# LINE 82 "./src-ag/CodeSyntaxDump.ag" #-} rule39 = \ ((_hdIpp) :: PP_Doc) ((_tlIppL) :: [PP_Doc]) -> {-# LINE 82 "./src-ag/CodeSyntaxDump.ag" #-} _hdIpp : _tlIppL {-# LINE 998 "dist/build/CodeSyntaxDump.hs"#-} {-# INLINE rule40 #-} rule40 = \ ((_hdIpp) :: PP_Doc) ((_tlIpp) :: PP_Doc) -> _hdIpp >-< _tlIpp {-# INLINE rule41 #-} rule41 = \ ((_hdIcopy) :: Pattern) ((_tlIcopy) :: Patterns) -> (:) _hdIcopy _tlIcopy {-# INLINE rule42 #-} rule42 = \ _copy -> _copy {-# NOINLINE sem_Patterns_Nil #-} sem_Patterns_Nil :: T_Patterns sem_Patterns_Nil = T_Patterns (return st38) where {-# NOINLINE st38 #-} st38 = let v37 :: T_Patterns_v37 v37 = \ (T_Patterns_vIn37 ) -> ( let _lhsOppL :: [PP_Doc] _lhsOppL = rule43 () _lhsOpp :: PP_Doc _lhsOpp = rule44 () _copy = rule45 () _lhsOcopy :: Patterns _lhsOcopy = rule46 _copy __result_ = T_Patterns_vOut37 _lhsOcopy _lhsOpp _lhsOppL in __result_ ) in C_Patterns_s38 v37 {-# INLINE rule43 #-} {-# LINE 83 "./src-ag/CodeSyntaxDump.ag" #-} rule43 = \ (_ :: ()) -> {-# LINE 83 "./src-ag/CodeSyntaxDump.ag" #-} [] {-# LINE 1030 "dist/build/CodeSyntaxDump.hs"#-} {-# INLINE rule44 #-} rule44 = \ (_ :: ()) -> empty {-# INLINE rule45 #-} rule45 = \ (_ :: ()) -> [] {-# INLINE rule46 #-} rule46 = \ _copy -> _copy -- Sequence ---------------------------------------------------- -- wrapper data Inh_Sequence = Inh_Sequence { } data Syn_Sequence = Syn_Sequence { ppL_Syn_Sequence :: ([PP_Doc]) } {-# INLINABLE wrap_Sequence #-} wrap_Sequence :: T_Sequence -> Inh_Sequence -> (Syn_Sequence ) wrap_Sequence (T_Sequence act) (Inh_Sequence ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Sequence_vIn40 (T_Sequence_vOut40 _lhsOppL) <- return (inv_Sequence_s41 sem arg) return (Syn_Sequence _lhsOppL) ) -- cata {-# NOINLINE sem_Sequence #-} sem_Sequence :: Sequence -> T_Sequence sem_Sequence list = Prelude.foldr sem_Sequence_Cons sem_Sequence_Nil (Prelude.map sem_CRule list) -- semantic domain newtype T_Sequence = T_Sequence { attach_T_Sequence :: Identity (T_Sequence_s41 ) } newtype T_Sequence_s41 = C_Sequence_s41 { inv_Sequence_s41 :: (T_Sequence_v40 ) } data T_Sequence_s42 = C_Sequence_s42 type T_Sequence_v40 = (T_Sequence_vIn40 ) -> (T_Sequence_vOut40 ) data T_Sequence_vIn40 = T_Sequence_vIn40 data T_Sequence_vOut40 = T_Sequence_vOut40 ([PP_Doc]) {-# NOINLINE sem_Sequence_Cons #-} sem_Sequence_Cons :: T_CRule -> T_Sequence -> T_Sequence sem_Sequence_Cons arg_hd_ arg_tl_ = T_Sequence (return st41) where {-# NOINLINE st41 #-} st41 = let v40 :: T_Sequence_v40 v40 = \ (T_Sequence_vIn40 ) -> ( let _hdX20 = Control.Monad.Identity.runIdentity (attach_T_CRule (arg_hd_)) _tlX41 = Control.Monad.Identity.runIdentity (attach_T_Sequence (arg_tl_)) (T_CRule_vOut19 _hdIpp) = inv_CRule_s20 _hdX20 (T_CRule_vIn19 ) (T_Sequence_vOut40 _tlIppL) = inv_Sequence_s41 _tlX41 (T_Sequence_vIn40 ) _lhsOppL :: [PP_Doc] _lhsOppL = rule47 _hdIpp _tlIppL __result_ = T_Sequence_vOut40 _lhsOppL in __result_ ) in C_Sequence_s41 v40 {-# INLINE rule47 #-} {-# LINE 86 "./src-ag/CodeSyntaxDump.ag" #-} rule47 = \ ((_hdIpp) :: PP_Doc) ((_tlIppL) :: [PP_Doc]) -> {-# LINE 86 "./src-ag/CodeSyntaxDump.ag" #-} _hdIpp : _tlIppL {-# LINE 1092 "dist/build/CodeSyntaxDump.hs"#-} {-# NOINLINE sem_Sequence_Nil #-} sem_Sequence_Nil :: T_Sequence sem_Sequence_Nil = T_Sequence (return st41) where {-# NOINLINE st41 #-} st41 = let v40 :: T_Sequence_v40 v40 = \ (T_Sequence_vIn40 ) -> ( let _lhsOppL :: [PP_Doc] _lhsOppL = rule48 () __result_ = T_Sequence_vOut40 _lhsOppL in __result_ ) in C_Sequence_s41 v40 {-# INLINE rule48 #-} {-# LINE 87 "./src-ag/CodeSyntaxDump.ag" #-} rule48 = \ (_ :: ()) -> {-# LINE 87 "./src-ag/CodeSyntaxDump.ag" #-} [] {-# LINE 1110 "dist/build/CodeSyntaxDump.hs"#-} uuagc-0.9.42.3/src-generated/ConcreteSyntax.hs000644 000765 000024 00000022001 12127045231 023071 0ustar00jeroenbransenstaff000000 000000 -- UUAGC 0.9.42.3 (src-ag/ConcreteSyntax.ag) module ConcreteSyntax where {-# LINE 2 "./src-ag/ConcreteSyntax.ag" #-} import UU.Scanner.Position (Pos) import Patterns (Pattern) import Expression (Expression) import CommonTypes import Macro --marcos {-# LINE 13 "dist/build/ConcreteSyntax.hs" #-} -- AG ---------------------------------------------------------- {- alternatives: alternative AG: child elems : Elems -} data AG = AG (Elems) -- Alt --------------------------------------------------------- {- alternatives: alternative Alt: child pos : {Pos} child names : ConstructorSet child tyvars : {[Identifier]} child fields : Fields child macro : {MaybeMacro} -} data Alt = Alt (Pos) (ConstructorSet) (([Identifier])) (Fields) (MaybeMacro) -- Alts -------------------------------------------------------- {- alternatives: alternative Cons: child hd : Alt child tl : Alts alternative Nil: -} type Alts = [Alt] -- Attrs ------------------------------------------------------- {- alternatives: alternative Attrs: child pos : {Pos} child inh : {AttrNames} child chn : {AttrNames} child syn : {AttrNames} -} data Attrs = Attrs (Pos) (AttrNames) (AttrNames) (AttrNames) -- ConstructorSet ---------------------------------------------- {- alternatives: alternative CName: child name : {ConstructorIdent} alternative CUnion: child set1 : ConstructorSet child set2 : ConstructorSet alternative CDifference: child set1 : ConstructorSet child set2 : ConstructorSet alternative CAll: -} data ConstructorSet = CName (ConstructorIdent) | CUnion (ConstructorSet) (ConstructorSet) | CDifference (ConstructorSet) (ConstructorSet) | CAll -- Elem -------------------------------------------------------- {- alternatives: alternative Data: child pos : {Pos} child ctx : {ClassContext} child names : NontSet child params : {[Identifier]} child attrs : Attrs child alts : Alts child ext : {Bool} alternative Type: child pos : {Pos} child ctx : {ClassContext} child name : {NontermIdent} child params : {[Identifier]} child type : {ComplexType} alternative Attr: child pos : {Pos} child ctx : {ClassContext} child names : NontSet child quants : {[String]} child attrs : Attrs alternative Sem: child pos : {Pos} child ctx : {ClassContext} child names : NontSet child attrs : Attrs child quants : {[String]} child alts : SemAlts alternative Txt: child pos : {Pos} child kind : {BlockKind} child mbNt : {Maybe NontermIdent} child lines : {[String]} alternative Set: child pos : {Pos} child name : {NontermIdent} child merge : {Bool} child set : NontSet alternative Deriving: child pos : {Pos} child set : NontSet child classes : {[NontermIdent]} alternative Wrapper: child pos : {Pos} child set : NontSet alternative Nocatas: child pos : {Pos} child set : NontSet alternative Pragma: child pos : {Pos} child names : {[NontermIdent]} alternative Module: child pos : {Pos} child name : {String} child exports : {String} child imports : {String} -} data Elem = Data (Pos) (ClassContext) (NontSet) (([Identifier])) (Attrs) (Alts) (Bool) | Type (Pos) (ClassContext) (NontermIdent) (([Identifier])) (ComplexType) | Attr (Pos) (ClassContext) (NontSet) (([String])) (Attrs) | Sem (Pos) (ClassContext) (NontSet) (Attrs) (([String])) (SemAlts) | Txt (Pos) (BlockKind) ((Maybe NontermIdent)) (([String])) | Set (Pos) (NontermIdent) (Bool) (NontSet) | Deriving (Pos) (NontSet) (([NontermIdent])) | Wrapper (Pos) (NontSet) | Nocatas (Pos) (NontSet) | Pragma (Pos) (([NontermIdent])) | Module (Pos) (String) (String) (String) -- Elems ------------------------------------------------------- {- alternatives: alternative Cons: child hd : Elem child tl : Elems alternative Nil: -} type Elems = [Elem] -- Field ------------------------------------------------------- {- alternatives: alternative FChild: child name : {Identifier} child tp : {Type} alternative FCtx: child tps : {[Type]} -} data Field = FChild (Identifier) (Type) | FCtx (([Type])) -- Fields ------------------------------------------------------ {- alternatives: alternative Cons: child hd : Field child tl : Fields alternative Nil: -} type Fields = [Field] -- NontSet ----------------------------------------------------- {- alternatives: alternative NamedSet: child name : {NontermIdent} alternative All: alternative Union: child set1 : NontSet child set2 : NontSet alternative Intersect: child set1 : NontSet child set2 : NontSet alternative Difference: child set1 : NontSet child set2 : NontSet alternative Path: child from : {NontermIdent} child to : {NontermIdent} -} data NontSet = NamedSet (NontermIdent) | All | Union (NontSet) (NontSet) | Intersect (NontSet) (NontSet) | Difference (NontSet) (NontSet) | Path (NontermIdent) (NontermIdent) -- SemAlt ------------------------------------------------------ {- alternatives: alternative SemAlt: child pos : {Pos} child constructorSet : ConstructorSet child rules : SemDefs -} data SemAlt = SemAlt (Pos) (ConstructorSet) (SemDefs) -- SemAlts ----------------------------------------------------- {- alternatives: alternative Cons: child hd : SemAlt child tl : SemAlts alternative Nil: -} type SemAlts = [SemAlt] -- SemDef ------------------------------------------------------ {- alternatives: alternative Def: child pos : {Pos} child mbName : {Maybe Identifier} child pattern : {Pattern} child rhs : {Expression} child owrt : {Bool} child pure : {Bool} child eager : {Bool} alternative TypeDef: child pos : {Pos} child ident : {Identifier} child tp : {Type} alternative UniqueDef: child ident : {Identifier} child ref : {Identifier} alternative AugmentDef: child ident : {Identifier} child rhs : {Expression} alternative AroundDef: child ident : {Identifier} child rhs : {Expression} alternative MergeDef: child target : {Identifier} child nt : {Identifier} child sources : {[Identifier]} child rhs : {Expression} alternative SemPragma: child names : {[NontermIdent]} alternative AttrOrderBefore: child before : {[Occurrence]} child after : {[Occurrence]} -} data SemDef = Def (Pos) ((Maybe Identifier)) (Pattern) (Expression) (Bool) (Bool) (Bool) | TypeDef (Pos) (Identifier) (Type) | UniqueDef (Identifier) (Identifier) | AugmentDef (Identifier) (Expression) | AroundDef (Identifier) (Expression) | MergeDef (Identifier) (Identifier) (([Identifier])) (Expression) | SemPragma (([NontermIdent])) | AttrOrderBefore (([Occurrence])) (([Occurrence])) -- SemDefs ----------------------------------------------------- {- alternatives: alternative Cons: child hd : SemDef child tl : SemDefs alternative Nil: -} type SemDefs = [SemDef]uuagc-0.9.42.3/src-generated/DeclBlocks.hs000644 000765 000024 00000001526 12127045231 022136 0ustar00jeroenbransenstaff000000 000000 -- UUAGC 0.9.42.3 (src-ag/DeclBlocks.ag) module DeclBlocks where {-# LINE 2 "./src-ag/DeclBlocks.ag" #-} import Code (Decl,Expr) {-# LINE 9 "dist/build/DeclBlocks.hs" #-} -- DeclBlocks -------------------------------------------------- {- alternatives: alternative DeclBlock: child defs : {[Decl]} child visit : {Decl} child next : DeclBlocks alternative DeclTerminator: child defs : {[Decl]} child result : {Expr} -} data DeclBlocks = DeclBlock (([Decl])) (Decl) (DeclBlocks) | DeclTerminator (([Decl])) (Expr) -- DeclBlocksRoot ---------------------------------------------- {- alternatives: alternative DeclBlocksRoot: child blocks : DeclBlocks -} data DeclBlocksRoot = DeclBlocksRoot (DeclBlocks)uuagc-0.9.42.3/src-generated/DefaultRules.hs000644 000765 000024 00001000721 12127045231 022525 0ustar00jeroenbransenstaff000000 000000 {-# LANGUAGE Rank2Types, GADTs #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} module DefaultRules where {-# LINE 2 "./src-ag/AbstractSyntax.ag" #-} -- 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 {-# LINE 17 "dist/build/DefaultRules.hs" #-} {-# LINE 2 "./src-ag/Patterns.ag" #-} -- Patterns.ag imports import UU.Scanner.Position(Pos) import CommonTypes (ConstructorIdent,Identifier) {-# LINE 24 "dist/build/DefaultRules.hs" #-} {-# LINE 15 "./src-ag/DefaultRules.ag" #-} 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 {-# LINE 46 "dist/build/DefaultRules.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 78 "./src-ag/DefaultRules.ag" #-} 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 buildConExpr ocaml typeSyns rename nt con1 fs | nt `elem` map fst typeSyns = if ocaml then synonymMl else synonymHs | otherwise = normalExpr where con = getName con1 tup = " " ++ buildTuple fs args = " " ++ unwords fs normalExpr = 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 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) ] ) {-# LINE 132 "dist/build/DefaultRules.hs" #-} {-# LINE 226 "./src-ag/DefaultRules.ag" #-} 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 nt con fld a = "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 :: Set Identifier -> [(Identifier,Attributes)] -> (Identifier,(String,String,String)) -> Rule useRule 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 noPos e | otherwise = lexTokens 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 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 {-# LINE 285 "dist/build/DefaultRules.hs" #-} {-# LINE 460 "./src-ag/DefaultRules.ag" #-} 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 "_around" and 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: "_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) {-# LINE 354 "dist/build/DefaultRules.hs" #-} {-# LINE 578 "./src-ag/DefaultRules.ag" #-} 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 {-# LINE 365 "dist/build/DefaultRules.hs" #-} {-# LINE 630 "./src-ag/DefaultRules.ag" #-} -- 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 {-# LINE 380 "dist/build/DefaultRules.hs" #-} {-# LINE 647 "./src-ag/DefaultRules.ag" #-} needsMultiRules :: Options -> Bool needsMultiRules opts = (visit opts || withCycle opts) && not (kennedyWarren opts) {-# LINE 386 "dist/build/DefaultRules.hs" #-} {-# LINE 652 "./src-ag/DefaultRules.ag" #-} {- 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) {-# LINE 436 "dist/build/DefaultRules.hs" #-} -- Child ------------------------------------------------------- -- wrapper data Inh_Child = Inh_Child { con_Inh_Child :: !(ConstructorIdent), cr_Inh_Child :: !(Bool), inhMap_Inh_Child :: !(Map Identifier Attributes), merged_Inh_Child :: !(Set Identifier), nt_Inh_Child :: !(NontermIdent), params_Inh_Child :: !([Identifier]), synMap_Inh_Child :: !(Map Identifier Attributes) } data Syn_Child = Syn_Child { errors_Syn_Child :: !(Seq Error), field_Syn_Child :: !( (Identifier,Type,ChildKind) ), inherited_Syn_Child :: !(Attributes), name_Syn_Child :: !(Identifier), output_Syn_Child :: !(Child), synthesized_Syn_Child :: !(Attributes) } {-# INLINABLE wrap_Child #-} wrap_Child :: T_Child -> Inh_Child -> (Syn_Child ) wrap_Child !(T_Child act) !(Inh_Child _lhsIcon _lhsIcr _lhsIinhMap _lhsImerged _lhsInt _lhsIparams _lhsIsynMap) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Child_vIn0 _lhsIcon _lhsIcr _lhsIinhMap _lhsImerged _lhsInt _lhsIparams _lhsIsynMap !(T_Child_vOut0 _lhsOerrors _lhsOfield _lhsOinherited _lhsOname _lhsOoutput _lhsOsynthesized) <- return (inv_Child_s0 sem K_Child_v0 arg) return (Syn_Child _lhsOerrors _lhsOfield _lhsOinherited _lhsOname _lhsOoutput _lhsOsynthesized) ) -- cata {-# INLINE sem_Child #-} sem_Child :: Child -> T_Child sem_Child ( Child !name_ !tp_ !kind_ ) = sem_Child_Child name_ tp_ kind_ -- semantic domain newtype T_Child = T_Child { attach_T_Child :: Identity (T_Child_s0 ) } data T_Child_s0 where C_Child_s0 :: { inv_Child_s0 :: !(forall t. K_Child_s0 t -> t) } -> T_Child_s0 data T_Child_s1 = C_Child_s1 data T_Child_s26 = C_Child_s26 newtype T_Child_s56 = C_Child_s56 { inv_Child_s56 :: (T_Child_v53 ) } data K_Child_s0 k where K_Child_v0 :: K_Child_s0 (T_Child_v0 ) K_Child_v13 :: K_Child_s0 (T_Child_v13 ) K_Child_v52 :: K_Child_s0 (T_Child_v52 ) type T_Child_v0 = (T_Child_vIn0 ) -> (T_Child_vOut0 ) data T_Child_vIn0 = T_Child_vIn0 !(ConstructorIdent) !(Bool) !(Map Identifier Attributes) !(Set Identifier) !(NontermIdent) !([Identifier]) !(Map Identifier Attributes) data T_Child_vOut0 = T_Child_vOut0 !(Seq Error) !( (Identifier,Type,ChildKind) ) !(Attributes) !(Identifier) !(Child) !(Attributes) type T_Child_v13 = (T_Child_vIn13 ) -> (T_Child_vOut13 ) data T_Child_vIn13 = T_Child_vIn13 !(Map Identifier Attributes) !(Set Identifier) !(Map Identifier Attributes) data T_Child_vOut13 = T_Child_vOut13 !(Seq Error) !( (Identifier,Type,ChildKind) ) !(Attributes) !(Identifier) !(Child) !(Attributes) type T_Child_v52 = (T_Child_vIn52 ) -> (T_Child_vOut52 ) data T_Child_vIn52 = T_Child_vIn52 !(Map Identifier Attributes) !(Set Identifier) !(Map Identifier Attributes) data T_Child_vOut52 = T_Child_vOut52 !(Seq Error) !( (Identifier,Type,ChildKind) ) !(Attributes) !(Identifier) !(Attributes) !(T_Child_s56 ) type T_Child_v53 = (T_Child_vIn53 ) -> (T_Child_vOut53 ) data T_Child_vIn53 = T_Child_vIn53 data T_Child_vOut53 = T_Child_vOut53 !(Child) {-# NOINLINE sem_Child_Child #-} sem_Child_Child :: (Identifier) -> (Type) -> (ChildKind) -> T_Child sem_Child_Child !arg_name_ !arg_tp_ !arg_kind_ = T_Child (return st0) where {-# NOINLINE st0 #-} !st0 = let k0 :: K_Child_s0 t -> t k0 K_Child_v0 = v0 k0 K_Child_v13 = v13 k0 K_Child_v52 = v52 v0 :: T_Child_v0 v0 = \ !(T_Child_vIn0 _lhsIcon _lhsIcr _lhsIinhMap _lhsImerged _lhsInt _lhsIparams _lhsIsynMap) -> ( let _lhsOerrors :: Seq Error !_lhsOerrors = rule11 () in let _lhsOfield :: (Identifier,Type,ChildKind) !_lhsOfield = rule6 arg_kind_ arg_name_ arg_tp_ in let !_chnt = rule0 arg_name_ arg_tp_ in let !_inh = rule1 _chnt _lhsIinhMap in let !(!_nt,!_params) = rule7 arg_name_ arg_tp_ in let !_inh1 = rule8 _inh _nt _params in let _lhsOinherited :: Attributes !_lhsOinherited = rule4 _inh1 in let _lhsOname :: Identifier !_lhsOname = rule3 arg_name_ in let _lhsOoutput :: Child !_lhsOoutput = rule10 arg_kind_ arg_name_ arg_tp_ in let !_syn = rule2 _chnt _lhsIsynMap in let !_syn1 = rule9 _nt _params _syn in let _lhsOsynthesized :: Attributes !_lhsOsynthesized = rule5 _lhsImerged _syn1 arg_name_ in let !__result_ = T_Child_vOut0 _lhsOerrors _lhsOfield _lhsOinherited _lhsOname _lhsOoutput _lhsOsynthesized in __result_ ) v13 :: T_Child_v13 v13 = \ !(T_Child_vIn13 _lhsIinhMap _lhsImerged _lhsIsynMap) -> ( let _lhsOerrors :: Seq Error !_lhsOerrors = rule11 () in let _lhsOfield :: (Identifier,Type,ChildKind) !_lhsOfield = rule6 arg_kind_ arg_name_ arg_tp_ in let !_chnt = rule0 arg_name_ arg_tp_ in let !_inh = rule1 _chnt _lhsIinhMap in let !(!_nt,!_params) = rule7 arg_name_ arg_tp_ in let !_inh1 = rule8 _inh _nt _params in let _lhsOinherited :: Attributes !_lhsOinherited = rule4 _inh1 in let _lhsOname :: Identifier !_lhsOname = rule3 arg_name_ in let _lhsOoutput :: Child !_lhsOoutput = rule10 arg_kind_ arg_name_ arg_tp_ in let !_syn = rule2 _chnt _lhsIsynMap in let !_syn1 = rule9 _nt _params _syn in let _lhsOsynthesized :: Attributes !_lhsOsynthesized = rule5 _lhsImerged _syn1 arg_name_ in let !__result_ = T_Child_vOut13 _lhsOerrors _lhsOfield _lhsOinherited _lhsOname _lhsOoutput _lhsOsynthesized in __result_ ) v52 :: T_Child_v52 v52 = \ !(T_Child_vIn52 _lhsIinhMap _lhsImerged _lhsIsynMap) -> ( let _lhsOerrors :: Seq Error !_lhsOerrors = rule11 () in let _lhsOfield :: (Identifier,Type,ChildKind) !_lhsOfield = rule6 arg_kind_ arg_name_ arg_tp_ in let !_chnt = rule0 arg_name_ arg_tp_ in let !_inh = rule1 _chnt _lhsIinhMap in let !(!_nt,!_params) = rule7 arg_name_ arg_tp_ in let !_inh1 = rule8 _inh _nt _params in let _lhsOinherited :: Attributes !_lhsOinherited = rule4 _inh1 in let _lhsOname :: Identifier !_lhsOname = rule3 arg_name_ in let !_syn = rule2 _chnt _lhsIsynMap in let !_syn1 = rule9 _nt _params _syn in let _lhsOsynthesized :: Attributes !_lhsOsynthesized = rule5 _lhsImerged _syn1 arg_name_ in let !__st_ = st56 () !__result_ = T_Child_vOut52 _lhsOerrors _lhsOfield _lhsOinherited _lhsOname _lhsOsynthesized __st_ in __result_ ) in C_Child_s0 k0 {-# NOINLINE st56 #-} st56 = \ (_ :: ()) -> let v53 :: T_Child_v53 v53 = \ !(T_Child_vIn53 ) -> ( let _lhsOoutput :: Child !_lhsOoutput = rule10 arg_kind_ arg_name_ arg_tp_ in let !__result_ = T_Child_vOut53 _lhsOoutput in __result_ ) in C_Child_s56 v53 {-# NOINLINE[1] rule0 #-} {-# LINE 19 "./src-ag/DistChildAttr.ag" #-} rule0 = \ !name_ !tp_ -> {-# LINE 19 "./src-ag/DistChildAttr.ag" #-} case tp_ of NT nt _ _ -> nt Self -> error ("The type of child " ++ show name_ ++ " should not be a Self type.") Haskell t -> identifier "" {-# LINE 576 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule1 #-} {-# LINE 23 "./src-ag/DistChildAttr.ag" #-} rule1 = \ !_chnt ((!_lhsIinhMap) :: Map Identifier Attributes) -> {-# LINE 23 "./src-ag/DistChildAttr.ag" #-} Map.findWithDefault Map.empty _chnt _lhsIinhMap {-# LINE 582 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule2 #-} {-# LINE 24 "./src-ag/DistChildAttr.ag" #-} rule2 = \ !_chnt ((!_lhsIsynMap) :: Map Identifier Attributes) -> {-# LINE 24 "./src-ag/DistChildAttr.ag" #-} Map.findWithDefault Map.empty _chnt _lhsIsynMap {-# LINE 588 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule3 #-} {-# LINE 200 "./src-ag/DefaultRules.ag" #-} rule3 = \ !name_ -> {-# LINE 200 "./src-ag/DefaultRules.ag" #-} name_ {-# LINE 594 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule4 #-} {-# LINE 209 "./src-ag/DefaultRules.ag" #-} rule4 = \ !_inh1 -> {-# LINE 209 "./src-ag/DefaultRules.ag" #-} _inh1 {-# LINE 600 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule5 #-} {-# LINE 210 "./src-ag/DefaultRules.ag" #-} rule5 = \ ((!_lhsImerged) :: Set Identifier) !_syn1 !name_ -> {-# LINE 210 "./src-ag/DefaultRules.ag" #-} if name_ `Set.member` _lhsImerged then Map.empty else _syn1 {-# LINE 608 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule6 #-} {-# LINE 546 "./src-ag/DefaultRules.ag" #-} rule6 = \ !kind_ !name_ !tp_ -> {-# LINE 546 "./src-ag/DefaultRules.ag" #-} (name_,tp_,kind_) {-# LINE 614 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule7 #-} {-# LINE 568 "./src-ag/DefaultRules.ag" #-} rule7 = \ !name_ !tp_ -> {-# LINE 568 "./src-ag/DefaultRules.ag" #-} 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, []) {-# LINE 623 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule8 #-} {-# LINE 572 "./src-ag/DefaultRules.ag" #-} rule8 = \ !_inh !_nt !_params -> {-# LINE 572 "./src-ag/DefaultRules.ag" #-} Map.map (elimSelfStr _nt _params ) _inh {-# LINE 629 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule9 #-} {-# LINE 573 "./src-ag/DefaultRules.ag" #-} rule9 = \ !_nt !_params !_syn -> {-# LINE 573 "./src-ag/DefaultRules.ag" #-} Map.map (elimSelfStr _nt _params ) _syn {-# LINE 635 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule10 #-} {-# LINE 614 "./src-ag/DefaultRules.ag" #-} rule10 = \ !kind_ !name_ !tp_ -> {-# LINE 614 "./src-ag/DefaultRules.ag" #-} Child name_ tp_ kind_ {-# LINE 641 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule11 #-} rule11 = \ (_ :: ()) -> Seq.empty -- Children ---------------------------------------------------- -- wrapper data Inh_Children = Inh_Children { con_Inh_Children :: !(ConstructorIdent), cr_Inh_Children :: !(Bool), inhMap_Inh_Children :: !(Map Identifier Attributes), merged_Inh_Children :: !(Set Identifier), nt_Inh_Children :: !(NontermIdent), params_Inh_Children :: !([Identifier]), synMap_Inh_Children :: !(Map Identifier Attributes) } data Syn_Children = Syn_Children { errors_Syn_Children :: !(Seq Error), fields_Syn_Children :: !([(Identifier,Type,ChildKind)]), inputs_Syn_Children :: !([(Identifier, Attributes)]), output_Syn_Children :: !(Children), outputs_Syn_Children :: !([(Identifier, Attributes)]) } {-# INLINABLE wrap_Children #-} wrap_Children :: T_Children -> Inh_Children -> (Syn_Children ) wrap_Children !(T_Children act) !(Inh_Children _lhsIcon _lhsIcr _lhsIinhMap _lhsImerged _lhsInt _lhsIparams _lhsIsynMap) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Children_vIn1 _lhsIcon _lhsIcr _lhsIinhMap _lhsImerged _lhsInt _lhsIparams _lhsIsynMap !(T_Children_vOut1 _lhsOerrors _lhsOfields _lhsOinputs _lhsOoutput _lhsOoutputs) <- return (inv_Children_s2 sem K_Children_v1 arg) return (Syn_Children _lhsOerrors _lhsOfields _lhsOinputs _lhsOoutput _lhsOoutputs) ) -- cata {-# NOINLINE sem_Children #-} sem_Children :: Children -> T_Children sem_Children list = Prelude.foldr sem_Children_Cons sem_Children_Nil (Prelude.map sem_Child list) -- semantic domain newtype T_Children = T_Children { attach_T_Children :: Identity (T_Children_s2 ) } data T_Children_s2 where C_Children_s2 :: { inv_Children_s2 :: !(forall t. K_Children_s2 t -> t) } -> T_Children_s2 data T_Children_s3 = C_Children_s3 data T_Children_s27 = C_Children_s27 newtype T_Children_s53 = C_Children_s53 { inv_Children_s53 :: (T_Children_v48 ) } data K_Children_s2 k where K_Children_v1 :: K_Children_s2 (T_Children_v1 ) K_Children_v14 :: K_Children_s2 (T_Children_v14 ) K_Children_v47 :: K_Children_s2 (T_Children_v47 ) type T_Children_v1 = (T_Children_vIn1 ) -> (T_Children_vOut1 ) data T_Children_vIn1 = T_Children_vIn1 !(ConstructorIdent) !(Bool) !(Map Identifier Attributes) !(Set Identifier) !(NontermIdent) !([Identifier]) !(Map Identifier Attributes) data T_Children_vOut1 = T_Children_vOut1 !(Seq Error) !([(Identifier,Type,ChildKind)]) !([(Identifier, Attributes)]) !(Children) !([(Identifier, Attributes)]) type T_Children_v14 = (T_Children_vIn14 ) -> (T_Children_vOut14 ) data T_Children_vIn14 = T_Children_vIn14 !(Map Identifier Attributes) !(Set Identifier) !(Map Identifier Attributes) data T_Children_vOut14 = T_Children_vOut14 !(Seq Error) !([(Identifier,Type,ChildKind)]) !([(Identifier, Attributes)]) !(Children) !([(Identifier, Attributes)]) type T_Children_v47 = (T_Children_vIn47 ) -> (T_Children_vOut47 ) data T_Children_vIn47 = T_Children_vIn47 !(Map Identifier Attributes) !(Set Identifier) !(Map Identifier Attributes) data T_Children_vOut47 = T_Children_vOut47 !(Seq Error) !([(Identifier,Type,ChildKind)]) !([(Identifier, Attributes)]) !([(Identifier, Attributes)]) !(T_Children_s53 ) type T_Children_v48 = (T_Children_vIn48 ) -> (T_Children_vOut48 ) data T_Children_vIn48 = T_Children_vIn48 data T_Children_vOut48 = T_Children_vOut48 !(Children) {-# NOINLINE sem_Children_Cons #-} sem_Children_Cons :: T_Child -> T_Children -> T_Children sem_Children_Cons arg_hd_ arg_tl_ = T_Children (return st2) where {-# NOINLINE st2 #-} !st2 = let k2 :: K_Children_s2 t -> t k2 K_Children_v1 = v1 k2 K_Children_v14 = v14 k2 K_Children_v47 = v47 v1 :: T_Children_v1 v1 = \ !(T_Children_vIn1 _lhsIcon _lhsIcr _lhsIinhMap _lhsImerged _lhsInt _lhsIparams _lhsIsynMap) -> ( let !_hdX0 = Control.Monad.Identity.runIdentity (attach_T_Child (arg_hd_)) in let !_tlX2 = Control.Monad.Identity.runIdentity (attach_T_Children (arg_tl_)) in let !_hdOinhMap = rule21 _lhsIinhMap in let !_tlOinhMap = rule28 _lhsIinhMap in let !_hdOmerged = rule22 _lhsImerged in let !_hdOsynMap = rule25 _lhsIsynMap in let !_tlOmerged = rule29 _lhsImerged in let !_tlOsynMap = rule32 _lhsIsynMap in let !(T_Child_vOut13 _hdIerrors _hdIfield _hdIinherited _hdIname _hdIoutput _hdIsynthesized) = inv_Child_s0 _hdX0 K_Child_v13 (T_Child_vIn13 _hdOinhMap _hdOmerged _hdOsynMap) in let !(T_Children_vOut14 _tlIerrors _tlIfields _tlIinputs _tlIoutput _tlIoutputs) = inv_Children_s2 _tlX2 K_Children_v14 (T_Children_vIn14 _tlOinhMap _tlOmerged _tlOsynMap) in let _lhsOerrors :: Seq Error !_lhsOerrors = rule16 _hdIerrors _tlIerrors in let _lhsOfields :: [(Identifier,Type,ChildKind)] !_lhsOfields = rule15 _hdIfield _tlIfields in let _lhsOinputs :: [(Identifier, Attributes)] !_lhsOinputs = rule13 _hdIinherited _hdIname _tlIinputs in let !_output = rule17 _hdIoutput _tlIoutput in let _lhsOoutput :: Children !_lhsOoutput = rule18 _output in let _lhsOoutputs :: [(Identifier, Attributes)] !_lhsOoutputs = rule14 _hdIname _hdIsynthesized _tlIoutputs in let !__result_ = T_Children_vOut1 _lhsOerrors _lhsOfields _lhsOinputs _lhsOoutput _lhsOoutputs in __result_ ) v14 :: T_Children_v14 v14 = \ !(T_Children_vIn14 _lhsIinhMap _lhsImerged _lhsIsynMap) -> ( let !_hdX0 = Control.Monad.Identity.runIdentity (attach_T_Child (arg_hd_)) in let !_tlX2 = Control.Monad.Identity.runIdentity (attach_T_Children (arg_tl_)) in let !_hdOinhMap = rule21 _lhsIinhMap in let !_tlOinhMap = rule28 _lhsIinhMap in let !_hdOmerged = rule22 _lhsImerged in let !_hdOsynMap = rule25 _lhsIsynMap in let !_tlOmerged = rule29 _lhsImerged in let !_tlOsynMap = rule32 _lhsIsynMap in let !(T_Child_vOut13 _hdIerrors _hdIfield _hdIinherited _hdIname _hdIoutput _hdIsynthesized) = inv_Child_s0 _hdX0 K_Child_v13 (T_Child_vIn13 _hdOinhMap _hdOmerged _hdOsynMap) in let !(T_Children_vOut14 _tlIerrors _tlIfields _tlIinputs _tlIoutput _tlIoutputs) = inv_Children_s2 _tlX2 K_Children_v14 (T_Children_vIn14 _tlOinhMap _tlOmerged _tlOsynMap) in let _lhsOerrors :: Seq Error !_lhsOerrors = rule16 _hdIerrors _tlIerrors in let _lhsOfields :: [(Identifier,Type,ChildKind)] !_lhsOfields = rule15 _hdIfield _tlIfields in let _lhsOinputs :: [(Identifier, Attributes)] !_lhsOinputs = rule13 _hdIinherited _hdIname _tlIinputs in let !_output = rule17 _hdIoutput _tlIoutput in let _lhsOoutput :: Children !_lhsOoutput = rule18 _output in let _lhsOoutputs :: [(Identifier, Attributes)] !_lhsOoutputs = rule14 _hdIname _hdIsynthesized _tlIoutputs in let !__result_ = T_Children_vOut14 _lhsOerrors _lhsOfields _lhsOinputs _lhsOoutput _lhsOoutputs in __result_ ) v47 :: T_Children_v47 v47 = \ !(T_Children_vIn47 _lhsIinhMap _lhsImerged _lhsIsynMap) -> ( let !_hdX0 = Control.Monad.Identity.runIdentity (attach_T_Child (arg_hd_)) in let !_tlX2 = Control.Monad.Identity.runIdentity (attach_T_Children (arg_tl_)) in let !_hdOinhMap = rule21 _lhsIinhMap in let !_tlOinhMap = rule28 _lhsIinhMap in let !_hdOmerged = rule22 _lhsImerged in let !_hdOsynMap = rule25 _lhsIsynMap in let !_tlOmerged = rule29 _lhsImerged in let !_tlOsynMap = rule32 _lhsIsynMap in let !(T_Child_vOut52 _hdIerrors _hdIfield _hdIinherited _hdIname _hdIsynthesized _hdX56) = inv_Child_s0 _hdX0 K_Child_v52 (T_Child_vIn52 _hdOinhMap _hdOmerged _hdOsynMap) in let !(T_Children_vOut47 _tlIerrors _tlIfields _tlIinputs _tlIoutputs _tlX53) = inv_Children_s2 _tlX2 K_Children_v47 (T_Children_vIn47 _tlOinhMap _tlOmerged _tlOsynMap) in let _lhsOerrors :: Seq Error !_lhsOerrors = rule16 _hdIerrors _tlIerrors in let _lhsOfields :: [(Identifier,Type,ChildKind)] !_lhsOfields = rule15 _hdIfield _tlIfields in let _lhsOinputs :: [(Identifier, Attributes)] !_lhsOinputs = rule13 _hdIinherited _hdIname _tlIinputs in let _lhsOoutputs :: [(Identifier, Attributes)] !_lhsOoutputs = rule14 _hdIname _hdIsynthesized _tlIoutputs in let !__st_ = st53 _hdX56 _tlX53 !__result_ = T_Children_vOut47 _lhsOerrors _lhsOfields _lhsOinputs _lhsOoutputs __st_ in __result_ ) in C_Children_s2 k2 {-# NOINLINE st53 #-} st53 = \ !_hdX56 !_tlX53 -> let v48 :: T_Children_v48 v48 = \ !(T_Children_vIn48 ) -> ( let !(T_Child_vOut53 _hdIoutput) = inv_Child_s56 _hdX56 (T_Child_vIn53 ) in let !(T_Children_vOut48 _tlIoutput) = inv_Children_s53 _tlX53 (T_Children_vIn48 ) in let !_output = rule17 _hdIoutput _tlIoutput in let _lhsOoutput :: Children !_lhsOoutput = rule18 _output in let !__result_ = T_Children_vOut48 _lhsOoutput in __result_ ) in C_Children_s53 v48 {-# NOINLINE[1] rule13 #-} {-# LINE 215 "./src-ag/DefaultRules.ag" #-} rule13 = \ ((!_hdIinherited) :: Attributes) ((!_hdIname) :: Identifier) ((!_tlIinputs) :: [(Identifier, Attributes)]) -> {-# LINE 215 "./src-ag/DefaultRules.ag" #-} (_hdIname, _hdIinherited) : _tlIinputs {-# LINE 793 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule14 #-} {-# LINE 216 "./src-ag/DefaultRules.ag" #-} rule14 = \ ((!_hdIname) :: Identifier) ((!_hdIsynthesized) :: Attributes) ((!_tlIoutputs) :: [(Identifier, Attributes)]) -> {-# LINE 216 "./src-ag/DefaultRules.ag" #-} (_hdIname, _hdIsynthesized) : _tlIoutputs {-# LINE 799 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule15 #-} {-# LINE 542 "./src-ag/DefaultRules.ag" #-} rule15 = \ ((!_hdIfield) :: (Identifier,Type,ChildKind) ) ((!_tlIfields) :: [(Identifier,Type,ChildKind)]) -> {-# LINE 542 "./src-ag/DefaultRules.ag" #-} _hdIfield : _tlIfields {-# LINE 805 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule16 #-} rule16 = \ ((!_hdIerrors) :: Seq Error) ((!_tlIerrors) :: Seq Error) -> _hdIerrors Seq.>< _tlIerrors {-# NOINLINE[1] rule17 #-} rule17 = \ ((!_hdIoutput) :: Child) ((!_tlIoutput) :: Children) -> (:) _hdIoutput _tlIoutput {-# NOINLINE[1] rule18 #-} rule18 = \ !_output -> _output {-# NOINLINE[1] rule21 #-} rule21 = \ ((!_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# NOINLINE[1] rule22 #-} rule22 = \ ((!_lhsImerged) :: Set Identifier) -> _lhsImerged {-# NOINLINE[1] rule25 #-} rule25 = \ ((!_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# NOINLINE[1] rule28 #-} rule28 = \ ((!_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# NOINLINE[1] rule29 #-} rule29 = \ ((!_lhsImerged) :: Set Identifier) -> _lhsImerged {-# NOINLINE[1] rule32 #-} rule32 = \ ((!_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# NOINLINE sem_Children_Nil #-} sem_Children_Nil :: T_Children sem_Children_Nil = T_Children (return st2) where {-# NOINLINE st2 #-} !st2 = let k2 :: K_Children_s2 t -> t k2 K_Children_v1 = v1 k2 K_Children_v14 = v14 k2 K_Children_v47 = v47 v1 :: T_Children_v1 v1 = \ !(T_Children_vIn1 _lhsIcon _lhsIcr _lhsIinhMap _lhsImerged _lhsInt _lhsIparams _lhsIsynMap) -> ( let _lhsOerrors :: Seq Error !_lhsOerrors = rule36 () in let _lhsOfields :: [(Identifier,Type,ChildKind)] !_lhsOfields = rule35 () in let _lhsOinputs :: [(Identifier, Attributes)] !_lhsOinputs = rule33 () in let !_output = rule37 () in let _lhsOoutputs :: [(Identifier, Attributes)] !_lhsOoutputs = rule34 () in let _lhsOoutput :: Children !_lhsOoutput = rule38 _output in let !__result_ = T_Children_vOut1 _lhsOerrors _lhsOfields _lhsOinputs _lhsOoutput _lhsOoutputs in __result_ ) v14 :: T_Children_v14 v14 = \ !(T_Children_vIn14 _lhsIinhMap _lhsImerged _lhsIsynMap) -> ( let _lhsOerrors :: Seq Error !_lhsOerrors = rule36 () in let _lhsOfields :: [(Identifier,Type,ChildKind)] !_lhsOfields = rule35 () in let _lhsOinputs :: [(Identifier, Attributes)] !_lhsOinputs = rule33 () in let !_output = rule37 () in let _lhsOoutputs :: [(Identifier, Attributes)] !_lhsOoutputs = rule34 () in let _lhsOoutput :: Children !_lhsOoutput = rule38 _output in let !__result_ = T_Children_vOut14 _lhsOerrors _lhsOfields _lhsOinputs _lhsOoutput _lhsOoutputs in __result_ ) v47 :: T_Children_v47 v47 = \ !(T_Children_vIn47 _lhsIinhMap _lhsImerged _lhsIsynMap) -> ( let _lhsOerrors :: Seq Error !_lhsOerrors = rule36 () in let _lhsOfields :: [(Identifier,Type,ChildKind)] !_lhsOfields = rule35 () in let _lhsOinputs :: [(Identifier, Attributes)] !_lhsOinputs = rule33 () in let _lhsOoutputs :: [(Identifier, Attributes)] !_lhsOoutputs = rule34 () in let !__st_ = st53 () !__result_ = T_Children_vOut47 _lhsOerrors _lhsOfields _lhsOinputs _lhsOoutputs __st_ in __result_ ) in C_Children_s2 k2 {-# NOINLINE st53 #-} st53 = \ (_ :: ()) -> let v48 :: T_Children_v48 v48 = \ !(T_Children_vIn48 ) -> ( let !_output = rule37 () in let _lhsOoutput :: Children !_lhsOoutput = rule38 _output in let !__result_ = T_Children_vOut48 _lhsOoutput in __result_ ) in C_Children_s53 v48 {-# NOINLINE[1] rule33 #-} {-# LINE 217 "./src-ag/DefaultRules.ag" #-} rule33 = \ (_ :: ()) -> {-# LINE 217 "./src-ag/DefaultRules.ag" #-} [] {-# LINE 901 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule34 #-} {-# LINE 218 "./src-ag/DefaultRules.ag" #-} rule34 = \ (_ :: ()) -> {-# LINE 218 "./src-ag/DefaultRules.ag" #-} [] {-# LINE 907 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule35 #-} {-# LINE 543 "./src-ag/DefaultRules.ag" #-} rule35 = \ (_ :: ()) -> {-# LINE 543 "./src-ag/DefaultRules.ag" #-} [] {-# LINE 913 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule36 #-} rule36 = \ (_ :: ()) -> Seq.empty {-# NOINLINE[1] rule37 #-} rule37 = \ (_ :: ()) -> [] {-# NOINLINE[1] rule38 #-} rule38 = \ !_output -> _output -- Grammar ----------------------------------------------------- -- wrapper data Inh_Grammar = Inh_Grammar { options_Inh_Grammar :: !(Options) } data Syn_Grammar = Syn_Grammar { errors_Syn_Grammar :: !(Seq Error), output_Syn_Grammar :: !(Grammar) } {-# INLINABLE wrap_Grammar #-} wrap_Grammar :: T_Grammar -> Inh_Grammar -> (Syn_Grammar ) wrap_Grammar !(T_Grammar act) !(Inh_Grammar _lhsIoptions) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Grammar_vIn2 _lhsIoptions !(T_Grammar_vOut2 _lhsOerrors _lhsOoutput) <- return (inv_Grammar_s4 sem arg) return (Syn_Grammar _lhsOerrors _lhsOoutput) ) -- cata {-# INLINE sem_Grammar #-} sem_Grammar :: Grammar -> T_Grammar sem_Grammar ( Grammar !typeSyns_ !useMap_ !derivings_ !wrappers_ nonts_ !pragmas_ !manualAttrOrderMap_ !paramMap_ !contextMap_ !quantMap_ !uniqueMap_ !augmentsMap_ !aroundsMap_ !mergeMap_ ) = sem_Grammar_Grammar typeSyns_ useMap_ derivings_ wrappers_ ( sem_Nonterminals nonts_ ) pragmas_ manualAttrOrderMap_ paramMap_ contextMap_ quantMap_ uniqueMap_ augmentsMap_ aroundsMap_ mergeMap_ -- semantic domain newtype T_Grammar = T_Grammar { attach_T_Grammar :: Identity (T_Grammar_s4 ) } newtype T_Grammar_s4 = C_Grammar_s4 { inv_Grammar_s4 :: (T_Grammar_v2 ) } data T_Grammar_s5 = C_Grammar_s5 type T_Grammar_v2 = (T_Grammar_vIn2 ) -> (T_Grammar_vOut2 ) data T_Grammar_vIn2 = T_Grammar_vIn2 !(Options) data T_Grammar_vOut2 = T_Grammar_vOut2 !(Seq Error) !(Grammar) {-# NOINLINE sem_Grammar_Grammar #-} sem_Grammar_Grammar :: (TypeSyns) -> (UseMap) -> (Derivings) -> (Set NontermIdent) -> T_Nonterminals -> (PragmaMap) -> (AttrOrderMap) -> (ParamMap) -> (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)))) -> T_Grammar sem_Grammar_Grammar !arg_typeSyns_ !arg_useMap_ !arg_derivings_ !arg_wrappers_ arg_nonts_ !arg_pragmas_ !arg_manualAttrOrderMap_ !arg_paramMap_ !arg_contextMap_ !arg_quantMap_ !arg_uniqueMap_ !arg_augmentsMap_ !arg_aroundsMap_ !arg_mergeMap_ = T_Grammar (return st4) where {-# NOINLINE st4 #-} !st4 = let v2 :: T_Grammar_v2 v2 = \ !(T_Grammar_vIn2 _lhsIoptions) -> ( let !_nontsX8 = Control.Monad.Identity.runIdentity (attach_T_Nonterminals (arg_nonts_)) in let !_nontsOuniq = rule47 () in let !_nontsOcr = rule42 _lhsIoptions in let !_nontsOmanualAttrOrderMap = rule48 arg_manualAttrOrderMap_ in let !_nontsOmergesIn = rule51 arg_mergeMap_ in let !_nontsOo_rename = rule41 _lhsIoptions in let !_nontsOoptions = rule55 _lhsIoptions in let !_nontsOtypeSyns = rule46 arg_typeSyns_ in let !_nontsOuseMap = rule45 arg_useMap_ in let !_nontsOwrappers = rule43 arg_wrappers_ in let !_nontsOaroundsIn = rule50 arg_aroundsMap_ in let !_nontsOaugmentsIn = rule49 arg_augmentsMap_ in let !(T_Nonterminals_vOut15 _nontsIinhMap' _nontsIsynMap' _nontsX28) = inv_Nonterminals_s8 _nontsX8 K_Nonterminals_v15 (T_Nonterminals_vIn15 ) in let !_nontsOinhMap = rule39 _nontsIinhMap' in let !_nontsOsynMap = rule40 _nontsIsynMap' in let !(T_Nonterminals_vOut16 _nontsIerrors _nontsIoutput _nontsIuniq) = inv_Nonterminals_s28 _nontsX28 K_Nonterminals_v16 (T_Nonterminals_vIn16 _nontsOaroundsIn _nontsOaugmentsIn _nontsOcr _nontsOinhMap _nontsOmanualAttrOrderMap _nontsOmergesIn _nontsOo_rename _nontsOoptions _nontsOsynMap _nontsOtypeSyns _nontsOuniq _nontsOuseMap _nontsOwrappers) in let _lhsOerrors :: Seq Error !_lhsOerrors = rule52 _nontsIerrors in let !_output = rule53 _nontsIoutput arg_aroundsMap_ arg_augmentsMap_ arg_contextMap_ arg_derivings_ arg_manualAttrOrderMap_ arg_mergeMap_ arg_paramMap_ arg_pragmas_ arg_quantMap_ arg_typeSyns_ arg_uniqueMap_ arg_useMap_ arg_wrappers_ in let _lhsOoutput :: Grammar !_lhsOoutput = rule54 _output in let !__result_ = T_Grammar_vOut2 _lhsOerrors _lhsOoutput in __result_ ) in C_Grammar_s4 v2 {-# INLINE rule39 #-} {-# LINE 15 "./src-ag/DistChildAttr.ag" #-} rule39 = \ ((!_nontsIinhMap') :: Map Identifier Attributes) -> {-# LINE 15 "./src-ag/DistChildAttr.ag" #-} _nontsIinhMap' {-# LINE 990 "dist/build/DefaultRules.hs"#-} {-# INLINE rule40 #-} {-# LINE 16 "./src-ag/DistChildAttr.ag" #-} rule40 = \ ((!_nontsIsynMap') :: Map Identifier Attributes) -> {-# LINE 16 "./src-ag/DistChildAttr.ag" #-} _nontsIsynMap' {-# LINE 996 "dist/build/DefaultRules.hs"#-} {-# INLINE rule41 #-} {-# LINE 58 "./src-ag/DefaultRules.ag" #-} rule41 = \ ((!_lhsIoptions) :: Options) -> {-# LINE 58 "./src-ag/DefaultRules.ag" #-} rename _lhsIoptions {-# LINE 1002 "dist/build/DefaultRules.hs"#-} {-# INLINE rule42 #-} {-# LINE 59 "./src-ag/DefaultRules.ag" #-} rule42 = \ ((!_lhsIoptions) :: Options) -> {-# LINE 59 "./src-ag/DefaultRules.ag" #-} modcopy _lhsIoptions {-# LINE 1008 "dist/build/DefaultRules.hs"#-} {-# INLINE rule43 #-} {-# LINE 67 "./src-ag/DefaultRules.ag" #-} rule43 = \ !wrappers_ -> {-# LINE 67 "./src-ag/DefaultRules.ag" #-} wrappers_ {-# LINE 1014 "dist/build/DefaultRules.hs"#-} {-# INLINE rule45 #-} {-# LINE 202 "./src-ag/DefaultRules.ag" #-} rule45 = \ !useMap_ -> {-# LINE 202 "./src-ag/DefaultRules.ag" #-} useMap_ {-# LINE 1020 "dist/build/DefaultRules.hs"#-} {-# INLINE rule46 #-} {-# LINE 204 "./src-ag/DefaultRules.ag" #-} rule46 = \ !typeSyns_ -> {-# LINE 204 "./src-ag/DefaultRules.ag" #-} typeSyns_ {-# LINE 1026 "dist/build/DefaultRules.hs"#-} {-# INLINE rule47 #-} {-# LINE 595 "./src-ag/DefaultRules.ag" #-} rule47 = \ (_ :: ()) -> {-# LINE 595 "./src-ag/DefaultRules.ag" #-} 1 {-# LINE 1032 "dist/build/DefaultRules.hs"#-} {-# INLINE rule48 #-} {-# LINE 709 "./src-ag/DefaultRules.ag" #-} rule48 = \ !manualAttrOrderMap_ -> {-# LINE 709 "./src-ag/DefaultRules.ag" #-} manualAttrOrderMap_ {-# LINE 1038 "dist/build/DefaultRules.hs"#-} {-# INLINE rule49 #-} {-# LINE 775 "./src-ag/DefaultRules.ag" #-} rule49 = \ !augmentsMap_ -> {-# LINE 775 "./src-ag/DefaultRules.ag" #-} augmentsMap_ {-# LINE 1044 "dist/build/DefaultRules.hs"#-} {-# INLINE rule50 #-} {-# LINE 782 "./src-ag/DefaultRules.ag" #-} rule50 = \ !aroundsMap_ -> {-# LINE 782 "./src-ag/DefaultRules.ag" #-} aroundsMap_ {-# LINE 1050 "dist/build/DefaultRules.hs"#-} {-# INLINE rule51 #-} {-# LINE 790 "./src-ag/DefaultRules.ag" #-} rule51 = \ !mergeMap_ -> {-# LINE 790 "./src-ag/DefaultRules.ag" #-} mergeMap_ {-# LINE 1056 "dist/build/DefaultRules.hs"#-} {-# INLINE rule52 #-} rule52 = \ ((!_nontsIerrors) :: Seq Error) -> _nontsIerrors {-# INLINE rule53 #-} rule53 = \ ((!_nontsIoutput) :: Nonterminals) !aroundsMap_ !augmentsMap_ !contextMap_ !derivings_ !manualAttrOrderMap_ !mergeMap_ !paramMap_ !pragmas_ !quantMap_ !typeSyns_ !uniqueMap_ !useMap_ !wrappers_ -> Grammar typeSyns_ useMap_ derivings_ wrappers_ _nontsIoutput pragmas_ manualAttrOrderMap_ paramMap_ contextMap_ quantMap_ uniqueMap_ augmentsMap_ aroundsMap_ mergeMap_ {-# INLINE rule54 #-} rule54 = \ !_output -> _output {-# INLINE rule55 #-} rule55 = \ ((!_lhsIoptions) :: Options) -> _lhsIoptions -- Nonterminal ------------------------------------------------- -- wrapper data Inh_Nonterminal = Inh_Nonterminal { aroundsIn_Inh_Nonterminal :: !(Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))), augmentsIn_Inh_Nonterminal :: !(Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))), cr_Inh_Nonterminal :: !(Bool), inhMap_Inh_Nonterminal :: !(Map Identifier Attributes), manualAttrOrderMap_Inh_Nonterminal :: !(AttrOrderMap), mergesIn_Inh_Nonterminal :: !(Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression)))), nonterminals_Inh_Nonterminal :: !(Set NontermIdent), o_rename_Inh_Nonterminal :: !(Bool), options_Inh_Nonterminal :: !(Options), synMap_Inh_Nonterminal :: !(Map Identifier Attributes), typeSyns_Inh_Nonterminal :: !(TypeSyns), uniq_Inh_Nonterminal :: !(Int), useMap_Inh_Nonterminal :: !(UseMap), wrappers_Inh_Nonterminal :: !(Set NontermIdent) } data Syn_Nonterminal = Syn_Nonterminal { collect_nts_Syn_Nonterminal :: !(Set NontermIdent), errors_Syn_Nonterminal :: !(Seq Error), inhMap'_Syn_Nonterminal :: !(Map Identifier Attributes), output_Syn_Nonterminal :: !(Nonterminal), synMap'_Syn_Nonterminal :: !(Map Identifier Attributes), uniq_Syn_Nonterminal :: !(Int) } {-# INLINABLE wrap_Nonterminal #-} wrap_Nonterminal :: T_Nonterminal -> Inh_Nonterminal -> (Syn_Nonterminal ) wrap_Nonterminal !(T_Nonterminal act) !(Inh_Nonterminal _lhsIaroundsIn _lhsIaugmentsIn _lhsIcr _lhsIinhMap _lhsImanualAttrOrderMap _lhsImergesIn _lhsInonterminals _lhsIo_rename _lhsIoptions _lhsIsynMap _lhsItypeSyns _lhsIuniq _lhsIuseMap _lhsIwrappers) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Nonterminal_vIn3 _lhsIaroundsIn _lhsIaugmentsIn _lhsIcr _lhsIinhMap _lhsImanualAttrOrderMap _lhsImergesIn _lhsInonterminals _lhsIo_rename _lhsIoptions _lhsIsynMap _lhsItypeSyns _lhsIuniq _lhsIuseMap _lhsIwrappers !(T_Nonterminal_vOut3 _lhsOcollect_nts _lhsOerrors _lhsOinhMap' _lhsOoutput _lhsOsynMap' _lhsOuniq) <- return (inv_Nonterminal_s6 sem K_Nonterminal_v3 arg) return (Syn_Nonterminal _lhsOcollect_nts _lhsOerrors _lhsOinhMap' _lhsOoutput _lhsOsynMap' _lhsOuniq) ) -- cata {-# INLINE sem_Nonterminal #-} sem_Nonterminal :: Nonterminal -> T_Nonterminal sem_Nonterminal ( Nonterminal !nt_ !params_ !inh_ !syn_ prods_ ) = sem_Nonterminal_Nonterminal nt_ params_ inh_ syn_ ( sem_Productions prods_ ) -- semantic domain newtype T_Nonterminal = T_Nonterminal { attach_T_Nonterminal :: Identity (T_Nonterminal_s6 ) } data T_Nonterminal_s6 where C_Nonterminal_s6 :: { inv_Nonterminal_s6 :: !(forall t. K_Nonterminal_s6 t -> t) } -> T_Nonterminal_s6 data T_Nonterminal_s7 = C_Nonterminal_s7 data T_Nonterminal_s31 = C_Nonterminal_s31 data T_Nonterminal_s43 where C_Nonterminal_s43 :: { inv_Nonterminal_s43 :: !(forall t. K_Nonterminal_s43 t -> t) } -> T_Nonterminal_s43 data T_Nonterminal_s44 = C_Nonterminal_s44 newtype T_Nonterminal_s46 = C_Nonterminal_s46 { inv_Nonterminal_s46 :: (T_Nonterminal_v37 ) } newtype T_Nonterminal_s52 = C_Nonterminal_s52 { inv_Nonterminal_s52 :: (T_Nonterminal_v46 ) } data K_Nonterminal_s6 k where K_Nonterminal_v3 :: K_Nonterminal_s6 (T_Nonterminal_v3 ) K_Nonterminal_v18 :: K_Nonterminal_s6 (T_Nonterminal_v18 ) K_Nonterminal_v32 :: K_Nonterminal_s6 (T_Nonterminal_v32 ) K_Nonterminal_v36 :: K_Nonterminal_s6 (T_Nonterminal_v36 ) data K_Nonterminal_s43 k where K_Nonterminal_v33 :: K_Nonterminal_s43 (T_Nonterminal_v33 ) K_Nonterminal_v45 :: K_Nonterminal_s43 (T_Nonterminal_v45 ) type T_Nonterminal_v3 = (T_Nonterminal_vIn3 ) -> (T_Nonterminal_vOut3 ) data T_Nonterminal_vIn3 = T_Nonterminal_vIn3 !(Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) !(Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) !(Bool) !(Map Identifier Attributes) !(AttrOrderMap) !(Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression)))) !(Set NontermIdent) !(Bool) !(Options) !(Map Identifier Attributes) !(TypeSyns) !(Int) !(UseMap) !(Set NontermIdent) data T_Nonterminal_vOut3 = T_Nonterminal_vOut3 !(Set NontermIdent) !(Seq Error) !(Map Identifier Attributes) !(Nonterminal) !(Map Identifier Attributes) !(Int) type T_Nonterminal_v18 = (T_Nonterminal_vIn18 ) -> (T_Nonterminal_vOut18 ) data T_Nonterminal_vIn18 = T_Nonterminal_vIn18 !(Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) !(Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) !(Bool) !(Map Identifier Attributes) !(AttrOrderMap) !(Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression)))) !(Bool) !(Options) !(Map Identifier Attributes) !(TypeSyns) !(Int) !(UseMap) !(Set NontermIdent) data T_Nonterminal_vOut18 = T_Nonterminal_vOut18 !(Set NontermIdent) !(Seq Error) !(Map Identifier Attributes) !(Nonterminal) !(Map Identifier Attributes) !(Int) type T_Nonterminal_v32 = (T_Nonterminal_vIn32 ) -> (T_Nonterminal_vOut32 ) data T_Nonterminal_vIn32 = T_Nonterminal_vIn32 data T_Nonterminal_vOut32 = T_Nonterminal_vOut32 !(Map Identifier Attributes) !(Map Identifier Attributes) !(T_Nonterminal_s43 ) type T_Nonterminal_v33 = (T_Nonterminal_vIn33 ) -> (T_Nonterminal_vOut33 ) data T_Nonterminal_vIn33 = T_Nonterminal_vIn33 !(Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) !(Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) !(Bool) !(Map Identifier Attributes) !(AttrOrderMap) !(Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression)))) !(Bool) !(Options) !(Map Identifier Attributes) !(TypeSyns) !(Int) !(UseMap) !(Set NontermIdent) data T_Nonterminal_vOut33 = T_Nonterminal_vOut33 !(Seq Error) !(Nonterminal) !(Int) type T_Nonterminal_v36 = (T_Nonterminal_vIn36 ) -> (T_Nonterminal_vOut36 ) data T_Nonterminal_vIn36 = T_Nonterminal_vIn36 !(Bool) !(Map Identifier Attributes) !(AttrOrderMap) !(Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression)))) !(Bool) !(Options) !(Map Identifier Attributes) !(TypeSyns) !(UseMap) !(Set NontermIdent) data T_Nonterminal_vOut36 = T_Nonterminal_vOut36 !(Set NontermIdent) !(Seq Error) !(Map Identifier Attributes) !(Map Identifier Attributes) !(T_Nonterminal_s46 ) type T_Nonterminal_v37 = (T_Nonterminal_vIn37 ) -> (T_Nonterminal_vOut37 ) data T_Nonterminal_vIn37 = T_Nonterminal_vIn37 !(Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) !(Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) !(Int) data T_Nonterminal_vOut37 = T_Nonterminal_vOut37 !(Nonterminal) !(Int) type T_Nonterminal_v45 = (T_Nonterminal_vIn45 ) -> (T_Nonterminal_vOut45 ) data T_Nonterminal_vIn45 = T_Nonterminal_vIn45 !(Bool) !(Map Identifier Attributes) !(AttrOrderMap) !(Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression)))) !(Bool) !(Options) !(Map Identifier Attributes) !(TypeSyns) !(UseMap) !(Set NontermIdent) data T_Nonterminal_vOut45 = T_Nonterminal_vOut45 !(Seq Error) !(T_Nonterminal_s52 ) type T_Nonterminal_v46 = (T_Nonterminal_vIn46 ) -> (T_Nonterminal_vOut46 ) data T_Nonterminal_vIn46 = T_Nonterminal_vIn46 !(Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) !(Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) !(Int) data T_Nonterminal_vOut46 = T_Nonterminal_vOut46 !(Nonterminal) !(Int) {-# NOINLINE sem_Nonterminal_Nonterminal #-} sem_Nonterminal_Nonterminal :: (NontermIdent) -> ([Identifier]) -> (Attributes) -> (Attributes) -> T_Productions -> T_Nonterminal sem_Nonterminal_Nonterminal !arg_nt_ !arg_params_ !arg_inh_ !arg_syn_ arg_prods_ = T_Nonterminal (return st6) where {-# NOINLINE st6 #-} !st6 = let k6 :: K_Nonterminal_s6 t -> t k6 K_Nonterminal_v3 = v3 k6 K_Nonterminal_v18 = v18 k6 K_Nonterminal_v32 = v32 k6 K_Nonterminal_v36 = v36 v3 :: T_Nonterminal_v3 v3 = \ !(T_Nonterminal_vIn3 _lhsIaroundsIn _lhsIaugmentsIn _lhsIcr _lhsIinhMap _lhsImanualAttrOrderMap _lhsImergesIn _lhsInonterminals _lhsIo_rename _lhsIoptions _lhsIsynMap _lhsItypeSyns _lhsIuniq _lhsIuseMap _lhsIwrappers) -> ( let !_prodsX16 = Control.Monad.Identity.runIdentity (attach_T_Productions (arg_prods_)) in let _lhsOcollect_nts :: Set NontermIdent !_lhsOcollect_nts = rule59 arg_nt_ in let !_prodsOcr = rule77 _lhsIcr in let !_inh1 = rule66 arg_inh_ arg_nt_ arg_params_ in let !_prodsOinh = rule60 _inh1 in let !_prodsOinhMap = rule78 _lhsIinhMap in let !_prodsOmanualAttrOrderMap = rule79 _lhsImanualAttrOrderMap in let !_mergesIn = rule71 _lhsImergesIn arg_nt_ in let !_prodsOmergesIn = rule80 _mergesIn in let !_prodsOnt = rule65 arg_nt_ in let !_prodsOo_rename = rule82 _lhsIo_rename in let !_prodsOoptions = rule83 _lhsIoptions in let !_syn1 = rule67 arg_nt_ arg_params_ arg_syn_ in let !_prodsOsyn = rule61 _syn1 in let !_prodsOsynMap = rule84 _lhsIsynMap in let !_prodsOsynOrig = rule63 arg_syn_ in let !_prodsOtypeSyns = rule85 _lhsItypeSyns in let !_prodsOuseMap = rule64 _lhsIuseMap arg_nt_ in let !_prodsOwrappers = rule87 _lhsIwrappers in let _lhsOinhMap' :: Map Identifier Attributes !_lhsOinhMap' = rule56 arg_inh_ arg_nt_ in let !_aroundsIn = rule70 _lhsIaroundsIn arg_nt_ in let !_prodsOaroundsIn = rule75 _aroundsIn in let !_augmentsIn = rule69 _lhsIaugmentsIn arg_nt_ in let !_prodsOaugmentsIn = rule76 _augmentsIn in let !_prodsOparams = rule58 arg_params_ in let !_prodsOuniq = rule86 _lhsIuniq in let _lhsOsynMap' :: Map Identifier Attributes !_lhsOsynMap' = rule57 arg_nt_ arg_syn_ in let !(T_Productions_vOut17 _prodsIerrors _prodsIoutput _prodsIuniq) = inv_Productions_s16 _prodsX16 K_Productions_v17 (T_Productions_vIn17 _prodsOaroundsIn _prodsOaugmentsIn _prodsOcr _prodsOinh _prodsOinhMap _prodsOmanualAttrOrderMap _prodsOmergesIn _prodsOnt _prodsOo_rename _prodsOoptions _prodsOparams _prodsOsyn _prodsOsynMap _prodsOsynOrig _prodsOtypeSyns _prodsOuniq _prodsOuseMap _prodsOwrappers) in let _lhsOerrors :: Seq Error !_lhsOerrors = rule72 _prodsIerrors in let _lhsOoutput :: Nonterminal !_lhsOoutput = rule68 _inh1 _prodsIoutput _syn1 arg_nt_ arg_params_ in let _lhsOuniq :: Int !_lhsOuniq = rule74 _prodsIuniq in let !__result_ = T_Nonterminal_vOut3 _lhsOcollect_nts _lhsOerrors _lhsOinhMap' _lhsOoutput _lhsOsynMap' _lhsOuniq in __result_ ) v18 :: T_Nonterminal_v18 v18 = \ !(T_Nonterminal_vIn18 _lhsIaroundsIn _lhsIaugmentsIn _lhsIcr _lhsIinhMap _lhsImanualAttrOrderMap _lhsImergesIn _lhsIo_rename _lhsIoptions _lhsIsynMap _lhsItypeSyns _lhsIuniq _lhsIuseMap _lhsIwrappers) -> ( let !_prodsX16 = Control.Monad.Identity.runIdentity (attach_T_Productions (arg_prods_)) in let _lhsOcollect_nts :: Set NontermIdent !_lhsOcollect_nts = rule59 arg_nt_ in let !_prodsOcr = rule77 _lhsIcr in let !_inh1 = rule66 arg_inh_ arg_nt_ arg_params_ in let !_prodsOinh = rule60 _inh1 in let !_prodsOinhMap = rule78 _lhsIinhMap in let !_prodsOmanualAttrOrderMap = rule79 _lhsImanualAttrOrderMap in let !_mergesIn = rule71 _lhsImergesIn arg_nt_ in let !_prodsOmergesIn = rule80 _mergesIn in let !_prodsOnt = rule65 arg_nt_ in let !_prodsOo_rename = rule82 _lhsIo_rename in let !_prodsOoptions = rule83 _lhsIoptions in let !_syn1 = rule67 arg_nt_ arg_params_ arg_syn_ in let !_prodsOsyn = rule61 _syn1 in let !_prodsOsynMap = rule84 _lhsIsynMap in let !_prodsOsynOrig = rule63 arg_syn_ in let !_prodsOtypeSyns = rule85 _lhsItypeSyns in let !_prodsOuseMap = rule64 _lhsIuseMap arg_nt_ in let !_prodsOwrappers = rule87 _lhsIwrappers in let _lhsOinhMap' :: Map Identifier Attributes !_lhsOinhMap' = rule56 arg_inh_ arg_nt_ in let !_aroundsIn = rule70 _lhsIaroundsIn arg_nt_ in let !_prodsOaroundsIn = rule75 _aroundsIn in let !_augmentsIn = rule69 _lhsIaugmentsIn arg_nt_ in let !_prodsOaugmentsIn = rule76 _augmentsIn in let !_prodsOparams = rule58 arg_params_ in let !_prodsOuniq = rule86 _lhsIuniq in let _lhsOsynMap' :: Map Identifier Attributes !_lhsOsynMap' = rule57 arg_nt_ arg_syn_ in let !(T_Productions_vOut17 _prodsIerrors _prodsIoutput _prodsIuniq) = inv_Productions_s16 _prodsX16 K_Productions_v17 (T_Productions_vIn17 _prodsOaroundsIn _prodsOaugmentsIn _prodsOcr _prodsOinh _prodsOinhMap _prodsOmanualAttrOrderMap _prodsOmergesIn _prodsOnt _prodsOo_rename _prodsOoptions _prodsOparams _prodsOsyn _prodsOsynMap _prodsOsynOrig _prodsOtypeSyns _prodsOuniq _prodsOuseMap _prodsOwrappers) in let _lhsOerrors :: Seq Error !_lhsOerrors = rule72 _prodsIerrors in let _lhsOoutput :: Nonterminal !_lhsOoutput = rule68 _inh1 _prodsIoutput _syn1 arg_nt_ arg_params_ in let _lhsOuniq :: Int !_lhsOuniq = rule74 _prodsIuniq in let !__result_ = T_Nonterminal_vOut18 _lhsOcollect_nts _lhsOerrors _lhsOinhMap' _lhsOoutput _lhsOsynMap' _lhsOuniq in __result_ ) v32 :: T_Nonterminal_v32 v32 = \ !(T_Nonterminal_vIn32 ) -> ( let _lhsOinhMap' :: Map Identifier Attributes !_lhsOinhMap' = rule56 arg_inh_ arg_nt_ in let _lhsOsynMap' :: Map Identifier Attributes !_lhsOsynMap' = rule57 arg_nt_ arg_syn_ in let !__st_ = st43 () !__result_ = T_Nonterminal_vOut32 _lhsOinhMap' _lhsOsynMap' __st_ in __result_ ) v36 :: T_Nonterminal_v36 v36 = \ !(T_Nonterminal_vIn36 _lhsIcr _lhsIinhMap _lhsImanualAttrOrderMap _lhsImergesIn _lhsIo_rename _lhsIoptions _lhsIsynMap _lhsItypeSyns _lhsIuseMap _lhsIwrappers) -> ( let !_prodsX16 = Control.Monad.Identity.runIdentity (attach_T_Productions (arg_prods_)) in let _lhsOcollect_nts :: Set NontermIdent !_lhsOcollect_nts = rule59 arg_nt_ in let !_prodsOcr = rule77 _lhsIcr in let !_inh1 = rule66 arg_inh_ arg_nt_ arg_params_ in let !_prodsOinh = rule60 _inh1 in let !_prodsOinhMap = rule78 _lhsIinhMap in let !_prodsOmanualAttrOrderMap = rule79 _lhsImanualAttrOrderMap in let !_mergesIn = rule71 _lhsImergesIn arg_nt_ in let !_prodsOmergesIn = rule80 _mergesIn in let !_prodsOnt = rule65 arg_nt_ in let !_prodsOo_rename = rule82 _lhsIo_rename in let !_prodsOoptions = rule83 _lhsIoptions in let !_syn1 = rule67 arg_nt_ arg_params_ arg_syn_ in let !_prodsOsyn = rule61 _syn1 in let !_prodsOsynMap = rule84 _lhsIsynMap in let !_prodsOsynOrig = rule63 arg_syn_ in let !_prodsOtypeSyns = rule85 _lhsItypeSyns in let !_prodsOuseMap = rule64 _lhsIuseMap arg_nt_ in let !_prodsOwrappers = rule87 _lhsIwrappers in let _lhsOinhMap' :: Map Identifier Attributes !_lhsOinhMap' = rule56 arg_inh_ arg_nt_ in let _lhsOsynMap' :: Map Identifier Attributes !_lhsOsynMap' = rule57 arg_nt_ arg_syn_ in let !(T_Productions_vOut26 _prodsIerrors _prodsX39) = inv_Productions_s16 _prodsX16 K_Productions_v26 (T_Productions_vIn26 _prodsOcr _prodsOinh _prodsOinhMap _prodsOmanualAttrOrderMap _prodsOmergesIn _prodsOnt _prodsOo_rename _prodsOoptions _prodsOsyn _prodsOsynMap _prodsOsynOrig _prodsOtypeSyns _prodsOuseMap _prodsOwrappers) in let _lhsOerrors :: Seq Error !_lhsOerrors = rule72 _prodsIerrors in let !__st_ = st46 _inh1 _prodsX39 _syn1 !__result_ = T_Nonterminal_vOut36 _lhsOcollect_nts _lhsOerrors _lhsOinhMap' _lhsOsynMap' __st_ in __result_ ) in C_Nonterminal_s6 k6 {-# NOINLINE st43 #-} st43 = \ (_ :: ()) -> let k43 :: K_Nonterminal_s43 t -> t k43 K_Nonterminal_v33 = v33 k43 K_Nonterminal_v45 = v45 v33 :: T_Nonterminal_v33 v33 = \ !(T_Nonterminal_vIn33 _lhsIaroundsIn _lhsIaugmentsIn _lhsIcr _lhsIinhMap _lhsImanualAttrOrderMap _lhsImergesIn _lhsIo_rename _lhsIoptions _lhsIsynMap _lhsItypeSyns _lhsIuniq _lhsIuseMap _lhsIwrappers) -> ( let !_prodsOnt = rule65 arg_nt_ in let !_prodsOsynOrig = rule63 arg_syn_ in let !_prodsX16 = Control.Monad.Identity.runIdentity (attach_T_Productions (arg_prods_)) in let !_prodsOcr = rule77 _lhsIcr in let !_inh1 = rule66 arg_inh_ arg_nt_ arg_params_ in let !_prodsOinh = rule60 _inh1 in let !_prodsOinhMap = rule78 _lhsIinhMap in let !_prodsOmanualAttrOrderMap = rule79 _lhsImanualAttrOrderMap in let !_mergesIn = rule71 _lhsImergesIn arg_nt_ in let !_prodsOmergesIn = rule80 _mergesIn in let !_prodsOo_rename = rule82 _lhsIo_rename in let !_prodsOoptions = rule83 _lhsIoptions in let !_syn1 = rule67 arg_nt_ arg_params_ arg_syn_ in let !_prodsOsyn = rule61 _syn1 in let !_prodsOsynMap = rule84 _lhsIsynMap in let !_prodsOtypeSyns = rule85 _lhsItypeSyns in let !_prodsOuseMap = rule64 _lhsIuseMap arg_nt_ in let !_prodsOwrappers = rule87 _lhsIwrappers in let !_aroundsIn = rule70 _lhsIaroundsIn arg_nt_ in let !_prodsOaroundsIn = rule75 _aroundsIn in let !_augmentsIn = rule69 _lhsIaugmentsIn arg_nt_ in let !_prodsOaugmentsIn = rule76 _augmentsIn in let !_prodsOparams = rule58 arg_params_ in let !_prodsOuniq = rule86 _lhsIuniq in let !(T_Productions_vOut17 _prodsIerrors _prodsIoutput _prodsIuniq) = inv_Productions_s16 _prodsX16 K_Productions_v17 (T_Productions_vIn17 _prodsOaroundsIn _prodsOaugmentsIn _prodsOcr _prodsOinh _prodsOinhMap _prodsOmanualAttrOrderMap _prodsOmergesIn _prodsOnt _prodsOo_rename _prodsOoptions _prodsOparams _prodsOsyn _prodsOsynMap _prodsOsynOrig _prodsOtypeSyns _prodsOuniq _prodsOuseMap _prodsOwrappers) in let _lhsOerrors :: Seq Error !_lhsOerrors = rule72 _prodsIerrors in let _lhsOoutput :: Nonterminal !_lhsOoutput = rule68 _inh1 _prodsIoutput _syn1 arg_nt_ arg_params_ in let _lhsOuniq :: Int !_lhsOuniq = rule74 _prodsIuniq in let !__result_ = T_Nonterminal_vOut33 _lhsOerrors _lhsOoutput _lhsOuniq in __result_ ) v45 :: T_Nonterminal_v45 v45 = \ !(T_Nonterminal_vIn45 _lhsIcr _lhsIinhMap _lhsImanualAttrOrderMap _lhsImergesIn _lhsIo_rename _lhsIoptions _lhsIsynMap _lhsItypeSyns _lhsIuseMap _lhsIwrappers) -> ( let !_prodsOnt = rule65 arg_nt_ in let !_prodsOsynOrig = rule63 arg_syn_ in let !_prodsX16 = Control.Monad.Identity.runIdentity (attach_T_Productions (arg_prods_)) in let !_prodsOcr = rule77 _lhsIcr in let !_inh1 = rule66 arg_inh_ arg_nt_ arg_params_ in let !_prodsOinh = rule60 _inh1 in let !_prodsOinhMap = rule78 _lhsIinhMap in let !_prodsOmanualAttrOrderMap = rule79 _lhsImanualAttrOrderMap in let !_mergesIn = rule71 _lhsImergesIn arg_nt_ in let !_prodsOmergesIn = rule80 _mergesIn in let !_prodsOo_rename = rule82 _lhsIo_rename in let !_prodsOoptions = rule83 _lhsIoptions in let !_syn1 = rule67 arg_nt_ arg_params_ arg_syn_ in let !_prodsOsyn = rule61 _syn1 in let !_prodsOsynMap = rule84 _lhsIsynMap in let !_prodsOtypeSyns = rule85 _lhsItypeSyns in let !_prodsOuseMap = rule64 _lhsIuseMap arg_nt_ in let !_prodsOwrappers = rule87 _lhsIwrappers in let !(T_Productions_vOut26 _prodsIerrors _prodsX39) = inv_Productions_s16 _prodsX16 K_Productions_v26 (T_Productions_vIn26 _prodsOcr _prodsOinh _prodsOinhMap _prodsOmanualAttrOrderMap _prodsOmergesIn _prodsOnt _prodsOo_rename _prodsOoptions _prodsOsyn _prodsOsynMap _prodsOsynOrig _prodsOtypeSyns _prodsOuseMap _prodsOwrappers) in let _lhsOerrors :: Seq Error !_lhsOerrors = rule72 _prodsIerrors in let !__st_ = st52 _inh1 _prodsX39 _syn1 !__result_ = T_Nonterminal_vOut45 _lhsOerrors __st_ in __result_ ) in C_Nonterminal_s43 k43 {-# NOINLINE st46 #-} st46 = \ !_inh1 !_prodsX39 !_syn1 -> let v37 :: T_Nonterminal_v37 v37 = \ !(T_Nonterminal_vIn37 _lhsIaroundsIn _lhsIaugmentsIn _lhsIuniq) -> ( let !_prodsOparams = rule58 arg_params_ in let !_aroundsIn = rule70 _lhsIaroundsIn arg_nt_ in let !_prodsOaroundsIn = rule75 _aroundsIn in let !_augmentsIn = rule69 _lhsIaugmentsIn arg_nt_ in let !_prodsOaugmentsIn = rule76 _augmentsIn in let !_prodsOuniq = rule86 _lhsIuniq in let !(T_Productions_vOut27 _prodsIoutput _prodsIuniq) = inv_Productions_s39 _prodsX39 (T_Productions_vIn27 _prodsOaroundsIn _prodsOaugmentsIn _prodsOparams _prodsOuniq) in let _lhsOoutput :: Nonterminal !_lhsOoutput = rule68 _inh1 _prodsIoutput _syn1 arg_nt_ arg_params_ in let _lhsOuniq :: Int !_lhsOuniq = rule74 _prodsIuniq in let !__result_ = T_Nonterminal_vOut37 _lhsOoutput _lhsOuniq in __result_ ) in C_Nonterminal_s46 v37 {-# NOINLINE st52 #-} st52 = \ !_inh1 !_prodsX39 !_syn1 -> let v46 :: T_Nonterminal_v46 v46 = \ !(T_Nonterminal_vIn46 _lhsIaroundsIn _lhsIaugmentsIn _lhsIuniq) -> ( let !_prodsOparams = rule58 arg_params_ in let !_aroundsIn = rule70 _lhsIaroundsIn arg_nt_ in let !_prodsOaroundsIn = rule75 _aroundsIn in let !_augmentsIn = rule69 _lhsIaugmentsIn arg_nt_ in let !_prodsOaugmentsIn = rule76 _augmentsIn in let !_prodsOuniq = rule86 _lhsIuniq in let !(T_Productions_vOut27 _prodsIoutput _prodsIuniq) = inv_Productions_s39 _prodsX39 (T_Productions_vIn27 _prodsOaroundsIn _prodsOaugmentsIn _prodsOparams _prodsOuniq) in let _lhsOoutput :: Nonterminal !_lhsOoutput = rule68 _inh1 _prodsIoutput _syn1 arg_nt_ arg_params_ in let _lhsOuniq :: Int !_lhsOuniq = rule74 _prodsIuniq in let !__result_ = T_Nonterminal_vOut46 _lhsOoutput _lhsOuniq in __result_ ) in C_Nonterminal_s52 v46 {-# NOINLINE rule56 #-} {-# LINE 7 "./src-ag/DistChildAttr.ag" #-} rule56 = \ !inh_ !nt_ -> {-# LINE 7 "./src-ag/DistChildAttr.ag" #-} Map.singleton nt_ inh_ {-# LINE 1382 "dist/build/DefaultRules.hs"#-} {-# NOINLINE rule57 #-} {-# LINE 8 "./src-ag/DistChildAttr.ag" #-} rule57 = \ !nt_ !syn_ -> {-# LINE 8 "./src-ag/DistChildAttr.ag" #-} Map.singleton nt_ syn_ {-# LINE 1388 "dist/build/DefaultRules.hs"#-} {-# NOINLINE rule58 #-} {-# LINE 44 "./src-ag/DefaultRules.ag" #-} rule58 = \ !params_ -> {-# LINE 44 "./src-ag/DefaultRules.ag" #-} params_ {-# LINE 1394 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule59 #-} {-# LINE 176 "./src-ag/DefaultRules.ag" #-} rule59 = \ !nt_ -> {-# LINE 176 "./src-ag/DefaultRules.ag" #-} Set.singleton nt_ {-# LINE 1400 "dist/build/DefaultRules.hs"#-} {-# NOINLINE rule60 #-} {-# LINE 190 "./src-ag/DefaultRules.ag" #-} rule60 = \ !_inh1 -> {-# LINE 190 "./src-ag/DefaultRules.ag" #-} _inh1 {-# LINE 1406 "dist/build/DefaultRules.hs"#-} {-# NOINLINE rule61 #-} {-# LINE 191 "./src-ag/DefaultRules.ag" #-} rule61 = \ !_syn1 -> {-# LINE 191 "./src-ag/DefaultRules.ag" #-} _syn1 {-# LINE 1412 "dist/build/DefaultRules.hs"#-} {-# NOINLINE rule63 #-} {-# LINE 193 "./src-ag/DefaultRules.ag" #-} rule63 = \ !syn_ -> {-# LINE 193 "./src-ag/DefaultRules.ag" #-} syn_ {-# LINE 1418 "dist/build/DefaultRules.hs"#-} {-# NOINLINE rule64 #-} {-# LINE 194 "./src-ag/DefaultRules.ag" #-} rule64 = \ ((!_lhsIuseMap) :: UseMap) !nt_ -> {-# LINE 194 "./src-ag/DefaultRules.ag" #-} Map.findWithDefault Map.empty nt_ _lhsIuseMap {-# LINE 1424 "dist/build/DefaultRules.hs"#-} {-# NOINLINE rule65 #-} {-# LINE 206 "./src-ag/DefaultRules.ag" #-} rule65 = \ !nt_ -> {-# LINE 206 "./src-ag/DefaultRules.ag" #-} nt_ {-# LINE 1430 "dist/build/DefaultRules.hs"#-} {-# NOINLINE rule66 #-} {-# LINE 564 "./src-ag/DefaultRules.ag" #-} rule66 = \ !inh_ !nt_ !params_ -> {-# LINE 564 "./src-ag/DefaultRules.ag" #-} Map.map (elimSelfId nt_ params_) inh_ {-# LINE 1436 "dist/build/DefaultRules.hs"#-} {-# NOINLINE rule67 #-} {-# LINE 565 "./src-ag/DefaultRules.ag" #-} rule67 = \ !nt_ !params_ !syn_ -> {-# LINE 565 "./src-ag/DefaultRules.ag" #-} Map.map (elimSelfId nt_ params_) syn_ {-# LINE 1442 "dist/build/DefaultRules.hs"#-} {-# NOINLINE rule68 #-} {-# LINE 604 "./src-ag/DefaultRules.ag" #-} rule68 = \ !_inh1 ((!_prodsIoutput) :: Productions) !_syn1 !nt_ !params_ -> {-# LINE 604 "./src-ag/DefaultRules.ag" #-} Nonterminal nt_ params_ _inh1 _syn1 _prodsIoutput {-# LINE 1448 "dist/build/DefaultRules.hs"#-} {-# NOINLINE rule69 #-} {-# LINE 776 "./src-ag/DefaultRules.ag" #-} rule69 = \ ((!_lhsIaugmentsIn) :: Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) !nt_ -> {-# LINE 776 "./src-ag/DefaultRules.ag" #-} Map.findWithDefault Map.empty nt_ _lhsIaugmentsIn {-# LINE 1454 "dist/build/DefaultRules.hs"#-} {-# NOINLINE rule70 #-} {-# LINE 783 "./src-ag/DefaultRules.ag" #-} rule70 = \ ((!_lhsIaroundsIn) :: Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) !nt_ -> {-# LINE 783 "./src-ag/DefaultRules.ag" #-} Map.findWithDefault Map.empty nt_ _lhsIaroundsIn {-# LINE 1460 "dist/build/DefaultRules.hs"#-} {-# NOINLINE rule71 #-} {-# LINE 791 "./src-ag/DefaultRules.ag" #-} rule71 = \ ((!_lhsImergesIn) :: Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression)))) !nt_ -> {-# LINE 791 "./src-ag/DefaultRules.ag" #-} Map.findWithDefault Map.empty nt_ _lhsImergesIn {-# LINE 1466 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule72 #-} rule72 = \ ((!_prodsIerrors) :: Seq Error) -> _prodsIerrors {-# NOINLINE[1] rule74 #-} rule74 = \ ((!_prodsIuniq) :: Int) -> _prodsIuniq {-# NOINLINE[1] rule75 #-} rule75 = \ !_aroundsIn -> _aroundsIn {-# NOINLINE[1] rule76 #-} rule76 = \ !_augmentsIn -> _augmentsIn {-# NOINLINE[1] rule77 #-} rule77 = \ ((!_lhsIcr) :: Bool) -> _lhsIcr {-# NOINLINE[1] rule78 #-} rule78 = \ ((!_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# NOINLINE[1] rule79 #-} rule79 = \ ((!_lhsImanualAttrOrderMap) :: AttrOrderMap) -> _lhsImanualAttrOrderMap {-# NOINLINE[1] rule80 #-} rule80 = \ !_mergesIn -> _mergesIn {-# NOINLINE[1] rule82 #-} rule82 = \ ((!_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# NOINLINE[1] rule83 #-} rule83 = \ ((!_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE[1] rule84 #-} rule84 = \ ((!_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# NOINLINE[1] rule85 #-} rule85 = \ ((!_lhsItypeSyns) :: TypeSyns) -> _lhsItypeSyns {-# NOINLINE[1] rule86 #-} rule86 = \ ((!_lhsIuniq) :: Int) -> _lhsIuniq {-# NOINLINE[1] rule87 #-} rule87 = \ ((!_lhsIwrappers) :: Set NontermIdent) -> _lhsIwrappers -- Nonterminals ------------------------------------------------ -- wrapper data Inh_Nonterminals = Inh_Nonterminals { aroundsIn_Inh_Nonterminals :: !(Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))), augmentsIn_Inh_Nonterminals :: !(Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))), cr_Inh_Nonterminals :: !(Bool), inhMap_Inh_Nonterminals :: !(Map Identifier Attributes), manualAttrOrderMap_Inh_Nonterminals :: !(AttrOrderMap), mergesIn_Inh_Nonterminals :: !(Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression)))), nonterminals_Inh_Nonterminals :: !(Set NontermIdent), o_rename_Inh_Nonterminals :: !(Bool), options_Inh_Nonterminals :: !(Options), synMap_Inh_Nonterminals :: !(Map Identifier Attributes), typeSyns_Inh_Nonterminals :: !(TypeSyns), uniq_Inh_Nonterminals :: !(Int), useMap_Inh_Nonterminals :: !(UseMap), wrappers_Inh_Nonterminals :: !(Set NontermIdent) } data Syn_Nonterminals = Syn_Nonterminals { collect_nts_Syn_Nonterminals :: !(Set NontermIdent), errors_Syn_Nonterminals :: !(Seq Error), inhMap'_Syn_Nonterminals :: !(Map Identifier Attributes), output_Syn_Nonterminals :: !(Nonterminals), synMap'_Syn_Nonterminals :: !(Map Identifier Attributes), uniq_Syn_Nonterminals :: !(Int) } {-# INLINABLE wrap_Nonterminals #-} wrap_Nonterminals :: T_Nonterminals -> Inh_Nonterminals -> (Syn_Nonterminals ) wrap_Nonterminals !(T_Nonterminals act) !(Inh_Nonterminals _lhsIaroundsIn _lhsIaugmentsIn _lhsIcr _lhsIinhMap _lhsImanualAttrOrderMap _lhsImergesIn _lhsInonterminals _lhsIo_rename _lhsIoptions _lhsIsynMap _lhsItypeSyns _lhsIuniq _lhsIuseMap _lhsIwrappers) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Nonterminals_vIn4 _lhsIaroundsIn _lhsIaugmentsIn _lhsIcr _lhsIinhMap _lhsImanualAttrOrderMap _lhsImergesIn _lhsInonterminals _lhsIo_rename _lhsIoptions _lhsIsynMap _lhsItypeSyns _lhsIuniq _lhsIuseMap _lhsIwrappers !(T_Nonterminals_vOut4 _lhsOcollect_nts _lhsOerrors _lhsOinhMap' _lhsOoutput _lhsOsynMap' _lhsOuniq) <- return (inv_Nonterminals_s8 sem K_Nonterminals_v4 arg) return (Syn_Nonterminals _lhsOcollect_nts _lhsOerrors _lhsOinhMap' _lhsOoutput _lhsOsynMap' _lhsOuniq) ) -- cata {-# NOINLINE sem_Nonterminals #-} sem_Nonterminals :: Nonterminals -> T_Nonterminals sem_Nonterminals list = Prelude.foldr sem_Nonterminals_Cons sem_Nonterminals_Nil (Prelude.map sem_Nonterminal list) -- semantic domain newtype T_Nonterminals = T_Nonterminals { attach_T_Nonterminals :: Identity (T_Nonterminals_s8 ) } data T_Nonterminals_s8 where C_Nonterminals_s8 :: { inv_Nonterminals_s8 :: !(forall t. K_Nonterminals_s8 t -> t) } -> T_Nonterminals_s8 data T_Nonterminals_s9 = C_Nonterminals_s9 data T_Nonterminals_s28 where C_Nonterminals_s28 :: { inv_Nonterminals_s28 :: !(forall t. K_Nonterminals_s28 t -> t) } -> T_Nonterminals_s28 data T_Nonterminals_s29 = C_Nonterminals_s29 newtype T_Nonterminals_s32 = C_Nonterminals_s32 { inv_Nonterminals_s32 :: (T_Nonterminals_v20 ) } data T_Nonterminals_s33 = C_Nonterminals_s33 newtype T_Nonterminals_s45 = C_Nonterminals_s45 { inv_Nonterminals_s45 :: (T_Nonterminals_v35 ) } data K_Nonterminals_s8 k where K_Nonterminals_v4 :: K_Nonterminals_s8 (T_Nonterminals_v4 ) K_Nonterminals_v15 :: K_Nonterminals_s8 (T_Nonterminals_v15 ) K_Nonterminals_v19 :: K_Nonterminals_s8 (T_Nonterminals_v19 ) data K_Nonterminals_s28 k where K_Nonterminals_v16 :: K_Nonterminals_s28 (T_Nonterminals_v16 ) K_Nonterminals_v34 :: K_Nonterminals_s28 (T_Nonterminals_v34 ) type T_Nonterminals_v4 = (T_Nonterminals_vIn4 ) -> (T_Nonterminals_vOut4 ) data T_Nonterminals_vIn4 = T_Nonterminals_vIn4 !(Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) !(Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) !(Bool) !(Map Identifier Attributes) !(AttrOrderMap) !(Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression)))) !(Set NontermIdent) !(Bool) !(Options) !(Map Identifier Attributes) !(TypeSyns) !(Int) !(UseMap) !(Set NontermIdent) data T_Nonterminals_vOut4 = T_Nonterminals_vOut4 !(Set NontermIdent) !(Seq Error) !(Map Identifier Attributes) !(Nonterminals) !(Map Identifier Attributes) !(Int) type T_Nonterminals_v15 = (T_Nonterminals_vIn15 ) -> (T_Nonterminals_vOut15 ) data T_Nonterminals_vIn15 = T_Nonterminals_vIn15 data T_Nonterminals_vOut15 = T_Nonterminals_vOut15 !(Map Identifier Attributes) !(Map Identifier Attributes) !(T_Nonterminals_s28 ) type T_Nonterminals_v16 = (T_Nonterminals_vIn16 ) -> (T_Nonterminals_vOut16 ) data T_Nonterminals_vIn16 = T_Nonterminals_vIn16 !(Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) !(Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) !(Bool) !(Map Identifier Attributes) !(AttrOrderMap) !(Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression)))) !(Bool) !(Options) !(Map Identifier Attributes) !(TypeSyns) !(Int) !(UseMap) !(Set NontermIdent) data T_Nonterminals_vOut16 = T_Nonterminals_vOut16 !(Seq Error) !(Nonterminals) !(Int) type T_Nonterminals_v19 = (T_Nonterminals_vIn19 ) -> (T_Nonterminals_vOut19 ) data T_Nonterminals_vIn19 = T_Nonterminals_vIn19 !(Bool) !(Map Identifier Attributes) !(AttrOrderMap) !(Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression)))) !(Bool) !(Options) !(Map Identifier Attributes) !(TypeSyns) !(UseMap) !(Set NontermIdent) data T_Nonterminals_vOut19 = T_Nonterminals_vOut19 !(Set NontermIdent) !(Seq Error) !(Map Identifier Attributes) !(Map Identifier Attributes) !(T_Nonterminals_s32 ) type T_Nonterminals_v20 = (T_Nonterminals_vIn20 ) -> (T_Nonterminals_vOut20 ) data T_Nonterminals_vIn20 = T_Nonterminals_vIn20 !(Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) !(Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) !(Int) data T_Nonterminals_vOut20 = T_Nonterminals_vOut20 !(Nonterminals) !(Int) type T_Nonterminals_v34 = (T_Nonterminals_vIn34 ) -> (T_Nonterminals_vOut34 ) data T_Nonterminals_vIn34 = T_Nonterminals_vIn34 !(Bool) !(Map Identifier Attributes) !(AttrOrderMap) !(Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression)))) !(Bool) !(Options) !(Map Identifier Attributes) !(TypeSyns) !(UseMap) !(Set NontermIdent) data T_Nonterminals_vOut34 = T_Nonterminals_vOut34 !(Seq Error) !(T_Nonterminals_s45 ) type T_Nonterminals_v35 = (T_Nonterminals_vIn35 ) -> (T_Nonterminals_vOut35 ) data T_Nonterminals_vIn35 = T_Nonterminals_vIn35 !(Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) !(Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) !(Int) data T_Nonterminals_vOut35 = T_Nonterminals_vOut35 !(Nonterminals) !(Int) {-# NOINLINE sem_Nonterminals_Cons #-} sem_Nonterminals_Cons :: T_Nonterminal -> T_Nonterminals -> T_Nonterminals sem_Nonterminals_Cons arg_hd_ arg_tl_ = T_Nonterminals (return st8) where {-# NOINLINE st8 #-} !st8 = let k8 :: K_Nonterminals_s8 t -> t k8 K_Nonterminals_v4 = v4 k8 K_Nonterminals_v15 = v15 k8 K_Nonterminals_v19 = v19 v4 :: T_Nonterminals_v4 v4 = \ !(T_Nonterminals_vIn4 _lhsIaroundsIn _lhsIaugmentsIn _lhsIcr _lhsIinhMap _lhsImanualAttrOrderMap _lhsImergesIn _lhsInonterminals _lhsIo_rename _lhsIoptions _lhsIsynMap _lhsItypeSyns _lhsIuniq _lhsIuseMap _lhsIwrappers) -> ( let !_hdX6 = Control.Monad.Identity.runIdentity (attach_T_Nonterminal (arg_hd_)) in let !_tlX8 = Control.Monad.Identity.runIdentity (attach_T_Nonterminals (arg_tl_)) in let !_hdOcr = rule97 _lhsIcr in let !_hdOinhMap = rule98 _lhsIinhMap in let !_hdOmanualAttrOrderMap = rule99 _lhsImanualAttrOrderMap in let !_hdOmergesIn = rule100 _lhsImergesIn in let !_hdOo_rename = rule102 _lhsIo_rename in let !_hdOoptions = rule103 _lhsIoptions in let !_hdOsynMap = rule104 _lhsIsynMap in let !_hdOtypeSyns = rule105 _lhsItypeSyns in let !_hdOuseMap = rule107 _lhsIuseMap in let !_hdOwrappers = rule108 _lhsIwrappers in let !_tlOcr = rule111 _lhsIcr in let !_tlOinhMap = rule112 _lhsIinhMap in let !_tlOmanualAttrOrderMap = rule113 _lhsImanualAttrOrderMap in let !_tlOmergesIn = rule114 _lhsImergesIn in let !_tlOo_rename = rule116 _lhsIo_rename in let !_tlOoptions = rule117 _lhsIoptions in let !_tlOsynMap = rule118 _lhsIsynMap in let !_tlOtypeSyns = rule119 _lhsItypeSyns in let !_tlOuseMap = rule121 _lhsIuseMap in let !_tlOwrappers = rule122 _lhsIwrappers in let !_hdOaroundsIn = rule95 _lhsIaroundsIn in let !_hdOaugmentsIn = rule96 _lhsIaugmentsIn in let !_hdOuniq = rule106 _lhsIuniq in let !_tlOaroundsIn = rule109 _lhsIaroundsIn in let !_tlOaugmentsIn = rule110 _lhsIaugmentsIn in let !(T_Nonterminal_vOut18 _hdIcollect_nts _hdIerrors _hdIinhMap' _hdIoutput _hdIsynMap' _hdIuniq) = inv_Nonterminal_s6 _hdX6 K_Nonterminal_v18 (T_Nonterminal_vIn18 _hdOaroundsIn _hdOaugmentsIn _hdOcr _hdOinhMap _hdOmanualAttrOrderMap _hdOmergesIn _hdOo_rename _hdOoptions _hdOsynMap _hdOtypeSyns _hdOuniq _hdOuseMap _hdOwrappers) in let !(T_Nonterminals_vOut19 _tlIcollect_nts _tlIerrors _tlIinhMap' _tlIsynMap' _tlX32) = inv_Nonterminals_s8 _tlX8 K_Nonterminals_v19 (T_Nonterminals_vIn19 _tlOcr _tlOinhMap _tlOmanualAttrOrderMap _tlOmergesIn _tlOo_rename _tlOoptions _tlOsynMap _tlOtypeSyns _tlOuseMap _tlOwrappers) in let _lhsOcollect_nts :: Set NontermIdent !_lhsOcollect_nts = rule88 _hdIcollect_nts _tlIcollect_nts in let _lhsOerrors :: Seq Error !_lhsOerrors = rule89 _hdIerrors _tlIerrors in let _lhsOinhMap' :: Map Identifier Attributes !_lhsOinhMap' = rule90 _hdIinhMap' _tlIinhMap' in let !_tlOuniq = rule120 _hdIuniq in let _lhsOsynMap' :: Map Identifier Attributes !_lhsOsynMap' = rule91 _hdIsynMap' _tlIsynMap' in let !(T_Nonterminals_vOut20 _tlIoutput _tlIuniq) = inv_Nonterminals_s32 _tlX32 (T_Nonterminals_vIn20 _tlOaroundsIn _tlOaugmentsIn _tlOuniq) in let !_output = rule92 _hdIoutput _tlIoutput in let _lhsOoutput :: Nonterminals !_lhsOoutput = rule93 _output in let _lhsOuniq :: Int !_lhsOuniq = rule94 _tlIuniq in let !__result_ = T_Nonterminals_vOut4 _lhsOcollect_nts _lhsOerrors _lhsOinhMap' _lhsOoutput _lhsOsynMap' _lhsOuniq in __result_ ) v15 :: T_Nonterminals_v15 v15 = \ !(T_Nonterminals_vIn15 ) -> ( let !_hdX6 = Control.Monad.Identity.runIdentity (attach_T_Nonterminal (arg_hd_)) in let !_tlX8 = Control.Monad.Identity.runIdentity (attach_T_Nonterminals (arg_tl_)) in let !(T_Nonterminal_vOut32 _hdIinhMap' _hdIsynMap' _hdX43) = inv_Nonterminal_s6 _hdX6 K_Nonterminal_v32 (T_Nonterminal_vIn32 ) in let !(T_Nonterminals_vOut15 _tlIinhMap' _tlIsynMap' _tlX28) = inv_Nonterminals_s8 _tlX8 K_Nonterminals_v15 (T_Nonterminals_vIn15 ) in let _lhsOinhMap' :: Map Identifier Attributes !_lhsOinhMap' = rule90 _hdIinhMap' _tlIinhMap' in let _lhsOsynMap' :: Map Identifier Attributes !_lhsOsynMap' = rule91 _hdIsynMap' _tlIsynMap' in let !__st_ = st28 _hdX43 _tlX28 !__result_ = T_Nonterminals_vOut15 _lhsOinhMap' _lhsOsynMap' __st_ in __result_ ) v19 :: T_Nonterminals_v19 v19 = \ !(T_Nonterminals_vIn19 _lhsIcr _lhsIinhMap _lhsImanualAttrOrderMap _lhsImergesIn _lhsIo_rename _lhsIoptions _lhsIsynMap _lhsItypeSyns _lhsIuseMap _lhsIwrappers) -> ( let !_hdX6 = Control.Monad.Identity.runIdentity (attach_T_Nonterminal (arg_hd_)) in let !_tlX8 = Control.Monad.Identity.runIdentity (attach_T_Nonterminals (arg_tl_)) in let !_hdOcr = rule97 _lhsIcr in let !_hdOinhMap = rule98 _lhsIinhMap in let !_hdOmanualAttrOrderMap = rule99 _lhsImanualAttrOrderMap in let !_hdOmergesIn = rule100 _lhsImergesIn in let !_hdOo_rename = rule102 _lhsIo_rename in let !_hdOoptions = rule103 _lhsIoptions in let !_hdOsynMap = rule104 _lhsIsynMap in let !_hdOtypeSyns = rule105 _lhsItypeSyns in let !_hdOuseMap = rule107 _lhsIuseMap in let !_hdOwrappers = rule108 _lhsIwrappers in let !_tlOcr = rule111 _lhsIcr in let !_tlOinhMap = rule112 _lhsIinhMap in let !_tlOmanualAttrOrderMap = rule113 _lhsImanualAttrOrderMap in let !_tlOmergesIn = rule114 _lhsImergesIn in let !_tlOo_rename = rule116 _lhsIo_rename in let !_tlOoptions = rule117 _lhsIoptions in let !_tlOsynMap = rule118 _lhsIsynMap in let !_tlOtypeSyns = rule119 _lhsItypeSyns in let !_tlOuseMap = rule121 _lhsIuseMap in let !_tlOwrappers = rule122 _lhsIwrappers in let !(T_Nonterminal_vOut36 _hdIcollect_nts _hdIerrors _hdIinhMap' _hdIsynMap' _hdX46) = inv_Nonterminal_s6 _hdX6 K_Nonterminal_v36 (T_Nonterminal_vIn36 _hdOcr _hdOinhMap _hdOmanualAttrOrderMap _hdOmergesIn _hdOo_rename _hdOoptions _hdOsynMap _hdOtypeSyns _hdOuseMap _hdOwrappers) in let !(T_Nonterminals_vOut19 _tlIcollect_nts _tlIerrors _tlIinhMap' _tlIsynMap' _tlX32) = inv_Nonterminals_s8 _tlX8 K_Nonterminals_v19 (T_Nonterminals_vIn19 _tlOcr _tlOinhMap _tlOmanualAttrOrderMap _tlOmergesIn _tlOo_rename _tlOoptions _tlOsynMap _tlOtypeSyns _tlOuseMap _tlOwrappers) in let _lhsOcollect_nts :: Set NontermIdent !_lhsOcollect_nts = rule88 _hdIcollect_nts _tlIcollect_nts in let _lhsOerrors :: Seq Error !_lhsOerrors = rule89 _hdIerrors _tlIerrors in let _lhsOinhMap' :: Map Identifier Attributes !_lhsOinhMap' = rule90 _hdIinhMap' _tlIinhMap' in let _lhsOsynMap' :: Map Identifier Attributes !_lhsOsynMap' = rule91 _hdIsynMap' _tlIsynMap' in let !__st_ = st32 _hdX46 _tlX32 !__result_ = T_Nonterminals_vOut19 _lhsOcollect_nts _lhsOerrors _lhsOinhMap' _lhsOsynMap' __st_ in __result_ ) in C_Nonterminals_s8 k8 {-# NOINLINE st28 #-} st28 = \ !_hdX43 !_tlX28 -> let k28 :: K_Nonterminals_s28 t -> t k28 K_Nonterminals_v16 = v16 k28 K_Nonterminals_v34 = v34 v16 :: T_Nonterminals_v16 v16 = \ !(T_Nonterminals_vIn16 _lhsIaroundsIn _lhsIaugmentsIn _lhsIcr _lhsIinhMap _lhsImanualAttrOrderMap _lhsImergesIn _lhsIo_rename _lhsIoptions _lhsIsynMap _lhsItypeSyns _lhsIuniq _lhsIuseMap _lhsIwrappers) -> ( let !_hdOcr = rule97 _lhsIcr in let !_hdOinhMap = rule98 _lhsIinhMap in let !_hdOmanualAttrOrderMap = rule99 _lhsImanualAttrOrderMap in let !_hdOmergesIn = rule100 _lhsImergesIn in let !_hdOo_rename = rule102 _lhsIo_rename in let !_hdOoptions = rule103 _lhsIoptions in let !_hdOsynMap = rule104 _lhsIsynMap in let !_hdOtypeSyns = rule105 _lhsItypeSyns in let !_hdOuseMap = rule107 _lhsIuseMap in let !_hdOwrappers = rule108 _lhsIwrappers in let !_tlOcr = rule111 _lhsIcr in let !_tlOinhMap = rule112 _lhsIinhMap in let !_tlOmanualAttrOrderMap = rule113 _lhsImanualAttrOrderMap in let !_tlOmergesIn = rule114 _lhsImergesIn in let !_tlOo_rename = rule116 _lhsIo_rename in let !_tlOoptions = rule117 _lhsIoptions in let !_tlOsynMap = rule118 _lhsIsynMap in let !_tlOtypeSyns = rule119 _lhsItypeSyns in let !_tlOuseMap = rule121 _lhsIuseMap in let !_tlOwrappers = rule122 _lhsIwrappers in let !_hdOaroundsIn = rule95 _lhsIaroundsIn in let !_hdOaugmentsIn = rule96 _lhsIaugmentsIn in let !_hdOuniq = rule106 _lhsIuniq in let !_tlOaroundsIn = rule109 _lhsIaroundsIn in let !_tlOaugmentsIn = rule110 _lhsIaugmentsIn in let !(T_Nonterminal_vOut33 _hdIerrors _hdIoutput _hdIuniq) = inv_Nonterminal_s43 _hdX43 K_Nonterminal_v33 (T_Nonterminal_vIn33 _hdOaroundsIn _hdOaugmentsIn _hdOcr _hdOinhMap _hdOmanualAttrOrderMap _hdOmergesIn _hdOo_rename _hdOoptions _hdOsynMap _hdOtypeSyns _hdOuniq _hdOuseMap _hdOwrappers) in let !(T_Nonterminals_vOut34 _tlIerrors _tlX45) = inv_Nonterminals_s28 _tlX28 K_Nonterminals_v34 (T_Nonterminals_vIn34 _tlOcr _tlOinhMap _tlOmanualAttrOrderMap _tlOmergesIn _tlOo_rename _tlOoptions _tlOsynMap _tlOtypeSyns _tlOuseMap _tlOwrappers) in let _lhsOerrors :: Seq Error !_lhsOerrors = rule89 _hdIerrors _tlIerrors in let !_tlOuniq = rule120 _hdIuniq in let !(T_Nonterminals_vOut35 _tlIoutput _tlIuniq) = inv_Nonterminals_s45 _tlX45 (T_Nonterminals_vIn35 _tlOaroundsIn _tlOaugmentsIn _tlOuniq) in let !_output = rule92 _hdIoutput _tlIoutput in let _lhsOoutput :: Nonterminals !_lhsOoutput = rule93 _output in let _lhsOuniq :: Int !_lhsOuniq = rule94 _tlIuniq in let !__result_ = T_Nonterminals_vOut16 _lhsOerrors _lhsOoutput _lhsOuniq in __result_ ) v34 :: T_Nonterminals_v34 v34 = \ !(T_Nonterminals_vIn34 _lhsIcr _lhsIinhMap _lhsImanualAttrOrderMap _lhsImergesIn _lhsIo_rename _lhsIoptions _lhsIsynMap _lhsItypeSyns _lhsIuseMap _lhsIwrappers) -> ( let !_hdOcr = rule97 _lhsIcr in let !_hdOinhMap = rule98 _lhsIinhMap in let !_hdOmanualAttrOrderMap = rule99 _lhsImanualAttrOrderMap in let !_hdOmergesIn = rule100 _lhsImergesIn in let !_hdOo_rename = rule102 _lhsIo_rename in let !_hdOoptions = rule103 _lhsIoptions in let !_hdOsynMap = rule104 _lhsIsynMap in let !_hdOtypeSyns = rule105 _lhsItypeSyns in let !_hdOuseMap = rule107 _lhsIuseMap in let !_hdOwrappers = rule108 _lhsIwrappers in let !_tlOcr = rule111 _lhsIcr in let !_tlOinhMap = rule112 _lhsIinhMap in let !_tlOmanualAttrOrderMap = rule113 _lhsImanualAttrOrderMap in let !_tlOmergesIn = rule114 _lhsImergesIn in let !_tlOo_rename = rule116 _lhsIo_rename in let !_tlOoptions = rule117 _lhsIoptions in let !_tlOsynMap = rule118 _lhsIsynMap in let !_tlOtypeSyns = rule119 _lhsItypeSyns in let !_tlOuseMap = rule121 _lhsIuseMap in let !_tlOwrappers = rule122 _lhsIwrappers in let !(T_Nonterminal_vOut45 _hdIerrors _hdX52) = inv_Nonterminal_s43 _hdX43 K_Nonterminal_v45 (T_Nonterminal_vIn45 _hdOcr _hdOinhMap _hdOmanualAttrOrderMap _hdOmergesIn _hdOo_rename _hdOoptions _hdOsynMap _hdOtypeSyns _hdOuseMap _hdOwrappers) in let !(T_Nonterminals_vOut34 _tlIerrors _tlX45) = inv_Nonterminals_s28 _tlX28 K_Nonterminals_v34 (T_Nonterminals_vIn34 _tlOcr _tlOinhMap _tlOmanualAttrOrderMap _tlOmergesIn _tlOo_rename _tlOoptions _tlOsynMap _tlOtypeSyns _tlOuseMap _tlOwrappers) in let _lhsOerrors :: Seq Error !_lhsOerrors = rule89 _hdIerrors _tlIerrors in let !__st_ = st45 _hdX52 _tlX45 !__result_ = T_Nonterminals_vOut34 _lhsOerrors __st_ in __result_ ) in C_Nonterminals_s28 k28 {-# NOINLINE st32 #-} st32 = \ !_hdX46 !_tlX32 -> let v20 :: T_Nonterminals_v20 v20 = \ !(T_Nonterminals_vIn20 _lhsIaroundsIn _lhsIaugmentsIn _lhsIuniq) -> ( let !_hdOaroundsIn = rule95 _lhsIaroundsIn in let !_hdOaugmentsIn = rule96 _lhsIaugmentsIn in let !_hdOuniq = rule106 _lhsIuniq in let !_tlOaroundsIn = rule109 _lhsIaroundsIn in let !_tlOaugmentsIn = rule110 _lhsIaugmentsIn in let !(T_Nonterminal_vOut37 _hdIoutput _hdIuniq) = inv_Nonterminal_s46 _hdX46 (T_Nonterminal_vIn37 _hdOaroundsIn _hdOaugmentsIn _hdOuniq) in let !_tlOuniq = rule120 _hdIuniq in let !(T_Nonterminals_vOut20 _tlIoutput _tlIuniq) = inv_Nonterminals_s32 _tlX32 (T_Nonterminals_vIn20 _tlOaroundsIn _tlOaugmentsIn _tlOuniq) in let !_output = rule92 _hdIoutput _tlIoutput in let _lhsOoutput :: Nonterminals !_lhsOoutput = rule93 _output in let _lhsOuniq :: Int !_lhsOuniq = rule94 _tlIuniq in let !__result_ = T_Nonterminals_vOut20 _lhsOoutput _lhsOuniq in __result_ ) in C_Nonterminals_s32 v20 {-# NOINLINE st45 #-} st45 = \ !_hdX52 !_tlX45 -> let v35 :: T_Nonterminals_v35 v35 = \ !(T_Nonterminals_vIn35 _lhsIaroundsIn _lhsIaugmentsIn _lhsIuniq) -> ( let !_hdOaroundsIn = rule95 _lhsIaroundsIn in let !_hdOaugmentsIn = rule96 _lhsIaugmentsIn in let !_hdOuniq = rule106 _lhsIuniq in let !_tlOaroundsIn = rule109 _lhsIaroundsIn in let !_tlOaugmentsIn = rule110 _lhsIaugmentsIn in let !(T_Nonterminal_vOut46 _hdIoutput _hdIuniq) = inv_Nonterminal_s52 _hdX52 (T_Nonterminal_vIn46 _hdOaroundsIn _hdOaugmentsIn _hdOuniq) in let !_tlOuniq = rule120 _hdIuniq in let !(T_Nonterminals_vOut35 _tlIoutput _tlIuniq) = inv_Nonterminals_s45 _tlX45 (T_Nonterminals_vIn35 _tlOaroundsIn _tlOaugmentsIn _tlOuniq) in let !_output = rule92 _hdIoutput _tlIoutput in let _lhsOoutput :: Nonterminals !_lhsOoutput = rule93 _output in let _lhsOuniq :: Int !_lhsOuniq = rule94 _tlIuniq in let !__result_ = T_Nonterminals_vOut35 _lhsOoutput _lhsOuniq in __result_ ) in C_Nonterminals_s45 v35 {-# NOINLINE[1] rule88 #-} rule88 = \ ((!_hdIcollect_nts) :: Set NontermIdent) ((!_tlIcollect_nts) :: Set NontermIdent) -> _hdIcollect_nts `Set.union` _tlIcollect_nts {-# NOINLINE[1] rule89 #-} rule89 = \ ((!_hdIerrors) :: Seq Error) ((!_tlIerrors) :: Seq Error) -> _hdIerrors Seq.>< _tlIerrors {-# NOINLINE[1] rule90 #-} rule90 = \ ((!_hdIinhMap') :: Map Identifier Attributes) ((!_tlIinhMap') :: Map Identifier Attributes) -> _hdIinhMap' `Map.union` _tlIinhMap' {-# NOINLINE[1] rule91 #-} rule91 = \ ((!_hdIsynMap') :: Map Identifier Attributes) ((!_tlIsynMap') :: Map Identifier Attributes) -> _hdIsynMap' `Map.union` _tlIsynMap' {-# NOINLINE[1] rule92 #-} rule92 = \ ((!_hdIoutput) :: Nonterminal) ((!_tlIoutput) :: Nonterminals) -> (:) _hdIoutput _tlIoutput {-# NOINLINE[1] rule93 #-} rule93 = \ !_output -> _output {-# NOINLINE[1] rule94 #-} rule94 = \ ((!_tlIuniq) :: Int) -> _tlIuniq {-# NOINLINE[1] rule95 #-} rule95 = \ ((!_lhsIaroundsIn) :: Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) -> _lhsIaroundsIn {-# NOINLINE[1] rule96 #-} rule96 = \ ((!_lhsIaugmentsIn) :: Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) -> _lhsIaugmentsIn {-# NOINLINE[1] rule97 #-} rule97 = \ ((!_lhsIcr) :: Bool) -> _lhsIcr {-# NOINLINE[1] rule98 #-} rule98 = \ ((!_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# NOINLINE[1] rule99 #-} rule99 = \ ((!_lhsImanualAttrOrderMap) :: AttrOrderMap) -> _lhsImanualAttrOrderMap {-# NOINLINE[1] rule100 #-} rule100 = \ ((!_lhsImergesIn) :: Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression)))) -> _lhsImergesIn {-# NOINLINE[1] rule102 #-} rule102 = \ ((!_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# NOINLINE[1] rule103 #-} rule103 = \ ((!_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE[1] rule104 #-} rule104 = \ ((!_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# NOINLINE[1] rule105 #-} rule105 = \ ((!_lhsItypeSyns) :: TypeSyns) -> _lhsItypeSyns {-# NOINLINE[1] rule106 #-} rule106 = \ ((!_lhsIuniq) :: Int) -> _lhsIuniq {-# NOINLINE[1] rule107 #-} rule107 = \ ((!_lhsIuseMap) :: UseMap) -> _lhsIuseMap {-# NOINLINE[1] rule108 #-} rule108 = \ ((!_lhsIwrappers) :: Set NontermIdent) -> _lhsIwrappers {-# NOINLINE[1] rule109 #-} rule109 = \ ((!_lhsIaroundsIn) :: Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) -> _lhsIaroundsIn {-# NOINLINE[1] rule110 #-} rule110 = \ ((!_lhsIaugmentsIn) :: Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) -> _lhsIaugmentsIn {-# NOINLINE[1] rule111 #-} rule111 = \ ((!_lhsIcr) :: Bool) -> _lhsIcr {-# NOINLINE[1] rule112 #-} rule112 = \ ((!_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# NOINLINE[1] rule113 #-} rule113 = \ ((!_lhsImanualAttrOrderMap) :: AttrOrderMap) -> _lhsImanualAttrOrderMap {-# NOINLINE[1] rule114 #-} rule114 = \ ((!_lhsImergesIn) :: Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression)))) -> _lhsImergesIn {-# NOINLINE[1] rule116 #-} rule116 = \ ((!_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# NOINLINE[1] rule117 #-} rule117 = \ ((!_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE[1] rule118 #-} rule118 = \ ((!_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# NOINLINE[1] rule119 #-} rule119 = \ ((!_lhsItypeSyns) :: TypeSyns) -> _lhsItypeSyns {-# NOINLINE[1] rule120 #-} rule120 = \ ((!_hdIuniq) :: Int) -> _hdIuniq {-# NOINLINE[1] rule121 #-} rule121 = \ ((!_lhsIuseMap) :: UseMap) -> _lhsIuseMap {-# NOINLINE[1] rule122 #-} rule122 = \ ((!_lhsIwrappers) :: Set NontermIdent) -> _lhsIwrappers {-# NOINLINE sem_Nonterminals_Nil #-} sem_Nonterminals_Nil :: T_Nonterminals sem_Nonterminals_Nil = T_Nonterminals (return st8) where {-# NOINLINE st8 #-} !st8 = let k8 :: K_Nonterminals_s8 t -> t k8 K_Nonterminals_v4 = v4 k8 K_Nonterminals_v15 = v15 k8 K_Nonterminals_v19 = v19 v4 :: T_Nonterminals_v4 v4 = \ !(T_Nonterminals_vIn4 _lhsIaroundsIn _lhsIaugmentsIn _lhsIcr _lhsIinhMap _lhsImanualAttrOrderMap _lhsImergesIn _lhsInonterminals _lhsIo_rename _lhsIoptions _lhsIsynMap _lhsItypeSyns _lhsIuniq _lhsIuseMap _lhsIwrappers) -> ( let _lhsOcollect_nts :: Set NontermIdent !_lhsOcollect_nts = rule123 () in let _lhsOerrors :: Seq Error !_lhsOerrors = rule124 () in let _lhsOinhMap' :: Map Identifier Attributes !_lhsOinhMap' = rule125 () in let !_output = rule127 () in let _lhsOsynMap' :: Map Identifier Attributes !_lhsOsynMap' = rule126 () in let _lhsOoutput :: Nonterminals !_lhsOoutput = rule128 _output in let _lhsOuniq :: Int !_lhsOuniq = rule129 _lhsIuniq in let !__result_ = T_Nonterminals_vOut4 _lhsOcollect_nts _lhsOerrors _lhsOinhMap' _lhsOoutput _lhsOsynMap' _lhsOuniq in __result_ ) v15 :: T_Nonterminals_v15 v15 = \ !(T_Nonterminals_vIn15 ) -> ( let _lhsOinhMap' :: Map Identifier Attributes !_lhsOinhMap' = rule125 () in let _lhsOsynMap' :: Map Identifier Attributes !_lhsOsynMap' = rule126 () in let !__st_ = st28 () !__result_ = T_Nonterminals_vOut15 _lhsOinhMap' _lhsOsynMap' __st_ in __result_ ) v19 :: T_Nonterminals_v19 v19 = \ !(T_Nonterminals_vIn19 _lhsIcr _lhsIinhMap _lhsImanualAttrOrderMap _lhsImergesIn _lhsIo_rename _lhsIoptions _lhsIsynMap _lhsItypeSyns _lhsIuseMap _lhsIwrappers) -> ( let _lhsOcollect_nts :: Set NontermIdent !_lhsOcollect_nts = rule123 () in let _lhsOerrors :: Seq Error !_lhsOerrors = rule124 () in let _lhsOinhMap' :: Map Identifier Attributes !_lhsOinhMap' = rule125 () in let _lhsOsynMap' :: Map Identifier Attributes !_lhsOsynMap' = rule126 () in let !__st_ = st32 () !__result_ = T_Nonterminals_vOut19 _lhsOcollect_nts _lhsOerrors _lhsOinhMap' _lhsOsynMap' __st_ in __result_ ) in C_Nonterminals_s8 k8 {-# NOINLINE st28 #-} st28 = \ (_ :: ()) -> let k28 :: K_Nonterminals_s28 t -> t k28 K_Nonterminals_v16 = v16 k28 K_Nonterminals_v34 = v34 v16 :: T_Nonterminals_v16 v16 = \ !(T_Nonterminals_vIn16 _lhsIaroundsIn _lhsIaugmentsIn _lhsIcr _lhsIinhMap _lhsImanualAttrOrderMap _lhsImergesIn _lhsIo_rename _lhsIoptions _lhsIsynMap _lhsItypeSyns _lhsIuniq _lhsIuseMap _lhsIwrappers) -> ( let _lhsOerrors :: Seq Error !_lhsOerrors = rule124 () in let !_output = rule127 () in let _lhsOoutput :: Nonterminals !_lhsOoutput = rule128 _output in let _lhsOuniq :: Int !_lhsOuniq = rule129 _lhsIuniq in let !__result_ = T_Nonterminals_vOut16 _lhsOerrors _lhsOoutput _lhsOuniq in __result_ ) v34 :: T_Nonterminals_v34 v34 = \ !(T_Nonterminals_vIn34 _lhsIcr _lhsIinhMap _lhsImanualAttrOrderMap _lhsImergesIn _lhsIo_rename _lhsIoptions _lhsIsynMap _lhsItypeSyns _lhsIuseMap _lhsIwrappers) -> ( let _lhsOerrors :: Seq Error !_lhsOerrors = rule124 () in let !__st_ = st45 () !__result_ = T_Nonterminals_vOut34 _lhsOerrors __st_ in __result_ ) in C_Nonterminals_s28 k28 {-# NOINLINE st32 #-} st32 = \ (_ :: ()) -> let v20 :: T_Nonterminals_v20 v20 = \ !(T_Nonterminals_vIn20 _lhsIaroundsIn _lhsIaugmentsIn _lhsIuniq) -> ( let !_output = rule127 () in let _lhsOoutput :: Nonterminals !_lhsOoutput = rule128 _output in let _lhsOuniq :: Int !_lhsOuniq = rule129 _lhsIuniq in let !__result_ = T_Nonterminals_vOut20 _lhsOoutput _lhsOuniq in __result_ ) in C_Nonterminals_s32 v20 {-# NOINLINE st45 #-} st45 = \ (_ :: ()) -> let v35 :: T_Nonterminals_v35 v35 = \ !(T_Nonterminals_vIn35 _lhsIaroundsIn _lhsIaugmentsIn _lhsIuniq) -> ( let !_output = rule127 () in let _lhsOoutput :: Nonterminals !_lhsOoutput = rule128 _output in let _lhsOuniq :: Int !_lhsOuniq = rule129 _lhsIuniq in let !__result_ = T_Nonterminals_vOut35 _lhsOoutput _lhsOuniq in __result_ ) in C_Nonterminals_s45 v35 {-# NOINLINE[1] rule123 #-} rule123 = \ (_ :: ()) -> Set.empty {-# NOINLINE[1] rule124 #-} rule124 = \ (_ :: ()) -> Seq.empty {-# NOINLINE[1] rule125 #-} rule125 = \ (_ :: ()) -> Map.empty {-# NOINLINE[1] rule126 #-} rule126 = \ (_ :: ()) -> Map.empty {-# NOINLINE[1] rule127 #-} rule127 = \ (_ :: ()) -> [] {-# NOINLINE[1] rule128 #-} rule128 = \ !_output -> _output {-# NOINLINE[1] rule129 #-} rule129 = \ ((!_lhsIuniq) :: Int) -> _lhsIuniq -- Pattern ----------------------------------------------------- -- wrapper data Inh_Pattern = Inh_Pattern { con_Inh_Pattern :: !(ConstructorIdent), nt_Inh_Pattern :: !(NontermIdent) } data Syn_Pattern = Syn_Pattern { containsVars_Syn_Pattern :: !(Bool), copy_Syn_Pattern :: !(Pattern), definedAttrs_Syn_Pattern :: !(Set (Identifier,Identifier)), errors_Syn_Pattern :: !(Seq Error), locals_Syn_Pattern :: !(Set Identifier), output_Syn_Pattern :: !(Pattern) } {-# INLINABLE wrap_Pattern #-} wrap_Pattern :: T_Pattern -> Inh_Pattern -> (Syn_Pattern ) wrap_Pattern !(T_Pattern act) !(Inh_Pattern _lhsIcon _lhsInt) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Pattern_vIn5 _lhsIcon _lhsInt !(T_Pattern_vOut5 _lhsOcontainsVars _lhsOcopy _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput) <- return (inv_Pattern_s10 sem K_Pattern_v5 arg) return (Syn_Pattern _lhsOcontainsVars _lhsOcopy _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput) ) -- cata {-# NOINLINE sem_Pattern #-} sem_Pattern :: Pattern -> T_Pattern sem_Pattern ( Constr !name_ pats_ ) = sem_Pattern_Constr name_ ( sem_Patterns pats_ ) sem_Pattern ( Product !pos_ pats_ ) = sem_Pattern_Product pos_ ( sem_Patterns pats_ ) sem_Pattern ( Alias !field_ !attr_ pat_ ) = sem_Pattern_Alias field_ attr_ ( sem_Pattern pat_ ) sem_Pattern ( Irrefutable pat_ ) = sem_Pattern_Irrefutable ( sem_Pattern pat_ ) sem_Pattern ( Underscore !pos_ ) = sem_Pattern_Underscore pos_ -- semantic domain newtype T_Pattern = T_Pattern { attach_T_Pattern :: Identity (T_Pattern_s10 ) } data T_Pattern_s10 where C_Pattern_s10 :: { inv_Pattern_s10 :: !(forall t. K_Pattern_s10 t -> t) } -> T_Pattern_s10 data T_Pattern_s11 = C_Pattern_s11 data T_Pattern_s35 = C_Pattern_s35 data T_Pattern_s36 = C_Pattern_s36 data T_Pattern_s40 = C_Pattern_s40 data T_Pattern_s50 = C_Pattern_s50 data T_Pattern_s55 where C_Pattern_s55 :: { inv_Pattern_s55 :: !(forall t. K_Pattern_s55 t -> t) } -> T_Pattern_s55 data K_Pattern_s10 k where K_Pattern_v5 :: K_Pattern_s10 (T_Pattern_v5 ) K_Pattern_v22 :: K_Pattern_s10 (T_Pattern_v22 ) K_Pattern_v23 :: K_Pattern_s10 (T_Pattern_v23 ) K_Pattern_v28 :: K_Pattern_s10 (T_Pattern_v28 ) K_Pattern_v42 :: K_Pattern_s10 (T_Pattern_v42 ) K_Pattern_v50 :: K_Pattern_s10 (T_Pattern_v50 ) data K_Pattern_s55 k where K_Pattern_v51 :: K_Pattern_s55 (T_Pattern_v51 ) K_Pattern_v56 :: K_Pattern_s55 (T_Pattern_v56 ) type T_Pattern_v5 = (T_Pattern_vIn5 ) -> (T_Pattern_vOut5 ) data T_Pattern_vIn5 = T_Pattern_vIn5 !(ConstructorIdent) !(NontermIdent) data T_Pattern_vOut5 = T_Pattern_vOut5 !(Bool) !(Pattern) !(Set (Identifier,Identifier)) !(Seq Error) !(Set Identifier) !(Pattern) type T_Pattern_v22 = (T_Pattern_vIn22 ) -> (T_Pattern_vOut22 ) data T_Pattern_vIn22 = T_Pattern_vIn22 data T_Pattern_vOut22 = T_Pattern_vOut22 !(Pattern) !(Set (Identifier,Identifier)) !(Seq Error) !(Set Identifier) !(Pattern) type T_Pattern_v23 = (T_Pattern_vIn23 ) -> (T_Pattern_vOut23 ) data T_Pattern_vIn23 = T_Pattern_vIn23 data T_Pattern_vOut23 = T_Pattern_vOut23 !(Bool) !(Pattern) !(Set (Identifier,Identifier)) !(Seq Error) !(Set Identifier) !(Pattern) type T_Pattern_v28 = (T_Pattern_vIn28 ) -> (T_Pattern_vOut28 ) data T_Pattern_vIn28 = T_Pattern_vIn28 data T_Pattern_vOut28 = T_Pattern_vOut28 !(Bool) !(Set (Identifier,Identifier)) !(Seq Error) !(Set Identifier) !(Pattern) type T_Pattern_v42 = (T_Pattern_vIn42 ) -> (T_Pattern_vOut42 ) data T_Pattern_vIn42 = T_Pattern_vIn42 data T_Pattern_vOut42 = T_Pattern_vOut42 !(Set (Identifier,Identifier)) !(Seq Error) !(Set Identifier) !(Pattern) type T_Pattern_v50 = (T_Pattern_vIn50 ) -> (T_Pattern_vOut50 ) data T_Pattern_vIn50 = T_Pattern_vIn50 data T_Pattern_vOut50 = T_Pattern_vOut50 !(Set (Identifier,Identifier)) !(Seq Error) !(Set Identifier) !(T_Pattern_s55 ) type T_Pattern_v51 = (T_Pattern_vIn51 ) -> (T_Pattern_vOut51 ) data T_Pattern_vIn51 = T_Pattern_vIn51 data T_Pattern_vOut51 = T_Pattern_vOut51 !(Bool) !(Pattern) type T_Pattern_v56 = (T_Pattern_vIn56 ) -> (T_Pattern_vOut56 ) data T_Pattern_vIn56 = T_Pattern_vIn56 data T_Pattern_vOut56 = T_Pattern_vOut56 !(Pattern) {-# NOINLINE sem_Pattern_Constr #-} sem_Pattern_Constr :: (ConstructorIdent) -> T_Patterns -> T_Pattern sem_Pattern_Constr !arg_name_ arg_pats_ = T_Pattern (return st10) where {-# NOINLINE st10 #-} !st10 = let k10 :: K_Pattern_s10 t -> t k10 K_Pattern_v5 = v5 k10 K_Pattern_v22 = v22 k10 K_Pattern_v23 = v23 k10 K_Pattern_v28 = v28 k10 K_Pattern_v42 = v42 k10 K_Pattern_v50 = v50 v5 :: T_Pattern_v5 v5 = \ !(T_Pattern_vIn5 _lhsIcon _lhsInt) -> ( let !_patsX12 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) in let !(T_Patterns_vOut21 _patsIcontainsVars _patsIcopy _patsIdefinedAttrs _patsIerrors _patsIlocals _patsIoutput) = inv_Patterns_s12 _patsX12 K_Patterns_v21 (T_Patterns_vIn21 ) in let _lhsOcontainsVars :: Bool !_lhsOcontainsVars = rule130 _patsIcontainsVars in let !_copy = rule134 _patsIcopy arg_name_ in let _lhsOcopy :: Pattern !_lhsOcopy = rule136 _copy in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule131 _patsIdefinedAttrs in let _lhsOerrors :: Seq Error !_lhsOerrors = rule132 _patsIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule133 _patsIlocals in let !_output = rule135 _patsIoutput arg_name_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule137 _output in let !__result_ = T_Pattern_vOut5 _lhsOcontainsVars _lhsOcopy _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v22 :: T_Pattern_v22 v22 = \ !(T_Pattern_vIn22 ) -> ( let !_patsX12 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) in let !(T_Patterns_vOut38 _patsIcopy _patsIdefinedAttrs _patsIerrors _patsIlocals _patsIoutput) = inv_Patterns_s12 _patsX12 K_Patterns_v38 (T_Patterns_vIn38 ) in let !_copy = rule134 _patsIcopy arg_name_ in let _lhsOcopy :: Pattern !_lhsOcopy = rule136 _copy in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule131 _patsIdefinedAttrs in let _lhsOerrors :: Seq Error !_lhsOerrors = rule132 _patsIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule133 _patsIlocals in let !_output = rule135 _patsIoutput arg_name_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule137 _output in let !__result_ = T_Pattern_vOut22 _lhsOcopy _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v23 :: T_Pattern_v23 v23 = \ !(T_Pattern_vIn23 ) -> ( let !_patsX12 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) in let !(T_Patterns_vOut21 _patsIcontainsVars _patsIcopy _patsIdefinedAttrs _patsIerrors _patsIlocals _patsIoutput) = inv_Patterns_s12 _patsX12 K_Patterns_v21 (T_Patterns_vIn21 ) in let _lhsOcontainsVars :: Bool !_lhsOcontainsVars = rule130 _patsIcontainsVars in let !_copy = rule134 _patsIcopy arg_name_ in let _lhsOcopy :: Pattern !_lhsOcopy = rule136 _copy in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule131 _patsIdefinedAttrs in let _lhsOerrors :: Seq Error !_lhsOerrors = rule132 _patsIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule133 _patsIlocals in let !_output = rule135 _patsIoutput arg_name_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule137 _output in let !__result_ = T_Pattern_vOut23 _lhsOcontainsVars _lhsOcopy _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v28 :: T_Pattern_v28 v28 = \ !(T_Pattern_vIn28 ) -> ( let !_patsX12 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) in let !(T_Patterns_vOut41 _patsIcontainsVars _patsIdefinedAttrs _patsIerrors _patsIlocals _patsIoutput) = inv_Patterns_s12 _patsX12 K_Patterns_v41 (T_Patterns_vIn41 ) in let _lhsOcontainsVars :: Bool !_lhsOcontainsVars = rule130 _patsIcontainsVars in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule131 _patsIdefinedAttrs in let _lhsOerrors :: Seq Error !_lhsOerrors = rule132 _patsIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule133 _patsIlocals in let !_output = rule135 _patsIoutput arg_name_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule137 _output in let !__result_ = T_Pattern_vOut28 _lhsOcontainsVars _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v42 :: T_Pattern_v42 v42 = \ !(T_Pattern_vIn42 ) -> ( let !_patsX12 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) in let !(T_Patterns_vOut49 _patsIdefinedAttrs _patsIerrors _patsIlocals _patsIoutput) = inv_Patterns_s12 _patsX12 K_Patterns_v49 (T_Patterns_vIn49 ) in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule131 _patsIdefinedAttrs in let _lhsOerrors :: Seq Error !_lhsOerrors = rule132 _patsIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule133 _patsIlocals in let !_output = rule135 _patsIoutput arg_name_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule137 _output in let !__result_ = T_Pattern_vOut42 _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v50 :: T_Pattern_v50 v50 = \ !(T_Pattern_vIn50 ) -> ( let !_patsX12 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) in let !(T_Patterns_vOut54 _patsIdefinedAttrs _patsIerrors _patsIlocals _patsX57) = inv_Patterns_s12 _patsX12 K_Patterns_v54 (T_Patterns_vIn54 ) in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule131 _patsIdefinedAttrs in let _lhsOerrors :: Seq Error !_lhsOerrors = rule132 _patsIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule133 _patsIlocals in let !__st_ = st55 _patsX57 !__result_ = T_Pattern_vOut50 _lhsOdefinedAttrs _lhsOerrors _lhsOlocals __st_ in __result_ ) in C_Pattern_s10 k10 {-# NOINLINE st55 #-} st55 = \ !_patsX57 -> let k55 :: K_Pattern_s55 t -> t k55 K_Pattern_v51 = v51 k55 K_Pattern_v56 = v56 v51 :: T_Pattern_v51 v51 = \ !(T_Pattern_vIn51 ) -> ( let !(T_Patterns_vOut55 _patsIcontainsVars _patsIoutput) = inv_Patterns_s57 _patsX57 K_Patterns_v55 (T_Patterns_vIn55 ) in let _lhsOcontainsVars :: Bool !_lhsOcontainsVars = rule130 _patsIcontainsVars in let !_output = rule135 _patsIoutput arg_name_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule137 _output in let !__result_ = T_Pattern_vOut51 _lhsOcontainsVars _lhsOoutput in __result_ ) v56 :: T_Pattern_v56 v56 = \ !(T_Pattern_vIn56 ) -> ( let !(T_Patterns_vOut57 _patsIoutput) = inv_Patterns_s57 _patsX57 K_Patterns_v57 (T_Patterns_vIn57 ) in let !_output = rule135 _patsIoutput arg_name_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule137 _output in let !__result_ = T_Pattern_vOut56 _lhsOoutput in __result_ ) in C_Pattern_s55 k55 {-# NOINLINE[1] rule130 #-} rule130 = \ ((!_patsIcontainsVars) :: Bool) -> _patsIcontainsVars {-# NOINLINE[1] rule131 #-} rule131 = \ ((!_patsIdefinedAttrs) :: Set (Identifier,Identifier)) -> _patsIdefinedAttrs {-# NOINLINE[1] rule132 #-} rule132 = \ ((!_patsIerrors) :: Seq Error) -> _patsIerrors {-# NOINLINE[1] rule133 #-} rule133 = \ ((!_patsIlocals) :: Set Identifier) -> _patsIlocals {-# NOINLINE[1] rule134 #-} rule134 = \ ((!_patsIcopy) :: Patterns) !name_ -> Constr name_ _patsIcopy {-# NOINLINE[1] rule135 #-} rule135 = \ ((!_patsIoutput) :: Patterns) !name_ -> Constr name_ _patsIoutput {-# NOINLINE[1] rule136 #-} rule136 = \ !_copy -> _copy {-# NOINLINE[1] rule137 #-} rule137 = \ !_output -> _output {-# NOINLINE sem_Pattern_Product #-} sem_Pattern_Product :: (Pos) -> T_Patterns -> T_Pattern sem_Pattern_Product !arg_pos_ arg_pats_ = T_Pattern (return st10) where {-# NOINLINE st10 #-} !st10 = let k10 :: K_Pattern_s10 t -> t k10 K_Pattern_v5 = v5 k10 K_Pattern_v22 = v22 k10 K_Pattern_v23 = v23 k10 K_Pattern_v28 = v28 k10 K_Pattern_v42 = v42 k10 K_Pattern_v50 = v50 v5 :: T_Pattern_v5 v5 = \ !(T_Pattern_vIn5 _lhsIcon _lhsInt) -> ( let !_patsX12 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) in let !(T_Patterns_vOut21 _patsIcontainsVars _patsIcopy _patsIdefinedAttrs _patsIerrors _patsIlocals _patsIoutput) = inv_Patterns_s12 _patsX12 K_Patterns_v21 (T_Patterns_vIn21 ) in let _lhsOcontainsVars :: Bool !_lhsOcontainsVars = rule140 _patsIcontainsVars in let !_copy = rule144 _patsIcopy arg_pos_ in let _lhsOcopy :: Pattern !_lhsOcopy = rule146 _copy in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule141 _patsIdefinedAttrs in let _lhsOerrors :: Seq Error !_lhsOerrors = rule142 _patsIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule143 _patsIlocals in let !_output = rule145 _patsIoutput arg_pos_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule147 _output in let !__result_ = T_Pattern_vOut5 _lhsOcontainsVars _lhsOcopy _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v22 :: T_Pattern_v22 v22 = \ !(T_Pattern_vIn22 ) -> ( let !_patsX12 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) in let !(T_Patterns_vOut38 _patsIcopy _patsIdefinedAttrs _patsIerrors _patsIlocals _patsIoutput) = inv_Patterns_s12 _patsX12 K_Patterns_v38 (T_Patterns_vIn38 ) in let !_copy = rule144 _patsIcopy arg_pos_ in let _lhsOcopy :: Pattern !_lhsOcopy = rule146 _copy in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule141 _patsIdefinedAttrs in let _lhsOerrors :: Seq Error !_lhsOerrors = rule142 _patsIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule143 _patsIlocals in let !_output = rule145 _patsIoutput arg_pos_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule147 _output in let !__result_ = T_Pattern_vOut22 _lhsOcopy _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v23 :: T_Pattern_v23 v23 = \ !(T_Pattern_vIn23 ) -> ( let !_patsX12 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) in let !(T_Patterns_vOut21 _patsIcontainsVars _patsIcopy _patsIdefinedAttrs _patsIerrors _patsIlocals _patsIoutput) = inv_Patterns_s12 _patsX12 K_Patterns_v21 (T_Patterns_vIn21 ) in let _lhsOcontainsVars :: Bool !_lhsOcontainsVars = rule140 _patsIcontainsVars in let !_copy = rule144 _patsIcopy arg_pos_ in let _lhsOcopy :: Pattern !_lhsOcopy = rule146 _copy in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule141 _patsIdefinedAttrs in let _lhsOerrors :: Seq Error !_lhsOerrors = rule142 _patsIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule143 _patsIlocals in let !_output = rule145 _patsIoutput arg_pos_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule147 _output in let !__result_ = T_Pattern_vOut23 _lhsOcontainsVars _lhsOcopy _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v28 :: T_Pattern_v28 v28 = \ !(T_Pattern_vIn28 ) -> ( let !_patsX12 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) in let !(T_Patterns_vOut41 _patsIcontainsVars _patsIdefinedAttrs _patsIerrors _patsIlocals _patsIoutput) = inv_Patterns_s12 _patsX12 K_Patterns_v41 (T_Patterns_vIn41 ) in let _lhsOcontainsVars :: Bool !_lhsOcontainsVars = rule140 _patsIcontainsVars in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule141 _patsIdefinedAttrs in let _lhsOerrors :: Seq Error !_lhsOerrors = rule142 _patsIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule143 _patsIlocals in let !_output = rule145 _patsIoutput arg_pos_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule147 _output in let !__result_ = T_Pattern_vOut28 _lhsOcontainsVars _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v42 :: T_Pattern_v42 v42 = \ !(T_Pattern_vIn42 ) -> ( let !_patsX12 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) in let !(T_Patterns_vOut49 _patsIdefinedAttrs _patsIerrors _patsIlocals _patsIoutput) = inv_Patterns_s12 _patsX12 K_Patterns_v49 (T_Patterns_vIn49 ) in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule141 _patsIdefinedAttrs in let _lhsOerrors :: Seq Error !_lhsOerrors = rule142 _patsIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule143 _patsIlocals in let !_output = rule145 _patsIoutput arg_pos_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule147 _output in let !__result_ = T_Pattern_vOut42 _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v50 :: T_Pattern_v50 v50 = \ !(T_Pattern_vIn50 ) -> ( let !_patsX12 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) in let !(T_Patterns_vOut54 _patsIdefinedAttrs _patsIerrors _patsIlocals _patsX57) = inv_Patterns_s12 _patsX12 K_Patterns_v54 (T_Patterns_vIn54 ) in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule141 _patsIdefinedAttrs in let _lhsOerrors :: Seq Error !_lhsOerrors = rule142 _patsIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule143 _patsIlocals in let !__st_ = st55 _patsX57 !__result_ = T_Pattern_vOut50 _lhsOdefinedAttrs _lhsOerrors _lhsOlocals __st_ in __result_ ) in C_Pattern_s10 k10 {-# NOINLINE st55 #-} st55 = \ !_patsX57 -> let k55 :: K_Pattern_s55 t -> t k55 K_Pattern_v51 = v51 k55 K_Pattern_v56 = v56 v51 :: T_Pattern_v51 v51 = \ !(T_Pattern_vIn51 ) -> ( let !(T_Patterns_vOut55 _patsIcontainsVars _patsIoutput) = inv_Patterns_s57 _patsX57 K_Patterns_v55 (T_Patterns_vIn55 ) in let _lhsOcontainsVars :: Bool !_lhsOcontainsVars = rule140 _patsIcontainsVars in let !_output = rule145 _patsIoutput arg_pos_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule147 _output in let !__result_ = T_Pattern_vOut51 _lhsOcontainsVars _lhsOoutput in __result_ ) v56 :: T_Pattern_v56 v56 = \ !(T_Pattern_vIn56 ) -> ( let !(T_Patterns_vOut57 _patsIoutput) = inv_Patterns_s57 _patsX57 K_Patterns_v57 (T_Patterns_vIn57 ) in let !_output = rule145 _patsIoutput arg_pos_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule147 _output in let !__result_ = T_Pattern_vOut56 _lhsOoutput in __result_ ) in C_Pattern_s55 k55 {-# NOINLINE[1] rule140 #-} rule140 = \ ((!_patsIcontainsVars) :: Bool) -> _patsIcontainsVars {-# NOINLINE[1] rule141 #-} rule141 = \ ((!_patsIdefinedAttrs) :: Set (Identifier,Identifier)) -> _patsIdefinedAttrs {-# NOINLINE[1] rule142 #-} rule142 = \ ((!_patsIerrors) :: Seq Error) -> _patsIerrors {-# NOINLINE[1] rule143 #-} rule143 = \ ((!_patsIlocals) :: Set Identifier) -> _patsIlocals {-# NOINLINE[1] rule144 #-} rule144 = \ ((!_patsIcopy) :: Patterns) !pos_ -> Product pos_ _patsIcopy {-# NOINLINE[1] rule145 #-} rule145 = \ ((!_patsIoutput) :: Patterns) !pos_ -> Product pos_ _patsIoutput {-# NOINLINE[1] rule146 #-} rule146 = \ !_copy -> _copy {-# NOINLINE[1] rule147 #-} rule147 = \ !_output -> _output {-# NOINLINE sem_Pattern_Alias #-} sem_Pattern_Alias :: (Identifier) -> (Identifier) -> T_Pattern -> T_Pattern sem_Pattern_Alias !arg_field_ !arg_attr_ arg_pat_ = T_Pattern (return st10) where {-# NOINLINE st10 #-} !st10 = let k10 :: K_Pattern_s10 t -> t k10 K_Pattern_v5 = v5 k10 K_Pattern_v22 = v22 k10 K_Pattern_v23 = v23 k10 K_Pattern_v28 = v28 k10 K_Pattern_v42 = v42 k10 K_Pattern_v50 = v50 v5 :: T_Pattern_v5 v5 = \ !(T_Pattern_vIn5 _lhsIcon _lhsInt) -> ( let _lhsOcontainsVars :: Bool !_lhsOcontainsVars = rule152 () in let !_patX10 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) in let !(T_Pattern_vOut22 _patIcopy _patIdefinedAttrs _patIerrors _patIlocals _patIoutput) = inv_Pattern_s10 _patX10 K_Pattern_v22 (T_Pattern_vIn22 ) in let !_copy = rule154 _patIcopy arg_attr_ arg_field_ in let _lhsOcopy :: Pattern !_lhsOcopy = rule156 _copy in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule150 _patIdefinedAttrs arg_attr_ arg_field_ in let _lhsOerrors :: Seq Error !_lhsOerrors = rule153 _patIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule151 _patIlocals arg_attr_ arg_field_ in let !_output = rule155 _patIoutput arg_attr_ arg_field_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule157 _output in let !__result_ = T_Pattern_vOut5 _lhsOcontainsVars _lhsOcopy _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v22 :: T_Pattern_v22 v22 = \ !(T_Pattern_vIn22 ) -> ( let !_patX10 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) in let !(T_Pattern_vOut22 _patIcopy _patIdefinedAttrs _patIerrors _patIlocals _patIoutput) = inv_Pattern_s10 _patX10 K_Pattern_v22 (T_Pattern_vIn22 ) in let !_copy = rule154 _patIcopy arg_attr_ arg_field_ in let _lhsOcopy :: Pattern !_lhsOcopy = rule156 _copy in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule150 _patIdefinedAttrs arg_attr_ arg_field_ in let _lhsOerrors :: Seq Error !_lhsOerrors = rule153 _patIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule151 _patIlocals arg_attr_ arg_field_ in let !_output = rule155 _patIoutput arg_attr_ arg_field_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule157 _output in let !__result_ = T_Pattern_vOut22 _lhsOcopy _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v23 :: T_Pattern_v23 v23 = \ !(T_Pattern_vIn23 ) -> ( let _lhsOcontainsVars :: Bool !_lhsOcontainsVars = rule152 () in let !_patX10 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) in let !(T_Pattern_vOut22 _patIcopy _patIdefinedAttrs _patIerrors _patIlocals _patIoutput) = inv_Pattern_s10 _patX10 K_Pattern_v22 (T_Pattern_vIn22 ) in let !_copy = rule154 _patIcopy arg_attr_ arg_field_ in let _lhsOcopy :: Pattern !_lhsOcopy = rule156 _copy in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule150 _patIdefinedAttrs arg_attr_ arg_field_ in let _lhsOerrors :: Seq Error !_lhsOerrors = rule153 _patIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule151 _patIlocals arg_attr_ arg_field_ in let !_output = rule155 _patIoutput arg_attr_ arg_field_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule157 _output in let !__result_ = T_Pattern_vOut23 _lhsOcontainsVars _lhsOcopy _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v28 :: T_Pattern_v28 v28 = \ !(T_Pattern_vIn28 ) -> ( let _lhsOcontainsVars :: Bool !_lhsOcontainsVars = rule152 () in let !_patX10 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) in let !(T_Pattern_vOut42 _patIdefinedAttrs _patIerrors _patIlocals _patIoutput) = inv_Pattern_s10 _patX10 K_Pattern_v42 (T_Pattern_vIn42 ) in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule150 _patIdefinedAttrs arg_attr_ arg_field_ in let _lhsOerrors :: Seq Error !_lhsOerrors = rule153 _patIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule151 _patIlocals arg_attr_ arg_field_ in let !_output = rule155 _patIoutput arg_attr_ arg_field_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule157 _output in let !__result_ = T_Pattern_vOut28 _lhsOcontainsVars _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v42 :: T_Pattern_v42 v42 = \ !(T_Pattern_vIn42 ) -> ( let !_patX10 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) in let !(T_Pattern_vOut42 _patIdefinedAttrs _patIerrors _patIlocals _patIoutput) = inv_Pattern_s10 _patX10 K_Pattern_v42 (T_Pattern_vIn42 ) in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule150 _patIdefinedAttrs arg_attr_ arg_field_ in let _lhsOerrors :: Seq Error !_lhsOerrors = rule153 _patIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule151 _patIlocals arg_attr_ arg_field_ in let !_output = rule155 _patIoutput arg_attr_ arg_field_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule157 _output in let !__result_ = T_Pattern_vOut42 _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v50 :: T_Pattern_v50 v50 = \ !(T_Pattern_vIn50 ) -> ( let !_patX10 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) in let !(T_Pattern_vOut50 _patIdefinedAttrs _patIerrors _patIlocals _patX55) = inv_Pattern_s10 _patX10 K_Pattern_v50 (T_Pattern_vIn50 ) in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule150 _patIdefinedAttrs arg_attr_ arg_field_ in let _lhsOerrors :: Seq Error !_lhsOerrors = rule153 _patIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule151 _patIlocals arg_attr_ arg_field_ in let !__st_ = st55 _patX55 !__result_ = T_Pattern_vOut50 _lhsOdefinedAttrs _lhsOerrors _lhsOlocals __st_ in __result_ ) in C_Pattern_s10 k10 {-# NOINLINE st55 #-} st55 = \ !_patX55 -> let k55 :: K_Pattern_s55 t -> t k55 K_Pattern_v51 = v51 k55 K_Pattern_v56 = v56 v51 :: T_Pattern_v51 v51 = \ !(T_Pattern_vIn51 ) -> ( let _lhsOcontainsVars :: Bool !_lhsOcontainsVars = rule152 () in let !(T_Pattern_vOut56 _patIoutput) = inv_Pattern_s55 _patX55 K_Pattern_v56 (T_Pattern_vIn56 ) in let !_output = rule155 _patIoutput arg_attr_ arg_field_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule157 _output in let !__result_ = T_Pattern_vOut51 _lhsOcontainsVars _lhsOoutput in __result_ ) v56 :: T_Pattern_v56 v56 = \ !(T_Pattern_vIn56 ) -> ( let !(T_Pattern_vOut56 _patIoutput) = inv_Pattern_s55 _patX55 K_Pattern_v56 (T_Pattern_vIn56 ) in let !_output = rule155 _patIoutput arg_attr_ arg_field_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule157 _output in let !__result_ = T_Pattern_vOut56 _lhsOoutput in __result_ ) in C_Pattern_s55 k55 {-# NOINLINE rule150 #-} {-# LINE 536 "./src-ag/DefaultRules.ag" #-} rule150 = \ ((!_patIdefinedAttrs) :: Set (Identifier,Identifier)) !attr_ !field_ -> {-# LINE 536 "./src-ag/DefaultRules.ag" #-} Set.insert (field_,attr_) _patIdefinedAttrs {-# LINE 2562 "dist/build/DefaultRules.hs"#-} {-# NOINLINE rule151 #-} {-# LINE 537 "./src-ag/DefaultRules.ag" #-} rule151 = \ ((!_patIlocals) :: Set Identifier) !attr_ !field_ -> {-# LINE 537 "./src-ag/DefaultRules.ag" #-} if field_ == _LOC then Set.insert attr_ _patIlocals else _patIlocals {-# LINE 2570 "dist/build/DefaultRules.hs"#-} {-# NOINLINE rule152 #-} {-# LINE 554 "./src-ag/DefaultRules.ag" #-} rule152 = \ (_ :: ()) -> {-# LINE 554 "./src-ag/DefaultRules.ag" #-} True {-# LINE 2576 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule153 #-} rule153 = \ ((!_patIerrors) :: Seq Error) -> _patIerrors {-# NOINLINE[1] rule154 #-} rule154 = \ ((!_patIcopy) :: Pattern) !attr_ !field_ -> Alias field_ attr_ _patIcopy {-# NOINLINE[1] rule155 #-} rule155 = \ ((!_patIoutput) :: Pattern) !attr_ !field_ -> Alias field_ attr_ _patIoutput {-# NOINLINE[1] rule156 #-} rule156 = \ !_copy -> _copy {-# NOINLINE[1] rule157 #-} rule157 = \ !_output -> _output {-# NOINLINE sem_Pattern_Irrefutable #-} sem_Pattern_Irrefutable :: T_Pattern -> T_Pattern sem_Pattern_Irrefutable arg_pat_ = T_Pattern (return st10) where {-# NOINLINE st10 #-} !st10 = let k10 :: K_Pattern_s10 t -> t k10 K_Pattern_v5 = v5 k10 K_Pattern_v22 = v22 k10 K_Pattern_v23 = v23 k10 K_Pattern_v28 = v28 k10 K_Pattern_v42 = v42 k10 K_Pattern_v50 = v50 v5 :: T_Pattern_v5 v5 = \ !(T_Pattern_vIn5 _lhsIcon _lhsInt) -> ( let !_patX10 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) in let !(T_Pattern_vOut23 _patIcontainsVars _patIcopy _patIdefinedAttrs _patIerrors _patIlocals _patIoutput) = inv_Pattern_s10 _patX10 K_Pattern_v23 (T_Pattern_vIn23 ) in let _lhsOcontainsVars :: Bool !_lhsOcontainsVars = rule160 _patIcontainsVars in let !_copy = rule164 _patIcopy in let _lhsOcopy :: Pattern !_lhsOcopy = rule166 _copy in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule161 _patIdefinedAttrs in let _lhsOerrors :: Seq Error !_lhsOerrors = rule162 _patIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule163 _patIlocals in let !_output = rule165 _patIoutput in let _lhsOoutput :: Pattern !_lhsOoutput = rule167 _output in let !__result_ = T_Pattern_vOut5 _lhsOcontainsVars _lhsOcopy _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v22 :: T_Pattern_v22 v22 = \ !(T_Pattern_vIn22 ) -> ( let !_patX10 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) in let !(T_Pattern_vOut22 _patIcopy _patIdefinedAttrs _patIerrors _patIlocals _patIoutput) = inv_Pattern_s10 _patX10 K_Pattern_v22 (T_Pattern_vIn22 ) in let !_copy = rule164 _patIcopy in let _lhsOcopy :: Pattern !_lhsOcopy = rule166 _copy in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule161 _patIdefinedAttrs in let _lhsOerrors :: Seq Error !_lhsOerrors = rule162 _patIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule163 _patIlocals in let !_output = rule165 _patIoutput in let _lhsOoutput :: Pattern !_lhsOoutput = rule167 _output in let !__result_ = T_Pattern_vOut22 _lhsOcopy _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v23 :: T_Pattern_v23 v23 = \ !(T_Pattern_vIn23 ) -> ( let !_patX10 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) in let !(T_Pattern_vOut23 _patIcontainsVars _patIcopy _patIdefinedAttrs _patIerrors _patIlocals _patIoutput) = inv_Pattern_s10 _patX10 K_Pattern_v23 (T_Pattern_vIn23 ) in let _lhsOcontainsVars :: Bool !_lhsOcontainsVars = rule160 _patIcontainsVars in let !_copy = rule164 _patIcopy in let _lhsOcopy :: Pattern !_lhsOcopy = rule166 _copy in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule161 _patIdefinedAttrs in let _lhsOerrors :: Seq Error !_lhsOerrors = rule162 _patIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule163 _patIlocals in let !_output = rule165 _patIoutput in let _lhsOoutput :: Pattern !_lhsOoutput = rule167 _output in let !__result_ = T_Pattern_vOut23 _lhsOcontainsVars _lhsOcopy _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v28 :: T_Pattern_v28 v28 = \ !(T_Pattern_vIn28 ) -> ( let !_patX10 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) in let !(T_Pattern_vOut28 _patIcontainsVars _patIdefinedAttrs _patIerrors _patIlocals _patIoutput) = inv_Pattern_s10 _patX10 K_Pattern_v28 (T_Pattern_vIn28 ) in let _lhsOcontainsVars :: Bool !_lhsOcontainsVars = rule160 _patIcontainsVars in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule161 _patIdefinedAttrs in let _lhsOerrors :: Seq Error !_lhsOerrors = rule162 _patIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule163 _patIlocals in let !_output = rule165 _patIoutput in let _lhsOoutput :: Pattern !_lhsOoutput = rule167 _output in let !__result_ = T_Pattern_vOut28 _lhsOcontainsVars _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v42 :: T_Pattern_v42 v42 = \ !(T_Pattern_vIn42 ) -> ( let !_patX10 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) in let !(T_Pattern_vOut42 _patIdefinedAttrs _patIerrors _patIlocals _patIoutput) = inv_Pattern_s10 _patX10 K_Pattern_v42 (T_Pattern_vIn42 ) in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule161 _patIdefinedAttrs in let _lhsOerrors :: Seq Error !_lhsOerrors = rule162 _patIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule163 _patIlocals in let !_output = rule165 _patIoutput in let _lhsOoutput :: Pattern !_lhsOoutput = rule167 _output in let !__result_ = T_Pattern_vOut42 _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v50 :: T_Pattern_v50 v50 = \ !(T_Pattern_vIn50 ) -> ( let !_patX10 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) in let !(T_Pattern_vOut50 _patIdefinedAttrs _patIerrors _patIlocals _patX55) = inv_Pattern_s10 _patX10 K_Pattern_v50 (T_Pattern_vIn50 ) in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule161 _patIdefinedAttrs in let _lhsOerrors :: Seq Error !_lhsOerrors = rule162 _patIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule163 _patIlocals in let !__st_ = st55 _patX55 !__result_ = T_Pattern_vOut50 _lhsOdefinedAttrs _lhsOerrors _lhsOlocals __st_ in __result_ ) in C_Pattern_s10 k10 {-# NOINLINE st55 #-} st55 = \ !_patX55 -> let k55 :: K_Pattern_s55 t -> t k55 K_Pattern_v51 = v51 k55 K_Pattern_v56 = v56 v51 :: T_Pattern_v51 v51 = \ !(T_Pattern_vIn51 ) -> ( let !(T_Pattern_vOut51 _patIcontainsVars _patIoutput) = inv_Pattern_s55 _patX55 K_Pattern_v51 (T_Pattern_vIn51 ) in let _lhsOcontainsVars :: Bool !_lhsOcontainsVars = rule160 _patIcontainsVars in let !_output = rule165 _patIoutput in let _lhsOoutput :: Pattern !_lhsOoutput = rule167 _output in let !__result_ = T_Pattern_vOut51 _lhsOcontainsVars _lhsOoutput in __result_ ) v56 :: T_Pattern_v56 v56 = \ !(T_Pattern_vIn56 ) -> ( let !(T_Pattern_vOut56 _patIoutput) = inv_Pattern_s55 _patX55 K_Pattern_v56 (T_Pattern_vIn56 ) in let !_output = rule165 _patIoutput in let _lhsOoutput :: Pattern !_lhsOoutput = rule167 _output in let !__result_ = T_Pattern_vOut56 _lhsOoutput in __result_ ) in C_Pattern_s55 k55 {-# NOINLINE[1] rule160 #-} rule160 = \ ((!_patIcontainsVars) :: Bool) -> _patIcontainsVars {-# NOINLINE[1] rule161 #-} rule161 = \ ((!_patIdefinedAttrs) :: Set (Identifier,Identifier)) -> _patIdefinedAttrs {-# NOINLINE[1] rule162 #-} rule162 = \ ((!_patIerrors) :: Seq Error) -> _patIerrors {-# NOINLINE[1] rule163 #-} rule163 = \ ((!_patIlocals) :: Set Identifier) -> _patIlocals {-# NOINLINE[1] rule164 #-} rule164 = \ ((!_patIcopy) :: Pattern) -> Irrefutable _patIcopy {-# NOINLINE[1] rule165 #-} rule165 = \ ((!_patIoutput) :: Pattern) -> Irrefutable _patIoutput {-# NOINLINE[1] rule166 #-} rule166 = \ !_copy -> _copy {-# NOINLINE[1] rule167 #-} rule167 = \ !_output -> _output {-# NOINLINE sem_Pattern_Underscore #-} sem_Pattern_Underscore :: (Pos) -> T_Pattern sem_Pattern_Underscore !arg_pos_ = T_Pattern (return st10) where {-# NOINLINE st10 #-} !st10 = let k10 :: K_Pattern_s10 t -> t k10 K_Pattern_v5 = v5 k10 K_Pattern_v22 = v22 k10 K_Pattern_v23 = v23 k10 K_Pattern_v28 = v28 k10 K_Pattern_v42 = v42 k10 K_Pattern_v50 = v50 v5 :: T_Pattern_v5 v5 = \ !(T_Pattern_vIn5 _lhsIcon _lhsInt) -> ( let _lhsOcontainsVars :: Bool !_lhsOcontainsVars = rule170 () in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule171 () in let _lhsOerrors :: Seq Error !_lhsOerrors = rule172 () in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule173 () in let !_copy = rule174 arg_pos_ in let _lhsOcopy :: Pattern !_lhsOcopy = rule176 _copy in let !_output = rule175 arg_pos_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule177 _output in let !__result_ = T_Pattern_vOut5 _lhsOcontainsVars _lhsOcopy _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v22 :: T_Pattern_v22 v22 = \ !(T_Pattern_vIn22 ) -> ( let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule171 () in let _lhsOerrors :: Seq Error !_lhsOerrors = rule172 () in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule173 () in let !_copy = rule174 arg_pos_ in let _lhsOcopy :: Pattern !_lhsOcopy = rule176 _copy in let !_output = rule175 arg_pos_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule177 _output in let !__result_ = T_Pattern_vOut22 _lhsOcopy _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v23 :: T_Pattern_v23 v23 = \ !(T_Pattern_vIn23 ) -> ( let _lhsOcontainsVars :: Bool !_lhsOcontainsVars = rule170 () in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule171 () in let _lhsOerrors :: Seq Error !_lhsOerrors = rule172 () in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule173 () in let !_copy = rule174 arg_pos_ in let _lhsOcopy :: Pattern !_lhsOcopy = rule176 _copy in let !_output = rule175 arg_pos_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule177 _output in let !__result_ = T_Pattern_vOut23 _lhsOcontainsVars _lhsOcopy _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v28 :: T_Pattern_v28 v28 = \ !(T_Pattern_vIn28 ) -> ( let _lhsOcontainsVars :: Bool !_lhsOcontainsVars = rule170 () in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule171 () in let _lhsOerrors :: Seq Error !_lhsOerrors = rule172 () in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule173 () in let !_output = rule175 arg_pos_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule177 _output in let !__result_ = T_Pattern_vOut28 _lhsOcontainsVars _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v42 :: T_Pattern_v42 v42 = \ !(T_Pattern_vIn42 ) -> ( let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule171 () in let _lhsOerrors :: Seq Error !_lhsOerrors = rule172 () in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule173 () in let !_output = rule175 arg_pos_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule177 _output in let !__result_ = T_Pattern_vOut42 _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v50 :: T_Pattern_v50 v50 = \ !(T_Pattern_vIn50 ) -> ( let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule171 () in let _lhsOerrors :: Seq Error !_lhsOerrors = rule172 () in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule173 () in let !__st_ = st55 () !__result_ = T_Pattern_vOut50 _lhsOdefinedAttrs _lhsOerrors _lhsOlocals __st_ in __result_ ) in C_Pattern_s10 k10 {-# NOINLINE st55 #-} st55 = \ (_ :: ()) -> let k55 :: K_Pattern_s55 t -> t k55 K_Pattern_v51 = v51 k55 K_Pattern_v56 = v56 v51 :: T_Pattern_v51 v51 = \ !(T_Pattern_vIn51 ) -> ( let _lhsOcontainsVars :: Bool !_lhsOcontainsVars = rule170 () in let !_output = rule175 arg_pos_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule177 _output in let !__result_ = T_Pattern_vOut51 _lhsOcontainsVars _lhsOoutput in __result_ ) v56 :: T_Pattern_v56 v56 = \ !(T_Pattern_vIn56 ) -> ( let !_output = rule175 arg_pos_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule177 _output in let !__result_ = T_Pattern_vOut56 _lhsOoutput in __result_ ) in C_Pattern_s55 k55 {-# NOINLINE[1] rule170 #-} rule170 = \ (_ :: ()) -> False {-# NOINLINE[1] rule171 #-} rule171 = \ (_ :: ()) -> Set.empty {-# NOINLINE[1] rule172 #-} rule172 = \ (_ :: ()) -> Seq.empty {-# NOINLINE[1] rule173 #-} rule173 = \ (_ :: ()) -> Set.empty {-# NOINLINE[1] rule174 #-} rule174 = \ !pos_ -> Underscore pos_ {-# NOINLINE[1] rule175 #-} rule175 = \ !pos_ -> Underscore pos_ {-# NOINLINE[1] rule176 #-} rule176 = \ !_copy -> _copy {-# NOINLINE[1] rule177 #-} rule177 = \ !_output -> _output -- Patterns ---------------------------------------------------- -- wrapper data Inh_Patterns = Inh_Patterns { con_Inh_Patterns :: !(ConstructorIdent), nt_Inh_Patterns :: !(NontermIdent) } data Syn_Patterns = Syn_Patterns { containsVars_Syn_Patterns :: !(Bool), copy_Syn_Patterns :: !(Patterns), definedAttrs_Syn_Patterns :: !(Set (Identifier,Identifier)), errors_Syn_Patterns :: !(Seq Error), locals_Syn_Patterns :: !(Set Identifier), output_Syn_Patterns :: !(Patterns) } {-# INLINABLE wrap_Patterns #-} wrap_Patterns :: T_Patterns -> Inh_Patterns -> (Syn_Patterns ) wrap_Patterns !(T_Patterns act) !(Inh_Patterns _lhsIcon _lhsInt) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Patterns_vIn6 _lhsIcon _lhsInt !(T_Patterns_vOut6 _lhsOcontainsVars _lhsOcopy _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput) <- return (inv_Patterns_s12 sem K_Patterns_v6 arg) return (Syn_Patterns _lhsOcontainsVars _lhsOcopy _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput) ) -- cata {-# NOINLINE sem_Patterns #-} sem_Patterns :: Patterns -> T_Patterns sem_Patterns list = Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list) -- semantic domain newtype T_Patterns = T_Patterns { attach_T_Patterns :: Identity (T_Patterns_s12 ) } data T_Patterns_s12 where C_Patterns_s12 :: { inv_Patterns_s12 :: !(forall t. K_Patterns_s12 t -> t) } -> T_Patterns_s12 data T_Patterns_s13 = C_Patterns_s13 data T_Patterns_s34 = C_Patterns_s34 data T_Patterns_s47 = C_Patterns_s47 data T_Patterns_s49 = C_Patterns_s49 data T_Patterns_s54 = C_Patterns_s54 data T_Patterns_s57 where C_Patterns_s57 :: { inv_Patterns_s57 :: !(forall t. K_Patterns_s57 t -> t) } -> T_Patterns_s57 data K_Patterns_s12 k where K_Patterns_v6 :: K_Patterns_s12 (T_Patterns_v6 ) K_Patterns_v21 :: K_Patterns_s12 (T_Patterns_v21 ) K_Patterns_v38 :: K_Patterns_s12 (T_Patterns_v38 ) K_Patterns_v41 :: K_Patterns_s12 (T_Patterns_v41 ) K_Patterns_v49 :: K_Patterns_s12 (T_Patterns_v49 ) K_Patterns_v54 :: K_Patterns_s12 (T_Patterns_v54 ) data K_Patterns_s57 k where K_Patterns_v55 :: K_Patterns_s57 (T_Patterns_v55 ) K_Patterns_v57 :: K_Patterns_s57 (T_Patterns_v57 ) type T_Patterns_v6 = (T_Patterns_vIn6 ) -> (T_Patterns_vOut6 ) data T_Patterns_vIn6 = T_Patterns_vIn6 !(ConstructorIdent) !(NontermIdent) data T_Patterns_vOut6 = T_Patterns_vOut6 !(Bool) !(Patterns) !(Set (Identifier,Identifier)) !(Seq Error) !(Set Identifier) !(Patterns) type T_Patterns_v21 = (T_Patterns_vIn21 ) -> (T_Patterns_vOut21 ) data T_Patterns_vIn21 = T_Patterns_vIn21 data T_Patterns_vOut21 = T_Patterns_vOut21 !(Bool) !(Patterns) !(Set (Identifier,Identifier)) !(Seq Error) !(Set Identifier) !(Patterns) type T_Patterns_v38 = (T_Patterns_vIn38 ) -> (T_Patterns_vOut38 ) data T_Patterns_vIn38 = T_Patterns_vIn38 data T_Patterns_vOut38 = T_Patterns_vOut38 !(Patterns) !(Set (Identifier,Identifier)) !(Seq Error) !(Set Identifier) !(Patterns) type T_Patterns_v41 = (T_Patterns_vIn41 ) -> (T_Patterns_vOut41 ) data T_Patterns_vIn41 = T_Patterns_vIn41 data T_Patterns_vOut41 = T_Patterns_vOut41 !(Bool) !(Set (Identifier,Identifier)) !(Seq Error) !(Set Identifier) !(Patterns) type T_Patterns_v49 = (T_Patterns_vIn49 ) -> (T_Patterns_vOut49 ) data T_Patterns_vIn49 = T_Patterns_vIn49 data T_Patterns_vOut49 = T_Patterns_vOut49 !(Set (Identifier,Identifier)) !(Seq Error) !(Set Identifier) !(Patterns) type T_Patterns_v54 = (T_Patterns_vIn54 ) -> (T_Patterns_vOut54 ) data T_Patterns_vIn54 = T_Patterns_vIn54 data T_Patterns_vOut54 = T_Patterns_vOut54 !(Set (Identifier,Identifier)) !(Seq Error) !(Set Identifier) !(T_Patterns_s57 ) type T_Patterns_v55 = (T_Patterns_vIn55 ) -> (T_Patterns_vOut55 ) data T_Patterns_vIn55 = T_Patterns_vIn55 data T_Patterns_vOut55 = T_Patterns_vOut55 !(Bool) !(Patterns) type T_Patterns_v57 = (T_Patterns_vIn57 ) -> (T_Patterns_vOut57 ) data T_Patterns_vIn57 = T_Patterns_vIn57 data T_Patterns_vOut57 = T_Patterns_vOut57 !(Patterns) {-# NOINLINE sem_Patterns_Cons #-} sem_Patterns_Cons :: T_Pattern -> T_Patterns -> T_Patterns sem_Patterns_Cons arg_hd_ arg_tl_ = T_Patterns (return st12) where {-# NOINLINE st12 #-} !st12 = let k12 :: K_Patterns_s12 t -> t k12 K_Patterns_v6 = v6 k12 K_Patterns_v21 = v21 k12 K_Patterns_v38 = v38 k12 K_Patterns_v41 = v41 k12 K_Patterns_v49 = v49 k12 K_Patterns_v54 = v54 v6 :: T_Patterns_v6 v6 = \ !(T_Patterns_vIn6 _lhsIcon _lhsInt) -> ( let !_hdX10 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_hd_)) in let !_tlX12 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_tl_)) in let !(T_Pattern_vOut23 _hdIcontainsVars _hdIcopy _hdIdefinedAttrs _hdIerrors _hdIlocals _hdIoutput) = inv_Pattern_s10 _hdX10 K_Pattern_v23 (T_Pattern_vIn23 ) in let !(T_Patterns_vOut21 _tlIcontainsVars _tlIcopy _tlIdefinedAttrs _tlIerrors _tlIlocals _tlIoutput) = inv_Patterns_s12 _tlX12 K_Patterns_v21 (T_Patterns_vIn21 ) in let _lhsOcontainsVars :: Bool !_lhsOcontainsVars = rule178 _hdIcontainsVars _tlIcontainsVars in let !_copy = rule182 _hdIcopy _tlIcopy in let _lhsOcopy :: Patterns !_lhsOcopy = rule184 _copy in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule179 _hdIdefinedAttrs _tlIdefinedAttrs in let _lhsOerrors :: Seq Error !_lhsOerrors = rule180 _hdIerrors _tlIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule181 _hdIlocals _tlIlocals in let !_output = rule183 _hdIoutput _tlIoutput in let _lhsOoutput :: Patterns !_lhsOoutput = rule185 _output in let !__result_ = T_Patterns_vOut6 _lhsOcontainsVars _lhsOcopy _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v21 :: T_Patterns_v21 v21 = \ !(T_Patterns_vIn21 ) -> ( let !_hdX10 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_hd_)) in let !_tlX12 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_tl_)) in let !(T_Pattern_vOut23 _hdIcontainsVars _hdIcopy _hdIdefinedAttrs _hdIerrors _hdIlocals _hdIoutput) = inv_Pattern_s10 _hdX10 K_Pattern_v23 (T_Pattern_vIn23 ) in let !(T_Patterns_vOut21 _tlIcontainsVars _tlIcopy _tlIdefinedAttrs _tlIerrors _tlIlocals _tlIoutput) = inv_Patterns_s12 _tlX12 K_Patterns_v21 (T_Patterns_vIn21 ) in let _lhsOcontainsVars :: Bool !_lhsOcontainsVars = rule178 _hdIcontainsVars _tlIcontainsVars in let !_copy = rule182 _hdIcopy _tlIcopy in let _lhsOcopy :: Patterns !_lhsOcopy = rule184 _copy in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule179 _hdIdefinedAttrs _tlIdefinedAttrs in let _lhsOerrors :: Seq Error !_lhsOerrors = rule180 _hdIerrors _tlIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule181 _hdIlocals _tlIlocals in let !_output = rule183 _hdIoutput _tlIoutput in let _lhsOoutput :: Patterns !_lhsOoutput = rule185 _output in let !__result_ = T_Patterns_vOut21 _lhsOcontainsVars _lhsOcopy _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v38 :: T_Patterns_v38 v38 = \ !(T_Patterns_vIn38 ) -> ( let !_hdX10 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_hd_)) in let !_tlX12 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_tl_)) in let !(T_Pattern_vOut22 _hdIcopy _hdIdefinedAttrs _hdIerrors _hdIlocals _hdIoutput) = inv_Pattern_s10 _hdX10 K_Pattern_v22 (T_Pattern_vIn22 ) in let !(T_Patterns_vOut38 _tlIcopy _tlIdefinedAttrs _tlIerrors _tlIlocals _tlIoutput) = inv_Patterns_s12 _tlX12 K_Patterns_v38 (T_Patterns_vIn38 ) in let !_copy = rule182 _hdIcopy _tlIcopy in let _lhsOcopy :: Patterns !_lhsOcopy = rule184 _copy in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule179 _hdIdefinedAttrs _tlIdefinedAttrs in let _lhsOerrors :: Seq Error !_lhsOerrors = rule180 _hdIerrors _tlIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule181 _hdIlocals _tlIlocals in let !_output = rule183 _hdIoutput _tlIoutput in let _lhsOoutput :: Patterns !_lhsOoutput = rule185 _output in let !__result_ = T_Patterns_vOut38 _lhsOcopy _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v41 :: T_Patterns_v41 v41 = \ !(T_Patterns_vIn41 ) -> ( let !_hdX10 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_hd_)) in let !_tlX12 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_tl_)) in let !(T_Pattern_vOut28 _hdIcontainsVars _hdIdefinedAttrs _hdIerrors _hdIlocals _hdIoutput) = inv_Pattern_s10 _hdX10 K_Pattern_v28 (T_Pattern_vIn28 ) in let !(T_Patterns_vOut41 _tlIcontainsVars _tlIdefinedAttrs _tlIerrors _tlIlocals _tlIoutput) = inv_Patterns_s12 _tlX12 K_Patterns_v41 (T_Patterns_vIn41 ) in let _lhsOcontainsVars :: Bool !_lhsOcontainsVars = rule178 _hdIcontainsVars _tlIcontainsVars in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule179 _hdIdefinedAttrs _tlIdefinedAttrs in let _lhsOerrors :: Seq Error !_lhsOerrors = rule180 _hdIerrors _tlIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule181 _hdIlocals _tlIlocals in let !_output = rule183 _hdIoutput _tlIoutput in let _lhsOoutput :: Patterns !_lhsOoutput = rule185 _output in let !__result_ = T_Patterns_vOut41 _lhsOcontainsVars _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v49 :: T_Patterns_v49 v49 = \ !(T_Patterns_vIn49 ) -> ( let !_hdX10 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_hd_)) in let !_tlX12 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_tl_)) in let !(T_Pattern_vOut42 _hdIdefinedAttrs _hdIerrors _hdIlocals _hdIoutput) = inv_Pattern_s10 _hdX10 K_Pattern_v42 (T_Pattern_vIn42 ) in let !(T_Patterns_vOut49 _tlIdefinedAttrs _tlIerrors _tlIlocals _tlIoutput) = inv_Patterns_s12 _tlX12 K_Patterns_v49 (T_Patterns_vIn49 ) in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule179 _hdIdefinedAttrs _tlIdefinedAttrs in let _lhsOerrors :: Seq Error !_lhsOerrors = rule180 _hdIerrors _tlIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule181 _hdIlocals _tlIlocals in let !_output = rule183 _hdIoutput _tlIoutput in let _lhsOoutput :: Patterns !_lhsOoutput = rule185 _output in let !__result_ = T_Patterns_vOut49 _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v54 :: T_Patterns_v54 v54 = \ !(T_Patterns_vIn54 ) -> ( let !_hdX10 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_hd_)) in let !_tlX12 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_tl_)) in let !(T_Pattern_vOut50 _hdIdefinedAttrs _hdIerrors _hdIlocals _hdX55) = inv_Pattern_s10 _hdX10 K_Pattern_v50 (T_Pattern_vIn50 ) in let !(T_Patterns_vOut54 _tlIdefinedAttrs _tlIerrors _tlIlocals _tlX57) = inv_Patterns_s12 _tlX12 K_Patterns_v54 (T_Patterns_vIn54 ) in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule179 _hdIdefinedAttrs _tlIdefinedAttrs in let _lhsOerrors :: Seq Error !_lhsOerrors = rule180 _hdIerrors _tlIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule181 _hdIlocals _tlIlocals in let !__st_ = st57 _hdX55 _tlX57 !__result_ = T_Patterns_vOut54 _lhsOdefinedAttrs _lhsOerrors _lhsOlocals __st_ in __result_ ) in C_Patterns_s12 k12 {-# NOINLINE st57 #-} st57 = \ !_hdX55 !_tlX57 -> let k57 :: K_Patterns_s57 t -> t k57 K_Patterns_v55 = v55 k57 K_Patterns_v57 = v57 v55 :: T_Patterns_v55 v55 = \ !(T_Patterns_vIn55 ) -> ( let !(T_Pattern_vOut51 _hdIcontainsVars _hdIoutput) = inv_Pattern_s55 _hdX55 K_Pattern_v51 (T_Pattern_vIn51 ) in let !(T_Patterns_vOut55 _tlIcontainsVars _tlIoutput) = inv_Patterns_s57 _tlX57 K_Patterns_v55 (T_Patterns_vIn55 ) in let _lhsOcontainsVars :: Bool !_lhsOcontainsVars = rule178 _hdIcontainsVars _tlIcontainsVars in let !_output = rule183 _hdIoutput _tlIoutput in let _lhsOoutput :: Patterns !_lhsOoutput = rule185 _output in let !__result_ = T_Patterns_vOut55 _lhsOcontainsVars _lhsOoutput in __result_ ) v57 :: T_Patterns_v57 v57 = \ !(T_Patterns_vIn57 ) -> ( let !(T_Pattern_vOut56 _hdIoutput) = inv_Pattern_s55 _hdX55 K_Pattern_v56 (T_Pattern_vIn56 ) in let !(T_Patterns_vOut57 _tlIoutput) = inv_Patterns_s57 _tlX57 K_Patterns_v57 (T_Patterns_vIn57 ) in let !_output = rule183 _hdIoutput _tlIoutput in let _lhsOoutput :: Patterns !_lhsOoutput = rule185 _output in let !__result_ = T_Patterns_vOut57 _lhsOoutput in __result_ ) in C_Patterns_s57 k57 {-# NOINLINE[1] rule178 #-} rule178 = \ ((!_hdIcontainsVars) :: Bool) ((!_tlIcontainsVars) :: Bool) -> _hdIcontainsVars || _tlIcontainsVars {-# NOINLINE[1] rule179 #-} rule179 = \ ((!_hdIdefinedAttrs) :: Set (Identifier,Identifier)) ((!_tlIdefinedAttrs) :: Set (Identifier,Identifier)) -> _hdIdefinedAttrs `Set.union` _tlIdefinedAttrs {-# NOINLINE[1] rule180 #-} rule180 = \ ((!_hdIerrors) :: Seq Error) ((!_tlIerrors) :: Seq Error) -> _hdIerrors Seq.>< _tlIerrors {-# NOINLINE[1] rule181 #-} rule181 = \ ((!_hdIlocals) :: Set Identifier) ((!_tlIlocals) :: Set Identifier) -> _hdIlocals `Set.union` _tlIlocals {-# NOINLINE[1] rule182 #-} rule182 = \ ((!_hdIcopy) :: Pattern) ((!_tlIcopy) :: Patterns) -> (:) _hdIcopy _tlIcopy {-# NOINLINE[1] rule183 #-} rule183 = \ ((!_hdIoutput) :: Pattern) ((!_tlIoutput) :: Patterns) -> (:) _hdIoutput _tlIoutput {-# NOINLINE[1] rule184 #-} rule184 = \ !_copy -> _copy {-# NOINLINE[1] rule185 #-} rule185 = \ !_output -> _output {-# NOINLINE sem_Patterns_Nil #-} sem_Patterns_Nil :: T_Patterns sem_Patterns_Nil = T_Patterns (return st12) where {-# NOINLINE st12 #-} !st12 = let k12 :: K_Patterns_s12 t -> t k12 K_Patterns_v6 = v6 k12 K_Patterns_v21 = v21 k12 K_Patterns_v38 = v38 k12 K_Patterns_v41 = v41 k12 K_Patterns_v49 = v49 k12 K_Patterns_v54 = v54 v6 :: T_Patterns_v6 v6 = \ !(T_Patterns_vIn6 _lhsIcon _lhsInt) -> ( let _lhsOcontainsVars :: Bool !_lhsOcontainsVars = rule190 () in let !_copy = rule194 () in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule191 () in let _lhsOerrors :: Seq Error !_lhsOerrors = rule192 () in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule193 () in let !_output = rule195 () in let _lhsOcopy :: Patterns !_lhsOcopy = rule196 _copy in let _lhsOoutput :: Patterns !_lhsOoutput = rule197 _output in let !__result_ = T_Patterns_vOut6 _lhsOcontainsVars _lhsOcopy _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v21 :: T_Patterns_v21 v21 = \ !(T_Patterns_vIn21 ) -> ( let _lhsOcontainsVars :: Bool !_lhsOcontainsVars = rule190 () in let !_copy = rule194 () in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule191 () in let _lhsOerrors :: Seq Error !_lhsOerrors = rule192 () in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule193 () in let !_output = rule195 () in let _lhsOcopy :: Patterns !_lhsOcopy = rule196 _copy in let _lhsOoutput :: Patterns !_lhsOoutput = rule197 _output in let !__result_ = T_Patterns_vOut21 _lhsOcontainsVars _lhsOcopy _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v38 :: T_Patterns_v38 v38 = \ !(T_Patterns_vIn38 ) -> ( let !_copy = rule194 () in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule191 () in let _lhsOerrors :: Seq Error !_lhsOerrors = rule192 () in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule193 () in let !_output = rule195 () in let _lhsOcopy :: Patterns !_lhsOcopy = rule196 _copy in let _lhsOoutput :: Patterns !_lhsOoutput = rule197 _output in let !__result_ = T_Patterns_vOut38 _lhsOcopy _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v41 :: T_Patterns_v41 v41 = \ !(T_Patterns_vIn41 ) -> ( let _lhsOcontainsVars :: Bool !_lhsOcontainsVars = rule190 () in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule191 () in let _lhsOerrors :: Seq Error !_lhsOerrors = rule192 () in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule193 () in let !_output = rule195 () in let _lhsOoutput :: Patterns !_lhsOoutput = rule197 _output in let !__result_ = T_Patterns_vOut41 _lhsOcontainsVars _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v49 :: T_Patterns_v49 v49 = \ !(T_Patterns_vIn49 ) -> ( let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule191 () in let _lhsOerrors :: Seq Error !_lhsOerrors = rule192 () in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule193 () in let !_output = rule195 () in let _lhsOoutput :: Patterns !_lhsOoutput = rule197 _output in let !__result_ = T_Patterns_vOut49 _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput in __result_ ) v54 :: T_Patterns_v54 v54 = \ !(T_Patterns_vIn54 ) -> ( let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule191 () in let _lhsOerrors :: Seq Error !_lhsOerrors = rule192 () in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule193 () in let !__st_ = st57 () !__result_ = T_Patterns_vOut54 _lhsOdefinedAttrs _lhsOerrors _lhsOlocals __st_ in __result_ ) in C_Patterns_s12 k12 {-# NOINLINE st57 #-} st57 = \ (_ :: ()) -> let k57 :: K_Patterns_s57 t -> t k57 K_Patterns_v55 = v55 k57 K_Patterns_v57 = v57 v55 :: T_Patterns_v55 v55 = \ !(T_Patterns_vIn55 ) -> ( let _lhsOcontainsVars :: Bool !_lhsOcontainsVars = rule190 () in let !_output = rule195 () in let _lhsOoutput :: Patterns !_lhsOoutput = rule197 _output in let !__result_ = T_Patterns_vOut55 _lhsOcontainsVars _lhsOoutput in __result_ ) v57 :: T_Patterns_v57 v57 = \ !(T_Patterns_vIn57 ) -> ( let !_output = rule195 () in let _lhsOoutput :: Patterns !_lhsOoutput = rule197 _output in let !__result_ = T_Patterns_vOut57 _lhsOoutput in __result_ ) in C_Patterns_s57 k57 {-# NOINLINE[1] rule190 #-} rule190 = \ (_ :: ()) -> False {-# NOINLINE[1] rule191 #-} rule191 = \ (_ :: ()) -> Set.empty {-# NOINLINE[1] rule192 #-} rule192 = \ (_ :: ()) -> Seq.empty {-# NOINLINE[1] rule193 #-} rule193 = \ (_ :: ()) -> Set.empty {-# NOINLINE[1] rule194 #-} rule194 = \ (_ :: ()) -> [] {-# NOINLINE[1] rule195 #-} rule195 = \ (_ :: ()) -> [] {-# NOINLINE[1] rule196 #-} rule196 = \ !_copy -> _copy {-# NOINLINE[1] rule197 #-} rule197 = \ !_output -> _output -- Production -------------------------------------------------- -- wrapper data Inh_Production = Inh_Production { aroundsIn_Inh_Production :: !(Map ConstructorIdent (Map Identifier [Expression])), augmentsIn_Inh_Production :: !(Map ConstructorIdent (Map Identifier [Expression])), cr_Inh_Production :: !(Bool), inh_Inh_Production :: !(Attributes), inhMap_Inh_Production :: !(Map Identifier Attributes), inhOrig_Inh_Production :: !(Attributes), manualAttrOrderMap_Inh_Production :: !(AttrOrderMap), mergesIn_Inh_Production :: !(Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression))), nonterminals_Inh_Production :: !(Set NontermIdent), nt_Inh_Production :: !(NontermIdent), o_rename_Inh_Production :: !(Bool), options_Inh_Production :: !(Options), params_Inh_Production :: !([Identifier]), syn_Inh_Production :: !(Attributes), synMap_Inh_Production :: !(Map Identifier Attributes), synOrig_Inh_Production :: !(Attributes), typeSyns_Inh_Production :: !(TypeSyns), uniq_Inh_Production :: !(Int), useMap_Inh_Production :: !(Map Identifier (String,String,String)), wrappers_Inh_Production :: !(Set NontermIdent) } data Syn_Production = Syn_Production { errors_Syn_Production :: !(Seq Error), output_Syn_Production :: !(Production), uniq_Syn_Production :: !(Int) } {-# INLINABLE wrap_Production #-} wrap_Production :: T_Production -> Inh_Production -> (Syn_Production ) wrap_Production !(T_Production act) !(Inh_Production _lhsIaroundsIn _lhsIaugmentsIn _lhsIcr _lhsIinh _lhsIinhMap _lhsIinhOrig _lhsImanualAttrOrderMap _lhsImergesIn _lhsInonterminals _lhsInt _lhsIo_rename _lhsIoptions _lhsIparams _lhsIsyn _lhsIsynMap _lhsIsynOrig _lhsItypeSyns _lhsIuniq _lhsIuseMap _lhsIwrappers) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Production_vIn7 _lhsIaroundsIn _lhsIaugmentsIn _lhsIcr _lhsIinh _lhsIinhMap _lhsIinhOrig _lhsImanualAttrOrderMap _lhsImergesIn _lhsInonterminals _lhsInt _lhsIo_rename _lhsIoptions _lhsIparams _lhsIsyn _lhsIsynMap _lhsIsynOrig _lhsItypeSyns _lhsIuniq _lhsIuseMap _lhsIwrappers !(T_Production_vOut7 _lhsOerrors _lhsOoutput _lhsOuniq) <- return (inv_Production_s14 sem K_Production_v7 arg) return (Syn_Production _lhsOerrors _lhsOoutput _lhsOuniq) ) -- cata {-# INLINE sem_Production #-} sem_Production :: Production -> T_Production sem_Production ( Production !con_ !params_ !constraints_ children_ rules_ typeSigs_ !macro_ ) = sem_Production_Production con_ params_ constraints_ ( sem_Children children_ ) ( sem_Rules rules_ ) ( sem_TypeSigs typeSigs_ ) macro_ -- semantic domain newtype T_Production = T_Production { attach_T_Production :: Identity (T_Production_s14 ) } data T_Production_s14 where C_Production_s14 :: { inv_Production_s14 :: !(forall t. K_Production_s14 t -> t) } -> T_Production_s14 data T_Production_s15 = C_Production_s15 data T_Production_s38 = C_Production_s38 newtype T_Production_s48 = C_Production_s48 { inv_Production_s48 :: (T_Production_v40 ) } data K_Production_s14 k where K_Production_v7 :: K_Production_s14 (T_Production_v7 ) K_Production_v25 :: K_Production_s14 (T_Production_v25 ) K_Production_v39 :: K_Production_s14 (T_Production_v39 ) type T_Production_v7 = (T_Production_vIn7 ) -> (T_Production_vOut7 ) data T_Production_vIn7 = T_Production_vIn7 !(Map ConstructorIdent (Map Identifier [Expression])) !(Map ConstructorIdent (Map Identifier [Expression])) !(Bool) !(Attributes) !(Map Identifier Attributes) !(Attributes) !(AttrOrderMap) !(Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression))) !(Set NontermIdent) !(NontermIdent) !(Bool) !(Options) !([Identifier]) !(Attributes) !(Map Identifier Attributes) !(Attributes) !(TypeSyns) !(Int) !(Map Identifier (String,String,String)) !(Set NontermIdent) data T_Production_vOut7 = T_Production_vOut7 !(Seq Error) !(Production) !(Int) type T_Production_v25 = (T_Production_vIn25 ) -> (T_Production_vOut25 ) data T_Production_vIn25 = T_Production_vIn25 !(Map ConstructorIdent (Map Identifier [Expression])) !(Map ConstructorIdent (Map Identifier [Expression])) !(Bool) !(Attributes) !(Map Identifier Attributes) !(AttrOrderMap) !(Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression))) !(NontermIdent) !(Bool) !(Options) !([Identifier]) !(Attributes) !(Map Identifier Attributes) !(Attributes) !(TypeSyns) !(Int) !(Map Identifier (String,String,String)) !(Set NontermIdent) data T_Production_vOut25 = T_Production_vOut25 !(Seq Error) !(Production) !(Int) type T_Production_v39 = (T_Production_vIn39 ) -> (T_Production_vOut39 ) data T_Production_vIn39 = T_Production_vIn39 !(Bool) !(Attributes) !(Map Identifier Attributes) !(AttrOrderMap) !(Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression))) !(NontermIdent) !(Bool) !(Options) !(Attributes) !(Map Identifier Attributes) !(Attributes) !(TypeSyns) !(Map Identifier (String,String,String)) !(Set NontermIdent) data T_Production_vOut39 = T_Production_vOut39 !(Seq Error) !(T_Production_s48 ) type T_Production_v40 = (T_Production_vIn40 ) -> (T_Production_vOut40 ) data T_Production_vIn40 = T_Production_vIn40 !(Map ConstructorIdent (Map Identifier [Expression])) !(Map ConstructorIdent (Map Identifier [Expression])) !([Identifier]) !(Int) data T_Production_vOut40 = T_Production_vOut40 !(Production) !(Int) {-# NOINLINE sem_Production_Production #-} sem_Production_Production :: (ConstructorIdent) -> ([Identifier]) -> ([Type]) -> T_Children -> T_Rules -> T_TypeSigs -> (MaybeMacro) -> T_Production sem_Production_Production !arg_con_ !arg_params_ !arg_constraints_ arg_children_ arg_rules_ arg_typeSigs_ !arg_macro_ = T_Production (return st14) where {-# NOINLINE st14 #-} !st14 = let k14 :: K_Production_s14 t -> t k14 K_Production_v7 = v7 k14 K_Production_v25 = v25 k14 K_Production_v39 = v39 v7 :: T_Production_v7 v7 = \ !(T_Production_vIn7 _lhsIaroundsIn _lhsIaugmentsIn _lhsIcr _lhsIinh _lhsIinhMap _lhsIinhOrig _lhsImanualAttrOrderMap _lhsImergesIn _lhsInonterminals _lhsInt _lhsIo_rename _lhsIoptions _lhsIparams _lhsIsyn _lhsIsynMap _lhsIsynOrig _lhsItypeSyns _lhsIuniq _lhsIuseMap _lhsIwrappers) -> ( let !_childrenX2 = Control.Monad.Identity.runIdentity (attach_T_Children (arg_children_)) in let !_rulesX20 = Control.Monad.Identity.runIdentity (attach_T_Rules (arg_rules_)) in let !_typeSigsX24 = Control.Monad.Identity.runIdentity (attach_T_TypeSigs (arg_typeSigs_)) in let !_childrenOinhMap = rule215 _lhsIinhMap in let !_mergesIn = rule210 _lhsImergesIn arg_con_ in let !_merged = rule211 _mergesIn in let !_childrenOmerged = rule216 _merged in let !_childrenOsynMap = rule219 _lhsIsynMap in let !_orderDeps = rule206 _lhsImanualAttrOrderMap _lhsInt arg_con_ in let !_typeSigsOnt = rule223 _lhsInt in let !_typeSigsOparams = rule224 _lhsIparams in let !_aroundsIn = rule209 _lhsIaroundsIn arg_con_ in let !_rulesOoptions = rule221 _lhsIoptions in let !_rulesOuniq = rule222 _lhsIuniq in let !_augmentsIn = rule208 _lhsIaugmentsIn arg_con_ in let !(T_Children_vOut14 _childrenIerrors _childrenIfields _childrenIinputs _childrenIoutput _childrenIoutputs) = inv_Children_s2 _childrenX2 K_Children_v14 (T_Children_vIn14 _childrenOinhMap _childrenOmerged _childrenOsynMap) in let !(T_Rules_vOut24 _rulesIdefinedAttrs _rulesIerrors _rulesIlocals _rulesIoutput _rulesIruleNames _rulesIuniq) = inv_Rules_s20 _rulesX20 K_Rules_v24 (T_Rules_vIn24 _rulesOoptions _rulesOuniq) in let !(T_TypeSigs_vOut12 _typeSigsIoutput) = inv_TypeSigs_s24 _typeSigsX24 (T_TypeSigs_vIn12 _typeSigsOnt _typeSigsOparams) in let !(!_newRls,!_errs) = rule201 _childrenIfields _childrenIinputs _childrenIoutputs _lhsIcr _lhsIinh _lhsInt _lhsIo_rename _lhsIoptions _lhsIsyn _lhsIsynOrig _lhsItypeSyns _lhsIuseMap _lhsIwrappers _rulesIdefinedAttrs _rulesIlocals arg_con_ in let !_orderErrs = rule207 _childrenIinputs _childrenIoutputs _lhsIinh _lhsInt _lhsIsyn _orderDeps _rulesIlocals _rulesIruleNames arg_con_ in let _lhsOerrors :: Seq Error !_lhsOerrors = rule200 _childrenIerrors _errs _orderErrs _rulesIerrors in let !_extra1 = rule202 _augmentsIn _newRls _rulesIoutput in let !_extra2 = rule203 _aroundsIn _extra1 in let !_extra3 = rule204 _extra2 _mergesIn in let _lhsOoutput :: Production !_lhsOoutput = rule205 _childrenIoutput _extra3 _typeSigsIoutput arg_con_ arg_constraints_ arg_macro_ arg_params_ in let _lhsOuniq :: Int !_lhsOuniq = rule213 _rulesIuniq in let !__result_ = T_Production_vOut7 _lhsOerrors _lhsOoutput _lhsOuniq in __result_ ) v25 :: T_Production_v25 v25 = \ !(T_Production_vIn25 _lhsIaroundsIn _lhsIaugmentsIn _lhsIcr _lhsIinh _lhsIinhMap _lhsImanualAttrOrderMap _lhsImergesIn _lhsInt _lhsIo_rename _lhsIoptions _lhsIparams _lhsIsyn _lhsIsynMap _lhsIsynOrig _lhsItypeSyns _lhsIuniq _lhsIuseMap _lhsIwrappers) -> ( let !_childrenX2 = Control.Monad.Identity.runIdentity (attach_T_Children (arg_children_)) in let !_rulesX20 = Control.Monad.Identity.runIdentity (attach_T_Rules (arg_rules_)) in let !_typeSigsX24 = Control.Monad.Identity.runIdentity (attach_T_TypeSigs (arg_typeSigs_)) in let !_childrenOinhMap = rule215 _lhsIinhMap in let !_mergesIn = rule210 _lhsImergesIn arg_con_ in let !_merged = rule211 _mergesIn in let !_childrenOmerged = rule216 _merged in let !_childrenOsynMap = rule219 _lhsIsynMap in let !_orderDeps = rule206 _lhsImanualAttrOrderMap _lhsInt arg_con_ in let !_typeSigsOnt = rule223 _lhsInt in let !_typeSigsOparams = rule224 _lhsIparams in let !_aroundsIn = rule209 _lhsIaroundsIn arg_con_ in let !_rulesOoptions = rule221 _lhsIoptions in let !_rulesOuniq = rule222 _lhsIuniq in let !_augmentsIn = rule208 _lhsIaugmentsIn arg_con_ in let !(T_Children_vOut14 _childrenIerrors _childrenIfields _childrenIinputs _childrenIoutput _childrenIoutputs) = inv_Children_s2 _childrenX2 K_Children_v14 (T_Children_vIn14 _childrenOinhMap _childrenOmerged _childrenOsynMap) in let !(T_Rules_vOut24 _rulesIdefinedAttrs _rulesIerrors _rulesIlocals _rulesIoutput _rulesIruleNames _rulesIuniq) = inv_Rules_s20 _rulesX20 K_Rules_v24 (T_Rules_vIn24 _rulesOoptions _rulesOuniq) in let !(T_TypeSigs_vOut12 _typeSigsIoutput) = inv_TypeSigs_s24 _typeSigsX24 (T_TypeSigs_vIn12 _typeSigsOnt _typeSigsOparams) in let !(!_newRls,!_errs) = rule201 _childrenIfields _childrenIinputs _childrenIoutputs _lhsIcr _lhsIinh _lhsInt _lhsIo_rename _lhsIoptions _lhsIsyn _lhsIsynOrig _lhsItypeSyns _lhsIuseMap _lhsIwrappers _rulesIdefinedAttrs _rulesIlocals arg_con_ in let !_orderErrs = rule207 _childrenIinputs _childrenIoutputs _lhsIinh _lhsInt _lhsIsyn _orderDeps _rulesIlocals _rulesIruleNames arg_con_ in let _lhsOerrors :: Seq Error !_lhsOerrors = rule200 _childrenIerrors _errs _orderErrs _rulesIerrors in let !_extra1 = rule202 _augmentsIn _newRls _rulesIoutput in let !_extra2 = rule203 _aroundsIn _extra1 in let !_extra3 = rule204 _extra2 _mergesIn in let _lhsOoutput :: Production !_lhsOoutput = rule205 _childrenIoutput _extra3 _typeSigsIoutput arg_con_ arg_constraints_ arg_macro_ arg_params_ in let _lhsOuniq :: Int !_lhsOuniq = rule213 _rulesIuniq in let !__result_ = T_Production_vOut25 _lhsOerrors _lhsOoutput _lhsOuniq in __result_ ) v39 :: T_Production_v39 v39 = \ !(T_Production_vIn39 _lhsIcr _lhsIinh _lhsIinhMap _lhsImanualAttrOrderMap _lhsImergesIn _lhsInt _lhsIo_rename _lhsIoptions _lhsIsyn _lhsIsynMap _lhsIsynOrig _lhsItypeSyns _lhsIuseMap _lhsIwrappers) -> ( let !_childrenX2 = Control.Monad.Identity.runIdentity (attach_T_Children (arg_children_)) in let !_rulesX20 = Control.Monad.Identity.runIdentity (attach_T_Rules (arg_rules_)) in let !_childrenOinhMap = rule215 _lhsIinhMap in let !_mergesIn = rule210 _lhsImergesIn arg_con_ in let !_merged = rule211 _mergesIn in let !_childrenOmerged = rule216 _merged in let !_childrenOsynMap = rule219 _lhsIsynMap in let !_orderDeps = rule206 _lhsImanualAttrOrderMap _lhsInt arg_con_ in let !(T_Children_vOut47 _childrenIerrors _childrenIfields _childrenIinputs _childrenIoutputs _childrenX53) = inv_Children_s2 _childrenX2 K_Children_v47 (T_Children_vIn47 _childrenOinhMap _childrenOmerged _childrenOsynMap) in let !(T_Rules_vOut30 _rulesIdefinedAttrs _rulesIerrors _rulesIlocals _rulesIruleNames _rulesX42) = inv_Rules_s20 _rulesX20 K_Rules_v30 (T_Rules_vIn30 ) in let !(!_newRls,!_errs) = rule201 _childrenIfields _childrenIinputs _childrenIoutputs _lhsIcr _lhsIinh _lhsInt _lhsIo_rename _lhsIoptions _lhsIsyn _lhsIsynOrig _lhsItypeSyns _lhsIuseMap _lhsIwrappers _rulesIdefinedAttrs _rulesIlocals arg_con_ in let !_orderErrs = rule207 _childrenIinputs _childrenIoutputs _lhsIinh _lhsInt _lhsIsyn _orderDeps _rulesIlocals _rulesIruleNames arg_con_ in let _lhsOerrors :: Seq Error !_lhsOerrors = rule200 _childrenIerrors _errs _orderErrs _rulesIerrors in let !__st_ = st48 _childrenX53 _lhsInt _lhsIoptions _mergesIn _newRls _rulesX42 !__result_ = T_Production_vOut39 _lhsOerrors __st_ in __result_ ) in C_Production_s14 k14 {-# NOINLINE st48 #-} st48 = \ !_childrenX53 ((!_lhsInt) :: NontermIdent) ((!_lhsIoptions) :: Options) !_mergesIn !_newRls !_rulesX42 -> let v40 :: T_Production_v40 v40 = \ !(T_Production_vIn40 _lhsIaroundsIn _lhsIaugmentsIn _lhsIparams _lhsIuniq) -> ( let !_typeSigsOnt = rule223 _lhsInt in let !_typeSigsX24 = Control.Monad.Identity.runIdentity (attach_T_TypeSigs (arg_typeSigs_)) in let !_rulesOoptions = rule221 _lhsIoptions in let !_typeSigsOparams = rule224 _lhsIparams in let !_aroundsIn = rule209 _lhsIaroundsIn arg_con_ in let !_rulesOuniq = rule222 _lhsIuniq in let !_augmentsIn = rule208 _lhsIaugmentsIn arg_con_ in let !(T_Children_vOut48 _childrenIoutput) = inv_Children_s53 _childrenX53 (T_Children_vIn48 ) in let !(T_Rules_vOut31 _rulesIoutput _rulesIuniq) = inv_Rules_s42 _rulesX42 (T_Rules_vIn31 _rulesOoptions _rulesOuniq) in let !(T_TypeSigs_vOut12 _typeSigsIoutput) = inv_TypeSigs_s24 _typeSigsX24 (T_TypeSigs_vIn12 _typeSigsOnt _typeSigsOparams) in let !_extra1 = rule202 _augmentsIn _newRls _rulesIoutput in let !_extra2 = rule203 _aroundsIn _extra1 in let !_extra3 = rule204 _extra2 _mergesIn in let _lhsOoutput :: Production !_lhsOoutput = rule205 _childrenIoutput _extra3 _typeSigsIoutput arg_con_ arg_constraints_ arg_macro_ arg_params_ in let _lhsOuniq :: Int !_lhsOuniq = rule213 _rulesIuniq in let !__result_ = T_Production_vOut40 _lhsOoutput _lhsOuniq in __result_ ) in C_Production_s48 v40 {-# NOINLINE[1] rule200 #-} {-# LINE 384 "./src-ag/DefaultRules.ag" #-} rule200 = \ ((!_childrenIerrors) :: Seq Error) !_errs !_orderErrs ((!_rulesIerrors) :: Seq Error) -> {-# LINE 384 "./src-ag/DefaultRules.ag" #-} _childrenIerrors >< _errs >< _rulesIerrors >< _orderErrs {-# LINE 3475 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule201 #-} {-# LINE 388 "./src-ag/DefaultRules.ag" #-} rule201 = \ ((!_childrenIfields) :: [(Identifier,Type,ChildKind)]) ((!_childrenIinputs) :: [(Identifier, Attributes)]) ((!_childrenIoutputs) :: [(Identifier, Attributes)]) ((!_lhsIcr) :: Bool) ((!_lhsIinh) :: Attributes) ((!_lhsInt) :: NontermIdent) ((!_lhsIo_rename) :: Bool) ((!_lhsIoptions) :: Options) ((!_lhsIsyn) :: Attributes) ((!_lhsIsynOrig) :: Attributes) ((!_lhsItypeSyns) :: TypeSyns) ((!_lhsIuseMap) :: Map Identifier (String,String,String)) ((!_lhsIwrappers) :: Set NontermIdent) ((!_rulesIdefinedAttrs) :: Set (Identifier,Identifier)) ((!_rulesIlocals) :: Set Identifier) !con_ -> {-# LINE 388 "./src-ag/DefaultRules.ag" #-} let locals = _rulesIlocals initenv = Map.fromList ( [ (a,_ACHILD) | (a,_,_) <- _childrenIfields ] ++ attrs(_LHS, _lhsIinh) ++ [ (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 ) _childrenIoutputs) child_envs = init envs lhs_env = last envs (selfAttrs, normalAttrs) = Map.partitionWithKey (\k _ -> maybe False isSELFNonterminal $ Map.lookup k _lhsIsynOrig) _lhsIsyn (_,undefAttrs) = removeDefined _rulesIdefinedAttrs (_LHS, normalAttrs) (useAttrs,others) = splitAttrs _lhsIuseMap undefAttrs (rules1, errors1) = concatRE $ map (copyRule _lhsIoptions _lhsIwrappers _lhsInt con_ _lhsIcr locals) (zip envs (map (removeDefined _rulesIdefinedAttrs) _childrenIinputs)) uRules = map (useRule locals _childrenIoutputs) useAttrs selfLocRules = [ selfRule False attr $ lexTokens noPos $ constructor [childSelf attr nm tp | (nm,tp,virt) <- _childrenIfields, 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 _lhsIoptions) _lhsItypeSyns _lhsIo_rename _lhsInt con_ fs childExists ChildAttr = False childExists _ = True selfRules = [ selfRule True attr [mkLocVar attr noPos Nothing] | attr <- Map.keys selfAttrs , not (Set.member (_LHS,attr) _rulesIdefinedAttrs) ] (rules5, errs5) = copyRule _lhsIoptions _lhsIwrappers _lhsInt con_ _lhsIcr locals (lhs_env, (_LHS, others)) in (uRules++selfLocRules++selfRules++rules5++rules1, errors1> {-# LINE 608 "./src-ag/DefaultRules.ag" #-} foldr addAugments (_rulesIoutput ++ _newRls) (Map.assocs _augmentsIn ) {-# LINE 3542 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule203 #-} {-# LINE 609 "./src-ag/DefaultRules.ag" #-} rule203 = \ !_aroundsIn !_extra1 -> {-# LINE 609 "./src-ag/DefaultRules.ag" #-} foldr addArounds _extra1 (Map.assocs _aroundsIn ) {-# LINE 3548 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule204 #-} {-# LINE 610 "./src-ag/DefaultRules.ag" #-} rule204 = \ !_extra2 !_mergesIn -> {-# LINE 610 "./src-ag/DefaultRules.ag" #-} foldr addMerges _extra2 (Map.assocs _mergesIn ) {-# LINE 3554 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule205 #-} {-# LINE 611 "./src-ag/DefaultRules.ag" #-} rule205 = \ ((!_childrenIoutput) :: Children) !_extra3 ((!_typeSigsIoutput) :: TypeSigs) !con_ !constraints_ !macro_ !params_ -> {-# LINE 611 "./src-ag/DefaultRules.ag" #-} Production con_ params_ constraints_ _childrenIoutput _extra3 _typeSigsIoutput macro_ {-# LINE 3560 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule206 #-} {-# LINE 719 "./src-ag/DefaultRules.ag" #-} rule206 = \ ((!_lhsImanualAttrOrderMap) :: AttrOrderMap) ((!_lhsInt) :: NontermIdent) !con_ -> {-# LINE 719 "./src-ag/DefaultRules.ag" #-} Set.toList $ Map.findWithDefault Set.empty con_ $ Map.findWithDefault Map.empty _lhsInt _lhsImanualAttrOrderMap {-# LINE 3566 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule207 #-} {-# LINE 722 "./src-ag/DefaultRules.ag" #-} rule207 = \ ((!_childrenIinputs) :: [(Identifier, Attributes)]) ((!_childrenIoutputs) :: [(Identifier, Attributes)]) ((!_lhsIinh) :: Attributes) ((!_lhsInt) :: NontermIdent) ((!_lhsIsyn) :: Attributes) !_orderDeps ((!_rulesIlocals) :: Set Identifier) ((!_rulesIruleNames) :: Set Identifier) !con_ -> {-# LINE 722 "./src-ag/DefaultRules.ag" #-} let chldOutMap = Map.fromList [ (k, Map.keysSet s) | (k,s) <- _childrenIoutputs ] chldInMap = Map.fromList [ (k, Map.keysSet s) | (k,s) <- _childrenIinputs ] isInAttribute :: Identifier -> Identifier -> [Error] isInAttribute fld nm | fld == _LOC = if nm `Set.member` _rulesIlocals then [] else [UndefAttr _lhsInt con_ fld nm False] | fld == _LHS = if nm `Map.member` _lhsIinh then [] else [UndefAttr _lhsInt con_ fld nm False] | otherwise = if nm `Set.member` (Map.findWithDefault Set.empty fld chldOutMap) then [] else [UndefAttr _lhsInt con_ fld nm False] isOutAttribute :: Identifier -> Identifier -> [Error] isOutAttribute fld nm | fld == _LOC = if nm `Set.member` _rulesIlocals then [] else [UndefAttr _lhsInt con_ fld nm True] | fld == _LHS = if nm `Map.member` _lhsIsyn then [] else [UndefAttr _lhsInt con_ fld nm True] | otherwise = if nm `Set.member` (Map.findWithDefault Set.empty fld chldInMap) then [] else [UndefAttr _lhsInt con_ fld nm True] existsRule nm = if nm `Set.member` _rulesIruleNames then [] else [MissingNamedRule _lhsInt 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) <- _orderDeps ] {-# LINE 3606 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule208 #-} {-# LINE 777 "./src-ag/DefaultRules.ag" #-} rule208 = \ ((!_lhsIaugmentsIn) :: Map ConstructorIdent (Map Identifier [Expression])) !con_ -> {-# LINE 777 "./src-ag/DefaultRules.ag" #-} Map.findWithDefault Map.empty con_ _lhsIaugmentsIn {-# LINE 3612 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule209 #-} {-# LINE 784 "./src-ag/DefaultRules.ag" #-} rule209 = \ ((!_lhsIaroundsIn) :: Map ConstructorIdent (Map Identifier [Expression])) !con_ -> {-# LINE 784 "./src-ag/DefaultRules.ag" #-} Map.findWithDefault Map.empty con_ _lhsIaroundsIn {-# LINE 3618 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule210 #-} {-# LINE 792 "./src-ag/DefaultRules.ag" #-} rule210 = \ ((!_lhsImergesIn) :: Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression))) !con_ -> {-# LINE 792 "./src-ag/DefaultRules.ag" #-} Map.findWithDefault Map.empty con_ _lhsImergesIn {-# LINE 3624 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule211 #-} {-# LINE 793 "./src-ag/DefaultRules.ag" #-} rule211 = \ !_mergesIn -> {-# LINE 793 "./src-ag/DefaultRules.ag" #-} Set.fromList [ c | (_,cs,_) <- Map.elems _mergesIn , c <- cs ] {-# LINE 3630 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule213 #-} rule213 = \ ((!_rulesIuniq) :: Int) -> _rulesIuniq {-# NOINLINE[1] rule215 #-} rule215 = \ ((!_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# NOINLINE[1] rule216 #-} rule216 = \ !_merged -> _merged {-# NOINLINE[1] rule219 #-} rule219 = \ ((!_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# NOINLINE[1] rule221 #-} rule221 = \ ((!_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE[1] rule222 #-} rule222 = \ ((!_lhsIuniq) :: Int) -> _lhsIuniq {-# NOINLINE[1] rule223 #-} rule223 = \ ((!_lhsInt) :: NontermIdent) -> _lhsInt {-# NOINLINE[1] rule224 #-} rule224 = \ ((!_lhsIparams) :: [Identifier]) -> _lhsIparams -- Productions ------------------------------------------------- -- wrapper data Inh_Productions = Inh_Productions { aroundsIn_Inh_Productions :: !(Map ConstructorIdent (Map Identifier [Expression])), augmentsIn_Inh_Productions :: !(Map ConstructorIdent (Map Identifier [Expression])), cr_Inh_Productions :: !(Bool), inh_Inh_Productions :: !(Attributes), inhMap_Inh_Productions :: !(Map Identifier Attributes), inhOrig_Inh_Productions :: !(Attributes), manualAttrOrderMap_Inh_Productions :: !(AttrOrderMap), mergesIn_Inh_Productions :: !(Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression))), nonterminals_Inh_Productions :: !(Set NontermIdent), nt_Inh_Productions :: !(NontermIdent), o_rename_Inh_Productions :: !(Bool), options_Inh_Productions :: !(Options), params_Inh_Productions :: !([Identifier]), syn_Inh_Productions :: !(Attributes), synMap_Inh_Productions :: !(Map Identifier Attributes), synOrig_Inh_Productions :: !(Attributes), typeSyns_Inh_Productions :: !(TypeSyns), uniq_Inh_Productions :: !(Int), useMap_Inh_Productions :: !(Map Identifier (String,String,String)), wrappers_Inh_Productions :: !(Set NontermIdent) } data Syn_Productions = Syn_Productions { errors_Syn_Productions :: !(Seq Error), output_Syn_Productions :: !(Productions), uniq_Syn_Productions :: !(Int) } {-# INLINABLE wrap_Productions #-} wrap_Productions :: T_Productions -> Inh_Productions -> (Syn_Productions ) wrap_Productions !(T_Productions act) !(Inh_Productions _lhsIaroundsIn _lhsIaugmentsIn _lhsIcr _lhsIinh _lhsIinhMap _lhsIinhOrig _lhsImanualAttrOrderMap _lhsImergesIn _lhsInonterminals _lhsInt _lhsIo_rename _lhsIoptions _lhsIparams _lhsIsyn _lhsIsynMap _lhsIsynOrig _lhsItypeSyns _lhsIuniq _lhsIuseMap _lhsIwrappers) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Productions_vIn8 _lhsIaroundsIn _lhsIaugmentsIn _lhsIcr _lhsIinh _lhsIinhMap _lhsIinhOrig _lhsImanualAttrOrderMap _lhsImergesIn _lhsInonterminals _lhsInt _lhsIo_rename _lhsIoptions _lhsIparams _lhsIsyn _lhsIsynMap _lhsIsynOrig _lhsItypeSyns _lhsIuniq _lhsIuseMap _lhsIwrappers !(T_Productions_vOut8 _lhsOerrors _lhsOoutput _lhsOuniq) <- return (inv_Productions_s16 sem K_Productions_v8 arg) return (Syn_Productions _lhsOerrors _lhsOoutput _lhsOuniq) ) -- cata {-# NOINLINE sem_Productions #-} sem_Productions :: Productions -> T_Productions sem_Productions list = Prelude.foldr sem_Productions_Cons sem_Productions_Nil (Prelude.map sem_Production list) -- semantic domain newtype T_Productions = T_Productions { attach_T_Productions :: Identity (T_Productions_s16 ) } data T_Productions_s16 where C_Productions_s16 :: { inv_Productions_s16 :: !(forall t. K_Productions_s16 t -> t) } -> T_Productions_s16 data T_Productions_s17 = C_Productions_s17 data T_Productions_s30 = C_Productions_s30 newtype T_Productions_s39 = C_Productions_s39 { inv_Productions_s39 :: (T_Productions_v27 ) } data K_Productions_s16 k where K_Productions_v8 :: K_Productions_s16 (T_Productions_v8 ) K_Productions_v17 :: K_Productions_s16 (T_Productions_v17 ) K_Productions_v26 :: K_Productions_s16 (T_Productions_v26 ) type T_Productions_v8 = (T_Productions_vIn8 ) -> (T_Productions_vOut8 ) data T_Productions_vIn8 = T_Productions_vIn8 !(Map ConstructorIdent (Map Identifier [Expression])) !(Map ConstructorIdent (Map Identifier [Expression])) !(Bool) !(Attributes) !(Map Identifier Attributes) !(Attributes) !(AttrOrderMap) !(Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression))) !(Set NontermIdent) !(NontermIdent) !(Bool) !(Options) !([Identifier]) !(Attributes) !(Map Identifier Attributes) !(Attributes) !(TypeSyns) !(Int) !(Map Identifier (String,String,String)) !(Set NontermIdent) data T_Productions_vOut8 = T_Productions_vOut8 !(Seq Error) !(Productions) !(Int) type T_Productions_v17 = (T_Productions_vIn17 ) -> (T_Productions_vOut17 ) data T_Productions_vIn17 = T_Productions_vIn17 !(Map ConstructorIdent (Map Identifier [Expression])) !(Map ConstructorIdent (Map Identifier [Expression])) !(Bool) !(Attributes) !(Map Identifier Attributes) !(AttrOrderMap) !(Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression))) !(NontermIdent) !(Bool) !(Options) !([Identifier]) !(Attributes) !(Map Identifier Attributes) !(Attributes) !(TypeSyns) !(Int) !(Map Identifier (String,String,String)) !(Set NontermIdent) data T_Productions_vOut17 = T_Productions_vOut17 !(Seq Error) !(Productions) !(Int) type T_Productions_v26 = (T_Productions_vIn26 ) -> (T_Productions_vOut26 ) data T_Productions_vIn26 = T_Productions_vIn26 !(Bool) !(Attributes) !(Map Identifier Attributes) !(AttrOrderMap) !(Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression))) !(NontermIdent) !(Bool) !(Options) !(Attributes) !(Map Identifier Attributes) !(Attributes) !(TypeSyns) !(Map Identifier (String,String,String)) !(Set NontermIdent) data T_Productions_vOut26 = T_Productions_vOut26 !(Seq Error) !(T_Productions_s39 ) type T_Productions_v27 = (T_Productions_vIn27 ) -> (T_Productions_vOut27 ) data T_Productions_vIn27 = T_Productions_vIn27 !(Map ConstructorIdent (Map Identifier [Expression])) !(Map ConstructorIdent (Map Identifier [Expression])) !([Identifier]) !(Int) data T_Productions_vOut27 = T_Productions_vOut27 !(Productions) !(Int) {-# NOINLINE sem_Productions_Cons #-} sem_Productions_Cons :: T_Production -> T_Productions -> T_Productions sem_Productions_Cons arg_hd_ arg_tl_ = T_Productions (return st16) where {-# NOINLINE st16 #-} !st16 = let k16 :: K_Productions_s16 t -> t k16 K_Productions_v8 = v8 k16 K_Productions_v17 = v17 k16 K_Productions_v26 = v26 v8 :: T_Productions_v8 v8 = \ !(T_Productions_vIn8 _lhsIaroundsIn _lhsIaugmentsIn _lhsIcr _lhsIinh _lhsIinhMap _lhsIinhOrig _lhsImanualAttrOrderMap _lhsImergesIn _lhsInonterminals _lhsInt _lhsIo_rename _lhsIoptions _lhsIparams _lhsIsyn _lhsIsynMap _lhsIsynOrig _lhsItypeSyns _lhsIuniq _lhsIuseMap _lhsIwrappers) -> ( let !_hdX14 = Control.Monad.Identity.runIdentity (attach_T_Production (arg_hd_)) in let !_tlX16 = Control.Monad.Identity.runIdentity (attach_T_Productions (arg_tl_)) in let !_hdOcr = rule231 _lhsIcr in let !_hdOinh = rule232 _lhsIinh in let !_hdOinhMap = rule233 _lhsIinhMap in let !_hdOmanualAttrOrderMap = rule235 _lhsImanualAttrOrderMap in let !_hdOmergesIn = rule236 _lhsImergesIn in let !_hdOnt = rule238 _lhsInt in let !_hdOo_rename = rule239 _lhsIo_rename in let !_hdOoptions = rule240 _lhsIoptions in let !_hdOsyn = rule242 _lhsIsyn in let !_hdOsynMap = rule243 _lhsIsynMap in let !_hdOsynOrig = rule244 _lhsIsynOrig in let !_hdOtypeSyns = rule245 _lhsItypeSyns in let !_hdOuseMap = rule247 _lhsIuseMap in let !_hdOwrappers = rule248 _lhsIwrappers in let !_tlOcr = rule251 _lhsIcr in let !_tlOinh = rule252 _lhsIinh in let !_tlOinhMap = rule253 _lhsIinhMap in let !_tlOmanualAttrOrderMap = rule255 _lhsImanualAttrOrderMap in let !_tlOmergesIn = rule256 _lhsImergesIn in let !_tlOnt = rule258 _lhsInt in let !_tlOo_rename = rule259 _lhsIo_rename in let !_tlOoptions = rule260 _lhsIoptions in let !_tlOsyn = rule262 _lhsIsyn in let !_tlOsynMap = rule263 _lhsIsynMap in let !_tlOsynOrig = rule264 _lhsIsynOrig in let !_tlOtypeSyns = rule265 _lhsItypeSyns in let !_tlOuseMap = rule267 _lhsIuseMap in let !_tlOwrappers = rule268 _lhsIwrappers in let !_hdOaroundsIn = rule229 _lhsIaroundsIn in let !_hdOaugmentsIn = rule230 _lhsIaugmentsIn in let !_hdOparams = rule241 _lhsIparams in let !_hdOuniq = rule246 _lhsIuniq in let !_tlOaroundsIn = rule249 _lhsIaroundsIn in let !_tlOaugmentsIn = rule250 _lhsIaugmentsIn in let !_tlOparams = rule261 _lhsIparams in let !(T_Production_vOut25 _hdIerrors _hdIoutput _hdIuniq) = inv_Production_s14 _hdX14 K_Production_v25 (T_Production_vIn25 _hdOaroundsIn _hdOaugmentsIn _hdOcr _hdOinh _hdOinhMap _hdOmanualAttrOrderMap _hdOmergesIn _hdOnt _hdOo_rename _hdOoptions _hdOparams _hdOsyn _hdOsynMap _hdOsynOrig _hdOtypeSyns _hdOuniq _hdOuseMap _hdOwrappers) in let !(T_Productions_vOut26 _tlIerrors _tlX39) = inv_Productions_s16 _tlX16 K_Productions_v26 (T_Productions_vIn26 _tlOcr _tlOinh _tlOinhMap _tlOmanualAttrOrderMap _tlOmergesIn _tlOnt _tlOo_rename _tlOoptions _tlOsyn _tlOsynMap _tlOsynOrig _tlOtypeSyns _tlOuseMap _tlOwrappers) in let _lhsOerrors :: Seq Error !_lhsOerrors = rule225 _hdIerrors _tlIerrors in let !_tlOuniq = rule266 _hdIuniq in let !(T_Productions_vOut27 _tlIoutput _tlIuniq) = inv_Productions_s39 _tlX39 (T_Productions_vIn27 _tlOaroundsIn _tlOaugmentsIn _tlOparams _tlOuniq) in let !_output = rule226 _hdIoutput _tlIoutput in let _lhsOoutput :: Productions !_lhsOoutput = rule227 _output in let _lhsOuniq :: Int !_lhsOuniq = rule228 _tlIuniq in let !__result_ = T_Productions_vOut8 _lhsOerrors _lhsOoutput _lhsOuniq in __result_ ) v17 :: T_Productions_v17 v17 = \ !(T_Productions_vIn17 _lhsIaroundsIn _lhsIaugmentsIn _lhsIcr _lhsIinh _lhsIinhMap _lhsImanualAttrOrderMap _lhsImergesIn _lhsInt _lhsIo_rename _lhsIoptions _lhsIparams _lhsIsyn _lhsIsynMap _lhsIsynOrig _lhsItypeSyns _lhsIuniq _lhsIuseMap _lhsIwrappers) -> ( let !_hdX14 = Control.Monad.Identity.runIdentity (attach_T_Production (arg_hd_)) in let !_tlX16 = Control.Monad.Identity.runIdentity (attach_T_Productions (arg_tl_)) in let !_hdOcr = rule231 _lhsIcr in let !_hdOinh = rule232 _lhsIinh in let !_hdOinhMap = rule233 _lhsIinhMap in let !_hdOmanualAttrOrderMap = rule235 _lhsImanualAttrOrderMap in let !_hdOmergesIn = rule236 _lhsImergesIn in let !_hdOnt = rule238 _lhsInt in let !_hdOo_rename = rule239 _lhsIo_rename in let !_hdOoptions = rule240 _lhsIoptions in let !_hdOsyn = rule242 _lhsIsyn in let !_hdOsynMap = rule243 _lhsIsynMap in let !_hdOsynOrig = rule244 _lhsIsynOrig in let !_hdOtypeSyns = rule245 _lhsItypeSyns in let !_hdOuseMap = rule247 _lhsIuseMap in let !_hdOwrappers = rule248 _lhsIwrappers in let !_tlOcr = rule251 _lhsIcr in let !_tlOinh = rule252 _lhsIinh in let !_tlOinhMap = rule253 _lhsIinhMap in let !_tlOmanualAttrOrderMap = rule255 _lhsImanualAttrOrderMap in let !_tlOmergesIn = rule256 _lhsImergesIn in let !_tlOnt = rule258 _lhsInt in let !_tlOo_rename = rule259 _lhsIo_rename in let !_tlOoptions = rule260 _lhsIoptions in let !_tlOsyn = rule262 _lhsIsyn in let !_tlOsynMap = rule263 _lhsIsynMap in let !_tlOsynOrig = rule264 _lhsIsynOrig in let !_tlOtypeSyns = rule265 _lhsItypeSyns in let !_tlOuseMap = rule267 _lhsIuseMap in let !_tlOwrappers = rule268 _lhsIwrappers in let !_hdOaroundsIn = rule229 _lhsIaroundsIn in let !_hdOaugmentsIn = rule230 _lhsIaugmentsIn in let !_hdOparams = rule241 _lhsIparams in let !_hdOuniq = rule246 _lhsIuniq in let !_tlOaroundsIn = rule249 _lhsIaroundsIn in let !_tlOaugmentsIn = rule250 _lhsIaugmentsIn in let !_tlOparams = rule261 _lhsIparams in let !(T_Production_vOut25 _hdIerrors _hdIoutput _hdIuniq) = inv_Production_s14 _hdX14 K_Production_v25 (T_Production_vIn25 _hdOaroundsIn _hdOaugmentsIn _hdOcr _hdOinh _hdOinhMap _hdOmanualAttrOrderMap _hdOmergesIn _hdOnt _hdOo_rename _hdOoptions _hdOparams _hdOsyn _hdOsynMap _hdOsynOrig _hdOtypeSyns _hdOuniq _hdOuseMap _hdOwrappers) in let !(T_Productions_vOut26 _tlIerrors _tlX39) = inv_Productions_s16 _tlX16 K_Productions_v26 (T_Productions_vIn26 _tlOcr _tlOinh _tlOinhMap _tlOmanualAttrOrderMap _tlOmergesIn _tlOnt _tlOo_rename _tlOoptions _tlOsyn _tlOsynMap _tlOsynOrig _tlOtypeSyns _tlOuseMap _tlOwrappers) in let _lhsOerrors :: Seq Error !_lhsOerrors = rule225 _hdIerrors _tlIerrors in let !_tlOuniq = rule266 _hdIuniq in let !(T_Productions_vOut27 _tlIoutput _tlIuniq) = inv_Productions_s39 _tlX39 (T_Productions_vIn27 _tlOaroundsIn _tlOaugmentsIn _tlOparams _tlOuniq) in let !_output = rule226 _hdIoutput _tlIoutput in let _lhsOoutput :: Productions !_lhsOoutput = rule227 _output in let _lhsOuniq :: Int !_lhsOuniq = rule228 _tlIuniq in let !__result_ = T_Productions_vOut17 _lhsOerrors _lhsOoutput _lhsOuniq in __result_ ) v26 :: T_Productions_v26 v26 = \ !(T_Productions_vIn26 _lhsIcr _lhsIinh _lhsIinhMap _lhsImanualAttrOrderMap _lhsImergesIn _lhsInt _lhsIo_rename _lhsIoptions _lhsIsyn _lhsIsynMap _lhsIsynOrig _lhsItypeSyns _lhsIuseMap _lhsIwrappers) -> ( let !_hdX14 = Control.Monad.Identity.runIdentity (attach_T_Production (arg_hd_)) in let !_tlX16 = Control.Monad.Identity.runIdentity (attach_T_Productions (arg_tl_)) in let !_hdOcr = rule231 _lhsIcr in let !_hdOinh = rule232 _lhsIinh in let !_hdOinhMap = rule233 _lhsIinhMap in let !_hdOmanualAttrOrderMap = rule235 _lhsImanualAttrOrderMap in let !_hdOmergesIn = rule236 _lhsImergesIn in let !_hdOnt = rule238 _lhsInt in let !_hdOo_rename = rule239 _lhsIo_rename in let !_hdOoptions = rule240 _lhsIoptions in let !_hdOsyn = rule242 _lhsIsyn in let !_hdOsynMap = rule243 _lhsIsynMap in let !_hdOsynOrig = rule244 _lhsIsynOrig in let !_hdOtypeSyns = rule245 _lhsItypeSyns in let !_hdOuseMap = rule247 _lhsIuseMap in let !_hdOwrappers = rule248 _lhsIwrappers in let !_tlOcr = rule251 _lhsIcr in let !_tlOinh = rule252 _lhsIinh in let !_tlOinhMap = rule253 _lhsIinhMap in let !_tlOmanualAttrOrderMap = rule255 _lhsImanualAttrOrderMap in let !_tlOmergesIn = rule256 _lhsImergesIn in let !_tlOnt = rule258 _lhsInt in let !_tlOo_rename = rule259 _lhsIo_rename in let !_tlOoptions = rule260 _lhsIoptions in let !_tlOsyn = rule262 _lhsIsyn in let !_tlOsynMap = rule263 _lhsIsynMap in let !_tlOsynOrig = rule264 _lhsIsynOrig in let !_tlOtypeSyns = rule265 _lhsItypeSyns in let !_tlOuseMap = rule267 _lhsIuseMap in let !_tlOwrappers = rule268 _lhsIwrappers in let !(T_Production_vOut39 _hdIerrors _hdX48) = inv_Production_s14 _hdX14 K_Production_v39 (T_Production_vIn39 _hdOcr _hdOinh _hdOinhMap _hdOmanualAttrOrderMap _hdOmergesIn _hdOnt _hdOo_rename _hdOoptions _hdOsyn _hdOsynMap _hdOsynOrig _hdOtypeSyns _hdOuseMap _hdOwrappers) in let !(T_Productions_vOut26 _tlIerrors _tlX39) = inv_Productions_s16 _tlX16 K_Productions_v26 (T_Productions_vIn26 _tlOcr _tlOinh _tlOinhMap _tlOmanualAttrOrderMap _tlOmergesIn _tlOnt _tlOo_rename _tlOoptions _tlOsyn _tlOsynMap _tlOsynOrig _tlOtypeSyns _tlOuseMap _tlOwrappers) in let _lhsOerrors :: Seq Error !_lhsOerrors = rule225 _hdIerrors _tlIerrors in let !__st_ = st39 _hdX48 _tlX39 !__result_ = T_Productions_vOut26 _lhsOerrors __st_ in __result_ ) in C_Productions_s16 k16 {-# NOINLINE st39 #-} st39 = \ !_hdX48 !_tlX39 -> let v27 :: T_Productions_v27 v27 = \ !(T_Productions_vIn27 _lhsIaroundsIn _lhsIaugmentsIn _lhsIparams _lhsIuniq) -> ( let !_hdOaroundsIn = rule229 _lhsIaroundsIn in let !_hdOaugmentsIn = rule230 _lhsIaugmentsIn in let !_hdOparams = rule241 _lhsIparams in let !_hdOuniq = rule246 _lhsIuniq in let !_tlOaroundsIn = rule249 _lhsIaroundsIn in let !_tlOaugmentsIn = rule250 _lhsIaugmentsIn in let !_tlOparams = rule261 _lhsIparams in let !(T_Production_vOut40 _hdIoutput _hdIuniq) = inv_Production_s48 _hdX48 (T_Production_vIn40 _hdOaroundsIn _hdOaugmentsIn _hdOparams _hdOuniq) in let !_tlOuniq = rule266 _hdIuniq in let !(T_Productions_vOut27 _tlIoutput _tlIuniq) = inv_Productions_s39 _tlX39 (T_Productions_vIn27 _tlOaroundsIn _tlOaugmentsIn _tlOparams _tlOuniq) in let !_output = rule226 _hdIoutput _tlIoutput in let _lhsOoutput :: Productions !_lhsOoutput = rule227 _output in let _lhsOuniq :: Int !_lhsOuniq = rule228 _tlIuniq in let !__result_ = T_Productions_vOut27 _lhsOoutput _lhsOuniq in __result_ ) in C_Productions_s39 v27 {-# NOINLINE[1] rule225 #-} rule225 = \ ((!_hdIerrors) :: Seq Error) ((!_tlIerrors) :: Seq Error) -> _hdIerrors Seq.>< _tlIerrors {-# NOINLINE[1] rule226 #-} rule226 = \ ((!_hdIoutput) :: Production) ((!_tlIoutput) :: Productions) -> (:) _hdIoutput _tlIoutput {-# NOINLINE[1] rule227 #-} rule227 = \ !_output -> _output {-# NOINLINE[1] rule228 #-} rule228 = \ ((!_tlIuniq) :: Int) -> _tlIuniq {-# NOINLINE[1] rule229 #-} rule229 = \ ((!_lhsIaroundsIn) :: Map ConstructorIdent (Map Identifier [Expression])) -> _lhsIaroundsIn {-# NOINLINE[1] rule230 #-} rule230 = \ ((!_lhsIaugmentsIn) :: Map ConstructorIdent (Map Identifier [Expression])) -> _lhsIaugmentsIn {-# NOINLINE[1] rule231 #-} rule231 = \ ((!_lhsIcr) :: Bool) -> _lhsIcr {-# NOINLINE[1] rule232 #-} rule232 = \ ((!_lhsIinh) :: Attributes) -> _lhsIinh {-# NOINLINE[1] rule233 #-} rule233 = \ ((!_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# NOINLINE[1] rule235 #-} rule235 = \ ((!_lhsImanualAttrOrderMap) :: AttrOrderMap) -> _lhsImanualAttrOrderMap {-# NOINLINE[1] rule236 #-} rule236 = \ ((!_lhsImergesIn) :: Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression))) -> _lhsImergesIn {-# NOINLINE[1] rule238 #-} rule238 = \ ((!_lhsInt) :: NontermIdent) -> _lhsInt {-# NOINLINE[1] rule239 #-} rule239 = \ ((!_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# NOINLINE[1] rule240 #-} rule240 = \ ((!_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE[1] rule241 #-} rule241 = \ ((!_lhsIparams) :: [Identifier]) -> _lhsIparams {-# NOINLINE[1] rule242 #-} rule242 = \ ((!_lhsIsyn) :: Attributes) -> _lhsIsyn {-# NOINLINE[1] rule243 #-} rule243 = \ ((!_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# NOINLINE[1] rule244 #-} rule244 = \ ((!_lhsIsynOrig) :: Attributes) -> _lhsIsynOrig {-# NOINLINE[1] rule245 #-} rule245 = \ ((!_lhsItypeSyns) :: TypeSyns) -> _lhsItypeSyns {-# NOINLINE[1] rule246 #-} rule246 = \ ((!_lhsIuniq) :: Int) -> _lhsIuniq {-# NOINLINE[1] rule247 #-} rule247 = \ ((!_lhsIuseMap) :: Map Identifier (String,String,String)) -> _lhsIuseMap {-# NOINLINE[1] rule248 #-} rule248 = \ ((!_lhsIwrappers) :: Set NontermIdent) -> _lhsIwrappers {-# NOINLINE[1] rule249 #-} rule249 = \ ((!_lhsIaroundsIn) :: Map ConstructorIdent (Map Identifier [Expression])) -> _lhsIaroundsIn {-# NOINLINE[1] rule250 #-} rule250 = \ ((!_lhsIaugmentsIn) :: Map ConstructorIdent (Map Identifier [Expression])) -> _lhsIaugmentsIn {-# NOINLINE[1] rule251 #-} rule251 = \ ((!_lhsIcr) :: Bool) -> _lhsIcr {-# NOINLINE[1] rule252 #-} rule252 = \ ((!_lhsIinh) :: Attributes) -> _lhsIinh {-# NOINLINE[1] rule253 #-} rule253 = \ ((!_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# NOINLINE[1] rule255 #-} rule255 = \ ((!_lhsImanualAttrOrderMap) :: AttrOrderMap) -> _lhsImanualAttrOrderMap {-# NOINLINE[1] rule256 #-} rule256 = \ ((!_lhsImergesIn) :: Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression))) -> _lhsImergesIn {-# NOINLINE[1] rule258 #-} rule258 = \ ((!_lhsInt) :: NontermIdent) -> _lhsInt {-# NOINLINE[1] rule259 #-} rule259 = \ ((!_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# NOINLINE[1] rule260 #-} rule260 = \ ((!_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE[1] rule261 #-} rule261 = \ ((!_lhsIparams) :: [Identifier]) -> _lhsIparams {-# NOINLINE[1] rule262 #-} rule262 = \ ((!_lhsIsyn) :: Attributes) -> _lhsIsyn {-# NOINLINE[1] rule263 #-} rule263 = \ ((!_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# NOINLINE[1] rule264 #-} rule264 = \ ((!_lhsIsynOrig) :: Attributes) -> _lhsIsynOrig {-# NOINLINE[1] rule265 #-} rule265 = \ ((!_lhsItypeSyns) :: TypeSyns) -> _lhsItypeSyns {-# NOINLINE[1] rule266 #-} rule266 = \ ((!_hdIuniq) :: Int) -> _hdIuniq {-# NOINLINE[1] rule267 #-} rule267 = \ ((!_lhsIuseMap) :: Map Identifier (String,String,String)) -> _lhsIuseMap {-# NOINLINE[1] rule268 #-} rule268 = \ ((!_lhsIwrappers) :: Set NontermIdent) -> _lhsIwrappers {-# NOINLINE sem_Productions_Nil #-} sem_Productions_Nil :: T_Productions sem_Productions_Nil = T_Productions (return st16) where {-# NOINLINE st16 #-} !st16 = let k16 :: K_Productions_s16 t -> t k16 K_Productions_v8 = v8 k16 K_Productions_v17 = v17 k16 K_Productions_v26 = v26 v8 :: T_Productions_v8 v8 = \ !(T_Productions_vIn8 _lhsIaroundsIn _lhsIaugmentsIn _lhsIcr _lhsIinh _lhsIinhMap _lhsIinhOrig _lhsImanualAttrOrderMap _lhsImergesIn _lhsInonterminals _lhsInt _lhsIo_rename _lhsIoptions _lhsIparams _lhsIsyn _lhsIsynMap _lhsIsynOrig _lhsItypeSyns _lhsIuniq _lhsIuseMap _lhsIwrappers) -> ( let _lhsOerrors :: Seq Error !_lhsOerrors = rule269 () in let !_output = rule270 () in let _lhsOoutput :: Productions !_lhsOoutput = rule271 _output in let _lhsOuniq :: Int !_lhsOuniq = rule272 _lhsIuniq in let !__result_ = T_Productions_vOut8 _lhsOerrors _lhsOoutput _lhsOuniq in __result_ ) v17 :: T_Productions_v17 v17 = \ !(T_Productions_vIn17 _lhsIaroundsIn _lhsIaugmentsIn _lhsIcr _lhsIinh _lhsIinhMap _lhsImanualAttrOrderMap _lhsImergesIn _lhsInt _lhsIo_rename _lhsIoptions _lhsIparams _lhsIsyn _lhsIsynMap _lhsIsynOrig _lhsItypeSyns _lhsIuniq _lhsIuseMap _lhsIwrappers) -> ( let _lhsOerrors :: Seq Error !_lhsOerrors = rule269 () in let !_output = rule270 () in let _lhsOoutput :: Productions !_lhsOoutput = rule271 _output in let _lhsOuniq :: Int !_lhsOuniq = rule272 _lhsIuniq in let !__result_ = T_Productions_vOut17 _lhsOerrors _lhsOoutput _lhsOuniq in __result_ ) v26 :: T_Productions_v26 v26 = \ !(T_Productions_vIn26 _lhsIcr _lhsIinh _lhsIinhMap _lhsImanualAttrOrderMap _lhsImergesIn _lhsInt _lhsIo_rename _lhsIoptions _lhsIsyn _lhsIsynMap _lhsIsynOrig _lhsItypeSyns _lhsIuseMap _lhsIwrappers) -> ( let _lhsOerrors :: Seq Error !_lhsOerrors = rule269 () in let !__st_ = st39 () !__result_ = T_Productions_vOut26 _lhsOerrors __st_ in __result_ ) in C_Productions_s16 k16 {-# NOINLINE st39 #-} st39 = \ (_ :: ()) -> let v27 :: T_Productions_v27 v27 = \ !(T_Productions_vIn27 _lhsIaroundsIn _lhsIaugmentsIn _lhsIparams _lhsIuniq) -> ( let !_output = rule270 () in let _lhsOoutput :: Productions !_lhsOoutput = rule271 _output in let _lhsOuniq :: Int !_lhsOuniq = rule272 _lhsIuniq in let !__result_ = T_Productions_vOut27 _lhsOoutput _lhsOuniq in __result_ ) in C_Productions_s39 v27 {-# NOINLINE[1] rule269 #-} rule269 = \ (_ :: ()) -> Seq.empty {-# NOINLINE[1] rule270 #-} rule270 = \ (_ :: ()) -> [] {-# NOINLINE[1] rule271 #-} rule271 = \ !_output -> _output {-# NOINLINE[1] rule272 #-} rule272 = \ ((!_lhsIuniq) :: Int) -> _lhsIuniq -- Rule -------------------------------------------------------- -- wrapper data Inh_Rule = Inh_Rule { con_Inh_Rule :: !(ConstructorIdent), nt_Inh_Rule :: !(NontermIdent), options_Inh_Rule :: !(Options), uniq_Inh_Rule :: !(Int) } data Syn_Rule = Syn_Rule { containsVars_Syn_Rule :: !(Bool), definedAttrs_Syn_Rule :: !(Set (Identifier,Identifier)), errors_Syn_Rule :: !(Seq Error), isPure_Syn_Rule :: !(Bool), locals_Syn_Rule :: !(Set Identifier), output_Syn_Rule :: !(Rule), outputs_Syn_Rule :: !(Rules), ruleNames_Syn_Rule :: !(Set Identifier), uniq_Syn_Rule :: !(Int) } {-# INLINABLE wrap_Rule #-} wrap_Rule :: T_Rule -> Inh_Rule -> (Syn_Rule ) wrap_Rule !(T_Rule act) !(Inh_Rule _lhsIcon _lhsInt _lhsIoptions _lhsIuniq) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Rule_vIn9 _lhsIcon _lhsInt _lhsIoptions _lhsIuniq !(T_Rule_vOut9 _lhsOcontainsVars _lhsOdefinedAttrs _lhsOerrors _lhsOisPure _lhsOlocals _lhsOoutput _lhsOoutputs _lhsOruleNames _lhsOuniq) <- return (inv_Rule_s18 sem K_Rule_v9 arg) return (Syn_Rule _lhsOcontainsVars _lhsOdefinedAttrs _lhsOerrors _lhsOisPure _lhsOlocals _lhsOoutput _lhsOoutputs _lhsOruleNames _lhsOuniq) ) -- cata {-# INLINE sem_Rule #-} sem_Rule :: Rule -> T_Rule sem_Rule ( Rule !mbName_ pattern_ !rhs_ !owrt_ !origin_ !explicit_ !pure_ !identity_ !mbError_ !eager_ ) = sem_Rule_Rule mbName_ ( sem_Pattern pattern_ ) rhs_ owrt_ origin_ explicit_ pure_ identity_ mbError_ eager_ -- semantic domain newtype T_Rule = T_Rule { attach_T_Rule :: Identity (T_Rule_s18 ) } data T_Rule_s18 where C_Rule_s18 :: { inv_Rule_s18 :: !(forall t. K_Rule_s18 t -> t) } -> T_Rule_s18 data T_Rule_s19 = C_Rule_s19 data T_Rule_s41 = C_Rule_s41 newtype T_Rule_s51 = C_Rule_s51 { inv_Rule_s51 :: (T_Rule_v44 ) } data K_Rule_s18 k where K_Rule_v9 :: K_Rule_s18 (T_Rule_v9 ) K_Rule_v29 :: K_Rule_s18 (T_Rule_v29 ) K_Rule_v43 :: K_Rule_s18 (T_Rule_v43 ) type T_Rule_v9 = (T_Rule_vIn9 ) -> (T_Rule_vOut9 ) data T_Rule_vIn9 = T_Rule_vIn9 !(ConstructorIdent) !(NontermIdent) !(Options) !(Int) data T_Rule_vOut9 = T_Rule_vOut9 !(Bool) !(Set (Identifier,Identifier)) !(Seq Error) !(Bool) !(Set Identifier) !(Rule) !(Rules) !(Set Identifier) !(Int) type T_Rule_v29 = (T_Rule_vIn29 ) -> (T_Rule_vOut29 ) data T_Rule_vIn29 = T_Rule_vIn29 !(Options) !(Int) data T_Rule_vOut29 = T_Rule_vOut29 !(Bool) !(Set (Identifier,Identifier)) !(Seq Error) !(Bool) !(Set Identifier) !(Rules) !(Set Identifier) !(Int) type T_Rule_v43 = (T_Rule_vIn43 ) -> (T_Rule_vOut43 ) data T_Rule_vIn43 = T_Rule_vIn43 data T_Rule_vOut43 = T_Rule_vOut43 !(Set (Identifier,Identifier)) !(Seq Error) !(Set Identifier) !(Set Identifier) !(T_Rule_s51 ) type T_Rule_v44 = (T_Rule_vIn44 ) -> (T_Rule_vOut44 ) data T_Rule_vIn44 = T_Rule_vIn44 !(Options) !(Int) data T_Rule_vOut44 = T_Rule_vOut44 !(Bool) !(Bool) !(Rules) !(Int) {-# NOINLINE sem_Rule_Rule #-} sem_Rule_Rule :: (Maybe Identifier) -> T_Pattern -> (Expression) -> (Bool) -> (String) -> (Bool) -> (Bool) -> (Bool) -> (Maybe Error) -> (Bool) -> T_Rule sem_Rule_Rule !arg_mbName_ arg_pattern_ !arg_rhs_ !arg_owrt_ !arg_origin_ !arg_explicit_ !arg_pure_ !arg_identity_ !arg_mbError_ !arg_eager_ = T_Rule (return st18) where {-# NOINLINE st18 #-} !st18 = let k18 :: K_Rule_s18 t -> t k18 K_Rule_v9 = v9 k18 K_Rule_v29 = v29 k18 K_Rule_v43 = v43 v9 :: T_Rule_v9 v9 = \ !(T_Rule_vIn9 _lhsIcon _lhsInt _lhsIoptions _lhsIuniq) -> ( let !_patternX10 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pattern_)) in let _lhsOisPure :: Bool !_lhsOisPure = rule273 arg_pure_ in let _lhsOruleNames :: Set Identifier !_lhsOruleNames = rule277 arg_mbName_ in let !(T_Pattern_vOut28 _patternIcontainsVars _patternIdefinedAttrs _patternIerrors _patternIlocals _patternIoutput) = inv_Pattern_s10 _patternX10 K_Pattern_v28 (T_Pattern_vIn28 ) in let _lhsOcontainsVars :: Bool !_lhsOcontainsVars = rule278 _patternIcontainsVars in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule279 _patternIdefinedAttrs in let _lhsOerrors :: Seq Error !_lhsOerrors = rule280 _patternIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule281 _patternIlocals in let !_output = rule282 _patternIoutput arg_eager_ arg_explicit_ arg_identity_ arg_mbError_ arg_mbName_ arg_origin_ arg_owrt_ arg_pure_ arg_rhs_ in let _lhsOoutput :: Rule !_lhsOoutput = rule283 _output in let !(!_output1,!_mbAlias) = rule274 _output in let _lhsOuniq :: Int !(!_outputs,!_lhsOuniq) = rule275 _lhsIoptions _lhsIuniq _output1 in let _lhsOoutputs :: Rules !_lhsOoutputs = rule276 _mbAlias _outputs in let !__result_ = T_Rule_vOut9 _lhsOcontainsVars _lhsOdefinedAttrs _lhsOerrors _lhsOisPure _lhsOlocals _lhsOoutput _lhsOoutputs _lhsOruleNames _lhsOuniq in __result_ ) v29 :: T_Rule_v29 v29 = \ !(T_Rule_vIn29 _lhsIoptions _lhsIuniq) -> ( let !_patternX10 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pattern_)) in let _lhsOisPure :: Bool !_lhsOisPure = rule273 arg_pure_ in let _lhsOruleNames :: Set Identifier !_lhsOruleNames = rule277 arg_mbName_ in let !(T_Pattern_vOut28 _patternIcontainsVars _patternIdefinedAttrs _patternIerrors _patternIlocals _patternIoutput) = inv_Pattern_s10 _patternX10 K_Pattern_v28 (T_Pattern_vIn28 ) in let _lhsOcontainsVars :: Bool !_lhsOcontainsVars = rule278 _patternIcontainsVars in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule279 _patternIdefinedAttrs in let _lhsOerrors :: Seq Error !_lhsOerrors = rule280 _patternIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule281 _patternIlocals in let !_output = rule282 _patternIoutput arg_eager_ arg_explicit_ arg_identity_ arg_mbError_ arg_mbName_ arg_origin_ arg_owrt_ arg_pure_ arg_rhs_ in let !(!_output1,!_mbAlias) = rule274 _output in let _lhsOuniq :: Int !(!_outputs,!_lhsOuniq) = rule275 _lhsIoptions _lhsIuniq _output1 in let _lhsOoutputs :: Rules !_lhsOoutputs = rule276 _mbAlias _outputs in let !__result_ = T_Rule_vOut29 _lhsOcontainsVars _lhsOdefinedAttrs _lhsOerrors _lhsOisPure _lhsOlocals _lhsOoutputs _lhsOruleNames _lhsOuniq in __result_ ) v43 :: T_Rule_v43 v43 = \ !(T_Rule_vIn43 ) -> ( let !_patternX10 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pattern_)) in let _lhsOruleNames :: Set Identifier !_lhsOruleNames = rule277 arg_mbName_ in let !(T_Pattern_vOut50 _patternIdefinedAttrs _patternIerrors _patternIlocals _patternX55) = inv_Pattern_s10 _patternX10 K_Pattern_v50 (T_Pattern_vIn50 ) in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule279 _patternIdefinedAttrs in let _lhsOerrors :: Seq Error !_lhsOerrors = rule280 _patternIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule281 _patternIlocals in let !__st_ = st51 _patternX55 !__result_ = T_Rule_vOut43 _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOruleNames __st_ in __result_ ) in C_Rule_s18 k18 {-# NOINLINE st51 #-} st51 = \ !_patternX55 -> let v44 :: T_Rule_v44 v44 = \ !(T_Rule_vIn44 _lhsIoptions _lhsIuniq) -> ( let _lhsOisPure :: Bool !_lhsOisPure = rule273 arg_pure_ in let !(T_Pattern_vOut51 _patternIcontainsVars _patternIoutput) = inv_Pattern_s55 _patternX55 K_Pattern_v51 (T_Pattern_vIn51 ) in let _lhsOcontainsVars :: Bool !_lhsOcontainsVars = rule278 _patternIcontainsVars in let !_output = rule282 _patternIoutput arg_eager_ arg_explicit_ arg_identity_ arg_mbError_ arg_mbName_ arg_origin_ arg_owrt_ arg_pure_ arg_rhs_ in let !(!_output1,!_mbAlias) = rule274 _output in let _lhsOuniq :: Int !(!_outputs,!_lhsOuniq) = rule275 _lhsIoptions _lhsIuniq _output1 in let _lhsOoutputs :: Rules !_lhsOoutputs = rule276 _mbAlias _outputs in let !__result_ = T_Rule_vOut44 _lhsOcontainsVars _lhsOisPure _lhsOoutputs _lhsOuniq in __result_ ) in C_Rule_s51 v44 {-# NOINLINE[1] rule273 #-} {-# LINE 557 "./src-ag/DefaultRules.ag" #-} rule273 = \ !pure_ -> {-# LINE 557 "./src-ag/DefaultRules.ag" #-} pure_ {-# LINE 4207 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule274 #-} {-# LINE 624 "./src-ag/DefaultRules.ag" #-} rule274 = \ !_output -> {-# LINE 624 "./src-ag/DefaultRules.ag" #-} mkRuleAlias _output {-# LINE 4213 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule275 #-} {-# LINE 625 "./src-ag/DefaultRules.ag" #-} rule275 = \ ((!_lhsIoptions) :: Options) ((!_lhsIuniq) :: Int) !_output1 -> {-# LINE 625 "./src-ag/DefaultRules.ag" #-} if needsMultiRules _lhsIoptions then multiRule _output1 _lhsIuniq else ([_output1 ], _lhsIuniq) {-# LINE 4221 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule276 #-} {-# LINE 628 "./src-ag/DefaultRules.ag" #-} rule276 = \ !_mbAlias !_outputs -> {-# LINE 628 "./src-ag/DefaultRules.ag" #-} maybe [] return _mbAlias ++ _outputs {-# LINE 4227 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule277 #-} {-# LINE 713 "./src-ag/DefaultRules.ag" #-} rule277 = \ !mbName_ -> {-# LINE 713 "./src-ag/DefaultRules.ag" #-} case mbName_ of Nothing -> Set.empty Just nm -> Set.singleton nm {-# LINE 4235 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule278 #-} rule278 = \ ((!_patternIcontainsVars) :: Bool) -> _patternIcontainsVars {-# NOINLINE[1] rule279 #-} rule279 = \ ((!_patternIdefinedAttrs) :: Set (Identifier,Identifier)) -> _patternIdefinedAttrs {-# NOINLINE[1] rule280 #-} rule280 = \ ((!_patternIerrors) :: Seq Error) -> _patternIerrors {-# NOINLINE[1] rule281 #-} rule281 = \ ((!_patternIlocals) :: Set Identifier) -> _patternIlocals {-# NOINLINE[1] rule282 #-} rule282 = \ ((!_patternIoutput) :: Pattern) !eager_ !explicit_ !identity_ !mbError_ !mbName_ !origin_ !owrt_ !pure_ !rhs_ -> Rule mbName_ _patternIoutput rhs_ owrt_ origin_ explicit_ pure_ identity_ mbError_ eager_ {-# INLINE rule283 #-} rule283 = \ !_output -> _output -- Rules ------------------------------------------------------- -- wrapper data Inh_Rules = Inh_Rules { con_Inh_Rules :: !(ConstructorIdent), nt_Inh_Rules :: !(NontermIdent), options_Inh_Rules :: !(Options), uniq_Inh_Rules :: !(Int) } data Syn_Rules = Syn_Rules { definedAttrs_Syn_Rules :: !(Set (Identifier,Identifier)), errors_Syn_Rules :: !(Seq Error), locals_Syn_Rules :: !(Set Identifier), output_Syn_Rules :: !(Rules), ruleNames_Syn_Rules :: !(Set Identifier), uniq_Syn_Rules :: !(Int) } {-# INLINABLE wrap_Rules #-} wrap_Rules :: T_Rules -> Inh_Rules -> (Syn_Rules ) wrap_Rules !(T_Rules act) !(Inh_Rules _lhsIcon _lhsInt _lhsIoptions _lhsIuniq) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Rules_vIn10 _lhsIcon _lhsInt _lhsIoptions _lhsIuniq !(T_Rules_vOut10 _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput _lhsOruleNames _lhsOuniq) <- return (inv_Rules_s20 sem K_Rules_v10 arg) return (Syn_Rules _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput _lhsOruleNames _lhsOuniq) ) -- cata {-# NOINLINE sem_Rules #-} sem_Rules :: Rules -> T_Rules sem_Rules list = Prelude.foldr sem_Rules_Cons sem_Rules_Nil (Prelude.map sem_Rule list) -- semantic domain newtype T_Rules = T_Rules { attach_T_Rules :: Identity (T_Rules_s20 ) } data T_Rules_s20 where C_Rules_s20 :: { inv_Rules_s20 :: !(forall t. K_Rules_s20 t -> t) } -> T_Rules_s20 data T_Rules_s21 = C_Rules_s21 data T_Rules_s37 = C_Rules_s37 newtype T_Rules_s42 = C_Rules_s42 { inv_Rules_s42 :: (T_Rules_v31 ) } data K_Rules_s20 k where K_Rules_v10 :: K_Rules_s20 (T_Rules_v10 ) K_Rules_v24 :: K_Rules_s20 (T_Rules_v24 ) K_Rules_v30 :: K_Rules_s20 (T_Rules_v30 ) type T_Rules_v10 = (T_Rules_vIn10 ) -> (T_Rules_vOut10 ) data T_Rules_vIn10 = T_Rules_vIn10 !(ConstructorIdent) !(NontermIdent) !(Options) !(Int) data T_Rules_vOut10 = T_Rules_vOut10 !(Set (Identifier,Identifier)) !(Seq Error) !(Set Identifier) !(Rules) !(Set Identifier) !(Int) type T_Rules_v24 = (T_Rules_vIn24 ) -> (T_Rules_vOut24 ) data T_Rules_vIn24 = T_Rules_vIn24 !(Options) !(Int) data T_Rules_vOut24 = T_Rules_vOut24 !(Set (Identifier,Identifier)) !(Seq Error) !(Set Identifier) !(Rules) !(Set Identifier) !(Int) type T_Rules_v30 = (T_Rules_vIn30 ) -> (T_Rules_vOut30 ) data T_Rules_vIn30 = T_Rules_vIn30 data T_Rules_vOut30 = T_Rules_vOut30 !(Set (Identifier,Identifier)) !(Seq Error) !(Set Identifier) !(Set Identifier) !(T_Rules_s42 ) type T_Rules_v31 = (T_Rules_vIn31 ) -> (T_Rules_vOut31 ) data T_Rules_vIn31 = T_Rules_vIn31 !(Options) !(Int) data T_Rules_vOut31 = T_Rules_vOut31 !(Rules) !(Int) {-# NOINLINE sem_Rules_Cons #-} sem_Rules_Cons :: T_Rule -> T_Rules -> T_Rules sem_Rules_Cons arg_hd_ arg_tl_ = T_Rules (return st20) where {-# NOINLINE st20 #-} !st20 = let k20 :: K_Rules_s20 t -> t k20 K_Rules_v10 = v10 k20 K_Rules_v24 = v24 k20 K_Rules_v30 = v30 v10 :: T_Rules_v10 v10 = \ !(T_Rules_vIn10 _lhsIcon _lhsInt _lhsIoptions _lhsIuniq) -> ( let !_hdX18 = Control.Monad.Identity.runIdentity (attach_T_Rule (arg_hd_)) in let !_tlX20 = Control.Monad.Identity.runIdentity (attach_T_Rules (arg_tl_)) in let !_hdOoptions = rule295 _lhsIoptions in let !_hdOuniq = rule296 _lhsIuniq in let !_tlOoptions = rule299 _lhsIoptions in let !(T_Rule_vOut29 _hdIcontainsVars _hdIdefinedAttrs _hdIerrors _hdIisPure _hdIlocals _hdIoutputs _hdIruleNames _hdIuniq) = inv_Rule_s18 _hdX18 K_Rule_v29 (T_Rule_vIn29 _hdOoptions _hdOuniq) in let !(T_Rules_vOut30 _tlIdefinedAttrs _tlIerrors _tlIlocals _tlIruleNames _tlX42) = inv_Rules_s20 _tlX20 K_Rules_v30 (T_Rules_vIn30 ) in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule287 _hdIdefinedAttrs _tlIdefinedAttrs in let _lhsOerrors :: Seq Error !_lhsOerrors = rule288 _hdIerrors _tlIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule289 _hdIlocals _tlIlocals in let !_tlOuniq = rule300 _hdIuniq in let _lhsOruleNames :: Set Identifier !_lhsOruleNames = rule290 _hdIruleNames _tlIruleNames in let !(T_Rules_vOut31 _tlIoutput _tlIuniq) = inv_Rules_s42 _tlX42 (T_Rules_vIn31 _tlOoptions _tlOuniq) in let _lhsOoutput :: Rules !_lhsOoutput = rule286 _hdIcontainsVars _hdIisPure _hdIoutputs _tlIoutput in let _lhsOuniq :: Int !_lhsOuniq = rule292 _tlIuniq in let !__result_ = T_Rules_vOut10 _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput _lhsOruleNames _lhsOuniq in __result_ ) v24 :: T_Rules_v24 v24 = \ !(T_Rules_vIn24 _lhsIoptions _lhsIuniq) -> ( let !_hdX18 = Control.Monad.Identity.runIdentity (attach_T_Rule (arg_hd_)) in let !_tlX20 = Control.Monad.Identity.runIdentity (attach_T_Rules (arg_tl_)) in let !_hdOoptions = rule295 _lhsIoptions in let !_hdOuniq = rule296 _lhsIuniq in let !_tlOoptions = rule299 _lhsIoptions in let !(T_Rule_vOut29 _hdIcontainsVars _hdIdefinedAttrs _hdIerrors _hdIisPure _hdIlocals _hdIoutputs _hdIruleNames _hdIuniq) = inv_Rule_s18 _hdX18 K_Rule_v29 (T_Rule_vIn29 _hdOoptions _hdOuniq) in let !(T_Rules_vOut30 _tlIdefinedAttrs _tlIerrors _tlIlocals _tlIruleNames _tlX42) = inv_Rules_s20 _tlX20 K_Rules_v30 (T_Rules_vIn30 ) in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule287 _hdIdefinedAttrs _tlIdefinedAttrs in let _lhsOerrors :: Seq Error !_lhsOerrors = rule288 _hdIerrors _tlIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule289 _hdIlocals _tlIlocals in let !_tlOuniq = rule300 _hdIuniq in let _lhsOruleNames :: Set Identifier !_lhsOruleNames = rule290 _hdIruleNames _tlIruleNames in let !(T_Rules_vOut31 _tlIoutput _tlIuniq) = inv_Rules_s42 _tlX42 (T_Rules_vIn31 _tlOoptions _tlOuniq) in let _lhsOoutput :: Rules !_lhsOoutput = rule286 _hdIcontainsVars _hdIisPure _hdIoutputs _tlIoutput in let _lhsOuniq :: Int !_lhsOuniq = rule292 _tlIuniq in let !__result_ = T_Rules_vOut24 _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput _lhsOruleNames _lhsOuniq in __result_ ) v30 :: T_Rules_v30 v30 = \ !(T_Rules_vIn30 ) -> ( let !_hdX18 = Control.Monad.Identity.runIdentity (attach_T_Rule (arg_hd_)) in let !_tlX20 = Control.Monad.Identity.runIdentity (attach_T_Rules (arg_tl_)) in let !(T_Rule_vOut43 _hdIdefinedAttrs _hdIerrors _hdIlocals _hdIruleNames _hdX51) = inv_Rule_s18 _hdX18 K_Rule_v43 (T_Rule_vIn43 ) in let !(T_Rules_vOut30 _tlIdefinedAttrs _tlIerrors _tlIlocals _tlIruleNames _tlX42) = inv_Rules_s20 _tlX20 K_Rules_v30 (T_Rules_vIn30 ) in let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule287 _hdIdefinedAttrs _tlIdefinedAttrs in let _lhsOerrors :: Seq Error !_lhsOerrors = rule288 _hdIerrors _tlIerrors in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule289 _hdIlocals _tlIlocals in let _lhsOruleNames :: Set Identifier !_lhsOruleNames = rule290 _hdIruleNames _tlIruleNames in let !__st_ = st42 _hdX51 _tlX42 !__result_ = T_Rules_vOut30 _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOruleNames __st_ in __result_ ) in C_Rules_s20 k20 {-# NOINLINE st42 #-} st42 = \ !_hdX51 !_tlX42 -> let v31 :: T_Rules_v31 v31 = \ !(T_Rules_vIn31 _lhsIoptions _lhsIuniq) -> ( let !_hdOoptions = rule295 _lhsIoptions in let !_hdOuniq = rule296 _lhsIuniq in let !_tlOoptions = rule299 _lhsIoptions in let !(T_Rule_vOut44 _hdIcontainsVars _hdIisPure _hdIoutputs _hdIuniq) = inv_Rule_s51 _hdX51 (T_Rule_vIn44 _hdOoptions _hdOuniq) in let !_tlOuniq = rule300 _hdIuniq in let !(T_Rules_vOut31 _tlIoutput _tlIuniq) = inv_Rules_s42 _tlX42 (T_Rules_vIn31 _tlOoptions _tlOuniq) in let _lhsOoutput :: Rules !_lhsOoutput = rule286 _hdIcontainsVars _hdIisPure _hdIoutputs _tlIoutput in let _lhsOuniq :: Int !_lhsOuniq = rule292 _tlIuniq in let !__result_ = T_Rules_vOut31 _lhsOoutput _lhsOuniq in __result_ ) in C_Rules_s42 v31 {-# NOINLINE[1] rule286 #-} {-# LINE 620 "./src-ag/DefaultRules.ag" #-} rule286 = \ ((!_hdIcontainsVars) :: Bool) ((!_hdIisPure) :: Bool) ((!_hdIoutputs) :: Rules) ((!_tlIoutput) :: Rules) -> {-# LINE 620 "./src-ag/DefaultRules.ag" #-} if _hdIcontainsVars && _hdIisPure then _hdIoutputs ++ _tlIoutput else _tlIoutput {-# LINE 4401 "dist/build/DefaultRules.hs"#-} {-# NOINLINE[1] rule287 #-} rule287 = \ ((!_hdIdefinedAttrs) :: Set (Identifier,Identifier)) ((!_tlIdefinedAttrs) :: Set (Identifier,Identifier)) -> _hdIdefinedAttrs `Set.union` _tlIdefinedAttrs {-# NOINLINE[1] rule288 #-} rule288 = \ ((!_hdIerrors) :: Seq Error) ((!_tlIerrors) :: Seq Error) -> _hdIerrors Seq.>< _tlIerrors {-# NOINLINE[1] rule289 #-} rule289 = \ ((!_hdIlocals) :: Set Identifier) ((!_tlIlocals) :: Set Identifier) -> _hdIlocals `Set.union` _tlIlocals {-# NOINLINE[1] rule290 #-} rule290 = \ ((!_hdIruleNames) :: Set Identifier) ((!_tlIruleNames) :: Set Identifier) -> _hdIruleNames `Set.union` _tlIruleNames {-# NOINLINE[1] rule292 #-} rule292 = \ ((!_tlIuniq) :: Int) -> _tlIuniq {-# NOINLINE[1] rule295 #-} rule295 = \ ((!_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE[1] rule296 #-} rule296 = \ ((!_lhsIuniq) :: Int) -> _lhsIuniq {-# NOINLINE[1] rule299 #-} rule299 = \ ((!_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE[1] rule300 #-} rule300 = \ ((!_hdIuniq) :: Int) -> _hdIuniq {-# NOINLINE sem_Rules_Nil #-} sem_Rules_Nil :: T_Rules sem_Rules_Nil = T_Rules (return st20) where {-# NOINLINE st20 #-} !st20 = let k20 :: K_Rules_s20 t -> t k20 K_Rules_v10 = v10 k20 K_Rules_v24 = v24 k20 K_Rules_v30 = v30 v10 :: T_Rules_v10 v10 = \ !(T_Rules_vIn10 _lhsIcon _lhsInt _lhsIoptions _lhsIuniq) -> ( let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule301 () in let _lhsOerrors :: Seq Error !_lhsOerrors = rule302 () in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule303 () in let !_output = rule305 () in let _lhsOruleNames :: Set Identifier !_lhsOruleNames = rule304 () in let _lhsOoutput :: Rules !_lhsOoutput = rule306 _output in let _lhsOuniq :: Int !_lhsOuniq = rule307 _lhsIuniq in let !__result_ = T_Rules_vOut10 _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput _lhsOruleNames _lhsOuniq in __result_ ) v24 :: T_Rules_v24 v24 = \ !(T_Rules_vIn24 _lhsIoptions _lhsIuniq) -> ( let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule301 () in let _lhsOerrors :: Seq Error !_lhsOerrors = rule302 () in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule303 () in let !_output = rule305 () in let _lhsOruleNames :: Set Identifier !_lhsOruleNames = rule304 () in let _lhsOoutput :: Rules !_lhsOoutput = rule306 _output in let _lhsOuniq :: Int !_lhsOuniq = rule307 _lhsIuniq in let !__result_ = T_Rules_vOut24 _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOoutput _lhsOruleNames _lhsOuniq in __result_ ) v30 :: T_Rules_v30 v30 = \ !(T_Rules_vIn30 ) -> ( let _lhsOdefinedAttrs :: Set (Identifier,Identifier) !_lhsOdefinedAttrs = rule301 () in let _lhsOerrors :: Seq Error !_lhsOerrors = rule302 () in let _lhsOlocals :: Set Identifier !_lhsOlocals = rule303 () in let _lhsOruleNames :: Set Identifier !_lhsOruleNames = rule304 () in let !__st_ = st42 () !__result_ = T_Rules_vOut30 _lhsOdefinedAttrs _lhsOerrors _lhsOlocals _lhsOruleNames __st_ in __result_ ) in C_Rules_s20 k20 {-# NOINLINE st42 #-} st42 = \ (_ :: ()) -> let v31 :: T_Rules_v31 v31 = \ !(T_Rules_vIn31 _lhsIoptions _lhsIuniq) -> ( let !_output = rule305 () in let _lhsOoutput :: Rules !_lhsOoutput = rule306 _output in let _lhsOuniq :: Int !_lhsOuniq = rule307 _lhsIuniq in let !__result_ = T_Rules_vOut31 _lhsOoutput _lhsOuniq in __result_ ) in C_Rules_s42 v31 {-# NOINLINE[1] rule301 #-} rule301 = \ (_ :: ()) -> Set.empty {-# NOINLINE[1] rule302 #-} rule302 = \ (_ :: ()) -> Seq.empty {-# NOINLINE[1] rule303 #-} rule303 = \ (_ :: ()) -> Set.empty {-# NOINLINE[1] rule304 #-} rule304 = \ (_ :: ()) -> Set.empty {-# NOINLINE[1] rule305 #-} rule305 = \ (_ :: ()) -> [] {-# NOINLINE[1] rule306 #-} rule306 = \ !_output -> _output {-# NOINLINE[1] rule307 #-} rule307 = \ ((!_lhsIuniq) :: Int) -> _lhsIuniq -- TypeSig ----------------------------------------------------- -- wrapper data Inh_TypeSig = Inh_TypeSig { nt_Inh_TypeSig :: !(NontermIdent), params_Inh_TypeSig :: !([Identifier]) } data Syn_TypeSig = Syn_TypeSig { output_Syn_TypeSig :: !(TypeSig) } {-# INLINABLE wrap_TypeSig #-} wrap_TypeSig :: T_TypeSig -> Inh_TypeSig -> (Syn_TypeSig ) wrap_TypeSig !(T_TypeSig act) !(Inh_TypeSig _lhsInt _lhsIparams) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_TypeSig_vIn11 _lhsInt _lhsIparams !(T_TypeSig_vOut11 _lhsOoutput) <- return (inv_TypeSig_s22 sem arg) return (Syn_TypeSig _lhsOoutput) ) -- cata {-# INLINE sem_TypeSig #-} sem_TypeSig :: TypeSig -> T_TypeSig sem_TypeSig ( TypeSig !name_ !tp_ ) = sem_TypeSig_TypeSig name_ tp_ -- semantic domain newtype T_TypeSig = T_TypeSig { attach_T_TypeSig :: Identity (T_TypeSig_s22 ) } newtype T_TypeSig_s22 = C_TypeSig_s22 { inv_TypeSig_s22 :: (T_TypeSig_v11 ) } data T_TypeSig_s23 = C_TypeSig_s23 type T_TypeSig_v11 = (T_TypeSig_vIn11 ) -> (T_TypeSig_vOut11 ) data T_TypeSig_vIn11 = T_TypeSig_vIn11 !(NontermIdent) !([Identifier]) data T_TypeSig_vOut11 = T_TypeSig_vOut11 !(TypeSig) {-# NOINLINE sem_TypeSig_TypeSig #-} sem_TypeSig_TypeSig :: (Identifier) -> (Type) -> T_TypeSig sem_TypeSig_TypeSig !arg_name_ !arg_tp_ = T_TypeSig (return st22) where {-# NOINLINE st22 #-} !st22 = let v11 :: T_TypeSig_v11 v11 = \ !(T_TypeSig_vIn11 _lhsInt _lhsIparams) -> ( let !_tp1 = rule308 _lhsInt _lhsIparams arg_tp_ in let _lhsOoutput :: TypeSig !_lhsOoutput = rule309 _tp1 arg_name_ in let !__result_ = T_TypeSig_vOut11 _lhsOoutput in __result_ ) in C_TypeSig_s22 v11 {-# INLINE rule308 #-} {-# LINE 576 "./src-ag/DefaultRules.ag" #-} rule308 = \ ((!_lhsInt) :: NontermIdent) ((!_lhsIparams) :: [Identifier]) !tp_ -> {-# LINE 576 "./src-ag/DefaultRules.ag" #-} elimSelfId _lhsInt _lhsIparams tp_ {-# LINE 4568 "dist/build/DefaultRules.hs"#-} {-# INLINE rule309 #-} {-# LINE 617 "./src-ag/DefaultRules.ag" #-} rule309 = \ !_tp1 !name_ -> {-# LINE 617 "./src-ag/DefaultRules.ag" #-} TypeSig name_ _tp1 {-# LINE 4574 "dist/build/DefaultRules.hs"#-} -- TypeSigs ---------------------------------------------------- -- wrapper data Inh_TypeSigs = Inh_TypeSigs { nt_Inh_TypeSigs :: !(NontermIdent), params_Inh_TypeSigs :: !([Identifier]) } data Syn_TypeSigs = Syn_TypeSigs { output_Syn_TypeSigs :: !(TypeSigs) } {-# INLINABLE wrap_TypeSigs #-} wrap_TypeSigs :: T_TypeSigs -> Inh_TypeSigs -> (Syn_TypeSigs ) wrap_TypeSigs !(T_TypeSigs act) !(Inh_TypeSigs _lhsInt _lhsIparams) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_TypeSigs_vIn12 _lhsInt _lhsIparams !(T_TypeSigs_vOut12 _lhsOoutput) <- return (inv_TypeSigs_s24 sem arg) return (Syn_TypeSigs _lhsOoutput) ) -- cata {-# NOINLINE sem_TypeSigs #-} sem_TypeSigs :: TypeSigs -> T_TypeSigs sem_TypeSigs list = Prelude.foldr sem_TypeSigs_Cons sem_TypeSigs_Nil (Prelude.map sem_TypeSig list) -- semantic domain newtype T_TypeSigs = T_TypeSigs { attach_T_TypeSigs :: Identity (T_TypeSigs_s24 ) } newtype T_TypeSigs_s24 = C_TypeSigs_s24 { inv_TypeSigs_s24 :: (T_TypeSigs_v12 ) } data T_TypeSigs_s25 = C_TypeSigs_s25 type T_TypeSigs_v12 = (T_TypeSigs_vIn12 ) -> (T_TypeSigs_vOut12 ) data T_TypeSigs_vIn12 = T_TypeSigs_vIn12 !(NontermIdent) !([Identifier]) data T_TypeSigs_vOut12 = T_TypeSigs_vOut12 !(TypeSigs) {-# NOINLINE sem_TypeSigs_Cons #-} sem_TypeSigs_Cons :: T_TypeSig -> T_TypeSigs -> T_TypeSigs sem_TypeSigs_Cons arg_hd_ arg_tl_ = T_TypeSigs (return st24) where {-# NOINLINE st24 #-} !st24 = let v12 :: T_TypeSigs_v12 v12 = \ !(T_TypeSigs_vIn12 _lhsInt _lhsIparams) -> ( let !_hdX22 = Control.Monad.Identity.runIdentity (attach_T_TypeSig (arg_hd_)) in let !_tlX24 = Control.Monad.Identity.runIdentity (attach_T_TypeSigs (arg_tl_)) in let !_hdOnt = rule313 _lhsInt in let !_hdOparams = rule314 _lhsIparams in let !_tlOnt = rule315 _lhsInt in let !_tlOparams = rule316 _lhsIparams in let !(T_TypeSig_vOut11 _hdIoutput) = inv_TypeSig_s22 _hdX22 (T_TypeSig_vIn11 _hdOnt _hdOparams) in let !(T_TypeSigs_vOut12 _tlIoutput) = inv_TypeSigs_s24 _tlX24 (T_TypeSigs_vIn12 _tlOnt _tlOparams) in let !_output = rule311 _hdIoutput _tlIoutput in let _lhsOoutput :: TypeSigs !_lhsOoutput = rule312 _output in let !__result_ = T_TypeSigs_vOut12 _lhsOoutput in __result_ ) in C_TypeSigs_s24 v12 {-# INLINE rule311 #-} rule311 = \ ((!_hdIoutput) :: TypeSig) ((!_tlIoutput) :: TypeSigs) -> (:) _hdIoutput _tlIoutput {-# INLINE rule312 #-} rule312 = \ !_output -> _output {-# INLINE rule313 #-} rule313 = \ ((!_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule314 #-} rule314 = \ ((!_lhsIparams) :: [Identifier]) -> _lhsIparams {-# INLINE rule315 #-} rule315 = \ ((!_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule316 #-} rule316 = \ ((!_lhsIparams) :: [Identifier]) -> _lhsIparams {-# NOINLINE sem_TypeSigs_Nil #-} sem_TypeSigs_Nil :: T_TypeSigs sem_TypeSigs_Nil = T_TypeSigs (return st24) where {-# NOINLINE st24 #-} !st24 = let v12 :: T_TypeSigs_v12 v12 = \ !(T_TypeSigs_vIn12 _lhsInt _lhsIparams) -> ( let !_output = rule317 () in let _lhsOoutput :: TypeSigs !_lhsOoutput = rule318 _output in let !__result_ = T_TypeSigs_vOut12 _lhsOoutput in __result_ ) in C_TypeSigs_s24 v12 {-# INLINE rule317 #-} rule317 = \ (_ :: ()) -> [] {-# INLINE rule318 #-} rule318 = \ !_output -> _output uuagc-0.9.42.3/src-generated/Desugar.hs000644 000765 000024 00000740172 12127045231 021532 0ustar00jeroenbransenstaff000000 000000 {-# LANGUAGE Rank2Types, GADTs #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} module Desugar where {-# LINE 2 "./src-ag/AbstractSyntax.ag" #-} -- 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 {-# LINE 17 "dist/build/Desugar.hs" #-} {-# LINE 2 "./src-ag/Patterns.ag" #-} -- Patterns.ag imports import UU.Scanner.Position(Pos) import CommonTypes (ConstructorIdent,Identifier) {-# LINE 24 "dist/build/Desugar.hs" #-} {-# LINE 2 "./src-ag/Expression.ag" #-} import UU.Scanner.Position(Pos) import HsToken {-# LINE 30 "dist/build/Desugar.hs" #-} {-# LINE 2 "./src-ag/HsToken.ag" #-} import CommonTypes import UU.Scanner.Position(Pos) {-# LINE 36 "dist/build/Desugar.hs" #-} {-# LINE 14 "./src-ag/Desugar.ag" #-} 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 {-# LINE 56 "dist/build/Desugar.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 98 "./src-ag/Desugar.ag" #-} addl :: Int -> Pos -> Pos addl n (Pos l c f) = Pos (l+n) c f {-# LINE 63 "dist/build/Desugar.hs" #-} {-# LINE 133 "./src-ag/Desugar.ag" #-} 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 {-# LINE 78 "dist/build/Desugar.hs" #-} {-# LINE 204 "./src-ag/Desugar.ag" #-} mergeAttributes :: AttrMap -> AttrMap -> AttrMap mergeAttributes = Map.unionWith $ Map.unionWith $ Set.union {-# LINE 84 "dist/build/Desugar.hs" #-} {-# LINE 251 "./src-ag/Desugar.ag" #-} 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 {-# LINE 110 "dist/build/Desugar.hs" #-} {-# LINE 294 "./src-ag/Desugar.ag" #-} addLateAttr :: Options -> String -> Attributes addLateAttr options mainName | kennedyWarren options && lateHigherOrderBinding options = let tp = lateBindingType mainName in Map.singleton idLateBindingAttr tp | otherwise = Map.empty {-# LINE 120 "dist/build/Desugar.hs" #-} -- Child ------------------------------------------------------- -- wrapper data Inh_Child = Inh_Child { inhMap_Inh_Child :: !(Map Identifier Attributes), mainName_Inh_Child :: !(String), options_Inh_Child :: !(Options), synMap_Inh_Child :: !(Map Identifier Attributes) } data Syn_Child = Syn_Child { childInhs_Syn_Child :: !([(Identifier, Identifier)]), childSyns_Syn_Child :: !([(Identifier, Identifier)]), output_Syn_Child :: !(Child) } {-# INLINABLE wrap_Child #-} wrap_Child :: T_Child -> Inh_Child -> (Syn_Child ) wrap_Child !(T_Child act) !(Inh_Child _lhsIinhMap _lhsImainName _lhsIoptions _lhsIsynMap) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Child_vIn0 _lhsIinhMap _lhsImainName _lhsIoptions _lhsIsynMap !(T_Child_vOut0 _lhsOchildInhs _lhsOchildSyns _lhsOoutput) <- return (inv_Child_s0 sem K_Child_v0 arg) return (Syn_Child _lhsOchildInhs _lhsOchildSyns _lhsOoutput) ) -- cata {-# INLINE sem_Child #-} sem_Child :: Child -> T_Child sem_Child ( Child !name_ !tp_ !kind_ ) = sem_Child_Child name_ tp_ kind_ -- semantic domain newtype T_Child = T_Child { attach_T_Child :: Identity (T_Child_s0 ) } data T_Child_s0 where C_Child_s0 :: { inv_Child_s0 :: !(forall t. K_Child_s0 t -> t) } -> T_Child_s0 data T_Child_s1 = C_Child_s1 data T_Child_s34 = C_Child_s34 data K_Child_s0 k where K_Child_v0 :: K_Child_s0 (T_Child_v0 ) K_Child_v17 :: K_Child_s0 (T_Child_v17 ) type T_Child_v0 = (T_Child_vIn0 ) -> (T_Child_vOut0 ) data T_Child_vIn0 = T_Child_vIn0 !(Map Identifier Attributes) !(String) !(Options) !(Map Identifier Attributes) data T_Child_vOut0 = T_Child_vOut0 !([(Identifier, Identifier)]) !([(Identifier, Identifier)]) !(Child) type T_Child_v17 = (T_Child_vIn17 ) -> (T_Child_vOut17 ) data T_Child_vIn17 = T_Child_vIn17 !(Map Identifier Attributes) !(Map Identifier Attributes) data T_Child_vOut17 = T_Child_vOut17 !([(Identifier, Identifier)]) !([(Identifier, Identifier)]) !(Child) {-# NOINLINE sem_Child_Child #-} sem_Child_Child :: (Identifier) -> (Type) -> (ChildKind) -> T_Child sem_Child_Child !arg_name_ !arg_tp_ !arg_kind_ = T_Child (return st0) where {-# NOINLINE st0 #-} !st0 = let k0 :: K_Child_s0 t -> t k0 K_Child_v0 = v0 k0 K_Child_v17 = v17 v0 :: T_Child_v0 v0 = \ !(T_Child_vIn0 _lhsIinhMap _lhsImainName _lhsIoptions _lhsIsynMap) -> ( let !_chnt = rule0 arg_name_ arg_tp_ in let !_inh = rule1 _chnt _lhsIinhMap in let _lhsOchildInhs :: [(Identifier, Identifier)] !_lhsOchildInhs = rule3 _inh arg_name_ in let !_syn = rule2 _chnt _lhsIsynMap in let _lhsOchildSyns :: [(Identifier, Identifier)] !_lhsOchildSyns = rule4 _syn arg_name_ in let _lhsOoutput :: Child !_lhsOoutput = rule5 arg_kind_ arg_name_ arg_tp_ in let !__result_ = T_Child_vOut0 _lhsOchildInhs _lhsOchildSyns _lhsOoutput in __result_ ) v17 :: T_Child_v17 v17 = \ !(T_Child_vIn17 _lhsIinhMap _lhsIsynMap) -> ( let !_chnt = rule0 arg_name_ arg_tp_ in let !_inh = rule1 _chnt _lhsIinhMap in let _lhsOchildInhs :: [(Identifier, Identifier)] !_lhsOchildInhs = rule3 _inh arg_name_ in let !_syn = rule2 _chnt _lhsIsynMap in let _lhsOchildSyns :: [(Identifier, Identifier)] !_lhsOchildSyns = rule4 _syn arg_name_ in let _lhsOoutput :: Child !_lhsOoutput = rule5 arg_kind_ arg_name_ arg_tp_ in let !__result_ = T_Child_vOut17 _lhsOchildInhs _lhsOchildSyns _lhsOoutput in __result_ ) in C_Child_s0 k0 {-# NOINLINE[1] rule0 #-} {-# LINE 19 "./src-ag/DistChildAttr.ag" #-} rule0 = \ !name_ !tp_ -> {-# LINE 19 "./src-ag/DistChildAttr.ag" #-} case tp_ of NT nt _ _ -> nt Self -> error ("The type of child " ++ show name_ ++ " should not be a Self type.") Haskell t -> identifier "" {-# LINE 201 "dist/build/Desugar.hs"#-} {-# NOINLINE[1] rule1 #-} {-# LINE 23 "./src-ag/DistChildAttr.ag" #-} rule1 = \ !_chnt ((!_lhsIinhMap) :: Map Identifier Attributes) -> {-# LINE 23 "./src-ag/DistChildAttr.ag" #-} Map.findWithDefault Map.empty _chnt _lhsIinhMap {-# LINE 207 "dist/build/Desugar.hs"#-} {-# NOINLINE[1] rule2 #-} {-# LINE 24 "./src-ag/DistChildAttr.ag" #-} rule2 = \ !_chnt ((!_lhsIsynMap) :: Map Identifier Attributes) -> {-# LINE 24 "./src-ag/DistChildAttr.ag" #-} Map.findWithDefault Map.empty _chnt _lhsIsynMap {-# LINE 213 "dist/build/Desugar.hs"#-} {-# NOINLINE[1] rule3 #-} {-# LINE 130 "./src-ag/Desugar.ag" #-} rule3 = \ !_inh !name_ -> {-# LINE 130 "./src-ag/Desugar.ag" #-} [(i, name_) | i <- Map.keys _inh ] {-# LINE 219 "dist/build/Desugar.hs"#-} {-# NOINLINE[1] rule4 #-} {-# LINE 131 "./src-ag/Desugar.ag" #-} rule4 = \ !_syn !name_ -> {-# LINE 131 "./src-ag/Desugar.ag" #-} [(s, name_) | s <- Map.keys _syn ] {-# LINE 225 "dist/build/Desugar.hs"#-} {-# NOINLINE[1] rule5 #-} {-# LINE 315 "./src-ag/Desugar.ag" #-} rule5 = \ !kind_ !name_ !tp_ -> {-# LINE 315 "./src-ag/Desugar.ag" #-} Child name_ tp_ kind_ {-# LINE 231 "dist/build/Desugar.hs"#-} -- Children ---------------------------------------------------- -- wrapper data Inh_Children = Inh_Children { inhMap_Inh_Children :: !(Map Identifier Attributes), mainName_Inh_Children :: !(String), options_Inh_Children :: !(Options), synMap_Inh_Children :: !(Map Identifier Attributes) } data Syn_Children = Syn_Children { childInhs_Syn_Children :: !([(Identifier, Identifier)]), childSyns_Syn_Children :: !([(Identifier, Identifier)]), output_Syn_Children :: !(Children) } {-# INLINABLE wrap_Children #-} wrap_Children :: T_Children -> Inh_Children -> (Syn_Children ) wrap_Children !(T_Children act) !(Inh_Children _lhsIinhMap _lhsImainName _lhsIoptions _lhsIsynMap) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Children_vIn1 _lhsIinhMap _lhsImainName _lhsIoptions _lhsIsynMap !(T_Children_vOut1 _lhsOchildInhs _lhsOchildSyns _lhsOoutput) <- return (inv_Children_s2 sem K_Children_v1 arg) return (Syn_Children _lhsOchildInhs _lhsOchildSyns _lhsOoutput) ) -- cata {-# NOINLINE sem_Children #-} sem_Children :: Children -> T_Children sem_Children list = Prelude.foldr sem_Children_Cons sem_Children_Nil (Prelude.map sem_Child list) -- semantic domain newtype T_Children = T_Children { attach_T_Children :: Identity (T_Children_s2 ) } data T_Children_s2 where C_Children_s2 :: { inv_Children_s2 :: !(forall t. K_Children_s2 t -> t) } -> T_Children_s2 data T_Children_s3 = C_Children_s3 data T_Children_s35 = C_Children_s35 data K_Children_s2 k where K_Children_v1 :: K_Children_s2 (T_Children_v1 ) K_Children_v18 :: K_Children_s2 (T_Children_v18 ) type T_Children_v1 = (T_Children_vIn1 ) -> (T_Children_vOut1 ) data T_Children_vIn1 = T_Children_vIn1 !(Map Identifier Attributes) !(String) !(Options) !(Map Identifier Attributes) data T_Children_vOut1 = T_Children_vOut1 !([(Identifier, Identifier)]) !([(Identifier, Identifier)]) !(Children) type T_Children_v18 = (T_Children_vIn18 ) -> (T_Children_vOut18 ) data T_Children_vIn18 = T_Children_vIn18 !(Map Identifier Attributes) !(Map Identifier Attributes) data T_Children_vOut18 = T_Children_vOut18 !([(Identifier, Identifier)]) !([(Identifier, Identifier)]) !(Children) {-# NOINLINE sem_Children_Cons #-} sem_Children_Cons :: T_Child -> T_Children -> T_Children sem_Children_Cons arg_hd_ arg_tl_ = T_Children (return st2) where {-# NOINLINE st2 #-} !st2 = let k2 :: K_Children_s2 t -> t k2 K_Children_v1 = v1 k2 K_Children_v18 = v18 v1 :: T_Children_v1 v1 = \ !(T_Children_vIn1 _lhsIinhMap _lhsImainName _lhsIoptions _lhsIsynMap) -> ( let !_hdX0 = Control.Monad.Identity.runIdentity (attach_T_Child (arg_hd_)) in let !_tlX2 = Control.Monad.Identity.runIdentity (attach_T_Children (arg_tl_)) in let !_hdOinhMap = rule11 _lhsIinhMap in let !_tlOinhMap = rule15 _lhsIinhMap in let !_hdOsynMap = rule14 _lhsIsynMap in let !_tlOsynMap = rule18 _lhsIsynMap in let !(T_Child_vOut17 _hdIchildInhs _hdIchildSyns _hdIoutput) = inv_Child_s0 _hdX0 K_Child_v17 (T_Child_vIn17 _hdOinhMap _hdOsynMap) in let !(T_Children_vOut18 _tlIchildInhs _tlIchildSyns _tlIoutput) = inv_Children_s2 _tlX2 K_Children_v18 (T_Children_vIn18 _tlOinhMap _tlOsynMap) in let _lhsOchildInhs :: [(Identifier, Identifier)] !_lhsOchildInhs = rule7 _hdIchildInhs _tlIchildInhs in let _lhsOchildSyns :: [(Identifier, Identifier)] !_lhsOchildSyns = rule8 _hdIchildSyns _tlIchildSyns in let !_output = rule9 _hdIoutput _tlIoutput in let _lhsOoutput :: Children !_lhsOoutput = rule10 _output in let !__result_ = T_Children_vOut1 _lhsOchildInhs _lhsOchildSyns _lhsOoutput in __result_ ) v18 :: T_Children_v18 v18 = \ !(T_Children_vIn18 _lhsIinhMap _lhsIsynMap) -> ( let !_hdX0 = Control.Monad.Identity.runIdentity (attach_T_Child (arg_hd_)) in let !_tlX2 = Control.Monad.Identity.runIdentity (attach_T_Children (arg_tl_)) in let !_hdOinhMap = rule11 _lhsIinhMap in let !_tlOinhMap = rule15 _lhsIinhMap in let !_hdOsynMap = rule14 _lhsIsynMap in let !_tlOsynMap = rule18 _lhsIsynMap in let !(T_Child_vOut17 _hdIchildInhs _hdIchildSyns _hdIoutput) = inv_Child_s0 _hdX0 K_Child_v17 (T_Child_vIn17 _hdOinhMap _hdOsynMap) in let !(T_Children_vOut18 _tlIchildInhs _tlIchildSyns _tlIoutput) = inv_Children_s2 _tlX2 K_Children_v18 (T_Children_vIn18 _tlOinhMap _tlOsynMap) in let _lhsOchildInhs :: [(Identifier, Identifier)] !_lhsOchildInhs = rule7 _hdIchildInhs _tlIchildInhs in let _lhsOchildSyns :: [(Identifier, Identifier)] !_lhsOchildSyns = rule8 _hdIchildSyns _tlIchildSyns in let !_output = rule9 _hdIoutput _tlIoutput in let _lhsOoutput :: Children !_lhsOoutput = rule10 _output in let !__result_ = T_Children_vOut18 _lhsOchildInhs _lhsOchildSyns _lhsOoutput in __result_ ) in C_Children_s2 k2 {-# NOINLINE[1] rule7 #-} rule7 = \ ((!_hdIchildInhs) :: [(Identifier, Identifier)]) ((!_tlIchildInhs) :: [(Identifier, Identifier)]) -> _hdIchildInhs ++ _tlIchildInhs {-# NOINLINE[1] rule8 #-} rule8 = \ ((!_hdIchildSyns) :: [(Identifier, Identifier)]) ((!_tlIchildSyns) :: [(Identifier, Identifier)]) -> _hdIchildSyns ++ _tlIchildSyns {-# NOINLINE[1] rule9 #-} rule9 = \ ((!_hdIoutput) :: Child) ((!_tlIoutput) :: Children) -> (:) _hdIoutput _tlIoutput {-# NOINLINE[1] rule10 #-} rule10 = \ !_output -> _output {-# NOINLINE[1] rule11 #-} rule11 = \ ((!_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# NOINLINE[1] rule14 #-} rule14 = \ ((!_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# NOINLINE[1] rule15 #-} rule15 = \ ((!_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# NOINLINE[1] rule18 #-} rule18 = \ ((!_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# NOINLINE sem_Children_Nil #-} sem_Children_Nil :: T_Children sem_Children_Nil = T_Children (return st2) where {-# NOINLINE st2 #-} !st2 = let k2 :: K_Children_s2 t -> t k2 K_Children_v1 = v1 k2 K_Children_v18 = v18 v1 :: T_Children_v1 v1 = \ !(T_Children_vIn1 _lhsIinhMap _lhsImainName _lhsIoptions _lhsIsynMap) -> ( let _lhsOchildInhs :: [(Identifier, Identifier)] !_lhsOchildInhs = rule19 () in let _lhsOchildSyns :: [(Identifier, Identifier)] !_lhsOchildSyns = rule20 () in let !_output = rule21 () in let _lhsOoutput :: Children !_lhsOoutput = rule22 _output in let !__result_ = T_Children_vOut1 _lhsOchildInhs _lhsOchildSyns _lhsOoutput in __result_ ) v18 :: T_Children_v18 v18 = \ !(T_Children_vIn18 _lhsIinhMap _lhsIsynMap) -> ( let _lhsOchildInhs :: [(Identifier, Identifier)] !_lhsOchildInhs = rule19 () in let _lhsOchildSyns :: [(Identifier, Identifier)] !_lhsOchildSyns = rule20 () in let !_output = rule21 () in let _lhsOoutput :: Children !_lhsOoutput = rule22 _output in let !__result_ = T_Children_vOut18 _lhsOchildInhs _lhsOchildSyns _lhsOoutput in __result_ ) in C_Children_s2 k2 {-# NOINLINE[1] rule19 #-} rule19 = \ (_ :: ()) -> [] {-# NOINLINE[1] rule20 #-} rule20 = \ (_ :: ()) -> [] {-# NOINLINE[1] rule21 #-} rule21 = \ (_ :: ()) -> [] {-# NOINLINE[1] rule22 #-} rule22 = \ !_output -> _output -- Expression -------------------------------------------------- -- wrapper data Inh_Expression = Inh_Expression { childInhs_Inh_Expression :: !([(Identifier, Identifier)]), childSyns_Inh_Expression :: !([(Identifier, Identifier)]), con_Inh_Expression :: !(ConstructorIdent), nt_Inh_Expression :: !(NontermIdent), options_Inh_Expression :: !(Options), ruleDescr_Inh_Expression :: !(String) } data Syn_Expression = Syn_Expression { errors_Syn_Expression :: !(Seq Error), output_Syn_Expression :: !(Expression) } {-# INLINABLE wrap_Expression #-} wrap_Expression :: T_Expression -> Inh_Expression -> (Syn_Expression ) wrap_Expression !(T_Expression act) !(Inh_Expression _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt _lhsIoptions _lhsIruleDescr) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Expression_vIn2 _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt _lhsIoptions _lhsIruleDescr !(T_Expression_vOut2 _lhsOerrors _lhsOoutput) <- return (inv_Expression_s4 sem arg) return (Syn_Expression _lhsOerrors _lhsOoutput) ) -- cata {-# INLINE sem_Expression #-} sem_Expression :: Expression -> T_Expression sem_Expression ( Expression !pos_ !tks_ ) = sem_Expression_Expression pos_ tks_ -- semantic domain newtype T_Expression = T_Expression { attach_T_Expression :: Identity (T_Expression_s4 ) } newtype T_Expression_s4 = C_Expression_s4 { inv_Expression_s4 :: (T_Expression_v2 ) } data T_Expression_s5 = C_Expression_s5 type T_Expression_v2 = (T_Expression_vIn2 ) -> (T_Expression_vOut2 ) data T_Expression_vIn2 = T_Expression_vIn2 !([(Identifier, Identifier)]) !([(Identifier, Identifier)]) !(ConstructorIdent) !(NontermIdent) !(Options) !(String) data T_Expression_vOut2 = T_Expression_vOut2 !(Seq Error) !(Expression) {-# NOINLINE sem_Expression_Expression #-} sem_Expression_Expression :: (Pos) -> ([HsToken]) -> T_Expression sem_Expression_Expression !arg_pos_ !arg_tks_ = T_Expression (return st4) where {-# NOINLINE st4 #-} !st4 = let v2 :: T_Expression_v2 v2 = \ !(T_Expression_vIn2 _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt _lhsIoptions _lhsIruleDescr) -> ( let _lhsOerrors :: Seq Error !(!_tks',!_lhsOerrors) = rule23 _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt _lhsIoptions _lhsIruleDescr arg_tks_ in let _lhsOoutput :: Expression !_lhsOoutput = rule24 _tks' arg_pos_ in let !__result_ = T_Expression_vOut2 _lhsOerrors _lhsOoutput in __result_ ) in C_Expression_s4 v2 {-# INLINE rule23 #-} {-# LINE 49 "./src-ag/Desugar.ag" #-} rule23 = \ ((!_lhsIchildInhs) :: [(Identifier, Identifier)]) ((!_lhsIchildSyns) :: [(Identifier, Identifier)]) ((!_lhsIcon) :: ConstructorIdent) ((!_lhsInt) :: NontermIdent) ((!_lhsIoptions) :: Options) ((!_lhsIruleDescr) :: String) !tks_ -> {-# LINE 49 "./src-ag/Desugar.ag" #-} let inh = Inh_HsTokensRoot { childInhs_Inh_HsTokensRoot = _lhsIchildInhs , childSyns_Inh_HsTokensRoot = _lhsIchildSyns , nt_Inh_HsTokensRoot = _lhsInt , con_Inh_HsTokensRoot = _lhsIcon , ruleDescr_Inh_HsTokensRoot = _lhsIruleDescr , useFieldIdent_Inh_HsTokensRoot = genUseTraces _lhsIoptions } sem = sem_HsTokensRoot (HsTokensRoot tks_) syn = wrap_HsTokensRoot sem inh in (tks_Syn_HsTokensRoot syn, errors_Syn_HsTokensRoot syn) {-# LINE 443 "dist/build/Desugar.hs"#-} {-# INLINE rule24 #-} {-# LINE 59 "./src-ag/Desugar.ag" #-} rule24 = \ !_tks' !pos_ -> {-# LINE 59 "./src-ag/Desugar.ag" #-} Expression pos_ _tks' {-# LINE 449 "dist/build/Desugar.hs"#-} -- Grammar ----------------------------------------------------- -- wrapper data Inh_Grammar = Inh_Grammar { forcedIrrefutables_Inh_Grammar :: !(AttrMap), mainName_Inh_Grammar :: !(String), options_Inh_Grammar :: !(Options) } data Syn_Grammar = Syn_Grammar { allAttributes_Syn_Grammar :: !(AttrMap), errors_Syn_Grammar :: !(Seq Error), output_Syn_Grammar :: !(Grammar) } {-# INLINABLE wrap_Grammar #-} wrap_Grammar :: T_Grammar -> Inh_Grammar -> (Syn_Grammar ) wrap_Grammar !(T_Grammar act) !(Inh_Grammar _lhsIforcedIrrefutables _lhsImainName _lhsIoptions) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Grammar_vIn3 _lhsIforcedIrrefutables _lhsImainName _lhsIoptions !(T_Grammar_vOut3 _lhsOallAttributes _lhsOerrors _lhsOoutput) <- return (inv_Grammar_s6 sem arg) return (Syn_Grammar _lhsOallAttributes _lhsOerrors _lhsOoutput) ) -- cata {-# INLINE sem_Grammar #-} sem_Grammar :: Grammar -> T_Grammar sem_Grammar ( Grammar !typeSyns_ !useMap_ !derivings_ !wrappers_ nonts_ !pragmas_ !manualAttrOrderMap_ !paramMap_ !contextMap_ !quantMap_ !uniqueMap_ !augmentsMap_ !aroundsMap_ !mergeMap_ ) = sem_Grammar_Grammar typeSyns_ useMap_ derivings_ wrappers_ ( sem_Nonterminals nonts_ ) pragmas_ manualAttrOrderMap_ paramMap_ contextMap_ quantMap_ uniqueMap_ augmentsMap_ aroundsMap_ mergeMap_ -- semantic domain newtype T_Grammar = T_Grammar { attach_T_Grammar :: Identity (T_Grammar_s6 ) } newtype T_Grammar_s6 = C_Grammar_s6 { inv_Grammar_s6 :: (T_Grammar_v3 ) } data T_Grammar_s7 = C_Grammar_s7 type T_Grammar_v3 = (T_Grammar_vIn3 ) -> (T_Grammar_vOut3 ) data T_Grammar_vIn3 = T_Grammar_vIn3 !(AttrMap) !(String) !(Options) data T_Grammar_vOut3 = T_Grammar_vOut3 !(AttrMap) !(Seq Error) !(Grammar) {-# NOINLINE sem_Grammar_Grammar #-} sem_Grammar_Grammar :: (TypeSyns) -> (UseMap) -> (Derivings) -> (Set NontermIdent) -> T_Nonterminals -> (PragmaMap) -> (AttrOrderMap) -> (ParamMap) -> (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)))) -> T_Grammar sem_Grammar_Grammar !arg_typeSyns_ !arg_useMap_ !arg_derivings_ !arg_wrappers_ arg_nonts_ !arg_pragmas_ !arg_manualAttrOrderMap_ !arg_paramMap_ !arg_contextMap_ !arg_quantMap_ !arg_uniqueMap_ !arg_augmentsMap_ !arg_aroundsMap_ !arg_mergeMap_ = T_Grammar (return st6) where {-# NOINLINE st6 #-} !st6 = let v3 :: T_Grammar_v3 v3 = \ !(T_Grammar_vIn3 _lhsIforcedIrrefutables _lhsImainName _lhsIoptions) -> ( let !_nontsX16 = Control.Monad.Identity.runIdentity (attach_T_Nonterminals (arg_nonts_)) in let !_nontsOaugmentsIn = rule28 arg_augmentsMap_ in let !_nontsOoptions = rule35 _lhsIoptions in let !_nontsOforcedIrrefutables = rule33 _lhsIforcedIrrefutables in let !_nontsOmainName = rule34 _lhsImainName in let !(T_Nonterminals_vOut19 _nontsIallAttributes _nontsIinhMap' _nontsIsynMap' _nontsX36) = inv_Nonterminals_s16 _nontsX16 K_Nonterminals_v19 (T_Nonterminals_vIn19 ) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule30 _nontsIallAttributes in let !_nontsOinhMap = rule26 _nontsIinhMap' in let !_nontsOsynMap = rule27 _nontsIsynMap' in let !(T_Nonterminals_vOut20 _nontsIaugmentsOut _nontsIerrors _nontsIoutput) = inv_Nonterminals_s36 _nontsX36 (T_Nonterminals_vIn20 _nontsOaugmentsIn _nontsOforcedIrrefutables _nontsOinhMap _nontsOmainName _nontsOoptions _nontsOsynMap) in let _lhsOerrors :: Seq Error !_lhsOerrors = rule31 _nontsIerrors in let _lhsOoutput :: Grammar !_lhsOoutput = rule29 _nontsIaugmentsOut _nontsIoutput arg_aroundsMap_ arg_contextMap_ arg_derivings_ arg_manualAttrOrderMap_ arg_mergeMap_ arg_paramMap_ arg_pragmas_ arg_quantMap_ arg_typeSyns_ arg_uniqueMap_ arg_useMap_ arg_wrappers_ in let !__result_ = T_Grammar_vOut3 _lhsOallAttributes _lhsOerrors _lhsOoutput in __result_ ) in C_Grammar_s6 v3 {-# INLINE rule26 #-} {-# LINE 15 "./src-ag/DistChildAttr.ag" #-} rule26 = \ ((!_nontsIinhMap') :: Map Identifier Attributes) -> {-# LINE 15 "./src-ag/DistChildAttr.ag" #-} _nontsIinhMap' {-# LINE 511 "dist/build/Desugar.hs"#-} {-# INLINE rule27 #-} {-# LINE 16 "./src-ag/DistChildAttr.ag" #-} rule27 = \ ((!_nontsIsynMap') :: Map Identifier Attributes) -> {-# LINE 16 "./src-ag/DistChildAttr.ag" #-} _nontsIsynMap' {-# LINE 517 "dist/build/Desugar.hs"#-} {-# INLINE rule28 #-} {-# LINE 235 "./src-ag/Desugar.ag" #-} rule28 = \ !augmentsMap_ -> {-# LINE 235 "./src-ag/Desugar.ag" #-} augmentsMap_ {-# LINE 523 "dist/build/Desugar.hs"#-} {-# INLINE rule29 #-} {-# LINE 319 "./src-ag/Desugar.ag" #-} rule29 = \ ((!_nontsIaugmentsOut) :: Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) ((!_nontsIoutput) :: Nonterminals) !aroundsMap_ !contextMap_ !derivings_ !manualAttrOrderMap_ !mergeMap_ !paramMap_ !pragmas_ !quantMap_ !typeSyns_ !uniqueMap_ !useMap_ !wrappers_ -> {-# LINE 319 "./src-ag/Desugar.ag" #-} Grammar typeSyns_ useMap_ derivings_ wrappers_ _nontsIoutput pragmas_ manualAttrOrderMap_ paramMap_ contextMap_ quantMap_ uniqueMap_ _nontsIaugmentsOut aroundsMap_ mergeMap_ {-# LINE 542 "dist/build/Desugar.hs"#-} {-# INLINE rule30 #-} rule30 = \ ((!_nontsIallAttributes) :: AttrMap) -> _nontsIallAttributes {-# INLINE rule31 #-} rule31 = \ ((!_nontsIerrors) :: Seq Error) -> _nontsIerrors {-# INLINE rule33 #-} rule33 = \ ((!_lhsIforcedIrrefutables) :: AttrMap) -> _lhsIforcedIrrefutables {-# INLINE rule34 #-} rule34 = \ ((!_lhsImainName) :: String) -> _lhsImainName {-# INLINE rule35 #-} rule35 = \ ((!_lhsIoptions) :: Options) -> _lhsIoptions -- HsToken ----------------------------------------------------- -- wrapper data Inh_HsToken = Inh_HsToken { addLines_Inh_HsToken :: !(Int), childInhs_Inh_HsToken :: !([(Identifier, Identifier)]), childSyns_Inh_HsToken :: !([(Identifier, Identifier)]), con_Inh_HsToken :: !(ConstructorIdent), nt_Inh_HsToken :: !(NontermIdent), ruleDescr_Inh_HsToken :: !(String), useFieldIdent_Inh_HsToken :: !(Bool) } data Syn_HsToken = Syn_HsToken { addLines_Syn_HsToken :: !(Int), errors_Syn_HsToken :: !(Seq Error), tks_Syn_HsToken :: !(HsToken) } {-# INLINABLE wrap_HsToken #-} wrap_HsToken :: T_HsToken -> Inh_HsToken -> (Syn_HsToken ) wrap_HsToken !(T_HsToken act) !(Inh_HsToken _lhsIaddLines _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt _lhsIruleDescr _lhsIuseFieldIdent) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_HsToken_vIn4 _lhsIaddLines _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt _lhsIruleDescr _lhsIuseFieldIdent !(T_HsToken_vOut4 _lhsOaddLines _lhsOerrors _lhsOtks) <- return (inv_HsToken_s8 sem K_HsToken_v4 arg) return (Syn_HsToken _lhsOaddLines _lhsOerrors _lhsOtks) ) -- cata {-# NOINLINE sem_HsToken #-} sem_HsToken :: HsToken -> T_HsToken sem_HsToken ( AGLocal !var_ !pos_ !rdesc_ ) = sem_HsToken_AGLocal var_ pos_ rdesc_ sem_HsToken ( AGField !field_ !attr_ !pos_ !rdesc_ ) = sem_HsToken_AGField field_ attr_ pos_ rdesc_ sem_HsToken ( HsToken !value_ !pos_ ) = sem_HsToken_HsToken value_ pos_ sem_HsToken ( CharToken !value_ !pos_ ) = sem_HsToken_CharToken value_ pos_ sem_HsToken ( StrToken !value_ !pos_ ) = sem_HsToken_StrToken value_ pos_ sem_HsToken ( Err !mesg_ !pos_ ) = sem_HsToken_Err mesg_ pos_ -- semantic domain newtype T_HsToken = T_HsToken { attach_T_HsToken :: Identity (T_HsToken_s8 ) } data T_HsToken_s8 where C_HsToken_s8 :: { inv_HsToken_s8 :: !(forall t. K_HsToken_s8 t -> t) } -> T_HsToken_s8 data T_HsToken_s9 = C_HsToken_s9 data T_HsToken_s37 = C_HsToken_s37 newtype T_HsToken_s47 = C_HsToken_s47 { inv_HsToken_s47 :: (T_HsToken_v35 ) } data K_HsToken_s8 k where K_HsToken_v4 :: K_HsToken_s8 (T_HsToken_v4 ) K_HsToken_v21 :: K_HsToken_s8 (T_HsToken_v21 ) K_HsToken_v34 :: K_HsToken_s8 (T_HsToken_v34 ) type T_HsToken_v4 = (T_HsToken_vIn4 ) -> (T_HsToken_vOut4 ) data T_HsToken_vIn4 = T_HsToken_vIn4 !(Int) !([(Identifier, Identifier)]) !([(Identifier, Identifier)]) !(ConstructorIdent) !(NontermIdent) !(String) !(Bool) data T_HsToken_vOut4 = T_HsToken_vOut4 !(Int) !(Seq Error) !(HsToken) type T_HsToken_v21 = (T_HsToken_vIn21 ) -> (T_HsToken_vOut21 ) data T_HsToken_vIn21 = T_HsToken_vIn21 !(Int) !([(Identifier, Identifier)]) !(ConstructorIdent) !(NontermIdent) !(String) !(Bool) data T_HsToken_vOut21 = T_HsToken_vOut21 !(Int) !(Seq Error) !(HsToken) type T_HsToken_v34 = (T_HsToken_vIn34 ) -> (T_HsToken_vOut34 ) data T_HsToken_vIn34 = T_HsToken_vIn34 !([(Identifier, Identifier)]) !(ConstructorIdent) !(NontermIdent) data T_HsToken_vOut34 = T_HsToken_vOut34 !(Seq Error) !(T_HsToken_s47 ) type T_HsToken_v35 = (T_HsToken_vIn35 ) -> (T_HsToken_vOut35 ) data T_HsToken_vIn35 = T_HsToken_vIn35 !(Int) !(String) !(Bool) data T_HsToken_vOut35 = T_HsToken_vOut35 !(Int) !(HsToken) {-# NOINLINE sem_HsToken_AGLocal #-} sem_HsToken_AGLocal :: (Identifier) -> (Pos) -> (Maybe String) -> T_HsToken sem_HsToken_AGLocal !arg_var_ !arg_pos_ _ = T_HsToken (return st8) where {-# NOINLINE st8 #-} !st8 = let k8 :: K_HsToken_s8 t -> t k8 K_HsToken_v4 = v4 k8 K_HsToken_v21 = v21 k8 K_HsToken_v34 = v34 v4 :: T_HsToken_v4 v4 = \ !(T_HsToken_vIn4 _lhsIaddLines _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt _lhsIruleDescr _lhsIuseFieldIdent) -> ( let _lhsOerrors :: Seq Error !_lhsOerrors = rule38 () in let _lhsOaddLines :: Int !_lhsOaddLines = rule36 _lhsIaddLines _lhsIuseFieldIdent in let !_tks = rule37 _lhsIaddLines _lhsIruleDescr _lhsIuseFieldIdent arg_pos_ arg_var_ in let _lhsOtks :: HsToken !_lhsOtks = rule39 _tks in let !__result_ = T_HsToken_vOut4 _lhsOaddLines _lhsOerrors _lhsOtks in __result_ ) v21 :: T_HsToken_v21 v21 = \ !(T_HsToken_vIn21 _lhsIaddLines _lhsIchildSyns _lhsIcon _lhsInt _lhsIruleDescr _lhsIuseFieldIdent) -> ( let _lhsOerrors :: Seq Error !_lhsOerrors = rule38 () in let _lhsOaddLines :: Int !_lhsOaddLines = rule36 _lhsIaddLines _lhsIuseFieldIdent in let !_tks = rule37 _lhsIaddLines _lhsIruleDescr _lhsIuseFieldIdent arg_pos_ arg_var_ in let _lhsOtks :: HsToken !_lhsOtks = rule39 _tks in let !__result_ = T_HsToken_vOut21 _lhsOaddLines _lhsOerrors _lhsOtks in __result_ ) v34 :: T_HsToken_v34 v34 = \ !(T_HsToken_vIn34 _lhsIchildSyns _lhsIcon _lhsInt) -> ( let _lhsOerrors :: Seq Error !_lhsOerrors = rule38 () in let !__st_ = st47 () !__result_ = T_HsToken_vOut34 _lhsOerrors __st_ in __result_ ) in C_HsToken_s8 k8 {-# NOINLINE st47 #-} st47 = \ (_ :: ()) -> let v35 :: T_HsToken_v35 v35 = \ !(T_HsToken_vIn35 _lhsIaddLines _lhsIruleDescr _lhsIuseFieldIdent) -> ( let _lhsOaddLines :: Int !_lhsOaddLines = rule36 _lhsIaddLines _lhsIuseFieldIdent in let !_tks = rule37 _lhsIaddLines _lhsIruleDescr _lhsIuseFieldIdent arg_pos_ arg_var_ in let _lhsOtks :: HsToken !_lhsOtks = rule39 _tks in let !__result_ = T_HsToken_vOut35 _lhsOaddLines _lhsOtks in __result_ ) in C_HsToken_s47 v35 {-# NOINLINE[1] rule36 #-} {-# LINE 74 "./src-ag/Desugar.ag" #-} rule36 = \ ((!_lhsIaddLines) :: Int) ((!_lhsIuseFieldIdent) :: Bool) -> {-# LINE 74 "./src-ag/Desugar.ag" #-} if _lhsIuseFieldIdent then _lhsIaddLines + 1 else _lhsIaddLines {-# LINE 669 "dist/build/Desugar.hs"#-} {-# NOINLINE[1] rule37 #-} {-# LINE 77 "./src-ag/Desugar.ag" #-} rule37 = \ ((!_lhsIaddLines) :: Int) ((!_lhsIruleDescr) :: String) ((!_lhsIuseFieldIdent) :: Bool) !pos_ !var_ -> {-# LINE 77 "./src-ag/Desugar.ag" #-} AGLocal var_ (addl _lhsIaddLines pos_) (if _lhsIuseFieldIdent then Just _lhsIruleDescr else Nothing) {-# LINE 675 "dist/build/Desugar.hs"#-} {-# NOINLINE[1] rule38 #-} rule38 = \ (_ :: ()) -> Seq.empty {-# NOINLINE[1] rule39 #-} rule39 = \ !_tks -> _tks {-# NOINLINE sem_HsToken_AGField #-} sem_HsToken_AGField :: (Identifier) -> (Identifier) -> (Pos) -> (Maybe String) -> T_HsToken sem_HsToken_AGField !arg_field_ !arg_attr_ !arg_pos_ _ = T_HsToken (return st8) where {-# NOINLINE st8 #-} !st8 = let k8 :: K_HsToken_s8 t -> t k8 K_HsToken_v4 = v4 k8 K_HsToken_v21 = v21 k8 K_HsToken_v34 = v34 v4 :: T_HsToken_v4 v4 = \ !(T_HsToken_vIn4 _lhsIaddLines _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt _lhsIruleDescr _lhsIuseFieldIdent) -> ( let !_mField = rule40 _lhsIchildSyns arg_attr_ arg_field_ in let !_field' = rule41 _mField arg_field_ in let _lhsOaddLines :: Int !_lhsOaddLines = rule43 _field' _lhsIaddLines _lhsIuseFieldIdent arg_field_ in let _lhsOerrors :: Seq Error !_lhsOerrors = rule42 _lhsIcon _lhsInt _mField arg_field_ in let !_tks = rule44 _field' _lhsIaddLines _lhsIruleDescr _lhsIuseFieldIdent arg_attr_ arg_pos_ in let _lhsOtks :: HsToken !_lhsOtks = rule45 _tks in let !__result_ = T_HsToken_vOut4 _lhsOaddLines _lhsOerrors _lhsOtks in __result_ ) v21 :: T_HsToken_v21 v21 = \ !(T_HsToken_vIn21 _lhsIaddLines _lhsIchildSyns _lhsIcon _lhsInt _lhsIruleDescr _lhsIuseFieldIdent) -> ( let !_mField = rule40 _lhsIchildSyns arg_attr_ arg_field_ in let !_field' = rule41 _mField arg_field_ in let _lhsOaddLines :: Int !_lhsOaddLines = rule43 _field' _lhsIaddLines _lhsIuseFieldIdent arg_field_ in let _lhsOerrors :: Seq Error !_lhsOerrors = rule42 _lhsIcon _lhsInt _mField arg_field_ in let !_tks = rule44 _field' _lhsIaddLines _lhsIruleDescr _lhsIuseFieldIdent arg_attr_ arg_pos_ in let _lhsOtks :: HsToken !_lhsOtks = rule45 _tks in let !__result_ = T_HsToken_vOut21 _lhsOaddLines _lhsOerrors _lhsOtks in __result_ ) v34 :: T_HsToken_v34 v34 = \ !(T_HsToken_vIn34 _lhsIchildSyns _lhsIcon _lhsInt) -> ( let !_mField = rule40 _lhsIchildSyns arg_attr_ arg_field_ in let _lhsOerrors :: Seq Error !_lhsOerrors = rule42 _lhsIcon _lhsInt _mField arg_field_ in let !__st_ = st47 _mField !__result_ = T_HsToken_vOut34 _lhsOerrors __st_ in __result_ ) in C_HsToken_s8 k8 {-# NOINLINE st47 #-} st47 = \ !_mField -> let v35 :: T_HsToken_v35 v35 = \ !(T_HsToken_vIn35 _lhsIaddLines _lhsIruleDescr _lhsIuseFieldIdent) -> ( let !_field' = rule41 _mField arg_field_ in let _lhsOaddLines :: Int !_lhsOaddLines = rule43 _field' _lhsIaddLines _lhsIuseFieldIdent arg_field_ in let !_tks = rule44 _field' _lhsIaddLines _lhsIruleDescr _lhsIuseFieldIdent arg_attr_ arg_pos_ in let _lhsOtks :: HsToken !_lhsOtks = rule45 _tks in let !__result_ = T_HsToken_vOut35 _lhsOaddLines _lhsOtks in __result_ ) in C_HsToken_s47 v35 {-# NOINLINE[1] rule40 #-} {-# LINE 79 "./src-ag/Desugar.ag" #-} rule40 = \ ((!_lhsIchildSyns) :: [(Identifier, Identifier)]) !attr_ !field_ -> {-# LINE 79 "./src-ag/Desugar.ag" #-} findField field_ attr_ _lhsIchildSyns {-# LINE 744 "dist/build/Desugar.hs"#-} {-# NOINLINE[1] rule41 #-} {-# LINE 81 "./src-ag/Desugar.ag" #-} rule41 = \ !_mField !field_ -> {-# LINE 81 "./src-ag/Desugar.ag" #-} maybe field_ id _mField {-# LINE 750 "dist/build/Desugar.hs"#-} {-# NOINLINE[1] rule42 #-} {-# LINE 82 "./src-ag/Desugar.ag" #-} rule42 = \ ((!_lhsIcon) :: ConstructorIdent) ((!_lhsInt) :: NontermIdent) !_mField !field_ -> {-# LINE 82 "./src-ag/Desugar.ag" #-} maybe (Seq.singleton (UndefAttr _lhsInt _lhsIcon field_ (Ident "" (getPos field_)) False)) (const Seq.empty) _mField {-# LINE 756 "dist/build/Desugar.hs"#-} {-# NOINLINE[1] rule43 #-} {-# LINE 84 "./src-ag/Desugar.ag" #-} rule43 = \ !_field' ((!_lhsIaddLines) :: Int) ((!_lhsIuseFieldIdent) :: Bool) !field_ -> {-# LINE 84 "./src-ag/Desugar.ag" #-} if _lhsIuseFieldIdent || length (getName field_) < length (getName _field' ) then _lhsIaddLines + 1 else _lhsIaddLines {-# LINE 764 "dist/build/Desugar.hs"#-} {-# NOINLINE[1] rule44 #-} {-# LINE 88 "./src-ag/Desugar.ag" #-} rule44 = \ !_field' ((!_lhsIaddLines) :: Int) ((!_lhsIruleDescr) :: String) ((!_lhsIuseFieldIdent) :: Bool) !attr_ !pos_ -> {-# LINE 88 "./src-ag/Desugar.ag" #-} AGField _field' attr_ (addl _lhsIaddLines pos_) (if _lhsIuseFieldIdent then Just _lhsIruleDescr else Nothing) {-# LINE 770 "dist/build/Desugar.hs"#-} {-# NOINLINE[1] rule45 #-} rule45 = \ !_tks -> _tks {-# NOINLINE sem_HsToken_HsToken #-} sem_HsToken_HsToken :: (String) -> (Pos) -> T_HsToken sem_HsToken_HsToken !arg_value_ !arg_pos_ = T_HsToken (return st8) where {-# NOINLINE st8 #-} !st8 = let k8 :: K_HsToken_s8 t -> t k8 K_HsToken_v4 = v4 k8 K_HsToken_v21 = v21 k8 K_HsToken_v34 = v34 v4 :: T_HsToken_v4 v4 = \ !(T_HsToken_vIn4 _lhsIaddLines _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt _lhsIruleDescr _lhsIuseFieldIdent) -> ( let _lhsOerrors :: Seq Error !_lhsOerrors = rule47 () in let _lhsOaddLines :: Int !_lhsOaddLines = rule49 _lhsIaddLines in let !_tks = rule46 _lhsIaddLines arg_pos_ arg_value_ in let _lhsOtks :: HsToken !_lhsOtks = rule48 _tks in let !__result_ = T_HsToken_vOut4 _lhsOaddLines _lhsOerrors _lhsOtks in __result_ ) v21 :: T_HsToken_v21 v21 = \ !(T_HsToken_vIn21 _lhsIaddLines _lhsIchildSyns _lhsIcon _lhsInt _lhsIruleDescr _lhsIuseFieldIdent) -> ( let _lhsOerrors :: Seq Error !_lhsOerrors = rule47 () in let _lhsOaddLines :: Int !_lhsOaddLines = rule49 _lhsIaddLines in let !_tks = rule46 _lhsIaddLines arg_pos_ arg_value_ in let _lhsOtks :: HsToken !_lhsOtks = rule48 _tks in let !__result_ = T_HsToken_vOut21 _lhsOaddLines _lhsOerrors _lhsOtks in __result_ ) v34 :: T_HsToken_v34 v34 = \ !(T_HsToken_vIn34 _lhsIchildSyns _lhsIcon _lhsInt) -> ( let _lhsOerrors :: Seq Error !_lhsOerrors = rule47 () in let !__st_ = st47 () !__result_ = T_HsToken_vOut34 _lhsOerrors __st_ in __result_ ) in C_HsToken_s8 k8 {-# NOINLINE st47 #-} st47 = \ (_ :: ()) -> let v35 :: T_HsToken_v35 v35 = \ !(T_HsToken_vIn35 _lhsIaddLines _lhsIruleDescr _lhsIuseFieldIdent) -> ( let _lhsOaddLines :: Int !_lhsOaddLines = rule49 _lhsIaddLines in let !_tks = rule46 _lhsIaddLines arg_pos_ arg_value_ in let _lhsOtks :: HsToken !_lhsOtks = rule48 _tks in let !__result_ = T_HsToken_vOut35 _lhsOaddLines _lhsOtks in __result_ ) in C_HsToken_s47 v35 {-# NOINLINE[1] rule46 #-} {-# LINE 90 "./src-ag/Desugar.ag" #-} rule46 = \ ((!_lhsIaddLines) :: Int) !pos_ !value_ -> {-# LINE 90 "./src-ag/Desugar.ag" #-} HsToken value_ (addl _lhsIaddLines pos_) {-# LINE 830 "dist/build/Desugar.hs"#-} {-# NOINLINE[1] rule47 #-} rule47 = \ (_ :: ()) -> Seq.empty {-# NOINLINE[1] rule48 #-} rule48 = \ !_tks -> _tks {-# NOINLINE[1] rule49 #-} rule49 = \ ((!_lhsIaddLines) :: Int) -> _lhsIaddLines {-# NOINLINE sem_HsToken_CharToken #-} sem_HsToken_CharToken :: (String) -> (Pos) -> T_HsToken sem_HsToken_CharToken !arg_value_ !arg_pos_ = T_HsToken (return st8) where {-# NOINLINE st8 #-} !st8 = let k8 :: K_HsToken_s8 t -> t k8 K_HsToken_v4 = v4 k8 K_HsToken_v21 = v21 k8 K_HsToken_v34 = v34 v4 :: T_HsToken_v4 v4 = \ !(T_HsToken_vIn4 _lhsIaddLines _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt _lhsIruleDescr _lhsIuseFieldIdent) -> ( let _lhsOerrors :: Seq Error !_lhsOerrors = rule51 () in let _lhsOaddLines :: Int !_lhsOaddLines = rule53 _lhsIaddLines in let !_tks = rule50 _lhsIaddLines arg_pos_ arg_value_ in let _lhsOtks :: HsToken !_lhsOtks = rule52 _tks in let !__result_ = T_HsToken_vOut4 _lhsOaddLines _lhsOerrors _lhsOtks in __result_ ) v21 :: T_HsToken_v21 v21 = \ !(T_HsToken_vIn21 _lhsIaddLines _lhsIchildSyns _lhsIcon _lhsInt _lhsIruleDescr _lhsIuseFieldIdent) -> ( let _lhsOerrors :: Seq Error !_lhsOerrors = rule51 () in let _lhsOaddLines :: Int !_lhsOaddLines = rule53 _lhsIaddLines in let !_tks = rule50 _lhsIaddLines arg_pos_ arg_value_ in let _lhsOtks :: HsToken !_lhsOtks = rule52 _tks in let !__result_ = T_HsToken_vOut21 _lhsOaddLines _lhsOerrors _lhsOtks in __result_ ) v34 :: T_HsToken_v34 v34 = \ !(T_HsToken_vIn34 _lhsIchildSyns _lhsIcon _lhsInt) -> ( let _lhsOerrors :: Seq Error !_lhsOerrors = rule51 () in let !__st_ = st47 () !__result_ = T_HsToken_vOut34 _lhsOerrors __st_ in __result_ ) in C_HsToken_s8 k8 {-# NOINLINE st47 #-} st47 = \ (_ :: ()) -> let v35 :: T_HsToken_v35 v35 = \ !(T_HsToken_vIn35 _lhsIaddLines _lhsIruleDescr _lhsIuseFieldIdent) -> ( let _lhsOaddLines :: Int !_lhsOaddLines = rule53 _lhsIaddLines in let !_tks = rule50 _lhsIaddLines arg_pos_ arg_value_ in let _lhsOtks :: HsToken !_lhsOtks = rule52 _tks in let !__result_ = T_HsToken_vOut35 _lhsOaddLines _lhsOtks in __result_ ) in C_HsToken_s47 v35 {-# NOINLINE[1] rule50 #-} {-# LINE 92 "./src-ag/Desugar.ag" #-} rule50 = \ ((!_lhsIaddLines) :: Int) !pos_ !value_ -> {-# LINE 92 "./src-ag/Desugar.ag" #-} CharToken value_ (addl _lhsIaddLines pos_) {-# LINE 896 "dist/build/Desugar.hs"#-} {-# NOINLINE[1] rule51 #-} rule51 = \ (_ :: ()) -> Seq.empty {-# NOINLINE[1] rule52 #-} rule52 = \ !_tks -> _tks {-# NOINLINE[1] rule53 #-} rule53 = \ ((!_lhsIaddLines) :: Int) -> _lhsIaddLines {-# NOINLINE sem_HsToken_StrToken #-} sem_HsToken_StrToken :: (String) -> (Pos) -> T_HsToken sem_HsToken_StrToken !arg_value_ !arg_pos_ = T_HsToken (return st8) where {-# NOINLINE st8 #-} !st8 = let k8 :: K_HsToken_s8 t -> t k8 K_HsToken_v4 = v4 k8 K_HsToken_v21 = v21 k8 K_HsToken_v34 = v34 v4 :: T_HsToken_v4 v4 = \ !(T_HsToken_vIn4 _lhsIaddLines _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt _lhsIruleDescr _lhsIuseFieldIdent) -> ( let _lhsOerrors :: Seq Error !_lhsOerrors = rule55 () in let _lhsOaddLines :: Int !_lhsOaddLines = rule57 _lhsIaddLines in let !_tks = rule54 _lhsIaddLines arg_pos_ arg_value_ in let _lhsOtks :: HsToken !_lhsOtks = rule56 _tks in let !__result_ = T_HsToken_vOut4 _lhsOaddLines _lhsOerrors _lhsOtks in __result_ ) v21 :: T_HsToken_v21 v21 = \ !(T_HsToken_vIn21 _lhsIaddLines _lhsIchildSyns _lhsIcon _lhsInt _lhsIruleDescr _lhsIuseFieldIdent) -> ( let _lhsOerrors :: Seq Error !_lhsOerrors = rule55 () in let _lhsOaddLines :: Int !_lhsOaddLines = rule57 _lhsIaddLines in let !_tks = rule54 _lhsIaddLines arg_pos_ arg_value_ in let _lhsOtks :: HsToken !_lhsOtks = rule56 _tks in let !__result_ = T_HsToken_vOut21 _lhsOaddLines _lhsOerrors _lhsOtks in __result_ ) v34 :: T_HsToken_v34 v34 = \ !(T_HsToken_vIn34 _lhsIchildSyns _lhsIcon _lhsInt) -> ( let _lhsOerrors :: Seq Error !_lhsOerrors = rule55 () in let !__st_ = st47 () !__result_ = T_HsToken_vOut34 _lhsOerrors __st_ in __result_ ) in C_HsToken_s8 k8 {-# NOINLINE st47 #-} st47 = \ (_ :: ()) -> let v35 :: T_HsToken_v35 v35 = \ !(T_HsToken_vIn35 _lhsIaddLines _lhsIruleDescr _lhsIuseFieldIdent) -> ( let _lhsOaddLines :: Int !_lhsOaddLines = rule57 _lhsIaddLines in let !_tks = rule54 _lhsIaddLines arg_pos_ arg_value_ in let _lhsOtks :: HsToken !_lhsOtks = rule56 _tks in let !__result_ = T_HsToken_vOut35 _lhsOaddLines _lhsOtks in __result_ ) in C_HsToken_s47 v35 {-# NOINLINE[1] rule54 #-} {-# LINE 94 "./src-ag/Desugar.ag" #-} rule54 = \ ((!_lhsIaddLines) :: Int) !pos_ !value_ -> {-# LINE 94 "./src-ag/Desugar.ag" #-} StrToken value_ (addl _lhsIaddLines pos_) {-# LINE 962 "dist/build/Desugar.hs"#-} {-# NOINLINE[1] rule55 #-} rule55 = \ (_ :: ()) -> Seq.empty {-# NOINLINE[1] rule56 #-} rule56 = \ !_tks -> _tks {-# NOINLINE[1] rule57 #-} rule57 = \ ((!_lhsIaddLines) :: Int) -> _lhsIaddLines {-# NOINLINE sem_HsToken_Err #-} sem_HsToken_Err :: (String) -> (Pos) -> T_HsToken sem_HsToken_Err !arg_mesg_ !arg_pos_ = T_HsToken (return st8) where {-# NOINLINE st8 #-} !st8 = let k8 :: K_HsToken_s8 t -> t k8 K_HsToken_v4 = v4 k8 K_HsToken_v21 = v21 k8 K_HsToken_v34 = v34 v4 :: T_HsToken_v4 v4 = \ !(T_HsToken_vIn4 _lhsIaddLines _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt _lhsIruleDescr _lhsIuseFieldIdent) -> ( let _lhsOerrors :: Seq Error !_lhsOerrors = rule59 () in let _lhsOaddLines :: Int !_lhsOaddLines = rule61 _lhsIaddLines in let !_tks = rule58 _lhsIaddLines arg_mesg_ arg_pos_ in let _lhsOtks :: HsToken !_lhsOtks = rule60 _tks in let !__result_ = T_HsToken_vOut4 _lhsOaddLines _lhsOerrors _lhsOtks in __result_ ) v21 :: T_HsToken_v21 v21 = \ !(T_HsToken_vIn21 _lhsIaddLines _lhsIchildSyns _lhsIcon _lhsInt _lhsIruleDescr _lhsIuseFieldIdent) -> ( let _lhsOerrors :: Seq Error !_lhsOerrors = rule59 () in let _lhsOaddLines :: Int !_lhsOaddLines = rule61 _lhsIaddLines in let !_tks = rule58 _lhsIaddLines arg_mesg_ arg_pos_ in let _lhsOtks :: HsToken !_lhsOtks = rule60 _tks in let !__result_ = T_HsToken_vOut21 _lhsOaddLines _lhsOerrors _lhsOtks in __result_ ) v34 :: T_HsToken_v34 v34 = \ !(T_HsToken_vIn34 _lhsIchildSyns _lhsIcon _lhsInt) -> ( let _lhsOerrors :: Seq Error !_lhsOerrors = rule59 () in let !__st_ = st47 () !__result_ = T_HsToken_vOut34 _lhsOerrors __st_ in __result_ ) in C_HsToken_s8 k8 {-# NOINLINE st47 #-} st47 = \ (_ :: ()) -> let v35 :: T_HsToken_v35 v35 = \ !(T_HsToken_vIn35 _lhsIaddLines _lhsIruleDescr _lhsIuseFieldIdent) -> ( let _lhsOaddLines :: Int !_lhsOaddLines = rule61 _lhsIaddLines in let !_tks = rule58 _lhsIaddLines arg_mesg_ arg_pos_ in let _lhsOtks :: HsToken !_lhsOtks = rule60 _tks in let !__result_ = T_HsToken_vOut35 _lhsOaddLines _lhsOtks in __result_ ) in C_HsToken_s47 v35 {-# NOINLINE[1] rule58 #-} {-# LINE 96 "./src-ag/Desugar.ag" #-} rule58 = \ ((!_lhsIaddLines) :: Int) !mesg_ !pos_ -> {-# LINE 96 "./src-ag/Desugar.ag" #-} Err mesg_ (addl _lhsIaddLines pos_) {-# LINE 1028 "dist/build/Desugar.hs"#-} {-# NOINLINE[1] rule59 #-} rule59 = \ (_ :: ()) -> Seq.empty {-# NOINLINE[1] rule60 #-} rule60 = \ !_tks -> _tks {-# NOINLINE[1] rule61 #-} rule61 = \ ((!_lhsIaddLines) :: Int) -> _lhsIaddLines -- HsTokens ---------------------------------------------------- -- wrapper data Inh_HsTokens = Inh_HsTokens { addLines_Inh_HsTokens :: !(Int), childInhs_Inh_HsTokens :: !([(Identifier, Identifier)]), childSyns_Inh_HsTokens :: !([(Identifier, Identifier)]), con_Inh_HsTokens :: !(ConstructorIdent), nt_Inh_HsTokens :: !(NontermIdent), ruleDescr_Inh_HsTokens :: !(String), useFieldIdent_Inh_HsTokens :: !(Bool) } data Syn_HsTokens = Syn_HsTokens { addLines_Syn_HsTokens :: !(Int), errors_Syn_HsTokens :: !(Seq Error), tks_Syn_HsTokens :: !(HsTokens) } {-# INLINABLE wrap_HsTokens #-} wrap_HsTokens :: T_HsTokens -> Inh_HsTokens -> (Syn_HsTokens ) wrap_HsTokens !(T_HsTokens act) !(Inh_HsTokens _lhsIaddLines _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt _lhsIruleDescr _lhsIuseFieldIdent) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_HsTokens_vIn5 _lhsIaddLines _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt _lhsIruleDescr _lhsIuseFieldIdent !(T_HsTokens_vOut5 _lhsOaddLines _lhsOerrors _lhsOtks) <- return (inv_HsTokens_s10 sem K_HsTokens_v5 arg) return (Syn_HsTokens _lhsOaddLines _lhsOerrors _lhsOtks) ) -- cata {-# NOINLINE sem_HsTokens #-} sem_HsTokens :: HsTokens -> T_HsTokens sem_HsTokens list = Prelude.foldr sem_HsTokens_Cons sem_HsTokens_Nil (Prelude.map sem_HsToken list) -- semantic domain newtype T_HsTokens = T_HsTokens { attach_T_HsTokens :: Identity (T_HsTokens_s10 ) } data T_HsTokens_s10 where C_HsTokens_s10 :: { inv_HsTokens_s10 :: !(forall t. K_HsTokens_s10 t -> t) } -> T_HsTokens_s10 data T_HsTokens_s11 = C_HsTokens_s11 newtype T_HsTokens_s38 = C_HsTokens_s38 { inv_HsTokens_s38 :: (T_HsTokens_v23 ) } data T_HsTokens_s39 = C_HsTokens_s39 data K_HsTokens_s10 k where K_HsTokens_v5 :: K_HsTokens_s10 (T_HsTokens_v5 ) K_HsTokens_v22 :: K_HsTokens_s10 (T_HsTokens_v22 ) K_HsTokens_v24 :: K_HsTokens_s10 (T_HsTokens_v24 ) type T_HsTokens_v5 = (T_HsTokens_vIn5 ) -> (T_HsTokens_vOut5 ) data T_HsTokens_vIn5 = T_HsTokens_vIn5 !(Int) !([(Identifier, Identifier)]) !([(Identifier, Identifier)]) !(ConstructorIdent) !(NontermIdent) !(String) !(Bool) data T_HsTokens_vOut5 = T_HsTokens_vOut5 !(Int) !(Seq Error) !(HsTokens) type T_HsTokens_v22 = (T_HsTokens_vIn22 ) -> (T_HsTokens_vOut22 ) data T_HsTokens_vIn22 = T_HsTokens_vIn22 !([(Identifier, Identifier)]) !(ConstructorIdent) !(NontermIdent) data T_HsTokens_vOut22 = T_HsTokens_vOut22 !(Seq Error) !(T_HsTokens_s38 ) type T_HsTokens_v23 = (T_HsTokens_vIn23 ) -> (T_HsTokens_vOut23 ) data T_HsTokens_vIn23 = T_HsTokens_vIn23 !(Int) !(String) !(Bool) data T_HsTokens_vOut23 = T_HsTokens_vOut23 !(Int) !(HsTokens) type T_HsTokens_v24 = (T_HsTokens_vIn24 ) -> (T_HsTokens_vOut24 ) data T_HsTokens_vIn24 = T_HsTokens_vIn24 !(Int) !([(Identifier, Identifier)]) !(ConstructorIdent) !(NontermIdent) !(String) !(Bool) data T_HsTokens_vOut24 = T_HsTokens_vOut24 !(Int) !(Seq Error) !(HsTokens) {-# NOINLINE sem_HsTokens_Cons #-} sem_HsTokens_Cons :: T_HsToken -> T_HsTokens -> T_HsTokens sem_HsTokens_Cons arg_hd_ arg_tl_ = T_HsTokens (return st10) where {-# NOINLINE st10 #-} !st10 = let k10 :: K_HsTokens_s10 t -> t k10 K_HsTokens_v5 = v5 k10 K_HsTokens_v22 = v22 k10 K_HsTokens_v24 = v24 v5 :: T_HsTokens_v5 v5 = \ !(T_HsTokens_vIn5 _lhsIaddLines _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt _lhsIruleDescr _lhsIuseFieldIdent) -> ( let !_hdX8 = Control.Monad.Identity.runIdentity (attach_T_HsToken (arg_hd_)) in let !_tlX10 = Control.Monad.Identity.runIdentity (attach_T_HsTokens (arg_tl_)) in let !_hdOaddLines = rule66 _lhsIaddLines in let !_hdOchildSyns = rule68 _lhsIchildSyns in let !_hdOuseFieldIdent = rule72 _lhsIuseFieldIdent in let !_tlOchildSyns = rule75 _lhsIchildSyns in let !_tlOuseFieldIdent = rule79 _lhsIuseFieldIdent in let !_hdOcon = rule69 _lhsIcon in let !_hdOnt = rule70 _lhsInt in let !_tlOcon = rule76 _lhsIcon in let !_tlOnt = rule77 _lhsInt in let !_hdOruleDescr = rule71 _lhsIruleDescr in let !_tlOruleDescr = rule78 _lhsIruleDescr in let !(T_HsToken_vOut21 _hdIaddLines _hdIerrors _hdItks) = inv_HsToken_s8 _hdX8 K_HsToken_v21 (T_HsToken_vIn21 _hdOaddLines _hdOchildSyns _hdOcon _hdOnt _hdOruleDescr _hdOuseFieldIdent) in let !(T_HsTokens_vOut22 _tlIerrors _tlX38) = inv_HsTokens_s10 _tlX10 K_HsTokens_v22 (T_HsTokens_vIn22 _tlOchildSyns _tlOcon _tlOnt) in let !_tlOaddLines = rule73 _hdIaddLines in let _lhsOerrors :: Seq Error !_lhsOerrors = rule62 _hdIerrors _tlIerrors in let !(T_HsTokens_vOut23 _tlIaddLines _tlItks) = inv_HsTokens_s38 _tlX38 (T_HsTokens_vIn23 _tlOaddLines _tlOruleDescr _tlOuseFieldIdent) in let _lhsOaddLines :: Int !_lhsOaddLines = rule65 _tlIaddLines in let !_tks = rule63 _hdItks _tlItks in let _lhsOtks :: HsTokens !_lhsOtks = rule64 _tks in let !__result_ = T_HsTokens_vOut5 _lhsOaddLines _lhsOerrors _lhsOtks in __result_ ) v22 :: T_HsTokens_v22 v22 = \ !(T_HsTokens_vIn22 _lhsIchildSyns _lhsIcon _lhsInt) -> ( let !_hdX8 = Control.Monad.Identity.runIdentity (attach_T_HsToken (arg_hd_)) in let !_tlX10 = Control.Monad.Identity.runIdentity (attach_T_HsTokens (arg_tl_)) in let !_hdOchildSyns = rule68 _lhsIchildSyns in let !_hdOcon = rule69 _lhsIcon in let !_hdOnt = rule70 _lhsInt in let !_tlOchildSyns = rule75 _lhsIchildSyns in let !_tlOcon = rule76 _lhsIcon in let !_tlOnt = rule77 _lhsInt in let !(T_HsToken_vOut34 _hdIerrors _hdX47) = inv_HsToken_s8 _hdX8 K_HsToken_v34 (T_HsToken_vIn34 _hdOchildSyns _hdOcon _hdOnt) in let !(T_HsTokens_vOut22 _tlIerrors _tlX38) = inv_HsTokens_s10 _tlX10 K_HsTokens_v22 (T_HsTokens_vIn22 _tlOchildSyns _tlOcon _tlOnt) in let _lhsOerrors :: Seq Error !_lhsOerrors = rule62 _hdIerrors _tlIerrors in let !__st_ = st38 _hdX47 _tlX38 !__result_ = T_HsTokens_vOut22 _lhsOerrors __st_ in __result_ ) v24 :: T_HsTokens_v24 v24 = \ !(T_HsTokens_vIn24 _lhsIaddLines _lhsIchildSyns _lhsIcon _lhsInt _lhsIruleDescr _lhsIuseFieldIdent) -> ( let !_hdX8 = Control.Monad.Identity.runIdentity (attach_T_HsToken (arg_hd_)) in let !_tlX10 = Control.Monad.Identity.runIdentity (attach_T_HsTokens (arg_tl_)) in let !_hdOaddLines = rule66 _lhsIaddLines in let !_hdOchildSyns = rule68 _lhsIchildSyns in let !_hdOuseFieldIdent = rule72 _lhsIuseFieldIdent in let !_tlOchildSyns = rule75 _lhsIchildSyns in let !_tlOuseFieldIdent = rule79 _lhsIuseFieldIdent in let !_hdOcon = rule69 _lhsIcon in let !_hdOnt = rule70 _lhsInt in let !_tlOcon = rule76 _lhsIcon in let !_tlOnt = rule77 _lhsInt in let !_hdOruleDescr = rule71 _lhsIruleDescr in let !_tlOruleDescr = rule78 _lhsIruleDescr in let !(T_HsToken_vOut21 _hdIaddLines _hdIerrors _hdItks) = inv_HsToken_s8 _hdX8 K_HsToken_v21 (T_HsToken_vIn21 _hdOaddLines _hdOchildSyns _hdOcon _hdOnt _hdOruleDescr _hdOuseFieldIdent) in let !(T_HsTokens_vOut22 _tlIerrors _tlX38) = inv_HsTokens_s10 _tlX10 K_HsTokens_v22 (T_HsTokens_vIn22 _tlOchildSyns _tlOcon _tlOnt) in let !_tlOaddLines = rule73 _hdIaddLines in let _lhsOerrors :: Seq Error !_lhsOerrors = rule62 _hdIerrors _tlIerrors in let !(T_HsTokens_vOut23 _tlIaddLines _tlItks) = inv_HsTokens_s38 _tlX38 (T_HsTokens_vIn23 _tlOaddLines _tlOruleDescr _tlOuseFieldIdent) in let _lhsOaddLines :: Int !_lhsOaddLines = rule65 _tlIaddLines in let !_tks = rule63 _hdItks _tlItks in let _lhsOtks :: HsTokens !_lhsOtks = rule64 _tks in let !__result_ = T_HsTokens_vOut24 _lhsOaddLines _lhsOerrors _lhsOtks in __result_ ) in C_HsTokens_s10 k10 {-# NOINLINE st38 #-} st38 = \ !_hdX47 !_tlX38 -> let v23 :: T_HsTokens_v23 v23 = \ !(T_HsTokens_vIn23 _lhsIaddLines _lhsIruleDescr _lhsIuseFieldIdent) -> ( let !_hdOaddLines = rule66 _lhsIaddLines in let !_hdOuseFieldIdent = rule72 _lhsIuseFieldIdent in let !_tlOuseFieldIdent = rule79 _lhsIuseFieldIdent in let !_hdOruleDescr = rule71 _lhsIruleDescr in let !_tlOruleDescr = rule78 _lhsIruleDescr in let !(T_HsToken_vOut35 _hdIaddLines _hdItks) = inv_HsToken_s47 _hdX47 (T_HsToken_vIn35 _hdOaddLines _hdOruleDescr _hdOuseFieldIdent) in let !_tlOaddLines = rule73 _hdIaddLines in let !(T_HsTokens_vOut23 _tlIaddLines _tlItks) = inv_HsTokens_s38 _tlX38 (T_HsTokens_vIn23 _tlOaddLines _tlOruleDescr _tlOuseFieldIdent) in let _lhsOaddLines :: Int !_lhsOaddLines = rule65 _tlIaddLines in let !_tks = rule63 _hdItks _tlItks in let _lhsOtks :: HsTokens !_lhsOtks = rule64 _tks in let !__result_ = T_HsTokens_vOut23 _lhsOaddLines _lhsOtks in __result_ ) in C_HsTokens_s38 v23 {-# NOINLINE[1] rule62 #-} rule62 = \ ((!_hdIerrors) :: Seq Error) ((!_tlIerrors) :: Seq Error) -> _hdIerrors Seq.>< _tlIerrors {-# NOINLINE[1] rule63 #-} rule63 = \ ((!_hdItks) :: HsToken) ((!_tlItks) :: HsTokens) -> (:) _hdItks _tlItks {-# NOINLINE[1] rule64 #-} rule64 = \ !_tks -> _tks {-# NOINLINE[1] rule65 #-} rule65 = \ ((!_tlIaddLines) :: Int) -> _tlIaddLines {-# NOINLINE[1] rule66 #-} rule66 = \ ((!_lhsIaddLines) :: Int) -> _lhsIaddLines {-# NOINLINE[1] rule68 #-} rule68 = \ ((!_lhsIchildSyns) :: [(Identifier, Identifier)]) -> _lhsIchildSyns {-# NOINLINE[1] rule69 #-} rule69 = \ ((!_lhsIcon) :: ConstructorIdent) -> _lhsIcon {-# NOINLINE[1] rule70 #-} rule70 = \ ((!_lhsInt) :: NontermIdent) -> _lhsInt {-# NOINLINE[1] rule71 #-} rule71 = \ ((!_lhsIruleDescr) :: String) -> _lhsIruleDescr {-# NOINLINE[1] rule72 #-} rule72 = \ ((!_lhsIuseFieldIdent) :: Bool) -> _lhsIuseFieldIdent {-# NOINLINE[1] rule73 #-} rule73 = \ ((!_hdIaddLines) :: Int) -> _hdIaddLines {-# NOINLINE[1] rule75 #-} rule75 = \ ((!_lhsIchildSyns) :: [(Identifier, Identifier)]) -> _lhsIchildSyns {-# NOINLINE[1] rule76 #-} rule76 = \ ((!_lhsIcon) :: ConstructorIdent) -> _lhsIcon {-# NOINLINE[1] rule77 #-} rule77 = \ ((!_lhsInt) :: NontermIdent) -> _lhsInt {-# NOINLINE[1] rule78 #-} rule78 = \ ((!_lhsIruleDescr) :: String) -> _lhsIruleDescr {-# NOINLINE[1] rule79 #-} rule79 = \ ((!_lhsIuseFieldIdent) :: Bool) -> _lhsIuseFieldIdent {-# NOINLINE sem_HsTokens_Nil #-} sem_HsTokens_Nil :: T_HsTokens sem_HsTokens_Nil = T_HsTokens (return st10) where {-# NOINLINE st10 #-} !st10 = let k10 :: K_HsTokens_s10 t -> t k10 K_HsTokens_v5 = v5 k10 K_HsTokens_v22 = v22 k10 K_HsTokens_v24 = v24 v5 :: T_HsTokens_v5 v5 = \ !(T_HsTokens_vIn5 _lhsIaddLines _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt _lhsIruleDescr _lhsIuseFieldIdent) -> ( let _lhsOerrors :: Seq Error !_lhsOerrors = rule80 () in let !_tks = rule81 () in let _lhsOaddLines :: Int !_lhsOaddLines = rule83 _lhsIaddLines in let _lhsOtks :: HsTokens !_lhsOtks = rule82 _tks in let !__result_ = T_HsTokens_vOut5 _lhsOaddLines _lhsOerrors _lhsOtks in __result_ ) v22 :: T_HsTokens_v22 v22 = \ !(T_HsTokens_vIn22 _lhsIchildSyns _lhsIcon _lhsInt) -> ( let _lhsOerrors :: Seq Error !_lhsOerrors = rule80 () in let !__st_ = st38 () !__result_ = T_HsTokens_vOut22 _lhsOerrors __st_ in __result_ ) v24 :: T_HsTokens_v24 v24 = \ !(T_HsTokens_vIn24 _lhsIaddLines _lhsIchildSyns _lhsIcon _lhsInt _lhsIruleDescr _lhsIuseFieldIdent) -> ( let _lhsOerrors :: Seq Error !_lhsOerrors = rule80 () in let !_tks = rule81 () in let _lhsOaddLines :: Int !_lhsOaddLines = rule83 _lhsIaddLines in let _lhsOtks :: HsTokens !_lhsOtks = rule82 _tks in let !__result_ = T_HsTokens_vOut24 _lhsOaddLines _lhsOerrors _lhsOtks in __result_ ) in C_HsTokens_s10 k10 {-# NOINLINE st38 #-} st38 = \ (_ :: ()) -> let v23 :: T_HsTokens_v23 v23 = \ !(T_HsTokens_vIn23 _lhsIaddLines _lhsIruleDescr _lhsIuseFieldIdent) -> ( let !_tks = rule81 () in let _lhsOaddLines :: Int !_lhsOaddLines = rule83 _lhsIaddLines in let _lhsOtks :: HsTokens !_lhsOtks = rule82 _tks in let !__result_ = T_HsTokens_vOut23 _lhsOaddLines _lhsOtks in __result_ ) in C_HsTokens_s38 v23 {-# NOINLINE[1] rule80 #-} rule80 = \ (_ :: ()) -> Seq.empty {-# NOINLINE[1] rule81 #-} rule81 = \ (_ :: ()) -> [] {-# NOINLINE[1] rule82 #-} rule82 = \ !_tks -> _tks {-# NOINLINE[1] rule83 #-} rule83 = \ ((!_lhsIaddLines) :: Int) -> _lhsIaddLines -- HsTokensRoot ------------------------------------------------ -- wrapper data Inh_HsTokensRoot = Inh_HsTokensRoot { childInhs_Inh_HsTokensRoot :: !([(Identifier, Identifier)]), childSyns_Inh_HsTokensRoot :: !([(Identifier, Identifier)]), con_Inh_HsTokensRoot :: !(ConstructorIdent), nt_Inh_HsTokensRoot :: !(NontermIdent), ruleDescr_Inh_HsTokensRoot :: !(String), useFieldIdent_Inh_HsTokensRoot :: !(Bool) } data Syn_HsTokensRoot = Syn_HsTokensRoot { errors_Syn_HsTokensRoot :: !(Seq Error), tks_Syn_HsTokensRoot :: !([HsToken]) } {-# INLINABLE wrap_HsTokensRoot #-} wrap_HsTokensRoot :: T_HsTokensRoot -> Inh_HsTokensRoot -> (Syn_HsTokensRoot ) wrap_HsTokensRoot !(T_HsTokensRoot act) !(Inh_HsTokensRoot _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt _lhsIruleDescr _lhsIuseFieldIdent) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_HsTokensRoot_vIn6 _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt _lhsIruleDescr _lhsIuseFieldIdent !(T_HsTokensRoot_vOut6 _lhsOerrors _lhsOtks) <- return (inv_HsTokensRoot_s12 sem arg) return (Syn_HsTokensRoot _lhsOerrors _lhsOtks) ) -- cata {-# INLINE sem_HsTokensRoot #-} sem_HsTokensRoot :: HsTokensRoot -> T_HsTokensRoot sem_HsTokensRoot ( HsTokensRoot tokens_ ) = sem_HsTokensRoot_HsTokensRoot ( sem_HsTokens tokens_ ) -- semantic domain newtype T_HsTokensRoot = T_HsTokensRoot { attach_T_HsTokensRoot :: Identity (T_HsTokensRoot_s12 ) } newtype T_HsTokensRoot_s12 = C_HsTokensRoot_s12 { inv_HsTokensRoot_s12 :: (T_HsTokensRoot_v6 ) } data T_HsTokensRoot_s13 = C_HsTokensRoot_s13 type T_HsTokensRoot_v6 = (T_HsTokensRoot_vIn6 ) -> (T_HsTokensRoot_vOut6 ) data T_HsTokensRoot_vIn6 = T_HsTokensRoot_vIn6 !([(Identifier, Identifier)]) !([(Identifier, Identifier)]) !(ConstructorIdent) !(NontermIdent) !(String) !(Bool) data T_HsTokensRoot_vOut6 = T_HsTokensRoot_vOut6 !(Seq Error) !([HsToken]) {-# NOINLINE sem_HsTokensRoot_HsTokensRoot #-} sem_HsTokensRoot_HsTokensRoot :: T_HsTokens -> T_HsTokensRoot sem_HsTokensRoot_HsTokensRoot arg_tokens_ = T_HsTokensRoot (return st12) where {-# NOINLINE st12 #-} !st12 = let v6 :: T_HsTokensRoot_v6 v6 = \ !(T_HsTokensRoot_vIn6 _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsInt _lhsIruleDescr _lhsIuseFieldIdent) -> ( let !_tokensX10 = Control.Monad.Identity.runIdentity (attach_T_HsTokens (arg_tokens_)) in let !_tokensOaddLines = rule84 () in let !_tokensOchildSyns = rule88 _lhsIchildSyns in let !_tokensOcon = rule89 _lhsIcon in let !_tokensOnt = rule90 _lhsInt in let !_tokensOruleDescr = rule91 _lhsIruleDescr in let !_tokensOuseFieldIdent = rule92 _lhsIuseFieldIdent in let !(T_HsTokens_vOut24 _tokensIaddLines _tokensIerrors _tokensItks) = inv_HsTokens_s10 _tokensX10 K_HsTokens_v24 (T_HsTokens_vIn24 _tokensOaddLines _tokensOchildSyns _tokensOcon _tokensOnt _tokensOruleDescr _tokensOuseFieldIdent) in let _lhsOerrors :: Seq Error !_lhsOerrors = rule85 _tokensIerrors in let _lhsOtks :: [HsToken] !_lhsOtks = rule86 _tokensItks in let !__result_ = T_HsTokensRoot_vOut6 _lhsOerrors _lhsOtks in __result_ ) in C_HsTokensRoot_s12 v6 {-# INLINE rule84 #-} {-# LINE 67 "./src-ag/Desugar.ag" #-} rule84 = \ (_ :: ()) -> {-# LINE 67 "./src-ag/Desugar.ag" #-} 0 {-# LINE 1358 "dist/build/Desugar.hs"#-} {-# INLINE rule85 #-} rule85 = \ ((!_tokensIerrors) :: Seq Error) -> _tokensIerrors {-# INLINE rule86 #-} rule86 = \ ((!_tokensItks) :: HsTokens) -> _tokensItks {-# INLINE rule88 #-} rule88 = \ ((!_lhsIchildSyns) :: [(Identifier, Identifier)]) -> _lhsIchildSyns {-# INLINE rule89 #-} rule89 = \ ((!_lhsIcon) :: ConstructorIdent) -> _lhsIcon {-# INLINE rule90 #-} rule90 = \ ((!_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule91 #-} rule91 = \ ((!_lhsIruleDescr) :: String) -> _lhsIruleDescr {-# INLINE rule92 #-} rule92 = \ ((!_lhsIuseFieldIdent) :: Bool) -> _lhsIuseFieldIdent -- Nonterminal ------------------------------------------------- -- wrapper data Inh_Nonterminal = Inh_Nonterminal { augmentsIn_Inh_Nonterminal :: !(Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))), forcedIrrefutables_Inh_Nonterminal :: !(AttrMap), inhMap_Inh_Nonterminal :: !(Map Identifier Attributes), mainName_Inh_Nonterminal :: !(String), options_Inh_Nonterminal :: !(Options), synMap_Inh_Nonterminal :: !(Map Identifier Attributes) } data Syn_Nonterminal = Syn_Nonterminal { allAttributes_Syn_Nonterminal :: !(AttrMap), augmentsOut_Syn_Nonterminal :: !(Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))), errors_Syn_Nonterminal :: !(Seq Error), inhMap'_Syn_Nonterminal :: !(Map Identifier Attributes), output_Syn_Nonterminal :: !(Nonterminal), synMap'_Syn_Nonterminal :: !(Map Identifier Attributes) } {-# INLINABLE wrap_Nonterminal #-} wrap_Nonterminal :: T_Nonterminal -> Inh_Nonterminal -> (Syn_Nonterminal ) wrap_Nonterminal !(T_Nonterminal act) !(Inh_Nonterminal _lhsIaugmentsIn _lhsIforcedIrrefutables _lhsIinhMap _lhsImainName _lhsIoptions _lhsIsynMap) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Nonterminal_vIn7 _lhsIaugmentsIn _lhsIforcedIrrefutables _lhsIinhMap _lhsImainName _lhsIoptions _lhsIsynMap !(T_Nonterminal_vOut7 _lhsOallAttributes _lhsOaugmentsOut _lhsOerrors _lhsOinhMap' _lhsOoutput _lhsOsynMap') <- return (inv_Nonterminal_s14 sem K_Nonterminal_v7 arg) return (Syn_Nonterminal _lhsOallAttributes _lhsOaugmentsOut _lhsOerrors _lhsOinhMap' _lhsOoutput _lhsOsynMap') ) -- cata {-# INLINE sem_Nonterminal #-} sem_Nonterminal :: Nonterminal -> T_Nonterminal sem_Nonterminal ( Nonterminal !nt_ !params_ !inh_ !syn_ prods_ ) = sem_Nonterminal_Nonterminal nt_ params_ inh_ syn_ ( sem_Productions prods_ ) -- semantic domain newtype T_Nonterminal = T_Nonterminal { attach_T_Nonterminal :: Identity (T_Nonterminal_s14 ) } data T_Nonterminal_s14 where C_Nonterminal_s14 :: { inv_Nonterminal_s14 :: !(forall t. K_Nonterminal_s14 t -> t) } -> T_Nonterminal_s14 data T_Nonterminal_s15 = C_Nonterminal_s15 newtype T_Nonterminal_s46 = C_Nonterminal_s46 { inv_Nonterminal_s46 :: (T_Nonterminal_v33 ) } data K_Nonterminal_s14 k where K_Nonterminal_v7 :: K_Nonterminal_s14 (T_Nonterminal_v7 ) K_Nonterminal_v32 :: K_Nonterminal_s14 (T_Nonterminal_v32 ) type T_Nonterminal_v7 = (T_Nonterminal_vIn7 ) -> (T_Nonterminal_vOut7 ) data T_Nonterminal_vIn7 = T_Nonterminal_vIn7 !(Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) !(AttrMap) !(Map Identifier Attributes) !(String) !(Options) !(Map Identifier Attributes) data T_Nonterminal_vOut7 = T_Nonterminal_vOut7 !(AttrMap) !(Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) !(Seq Error) !(Map Identifier Attributes) !(Nonterminal) !(Map Identifier Attributes) type T_Nonterminal_v32 = (T_Nonterminal_vIn32 ) -> (T_Nonterminal_vOut32 ) data T_Nonterminal_vIn32 = T_Nonterminal_vIn32 data T_Nonterminal_vOut32 = T_Nonterminal_vOut32 !(AttrMap) !(Map Identifier Attributes) !(Map Identifier Attributes) !(T_Nonterminal_s46 ) type T_Nonterminal_v33 = (T_Nonterminal_vIn33 ) -> (T_Nonterminal_vOut33 ) data T_Nonterminal_vIn33 = T_Nonterminal_vIn33 !(Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) !(AttrMap) !(Map Identifier Attributes) !(String) !(Options) !(Map Identifier Attributes) data T_Nonterminal_vOut33 = T_Nonterminal_vOut33 !(Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) !(Seq Error) !(Nonterminal) {-# NOINLINE sem_Nonterminal_Nonterminal #-} sem_Nonterminal_Nonterminal :: (NontermIdent) -> ([Identifier]) -> (Attributes) -> (Attributes) -> T_Productions -> T_Nonterminal sem_Nonterminal_Nonterminal !arg_nt_ !arg_params_ !arg_inh_ !arg_syn_ arg_prods_ = T_Nonterminal (return st14) where {-# NOINLINE st14 #-} !st14 = let k14 :: K_Nonterminal_s14 t -> t k14 K_Nonterminal_v7 = v7 k14 K_Nonterminal_v32 = v32 v7 :: T_Nonterminal_v7 v7 = \ !(T_Nonterminal_vIn7 _lhsIaugmentsIn _lhsIforcedIrrefutables _lhsIinhMap _lhsImainName _lhsIoptions _lhsIsynMap) -> ( let !_prodsX24 = Control.Monad.Identity.runIdentity (attach_T_Productions (arg_prods_)) in let !_prodsOnt = rule95 arg_nt_ in let !_augmentsIn = rule96 _lhsIaugmentsIn arg_nt_ in let !_prodsOaugmentsIn = rule104 _augmentsIn in let !_prodsOinhMap = rule106 _lhsIinhMap in let !_prodsOoptions = rule108 _lhsIoptions in let !_prodsOsynMap = rule109 _lhsIsynMap in let _lhsOinhMap' :: Map Identifier Attributes !_lhsOinhMap' = rule93 arg_inh_ arg_nt_ in let !_prodsOforcedIrrefutables = rule105 _lhsIforcedIrrefutables in let !_extraInh = rule98 _lhsImainName _lhsIoptions in let _lhsOsynMap' :: Map Identifier Attributes !_lhsOsynMap' = rule94 arg_nt_ arg_syn_ in let !(T_Productions_vOut25 _prodsIallAttributes _prodsIaugmentsOut _prodsIerrors _prodsIoutput) = inv_Productions_s24 _prodsX24 K_Productions_v25 (T_Productions_vIn25 _prodsOaugmentsIn _prodsOforcedIrrefutables _prodsOinhMap _prodsOnt _prodsOoptions _prodsOsynMap) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule100 _prodsIallAttributes in let !_augmentsOut = rule97 _prodsIaugmentsOut arg_nt_ in let _lhsOaugmentsOut :: Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression])) !_lhsOaugmentsOut = rule101 _augmentsOut in let _lhsOerrors :: Seq Error !_lhsOerrors = rule102 _prodsIerrors in let _lhsOoutput :: Nonterminal !_lhsOoutput = rule99 _extraInh _prodsIoutput arg_inh_ arg_nt_ arg_params_ arg_syn_ in let !__result_ = T_Nonterminal_vOut7 _lhsOallAttributes _lhsOaugmentsOut _lhsOerrors _lhsOinhMap' _lhsOoutput _lhsOsynMap' in __result_ ) v32 :: T_Nonterminal_v32 v32 = \ !(T_Nonterminal_vIn32 ) -> ( let !_prodsX24 = Control.Monad.Identity.runIdentity (attach_T_Productions (arg_prods_)) in let !_prodsOnt = rule95 arg_nt_ in let _lhsOinhMap' :: Map Identifier Attributes !_lhsOinhMap' = rule93 arg_inh_ arg_nt_ in let _lhsOsynMap' :: Map Identifier Attributes !_lhsOsynMap' = rule94 arg_nt_ arg_syn_ in let !(T_Productions_vOut39 _prodsIallAttributes _prodsX50) = inv_Productions_s24 _prodsX24 K_Productions_v39 (T_Productions_vIn39 _prodsOnt) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule100 _prodsIallAttributes in let !__st_ = st46 _prodsX50 !__result_ = T_Nonterminal_vOut32 _lhsOallAttributes _lhsOinhMap' _lhsOsynMap' __st_ in __result_ ) in C_Nonterminal_s14 k14 {-# NOINLINE st46 #-} st46 = \ !_prodsX50 -> let v33 :: T_Nonterminal_v33 v33 = \ !(T_Nonterminal_vIn33 _lhsIaugmentsIn _lhsIforcedIrrefutables _lhsIinhMap _lhsImainName _lhsIoptions _lhsIsynMap) -> ( let !_augmentsIn = rule96 _lhsIaugmentsIn arg_nt_ in let !_prodsOaugmentsIn = rule104 _augmentsIn in let !_prodsOinhMap = rule106 _lhsIinhMap in let !_prodsOoptions = rule108 _lhsIoptions in let !_prodsOsynMap = rule109 _lhsIsynMap in let !_prodsOforcedIrrefutables = rule105 _lhsIforcedIrrefutables in let !_extraInh = rule98 _lhsImainName _lhsIoptions in let !(T_Productions_vOut40 _prodsIaugmentsOut _prodsIerrors _prodsIoutput) = inv_Productions_s50 _prodsX50 (T_Productions_vIn40 _prodsOaugmentsIn _prodsOforcedIrrefutables _prodsOinhMap _prodsOoptions _prodsOsynMap) in let !_augmentsOut = rule97 _prodsIaugmentsOut arg_nt_ in let _lhsOaugmentsOut :: Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression])) !_lhsOaugmentsOut = rule101 _augmentsOut in let _lhsOerrors :: Seq Error !_lhsOerrors = rule102 _prodsIerrors in let _lhsOoutput :: Nonterminal !_lhsOoutput = rule99 _extraInh _prodsIoutput arg_inh_ arg_nt_ arg_params_ arg_syn_ in let !__result_ = T_Nonterminal_vOut33 _lhsOaugmentsOut _lhsOerrors _lhsOoutput in __result_ ) in C_Nonterminal_s46 v33 {-# NOINLINE[1] rule93 #-} {-# LINE 7 "./src-ag/DistChildAttr.ag" #-} rule93 = \ !inh_ !nt_ -> {-# LINE 7 "./src-ag/DistChildAttr.ag" #-} Map.singleton nt_ inh_ {-# LINE 1500 "dist/build/Desugar.hs"#-} {-# NOINLINE[1] rule94 #-} {-# LINE 8 "./src-ag/DistChildAttr.ag" #-} rule94 = \ !nt_ !syn_ -> {-# LINE 8 "./src-ag/DistChildAttr.ag" #-} Map.singleton nt_ syn_ {-# LINE 1506 "dist/build/Desugar.hs"#-} {-# NOINLINE[1] rule95 #-} {-# LINE 157 "./src-ag/Desugar.ag" #-} rule95 = \ !nt_ -> {-# LINE 157 "./src-ag/Desugar.ag" #-} nt_ {-# LINE 1512 "dist/build/Desugar.hs"#-} {-# NOINLINE[1] rule96 #-} {-# LINE 239 "./src-ag/Desugar.ag" #-} rule96 = \ ((!_lhsIaugmentsIn) :: Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) !nt_ -> {-# LINE 239 "./src-ag/Desugar.ag" #-} Map.findWithDefault Map.empty nt_ _lhsIaugmentsIn {-# LINE 1518 "dist/build/Desugar.hs"#-} {-# NOINLINE[1] rule97 #-} {-# LINE 240 "./src-ag/Desugar.ag" #-} rule97 = \ ((!_prodsIaugmentsOut) :: Map ConstructorIdent (Map Identifier [Expression])) !nt_ -> {-# LINE 240 "./src-ag/Desugar.ag" #-} Map.singleton nt_ _prodsIaugmentsOut {-# LINE 1524 "dist/build/Desugar.hs"#-} {-# NOINLINE[1] rule98 #-} {-# LINE 292 "./src-ag/Desugar.ag" #-} rule98 = \ ((!_lhsImainName) :: String) ((!_lhsIoptions) :: Options) -> {-# LINE 292 "./src-ag/Desugar.ag" #-} addLateAttr _lhsIoptions _lhsImainName {-# LINE 1530 "dist/build/Desugar.hs"#-} {-# NOINLINE[1] rule99 #-} {-# LINE 308 "./src-ag/Desugar.ag" #-} rule99 = \ !_extraInh ((!_prodsIoutput) :: Productions) !inh_ !nt_ !params_ !syn_ -> {-# LINE 308 "./src-ag/Desugar.ag" #-} Nonterminal nt_ params_ (_extraInh `Map.union` inh_) syn_ _prodsIoutput {-# LINE 1540 "dist/build/Desugar.hs"#-} {-# NOINLINE[1] rule100 #-} rule100 = \ ((!_prodsIallAttributes) :: AttrMap) -> _prodsIallAttributes {-# NOINLINE[1] rule101 #-} rule101 = \ !_augmentsOut -> _augmentsOut {-# NOINLINE[1] rule102 #-} rule102 = \ ((!_prodsIerrors) :: Seq Error) -> _prodsIerrors {-# NOINLINE[1] rule104 #-} rule104 = \ !_augmentsIn -> _augmentsIn {-# NOINLINE[1] rule105 #-} rule105 = \ ((!_lhsIforcedIrrefutables) :: AttrMap) -> _lhsIforcedIrrefutables {-# NOINLINE[1] rule106 #-} rule106 = \ ((!_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# NOINLINE[1] rule108 #-} rule108 = \ ((!_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE[1] rule109 #-} rule109 = \ ((!_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap -- Nonterminals ------------------------------------------------ -- wrapper data Inh_Nonterminals = Inh_Nonterminals { augmentsIn_Inh_Nonterminals :: !(Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))), forcedIrrefutables_Inh_Nonterminals :: !(AttrMap), inhMap_Inh_Nonterminals :: !(Map Identifier Attributes), mainName_Inh_Nonterminals :: !(String), options_Inh_Nonterminals :: !(Options), synMap_Inh_Nonterminals :: !(Map Identifier Attributes) } data Syn_Nonterminals = Syn_Nonterminals { allAttributes_Syn_Nonterminals :: !(AttrMap), augmentsOut_Syn_Nonterminals :: !(Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))), errors_Syn_Nonterminals :: !(Seq Error), inhMap'_Syn_Nonterminals :: !(Map Identifier Attributes), output_Syn_Nonterminals :: !(Nonterminals), synMap'_Syn_Nonterminals :: !(Map Identifier Attributes) } {-# INLINABLE wrap_Nonterminals #-} wrap_Nonterminals :: T_Nonterminals -> Inh_Nonterminals -> (Syn_Nonterminals ) wrap_Nonterminals !(T_Nonterminals act) !(Inh_Nonterminals _lhsIaugmentsIn _lhsIforcedIrrefutables _lhsIinhMap _lhsImainName _lhsIoptions _lhsIsynMap) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Nonterminals_vIn8 _lhsIaugmentsIn _lhsIforcedIrrefutables _lhsIinhMap _lhsImainName _lhsIoptions _lhsIsynMap !(T_Nonterminals_vOut8 _lhsOallAttributes _lhsOaugmentsOut _lhsOerrors _lhsOinhMap' _lhsOoutput _lhsOsynMap') <- return (inv_Nonterminals_s16 sem K_Nonterminals_v8 arg) return (Syn_Nonterminals _lhsOallAttributes _lhsOaugmentsOut _lhsOerrors _lhsOinhMap' _lhsOoutput _lhsOsynMap') ) -- cata {-# NOINLINE sem_Nonterminals #-} sem_Nonterminals :: Nonterminals -> T_Nonterminals sem_Nonterminals list = Prelude.foldr sem_Nonterminals_Cons sem_Nonterminals_Nil (Prelude.map sem_Nonterminal list) -- semantic domain newtype T_Nonterminals = T_Nonterminals { attach_T_Nonterminals :: Identity (T_Nonterminals_s16 ) } data T_Nonterminals_s16 where C_Nonterminals_s16 :: { inv_Nonterminals_s16 :: !(forall t. K_Nonterminals_s16 t -> t) } -> T_Nonterminals_s16 data T_Nonterminals_s17 = C_Nonterminals_s17 newtype T_Nonterminals_s36 = C_Nonterminals_s36 { inv_Nonterminals_s36 :: (T_Nonterminals_v20 ) } data K_Nonterminals_s16 k where K_Nonterminals_v8 :: K_Nonterminals_s16 (T_Nonterminals_v8 ) K_Nonterminals_v19 :: K_Nonterminals_s16 (T_Nonterminals_v19 ) type T_Nonterminals_v8 = (T_Nonterminals_vIn8 ) -> (T_Nonterminals_vOut8 ) data T_Nonterminals_vIn8 = T_Nonterminals_vIn8 !(Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) !(AttrMap) !(Map Identifier Attributes) !(String) !(Options) !(Map Identifier Attributes) data T_Nonterminals_vOut8 = T_Nonterminals_vOut8 !(AttrMap) !(Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) !(Seq Error) !(Map Identifier Attributes) !(Nonterminals) !(Map Identifier Attributes) type T_Nonterminals_v19 = (T_Nonterminals_vIn19 ) -> (T_Nonterminals_vOut19 ) data T_Nonterminals_vIn19 = T_Nonterminals_vIn19 data T_Nonterminals_vOut19 = T_Nonterminals_vOut19 !(AttrMap) !(Map Identifier Attributes) !(Map Identifier Attributes) !(T_Nonterminals_s36 ) type T_Nonterminals_v20 = (T_Nonterminals_vIn20 ) -> (T_Nonterminals_vOut20 ) data T_Nonterminals_vIn20 = T_Nonterminals_vIn20 !(Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) !(AttrMap) !(Map Identifier Attributes) !(String) !(Options) !(Map Identifier Attributes) data T_Nonterminals_vOut20 = T_Nonterminals_vOut20 !(Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) !(Seq Error) !(Nonterminals) {-# NOINLINE sem_Nonterminals_Cons #-} sem_Nonterminals_Cons :: T_Nonterminal -> T_Nonterminals -> T_Nonterminals sem_Nonterminals_Cons arg_hd_ arg_tl_ = T_Nonterminals (return st16) where {-# NOINLINE st16 #-} !st16 = let k16 :: K_Nonterminals_s16 t -> t k16 K_Nonterminals_v8 = v8 k16 K_Nonterminals_v19 = v19 v8 :: T_Nonterminals_v8 v8 = \ !(T_Nonterminals_vIn8 _lhsIaugmentsIn _lhsIforcedIrrefutables _lhsIinhMap _lhsImainName _lhsIoptions _lhsIsynMap) -> ( let !_hdX14 = Control.Monad.Identity.runIdentity (attach_T_Nonterminal (arg_hd_)) in let !_tlX16 = Control.Monad.Identity.runIdentity (attach_T_Nonterminals (arg_tl_)) in let !_hdOaugmentsIn = rule117 _lhsIaugmentsIn in let !_hdOinhMap = rule119 _lhsIinhMap in let !_hdOoptions = rule121 _lhsIoptions in let !_hdOsynMap = rule122 _lhsIsynMap in let !_tlOaugmentsIn = rule123 _lhsIaugmentsIn in let !_tlOinhMap = rule125 _lhsIinhMap in let !_tlOoptions = rule127 _lhsIoptions in let !_tlOsynMap = rule128 _lhsIsynMap in let !_hdOforcedIrrefutables = rule118 _lhsIforcedIrrefutables in let !_hdOmainName = rule120 _lhsImainName in let !_tlOforcedIrrefutables = rule124 _lhsIforcedIrrefutables in let !_tlOmainName = rule126 _lhsImainName in let !(T_Nonterminal_vOut7 _hdIallAttributes _hdIaugmentsOut _hdIerrors _hdIinhMap' _hdIoutput _hdIsynMap') = inv_Nonterminal_s14 _hdX14 K_Nonterminal_v7 (T_Nonterminal_vIn7 _hdOaugmentsIn _hdOforcedIrrefutables _hdOinhMap _hdOmainName _hdOoptions _hdOsynMap) in let !(T_Nonterminals_vOut8 _tlIallAttributes _tlIaugmentsOut _tlIerrors _tlIinhMap' _tlIoutput _tlIsynMap') = inv_Nonterminals_s16 _tlX16 K_Nonterminals_v8 (T_Nonterminals_vIn8 _tlOaugmentsIn _tlOforcedIrrefutables _tlOinhMap _tlOmainName _tlOoptions _tlOsynMap) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule110 _hdIallAttributes _tlIallAttributes in let _lhsOaugmentsOut :: Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression])) !_lhsOaugmentsOut = rule111 _hdIaugmentsOut _tlIaugmentsOut in let _lhsOerrors :: Seq Error !_lhsOerrors = rule112 _hdIerrors _tlIerrors in let _lhsOinhMap' :: Map Identifier Attributes !_lhsOinhMap' = rule113 _hdIinhMap' _tlIinhMap' in let !_output = rule115 _hdIoutput _tlIoutput in let _lhsOoutput :: Nonterminals !_lhsOoutput = rule116 _output in let _lhsOsynMap' :: Map Identifier Attributes !_lhsOsynMap' = rule114 _hdIsynMap' _tlIsynMap' in let !__result_ = T_Nonterminals_vOut8 _lhsOallAttributes _lhsOaugmentsOut _lhsOerrors _lhsOinhMap' _lhsOoutput _lhsOsynMap' in __result_ ) v19 :: T_Nonterminals_v19 v19 = \ !(T_Nonterminals_vIn19 ) -> ( let !_hdX14 = Control.Monad.Identity.runIdentity (attach_T_Nonterminal (arg_hd_)) in let !_tlX16 = Control.Monad.Identity.runIdentity (attach_T_Nonterminals (arg_tl_)) in let !(T_Nonterminal_vOut32 _hdIallAttributes _hdIinhMap' _hdIsynMap' _hdX46) = inv_Nonterminal_s14 _hdX14 K_Nonterminal_v32 (T_Nonterminal_vIn32 ) in let !(T_Nonterminals_vOut19 _tlIallAttributes _tlIinhMap' _tlIsynMap' _tlX36) = inv_Nonterminals_s16 _tlX16 K_Nonterminals_v19 (T_Nonterminals_vIn19 ) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule110 _hdIallAttributes _tlIallAttributes in let _lhsOinhMap' :: Map Identifier Attributes !_lhsOinhMap' = rule113 _hdIinhMap' _tlIinhMap' in let _lhsOsynMap' :: Map Identifier Attributes !_lhsOsynMap' = rule114 _hdIsynMap' _tlIsynMap' in let !__st_ = st36 _hdX46 _tlX36 !__result_ = T_Nonterminals_vOut19 _lhsOallAttributes _lhsOinhMap' _lhsOsynMap' __st_ in __result_ ) in C_Nonterminals_s16 k16 {-# NOINLINE st36 #-} st36 = \ !_hdX46 !_tlX36 -> let v20 :: T_Nonterminals_v20 v20 = \ !(T_Nonterminals_vIn20 _lhsIaugmentsIn _lhsIforcedIrrefutables _lhsIinhMap _lhsImainName _lhsIoptions _lhsIsynMap) -> ( let !_hdOaugmentsIn = rule117 _lhsIaugmentsIn in let !_hdOinhMap = rule119 _lhsIinhMap in let !_hdOoptions = rule121 _lhsIoptions in let !_hdOsynMap = rule122 _lhsIsynMap in let !_tlOaugmentsIn = rule123 _lhsIaugmentsIn in let !_tlOinhMap = rule125 _lhsIinhMap in let !_tlOoptions = rule127 _lhsIoptions in let !_tlOsynMap = rule128 _lhsIsynMap in let !_hdOforcedIrrefutables = rule118 _lhsIforcedIrrefutables in let !_hdOmainName = rule120 _lhsImainName in let !_tlOforcedIrrefutables = rule124 _lhsIforcedIrrefutables in let !_tlOmainName = rule126 _lhsImainName in let !(T_Nonterminal_vOut33 _hdIaugmentsOut _hdIerrors _hdIoutput) = inv_Nonterminal_s46 _hdX46 (T_Nonterminal_vIn33 _hdOaugmentsIn _hdOforcedIrrefutables _hdOinhMap _hdOmainName _hdOoptions _hdOsynMap) in let !(T_Nonterminals_vOut20 _tlIaugmentsOut _tlIerrors _tlIoutput) = inv_Nonterminals_s36 _tlX36 (T_Nonterminals_vIn20 _tlOaugmentsIn _tlOforcedIrrefutables _tlOinhMap _tlOmainName _tlOoptions _tlOsynMap) in let _lhsOaugmentsOut :: Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression])) !_lhsOaugmentsOut = rule111 _hdIaugmentsOut _tlIaugmentsOut in let _lhsOerrors :: Seq Error !_lhsOerrors = rule112 _hdIerrors _tlIerrors in let !_output = rule115 _hdIoutput _tlIoutput in let _lhsOoutput :: Nonterminals !_lhsOoutput = rule116 _output in let !__result_ = T_Nonterminals_vOut20 _lhsOaugmentsOut _lhsOerrors _lhsOoutput in __result_ ) in C_Nonterminals_s36 v20 {-# NOINLINE[1] rule110 #-} rule110 = \ ((!_hdIallAttributes) :: AttrMap) ((!_tlIallAttributes) :: AttrMap) -> _hdIallAttributes `mergeAttributes` _tlIallAttributes {-# NOINLINE[1] rule111 #-} rule111 = \ ((!_hdIaugmentsOut) :: Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) ((!_tlIaugmentsOut) :: Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) -> _hdIaugmentsOut `Map.union` _tlIaugmentsOut {-# NOINLINE[1] rule112 #-} rule112 = \ ((!_hdIerrors) :: Seq Error) ((!_tlIerrors) :: Seq Error) -> _hdIerrors Seq.>< _tlIerrors {-# NOINLINE[1] rule113 #-} rule113 = \ ((!_hdIinhMap') :: Map Identifier Attributes) ((!_tlIinhMap') :: Map Identifier Attributes) -> _hdIinhMap' `Map.union` _tlIinhMap' {-# NOINLINE[1] rule114 #-} rule114 = \ ((!_hdIsynMap') :: Map Identifier Attributes) ((!_tlIsynMap') :: Map Identifier Attributes) -> _hdIsynMap' `Map.union` _tlIsynMap' {-# NOINLINE[1] rule115 #-} rule115 = \ ((!_hdIoutput) :: Nonterminal) ((!_tlIoutput) :: Nonterminals) -> (:) _hdIoutput _tlIoutput {-# NOINLINE[1] rule116 #-} rule116 = \ !_output -> _output {-# NOINLINE[1] rule117 #-} rule117 = \ ((!_lhsIaugmentsIn) :: Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) -> _lhsIaugmentsIn {-# NOINLINE[1] rule118 #-} rule118 = \ ((!_lhsIforcedIrrefutables) :: AttrMap) -> _lhsIforcedIrrefutables {-# NOINLINE[1] rule119 #-} rule119 = \ ((!_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# NOINLINE[1] rule120 #-} rule120 = \ ((!_lhsImainName) :: String) -> _lhsImainName {-# NOINLINE[1] rule121 #-} rule121 = \ ((!_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE[1] rule122 #-} rule122 = \ ((!_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# NOINLINE[1] rule123 #-} rule123 = \ ((!_lhsIaugmentsIn) :: Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) -> _lhsIaugmentsIn {-# NOINLINE[1] rule124 #-} rule124 = \ ((!_lhsIforcedIrrefutables) :: AttrMap) -> _lhsIforcedIrrefutables {-# NOINLINE[1] rule125 #-} rule125 = \ ((!_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# NOINLINE[1] rule126 #-} rule126 = \ ((!_lhsImainName) :: String) -> _lhsImainName {-# NOINLINE[1] rule127 #-} rule127 = \ ((!_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE[1] rule128 #-} rule128 = \ ((!_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# NOINLINE sem_Nonterminals_Nil #-} sem_Nonterminals_Nil :: T_Nonterminals sem_Nonterminals_Nil = T_Nonterminals (return st16) where {-# NOINLINE st16 #-} !st16 = let k16 :: K_Nonterminals_s16 t -> t k16 K_Nonterminals_v8 = v8 k16 K_Nonterminals_v19 = v19 v8 :: T_Nonterminals_v8 v8 = \ !(T_Nonterminals_vIn8 _lhsIaugmentsIn _lhsIforcedIrrefutables _lhsIinhMap _lhsImainName _lhsIoptions _lhsIsynMap) -> ( let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule129 () in let _lhsOaugmentsOut :: Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression])) !_lhsOaugmentsOut = rule130 () in let _lhsOerrors :: Seq Error !_lhsOerrors = rule131 () in let _lhsOinhMap' :: Map Identifier Attributes !_lhsOinhMap' = rule132 () in let !_output = rule134 () in let _lhsOsynMap' :: Map Identifier Attributes !_lhsOsynMap' = rule133 () in let _lhsOoutput :: Nonterminals !_lhsOoutput = rule135 _output in let !__result_ = T_Nonterminals_vOut8 _lhsOallAttributes _lhsOaugmentsOut _lhsOerrors _lhsOinhMap' _lhsOoutput _lhsOsynMap' in __result_ ) v19 :: T_Nonterminals_v19 v19 = \ !(T_Nonterminals_vIn19 ) -> ( let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule129 () in let _lhsOinhMap' :: Map Identifier Attributes !_lhsOinhMap' = rule132 () in let _lhsOsynMap' :: Map Identifier Attributes !_lhsOsynMap' = rule133 () in let !__st_ = st36 () !__result_ = T_Nonterminals_vOut19 _lhsOallAttributes _lhsOinhMap' _lhsOsynMap' __st_ in __result_ ) in C_Nonterminals_s16 k16 {-# NOINLINE st36 #-} st36 = \ (_ :: ()) -> let v20 :: T_Nonterminals_v20 v20 = \ !(T_Nonterminals_vIn20 _lhsIaugmentsIn _lhsIforcedIrrefutables _lhsIinhMap _lhsImainName _lhsIoptions _lhsIsynMap) -> ( let _lhsOaugmentsOut :: Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression])) !_lhsOaugmentsOut = rule130 () in let _lhsOerrors :: Seq Error !_lhsOerrors = rule131 () in let !_output = rule134 () in let _lhsOoutput :: Nonterminals !_lhsOoutput = rule135 _output in let !__result_ = T_Nonterminals_vOut20 _lhsOaugmentsOut _lhsOerrors _lhsOoutput in __result_ ) in C_Nonterminals_s36 v20 {-# NOINLINE[1] rule129 #-} rule129 = \ (_ :: ()) -> Map.empty {-# NOINLINE[1] rule130 #-} rule130 = \ (_ :: ()) -> Map.empty {-# NOINLINE[1] rule131 #-} rule131 = \ (_ :: ()) -> Seq.empty {-# NOINLINE[1] rule132 #-} rule132 = \ (_ :: ()) -> Map.empty {-# NOINLINE[1] rule133 #-} rule133 = \ (_ :: ()) -> Map.empty {-# NOINLINE[1] rule134 #-} rule134 = \ (_ :: ()) -> [] {-# NOINLINE[1] rule135 #-} rule135 = \ !_output -> _output -- Pattern ----------------------------------------------------- -- wrapper data Inh_Pattern = Inh_Pattern { childInhs_Inh_Pattern :: !([(Identifier, Identifier)]), childSyns_Inh_Pattern :: !([(Identifier, Identifier)]), con_Inh_Pattern :: !(ConstructorIdent), defs_Inh_Pattern :: !(Set (Identifier, Identifier)), forcedIrrefutables_Inh_Pattern :: !(AttrMap), nt_Inh_Pattern :: !(NontermIdent) } data Syn_Pattern = Syn_Pattern { allAttributes_Syn_Pattern :: !(AttrMap), copy_Syn_Pattern :: !(Pattern), defsCollect_Syn_Pattern :: !(Set (Identifier, Identifier)), errors_Syn_Pattern :: !(Seq Error), output_Syn_Pattern :: !(Pattern) } {-# INLINABLE wrap_Pattern #-} wrap_Pattern :: T_Pattern -> Inh_Pattern -> (Syn_Pattern ) wrap_Pattern !(T_Pattern act) !(Inh_Pattern _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Pattern_vIn9 _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt !(T_Pattern_vOut9 _lhsOallAttributes _lhsOcopy _lhsOdefsCollect _lhsOerrors _lhsOoutput) <- return (inv_Pattern_s18 sem K_Pattern_v9 arg) return (Syn_Pattern _lhsOallAttributes _lhsOcopy _lhsOdefsCollect _lhsOerrors _lhsOoutput) ) -- cata {-# NOINLINE sem_Pattern #-} sem_Pattern :: Pattern -> T_Pattern sem_Pattern ( Constr !name_ pats_ ) = sem_Pattern_Constr name_ ( sem_Patterns pats_ ) sem_Pattern ( Product !pos_ pats_ ) = sem_Pattern_Product pos_ ( sem_Patterns pats_ ) sem_Pattern ( Alias !field_ !attr_ pat_ ) = sem_Pattern_Alias field_ attr_ ( sem_Pattern pat_ ) sem_Pattern ( Irrefutable pat_ ) = sem_Pattern_Irrefutable ( sem_Pattern pat_ ) sem_Pattern ( Underscore !pos_ ) = sem_Pattern_Underscore pos_ -- semantic domain newtype T_Pattern = T_Pattern { attach_T_Pattern :: Identity (T_Pattern_s18 ) } data T_Pattern_s18 where C_Pattern_s18 :: { inv_Pattern_s18 :: !(forall t. K_Pattern_s18 t -> t) } -> T_Pattern_s18 data T_Pattern_s19 = C_Pattern_s19 data T_Pattern_s42 = C_Pattern_s42 data T_Pattern_s45 = C_Pattern_s45 newtype T_Pattern_s51 = C_Pattern_s51 { inv_Pattern_s51 :: (T_Pattern_v42 ) } newtype T_Pattern_s54 = C_Pattern_s54 { inv_Pattern_s54 :: (T_Pattern_v48 ) } newtype T_Pattern_s58 = C_Pattern_s58 { inv_Pattern_s58 :: (T_Pattern_v56 ) } data K_Pattern_s18 k where K_Pattern_v9 :: K_Pattern_s18 (T_Pattern_v9 ) K_Pattern_v27 :: K_Pattern_s18 (T_Pattern_v27 ) K_Pattern_v31 :: K_Pattern_s18 (T_Pattern_v31 ) K_Pattern_v41 :: K_Pattern_s18 (T_Pattern_v41 ) K_Pattern_v46 :: K_Pattern_s18 (T_Pattern_v46 ) K_Pattern_v55 :: K_Pattern_s18 (T_Pattern_v55 ) type T_Pattern_v9 = (T_Pattern_vIn9 ) -> (T_Pattern_vOut9 ) data T_Pattern_vIn9 = T_Pattern_vIn9 !([(Identifier, Identifier)]) !([(Identifier, Identifier)]) !(ConstructorIdent) !(Set (Identifier, Identifier)) !(AttrMap) !(NontermIdent) data T_Pattern_vOut9 = T_Pattern_vOut9 !(AttrMap) !(Pattern) !(Set (Identifier, Identifier)) !(Seq Error) !(Pattern) type T_Pattern_v27 = (T_Pattern_vIn27 ) -> (T_Pattern_vOut27 ) data T_Pattern_vIn27 = T_Pattern_vIn27 !([(Identifier, Identifier)]) !(ConstructorIdent) !(Set (Identifier, Identifier)) !(AttrMap) !(NontermIdent) data T_Pattern_vOut27 = T_Pattern_vOut27 !(AttrMap) !(Pattern) !(Set (Identifier, Identifier)) !(Seq Error) !(Pattern) type T_Pattern_v31 = (T_Pattern_vIn31 ) -> (T_Pattern_vOut31 ) data T_Pattern_vIn31 = T_Pattern_vIn31 !([(Identifier, Identifier)]) !(ConstructorIdent) !(Set (Identifier, Identifier)) !(AttrMap) !(NontermIdent) data T_Pattern_vOut31 = T_Pattern_vOut31 !(AttrMap) !(Set (Identifier, Identifier)) !(Seq Error) !(Pattern) type T_Pattern_v41 = (T_Pattern_vIn41 ) -> (T_Pattern_vOut41 ) data T_Pattern_vIn41 = T_Pattern_vIn41 !(ConstructorIdent) !(NontermIdent) data T_Pattern_vOut41 = T_Pattern_vOut41 !(AttrMap) !(Set (Identifier, Identifier)) !(T_Pattern_s51 ) type T_Pattern_v42 = (T_Pattern_vIn42 ) -> (T_Pattern_vOut42 ) data T_Pattern_vIn42 = T_Pattern_vIn42 !([(Identifier, Identifier)]) !(Set (Identifier, Identifier)) !(AttrMap) data T_Pattern_vOut42 = T_Pattern_vOut42 !(Seq Error) !(Pattern) type T_Pattern_v46 = (T_Pattern_vIn46 ) -> (T_Pattern_vOut46 ) data T_Pattern_vIn46 = T_Pattern_vIn46 data T_Pattern_vOut46 = T_Pattern_vOut46 !(Set (Identifier, Identifier)) !(T_Pattern_s54 ) type T_Pattern_v48 = (T_Pattern_vIn48 ) -> (T_Pattern_vOut48 ) data T_Pattern_vIn48 = T_Pattern_vIn48 !([(Identifier, Identifier)]) !(ConstructorIdent) !(Set (Identifier, Identifier)) !(AttrMap) !(NontermIdent) data T_Pattern_vOut48 = T_Pattern_vOut48 !(AttrMap) !(Seq Error) !(Pattern) type T_Pattern_v55 = (T_Pattern_vIn55 ) -> (T_Pattern_vOut55 ) data T_Pattern_vIn55 = T_Pattern_vIn55 !(ConstructorIdent) !(NontermIdent) data T_Pattern_vOut55 = T_Pattern_vOut55 !(AttrMap) !(T_Pattern_s58 ) type T_Pattern_v56 = (T_Pattern_vIn56 ) -> (T_Pattern_vOut56 ) data T_Pattern_vIn56 = T_Pattern_vIn56 data T_Pattern_vOut56 = T_Pattern_vOut56 !(Set (Identifier, Identifier)) !(T_Pattern_s51 ) {-# NOINLINE sem_Pattern_Constr #-} sem_Pattern_Constr :: (ConstructorIdent) -> T_Patterns -> T_Pattern sem_Pattern_Constr !arg_name_ arg_pats_ = T_Pattern (return st18) where {-# NOINLINE st18 #-} !st18 = let k18 :: K_Pattern_s18 t -> t k18 K_Pattern_v9 = v9 k18 K_Pattern_v27 = v27 k18 K_Pattern_v31 = v31 k18 K_Pattern_v41 = v41 k18 K_Pattern_v46 = v46 k18 K_Pattern_v55 = v55 v9 :: T_Pattern_v9 v9 = \ !(T_Pattern_vIn9 _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt) -> ( let !_patsX20 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) in let !_patsOcon = rule145 _lhsIcon in let !_patsOnt = rule148 _lhsInt in let !_patsOchildInhs = rule143 _lhsIchildInhs in let !_patsOdefs = rule146 _lhsIdefs in let !_patsOforcedIrrefutables = rule147 _lhsIforcedIrrefutables in let !(T_Patterns_vOut26 _patsIallAttributes _patsIcopy _patsIdefsCollect _patsIerrors _patsIoutput) = inv_Patterns_s20 _patsX20 K_Patterns_v26 (T_Patterns_vIn26 _patsOchildInhs _patsOcon _patsOdefs _patsOforcedIrrefutables _patsOnt) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule136 _patsIallAttributes in let !_copy = rule139 _patsIcopy arg_name_ in let _lhsOcopy :: Pattern !_lhsOcopy = rule141 _copy in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule137 _patsIdefsCollect in let _lhsOerrors :: Seq Error !_lhsOerrors = rule138 _patsIerrors in let !_output = rule140 _patsIoutput arg_name_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule142 _output in let !__result_ = T_Pattern_vOut9 _lhsOallAttributes _lhsOcopy _lhsOdefsCollect _lhsOerrors _lhsOoutput in __result_ ) v27 :: T_Pattern_v27 v27 = \ !(T_Pattern_vIn27 _lhsIchildInhs _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt) -> ( let !_patsX20 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) in let !_patsOcon = rule145 _lhsIcon in let !_patsOnt = rule148 _lhsInt in let !_patsOchildInhs = rule143 _lhsIchildInhs in let !_patsOdefs = rule146 _lhsIdefs in let !_patsOforcedIrrefutables = rule147 _lhsIforcedIrrefutables in let !(T_Patterns_vOut26 _patsIallAttributes _patsIcopy _patsIdefsCollect _patsIerrors _patsIoutput) = inv_Patterns_s20 _patsX20 K_Patterns_v26 (T_Patterns_vIn26 _patsOchildInhs _patsOcon _patsOdefs _patsOforcedIrrefutables _patsOnt) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule136 _patsIallAttributes in let !_copy = rule139 _patsIcopy arg_name_ in let _lhsOcopy :: Pattern !_lhsOcopy = rule141 _copy in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule137 _patsIdefsCollect in let _lhsOerrors :: Seq Error !_lhsOerrors = rule138 _patsIerrors in let !_output = rule140 _patsIoutput arg_name_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule142 _output in let !__result_ = T_Pattern_vOut27 _lhsOallAttributes _lhsOcopy _lhsOdefsCollect _lhsOerrors _lhsOoutput in __result_ ) v31 :: T_Pattern_v31 v31 = \ !(T_Pattern_vIn31 _lhsIchildInhs _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt) -> ( let !_patsX20 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) in let !_patsOcon = rule145 _lhsIcon in let !_patsOnt = rule148 _lhsInt in let !_patsOchildInhs = rule143 _lhsIchildInhs in let !_patsOdefs = rule146 _lhsIdefs in let !_patsOforcedIrrefutables = rule147 _lhsIforcedIrrefutables in let !(T_Patterns_vOut38 _patsIallAttributes _patsIdefsCollect _patsIerrors _patsIoutput) = inv_Patterns_s20 _patsX20 K_Patterns_v38 (T_Patterns_vIn38 _patsOchildInhs _patsOcon _patsOdefs _patsOforcedIrrefutables _patsOnt) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule136 _patsIallAttributes in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule137 _patsIdefsCollect in let _lhsOerrors :: Seq Error !_lhsOerrors = rule138 _patsIerrors in let !_output = rule140 _patsIoutput arg_name_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule142 _output in let !__result_ = T_Pattern_vOut31 _lhsOallAttributes _lhsOdefsCollect _lhsOerrors _lhsOoutput in __result_ ) v41 :: T_Pattern_v41 v41 = \ !(T_Pattern_vIn41 _lhsIcon _lhsInt) -> ( let !_patsX20 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) in let !_patsOcon = rule145 _lhsIcon in let !_patsOnt = rule148 _lhsInt in let !(T_Patterns_vOut45 _patsIallAttributes _patsIdefsCollect _patsX53) = inv_Patterns_s20 _patsX20 K_Patterns_v45 (T_Patterns_vIn45 _patsOcon _patsOnt) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule136 _patsIallAttributes in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule137 _patsIdefsCollect in let !__st_ = st51 _patsX53 !__result_ = T_Pattern_vOut41 _lhsOallAttributes _lhsOdefsCollect __st_ in __result_ ) v46 :: T_Pattern_v46 v46 = \ !(T_Pattern_vIn46 ) -> ( let !_patsX20 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) in let !(T_Patterns_vOut51 _patsIdefsCollect _patsX56) = inv_Patterns_s20 _patsX20 K_Patterns_v51 (T_Patterns_vIn51 ) in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule137 _patsIdefsCollect in let !__st_ = st54 _patsX56 !__result_ = T_Pattern_vOut46 _lhsOdefsCollect __st_ in __result_ ) v55 :: T_Pattern_v55 v55 = \ !(T_Pattern_vIn55 _lhsIcon _lhsInt) -> ( let !_patsX20 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) in let !_patsOcon = rule145 _lhsIcon in let !_patsOnt = rule148 _lhsInt in let !(T_Patterns_vOut57 _patsIallAttributes _patsX59) = inv_Patterns_s20 _patsX20 K_Patterns_v57 (T_Patterns_vIn57 _patsOcon _patsOnt) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule136 _patsIallAttributes in let !__st_ = st58 _patsX59 !__result_ = T_Pattern_vOut55 _lhsOallAttributes __st_ in __result_ ) in C_Pattern_s18 k18 {-# NOINLINE st51 #-} st51 = \ !_patsX53 -> let v42 :: T_Pattern_v42 v42 = \ !(T_Pattern_vIn42 _lhsIchildInhs _lhsIdefs _lhsIforcedIrrefutables) -> ( let !_patsOchildInhs = rule143 _lhsIchildInhs in let !_patsOdefs = rule146 _lhsIdefs in let !_patsOforcedIrrefutables = rule147 _lhsIforcedIrrefutables in let !(T_Patterns_vOut47 _patsIerrors _patsIoutput) = inv_Patterns_s53 _patsX53 (T_Patterns_vIn47 _patsOchildInhs _patsOdefs _patsOforcedIrrefutables) in let _lhsOerrors :: Seq Error !_lhsOerrors = rule138 _patsIerrors in let !_output = rule140 _patsIoutput arg_name_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule142 _output in let !__result_ = T_Pattern_vOut42 _lhsOerrors _lhsOoutput in __result_ ) in C_Pattern_s51 v42 {-# NOINLINE st54 #-} st54 = \ !_patsX56 -> let v48 :: T_Pattern_v48 v48 = \ !(T_Pattern_vIn48 _lhsIchildInhs _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt) -> ( let !_patsOcon = rule145 _lhsIcon in let !_patsOnt = rule148 _lhsInt in let !_patsOchildInhs = rule143 _lhsIchildInhs in let !_patsOdefs = rule146 _lhsIdefs in let !_patsOforcedIrrefutables = rule147 _lhsIforcedIrrefutables in let !(T_Patterns_vOut52 _patsIallAttributes _patsIerrors _patsIoutput) = inv_Patterns_s56 _patsX56 (T_Patterns_vIn52 _patsOchildInhs _patsOcon _patsOdefs _patsOforcedIrrefutables _patsOnt) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule136 _patsIallAttributes in let _lhsOerrors :: Seq Error !_lhsOerrors = rule138 _patsIerrors in let !_output = rule140 _patsIoutput arg_name_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule142 _output in let !__result_ = T_Pattern_vOut48 _lhsOallAttributes _lhsOerrors _lhsOoutput in __result_ ) in C_Pattern_s54 v48 {-# NOINLINE st58 #-} st58 = \ !_patsX59 -> let v56 :: T_Pattern_v56 v56 = \ !(T_Pattern_vIn56 ) -> ( let !(T_Patterns_vOut58 _patsIdefsCollect _patsX53) = inv_Patterns_s59 _patsX59 (T_Patterns_vIn58 ) in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule137 _patsIdefsCollect in let !__st_ = st51 _patsX53 !__result_ = T_Pattern_vOut56 _lhsOdefsCollect __st_ in __result_ ) in C_Pattern_s58 v56 {-# NOINLINE[1] rule136 #-} rule136 = \ ((!_patsIallAttributes) :: AttrMap) -> _patsIallAttributes {-# NOINLINE[1] rule137 #-} rule137 = \ ((!_patsIdefsCollect) :: Set (Identifier, Identifier)) -> _patsIdefsCollect {-# NOINLINE[1] rule138 #-} rule138 = \ ((!_patsIerrors) :: Seq Error) -> _patsIerrors {-# NOINLINE[1] rule139 #-} rule139 = \ ((!_patsIcopy) :: Patterns) !name_ -> Constr name_ _patsIcopy {-# NOINLINE[1] rule140 #-} rule140 = \ ((!_patsIoutput) :: Patterns) !name_ -> Constr name_ _patsIoutput {-# NOINLINE[1] rule141 #-} rule141 = \ !_copy -> _copy {-# NOINLINE[1] rule142 #-} rule142 = \ !_output -> _output {-# NOINLINE[1] rule143 #-} rule143 = \ ((!_lhsIchildInhs) :: [(Identifier, Identifier)]) -> _lhsIchildInhs {-# NOINLINE[1] rule145 #-} rule145 = \ ((!_lhsIcon) :: ConstructorIdent) -> _lhsIcon {-# NOINLINE[1] rule146 #-} rule146 = \ ((!_lhsIdefs) :: Set (Identifier, Identifier)) -> _lhsIdefs {-# NOINLINE[1] rule147 #-} rule147 = \ ((!_lhsIforcedIrrefutables) :: AttrMap) -> _lhsIforcedIrrefutables {-# NOINLINE[1] rule148 #-} rule148 = \ ((!_lhsInt) :: NontermIdent) -> _lhsInt {-# NOINLINE sem_Pattern_Product #-} sem_Pattern_Product :: (Pos) -> T_Patterns -> T_Pattern sem_Pattern_Product !arg_pos_ arg_pats_ = T_Pattern (return st18) where {-# NOINLINE st18 #-} !st18 = let k18 :: K_Pattern_s18 t -> t k18 K_Pattern_v9 = v9 k18 K_Pattern_v27 = v27 k18 K_Pattern_v31 = v31 k18 K_Pattern_v41 = v41 k18 K_Pattern_v46 = v46 k18 K_Pattern_v55 = v55 v9 :: T_Pattern_v9 v9 = \ !(T_Pattern_vIn9 _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt) -> ( let !_patsX20 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) in let !_patsOcon = rule158 _lhsIcon in let !_patsOnt = rule161 _lhsInt in let !_patsOchildInhs = rule156 _lhsIchildInhs in let !_patsOdefs = rule159 _lhsIdefs in let !_patsOforcedIrrefutables = rule160 _lhsIforcedIrrefutables in let !(T_Patterns_vOut26 _patsIallAttributes _patsIcopy _patsIdefsCollect _patsIerrors _patsIoutput) = inv_Patterns_s20 _patsX20 K_Patterns_v26 (T_Patterns_vIn26 _patsOchildInhs _patsOcon _patsOdefs _patsOforcedIrrefutables _patsOnt) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule149 _patsIallAttributes in let !_copy = rule152 _patsIcopy arg_pos_ in let _lhsOcopy :: Pattern !_lhsOcopy = rule154 _copy in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule150 _patsIdefsCollect in let _lhsOerrors :: Seq Error !_lhsOerrors = rule151 _patsIerrors in let !_output = rule153 _patsIoutput arg_pos_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule155 _output in let !__result_ = T_Pattern_vOut9 _lhsOallAttributes _lhsOcopy _lhsOdefsCollect _lhsOerrors _lhsOoutput in __result_ ) v27 :: T_Pattern_v27 v27 = \ !(T_Pattern_vIn27 _lhsIchildInhs _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt) -> ( let !_patsX20 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) in let !_patsOcon = rule158 _lhsIcon in let !_patsOnt = rule161 _lhsInt in let !_patsOchildInhs = rule156 _lhsIchildInhs in let !_patsOdefs = rule159 _lhsIdefs in let !_patsOforcedIrrefutables = rule160 _lhsIforcedIrrefutables in let !(T_Patterns_vOut26 _patsIallAttributes _patsIcopy _patsIdefsCollect _patsIerrors _patsIoutput) = inv_Patterns_s20 _patsX20 K_Patterns_v26 (T_Patterns_vIn26 _patsOchildInhs _patsOcon _patsOdefs _patsOforcedIrrefutables _patsOnt) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule149 _patsIallAttributes in let !_copy = rule152 _patsIcopy arg_pos_ in let _lhsOcopy :: Pattern !_lhsOcopy = rule154 _copy in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule150 _patsIdefsCollect in let _lhsOerrors :: Seq Error !_lhsOerrors = rule151 _patsIerrors in let !_output = rule153 _patsIoutput arg_pos_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule155 _output in let !__result_ = T_Pattern_vOut27 _lhsOallAttributes _lhsOcopy _lhsOdefsCollect _lhsOerrors _lhsOoutput in __result_ ) v31 :: T_Pattern_v31 v31 = \ !(T_Pattern_vIn31 _lhsIchildInhs _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt) -> ( let !_patsX20 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) in let !_patsOcon = rule158 _lhsIcon in let !_patsOnt = rule161 _lhsInt in let !_patsOchildInhs = rule156 _lhsIchildInhs in let !_patsOdefs = rule159 _lhsIdefs in let !_patsOforcedIrrefutables = rule160 _lhsIforcedIrrefutables in let !(T_Patterns_vOut38 _patsIallAttributes _patsIdefsCollect _patsIerrors _patsIoutput) = inv_Patterns_s20 _patsX20 K_Patterns_v38 (T_Patterns_vIn38 _patsOchildInhs _patsOcon _patsOdefs _patsOforcedIrrefutables _patsOnt) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule149 _patsIallAttributes in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule150 _patsIdefsCollect in let _lhsOerrors :: Seq Error !_lhsOerrors = rule151 _patsIerrors in let !_output = rule153 _patsIoutput arg_pos_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule155 _output in let !__result_ = T_Pattern_vOut31 _lhsOallAttributes _lhsOdefsCollect _lhsOerrors _lhsOoutput in __result_ ) v41 :: T_Pattern_v41 v41 = \ !(T_Pattern_vIn41 _lhsIcon _lhsInt) -> ( let !_patsX20 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) in let !_patsOcon = rule158 _lhsIcon in let !_patsOnt = rule161 _lhsInt in let !(T_Patterns_vOut45 _patsIallAttributes _patsIdefsCollect _patsX53) = inv_Patterns_s20 _patsX20 K_Patterns_v45 (T_Patterns_vIn45 _patsOcon _patsOnt) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule149 _patsIallAttributes in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule150 _patsIdefsCollect in let !__st_ = st51 _patsX53 !__result_ = T_Pattern_vOut41 _lhsOallAttributes _lhsOdefsCollect __st_ in __result_ ) v46 :: T_Pattern_v46 v46 = \ !(T_Pattern_vIn46 ) -> ( let !_patsX20 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) in let !(T_Patterns_vOut51 _patsIdefsCollect _patsX56) = inv_Patterns_s20 _patsX20 K_Patterns_v51 (T_Patterns_vIn51 ) in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule150 _patsIdefsCollect in let !__st_ = st54 _patsX56 !__result_ = T_Pattern_vOut46 _lhsOdefsCollect __st_ in __result_ ) v55 :: T_Pattern_v55 v55 = \ !(T_Pattern_vIn55 _lhsIcon _lhsInt) -> ( let !_patsX20 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) in let !_patsOcon = rule158 _lhsIcon in let !_patsOnt = rule161 _lhsInt in let !(T_Patterns_vOut57 _patsIallAttributes _patsX59) = inv_Patterns_s20 _patsX20 K_Patterns_v57 (T_Patterns_vIn57 _patsOcon _patsOnt) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule149 _patsIallAttributes in let !__st_ = st58 _patsX59 !__result_ = T_Pattern_vOut55 _lhsOallAttributes __st_ in __result_ ) in C_Pattern_s18 k18 {-# NOINLINE st51 #-} st51 = \ !_patsX53 -> let v42 :: T_Pattern_v42 v42 = \ !(T_Pattern_vIn42 _lhsIchildInhs _lhsIdefs _lhsIforcedIrrefutables) -> ( let !_patsOchildInhs = rule156 _lhsIchildInhs in let !_patsOdefs = rule159 _lhsIdefs in let !_patsOforcedIrrefutables = rule160 _lhsIforcedIrrefutables in let !(T_Patterns_vOut47 _patsIerrors _patsIoutput) = inv_Patterns_s53 _patsX53 (T_Patterns_vIn47 _patsOchildInhs _patsOdefs _patsOforcedIrrefutables) in let _lhsOerrors :: Seq Error !_lhsOerrors = rule151 _patsIerrors in let !_output = rule153 _patsIoutput arg_pos_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule155 _output in let !__result_ = T_Pattern_vOut42 _lhsOerrors _lhsOoutput in __result_ ) in C_Pattern_s51 v42 {-# NOINLINE st54 #-} st54 = \ !_patsX56 -> let v48 :: T_Pattern_v48 v48 = \ !(T_Pattern_vIn48 _lhsIchildInhs _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt) -> ( let !_patsOcon = rule158 _lhsIcon in let !_patsOnt = rule161 _lhsInt in let !_patsOchildInhs = rule156 _lhsIchildInhs in let !_patsOdefs = rule159 _lhsIdefs in let !_patsOforcedIrrefutables = rule160 _lhsIforcedIrrefutables in let !(T_Patterns_vOut52 _patsIallAttributes _patsIerrors _patsIoutput) = inv_Patterns_s56 _patsX56 (T_Patterns_vIn52 _patsOchildInhs _patsOcon _patsOdefs _patsOforcedIrrefutables _patsOnt) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule149 _patsIallAttributes in let _lhsOerrors :: Seq Error !_lhsOerrors = rule151 _patsIerrors in let !_output = rule153 _patsIoutput arg_pos_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule155 _output in let !__result_ = T_Pattern_vOut48 _lhsOallAttributes _lhsOerrors _lhsOoutput in __result_ ) in C_Pattern_s54 v48 {-# NOINLINE st58 #-} st58 = \ !_patsX59 -> let v56 :: T_Pattern_v56 v56 = \ !(T_Pattern_vIn56 ) -> ( let !(T_Patterns_vOut58 _patsIdefsCollect _patsX53) = inv_Patterns_s59 _patsX59 (T_Patterns_vIn58 ) in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule150 _patsIdefsCollect in let !__st_ = st51 _patsX53 !__result_ = T_Pattern_vOut56 _lhsOdefsCollect __st_ in __result_ ) in C_Pattern_s58 v56 {-# NOINLINE[1] rule149 #-} rule149 = \ ((!_patsIallAttributes) :: AttrMap) -> _patsIallAttributes {-# NOINLINE[1] rule150 #-} rule150 = \ ((!_patsIdefsCollect) :: Set (Identifier, Identifier)) -> _patsIdefsCollect {-# NOINLINE[1] rule151 #-} rule151 = \ ((!_patsIerrors) :: Seq Error) -> _patsIerrors {-# NOINLINE[1] rule152 #-} rule152 = \ ((!_patsIcopy) :: Patterns) !pos_ -> Product pos_ _patsIcopy {-# NOINLINE[1] rule153 #-} rule153 = \ ((!_patsIoutput) :: Patterns) !pos_ -> Product pos_ _patsIoutput {-# NOINLINE[1] rule154 #-} rule154 = \ !_copy -> _copy {-# NOINLINE[1] rule155 #-} rule155 = \ !_output -> _output {-# NOINLINE[1] rule156 #-} rule156 = \ ((!_lhsIchildInhs) :: [(Identifier, Identifier)]) -> _lhsIchildInhs {-# NOINLINE[1] rule158 #-} rule158 = \ ((!_lhsIcon) :: ConstructorIdent) -> _lhsIcon {-# NOINLINE[1] rule159 #-} rule159 = \ ((!_lhsIdefs) :: Set (Identifier, Identifier)) -> _lhsIdefs {-# NOINLINE[1] rule160 #-} rule160 = \ ((!_lhsIforcedIrrefutables) :: AttrMap) -> _lhsIforcedIrrefutables {-# NOINLINE[1] rule161 #-} rule161 = \ ((!_lhsInt) :: NontermIdent) -> _lhsInt {-# NOINLINE sem_Pattern_Alias #-} sem_Pattern_Alias :: (Identifier) -> (Identifier) -> T_Pattern -> T_Pattern sem_Pattern_Alias !arg_field_ !arg_attr_ arg_pat_ = T_Pattern (return st18) where {-# NOINLINE st18 #-} !st18 = let k18 :: K_Pattern_s18 t -> t k18 K_Pattern_v9 = v9 k18 K_Pattern_v27 = v27 k18 K_Pattern_v31 = v31 k18 K_Pattern_v41 = v41 k18 K_Pattern_v46 = v46 k18 K_Pattern_v55 = v55 v9 :: T_Pattern_v9 v9 = \ !(T_Pattern_vIn9 _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt) -> ( let !_patX18 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) in let !_patOcon = rule174 _lhsIcon in let !_patOnt = rule177 _lhsInt in let !_def = rule166 arg_attr_ arg_field_ in let !_patOchildInhs = rule172 _lhsIchildInhs in let !_patOdefs = rule175 _lhsIdefs in let !(!_field',!_err1) = rule162 _lhsIchildInhs _lhsIcon _lhsInt arg_attr_ arg_field_ in let !_err2 = rule163 _field' _lhsIcon _lhsIdefs _lhsInt arg_attr_ arg_field_ in let !_patOforcedIrrefutables = rule176 _lhsIforcedIrrefutables in let !(T_Pattern_vOut27 _patIallAttributes _patIcopy _patIdefsCollect _patIerrors _patIoutput) = inv_Pattern_s18 _patX18 K_Pattern_v27 (T_Pattern_vIn27 _patOchildInhs _patOcon _patOdefs _patOforcedIrrefutables _patOnt) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule168 _lhsIcon _lhsInt _patIallAttributes arg_attr_ arg_field_ in let !_copy = rule170 _patIcopy arg_attr_ arg_field_ in let _lhsOcopy :: Pattern !_lhsOcopy = rule171 _copy in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule167 _def _patIdefsCollect in let _lhsOerrors :: Seq Error !_lhsOerrors = rule164 _err1 _err2 _patIerrors in let !_output = rule165 _field' _patIoutput arg_attr_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule169 _lhsIcon _lhsIforcedIrrefutables _lhsInt _output arg_attr_ arg_field_ in let !__result_ = T_Pattern_vOut9 _lhsOallAttributes _lhsOcopy _lhsOdefsCollect _lhsOerrors _lhsOoutput in __result_ ) v27 :: T_Pattern_v27 v27 = \ !(T_Pattern_vIn27 _lhsIchildInhs _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt) -> ( let !_patX18 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) in let !_patOcon = rule174 _lhsIcon in let !_patOnt = rule177 _lhsInt in let !_def = rule166 arg_attr_ arg_field_ in let !_patOchildInhs = rule172 _lhsIchildInhs in let !_patOdefs = rule175 _lhsIdefs in let !(!_field',!_err1) = rule162 _lhsIchildInhs _lhsIcon _lhsInt arg_attr_ arg_field_ in let !_err2 = rule163 _field' _lhsIcon _lhsIdefs _lhsInt arg_attr_ arg_field_ in let !_patOforcedIrrefutables = rule176 _lhsIforcedIrrefutables in let !(T_Pattern_vOut27 _patIallAttributes _patIcopy _patIdefsCollect _patIerrors _patIoutput) = inv_Pattern_s18 _patX18 K_Pattern_v27 (T_Pattern_vIn27 _patOchildInhs _patOcon _patOdefs _patOforcedIrrefutables _patOnt) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule168 _lhsIcon _lhsInt _patIallAttributes arg_attr_ arg_field_ in let !_copy = rule170 _patIcopy arg_attr_ arg_field_ in let _lhsOcopy :: Pattern !_lhsOcopy = rule171 _copy in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule167 _def _patIdefsCollect in let _lhsOerrors :: Seq Error !_lhsOerrors = rule164 _err1 _err2 _patIerrors in let !_output = rule165 _field' _patIoutput arg_attr_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule169 _lhsIcon _lhsIforcedIrrefutables _lhsInt _output arg_attr_ arg_field_ in let !__result_ = T_Pattern_vOut27 _lhsOallAttributes _lhsOcopy _lhsOdefsCollect _lhsOerrors _lhsOoutput in __result_ ) v31 :: T_Pattern_v31 v31 = \ !(T_Pattern_vIn31 _lhsIchildInhs _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt) -> ( let !_patX18 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) in let !_patOcon = rule174 _lhsIcon in let !_patOnt = rule177 _lhsInt in let !_def = rule166 arg_attr_ arg_field_ in let !_patOchildInhs = rule172 _lhsIchildInhs in let !_patOdefs = rule175 _lhsIdefs in let !(!_field',!_err1) = rule162 _lhsIchildInhs _lhsIcon _lhsInt arg_attr_ arg_field_ in let !_err2 = rule163 _field' _lhsIcon _lhsIdefs _lhsInt arg_attr_ arg_field_ in let !_patOforcedIrrefutables = rule176 _lhsIforcedIrrefutables in let !(T_Pattern_vOut31 _patIallAttributes _patIdefsCollect _patIerrors _patIoutput) = inv_Pattern_s18 _patX18 K_Pattern_v31 (T_Pattern_vIn31 _patOchildInhs _patOcon _patOdefs _patOforcedIrrefutables _patOnt) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule168 _lhsIcon _lhsInt _patIallAttributes arg_attr_ arg_field_ in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule167 _def _patIdefsCollect in let _lhsOerrors :: Seq Error !_lhsOerrors = rule164 _err1 _err2 _patIerrors in let !_output = rule165 _field' _patIoutput arg_attr_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule169 _lhsIcon _lhsIforcedIrrefutables _lhsInt _output arg_attr_ arg_field_ in let !__result_ = T_Pattern_vOut31 _lhsOallAttributes _lhsOdefsCollect _lhsOerrors _lhsOoutput in __result_ ) v41 :: T_Pattern_v41 v41 = \ !(T_Pattern_vIn41 _lhsIcon _lhsInt) -> ( let !_patX18 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) in let !_patOcon = rule174 _lhsIcon in let !_patOnt = rule177 _lhsInt in let !_def = rule166 arg_attr_ arg_field_ in let !(T_Pattern_vOut41 _patIallAttributes _patIdefsCollect _patX51) = inv_Pattern_s18 _patX18 K_Pattern_v41 (T_Pattern_vIn41 _patOcon _patOnt) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule168 _lhsIcon _lhsInt _patIallAttributes arg_attr_ arg_field_ in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule167 _def _patIdefsCollect in let !__st_ = st51 _lhsIcon _lhsInt _patX51 !__result_ = T_Pattern_vOut41 _lhsOallAttributes _lhsOdefsCollect __st_ in __result_ ) v46 :: T_Pattern_v46 v46 = \ !(T_Pattern_vIn46 ) -> ( let !_patX18 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) in let !_def = rule166 arg_attr_ arg_field_ in let !(T_Pattern_vOut46 _patIdefsCollect _patX54) = inv_Pattern_s18 _patX18 K_Pattern_v46 (T_Pattern_vIn46 ) in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule167 _def _patIdefsCollect in let !__st_ = st54 _patX54 !__result_ = T_Pattern_vOut46 _lhsOdefsCollect __st_ in __result_ ) v55 :: T_Pattern_v55 v55 = \ !(T_Pattern_vIn55 _lhsIcon _lhsInt) -> ( let !_patX18 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) in let !_patOcon = rule174 _lhsIcon in let !_patOnt = rule177 _lhsInt in let !(T_Pattern_vOut55 _patIallAttributes _patX58) = inv_Pattern_s18 _patX18 K_Pattern_v55 (T_Pattern_vIn55 _patOcon _patOnt) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule168 _lhsIcon _lhsInt _patIallAttributes arg_attr_ arg_field_ in let !__st_ = st58 _lhsIcon _lhsInt _patX58 !__result_ = T_Pattern_vOut55 _lhsOallAttributes __st_ in __result_ ) in C_Pattern_s18 k18 {-# NOINLINE st51 #-} st51 = \ ((!_lhsIcon) :: ConstructorIdent) ((!_lhsInt) :: NontermIdent) !_patX51 -> let v42 :: T_Pattern_v42 v42 = \ !(T_Pattern_vIn42 _lhsIchildInhs _lhsIdefs _lhsIforcedIrrefutables) -> ( let !_patOchildInhs = rule172 _lhsIchildInhs in let !_patOdefs = rule175 _lhsIdefs in let !(!_field',!_err1) = rule162 _lhsIchildInhs _lhsIcon _lhsInt arg_attr_ arg_field_ in let !_err2 = rule163 _field' _lhsIcon _lhsIdefs _lhsInt arg_attr_ arg_field_ in let !_patOforcedIrrefutables = rule176 _lhsIforcedIrrefutables in let !(T_Pattern_vOut42 _patIerrors _patIoutput) = inv_Pattern_s51 _patX51 (T_Pattern_vIn42 _patOchildInhs _patOdefs _patOforcedIrrefutables) in let _lhsOerrors :: Seq Error !_lhsOerrors = rule164 _err1 _err2 _patIerrors in let !_output = rule165 _field' _patIoutput arg_attr_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule169 _lhsIcon _lhsIforcedIrrefutables _lhsInt _output arg_attr_ arg_field_ in let !__result_ = T_Pattern_vOut42 _lhsOerrors _lhsOoutput in __result_ ) in C_Pattern_s51 v42 {-# NOINLINE st54 #-} st54 = \ !_patX54 -> let v48 :: T_Pattern_v48 v48 = \ !(T_Pattern_vIn48 _lhsIchildInhs _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt) -> ( let !_patOcon = rule174 _lhsIcon in let !_patOnt = rule177 _lhsInt in let !_patOchildInhs = rule172 _lhsIchildInhs in let !_patOdefs = rule175 _lhsIdefs in let !(!_field',!_err1) = rule162 _lhsIchildInhs _lhsIcon _lhsInt arg_attr_ arg_field_ in let !_err2 = rule163 _field' _lhsIcon _lhsIdefs _lhsInt arg_attr_ arg_field_ in let !_patOforcedIrrefutables = rule176 _lhsIforcedIrrefutables in let !(T_Pattern_vOut48 _patIallAttributes _patIerrors _patIoutput) = inv_Pattern_s54 _patX54 (T_Pattern_vIn48 _patOchildInhs _patOcon _patOdefs _patOforcedIrrefutables _patOnt) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule168 _lhsIcon _lhsInt _patIallAttributes arg_attr_ arg_field_ in let _lhsOerrors :: Seq Error !_lhsOerrors = rule164 _err1 _err2 _patIerrors in let !_output = rule165 _field' _patIoutput arg_attr_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule169 _lhsIcon _lhsIforcedIrrefutables _lhsInt _output arg_attr_ arg_field_ in let !__result_ = T_Pattern_vOut48 _lhsOallAttributes _lhsOerrors _lhsOoutput in __result_ ) in C_Pattern_s54 v48 {-# NOINLINE st58 #-} st58 = \ ((!_lhsIcon) :: ConstructorIdent) ((!_lhsInt) :: NontermIdent) !_patX58 -> let v56 :: T_Pattern_v56 v56 = \ !(T_Pattern_vIn56 ) -> ( let !_def = rule166 arg_attr_ arg_field_ in let !(T_Pattern_vOut56 _patIdefsCollect _patX51) = inv_Pattern_s58 _patX58 (T_Pattern_vIn56 ) in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule167 _def _patIdefsCollect in let !__st_ = st51 _lhsIcon _lhsInt _patX51 !__result_ = T_Pattern_vOut56 _lhsOdefsCollect __st_ in __result_ ) in C_Pattern_s58 v56 {-# NOINLINE rule162 #-} {-# LINE 110 "./src-ag/Desugar.ag" #-} rule162 = \ ((!_lhsIchildInhs) :: [(Identifier, Identifier)]) ((!_lhsIcon) :: ConstructorIdent) ((!_lhsInt) :: NontermIdent) !attr_ !field_ -> {-# LINE 110 "./src-ag/Desugar.ag" #-} maybeError field_ (UndefAttr _lhsInt _lhsIcon (Ident "" (getPos field_)) attr_ True) $ findField field_ attr_ _lhsIchildInhs {-# LINE 2470 "dist/build/Desugar.hs"#-} {-# NOINLINE rule163 #-} {-# LINE 112 "./src-ag/Desugar.ag" #-} rule163 = \ !_field' ((!_lhsIcon) :: ConstructorIdent) ((!_lhsIdefs) :: Set (Identifier, Identifier)) ((!_lhsInt) :: NontermIdent) !attr_ !field_ -> {-# LINE 112 "./src-ag/Desugar.ag" #-} if _field' == field_ then Seq.empty else if (_field' , attr_) `Set.member` _lhsIdefs then Seq.singleton $ DupRule _lhsInt _lhsIcon field_ attr_ _field' else Seq.empty {-# LINE 2480 "dist/build/Desugar.hs"#-} {-# NOINLINE rule164 #-} {-# LINE 117 "./src-ag/Desugar.ag" #-} rule164 = \ !_err1 !_err2 ((!_patIerrors) :: Seq Error) -> {-# LINE 117 "./src-ag/Desugar.ag" #-} _err1 Seq.>< _err2 Seq.>< _patIerrors {-# LINE 2486 "dist/build/Desugar.hs"#-} {-# NOINLINE rule165 #-} {-# LINE 118 "./src-ag/Desugar.ag" #-} rule165 = \ !_field' ((!_patIoutput) :: Pattern) !attr_ -> {-# LINE 118 "./src-ag/Desugar.ag" #-} Alias _field' attr_ _patIoutput {-# LINE 2492 "dist/build/Desugar.hs"#-} {-# NOINLINE rule166 #-} {-# LINE 182 "./src-ag/Desugar.ag" #-} rule166 = \ !attr_ !field_ -> {-# LINE 182 "./src-ag/Desugar.ag" #-} Set.singleton (field_, attr_) {-# LINE 2498 "dist/build/Desugar.hs"#-} {-# NOINLINE rule167 #-} {-# LINE 183 "./src-ag/Desugar.ag" #-} rule167 = \ !_def ((!_patIdefsCollect) :: Set (Identifier, Identifier)) -> {-# LINE 183 "./src-ag/Desugar.ag" #-} _def `Set.union` _patIdefsCollect {-# LINE 2504 "dist/build/Desugar.hs"#-} {-# NOINLINE rule168 #-} {-# LINE 200 "./src-ag/Desugar.ag" #-} rule168 = \ ((!_lhsIcon) :: ConstructorIdent) ((!_lhsInt) :: NontermIdent) ((!_patIallAttributes) :: AttrMap) !attr_ !field_ -> {-# LINE 200 "./src-ag/Desugar.ag" #-} (Map.singleton _lhsInt $ Map.singleton _lhsIcon $ Set.singleton (field_, attr_)) `mergeAttributes` _patIallAttributes {-# LINE 2510 "dist/build/Desugar.hs"#-} {-# NOINLINE rule169 #-} {-# LINE 219 "./src-ag/Desugar.ag" #-} rule169 = \ ((!_lhsIcon) :: ConstructorIdent) ((!_lhsIforcedIrrefutables) :: AttrMap) ((!_lhsInt) :: NontermIdent) !_output !attr_ !field_ -> {-# LINE 219 "./src-ag/Desugar.ag" #-} if Set.member (field_, attr_) $ Map.findWithDefault Set.empty _lhsIcon $ Map.findWithDefault Map.empty _lhsInt $ _lhsIforcedIrrefutables then Irrefutable _output else _output {-# LINE 2518 "dist/build/Desugar.hs"#-} {-# NOINLINE[1] rule170 #-} rule170 = \ ((!_patIcopy) :: Pattern) !attr_ !field_ -> Alias field_ attr_ _patIcopy {-# NOINLINE[1] rule171 #-} rule171 = \ !_copy -> _copy {-# NOINLINE[1] rule172 #-} rule172 = \ ((!_lhsIchildInhs) :: [(Identifier, Identifier)]) -> _lhsIchildInhs {-# NOINLINE[1] rule174 #-} rule174 = \ ((!_lhsIcon) :: ConstructorIdent) -> _lhsIcon {-# NOINLINE[1] rule175 #-} rule175 = \ ((!_lhsIdefs) :: Set (Identifier, Identifier)) -> _lhsIdefs {-# NOINLINE[1] rule176 #-} rule176 = \ ((!_lhsIforcedIrrefutables) :: AttrMap) -> _lhsIforcedIrrefutables {-# NOINLINE[1] rule177 #-} rule177 = \ ((!_lhsInt) :: NontermIdent) -> _lhsInt {-# NOINLINE sem_Pattern_Irrefutable #-} sem_Pattern_Irrefutable :: T_Pattern -> T_Pattern sem_Pattern_Irrefutable arg_pat_ = T_Pattern (return st18) where {-# NOINLINE st18 #-} !st18 = let k18 :: K_Pattern_s18 t -> t k18 K_Pattern_v9 = v9 k18 K_Pattern_v27 = v27 k18 K_Pattern_v31 = v31 k18 K_Pattern_v41 = v41 k18 K_Pattern_v46 = v46 k18 K_Pattern_v55 = v55 v9 :: T_Pattern_v9 v9 = \ !(T_Pattern_vIn9 _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt) -> ( let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule178 () in let !_patX18 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) in let !_patOchildInhs = rule185 _lhsIchildInhs in let !_patOcon = rule187 _lhsIcon in let !_patOdefs = rule188 _lhsIdefs in let !_patOnt = rule190 _lhsInt in let !_patOforcedIrrefutables = rule189 _lhsIforcedIrrefutables in let !(T_Pattern_vOut27 _patIallAttributes _patIcopy _patIdefsCollect _patIerrors _patIoutput) = inv_Pattern_s18 _patX18 K_Pattern_v27 (T_Pattern_vIn27 _patOchildInhs _patOcon _patOdefs _patOforcedIrrefutables _patOnt) in let !_copy = rule181 _patIcopy in let _lhsOcopy :: Pattern !_lhsOcopy = rule183 _copy in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule179 _patIdefsCollect in let _lhsOerrors :: Seq Error !_lhsOerrors = rule180 _patIerrors in let !_output = rule182 _patIoutput in let _lhsOoutput :: Pattern !_lhsOoutput = rule184 _output in let !__result_ = T_Pattern_vOut9 _lhsOallAttributes _lhsOcopy _lhsOdefsCollect _lhsOerrors _lhsOoutput in __result_ ) v27 :: T_Pattern_v27 v27 = \ !(T_Pattern_vIn27 _lhsIchildInhs _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt) -> ( let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule178 () in let !_patX18 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) in let !_patOchildInhs = rule185 _lhsIchildInhs in let !_patOcon = rule187 _lhsIcon in let !_patOdefs = rule188 _lhsIdefs in let !_patOnt = rule190 _lhsInt in let !_patOforcedIrrefutables = rule189 _lhsIforcedIrrefutables in let !(T_Pattern_vOut27 _patIallAttributes _patIcopy _patIdefsCollect _patIerrors _patIoutput) = inv_Pattern_s18 _patX18 K_Pattern_v27 (T_Pattern_vIn27 _patOchildInhs _patOcon _patOdefs _patOforcedIrrefutables _patOnt) in let !_copy = rule181 _patIcopy in let _lhsOcopy :: Pattern !_lhsOcopy = rule183 _copy in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule179 _patIdefsCollect in let _lhsOerrors :: Seq Error !_lhsOerrors = rule180 _patIerrors in let !_output = rule182 _patIoutput in let _lhsOoutput :: Pattern !_lhsOoutput = rule184 _output in let !__result_ = T_Pattern_vOut27 _lhsOallAttributes _lhsOcopy _lhsOdefsCollect _lhsOerrors _lhsOoutput in __result_ ) v31 :: T_Pattern_v31 v31 = \ !(T_Pattern_vIn31 _lhsIchildInhs _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt) -> ( let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule178 () in let !_patX18 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) in let !_patOchildInhs = rule185 _lhsIchildInhs in let !_patOcon = rule187 _lhsIcon in let !_patOdefs = rule188 _lhsIdefs in let !_patOnt = rule190 _lhsInt in let !_patOforcedIrrefutables = rule189 _lhsIforcedIrrefutables in let !(T_Pattern_vOut31 _patIallAttributes _patIdefsCollect _patIerrors _patIoutput) = inv_Pattern_s18 _patX18 K_Pattern_v31 (T_Pattern_vIn31 _patOchildInhs _patOcon _patOdefs _patOforcedIrrefutables _patOnt) in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule179 _patIdefsCollect in let _lhsOerrors :: Seq Error !_lhsOerrors = rule180 _patIerrors in let !_output = rule182 _patIoutput in let _lhsOoutput :: Pattern !_lhsOoutput = rule184 _output in let !__result_ = T_Pattern_vOut31 _lhsOallAttributes _lhsOdefsCollect _lhsOerrors _lhsOoutput in __result_ ) v41 :: T_Pattern_v41 v41 = \ !(T_Pattern_vIn41 _lhsIcon _lhsInt) -> ( let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule178 () in let !_patX18 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) in let !(T_Pattern_vOut46 _patIdefsCollect _patX54) = inv_Pattern_s18 _patX18 K_Pattern_v46 (T_Pattern_vIn46 ) in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule179 _patIdefsCollect in let !__st_ = st51 _lhsIcon _lhsInt _patX54 !__result_ = T_Pattern_vOut41 _lhsOallAttributes _lhsOdefsCollect __st_ in __result_ ) v46 :: T_Pattern_v46 v46 = \ !(T_Pattern_vIn46 ) -> ( let !_patX18 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) in let !(T_Pattern_vOut46 _patIdefsCollect _patX54) = inv_Pattern_s18 _patX18 K_Pattern_v46 (T_Pattern_vIn46 ) in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule179 _patIdefsCollect in let !__st_ = st54 _patX54 !__result_ = T_Pattern_vOut46 _lhsOdefsCollect __st_ in __result_ ) v55 :: T_Pattern_v55 v55 = \ !(T_Pattern_vIn55 _lhsIcon _lhsInt) -> ( let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule178 () in let !__st_ = st58 _lhsIcon _lhsInt !__result_ = T_Pattern_vOut55 _lhsOallAttributes __st_ in __result_ ) in C_Pattern_s18 k18 {-# NOINLINE st51 #-} st51 = \ ((!_lhsIcon) :: ConstructorIdent) ((!_lhsInt) :: NontermIdent) !_patX54 -> let v42 :: T_Pattern_v42 v42 = \ !(T_Pattern_vIn42 _lhsIchildInhs _lhsIdefs _lhsIforcedIrrefutables) -> ( let !_patOcon = rule187 _lhsIcon in let !_patOnt = rule190 _lhsInt in let !_patOchildInhs = rule185 _lhsIchildInhs in let !_patOdefs = rule188 _lhsIdefs in let !_patOforcedIrrefutables = rule189 _lhsIforcedIrrefutables in let !(T_Pattern_vOut48 _patIallAttributes _patIerrors _patIoutput) = inv_Pattern_s54 _patX54 (T_Pattern_vIn48 _patOchildInhs _patOcon _patOdefs _patOforcedIrrefutables _patOnt) in let _lhsOerrors :: Seq Error !_lhsOerrors = rule180 _patIerrors in let !_output = rule182 _patIoutput in let _lhsOoutput :: Pattern !_lhsOoutput = rule184 _output in let !__result_ = T_Pattern_vOut42 _lhsOerrors _lhsOoutput in __result_ ) in C_Pattern_s51 v42 {-# NOINLINE st54 #-} st54 = \ !_patX54 -> let v48 :: T_Pattern_v48 v48 = \ !(T_Pattern_vIn48 _lhsIchildInhs _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt) -> ( let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule178 () in let !_patOchildInhs = rule185 _lhsIchildInhs in let !_patOcon = rule187 _lhsIcon in let !_patOdefs = rule188 _lhsIdefs in let !_patOnt = rule190 _lhsInt in let !_patOforcedIrrefutables = rule189 _lhsIforcedIrrefutables in let !(T_Pattern_vOut48 _patIallAttributes _patIerrors _patIoutput) = inv_Pattern_s54 _patX54 (T_Pattern_vIn48 _patOchildInhs _patOcon _patOdefs _patOforcedIrrefutables _patOnt) in let _lhsOerrors :: Seq Error !_lhsOerrors = rule180 _patIerrors in let !_output = rule182 _patIoutput in let _lhsOoutput :: Pattern !_lhsOoutput = rule184 _output in let !__result_ = T_Pattern_vOut48 _lhsOallAttributes _lhsOerrors _lhsOoutput in __result_ ) in C_Pattern_s54 v48 {-# NOINLINE st58 #-} st58 = \ ((!_lhsIcon) :: ConstructorIdent) ((!_lhsInt) :: NontermIdent) -> let v56 :: T_Pattern_v56 v56 = \ !(T_Pattern_vIn56 ) -> ( let !_patX18 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) in let !(T_Pattern_vOut46 _patIdefsCollect _patX54) = inv_Pattern_s18 _patX18 K_Pattern_v46 (T_Pattern_vIn46 ) in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule179 _patIdefsCollect in let !__st_ = st51 _lhsIcon _lhsInt _patX54 !__result_ = T_Pattern_vOut56 _lhsOdefsCollect __st_ in __result_ ) in C_Pattern_s58 v56 {-# NOINLINE rule178 #-} {-# LINE 202 "./src-ag/Desugar.ag" #-} rule178 = \ (_ :: ()) -> {-# LINE 202 "./src-ag/Desugar.ag" #-} Map.empty {-# LINE 2701 "dist/build/Desugar.hs"#-} {-# NOINLINE[1] rule179 #-} rule179 = \ ((!_patIdefsCollect) :: Set (Identifier, Identifier)) -> _patIdefsCollect {-# NOINLINE[1] rule180 #-} rule180 = \ ((!_patIerrors) :: Seq Error) -> _patIerrors {-# NOINLINE[1] rule181 #-} rule181 = \ ((!_patIcopy) :: Pattern) -> Irrefutable _patIcopy {-# NOINLINE[1] rule182 #-} rule182 = \ ((!_patIoutput) :: Pattern) -> Irrefutable _patIoutput {-# NOINLINE[1] rule183 #-} rule183 = \ !_copy -> _copy {-# NOINLINE[1] rule184 #-} rule184 = \ !_output -> _output {-# NOINLINE[1] rule185 #-} rule185 = \ ((!_lhsIchildInhs) :: [(Identifier, Identifier)]) -> _lhsIchildInhs {-# NOINLINE[1] rule187 #-} rule187 = \ ((!_lhsIcon) :: ConstructorIdent) -> _lhsIcon {-# NOINLINE[1] rule188 #-} rule188 = \ ((!_lhsIdefs) :: Set (Identifier, Identifier)) -> _lhsIdefs {-# NOINLINE[1] rule189 #-} rule189 = \ ((!_lhsIforcedIrrefutables) :: AttrMap) -> _lhsIforcedIrrefutables {-# NOINLINE[1] rule190 #-} rule190 = \ ((!_lhsInt) :: NontermIdent) -> _lhsInt {-# NOINLINE sem_Pattern_Underscore #-} sem_Pattern_Underscore :: (Pos) -> T_Pattern sem_Pattern_Underscore !arg_pos_ = T_Pattern (return st18) where {-# NOINLINE st18 #-} !st18 = let k18 :: K_Pattern_s18 t -> t k18 K_Pattern_v9 = v9 k18 K_Pattern_v27 = v27 k18 K_Pattern_v31 = v31 k18 K_Pattern_v41 = v41 k18 K_Pattern_v46 = v46 k18 K_Pattern_v55 = v55 v9 :: T_Pattern_v9 v9 = \ !(T_Pattern_vIn9 _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt) -> ( let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule191 () in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule192 () in let _lhsOerrors :: Seq Error !_lhsOerrors = rule193 () in let !_copy = rule194 arg_pos_ in let _lhsOcopy :: Pattern !_lhsOcopy = rule196 _copy in let !_output = rule195 arg_pos_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule197 _output in let !__result_ = T_Pattern_vOut9 _lhsOallAttributes _lhsOcopy _lhsOdefsCollect _lhsOerrors _lhsOoutput in __result_ ) v27 :: T_Pattern_v27 v27 = \ !(T_Pattern_vIn27 _lhsIchildInhs _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt) -> ( let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule191 () in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule192 () in let _lhsOerrors :: Seq Error !_lhsOerrors = rule193 () in let !_copy = rule194 arg_pos_ in let _lhsOcopy :: Pattern !_lhsOcopy = rule196 _copy in let !_output = rule195 arg_pos_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule197 _output in let !__result_ = T_Pattern_vOut27 _lhsOallAttributes _lhsOcopy _lhsOdefsCollect _lhsOerrors _lhsOoutput in __result_ ) v31 :: T_Pattern_v31 v31 = \ !(T_Pattern_vIn31 _lhsIchildInhs _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt) -> ( let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule191 () in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule192 () in let _lhsOerrors :: Seq Error !_lhsOerrors = rule193 () in let !_output = rule195 arg_pos_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule197 _output in let !__result_ = T_Pattern_vOut31 _lhsOallAttributes _lhsOdefsCollect _lhsOerrors _lhsOoutput in __result_ ) v41 :: T_Pattern_v41 v41 = \ !(T_Pattern_vIn41 _lhsIcon _lhsInt) -> ( let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule191 () in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule192 () in let !__st_ = st51 () !__result_ = T_Pattern_vOut41 _lhsOallAttributes _lhsOdefsCollect __st_ in __result_ ) v46 :: T_Pattern_v46 v46 = \ !(T_Pattern_vIn46 ) -> ( let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule192 () in let !__st_ = st54 () !__result_ = T_Pattern_vOut46 _lhsOdefsCollect __st_ in __result_ ) v55 :: T_Pattern_v55 v55 = \ !(T_Pattern_vIn55 _lhsIcon _lhsInt) -> ( let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule191 () in let !__st_ = st58 () !__result_ = T_Pattern_vOut55 _lhsOallAttributes __st_ in __result_ ) in C_Pattern_s18 k18 {-# NOINLINE st51 #-} st51 = \ (_ :: ()) -> let v42 :: T_Pattern_v42 v42 = \ !(T_Pattern_vIn42 _lhsIchildInhs _lhsIdefs _lhsIforcedIrrefutables) -> ( let _lhsOerrors :: Seq Error !_lhsOerrors = rule193 () in let !_output = rule195 arg_pos_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule197 _output in let !__result_ = T_Pattern_vOut42 _lhsOerrors _lhsOoutput in __result_ ) in C_Pattern_s51 v42 {-# NOINLINE st54 #-} st54 = \ (_ :: ()) -> let v48 :: T_Pattern_v48 v48 = \ !(T_Pattern_vIn48 _lhsIchildInhs _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt) -> ( let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule191 () in let _lhsOerrors :: Seq Error !_lhsOerrors = rule193 () in let !_output = rule195 arg_pos_ in let _lhsOoutput :: Pattern !_lhsOoutput = rule197 _output in let !__result_ = T_Pattern_vOut48 _lhsOallAttributes _lhsOerrors _lhsOoutput in __result_ ) in C_Pattern_s54 v48 {-# NOINLINE st58 #-} st58 = \ (_ :: ()) -> let v56 :: T_Pattern_v56 v56 = \ !(T_Pattern_vIn56 ) -> ( let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule192 () in let !__st_ = st51 () !__result_ = T_Pattern_vOut56 _lhsOdefsCollect __st_ in __result_ ) in C_Pattern_s58 v56 {-# NOINLINE[1] rule191 #-} rule191 = \ (_ :: ()) -> Map.empty {-# NOINLINE[1] rule192 #-} rule192 = \ (_ :: ()) -> Set.empty {-# NOINLINE[1] rule193 #-} rule193 = \ (_ :: ()) -> Seq.empty {-# NOINLINE[1] rule194 #-} rule194 = \ !pos_ -> Underscore pos_ {-# NOINLINE[1] rule195 #-} rule195 = \ !pos_ -> Underscore pos_ {-# NOINLINE[1] rule196 #-} rule196 = \ !_copy -> _copy {-# NOINLINE[1] rule197 #-} rule197 = \ !_output -> _output -- Patterns ---------------------------------------------------- -- wrapper data Inh_Patterns = Inh_Patterns { childInhs_Inh_Patterns :: !([(Identifier, Identifier)]), childSyns_Inh_Patterns :: !([(Identifier, Identifier)]), con_Inh_Patterns :: !(ConstructorIdent), defs_Inh_Patterns :: !(Set (Identifier, Identifier)), forcedIrrefutables_Inh_Patterns :: !(AttrMap), nt_Inh_Patterns :: !(NontermIdent) } data Syn_Patterns = Syn_Patterns { allAttributes_Syn_Patterns :: !(AttrMap), copy_Syn_Patterns :: !(Patterns), defsCollect_Syn_Patterns :: !(Set (Identifier, Identifier)), errors_Syn_Patterns :: !(Seq Error), output_Syn_Patterns :: !(Patterns) } {-# INLINABLE wrap_Patterns #-} wrap_Patterns :: T_Patterns -> Inh_Patterns -> (Syn_Patterns ) wrap_Patterns !(T_Patterns act) !(Inh_Patterns _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Patterns_vIn10 _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt !(T_Patterns_vOut10 _lhsOallAttributes _lhsOcopy _lhsOdefsCollect _lhsOerrors _lhsOoutput) <- return (inv_Patterns_s20 sem K_Patterns_v10 arg) return (Syn_Patterns _lhsOallAttributes _lhsOcopy _lhsOdefsCollect _lhsOerrors _lhsOoutput) ) -- cata {-# NOINLINE sem_Patterns #-} sem_Patterns :: Patterns -> T_Patterns sem_Patterns list = Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list) -- semantic domain newtype T_Patterns = T_Patterns { attach_T_Patterns :: Identity (T_Patterns_s20 ) } data T_Patterns_s20 where C_Patterns_s20 :: { inv_Patterns_s20 :: !(forall t. K_Patterns_s20 t -> t) } -> T_Patterns_s20 data T_Patterns_s21 = C_Patterns_s21 data T_Patterns_s41 = C_Patterns_s41 data T_Patterns_s49 = C_Patterns_s49 newtype T_Patterns_s53 = C_Patterns_s53 { inv_Patterns_s53 :: (T_Patterns_v47 ) } newtype T_Patterns_s56 = C_Patterns_s56 { inv_Patterns_s56 :: (T_Patterns_v52 ) } newtype T_Patterns_s59 = C_Patterns_s59 { inv_Patterns_s59 :: (T_Patterns_v58 ) } data K_Patterns_s20 k where K_Patterns_v10 :: K_Patterns_s20 (T_Patterns_v10 ) K_Patterns_v26 :: K_Patterns_s20 (T_Patterns_v26 ) K_Patterns_v38 :: K_Patterns_s20 (T_Patterns_v38 ) K_Patterns_v45 :: K_Patterns_s20 (T_Patterns_v45 ) K_Patterns_v51 :: K_Patterns_s20 (T_Patterns_v51 ) K_Patterns_v57 :: K_Patterns_s20 (T_Patterns_v57 ) type T_Patterns_v10 = (T_Patterns_vIn10 ) -> (T_Patterns_vOut10 ) data T_Patterns_vIn10 = T_Patterns_vIn10 !([(Identifier, Identifier)]) !([(Identifier, Identifier)]) !(ConstructorIdent) !(Set (Identifier, Identifier)) !(AttrMap) !(NontermIdent) data T_Patterns_vOut10 = T_Patterns_vOut10 !(AttrMap) !(Patterns) !(Set (Identifier, Identifier)) !(Seq Error) !(Patterns) type T_Patterns_v26 = (T_Patterns_vIn26 ) -> (T_Patterns_vOut26 ) data T_Patterns_vIn26 = T_Patterns_vIn26 !([(Identifier, Identifier)]) !(ConstructorIdent) !(Set (Identifier, Identifier)) !(AttrMap) !(NontermIdent) data T_Patterns_vOut26 = T_Patterns_vOut26 !(AttrMap) !(Patterns) !(Set (Identifier, Identifier)) !(Seq Error) !(Patterns) type T_Patterns_v38 = (T_Patterns_vIn38 ) -> (T_Patterns_vOut38 ) data T_Patterns_vIn38 = T_Patterns_vIn38 !([(Identifier, Identifier)]) !(ConstructorIdent) !(Set (Identifier, Identifier)) !(AttrMap) !(NontermIdent) data T_Patterns_vOut38 = T_Patterns_vOut38 !(AttrMap) !(Set (Identifier, Identifier)) !(Seq Error) !(Patterns) type T_Patterns_v45 = (T_Patterns_vIn45 ) -> (T_Patterns_vOut45 ) data T_Patterns_vIn45 = T_Patterns_vIn45 !(ConstructorIdent) !(NontermIdent) data T_Patterns_vOut45 = T_Patterns_vOut45 !(AttrMap) !(Set (Identifier, Identifier)) !(T_Patterns_s53 ) type T_Patterns_v47 = (T_Patterns_vIn47 ) -> (T_Patterns_vOut47 ) data T_Patterns_vIn47 = T_Patterns_vIn47 !([(Identifier, Identifier)]) !(Set (Identifier, Identifier)) !(AttrMap) data T_Patterns_vOut47 = T_Patterns_vOut47 !(Seq Error) !(Patterns) type T_Patterns_v51 = (T_Patterns_vIn51 ) -> (T_Patterns_vOut51 ) data T_Patterns_vIn51 = T_Patterns_vIn51 data T_Patterns_vOut51 = T_Patterns_vOut51 !(Set (Identifier, Identifier)) !(T_Patterns_s56 ) type T_Patterns_v52 = (T_Patterns_vIn52 ) -> (T_Patterns_vOut52 ) data T_Patterns_vIn52 = T_Patterns_vIn52 !([(Identifier, Identifier)]) !(ConstructorIdent) !(Set (Identifier, Identifier)) !(AttrMap) !(NontermIdent) data T_Patterns_vOut52 = T_Patterns_vOut52 !(AttrMap) !(Seq Error) !(Patterns) type T_Patterns_v57 = (T_Patterns_vIn57 ) -> (T_Patterns_vOut57 ) data T_Patterns_vIn57 = T_Patterns_vIn57 !(ConstructorIdent) !(NontermIdent) data T_Patterns_vOut57 = T_Patterns_vOut57 !(AttrMap) !(T_Patterns_s59 ) type T_Patterns_v58 = (T_Patterns_vIn58 ) -> (T_Patterns_vOut58 ) data T_Patterns_vIn58 = T_Patterns_vIn58 data T_Patterns_vOut58 = T_Patterns_vOut58 !(Set (Identifier, Identifier)) !(T_Patterns_s53 ) {-# NOINLINE sem_Patterns_Cons #-} sem_Patterns_Cons :: T_Pattern -> T_Patterns -> T_Patterns sem_Patterns_Cons arg_hd_ arg_tl_ = T_Patterns (return st20) where {-# NOINLINE st20 #-} !st20 = let k20 :: K_Patterns_s20 t -> t k20 K_Patterns_v10 = v10 k20 K_Patterns_v26 = v26 k20 K_Patterns_v38 = v38 k20 K_Patterns_v45 = v45 k20 K_Patterns_v51 = v51 k20 K_Patterns_v57 = v57 v10 :: T_Patterns_v10 v10 = \ !(T_Patterns_vIn10 _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt) -> ( let !_hdX18 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_hd_)) in let !_tlX20 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_tl_)) in let !_hdOcon = rule207 _lhsIcon in let !_hdOnt = rule210 _lhsInt in let !_tlOcon = rule213 _lhsIcon in let !_tlOnt = rule216 _lhsInt in let !_hdOchildInhs = rule205 _lhsIchildInhs in let !_hdOdefs = rule208 _lhsIdefs in let !_tlOchildInhs = rule211 _lhsIchildInhs in let !_tlOdefs = rule214 _lhsIdefs in let !_hdOforcedIrrefutables = rule209 _lhsIforcedIrrefutables in let !_tlOforcedIrrefutables = rule215 _lhsIforcedIrrefutables in let !(T_Pattern_vOut27 _hdIallAttributes _hdIcopy _hdIdefsCollect _hdIerrors _hdIoutput) = inv_Pattern_s18 _hdX18 K_Pattern_v27 (T_Pattern_vIn27 _hdOchildInhs _hdOcon _hdOdefs _hdOforcedIrrefutables _hdOnt) in let !(T_Patterns_vOut26 _tlIallAttributes _tlIcopy _tlIdefsCollect _tlIerrors _tlIoutput) = inv_Patterns_s20 _tlX20 K_Patterns_v26 (T_Patterns_vIn26 _tlOchildInhs _tlOcon _tlOdefs _tlOforcedIrrefutables _tlOnt) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule198 _hdIallAttributes _tlIallAttributes in let !_copy = rule201 _hdIcopy _tlIcopy in let _lhsOcopy :: Patterns !_lhsOcopy = rule203 _copy in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule199 _hdIdefsCollect _tlIdefsCollect in let _lhsOerrors :: Seq Error !_lhsOerrors = rule200 _hdIerrors _tlIerrors in let !_output = rule202 _hdIoutput _tlIoutput in let _lhsOoutput :: Patterns !_lhsOoutput = rule204 _output in let !__result_ = T_Patterns_vOut10 _lhsOallAttributes _lhsOcopy _lhsOdefsCollect _lhsOerrors _lhsOoutput in __result_ ) v26 :: T_Patterns_v26 v26 = \ !(T_Patterns_vIn26 _lhsIchildInhs _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt) -> ( let !_hdX18 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_hd_)) in let !_tlX20 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_tl_)) in let !_hdOcon = rule207 _lhsIcon in let !_hdOnt = rule210 _lhsInt in let !_tlOcon = rule213 _lhsIcon in let !_tlOnt = rule216 _lhsInt in let !_hdOchildInhs = rule205 _lhsIchildInhs in let !_hdOdefs = rule208 _lhsIdefs in let !_tlOchildInhs = rule211 _lhsIchildInhs in let !_tlOdefs = rule214 _lhsIdefs in let !_hdOforcedIrrefutables = rule209 _lhsIforcedIrrefutables in let !_tlOforcedIrrefutables = rule215 _lhsIforcedIrrefutables in let !(T_Pattern_vOut27 _hdIallAttributes _hdIcopy _hdIdefsCollect _hdIerrors _hdIoutput) = inv_Pattern_s18 _hdX18 K_Pattern_v27 (T_Pattern_vIn27 _hdOchildInhs _hdOcon _hdOdefs _hdOforcedIrrefutables _hdOnt) in let !(T_Patterns_vOut26 _tlIallAttributes _tlIcopy _tlIdefsCollect _tlIerrors _tlIoutput) = inv_Patterns_s20 _tlX20 K_Patterns_v26 (T_Patterns_vIn26 _tlOchildInhs _tlOcon _tlOdefs _tlOforcedIrrefutables _tlOnt) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule198 _hdIallAttributes _tlIallAttributes in let !_copy = rule201 _hdIcopy _tlIcopy in let _lhsOcopy :: Patterns !_lhsOcopy = rule203 _copy in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule199 _hdIdefsCollect _tlIdefsCollect in let _lhsOerrors :: Seq Error !_lhsOerrors = rule200 _hdIerrors _tlIerrors in let !_output = rule202 _hdIoutput _tlIoutput in let _lhsOoutput :: Patterns !_lhsOoutput = rule204 _output in let !__result_ = T_Patterns_vOut26 _lhsOallAttributes _lhsOcopy _lhsOdefsCollect _lhsOerrors _lhsOoutput in __result_ ) v38 :: T_Patterns_v38 v38 = \ !(T_Patterns_vIn38 _lhsIchildInhs _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt) -> ( let !_hdX18 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_hd_)) in let !_tlX20 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_tl_)) in let !_hdOcon = rule207 _lhsIcon in let !_hdOnt = rule210 _lhsInt in let !_tlOcon = rule213 _lhsIcon in let !_tlOnt = rule216 _lhsInt in let !_hdOchildInhs = rule205 _lhsIchildInhs in let !_hdOdefs = rule208 _lhsIdefs in let !_tlOchildInhs = rule211 _lhsIchildInhs in let !_tlOdefs = rule214 _lhsIdefs in let !_hdOforcedIrrefutables = rule209 _lhsIforcedIrrefutables in let !_tlOforcedIrrefutables = rule215 _lhsIforcedIrrefutables in let !(T_Pattern_vOut31 _hdIallAttributes _hdIdefsCollect _hdIerrors _hdIoutput) = inv_Pattern_s18 _hdX18 K_Pattern_v31 (T_Pattern_vIn31 _hdOchildInhs _hdOcon _hdOdefs _hdOforcedIrrefutables _hdOnt) in let !(T_Patterns_vOut38 _tlIallAttributes _tlIdefsCollect _tlIerrors _tlIoutput) = inv_Patterns_s20 _tlX20 K_Patterns_v38 (T_Patterns_vIn38 _tlOchildInhs _tlOcon _tlOdefs _tlOforcedIrrefutables _tlOnt) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule198 _hdIallAttributes _tlIallAttributes in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule199 _hdIdefsCollect _tlIdefsCollect in let _lhsOerrors :: Seq Error !_lhsOerrors = rule200 _hdIerrors _tlIerrors in let !_output = rule202 _hdIoutput _tlIoutput in let _lhsOoutput :: Patterns !_lhsOoutput = rule204 _output in let !__result_ = T_Patterns_vOut38 _lhsOallAttributes _lhsOdefsCollect _lhsOerrors _lhsOoutput in __result_ ) v45 :: T_Patterns_v45 v45 = \ !(T_Patterns_vIn45 _lhsIcon _lhsInt) -> ( let !_hdX18 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_hd_)) in let !_tlX20 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_tl_)) in let !_hdOcon = rule207 _lhsIcon in let !_hdOnt = rule210 _lhsInt in let !_tlOcon = rule213 _lhsIcon in let !_tlOnt = rule216 _lhsInt in let !(T_Pattern_vOut41 _hdIallAttributes _hdIdefsCollect _hdX51) = inv_Pattern_s18 _hdX18 K_Pattern_v41 (T_Pattern_vIn41 _hdOcon _hdOnt) in let !(T_Patterns_vOut45 _tlIallAttributes _tlIdefsCollect _tlX53) = inv_Patterns_s20 _tlX20 K_Patterns_v45 (T_Patterns_vIn45 _tlOcon _tlOnt) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule198 _hdIallAttributes _tlIallAttributes in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule199 _hdIdefsCollect _tlIdefsCollect in let !__st_ = st53 _hdX51 _tlX53 !__result_ = T_Patterns_vOut45 _lhsOallAttributes _lhsOdefsCollect __st_ in __result_ ) v51 :: T_Patterns_v51 v51 = \ !(T_Patterns_vIn51 ) -> ( let !_hdX18 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_hd_)) in let !_tlX20 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_tl_)) in let !(T_Pattern_vOut46 _hdIdefsCollect _hdX54) = inv_Pattern_s18 _hdX18 K_Pattern_v46 (T_Pattern_vIn46 ) in let !(T_Patterns_vOut51 _tlIdefsCollect _tlX56) = inv_Patterns_s20 _tlX20 K_Patterns_v51 (T_Patterns_vIn51 ) in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule199 _hdIdefsCollect _tlIdefsCollect in let !__st_ = st56 _hdX54 _tlX56 !__result_ = T_Patterns_vOut51 _lhsOdefsCollect __st_ in __result_ ) v57 :: T_Patterns_v57 v57 = \ !(T_Patterns_vIn57 _lhsIcon _lhsInt) -> ( let !_hdX18 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_hd_)) in let !_tlX20 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_tl_)) in let !_hdOcon = rule207 _lhsIcon in let !_hdOnt = rule210 _lhsInt in let !_tlOcon = rule213 _lhsIcon in let !_tlOnt = rule216 _lhsInt in let !(T_Pattern_vOut55 _hdIallAttributes _hdX58) = inv_Pattern_s18 _hdX18 K_Pattern_v55 (T_Pattern_vIn55 _hdOcon _hdOnt) in let !(T_Patterns_vOut57 _tlIallAttributes _tlX59) = inv_Patterns_s20 _tlX20 K_Patterns_v57 (T_Patterns_vIn57 _tlOcon _tlOnt) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule198 _hdIallAttributes _tlIallAttributes in let !__st_ = st59 _hdX58 _tlX59 !__result_ = T_Patterns_vOut57 _lhsOallAttributes __st_ in __result_ ) in C_Patterns_s20 k20 {-# NOINLINE st53 #-} st53 = \ !_hdX51 !_tlX53 -> let v47 :: T_Patterns_v47 v47 = \ !(T_Patterns_vIn47 _lhsIchildInhs _lhsIdefs _lhsIforcedIrrefutables) -> ( let !_hdOchildInhs = rule205 _lhsIchildInhs in let !_hdOdefs = rule208 _lhsIdefs in let !_tlOchildInhs = rule211 _lhsIchildInhs in let !_tlOdefs = rule214 _lhsIdefs in let !_hdOforcedIrrefutables = rule209 _lhsIforcedIrrefutables in let !_tlOforcedIrrefutables = rule215 _lhsIforcedIrrefutables in let !(T_Pattern_vOut42 _hdIerrors _hdIoutput) = inv_Pattern_s51 _hdX51 (T_Pattern_vIn42 _hdOchildInhs _hdOdefs _hdOforcedIrrefutables) in let !(T_Patterns_vOut47 _tlIerrors _tlIoutput) = inv_Patterns_s53 _tlX53 (T_Patterns_vIn47 _tlOchildInhs _tlOdefs _tlOforcedIrrefutables) in let _lhsOerrors :: Seq Error !_lhsOerrors = rule200 _hdIerrors _tlIerrors in let !_output = rule202 _hdIoutput _tlIoutput in let _lhsOoutput :: Patterns !_lhsOoutput = rule204 _output in let !__result_ = T_Patterns_vOut47 _lhsOerrors _lhsOoutput in __result_ ) in C_Patterns_s53 v47 {-# NOINLINE st56 #-} st56 = \ !_hdX54 !_tlX56 -> let v52 :: T_Patterns_v52 v52 = \ !(T_Patterns_vIn52 _lhsIchildInhs _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt) -> ( let !_hdOcon = rule207 _lhsIcon in let !_hdOnt = rule210 _lhsInt in let !_tlOcon = rule213 _lhsIcon in let !_tlOnt = rule216 _lhsInt in let !_hdOchildInhs = rule205 _lhsIchildInhs in let !_hdOdefs = rule208 _lhsIdefs in let !_tlOchildInhs = rule211 _lhsIchildInhs in let !_tlOdefs = rule214 _lhsIdefs in let !_hdOforcedIrrefutables = rule209 _lhsIforcedIrrefutables in let !_tlOforcedIrrefutables = rule215 _lhsIforcedIrrefutables in let !(T_Pattern_vOut48 _hdIallAttributes _hdIerrors _hdIoutput) = inv_Pattern_s54 _hdX54 (T_Pattern_vIn48 _hdOchildInhs _hdOcon _hdOdefs _hdOforcedIrrefutables _hdOnt) in let !(T_Patterns_vOut52 _tlIallAttributes _tlIerrors _tlIoutput) = inv_Patterns_s56 _tlX56 (T_Patterns_vIn52 _tlOchildInhs _tlOcon _tlOdefs _tlOforcedIrrefutables _tlOnt) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule198 _hdIallAttributes _tlIallAttributes in let _lhsOerrors :: Seq Error !_lhsOerrors = rule200 _hdIerrors _tlIerrors in let !_output = rule202 _hdIoutput _tlIoutput in let _lhsOoutput :: Patterns !_lhsOoutput = rule204 _output in let !__result_ = T_Patterns_vOut52 _lhsOallAttributes _lhsOerrors _lhsOoutput in __result_ ) in C_Patterns_s56 v52 {-# NOINLINE st59 #-} st59 = \ !_hdX58 !_tlX59 -> let v58 :: T_Patterns_v58 v58 = \ !(T_Patterns_vIn58 ) -> ( let !(T_Pattern_vOut56 _hdIdefsCollect _hdX51) = inv_Pattern_s58 _hdX58 (T_Pattern_vIn56 ) in let !(T_Patterns_vOut58 _tlIdefsCollect _tlX53) = inv_Patterns_s59 _tlX59 (T_Patterns_vIn58 ) in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule199 _hdIdefsCollect _tlIdefsCollect in let !__st_ = st53 _hdX51 _tlX53 !__result_ = T_Patterns_vOut58 _lhsOdefsCollect __st_ in __result_ ) in C_Patterns_s59 v58 {-# NOINLINE[1] rule198 #-} rule198 = \ ((!_hdIallAttributes) :: AttrMap) ((!_tlIallAttributes) :: AttrMap) -> _hdIallAttributes `mergeAttributes` _tlIallAttributes {-# NOINLINE[1] rule199 #-} rule199 = \ ((!_hdIdefsCollect) :: Set (Identifier, Identifier)) ((!_tlIdefsCollect) :: Set (Identifier, Identifier)) -> _hdIdefsCollect `Set.union` _tlIdefsCollect {-# NOINLINE[1] rule200 #-} rule200 = \ ((!_hdIerrors) :: Seq Error) ((!_tlIerrors) :: Seq Error) -> _hdIerrors Seq.>< _tlIerrors {-# NOINLINE[1] rule201 #-} rule201 = \ ((!_hdIcopy) :: Pattern) ((!_tlIcopy) :: Patterns) -> (:) _hdIcopy _tlIcopy {-# NOINLINE[1] rule202 #-} rule202 = \ ((!_hdIoutput) :: Pattern) ((!_tlIoutput) :: Patterns) -> (:) _hdIoutput _tlIoutput {-# NOINLINE[1] rule203 #-} rule203 = \ !_copy -> _copy {-# NOINLINE[1] rule204 #-} rule204 = \ !_output -> _output {-# NOINLINE[1] rule205 #-} rule205 = \ ((!_lhsIchildInhs) :: [(Identifier, Identifier)]) -> _lhsIchildInhs {-# NOINLINE[1] rule207 #-} rule207 = \ ((!_lhsIcon) :: ConstructorIdent) -> _lhsIcon {-# NOINLINE[1] rule208 #-} rule208 = \ ((!_lhsIdefs) :: Set (Identifier, Identifier)) -> _lhsIdefs {-# NOINLINE[1] rule209 #-} rule209 = \ ((!_lhsIforcedIrrefutables) :: AttrMap) -> _lhsIforcedIrrefutables {-# NOINLINE[1] rule210 #-} rule210 = \ ((!_lhsInt) :: NontermIdent) -> _lhsInt {-# NOINLINE[1] rule211 #-} rule211 = \ ((!_lhsIchildInhs) :: [(Identifier, Identifier)]) -> _lhsIchildInhs {-# NOINLINE[1] rule213 #-} rule213 = \ ((!_lhsIcon) :: ConstructorIdent) -> _lhsIcon {-# NOINLINE[1] rule214 #-} rule214 = \ ((!_lhsIdefs) :: Set (Identifier, Identifier)) -> _lhsIdefs {-# NOINLINE[1] rule215 #-} rule215 = \ ((!_lhsIforcedIrrefutables) :: AttrMap) -> _lhsIforcedIrrefutables {-# NOINLINE[1] rule216 #-} rule216 = \ ((!_lhsInt) :: NontermIdent) -> _lhsInt {-# NOINLINE sem_Patterns_Nil #-} sem_Patterns_Nil :: T_Patterns sem_Patterns_Nil = T_Patterns (return st20) where {-# NOINLINE st20 #-} !st20 = let k20 :: K_Patterns_s20 t -> t k20 K_Patterns_v10 = v10 k20 K_Patterns_v26 = v26 k20 K_Patterns_v38 = v38 k20 K_Patterns_v45 = v45 k20 K_Patterns_v51 = v51 k20 K_Patterns_v57 = v57 v10 :: T_Patterns_v10 v10 = \ !(T_Patterns_vIn10 _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt) -> ( let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule217 () in let !_copy = rule220 () in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule218 () in let _lhsOerrors :: Seq Error !_lhsOerrors = rule219 () in let !_output = rule221 () in let _lhsOcopy :: Patterns !_lhsOcopy = rule222 _copy in let _lhsOoutput :: Patterns !_lhsOoutput = rule223 _output in let !__result_ = T_Patterns_vOut10 _lhsOallAttributes _lhsOcopy _lhsOdefsCollect _lhsOerrors _lhsOoutput in __result_ ) v26 :: T_Patterns_v26 v26 = \ !(T_Patterns_vIn26 _lhsIchildInhs _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt) -> ( let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule217 () in let !_copy = rule220 () in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule218 () in let _lhsOerrors :: Seq Error !_lhsOerrors = rule219 () in let !_output = rule221 () in let _lhsOcopy :: Patterns !_lhsOcopy = rule222 _copy in let _lhsOoutput :: Patterns !_lhsOoutput = rule223 _output in let !__result_ = T_Patterns_vOut26 _lhsOallAttributes _lhsOcopy _lhsOdefsCollect _lhsOerrors _lhsOoutput in __result_ ) v38 :: T_Patterns_v38 v38 = \ !(T_Patterns_vIn38 _lhsIchildInhs _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt) -> ( let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule217 () in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule218 () in let _lhsOerrors :: Seq Error !_lhsOerrors = rule219 () in let !_output = rule221 () in let _lhsOoutput :: Patterns !_lhsOoutput = rule223 _output in let !__result_ = T_Patterns_vOut38 _lhsOallAttributes _lhsOdefsCollect _lhsOerrors _lhsOoutput in __result_ ) v45 :: T_Patterns_v45 v45 = \ !(T_Patterns_vIn45 _lhsIcon _lhsInt) -> ( let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule217 () in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule218 () in let !__st_ = st53 () !__result_ = T_Patterns_vOut45 _lhsOallAttributes _lhsOdefsCollect __st_ in __result_ ) v51 :: T_Patterns_v51 v51 = \ !(T_Patterns_vIn51 ) -> ( let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule218 () in let !__st_ = st56 () !__result_ = T_Patterns_vOut51 _lhsOdefsCollect __st_ in __result_ ) v57 :: T_Patterns_v57 v57 = \ !(T_Patterns_vIn57 _lhsIcon _lhsInt) -> ( let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule217 () in let !__st_ = st59 () !__result_ = T_Patterns_vOut57 _lhsOallAttributes __st_ in __result_ ) in C_Patterns_s20 k20 {-# NOINLINE st53 #-} st53 = \ (_ :: ()) -> let v47 :: T_Patterns_v47 v47 = \ !(T_Patterns_vIn47 _lhsIchildInhs _lhsIdefs _lhsIforcedIrrefutables) -> ( let _lhsOerrors :: Seq Error !_lhsOerrors = rule219 () in let !_output = rule221 () in let _lhsOoutput :: Patterns !_lhsOoutput = rule223 _output in let !__result_ = T_Patterns_vOut47 _lhsOerrors _lhsOoutput in __result_ ) in C_Patterns_s53 v47 {-# NOINLINE st56 #-} st56 = \ (_ :: ()) -> let v52 :: T_Patterns_v52 v52 = \ !(T_Patterns_vIn52 _lhsIchildInhs _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt) -> ( let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule217 () in let _lhsOerrors :: Seq Error !_lhsOerrors = rule219 () in let !_output = rule221 () in let _lhsOoutput :: Patterns !_lhsOoutput = rule223 _output in let !__result_ = T_Patterns_vOut52 _lhsOallAttributes _lhsOerrors _lhsOoutput in __result_ ) in C_Patterns_s56 v52 {-# NOINLINE st59 #-} st59 = \ (_ :: ()) -> let v58 :: T_Patterns_v58 v58 = \ !(T_Patterns_vIn58 ) -> ( let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule218 () in let !__st_ = st53 () !__result_ = T_Patterns_vOut58 _lhsOdefsCollect __st_ in __result_ ) in C_Patterns_s59 v58 {-# NOINLINE[1] rule217 #-} rule217 = \ (_ :: ()) -> Map.empty {-# NOINLINE[1] rule218 #-} rule218 = \ (_ :: ()) -> Set.empty {-# NOINLINE[1] rule219 #-} rule219 = \ (_ :: ()) -> Seq.empty {-# NOINLINE[1] rule220 #-} rule220 = \ (_ :: ()) -> [] {-# NOINLINE[1] rule221 #-} rule221 = \ (_ :: ()) -> [] {-# NOINLINE[1] rule222 #-} rule222 = \ !_copy -> _copy {-# NOINLINE[1] rule223 #-} rule223 = \ !_output -> _output -- Production -------------------------------------------------- -- wrapper data Inh_Production = Inh_Production { augmentsIn_Inh_Production :: !(Map ConstructorIdent (Map Identifier [Expression])), forcedIrrefutables_Inh_Production :: !(AttrMap), inhMap_Inh_Production :: !(Map Identifier Attributes), mainName_Inh_Production :: !(String), nt_Inh_Production :: !(NontermIdent), options_Inh_Production :: !(Options), synMap_Inh_Production :: !(Map Identifier Attributes) } data Syn_Production = Syn_Production { allAttributes_Syn_Production :: !(AttrMap), augmentsOut_Syn_Production :: !(Map ConstructorIdent (Map Identifier [Expression])), errors_Syn_Production :: !(Seq Error), output_Syn_Production :: !(Production) } {-# INLINABLE wrap_Production #-} wrap_Production :: T_Production -> Inh_Production -> (Syn_Production ) wrap_Production !(T_Production act) !(Inh_Production _lhsIaugmentsIn _lhsIforcedIrrefutables _lhsIinhMap _lhsImainName _lhsInt _lhsIoptions _lhsIsynMap) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Production_vIn11 _lhsIaugmentsIn _lhsIforcedIrrefutables _lhsIinhMap _lhsImainName _lhsInt _lhsIoptions _lhsIsynMap !(T_Production_vOut11 _lhsOallAttributes _lhsOaugmentsOut _lhsOerrors _lhsOoutput) <- return (inv_Production_s22 sem K_Production_v11 arg) return (Syn_Production _lhsOallAttributes _lhsOaugmentsOut _lhsOerrors _lhsOoutput) ) -- cata {-# INLINE sem_Production #-} sem_Production :: Production -> T_Production sem_Production ( Production !con_ !params_ !constraints_ children_ rules_ typeSigs_ !macro_ ) = sem_Production_Production con_ params_ constraints_ ( sem_Children children_ ) ( sem_Rules rules_ ) ( sem_TypeSigs typeSigs_ ) macro_ -- semantic domain newtype T_Production = T_Production { attach_T_Production :: Identity (T_Production_s22 ) } data T_Production_s22 where C_Production_s22 :: { inv_Production_s22 :: !(forall t. K_Production_s22 t -> t) } -> T_Production_s22 data T_Production_s23 = C_Production_s23 data T_Production_s44 = C_Production_s44 newtype T_Production_s52 = C_Production_s52 { inv_Production_s52 :: (T_Production_v44 ) } data K_Production_s22 k where K_Production_v11 :: K_Production_s22 (T_Production_v11 ) K_Production_v30 :: K_Production_s22 (T_Production_v30 ) K_Production_v43 :: K_Production_s22 (T_Production_v43 ) type T_Production_v11 = (T_Production_vIn11 ) -> (T_Production_vOut11 ) data T_Production_vIn11 = T_Production_vIn11 !(Map ConstructorIdent (Map Identifier [Expression])) !(AttrMap) !(Map Identifier Attributes) !(String) !(NontermIdent) !(Options) !(Map Identifier Attributes) data T_Production_vOut11 = T_Production_vOut11 !(AttrMap) !(Map ConstructorIdent (Map Identifier [Expression])) !(Seq Error) !(Production) type T_Production_v30 = (T_Production_vIn30 ) -> (T_Production_vOut30 ) data T_Production_vIn30 = T_Production_vIn30 !(Map ConstructorIdent (Map Identifier [Expression])) !(AttrMap) !(Map Identifier Attributes) !(NontermIdent) !(Options) !(Map Identifier Attributes) data T_Production_vOut30 = T_Production_vOut30 !(AttrMap) !(Map ConstructorIdent (Map Identifier [Expression])) !(Seq Error) !(Production) type T_Production_v43 = (T_Production_vIn43 ) -> (T_Production_vOut43 ) data T_Production_vIn43 = T_Production_vIn43 !(NontermIdent) data T_Production_vOut43 = T_Production_vOut43 !(AttrMap) !(T_Production_s52 ) type T_Production_v44 = (T_Production_vIn44 ) -> (T_Production_vOut44 ) data T_Production_vIn44 = T_Production_vIn44 !(Map ConstructorIdent (Map Identifier [Expression])) !(AttrMap) !(Map Identifier Attributes) !(Options) !(Map Identifier Attributes) data T_Production_vOut44 = T_Production_vOut44 !(Map ConstructorIdent (Map Identifier [Expression])) !(Seq Error) !(Production) {-# NOINLINE sem_Production_Production #-} sem_Production_Production :: (ConstructorIdent) -> ([Identifier]) -> ([Type]) -> T_Children -> T_Rules -> T_TypeSigs -> (MaybeMacro) -> T_Production sem_Production_Production !arg_con_ !arg_params_ !arg_constraints_ arg_children_ arg_rules_ arg_typeSigs_ !arg_macro_ = T_Production (return st22) where {-# NOINLINE st22 #-} !st22 = let k22 :: K_Production_s22 t -> t k22 K_Production_v11 = v11 k22 K_Production_v30 = v30 k22 K_Production_v43 = v43 v11 :: T_Production_v11 v11 = \ !(T_Production_vIn11 _lhsIaugmentsIn _lhsIforcedIrrefutables _lhsIinhMap _lhsImainName _lhsInt _lhsIoptions _lhsIsynMap) -> ( let !_rulesX28 = Control.Monad.Identity.runIdentity (attach_T_Rules (arg_rules_)) in let !_childrenX2 = Control.Monad.Identity.runIdentity (attach_T_Children (arg_children_)) in let !_typeSigsX32 = Control.Monad.Identity.runIdentity (attach_T_TypeSigs (arg_typeSigs_)) in let !_rulesOcon = rule224 arg_con_ in let !_rulesOnt = rule241 _lhsInt in let !_childrenOinhMap = rule234 _lhsIinhMap in let !_childrenOsynMap = rule237 _lhsIsynMap in let !_augmentsIn = rule226 _lhsIaugmentsIn arg_con_ in let !_rulesOoptions = rule242 _lhsIoptions in let !_rulesOforcedIrrefutables = rule240 _lhsIforcedIrrefutables in let !(T_Children_vOut18 _childrenIchildInhs _childrenIchildSyns _childrenIoutput) = inv_Children_s2 _childrenX2 K_Children_v18 (T_Children_vIn18 _childrenOinhMap _childrenOsynMap) in let !(T_Rules_vOut28 _rulesIallAttributes _rulesIdefsCollect _rulesX43) = inv_Rules_s28 _rulesX28 K_Rules_v28 (T_Rules_vIn28 _rulesOcon _rulesOnt) in let !(T_TypeSigs_vOut16 _typeSigsIoutput) = inv_TypeSigs_s32 _typeSigsX32 (T_TypeSigs_vIn16 ) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule230 _rulesIallAttributes in let !(!_augmentErrs,!_augmentsOut1) = rule228 _augmentsIn _childrenIchildInhs _childrenIchildSyns _lhsInt _lhsIoptions arg_con_ in let !_augmentsOut = rule227 _augmentsOut1 arg_con_ in let _lhsOaugmentsOut :: Map ConstructorIdent (Map Identifier [Expression]) !_lhsOaugmentsOut = rule231 _augmentsOut in let !_rulesOchildInhs = rule238 _childrenIchildInhs in let !_rulesOchildSyns = rule239 _childrenIchildSyns in let !_rulesOdefs = rule225 _rulesIdefsCollect in let !(T_Rules_vOut29 _rulesIerrors _rulesIoutput) = inv_Rules_s43 _rulesX43 (T_Rules_vIn29 _rulesOchildInhs _rulesOchildSyns _rulesOdefs _rulesOforcedIrrefutables _rulesOoptions) in let _lhsOerrors :: Seq Error !_lhsOerrors = rule229 _augmentErrs _rulesIerrors in let !_output = rule232 _childrenIoutput _rulesIoutput _typeSigsIoutput arg_con_ arg_constraints_ arg_macro_ arg_params_ in let _lhsOoutput :: Production !_lhsOoutput = rule233 _output in let !__result_ = T_Production_vOut11 _lhsOallAttributes _lhsOaugmentsOut _lhsOerrors _lhsOoutput in __result_ ) v30 :: T_Production_v30 v30 = \ !(T_Production_vIn30 _lhsIaugmentsIn _lhsIforcedIrrefutables _lhsIinhMap _lhsInt _lhsIoptions _lhsIsynMap) -> ( let !_rulesX28 = Control.Monad.Identity.runIdentity (attach_T_Rules (arg_rules_)) in let !_childrenX2 = Control.Monad.Identity.runIdentity (attach_T_Children (arg_children_)) in let !_typeSigsX32 = Control.Monad.Identity.runIdentity (attach_T_TypeSigs (arg_typeSigs_)) in let !_rulesOcon = rule224 arg_con_ in let !_rulesOnt = rule241 _lhsInt in let !_childrenOinhMap = rule234 _lhsIinhMap in let !_childrenOsynMap = rule237 _lhsIsynMap in let !_augmentsIn = rule226 _lhsIaugmentsIn arg_con_ in let !_rulesOoptions = rule242 _lhsIoptions in let !_rulesOforcedIrrefutables = rule240 _lhsIforcedIrrefutables in let !(T_Children_vOut18 _childrenIchildInhs _childrenIchildSyns _childrenIoutput) = inv_Children_s2 _childrenX2 K_Children_v18 (T_Children_vIn18 _childrenOinhMap _childrenOsynMap) in let !(T_Rules_vOut28 _rulesIallAttributes _rulesIdefsCollect _rulesX43) = inv_Rules_s28 _rulesX28 K_Rules_v28 (T_Rules_vIn28 _rulesOcon _rulesOnt) in let !(T_TypeSigs_vOut16 _typeSigsIoutput) = inv_TypeSigs_s32 _typeSigsX32 (T_TypeSigs_vIn16 ) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule230 _rulesIallAttributes in let !(!_augmentErrs,!_augmentsOut1) = rule228 _augmentsIn _childrenIchildInhs _childrenIchildSyns _lhsInt _lhsIoptions arg_con_ in let !_augmentsOut = rule227 _augmentsOut1 arg_con_ in let _lhsOaugmentsOut :: Map ConstructorIdent (Map Identifier [Expression]) !_lhsOaugmentsOut = rule231 _augmentsOut in let !_rulesOchildInhs = rule238 _childrenIchildInhs in let !_rulesOchildSyns = rule239 _childrenIchildSyns in let !_rulesOdefs = rule225 _rulesIdefsCollect in let !(T_Rules_vOut29 _rulesIerrors _rulesIoutput) = inv_Rules_s43 _rulesX43 (T_Rules_vIn29 _rulesOchildInhs _rulesOchildSyns _rulesOdefs _rulesOforcedIrrefutables _rulesOoptions) in let _lhsOerrors :: Seq Error !_lhsOerrors = rule229 _augmentErrs _rulesIerrors in let !_output = rule232 _childrenIoutput _rulesIoutput _typeSigsIoutput arg_con_ arg_constraints_ arg_macro_ arg_params_ in let _lhsOoutput :: Production !_lhsOoutput = rule233 _output in let !__result_ = T_Production_vOut30 _lhsOallAttributes _lhsOaugmentsOut _lhsOerrors _lhsOoutput in __result_ ) v43 :: T_Production_v43 v43 = \ !(T_Production_vIn43 _lhsInt) -> ( let !_rulesX28 = Control.Monad.Identity.runIdentity (attach_T_Rules (arg_rules_)) in let !_rulesOcon = rule224 arg_con_ in let !_rulesOnt = rule241 _lhsInt in let !(T_Rules_vOut49 _rulesIallAttributes _rulesX55) = inv_Rules_s28 _rulesX28 K_Rules_v49 (T_Rules_vIn49 _rulesOcon _rulesOnt) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule230 _rulesIallAttributes in let !__st_ = st52 _lhsInt _rulesX55 !__result_ = T_Production_vOut43 _lhsOallAttributes __st_ in __result_ ) in C_Production_s22 k22 {-# NOINLINE st52 #-} st52 = \ ((!_lhsInt) :: NontermIdent) !_rulesX55 -> let v44 :: T_Production_v44 v44 = \ !(T_Production_vIn44 _lhsIaugmentsIn _lhsIforcedIrrefutables _lhsIinhMap _lhsIoptions _lhsIsynMap) -> ( let !_childrenX2 = Control.Monad.Identity.runIdentity (attach_T_Children (arg_children_)) in let !_typeSigsX32 = Control.Monad.Identity.runIdentity (attach_T_TypeSigs (arg_typeSigs_)) in let !_childrenOinhMap = rule234 _lhsIinhMap in let !_childrenOsynMap = rule237 _lhsIsynMap in let !_augmentsIn = rule226 _lhsIaugmentsIn arg_con_ in let !_rulesOoptions = rule242 _lhsIoptions in let !_rulesOforcedIrrefutables = rule240 _lhsIforcedIrrefutables in let !(T_Children_vOut18 _childrenIchildInhs _childrenIchildSyns _childrenIoutput) = inv_Children_s2 _childrenX2 K_Children_v18 (T_Children_vIn18 _childrenOinhMap _childrenOsynMap) in let !(T_Rules_vOut50 _rulesIdefsCollect _rulesX43) = inv_Rules_s55 _rulesX55 (T_Rules_vIn50 ) in let !(T_TypeSigs_vOut16 _typeSigsIoutput) = inv_TypeSigs_s32 _typeSigsX32 (T_TypeSigs_vIn16 ) in let !(!_augmentErrs,!_augmentsOut1) = rule228 _augmentsIn _childrenIchildInhs _childrenIchildSyns _lhsInt _lhsIoptions arg_con_ in let !_augmentsOut = rule227 _augmentsOut1 arg_con_ in let _lhsOaugmentsOut :: Map ConstructorIdent (Map Identifier [Expression]) !_lhsOaugmentsOut = rule231 _augmentsOut in let !_rulesOchildInhs = rule238 _childrenIchildInhs in let !_rulesOchildSyns = rule239 _childrenIchildSyns in let !_rulesOdefs = rule225 _rulesIdefsCollect in let !(T_Rules_vOut29 _rulesIerrors _rulesIoutput) = inv_Rules_s43 _rulesX43 (T_Rules_vIn29 _rulesOchildInhs _rulesOchildSyns _rulesOdefs _rulesOforcedIrrefutables _rulesOoptions) in let _lhsOerrors :: Seq Error !_lhsOerrors = rule229 _augmentErrs _rulesIerrors in let !_output = rule232 _childrenIoutput _rulesIoutput _typeSigsIoutput arg_con_ arg_constraints_ arg_macro_ arg_params_ in let _lhsOoutput :: Production !_lhsOoutput = rule233 _output in let !__result_ = T_Production_vOut44 _lhsOaugmentsOut _lhsOerrors _lhsOoutput in __result_ ) in C_Production_s52 v44 {-# NOINLINE[1] rule224 #-} {-# LINE 161 "./src-ag/Desugar.ag" #-} rule224 = \ !con_ -> {-# LINE 161 "./src-ag/Desugar.ag" #-} con_ {-# LINE 3504 "dist/build/Desugar.hs"#-} {-# NOINLINE[1] rule225 #-} {-# LINE 188 "./src-ag/Desugar.ag" #-} rule225 = \ ((!_rulesIdefsCollect) :: Set (Identifier, Identifier)) -> {-# LINE 188 "./src-ag/Desugar.ag" #-} _rulesIdefsCollect {-# LINE 3510 "dist/build/Desugar.hs"#-} {-# NOINLINE[1] rule226 #-} {-# LINE 244 "./src-ag/Desugar.ag" #-} rule226 = \ ((!_lhsIaugmentsIn) :: Map ConstructorIdent (Map Identifier [Expression])) !con_ -> {-# LINE 244 "./src-ag/Desugar.ag" #-} Map.findWithDefault Map.empty con_ _lhsIaugmentsIn {-# LINE 3516 "dist/build/Desugar.hs"#-} {-# NOINLINE[1] rule227 #-} {-# LINE 245 "./src-ag/Desugar.ag" #-} rule227 = \ !_augmentsOut1 !con_ -> {-# LINE 245 "./src-ag/Desugar.ag" #-} Map.singleton con_ _augmentsOut1 {-# LINE 3522 "dist/build/Desugar.hs"#-} {-# NOINLINE[1] rule228 #-} {-# LINE 247 "./src-ag/Desugar.ag" #-} rule228 = \ !_augmentsIn ((!_childrenIchildInhs) :: [(Identifier, Identifier)]) ((!_childrenIchildSyns) :: [(Identifier, Identifier)]) ((!_lhsInt) :: NontermIdent) ((!_lhsIoptions) :: Options) !con_ -> {-# LINE 247 "./src-ag/Desugar.ag" #-} Map.mapAccum (desugarExprs _lhsIoptions _lhsInt con_ _childrenIchildInhs _childrenIchildSyns) Seq.empty _augmentsIn {-# LINE 3528 "dist/build/Desugar.hs"#-} {-# NOINLINE[1] rule229 #-} {-# LINE 283 "./src-ag/Desugar.ag" #-} rule229 = \ !_augmentErrs ((!_rulesIerrors) :: Seq Error) -> {-# LINE 283 "./src-ag/Desugar.ag" #-} _rulesIerrors Seq.>< _augmentErrs {-# LINE 3534 "dist/build/Desugar.hs"#-} {-# NOINLINE[1] rule230 #-} rule230 = \ ((!_rulesIallAttributes) :: AttrMap) -> _rulesIallAttributes {-# NOINLINE[1] rule231 #-} rule231 = \ !_augmentsOut -> _augmentsOut {-# NOINLINE[1] rule232 #-} rule232 = \ ((!_childrenIoutput) :: Children) ((!_rulesIoutput) :: Rules) ((!_typeSigsIoutput) :: TypeSigs) !con_ !constraints_ !macro_ !params_ -> Production con_ params_ constraints_ _childrenIoutput _rulesIoutput _typeSigsIoutput macro_ {-# NOINLINE[1] rule233 #-} rule233 = \ !_output -> _output {-# NOINLINE[1] rule234 #-} rule234 = \ ((!_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# NOINLINE[1] rule237 #-} rule237 = \ ((!_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# NOINLINE[1] rule238 #-} rule238 = \ ((!_childrenIchildInhs) :: [(Identifier, Identifier)]) -> _childrenIchildInhs {-# NOINLINE[1] rule239 #-} rule239 = \ ((!_childrenIchildSyns) :: [(Identifier, Identifier)]) -> _childrenIchildSyns {-# NOINLINE[1] rule240 #-} rule240 = \ ((!_lhsIforcedIrrefutables) :: AttrMap) -> _lhsIforcedIrrefutables {-# NOINLINE[1] rule241 #-} rule241 = \ ((!_lhsInt) :: NontermIdent) -> _lhsInt {-# NOINLINE[1] rule242 #-} rule242 = \ ((!_lhsIoptions) :: Options) -> _lhsIoptions -- Productions ------------------------------------------------- -- wrapper data Inh_Productions = Inh_Productions { augmentsIn_Inh_Productions :: !(Map ConstructorIdent (Map Identifier [Expression])), forcedIrrefutables_Inh_Productions :: !(AttrMap), inhMap_Inh_Productions :: !(Map Identifier Attributes), mainName_Inh_Productions :: !(String), nt_Inh_Productions :: !(NontermIdent), options_Inh_Productions :: !(Options), synMap_Inh_Productions :: !(Map Identifier Attributes) } data Syn_Productions = Syn_Productions { allAttributes_Syn_Productions :: !(AttrMap), augmentsOut_Syn_Productions :: !(Map ConstructorIdent (Map Identifier [Expression])), errors_Syn_Productions :: !(Seq Error), output_Syn_Productions :: !(Productions) } {-# INLINABLE wrap_Productions #-} wrap_Productions :: T_Productions -> Inh_Productions -> (Syn_Productions ) wrap_Productions !(T_Productions act) !(Inh_Productions _lhsIaugmentsIn _lhsIforcedIrrefutables _lhsIinhMap _lhsImainName _lhsInt _lhsIoptions _lhsIsynMap) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Productions_vIn12 _lhsIaugmentsIn _lhsIforcedIrrefutables _lhsIinhMap _lhsImainName _lhsInt _lhsIoptions _lhsIsynMap !(T_Productions_vOut12 _lhsOallAttributes _lhsOaugmentsOut _lhsOerrors _lhsOoutput) <- return (inv_Productions_s24 sem K_Productions_v12 arg) return (Syn_Productions _lhsOallAttributes _lhsOaugmentsOut _lhsOerrors _lhsOoutput) ) -- cata {-# NOINLINE sem_Productions #-} sem_Productions :: Productions -> T_Productions sem_Productions list = Prelude.foldr sem_Productions_Cons sem_Productions_Nil (Prelude.map sem_Production list) -- semantic domain newtype T_Productions = T_Productions { attach_T_Productions :: Identity (T_Productions_s24 ) } data T_Productions_s24 where C_Productions_s24 :: { inv_Productions_s24 :: !(forall t. K_Productions_s24 t -> t) } -> T_Productions_s24 data T_Productions_s25 = C_Productions_s25 data T_Productions_s40 = C_Productions_s40 newtype T_Productions_s50 = C_Productions_s50 { inv_Productions_s50 :: (T_Productions_v40 ) } data K_Productions_s24 k where K_Productions_v12 :: K_Productions_s24 (T_Productions_v12 ) K_Productions_v25 :: K_Productions_s24 (T_Productions_v25 ) K_Productions_v39 :: K_Productions_s24 (T_Productions_v39 ) type T_Productions_v12 = (T_Productions_vIn12 ) -> (T_Productions_vOut12 ) data T_Productions_vIn12 = T_Productions_vIn12 !(Map ConstructorIdent (Map Identifier [Expression])) !(AttrMap) !(Map Identifier Attributes) !(String) !(NontermIdent) !(Options) !(Map Identifier Attributes) data T_Productions_vOut12 = T_Productions_vOut12 !(AttrMap) !(Map ConstructorIdent (Map Identifier [Expression])) !(Seq Error) !(Productions) type T_Productions_v25 = (T_Productions_vIn25 ) -> (T_Productions_vOut25 ) data T_Productions_vIn25 = T_Productions_vIn25 !(Map ConstructorIdent (Map Identifier [Expression])) !(AttrMap) !(Map Identifier Attributes) !(NontermIdent) !(Options) !(Map Identifier Attributes) data T_Productions_vOut25 = T_Productions_vOut25 !(AttrMap) !(Map ConstructorIdent (Map Identifier [Expression])) !(Seq Error) !(Productions) type T_Productions_v39 = (T_Productions_vIn39 ) -> (T_Productions_vOut39 ) data T_Productions_vIn39 = T_Productions_vIn39 !(NontermIdent) data T_Productions_vOut39 = T_Productions_vOut39 !(AttrMap) !(T_Productions_s50 ) type T_Productions_v40 = (T_Productions_vIn40 ) -> (T_Productions_vOut40 ) data T_Productions_vIn40 = T_Productions_vIn40 !(Map ConstructorIdent (Map Identifier [Expression])) !(AttrMap) !(Map Identifier Attributes) !(Options) !(Map Identifier Attributes) data T_Productions_vOut40 = T_Productions_vOut40 !(Map ConstructorIdent (Map Identifier [Expression])) !(Seq Error) !(Productions) {-# NOINLINE sem_Productions_Cons #-} sem_Productions_Cons :: T_Production -> T_Productions -> T_Productions sem_Productions_Cons arg_hd_ arg_tl_ = T_Productions (return st24) where {-# NOINLINE st24 #-} !st24 = let k24 :: K_Productions_s24 t -> t k24 K_Productions_v12 = v12 k24 K_Productions_v25 = v25 k24 K_Productions_v39 = v39 v12 :: T_Productions_v12 v12 = \ !(T_Productions_vIn12 _lhsIaugmentsIn _lhsIforcedIrrefutables _lhsIinhMap _lhsImainName _lhsInt _lhsIoptions _lhsIsynMap) -> ( let !_hdX22 = Control.Monad.Identity.runIdentity (attach_T_Production (arg_hd_)) in let !_tlX24 = Control.Monad.Identity.runIdentity (attach_T_Productions (arg_tl_)) in let !_hdOnt = rule252 _lhsInt in let !_tlOnt = rule259 _lhsInt in let !_hdOaugmentsIn = rule248 _lhsIaugmentsIn in let !_hdOinhMap = rule250 _lhsIinhMap in let !_hdOoptions = rule253 _lhsIoptions in let !_hdOsynMap = rule254 _lhsIsynMap in let !_tlOaugmentsIn = rule255 _lhsIaugmentsIn in let !_tlOinhMap = rule257 _lhsIinhMap in let !_tlOoptions = rule260 _lhsIoptions in let !_tlOsynMap = rule261 _lhsIsynMap in let !_hdOforcedIrrefutables = rule249 _lhsIforcedIrrefutables in let !_tlOforcedIrrefutables = rule256 _lhsIforcedIrrefutables in let !(T_Production_vOut30 _hdIallAttributes _hdIaugmentsOut _hdIerrors _hdIoutput) = inv_Production_s22 _hdX22 K_Production_v30 (T_Production_vIn30 _hdOaugmentsIn _hdOforcedIrrefutables _hdOinhMap _hdOnt _hdOoptions _hdOsynMap) in let !(T_Productions_vOut25 _tlIallAttributes _tlIaugmentsOut _tlIerrors _tlIoutput) = inv_Productions_s24 _tlX24 K_Productions_v25 (T_Productions_vIn25 _tlOaugmentsIn _tlOforcedIrrefutables _tlOinhMap _tlOnt _tlOoptions _tlOsynMap) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule243 _hdIallAttributes _tlIallAttributes in let _lhsOaugmentsOut :: Map ConstructorIdent (Map Identifier [Expression]) !_lhsOaugmentsOut = rule244 _hdIaugmentsOut _tlIaugmentsOut in let _lhsOerrors :: Seq Error !_lhsOerrors = rule245 _hdIerrors _tlIerrors in let !_output = rule246 _hdIoutput _tlIoutput in let _lhsOoutput :: Productions !_lhsOoutput = rule247 _output in let !__result_ = T_Productions_vOut12 _lhsOallAttributes _lhsOaugmentsOut _lhsOerrors _lhsOoutput in __result_ ) v25 :: T_Productions_v25 v25 = \ !(T_Productions_vIn25 _lhsIaugmentsIn _lhsIforcedIrrefutables _lhsIinhMap _lhsInt _lhsIoptions _lhsIsynMap) -> ( let !_hdX22 = Control.Monad.Identity.runIdentity (attach_T_Production (arg_hd_)) in let !_tlX24 = Control.Monad.Identity.runIdentity (attach_T_Productions (arg_tl_)) in let !_hdOnt = rule252 _lhsInt in let !_tlOnt = rule259 _lhsInt in let !_hdOaugmentsIn = rule248 _lhsIaugmentsIn in let !_hdOinhMap = rule250 _lhsIinhMap in let !_hdOoptions = rule253 _lhsIoptions in let !_hdOsynMap = rule254 _lhsIsynMap in let !_tlOaugmentsIn = rule255 _lhsIaugmentsIn in let !_tlOinhMap = rule257 _lhsIinhMap in let !_tlOoptions = rule260 _lhsIoptions in let !_tlOsynMap = rule261 _lhsIsynMap in let !_hdOforcedIrrefutables = rule249 _lhsIforcedIrrefutables in let !_tlOforcedIrrefutables = rule256 _lhsIforcedIrrefutables in let !(T_Production_vOut30 _hdIallAttributes _hdIaugmentsOut _hdIerrors _hdIoutput) = inv_Production_s22 _hdX22 K_Production_v30 (T_Production_vIn30 _hdOaugmentsIn _hdOforcedIrrefutables _hdOinhMap _hdOnt _hdOoptions _hdOsynMap) in let !(T_Productions_vOut25 _tlIallAttributes _tlIaugmentsOut _tlIerrors _tlIoutput) = inv_Productions_s24 _tlX24 K_Productions_v25 (T_Productions_vIn25 _tlOaugmentsIn _tlOforcedIrrefutables _tlOinhMap _tlOnt _tlOoptions _tlOsynMap) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule243 _hdIallAttributes _tlIallAttributes in let _lhsOaugmentsOut :: Map ConstructorIdent (Map Identifier [Expression]) !_lhsOaugmentsOut = rule244 _hdIaugmentsOut _tlIaugmentsOut in let _lhsOerrors :: Seq Error !_lhsOerrors = rule245 _hdIerrors _tlIerrors in let !_output = rule246 _hdIoutput _tlIoutput in let _lhsOoutput :: Productions !_lhsOoutput = rule247 _output in let !__result_ = T_Productions_vOut25 _lhsOallAttributes _lhsOaugmentsOut _lhsOerrors _lhsOoutput in __result_ ) v39 :: T_Productions_v39 v39 = \ !(T_Productions_vIn39 _lhsInt) -> ( let !_hdX22 = Control.Monad.Identity.runIdentity (attach_T_Production (arg_hd_)) in let !_tlX24 = Control.Monad.Identity.runIdentity (attach_T_Productions (arg_tl_)) in let !_hdOnt = rule252 _lhsInt in let !_tlOnt = rule259 _lhsInt in let !(T_Production_vOut43 _hdIallAttributes _hdX52) = inv_Production_s22 _hdX22 K_Production_v43 (T_Production_vIn43 _hdOnt) in let !(T_Productions_vOut39 _tlIallAttributes _tlX50) = inv_Productions_s24 _tlX24 K_Productions_v39 (T_Productions_vIn39 _tlOnt) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule243 _hdIallAttributes _tlIallAttributes in let !__st_ = st50 _hdX52 _tlX50 !__result_ = T_Productions_vOut39 _lhsOallAttributes __st_ in __result_ ) in C_Productions_s24 k24 {-# NOINLINE st50 #-} st50 = \ !_hdX52 !_tlX50 -> let v40 :: T_Productions_v40 v40 = \ !(T_Productions_vIn40 _lhsIaugmentsIn _lhsIforcedIrrefutables _lhsIinhMap _lhsIoptions _lhsIsynMap) -> ( let !_hdOaugmentsIn = rule248 _lhsIaugmentsIn in let !_hdOinhMap = rule250 _lhsIinhMap in let !_hdOoptions = rule253 _lhsIoptions in let !_hdOsynMap = rule254 _lhsIsynMap in let !_tlOaugmentsIn = rule255 _lhsIaugmentsIn in let !_tlOinhMap = rule257 _lhsIinhMap in let !_tlOoptions = rule260 _lhsIoptions in let !_tlOsynMap = rule261 _lhsIsynMap in let !_hdOforcedIrrefutables = rule249 _lhsIforcedIrrefutables in let !_tlOforcedIrrefutables = rule256 _lhsIforcedIrrefutables in let !(T_Production_vOut44 _hdIaugmentsOut _hdIerrors _hdIoutput) = inv_Production_s52 _hdX52 (T_Production_vIn44 _hdOaugmentsIn _hdOforcedIrrefutables _hdOinhMap _hdOoptions _hdOsynMap) in let !(T_Productions_vOut40 _tlIaugmentsOut _tlIerrors _tlIoutput) = inv_Productions_s50 _tlX50 (T_Productions_vIn40 _tlOaugmentsIn _tlOforcedIrrefutables _tlOinhMap _tlOoptions _tlOsynMap) in let _lhsOaugmentsOut :: Map ConstructorIdent (Map Identifier [Expression]) !_lhsOaugmentsOut = rule244 _hdIaugmentsOut _tlIaugmentsOut in let _lhsOerrors :: Seq Error !_lhsOerrors = rule245 _hdIerrors _tlIerrors in let !_output = rule246 _hdIoutput _tlIoutput in let _lhsOoutput :: Productions !_lhsOoutput = rule247 _output in let !__result_ = T_Productions_vOut40 _lhsOaugmentsOut _lhsOerrors _lhsOoutput in __result_ ) in C_Productions_s50 v40 {-# NOINLINE[1] rule243 #-} rule243 = \ ((!_hdIallAttributes) :: AttrMap) ((!_tlIallAttributes) :: AttrMap) -> _hdIallAttributes `mergeAttributes` _tlIallAttributes {-# NOINLINE[1] rule244 #-} rule244 = \ ((!_hdIaugmentsOut) :: Map ConstructorIdent (Map Identifier [Expression])) ((!_tlIaugmentsOut) :: Map ConstructorIdent (Map Identifier [Expression])) -> _hdIaugmentsOut `Map.union` _tlIaugmentsOut {-# NOINLINE[1] rule245 #-} rule245 = \ ((!_hdIerrors) :: Seq Error) ((!_tlIerrors) :: Seq Error) -> _hdIerrors Seq.>< _tlIerrors {-# NOINLINE[1] rule246 #-} rule246 = \ ((!_hdIoutput) :: Production) ((!_tlIoutput) :: Productions) -> (:) _hdIoutput _tlIoutput {-# NOINLINE[1] rule247 #-} rule247 = \ !_output -> _output {-# NOINLINE[1] rule248 #-} rule248 = \ ((!_lhsIaugmentsIn) :: Map ConstructorIdent (Map Identifier [Expression])) -> _lhsIaugmentsIn {-# NOINLINE[1] rule249 #-} rule249 = \ ((!_lhsIforcedIrrefutables) :: AttrMap) -> _lhsIforcedIrrefutables {-# NOINLINE[1] rule250 #-} rule250 = \ ((!_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# NOINLINE[1] rule252 #-} rule252 = \ ((!_lhsInt) :: NontermIdent) -> _lhsInt {-# NOINLINE[1] rule253 #-} rule253 = \ ((!_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE[1] rule254 #-} rule254 = \ ((!_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# NOINLINE[1] rule255 #-} rule255 = \ ((!_lhsIaugmentsIn) :: Map ConstructorIdent (Map Identifier [Expression])) -> _lhsIaugmentsIn {-# NOINLINE[1] rule256 #-} rule256 = \ ((!_lhsIforcedIrrefutables) :: AttrMap) -> _lhsIforcedIrrefutables {-# NOINLINE[1] rule257 #-} rule257 = \ ((!_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# NOINLINE[1] rule259 #-} rule259 = \ ((!_lhsInt) :: NontermIdent) -> _lhsInt {-# NOINLINE[1] rule260 #-} rule260 = \ ((!_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE[1] rule261 #-} rule261 = \ ((!_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# NOINLINE sem_Productions_Nil #-} sem_Productions_Nil :: T_Productions sem_Productions_Nil = T_Productions (return st24) where {-# NOINLINE st24 #-} !st24 = let k24 :: K_Productions_s24 t -> t k24 K_Productions_v12 = v12 k24 K_Productions_v25 = v25 k24 K_Productions_v39 = v39 v12 :: T_Productions_v12 v12 = \ !(T_Productions_vIn12 _lhsIaugmentsIn _lhsIforcedIrrefutables _lhsIinhMap _lhsImainName _lhsInt _lhsIoptions _lhsIsynMap) -> ( let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule262 () in let _lhsOaugmentsOut :: Map ConstructorIdent (Map Identifier [Expression]) !_lhsOaugmentsOut = rule263 () in let _lhsOerrors :: Seq Error !_lhsOerrors = rule264 () in let !_output = rule265 () in let _lhsOoutput :: Productions !_lhsOoutput = rule266 _output in let !__result_ = T_Productions_vOut12 _lhsOallAttributes _lhsOaugmentsOut _lhsOerrors _lhsOoutput in __result_ ) v25 :: T_Productions_v25 v25 = \ !(T_Productions_vIn25 _lhsIaugmentsIn _lhsIforcedIrrefutables _lhsIinhMap _lhsInt _lhsIoptions _lhsIsynMap) -> ( let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule262 () in let _lhsOaugmentsOut :: Map ConstructorIdent (Map Identifier [Expression]) !_lhsOaugmentsOut = rule263 () in let _lhsOerrors :: Seq Error !_lhsOerrors = rule264 () in let !_output = rule265 () in let _lhsOoutput :: Productions !_lhsOoutput = rule266 _output in let !__result_ = T_Productions_vOut25 _lhsOallAttributes _lhsOaugmentsOut _lhsOerrors _lhsOoutput in __result_ ) v39 :: T_Productions_v39 v39 = \ !(T_Productions_vIn39 _lhsInt) -> ( let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule262 () in let !__st_ = st50 () !__result_ = T_Productions_vOut39 _lhsOallAttributes __st_ in __result_ ) in C_Productions_s24 k24 {-# NOINLINE st50 #-} st50 = \ (_ :: ()) -> let v40 :: T_Productions_v40 v40 = \ !(T_Productions_vIn40 _lhsIaugmentsIn _lhsIforcedIrrefutables _lhsIinhMap _lhsIoptions _lhsIsynMap) -> ( let _lhsOaugmentsOut :: Map ConstructorIdent (Map Identifier [Expression]) !_lhsOaugmentsOut = rule263 () in let _lhsOerrors :: Seq Error !_lhsOerrors = rule264 () in let !_output = rule265 () in let _lhsOoutput :: Productions !_lhsOoutput = rule266 _output in let !__result_ = T_Productions_vOut40 _lhsOaugmentsOut _lhsOerrors _lhsOoutput in __result_ ) in C_Productions_s50 v40 {-# NOINLINE[1] rule262 #-} rule262 = \ (_ :: ()) -> Map.empty {-# NOINLINE[1] rule263 #-} rule263 = \ (_ :: ()) -> Map.empty {-# NOINLINE[1] rule264 #-} rule264 = \ (_ :: ()) -> Seq.empty {-# NOINLINE[1] rule265 #-} rule265 = \ (_ :: ()) -> [] {-# NOINLINE[1] rule266 #-} rule266 = \ !_output -> _output -- Rule -------------------------------------------------------- -- wrapper data Inh_Rule = Inh_Rule { childInhs_Inh_Rule :: !([(Identifier, Identifier)]), childSyns_Inh_Rule :: !([(Identifier, Identifier)]), con_Inh_Rule :: !(ConstructorIdent), defs_Inh_Rule :: !(Set (Identifier, Identifier)), forcedIrrefutables_Inh_Rule :: !(AttrMap), nt_Inh_Rule :: !(NontermIdent), options_Inh_Rule :: !(Options) } data Syn_Rule = Syn_Rule { allAttributes_Syn_Rule :: !(AttrMap), defsCollect_Syn_Rule :: !(Set (Identifier, Identifier)), errors_Syn_Rule :: !(Seq Error), output_Syn_Rule :: !(Rule) } {-# INLINABLE wrap_Rule #-} wrap_Rule :: T_Rule -> Inh_Rule -> (Syn_Rule ) wrap_Rule !(T_Rule act) !(Inh_Rule _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt _lhsIoptions) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Rule_vIn13 _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt _lhsIoptions !(T_Rule_vOut13 _lhsOallAttributes _lhsOdefsCollect _lhsOerrors _lhsOoutput) <- return (inv_Rule_s26 sem K_Rule_v13 arg) return (Syn_Rule _lhsOallAttributes _lhsOdefsCollect _lhsOerrors _lhsOoutput) ) -- cata {-# INLINE sem_Rule #-} sem_Rule :: Rule -> T_Rule sem_Rule ( Rule !mbName_ pattern_ rhs_ !owrt_ !origin_ !explicit_ !pure_ !identity_ !mbError_ !eager_ ) = sem_Rule_Rule mbName_ ( sem_Pattern pattern_ ) ( sem_Expression rhs_ ) owrt_ origin_ explicit_ pure_ identity_ mbError_ eager_ -- semantic domain newtype T_Rule = T_Rule { attach_T_Rule :: Identity (T_Rule_s26 ) } data T_Rule_s26 where C_Rule_s26 :: { inv_Rule_s26 :: !(forall t. K_Rule_s26 t -> t) } -> T_Rule_s26 data T_Rule_s27 = C_Rule_s27 newtype T_Rule_s48 = C_Rule_s48 { inv_Rule_s48 :: (T_Rule_v37 ) } newtype T_Rule_s57 = C_Rule_s57 { inv_Rule_s57 :: (T_Rule_v54 ) } data K_Rule_s26 k where K_Rule_v13 :: K_Rule_s26 (T_Rule_v13 ) K_Rule_v36 :: K_Rule_s26 (T_Rule_v36 ) K_Rule_v53 :: K_Rule_s26 (T_Rule_v53 ) type T_Rule_v13 = (T_Rule_vIn13 ) -> (T_Rule_vOut13 ) data T_Rule_vIn13 = T_Rule_vIn13 !([(Identifier, Identifier)]) !([(Identifier, Identifier)]) !(ConstructorIdent) !(Set (Identifier, Identifier)) !(AttrMap) !(NontermIdent) !(Options) data T_Rule_vOut13 = T_Rule_vOut13 !(AttrMap) !(Set (Identifier, Identifier)) !(Seq Error) !(Rule) type T_Rule_v36 = (T_Rule_vIn36 ) -> (T_Rule_vOut36 ) data T_Rule_vIn36 = T_Rule_vIn36 !(ConstructorIdent) !(NontermIdent) data T_Rule_vOut36 = T_Rule_vOut36 !(AttrMap) !(Set (Identifier, Identifier)) !(T_Rule_s48 ) type T_Rule_v37 = (T_Rule_vIn37 ) -> (T_Rule_vOut37 ) data T_Rule_vIn37 = T_Rule_vIn37 !([(Identifier, Identifier)]) !([(Identifier, Identifier)]) !(Set (Identifier, Identifier)) !(AttrMap) !(Options) data T_Rule_vOut37 = T_Rule_vOut37 !(Seq Error) !(Rule) type T_Rule_v53 = (T_Rule_vIn53 ) -> (T_Rule_vOut53 ) data T_Rule_vIn53 = T_Rule_vIn53 !(ConstructorIdent) !(NontermIdent) data T_Rule_vOut53 = T_Rule_vOut53 !(AttrMap) !(T_Rule_s57 ) type T_Rule_v54 = (T_Rule_vIn54 ) -> (T_Rule_vOut54 ) data T_Rule_vIn54 = T_Rule_vIn54 data T_Rule_vOut54 = T_Rule_vOut54 !(Set (Identifier, Identifier)) !(T_Rule_s48 ) {-# NOINLINE sem_Rule_Rule #-} sem_Rule_Rule :: (Maybe Identifier) -> T_Pattern -> T_Expression -> (Bool) -> (String) -> (Bool) -> (Bool) -> (Bool) -> (Maybe Error) -> (Bool) -> T_Rule sem_Rule_Rule !arg_mbName_ arg_pattern_ arg_rhs_ !arg_owrt_ !arg_origin_ !arg_explicit_ !arg_pure_ !arg_identity_ !arg_mbError_ !arg_eager_ = T_Rule (return st26) where {-# NOINLINE st26 #-} !st26 = let k26 :: K_Rule_s26 t -> t k26 K_Rule_v13 = v13 k26 K_Rule_v36 = v36 k26 K_Rule_v53 = v53 v13 :: T_Rule_v13 v13 = \ !(T_Rule_vIn13 _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt _lhsIoptions) -> ( let !_patternX18 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pattern_)) in let !_rhsX4 = Control.Monad.Identity.runIdentity (attach_T_Expression (arg_rhs_)) in let !_patternOcon = rule275 _lhsIcon in let !_patternOnt = rule278 _lhsInt in let !_patternOchildInhs = rule273 _lhsIchildInhs in let !_patternOdefs = rule276 _lhsIdefs in let !_rhsOchildInhs = rule279 _lhsIchildInhs in let !_rhsOchildSyns = rule280 _lhsIchildSyns in let !_rhsOcon = rule281 _lhsIcon in let !_rhsOnt = rule282 _lhsInt in let !_rhsOoptions = rule283 _lhsIoptions in let !_patternOforcedIrrefutables = rule277 _lhsIforcedIrrefutables in let !(T_Pattern_vOut31 _patternIallAttributes _patternIdefsCollect _patternIerrors _patternIoutput) = inv_Pattern_s18 _patternX18 K_Pattern_v31 (T_Pattern_vIn31 _patternOchildInhs _patternOcon _patternOdefs _patternOforcedIrrefutables _patternOnt) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule268 _patternIallAttributes in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule269 _patternIdefsCollect in let !_ruleDescr = rule267 _lhsIcon _lhsInt _patternIdefsCollect in let !_rhsOruleDescr = rule284 _ruleDescr in let !(T_Expression_vOut2 _rhsIerrors _rhsIoutput) = inv_Expression_s4 _rhsX4 (T_Expression_vIn2 _rhsOchildInhs _rhsOchildSyns _rhsOcon _rhsOnt _rhsOoptions _rhsOruleDescr) in let _lhsOerrors :: Seq Error !_lhsOerrors = rule270 _patternIerrors _rhsIerrors in let !_output = rule271 _patternIoutput _rhsIoutput arg_eager_ arg_explicit_ arg_identity_ arg_mbError_ arg_mbName_ arg_origin_ arg_owrt_ arg_pure_ in let _lhsOoutput :: Rule !_lhsOoutput = rule272 _output in let !__result_ = T_Rule_vOut13 _lhsOallAttributes _lhsOdefsCollect _lhsOerrors _lhsOoutput in __result_ ) v36 :: T_Rule_v36 v36 = \ !(T_Rule_vIn36 _lhsIcon _lhsInt) -> ( let !_patternX18 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pattern_)) in let !_patternOcon = rule275 _lhsIcon in let !_patternOnt = rule278 _lhsInt in let !(T_Pattern_vOut41 _patternIallAttributes _patternIdefsCollect _patternX51) = inv_Pattern_s18 _patternX18 K_Pattern_v41 (T_Pattern_vIn41 _patternOcon _patternOnt) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule268 _patternIallAttributes in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule269 _patternIdefsCollect in let !__st_ = st48 _lhsIcon _lhsInt _patternIdefsCollect _patternX51 !__result_ = T_Rule_vOut36 _lhsOallAttributes _lhsOdefsCollect __st_ in __result_ ) v53 :: T_Rule_v53 v53 = \ !(T_Rule_vIn53 _lhsIcon _lhsInt) -> ( let !_patternX18 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pattern_)) in let !_patternOcon = rule275 _lhsIcon in let !_patternOnt = rule278 _lhsInt in let !(T_Pattern_vOut55 _patternIallAttributes _patternX58) = inv_Pattern_s18 _patternX18 K_Pattern_v55 (T_Pattern_vIn55 _patternOcon _patternOnt) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule268 _patternIallAttributes in let !__st_ = st57 _lhsIcon _lhsInt _patternX58 !__result_ = T_Rule_vOut53 _lhsOallAttributes __st_ in __result_ ) in C_Rule_s26 k26 {-# NOINLINE st48 #-} st48 = \ ((!_lhsIcon) :: ConstructorIdent) ((!_lhsInt) :: NontermIdent) ((!_patternIdefsCollect) :: Set (Identifier, Identifier)) !_patternX51 -> let v37 :: T_Rule_v37 v37 = \ !(T_Rule_vIn37 _lhsIchildInhs _lhsIchildSyns _lhsIdefs _lhsIforcedIrrefutables _lhsIoptions) -> ( let !_rhsOcon = rule281 _lhsIcon in let !_rhsOnt = rule282 _lhsInt in let !_ruleDescr = rule267 _lhsIcon _lhsInt _patternIdefsCollect in let !_rhsX4 = Control.Monad.Identity.runIdentity (attach_T_Expression (arg_rhs_)) in let !_patternOchildInhs = rule273 _lhsIchildInhs in let !_patternOdefs = rule276 _lhsIdefs in let !_rhsOchildInhs = rule279 _lhsIchildInhs in let !_rhsOchildSyns = rule280 _lhsIchildSyns in let !_rhsOoptions = rule283 _lhsIoptions in let !_rhsOruleDescr = rule284 _ruleDescr in let !_patternOforcedIrrefutables = rule277 _lhsIforcedIrrefutables in let !(T_Pattern_vOut42 _patternIerrors _patternIoutput) = inv_Pattern_s51 _patternX51 (T_Pattern_vIn42 _patternOchildInhs _patternOdefs _patternOforcedIrrefutables) in let !(T_Expression_vOut2 _rhsIerrors _rhsIoutput) = inv_Expression_s4 _rhsX4 (T_Expression_vIn2 _rhsOchildInhs _rhsOchildSyns _rhsOcon _rhsOnt _rhsOoptions _rhsOruleDescr) in let _lhsOerrors :: Seq Error !_lhsOerrors = rule270 _patternIerrors _rhsIerrors in let !_output = rule271 _patternIoutput _rhsIoutput arg_eager_ arg_explicit_ arg_identity_ arg_mbError_ arg_mbName_ arg_origin_ arg_owrt_ arg_pure_ in let _lhsOoutput :: Rule !_lhsOoutput = rule272 _output in let !__result_ = T_Rule_vOut37 _lhsOerrors _lhsOoutput in __result_ ) in C_Rule_s48 v37 {-# NOINLINE st57 #-} st57 = \ ((!_lhsIcon) :: ConstructorIdent) ((!_lhsInt) :: NontermIdent) !_patternX58 -> let v54 :: T_Rule_v54 v54 = \ !(T_Rule_vIn54 ) -> ( let !(T_Pattern_vOut56 _patternIdefsCollect _patternX51) = inv_Pattern_s58 _patternX58 (T_Pattern_vIn56 ) in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule269 _patternIdefsCollect in let !__st_ = st48 _lhsIcon _lhsInt _patternIdefsCollect _patternX51 !__result_ = T_Rule_vOut54 _lhsOdefsCollect __st_ in __result_ ) in C_Rule_s57 v54 {-# NOINLINE[1] rule267 #-} {-# LINE 172 "./src-ag/Desugar.ag" #-} rule267 = \ ((!_lhsIcon) :: ConstructorIdent) ((!_lhsInt) :: NontermIdent) ((!_patternIdefsCollect) :: Set (Identifier, Identifier)) -> {-# LINE 172 "./src-ag/Desugar.ag" #-} show _lhsInt ++ " :: " ++ show _lhsIcon ++ " :: " ++ (concat $ intersperse "," $ map (\(f,a) -> show f ++ "." ++ show a) $ Set.toList _patternIdefsCollect) {-# LINE 4003 "dist/build/Desugar.hs"#-} {-# NOINLINE[1] rule268 #-} rule268 = \ ((!_patternIallAttributes) :: AttrMap) -> _patternIallAttributes {-# NOINLINE[1] rule269 #-} rule269 = \ ((!_patternIdefsCollect) :: Set (Identifier, Identifier)) -> _patternIdefsCollect {-# NOINLINE[1] rule270 #-} rule270 = \ ((!_patternIerrors) :: Seq Error) ((!_rhsIerrors) :: Seq Error) -> _patternIerrors Seq.>< _rhsIerrors {-# NOINLINE[1] rule271 #-} rule271 = \ ((!_patternIoutput) :: Pattern) ((!_rhsIoutput) :: Expression) !eager_ !explicit_ !identity_ !mbError_ !mbName_ !origin_ !owrt_ !pure_ -> Rule mbName_ _patternIoutput _rhsIoutput owrt_ origin_ explicit_ pure_ identity_ mbError_ eager_ {-# NOINLINE[1] rule272 #-} rule272 = \ !_output -> _output {-# NOINLINE[1] rule273 #-} rule273 = \ ((!_lhsIchildInhs) :: [(Identifier, Identifier)]) -> _lhsIchildInhs {-# NOINLINE[1] rule275 #-} rule275 = \ ((!_lhsIcon) :: ConstructorIdent) -> _lhsIcon {-# NOINLINE[1] rule276 #-} rule276 = \ ((!_lhsIdefs) :: Set (Identifier, Identifier)) -> _lhsIdefs {-# NOINLINE[1] rule277 #-} rule277 = \ ((!_lhsIforcedIrrefutables) :: AttrMap) -> _lhsIforcedIrrefutables {-# NOINLINE[1] rule278 #-} rule278 = \ ((!_lhsInt) :: NontermIdent) -> _lhsInt {-# NOINLINE[1] rule279 #-} rule279 = \ ((!_lhsIchildInhs) :: [(Identifier, Identifier)]) -> _lhsIchildInhs {-# NOINLINE[1] rule280 #-} rule280 = \ ((!_lhsIchildSyns) :: [(Identifier, Identifier)]) -> _lhsIchildSyns {-# NOINLINE[1] rule281 #-} rule281 = \ ((!_lhsIcon) :: ConstructorIdent) -> _lhsIcon {-# NOINLINE[1] rule282 #-} rule282 = \ ((!_lhsInt) :: NontermIdent) -> _lhsInt {-# NOINLINE[1] rule283 #-} rule283 = \ ((!_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE[1] rule284 #-} rule284 = \ !_ruleDescr -> _ruleDescr -- Rules ------------------------------------------------------- -- wrapper data Inh_Rules = Inh_Rules { childInhs_Inh_Rules :: !([(Identifier, Identifier)]), childSyns_Inh_Rules :: !([(Identifier, Identifier)]), con_Inh_Rules :: !(ConstructorIdent), defs_Inh_Rules :: !(Set (Identifier, Identifier)), forcedIrrefutables_Inh_Rules :: !(AttrMap), nt_Inh_Rules :: !(NontermIdent), options_Inh_Rules :: !(Options) } data Syn_Rules = Syn_Rules { allAttributes_Syn_Rules :: !(AttrMap), defsCollect_Syn_Rules :: !(Set (Identifier, Identifier)), errors_Syn_Rules :: !(Seq Error), output_Syn_Rules :: !(Rules) } {-# INLINABLE wrap_Rules #-} wrap_Rules :: T_Rules -> Inh_Rules -> (Syn_Rules ) wrap_Rules !(T_Rules act) !(Inh_Rules _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt _lhsIoptions) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Rules_vIn14 _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt _lhsIoptions !(T_Rules_vOut14 _lhsOallAttributes _lhsOdefsCollect _lhsOerrors _lhsOoutput) <- return (inv_Rules_s28 sem K_Rules_v14 arg) return (Syn_Rules _lhsOallAttributes _lhsOdefsCollect _lhsOerrors _lhsOoutput) ) -- cata {-# NOINLINE sem_Rules #-} sem_Rules :: Rules -> T_Rules sem_Rules list = Prelude.foldr sem_Rules_Cons sem_Rules_Nil (Prelude.map sem_Rule list) -- semantic domain newtype T_Rules = T_Rules { attach_T_Rules :: Identity (T_Rules_s28 ) } data T_Rules_s28 where C_Rules_s28 :: { inv_Rules_s28 :: !(forall t. K_Rules_s28 t -> t) } -> T_Rules_s28 data T_Rules_s29 = C_Rules_s29 newtype T_Rules_s43 = C_Rules_s43 { inv_Rules_s43 :: (T_Rules_v29 ) } newtype T_Rules_s55 = C_Rules_s55 { inv_Rules_s55 :: (T_Rules_v50 ) } data K_Rules_s28 k where K_Rules_v14 :: K_Rules_s28 (T_Rules_v14 ) K_Rules_v28 :: K_Rules_s28 (T_Rules_v28 ) K_Rules_v49 :: K_Rules_s28 (T_Rules_v49 ) type T_Rules_v14 = (T_Rules_vIn14 ) -> (T_Rules_vOut14 ) data T_Rules_vIn14 = T_Rules_vIn14 !([(Identifier, Identifier)]) !([(Identifier, Identifier)]) !(ConstructorIdent) !(Set (Identifier, Identifier)) !(AttrMap) !(NontermIdent) !(Options) data T_Rules_vOut14 = T_Rules_vOut14 !(AttrMap) !(Set (Identifier, Identifier)) !(Seq Error) !(Rules) type T_Rules_v28 = (T_Rules_vIn28 ) -> (T_Rules_vOut28 ) data T_Rules_vIn28 = T_Rules_vIn28 !(ConstructorIdent) !(NontermIdent) data T_Rules_vOut28 = T_Rules_vOut28 !(AttrMap) !(Set (Identifier, Identifier)) !(T_Rules_s43 ) type T_Rules_v29 = (T_Rules_vIn29 ) -> (T_Rules_vOut29 ) data T_Rules_vIn29 = T_Rules_vIn29 !([(Identifier, Identifier)]) !([(Identifier, Identifier)]) !(Set (Identifier, Identifier)) !(AttrMap) !(Options) data T_Rules_vOut29 = T_Rules_vOut29 !(Seq Error) !(Rules) type T_Rules_v49 = (T_Rules_vIn49 ) -> (T_Rules_vOut49 ) data T_Rules_vIn49 = T_Rules_vIn49 !(ConstructorIdent) !(NontermIdent) data T_Rules_vOut49 = T_Rules_vOut49 !(AttrMap) !(T_Rules_s55 ) type T_Rules_v50 = (T_Rules_vIn50 ) -> (T_Rules_vOut50 ) data T_Rules_vIn50 = T_Rules_vIn50 data T_Rules_vOut50 = T_Rules_vOut50 !(Set (Identifier, Identifier)) !(T_Rules_s43 ) {-# NOINLINE sem_Rules_Cons #-} sem_Rules_Cons :: T_Rule -> T_Rules -> T_Rules sem_Rules_Cons arg_hd_ arg_tl_ = T_Rules (return st28) where {-# NOINLINE st28 #-} !st28 = let k28 :: K_Rules_s28 t -> t k28 K_Rules_v14 = v14 k28 K_Rules_v28 = v28 k28 K_Rules_v49 = v49 v14 :: T_Rules_v14 v14 = \ !(T_Rules_vIn14 _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt _lhsIoptions) -> ( let !_hdX26 = Control.Monad.Identity.runIdentity (attach_T_Rule (arg_hd_)) in let !_tlX28 = Control.Monad.Identity.runIdentity (attach_T_Rules (arg_tl_)) in let !_hdOcon = rule292 _lhsIcon in let !_hdOnt = rule295 _lhsInt in let !_tlOcon = rule299 _lhsIcon in let !_tlOnt = rule302 _lhsInt in let !_hdOchildInhs = rule290 _lhsIchildInhs in let !_hdOchildSyns = rule291 _lhsIchildSyns in let !_hdOdefs = rule293 _lhsIdefs in let !_hdOoptions = rule296 _lhsIoptions in let !_tlOchildInhs = rule297 _lhsIchildInhs in let !_tlOchildSyns = rule298 _lhsIchildSyns in let !_tlOdefs = rule300 _lhsIdefs in let !_tlOoptions = rule303 _lhsIoptions in let !_hdOforcedIrrefutables = rule294 _lhsIforcedIrrefutables in let !_tlOforcedIrrefutables = rule301 _lhsIforcedIrrefutables in let !(T_Rule_vOut13 _hdIallAttributes _hdIdefsCollect _hdIerrors _hdIoutput) = inv_Rule_s26 _hdX26 K_Rule_v13 (T_Rule_vIn13 _hdOchildInhs _hdOchildSyns _hdOcon _hdOdefs _hdOforcedIrrefutables _hdOnt _hdOoptions) in let !(T_Rules_vOut14 _tlIallAttributes _tlIdefsCollect _tlIerrors _tlIoutput) = inv_Rules_s28 _tlX28 K_Rules_v14 (T_Rules_vIn14 _tlOchildInhs _tlOchildSyns _tlOcon _tlOdefs _tlOforcedIrrefutables _tlOnt _tlOoptions) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule285 _hdIallAttributes _tlIallAttributes in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule286 _hdIdefsCollect _tlIdefsCollect in let _lhsOerrors :: Seq Error !_lhsOerrors = rule287 _hdIerrors _tlIerrors in let !_output = rule288 _hdIoutput _tlIoutput in let _lhsOoutput :: Rules !_lhsOoutput = rule289 _output in let !__result_ = T_Rules_vOut14 _lhsOallAttributes _lhsOdefsCollect _lhsOerrors _lhsOoutput in __result_ ) v28 :: T_Rules_v28 v28 = \ !(T_Rules_vIn28 _lhsIcon _lhsInt) -> ( let !_hdX26 = Control.Monad.Identity.runIdentity (attach_T_Rule (arg_hd_)) in let !_tlX28 = Control.Monad.Identity.runIdentity (attach_T_Rules (arg_tl_)) in let !_hdOcon = rule292 _lhsIcon in let !_hdOnt = rule295 _lhsInt in let !_tlOcon = rule299 _lhsIcon in let !_tlOnt = rule302 _lhsInt in let !(T_Rule_vOut36 _hdIallAttributes _hdIdefsCollect _hdX48) = inv_Rule_s26 _hdX26 K_Rule_v36 (T_Rule_vIn36 _hdOcon _hdOnt) in let !(T_Rules_vOut28 _tlIallAttributes _tlIdefsCollect _tlX43) = inv_Rules_s28 _tlX28 K_Rules_v28 (T_Rules_vIn28 _tlOcon _tlOnt) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule285 _hdIallAttributes _tlIallAttributes in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule286 _hdIdefsCollect _tlIdefsCollect in let !__st_ = st43 _hdX48 _tlX43 !__result_ = T_Rules_vOut28 _lhsOallAttributes _lhsOdefsCollect __st_ in __result_ ) v49 :: T_Rules_v49 v49 = \ !(T_Rules_vIn49 _lhsIcon _lhsInt) -> ( let !_hdX26 = Control.Monad.Identity.runIdentity (attach_T_Rule (arg_hd_)) in let !_tlX28 = Control.Monad.Identity.runIdentity (attach_T_Rules (arg_tl_)) in let !_hdOcon = rule292 _lhsIcon in let !_hdOnt = rule295 _lhsInt in let !_tlOcon = rule299 _lhsIcon in let !_tlOnt = rule302 _lhsInt in let !(T_Rule_vOut53 _hdIallAttributes _hdX57) = inv_Rule_s26 _hdX26 K_Rule_v53 (T_Rule_vIn53 _hdOcon _hdOnt) in let !(T_Rules_vOut49 _tlIallAttributes _tlX55) = inv_Rules_s28 _tlX28 K_Rules_v49 (T_Rules_vIn49 _tlOcon _tlOnt) in let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule285 _hdIallAttributes _tlIallAttributes in let !__st_ = st55 _hdX57 _tlX55 !__result_ = T_Rules_vOut49 _lhsOallAttributes __st_ in __result_ ) in C_Rules_s28 k28 {-# NOINLINE st43 #-} st43 = \ !_hdX48 !_tlX43 -> let v29 :: T_Rules_v29 v29 = \ !(T_Rules_vIn29 _lhsIchildInhs _lhsIchildSyns _lhsIdefs _lhsIforcedIrrefutables _lhsIoptions) -> ( let !_hdOchildInhs = rule290 _lhsIchildInhs in let !_hdOchildSyns = rule291 _lhsIchildSyns in let !_hdOdefs = rule293 _lhsIdefs in let !_hdOoptions = rule296 _lhsIoptions in let !_tlOchildInhs = rule297 _lhsIchildInhs in let !_tlOchildSyns = rule298 _lhsIchildSyns in let !_tlOdefs = rule300 _lhsIdefs in let !_tlOoptions = rule303 _lhsIoptions in let !_hdOforcedIrrefutables = rule294 _lhsIforcedIrrefutables in let !_tlOforcedIrrefutables = rule301 _lhsIforcedIrrefutables in let !(T_Rule_vOut37 _hdIerrors _hdIoutput) = inv_Rule_s48 _hdX48 (T_Rule_vIn37 _hdOchildInhs _hdOchildSyns _hdOdefs _hdOforcedIrrefutables _hdOoptions) in let !(T_Rules_vOut29 _tlIerrors _tlIoutput) = inv_Rules_s43 _tlX43 (T_Rules_vIn29 _tlOchildInhs _tlOchildSyns _tlOdefs _tlOforcedIrrefutables _tlOoptions) in let _lhsOerrors :: Seq Error !_lhsOerrors = rule287 _hdIerrors _tlIerrors in let !_output = rule288 _hdIoutput _tlIoutput in let _lhsOoutput :: Rules !_lhsOoutput = rule289 _output in let !__result_ = T_Rules_vOut29 _lhsOerrors _lhsOoutput in __result_ ) in C_Rules_s43 v29 {-# NOINLINE st55 #-} st55 = \ !_hdX57 !_tlX55 -> let v50 :: T_Rules_v50 v50 = \ !(T_Rules_vIn50 ) -> ( let !(T_Rule_vOut54 _hdIdefsCollect _hdX48) = inv_Rule_s57 _hdX57 (T_Rule_vIn54 ) in let !(T_Rules_vOut50 _tlIdefsCollect _tlX43) = inv_Rules_s55 _tlX55 (T_Rules_vIn50 ) in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule286 _hdIdefsCollect _tlIdefsCollect in let !__st_ = st43 _hdX48 _tlX43 !__result_ = T_Rules_vOut50 _lhsOdefsCollect __st_ in __result_ ) in C_Rules_s55 v50 {-# NOINLINE[1] rule285 #-} rule285 = \ ((!_hdIallAttributes) :: AttrMap) ((!_tlIallAttributes) :: AttrMap) -> _hdIallAttributes `mergeAttributes` _tlIallAttributes {-# NOINLINE[1] rule286 #-} rule286 = \ ((!_hdIdefsCollect) :: Set (Identifier, Identifier)) ((!_tlIdefsCollect) :: Set (Identifier, Identifier)) -> _hdIdefsCollect `Set.union` _tlIdefsCollect {-# NOINLINE[1] rule287 #-} rule287 = \ ((!_hdIerrors) :: Seq Error) ((!_tlIerrors) :: Seq Error) -> _hdIerrors Seq.>< _tlIerrors {-# NOINLINE[1] rule288 #-} rule288 = \ ((!_hdIoutput) :: Rule) ((!_tlIoutput) :: Rules) -> (:) _hdIoutput _tlIoutput {-# NOINLINE[1] rule289 #-} rule289 = \ !_output -> _output {-# NOINLINE[1] rule290 #-} rule290 = \ ((!_lhsIchildInhs) :: [(Identifier, Identifier)]) -> _lhsIchildInhs {-# NOINLINE[1] rule291 #-} rule291 = \ ((!_lhsIchildSyns) :: [(Identifier, Identifier)]) -> _lhsIchildSyns {-# NOINLINE[1] rule292 #-} rule292 = \ ((!_lhsIcon) :: ConstructorIdent) -> _lhsIcon {-# NOINLINE[1] rule293 #-} rule293 = \ ((!_lhsIdefs) :: Set (Identifier, Identifier)) -> _lhsIdefs {-# NOINLINE[1] rule294 #-} rule294 = \ ((!_lhsIforcedIrrefutables) :: AttrMap) -> _lhsIforcedIrrefutables {-# NOINLINE[1] rule295 #-} rule295 = \ ((!_lhsInt) :: NontermIdent) -> _lhsInt {-# NOINLINE[1] rule296 #-} rule296 = \ ((!_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE[1] rule297 #-} rule297 = \ ((!_lhsIchildInhs) :: [(Identifier, Identifier)]) -> _lhsIchildInhs {-# NOINLINE[1] rule298 #-} rule298 = \ ((!_lhsIchildSyns) :: [(Identifier, Identifier)]) -> _lhsIchildSyns {-# NOINLINE[1] rule299 #-} rule299 = \ ((!_lhsIcon) :: ConstructorIdent) -> _lhsIcon {-# NOINLINE[1] rule300 #-} rule300 = \ ((!_lhsIdefs) :: Set (Identifier, Identifier)) -> _lhsIdefs {-# NOINLINE[1] rule301 #-} rule301 = \ ((!_lhsIforcedIrrefutables) :: AttrMap) -> _lhsIforcedIrrefutables {-# NOINLINE[1] rule302 #-} rule302 = \ ((!_lhsInt) :: NontermIdent) -> _lhsInt {-# NOINLINE[1] rule303 #-} rule303 = \ ((!_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Rules_Nil #-} sem_Rules_Nil :: T_Rules sem_Rules_Nil = T_Rules (return st28) where {-# NOINLINE st28 #-} !st28 = let k28 :: K_Rules_s28 t -> t k28 K_Rules_v14 = v14 k28 K_Rules_v28 = v28 k28 K_Rules_v49 = v49 v14 :: T_Rules_v14 v14 = \ !(T_Rules_vIn14 _lhsIchildInhs _lhsIchildSyns _lhsIcon _lhsIdefs _lhsIforcedIrrefutables _lhsInt _lhsIoptions) -> ( let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule304 () in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule305 () in let _lhsOerrors :: Seq Error !_lhsOerrors = rule306 () in let !_output = rule307 () in let _lhsOoutput :: Rules !_lhsOoutput = rule308 _output in let !__result_ = T_Rules_vOut14 _lhsOallAttributes _lhsOdefsCollect _lhsOerrors _lhsOoutput in __result_ ) v28 :: T_Rules_v28 v28 = \ !(T_Rules_vIn28 _lhsIcon _lhsInt) -> ( let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule304 () in let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule305 () in let !__st_ = st43 () !__result_ = T_Rules_vOut28 _lhsOallAttributes _lhsOdefsCollect __st_ in __result_ ) v49 :: T_Rules_v49 v49 = \ !(T_Rules_vIn49 _lhsIcon _lhsInt) -> ( let _lhsOallAttributes :: AttrMap !_lhsOallAttributes = rule304 () in let !__st_ = st55 () !__result_ = T_Rules_vOut49 _lhsOallAttributes __st_ in __result_ ) in C_Rules_s28 k28 {-# NOINLINE st43 #-} st43 = \ (_ :: ()) -> let v29 :: T_Rules_v29 v29 = \ !(T_Rules_vIn29 _lhsIchildInhs _lhsIchildSyns _lhsIdefs _lhsIforcedIrrefutables _lhsIoptions) -> ( let _lhsOerrors :: Seq Error !_lhsOerrors = rule306 () in let !_output = rule307 () in let _lhsOoutput :: Rules !_lhsOoutput = rule308 _output in let !__result_ = T_Rules_vOut29 _lhsOerrors _lhsOoutput in __result_ ) in C_Rules_s43 v29 {-# NOINLINE st55 #-} st55 = \ (_ :: ()) -> let v50 :: T_Rules_v50 v50 = \ !(T_Rules_vIn50 ) -> ( let _lhsOdefsCollect :: Set (Identifier, Identifier) !_lhsOdefsCollect = rule305 () in let !__st_ = st43 () !__result_ = T_Rules_vOut50 _lhsOdefsCollect __st_ in __result_ ) in C_Rules_s55 v50 {-# NOINLINE[1] rule304 #-} rule304 = \ (_ :: ()) -> Map.empty {-# NOINLINE[1] rule305 #-} rule305 = \ (_ :: ()) -> Set.empty {-# NOINLINE[1] rule306 #-} rule306 = \ (_ :: ()) -> Seq.empty {-# NOINLINE[1] rule307 #-} rule307 = \ (_ :: ()) -> [] {-# NOINLINE[1] rule308 #-} rule308 = \ !_output -> _output -- TypeSig ----------------------------------------------------- -- wrapper data Inh_TypeSig = Inh_TypeSig { } data Syn_TypeSig = Syn_TypeSig { output_Syn_TypeSig :: !(TypeSig) } {-# INLINABLE wrap_TypeSig #-} wrap_TypeSig :: T_TypeSig -> Inh_TypeSig -> (Syn_TypeSig ) wrap_TypeSig !(T_TypeSig act) !(Inh_TypeSig ) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_TypeSig_vIn15 !(T_TypeSig_vOut15 _lhsOoutput) <- return (inv_TypeSig_s30 sem arg) return (Syn_TypeSig _lhsOoutput) ) -- cata {-# INLINE sem_TypeSig #-} sem_TypeSig :: TypeSig -> T_TypeSig sem_TypeSig ( TypeSig !name_ !tp_ ) = sem_TypeSig_TypeSig name_ tp_ -- semantic domain newtype T_TypeSig = T_TypeSig { attach_T_TypeSig :: Identity (T_TypeSig_s30 ) } newtype T_TypeSig_s30 = C_TypeSig_s30 { inv_TypeSig_s30 :: (T_TypeSig_v15 ) } data T_TypeSig_s31 = C_TypeSig_s31 type T_TypeSig_v15 = (T_TypeSig_vIn15 ) -> (T_TypeSig_vOut15 ) data T_TypeSig_vIn15 = T_TypeSig_vIn15 data T_TypeSig_vOut15 = T_TypeSig_vOut15 !(TypeSig) {-# NOINLINE sem_TypeSig_TypeSig #-} sem_TypeSig_TypeSig :: (Identifier) -> (Type) -> T_TypeSig sem_TypeSig_TypeSig !arg_name_ !arg_tp_ = T_TypeSig (return st30) where {-# NOINLINE st30 #-} !st30 = let v15 :: T_TypeSig_v15 v15 = \ !(T_TypeSig_vIn15 ) -> ( let !_output = rule309 arg_name_ arg_tp_ in let _lhsOoutput :: TypeSig !_lhsOoutput = rule310 _output in let !__result_ = T_TypeSig_vOut15 _lhsOoutput in __result_ ) in C_TypeSig_s30 v15 {-# INLINE rule309 #-} rule309 = \ !name_ !tp_ -> TypeSig name_ tp_ {-# INLINE rule310 #-} rule310 = \ !_output -> _output -- TypeSigs ---------------------------------------------------- -- wrapper data Inh_TypeSigs = Inh_TypeSigs { } data Syn_TypeSigs = Syn_TypeSigs { output_Syn_TypeSigs :: !(TypeSigs) } {-# INLINABLE wrap_TypeSigs #-} wrap_TypeSigs :: T_TypeSigs -> Inh_TypeSigs -> (Syn_TypeSigs ) wrap_TypeSigs !(T_TypeSigs act) !(Inh_TypeSigs ) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_TypeSigs_vIn16 !(T_TypeSigs_vOut16 _lhsOoutput) <- return (inv_TypeSigs_s32 sem arg) return (Syn_TypeSigs _lhsOoutput) ) -- cata {-# NOINLINE sem_TypeSigs #-} sem_TypeSigs :: TypeSigs -> T_TypeSigs sem_TypeSigs list = Prelude.foldr sem_TypeSigs_Cons sem_TypeSigs_Nil (Prelude.map sem_TypeSig list) -- semantic domain newtype T_TypeSigs = T_TypeSigs { attach_T_TypeSigs :: Identity (T_TypeSigs_s32 ) } newtype T_TypeSigs_s32 = C_TypeSigs_s32 { inv_TypeSigs_s32 :: (T_TypeSigs_v16 ) } data T_TypeSigs_s33 = C_TypeSigs_s33 type T_TypeSigs_v16 = (T_TypeSigs_vIn16 ) -> (T_TypeSigs_vOut16 ) data T_TypeSigs_vIn16 = T_TypeSigs_vIn16 data T_TypeSigs_vOut16 = T_TypeSigs_vOut16 !(TypeSigs) {-# NOINLINE sem_TypeSigs_Cons #-} sem_TypeSigs_Cons :: T_TypeSig -> T_TypeSigs -> T_TypeSigs sem_TypeSigs_Cons arg_hd_ arg_tl_ = T_TypeSigs (return st32) where {-# NOINLINE st32 #-} !st32 = let v16 :: T_TypeSigs_v16 v16 = \ !(T_TypeSigs_vIn16 ) -> ( let !_hdX30 = Control.Monad.Identity.runIdentity (attach_T_TypeSig (arg_hd_)) in let !_tlX32 = Control.Monad.Identity.runIdentity (attach_T_TypeSigs (arg_tl_)) in let !(T_TypeSig_vOut15 _hdIoutput) = inv_TypeSig_s30 _hdX30 (T_TypeSig_vIn15 ) in let !(T_TypeSigs_vOut16 _tlIoutput) = inv_TypeSigs_s32 _tlX32 (T_TypeSigs_vIn16 ) in let !_output = rule311 _hdIoutput _tlIoutput in let _lhsOoutput :: TypeSigs !_lhsOoutput = rule312 _output in let !__result_ = T_TypeSigs_vOut16 _lhsOoutput in __result_ ) in C_TypeSigs_s32 v16 {-# INLINE rule311 #-} rule311 = \ ((!_hdIoutput) :: TypeSig) ((!_tlIoutput) :: TypeSigs) -> (:) _hdIoutput _tlIoutput {-# INLINE rule312 #-} rule312 = \ !_output -> _output {-# NOINLINE sem_TypeSigs_Nil #-} sem_TypeSigs_Nil :: T_TypeSigs sem_TypeSigs_Nil = T_TypeSigs (return st32) where {-# NOINLINE st32 #-} !st32 = let v16 :: T_TypeSigs_v16 v16 = \ !(T_TypeSigs_vIn16 ) -> ( let !_output = rule313 () in let _lhsOoutput :: TypeSigs !_lhsOoutput = rule314 _output in let !__result_ = T_TypeSigs_vOut16 _lhsOoutput in __result_ ) in C_TypeSigs_s32 v16 {-# INLINE rule313 #-} rule313 = \ (_ :: ()) -> [] {-# INLINE rule314 #-} rule314 = \ !_output -> _output uuagc-0.9.42.3/src-generated/ErrorMessages.hs000644 000765 000024 00000021431 12127045231 022707 0ustar00jeroenbransenstaff000000 000000 -- UUAGC 0.9.42.3 (src-ag/ErrorMessages.ag) module ErrorMessages where {-# LINE 2 "./src-ag/ErrorMessages.ag" #-} import UU.Scanner.Position(Pos) import Pretty import CodeSyntax import CommonTypes {-# LINE 12 "dist/build/ErrorMessages.hs" #-} -- Error ------------------------------------------------------- {- alternatives: alternative ParserError: child pos : {Pos} child problem : {String} child action : {String} alternative HsParseError: child pos : {Pos} child msg : {String} alternative DupAlt: child nt : {NontermIdent} child con : {ConstructorIdent} child occ1 : {ConstructorIdent} alternative DupSynonym: child nt : {NontermIdent} child occ1 : {NontermIdent} alternative DupSet: child name : {NontermIdent} child occ1 : {NontermIdent} alternative DupInhAttr: child nt : {NontermIdent} child attr : {Identifier} child occ1 : {Identifier} alternative DupSynAttr: child nt : {NontermIdent} child attr : {Identifier} child occ1 : {Identifier} alternative DupChild: child nt : {NontermIdent} child con : {ConstructorIdent} child name : {Identifier} child occ1 : {Identifier} alternative DupRule: child nt : {NontermIdent} child con : {ConstructorIdent} child field : {Identifier} child attr : {Identifier} child occ1 : {Identifier} alternative DupRuleName: child nt : {NontermIdent} child con : {ConstructorIdent} child nm : {Identifier} alternative DupSig: child nt : {NontermIdent} child con : {ConstructorIdent} child attr : {Identifier} alternative UndefNont: child nt : {NontermIdent} alternative UndefAlt: child nt : {NontermIdent} child con : {ConstructorIdent} alternative UndefChild: child nt : {NontermIdent} child con : {ConstructorIdent} child name : {Identifier} alternative MissingRule: child nt : {NontermIdent} child con : {ConstructorIdent} child field : {Identifier} child attr : {Identifier} alternative MissingNamedRule: child nt : {NontermIdent} child con : {Identifier} child name : {Identifier} alternative SuperfluousRule: child nt : {NontermIdent} child con : {ConstructorIdent} child field : {Identifier} child attr : {Identifier} alternative UndefLocal: child nt : {NontermIdent} child con : {ConstructorIdent} child var : {Identifier} alternative ChildAsLocal: child nt : {NontermIdent} child con : {ConstructorIdent} child var : {Identifier} alternative UndefAttr: child nt : {NontermIdent} child con : {ConstructorIdent} child field : {Identifier} child attr : {Identifier} child isOut : {Bool} alternative Cyclic: child nt : {NontermIdent} child mbCon : {Maybe ConstructorIdent} child verts : {[String]} alternative CyclicSet: child name : {Identifier} alternative CustomError: child isWarning : {Bool} child pos : {Pos} child mesg : {PP_Doc} alternative LocalCirc: child nt : {NontermIdent} child con : {ConstructorIdent} child attr : {Identifier} child o_visit : {Bool} child path : {[String]} alternative InstCirc: child nt : {NontermIdent} child con : {ConstructorIdent} child attr : {Identifier} child o_visit : {Bool} child path : {[String]} alternative DirectCirc: child nt : {NontermIdent} child o_visit : {Bool} child cyclic : {[((Identifier,Identifier),[String],[String])]} alternative InducedCirc: child nt : {NontermIdent} child cinter : {CInterface} child cyclic : {[((Identifier,Identifier),[String],[String])]} alternative MissingTypeSig: child nt : {NontermIdent} child con : {ConstructorIdent} child attr : {Identifier} alternative MissingInstSig: child nt : {NontermIdent} child con : {ConstructorIdent} child attr : {Identifier} alternative DupUnique: child nt : {NontermIdent} child con : {ConstructorIdent} child attr : {Identifier} alternative MissingUnique: child nt : {NontermIdent} child attr : {Identifier} alternative MissingSyn: child nt : {NontermIdent} child attr : {Identifier} alternative IncompatibleVisitKind: child child : {Identifier} child vis : {VisitIdentifier} child from : {VisitKind} child to : {VisitKind} alternative IncompatibleRuleKind: child rule : {Identifier} child kind : {VisitKind} alternative IncompatibleAttachKind: child child : {Identifier} child kind : {VisitKind} -} data Error = ParserError (Pos) (String) (String) | HsParseError (Pos) (String) | DupAlt (NontermIdent) (ConstructorIdent) (ConstructorIdent) | DupSynonym (NontermIdent) (NontermIdent) | DupSet (NontermIdent) (NontermIdent) | DupInhAttr (NontermIdent) (Identifier) (Identifier) | DupSynAttr (NontermIdent) (Identifier) (Identifier) | DupChild (NontermIdent) (ConstructorIdent) (Identifier) (Identifier) | DupRule (NontermIdent) (ConstructorIdent) (Identifier) (Identifier) (Identifier) | DupRuleName (NontermIdent) (ConstructorIdent) (Identifier) | DupSig (NontermIdent) (ConstructorIdent) (Identifier) | UndefNont (NontermIdent) | UndefAlt (NontermIdent) (ConstructorIdent) | UndefChild (NontermIdent) (ConstructorIdent) (Identifier) | MissingRule (NontermIdent) (ConstructorIdent) (Identifier) (Identifier) | MissingNamedRule (NontermIdent) (Identifier) (Identifier) | SuperfluousRule (NontermIdent) (ConstructorIdent) (Identifier) (Identifier) | UndefLocal (NontermIdent) (ConstructorIdent) (Identifier) | ChildAsLocal (NontermIdent) (ConstructorIdent) (Identifier) | UndefAttr (NontermIdent) (ConstructorIdent) (Identifier) (Identifier) (Bool) | Cyclic (NontermIdent) ((Maybe ConstructorIdent)) (([String])) | CyclicSet (Identifier) | CustomError (Bool) (Pos) (PP_Doc) | LocalCirc (NontermIdent) (ConstructorIdent) (Identifier) (Bool) (([String])) | InstCirc (NontermIdent) (ConstructorIdent) (Identifier) (Bool) (([String])) | DirectCirc (NontermIdent) (Bool) (([((Identifier,Identifier),[String],[String])])) | InducedCirc (NontermIdent) (CInterface) (([((Identifier,Identifier),[String],[String])])) | MissingTypeSig (NontermIdent) (ConstructorIdent) (Identifier) | MissingInstSig (NontermIdent) (ConstructorIdent) (Identifier) | DupUnique (NontermIdent) (ConstructorIdent) (Identifier) | MissingUnique (NontermIdent) (Identifier) | MissingSyn (NontermIdent) (Identifier) | IncompatibleVisitKind (Identifier) (VisitIdentifier) (VisitKind) (VisitKind) | IncompatibleRuleKind (Identifier) (VisitKind) | IncompatibleAttachKind (Identifier) (VisitKind) -- Errors ------------------------------------------------------ {- alternatives: alternative Cons: child hd : Error child tl : Errors alternative Nil: -} type Errors = [Error]uuagc-0.9.42.3/src-generated/ExecutionPlan.hs000644 000765 000024 00000014106 12127045231 022705 0ustar00jeroenbransenstaff000000 000000 -- UUAGC 0.9.42.3 (src-ag/ExecutionPlan.ag) module ExecutionPlan where {-# LINE 2 "./src-ag/ExecutionPlan.ag" #-} -- 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) {-# LINE 18 "dist/build/ExecutionPlan.hs" #-} -- EChild ------------------------------------------------------ {- alternatives: alternative EChild: child name : {Identifier} child tp : {Type} child kind : {ChildKind} child hasAround : {Bool} child merges : {Maybe [Identifier]} child isMerged : {Bool} alternative ETerm: child name : {Identifier} child tp : {Type} -} data EChild = EChild (Identifier) (Type) (ChildKind) (Bool) ((Maybe [Identifier])) (Bool) | ETerm (Identifier) (Type) -- EChildren --------------------------------------------------- {- alternatives: alternative Cons: child hd : EChild child tl : EChildren alternative Nil: -} type EChildren = [EChild] -- ENonterminal ------------------------------------------------ {- alternatives: alternative ENonterminal: child nt : {NontermIdent} child params : {[Identifier]} child classCtxs : {ClassContext} child initial : {StateIdentifier} child initialv : {Maybe VisitIdentifier} child nextVisits : {Map StateIdentifier StateCtx} child prevVisits : {Map StateIdentifier StateCtx} child prods : EProductions child recursive : {Bool} child hoInfo : {HigherOrderInfo} -} data ENonterminal = ENonterminal (NontermIdent) (([Identifier])) (ClassContext) (StateIdentifier) ((Maybe VisitIdentifier)) ((Map StateIdentifier StateCtx)) ((Map StateIdentifier StateCtx)) (EProductions) (Bool) (HigherOrderInfo) -- ENonterminals ----------------------------------------------- {- alternatives: alternative Cons: child hd : ENonterminal child tl : ENonterminals alternative Nil: -} type ENonterminals = [ENonterminal] -- EProduction ------------------------------------------------- {- alternatives: alternative EProduction: child con : {ConstructorIdent} child params : {[Identifier]} child constraints : {[Type]} child rules : ERules child children : EChildren child visits : Visits -} data EProduction = EProduction (ConstructorIdent) (([Identifier])) (([Type])) (ERules) (EChildren) (Visits) -- EProductions ------------------------------------------------ {- alternatives: alternative Cons: child hd : EProduction child tl : EProductions alternative Nil: -} type EProductions = [EProduction] -- ERule ------------------------------------------------------- {- alternatives: alternative ERule: child name : {Identifier} child pattern : {Pattern} child rhs : {Expression} child owrt : {Bool} child origin : {String} child explicit : {Bool} child pure : {Bool} child mbError : {Maybe Error} -} data ERule = ERule (Identifier) (Pattern) (Expression) (Bool) (String) (Bool) (Bool) ((Maybe Error)) -- ERules ------------------------------------------------------ {- alternatives: alternative Cons: child hd : ERule child tl : ERules alternative Nil: -} type ERules = [ERule] -- ExecutionPlan ----------------------------------------------- {- alternatives: alternative ExecutionPlan: child nonts : ENonterminals child typeSyns : {TypeSyns} child wrappers : {Set NontermIdent} child derivings : {Derivings} -} data ExecutionPlan = ExecutionPlan (ENonterminals) (TypeSyns) ((Set NontermIdent)) (Derivings) -- Visit ------------------------------------------------------- {- alternatives: alternative Visit: child ident : {VisitIdentifier} child from : {StateIdentifier} child to : {StateIdentifier} child inh : {Set Identifier} child syn : {Set Identifier} child steps : VisitSteps child kind : {VisitKind} -} data Visit = Visit (VisitIdentifier) (StateIdentifier) (StateIdentifier) ((Set Identifier)) ((Set Identifier)) (VisitSteps) (VisitKind) -- VisitStep --------------------------------------------------- {- alternatives: alternative Sem: child name : {Identifier} alternative ChildVisit: child child : {Identifier} child nonterm : {NontermIdent} child visit : {VisitIdentifier} alternative PureGroup: child steps : VisitSteps child ordered : {Bool} alternative Sim: child steps : VisitSteps alternative ChildIntro: child child : {Identifier} -} data VisitStep = Sem (Identifier) | ChildVisit (Identifier) (NontermIdent) (VisitIdentifier) | PureGroup (VisitSteps) (Bool) | Sim (VisitSteps) | ChildIntro (Identifier) -- VisitSteps -------------------------------------------------- {- alternatives: alternative Cons: child hd : VisitStep child tl : VisitSteps alternative Nil: -} type VisitSteps = [VisitStep] -- Visits ------------------------------------------------------ {- alternatives: alternative Cons: child hd : Visit child tl : Visits alternative Nil: -} type Visits = [Visit]uuagc-0.9.42.3/src-generated/ExecutionPlan2Caml.hs000644 000765 000024 00001251275 12127045231 023577 0ustar00jeroenbransenstaff000000 000000 {-# LANGUAGE Rank2Types, GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} module ExecutionPlan2Caml where {-# LINE 2 "./src-ag/ExecutionPlan.ag" #-} -- 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) {-# LINE 18 "dist/build/ExecutionPlan2Caml.hs" #-} {-# LINE 2 "./src-ag/Patterns.ag" #-} -- Patterns.ag imports import UU.Scanner.Position(Pos) import CommonTypes (ConstructorIdent,Identifier) {-# LINE 25 "dist/build/ExecutionPlan2Caml.hs" #-} {-# LINE 2 "./src-ag/Expression.ag" #-} import UU.Scanner.Position(Pos) import HsToken {-# LINE 31 "dist/build/ExecutionPlan2Caml.hs" #-} {-# LINE 2 "./src-ag/HsToken.ag" #-} import CommonTypes import UU.Scanner.Position(Pos) {-# LINE 37 "dist/build/ExecutionPlan2Caml.hs" #-} {-# LINE 32 "./src-ag/ExecutionPlan2Caml.ag" #-} 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) {-# LINE 65 "dist/build/ExecutionPlan2Caml.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 173 "./src-ag/ExecutionPlan2Caml.ag" #-} 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 ] {-# LINE 91 "dist/build/ExecutionPlan2Caml.hs" #-} {-# LINE 286 "./src-ag/ExecutionPlan2Caml.ag" #-} 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) {-# LINE 113 "dist/build/ExecutionPlan2Caml.hs" #-} {-# LINE 359 "./src-ag/ExecutionPlan2Caml.ag" #-} -- 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 {-# LINE 135 "dist/build/ExecutionPlan2Caml.hs" #-} {-# LINE 426 "./src-ag/ExecutionPlan2Caml.ag" #-} type VisitStateState = (VisitIdentifier,StateIdentifier, StateIdentifier) {-# LINE 139 "dist/build/ExecutionPlan2Caml.hs" #-} {-# LINE 462 "./src-ag/ExecutionPlan2Caml.ag" #-} -- -- 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 {-# LINE 179 "dist/build/ExecutionPlan2Caml.hs" #-} {-# LINE 519 "./src-ag/ExecutionPlan2Caml.ag" #-} 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 {-# LINE 189 "dist/build/ExecutionPlan2Caml.hs" #-} {-# LINE 565 "./src-ag/ExecutionPlan2Caml.ag" #-} -- 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" {-# LINE 207 "dist/build/ExecutionPlan2Caml.hs" #-} {-# LINE 778 "./src-ag/ExecutionPlan2Caml.ag" #-} 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 {-# LINE 219 "dist/build/ExecutionPlan2Caml.hs" #-} {-# LINE 820 "./src-ag/ExecutionPlan2Caml.ag" #-} resultValName :: String resultValName = "__result_" nextStName :: String nextStName = "__st_" {-# LINE 228 "dist/build/ExecutionPlan2Caml.hs" #-} {-# LINE 961 "./src-ag/ExecutionPlan2Caml.ag" #-} 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 {-# LINE 238 "dist/build/ExecutionPlan2Caml.hs" #-} {-# LINE 1028 "./src-ag/ExecutionPlan2Caml.ag" #-} 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" {-# LINE 257 "dist/build/ExecutionPlan2Caml.hs" #-} {-# LINE 1104 "./src-ag/ExecutionPlan2Caml.ag" #-} 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 {-# LINE 290 "dist/build/ExecutionPlan2Caml.hs" #-} {-# LINE 1201 "./src-ag/ExecutionPlan2Caml.ag" #-} 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 {-# LINE 304 "dist/build/ExecutionPlan2Caml.hs" #-} {-# LINE 1226 "./src-ag/ExecutionPlan2Caml.ag" #-} unionWithSum = Map.unionWith (+) {-# LINE 309 "dist/build/ExecutionPlan2Caml.hs" #-} {-# LINE 1249 "./src-ag/ExecutionPlan2Caml.ag" #-} 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 {-# LINE 318 "dist/build/ExecutionPlan2Caml.hs" #-} -- EChild ------------------------------------------------------ -- wrapper data Inh_EChild = Inh_EChild { allInitStates_Inh_EChild :: (Map NontermIdent Int), con_Inh_EChild :: (ConstructorIdent), mainFile_Inh_EChild :: (String), mainName_Inh_EChild :: (String), nt_Inh_EChild :: (NontermIdent), options_Inh_EChild :: (Options) } data Syn_EChild = Syn_EChild { argnamesw_Syn_EChild :: ( PP_Doc ), childTypes_Syn_EChild :: (Map Identifier Type), childintros_Syn_EChild :: (Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))), sigs_Syn_EChild :: ([(PP_Doc,PP_Doc,PP_Doc,PP_Doc)]), terminaldefs_Syn_EChild :: (Set String) } {-# INLINABLE wrap_EChild #-} wrap_EChild :: T_EChild -> Inh_EChild -> (Syn_EChild ) wrap_EChild (T_EChild act) (Inh_EChild _lhsIallInitStates _lhsIcon _lhsImainFile _lhsImainName _lhsInt _lhsIoptions) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_EChild_vIn1 _lhsIallInitStates _lhsIcon _lhsImainFile _lhsImainName _lhsInt _lhsIoptions (T_EChild_vOut1 _lhsOargnamesw _lhsOchildTypes _lhsOchildintros _lhsOsigs _lhsOterminaldefs) <- return (inv_EChild_s2 sem arg) return (Syn_EChild _lhsOargnamesw _lhsOchildTypes _lhsOchildintros _lhsOsigs _lhsOterminaldefs) ) -- cata {-# NOINLINE sem_EChild #-} sem_EChild :: EChild -> T_EChild sem_EChild ( EChild name_ tp_ kind_ hasAround_ merges_ isMerged_ ) = sem_EChild_EChild name_ tp_ kind_ hasAround_ merges_ isMerged_ sem_EChild ( ETerm name_ tp_ ) = sem_EChild_ETerm name_ tp_ -- semantic domain newtype T_EChild = T_EChild { attach_T_EChild :: Identity (T_EChild_s2 ) } newtype T_EChild_s2 = C_EChild_s2 { inv_EChild_s2 :: (T_EChild_v1 ) } data T_EChild_s3 = C_EChild_s3 type T_EChild_v1 = (T_EChild_vIn1 ) -> (T_EChild_vOut1 ) data T_EChild_vIn1 = T_EChild_vIn1 (Map NontermIdent Int) (ConstructorIdent) (String) (String) (NontermIdent) (Options) data T_EChild_vOut1 = T_EChild_vOut1 ( PP_Doc ) (Map Identifier Type) (Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))) ([(PP_Doc,PP_Doc,PP_Doc,PP_Doc)]) (Set String) {-# NOINLINE sem_EChild_EChild #-} sem_EChild_EChild :: (Identifier) -> (Type) -> (ChildKind) -> (Bool) -> (Maybe [Identifier]) -> (Bool) -> T_EChild sem_EChild_EChild arg_name_ arg_tp_ arg_kind_ arg_hasAround_ _ _ = T_EChild (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_EChild_v1 v1 = \ (T_EChild_vIn1 _lhsIallInitStates _lhsIcon _lhsImainFile _lhsImainName _lhsInt _lhsIoptions) -> ( let _tpDocFor = rule0 arg_tp_ _tpDocDefor = rule1 arg_tp_ _fieldNm = rule2 _lhsIcon _lhsInt arg_name_ _childNm = rule3 arg_name_ _field = rule4 _childNm _fieldNm _tpDocDefor _tpDocFor _lhsOsigs :: [(PP_Doc,PP_Doc,PP_Doc,PP_Doc)] _lhsOsigs = rule5 _field arg_kind_ _lhsOargnamesw :: PP_Doc _lhsOargnamesw = rule6 _lhsIoptions _nt arg_kind_ arg_name_ _lhsOchildintros :: Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr))) _lhsOchildintros = rule7 _introcode arg_name_ _isDefor = rule8 arg_tp_ _valcode = rule9 _isDefor _lhsIoptions _nt arg_kind_ arg_name_ _aroundcode = rule10 arg_hasAround_ arg_name_ _introcode = rule11 _aroundcode _initSt _isDefor _lhsIoptions _nt _valcode arg_hasAround_ arg_kind_ arg_name_ _nt = rule12 arg_tp_ _lhsOchildTypes :: Map Identifier Type _lhsOchildTypes = rule13 arg_name_ arg_tp_ _initSt = rule14 _lhsIallInitStates _nt _lhsOterminaldefs :: Set String _lhsOterminaldefs = rule15 () __result_ = T_EChild_vOut1 _lhsOargnamesw _lhsOchildTypes _lhsOchildintros _lhsOsigs _lhsOterminaldefs in __result_ ) in C_EChild_s2 v1 {-# INLINE rule0 #-} {-# LINE 276 "./src-ag/ExecutionPlan2Caml.ag" #-} rule0 = \ tp_ -> {-# LINE 276 "./src-ag/ExecutionPlan2Caml.ag" #-} ppTp $ removeDeforested tp_ {-# LINE 386 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule1 #-} {-# LINE 277 "./src-ag/ExecutionPlan2Caml.ag" #-} rule1 = \ tp_ -> {-# LINE 277 "./src-ag/ExecutionPlan2Caml.ag" #-} ppTp $ forceDeforested tp_ {-# LINE 392 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule2 #-} {-# LINE 278 "./src-ag/ExecutionPlan2Caml.ag" #-} rule2 = \ ((_lhsIcon) :: ConstructorIdent) ((_lhsInt) :: NontermIdent) name_ -> {-# LINE 278 "./src-ag/ExecutionPlan2Caml.ag" #-} text $ recordFieldname _lhsInt _lhsIcon name_ {-# LINE 398 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule3 #-} {-# LINE 279 "./src-ag/ExecutionPlan2Caml.ag" #-} rule3 = \ name_ -> {-# LINE 279 "./src-ag/ExecutionPlan2Caml.ag" #-} text (fieldname name_) {-# LINE 404 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule4 #-} {-# LINE 280 "./src-ag/ExecutionPlan2Caml.ag" #-} rule4 = \ _childNm _fieldNm _tpDocDefor _tpDocFor -> {-# LINE 280 "./src-ag/ExecutionPlan2Caml.ag" #-} (_fieldNm , _childNm , _tpDocDefor , _tpDocFor ) {-# LINE 410 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule5 #-} {-# LINE 281 "./src-ag/ExecutionPlan2Caml.ag" #-} rule5 = \ _field kind_ -> {-# LINE 281 "./src-ag/ExecutionPlan2Caml.ag" #-} case kind_ of ChildAttr -> [] _ -> [_field ] {-# LINE 418 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule6 #-} {-# LINE 394 "./src-ag/ExecutionPlan2Caml.ag" #-} rule6 = \ ((_lhsIoptions) :: Options) _nt kind_ name_ -> {-# LINE 394 "./src-ag/ExecutionPlan2Caml.ag" #-} case kind_ of ChildSyntax -> "(" >#< prefix _lhsIoptions >|< _nt >#< name_ >|< "_" >#< ")" ChildAttr -> empty ChildReplace tp -> "(" >#< prefix _lhsIoptions >|< extractNonterminal tp >#< name_ >|< "_" >#< ")" {-# LINE 427 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule7 #-} {-# LINE 921 "./src-ag/ExecutionPlan2Caml.ag" #-} rule7 = \ _introcode name_ -> {-# LINE 921 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.singleton name_ _introcode {-# LINE 433 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule8 #-} {-# LINE 922 "./src-ag/ExecutionPlan2Caml.ag" #-} rule8 = \ tp_ -> {-# LINE 922 "./src-ag/ExecutionPlan2Caml.ag" #-} case tp_ of NT _ _ defor -> defor _ -> False {-# LINE 441 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule9 #-} {-# LINE 925 "./src-ag/ExecutionPlan2Caml.ag" #-} rule9 = \ _isDefor ((_lhsIoptions) :: Options) _nt kind_ name_ -> {-# LINE 925 "./src-ag/ExecutionPlan2Caml.ag" #-} case kind_ of ChildSyntax -> name_ >|< "_" ChildAttr -> let head | not _isDefor = if lateHigherOrderBinding _lhsIoptions then lateSemNtLabel _nt >#< lhsname True idLateBindingAttr else prefix _lhsIoptions >|< _nt | otherwise = empty in pp_parens (head >#< instname name_) ChildReplace _ -> pp_parens (instname name_ >#< name_ >|< "_") {-# LINE 456 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule10 #-} {-# LINE 936 "./src-ag/ExecutionPlan2Caml.ag" #-} rule10 = \ hasAround_ name_ -> {-# LINE 936 "./src-ag/ExecutionPlan2Caml.ag" #-} if hasAround_ then locname name_ >|< "_around" else empty {-# LINE 464 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule11 #-} {-# LINE 939 "./src-ag/ExecutionPlan2Caml.ag" #-} rule11 = \ _aroundcode _initSt _isDefor ((_lhsIoptions) :: Options) _nt _valcode hasAround_ kind_ name_ -> {-# LINE 939 "./src-ag/ExecutionPlan2Caml.ag" #-} \kind -> let pat = text $ stname name_ _initSt attach = pp_parens (_aroundcode >#< _valcode ) >|< "." >|< nm_attach _nt >#< "()" decl = pat >#< "=" >#< attach in if compatibleAttach kind _nt _lhsIoptions then Right ( "let" >#< decl >#< "in" , Set.singleton (stname name_ _initSt ) , case kind_ of ChildAttr -> Map.insert (instname name_) Nothing $ ( if _isDefor || not (lateHigherOrderBinding _lhsIoptions) then id else Map.insert (lhsname True idLateBindingAttr) (Just $ AttrInh _LHS idLateBindingAttr) ) $ ( if hasAround_ then Map.insert (locname (name_) ++ "_around") Nothing else id ) $ Map.empty ChildReplace _ -> Map.singleton (instname name_) Nothing ChildSyntax -> Map.empty ) else Left $ IncompatibleAttachKind name_ kind {-# LINE 489 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule12 #-} {-# LINE 959 "./src-ag/ExecutionPlan2Caml.ag" #-} rule12 = \ tp_ -> {-# LINE 959 "./src-ag/ExecutionPlan2Caml.ag" #-} extractNonterminal tp_ {-# LINE 495 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule13 #-} {-# LINE 1421 "./src-ag/ExecutionPlan2Caml.ag" #-} rule13 = \ name_ tp_ -> {-# LINE 1421 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.singleton name_ tp_ {-# LINE 501 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule14 #-} {-# LINE 1465 "./src-ag/ExecutionPlan2Caml.ag" #-} rule14 = \ ((_lhsIallInitStates) :: Map NontermIdent Int) _nt -> {-# LINE 1465 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.findWithDefault (error "nonterminal not in allInitStates map") _nt _lhsIallInitStates {-# LINE 507 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule15 #-} rule15 = \ (_ :: ()) -> Set.empty {-# NOINLINE sem_EChild_ETerm #-} sem_EChild_ETerm :: (Identifier) -> (Type) -> T_EChild sem_EChild_ETerm arg_name_ arg_tp_ = T_EChild (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_EChild_v1 v1 = \ (T_EChild_vIn1 _lhsIallInitStates _lhsIcon _lhsImainFile _lhsImainName _lhsInt _lhsIoptions) -> ( let _tpDocFor = rule16 arg_tp_ _tpDocDefor = rule17 arg_tp_ _fieldNm = rule18 _lhsIcon _lhsInt arg_name_ _childNm = rule19 arg_name_ _field = rule20 _childNm _fieldNm _tpDocDefor _tpDocFor _lhsOsigs :: [(PP_Doc,PP_Doc,PP_Doc,PP_Doc)] _lhsOsigs = rule21 _field _lhsOargnamesw :: PP_Doc _lhsOargnamesw = rule22 arg_name_ _lhsOchildintros :: Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr))) _lhsOchildintros = rule23 arg_name_ _lhsOterminaldefs :: Set String _lhsOterminaldefs = rule24 arg_name_ _lhsOchildTypes :: Map Identifier Type _lhsOchildTypes = rule25 arg_name_ arg_tp_ __result_ = T_EChild_vOut1 _lhsOargnamesw _lhsOchildTypes _lhsOchildintros _lhsOsigs _lhsOterminaldefs in __result_ ) in C_EChild_s2 v1 {-# INLINE rule16 #-} {-# LINE 276 "./src-ag/ExecutionPlan2Caml.ag" #-} rule16 = \ tp_ -> {-# LINE 276 "./src-ag/ExecutionPlan2Caml.ag" #-} ppTp $ removeDeforested tp_ {-# LINE 541 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule17 #-} {-# LINE 277 "./src-ag/ExecutionPlan2Caml.ag" #-} rule17 = \ tp_ -> {-# LINE 277 "./src-ag/ExecutionPlan2Caml.ag" #-} ppTp $ forceDeforested tp_ {-# LINE 547 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule18 #-} {-# LINE 278 "./src-ag/ExecutionPlan2Caml.ag" #-} rule18 = \ ((_lhsIcon) :: ConstructorIdent) ((_lhsInt) :: NontermIdent) name_ -> {-# LINE 278 "./src-ag/ExecutionPlan2Caml.ag" #-} text $ recordFieldname _lhsInt _lhsIcon name_ {-# LINE 553 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule19 #-} {-# LINE 279 "./src-ag/ExecutionPlan2Caml.ag" #-} rule19 = \ name_ -> {-# LINE 279 "./src-ag/ExecutionPlan2Caml.ag" #-} text (fieldname name_) {-# LINE 559 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule20 #-} {-# LINE 280 "./src-ag/ExecutionPlan2Caml.ag" #-} rule20 = \ _childNm _fieldNm _tpDocDefor _tpDocFor -> {-# LINE 280 "./src-ag/ExecutionPlan2Caml.ag" #-} (_fieldNm , _childNm , _tpDocDefor , _tpDocFor ) {-# LINE 565 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule21 #-} {-# LINE 284 "./src-ag/ExecutionPlan2Caml.ag" #-} rule21 = \ _field -> {-# LINE 284 "./src-ag/ExecutionPlan2Caml.ag" #-} [_field ] {-# LINE 571 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule22 #-} {-# LINE 398 "./src-ag/ExecutionPlan2Caml.ag" #-} rule22 = \ name_ -> {-# LINE 398 "./src-ag/ExecutionPlan2Caml.ag" #-} text $ fieldname name_ {-# LINE 577 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule23 #-} {-# LINE 920 "./src-ag/ExecutionPlan2Caml.ag" #-} rule23 = \ name_ -> {-# LINE 920 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.singleton name_ (\_ -> Right (empty, Set.empty, Map.empty)) {-# LINE 583 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule24 #-} {-# LINE 1263 "./src-ag/ExecutionPlan2Caml.ag" #-} rule24 = \ name_ -> {-# LINE 1263 "./src-ag/ExecutionPlan2Caml.ag" #-} Set.singleton $ fieldname name_ {-# LINE 589 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule25 #-} {-# LINE 1421 "./src-ag/ExecutionPlan2Caml.ag" #-} rule25 = \ name_ tp_ -> {-# LINE 1421 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.singleton name_ tp_ {-# LINE 595 "dist/build/ExecutionPlan2Caml.hs"#-} -- EChildren --------------------------------------------------- -- wrapper data Inh_EChildren = Inh_EChildren { allInitStates_Inh_EChildren :: (Map NontermIdent Int), con_Inh_EChildren :: (ConstructorIdent), mainFile_Inh_EChildren :: (String), mainName_Inh_EChildren :: (String), nt_Inh_EChildren :: (NontermIdent), options_Inh_EChildren :: (Options) } data Syn_EChildren = Syn_EChildren { argnamesw_Syn_EChildren :: ([PP_Doc]), childTypes_Syn_EChildren :: (Map Identifier Type), childintros_Syn_EChildren :: (Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))), sigs_Syn_EChildren :: ([(PP_Doc,PP_Doc,PP_Doc,PP_Doc)]), terminaldefs_Syn_EChildren :: (Set String) } {-# INLINABLE wrap_EChildren #-} wrap_EChildren :: T_EChildren -> Inh_EChildren -> (Syn_EChildren ) wrap_EChildren (T_EChildren act) (Inh_EChildren _lhsIallInitStates _lhsIcon _lhsImainFile _lhsImainName _lhsInt _lhsIoptions) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_EChildren_vIn4 _lhsIallInitStates _lhsIcon _lhsImainFile _lhsImainName _lhsInt _lhsIoptions (T_EChildren_vOut4 _lhsOargnamesw _lhsOchildTypes _lhsOchildintros _lhsOsigs _lhsOterminaldefs) <- return (inv_EChildren_s5 sem arg) return (Syn_EChildren _lhsOargnamesw _lhsOchildTypes _lhsOchildintros _lhsOsigs _lhsOterminaldefs) ) -- cata {-# NOINLINE sem_EChildren #-} sem_EChildren :: EChildren -> T_EChildren sem_EChildren list = Prelude.foldr sem_EChildren_Cons sem_EChildren_Nil (Prelude.map sem_EChild list) -- semantic domain newtype T_EChildren = T_EChildren { attach_T_EChildren :: Identity (T_EChildren_s5 ) } newtype T_EChildren_s5 = C_EChildren_s5 { inv_EChildren_s5 :: (T_EChildren_v4 ) } data T_EChildren_s6 = C_EChildren_s6 type T_EChildren_v4 = (T_EChildren_vIn4 ) -> (T_EChildren_vOut4 ) data T_EChildren_vIn4 = T_EChildren_vIn4 (Map NontermIdent Int) (ConstructorIdent) (String) (String) (NontermIdent) (Options) data T_EChildren_vOut4 = T_EChildren_vOut4 ([PP_Doc]) (Map Identifier Type) (Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))) ([(PP_Doc,PP_Doc,PP_Doc,PP_Doc)]) (Set String) {-# NOINLINE sem_EChildren_Cons #-} sem_EChildren_Cons :: T_EChild -> T_EChildren -> T_EChildren sem_EChildren_Cons arg_hd_ arg_tl_ = T_EChildren (return st5) where {-# NOINLINE st5 #-} st5 = let v4 :: T_EChildren_v4 v4 = \ (T_EChildren_vIn4 _lhsIallInitStates _lhsIcon _lhsImainFile _lhsImainName _lhsInt _lhsIoptions) -> ( let _hdX2 = Control.Monad.Identity.runIdentity (attach_T_EChild (arg_hd_)) _tlX5 = Control.Monad.Identity.runIdentity (attach_T_EChildren (arg_tl_)) (T_EChild_vOut1 _hdIargnamesw _hdIchildTypes _hdIchildintros _hdIsigs _hdIterminaldefs) = inv_EChild_s2 _hdX2 (T_EChild_vIn1 _hdOallInitStates _hdOcon _hdOmainFile _hdOmainName _hdOnt _hdOoptions) (T_EChildren_vOut4 _tlIargnamesw _tlIchildTypes _tlIchildintros _tlIsigs _tlIterminaldefs) = inv_EChildren_s5 _tlX5 (T_EChildren_vIn4 _tlOallInitStates _tlOcon _tlOmainFile _tlOmainName _tlOnt _tlOoptions) _lhsOargnamesw :: [PP_Doc] _lhsOargnamesw = rule26 _hdIargnamesw _tlIargnamesw _lhsOchildTypes :: Map Identifier Type _lhsOchildTypes = rule27 _hdIchildTypes _tlIchildTypes _lhsOchildintros :: Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr))) _lhsOchildintros = rule28 _hdIchildintros _tlIchildintros _lhsOsigs :: [(PP_Doc,PP_Doc,PP_Doc,PP_Doc)] _lhsOsigs = rule29 _hdIsigs _tlIsigs _lhsOterminaldefs :: Set String _lhsOterminaldefs = rule30 _hdIterminaldefs _tlIterminaldefs _hdOallInitStates = rule31 _lhsIallInitStates _hdOcon = rule32 _lhsIcon _hdOmainFile = rule33 _lhsImainFile _hdOmainName = rule34 _lhsImainName _hdOnt = rule35 _lhsInt _hdOoptions = rule36 _lhsIoptions _tlOallInitStates = rule37 _lhsIallInitStates _tlOcon = rule38 _lhsIcon _tlOmainFile = rule39 _lhsImainFile _tlOmainName = rule40 _lhsImainName _tlOnt = rule41 _lhsInt _tlOoptions = rule42 _lhsIoptions __result_ = T_EChildren_vOut4 _lhsOargnamesw _lhsOchildTypes _lhsOchildintros _lhsOsigs _lhsOterminaldefs in __result_ ) in C_EChildren_s5 v4 {-# INLINE rule26 #-} rule26 = \ ((_hdIargnamesw) :: PP_Doc ) ((_tlIargnamesw) :: [PP_Doc]) -> _hdIargnamesw : _tlIargnamesw {-# INLINE rule27 #-} rule27 = \ ((_hdIchildTypes) :: Map Identifier Type) ((_tlIchildTypes) :: Map Identifier Type) -> _hdIchildTypes `mappend` _tlIchildTypes {-# INLINE rule28 #-} rule28 = \ ((_hdIchildintros) :: Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))) ((_tlIchildintros) :: Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))) -> _hdIchildintros `Map.union` _tlIchildintros {-# INLINE rule29 #-} rule29 = \ ((_hdIsigs) :: [(PP_Doc,PP_Doc,PP_Doc,PP_Doc)]) ((_tlIsigs) :: [(PP_Doc,PP_Doc,PP_Doc,PP_Doc)]) -> _hdIsigs ++ _tlIsigs {-# INLINE rule30 #-} rule30 = \ ((_hdIterminaldefs) :: Set String) ((_tlIterminaldefs) :: Set String) -> _hdIterminaldefs `Set.union` _tlIterminaldefs {-# INLINE rule31 #-} rule31 = \ ((_lhsIallInitStates) :: Map NontermIdent Int) -> _lhsIallInitStates {-# INLINE rule32 #-} rule32 = \ ((_lhsIcon) :: ConstructorIdent) -> _lhsIcon {-# INLINE rule33 #-} rule33 = \ ((_lhsImainFile) :: String) -> _lhsImainFile {-# INLINE rule34 #-} rule34 = \ ((_lhsImainName) :: String) -> _lhsImainName {-# INLINE rule35 #-} rule35 = \ ((_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule36 #-} rule36 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule37 #-} rule37 = \ ((_lhsIallInitStates) :: Map NontermIdent Int) -> _lhsIallInitStates {-# INLINE rule38 #-} rule38 = \ ((_lhsIcon) :: ConstructorIdent) -> _lhsIcon {-# INLINE rule39 #-} rule39 = \ ((_lhsImainFile) :: String) -> _lhsImainFile {-# INLINE rule40 #-} rule40 = \ ((_lhsImainName) :: String) -> _lhsImainName {-# INLINE rule41 #-} rule41 = \ ((_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule42 #-} rule42 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_EChildren_Nil #-} sem_EChildren_Nil :: T_EChildren sem_EChildren_Nil = T_EChildren (return st5) where {-# NOINLINE st5 #-} st5 = let v4 :: T_EChildren_v4 v4 = \ (T_EChildren_vIn4 _lhsIallInitStates _lhsIcon _lhsImainFile _lhsImainName _lhsInt _lhsIoptions) -> ( let _lhsOargnamesw :: [PP_Doc] _lhsOargnamesw = rule43 () _lhsOchildTypes :: Map Identifier Type _lhsOchildTypes = rule44 () _lhsOchildintros :: Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr))) _lhsOchildintros = rule45 () _lhsOsigs :: [(PP_Doc,PP_Doc,PP_Doc,PP_Doc)] _lhsOsigs = rule46 () _lhsOterminaldefs :: Set String _lhsOterminaldefs = rule47 () __result_ = T_EChildren_vOut4 _lhsOargnamesw _lhsOchildTypes _lhsOchildintros _lhsOsigs _lhsOterminaldefs in __result_ ) in C_EChildren_s5 v4 {-# INLINE rule43 #-} rule43 = \ (_ :: ()) -> [] {-# INLINE rule44 #-} rule44 = \ (_ :: ()) -> mempty {-# INLINE rule45 #-} rule45 = \ (_ :: ()) -> Map.empty {-# INLINE rule46 #-} rule46 = \ (_ :: ()) -> [] {-# INLINE rule47 #-} rule47 = \ (_ :: ()) -> Set.empty -- ENonterminal ------------------------------------------------ -- wrapper data Inh_ENonterminal = Inh_ENonterminal { allFromToStates_Inh_ENonterminal :: (Map VisitIdentifier (Int,Int)), allInitStates_Inh_ENonterminal :: (Map NontermIdent Int), allVisitKinds_Inh_ENonterminal :: (Map VisitIdentifier VisitKind), allchildvisit_Inh_ENonterminal :: (Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)), avisitdefs_Inh_ENonterminal :: (Map VisitIdentifier (Set Identifier)), avisituses_Inh_ENonterminal :: (Map VisitIdentifier (Set Identifier)), inhmap_Inh_ENonterminal :: (Map NontermIdent Attributes), localAttrTypes_Inh_ENonterminal :: (Map NontermIdent (Map ConstructorIdent (Map Identifier Type))), mainFile_Inh_ENonterminal :: (String), mainName_Inh_ENonterminal :: (String), options_Inh_ENonterminal :: (Options), synmap_Inh_ENonterminal :: (Map NontermIdent Attributes), typeSyns_Inh_ENonterminal :: (TypeSyns), wrappers_Inh_ENonterminal :: (Set NontermIdent) } data Syn_ENonterminal = Syn_ENonterminal { childvisit_Syn_ENonterminal :: (Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)), code_Syn_ENonterminal :: (PP_Doc), datas_Syn_ENonterminal :: (PP_Doc), errors_Syn_ENonterminal :: (Seq Error), fromToStates_Syn_ENonterminal :: (Map VisitIdentifier (Int,Int)), initStates_Syn_ENonterminal :: (Map NontermIdent Int), modules_Syn_ENonterminal :: (PP_Doc), semFunBndDefs_Syn_ENonterminal :: (Seq PP_Doc), semFunBndTps_Syn_ENonterminal :: (Seq PP_Doc), visitKinds_Syn_ENonterminal :: (Map VisitIdentifier VisitKind), visitdefs_Syn_ENonterminal :: (Map VisitIdentifier (Set Identifier)), visituses_Syn_ENonterminal :: (Map VisitIdentifier (Set Identifier)) } {-# INLINABLE wrap_ENonterminal #-} wrap_ENonterminal :: T_ENonterminal -> Inh_ENonterminal -> (Syn_ENonterminal ) wrap_ENonterminal (T_ENonterminal act) (Inh_ENonterminal _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIinhmap _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsIoptions _lhsIsynmap _lhsItypeSyns _lhsIwrappers) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_ENonterminal_vIn7 _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIinhmap _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsIoptions _lhsIsynmap _lhsItypeSyns _lhsIwrappers (T_ENonterminal_vOut7 _lhsOchildvisit _lhsOcode _lhsOdatas _lhsOerrors _lhsOfromToStates _lhsOinitStates _lhsOmodules _lhsOsemFunBndDefs _lhsOsemFunBndTps _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses) <- return (inv_ENonterminal_s8 sem arg) return (Syn_ENonterminal _lhsOchildvisit _lhsOcode _lhsOdatas _lhsOerrors _lhsOfromToStates _lhsOinitStates _lhsOmodules _lhsOsemFunBndDefs _lhsOsemFunBndTps _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses) ) -- cata {-# INLINE sem_ENonterminal #-} sem_ENonterminal :: ENonterminal -> T_ENonterminal sem_ENonterminal ( ENonterminal nt_ params_ classCtxs_ initial_ initialv_ nextVisits_ prevVisits_ prods_ recursive_ hoInfo_ ) = sem_ENonterminal_ENonterminal nt_ params_ classCtxs_ initial_ initialv_ nextVisits_ prevVisits_ ( sem_EProductions prods_ ) recursive_ hoInfo_ -- semantic domain newtype T_ENonterminal = T_ENonterminal { attach_T_ENonterminal :: Identity (T_ENonterminal_s8 ) } newtype T_ENonterminal_s8 = C_ENonterminal_s8 { inv_ENonterminal_s8 :: (T_ENonterminal_v7 ) } data T_ENonterminal_s9 = C_ENonterminal_s9 type T_ENonterminal_v7 = (T_ENonterminal_vIn7 ) -> (T_ENonterminal_vOut7 ) data T_ENonterminal_vIn7 = T_ENonterminal_vIn7 (Map VisitIdentifier (Int,Int)) (Map NontermIdent Int) (Map VisitIdentifier VisitKind) (Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) (Map VisitIdentifier (Set Identifier)) (Map VisitIdentifier (Set Identifier)) (Map NontermIdent Attributes) (Map NontermIdent (Map ConstructorIdent (Map Identifier Type))) (String) (String) (Options) (Map NontermIdent Attributes) (TypeSyns) (Set NontermIdent) data T_ENonterminal_vOut7 = T_ENonterminal_vOut7 (Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) (PP_Doc) (PP_Doc) (Seq Error) (Map VisitIdentifier (Int,Int)) (Map NontermIdent Int) (PP_Doc) (Seq PP_Doc) (Seq PP_Doc) (Map VisitIdentifier VisitKind) (Map VisitIdentifier (Set Identifier)) (Map VisitIdentifier (Set Identifier)) {-# NOINLINE sem_ENonterminal_ENonterminal #-} sem_ENonterminal_ENonterminal :: (NontermIdent) -> ([Identifier]) -> (ClassContext) -> (StateIdentifier) -> (Maybe VisitIdentifier) -> (Map StateIdentifier StateCtx) -> (Map StateIdentifier StateCtx) -> T_EProductions -> (Bool) -> (HigherOrderInfo) -> T_ENonterminal sem_ENonterminal_ENonterminal arg_nt_ arg_params_ _ arg_initial_ arg_initialv_ arg_nextVisits_ arg_prevVisits_ arg_prods_ _ _ = T_ENonterminal (return st8) where {-# NOINLINE st8 #-} st8 = let v7 :: T_ENonterminal_v7 v7 = \ (T_ENonterminal_vIn7 _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIinhmap _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsIoptions _lhsIsynmap _lhsItypeSyns _lhsIwrappers) -> ( let _prodsX17 = Control.Monad.Identity.runIdentity (attach_T_EProductions (arg_prods_)) (T_EProductions_vOut16 _prodsIallvisits _prodsIchildvisit _prodsIcount _prodsIdatatype _prodsIdatatype_call _prodsIdatatype_con _prodsIerrors _prodsIfromToStates _prodsIsemFunBndDefs _prodsIsemFunBndTps _prodsIsem_nt _prodsIsem_prod _prodsIt_visits _prodsIvisitKinds _prodsIvisitdefs _prodsIvisituses) = inv_EProductions_s17 _prodsX17 (T_EProductions_vIn16 _prodsOallFromToStates _prodsOallInhmap _prodsOallInitStates _prodsOallSynmap _prodsOallVisitKinds _prodsOallchildvisit _prodsOallstates _prodsOavisitdefs _prodsOavisituses _prodsOinhmap _prodsOinitial _prodsOlocalAttrTypes _prodsOmainFile _prodsOmainName _prodsOnextVisits _prodsOnt _prodsOntType _prodsOoptions _prodsOparams _prodsOprevVisits _prodsOrename _prodsOsynmap) _prodsOrename = rule48 _lhsIoptions _prodsOnt = rule49 arg_nt_ _prodsOparams = rule50 arg_params_ _lhsOdatas :: PP_Doc _lhsOdatas = rule51 _c_states _datatypeNt _datatypeProds _hasWrapper _lhsIoptions _prodsIt_visits _t_init _t_states _wr_inh _wr_syn arg_nt_ _lhsOcode :: PP_Doc _lhsOcode = rule52 _datatypeCon _hasWrapper _lhsIoptions _prodsIsem_prod _sem_nt _wrapper arg_nt_ _lhsOmodules :: PP_Doc _lhsOmodules = rule53 _moduleDecl _hasWrapper = rule54 _lhsIwrappers arg_nt_ _t_params = rule55 arg_params_ _aliasPre = rule56 _t_params arg_nt_ _aliasMod = rule57 _aliasPre arg_nt_ _datatypeNt = rule58 _aliasMod _aliasPre _lhsItypeSyns _prodsIdatatype _prodsIdatatype_call _t_params arg_nt_ _datatypeCon = rule59 _lhsItypeSyns _prodsIdatatype_con arg_nt_ _moduleDecl = rule60 _lhsItypeSyns arg_nt_ _datatypeProds = rule61 _prodsIdatatype _fsemname = rule62 _lhsIoptions _semname = rule63 _fsemname arg_nt_ _frecarg = rule64 _fsemname _sem_param_tp = rule65 _t_params arg_nt_ _sem_res_tp = rule66 _t_params _t_type _sem_tp = rule67 _sem_param_tp _sem_res_tp _o_sigs = rule68 _lhsIoptions _sem_nt_body = rule69 _prodsIsem_nt _sem_nt = rule70 _frecarg _fsemname _lhsItypeSyns _o_sigs _sem_nt_body _sem_param_tp _sem_res_tp _semname arg_nt_ (Just _prodsOinhmap) = rule71 _lhsIinhmap arg_nt_ (Just _prodsOsynmap) = rule72 _lhsIsynmap arg_nt_ _prodsOallInhmap = rule73 _lhsIinhmap _prodsOallSynmap = rule74 _lhsIsynmap _allstates = rule75 _prodsIallvisits arg_initial_ _stvisits = rule76 _prodsIallvisits _t_type = rule77 arg_nt_ _t_c_params = rule78 arg_params_ _t_init = rule79 _t_params _t_type arg_initial_ arg_nt_ _t_states = rule80 _allstates _t_c_params _t_params arg_nextVisits_ arg_nt_ _c_states = rule81 _allstates _prodsIallvisits _t_c_params arg_nextVisits_ arg_nt_ _wr_inh = rule82 _genwrap _wr_inhs1 _wr_syn = rule83 _genwrap _wr_syns _genwrap = rule84 _t_params arg_nt_ _inhAttrs = rule85 _lhsIinhmap arg_nt_ _wr_inhs = rule86 _inhAttrs _wr_filter _wr_inhs1 = rule87 _inhAttrs _wr_filter = rule88 _lhsIoptions _wr_syns = rule89 _lhsIsynmap arg_nt_ _wrapname = rule90 arg_nt_ _inhname = rule91 arg_nt_ _synname = rule92 arg_nt_ _firstVisitInfo = rule93 arg_initial_ arg_nextVisits_ _wrapArgSemTp = rule94 _t_params _t_type _wrapArgInhTp = rule95 _inhname _t_params _wrapArgPats = rule96 _wr_inhs1 arg_nt_ _wrapResTp = rule97 _synname _t_params _wrapper = rule98 _o_sigs _wrapArgInhTp _wrapArgPats _wrapArgSemTp _wrapResTp _wrapname _wrapperPreamble _wrapperPreamble = rule99 _lhsImainName _lhsIoptions _wrapperBody _wrapperBody = rule100 _firstVisitInfo _wr_inhs _wr_syns arg_initial_ arg_initialv_ arg_nt_ _lhsOsemFunBndDefs :: Seq PP_Doc _lhsOsemFunBndDefs = rule101 _prodsIsemFunBndDefs _semFunBndDef _lhsOsemFunBndTps :: Seq PP_Doc _lhsOsemFunBndTps = rule102 _prodsIsemFunBndTps _semFunBndTp _semFunBndDef = rule103 _semFunBndNm _semname _semFunBndTp = rule104 _semFunBndNm _sem_tp _semFunBndNm = rule105 arg_nt_ _prodsOinitial = rule106 arg_initial_ _prodsOallstates = rule107 _allstates _prodsOnextVisits = rule108 arg_nextVisits_ _prodsOprevVisits = rule109 arg_prevVisits_ _prodsOlocalAttrTypes = rule110 _lhsIlocalAttrTypes arg_nt_ _lhsOinitStates :: Map NontermIdent Int _lhsOinitStates = rule111 arg_initial_ arg_nt_ _ntType = rule112 arg_nt_ arg_params_ _lhsOchildvisit :: Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc) _lhsOchildvisit = rule113 _prodsIchildvisit _lhsOerrors :: Seq Error _lhsOerrors = rule114 _prodsIerrors _lhsOfromToStates :: Map VisitIdentifier (Int,Int) _lhsOfromToStates = rule115 _prodsIfromToStates _lhsOvisitKinds :: Map VisitIdentifier VisitKind _lhsOvisitKinds = rule116 _prodsIvisitKinds _lhsOvisitdefs :: Map VisitIdentifier (Set Identifier) _lhsOvisitdefs = rule117 _prodsIvisitdefs _lhsOvisituses :: Map VisitIdentifier (Set Identifier) _lhsOvisituses = rule118 _prodsIvisituses _prodsOallFromToStates = rule119 _lhsIallFromToStates _prodsOallInitStates = rule120 _lhsIallInitStates _prodsOallVisitKinds = rule121 _lhsIallVisitKinds _prodsOallchildvisit = rule122 _lhsIallchildvisit _prodsOavisitdefs = rule123 _lhsIavisitdefs _prodsOavisituses = rule124 _lhsIavisituses _prodsOmainFile = rule125 _lhsImainFile _prodsOmainName = rule126 _lhsImainName _prodsOntType = rule127 _ntType _prodsOoptions = rule128 _lhsIoptions __result_ = T_ENonterminal_vOut7 _lhsOchildvisit _lhsOcode _lhsOdatas _lhsOerrors _lhsOfromToStates _lhsOinitStates _lhsOmodules _lhsOsemFunBndDefs _lhsOsemFunBndTps _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses in __result_ ) in C_ENonterminal_s8 v7 {-# INLINE rule48 #-} {-# LINE 76 "./src-ag/ExecutionPlan2Caml.ag" #-} rule48 = \ ((_lhsIoptions) :: Options) -> {-# LINE 76 "./src-ag/ExecutionPlan2Caml.ag" #-} rename _lhsIoptions {-# LINE 890 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule49 #-} {-# LINE 84 "./src-ag/ExecutionPlan2Caml.ag" #-} rule49 = \ nt_ -> {-# LINE 84 "./src-ag/ExecutionPlan2Caml.ag" #-} nt_ {-# LINE 896 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule50 #-} {-# LINE 94 "./src-ag/ExecutionPlan2Caml.ag" #-} rule50 = \ params_ -> {-# LINE 94 "./src-ag/ExecutionPlan2Caml.ag" #-} params_ {-# LINE 902 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule51 #-} {-# LINE 113 "./src-ag/ExecutionPlan2Caml.ag" #-} rule51 = \ _c_states _datatypeNt _datatypeProds _hasWrapper ((_lhsIoptions) :: Options) ((_prodsIt_visits) :: PP_Doc) _t_init _t_states _wr_inh _wr_syn nt_ -> {-# LINE 113 "./src-ag/ExecutionPlan2Caml.ag" #-} ( text "" >-< "(* *** " ++ getName nt_ ++ " *** [data] *)") >-< (if dataTypes _lhsIoptions then pp "(* data *)" >-< _datatypeNt >-< _datatypeProds >-< "" else empty) >-< (if _hasWrapper then pp "(* wrapper *)" >-< _wr_inh >-< _wr_syn >-< "" else empty) >-< (if semfuns _lhsIoptions then pp "(* semantic domain *)" >-< _t_init >-< _t_states >-< _c_states >-< _prodsIt_visits >-< "" else empty) {-# LINE 929 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule52 #-} {-# LINE 136 "./src-ag/ExecutionPlan2Caml.ag" #-} rule52 = \ _datatypeCon _hasWrapper ((_lhsIoptions) :: Options) ((_prodsIsem_prod) :: PP_Doc) _sem_nt _wrapper nt_ -> {-# LINE 136 "./src-ag/ExecutionPlan2Caml.ag" #-} ( text "" >-< "(* *** " ++ getName nt_ ++ " *** [code] *)") >-< (if dataTypes _lhsIoptions then pp "(* constructor functions *)" >-< _datatypeCon else empty) >-< (if _hasWrapper then pp "(* wrapper *)" >-< _wrapper >-< "" else empty) >-< (if folds _lhsIoptions then "(* cata *)" >-< _sem_nt >-< "" else empty) >-< (if semfuns _lhsIoptions then "(* semantic domain *)" >-< _prodsIsem_prod >-< "" else empty) {-# LINE 955 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule53 #-} {-# LINE 161 "./src-ag/ExecutionPlan2Caml.ag" #-} rule53 = \ _moduleDecl -> {-# LINE 161 "./src-ag/ExecutionPlan2Caml.ag" #-} _moduleDecl {-# LINE 961 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule54 #-} {-# LINE 163 "./src-ag/ExecutionPlan2Caml.ag" #-} rule54 = \ ((_lhsIwrappers) :: Set NontermIdent) nt_ -> {-# LINE 163 "./src-ag/ExecutionPlan2Caml.ag" #-} nt_ `Set.member` _lhsIwrappers {-# LINE 967 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule55 #-} {-# LINE 214 "./src-ag/ExecutionPlan2Caml.ag" #-} rule55 = \ params_ -> {-# LINE 214 "./src-ag/ExecutionPlan2Caml.ag" #-} ppTypeParams params_ {-# LINE 973 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule56 #-} {-# LINE 215 "./src-ag/ExecutionPlan2Caml.ag" #-} rule56 = \ _t_params nt_ -> {-# LINE 215 "./src-ag/ExecutionPlan2Caml.ag" #-} "and" >#< _t_params >#< nt_ >#< "=" {-# LINE 979 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule57 #-} {-# LINE 216 "./src-ag/ExecutionPlan2Caml.ag" #-} rule57 = \ _aliasPre nt_ -> {-# LINE 216 "./src-ag/ExecutionPlan2Caml.ag" #-} _aliasPre >#< modName nt_ >|< ".t" {-# LINE 985 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule58 #-} {-# LINE 218 "./src-ag/ExecutionPlan2Caml.ag" #-} rule58 = \ _aliasMod _aliasPre ((_lhsItypeSyns) :: TypeSyns) ((_prodsIdatatype) :: [PP_Doc]) ((_prodsIdatatype_call) :: [PP_Doc]) _t_params nt_ -> {-# LINE 218 "./src-ag/ExecutionPlan2Caml.ag" #-} case lookup nt_ _lhsItypeSyns of Just (List t) -> _aliasPre >#< ppTp t >#< "list" Just (Maybe t) -> _aliasPre >#< ppTp t >#< "option" Just (Tuple ts) -> _aliasPre >#< (pp_block "(" ")" " * " $ map (ppTp . snd) ts) Just (Map k v) -> _aliasMod Just (IntMap t) -> _aliasMod Just (OrdSet t) -> _aliasMod Just IntSet -> _aliasMod _ -> "and" >#< _t_params >#< nt_ >#< "=" >-< ( if null _prodsIdatatype then pp "unit" else indent 2 $ vlist _prodsIdatatype_call ) {-# LINE 1003 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule59 #-} {-# LINE 237 "./src-ag/ExecutionPlan2Caml.ag" #-} rule59 = \ ((_lhsItypeSyns) :: TypeSyns) ((_prodsIdatatype_con) :: [PP_Doc]) nt_ -> {-# LINE 237 "./src-ag/ExecutionPlan2Caml.ag" #-} case lookup nt_ _lhsItypeSyns of Just _ -> empty Nothing -> vlist _prodsIdatatype_con {-# LINE 1011 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule60 #-} {-# LINE 242 "./src-ag/ExecutionPlan2Caml.ag" #-} rule60 = \ ((_lhsItypeSyns) :: TypeSyns) nt_ -> {-# LINE 242 "./src-ag/ExecutionPlan2Caml.ag" #-} let ppModule :: PP a => a -> PP_Doc ppModule expr = "module" >#< modName nt_ >#< "=" in case lookup nt_ _lhsItypeSyns 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 {-# LINE 1024 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule61 #-} {-# LINE 251 "./src-ag/ExecutionPlan2Caml.ag" #-} rule61 = \ ((_prodsIdatatype) :: [PP_Doc]) -> {-# LINE 251 "./src-ag/ExecutionPlan2Caml.ag" #-} vlist _prodsIdatatype {-# LINE 1030 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule62 #-} {-# LINE 311 "./src-ag/ExecutionPlan2Caml.ag" #-} rule62 = \ ((_lhsIoptions) :: Options) -> {-# LINE 311 "./src-ag/ExecutionPlan2Caml.ag" #-} \x -> prefix _lhsIoptions ++ show x {-# LINE 1036 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule63 #-} {-# LINE 312 "./src-ag/ExecutionPlan2Caml.ag" #-} rule63 = \ _fsemname nt_ -> {-# LINE 312 "./src-ag/ExecutionPlan2Caml.ag" #-} _fsemname nt_ {-# LINE 1042 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule64 #-} {-# LINE 313 "./src-ag/ExecutionPlan2Caml.ag" #-} rule64 = \ _fsemname -> {-# LINE 313 "./src-ag/ExecutionPlan2Caml.ag" #-} \t x -> case t of NT nt _ _ -> pp_parens (_fsemname nt >#< x) _ -> x {-# LINE 1050 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule65 #-} {-# LINE 317 "./src-ag/ExecutionPlan2Caml.ag" #-} rule65 = \ _t_params nt_ -> {-# LINE 317 "./src-ag/ExecutionPlan2Caml.ag" #-} _t_params >#< nt_ {-# LINE 1056 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule66 #-} {-# LINE 318 "./src-ag/ExecutionPlan2Caml.ag" #-} rule66 = \ _t_params _t_type -> {-# LINE 318 "./src-ag/ExecutionPlan2Caml.ag" #-} _t_params >#< _t_type {-# LINE 1062 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule67 #-} {-# LINE 319 "./src-ag/ExecutionPlan2Caml.ag" #-} rule67 = \ _sem_param_tp _sem_res_tp -> {-# LINE 319 "./src-ag/ExecutionPlan2Caml.ag" #-} _sem_param_tp >#< "->" >#< _sem_res_tp {-# LINE 1068 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule68 #-} {-# LINE 321 "./src-ag/ExecutionPlan2Caml.ag" #-} rule68 = \ ((_lhsIoptions) :: Options) -> {-# LINE 321 "./src-ag/ExecutionPlan2Caml.ag" #-} typeSigs _lhsIoptions {-# LINE 1074 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule69 #-} {-# LINE 322 "./src-ag/ExecutionPlan2Caml.ag" #-} rule69 = \ ((_prodsIsem_nt) :: PP_Doc) -> {-# LINE 322 "./src-ag/ExecutionPlan2Caml.ag" #-} "match arg with" >-< (indent 2 $ _prodsIsem_nt) {-# LINE 1080 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule70 #-} {-# LINE 323 "./src-ag/ExecutionPlan2Caml.ag" #-} rule70 = \ _frecarg _fsemname ((_lhsItypeSyns) :: TypeSyns) _o_sigs _sem_nt_body _sem_param_tp _sem_res_tp _semname nt_ -> {-# LINE 323 "./src-ag/ExecutionPlan2Caml.ag" #-} let genSem :: PP a => a -> PP_Doc -> PP_Doc genSem nm body = "and" >#< ppFunDecl _o_sigs (pp _semname ) [(pp nm, _sem_param_tp )] _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" >#< _semname >|< "_Entry" >#< _semname >|< "_Nil" >#< els els = case v of NT nt _ _ -> pp_parens (modName nt_ >|< ".map" >#< _fsemname nt >#< "m") _ -> pp "m" in genSem "m" body genSet mbNt = let body = "List.fold_right" >#< _semname >|< "_Entry" >#< els (pp_parens (modName nt_ >|< ".elements" >#< "s")) >#< _semname >|< "_Nil" els r = maybe r (\nt -> pp_parens ("List.map" >#< _fsemname nt >#< r)) mbNt in genSem "s" body in case lookup nt_ _lhsItypeSyns of Just (List t) -> let body = "List.fold_right" >#< _semname >|< "_Cons" >#< els >#< _semname >|< "_Nil" els = case t of NT nt _ _ -> pp_parens ("List.map" >#< _fsemname nt >#< "list") _ -> pp "list" in genSem "list" body Just (Tuple ts) -> let pat = pp_parens (ppCommas $ map fst ts) body = _semname >|< "_Tuple" >#< ppSpaced (map (\t -> _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" >#< "->" >#< "=" >#< _semname >|< "_Nothing" , "Some" >#< "just" >#< "->" >#< _semname >|< "_Just" >#< _frecarg t (pp "just") ] Just (OrdSet t) -> genSet $ case t of NT nt _ _ -> Just nt _ -> Nothing Just (IntSet) -> genSet Nothing _ -> genSem "arg" _sem_nt_body {-# LINE 1117 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule71 #-} {-# LINE 418 "./src-ag/ExecutionPlan2Caml.ag" #-} rule71 = \ ((_lhsIinhmap) :: Map NontermIdent Attributes) nt_ -> {-# LINE 418 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.lookup nt_ _lhsIinhmap {-# LINE 1123 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule72 #-} {-# LINE 419 "./src-ag/ExecutionPlan2Caml.ag" #-} rule72 = \ ((_lhsIsynmap) :: Map NontermIdent Attributes) nt_ -> {-# LINE 419 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.lookup nt_ _lhsIsynmap {-# LINE 1129 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule73 #-} {-# LINE 420 "./src-ag/ExecutionPlan2Caml.ag" #-} rule73 = \ ((_lhsIinhmap) :: Map NontermIdent Attributes) -> {-# LINE 420 "./src-ag/ExecutionPlan2Caml.ag" #-} _lhsIinhmap {-# LINE 1135 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule74 #-} {-# LINE 421 "./src-ag/ExecutionPlan2Caml.ag" #-} rule74 = \ ((_lhsIsynmap) :: Map NontermIdent Attributes) -> {-# LINE 421 "./src-ag/ExecutionPlan2Caml.ag" #-} _lhsIsynmap {-# LINE 1141 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule75 #-} {-# LINE 442 "./src-ag/ExecutionPlan2Caml.ag" #-} rule75 = \ ((_prodsIallvisits) :: [VisitStateState]) initial_ -> {-# LINE 442 "./src-ag/ExecutionPlan2Caml.ag" #-} orderStates initial_ _prodsIallvisits {-# LINE 1147 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule76 #-} {-# LINE 443 "./src-ag/ExecutionPlan2Caml.ag" #-} rule76 = \ ((_prodsIallvisits) :: [VisitStateState]) -> {-# LINE 443 "./src-ag/ExecutionPlan2Caml.ag" #-} \st -> filter (\(v,f,t) -> f == st) _prodsIallvisits {-# LINE 1153 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule77 #-} {-# LINE 444 "./src-ag/ExecutionPlan2Caml.ag" #-} rule77 = \ nt_ -> {-# LINE 444 "./src-ag/ExecutionPlan2Caml.ag" #-} type_nt_sem_top nt_ {-# LINE 1159 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule78 #-} {-# LINE 445 "./src-ag/ExecutionPlan2Caml.ag" #-} rule78 = \ params_ -> {-# LINE 445 "./src-ag/ExecutionPlan2Caml.ag" #-} ppTypeParams (cont_tvar : map pp params_) {-# LINE 1165 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule79 #-} {-# LINE 448 "./src-ag/ExecutionPlan2Caml.ag" #-} rule79 = \ _t_params _t_type initial_ nt_ -> {-# LINE 448 "./src-ag/ExecutionPlan2Caml.ag" #-} "and" >#< _t_params >#< _t_type >#< "=" >#< pp_braces ( nm_attach nt_ >#< ":" >#< "unit" >#< "->" >#< _t_params >#< type_nt_sem nt_ initial_) {-# LINE 1171 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule80 #-} {-# LINE 451 "./src-ag/ExecutionPlan2Caml.ag" #-} rule80 = \ _allstates _t_c_params _t_params nextVisits_ nt_ -> {-# LINE 451 "./src-ag/ExecutionPlan2Caml.ag" #-} 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" >#< _t_params >#< t_st >#< "=" in case nextVisits of NoneVis -> decl >#< "unit" _ -> decl >#< ppRecordVal [ nm_invoke nt_ st >#< ":" >#< cont_tvar >#< "." >#< _t_c_params >#< c_st >#< "->" >#< cont_tvar ] ) _allstates {-# LINE 1186 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule81 #-} {-# LINE 504 "./src-ag/ExecutionPlan2Caml.ag" #-} rule81 = \ _allstates ((_prodsIallvisits) :: [VisitStateState]) _t_c_params nextVisits_ nt_ -> {-# LINE 504 "./src-ag/ExecutionPlan2Caml.ag" #-} vlist $ map (\st -> let nt_st = type_nt_state nt_ st c_st = type_caller nt_ st outg = filter (\(_,f,_) -> f == st) _prodsIallvisits nextVisits = Map.findWithDefault ManyVis st nextVisits_ declHead = "and" >#< _t_c_params >#< c_st >#< "=" visitcons = vlist $ map (\(v,_,_) -> "|" >#< con_visit nt_ v >#< "of" >#< _t_c_params >#< type_caller_visit nt_ v ) outg in case nextVisits of NoneVis -> empty OneVis v -> declHead >#< _t_c_params >#< type_caller_visit nt_ v ManyVis -> declHead >-< indent 3 visitcons ) _allstates {-# LINE 1205 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule82 #-} {-# LINE 586 "./src-ag/ExecutionPlan2Caml.ag" #-} rule82 = \ _genwrap _wr_inhs1 -> {-# LINE 586 "./src-ag/ExecutionPlan2Caml.ag" #-} _genwrap "inh" _wr_inhs1 {-# LINE 1211 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule83 #-} {-# LINE 587 "./src-ag/ExecutionPlan2Caml.ag" #-} rule83 = \ _genwrap _wr_syns -> {-# LINE 587 "./src-ag/ExecutionPlan2Caml.ag" #-} _genwrap "syn" _wr_syns {-# LINE 1217 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule84 #-} {-# LINE 588 "./src-ag/ExecutionPlan2Caml.ag" #-} rule84 = \ _t_params nt_ -> {-# LINE 588 "./src-ag/ExecutionPlan2Caml.ag" #-} \nm attrs -> "and" >#< _t_params >#< nm >|< "_" >|< nt_ >#< "=" >#< ppRecordTp [ i >|< "_" >|< nm >|< "_" >|< nt_ >#< ":" >#< ppTp t | (i,t) <- attrs ] {-# LINE 1225 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule85 #-} {-# LINE 592 "./src-ag/ExecutionPlan2Caml.ag" #-} rule85 = \ ((_lhsIinhmap) :: Map NontermIdent Attributes) nt_ -> {-# LINE 592 "./src-ag/ExecutionPlan2Caml.ag" #-} fromJust $ Map.lookup nt_ _lhsIinhmap {-# LINE 1231 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule86 #-} {-# LINE 593 "./src-ag/ExecutionPlan2Caml.ag" #-} rule86 = \ _inhAttrs _wr_filter -> {-# LINE 593 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.toList $ _wr_filter $ _inhAttrs {-# LINE 1237 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule87 #-} {-# LINE 594 "./src-ag/ExecutionPlan2Caml.ag" #-} rule87 = \ _inhAttrs -> {-# LINE 594 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.toList _inhAttrs {-# LINE 1243 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule88 #-} {-# LINE 595 "./src-ag/ExecutionPlan2Caml.ag" #-} rule88 = \ ((_lhsIoptions) :: Options) -> {-# LINE 595 "./src-ag/ExecutionPlan2Caml.ag" #-} if kennedyWarren _lhsIoptions && lateHigherOrderBinding _lhsIoptions then Map.delete idLateBindingAttr else id {-# LINE 1251 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule89 #-} {-# LINE 598 "./src-ag/ExecutionPlan2Caml.ag" #-} rule89 = \ ((_lhsIsynmap) :: Map NontermIdent Attributes) nt_ -> {-# LINE 598 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.toList $ fromJust $ Map.lookup nt_ _lhsIsynmap {-# LINE 1257 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule90 #-} {-# LINE 600 "./src-ag/ExecutionPlan2Caml.ag" #-} rule90 = \ nt_ -> {-# LINE 600 "./src-ag/ExecutionPlan2Caml.ag" #-} text ("wrap_" ++ show nt_) {-# LINE 1263 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule91 #-} {-# LINE 601 "./src-ag/ExecutionPlan2Caml.ag" #-} rule91 = \ nt_ -> {-# LINE 601 "./src-ag/ExecutionPlan2Caml.ag" #-} text ("inh_" ++ show nt_) {-# LINE 1269 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule92 #-} {-# LINE 602 "./src-ag/ExecutionPlan2Caml.ag" #-} rule92 = \ nt_ -> {-# LINE 602 "./src-ag/ExecutionPlan2Caml.ag" #-} text ("syn_" ++ show nt_) {-# LINE 1275 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule93 #-} {-# LINE 603 "./src-ag/ExecutionPlan2Caml.ag" #-} rule93 = \ initial_ nextVisits_ -> {-# LINE 603 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.findWithDefault ManyVis initial_ nextVisits_ {-# LINE 1281 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule94 #-} {-# LINE 605 "./src-ag/ExecutionPlan2Caml.ag" #-} rule94 = \ _t_params _t_type -> {-# LINE 605 "./src-ag/ExecutionPlan2Caml.ag" #-} _t_params >#< _t_type {-# LINE 1287 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule95 #-} {-# LINE 606 "./src-ag/ExecutionPlan2Caml.ag" #-} rule95 = \ _inhname _t_params -> {-# LINE 606 "./src-ag/ExecutionPlan2Caml.ag" #-} _t_params >#< _inhname {-# LINE 1293 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule96 #-} {-# LINE 607 "./src-ag/ExecutionPlan2Caml.ag" #-} rule96 = \ _wr_inhs1 nt_ -> {-# LINE 607 "./src-ag/ExecutionPlan2Caml.ag" #-} ppRecordVal [ i >|< "_inh_" >|< nt_ >#< "=" >#< lhsname True i | (i,_) <- _wr_inhs1 ] {-# LINE 1299 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule97 #-} {-# LINE 608 "./src-ag/ExecutionPlan2Caml.ag" #-} rule97 = \ _synname _t_params -> {-# LINE 608 "./src-ag/ExecutionPlan2Caml.ag" #-} _t_params >#< _synname {-# LINE 1305 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule98 #-} {-# LINE 609 "./src-ag/ExecutionPlan2Caml.ag" #-} rule98 = \ _o_sigs _wrapArgInhTp _wrapArgPats _wrapArgSemTp _wrapResTp _wrapname _wrapperPreamble -> {-# LINE 609 "./src-ag/ExecutionPlan2Caml.ag" #-} "and" >#< ppFunDecl _o_sigs _wrapname [(pp "act", _wrapArgSemTp ), (_wrapArgPats , _wrapArgInhTp )] _wrapResTp _wrapperPreamble {-# LINE 1311 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule99 #-} {-# LINE 611 "./src-ag/ExecutionPlan2Caml.ag" #-} rule99 = \ ((_lhsImainName) :: String) ((_lhsIoptions) :: Options) _wrapperBody -> {-# LINE 611 "./src-ag/ExecutionPlan2Caml.ag" #-} ( if lateHigherOrderBinding _lhsIoptions then "let" >#< lhsname True idLateBindingAttr >#< "=" >#< lateBindingFieldNm _lhsImainName >#< "in" else empty ) >-< _wrapperBody {-# LINE 1321 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule100 #-} {-# LINE 617 "./src-ag/ExecutionPlan2Caml.ag" #-} rule100 = \ _firstVisitInfo _wr_inhs _wr_syns initial_ initialv_ nt_ -> {-# LINE 617 "./src-ag/ExecutionPlan2Caml.ag" #-} case initialv_ of Nothing -> text "{ }" Just initv -> let attach = "let" >#< "sem" >#< "=" >#< "act." >|< nm_attach nt_ >#< "()" >#< "in" pat = ppRecordVal [ nm_outarg i nt_ initv >#< "=" >#< lhsname False i | (i,_) <- _wr_syns ] bld = ppRecordVal [ i >|< "_syn_" >|< nt_ >#< "=" >#< lhsname False i | (i,_) <- _wr_syns ] res = "let res = function" >#< pat >#< "->" >#< bld >#< "in" inps = "let" >#< "inps" >#< "=" >#< ppRecordVal [ nm_inarg i nt_ initv >#< "=" >#< lhsname True i | (i,_) <- _wr_inhs ] >#< "in" arg = "let" >#< "arg" >#< "=" >#< argcon >#< argrec >#< "in" argcon = case _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" in attach >-< res >-< inps >-< arg >-< invoke {-# LINE 1344 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule101 #-} {-# LINE 646 "./src-ag/ExecutionPlan2Caml.ag" #-} rule101 = \ ((_prodsIsemFunBndDefs) :: Seq PP_Doc) _semFunBndDef -> {-# LINE 646 "./src-ag/ExecutionPlan2Caml.ag" #-} _semFunBndDef Seq.<| _prodsIsemFunBndDefs {-# LINE 1350 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule102 #-} {-# LINE 647 "./src-ag/ExecutionPlan2Caml.ag" #-} rule102 = \ ((_prodsIsemFunBndTps) :: Seq PP_Doc) _semFunBndTp -> {-# LINE 647 "./src-ag/ExecutionPlan2Caml.ag" #-} _semFunBndTp Seq.<| _prodsIsemFunBndTps {-# LINE 1356 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule103 #-} {-# LINE 648 "./src-ag/ExecutionPlan2Caml.ag" #-} rule103 = \ _semFunBndNm _semname -> {-# LINE 648 "./src-ag/ExecutionPlan2Caml.ag" #-} _semFunBndNm >#< "=" >#< _semname {-# LINE 1362 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule104 #-} {-# LINE 649 "./src-ag/ExecutionPlan2Caml.ag" #-} rule104 = \ _semFunBndNm _sem_tp -> {-# LINE 649 "./src-ag/ExecutionPlan2Caml.ag" #-} _semFunBndNm >#< ":" >#< _sem_tp {-# LINE 1368 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule105 #-} {-# LINE 650 "./src-ag/ExecutionPlan2Caml.ag" #-} rule105 = \ nt_ -> {-# LINE 650 "./src-ag/ExecutionPlan2Caml.ag" #-} lateSemNtLabel nt_ {-# LINE 1374 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule106 #-} {-# LINE 680 "./src-ag/ExecutionPlan2Caml.ag" #-} rule106 = \ initial_ -> {-# LINE 680 "./src-ag/ExecutionPlan2Caml.ag" #-} initial_ {-# LINE 1380 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule107 #-} {-# LINE 681 "./src-ag/ExecutionPlan2Caml.ag" #-} rule107 = \ _allstates -> {-# LINE 681 "./src-ag/ExecutionPlan2Caml.ag" #-} _allstates {-# LINE 1386 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule108 #-} {-# LINE 1387 "./src-ag/ExecutionPlan2Caml.ag" #-} rule108 = \ nextVisits_ -> {-# LINE 1387 "./src-ag/ExecutionPlan2Caml.ag" #-} nextVisits_ {-# LINE 1392 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule109 #-} {-# LINE 1388 "./src-ag/ExecutionPlan2Caml.ag" #-} rule109 = \ prevVisits_ -> {-# LINE 1388 "./src-ag/ExecutionPlan2Caml.ag" #-} prevVisits_ {-# LINE 1398 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule110 #-} {-# LINE 1432 "./src-ag/ExecutionPlan2Caml.ag" #-} rule110 = \ ((_lhsIlocalAttrTypes) :: Map NontermIdent (Map ConstructorIdent (Map Identifier Type))) nt_ -> {-# LINE 1432 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.findWithDefault Map.empty nt_ _lhsIlocalAttrTypes {-# LINE 1404 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule111 #-} {-# LINE 1459 "./src-ag/ExecutionPlan2Caml.ag" #-} rule111 = \ initial_ nt_ -> {-# LINE 1459 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.singleton nt_ initial_ {-# LINE 1410 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule112 #-} {-# LINE 1473 "./src-ag/ExecutionPlan2Caml.ag" #-} rule112 = \ nt_ params_ -> {-# LINE 1473 "./src-ag/ExecutionPlan2Caml.ag" #-} NT nt_ (map show params_) False {-# LINE 1416 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule113 #-} rule113 = \ ((_prodsIchildvisit) :: Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) -> _prodsIchildvisit {-# INLINE rule114 #-} rule114 = \ ((_prodsIerrors) :: Seq Error) -> _prodsIerrors {-# INLINE rule115 #-} rule115 = \ ((_prodsIfromToStates) :: Map VisitIdentifier (Int,Int)) -> _prodsIfromToStates {-# INLINE rule116 #-} rule116 = \ ((_prodsIvisitKinds) :: Map VisitIdentifier VisitKind) -> _prodsIvisitKinds {-# INLINE rule117 #-} rule117 = \ ((_prodsIvisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _prodsIvisitdefs {-# INLINE rule118 #-} rule118 = \ ((_prodsIvisituses) :: Map VisitIdentifier (Set Identifier)) -> _prodsIvisituses {-# INLINE rule119 #-} rule119 = \ ((_lhsIallFromToStates) :: Map VisitIdentifier (Int,Int)) -> _lhsIallFromToStates {-# INLINE rule120 #-} rule120 = \ ((_lhsIallInitStates) :: Map NontermIdent Int) -> _lhsIallInitStates {-# INLINE rule121 #-} rule121 = \ ((_lhsIallVisitKinds) :: Map VisitIdentifier VisitKind) -> _lhsIallVisitKinds {-# INLINE rule122 #-} rule122 = \ ((_lhsIallchildvisit) :: Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) -> _lhsIallchildvisit {-# INLINE rule123 #-} rule123 = \ ((_lhsIavisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisitdefs {-# INLINE rule124 #-} rule124 = \ ((_lhsIavisituses) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisituses {-# INLINE rule125 #-} rule125 = \ ((_lhsImainFile) :: String) -> _lhsImainFile {-# INLINE rule126 #-} rule126 = \ ((_lhsImainName) :: String) -> _lhsImainName {-# INLINE rule127 #-} rule127 = \ _ntType -> _ntType {-# INLINE rule128 #-} rule128 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions -- ENonterminals ----------------------------------------------- -- wrapper data Inh_ENonterminals = Inh_ENonterminals { allFromToStates_Inh_ENonterminals :: (Map VisitIdentifier (Int,Int)), allInitStates_Inh_ENonterminals :: (Map NontermIdent Int), allVisitKinds_Inh_ENonterminals :: (Map VisitIdentifier VisitKind), allchildvisit_Inh_ENonterminals :: (Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)), avisitdefs_Inh_ENonterminals :: (Map VisitIdentifier (Set Identifier)), avisituses_Inh_ENonterminals :: (Map VisitIdentifier (Set Identifier)), inhmap_Inh_ENonterminals :: (Map NontermIdent Attributes), localAttrTypes_Inh_ENonterminals :: (Map NontermIdent (Map ConstructorIdent (Map Identifier Type))), mainFile_Inh_ENonterminals :: (String), mainName_Inh_ENonterminals :: (String), options_Inh_ENonterminals :: (Options), synmap_Inh_ENonterminals :: (Map NontermIdent Attributes), typeSyns_Inh_ENonterminals :: (TypeSyns), wrappers_Inh_ENonterminals :: (Set NontermIdent) } data Syn_ENonterminals = Syn_ENonterminals { childvisit_Syn_ENonterminals :: (Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)), code_Syn_ENonterminals :: (PP_Doc), datas_Syn_ENonterminals :: (PP_Doc), errors_Syn_ENonterminals :: (Seq Error), fromToStates_Syn_ENonterminals :: (Map VisitIdentifier (Int,Int)), initStates_Syn_ENonterminals :: (Map NontermIdent Int), modules_Syn_ENonterminals :: (PP_Doc), semFunBndDefs_Syn_ENonterminals :: (Seq PP_Doc), semFunBndTps_Syn_ENonterminals :: (Seq PP_Doc), visitKinds_Syn_ENonterminals :: (Map VisitIdentifier VisitKind), visitdefs_Syn_ENonterminals :: (Map VisitIdentifier (Set Identifier)), visituses_Syn_ENonterminals :: (Map VisitIdentifier (Set Identifier)) } {-# INLINABLE wrap_ENonterminals #-} wrap_ENonterminals :: T_ENonterminals -> Inh_ENonterminals -> (Syn_ENonterminals ) wrap_ENonterminals (T_ENonterminals act) (Inh_ENonterminals _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIinhmap _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsIoptions _lhsIsynmap _lhsItypeSyns _lhsIwrappers) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_ENonterminals_vIn10 _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIinhmap _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsIoptions _lhsIsynmap _lhsItypeSyns _lhsIwrappers (T_ENonterminals_vOut10 _lhsOchildvisit _lhsOcode _lhsOdatas _lhsOerrors _lhsOfromToStates _lhsOinitStates _lhsOmodules _lhsOsemFunBndDefs _lhsOsemFunBndTps _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses) <- return (inv_ENonterminals_s11 sem arg) return (Syn_ENonterminals _lhsOchildvisit _lhsOcode _lhsOdatas _lhsOerrors _lhsOfromToStates _lhsOinitStates _lhsOmodules _lhsOsemFunBndDefs _lhsOsemFunBndTps _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses) ) -- cata {-# NOINLINE sem_ENonterminals #-} sem_ENonterminals :: ENonterminals -> T_ENonterminals sem_ENonterminals list = Prelude.foldr sem_ENonterminals_Cons sem_ENonterminals_Nil (Prelude.map sem_ENonterminal list) -- semantic domain newtype T_ENonterminals = T_ENonterminals { attach_T_ENonterminals :: Identity (T_ENonterminals_s11 ) } newtype T_ENonterminals_s11 = C_ENonterminals_s11 { inv_ENonterminals_s11 :: (T_ENonterminals_v10 ) } data T_ENonterminals_s12 = C_ENonterminals_s12 type T_ENonterminals_v10 = (T_ENonterminals_vIn10 ) -> (T_ENonterminals_vOut10 ) data T_ENonterminals_vIn10 = T_ENonterminals_vIn10 (Map VisitIdentifier (Int,Int)) (Map NontermIdent Int) (Map VisitIdentifier VisitKind) (Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) (Map VisitIdentifier (Set Identifier)) (Map VisitIdentifier (Set Identifier)) (Map NontermIdent Attributes) (Map NontermIdent (Map ConstructorIdent (Map Identifier Type))) (String) (String) (Options) (Map NontermIdent Attributes) (TypeSyns) (Set NontermIdent) data T_ENonterminals_vOut10 = T_ENonterminals_vOut10 (Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) (PP_Doc) (PP_Doc) (Seq Error) (Map VisitIdentifier (Int,Int)) (Map NontermIdent Int) (PP_Doc) (Seq PP_Doc) (Seq PP_Doc) (Map VisitIdentifier VisitKind) (Map VisitIdentifier (Set Identifier)) (Map VisitIdentifier (Set Identifier)) {-# NOINLINE sem_ENonterminals_Cons #-} sem_ENonterminals_Cons :: T_ENonterminal -> T_ENonterminals -> T_ENonterminals sem_ENonterminals_Cons arg_hd_ arg_tl_ = T_ENonterminals (return st11) where {-# NOINLINE st11 #-} st11 = let v10 :: T_ENonterminals_v10 v10 = \ (T_ENonterminals_vIn10 _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIinhmap _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsIoptions _lhsIsynmap _lhsItypeSyns _lhsIwrappers) -> ( let _hdX8 = Control.Monad.Identity.runIdentity (attach_T_ENonterminal (arg_hd_)) _tlX11 = Control.Monad.Identity.runIdentity (attach_T_ENonterminals (arg_tl_)) (T_ENonterminal_vOut7 _hdIchildvisit _hdIcode _hdIdatas _hdIerrors _hdIfromToStates _hdIinitStates _hdImodules _hdIsemFunBndDefs _hdIsemFunBndTps _hdIvisitKinds _hdIvisitdefs _hdIvisituses) = inv_ENonterminal_s8 _hdX8 (T_ENonterminal_vIn7 _hdOallFromToStates _hdOallInitStates _hdOallVisitKinds _hdOallchildvisit _hdOavisitdefs _hdOavisituses _hdOinhmap _hdOlocalAttrTypes _hdOmainFile _hdOmainName _hdOoptions _hdOsynmap _hdOtypeSyns _hdOwrappers) (T_ENonterminals_vOut10 _tlIchildvisit _tlIcode _tlIdatas _tlIerrors _tlIfromToStates _tlIinitStates _tlImodules _tlIsemFunBndDefs _tlIsemFunBndTps _tlIvisitKinds _tlIvisitdefs _tlIvisituses) = inv_ENonterminals_s11 _tlX11 (T_ENonterminals_vIn10 _tlOallFromToStates _tlOallInitStates _tlOallVisitKinds _tlOallchildvisit _tlOavisitdefs _tlOavisituses _tlOinhmap _tlOlocalAttrTypes _tlOmainFile _tlOmainName _tlOoptions _tlOsynmap _tlOtypeSyns _tlOwrappers) _lhsOchildvisit :: Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc) _lhsOchildvisit = rule129 _hdIchildvisit _tlIchildvisit _lhsOcode :: PP_Doc _lhsOcode = rule130 _hdIcode _tlIcode _lhsOdatas :: PP_Doc _lhsOdatas = rule131 _hdIdatas _tlIdatas _lhsOerrors :: Seq Error _lhsOerrors = rule132 _hdIerrors _tlIerrors _lhsOfromToStates :: Map VisitIdentifier (Int,Int) _lhsOfromToStates = rule133 _hdIfromToStates _tlIfromToStates _lhsOinitStates :: Map NontermIdent Int _lhsOinitStates = rule134 _hdIinitStates _tlIinitStates _lhsOmodules :: PP_Doc _lhsOmodules = rule135 _hdImodules _tlImodules _lhsOsemFunBndDefs :: Seq PP_Doc _lhsOsemFunBndDefs = rule136 _hdIsemFunBndDefs _tlIsemFunBndDefs _lhsOsemFunBndTps :: Seq PP_Doc _lhsOsemFunBndTps = rule137 _hdIsemFunBndTps _tlIsemFunBndTps _lhsOvisitKinds :: Map VisitIdentifier VisitKind _lhsOvisitKinds = rule138 _hdIvisitKinds _tlIvisitKinds _lhsOvisitdefs :: Map VisitIdentifier (Set Identifier) _lhsOvisitdefs = rule139 _hdIvisitdefs _tlIvisitdefs _lhsOvisituses :: Map VisitIdentifier (Set Identifier) _lhsOvisituses = rule140 _hdIvisituses _tlIvisituses _hdOallFromToStates = rule141 _lhsIallFromToStates _hdOallInitStates = rule142 _lhsIallInitStates _hdOallVisitKinds = rule143 _lhsIallVisitKinds _hdOallchildvisit = rule144 _lhsIallchildvisit _hdOavisitdefs = rule145 _lhsIavisitdefs _hdOavisituses = rule146 _lhsIavisituses _hdOinhmap = rule147 _lhsIinhmap _hdOlocalAttrTypes = rule148 _lhsIlocalAttrTypes _hdOmainFile = rule149 _lhsImainFile _hdOmainName = rule150 _lhsImainName _hdOoptions = rule151 _lhsIoptions _hdOsynmap = rule152 _lhsIsynmap _hdOtypeSyns = rule153 _lhsItypeSyns _hdOwrappers = rule154 _lhsIwrappers _tlOallFromToStates = rule155 _lhsIallFromToStates _tlOallInitStates = rule156 _lhsIallInitStates _tlOallVisitKinds = rule157 _lhsIallVisitKinds _tlOallchildvisit = rule158 _lhsIallchildvisit _tlOavisitdefs = rule159 _lhsIavisitdefs _tlOavisituses = rule160 _lhsIavisituses _tlOinhmap = rule161 _lhsIinhmap _tlOlocalAttrTypes = rule162 _lhsIlocalAttrTypes _tlOmainFile = rule163 _lhsImainFile _tlOmainName = rule164 _lhsImainName _tlOoptions = rule165 _lhsIoptions _tlOsynmap = rule166 _lhsIsynmap _tlOtypeSyns = rule167 _lhsItypeSyns _tlOwrappers = rule168 _lhsIwrappers __result_ = T_ENonterminals_vOut10 _lhsOchildvisit _lhsOcode _lhsOdatas _lhsOerrors _lhsOfromToStates _lhsOinitStates _lhsOmodules _lhsOsemFunBndDefs _lhsOsemFunBndTps _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses in __result_ ) in C_ENonterminals_s11 v10 {-# INLINE rule129 #-} rule129 = \ ((_hdIchildvisit) :: Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) ((_tlIchildvisit) :: Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) -> _hdIchildvisit `Map.union` _tlIchildvisit {-# INLINE rule130 #-} rule130 = \ ((_hdIcode) :: PP_Doc) ((_tlIcode) :: PP_Doc) -> _hdIcode >-< _tlIcode {-# INLINE rule131 #-} rule131 = \ ((_hdIdatas) :: PP_Doc) ((_tlIdatas) :: PP_Doc) -> _hdIdatas >-< _tlIdatas {-# INLINE rule132 #-} rule132 = \ ((_hdIerrors) :: Seq Error) ((_tlIerrors) :: Seq Error) -> _hdIerrors Seq.>< _tlIerrors {-# INLINE rule133 #-} rule133 = \ ((_hdIfromToStates) :: Map VisitIdentifier (Int,Int)) ((_tlIfromToStates) :: Map VisitIdentifier (Int,Int)) -> _hdIfromToStates `mappend` _tlIfromToStates {-# INLINE rule134 #-} rule134 = \ ((_hdIinitStates) :: Map NontermIdent Int) ((_tlIinitStates) :: Map NontermIdent Int) -> _hdIinitStates `mappend` _tlIinitStates {-# INLINE rule135 #-} rule135 = \ ((_hdImodules) :: PP_Doc) ((_tlImodules) :: PP_Doc) -> _hdImodules >-< _tlImodules {-# INLINE rule136 #-} rule136 = \ ((_hdIsemFunBndDefs) :: Seq PP_Doc) ((_tlIsemFunBndDefs) :: Seq PP_Doc) -> _hdIsemFunBndDefs Seq.>< _tlIsemFunBndDefs {-# INLINE rule137 #-} rule137 = \ ((_hdIsemFunBndTps) :: Seq PP_Doc) ((_tlIsemFunBndTps) :: Seq PP_Doc) -> _hdIsemFunBndTps Seq.>< _tlIsemFunBndTps {-# INLINE rule138 #-} rule138 = \ ((_hdIvisitKinds) :: Map VisitIdentifier VisitKind) ((_tlIvisitKinds) :: Map VisitIdentifier VisitKind) -> _hdIvisitKinds `mappend` _tlIvisitKinds {-# INLINE rule139 #-} rule139 = \ ((_hdIvisitdefs) :: Map VisitIdentifier (Set Identifier)) ((_tlIvisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _hdIvisitdefs `uwSetUnion` _tlIvisitdefs {-# INLINE rule140 #-} rule140 = \ ((_hdIvisituses) :: Map VisitIdentifier (Set Identifier)) ((_tlIvisituses) :: Map VisitIdentifier (Set Identifier)) -> _hdIvisituses `uwSetUnion` _tlIvisituses {-# INLINE rule141 #-} rule141 = \ ((_lhsIallFromToStates) :: Map VisitIdentifier (Int,Int)) -> _lhsIallFromToStates {-# INLINE rule142 #-} rule142 = \ ((_lhsIallInitStates) :: Map NontermIdent Int) -> _lhsIallInitStates {-# INLINE rule143 #-} rule143 = \ ((_lhsIallVisitKinds) :: Map VisitIdentifier VisitKind) -> _lhsIallVisitKinds {-# INLINE rule144 #-} rule144 = \ ((_lhsIallchildvisit) :: Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) -> _lhsIallchildvisit {-# INLINE rule145 #-} rule145 = \ ((_lhsIavisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisitdefs {-# INLINE rule146 #-} rule146 = \ ((_lhsIavisituses) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisituses {-# INLINE rule147 #-} rule147 = \ ((_lhsIinhmap) :: Map NontermIdent Attributes) -> _lhsIinhmap {-# INLINE rule148 #-} rule148 = \ ((_lhsIlocalAttrTypes) :: Map NontermIdent (Map ConstructorIdent (Map Identifier Type))) -> _lhsIlocalAttrTypes {-# INLINE rule149 #-} rule149 = \ ((_lhsImainFile) :: String) -> _lhsImainFile {-# INLINE rule150 #-} rule150 = \ ((_lhsImainName) :: String) -> _lhsImainName {-# INLINE rule151 #-} rule151 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule152 #-} rule152 = \ ((_lhsIsynmap) :: Map NontermIdent Attributes) -> _lhsIsynmap {-# INLINE rule153 #-} rule153 = \ ((_lhsItypeSyns) :: TypeSyns) -> _lhsItypeSyns {-# INLINE rule154 #-} rule154 = \ ((_lhsIwrappers) :: Set NontermIdent) -> _lhsIwrappers {-# INLINE rule155 #-} rule155 = \ ((_lhsIallFromToStates) :: Map VisitIdentifier (Int,Int)) -> _lhsIallFromToStates {-# INLINE rule156 #-} rule156 = \ ((_lhsIallInitStates) :: Map NontermIdent Int) -> _lhsIallInitStates {-# INLINE rule157 #-} rule157 = \ ((_lhsIallVisitKinds) :: Map VisitIdentifier VisitKind) -> _lhsIallVisitKinds {-# INLINE rule158 #-} rule158 = \ ((_lhsIallchildvisit) :: Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) -> _lhsIallchildvisit {-# INLINE rule159 #-} rule159 = \ ((_lhsIavisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisitdefs {-# INLINE rule160 #-} rule160 = \ ((_lhsIavisituses) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisituses {-# INLINE rule161 #-} rule161 = \ ((_lhsIinhmap) :: Map NontermIdent Attributes) -> _lhsIinhmap {-# INLINE rule162 #-} rule162 = \ ((_lhsIlocalAttrTypes) :: Map NontermIdent (Map ConstructorIdent (Map Identifier Type))) -> _lhsIlocalAttrTypes {-# INLINE rule163 #-} rule163 = \ ((_lhsImainFile) :: String) -> _lhsImainFile {-# INLINE rule164 #-} rule164 = \ ((_lhsImainName) :: String) -> _lhsImainName {-# INLINE rule165 #-} rule165 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule166 #-} rule166 = \ ((_lhsIsynmap) :: Map NontermIdent Attributes) -> _lhsIsynmap {-# INLINE rule167 #-} rule167 = \ ((_lhsItypeSyns) :: TypeSyns) -> _lhsItypeSyns {-# INLINE rule168 #-} rule168 = \ ((_lhsIwrappers) :: Set NontermIdent) -> _lhsIwrappers {-# NOINLINE sem_ENonterminals_Nil #-} sem_ENonterminals_Nil :: T_ENonterminals sem_ENonterminals_Nil = T_ENonterminals (return st11) where {-# NOINLINE st11 #-} st11 = let v10 :: T_ENonterminals_v10 v10 = \ (T_ENonterminals_vIn10 _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIinhmap _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsIoptions _lhsIsynmap _lhsItypeSyns _lhsIwrappers) -> ( let _lhsOchildvisit :: Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc) _lhsOchildvisit = rule169 () _lhsOcode :: PP_Doc _lhsOcode = rule170 () _lhsOdatas :: PP_Doc _lhsOdatas = rule171 () _lhsOerrors :: Seq Error _lhsOerrors = rule172 () _lhsOfromToStates :: Map VisitIdentifier (Int,Int) _lhsOfromToStates = rule173 () _lhsOinitStates :: Map NontermIdent Int _lhsOinitStates = rule174 () _lhsOmodules :: PP_Doc _lhsOmodules = rule175 () _lhsOsemFunBndDefs :: Seq PP_Doc _lhsOsemFunBndDefs = rule176 () _lhsOsemFunBndTps :: Seq PP_Doc _lhsOsemFunBndTps = rule177 () _lhsOvisitKinds :: Map VisitIdentifier VisitKind _lhsOvisitKinds = rule178 () _lhsOvisitdefs :: Map VisitIdentifier (Set Identifier) _lhsOvisitdefs = rule179 () _lhsOvisituses :: Map VisitIdentifier (Set Identifier) _lhsOvisituses = rule180 () __result_ = T_ENonterminals_vOut10 _lhsOchildvisit _lhsOcode _lhsOdatas _lhsOerrors _lhsOfromToStates _lhsOinitStates _lhsOmodules _lhsOsemFunBndDefs _lhsOsemFunBndTps _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses in __result_ ) in C_ENonterminals_s11 v10 {-# INLINE rule169 #-} rule169 = \ (_ :: ()) -> Map.empty {-# INLINE rule170 #-} rule170 = \ (_ :: ()) -> empty {-# INLINE rule171 #-} rule171 = \ (_ :: ()) -> empty {-# INLINE rule172 #-} rule172 = \ (_ :: ()) -> Seq.empty {-# INLINE rule173 #-} rule173 = \ (_ :: ()) -> mempty {-# INLINE rule174 #-} rule174 = \ (_ :: ()) -> mempty {-# INLINE rule175 #-} rule175 = \ (_ :: ()) -> empty {-# INLINE rule176 #-} rule176 = \ (_ :: ()) -> Seq.empty {-# INLINE rule177 #-} rule177 = \ (_ :: ()) -> Seq.empty {-# INLINE rule178 #-} rule178 = \ (_ :: ()) -> mempty {-# INLINE rule179 #-} rule179 = \ (_ :: ()) -> Map.empty {-# INLINE rule180 #-} rule180 = \ (_ :: ()) -> Map.empty -- EProduction ------------------------------------------------- -- wrapper data Inh_EProduction = Inh_EProduction { allFromToStates_Inh_EProduction :: (Map VisitIdentifier (Int,Int)), allInhmap_Inh_EProduction :: (Map NontermIdent Attributes), allInitStates_Inh_EProduction :: (Map NontermIdent Int), allSynmap_Inh_EProduction :: (Map NontermIdent Attributes), allVisitKinds_Inh_EProduction :: (Map VisitIdentifier VisitKind), allchildvisit_Inh_EProduction :: (Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)), allstates_Inh_EProduction :: ([StateIdentifier]), avisitdefs_Inh_EProduction :: (Map VisitIdentifier (Set Identifier)), avisituses_Inh_EProduction :: (Map VisitIdentifier (Set Identifier)), inhmap_Inh_EProduction :: (Attributes), initial_Inh_EProduction :: (StateIdentifier), localAttrTypes_Inh_EProduction :: (Map ConstructorIdent (Map Identifier Type)), mainFile_Inh_EProduction :: (String), mainName_Inh_EProduction :: (String), nextVisits_Inh_EProduction :: (Map StateIdentifier StateCtx), nt_Inh_EProduction :: (NontermIdent), ntType_Inh_EProduction :: (Type), options_Inh_EProduction :: (Options), params_Inh_EProduction :: ([Identifier]), prevVisits_Inh_EProduction :: (Map StateIdentifier StateCtx), rename_Inh_EProduction :: (Bool), synmap_Inh_EProduction :: (Attributes) } data Syn_EProduction = Syn_EProduction { allvisits_Syn_EProduction :: ([VisitStateState]), childvisit_Syn_EProduction :: (Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)), count_Syn_EProduction :: (Int), datatype_Syn_EProduction :: (PP_Doc), datatype_call_Syn_EProduction :: (PP_Doc), datatype_con_Syn_EProduction :: (PP_Doc), errors_Syn_EProduction :: (Seq Error), fromToStates_Syn_EProduction :: (Map VisitIdentifier (Int,Int)), semFunBndDefs_Syn_EProduction :: (Seq PP_Doc), semFunBndTps_Syn_EProduction :: (Seq PP_Doc), sem_nt_Syn_EProduction :: (PP_Doc), sem_prod_Syn_EProduction :: (PP_Doc), t_visits_Syn_EProduction :: (PP_Doc), visitKinds_Syn_EProduction :: (Map VisitIdentifier VisitKind), visitdefs_Syn_EProduction :: (Map VisitIdentifier (Set Identifier)), visituses_Syn_EProduction :: (Map VisitIdentifier (Set Identifier)) } {-# INLINABLE wrap_EProduction #-} wrap_EProduction :: T_EProduction -> Inh_EProduction -> (Syn_EProduction ) wrap_EProduction (T_EProduction act) (Inh_EProduction _lhsIallFromToStates _lhsIallInhmap _lhsIallInitStates _lhsIallSynmap _lhsIallVisitKinds _lhsIallchildvisit _lhsIallstates _lhsIavisitdefs _lhsIavisituses _lhsIinhmap _lhsIinitial _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsInextVisits _lhsInt _lhsIntType _lhsIoptions _lhsIparams _lhsIprevVisits _lhsIrename _lhsIsynmap) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_EProduction_vIn13 _lhsIallFromToStates _lhsIallInhmap _lhsIallInitStates _lhsIallSynmap _lhsIallVisitKinds _lhsIallchildvisit _lhsIallstates _lhsIavisitdefs _lhsIavisituses _lhsIinhmap _lhsIinitial _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsInextVisits _lhsInt _lhsIntType _lhsIoptions _lhsIparams _lhsIprevVisits _lhsIrename _lhsIsynmap (T_EProduction_vOut13 _lhsOallvisits _lhsOchildvisit _lhsOcount _lhsOdatatype _lhsOdatatype_call _lhsOdatatype_con _lhsOerrors _lhsOfromToStates _lhsOsemFunBndDefs _lhsOsemFunBndTps _lhsOsem_nt _lhsOsem_prod _lhsOt_visits _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses) <- return (inv_EProduction_s14 sem arg) return (Syn_EProduction _lhsOallvisits _lhsOchildvisit _lhsOcount _lhsOdatatype _lhsOdatatype_call _lhsOdatatype_con _lhsOerrors _lhsOfromToStates _lhsOsemFunBndDefs _lhsOsemFunBndTps _lhsOsem_nt _lhsOsem_prod _lhsOt_visits _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses) ) -- cata {-# INLINE sem_EProduction #-} sem_EProduction :: EProduction -> T_EProduction sem_EProduction ( EProduction con_ params_ constraints_ rules_ children_ visits_ ) = sem_EProduction_EProduction con_ params_ constraints_ ( sem_ERules rules_ ) ( sem_EChildren children_ ) ( sem_Visits visits_ ) -- semantic domain newtype T_EProduction = T_EProduction { attach_T_EProduction :: Identity (T_EProduction_s14 ) } newtype T_EProduction_s14 = C_EProduction_s14 { inv_EProduction_s14 :: (T_EProduction_v13 ) } data T_EProduction_s15 = C_EProduction_s15 type T_EProduction_v13 = (T_EProduction_vIn13 ) -> (T_EProduction_vOut13 ) data T_EProduction_vIn13 = T_EProduction_vIn13 (Map VisitIdentifier (Int,Int)) (Map NontermIdent Attributes) (Map NontermIdent Int) (Map NontermIdent Attributes) (Map VisitIdentifier VisitKind) (Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) ([StateIdentifier]) (Map VisitIdentifier (Set Identifier)) (Map VisitIdentifier (Set Identifier)) (Attributes) (StateIdentifier) (Map ConstructorIdent (Map Identifier Type)) (String) (String) (Map StateIdentifier StateCtx) (NontermIdent) (Type) (Options) ([Identifier]) (Map StateIdentifier StateCtx) (Bool) (Attributes) data T_EProduction_vOut13 = T_EProduction_vOut13 ([VisitStateState]) (Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) (Int) (PP_Doc) (PP_Doc) (PP_Doc) (Seq Error) (Map VisitIdentifier (Int,Int)) (Seq PP_Doc) (Seq PP_Doc) (PP_Doc) (PP_Doc) (PP_Doc) (Map VisitIdentifier VisitKind) (Map VisitIdentifier (Set Identifier)) (Map VisitIdentifier (Set Identifier)) {-# NOINLINE sem_EProduction_EProduction #-} sem_EProduction_EProduction :: (ConstructorIdent) -> ([Identifier]) -> ([Type]) -> T_ERules -> T_EChildren -> T_Visits -> T_EProduction sem_EProduction_EProduction arg_con_ arg_params_ _ arg_rules_ arg_children_ arg_visits_ = T_EProduction (return st14) where {-# NOINLINE st14 #-} st14 = let v13 :: T_EProduction_v13 v13 = \ (T_EProduction_vIn13 _lhsIallFromToStates _lhsIallInhmap _lhsIallInitStates _lhsIallSynmap _lhsIallVisitKinds _lhsIallchildvisit _lhsIallstates _lhsIavisitdefs _lhsIavisituses _lhsIinhmap _lhsIinitial _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsInextVisits _lhsInt _lhsIntType _lhsIoptions _lhsIparams _lhsIprevVisits _lhsIrename _lhsIsynmap) -> ( let _rulesX23 = Control.Monad.Identity.runIdentity (attach_T_ERules (arg_rules_)) _childrenX5 = Control.Monad.Identity.runIdentity (attach_T_EChildren (arg_children_)) _visitsX56 = Control.Monad.Identity.runIdentity (attach_T_Visits (arg_visits_)) (T_ERules_vOut22 _rulesIerrors _rulesImrules _rulesIruledefs _rulesIruleuses _rulesIsem_rules) = inv_ERules_s23 _rulesX23 (T_ERules_vIn22 _rulesOallInhmap _rulesOallSynmap _rulesOchildTypes _rulesOcon _rulesOinhmap _rulesOlazyIntras _rulesOlocalAttrTypes _rulesOmainFile _rulesOmainName _rulesOnt _rulesOoptions _rulesOruleKinds _rulesOsynmap _rulesOusageInfo) (T_EChildren_vOut4 _childrenIargnamesw _childrenIchildTypes _childrenIchildintros _childrenIsigs _childrenIterminaldefs) = inv_EChildren_s5 _childrenX5 (T_EChildren_vIn4 _childrenOallInitStates _childrenOcon _childrenOmainFile _childrenOmainName _childrenOnt _childrenOoptions) (T_Visits_vOut55 _visitsIallvisits _visitsIchildvisit _visitsIerrors _visitsIfromToStates _visitsIintramap _visitsIlazyIntras _visitsIruleKinds _visitsIruleUsage _visitsIsem_visit _visitsIt_visits _visitsIvisitKinds _visitsIvisitdefs _visitsIvisituses) = inv_Visits_s56 _visitsX56 (T_Visits_vIn55 _visitsOallFromToStates _visitsOallInhmap _visitsOallInitStates _visitsOallSynmap _visitsOallVisitKinds _visitsOallchildvisit _visitsOallintramap _visitsOavisitdefs _visitsOavisituses _visitsOchildTypes _visitsOchildintros _visitsOcon _visitsOinhmap _visitsOmrules _visitsOnextVisits _visitsOnt _visitsOoptions _visitsOparams _visitsOprevVisits _visitsOruledefs _visitsOruleuses _visitsOsynmap _visitsOterminaldefs) _childrenOcon = rule181 arg_con_ _rulesOcon = rule182 arg_con_ _visitsOcon = rule183 arg_con_ _o_records = rule184 _lhsIoptions _t_params = rule185 _lhsIparams _t_c_params = rule186 arg_params_ _conname = rule187 _lhsInt _lhsIrename arg_con_ _recname = rule188 _conname _lhsOdatatype :: PP_Doc _lhsOdatatype = rule189 _childrenIsigs _o_records _recname _t_params _lhsOdatatype_call :: PP_Doc _lhsOdatatype_call = rule190 _conname _recname _t_params _lhsOdatatype_con :: PP_Doc _lhsOdatatype_con = rule191 _childrenIsigs _conname _lhsInt _o_records _o_sigs _t_params arg_con_ _lhsOcount :: Int _lhsOcount = rule192 () _lhsOsem_nt :: PP_Doc _lhsOsem_nt = rule193 _childrenIargnamesw _childrenIsigs _lhsInt _lhsIoptions _lhsIrename _o_records arg_con_ _lhsOsemFunBndDefs :: Seq PP_Doc _lhsOsemFunBndDefs = rule194 _semFunBndDef _lhsOsemFunBndTps :: Seq PP_Doc _lhsOsemFunBndTps = rule195 _semFunBndTp _semFunBndDef = rule196 _semFunBndNm _semname _semFunBndTp = rule197 _semFunBndNm _sem_tp _semFunBndNm = rule198 _lhsInt arg_con_ _o_sigs = rule199 _lhsIoptions _t_type = rule200 _lhsInt _semname = rule201 _lhsInt _lhsIoptions arg_con_ _sem_res_tp = rule202 _t_params _t_type _sem_tp = rule203 _childrenIsigs _sem_res_tp _initializer = rule204 () _sem_prod = rule205 _childrenIsigs _o_sigs _prod_body _sem_res_tp _semname _prod_body = rule206 _initializer _lhsIinitial _lhsInt _rulesIsem_rules _statefuns arg_con_ _statefuns = rule207 _genstfn _lhsIallstates _genstfn = rule208 _lhsIinitial _lhsInextVisits _lhsInt _stargs _stks _stvs _stargs = rule209 _childTypes _lhsIallInhmap _lhsIallSynmap _lhsIoptions _localAttrTypes _visitsIintramap _stvisits = rule210 _visitsIallvisits _stks = rule211 _lhsInextVisits _lhsInt _stvisits _t_c_params arg_con_ _stvs = rule212 _visitsIsem_visit _visitsOmrules = rule213 _rulesImrules _visitsOchildintros = rule214 _childrenIchildintros _rulesOusageInfo = rule215 _visitsIruleUsage _rulesOruleKinds = rule216 _visitsIruleKinds _visitsOallintramap = rule217 _visitsIintramap _visitsOterminaldefs = rule218 _childrenIterminaldefs _visitsOruledefs = rule219 _rulesIruledefs _visitsOruleuses = rule220 _rulesIruleuses _lazyIntras = rule221 _visitsIlazyIntras _childTypes = rule222 _childrenIchildTypes _lhsIntType _localAttrTypes = rule223 _lhsIlocalAttrTypes arg_con_ _lhsOchildvisit :: Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc) _lhsOchildvisit = rule224 _visitsIchildvisit _lhsOerrors :: Seq Error _lhsOerrors = rule225 _rulesIerrors _visitsIerrors _lhsOfromToStates :: Map VisitIdentifier (Int,Int) _lhsOfromToStates = rule226 _visitsIfromToStates _lhsOt_visits :: PP_Doc _lhsOt_visits = rule227 _visitsIt_visits _lhsOvisitKinds :: Map VisitIdentifier VisitKind _lhsOvisitKinds = rule228 _visitsIvisitKinds _lhsOvisitdefs :: Map VisitIdentifier (Set Identifier) _lhsOvisitdefs = rule229 _visitsIvisitdefs _lhsOvisituses :: Map VisitIdentifier (Set Identifier) _lhsOvisituses = rule230 _visitsIvisituses _lhsOallvisits :: [VisitStateState] _lhsOallvisits = rule231 _visitsIallvisits _lhsOsem_prod :: PP_Doc _lhsOsem_prod = rule232 _sem_prod _rulesOallInhmap = rule233 _lhsIallInhmap _rulesOallSynmap = rule234 _lhsIallSynmap _rulesOchildTypes = rule235 _childTypes _rulesOinhmap = rule236 _lhsIinhmap _rulesOlazyIntras = rule237 _lazyIntras _rulesOlocalAttrTypes = rule238 _localAttrTypes _rulesOmainFile = rule239 _lhsImainFile _rulesOmainName = rule240 _lhsImainName _rulesOnt = rule241 _lhsInt _rulesOoptions = rule242 _lhsIoptions _rulesOsynmap = rule243 _lhsIsynmap _childrenOallInitStates = rule244 _lhsIallInitStates _childrenOmainFile = rule245 _lhsImainFile _childrenOmainName = rule246 _lhsImainName _childrenOnt = rule247 _lhsInt _childrenOoptions = rule248 _lhsIoptions _visitsOallFromToStates = rule249 _lhsIallFromToStates _visitsOallInhmap = rule250 _lhsIallInhmap _visitsOallInitStates = rule251 _lhsIallInitStates _visitsOallSynmap = rule252 _lhsIallSynmap _visitsOallVisitKinds = rule253 _lhsIallVisitKinds _visitsOallchildvisit = rule254 _lhsIallchildvisit _visitsOavisitdefs = rule255 _lhsIavisitdefs _visitsOavisituses = rule256 _lhsIavisituses _visitsOchildTypes = rule257 _childTypes _visitsOinhmap = rule258 _lhsIinhmap _visitsOnextVisits = rule259 _lhsInextVisits _visitsOnt = rule260 _lhsInt _visitsOoptions = rule261 _lhsIoptions _visitsOparams = rule262 _lhsIparams _visitsOprevVisits = rule263 _lhsIprevVisits _visitsOsynmap = rule264 _lhsIsynmap __result_ = T_EProduction_vOut13 _lhsOallvisits _lhsOchildvisit _lhsOcount _lhsOdatatype _lhsOdatatype_call _lhsOdatatype_con _lhsOerrors _lhsOfromToStates _lhsOsemFunBndDefs _lhsOsemFunBndTps _lhsOsem_nt _lhsOsem_prod _lhsOt_visits _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses in __result_ ) in C_EProduction_s14 v13 {-# INLINE rule181 #-} {-# LINE 88 "./src-ag/ExecutionPlan2Caml.ag" #-} rule181 = \ con_ -> {-# LINE 88 "./src-ag/ExecutionPlan2Caml.ag" #-} con_ {-# LINE 1904 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule182 #-} {-# LINE 89 "./src-ag/ExecutionPlan2Caml.ag" #-} rule182 = \ con_ -> {-# LINE 89 "./src-ag/ExecutionPlan2Caml.ag" #-} con_ {-# LINE 1910 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule183 #-} {-# LINE 90 "./src-ag/ExecutionPlan2Caml.ag" #-} rule183 = \ con_ -> {-# LINE 90 "./src-ag/ExecutionPlan2Caml.ag" #-} con_ {-# LINE 1916 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule184 #-} {-# LINE 257 "./src-ag/ExecutionPlan2Caml.ag" #-} rule184 = \ ((_lhsIoptions) :: Options) -> {-# LINE 257 "./src-ag/ExecutionPlan2Caml.ag" #-} dataRecords _lhsIoptions {-# LINE 1922 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule185 #-} {-# LINE 258 "./src-ag/ExecutionPlan2Caml.ag" #-} rule185 = \ ((_lhsIparams) :: [Identifier]) -> {-# LINE 258 "./src-ag/ExecutionPlan2Caml.ag" #-} ppTypeParams _lhsIparams {-# LINE 1928 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule186 #-} {-# LINE 259 "./src-ag/ExecutionPlan2Caml.ag" #-} rule186 = \ params_ -> {-# LINE 259 "./src-ag/ExecutionPlan2Caml.ag" #-} ppTypeParams (cont_tvar : map pp params_) {-# LINE 1934 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule187 #-} {-# LINE 260 "./src-ag/ExecutionPlan2Caml.ag" #-} rule187 = \ ((_lhsInt) :: NontermIdent) ((_lhsIrename) :: Bool) con_ -> {-# LINE 260 "./src-ag/ExecutionPlan2Caml.ag" #-} conname _lhsIrename _lhsInt con_ {-# LINE 1940 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule188 #-} {-# LINE 261 "./src-ag/ExecutionPlan2Caml.ag" #-} rule188 = \ _conname -> {-# LINE 261 "./src-ag/ExecutionPlan2Caml.ag" #-} pp "fields_" >|< _conname {-# LINE 1946 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule189 #-} {-# LINE 262 "./src-ag/ExecutionPlan2Caml.ag" #-} rule189 = \ ((_childrenIsigs) :: [(PP_Doc,PP_Doc,PP_Doc,PP_Doc)]) _o_records _recname _t_params -> {-# LINE 262 "./src-ag/ExecutionPlan2Caml.ag" #-} "and" >#< _t_params >#< _recname >#< "=" >#< ppFieldsType _o_records False _childrenIsigs {-# LINE 1953 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule190 #-} {-# LINE 264 "./src-ag/ExecutionPlan2Caml.ag" #-} rule190 = \ _conname _recname _t_params -> {-# LINE 264 "./src-ag/ExecutionPlan2Caml.ag" #-} pp "|" >#< _conname >#< "of" >#< pp_parens (_t_params >#< _recname ) {-# LINE 1959 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule191 #-} {-# LINE 266 "./src-ag/ExecutionPlan2Caml.ag" #-} rule191 = \ ((_childrenIsigs) :: [(PP_Doc,PP_Doc,PP_Doc,PP_Doc)]) _conname ((_lhsInt) :: NontermIdent) _o_records _o_sigs _t_params con_ -> {-# LINE 266 "./src-ag/ExecutionPlan2Caml.ag" #-} let funNm = _lhsInt >|< "_" >|< con_ decl = "and" >#< ppFunDecl _o_sigs funNm params (_t_params >#< _lhsInt) body params = [ (x, t) | (_,x,_,t) <- _childrenIsigs ] body = _conname >#< ppFieldsVal _o_records _childrenIsigs in decl {-# LINE 1969 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule192 #-} {-# LINE 382 "./src-ag/ExecutionPlan2Caml.ag" #-} rule192 = \ (_ :: ()) -> {-# LINE 382 "./src-ag/ExecutionPlan2Caml.ag" #-} 1 {-# LINE 1975 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule193 #-} {-# LINE 387 "./src-ag/ExecutionPlan2Caml.ag" #-} rule193 = \ ((_childrenIargnamesw) :: [PP_Doc]) ((_childrenIsigs) :: [(PP_Doc,PP_Doc,PP_Doc,PP_Doc)]) ((_lhsInt) :: NontermIdent) ((_lhsIoptions) :: Options) ((_lhsIrename) :: Bool) _o_records con_ -> {-# LINE 387 "./src-ag/ExecutionPlan2Caml.ag" #-} "|" >#< conname _lhsIrename _lhsInt con_ >#< ppFieldsVal _o_records _childrenIsigs >#< "->" >#< prefix _lhsIoptions >|< _lhsInt >|< "_" >|< con_ >#< ppSpaced _childrenIargnamesw {-# LINE 1982 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule194 #-} {-# LINE 653 "./src-ag/ExecutionPlan2Caml.ag" #-} rule194 = \ _semFunBndDef -> {-# LINE 653 "./src-ag/ExecutionPlan2Caml.ag" #-} Seq.singleton _semFunBndDef {-# LINE 1988 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule195 #-} {-# LINE 654 "./src-ag/ExecutionPlan2Caml.ag" #-} rule195 = \ _semFunBndTp -> {-# LINE 654 "./src-ag/ExecutionPlan2Caml.ag" #-} Seq.singleton _semFunBndTp {-# LINE 1994 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule196 #-} {-# LINE 655 "./src-ag/ExecutionPlan2Caml.ag" #-} rule196 = \ _semFunBndNm _semname -> {-# LINE 655 "./src-ag/ExecutionPlan2Caml.ag" #-} _semFunBndNm >#< "=" >#< _semname {-# LINE 2000 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule197 #-} {-# LINE 656 "./src-ag/ExecutionPlan2Caml.ag" #-} rule197 = \ _semFunBndNm _sem_tp -> {-# LINE 656 "./src-ag/ExecutionPlan2Caml.ag" #-} _semFunBndNm >#< ":" >#< _sem_tp {-# LINE 2006 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule198 #-} {-# LINE 657 "./src-ag/ExecutionPlan2Caml.ag" #-} rule198 = \ ((_lhsInt) :: NontermIdent) con_ -> {-# LINE 657 "./src-ag/ExecutionPlan2Caml.ag" #-} lateSemConLabel _lhsInt con_ {-# LINE 2012 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule199 #-} {-# LINE 684 "./src-ag/ExecutionPlan2Caml.ag" #-} rule199 = \ ((_lhsIoptions) :: Options) -> {-# LINE 684 "./src-ag/ExecutionPlan2Caml.ag" #-} typeSigs _lhsIoptions {-# LINE 2018 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule200 #-} {-# LINE 685 "./src-ag/ExecutionPlan2Caml.ag" #-} rule200 = \ ((_lhsInt) :: NontermIdent) -> {-# LINE 685 "./src-ag/ExecutionPlan2Caml.ag" #-} type_nt_sem_top _lhsInt {-# LINE 2024 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule201 #-} {-# LINE 686 "./src-ag/ExecutionPlan2Caml.ag" #-} rule201 = \ ((_lhsInt) :: NontermIdent) ((_lhsIoptions) :: Options) con_ -> {-# LINE 686 "./src-ag/ExecutionPlan2Caml.ag" #-} prefix _lhsIoptions >|< _lhsInt >|< "_" >|< con_ {-# LINE 2030 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule202 #-} {-# LINE 687 "./src-ag/ExecutionPlan2Caml.ag" #-} rule202 = \ _t_params _t_type -> {-# LINE 687 "./src-ag/ExecutionPlan2Caml.ag" #-} _t_params >#< _t_type {-# LINE 2036 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule203 #-} {-# LINE 688 "./src-ag/ExecutionPlan2Caml.ag" #-} rule203 = \ ((_childrenIsigs) :: [(PP_Doc,PP_Doc,PP_Doc,PP_Doc)]) _sem_res_tp -> {-# LINE 688 "./src-ag/ExecutionPlan2Caml.ag" #-} pp_block "" "" "->" [ d | (_,_,d,_) <- _childrenIsigs ] >#< "->" >#< _sem_res_tp {-# LINE 2042 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule204 #-} {-# LINE 691 "./src-ag/ExecutionPlan2Caml.ag" #-} rule204 = \ (_ :: ()) -> {-# LINE 691 "./src-ag/ExecutionPlan2Caml.ag" #-} empty {-# LINE 2048 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule205 #-} {-# LINE 697 "./src-ag/ExecutionPlan2Caml.ag" #-} rule205 = \ ((_childrenIsigs) :: [(PP_Doc,PP_Doc,PP_Doc,PP_Doc)]) _o_sigs _prod_body _sem_res_tp _semname -> {-# LINE 697 "./src-ag/ExecutionPlan2Caml.ag" #-} "and" >#< ppFunDecl _o_sigs _semname [ (x,d) | (_,x,d,_) <- _childrenIsigs ] _sem_res_tp _prod_body {-# LINE 2054 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule206 #-} {-# LINE 699 "./src-ag/ExecutionPlan2Caml.ag" #-} rule206 = \ _initializer ((_lhsIinitial) :: StateIdentifier) ((_lhsInt) :: NontermIdent) ((_rulesIsem_rules) :: PP_Doc) _statefuns con_ -> {-# LINE 699 "./src-ag/ExecutionPlan2Caml.ag" #-} _initializer >-< "{" >#< nm_attach _lhsInt >#< "=" >#< "function () ->" >-< indent 2 ( "(* rules of production" >#< con_ >#< "*)" >-< _rulesIsem_rules >-< "(* states of production" >#< con_ >#< "*)" >-< vlist _statefuns >-< nm_st _lhsIinitial ) >#< "}" {-# LINE 2069 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule207 #-} {-# LINE 715 "./src-ag/ExecutionPlan2Caml.ag" #-} rule207 = \ _genstfn ((_lhsIallstates) :: [StateIdentifier]) -> {-# LINE 715 "./src-ag/ExecutionPlan2Caml.ag" #-} map _genstfn _lhsIallstates {-# LINE 2075 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule208 #-} {-# LINE 717 "./src-ag/ExecutionPlan2Caml.ag" #-} rule208 = \ ((_lhsIinitial) :: StateIdentifier) ((_lhsInextVisits) :: Map StateIdentifier StateCtx) ((_lhsInt) :: NontermIdent) _stargs _stks _stvs -> {-# LINE 717 "./src-ag/ExecutionPlan2Caml.ag" #-} \st -> let nextVisitInfo = Map.findWithDefault ManyVis st _lhsInextVisits stNm = nm_st st stDef body = "let" >#< stNm >#< (if st == _lhsIinitial then empty else _stargs st) >#< "=" >-< indent 2 body >#< "in" in case nextVisitInfo of NoneVis -> if st == _lhsIinitial then stDef (pp "unit") else empty _ -> stDef $ mklets (_stvs st ++ _stks st) $ ppRecordVal [ nm_invoke _lhsInt st >#< "=" >#< nm_k st ] {-# LINE 2091 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule209 #-} {-# LINE 737 "./src-ag/ExecutionPlan2Caml.ag" #-} rule209 = \ _childTypes ((_lhsIallInhmap) :: Map NontermIdent Attributes) ((_lhsIallSynmap) :: Map NontermIdent Attributes) ((_lhsIoptions) :: Options) _localAttrTypes ((_visitsIintramap) :: Map StateIdentifier (Map String (Maybe NonLocalAttr))) -> {-# LINE 737 "./src-ag/ExecutionPlan2Caml.ag" #-} \st -> let attrs = maybe Map.empty id $ Map.lookup st _visitsIintramap in ppSpaced [ case mbAttr of Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs _lhsIoptions) -> case Map.lookup nm _localAttrTypes of Just tp -> pp_parens (strNm >#< ":" >#< ppTp tp) Nothing -> pp strNm Just attr | not (noPerStateTypeSigs _lhsIoptions) -> case lookupAttrType attr _lhsIallInhmap _lhsIallSynmap _childTypes of Just tpDoc -> pp_parens (strNm >#< ":" >#< tpDoc) Nothing -> pp strNm _ -> pp strNm | (strNm, mbAttr) <- Map.assocs attrs ] >#< dummyPat _lhsIoptions (Map.null attrs) {-# LINE 2109 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule210 #-} {-# LINE 752 "./src-ag/ExecutionPlan2Caml.ag" #-} rule210 = \ ((_visitsIallvisits) :: [VisitStateState]) -> {-# LINE 752 "./src-ag/ExecutionPlan2Caml.ag" #-} \st -> filter (\(_,f,_) -> f == st) _visitsIallvisits {-# LINE 2115 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule211 #-} {-# LINE 754 "./src-ag/ExecutionPlan2Caml.ag" #-} rule211 = \ ((_lhsInextVisits) :: Map StateIdentifier StateCtx) ((_lhsInt) :: NontermIdent) _stvisits _t_c_params con_ -> {-# LINE 754 "./src-ag/ExecutionPlan2Caml.ag" #-} \st -> let stvisits = _stvisits st def = ppFunDecl False (pp $ nm_k st) [(pp "arg", _t_c_params >#< type_caller _lhsInt st)] (pp cont_tvar) body nextVisitInfo = Map.findWithDefault ManyVis st _lhsInextVisits body = case nextVisitInfo of NoneVis -> text "?no next visit?" OneVis v -> dispatch "arg" v ManyVis -> let alt (v,_,_) = "|" >#< con_visit _lhsInt v >#< "chosen" >#< "->" >-< indent 2 (dispatch "chosen" v) in "match arg with" >-< (indent 2 $ vlist $ map alt stvisits) dispatch nm v = "let" >#< ppRecordVal [ nm_inh _lhsInt v >#< "=" >#< "inp" , nm_cont _lhsInt v >#< "=" >#< "cont" ] >#< "=" >#< pp nm >-< "in" >#< "cont" >#< pp_parens (nm_visit v >#< "inp") in if null stvisits then [] else [ "(* k-function for production" >#< con_ >#< " *)" >-< def ] {-# LINE 2137 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule212 #-} {-# LINE 775 "./src-ag/ExecutionPlan2Caml.ag" #-} rule212 = \ ((_visitsIsem_visit) :: [(StateIdentifier,PP_Doc)] ) -> {-# LINE 775 "./src-ag/ExecutionPlan2Caml.ag" #-} \st -> [ppf | (f,ppf) <- _visitsIsem_visit, f == st] {-# LINE 2143 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule213 #-} {-# LINE 776 "./src-ag/ExecutionPlan2Caml.ag" #-} rule213 = \ ((_rulesImrules) :: Map Identifier (VisitKind -> Either Error PP_Doc)) -> {-# LINE 776 "./src-ag/ExecutionPlan2Caml.ag" #-} _rulesImrules {-# LINE 2149 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule214 #-} {-# LINE 917 "./src-ag/ExecutionPlan2Caml.ag" #-} rule214 = \ ((_childrenIchildintros) :: Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))) -> {-# LINE 917 "./src-ag/ExecutionPlan2Caml.ag" #-} _childrenIchildintros {-# LINE 2155 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule215 #-} {-# LINE 1222 "./src-ag/ExecutionPlan2Caml.ag" #-} rule215 = \ ((_visitsIruleUsage) :: Map Identifier Int) -> {-# LINE 1222 "./src-ag/ExecutionPlan2Caml.ag" #-} _visitsIruleUsage {-# LINE 2161 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule216 #-} {-# LINE 1237 "./src-ag/ExecutionPlan2Caml.ag" #-} rule216 = \ ((_visitsIruleKinds) :: Map Identifier (Set VisitKind)) -> {-# LINE 1237 "./src-ag/ExecutionPlan2Caml.ag" #-} _visitsIruleKinds {-# LINE 2167 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule217 #-} {-# LINE 1266 "./src-ag/ExecutionPlan2Caml.ag" #-} rule217 = \ ((_visitsIintramap) :: Map StateIdentifier (Map String (Maybe NonLocalAttr))) -> {-# LINE 1266 "./src-ag/ExecutionPlan2Caml.ag" #-} _visitsIintramap {-# LINE 2173 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule218 #-} {-# LINE 1267 "./src-ag/ExecutionPlan2Caml.ag" #-} rule218 = \ ((_childrenIterminaldefs) :: Set String) -> {-# LINE 1267 "./src-ag/ExecutionPlan2Caml.ag" #-} _childrenIterminaldefs {-# LINE 2179 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule219 #-} {-# LINE 1291 "./src-ag/ExecutionPlan2Caml.ag" #-} rule219 = \ ((_rulesIruledefs) :: Map Identifier (Set String)) -> {-# LINE 1291 "./src-ag/ExecutionPlan2Caml.ag" #-} _rulesIruledefs {-# LINE 2185 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule220 #-} {-# LINE 1292 "./src-ag/ExecutionPlan2Caml.ag" #-} rule220 = \ ((_rulesIruleuses) :: Map Identifier (Map String (Maybe NonLocalAttr))) -> {-# LINE 1292 "./src-ag/ExecutionPlan2Caml.ag" #-} _rulesIruleuses {-# LINE 2191 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule221 #-} {-# LINE 1346 "./src-ag/ExecutionPlan2Caml.ag" #-} rule221 = \ ((_visitsIlazyIntras) :: Set String) -> {-# LINE 1346 "./src-ag/ExecutionPlan2Caml.ag" #-} _visitsIlazyIntras {-# LINE 2197 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule222 #-} {-# LINE 1418 "./src-ag/ExecutionPlan2Caml.ag" #-} rule222 = \ ((_childrenIchildTypes) :: Map Identifier Type) ((_lhsIntType) :: Type) -> {-# LINE 1418 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.singleton _LHS _lhsIntType `Map.union` _childrenIchildTypes {-# LINE 2203 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule223 #-} {-# LINE 1435 "./src-ag/ExecutionPlan2Caml.ag" #-} rule223 = \ ((_lhsIlocalAttrTypes) :: Map ConstructorIdent (Map Identifier Type)) con_ -> {-# LINE 1435 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.findWithDefault Map.empty con_ _lhsIlocalAttrTypes {-# LINE 2209 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule224 #-} rule224 = \ ((_visitsIchildvisit) :: Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) -> _visitsIchildvisit {-# INLINE rule225 #-} rule225 = \ ((_rulesIerrors) :: Seq Error) ((_visitsIerrors) :: Seq Error) -> _rulesIerrors Seq.>< _visitsIerrors {-# INLINE rule226 #-} rule226 = \ ((_visitsIfromToStates) :: Map VisitIdentifier (Int,Int)) -> _visitsIfromToStates {-# INLINE rule227 #-} rule227 = \ ((_visitsIt_visits) :: PP_Doc) -> _visitsIt_visits {-# INLINE rule228 #-} rule228 = \ ((_visitsIvisitKinds) :: Map VisitIdentifier VisitKind) -> _visitsIvisitKinds {-# INLINE rule229 #-} rule229 = \ ((_visitsIvisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _visitsIvisitdefs {-# INLINE rule230 #-} rule230 = \ ((_visitsIvisituses) :: Map VisitIdentifier (Set Identifier)) -> _visitsIvisituses {-# INLINE rule231 #-} rule231 = \ ((_visitsIallvisits) :: [VisitStateState]) -> _visitsIallvisits {-# INLINE rule232 #-} rule232 = \ _sem_prod -> _sem_prod {-# INLINE rule233 #-} rule233 = \ ((_lhsIallInhmap) :: Map NontermIdent Attributes) -> _lhsIallInhmap {-# INLINE rule234 #-} rule234 = \ ((_lhsIallSynmap) :: Map NontermIdent Attributes) -> _lhsIallSynmap {-# INLINE rule235 #-} rule235 = \ _childTypes -> _childTypes {-# INLINE rule236 #-} rule236 = \ ((_lhsIinhmap) :: Attributes) -> _lhsIinhmap {-# INLINE rule237 #-} rule237 = \ _lazyIntras -> _lazyIntras {-# INLINE rule238 #-} rule238 = \ _localAttrTypes -> _localAttrTypes {-# INLINE rule239 #-} rule239 = \ ((_lhsImainFile) :: String) -> _lhsImainFile {-# INLINE rule240 #-} rule240 = \ ((_lhsImainName) :: String) -> _lhsImainName {-# INLINE rule241 #-} rule241 = \ ((_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule242 #-} rule242 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule243 #-} rule243 = \ ((_lhsIsynmap) :: Attributes) -> _lhsIsynmap {-# INLINE rule244 #-} rule244 = \ ((_lhsIallInitStates) :: Map NontermIdent Int) -> _lhsIallInitStates {-# INLINE rule245 #-} rule245 = \ ((_lhsImainFile) :: String) -> _lhsImainFile {-# INLINE rule246 #-} rule246 = \ ((_lhsImainName) :: String) -> _lhsImainName {-# INLINE rule247 #-} rule247 = \ ((_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule248 #-} rule248 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule249 #-} rule249 = \ ((_lhsIallFromToStates) :: Map VisitIdentifier (Int,Int)) -> _lhsIallFromToStates {-# INLINE rule250 #-} rule250 = \ ((_lhsIallInhmap) :: Map NontermIdent Attributes) -> _lhsIallInhmap {-# INLINE rule251 #-} rule251 = \ ((_lhsIallInitStates) :: Map NontermIdent Int) -> _lhsIallInitStates {-# INLINE rule252 #-} rule252 = \ ((_lhsIallSynmap) :: Map NontermIdent Attributes) -> _lhsIallSynmap {-# INLINE rule253 #-} rule253 = \ ((_lhsIallVisitKinds) :: Map VisitIdentifier VisitKind) -> _lhsIallVisitKinds {-# INLINE rule254 #-} rule254 = \ ((_lhsIallchildvisit) :: Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) -> _lhsIallchildvisit {-# INLINE rule255 #-} rule255 = \ ((_lhsIavisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisitdefs {-# INLINE rule256 #-} rule256 = \ ((_lhsIavisituses) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisituses {-# INLINE rule257 #-} rule257 = \ _childTypes -> _childTypes {-# INLINE rule258 #-} rule258 = \ ((_lhsIinhmap) :: Attributes) -> _lhsIinhmap {-# INLINE rule259 #-} rule259 = \ ((_lhsInextVisits) :: Map StateIdentifier StateCtx) -> _lhsInextVisits {-# INLINE rule260 #-} rule260 = \ ((_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule261 #-} rule261 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule262 #-} rule262 = \ ((_lhsIparams) :: [Identifier]) -> _lhsIparams {-# INLINE rule263 #-} rule263 = \ ((_lhsIprevVisits) :: Map StateIdentifier StateCtx) -> _lhsIprevVisits {-# INLINE rule264 #-} rule264 = \ ((_lhsIsynmap) :: Attributes) -> _lhsIsynmap -- EProductions ------------------------------------------------ -- wrapper data Inh_EProductions = Inh_EProductions { allFromToStates_Inh_EProductions :: (Map VisitIdentifier (Int,Int)), allInhmap_Inh_EProductions :: (Map NontermIdent Attributes), allInitStates_Inh_EProductions :: (Map NontermIdent Int), allSynmap_Inh_EProductions :: (Map NontermIdent Attributes), allVisitKinds_Inh_EProductions :: (Map VisitIdentifier VisitKind), allchildvisit_Inh_EProductions :: (Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)), allstates_Inh_EProductions :: ([StateIdentifier]), avisitdefs_Inh_EProductions :: (Map VisitIdentifier (Set Identifier)), avisituses_Inh_EProductions :: (Map VisitIdentifier (Set Identifier)), inhmap_Inh_EProductions :: (Attributes), initial_Inh_EProductions :: (StateIdentifier), localAttrTypes_Inh_EProductions :: (Map ConstructorIdent (Map Identifier Type)), mainFile_Inh_EProductions :: (String), mainName_Inh_EProductions :: (String), nextVisits_Inh_EProductions :: (Map StateIdentifier StateCtx), nt_Inh_EProductions :: (NontermIdent), ntType_Inh_EProductions :: (Type), options_Inh_EProductions :: (Options), params_Inh_EProductions :: ([Identifier]), prevVisits_Inh_EProductions :: (Map StateIdentifier StateCtx), rename_Inh_EProductions :: (Bool), synmap_Inh_EProductions :: (Attributes) } data Syn_EProductions = Syn_EProductions { allvisits_Syn_EProductions :: ([VisitStateState]), childvisit_Syn_EProductions :: (Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)), count_Syn_EProductions :: (Int), datatype_Syn_EProductions :: ([PP_Doc]), datatype_call_Syn_EProductions :: ([PP_Doc]), datatype_con_Syn_EProductions :: ([PP_Doc]), errors_Syn_EProductions :: (Seq Error), fromToStates_Syn_EProductions :: (Map VisitIdentifier (Int,Int)), semFunBndDefs_Syn_EProductions :: (Seq PP_Doc), semFunBndTps_Syn_EProductions :: (Seq PP_Doc), sem_nt_Syn_EProductions :: (PP_Doc), sem_prod_Syn_EProductions :: (PP_Doc), t_visits_Syn_EProductions :: (PP_Doc), visitKinds_Syn_EProductions :: (Map VisitIdentifier VisitKind), visitdefs_Syn_EProductions :: (Map VisitIdentifier (Set Identifier)), visituses_Syn_EProductions :: (Map VisitIdentifier (Set Identifier)) } {-# INLINABLE wrap_EProductions #-} wrap_EProductions :: T_EProductions -> Inh_EProductions -> (Syn_EProductions ) wrap_EProductions (T_EProductions act) (Inh_EProductions _lhsIallFromToStates _lhsIallInhmap _lhsIallInitStates _lhsIallSynmap _lhsIallVisitKinds _lhsIallchildvisit _lhsIallstates _lhsIavisitdefs _lhsIavisituses _lhsIinhmap _lhsIinitial _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsInextVisits _lhsInt _lhsIntType _lhsIoptions _lhsIparams _lhsIprevVisits _lhsIrename _lhsIsynmap) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_EProductions_vIn16 _lhsIallFromToStates _lhsIallInhmap _lhsIallInitStates _lhsIallSynmap _lhsIallVisitKinds _lhsIallchildvisit _lhsIallstates _lhsIavisitdefs _lhsIavisituses _lhsIinhmap _lhsIinitial _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsInextVisits _lhsInt _lhsIntType _lhsIoptions _lhsIparams _lhsIprevVisits _lhsIrename _lhsIsynmap (T_EProductions_vOut16 _lhsOallvisits _lhsOchildvisit _lhsOcount _lhsOdatatype _lhsOdatatype_call _lhsOdatatype_con _lhsOerrors _lhsOfromToStates _lhsOsemFunBndDefs _lhsOsemFunBndTps _lhsOsem_nt _lhsOsem_prod _lhsOt_visits _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses) <- return (inv_EProductions_s17 sem arg) return (Syn_EProductions _lhsOallvisits _lhsOchildvisit _lhsOcount _lhsOdatatype _lhsOdatatype_call _lhsOdatatype_con _lhsOerrors _lhsOfromToStates _lhsOsemFunBndDefs _lhsOsemFunBndTps _lhsOsem_nt _lhsOsem_prod _lhsOt_visits _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses) ) -- cata {-# NOINLINE sem_EProductions #-} sem_EProductions :: EProductions -> T_EProductions sem_EProductions list = Prelude.foldr sem_EProductions_Cons sem_EProductions_Nil (Prelude.map sem_EProduction list) -- semantic domain newtype T_EProductions = T_EProductions { attach_T_EProductions :: Identity (T_EProductions_s17 ) } newtype T_EProductions_s17 = C_EProductions_s17 { inv_EProductions_s17 :: (T_EProductions_v16 ) } data T_EProductions_s18 = C_EProductions_s18 type T_EProductions_v16 = (T_EProductions_vIn16 ) -> (T_EProductions_vOut16 ) data T_EProductions_vIn16 = T_EProductions_vIn16 (Map VisitIdentifier (Int,Int)) (Map NontermIdent Attributes) (Map NontermIdent Int) (Map NontermIdent Attributes) (Map VisitIdentifier VisitKind) (Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) ([StateIdentifier]) (Map VisitIdentifier (Set Identifier)) (Map VisitIdentifier (Set Identifier)) (Attributes) (StateIdentifier) (Map ConstructorIdent (Map Identifier Type)) (String) (String) (Map StateIdentifier StateCtx) (NontermIdent) (Type) (Options) ([Identifier]) (Map StateIdentifier StateCtx) (Bool) (Attributes) data T_EProductions_vOut16 = T_EProductions_vOut16 ([VisitStateState]) (Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) (Int) ([PP_Doc]) ([PP_Doc]) ([PP_Doc]) (Seq Error) (Map VisitIdentifier (Int,Int)) (Seq PP_Doc) (Seq PP_Doc) (PP_Doc) (PP_Doc) (PP_Doc) (Map VisitIdentifier VisitKind) (Map VisitIdentifier (Set Identifier)) (Map VisitIdentifier (Set Identifier)) {-# NOINLINE sem_EProductions_Cons #-} sem_EProductions_Cons :: T_EProduction -> T_EProductions -> T_EProductions sem_EProductions_Cons arg_hd_ arg_tl_ = T_EProductions (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_EProductions_v16 v16 = \ (T_EProductions_vIn16 _lhsIallFromToStates _lhsIallInhmap _lhsIallInitStates _lhsIallSynmap _lhsIallVisitKinds _lhsIallchildvisit _lhsIallstates _lhsIavisitdefs _lhsIavisituses _lhsIinhmap _lhsIinitial _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsInextVisits _lhsInt _lhsIntType _lhsIoptions _lhsIparams _lhsIprevVisits _lhsIrename _lhsIsynmap) -> ( let _hdX14 = Control.Monad.Identity.runIdentity (attach_T_EProduction (arg_hd_)) _tlX17 = Control.Monad.Identity.runIdentity (attach_T_EProductions (arg_tl_)) (T_EProduction_vOut13 _hdIallvisits _hdIchildvisit _hdIcount _hdIdatatype _hdIdatatype_call _hdIdatatype_con _hdIerrors _hdIfromToStates _hdIsemFunBndDefs _hdIsemFunBndTps _hdIsem_nt _hdIsem_prod _hdIt_visits _hdIvisitKinds _hdIvisitdefs _hdIvisituses) = inv_EProduction_s14 _hdX14 (T_EProduction_vIn13 _hdOallFromToStates _hdOallInhmap _hdOallInitStates _hdOallSynmap _hdOallVisitKinds _hdOallchildvisit _hdOallstates _hdOavisitdefs _hdOavisituses _hdOinhmap _hdOinitial _hdOlocalAttrTypes _hdOmainFile _hdOmainName _hdOnextVisits _hdOnt _hdOntType _hdOoptions _hdOparams _hdOprevVisits _hdOrename _hdOsynmap) (T_EProductions_vOut16 _tlIallvisits _tlIchildvisit _tlIcount _tlIdatatype _tlIdatatype_call _tlIdatatype_con _tlIerrors _tlIfromToStates _tlIsemFunBndDefs _tlIsemFunBndTps _tlIsem_nt _tlIsem_prod _tlIt_visits _tlIvisitKinds _tlIvisitdefs _tlIvisituses) = inv_EProductions_s17 _tlX17 (T_EProductions_vIn16 _tlOallFromToStates _tlOallInhmap _tlOallInitStates _tlOallSynmap _tlOallVisitKinds _tlOallchildvisit _tlOallstates _tlOavisitdefs _tlOavisituses _tlOinhmap _tlOinitial _tlOlocalAttrTypes _tlOmainFile _tlOmainName _tlOnextVisits _tlOnt _tlOntType _tlOoptions _tlOparams _tlOprevVisits _tlOrename _tlOsynmap) _lhsOallvisits :: [VisitStateState] _lhsOallvisits = rule265 _hdIallvisits _lhsOt_visits :: PP_Doc _lhsOt_visits = rule266 _hdIt_visits _lhsOchildvisit :: Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc) _lhsOchildvisit = rule267 _hdIchildvisit _tlIchildvisit _lhsOcount :: Int _lhsOcount = rule268 _hdIcount _tlIcount _lhsOdatatype :: [PP_Doc] _lhsOdatatype = rule269 _hdIdatatype _tlIdatatype _lhsOdatatype_call :: [PP_Doc] _lhsOdatatype_call = rule270 _hdIdatatype_call _tlIdatatype_call _lhsOdatatype_con :: [PP_Doc] _lhsOdatatype_con = rule271 _hdIdatatype_con _tlIdatatype_con _lhsOerrors :: Seq Error _lhsOerrors = rule272 _hdIerrors _tlIerrors _lhsOfromToStates :: Map VisitIdentifier (Int,Int) _lhsOfromToStates = rule273 _hdIfromToStates _tlIfromToStates _lhsOsemFunBndDefs :: Seq PP_Doc _lhsOsemFunBndDefs = rule274 _hdIsemFunBndDefs _tlIsemFunBndDefs _lhsOsemFunBndTps :: Seq PP_Doc _lhsOsemFunBndTps = rule275 _hdIsemFunBndTps _tlIsemFunBndTps _lhsOsem_nt :: PP_Doc _lhsOsem_nt = rule276 _hdIsem_nt _tlIsem_nt _lhsOsem_prod :: PP_Doc _lhsOsem_prod = rule277 _hdIsem_prod _tlIsem_prod _lhsOvisitKinds :: Map VisitIdentifier VisitKind _lhsOvisitKinds = rule278 _hdIvisitKinds _tlIvisitKinds _lhsOvisitdefs :: Map VisitIdentifier (Set Identifier) _lhsOvisitdefs = rule279 _hdIvisitdefs _tlIvisitdefs _lhsOvisituses :: Map VisitIdentifier (Set Identifier) _lhsOvisituses = rule280 _hdIvisituses _tlIvisituses _hdOallFromToStates = rule281 _lhsIallFromToStates _hdOallInhmap = rule282 _lhsIallInhmap _hdOallInitStates = rule283 _lhsIallInitStates _hdOallSynmap = rule284 _lhsIallSynmap _hdOallVisitKinds = rule285 _lhsIallVisitKinds _hdOallchildvisit = rule286 _lhsIallchildvisit _hdOallstates = rule287 _lhsIallstates _hdOavisitdefs = rule288 _lhsIavisitdefs _hdOavisituses = rule289 _lhsIavisituses _hdOinhmap = rule290 _lhsIinhmap _hdOinitial = rule291 _lhsIinitial _hdOlocalAttrTypes = rule292 _lhsIlocalAttrTypes _hdOmainFile = rule293 _lhsImainFile _hdOmainName = rule294 _lhsImainName _hdOnextVisits = rule295 _lhsInextVisits _hdOnt = rule296 _lhsInt _hdOntType = rule297 _lhsIntType _hdOoptions = rule298 _lhsIoptions _hdOparams = rule299 _lhsIparams _hdOprevVisits = rule300 _lhsIprevVisits _hdOrename = rule301 _lhsIrename _hdOsynmap = rule302 _lhsIsynmap _tlOallFromToStates = rule303 _lhsIallFromToStates _tlOallInhmap = rule304 _lhsIallInhmap _tlOallInitStates = rule305 _lhsIallInitStates _tlOallSynmap = rule306 _lhsIallSynmap _tlOallVisitKinds = rule307 _lhsIallVisitKinds _tlOallchildvisit = rule308 _lhsIallchildvisit _tlOallstates = rule309 _lhsIallstates _tlOavisitdefs = rule310 _lhsIavisitdefs _tlOavisituses = rule311 _lhsIavisituses _tlOinhmap = rule312 _lhsIinhmap _tlOinitial = rule313 _lhsIinitial _tlOlocalAttrTypes = rule314 _lhsIlocalAttrTypes _tlOmainFile = rule315 _lhsImainFile _tlOmainName = rule316 _lhsImainName _tlOnextVisits = rule317 _lhsInextVisits _tlOnt = rule318 _lhsInt _tlOntType = rule319 _lhsIntType _tlOoptions = rule320 _lhsIoptions _tlOparams = rule321 _lhsIparams _tlOprevVisits = rule322 _lhsIprevVisits _tlOrename = rule323 _lhsIrename _tlOsynmap = rule324 _lhsIsynmap __result_ = T_EProductions_vOut16 _lhsOallvisits _lhsOchildvisit _lhsOcount _lhsOdatatype _lhsOdatatype_call _lhsOdatatype_con _lhsOerrors _lhsOfromToStates _lhsOsemFunBndDefs _lhsOsemFunBndTps _lhsOsem_nt _lhsOsem_prod _lhsOt_visits _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses in __result_ ) in C_EProductions_s17 v16 {-# INLINE rule265 #-} {-# LINE 437 "./src-ag/ExecutionPlan2Caml.ag" #-} rule265 = \ ((_hdIallvisits) :: [VisitStateState]) -> {-# LINE 437 "./src-ag/ExecutionPlan2Caml.ag" #-} _hdIallvisits {-# LINE 2459 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule266 #-} {-# LINE 532 "./src-ag/ExecutionPlan2Caml.ag" #-} rule266 = \ ((_hdIt_visits) :: PP_Doc) -> {-# LINE 532 "./src-ag/ExecutionPlan2Caml.ag" #-} _hdIt_visits {-# LINE 2465 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule267 #-} rule267 = \ ((_hdIchildvisit) :: Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) ((_tlIchildvisit) :: Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) -> _hdIchildvisit `Map.union` _tlIchildvisit {-# INLINE rule268 #-} rule268 = \ ((_hdIcount) :: Int) ((_tlIcount) :: Int) -> _hdIcount + _tlIcount {-# INLINE rule269 #-} rule269 = \ ((_hdIdatatype) :: PP_Doc) ((_tlIdatatype) :: [PP_Doc]) -> _hdIdatatype : _tlIdatatype {-# INLINE rule270 #-} rule270 = \ ((_hdIdatatype_call) :: PP_Doc) ((_tlIdatatype_call) :: [PP_Doc]) -> _hdIdatatype_call : _tlIdatatype_call {-# INLINE rule271 #-} rule271 = \ ((_hdIdatatype_con) :: PP_Doc) ((_tlIdatatype_con) :: [PP_Doc]) -> _hdIdatatype_con : _tlIdatatype_con {-# INLINE rule272 #-} rule272 = \ ((_hdIerrors) :: Seq Error) ((_tlIerrors) :: Seq Error) -> _hdIerrors Seq.>< _tlIerrors {-# INLINE rule273 #-} rule273 = \ ((_hdIfromToStates) :: Map VisitIdentifier (Int,Int)) ((_tlIfromToStates) :: Map VisitIdentifier (Int,Int)) -> _hdIfromToStates `mappend` _tlIfromToStates {-# INLINE rule274 #-} rule274 = \ ((_hdIsemFunBndDefs) :: Seq PP_Doc) ((_tlIsemFunBndDefs) :: Seq PP_Doc) -> _hdIsemFunBndDefs Seq.>< _tlIsemFunBndDefs {-# INLINE rule275 #-} rule275 = \ ((_hdIsemFunBndTps) :: Seq PP_Doc) ((_tlIsemFunBndTps) :: Seq PP_Doc) -> _hdIsemFunBndTps Seq.>< _tlIsemFunBndTps {-# INLINE rule276 #-} rule276 = \ ((_hdIsem_nt) :: PP_Doc) ((_tlIsem_nt) :: PP_Doc) -> _hdIsem_nt >-< _tlIsem_nt {-# INLINE rule277 #-} rule277 = \ ((_hdIsem_prod) :: PP_Doc) ((_tlIsem_prod) :: PP_Doc) -> _hdIsem_prod >-< _tlIsem_prod {-# INLINE rule278 #-} rule278 = \ ((_hdIvisitKinds) :: Map VisitIdentifier VisitKind) ((_tlIvisitKinds) :: Map VisitIdentifier VisitKind) -> _hdIvisitKinds `mappend` _tlIvisitKinds {-# INLINE rule279 #-} rule279 = \ ((_hdIvisitdefs) :: Map VisitIdentifier (Set Identifier)) ((_tlIvisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _hdIvisitdefs `uwSetUnion` _tlIvisitdefs {-# INLINE rule280 #-} rule280 = \ ((_hdIvisituses) :: Map VisitIdentifier (Set Identifier)) ((_tlIvisituses) :: Map VisitIdentifier (Set Identifier)) -> _hdIvisituses `uwSetUnion` _tlIvisituses {-# INLINE rule281 #-} rule281 = \ ((_lhsIallFromToStates) :: Map VisitIdentifier (Int,Int)) -> _lhsIallFromToStates {-# INLINE rule282 #-} rule282 = \ ((_lhsIallInhmap) :: Map NontermIdent Attributes) -> _lhsIallInhmap {-# INLINE rule283 #-} rule283 = \ ((_lhsIallInitStates) :: Map NontermIdent Int) -> _lhsIallInitStates {-# INLINE rule284 #-} rule284 = \ ((_lhsIallSynmap) :: Map NontermIdent Attributes) -> _lhsIallSynmap {-# INLINE rule285 #-} rule285 = \ ((_lhsIallVisitKinds) :: Map VisitIdentifier VisitKind) -> _lhsIallVisitKinds {-# INLINE rule286 #-} rule286 = \ ((_lhsIallchildvisit) :: Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) -> _lhsIallchildvisit {-# INLINE rule287 #-} rule287 = \ ((_lhsIallstates) :: [StateIdentifier]) -> _lhsIallstates {-# INLINE rule288 #-} rule288 = \ ((_lhsIavisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisitdefs {-# INLINE rule289 #-} rule289 = \ ((_lhsIavisituses) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisituses {-# INLINE rule290 #-} rule290 = \ ((_lhsIinhmap) :: Attributes) -> _lhsIinhmap {-# INLINE rule291 #-} rule291 = \ ((_lhsIinitial) :: StateIdentifier) -> _lhsIinitial {-# INLINE rule292 #-} rule292 = \ ((_lhsIlocalAttrTypes) :: Map ConstructorIdent (Map Identifier Type)) -> _lhsIlocalAttrTypes {-# INLINE rule293 #-} rule293 = \ ((_lhsImainFile) :: String) -> _lhsImainFile {-# INLINE rule294 #-} rule294 = \ ((_lhsImainName) :: String) -> _lhsImainName {-# INLINE rule295 #-} rule295 = \ ((_lhsInextVisits) :: Map StateIdentifier StateCtx) -> _lhsInextVisits {-# INLINE rule296 #-} rule296 = \ ((_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule297 #-} rule297 = \ ((_lhsIntType) :: Type) -> _lhsIntType {-# INLINE rule298 #-} rule298 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule299 #-} rule299 = \ ((_lhsIparams) :: [Identifier]) -> _lhsIparams {-# INLINE rule300 #-} rule300 = \ ((_lhsIprevVisits) :: Map StateIdentifier StateCtx) -> _lhsIprevVisits {-# INLINE rule301 #-} rule301 = \ ((_lhsIrename) :: Bool) -> _lhsIrename {-# INLINE rule302 #-} rule302 = \ ((_lhsIsynmap) :: Attributes) -> _lhsIsynmap {-# INLINE rule303 #-} rule303 = \ ((_lhsIallFromToStates) :: Map VisitIdentifier (Int,Int)) -> _lhsIallFromToStates {-# INLINE rule304 #-} rule304 = \ ((_lhsIallInhmap) :: Map NontermIdent Attributes) -> _lhsIallInhmap {-# INLINE rule305 #-} rule305 = \ ((_lhsIallInitStates) :: Map NontermIdent Int) -> _lhsIallInitStates {-# INLINE rule306 #-} rule306 = \ ((_lhsIallSynmap) :: Map NontermIdent Attributes) -> _lhsIallSynmap {-# INLINE rule307 #-} rule307 = \ ((_lhsIallVisitKinds) :: Map VisitIdentifier VisitKind) -> _lhsIallVisitKinds {-# INLINE rule308 #-} rule308 = \ ((_lhsIallchildvisit) :: Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) -> _lhsIallchildvisit {-# INLINE rule309 #-} rule309 = \ ((_lhsIallstates) :: [StateIdentifier]) -> _lhsIallstates {-# INLINE rule310 #-} rule310 = \ ((_lhsIavisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisitdefs {-# INLINE rule311 #-} rule311 = \ ((_lhsIavisituses) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisituses {-# INLINE rule312 #-} rule312 = \ ((_lhsIinhmap) :: Attributes) -> _lhsIinhmap {-# INLINE rule313 #-} rule313 = \ ((_lhsIinitial) :: StateIdentifier) -> _lhsIinitial {-# INLINE rule314 #-} rule314 = \ ((_lhsIlocalAttrTypes) :: Map ConstructorIdent (Map Identifier Type)) -> _lhsIlocalAttrTypes {-# INLINE rule315 #-} rule315 = \ ((_lhsImainFile) :: String) -> _lhsImainFile {-# INLINE rule316 #-} rule316 = \ ((_lhsImainName) :: String) -> _lhsImainName {-# INLINE rule317 #-} rule317 = \ ((_lhsInextVisits) :: Map StateIdentifier StateCtx) -> _lhsInextVisits {-# INLINE rule318 #-} rule318 = \ ((_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule319 #-} rule319 = \ ((_lhsIntType) :: Type) -> _lhsIntType {-# INLINE rule320 #-} rule320 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule321 #-} rule321 = \ ((_lhsIparams) :: [Identifier]) -> _lhsIparams {-# INLINE rule322 #-} rule322 = \ ((_lhsIprevVisits) :: Map StateIdentifier StateCtx) -> _lhsIprevVisits {-# INLINE rule323 #-} rule323 = \ ((_lhsIrename) :: Bool) -> _lhsIrename {-# INLINE rule324 #-} rule324 = \ ((_lhsIsynmap) :: Attributes) -> _lhsIsynmap {-# NOINLINE sem_EProductions_Nil #-} sem_EProductions_Nil :: T_EProductions sem_EProductions_Nil = T_EProductions (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_EProductions_v16 v16 = \ (T_EProductions_vIn16 _lhsIallFromToStates _lhsIallInhmap _lhsIallInitStates _lhsIallSynmap _lhsIallVisitKinds _lhsIallchildvisit _lhsIallstates _lhsIavisitdefs _lhsIavisituses _lhsIinhmap _lhsIinitial _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsInextVisits _lhsInt _lhsIntType _lhsIoptions _lhsIparams _lhsIprevVisits _lhsIrename _lhsIsynmap) -> ( let _lhsOallvisits :: [VisitStateState] _lhsOallvisits = rule325 () _lhsOchildvisit :: Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc) _lhsOchildvisit = rule326 () _lhsOcount :: Int _lhsOcount = rule327 () _lhsOdatatype :: [PP_Doc] _lhsOdatatype = rule328 () _lhsOdatatype_call :: [PP_Doc] _lhsOdatatype_call = rule329 () _lhsOdatatype_con :: [PP_Doc] _lhsOdatatype_con = rule330 () _lhsOerrors :: Seq Error _lhsOerrors = rule331 () _lhsOfromToStates :: Map VisitIdentifier (Int,Int) _lhsOfromToStates = rule332 () _lhsOsemFunBndDefs :: Seq PP_Doc _lhsOsemFunBndDefs = rule333 () _lhsOsemFunBndTps :: Seq PP_Doc _lhsOsemFunBndTps = rule334 () _lhsOsem_nt :: PP_Doc _lhsOsem_nt = rule335 () _lhsOsem_prod :: PP_Doc _lhsOsem_prod = rule336 () _lhsOt_visits :: PP_Doc _lhsOt_visits = rule337 () _lhsOvisitKinds :: Map VisitIdentifier VisitKind _lhsOvisitKinds = rule338 () _lhsOvisitdefs :: Map VisitIdentifier (Set Identifier) _lhsOvisitdefs = rule339 () _lhsOvisituses :: Map VisitIdentifier (Set Identifier) _lhsOvisituses = rule340 () __result_ = T_EProductions_vOut16 _lhsOallvisits _lhsOchildvisit _lhsOcount _lhsOdatatype _lhsOdatatype_call _lhsOdatatype_con _lhsOerrors _lhsOfromToStates _lhsOsemFunBndDefs _lhsOsemFunBndTps _lhsOsem_nt _lhsOsem_prod _lhsOt_visits _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses in __result_ ) in C_EProductions_s17 v16 {-# INLINE rule325 #-} {-# LINE 438 "./src-ag/ExecutionPlan2Caml.ag" #-} rule325 = \ (_ :: ()) -> {-# LINE 438 "./src-ag/ExecutionPlan2Caml.ag" #-} error "Every nonterminal should have at least 1 production" {-# LINE 2687 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule326 #-} rule326 = \ (_ :: ()) -> Map.empty {-# INLINE rule327 #-} rule327 = \ (_ :: ()) -> 0 {-# INLINE rule328 #-} rule328 = \ (_ :: ()) -> [] {-# INLINE rule329 #-} rule329 = \ (_ :: ()) -> [] {-# INLINE rule330 #-} rule330 = \ (_ :: ()) -> [] {-# INLINE rule331 #-} rule331 = \ (_ :: ()) -> Seq.empty {-# INLINE rule332 #-} rule332 = \ (_ :: ()) -> mempty {-# INLINE rule333 #-} rule333 = \ (_ :: ()) -> Seq.empty {-# INLINE rule334 #-} rule334 = \ (_ :: ()) -> Seq.empty {-# INLINE rule335 #-} rule335 = \ (_ :: ()) -> empty {-# INLINE rule336 #-} rule336 = \ (_ :: ()) -> empty {-# INLINE rule337 #-} rule337 = \ (_ :: ()) -> empty {-# INLINE rule338 #-} rule338 = \ (_ :: ()) -> mempty {-# INLINE rule339 #-} rule339 = \ (_ :: ()) -> Map.empty {-# INLINE rule340 #-} rule340 = \ (_ :: ()) -> Map.empty -- ERule ------------------------------------------------------- -- wrapper data Inh_ERule = Inh_ERule { allInhmap_Inh_ERule :: (Map NontermIdent Attributes), allSynmap_Inh_ERule :: (Map NontermIdent Attributes), childTypes_Inh_ERule :: (Map Identifier Type), con_Inh_ERule :: (ConstructorIdent), inhmap_Inh_ERule :: (Attributes), lazyIntras_Inh_ERule :: (Set String), localAttrTypes_Inh_ERule :: (Map Identifier Type), mainFile_Inh_ERule :: (String), mainName_Inh_ERule :: (String), nt_Inh_ERule :: (NontermIdent), options_Inh_ERule :: (Options), ruleKinds_Inh_ERule :: (Map Identifier (Set VisitKind)), synmap_Inh_ERule :: (Attributes), usageInfo_Inh_ERule :: (Map Identifier Int) } data Syn_ERule = Syn_ERule { errors_Syn_ERule :: (Seq Error), mrules_Syn_ERule :: (Map Identifier (VisitKind -> Either Error PP_Doc)), ruledefs_Syn_ERule :: (Map Identifier (Set String)), ruleuses_Syn_ERule :: (Map Identifier (Map String (Maybe NonLocalAttr))), sem_rules_Syn_ERule :: (PP_Doc) } {-# INLINABLE wrap_ERule #-} wrap_ERule :: T_ERule -> Inh_ERule -> (Syn_ERule ) wrap_ERule (T_ERule act) (Inh_ERule _lhsIallInhmap _lhsIallSynmap _lhsIchildTypes _lhsIcon _lhsIinhmap _lhsIlazyIntras _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsInt _lhsIoptions _lhsIruleKinds _lhsIsynmap _lhsIusageInfo) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_ERule_vIn19 _lhsIallInhmap _lhsIallSynmap _lhsIchildTypes _lhsIcon _lhsIinhmap _lhsIlazyIntras _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsInt _lhsIoptions _lhsIruleKinds _lhsIsynmap _lhsIusageInfo (T_ERule_vOut19 _lhsOerrors _lhsOmrules _lhsOruledefs _lhsOruleuses _lhsOsem_rules) <- return (inv_ERule_s20 sem arg) return (Syn_ERule _lhsOerrors _lhsOmrules _lhsOruledefs _lhsOruleuses _lhsOsem_rules) ) -- cata {-# INLINE sem_ERule #-} sem_ERule :: ERule -> T_ERule sem_ERule ( ERule name_ pattern_ rhs_ owrt_ origin_ explicit_ pure_ mbError_ ) = sem_ERule_ERule name_ ( sem_Pattern pattern_ ) ( sem_Expression rhs_ ) owrt_ origin_ explicit_ pure_ mbError_ -- semantic domain newtype T_ERule = T_ERule { attach_T_ERule :: Identity (T_ERule_s20 ) } newtype T_ERule_s20 = C_ERule_s20 { inv_ERule_s20 :: (T_ERule_v19 ) } data T_ERule_s21 = C_ERule_s21 type T_ERule_v19 = (T_ERule_vIn19 ) -> (T_ERule_vOut19 ) data T_ERule_vIn19 = T_ERule_vIn19 (Map NontermIdent Attributes) (Map NontermIdent Attributes) (Map Identifier Type) (ConstructorIdent) (Attributes) (Set String) (Map Identifier Type) (String) (String) (NontermIdent) (Options) (Map Identifier (Set VisitKind)) (Attributes) (Map Identifier Int) data T_ERule_vOut19 = T_ERule_vOut19 (Seq Error) (Map Identifier (VisitKind -> Either Error PP_Doc)) (Map Identifier (Set String)) (Map Identifier (Map String (Maybe NonLocalAttr))) (PP_Doc) {-# NOINLINE sem_ERule_ERule #-} sem_ERule_ERule :: (Identifier) -> T_Pattern -> T_Expression -> (Bool) -> (String) -> (Bool) -> (Bool) -> (Maybe Error) -> T_ERule sem_ERule_ERule arg_name_ arg_pattern_ arg_rhs_ _ _ arg_explicit_ arg_pure_ arg_mbError_ = T_ERule (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_ERule_v19 v19 = \ (T_ERule_vIn19 _lhsIallInhmap _lhsIallSynmap _lhsIchildTypes _lhsIcon _lhsIinhmap _lhsIlazyIntras _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsInt _lhsIoptions _lhsIruleKinds _lhsIsynmap _lhsIusageInfo) -> ( let _patternX41 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pattern_)) _rhsX29 = Control.Monad.Identity.runIdentity (attach_T_Expression (arg_rhs_)) (T_Pattern_vOut40 _patternIattrTypes _patternIattrs _patternIcopy _patternIextraDefs _patternIisUnderscore _patternIsem_lhs) = inv_Pattern_s41 _patternX41 (T_Pattern_vIn40 _patternOallInhmap _patternOallSynmap _patternOanyLazyKind _patternOinhmap _patternOlocalAttrTypes _patternOoptions _patternOsynmap) (T_Expression_vOut28 _rhsIattrs _rhsIpos _rhsIsemfunc _rhsItks) = inv_Expression_s29 _rhsX29 (T_Expression_vIn28 ) _lhsOsem_rules :: PP_Doc _lhsOsem_rules = rule341 _rulecode _used _rulecode = rule342 _declHead _endpragma _genpragma _pragma _rhsIpos _rhsIsemfunc _pragma = rule343 _lhsIoptions _rhsIpos _endpragma = rule344 _lhsImainFile _lhsIoptions _genpragma = rule345 _haspos _lhsIoptions arg_explicit_ _haspos = rule346 _rhsIpos _declHead = rule347 _argPats _lhsIoptions _rhsIattrs arg_name_ _argPats = rule348 _lhsIallInhmap _lhsIallSynmap _lhsIchildTypes _lhsIlocalAttrTypes _lhsIoptions _rhsIattrs _argExprs = rule349 _rhsIattrs _stepcode = rule350 _argExprs _lhsIoptions _patternIextraDefs _patternIsem_lhs _rhsIattrs arg_name_ arg_pure_ _lhsOmrules :: Map Identifier (VisitKind -> Either Error PP_Doc) _lhsOmrules = rule351 _stepcode arg_name_ _used = rule352 _lhsIusageInfo arg_name_ _kinds = rule353 _lhsIruleKinds arg_name_ _anyLazyKind = rule354 _kinds _lhsOruledefs :: Map Identifier (Set String) _lhsOruledefs = rule355 _patternIattrs arg_name_ _lhsOruleuses :: Map Identifier (Map String (Maybe NonLocalAttr)) _lhsOruleuses = rule356 _rhsIattrs arg_name_ _lhsOerrors :: Seq Error _lhsOerrors = rule357 _used arg_mbError_ _patternOallInhmap = rule358 _lhsIallInhmap _patternOallSynmap = rule359 _lhsIallSynmap _patternOanyLazyKind = rule360 _anyLazyKind _patternOinhmap = rule361 _lhsIinhmap _patternOlocalAttrTypes = rule362 _lhsIlocalAttrTypes _patternOoptions = rule363 _lhsIoptions _patternOsynmap = rule364 _lhsIsynmap __result_ = T_ERule_vOut19 _lhsOerrors _lhsOmrules _lhsOruledefs _lhsOruleuses _lhsOsem_rules in __result_ ) in C_ERule_s20 v19 {-# INLINE rule341 #-} {-# LINE 975 "./src-ag/ExecutionPlan2Caml.ag" #-} rule341 = \ _rulecode _used -> {-# LINE 975 "./src-ag/ExecutionPlan2Caml.ag" #-} if _used == 0 then empty else _rulecode {-# LINE 2814 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule342 #-} {-# LINE 978 "./src-ag/ExecutionPlan2Caml.ag" #-} rule342 = \ _declHead _endpragma _genpragma _pragma ((_rhsIpos) :: Pos) ((_rhsIsemfunc) :: PP_Doc) -> {-# LINE 978 "./src-ag/ExecutionPlan2Caml.ag" #-} ( if _genpragma then _pragma else empty ) >-< _declHead >-< indent ((column _rhsIpos - 2) `max` 2) ( if _genpragma then _pragma >-< _rhsIsemfunc >-< _endpragma else _rhsIsemfunc ) >#< "in" {-# LINE 2830 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule343 #-} {-# LINE 991 "./src-ag/ExecutionPlan2Caml.ag" #-} rule343 = \ ((_lhsIoptions) :: Options) ((_rhsIpos) :: Pos) -> {-# LINE 991 "./src-ag/ExecutionPlan2Caml.ag" #-} ppLinePragma _lhsIoptions (line _rhsIpos) (file _rhsIpos) {-# LINE 2836 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule344 #-} {-# LINE 992 "./src-ag/ExecutionPlan2Caml.ag" #-} rule344 = \ ((_lhsImainFile) :: String) ((_lhsIoptions) :: Options) -> {-# LINE 992 "./src-ag/ExecutionPlan2Caml.ag" #-} ppWithLineNr (\ln -> ppLinePragma _lhsIoptions (ln+1) _lhsImainFile) {-# LINE 2842 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule345 #-} {-# LINE 993 "./src-ag/ExecutionPlan2Caml.ag" #-} rule345 = \ _haspos ((_lhsIoptions) :: Options) explicit_ -> {-# LINE 993 "./src-ag/ExecutionPlan2Caml.ag" #-} genLinePragmas _lhsIoptions && explicit_ && _haspos {-# LINE 2848 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule346 #-} {-# LINE 994 "./src-ag/ExecutionPlan2Caml.ag" #-} rule346 = \ ((_rhsIpos) :: Pos) -> {-# LINE 994 "./src-ag/ExecutionPlan2Caml.ag" #-} line _rhsIpos > 0 && column _rhsIpos >= 0 && not (null (file _rhsIpos)) {-# LINE 2854 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule347 #-} {-# LINE 998 "./src-ag/ExecutionPlan2Caml.ag" #-} rule347 = \ _argPats ((_lhsIoptions) :: Options) ((_rhsIattrs) :: Map String (Maybe NonLocalAttr)) name_ -> {-# LINE 998 "./src-ag/ExecutionPlan2Caml.ag" #-} "let" >#< name_ >#< _argPats >#< dummyPat _lhsIoptions (Map.null _rhsIattrs) >#< "=" {-# LINE 2860 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule348 #-} {-# LINE 1000 "./src-ag/ExecutionPlan2Caml.ag" #-} rule348 = \ ((_lhsIallInhmap) :: Map NontermIdent Attributes) ((_lhsIallSynmap) :: Map NontermIdent Attributes) ((_lhsIchildTypes) :: Map Identifier Type) ((_lhsIlocalAttrTypes) :: Map Identifier Type) ((_lhsIoptions) :: Options) ((_rhsIattrs) :: Map String (Maybe NonLocalAttr)) -> {-# LINE 1000 "./src-ag/ExecutionPlan2Caml.ag" #-} ppSpaced [ case mbAttr of Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs _lhsIoptions) -> case Map.lookup nm _lhsIlocalAttrTypes of Just tp -> pp_parens (strNm >#< ":" >#< ppTp tp) Nothing -> pp strNm Just attr | not (noPerStateTypeSigs _lhsIoptions) -> case lookupAttrType attr _lhsIallInhmap _lhsIallSynmap _lhsIchildTypes of Just tpDoc -> pp_parens (strNm >#< ":" >#< tpDoc) Nothing -> pp strNm _ -> pp strNm | (strNm, mbAttr) <- Map.assocs _rhsIattrs ] {-# LINE 2878 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule349 #-} {-# LINE 1014 "./src-ag/ExecutionPlan2Caml.ag" #-} rule349 = \ ((_rhsIattrs) :: Map String (Maybe NonLocalAttr)) -> {-# LINE 1014 "./src-ag/ExecutionPlan2Caml.ag" #-} ppSpaced $ Map.keys _rhsIattrs {-# LINE 2884 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule350 #-} {-# LINE 1015 "./src-ag/ExecutionPlan2Caml.ag" #-} rule350 = \ _argExprs ((_lhsIoptions) :: Options) ((_patternIextraDefs) :: [(PP_Doc,PP_Doc)]) ((_patternIsem_lhs) :: PP_Doc ) ((_rhsIattrs) :: Map String (Maybe NonLocalAttr)) name_ pure_ -> {-# LINE 1015 "./src-ag/ExecutionPlan2Caml.ag" #-} \kind -> let mkBind (pat,expr) = "let" >#< pat >#< "=" >#< expr >#< "in" in if kind `compatibleRule` pure_ then Right $ mkBind (_patternIsem_lhs, name_ >#< _argExprs >#< dummyArg _lhsIoptions (Map.null _rhsIattrs)) >-< vlist (map mkBind _patternIextraDefs) else Left $ IncompatibleRuleKind name_ kind {-# LINE 2895 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule351 #-} {-# LINE 1022 "./src-ag/ExecutionPlan2Caml.ag" #-} rule351 = \ _stepcode name_ -> {-# LINE 1022 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.singleton name_ _stepcode {-# LINE 2901 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule352 #-} {-# LINE 1224 "./src-ag/ExecutionPlan2Caml.ag" #-} rule352 = \ ((_lhsIusageInfo) :: Map Identifier Int) name_ -> {-# LINE 1224 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.findWithDefault 0 name_ _lhsIusageInfo {-# LINE 2907 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule353 #-} {-# LINE 1240 "./src-ag/ExecutionPlan2Caml.ag" #-} rule353 = \ ((_lhsIruleKinds) :: Map Identifier (Set VisitKind)) name_ -> {-# LINE 1240 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.findWithDefault Set.empty name_ _lhsIruleKinds {-# LINE 2913 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule354 #-} {-# LINE 1241 "./src-ag/ExecutionPlan2Caml.ag" #-} rule354 = \ _kinds -> {-# LINE 1241 "./src-ag/ExecutionPlan2Caml.ag" #-} Set.fold (\k r -> isLazyKind k || r) False _kinds {-# LINE 2919 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule355 #-} {-# LINE 1287 "./src-ag/ExecutionPlan2Caml.ag" #-} rule355 = \ ((_patternIattrs) :: Set String) name_ -> {-# LINE 1287 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.singleton name_ _patternIattrs {-# LINE 2925 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule356 #-} {-# LINE 1288 "./src-ag/ExecutionPlan2Caml.ag" #-} rule356 = \ ((_rhsIattrs) :: Map String (Maybe NonLocalAttr)) name_ -> {-# LINE 1288 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.singleton name_ _rhsIattrs {-# LINE 2931 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule357 #-} {-# LINE 1482 "./src-ag/ExecutionPlan2Caml.ag" #-} rule357 = \ _used mbError_ -> {-# LINE 1482 "./src-ag/ExecutionPlan2Caml.ag" #-} case mbError_ of Just e | _used > 0 -> Seq.singleton e _ -> Seq.empty {-# LINE 2939 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule358 #-} rule358 = \ ((_lhsIallInhmap) :: Map NontermIdent Attributes) -> _lhsIallInhmap {-# INLINE rule359 #-} rule359 = \ ((_lhsIallSynmap) :: Map NontermIdent Attributes) -> _lhsIallSynmap {-# INLINE rule360 #-} rule360 = \ _anyLazyKind -> _anyLazyKind {-# INLINE rule361 #-} rule361 = \ ((_lhsIinhmap) :: Attributes) -> _lhsIinhmap {-# INLINE rule362 #-} rule362 = \ ((_lhsIlocalAttrTypes) :: Map Identifier Type) -> _lhsIlocalAttrTypes {-# INLINE rule363 #-} rule363 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule364 #-} rule364 = \ ((_lhsIsynmap) :: Attributes) -> _lhsIsynmap -- ERules ------------------------------------------------------ -- wrapper data Inh_ERules = Inh_ERules { allInhmap_Inh_ERules :: (Map NontermIdent Attributes), allSynmap_Inh_ERules :: (Map NontermIdent Attributes), childTypes_Inh_ERules :: (Map Identifier Type), con_Inh_ERules :: (ConstructorIdent), inhmap_Inh_ERules :: (Attributes), lazyIntras_Inh_ERules :: (Set String), localAttrTypes_Inh_ERules :: (Map Identifier Type), mainFile_Inh_ERules :: (String), mainName_Inh_ERules :: (String), nt_Inh_ERules :: (NontermIdent), options_Inh_ERules :: (Options), ruleKinds_Inh_ERules :: (Map Identifier (Set VisitKind)), synmap_Inh_ERules :: (Attributes), usageInfo_Inh_ERules :: (Map Identifier Int) } data Syn_ERules = Syn_ERules { errors_Syn_ERules :: (Seq Error), mrules_Syn_ERules :: (Map Identifier (VisitKind -> Either Error PP_Doc)), ruledefs_Syn_ERules :: (Map Identifier (Set String)), ruleuses_Syn_ERules :: (Map Identifier (Map String (Maybe NonLocalAttr))), sem_rules_Syn_ERules :: (PP_Doc) } {-# INLINABLE wrap_ERules #-} wrap_ERules :: T_ERules -> Inh_ERules -> (Syn_ERules ) wrap_ERules (T_ERules act) (Inh_ERules _lhsIallInhmap _lhsIallSynmap _lhsIchildTypes _lhsIcon _lhsIinhmap _lhsIlazyIntras _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsInt _lhsIoptions _lhsIruleKinds _lhsIsynmap _lhsIusageInfo) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_ERules_vIn22 _lhsIallInhmap _lhsIallSynmap _lhsIchildTypes _lhsIcon _lhsIinhmap _lhsIlazyIntras _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsInt _lhsIoptions _lhsIruleKinds _lhsIsynmap _lhsIusageInfo (T_ERules_vOut22 _lhsOerrors _lhsOmrules _lhsOruledefs _lhsOruleuses _lhsOsem_rules) <- return (inv_ERules_s23 sem arg) return (Syn_ERules _lhsOerrors _lhsOmrules _lhsOruledefs _lhsOruleuses _lhsOsem_rules) ) -- cata {-# NOINLINE sem_ERules #-} sem_ERules :: ERules -> T_ERules sem_ERules list = Prelude.foldr sem_ERules_Cons sem_ERules_Nil (Prelude.map sem_ERule list) -- semantic domain newtype T_ERules = T_ERules { attach_T_ERules :: Identity (T_ERules_s23 ) } newtype T_ERules_s23 = C_ERules_s23 { inv_ERules_s23 :: (T_ERules_v22 ) } data T_ERules_s24 = C_ERules_s24 type T_ERules_v22 = (T_ERules_vIn22 ) -> (T_ERules_vOut22 ) data T_ERules_vIn22 = T_ERules_vIn22 (Map NontermIdent Attributes) (Map NontermIdent Attributes) (Map Identifier Type) (ConstructorIdent) (Attributes) (Set String) (Map Identifier Type) (String) (String) (NontermIdent) (Options) (Map Identifier (Set VisitKind)) (Attributes) (Map Identifier Int) data T_ERules_vOut22 = T_ERules_vOut22 (Seq Error) (Map Identifier (VisitKind -> Either Error PP_Doc)) (Map Identifier (Set String)) (Map Identifier (Map String (Maybe NonLocalAttr))) (PP_Doc) {-# NOINLINE sem_ERules_Cons #-} sem_ERules_Cons :: T_ERule -> T_ERules -> T_ERules sem_ERules_Cons arg_hd_ arg_tl_ = T_ERules (return st23) where {-# NOINLINE st23 #-} st23 = let v22 :: T_ERules_v22 v22 = \ (T_ERules_vIn22 _lhsIallInhmap _lhsIallSynmap _lhsIchildTypes _lhsIcon _lhsIinhmap _lhsIlazyIntras _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsInt _lhsIoptions _lhsIruleKinds _lhsIsynmap _lhsIusageInfo) -> ( let _hdX20 = Control.Monad.Identity.runIdentity (attach_T_ERule (arg_hd_)) _tlX23 = Control.Monad.Identity.runIdentity (attach_T_ERules (arg_tl_)) (T_ERule_vOut19 _hdIerrors _hdImrules _hdIruledefs _hdIruleuses _hdIsem_rules) = inv_ERule_s20 _hdX20 (T_ERule_vIn19 _hdOallInhmap _hdOallSynmap _hdOchildTypes _hdOcon _hdOinhmap _hdOlazyIntras _hdOlocalAttrTypes _hdOmainFile _hdOmainName _hdOnt _hdOoptions _hdOruleKinds _hdOsynmap _hdOusageInfo) (T_ERules_vOut22 _tlIerrors _tlImrules _tlIruledefs _tlIruleuses _tlIsem_rules) = inv_ERules_s23 _tlX23 (T_ERules_vIn22 _tlOallInhmap _tlOallSynmap _tlOchildTypes _tlOcon _tlOinhmap _tlOlazyIntras _tlOlocalAttrTypes _tlOmainFile _tlOmainName _tlOnt _tlOoptions _tlOruleKinds _tlOsynmap _tlOusageInfo) _lhsOerrors :: Seq Error _lhsOerrors = rule365 _hdIerrors _tlIerrors _lhsOmrules :: Map Identifier (VisitKind -> Either Error PP_Doc) _lhsOmrules = rule366 _hdImrules _tlImrules _lhsOruledefs :: Map Identifier (Set String) _lhsOruledefs = rule367 _hdIruledefs _tlIruledefs _lhsOruleuses :: Map Identifier (Map String (Maybe NonLocalAttr)) _lhsOruleuses = rule368 _hdIruleuses _tlIruleuses _lhsOsem_rules :: PP_Doc _lhsOsem_rules = rule369 _hdIsem_rules _tlIsem_rules _hdOallInhmap = rule370 _lhsIallInhmap _hdOallSynmap = rule371 _lhsIallSynmap _hdOchildTypes = rule372 _lhsIchildTypes _hdOcon = rule373 _lhsIcon _hdOinhmap = rule374 _lhsIinhmap _hdOlazyIntras = rule375 _lhsIlazyIntras _hdOlocalAttrTypes = rule376 _lhsIlocalAttrTypes _hdOmainFile = rule377 _lhsImainFile _hdOmainName = rule378 _lhsImainName _hdOnt = rule379 _lhsInt _hdOoptions = rule380 _lhsIoptions _hdOruleKinds = rule381 _lhsIruleKinds _hdOsynmap = rule382 _lhsIsynmap _hdOusageInfo = rule383 _lhsIusageInfo _tlOallInhmap = rule384 _lhsIallInhmap _tlOallSynmap = rule385 _lhsIallSynmap _tlOchildTypes = rule386 _lhsIchildTypes _tlOcon = rule387 _lhsIcon _tlOinhmap = rule388 _lhsIinhmap _tlOlazyIntras = rule389 _lhsIlazyIntras _tlOlocalAttrTypes = rule390 _lhsIlocalAttrTypes _tlOmainFile = rule391 _lhsImainFile _tlOmainName = rule392 _lhsImainName _tlOnt = rule393 _lhsInt _tlOoptions = rule394 _lhsIoptions _tlOruleKinds = rule395 _lhsIruleKinds _tlOsynmap = rule396 _lhsIsynmap _tlOusageInfo = rule397 _lhsIusageInfo __result_ = T_ERules_vOut22 _lhsOerrors _lhsOmrules _lhsOruledefs _lhsOruleuses _lhsOsem_rules in __result_ ) in C_ERules_s23 v22 {-# INLINE rule365 #-} rule365 = \ ((_hdIerrors) :: Seq Error) ((_tlIerrors) :: Seq Error) -> _hdIerrors Seq.>< _tlIerrors {-# INLINE rule366 #-} rule366 = \ ((_hdImrules) :: Map Identifier (VisitKind -> Either Error PP_Doc)) ((_tlImrules) :: Map Identifier (VisitKind -> Either Error PP_Doc)) -> _hdImrules `Map.union` _tlImrules {-# INLINE rule367 #-} rule367 = \ ((_hdIruledefs) :: Map Identifier (Set String)) ((_tlIruledefs) :: Map Identifier (Set String)) -> _hdIruledefs `uwSetUnion` _tlIruledefs {-# INLINE rule368 #-} rule368 = \ ((_hdIruleuses) :: Map Identifier (Map String (Maybe NonLocalAttr))) ((_tlIruleuses) :: Map Identifier (Map String (Maybe NonLocalAttr))) -> _hdIruleuses `uwMapUnion` _tlIruleuses {-# INLINE rule369 #-} rule369 = \ ((_hdIsem_rules) :: PP_Doc) ((_tlIsem_rules) :: PP_Doc) -> _hdIsem_rules >-< _tlIsem_rules {-# INLINE rule370 #-} rule370 = \ ((_lhsIallInhmap) :: Map NontermIdent Attributes) -> _lhsIallInhmap {-# INLINE rule371 #-} rule371 = \ ((_lhsIallSynmap) :: Map NontermIdent Attributes) -> _lhsIallSynmap {-# INLINE rule372 #-} rule372 = \ ((_lhsIchildTypes) :: Map Identifier Type) -> _lhsIchildTypes {-# INLINE rule373 #-} rule373 = \ ((_lhsIcon) :: ConstructorIdent) -> _lhsIcon {-# INLINE rule374 #-} rule374 = \ ((_lhsIinhmap) :: Attributes) -> _lhsIinhmap {-# INLINE rule375 #-} rule375 = \ ((_lhsIlazyIntras) :: Set String) -> _lhsIlazyIntras {-# INLINE rule376 #-} rule376 = \ ((_lhsIlocalAttrTypes) :: Map Identifier Type) -> _lhsIlocalAttrTypes {-# INLINE rule377 #-} rule377 = \ ((_lhsImainFile) :: String) -> _lhsImainFile {-# INLINE rule378 #-} rule378 = \ ((_lhsImainName) :: String) -> _lhsImainName {-# INLINE rule379 #-} rule379 = \ ((_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule380 #-} rule380 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule381 #-} rule381 = \ ((_lhsIruleKinds) :: Map Identifier (Set VisitKind)) -> _lhsIruleKinds {-# INLINE rule382 #-} rule382 = \ ((_lhsIsynmap) :: Attributes) -> _lhsIsynmap {-# INLINE rule383 #-} rule383 = \ ((_lhsIusageInfo) :: Map Identifier Int) -> _lhsIusageInfo {-# INLINE rule384 #-} rule384 = \ ((_lhsIallInhmap) :: Map NontermIdent Attributes) -> _lhsIallInhmap {-# INLINE rule385 #-} rule385 = \ ((_lhsIallSynmap) :: Map NontermIdent Attributes) -> _lhsIallSynmap {-# INLINE rule386 #-} rule386 = \ ((_lhsIchildTypes) :: Map Identifier Type) -> _lhsIchildTypes {-# INLINE rule387 #-} rule387 = \ ((_lhsIcon) :: ConstructorIdent) -> _lhsIcon {-# INLINE rule388 #-} rule388 = \ ((_lhsIinhmap) :: Attributes) -> _lhsIinhmap {-# INLINE rule389 #-} rule389 = \ ((_lhsIlazyIntras) :: Set String) -> _lhsIlazyIntras {-# INLINE rule390 #-} rule390 = \ ((_lhsIlocalAttrTypes) :: Map Identifier Type) -> _lhsIlocalAttrTypes {-# INLINE rule391 #-} rule391 = \ ((_lhsImainFile) :: String) -> _lhsImainFile {-# INLINE rule392 #-} rule392 = \ ((_lhsImainName) :: String) -> _lhsImainName {-# INLINE rule393 #-} rule393 = \ ((_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule394 #-} rule394 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule395 #-} rule395 = \ ((_lhsIruleKinds) :: Map Identifier (Set VisitKind)) -> _lhsIruleKinds {-# INLINE rule396 #-} rule396 = \ ((_lhsIsynmap) :: Attributes) -> _lhsIsynmap {-# INLINE rule397 #-} rule397 = \ ((_lhsIusageInfo) :: Map Identifier Int) -> _lhsIusageInfo {-# NOINLINE sem_ERules_Nil #-} sem_ERules_Nil :: T_ERules sem_ERules_Nil = T_ERules (return st23) where {-# NOINLINE st23 #-} st23 = let v22 :: T_ERules_v22 v22 = \ (T_ERules_vIn22 _lhsIallInhmap _lhsIallSynmap _lhsIchildTypes _lhsIcon _lhsIinhmap _lhsIlazyIntras _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsInt _lhsIoptions _lhsIruleKinds _lhsIsynmap _lhsIusageInfo) -> ( let _lhsOerrors :: Seq Error _lhsOerrors = rule398 () _lhsOmrules :: Map Identifier (VisitKind -> Either Error PP_Doc) _lhsOmrules = rule399 () _lhsOruledefs :: Map Identifier (Set String) _lhsOruledefs = rule400 () _lhsOruleuses :: Map Identifier (Map String (Maybe NonLocalAttr)) _lhsOruleuses = rule401 () _lhsOsem_rules :: PP_Doc _lhsOsem_rules = rule402 () __result_ = T_ERules_vOut22 _lhsOerrors _lhsOmrules _lhsOruledefs _lhsOruleuses _lhsOsem_rules in __result_ ) in C_ERules_s23 v22 {-# INLINE rule398 #-} rule398 = \ (_ :: ()) -> Seq.empty {-# INLINE rule399 #-} rule399 = \ (_ :: ()) -> Map.empty {-# INLINE rule400 #-} rule400 = \ (_ :: ()) -> Map.empty {-# INLINE rule401 #-} rule401 = \ (_ :: ()) -> Map.empty {-# INLINE rule402 #-} rule402 = \ (_ :: ()) -> empty -- ExecutionPlan ----------------------------------------------- -- wrapper data Inh_ExecutionPlan = Inh_ExecutionPlan { inhmap_Inh_ExecutionPlan :: (Map NontermIdent Attributes), localAttrTypes_Inh_ExecutionPlan :: (Map NontermIdent (Map ConstructorIdent (Map Identifier Type))), mainFile_Inh_ExecutionPlan :: (String), mainName_Inh_ExecutionPlan :: (String), options_Inh_ExecutionPlan :: (Options), synmap_Inh_ExecutionPlan :: (Map NontermIdent Attributes) } data Syn_ExecutionPlan = Syn_ExecutionPlan { code_Syn_ExecutionPlan :: (PP_Doc), datas_Syn_ExecutionPlan :: (PP_Doc), errors_Syn_ExecutionPlan :: (Seq Error), modules_Syn_ExecutionPlan :: (PP_Doc) } {-# INLINABLE wrap_ExecutionPlan #-} wrap_ExecutionPlan :: T_ExecutionPlan -> Inh_ExecutionPlan -> (Syn_ExecutionPlan ) wrap_ExecutionPlan (T_ExecutionPlan act) (Inh_ExecutionPlan _lhsIinhmap _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsIoptions _lhsIsynmap) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_ExecutionPlan_vIn25 _lhsIinhmap _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsIoptions _lhsIsynmap (T_ExecutionPlan_vOut25 _lhsOcode _lhsOdatas _lhsOerrors _lhsOmodules) <- return (inv_ExecutionPlan_s26 sem arg) return (Syn_ExecutionPlan _lhsOcode _lhsOdatas _lhsOerrors _lhsOmodules) ) -- cata {-# INLINE sem_ExecutionPlan #-} sem_ExecutionPlan :: ExecutionPlan -> T_ExecutionPlan sem_ExecutionPlan ( ExecutionPlan nonts_ typeSyns_ wrappers_ derivings_ ) = sem_ExecutionPlan_ExecutionPlan ( sem_ENonterminals nonts_ ) typeSyns_ wrappers_ derivings_ -- semantic domain newtype T_ExecutionPlan = T_ExecutionPlan { attach_T_ExecutionPlan :: Identity (T_ExecutionPlan_s26 ) } newtype T_ExecutionPlan_s26 = C_ExecutionPlan_s26 { inv_ExecutionPlan_s26 :: (T_ExecutionPlan_v25 ) } data T_ExecutionPlan_s27 = C_ExecutionPlan_s27 type T_ExecutionPlan_v25 = (T_ExecutionPlan_vIn25 ) -> (T_ExecutionPlan_vOut25 ) data T_ExecutionPlan_vIn25 = T_ExecutionPlan_vIn25 (Map NontermIdent Attributes) (Map NontermIdent (Map ConstructorIdent (Map Identifier Type))) (String) (String) (Options) (Map NontermIdent Attributes) data T_ExecutionPlan_vOut25 = T_ExecutionPlan_vOut25 (PP_Doc) (PP_Doc) (Seq Error) (PP_Doc) {-# NOINLINE sem_ExecutionPlan_ExecutionPlan #-} sem_ExecutionPlan_ExecutionPlan :: T_ENonterminals -> (TypeSyns) -> (Set NontermIdent) -> (Derivings) -> T_ExecutionPlan sem_ExecutionPlan_ExecutionPlan arg_nonts_ arg_typeSyns_ arg_wrappers_ _ = T_ExecutionPlan (return st26) where {-# NOINLINE st26 #-} st26 = let v25 :: T_ExecutionPlan_v25 v25 = \ (T_ExecutionPlan_vIn25 _lhsIinhmap _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsIoptions _lhsIsynmap) -> ( let _nontsX11 = Control.Monad.Identity.runIdentity (attach_T_ENonterminals (arg_nonts_)) (T_ENonterminals_vOut10 _nontsIchildvisit _nontsIcode _nontsIdatas _nontsIerrors _nontsIfromToStates _nontsIinitStates _nontsImodules _nontsIsemFunBndDefs _nontsIsemFunBndTps _nontsIvisitKinds _nontsIvisitdefs _nontsIvisituses) = inv_ENonterminals_s11 _nontsX11 (T_ENonterminals_vIn10 _nontsOallFromToStates _nontsOallInitStates _nontsOallVisitKinds _nontsOallchildvisit _nontsOavisitdefs _nontsOavisituses _nontsOinhmap _nontsOlocalAttrTypes _nontsOmainFile _nontsOmainName _nontsOoptions _nontsOsynmap _nontsOtypeSyns _nontsOwrappers) _lhsOcode :: PP_Doc _lhsOcode = rule403 _nontsIcode _wrappersExtra _lhsOdatas :: PP_Doc _lhsOdatas = rule404 _commonExtra _nontsIdatas _nontsOwrappers = rule405 arg_wrappers_ _nontsOtypeSyns = rule406 arg_typeSyns_ _wrappersExtra = rule407 _lateSemBndDef _lhsIoptions _commonExtra = rule408 _lateSemBndTp _lhsIoptions _lateSemBndTp = rule409 _lhsImainName _nontsIsemFunBndTps _lateSemBndDef = rule410 _lhsImainName _nontsIsemFunBndDefs _nontsOallchildvisit = rule411 _nontsIchildvisit _nontsOavisitdefs = rule412 _nontsIvisitdefs _nontsOavisituses = rule413 _nontsIvisituses _nontsOallFromToStates = rule414 _nontsIfromToStates _nontsOallVisitKinds = rule415 _nontsIvisitKinds _nontsOallInitStates = rule416 _nontsIinitStates _lhsOerrors :: Seq Error _lhsOerrors = rule417 _nontsIerrors _lhsOmodules :: PP_Doc _lhsOmodules = rule418 _nontsImodules _nontsOinhmap = rule419 _lhsIinhmap _nontsOlocalAttrTypes = rule420 _lhsIlocalAttrTypes _nontsOmainFile = rule421 _lhsImainFile _nontsOmainName = rule422 _lhsImainName _nontsOoptions = rule423 _lhsIoptions _nontsOsynmap = rule424 _lhsIsynmap __result_ = T_ExecutionPlan_vOut25 _lhsOcode _lhsOdatas _lhsOerrors _lhsOmodules in __result_ ) in C_ExecutionPlan_s26 v25 {-# INLINE rule403 #-} {-# LINE 103 "./src-ag/ExecutionPlan2Caml.ag" #-} rule403 = \ ((_nontsIcode) :: PP_Doc) _wrappersExtra -> {-# LINE 103 "./src-ag/ExecutionPlan2Caml.ag" #-} _nontsIcode >-< _wrappersExtra {-# LINE 3252 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule404 #-} {-# LINE 104 "./src-ag/ExecutionPlan2Caml.ag" #-} rule404 = \ _commonExtra ((_nontsIdatas) :: PP_Doc) -> {-# LINE 104 "./src-ag/ExecutionPlan2Caml.ag" #-} _nontsIdatas >-< _commonExtra {-# LINE 3258 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule405 #-} {-# LINE 110 "./src-ag/ExecutionPlan2Caml.ag" #-} rule405 = \ wrappers_ -> {-# LINE 110 "./src-ag/ExecutionPlan2Caml.ag" #-} wrappers_ {-# LINE 3264 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule406 #-} {-# LINE 171 "./src-ag/ExecutionPlan2Caml.ag" #-} rule406 = \ typeSyns_ -> {-# LINE 171 "./src-ag/ExecutionPlan2Caml.ag" #-} typeSyns_ {-# LINE 3270 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule407 #-} {-# LINE 661 "./src-ag/ExecutionPlan2Caml.ag" #-} rule407 = \ _lateSemBndDef ((_lhsIoptions) :: Options) -> {-# LINE 661 "./src-ag/ExecutionPlan2Caml.ag" #-} if lateHigherOrderBinding _lhsIoptions then _lateSemBndDef else empty {-# LINE 3278 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule408 #-} {-# LINE 664 "./src-ag/ExecutionPlan2Caml.ag" #-} rule408 = \ _lateSemBndTp ((_lhsIoptions) :: Options) -> {-# LINE 664 "./src-ag/ExecutionPlan2Caml.ag" #-} if lateHigherOrderBinding _lhsIoptions then _lateSemBndTp else empty {-# LINE 3286 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule409 #-} {-# LINE 667 "./src-ag/ExecutionPlan2Caml.ag" #-} rule409 = \ ((_lhsImainName) :: String) ((_nontsIsemFunBndTps) :: Seq PP_Doc) -> {-# LINE 667 "./src-ag/ExecutionPlan2Caml.ag" #-} "and" >#< lateBindingTypeNm _lhsImainName >#< "=" >#< ppRecordTp (toList _nontsIsemFunBndTps) {-# LINE 3292 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule410 #-} {-# LINE 668 "./src-ag/ExecutionPlan2Caml.ag" #-} rule410 = \ ((_lhsImainName) :: String) ((_nontsIsemFunBndDefs) :: Seq PP_Doc) -> {-# LINE 668 "./src-ag/ExecutionPlan2Caml.ag" #-} "and" >#< lateBindingFieldNm _lhsImainName >#< ":" >#< lateBindingTypeNm _lhsImainName >#< "=" >-< (indent 2 $ ppRecordVal $ toList _nontsIsemFunBndDefs) {-# LINE 3299 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule411 #-} {-# LINE 1154 "./src-ag/ExecutionPlan2Caml.ag" #-} rule411 = \ ((_nontsIchildvisit) :: Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) -> {-# LINE 1154 "./src-ag/ExecutionPlan2Caml.ag" #-} _nontsIchildvisit {-# LINE 3305 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule412 #-} {-# LINE 1312 "./src-ag/ExecutionPlan2Caml.ag" #-} rule412 = \ ((_nontsIvisitdefs) :: Map VisitIdentifier (Set Identifier)) -> {-# LINE 1312 "./src-ag/ExecutionPlan2Caml.ag" #-} _nontsIvisitdefs {-# LINE 3311 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule413 #-} {-# LINE 1313 "./src-ag/ExecutionPlan2Caml.ag" #-} rule413 = \ ((_nontsIvisituses) :: Map VisitIdentifier (Set Identifier)) -> {-# LINE 1313 "./src-ag/ExecutionPlan2Caml.ag" #-} _nontsIvisituses {-# LINE 3317 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule414 #-} {-# LINE 1404 "./src-ag/ExecutionPlan2Caml.ag" #-} rule414 = \ ((_nontsIfromToStates) :: Map VisitIdentifier (Int,Int)) -> {-# LINE 1404 "./src-ag/ExecutionPlan2Caml.ag" #-} _nontsIfromToStates {-# LINE 3323 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule415 #-} {-# LINE 1448 "./src-ag/ExecutionPlan2Caml.ag" #-} rule415 = \ ((_nontsIvisitKinds) :: Map VisitIdentifier VisitKind) -> {-# LINE 1448 "./src-ag/ExecutionPlan2Caml.ag" #-} _nontsIvisitKinds {-# LINE 3329 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule416 #-} {-# LINE 1462 "./src-ag/ExecutionPlan2Caml.ag" #-} rule416 = \ ((_nontsIinitStates) :: Map NontermIdent Int) -> {-# LINE 1462 "./src-ag/ExecutionPlan2Caml.ag" #-} _nontsIinitStates {-# LINE 3335 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule417 #-} rule417 = \ ((_nontsIerrors) :: Seq Error) -> _nontsIerrors {-# INLINE rule418 #-} rule418 = \ ((_nontsImodules) :: PP_Doc) -> _nontsImodules {-# INLINE rule419 #-} rule419 = \ ((_lhsIinhmap) :: Map NontermIdent Attributes) -> _lhsIinhmap {-# INLINE rule420 #-} rule420 = \ ((_lhsIlocalAttrTypes) :: Map NontermIdent (Map ConstructorIdent (Map Identifier Type))) -> _lhsIlocalAttrTypes {-# INLINE rule421 #-} rule421 = \ ((_lhsImainFile) :: String) -> _lhsImainFile {-# INLINE rule422 #-} rule422 = \ ((_lhsImainName) :: String) -> _lhsImainName {-# INLINE rule423 #-} rule423 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule424 #-} rule424 = \ ((_lhsIsynmap) :: Map NontermIdent Attributes) -> _lhsIsynmap -- Expression -------------------------------------------------- -- wrapper data Inh_Expression = Inh_Expression { } data Syn_Expression = Syn_Expression { attrs_Syn_Expression :: (Map String (Maybe NonLocalAttr)), pos_Syn_Expression :: (Pos), semfunc_Syn_Expression :: (PP_Doc), tks_Syn_Expression :: ([HsToken]) } {-# INLINABLE wrap_Expression #-} wrap_Expression :: T_Expression -> Inh_Expression -> (Syn_Expression ) wrap_Expression (T_Expression act) (Inh_Expression ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Expression_vIn28 (T_Expression_vOut28 _lhsOattrs _lhsOpos _lhsOsemfunc _lhsOtks) <- return (inv_Expression_s29 sem arg) return (Syn_Expression _lhsOattrs _lhsOpos _lhsOsemfunc _lhsOtks) ) -- cata {-# INLINE sem_Expression #-} sem_Expression :: Expression -> T_Expression sem_Expression ( Expression pos_ tks_ ) = sem_Expression_Expression pos_ tks_ -- semantic domain newtype T_Expression = T_Expression { attach_T_Expression :: Identity (T_Expression_s29 ) } newtype T_Expression_s29 = C_Expression_s29 { inv_Expression_s29 :: (T_Expression_v28 ) } data T_Expression_s30 = C_Expression_s30 type T_Expression_v28 = (T_Expression_vIn28 ) -> (T_Expression_vOut28 ) data T_Expression_vIn28 = T_Expression_vIn28 data T_Expression_vOut28 = T_Expression_vOut28 (Map String (Maybe NonLocalAttr)) (Pos) (PP_Doc) ([HsToken]) {-# NOINLINE sem_Expression_Expression #-} sem_Expression_Expression :: (Pos) -> ([HsToken]) -> T_Expression sem_Expression_Expression arg_pos_ arg_tks_ = T_Expression (return st29) where {-# NOINLINE st29 #-} st29 = let v28 :: T_Expression_v28 v28 = \ (T_Expression_vIn28 ) -> ( let _lhsOtks :: [HsToken] _lhsOtks = rule425 arg_tks_ _lhsOpos :: Pos _lhsOpos = rule426 arg_pos_ _lhsOattrs :: Map String (Maybe NonLocalAttr) _lhsOattrs = rule427 arg_tks_ _lhsOsemfunc :: PP_Doc _lhsOsemfunc = rule428 arg_tks_ __result_ = T_Expression_vOut28 _lhsOattrs _lhsOpos _lhsOsemfunc _lhsOtks in __result_ ) in C_Expression_s29 v28 {-# INLINE rule425 #-} {-# LINE 1026 "./src-ag/ExecutionPlan2Caml.ag" #-} rule425 = \ tks_ -> {-# LINE 1026 "./src-ag/ExecutionPlan2Caml.ag" #-} tks_ {-# LINE 3414 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule426 #-} {-# LINE 1047 "./src-ag/ExecutionPlan2Caml.ag" #-} rule426 = \ pos_ -> {-# LINE 1047 "./src-ag/ExecutionPlan2Caml.ag" #-} pos_ {-# LINE 3420 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule427 #-} {-# LINE 1139 "./src-ag/ExecutionPlan2Caml.ag" #-} rule427 = \ tks_ -> {-# LINE 1139 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.unions $ map (\tok -> attrs_Syn_HsToken (wrap_HsToken (sem_HsToken tok) Inh_HsToken)) tks_ {-# LINE 3426 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule428 #-} {-# LINE 1140 "./src-ag/ExecutionPlan2Caml.ag" #-} rule428 = \ tks_ -> {-# LINE 1140 "./src-ag/ExecutionPlan2Caml.ag" #-} vlist $ showTokens $ map (\tok -> tok_Syn_HsToken (wrap_HsToken (sem_HsToken tok) Inh_HsToken)) tks_ {-# LINE 3432 "dist/build/ExecutionPlan2Caml.hs"#-} -- HsToken ----------------------------------------------------- -- wrapper data Inh_HsToken = Inh_HsToken { } data Syn_HsToken = Syn_HsToken { attrs_Syn_HsToken :: (Map String (Maybe NonLocalAttr)), tok_Syn_HsToken :: ((Pos,String)) } {-# INLINABLE wrap_HsToken #-} wrap_HsToken :: T_HsToken -> Inh_HsToken -> (Syn_HsToken ) wrap_HsToken (T_HsToken act) (Inh_HsToken ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_HsToken_vIn31 (T_HsToken_vOut31 _lhsOattrs _lhsOtok) <- return (inv_HsToken_s32 sem arg) return (Syn_HsToken _lhsOattrs _lhsOtok) ) -- cata {-# NOINLINE sem_HsToken #-} sem_HsToken :: HsToken -> T_HsToken sem_HsToken ( AGLocal var_ pos_ rdesc_ ) = sem_HsToken_AGLocal var_ pos_ rdesc_ sem_HsToken ( AGField field_ attr_ pos_ rdesc_ ) = sem_HsToken_AGField field_ attr_ pos_ rdesc_ sem_HsToken ( HsToken value_ pos_ ) = sem_HsToken_HsToken value_ pos_ sem_HsToken ( CharToken value_ pos_ ) = sem_HsToken_CharToken value_ pos_ sem_HsToken ( StrToken value_ pos_ ) = sem_HsToken_StrToken value_ pos_ sem_HsToken ( Err mesg_ pos_ ) = sem_HsToken_Err mesg_ pos_ -- semantic domain newtype T_HsToken = T_HsToken { attach_T_HsToken :: Identity (T_HsToken_s32 ) } newtype T_HsToken_s32 = C_HsToken_s32 { inv_HsToken_s32 :: (T_HsToken_v31 ) } data T_HsToken_s33 = C_HsToken_s33 type T_HsToken_v31 = (T_HsToken_vIn31 ) -> (T_HsToken_vOut31 ) data T_HsToken_vIn31 = T_HsToken_vIn31 data T_HsToken_vOut31 = T_HsToken_vOut31 (Map String (Maybe NonLocalAttr)) ((Pos,String)) {-# NOINLINE sem_HsToken_AGLocal #-} sem_HsToken_AGLocal :: (Identifier) -> (Pos) -> (Maybe String) -> T_HsToken sem_HsToken_AGLocal arg_var_ arg_pos_ _ = T_HsToken (return st32) where {-# NOINLINE st32 #-} st32 = let v31 :: T_HsToken_v31 v31 = \ (T_HsToken_vIn31 ) -> ( let _lhsOattrs :: Map String (Maybe NonLocalAttr) _lhsOattrs = rule429 arg_var_ _tok = rule430 arg_pos_ arg_var_ _lhsOtok :: (Pos,String) _lhsOtok = rule431 _tok __result_ = T_HsToken_vOut31 _lhsOattrs _lhsOtok in __result_ ) in C_HsToken_s32 v31 {-# INLINE rule429 #-} {-# LINE 1098 "./src-ag/ExecutionPlan2Caml.ag" #-} rule429 = \ var_ -> {-# LINE 1098 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.singleton (fieldname var_) Nothing {-# LINE 3489 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule430 #-} {-# LINE 1360 "./src-ag/ExecutionPlan2Caml.ag" #-} rule430 = \ pos_ var_ -> {-# LINE 1360 "./src-ag/ExecutionPlan2Caml.ag" #-} (pos_,fieldname var_) {-# LINE 3495 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule431 #-} rule431 = \ _tok -> _tok {-# NOINLINE sem_HsToken_AGField #-} sem_HsToken_AGField :: (Identifier) -> (Identifier) -> (Pos) -> (Maybe String) -> T_HsToken sem_HsToken_AGField arg_field_ arg_attr_ arg_pos_ arg_rdesc_ = T_HsToken (return st32) where {-# NOINLINE st32 #-} st32 = let v31 :: T_HsToken_v31 v31 = \ (T_HsToken_vIn31 ) -> ( let _mbAttr = rule432 arg_attr_ arg_field_ _lhsOattrs :: Map String (Maybe NonLocalAttr) _lhsOattrs = rule433 _mbAttr arg_attr_ arg_field_ _addTrace = rule434 arg_attr_ arg_field_ arg_rdesc_ _lhsOtok :: (Pos,String) _lhsOtok = rule435 _addTrace arg_attr_ arg_field_ arg_pos_ __result_ = T_HsToken_vOut31 _lhsOattrs _lhsOtok in __result_ ) in C_HsToken_s32 v31 {-# INLINE rule432 #-} {-# LINE 1099 "./src-ag/ExecutionPlan2Caml.ag" #-} rule432 = \ attr_ field_ -> {-# LINE 1099 "./src-ag/ExecutionPlan2Caml.ag" #-} if field_ == _INST || field_ == _FIELD || field_ == _INST' then Nothing else Just $ mkNonLocalAttr (field_ == _LHS) field_ attr_ {-# LINE 3522 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule433 #-} {-# LINE 1102 "./src-ag/ExecutionPlan2Caml.ag" #-} rule433 = \ _mbAttr attr_ field_ -> {-# LINE 1102 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.singleton (attrname True field_ attr_) _mbAttr {-# LINE 3528 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule434 #-} {-# LINE 1364 "./src-ag/ExecutionPlan2Caml.ag" #-} rule434 = \ attr_ field_ rdesc_ -> {-# LINE 1364 "./src-ag/ExecutionPlan2Caml.ag" #-} case rdesc_ of Just d -> \x -> "(prerr_endline " ++ show (d ++ " -> " ++ show field_ ++ "." ++ show attr_) ++ "; " ++ x ++ ")" Nothing -> id {-# LINE 3536 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule435 #-} {-# LINE 1367 "./src-ag/ExecutionPlan2Caml.ag" #-} rule435 = \ _addTrace attr_ field_ pos_ -> {-# LINE 1367 "./src-ag/ExecutionPlan2Caml.ag" #-} (pos_, _addTrace $ attrname True field_ attr_) {-# LINE 3542 "dist/build/ExecutionPlan2Caml.hs"#-} {-# NOINLINE sem_HsToken_HsToken #-} sem_HsToken_HsToken :: (String) -> (Pos) -> T_HsToken sem_HsToken_HsToken arg_value_ arg_pos_ = T_HsToken (return st32) where {-# NOINLINE st32 #-} st32 = let v31 :: T_HsToken_v31 v31 = \ (T_HsToken_vIn31 ) -> ( let _lhsOtok :: (Pos,String) _lhsOtok = rule436 arg_pos_ arg_value_ _lhsOattrs :: Map String (Maybe NonLocalAttr) _lhsOattrs = rule437 () __result_ = T_HsToken_vOut31 _lhsOattrs _lhsOtok in __result_ ) in C_HsToken_s32 v31 {-# INLINE rule436 #-} {-# LINE 1369 "./src-ag/ExecutionPlan2Caml.ag" #-} rule436 = \ pos_ value_ -> {-# LINE 1369 "./src-ag/ExecutionPlan2Caml.ag" #-} (pos_, value_) {-# LINE 3562 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule437 #-} rule437 = \ (_ :: ()) -> Map.empty {-# NOINLINE sem_HsToken_CharToken #-} sem_HsToken_CharToken :: (String) -> (Pos) -> T_HsToken sem_HsToken_CharToken arg_value_ arg_pos_ = T_HsToken (return st32) where {-# NOINLINE st32 #-} st32 = let v31 :: T_HsToken_v31 v31 = \ (T_HsToken_vIn31 ) -> ( let _lhsOtok :: (Pos,String) _lhsOtok = rule438 arg_pos_ arg_value_ _lhsOattrs :: Map String (Maybe NonLocalAttr) _lhsOattrs = rule439 () __result_ = T_HsToken_vOut31 _lhsOattrs _lhsOtok in __result_ ) in C_HsToken_s32 v31 {-# INLINE rule438 #-} {-# LINE 1371 "./src-ag/ExecutionPlan2Caml.ag" #-} rule438 = \ pos_ value_ -> {-# LINE 1371 "./src-ag/ExecutionPlan2Caml.ag" #-} (pos_, if null value_ then "" else showCharShort (head value_) ) {-# LINE 3588 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule439 #-} rule439 = \ (_ :: ()) -> Map.empty {-# NOINLINE sem_HsToken_StrToken #-} sem_HsToken_StrToken :: (String) -> (Pos) -> T_HsToken sem_HsToken_StrToken arg_value_ arg_pos_ = T_HsToken (return st32) where {-# NOINLINE st32 #-} st32 = let v31 :: T_HsToken_v31 v31 = \ (T_HsToken_vIn31 ) -> ( let _lhsOtok :: (Pos,String) _lhsOtok = rule440 arg_pos_ arg_value_ _lhsOattrs :: Map String (Maybe NonLocalAttr) _lhsOattrs = rule441 () __result_ = T_HsToken_vOut31 _lhsOattrs _lhsOtok in __result_ ) in C_HsToken_s32 v31 {-# INLINE rule440 #-} {-# LINE 1376 "./src-ag/ExecutionPlan2Caml.ag" #-} rule440 = \ pos_ value_ -> {-# LINE 1376 "./src-ag/ExecutionPlan2Caml.ag" #-} (pos_, showStrShort value_) {-# LINE 3611 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule441 #-} rule441 = \ (_ :: ()) -> Map.empty {-# NOINLINE sem_HsToken_Err #-} sem_HsToken_Err :: (String) -> (Pos) -> T_HsToken sem_HsToken_Err _ arg_pos_ = T_HsToken (return st32) where {-# NOINLINE st32 #-} st32 = let v31 :: T_HsToken_v31 v31 = \ (T_HsToken_vIn31 ) -> ( let _lhsOtok :: (Pos,String) _lhsOtok = rule442 arg_pos_ _lhsOattrs :: Map String (Maybe NonLocalAttr) _lhsOattrs = rule443 () __result_ = T_HsToken_vOut31 _lhsOattrs _lhsOtok in __result_ ) in C_HsToken_s32 v31 {-# INLINE rule442 #-} {-# LINE 1377 "./src-ag/ExecutionPlan2Caml.ag" #-} rule442 = \ pos_ -> {-# LINE 1377 "./src-ag/ExecutionPlan2Caml.ag" #-} (pos_, "") {-# LINE 3634 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule443 #-} rule443 = \ (_ :: ()) -> Map.empty -- HsTokens ---------------------------------------------------- -- wrapper data Inh_HsTokens = Inh_HsTokens { } data Syn_HsTokens = Syn_HsTokens { tks_Syn_HsTokens :: ([(Pos,String)]) } {-# INLINABLE wrap_HsTokens #-} wrap_HsTokens :: T_HsTokens -> Inh_HsTokens -> (Syn_HsTokens ) wrap_HsTokens (T_HsTokens act) (Inh_HsTokens ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_HsTokens_vIn34 (T_HsTokens_vOut34 _lhsOtks) <- return (inv_HsTokens_s35 sem arg) return (Syn_HsTokens _lhsOtks) ) -- cata {-# NOINLINE sem_HsTokens #-} sem_HsTokens :: HsTokens -> T_HsTokens sem_HsTokens list = Prelude.foldr sem_HsTokens_Cons sem_HsTokens_Nil (Prelude.map sem_HsToken list) -- semantic domain newtype T_HsTokens = T_HsTokens { attach_T_HsTokens :: Identity (T_HsTokens_s35 ) } newtype T_HsTokens_s35 = C_HsTokens_s35 { inv_HsTokens_s35 :: (T_HsTokens_v34 ) } data T_HsTokens_s36 = C_HsTokens_s36 type T_HsTokens_v34 = (T_HsTokens_vIn34 ) -> (T_HsTokens_vOut34 ) data T_HsTokens_vIn34 = T_HsTokens_vIn34 data T_HsTokens_vOut34 = T_HsTokens_vOut34 ([(Pos,String)]) {-# NOINLINE sem_HsTokens_Cons #-} sem_HsTokens_Cons :: T_HsToken -> T_HsTokens -> T_HsTokens sem_HsTokens_Cons arg_hd_ arg_tl_ = T_HsTokens (return st35) where {-# NOINLINE st35 #-} st35 = let v34 :: T_HsTokens_v34 v34 = \ (T_HsTokens_vIn34 ) -> ( let _hdX32 = Control.Monad.Identity.runIdentity (attach_T_HsToken (arg_hd_)) _tlX35 = Control.Monad.Identity.runIdentity (attach_T_HsTokens (arg_tl_)) (T_HsToken_vOut31 _hdIattrs _hdItok) = inv_HsToken_s32 _hdX32 (T_HsToken_vIn31 ) (T_HsTokens_vOut34 _tlItks) = inv_HsTokens_s35 _tlX35 (T_HsTokens_vIn34 ) _lhsOtks :: [(Pos,String)] _lhsOtks = rule444 _hdItok _tlItks __result_ = T_HsTokens_vOut34 _lhsOtks in __result_ ) in C_HsTokens_s35 v34 {-# INLINE rule444 #-} {-# LINE 1356 "./src-ag/ExecutionPlan2Caml.ag" #-} rule444 = \ ((_hdItok) :: (Pos,String)) ((_tlItks) :: [(Pos,String)]) -> {-# LINE 1356 "./src-ag/ExecutionPlan2Caml.ag" #-} _hdItok : _tlItks {-# LINE 3690 "dist/build/ExecutionPlan2Caml.hs"#-} {-# NOINLINE sem_HsTokens_Nil #-} sem_HsTokens_Nil :: T_HsTokens sem_HsTokens_Nil = T_HsTokens (return st35) where {-# NOINLINE st35 #-} st35 = let v34 :: T_HsTokens_v34 v34 = \ (T_HsTokens_vIn34 ) -> ( let _lhsOtks :: [(Pos,String)] _lhsOtks = rule445 () __result_ = T_HsTokens_vOut34 _lhsOtks in __result_ ) in C_HsTokens_s35 v34 {-# INLINE rule445 #-} {-# LINE 1357 "./src-ag/ExecutionPlan2Caml.ag" #-} rule445 = \ (_ :: ()) -> {-# LINE 1357 "./src-ag/ExecutionPlan2Caml.ag" #-} [] {-# LINE 3708 "dist/build/ExecutionPlan2Caml.hs"#-} -- HsTokensRoot ------------------------------------------------ -- wrapper data Inh_HsTokensRoot = Inh_HsTokensRoot { } data Syn_HsTokensRoot = Syn_HsTokensRoot { } {-# INLINABLE wrap_HsTokensRoot #-} wrap_HsTokensRoot :: T_HsTokensRoot -> Inh_HsTokensRoot -> (Syn_HsTokensRoot ) wrap_HsTokensRoot (T_HsTokensRoot act) (Inh_HsTokensRoot ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_HsTokensRoot_vIn37 (T_HsTokensRoot_vOut37 ) <- return (inv_HsTokensRoot_s38 sem arg) return (Syn_HsTokensRoot ) ) -- cata {-# INLINE sem_HsTokensRoot #-} sem_HsTokensRoot :: HsTokensRoot -> T_HsTokensRoot sem_HsTokensRoot ( HsTokensRoot tokens_ ) = sem_HsTokensRoot_HsTokensRoot ( sem_HsTokens tokens_ ) -- semantic domain newtype T_HsTokensRoot = T_HsTokensRoot { attach_T_HsTokensRoot :: Identity (T_HsTokensRoot_s38 ) } newtype T_HsTokensRoot_s38 = C_HsTokensRoot_s38 { inv_HsTokensRoot_s38 :: (T_HsTokensRoot_v37 ) } data T_HsTokensRoot_s39 = C_HsTokensRoot_s39 type T_HsTokensRoot_v37 = (T_HsTokensRoot_vIn37 ) -> (T_HsTokensRoot_vOut37 ) data T_HsTokensRoot_vIn37 = T_HsTokensRoot_vIn37 data T_HsTokensRoot_vOut37 = T_HsTokensRoot_vOut37 {-# NOINLINE sem_HsTokensRoot_HsTokensRoot #-} sem_HsTokensRoot_HsTokensRoot :: T_HsTokens -> T_HsTokensRoot sem_HsTokensRoot_HsTokensRoot arg_tokens_ = T_HsTokensRoot (return st38) where {-# NOINLINE st38 #-} st38 = let v37 :: T_HsTokensRoot_v37 v37 = \ (T_HsTokensRoot_vIn37 ) -> ( let _tokensX35 = Control.Monad.Identity.runIdentity (attach_T_HsTokens (arg_tokens_)) (T_HsTokens_vOut34 _tokensItks) = inv_HsTokens_s35 _tokensX35 (T_HsTokens_vIn34 ) __result_ = T_HsTokensRoot_vOut37 in __result_ ) in C_HsTokensRoot_s38 v37 -- Pattern ----------------------------------------------------- -- wrapper data Inh_Pattern = Inh_Pattern { allInhmap_Inh_Pattern :: (Map NontermIdent Attributes), allSynmap_Inh_Pattern :: (Map NontermIdent Attributes), anyLazyKind_Inh_Pattern :: (Bool), inhmap_Inh_Pattern :: (Attributes), localAttrTypes_Inh_Pattern :: (Map Identifier Type), options_Inh_Pattern :: (Options), synmap_Inh_Pattern :: (Attributes) } data Syn_Pattern = Syn_Pattern { attrTypes_Syn_Pattern :: (PP_Doc), attrs_Syn_Pattern :: (Set String), copy_Syn_Pattern :: (Pattern), extraDefs_Syn_Pattern :: ([(PP_Doc,PP_Doc)]), isUnderscore_Syn_Pattern :: (Bool), sem_lhs_Syn_Pattern :: ( PP_Doc ) } {-# INLINABLE wrap_Pattern #-} wrap_Pattern :: T_Pattern -> Inh_Pattern -> (Syn_Pattern ) wrap_Pattern (T_Pattern act) (Inh_Pattern _lhsIallInhmap _lhsIallSynmap _lhsIanyLazyKind _lhsIinhmap _lhsIlocalAttrTypes _lhsIoptions _lhsIsynmap) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Pattern_vIn40 _lhsIallInhmap _lhsIallSynmap _lhsIanyLazyKind _lhsIinhmap _lhsIlocalAttrTypes _lhsIoptions _lhsIsynmap (T_Pattern_vOut40 _lhsOattrTypes _lhsOattrs _lhsOcopy _lhsOextraDefs _lhsOisUnderscore _lhsOsem_lhs) <- return (inv_Pattern_s41 sem arg) return (Syn_Pattern _lhsOattrTypes _lhsOattrs _lhsOcopy _lhsOextraDefs _lhsOisUnderscore _lhsOsem_lhs) ) -- cata {-# NOINLINE sem_Pattern #-} sem_Pattern :: Pattern -> T_Pattern sem_Pattern ( Constr name_ pats_ ) = sem_Pattern_Constr name_ ( sem_Patterns pats_ ) sem_Pattern ( Product pos_ pats_ ) = sem_Pattern_Product pos_ ( sem_Patterns pats_ ) sem_Pattern ( Alias field_ attr_ pat_ ) = sem_Pattern_Alias field_ attr_ ( sem_Pattern pat_ ) sem_Pattern ( Irrefutable pat_ ) = sem_Pattern_Irrefutable ( sem_Pattern pat_ ) sem_Pattern ( Underscore pos_ ) = sem_Pattern_Underscore pos_ -- semantic domain newtype T_Pattern = T_Pattern { attach_T_Pattern :: Identity (T_Pattern_s41 ) } newtype T_Pattern_s41 = C_Pattern_s41 { inv_Pattern_s41 :: (T_Pattern_v40 ) } data T_Pattern_s42 = C_Pattern_s42 type T_Pattern_v40 = (T_Pattern_vIn40 ) -> (T_Pattern_vOut40 ) data T_Pattern_vIn40 = T_Pattern_vIn40 (Map NontermIdent Attributes) (Map NontermIdent Attributes) (Bool) (Attributes) (Map Identifier Type) (Options) (Attributes) data T_Pattern_vOut40 = T_Pattern_vOut40 (PP_Doc) (Set String) (Pattern) ([(PP_Doc,PP_Doc)]) (Bool) ( PP_Doc ) {-# NOINLINE sem_Pattern_Constr #-} sem_Pattern_Constr :: (ConstructorIdent) -> T_Patterns -> T_Pattern sem_Pattern_Constr arg_name_ arg_pats_ = T_Pattern (return st41) where {-# NOINLINE st41 #-} st41 = let v40 :: T_Pattern_v40 v40 = \ (T_Pattern_vIn40 _lhsIallInhmap _lhsIallSynmap _lhsIanyLazyKind _lhsIinhmap _lhsIlocalAttrTypes _lhsIoptions _lhsIsynmap) -> ( let _patsX44 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) (T_Patterns_vOut43 _patsIattrTypes _patsIattrs _patsIcopy _patsIextraDefs _patsIsem_lhs) = inv_Patterns_s44 _patsX44 (T_Patterns_vIn43 _patsOallInhmap _patsOallSynmap _patsOanyLazyKind _patsOinhmap _patsOlocalAttrTypes _patsOoptions _patsOsynmap) _lhsOsem_lhs :: PP_Doc _lhsOsem_lhs = rule446 _patsIsem_lhs arg_name_ _lhsOisUnderscore :: Bool _lhsOisUnderscore = rule447 () _lhsOattrTypes :: PP_Doc _lhsOattrTypes = rule448 _patsIattrTypes _lhsOattrs :: Set String _lhsOattrs = rule449 _patsIattrs _lhsOextraDefs :: [(PP_Doc,PP_Doc)] _lhsOextraDefs = rule450 _patsIextraDefs _copy = rule451 _patsIcopy arg_name_ _lhsOcopy :: Pattern _lhsOcopy = rule452 _copy _patsOallInhmap = rule453 _lhsIallInhmap _patsOallSynmap = rule454 _lhsIallSynmap _patsOanyLazyKind = rule455 _lhsIanyLazyKind _patsOinhmap = rule456 _lhsIinhmap _patsOlocalAttrTypes = rule457 _lhsIlocalAttrTypes _patsOoptions = rule458 _lhsIoptions _patsOsynmap = rule459 _lhsIsynmap __result_ = T_Pattern_vOut40 _lhsOattrTypes _lhsOattrs _lhsOcopy _lhsOextraDefs _lhsOisUnderscore _lhsOsem_lhs in __result_ ) in C_Pattern_s41 v40 {-# INLINE rule446 #-} {-# LINE 1064 "./src-ag/ExecutionPlan2Caml.ag" #-} rule446 = \ ((_patsIsem_lhs) :: [PP_Doc]) name_ -> {-# LINE 1064 "./src-ag/ExecutionPlan2Caml.ag" #-} pp_parens $ name_ >#< pp_block "(" ")" "," _patsIsem_lhs {-# LINE 3824 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule447 #-} {-# LINE 1073 "./src-ag/ExecutionPlan2Caml.ag" #-} rule447 = \ (_ :: ()) -> {-# LINE 1073 "./src-ag/ExecutionPlan2Caml.ag" #-} False {-# LINE 3830 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule448 #-} rule448 = \ ((_patsIattrTypes) :: PP_Doc) -> _patsIattrTypes {-# INLINE rule449 #-} rule449 = \ ((_patsIattrs) :: Set String) -> _patsIattrs {-# INLINE rule450 #-} rule450 = \ ((_patsIextraDefs) :: [(PP_Doc,PP_Doc)]) -> _patsIextraDefs {-# INLINE rule451 #-} rule451 = \ ((_patsIcopy) :: Patterns) name_ -> Constr name_ _patsIcopy {-# INLINE rule452 #-} rule452 = \ _copy -> _copy {-# INLINE rule453 #-} rule453 = \ ((_lhsIallInhmap) :: Map NontermIdent Attributes) -> _lhsIallInhmap {-# INLINE rule454 #-} rule454 = \ ((_lhsIallSynmap) :: Map NontermIdent Attributes) -> _lhsIallSynmap {-# INLINE rule455 #-} rule455 = \ ((_lhsIanyLazyKind) :: Bool) -> _lhsIanyLazyKind {-# INLINE rule456 #-} rule456 = \ ((_lhsIinhmap) :: Attributes) -> _lhsIinhmap {-# INLINE rule457 #-} rule457 = \ ((_lhsIlocalAttrTypes) :: Map Identifier Type) -> _lhsIlocalAttrTypes {-# INLINE rule458 #-} rule458 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule459 #-} rule459 = \ ((_lhsIsynmap) :: Attributes) -> _lhsIsynmap {-# NOINLINE sem_Pattern_Product #-} sem_Pattern_Product :: (Pos) -> T_Patterns -> T_Pattern sem_Pattern_Product arg_pos_ arg_pats_ = T_Pattern (return st41) where {-# NOINLINE st41 #-} st41 = let v40 :: T_Pattern_v40 v40 = \ (T_Pattern_vIn40 _lhsIallInhmap _lhsIallSynmap _lhsIanyLazyKind _lhsIinhmap _lhsIlocalAttrTypes _lhsIoptions _lhsIsynmap) -> ( let _patsX44 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) (T_Patterns_vOut43 _patsIattrTypes _patsIattrs _patsIcopy _patsIextraDefs _patsIsem_lhs) = inv_Patterns_s44 _patsX44 (T_Patterns_vIn43 _patsOallInhmap _patsOallSynmap _patsOanyLazyKind _patsOinhmap _patsOlocalAttrTypes _patsOoptions _patsOsynmap) _lhsOsem_lhs :: PP_Doc _lhsOsem_lhs = rule460 _patsIsem_lhs _lhsOisUnderscore :: Bool _lhsOisUnderscore = rule461 () _lhsOattrTypes :: PP_Doc _lhsOattrTypes = rule462 _patsIattrTypes _lhsOattrs :: Set String _lhsOattrs = rule463 _patsIattrs _lhsOextraDefs :: [(PP_Doc,PP_Doc)] _lhsOextraDefs = rule464 _patsIextraDefs _copy = rule465 _patsIcopy arg_pos_ _lhsOcopy :: Pattern _lhsOcopy = rule466 _copy _patsOallInhmap = rule467 _lhsIallInhmap _patsOallSynmap = rule468 _lhsIallSynmap _patsOanyLazyKind = rule469 _lhsIanyLazyKind _patsOinhmap = rule470 _lhsIinhmap _patsOlocalAttrTypes = rule471 _lhsIlocalAttrTypes _patsOoptions = rule472 _lhsIoptions _patsOsynmap = rule473 _lhsIsynmap __result_ = T_Pattern_vOut40 _lhsOattrTypes _lhsOattrs _lhsOcopy _lhsOextraDefs _lhsOisUnderscore _lhsOsem_lhs in __result_ ) in C_Pattern_s41 v40 {-# INLINE rule460 #-} {-# LINE 1063 "./src-ag/ExecutionPlan2Caml.ag" #-} rule460 = \ ((_patsIsem_lhs) :: [PP_Doc]) -> {-# LINE 1063 "./src-ag/ExecutionPlan2Caml.ag" #-} pp_block "(" ")" "," _patsIsem_lhs {-# LINE 3904 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule461 #-} {-# LINE 1074 "./src-ag/ExecutionPlan2Caml.ag" #-} rule461 = \ (_ :: ()) -> {-# LINE 1074 "./src-ag/ExecutionPlan2Caml.ag" #-} False {-# LINE 3910 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule462 #-} rule462 = \ ((_patsIattrTypes) :: PP_Doc) -> _patsIattrTypes {-# INLINE rule463 #-} rule463 = \ ((_patsIattrs) :: Set String) -> _patsIattrs {-# INLINE rule464 #-} rule464 = \ ((_patsIextraDefs) :: [(PP_Doc,PP_Doc)]) -> _patsIextraDefs {-# INLINE rule465 #-} rule465 = \ ((_patsIcopy) :: Patterns) pos_ -> Product pos_ _patsIcopy {-# INLINE rule466 #-} rule466 = \ _copy -> _copy {-# INLINE rule467 #-} rule467 = \ ((_lhsIallInhmap) :: Map NontermIdent Attributes) -> _lhsIallInhmap {-# INLINE rule468 #-} rule468 = \ ((_lhsIallSynmap) :: Map NontermIdent Attributes) -> _lhsIallSynmap {-# INLINE rule469 #-} rule469 = \ ((_lhsIanyLazyKind) :: Bool) -> _lhsIanyLazyKind {-# INLINE rule470 #-} rule470 = \ ((_lhsIinhmap) :: Attributes) -> _lhsIinhmap {-# INLINE rule471 #-} rule471 = \ ((_lhsIlocalAttrTypes) :: Map Identifier Type) -> _lhsIlocalAttrTypes {-# INLINE rule472 #-} rule472 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule473 #-} rule473 = \ ((_lhsIsynmap) :: Attributes) -> _lhsIsynmap {-# NOINLINE sem_Pattern_Alias #-} sem_Pattern_Alias :: (Identifier) -> (Identifier) -> T_Pattern -> T_Pattern sem_Pattern_Alias arg_field_ arg_attr_ arg_pat_ = T_Pattern (return st41) where {-# NOINLINE st41 #-} st41 = let v40 :: T_Pattern_v40 v40 = \ (T_Pattern_vIn40 _lhsIallInhmap _lhsIallSynmap _lhsIanyLazyKind _lhsIinhmap _lhsIlocalAttrTypes _lhsIoptions _lhsIsynmap) -> ( let _patX41 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) (T_Pattern_vOut40 _patIattrTypes _patIattrs _patIcopy _patIextraDefs _patIisUnderscore _patIsem_lhs) = inv_Pattern_s41 _patX41 (T_Pattern_vIn40 _patOallInhmap _patOallSynmap _patOanyLazyKind _patOinhmap _patOlocalAttrTypes _patOoptions _patOsynmap) _var = rule474 arg_attr_ arg_field_ _hasTp = rule475 _mbTp _o_sigs = rule476 _lhsIoptions _lhsOsem_lhs :: PP_Doc _lhsOsem_lhs = rule477 _hasTp _mbTp _o_sigs _var _lhsOextraDefs :: [(PP_Doc,PP_Doc)] _lhsOextraDefs = rule478 _patIisUnderscore _patIsem_lhs _var _lhsOisUnderscore :: Bool _lhsOisUnderscore = rule479 () _lhsOattrs :: Set String _lhsOattrs = rule480 _patIattrs arg_attr_ arg_field_ _mbTp = rule481 _lhsIlocalAttrTypes _lhsIsynmap arg_attr_ arg_field_ _lhsOattrTypes :: PP_Doc _lhsOattrTypes = rule482 _mbTp _patIattrTypes arg_attr_ arg_field_ _copy = rule483 _patIcopy arg_attr_ arg_field_ _lhsOcopy :: Pattern _lhsOcopy = rule484 _copy _patOallInhmap = rule485 _lhsIallInhmap _patOallSynmap = rule486 _lhsIallSynmap _patOanyLazyKind = rule487 _lhsIanyLazyKind _patOinhmap = rule488 _lhsIinhmap _patOlocalAttrTypes = rule489 _lhsIlocalAttrTypes _patOoptions = rule490 _lhsIoptions _patOsynmap = rule491 _lhsIsynmap __result_ = T_Pattern_vOut40 _lhsOattrTypes _lhsOattrs _lhsOcopy _lhsOextraDefs _lhsOisUnderscore _lhsOsem_lhs in __result_ ) in C_Pattern_s41 v40 {-# INLINE rule474 #-} {-# LINE 1055 "./src-ag/ExecutionPlan2Caml.ag" #-} rule474 = \ attr_ field_ -> {-# LINE 1055 "./src-ag/ExecutionPlan2Caml.ag" #-} text $ attrname False field_ attr_ {-# LINE 3988 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule475 #-} {-# LINE 1056 "./src-ag/ExecutionPlan2Caml.ag" #-} rule475 = \ _mbTp -> {-# LINE 1056 "./src-ag/ExecutionPlan2Caml.ag" #-} isJust _mbTp {-# LINE 3994 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule476 #-} {-# LINE 1057 "./src-ag/ExecutionPlan2Caml.ag" #-} rule476 = \ ((_lhsIoptions) :: Options) -> {-# LINE 1057 "./src-ag/ExecutionPlan2Caml.ag" #-} typeSigs _lhsIoptions {-# LINE 4000 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule477 #-} {-# LINE 1059 "./src-ag/ExecutionPlan2Caml.ag" #-} rule477 = \ _hasTp _mbTp _o_sigs _var -> {-# LINE 1059 "./src-ag/ExecutionPlan2Caml.ag" #-} ppArg (_hasTp && _o_sigs ) _var (maybe (text "?no type?") ppTp _mbTp ) {-# LINE 4006 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule478 #-} {-# LINE 1060 "./src-ag/ExecutionPlan2Caml.ag" #-} rule478 = \ ((_patIisUnderscore) :: Bool) ((_patIsem_lhs) :: PP_Doc ) _var -> {-# LINE 1060 "./src-ag/ExecutionPlan2Caml.ag" #-} if _patIisUnderscore then [] else [ (_patIsem_lhs, _var ) ] {-# LINE 4014 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule479 #-} {-# LINE 1075 "./src-ag/ExecutionPlan2Caml.ag" #-} rule479 = \ (_ :: ()) -> {-# LINE 1075 "./src-ag/ExecutionPlan2Caml.ag" #-} False {-# LINE 4020 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule480 #-} {-# LINE 1081 "./src-ag/ExecutionPlan2Caml.ag" #-} rule480 = \ ((_patIattrs) :: Set String) attr_ field_ -> {-# LINE 1081 "./src-ag/ExecutionPlan2Caml.ag" #-} Set.insert (attrname False field_ attr_) _patIattrs {-# LINE 4026 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule481 #-} {-# LINE 1087 "./src-ag/ExecutionPlan2Caml.ag" #-} rule481 = \ ((_lhsIlocalAttrTypes) :: Map Identifier Type) ((_lhsIsynmap) :: Attributes) attr_ field_ -> {-# LINE 1087 "./src-ag/ExecutionPlan2Caml.ag" #-} if field_ == _LHS then Map.lookup attr_ _lhsIsynmap else if field_ == _LOC then Map.lookup attr_ _lhsIlocalAttrTypes else Nothing {-# LINE 4036 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule482 #-} {-# LINE 1092 "./src-ag/ExecutionPlan2Caml.ag" #-} rule482 = \ _mbTp ((_patIattrTypes) :: PP_Doc) attr_ field_ -> {-# LINE 1092 "./src-ag/ExecutionPlan2Caml.ag" #-} maybe empty (\tp -> (attrname False field_ attr_) >#< "::" >#< ppTp tp) _mbTp >-< _patIattrTypes {-# LINE 4043 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule483 #-} rule483 = \ ((_patIcopy) :: Pattern) attr_ field_ -> Alias field_ attr_ _patIcopy {-# INLINE rule484 #-} rule484 = \ _copy -> _copy {-# INLINE rule485 #-} rule485 = \ ((_lhsIallInhmap) :: Map NontermIdent Attributes) -> _lhsIallInhmap {-# INLINE rule486 #-} rule486 = \ ((_lhsIallSynmap) :: Map NontermIdent Attributes) -> _lhsIallSynmap {-# INLINE rule487 #-} rule487 = \ ((_lhsIanyLazyKind) :: Bool) -> _lhsIanyLazyKind {-# INLINE rule488 #-} rule488 = \ ((_lhsIinhmap) :: Attributes) -> _lhsIinhmap {-# INLINE rule489 #-} rule489 = \ ((_lhsIlocalAttrTypes) :: Map Identifier Type) -> _lhsIlocalAttrTypes {-# INLINE rule490 #-} rule490 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule491 #-} rule491 = \ ((_lhsIsynmap) :: Attributes) -> _lhsIsynmap {-# NOINLINE sem_Pattern_Irrefutable #-} sem_Pattern_Irrefutable :: T_Pattern -> T_Pattern sem_Pattern_Irrefutable arg_pat_ = T_Pattern (return st41) where {-# NOINLINE st41 #-} st41 = let v40 :: T_Pattern_v40 v40 = \ (T_Pattern_vIn40 _lhsIallInhmap _lhsIallSynmap _lhsIanyLazyKind _lhsIinhmap _lhsIlocalAttrTypes _lhsIoptions _lhsIsynmap) -> ( let _patX41 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) (T_Pattern_vOut40 _patIattrTypes _patIattrs _patIcopy _patIextraDefs _patIisUnderscore _patIsem_lhs) = inv_Pattern_s41 _patX41 (T_Pattern_vIn40 _patOallInhmap _patOallSynmap _patOanyLazyKind _patOinhmap _patOlocalAttrTypes _patOoptions _patOsynmap) _lhsOsem_lhs :: PP_Doc _lhsOsem_lhs = rule492 _patIsem_lhs _lhsOattrTypes :: PP_Doc _lhsOattrTypes = rule493 _patIattrTypes _lhsOattrs :: Set String _lhsOattrs = rule494 _patIattrs _lhsOextraDefs :: [(PP_Doc,PP_Doc)] _lhsOextraDefs = rule495 _patIextraDefs _copy = rule496 _patIcopy _lhsOcopy :: Pattern _lhsOcopy = rule497 _copy _lhsOisUnderscore :: Bool _lhsOisUnderscore = rule498 _patIisUnderscore _patOallInhmap = rule499 _lhsIallInhmap _patOallSynmap = rule500 _lhsIallSynmap _patOanyLazyKind = rule501 _lhsIanyLazyKind _patOinhmap = rule502 _lhsIinhmap _patOlocalAttrTypes = rule503 _lhsIlocalAttrTypes _patOoptions = rule504 _lhsIoptions _patOsynmap = rule505 _lhsIsynmap __result_ = T_Pattern_vOut40 _lhsOattrTypes _lhsOattrs _lhsOcopy _lhsOextraDefs _lhsOisUnderscore _lhsOsem_lhs in __result_ ) in C_Pattern_s41 v40 {-# INLINE rule492 #-} {-# LINE 1066 "./src-ag/ExecutionPlan2Caml.ag" #-} rule492 = \ ((_patIsem_lhs) :: PP_Doc ) -> {-# LINE 1066 "./src-ag/ExecutionPlan2Caml.ag" #-} pp_parens (text "lazy" >#< _patIsem_lhs) {-# LINE 4108 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule493 #-} rule493 = \ ((_patIattrTypes) :: PP_Doc) -> _patIattrTypes {-# INLINE rule494 #-} rule494 = \ ((_patIattrs) :: Set String) -> _patIattrs {-# INLINE rule495 #-} rule495 = \ ((_patIextraDefs) :: [(PP_Doc,PP_Doc)]) -> _patIextraDefs {-# INLINE rule496 #-} rule496 = \ ((_patIcopy) :: Pattern) -> Irrefutable _patIcopy {-# INLINE rule497 #-} rule497 = \ _copy -> _copy {-# INLINE rule498 #-} rule498 = \ ((_patIisUnderscore) :: Bool) -> _patIisUnderscore {-# INLINE rule499 #-} rule499 = \ ((_lhsIallInhmap) :: Map NontermIdent Attributes) -> _lhsIallInhmap {-# INLINE rule500 #-} rule500 = \ ((_lhsIallSynmap) :: Map NontermIdent Attributes) -> _lhsIallSynmap {-# INLINE rule501 #-} rule501 = \ ((_lhsIanyLazyKind) :: Bool) -> _lhsIanyLazyKind {-# INLINE rule502 #-} rule502 = \ ((_lhsIinhmap) :: Attributes) -> _lhsIinhmap {-# INLINE rule503 #-} rule503 = \ ((_lhsIlocalAttrTypes) :: Map Identifier Type) -> _lhsIlocalAttrTypes {-# INLINE rule504 #-} rule504 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule505 #-} rule505 = \ ((_lhsIsynmap) :: Attributes) -> _lhsIsynmap {-# NOINLINE sem_Pattern_Underscore #-} sem_Pattern_Underscore :: (Pos) -> T_Pattern sem_Pattern_Underscore arg_pos_ = T_Pattern (return st41) where {-# NOINLINE st41 #-} st41 = let v40 :: T_Pattern_v40 v40 = \ (T_Pattern_vIn40 _lhsIallInhmap _lhsIallSynmap _lhsIanyLazyKind _lhsIinhmap _lhsIlocalAttrTypes _lhsIoptions _lhsIsynmap) -> ( let _lhsOsem_lhs :: PP_Doc _lhsOsem_lhs = rule506 () _lhsOisUnderscore :: Bool _lhsOisUnderscore = rule507 () _lhsOattrTypes :: PP_Doc _lhsOattrTypes = rule508 () _lhsOattrs :: Set String _lhsOattrs = rule509 () _lhsOextraDefs :: [(PP_Doc,PP_Doc)] _lhsOextraDefs = rule510 () _copy = rule511 arg_pos_ _lhsOcopy :: Pattern _lhsOcopy = rule512 _copy __result_ = T_Pattern_vOut40 _lhsOattrTypes _lhsOattrs _lhsOcopy _lhsOextraDefs _lhsOisUnderscore _lhsOsem_lhs in __result_ ) in C_Pattern_s41 v40 {-# INLINE rule506 #-} {-# LINE 1065 "./src-ag/ExecutionPlan2Caml.ag" #-} rule506 = \ (_ :: ()) -> {-# LINE 1065 "./src-ag/ExecutionPlan2Caml.ag" #-} text "_" {-# LINE 4176 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule507 #-} {-# LINE 1076 "./src-ag/ExecutionPlan2Caml.ag" #-} rule507 = \ (_ :: ()) -> {-# LINE 1076 "./src-ag/ExecutionPlan2Caml.ag" #-} True {-# LINE 4182 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule508 #-} rule508 = \ (_ :: ()) -> empty {-# INLINE rule509 #-} rule509 = \ (_ :: ()) -> Set.empty {-# INLINE rule510 #-} rule510 = \ (_ :: ()) -> [] {-# INLINE rule511 #-} rule511 = \ pos_ -> Underscore pos_ {-# INLINE rule512 #-} rule512 = \ _copy -> _copy -- Patterns ---------------------------------------------------- -- wrapper data Inh_Patterns = Inh_Patterns { allInhmap_Inh_Patterns :: (Map NontermIdent Attributes), allSynmap_Inh_Patterns :: (Map NontermIdent Attributes), anyLazyKind_Inh_Patterns :: (Bool), inhmap_Inh_Patterns :: (Attributes), localAttrTypes_Inh_Patterns :: (Map Identifier Type), options_Inh_Patterns :: (Options), synmap_Inh_Patterns :: (Attributes) } data Syn_Patterns = Syn_Patterns { attrTypes_Syn_Patterns :: (PP_Doc), attrs_Syn_Patterns :: (Set String), copy_Syn_Patterns :: (Patterns), extraDefs_Syn_Patterns :: ([(PP_Doc,PP_Doc)]), sem_lhs_Syn_Patterns :: ([PP_Doc]) } {-# INLINABLE wrap_Patterns #-} wrap_Patterns :: T_Patterns -> Inh_Patterns -> (Syn_Patterns ) wrap_Patterns (T_Patterns act) (Inh_Patterns _lhsIallInhmap _lhsIallSynmap _lhsIanyLazyKind _lhsIinhmap _lhsIlocalAttrTypes _lhsIoptions _lhsIsynmap) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Patterns_vIn43 _lhsIallInhmap _lhsIallSynmap _lhsIanyLazyKind _lhsIinhmap _lhsIlocalAttrTypes _lhsIoptions _lhsIsynmap (T_Patterns_vOut43 _lhsOattrTypes _lhsOattrs _lhsOcopy _lhsOextraDefs _lhsOsem_lhs) <- return (inv_Patterns_s44 sem arg) return (Syn_Patterns _lhsOattrTypes _lhsOattrs _lhsOcopy _lhsOextraDefs _lhsOsem_lhs) ) -- cata {-# NOINLINE sem_Patterns #-} sem_Patterns :: Patterns -> T_Patterns sem_Patterns list = Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list) -- semantic domain newtype T_Patterns = T_Patterns { attach_T_Patterns :: Identity (T_Patterns_s44 ) } newtype T_Patterns_s44 = C_Patterns_s44 { inv_Patterns_s44 :: (T_Patterns_v43 ) } data T_Patterns_s45 = C_Patterns_s45 type T_Patterns_v43 = (T_Patterns_vIn43 ) -> (T_Patterns_vOut43 ) data T_Patterns_vIn43 = T_Patterns_vIn43 (Map NontermIdent Attributes) (Map NontermIdent Attributes) (Bool) (Attributes) (Map Identifier Type) (Options) (Attributes) data T_Patterns_vOut43 = T_Patterns_vOut43 (PP_Doc) (Set String) (Patterns) ([(PP_Doc,PP_Doc)]) ([PP_Doc]) {-# NOINLINE sem_Patterns_Cons #-} sem_Patterns_Cons :: T_Pattern -> T_Patterns -> T_Patterns sem_Patterns_Cons arg_hd_ arg_tl_ = T_Patterns (return st44) where {-# NOINLINE st44 #-} st44 = let v43 :: T_Patterns_v43 v43 = \ (T_Patterns_vIn43 _lhsIallInhmap _lhsIallSynmap _lhsIanyLazyKind _lhsIinhmap _lhsIlocalAttrTypes _lhsIoptions _lhsIsynmap) -> ( let _hdX41 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_hd_)) _tlX44 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_tl_)) (T_Pattern_vOut40 _hdIattrTypes _hdIattrs _hdIcopy _hdIextraDefs _hdIisUnderscore _hdIsem_lhs) = inv_Pattern_s41 _hdX41 (T_Pattern_vIn40 _hdOallInhmap _hdOallSynmap _hdOanyLazyKind _hdOinhmap _hdOlocalAttrTypes _hdOoptions _hdOsynmap) (T_Patterns_vOut43 _tlIattrTypes _tlIattrs _tlIcopy _tlIextraDefs _tlIsem_lhs) = inv_Patterns_s44 _tlX44 (T_Patterns_vIn43 _tlOallInhmap _tlOallSynmap _tlOanyLazyKind _tlOinhmap _tlOlocalAttrTypes _tlOoptions _tlOsynmap) _lhsOattrTypes :: PP_Doc _lhsOattrTypes = rule513 _hdIattrTypes _tlIattrTypes _lhsOattrs :: Set String _lhsOattrs = rule514 _hdIattrs _tlIattrs _lhsOextraDefs :: [(PP_Doc,PP_Doc)] _lhsOextraDefs = rule515 _hdIextraDefs _tlIextraDefs _lhsOsem_lhs :: [PP_Doc] _lhsOsem_lhs = rule516 _hdIsem_lhs _tlIsem_lhs _copy = rule517 _hdIcopy _tlIcopy _lhsOcopy :: Patterns _lhsOcopy = rule518 _copy _hdOallInhmap = rule519 _lhsIallInhmap _hdOallSynmap = rule520 _lhsIallSynmap _hdOanyLazyKind = rule521 _lhsIanyLazyKind _hdOinhmap = rule522 _lhsIinhmap _hdOlocalAttrTypes = rule523 _lhsIlocalAttrTypes _hdOoptions = rule524 _lhsIoptions _hdOsynmap = rule525 _lhsIsynmap _tlOallInhmap = rule526 _lhsIallInhmap _tlOallSynmap = rule527 _lhsIallSynmap _tlOanyLazyKind = rule528 _lhsIanyLazyKind _tlOinhmap = rule529 _lhsIinhmap _tlOlocalAttrTypes = rule530 _lhsIlocalAttrTypes _tlOoptions = rule531 _lhsIoptions _tlOsynmap = rule532 _lhsIsynmap __result_ = T_Patterns_vOut43 _lhsOattrTypes _lhsOattrs _lhsOcopy _lhsOextraDefs _lhsOsem_lhs in __result_ ) in C_Patterns_s44 v43 {-# INLINE rule513 #-} rule513 = \ ((_hdIattrTypes) :: PP_Doc) ((_tlIattrTypes) :: PP_Doc) -> _hdIattrTypes >-< _tlIattrTypes {-# INLINE rule514 #-} rule514 = \ ((_hdIattrs) :: Set String) ((_tlIattrs) :: Set String) -> _hdIattrs `Set.union` _tlIattrs {-# INLINE rule515 #-} rule515 = \ ((_hdIextraDefs) :: [(PP_Doc,PP_Doc)]) ((_tlIextraDefs) :: [(PP_Doc,PP_Doc)]) -> _hdIextraDefs ++ _tlIextraDefs {-# INLINE rule516 #-} rule516 = \ ((_hdIsem_lhs) :: PP_Doc ) ((_tlIsem_lhs) :: [PP_Doc]) -> _hdIsem_lhs : _tlIsem_lhs {-# INLINE rule517 #-} rule517 = \ ((_hdIcopy) :: Pattern) ((_tlIcopy) :: Patterns) -> (:) _hdIcopy _tlIcopy {-# INLINE rule518 #-} rule518 = \ _copy -> _copy {-# INLINE rule519 #-} rule519 = \ ((_lhsIallInhmap) :: Map NontermIdent Attributes) -> _lhsIallInhmap {-# INLINE rule520 #-} rule520 = \ ((_lhsIallSynmap) :: Map NontermIdent Attributes) -> _lhsIallSynmap {-# INLINE rule521 #-} rule521 = \ ((_lhsIanyLazyKind) :: Bool) -> _lhsIanyLazyKind {-# INLINE rule522 #-} rule522 = \ ((_lhsIinhmap) :: Attributes) -> _lhsIinhmap {-# INLINE rule523 #-} rule523 = \ ((_lhsIlocalAttrTypes) :: Map Identifier Type) -> _lhsIlocalAttrTypes {-# INLINE rule524 #-} rule524 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule525 #-} rule525 = \ ((_lhsIsynmap) :: Attributes) -> _lhsIsynmap {-# INLINE rule526 #-} rule526 = \ ((_lhsIallInhmap) :: Map NontermIdent Attributes) -> _lhsIallInhmap {-# INLINE rule527 #-} rule527 = \ ((_lhsIallSynmap) :: Map NontermIdent Attributes) -> _lhsIallSynmap {-# INLINE rule528 #-} rule528 = \ ((_lhsIanyLazyKind) :: Bool) -> _lhsIanyLazyKind {-# INLINE rule529 #-} rule529 = \ ((_lhsIinhmap) :: Attributes) -> _lhsIinhmap {-# INLINE rule530 #-} rule530 = \ ((_lhsIlocalAttrTypes) :: Map Identifier Type) -> _lhsIlocalAttrTypes {-# INLINE rule531 #-} rule531 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule532 #-} rule532 = \ ((_lhsIsynmap) :: Attributes) -> _lhsIsynmap {-# NOINLINE sem_Patterns_Nil #-} sem_Patterns_Nil :: T_Patterns sem_Patterns_Nil = T_Patterns (return st44) where {-# NOINLINE st44 #-} st44 = let v43 :: T_Patterns_v43 v43 = \ (T_Patterns_vIn43 _lhsIallInhmap _lhsIallSynmap _lhsIanyLazyKind _lhsIinhmap _lhsIlocalAttrTypes _lhsIoptions _lhsIsynmap) -> ( let _lhsOattrTypes :: PP_Doc _lhsOattrTypes = rule533 () _lhsOattrs :: Set String _lhsOattrs = rule534 () _lhsOextraDefs :: [(PP_Doc,PP_Doc)] _lhsOextraDefs = rule535 () _lhsOsem_lhs :: [PP_Doc] _lhsOsem_lhs = rule536 () _copy = rule537 () _lhsOcopy :: Patterns _lhsOcopy = rule538 _copy __result_ = T_Patterns_vOut43 _lhsOattrTypes _lhsOattrs _lhsOcopy _lhsOextraDefs _lhsOsem_lhs in __result_ ) in C_Patterns_s44 v43 {-# INLINE rule533 #-} rule533 = \ (_ :: ()) -> empty {-# INLINE rule534 #-} rule534 = \ (_ :: ()) -> Set.empty {-# INLINE rule535 #-} rule535 = \ (_ :: ()) -> [] {-# INLINE rule536 #-} rule536 = \ (_ :: ()) -> [] {-# INLINE rule537 #-} rule537 = \ (_ :: ()) -> [] {-# INLINE rule538 #-} rule538 = \ _copy -> _copy -- Visit ------------------------------------------------------- -- wrapper data Inh_Visit = Inh_Visit { allFromToStates_Inh_Visit :: (Map VisitIdentifier (Int,Int)), allInhmap_Inh_Visit :: (Map NontermIdent Attributes), allInitStates_Inh_Visit :: (Map NontermIdent Int), allSynmap_Inh_Visit :: (Map NontermIdent Attributes), allVisitKinds_Inh_Visit :: (Map VisitIdentifier VisitKind), allchildvisit_Inh_Visit :: (Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)), allintramap_Inh_Visit :: (Map StateIdentifier (Map String (Maybe NonLocalAttr))), avisitdefs_Inh_Visit :: (Map VisitIdentifier (Set Identifier)), avisituses_Inh_Visit :: (Map VisitIdentifier (Set Identifier)), childTypes_Inh_Visit :: (Map Identifier Type), childintros_Inh_Visit :: (Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))), con_Inh_Visit :: (ConstructorIdent), inhmap_Inh_Visit :: (Attributes), mrules_Inh_Visit :: (Map Identifier (VisitKind -> Either Error PP_Doc)), nextVisits_Inh_Visit :: (Map StateIdentifier StateCtx), nt_Inh_Visit :: (NontermIdent), options_Inh_Visit :: (Options), params_Inh_Visit :: ([Identifier]), prevVisits_Inh_Visit :: (Map StateIdentifier StateCtx), ruledefs_Inh_Visit :: (Map Identifier (Set String)), ruleuses_Inh_Visit :: (Map Identifier (Map String (Maybe NonLocalAttr))), synmap_Inh_Visit :: (Attributes), terminaldefs_Inh_Visit :: (Set String) } data Syn_Visit = Syn_Visit { allvisits_Syn_Visit :: ( VisitStateState ), childvisit_Syn_Visit :: (Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)), errors_Syn_Visit :: (Seq Error), fromToStates_Syn_Visit :: (Map VisitIdentifier (Int,Int)), intramap_Syn_Visit :: (Map StateIdentifier (Map String (Maybe NonLocalAttr))), lazyIntras_Syn_Visit :: (Set String), ruleKinds_Syn_Visit :: (Map Identifier (Set VisitKind)), ruleUsage_Syn_Visit :: (Map Identifier Int), sem_visit_Syn_Visit :: ( (StateIdentifier,PP_Doc) ), t_visits_Syn_Visit :: (PP_Doc), visitKinds_Syn_Visit :: (Map VisitIdentifier VisitKind), visitdefs_Syn_Visit :: (Map VisitIdentifier (Set Identifier)), visituses_Syn_Visit :: (Map VisitIdentifier (Set Identifier)) } {-# INLINABLE wrap_Visit #-} wrap_Visit :: T_Visit -> Inh_Visit -> (Syn_Visit ) wrap_Visit (T_Visit act) (Inh_Visit _lhsIallFromToStates _lhsIallInhmap _lhsIallInitStates _lhsIallSynmap _lhsIallVisitKinds _lhsIallchildvisit _lhsIallintramap _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIcon _lhsIinhmap _lhsImrules _lhsInextVisits _lhsInt _lhsIoptions _lhsIparams _lhsIprevVisits _lhsIruledefs _lhsIruleuses _lhsIsynmap _lhsIterminaldefs) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Visit_vIn46 _lhsIallFromToStates _lhsIallInhmap _lhsIallInitStates _lhsIallSynmap _lhsIallVisitKinds _lhsIallchildvisit _lhsIallintramap _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIcon _lhsIinhmap _lhsImrules _lhsInextVisits _lhsInt _lhsIoptions _lhsIparams _lhsIprevVisits _lhsIruledefs _lhsIruleuses _lhsIsynmap _lhsIterminaldefs (T_Visit_vOut46 _lhsOallvisits _lhsOchildvisit _lhsOerrors _lhsOfromToStates _lhsOintramap _lhsOlazyIntras _lhsOruleKinds _lhsOruleUsage _lhsOsem_visit _lhsOt_visits _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses) <- return (inv_Visit_s47 sem arg) return (Syn_Visit _lhsOallvisits _lhsOchildvisit _lhsOerrors _lhsOfromToStates _lhsOintramap _lhsOlazyIntras _lhsOruleKinds _lhsOruleUsage _lhsOsem_visit _lhsOt_visits _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses) ) -- cata {-# INLINE sem_Visit #-} sem_Visit :: Visit -> T_Visit sem_Visit ( Visit ident_ from_ to_ inh_ syn_ steps_ kind_ ) = sem_Visit_Visit ident_ from_ to_ inh_ syn_ ( sem_VisitSteps steps_ ) kind_ -- semantic domain newtype T_Visit = T_Visit { attach_T_Visit :: Identity (T_Visit_s47 ) } newtype T_Visit_s47 = C_Visit_s47 { inv_Visit_s47 :: (T_Visit_v46 ) } data T_Visit_s48 = C_Visit_s48 type T_Visit_v46 = (T_Visit_vIn46 ) -> (T_Visit_vOut46 ) data T_Visit_vIn46 = T_Visit_vIn46 (Map VisitIdentifier (Int,Int)) (Map NontermIdent Attributes) (Map NontermIdent Int) (Map NontermIdent Attributes) (Map VisitIdentifier VisitKind) (Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) (Map StateIdentifier (Map String (Maybe NonLocalAttr))) (Map VisitIdentifier (Set Identifier)) (Map VisitIdentifier (Set Identifier)) (Map Identifier Type) (Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))) (ConstructorIdent) (Attributes) (Map Identifier (VisitKind -> Either Error PP_Doc)) (Map StateIdentifier StateCtx) (NontermIdent) (Options) ([Identifier]) (Map StateIdentifier StateCtx) (Map Identifier (Set String)) (Map Identifier (Map String (Maybe NonLocalAttr))) (Attributes) (Set String) data T_Visit_vOut46 = T_Visit_vOut46 ( VisitStateState ) (Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) (Seq Error) (Map VisitIdentifier (Int,Int)) (Map StateIdentifier (Map String (Maybe NonLocalAttr))) (Set String) (Map Identifier (Set VisitKind)) (Map Identifier Int) ( (StateIdentifier,PP_Doc) ) (PP_Doc) (Map VisitIdentifier VisitKind) (Map VisitIdentifier (Set Identifier)) (Map VisitIdentifier (Set Identifier)) {-# NOINLINE sem_Visit_Visit #-} sem_Visit_Visit :: (VisitIdentifier) -> (StateIdentifier) -> (StateIdentifier) -> (Set Identifier) -> (Set Identifier) -> T_VisitSteps -> (VisitKind) -> T_Visit sem_Visit_Visit arg_ident_ arg_from_ arg_to_ arg_inh_ arg_syn_ arg_steps_ arg_kind_ = T_Visit (return st47) where {-# NOINLINE st47 #-} st47 = let v46 :: T_Visit_v46 v46 = \ (T_Visit_vIn46 _lhsIallFromToStates _lhsIallInhmap _lhsIallInitStates _lhsIallSynmap _lhsIallVisitKinds _lhsIallchildvisit _lhsIallintramap _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIcon _lhsIinhmap _lhsImrules _lhsInextVisits _lhsInt _lhsIoptions _lhsIparams _lhsIprevVisits _lhsIruledefs _lhsIruleuses _lhsIsynmap _lhsIterminaldefs) -> ( let _stepsX53 = Control.Monad.Identity.runIdentity (attach_T_VisitSteps (arg_steps_)) (T_VisitSteps_vOut52 _stepsIdefs _stepsIerrors _stepsIindex _stepsIisLast _stepsIlazyIntras _stepsIprevMaxSimRefs _stepsIruleKinds _stepsIruleUsage _stepsIsem_steps _stepsIsize _stepsIuses _stepsIvisitKinds) = inv_VisitSteps_s53 _stepsX53 (T_VisitSteps_vIn52 _stepsOallFromToStates _stepsOallInitStates _stepsOallVisitKinds _stepsOallchildvisit _stepsOavisitdefs _stepsOavisituses _stepsOchildTypes _stepsOchildintros _stepsOfollow _stepsOindex _stepsOkind _stepsOmrules _stepsOoptions _stepsOprevMaxSimRefs _stepsOruledefs _stepsOruleuses _stepsOuseParallel) _lhsOallvisits :: VisitStateState _lhsOallvisits = rule539 arg_from_ arg_ident_ arg_to_ _nameTIn_visit = rule540 _lhsInt arg_ident_ _nameTOut_visit = rule541 _lhsInt arg_ident_ _nameNextState = rule542 _lhsInt arg_to_ _nameCaller_visit = rule543 _lhsInt arg_ident_ _nextVisitInfo = rule544 _lhsInextVisits arg_to_ _t_params = rule545 _lhsIparams _t_c_params = rule546 _lhsIparams _lhsOt_visits :: PP_Doc _lhsOt_visits = rule547 _contpart _inhpart _lhsInt _nameCaller_visit _nameTIn_visit _nameTOut_visit _synpart _t_c_params _t_params arg_ident_ _contpart = rule548 _lhsInt _nameNextState _nextVisitInfo _t_params arg_ident_ _inhpart = rule549 _lhsIinhmap _ppTypeList arg_inh_ _synpart = rule550 _lhsIsynmap _ppTypeList arg_syn_ _ppTypeList = rule551 _lhsInt arg_ident_ _o_sigs = rule552 _lhsIoptions _lhsOsem_visit :: (StateIdentifier,PP_Doc) _lhsOsem_visit = rule553 _lhsInt _nameTIn_visit _nameTOut_visit _o_sigs _stepsIsem_steps _t_params arg_from_ arg_ident_ arg_inh_ _stepsOfollow = rule554 _nextStBuild _resultval _nextArgsMp = rule555 _lhsIallintramap arg_to_ _nextArgs = rule556 _nextArgsMp _nextStExp = rule557 _lhsIoptions _nextArgs _nextArgsMp arg_to_ _resultval = rule558 _lhsInt _nextStRefExp arg_ident_ arg_syn_ (_nextStBuild,_nextStRefExp) = rule559 _lhsInt _nextStExp _nextVisitInfo arg_ident_ _stepsOkind = rule560 arg_kind_ _stepsOindex = rule561 () _stepsOprevMaxSimRefs = rule562 () _stepsOuseParallel = rule563 () _prevVisitInfo = rule564 _lhsInextVisits arg_from_ _lhsOchildvisit :: Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc) _lhsOchildvisit = rule565 _invokecode arg_ident_ _invokecode = rule566 _lhsInt _nameTOut_visit _nextVisitInfo _o_sigs _prevVisitInfo arg_from_ arg_ident_ arg_inh_ arg_kind_ arg_syn_ arg_to_ _thisintra = rule567 _defsAsMap _nextintra _uses _lhsOintramap :: Map StateIdentifier (Map String (Maybe NonLocalAttr)) _lhsOintramap = rule568 _thisintra arg_from_ _nextintra = rule569 _lhsIallintramap arg_to_ _uses = rule570 _stepsIuses arg_syn_ _inhVarNms = rule571 arg_inh_ _defs = rule572 _inhVarNms _lhsIterminaldefs _stepsIdefs _defsAsMap = rule573 _defs _lhsOvisitdefs :: Map VisitIdentifier (Set Identifier) _lhsOvisitdefs = rule574 arg_ident_ arg_syn_ _lhsOvisituses :: Map VisitIdentifier (Set Identifier) _lhsOvisituses = rule575 arg_ident_ arg_inh_ _lazyIntrasInh = rule576 _inhVarNms _stepsIdefs arg_kind_ _lhsOlazyIntras :: Set String _lhsOlazyIntras = rule577 _lazyIntrasInh _stepsIlazyIntras _lhsOfromToStates :: Map VisitIdentifier (Int,Int) _lhsOfromToStates = rule578 arg_from_ arg_ident_ arg_to_ _lhsOvisitKinds :: Map VisitIdentifier VisitKind _lhsOvisitKinds = rule579 arg_ident_ arg_kind_ _lhsOerrors :: Seq Error _lhsOerrors = rule580 _stepsIerrors _lhsOruleKinds :: Map Identifier (Set VisitKind) _lhsOruleKinds = rule581 _stepsIruleKinds _lhsOruleUsage :: Map Identifier Int _lhsOruleUsage = rule582 _stepsIruleUsage _stepsOallFromToStates = rule583 _lhsIallFromToStates _stepsOallInitStates = rule584 _lhsIallInitStates _stepsOallVisitKinds = rule585 _lhsIallVisitKinds _stepsOallchildvisit = rule586 _lhsIallchildvisit _stepsOavisitdefs = rule587 _lhsIavisitdefs _stepsOavisituses = rule588 _lhsIavisituses _stepsOchildTypes = rule589 _lhsIchildTypes _stepsOchildintros = rule590 _lhsIchildintros _stepsOmrules = rule591 _lhsImrules _stepsOoptions = rule592 _lhsIoptions _stepsOruledefs = rule593 _lhsIruledefs _stepsOruleuses = rule594 _lhsIruleuses __result_ = T_Visit_vOut46 _lhsOallvisits _lhsOchildvisit _lhsOerrors _lhsOfromToStates _lhsOintramap _lhsOlazyIntras _lhsOruleKinds _lhsOruleUsage _lhsOsem_visit _lhsOt_visits _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses in __result_ ) in C_Visit_s47 v46 {-# INLINE rule539 #-} {-# LINE 434 "./src-ag/ExecutionPlan2Caml.ag" #-} rule539 = \ from_ ident_ to_ -> {-# LINE 434 "./src-ag/ExecutionPlan2Caml.ag" #-} (ident_, from_, to_) {-# LINE 4484 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule540 #-} {-# LINE 537 "./src-ag/ExecutionPlan2Caml.ag" #-} rule540 = \ ((_lhsInt) :: NontermIdent) ident_ -> {-# LINE 537 "./src-ag/ExecutionPlan2Caml.ag" #-} conNmTVisitIn _lhsInt ident_ {-# LINE 4490 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule541 #-} {-# LINE 538 "./src-ag/ExecutionPlan2Caml.ag" #-} rule541 = \ ((_lhsInt) :: NontermIdent) ident_ -> {-# LINE 538 "./src-ag/ExecutionPlan2Caml.ag" #-} conNmTVisitOut _lhsInt ident_ {-# LINE 4496 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule542 #-} {-# LINE 539 "./src-ag/ExecutionPlan2Caml.ag" #-} rule542 = \ ((_lhsInt) :: NontermIdent) to_ -> {-# LINE 539 "./src-ag/ExecutionPlan2Caml.ag" #-} type_nt_sem _lhsInt to_ {-# LINE 4502 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule543 #-} {-# LINE 540 "./src-ag/ExecutionPlan2Caml.ag" #-} rule543 = \ ((_lhsInt) :: NontermIdent) ident_ -> {-# LINE 540 "./src-ag/ExecutionPlan2Caml.ag" #-} type_caller_visit _lhsInt ident_ {-# LINE 4508 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule544 #-} {-# LINE 542 "./src-ag/ExecutionPlan2Caml.ag" #-} rule544 = \ ((_lhsInextVisits) :: Map StateIdentifier StateCtx) to_ -> {-# LINE 542 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.findWithDefault ManyVis to_ _lhsInextVisits {-# LINE 4514 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule545 #-} {-# LINE 544 "./src-ag/ExecutionPlan2Caml.ag" #-} rule545 = \ ((_lhsIparams) :: [Identifier]) -> {-# LINE 544 "./src-ag/ExecutionPlan2Caml.ag" #-} ppTypeParams _lhsIparams {-# LINE 4520 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule546 #-} {-# LINE 545 "./src-ag/ExecutionPlan2Caml.ag" #-} rule546 = \ ((_lhsIparams) :: [Identifier]) -> {-# LINE 545 "./src-ag/ExecutionPlan2Caml.ag" #-} ppTypeParams (cont_tvar : map pp _lhsIparams) {-# LINE 4526 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule547 #-} {-# LINE 549 "./src-ag/ExecutionPlan2Caml.ag" #-} rule547 = \ _contpart _inhpart ((_lhsInt) :: NontermIdent) _nameCaller_visit _nameTIn_visit _nameTOut_visit _synpart _t_c_params _t_params ident_ -> {-# LINE 549 "./src-ag/ExecutionPlan2Caml.ag" #-} "and" >#< _t_c_params >#< _nameCaller_visit >#< "=" >#< ppRecordTp [ nm_inh _lhsInt ident_ >#< ":" >#< _t_params >#< conNmTVisitIn _lhsInt ident_ , nm_cont _lhsInt ident_ >#< ":" >#< _t_params >#< conNmTVisitOut _lhsInt ident_ >#< "->" >#< cont_tvar ] >-< "and" >#< _t_params >#< _nameTIn_visit >#< "=" >#< ppRecordTp _inhpart >-< "and" >#< _t_params >#< _nameTOut_visit >#< "=" >#< ppRecordTp (_synpart ++ _contpart ) {-# LINE 4537 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule548 #-} {-# LINE 556 "./src-ag/ExecutionPlan2Caml.ag" #-} rule548 = \ ((_lhsInt) :: NontermIdent) _nameNextState _nextVisitInfo _t_params ident_ -> {-# LINE 556 "./src-ag/ExecutionPlan2Caml.ag" #-} case _nextVisitInfo of NoneVis -> [] _ -> [ nm_outarg_cont _lhsInt ident_ >#< ":" >#< _t_params >#< _nameNextState ] {-# LINE 4545 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule549 #-} {-# LINE 560 "./src-ag/ExecutionPlan2Caml.ag" #-} rule549 = \ ((_lhsIinhmap) :: Attributes) _ppTypeList inh_ -> {-# LINE 560 "./src-ag/ExecutionPlan2Caml.ag" #-} _ppTypeList nm_inarg inh_ _lhsIinhmap {-# LINE 4551 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule550 #-} {-# LINE 561 "./src-ag/ExecutionPlan2Caml.ag" #-} rule550 = \ ((_lhsIsynmap) :: Attributes) _ppTypeList syn_ -> {-# LINE 561 "./src-ag/ExecutionPlan2Caml.ag" #-} _ppTypeList nm_outarg syn_ _lhsIsynmap {-# LINE 4557 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule551 #-} {-# LINE 562 "./src-ag/ExecutionPlan2Caml.ag" #-} rule551 = \ ((_lhsInt) :: NontermIdent) ident_ -> {-# LINE 562 "./src-ag/ExecutionPlan2Caml.ag" #-} \f s m -> map (\i -> case Map.lookup i m of Just tp -> f i _lhsInt ident_ >#< ":" >#< ppTp tp ) $ Set.toList s {-# LINE 4564 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule552 #-} {-# LINE 796 "./src-ag/ExecutionPlan2Caml.ag" #-} rule552 = \ ((_lhsIoptions) :: Options) -> {-# LINE 796 "./src-ag/ExecutionPlan2Caml.ag" #-} typeSigs _lhsIoptions {-# LINE 4570 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule553 #-} {-# LINE 797 "./src-ag/ExecutionPlan2Caml.ag" #-} rule553 = \ ((_lhsInt) :: NontermIdent) _nameTIn_visit _nameTOut_visit _o_sigs ((_stepsIsem_steps) :: PP_Doc) _t_params from_ ident_ inh_ -> {-# LINE 797 "./src-ag/ExecutionPlan2Caml.ag" #-} ( from_ , let resTp = _t_params >#< _nameTOut_visit argTp = _t_params >#< _nameTIn_visit argMatch = ppRecordVal [ nm_inarg i _lhsInt ident_ >#< "=" >#< lhsname True i | i <- Set.toList inh_ ] in ppFunDecl _o_sigs (nm_visit ident_) [(argMatch, argTp)] resTp _stepsIsem_steps ) {-# LINE 4581 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule554 #-} {-# LINE 804 "./src-ag/ExecutionPlan2Caml.ag" #-} rule554 = \ _nextStBuild _resultval -> {-# LINE 804 "./src-ag/ExecutionPlan2Caml.ag" #-} _nextStBuild >-< _resultval {-# LINE 4587 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule555 #-} {-# LINE 806 "./src-ag/ExecutionPlan2Caml.ag" #-} rule555 = \ ((_lhsIallintramap) :: Map StateIdentifier (Map String (Maybe NonLocalAttr))) to_ -> {-# LINE 806 "./src-ag/ExecutionPlan2Caml.ag" #-} maybe Map.empty id $ Map.lookup to_ _lhsIallintramap {-# LINE 4593 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule556 #-} {-# LINE 807 "./src-ag/ExecutionPlan2Caml.ag" #-} rule556 = \ _nextArgsMp -> {-# LINE 807 "./src-ag/ExecutionPlan2Caml.ag" #-} ppSpaced $ Map.keys $ _nextArgsMp {-# LINE 4599 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule557 #-} {-# LINE 808 "./src-ag/ExecutionPlan2Caml.ag" #-} rule557 = \ ((_lhsIoptions) :: Options) _nextArgs _nextArgsMp to_ -> {-# LINE 808 "./src-ag/ExecutionPlan2Caml.ag" #-} nm_st to_ >#< _nextArgs >#< dummyArg _lhsIoptions (Map.null _nextArgsMp ) {-# LINE 4605 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule558 #-} {-# LINE 810 "./src-ag/ExecutionPlan2Caml.ag" #-} rule558 = \ ((_lhsInt) :: NontermIdent) _nextStRefExp ident_ syn_ -> {-# LINE 810 "./src-ag/ExecutionPlan2Caml.ag" #-} ppRecordVal ( [ nm_outarg i _lhsInt ident_ >#< "=" >#< lhsname False i | i <- Set.toList syn_ ] ++ [ _nextStRefExp ]) {-# LINE 4613 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule559 #-} {-# LINE 815 "./src-ag/ExecutionPlan2Caml.ag" #-} rule559 = \ ((_lhsInt) :: NontermIdent) _nextStExp _nextVisitInfo ident_ -> {-# LINE 815 "./src-ag/ExecutionPlan2Caml.ag" #-} case _nextVisitInfo of NoneVis -> (empty, empty) _ -> ( "let" >#< nextStName >#< "=" >#< _nextStExp >#< "in" , nm_outarg_cont _lhsInt ident_ >#< "=" >#< nextStName) {-# LINE 4622 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule560 #-} {-# LINE 830 "./src-ag/ExecutionPlan2Caml.ag" #-} rule560 = \ kind_ -> {-# LINE 830 "./src-ag/ExecutionPlan2Caml.ag" #-} kind_ {-# LINE 4628 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule561 #-} {-# LINE 882 "./src-ag/ExecutionPlan2Caml.ag" #-} rule561 = \ (_ :: ()) -> {-# LINE 882 "./src-ag/ExecutionPlan2Caml.ag" #-} 0 {-# LINE 4634 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule562 #-} {-# LINE 889 "./src-ag/ExecutionPlan2Caml.ag" #-} rule562 = \ (_ :: ()) -> {-# LINE 889 "./src-ag/ExecutionPlan2Caml.ag" #-} 0 {-# LINE 4640 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule563 #-} {-# LINE 906 "./src-ag/ExecutionPlan2Caml.ag" #-} rule563 = \ (_ :: ()) -> {-# LINE 906 "./src-ag/ExecutionPlan2Caml.ag" #-} False {-# LINE 4646 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule564 #-} {-# LINE 1162 "./src-ag/ExecutionPlan2Caml.ag" #-} rule564 = \ ((_lhsInextVisits) :: Map StateIdentifier StateCtx) from_ -> {-# LINE 1162 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.findWithDefault ManyVis from_ _lhsInextVisits {-# LINE 4652 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule565 #-} {-# LINE 1163 "./src-ag/ExecutionPlan2Caml.ag" #-} rule565 = \ _invokecode ident_ -> {-# LINE 1163 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.singleton ident_ _invokecode {-# LINE 4658 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule566 #-} {-# LINE 1165 "./src-ag/ExecutionPlan2Caml.ag" #-} rule566 = \ ((_lhsInt) :: NontermIdent) _nameTOut_visit _nextVisitInfo _o_sigs _prevVisitInfo from_ ident_ inh_ kind_ syn_ to_ -> {-# LINE 1165 "./src-ag/ExecutionPlan2Caml.ag" #-} \chld childTp kind follow -> 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 = "let" >#< contNm >#< ppArg _o_sigs (ppRecordVal cont_in) cont_in_tp >#< "=" >-< indent 2 follow >#< "in" cont_in = [ nm_outarg i _lhsInt ident_ >#< "=" >#< attrname True chld i | i <- Set.toList syn_ ] ++ case _nextVisitInfo of NoneVis -> [] _ -> [ nm_outarg_cont _lhsInt ident_ >#< "=" >#< childNmTo ] cont_in_tp = ppTypeParams childTpArgs >#< _nameTOut_visit inps = "let" >#< inpsNm >#< "=" >#< ppRecordVal [ nm_inh _lhsInt ident_ >#< "=" >#< ppRecordVal inps_in , nm_cont _lhsInt ident_ >#< "=" >#< contNm ] >#< "in" inps_in = [ nm_inarg i _lhsInt ident_ >#< "=" >#< attrname False chld i | i <- Set.toList inh_ ] call = childNmFrom >|< "." >|< nm_invoke _lhsInt from_ >#< arg arg = case _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 _lhsInt ident_ >#< inpsNm) in if kind `compatibleKind` kind_ then Right code else Left $ IncompatibleVisitKind chld ident_ kind kind_ {-# LINE 4691 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule567 #-} {-# LINE 1270 "./src-ag/ExecutionPlan2Caml.ag" #-} rule567 = \ _defsAsMap _nextintra _uses -> {-# LINE 1270 "./src-ag/ExecutionPlan2Caml.ag" #-} (_uses `Map.union` _nextintra ) `Map.difference` _defsAsMap {-# LINE 4697 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule568 #-} {-# LINE 1271 "./src-ag/ExecutionPlan2Caml.ag" #-} rule568 = \ _thisintra from_ -> {-# LINE 1271 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.singleton from_ _thisintra {-# LINE 4703 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule569 #-} {-# LINE 1272 "./src-ag/ExecutionPlan2Caml.ag" #-} rule569 = \ ((_lhsIallintramap) :: Map StateIdentifier (Map String (Maybe NonLocalAttr))) to_ -> {-# LINE 1272 "./src-ag/ExecutionPlan2Caml.ag" #-} maybe Map.empty id $ Map.lookup to_ _lhsIallintramap {-# LINE 4709 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule570 #-} {-# LINE 1273 "./src-ag/ExecutionPlan2Caml.ag" #-} rule570 = \ ((_stepsIuses) :: Map String (Maybe NonLocalAttr)) syn_ -> {-# LINE 1273 "./src-ag/ExecutionPlan2Caml.ag" #-} let mp1 = _stepsIuses mp2 = Map.fromList [ (lhsname False i, Just (AttrSyn _LHS i)) | i <- Set.elems syn_ ] in mp1 `Map.union` mp2 {-# LINE 4717 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule571 #-} {-# LINE 1276 "./src-ag/ExecutionPlan2Caml.ag" #-} rule571 = \ inh_ -> {-# LINE 1276 "./src-ag/ExecutionPlan2Caml.ag" #-} Set.map (lhsname True) inh_ {-# LINE 4723 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule572 #-} {-# LINE 1277 "./src-ag/ExecutionPlan2Caml.ag" #-} rule572 = \ _inhVarNms ((_lhsIterminaldefs) :: Set String) ((_stepsIdefs) :: Set String) -> {-# LINE 1277 "./src-ag/ExecutionPlan2Caml.ag" #-} _stepsIdefs `Set.union` _inhVarNms `Set.union` _lhsIterminaldefs {-# LINE 4729 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule573 #-} {-# LINE 1278 "./src-ag/ExecutionPlan2Caml.ag" #-} rule573 = \ _defs -> {-# LINE 1278 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.fromList [ (a, Nothing) | a <- Set.elems _defs ] {-# LINE 4735 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule574 #-} {-# LINE 1302 "./src-ag/ExecutionPlan2Caml.ag" #-} rule574 = \ ident_ syn_ -> {-# LINE 1302 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.singleton ident_ syn_ {-# LINE 4741 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule575 #-} {-# LINE 1303 "./src-ag/ExecutionPlan2Caml.ag" #-} rule575 = \ ident_ inh_ -> {-# LINE 1303 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.singleton ident_ inh_ {-# LINE 4747 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule576 #-} {-# LINE 1335 "./src-ag/ExecutionPlan2Caml.ag" #-} rule576 = \ _inhVarNms ((_stepsIdefs) :: Set String) kind_ -> {-# LINE 1335 "./src-ag/ExecutionPlan2Caml.ag" #-} case kind_ of VisitPure False -> _inhVarNms `Set.union` _stepsIdefs _ -> Set.empty {-# LINE 4755 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule577 #-} {-# LINE 1338 "./src-ag/ExecutionPlan2Caml.ag" #-} rule577 = \ _lazyIntrasInh ((_stepsIlazyIntras) :: Set String) -> {-# LINE 1338 "./src-ag/ExecutionPlan2Caml.ag" #-} _lazyIntrasInh `Set.union` _stepsIlazyIntras {-# LINE 4761 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule578 #-} {-# LINE 1401 "./src-ag/ExecutionPlan2Caml.ag" #-} rule578 = \ from_ ident_ to_ -> {-# LINE 1401 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.singleton ident_ (from_, to_) {-# LINE 4767 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule579 #-} {-# LINE 1445 "./src-ag/ExecutionPlan2Caml.ag" #-} rule579 = \ ident_ kind_ -> {-# LINE 1445 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.singleton ident_ kind_ {-# LINE 4773 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule580 #-} rule580 = \ ((_stepsIerrors) :: Seq Error) -> _stepsIerrors {-# INLINE rule581 #-} rule581 = \ ((_stepsIruleKinds) :: Map Identifier (Set VisitKind)) -> _stepsIruleKinds {-# INLINE rule582 #-} rule582 = \ ((_stepsIruleUsage) :: Map Identifier Int) -> _stepsIruleUsage {-# INLINE rule583 #-} rule583 = \ ((_lhsIallFromToStates) :: Map VisitIdentifier (Int,Int)) -> _lhsIallFromToStates {-# INLINE rule584 #-} rule584 = \ ((_lhsIallInitStates) :: Map NontermIdent Int) -> _lhsIallInitStates {-# INLINE rule585 #-} rule585 = \ ((_lhsIallVisitKinds) :: Map VisitIdentifier VisitKind) -> _lhsIallVisitKinds {-# INLINE rule586 #-} rule586 = \ ((_lhsIallchildvisit) :: Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) -> _lhsIallchildvisit {-# INLINE rule587 #-} rule587 = \ ((_lhsIavisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisitdefs {-# INLINE rule588 #-} rule588 = \ ((_lhsIavisituses) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisituses {-# INLINE rule589 #-} rule589 = \ ((_lhsIchildTypes) :: Map Identifier Type) -> _lhsIchildTypes {-# INLINE rule590 #-} rule590 = \ ((_lhsIchildintros) :: Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))) -> _lhsIchildintros {-# INLINE rule591 #-} rule591 = \ ((_lhsImrules) :: Map Identifier (VisitKind -> Either Error PP_Doc)) -> _lhsImrules {-# INLINE rule592 #-} rule592 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule593 #-} rule593 = \ ((_lhsIruledefs) :: Map Identifier (Set String)) -> _lhsIruledefs {-# INLINE rule594 #-} rule594 = \ ((_lhsIruleuses) :: Map Identifier (Map String (Maybe NonLocalAttr))) -> _lhsIruleuses -- VisitStep --------------------------------------------------- -- wrapper data Inh_VisitStep = Inh_VisitStep { allFromToStates_Inh_VisitStep :: (Map VisitIdentifier (Int,Int)), allInitStates_Inh_VisitStep :: (Map NontermIdent Int), allVisitKinds_Inh_VisitStep :: (Map VisitIdentifier VisitKind), allchildvisit_Inh_VisitStep :: (Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)), avisitdefs_Inh_VisitStep :: (Map VisitIdentifier (Set Identifier)), avisituses_Inh_VisitStep :: (Map VisitIdentifier (Set Identifier)), childTypes_Inh_VisitStep :: (Map Identifier Type), childintros_Inh_VisitStep :: (Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))), follow_Inh_VisitStep :: (PP_Doc), index_Inh_VisitStep :: (Int), isLast_Inh_VisitStep :: (Bool), kind_Inh_VisitStep :: (VisitKind), mrules_Inh_VisitStep :: (Map Identifier (VisitKind -> Either Error PP_Doc)), options_Inh_VisitStep :: (Options), prevMaxSimRefs_Inh_VisitStep :: (Int), ruledefs_Inh_VisitStep :: (Map Identifier (Set String)), ruleuses_Inh_VisitStep :: (Map Identifier (Map String (Maybe NonLocalAttr))), useParallel_Inh_VisitStep :: (Bool) } data Syn_VisitStep = Syn_VisitStep { defs_Syn_VisitStep :: (Set String), errors_Syn_VisitStep :: (Seq Error), index_Syn_VisitStep :: (Int), isLast_Syn_VisitStep :: (Bool), lazyIntras_Syn_VisitStep :: (Set String), prevMaxSimRefs_Syn_VisitStep :: (Int), ruleKinds_Syn_VisitStep :: (Map Identifier (Set VisitKind)), ruleUsage_Syn_VisitStep :: (Map Identifier Int), sem_steps_Syn_VisitStep :: (PP_Doc), uses_Syn_VisitStep :: (Map String (Maybe NonLocalAttr)), visitKinds_Syn_VisitStep :: (Map VisitIdentifier VisitKind) } {-# INLINABLE wrap_VisitStep #-} wrap_VisitStep :: T_VisitStep -> Inh_VisitStep -> (Syn_VisitStep ) wrap_VisitStep (T_VisitStep act) (Inh_VisitStep _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIfollow _lhsIindex _lhsIisLast _lhsIkind _lhsImrules _lhsIoptions _lhsIprevMaxSimRefs _lhsIruledefs _lhsIruleuses _lhsIuseParallel) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_VisitStep_vIn49 _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIfollow _lhsIindex _lhsIisLast _lhsIkind _lhsImrules _lhsIoptions _lhsIprevMaxSimRefs _lhsIruledefs _lhsIruleuses _lhsIuseParallel (T_VisitStep_vOut49 _lhsOdefs _lhsOerrors _lhsOindex _lhsOisLast _lhsOlazyIntras _lhsOprevMaxSimRefs _lhsOruleKinds _lhsOruleUsage _lhsOsem_steps _lhsOuses _lhsOvisitKinds) <- return (inv_VisitStep_s50 sem arg) return (Syn_VisitStep _lhsOdefs _lhsOerrors _lhsOindex _lhsOisLast _lhsOlazyIntras _lhsOprevMaxSimRefs _lhsOruleKinds _lhsOruleUsage _lhsOsem_steps _lhsOuses _lhsOvisitKinds) ) -- cata {-# NOINLINE sem_VisitStep #-} sem_VisitStep :: VisitStep -> T_VisitStep sem_VisitStep ( Sem name_ ) = sem_VisitStep_Sem name_ sem_VisitStep ( ChildVisit child_ nonterm_ visit_ ) = sem_VisitStep_ChildVisit child_ nonterm_ visit_ sem_VisitStep ( PureGroup steps_ ordered_ ) = sem_VisitStep_PureGroup ( sem_VisitSteps steps_ ) ordered_ sem_VisitStep ( Sim steps_ ) = sem_VisitStep_Sim ( sem_VisitSteps steps_ ) sem_VisitStep ( ChildIntro child_ ) = sem_VisitStep_ChildIntro child_ -- semantic domain newtype T_VisitStep = T_VisitStep { attach_T_VisitStep :: Identity (T_VisitStep_s50 ) } newtype T_VisitStep_s50 = C_VisitStep_s50 { inv_VisitStep_s50 :: (T_VisitStep_v49 ) } data T_VisitStep_s51 = C_VisitStep_s51 type T_VisitStep_v49 = (T_VisitStep_vIn49 ) -> (T_VisitStep_vOut49 ) data T_VisitStep_vIn49 = T_VisitStep_vIn49 (Map VisitIdentifier (Int,Int)) (Map NontermIdent Int) (Map VisitIdentifier VisitKind) (Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) (Map VisitIdentifier (Set Identifier)) (Map VisitIdentifier (Set Identifier)) (Map Identifier Type) (Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))) (PP_Doc) (Int) (Bool) (VisitKind) (Map Identifier (VisitKind -> Either Error PP_Doc)) (Options) (Int) (Map Identifier (Set String)) (Map Identifier (Map String (Maybe NonLocalAttr))) (Bool) data T_VisitStep_vOut49 = T_VisitStep_vOut49 (Set String) (Seq Error) (Int) (Bool) (Set String) (Int) (Map Identifier (Set VisitKind)) (Map Identifier Int) (PP_Doc) (Map String (Maybe NonLocalAttr)) (Map VisitIdentifier VisitKind) {-# NOINLINE sem_VisitStep_Sem #-} sem_VisitStep_Sem :: (Identifier) -> T_VisitStep sem_VisitStep_Sem arg_name_ = T_VisitStep (return st50) where {-# NOINLINE st50 #-} st50 = let v49 :: T_VisitStep_v49 v49 = \ (T_VisitStep_vIn49 _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIfollow _lhsIindex _lhsIisLast _lhsIkind _lhsImrules _lhsIoptions _lhsIprevMaxSimRefs _lhsIruledefs _lhsIruleuses _lhsIuseParallel) -> ( let _ruleItf = rule595 _lhsImrules arg_name_ _lhsOerrors :: Seq Error (_lhsOerrors,_sem_steps) = rule596 _lhsIkind _ruleItf _lhsOsem_steps :: PP_Doc _lhsOsem_steps = rule597 _lhsIfollow _sem_steps _lhsOruleUsage :: Map Identifier Int _lhsOruleUsage = rule598 arg_name_ _lhsOruleKinds :: Map Identifier (Set VisitKind) _lhsOruleKinds = rule599 _lhsIkind arg_name_ _lhsOdefs :: Set String _lhsOdefs = rule600 _lhsIruledefs arg_name_ _lhsOuses :: Map String (Maybe NonLocalAttr) _lhsOuses = rule601 _lhsIruleuses arg_name_ _lhsOlazyIntras :: Set String _lhsOlazyIntras = rule602 () _lhsOvisitKinds :: Map VisitIdentifier VisitKind _lhsOvisitKinds = rule603 () _lhsOindex :: Int _lhsOindex = rule604 _lhsIindex _lhsOisLast :: Bool _lhsOisLast = rule605 _lhsIisLast _lhsOprevMaxSimRefs :: Int _lhsOprevMaxSimRefs = rule606 _lhsIprevMaxSimRefs __result_ = T_VisitStep_vOut49 _lhsOdefs _lhsOerrors _lhsOindex _lhsOisLast _lhsOlazyIntras _lhsOprevMaxSimRefs _lhsOruleKinds _lhsOruleUsage _lhsOsem_steps _lhsOuses _lhsOvisitKinds in __result_ ) in C_VisitStep_s50 v49 {-# INLINE rule595 #-} {-# LINE 847 "./src-ag/ExecutionPlan2Caml.ag" #-} rule595 = \ ((_lhsImrules) :: Map Identifier (VisitKind -> Either Error PP_Doc)) name_ -> {-# LINE 847 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.findWithDefault (error $ "Rule " ++ show name_ ++ " not found") name_ _lhsImrules {-# LINE 4892 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule596 #-} {-# LINE 848 "./src-ag/ExecutionPlan2Caml.ag" #-} rule596 = \ ((_lhsIkind) :: VisitKind) _ruleItf -> {-# LINE 848 "./src-ag/ExecutionPlan2Caml.ag" #-} case _ruleItf _lhsIkind of Left e -> (Seq.singleton e, empty) Right stmt -> (Seq.empty, stmt) {-# LINE 4900 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule597 #-} {-# LINE 851 "./src-ag/ExecutionPlan2Caml.ag" #-} rule597 = \ ((_lhsIfollow) :: PP_Doc) _sem_steps -> {-# LINE 851 "./src-ag/ExecutionPlan2Caml.ag" #-} _sem_steps >-< _lhsIfollow {-# LINE 4906 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule598 #-} {-# LINE 1223 "./src-ag/ExecutionPlan2Caml.ag" #-} rule598 = \ name_ -> {-# LINE 1223 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.singleton name_ 1 {-# LINE 4912 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule599 #-} {-# LINE 1233 "./src-ag/ExecutionPlan2Caml.ag" #-} rule599 = \ ((_lhsIkind) :: VisitKind) name_ -> {-# LINE 1233 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.singleton name_ (Set.singleton _lhsIkind) {-# LINE 4918 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule600 #-} {-# LINE 1318 "./src-ag/ExecutionPlan2Caml.ag" #-} rule600 = \ ((_lhsIruledefs) :: Map Identifier (Set String)) name_ -> {-# LINE 1318 "./src-ag/ExecutionPlan2Caml.ag" #-} maybe (error "Rule not found") id $ Map.lookup name_ _lhsIruledefs {-# LINE 4924 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule601 #-} {-# LINE 1319 "./src-ag/ExecutionPlan2Caml.ag" #-} rule601 = \ ((_lhsIruleuses) :: Map Identifier (Map String (Maybe NonLocalAttr))) name_ -> {-# LINE 1319 "./src-ag/ExecutionPlan2Caml.ag" #-} maybe (error "Rule not found") id $ Map.lookup name_ _lhsIruleuses {-# LINE 4930 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule602 #-} rule602 = \ (_ :: ()) -> Set.empty {-# INLINE rule603 #-} rule603 = \ (_ :: ()) -> mempty {-# INLINE rule604 #-} rule604 = \ ((_lhsIindex) :: Int) -> _lhsIindex {-# INLINE rule605 #-} rule605 = \ ((_lhsIisLast) :: Bool) -> _lhsIisLast {-# INLINE rule606 #-} rule606 = \ ((_lhsIprevMaxSimRefs) :: Int) -> _lhsIprevMaxSimRefs {-# NOINLINE sem_VisitStep_ChildVisit #-} sem_VisitStep_ChildVisit :: (Identifier) -> (NontermIdent) -> (VisitIdentifier) -> T_VisitStep sem_VisitStep_ChildVisit arg_child_ _ arg_visit_ = T_VisitStep (return st50) where {-# NOINLINE st50 #-} st50 = let v49 :: T_VisitStep_v49 v49 = \ (T_VisitStep_vIn49 _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIfollow _lhsIindex _lhsIisLast _lhsIkind _lhsImrules _lhsIoptions _lhsIprevMaxSimRefs _lhsIruledefs _lhsIruleuses _lhsIuseParallel) -> ( let _visitItf = rule607 _lhsIallchildvisit arg_visit_ _childType = rule608 _lhsIchildTypes arg_child_ _lhsOerrors :: Seq Error _lhsOsem_steps :: PP_Doc (_lhsOerrors,_lhsOsem_steps) = rule609 _childType _lhsIfollow _lhsIkind _visitItf arg_child_ _lhsOdefs :: Set String _lhsOdefs = rule610 _lhsIavisitdefs _to arg_child_ arg_visit_ _lhsOuses :: Map String (Maybe NonLocalAttr) _lhsOuses = rule611 _from _lhsIavisituses arg_child_ arg_visit_ (_from,_to) = rule612 _lhsIallFromToStates arg_visit_ _lhsOlazyIntras :: Set String _lhsOlazyIntras = rule613 () _lhsOruleKinds :: Map Identifier (Set VisitKind) _lhsOruleKinds = rule614 () _lhsOruleUsage :: Map Identifier Int _lhsOruleUsage = rule615 () _lhsOvisitKinds :: Map VisitIdentifier VisitKind _lhsOvisitKinds = rule616 () _lhsOindex :: Int _lhsOindex = rule617 _lhsIindex _lhsOisLast :: Bool _lhsOisLast = rule618 _lhsIisLast _lhsOprevMaxSimRefs :: Int _lhsOprevMaxSimRefs = rule619 _lhsIprevMaxSimRefs __result_ = T_VisitStep_vOut49 _lhsOdefs _lhsOerrors _lhsOindex _lhsOisLast _lhsOlazyIntras _lhsOprevMaxSimRefs _lhsOruleKinds _lhsOruleUsage _lhsOsem_steps _lhsOuses _lhsOvisitKinds in __result_ ) in C_VisitStep_s50 v49 {-# INLINE rule607 #-} {-# LINE 858 "./src-ag/ExecutionPlan2Caml.ag" #-} rule607 = \ ((_lhsIallchildvisit) :: Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) visit_ -> {-# LINE 858 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.findWithDefault (error $ "Visit " ++ show visit_ ++ " not found") visit_ _lhsIallchildvisit {-# LINE 4985 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule608 #-} {-# LINE 859 "./src-ag/ExecutionPlan2Caml.ag" #-} rule608 = \ ((_lhsIchildTypes) :: Map Identifier Type) child_ -> {-# LINE 859 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.findWithDefault (error ("type of child " ++ show child_ ++ " is not in the childTypes map! " ++ show _lhsIchildTypes)) child_ _lhsIchildTypes {-# LINE 4991 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule609 #-} {-# LINE 860 "./src-ag/ExecutionPlan2Caml.ag" #-} rule609 = \ _childType ((_lhsIfollow) :: PP_Doc) ((_lhsIkind) :: VisitKind) _visitItf child_ -> {-# LINE 860 "./src-ag/ExecutionPlan2Caml.ag" #-} case _visitItf child_ _childType _lhsIkind _lhsIfollow of Left e -> (Seq.singleton e, empty) Right steps -> (Seq.empty, steps) {-# LINE 4999 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule610 #-} {-# LINE 1320 "./src-ag/ExecutionPlan2Caml.ag" #-} rule610 = \ ((_lhsIavisitdefs) :: Map VisitIdentifier (Set Identifier)) _to child_ visit_ -> {-# LINE 1320 "./src-ag/ExecutionPlan2Caml.ag" #-} Set.insert (stname child_ _to) $ maybe (error "Visit not found") (Set.map $ attrname True child_) $ Map.lookup visit_ _lhsIavisitdefs {-# LINE 5005 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule611 #-} {-# LINE 1321 "./src-ag/ExecutionPlan2Caml.ag" #-} rule611 = \ _from ((_lhsIavisituses) :: Map VisitIdentifier (Set Identifier)) child_ visit_ -> {-# LINE 1321 "./src-ag/ExecutionPlan2Caml.ag" #-} let convert attrs = Map.fromList [ (attrname False child_ attr, Just $ mkNonLocalAttr True child_ attr) | attr <- Set.elems attrs ] in Map.insert (stname child_ _from) Nothing $ convert $ maybe (error "Visit not found") id $ Map.lookup visit_ _lhsIavisituses {-# LINE 5013 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule612 #-} {-# LINE 1407 "./src-ag/ExecutionPlan2Caml.ag" #-} rule612 = \ ((_lhsIallFromToStates) :: Map VisitIdentifier (Int,Int)) visit_ -> {-# LINE 1407 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.findWithDefault (error "visit not in allFromToStates") visit_ _lhsIallFromToStates {-# LINE 5019 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule613 #-} rule613 = \ (_ :: ()) -> Set.empty {-# INLINE rule614 #-} rule614 = \ (_ :: ()) -> Map.empty {-# INLINE rule615 #-} rule615 = \ (_ :: ()) -> Map.empty {-# INLINE rule616 #-} rule616 = \ (_ :: ()) -> mempty {-# INLINE rule617 #-} rule617 = \ ((_lhsIindex) :: Int) -> _lhsIindex {-# INLINE rule618 #-} rule618 = \ ((_lhsIisLast) :: Bool) -> _lhsIisLast {-# INLINE rule619 #-} rule619 = \ ((_lhsIprevMaxSimRefs) :: Int) -> _lhsIprevMaxSimRefs {-# NOINLINE sem_VisitStep_PureGroup #-} sem_VisitStep_PureGroup :: T_VisitSteps -> (Bool) -> T_VisitStep sem_VisitStep_PureGroup arg_steps_ arg_ordered_ = T_VisitStep (return st50) where {-# NOINLINE st50 #-} st50 = let v49 :: T_VisitStep_v49 v49 = \ (T_VisitStep_vIn49 _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIfollow _lhsIindex _lhsIisLast _lhsIkind _lhsImrules _lhsIoptions _lhsIprevMaxSimRefs _lhsIruledefs _lhsIruleuses _lhsIuseParallel) -> ( let _stepsX53 = Control.Monad.Identity.runIdentity (attach_T_VisitSteps (arg_steps_)) (T_VisitSteps_vOut52 _stepsIdefs _stepsIerrors _stepsIindex _stepsIisLast _stepsIlazyIntras _stepsIprevMaxSimRefs _stepsIruleKinds _stepsIruleUsage _stepsIsem_steps _stepsIsize _stepsIuses _stepsIvisitKinds) = inv_VisitSteps_s53 _stepsX53 (T_VisitSteps_vIn52 _stepsOallFromToStates _stepsOallInitStates _stepsOallVisitKinds _stepsOallchildvisit _stepsOavisitdefs _stepsOavisituses _stepsOchildTypes _stepsOchildintros _stepsOfollow _stepsOindex _stepsOkind _stepsOmrules _stepsOoptions _stepsOprevMaxSimRefs _stepsOruledefs _stepsOruleuses _stepsOuseParallel) _stepsOkind = rule620 arg_ordered_ _lhsOlazyIntras :: Set String _lhsOlazyIntras = rule621 _stepsIdefs _stepsIlazyIntras arg_ordered_ _lhsOdefs :: Set String _lhsOdefs = rule622 _stepsIdefs _lhsOerrors :: Seq Error _lhsOerrors = rule623 _stepsIerrors _lhsOruleKinds :: Map Identifier (Set VisitKind) _lhsOruleKinds = rule624 _stepsIruleKinds _lhsOruleUsage :: Map Identifier Int _lhsOruleUsage = rule625 _stepsIruleUsage _lhsOsem_steps :: PP_Doc _lhsOsem_steps = rule626 _stepsIsem_steps _lhsOuses :: Map String (Maybe NonLocalAttr) _lhsOuses = rule627 _stepsIuses _lhsOvisitKinds :: Map VisitIdentifier VisitKind _lhsOvisitKinds = rule628 _stepsIvisitKinds _lhsOindex :: Int _lhsOindex = rule629 _stepsIindex _lhsOisLast :: Bool _lhsOisLast = rule630 _stepsIisLast _lhsOprevMaxSimRefs :: Int _lhsOprevMaxSimRefs = rule631 _stepsIprevMaxSimRefs _stepsOallFromToStates = rule632 _lhsIallFromToStates _stepsOallInitStates = rule633 _lhsIallInitStates _stepsOallVisitKinds = rule634 _lhsIallVisitKinds _stepsOallchildvisit = rule635 _lhsIallchildvisit _stepsOavisitdefs = rule636 _lhsIavisitdefs _stepsOavisituses = rule637 _lhsIavisituses _stepsOchildTypes = rule638 _lhsIchildTypes _stepsOchildintros = rule639 _lhsIchildintros _stepsOfollow = rule640 _lhsIfollow _stepsOindex = rule641 _lhsIindex _stepsOmrules = rule642 _lhsImrules _stepsOoptions = rule643 _lhsIoptions _stepsOprevMaxSimRefs = rule644 _lhsIprevMaxSimRefs _stepsOruledefs = rule645 _lhsIruledefs _stepsOruleuses = rule646 _lhsIruleuses _stepsOuseParallel = rule647 _lhsIuseParallel __result_ = T_VisitStep_vOut49 _lhsOdefs _lhsOerrors _lhsOindex _lhsOisLast _lhsOlazyIntras _lhsOprevMaxSimRefs _lhsOruleKinds _lhsOruleUsage _lhsOsem_steps _lhsOuses _lhsOvisitKinds in __result_ ) in C_VisitStep_s50 v49 {-# INLINE rule620 #-} {-# LINE 834 "./src-ag/ExecutionPlan2Caml.ag" #-} rule620 = \ ordered_ -> {-# LINE 834 "./src-ag/ExecutionPlan2Caml.ag" #-} VisitPure ordered_ {-# LINE 5097 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule621 #-} {-# LINE 1341 "./src-ag/ExecutionPlan2Caml.ag" #-} rule621 = \ ((_stepsIdefs) :: Set String) ((_stepsIlazyIntras) :: Set String) ordered_ -> {-# LINE 1341 "./src-ag/ExecutionPlan2Caml.ag" #-} if ordered_ then _stepsIlazyIntras else _stepsIdefs {-# LINE 5105 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule622 #-} rule622 = \ ((_stepsIdefs) :: Set String) -> _stepsIdefs {-# INLINE rule623 #-} rule623 = \ ((_stepsIerrors) :: Seq Error) -> _stepsIerrors {-# INLINE rule624 #-} rule624 = \ ((_stepsIruleKinds) :: Map Identifier (Set VisitKind)) -> _stepsIruleKinds {-# INLINE rule625 #-} rule625 = \ ((_stepsIruleUsage) :: Map Identifier Int) -> _stepsIruleUsage {-# INLINE rule626 #-} rule626 = \ ((_stepsIsem_steps) :: PP_Doc) -> _stepsIsem_steps {-# INLINE rule627 #-} rule627 = \ ((_stepsIuses) :: Map String (Maybe NonLocalAttr)) -> _stepsIuses {-# INLINE rule628 #-} rule628 = \ ((_stepsIvisitKinds) :: Map VisitIdentifier VisitKind) -> _stepsIvisitKinds {-# INLINE rule629 #-} rule629 = \ ((_stepsIindex) :: Int) -> _stepsIindex {-# INLINE rule630 #-} rule630 = \ ((_stepsIisLast) :: Bool) -> _stepsIisLast {-# INLINE rule631 #-} rule631 = \ ((_stepsIprevMaxSimRefs) :: Int) -> _stepsIprevMaxSimRefs {-# INLINE rule632 #-} rule632 = \ ((_lhsIallFromToStates) :: Map VisitIdentifier (Int,Int)) -> _lhsIallFromToStates {-# INLINE rule633 #-} rule633 = \ ((_lhsIallInitStates) :: Map NontermIdent Int) -> _lhsIallInitStates {-# INLINE rule634 #-} rule634 = \ ((_lhsIallVisitKinds) :: Map VisitIdentifier VisitKind) -> _lhsIallVisitKinds {-# INLINE rule635 #-} rule635 = \ ((_lhsIallchildvisit) :: Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) -> _lhsIallchildvisit {-# INLINE rule636 #-} rule636 = \ ((_lhsIavisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisitdefs {-# INLINE rule637 #-} rule637 = \ ((_lhsIavisituses) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisituses {-# INLINE rule638 #-} rule638 = \ ((_lhsIchildTypes) :: Map Identifier Type) -> _lhsIchildTypes {-# INLINE rule639 #-} rule639 = \ ((_lhsIchildintros) :: Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))) -> _lhsIchildintros {-# INLINE rule640 #-} rule640 = \ ((_lhsIfollow) :: PP_Doc) -> _lhsIfollow {-# INLINE rule641 #-} rule641 = \ ((_lhsIindex) :: Int) -> _lhsIindex {-# INLINE rule642 #-} rule642 = \ ((_lhsImrules) :: Map Identifier (VisitKind -> Either Error PP_Doc)) -> _lhsImrules {-# INLINE rule643 #-} rule643 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule644 #-} rule644 = \ ((_lhsIprevMaxSimRefs) :: Int) -> _lhsIprevMaxSimRefs {-# INLINE rule645 #-} rule645 = \ ((_lhsIruledefs) :: Map Identifier (Set String)) -> _lhsIruledefs {-# INLINE rule646 #-} rule646 = \ ((_lhsIruleuses) :: Map Identifier (Map String (Maybe NonLocalAttr))) -> _lhsIruleuses {-# INLINE rule647 #-} rule647 = \ ((_lhsIuseParallel) :: Bool) -> _lhsIuseParallel {-# NOINLINE sem_VisitStep_Sim #-} sem_VisitStep_Sim :: T_VisitSteps -> T_VisitStep sem_VisitStep_Sim arg_steps_ = T_VisitStep (return st50) where {-# NOINLINE st50 #-} st50 = let v49 :: T_VisitStep_v49 v49 = \ (T_VisitStep_vIn49 _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIfollow _lhsIindex _lhsIisLast _lhsIkind _lhsImrules _lhsIoptions _lhsIprevMaxSimRefs _lhsIruledefs _lhsIruleuses _lhsIuseParallel) -> ( let _stepsX53 = Control.Monad.Identity.runIdentity (attach_T_VisitSteps (arg_steps_)) (T_VisitSteps_vOut52 _stepsIdefs _stepsIerrors _stepsIindex _stepsIisLast _stepsIlazyIntras _stepsIprevMaxSimRefs _stepsIruleKinds _stepsIruleUsage _stepsIsem_steps _stepsIsize _stepsIuses _stepsIvisitKinds) = inv_VisitSteps_s53 _stepsX53 (T_VisitSteps_vIn52 _stepsOallFromToStates _stepsOallInitStates _stepsOallVisitKinds _stepsOallchildvisit _stepsOavisitdefs _stepsOavisituses _stepsOchildTypes _stepsOchildintros _stepsOfollow _stepsOindex _stepsOkind _stepsOmrules _stepsOoptions _stepsOprevMaxSimRefs _stepsOruledefs _stepsOruleuses _stepsOuseParallel) _stepsOindex = rule648 () _lhsOindex :: Int _lhsOindex = rule649 _lhsIindex _lhsOprevMaxSimRefs :: Int _lhsOprevMaxSimRefs = rule650 _lhsIprevMaxSimRefs _stepsIindex _useParallel _useParallel = rule651 _lhsIoptions _stepsIsize _lhsOdefs :: Set String _lhsOdefs = rule652 _stepsIdefs _lhsOerrors :: Seq Error _lhsOerrors = rule653 _stepsIerrors _lhsOlazyIntras :: Set String _lhsOlazyIntras = rule654 _stepsIlazyIntras _lhsOruleKinds :: Map Identifier (Set VisitKind) _lhsOruleKinds = rule655 _stepsIruleKinds _lhsOruleUsage :: Map Identifier Int _lhsOruleUsage = rule656 _stepsIruleUsage _lhsOsem_steps :: PP_Doc _lhsOsem_steps = rule657 _stepsIsem_steps _lhsOuses :: Map String (Maybe NonLocalAttr) _lhsOuses = rule658 _stepsIuses _lhsOvisitKinds :: Map VisitIdentifier VisitKind _lhsOvisitKinds = rule659 _stepsIvisitKinds _lhsOisLast :: Bool _lhsOisLast = rule660 _stepsIisLast _stepsOallFromToStates = rule661 _lhsIallFromToStates _stepsOallInitStates = rule662 _lhsIallInitStates _stepsOallVisitKinds = rule663 _lhsIallVisitKinds _stepsOallchildvisit = rule664 _lhsIallchildvisit _stepsOavisitdefs = rule665 _lhsIavisitdefs _stepsOavisituses = rule666 _lhsIavisituses _stepsOchildTypes = rule667 _lhsIchildTypes _stepsOchildintros = rule668 _lhsIchildintros _stepsOfollow = rule669 _lhsIfollow _stepsOkind = rule670 _lhsIkind _stepsOmrules = rule671 _lhsImrules _stepsOoptions = rule672 _lhsIoptions _stepsOprevMaxSimRefs = rule673 _lhsIprevMaxSimRefs _stepsOruledefs = rule674 _lhsIruledefs _stepsOruleuses = rule675 _lhsIruleuses _stepsOuseParallel = rule676 _useParallel __result_ = T_VisitStep_vOut49 _lhsOdefs _lhsOerrors _lhsOindex _lhsOisLast _lhsOlazyIntras _lhsOprevMaxSimRefs _lhsOruleKinds _lhsOruleUsage _lhsOsem_steps _lhsOuses _lhsOvisitKinds in __result_ ) in C_VisitStep_s50 v49 {-# INLINE rule648 #-} {-# LINE 883 "./src-ag/ExecutionPlan2Caml.ag" #-} rule648 = \ (_ :: ()) -> {-# LINE 883 "./src-ag/ExecutionPlan2Caml.ag" #-} 0 {-# LINE 5241 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule649 #-} {-# LINE 884 "./src-ag/ExecutionPlan2Caml.ag" #-} rule649 = \ ((_lhsIindex) :: Int) -> {-# LINE 884 "./src-ag/ExecutionPlan2Caml.ag" #-} _lhsIindex {-# LINE 5247 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule650 #-} {-# LINE 891 "./src-ag/ExecutionPlan2Caml.ag" #-} rule650 = \ ((_lhsIprevMaxSimRefs) :: Int) ((_stepsIindex) :: Int) _useParallel -> {-# LINE 891 "./src-ag/ExecutionPlan2Caml.ag" #-} if _useParallel then _lhsIprevMaxSimRefs `max` (_stepsIindex - 1) else _lhsIprevMaxSimRefs {-# LINE 5255 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule651 #-} {-# LINE 907 "./src-ag/ExecutionPlan2Caml.ag" #-} rule651 = \ ((_lhsIoptions) :: Options) ((_stepsIsize) :: Int) -> {-# LINE 907 "./src-ag/ExecutionPlan2Caml.ag" #-} parallelInvoke _lhsIoptions && _stepsIsize > 1 {-# LINE 5261 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule652 #-} rule652 = \ ((_stepsIdefs) :: Set String) -> _stepsIdefs {-# INLINE rule653 #-} rule653 = \ ((_stepsIerrors) :: Seq Error) -> _stepsIerrors {-# INLINE rule654 #-} rule654 = \ ((_stepsIlazyIntras) :: Set String) -> _stepsIlazyIntras {-# INLINE rule655 #-} rule655 = \ ((_stepsIruleKinds) :: Map Identifier (Set VisitKind)) -> _stepsIruleKinds {-# INLINE rule656 #-} rule656 = \ ((_stepsIruleUsage) :: Map Identifier Int) -> _stepsIruleUsage {-# INLINE rule657 #-} rule657 = \ ((_stepsIsem_steps) :: PP_Doc) -> _stepsIsem_steps {-# INLINE rule658 #-} rule658 = \ ((_stepsIuses) :: Map String (Maybe NonLocalAttr)) -> _stepsIuses {-# INLINE rule659 #-} rule659 = \ ((_stepsIvisitKinds) :: Map VisitIdentifier VisitKind) -> _stepsIvisitKinds {-# INLINE rule660 #-} rule660 = \ ((_stepsIisLast) :: Bool) -> _stepsIisLast {-# INLINE rule661 #-} rule661 = \ ((_lhsIallFromToStates) :: Map VisitIdentifier (Int,Int)) -> _lhsIallFromToStates {-# INLINE rule662 #-} rule662 = \ ((_lhsIallInitStates) :: Map NontermIdent Int) -> _lhsIallInitStates {-# INLINE rule663 #-} rule663 = \ ((_lhsIallVisitKinds) :: Map VisitIdentifier VisitKind) -> _lhsIallVisitKinds {-# INLINE rule664 #-} rule664 = \ ((_lhsIallchildvisit) :: Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) -> _lhsIallchildvisit {-# INLINE rule665 #-} rule665 = \ ((_lhsIavisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisitdefs {-# INLINE rule666 #-} rule666 = \ ((_lhsIavisituses) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisituses {-# INLINE rule667 #-} rule667 = \ ((_lhsIchildTypes) :: Map Identifier Type) -> _lhsIchildTypes {-# INLINE rule668 #-} rule668 = \ ((_lhsIchildintros) :: Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))) -> _lhsIchildintros {-# INLINE rule669 #-} rule669 = \ ((_lhsIfollow) :: PP_Doc) -> _lhsIfollow {-# INLINE rule670 #-} rule670 = \ ((_lhsIkind) :: VisitKind) -> _lhsIkind {-# INLINE rule671 #-} rule671 = \ ((_lhsImrules) :: Map Identifier (VisitKind -> Either Error PP_Doc)) -> _lhsImrules {-# INLINE rule672 #-} rule672 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule673 #-} rule673 = \ ((_lhsIprevMaxSimRefs) :: Int) -> _lhsIprevMaxSimRefs {-# INLINE rule674 #-} rule674 = \ ((_lhsIruledefs) :: Map Identifier (Set String)) -> _lhsIruledefs {-# INLINE rule675 #-} rule675 = \ ((_lhsIruleuses) :: Map Identifier (Map String (Maybe NonLocalAttr))) -> _lhsIruleuses {-# INLINE rule676 #-} rule676 = \ _useParallel -> _useParallel {-# NOINLINE sem_VisitStep_ChildIntro #-} sem_VisitStep_ChildIntro :: (Identifier) -> T_VisitStep sem_VisitStep_ChildIntro arg_child_ = T_VisitStep (return st50) where {-# NOINLINE st50 #-} st50 = let v49 :: T_VisitStep_v49 v49 = \ (T_VisitStep_vIn49 _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIfollow _lhsIindex _lhsIisLast _lhsIkind _lhsImrules _lhsIoptions _lhsIprevMaxSimRefs _lhsIruledefs _lhsIruleuses _lhsIuseParallel) -> ( let _attachItf = rule677 _lhsIchildintros arg_child_ _lhsOerrors :: Seq Error _lhsOdefs :: Set String _lhsOuses :: Map String (Maybe NonLocalAttr) (_lhsOerrors,_sem_steps,_lhsOdefs,_lhsOuses) = rule678 _attachItf _lhsIkind _lhsOsem_steps :: PP_Doc _lhsOsem_steps = rule679 _lhsIfollow _sem_steps _lhsOlazyIntras :: Set String _lhsOlazyIntras = rule680 () _lhsOruleKinds :: Map Identifier (Set VisitKind) _lhsOruleKinds = rule681 () _lhsOruleUsage :: Map Identifier Int _lhsOruleUsage = rule682 () _lhsOvisitKinds :: Map VisitIdentifier VisitKind _lhsOvisitKinds = rule683 () _lhsOindex :: Int _lhsOindex = rule684 _lhsIindex _lhsOisLast :: Bool _lhsOisLast = rule685 _lhsIisLast _lhsOprevMaxSimRefs :: Int _lhsOprevMaxSimRefs = rule686 _lhsIprevMaxSimRefs __result_ = T_VisitStep_vOut49 _lhsOdefs _lhsOerrors _lhsOindex _lhsOisLast _lhsOlazyIntras _lhsOprevMaxSimRefs _lhsOruleKinds _lhsOruleUsage _lhsOsem_steps _lhsOuses _lhsOvisitKinds in __result_ ) in C_VisitStep_s50 v49 {-# INLINE rule677 #-} {-# LINE 852 "./src-ag/ExecutionPlan2Caml.ag" #-} rule677 = \ ((_lhsIchildintros) :: Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))) child_ -> {-# LINE 852 "./src-ag/ExecutionPlan2Caml.ag" #-} Map.findWithDefault (error $ "Child " ++ show child_ ++ " not found") child_ _lhsIchildintros {-# LINE 5373 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule678 #-} {-# LINE 854 "./src-ag/ExecutionPlan2Caml.ag" #-} rule678 = \ _attachItf ((_lhsIkind) :: VisitKind) -> {-# LINE 854 "./src-ag/ExecutionPlan2Caml.ag" #-} case _attachItf _lhsIkind of Left e -> (Seq.singleton e, empty, Set.empty, Map.empty) Right (code, defs, uses) -> (Seq.empty, code, defs, uses) {-# LINE 5381 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule679 #-} {-# LINE 857 "./src-ag/ExecutionPlan2Caml.ag" #-} rule679 = \ ((_lhsIfollow) :: PP_Doc) _sem_steps -> {-# LINE 857 "./src-ag/ExecutionPlan2Caml.ag" #-} _sem_steps >-< _lhsIfollow {-# LINE 5387 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule680 #-} rule680 = \ (_ :: ()) -> Set.empty {-# INLINE rule681 #-} rule681 = \ (_ :: ()) -> Map.empty {-# INLINE rule682 #-} rule682 = \ (_ :: ()) -> Map.empty {-# INLINE rule683 #-} rule683 = \ (_ :: ()) -> mempty {-# INLINE rule684 #-} rule684 = \ ((_lhsIindex) :: Int) -> _lhsIindex {-# INLINE rule685 #-} rule685 = \ ((_lhsIisLast) :: Bool) -> _lhsIisLast {-# INLINE rule686 #-} rule686 = \ ((_lhsIprevMaxSimRefs) :: Int) -> _lhsIprevMaxSimRefs -- VisitSteps -------------------------------------------------- -- wrapper data Inh_VisitSteps = Inh_VisitSteps { allFromToStates_Inh_VisitSteps :: (Map VisitIdentifier (Int,Int)), allInitStates_Inh_VisitSteps :: (Map NontermIdent Int), allVisitKinds_Inh_VisitSteps :: (Map VisitIdentifier VisitKind), allchildvisit_Inh_VisitSteps :: (Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)), avisitdefs_Inh_VisitSteps :: (Map VisitIdentifier (Set Identifier)), avisituses_Inh_VisitSteps :: (Map VisitIdentifier (Set Identifier)), childTypes_Inh_VisitSteps :: (Map Identifier Type), childintros_Inh_VisitSteps :: (Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))), follow_Inh_VisitSteps :: (PP_Doc), index_Inh_VisitSteps :: (Int), kind_Inh_VisitSteps :: (VisitKind), mrules_Inh_VisitSteps :: (Map Identifier (VisitKind -> Either Error PP_Doc)), options_Inh_VisitSteps :: (Options), prevMaxSimRefs_Inh_VisitSteps :: (Int), ruledefs_Inh_VisitSteps :: (Map Identifier (Set String)), ruleuses_Inh_VisitSteps :: (Map Identifier (Map String (Maybe NonLocalAttr))), useParallel_Inh_VisitSteps :: (Bool) } data Syn_VisitSteps = Syn_VisitSteps { defs_Syn_VisitSteps :: (Set String), errors_Syn_VisitSteps :: (Seq Error), index_Syn_VisitSteps :: (Int), isLast_Syn_VisitSteps :: (Bool), lazyIntras_Syn_VisitSteps :: (Set String), prevMaxSimRefs_Syn_VisitSteps :: (Int), ruleKinds_Syn_VisitSteps :: (Map Identifier (Set VisitKind)), ruleUsage_Syn_VisitSteps :: (Map Identifier Int), sem_steps_Syn_VisitSteps :: (PP_Doc), size_Syn_VisitSteps :: (Int), uses_Syn_VisitSteps :: (Map String (Maybe NonLocalAttr)), visitKinds_Syn_VisitSteps :: (Map VisitIdentifier VisitKind) } {-# INLINABLE wrap_VisitSteps #-} wrap_VisitSteps :: T_VisitSteps -> Inh_VisitSteps -> (Syn_VisitSteps ) wrap_VisitSteps (T_VisitSteps act) (Inh_VisitSteps _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIfollow _lhsIindex _lhsIkind _lhsImrules _lhsIoptions _lhsIprevMaxSimRefs _lhsIruledefs _lhsIruleuses _lhsIuseParallel) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_VisitSteps_vIn52 _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIfollow _lhsIindex _lhsIkind _lhsImrules _lhsIoptions _lhsIprevMaxSimRefs _lhsIruledefs _lhsIruleuses _lhsIuseParallel (T_VisitSteps_vOut52 _lhsOdefs _lhsOerrors _lhsOindex _lhsOisLast _lhsOlazyIntras _lhsOprevMaxSimRefs _lhsOruleKinds _lhsOruleUsage _lhsOsem_steps _lhsOsize _lhsOuses _lhsOvisitKinds) <- return (inv_VisitSteps_s53 sem arg) return (Syn_VisitSteps _lhsOdefs _lhsOerrors _lhsOindex _lhsOisLast _lhsOlazyIntras _lhsOprevMaxSimRefs _lhsOruleKinds _lhsOruleUsage _lhsOsem_steps _lhsOsize _lhsOuses _lhsOvisitKinds) ) -- cata {-# NOINLINE sem_VisitSteps #-} sem_VisitSteps :: VisitSteps -> T_VisitSteps sem_VisitSteps list = Prelude.foldr sem_VisitSteps_Cons sem_VisitSteps_Nil (Prelude.map sem_VisitStep list) -- semantic domain newtype T_VisitSteps = T_VisitSteps { attach_T_VisitSteps :: Identity (T_VisitSteps_s53 ) } newtype T_VisitSteps_s53 = C_VisitSteps_s53 { inv_VisitSteps_s53 :: (T_VisitSteps_v52 ) } data T_VisitSteps_s54 = C_VisitSteps_s54 type T_VisitSteps_v52 = (T_VisitSteps_vIn52 ) -> (T_VisitSteps_vOut52 ) data T_VisitSteps_vIn52 = T_VisitSteps_vIn52 (Map VisitIdentifier (Int,Int)) (Map NontermIdent Int) (Map VisitIdentifier VisitKind) (Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) (Map VisitIdentifier (Set Identifier)) (Map VisitIdentifier (Set Identifier)) (Map Identifier Type) (Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))) (PP_Doc) (Int) (VisitKind) (Map Identifier (VisitKind -> Either Error PP_Doc)) (Options) (Int) (Map Identifier (Set String)) (Map Identifier (Map String (Maybe NonLocalAttr))) (Bool) data T_VisitSteps_vOut52 = T_VisitSteps_vOut52 (Set String) (Seq Error) (Int) (Bool) (Set String) (Int) (Map Identifier (Set VisitKind)) (Map Identifier Int) (PP_Doc) (Int) (Map String (Maybe NonLocalAttr)) (Map VisitIdentifier VisitKind) {-# NOINLINE sem_VisitSteps_Cons #-} sem_VisitSteps_Cons :: T_VisitStep -> T_VisitSteps -> T_VisitSteps sem_VisitSteps_Cons arg_hd_ arg_tl_ = T_VisitSteps (return st53) where {-# NOINLINE st53 #-} st53 = let v52 :: T_VisitSteps_v52 v52 = \ (T_VisitSteps_vIn52 _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIfollow _lhsIindex _lhsIkind _lhsImrules _lhsIoptions _lhsIprevMaxSimRefs _lhsIruledefs _lhsIruleuses _lhsIuseParallel) -> ( let _hdX50 = Control.Monad.Identity.runIdentity (attach_T_VisitStep (arg_hd_)) _tlX53 = Control.Monad.Identity.runIdentity (attach_T_VisitSteps (arg_tl_)) (T_VisitStep_vOut49 _hdIdefs _hdIerrors _hdIindex _hdIisLast _hdIlazyIntras _hdIprevMaxSimRefs _hdIruleKinds _hdIruleUsage _hdIsem_steps _hdIuses _hdIvisitKinds) = inv_VisitStep_s50 _hdX50 (T_VisitStep_vIn49 _hdOallFromToStates _hdOallInitStates _hdOallVisitKinds _hdOallchildvisit _hdOavisitdefs _hdOavisituses _hdOchildTypes _hdOchildintros _hdOfollow _hdOindex _hdOisLast _hdOkind _hdOmrules _hdOoptions _hdOprevMaxSimRefs _hdOruledefs _hdOruleuses _hdOuseParallel) (T_VisitSteps_vOut52 _tlIdefs _tlIerrors _tlIindex _tlIisLast _tlIlazyIntras _tlIprevMaxSimRefs _tlIruleKinds _tlIruleUsage _tlIsem_steps _tlIsize _tlIuses _tlIvisitKinds) = inv_VisitSteps_s53 _tlX53 (T_VisitSteps_vIn52 _tlOallFromToStates _tlOallInitStates _tlOallVisitKinds _tlOallchildvisit _tlOavisitdefs _tlOavisituses _tlOchildTypes _tlOchildintros _tlOfollow _tlOindex _tlOkind _tlOmrules _tlOoptions _tlOprevMaxSimRefs _tlOruledefs _tlOruleuses _tlOuseParallel) _hdOfollow = rule687 _tlIsem_steps _lhsOsem_steps :: PP_Doc _lhsOsem_steps = rule688 _hdIsem_steps _lhsOsize :: Int _lhsOsize = rule689 _tlIsize _hdOindex = rule690 _lhsIindex _tlOindex = rule691 _lhsIindex _lhsOindex :: Int _lhsOindex = rule692 _tlIindex _lhsOisLast :: Bool _lhsOisLast = rule693 () _hdOisLast = rule694 _tlIisLast _lhsOdefs :: Set String _lhsOdefs = rule695 _hdIdefs _tlIdefs _lhsOerrors :: Seq Error _lhsOerrors = rule696 _hdIerrors _tlIerrors _lhsOlazyIntras :: Set String _lhsOlazyIntras = rule697 _hdIlazyIntras _tlIlazyIntras _lhsOruleKinds :: Map Identifier (Set VisitKind) _lhsOruleKinds = rule698 _hdIruleKinds _tlIruleKinds _lhsOruleUsage :: Map Identifier Int _lhsOruleUsage = rule699 _hdIruleUsage _tlIruleUsage _lhsOuses :: Map String (Maybe NonLocalAttr) _lhsOuses = rule700 _hdIuses _tlIuses _lhsOvisitKinds :: Map VisitIdentifier VisitKind _lhsOvisitKinds = rule701 _hdIvisitKinds _tlIvisitKinds _lhsOprevMaxSimRefs :: Int _lhsOprevMaxSimRefs = rule702 _tlIprevMaxSimRefs _hdOallFromToStates = rule703 _lhsIallFromToStates _hdOallInitStates = rule704 _lhsIallInitStates _hdOallVisitKinds = rule705 _lhsIallVisitKinds _hdOallchildvisit = rule706 _lhsIallchildvisit _hdOavisitdefs = rule707 _lhsIavisitdefs _hdOavisituses = rule708 _lhsIavisituses _hdOchildTypes = rule709 _lhsIchildTypes _hdOchildintros = rule710 _lhsIchildintros _hdOkind = rule711 _lhsIkind _hdOmrules = rule712 _lhsImrules _hdOoptions = rule713 _lhsIoptions _hdOprevMaxSimRefs = rule714 _lhsIprevMaxSimRefs _hdOruledefs = rule715 _lhsIruledefs _hdOruleuses = rule716 _lhsIruleuses _hdOuseParallel = rule717 _lhsIuseParallel _tlOallFromToStates = rule718 _lhsIallFromToStates _tlOallInitStates = rule719 _lhsIallInitStates _tlOallVisitKinds = rule720 _lhsIallVisitKinds _tlOallchildvisit = rule721 _lhsIallchildvisit _tlOavisitdefs = rule722 _lhsIavisitdefs _tlOavisituses = rule723 _lhsIavisituses _tlOchildTypes = rule724 _lhsIchildTypes _tlOchildintros = rule725 _lhsIchildintros _tlOfollow = rule726 _lhsIfollow _tlOkind = rule727 _lhsIkind _tlOmrules = rule728 _lhsImrules _tlOoptions = rule729 _lhsIoptions _tlOprevMaxSimRefs = rule730 _hdIprevMaxSimRefs _tlOruledefs = rule731 _lhsIruledefs _tlOruleuses = rule732 _lhsIruleuses _tlOuseParallel = rule733 _lhsIuseParallel __result_ = T_VisitSteps_vOut52 _lhsOdefs _lhsOerrors _lhsOindex _lhsOisLast _lhsOlazyIntras _lhsOprevMaxSimRefs _lhsOruleKinds _lhsOruleUsage _lhsOsem_steps _lhsOsize _lhsOuses _lhsOvisitKinds in __result_ ) in C_VisitSteps_s53 v52 {-# INLINE rule687 #-} {-# LINE 842 "./src-ag/ExecutionPlan2Caml.ag" #-} rule687 = \ ((_tlIsem_steps) :: PP_Doc) -> {-# LINE 842 "./src-ag/ExecutionPlan2Caml.ag" #-} _tlIsem_steps {-# LINE 5518 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule688 #-} {-# LINE 843 "./src-ag/ExecutionPlan2Caml.ag" #-} rule688 = \ ((_hdIsem_steps) :: PP_Doc) -> {-# LINE 843 "./src-ag/ExecutionPlan2Caml.ag" #-} _hdIsem_steps {-# LINE 5524 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule689 #-} {-# LINE 874 "./src-ag/ExecutionPlan2Caml.ag" #-} rule689 = \ ((_tlIsize) :: Int) -> {-# LINE 874 "./src-ag/ExecutionPlan2Caml.ag" #-} 1 + _tlIsize {-# LINE 5530 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule690 #-} {-# LINE 879 "./src-ag/ExecutionPlan2Caml.ag" #-} rule690 = \ ((_lhsIindex) :: Int) -> {-# LINE 879 "./src-ag/ExecutionPlan2Caml.ag" #-} _lhsIindex {-# LINE 5536 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule691 #-} {-# LINE 880 "./src-ag/ExecutionPlan2Caml.ag" #-} rule691 = \ ((_lhsIindex) :: Int) -> {-# LINE 880 "./src-ag/ExecutionPlan2Caml.ag" #-} 1 + _lhsIindex {-# LINE 5542 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule692 #-} {-# LINE 881 "./src-ag/ExecutionPlan2Caml.ag" #-} rule692 = \ ((_tlIindex) :: Int) -> {-# LINE 881 "./src-ag/ExecutionPlan2Caml.ag" #-} _tlIindex {-# LINE 5548 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule693 #-} {-# LINE 900 "./src-ag/ExecutionPlan2Caml.ag" #-} rule693 = \ (_ :: ()) -> {-# LINE 900 "./src-ag/ExecutionPlan2Caml.ag" #-} False {-# LINE 5554 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule694 #-} {-# LINE 901 "./src-ag/ExecutionPlan2Caml.ag" #-} rule694 = \ ((_tlIisLast) :: Bool) -> {-# LINE 901 "./src-ag/ExecutionPlan2Caml.ag" #-} _tlIisLast {-# LINE 5560 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule695 #-} rule695 = \ ((_hdIdefs) :: Set String) ((_tlIdefs) :: Set String) -> _hdIdefs `Set.union` _tlIdefs {-# INLINE rule696 #-} rule696 = \ ((_hdIerrors) :: Seq Error) ((_tlIerrors) :: Seq Error) -> _hdIerrors Seq.>< _tlIerrors {-# INLINE rule697 #-} rule697 = \ ((_hdIlazyIntras) :: Set String) ((_tlIlazyIntras) :: Set String) -> _hdIlazyIntras `Set.union` _tlIlazyIntras {-# INLINE rule698 #-} rule698 = \ ((_hdIruleKinds) :: Map Identifier (Set VisitKind)) ((_tlIruleKinds) :: Map Identifier (Set VisitKind)) -> _hdIruleKinds `unionWithMappend` _tlIruleKinds {-# INLINE rule699 #-} rule699 = \ ((_hdIruleUsage) :: Map Identifier Int) ((_tlIruleUsage) :: Map Identifier Int) -> _hdIruleUsage `unionWithSum` _tlIruleUsage {-# INLINE rule700 #-} rule700 = \ ((_hdIuses) :: Map String (Maybe NonLocalAttr)) ((_tlIuses) :: Map String (Maybe NonLocalAttr)) -> _hdIuses `Map.union` _tlIuses {-# INLINE rule701 #-} rule701 = \ ((_hdIvisitKinds) :: Map VisitIdentifier VisitKind) ((_tlIvisitKinds) :: Map VisitIdentifier VisitKind) -> _hdIvisitKinds `mappend` _tlIvisitKinds {-# INLINE rule702 #-} rule702 = \ ((_tlIprevMaxSimRefs) :: Int) -> _tlIprevMaxSimRefs {-# INLINE rule703 #-} rule703 = \ ((_lhsIallFromToStates) :: Map VisitIdentifier (Int,Int)) -> _lhsIallFromToStates {-# INLINE rule704 #-} rule704 = \ ((_lhsIallInitStates) :: Map NontermIdent Int) -> _lhsIallInitStates {-# INLINE rule705 #-} rule705 = \ ((_lhsIallVisitKinds) :: Map VisitIdentifier VisitKind) -> _lhsIallVisitKinds {-# INLINE rule706 #-} rule706 = \ ((_lhsIallchildvisit) :: Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) -> _lhsIallchildvisit {-# INLINE rule707 #-} rule707 = \ ((_lhsIavisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisitdefs {-# INLINE rule708 #-} rule708 = \ ((_lhsIavisituses) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisituses {-# INLINE rule709 #-} rule709 = \ ((_lhsIchildTypes) :: Map Identifier Type) -> _lhsIchildTypes {-# INLINE rule710 #-} rule710 = \ ((_lhsIchildintros) :: Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))) -> _lhsIchildintros {-# INLINE rule711 #-} rule711 = \ ((_lhsIkind) :: VisitKind) -> _lhsIkind {-# INLINE rule712 #-} rule712 = \ ((_lhsImrules) :: Map Identifier (VisitKind -> Either Error PP_Doc)) -> _lhsImrules {-# INLINE rule713 #-} rule713 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule714 #-} rule714 = \ ((_lhsIprevMaxSimRefs) :: Int) -> _lhsIprevMaxSimRefs {-# INLINE rule715 #-} rule715 = \ ((_lhsIruledefs) :: Map Identifier (Set String)) -> _lhsIruledefs {-# INLINE rule716 #-} rule716 = \ ((_lhsIruleuses) :: Map Identifier (Map String (Maybe NonLocalAttr))) -> _lhsIruleuses {-# INLINE rule717 #-} rule717 = \ ((_lhsIuseParallel) :: Bool) -> _lhsIuseParallel {-# INLINE rule718 #-} rule718 = \ ((_lhsIallFromToStates) :: Map VisitIdentifier (Int,Int)) -> _lhsIallFromToStates {-# INLINE rule719 #-} rule719 = \ ((_lhsIallInitStates) :: Map NontermIdent Int) -> _lhsIallInitStates {-# INLINE rule720 #-} rule720 = \ ((_lhsIallVisitKinds) :: Map VisitIdentifier VisitKind) -> _lhsIallVisitKinds {-# INLINE rule721 #-} rule721 = \ ((_lhsIallchildvisit) :: Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) -> _lhsIallchildvisit {-# INLINE rule722 #-} rule722 = \ ((_lhsIavisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisitdefs {-# INLINE rule723 #-} rule723 = \ ((_lhsIavisituses) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisituses {-# INLINE rule724 #-} rule724 = \ ((_lhsIchildTypes) :: Map Identifier Type) -> _lhsIchildTypes {-# INLINE rule725 #-} rule725 = \ ((_lhsIchildintros) :: Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))) -> _lhsIchildintros {-# INLINE rule726 #-} rule726 = \ ((_lhsIfollow) :: PP_Doc) -> _lhsIfollow {-# INLINE rule727 #-} rule727 = \ ((_lhsIkind) :: VisitKind) -> _lhsIkind {-# INLINE rule728 #-} rule728 = \ ((_lhsImrules) :: Map Identifier (VisitKind -> Either Error PP_Doc)) -> _lhsImrules {-# INLINE rule729 #-} rule729 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule730 #-} rule730 = \ ((_hdIprevMaxSimRefs) :: Int) -> _hdIprevMaxSimRefs {-# INLINE rule731 #-} rule731 = \ ((_lhsIruledefs) :: Map Identifier (Set String)) -> _lhsIruledefs {-# INLINE rule732 #-} rule732 = \ ((_lhsIruleuses) :: Map Identifier (Map String (Maybe NonLocalAttr))) -> _lhsIruleuses {-# INLINE rule733 #-} rule733 = \ ((_lhsIuseParallel) :: Bool) -> _lhsIuseParallel {-# NOINLINE sem_VisitSteps_Nil #-} sem_VisitSteps_Nil :: T_VisitSteps sem_VisitSteps_Nil = T_VisitSteps (return st53) where {-# NOINLINE st53 #-} st53 = let v52 :: T_VisitSteps_v52 v52 = \ (T_VisitSteps_vIn52 _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIfollow _lhsIindex _lhsIkind _lhsImrules _lhsIoptions _lhsIprevMaxSimRefs _lhsIruledefs _lhsIruleuses _lhsIuseParallel) -> ( let _lhsOsem_steps :: PP_Doc _lhsOsem_steps = rule734 _lhsIfollow _lhsOsize :: Int _lhsOsize = rule735 () _lhsOisLast :: Bool _lhsOisLast = rule736 () _lhsOdefs :: Set String _lhsOdefs = rule737 () _lhsOerrors :: Seq Error _lhsOerrors = rule738 () _lhsOlazyIntras :: Set String _lhsOlazyIntras = rule739 () _lhsOruleKinds :: Map Identifier (Set VisitKind) _lhsOruleKinds = rule740 () _lhsOruleUsage :: Map Identifier Int _lhsOruleUsage = rule741 () _lhsOuses :: Map String (Maybe NonLocalAttr) _lhsOuses = rule742 () _lhsOvisitKinds :: Map VisitIdentifier VisitKind _lhsOvisitKinds = rule743 () _lhsOindex :: Int _lhsOindex = rule744 _lhsIindex _lhsOprevMaxSimRefs :: Int _lhsOprevMaxSimRefs = rule745 _lhsIprevMaxSimRefs __result_ = T_VisitSteps_vOut52 _lhsOdefs _lhsOerrors _lhsOindex _lhsOisLast _lhsOlazyIntras _lhsOprevMaxSimRefs _lhsOruleKinds _lhsOruleUsage _lhsOsem_steps _lhsOsize _lhsOuses _lhsOvisitKinds in __result_ ) in C_VisitSteps_s53 v52 {-# INLINE rule734 #-} {-# LINE 844 "./src-ag/ExecutionPlan2Caml.ag" #-} rule734 = \ ((_lhsIfollow) :: PP_Doc) -> {-# LINE 844 "./src-ag/ExecutionPlan2Caml.ag" #-} _lhsIfollow {-# LINE 5717 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule735 #-} {-# LINE 873 "./src-ag/ExecutionPlan2Caml.ag" #-} rule735 = \ (_ :: ()) -> {-# LINE 873 "./src-ag/ExecutionPlan2Caml.ag" #-} 0 {-# LINE 5723 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule736 #-} {-# LINE 899 "./src-ag/ExecutionPlan2Caml.ag" #-} rule736 = \ (_ :: ()) -> {-# LINE 899 "./src-ag/ExecutionPlan2Caml.ag" #-} True {-# LINE 5729 "dist/build/ExecutionPlan2Caml.hs"#-} {-# INLINE rule737 #-} rule737 = \ (_ :: ()) -> Set.empty {-# INLINE rule738 #-} rule738 = \ (_ :: ()) -> Seq.empty {-# INLINE rule739 #-} rule739 = \ (_ :: ()) -> Set.empty {-# INLINE rule740 #-} rule740 = \ (_ :: ()) -> Map.empty {-# INLINE rule741 #-} rule741 = \ (_ :: ()) -> Map.empty {-# INLINE rule742 #-} rule742 = \ (_ :: ()) -> Map.empty {-# INLINE rule743 #-} rule743 = \ (_ :: ()) -> mempty {-# INLINE rule744 #-} rule744 = \ ((_lhsIindex) :: Int) -> _lhsIindex {-# INLINE rule745 #-} rule745 = \ ((_lhsIprevMaxSimRefs) :: Int) -> _lhsIprevMaxSimRefs -- Visits ------------------------------------------------------ -- wrapper data Inh_Visits = Inh_Visits { allFromToStates_Inh_Visits :: (Map VisitIdentifier (Int,Int)), allInhmap_Inh_Visits :: (Map NontermIdent Attributes), allInitStates_Inh_Visits :: (Map NontermIdent Int), allSynmap_Inh_Visits :: (Map NontermIdent Attributes), allVisitKinds_Inh_Visits :: (Map VisitIdentifier VisitKind), allchildvisit_Inh_Visits :: (Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)), allintramap_Inh_Visits :: (Map StateIdentifier (Map String (Maybe NonLocalAttr))), avisitdefs_Inh_Visits :: (Map VisitIdentifier (Set Identifier)), avisituses_Inh_Visits :: (Map VisitIdentifier (Set Identifier)), childTypes_Inh_Visits :: (Map Identifier Type), childintros_Inh_Visits :: (Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))), con_Inh_Visits :: (ConstructorIdent), inhmap_Inh_Visits :: (Attributes), mrules_Inh_Visits :: (Map Identifier (VisitKind -> Either Error PP_Doc)), nextVisits_Inh_Visits :: (Map StateIdentifier StateCtx), nt_Inh_Visits :: (NontermIdent), options_Inh_Visits :: (Options), params_Inh_Visits :: ([Identifier]), prevVisits_Inh_Visits :: (Map StateIdentifier StateCtx), ruledefs_Inh_Visits :: (Map Identifier (Set String)), ruleuses_Inh_Visits :: (Map Identifier (Map String (Maybe NonLocalAttr))), synmap_Inh_Visits :: (Attributes), terminaldefs_Inh_Visits :: (Set String) } data Syn_Visits = Syn_Visits { allvisits_Syn_Visits :: ([VisitStateState]), childvisit_Syn_Visits :: (Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)), errors_Syn_Visits :: (Seq Error), fromToStates_Syn_Visits :: (Map VisitIdentifier (Int,Int)), intramap_Syn_Visits :: (Map StateIdentifier (Map String (Maybe NonLocalAttr))), lazyIntras_Syn_Visits :: (Set String), ruleKinds_Syn_Visits :: (Map Identifier (Set VisitKind)), ruleUsage_Syn_Visits :: (Map Identifier Int), sem_visit_Syn_Visits :: ( [(StateIdentifier,PP_Doc)] ), t_visits_Syn_Visits :: (PP_Doc), visitKinds_Syn_Visits :: (Map VisitIdentifier VisitKind), visitdefs_Syn_Visits :: (Map VisitIdentifier (Set Identifier)), visituses_Syn_Visits :: (Map VisitIdentifier (Set Identifier)) } {-# INLINABLE wrap_Visits #-} wrap_Visits :: T_Visits -> Inh_Visits -> (Syn_Visits ) wrap_Visits (T_Visits act) (Inh_Visits _lhsIallFromToStates _lhsIallInhmap _lhsIallInitStates _lhsIallSynmap _lhsIallVisitKinds _lhsIallchildvisit _lhsIallintramap _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIcon _lhsIinhmap _lhsImrules _lhsInextVisits _lhsInt _lhsIoptions _lhsIparams _lhsIprevVisits _lhsIruledefs _lhsIruleuses _lhsIsynmap _lhsIterminaldefs) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Visits_vIn55 _lhsIallFromToStates _lhsIallInhmap _lhsIallInitStates _lhsIallSynmap _lhsIallVisitKinds _lhsIallchildvisit _lhsIallintramap _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIcon _lhsIinhmap _lhsImrules _lhsInextVisits _lhsInt _lhsIoptions _lhsIparams _lhsIprevVisits _lhsIruledefs _lhsIruleuses _lhsIsynmap _lhsIterminaldefs (T_Visits_vOut55 _lhsOallvisits _lhsOchildvisit _lhsOerrors _lhsOfromToStates _lhsOintramap _lhsOlazyIntras _lhsOruleKinds _lhsOruleUsage _lhsOsem_visit _lhsOt_visits _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses) <- return (inv_Visits_s56 sem arg) return (Syn_Visits _lhsOallvisits _lhsOchildvisit _lhsOerrors _lhsOfromToStates _lhsOintramap _lhsOlazyIntras _lhsOruleKinds _lhsOruleUsage _lhsOsem_visit _lhsOt_visits _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses) ) -- cata {-# NOINLINE sem_Visits #-} sem_Visits :: Visits -> T_Visits sem_Visits list = Prelude.foldr sem_Visits_Cons sem_Visits_Nil (Prelude.map sem_Visit list) -- semantic domain newtype T_Visits = T_Visits { attach_T_Visits :: Identity (T_Visits_s56 ) } newtype T_Visits_s56 = C_Visits_s56 { inv_Visits_s56 :: (T_Visits_v55 ) } data T_Visits_s57 = C_Visits_s57 type T_Visits_v55 = (T_Visits_vIn55 ) -> (T_Visits_vOut55 ) data T_Visits_vIn55 = T_Visits_vIn55 (Map VisitIdentifier (Int,Int)) (Map NontermIdent Attributes) (Map NontermIdent Int) (Map NontermIdent Attributes) (Map VisitIdentifier VisitKind) (Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) (Map StateIdentifier (Map String (Maybe NonLocalAttr))) (Map VisitIdentifier (Set Identifier)) (Map VisitIdentifier (Set Identifier)) (Map Identifier Type) (Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))) (ConstructorIdent) (Attributes) (Map Identifier (VisitKind -> Either Error PP_Doc)) (Map StateIdentifier StateCtx) (NontermIdent) (Options) ([Identifier]) (Map StateIdentifier StateCtx) (Map Identifier (Set String)) (Map Identifier (Map String (Maybe NonLocalAttr))) (Attributes) (Set String) data T_Visits_vOut55 = T_Visits_vOut55 ([VisitStateState]) (Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) (Seq Error) (Map VisitIdentifier (Int,Int)) (Map StateIdentifier (Map String (Maybe NonLocalAttr))) (Set String) (Map Identifier (Set VisitKind)) (Map Identifier Int) ( [(StateIdentifier,PP_Doc)] ) (PP_Doc) (Map VisitIdentifier VisitKind) (Map VisitIdentifier (Set Identifier)) (Map VisitIdentifier (Set Identifier)) {-# NOINLINE sem_Visits_Cons #-} sem_Visits_Cons :: T_Visit -> T_Visits -> T_Visits sem_Visits_Cons arg_hd_ arg_tl_ = T_Visits (return st56) where {-# NOINLINE st56 #-} st56 = let v55 :: T_Visits_v55 v55 = \ (T_Visits_vIn55 _lhsIallFromToStates _lhsIallInhmap _lhsIallInitStates _lhsIallSynmap _lhsIallVisitKinds _lhsIallchildvisit _lhsIallintramap _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIcon _lhsIinhmap _lhsImrules _lhsInextVisits _lhsInt _lhsIoptions _lhsIparams _lhsIprevVisits _lhsIruledefs _lhsIruleuses _lhsIsynmap _lhsIterminaldefs) -> ( let _hdX47 = Control.Monad.Identity.runIdentity (attach_T_Visit (arg_hd_)) _tlX56 = Control.Monad.Identity.runIdentity (attach_T_Visits (arg_tl_)) (T_Visit_vOut46 _hdIallvisits _hdIchildvisit _hdIerrors _hdIfromToStates _hdIintramap _hdIlazyIntras _hdIruleKinds _hdIruleUsage _hdIsem_visit _hdIt_visits _hdIvisitKinds _hdIvisitdefs _hdIvisituses) = inv_Visit_s47 _hdX47 (T_Visit_vIn46 _hdOallFromToStates _hdOallInhmap _hdOallInitStates _hdOallSynmap _hdOallVisitKinds _hdOallchildvisit _hdOallintramap _hdOavisitdefs _hdOavisituses _hdOchildTypes _hdOchildintros _hdOcon _hdOinhmap _hdOmrules _hdOnextVisits _hdOnt _hdOoptions _hdOparams _hdOprevVisits _hdOruledefs _hdOruleuses _hdOsynmap _hdOterminaldefs) (T_Visits_vOut55 _tlIallvisits _tlIchildvisit _tlIerrors _tlIfromToStates _tlIintramap _tlIlazyIntras _tlIruleKinds _tlIruleUsage _tlIsem_visit _tlIt_visits _tlIvisitKinds _tlIvisitdefs _tlIvisituses) = inv_Visits_s56 _tlX56 (T_Visits_vIn55 _tlOallFromToStates _tlOallInhmap _tlOallInitStates _tlOallSynmap _tlOallVisitKinds _tlOallchildvisit _tlOallintramap _tlOavisitdefs _tlOavisituses _tlOchildTypes _tlOchildintros _tlOcon _tlOinhmap _tlOmrules _tlOnextVisits _tlOnt _tlOoptions _tlOparams _tlOprevVisits _tlOruledefs _tlOruleuses _tlOsynmap _tlOterminaldefs) _lhsOallvisits :: [VisitStateState] _lhsOallvisits = rule746 _hdIallvisits _tlIallvisits _lhsOchildvisit :: Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc) _lhsOchildvisit = rule747 _hdIchildvisit _tlIchildvisit _lhsOerrors :: Seq Error _lhsOerrors = rule748 _hdIerrors _tlIerrors _lhsOfromToStates :: Map VisitIdentifier (Int,Int) _lhsOfromToStates = rule749 _hdIfromToStates _tlIfromToStates _lhsOintramap :: Map StateIdentifier (Map String (Maybe NonLocalAttr)) _lhsOintramap = rule750 _hdIintramap _tlIintramap _lhsOlazyIntras :: Set String _lhsOlazyIntras = rule751 _hdIlazyIntras _tlIlazyIntras _lhsOruleKinds :: Map Identifier (Set VisitKind) _lhsOruleKinds = rule752 _hdIruleKinds _tlIruleKinds _lhsOruleUsage :: Map Identifier Int _lhsOruleUsage = rule753 _hdIruleUsage _tlIruleUsage _lhsOsem_visit :: [(StateIdentifier,PP_Doc)] _lhsOsem_visit = rule754 _hdIsem_visit _tlIsem_visit _lhsOt_visits :: PP_Doc _lhsOt_visits = rule755 _hdIt_visits _tlIt_visits _lhsOvisitKinds :: Map VisitIdentifier VisitKind _lhsOvisitKinds = rule756 _hdIvisitKinds _tlIvisitKinds _lhsOvisitdefs :: Map VisitIdentifier (Set Identifier) _lhsOvisitdefs = rule757 _hdIvisitdefs _tlIvisitdefs _lhsOvisituses :: Map VisitIdentifier (Set Identifier) _lhsOvisituses = rule758 _hdIvisituses _tlIvisituses _hdOallFromToStates = rule759 _lhsIallFromToStates _hdOallInhmap = rule760 _lhsIallInhmap _hdOallInitStates = rule761 _lhsIallInitStates _hdOallSynmap = rule762 _lhsIallSynmap _hdOallVisitKinds = rule763 _lhsIallVisitKinds _hdOallchildvisit = rule764 _lhsIallchildvisit _hdOallintramap = rule765 _lhsIallintramap _hdOavisitdefs = rule766 _lhsIavisitdefs _hdOavisituses = rule767 _lhsIavisituses _hdOchildTypes = rule768 _lhsIchildTypes _hdOchildintros = rule769 _lhsIchildintros _hdOcon = rule770 _lhsIcon _hdOinhmap = rule771 _lhsIinhmap _hdOmrules = rule772 _lhsImrules _hdOnextVisits = rule773 _lhsInextVisits _hdOnt = rule774 _lhsInt _hdOoptions = rule775 _lhsIoptions _hdOparams = rule776 _lhsIparams _hdOprevVisits = rule777 _lhsIprevVisits _hdOruledefs = rule778 _lhsIruledefs _hdOruleuses = rule779 _lhsIruleuses _hdOsynmap = rule780 _lhsIsynmap _hdOterminaldefs = rule781 _lhsIterminaldefs _tlOallFromToStates = rule782 _lhsIallFromToStates _tlOallInhmap = rule783 _lhsIallInhmap _tlOallInitStates = rule784 _lhsIallInitStates _tlOallSynmap = rule785 _lhsIallSynmap _tlOallVisitKinds = rule786 _lhsIallVisitKinds _tlOallchildvisit = rule787 _lhsIallchildvisit _tlOallintramap = rule788 _lhsIallintramap _tlOavisitdefs = rule789 _lhsIavisitdefs _tlOavisituses = rule790 _lhsIavisituses _tlOchildTypes = rule791 _lhsIchildTypes _tlOchildintros = rule792 _lhsIchildintros _tlOcon = rule793 _lhsIcon _tlOinhmap = rule794 _lhsIinhmap _tlOmrules = rule795 _lhsImrules _tlOnextVisits = rule796 _lhsInextVisits _tlOnt = rule797 _lhsInt _tlOoptions = rule798 _lhsIoptions _tlOparams = rule799 _lhsIparams _tlOprevVisits = rule800 _lhsIprevVisits _tlOruledefs = rule801 _lhsIruledefs _tlOruleuses = rule802 _lhsIruleuses _tlOsynmap = rule803 _lhsIsynmap _tlOterminaldefs = rule804 _lhsIterminaldefs __result_ = T_Visits_vOut55 _lhsOallvisits _lhsOchildvisit _lhsOerrors _lhsOfromToStates _lhsOintramap _lhsOlazyIntras _lhsOruleKinds _lhsOruleUsage _lhsOsem_visit _lhsOt_visits _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses in __result_ ) in C_Visits_s56 v55 {-# INLINE rule746 #-} rule746 = \ ((_hdIallvisits) :: VisitStateState ) ((_tlIallvisits) :: [VisitStateState]) -> _hdIallvisits : _tlIallvisits {-# INLINE rule747 #-} rule747 = \ ((_hdIchildvisit) :: Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) ((_tlIchildvisit) :: Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) -> _hdIchildvisit `Map.union` _tlIchildvisit {-# INLINE rule748 #-} rule748 = \ ((_hdIerrors) :: Seq Error) ((_tlIerrors) :: Seq Error) -> _hdIerrors Seq.>< _tlIerrors {-# INLINE rule749 #-} rule749 = \ ((_hdIfromToStates) :: Map VisitIdentifier (Int,Int)) ((_tlIfromToStates) :: Map VisitIdentifier (Int,Int)) -> _hdIfromToStates `mappend` _tlIfromToStates {-# INLINE rule750 #-} rule750 = \ ((_hdIintramap) :: Map StateIdentifier (Map String (Maybe NonLocalAttr))) ((_tlIintramap) :: Map StateIdentifier (Map String (Maybe NonLocalAttr))) -> _hdIintramap `uwMapUnion` _tlIintramap {-# INLINE rule751 #-} rule751 = \ ((_hdIlazyIntras) :: Set String) ((_tlIlazyIntras) :: Set String) -> _hdIlazyIntras `Set.union` _tlIlazyIntras {-# INLINE rule752 #-} rule752 = \ ((_hdIruleKinds) :: Map Identifier (Set VisitKind)) ((_tlIruleKinds) :: Map Identifier (Set VisitKind)) -> _hdIruleKinds `unionWithMappend` _tlIruleKinds {-# INLINE rule753 #-} rule753 = \ ((_hdIruleUsage) :: Map Identifier Int) ((_tlIruleUsage) :: Map Identifier Int) -> _hdIruleUsage `unionWithSum` _tlIruleUsage {-# INLINE rule754 #-} rule754 = \ ((_hdIsem_visit) :: (StateIdentifier,PP_Doc) ) ((_tlIsem_visit) :: [(StateIdentifier,PP_Doc)] ) -> _hdIsem_visit : _tlIsem_visit {-# INLINE rule755 #-} rule755 = \ ((_hdIt_visits) :: PP_Doc) ((_tlIt_visits) :: PP_Doc) -> _hdIt_visits >-< _tlIt_visits {-# INLINE rule756 #-} rule756 = \ ((_hdIvisitKinds) :: Map VisitIdentifier VisitKind) ((_tlIvisitKinds) :: Map VisitIdentifier VisitKind) -> _hdIvisitKinds `mappend` _tlIvisitKinds {-# INLINE rule757 #-} rule757 = \ ((_hdIvisitdefs) :: Map VisitIdentifier (Set Identifier)) ((_tlIvisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _hdIvisitdefs `uwSetUnion` _tlIvisitdefs {-# INLINE rule758 #-} rule758 = \ ((_hdIvisituses) :: Map VisitIdentifier (Set Identifier)) ((_tlIvisituses) :: Map VisitIdentifier (Set Identifier)) -> _hdIvisituses `uwSetUnion` _tlIvisituses {-# INLINE rule759 #-} rule759 = \ ((_lhsIallFromToStates) :: Map VisitIdentifier (Int,Int)) -> _lhsIallFromToStates {-# INLINE rule760 #-} rule760 = \ ((_lhsIallInhmap) :: Map NontermIdent Attributes) -> _lhsIallInhmap {-# INLINE rule761 #-} rule761 = \ ((_lhsIallInitStates) :: Map NontermIdent Int) -> _lhsIallInitStates {-# INLINE rule762 #-} rule762 = \ ((_lhsIallSynmap) :: Map NontermIdent Attributes) -> _lhsIallSynmap {-# INLINE rule763 #-} rule763 = \ ((_lhsIallVisitKinds) :: Map VisitIdentifier VisitKind) -> _lhsIallVisitKinds {-# INLINE rule764 #-} rule764 = \ ((_lhsIallchildvisit) :: Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) -> _lhsIallchildvisit {-# INLINE rule765 #-} rule765 = \ ((_lhsIallintramap) :: Map StateIdentifier (Map String (Maybe NonLocalAttr))) -> _lhsIallintramap {-# INLINE rule766 #-} rule766 = \ ((_lhsIavisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisitdefs {-# INLINE rule767 #-} rule767 = \ ((_lhsIavisituses) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisituses {-# INLINE rule768 #-} rule768 = \ ((_lhsIchildTypes) :: Map Identifier Type) -> _lhsIchildTypes {-# INLINE rule769 #-} rule769 = \ ((_lhsIchildintros) :: Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))) -> _lhsIchildintros {-# INLINE rule770 #-} rule770 = \ ((_lhsIcon) :: ConstructorIdent) -> _lhsIcon {-# INLINE rule771 #-} rule771 = \ ((_lhsIinhmap) :: Attributes) -> _lhsIinhmap {-# INLINE rule772 #-} rule772 = \ ((_lhsImrules) :: Map Identifier (VisitKind -> Either Error PP_Doc)) -> _lhsImrules {-# INLINE rule773 #-} rule773 = \ ((_lhsInextVisits) :: Map StateIdentifier StateCtx) -> _lhsInextVisits {-# INLINE rule774 #-} rule774 = \ ((_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule775 #-} rule775 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule776 #-} rule776 = \ ((_lhsIparams) :: [Identifier]) -> _lhsIparams {-# INLINE rule777 #-} rule777 = \ ((_lhsIprevVisits) :: Map StateIdentifier StateCtx) -> _lhsIprevVisits {-# INLINE rule778 #-} rule778 = \ ((_lhsIruledefs) :: Map Identifier (Set String)) -> _lhsIruledefs {-# INLINE rule779 #-} rule779 = \ ((_lhsIruleuses) :: Map Identifier (Map String (Maybe NonLocalAttr))) -> _lhsIruleuses {-# INLINE rule780 #-} rule780 = \ ((_lhsIsynmap) :: Attributes) -> _lhsIsynmap {-# INLINE rule781 #-} rule781 = \ ((_lhsIterminaldefs) :: Set String) -> _lhsIterminaldefs {-# INLINE rule782 #-} rule782 = \ ((_lhsIallFromToStates) :: Map VisitIdentifier (Int,Int)) -> _lhsIallFromToStates {-# INLINE rule783 #-} rule783 = \ ((_lhsIallInhmap) :: Map NontermIdent Attributes) -> _lhsIallInhmap {-# INLINE rule784 #-} rule784 = \ ((_lhsIallInitStates) :: Map NontermIdent Int) -> _lhsIallInitStates {-# INLINE rule785 #-} rule785 = \ ((_lhsIallSynmap) :: Map NontermIdent Attributes) -> _lhsIallSynmap {-# INLINE rule786 #-} rule786 = \ ((_lhsIallVisitKinds) :: Map VisitIdentifier VisitKind) -> _lhsIallVisitKinds {-# INLINE rule787 #-} rule787 = \ ((_lhsIallchildvisit) :: Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)) -> _lhsIallchildvisit {-# INLINE rule788 #-} rule788 = \ ((_lhsIallintramap) :: Map StateIdentifier (Map String (Maybe NonLocalAttr))) -> _lhsIallintramap {-# INLINE rule789 #-} rule789 = \ ((_lhsIavisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisitdefs {-# INLINE rule790 #-} rule790 = \ ((_lhsIavisituses) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisituses {-# INLINE rule791 #-} rule791 = \ ((_lhsIchildTypes) :: Map Identifier Type) -> _lhsIchildTypes {-# INLINE rule792 #-} rule792 = \ ((_lhsIchildintros) :: Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))) -> _lhsIchildintros {-# INLINE rule793 #-} rule793 = \ ((_lhsIcon) :: ConstructorIdent) -> _lhsIcon {-# INLINE rule794 #-} rule794 = \ ((_lhsIinhmap) :: Attributes) -> _lhsIinhmap {-# INLINE rule795 #-} rule795 = \ ((_lhsImrules) :: Map Identifier (VisitKind -> Either Error PP_Doc)) -> _lhsImrules {-# INLINE rule796 #-} rule796 = \ ((_lhsInextVisits) :: Map StateIdentifier StateCtx) -> _lhsInextVisits {-# INLINE rule797 #-} rule797 = \ ((_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule798 #-} rule798 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule799 #-} rule799 = \ ((_lhsIparams) :: [Identifier]) -> _lhsIparams {-# INLINE rule800 #-} rule800 = \ ((_lhsIprevVisits) :: Map StateIdentifier StateCtx) -> _lhsIprevVisits {-# INLINE rule801 #-} rule801 = \ ((_lhsIruledefs) :: Map Identifier (Set String)) -> _lhsIruledefs {-# INLINE rule802 #-} rule802 = \ ((_lhsIruleuses) :: Map Identifier (Map String (Maybe NonLocalAttr))) -> _lhsIruleuses {-# INLINE rule803 #-} rule803 = \ ((_lhsIsynmap) :: Attributes) -> _lhsIsynmap {-# INLINE rule804 #-} rule804 = \ ((_lhsIterminaldefs) :: Set String) -> _lhsIterminaldefs {-# NOINLINE sem_Visits_Nil #-} sem_Visits_Nil :: T_Visits sem_Visits_Nil = T_Visits (return st56) where {-# NOINLINE st56 #-} st56 = let v55 :: T_Visits_v55 v55 = \ (T_Visits_vIn55 _lhsIallFromToStates _lhsIallInhmap _lhsIallInitStates _lhsIallSynmap _lhsIallVisitKinds _lhsIallchildvisit _lhsIallintramap _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIcon _lhsIinhmap _lhsImrules _lhsInextVisits _lhsInt _lhsIoptions _lhsIparams _lhsIprevVisits _lhsIruledefs _lhsIruleuses _lhsIsynmap _lhsIterminaldefs) -> ( let _lhsOallvisits :: [VisitStateState] _lhsOallvisits = rule805 () _lhsOchildvisit :: Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc) _lhsOchildvisit = rule806 () _lhsOerrors :: Seq Error _lhsOerrors = rule807 () _lhsOfromToStates :: Map VisitIdentifier (Int,Int) _lhsOfromToStates = rule808 () _lhsOintramap :: Map StateIdentifier (Map String (Maybe NonLocalAttr)) _lhsOintramap = rule809 () _lhsOlazyIntras :: Set String _lhsOlazyIntras = rule810 () _lhsOruleKinds :: Map Identifier (Set VisitKind) _lhsOruleKinds = rule811 () _lhsOruleUsage :: Map Identifier Int _lhsOruleUsage = rule812 () _lhsOsem_visit :: [(StateIdentifier,PP_Doc)] _lhsOsem_visit = rule813 () _lhsOt_visits :: PP_Doc _lhsOt_visits = rule814 () _lhsOvisitKinds :: Map VisitIdentifier VisitKind _lhsOvisitKinds = rule815 () _lhsOvisitdefs :: Map VisitIdentifier (Set Identifier) _lhsOvisitdefs = rule816 () _lhsOvisituses :: Map VisitIdentifier (Set Identifier) _lhsOvisituses = rule817 () __result_ = T_Visits_vOut55 _lhsOallvisits _lhsOchildvisit _lhsOerrors _lhsOfromToStates _lhsOintramap _lhsOlazyIntras _lhsOruleKinds _lhsOruleUsage _lhsOsem_visit _lhsOt_visits _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses in __result_ ) in C_Visits_s56 v55 {-# INLINE rule805 #-} rule805 = \ (_ :: ()) -> [] {-# INLINE rule806 #-} rule806 = \ (_ :: ()) -> Map.empty {-# INLINE rule807 #-} rule807 = \ (_ :: ()) -> Seq.empty {-# INLINE rule808 #-} rule808 = \ (_ :: ()) -> mempty {-# INLINE rule809 #-} rule809 = \ (_ :: ()) -> Map.empty {-# INLINE rule810 #-} rule810 = \ (_ :: ()) -> Set.empty {-# INLINE rule811 #-} rule811 = \ (_ :: ()) -> Map.empty {-# INLINE rule812 #-} rule812 = \ (_ :: ()) -> Map.empty {-# INLINE rule813 #-} rule813 = \ (_ :: ()) -> [] {-# INLINE rule814 #-} rule814 = \ (_ :: ()) -> empty {-# INLINE rule815 #-} rule815 = \ (_ :: ()) -> mempty {-# INLINE rule816 #-} rule816 = \ (_ :: ()) -> Map.empty {-# INLINE rule817 #-} rule817 = \ (_ :: ()) -> Map.empty uuagc-0.9.42.3/src-generated/ExecutionPlan2Hs.hs000644 000765 000024 00001453700 12127045231 023272 0ustar00jeroenbransenstaff000000 000000 {-# LANGUAGE Rank2Types, GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} module ExecutionPlan2Hs where {-# LINE 2 "./src-ag/ExecutionPlan.ag" #-} -- 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) {-# LINE 18 "dist/build/ExecutionPlan2Hs.hs" #-} {-# LINE 2 "./src-ag/Patterns.ag" #-} -- Patterns.ag imports import UU.Scanner.Position(Pos) import CommonTypes (ConstructorIdent,Identifier) {-# LINE 25 "dist/build/ExecutionPlan2Hs.hs" #-} {-# LINE 2 "./src-ag/Expression.ag" #-} import UU.Scanner.Position(Pos) import HsToken {-# LINE 31 "dist/build/ExecutionPlan2Hs.hs" #-} {-# LINE 2 "./src-ag/HsToken.ag" #-} import CommonTypes import UU.Scanner.Position(Pos) {-# LINE 37 "dist/build/ExecutionPlan2Hs.hs" #-} {-# LINE 7 "./src-ag/ExecutionPlan2Hs.ag" #-} 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) {-# LINE 64 "dist/build/ExecutionPlan2Hs.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 161 "./src-ag/ExecutionPlan2Hs.ag" #-} 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 >#< "." {-# LINE 83 "dist/build/ExecutionPlan2Hs.hs" #-} {-# LINE 190 "./src-ag/ExecutionPlan2Hs.ag" #-} -- first parameter indicates: generate a record or not ppConFields :: Bool -> [PP_Doc] -> PP_Doc ppConFields True flds = ppListSep "{" "}" ", " flds ppConFields False flds = ppSpaced flds {-# LINE 91 "dist/build/ExecutionPlan2Hs.hs" #-} {-# LINE 216 "./src-ag/ExecutionPlan2Hs.ag" #-} ppTp :: Type -> PP_Doc ppTp = text . typeToHaskellString Nothing [] {-# LINE 97 "dist/build/ExecutionPlan2Hs.hs" #-} {-# LINE 330 "./src-ag/ExecutionPlan2Hs.ag" #-} type VisitStateState = (VisitIdentifier,StateIdentifier, StateIdentifier) {-# LINE 101 "dist/build/ExecutionPlan2Hs.hs" #-} {-# LINE 426 "./src-ag/ExecutionPlan2Hs.ag" #-} 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" {-# LINE 114 "dist/build/ExecutionPlan2Hs.hs" #-} {-# LINE 576 "./src-ag/ExecutionPlan2Hs.ag" #-} ppDefor :: Type -> PP_Doc ppDefor (NT nt args _) = "T_" >|< nt >#< ppSpaced (map pp_parens args) ppDefor (Haskell s) = text s {-# LINE 121 "dist/build/ExecutionPlan2Hs.hs" #-} {-# LINE 700 "./src-ag/ExecutionPlan2Hs.ag" #-} 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 {-# LINE 130 "dist/build/ExecutionPlan2Hs.hs" #-} {-# LINE 766 "./src-ag/ExecutionPlan2Hs.ag" #-} resultValName :: String resultValName = "__result_" nextStName :: String nextStName = "__st_" {-# LINE 139 "dist/build/ExecutionPlan2Hs.hs" #-} {-# LINE 837 "./src-ag/ExecutionPlan2Hs.ag" #-} 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 {-# LINE 152 "dist/build/ExecutionPlan2Hs.hs" #-} {-# LINE 963 "./src-ag/ExecutionPlan2Hs.ag" #-} 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 {-# LINE 167 "dist/build/ExecutionPlan2Hs.hs" #-} {-# LINE 1071 "./src-ag/ExecutionPlan2Hs.ag" #-} 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)" {-# LINE 194 "dist/build/ExecutionPlan2Hs.hs" #-} {-# LINE 1097 "./src-ag/ExecutionPlan2Hs.ag" #-} -- 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 {-# LINE 209 "dist/build/ExecutionPlan2Hs.hs" #-} {-# LINE 1163 "./src-ag/ExecutionPlan2Hs.ag" #-} 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 {-# LINE 242 "dist/build/ExecutionPlan2Hs.hs" #-} {-# LINE 1249 "./src-ag/ExecutionPlan2Hs.ag" #-} -- 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 {-# LINE 253 "dist/build/ExecutionPlan2Hs.hs" #-} {-# LINE 1271 "./src-ag/ExecutionPlan2Hs.ag" #-} unionWithSum = Map.unionWith (+) {-# LINE 258 "dist/build/ExecutionPlan2Hs.hs" #-} {-# LINE 1294 "./src-ag/ExecutionPlan2Hs.ag" #-} 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 {-# LINE 267 "dist/build/ExecutionPlan2Hs.hs" #-} {-# LINE 1511 "./src-ag/ExecutionPlan2Hs.ag" #-} 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 {-# LINE 287 "dist/build/ExecutionPlan2Hs.hs" #-} {-# LINE 1658 "./src-ag/ExecutionPlan2Hs.ag" #-} 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 ] {-# LINE 329 "dist/build/ExecutionPlan2Hs.hs" #-} -- EChild ------------------------------------------------------ -- wrapper data Inh_EChild = Inh_EChild { allInitStates_Inh_EChild :: (Map NontermIdent Int), con_Inh_EChild :: (ConstructorIdent), importBlocks_Inh_EChild :: (PP_Doc), mainFile_Inh_EChild :: (String), mainName_Inh_EChild :: (String), moduleHeader_Inh_EChild :: (String -> String -> String -> Bool -> String), nt_Inh_EChild :: (NontermIdent), options_Inh_EChild :: (Options), pragmaBlocks_Inh_EChild :: (String), textBlocks_Inh_EChild :: (PP_Doc) } data Syn_EChild = Syn_EChild { argnamesw_Syn_EChild :: ( PP_Doc ), argpats_Syn_EChild :: ( PP_Doc ), argtps_Syn_EChild :: ( PP_Doc ), childTypes_Syn_EChild :: (Map Identifier Type), childintros_Syn_EChild :: (Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))), datatype_Syn_EChild :: (PP_Doc), terminaldefs_Syn_EChild :: (Set String), usedArgs_Syn_EChild :: (Set String) } {-# INLINABLE wrap_EChild #-} wrap_EChild :: T_EChild -> Inh_EChild -> (Syn_EChild ) wrap_EChild (T_EChild act) (Inh_EChild _lhsIallInitStates _lhsIcon _lhsIimportBlocks _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInt _lhsIoptions _lhsIpragmaBlocks _lhsItextBlocks) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_EChild_vIn1 _lhsIallInitStates _lhsIcon _lhsIimportBlocks _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInt _lhsIoptions _lhsIpragmaBlocks _lhsItextBlocks (T_EChild_vOut1 _lhsOargnamesw _lhsOargpats _lhsOargtps _lhsOchildTypes _lhsOchildintros _lhsOdatatype _lhsOterminaldefs _lhsOusedArgs) <- return (inv_EChild_s2 sem arg) return (Syn_EChild _lhsOargnamesw _lhsOargpats _lhsOargtps _lhsOchildTypes _lhsOchildintros _lhsOdatatype _lhsOterminaldefs _lhsOusedArgs) ) -- cata {-# NOINLINE sem_EChild #-} sem_EChild :: EChild -> T_EChild sem_EChild ( EChild name_ tp_ kind_ hasAround_ merges_ isMerged_ ) = sem_EChild_EChild name_ tp_ kind_ hasAround_ merges_ isMerged_ sem_EChild ( ETerm name_ tp_ ) = sem_EChild_ETerm name_ tp_ -- semantic domain newtype T_EChild = T_EChild { attach_T_EChild :: Identity (T_EChild_s2 ) } newtype T_EChild_s2 = C_EChild_s2 { inv_EChild_s2 :: (T_EChild_v1 ) } data T_EChild_s3 = C_EChild_s3 type T_EChild_v1 = (T_EChild_vIn1 ) -> (T_EChild_vOut1 ) data T_EChild_vIn1 = T_EChild_vIn1 (Map NontermIdent Int) (ConstructorIdent) (PP_Doc) (String) (String) (String -> String -> String -> Bool -> String) (NontermIdent) (Options) (String) (PP_Doc) data T_EChild_vOut1 = T_EChild_vOut1 ( PP_Doc ) ( PP_Doc ) ( PP_Doc ) (Map Identifier Type) (Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))) (PP_Doc) (Set String) (Set String) {-# NOINLINE sem_EChild_EChild #-} sem_EChild_EChild :: (Identifier) -> (Type) -> (ChildKind) -> (Bool) -> (Maybe [Identifier]) -> (Bool) -> T_EChild sem_EChild_EChild arg_name_ arg_tp_ arg_kind_ arg_hasAround_ _ _ = T_EChild (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_EChild_v1 v1 = \ (T_EChild_vIn1 _lhsIallInitStates _lhsIcon _lhsIimportBlocks _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInt _lhsIoptions _lhsIpragmaBlocks _lhsItextBlocks) -> ( let _lhsOusedArgs :: Set String _lhsOusedArgs = rule0 _usedArgs_augmented_f1 _usedArgs_augmented_syn _usedArgs_augmented_f1 = rule1 arg_kind_ arg_name_ _tpDoc = rule2 _addStrict arg_tp_ _strNm = rule3 _lhsIcon _lhsInt arg_name_ _field = rule4 _lhsIoptions _strNm _tpDoc _addStrict = rule5 _lhsIoptions _lhsOdatatype :: PP_Doc _lhsOdatatype = rule6 _field arg_kind_ _lhsOargnamesw :: PP_Doc _lhsOargnamesw = rule7 _nt arg_kind_ arg_name_ _lhsOargtps :: PP_Doc _lhsOargtps = rule8 arg_kind_ arg_tp_ _argpats = rule9 arg_kind_ arg_name_ _lhsOchildintros :: Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr))) _lhsOchildintros = rule10 _introcode arg_name_ _isDefor = rule11 arg_tp_ _valcode = rule12 _isDefor _lhsIoptions _nt arg_kind_ arg_name_ _aroundcode = rule13 arg_hasAround_ arg_name_ _introcode = rule14 _addbang _aroundcode _initSt _isDefor _lhsIoptions _nt _valcode arg_hasAround_ arg_kind_ arg_name_ _nt = rule15 arg_tp_ _addbang = rule16 _lhsIoptions _lhsOchildTypes :: Map Identifier Type _lhsOchildTypes = rule17 arg_name_ arg_tp_ _initSt = rule18 _lhsIallInitStates _nt _lhsOterminaldefs :: Set String _lhsOterminaldefs = rule19 () _usedArgs_augmented_syn = rule20 () _lhsOargpats :: PP_Doc _lhsOargpats = rule21 _argpats __result_ = T_EChild_vOut1 _lhsOargnamesw _lhsOargpats _lhsOargtps _lhsOchildTypes _lhsOchildintros _lhsOdatatype _lhsOterminaldefs _lhsOusedArgs in __result_ ) in C_EChild_s2 v1 {-# INLINE rule0 #-} rule0 = \ _usedArgs_augmented_f1 _usedArgs_augmented_syn -> foldr ($) _usedArgs_augmented_syn [_usedArgs_augmented_f1] {-# INLINE rule1 #-} rule1 = \ kind_ name_ -> \s -> case kind_ of ChildSyntax -> Set.insert ("arg_" ++ show name_ ++ "_") s _ -> s {-# INLINE rule2 #-} {-# LINE 204 "./src-ag/ExecutionPlan2Hs.ag" #-} rule2 = \ _addStrict tp_ -> {-# LINE 204 "./src-ag/ExecutionPlan2Hs.ag" #-} _addStrict $ pp_parens $ ppTp $ removeDeforested tp_ {-# LINE 414 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule3 #-} {-# LINE 205 "./src-ag/ExecutionPlan2Hs.ag" #-} rule3 = \ ((_lhsIcon) :: ConstructorIdent) ((_lhsInt) :: NontermIdent) name_ -> {-# LINE 205 "./src-ag/ExecutionPlan2Hs.ag" #-} recordFieldname _lhsInt _lhsIcon name_ {-# LINE 420 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule4 #-} {-# LINE 206 "./src-ag/ExecutionPlan2Hs.ag" #-} rule4 = \ ((_lhsIoptions) :: Options) _strNm _tpDoc -> {-# LINE 206 "./src-ag/ExecutionPlan2Hs.ag" #-} if dataRecords _lhsIoptions then _strNm >#< "::" >#< _tpDoc else _tpDoc {-# LINE 428 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule5 #-} {-# LINE 209 "./src-ag/ExecutionPlan2Hs.ag" #-} rule5 = \ ((_lhsIoptions) :: Options) -> {-# LINE 209 "./src-ag/ExecutionPlan2Hs.ag" #-} \x -> if strictData _lhsIoptions then "!" >|< x else x {-# LINE 434 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule6 #-} {-# LINE 210 "./src-ag/ExecutionPlan2Hs.ag" #-} rule6 = \ _field kind_ -> {-# LINE 210 "./src-ag/ExecutionPlan2Hs.ag" #-} case kind_ of ChildAttr -> empty _ -> _field {-# LINE 442 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule7 #-} {-# LINE 298 "./src-ag/ExecutionPlan2Hs.ag" #-} rule7 = \ _nt kind_ name_ -> {-# LINE 298 "./src-ag/ExecutionPlan2Hs.ag" #-} case kind_ of ChildSyntax -> "(" >#< "sem_" >|< _nt >#< name_ >|< "_" >#< ")" ChildAttr -> empty ChildReplace tp -> "(" >#< "sem_" >|< extractNonterminal tp >#< name_ >|< "_" >#< ")" {-# LINE 451 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule8 #-} {-# LINE 565 "./src-ag/ExecutionPlan2Hs.ag" #-} rule8 = \ kind_ tp_ -> {-# LINE 565 "./src-ag/ExecutionPlan2Hs.ag" #-} case kind_ of ChildSyntax -> ppDefor tp_ >#< "->" ChildReplace tp -> ppDefor tp >#< "->" _ -> empty {-# LINE 460 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule9 #-} {-# LINE 569 "./src-ag/ExecutionPlan2Hs.ag" #-} rule9 = \ kind_ name_ -> {-# LINE 569 "./src-ag/ExecutionPlan2Hs.ag" #-} case kind_ of ChildSyntax -> name_ >|< "_" ChildReplace _ -> name_ >|< "_" _ -> empty {-# LINE 469 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule10 #-} {-# LINE 917 "./src-ag/ExecutionPlan2Hs.ag" #-} rule10 = \ _introcode name_ -> {-# LINE 917 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.singleton name_ _introcode {-# LINE 475 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule11 #-} {-# LINE 918 "./src-ag/ExecutionPlan2Hs.ag" #-} rule11 = \ tp_ -> {-# LINE 918 "./src-ag/ExecutionPlan2Hs.ag" #-} case tp_ of NT _ _ defor -> defor _ -> False {-# LINE 483 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule12 #-} {-# LINE 921 "./src-ag/ExecutionPlan2Hs.ag" #-} rule12 = \ _isDefor ((_lhsIoptions) :: Options) _nt kind_ name_ -> {-# LINE 921 "./src-ag/ExecutionPlan2Hs.ag" #-} case kind_ of ChildSyntax -> "arg_" >|< name_ >|< "_" ChildAttr -> let prefix | not _isDefor = if lateHigherOrderBinding _lhsIoptions then lateSemNtLabel _nt >#< lhsname True idLateBindingAttr else "sem_" >|< _nt | otherwise = empty in pp_parens (prefix >#< instname name_) ChildReplace _ -> pp_parens (instname name_ >#< name_ >|< "_") {-# LINE 498 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule13 #-} {-# LINE 932 "./src-ag/ExecutionPlan2Hs.ag" #-} rule13 = \ hasAround_ name_ -> {-# LINE 932 "./src-ag/ExecutionPlan2Hs.ag" #-} if hasAround_ then locname name_ >|< "_around" else empty {-# LINE 506 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule14 #-} {-# LINE 935 "./src-ag/ExecutionPlan2Hs.ag" #-} rule14 = \ _addbang _aroundcode _initSt _isDefor ((_lhsIoptions) :: Options) _nt _valcode hasAround_ kind_ name_ -> {-# LINE 935 "./src-ag/ExecutionPlan2Hs.ag" #-} \kind fmtMode -> let pat = text $ stname name_ _initSt patStrict = _addbang pat attach = "attach_T_" >|< _nt >#< pp_parens (_aroundcode >#< _valcode ) runAttach = unMon _lhsIoptions >#< pp_parens attach decl = case kind of VisitPure False -> pat >#< "=" >#< runAttach VisitPure True -> patStrict >#< "=" >#< runAttach VisitMonadic -> patStrict >#< "<-" >#< attach in if compatibleAttach kind _nt _lhsIoptions then Right ( fmtDecl False fmtMode decl , Set.singleton (stname name_ _initSt ) , case kind_ of ChildAttr -> Map.insert (instname name_) Nothing $ ( if _isDefor || not (lateHigherOrderBinding _lhsIoptions) then id else Map.insert (lhsname True idLateBindingAttr) (Just $ AttrInh _LHS idLateBindingAttr) ) $ ( if hasAround_ then Map.insert (locname (name_) ++ "_around") Nothing else id ) $ Map.empty ChildReplace _ -> Map.singleton (instname name_) Nothing ChildSyntax -> Map.empty ) else Left $ IncompatibleAttachKind name_ kind {-# LINE 537 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule15 #-} {-# LINE 961 "./src-ag/ExecutionPlan2Hs.ag" #-} rule15 = \ tp_ -> {-# LINE 961 "./src-ag/ExecutionPlan2Hs.ag" #-} extractNonterminal tp_ {-# LINE 543 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule16 #-} {-# LINE 1539 "./src-ag/ExecutionPlan2Hs.ag" #-} rule16 = \ ((_lhsIoptions) :: Options) -> {-# LINE 1539 "./src-ag/ExecutionPlan2Hs.ag" #-} \x -> if bangpats _lhsIoptions then "!" >|< x else x {-# LINE 549 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule17 #-} {-# LINE 1591 "./src-ag/ExecutionPlan2Hs.ag" #-} rule17 = \ name_ tp_ -> {-# LINE 1591 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.singleton name_ tp_ {-# LINE 555 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule18 #-} {-# LINE 1635 "./src-ag/ExecutionPlan2Hs.ag" #-} rule18 = \ ((_lhsIallInitStates) :: Map NontermIdent Int) _nt -> {-# LINE 1635 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.findWithDefault (error "nonterminal not in allInitStates map") _nt _lhsIallInitStates {-# LINE 561 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule19 #-} rule19 = \ (_ :: ()) -> Set.empty {-# INLINE rule20 #-} rule20 = \ (_ :: ()) -> Set.empty {-# INLINE rule21 #-} rule21 = \ _argpats -> _argpats {-# NOINLINE sem_EChild_ETerm #-} sem_EChild_ETerm :: (Identifier) -> (Type) -> T_EChild sem_EChild_ETerm arg_name_ arg_tp_ = T_EChild (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_EChild_v1 v1 = \ (T_EChild_vIn1 _lhsIallInitStates _lhsIcon _lhsIimportBlocks _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInt _lhsIoptions _lhsIpragmaBlocks _lhsItextBlocks) -> ( let _tpDoc = rule22 _addStrict arg_tp_ _strNm = rule23 _lhsIcon _lhsInt arg_name_ _field = rule24 _lhsIoptions _strNm _tpDoc _addStrict = rule25 _lhsIoptions _lhsOdatatype :: PP_Doc _lhsOdatatype = rule26 _field _lhsOargnamesw :: PP_Doc _lhsOargnamesw = rule27 arg_name_ _lhsOargtps :: PP_Doc _lhsOargtps = rule28 arg_tp_ _argpats = rule29 _addbang arg_name_ _lhsOchildintros :: Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr))) _lhsOchildintros = rule30 arg_name_ _lhsOterminaldefs :: Set String _lhsOterminaldefs = rule31 arg_name_ _addbang = rule32 _lhsIoptions _lhsOchildTypes :: Map Identifier Type _lhsOchildTypes = rule33 arg_name_ arg_tp_ _lhsOusedArgs :: Set String _lhsOusedArgs = rule34 () _lhsOargpats :: PP_Doc _lhsOargpats = rule35 _argpats __result_ = T_EChild_vOut1 _lhsOargnamesw _lhsOargpats _lhsOargtps _lhsOchildTypes _lhsOchildintros _lhsOdatatype _lhsOterminaldefs _lhsOusedArgs in __result_ ) in C_EChild_s2 v1 {-# INLINE rule22 #-} {-# LINE 204 "./src-ag/ExecutionPlan2Hs.ag" #-} rule22 = \ _addStrict tp_ -> {-# LINE 204 "./src-ag/ExecutionPlan2Hs.ag" #-} _addStrict $ pp_parens $ ppTp $ removeDeforested tp_ {-# LINE 608 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule23 #-} {-# LINE 205 "./src-ag/ExecutionPlan2Hs.ag" #-} rule23 = \ ((_lhsIcon) :: ConstructorIdent) ((_lhsInt) :: NontermIdent) name_ -> {-# LINE 205 "./src-ag/ExecutionPlan2Hs.ag" #-} recordFieldname _lhsInt _lhsIcon name_ {-# LINE 614 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule24 #-} {-# LINE 206 "./src-ag/ExecutionPlan2Hs.ag" #-} rule24 = \ ((_lhsIoptions) :: Options) _strNm _tpDoc -> {-# LINE 206 "./src-ag/ExecutionPlan2Hs.ag" #-} if dataRecords _lhsIoptions then _strNm >#< "::" >#< _tpDoc else _tpDoc {-# LINE 622 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule25 #-} {-# LINE 209 "./src-ag/ExecutionPlan2Hs.ag" #-} rule25 = \ ((_lhsIoptions) :: Options) -> {-# LINE 209 "./src-ag/ExecutionPlan2Hs.ag" #-} \x -> if strictData _lhsIoptions then "!" >|< x else x {-# LINE 628 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule26 #-} {-# LINE 214 "./src-ag/ExecutionPlan2Hs.ag" #-} rule26 = \ _field -> {-# LINE 214 "./src-ag/ExecutionPlan2Hs.ag" #-} _field {-# LINE 634 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule27 #-} {-# LINE 302 "./src-ag/ExecutionPlan2Hs.ag" #-} rule27 = \ name_ -> {-# LINE 302 "./src-ag/ExecutionPlan2Hs.ag" #-} text $ fieldname name_ {-# LINE 640 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule28 #-} {-# LINE 573 "./src-ag/ExecutionPlan2Hs.ag" #-} rule28 = \ tp_ -> {-# LINE 573 "./src-ag/ExecutionPlan2Hs.ag" #-} (pp_parens $ show tp_) >#< "->" {-# LINE 646 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule29 #-} {-# LINE 574 "./src-ag/ExecutionPlan2Hs.ag" #-} rule29 = \ _addbang name_ -> {-# LINE 574 "./src-ag/ExecutionPlan2Hs.ag" #-} _addbang $ text $ fieldname name_ {-# LINE 652 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule30 #-} {-# LINE 916 "./src-ag/ExecutionPlan2Hs.ag" #-} rule30 = \ name_ -> {-# LINE 916 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.singleton name_ (\_ _ -> Right (empty, Set.empty, Map.empty)) {-# LINE 658 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule31 #-} {-# LINE 1308 "./src-ag/ExecutionPlan2Hs.ag" #-} rule31 = \ name_ -> {-# LINE 1308 "./src-ag/ExecutionPlan2Hs.ag" #-} Set.singleton $ fieldname name_ {-# LINE 664 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule32 #-} {-# LINE 1540 "./src-ag/ExecutionPlan2Hs.ag" #-} rule32 = \ ((_lhsIoptions) :: Options) -> {-# LINE 1540 "./src-ag/ExecutionPlan2Hs.ag" #-} \x -> if bangpats _lhsIoptions then "!" >|< x else x {-# LINE 670 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule33 #-} {-# LINE 1591 "./src-ag/ExecutionPlan2Hs.ag" #-} rule33 = \ name_ tp_ -> {-# LINE 1591 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.singleton name_ tp_ {-# LINE 676 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule34 #-} rule34 = \ (_ :: ()) -> Set.empty {-# INLINE rule35 #-} rule35 = \ _argpats -> _argpats -- EChildren --------------------------------------------------- -- wrapper data Inh_EChildren = Inh_EChildren { allInitStates_Inh_EChildren :: (Map NontermIdent Int), con_Inh_EChildren :: (ConstructorIdent), importBlocks_Inh_EChildren :: (PP_Doc), mainFile_Inh_EChildren :: (String), mainName_Inh_EChildren :: (String), moduleHeader_Inh_EChildren :: (String -> String -> String -> Bool -> String), nt_Inh_EChildren :: (NontermIdent), options_Inh_EChildren :: (Options), pragmaBlocks_Inh_EChildren :: (String), textBlocks_Inh_EChildren :: (PP_Doc) } data Syn_EChildren = Syn_EChildren { argnamesw_Syn_EChildren :: ([PP_Doc]), argpats_Syn_EChildren :: ( [PP_Doc] ), argtps_Syn_EChildren :: ( [PP_Doc] ), childTypes_Syn_EChildren :: (Map Identifier Type), childintros_Syn_EChildren :: (Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))), datatype_Syn_EChildren :: ([PP_Doc]), terminaldefs_Syn_EChildren :: (Set String), usedArgs_Syn_EChildren :: (Set String) } {-# INLINABLE wrap_EChildren #-} wrap_EChildren :: T_EChildren -> Inh_EChildren -> (Syn_EChildren ) wrap_EChildren (T_EChildren act) (Inh_EChildren _lhsIallInitStates _lhsIcon _lhsIimportBlocks _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInt _lhsIoptions _lhsIpragmaBlocks _lhsItextBlocks) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_EChildren_vIn4 _lhsIallInitStates _lhsIcon _lhsIimportBlocks _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInt _lhsIoptions _lhsIpragmaBlocks _lhsItextBlocks (T_EChildren_vOut4 _lhsOargnamesw _lhsOargpats _lhsOargtps _lhsOchildTypes _lhsOchildintros _lhsOdatatype _lhsOterminaldefs _lhsOusedArgs) <- return (inv_EChildren_s5 sem arg) return (Syn_EChildren _lhsOargnamesw _lhsOargpats _lhsOargtps _lhsOchildTypes _lhsOchildintros _lhsOdatatype _lhsOterminaldefs _lhsOusedArgs) ) -- cata {-# NOINLINE sem_EChildren #-} sem_EChildren :: EChildren -> T_EChildren sem_EChildren list = Prelude.foldr sem_EChildren_Cons sem_EChildren_Nil (Prelude.map sem_EChild list) -- semantic domain newtype T_EChildren = T_EChildren { attach_T_EChildren :: Identity (T_EChildren_s5 ) } newtype T_EChildren_s5 = C_EChildren_s5 { inv_EChildren_s5 :: (T_EChildren_v4 ) } data T_EChildren_s6 = C_EChildren_s6 type T_EChildren_v4 = (T_EChildren_vIn4 ) -> (T_EChildren_vOut4 ) data T_EChildren_vIn4 = T_EChildren_vIn4 (Map NontermIdent Int) (ConstructorIdent) (PP_Doc) (String) (String) (String -> String -> String -> Bool -> String) (NontermIdent) (Options) (String) (PP_Doc) data T_EChildren_vOut4 = T_EChildren_vOut4 ([PP_Doc]) ( [PP_Doc] ) ( [PP_Doc] ) (Map Identifier Type) (Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))) ([PP_Doc]) (Set String) (Set String) {-# NOINLINE sem_EChildren_Cons #-} sem_EChildren_Cons :: T_EChild -> T_EChildren -> T_EChildren sem_EChildren_Cons arg_hd_ arg_tl_ = T_EChildren (return st5) where {-# NOINLINE st5 #-} st5 = let v4 :: T_EChildren_v4 v4 = \ (T_EChildren_vIn4 _lhsIallInitStates _lhsIcon _lhsIimportBlocks _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInt _lhsIoptions _lhsIpragmaBlocks _lhsItextBlocks) -> ( let _hdX2 = Control.Monad.Identity.runIdentity (attach_T_EChild (arg_hd_)) _tlX5 = Control.Monad.Identity.runIdentity (attach_T_EChildren (arg_tl_)) (T_EChild_vOut1 _hdIargnamesw _hdIargpats _hdIargtps _hdIchildTypes _hdIchildintros _hdIdatatype _hdIterminaldefs _hdIusedArgs) = inv_EChild_s2 _hdX2 (T_EChild_vIn1 _hdOallInitStates _hdOcon _hdOimportBlocks _hdOmainFile _hdOmainName _hdOmoduleHeader _hdOnt _hdOoptions _hdOpragmaBlocks _hdOtextBlocks) (T_EChildren_vOut4 _tlIargnamesw _tlIargpats _tlIargtps _tlIchildTypes _tlIchildintros _tlIdatatype _tlIterminaldefs _tlIusedArgs) = inv_EChildren_s5 _tlX5 (T_EChildren_vIn4 _tlOallInitStates _tlOcon _tlOimportBlocks _tlOmainFile _tlOmainName _tlOmoduleHeader _tlOnt _tlOoptions _tlOpragmaBlocks _tlOtextBlocks) _lhsOargnamesw :: [PP_Doc] _lhsOargnamesw = rule36 _hdIargnamesw _tlIargnamesw _lhsOargpats :: [PP_Doc] _lhsOargpats = rule37 _hdIargpats _tlIargpats _lhsOargtps :: [PP_Doc] _lhsOargtps = rule38 _hdIargtps _tlIargtps _lhsOchildTypes :: Map Identifier Type _lhsOchildTypes = rule39 _hdIchildTypes _tlIchildTypes _lhsOchildintros :: Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr))) _lhsOchildintros = rule40 _hdIchildintros _tlIchildintros _lhsOdatatype :: [PP_Doc] _lhsOdatatype = rule41 _hdIdatatype _tlIdatatype _lhsOterminaldefs :: Set String _lhsOterminaldefs = rule42 _hdIterminaldefs _tlIterminaldefs _lhsOusedArgs :: Set String _lhsOusedArgs = rule43 _hdIusedArgs _tlIusedArgs _hdOallInitStates = rule44 _lhsIallInitStates _hdOcon = rule45 _lhsIcon _hdOimportBlocks = rule46 _lhsIimportBlocks _hdOmainFile = rule47 _lhsImainFile _hdOmainName = rule48 _lhsImainName _hdOmoduleHeader = rule49 _lhsImoduleHeader _hdOnt = rule50 _lhsInt _hdOoptions = rule51 _lhsIoptions _hdOpragmaBlocks = rule52 _lhsIpragmaBlocks _hdOtextBlocks = rule53 _lhsItextBlocks _tlOallInitStates = rule54 _lhsIallInitStates _tlOcon = rule55 _lhsIcon _tlOimportBlocks = rule56 _lhsIimportBlocks _tlOmainFile = rule57 _lhsImainFile _tlOmainName = rule58 _lhsImainName _tlOmoduleHeader = rule59 _lhsImoduleHeader _tlOnt = rule60 _lhsInt _tlOoptions = rule61 _lhsIoptions _tlOpragmaBlocks = rule62 _lhsIpragmaBlocks _tlOtextBlocks = rule63 _lhsItextBlocks __result_ = T_EChildren_vOut4 _lhsOargnamesw _lhsOargpats _lhsOargtps _lhsOchildTypes _lhsOchildintros _lhsOdatatype _lhsOterminaldefs _lhsOusedArgs in __result_ ) in C_EChildren_s5 v4 {-# INLINE rule36 #-} rule36 = \ ((_hdIargnamesw) :: PP_Doc ) ((_tlIargnamesw) :: [PP_Doc]) -> _hdIargnamesw : _tlIargnamesw {-# INLINE rule37 #-} rule37 = \ ((_hdIargpats) :: PP_Doc ) ((_tlIargpats) :: [PP_Doc] ) -> _hdIargpats : _tlIargpats {-# INLINE rule38 #-} rule38 = \ ((_hdIargtps) :: PP_Doc ) ((_tlIargtps) :: [PP_Doc] ) -> _hdIargtps : _tlIargtps {-# INLINE rule39 #-} rule39 = \ ((_hdIchildTypes) :: Map Identifier Type) ((_tlIchildTypes) :: Map Identifier Type) -> _hdIchildTypes `mappend` _tlIchildTypes {-# INLINE rule40 #-} rule40 = \ ((_hdIchildintros) :: Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))) ((_tlIchildintros) :: Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))) -> _hdIchildintros `Map.union` _tlIchildintros {-# INLINE rule41 #-} rule41 = \ ((_hdIdatatype) :: PP_Doc) ((_tlIdatatype) :: [PP_Doc]) -> _hdIdatatype : _tlIdatatype {-# INLINE rule42 #-} rule42 = \ ((_hdIterminaldefs) :: Set String) ((_tlIterminaldefs) :: Set String) -> _hdIterminaldefs `Set.union` _tlIterminaldefs {-# INLINE rule43 #-} rule43 = \ ((_hdIusedArgs) :: Set String) ((_tlIusedArgs) :: Set String) -> _hdIusedArgs `Set.union` _tlIusedArgs {-# INLINE rule44 #-} rule44 = \ ((_lhsIallInitStates) :: Map NontermIdent Int) -> _lhsIallInitStates {-# INLINE rule45 #-} rule45 = \ ((_lhsIcon) :: ConstructorIdent) -> _lhsIcon {-# INLINE rule46 #-} rule46 = \ ((_lhsIimportBlocks) :: PP_Doc) -> _lhsIimportBlocks {-# INLINE rule47 #-} rule47 = \ ((_lhsImainFile) :: String) -> _lhsImainFile {-# INLINE rule48 #-} rule48 = \ ((_lhsImainName) :: String) -> _lhsImainName {-# INLINE rule49 #-} rule49 = \ ((_lhsImoduleHeader) :: String -> String -> String -> Bool -> String) -> _lhsImoduleHeader {-# INLINE rule50 #-} rule50 = \ ((_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule51 #-} rule51 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule52 #-} rule52 = \ ((_lhsIpragmaBlocks) :: String) -> _lhsIpragmaBlocks {-# INLINE rule53 #-} rule53 = \ ((_lhsItextBlocks) :: PP_Doc) -> _lhsItextBlocks {-# INLINE rule54 #-} rule54 = \ ((_lhsIallInitStates) :: Map NontermIdent Int) -> _lhsIallInitStates {-# INLINE rule55 #-} rule55 = \ ((_lhsIcon) :: ConstructorIdent) -> _lhsIcon {-# INLINE rule56 #-} rule56 = \ ((_lhsIimportBlocks) :: PP_Doc) -> _lhsIimportBlocks {-# INLINE rule57 #-} rule57 = \ ((_lhsImainFile) :: String) -> _lhsImainFile {-# INLINE rule58 #-} rule58 = \ ((_lhsImainName) :: String) -> _lhsImainName {-# INLINE rule59 #-} rule59 = \ ((_lhsImoduleHeader) :: String -> String -> String -> Bool -> String) -> _lhsImoduleHeader {-# INLINE rule60 #-} rule60 = \ ((_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule61 #-} rule61 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule62 #-} rule62 = \ ((_lhsIpragmaBlocks) :: String) -> _lhsIpragmaBlocks {-# INLINE rule63 #-} rule63 = \ ((_lhsItextBlocks) :: PP_Doc) -> _lhsItextBlocks {-# NOINLINE sem_EChildren_Nil #-} sem_EChildren_Nil :: T_EChildren sem_EChildren_Nil = T_EChildren (return st5) where {-# NOINLINE st5 #-} st5 = let v4 :: T_EChildren_v4 v4 = \ (T_EChildren_vIn4 _lhsIallInitStates _lhsIcon _lhsIimportBlocks _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInt _lhsIoptions _lhsIpragmaBlocks _lhsItextBlocks) -> ( let _lhsOargnamesw :: [PP_Doc] _lhsOargnamesw = rule64 () _lhsOargpats :: [PP_Doc] _lhsOargpats = rule65 () _lhsOargtps :: [PP_Doc] _lhsOargtps = rule66 () _lhsOchildTypes :: Map Identifier Type _lhsOchildTypes = rule67 () _lhsOchildintros :: Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr))) _lhsOchildintros = rule68 () _lhsOdatatype :: [PP_Doc] _lhsOdatatype = rule69 () _lhsOterminaldefs :: Set String _lhsOterminaldefs = rule70 () _lhsOusedArgs :: Set String _lhsOusedArgs = rule71 () __result_ = T_EChildren_vOut4 _lhsOargnamesw _lhsOargpats _lhsOargtps _lhsOchildTypes _lhsOchildintros _lhsOdatatype _lhsOterminaldefs _lhsOusedArgs in __result_ ) in C_EChildren_s5 v4 {-# INLINE rule64 #-} rule64 = \ (_ :: ()) -> [] {-# INLINE rule65 #-} rule65 = \ (_ :: ()) -> [] {-# INLINE rule66 #-} rule66 = \ (_ :: ()) -> [] {-# INLINE rule67 #-} rule67 = \ (_ :: ()) -> mempty {-# INLINE rule68 #-} rule68 = \ (_ :: ()) -> Map.empty {-# INLINE rule69 #-} rule69 = \ (_ :: ()) -> [] {-# INLINE rule70 #-} rule70 = \ (_ :: ()) -> Set.empty {-# INLINE rule71 #-} rule71 = \ (_ :: ()) -> Set.empty -- ENonterminal ------------------------------------------------ -- wrapper data Inh_ENonterminal = Inh_ENonterminal { allFromToStates_Inh_ENonterminal :: (Map VisitIdentifier (Int,Int)), allInitStates_Inh_ENonterminal :: (Map NontermIdent Int), allVisitKinds_Inh_ENonterminal :: (Map VisitIdentifier VisitKind), allchildvisit_Inh_ENonterminal :: (Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))), avisitdefs_Inh_ENonterminal :: (Map VisitIdentifier (Set Identifier)), avisituses_Inh_ENonterminal :: (Map VisitIdentifier (Set Identifier)), derivings_Inh_ENonterminal :: (Derivings), importBlocks_Inh_ENonterminal :: (PP_Doc), inhmap_Inh_ENonterminal :: (Map NontermIdent Attributes), localAttrTypes_Inh_ENonterminal :: (Map NontermIdent (Map ConstructorIdent (Map Identifier Type))), mainFile_Inh_ENonterminal :: (String), mainName_Inh_ENonterminal :: (String), moduleHeader_Inh_ENonterminal :: (String -> String -> String -> Bool -> String), options_Inh_ENonterminal :: (Options), pragmaBlocks_Inh_ENonterminal :: (String), synmap_Inh_ENonterminal :: (Map NontermIdent Attributes), textBlocks_Inh_ENonterminal :: (PP_Doc), typeSyns_Inh_ENonterminal :: (TypeSyns), wrappers_Inh_ENonterminal :: (Set NontermIdent) } data Syn_ENonterminal = Syn_ENonterminal { appendCommon_Syn_ENonterminal :: ( PP_Doc ), appendMain_Syn_ENonterminal :: ( PP_Doc ), childvisit_Syn_ENonterminal :: (Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))), errors_Syn_ENonterminal :: (Seq Error), fromToStates_Syn_ENonterminal :: (Map VisitIdentifier (Int,Int)), genProdIO_Syn_ENonterminal :: (IO ()), imports_Syn_ENonterminal :: ([PP_Doc]), initStates_Syn_ENonterminal :: (Map NontermIdent Int), output_Syn_ENonterminal :: (PP_Doc), semFunBndDefs_Syn_ENonterminal :: (Seq PP_Doc), semFunBndTps_Syn_ENonterminal :: (Seq PP_Doc), visitKinds_Syn_ENonterminal :: (Map VisitIdentifier VisitKind), visitdefs_Syn_ENonterminal :: (Map VisitIdentifier (Set Identifier)), visituses_Syn_ENonterminal :: (Map VisitIdentifier (Set Identifier)) } {-# INLINABLE wrap_ENonterminal #-} wrap_ENonterminal :: T_ENonterminal -> Inh_ENonterminal -> (Syn_ENonterminal ) wrap_ENonterminal (T_ENonterminal act) (Inh_ENonterminal _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIderivings _lhsIimportBlocks _lhsIinhmap _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsIoptions _lhsIpragmaBlocks _lhsIsynmap _lhsItextBlocks _lhsItypeSyns _lhsIwrappers) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_ENonterminal_vIn7 _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIderivings _lhsIimportBlocks _lhsIinhmap _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsIoptions _lhsIpragmaBlocks _lhsIsynmap _lhsItextBlocks _lhsItypeSyns _lhsIwrappers (T_ENonterminal_vOut7 _lhsOappendCommon _lhsOappendMain _lhsOchildvisit _lhsOerrors _lhsOfromToStates _lhsOgenProdIO _lhsOimports _lhsOinitStates _lhsOoutput _lhsOsemFunBndDefs _lhsOsemFunBndTps _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses) <- return (inv_ENonterminal_s8 sem arg) return (Syn_ENonterminal _lhsOappendCommon _lhsOappendMain _lhsOchildvisit _lhsOerrors _lhsOfromToStates _lhsOgenProdIO _lhsOimports _lhsOinitStates _lhsOoutput _lhsOsemFunBndDefs _lhsOsemFunBndTps _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses) ) -- cata {-# INLINE sem_ENonterminal #-} sem_ENonterminal :: ENonterminal -> T_ENonterminal sem_ENonterminal ( ENonterminal nt_ params_ classCtxs_ initial_ initialv_ nextVisits_ prevVisits_ prods_ recursive_ hoInfo_ ) = sem_ENonterminal_ENonterminal nt_ params_ classCtxs_ initial_ initialv_ nextVisits_ prevVisits_ ( sem_EProductions prods_ ) recursive_ hoInfo_ -- semantic domain newtype T_ENonterminal = T_ENonterminal { attach_T_ENonterminal :: Identity (T_ENonterminal_s8 ) } newtype T_ENonterminal_s8 = C_ENonterminal_s8 { inv_ENonterminal_s8 :: (T_ENonterminal_v7 ) } data T_ENonterminal_s9 = C_ENonterminal_s9 type T_ENonterminal_v7 = (T_ENonterminal_vIn7 ) -> (T_ENonterminal_vOut7 ) data T_ENonterminal_vIn7 = T_ENonterminal_vIn7 (Map VisitIdentifier (Int,Int)) (Map NontermIdent Int) (Map VisitIdentifier VisitKind) (Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) (Map VisitIdentifier (Set Identifier)) (Map VisitIdentifier (Set Identifier)) (Derivings) (PP_Doc) (Map NontermIdent Attributes) (Map NontermIdent (Map ConstructorIdent (Map Identifier Type))) (String) (String) (String -> String -> String -> Bool -> String) (Options) (String) (Map NontermIdent Attributes) (PP_Doc) (TypeSyns) (Set NontermIdent) data T_ENonterminal_vOut7 = T_ENonterminal_vOut7 ( PP_Doc ) ( PP_Doc ) (Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) (Seq Error) (Map VisitIdentifier (Int,Int)) (IO ()) ([PP_Doc]) (Map NontermIdent Int) (PP_Doc) (Seq PP_Doc) (Seq PP_Doc) (Map VisitIdentifier VisitKind) (Map VisitIdentifier (Set Identifier)) (Map VisitIdentifier (Set Identifier)) {-# NOINLINE sem_ENonterminal_ENonterminal #-} sem_ENonterminal_ENonterminal :: (NontermIdent) -> ([Identifier]) -> (ClassContext) -> (StateIdentifier) -> (Maybe VisitIdentifier) -> (Map StateIdentifier StateCtx) -> (Map StateIdentifier StateCtx) -> T_EProductions -> (Bool) -> (HigherOrderInfo) -> T_ENonterminal sem_ENonterminal_ENonterminal arg_nt_ arg_params_ arg_classCtxs_ arg_initial_ arg_initialv_ arg_nextVisits_ arg_prevVisits_ arg_prods_ arg_recursive_ _ = T_ENonterminal (return st8) where {-# NOINLINE st8 #-} st8 = let v7 :: T_ENonterminal_v7 v7 = \ (T_ENonterminal_vIn7 _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIderivings _lhsIimportBlocks _lhsIinhmap _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsIoptions _lhsIpragmaBlocks _lhsIsynmap _lhsItextBlocks _lhsItypeSyns _lhsIwrappers) -> ( let _prodsX17 = Control.Monad.Identity.runIdentity (attach_T_EProductions (arg_prods_)) (T_EProductions_vOut16 _prodsIallvisits _prodsIchildvisit _prodsIcount _prodsIdatatype _prodsIerrors _prodsIfromToStates _prodsIgenProdIO _prodsIimports _prodsIsemFunBndDefs _prodsIsemFunBndTps _prodsIsem_nt _prodsIsem_prod _prodsIt_visits _prodsIvisitKinds _prodsIvisitdefs _prodsIvisituses) = inv_EProductions_s17 _prodsX17 (T_EProductions_vIn16 _prodsOallFromToStates _prodsOallInhmap _prodsOallInitStates _prodsOallSynmap _prodsOallVisitKinds _prodsOallchildvisit _prodsOallstates _prodsOavisitdefs _prodsOavisituses _prodsOclassCtxs _prodsOimportBlocks _prodsOinhmap _prodsOinitial _prodsOlocalAttrTypes _prodsOmainFile _prodsOmainName _prodsOmoduleHeader _prodsOnextVisits _prodsOnt _prodsOntType _prodsOoptions _prodsOparams _prodsOpragmaBlocks _prodsOprevVisits _prodsOrename _prodsOsynmap _prodsOtextBlocks) _prodsOrename = rule72 _lhsIoptions _prodsOnt = rule73 arg_nt_ _prodsOparams = rule74 arg_params_ _prodsOclassCtxs = rule75 arg_classCtxs_ _lhsOoutput :: PP_Doc _lhsOoutput = rule76 _datatype _hasWrapper _k_states _lhsIoptions _prodsIsem_prod _prodsIt_visits _sem_nt _t_init _t_states _wr_inh _wr_syn _wrapper arg_nt_ _hasWrapper = rule77 _lhsIwrappers arg_nt_ _classPP = rule78 arg_classCtxs_ _aliasPre = rule79 _classPP _t_params arg_nt_ _datatype = rule80 _aliasPre _classPP _derivings _lhsItypeSyns _prodsIdatatype _t_params arg_nt_ _derivings = rule81 _lhsIderivings arg_nt_ _fsemname = rule82 () _semname = rule83 _fsemname arg_nt_ _frecarg = rule84 _fsemname _sem_tp = rule85 _classPP _quantPP _t_params _t_type arg_nt_ _quantPP = rule86 arg_params_ _sem_nt = rule87 _frecarg _fsemname _lhsItypeSyns _prodsIsem_nt _semPragma _sem_tp _semname arg_nt_ _inlineNt = rule88 _hasWrapper _lhsIoptions _prodsIcount arg_recursive_ _semPragma = rule89 _inlineNt _lhsIoptions _semname (Just _prodsOinhmap) = rule90 _lhsIinhmap arg_nt_ (Just _prodsOsynmap) = rule91 _lhsIsynmap arg_nt_ _prodsOallInhmap = rule92 _lhsIinhmap _prodsOallSynmap = rule93 _lhsIsynmap _outedges = rule94 _prodsIallvisits _inedges = rule95 _prodsIallvisits _allstates = rule96 _inedges _outedges arg_initial_ _stvisits = rule97 _prodsIallvisits _t_type = rule98 arg_nt_ _t_params = rule99 arg_params_ _t_init = rule100 _lhsIoptions _t_params _t_type arg_initial_ _t_states = rule101 _allstates _t_params arg_nextVisits_ arg_nt_ _k_type = rule102 arg_nt_ _k_states = rule103 _allstates _k_type _prodsIallvisits _t_params _t_type arg_nextVisits_ arg_nt_ _wr_inh = rule104 _genwrap _wr_inhs _wr_syn = rule105 _genwrap _wr_syns _genwrap = rule106 _addbang _t_params arg_nt_ _synAttrs = rule107 _lhsIinhmap arg_nt_ _wr_inhs = rule108 _synAttrs _wr_filter _wr_inhs1 = rule109 _synAttrs _wr_filter = rule110 _lhsIoptions _wr_syns = rule111 _lhsIsynmap arg_nt_ _inhlist = rule112 _wr_inhs _inhlist1 = rule113 _wr_inhs1 _synlist = rule114 _wr_syns _wrapname = rule115 arg_nt_ _inhname = rule116 arg_nt_ _synname = rule117 arg_nt_ _firstVisitInfo = rule118 arg_initial_ arg_nextVisits_ _wrapper = rule119 _addbang _addbangWrap _classPP _firstVisitInfo _inhlist _inhlist1 _inhname _k_type _lhsIallVisitKinds _lhsImainName _lhsIoptions _quantPP _synlist _synname _t_params _t_type _wrapPragma _wrapname arg_initial_ arg_initialv_ arg_nt_ _wrapPragma = rule120 _lhsIoptions _wrapname _lhsOsemFunBndDefs :: Seq PP_Doc _lhsOsemFunBndDefs = rule121 _prodsIsemFunBndDefs _semFunBndDef _lhsOsemFunBndTps :: Seq PP_Doc _lhsOsemFunBndTps = rule122 _prodsIsemFunBndTps _semFunBndTp _semFunBndDef = rule123 _semFunBndNm _semname _semFunBndTp = rule124 _semFunBndNm _sem_tp _semFunBndNm = rule125 arg_nt_ _prodsOinitial = rule126 arg_initial_ _prodsOallstates = rule127 _allstates _lhsOappendMain :: PP_Doc _lhsOappendMain = rule128 _lhsIwrappers _sem_nt _wr_inh _wr_syn _wrapper arg_nt_ _lhsOappendCommon :: PP_Doc _lhsOappendCommon = rule129 _datatype _k_states _lhsIoptions _prodsIt_visits _t_init _t_states _addbang = rule130 _lhsIoptions _addbangWrap = rule131 () _prodsOnextVisits = rule132 arg_nextVisits_ _prodsOprevVisits = rule133 arg_prevVisits_ _prodsOlocalAttrTypes = rule134 _lhsIlocalAttrTypes arg_nt_ _lhsOinitStates :: Map NontermIdent Int _lhsOinitStates = rule135 arg_initial_ arg_nt_ _ntType = rule136 arg_nt_ arg_params_ _lhsOchildvisit :: Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc)) _lhsOchildvisit = rule137 _prodsIchildvisit _lhsOerrors :: Seq Error _lhsOerrors = rule138 _prodsIerrors _lhsOfromToStates :: Map VisitIdentifier (Int,Int) _lhsOfromToStates = rule139 _prodsIfromToStates _lhsOgenProdIO :: IO () _lhsOgenProdIO = rule140 _prodsIgenProdIO _lhsOimports :: [PP_Doc] _lhsOimports = rule141 _prodsIimports _lhsOvisitKinds :: Map VisitIdentifier VisitKind _lhsOvisitKinds = rule142 _prodsIvisitKinds _lhsOvisitdefs :: Map VisitIdentifier (Set Identifier) _lhsOvisitdefs = rule143 _prodsIvisitdefs _lhsOvisituses :: Map VisitIdentifier (Set Identifier) _lhsOvisituses = rule144 _prodsIvisituses _prodsOallFromToStates = rule145 _lhsIallFromToStates _prodsOallInitStates = rule146 _lhsIallInitStates _prodsOallVisitKinds = rule147 _lhsIallVisitKinds _prodsOallchildvisit = rule148 _lhsIallchildvisit _prodsOavisitdefs = rule149 _lhsIavisitdefs _prodsOavisituses = rule150 _lhsIavisituses _prodsOimportBlocks = rule151 _lhsIimportBlocks _prodsOmainFile = rule152 _lhsImainFile _prodsOmainName = rule153 _lhsImainName _prodsOmoduleHeader = rule154 _lhsImoduleHeader _prodsOntType = rule155 _ntType _prodsOoptions = rule156 _lhsIoptions _prodsOpragmaBlocks = rule157 _lhsIpragmaBlocks _prodsOtextBlocks = rule158 _lhsItextBlocks __result_ = T_ENonterminal_vOut7 _lhsOappendCommon _lhsOappendMain _lhsOchildvisit _lhsOerrors _lhsOfromToStates _lhsOgenProdIO _lhsOimports _lhsOinitStates _lhsOoutput _lhsOsemFunBndDefs _lhsOsemFunBndTps _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses in __result_ ) in C_ENonterminal_s8 v7 {-# INLINE rule72 #-} {-# LINE 55 "./src-ag/ExecutionPlan2Hs.ag" #-} rule72 = \ ((_lhsIoptions) :: Options) -> {-# LINE 55 "./src-ag/ExecutionPlan2Hs.ag" #-} rename _lhsIoptions {-# LINE 1047 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule73 #-} {-# LINE 63 "./src-ag/ExecutionPlan2Hs.ag" #-} rule73 = \ nt_ -> {-# LINE 63 "./src-ag/ExecutionPlan2Hs.ag" #-} nt_ {-# LINE 1053 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule74 #-} {-# LINE 75 "./src-ag/ExecutionPlan2Hs.ag" #-} rule74 = \ params_ -> {-# LINE 75 "./src-ag/ExecutionPlan2Hs.ag" #-} params_ {-# LINE 1059 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule75 #-} {-# LINE 79 "./src-ag/ExecutionPlan2Hs.ag" #-} rule75 = \ classCtxs_ -> {-# LINE 79 "./src-ag/ExecutionPlan2Hs.ag" #-} classCtxs_ {-# LINE 1065 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule76 #-} {-# LINE 96 "./src-ag/ExecutionPlan2Hs.ag" #-} rule76 = \ _datatype _hasWrapper _k_states ((_lhsIoptions) :: Options) ((_prodsIsem_prod) :: PP_Doc) ((_prodsIt_visits) :: PP_Doc) _sem_nt _t_init _t_states _wr_inh _wr_syn _wrapper nt_ -> {-# LINE 96 "./src-ag/ExecutionPlan2Hs.ag" #-} ("-- " ++ getName nt_ ++ " " ++ replicate (60 - length (getName nt_)) '-') >-< (if dataTypes _lhsIoptions then "-- data" >-< _datatype >-< "" else empty) >-< (if _hasWrapper then "-- wrapper" >-< _wr_inh >-< _wr_syn >-< _wrapper >-< "" else empty) >-< (if folds _lhsIoptions then "-- cata" >-< _sem_nt >-< "" else empty) >-< (if semfuns _lhsIoptions then "-- semantic domain" >-< _t_init >-< _t_states >-< _k_states >-< _prodsIt_visits >-< _prodsIsem_prod >-< "" else empty) {-# LINE 1097 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule77 #-} {-# LINE 123 "./src-ag/ExecutionPlan2Hs.ag" #-} rule77 = \ ((_lhsIwrappers) :: Set NontermIdent) nt_ -> {-# LINE 123 "./src-ag/ExecutionPlan2Hs.ag" #-} nt_ `Set.member` _lhsIwrappers {-# LINE 1103 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule78 #-} {-# LINE 136 "./src-ag/ExecutionPlan2Hs.ag" #-} rule78 = \ classCtxs_ -> {-# LINE 136 "./src-ag/ExecutionPlan2Hs.ag" #-} ppClasses $ classCtxsToDocs classCtxs_ {-# LINE 1109 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule79 #-} {-# LINE 137 "./src-ag/ExecutionPlan2Hs.ag" #-} rule79 = \ _classPP _t_params nt_ -> {-# LINE 137 "./src-ag/ExecutionPlan2Hs.ag" #-} "type" >#< _classPP >#< nt_ >#< _t_params >#< "=" {-# LINE 1115 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule80 #-} {-# LINE 138 "./src-ag/ExecutionPlan2Hs.ag" #-} rule80 = \ _aliasPre _classPP _derivings ((_lhsItypeSyns) :: TypeSyns) ((_prodsIdatatype) :: [PP_Doc]) _t_params nt_ -> {-# LINE 138 "./src-ag/ExecutionPlan2Hs.ag" #-} case lookup nt_ _lhsItypeSyns of Nothing -> "data" >#< _classPP >#< nt_ >#< _t_params >-< ( if null _prodsIdatatype then empty else indent 2 $ vlist $ ( ("=" >#< head _prodsIdatatype) : (map ("|" >#<) $ tail _prodsIdatatype)) ) >-< indent 2 _derivings Just (List t) -> _aliasPre >#< "[" >#< show t >#< "]" Just (Maybe t) -> _aliasPre >#< "Maybe" >#< show t Just (Tuple ts) -> _aliasPre >#< pp_parens (ppCommas $ map (show . snd) ts) Just (Either l r) -> _aliasPre >#< "Either" >#< show l >#< show r Just (Map k v) -> _aliasPre >#< "Data.Map" >#< pp_parens (show k) >#< show v Just (IntMap t) -> _aliasPre >#< "Data.IntMap.IntMap" >#< show t Just (OrdSet t) -> _aliasPre >#< "Data.Set.Set" >#< show t Just IntSet -> _aliasPre >#< "Data.IntSet.IntSet" {-# LINE 1136 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule81 #-} {-# LINE 155 "./src-ag/ExecutionPlan2Hs.ag" #-} rule81 = \ ((_lhsIderivings) :: Derivings) nt_ -> {-# LINE 155 "./src-ag/ExecutionPlan2Hs.ag" #-} case Map.lookup nt_ _lhsIderivings of Nothing -> empty Just s -> if Set.null s then empty else "deriving" >#< (pp_parens $ ppCommas $ map pp $ Set.toList s) {-# LINE 1146 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule82 #-} {-# LINE 225 "./src-ag/ExecutionPlan2Hs.ag" #-} rule82 = \ (_ :: ()) -> {-# LINE 225 "./src-ag/ExecutionPlan2Hs.ag" #-} \x -> "sem_" ++ show x {-# LINE 1152 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule83 #-} {-# LINE 226 "./src-ag/ExecutionPlan2Hs.ag" #-} rule83 = \ _fsemname nt_ -> {-# LINE 226 "./src-ag/ExecutionPlan2Hs.ag" #-} _fsemname nt_ {-# LINE 1158 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule84 #-} {-# LINE 227 "./src-ag/ExecutionPlan2Hs.ag" #-} rule84 = \ _fsemname -> {-# LINE 227 "./src-ag/ExecutionPlan2Hs.ag" #-} \t x -> case t of NT nt _ _ -> pp_parens (_fsemname nt >#< x) _ -> pp x {-# LINE 1166 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule85 #-} {-# LINE 233 "./src-ag/ExecutionPlan2Hs.ag" #-} rule85 = \ _classPP _quantPP _t_params _t_type nt_ -> {-# LINE 233 "./src-ag/ExecutionPlan2Hs.ag" #-} _quantPP >#< _classPP >#< nt_ >#< _t_params >#< "->" >#< _t_type >#< _t_params {-# LINE 1172 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule86 #-} {-# LINE 234 "./src-ag/ExecutionPlan2Hs.ag" #-} rule86 = \ params_ -> {-# LINE 234 "./src-ag/ExecutionPlan2Hs.ag" #-} ppQuants params_ {-# LINE 1178 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule87 #-} {-# LINE 235 "./src-ag/ExecutionPlan2Hs.ag" #-} rule87 = \ _frecarg _fsemname ((_lhsItypeSyns) :: TypeSyns) ((_prodsIsem_nt) :: PP_Doc) _semPragma _sem_tp _semname nt_ -> {-# LINE 235 "./src-ag/ExecutionPlan2Hs.ag" #-} _semPragma >-< _semname >#< "::" >#< _sem_tp >-< case lookup nt_ _lhsItypeSyns of Nothing -> _prodsIsem_nt Just (List t) -> _semname >#< "list" >#< "=" >#< "Prelude.foldr" >#< _semname >|< "_Cons" >#< _semname >|< "_Nil" >#< case t of NT nt _ _ -> pp_parens ("Prelude.map" >#< _fsemname nt >#< "list") _ -> pp "list" Just (Maybe t) -> _semname >#< "Prelude.Nothing" >#< "=" >#< _semname >|< "_Nothing" >-< _semname >#< pp_parens ("Prelude.Just just") >#< "=" >#< _semname >|< "_Just" >#< _frecarg t "just" Just (Tuple ts) -> _semname >#< pp_parens (ppCommas $ map fst ts) >#< "=" >#< _semname >|< "_Tuple" >#< ppSpaced (map (\t -> _frecarg (snd t) (show $ fst t)) ts) Just (Either l r) -> _semname >#< "(Prelude.Left left)" >#< "=" >#< _semname >|< "_Left" >#< _frecarg l "left" >-< _semname >#< "(Prelude.Right right)" >#< "=" >#< _semname >|< "_Right" >#< _frecarg r "right" Just (Map k v) -> _semname >#< "m" >#< "=" >#< "Data.Map.foldrWithKey" >#< _semname >|< "_Entry" >#< _semname >|< "_Nil" >#< case v of NT nt _ _ -> pp_parens ("Data.Map.map" >#< _fsemname nt >#< "m") _ -> pp "m" Just (IntMap v) -> _semname >#< "m" >#< "=" >#< "Data.IntMap.foldWithKey" >#< _semname >|< "_Entry" >#< _semname >|< "_Nil" >#< case v of NT nt _ _ -> pp_parens ("Data.IntMap.map" >#< _fsemname nt >#< "m") _ -> pp "m" Just (OrdSet t) -> _semname >#< "s" >#< "=" >#< "Prelude.foldr" >#< _semname >|< "_Entry" >#< _semname >|< "_Nil" >#< pp_parens ( ( case t of NT nt _ _ -> pp_parens ("Prelude.map" >#< _fsemname nt) _ -> empty ) >#< pp_parens ("Data.IntSet.elems" >#< "s") ) Just IntSet -> _semname >#< "s" >#< "=" >#< "Prelude.foldr" >#< _semname >|< "_Entry" >#< _semname >|< "_Nil" >#< pp_parens ("Data.IntSet.elems" >#< "s") {-# LINE 1220 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule88 #-} {-# LINE 275 "./src-ag/ExecutionPlan2Hs.ag" #-} rule88 = \ _hasWrapper ((_lhsIoptions) :: Options) ((_prodsIcount) :: Int) recursive_ -> {-# LINE 275 "./src-ag/ExecutionPlan2Hs.ag" #-} not (lateHigherOrderBinding _lhsIoptions) && not recursive_ && (_prodsIcount == 1 || (aggressiveInlinePragmas _lhsIoptions && not _hasWrapper )) {-# LINE 1226 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule89 #-} {-# LINE 276 "./src-ag/ExecutionPlan2Hs.ag" #-} rule89 = \ _inlineNt ((_lhsIoptions) :: Options) _semname -> {-# LINE 276 "./src-ag/ExecutionPlan2Hs.ag" #-} if noInlinePragmas _lhsIoptions then empty else if _inlineNt then ppInline _semname else if helpInlining _lhsIoptions && not (lateHigherOrderBinding _lhsIoptions) then ppInlinable _semname else ppNoInline _semname {-# LINE 1238 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule90 #-} {-# LINE 322 "./src-ag/ExecutionPlan2Hs.ag" #-} rule90 = \ ((_lhsIinhmap) :: Map NontermIdent Attributes) nt_ -> {-# LINE 322 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.lookup nt_ _lhsIinhmap {-# LINE 1244 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule91 #-} {-# LINE 323 "./src-ag/ExecutionPlan2Hs.ag" #-} rule91 = \ ((_lhsIsynmap) :: Map NontermIdent Attributes) nt_ -> {-# LINE 323 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.lookup nt_ _lhsIsynmap {-# LINE 1250 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule92 #-} {-# LINE 324 "./src-ag/ExecutionPlan2Hs.ag" #-} rule92 = \ ((_lhsIinhmap) :: Map NontermIdent Attributes) -> {-# LINE 324 "./src-ag/ExecutionPlan2Hs.ag" #-} _lhsIinhmap {-# LINE 1256 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule93 #-} {-# LINE 325 "./src-ag/ExecutionPlan2Hs.ag" #-} rule93 = \ ((_lhsIsynmap) :: Map NontermIdent Attributes) -> {-# LINE 325 "./src-ag/ExecutionPlan2Hs.ag" #-} _lhsIsynmap {-# LINE 1262 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule94 #-} {-# LINE 346 "./src-ag/ExecutionPlan2Hs.ag" #-} rule94 = \ ((_prodsIallvisits) :: [VisitStateState]) -> {-# LINE 346 "./src-ag/ExecutionPlan2Hs.ag" #-} Set.fromList $ map (\(_,f,_) -> f) _prodsIallvisits {-# LINE 1268 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule95 #-} {-# LINE 347 "./src-ag/ExecutionPlan2Hs.ag" #-} rule95 = \ ((_prodsIallvisits) :: [VisitStateState]) -> {-# LINE 347 "./src-ag/ExecutionPlan2Hs.ag" #-} Set.fromList $ map (\(_,_,t) -> t) _prodsIallvisits {-# LINE 1274 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule96 #-} {-# LINE 348 "./src-ag/ExecutionPlan2Hs.ag" #-} rule96 = \ _inedges _outedges initial_ -> {-# LINE 348 "./src-ag/ExecutionPlan2Hs.ag" #-} Set.insert initial_ $ _inedges `Set.union` _outedges {-# LINE 1280 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule97 #-} {-# LINE 349 "./src-ag/ExecutionPlan2Hs.ag" #-} rule97 = \ ((_prodsIallvisits) :: [VisitStateState]) -> {-# LINE 349 "./src-ag/ExecutionPlan2Hs.ag" #-} \st -> filter (\(v,f,t) -> f == st) _prodsIallvisits {-# LINE 1286 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule98 #-} {-# LINE 350 "./src-ag/ExecutionPlan2Hs.ag" #-} rule98 = \ nt_ -> {-# LINE 350 "./src-ag/ExecutionPlan2Hs.ag" #-} "T_" >|< nt_ {-# LINE 1292 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule99 #-} {-# LINE 351 "./src-ag/ExecutionPlan2Hs.ag" #-} rule99 = \ params_ -> {-# LINE 351 "./src-ag/ExecutionPlan2Hs.ag" #-} ppSpaced params_ {-# LINE 1298 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule100 #-} {-# LINE 352 "./src-ag/ExecutionPlan2Hs.ag" #-} rule100 = \ ((_lhsIoptions) :: Options) _t_params _t_type initial_ -> {-# LINE 352 "./src-ag/ExecutionPlan2Hs.ag" #-} "newtype" >#< _t_type >#< _t_params >#< "=" >#< _t_type >#< pp_braces ( "attach_">|< _t_type >#< "::" >#< ppMonadType _lhsIoptions >#< pp_parens (_t_type >|< "_s" >|< initial_ >#< _t_params )) {-# LINE 1307 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule101 #-} {-# LINE 356 "./src-ag/ExecutionPlan2Hs.ag" #-} rule101 = \ _allstates _t_params nextVisits_ nt_ -> {-# LINE 356 "./src-ag/ExecutionPlan2Hs.ag" #-} 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 >#< _t_params >#< "=" >#< c_st OneVis vId -> "newtype" >#< t_st >#< _t_params >#< "=" >#< c_st >#< (pp_braces $ inv_st >#< "::" >#< pp_parens (conNmTVisit nt_ vId >#< _t_params )) ManyVis -> "data" >#< t_st >#< _t_params >#< "where" >#< c_st >#< "::" >#< (pp_braces $ inv_st >#< "::" >#< "!" >|< pp_parens ("forall t." >#< k_st >#< _t_params >#< "t" >#< "->" >#< "t")) >#< "->" >#< t_st >#< _t_params ) $ Set.toList _allstates {-# LINE 1327 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule102 #-} {-# LINE 374 "./src-ag/ExecutionPlan2Hs.ag" #-} rule102 = \ nt_ -> {-# LINE 374 "./src-ag/ExecutionPlan2Hs.ag" #-} "K_" ++ show nt_ {-# LINE 1333 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule103 #-} {-# LINE 375 "./src-ag/ExecutionPlan2Hs.ag" #-} rule103 = \ _allstates _k_type ((_prodsIallvisits) :: [VisitStateState]) _t_params _t_type nextVisits_ nt_ -> {-# LINE 375 "./src-ag/ExecutionPlan2Hs.ag" #-} vlist $ map (\st -> let nt_st = nt_ >|< "_s" >|< st k_st = "K_" >|< nt_st outg = filter (\(v,f,t) -> f == st) _prodsIallvisits visitlist = vlist $ map (\(v,f,t) -> _k_type >|< "_v" >|< v >#< "::" >#< k_st >#< _t_params >#< pp_parens (_t_type >|< "_v" >|< v >#< _t_params ) ) outg nextVisit = Map.findWithDefault ManyVis st nextVisits_ decl = "data" >#< k_st >#< "k" >#< _t_params >#< "where" >-< indent 3 visitlist in case nextVisit of NoneVis -> empty OneVis _ -> empty ManyVis -> decl ) $ Set.toList _allstates {-# LINE 1352 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule104 #-} {-# LINE 442 "./src-ag/ExecutionPlan2Hs.ag" #-} rule104 = \ _genwrap _wr_inhs -> {-# LINE 442 "./src-ag/ExecutionPlan2Hs.ag" #-} _genwrap "Inh" _wr_inhs {-# LINE 1358 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule105 #-} {-# LINE 443 "./src-ag/ExecutionPlan2Hs.ag" #-} rule105 = \ _genwrap _wr_syns -> {-# LINE 443 "./src-ag/ExecutionPlan2Hs.ag" #-} _genwrap "Syn" _wr_syns {-# LINE 1364 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule106 #-} {-# LINE 444 "./src-ag/ExecutionPlan2Hs.ag" #-} rule106 = \ _addbang _t_params nt_ -> {-# LINE 444 "./src-ag/ExecutionPlan2Hs.ag" #-} \nm attr -> "data" >#< nm >|< "_" >|< nt_ >#< _t_params >#< "=" >#< nm >|< "_" >|< nt_ >#< "{" >#< (ppCommas $ map (\(i,t) -> i >|< "_" >|< nm >|< "_" >|< nt_ >#< "::" >#< (_addbang $ pp_parens $ typeToHaskellString (Just nt_) [] t)) attr) >#< "}" {-# LINE 1372 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule107 #-} {-# LINE 447 "./src-ag/ExecutionPlan2Hs.ag" #-} rule107 = \ ((_lhsIinhmap) :: Map NontermIdent Attributes) nt_ -> {-# LINE 447 "./src-ag/ExecutionPlan2Hs.ag" #-} fromJust $ Map.lookup nt_ _lhsIinhmap {-# LINE 1378 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule108 #-} {-# LINE 448 "./src-ag/ExecutionPlan2Hs.ag" #-} rule108 = \ _synAttrs _wr_filter -> {-# LINE 448 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.toList $ _wr_filter $ _synAttrs {-# LINE 1384 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule109 #-} {-# LINE 449 "./src-ag/ExecutionPlan2Hs.ag" #-} rule109 = \ _synAttrs -> {-# LINE 449 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.toList _synAttrs {-# LINE 1390 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule110 #-} {-# LINE 450 "./src-ag/ExecutionPlan2Hs.ag" #-} rule110 = \ ((_lhsIoptions) :: Options) -> {-# LINE 450 "./src-ag/ExecutionPlan2Hs.ag" #-} if lateHigherOrderBinding _lhsIoptions then Map.delete idLateBindingAttr else id {-# LINE 1398 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule111 #-} {-# LINE 453 "./src-ag/ExecutionPlan2Hs.ag" #-} rule111 = \ ((_lhsIsynmap) :: Map NontermIdent Attributes) nt_ -> {-# LINE 453 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.toList $ fromJust $ Map.lookup nt_ _lhsIsynmap {-# LINE 1404 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule112 #-} {-# LINE 454 "./src-ag/ExecutionPlan2Hs.ag" #-} rule112 = \ _wr_inhs -> {-# LINE 454 "./src-ag/ExecutionPlan2Hs.ag" #-} map (lhsname True . fst) _wr_inhs {-# LINE 1410 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule113 #-} {-# LINE 455 "./src-ag/ExecutionPlan2Hs.ag" #-} rule113 = \ _wr_inhs1 -> {-# LINE 455 "./src-ag/ExecutionPlan2Hs.ag" #-} map (lhsname True . fst) _wr_inhs1 {-# LINE 1416 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule114 #-} {-# LINE 456 "./src-ag/ExecutionPlan2Hs.ag" #-} rule114 = \ _wr_syns -> {-# LINE 456 "./src-ag/ExecutionPlan2Hs.ag" #-} map (lhsname False . fst) _wr_syns {-# LINE 1422 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule115 #-} {-# LINE 457 "./src-ag/ExecutionPlan2Hs.ag" #-} rule115 = \ nt_ -> {-# LINE 457 "./src-ag/ExecutionPlan2Hs.ag" #-} "wrap_" ++ show nt_ {-# LINE 1428 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule116 #-} {-# LINE 458 "./src-ag/ExecutionPlan2Hs.ag" #-} rule116 = \ nt_ -> {-# LINE 458 "./src-ag/ExecutionPlan2Hs.ag" #-} "Inh_" ++ show nt_ {-# LINE 1434 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule117 #-} {-# LINE 459 "./src-ag/ExecutionPlan2Hs.ag" #-} rule117 = \ nt_ -> {-# LINE 459 "./src-ag/ExecutionPlan2Hs.ag" #-} "Syn_" ++ show nt_ {-# LINE 1440 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule118 #-} {-# LINE 460 "./src-ag/ExecutionPlan2Hs.ag" #-} rule118 = \ initial_ nextVisits_ -> {-# LINE 460 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.findWithDefault ManyVis initial_ nextVisits_ {-# LINE 1446 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule119 #-} {-# LINE 461 "./src-ag/ExecutionPlan2Hs.ag" #-} rule119 = \ _addbang _addbangWrap _classPP _firstVisitInfo _inhlist _inhlist1 _inhname _k_type ((_lhsIallVisitKinds) :: Map VisitIdentifier VisitKind) ((_lhsImainName) :: String) ((_lhsIoptions) :: Options) _quantPP _synlist _synname _t_params _t_type _wrapPragma _wrapname initial_ initialv_ nt_ -> {-# LINE 461 "./src-ag/ExecutionPlan2Hs.ag" #-} _wrapPragma >-< (_wrapname >#< "::" >#< _quantPP >#< _classPP >#< _t_type >#< _t_params >#< "->" >#< _inhname >#< _t_params >#< "->" >#< ( if monadicWrappers _lhsIoptions then ppMonadType _lhsIoptions else empty) >#< pp_parens (_synname >#< _t_params )) >-< (_wrapname >#< (_addbang $ pp_parens (_t_type >#< pp "act")) >#< (_addbang $ pp_parens (_inhname >#< (ppSpaced $ map (_addbangWrap . pp) _inhlist )) >#< "=")) >-< indent 3 (case initialv_ of Nothing -> _synname >#< " { }" Just initv -> let inCon = conNmTVisitIn nt_ initv outCon = conNmTVisitOut nt_ initv pat = _addbang $ pp_parens $ pat0 pat0 = outCon >#< ppSpaced _synlist arg = inCon >#< ppSpaced _inhlist1 ind = case _firstVisitInfo of NoneVis -> error "wrapper: initial state should have a next visit but it has none" OneVis _ -> empty ManyVis -> _k_type >|< "_v" >|< initv extra = if dummyTokenVisit _lhsIoptions then pp $ dummyArg _lhsIoptions True else empty convert = case Map.lookup initv _lhsIallVisitKinds of Just kind -> case kind of VisitPure _ -> text "return" VisitMonadic -> empty unMonad | monadicWrappers _lhsIoptions = empty | otherwise = unMon _lhsIoptions in unMonad >#< "(" >-< indent 2 ( "do" >#< ( _addbang (pp "sem") >#< "<-" >#< "act" >-< "let" >#< _addbangWrap (pp "arg") >#< "=" >#< arg >-< pat >#< "<-" >#< convert >#< pp_parens ("inv_" >|< nt_ >|< "_s" >|< initial_ >#< "sem" >#< ind >#< "arg" >#< extra) >-< "return" >#< pp_parens (_synname >#< ppSpaced _synlist ) ) ) >-< ")" ) >-< if lateHigherOrderBinding _lhsIoptions then indent 2 ("where" >#< lhsname True idLateBindingAttr >#< "=" >#< lateBindingFieldNm _lhsImainName) else empty {-# LINE 1491 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule120 #-} {-# LINE 502 "./src-ag/ExecutionPlan2Hs.ag" #-} rule120 = \ ((_lhsIoptions) :: Options) _wrapname -> {-# LINE 502 "./src-ag/ExecutionPlan2Hs.ag" #-} if parallelInvoke _lhsIoptions && not (monadicWrappers _lhsIoptions) then ppNoInline _wrapname else if noInlinePragmas _lhsIoptions then empty else ppInlinable _wrapname {-# LINE 1501 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule121 #-} {-# LINE 514 "./src-ag/ExecutionPlan2Hs.ag" #-} rule121 = \ ((_prodsIsemFunBndDefs) :: Seq PP_Doc) _semFunBndDef -> {-# LINE 514 "./src-ag/ExecutionPlan2Hs.ag" #-} _semFunBndDef Seq.<| _prodsIsemFunBndDefs {-# LINE 1507 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule122 #-} {-# LINE 515 "./src-ag/ExecutionPlan2Hs.ag" #-} rule122 = \ ((_prodsIsemFunBndTps) :: Seq PP_Doc) _semFunBndTp -> {-# LINE 515 "./src-ag/ExecutionPlan2Hs.ag" #-} _semFunBndTp Seq.<| _prodsIsemFunBndTps {-# LINE 1513 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule123 #-} {-# LINE 516 "./src-ag/ExecutionPlan2Hs.ag" #-} rule123 = \ _semFunBndNm _semname -> {-# LINE 516 "./src-ag/ExecutionPlan2Hs.ag" #-} _semFunBndNm >#< "=" >#< _semname {-# LINE 1519 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule124 #-} {-# LINE 517 "./src-ag/ExecutionPlan2Hs.ag" #-} rule124 = \ _semFunBndNm _sem_tp -> {-# LINE 517 "./src-ag/ExecutionPlan2Hs.ag" #-} _semFunBndNm >#< "::" >#< _sem_tp {-# LINE 1525 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule125 #-} {-# LINE 518 "./src-ag/ExecutionPlan2Hs.ag" #-} rule125 = \ nt_ -> {-# LINE 518 "./src-ag/ExecutionPlan2Hs.ag" #-} lateSemNtLabel nt_ {-# LINE 1531 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule126 #-} {-# LINE 556 "./src-ag/ExecutionPlan2Hs.ag" #-} rule126 = \ initial_ -> {-# LINE 556 "./src-ag/ExecutionPlan2Hs.ag" #-} initial_ {-# LINE 1537 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule127 #-} {-# LINE 557 "./src-ag/ExecutionPlan2Hs.ag" #-} rule127 = \ _allstates -> {-# LINE 557 "./src-ag/ExecutionPlan2Hs.ag" #-} _allstates {-# LINE 1543 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule128 #-} {-# LINE 1471 "./src-ag/ExecutionPlan2Hs.ag" #-} rule128 = \ ((_lhsIwrappers) :: Set NontermIdent) _sem_nt _wr_inh _wr_syn _wrapper nt_ -> {-# LINE 1471 "./src-ag/ExecutionPlan2Hs.ag" #-} (if nt_ `Set.member` _lhsIwrappers then _wr_inh >-< _wr_syn >-< _wrapper else empty) >-< _sem_nt {-# LINE 1554 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule129 #-} {-# LINE 1477 "./src-ag/ExecutionPlan2Hs.ag" #-} rule129 = \ _datatype _k_states ((_lhsIoptions) :: Options) ((_prodsIt_visits) :: PP_Doc) _t_init _t_states -> {-# LINE 1477 "./src-ag/ExecutionPlan2Hs.ag" #-} (if dataTypes _lhsIoptions then _datatype else empty) >-< _t_init >-< _t_states >-< _k_states >-< _prodsIt_visits {-# LINE 1564 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule130 #-} {-# LINE 1537 "./src-ag/ExecutionPlan2Hs.ag" #-} rule130 = \ ((_lhsIoptions) :: Options) -> {-# LINE 1537 "./src-ag/ExecutionPlan2Hs.ag" #-} \x -> if bangpats _lhsIoptions then "!" >|< x else x {-# LINE 1570 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule131 #-} {-# LINE 1545 "./src-ag/ExecutionPlan2Hs.ag" #-} rule131 = \ (_ :: ()) -> {-# LINE 1545 "./src-ag/ExecutionPlan2Hs.ag" #-} id {-# LINE 1576 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule132 #-} {-# LINE 1557 "./src-ag/ExecutionPlan2Hs.ag" #-} rule132 = \ nextVisits_ -> {-# LINE 1557 "./src-ag/ExecutionPlan2Hs.ag" #-} nextVisits_ {-# LINE 1582 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule133 #-} {-# LINE 1558 "./src-ag/ExecutionPlan2Hs.ag" #-} rule133 = \ prevVisits_ -> {-# LINE 1558 "./src-ag/ExecutionPlan2Hs.ag" #-} prevVisits_ {-# LINE 1588 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule134 #-} {-# LINE 1602 "./src-ag/ExecutionPlan2Hs.ag" #-} rule134 = \ ((_lhsIlocalAttrTypes) :: Map NontermIdent (Map ConstructorIdent (Map Identifier Type))) nt_ -> {-# LINE 1602 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.findWithDefault Map.empty nt_ _lhsIlocalAttrTypes {-# LINE 1594 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule135 #-} {-# LINE 1629 "./src-ag/ExecutionPlan2Hs.ag" #-} rule135 = \ initial_ nt_ -> {-# LINE 1629 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.singleton nt_ initial_ {-# LINE 1600 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule136 #-} {-# LINE 1643 "./src-ag/ExecutionPlan2Hs.ag" #-} rule136 = \ nt_ params_ -> {-# LINE 1643 "./src-ag/ExecutionPlan2Hs.ag" #-} NT nt_ (map show params_) False {-# LINE 1606 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule137 #-} rule137 = \ ((_prodsIchildvisit) :: Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) -> _prodsIchildvisit {-# INLINE rule138 #-} rule138 = \ ((_prodsIerrors) :: Seq Error) -> _prodsIerrors {-# INLINE rule139 #-} rule139 = \ ((_prodsIfromToStates) :: Map VisitIdentifier (Int,Int)) -> _prodsIfromToStates {-# INLINE rule140 #-} rule140 = \ ((_prodsIgenProdIO) :: IO ()) -> _prodsIgenProdIO {-# INLINE rule141 #-} rule141 = \ ((_prodsIimports) :: [PP_Doc]) -> _prodsIimports {-# INLINE rule142 #-} rule142 = \ ((_prodsIvisitKinds) :: Map VisitIdentifier VisitKind) -> _prodsIvisitKinds {-# INLINE rule143 #-} rule143 = \ ((_prodsIvisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _prodsIvisitdefs {-# INLINE rule144 #-} rule144 = \ ((_prodsIvisituses) :: Map VisitIdentifier (Set Identifier)) -> _prodsIvisituses {-# INLINE rule145 #-} rule145 = \ ((_lhsIallFromToStates) :: Map VisitIdentifier (Int,Int)) -> _lhsIallFromToStates {-# INLINE rule146 #-} rule146 = \ ((_lhsIallInitStates) :: Map NontermIdent Int) -> _lhsIallInitStates {-# INLINE rule147 #-} rule147 = \ ((_lhsIallVisitKinds) :: Map VisitIdentifier VisitKind) -> _lhsIallVisitKinds {-# INLINE rule148 #-} rule148 = \ ((_lhsIallchildvisit) :: Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) -> _lhsIallchildvisit {-# INLINE rule149 #-} rule149 = \ ((_lhsIavisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisitdefs {-# INLINE rule150 #-} rule150 = \ ((_lhsIavisituses) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisituses {-# INLINE rule151 #-} rule151 = \ ((_lhsIimportBlocks) :: PP_Doc) -> _lhsIimportBlocks {-# INLINE rule152 #-} rule152 = \ ((_lhsImainFile) :: String) -> _lhsImainFile {-# INLINE rule153 #-} rule153 = \ ((_lhsImainName) :: String) -> _lhsImainName {-# INLINE rule154 #-} rule154 = \ ((_lhsImoduleHeader) :: String -> String -> String -> Bool -> String) -> _lhsImoduleHeader {-# INLINE rule155 #-} rule155 = \ _ntType -> _ntType {-# INLINE rule156 #-} rule156 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule157 #-} rule157 = \ ((_lhsIpragmaBlocks) :: String) -> _lhsIpragmaBlocks {-# INLINE rule158 #-} rule158 = \ ((_lhsItextBlocks) :: PP_Doc) -> _lhsItextBlocks -- ENonterminals ----------------------------------------------- -- wrapper data Inh_ENonterminals = Inh_ENonterminals { allFromToStates_Inh_ENonterminals :: (Map VisitIdentifier (Int,Int)), allInitStates_Inh_ENonterminals :: (Map NontermIdent Int), allVisitKinds_Inh_ENonterminals :: (Map VisitIdentifier VisitKind), allchildvisit_Inh_ENonterminals :: (Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))), avisitdefs_Inh_ENonterminals :: (Map VisitIdentifier (Set Identifier)), avisituses_Inh_ENonterminals :: (Map VisitIdentifier (Set Identifier)), derivings_Inh_ENonterminals :: (Derivings), importBlocks_Inh_ENonterminals :: (PP_Doc), inhmap_Inh_ENonterminals :: (Map NontermIdent Attributes), localAttrTypes_Inh_ENonterminals :: (Map NontermIdent (Map ConstructorIdent (Map Identifier Type))), mainFile_Inh_ENonterminals :: (String), mainName_Inh_ENonterminals :: (String), moduleHeader_Inh_ENonterminals :: (String -> String -> String -> Bool -> String), options_Inh_ENonterminals :: (Options), pragmaBlocks_Inh_ENonterminals :: (String), synmap_Inh_ENonterminals :: (Map NontermIdent Attributes), textBlocks_Inh_ENonterminals :: (PP_Doc), typeSyns_Inh_ENonterminals :: (TypeSyns), wrappers_Inh_ENonterminals :: (Set NontermIdent) } data Syn_ENonterminals = Syn_ENonterminals { appendCommon_Syn_ENonterminals :: ([PP_Doc]), appendMain_Syn_ENonterminals :: ([PP_Doc]), childvisit_Syn_ENonterminals :: (Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))), errors_Syn_ENonterminals :: (Seq Error), fromToStates_Syn_ENonterminals :: (Map VisitIdentifier (Int,Int)), genProdIO_Syn_ENonterminals :: (IO ()), imports_Syn_ENonterminals :: ([PP_Doc]), initStates_Syn_ENonterminals :: (Map NontermIdent Int), output_Syn_ENonterminals :: (PP_Doc), semFunBndDefs_Syn_ENonterminals :: (Seq PP_Doc), semFunBndTps_Syn_ENonterminals :: (Seq PP_Doc), visitKinds_Syn_ENonterminals :: (Map VisitIdentifier VisitKind), visitdefs_Syn_ENonterminals :: (Map VisitIdentifier (Set Identifier)), visituses_Syn_ENonterminals :: (Map VisitIdentifier (Set Identifier)) } {-# INLINABLE wrap_ENonterminals #-} wrap_ENonterminals :: T_ENonterminals -> Inh_ENonterminals -> (Syn_ENonterminals ) wrap_ENonterminals (T_ENonterminals act) (Inh_ENonterminals _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIderivings _lhsIimportBlocks _lhsIinhmap _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsIoptions _lhsIpragmaBlocks _lhsIsynmap _lhsItextBlocks _lhsItypeSyns _lhsIwrappers) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_ENonterminals_vIn10 _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIderivings _lhsIimportBlocks _lhsIinhmap _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsIoptions _lhsIpragmaBlocks _lhsIsynmap _lhsItextBlocks _lhsItypeSyns _lhsIwrappers (T_ENonterminals_vOut10 _lhsOappendCommon _lhsOappendMain _lhsOchildvisit _lhsOerrors _lhsOfromToStates _lhsOgenProdIO _lhsOimports _lhsOinitStates _lhsOoutput _lhsOsemFunBndDefs _lhsOsemFunBndTps _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses) <- return (inv_ENonterminals_s11 sem arg) return (Syn_ENonterminals _lhsOappendCommon _lhsOappendMain _lhsOchildvisit _lhsOerrors _lhsOfromToStates _lhsOgenProdIO _lhsOimports _lhsOinitStates _lhsOoutput _lhsOsemFunBndDefs _lhsOsemFunBndTps _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses) ) -- cata {-# NOINLINE sem_ENonterminals #-} sem_ENonterminals :: ENonterminals -> T_ENonterminals sem_ENonterminals list = Prelude.foldr sem_ENonterminals_Cons sem_ENonterminals_Nil (Prelude.map sem_ENonterminal list) -- semantic domain newtype T_ENonterminals = T_ENonterminals { attach_T_ENonterminals :: Identity (T_ENonterminals_s11 ) } newtype T_ENonterminals_s11 = C_ENonterminals_s11 { inv_ENonterminals_s11 :: (T_ENonterminals_v10 ) } data T_ENonterminals_s12 = C_ENonterminals_s12 type T_ENonterminals_v10 = (T_ENonterminals_vIn10 ) -> (T_ENonterminals_vOut10 ) data T_ENonterminals_vIn10 = T_ENonterminals_vIn10 (Map VisitIdentifier (Int,Int)) (Map NontermIdent Int) (Map VisitIdentifier VisitKind) (Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) (Map VisitIdentifier (Set Identifier)) (Map VisitIdentifier (Set Identifier)) (Derivings) (PP_Doc) (Map NontermIdent Attributes) (Map NontermIdent (Map ConstructorIdent (Map Identifier Type))) (String) (String) (String -> String -> String -> Bool -> String) (Options) (String) (Map NontermIdent Attributes) (PP_Doc) (TypeSyns) (Set NontermIdent) data T_ENonterminals_vOut10 = T_ENonterminals_vOut10 ([PP_Doc]) ([PP_Doc]) (Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) (Seq Error) (Map VisitIdentifier (Int,Int)) (IO ()) ([PP_Doc]) (Map NontermIdent Int) (PP_Doc) (Seq PP_Doc) (Seq PP_Doc) (Map VisitIdentifier VisitKind) (Map VisitIdentifier (Set Identifier)) (Map VisitIdentifier (Set Identifier)) {-# NOINLINE sem_ENonterminals_Cons #-} sem_ENonterminals_Cons :: T_ENonterminal -> T_ENonterminals -> T_ENonterminals sem_ENonterminals_Cons arg_hd_ arg_tl_ = T_ENonterminals (return st11) where {-# NOINLINE st11 #-} st11 = let v10 :: T_ENonterminals_v10 v10 = \ (T_ENonterminals_vIn10 _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIderivings _lhsIimportBlocks _lhsIinhmap _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsIoptions _lhsIpragmaBlocks _lhsIsynmap _lhsItextBlocks _lhsItypeSyns _lhsIwrappers) -> ( let _hdX8 = Control.Monad.Identity.runIdentity (attach_T_ENonterminal (arg_hd_)) _tlX11 = Control.Monad.Identity.runIdentity (attach_T_ENonterminals (arg_tl_)) (T_ENonterminal_vOut7 _hdIappendCommon _hdIappendMain _hdIchildvisit _hdIerrors _hdIfromToStates _hdIgenProdIO _hdIimports _hdIinitStates _hdIoutput _hdIsemFunBndDefs _hdIsemFunBndTps _hdIvisitKinds _hdIvisitdefs _hdIvisituses) = inv_ENonterminal_s8 _hdX8 (T_ENonterminal_vIn7 _hdOallFromToStates _hdOallInitStates _hdOallVisitKinds _hdOallchildvisit _hdOavisitdefs _hdOavisituses _hdOderivings _hdOimportBlocks _hdOinhmap _hdOlocalAttrTypes _hdOmainFile _hdOmainName _hdOmoduleHeader _hdOoptions _hdOpragmaBlocks _hdOsynmap _hdOtextBlocks _hdOtypeSyns _hdOwrappers) (T_ENonterminals_vOut10 _tlIappendCommon _tlIappendMain _tlIchildvisit _tlIerrors _tlIfromToStates _tlIgenProdIO _tlIimports _tlIinitStates _tlIoutput _tlIsemFunBndDefs _tlIsemFunBndTps _tlIvisitKinds _tlIvisitdefs _tlIvisituses) = inv_ENonterminals_s11 _tlX11 (T_ENonterminals_vIn10 _tlOallFromToStates _tlOallInitStates _tlOallVisitKinds _tlOallchildvisit _tlOavisitdefs _tlOavisituses _tlOderivings _tlOimportBlocks _tlOinhmap _tlOlocalAttrTypes _tlOmainFile _tlOmainName _tlOmoduleHeader _tlOoptions _tlOpragmaBlocks _tlOsynmap _tlOtextBlocks _tlOtypeSyns _tlOwrappers) _lhsOappendCommon :: [PP_Doc] _lhsOappendCommon = rule159 _hdIappendCommon _tlIappendCommon _lhsOappendMain :: [PP_Doc] _lhsOappendMain = rule160 _hdIappendMain _tlIappendMain _lhsOchildvisit :: Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc)) _lhsOchildvisit = rule161 _hdIchildvisit _tlIchildvisit _lhsOerrors :: Seq Error _lhsOerrors = rule162 _hdIerrors _tlIerrors _lhsOfromToStates :: Map VisitIdentifier (Int,Int) _lhsOfromToStates = rule163 _hdIfromToStates _tlIfromToStates _lhsOgenProdIO :: IO () _lhsOgenProdIO = rule164 _hdIgenProdIO _tlIgenProdIO _lhsOimports :: [PP_Doc] _lhsOimports = rule165 _hdIimports _tlIimports _lhsOinitStates :: Map NontermIdent Int _lhsOinitStates = rule166 _hdIinitStates _tlIinitStates _lhsOoutput :: PP_Doc _lhsOoutput = rule167 _hdIoutput _tlIoutput _lhsOsemFunBndDefs :: Seq PP_Doc _lhsOsemFunBndDefs = rule168 _hdIsemFunBndDefs _tlIsemFunBndDefs _lhsOsemFunBndTps :: Seq PP_Doc _lhsOsemFunBndTps = rule169 _hdIsemFunBndTps _tlIsemFunBndTps _lhsOvisitKinds :: Map VisitIdentifier VisitKind _lhsOvisitKinds = rule170 _hdIvisitKinds _tlIvisitKinds _lhsOvisitdefs :: Map VisitIdentifier (Set Identifier) _lhsOvisitdefs = rule171 _hdIvisitdefs _tlIvisitdefs _lhsOvisituses :: Map VisitIdentifier (Set Identifier) _lhsOvisituses = rule172 _hdIvisituses _tlIvisituses _hdOallFromToStates = rule173 _lhsIallFromToStates _hdOallInitStates = rule174 _lhsIallInitStates _hdOallVisitKinds = rule175 _lhsIallVisitKinds _hdOallchildvisit = rule176 _lhsIallchildvisit _hdOavisitdefs = rule177 _lhsIavisitdefs _hdOavisituses = rule178 _lhsIavisituses _hdOderivings = rule179 _lhsIderivings _hdOimportBlocks = rule180 _lhsIimportBlocks _hdOinhmap = rule181 _lhsIinhmap _hdOlocalAttrTypes = rule182 _lhsIlocalAttrTypes _hdOmainFile = rule183 _lhsImainFile _hdOmainName = rule184 _lhsImainName _hdOmoduleHeader = rule185 _lhsImoduleHeader _hdOoptions = rule186 _lhsIoptions _hdOpragmaBlocks = rule187 _lhsIpragmaBlocks _hdOsynmap = rule188 _lhsIsynmap _hdOtextBlocks = rule189 _lhsItextBlocks _hdOtypeSyns = rule190 _lhsItypeSyns _hdOwrappers = rule191 _lhsIwrappers _tlOallFromToStates = rule192 _lhsIallFromToStates _tlOallInitStates = rule193 _lhsIallInitStates _tlOallVisitKinds = rule194 _lhsIallVisitKinds _tlOallchildvisit = rule195 _lhsIallchildvisit _tlOavisitdefs = rule196 _lhsIavisitdefs _tlOavisituses = rule197 _lhsIavisituses _tlOderivings = rule198 _lhsIderivings _tlOimportBlocks = rule199 _lhsIimportBlocks _tlOinhmap = rule200 _lhsIinhmap _tlOlocalAttrTypes = rule201 _lhsIlocalAttrTypes _tlOmainFile = rule202 _lhsImainFile _tlOmainName = rule203 _lhsImainName _tlOmoduleHeader = rule204 _lhsImoduleHeader _tlOoptions = rule205 _lhsIoptions _tlOpragmaBlocks = rule206 _lhsIpragmaBlocks _tlOsynmap = rule207 _lhsIsynmap _tlOtextBlocks = rule208 _lhsItextBlocks _tlOtypeSyns = rule209 _lhsItypeSyns _tlOwrappers = rule210 _lhsIwrappers __result_ = T_ENonterminals_vOut10 _lhsOappendCommon _lhsOappendMain _lhsOchildvisit _lhsOerrors _lhsOfromToStates _lhsOgenProdIO _lhsOimports _lhsOinitStates _lhsOoutput _lhsOsemFunBndDefs _lhsOsemFunBndTps _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses in __result_ ) in C_ENonterminals_s11 v10 {-# INLINE rule159 #-} rule159 = \ ((_hdIappendCommon) :: PP_Doc ) ((_tlIappendCommon) :: [PP_Doc]) -> _hdIappendCommon : _tlIappendCommon {-# INLINE rule160 #-} rule160 = \ ((_hdIappendMain) :: PP_Doc ) ((_tlIappendMain) :: [PP_Doc]) -> _hdIappendMain : _tlIappendMain {-# INLINE rule161 #-} rule161 = \ ((_hdIchildvisit) :: Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) ((_tlIchildvisit) :: Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) -> _hdIchildvisit `Map.union` _tlIchildvisit {-# INLINE rule162 #-} rule162 = \ ((_hdIerrors) :: Seq Error) ((_tlIerrors) :: Seq Error) -> _hdIerrors Seq.>< _tlIerrors {-# INLINE rule163 #-} rule163 = \ ((_hdIfromToStates) :: Map VisitIdentifier (Int,Int)) ((_tlIfromToStates) :: Map VisitIdentifier (Int,Int)) -> _hdIfromToStates `mappend` _tlIfromToStates {-# INLINE rule164 #-} rule164 = \ ((_hdIgenProdIO) :: IO ()) ((_tlIgenProdIO) :: IO ()) -> _hdIgenProdIO >> _tlIgenProdIO {-# INLINE rule165 #-} rule165 = \ ((_hdIimports) :: [PP_Doc]) ((_tlIimports) :: [PP_Doc]) -> _hdIimports ++ _tlIimports {-# INLINE rule166 #-} rule166 = \ ((_hdIinitStates) :: Map NontermIdent Int) ((_tlIinitStates) :: Map NontermIdent Int) -> _hdIinitStates `mappend` _tlIinitStates {-# INLINE rule167 #-} rule167 = \ ((_hdIoutput) :: PP_Doc) ((_tlIoutput) :: PP_Doc) -> _hdIoutput >-< _tlIoutput {-# INLINE rule168 #-} rule168 = \ ((_hdIsemFunBndDefs) :: Seq PP_Doc) ((_tlIsemFunBndDefs) :: Seq PP_Doc) -> _hdIsemFunBndDefs Seq.>< _tlIsemFunBndDefs {-# INLINE rule169 #-} rule169 = \ ((_hdIsemFunBndTps) :: Seq PP_Doc) ((_tlIsemFunBndTps) :: Seq PP_Doc) -> _hdIsemFunBndTps Seq.>< _tlIsemFunBndTps {-# INLINE rule170 #-} rule170 = \ ((_hdIvisitKinds) :: Map VisitIdentifier VisitKind) ((_tlIvisitKinds) :: Map VisitIdentifier VisitKind) -> _hdIvisitKinds `mappend` _tlIvisitKinds {-# INLINE rule171 #-} rule171 = \ ((_hdIvisitdefs) :: Map VisitIdentifier (Set Identifier)) ((_tlIvisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _hdIvisitdefs `uwSetUnion` _tlIvisitdefs {-# INLINE rule172 #-} rule172 = \ ((_hdIvisituses) :: Map VisitIdentifier (Set Identifier)) ((_tlIvisituses) :: Map VisitIdentifier (Set Identifier)) -> _hdIvisituses `uwSetUnion` _tlIvisituses {-# INLINE rule173 #-} rule173 = \ ((_lhsIallFromToStates) :: Map VisitIdentifier (Int,Int)) -> _lhsIallFromToStates {-# INLINE rule174 #-} rule174 = \ ((_lhsIallInitStates) :: Map NontermIdent Int) -> _lhsIallInitStates {-# INLINE rule175 #-} rule175 = \ ((_lhsIallVisitKinds) :: Map VisitIdentifier VisitKind) -> _lhsIallVisitKinds {-# INLINE rule176 #-} rule176 = \ ((_lhsIallchildvisit) :: Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) -> _lhsIallchildvisit {-# INLINE rule177 #-} rule177 = \ ((_lhsIavisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisitdefs {-# INLINE rule178 #-} rule178 = \ ((_lhsIavisituses) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisituses {-# INLINE rule179 #-} rule179 = \ ((_lhsIderivings) :: Derivings) -> _lhsIderivings {-# INLINE rule180 #-} rule180 = \ ((_lhsIimportBlocks) :: PP_Doc) -> _lhsIimportBlocks {-# INLINE rule181 #-} rule181 = \ ((_lhsIinhmap) :: Map NontermIdent Attributes) -> _lhsIinhmap {-# INLINE rule182 #-} rule182 = \ ((_lhsIlocalAttrTypes) :: Map NontermIdent (Map ConstructorIdent (Map Identifier Type))) -> _lhsIlocalAttrTypes {-# INLINE rule183 #-} rule183 = \ ((_lhsImainFile) :: String) -> _lhsImainFile {-# INLINE rule184 #-} rule184 = \ ((_lhsImainName) :: String) -> _lhsImainName {-# INLINE rule185 #-} rule185 = \ ((_lhsImoduleHeader) :: String -> String -> String -> Bool -> String) -> _lhsImoduleHeader {-# INLINE rule186 #-} rule186 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule187 #-} rule187 = \ ((_lhsIpragmaBlocks) :: String) -> _lhsIpragmaBlocks {-# INLINE rule188 #-} rule188 = \ ((_lhsIsynmap) :: Map NontermIdent Attributes) -> _lhsIsynmap {-# INLINE rule189 #-} rule189 = \ ((_lhsItextBlocks) :: PP_Doc) -> _lhsItextBlocks {-# INLINE rule190 #-} rule190 = \ ((_lhsItypeSyns) :: TypeSyns) -> _lhsItypeSyns {-# INLINE rule191 #-} rule191 = \ ((_lhsIwrappers) :: Set NontermIdent) -> _lhsIwrappers {-# INLINE rule192 #-} rule192 = \ ((_lhsIallFromToStates) :: Map VisitIdentifier (Int,Int)) -> _lhsIallFromToStates {-# INLINE rule193 #-} rule193 = \ ((_lhsIallInitStates) :: Map NontermIdent Int) -> _lhsIallInitStates {-# INLINE rule194 #-} rule194 = \ ((_lhsIallVisitKinds) :: Map VisitIdentifier VisitKind) -> _lhsIallVisitKinds {-# INLINE rule195 #-} rule195 = \ ((_lhsIallchildvisit) :: Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) -> _lhsIallchildvisit {-# INLINE rule196 #-} rule196 = \ ((_lhsIavisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisitdefs {-# INLINE rule197 #-} rule197 = \ ((_lhsIavisituses) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisituses {-# INLINE rule198 #-} rule198 = \ ((_lhsIderivings) :: Derivings) -> _lhsIderivings {-# INLINE rule199 #-} rule199 = \ ((_lhsIimportBlocks) :: PP_Doc) -> _lhsIimportBlocks {-# INLINE rule200 #-} rule200 = \ ((_lhsIinhmap) :: Map NontermIdent Attributes) -> _lhsIinhmap {-# INLINE rule201 #-} rule201 = \ ((_lhsIlocalAttrTypes) :: Map NontermIdent (Map ConstructorIdent (Map Identifier Type))) -> _lhsIlocalAttrTypes {-# INLINE rule202 #-} rule202 = \ ((_lhsImainFile) :: String) -> _lhsImainFile {-# INLINE rule203 #-} rule203 = \ ((_lhsImainName) :: String) -> _lhsImainName {-# INLINE rule204 #-} rule204 = \ ((_lhsImoduleHeader) :: String -> String -> String -> Bool -> String) -> _lhsImoduleHeader {-# INLINE rule205 #-} rule205 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule206 #-} rule206 = \ ((_lhsIpragmaBlocks) :: String) -> _lhsIpragmaBlocks {-# INLINE rule207 #-} rule207 = \ ((_lhsIsynmap) :: Map NontermIdent Attributes) -> _lhsIsynmap {-# INLINE rule208 #-} rule208 = \ ((_lhsItextBlocks) :: PP_Doc) -> _lhsItextBlocks {-# INLINE rule209 #-} rule209 = \ ((_lhsItypeSyns) :: TypeSyns) -> _lhsItypeSyns {-# INLINE rule210 #-} rule210 = \ ((_lhsIwrappers) :: Set NontermIdent) -> _lhsIwrappers {-# NOINLINE sem_ENonterminals_Nil #-} sem_ENonterminals_Nil :: T_ENonterminals sem_ENonterminals_Nil = T_ENonterminals (return st11) where {-# NOINLINE st11 #-} st11 = let v10 :: T_ENonterminals_v10 v10 = \ (T_ENonterminals_vIn10 _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIderivings _lhsIimportBlocks _lhsIinhmap _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsIoptions _lhsIpragmaBlocks _lhsIsynmap _lhsItextBlocks _lhsItypeSyns _lhsIwrappers) -> ( let _lhsOappendCommon :: [PP_Doc] _lhsOappendCommon = rule211 () _lhsOappendMain :: [PP_Doc] _lhsOappendMain = rule212 () _lhsOchildvisit :: Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc)) _lhsOchildvisit = rule213 () _lhsOerrors :: Seq Error _lhsOerrors = rule214 () _lhsOfromToStates :: Map VisitIdentifier (Int,Int) _lhsOfromToStates = rule215 () _lhsOgenProdIO :: IO () _lhsOgenProdIO = rule216 () _lhsOimports :: [PP_Doc] _lhsOimports = rule217 () _lhsOinitStates :: Map NontermIdent Int _lhsOinitStates = rule218 () _lhsOoutput :: PP_Doc _lhsOoutput = rule219 () _lhsOsemFunBndDefs :: Seq PP_Doc _lhsOsemFunBndDefs = rule220 () _lhsOsemFunBndTps :: Seq PP_Doc _lhsOsemFunBndTps = rule221 () _lhsOvisitKinds :: Map VisitIdentifier VisitKind _lhsOvisitKinds = rule222 () _lhsOvisitdefs :: Map VisitIdentifier (Set Identifier) _lhsOvisitdefs = rule223 () _lhsOvisituses :: Map VisitIdentifier (Set Identifier) _lhsOvisituses = rule224 () __result_ = T_ENonterminals_vOut10 _lhsOappendCommon _lhsOappendMain _lhsOchildvisit _lhsOerrors _lhsOfromToStates _lhsOgenProdIO _lhsOimports _lhsOinitStates _lhsOoutput _lhsOsemFunBndDefs _lhsOsemFunBndTps _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses in __result_ ) in C_ENonterminals_s11 v10 {-# INLINE rule211 #-} rule211 = \ (_ :: ()) -> [] {-# INLINE rule212 #-} rule212 = \ (_ :: ()) -> [] {-# INLINE rule213 #-} rule213 = \ (_ :: ()) -> Map.empty {-# INLINE rule214 #-} rule214 = \ (_ :: ()) -> Seq.empty {-# INLINE rule215 #-} rule215 = \ (_ :: ()) -> mempty {-# INLINE rule216 #-} rule216 = \ (_ :: ()) -> return () {-# INLINE rule217 #-} rule217 = \ (_ :: ()) -> [] {-# INLINE rule218 #-} rule218 = \ (_ :: ()) -> mempty {-# INLINE rule219 #-} rule219 = \ (_ :: ()) -> empty {-# INLINE rule220 #-} rule220 = \ (_ :: ()) -> Seq.empty {-# INLINE rule221 #-} rule221 = \ (_ :: ()) -> Seq.empty {-# INLINE rule222 #-} rule222 = \ (_ :: ()) -> mempty {-# INLINE rule223 #-} rule223 = \ (_ :: ()) -> Map.empty {-# INLINE rule224 #-} rule224 = \ (_ :: ()) -> Map.empty -- EProduction ------------------------------------------------- -- wrapper data Inh_EProduction = Inh_EProduction { allFromToStates_Inh_EProduction :: (Map VisitIdentifier (Int,Int)), allInhmap_Inh_EProduction :: (Map NontermIdent Attributes), allInitStates_Inh_EProduction :: (Map NontermIdent Int), allSynmap_Inh_EProduction :: (Map NontermIdent Attributes), allVisitKinds_Inh_EProduction :: (Map VisitIdentifier VisitKind), allchildvisit_Inh_EProduction :: (Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))), allstates_Inh_EProduction :: (Set StateIdentifier), avisitdefs_Inh_EProduction :: (Map VisitIdentifier (Set Identifier)), avisituses_Inh_EProduction :: (Map VisitIdentifier (Set Identifier)), classCtxs_Inh_EProduction :: (ClassContext), importBlocks_Inh_EProduction :: (PP_Doc), inhmap_Inh_EProduction :: (Attributes), initial_Inh_EProduction :: (StateIdentifier), localAttrTypes_Inh_EProduction :: (Map ConstructorIdent (Map Identifier Type)), mainFile_Inh_EProduction :: (String), mainName_Inh_EProduction :: (String), moduleHeader_Inh_EProduction :: (String -> String -> String -> Bool -> String), nextVisits_Inh_EProduction :: (Map StateIdentifier StateCtx), nt_Inh_EProduction :: (NontermIdent), ntType_Inh_EProduction :: (Type), options_Inh_EProduction :: (Options), params_Inh_EProduction :: ([Identifier]), pragmaBlocks_Inh_EProduction :: (String), prevVisits_Inh_EProduction :: (Map StateIdentifier StateCtx), rename_Inh_EProduction :: (Bool), synmap_Inh_EProduction :: (Attributes), textBlocks_Inh_EProduction :: (PP_Doc) } data Syn_EProduction = Syn_EProduction { allvisits_Syn_EProduction :: ([VisitStateState]), childvisit_Syn_EProduction :: (Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))), count_Syn_EProduction :: (Int), datatype_Syn_EProduction :: (PP_Doc), errors_Syn_EProduction :: (Seq Error), fromToStates_Syn_EProduction :: (Map VisitIdentifier (Int,Int)), genProdIO_Syn_EProduction :: (IO ()), imports_Syn_EProduction :: ([PP_Doc]), semFunBndDefs_Syn_EProduction :: (Seq PP_Doc), semFunBndTps_Syn_EProduction :: (Seq PP_Doc), sem_nt_Syn_EProduction :: (PP_Doc), sem_prod_Syn_EProduction :: (PP_Doc), t_visits_Syn_EProduction :: (PP_Doc), visitKinds_Syn_EProduction :: (Map VisitIdentifier VisitKind), visitdefs_Syn_EProduction :: (Map VisitIdentifier (Set Identifier)), visituses_Syn_EProduction :: (Map VisitIdentifier (Set Identifier)) } {-# INLINABLE wrap_EProduction #-} wrap_EProduction :: T_EProduction -> Inh_EProduction -> (Syn_EProduction ) wrap_EProduction (T_EProduction act) (Inh_EProduction _lhsIallFromToStates _lhsIallInhmap _lhsIallInitStates _lhsIallSynmap _lhsIallVisitKinds _lhsIallchildvisit _lhsIallstates _lhsIavisitdefs _lhsIavisituses _lhsIclassCtxs _lhsIimportBlocks _lhsIinhmap _lhsIinitial _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInextVisits _lhsInt _lhsIntType _lhsIoptions _lhsIparams _lhsIpragmaBlocks _lhsIprevVisits _lhsIrename _lhsIsynmap _lhsItextBlocks) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_EProduction_vIn13 _lhsIallFromToStates _lhsIallInhmap _lhsIallInitStates _lhsIallSynmap _lhsIallVisitKinds _lhsIallchildvisit _lhsIallstates _lhsIavisitdefs _lhsIavisituses _lhsIclassCtxs _lhsIimportBlocks _lhsIinhmap _lhsIinitial _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInextVisits _lhsInt _lhsIntType _lhsIoptions _lhsIparams _lhsIpragmaBlocks _lhsIprevVisits _lhsIrename _lhsIsynmap _lhsItextBlocks (T_EProduction_vOut13 _lhsOallvisits _lhsOchildvisit _lhsOcount _lhsOdatatype _lhsOerrors _lhsOfromToStates _lhsOgenProdIO _lhsOimports _lhsOsemFunBndDefs _lhsOsemFunBndTps _lhsOsem_nt _lhsOsem_prod _lhsOt_visits _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses) <- return (inv_EProduction_s14 sem arg) return (Syn_EProduction _lhsOallvisits _lhsOchildvisit _lhsOcount _lhsOdatatype _lhsOerrors _lhsOfromToStates _lhsOgenProdIO _lhsOimports _lhsOsemFunBndDefs _lhsOsemFunBndTps _lhsOsem_nt _lhsOsem_prod _lhsOt_visits _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses) ) -- cata {-# INLINE sem_EProduction #-} sem_EProduction :: EProduction -> T_EProduction sem_EProduction ( EProduction con_ params_ constraints_ rules_ children_ visits_ ) = sem_EProduction_EProduction con_ params_ constraints_ ( sem_ERules rules_ ) ( sem_EChildren children_ ) ( sem_Visits visits_ ) -- semantic domain newtype T_EProduction = T_EProduction { attach_T_EProduction :: Identity (T_EProduction_s14 ) } newtype T_EProduction_s14 = C_EProduction_s14 { inv_EProduction_s14 :: (T_EProduction_v13 ) } data T_EProduction_s15 = C_EProduction_s15 type T_EProduction_v13 = (T_EProduction_vIn13 ) -> (T_EProduction_vOut13 ) data T_EProduction_vIn13 = T_EProduction_vIn13 (Map VisitIdentifier (Int,Int)) (Map NontermIdent Attributes) (Map NontermIdent Int) (Map NontermIdent Attributes) (Map VisitIdentifier VisitKind) (Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) (Set StateIdentifier) (Map VisitIdentifier (Set Identifier)) (Map VisitIdentifier (Set Identifier)) (ClassContext) (PP_Doc) (Attributes) (StateIdentifier) (Map ConstructorIdent (Map Identifier Type)) (String) (String) (String -> String -> String -> Bool -> String) (Map StateIdentifier StateCtx) (NontermIdent) (Type) (Options) ([Identifier]) (String) (Map StateIdentifier StateCtx) (Bool) (Attributes) (PP_Doc) data T_EProduction_vOut13 = T_EProduction_vOut13 ([VisitStateState]) (Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) (Int) (PP_Doc) (Seq Error) (Map VisitIdentifier (Int,Int)) (IO ()) ([PP_Doc]) (Seq PP_Doc) (Seq PP_Doc) (PP_Doc) (PP_Doc) (PP_Doc) (Map VisitIdentifier VisitKind) (Map VisitIdentifier (Set Identifier)) (Map VisitIdentifier (Set Identifier)) {-# NOINLINE sem_EProduction_EProduction #-} sem_EProduction_EProduction :: (ConstructorIdent) -> ([Identifier]) -> ([Type]) -> T_ERules -> T_EChildren -> T_Visits -> T_EProduction sem_EProduction_EProduction arg_con_ arg_params_ arg_constraints_ arg_rules_ arg_children_ arg_visits_ = T_EProduction (return st14) where {-# NOINLINE st14 #-} st14 = let v13 :: T_EProduction_v13 v13 = \ (T_EProduction_vIn13 _lhsIallFromToStates _lhsIallInhmap _lhsIallInitStates _lhsIallSynmap _lhsIallVisitKinds _lhsIallchildvisit _lhsIallstates _lhsIavisitdefs _lhsIavisituses _lhsIclassCtxs _lhsIimportBlocks _lhsIinhmap _lhsIinitial _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInextVisits _lhsInt _lhsIntType _lhsIoptions _lhsIparams _lhsIpragmaBlocks _lhsIprevVisits _lhsIrename _lhsIsynmap _lhsItextBlocks) -> ( let _rulesX23 = Control.Monad.Identity.runIdentity (attach_T_ERules (arg_rules_)) _childrenX5 = Control.Monad.Identity.runIdentity (attach_T_EChildren (arg_children_)) _visitsX56 = Control.Monad.Identity.runIdentity (attach_T_Visits (arg_visits_)) (T_ERules_vOut22 _rulesIerrors _rulesImrules _rulesIruledefs _rulesIruleuses _rulesIsem_rules _rulesIusedArgs) = inv_ERules_s23 _rulesX23 (T_ERules_vIn22 _rulesOallInhmap _rulesOallSynmap _rulesOchildTypes _rulesOcon _rulesOimportBlocks _rulesOinhmap _rulesOlazyIntras _rulesOlocalAttrTypes _rulesOmainFile _rulesOmainName _rulesOmoduleHeader _rulesOnt _rulesOoptions _rulesOpragmaBlocks _rulesOruleKinds _rulesOsynmap _rulesOtextBlocks _rulesOusageInfo) (T_EChildren_vOut4 _childrenIargnamesw _childrenIargpats _childrenIargtps _childrenIchildTypes _childrenIchildintros _childrenIdatatype _childrenIterminaldefs _childrenIusedArgs) = inv_EChildren_s5 _childrenX5 (T_EChildren_vIn4 _childrenOallInitStates _childrenOcon _childrenOimportBlocks _childrenOmainFile _childrenOmainName _childrenOmoduleHeader _childrenOnt _childrenOoptions _childrenOpragmaBlocks _childrenOtextBlocks) (T_Visits_vOut55 _visitsIallvisits _visitsIchildvisit _visitsIerrors _visitsIfromToStates _visitsIintramap _visitsIlazyIntras _visitsIruleKinds _visitsIruleUsage _visitsIsem_visit _visitsIt_visits _visitsIusedArgs _visitsIvisitKinds _visitsIvisitdefs _visitsIvisituses) = inv_Visits_s56 _visitsX56 (T_Visits_vIn55 _visitsOallFromToStates _visitsOallInhmap _visitsOallInitStates _visitsOallSynmap _visitsOallVisitKinds _visitsOallchildvisit _visitsOallintramap _visitsOavisitdefs _visitsOavisituses _visitsOchildTypes _visitsOchildintros _visitsOcon _visitsOinhmap _visitsOmrules _visitsOnextVisits _visitsOnt _visitsOoptions _visitsOparams _visitsOprevVisits _visitsOruledefs _visitsOruleuses _visitsOsynmap _visitsOterminaldefs) _childrenOcon = rule225 arg_con_ _rulesOcon = rule226 arg_con_ _visitsOcon = rule227 arg_con_ _lhsOdatatype :: PP_Doc _lhsOdatatype = rule228 _childrenIdatatype _classPP1 _lhsInt _lhsIoptions _lhsIrename _quantPP1 arg_con_ _classPP1 = rule229 arg_constraints_ _quantPP1 = rule230 arg_params_ _lhsOcount :: Int _lhsOcount = rule231 () _lhsOsem_nt :: PP_Doc _lhsOsem_nt = rule232 _childrenIargnamesw _childrenIargpats _lhsInt _lhsIrename arg_con_ _lhsOsemFunBndDefs :: Seq PP_Doc _lhsOsemFunBndDefs = rule233 _semFunBndDef _lhsOsemFunBndTps :: Seq PP_Doc _lhsOsemFunBndTps = rule234 _semFunBndTp _semFunBndDef = rule235 _semFunBndNm _semname _semFunBndTp = rule236 _semFunBndNm _sem_tp _semFunBndNm = rule237 _lhsInt arg_con_ _t_type = rule238 _lhsInt _t_params = rule239 _lhsIparams _usedArgs = rule240 _childrenIusedArgs _rulesIusedArgs _visitsIusedArgs _args = rule241 _childrenIargpats _usedArgs _semname = rule242 _lhsInt arg_con_ _sem_tp = rule243 _childrenIargtps _classPP2 _quantPP2 _t_params _t_type _classPP2 = rule244 _lhsIclassCtxs arg_constraints_ _quantPP2 = rule245 _lhsIparams arg_params_ _sem_prod = rule246 _args _lhsIinitial _mbInitializer _mkSemBody _outerlet _scc _semInlinePragma _sem_tp _semname _t_type _mkSemBody = rule247 () _mbInitializer = rule248 _lhsIoptions _scc = rule249 _lhsIoptions _semname _semInlinePragma = rule250 _lhsIoptions _semname _outerlet = rule251 _rulesIsem_rules _statefns _statefns = rule252 _genstfn _lhsIallstates _genstfn = rule253 _addbang _lhsIinitial _lhsInextVisits _lhsInt _lhsIoptions _lhsIprevVisits _stargs _stks _stvs _stargs = rule254 _addbang _childTypes _lazyIntras _lhsIallInhmap _lhsIallSynmap _lhsIoptions _localAttrTypes _visitsIintramap _stks = rule255 _lhsInt _lhsIoptions _stvisits _t_params _stvisits = rule256 _visitsIallvisits _stvs = rule257 _visitsIsem_visit _visitsOmrules = rule258 _rulesImrules _visitsOchildintros = rule259 _childrenIchildintros _rulesOusageInfo = rule260 _visitsIruleUsage _rulesOruleKinds = rule261 _visitsIruleKinds _visitsOallintramap = rule262 _visitsIintramap _visitsOterminaldefs = rule263 _childrenIterminaldefs _visitsOruledefs = rule264 _rulesIruledefs _visitsOruleuses = rule265 _rulesIruleuses _lazyIntras = rule266 _visitsIlazyIntras _lhsOimports :: [PP_Doc] _lhsOimports = rule267 _moduleName _moduleName = rule268 _lhsImainName _suffix _suffix = rule269 _lhsInt arg_con_ _outputfile = rule270 _lhsImainFile _suffix _ppMonadImports = rule271 _lhsIoptions _lhsOgenProdIO :: IO () _lhsOgenProdIO = rule272 _lhsIimportBlocks _lhsImainName _lhsImoduleHeader _lhsIoptions _lhsIpragmaBlocks _outputfile _ppMonadImports _sem_prod _semname _suffix _addbang = rule273 _lhsIoptions _childTypes = rule274 _childrenIchildTypes _lhsIntType _localAttrTypes = rule275 _lhsIlocalAttrTypes arg_con_ _lhsOchildvisit :: Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc)) _lhsOchildvisit = rule276 _visitsIchildvisit _lhsOerrors :: Seq Error _lhsOerrors = rule277 _rulesIerrors _visitsIerrors _lhsOfromToStates :: Map VisitIdentifier (Int,Int) _lhsOfromToStates = rule278 _visitsIfromToStates _lhsOt_visits :: PP_Doc _lhsOt_visits = rule279 _visitsIt_visits _lhsOvisitKinds :: Map VisitIdentifier VisitKind _lhsOvisitKinds = rule280 _visitsIvisitKinds _lhsOvisitdefs :: Map VisitIdentifier (Set Identifier) _lhsOvisitdefs = rule281 _visitsIvisitdefs _lhsOvisituses :: Map VisitIdentifier (Set Identifier) _lhsOvisituses = rule282 _visitsIvisituses _lhsOallvisits :: [VisitStateState] _lhsOallvisits = rule283 _visitsIallvisits _lhsOsem_prod :: PP_Doc _lhsOsem_prod = rule284 _sem_prod _rulesOallInhmap = rule285 _lhsIallInhmap _rulesOallSynmap = rule286 _lhsIallSynmap _rulesOchildTypes = rule287 _childTypes _rulesOimportBlocks = rule288 _lhsIimportBlocks _rulesOinhmap = rule289 _lhsIinhmap _rulesOlazyIntras = rule290 _lazyIntras _rulesOlocalAttrTypes = rule291 _localAttrTypes _rulesOmainFile = rule292 _lhsImainFile _rulesOmainName = rule293 _lhsImainName _rulesOmoduleHeader = rule294 _lhsImoduleHeader _rulesOnt = rule295 _lhsInt _rulesOoptions = rule296 _lhsIoptions _rulesOpragmaBlocks = rule297 _lhsIpragmaBlocks _rulesOsynmap = rule298 _lhsIsynmap _rulesOtextBlocks = rule299 _lhsItextBlocks _childrenOallInitStates = rule300 _lhsIallInitStates _childrenOimportBlocks = rule301 _lhsIimportBlocks _childrenOmainFile = rule302 _lhsImainFile _childrenOmainName = rule303 _lhsImainName _childrenOmoduleHeader = rule304 _lhsImoduleHeader _childrenOnt = rule305 _lhsInt _childrenOoptions = rule306 _lhsIoptions _childrenOpragmaBlocks = rule307 _lhsIpragmaBlocks _childrenOtextBlocks = rule308 _lhsItextBlocks _visitsOallFromToStates = rule309 _lhsIallFromToStates _visitsOallInhmap = rule310 _lhsIallInhmap _visitsOallInitStates = rule311 _lhsIallInitStates _visitsOallSynmap = rule312 _lhsIallSynmap _visitsOallVisitKinds = rule313 _lhsIallVisitKinds _visitsOallchildvisit = rule314 _lhsIallchildvisit _visitsOavisitdefs = rule315 _lhsIavisitdefs _visitsOavisituses = rule316 _lhsIavisituses _visitsOchildTypes = rule317 _childTypes _visitsOinhmap = rule318 _lhsIinhmap _visitsOnextVisits = rule319 _lhsInextVisits _visitsOnt = rule320 _lhsInt _visitsOoptions = rule321 _lhsIoptions _visitsOparams = rule322 _lhsIparams _visitsOprevVisits = rule323 _lhsIprevVisits _visitsOsynmap = rule324 _lhsIsynmap __result_ = T_EProduction_vOut13 _lhsOallvisits _lhsOchildvisit _lhsOcount _lhsOdatatype _lhsOerrors _lhsOfromToStates _lhsOgenProdIO _lhsOimports _lhsOsemFunBndDefs _lhsOsemFunBndTps _lhsOsem_nt _lhsOsem_prod _lhsOt_visits _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses in __result_ ) in C_EProduction_s14 v13 {-# INLINE rule225 #-} {-# LINE 69 "./src-ag/ExecutionPlan2Hs.ag" #-} rule225 = \ con_ -> {-# LINE 69 "./src-ag/ExecutionPlan2Hs.ag" #-} con_ {-# LINE 2188 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule226 #-} {-# LINE 70 "./src-ag/ExecutionPlan2Hs.ag" #-} rule226 = \ con_ -> {-# LINE 70 "./src-ag/ExecutionPlan2Hs.ag" #-} con_ {-# LINE 2194 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule227 #-} {-# LINE 71 "./src-ag/ExecutionPlan2Hs.ag" #-} rule227 = \ con_ -> {-# LINE 71 "./src-ag/ExecutionPlan2Hs.ag" #-} con_ {-# LINE 2200 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule228 #-} {-# LINE 184 "./src-ag/ExecutionPlan2Hs.ag" #-} rule228 = \ ((_childrenIdatatype) :: [PP_Doc]) _classPP1 ((_lhsInt) :: NontermIdent) ((_lhsIoptions) :: Options) ((_lhsIrename) :: Bool) _quantPP1 con_ -> {-# LINE 184 "./src-ag/ExecutionPlan2Hs.ag" #-} _quantPP1 >#< _classPP1 >#< conname _lhsIrename _lhsInt con_ >#< ppConFields (dataRecords _lhsIoptions) _childrenIdatatype {-# LINE 2208 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule229 #-} {-# LINE 187 "./src-ag/ExecutionPlan2Hs.ag" #-} rule229 = \ constraints_ -> {-# LINE 187 "./src-ag/ExecutionPlan2Hs.ag" #-} ppClasses (classConstrsToDocs constraints_) {-# LINE 2214 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule230 #-} {-# LINE 188 "./src-ag/ExecutionPlan2Hs.ag" #-} rule230 = \ params_ -> {-# LINE 188 "./src-ag/ExecutionPlan2Hs.ag" #-} ppQuants params_ {-# LINE 2220 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule231 #-} {-# LINE 286 "./src-ag/ExecutionPlan2Hs.ag" #-} rule231 = \ (_ :: ()) -> {-# LINE 286 "./src-ag/ExecutionPlan2Hs.ag" #-} 1 {-# LINE 2226 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule232 #-} {-# LINE 291 "./src-ag/ExecutionPlan2Hs.ag" #-} rule232 = \ ((_childrenIargnamesw) :: [PP_Doc]) ((_childrenIargpats) :: [PP_Doc] ) ((_lhsInt) :: NontermIdent) ((_lhsIrename) :: Bool) con_ -> {-# LINE 291 "./src-ag/ExecutionPlan2Hs.ag" #-} "sem_" >|< _lhsInt >#< "(" >#< conname _lhsIrename _lhsInt con_ >#< ppSpaced _childrenIargpats >#< ")" >#< "=" >#< "sem_" >|< _lhsInt >|< "_" >|< con_ >#< ppSpaced _childrenIargnamesw {-# LINE 2233 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule233 #-} {-# LINE 521 "./src-ag/ExecutionPlan2Hs.ag" #-} rule233 = \ _semFunBndDef -> {-# LINE 521 "./src-ag/ExecutionPlan2Hs.ag" #-} Seq.singleton _semFunBndDef {-# LINE 2239 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule234 #-} {-# LINE 522 "./src-ag/ExecutionPlan2Hs.ag" #-} rule234 = \ _semFunBndTp -> {-# LINE 522 "./src-ag/ExecutionPlan2Hs.ag" #-} Seq.singleton _semFunBndTp {-# LINE 2245 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule235 #-} {-# LINE 523 "./src-ag/ExecutionPlan2Hs.ag" #-} rule235 = \ _semFunBndNm _semname -> {-# LINE 523 "./src-ag/ExecutionPlan2Hs.ag" #-} _semFunBndNm >#< "=" >#< _semname {-# LINE 2251 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule236 #-} {-# LINE 524 "./src-ag/ExecutionPlan2Hs.ag" #-} rule236 = \ _semFunBndNm _sem_tp -> {-# LINE 524 "./src-ag/ExecutionPlan2Hs.ag" #-} _semFunBndNm >#< "::" >#< _sem_tp {-# LINE 2257 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule237 #-} {-# LINE 525 "./src-ag/ExecutionPlan2Hs.ag" #-} rule237 = \ ((_lhsInt) :: NontermIdent) con_ -> {-# LINE 525 "./src-ag/ExecutionPlan2Hs.ag" #-} lateSemConLabel _lhsInt con_ {-# LINE 2263 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule238 #-} {-# LINE 583 "./src-ag/ExecutionPlan2Hs.ag" #-} rule238 = \ ((_lhsInt) :: NontermIdent) -> {-# LINE 583 "./src-ag/ExecutionPlan2Hs.ag" #-} "T_" >|< _lhsInt {-# LINE 2269 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule239 #-} {-# LINE 584 "./src-ag/ExecutionPlan2Hs.ag" #-} rule239 = \ ((_lhsIparams) :: [Identifier]) -> {-# LINE 584 "./src-ag/ExecutionPlan2Hs.ag" #-} ppSpaced _lhsIparams {-# LINE 2275 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule240 #-} {-# LINE 585 "./src-ag/ExecutionPlan2Hs.ag" #-} rule240 = \ ((_childrenIusedArgs) :: Set String) ((_rulesIusedArgs) :: Set String) ((_visitsIusedArgs) :: Set String) -> {-# LINE 585 "./src-ag/ExecutionPlan2Hs.ag" #-} _childrenIusedArgs `Set.union` _visitsIusedArgs `Set.union` _rulesIusedArgs {-# LINE 2281 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule241 #-} {-# LINE 588 "./src-ag/ExecutionPlan2Hs.ag" #-} rule241 = \ ((_childrenIargpats) :: [PP_Doc] ) _usedArgs -> {-# LINE 588 "./src-ag/ExecutionPlan2Hs.ag" #-} 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` _usedArgs then arg else text "_") _childrenIargpats {-# LINE 2293 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule242 #-} {-# LINE 595 "./src-ag/ExecutionPlan2Hs.ag" #-} rule242 = \ ((_lhsInt) :: NontermIdent) con_ -> {-# LINE 595 "./src-ag/ExecutionPlan2Hs.ag" #-} "sem_" ++ show _lhsInt ++ "_" ++ show con_ {-# LINE 2299 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule243 #-} {-# LINE 596 "./src-ag/ExecutionPlan2Hs.ag" #-} rule243 = \ ((_childrenIargtps) :: [PP_Doc] ) _classPP2 _quantPP2 _t_params _t_type -> {-# LINE 596 "./src-ag/ExecutionPlan2Hs.ag" #-} _quantPP2 >#< _classPP2 >#< ppSpaced _childrenIargtps >#< _t_type >#< _t_params {-# LINE 2305 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule244 #-} {-# LINE 597 "./src-ag/ExecutionPlan2Hs.ag" #-} rule244 = \ ((_lhsIclassCtxs) :: ClassContext) constraints_ -> {-# LINE 597 "./src-ag/ExecutionPlan2Hs.ag" #-} ppClasses (classCtxsToDocs _lhsIclassCtxs ++ classConstrsToDocs constraints_) {-# LINE 2311 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule245 #-} {-# LINE 598 "./src-ag/ExecutionPlan2Hs.ag" #-} rule245 = \ ((_lhsIparams) :: [Identifier]) params_ -> {-# LINE 598 "./src-ag/ExecutionPlan2Hs.ag" #-} ppQuants (_lhsIparams ++ params_) {-# LINE 2317 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule246 #-} {-# LINE 599 "./src-ag/ExecutionPlan2Hs.ag" #-} rule246 = \ _args ((_lhsIinitial) :: StateIdentifier) _mbInitializer _mkSemBody _outerlet _scc _semInlinePragma _sem_tp _semname _t_type -> {-# LINE 599 "./src-ag/ExecutionPlan2Hs.ag" #-} _semInlinePragma >-< _semname >#< "::" >#< _sem_tp >-< _mkSemBody (_semname >#< ppSpaced _args >#< "=" >#< _scc >#< _t_type ) _mbInitializer _outerlet ("return" >#< "st" >|< _lhsIinitial) {-# LINE 2326 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule247 #-} {-# LINE 603 "./src-ag/ExecutionPlan2Hs.ag" #-} rule247 = \ (_ :: ()) -> {-# LINE 603 "./src-ag/ExecutionPlan2Hs.ag" #-} \prefix mbInit outerlet ret -> case mbInit of Nothing -> prefix >#< pp_parens ret >#< "where" >-< indent 3 outerlet Just m -> prefix >#< "(" >#< "do" >-< indent 1 ( m >-< "let" >-< indent 2 outerlet >-< ret ) >-< indent 1 ")" {-# LINE 2342 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule248 #-} {-# LINE 615 "./src-ag/ExecutionPlan2Hs.ag" #-} rule248 = \ ((_lhsIoptions) :: Options) -> {-# LINE 615 "./src-ag/ExecutionPlan2Hs.ag" #-} if parallelInvoke _lhsIoptions then (Nothing :: Maybe PP_Doc) else Nothing {-# LINE 2350 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule249 #-} {-# LINE 621 "./src-ag/ExecutionPlan2Hs.ag" #-} rule249 = \ ((_lhsIoptions) :: Options) _semname -> {-# LINE 621 "./src-ag/ExecutionPlan2Hs.ag" #-} if genCostCentres _lhsIoptions then ppCostCentre _semname else empty {-# LINE 2358 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule250 #-} {-# LINE 624 "./src-ag/ExecutionPlan2Hs.ag" #-} rule250 = \ ((_lhsIoptions) :: Options) _semname -> {-# LINE 624 "./src-ag/ExecutionPlan2Hs.ag" #-} if noInlinePragmas _lhsIoptions then empty else ppNoInline _semname {-# LINE 2366 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule251 #-} {-# LINE 627 "./src-ag/ExecutionPlan2Hs.ag" #-} rule251 = \ ((_rulesIsem_rules) :: PP_Doc) _statefns -> {-# LINE 627 "./src-ag/ExecutionPlan2Hs.ag" #-} vlist _statefns >-< _rulesIsem_rules {-# LINE 2372 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule252 #-} {-# LINE 628 "./src-ag/ExecutionPlan2Hs.ag" #-} rule252 = \ _genstfn ((_lhsIallstates) :: Set StateIdentifier) -> {-# LINE 628 "./src-ag/ExecutionPlan2Hs.ag" #-} map _genstfn $ Set.toList _lhsIallstates {-# LINE 2378 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule253 #-} {-# LINE 629 "./src-ag/ExecutionPlan2Hs.ag" #-} rule253 = \ _addbang ((_lhsIinitial) :: StateIdentifier) ((_lhsInextVisits) :: Map StateIdentifier StateCtx) ((_lhsInt) :: NontermIdent) ((_lhsIoptions) :: Options) ((_lhsIprevVisits) :: Map StateIdentifier StateCtx) _stargs _stks _stvs -> {-# LINE 629 "./src-ag/ExecutionPlan2Hs.ag" #-} \st -> let nextVisitInfo = Map.findWithDefault ManyVis st _lhsInextVisits prevVisitInfo = Map.findWithDefault ManyVis st _lhsIprevVisits stNm = "st" >|< st lhs = pragma >-< bang stNm >#< "=" >#< ( if st == _lhsIinitial then empty else "\\" >#< _stargs st >#< "->" ) pragma = if noInlinePragmas _lhsIoptions then empty else if helpInlining _lhsIoptions then case prevVisitInfo of ManyVis -> ppNoInline stNm OneVis _ -> if aggressiveInlinePragmas _lhsIoptions then ppInline stNm else ppInlinable stNm NoneVis -> if st /= _lhsIinitial then error ("State " ++ show st ++ " is not reachable from the initial state.") else if aggressiveInlinePragmas _lhsIoptions then ppInline stNm else ppInlinable stNm else ppNoInline stNm cCon = "C_" >|< _lhsInt >|< "_s" >|< st bang | st == _lhsIinitial = _addbang | otherwise = id in case nextVisitInfo of NoneVis -> if st == _lhsIinitial then lhs >#< cCon else empty OneVis vId -> mklet lhs (_stvs st False) (cCon >#< "v" >|< vId) ManyVis -> mklet lhs (_stks st >-< _stvs st True) (cCon >#< "k" >|< st) {-# LINE 2416 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule254 #-} {-# LINE 671 "./src-ag/ExecutionPlan2Hs.ag" #-} rule254 = \ _addbang _childTypes _lazyIntras ((_lhsIallInhmap) :: Map NontermIdent Attributes) ((_lhsIallSynmap) :: Map NontermIdent Attributes) ((_lhsIoptions) :: Options) _localAttrTypes ((_visitsIintramap) :: Map StateIdentifier (Map String (Maybe NonLocalAttr))) -> {-# LINE 671 "./src-ag/ExecutionPlan2Hs.ag" #-} \st -> let attrs = maybe Map.empty id $ Map.lookup st _visitsIintramap in ppSpaced [ let match | str `Set.member` _lazyIntras = pp str | otherwise = _addbang (pp str) in case mbAttr of Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs _lhsIoptions) -> case Map.lookup nm _localAttrTypes of Just tp -> pp_parens (pp_parens match >#< "::" >#< ppTp tp) Nothing -> match Just attr | not (noPerStateTypeSigs _lhsIoptions) -> case lookupAttrType attr _lhsIallInhmap _lhsIallSynmap _childTypes of Just tpDoc -> pp_parens (pp_parens match >#< "::" >#< tpDoc) Nothing -> match _ -> match | (str,mbAttr) <- Map.assocs attrs ] >#< dummyPat _lhsIoptions (Map.null attrs) {-# LINE 2436 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule255 #-} {-# LINE 687 "./src-ag/ExecutionPlan2Hs.ag" #-} rule255 = \ ((_lhsInt) :: NontermIdent) ((_lhsIoptions) :: Options) _stvisits _t_params -> {-# LINE 687 "./src-ag/ExecutionPlan2Hs.ag" #-} \st -> if null (_stvisits st) then empty else ( if not (noInlinePragmas _lhsIoptions) && helpInlining _lhsIoptions then ppNoInline ("k" >|< st) else empty ) >-< "k" >|< st >#< "::" >#< "K_" >|< _lhsInt >|< "_s" >|< st >#< _t_params >#< "t" >#< "->" >#< "t" >-< vlist (map (\(v,f,t) -> "k" >|< st >#< "K_" >|< _lhsInt >|< "_v" >|< v >#< "=" >#< "v" >|< v) $ _stvisits st) {-# LINE 2450 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule256 #-} {-# LINE 696 "./src-ag/ExecutionPlan2Hs.ag" #-} rule256 = \ ((_visitsIallvisits) :: [VisitStateState]) -> {-# LINE 696 "./src-ag/ExecutionPlan2Hs.ag" #-} \st -> filter (\(v,f,t) -> f == st) _visitsIallvisits {-# LINE 2456 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule257 #-} {-# LINE 697 "./src-ag/ExecutionPlan2Hs.ag" #-} rule257 = \ ((_visitsIsem_visit) :: [(StateIdentifier,Bool -> PP_Doc)] ) -> {-# LINE 697 "./src-ag/ExecutionPlan2Hs.ag" #-} \st inlinePragma -> vlist [ppf inlinePragma | (f,ppf) <- _visitsIsem_visit, f == st] {-# LINE 2462 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule258 #-} {-# LINE 698 "./src-ag/ExecutionPlan2Hs.ag" #-} rule258 = \ ((_rulesImrules) :: Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)) -> {-# LINE 698 "./src-ag/ExecutionPlan2Hs.ag" #-} _rulesImrules {-# LINE 2468 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule259 #-} {-# LINE 913 "./src-ag/ExecutionPlan2Hs.ag" #-} rule259 = \ ((_childrenIchildintros) :: Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))) -> {-# LINE 913 "./src-ag/ExecutionPlan2Hs.ag" #-} _childrenIchildintros {-# LINE 2474 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule260 #-} {-# LINE 1267 "./src-ag/ExecutionPlan2Hs.ag" #-} rule260 = \ ((_visitsIruleUsage) :: Map Identifier Int) -> {-# LINE 1267 "./src-ag/ExecutionPlan2Hs.ag" #-} _visitsIruleUsage {-# LINE 2480 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule261 #-} {-# LINE 1282 "./src-ag/ExecutionPlan2Hs.ag" #-} rule261 = \ ((_visitsIruleKinds) :: Map Identifier (Set VisitKind)) -> {-# LINE 1282 "./src-ag/ExecutionPlan2Hs.ag" #-} _visitsIruleKinds {-# LINE 2486 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule262 #-} {-# LINE 1311 "./src-ag/ExecutionPlan2Hs.ag" #-} rule262 = \ ((_visitsIintramap) :: Map StateIdentifier (Map String (Maybe NonLocalAttr))) -> {-# LINE 1311 "./src-ag/ExecutionPlan2Hs.ag" #-} _visitsIintramap {-# LINE 2492 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule263 #-} {-# LINE 1312 "./src-ag/ExecutionPlan2Hs.ag" #-} rule263 = \ ((_childrenIterminaldefs) :: Set String) -> {-# LINE 1312 "./src-ag/ExecutionPlan2Hs.ag" #-} _childrenIterminaldefs {-# LINE 2498 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule264 #-} {-# LINE 1336 "./src-ag/ExecutionPlan2Hs.ag" #-} rule264 = \ ((_rulesIruledefs) :: Map Identifier (Set String)) -> {-# LINE 1336 "./src-ag/ExecutionPlan2Hs.ag" #-} _rulesIruledefs {-# LINE 2504 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule265 #-} {-# LINE 1337 "./src-ag/ExecutionPlan2Hs.ag" #-} rule265 = \ ((_rulesIruleuses) :: Map Identifier (Map String (Maybe NonLocalAttr))) -> {-# LINE 1337 "./src-ag/ExecutionPlan2Hs.ag" #-} _rulesIruleuses {-# LINE 2510 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule266 #-} {-# LINE 1391 "./src-ag/ExecutionPlan2Hs.ag" #-} rule266 = \ ((_visitsIlazyIntras) :: Set String) -> {-# LINE 1391 "./src-ag/ExecutionPlan2Hs.ag" #-} _visitsIlazyIntras {-# LINE 2516 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule267 #-} {-# LINE 1488 "./src-ag/ExecutionPlan2Hs.ag" #-} rule267 = \ _moduleName -> {-# LINE 1488 "./src-ag/ExecutionPlan2Hs.ag" #-} [pp $ "import " ++ _moduleName ] {-# LINE 2522 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule268 #-} {-# LINE 1489 "./src-ag/ExecutionPlan2Hs.ag" #-} rule268 = \ ((_lhsImainName) :: String) _suffix -> {-# LINE 1489 "./src-ag/ExecutionPlan2Hs.ag" #-} _lhsImainName ++ _suffix {-# LINE 2528 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule269 #-} {-# LINE 1490 "./src-ag/ExecutionPlan2Hs.ag" #-} rule269 = \ ((_lhsInt) :: NontermIdent) con_ -> {-# LINE 1490 "./src-ag/ExecutionPlan2Hs.ag" #-} "_" ++ show _lhsInt ++ "_" ++ show con_ {-# LINE 2534 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule270 #-} {-# LINE 1491 "./src-ag/ExecutionPlan2Hs.ag" #-} rule270 = \ ((_lhsImainFile) :: String) _suffix -> {-# LINE 1491 "./src-ag/ExecutionPlan2Hs.ag" #-} replaceBaseName _lhsImainFile (takeBaseName _lhsImainFile ++ _suffix ) {-# LINE 2540 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule271 #-} {-# LINE 1492 "./src-ag/ExecutionPlan2Hs.ag" #-} rule271 = \ ((_lhsIoptions) :: Options) -> {-# LINE 1492 "./src-ag/ExecutionPlan2Hs.ag" #-} if parallelInvoke _lhsIoptions 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" {-# LINE 2550 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule272 #-} {-# LINE 1497 "./src-ag/ExecutionPlan2Hs.ag" #-} rule272 = \ ((_lhsIimportBlocks) :: PP_Doc) ((_lhsImainName) :: String) ((_lhsImoduleHeader) :: String -> String -> String -> Bool -> String) ((_lhsIoptions) :: Options) ((_lhsIpragmaBlocks) :: String) _outputfile _ppMonadImports _sem_prod _semname _suffix -> {-# LINE 1497 "./src-ag/ExecutionPlan2Hs.ag" #-} writeModule _outputfile [ warrenFlagsPP _lhsIoptions , pp $ _lhsIpragmaBlocks , pp $ _lhsImoduleHeader _lhsImainName _suffix _semname True , _lhsIimportBlocks , _ppMonadImports , ( if tupleAsDummyToken _lhsIoptions then empty else pp "import GHC.Prim" ) , pp $ "import " ++ _lhsImainName ++ "_common" , _sem_prod ] {-# LINE 2568 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule273 #-} {-# LINE 1538 "./src-ag/ExecutionPlan2Hs.ag" #-} rule273 = \ ((_lhsIoptions) :: Options) -> {-# LINE 1538 "./src-ag/ExecutionPlan2Hs.ag" #-} \x -> if bangpats _lhsIoptions then "!" >|< x else x {-# LINE 2574 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule274 #-} {-# LINE 1588 "./src-ag/ExecutionPlan2Hs.ag" #-} rule274 = \ ((_childrenIchildTypes) :: Map Identifier Type) ((_lhsIntType) :: Type) -> {-# LINE 1588 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.singleton _LHS _lhsIntType `Map.union` _childrenIchildTypes {-# LINE 2580 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule275 #-} {-# LINE 1605 "./src-ag/ExecutionPlan2Hs.ag" #-} rule275 = \ ((_lhsIlocalAttrTypes) :: Map ConstructorIdent (Map Identifier Type)) con_ -> {-# LINE 1605 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.findWithDefault Map.empty con_ _lhsIlocalAttrTypes {-# LINE 2586 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule276 #-} rule276 = \ ((_visitsIchildvisit) :: Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) -> _visitsIchildvisit {-# INLINE rule277 #-} rule277 = \ ((_rulesIerrors) :: Seq Error) ((_visitsIerrors) :: Seq Error) -> _rulesIerrors Seq.>< _visitsIerrors {-# INLINE rule278 #-} rule278 = \ ((_visitsIfromToStates) :: Map VisitIdentifier (Int,Int)) -> _visitsIfromToStates {-# INLINE rule279 #-} rule279 = \ ((_visitsIt_visits) :: PP_Doc) -> _visitsIt_visits {-# INLINE rule280 #-} rule280 = \ ((_visitsIvisitKinds) :: Map VisitIdentifier VisitKind) -> _visitsIvisitKinds {-# INLINE rule281 #-} rule281 = \ ((_visitsIvisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _visitsIvisitdefs {-# INLINE rule282 #-} rule282 = \ ((_visitsIvisituses) :: Map VisitIdentifier (Set Identifier)) -> _visitsIvisituses {-# INLINE rule283 #-} rule283 = \ ((_visitsIallvisits) :: [VisitStateState]) -> _visitsIallvisits {-# INLINE rule284 #-} rule284 = \ _sem_prod -> _sem_prod {-# INLINE rule285 #-} rule285 = \ ((_lhsIallInhmap) :: Map NontermIdent Attributes) -> _lhsIallInhmap {-# INLINE rule286 #-} rule286 = \ ((_lhsIallSynmap) :: Map NontermIdent Attributes) -> _lhsIallSynmap {-# INLINE rule287 #-} rule287 = \ _childTypes -> _childTypes {-# INLINE rule288 #-} rule288 = \ ((_lhsIimportBlocks) :: PP_Doc) -> _lhsIimportBlocks {-# INLINE rule289 #-} rule289 = \ ((_lhsIinhmap) :: Attributes) -> _lhsIinhmap {-# INLINE rule290 #-} rule290 = \ _lazyIntras -> _lazyIntras {-# INLINE rule291 #-} rule291 = \ _localAttrTypes -> _localAttrTypes {-# INLINE rule292 #-} rule292 = \ ((_lhsImainFile) :: String) -> _lhsImainFile {-# INLINE rule293 #-} rule293 = \ ((_lhsImainName) :: String) -> _lhsImainName {-# INLINE rule294 #-} rule294 = \ ((_lhsImoduleHeader) :: String -> String -> String -> Bool -> String) -> _lhsImoduleHeader {-# INLINE rule295 #-} rule295 = \ ((_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule296 #-} rule296 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule297 #-} rule297 = \ ((_lhsIpragmaBlocks) :: String) -> _lhsIpragmaBlocks {-# INLINE rule298 #-} rule298 = \ ((_lhsIsynmap) :: Attributes) -> _lhsIsynmap {-# INLINE rule299 #-} rule299 = \ ((_lhsItextBlocks) :: PP_Doc) -> _lhsItextBlocks {-# INLINE rule300 #-} rule300 = \ ((_lhsIallInitStates) :: Map NontermIdent Int) -> _lhsIallInitStates {-# INLINE rule301 #-} rule301 = \ ((_lhsIimportBlocks) :: PP_Doc) -> _lhsIimportBlocks {-# INLINE rule302 #-} rule302 = \ ((_lhsImainFile) :: String) -> _lhsImainFile {-# INLINE rule303 #-} rule303 = \ ((_lhsImainName) :: String) -> _lhsImainName {-# INLINE rule304 #-} rule304 = \ ((_lhsImoduleHeader) :: String -> String -> String -> Bool -> String) -> _lhsImoduleHeader {-# INLINE rule305 #-} rule305 = \ ((_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule306 #-} rule306 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule307 #-} rule307 = \ ((_lhsIpragmaBlocks) :: String) -> _lhsIpragmaBlocks {-# INLINE rule308 #-} rule308 = \ ((_lhsItextBlocks) :: PP_Doc) -> _lhsItextBlocks {-# INLINE rule309 #-} rule309 = \ ((_lhsIallFromToStates) :: Map VisitIdentifier (Int,Int)) -> _lhsIallFromToStates {-# INLINE rule310 #-} rule310 = \ ((_lhsIallInhmap) :: Map NontermIdent Attributes) -> _lhsIallInhmap {-# INLINE rule311 #-} rule311 = \ ((_lhsIallInitStates) :: Map NontermIdent Int) -> _lhsIallInitStates {-# INLINE rule312 #-} rule312 = \ ((_lhsIallSynmap) :: Map NontermIdent Attributes) -> _lhsIallSynmap {-# INLINE rule313 #-} rule313 = \ ((_lhsIallVisitKinds) :: Map VisitIdentifier VisitKind) -> _lhsIallVisitKinds {-# INLINE rule314 #-} rule314 = \ ((_lhsIallchildvisit) :: Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) -> _lhsIallchildvisit {-# INLINE rule315 #-} rule315 = \ ((_lhsIavisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisitdefs {-# INLINE rule316 #-} rule316 = \ ((_lhsIavisituses) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisituses {-# INLINE rule317 #-} rule317 = \ _childTypes -> _childTypes {-# INLINE rule318 #-} rule318 = \ ((_lhsIinhmap) :: Attributes) -> _lhsIinhmap {-# INLINE rule319 #-} rule319 = \ ((_lhsInextVisits) :: Map StateIdentifier StateCtx) -> _lhsInextVisits {-# INLINE rule320 #-} rule320 = \ ((_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule321 #-} rule321 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule322 #-} rule322 = \ ((_lhsIparams) :: [Identifier]) -> _lhsIparams {-# INLINE rule323 #-} rule323 = \ ((_lhsIprevVisits) :: Map StateIdentifier StateCtx) -> _lhsIprevVisits {-# INLINE rule324 #-} rule324 = \ ((_lhsIsynmap) :: Attributes) -> _lhsIsynmap -- EProductions ------------------------------------------------ -- wrapper data Inh_EProductions = Inh_EProductions { allFromToStates_Inh_EProductions :: (Map VisitIdentifier (Int,Int)), allInhmap_Inh_EProductions :: (Map NontermIdent Attributes), allInitStates_Inh_EProductions :: (Map NontermIdent Int), allSynmap_Inh_EProductions :: (Map NontermIdent Attributes), allVisitKinds_Inh_EProductions :: (Map VisitIdentifier VisitKind), allchildvisit_Inh_EProductions :: (Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))), allstates_Inh_EProductions :: (Set StateIdentifier), avisitdefs_Inh_EProductions :: (Map VisitIdentifier (Set Identifier)), avisituses_Inh_EProductions :: (Map VisitIdentifier (Set Identifier)), classCtxs_Inh_EProductions :: (ClassContext), importBlocks_Inh_EProductions :: (PP_Doc), inhmap_Inh_EProductions :: (Attributes), initial_Inh_EProductions :: (StateIdentifier), localAttrTypes_Inh_EProductions :: (Map ConstructorIdent (Map Identifier Type)), mainFile_Inh_EProductions :: (String), mainName_Inh_EProductions :: (String), moduleHeader_Inh_EProductions :: (String -> String -> String -> Bool -> String), nextVisits_Inh_EProductions :: (Map StateIdentifier StateCtx), nt_Inh_EProductions :: (NontermIdent), ntType_Inh_EProductions :: (Type), options_Inh_EProductions :: (Options), params_Inh_EProductions :: ([Identifier]), pragmaBlocks_Inh_EProductions :: (String), prevVisits_Inh_EProductions :: (Map StateIdentifier StateCtx), rename_Inh_EProductions :: (Bool), synmap_Inh_EProductions :: (Attributes), textBlocks_Inh_EProductions :: (PP_Doc) } data Syn_EProductions = Syn_EProductions { allvisits_Syn_EProductions :: ([VisitStateState]), childvisit_Syn_EProductions :: (Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))), count_Syn_EProductions :: (Int), datatype_Syn_EProductions :: ([PP_Doc]), errors_Syn_EProductions :: (Seq Error), fromToStates_Syn_EProductions :: (Map VisitIdentifier (Int,Int)), genProdIO_Syn_EProductions :: (IO ()), imports_Syn_EProductions :: ([PP_Doc]), semFunBndDefs_Syn_EProductions :: (Seq PP_Doc), semFunBndTps_Syn_EProductions :: (Seq PP_Doc), sem_nt_Syn_EProductions :: (PP_Doc), sem_prod_Syn_EProductions :: (PP_Doc), t_visits_Syn_EProductions :: (PP_Doc), visitKinds_Syn_EProductions :: (Map VisitIdentifier VisitKind), visitdefs_Syn_EProductions :: (Map VisitIdentifier (Set Identifier)), visituses_Syn_EProductions :: (Map VisitIdentifier (Set Identifier)) } {-# INLINABLE wrap_EProductions #-} wrap_EProductions :: T_EProductions -> Inh_EProductions -> (Syn_EProductions ) wrap_EProductions (T_EProductions act) (Inh_EProductions _lhsIallFromToStates _lhsIallInhmap _lhsIallInitStates _lhsIallSynmap _lhsIallVisitKinds _lhsIallchildvisit _lhsIallstates _lhsIavisitdefs _lhsIavisituses _lhsIclassCtxs _lhsIimportBlocks _lhsIinhmap _lhsIinitial _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInextVisits _lhsInt _lhsIntType _lhsIoptions _lhsIparams _lhsIpragmaBlocks _lhsIprevVisits _lhsIrename _lhsIsynmap _lhsItextBlocks) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_EProductions_vIn16 _lhsIallFromToStates _lhsIallInhmap _lhsIallInitStates _lhsIallSynmap _lhsIallVisitKinds _lhsIallchildvisit _lhsIallstates _lhsIavisitdefs _lhsIavisituses _lhsIclassCtxs _lhsIimportBlocks _lhsIinhmap _lhsIinitial _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInextVisits _lhsInt _lhsIntType _lhsIoptions _lhsIparams _lhsIpragmaBlocks _lhsIprevVisits _lhsIrename _lhsIsynmap _lhsItextBlocks (T_EProductions_vOut16 _lhsOallvisits _lhsOchildvisit _lhsOcount _lhsOdatatype _lhsOerrors _lhsOfromToStates _lhsOgenProdIO _lhsOimports _lhsOsemFunBndDefs _lhsOsemFunBndTps _lhsOsem_nt _lhsOsem_prod _lhsOt_visits _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses) <- return (inv_EProductions_s17 sem arg) return (Syn_EProductions _lhsOallvisits _lhsOchildvisit _lhsOcount _lhsOdatatype _lhsOerrors _lhsOfromToStates _lhsOgenProdIO _lhsOimports _lhsOsemFunBndDefs _lhsOsemFunBndTps _lhsOsem_nt _lhsOsem_prod _lhsOt_visits _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses) ) -- cata {-# NOINLINE sem_EProductions #-} sem_EProductions :: EProductions -> T_EProductions sem_EProductions list = Prelude.foldr sem_EProductions_Cons sem_EProductions_Nil (Prelude.map sem_EProduction list) -- semantic domain newtype T_EProductions = T_EProductions { attach_T_EProductions :: Identity (T_EProductions_s17 ) } newtype T_EProductions_s17 = C_EProductions_s17 { inv_EProductions_s17 :: (T_EProductions_v16 ) } data T_EProductions_s18 = C_EProductions_s18 type T_EProductions_v16 = (T_EProductions_vIn16 ) -> (T_EProductions_vOut16 ) data T_EProductions_vIn16 = T_EProductions_vIn16 (Map VisitIdentifier (Int,Int)) (Map NontermIdent Attributes) (Map NontermIdent Int) (Map NontermIdent Attributes) (Map VisitIdentifier VisitKind) (Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) (Set StateIdentifier) (Map VisitIdentifier (Set Identifier)) (Map VisitIdentifier (Set Identifier)) (ClassContext) (PP_Doc) (Attributes) (StateIdentifier) (Map ConstructorIdent (Map Identifier Type)) (String) (String) (String -> String -> String -> Bool -> String) (Map StateIdentifier StateCtx) (NontermIdent) (Type) (Options) ([Identifier]) (String) (Map StateIdentifier StateCtx) (Bool) (Attributes) (PP_Doc) data T_EProductions_vOut16 = T_EProductions_vOut16 ([VisitStateState]) (Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) (Int) ([PP_Doc]) (Seq Error) (Map VisitIdentifier (Int,Int)) (IO ()) ([PP_Doc]) (Seq PP_Doc) (Seq PP_Doc) (PP_Doc) (PP_Doc) (PP_Doc) (Map VisitIdentifier VisitKind) (Map VisitIdentifier (Set Identifier)) (Map VisitIdentifier (Set Identifier)) {-# NOINLINE sem_EProductions_Cons #-} sem_EProductions_Cons :: T_EProduction -> T_EProductions -> T_EProductions sem_EProductions_Cons arg_hd_ arg_tl_ = T_EProductions (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_EProductions_v16 v16 = \ (T_EProductions_vIn16 _lhsIallFromToStates _lhsIallInhmap _lhsIallInitStates _lhsIallSynmap _lhsIallVisitKinds _lhsIallchildvisit _lhsIallstates _lhsIavisitdefs _lhsIavisituses _lhsIclassCtxs _lhsIimportBlocks _lhsIinhmap _lhsIinitial _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInextVisits _lhsInt _lhsIntType _lhsIoptions _lhsIparams _lhsIpragmaBlocks _lhsIprevVisits _lhsIrename _lhsIsynmap _lhsItextBlocks) -> ( let _hdX14 = Control.Monad.Identity.runIdentity (attach_T_EProduction (arg_hd_)) _tlX17 = Control.Monad.Identity.runIdentity (attach_T_EProductions (arg_tl_)) (T_EProduction_vOut13 _hdIallvisits _hdIchildvisit _hdIcount _hdIdatatype _hdIerrors _hdIfromToStates _hdIgenProdIO _hdIimports _hdIsemFunBndDefs _hdIsemFunBndTps _hdIsem_nt _hdIsem_prod _hdIt_visits _hdIvisitKinds _hdIvisitdefs _hdIvisituses) = inv_EProduction_s14 _hdX14 (T_EProduction_vIn13 _hdOallFromToStates _hdOallInhmap _hdOallInitStates _hdOallSynmap _hdOallVisitKinds _hdOallchildvisit _hdOallstates _hdOavisitdefs _hdOavisituses _hdOclassCtxs _hdOimportBlocks _hdOinhmap _hdOinitial _hdOlocalAttrTypes _hdOmainFile _hdOmainName _hdOmoduleHeader _hdOnextVisits _hdOnt _hdOntType _hdOoptions _hdOparams _hdOpragmaBlocks _hdOprevVisits _hdOrename _hdOsynmap _hdOtextBlocks) (T_EProductions_vOut16 _tlIallvisits _tlIchildvisit _tlIcount _tlIdatatype _tlIerrors _tlIfromToStates _tlIgenProdIO _tlIimports _tlIsemFunBndDefs _tlIsemFunBndTps _tlIsem_nt _tlIsem_prod _tlIt_visits _tlIvisitKinds _tlIvisitdefs _tlIvisituses) = inv_EProductions_s17 _tlX17 (T_EProductions_vIn16 _tlOallFromToStates _tlOallInhmap _tlOallInitStates _tlOallSynmap _tlOallVisitKinds _tlOallchildvisit _tlOallstates _tlOavisitdefs _tlOavisituses _tlOclassCtxs _tlOimportBlocks _tlOinhmap _tlOinitial _tlOlocalAttrTypes _tlOmainFile _tlOmainName _tlOmoduleHeader _tlOnextVisits _tlOnt _tlOntType _tlOoptions _tlOparams _tlOpragmaBlocks _tlOprevVisits _tlOrename _tlOsynmap _tlOtextBlocks) _lhsOallvisits :: [VisitStateState] _lhsOallvisits = rule325 _hdIallvisits _lhsOt_visits :: PP_Doc _lhsOt_visits = rule326 _hdIt_visits _lhsOchildvisit :: Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc)) _lhsOchildvisit = rule327 _hdIchildvisit _tlIchildvisit _lhsOcount :: Int _lhsOcount = rule328 _hdIcount _tlIcount _lhsOdatatype :: [PP_Doc] _lhsOdatatype = rule329 _hdIdatatype _tlIdatatype _lhsOerrors :: Seq Error _lhsOerrors = rule330 _hdIerrors _tlIerrors _lhsOfromToStates :: Map VisitIdentifier (Int,Int) _lhsOfromToStates = rule331 _hdIfromToStates _tlIfromToStates _lhsOgenProdIO :: IO () _lhsOgenProdIO = rule332 _hdIgenProdIO _tlIgenProdIO _lhsOimports :: [PP_Doc] _lhsOimports = rule333 _hdIimports _tlIimports _lhsOsemFunBndDefs :: Seq PP_Doc _lhsOsemFunBndDefs = rule334 _hdIsemFunBndDefs _tlIsemFunBndDefs _lhsOsemFunBndTps :: Seq PP_Doc _lhsOsemFunBndTps = rule335 _hdIsemFunBndTps _tlIsemFunBndTps _lhsOsem_nt :: PP_Doc _lhsOsem_nt = rule336 _hdIsem_nt _tlIsem_nt _lhsOsem_prod :: PP_Doc _lhsOsem_prod = rule337 _hdIsem_prod _tlIsem_prod _lhsOvisitKinds :: Map VisitIdentifier VisitKind _lhsOvisitKinds = rule338 _hdIvisitKinds _tlIvisitKinds _lhsOvisitdefs :: Map VisitIdentifier (Set Identifier) _lhsOvisitdefs = rule339 _hdIvisitdefs _tlIvisitdefs _lhsOvisituses :: Map VisitIdentifier (Set Identifier) _lhsOvisituses = rule340 _hdIvisituses _tlIvisituses _hdOallFromToStates = rule341 _lhsIallFromToStates _hdOallInhmap = rule342 _lhsIallInhmap _hdOallInitStates = rule343 _lhsIallInitStates _hdOallSynmap = rule344 _lhsIallSynmap _hdOallVisitKinds = rule345 _lhsIallVisitKinds _hdOallchildvisit = rule346 _lhsIallchildvisit _hdOallstates = rule347 _lhsIallstates _hdOavisitdefs = rule348 _lhsIavisitdefs _hdOavisituses = rule349 _lhsIavisituses _hdOclassCtxs = rule350 _lhsIclassCtxs _hdOimportBlocks = rule351 _lhsIimportBlocks _hdOinhmap = rule352 _lhsIinhmap _hdOinitial = rule353 _lhsIinitial _hdOlocalAttrTypes = rule354 _lhsIlocalAttrTypes _hdOmainFile = rule355 _lhsImainFile _hdOmainName = rule356 _lhsImainName _hdOmoduleHeader = rule357 _lhsImoduleHeader _hdOnextVisits = rule358 _lhsInextVisits _hdOnt = rule359 _lhsInt _hdOntType = rule360 _lhsIntType _hdOoptions = rule361 _lhsIoptions _hdOparams = rule362 _lhsIparams _hdOpragmaBlocks = rule363 _lhsIpragmaBlocks _hdOprevVisits = rule364 _lhsIprevVisits _hdOrename = rule365 _lhsIrename _hdOsynmap = rule366 _lhsIsynmap _hdOtextBlocks = rule367 _lhsItextBlocks _tlOallFromToStates = rule368 _lhsIallFromToStates _tlOallInhmap = rule369 _lhsIallInhmap _tlOallInitStates = rule370 _lhsIallInitStates _tlOallSynmap = rule371 _lhsIallSynmap _tlOallVisitKinds = rule372 _lhsIallVisitKinds _tlOallchildvisit = rule373 _lhsIallchildvisit _tlOallstates = rule374 _lhsIallstates _tlOavisitdefs = rule375 _lhsIavisitdefs _tlOavisituses = rule376 _lhsIavisituses _tlOclassCtxs = rule377 _lhsIclassCtxs _tlOimportBlocks = rule378 _lhsIimportBlocks _tlOinhmap = rule379 _lhsIinhmap _tlOinitial = rule380 _lhsIinitial _tlOlocalAttrTypes = rule381 _lhsIlocalAttrTypes _tlOmainFile = rule382 _lhsImainFile _tlOmainName = rule383 _lhsImainName _tlOmoduleHeader = rule384 _lhsImoduleHeader _tlOnextVisits = rule385 _lhsInextVisits _tlOnt = rule386 _lhsInt _tlOntType = rule387 _lhsIntType _tlOoptions = rule388 _lhsIoptions _tlOparams = rule389 _lhsIparams _tlOpragmaBlocks = rule390 _lhsIpragmaBlocks _tlOprevVisits = rule391 _lhsIprevVisits _tlOrename = rule392 _lhsIrename _tlOsynmap = rule393 _lhsIsynmap _tlOtextBlocks = rule394 _lhsItextBlocks __result_ = T_EProductions_vOut16 _lhsOallvisits _lhsOchildvisit _lhsOcount _lhsOdatatype _lhsOerrors _lhsOfromToStates _lhsOgenProdIO _lhsOimports _lhsOsemFunBndDefs _lhsOsemFunBndTps _lhsOsem_nt _lhsOsem_prod _lhsOt_visits _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses in __result_ ) in C_EProductions_s17 v16 {-# INLINE rule325 #-} {-# LINE 341 "./src-ag/ExecutionPlan2Hs.ag" #-} rule325 = \ ((_hdIallvisits) :: [VisitStateState]) -> {-# LINE 341 "./src-ag/ExecutionPlan2Hs.ag" #-} _hdIallvisits {-# LINE 2870 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule326 #-} {-# LINE 394 "./src-ag/ExecutionPlan2Hs.ag" #-} rule326 = \ ((_hdIt_visits) :: PP_Doc) -> {-# LINE 394 "./src-ag/ExecutionPlan2Hs.ag" #-} _hdIt_visits {-# LINE 2876 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule327 #-} rule327 = \ ((_hdIchildvisit) :: Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) ((_tlIchildvisit) :: Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) -> _hdIchildvisit `Map.union` _tlIchildvisit {-# INLINE rule328 #-} rule328 = \ ((_hdIcount) :: Int) ((_tlIcount) :: Int) -> _hdIcount + _tlIcount {-# INLINE rule329 #-} rule329 = \ ((_hdIdatatype) :: PP_Doc) ((_tlIdatatype) :: [PP_Doc]) -> _hdIdatatype : _tlIdatatype {-# INLINE rule330 #-} rule330 = \ ((_hdIerrors) :: Seq Error) ((_tlIerrors) :: Seq Error) -> _hdIerrors Seq.>< _tlIerrors {-# INLINE rule331 #-} rule331 = \ ((_hdIfromToStates) :: Map VisitIdentifier (Int,Int)) ((_tlIfromToStates) :: Map VisitIdentifier (Int,Int)) -> _hdIfromToStates `mappend` _tlIfromToStates {-# INLINE rule332 #-} rule332 = \ ((_hdIgenProdIO) :: IO ()) ((_tlIgenProdIO) :: IO ()) -> _hdIgenProdIO >> _tlIgenProdIO {-# INLINE rule333 #-} rule333 = \ ((_hdIimports) :: [PP_Doc]) ((_tlIimports) :: [PP_Doc]) -> _hdIimports ++ _tlIimports {-# INLINE rule334 #-} rule334 = \ ((_hdIsemFunBndDefs) :: Seq PP_Doc) ((_tlIsemFunBndDefs) :: Seq PP_Doc) -> _hdIsemFunBndDefs Seq.>< _tlIsemFunBndDefs {-# INLINE rule335 #-} rule335 = \ ((_hdIsemFunBndTps) :: Seq PP_Doc) ((_tlIsemFunBndTps) :: Seq PP_Doc) -> _hdIsemFunBndTps Seq.>< _tlIsemFunBndTps {-# INLINE rule336 #-} rule336 = \ ((_hdIsem_nt) :: PP_Doc) ((_tlIsem_nt) :: PP_Doc) -> _hdIsem_nt >-< _tlIsem_nt {-# INLINE rule337 #-} rule337 = \ ((_hdIsem_prod) :: PP_Doc) ((_tlIsem_prod) :: PP_Doc) -> _hdIsem_prod >-< _tlIsem_prod {-# INLINE rule338 #-} rule338 = \ ((_hdIvisitKinds) :: Map VisitIdentifier VisitKind) ((_tlIvisitKinds) :: Map VisitIdentifier VisitKind) -> _hdIvisitKinds `mappend` _tlIvisitKinds {-# INLINE rule339 #-} rule339 = \ ((_hdIvisitdefs) :: Map VisitIdentifier (Set Identifier)) ((_tlIvisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _hdIvisitdefs `uwSetUnion` _tlIvisitdefs {-# INLINE rule340 #-} rule340 = \ ((_hdIvisituses) :: Map VisitIdentifier (Set Identifier)) ((_tlIvisituses) :: Map VisitIdentifier (Set Identifier)) -> _hdIvisituses `uwSetUnion` _tlIvisituses {-# INLINE rule341 #-} rule341 = \ ((_lhsIallFromToStates) :: Map VisitIdentifier (Int,Int)) -> _lhsIallFromToStates {-# INLINE rule342 #-} rule342 = \ ((_lhsIallInhmap) :: Map NontermIdent Attributes) -> _lhsIallInhmap {-# INLINE rule343 #-} rule343 = \ ((_lhsIallInitStates) :: Map NontermIdent Int) -> _lhsIallInitStates {-# INLINE rule344 #-} rule344 = \ ((_lhsIallSynmap) :: Map NontermIdent Attributes) -> _lhsIallSynmap {-# INLINE rule345 #-} rule345 = \ ((_lhsIallVisitKinds) :: Map VisitIdentifier VisitKind) -> _lhsIallVisitKinds {-# INLINE rule346 #-} rule346 = \ ((_lhsIallchildvisit) :: Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) -> _lhsIallchildvisit {-# INLINE rule347 #-} rule347 = \ ((_lhsIallstates) :: Set StateIdentifier) -> _lhsIallstates {-# INLINE rule348 #-} rule348 = \ ((_lhsIavisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisitdefs {-# INLINE rule349 #-} rule349 = \ ((_lhsIavisituses) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisituses {-# INLINE rule350 #-} rule350 = \ ((_lhsIclassCtxs) :: ClassContext) -> _lhsIclassCtxs {-# INLINE rule351 #-} rule351 = \ ((_lhsIimportBlocks) :: PP_Doc) -> _lhsIimportBlocks {-# INLINE rule352 #-} rule352 = \ ((_lhsIinhmap) :: Attributes) -> _lhsIinhmap {-# INLINE rule353 #-} rule353 = \ ((_lhsIinitial) :: StateIdentifier) -> _lhsIinitial {-# INLINE rule354 #-} rule354 = \ ((_lhsIlocalAttrTypes) :: Map ConstructorIdent (Map Identifier Type)) -> _lhsIlocalAttrTypes {-# INLINE rule355 #-} rule355 = \ ((_lhsImainFile) :: String) -> _lhsImainFile {-# INLINE rule356 #-} rule356 = \ ((_lhsImainName) :: String) -> _lhsImainName {-# INLINE rule357 #-} rule357 = \ ((_lhsImoduleHeader) :: String -> String -> String -> Bool -> String) -> _lhsImoduleHeader {-# INLINE rule358 #-} rule358 = \ ((_lhsInextVisits) :: Map StateIdentifier StateCtx) -> _lhsInextVisits {-# INLINE rule359 #-} rule359 = \ ((_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule360 #-} rule360 = \ ((_lhsIntType) :: Type) -> _lhsIntType {-# INLINE rule361 #-} rule361 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule362 #-} rule362 = \ ((_lhsIparams) :: [Identifier]) -> _lhsIparams {-# INLINE rule363 #-} rule363 = \ ((_lhsIpragmaBlocks) :: String) -> _lhsIpragmaBlocks {-# INLINE rule364 #-} rule364 = \ ((_lhsIprevVisits) :: Map StateIdentifier StateCtx) -> _lhsIprevVisits {-# INLINE rule365 #-} rule365 = \ ((_lhsIrename) :: Bool) -> _lhsIrename {-# INLINE rule366 #-} rule366 = \ ((_lhsIsynmap) :: Attributes) -> _lhsIsynmap {-# INLINE rule367 #-} rule367 = \ ((_lhsItextBlocks) :: PP_Doc) -> _lhsItextBlocks {-# INLINE rule368 #-} rule368 = \ ((_lhsIallFromToStates) :: Map VisitIdentifier (Int,Int)) -> _lhsIallFromToStates {-# INLINE rule369 #-} rule369 = \ ((_lhsIallInhmap) :: Map NontermIdent Attributes) -> _lhsIallInhmap {-# INLINE rule370 #-} rule370 = \ ((_lhsIallInitStates) :: Map NontermIdent Int) -> _lhsIallInitStates {-# INLINE rule371 #-} rule371 = \ ((_lhsIallSynmap) :: Map NontermIdent Attributes) -> _lhsIallSynmap {-# INLINE rule372 #-} rule372 = \ ((_lhsIallVisitKinds) :: Map VisitIdentifier VisitKind) -> _lhsIallVisitKinds {-# INLINE rule373 #-} rule373 = \ ((_lhsIallchildvisit) :: Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) -> _lhsIallchildvisit {-# INLINE rule374 #-} rule374 = \ ((_lhsIallstates) :: Set StateIdentifier) -> _lhsIallstates {-# INLINE rule375 #-} rule375 = \ ((_lhsIavisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisitdefs {-# INLINE rule376 #-} rule376 = \ ((_lhsIavisituses) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisituses {-# INLINE rule377 #-} rule377 = \ ((_lhsIclassCtxs) :: ClassContext) -> _lhsIclassCtxs {-# INLINE rule378 #-} rule378 = \ ((_lhsIimportBlocks) :: PP_Doc) -> _lhsIimportBlocks {-# INLINE rule379 #-} rule379 = \ ((_lhsIinhmap) :: Attributes) -> _lhsIinhmap {-# INLINE rule380 #-} rule380 = \ ((_lhsIinitial) :: StateIdentifier) -> _lhsIinitial {-# INLINE rule381 #-} rule381 = \ ((_lhsIlocalAttrTypes) :: Map ConstructorIdent (Map Identifier Type)) -> _lhsIlocalAttrTypes {-# INLINE rule382 #-} rule382 = \ ((_lhsImainFile) :: String) -> _lhsImainFile {-# INLINE rule383 #-} rule383 = \ ((_lhsImainName) :: String) -> _lhsImainName {-# INLINE rule384 #-} rule384 = \ ((_lhsImoduleHeader) :: String -> String -> String -> Bool -> String) -> _lhsImoduleHeader {-# INLINE rule385 #-} rule385 = \ ((_lhsInextVisits) :: Map StateIdentifier StateCtx) -> _lhsInextVisits {-# INLINE rule386 #-} rule386 = \ ((_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule387 #-} rule387 = \ ((_lhsIntType) :: Type) -> _lhsIntType {-# INLINE rule388 #-} rule388 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule389 #-} rule389 = \ ((_lhsIparams) :: [Identifier]) -> _lhsIparams {-# INLINE rule390 #-} rule390 = \ ((_lhsIpragmaBlocks) :: String) -> _lhsIpragmaBlocks {-# INLINE rule391 #-} rule391 = \ ((_lhsIprevVisits) :: Map StateIdentifier StateCtx) -> _lhsIprevVisits {-# INLINE rule392 #-} rule392 = \ ((_lhsIrename) :: Bool) -> _lhsIrename {-# INLINE rule393 #-} rule393 = \ ((_lhsIsynmap) :: Attributes) -> _lhsIsynmap {-# INLINE rule394 #-} rule394 = \ ((_lhsItextBlocks) :: PP_Doc) -> _lhsItextBlocks {-# NOINLINE sem_EProductions_Nil #-} sem_EProductions_Nil :: T_EProductions sem_EProductions_Nil = T_EProductions (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_EProductions_v16 v16 = \ (T_EProductions_vIn16 _lhsIallFromToStates _lhsIallInhmap _lhsIallInitStates _lhsIallSynmap _lhsIallVisitKinds _lhsIallchildvisit _lhsIallstates _lhsIavisitdefs _lhsIavisituses _lhsIclassCtxs _lhsIimportBlocks _lhsIinhmap _lhsIinitial _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInextVisits _lhsInt _lhsIntType _lhsIoptions _lhsIparams _lhsIpragmaBlocks _lhsIprevVisits _lhsIrename _lhsIsynmap _lhsItextBlocks) -> ( let _lhsOallvisits :: [VisitStateState] _lhsOallvisits = rule395 () _lhsOchildvisit :: Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc)) _lhsOchildvisit = rule396 () _lhsOcount :: Int _lhsOcount = rule397 () _lhsOdatatype :: [PP_Doc] _lhsOdatatype = rule398 () _lhsOerrors :: Seq Error _lhsOerrors = rule399 () _lhsOfromToStates :: Map VisitIdentifier (Int,Int) _lhsOfromToStates = rule400 () _lhsOgenProdIO :: IO () _lhsOgenProdIO = rule401 () _lhsOimports :: [PP_Doc] _lhsOimports = rule402 () _lhsOsemFunBndDefs :: Seq PP_Doc _lhsOsemFunBndDefs = rule403 () _lhsOsemFunBndTps :: Seq PP_Doc _lhsOsemFunBndTps = rule404 () _lhsOsem_nt :: PP_Doc _lhsOsem_nt = rule405 () _lhsOsem_prod :: PP_Doc _lhsOsem_prod = rule406 () _lhsOt_visits :: PP_Doc _lhsOt_visits = rule407 () _lhsOvisitKinds :: Map VisitIdentifier VisitKind _lhsOvisitKinds = rule408 () _lhsOvisitdefs :: Map VisitIdentifier (Set Identifier) _lhsOvisitdefs = rule409 () _lhsOvisituses :: Map VisitIdentifier (Set Identifier) _lhsOvisituses = rule410 () __result_ = T_EProductions_vOut16 _lhsOallvisits _lhsOchildvisit _lhsOcount _lhsOdatatype _lhsOerrors _lhsOfromToStates _lhsOgenProdIO _lhsOimports _lhsOsemFunBndDefs _lhsOsemFunBndTps _lhsOsem_nt _lhsOsem_prod _lhsOt_visits _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses in __result_ ) in C_EProductions_s17 v16 {-# INLINE rule395 #-} {-# LINE 342 "./src-ag/ExecutionPlan2Hs.ag" #-} rule395 = \ (_ :: ()) -> {-# LINE 342 "./src-ag/ExecutionPlan2Hs.ag" #-} error "Every nonterminal should have at least 1 production" {-# LINE 3128 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule396 #-} rule396 = \ (_ :: ()) -> Map.empty {-# INLINE rule397 #-} rule397 = \ (_ :: ()) -> 0 {-# INLINE rule398 #-} rule398 = \ (_ :: ()) -> [] {-# INLINE rule399 #-} rule399 = \ (_ :: ()) -> Seq.empty {-# INLINE rule400 #-} rule400 = \ (_ :: ()) -> mempty {-# INLINE rule401 #-} rule401 = \ (_ :: ()) -> return () {-# INLINE rule402 #-} rule402 = \ (_ :: ()) -> [] {-# INLINE rule403 #-} rule403 = \ (_ :: ()) -> Seq.empty {-# INLINE rule404 #-} rule404 = \ (_ :: ()) -> Seq.empty {-# INLINE rule405 #-} rule405 = \ (_ :: ()) -> empty {-# INLINE rule406 #-} rule406 = \ (_ :: ()) -> empty {-# INLINE rule407 #-} rule407 = \ (_ :: ()) -> empty {-# INLINE rule408 #-} rule408 = \ (_ :: ()) -> mempty {-# INLINE rule409 #-} rule409 = \ (_ :: ()) -> Map.empty {-# INLINE rule410 #-} rule410 = \ (_ :: ()) -> Map.empty -- ERule ------------------------------------------------------- -- wrapper data Inh_ERule = Inh_ERule { allInhmap_Inh_ERule :: (Map NontermIdent Attributes), allSynmap_Inh_ERule :: (Map NontermIdent Attributes), childTypes_Inh_ERule :: (Map Identifier Type), con_Inh_ERule :: (ConstructorIdent), importBlocks_Inh_ERule :: (PP_Doc), inhmap_Inh_ERule :: (Attributes), lazyIntras_Inh_ERule :: (Set String), localAttrTypes_Inh_ERule :: (Map Identifier Type), mainFile_Inh_ERule :: (String), mainName_Inh_ERule :: (String), moduleHeader_Inh_ERule :: (String -> String -> String -> Bool -> String), nt_Inh_ERule :: (NontermIdent), options_Inh_ERule :: (Options), pragmaBlocks_Inh_ERule :: (String), ruleKinds_Inh_ERule :: (Map Identifier (Set VisitKind)), synmap_Inh_ERule :: (Attributes), textBlocks_Inh_ERule :: (PP_Doc), usageInfo_Inh_ERule :: (Map Identifier Int) } data Syn_ERule = Syn_ERule { errors_Syn_ERule :: (Seq Error), mrules_Syn_ERule :: (Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)), ruledefs_Syn_ERule :: (Map Identifier (Set String)), ruleuses_Syn_ERule :: (Map Identifier (Map String (Maybe NonLocalAttr))), sem_rules_Syn_ERule :: (PP_Doc), usedArgs_Syn_ERule :: (Set String) } {-# INLINABLE wrap_ERule #-} wrap_ERule :: T_ERule -> Inh_ERule -> (Syn_ERule ) wrap_ERule (T_ERule act) (Inh_ERule _lhsIallInhmap _lhsIallSynmap _lhsIchildTypes _lhsIcon _lhsIimportBlocks _lhsIinhmap _lhsIlazyIntras _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInt _lhsIoptions _lhsIpragmaBlocks _lhsIruleKinds _lhsIsynmap _lhsItextBlocks _lhsIusageInfo) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_ERule_vIn19 _lhsIallInhmap _lhsIallSynmap _lhsIchildTypes _lhsIcon _lhsIimportBlocks _lhsIinhmap _lhsIlazyIntras _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInt _lhsIoptions _lhsIpragmaBlocks _lhsIruleKinds _lhsIsynmap _lhsItextBlocks _lhsIusageInfo (T_ERule_vOut19 _lhsOerrors _lhsOmrules _lhsOruledefs _lhsOruleuses _lhsOsem_rules _lhsOusedArgs) <- return (inv_ERule_s20 sem arg) return (Syn_ERule _lhsOerrors _lhsOmrules _lhsOruledefs _lhsOruleuses _lhsOsem_rules _lhsOusedArgs) ) -- cata {-# INLINE sem_ERule #-} sem_ERule :: ERule -> T_ERule sem_ERule ( ERule name_ pattern_ rhs_ owrt_ origin_ explicit_ pure_ mbError_ ) = sem_ERule_ERule name_ ( sem_Pattern pattern_ ) ( sem_Expression rhs_ ) owrt_ origin_ explicit_ pure_ mbError_ -- semantic domain newtype T_ERule = T_ERule { attach_T_ERule :: Identity (T_ERule_s20 ) } newtype T_ERule_s20 = C_ERule_s20 { inv_ERule_s20 :: (T_ERule_v19 ) } data T_ERule_s21 = C_ERule_s21 type T_ERule_v19 = (T_ERule_vIn19 ) -> (T_ERule_vOut19 ) data T_ERule_vIn19 = T_ERule_vIn19 (Map NontermIdent Attributes) (Map NontermIdent Attributes) (Map Identifier Type) (ConstructorIdent) (PP_Doc) (Attributes) (Set String) (Map Identifier Type) (String) (String) (String -> String -> String -> Bool -> String) (NontermIdent) (Options) (String) (Map Identifier (Set VisitKind)) (Attributes) (PP_Doc) (Map Identifier Int) data T_ERule_vOut19 = T_ERule_vOut19 (Seq Error) (Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)) (Map Identifier (Set String)) (Map Identifier (Map String (Maybe NonLocalAttr))) (PP_Doc) (Set String) {-# NOINLINE sem_ERule_ERule #-} sem_ERule_ERule :: (Identifier) -> T_Pattern -> T_Expression -> (Bool) -> (String) -> (Bool) -> (Bool) -> (Maybe Error) -> T_ERule sem_ERule_ERule arg_name_ arg_pattern_ arg_rhs_ _ _ arg_explicit_ arg_pure_ arg_mbError_ = T_ERule (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_ERule_v19 v19 = \ (T_ERule_vIn19 _lhsIallInhmap _lhsIallSynmap _lhsIchildTypes _lhsIcon _lhsIimportBlocks _lhsIinhmap _lhsIlazyIntras _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInt _lhsIoptions _lhsIpragmaBlocks _lhsIruleKinds _lhsIsynmap _lhsItextBlocks _lhsIusageInfo) -> ( let _patternX41 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pattern_)) _rhsX29 = Control.Monad.Identity.runIdentity (attach_T_Expression (arg_rhs_)) (T_Pattern_vOut40 _patternIattrTypes _patternIattrs _patternIcopy _patternIisUnderscore _patternIsem_lhs) = inv_Pattern_s41 _patternX41 (T_Pattern_vIn40 _patternOallInhmap _patternOallSynmap _patternOanyLazyKind _patternOinhmap _patternOlocalAttrTypes _patternOoptions _patternOsynmap) (T_Expression_vOut28 _rhsIattrs _rhsIpos _rhsIsemfunc _rhsItks) = inv_Expression_s29 _rhsX29 (T_Expression_vIn28 ) _lhsOusedArgs :: Set String _lhsOusedArgs = rule411 _usedArgs_augmented_f1 _usedArgs_augmented_syn _usedArgs_augmented_f1 = rule412 _rhsIattrs _lhsOsem_rules :: PP_Doc _lhsOsem_rules = rule413 _rulePragma _rulecode _used _rulecode = rule414 _endpragma _genpragma _lambda _pragma _rhsIpos _rhsIsemfunc _scc _rulePragma = rule415 _lhsIoptions _used arg_explicit_ arg_name_ _scc = rule416 _lhsIcon _lhsInt _lhsIoptions _rhsIpos arg_explicit_ arg_name_ arg_pure_ _pragma = rule417 _rhsIpos _endpragma = rule418 _lhsImainFile _genpragma = rule419 _haspos _lhsIoptions arg_explicit_ _haspos = rule420 _rhsIpos _lambda = rule421 _argPats _lhsIoptions _rhsIattrs arg_name_ _argPats = rule422 _addbang1 _lhsIallInhmap _lhsIallSynmap _lhsIchildTypes _lhsIlazyIntras _lhsIlocalAttrTypes _lhsIoptions _rhsIattrs _argExprs = rule423 _rhsIattrs _stepcode = rule424 _argExprs _lhsIoptions _patternIattrTypes _patternIsem_lhs _rhsIattrs arg_name_ arg_pure_ _lhsOmrules :: Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc) _lhsOmrules = rule425 _stepcode arg_name_ _used = rule426 _lhsIusageInfo arg_name_ _kinds = rule427 _lhsIruleKinds arg_name_ _anyLazyKind = rule428 _kinds _lhsOruledefs :: Map Identifier (Set String) _lhsOruledefs = rule429 _patternIattrs arg_name_ _lhsOruleuses :: Map Identifier (Map String (Maybe NonLocalAttr)) _lhsOruleuses = rule430 _rhsIattrs arg_name_ _addbang = rule431 _lhsIoptions _addbang1 = rule432 _addbang _anyLazyKind _lhsOerrors :: Seq Error _lhsOerrors = rule433 _used arg_mbError_ _usedArgs_augmented_syn = rule434 () _patternOallInhmap = rule435 _lhsIallInhmap _patternOallSynmap = rule436 _lhsIallSynmap _patternOanyLazyKind = rule437 _anyLazyKind _patternOinhmap = rule438 _lhsIinhmap _patternOlocalAttrTypes = rule439 _lhsIlocalAttrTypes _patternOoptions = rule440 _lhsIoptions _patternOsynmap = rule441 _lhsIsynmap __result_ = T_ERule_vOut19 _lhsOerrors _lhsOmrules _lhsOruledefs _lhsOruleuses _lhsOsem_rules _lhsOusedArgs in __result_ ) in C_ERule_s20 v19 {-# INLINE rule411 #-} rule411 = \ _usedArgs_augmented_f1 _usedArgs_augmented_syn -> foldr ($) _usedArgs_augmented_syn [_usedArgs_augmented_f1] {-# INLINE rule412 #-} rule412 = \ ((_rhsIattrs) :: Map String (Maybe NonLocalAttr)) -> Set.union $ Map.keysSet $ Map.mapKeys (\a -> "arg_" ++ a) $ Map.filter isNothing _rhsIattrs {-# INLINE rule413 #-} {-# LINE 982 "./src-ag/ExecutionPlan2Hs.ag" #-} rule413 = \ _rulePragma _rulecode _used -> {-# LINE 982 "./src-ag/ExecutionPlan2Hs.ag" #-} if _used == 0 then empty else _rulePragma >-< _rulecode {-# LINE 3269 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule414 #-} {-# LINE 985 "./src-ag/ExecutionPlan2Hs.ag" #-} rule414 = \ _endpragma _genpragma _lambda _pragma ((_rhsIpos) :: Pos) ((_rhsIsemfunc) :: PP_Doc) _scc -> {-# LINE 985 "./src-ag/ExecutionPlan2Hs.ag" #-} ( if _genpragma then _pragma else empty ) >-< _lambda >#< _scc >-< indent ((column _rhsIpos - 2) `max` 2) ( if _genpragma then _pragma >-< _rhsIsemfunc >-< _endpragma else _rhsIsemfunc ) {-# LINE 3284 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule415 #-} {-# LINE 997 "./src-ag/ExecutionPlan2Hs.ag" #-} rule415 = \ ((_lhsIoptions) :: Options) _used explicit_ name_ -> {-# LINE 997 "./src-ag/ExecutionPlan2Hs.ag" #-} ( let reallyInlineStr = "INLINE" reallyNoInlineStr = "NOINLINE" in if noInlinePragmas _lhsIoptions then empty else if _used == 1 then ppPragmaBinding reallyInlineStr name_ else if helpInlining _lhsIoptions then if not explicit_ && _used <= reallyOftenUsedThreshold then ppPragmaBinding "INLINE[1]" name_ else if _used > ruleInlineThresholdSoft && explicit_ then if _used > ruleInlineThresholdHard then ppPragmaBinding reallyNoInlineStr name_ else if aggressiveInlinePragmas _lhsIoptions then ppPragmaBinding "NOINLINE[2]" name_ else ppNoInline name_ else if aggressiveInlinePragmas _lhsIoptions then ppPragmaBinding "NOINLINE[1]" name_ else ppNoInline name_ else if not explicit_ || _used <= ruleInlineThresholdSoft then ppPragmaBinding "NOINLINE[1]" name_ else ppNoInline name_ ) {-# LINE 3311 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule416 #-} {-# LINE 1019 "./src-ag/ExecutionPlan2Hs.ag" #-} rule416 = \ ((_lhsIcon) :: ConstructorIdent) ((_lhsInt) :: NontermIdent) ((_lhsIoptions) :: Options) ((_rhsIpos) :: Pos) explicit_ name_ pure_ -> {-# LINE 1019 "./src-ag/ExecutionPlan2Hs.ag" #-} if genCostCentres _lhsIoptions && explicit_ && pure_ && not (noPerRuleCostCentres _lhsIoptions) then ppCostCentre (name_ >|< "_" >|< line _rhsIpos >|< "_" >|< _lhsInt >|< "_" >|< _lhsIcon) else empty {-# LINE 3319 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule417 #-} {-# LINE 1022 "./src-ag/ExecutionPlan2Hs.ag" #-} rule417 = \ ((_rhsIpos) :: Pos) -> {-# LINE 1022 "./src-ag/ExecutionPlan2Hs.ag" #-} "{-# LINE" >#< show (line _rhsIpos) >#< show (file _rhsIpos) >#< "#-}" {-# LINE 3325 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule418 #-} {-# LINE 1023 "./src-ag/ExecutionPlan2Hs.ag" #-} rule418 = \ ((_lhsImainFile) :: String) -> {-# LINE 1023 "./src-ag/ExecutionPlan2Hs.ag" #-} ppWithLineNr (\ln -> "{-# LINE " ++ show (ln+1) ++ " " ++ show _lhsImainFile ++ "#-}") {-# LINE 3331 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule419 #-} {-# LINE 1024 "./src-ag/ExecutionPlan2Hs.ag" #-} rule419 = \ _haspos ((_lhsIoptions) :: Options) explicit_ -> {-# LINE 1024 "./src-ag/ExecutionPlan2Hs.ag" #-} genLinePragmas _lhsIoptions && explicit_ && _haspos {-# LINE 3337 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule420 #-} {-# LINE 1025 "./src-ag/ExecutionPlan2Hs.ag" #-} rule420 = \ ((_rhsIpos) :: Pos) -> {-# LINE 1025 "./src-ag/ExecutionPlan2Hs.ag" #-} line _rhsIpos > 0 && column _rhsIpos >= 0 && not (null (file _rhsIpos)) {-# LINE 3343 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule421 #-} {-# LINE 1034 "./src-ag/ExecutionPlan2Hs.ag" #-} rule421 = \ _argPats ((_lhsIoptions) :: Options) ((_rhsIattrs) :: Map String (Maybe NonLocalAttr)) name_ -> {-# LINE 1034 "./src-ag/ExecutionPlan2Hs.ag" #-} name_ >#< "=" >#< "\\" >#< _argPats >#< dummyPat _lhsIoptions (Map.null _rhsIattrs) >#< "->" {-# LINE 3349 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule422 #-} {-# LINE 1036 "./src-ag/ExecutionPlan2Hs.ag" #-} rule422 = \ _addbang1 ((_lhsIallInhmap) :: Map NontermIdent Attributes) ((_lhsIallSynmap) :: Map NontermIdent Attributes) ((_lhsIchildTypes) :: Map Identifier Type) ((_lhsIlazyIntras) :: Set String) ((_lhsIlocalAttrTypes) :: Map Identifier Type) ((_lhsIoptions) :: Options) ((_rhsIattrs) :: Map String (Maybe NonLocalAttr)) -> {-# LINE 1036 "./src-ag/ExecutionPlan2Hs.ag" #-} ppSpaced [ let match | str `Set.member` _lhsIlazyIntras = pp str | otherwise = _addbang1 (pp str) in case mbAttr of Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs _lhsIoptions) -> case Map.lookup nm _lhsIlocalAttrTypes of Just tp -> pp_parens (pp_parens match >#< "::" >#< ppTp tp) Nothing -> match Just attr | not (noPerRuleTypeSigs _lhsIoptions) -> case lookupAttrType attr _lhsIallInhmap _lhsIallSynmap _lhsIchildTypes of Just tpDoc -> pp_parens (pp_parens match >#< "::" >#< tpDoc) Nothing -> match _ -> match | (str,mbAttr) <- Map.assocs _rhsIattrs ] {-# LINE 3368 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule423 #-} {-# LINE 1050 "./src-ag/ExecutionPlan2Hs.ag" #-} rule423 = \ ((_rhsIattrs) :: Map String (Maybe NonLocalAttr)) -> {-# LINE 1050 "./src-ag/ExecutionPlan2Hs.ag" #-} ppSpaced [ case mbAttr of Nothing -> "arg_" >|< str _ -> text str | (str,mbAttr) <- Map.assocs _rhsIattrs ] {-# LINE 3378 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule424 #-} {-# LINE 1055 "./src-ag/ExecutionPlan2Hs.ag" #-} rule424 = \ _argExprs ((_lhsIoptions) :: Options) ((_patternIattrTypes) :: PP_Doc) ((_patternIsem_lhs) :: PP_Doc ) ((_rhsIattrs) :: Map String (Maybe NonLocalAttr)) name_ pure_ -> {-# LINE 1055 "./src-ag/ExecutionPlan2Hs.ag" #-} \kind fmtMode -> if kind `compatibleRule` pure_ then Right $ let oper | pure_ = "=" | otherwise = "<-" decl = _patternIsem_lhs >#< oper >#< name_ >#< _argExprs >#< dummyArg _lhsIoptions (Map.null _rhsIattrs) tp = if pure_ && not (noPerRuleTypeSigs _lhsIoptions) then _patternIattrTypes else empty in fmtDecl pure_ fmtMode (tp >-< decl) else Left $ IncompatibleRuleKind name_ kind {-# LINE 3392 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule425 #-} {-# LINE 1065 "./src-ag/ExecutionPlan2Hs.ag" #-} rule425 = \ _stepcode name_ -> {-# LINE 1065 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.singleton name_ _stepcode {-# LINE 3398 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule426 #-} {-# LINE 1269 "./src-ag/ExecutionPlan2Hs.ag" #-} rule426 = \ ((_lhsIusageInfo) :: Map Identifier Int) name_ -> {-# LINE 1269 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.findWithDefault 0 name_ _lhsIusageInfo {-# LINE 3404 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule427 #-} {-# LINE 1285 "./src-ag/ExecutionPlan2Hs.ag" #-} rule427 = \ ((_lhsIruleKinds) :: Map Identifier (Set VisitKind)) name_ -> {-# LINE 1285 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.findWithDefault Set.empty name_ _lhsIruleKinds {-# LINE 3410 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule428 #-} {-# LINE 1286 "./src-ag/ExecutionPlan2Hs.ag" #-} rule428 = \ _kinds -> {-# LINE 1286 "./src-ag/ExecutionPlan2Hs.ag" #-} Set.fold (\k r -> isLazyKind k || r) False _kinds {-# LINE 3416 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule429 #-} {-# LINE 1332 "./src-ag/ExecutionPlan2Hs.ag" #-} rule429 = \ ((_patternIattrs) :: Set String) name_ -> {-# LINE 1332 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.singleton name_ _patternIattrs {-# LINE 3422 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule430 #-} {-# LINE 1333 "./src-ag/ExecutionPlan2Hs.ag" #-} rule430 = \ ((_rhsIattrs) :: Map String (Maybe NonLocalAttr)) name_ -> {-# LINE 1333 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.singleton name_ _rhsIattrs {-# LINE 3428 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule431 #-} {-# LINE 1535 "./src-ag/ExecutionPlan2Hs.ag" #-} rule431 = \ ((_lhsIoptions) :: Options) -> {-# LINE 1535 "./src-ag/ExecutionPlan2Hs.ag" #-} \x -> if bangpats _lhsIoptions then "!" >|< x else x {-# LINE 3434 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule432 #-} {-# LINE 1546 "./src-ag/ExecutionPlan2Hs.ag" #-} rule432 = \ _addbang _anyLazyKind -> {-# LINE 1546 "./src-ag/ExecutionPlan2Hs.ag" #-} if _anyLazyKind then id else _addbang {-# LINE 3440 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule433 #-} {-# LINE 1652 "./src-ag/ExecutionPlan2Hs.ag" #-} rule433 = \ _used mbError_ -> {-# LINE 1652 "./src-ag/ExecutionPlan2Hs.ag" #-} case mbError_ of Just e | _used > 0 -> Seq.singleton e _ -> Seq.empty {-# LINE 3448 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule434 #-} rule434 = \ (_ :: ()) -> Set.empty {-# INLINE rule435 #-} rule435 = \ ((_lhsIallInhmap) :: Map NontermIdent Attributes) -> _lhsIallInhmap {-# INLINE rule436 #-} rule436 = \ ((_lhsIallSynmap) :: Map NontermIdent Attributes) -> _lhsIallSynmap {-# INLINE rule437 #-} rule437 = \ _anyLazyKind -> _anyLazyKind {-# INLINE rule438 #-} rule438 = \ ((_lhsIinhmap) :: Attributes) -> _lhsIinhmap {-# INLINE rule439 #-} rule439 = \ ((_lhsIlocalAttrTypes) :: Map Identifier Type) -> _lhsIlocalAttrTypes {-# INLINE rule440 #-} rule440 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule441 #-} rule441 = \ ((_lhsIsynmap) :: Attributes) -> _lhsIsynmap -- ERules ------------------------------------------------------ -- wrapper data Inh_ERules = Inh_ERules { allInhmap_Inh_ERules :: (Map NontermIdent Attributes), allSynmap_Inh_ERules :: (Map NontermIdent Attributes), childTypes_Inh_ERules :: (Map Identifier Type), con_Inh_ERules :: (ConstructorIdent), importBlocks_Inh_ERules :: (PP_Doc), inhmap_Inh_ERules :: (Attributes), lazyIntras_Inh_ERules :: (Set String), localAttrTypes_Inh_ERules :: (Map Identifier Type), mainFile_Inh_ERules :: (String), mainName_Inh_ERules :: (String), moduleHeader_Inh_ERules :: (String -> String -> String -> Bool -> String), nt_Inh_ERules :: (NontermIdent), options_Inh_ERules :: (Options), pragmaBlocks_Inh_ERules :: (String), ruleKinds_Inh_ERules :: (Map Identifier (Set VisitKind)), synmap_Inh_ERules :: (Attributes), textBlocks_Inh_ERules :: (PP_Doc), usageInfo_Inh_ERules :: (Map Identifier Int) } data Syn_ERules = Syn_ERules { errors_Syn_ERules :: (Seq Error), mrules_Syn_ERules :: (Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)), ruledefs_Syn_ERules :: (Map Identifier (Set String)), ruleuses_Syn_ERules :: (Map Identifier (Map String (Maybe NonLocalAttr))), sem_rules_Syn_ERules :: (PP_Doc), usedArgs_Syn_ERules :: (Set String) } {-# INLINABLE wrap_ERules #-} wrap_ERules :: T_ERules -> Inh_ERules -> (Syn_ERules ) wrap_ERules (T_ERules act) (Inh_ERules _lhsIallInhmap _lhsIallSynmap _lhsIchildTypes _lhsIcon _lhsIimportBlocks _lhsIinhmap _lhsIlazyIntras _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInt _lhsIoptions _lhsIpragmaBlocks _lhsIruleKinds _lhsIsynmap _lhsItextBlocks _lhsIusageInfo) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_ERules_vIn22 _lhsIallInhmap _lhsIallSynmap _lhsIchildTypes _lhsIcon _lhsIimportBlocks _lhsIinhmap _lhsIlazyIntras _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInt _lhsIoptions _lhsIpragmaBlocks _lhsIruleKinds _lhsIsynmap _lhsItextBlocks _lhsIusageInfo (T_ERules_vOut22 _lhsOerrors _lhsOmrules _lhsOruledefs _lhsOruleuses _lhsOsem_rules _lhsOusedArgs) <- return (inv_ERules_s23 sem arg) return (Syn_ERules _lhsOerrors _lhsOmrules _lhsOruledefs _lhsOruleuses _lhsOsem_rules _lhsOusedArgs) ) -- cata {-# NOINLINE sem_ERules #-} sem_ERules :: ERules -> T_ERules sem_ERules list = Prelude.foldr sem_ERules_Cons sem_ERules_Nil (Prelude.map sem_ERule list) -- semantic domain newtype T_ERules = T_ERules { attach_T_ERules :: Identity (T_ERules_s23 ) } newtype T_ERules_s23 = C_ERules_s23 { inv_ERules_s23 :: (T_ERules_v22 ) } data T_ERules_s24 = C_ERules_s24 type T_ERules_v22 = (T_ERules_vIn22 ) -> (T_ERules_vOut22 ) data T_ERules_vIn22 = T_ERules_vIn22 (Map NontermIdent Attributes) (Map NontermIdent Attributes) (Map Identifier Type) (ConstructorIdent) (PP_Doc) (Attributes) (Set String) (Map Identifier Type) (String) (String) (String -> String -> String -> Bool -> String) (NontermIdent) (Options) (String) (Map Identifier (Set VisitKind)) (Attributes) (PP_Doc) (Map Identifier Int) data T_ERules_vOut22 = T_ERules_vOut22 (Seq Error) (Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)) (Map Identifier (Set String)) (Map Identifier (Map String (Maybe NonLocalAttr))) (PP_Doc) (Set String) {-# NOINLINE sem_ERules_Cons #-} sem_ERules_Cons :: T_ERule -> T_ERules -> T_ERules sem_ERules_Cons arg_hd_ arg_tl_ = T_ERules (return st23) where {-# NOINLINE st23 #-} st23 = let v22 :: T_ERules_v22 v22 = \ (T_ERules_vIn22 _lhsIallInhmap _lhsIallSynmap _lhsIchildTypes _lhsIcon _lhsIimportBlocks _lhsIinhmap _lhsIlazyIntras _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInt _lhsIoptions _lhsIpragmaBlocks _lhsIruleKinds _lhsIsynmap _lhsItextBlocks _lhsIusageInfo) -> ( let _hdX20 = Control.Monad.Identity.runIdentity (attach_T_ERule (arg_hd_)) _tlX23 = Control.Monad.Identity.runIdentity (attach_T_ERules (arg_tl_)) (T_ERule_vOut19 _hdIerrors _hdImrules _hdIruledefs _hdIruleuses _hdIsem_rules _hdIusedArgs) = inv_ERule_s20 _hdX20 (T_ERule_vIn19 _hdOallInhmap _hdOallSynmap _hdOchildTypes _hdOcon _hdOimportBlocks _hdOinhmap _hdOlazyIntras _hdOlocalAttrTypes _hdOmainFile _hdOmainName _hdOmoduleHeader _hdOnt _hdOoptions _hdOpragmaBlocks _hdOruleKinds _hdOsynmap _hdOtextBlocks _hdOusageInfo) (T_ERules_vOut22 _tlIerrors _tlImrules _tlIruledefs _tlIruleuses _tlIsem_rules _tlIusedArgs) = inv_ERules_s23 _tlX23 (T_ERules_vIn22 _tlOallInhmap _tlOallSynmap _tlOchildTypes _tlOcon _tlOimportBlocks _tlOinhmap _tlOlazyIntras _tlOlocalAttrTypes _tlOmainFile _tlOmainName _tlOmoduleHeader _tlOnt _tlOoptions _tlOpragmaBlocks _tlOruleKinds _tlOsynmap _tlOtextBlocks _tlOusageInfo) _lhsOerrors :: Seq Error _lhsOerrors = rule442 _hdIerrors _tlIerrors _lhsOmrules :: Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc) _lhsOmrules = rule443 _hdImrules _tlImrules _lhsOruledefs :: Map Identifier (Set String) _lhsOruledefs = rule444 _hdIruledefs _tlIruledefs _lhsOruleuses :: Map Identifier (Map String (Maybe NonLocalAttr)) _lhsOruleuses = rule445 _hdIruleuses _tlIruleuses _lhsOsem_rules :: PP_Doc _lhsOsem_rules = rule446 _hdIsem_rules _tlIsem_rules _lhsOusedArgs :: Set String _lhsOusedArgs = rule447 _hdIusedArgs _tlIusedArgs _hdOallInhmap = rule448 _lhsIallInhmap _hdOallSynmap = rule449 _lhsIallSynmap _hdOchildTypes = rule450 _lhsIchildTypes _hdOcon = rule451 _lhsIcon _hdOimportBlocks = rule452 _lhsIimportBlocks _hdOinhmap = rule453 _lhsIinhmap _hdOlazyIntras = rule454 _lhsIlazyIntras _hdOlocalAttrTypes = rule455 _lhsIlocalAttrTypes _hdOmainFile = rule456 _lhsImainFile _hdOmainName = rule457 _lhsImainName _hdOmoduleHeader = rule458 _lhsImoduleHeader _hdOnt = rule459 _lhsInt _hdOoptions = rule460 _lhsIoptions _hdOpragmaBlocks = rule461 _lhsIpragmaBlocks _hdOruleKinds = rule462 _lhsIruleKinds _hdOsynmap = rule463 _lhsIsynmap _hdOtextBlocks = rule464 _lhsItextBlocks _hdOusageInfo = rule465 _lhsIusageInfo _tlOallInhmap = rule466 _lhsIallInhmap _tlOallSynmap = rule467 _lhsIallSynmap _tlOchildTypes = rule468 _lhsIchildTypes _tlOcon = rule469 _lhsIcon _tlOimportBlocks = rule470 _lhsIimportBlocks _tlOinhmap = rule471 _lhsIinhmap _tlOlazyIntras = rule472 _lhsIlazyIntras _tlOlocalAttrTypes = rule473 _lhsIlocalAttrTypes _tlOmainFile = rule474 _lhsImainFile _tlOmainName = rule475 _lhsImainName _tlOmoduleHeader = rule476 _lhsImoduleHeader _tlOnt = rule477 _lhsInt _tlOoptions = rule478 _lhsIoptions _tlOpragmaBlocks = rule479 _lhsIpragmaBlocks _tlOruleKinds = rule480 _lhsIruleKinds _tlOsynmap = rule481 _lhsIsynmap _tlOtextBlocks = rule482 _lhsItextBlocks _tlOusageInfo = rule483 _lhsIusageInfo __result_ = T_ERules_vOut22 _lhsOerrors _lhsOmrules _lhsOruledefs _lhsOruleuses _lhsOsem_rules _lhsOusedArgs in __result_ ) in C_ERules_s23 v22 {-# INLINE rule442 #-} rule442 = \ ((_hdIerrors) :: Seq Error) ((_tlIerrors) :: Seq Error) -> _hdIerrors Seq.>< _tlIerrors {-# INLINE rule443 #-} rule443 = \ ((_hdImrules) :: Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)) ((_tlImrules) :: Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)) -> _hdImrules `Map.union` _tlImrules {-# INLINE rule444 #-} rule444 = \ ((_hdIruledefs) :: Map Identifier (Set String)) ((_tlIruledefs) :: Map Identifier (Set String)) -> _hdIruledefs `uwSetUnion` _tlIruledefs {-# INLINE rule445 #-} rule445 = \ ((_hdIruleuses) :: Map Identifier (Map String (Maybe NonLocalAttr))) ((_tlIruleuses) :: Map Identifier (Map String (Maybe NonLocalAttr))) -> _hdIruleuses `uwMapUnion` _tlIruleuses {-# INLINE rule446 #-} rule446 = \ ((_hdIsem_rules) :: PP_Doc) ((_tlIsem_rules) :: PP_Doc) -> _hdIsem_rules >-< _tlIsem_rules {-# INLINE rule447 #-} rule447 = \ ((_hdIusedArgs) :: Set String) ((_tlIusedArgs) :: Set String) -> _hdIusedArgs `Set.union` _tlIusedArgs {-# INLINE rule448 #-} rule448 = \ ((_lhsIallInhmap) :: Map NontermIdent Attributes) -> _lhsIallInhmap {-# INLINE rule449 #-} rule449 = \ ((_lhsIallSynmap) :: Map NontermIdent Attributes) -> _lhsIallSynmap {-# INLINE rule450 #-} rule450 = \ ((_lhsIchildTypes) :: Map Identifier Type) -> _lhsIchildTypes {-# INLINE rule451 #-} rule451 = \ ((_lhsIcon) :: ConstructorIdent) -> _lhsIcon {-# INLINE rule452 #-} rule452 = \ ((_lhsIimportBlocks) :: PP_Doc) -> _lhsIimportBlocks {-# INLINE rule453 #-} rule453 = \ ((_lhsIinhmap) :: Attributes) -> _lhsIinhmap {-# INLINE rule454 #-} rule454 = \ ((_lhsIlazyIntras) :: Set String) -> _lhsIlazyIntras {-# INLINE rule455 #-} rule455 = \ ((_lhsIlocalAttrTypes) :: Map Identifier Type) -> _lhsIlocalAttrTypes {-# INLINE rule456 #-} rule456 = \ ((_lhsImainFile) :: String) -> _lhsImainFile {-# INLINE rule457 #-} rule457 = \ ((_lhsImainName) :: String) -> _lhsImainName {-# INLINE rule458 #-} rule458 = \ ((_lhsImoduleHeader) :: String -> String -> String -> Bool -> String) -> _lhsImoduleHeader {-# INLINE rule459 #-} rule459 = \ ((_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule460 #-} rule460 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule461 #-} rule461 = \ ((_lhsIpragmaBlocks) :: String) -> _lhsIpragmaBlocks {-# INLINE rule462 #-} rule462 = \ ((_lhsIruleKinds) :: Map Identifier (Set VisitKind)) -> _lhsIruleKinds {-# INLINE rule463 #-} rule463 = \ ((_lhsIsynmap) :: Attributes) -> _lhsIsynmap {-# INLINE rule464 #-} rule464 = \ ((_lhsItextBlocks) :: PP_Doc) -> _lhsItextBlocks {-# INLINE rule465 #-} rule465 = \ ((_lhsIusageInfo) :: Map Identifier Int) -> _lhsIusageInfo {-# INLINE rule466 #-} rule466 = \ ((_lhsIallInhmap) :: Map NontermIdent Attributes) -> _lhsIallInhmap {-# INLINE rule467 #-} rule467 = \ ((_lhsIallSynmap) :: Map NontermIdent Attributes) -> _lhsIallSynmap {-# INLINE rule468 #-} rule468 = \ ((_lhsIchildTypes) :: Map Identifier Type) -> _lhsIchildTypes {-# INLINE rule469 #-} rule469 = \ ((_lhsIcon) :: ConstructorIdent) -> _lhsIcon {-# INLINE rule470 #-} rule470 = \ ((_lhsIimportBlocks) :: PP_Doc) -> _lhsIimportBlocks {-# INLINE rule471 #-} rule471 = \ ((_lhsIinhmap) :: Attributes) -> _lhsIinhmap {-# INLINE rule472 #-} rule472 = \ ((_lhsIlazyIntras) :: Set String) -> _lhsIlazyIntras {-# INLINE rule473 #-} rule473 = \ ((_lhsIlocalAttrTypes) :: Map Identifier Type) -> _lhsIlocalAttrTypes {-# INLINE rule474 #-} rule474 = \ ((_lhsImainFile) :: String) -> _lhsImainFile {-# INLINE rule475 #-} rule475 = \ ((_lhsImainName) :: String) -> _lhsImainName {-# INLINE rule476 #-} rule476 = \ ((_lhsImoduleHeader) :: String -> String -> String -> Bool -> String) -> _lhsImoduleHeader {-# INLINE rule477 #-} rule477 = \ ((_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule478 #-} rule478 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule479 #-} rule479 = \ ((_lhsIpragmaBlocks) :: String) -> _lhsIpragmaBlocks {-# INLINE rule480 #-} rule480 = \ ((_lhsIruleKinds) :: Map Identifier (Set VisitKind)) -> _lhsIruleKinds {-# INLINE rule481 #-} rule481 = \ ((_lhsIsynmap) :: Attributes) -> _lhsIsynmap {-# INLINE rule482 #-} rule482 = \ ((_lhsItextBlocks) :: PP_Doc) -> _lhsItextBlocks {-# INLINE rule483 #-} rule483 = \ ((_lhsIusageInfo) :: Map Identifier Int) -> _lhsIusageInfo {-# NOINLINE sem_ERules_Nil #-} sem_ERules_Nil :: T_ERules sem_ERules_Nil = T_ERules (return st23) where {-# NOINLINE st23 #-} st23 = let v22 :: T_ERules_v22 v22 = \ (T_ERules_vIn22 _lhsIallInhmap _lhsIallSynmap _lhsIchildTypes _lhsIcon _lhsIimportBlocks _lhsIinhmap _lhsIlazyIntras _lhsIlocalAttrTypes _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInt _lhsIoptions _lhsIpragmaBlocks _lhsIruleKinds _lhsIsynmap _lhsItextBlocks _lhsIusageInfo) -> ( let _lhsOerrors :: Seq Error _lhsOerrors = rule484 () _lhsOmrules :: Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc) _lhsOmrules = rule485 () _lhsOruledefs :: Map Identifier (Set String) _lhsOruledefs = rule486 () _lhsOruleuses :: Map Identifier (Map String (Maybe NonLocalAttr)) _lhsOruleuses = rule487 () _lhsOsem_rules :: PP_Doc _lhsOsem_rules = rule488 () _lhsOusedArgs :: Set String _lhsOusedArgs = rule489 () __result_ = T_ERules_vOut22 _lhsOerrors _lhsOmrules _lhsOruledefs _lhsOruleuses _lhsOsem_rules _lhsOusedArgs in __result_ ) in C_ERules_s23 v22 {-# INLINE rule484 #-} rule484 = \ (_ :: ()) -> Seq.empty {-# INLINE rule485 #-} rule485 = \ (_ :: ()) -> Map.empty {-# INLINE rule486 #-} rule486 = \ (_ :: ()) -> Map.empty {-# INLINE rule487 #-} rule487 = \ (_ :: ()) -> Map.empty {-# INLINE rule488 #-} rule488 = \ (_ :: ()) -> empty {-# INLINE rule489 #-} rule489 = \ (_ :: ()) -> Set.empty -- ExecutionPlan ----------------------------------------------- -- wrapper data Inh_ExecutionPlan = Inh_ExecutionPlan { importBlocks_Inh_ExecutionPlan :: (PP_Doc), inhmap_Inh_ExecutionPlan :: (Map NontermIdent Attributes), localAttrTypes_Inh_ExecutionPlan :: (Map NontermIdent (Map ConstructorIdent (Map Identifier Type))), mainBlocksDoc_Inh_ExecutionPlan :: (PP_Doc), mainFile_Inh_ExecutionPlan :: (String), mainName_Inh_ExecutionPlan :: (String), moduleHeader_Inh_ExecutionPlan :: (String -> String -> String -> Bool -> String), options_Inh_ExecutionPlan :: (Options), pragmaBlocks_Inh_ExecutionPlan :: (String), synmap_Inh_ExecutionPlan :: (Map NontermIdent Attributes), textBlockMap_Inh_ExecutionPlan :: (Map BlockInfo PP_Doc), textBlocks_Inh_ExecutionPlan :: (PP_Doc) } data Syn_ExecutionPlan = Syn_ExecutionPlan { errors_Syn_ExecutionPlan :: (Seq Error), genIO_Syn_ExecutionPlan :: (IO ()), output_Syn_ExecutionPlan :: (PP_Doc) } {-# INLINABLE wrap_ExecutionPlan #-} wrap_ExecutionPlan :: T_ExecutionPlan -> Inh_ExecutionPlan -> (Syn_ExecutionPlan ) wrap_ExecutionPlan (T_ExecutionPlan act) (Inh_ExecutionPlan _lhsIimportBlocks _lhsIinhmap _lhsIlocalAttrTypes _lhsImainBlocksDoc _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsIoptions _lhsIpragmaBlocks _lhsIsynmap _lhsItextBlockMap _lhsItextBlocks) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_ExecutionPlan_vIn25 _lhsIimportBlocks _lhsIinhmap _lhsIlocalAttrTypes _lhsImainBlocksDoc _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsIoptions _lhsIpragmaBlocks _lhsIsynmap _lhsItextBlockMap _lhsItextBlocks (T_ExecutionPlan_vOut25 _lhsOerrors _lhsOgenIO _lhsOoutput) <- return (inv_ExecutionPlan_s26 sem arg) return (Syn_ExecutionPlan _lhsOerrors _lhsOgenIO _lhsOoutput) ) -- cata {-# INLINE sem_ExecutionPlan #-} sem_ExecutionPlan :: ExecutionPlan -> T_ExecutionPlan sem_ExecutionPlan ( ExecutionPlan nonts_ typeSyns_ wrappers_ derivings_ ) = sem_ExecutionPlan_ExecutionPlan ( sem_ENonterminals nonts_ ) typeSyns_ wrappers_ derivings_ -- semantic domain newtype T_ExecutionPlan = T_ExecutionPlan { attach_T_ExecutionPlan :: Identity (T_ExecutionPlan_s26 ) } newtype T_ExecutionPlan_s26 = C_ExecutionPlan_s26 { inv_ExecutionPlan_s26 :: (T_ExecutionPlan_v25 ) } data T_ExecutionPlan_s27 = C_ExecutionPlan_s27 type T_ExecutionPlan_v25 = (T_ExecutionPlan_vIn25 ) -> (T_ExecutionPlan_vOut25 ) data T_ExecutionPlan_vIn25 = T_ExecutionPlan_vIn25 (PP_Doc) (Map NontermIdent Attributes) (Map NontermIdent (Map ConstructorIdent (Map Identifier Type))) (PP_Doc) (String) (String) (String -> String -> String -> Bool -> String) (Options) (String) (Map NontermIdent Attributes) (Map BlockInfo PP_Doc) (PP_Doc) data T_ExecutionPlan_vOut25 = T_ExecutionPlan_vOut25 (Seq Error) (IO ()) (PP_Doc) {-# NOINLINE sem_ExecutionPlan_ExecutionPlan #-} sem_ExecutionPlan_ExecutionPlan :: T_ENonterminals -> (TypeSyns) -> (Set NontermIdent) -> (Derivings) -> T_ExecutionPlan sem_ExecutionPlan_ExecutionPlan arg_nonts_ arg_typeSyns_ arg_wrappers_ arg_derivings_ = T_ExecutionPlan (return st26) where {-# NOINLINE st26 #-} st26 = let v25 :: T_ExecutionPlan_v25 v25 = \ (T_ExecutionPlan_vIn25 _lhsIimportBlocks _lhsIinhmap _lhsIlocalAttrTypes _lhsImainBlocksDoc _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsIoptions _lhsIpragmaBlocks _lhsIsynmap _lhsItextBlockMap _lhsItextBlocks) -> ( let _nontsX11 = Control.Monad.Identity.runIdentity (attach_T_ENonterminals (arg_nonts_)) (T_ENonterminals_vOut10 _nontsIappendCommon _nontsIappendMain _nontsIchildvisit _nontsIerrors _nontsIfromToStates _nontsIgenProdIO _nontsIimports _nontsIinitStates _nontsIoutput _nontsIsemFunBndDefs _nontsIsemFunBndTps _nontsIvisitKinds _nontsIvisitdefs _nontsIvisituses) = inv_ENonterminals_s11 _nontsX11 (T_ENonterminals_vIn10 _nontsOallFromToStates _nontsOallInitStates _nontsOallVisitKinds _nontsOallchildvisit _nontsOavisitdefs _nontsOavisituses _nontsOderivings _nontsOimportBlocks _nontsOinhmap _nontsOlocalAttrTypes _nontsOmainFile _nontsOmainName _nontsOmoduleHeader _nontsOoptions _nontsOpragmaBlocks _nontsOsynmap _nontsOtextBlocks _nontsOtypeSyns _nontsOwrappers) _lhsOoutput :: PP_Doc _lhsOoutput = rule490 _commonExtra _nontsIoutput _wrappersExtra _nontsOwrappers = rule491 arg_wrappers_ _nontsOtypeSyns = rule492 arg_typeSyns_ _nontsOderivings = rule493 arg_derivings_ _wrappersExtra = rule494 _lateSemBndDef _lhsIoptions _commonExtra = rule495 _lateSemBndTp _lhsIoptions _lateSemBndTp = rule496 _lhsImainName _nontsIsemFunBndTps _lateSemBndDef = rule497 _lhsImainName _lhsIoptions _nontsIsemFunBndDefs arg_wrappers_ _nontsOallchildvisit = rule498 _nontsIchildvisit _nontsOavisitdefs = rule499 _nontsIvisitdefs _nontsOavisituses = rule500 _nontsIvisituses _lhsOgenIO :: IO () _lhsOgenIO = rule501 _genCommonModule _genMainModule _nontsIgenProdIO _mainModuleFile = rule502 _lhsImainFile _ppMonadImports = rule503 _lhsIoptions _genMainModule = rule504 _lhsImainBlocksDoc _lhsImainName _lhsImoduleHeader _lhsIoptions _lhsIpragmaBlocks _mainModuleFile _nontsIappendMain _nontsIimports _ppMonadImports _wrappersExtra _commonFile = rule505 _lhsImainFile _genCommonModule = rule506 _commonExtra _commonFile _lhsIimportBlocks _lhsImainName _lhsImoduleHeader _lhsIpragmaBlocks _lhsItextBlocks _nontsIappendCommon _ppMonadImports _nontsOallFromToStates = rule507 _nontsIfromToStates _nontsOallVisitKinds = rule508 _nontsIvisitKinds _nontsOallInitStates = rule509 _nontsIinitStates _lhsOerrors :: Seq Error _lhsOerrors = rule510 _nontsIerrors _nontsOimportBlocks = rule511 _lhsIimportBlocks _nontsOinhmap = rule512 _lhsIinhmap _nontsOlocalAttrTypes = rule513 _lhsIlocalAttrTypes _nontsOmainFile = rule514 _lhsImainFile _nontsOmainName = rule515 _lhsImainName _nontsOmoduleHeader = rule516 _lhsImoduleHeader _nontsOoptions = rule517 _lhsIoptions _nontsOpragmaBlocks = rule518 _lhsIpragmaBlocks _nontsOsynmap = rule519 _lhsIsynmap _nontsOtextBlocks = rule520 _lhsItextBlocks __result_ = T_ExecutionPlan_vOut25 _lhsOerrors _lhsOgenIO _lhsOoutput in __result_ ) in C_ExecutionPlan_s26 v25 {-# INLINE rule490 #-} {-# LINE 87 "./src-ag/ExecutionPlan2Hs.ag" #-} rule490 = \ _commonExtra ((_nontsIoutput) :: PP_Doc) _wrappersExtra -> {-# LINE 87 "./src-ag/ExecutionPlan2Hs.ag" #-} _nontsIoutput >-< _commonExtra >-< _wrappersExtra {-# LINE 3814 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule491 #-} {-# LINE 93 "./src-ag/ExecutionPlan2Hs.ag" #-} rule491 = \ wrappers_ -> {-# LINE 93 "./src-ag/ExecutionPlan2Hs.ag" #-} wrappers_ {-# LINE 3820 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule492 #-} {-# LINE 132 "./src-ag/ExecutionPlan2Hs.ag" #-} rule492 = \ typeSyns_ -> {-# LINE 132 "./src-ag/ExecutionPlan2Hs.ag" #-} typeSyns_ {-# LINE 3826 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule493 #-} {-# LINE 133 "./src-ag/ExecutionPlan2Hs.ag" #-} rule493 = \ derivings_ -> {-# LINE 133 "./src-ag/ExecutionPlan2Hs.ag" #-} derivings_ {-# LINE 3832 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule494 #-} {-# LINE 529 "./src-ag/ExecutionPlan2Hs.ag" #-} rule494 = \ _lateSemBndDef ((_lhsIoptions) :: Options) -> {-# LINE 529 "./src-ag/ExecutionPlan2Hs.ag" #-} if lateHigherOrderBinding _lhsIoptions then _lateSemBndDef else empty {-# LINE 3840 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule495 #-} {-# LINE 532 "./src-ag/ExecutionPlan2Hs.ag" #-} rule495 = \ _lateSemBndTp ((_lhsIoptions) :: Options) -> {-# LINE 532 "./src-ag/ExecutionPlan2Hs.ag" #-} if lateHigherOrderBinding _lhsIoptions then _lateSemBndTp else empty {-# LINE 3848 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule496 #-} {-# LINE 535 "./src-ag/ExecutionPlan2Hs.ag" #-} rule496 = \ ((_lhsImainName) :: String) ((_nontsIsemFunBndTps) :: Seq PP_Doc) -> {-# LINE 535 "./src-ag/ExecutionPlan2Hs.ag" #-} "data" >#< lateBindingTypeNm _lhsImainName >#< "=" >#< lateBindingTypeNm _lhsImainName >-< (indent 2 $ pp_block "{" "}" "," $ toList _nontsIsemFunBndTps) {-# LINE 3855 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule497 #-} {-# LINE 537 "./src-ag/ExecutionPlan2Hs.ag" #-} rule497 = \ ((_lhsImainName) :: String) ((_lhsIoptions) :: Options) ((_nontsIsemFunBndDefs) :: Seq PP_Doc) wrappers_ -> {-# LINE 537 "./src-ag/ExecutionPlan2Hs.ag" #-} ( if noInlinePragmas _lhsIoptions then empty else if helpInlining _lhsIoptions && Set.size wrappers_ == 1 then ppInline $ lateBindingFieldNm _lhsImainName else ppNoInline $ lateBindingFieldNm _lhsImainName ) >-< lateBindingFieldNm _lhsImainName >#< "::" >#< lateBindingTypeNm _lhsImainName >-< lateBindingFieldNm _lhsImainName >#< "=" >#< lateBindingTypeNm _lhsImainName >-< (indent 2 $ pp_block "{" "}" "," $ toList _nontsIsemFunBndDefs ) {-# LINE 3869 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule498 #-} {-# LINE 1213 "./src-ag/ExecutionPlan2Hs.ag" #-} rule498 = \ ((_nontsIchildvisit) :: Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) -> {-# LINE 1213 "./src-ag/ExecutionPlan2Hs.ag" #-} _nontsIchildvisit {-# LINE 3875 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule499 #-} {-# LINE 1357 "./src-ag/ExecutionPlan2Hs.ag" #-} rule499 = \ ((_nontsIvisitdefs) :: Map VisitIdentifier (Set Identifier)) -> {-# LINE 1357 "./src-ag/ExecutionPlan2Hs.ag" #-} _nontsIvisitdefs {-# LINE 3881 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule500 #-} {-# LINE 1358 "./src-ag/ExecutionPlan2Hs.ag" #-} rule500 = \ ((_nontsIvisituses) :: Map VisitIdentifier (Set Identifier)) -> {-# LINE 1358 "./src-ag/ExecutionPlan2Hs.ag" #-} _nontsIvisituses {-# LINE 3887 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule501 #-} {-# LINE 1429 "./src-ag/ExecutionPlan2Hs.ag" #-} rule501 = \ _genCommonModule _genMainModule ((_nontsIgenProdIO) :: IO ()) -> {-# LINE 1429 "./src-ag/ExecutionPlan2Hs.ag" #-} do _genMainModule _genCommonModule _nontsIgenProdIO {-# LINE 3895 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule502 #-} {-# LINE 1432 "./src-ag/ExecutionPlan2Hs.ag" #-} rule502 = \ ((_lhsImainFile) :: String) -> {-# LINE 1432 "./src-ag/ExecutionPlan2Hs.ag" #-} _lhsImainFile {-# LINE 3901 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule503 #-} {-# LINE 1433 "./src-ag/ExecutionPlan2Hs.ag" #-} rule503 = \ ((_lhsIoptions) :: Options) -> {-# LINE 1433 "./src-ag/ExecutionPlan2Hs.ag" #-} ( if tupleAsDummyToken _lhsIoptions then empty else pp "import GHC.Prim" ) >-< if parallelInvoke _lhsIoptions 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" {-# LINE 3915 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule504 #-} {-# LINE 1442 "./src-ag/ExecutionPlan2Hs.ag" #-} rule504 = \ ((_lhsImainBlocksDoc) :: PP_Doc) ((_lhsImainName) :: String) ((_lhsImoduleHeader) :: String -> String -> String -> Bool -> String) ((_lhsIoptions) :: Options) ((_lhsIpragmaBlocks) :: String) _mainModuleFile ((_nontsIappendMain) :: [PP_Doc]) ((_nontsIimports) :: [PP_Doc]) _ppMonadImports _wrappersExtra -> {-# LINE 1442 "./src-ag/ExecutionPlan2Hs.ag" #-} writeModule _mainModuleFile ( [ warrenFlagsPP _lhsIoptions , pp $ _lhsIpragmaBlocks , pp $ _lhsImoduleHeader _lhsImainName "" "" False , _ppMonadImports , pp $ "import " ++ _lhsImainName ++ "_common" ] ++ _nontsIimports ++ [_lhsImainBlocksDoc] ++ [_wrappersExtra ] ++ _nontsIappendMain ) {-# LINE 3932 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule505 #-} {-# LINE 1454 "./src-ag/ExecutionPlan2Hs.ag" #-} rule505 = \ ((_lhsImainFile) :: String) -> {-# LINE 1454 "./src-ag/ExecutionPlan2Hs.ag" #-} replaceBaseName _lhsImainFile (takeBaseName _lhsImainFile ++ "_common") {-# LINE 3938 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule506 #-} {-# LINE 1455 "./src-ag/ExecutionPlan2Hs.ag" #-} rule506 = \ _commonExtra _commonFile ((_lhsIimportBlocks) :: PP_Doc) ((_lhsImainName) :: String) ((_lhsImoduleHeader) :: String -> String -> String -> Bool -> String) ((_lhsIpragmaBlocks) :: String) ((_lhsItextBlocks) :: PP_Doc) ((_nontsIappendCommon) :: [PP_Doc]) _ppMonadImports -> {-# LINE 1455 "./src-ag/ExecutionPlan2Hs.ag" #-} writeModule _commonFile ( [ pp $ "{-# LANGUAGE Rank2Types, GADTs #-}" , pp $ _lhsIpragmaBlocks , pp $ _lhsImoduleHeader _lhsImainName "_common" "" True , _ppMonadImports , _lhsIimportBlocks , _lhsItextBlocks , _commonExtra ] ++ _nontsIappendCommon ) {-# LINE 3954 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule507 #-} {-# LINE 1574 "./src-ag/ExecutionPlan2Hs.ag" #-} rule507 = \ ((_nontsIfromToStates) :: Map VisitIdentifier (Int,Int)) -> {-# LINE 1574 "./src-ag/ExecutionPlan2Hs.ag" #-} _nontsIfromToStates {-# LINE 3960 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule508 #-} {-# LINE 1618 "./src-ag/ExecutionPlan2Hs.ag" #-} rule508 = \ ((_nontsIvisitKinds) :: Map VisitIdentifier VisitKind) -> {-# LINE 1618 "./src-ag/ExecutionPlan2Hs.ag" #-} _nontsIvisitKinds {-# LINE 3966 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule509 #-} {-# LINE 1632 "./src-ag/ExecutionPlan2Hs.ag" #-} rule509 = \ ((_nontsIinitStates) :: Map NontermIdent Int) -> {-# LINE 1632 "./src-ag/ExecutionPlan2Hs.ag" #-} _nontsIinitStates {-# LINE 3972 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule510 #-} rule510 = \ ((_nontsIerrors) :: Seq Error) -> _nontsIerrors {-# INLINE rule511 #-} rule511 = \ ((_lhsIimportBlocks) :: PP_Doc) -> _lhsIimportBlocks {-# INLINE rule512 #-} rule512 = \ ((_lhsIinhmap) :: Map NontermIdent Attributes) -> _lhsIinhmap {-# INLINE rule513 #-} rule513 = \ ((_lhsIlocalAttrTypes) :: Map NontermIdent (Map ConstructorIdent (Map Identifier Type))) -> _lhsIlocalAttrTypes {-# INLINE rule514 #-} rule514 = \ ((_lhsImainFile) :: String) -> _lhsImainFile {-# INLINE rule515 #-} rule515 = \ ((_lhsImainName) :: String) -> _lhsImainName {-# INLINE rule516 #-} rule516 = \ ((_lhsImoduleHeader) :: String -> String -> String -> Bool -> String) -> _lhsImoduleHeader {-# INLINE rule517 #-} rule517 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule518 #-} rule518 = \ ((_lhsIpragmaBlocks) :: String) -> _lhsIpragmaBlocks {-# INLINE rule519 #-} rule519 = \ ((_lhsIsynmap) :: Map NontermIdent Attributes) -> _lhsIsynmap {-# INLINE rule520 #-} rule520 = \ ((_lhsItextBlocks) :: PP_Doc) -> _lhsItextBlocks -- Expression -------------------------------------------------- -- wrapper data Inh_Expression = Inh_Expression { } data Syn_Expression = Syn_Expression { attrs_Syn_Expression :: (Map String (Maybe NonLocalAttr)), pos_Syn_Expression :: (Pos), semfunc_Syn_Expression :: (PP_Doc), tks_Syn_Expression :: ([HsToken]) } {-# INLINABLE wrap_Expression #-} wrap_Expression :: T_Expression -> Inh_Expression -> (Syn_Expression ) wrap_Expression (T_Expression act) (Inh_Expression ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Expression_vIn28 (T_Expression_vOut28 _lhsOattrs _lhsOpos _lhsOsemfunc _lhsOtks) <- return (inv_Expression_s29 sem arg) return (Syn_Expression _lhsOattrs _lhsOpos _lhsOsemfunc _lhsOtks) ) -- cata {-# INLINE sem_Expression #-} sem_Expression :: Expression -> T_Expression sem_Expression ( Expression pos_ tks_ ) = sem_Expression_Expression pos_ tks_ -- semantic domain newtype T_Expression = T_Expression { attach_T_Expression :: Identity (T_Expression_s29 ) } newtype T_Expression_s29 = C_Expression_s29 { inv_Expression_s29 :: (T_Expression_v28 ) } data T_Expression_s30 = C_Expression_s30 type T_Expression_v28 = (T_Expression_vIn28 ) -> (T_Expression_vOut28 ) data T_Expression_vIn28 = T_Expression_vIn28 data T_Expression_vOut28 = T_Expression_vOut28 (Map String (Maybe NonLocalAttr)) (Pos) (PP_Doc) ([HsToken]) {-# NOINLINE sem_Expression_Expression #-} sem_Expression_Expression :: (Pos) -> ([HsToken]) -> T_Expression sem_Expression_Expression arg_pos_ arg_tks_ = T_Expression (return st29) where {-# NOINLINE st29 #-} st29 = let v28 :: T_Expression_v28 v28 = \ (T_Expression_vIn28 ) -> ( let _lhsOtks :: [HsToken] _lhsOtks = rule521 arg_tks_ _lhsOpos :: Pos _lhsOpos = rule522 arg_pos_ _lhsOattrs :: Map String (Maybe NonLocalAttr) _lhsOattrs = rule523 arg_tks_ _lhsOsemfunc :: PP_Doc _lhsOsemfunc = rule524 arg_tks_ __result_ = T_Expression_vOut28 _lhsOattrs _lhsOpos _lhsOsemfunc _lhsOtks in __result_ ) in C_Expression_s29 v28 {-# INLINE rule521 #-} {-# LINE 1069 "./src-ag/ExecutionPlan2Hs.ag" #-} rule521 = \ tks_ -> {-# LINE 1069 "./src-ag/ExecutionPlan2Hs.ag" #-} tks_ {-# LINE 4060 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule522 #-} {-# LINE 1112 "./src-ag/ExecutionPlan2Hs.ag" #-} rule522 = \ pos_ -> {-# LINE 1112 "./src-ag/ExecutionPlan2Hs.ag" #-} pos_ {-# LINE 4066 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule523 #-} {-# LINE 1198 "./src-ag/ExecutionPlan2Hs.ag" #-} rule523 = \ tks_ -> {-# LINE 1198 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.unions $ map (\tok -> attrs_Syn_HsToken (wrap_HsToken (sem_HsToken tok) Inh_HsToken)) tks_ {-# LINE 4072 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule524 #-} {-# LINE 1199 "./src-ag/ExecutionPlan2Hs.ag" #-} rule524 = \ tks_ -> {-# LINE 1199 "./src-ag/ExecutionPlan2Hs.ag" #-} vlist $ showTokens $ map (\tok -> tok_Syn_HsToken (wrap_HsToken (sem_HsToken tok) Inh_HsToken)) tks_ {-# LINE 4078 "dist/build/ExecutionPlan2Hs.hs"#-} -- HsToken ----------------------------------------------------- -- wrapper data Inh_HsToken = Inh_HsToken { } data Syn_HsToken = Syn_HsToken { attrs_Syn_HsToken :: (Map String (Maybe NonLocalAttr)), tok_Syn_HsToken :: ((Pos,String)) } {-# INLINABLE wrap_HsToken #-} wrap_HsToken :: T_HsToken -> Inh_HsToken -> (Syn_HsToken ) wrap_HsToken (T_HsToken act) (Inh_HsToken ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_HsToken_vIn31 (T_HsToken_vOut31 _lhsOattrs _lhsOtok) <- return (inv_HsToken_s32 sem arg) return (Syn_HsToken _lhsOattrs _lhsOtok) ) -- cata {-# NOINLINE sem_HsToken #-} sem_HsToken :: HsToken -> T_HsToken sem_HsToken ( AGLocal var_ pos_ rdesc_ ) = sem_HsToken_AGLocal var_ pos_ rdesc_ sem_HsToken ( AGField field_ attr_ pos_ rdesc_ ) = sem_HsToken_AGField field_ attr_ pos_ rdesc_ sem_HsToken ( HsToken value_ pos_ ) = sem_HsToken_HsToken value_ pos_ sem_HsToken ( CharToken value_ pos_ ) = sem_HsToken_CharToken value_ pos_ sem_HsToken ( StrToken value_ pos_ ) = sem_HsToken_StrToken value_ pos_ sem_HsToken ( Err mesg_ pos_ ) = sem_HsToken_Err mesg_ pos_ -- semantic domain newtype T_HsToken = T_HsToken { attach_T_HsToken :: Identity (T_HsToken_s32 ) } newtype T_HsToken_s32 = C_HsToken_s32 { inv_HsToken_s32 :: (T_HsToken_v31 ) } data T_HsToken_s33 = C_HsToken_s33 type T_HsToken_v31 = (T_HsToken_vIn31 ) -> (T_HsToken_vOut31 ) data T_HsToken_vIn31 = T_HsToken_vIn31 data T_HsToken_vOut31 = T_HsToken_vOut31 (Map String (Maybe NonLocalAttr)) ((Pos,String)) {-# NOINLINE sem_HsToken_AGLocal #-} sem_HsToken_AGLocal :: (Identifier) -> (Pos) -> (Maybe String) -> T_HsToken sem_HsToken_AGLocal arg_var_ arg_pos_ _ = T_HsToken (return st32) where {-# NOINLINE st32 #-} st32 = let v31 :: T_HsToken_v31 v31 = \ (T_HsToken_vIn31 ) -> ( let _lhsOattrs :: Map String (Maybe NonLocalAttr) _lhsOattrs = rule525 arg_var_ _tok = rule526 arg_pos_ arg_var_ _lhsOtok :: (Pos,String) _lhsOtok = rule527 _tok __result_ = T_HsToken_vOut31 _lhsOattrs _lhsOtok in __result_ ) in C_HsToken_s32 v31 {-# INLINE rule525 #-} {-# LINE 1157 "./src-ag/ExecutionPlan2Hs.ag" #-} rule525 = \ var_ -> {-# LINE 1157 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.singleton (fieldname var_) Nothing {-# LINE 4135 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule526 #-} {-# LINE 1402 "./src-ag/ExecutionPlan2Hs.ag" #-} rule526 = \ pos_ var_ -> {-# LINE 1402 "./src-ag/ExecutionPlan2Hs.ag" #-} (pos_,fieldname var_) {-# LINE 4141 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule527 #-} rule527 = \ _tok -> _tok {-# NOINLINE sem_HsToken_AGField #-} sem_HsToken_AGField :: (Identifier) -> (Identifier) -> (Pos) -> (Maybe String) -> T_HsToken sem_HsToken_AGField arg_field_ arg_attr_ arg_pos_ arg_rdesc_ = T_HsToken (return st32) where {-# NOINLINE st32 #-} st32 = let v31 :: T_HsToken_v31 v31 = \ (T_HsToken_vIn31 ) -> ( let _mbAttr = rule528 arg_attr_ arg_field_ _lhsOattrs :: Map String (Maybe NonLocalAttr) _lhsOattrs = rule529 _mbAttr arg_attr_ arg_field_ _addTrace = rule530 arg_attr_ arg_field_ arg_rdesc_ _lhsOtok :: (Pos,String) _lhsOtok = rule531 _addTrace arg_attr_ arg_field_ arg_pos_ __result_ = T_HsToken_vOut31 _lhsOattrs _lhsOtok in __result_ ) in C_HsToken_s32 v31 {-# INLINE rule528 #-} {-# LINE 1158 "./src-ag/ExecutionPlan2Hs.ag" #-} rule528 = \ attr_ field_ -> {-# LINE 1158 "./src-ag/ExecutionPlan2Hs.ag" #-} if field_ == _INST || field_ == _FIELD || field_ == _INST' then Nothing else Just $ mkNonLocalAttr (field_ == _LHS) field_ attr_ {-# LINE 4168 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule529 #-} {-# LINE 1161 "./src-ag/ExecutionPlan2Hs.ag" #-} rule529 = \ _mbAttr attr_ field_ -> {-# LINE 1161 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.singleton (attrname True field_ attr_) _mbAttr {-# LINE 4174 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule530 #-} {-# LINE 1406 "./src-ag/ExecutionPlan2Hs.ag" #-} rule530 = \ attr_ field_ rdesc_ -> {-# LINE 1406 "./src-ag/ExecutionPlan2Hs.ag" #-} case rdesc_ of Just d -> \x -> "(trace " ++ show (d ++ " -> " ++ show field_ ++ "." ++ show attr_) ++ " (" ++ x ++ "))" Nothing -> id {-# LINE 4182 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule531 #-} {-# LINE 1409 "./src-ag/ExecutionPlan2Hs.ag" #-} rule531 = \ _addTrace attr_ field_ pos_ -> {-# LINE 1409 "./src-ag/ExecutionPlan2Hs.ag" #-} (pos_, _addTrace $ attrname True field_ attr_) {-# LINE 4188 "dist/build/ExecutionPlan2Hs.hs"#-} {-# NOINLINE sem_HsToken_HsToken #-} sem_HsToken_HsToken :: (String) -> (Pos) -> T_HsToken sem_HsToken_HsToken arg_value_ arg_pos_ = T_HsToken (return st32) where {-# NOINLINE st32 #-} st32 = let v31 :: T_HsToken_v31 v31 = \ (T_HsToken_vIn31 ) -> ( let _lhsOtok :: (Pos,String) _lhsOtok = rule532 arg_pos_ arg_value_ _lhsOattrs :: Map String (Maybe NonLocalAttr) _lhsOattrs = rule533 () __result_ = T_HsToken_vOut31 _lhsOattrs _lhsOtok in __result_ ) in C_HsToken_s32 v31 {-# INLINE rule532 #-} {-# LINE 1411 "./src-ag/ExecutionPlan2Hs.ag" #-} rule532 = \ pos_ value_ -> {-# LINE 1411 "./src-ag/ExecutionPlan2Hs.ag" #-} (pos_, value_) {-# LINE 4208 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule533 #-} rule533 = \ (_ :: ()) -> Map.empty {-# NOINLINE sem_HsToken_CharToken #-} sem_HsToken_CharToken :: (String) -> (Pos) -> T_HsToken sem_HsToken_CharToken arg_value_ arg_pos_ = T_HsToken (return st32) where {-# NOINLINE st32 #-} st32 = let v31 :: T_HsToken_v31 v31 = \ (T_HsToken_vIn31 ) -> ( let _lhsOtok :: (Pos,String) _lhsOtok = rule534 arg_pos_ arg_value_ _lhsOattrs :: Map String (Maybe NonLocalAttr) _lhsOattrs = rule535 () __result_ = T_HsToken_vOut31 _lhsOattrs _lhsOtok in __result_ ) in C_HsToken_s32 v31 {-# INLINE rule534 #-} {-# LINE 1413 "./src-ag/ExecutionPlan2Hs.ag" #-} rule534 = \ pos_ value_ -> {-# LINE 1413 "./src-ag/ExecutionPlan2Hs.ag" #-} (pos_, if null value_ then "" else showCharShort (head value_) ) {-# LINE 4234 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule535 #-} rule535 = \ (_ :: ()) -> Map.empty {-# NOINLINE sem_HsToken_StrToken #-} sem_HsToken_StrToken :: (String) -> (Pos) -> T_HsToken sem_HsToken_StrToken arg_value_ arg_pos_ = T_HsToken (return st32) where {-# NOINLINE st32 #-} st32 = let v31 :: T_HsToken_v31 v31 = \ (T_HsToken_vIn31 ) -> ( let _lhsOtok :: (Pos,String) _lhsOtok = rule536 arg_pos_ arg_value_ _lhsOattrs :: Map String (Maybe NonLocalAttr) _lhsOattrs = rule537 () __result_ = T_HsToken_vOut31 _lhsOattrs _lhsOtok in __result_ ) in C_HsToken_s32 v31 {-# INLINE rule536 #-} {-# LINE 1418 "./src-ag/ExecutionPlan2Hs.ag" #-} rule536 = \ pos_ value_ -> {-# LINE 1418 "./src-ag/ExecutionPlan2Hs.ag" #-} (pos_, showStrShort value_) {-# LINE 4257 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule537 #-} rule537 = \ (_ :: ()) -> Map.empty {-# NOINLINE sem_HsToken_Err #-} sem_HsToken_Err :: (String) -> (Pos) -> T_HsToken sem_HsToken_Err _ arg_pos_ = T_HsToken (return st32) where {-# NOINLINE st32 #-} st32 = let v31 :: T_HsToken_v31 v31 = \ (T_HsToken_vIn31 ) -> ( let _lhsOtok :: (Pos,String) _lhsOtok = rule538 arg_pos_ _lhsOattrs :: Map String (Maybe NonLocalAttr) _lhsOattrs = rule539 () __result_ = T_HsToken_vOut31 _lhsOattrs _lhsOtok in __result_ ) in C_HsToken_s32 v31 {-# INLINE rule538 #-} {-# LINE 1419 "./src-ag/ExecutionPlan2Hs.ag" #-} rule538 = \ pos_ -> {-# LINE 1419 "./src-ag/ExecutionPlan2Hs.ag" #-} (pos_, "") {-# LINE 4280 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule539 #-} rule539 = \ (_ :: ()) -> Map.empty -- HsTokens ---------------------------------------------------- -- wrapper data Inh_HsTokens = Inh_HsTokens { } data Syn_HsTokens = Syn_HsTokens { tks_Syn_HsTokens :: ([(Pos,String)]) } {-# INLINABLE wrap_HsTokens #-} wrap_HsTokens :: T_HsTokens -> Inh_HsTokens -> (Syn_HsTokens ) wrap_HsTokens (T_HsTokens act) (Inh_HsTokens ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_HsTokens_vIn34 (T_HsTokens_vOut34 _lhsOtks) <- return (inv_HsTokens_s35 sem arg) return (Syn_HsTokens _lhsOtks) ) -- cata {-# NOINLINE sem_HsTokens #-} sem_HsTokens :: HsTokens -> T_HsTokens sem_HsTokens list = Prelude.foldr sem_HsTokens_Cons sem_HsTokens_Nil (Prelude.map sem_HsToken list) -- semantic domain newtype T_HsTokens = T_HsTokens { attach_T_HsTokens :: Identity (T_HsTokens_s35 ) } newtype T_HsTokens_s35 = C_HsTokens_s35 { inv_HsTokens_s35 :: (T_HsTokens_v34 ) } data T_HsTokens_s36 = C_HsTokens_s36 type T_HsTokens_v34 = (T_HsTokens_vIn34 ) -> (T_HsTokens_vOut34 ) data T_HsTokens_vIn34 = T_HsTokens_vIn34 data T_HsTokens_vOut34 = T_HsTokens_vOut34 ([(Pos,String)]) {-# NOINLINE sem_HsTokens_Cons #-} sem_HsTokens_Cons :: T_HsToken -> T_HsTokens -> T_HsTokens sem_HsTokens_Cons arg_hd_ arg_tl_ = T_HsTokens (return st35) where {-# NOINLINE st35 #-} st35 = let v34 :: T_HsTokens_v34 v34 = \ (T_HsTokens_vIn34 ) -> ( let _hdX32 = Control.Monad.Identity.runIdentity (attach_T_HsToken (arg_hd_)) _tlX35 = Control.Monad.Identity.runIdentity (attach_T_HsTokens (arg_tl_)) (T_HsToken_vOut31 _hdIattrs _hdItok) = inv_HsToken_s32 _hdX32 (T_HsToken_vIn31 ) (T_HsTokens_vOut34 _tlItks) = inv_HsTokens_s35 _tlX35 (T_HsTokens_vIn34 ) _lhsOtks :: [(Pos,String)] _lhsOtks = rule540 _hdItok _tlItks __result_ = T_HsTokens_vOut34 _lhsOtks in __result_ ) in C_HsTokens_s35 v34 {-# INLINE rule540 #-} {-# LINE 1398 "./src-ag/ExecutionPlan2Hs.ag" #-} rule540 = \ ((_hdItok) :: (Pos,String)) ((_tlItks) :: [(Pos,String)]) -> {-# LINE 1398 "./src-ag/ExecutionPlan2Hs.ag" #-} _hdItok : _tlItks {-# LINE 4336 "dist/build/ExecutionPlan2Hs.hs"#-} {-# NOINLINE sem_HsTokens_Nil #-} sem_HsTokens_Nil :: T_HsTokens sem_HsTokens_Nil = T_HsTokens (return st35) where {-# NOINLINE st35 #-} st35 = let v34 :: T_HsTokens_v34 v34 = \ (T_HsTokens_vIn34 ) -> ( let _lhsOtks :: [(Pos,String)] _lhsOtks = rule541 () __result_ = T_HsTokens_vOut34 _lhsOtks in __result_ ) in C_HsTokens_s35 v34 {-# INLINE rule541 #-} {-# LINE 1399 "./src-ag/ExecutionPlan2Hs.ag" #-} rule541 = \ (_ :: ()) -> {-# LINE 1399 "./src-ag/ExecutionPlan2Hs.ag" #-} [] {-# LINE 4354 "dist/build/ExecutionPlan2Hs.hs"#-} -- HsTokensRoot ------------------------------------------------ -- wrapper data Inh_HsTokensRoot = Inh_HsTokensRoot { } data Syn_HsTokensRoot = Syn_HsTokensRoot { } {-# INLINABLE wrap_HsTokensRoot #-} wrap_HsTokensRoot :: T_HsTokensRoot -> Inh_HsTokensRoot -> (Syn_HsTokensRoot ) wrap_HsTokensRoot (T_HsTokensRoot act) (Inh_HsTokensRoot ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_HsTokensRoot_vIn37 (T_HsTokensRoot_vOut37 ) <- return (inv_HsTokensRoot_s38 sem arg) return (Syn_HsTokensRoot ) ) -- cata {-# INLINE sem_HsTokensRoot #-} sem_HsTokensRoot :: HsTokensRoot -> T_HsTokensRoot sem_HsTokensRoot ( HsTokensRoot tokens_ ) = sem_HsTokensRoot_HsTokensRoot ( sem_HsTokens tokens_ ) -- semantic domain newtype T_HsTokensRoot = T_HsTokensRoot { attach_T_HsTokensRoot :: Identity (T_HsTokensRoot_s38 ) } newtype T_HsTokensRoot_s38 = C_HsTokensRoot_s38 { inv_HsTokensRoot_s38 :: (T_HsTokensRoot_v37 ) } data T_HsTokensRoot_s39 = C_HsTokensRoot_s39 type T_HsTokensRoot_v37 = (T_HsTokensRoot_vIn37 ) -> (T_HsTokensRoot_vOut37 ) data T_HsTokensRoot_vIn37 = T_HsTokensRoot_vIn37 data T_HsTokensRoot_vOut37 = T_HsTokensRoot_vOut37 {-# NOINLINE sem_HsTokensRoot_HsTokensRoot #-} sem_HsTokensRoot_HsTokensRoot :: T_HsTokens -> T_HsTokensRoot sem_HsTokensRoot_HsTokensRoot arg_tokens_ = T_HsTokensRoot (return st38) where {-# NOINLINE st38 #-} st38 = let v37 :: T_HsTokensRoot_v37 v37 = \ (T_HsTokensRoot_vIn37 ) -> ( let _tokensX35 = Control.Monad.Identity.runIdentity (attach_T_HsTokens (arg_tokens_)) (T_HsTokens_vOut34 _tokensItks) = inv_HsTokens_s35 _tokensX35 (T_HsTokens_vIn34 ) __result_ = T_HsTokensRoot_vOut37 in __result_ ) in C_HsTokensRoot_s38 v37 -- Pattern ----------------------------------------------------- -- wrapper data Inh_Pattern = Inh_Pattern { allInhmap_Inh_Pattern :: (Map NontermIdent Attributes), allSynmap_Inh_Pattern :: (Map NontermIdent Attributes), anyLazyKind_Inh_Pattern :: (Bool), inhmap_Inh_Pattern :: (Attributes), localAttrTypes_Inh_Pattern :: (Map Identifier Type), options_Inh_Pattern :: (Options), synmap_Inh_Pattern :: (Attributes) } data Syn_Pattern = Syn_Pattern { attrTypes_Syn_Pattern :: (PP_Doc), attrs_Syn_Pattern :: (Set String), copy_Syn_Pattern :: (Pattern), isUnderscore_Syn_Pattern :: (Bool), sem_lhs_Syn_Pattern :: ( PP_Doc ) } {-# INLINABLE wrap_Pattern #-} wrap_Pattern :: T_Pattern -> Inh_Pattern -> (Syn_Pattern ) wrap_Pattern (T_Pattern act) (Inh_Pattern _lhsIallInhmap _lhsIallSynmap _lhsIanyLazyKind _lhsIinhmap _lhsIlocalAttrTypes _lhsIoptions _lhsIsynmap) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Pattern_vIn40 _lhsIallInhmap _lhsIallSynmap _lhsIanyLazyKind _lhsIinhmap _lhsIlocalAttrTypes _lhsIoptions _lhsIsynmap (T_Pattern_vOut40 _lhsOattrTypes _lhsOattrs _lhsOcopy _lhsOisUnderscore _lhsOsem_lhs) <- return (inv_Pattern_s41 sem arg) return (Syn_Pattern _lhsOattrTypes _lhsOattrs _lhsOcopy _lhsOisUnderscore _lhsOsem_lhs) ) -- cata {-# NOINLINE sem_Pattern #-} sem_Pattern :: Pattern -> T_Pattern sem_Pattern ( Constr name_ pats_ ) = sem_Pattern_Constr name_ ( sem_Patterns pats_ ) sem_Pattern ( Product pos_ pats_ ) = sem_Pattern_Product pos_ ( sem_Patterns pats_ ) sem_Pattern ( Alias field_ attr_ pat_ ) = sem_Pattern_Alias field_ attr_ ( sem_Pattern pat_ ) sem_Pattern ( Irrefutable pat_ ) = sem_Pattern_Irrefutable ( sem_Pattern pat_ ) sem_Pattern ( Underscore pos_ ) = sem_Pattern_Underscore pos_ -- semantic domain newtype T_Pattern = T_Pattern { attach_T_Pattern :: Identity (T_Pattern_s41 ) } newtype T_Pattern_s41 = C_Pattern_s41 { inv_Pattern_s41 :: (T_Pattern_v40 ) } data T_Pattern_s42 = C_Pattern_s42 type T_Pattern_v40 = (T_Pattern_vIn40 ) -> (T_Pattern_vOut40 ) data T_Pattern_vIn40 = T_Pattern_vIn40 (Map NontermIdent Attributes) (Map NontermIdent Attributes) (Bool) (Attributes) (Map Identifier Type) (Options) (Attributes) data T_Pattern_vOut40 = T_Pattern_vOut40 (PP_Doc) (Set String) (Pattern) (Bool) ( PP_Doc ) {-# NOINLINE sem_Pattern_Constr #-} sem_Pattern_Constr :: (ConstructorIdent) -> T_Patterns -> T_Pattern sem_Pattern_Constr arg_name_ arg_pats_ = T_Pattern (return st41) where {-# NOINLINE st41 #-} st41 = let v40 :: T_Pattern_v40 v40 = \ (T_Pattern_vIn40 _lhsIallInhmap _lhsIallSynmap _lhsIanyLazyKind _lhsIinhmap _lhsIlocalAttrTypes _lhsIoptions _lhsIsynmap) -> ( let _patsX44 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) (T_Patterns_vOut43 _patsIattrTypes _patsIattrs _patsIcopy _patsIsem_lhs) = inv_Patterns_s44 _patsX44 (T_Patterns_vIn43 _patsOallInhmap _patsOallSynmap _patsOanyLazyKind _patsOinhmap _patsOlocalAttrTypes _patsOoptions _patsOsynmap) _lhsOsem_lhs :: PP_Doc _lhsOsem_lhs = rule542 _addbang1 _patsIsem_lhs arg_name_ _lhsOisUnderscore :: Bool _lhsOisUnderscore = rule543 () _addbang = rule544 _lhsIoptions _addbang1 = rule545 _addbang _lhsIanyLazyKind _lhsOattrTypes :: PP_Doc _lhsOattrTypes = rule546 _patsIattrTypes _lhsOattrs :: Set String _lhsOattrs = rule547 _patsIattrs _copy = rule548 _patsIcopy arg_name_ _lhsOcopy :: Pattern _lhsOcopy = rule549 _copy _patsOallInhmap = rule550 _lhsIallInhmap _patsOallSynmap = rule551 _lhsIallSynmap _patsOanyLazyKind = rule552 _lhsIanyLazyKind _patsOinhmap = rule553 _lhsIinhmap _patsOlocalAttrTypes = rule554 _lhsIlocalAttrTypes _patsOoptions = rule555 _lhsIoptions _patsOsynmap = rule556 _lhsIsynmap __result_ = T_Pattern_vOut40 _lhsOattrTypes _lhsOattrs _lhsOcopy _lhsOisUnderscore _lhsOsem_lhs in __result_ ) in C_Pattern_s41 v40 {-# INLINE rule542 #-} {-# LINE 1126 "./src-ag/ExecutionPlan2Hs.ag" #-} rule542 = \ _addbang1 ((_patsIsem_lhs) :: [PP_Doc]) name_ -> {-# LINE 1126 "./src-ag/ExecutionPlan2Hs.ag" #-} _addbang1 $ pp_parens $ name_ >#< hv_sp _patsIsem_lhs {-# LINE 4470 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule543 #-} {-# LINE 1133 "./src-ag/ExecutionPlan2Hs.ag" #-} rule543 = \ (_ :: ()) -> {-# LINE 1133 "./src-ag/ExecutionPlan2Hs.ag" #-} False {-# LINE 4476 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule544 #-} {-# LINE 1542 "./src-ag/ExecutionPlan2Hs.ag" #-} rule544 = \ ((_lhsIoptions) :: Options) -> {-# LINE 1542 "./src-ag/ExecutionPlan2Hs.ag" #-} \x -> if bangpats _lhsIoptions then "!" >|< x else x {-# LINE 4482 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule545 #-} {-# LINE 1547 "./src-ag/ExecutionPlan2Hs.ag" #-} rule545 = \ _addbang ((_lhsIanyLazyKind) :: Bool) -> {-# LINE 1547 "./src-ag/ExecutionPlan2Hs.ag" #-} if _lhsIanyLazyKind then id else _addbang {-# LINE 4488 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule546 #-} rule546 = \ ((_patsIattrTypes) :: PP_Doc) -> _patsIattrTypes {-# INLINE rule547 #-} rule547 = \ ((_patsIattrs) :: Set String) -> _patsIattrs {-# INLINE rule548 #-} rule548 = \ ((_patsIcopy) :: Patterns) name_ -> Constr name_ _patsIcopy {-# INLINE rule549 #-} rule549 = \ _copy -> _copy {-# INLINE rule550 #-} rule550 = \ ((_lhsIallInhmap) :: Map NontermIdent Attributes) -> _lhsIallInhmap {-# INLINE rule551 #-} rule551 = \ ((_lhsIallSynmap) :: Map NontermIdent Attributes) -> _lhsIallSynmap {-# INLINE rule552 #-} rule552 = \ ((_lhsIanyLazyKind) :: Bool) -> _lhsIanyLazyKind {-# INLINE rule553 #-} rule553 = \ ((_lhsIinhmap) :: Attributes) -> _lhsIinhmap {-# INLINE rule554 #-} rule554 = \ ((_lhsIlocalAttrTypes) :: Map Identifier Type) -> _lhsIlocalAttrTypes {-# INLINE rule555 #-} rule555 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule556 #-} rule556 = \ ((_lhsIsynmap) :: Attributes) -> _lhsIsynmap {-# NOINLINE sem_Pattern_Product #-} sem_Pattern_Product :: (Pos) -> T_Patterns -> T_Pattern sem_Pattern_Product arg_pos_ arg_pats_ = T_Pattern (return st41) where {-# NOINLINE st41 #-} st41 = let v40 :: T_Pattern_v40 v40 = \ (T_Pattern_vIn40 _lhsIallInhmap _lhsIallSynmap _lhsIanyLazyKind _lhsIinhmap _lhsIlocalAttrTypes _lhsIoptions _lhsIsynmap) -> ( let _patsX44 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) (T_Patterns_vOut43 _patsIattrTypes _patsIattrs _patsIcopy _patsIsem_lhs) = inv_Patterns_s44 _patsX44 (T_Patterns_vIn43 _patsOallInhmap _patsOallSynmap _patsOanyLazyKind _patsOinhmap _patsOlocalAttrTypes _patsOoptions _patsOsynmap) _lhsOsem_lhs :: PP_Doc _lhsOsem_lhs = rule557 _addbang1 _patsIsem_lhs _lhsOisUnderscore :: Bool _lhsOisUnderscore = rule558 () _addbang = rule559 _lhsIoptions _addbang1 = rule560 _addbang _lhsIanyLazyKind _lhsOattrTypes :: PP_Doc _lhsOattrTypes = rule561 _patsIattrTypes _lhsOattrs :: Set String _lhsOattrs = rule562 _patsIattrs _copy = rule563 _patsIcopy arg_pos_ _lhsOcopy :: Pattern _lhsOcopy = rule564 _copy _patsOallInhmap = rule565 _lhsIallInhmap _patsOallSynmap = rule566 _lhsIallSynmap _patsOanyLazyKind = rule567 _lhsIanyLazyKind _patsOinhmap = rule568 _lhsIinhmap _patsOlocalAttrTypes = rule569 _lhsIlocalAttrTypes _patsOoptions = rule570 _lhsIoptions _patsOsynmap = rule571 _lhsIsynmap __result_ = T_Pattern_vOut40 _lhsOattrTypes _lhsOattrs _lhsOcopy _lhsOisUnderscore _lhsOsem_lhs in __result_ ) in C_Pattern_s41 v40 {-# INLINE rule557 #-} {-# LINE 1125 "./src-ag/ExecutionPlan2Hs.ag" #-} rule557 = \ _addbang1 ((_patsIsem_lhs) :: [PP_Doc]) -> {-# LINE 1125 "./src-ag/ExecutionPlan2Hs.ag" #-} _addbang1 $ pp_block "(" ")" "," _patsIsem_lhs {-# LINE 4559 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule558 #-} {-# LINE 1134 "./src-ag/ExecutionPlan2Hs.ag" #-} rule558 = \ (_ :: ()) -> {-# LINE 1134 "./src-ag/ExecutionPlan2Hs.ag" #-} False {-# LINE 4565 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule559 #-} {-# LINE 1542 "./src-ag/ExecutionPlan2Hs.ag" #-} rule559 = \ ((_lhsIoptions) :: Options) -> {-# LINE 1542 "./src-ag/ExecutionPlan2Hs.ag" #-} \x -> if bangpats _lhsIoptions then "!" >|< x else x {-# LINE 4571 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule560 #-} {-# LINE 1547 "./src-ag/ExecutionPlan2Hs.ag" #-} rule560 = \ _addbang ((_lhsIanyLazyKind) :: Bool) -> {-# LINE 1547 "./src-ag/ExecutionPlan2Hs.ag" #-} if _lhsIanyLazyKind then id else _addbang {-# LINE 4577 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule561 #-} rule561 = \ ((_patsIattrTypes) :: PP_Doc) -> _patsIattrTypes {-# INLINE rule562 #-} rule562 = \ ((_patsIattrs) :: Set String) -> _patsIattrs {-# INLINE rule563 #-} rule563 = \ ((_patsIcopy) :: Patterns) pos_ -> Product pos_ _patsIcopy {-# INLINE rule564 #-} rule564 = \ _copy -> _copy {-# INLINE rule565 #-} rule565 = \ ((_lhsIallInhmap) :: Map NontermIdent Attributes) -> _lhsIallInhmap {-# INLINE rule566 #-} rule566 = \ ((_lhsIallSynmap) :: Map NontermIdent Attributes) -> _lhsIallSynmap {-# INLINE rule567 #-} rule567 = \ ((_lhsIanyLazyKind) :: Bool) -> _lhsIanyLazyKind {-# INLINE rule568 #-} rule568 = \ ((_lhsIinhmap) :: Attributes) -> _lhsIinhmap {-# INLINE rule569 #-} rule569 = \ ((_lhsIlocalAttrTypes) :: Map Identifier Type) -> _lhsIlocalAttrTypes {-# INLINE rule570 #-} rule570 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule571 #-} rule571 = \ ((_lhsIsynmap) :: Attributes) -> _lhsIsynmap {-# NOINLINE sem_Pattern_Alias #-} sem_Pattern_Alias :: (Identifier) -> (Identifier) -> T_Pattern -> T_Pattern sem_Pattern_Alias arg_field_ arg_attr_ arg_pat_ = T_Pattern (return st41) where {-# NOINLINE st41 #-} st41 = let v40 :: T_Pattern_v40 v40 = \ (T_Pattern_vIn40 _lhsIallInhmap _lhsIallSynmap _lhsIanyLazyKind _lhsIinhmap _lhsIlocalAttrTypes _lhsIoptions _lhsIsynmap) -> ( let _patX41 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) (T_Pattern_vOut40 _patIattrTypes _patIattrs _patIcopy _patIisUnderscore _patIsem_lhs) = inv_Pattern_s41 _patX41 (T_Pattern_vIn40 _patOallInhmap _patOallSynmap _patOanyLazyKind _patOinhmap _patOlocalAttrTypes _patOoptions _patOsynmap) _varPat = rule572 arg_attr_ arg_field_ _patExpr = rule573 _patIisUnderscore _patIsem_lhs _varPat _lhsOsem_lhs :: PP_Doc _lhsOsem_lhs = rule574 _addbang1 _patExpr _lhsOisUnderscore :: Bool _lhsOisUnderscore = rule575 () _lhsOattrs :: Set String _lhsOattrs = rule576 _patIattrs arg_attr_ arg_field_ _mbTp = rule577 _lhsIlocalAttrTypes _lhsIsynmap arg_attr_ arg_field_ _lhsOattrTypes :: PP_Doc _lhsOattrTypes = rule578 _mbTp _patIattrTypes arg_attr_ arg_field_ _addbang = rule579 _lhsIoptions _addbang1 = rule580 _addbang _lhsIanyLazyKind _copy = rule581 _patIcopy arg_attr_ arg_field_ _lhsOcopy :: Pattern _lhsOcopy = rule582 _copy _patOallInhmap = rule583 _lhsIallInhmap _patOallSynmap = rule584 _lhsIallSynmap _patOanyLazyKind = rule585 _lhsIanyLazyKind _patOinhmap = rule586 _lhsIinhmap _patOlocalAttrTypes = rule587 _lhsIlocalAttrTypes _patOoptions = rule588 _lhsIoptions _patOsynmap = rule589 _lhsIsynmap __result_ = T_Pattern_vOut40 _lhsOattrTypes _lhsOattrs _lhsOcopy _lhsOisUnderscore _lhsOsem_lhs in __result_ ) in C_Pattern_s41 v40 {-# INLINE rule572 #-} {-# LINE 1120 "./src-ag/ExecutionPlan2Hs.ag" #-} rule572 = \ attr_ field_ -> {-# LINE 1120 "./src-ag/ExecutionPlan2Hs.ag" #-} text $ attrname False field_ attr_ {-# LINE 4651 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule573 #-} {-# LINE 1121 "./src-ag/ExecutionPlan2Hs.ag" #-} rule573 = \ ((_patIisUnderscore) :: Bool) ((_patIsem_lhs) :: PP_Doc ) _varPat -> {-# LINE 1121 "./src-ag/ExecutionPlan2Hs.ag" #-} if _patIisUnderscore then _varPat else _varPat >|< "@" >|< _patIsem_lhs {-# LINE 4659 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule574 #-} {-# LINE 1124 "./src-ag/ExecutionPlan2Hs.ag" #-} rule574 = \ _addbang1 _patExpr -> {-# LINE 1124 "./src-ag/ExecutionPlan2Hs.ag" #-} _addbang1 _patExpr {-# LINE 4665 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule575 #-} {-# LINE 1135 "./src-ag/ExecutionPlan2Hs.ag" #-} rule575 = \ (_ :: ()) -> {-# LINE 1135 "./src-ag/ExecutionPlan2Hs.ag" #-} False {-# LINE 4671 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule576 #-} {-# LINE 1141 "./src-ag/ExecutionPlan2Hs.ag" #-} rule576 = \ ((_patIattrs) :: Set String) attr_ field_ -> {-# LINE 1141 "./src-ag/ExecutionPlan2Hs.ag" #-} Set.insert (attrname False field_ attr_) _patIattrs {-# LINE 4677 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule577 #-} {-# LINE 1146 "./src-ag/ExecutionPlan2Hs.ag" #-} rule577 = \ ((_lhsIlocalAttrTypes) :: Map Identifier Type) ((_lhsIsynmap) :: Attributes) attr_ field_ -> {-# LINE 1146 "./src-ag/ExecutionPlan2Hs.ag" #-} if field_ == _LHS then Map.lookup attr_ _lhsIsynmap else if field_ == _LOC then Map.lookup attr_ _lhsIlocalAttrTypes else Nothing {-# LINE 4687 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule578 #-} {-# LINE 1151 "./src-ag/ExecutionPlan2Hs.ag" #-} rule578 = \ _mbTp ((_patIattrTypes) :: PP_Doc) attr_ field_ -> {-# LINE 1151 "./src-ag/ExecutionPlan2Hs.ag" #-} maybe empty (\tp -> (attrname False field_ attr_) >#< "::" >#< ppTp tp) _mbTp >-< _patIattrTypes {-# LINE 4694 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule579 #-} {-# LINE 1542 "./src-ag/ExecutionPlan2Hs.ag" #-} rule579 = \ ((_lhsIoptions) :: Options) -> {-# LINE 1542 "./src-ag/ExecutionPlan2Hs.ag" #-} \x -> if bangpats _lhsIoptions then "!" >|< x else x {-# LINE 4700 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule580 #-} {-# LINE 1547 "./src-ag/ExecutionPlan2Hs.ag" #-} rule580 = \ _addbang ((_lhsIanyLazyKind) :: Bool) -> {-# LINE 1547 "./src-ag/ExecutionPlan2Hs.ag" #-} if _lhsIanyLazyKind then id else _addbang {-# LINE 4706 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule581 #-} rule581 = \ ((_patIcopy) :: Pattern) attr_ field_ -> Alias field_ attr_ _patIcopy {-# INLINE rule582 #-} rule582 = \ _copy -> _copy {-# INLINE rule583 #-} rule583 = \ ((_lhsIallInhmap) :: Map NontermIdent Attributes) -> _lhsIallInhmap {-# INLINE rule584 #-} rule584 = \ ((_lhsIallSynmap) :: Map NontermIdent Attributes) -> _lhsIallSynmap {-# INLINE rule585 #-} rule585 = \ ((_lhsIanyLazyKind) :: Bool) -> _lhsIanyLazyKind {-# INLINE rule586 #-} rule586 = \ ((_lhsIinhmap) :: Attributes) -> _lhsIinhmap {-# INLINE rule587 #-} rule587 = \ ((_lhsIlocalAttrTypes) :: Map Identifier Type) -> _lhsIlocalAttrTypes {-# INLINE rule588 #-} rule588 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule589 #-} rule589 = \ ((_lhsIsynmap) :: Attributes) -> _lhsIsynmap {-# NOINLINE sem_Pattern_Irrefutable #-} sem_Pattern_Irrefutable :: T_Pattern -> T_Pattern sem_Pattern_Irrefutable arg_pat_ = T_Pattern (return st41) where {-# NOINLINE st41 #-} st41 = let v40 :: T_Pattern_v40 v40 = \ (T_Pattern_vIn40 _lhsIallInhmap _lhsIallSynmap _lhsIanyLazyKind _lhsIinhmap _lhsIlocalAttrTypes _lhsIoptions _lhsIsynmap) -> ( let _patX41 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) (T_Pattern_vOut40 _patIattrTypes _patIattrs _patIcopy _patIisUnderscore _patIsem_lhs) = inv_Pattern_s41 _patX41 (T_Pattern_vIn40 _patOallInhmap _patOallSynmap _patOanyLazyKind _patOinhmap _patOlocalAttrTypes _patOoptions _patOsynmap) _lhsOsem_lhs :: PP_Doc _lhsOsem_lhs = rule590 _patIsem_lhs _lhsOattrTypes :: PP_Doc _lhsOattrTypes = rule591 _patIattrTypes _lhsOattrs :: Set String _lhsOattrs = rule592 _patIattrs _copy = rule593 _patIcopy _lhsOcopy :: Pattern _lhsOcopy = rule594 _copy _lhsOisUnderscore :: Bool _lhsOisUnderscore = rule595 _patIisUnderscore _patOallInhmap = rule596 _lhsIallInhmap _patOallSynmap = rule597 _lhsIallSynmap _patOanyLazyKind = rule598 _lhsIanyLazyKind _patOinhmap = rule599 _lhsIinhmap _patOlocalAttrTypes = rule600 _lhsIlocalAttrTypes _patOoptions = rule601 _lhsIoptions _patOsynmap = rule602 _lhsIsynmap __result_ = T_Pattern_vOut40 _lhsOattrTypes _lhsOattrs _lhsOcopy _lhsOisUnderscore _lhsOsem_lhs in __result_ ) in C_Pattern_s41 v40 {-# INLINE rule590 #-} {-# LINE 1128 "./src-ag/ExecutionPlan2Hs.ag" #-} rule590 = \ ((_patIsem_lhs) :: PP_Doc ) -> {-# LINE 1128 "./src-ag/ExecutionPlan2Hs.ag" #-} text "~" >|< pp_parens _patIsem_lhs {-# LINE 4769 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule591 #-} rule591 = \ ((_patIattrTypes) :: PP_Doc) -> _patIattrTypes {-# INLINE rule592 #-} rule592 = \ ((_patIattrs) :: Set String) -> _patIattrs {-# INLINE rule593 #-} rule593 = \ ((_patIcopy) :: Pattern) -> Irrefutable _patIcopy {-# INLINE rule594 #-} rule594 = \ _copy -> _copy {-# INLINE rule595 #-} rule595 = \ ((_patIisUnderscore) :: Bool) -> _patIisUnderscore {-# INLINE rule596 #-} rule596 = \ ((_lhsIallInhmap) :: Map NontermIdent Attributes) -> _lhsIallInhmap {-# INLINE rule597 #-} rule597 = \ ((_lhsIallSynmap) :: Map NontermIdent Attributes) -> _lhsIallSynmap {-# INLINE rule598 #-} rule598 = \ ((_lhsIanyLazyKind) :: Bool) -> _lhsIanyLazyKind {-# INLINE rule599 #-} rule599 = \ ((_lhsIinhmap) :: Attributes) -> _lhsIinhmap {-# INLINE rule600 #-} rule600 = \ ((_lhsIlocalAttrTypes) :: Map Identifier Type) -> _lhsIlocalAttrTypes {-# INLINE rule601 #-} rule601 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule602 #-} rule602 = \ ((_lhsIsynmap) :: Attributes) -> _lhsIsynmap {-# NOINLINE sem_Pattern_Underscore #-} sem_Pattern_Underscore :: (Pos) -> T_Pattern sem_Pattern_Underscore arg_pos_ = T_Pattern (return st41) where {-# NOINLINE st41 #-} st41 = let v40 :: T_Pattern_v40 v40 = \ (T_Pattern_vIn40 _lhsIallInhmap _lhsIallSynmap _lhsIanyLazyKind _lhsIinhmap _lhsIlocalAttrTypes _lhsIoptions _lhsIsynmap) -> ( let _lhsOsem_lhs :: PP_Doc _lhsOsem_lhs = rule603 () _lhsOisUnderscore :: Bool _lhsOisUnderscore = rule604 () _lhsOattrTypes :: PP_Doc _lhsOattrTypes = rule605 () _lhsOattrs :: Set String _lhsOattrs = rule606 () _copy = rule607 arg_pos_ _lhsOcopy :: Pattern _lhsOcopy = rule608 _copy __result_ = T_Pattern_vOut40 _lhsOattrTypes _lhsOattrs _lhsOcopy _lhsOisUnderscore _lhsOsem_lhs in __result_ ) in C_Pattern_s41 v40 {-# INLINE rule603 #-} {-# LINE 1127 "./src-ag/ExecutionPlan2Hs.ag" #-} rule603 = \ (_ :: ()) -> {-# LINE 1127 "./src-ag/ExecutionPlan2Hs.ag" #-} text "_" {-# LINE 4832 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule604 #-} {-# LINE 1136 "./src-ag/ExecutionPlan2Hs.ag" #-} rule604 = \ (_ :: ()) -> {-# LINE 1136 "./src-ag/ExecutionPlan2Hs.ag" #-} True {-# LINE 4838 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule605 #-} rule605 = \ (_ :: ()) -> empty {-# INLINE rule606 #-} rule606 = \ (_ :: ()) -> Set.empty {-# INLINE rule607 #-} rule607 = \ pos_ -> Underscore pos_ {-# INLINE rule608 #-} rule608 = \ _copy -> _copy -- Patterns ---------------------------------------------------- -- wrapper data Inh_Patterns = Inh_Patterns { allInhmap_Inh_Patterns :: (Map NontermIdent Attributes), allSynmap_Inh_Patterns :: (Map NontermIdent Attributes), anyLazyKind_Inh_Patterns :: (Bool), inhmap_Inh_Patterns :: (Attributes), localAttrTypes_Inh_Patterns :: (Map Identifier Type), options_Inh_Patterns :: (Options), synmap_Inh_Patterns :: (Attributes) } data Syn_Patterns = Syn_Patterns { attrTypes_Syn_Patterns :: (PP_Doc), attrs_Syn_Patterns :: (Set String), copy_Syn_Patterns :: (Patterns), sem_lhs_Syn_Patterns :: ([PP_Doc]) } {-# INLINABLE wrap_Patterns #-} wrap_Patterns :: T_Patterns -> Inh_Patterns -> (Syn_Patterns ) wrap_Patterns (T_Patterns act) (Inh_Patterns _lhsIallInhmap _lhsIallSynmap _lhsIanyLazyKind _lhsIinhmap _lhsIlocalAttrTypes _lhsIoptions _lhsIsynmap) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Patterns_vIn43 _lhsIallInhmap _lhsIallSynmap _lhsIanyLazyKind _lhsIinhmap _lhsIlocalAttrTypes _lhsIoptions _lhsIsynmap (T_Patterns_vOut43 _lhsOattrTypes _lhsOattrs _lhsOcopy _lhsOsem_lhs) <- return (inv_Patterns_s44 sem arg) return (Syn_Patterns _lhsOattrTypes _lhsOattrs _lhsOcopy _lhsOsem_lhs) ) -- cata {-# NOINLINE sem_Patterns #-} sem_Patterns :: Patterns -> T_Patterns sem_Patterns list = Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list) -- semantic domain newtype T_Patterns = T_Patterns { attach_T_Patterns :: Identity (T_Patterns_s44 ) } newtype T_Patterns_s44 = C_Patterns_s44 { inv_Patterns_s44 :: (T_Patterns_v43 ) } data T_Patterns_s45 = C_Patterns_s45 type T_Patterns_v43 = (T_Patterns_vIn43 ) -> (T_Patterns_vOut43 ) data T_Patterns_vIn43 = T_Patterns_vIn43 (Map NontermIdent Attributes) (Map NontermIdent Attributes) (Bool) (Attributes) (Map Identifier Type) (Options) (Attributes) data T_Patterns_vOut43 = T_Patterns_vOut43 (PP_Doc) (Set String) (Patterns) ([PP_Doc]) {-# NOINLINE sem_Patterns_Cons #-} sem_Patterns_Cons :: T_Pattern -> T_Patterns -> T_Patterns sem_Patterns_Cons arg_hd_ arg_tl_ = T_Patterns (return st44) where {-# NOINLINE st44 #-} st44 = let v43 :: T_Patterns_v43 v43 = \ (T_Patterns_vIn43 _lhsIallInhmap _lhsIallSynmap _lhsIanyLazyKind _lhsIinhmap _lhsIlocalAttrTypes _lhsIoptions _lhsIsynmap) -> ( let _hdX41 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_hd_)) _tlX44 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_tl_)) (T_Pattern_vOut40 _hdIattrTypes _hdIattrs _hdIcopy _hdIisUnderscore _hdIsem_lhs) = inv_Pattern_s41 _hdX41 (T_Pattern_vIn40 _hdOallInhmap _hdOallSynmap _hdOanyLazyKind _hdOinhmap _hdOlocalAttrTypes _hdOoptions _hdOsynmap) (T_Patterns_vOut43 _tlIattrTypes _tlIattrs _tlIcopy _tlIsem_lhs) = inv_Patterns_s44 _tlX44 (T_Patterns_vIn43 _tlOallInhmap _tlOallSynmap _tlOanyLazyKind _tlOinhmap _tlOlocalAttrTypes _tlOoptions _tlOsynmap) _lhsOattrTypes :: PP_Doc _lhsOattrTypes = rule609 _hdIattrTypes _tlIattrTypes _lhsOattrs :: Set String _lhsOattrs = rule610 _hdIattrs _tlIattrs _lhsOsem_lhs :: [PP_Doc] _lhsOsem_lhs = rule611 _hdIsem_lhs _tlIsem_lhs _copy = rule612 _hdIcopy _tlIcopy _lhsOcopy :: Patterns _lhsOcopy = rule613 _copy _hdOallInhmap = rule614 _lhsIallInhmap _hdOallSynmap = rule615 _lhsIallSynmap _hdOanyLazyKind = rule616 _lhsIanyLazyKind _hdOinhmap = rule617 _lhsIinhmap _hdOlocalAttrTypes = rule618 _lhsIlocalAttrTypes _hdOoptions = rule619 _lhsIoptions _hdOsynmap = rule620 _lhsIsynmap _tlOallInhmap = rule621 _lhsIallInhmap _tlOallSynmap = rule622 _lhsIallSynmap _tlOanyLazyKind = rule623 _lhsIanyLazyKind _tlOinhmap = rule624 _lhsIinhmap _tlOlocalAttrTypes = rule625 _lhsIlocalAttrTypes _tlOoptions = rule626 _lhsIoptions _tlOsynmap = rule627 _lhsIsynmap __result_ = T_Patterns_vOut43 _lhsOattrTypes _lhsOattrs _lhsOcopy _lhsOsem_lhs in __result_ ) in C_Patterns_s44 v43 {-# INLINE rule609 #-} rule609 = \ ((_hdIattrTypes) :: PP_Doc) ((_tlIattrTypes) :: PP_Doc) -> _hdIattrTypes >-< _tlIattrTypes {-# INLINE rule610 #-} rule610 = \ ((_hdIattrs) :: Set String) ((_tlIattrs) :: Set String) -> _hdIattrs `Set.union` _tlIattrs {-# INLINE rule611 #-} rule611 = \ ((_hdIsem_lhs) :: PP_Doc ) ((_tlIsem_lhs) :: [PP_Doc]) -> _hdIsem_lhs : _tlIsem_lhs {-# INLINE rule612 #-} rule612 = \ ((_hdIcopy) :: Pattern) ((_tlIcopy) :: Patterns) -> (:) _hdIcopy _tlIcopy {-# INLINE rule613 #-} rule613 = \ _copy -> _copy {-# INLINE rule614 #-} rule614 = \ ((_lhsIallInhmap) :: Map NontermIdent Attributes) -> _lhsIallInhmap {-# INLINE rule615 #-} rule615 = \ ((_lhsIallSynmap) :: Map NontermIdent Attributes) -> _lhsIallSynmap {-# INLINE rule616 #-} rule616 = \ ((_lhsIanyLazyKind) :: Bool) -> _lhsIanyLazyKind {-# INLINE rule617 #-} rule617 = \ ((_lhsIinhmap) :: Attributes) -> _lhsIinhmap {-# INLINE rule618 #-} rule618 = \ ((_lhsIlocalAttrTypes) :: Map Identifier Type) -> _lhsIlocalAttrTypes {-# INLINE rule619 #-} rule619 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule620 #-} rule620 = \ ((_lhsIsynmap) :: Attributes) -> _lhsIsynmap {-# INLINE rule621 #-} rule621 = \ ((_lhsIallInhmap) :: Map NontermIdent Attributes) -> _lhsIallInhmap {-# INLINE rule622 #-} rule622 = \ ((_lhsIallSynmap) :: Map NontermIdent Attributes) -> _lhsIallSynmap {-# INLINE rule623 #-} rule623 = \ ((_lhsIanyLazyKind) :: Bool) -> _lhsIanyLazyKind {-# INLINE rule624 #-} rule624 = \ ((_lhsIinhmap) :: Attributes) -> _lhsIinhmap {-# INLINE rule625 #-} rule625 = \ ((_lhsIlocalAttrTypes) :: Map Identifier Type) -> _lhsIlocalAttrTypes {-# INLINE rule626 #-} rule626 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule627 #-} rule627 = \ ((_lhsIsynmap) :: Attributes) -> _lhsIsynmap {-# NOINLINE sem_Patterns_Nil #-} sem_Patterns_Nil :: T_Patterns sem_Patterns_Nil = T_Patterns (return st44) where {-# NOINLINE st44 #-} st44 = let v43 :: T_Patterns_v43 v43 = \ (T_Patterns_vIn43 _lhsIallInhmap _lhsIallSynmap _lhsIanyLazyKind _lhsIinhmap _lhsIlocalAttrTypes _lhsIoptions _lhsIsynmap) -> ( let _lhsOattrTypes :: PP_Doc _lhsOattrTypes = rule628 () _lhsOattrs :: Set String _lhsOattrs = rule629 () _lhsOsem_lhs :: [PP_Doc] _lhsOsem_lhs = rule630 () _copy = rule631 () _lhsOcopy :: Patterns _lhsOcopy = rule632 _copy __result_ = T_Patterns_vOut43 _lhsOattrTypes _lhsOattrs _lhsOcopy _lhsOsem_lhs in __result_ ) in C_Patterns_s44 v43 {-# INLINE rule628 #-} rule628 = \ (_ :: ()) -> empty {-# INLINE rule629 #-} rule629 = \ (_ :: ()) -> Set.empty {-# INLINE rule630 #-} rule630 = \ (_ :: ()) -> [] {-# INLINE rule631 #-} rule631 = \ (_ :: ()) -> [] {-# INLINE rule632 #-} rule632 = \ _copy -> _copy -- Visit ------------------------------------------------------- -- wrapper data Inh_Visit = Inh_Visit { allFromToStates_Inh_Visit :: (Map VisitIdentifier (Int,Int)), allInhmap_Inh_Visit :: (Map NontermIdent Attributes), allInitStates_Inh_Visit :: (Map NontermIdent Int), allSynmap_Inh_Visit :: (Map NontermIdent Attributes), allVisitKinds_Inh_Visit :: (Map VisitIdentifier VisitKind), allchildvisit_Inh_Visit :: (Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))), allintramap_Inh_Visit :: (Map StateIdentifier (Map String (Maybe NonLocalAttr))), avisitdefs_Inh_Visit :: (Map VisitIdentifier (Set Identifier)), avisituses_Inh_Visit :: (Map VisitIdentifier (Set Identifier)), childTypes_Inh_Visit :: (Map Identifier Type), childintros_Inh_Visit :: (Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))), con_Inh_Visit :: (ConstructorIdent), inhmap_Inh_Visit :: (Attributes), mrules_Inh_Visit :: (Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)), nextVisits_Inh_Visit :: (Map StateIdentifier StateCtx), nt_Inh_Visit :: (NontermIdent), options_Inh_Visit :: (Options), params_Inh_Visit :: ([Identifier]), prevVisits_Inh_Visit :: (Map StateIdentifier StateCtx), ruledefs_Inh_Visit :: (Map Identifier (Set String)), ruleuses_Inh_Visit :: (Map Identifier (Map String (Maybe NonLocalAttr))), synmap_Inh_Visit :: (Attributes), terminaldefs_Inh_Visit :: (Set String) } data Syn_Visit = Syn_Visit { allvisits_Syn_Visit :: ( VisitStateState ), childvisit_Syn_Visit :: (Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))), errors_Syn_Visit :: (Seq Error), fromToStates_Syn_Visit :: (Map VisitIdentifier (Int,Int)), intramap_Syn_Visit :: (Map StateIdentifier (Map String (Maybe NonLocalAttr))), lazyIntras_Syn_Visit :: (Set String), ruleKinds_Syn_Visit :: (Map Identifier (Set VisitKind)), ruleUsage_Syn_Visit :: (Map Identifier Int), sem_visit_Syn_Visit :: ( (StateIdentifier,Bool -> PP_Doc) ), t_visits_Syn_Visit :: (PP_Doc), usedArgs_Syn_Visit :: (Set String), visitKinds_Syn_Visit :: (Map VisitIdentifier VisitKind), visitdefs_Syn_Visit :: (Map VisitIdentifier (Set Identifier)), visituses_Syn_Visit :: (Map VisitIdentifier (Set Identifier)) } {-# INLINABLE wrap_Visit #-} wrap_Visit :: T_Visit -> Inh_Visit -> (Syn_Visit ) wrap_Visit (T_Visit act) (Inh_Visit _lhsIallFromToStates _lhsIallInhmap _lhsIallInitStates _lhsIallSynmap _lhsIallVisitKinds _lhsIallchildvisit _lhsIallintramap _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIcon _lhsIinhmap _lhsImrules _lhsInextVisits _lhsInt _lhsIoptions _lhsIparams _lhsIprevVisits _lhsIruledefs _lhsIruleuses _lhsIsynmap _lhsIterminaldefs) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Visit_vIn46 _lhsIallFromToStates _lhsIallInhmap _lhsIallInitStates _lhsIallSynmap _lhsIallVisitKinds _lhsIallchildvisit _lhsIallintramap _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIcon _lhsIinhmap _lhsImrules _lhsInextVisits _lhsInt _lhsIoptions _lhsIparams _lhsIprevVisits _lhsIruledefs _lhsIruleuses _lhsIsynmap _lhsIterminaldefs (T_Visit_vOut46 _lhsOallvisits _lhsOchildvisit _lhsOerrors _lhsOfromToStates _lhsOintramap _lhsOlazyIntras _lhsOruleKinds _lhsOruleUsage _lhsOsem_visit _lhsOt_visits _lhsOusedArgs _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses) <- return (inv_Visit_s47 sem arg) return (Syn_Visit _lhsOallvisits _lhsOchildvisit _lhsOerrors _lhsOfromToStates _lhsOintramap _lhsOlazyIntras _lhsOruleKinds _lhsOruleUsage _lhsOsem_visit _lhsOt_visits _lhsOusedArgs _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses) ) -- cata {-# INLINE sem_Visit #-} sem_Visit :: Visit -> T_Visit sem_Visit ( Visit ident_ from_ to_ inh_ syn_ steps_ kind_ ) = sem_Visit_Visit ident_ from_ to_ inh_ syn_ ( sem_VisitSteps steps_ ) kind_ -- semantic domain newtype T_Visit = T_Visit { attach_T_Visit :: Identity (T_Visit_s47 ) } newtype T_Visit_s47 = C_Visit_s47 { inv_Visit_s47 :: (T_Visit_v46 ) } data T_Visit_s48 = C_Visit_s48 type T_Visit_v46 = (T_Visit_vIn46 ) -> (T_Visit_vOut46 ) data T_Visit_vIn46 = T_Visit_vIn46 (Map VisitIdentifier (Int,Int)) (Map NontermIdent Attributes) (Map NontermIdent Int) (Map NontermIdent Attributes) (Map VisitIdentifier VisitKind) (Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) (Map StateIdentifier (Map String (Maybe NonLocalAttr))) (Map VisitIdentifier (Set Identifier)) (Map VisitIdentifier (Set Identifier)) (Map Identifier Type) (Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))) (ConstructorIdent) (Attributes) (Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)) (Map StateIdentifier StateCtx) (NontermIdent) (Options) ([Identifier]) (Map StateIdentifier StateCtx) (Map Identifier (Set String)) (Map Identifier (Map String (Maybe NonLocalAttr))) (Attributes) (Set String) data T_Visit_vOut46 = T_Visit_vOut46 ( VisitStateState ) (Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) (Seq Error) (Map VisitIdentifier (Int,Int)) (Map StateIdentifier (Map String (Maybe NonLocalAttr))) (Set String) (Map Identifier (Set VisitKind)) (Map Identifier Int) ( (StateIdentifier,Bool -> PP_Doc) ) (PP_Doc) (Set String) (Map VisitIdentifier VisitKind) (Map VisitIdentifier (Set Identifier)) (Map VisitIdentifier (Set Identifier)) {-# NOINLINE sem_Visit_Visit #-} sem_Visit_Visit :: (VisitIdentifier) -> (StateIdentifier) -> (StateIdentifier) -> (Set Identifier) -> (Set Identifier) -> T_VisitSteps -> (VisitKind) -> T_Visit sem_Visit_Visit arg_ident_ arg_from_ arg_to_ arg_inh_ arg_syn_ arg_steps_ arg_kind_ = T_Visit (return st47) where {-# NOINLINE st47 #-} st47 = let v46 :: T_Visit_v46 v46 = \ (T_Visit_vIn46 _lhsIallFromToStates _lhsIallInhmap _lhsIallInitStates _lhsIallSynmap _lhsIallVisitKinds _lhsIallchildvisit _lhsIallintramap _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIcon _lhsIinhmap _lhsImrules _lhsInextVisits _lhsInt _lhsIoptions _lhsIparams _lhsIprevVisits _lhsIruledefs _lhsIruleuses _lhsIsynmap _lhsIterminaldefs) -> ( let _stepsX53 = Control.Monad.Identity.runIdentity (attach_T_VisitSteps (arg_steps_)) (T_VisitSteps_vOut52 _stepsIdefs _stepsIerrors _stepsIindex _stepsIisLast _stepsIlazyIntras _stepsIprevMaxSimRefs _stepsIruleKinds _stepsIruleUsage _stepsIsem_steps _stepsIsize _stepsIsync_steps _stepsIusedArgs _stepsIuses _stepsIvisitKinds) = inv_VisitSteps_s53 _stepsX53 (T_VisitSteps_vIn52 _stepsOallFromToStates _stepsOallInitStates _stepsOallVisitKinds _stepsOallchildvisit _stepsOavisitdefs _stepsOavisituses _stepsOchildTypes _stepsOchildintros _stepsOfmtMode _stepsOindex _stepsOkind _stepsOmrules _stepsOoptions _stepsOprevMaxSimRefs _stepsOruledefs _stepsOruleuses _stepsOuseParallel) _lhsOallvisits :: VisitStateState _lhsOallvisits = rule633 arg_from_ arg_ident_ arg_to_ _nameT_visit = rule634 _lhsInt arg_ident_ _nameTIn_visit = rule635 _lhsInt arg_ident_ _nameTOut_visit = rule636 _lhsInt arg_ident_ _nameTNext_visit = rule637 _lhsInt arg_to_ _nextVisitInfo = rule638 _lhsInextVisits arg_to_ _typecon = rule639 _lhsIoptions arg_kind_ _t_params = rule640 _lhsIparams _lhsOt_visits :: PP_Doc _lhsOt_visits = rule641 _addbang1 _inhpart _lhsIoptions _nameTIn_visit _nameTNext_visit _nameTOut_visit _nameT_visit _nextVisitInfo _synpart _t_params _typecon _inhpart = rule642 _lhsIinhmap _ppTypeList arg_inh_ _synpart = rule643 _lhsIsynmap _ppTypeList arg_syn_ _ppTypeList = rule644 _addbang1 _lhsOsem_visit :: (StateIdentifier,Bool -> PP_Doc) _lhsOsem_visit = rule645 _addbang _inhpats _lhsIcon _lhsInt _lhsIoptions _nameTIn_visit _nameT_visit _stepsClosing _stepsInitial _stepsIsem_steps _t_params _vname arg_from_ arg_ident_ _stepsInitial = rule646 arg_kind_ _stepsClosing = rule647 _addbang _nextStBuild _resultval arg_kind_ _vname = rule648 arg_ident_ _inhpats = rule649 arg_inh_ _inhargs = rule650 arg_inh_ _synargs = rule651 arg_syn_ _nextargsMp = rule652 _lhsIallintramap arg_to_ _nextargs = rule653 _nextargsMp _nextst = rule654 _lhsIoptions _nextargs _nextargsMp arg_to_ _resultval = rule655 _nameTOut_visit _nextStRef _synargs (_nextStBuild,_nextStRef) = rule656 _addbang _nextVisitInfo _nextst _stepsOkind = rule657 arg_kind_ _stepsOfmtMode = rule658 arg_kind_ _stepsOindex = rule659 () _stepsOprevMaxSimRefs = rule660 () _stepsOuseParallel = rule661 () _prevVisitInfo = rule662 _lhsInextVisits arg_from_ _lhsOchildvisit :: Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc)) _lhsOchildvisit = rule663 _invokecode arg_ident_ _invokecode = rule664 _addbang _inhargs _lhsInt _lhsIoptions _nameTIn_visit _nameTOut_visit _nextVisitInfo _prevVisitInfo arg_from_ arg_ident_ arg_kind_ arg_syn_ arg_to_ _thisintra = rule665 _defsAsMap _nextintra _uses _lhsOintramap :: Map StateIdentifier (Map String (Maybe NonLocalAttr)) _lhsOintramap = rule666 _thisintra arg_from_ _nextintra = rule667 _lhsIallintramap arg_to_ _uses = rule668 _stepsIuses arg_syn_ _inhVarNms = rule669 arg_inh_ _defs = rule670 _inhVarNms _lhsIterminaldefs _stepsIdefs _defsAsMap = rule671 _defs _lhsOvisitdefs :: Map VisitIdentifier (Set Identifier) _lhsOvisitdefs = rule672 arg_ident_ arg_syn_ _lhsOvisituses :: Map VisitIdentifier (Set Identifier) _lhsOvisituses = rule673 arg_ident_ arg_inh_ _lazyIntrasInh = rule674 _inhVarNms _stepsIdefs arg_kind_ _lhsOlazyIntras :: Set String _lhsOlazyIntras = rule675 _lazyIntrasInh _stepsIlazyIntras _addbang = rule676 _lhsIoptions _addbang1 = rule677 _addbang arg_kind_ _lhsOfromToStates :: Map VisitIdentifier (Int,Int) _lhsOfromToStates = rule678 arg_from_ arg_ident_ arg_to_ _lhsOvisitKinds :: Map VisitIdentifier VisitKind _lhsOvisitKinds = rule679 arg_ident_ arg_kind_ _lhsOerrors :: Seq Error _lhsOerrors = rule680 _stepsIerrors _lhsOruleKinds :: Map Identifier (Set VisitKind) _lhsOruleKinds = rule681 _stepsIruleKinds _lhsOruleUsage :: Map Identifier Int _lhsOruleUsage = rule682 _stepsIruleUsage _lhsOusedArgs :: Set String _lhsOusedArgs = rule683 _stepsIusedArgs _stepsOallFromToStates = rule684 _lhsIallFromToStates _stepsOallInitStates = rule685 _lhsIallInitStates _stepsOallVisitKinds = rule686 _lhsIallVisitKinds _stepsOallchildvisit = rule687 _lhsIallchildvisit _stepsOavisitdefs = rule688 _lhsIavisitdefs _stepsOavisituses = rule689 _lhsIavisituses _stepsOchildTypes = rule690 _lhsIchildTypes _stepsOchildintros = rule691 _lhsIchildintros _stepsOmrules = rule692 _lhsImrules _stepsOoptions = rule693 _lhsIoptions _stepsOruledefs = rule694 _lhsIruledefs _stepsOruleuses = rule695 _lhsIruleuses __result_ = T_Visit_vOut46 _lhsOallvisits _lhsOchildvisit _lhsOerrors _lhsOfromToStates _lhsOintramap _lhsOlazyIntras _lhsOruleKinds _lhsOruleUsage _lhsOsem_visit _lhsOt_visits _lhsOusedArgs _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses in __result_ ) in C_Visit_s47 v46 {-# INLINE rule633 #-} {-# LINE 338 "./src-ag/ExecutionPlan2Hs.ag" #-} rule633 = \ from_ ident_ to_ -> {-# LINE 338 "./src-ag/ExecutionPlan2Hs.ag" #-} (ident_, from_, to_) {-# LINE 5135 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule634 #-} {-# LINE 397 "./src-ag/ExecutionPlan2Hs.ag" #-} rule634 = \ ((_lhsInt) :: NontermIdent) ident_ -> {-# LINE 397 "./src-ag/ExecutionPlan2Hs.ag" #-} conNmTVisit _lhsInt ident_ {-# LINE 5141 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule635 #-} {-# LINE 398 "./src-ag/ExecutionPlan2Hs.ag" #-} rule635 = \ ((_lhsInt) :: NontermIdent) ident_ -> {-# LINE 398 "./src-ag/ExecutionPlan2Hs.ag" #-} conNmTVisitIn _lhsInt ident_ {-# LINE 5147 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule636 #-} {-# LINE 399 "./src-ag/ExecutionPlan2Hs.ag" #-} rule636 = \ ((_lhsInt) :: NontermIdent) ident_ -> {-# LINE 399 "./src-ag/ExecutionPlan2Hs.ag" #-} conNmTVisitOut _lhsInt ident_ {-# LINE 5153 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule637 #-} {-# LINE 400 "./src-ag/ExecutionPlan2Hs.ag" #-} rule637 = \ ((_lhsInt) :: NontermIdent) to_ -> {-# LINE 400 "./src-ag/ExecutionPlan2Hs.ag" #-} conNmTNextVisit _lhsInt to_ {-# LINE 5159 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule638 #-} {-# LINE 402 "./src-ag/ExecutionPlan2Hs.ag" #-} rule638 = \ ((_lhsInextVisits) :: Map StateIdentifier StateCtx) to_ -> {-# LINE 402 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.findWithDefault ManyVis to_ _lhsInextVisits {-# LINE 5165 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule639 #-} {-# LINE 403 "./src-ag/ExecutionPlan2Hs.ag" #-} rule639 = \ ((_lhsIoptions) :: Options) kind_ -> {-# LINE 403 "./src-ag/ExecutionPlan2Hs.ag" #-} case kind_ of VisitPure _ -> empty VisitMonadic -> ppMonadType _lhsIoptions {-# LINE 5173 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule640 #-} {-# LINE 407 "./src-ag/ExecutionPlan2Hs.ag" #-} rule640 = \ ((_lhsIparams) :: [Identifier]) -> {-# LINE 407 "./src-ag/ExecutionPlan2Hs.ag" #-} ppSpaced _lhsIparams {-# LINE 5179 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule641 #-} {-# LINE 408 "./src-ag/ExecutionPlan2Hs.ag" #-} rule641 = \ _addbang1 _inhpart ((_lhsIoptions) :: Options) _nameTIn_visit _nameTNext_visit _nameTOut_visit _nameT_visit _nextVisitInfo _synpart _t_params _typecon -> {-# LINE 408 "./src-ag/ExecutionPlan2Hs.ag" #-} "type" >#< _nameT_visit >#< _t_params >#< "=" >#< pp_parens (_nameTIn_visit >#< _t_params ) >#< ( if dummyTokenVisit _lhsIoptions then "->" >#< dummyType _lhsIoptions True else empty ) >#< "->" >#< _typecon >#< pp_parens (_nameTOut_visit >#< _t_params ) >-< "data" >#< _nameTIn_visit >#< _t_params >#< "=" >#< _nameTIn_visit >#< _inhpart >-< "data" >#< _nameTOut_visit >#< _t_params >#< "=" >#< _nameTOut_visit >#< _synpart >#< case _nextVisitInfo of NoneVis -> empty _ -> _addbang1 $ pp_parens (_nameTNext_visit >#< _t_params ) {-# LINE 5197 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule642 #-} {-# LINE 421 "./src-ag/ExecutionPlan2Hs.ag" #-} rule642 = \ ((_lhsIinhmap) :: Attributes) _ppTypeList inh_ -> {-# LINE 421 "./src-ag/ExecutionPlan2Hs.ag" #-} _ppTypeList inh_ _lhsIinhmap {-# LINE 5203 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule643 #-} {-# LINE 422 "./src-ag/ExecutionPlan2Hs.ag" #-} rule643 = \ ((_lhsIsynmap) :: Attributes) _ppTypeList syn_ -> {-# LINE 422 "./src-ag/ExecutionPlan2Hs.ag" #-} _ppTypeList syn_ _lhsIsynmap {-# LINE 5209 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule644 #-} {-# LINE 423 "./src-ag/ExecutionPlan2Hs.ag" #-} rule644 = \ _addbang1 -> {-# LINE 423 "./src-ag/ExecutionPlan2Hs.ag" #-} \s m -> ppSpaced $ map (\i -> _addbang1 $ pp_parens $ case Map.lookup i m of Just tp -> ppTp tp ) $ Set.toList s {-# LINE 5216 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule645 #-} {-# LINE 715 "./src-ag/ExecutionPlan2Hs.ag" #-} rule645 = \ _addbang _inhpats ((_lhsIcon) :: ConstructorIdent) ((_lhsInt) :: NontermIdent) ((_lhsIoptions) :: Options) _nameTIn_visit _nameT_visit _stepsClosing _stepsInitial ((_stepsIsem_steps) :: PP_Doc) _t_params _vname from_ ident_ -> {-# LINE 715 "./src-ag/ExecutionPlan2Hs.ag" #-} ( from_ , \addInlinePragma -> ( if noInlinePragmas _lhsIoptions then empty else if addInlinePragma && aggressiveInlinePragmas _lhsIoptions then ppInline _vname else if helpInlining _lhsIoptions then ppNoInline _vname else empty ) >-< "v" >|< ident_ >#< "::" >#< _nameT_visit >#< _t_params >-< "v" >|< ident_ >#< "=" >#< "\\" >#< (_addbang $ pp_parens (_nameTIn_visit >#< _inhpats )) >#< ( if dummyTokenVisit _lhsIoptions then pp $ dummyPat _lhsIoptions True else empty ) >#< "->" >#< ( if genCostCentres _lhsIoptions then ppCostCentre (_vname >|< "_" >|< _lhsInt >|< "_" >|< _lhsIcon) else empty ) >#< "(" >#< _stepsInitial >-< indent 3 (_stepsIsem_steps >-< _stepsClosing >#< ")") ) {-# LINE 5244 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule646 #-} {-# LINE 740 "./src-ag/ExecutionPlan2Hs.ag" #-} rule646 = \ kind_ -> {-# LINE 740 "./src-ag/ExecutionPlan2Hs.ag" #-} case kind_ of VisitPure False -> text "let" VisitPure True -> empty VisitMonadic -> text "do" {-# LINE 5253 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule647 #-} {-# LINE 744 "./src-ag/ExecutionPlan2Hs.ag" #-} rule647 = \ _addbang _nextStBuild _resultval kind_ -> {-# LINE 744 "./src-ag/ExecutionPlan2Hs.ag" #-} let decls = _nextStBuild >-< _addbang (pp resultValName) >#< "=" >#< _resultval in case kind_ of VisitPure False -> decls >-< "in" >#< resultValName VisitPure True -> "let" >#< decls >-< indent 1 ("in" >#< resultValName) VisitMonadic -> "let" >#< decls >-< "return" >#< resultValName {-# LINE 5267 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule648 #-} {-# LINE 753 "./src-ag/ExecutionPlan2Hs.ag" #-} rule648 = \ ident_ -> {-# LINE 753 "./src-ag/ExecutionPlan2Hs.ag" #-} "v" >|< ident_ {-# LINE 5273 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule649 #-} {-# LINE 754 "./src-ag/ExecutionPlan2Hs.ag" #-} rule649 = \ inh_ -> {-# LINE 754 "./src-ag/ExecutionPlan2Hs.ag" #-} ppSpaced $ map (\arg -> pp $ attrname True _LHS arg) $ Set.toList inh_ {-# LINE 5279 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule650 #-} {-# LINE 755 "./src-ag/ExecutionPlan2Hs.ag" #-} rule650 = \ inh_ -> {-# LINE 755 "./src-ag/ExecutionPlan2Hs.ag" #-} \chn -> ppSpaced $ map (attrname False chn) $ Set.toList inh_ {-# LINE 5285 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule651 #-} {-# LINE 756 "./src-ag/ExecutionPlan2Hs.ag" #-} rule651 = \ syn_ -> {-# LINE 756 "./src-ag/ExecutionPlan2Hs.ag" #-} ppSpaced $ map (\arg -> attrname False _LHS arg) $ Set.toList syn_ {-# LINE 5291 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule652 #-} {-# LINE 757 "./src-ag/ExecutionPlan2Hs.ag" #-} rule652 = \ ((_lhsIallintramap) :: Map StateIdentifier (Map String (Maybe NonLocalAttr))) to_ -> {-# LINE 757 "./src-ag/ExecutionPlan2Hs.ag" #-} maybe Map.empty id $ Map.lookup to_ _lhsIallintramap {-# LINE 5297 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule653 #-} {-# LINE 758 "./src-ag/ExecutionPlan2Hs.ag" #-} rule653 = \ _nextargsMp -> {-# LINE 758 "./src-ag/ExecutionPlan2Hs.ag" #-} ppSpaced $ Map.keys $ _nextargsMp {-# LINE 5303 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule654 #-} {-# LINE 759 "./src-ag/ExecutionPlan2Hs.ag" #-} rule654 = \ ((_lhsIoptions) :: Options) _nextargs _nextargsMp to_ -> {-# LINE 759 "./src-ag/ExecutionPlan2Hs.ag" #-} "st" >|< to_ >#< _nextargs >#< dummyArg _lhsIoptions (Map.null _nextargsMp ) {-# LINE 5309 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule655 #-} {-# LINE 760 "./src-ag/ExecutionPlan2Hs.ag" #-} rule655 = \ _nameTOut_visit _nextStRef _synargs -> {-# LINE 760 "./src-ag/ExecutionPlan2Hs.ag" #-} _nameTOut_visit >#< _synargs >#< _nextStRef {-# LINE 5315 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule656 #-} {-# LINE 762 "./src-ag/ExecutionPlan2Hs.ag" #-} rule656 = \ _addbang _nextVisitInfo _nextst -> {-# LINE 762 "./src-ag/ExecutionPlan2Hs.ag" #-} case _nextVisitInfo of NoneVis -> (empty, empty) _ -> (_addbang (pp nextStName) >#< "=" >#< _nextst , pp nextStName) {-# LINE 5323 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule657 #-} {-# LINE 776 "./src-ag/ExecutionPlan2Hs.ag" #-} rule657 = \ kind_ -> {-# LINE 776 "./src-ag/ExecutionPlan2Hs.ag" #-} kind_ {-# LINE 5329 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule658 #-} {-# LINE 827 "./src-ag/ExecutionPlan2Hs.ag" #-} rule658 = \ kind_ -> {-# LINE 827 "./src-ag/ExecutionPlan2Hs.ag" #-} case kind_ of VisitPure False -> FormatLetDecl VisitPure True -> FormatLetLine VisitMonadic -> FormatDo {-# LINE 5338 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule659 #-} {-# LINE 876 "./src-ag/ExecutionPlan2Hs.ag" #-} rule659 = \ (_ :: ()) -> {-# LINE 876 "./src-ag/ExecutionPlan2Hs.ag" #-} 0 {-# LINE 5344 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule660 #-} {-# LINE 883 "./src-ag/ExecutionPlan2Hs.ag" #-} rule660 = \ (_ :: ()) -> {-# LINE 883 "./src-ag/ExecutionPlan2Hs.ag" #-} 0 {-# LINE 5350 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule661 #-} {-# LINE 899 "./src-ag/ExecutionPlan2Hs.ag" #-} rule661 = \ (_ :: ()) -> {-# LINE 899 "./src-ag/ExecutionPlan2Hs.ag" #-} False {-# LINE 5356 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule662 #-} {-# LINE 1217 "./src-ag/ExecutionPlan2Hs.ag" #-} rule662 = \ ((_lhsInextVisits) :: Map StateIdentifier StateCtx) from_ -> {-# LINE 1217 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.findWithDefault ManyVis from_ _lhsInextVisits {-# LINE 5362 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule663 #-} {-# LINE 1218 "./src-ag/ExecutionPlan2Hs.ag" #-} rule663 = \ _invokecode ident_ -> {-# LINE 1218 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.singleton ident_ _invokecode {-# LINE 5368 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule664 #-} {-# LINE 1219 "./src-ag/ExecutionPlan2Hs.ag" #-} rule664 = \ _addbang _inhargs ((_lhsInt) :: NontermIdent) ((_lhsIoptions) :: Options) _nameTIn_visit _nameTOut_visit _nextVisitInfo _prevVisitInfo from_ ident_ kind_ syn_ to_ -> {-# LINE 1219 "./src-ag/ExecutionPlan2Hs.ag" #-} \chn kind -> if kind `compatibleKind` kind_ then Right $ let pat | isLazyKind kind_ = pat0 | otherwise = _addbang pat0 pat0 = pp_parens pat1 pat1 = _nameTOut_visit >#< (ppSpaced $ map (attrname True chn) $ Set.toList syn_) >#< cont cont = case _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 _lhsIoptions >#< expr0 (VisitMonadic, VisitPure _) -> "return" >#< expr0 (VisitMonadic, VisitMonadic) -> expr0 expr0 = case _prevVisitInfo of NoneVis -> error "error: invocation of a visit from a state that has no next visits" OneVis _ -> "inv_" >|< _lhsInt >|< "_s" >|< from_ >#< ch0 >#< args ManyVis -> "inv_" >|< _lhsInt >|< "_s" >|< from_ >#< ch0 >#< "K_" >|< _lhsInt >|< "_v" >|< ident_ >#< args args = pp_parens args0 >#< args1 args0 = _nameTIn_visit >#< _inhargs chn args1 | dummyTokenVisit _lhsIoptions = pp $ dummyArg _lhsIoptions True | otherwise = empty in (pat, expr) else Left $ IncompatibleVisitKind chn ident_ kind kind_ {-# LINE 5402 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule665 #-} {-# LINE 1315 "./src-ag/ExecutionPlan2Hs.ag" #-} rule665 = \ _defsAsMap _nextintra _uses -> {-# LINE 1315 "./src-ag/ExecutionPlan2Hs.ag" #-} (_uses `Map.union` _nextintra ) `Map.difference` _defsAsMap {-# LINE 5408 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule666 #-} {-# LINE 1316 "./src-ag/ExecutionPlan2Hs.ag" #-} rule666 = \ _thisintra from_ -> {-# LINE 1316 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.singleton from_ _thisintra {-# LINE 5414 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule667 #-} {-# LINE 1317 "./src-ag/ExecutionPlan2Hs.ag" #-} rule667 = \ ((_lhsIallintramap) :: Map StateIdentifier (Map String (Maybe NonLocalAttr))) to_ -> {-# LINE 1317 "./src-ag/ExecutionPlan2Hs.ag" #-} maybe Map.empty id $ Map.lookup to_ _lhsIallintramap {-# LINE 5420 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule668 #-} {-# LINE 1318 "./src-ag/ExecutionPlan2Hs.ag" #-} rule668 = \ ((_stepsIuses) :: Map String (Maybe NonLocalAttr)) syn_ -> {-# LINE 1318 "./src-ag/ExecutionPlan2Hs.ag" #-} let mp1 = _stepsIuses mp2 = Map.fromList [ (lhsname False i, Just (AttrSyn _LHS i)) | i <- Set.elems syn_ ] in mp1 `Map.union` mp2 {-# LINE 5428 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule669 #-} {-# LINE 1321 "./src-ag/ExecutionPlan2Hs.ag" #-} rule669 = \ inh_ -> {-# LINE 1321 "./src-ag/ExecutionPlan2Hs.ag" #-} Set.map (lhsname True) inh_ {-# LINE 5434 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule670 #-} {-# LINE 1322 "./src-ag/ExecutionPlan2Hs.ag" #-} rule670 = \ _inhVarNms ((_lhsIterminaldefs) :: Set String) ((_stepsIdefs) :: Set String) -> {-# LINE 1322 "./src-ag/ExecutionPlan2Hs.ag" #-} _stepsIdefs `Set.union` _inhVarNms `Set.union` _lhsIterminaldefs {-# LINE 5440 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule671 #-} {-# LINE 1323 "./src-ag/ExecutionPlan2Hs.ag" #-} rule671 = \ _defs -> {-# LINE 1323 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.fromList [ (a, Nothing) | a <- Set.elems _defs ] {-# LINE 5446 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule672 #-} {-# LINE 1347 "./src-ag/ExecutionPlan2Hs.ag" #-} rule672 = \ ident_ syn_ -> {-# LINE 1347 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.singleton ident_ syn_ {-# LINE 5452 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule673 #-} {-# LINE 1348 "./src-ag/ExecutionPlan2Hs.ag" #-} rule673 = \ ident_ inh_ -> {-# LINE 1348 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.singleton ident_ inh_ {-# LINE 5458 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule674 #-} {-# LINE 1380 "./src-ag/ExecutionPlan2Hs.ag" #-} rule674 = \ _inhVarNms ((_stepsIdefs) :: Set String) kind_ -> {-# LINE 1380 "./src-ag/ExecutionPlan2Hs.ag" #-} case kind_ of VisitPure False -> _inhVarNms `Set.union` _stepsIdefs _ -> Set.empty {-# LINE 5466 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule675 #-} {-# LINE 1383 "./src-ag/ExecutionPlan2Hs.ag" #-} rule675 = \ _lazyIntrasInh ((_stepsIlazyIntras) :: Set String) -> {-# LINE 1383 "./src-ag/ExecutionPlan2Hs.ag" #-} _lazyIntrasInh `Set.union` _stepsIlazyIntras {-# LINE 5472 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule676 #-} {-# LINE 1536 "./src-ag/ExecutionPlan2Hs.ag" #-} rule676 = \ ((_lhsIoptions) :: Options) -> {-# LINE 1536 "./src-ag/ExecutionPlan2Hs.ag" #-} \x -> if bangpats _lhsIoptions then "!" >|< x else x {-# LINE 5478 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule677 #-} {-# LINE 1544 "./src-ag/ExecutionPlan2Hs.ag" #-} rule677 = \ _addbang kind_ -> {-# LINE 1544 "./src-ag/ExecutionPlan2Hs.ag" #-} if isLazyKind kind_ then id else _addbang {-# LINE 5484 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule678 #-} {-# LINE 1571 "./src-ag/ExecutionPlan2Hs.ag" #-} rule678 = \ from_ ident_ to_ -> {-# LINE 1571 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.singleton ident_ (from_, to_) {-# LINE 5490 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule679 #-} {-# LINE 1615 "./src-ag/ExecutionPlan2Hs.ag" #-} rule679 = \ ident_ kind_ -> {-# LINE 1615 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.singleton ident_ kind_ {-# LINE 5496 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule680 #-} rule680 = \ ((_stepsIerrors) :: Seq Error) -> _stepsIerrors {-# INLINE rule681 #-} rule681 = \ ((_stepsIruleKinds) :: Map Identifier (Set VisitKind)) -> _stepsIruleKinds {-# INLINE rule682 #-} rule682 = \ ((_stepsIruleUsage) :: Map Identifier Int) -> _stepsIruleUsage {-# INLINE rule683 #-} rule683 = \ ((_stepsIusedArgs) :: Set String) -> _stepsIusedArgs {-# INLINE rule684 #-} rule684 = \ ((_lhsIallFromToStates) :: Map VisitIdentifier (Int,Int)) -> _lhsIallFromToStates {-# INLINE rule685 #-} rule685 = \ ((_lhsIallInitStates) :: Map NontermIdent Int) -> _lhsIallInitStates {-# INLINE rule686 #-} rule686 = \ ((_lhsIallVisitKinds) :: Map VisitIdentifier VisitKind) -> _lhsIallVisitKinds {-# INLINE rule687 #-} rule687 = \ ((_lhsIallchildvisit) :: Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) -> _lhsIallchildvisit {-# INLINE rule688 #-} rule688 = \ ((_lhsIavisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisitdefs {-# INLINE rule689 #-} rule689 = \ ((_lhsIavisituses) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisituses {-# INLINE rule690 #-} rule690 = \ ((_lhsIchildTypes) :: Map Identifier Type) -> _lhsIchildTypes {-# INLINE rule691 #-} rule691 = \ ((_lhsIchildintros) :: Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))) -> _lhsIchildintros {-# INLINE rule692 #-} rule692 = \ ((_lhsImrules) :: Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)) -> _lhsImrules {-# INLINE rule693 #-} rule693 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule694 #-} rule694 = \ ((_lhsIruledefs) :: Map Identifier (Set String)) -> _lhsIruledefs {-# INLINE rule695 #-} rule695 = \ ((_lhsIruleuses) :: Map Identifier (Map String (Maybe NonLocalAttr))) -> _lhsIruleuses -- VisitStep --------------------------------------------------- -- wrapper data Inh_VisitStep = Inh_VisitStep { allFromToStates_Inh_VisitStep :: (Map VisitIdentifier (Int,Int)), allInitStates_Inh_VisitStep :: (Map NontermIdent Int), allVisitKinds_Inh_VisitStep :: (Map VisitIdentifier VisitKind), allchildvisit_Inh_VisitStep :: (Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))), avisitdefs_Inh_VisitStep :: (Map VisitIdentifier (Set Identifier)), avisituses_Inh_VisitStep :: (Map VisitIdentifier (Set Identifier)), childTypes_Inh_VisitStep :: (Map Identifier Type), childintros_Inh_VisitStep :: (Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))), fmtMode_Inh_VisitStep :: (FormatMode), index_Inh_VisitStep :: (Int), isLast_Inh_VisitStep :: (Bool), kind_Inh_VisitStep :: (VisitKind), mrules_Inh_VisitStep :: (Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)), options_Inh_VisitStep :: (Options), prevMaxSimRefs_Inh_VisitStep :: (Int), ruledefs_Inh_VisitStep :: (Map Identifier (Set String)), ruleuses_Inh_VisitStep :: (Map Identifier (Map String (Maybe NonLocalAttr))), useParallel_Inh_VisitStep :: (Bool) } data Syn_VisitStep = Syn_VisitStep { defs_Syn_VisitStep :: (Set String), errors_Syn_VisitStep :: (Seq Error), index_Syn_VisitStep :: (Int), isLast_Syn_VisitStep :: (Bool), lazyIntras_Syn_VisitStep :: (Set String), prevMaxSimRefs_Syn_VisitStep :: (Int), ruleKinds_Syn_VisitStep :: (Map Identifier (Set VisitKind)), ruleUsage_Syn_VisitStep :: (Map Identifier Int), sem_steps_Syn_VisitStep :: (PP_Doc), sync_steps_Syn_VisitStep :: (PP_Doc), usedArgs_Syn_VisitStep :: (Set String), uses_Syn_VisitStep :: (Map String (Maybe NonLocalAttr)), visitKinds_Syn_VisitStep :: (Map VisitIdentifier VisitKind) } {-# INLINABLE wrap_VisitStep #-} wrap_VisitStep :: T_VisitStep -> Inh_VisitStep -> (Syn_VisitStep ) wrap_VisitStep (T_VisitStep act) (Inh_VisitStep _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIfmtMode _lhsIindex _lhsIisLast _lhsIkind _lhsImrules _lhsIoptions _lhsIprevMaxSimRefs _lhsIruledefs _lhsIruleuses _lhsIuseParallel) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_VisitStep_vIn49 _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIfmtMode _lhsIindex _lhsIisLast _lhsIkind _lhsImrules _lhsIoptions _lhsIprevMaxSimRefs _lhsIruledefs _lhsIruleuses _lhsIuseParallel (T_VisitStep_vOut49 _lhsOdefs _lhsOerrors _lhsOindex _lhsOisLast _lhsOlazyIntras _lhsOprevMaxSimRefs _lhsOruleKinds _lhsOruleUsage _lhsOsem_steps _lhsOsync_steps _lhsOusedArgs _lhsOuses _lhsOvisitKinds) <- return (inv_VisitStep_s50 sem arg) return (Syn_VisitStep _lhsOdefs _lhsOerrors _lhsOindex _lhsOisLast _lhsOlazyIntras _lhsOprevMaxSimRefs _lhsOruleKinds _lhsOruleUsage _lhsOsem_steps _lhsOsync_steps _lhsOusedArgs _lhsOuses _lhsOvisitKinds) ) -- cata {-# NOINLINE sem_VisitStep #-} sem_VisitStep :: VisitStep -> T_VisitStep sem_VisitStep ( Sem name_ ) = sem_VisitStep_Sem name_ sem_VisitStep ( ChildVisit child_ nonterm_ visit_ ) = sem_VisitStep_ChildVisit child_ nonterm_ visit_ sem_VisitStep ( PureGroup steps_ ordered_ ) = sem_VisitStep_PureGroup ( sem_VisitSteps steps_ ) ordered_ sem_VisitStep ( Sim steps_ ) = sem_VisitStep_Sim ( sem_VisitSteps steps_ ) sem_VisitStep ( ChildIntro child_ ) = sem_VisitStep_ChildIntro child_ -- semantic domain newtype T_VisitStep = T_VisitStep { attach_T_VisitStep :: Identity (T_VisitStep_s50 ) } newtype T_VisitStep_s50 = C_VisitStep_s50 { inv_VisitStep_s50 :: (T_VisitStep_v49 ) } data T_VisitStep_s51 = C_VisitStep_s51 type T_VisitStep_v49 = (T_VisitStep_vIn49 ) -> (T_VisitStep_vOut49 ) data T_VisitStep_vIn49 = T_VisitStep_vIn49 (Map VisitIdentifier (Int,Int)) (Map NontermIdent Int) (Map VisitIdentifier VisitKind) (Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) (Map VisitIdentifier (Set Identifier)) (Map VisitIdentifier (Set Identifier)) (Map Identifier Type) (Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))) (FormatMode) (Int) (Bool) (VisitKind) (Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)) (Options) (Int) (Map Identifier (Set String)) (Map Identifier (Map String (Maybe NonLocalAttr))) (Bool) data T_VisitStep_vOut49 = T_VisitStep_vOut49 (Set String) (Seq Error) (Int) (Bool) (Set String) (Int) (Map Identifier (Set VisitKind)) (Map Identifier Int) (PP_Doc) (PP_Doc) (Set String) (Map String (Maybe NonLocalAttr)) (Map VisitIdentifier VisitKind) {-# NOINLINE sem_VisitStep_Sem #-} sem_VisitStep_Sem :: (Identifier) -> T_VisitStep sem_VisitStep_Sem arg_name_ = T_VisitStep (return st50) where {-# NOINLINE st50 #-} st50 = let v49 :: T_VisitStep_v49 v49 = \ (T_VisitStep_vIn49 _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIfmtMode _lhsIindex _lhsIisLast _lhsIkind _lhsImrules _lhsIoptions _lhsIprevMaxSimRefs _lhsIruledefs _lhsIruleuses _lhsIuseParallel) -> ( let _ruleItf = rule696 _lhsImrules arg_name_ _lhsOerrors :: Seq Error (_lhsOerrors,_sem_steps) = rule697 _lhsIfmtMode _lhsIkind _ruleItf _lhsOruleUsage :: Map Identifier Int _lhsOruleUsage = rule698 arg_name_ _lhsOruleKinds :: Map Identifier (Set VisitKind) _lhsOruleKinds = rule699 _lhsIkind arg_name_ _lhsOdefs :: Set String _lhsOdefs = rule700 _lhsIruledefs arg_name_ _lhsOuses :: Map String (Maybe NonLocalAttr) _lhsOuses = rule701 _lhsIruleuses arg_name_ _lhsOlazyIntras :: Set String _lhsOlazyIntras = rule702 () _lhsOsem_steps :: PP_Doc _lhsOsem_steps = rule703 _sem_steps _lhsOsync_steps :: PP_Doc _lhsOsync_steps = rule704 () _lhsOusedArgs :: Set String _lhsOusedArgs = rule705 () _lhsOvisitKinds :: Map VisitIdentifier VisitKind _lhsOvisitKinds = rule706 () _lhsOindex :: Int _lhsOindex = rule707 _lhsIindex _lhsOisLast :: Bool _lhsOisLast = rule708 _lhsIisLast _lhsOprevMaxSimRefs :: Int _lhsOprevMaxSimRefs = rule709 _lhsIprevMaxSimRefs __result_ = T_VisitStep_vOut49 _lhsOdefs _lhsOerrors _lhsOindex _lhsOisLast _lhsOlazyIntras _lhsOprevMaxSimRefs _lhsOruleKinds _lhsOruleUsage _lhsOsem_steps _lhsOsync_steps _lhsOusedArgs _lhsOuses _lhsOvisitKinds in __result_ ) in C_VisitStep_s50 v49 {-# INLINE rule696 #-} {-# LINE 785 "./src-ag/ExecutionPlan2Hs.ag" #-} rule696 = \ ((_lhsImrules) :: Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)) name_ -> {-# LINE 785 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.findWithDefault (error $ "Rule " ++ show name_ ++ " not found") name_ _lhsImrules {-# LINE 5622 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule697 #-} {-# LINE 786 "./src-ag/ExecutionPlan2Hs.ag" #-} rule697 = \ ((_lhsIfmtMode) :: FormatMode) ((_lhsIkind) :: VisitKind) _ruleItf -> {-# LINE 786 "./src-ag/ExecutionPlan2Hs.ag" #-} case _ruleItf _lhsIkind _lhsIfmtMode of Left e -> (Seq.singleton e, empty) Right stmt -> (Seq.empty, stmt) {-# LINE 5630 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule698 #-} {-# LINE 1268 "./src-ag/ExecutionPlan2Hs.ag" #-} rule698 = \ name_ -> {-# LINE 1268 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.singleton name_ 1 {-# LINE 5636 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule699 #-} {-# LINE 1278 "./src-ag/ExecutionPlan2Hs.ag" #-} rule699 = \ ((_lhsIkind) :: VisitKind) name_ -> {-# LINE 1278 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.singleton name_ (Set.singleton _lhsIkind) {-# LINE 5642 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule700 #-} {-# LINE 1363 "./src-ag/ExecutionPlan2Hs.ag" #-} rule700 = \ ((_lhsIruledefs) :: Map Identifier (Set String)) name_ -> {-# LINE 1363 "./src-ag/ExecutionPlan2Hs.ag" #-} maybe (error "Rule not found") id $ Map.lookup name_ _lhsIruledefs {-# LINE 5648 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule701 #-} {-# LINE 1364 "./src-ag/ExecutionPlan2Hs.ag" #-} rule701 = \ ((_lhsIruleuses) :: Map Identifier (Map String (Maybe NonLocalAttr))) name_ -> {-# LINE 1364 "./src-ag/ExecutionPlan2Hs.ag" #-} maybe (error "Rule not found") id $ Map.lookup name_ _lhsIruleuses {-# LINE 5654 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule702 #-} rule702 = \ (_ :: ()) -> Set.empty {-# INLINE rule703 #-} rule703 = \ _sem_steps -> _sem_steps {-# INLINE rule704 #-} rule704 = \ (_ :: ()) -> empty {-# INLINE rule705 #-} rule705 = \ (_ :: ()) -> Set.empty {-# INLINE rule706 #-} rule706 = \ (_ :: ()) -> mempty {-# INLINE rule707 #-} rule707 = \ ((_lhsIindex) :: Int) -> _lhsIindex {-# INLINE rule708 #-} rule708 = \ ((_lhsIisLast) :: Bool) -> _lhsIisLast {-# INLINE rule709 #-} rule709 = \ ((_lhsIprevMaxSimRefs) :: Int) -> _lhsIprevMaxSimRefs {-# NOINLINE sem_VisitStep_ChildVisit #-} sem_VisitStep_ChildVisit :: (Identifier) -> (NontermIdent) -> (VisitIdentifier) -> T_VisitStep sem_VisitStep_ChildVisit arg_child_ _ arg_visit_ = T_VisitStep (return st50) where {-# NOINLINE st50 #-} st50 = let v49 :: T_VisitStep_v49 v49 = \ (T_VisitStep_vIn49 _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIfmtMode _lhsIindex _lhsIisLast _lhsIkind _lhsImrules _lhsIoptions _lhsIprevMaxSimRefs _lhsIruledefs _lhsIruleuses _lhsIuseParallel) -> ( let _visitItf = rule710 _lhsIallchildvisit arg_visit_ _lhsOerrors :: Seq Error (_lhsOerrors,_patPP,_exprPP) = rule711 _lhsIkind _visitItf arg_child_ _useParallel = rule712 _lhsIisLast _lhsIuseParallel _lhsOsem_steps :: PP_Doc _lhsOsem_steps = rule713 _addbang _convToMonad _exprPP _lhsIfmtMode _lhsIindex _lhsIkind _patPP _useParallel _convToMonad = rule714 _callKind _callKind = rule715 _lhsIallVisitKinds arg_visit_ _lhsOsync_steps :: PP_Doc _lhsOsync_steps = rule716 _lhsIindex _patPP _useParallel _lhsOdefs :: Set String _lhsOdefs = rule717 _lhsIavisitdefs _to arg_child_ arg_visit_ _lhsOuses :: Map String (Maybe NonLocalAttr) _lhsOuses = rule718 _from _lhsIavisituses arg_child_ arg_visit_ _addbang = rule719 _lhsIoptions (_from,_to) = rule720 _lhsIallFromToStates arg_visit_ _lhsOlazyIntras :: Set String _lhsOlazyIntras = rule721 () _lhsOruleKinds :: Map Identifier (Set VisitKind) _lhsOruleKinds = rule722 () _lhsOruleUsage :: Map Identifier Int _lhsOruleUsage = rule723 () _lhsOusedArgs :: Set String _lhsOusedArgs = rule724 () _lhsOvisitKinds :: Map VisitIdentifier VisitKind _lhsOvisitKinds = rule725 () _lhsOindex :: Int _lhsOindex = rule726 _lhsIindex _lhsOisLast :: Bool _lhsOisLast = rule727 _lhsIisLast _lhsOprevMaxSimRefs :: Int _lhsOprevMaxSimRefs = rule728 _lhsIprevMaxSimRefs __result_ = T_VisitStep_vOut49 _lhsOdefs _lhsOerrors _lhsOindex _lhsOisLast _lhsOlazyIntras _lhsOprevMaxSimRefs _lhsOruleKinds _lhsOruleUsage _lhsOsem_steps _lhsOsync_steps _lhsOusedArgs _lhsOuses _lhsOvisitKinds in __result_ ) in C_VisitStep_s50 v49 {-# INLINE rule710 #-} {-# LINE 794 "./src-ag/ExecutionPlan2Hs.ag" #-} rule710 = \ ((_lhsIallchildvisit) :: Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) visit_ -> {-# LINE 794 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.findWithDefault (error $ "Visit " ++ show visit_ ++ " not found") visit_ _lhsIallchildvisit {-# LINE 5726 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule711 #-} {-# LINE 795 "./src-ag/ExecutionPlan2Hs.ag" #-} rule711 = \ ((_lhsIkind) :: VisitKind) _visitItf child_ -> {-# LINE 795 "./src-ag/ExecutionPlan2Hs.ag" #-} case _visitItf child_ _lhsIkind of Left e -> (Seq.singleton e, empty, empty) Right (pat,expr) -> (Seq.empty, pat, expr) {-# LINE 5734 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule712 #-} {-# LINE 799 "./src-ag/ExecutionPlan2Hs.ag" #-} rule712 = \ ((_lhsIisLast) :: Bool) ((_lhsIuseParallel) :: Bool) -> {-# LINE 799 "./src-ag/ExecutionPlan2Hs.ag" #-} _lhsIuseParallel && not _lhsIisLast {-# LINE 5740 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule713 #-} {-# LINE 800 "./src-ag/ExecutionPlan2Hs.ag" #-} rule713 = \ _addbang _convToMonad _exprPP ((_lhsIfmtMode) :: FormatMode) ((_lhsIindex) :: Int) ((_lhsIkind) :: VisitKind) _patPP _useParallel -> {-# LINE 800 "./src-ag/ExecutionPlan2Hs.ag" #-} if _useParallel then _addbang ("sync_" >|< _lhsIindex) >#< "<- newEmptyMVar" >-< "forkIO" >#< pp_parens (_convToMonad >#< pp_parens _exprPP >#< ">>= \\" >#< _addbang (pp parResultName) >#< " -> putMVar sync_" >|< _lhsIindex >#< parResultName) else let decl = case _lhsIkind of VisitPure _ -> _patPP >#< "=" >#< _exprPP VisitMonadic -> _patPP >#< "<-" >#< _exprPP in fmtDecl False _lhsIfmtMode decl {-# LINE 5752 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule714 #-} {-# LINE 807 "./src-ag/ExecutionPlan2Hs.ag" #-} rule714 = \ _callKind -> {-# LINE 807 "./src-ag/ExecutionPlan2Hs.ag" #-} case _callKind of VisitPure _ -> text "return" VisitMonadic -> empty {-# LINE 5760 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule715 #-} {-# LINE 810 "./src-ag/ExecutionPlan2Hs.ag" #-} rule715 = \ ((_lhsIallVisitKinds) :: Map VisitIdentifier VisitKind) visit_ -> {-# LINE 810 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.findWithDefault (error "visit kind should be in the map") visit_ _lhsIallVisitKinds {-# LINE 5766 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule716 #-} {-# LINE 818 "./src-ag/ExecutionPlan2Hs.ag" #-} rule716 = \ ((_lhsIindex) :: Int) _patPP _useParallel -> {-# LINE 818 "./src-ag/ExecutionPlan2Hs.ag" #-} if _useParallel then _patPP >#< "<-" >#< "takeMVar sync_" >|< _lhsIindex else empty {-# LINE 5774 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule717 #-} {-# LINE 1365 "./src-ag/ExecutionPlan2Hs.ag" #-} rule717 = \ ((_lhsIavisitdefs) :: Map VisitIdentifier (Set Identifier)) _to child_ visit_ -> {-# LINE 1365 "./src-ag/ExecutionPlan2Hs.ag" #-} Set.insert (stname child_ _to) $ maybe (error "Visit not found") (Set.map $ attrname True child_) $ Map.lookup visit_ _lhsIavisitdefs {-# LINE 5780 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule718 #-} {-# LINE 1366 "./src-ag/ExecutionPlan2Hs.ag" #-} rule718 = \ _from ((_lhsIavisituses) :: Map VisitIdentifier (Set Identifier)) child_ visit_ -> {-# LINE 1366 "./src-ag/ExecutionPlan2Hs.ag" #-} let convert attrs = Map.fromList [ (attrname False child_ attr, Just $ mkNonLocalAttr True child_ attr) | attr <- Set.elems attrs ] in Map.insert (stname child_ _from) Nothing $ convert $ maybe (error "Visit not found") id $ Map.lookup visit_ _lhsIavisituses {-# LINE 5788 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule719 #-} {-# LINE 1541 "./src-ag/ExecutionPlan2Hs.ag" #-} rule719 = \ ((_lhsIoptions) :: Options) -> {-# LINE 1541 "./src-ag/ExecutionPlan2Hs.ag" #-} \x -> if bangpats _lhsIoptions then "!" >|< x else x {-# LINE 5794 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule720 #-} {-# LINE 1577 "./src-ag/ExecutionPlan2Hs.ag" #-} rule720 = \ ((_lhsIallFromToStates) :: Map VisitIdentifier (Int,Int)) visit_ -> {-# LINE 1577 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.findWithDefault (error "visit not in allFromToStates") visit_ _lhsIallFromToStates {-# LINE 5800 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule721 #-} rule721 = \ (_ :: ()) -> Set.empty {-# INLINE rule722 #-} rule722 = \ (_ :: ()) -> Map.empty {-# INLINE rule723 #-} rule723 = \ (_ :: ()) -> Map.empty {-# INLINE rule724 #-} rule724 = \ (_ :: ()) -> Set.empty {-# INLINE rule725 #-} rule725 = \ (_ :: ()) -> mempty {-# INLINE rule726 #-} rule726 = \ ((_lhsIindex) :: Int) -> _lhsIindex {-# INLINE rule727 #-} rule727 = \ ((_lhsIisLast) :: Bool) -> _lhsIisLast {-# INLINE rule728 #-} rule728 = \ ((_lhsIprevMaxSimRefs) :: Int) -> _lhsIprevMaxSimRefs {-# NOINLINE sem_VisitStep_PureGroup #-} sem_VisitStep_PureGroup :: T_VisitSteps -> (Bool) -> T_VisitStep sem_VisitStep_PureGroup arg_steps_ arg_ordered_ = T_VisitStep (return st50) where {-# NOINLINE st50 #-} st50 = let v49 :: T_VisitStep_v49 v49 = \ (T_VisitStep_vIn49 _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIfmtMode _lhsIindex _lhsIisLast _lhsIkind _lhsImrules _lhsIoptions _lhsIprevMaxSimRefs _lhsIruledefs _lhsIruleuses _lhsIuseParallel) -> ( let _stepsX53 = Control.Monad.Identity.runIdentity (attach_T_VisitSteps (arg_steps_)) (T_VisitSteps_vOut52 _stepsIdefs _stepsIerrors _stepsIindex _stepsIisLast _stepsIlazyIntras _stepsIprevMaxSimRefs _stepsIruleKinds _stepsIruleUsage _stepsIsem_steps _stepsIsize _stepsIsync_steps _stepsIusedArgs _stepsIuses _stepsIvisitKinds) = inv_VisitSteps_s53 _stepsX53 (T_VisitSteps_vIn52 _stepsOallFromToStates _stepsOallInitStates _stepsOallVisitKinds _stepsOallchildvisit _stepsOavisitdefs _stepsOavisituses _stepsOchildTypes _stepsOchildintros _stepsOfmtMode _stepsOindex _stepsOkind _stepsOmrules _stepsOoptions _stepsOprevMaxSimRefs _stepsOruledefs _stepsOruleuses _stepsOuseParallel) _stepsOkind = rule729 arg_ordered_ _lhsOsem_steps :: PP_Doc _lhsOsem_steps = rule730 _lhsIfmtMode _stepsIsem_steps _stepsOfmtMode = rule731 _lhsIfmtMode _lhsOlazyIntras :: Set String _lhsOlazyIntras = rule732 _stepsIdefs _stepsIlazyIntras arg_ordered_ _lhsOdefs :: Set String _lhsOdefs = rule733 _stepsIdefs _lhsOerrors :: Seq Error _lhsOerrors = rule734 _stepsIerrors _lhsOruleKinds :: Map Identifier (Set VisitKind) _lhsOruleKinds = rule735 _stepsIruleKinds _lhsOruleUsage :: Map Identifier Int _lhsOruleUsage = rule736 _stepsIruleUsage _lhsOsync_steps :: PP_Doc _lhsOsync_steps = rule737 _stepsIsync_steps _lhsOusedArgs :: Set String _lhsOusedArgs = rule738 _stepsIusedArgs _lhsOuses :: Map String (Maybe NonLocalAttr) _lhsOuses = rule739 _stepsIuses _lhsOvisitKinds :: Map VisitIdentifier VisitKind _lhsOvisitKinds = rule740 _stepsIvisitKinds _lhsOindex :: Int _lhsOindex = rule741 _stepsIindex _lhsOisLast :: Bool _lhsOisLast = rule742 _stepsIisLast _lhsOprevMaxSimRefs :: Int _lhsOprevMaxSimRefs = rule743 _stepsIprevMaxSimRefs _stepsOallFromToStates = rule744 _lhsIallFromToStates _stepsOallInitStates = rule745 _lhsIallInitStates _stepsOallVisitKinds = rule746 _lhsIallVisitKinds _stepsOallchildvisit = rule747 _lhsIallchildvisit _stepsOavisitdefs = rule748 _lhsIavisitdefs _stepsOavisituses = rule749 _lhsIavisituses _stepsOchildTypes = rule750 _lhsIchildTypes _stepsOchildintros = rule751 _lhsIchildintros _stepsOindex = rule752 _lhsIindex _stepsOmrules = rule753 _lhsImrules _stepsOoptions = rule754 _lhsIoptions _stepsOprevMaxSimRefs = rule755 _lhsIprevMaxSimRefs _stepsOruledefs = rule756 _lhsIruledefs _stepsOruleuses = rule757 _lhsIruleuses _stepsOuseParallel = rule758 _lhsIuseParallel __result_ = T_VisitStep_vOut49 _lhsOdefs _lhsOerrors _lhsOindex _lhsOisLast _lhsOlazyIntras _lhsOprevMaxSimRefs _lhsOruleKinds _lhsOruleUsage _lhsOsem_steps _lhsOsync_steps _lhsOusedArgs _lhsOuses _lhsOvisitKinds in __result_ ) in C_VisitStep_s50 v49 {-# INLINE rule729 #-} {-# LINE 780 "./src-ag/ExecutionPlan2Hs.ag" #-} rule729 = \ ordered_ -> {-# LINE 780 "./src-ag/ExecutionPlan2Hs.ag" #-} VisitPure ordered_ {-# LINE 5885 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule730 #-} {-# LINE 812 "./src-ag/ExecutionPlan2Hs.ag" #-} rule730 = \ ((_lhsIfmtMode) :: FormatMode) ((_stepsIsem_steps) :: PP_Doc) -> {-# LINE 812 "./src-ag/ExecutionPlan2Hs.ag" #-} case _lhsIfmtMode of FormatDo -> "let" >#< _stepsIsem_steps _ -> _stepsIsem_steps {-# LINE 5893 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule731 #-} {-# LINE 833 "./src-ag/ExecutionPlan2Hs.ag" #-} rule731 = \ ((_lhsIfmtMode) :: FormatMode) -> {-# LINE 833 "./src-ag/ExecutionPlan2Hs.ag" #-} case _lhsIfmtMode of FormatDo -> FormatLetDecl mode -> mode {-# LINE 5901 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule732 #-} {-# LINE 1386 "./src-ag/ExecutionPlan2Hs.ag" #-} rule732 = \ ((_stepsIdefs) :: Set String) ((_stepsIlazyIntras) :: Set String) ordered_ -> {-# LINE 1386 "./src-ag/ExecutionPlan2Hs.ag" #-} if ordered_ then _stepsIlazyIntras else _stepsIdefs {-# LINE 5909 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule733 #-} rule733 = \ ((_stepsIdefs) :: Set String) -> _stepsIdefs {-# INLINE rule734 #-} rule734 = \ ((_stepsIerrors) :: Seq Error) -> _stepsIerrors {-# INLINE rule735 #-} rule735 = \ ((_stepsIruleKinds) :: Map Identifier (Set VisitKind)) -> _stepsIruleKinds {-# INLINE rule736 #-} rule736 = \ ((_stepsIruleUsage) :: Map Identifier Int) -> _stepsIruleUsage {-# INLINE rule737 #-} rule737 = \ ((_stepsIsync_steps) :: PP_Doc) -> _stepsIsync_steps {-# INLINE rule738 #-} rule738 = \ ((_stepsIusedArgs) :: Set String) -> _stepsIusedArgs {-# INLINE rule739 #-} rule739 = \ ((_stepsIuses) :: Map String (Maybe NonLocalAttr)) -> _stepsIuses {-# INLINE rule740 #-} rule740 = \ ((_stepsIvisitKinds) :: Map VisitIdentifier VisitKind) -> _stepsIvisitKinds {-# INLINE rule741 #-} rule741 = \ ((_stepsIindex) :: Int) -> _stepsIindex {-# INLINE rule742 #-} rule742 = \ ((_stepsIisLast) :: Bool) -> _stepsIisLast {-# INLINE rule743 #-} rule743 = \ ((_stepsIprevMaxSimRefs) :: Int) -> _stepsIprevMaxSimRefs {-# INLINE rule744 #-} rule744 = \ ((_lhsIallFromToStates) :: Map VisitIdentifier (Int,Int)) -> _lhsIallFromToStates {-# INLINE rule745 #-} rule745 = \ ((_lhsIallInitStates) :: Map NontermIdent Int) -> _lhsIallInitStates {-# INLINE rule746 #-} rule746 = \ ((_lhsIallVisitKinds) :: Map VisitIdentifier VisitKind) -> _lhsIallVisitKinds {-# INLINE rule747 #-} rule747 = \ ((_lhsIallchildvisit) :: Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) -> _lhsIallchildvisit {-# INLINE rule748 #-} rule748 = \ ((_lhsIavisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisitdefs {-# INLINE rule749 #-} rule749 = \ ((_lhsIavisituses) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisituses {-# INLINE rule750 #-} rule750 = \ ((_lhsIchildTypes) :: Map Identifier Type) -> _lhsIchildTypes {-# INLINE rule751 #-} rule751 = \ ((_lhsIchildintros) :: Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))) -> _lhsIchildintros {-# INLINE rule752 #-} rule752 = \ ((_lhsIindex) :: Int) -> _lhsIindex {-# INLINE rule753 #-} rule753 = \ ((_lhsImrules) :: Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)) -> _lhsImrules {-# INLINE rule754 #-} rule754 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule755 #-} rule755 = \ ((_lhsIprevMaxSimRefs) :: Int) -> _lhsIprevMaxSimRefs {-# INLINE rule756 #-} rule756 = \ ((_lhsIruledefs) :: Map Identifier (Set String)) -> _lhsIruledefs {-# INLINE rule757 #-} rule757 = \ ((_lhsIruleuses) :: Map Identifier (Map String (Maybe NonLocalAttr))) -> _lhsIruleuses {-# INLINE rule758 #-} rule758 = \ ((_lhsIuseParallel) :: Bool) -> _lhsIuseParallel {-# NOINLINE sem_VisitStep_Sim #-} sem_VisitStep_Sim :: T_VisitSteps -> T_VisitStep sem_VisitStep_Sim arg_steps_ = T_VisitStep (return st50) where {-# NOINLINE st50 #-} st50 = let v49 :: T_VisitStep_v49 v49 = \ (T_VisitStep_vIn49 _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIfmtMode _lhsIindex _lhsIisLast _lhsIkind _lhsImrules _lhsIoptions _lhsIprevMaxSimRefs _lhsIruledefs _lhsIruleuses _lhsIuseParallel) -> ( let _stepsX53 = Control.Monad.Identity.runIdentity (attach_T_VisitSteps (arg_steps_)) (T_VisitSteps_vOut52 _stepsIdefs _stepsIerrors _stepsIindex _stepsIisLast _stepsIlazyIntras _stepsIprevMaxSimRefs _stepsIruleKinds _stepsIruleUsage _stepsIsem_steps _stepsIsize _stepsIsync_steps _stepsIusedArgs _stepsIuses _stepsIvisitKinds) = inv_VisitSteps_s53 _stepsX53 (T_VisitSteps_vIn52 _stepsOallFromToStates _stepsOallInitStates _stepsOallVisitKinds _stepsOallchildvisit _stepsOavisitdefs _stepsOavisituses _stepsOchildTypes _stepsOchildintros _stepsOfmtMode _stepsOindex _stepsOkind _stepsOmrules _stepsOoptions _stepsOprevMaxSimRefs _stepsOruledefs _stepsOruleuses _stepsOuseParallel) _lhsOsem_steps :: PP_Doc _lhsOsem_steps = rule759 _stepsIsem_steps _stepsIsync_steps _stepsOindex = rule760 () _lhsOindex :: Int _lhsOindex = rule761 _lhsIindex _lhsOprevMaxSimRefs :: Int _lhsOprevMaxSimRefs = rule762 _lhsIprevMaxSimRefs _stepsIindex _useParallel _useParallel = rule763 _isMonadic _lhsIoptions _stepsIsize _isMonadic = rule764 _lhsIkind _lhsOdefs :: Set String _lhsOdefs = rule765 _stepsIdefs _lhsOerrors :: Seq Error _lhsOerrors = rule766 _stepsIerrors _lhsOlazyIntras :: Set String _lhsOlazyIntras = rule767 _stepsIlazyIntras _lhsOruleKinds :: Map Identifier (Set VisitKind) _lhsOruleKinds = rule768 _stepsIruleKinds _lhsOruleUsage :: Map Identifier Int _lhsOruleUsage = rule769 _stepsIruleUsage _lhsOsync_steps :: PP_Doc _lhsOsync_steps = rule770 _stepsIsync_steps _lhsOusedArgs :: Set String _lhsOusedArgs = rule771 _stepsIusedArgs _lhsOuses :: Map String (Maybe NonLocalAttr) _lhsOuses = rule772 _stepsIuses _lhsOvisitKinds :: Map VisitIdentifier VisitKind _lhsOvisitKinds = rule773 _stepsIvisitKinds _lhsOisLast :: Bool _lhsOisLast = rule774 _stepsIisLast _stepsOallFromToStates = rule775 _lhsIallFromToStates _stepsOallInitStates = rule776 _lhsIallInitStates _stepsOallVisitKinds = rule777 _lhsIallVisitKinds _stepsOallchildvisit = rule778 _lhsIallchildvisit _stepsOavisitdefs = rule779 _lhsIavisitdefs _stepsOavisituses = rule780 _lhsIavisituses _stepsOchildTypes = rule781 _lhsIchildTypes _stepsOchildintros = rule782 _lhsIchildintros _stepsOfmtMode = rule783 _lhsIfmtMode _stepsOkind = rule784 _lhsIkind _stepsOmrules = rule785 _lhsImrules _stepsOoptions = rule786 _lhsIoptions _stepsOprevMaxSimRefs = rule787 _lhsIprevMaxSimRefs _stepsOruledefs = rule788 _lhsIruledefs _stepsOruleuses = rule789 _lhsIruleuses _stepsOuseParallel = rule790 _useParallel __result_ = T_VisitStep_vOut49 _lhsOdefs _lhsOerrors _lhsOindex _lhsOisLast _lhsOlazyIntras _lhsOprevMaxSimRefs _lhsOruleKinds _lhsOruleUsage _lhsOsem_steps _lhsOsync_steps _lhsOusedArgs _lhsOuses _lhsOvisitKinds in __result_ ) in C_VisitStep_s50 v49 {-# INLINE rule759 #-} {-# LINE 811 "./src-ag/ExecutionPlan2Hs.ag" #-} rule759 = \ ((_stepsIsem_steps) :: PP_Doc) ((_stepsIsync_steps) :: PP_Doc) -> {-# LINE 811 "./src-ag/ExecutionPlan2Hs.ag" #-} _stepsIsem_steps >-< _stepsIsync_steps {-# LINE 6050 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule760 #-} {-# LINE 877 "./src-ag/ExecutionPlan2Hs.ag" #-} rule760 = \ (_ :: ()) -> {-# LINE 877 "./src-ag/ExecutionPlan2Hs.ag" #-} 0 {-# LINE 6056 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule761 #-} {-# LINE 878 "./src-ag/ExecutionPlan2Hs.ag" #-} rule761 = \ ((_lhsIindex) :: Int) -> {-# LINE 878 "./src-ag/ExecutionPlan2Hs.ag" #-} _lhsIindex {-# LINE 6062 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule762 #-} {-# LINE 885 "./src-ag/ExecutionPlan2Hs.ag" #-} rule762 = \ ((_lhsIprevMaxSimRefs) :: Int) ((_stepsIindex) :: Int) _useParallel -> {-# LINE 885 "./src-ag/ExecutionPlan2Hs.ag" #-} if _useParallel then _lhsIprevMaxSimRefs `max` (_stepsIindex - 1) else _lhsIprevMaxSimRefs {-# LINE 6070 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule763 #-} {-# LINE 900 "./src-ag/ExecutionPlan2Hs.ag" #-} rule763 = \ _isMonadic ((_lhsIoptions) :: Options) ((_stepsIsize) :: Int) -> {-# LINE 900 "./src-ag/ExecutionPlan2Hs.ag" #-} parallelInvoke _lhsIoptions && _stepsIsize > 1 && _isMonadic {-# LINE 6076 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule764 #-} {-# LINE 901 "./src-ag/ExecutionPlan2Hs.ag" #-} rule764 = \ ((_lhsIkind) :: VisitKind) -> {-# LINE 901 "./src-ag/ExecutionPlan2Hs.ag" #-} case _lhsIkind of VisitMonadic -> True _ -> False {-# LINE 6084 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule765 #-} rule765 = \ ((_stepsIdefs) :: Set String) -> _stepsIdefs {-# INLINE rule766 #-} rule766 = \ ((_stepsIerrors) :: Seq Error) -> _stepsIerrors {-# INLINE rule767 #-} rule767 = \ ((_stepsIlazyIntras) :: Set String) -> _stepsIlazyIntras {-# INLINE rule768 #-} rule768 = \ ((_stepsIruleKinds) :: Map Identifier (Set VisitKind)) -> _stepsIruleKinds {-# INLINE rule769 #-} rule769 = \ ((_stepsIruleUsage) :: Map Identifier Int) -> _stepsIruleUsage {-# INLINE rule770 #-} rule770 = \ ((_stepsIsync_steps) :: PP_Doc) -> _stepsIsync_steps {-# INLINE rule771 #-} rule771 = \ ((_stepsIusedArgs) :: Set String) -> _stepsIusedArgs {-# INLINE rule772 #-} rule772 = \ ((_stepsIuses) :: Map String (Maybe NonLocalAttr)) -> _stepsIuses {-# INLINE rule773 #-} rule773 = \ ((_stepsIvisitKinds) :: Map VisitIdentifier VisitKind) -> _stepsIvisitKinds {-# INLINE rule774 #-} rule774 = \ ((_stepsIisLast) :: Bool) -> _stepsIisLast {-# INLINE rule775 #-} rule775 = \ ((_lhsIallFromToStates) :: Map VisitIdentifier (Int,Int)) -> _lhsIallFromToStates {-# INLINE rule776 #-} rule776 = \ ((_lhsIallInitStates) :: Map NontermIdent Int) -> _lhsIallInitStates {-# INLINE rule777 #-} rule777 = \ ((_lhsIallVisitKinds) :: Map VisitIdentifier VisitKind) -> _lhsIallVisitKinds {-# INLINE rule778 #-} rule778 = \ ((_lhsIallchildvisit) :: Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) -> _lhsIallchildvisit {-# INLINE rule779 #-} rule779 = \ ((_lhsIavisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisitdefs {-# INLINE rule780 #-} rule780 = \ ((_lhsIavisituses) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisituses {-# INLINE rule781 #-} rule781 = \ ((_lhsIchildTypes) :: Map Identifier Type) -> _lhsIchildTypes {-# INLINE rule782 #-} rule782 = \ ((_lhsIchildintros) :: Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))) -> _lhsIchildintros {-# INLINE rule783 #-} rule783 = \ ((_lhsIfmtMode) :: FormatMode) -> _lhsIfmtMode {-# INLINE rule784 #-} rule784 = \ ((_lhsIkind) :: VisitKind) -> _lhsIkind {-# INLINE rule785 #-} rule785 = \ ((_lhsImrules) :: Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)) -> _lhsImrules {-# INLINE rule786 #-} rule786 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule787 #-} rule787 = \ ((_lhsIprevMaxSimRefs) :: Int) -> _lhsIprevMaxSimRefs {-# INLINE rule788 #-} rule788 = \ ((_lhsIruledefs) :: Map Identifier (Set String)) -> _lhsIruledefs {-# INLINE rule789 #-} rule789 = \ ((_lhsIruleuses) :: Map Identifier (Map String (Maybe NonLocalAttr))) -> _lhsIruleuses {-# INLINE rule790 #-} rule790 = \ _useParallel -> _useParallel {-# NOINLINE sem_VisitStep_ChildIntro #-} sem_VisitStep_ChildIntro :: (Identifier) -> T_VisitStep sem_VisitStep_ChildIntro arg_child_ = T_VisitStep (return st50) where {-# NOINLINE st50 #-} st50 = let v49 :: T_VisitStep_v49 v49 = \ (T_VisitStep_vIn49 _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIfmtMode _lhsIindex _lhsIisLast _lhsIkind _lhsImrules _lhsIoptions _lhsIprevMaxSimRefs _lhsIruledefs _lhsIruleuses _lhsIuseParallel) -> ( let _attachItf = rule791 _lhsIchildintros arg_child_ _lhsOerrors :: Seq Error _lhsOsem_steps :: PP_Doc _lhsOdefs :: Set String _lhsOuses :: Map String (Maybe NonLocalAttr) (_lhsOerrors,_lhsOsem_steps,_lhsOdefs,_lhsOuses) = rule792 _attachItf _lhsIfmtMode _lhsIkind _lhsOlazyIntras :: Set String _lhsOlazyIntras = rule793 () _lhsOruleKinds :: Map Identifier (Set VisitKind) _lhsOruleKinds = rule794 () _lhsOruleUsage :: Map Identifier Int _lhsOruleUsage = rule795 () _lhsOsync_steps :: PP_Doc _lhsOsync_steps = rule796 () _lhsOusedArgs :: Set String _lhsOusedArgs = rule797 () _lhsOvisitKinds :: Map VisitIdentifier VisitKind _lhsOvisitKinds = rule798 () _lhsOindex :: Int _lhsOindex = rule799 _lhsIindex _lhsOisLast :: Bool _lhsOisLast = rule800 _lhsIisLast _lhsOprevMaxSimRefs :: Int _lhsOprevMaxSimRefs = rule801 _lhsIprevMaxSimRefs __result_ = T_VisitStep_vOut49 _lhsOdefs _lhsOerrors _lhsOindex _lhsOisLast _lhsOlazyIntras _lhsOprevMaxSimRefs _lhsOruleKinds _lhsOruleUsage _lhsOsem_steps _lhsOsync_steps _lhsOusedArgs _lhsOuses _lhsOvisitKinds in __result_ ) in C_VisitStep_s50 v49 {-# INLINE rule791 #-} {-# LINE 789 "./src-ag/ExecutionPlan2Hs.ag" #-} rule791 = \ ((_lhsIchildintros) :: Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))) child_ -> {-# LINE 789 "./src-ag/ExecutionPlan2Hs.ag" #-} Map.findWithDefault (error $ "Child " ++ show child_ ++ " not found") child_ _lhsIchildintros {-# LINE 6202 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule792 #-} {-# LINE 791 "./src-ag/ExecutionPlan2Hs.ag" #-} rule792 = \ _attachItf ((_lhsIfmtMode) :: FormatMode) ((_lhsIkind) :: VisitKind) -> {-# LINE 791 "./src-ag/ExecutionPlan2Hs.ag" #-} case _attachItf _lhsIkind _lhsIfmtMode of Left e -> (Seq.singleton e, empty, Set.empty, Map.empty) Right (code, defs, uses) -> (Seq.empty, code, defs, uses) {-# LINE 6210 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule793 #-} rule793 = \ (_ :: ()) -> Set.empty {-# INLINE rule794 #-} rule794 = \ (_ :: ()) -> Map.empty {-# INLINE rule795 #-} rule795 = \ (_ :: ()) -> Map.empty {-# INLINE rule796 #-} rule796 = \ (_ :: ()) -> empty {-# INLINE rule797 #-} rule797 = \ (_ :: ()) -> Set.empty {-# INLINE rule798 #-} rule798 = \ (_ :: ()) -> mempty {-# INLINE rule799 #-} rule799 = \ ((_lhsIindex) :: Int) -> _lhsIindex {-# INLINE rule800 #-} rule800 = \ ((_lhsIisLast) :: Bool) -> _lhsIisLast {-# INLINE rule801 #-} rule801 = \ ((_lhsIprevMaxSimRefs) :: Int) -> _lhsIprevMaxSimRefs -- VisitSteps -------------------------------------------------- -- wrapper data Inh_VisitSteps = Inh_VisitSteps { allFromToStates_Inh_VisitSteps :: (Map VisitIdentifier (Int,Int)), allInitStates_Inh_VisitSteps :: (Map NontermIdent Int), allVisitKinds_Inh_VisitSteps :: (Map VisitIdentifier VisitKind), allchildvisit_Inh_VisitSteps :: (Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))), avisitdefs_Inh_VisitSteps :: (Map VisitIdentifier (Set Identifier)), avisituses_Inh_VisitSteps :: (Map VisitIdentifier (Set Identifier)), childTypes_Inh_VisitSteps :: (Map Identifier Type), childintros_Inh_VisitSteps :: (Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))), fmtMode_Inh_VisitSteps :: (FormatMode), index_Inh_VisitSteps :: (Int), kind_Inh_VisitSteps :: (VisitKind), mrules_Inh_VisitSteps :: (Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)), options_Inh_VisitSteps :: (Options), prevMaxSimRefs_Inh_VisitSteps :: (Int), ruledefs_Inh_VisitSteps :: (Map Identifier (Set String)), ruleuses_Inh_VisitSteps :: (Map Identifier (Map String (Maybe NonLocalAttr))), useParallel_Inh_VisitSteps :: (Bool) } data Syn_VisitSteps = Syn_VisitSteps { defs_Syn_VisitSteps :: (Set String), errors_Syn_VisitSteps :: (Seq Error), index_Syn_VisitSteps :: (Int), isLast_Syn_VisitSteps :: (Bool), lazyIntras_Syn_VisitSteps :: (Set String), prevMaxSimRefs_Syn_VisitSteps :: (Int), ruleKinds_Syn_VisitSteps :: (Map Identifier (Set VisitKind)), ruleUsage_Syn_VisitSteps :: (Map Identifier Int), sem_steps_Syn_VisitSteps :: (PP_Doc), size_Syn_VisitSteps :: (Int), sync_steps_Syn_VisitSteps :: (PP_Doc), usedArgs_Syn_VisitSteps :: (Set String), uses_Syn_VisitSteps :: (Map String (Maybe NonLocalAttr)), visitKinds_Syn_VisitSteps :: (Map VisitIdentifier VisitKind) } {-# INLINABLE wrap_VisitSteps #-} wrap_VisitSteps :: T_VisitSteps -> Inh_VisitSteps -> (Syn_VisitSteps ) wrap_VisitSteps (T_VisitSteps act) (Inh_VisitSteps _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIfmtMode _lhsIindex _lhsIkind _lhsImrules _lhsIoptions _lhsIprevMaxSimRefs _lhsIruledefs _lhsIruleuses _lhsIuseParallel) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_VisitSteps_vIn52 _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIfmtMode _lhsIindex _lhsIkind _lhsImrules _lhsIoptions _lhsIprevMaxSimRefs _lhsIruledefs _lhsIruleuses _lhsIuseParallel (T_VisitSteps_vOut52 _lhsOdefs _lhsOerrors _lhsOindex _lhsOisLast _lhsOlazyIntras _lhsOprevMaxSimRefs _lhsOruleKinds _lhsOruleUsage _lhsOsem_steps _lhsOsize _lhsOsync_steps _lhsOusedArgs _lhsOuses _lhsOvisitKinds) <- return (inv_VisitSteps_s53 sem arg) return (Syn_VisitSteps _lhsOdefs _lhsOerrors _lhsOindex _lhsOisLast _lhsOlazyIntras _lhsOprevMaxSimRefs _lhsOruleKinds _lhsOruleUsage _lhsOsem_steps _lhsOsize _lhsOsync_steps _lhsOusedArgs _lhsOuses _lhsOvisitKinds) ) -- cata {-# NOINLINE sem_VisitSteps #-} sem_VisitSteps :: VisitSteps -> T_VisitSteps sem_VisitSteps list = Prelude.foldr sem_VisitSteps_Cons sem_VisitSteps_Nil (Prelude.map sem_VisitStep list) -- semantic domain newtype T_VisitSteps = T_VisitSteps { attach_T_VisitSteps :: Identity (T_VisitSteps_s53 ) } newtype T_VisitSteps_s53 = C_VisitSteps_s53 { inv_VisitSteps_s53 :: (T_VisitSteps_v52 ) } data T_VisitSteps_s54 = C_VisitSteps_s54 type T_VisitSteps_v52 = (T_VisitSteps_vIn52 ) -> (T_VisitSteps_vOut52 ) data T_VisitSteps_vIn52 = T_VisitSteps_vIn52 (Map VisitIdentifier (Int,Int)) (Map NontermIdent Int) (Map VisitIdentifier VisitKind) (Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) (Map VisitIdentifier (Set Identifier)) (Map VisitIdentifier (Set Identifier)) (Map Identifier Type) (Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))) (FormatMode) (Int) (VisitKind) (Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)) (Options) (Int) (Map Identifier (Set String)) (Map Identifier (Map String (Maybe NonLocalAttr))) (Bool) data T_VisitSteps_vOut52 = T_VisitSteps_vOut52 (Set String) (Seq Error) (Int) (Bool) (Set String) (Int) (Map Identifier (Set VisitKind)) (Map Identifier Int) (PP_Doc) (Int) (PP_Doc) (Set String) (Map String (Maybe NonLocalAttr)) (Map VisitIdentifier VisitKind) {-# NOINLINE sem_VisitSteps_Cons #-} sem_VisitSteps_Cons :: T_VisitStep -> T_VisitSteps -> T_VisitSteps sem_VisitSteps_Cons arg_hd_ arg_tl_ = T_VisitSteps (return st53) where {-# NOINLINE st53 #-} st53 = let v52 :: T_VisitSteps_v52 v52 = \ (T_VisitSteps_vIn52 _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIfmtMode _lhsIindex _lhsIkind _lhsImrules _lhsIoptions _lhsIprevMaxSimRefs _lhsIruledefs _lhsIruleuses _lhsIuseParallel) -> ( let _hdX50 = Control.Monad.Identity.runIdentity (attach_T_VisitStep (arg_hd_)) _tlX53 = Control.Monad.Identity.runIdentity (attach_T_VisitSteps (arg_tl_)) (T_VisitStep_vOut49 _hdIdefs _hdIerrors _hdIindex _hdIisLast _hdIlazyIntras _hdIprevMaxSimRefs _hdIruleKinds _hdIruleUsage _hdIsem_steps _hdIsync_steps _hdIusedArgs _hdIuses _hdIvisitKinds) = inv_VisitStep_s50 _hdX50 (T_VisitStep_vIn49 _hdOallFromToStates _hdOallInitStates _hdOallVisitKinds _hdOallchildvisit _hdOavisitdefs _hdOavisituses _hdOchildTypes _hdOchildintros _hdOfmtMode _hdOindex _hdOisLast _hdOkind _hdOmrules _hdOoptions _hdOprevMaxSimRefs _hdOruledefs _hdOruleuses _hdOuseParallel) (T_VisitSteps_vOut52 _tlIdefs _tlIerrors _tlIindex _tlIisLast _tlIlazyIntras _tlIprevMaxSimRefs _tlIruleKinds _tlIruleUsage _tlIsem_steps _tlIsize _tlIsync_steps _tlIusedArgs _tlIuses _tlIvisitKinds) = inv_VisitSteps_s53 _tlX53 (T_VisitSteps_vIn52 _tlOallFromToStates _tlOallInitStates _tlOallVisitKinds _tlOallchildvisit _tlOavisitdefs _tlOavisituses _tlOchildTypes _tlOchildintros _tlOfmtMode _tlOindex _tlOkind _tlOmrules _tlOoptions _tlOprevMaxSimRefs _tlOruledefs _tlOruleuses _tlOuseParallel) _lhsOsize :: Int _lhsOsize = rule802 _tlIsize _hdOindex = rule803 _lhsIindex _tlOindex = rule804 _lhsIindex _lhsOindex :: Int _lhsOindex = rule805 _tlIindex _lhsOisLast :: Bool _lhsOisLast = rule806 () _hdOisLast = rule807 _tlIisLast _lhsOdefs :: Set String _lhsOdefs = rule808 _hdIdefs _tlIdefs _lhsOerrors :: Seq Error _lhsOerrors = rule809 _hdIerrors _tlIerrors _lhsOlazyIntras :: Set String _lhsOlazyIntras = rule810 _hdIlazyIntras _tlIlazyIntras _lhsOruleKinds :: Map Identifier (Set VisitKind) _lhsOruleKinds = rule811 _hdIruleKinds _tlIruleKinds _lhsOruleUsage :: Map Identifier Int _lhsOruleUsage = rule812 _hdIruleUsage _tlIruleUsage _lhsOsem_steps :: PP_Doc _lhsOsem_steps = rule813 _hdIsem_steps _tlIsem_steps _lhsOsync_steps :: PP_Doc _lhsOsync_steps = rule814 _hdIsync_steps _tlIsync_steps _lhsOusedArgs :: Set String _lhsOusedArgs = rule815 _hdIusedArgs _tlIusedArgs _lhsOuses :: Map String (Maybe NonLocalAttr) _lhsOuses = rule816 _hdIuses _tlIuses _lhsOvisitKinds :: Map VisitIdentifier VisitKind _lhsOvisitKinds = rule817 _hdIvisitKinds _tlIvisitKinds _lhsOprevMaxSimRefs :: Int _lhsOprevMaxSimRefs = rule818 _tlIprevMaxSimRefs _hdOallFromToStates = rule819 _lhsIallFromToStates _hdOallInitStates = rule820 _lhsIallInitStates _hdOallVisitKinds = rule821 _lhsIallVisitKinds _hdOallchildvisit = rule822 _lhsIallchildvisit _hdOavisitdefs = rule823 _lhsIavisitdefs _hdOavisituses = rule824 _lhsIavisituses _hdOchildTypes = rule825 _lhsIchildTypes _hdOchildintros = rule826 _lhsIchildintros _hdOfmtMode = rule827 _lhsIfmtMode _hdOkind = rule828 _lhsIkind _hdOmrules = rule829 _lhsImrules _hdOoptions = rule830 _lhsIoptions _hdOprevMaxSimRefs = rule831 _lhsIprevMaxSimRefs _hdOruledefs = rule832 _lhsIruledefs _hdOruleuses = rule833 _lhsIruleuses _hdOuseParallel = rule834 _lhsIuseParallel _tlOallFromToStates = rule835 _lhsIallFromToStates _tlOallInitStates = rule836 _lhsIallInitStates _tlOallVisitKinds = rule837 _lhsIallVisitKinds _tlOallchildvisit = rule838 _lhsIallchildvisit _tlOavisitdefs = rule839 _lhsIavisitdefs _tlOavisituses = rule840 _lhsIavisituses _tlOchildTypes = rule841 _lhsIchildTypes _tlOchildintros = rule842 _lhsIchildintros _tlOfmtMode = rule843 _lhsIfmtMode _tlOkind = rule844 _lhsIkind _tlOmrules = rule845 _lhsImrules _tlOoptions = rule846 _lhsIoptions _tlOprevMaxSimRefs = rule847 _hdIprevMaxSimRefs _tlOruledefs = rule848 _lhsIruledefs _tlOruleuses = rule849 _lhsIruleuses _tlOuseParallel = rule850 _lhsIuseParallel __result_ = T_VisitSteps_vOut52 _lhsOdefs _lhsOerrors _lhsOindex _lhsOisLast _lhsOlazyIntras _lhsOprevMaxSimRefs _lhsOruleKinds _lhsOruleUsage _lhsOsem_steps _lhsOsize _lhsOsync_steps _lhsOusedArgs _lhsOuses _lhsOvisitKinds in __result_ ) in C_VisitSteps_s53 v52 {-# INLINE rule802 #-} {-# LINE 868 "./src-ag/ExecutionPlan2Hs.ag" #-} rule802 = \ ((_tlIsize) :: Int) -> {-# LINE 868 "./src-ag/ExecutionPlan2Hs.ag" #-} 1 + _tlIsize {-# LINE 6351 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule803 #-} {-# LINE 873 "./src-ag/ExecutionPlan2Hs.ag" #-} rule803 = \ ((_lhsIindex) :: Int) -> {-# LINE 873 "./src-ag/ExecutionPlan2Hs.ag" #-} _lhsIindex {-# LINE 6357 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule804 #-} {-# LINE 874 "./src-ag/ExecutionPlan2Hs.ag" #-} rule804 = \ ((_lhsIindex) :: Int) -> {-# LINE 874 "./src-ag/ExecutionPlan2Hs.ag" #-} 1 + _lhsIindex {-# LINE 6363 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule805 #-} {-# LINE 875 "./src-ag/ExecutionPlan2Hs.ag" #-} rule805 = \ ((_tlIindex) :: Int) -> {-# LINE 875 "./src-ag/ExecutionPlan2Hs.ag" #-} _tlIindex {-# LINE 6369 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule806 #-} {-# LINE 894 "./src-ag/ExecutionPlan2Hs.ag" #-} rule806 = \ (_ :: ()) -> {-# LINE 894 "./src-ag/ExecutionPlan2Hs.ag" #-} False {-# LINE 6375 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule807 #-} {-# LINE 895 "./src-ag/ExecutionPlan2Hs.ag" #-} rule807 = \ ((_tlIisLast) :: Bool) -> {-# LINE 895 "./src-ag/ExecutionPlan2Hs.ag" #-} _tlIisLast {-# LINE 6381 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule808 #-} rule808 = \ ((_hdIdefs) :: Set String) ((_tlIdefs) :: Set String) -> _hdIdefs `Set.union` _tlIdefs {-# INLINE rule809 #-} rule809 = \ ((_hdIerrors) :: Seq Error) ((_tlIerrors) :: Seq Error) -> _hdIerrors Seq.>< _tlIerrors {-# INLINE rule810 #-} rule810 = \ ((_hdIlazyIntras) :: Set String) ((_tlIlazyIntras) :: Set String) -> _hdIlazyIntras `Set.union` _tlIlazyIntras {-# INLINE rule811 #-} rule811 = \ ((_hdIruleKinds) :: Map Identifier (Set VisitKind)) ((_tlIruleKinds) :: Map Identifier (Set VisitKind)) -> _hdIruleKinds `unionWithMappend` _tlIruleKinds {-# INLINE rule812 #-} rule812 = \ ((_hdIruleUsage) :: Map Identifier Int) ((_tlIruleUsage) :: Map Identifier Int) -> _hdIruleUsage `unionWithSum` _tlIruleUsage {-# INLINE rule813 #-} rule813 = \ ((_hdIsem_steps) :: PP_Doc) ((_tlIsem_steps) :: PP_Doc) -> _hdIsem_steps >-< _tlIsem_steps {-# INLINE rule814 #-} rule814 = \ ((_hdIsync_steps) :: PP_Doc) ((_tlIsync_steps) :: PP_Doc) -> _hdIsync_steps >-< _tlIsync_steps {-# INLINE rule815 #-} rule815 = \ ((_hdIusedArgs) :: Set String) ((_tlIusedArgs) :: Set String) -> _hdIusedArgs `Set.union` _tlIusedArgs {-# INLINE rule816 #-} rule816 = \ ((_hdIuses) :: Map String (Maybe NonLocalAttr)) ((_tlIuses) :: Map String (Maybe NonLocalAttr)) -> _hdIuses `Map.union` _tlIuses {-# INLINE rule817 #-} rule817 = \ ((_hdIvisitKinds) :: Map VisitIdentifier VisitKind) ((_tlIvisitKinds) :: Map VisitIdentifier VisitKind) -> _hdIvisitKinds `mappend` _tlIvisitKinds {-# INLINE rule818 #-} rule818 = \ ((_tlIprevMaxSimRefs) :: Int) -> _tlIprevMaxSimRefs {-# INLINE rule819 #-} rule819 = \ ((_lhsIallFromToStates) :: Map VisitIdentifier (Int,Int)) -> _lhsIallFromToStates {-# INLINE rule820 #-} rule820 = \ ((_lhsIallInitStates) :: Map NontermIdent Int) -> _lhsIallInitStates {-# INLINE rule821 #-} rule821 = \ ((_lhsIallVisitKinds) :: Map VisitIdentifier VisitKind) -> _lhsIallVisitKinds {-# INLINE rule822 #-} rule822 = \ ((_lhsIallchildvisit) :: Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) -> _lhsIallchildvisit {-# INLINE rule823 #-} rule823 = \ ((_lhsIavisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisitdefs {-# INLINE rule824 #-} rule824 = \ ((_lhsIavisituses) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisituses {-# INLINE rule825 #-} rule825 = \ ((_lhsIchildTypes) :: Map Identifier Type) -> _lhsIchildTypes {-# INLINE rule826 #-} rule826 = \ ((_lhsIchildintros) :: Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))) -> _lhsIchildintros {-# INLINE rule827 #-} rule827 = \ ((_lhsIfmtMode) :: FormatMode) -> _lhsIfmtMode {-# INLINE rule828 #-} rule828 = \ ((_lhsIkind) :: VisitKind) -> _lhsIkind {-# INLINE rule829 #-} rule829 = \ ((_lhsImrules) :: Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)) -> _lhsImrules {-# INLINE rule830 #-} rule830 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule831 #-} rule831 = \ ((_lhsIprevMaxSimRefs) :: Int) -> _lhsIprevMaxSimRefs {-# INLINE rule832 #-} rule832 = \ ((_lhsIruledefs) :: Map Identifier (Set String)) -> _lhsIruledefs {-# INLINE rule833 #-} rule833 = \ ((_lhsIruleuses) :: Map Identifier (Map String (Maybe NonLocalAttr))) -> _lhsIruleuses {-# INLINE rule834 #-} rule834 = \ ((_lhsIuseParallel) :: Bool) -> _lhsIuseParallel {-# INLINE rule835 #-} rule835 = \ ((_lhsIallFromToStates) :: Map VisitIdentifier (Int,Int)) -> _lhsIallFromToStates {-# INLINE rule836 #-} rule836 = \ ((_lhsIallInitStates) :: Map NontermIdent Int) -> _lhsIallInitStates {-# INLINE rule837 #-} rule837 = \ ((_lhsIallVisitKinds) :: Map VisitIdentifier VisitKind) -> _lhsIallVisitKinds {-# INLINE rule838 #-} rule838 = \ ((_lhsIallchildvisit) :: Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) -> _lhsIallchildvisit {-# INLINE rule839 #-} rule839 = \ ((_lhsIavisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisitdefs {-# INLINE rule840 #-} rule840 = \ ((_lhsIavisituses) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisituses {-# INLINE rule841 #-} rule841 = \ ((_lhsIchildTypes) :: Map Identifier Type) -> _lhsIchildTypes {-# INLINE rule842 #-} rule842 = \ ((_lhsIchildintros) :: Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))) -> _lhsIchildintros {-# INLINE rule843 #-} rule843 = \ ((_lhsIfmtMode) :: FormatMode) -> _lhsIfmtMode {-# INLINE rule844 #-} rule844 = \ ((_lhsIkind) :: VisitKind) -> _lhsIkind {-# INLINE rule845 #-} rule845 = \ ((_lhsImrules) :: Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)) -> _lhsImrules {-# INLINE rule846 #-} rule846 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule847 #-} rule847 = \ ((_hdIprevMaxSimRefs) :: Int) -> _hdIprevMaxSimRefs {-# INLINE rule848 #-} rule848 = \ ((_lhsIruledefs) :: Map Identifier (Set String)) -> _lhsIruledefs {-# INLINE rule849 #-} rule849 = \ ((_lhsIruleuses) :: Map Identifier (Map String (Maybe NonLocalAttr))) -> _lhsIruleuses {-# INLINE rule850 #-} rule850 = \ ((_lhsIuseParallel) :: Bool) -> _lhsIuseParallel {-# NOINLINE sem_VisitSteps_Nil #-} sem_VisitSteps_Nil :: T_VisitSteps sem_VisitSteps_Nil = T_VisitSteps (return st53) where {-# NOINLINE st53 #-} st53 = let v52 :: T_VisitSteps_v52 v52 = \ (T_VisitSteps_vIn52 _lhsIallFromToStates _lhsIallInitStates _lhsIallVisitKinds _lhsIallchildvisit _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIfmtMode _lhsIindex _lhsIkind _lhsImrules _lhsIoptions _lhsIprevMaxSimRefs _lhsIruledefs _lhsIruleuses _lhsIuseParallel) -> ( let _lhsOsize :: Int _lhsOsize = rule851 () _lhsOisLast :: Bool _lhsOisLast = rule852 () _lhsOdefs :: Set String _lhsOdefs = rule853 () _lhsOerrors :: Seq Error _lhsOerrors = rule854 () _lhsOlazyIntras :: Set String _lhsOlazyIntras = rule855 () _lhsOruleKinds :: Map Identifier (Set VisitKind) _lhsOruleKinds = rule856 () _lhsOruleUsage :: Map Identifier Int _lhsOruleUsage = rule857 () _lhsOsem_steps :: PP_Doc _lhsOsem_steps = rule858 () _lhsOsync_steps :: PP_Doc _lhsOsync_steps = rule859 () _lhsOusedArgs :: Set String _lhsOusedArgs = rule860 () _lhsOuses :: Map String (Maybe NonLocalAttr) _lhsOuses = rule861 () _lhsOvisitKinds :: Map VisitIdentifier VisitKind _lhsOvisitKinds = rule862 () _lhsOindex :: Int _lhsOindex = rule863 _lhsIindex _lhsOprevMaxSimRefs :: Int _lhsOprevMaxSimRefs = rule864 _lhsIprevMaxSimRefs __result_ = T_VisitSteps_vOut52 _lhsOdefs _lhsOerrors _lhsOindex _lhsOisLast _lhsOlazyIntras _lhsOprevMaxSimRefs _lhsOruleKinds _lhsOruleUsage _lhsOsem_steps _lhsOsize _lhsOsync_steps _lhsOusedArgs _lhsOuses _lhsOvisitKinds in __result_ ) in C_VisitSteps_s53 v52 {-# INLINE rule851 #-} {-# LINE 867 "./src-ag/ExecutionPlan2Hs.ag" #-} rule851 = \ (_ :: ()) -> {-# LINE 867 "./src-ag/ExecutionPlan2Hs.ag" #-} 0 {-# LINE 6554 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule852 #-} {-# LINE 893 "./src-ag/ExecutionPlan2Hs.ag" #-} rule852 = \ (_ :: ()) -> {-# LINE 893 "./src-ag/ExecutionPlan2Hs.ag" #-} True {-# LINE 6560 "dist/build/ExecutionPlan2Hs.hs"#-} {-# INLINE rule853 #-} rule853 = \ (_ :: ()) -> Set.empty {-# INLINE rule854 #-} rule854 = \ (_ :: ()) -> Seq.empty {-# INLINE rule855 #-} rule855 = \ (_ :: ()) -> Set.empty {-# INLINE rule856 #-} rule856 = \ (_ :: ()) -> Map.empty {-# INLINE rule857 #-} rule857 = \ (_ :: ()) -> Map.empty {-# INLINE rule858 #-} rule858 = \ (_ :: ()) -> empty {-# INLINE rule859 #-} rule859 = \ (_ :: ()) -> empty {-# INLINE rule860 #-} rule860 = \ (_ :: ()) -> Set.empty {-# INLINE rule861 #-} rule861 = \ (_ :: ()) -> Map.empty {-# INLINE rule862 #-} rule862 = \ (_ :: ()) -> mempty {-# INLINE rule863 #-} rule863 = \ ((_lhsIindex) :: Int) -> _lhsIindex {-# INLINE rule864 #-} rule864 = \ ((_lhsIprevMaxSimRefs) :: Int) -> _lhsIprevMaxSimRefs -- Visits ------------------------------------------------------ -- wrapper data Inh_Visits = Inh_Visits { allFromToStates_Inh_Visits :: (Map VisitIdentifier (Int,Int)), allInhmap_Inh_Visits :: (Map NontermIdent Attributes), allInitStates_Inh_Visits :: (Map NontermIdent Int), allSynmap_Inh_Visits :: (Map NontermIdent Attributes), allVisitKinds_Inh_Visits :: (Map VisitIdentifier VisitKind), allchildvisit_Inh_Visits :: (Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))), allintramap_Inh_Visits :: (Map StateIdentifier (Map String (Maybe NonLocalAttr))), avisitdefs_Inh_Visits :: (Map VisitIdentifier (Set Identifier)), avisituses_Inh_Visits :: (Map VisitIdentifier (Set Identifier)), childTypes_Inh_Visits :: (Map Identifier Type), childintros_Inh_Visits :: (Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))), con_Inh_Visits :: (ConstructorIdent), inhmap_Inh_Visits :: (Attributes), mrules_Inh_Visits :: (Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)), nextVisits_Inh_Visits :: (Map StateIdentifier StateCtx), nt_Inh_Visits :: (NontermIdent), options_Inh_Visits :: (Options), params_Inh_Visits :: ([Identifier]), prevVisits_Inh_Visits :: (Map StateIdentifier StateCtx), ruledefs_Inh_Visits :: (Map Identifier (Set String)), ruleuses_Inh_Visits :: (Map Identifier (Map String (Maybe NonLocalAttr))), synmap_Inh_Visits :: (Attributes), terminaldefs_Inh_Visits :: (Set String) } data Syn_Visits = Syn_Visits { allvisits_Syn_Visits :: ([VisitStateState]), childvisit_Syn_Visits :: (Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))), errors_Syn_Visits :: (Seq Error), fromToStates_Syn_Visits :: (Map VisitIdentifier (Int,Int)), intramap_Syn_Visits :: (Map StateIdentifier (Map String (Maybe NonLocalAttr))), lazyIntras_Syn_Visits :: (Set String), ruleKinds_Syn_Visits :: (Map Identifier (Set VisitKind)), ruleUsage_Syn_Visits :: (Map Identifier Int), sem_visit_Syn_Visits :: ( [(StateIdentifier,Bool -> PP_Doc)] ), t_visits_Syn_Visits :: (PP_Doc), usedArgs_Syn_Visits :: (Set String), visitKinds_Syn_Visits :: (Map VisitIdentifier VisitKind), visitdefs_Syn_Visits :: (Map VisitIdentifier (Set Identifier)), visituses_Syn_Visits :: (Map VisitIdentifier (Set Identifier)) } {-# INLINABLE wrap_Visits #-} wrap_Visits :: T_Visits -> Inh_Visits -> (Syn_Visits ) wrap_Visits (T_Visits act) (Inh_Visits _lhsIallFromToStates _lhsIallInhmap _lhsIallInitStates _lhsIallSynmap _lhsIallVisitKinds _lhsIallchildvisit _lhsIallintramap _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIcon _lhsIinhmap _lhsImrules _lhsInextVisits _lhsInt _lhsIoptions _lhsIparams _lhsIprevVisits _lhsIruledefs _lhsIruleuses _lhsIsynmap _lhsIterminaldefs) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Visits_vIn55 _lhsIallFromToStates _lhsIallInhmap _lhsIallInitStates _lhsIallSynmap _lhsIallVisitKinds _lhsIallchildvisit _lhsIallintramap _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIcon _lhsIinhmap _lhsImrules _lhsInextVisits _lhsInt _lhsIoptions _lhsIparams _lhsIprevVisits _lhsIruledefs _lhsIruleuses _lhsIsynmap _lhsIterminaldefs (T_Visits_vOut55 _lhsOallvisits _lhsOchildvisit _lhsOerrors _lhsOfromToStates _lhsOintramap _lhsOlazyIntras _lhsOruleKinds _lhsOruleUsage _lhsOsem_visit _lhsOt_visits _lhsOusedArgs _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses) <- return (inv_Visits_s56 sem arg) return (Syn_Visits _lhsOallvisits _lhsOchildvisit _lhsOerrors _lhsOfromToStates _lhsOintramap _lhsOlazyIntras _lhsOruleKinds _lhsOruleUsage _lhsOsem_visit _lhsOt_visits _lhsOusedArgs _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses) ) -- cata {-# NOINLINE sem_Visits #-} sem_Visits :: Visits -> T_Visits sem_Visits list = Prelude.foldr sem_Visits_Cons sem_Visits_Nil (Prelude.map sem_Visit list) -- semantic domain newtype T_Visits = T_Visits { attach_T_Visits :: Identity (T_Visits_s56 ) } newtype T_Visits_s56 = C_Visits_s56 { inv_Visits_s56 :: (T_Visits_v55 ) } data T_Visits_s57 = C_Visits_s57 type T_Visits_v55 = (T_Visits_vIn55 ) -> (T_Visits_vOut55 ) data T_Visits_vIn55 = T_Visits_vIn55 (Map VisitIdentifier (Int,Int)) (Map NontermIdent Attributes) (Map NontermIdent Int) (Map NontermIdent Attributes) (Map VisitIdentifier VisitKind) (Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) (Map StateIdentifier (Map String (Maybe NonLocalAttr))) (Map VisitIdentifier (Set Identifier)) (Map VisitIdentifier (Set Identifier)) (Map Identifier Type) (Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))) (ConstructorIdent) (Attributes) (Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)) (Map StateIdentifier StateCtx) (NontermIdent) (Options) ([Identifier]) (Map StateIdentifier StateCtx) (Map Identifier (Set String)) (Map Identifier (Map String (Maybe NonLocalAttr))) (Attributes) (Set String) data T_Visits_vOut55 = T_Visits_vOut55 ([VisitStateState]) (Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) (Seq Error) (Map VisitIdentifier (Int,Int)) (Map StateIdentifier (Map String (Maybe NonLocalAttr))) (Set String) (Map Identifier (Set VisitKind)) (Map Identifier Int) ( [(StateIdentifier,Bool -> PP_Doc)] ) (PP_Doc) (Set String) (Map VisitIdentifier VisitKind) (Map VisitIdentifier (Set Identifier)) (Map VisitIdentifier (Set Identifier)) {-# NOINLINE sem_Visits_Cons #-} sem_Visits_Cons :: T_Visit -> T_Visits -> T_Visits sem_Visits_Cons arg_hd_ arg_tl_ = T_Visits (return st56) where {-# NOINLINE st56 #-} st56 = let v55 :: T_Visits_v55 v55 = \ (T_Visits_vIn55 _lhsIallFromToStates _lhsIallInhmap _lhsIallInitStates _lhsIallSynmap _lhsIallVisitKinds _lhsIallchildvisit _lhsIallintramap _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIcon _lhsIinhmap _lhsImrules _lhsInextVisits _lhsInt _lhsIoptions _lhsIparams _lhsIprevVisits _lhsIruledefs _lhsIruleuses _lhsIsynmap _lhsIterminaldefs) -> ( let _hdX47 = Control.Monad.Identity.runIdentity (attach_T_Visit (arg_hd_)) _tlX56 = Control.Monad.Identity.runIdentity (attach_T_Visits (arg_tl_)) (T_Visit_vOut46 _hdIallvisits _hdIchildvisit _hdIerrors _hdIfromToStates _hdIintramap _hdIlazyIntras _hdIruleKinds _hdIruleUsage _hdIsem_visit _hdIt_visits _hdIusedArgs _hdIvisitKinds _hdIvisitdefs _hdIvisituses) = inv_Visit_s47 _hdX47 (T_Visit_vIn46 _hdOallFromToStates _hdOallInhmap _hdOallInitStates _hdOallSynmap _hdOallVisitKinds _hdOallchildvisit _hdOallintramap _hdOavisitdefs _hdOavisituses _hdOchildTypes _hdOchildintros _hdOcon _hdOinhmap _hdOmrules _hdOnextVisits _hdOnt _hdOoptions _hdOparams _hdOprevVisits _hdOruledefs _hdOruleuses _hdOsynmap _hdOterminaldefs) (T_Visits_vOut55 _tlIallvisits _tlIchildvisit _tlIerrors _tlIfromToStates _tlIintramap _tlIlazyIntras _tlIruleKinds _tlIruleUsage _tlIsem_visit _tlIt_visits _tlIusedArgs _tlIvisitKinds _tlIvisitdefs _tlIvisituses) = inv_Visits_s56 _tlX56 (T_Visits_vIn55 _tlOallFromToStates _tlOallInhmap _tlOallInitStates _tlOallSynmap _tlOallVisitKinds _tlOallchildvisit _tlOallintramap _tlOavisitdefs _tlOavisituses _tlOchildTypes _tlOchildintros _tlOcon _tlOinhmap _tlOmrules _tlOnextVisits _tlOnt _tlOoptions _tlOparams _tlOprevVisits _tlOruledefs _tlOruleuses _tlOsynmap _tlOterminaldefs) _lhsOallvisits :: [VisitStateState] _lhsOallvisits = rule865 _hdIallvisits _tlIallvisits _lhsOchildvisit :: Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc)) _lhsOchildvisit = rule866 _hdIchildvisit _tlIchildvisit _lhsOerrors :: Seq Error _lhsOerrors = rule867 _hdIerrors _tlIerrors _lhsOfromToStates :: Map VisitIdentifier (Int,Int) _lhsOfromToStates = rule868 _hdIfromToStates _tlIfromToStates _lhsOintramap :: Map StateIdentifier (Map String (Maybe NonLocalAttr)) _lhsOintramap = rule869 _hdIintramap _tlIintramap _lhsOlazyIntras :: Set String _lhsOlazyIntras = rule870 _hdIlazyIntras _tlIlazyIntras _lhsOruleKinds :: Map Identifier (Set VisitKind) _lhsOruleKinds = rule871 _hdIruleKinds _tlIruleKinds _lhsOruleUsage :: Map Identifier Int _lhsOruleUsage = rule872 _hdIruleUsage _tlIruleUsage _lhsOsem_visit :: [(StateIdentifier,Bool -> PP_Doc)] _lhsOsem_visit = rule873 _hdIsem_visit _tlIsem_visit _lhsOt_visits :: PP_Doc _lhsOt_visits = rule874 _hdIt_visits _tlIt_visits _lhsOusedArgs :: Set String _lhsOusedArgs = rule875 _hdIusedArgs _tlIusedArgs _lhsOvisitKinds :: Map VisitIdentifier VisitKind _lhsOvisitKinds = rule876 _hdIvisitKinds _tlIvisitKinds _lhsOvisitdefs :: Map VisitIdentifier (Set Identifier) _lhsOvisitdefs = rule877 _hdIvisitdefs _tlIvisitdefs _lhsOvisituses :: Map VisitIdentifier (Set Identifier) _lhsOvisituses = rule878 _hdIvisituses _tlIvisituses _hdOallFromToStates = rule879 _lhsIallFromToStates _hdOallInhmap = rule880 _lhsIallInhmap _hdOallInitStates = rule881 _lhsIallInitStates _hdOallSynmap = rule882 _lhsIallSynmap _hdOallVisitKinds = rule883 _lhsIallVisitKinds _hdOallchildvisit = rule884 _lhsIallchildvisit _hdOallintramap = rule885 _lhsIallintramap _hdOavisitdefs = rule886 _lhsIavisitdefs _hdOavisituses = rule887 _lhsIavisituses _hdOchildTypes = rule888 _lhsIchildTypes _hdOchildintros = rule889 _lhsIchildintros _hdOcon = rule890 _lhsIcon _hdOinhmap = rule891 _lhsIinhmap _hdOmrules = rule892 _lhsImrules _hdOnextVisits = rule893 _lhsInextVisits _hdOnt = rule894 _lhsInt _hdOoptions = rule895 _lhsIoptions _hdOparams = rule896 _lhsIparams _hdOprevVisits = rule897 _lhsIprevVisits _hdOruledefs = rule898 _lhsIruledefs _hdOruleuses = rule899 _lhsIruleuses _hdOsynmap = rule900 _lhsIsynmap _hdOterminaldefs = rule901 _lhsIterminaldefs _tlOallFromToStates = rule902 _lhsIallFromToStates _tlOallInhmap = rule903 _lhsIallInhmap _tlOallInitStates = rule904 _lhsIallInitStates _tlOallSynmap = rule905 _lhsIallSynmap _tlOallVisitKinds = rule906 _lhsIallVisitKinds _tlOallchildvisit = rule907 _lhsIallchildvisit _tlOallintramap = rule908 _lhsIallintramap _tlOavisitdefs = rule909 _lhsIavisitdefs _tlOavisituses = rule910 _lhsIavisituses _tlOchildTypes = rule911 _lhsIchildTypes _tlOchildintros = rule912 _lhsIchildintros _tlOcon = rule913 _lhsIcon _tlOinhmap = rule914 _lhsIinhmap _tlOmrules = rule915 _lhsImrules _tlOnextVisits = rule916 _lhsInextVisits _tlOnt = rule917 _lhsInt _tlOoptions = rule918 _lhsIoptions _tlOparams = rule919 _lhsIparams _tlOprevVisits = rule920 _lhsIprevVisits _tlOruledefs = rule921 _lhsIruledefs _tlOruleuses = rule922 _lhsIruleuses _tlOsynmap = rule923 _lhsIsynmap _tlOterminaldefs = rule924 _lhsIterminaldefs __result_ = T_Visits_vOut55 _lhsOallvisits _lhsOchildvisit _lhsOerrors _lhsOfromToStates _lhsOintramap _lhsOlazyIntras _lhsOruleKinds _lhsOruleUsage _lhsOsem_visit _lhsOt_visits _lhsOusedArgs _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses in __result_ ) in C_Visits_s56 v55 {-# INLINE rule865 #-} rule865 = \ ((_hdIallvisits) :: VisitStateState ) ((_tlIallvisits) :: [VisitStateState]) -> _hdIallvisits : _tlIallvisits {-# INLINE rule866 #-} rule866 = \ ((_hdIchildvisit) :: Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) ((_tlIchildvisit) :: Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) -> _hdIchildvisit `Map.union` _tlIchildvisit {-# INLINE rule867 #-} rule867 = \ ((_hdIerrors) :: Seq Error) ((_tlIerrors) :: Seq Error) -> _hdIerrors Seq.>< _tlIerrors {-# INLINE rule868 #-} rule868 = \ ((_hdIfromToStates) :: Map VisitIdentifier (Int,Int)) ((_tlIfromToStates) :: Map VisitIdentifier (Int,Int)) -> _hdIfromToStates `mappend` _tlIfromToStates {-# INLINE rule869 #-} rule869 = \ ((_hdIintramap) :: Map StateIdentifier (Map String (Maybe NonLocalAttr))) ((_tlIintramap) :: Map StateIdentifier (Map String (Maybe NonLocalAttr))) -> _hdIintramap `uwMapUnion` _tlIintramap {-# INLINE rule870 #-} rule870 = \ ((_hdIlazyIntras) :: Set String) ((_tlIlazyIntras) :: Set String) -> _hdIlazyIntras `Set.union` _tlIlazyIntras {-# INLINE rule871 #-} rule871 = \ ((_hdIruleKinds) :: Map Identifier (Set VisitKind)) ((_tlIruleKinds) :: Map Identifier (Set VisitKind)) -> _hdIruleKinds `unionWithMappend` _tlIruleKinds {-# INLINE rule872 #-} rule872 = \ ((_hdIruleUsage) :: Map Identifier Int) ((_tlIruleUsage) :: Map Identifier Int) -> _hdIruleUsage `unionWithSum` _tlIruleUsage {-# INLINE rule873 #-} rule873 = \ ((_hdIsem_visit) :: (StateIdentifier,Bool -> PP_Doc) ) ((_tlIsem_visit) :: [(StateIdentifier,Bool -> PP_Doc)] ) -> _hdIsem_visit : _tlIsem_visit {-# INLINE rule874 #-} rule874 = \ ((_hdIt_visits) :: PP_Doc) ((_tlIt_visits) :: PP_Doc) -> _hdIt_visits >-< _tlIt_visits {-# INLINE rule875 #-} rule875 = \ ((_hdIusedArgs) :: Set String) ((_tlIusedArgs) :: Set String) -> _hdIusedArgs `Set.union` _tlIusedArgs {-# INLINE rule876 #-} rule876 = \ ((_hdIvisitKinds) :: Map VisitIdentifier VisitKind) ((_tlIvisitKinds) :: Map VisitIdentifier VisitKind) -> _hdIvisitKinds `mappend` _tlIvisitKinds {-# INLINE rule877 #-} rule877 = \ ((_hdIvisitdefs) :: Map VisitIdentifier (Set Identifier)) ((_tlIvisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _hdIvisitdefs `uwSetUnion` _tlIvisitdefs {-# INLINE rule878 #-} rule878 = \ ((_hdIvisituses) :: Map VisitIdentifier (Set Identifier)) ((_tlIvisituses) :: Map VisitIdentifier (Set Identifier)) -> _hdIvisituses `uwSetUnion` _tlIvisituses {-# INLINE rule879 #-} rule879 = \ ((_lhsIallFromToStates) :: Map VisitIdentifier (Int,Int)) -> _lhsIallFromToStates {-# INLINE rule880 #-} rule880 = \ ((_lhsIallInhmap) :: Map NontermIdent Attributes) -> _lhsIallInhmap {-# INLINE rule881 #-} rule881 = \ ((_lhsIallInitStates) :: Map NontermIdent Int) -> _lhsIallInitStates {-# INLINE rule882 #-} rule882 = \ ((_lhsIallSynmap) :: Map NontermIdent Attributes) -> _lhsIallSynmap {-# INLINE rule883 #-} rule883 = \ ((_lhsIallVisitKinds) :: Map VisitIdentifier VisitKind) -> _lhsIallVisitKinds {-# INLINE rule884 #-} rule884 = \ ((_lhsIallchildvisit) :: Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) -> _lhsIallchildvisit {-# INLINE rule885 #-} rule885 = \ ((_lhsIallintramap) :: Map StateIdentifier (Map String (Maybe NonLocalAttr))) -> _lhsIallintramap {-# INLINE rule886 #-} rule886 = \ ((_lhsIavisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisitdefs {-# INLINE rule887 #-} rule887 = \ ((_lhsIavisituses) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisituses {-# INLINE rule888 #-} rule888 = \ ((_lhsIchildTypes) :: Map Identifier Type) -> _lhsIchildTypes {-# INLINE rule889 #-} rule889 = \ ((_lhsIchildintros) :: Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))) -> _lhsIchildintros {-# INLINE rule890 #-} rule890 = \ ((_lhsIcon) :: ConstructorIdent) -> _lhsIcon {-# INLINE rule891 #-} rule891 = \ ((_lhsIinhmap) :: Attributes) -> _lhsIinhmap {-# INLINE rule892 #-} rule892 = \ ((_lhsImrules) :: Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)) -> _lhsImrules {-# INLINE rule893 #-} rule893 = \ ((_lhsInextVisits) :: Map StateIdentifier StateCtx) -> _lhsInextVisits {-# INLINE rule894 #-} rule894 = \ ((_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule895 #-} rule895 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule896 #-} rule896 = \ ((_lhsIparams) :: [Identifier]) -> _lhsIparams {-# INLINE rule897 #-} rule897 = \ ((_lhsIprevVisits) :: Map StateIdentifier StateCtx) -> _lhsIprevVisits {-# INLINE rule898 #-} rule898 = \ ((_lhsIruledefs) :: Map Identifier (Set String)) -> _lhsIruledefs {-# INLINE rule899 #-} rule899 = \ ((_lhsIruleuses) :: Map Identifier (Map String (Maybe NonLocalAttr))) -> _lhsIruleuses {-# INLINE rule900 #-} rule900 = \ ((_lhsIsynmap) :: Attributes) -> _lhsIsynmap {-# INLINE rule901 #-} rule901 = \ ((_lhsIterminaldefs) :: Set String) -> _lhsIterminaldefs {-# INLINE rule902 #-} rule902 = \ ((_lhsIallFromToStates) :: Map VisitIdentifier (Int,Int)) -> _lhsIallFromToStates {-# INLINE rule903 #-} rule903 = \ ((_lhsIallInhmap) :: Map NontermIdent Attributes) -> _lhsIallInhmap {-# INLINE rule904 #-} rule904 = \ ((_lhsIallInitStates) :: Map NontermIdent Int) -> _lhsIallInitStates {-# INLINE rule905 #-} rule905 = \ ((_lhsIallSynmap) :: Map NontermIdent Attributes) -> _lhsIallSynmap {-# INLINE rule906 #-} rule906 = \ ((_lhsIallVisitKinds) :: Map VisitIdentifier VisitKind) -> _lhsIallVisitKinds {-# INLINE rule907 #-} rule907 = \ ((_lhsIallchildvisit) :: Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))) -> _lhsIallchildvisit {-# INLINE rule908 #-} rule908 = \ ((_lhsIallintramap) :: Map StateIdentifier (Map String (Maybe NonLocalAttr))) -> _lhsIallintramap {-# INLINE rule909 #-} rule909 = \ ((_lhsIavisitdefs) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisitdefs {-# INLINE rule910 #-} rule910 = \ ((_lhsIavisituses) :: Map VisitIdentifier (Set Identifier)) -> _lhsIavisituses {-# INLINE rule911 #-} rule911 = \ ((_lhsIchildTypes) :: Map Identifier Type) -> _lhsIchildTypes {-# INLINE rule912 #-} rule912 = \ ((_lhsIchildintros) :: Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))) -> _lhsIchildintros {-# INLINE rule913 #-} rule913 = \ ((_lhsIcon) :: ConstructorIdent) -> _lhsIcon {-# INLINE rule914 #-} rule914 = \ ((_lhsIinhmap) :: Attributes) -> _lhsIinhmap {-# INLINE rule915 #-} rule915 = \ ((_lhsImrules) :: Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)) -> _lhsImrules {-# INLINE rule916 #-} rule916 = \ ((_lhsInextVisits) :: Map StateIdentifier StateCtx) -> _lhsInextVisits {-# INLINE rule917 #-} rule917 = \ ((_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule918 #-} rule918 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule919 #-} rule919 = \ ((_lhsIparams) :: [Identifier]) -> _lhsIparams {-# INLINE rule920 #-} rule920 = \ ((_lhsIprevVisits) :: Map StateIdentifier StateCtx) -> _lhsIprevVisits {-# INLINE rule921 #-} rule921 = \ ((_lhsIruledefs) :: Map Identifier (Set String)) -> _lhsIruledefs {-# INLINE rule922 #-} rule922 = \ ((_lhsIruleuses) :: Map Identifier (Map String (Maybe NonLocalAttr))) -> _lhsIruleuses {-# INLINE rule923 #-} rule923 = \ ((_lhsIsynmap) :: Attributes) -> _lhsIsynmap {-# INLINE rule924 #-} rule924 = \ ((_lhsIterminaldefs) :: Set String) -> _lhsIterminaldefs {-# NOINLINE sem_Visits_Nil #-} sem_Visits_Nil :: T_Visits sem_Visits_Nil = T_Visits (return st56) where {-# NOINLINE st56 #-} st56 = let v55 :: T_Visits_v55 v55 = \ (T_Visits_vIn55 _lhsIallFromToStates _lhsIallInhmap _lhsIallInitStates _lhsIallSynmap _lhsIallVisitKinds _lhsIallchildvisit _lhsIallintramap _lhsIavisitdefs _lhsIavisituses _lhsIchildTypes _lhsIchildintros _lhsIcon _lhsIinhmap _lhsImrules _lhsInextVisits _lhsInt _lhsIoptions _lhsIparams _lhsIprevVisits _lhsIruledefs _lhsIruleuses _lhsIsynmap _lhsIterminaldefs) -> ( let _lhsOallvisits :: [VisitStateState] _lhsOallvisits = rule925 () _lhsOchildvisit :: Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc)) _lhsOchildvisit = rule926 () _lhsOerrors :: Seq Error _lhsOerrors = rule927 () _lhsOfromToStates :: Map VisitIdentifier (Int,Int) _lhsOfromToStates = rule928 () _lhsOintramap :: Map StateIdentifier (Map String (Maybe NonLocalAttr)) _lhsOintramap = rule929 () _lhsOlazyIntras :: Set String _lhsOlazyIntras = rule930 () _lhsOruleKinds :: Map Identifier (Set VisitKind) _lhsOruleKinds = rule931 () _lhsOruleUsage :: Map Identifier Int _lhsOruleUsage = rule932 () _lhsOsem_visit :: [(StateIdentifier,Bool -> PP_Doc)] _lhsOsem_visit = rule933 () _lhsOt_visits :: PP_Doc _lhsOt_visits = rule934 () _lhsOusedArgs :: Set String _lhsOusedArgs = rule935 () _lhsOvisitKinds :: Map VisitIdentifier VisitKind _lhsOvisitKinds = rule936 () _lhsOvisitdefs :: Map VisitIdentifier (Set Identifier) _lhsOvisitdefs = rule937 () _lhsOvisituses :: Map VisitIdentifier (Set Identifier) _lhsOvisituses = rule938 () __result_ = T_Visits_vOut55 _lhsOallvisits _lhsOchildvisit _lhsOerrors _lhsOfromToStates _lhsOintramap _lhsOlazyIntras _lhsOruleKinds _lhsOruleUsage _lhsOsem_visit _lhsOt_visits _lhsOusedArgs _lhsOvisitKinds _lhsOvisitdefs _lhsOvisituses in __result_ ) in C_Visits_s56 v55 {-# INLINE rule925 #-} rule925 = \ (_ :: ()) -> [] {-# INLINE rule926 #-} rule926 = \ (_ :: ()) -> Map.empty {-# INLINE rule927 #-} rule927 = \ (_ :: ()) -> Seq.empty {-# INLINE rule928 #-} rule928 = \ (_ :: ()) -> mempty {-# INLINE rule929 #-} rule929 = \ (_ :: ()) -> Map.empty {-# INLINE rule930 #-} rule930 = \ (_ :: ()) -> Set.empty {-# INLINE rule931 #-} rule931 = \ (_ :: ()) -> Map.empty {-# INLINE rule932 #-} rule932 = \ (_ :: ()) -> Map.empty {-# INLINE rule933 #-} rule933 = \ (_ :: ()) -> [] {-# INLINE rule934 #-} rule934 = \ (_ :: ()) -> empty {-# INLINE rule935 #-} rule935 = \ (_ :: ()) -> Set.empty {-# INLINE rule936 #-} rule936 = \ (_ :: ()) -> mempty {-# INLINE rule937 #-} rule937 = \ (_ :: ()) -> Map.empty {-# INLINE rule938 #-} rule938 = \ (_ :: ()) -> Map.empty uuagc-0.9.42.3/src-generated/Expression.hs000644 000765 000024 00000000676 12127045231 022275 0ustar00jeroenbransenstaff000000 000000 -- UUAGC 0.9.42.3 (src-ag/Expression.ag) module Expression where {-# LINE 2 "./src-ag/Expression.ag" #-} import UU.Scanner.Position(Pos) import HsToken {-# LINE 10 "dist/build/Expression.hs" #-} -- Expression -------------------------------------------------- {- alternatives: alternative Expression: child pos : {Pos} child tks : {[HsToken]} -} data Expression = Expression (Pos) (([HsToken]))uuagc-0.9.42.3/src-generated/GenerateCode.hs000644 000765 000024 00001100600 12127045231 022450 0ustar00jeroenbransenstaff000000 000000 {-# LANGUAGE Rank2Types, GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} module GenerateCode where {-# LINE 2 "./src-ag/CodeSyntax.ag" #-} import Patterns import CommonTypes import Data.Map(Map) import Data.Set(Set) {-# LINE 12 "dist/build/GenerateCode.hs" #-} {-# LINE 2 "./src-ag/Patterns.ag" #-} -- Patterns.ag imports import UU.Scanner.Position(Pos) import CommonTypes (ConstructorIdent,Identifier) {-# LINE 19 "dist/build/GenerateCode.hs" #-} {-# LINE 2 "./src-ag/DeclBlocks.ag" #-} import Code (Decl,Expr) {-# LINE 24 "dist/build/GenerateCode.hs" #-} {-# LINE 9 "./src-ag/GenerateCode.ag" #-} 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) {-# LINE 52 "dist/build/GenerateCode.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 106 "./src-ag/GenerateCode.ag" #-} -- remove possible @v references in the types of a data type. cleanupArg :: String -> String cleanupArg s = case idEvalType (SimpleType s) of SimpleType s' -> s' _ -> error "Only SimpleType supported" {-# LINE 63 "dist/build/GenerateCode.hs" #-} {-# LINE 122 "./src-ag/GenerateCode.ag" #-} 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 {-# LINE 74 "dist/build/GenerateCode.hs" #-} {-# LINE 247 "./src-ag/GenerateCode.ag" #-} 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" {-# LINE 88 "dist/build/GenerateCode.hs" #-} {-# LINE 538 "./src-ag/GenerateCode.ag" #-} 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 {-# LINE 113 "dist/build/GenerateCode.hs" #-} {-# LINE 635 "./src-ag/GenerateCode.ag" #-} 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) {-# LINE 127 "dist/build/GenerateCode.hs" #-} {-# LINE 685 "./src-ag/GenerateCode.ag" #-} 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 {-# LINE 150 "dist/build/GenerateCode.hs" #-} {-# LINE 763 "./src-ag/GenerateCode.ag" #-} 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 :: (String -> String) -> Code.Type -> Code.Type evalType 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 (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) _ -> t replaceTok t = case t of AGLocal v p _ -> HsToken (replf $ getName v) p _ -> t idEvalType :: Code.Type -> Code.Type idEvalType = evalType id {-# LINE 189 "dist/build/GenerateCode.hs" #-} {-# LINE 888 "./src-ag/GenerateCode.ag" #-} -- 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 {-# LINE 198 "dist/build/GenerateCode.hs" #-} {-# LINE 909 "./src-ag/GenerateCode.ag" #-} 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 ) {-# LINE 210 "dist/build/GenerateCode.hs" #-} {-# LINE 943 "./src-ag/GenerateCode.ag" #-} -- 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 {-# LINE 257 "dist/build/GenerateCode.hs" #-} {-# LINE 1033 "./src-ag/GenerateCode.ag" #-} 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 {-# LINE 265 "dist/build/GenerateCode.hs" #-} -- CGrammar ---------------------------------------------------- -- wrapper data Inh_CGrammar = Inh_CGrammar { options_Inh_CGrammar :: (Options) } data Syn_CGrammar = Syn_CGrammar { errors_Syn_CGrammar :: (Seq Error), output_Syn_CGrammar :: (Program) } {-# INLINABLE wrap_CGrammar #-} wrap_CGrammar :: T_CGrammar -> Inh_CGrammar -> (Syn_CGrammar ) wrap_CGrammar (T_CGrammar act) (Inh_CGrammar _lhsIoptions) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_CGrammar_vIn1 _lhsIoptions (T_CGrammar_vOut1 _lhsOerrors _lhsOoutput) <- return (inv_CGrammar_s2 sem arg) return (Syn_CGrammar _lhsOerrors _lhsOoutput) ) -- cata {-# INLINE sem_CGrammar #-} sem_CGrammar :: CGrammar -> T_CGrammar sem_CGrammar ( CGrammar typeSyns_ derivings_ wrappers_ nonts_ pragmas_ paramMap_ contextMap_ quantMap_ aroundsMap_ mergeMap_ multivisit_ ) = sem_CGrammar_CGrammar typeSyns_ derivings_ wrappers_ ( sem_CNonterminals nonts_ ) pragmas_ paramMap_ contextMap_ quantMap_ aroundsMap_ mergeMap_ multivisit_ -- semantic domain newtype T_CGrammar = T_CGrammar { attach_T_CGrammar :: Identity (T_CGrammar_s2 ) } newtype T_CGrammar_s2 = C_CGrammar_s2 { inv_CGrammar_s2 :: (T_CGrammar_v1 ) } data T_CGrammar_s3 = C_CGrammar_s3 type T_CGrammar_v1 = (T_CGrammar_vIn1 ) -> (T_CGrammar_vOut1 ) data T_CGrammar_vIn1 = T_CGrammar_vIn1 (Options) data T_CGrammar_vOut1 = T_CGrammar_vOut1 (Seq Error) (Program) {-# NOINLINE sem_CGrammar_CGrammar #-} sem_CGrammar_CGrammar :: (TypeSyns) -> (Derivings) -> (Set NontermIdent) -> T_CNonterminals -> (PragmaMap) -> (ParamMap) -> (ContextMap) -> (QuantMap) -> (Map NontermIdent (Map ConstructorIdent (Set Identifier))) -> (Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))) -> (Bool) -> T_CGrammar sem_CGrammar_CGrammar arg_typeSyns_ arg_derivings_ arg_wrappers_ arg_nonts_ arg_pragmas_ arg_paramMap_ arg_contextMap_ arg_quantMap_ arg_aroundsMap_ arg_mergeMap_ arg_multivisit_ = T_CGrammar (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_CGrammar_v1 v1 = \ (T_CGrammar_vIn1 _lhsIoptions) -> ( let _nontsX11 = Control.Monad.Identity.runIdentity (attach_T_CNonterminals (arg_nonts_)) (T_CNonterminals_vOut10 _nontsIchunks _nontsIgathNts _nontsIsemDomUnfoldGath) = inv_CNonterminals_s11 _nontsX11 (T_CNonterminals_vIn10 _nontsOallNts _nontsOallPragmas _nontsOaroundMap _nontsOcontextMap _nontsOderivings _nontsOmergeMap _nontsOo_case _nontsOo_cata _nontsOo_costcentre _nontsOo_data _nontsOo_linePragmas _nontsOo_monadic _nontsOo_newtypes _nontsOo_pretty _nontsOo_rename _nontsOo_sem _nontsOo_sig _nontsOo_splitsems _nontsOo_strictwrap _nontsOo_traces _nontsOo_unbox _nontsOoptions _nontsOparamMap _nontsOprefix _nontsOquantMap _nontsOtypeSyns _nontsOunfoldSemDom _nontsOwith_sig _nontsOwrappers) _nontsOo_sig = rule0 _lhsIoptions _nontsOo_cata = rule1 _lhsIoptions _nontsOo_sem = rule2 _lhsIoptions _nontsOo_newtypes = rule3 _lhsIoptions _nontsOo_unbox = rule4 _lhsIoptions _nontsOo_case = rule5 _lhsIoptions _nontsOo_pretty = rule6 _lhsIoptions _nontsOo_rename = rule7 _lhsIoptions _nontsOo_strictwrap = rule8 _lhsIoptions _nontsOo_splitsems = rule9 _lhsIoptions _nontsOo_data = rule10 _lhsIoptions _nontsOprefix = rule11 _lhsIoptions _nontsOo_traces = rule12 _lhsIoptions _nontsOo_costcentre = rule13 _lhsIoptions _nontsOo_linePragmas = rule14 _lhsIoptions _nontsOo_monadic = rule15 _lhsIoptions _options = rule16 _lhsIoptions arg_multivisit_ _nontsOallPragmas = rule17 arg_pragmas_ _nontsOparamMap = rule18 arg_paramMap_ _nontsOcontextMap = rule19 arg_contextMap_ _nontsOquantMap = rule20 arg_quantMap_ _nontsOallNts = rule21 _nontsIgathNts _aroundMap = rule22 arg_aroundsMap_ _mergeMap = rule23 arg_mergeMap_ _unfoldSemDom = rule24 _nontsIsemDomUnfoldGath _nontsOwith_sig = rule25 _lhsIoptions _lhsOerrors :: Seq Error _lhsOerrors = rule26 () _lhsOoutput :: Program _lhsOoutput = rule27 _nontsIchunks arg_multivisit_ _nontsOtypeSyns = rule28 arg_typeSyns_ _nontsOderivings = rule29 arg_derivings_ _nontsOwrappers = rule30 arg_wrappers_ _nontsOaroundMap = rule31 _aroundMap _nontsOmergeMap = rule32 _mergeMap _nontsOoptions = rule33 _options _nontsOunfoldSemDom = rule34 _unfoldSemDom __result_ = T_CGrammar_vOut1 _lhsOerrors _lhsOoutput in __result_ ) in C_CGrammar_s2 v1 {-# INLINE rule0 #-} {-# LINE 52 "./src-ag/GenerateCode.ag" #-} rule0 = \ ((_lhsIoptions) :: Options) -> {-# LINE 52 "./src-ag/GenerateCode.ag" #-} typeSigs _lhsIoptions {-# LINE 350 "dist/build/GenerateCode.hs"#-} {-# INLINE rule1 #-} {-# LINE 53 "./src-ag/GenerateCode.ag" #-} rule1 = \ ((_lhsIoptions) :: Options) -> {-# LINE 53 "./src-ag/GenerateCode.ag" #-} folds _lhsIoptions {-# LINE 356 "dist/build/GenerateCode.hs"#-} {-# INLINE rule2 #-} {-# LINE 54 "./src-ag/GenerateCode.ag" #-} rule2 = \ ((_lhsIoptions) :: Options) -> {-# LINE 54 "./src-ag/GenerateCode.ag" #-} semfuns _lhsIoptions {-# LINE 362 "dist/build/GenerateCode.hs"#-} {-# INLINE rule3 #-} {-# LINE 55 "./src-ag/GenerateCode.ag" #-} rule3 = \ ((_lhsIoptions) :: Options) -> {-# LINE 55 "./src-ag/GenerateCode.ag" #-} newtypes _lhsIoptions {-# LINE 368 "dist/build/GenerateCode.hs"#-} {-# INLINE rule4 #-} {-# LINE 56 "./src-ag/GenerateCode.ag" #-} rule4 = \ ((_lhsIoptions) :: Options) -> {-# LINE 56 "./src-ag/GenerateCode.ag" #-} unbox _lhsIoptions {-# LINE 374 "dist/build/GenerateCode.hs"#-} {-# INLINE rule5 #-} {-# LINE 57 "./src-ag/GenerateCode.ag" #-} rule5 = \ ((_lhsIoptions) :: Options) -> {-# LINE 57 "./src-ag/GenerateCode.ag" #-} cases _lhsIoptions {-# LINE 380 "dist/build/GenerateCode.hs"#-} {-# INLINE rule6 #-} {-# LINE 58 "./src-ag/GenerateCode.ag" #-} rule6 = \ ((_lhsIoptions) :: Options) -> {-# LINE 58 "./src-ag/GenerateCode.ag" #-} attrInfo _lhsIoptions {-# LINE 386 "dist/build/GenerateCode.hs"#-} {-# INLINE rule7 #-} {-# LINE 59 "./src-ag/GenerateCode.ag" #-} rule7 = \ ((_lhsIoptions) :: Options) -> {-# LINE 59 "./src-ag/GenerateCode.ag" #-} rename _lhsIoptions {-# LINE 392 "dist/build/GenerateCode.hs"#-} {-# INLINE rule8 #-} {-# LINE 60 "./src-ag/GenerateCode.ag" #-} rule8 = \ ((_lhsIoptions) :: Options) -> {-# LINE 60 "./src-ag/GenerateCode.ag" #-} strictWrap _lhsIoptions {-# LINE 398 "dist/build/GenerateCode.hs"#-} {-# INLINE rule9 #-} {-# LINE 61 "./src-ag/GenerateCode.ag" #-} rule9 = \ ((_lhsIoptions) :: Options) -> {-# LINE 61 "./src-ag/GenerateCode.ag" #-} splitSems _lhsIoptions {-# LINE 404 "dist/build/GenerateCode.hs"#-} {-# INLINE rule10 #-} {-# LINE 62 "./src-ag/GenerateCode.ag" #-} rule10 = \ ((_lhsIoptions) :: Options) -> {-# LINE 62 "./src-ag/GenerateCode.ag" #-} if dataTypes _lhsIoptions then Just (strictData _lhsIoptions) else Nothing {-# LINE 410 "dist/build/GenerateCode.hs"#-} {-# INLINE rule11 #-} {-# LINE 63 "./src-ag/GenerateCode.ag" #-} rule11 = \ ((_lhsIoptions) :: Options) -> {-# LINE 63 "./src-ag/GenerateCode.ag" #-} prefix _lhsIoptions {-# LINE 416 "dist/build/GenerateCode.hs"#-} {-# INLINE rule12 #-} {-# LINE 64 "./src-ag/GenerateCode.ag" #-} rule12 = \ ((_lhsIoptions) :: Options) -> {-# LINE 64 "./src-ag/GenerateCode.ag" #-} genTraces _lhsIoptions {-# LINE 422 "dist/build/GenerateCode.hs"#-} {-# INLINE rule13 #-} {-# LINE 65 "./src-ag/GenerateCode.ag" #-} rule13 = \ ((_lhsIoptions) :: Options) -> {-# LINE 65 "./src-ag/GenerateCode.ag" #-} genCostCentres _lhsIoptions {-# LINE 428 "dist/build/GenerateCode.hs"#-} {-# INLINE rule14 #-} {-# LINE 66 "./src-ag/GenerateCode.ag" #-} rule14 = \ ((_lhsIoptions) :: Options) -> {-# LINE 66 "./src-ag/GenerateCode.ag" #-} genLinePragmas _lhsIoptions {-# LINE 434 "dist/build/GenerateCode.hs"#-} {-# INLINE rule15 #-} {-# LINE 67 "./src-ag/GenerateCode.ag" #-} rule15 = \ ((_lhsIoptions) :: Options) -> {-# LINE 67 "./src-ag/GenerateCode.ag" #-} monadic _lhsIoptions {-# LINE 440 "dist/build/GenerateCode.hs"#-} {-# INLINE rule16 #-} {-# LINE 70 "./src-ag/GenerateCode.ag" #-} rule16 = \ ((_lhsIoptions) :: Options) multivisit_ -> {-# LINE 70 "./src-ag/GenerateCode.ag" #-} _lhsIoptions { breadthFirst = breadthFirst _lhsIoptions && visit _lhsIoptions && cases _lhsIoptions && multivisit_ } {-# LINE 446 "dist/build/GenerateCode.hs"#-} {-# INLINE rule17 #-} {-# LINE 75 "./src-ag/GenerateCode.ag" #-} rule17 = \ pragmas_ -> {-# LINE 75 "./src-ag/GenerateCode.ag" #-} pragmas_ {-# LINE 452 "dist/build/GenerateCode.hs"#-} {-# INLINE rule18 #-} {-# LINE 97 "./src-ag/GenerateCode.ag" #-} rule18 = \ paramMap_ -> {-# LINE 97 "./src-ag/GenerateCode.ag" #-} paramMap_ {-# LINE 458 "dist/build/GenerateCode.hs"#-} {-# INLINE rule19 #-} {-# LINE 119 "./src-ag/GenerateCode.ag" #-} rule19 = \ contextMap_ -> {-# LINE 119 "./src-ag/GenerateCode.ag" #-} contextMap_ {-# LINE 464 "dist/build/GenerateCode.hs"#-} {-# INLINE rule20 #-} {-# LINE 120 "./src-ag/GenerateCode.ag" #-} rule20 = \ quantMap_ -> {-# LINE 120 "./src-ag/GenerateCode.ag" #-} quantMap_ {-# LINE 470 "dist/build/GenerateCode.hs"#-} {-# INLINE rule21 #-} {-# LINE 136 "./src-ag/GenerateCode.ag" #-} rule21 = \ ((_nontsIgathNts) :: Set NontermIdent) -> {-# LINE 136 "./src-ag/GenerateCode.ag" #-} _nontsIgathNts {-# LINE 476 "dist/build/GenerateCode.hs"#-} {-# INLINE rule22 #-} {-# LINE 584 "./src-ag/GenerateCode.ag" #-} rule22 = \ aroundsMap_ -> {-# LINE 584 "./src-ag/GenerateCode.ag" #-} aroundsMap_ {-# LINE 482 "dist/build/GenerateCode.hs"#-} {-# INLINE rule23 #-} {-# LINE 600 "./src-ag/GenerateCode.ag" #-} rule23 = \ mergeMap_ -> {-# LINE 600 "./src-ag/GenerateCode.ag" #-} mergeMap_ {-# LINE 488 "dist/build/GenerateCode.hs"#-} {-# INLINE rule24 #-} {-# LINE 757 "./src-ag/GenerateCode.ag" #-} rule24 = \ ((_nontsIsemDomUnfoldGath) :: Map (NontermIdent, Int) ([String], Code.Type)) -> {-# LINE 757 "./src-ag/GenerateCode.ag" #-} \nt nr repl -> let (params, tp) = Map.findWithDefault (error ("No such semantic domain: " ++ show nt)) (nt, nr) _nontsIsemDomUnfoldGath replMap = Map.fromList (zip params repl) replace k = Map.findWithDefault ('@':k) k replMap in evalType replace tp {-# LINE 498 "dist/build/GenerateCode.hs"#-} {-# INLINE rule25 #-} {-# LINE 857 "./src-ag/GenerateCode.ag" #-} rule25 = \ ((_lhsIoptions) :: Options) -> {-# LINE 857 "./src-ag/GenerateCode.ag" #-} typeSigs _lhsIoptions {-# LINE 504 "dist/build/GenerateCode.hs"#-} {-# INLINE rule26 #-} {-# LINE 860 "./src-ag/GenerateCode.ag" #-} rule26 = \ (_ :: ()) -> {-# LINE 860 "./src-ag/GenerateCode.ag" #-} Seq.empty {-# LINE 510 "dist/build/GenerateCode.hs"#-} {-# INLINE rule27 #-} {-# LINE 929 "./src-ag/GenerateCode.ag" #-} rule27 = \ ((_nontsIchunks) :: Chunks) multivisit_ -> {-# LINE 929 "./src-ag/GenerateCode.ag" #-} Program _nontsIchunks multivisit_ {-# LINE 516 "dist/build/GenerateCode.hs"#-} {-# INLINE rule28 #-} {-# LINE 997 "./src-ag/GenerateCode.ag" #-} rule28 = \ typeSyns_ -> {-# LINE 997 "./src-ag/GenerateCode.ag" #-} typeSyns_ {-# LINE 522 "dist/build/GenerateCode.hs"#-} {-# INLINE rule29 #-} {-# LINE 998 "./src-ag/GenerateCode.ag" #-} rule29 = \ derivings_ -> {-# LINE 998 "./src-ag/GenerateCode.ag" #-} derivings_ {-# LINE 528 "dist/build/GenerateCode.hs"#-} {-# INLINE rule30 #-} {-# LINE 999 "./src-ag/GenerateCode.ag" #-} rule30 = \ wrappers_ -> {-# LINE 999 "./src-ag/GenerateCode.ag" #-} wrappers_ {-# LINE 534 "dist/build/GenerateCode.hs"#-} {-# INLINE rule31 #-} rule31 = \ _aroundMap -> _aroundMap {-# INLINE rule32 #-} rule32 = \ _mergeMap -> _mergeMap {-# INLINE rule33 #-} rule33 = \ _options -> _options {-# INLINE rule34 #-} rule34 = \ _unfoldSemDom -> _unfoldSemDom -- CInterface -------------------------------------------------- -- wrapper data Inh_CInterface = Inh_CInterface { inh_Inh_CInterface :: (Attributes), nt_Inh_CInterface :: (NontermIdent), o_case_Inh_CInterface :: (Bool), o_cata_Inh_CInterface :: (Bool), o_costcentre_Inh_CInterface :: (Bool), o_data_Inh_CInterface :: (Maybe Bool), o_linePragmas_Inh_CInterface :: (Bool), o_monadic_Inh_CInterface :: (Bool), o_newtypes_Inh_CInterface :: (Bool), o_pretty_Inh_CInterface :: (Bool), o_rename_Inh_CInterface :: (Bool), o_sem_Inh_CInterface :: (Bool), o_sig_Inh_CInterface :: (Bool), o_splitsems_Inh_CInterface :: (Bool), o_strictwrap_Inh_CInterface :: (Bool), o_traces_Inh_CInterface :: (Bool), o_unbox_Inh_CInterface :: (Bool), options_Inh_CInterface :: (Options), paramMap_Inh_CInterface :: (ParamMap), prefix_Inh_CInterface :: (String), syn_Inh_CInterface :: (Attributes) } data Syn_CInterface = Syn_CInterface { comments_Syn_CInterface :: ([String]), semDom_Syn_CInterface :: ([Decl]), semDomUnfoldGath_Syn_CInterface :: (Map (NontermIdent, Int) ([String], Code.Type)), wrapDecls_Syn_CInterface :: (Decls) } {-# INLINABLE wrap_CInterface #-} wrap_CInterface :: T_CInterface -> Inh_CInterface -> (Syn_CInterface ) wrap_CInterface (T_CInterface act) (Inh_CInterface _lhsIinh _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIsyn) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_CInterface_vIn4 _lhsIinh _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIsyn (T_CInterface_vOut4 _lhsOcomments _lhsOsemDom _lhsOsemDomUnfoldGath _lhsOwrapDecls) <- return (inv_CInterface_s5 sem arg) return (Syn_CInterface _lhsOcomments _lhsOsemDom _lhsOsemDomUnfoldGath _lhsOwrapDecls) ) -- cata {-# INLINE sem_CInterface #-} sem_CInterface :: CInterface -> T_CInterface sem_CInterface ( CInterface seg_ ) = sem_CInterface_CInterface ( sem_CSegments seg_ ) -- semantic domain newtype T_CInterface = T_CInterface { attach_T_CInterface :: Identity (T_CInterface_s5 ) } newtype T_CInterface_s5 = C_CInterface_s5 { inv_CInterface_s5 :: (T_CInterface_v4 ) } data T_CInterface_s6 = C_CInterface_s6 type T_CInterface_v4 = (T_CInterface_vIn4 ) -> (T_CInterface_vOut4 ) data T_CInterface_vIn4 = T_CInterface_vIn4 (Attributes) (NontermIdent) (Bool) (Bool) (Bool) (Maybe Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Options) (ParamMap) (String) (Attributes) data T_CInterface_vOut4 = T_CInterface_vOut4 ([String]) ([Decl]) (Map (NontermIdent, Int) ([String], Code.Type)) (Decls) {-# NOINLINE sem_CInterface_CInterface #-} sem_CInterface_CInterface :: T_CSegments -> T_CInterface sem_CInterface_CInterface arg_seg_ = T_CInterface (return st5) where {-# NOINLINE st5 #-} st5 = let v4 :: T_CInterface_v4 v4 = \ (T_CInterface_vIn4 _lhsIinh _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIsyn) -> ( let _segX26 = Control.Monad.Identity.runIdentity (attach_T_CSegments (arg_seg_)) (T_CSegments_vOut25 _segIcomments _segIisNil _segIsemDom _segIsemDomUnfoldGath _segIwrapDecls) = inv_CSegments_s26 _segX26 (T_CSegments_vIn25 _segOinh _segOnr _segOnt _segOo_case _segOo_cata _segOo_costcentre _segOo_data _segOo_linePragmas _segOo_monadic _segOo_newtypes _segOo_pretty _segOo_rename _segOo_sem _segOo_sig _segOo_splitsems _segOo_strictwrap _segOo_traces _segOo_unbox _segOoptions _segOparamMap _segOprefix _segOsyn) _segOnr = rule35 () _lhsOsemDom :: [Decl] _lhsOsemDom = rule36 _segIsemDom _lhsOcomments :: [String] _lhsOcomments = rule37 _segIcomments _lhsOsemDomUnfoldGath :: Map (NontermIdent, Int) ([String], Code.Type) _lhsOsemDomUnfoldGath = rule38 _segIsemDomUnfoldGath _lhsOwrapDecls :: Decls _lhsOwrapDecls = rule39 _segIwrapDecls _segOinh = rule40 _lhsIinh _segOnt = rule41 _lhsInt _segOo_case = rule42 _lhsIo_case _segOo_cata = rule43 _lhsIo_cata _segOo_costcentre = rule44 _lhsIo_costcentre _segOo_data = rule45 _lhsIo_data _segOo_linePragmas = rule46 _lhsIo_linePragmas _segOo_monadic = rule47 _lhsIo_monadic _segOo_newtypes = rule48 _lhsIo_newtypes _segOo_pretty = rule49 _lhsIo_pretty _segOo_rename = rule50 _lhsIo_rename _segOo_sem = rule51 _lhsIo_sem _segOo_sig = rule52 _lhsIo_sig _segOo_splitsems = rule53 _lhsIo_splitsems _segOo_strictwrap = rule54 _lhsIo_strictwrap _segOo_traces = rule55 _lhsIo_traces _segOo_unbox = rule56 _lhsIo_unbox _segOoptions = rule57 _lhsIoptions _segOparamMap = rule58 _lhsIparamMap _segOprefix = rule59 _lhsIprefix _segOsyn = rule60 _lhsIsyn __result_ = T_CInterface_vOut4 _lhsOcomments _lhsOsemDom _lhsOsemDomUnfoldGath _lhsOwrapDecls in __result_ ) in C_CInterface_s5 v4 {-# INLINE rule35 #-} {-# LINE 285 "./src-ag/GenerateCode.ag" #-} rule35 = \ (_ :: ()) -> {-# LINE 285 "./src-ag/GenerateCode.ag" #-} 0 {-# LINE 625 "dist/build/GenerateCode.hs"#-} {-# INLINE rule36 #-} {-# LINE 714 "./src-ag/GenerateCode.ag" #-} rule36 = \ ((_segIsemDom) :: [Decl]) -> {-# LINE 714 "./src-ag/GenerateCode.ag" #-} Comment "semantic domain" : _segIsemDom {-# LINE 631 "dist/build/GenerateCode.hs"#-} {-# INLINE rule37 #-} rule37 = \ ((_segIcomments) :: [String]) -> _segIcomments {-# INLINE rule38 #-} rule38 = \ ((_segIsemDomUnfoldGath) :: Map (NontermIdent, Int) ([String], Code.Type)) -> _segIsemDomUnfoldGath {-# INLINE rule39 #-} rule39 = \ ((_segIwrapDecls) :: Decls) -> _segIwrapDecls {-# INLINE rule40 #-} rule40 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule41 #-} rule41 = \ ((_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule42 #-} rule42 = \ ((_lhsIo_case) :: Bool) -> _lhsIo_case {-# INLINE rule43 #-} rule43 = \ ((_lhsIo_cata) :: Bool) -> _lhsIo_cata {-# INLINE rule44 #-} rule44 = \ ((_lhsIo_costcentre) :: Bool) -> _lhsIo_costcentre {-# INLINE rule45 #-} rule45 = \ ((_lhsIo_data) :: Maybe Bool) -> _lhsIo_data {-# INLINE rule46 #-} rule46 = \ ((_lhsIo_linePragmas) :: Bool) -> _lhsIo_linePragmas {-# INLINE rule47 #-} rule47 = \ ((_lhsIo_monadic) :: Bool) -> _lhsIo_monadic {-# INLINE rule48 #-} rule48 = \ ((_lhsIo_newtypes) :: Bool) -> _lhsIo_newtypes {-# INLINE rule49 #-} rule49 = \ ((_lhsIo_pretty) :: Bool) -> _lhsIo_pretty {-# INLINE rule50 #-} rule50 = \ ((_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# INLINE rule51 #-} rule51 = \ ((_lhsIo_sem) :: Bool) -> _lhsIo_sem {-# INLINE rule52 #-} rule52 = \ ((_lhsIo_sig) :: Bool) -> _lhsIo_sig {-# INLINE rule53 #-} rule53 = \ ((_lhsIo_splitsems) :: Bool) -> _lhsIo_splitsems {-# INLINE rule54 #-} rule54 = \ ((_lhsIo_strictwrap) :: Bool) -> _lhsIo_strictwrap {-# INLINE rule55 #-} rule55 = \ ((_lhsIo_traces) :: Bool) -> _lhsIo_traces {-# INLINE rule56 #-} rule56 = \ ((_lhsIo_unbox) :: Bool) -> _lhsIo_unbox {-# INLINE rule57 #-} rule57 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule58 #-} rule58 = \ ((_lhsIparamMap) :: ParamMap) -> _lhsIparamMap {-# INLINE rule59 #-} rule59 = \ ((_lhsIprefix) :: String) -> _lhsIprefix {-# INLINE rule60 #-} rule60 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn -- CNonterminal ------------------------------------------------ -- wrapper data Inh_CNonterminal = Inh_CNonterminal { allNts_Inh_CNonterminal :: (Set NontermIdent), allPragmas_Inh_CNonterminal :: (PragmaMap), aroundMap_Inh_CNonterminal :: (Map NontermIdent (Map ConstructorIdent (Set Identifier))), contextMap_Inh_CNonterminal :: (ContextMap), derivings_Inh_CNonterminal :: (Derivings), mergeMap_Inh_CNonterminal :: (Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier])))), o_case_Inh_CNonterminal :: (Bool), o_cata_Inh_CNonterminal :: (Bool), o_costcentre_Inh_CNonterminal :: (Bool), o_data_Inh_CNonterminal :: (Maybe Bool), o_linePragmas_Inh_CNonterminal :: (Bool), o_monadic_Inh_CNonterminal :: (Bool), o_newtypes_Inh_CNonterminal :: (Bool), o_pretty_Inh_CNonterminal :: (Bool), o_rename_Inh_CNonterminal :: (Bool), o_sem_Inh_CNonterminal :: (Bool), o_sig_Inh_CNonterminal :: (Bool), o_splitsems_Inh_CNonterminal :: (Bool), o_strictwrap_Inh_CNonterminal :: (Bool), o_traces_Inh_CNonterminal :: (Bool), o_unbox_Inh_CNonterminal :: (Bool), options_Inh_CNonterminal :: (Options), paramMap_Inh_CNonterminal :: (ParamMap), prefix_Inh_CNonterminal :: (String), quantMap_Inh_CNonterminal :: (QuantMap), typeSyns_Inh_CNonterminal :: (TypeSyns), unfoldSemDom_Inh_CNonterminal :: (NontermIdent -> Int -> [String] -> Code.Type), with_sig_Inh_CNonterminal :: (Bool), wrappers_Inh_CNonterminal :: (Set NontermIdent) } data Syn_CNonterminal = Syn_CNonterminal { chunks_Syn_CNonterminal :: (Chunks), gathNts_Syn_CNonterminal :: (Set NontermIdent), semDomUnfoldGath_Syn_CNonterminal :: (Map (NontermIdent, Int) ([String], Code.Type)) } {-# INLINABLE wrap_CNonterminal #-} wrap_CNonterminal :: T_CNonterminal -> Inh_CNonterminal -> (Syn_CNonterminal ) wrap_CNonterminal (T_CNonterminal act) (Inh_CNonterminal _lhsIallNts _lhsIallPragmas _lhsIaroundMap _lhsIcontextMap _lhsIderivings _lhsImergeMap _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIquantMap _lhsItypeSyns _lhsIunfoldSemDom _lhsIwith_sig _lhsIwrappers) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_CNonterminal_vIn7 _lhsIallNts _lhsIallPragmas _lhsIaroundMap _lhsIcontextMap _lhsIderivings _lhsImergeMap _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIquantMap _lhsItypeSyns _lhsIunfoldSemDom _lhsIwith_sig _lhsIwrappers (T_CNonterminal_vOut7 _lhsOchunks _lhsOgathNts _lhsOsemDomUnfoldGath) <- return (inv_CNonterminal_s8 sem arg) return (Syn_CNonterminal _lhsOchunks _lhsOgathNts _lhsOsemDomUnfoldGath) ) -- cata {-# INLINE sem_CNonterminal #-} sem_CNonterminal :: CNonterminal -> T_CNonterminal sem_CNonterminal ( CNonterminal nt_ params_ inh_ syn_ prods_ inter_ ) = sem_CNonterminal_CNonterminal nt_ params_ inh_ syn_ ( sem_CProductions prods_ ) ( sem_CInterface inter_ ) -- semantic domain newtype T_CNonterminal = T_CNonterminal { attach_T_CNonterminal :: Identity (T_CNonterminal_s8 ) } newtype T_CNonterminal_s8 = C_CNonterminal_s8 { inv_CNonterminal_s8 :: (T_CNonterminal_v7 ) } data T_CNonterminal_s9 = C_CNonterminal_s9 type T_CNonterminal_v7 = (T_CNonterminal_vIn7 ) -> (T_CNonterminal_vOut7 ) data T_CNonterminal_vIn7 = T_CNonterminal_vIn7 (Set NontermIdent) (PragmaMap) (Map NontermIdent (Map ConstructorIdent (Set Identifier))) (ContextMap) (Derivings) (Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier])))) (Bool) (Bool) (Bool) (Maybe Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Options) (ParamMap) (String) (QuantMap) (TypeSyns) (NontermIdent -> Int -> [String] -> Code.Type) (Bool) (Set NontermIdent) data T_CNonterminal_vOut7 = T_CNonterminal_vOut7 (Chunks) (Set NontermIdent) (Map (NontermIdent, Int) ([String], Code.Type)) {-# NOINLINE sem_CNonterminal_CNonterminal #-} sem_CNonterminal_CNonterminal :: (NontermIdent) -> ([Identifier]) -> (Attributes) -> (Attributes) -> T_CProductions -> T_CInterface -> T_CNonterminal sem_CNonterminal_CNonterminal arg_nt_ arg_params_ arg_inh_ arg_syn_ arg_prods_ arg_inter_ = T_CNonterminal (return st8) where {-# NOINLINE st8 #-} st8 = let v7 :: T_CNonterminal_v7 v7 = \ (T_CNonterminal_vIn7 _lhsIallNts _lhsIallPragmas _lhsIaroundMap _lhsIcontextMap _lhsIderivings _lhsImergeMap _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIquantMap _lhsItypeSyns _lhsIunfoldSemDom _lhsIwith_sig _lhsIwrappers) -> ( let _prodsX17 = Control.Monad.Identity.runIdentity (attach_T_CProductions (arg_prods_)) _interX5 = Control.Monad.Identity.runIdentity (attach_T_CInterface (arg_inter_)) (T_CProductions_vOut16 _prodsIcataAlts _prodsIcomments _prodsIdataAlts _prodsIdecls _prodsIsemNames) = inv_CProductions_s17 _prodsX17 (T_CProductions_vIn16 _prodsOallNts _prodsOallPragmas _prodsOaroundMap _prodsOcontextMap _prodsOinh _prodsOmergeMap _prodsOnt _prodsOo_case _prodsOo_cata _prodsOo_costcentre _prodsOo_data _prodsOo_linePragmas _prodsOo_monadic _prodsOo_newtypes _prodsOo_pretty _prodsOo_rename _prodsOo_sem _prodsOo_sig _prodsOo_splitsems _prodsOo_strictwrap _prodsOo_traces _prodsOo_unbox _prodsOoptions _prodsOparamMap _prodsOprefix _prodsOquantMap _prodsOsyn _prodsOunfoldSemDom _prodsOwith_sig _prodsOwrappers) (T_CInterface_vOut4 _interIcomments _interIsemDom _interIsemDomUnfoldGath _interIwrapDecls) = inv_CInterface_s5 _interX5 (T_CInterface_vIn4 _interOinh _interOnt _interOo_case _interOo_cata _interOo_costcentre _interOo_data _interOo_linePragmas _interOo_monadic _interOo_newtypes _interOo_pretty _interOo_rename _interOo_sem _interOo_sig _interOo_splitsems _interOo_strictwrap _interOo_traces _interOo_unbox _interOoptions _interOparamMap _interOprefix _interOsyn) (_interOinh,_interOsyn,_interOnt) = rule61 arg_inh_ arg_nt_ arg_syn_ (_prodsOinh,_prodsOsyn,_prodsOnt) = rule62 arg_inh_ arg_nt_ arg_syn_ _lhsOgathNts :: Set NontermIdent _lhsOgathNts = rule63 arg_nt_ _aroundMap = rule64 _lhsIaroundMap arg_nt_ _mergeMap = rule65 _lhsImergeMap arg_nt_ _semWrapper = rule66 _interIwrapDecls _lhsIo_newtypes _lhsIo_strictwrap arg_inh_ arg_nt_ arg_params_ arg_syn_ _comment = rule67 _interIcomments _prodsIcomments _lhsOchunks :: Chunks _lhsOchunks = rule68 _cataFun _comment _dataDef _genCata _interIsemDom _lhsIo_cata _lhsIo_data _lhsIo_pretty _lhsIo_sem _lhsIo_sig _lhsIwrappers _prodsIdecls _prodsIsemNames _semWrapper arg_nt_ _dataDef = rule69 _lhsIderivings _lhsIo_data _lhsItypeSyns _prodsIdataAlts arg_nt_ arg_params_ _genCata = rule70 _lhsIoptions arg_nt_ _cataFun = rule71 _lhsIcontextMap _lhsIo_sig _lhsIprefix _lhsIquantMap _lhsItypeSyns _prodsIcataAlts arg_nt_ arg_params_ _lhsOsemDomUnfoldGath :: Map (NontermIdent, Int) ([String], Code.Type) _lhsOsemDomUnfoldGath = rule72 _interIsemDomUnfoldGath _prodsOallNts = rule73 _lhsIallNts _prodsOallPragmas = rule74 _lhsIallPragmas _prodsOaroundMap = rule75 _aroundMap _prodsOcontextMap = rule76 _lhsIcontextMap _prodsOmergeMap = rule77 _mergeMap _prodsOo_case = rule78 _lhsIo_case _prodsOo_cata = rule79 _lhsIo_cata _prodsOo_costcentre = rule80 _lhsIo_costcentre _prodsOo_data = rule81 _lhsIo_data _prodsOo_linePragmas = rule82 _lhsIo_linePragmas _prodsOo_monadic = rule83 _lhsIo_monadic _prodsOo_newtypes = rule84 _lhsIo_newtypes _prodsOo_pretty = rule85 _lhsIo_pretty _prodsOo_rename = rule86 _lhsIo_rename _prodsOo_sem = rule87 _lhsIo_sem _prodsOo_sig = rule88 _lhsIo_sig _prodsOo_splitsems = rule89 _lhsIo_splitsems _prodsOo_strictwrap = rule90 _lhsIo_strictwrap _prodsOo_traces = rule91 _lhsIo_traces _prodsOo_unbox = rule92 _lhsIo_unbox _prodsOoptions = rule93 _lhsIoptions _prodsOparamMap = rule94 _lhsIparamMap _prodsOprefix = rule95 _lhsIprefix _prodsOquantMap = rule96 _lhsIquantMap _prodsOunfoldSemDom = rule97 _lhsIunfoldSemDom _prodsOwith_sig = rule98 _lhsIwith_sig _prodsOwrappers = rule99 _lhsIwrappers _interOo_case = rule100 _lhsIo_case _interOo_cata = rule101 _lhsIo_cata _interOo_costcentre = rule102 _lhsIo_costcentre _interOo_data = rule103 _lhsIo_data _interOo_linePragmas = rule104 _lhsIo_linePragmas _interOo_monadic = rule105 _lhsIo_monadic _interOo_newtypes = rule106 _lhsIo_newtypes _interOo_pretty = rule107 _lhsIo_pretty _interOo_rename = rule108 _lhsIo_rename _interOo_sem = rule109 _lhsIo_sem _interOo_sig = rule110 _lhsIo_sig _interOo_splitsems = rule111 _lhsIo_splitsems _interOo_strictwrap = rule112 _lhsIo_strictwrap _interOo_traces = rule113 _lhsIo_traces _interOo_unbox = rule114 _lhsIo_unbox _interOoptions = rule115 _lhsIoptions _interOparamMap = rule116 _lhsIparamMap _interOprefix = rule117 _lhsIprefix __result_ = T_CNonterminal_vOut7 _lhsOchunks _lhsOgathNts _lhsOsemDomUnfoldGath in __result_ ) in C_CNonterminal_s8 v7 {-# INLINE rule61 #-} {-# LINE 85 "./src-ag/GenerateCode.ag" #-} rule61 = \ inh_ nt_ syn_ -> {-# LINE 85 "./src-ag/GenerateCode.ag" #-} (inh_,syn_,nt_) {-# LINE 814 "dist/build/GenerateCode.hs"#-} {-# INLINE rule62 #-} {-# LINE 86 "./src-ag/GenerateCode.ag" #-} rule62 = \ inh_ nt_ syn_ -> {-# LINE 86 "./src-ag/GenerateCode.ag" #-} (inh_,syn_,nt_) {-# LINE 820 "dist/build/GenerateCode.hs"#-} {-# INLINE rule63 #-} {-# LINE 142 "./src-ag/GenerateCode.ag" #-} rule63 = \ nt_ -> {-# LINE 142 "./src-ag/GenerateCode.ag" #-} Set.singleton nt_ {-# LINE 826 "dist/build/GenerateCode.hs"#-} {-# INLINE rule64 #-} {-# LINE 585 "./src-ag/GenerateCode.ag" #-} rule64 = \ ((_lhsIaroundMap) :: Map NontermIdent (Map ConstructorIdent (Set Identifier))) nt_ -> {-# LINE 585 "./src-ag/GenerateCode.ag" #-} Map.findWithDefault Map.empty nt_ _lhsIaroundMap {-# LINE 832 "dist/build/GenerateCode.hs"#-} {-# INLINE rule65 #-} {-# LINE 601 "./src-ag/GenerateCode.ag" #-} rule65 = \ ((_lhsImergeMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier])))) nt_ -> {-# LINE 601 "./src-ag/GenerateCode.ag" #-} Map.findWithDefault Map.empty nt_ _lhsImergeMap {-# LINE 838 "dist/build/GenerateCode.hs"#-} {-# INLINE rule66 #-} {-# LINE 806 "./src-ag/GenerateCode.ag" #-} rule66 = \ ((_interIwrapDecls) :: Decls) ((_lhsIo_newtypes) :: Bool) ((_lhsIo_strictwrap) :: Bool) inh_ nt_ params_ syn_ -> {-# LINE 806 "./src-ag/GenerateCode.ag" #-} let params' = map getName params_ inhAttrs = Map.toList inh_ synAttrs = Map.toList syn_ inhVars = [ SimpleExpr (attrname True _LHS a) | (a,_) <- inhAttrs ] synVars = [ SimpleExpr (attrname False _LHS a) | (a,_) <- synAttrs ] var = "sem" wrapNT = "wrap" ++ "_" ++ getName nt_ inhNT = "Inh" ++ "_" ++ getName nt_ synNT = "Syn" ++ "_" ++ getName nt_ varPat = if _lhsIo_newtypes then App (sdtype nt_) [SimpleExpr var] else SimpleExpr var evalTp | null params' = id | otherwise = idEvalType appParams nm = TypeApp (SimpleType nm) (map SimpleType params') typeSig = TSig wrapNT (evalTp $ appParams (sdtype nt_) `Arr` (appParams inhNT `Arr` appParams synNT)) mkstrict = Named _lhsIo_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 _interIwrapDecls (App synNT synVars)) Set.empty Set.empty ] {-# LINE 867 "dist/build/GenerateCode.hs"#-} {-# INLINE rule67 #-} {-# LINE 867 "./src-ag/GenerateCode.ag" #-} rule67 = \ ((_interIcomments) :: [String]) ((_prodsIcomments) :: [String]) -> {-# LINE 867 "./src-ag/GenerateCode.ag" #-} Comment . unlines . map ind $ ( _interIcomments ++ ("alternatives:" : map ind _prodsIcomments) ) {-# LINE 873 "dist/build/GenerateCode.hs"#-} {-# INLINE rule68 #-} {-# LINE 932 "./src-ag/GenerateCode.ag" #-} rule68 = \ _cataFun _comment _dataDef _genCata ((_interIsemDom) :: [Decl]) ((_lhsIo_cata) :: Bool) ((_lhsIo_data) :: Maybe Bool) ((_lhsIo_pretty) :: Bool) ((_lhsIo_sem) :: Bool) ((_lhsIo_sig) :: Bool) ((_lhsIwrappers) :: Set NontermIdent) ((_prodsIdecls) :: Decls) ((_prodsIsemNames) :: [String]) _semWrapper nt_ -> {-# LINE 932 "./src-ag/GenerateCode.ag" #-} [ Chunk (getName nt_) (Comment (getName nt_ ++ " " ++ replicate (60 - length (getName nt_)) '-')) (if _lhsIo_pretty then [_comment ] else []) (if isJust _lhsIo_data then [_dataDef ] else []) (if _lhsIo_cata && _genCata then _cataFun else []) (if _lhsIo_sig then _interIsemDom else []) (if nt_ `Set.member` _lhsIwrappers then _semWrapper else []) (if _lhsIo_sem then _prodsIdecls else []) (if _lhsIo_sem then _prodsIsemNames else []) ] {-# LINE 888 "dist/build/GenerateCode.hs"#-} {-# INLINE rule69 #-} {-# LINE 1002 "./src-ag/GenerateCode.ag" #-} rule69 = \ ((_lhsIderivings) :: Derivings) ((_lhsIo_data) :: Maybe Bool) ((_lhsItypeSyns) :: TypeSyns) ((_prodsIdataAlts) :: DataAlts) nt_ params_ -> {-# LINE 1002 "./src-ag/GenerateCode.ag" #-} 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 ] tp' -> error $ show tp' ++ " not supported" in Code.Type (getName nt_) params' (idEvalType theType) derivings = maybe [] (map getName . Set.toList) (Map.lookup nt_ _lhsIderivings) dataDef = Data (getName nt_) (map getName params_) _prodsIdataAlts (maybe False id _lhsIo_data) derivings in maybe dataDef typeSyn $ lookup nt_ _lhsItypeSyns {-# LINE 907 "dist/build/GenerateCode.hs"#-} {-# INLINE rule70 #-} {-# LINE 1045 "./src-ag/GenerateCode.ag" #-} rule70 = \ ((_lhsIoptions) :: Options) nt_ -> {-# LINE 1045 "./src-ag/GenerateCode.ag" #-} not (nt_ `Set.member` nocatas _lhsIoptions) {-# LINE 913 "dist/build/GenerateCode.hs"#-} {-# INLINE rule71 #-} {-# LINE 1046 "./src-ag/GenerateCode.ag" #-} rule71 = \ ((_lhsIcontextMap) :: ContextMap) ((_lhsIo_sig) :: Bool) ((_lhsIprefix) :: String) ((_lhsIquantMap) :: QuantMap) ((_lhsItypeSyns) :: TypeSyns) ((_prodsIcataAlts) :: Decls) nt_ params_ -> {-# LINE 1046 "./src-ag/GenerateCode.ag" #-} let appParams nm = TypeApp (SimpleType nm) (map SimpleType (map getName params_)) evalTp | null params_ = id | otherwise = idEvalType tSig = TSig (cataname _lhsIprefix nt_) (appQuant _lhsIquantMap nt_ $ appContext _lhsIcontextMap nt_ $ evalTp $ appParams (getName nt_) `Arr` appParams (sdtype nt_)) special typ = case typ of CommonTypes.List tp -> let cons = SimpleExpr (semname _lhsIprefix nt_ (identifier "Cons")) nil = SimpleExpr (semname _lhsIprefix nt_ (identifier "Nil" )) arg = SimpleExpr "list" rarg = case tp of NT t _ _ -> let t' = maybe t id (deforestedNt t) in SimpleExpr ("(Prelude.map " ++ (cataname _lhsIprefix t') ++ " list)") _ -> arg lhs = Fun (cataname _lhsIprefix nt_) [arg] rhs = (App "Prelude.foldr" [cons,nil,rarg]) in [Decl lhs rhs Set.empty Set.empty] CommonTypes.Maybe tp -> let just = semname _lhsIprefix nt_ (identifier "Just") nothing = semname _lhsIprefix nt_ (identifier "Nothing" ) arg = SimpleExpr "x" rarg = case tp of NT t _ _ -> let t' = maybe t id (deforestedNt t) in App (cataname _lhsIprefix t') [arg] _ -> arg lhs a = Fun (cataname _lhsIprefix 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 _lhsIprefix nt_ (identifier "Left") right = semname _lhsIprefix nt_ (identifier "Right" ) arg = SimpleExpr "x" rarg0 = case tp1 of NT t _ _ -> let t' = maybe t id (deforestedNt t) in App (cataname _lhsIprefix t') [arg] _ -> arg rarg1 = case tp2 of NT t _ _ -> let t' = maybe t id (deforestedNt t) in App (cataname _lhsIprefix t') [arg] _ -> arg lhs a = Fun (cataname _lhsIprefix 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 _lhsIprefix nt_ (identifier "Entry")) nil = SimpleExpr (semname _lhsIprefix 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 _lhsIprefix t', arg] _ -> arg lhs = Fun (cataname _lhsIprefix 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 _lhsIprefix nt_ (identifier "Entry")) nil = SimpleExpr (semname _lhsIprefix 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 _lhsIprefix t', arg] _ -> arg lhs = Fun (cataname _lhsIprefix nt_) [arg] rhs = App "Data.IntMap.foldWithKey" [entry,nil,rarg] in [Decl lhs rhs Set.empty Set.empty] CommonTypes.Tuple tps -> let con = semname _lhsIprefix 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 _lhsIprefix t') [n] _ -> n lhs = Fun (cataname _lhsIprefix nt_) [TupleExpr (map fst tps')] rhs = App con rargs in [Decl lhs rhs Set.empty Set.empty] _ -> error "TODO" in Comment "cata" : (if _lhsIo_sig then [tSig] else []) ++ maybe _prodsIcataAlts special (lookup nt_ _lhsItypeSyns) {-# LINE 1000 "dist/build/GenerateCode.hs"#-} {-# INLINE rule72 #-} rule72 = \ ((_interIsemDomUnfoldGath) :: Map (NontermIdent, Int) ([String], Code.Type)) -> _interIsemDomUnfoldGath {-# INLINE rule73 #-} rule73 = \ ((_lhsIallNts) :: Set NontermIdent) -> _lhsIallNts {-# INLINE rule74 #-} rule74 = \ ((_lhsIallPragmas) :: PragmaMap) -> _lhsIallPragmas {-# INLINE rule75 #-} rule75 = \ _aroundMap -> _aroundMap {-# INLINE rule76 #-} rule76 = \ ((_lhsIcontextMap) :: ContextMap) -> _lhsIcontextMap {-# INLINE rule77 #-} rule77 = \ _mergeMap -> _mergeMap {-# INLINE rule78 #-} rule78 = \ ((_lhsIo_case) :: Bool) -> _lhsIo_case {-# INLINE rule79 #-} rule79 = \ ((_lhsIo_cata) :: Bool) -> _lhsIo_cata {-# INLINE rule80 #-} rule80 = \ ((_lhsIo_costcentre) :: Bool) -> _lhsIo_costcentre {-# INLINE rule81 #-} rule81 = \ ((_lhsIo_data) :: Maybe Bool) -> _lhsIo_data {-# INLINE rule82 #-} rule82 = \ ((_lhsIo_linePragmas) :: Bool) -> _lhsIo_linePragmas {-# INLINE rule83 #-} rule83 = \ ((_lhsIo_monadic) :: Bool) -> _lhsIo_monadic {-# INLINE rule84 #-} rule84 = \ ((_lhsIo_newtypes) :: Bool) -> _lhsIo_newtypes {-# INLINE rule85 #-} rule85 = \ ((_lhsIo_pretty) :: Bool) -> _lhsIo_pretty {-# INLINE rule86 #-} rule86 = \ ((_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# INLINE rule87 #-} rule87 = \ ((_lhsIo_sem) :: Bool) -> _lhsIo_sem {-# INLINE rule88 #-} rule88 = \ ((_lhsIo_sig) :: Bool) -> _lhsIo_sig {-# INLINE rule89 #-} rule89 = \ ((_lhsIo_splitsems) :: Bool) -> _lhsIo_splitsems {-# INLINE rule90 #-} rule90 = \ ((_lhsIo_strictwrap) :: Bool) -> _lhsIo_strictwrap {-# INLINE rule91 #-} rule91 = \ ((_lhsIo_traces) :: Bool) -> _lhsIo_traces {-# INLINE rule92 #-} rule92 = \ ((_lhsIo_unbox) :: Bool) -> _lhsIo_unbox {-# INLINE rule93 #-} rule93 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule94 #-} rule94 = \ ((_lhsIparamMap) :: ParamMap) -> _lhsIparamMap {-# INLINE rule95 #-} rule95 = \ ((_lhsIprefix) :: String) -> _lhsIprefix {-# INLINE rule96 #-} rule96 = \ ((_lhsIquantMap) :: QuantMap) -> _lhsIquantMap {-# INLINE rule97 #-} rule97 = \ ((_lhsIunfoldSemDom) :: NontermIdent -> Int -> [String] -> Code.Type) -> _lhsIunfoldSemDom {-# INLINE rule98 #-} rule98 = \ ((_lhsIwith_sig) :: Bool) -> _lhsIwith_sig {-# INLINE rule99 #-} rule99 = \ ((_lhsIwrappers) :: Set NontermIdent) -> _lhsIwrappers {-# INLINE rule100 #-} rule100 = \ ((_lhsIo_case) :: Bool) -> _lhsIo_case {-# INLINE rule101 #-} rule101 = \ ((_lhsIo_cata) :: Bool) -> _lhsIo_cata {-# INLINE rule102 #-} rule102 = \ ((_lhsIo_costcentre) :: Bool) -> _lhsIo_costcentre {-# INLINE rule103 #-} rule103 = \ ((_lhsIo_data) :: Maybe Bool) -> _lhsIo_data {-# INLINE rule104 #-} rule104 = \ ((_lhsIo_linePragmas) :: Bool) -> _lhsIo_linePragmas {-# INLINE rule105 #-} rule105 = \ ((_lhsIo_monadic) :: Bool) -> _lhsIo_monadic {-# INLINE rule106 #-} rule106 = \ ((_lhsIo_newtypes) :: Bool) -> _lhsIo_newtypes {-# INLINE rule107 #-} rule107 = \ ((_lhsIo_pretty) :: Bool) -> _lhsIo_pretty {-# INLINE rule108 #-} rule108 = \ ((_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# INLINE rule109 #-} rule109 = \ ((_lhsIo_sem) :: Bool) -> _lhsIo_sem {-# INLINE rule110 #-} rule110 = \ ((_lhsIo_sig) :: Bool) -> _lhsIo_sig {-# INLINE rule111 #-} rule111 = \ ((_lhsIo_splitsems) :: Bool) -> _lhsIo_splitsems {-# INLINE rule112 #-} rule112 = \ ((_lhsIo_strictwrap) :: Bool) -> _lhsIo_strictwrap {-# INLINE rule113 #-} rule113 = \ ((_lhsIo_traces) :: Bool) -> _lhsIo_traces {-# INLINE rule114 #-} rule114 = \ ((_lhsIo_unbox) :: Bool) -> _lhsIo_unbox {-# INLINE rule115 #-} rule115 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule116 #-} rule116 = \ ((_lhsIparamMap) :: ParamMap) -> _lhsIparamMap {-# INLINE rule117 #-} rule117 = \ ((_lhsIprefix) :: String) -> _lhsIprefix -- CNonterminals ----------------------------------------------- -- wrapper data Inh_CNonterminals = Inh_CNonterminals { allNts_Inh_CNonterminals :: (Set NontermIdent), allPragmas_Inh_CNonterminals :: (PragmaMap), aroundMap_Inh_CNonterminals :: (Map NontermIdent (Map ConstructorIdent (Set Identifier))), contextMap_Inh_CNonterminals :: (ContextMap), derivings_Inh_CNonterminals :: (Derivings), mergeMap_Inh_CNonterminals :: (Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier])))), o_case_Inh_CNonterminals :: (Bool), o_cata_Inh_CNonterminals :: (Bool), o_costcentre_Inh_CNonterminals :: (Bool), o_data_Inh_CNonterminals :: (Maybe Bool), o_linePragmas_Inh_CNonterminals :: (Bool), o_monadic_Inh_CNonterminals :: (Bool), o_newtypes_Inh_CNonterminals :: (Bool), o_pretty_Inh_CNonterminals :: (Bool), o_rename_Inh_CNonterminals :: (Bool), o_sem_Inh_CNonterminals :: (Bool), o_sig_Inh_CNonterminals :: (Bool), o_splitsems_Inh_CNonterminals :: (Bool), o_strictwrap_Inh_CNonterminals :: (Bool), o_traces_Inh_CNonterminals :: (Bool), o_unbox_Inh_CNonterminals :: (Bool), options_Inh_CNonterminals :: (Options), paramMap_Inh_CNonterminals :: (ParamMap), prefix_Inh_CNonterminals :: (String), quantMap_Inh_CNonterminals :: (QuantMap), typeSyns_Inh_CNonterminals :: (TypeSyns), unfoldSemDom_Inh_CNonterminals :: (NontermIdent -> Int -> [String] -> Code.Type), with_sig_Inh_CNonterminals :: (Bool), wrappers_Inh_CNonterminals :: (Set NontermIdent) } data Syn_CNonterminals = Syn_CNonterminals { chunks_Syn_CNonterminals :: (Chunks), gathNts_Syn_CNonterminals :: (Set NontermIdent), semDomUnfoldGath_Syn_CNonterminals :: (Map (NontermIdent, Int) ([String], Code.Type)) } {-# INLINABLE wrap_CNonterminals #-} wrap_CNonterminals :: T_CNonterminals -> Inh_CNonterminals -> (Syn_CNonterminals ) wrap_CNonterminals (T_CNonterminals act) (Inh_CNonterminals _lhsIallNts _lhsIallPragmas _lhsIaroundMap _lhsIcontextMap _lhsIderivings _lhsImergeMap _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIquantMap _lhsItypeSyns _lhsIunfoldSemDom _lhsIwith_sig _lhsIwrappers) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_CNonterminals_vIn10 _lhsIallNts _lhsIallPragmas _lhsIaroundMap _lhsIcontextMap _lhsIderivings _lhsImergeMap _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIquantMap _lhsItypeSyns _lhsIunfoldSemDom _lhsIwith_sig _lhsIwrappers (T_CNonterminals_vOut10 _lhsOchunks _lhsOgathNts _lhsOsemDomUnfoldGath) <- return (inv_CNonterminals_s11 sem arg) return (Syn_CNonterminals _lhsOchunks _lhsOgathNts _lhsOsemDomUnfoldGath) ) -- cata {-# NOINLINE sem_CNonterminals #-} sem_CNonterminals :: CNonterminals -> T_CNonterminals sem_CNonterminals list = Prelude.foldr sem_CNonterminals_Cons sem_CNonterminals_Nil (Prelude.map sem_CNonterminal list) -- semantic domain newtype T_CNonterminals = T_CNonterminals { attach_T_CNonterminals :: Identity (T_CNonterminals_s11 ) } newtype T_CNonterminals_s11 = C_CNonterminals_s11 { inv_CNonterminals_s11 :: (T_CNonterminals_v10 ) } data T_CNonterminals_s12 = C_CNonterminals_s12 type T_CNonterminals_v10 = (T_CNonterminals_vIn10 ) -> (T_CNonterminals_vOut10 ) data T_CNonterminals_vIn10 = T_CNonterminals_vIn10 (Set NontermIdent) (PragmaMap) (Map NontermIdent (Map ConstructorIdent (Set Identifier))) (ContextMap) (Derivings) (Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier])))) (Bool) (Bool) (Bool) (Maybe Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Options) (ParamMap) (String) (QuantMap) (TypeSyns) (NontermIdent -> Int -> [String] -> Code.Type) (Bool) (Set NontermIdent) data T_CNonterminals_vOut10 = T_CNonterminals_vOut10 (Chunks) (Set NontermIdent) (Map (NontermIdent, Int) ([String], Code.Type)) {-# NOINLINE sem_CNonterminals_Cons #-} sem_CNonterminals_Cons :: T_CNonterminal -> T_CNonterminals -> T_CNonterminals sem_CNonterminals_Cons arg_hd_ arg_tl_ = T_CNonterminals (return st11) where {-# NOINLINE st11 #-} st11 = let v10 :: T_CNonterminals_v10 v10 = \ (T_CNonterminals_vIn10 _lhsIallNts _lhsIallPragmas _lhsIaroundMap _lhsIcontextMap _lhsIderivings _lhsImergeMap _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIquantMap _lhsItypeSyns _lhsIunfoldSemDom _lhsIwith_sig _lhsIwrappers) -> ( let _hdX8 = Control.Monad.Identity.runIdentity (attach_T_CNonterminal (arg_hd_)) _tlX11 = Control.Monad.Identity.runIdentity (attach_T_CNonterminals (arg_tl_)) (T_CNonterminal_vOut7 _hdIchunks _hdIgathNts _hdIsemDomUnfoldGath) = inv_CNonterminal_s8 _hdX8 (T_CNonterminal_vIn7 _hdOallNts _hdOallPragmas _hdOaroundMap _hdOcontextMap _hdOderivings _hdOmergeMap _hdOo_case _hdOo_cata _hdOo_costcentre _hdOo_data _hdOo_linePragmas _hdOo_monadic _hdOo_newtypes _hdOo_pretty _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_splitsems _hdOo_strictwrap _hdOo_traces _hdOo_unbox _hdOoptions _hdOparamMap _hdOprefix _hdOquantMap _hdOtypeSyns _hdOunfoldSemDom _hdOwith_sig _hdOwrappers) (T_CNonterminals_vOut10 _tlIchunks _tlIgathNts _tlIsemDomUnfoldGath) = inv_CNonterminals_s11 _tlX11 (T_CNonterminals_vIn10 _tlOallNts _tlOallPragmas _tlOaroundMap _tlOcontextMap _tlOderivings _tlOmergeMap _tlOo_case _tlOo_cata _tlOo_costcentre _tlOo_data _tlOo_linePragmas _tlOo_monadic _tlOo_newtypes _tlOo_pretty _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_splitsems _tlOo_strictwrap _tlOo_traces _tlOo_unbox _tlOoptions _tlOparamMap _tlOprefix _tlOquantMap _tlOtypeSyns _tlOunfoldSemDom _tlOwith_sig _tlOwrappers) _lhsOchunks :: Chunks _lhsOchunks = rule118 _hdIchunks _tlIchunks _lhsOgathNts :: Set NontermIdent _lhsOgathNts = rule119 _hdIgathNts _tlIgathNts _lhsOsemDomUnfoldGath :: Map (NontermIdent, Int) ([String], Code.Type) _lhsOsemDomUnfoldGath = rule120 _hdIsemDomUnfoldGath _tlIsemDomUnfoldGath _hdOallNts = rule121 _lhsIallNts _hdOallPragmas = rule122 _lhsIallPragmas _hdOaroundMap = rule123 _lhsIaroundMap _hdOcontextMap = rule124 _lhsIcontextMap _hdOderivings = rule125 _lhsIderivings _hdOmergeMap = rule126 _lhsImergeMap _hdOo_case = rule127 _lhsIo_case _hdOo_cata = rule128 _lhsIo_cata _hdOo_costcentre = rule129 _lhsIo_costcentre _hdOo_data = rule130 _lhsIo_data _hdOo_linePragmas = rule131 _lhsIo_linePragmas _hdOo_monadic = rule132 _lhsIo_monadic _hdOo_newtypes = rule133 _lhsIo_newtypes _hdOo_pretty = rule134 _lhsIo_pretty _hdOo_rename = rule135 _lhsIo_rename _hdOo_sem = rule136 _lhsIo_sem _hdOo_sig = rule137 _lhsIo_sig _hdOo_splitsems = rule138 _lhsIo_splitsems _hdOo_strictwrap = rule139 _lhsIo_strictwrap _hdOo_traces = rule140 _lhsIo_traces _hdOo_unbox = rule141 _lhsIo_unbox _hdOoptions = rule142 _lhsIoptions _hdOparamMap = rule143 _lhsIparamMap _hdOprefix = rule144 _lhsIprefix _hdOquantMap = rule145 _lhsIquantMap _hdOtypeSyns = rule146 _lhsItypeSyns _hdOunfoldSemDom = rule147 _lhsIunfoldSemDom _hdOwith_sig = rule148 _lhsIwith_sig _hdOwrappers = rule149 _lhsIwrappers _tlOallNts = rule150 _lhsIallNts _tlOallPragmas = rule151 _lhsIallPragmas _tlOaroundMap = rule152 _lhsIaroundMap _tlOcontextMap = rule153 _lhsIcontextMap _tlOderivings = rule154 _lhsIderivings _tlOmergeMap = rule155 _lhsImergeMap _tlOo_case = rule156 _lhsIo_case _tlOo_cata = rule157 _lhsIo_cata _tlOo_costcentre = rule158 _lhsIo_costcentre _tlOo_data = rule159 _lhsIo_data _tlOo_linePragmas = rule160 _lhsIo_linePragmas _tlOo_monadic = rule161 _lhsIo_monadic _tlOo_newtypes = rule162 _lhsIo_newtypes _tlOo_pretty = rule163 _lhsIo_pretty _tlOo_rename = rule164 _lhsIo_rename _tlOo_sem = rule165 _lhsIo_sem _tlOo_sig = rule166 _lhsIo_sig _tlOo_splitsems = rule167 _lhsIo_splitsems _tlOo_strictwrap = rule168 _lhsIo_strictwrap _tlOo_traces = rule169 _lhsIo_traces _tlOo_unbox = rule170 _lhsIo_unbox _tlOoptions = rule171 _lhsIoptions _tlOparamMap = rule172 _lhsIparamMap _tlOprefix = rule173 _lhsIprefix _tlOquantMap = rule174 _lhsIquantMap _tlOtypeSyns = rule175 _lhsItypeSyns _tlOunfoldSemDom = rule176 _lhsIunfoldSemDom _tlOwith_sig = rule177 _lhsIwith_sig _tlOwrappers = rule178 _lhsIwrappers __result_ = T_CNonterminals_vOut10 _lhsOchunks _lhsOgathNts _lhsOsemDomUnfoldGath in __result_ ) in C_CNonterminals_s11 v10 {-# INLINE rule118 #-} rule118 = \ ((_hdIchunks) :: Chunks) ((_tlIchunks) :: Chunks) -> _hdIchunks ++ _tlIchunks {-# INLINE rule119 #-} rule119 = \ ((_hdIgathNts) :: Set NontermIdent) ((_tlIgathNts) :: Set NontermIdent) -> _hdIgathNts `Set.union` _tlIgathNts {-# INLINE rule120 #-} rule120 = \ ((_hdIsemDomUnfoldGath) :: Map (NontermIdent, Int) ([String], Code.Type)) ((_tlIsemDomUnfoldGath) :: Map (NontermIdent, Int) ([String], Code.Type)) -> _hdIsemDomUnfoldGath `Map.union` _tlIsemDomUnfoldGath {-# INLINE rule121 #-} rule121 = \ ((_lhsIallNts) :: Set NontermIdent) -> _lhsIallNts {-# INLINE rule122 #-} rule122 = \ ((_lhsIallPragmas) :: PragmaMap) -> _lhsIallPragmas {-# INLINE rule123 #-} rule123 = \ ((_lhsIaroundMap) :: Map NontermIdent (Map ConstructorIdent (Set Identifier))) -> _lhsIaroundMap {-# INLINE rule124 #-} rule124 = \ ((_lhsIcontextMap) :: ContextMap) -> _lhsIcontextMap {-# INLINE rule125 #-} rule125 = \ ((_lhsIderivings) :: Derivings) -> _lhsIderivings {-# INLINE rule126 #-} rule126 = \ ((_lhsImergeMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier])))) -> _lhsImergeMap {-# INLINE rule127 #-} rule127 = \ ((_lhsIo_case) :: Bool) -> _lhsIo_case {-# INLINE rule128 #-} rule128 = \ ((_lhsIo_cata) :: Bool) -> _lhsIo_cata {-# INLINE rule129 #-} rule129 = \ ((_lhsIo_costcentre) :: Bool) -> _lhsIo_costcentre {-# INLINE rule130 #-} rule130 = \ ((_lhsIo_data) :: Maybe Bool) -> _lhsIo_data {-# INLINE rule131 #-} rule131 = \ ((_lhsIo_linePragmas) :: Bool) -> _lhsIo_linePragmas {-# INLINE rule132 #-} rule132 = \ ((_lhsIo_monadic) :: Bool) -> _lhsIo_monadic {-# INLINE rule133 #-} rule133 = \ ((_lhsIo_newtypes) :: Bool) -> _lhsIo_newtypes {-# INLINE rule134 #-} rule134 = \ ((_lhsIo_pretty) :: Bool) -> _lhsIo_pretty {-# INLINE rule135 #-} rule135 = \ ((_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# INLINE rule136 #-} rule136 = \ ((_lhsIo_sem) :: Bool) -> _lhsIo_sem {-# INLINE rule137 #-} rule137 = \ ((_lhsIo_sig) :: Bool) -> _lhsIo_sig {-# INLINE rule138 #-} rule138 = \ ((_lhsIo_splitsems) :: Bool) -> _lhsIo_splitsems {-# INLINE rule139 #-} rule139 = \ ((_lhsIo_strictwrap) :: Bool) -> _lhsIo_strictwrap {-# INLINE rule140 #-} rule140 = \ ((_lhsIo_traces) :: Bool) -> _lhsIo_traces {-# INLINE rule141 #-} rule141 = \ ((_lhsIo_unbox) :: Bool) -> _lhsIo_unbox {-# INLINE rule142 #-} rule142 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule143 #-} rule143 = \ ((_lhsIparamMap) :: ParamMap) -> _lhsIparamMap {-# INLINE rule144 #-} rule144 = \ ((_lhsIprefix) :: String) -> _lhsIprefix {-# INLINE rule145 #-} rule145 = \ ((_lhsIquantMap) :: QuantMap) -> _lhsIquantMap {-# INLINE rule146 #-} rule146 = \ ((_lhsItypeSyns) :: TypeSyns) -> _lhsItypeSyns {-# INLINE rule147 #-} rule147 = \ ((_lhsIunfoldSemDom) :: NontermIdent -> Int -> [String] -> Code.Type) -> _lhsIunfoldSemDom {-# INLINE rule148 #-} rule148 = \ ((_lhsIwith_sig) :: Bool) -> _lhsIwith_sig {-# INLINE rule149 #-} rule149 = \ ((_lhsIwrappers) :: Set NontermIdent) -> _lhsIwrappers {-# INLINE rule150 #-} rule150 = \ ((_lhsIallNts) :: Set NontermIdent) -> _lhsIallNts {-# INLINE rule151 #-} rule151 = \ ((_lhsIallPragmas) :: PragmaMap) -> _lhsIallPragmas {-# INLINE rule152 #-} rule152 = \ ((_lhsIaroundMap) :: Map NontermIdent (Map ConstructorIdent (Set Identifier))) -> _lhsIaroundMap {-# INLINE rule153 #-} rule153 = \ ((_lhsIcontextMap) :: ContextMap) -> _lhsIcontextMap {-# INLINE rule154 #-} rule154 = \ ((_lhsIderivings) :: Derivings) -> _lhsIderivings {-# INLINE rule155 #-} rule155 = \ ((_lhsImergeMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier])))) -> _lhsImergeMap {-# INLINE rule156 #-} rule156 = \ ((_lhsIo_case) :: Bool) -> _lhsIo_case {-# INLINE rule157 #-} rule157 = \ ((_lhsIo_cata) :: Bool) -> _lhsIo_cata {-# INLINE rule158 #-} rule158 = \ ((_lhsIo_costcentre) :: Bool) -> _lhsIo_costcentre {-# INLINE rule159 #-} rule159 = \ ((_lhsIo_data) :: Maybe Bool) -> _lhsIo_data {-# INLINE rule160 #-} rule160 = \ ((_lhsIo_linePragmas) :: Bool) -> _lhsIo_linePragmas {-# INLINE rule161 #-} rule161 = \ ((_lhsIo_monadic) :: Bool) -> _lhsIo_monadic {-# INLINE rule162 #-} rule162 = \ ((_lhsIo_newtypes) :: Bool) -> _lhsIo_newtypes {-# INLINE rule163 #-} rule163 = \ ((_lhsIo_pretty) :: Bool) -> _lhsIo_pretty {-# INLINE rule164 #-} rule164 = \ ((_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# INLINE rule165 #-} rule165 = \ ((_lhsIo_sem) :: Bool) -> _lhsIo_sem {-# INLINE rule166 #-} rule166 = \ ((_lhsIo_sig) :: Bool) -> _lhsIo_sig {-# INLINE rule167 #-} rule167 = \ ((_lhsIo_splitsems) :: Bool) -> _lhsIo_splitsems {-# INLINE rule168 #-} rule168 = \ ((_lhsIo_strictwrap) :: Bool) -> _lhsIo_strictwrap {-# INLINE rule169 #-} rule169 = \ ((_lhsIo_traces) :: Bool) -> _lhsIo_traces {-# INLINE rule170 #-} rule170 = \ ((_lhsIo_unbox) :: Bool) -> _lhsIo_unbox {-# INLINE rule171 #-} rule171 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule172 #-} rule172 = \ ((_lhsIparamMap) :: ParamMap) -> _lhsIparamMap {-# INLINE rule173 #-} rule173 = \ ((_lhsIprefix) :: String) -> _lhsIprefix {-# INLINE rule174 #-} rule174 = \ ((_lhsIquantMap) :: QuantMap) -> _lhsIquantMap {-# INLINE rule175 #-} rule175 = \ ((_lhsItypeSyns) :: TypeSyns) -> _lhsItypeSyns {-# INLINE rule176 #-} rule176 = \ ((_lhsIunfoldSemDom) :: NontermIdent -> Int -> [String] -> Code.Type) -> _lhsIunfoldSemDom {-# INLINE rule177 #-} rule177 = \ ((_lhsIwith_sig) :: Bool) -> _lhsIwith_sig {-# INLINE rule178 #-} rule178 = \ ((_lhsIwrappers) :: Set NontermIdent) -> _lhsIwrappers {-# NOINLINE sem_CNonterminals_Nil #-} sem_CNonterminals_Nil :: T_CNonterminals sem_CNonterminals_Nil = T_CNonterminals (return st11) where {-# NOINLINE st11 #-} st11 = let v10 :: T_CNonterminals_v10 v10 = \ (T_CNonterminals_vIn10 _lhsIallNts _lhsIallPragmas _lhsIaroundMap _lhsIcontextMap _lhsIderivings _lhsImergeMap _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIquantMap _lhsItypeSyns _lhsIunfoldSemDom _lhsIwith_sig _lhsIwrappers) -> ( let _lhsOchunks :: Chunks _lhsOchunks = rule179 () _lhsOgathNts :: Set NontermIdent _lhsOgathNts = rule180 () _lhsOsemDomUnfoldGath :: Map (NontermIdent, Int) ([String], Code.Type) _lhsOsemDomUnfoldGath = rule181 () __result_ = T_CNonterminals_vOut10 _lhsOchunks _lhsOgathNts _lhsOsemDomUnfoldGath in __result_ ) in C_CNonterminals_s11 v10 {-# INLINE rule179 #-} rule179 = \ (_ :: ()) -> [] {-# INLINE rule180 #-} rule180 = \ (_ :: ()) -> Set.empty {-# INLINE rule181 #-} rule181 = \ (_ :: ()) -> Map.empty -- CProduction ------------------------------------------------- -- wrapper data Inh_CProduction = Inh_CProduction { allNts_Inh_CProduction :: (Set NontermIdent), allPragmas_Inh_CProduction :: (PragmaMap), aroundMap_Inh_CProduction :: (Map ConstructorIdent (Set Identifier)), contextMap_Inh_CProduction :: (ContextMap), inh_Inh_CProduction :: (Attributes), mergeMap_Inh_CProduction :: (Map ConstructorIdent (Map Identifier (Identifier, [Identifier]))), nt_Inh_CProduction :: (NontermIdent), o_case_Inh_CProduction :: (Bool), o_cata_Inh_CProduction :: (Bool), o_costcentre_Inh_CProduction :: (Bool), o_data_Inh_CProduction :: (Maybe Bool), o_linePragmas_Inh_CProduction :: (Bool), o_monadic_Inh_CProduction :: (Bool), o_newtypes_Inh_CProduction :: (Bool), o_pretty_Inh_CProduction :: (Bool), o_rename_Inh_CProduction :: (Bool), o_sem_Inh_CProduction :: (Bool), o_sig_Inh_CProduction :: (Bool), o_splitsems_Inh_CProduction :: (Bool), o_strictwrap_Inh_CProduction :: (Bool), o_traces_Inh_CProduction :: (Bool), o_unbox_Inh_CProduction :: (Bool), options_Inh_CProduction :: (Options), paramMap_Inh_CProduction :: (ParamMap), prefix_Inh_CProduction :: (String), quantMap_Inh_CProduction :: (QuantMap), syn_Inh_CProduction :: (Attributes), unfoldSemDom_Inh_CProduction :: (NontermIdent -> Int -> [String] -> Code.Type), with_sig_Inh_CProduction :: (Bool), wrappers_Inh_CProduction :: (Set NontermIdent) } data Syn_CProduction = Syn_CProduction { cataAlt_Syn_CProduction :: (Decl), comments_Syn_CProduction :: ([String]), dataAlt_Syn_CProduction :: (DataAlt), decls_Syn_CProduction :: (Decls), semNames_Syn_CProduction :: ([String]) } {-# INLINABLE wrap_CProduction #-} wrap_CProduction :: T_CProduction -> Inh_CProduction -> (Syn_CProduction ) wrap_CProduction (T_CProduction act) (Inh_CProduction _lhsIallNts _lhsIallPragmas _lhsIaroundMap _lhsIcontextMap _lhsIinh _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIquantMap _lhsIsyn _lhsIunfoldSemDom _lhsIwith_sig _lhsIwrappers) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_CProduction_vIn13 _lhsIallNts _lhsIallPragmas _lhsIaroundMap _lhsIcontextMap _lhsIinh _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIquantMap _lhsIsyn _lhsIunfoldSemDom _lhsIwith_sig _lhsIwrappers (T_CProduction_vOut13 _lhsOcataAlt _lhsOcomments _lhsOdataAlt _lhsOdecls _lhsOsemNames) <- return (inv_CProduction_s14 sem arg) return (Syn_CProduction _lhsOcataAlt _lhsOcomments _lhsOdataAlt _lhsOdecls _lhsOsemNames) ) -- cata {-# INLINE sem_CProduction #-} sem_CProduction :: CProduction -> T_CProduction sem_CProduction ( CProduction con_ visits_ children_ terminals_ ) = sem_CProduction_CProduction con_ ( sem_CVisits visits_ ) children_ terminals_ -- semantic domain newtype T_CProduction = T_CProduction { attach_T_CProduction :: Identity (T_CProduction_s14 ) } newtype T_CProduction_s14 = C_CProduction_s14 { inv_CProduction_s14 :: (T_CProduction_v13 ) } data T_CProduction_s15 = C_CProduction_s15 type T_CProduction_v13 = (T_CProduction_vIn13 ) -> (T_CProduction_vOut13 ) data T_CProduction_vIn13 = T_CProduction_vIn13 (Set NontermIdent) (PragmaMap) (Map ConstructorIdent (Set Identifier)) (ContextMap) (Attributes) (Map ConstructorIdent (Map Identifier (Identifier, [Identifier]))) (NontermIdent) (Bool) (Bool) (Bool) (Maybe Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Options) (ParamMap) (String) (QuantMap) (Attributes) (NontermIdent -> Int -> [String] -> Code.Type) (Bool) (Set NontermIdent) data T_CProduction_vOut13 = T_CProduction_vOut13 (Decl) ([String]) (DataAlt) (Decls) ([String]) {-# NOINLINE sem_CProduction_CProduction #-} sem_CProduction_CProduction :: (ConstructorIdent) -> T_CVisits -> ([(Identifier,Type,ChildKind)]) -> ([Identifier]) -> T_CProduction sem_CProduction_CProduction arg_con_ arg_visits_ arg_children_ arg_terminals_ = T_CProduction (return st14) where {-# NOINLINE st14 #-} st14 = let v13 :: T_CProduction_v13 v13 = \ (T_CProduction_vIn13 _lhsIallNts _lhsIallPragmas _lhsIaroundMap _lhsIcontextMap _lhsIinh _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIquantMap _lhsIsyn _lhsIunfoldSemDom _lhsIwith_sig _lhsIwrappers) -> ( let _visitsX32 = Control.Monad.Identity.runIdentity (attach_T_CVisits (arg_visits_)) (T_CVisits_vOut31 _visitsIcomments _visitsIdecls _visitsIgatherInstVisitNrs _visitsIintra _visitsIintraVars _visitsIisNil _visitsIsemNames _visitsIvisitedSet) = inv_CVisits_s32 _visitsX32 (T_CVisits_vIn31 _visitsOallNts _visitsOallPragmas _visitsOaroundMap _visitsOchildren _visitsOcon _visitsOcontextMap _visitsOinh _visitsOinstVisitNrs _visitsOmergeMap _visitsOnr _visitsOnt _visitsOo_case _visitsOo_cata _visitsOo_costcentre _visitsOo_data _visitsOo_linePragmas _visitsOo_monadic _visitsOo_newtypes _visitsOo_pretty _visitsOo_rename _visitsOo_sem _visitsOo_sig _visitsOo_splitsems _visitsOo_strictwrap _visitsOo_traces _visitsOo_unbox _visitsOoptions _visitsOparamInstMap _visitsOparamMap _visitsOprefix _visitsOquantMap _visitsOsyn _visitsOterminals _visitsOunfoldSemDom _visitsOvisitedSet _visitsOwith_sig _visitsOwrappers) _visitsOcon = rule182 arg_con_ _visitsOterminals = rule183 arg_terminals_ _paramInstMap = rule184 arg_children_ _visitsOvisitedSet = rule185 () _visitsOnr = rule186 () _visitsOchildren = rule187 arg_children_ _visitsOinstVisitNrs = rule188 _visitsIgatherInstVisitNrs _aroundMap = rule189 _lhsIaroundMap arg_con_ _mergeMap = rule190 _lhsImergeMap arg_con_ _firstOrderChildren = rule191 arg_children_ _lhsOcomments :: [String] _lhsOcomments = rule192 _firstOrderChildren _visitsIcomments arg_con_ _params = rule193 _lhsInt _lhsIparamMap _lhsOdataAlt :: DataAlt _lhsOdataAlt = rule194 _firstOrderChildren _lhsInt _lhsIo_rename _lhsIoptions _params arg_con_ _lhsOcataAlt :: Decl _lhsOcataAlt = rule195 _firstOrderChildren _lhsInt _lhsIo_rename _lhsIprefix arg_con_ _lhsOdecls :: Decls _lhsOdecls = rule196 _visitsIdecls _lhsOsemNames :: [String] _lhsOsemNames = rule197 _visitsIsemNames _visitsOallNts = rule198 _lhsIallNts _visitsOallPragmas = rule199 _lhsIallPragmas _visitsOaroundMap = rule200 _aroundMap _visitsOcontextMap = rule201 _lhsIcontextMap _visitsOinh = rule202 _lhsIinh _visitsOmergeMap = rule203 _mergeMap _visitsOnt = rule204 _lhsInt _visitsOo_case = rule205 _lhsIo_case _visitsOo_cata = rule206 _lhsIo_cata _visitsOo_costcentre = rule207 _lhsIo_costcentre _visitsOo_data = rule208 _lhsIo_data _visitsOo_linePragmas = rule209 _lhsIo_linePragmas _visitsOo_monadic = rule210 _lhsIo_monadic _visitsOo_newtypes = rule211 _lhsIo_newtypes _visitsOo_pretty = rule212 _lhsIo_pretty _visitsOo_rename = rule213 _lhsIo_rename _visitsOo_sem = rule214 _lhsIo_sem _visitsOo_sig = rule215 _lhsIo_sig _visitsOo_splitsems = rule216 _lhsIo_splitsems _visitsOo_strictwrap = rule217 _lhsIo_strictwrap _visitsOo_traces = rule218 _lhsIo_traces _visitsOo_unbox = rule219 _lhsIo_unbox _visitsOoptions = rule220 _lhsIoptions _visitsOparamInstMap = rule221 _paramInstMap _visitsOparamMap = rule222 _lhsIparamMap _visitsOprefix = rule223 _lhsIprefix _visitsOquantMap = rule224 _lhsIquantMap _visitsOsyn = rule225 _lhsIsyn _visitsOunfoldSemDom = rule226 _lhsIunfoldSemDom _visitsOwith_sig = rule227 _lhsIwith_sig _visitsOwrappers = rule228 _lhsIwrappers __result_ = T_CProduction_vOut13 _lhsOcataAlt _lhsOcomments _lhsOdataAlt _lhsOdecls _lhsOsemNames in __result_ ) in C_CProduction_s14 v13 {-# INLINE rule182 #-} {-# LINE 91 "./src-ag/GenerateCode.ag" #-} rule182 = \ con_ -> {-# LINE 91 "./src-ag/GenerateCode.ag" #-} con_ {-# LINE 1556 "dist/build/GenerateCode.hs"#-} {-# INLINE rule183 #-} {-# LINE 92 "./src-ag/GenerateCode.ag" #-} rule183 = \ terminals_ -> {-# LINE 92 "./src-ag/GenerateCode.ag" #-} terminals_ {-# LINE 1562 "dist/build/GenerateCode.hs"#-} {-# INLINE rule184 #-} {-# LINE 104 "./src-ag/GenerateCode.ag" #-} rule184 = \ children_ -> {-# LINE 104 "./src-ag/GenerateCode.ag" #-} Map.fromList [(nm, (extractNonterminal tp, tps)) | (nm,tp,_) <- children_, let tps = map cleanupArg $ nontermArgs tp, not (null tps) ] {-# LINE 1568 "dist/build/GenerateCode.hs"#-} {-# INLINE rule185 #-} {-# LINE 146 "./src-ag/GenerateCode.ag" #-} rule185 = \ (_ :: ()) -> {-# LINE 146 "./src-ag/GenerateCode.ag" #-} Set.empty {-# LINE 1574 "dist/build/GenerateCode.hs"#-} {-# INLINE rule186 #-} {-# LINE 281 "./src-ag/GenerateCode.ag" #-} rule186 = \ (_ :: ()) -> {-# LINE 281 "./src-ag/GenerateCode.ag" #-} 0 {-# LINE 1580 "dist/build/GenerateCode.hs"#-} {-# INLINE rule187 #-} {-# LINE 413 "./src-ag/GenerateCode.ag" #-} rule187 = \ children_ -> {-# LINE 413 "./src-ag/GenerateCode.ag" #-} children_ {-# LINE 1586 "dist/build/GenerateCode.hs"#-} {-# INLINE rule188 #-} {-# LINE 566 "./src-ag/GenerateCode.ag" #-} rule188 = \ ((_visitsIgatherInstVisitNrs) :: Map Identifier Int) -> {-# LINE 566 "./src-ag/GenerateCode.ag" #-} _visitsIgatherInstVisitNrs {-# LINE 1592 "dist/build/GenerateCode.hs"#-} {-# INLINE rule189 #-} {-# LINE 586 "./src-ag/GenerateCode.ag" #-} rule189 = \ ((_lhsIaroundMap) :: Map ConstructorIdent (Set Identifier)) con_ -> {-# LINE 586 "./src-ag/GenerateCode.ag" #-} Map.findWithDefault Set.empty con_ _lhsIaroundMap {-# LINE 1598 "dist/build/GenerateCode.hs"#-} {-# INLINE rule190 #-} {-# LINE 602 "./src-ag/GenerateCode.ag" #-} rule190 = \ ((_lhsImergeMap) :: Map ConstructorIdent (Map Identifier (Identifier, [Identifier]))) con_ -> {-# LINE 602 "./src-ag/GenerateCode.ag" #-} Map.findWithDefault Map.empty con_ _lhsImergeMap {-# LINE 1604 "dist/build/GenerateCode.hs"#-} {-# INLINE rule191 #-} {-# LINE 882 "./src-ag/GenerateCode.ag" #-} rule191 = \ children_ -> {-# LINE 882 "./src-ag/GenerateCode.ag" #-} [ (nm,fromJust mb,virt) | (nm,tp,virt) <- children_, let mb = isFirstOrder virt tp, isJust mb ] {-# LINE 1610 "dist/build/GenerateCode.hs"#-} {-# INLINE rule192 #-} {-# LINE 883 "./src-ag/GenerateCode.ag" #-} rule192 = \ _firstOrderChildren ((_visitsIcomments) :: [String]) con_ -> {-# LINE 883 "./src-ag/GenerateCode.ag" #-} ("alternative " ++ getName con_ ++ ":") : map ind ( map (\(x,y,_) -> makeLocalComment 14 "child" x (Just y)) _firstOrderChildren ++ _visitsIcomments ) {-# LINE 1619 "dist/build/GenerateCode.hs"#-} {-# INLINE rule193 #-} {-# LINE 1025 "./src-ag/GenerateCode.ag" #-} rule193 = \ ((_lhsInt) :: NontermIdent) ((_lhsIparamMap) :: ParamMap) -> {-# LINE 1025 "./src-ag/GenerateCode.ag" #-} map getName $ Map.findWithDefault [] _lhsInt _lhsIparamMap {-# LINE 1625 "dist/build/GenerateCode.hs"#-} {-# INLINE rule194 #-} {-# LINE 1026 "./src-ag/GenerateCode.ag" #-} rule194 = \ _firstOrderChildren ((_lhsInt) :: NontermIdent) ((_lhsIo_rename) :: Bool) ((_lhsIoptions) :: Options) _params con_ -> {-# LINE 1026 "./src-ag/GenerateCode.ag" #-} let conNm = conname _lhsIo_rename _lhsInt con_ mkFields :: (NontermIdent -> ConstructorIdent -> Identifier -> Code.Type -> a) -> [a] mkFields f = map (\(nm,t,_) -> f _lhsInt con_ nm (typeToCodeType (Just _lhsInt) _params $ removeDeforested t)) _firstOrderChildren in if dataRecords _lhsIoptions then Record conNm $ mkFields $ toNamedType (strictData _lhsIoptions) else DataAlt conNm $ mkFields $ \_ _ _ t -> t {-# LINE 1636 "dist/build/GenerateCode.hs"#-} {-# INLINE rule195 #-} {-# LINE 1139 "./src-ag/GenerateCode.ag" #-} rule195 = \ _firstOrderChildren ((_lhsInt) :: NontermIdent) ((_lhsIo_rename) :: Bool) ((_lhsIprefix) :: String) con_ -> {-# LINE 1139 "./src-ag/GenerateCode.ag" #-} let lhs = Fun (cataname _lhsIprefix _lhsInt) [lhs_pat] lhs_pat = App (conname _lhsIo_rename _lhsInt con_) (map (\(n,_,_) -> SimpleExpr $ locname $ n) _firstOrderChildren ) rhs = App (semname _lhsIprefix _lhsInt con_) (map argument _firstOrderChildren ) argument (nm,NT tp _ _,_) = App (cataname _lhsIprefix tp) [SimpleExpr (locname nm)] argument (nm, _,_) = SimpleExpr (locname nm) in Decl lhs rhs Set.empty Set.empty {-# LINE 1650 "dist/build/GenerateCode.hs"#-} {-# INLINE rule196 #-} rule196 = \ ((_visitsIdecls) :: Decls) -> _visitsIdecls {-# INLINE rule197 #-} rule197 = \ ((_visitsIsemNames) :: [String]) -> _visitsIsemNames {-# INLINE rule198 #-} rule198 = \ ((_lhsIallNts) :: Set NontermIdent) -> _lhsIallNts {-# INLINE rule199 #-} rule199 = \ ((_lhsIallPragmas) :: PragmaMap) -> _lhsIallPragmas {-# INLINE rule200 #-} rule200 = \ _aroundMap -> _aroundMap {-# INLINE rule201 #-} rule201 = \ ((_lhsIcontextMap) :: ContextMap) -> _lhsIcontextMap {-# INLINE rule202 #-} rule202 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule203 #-} rule203 = \ _mergeMap -> _mergeMap {-# INLINE rule204 #-} rule204 = \ ((_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule205 #-} rule205 = \ ((_lhsIo_case) :: Bool) -> _lhsIo_case {-# INLINE rule206 #-} rule206 = \ ((_lhsIo_cata) :: Bool) -> _lhsIo_cata {-# INLINE rule207 #-} rule207 = \ ((_lhsIo_costcentre) :: Bool) -> _lhsIo_costcentre {-# INLINE rule208 #-} rule208 = \ ((_lhsIo_data) :: Maybe Bool) -> _lhsIo_data {-# INLINE rule209 #-} rule209 = \ ((_lhsIo_linePragmas) :: Bool) -> _lhsIo_linePragmas {-# INLINE rule210 #-} rule210 = \ ((_lhsIo_monadic) :: Bool) -> _lhsIo_monadic {-# INLINE rule211 #-} rule211 = \ ((_lhsIo_newtypes) :: Bool) -> _lhsIo_newtypes {-# INLINE rule212 #-} rule212 = \ ((_lhsIo_pretty) :: Bool) -> _lhsIo_pretty {-# INLINE rule213 #-} rule213 = \ ((_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# INLINE rule214 #-} rule214 = \ ((_lhsIo_sem) :: Bool) -> _lhsIo_sem {-# INLINE rule215 #-} rule215 = \ ((_lhsIo_sig) :: Bool) -> _lhsIo_sig {-# INLINE rule216 #-} rule216 = \ ((_lhsIo_splitsems) :: Bool) -> _lhsIo_splitsems {-# INLINE rule217 #-} rule217 = \ ((_lhsIo_strictwrap) :: Bool) -> _lhsIo_strictwrap {-# INLINE rule218 #-} rule218 = \ ((_lhsIo_traces) :: Bool) -> _lhsIo_traces {-# INLINE rule219 #-} rule219 = \ ((_lhsIo_unbox) :: Bool) -> _lhsIo_unbox {-# INLINE rule220 #-} rule220 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule221 #-} rule221 = \ _paramInstMap -> _paramInstMap {-# INLINE rule222 #-} rule222 = \ ((_lhsIparamMap) :: ParamMap) -> _lhsIparamMap {-# INLINE rule223 #-} rule223 = \ ((_lhsIprefix) :: String) -> _lhsIprefix {-# INLINE rule224 #-} rule224 = \ ((_lhsIquantMap) :: QuantMap) -> _lhsIquantMap {-# INLINE rule225 #-} rule225 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# INLINE rule226 #-} rule226 = \ ((_lhsIunfoldSemDom) :: NontermIdent -> Int -> [String] -> Code.Type) -> _lhsIunfoldSemDom {-# INLINE rule227 #-} rule227 = \ ((_lhsIwith_sig) :: Bool) -> _lhsIwith_sig {-# INLINE rule228 #-} rule228 = \ ((_lhsIwrappers) :: Set NontermIdent) -> _lhsIwrappers -- CProductions ------------------------------------------------ -- wrapper data Inh_CProductions = Inh_CProductions { allNts_Inh_CProductions :: (Set NontermIdent), allPragmas_Inh_CProductions :: (PragmaMap), aroundMap_Inh_CProductions :: (Map ConstructorIdent (Set Identifier)), contextMap_Inh_CProductions :: (ContextMap), inh_Inh_CProductions :: (Attributes), mergeMap_Inh_CProductions :: (Map ConstructorIdent (Map Identifier (Identifier, [Identifier]))), nt_Inh_CProductions :: (NontermIdent), o_case_Inh_CProductions :: (Bool), o_cata_Inh_CProductions :: (Bool), o_costcentre_Inh_CProductions :: (Bool), o_data_Inh_CProductions :: (Maybe Bool), o_linePragmas_Inh_CProductions :: (Bool), o_monadic_Inh_CProductions :: (Bool), o_newtypes_Inh_CProductions :: (Bool), o_pretty_Inh_CProductions :: (Bool), o_rename_Inh_CProductions :: (Bool), o_sem_Inh_CProductions :: (Bool), o_sig_Inh_CProductions :: (Bool), o_splitsems_Inh_CProductions :: (Bool), o_strictwrap_Inh_CProductions :: (Bool), o_traces_Inh_CProductions :: (Bool), o_unbox_Inh_CProductions :: (Bool), options_Inh_CProductions :: (Options), paramMap_Inh_CProductions :: (ParamMap), prefix_Inh_CProductions :: (String), quantMap_Inh_CProductions :: (QuantMap), syn_Inh_CProductions :: (Attributes), unfoldSemDom_Inh_CProductions :: (NontermIdent -> Int -> [String] -> Code.Type), with_sig_Inh_CProductions :: (Bool), wrappers_Inh_CProductions :: (Set NontermIdent) } data Syn_CProductions = Syn_CProductions { cataAlts_Syn_CProductions :: (Decls), comments_Syn_CProductions :: ([String]), dataAlts_Syn_CProductions :: (DataAlts), decls_Syn_CProductions :: (Decls), semNames_Syn_CProductions :: ([String]) } {-# INLINABLE wrap_CProductions #-} wrap_CProductions :: T_CProductions -> Inh_CProductions -> (Syn_CProductions ) wrap_CProductions (T_CProductions act) (Inh_CProductions _lhsIallNts _lhsIallPragmas _lhsIaroundMap _lhsIcontextMap _lhsIinh _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIquantMap _lhsIsyn _lhsIunfoldSemDom _lhsIwith_sig _lhsIwrappers) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_CProductions_vIn16 _lhsIallNts _lhsIallPragmas _lhsIaroundMap _lhsIcontextMap _lhsIinh _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIquantMap _lhsIsyn _lhsIunfoldSemDom _lhsIwith_sig _lhsIwrappers (T_CProductions_vOut16 _lhsOcataAlts _lhsOcomments _lhsOdataAlts _lhsOdecls _lhsOsemNames) <- return (inv_CProductions_s17 sem arg) return (Syn_CProductions _lhsOcataAlts _lhsOcomments _lhsOdataAlts _lhsOdecls _lhsOsemNames) ) -- cata {-# NOINLINE sem_CProductions #-} sem_CProductions :: CProductions -> T_CProductions sem_CProductions list = Prelude.foldr sem_CProductions_Cons sem_CProductions_Nil (Prelude.map sem_CProduction list) -- semantic domain newtype T_CProductions = T_CProductions { attach_T_CProductions :: Identity (T_CProductions_s17 ) } newtype T_CProductions_s17 = C_CProductions_s17 { inv_CProductions_s17 :: (T_CProductions_v16 ) } data T_CProductions_s18 = C_CProductions_s18 type T_CProductions_v16 = (T_CProductions_vIn16 ) -> (T_CProductions_vOut16 ) data T_CProductions_vIn16 = T_CProductions_vIn16 (Set NontermIdent) (PragmaMap) (Map ConstructorIdent (Set Identifier)) (ContextMap) (Attributes) (Map ConstructorIdent (Map Identifier (Identifier, [Identifier]))) (NontermIdent) (Bool) (Bool) (Bool) (Maybe Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Options) (ParamMap) (String) (QuantMap) (Attributes) (NontermIdent -> Int -> [String] -> Code.Type) (Bool) (Set NontermIdent) data T_CProductions_vOut16 = T_CProductions_vOut16 (Decls) ([String]) (DataAlts) (Decls) ([String]) {-# NOINLINE sem_CProductions_Cons #-} sem_CProductions_Cons :: T_CProduction -> T_CProductions -> T_CProductions sem_CProductions_Cons arg_hd_ arg_tl_ = T_CProductions (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_CProductions_v16 v16 = \ (T_CProductions_vIn16 _lhsIallNts _lhsIallPragmas _lhsIaroundMap _lhsIcontextMap _lhsIinh _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIquantMap _lhsIsyn _lhsIunfoldSemDom _lhsIwith_sig _lhsIwrappers) -> ( let _hdX14 = Control.Monad.Identity.runIdentity (attach_T_CProduction (arg_hd_)) _tlX17 = Control.Monad.Identity.runIdentity (attach_T_CProductions (arg_tl_)) (T_CProduction_vOut13 _hdIcataAlt _hdIcomments _hdIdataAlt _hdIdecls _hdIsemNames) = inv_CProduction_s14 _hdX14 (T_CProduction_vIn13 _hdOallNts _hdOallPragmas _hdOaroundMap _hdOcontextMap _hdOinh _hdOmergeMap _hdOnt _hdOo_case _hdOo_cata _hdOo_costcentre _hdOo_data _hdOo_linePragmas _hdOo_monadic _hdOo_newtypes _hdOo_pretty _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_splitsems _hdOo_strictwrap _hdOo_traces _hdOo_unbox _hdOoptions _hdOparamMap _hdOprefix _hdOquantMap _hdOsyn _hdOunfoldSemDom _hdOwith_sig _hdOwrappers) (T_CProductions_vOut16 _tlIcataAlts _tlIcomments _tlIdataAlts _tlIdecls _tlIsemNames) = inv_CProductions_s17 _tlX17 (T_CProductions_vIn16 _tlOallNts _tlOallPragmas _tlOaroundMap _tlOcontextMap _tlOinh _tlOmergeMap _tlOnt _tlOo_case _tlOo_cata _tlOo_costcentre _tlOo_data _tlOo_linePragmas _tlOo_monadic _tlOo_newtypes _tlOo_pretty _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_splitsems _tlOo_strictwrap _tlOo_traces _tlOo_unbox _tlOoptions _tlOparamMap _tlOprefix _tlOquantMap _tlOsyn _tlOunfoldSemDom _tlOwith_sig _tlOwrappers) _lhsOdataAlts :: DataAlts _lhsOdataAlts = rule229 _hdIdataAlt _tlIdataAlts _lhsOcataAlts :: Decls _lhsOcataAlts = rule230 _hdIcataAlt _tlIcataAlts _lhsOcomments :: [String] _lhsOcomments = rule231 _hdIcomments _tlIcomments _lhsOdecls :: Decls _lhsOdecls = rule232 _hdIdecls _tlIdecls _lhsOsemNames :: [String] _lhsOsemNames = rule233 _hdIsemNames _tlIsemNames _hdOallNts = rule234 _lhsIallNts _hdOallPragmas = rule235 _lhsIallPragmas _hdOaroundMap = rule236 _lhsIaroundMap _hdOcontextMap = rule237 _lhsIcontextMap _hdOinh = rule238 _lhsIinh _hdOmergeMap = rule239 _lhsImergeMap _hdOnt = rule240 _lhsInt _hdOo_case = rule241 _lhsIo_case _hdOo_cata = rule242 _lhsIo_cata _hdOo_costcentre = rule243 _lhsIo_costcentre _hdOo_data = rule244 _lhsIo_data _hdOo_linePragmas = rule245 _lhsIo_linePragmas _hdOo_monadic = rule246 _lhsIo_monadic _hdOo_newtypes = rule247 _lhsIo_newtypes _hdOo_pretty = rule248 _lhsIo_pretty _hdOo_rename = rule249 _lhsIo_rename _hdOo_sem = rule250 _lhsIo_sem _hdOo_sig = rule251 _lhsIo_sig _hdOo_splitsems = rule252 _lhsIo_splitsems _hdOo_strictwrap = rule253 _lhsIo_strictwrap _hdOo_traces = rule254 _lhsIo_traces _hdOo_unbox = rule255 _lhsIo_unbox _hdOoptions = rule256 _lhsIoptions _hdOparamMap = rule257 _lhsIparamMap _hdOprefix = rule258 _lhsIprefix _hdOquantMap = rule259 _lhsIquantMap _hdOsyn = rule260 _lhsIsyn _hdOunfoldSemDom = rule261 _lhsIunfoldSemDom _hdOwith_sig = rule262 _lhsIwith_sig _hdOwrappers = rule263 _lhsIwrappers _tlOallNts = rule264 _lhsIallNts _tlOallPragmas = rule265 _lhsIallPragmas _tlOaroundMap = rule266 _lhsIaroundMap _tlOcontextMap = rule267 _lhsIcontextMap _tlOinh = rule268 _lhsIinh _tlOmergeMap = rule269 _lhsImergeMap _tlOnt = rule270 _lhsInt _tlOo_case = rule271 _lhsIo_case _tlOo_cata = rule272 _lhsIo_cata _tlOo_costcentre = rule273 _lhsIo_costcentre _tlOo_data = rule274 _lhsIo_data _tlOo_linePragmas = rule275 _lhsIo_linePragmas _tlOo_monadic = rule276 _lhsIo_monadic _tlOo_newtypes = rule277 _lhsIo_newtypes _tlOo_pretty = rule278 _lhsIo_pretty _tlOo_rename = rule279 _lhsIo_rename _tlOo_sem = rule280 _lhsIo_sem _tlOo_sig = rule281 _lhsIo_sig _tlOo_splitsems = rule282 _lhsIo_splitsems _tlOo_strictwrap = rule283 _lhsIo_strictwrap _tlOo_traces = rule284 _lhsIo_traces _tlOo_unbox = rule285 _lhsIo_unbox _tlOoptions = rule286 _lhsIoptions _tlOparamMap = rule287 _lhsIparamMap _tlOprefix = rule288 _lhsIprefix _tlOquantMap = rule289 _lhsIquantMap _tlOsyn = rule290 _lhsIsyn _tlOunfoldSemDom = rule291 _lhsIunfoldSemDom _tlOwith_sig = rule292 _lhsIwith_sig _tlOwrappers = rule293 _lhsIwrappers __result_ = T_CProductions_vOut16 _lhsOcataAlts _lhsOcomments _lhsOdataAlts _lhsOdecls _lhsOsemNames in __result_ ) in C_CProductions_s17 v16 {-# INLINE rule229 #-} {-# LINE 1021 "./src-ag/GenerateCode.ag" #-} rule229 = \ ((_hdIdataAlt) :: DataAlt) ((_tlIdataAlts) :: DataAlts) -> {-# LINE 1021 "./src-ag/GenerateCode.ag" #-} _hdIdataAlt : _tlIdataAlts {-# LINE 1870 "dist/build/GenerateCode.hs"#-} {-# INLINE rule230 #-} {-# LINE 1135 "./src-ag/GenerateCode.ag" #-} rule230 = \ ((_hdIcataAlt) :: Decl) ((_tlIcataAlts) :: Decls) -> {-# LINE 1135 "./src-ag/GenerateCode.ag" #-} _hdIcataAlt : _tlIcataAlts {-# LINE 1876 "dist/build/GenerateCode.hs"#-} {-# INLINE rule231 #-} rule231 = \ ((_hdIcomments) :: [String]) ((_tlIcomments) :: [String]) -> _hdIcomments ++ _tlIcomments {-# INLINE rule232 #-} rule232 = \ ((_hdIdecls) :: Decls) ((_tlIdecls) :: Decls) -> _hdIdecls ++ _tlIdecls {-# INLINE rule233 #-} rule233 = \ ((_hdIsemNames) :: [String]) ((_tlIsemNames) :: [String]) -> _hdIsemNames ++ _tlIsemNames {-# INLINE rule234 #-} rule234 = \ ((_lhsIallNts) :: Set NontermIdent) -> _lhsIallNts {-# INLINE rule235 #-} rule235 = \ ((_lhsIallPragmas) :: PragmaMap) -> _lhsIallPragmas {-# INLINE rule236 #-} rule236 = \ ((_lhsIaroundMap) :: Map ConstructorIdent (Set Identifier)) -> _lhsIaroundMap {-# INLINE rule237 #-} rule237 = \ ((_lhsIcontextMap) :: ContextMap) -> _lhsIcontextMap {-# INLINE rule238 #-} rule238 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule239 #-} rule239 = \ ((_lhsImergeMap) :: Map ConstructorIdent (Map Identifier (Identifier, [Identifier]))) -> _lhsImergeMap {-# INLINE rule240 #-} rule240 = \ ((_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule241 #-} rule241 = \ ((_lhsIo_case) :: Bool) -> _lhsIo_case {-# INLINE rule242 #-} rule242 = \ ((_lhsIo_cata) :: Bool) -> _lhsIo_cata {-# INLINE rule243 #-} rule243 = \ ((_lhsIo_costcentre) :: Bool) -> _lhsIo_costcentre {-# INLINE rule244 #-} rule244 = \ ((_lhsIo_data) :: Maybe Bool) -> _lhsIo_data {-# INLINE rule245 #-} rule245 = \ ((_lhsIo_linePragmas) :: Bool) -> _lhsIo_linePragmas {-# INLINE rule246 #-} rule246 = \ ((_lhsIo_monadic) :: Bool) -> _lhsIo_monadic {-# INLINE rule247 #-} rule247 = \ ((_lhsIo_newtypes) :: Bool) -> _lhsIo_newtypes {-# INLINE rule248 #-} rule248 = \ ((_lhsIo_pretty) :: Bool) -> _lhsIo_pretty {-# INLINE rule249 #-} rule249 = \ ((_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# INLINE rule250 #-} rule250 = \ ((_lhsIo_sem) :: Bool) -> _lhsIo_sem {-# INLINE rule251 #-} rule251 = \ ((_lhsIo_sig) :: Bool) -> _lhsIo_sig {-# INLINE rule252 #-} rule252 = \ ((_lhsIo_splitsems) :: Bool) -> _lhsIo_splitsems {-# INLINE rule253 #-} rule253 = \ ((_lhsIo_strictwrap) :: Bool) -> _lhsIo_strictwrap {-# INLINE rule254 #-} rule254 = \ ((_lhsIo_traces) :: Bool) -> _lhsIo_traces {-# INLINE rule255 #-} rule255 = \ ((_lhsIo_unbox) :: Bool) -> _lhsIo_unbox {-# INLINE rule256 #-} rule256 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule257 #-} rule257 = \ ((_lhsIparamMap) :: ParamMap) -> _lhsIparamMap {-# INLINE rule258 #-} rule258 = \ ((_lhsIprefix) :: String) -> _lhsIprefix {-# INLINE rule259 #-} rule259 = \ ((_lhsIquantMap) :: QuantMap) -> _lhsIquantMap {-# INLINE rule260 #-} rule260 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# INLINE rule261 #-} rule261 = \ ((_lhsIunfoldSemDom) :: NontermIdent -> Int -> [String] -> Code.Type) -> _lhsIunfoldSemDom {-# INLINE rule262 #-} rule262 = \ ((_lhsIwith_sig) :: Bool) -> _lhsIwith_sig {-# INLINE rule263 #-} rule263 = \ ((_lhsIwrappers) :: Set NontermIdent) -> _lhsIwrappers {-# INLINE rule264 #-} rule264 = \ ((_lhsIallNts) :: Set NontermIdent) -> _lhsIallNts {-# INLINE rule265 #-} rule265 = \ ((_lhsIallPragmas) :: PragmaMap) -> _lhsIallPragmas {-# INLINE rule266 #-} rule266 = \ ((_lhsIaroundMap) :: Map ConstructorIdent (Set Identifier)) -> _lhsIaroundMap {-# INLINE rule267 #-} rule267 = \ ((_lhsIcontextMap) :: ContextMap) -> _lhsIcontextMap {-# INLINE rule268 #-} rule268 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule269 #-} rule269 = \ ((_lhsImergeMap) :: Map ConstructorIdent (Map Identifier (Identifier, [Identifier]))) -> _lhsImergeMap {-# INLINE rule270 #-} rule270 = \ ((_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule271 #-} rule271 = \ ((_lhsIo_case) :: Bool) -> _lhsIo_case {-# INLINE rule272 #-} rule272 = \ ((_lhsIo_cata) :: Bool) -> _lhsIo_cata {-# INLINE rule273 #-} rule273 = \ ((_lhsIo_costcentre) :: Bool) -> _lhsIo_costcentre {-# INLINE rule274 #-} rule274 = \ ((_lhsIo_data) :: Maybe Bool) -> _lhsIo_data {-# INLINE rule275 #-} rule275 = \ ((_lhsIo_linePragmas) :: Bool) -> _lhsIo_linePragmas {-# INLINE rule276 #-} rule276 = \ ((_lhsIo_monadic) :: Bool) -> _lhsIo_monadic {-# INLINE rule277 #-} rule277 = \ ((_lhsIo_newtypes) :: Bool) -> _lhsIo_newtypes {-# INLINE rule278 #-} rule278 = \ ((_lhsIo_pretty) :: Bool) -> _lhsIo_pretty {-# INLINE rule279 #-} rule279 = \ ((_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# INLINE rule280 #-} rule280 = \ ((_lhsIo_sem) :: Bool) -> _lhsIo_sem {-# INLINE rule281 #-} rule281 = \ ((_lhsIo_sig) :: Bool) -> _lhsIo_sig {-# INLINE rule282 #-} rule282 = \ ((_lhsIo_splitsems) :: Bool) -> _lhsIo_splitsems {-# INLINE rule283 #-} rule283 = \ ((_lhsIo_strictwrap) :: Bool) -> _lhsIo_strictwrap {-# INLINE rule284 #-} rule284 = \ ((_lhsIo_traces) :: Bool) -> _lhsIo_traces {-# INLINE rule285 #-} rule285 = \ ((_lhsIo_unbox) :: Bool) -> _lhsIo_unbox {-# INLINE rule286 #-} rule286 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule287 #-} rule287 = \ ((_lhsIparamMap) :: ParamMap) -> _lhsIparamMap {-# INLINE rule288 #-} rule288 = \ ((_lhsIprefix) :: String) -> _lhsIprefix {-# INLINE rule289 #-} rule289 = \ ((_lhsIquantMap) :: QuantMap) -> _lhsIquantMap {-# INLINE rule290 #-} rule290 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# INLINE rule291 #-} rule291 = \ ((_lhsIunfoldSemDom) :: NontermIdent -> Int -> [String] -> Code.Type) -> _lhsIunfoldSemDom {-# INLINE rule292 #-} rule292 = \ ((_lhsIwith_sig) :: Bool) -> _lhsIwith_sig {-# INLINE rule293 #-} rule293 = \ ((_lhsIwrappers) :: Set NontermIdent) -> _lhsIwrappers {-# NOINLINE sem_CProductions_Nil #-} sem_CProductions_Nil :: T_CProductions sem_CProductions_Nil = T_CProductions (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_CProductions_v16 v16 = \ (T_CProductions_vIn16 _lhsIallNts _lhsIallPragmas _lhsIaroundMap _lhsIcontextMap _lhsIinh _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIquantMap _lhsIsyn _lhsIunfoldSemDom _lhsIwith_sig _lhsIwrappers) -> ( let _lhsOdataAlts :: DataAlts _lhsOdataAlts = rule294 () _lhsOcataAlts :: Decls _lhsOcataAlts = rule295 () _lhsOcomments :: [String] _lhsOcomments = rule296 () _lhsOdecls :: Decls _lhsOdecls = rule297 () _lhsOsemNames :: [String] _lhsOsemNames = rule298 () __result_ = T_CProductions_vOut16 _lhsOcataAlts _lhsOcomments _lhsOdataAlts _lhsOdecls _lhsOsemNames in __result_ ) in C_CProductions_s17 v16 {-# INLINE rule294 #-} {-# LINE 1022 "./src-ag/GenerateCode.ag" #-} rule294 = \ (_ :: ()) -> {-# LINE 1022 "./src-ag/GenerateCode.ag" #-} [] {-# LINE 2091 "dist/build/GenerateCode.hs"#-} {-# INLINE rule295 #-} {-# LINE 1136 "./src-ag/GenerateCode.ag" #-} rule295 = \ (_ :: ()) -> {-# LINE 1136 "./src-ag/GenerateCode.ag" #-} [] {-# LINE 2097 "dist/build/GenerateCode.hs"#-} {-# INLINE rule296 #-} rule296 = \ (_ :: ()) -> [] {-# INLINE rule297 #-} rule297 = \ (_ :: ()) -> [] {-# INLINE rule298 #-} rule298 = \ (_ :: ()) -> [] -- CRule ------------------------------------------------------- -- wrapper data Inh_CRule = Inh_CRule { allNts_Inh_CRule :: (Set NontermIdent), aroundMap_Inh_CRule :: (Set Identifier), children_Inh_CRule :: ([(Identifier,Type,ChildKind)]), con_Inh_CRule :: (ConstructorIdent), declsAbove_Inh_CRule :: ([Decl]), inh_Inh_CRule :: (Attributes), instVisitNrs_Inh_CRule :: (Map Identifier Int), mergeMap_Inh_CRule :: (Map Identifier (Identifier, [Identifier])), nr_Inh_CRule :: (Int), nt_Inh_CRule :: (NontermIdent), o_case_Inh_CRule :: (Bool), o_cata_Inh_CRule :: (Bool), o_costcentre_Inh_CRule :: (Bool), o_data_Inh_CRule :: (Maybe Bool), o_linePragmas_Inh_CRule :: (Bool), o_monadic_Inh_CRule :: (Bool), o_newtypes_Inh_CRule :: (Bool), o_pretty_Inh_CRule :: (Bool), o_rename_Inh_CRule :: (Bool), o_sem_Inh_CRule :: (Bool), o_sig_Inh_CRule :: (Bool), o_splitsems_Inh_CRule :: (Bool), o_strictwrap_Inh_CRule :: (Bool), o_traces_Inh_CRule :: (Bool), o_unbox_Inh_CRule :: (Bool), options_Inh_CRule :: (Options), paramInstMap_Inh_CRule :: (Map Identifier (NontermIdent, [String])), paramMap_Inh_CRule :: (ParamMap), prefix_Inh_CRule :: (String), syn_Inh_CRule :: (Attributes), terminals_Inh_CRule :: ([Identifier]), unfoldSemDom_Inh_CRule :: (NontermIdent -> Int -> [String] -> Code.Type), visitedSet_Inh_CRule :: (Set Identifier), what_Inh_CRule :: (String) } data Syn_CRule = Syn_CRule { allTpsFound_Syn_CRule :: (Bool), bldBlocksFun_Syn_CRule :: (DeclBlocks -> DeclBlocks), comments_Syn_CRule :: ([String]), decls_Syn_CRule :: (Decls), declsAbove_Syn_CRule :: ([Decl]), definedInsts_Syn_CRule :: ([Identifier]), exprs_Syn_CRule :: (Exprs), tSigs_Syn_CRule :: ([Decl]), tps_Syn_CRule :: ([Type]), usedVars_Syn_CRule :: (Set String), visitedSet_Syn_CRule :: (Set Identifier) } {-# INLINABLE wrap_CRule #-} wrap_CRule :: T_CRule -> Inh_CRule -> (Syn_CRule ) wrap_CRule (T_CRule act) (Inh_CRule _lhsIallNts _lhsIaroundMap _lhsIchildren _lhsIcon _lhsIdeclsAbove _lhsIinh _lhsIinstVisitNrs _lhsImergeMap _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamInstMap _lhsIparamMap _lhsIprefix _lhsIsyn _lhsIterminals _lhsIunfoldSemDom _lhsIvisitedSet _lhsIwhat) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_CRule_vIn19 _lhsIallNts _lhsIaroundMap _lhsIchildren _lhsIcon _lhsIdeclsAbove _lhsIinh _lhsIinstVisitNrs _lhsImergeMap _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamInstMap _lhsIparamMap _lhsIprefix _lhsIsyn _lhsIterminals _lhsIunfoldSemDom _lhsIvisitedSet _lhsIwhat (T_CRule_vOut19 _lhsOallTpsFound _lhsObldBlocksFun _lhsOcomments _lhsOdecls _lhsOdeclsAbove _lhsOdefinedInsts _lhsOexprs _lhsOtSigs _lhsOtps _lhsOusedVars _lhsOvisitedSet) <- return (inv_CRule_s20 sem arg) return (Syn_CRule _lhsOallTpsFound _lhsObldBlocksFun _lhsOcomments _lhsOdecls _lhsOdeclsAbove _lhsOdefinedInsts _lhsOexprs _lhsOtSigs _lhsOtps _lhsOusedVars _lhsOvisitedSet) ) -- cata {-# NOINLINE sem_CRule #-} sem_CRule :: CRule -> T_CRule sem_CRule ( CRule name_ isIn_ hasCode_ nt_ con_ field_ childnt_ tp_ pattern_ rhs_ defines_ owrt_ origin_ uses_ explicit_ mbNamed_ ) = sem_CRule_CRule name_ isIn_ hasCode_ nt_ con_ field_ childnt_ tp_ ( sem_Pattern pattern_ ) rhs_ defines_ owrt_ origin_ uses_ explicit_ mbNamed_ sem_CRule ( CChildVisit name_ nt_ nr_ inh_ syn_ isLast_ ) = sem_CRule_CChildVisit name_ nt_ nr_ inh_ syn_ isLast_ -- semantic domain newtype T_CRule = T_CRule { attach_T_CRule :: Identity (T_CRule_s20 ) } newtype T_CRule_s20 = C_CRule_s20 { inv_CRule_s20 :: (T_CRule_v19 ) } data T_CRule_s21 = C_CRule_s21 type T_CRule_v19 = (T_CRule_vIn19 ) -> (T_CRule_vOut19 ) data T_CRule_vIn19 = T_CRule_vIn19 (Set NontermIdent) (Set Identifier) ([(Identifier,Type,ChildKind)]) (ConstructorIdent) ([Decl]) (Attributes) (Map Identifier Int) (Map Identifier (Identifier, [Identifier])) (Int) (NontermIdent) (Bool) (Bool) (Bool) (Maybe Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Options) (Map Identifier (NontermIdent, [String])) (ParamMap) (String) (Attributes) ([Identifier]) (NontermIdent -> Int -> [String] -> Code.Type) (Set Identifier) (String) data T_CRule_vOut19 = T_CRule_vOut19 (Bool) (DeclBlocks -> DeclBlocks) ([String]) (Decls) ([Decl]) ([Identifier]) (Exprs) ([Decl]) ([Type]) (Set String) (Set Identifier) {-# NOINLINE sem_CRule_CRule #-} sem_CRule_CRule :: (Identifier) -> (Bool) -> (Bool) -> (NontermIdent) -> (ConstructorIdent) -> (Identifier) -> (Maybe NontermIdent) -> (Maybe Type) -> T_Pattern -> ([String]) -> (Map Int (Identifier,Identifier,Maybe Type)) -> (Bool) -> (String) -> (Set (Identifier, Identifier)) -> (Bool) -> (Maybe Identifier) -> T_CRule sem_CRule_CRule arg_name_ arg_isIn_ arg_hasCode_ arg_nt_ arg_con_ arg_field_ _ arg_tp_ arg_pattern_ arg_rhs_ arg_defines_ _ arg_origin_ arg_uses_ arg_explicit_ arg_mbNamed_ = T_CRule (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_CRule_v19 v19 = \ (T_CRule_vIn19 _lhsIallNts _lhsIaroundMap _lhsIchildren _lhsIcon _lhsIdeclsAbove _lhsIinh _lhsIinstVisitNrs _lhsImergeMap _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamInstMap _lhsIparamMap _lhsIprefix _lhsIsyn _lhsIterminals _lhsIunfoldSemDom _lhsIvisitedSet _lhsIwhat) -> ( let _patternX41 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pattern_)) (T_Pattern_vOut40 _patternIcopy _patternIdefinedInsts _patternIpatternAttributes) = inv_Pattern_s41 _patternX41 (T_Pattern_vIn40 ) _instTypes = rule299 _lhsIchildren _originComment = rule300 _lhsIo_pretty arg_origin_ _instDecls = rule301 _definedInsts _instTypes _lhsIo_monadic _lhsIo_newtypes _lhsIprefix _patDescr = rule302 _patternIpatternAttributes arg_isIn_ _traceDescr = rule303 _patDescr arg_con_ arg_mbNamed_ arg_nt_ _addTrace = rule304 _lhsIo_traces _traceDescr _costCentreDescr = rule305 _patDescr arg_con_ arg_nt_ _addCostCentre = rule306 _costCentreDescr _lhsIo_costcentre _addLinePragma = rule307 _lhsIo_linePragmas arg_name_ _decls = rule308 _addCostCentre _addLinePragma _addTrace _instDecls _lhsIo_monadic _originComment _patternIcopy arg_defines_ arg_explicit_ arg_hasCode_ arg_rhs_ arg_uses_ _definedInsts = rule309 _patternIdefinedInsts arg_isIn_ _rulename = rule310 _lhsIterminals arg_field_ arg_isIn_ arg_name_ _lhsOexprs :: Exprs _lhsOexprs = rule311 _rulename _lhsOusedVars :: Set String _lhsOusedVars = rule312 _rulename _mkTp = rule313 _lhsInt _orgParams _lhsOtSigs :: [Decl] _lhsOtSigs = rule314 _evalTp _lhsIchildren _mkTp arg_defines_ _orgParams = rule315 _lhsInt _lhsIparamMap _evalTp = rule316 _lhsInt _lhsIparamInstMap _lhsIparamMap _orgParams _lhsOtps :: [Type] _lhsOallTpsFound :: Bool (_lhsOtps,_lhsOallTpsFound) = rule317 arg_tp_ _lhsOdeclsAbove :: [Decl] _lhsOdeclsAbove = rule318 _decls _lhsIdeclsAbove _lhsObldBlocksFun :: DeclBlocks -> DeclBlocks _lhsObldBlocksFun = rule319 () _lhsOcomments :: [String] _lhsOcomments = rule320 _lhsIwhat arg_defines_ _lhsOdecls :: Decls _lhsOdecls = rule321 _decls _lhsOdefinedInsts :: [Identifier] _lhsOdefinedInsts = rule322 _definedInsts _lhsOvisitedSet :: Set Identifier _lhsOvisitedSet = rule323 _lhsIvisitedSet __result_ = T_CRule_vOut19 _lhsOallTpsFound _lhsObldBlocksFun _lhsOcomments _lhsOdecls _lhsOdeclsAbove _lhsOdefinedInsts _lhsOexprs _lhsOtSigs _lhsOtps _lhsOusedVars _lhsOvisitedSet in __result_ ) in C_CRule_s20 v19 {-# INLINE rule299 #-} {-# LINE 157 "./src-ag/GenerateCode.ag" #-} rule299 = \ ((_lhsIchildren) :: [(Identifier,Type,ChildKind)]) -> {-# LINE 157 "./src-ag/GenerateCode.ag" #-} [ (n, (t, mb, for)) | (n, NT t _ for, mb) <- _lhsIchildren ] {-# LINE 2192 "dist/build/GenerateCode.hs"#-} {-# INLINE rule300 #-} {-# LINE 158 "./src-ag/GenerateCode.ag" #-} rule300 = \ ((_lhsIo_pretty) :: Bool) origin_ -> {-# LINE 158 "./src-ag/GenerateCode.ag" #-} if _lhsIo_pretty then (Comment origin_:) else id {-# LINE 2200 "dist/build/GenerateCode.hs"#-} {-# INLINE rule301 #-} {-# LINE 161 "./src-ag/GenerateCode.ag" #-} rule301 = \ _definedInsts _instTypes ((_lhsIo_monadic) :: Bool) ((_lhsIo_newtypes) :: Bool) ((_lhsIprefix) :: String) -> {-# LINE 161 "./src-ag/GenerateCode.ag" #-} [ mkDecl _lhsIo_monadic (Pattern3 (Alias _INST' inst (Underscore (getPos inst)))) ( let (nm,mb,defor) = fromJust $ inst `lookup` _instTypes in unwrapSem _lhsIo_newtypes nm $ case mb of ChildReplace _ -> App instLocFieldName [SimpleExpr $ fieldname inst] _ -> if defor then SimpleExpr instLocFieldName else App (cataname _lhsIprefix nm) [SimpleExpr instLocFieldName] ) (Set.singleton instSemFieldName) (Set.singleton instLocFieldName) | inst <- _definedInsts , let instLocFieldName = attrname True _INST inst instSemFieldName = attrname False _INST' inst ] {-# LINE 2222 "dist/build/GenerateCode.hs"#-} {-# INLINE rule302 #-} {-# LINE 178 "./src-ag/GenerateCode.ag" #-} rule302 = \ ((_patternIpatternAttributes) :: [(Identifier, Identifier)]) isIn_ -> {-# LINE 178 "./src-ag/GenerateCode.ag" #-} if isIn_ then "_" else concat $ intersperse "," (map (\(f,a) -> show f ++ "." ++ show a) _patternIpatternAttributes) {-# LINE 2230 "dist/build/GenerateCode.hs"#-} {-# INLINE rule303 #-} {-# LINE 181 "./src-ag/GenerateCode.ag" #-} rule303 = \ _patDescr con_ mbNamed_ nt_ -> {-# LINE 181 "./src-ag/GenerateCode.ag" #-} (maybe "" (\nm -> show nm ++ ":") mbNamed_) ++ show nt_ ++ " :: " ++ show con_ ++ " :: " ++ _patDescr {-# LINE 2236 "dist/build/GenerateCode.hs"#-} {-# INLINE rule304 #-} {-# LINE 183 "./src-ag/GenerateCode.ag" #-} rule304 = \ ((_lhsIo_traces) :: Bool) _traceDescr -> {-# LINE 183 "./src-ag/GenerateCode.ag" #-} \v -> if _lhsIo_traces then Trace _traceDescr v else v {-# LINE 2244 "dist/build/GenerateCode.hs"#-} {-# INLINE rule305 #-} {-# LINE 186 "./src-ag/GenerateCode.ag" #-} rule305 = \ _patDescr con_ nt_ -> {-# LINE 186 "./src-ag/GenerateCode.ag" #-} show nt_ ++ ":" ++ show con_ ++ ":" ++ _patDescr {-# LINE 2250 "dist/build/GenerateCode.hs"#-} {-# INLINE rule306 #-} {-# LINE 187 "./src-ag/GenerateCode.ag" #-} rule306 = \ _costCentreDescr ((_lhsIo_costcentre) :: Bool) -> {-# LINE 187 "./src-ag/GenerateCode.ag" #-} \v -> if _lhsIo_costcentre then PragmaExpr True False ("SCC \"" ++ _costCentreDescr ++ "\"") v else v {-# LINE 2258 "dist/build/GenerateCode.hs"#-} {-# INLINE rule307 #-} {-# LINE 190 "./src-ag/GenerateCode.ag" #-} rule307 = \ ((_lhsIo_linePragmas) :: Bool) name_ -> {-# LINE 190 "./src-ag/GenerateCode.ag" #-} \v -> let p = getPos name_ hasPos = line p > 0 && column p >= 0 && not (null (file p)) in if _lhsIo_linePragmas && hasPos then PragmaExpr True True ("LINE " ++ show (line p) ++ " " ++ show (file p)) $ LineExpr $ v else v {-# LINE 2270 "dist/build/GenerateCode.hs"#-} {-# INLINE rule308 #-} {-# LINE 197 "./src-ag/GenerateCode.ag" #-} rule308 = \ _addCostCentre _addLinePragma _addTrace _instDecls ((_lhsIo_monadic) :: Bool) _originComment ((_patternIcopy) :: Pattern) defines_ explicit_ hasCode_ rhs_ uses_ -> {-# LINE 197 "./src-ag/GenerateCode.ag" #-} if hasCode_ then _originComment ( mkDecl (_lhsIo_monadic && explicit_) (Pattern3 _patternIcopy) (_addTrace $ _addCostCentre $ _addLinePragma $ (TextExpr rhs_)) (Set.fromList [attrname False fld nm | (fld,nm,_) <- Map.elems defines_]) (Set.fromList [attrname True fld nm | (fld,nm) <- Set.toList uses_]) : _instDecls ) else _instDecls {-# LINE 2281 "dist/build/GenerateCode.hs"#-} {-# INLINE rule309 #-} {-# LINE 267 "./src-ag/GenerateCode.ag" #-} rule309 = \ ((_patternIdefinedInsts) :: [Identifier]) isIn_ -> {-# LINE 267 "./src-ag/GenerateCode.ag" #-} if isIn_ then [] else _patternIdefinedInsts {-# LINE 2287 "dist/build/GenerateCode.hs"#-} {-# INLINE rule310 #-} {-# LINE 337 "./src-ag/GenerateCode.ag" #-} rule310 = \ ((_lhsIterminals) :: [Identifier]) field_ isIn_ name_ -> {-# LINE 337 "./src-ag/GenerateCode.ag" #-} if field_ == _LOC && name_ `elem` _lhsIterminals then funname name_ 0 else attrname isIn_ field_ name_ {-# LINE 2295 "dist/build/GenerateCode.hs"#-} {-# INLINE rule311 #-} {-# LINE 340 "./src-ag/GenerateCode.ag" #-} rule311 = \ _rulename -> {-# LINE 340 "./src-ag/GenerateCode.ag" #-} [SimpleExpr _rulename ] {-# LINE 2301 "dist/build/GenerateCode.hs"#-} {-# INLINE rule312 #-} {-# LINE 356 "./src-ag/GenerateCode.ag" #-} rule312 = \ _rulename -> {-# LINE 356 "./src-ag/GenerateCode.ag" #-} Set.singleton _rulename {-# LINE 2307 "dist/build/GenerateCode.hs"#-} {-# INLINE rule313 #-} {-# LINE 366 "./src-ag/GenerateCode.ag" #-} rule313 = \ ((_lhsInt) :: NontermIdent) _orgParams -> {-# LINE 366 "./src-ag/GenerateCode.ag" #-} typeToCodeType (Just _lhsInt) _orgParams {-# LINE 2313 "dist/build/GenerateCode.hs"#-} {-# INLINE rule314 #-} {-# LINE 367 "./src-ag/GenerateCode.ag" #-} rule314 = \ _evalTp ((_lhsIchildren) :: [(Identifier,Type,ChildKind)]) _mkTp defines_ -> {-# LINE 367 "./src-ag/GenerateCode.ag" #-} [ TSig (attrname False field attr) tp' | (field,attr,tp) <- Map.elems defines_, isJust tp , let tp1 = _evalTp field $ _mkTp (fromJust tp) tp' = case findOrigType attr _lhsIchildren of Just tp'' -> let tp2 = _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 ] {-# LINE 2332 "dist/build/GenerateCode.hs"#-} {-# INLINE rule315 #-} {-# LINE 382 "./src-ag/GenerateCode.ag" #-} rule315 = \ ((_lhsInt) :: NontermIdent) ((_lhsIparamMap) :: ParamMap) -> {-# LINE 382 "./src-ag/GenerateCode.ag" #-} map getName $ Map.findWithDefault [] _lhsInt _lhsIparamMap {-# LINE 2338 "dist/build/GenerateCode.hs"#-} {-# INLINE rule316 #-} {-# LINE 384 "./src-ag/GenerateCode.ag" #-} rule316 = \ ((_lhsInt) :: NontermIdent) ((_lhsIparamInstMap) :: Map Identifier (NontermIdent, [String])) ((_lhsIparamMap) :: ParamMap) _orgParams -> {-# LINE 384 "./src-ag/GenerateCode.ag" #-} \field tp -> let orgFldParams = map getName $ Map.findWithDefault [] childNt _lhsIparamMap (childNt,instParams) = Map.findWithDefault (_lhsInt,[]) field _lhsIparamInstMap 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 tp else evalType replace tp {-# LINE 2352 "dist/build/GenerateCode.hs"#-} {-# INLINE rule317 #-} {-# LINE 419 "./src-ag/GenerateCode.ag" #-} rule317 = \ tp_ -> {-# LINE 419 "./src-ag/GenerateCode.ag" #-} maybe ([],False) (\tp -> ([tp],True)) tp_ {-# LINE 2358 "dist/build/GenerateCode.hs"#-} {-# INLINE rule318 #-} {-# LINE 618 "./src-ag/GenerateCode.ag" #-} rule318 = \ _decls ((_lhsIdeclsAbove) :: [Decl]) -> {-# LINE 618 "./src-ag/GenerateCode.ag" #-} _lhsIdeclsAbove ++ _decls {-# LINE 2364 "dist/build/GenerateCode.hs"#-} {-# INLINE rule319 #-} {-# LINE 631 "./src-ag/GenerateCode.ag" #-} rule319 = \ (_ :: ()) -> {-# LINE 631 "./src-ag/GenerateCode.ag" #-} id {-# LINE 2370 "dist/build/GenerateCode.hs"#-} {-# INLINE rule320 #-} {-# LINE 906 "./src-ag/GenerateCode.ag" #-} rule320 = \ ((_lhsIwhat) :: String) defines_ -> {-# LINE 906 "./src-ag/GenerateCode.ag" #-} [ makeLocalComment 11 _lhsIwhat name tp | (field,name,tp) <- Map.elems defines_, field == _LOC ] ++ [ makeLocalComment 11 "inst " name tp | (field,name,tp) <- Map.elems defines_, field == _INST ] {-# LINE 2377 "dist/build/GenerateCode.hs"#-} {-# INLINE rule321 #-} rule321 = \ _decls -> _decls {-# INLINE rule322 #-} rule322 = \ _definedInsts -> _definedInsts {-# INLINE rule323 #-} rule323 = \ ((_lhsIvisitedSet) :: Set Identifier) -> _lhsIvisitedSet {-# NOINLINE sem_CRule_CChildVisit #-} sem_CRule_CChildVisit :: (Identifier) -> (NontermIdent) -> (Int) -> (Attributes) -> (Attributes) -> (Bool) -> T_CRule sem_CRule_CChildVisit arg_name_ arg_nt_ arg_nr_ arg_inh_ arg_syn_ arg_isLast_ = T_CRule (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_CRule_v19 v19 = \ (T_CRule_vIn19 _lhsIallNts _lhsIaroundMap _lhsIchildren _lhsIcon _lhsIdeclsAbove _lhsIinh _lhsIinstVisitNrs _lhsImergeMap _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamInstMap _lhsIparamMap _lhsIprefix _lhsIsyn _lhsIterminals _lhsIunfoldSemDom _lhsIvisitedSet _lhsIwhat) -> ( let _visitedSet = rule324 _lhsIvisitedSet arg_name_ _costCentreDescr = rule325 _lhsIcon _lhsInt arg_name_ arg_nr_ arg_nt_ _addCostCentre = rule326 _costCentreDescr _lhsIo_costcentre _decls = rule327 _addCostCentre _lhsIaroundMap _lhsIchildren _lhsImergeMap _lhsIo_monadic _lhsIo_newtypes _lhsIo_unbox _visitedSet arg_inh_ arg_isLast_ arg_name_ arg_nr_ arg_nt_ arg_syn_ _isSuperfluousHigherOrderIntra = rule328 _lhsIinstVisitNrs _lhsInr arg_name_ _names = rule329 _isSuperfluousHigherOrderIntra arg_name_ arg_nr_ _lhsOexprs :: Exprs _lhsOexprs = rule330 _instParams _lhsIo_newtypes _lhsIunfoldSemDom _names arg_nr_ arg_nt_ _lhsOusedVars :: Set String _lhsOusedVars = rule331 _names _mkTp = rule332 _evalTp _orgParams arg_nt_ _definedTps = rule333 _mkTp arg_name_ arg_syn_ _nextTp = rule334 arg_nr_ arg_nt_ _lhsOtSigs :: [Decl] _lhsOtSigs = rule335 _definedTps _instParams _nextTp arg_isLast_ arg_name_ arg_nr_ _orgParams = rule336 _lhsIparamMap arg_nt_ _instParams = rule337 _lhsIparamInstMap arg_name_ arg_nt_ _replParamMap = rule338 _instParams _orgParams _replace = rule339 _replParamMap _evalTp = rule340 _orgParams _replace _lhsOtps :: [Type] _lhsOtps = rule341 _instParams _isSuperfluousHigherOrderIntra arg_nr_ arg_nt_ _lhsOdeclsAbove :: [Decl] _lhsOdeclsAbove = rule342 () _lhsObldBlocksFun :: DeclBlocks -> DeclBlocks _lhsObldBlocksFun = rule343 _decls _lhsIdeclsAbove _lhsOallTpsFound :: Bool _lhsOallTpsFound = rule344 () _lhsOcomments :: [String] _lhsOcomments = rule345 () _lhsOdecls :: Decls _lhsOdecls = rule346 _decls _lhsOdefinedInsts :: [Identifier] _lhsOdefinedInsts = rule347 () _lhsOvisitedSet :: Set Identifier _lhsOvisitedSet = rule348 _visitedSet __result_ = T_CRule_vOut19 _lhsOallTpsFound _lhsObldBlocksFun _lhsOcomments _lhsOdecls _lhsOdeclsAbove _lhsOdefinedInsts _lhsOexprs _lhsOtSigs _lhsOtps _lhsOusedVars _lhsOvisitedSet in __result_ ) in C_CRule_s20 v19 {-# INLINE rule324 #-} {-# LINE 147 "./src-ag/GenerateCode.ag" #-} rule324 = \ ((_lhsIvisitedSet) :: Set Identifier) name_ -> {-# LINE 147 "./src-ag/GenerateCode.ag" #-} Set.insert name_ _lhsIvisitedSet {-# LINE 2438 "dist/build/GenerateCode.hs"#-} {-# INLINE rule325 #-} {-# LINE 203 "./src-ag/GenerateCode.ag" #-} rule325 = \ ((_lhsIcon) :: ConstructorIdent) ((_lhsInt) :: NontermIdent) name_ nr_ nt_ -> {-# LINE 203 "./src-ag/GenerateCode.ag" #-} show _lhsInt ++ ":" ++ show _lhsIcon ++ ":" ++ show name_ ++ ":" ++ show nt_ ++ ":" ++ show nr_ {-# LINE 2444 "dist/build/GenerateCode.hs"#-} {-# INLINE rule326 #-} {-# LINE 204 "./src-ag/GenerateCode.ag" #-} rule326 = \ _costCentreDescr ((_lhsIo_costcentre) :: Bool) -> {-# LINE 204 "./src-ag/GenerateCode.ag" #-} \v -> if _lhsIo_costcentre then PragmaExpr True False ("SCC \"" ++ _costCentreDescr ++ "\"") v else v {-# LINE 2452 "dist/build/GenerateCode.hs"#-} {-# INLINE rule327 #-} {-# LINE 207 "./src-ag/GenerateCode.ag" #-} rule327 = \ _addCostCentre ((_lhsIaroundMap) :: Set Identifier) ((_lhsIchildren) :: [(Identifier,Type,ChildKind)]) ((_lhsImergeMap) :: Map Identifier (Identifier, [Identifier])) ((_lhsIo_monadic) :: Bool) ((_lhsIo_newtypes) :: Bool) ((_lhsIo_unbox) :: Bool) _visitedSet inh_ isLast_ name_ nr_ nt_ syn_ -> {-# LINE 207 "./src-ag/GenerateCode.ag" #-} let lhsVars = map (attrname True name_) (Map.keys syn_) ++ if isLast_ then [] else [unwrap ++ funname name_ (nr_+1)] rhsVars = map (attrname False name_) (Map.keys inh_) unwrap = if _lhsIo_newtypes then typeName nt_ (nr_ + 1) ++ " " else "" tuple | isMerging = TupleLhs [locname name_ ++ "_comp"] | otherwise = mkTupleLhs _lhsIo_unbox (null $ Map.keys inh_) lhsVars rhs = _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` _lhsImergeMap isMerging = name_ `elem` concatMap (\(_,cs) -> cs) (Map.elems _lhsImergeMap) merges = [ (c,cs) | (c,(_,cs)) <- Map.assocs _lhsImergeMap, all (`Set.member` _visitedSet ) cs, name_ `elem` (c:cs) ] baseNm = if nr_ == 0 && isVirtual name_ _lhsIchildren then Ident (getName name_ ++ "_inst") (getPos name_) else name_ fun | nr_ == 0 && Set.member name_ _lhsIaroundMap = locname name_ ++ "_around " ++ funname baseNm 0 | otherwise = funname baseNm nr_ outDecls | isMerged = [] | otherwise = if isMerging then [mkDecl _lhsIo_monadic tuple rhs Set.empty Set.empty] else [Resume _lhsIo_monadic (typeName nt_ nr_) tuple rhs] outMerged | null merges || nr_ /= 0 = [] | otherwise = let (c,cs) = head merges tuple' = mkTupleLhs _lhsIo_unbox (null $ Map.keys inh_) lhsVars' lhsVars' = map (attrname True c) (Map.keys syn_) ++ if isLast_ then [] else [unwrap ++ funname c (nr_+1)] rhsVars' = [ locname c' ++ "_comp" | c' <- cs ] fun' = locname c ++ "_merge" rhs' = App fun' (map SimpleExpr rhsVars') in [Resume _lhsIo_monadic (typeName nt_ nr_) tuple' rhs'] in (outDecls ++ outMerged) {-# LINE 2495 "dist/build/GenerateCode.hs"#-} {-# INLINE rule328 #-} {-# LINE 329 "./src-ag/GenerateCode.ag" #-} rule328 = \ ((_lhsIinstVisitNrs) :: Map Identifier Int) ((_lhsInr) :: Int) name_ -> {-# LINE 329 "./src-ag/GenerateCode.ag" #-} _lhsInr <= Map.findWithDefault (-1) name_ _lhsIinstVisitNrs {-# LINE 2501 "dist/build/GenerateCode.hs"#-} {-# INLINE rule329 #-} {-# LINE 342 "./src-ag/GenerateCode.ag" #-} rule329 = \ _isSuperfluousHigherOrderIntra name_ nr_ -> {-# LINE 342 "./src-ag/GenerateCode.ag" #-} if _isSuperfluousHigherOrderIntra then [] else [funname name_ (nr_+1)] {-# LINE 2509 "dist/build/GenerateCode.hs"#-} {-# INLINE rule330 #-} {-# LINE 346 "./src-ag/GenerateCode.ag" #-} rule330 = \ _instParams ((_lhsIo_newtypes) :: Bool) ((_lhsIunfoldSemDom) :: NontermIdent -> Int -> [String] -> Code.Type) _names nr_ nt_ -> {-# LINE 346 "./src-ag/GenerateCode.ag" #-} let wrap = if _lhsIo_newtypes then \x -> App (typeName nt_ (nr_ + 1)) [x] else id addType expr | null _instParams = expr | otherwise = TypedExpr expr (_lhsIunfoldSemDom nt_ (nr_+1) _instParams ) in map (wrap . addType . SimpleExpr) _names {-# LINE 2518 "dist/build/GenerateCode.hs"#-} {-# INLINE rule331 #-} {-# LINE 358 "./src-ag/GenerateCode.ag" #-} rule331 = \ _names -> {-# LINE 358 "./src-ag/GenerateCode.ag" #-} Set.fromList _names {-# LINE 2524 "dist/build/GenerateCode.hs"#-} {-# INLINE rule332 #-} {-# LINE 394 "./src-ag/GenerateCode.ag" #-} rule332 = \ _evalTp _orgParams nt_ -> {-# LINE 394 "./src-ag/GenerateCode.ag" #-} _evalTp . typeToCodeType (Just nt_) _orgParams {-# LINE 2530 "dist/build/GenerateCode.hs"#-} {-# INLINE rule333 #-} {-# LINE 395 "./src-ag/GenerateCode.ag" #-} rule333 = \ _mkTp name_ syn_ -> {-# LINE 395 "./src-ag/GenerateCode.ag" #-} [ TSig (attrname True name_ a) (_mkTp tp) | (a,tp) <- Map.toList syn_ ] {-# LINE 2536 "dist/build/GenerateCode.hs"#-} {-# INLINE rule334 #-} {-# LINE 396 "./src-ag/GenerateCode.ag" #-} rule334 = \ nr_ nt_ -> {-# LINE 396 "./src-ag/GenerateCode.ag" #-} typeName nt_ (nr_+1) {-# LINE 2542 "dist/build/GenerateCode.hs"#-} {-# INLINE rule335 #-} {-# LINE 397 "./src-ag/GenerateCode.ag" #-} rule335 = \ _definedTps _instParams _nextTp isLast_ name_ nr_ -> {-# LINE 397 "./src-ag/GenerateCode.ag" #-} (if isLast_ then id else (TSig (funname name_ (nr_+1)) (TypeApp (SimpleType _nextTp) (map SimpleType _instParams )) :)) _definedTps {-# LINE 2548 "dist/build/GenerateCode.hs"#-} {-# INLINE rule336 #-} {-# LINE 399 "./src-ag/GenerateCode.ag" #-} rule336 = \ ((_lhsIparamMap) :: ParamMap) nt_ -> {-# LINE 399 "./src-ag/GenerateCode.ag" #-} map getName $ Map.findWithDefault [] nt_ _lhsIparamMap {-# LINE 2554 "dist/build/GenerateCode.hs"#-} {-# INLINE rule337 #-} {-# LINE 400 "./src-ag/GenerateCode.ag" #-} rule337 = \ ((_lhsIparamInstMap) :: Map Identifier (NontermIdent, [String])) name_ nt_ -> {-# LINE 400 "./src-ag/GenerateCode.ag" #-} snd $ Map.findWithDefault (nt_,[]) name_ _lhsIparamInstMap {-# LINE 2560 "dist/build/GenerateCode.hs"#-} {-# INLINE rule338 #-} {-# LINE 401 "./src-ag/GenerateCode.ag" #-} rule338 = \ _instParams _orgParams -> {-# LINE 401 "./src-ag/GenerateCode.ag" #-} Map.fromList (zip _orgParams _instParams ) {-# LINE 2566 "dist/build/GenerateCode.hs"#-} {-# INLINE rule339 #-} {-# LINE 402 "./src-ag/GenerateCode.ag" #-} rule339 = \ _replParamMap -> {-# LINE 402 "./src-ag/GenerateCode.ag" #-} \k -> Map.findWithDefault k k _replParamMap {-# LINE 2572 "dist/build/GenerateCode.hs"#-} {-# INLINE rule340 #-} {-# LINE 403 "./src-ag/GenerateCode.ag" #-} rule340 = \ _orgParams _replace -> {-# LINE 403 "./src-ag/GenerateCode.ag" #-} if null _orgParams then id else evalType _replace {-# LINE 2578 "dist/build/GenerateCode.hs"#-} {-# INLINE rule341 #-} {-# LINE 420 "./src-ag/GenerateCode.ag" #-} rule341 = \ _instParams _isSuperfluousHigherOrderIntra nr_ nt_ -> {-# LINE 420 "./src-ag/GenerateCode.ag" #-} if _isSuperfluousHigherOrderIntra then [] else [NT (ntOfVisit nt_ (nr_+1)) _instParams False] {-# LINE 2586 "dist/build/GenerateCode.hs"#-} {-# INLINE rule342 #-} {-# LINE 620 "./src-ag/GenerateCode.ag" #-} rule342 = \ (_ :: ()) -> {-# LINE 620 "./src-ag/GenerateCode.ag" #-} [] {-# LINE 2592 "dist/build/GenerateCode.hs"#-} {-# INLINE rule343 #-} {-# LINE 633 "./src-ag/GenerateCode.ag" #-} rule343 = \ _decls ((_lhsIdeclsAbove) :: [Decl]) -> {-# LINE 633 "./src-ag/GenerateCode.ag" #-} DeclBlock _lhsIdeclsAbove (head _decls ) {-# LINE 2598 "dist/build/GenerateCode.hs"#-} {-# INLINE rule344 #-} rule344 = \ (_ :: ()) -> True {-# INLINE rule345 #-} rule345 = \ (_ :: ()) -> [] {-# INLINE rule346 #-} rule346 = \ _decls -> _decls {-# INLINE rule347 #-} rule347 = \ (_ :: ()) -> [] {-# INLINE rule348 #-} rule348 = \ _visitedSet -> _visitedSet -- CSegment ---------------------------------------------------- -- wrapper data Inh_CSegment = Inh_CSegment { inh_Inh_CSegment :: (Attributes), isLast_Inh_CSegment :: (Bool), nr_Inh_CSegment :: (Int), nt_Inh_CSegment :: (NontermIdent), o_case_Inh_CSegment :: (Bool), o_cata_Inh_CSegment :: (Bool), o_costcentre_Inh_CSegment :: (Bool), o_data_Inh_CSegment :: (Maybe Bool), o_linePragmas_Inh_CSegment :: (Bool), o_monadic_Inh_CSegment :: (Bool), o_newtypes_Inh_CSegment :: (Bool), o_pretty_Inh_CSegment :: (Bool), o_rename_Inh_CSegment :: (Bool), o_sem_Inh_CSegment :: (Bool), o_sig_Inh_CSegment :: (Bool), o_splitsems_Inh_CSegment :: (Bool), o_strictwrap_Inh_CSegment :: (Bool), o_traces_Inh_CSegment :: (Bool), o_unbox_Inh_CSegment :: (Bool), options_Inh_CSegment :: (Options), paramMap_Inh_CSegment :: (ParamMap), prefix_Inh_CSegment :: (String), syn_Inh_CSegment :: (Attributes) } data Syn_CSegment = Syn_CSegment { comments_Syn_CSegment :: ([String]), semDom_Syn_CSegment :: ([Decl]), semDomUnfoldGath_Syn_CSegment :: (Map (NontermIdent, Int) ([String], Code.Type)), wrapDecls_Syn_CSegment :: (Decls) } {-# INLINABLE wrap_CSegment #-} wrap_CSegment :: T_CSegment -> Inh_CSegment -> (Syn_CSegment ) wrap_CSegment (T_CSegment act) (Inh_CSegment _lhsIinh _lhsIisLast _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIsyn) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_CSegment_vIn22 _lhsIinh _lhsIisLast _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIsyn (T_CSegment_vOut22 _lhsOcomments _lhsOsemDom _lhsOsemDomUnfoldGath _lhsOwrapDecls) <- return (inv_CSegment_s23 sem arg) return (Syn_CSegment _lhsOcomments _lhsOsemDom _lhsOsemDomUnfoldGath _lhsOwrapDecls) ) -- cata {-# INLINE sem_CSegment #-} sem_CSegment :: CSegment -> T_CSegment sem_CSegment ( CSegment inh_ syn_ ) = sem_CSegment_CSegment inh_ syn_ -- semantic domain newtype T_CSegment = T_CSegment { attach_T_CSegment :: Identity (T_CSegment_s23 ) } newtype T_CSegment_s23 = C_CSegment_s23 { inv_CSegment_s23 :: (T_CSegment_v22 ) } data T_CSegment_s24 = C_CSegment_s24 type T_CSegment_v22 = (T_CSegment_vIn22 ) -> (T_CSegment_vOut22 ) data T_CSegment_vIn22 = T_CSegment_vIn22 (Attributes) (Bool) (Int) (NontermIdent) (Bool) (Bool) (Bool) (Maybe Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Options) (ParamMap) (String) (Attributes) data T_CSegment_vOut22 = T_CSegment_vOut22 ([String]) ([Decl]) (Map (NontermIdent, Int) ([String], Code.Type)) (Decls) {-# NOINLINE sem_CSegment_CSegment #-} sem_CSegment_CSegment :: (Attributes) -> (Attributes) -> T_CSegment sem_CSegment_CSegment arg_inh_ arg_syn_ = T_CSegment (return st23) where {-# NOINLINE st23 #-} st23 = let v22 :: T_CSegment_v22 v22 = \ (T_CSegment_vIn22 _lhsIinh _lhsIisLast _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIsyn) -> ( let _altSemForm = rule349 _lhsIoptions _tp = rule350 _altSemForm _indexExpr _inhTps _synTps _inhTps = rule351 _lhsInt _params arg_inh_ _inhTup = rule352 _inhTps _lhsIo_unbox _synTps = rule353 _continuation _inhTps _lhsInt _lhsIo_unbox _params arg_syn_ _curTypeName = rule354 _lhsInr _lhsInt _nextTypeName = rule355 _lhsInr _lhsInt _indexName = rule356 _curTypeName _dataIndex = rule357 _indexName _params _indexExpr = rule358 _indexName _params _indexStr = rule359 _indexName _params _inhInstance = rule360 _indexStr _inhTup _lhsInr _lhsInt _synInstance = rule361 _indexStr _lhsInr _lhsInt _synTps _continuation = rule362 _lhsIisLast _nextTypeName _params _params = rule363 _lhsInt _lhsIparamMap _lhsOsemDom :: [Decl] _lhsOsemDom = rule364 _altSemForm _dataIndex _inhInstance _lhsInr _lhsInt _lhsIo_newtypes _params _synInstance _tp _lhsOsemDomUnfoldGath :: Map (NontermIdent, Int) ([String], Code.Type) _lhsOsemDomUnfoldGath = rule365 _lhsInr _lhsInt _params _tp _lhsOwrapDecls :: Decls _lhsOwrapDecls = rule366 _lhsIisLast _lhsInr _lhsInt _lhsIo_newtypes _lhsIo_unbox arg_inh_ arg_syn_ _lhsOcomments :: [String] _lhsOcomments = rule367 _lhsInr arg_inh_ arg_syn_ __result_ = T_CSegment_vOut22 _lhsOcomments _lhsOsemDom _lhsOsemDomUnfoldGath _lhsOwrapDecls in __result_ ) in C_CSegment_s23 v22 {-# INLINE rule349 #-} {-# LINE 717 "./src-ag/GenerateCode.ag" #-} rule349 = \ ((_lhsIoptions) :: Options) -> {-# LINE 717 "./src-ag/GenerateCode.ag" #-} breadthFirst _lhsIoptions {-# LINE 2683 "dist/build/GenerateCode.hs"#-} {-# INLINE rule350 #-} {-# LINE 718 "./src-ag/GenerateCode.ag" #-} rule350 = \ _altSemForm _indexExpr _inhTps _synTps -> {-# LINE 718 "./src-ag/GenerateCode.ag" #-} if _altSemForm then TypeApp (SimpleType "Child") [SimpleType "EvalInfo", _indexExpr ] else foldr Arr _synTps _inhTps {-# LINE 2691 "dist/build/GenerateCode.hs"#-} {-# INLINE rule351 #-} {-# LINE 721 "./src-ag/GenerateCode.ag" #-} rule351 = \ ((_lhsInt) :: NontermIdent) _params inh_ -> {-# LINE 721 "./src-ag/GenerateCode.ag" #-} [typeToCodeType (Just _lhsInt) _params tp | tp <- Map.elems inh_] {-# LINE 2697 "dist/build/GenerateCode.hs"#-} {-# INLINE rule352 #-} {-# LINE 722 "./src-ag/GenerateCode.ag" #-} rule352 = \ _inhTps ((_lhsIo_unbox) :: Bool) -> {-# LINE 722 "./src-ag/GenerateCode.ag" #-} mkTupleType _lhsIo_unbox (null _inhTps ) _inhTps {-# LINE 2703 "dist/build/GenerateCode.hs"#-} {-# INLINE rule353 #-} {-# LINE 723 "./src-ag/GenerateCode.ag" #-} rule353 = \ _continuation _inhTps ((_lhsInt) :: NontermIdent) ((_lhsIo_unbox) :: Bool) _params syn_ -> {-# LINE 723 "./src-ag/GenerateCode.ag" #-} mkTupleType _lhsIo_unbox (null _inhTps ) ([typeToCodeType (Just _lhsInt) _params tp | tp <- Map.elems syn_] ++ _continuation ) {-# LINE 2709 "dist/build/GenerateCode.hs"#-} {-# INLINE rule354 #-} {-# LINE 724 "./src-ag/GenerateCode.ag" #-} rule354 = \ ((_lhsInr) :: Int) ((_lhsInt) :: NontermIdent) -> {-# LINE 724 "./src-ag/GenerateCode.ag" #-} typeName _lhsInt _lhsInr {-# LINE 2715 "dist/build/GenerateCode.hs"#-} {-# INLINE rule355 #-} {-# LINE 725 "./src-ag/GenerateCode.ag" #-} rule355 = \ ((_lhsInr) :: Int) ((_lhsInt) :: NontermIdent) -> {-# LINE 725 "./src-ag/GenerateCode.ag" #-} typeName _lhsInt (_lhsInr + 1) {-# LINE 2721 "dist/build/GenerateCode.hs"#-} {-# INLINE rule356 #-} {-# LINE 726 "./src-ag/GenerateCode.ag" #-} rule356 = \ _curTypeName -> {-# LINE 726 "./src-ag/GenerateCode.ag" #-} "I_" ++ _curTypeName {-# LINE 2727 "dist/build/GenerateCode.hs"#-} {-# INLINE rule357 #-} {-# LINE 727 "./src-ag/GenerateCode.ag" #-} rule357 = \ _indexName _params -> {-# LINE 727 "./src-ag/GenerateCode.ag" #-} Code.Data _indexName _params [DataAlt _indexName []] False [] {-# LINE 2733 "dist/build/GenerateCode.hs"#-} {-# INLINE rule358 #-} {-# LINE 728 "./src-ag/GenerateCode.ag" #-} rule358 = \ _indexName _params -> {-# LINE 728 "./src-ag/GenerateCode.ag" #-} TypeApp (SimpleType _indexName ) (map (SimpleType . ('@':)) _params ) {-# LINE 2739 "dist/build/GenerateCode.hs"#-} {-# INLINE rule359 #-} {-# LINE 729 "./src-ag/GenerateCode.ag" #-} rule359 = \ _indexName _params -> {-# LINE 729 "./src-ag/GenerateCode.ag" #-} "(" ++ _indexName ++ concatMap (\p -> " " ++ p) _params ++ ")" {-# LINE 2745 "dist/build/GenerateCode.hs"#-} {-# INLINE rule360 #-} {-# LINE 730 "./src-ag/GenerateCode.ag" #-} rule360 = \ _indexStr _inhTup ((_lhsInr) :: Int) ((_lhsInt) :: NontermIdent) -> {-# LINE 730 "./src-ag/GenerateCode.ag" #-} Code.Data "instance Inh" [_indexStr ] [DataAlt (typeName _lhsInt _lhsInr ++ "_Inh") [_inhTup ] ] False [] {-# LINE 2751 "dist/build/GenerateCode.hs"#-} {-# INLINE rule361 #-} {-# LINE 731 "./src-ag/GenerateCode.ag" #-} rule361 = \ _indexStr ((_lhsInr) :: Int) ((_lhsInt) :: NontermIdent) _synTps -> {-# LINE 731 "./src-ag/GenerateCode.ag" #-} Code.Data "instance Syn" [_indexStr ] [DataAlt (typeName _lhsInt _lhsInr ++ "_Syn") [_synTps ] ] False [] {-# LINE 2757 "dist/build/GenerateCode.hs"#-} {-# INLINE rule362 #-} {-# LINE 732 "./src-ag/GenerateCode.ag" #-} rule362 = \ ((_lhsIisLast) :: Bool) _nextTypeName _params -> {-# LINE 732 "./src-ag/GenerateCode.ag" #-} if _lhsIisLast then [] else [TypeApp (SimpleType _nextTypeName ) (map (SimpleType . ('@':)) _params )] {-# LINE 2765 "dist/build/GenerateCode.hs"#-} {-# INLINE rule363 #-} {-# LINE 735 "./src-ag/GenerateCode.ag" #-} rule363 = \ ((_lhsInt) :: NontermIdent) ((_lhsIparamMap) :: ParamMap) -> {-# LINE 735 "./src-ag/GenerateCode.ag" #-} map getName $ Map.findWithDefault [] _lhsInt _lhsIparamMap {-# LINE 2771 "dist/build/GenerateCode.hs"#-} {-# INLINE rule364 #-} {-# LINE 736 "./src-ag/GenerateCode.ag" #-} rule364 = \ _altSemForm _dataIndex _inhInstance ((_lhsInr) :: Int) ((_lhsInt) :: NontermIdent) ((_lhsIo_newtypes) :: Bool) _params _synInstance _tp -> {-# LINE 736 "./src-ag/GenerateCode.ag" #-} let name = typeName _lhsInt _lhsInr evalTp | null _params = id | otherwise = idEvalType in ( if _lhsIo_newtypes then [ Code.NewType name _params name (evalTp _tp ) ] else [ Code.Type name _params (evalTp _tp ) ] ) ++ ( if _altSemForm then [_dataIndex , _inhInstance , _synInstance ] else [] ) {-# LINE 2785 "dist/build/GenerateCode.hs"#-} {-# INLINE rule365 #-} {-# LINE 750 "./src-ag/GenerateCode.ag" #-} rule365 = \ ((_lhsInr) :: Int) ((_lhsInt) :: NontermIdent) _params _tp -> {-# LINE 750 "./src-ag/GenerateCode.ag" #-} Map.singleton (_lhsInt, _lhsInr) (_params , _tp ) {-# LINE 2791 "dist/build/GenerateCode.hs"#-} {-# INLINE rule366 #-} {-# LINE 834 "./src-ag/GenerateCode.ag" #-} rule366 = \ ((_lhsIisLast) :: Bool) ((_lhsInr) :: Int) ((_lhsInt) :: NontermIdent) ((_lhsIo_newtypes) :: Bool) ((_lhsIo_unbox) :: Bool) inh_ syn_ -> {-# LINE 834 "./src-ag/GenerateCode.ag" #-} let lhsVars = map (lhsname False) (Map.keys syn_) ++ if _lhsIisLast then [] else [unwrap ++ sem (_lhsInr+1)] rhsVars = map (lhsname True) (Map.keys inh_) rhs = map SimpleExpr rhsVars unwrap = if _lhsIo_newtypes then typeName _lhsInt (_lhsInr + 1) ++ " " else "" var = "sem" sem 0 = var sem n = var ++ "_" ++ show n ntt = typeName _lhsInt _lhsInr in [ EvalDecl ntt (mkTupleLhs _lhsIo_unbox (null $ Map.keys inh_) lhsVars) (InvokeExpr ntt (SimpleExpr $ sem _lhsInr) rhs) ] {-# LINE 2806 "dist/build/GenerateCode.hs"#-} {-# INLINE rule367 #-} {-# LINE 876 "./src-ag/GenerateCode.ag" #-} rule367 = \ ((_lhsInr) :: Int) inh_ syn_ -> {-# LINE 876 "./src-ag/GenerateCode.ag" #-} let body = map ind (showsSegment (CSegment inh_ syn_)) in if null body then [] else ("visit " ++ show _lhsInr ++ ":") : body {-# LINE 2815 "dist/build/GenerateCode.hs"#-} -- CSegments --------------------------------------------------- -- wrapper data Inh_CSegments = Inh_CSegments { inh_Inh_CSegments :: (Attributes), nr_Inh_CSegments :: (Int), nt_Inh_CSegments :: (NontermIdent), o_case_Inh_CSegments :: (Bool), o_cata_Inh_CSegments :: (Bool), o_costcentre_Inh_CSegments :: (Bool), o_data_Inh_CSegments :: (Maybe Bool), o_linePragmas_Inh_CSegments :: (Bool), o_monadic_Inh_CSegments :: (Bool), o_newtypes_Inh_CSegments :: (Bool), o_pretty_Inh_CSegments :: (Bool), o_rename_Inh_CSegments :: (Bool), o_sem_Inh_CSegments :: (Bool), o_sig_Inh_CSegments :: (Bool), o_splitsems_Inh_CSegments :: (Bool), o_strictwrap_Inh_CSegments :: (Bool), o_traces_Inh_CSegments :: (Bool), o_unbox_Inh_CSegments :: (Bool), options_Inh_CSegments :: (Options), paramMap_Inh_CSegments :: (ParamMap), prefix_Inh_CSegments :: (String), syn_Inh_CSegments :: (Attributes) } data Syn_CSegments = Syn_CSegments { comments_Syn_CSegments :: ([String]), isNil_Syn_CSegments :: (Bool), semDom_Syn_CSegments :: ([Decl]), semDomUnfoldGath_Syn_CSegments :: (Map (NontermIdent, Int) ([String], Code.Type)), wrapDecls_Syn_CSegments :: (Decls) } {-# INLINABLE wrap_CSegments #-} wrap_CSegments :: T_CSegments -> Inh_CSegments -> (Syn_CSegments ) wrap_CSegments (T_CSegments act) (Inh_CSegments _lhsIinh _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIsyn) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_CSegments_vIn25 _lhsIinh _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIsyn (T_CSegments_vOut25 _lhsOcomments _lhsOisNil _lhsOsemDom _lhsOsemDomUnfoldGath _lhsOwrapDecls) <- return (inv_CSegments_s26 sem arg) return (Syn_CSegments _lhsOcomments _lhsOisNil _lhsOsemDom _lhsOsemDomUnfoldGath _lhsOwrapDecls) ) -- cata {-# NOINLINE sem_CSegments #-} sem_CSegments :: CSegments -> T_CSegments sem_CSegments list = Prelude.foldr sem_CSegments_Cons sem_CSegments_Nil (Prelude.map sem_CSegment list) -- semantic domain newtype T_CSegments = T_CSegments { attach_T_CSegments :: Identity (T_CSegments_s26 ) } newtype T_CSegments_s26 = C_CSegments_s26 { inv_CSegments_s26 :: (T_CSegments_v25 ) } data T_CSegments_s27 = C_CSegments_s27 type T_CSegments_v25 = (T_CSegments_vIn25 ) -> (T_CSegments_vOut25 ) data T_CSegments_vIn25 = T_CSegments_vIn25 (Attributes) (Int) (NontermIdent) (Bool) (Bool) (Bool) (Maybe Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Options) (ParamMap) (String) (Attributes) data T_CSegments_vOut25 = T_CSegments_vOut25 ([String]) (Bool) ([Decl]) (Map (NontermIdent, Int) ([String], Code.Type)) (Decls) {-# NOINLINE sem_CSegments_Cons #-} sem_CSegments_Cons :: T_CSegment -> T_CSegments -> T_CSegments sem_CSegments_Cons arg_hd_ arg_tl_ = T_CSegments (return st26) where {-# NOINLINE st26 #-} st26 = let v25 :: T_CSegments_v25 v25 = \ (T_CSegments_vIn25 _lhsIinh _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIsyn) -> ( let _hdX23 = Control.Monad.Identity.runIdentity (attach_T_CSegment (arg_hd_)) _tlX26 = Control.Monad.Identity.runIdentity (attach_T_CSegments (arg_tl_)) (T_CSegment_vOut22 _hdIcomments _hdIsemDom _hdIsemDomUnfoldGath _hdIwrapDecls) = inv_CSegment_s23 _hdX23 (T_CSegment_vIn22 _hdOinh _hdOisLast _hdOnr _hdOnt _hdOo_case _hdOo_cata _hdOo_costcentre _hdOo_data _hdOo_linePragmas _hdOo_monadic _hdOo_newtypes _hdOo_pretty _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_splitsems _hdOo_strictwrap _hdOo_traces _hdOo_unbox _hdOoptions _hdOparamMap _hdOprefix _hdOsyn) (T_CSegments_vOut25 _tlIcomments _tlIisNil _tlIsemDom _tlIsemDomUnfoldGath _tlIwrapDecls) = inv_CSegments_s26 _tlX26 (T_CSegments_vIn25 _tlOinh _tlOnr _tlOnt _tlOo_case _tlOo_cata _tlOo_costcentre _tlOo_data _tlOo_linePragmas _tlOo_monadic _tlOo_newtypes _tlOo_pretty _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_splitsems _tlOo_strictwrap _tlOo_traces _tlOo_unbox _tlOoptions _tlOparamMap _tlOprefix _tlOsyn) _tlOnr = rule368 _lhsInr _lhsOisNil :: Bool _lhsOisNil = rule369 () _hdOisLast = rule370 _tlIisNil _lhsOcomments :: [String] _lhsOcomments = rule371 _hdIcomments _tlIcomments _lhsOsemDom :: [Decl] _lhsOsemDom = rule372 _hdIsemDom _tlIsemDom _lhsOsemDomUnfoldGath :: Map (NontermIdent, Int) ([String], Code.Type) _lhsOsemDomUnfoldGath = rule373 _hdIsemDomUnfoldGath _tlIsemDomUnfoldGath _lhsOwrapDecls :: Decls _lhsOwrapDecls = rule374 _hdIwrapDecls _tlIwrapDecls _hdOinh = rule375 _lhsIinh _hdOnr = rule376 _lhsInr _hdOnt = rule377 _lhsInt _hdOo_case = rule378 _lhsIo_case _hdOo_cata = rule379 _lhsIo_cata _hdOo_costcentre = rule380 _lhsIo_costcentre _hdOo_data = rule381 _lhsIo_data _hdOo_linePragmas = rule382 _lhsIo_linePragmas _hdOo_monadic = rule383 _lhsIo_monadic _hdOo_newtypes = rule384 _lhsIo_newtypes _hdOo_pretty = rule385 _lhsIo_pretty _hdOo_rename = rule386 _lhsIo_rename _hdOo_sem = rule387 _lhsIo_sem _hdOo_sig = rule388 _lhsIo_sig _hdOo_splitsems = rule389 _lhsIo_splitsems _hdOo_strictwrap = rule390 _lhsIo_strictwrap _hdOo_traces = rule391 _lhsIo_traces _hdOo_unbox = rule392 _lhsIo_unbox _hdOoptions = rule393 _lhsIoptions _hdOparamMap = rule394 _lhsIparamMap _hdOprefix = rule395 _lhsIprefix _hdOsyn = rule396 _lhsIsyn _tlOinh = rule397 _lhsIinh _tlOnt = rule398 _lhsInt _tlOo_case = rule399 _lhsIo_case _tlOo_cata = rule400 _lhsIo_cata _tlOo_costcentre = rule401 _lhsIo_costcentre _tlOo_data = rule402 _lhsIo_data _tlOo_linePragmas = rule403 _lhsIo_linePragmas _tlOo_monadic = rule404 _lhsIo_monadic _tlOo_newtypes = rule405 _lhsIo_newtypes _tlOo_pretty = rule406 _lhsIo_pretty _tlOo_rename = rule407 _lhsIo_rename _tlOo_sem = rule408 _lhsIo_sem _tlOo_sig = rule409 _lhsIo_sig _tlOo_splitsems = rule410 _lhsIo_splitsems _tlOo_strictwrap = rule411 _lhsIo_strictwrap _tlOo_traces = rule412 _lhsIo_traces _tlOo_unbox = rule413 _lhsIo_unbox _tlOoptions = rule414 _lhsIoptions _tlOparamMap = rule415 _lhsIparamMap _tlOprefix = rule416 _lhsIprefix _tlOsyn = rule417 _lhsIsyn __result_ = T_CSegments_vOut25 _lhsOcomments _lhsOisNil _lhsOsemDom _lhsOsemDomUnfoldGath _lhsOwrapDecls in __result_ ) in C_CSegments_s26 v25 {-# INLINE rule368 #-} {-# LINE 287 "./src-ag/GenerateCode.ag" #-} rule368 = \ ((_lhsInr) :: Int) -> {-# LINE 287 "./src-ag/GenerateCode.ag" #-} _lhsInr + 1 {-# LINE 2921 "dist/build/GenerateCode.hs"#-} {-# INLINE rule369 #-} {-# LINE 300 "./src-ag/GenerateCode.ag" #-} rule369 = \ (_ :: ()) -> {-# LINE 300 "./src-ag/GenerateCode.ag" #-} False {-# LINE 2927 "dist/build/GenerateCode.hs"#-} {-# INLINE rule370 #-} {-# LINE 301 "./src-ag/GenerateCode.ag" #-} rule370 = \ ((_tlIisNil) :: Bool) -> {-# LINE 301 "./src-ag/GenerateCode.ag" #-} _tlIisNil {-# LINE 2933 "dist/build/GenerateCode.hs"#-} {-# INLINE rule371 #-} rule371 = \ ((_hdIcomments) :: [String]) ((_tlIcomments) :: [String]) -> _hdIcomments ++ _tlIcomments {-# INLINE rule372 #-} rule372 = \ ((_hdIsemDom) :: [Decl]) ((_tlIsemDom) :: [Decl]) -> _hdIsemDom ++ _tlIsemDom {-# INLINE rule373 #-} rule373 = \ ((_hdIsemDomUnfoldGath) :: Map (NontermIdent, Int) ([String], Code.Type)) ((_tlIsemDomUnfoldGath) :: Map (NontermIdent, Int) ([String], Code.Type)) -> _hdIsemDomUnfoldGath `Map.union` _tlIsemDomUnfoldGath {-# INLINE rule374 #-} rule374 = \ ((_hdIwrapDecls) :: Decls) ((_tlIwrapDecls) :: Decls) -> _hdIwrapDecls ++ _tlIwrapDecls {-# INLINE rule375 #-} rule375 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule376 #-} rule376 = \ ((_lhsInr) :: Int) -> _lhsInr {-# INLINE rule377 #-} rule377 = \ ((_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule378 #-} rule378 = \ ((_lhsIo_case) :: Bool) -> _lhsIo_case {-# INLINE rule379 #-} rule379 = \ ((_lhsIo_cata) :: Bool) -> _lhsIo_cata {-# INLINE rule380 #-} rule380 = \ ((_lhsIo_costcentre) :: Bool) -> _lhsIo_costcentre {-# INLINE rule381 #-} rule381 = \ ((_lhsIo_data) :: Maybe Bool) -> _lhsIo_data {-# INLINE rule382 #-} rule382 = \ ((_lhsIo_linePragmas) :: Bool) -> _lhsIo_linePragmas {-# INLINE rule383 #-} rule383 = \ ((_lhsIo_monadic) :: Bool) -> _lhsIo_monadic {-# INLINE rule384 #-} rule384 = \ ((_lhsIo_newtypes) :: Bool) -> _lhsIo_newtypes {-# INLINE rule385 #-} rule385 = \ ((_lhsIo_pretty) :: Bool) -> _lhsIo_pretty {-# INLINE rule386 #-} rule386 = \ ((_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# INLINE rule387 #-} rule387 = \ ((_lhsIo_sem) :: Bool) -> _lhsIo_sem {-# INLINE rule388 #-} rule388 = \ ((_lhsIo_sig) :: Bool) -> _lhsIo_sig {-# INLINE rule389 #-} rule389 = \ ((_lhsIo_splitsems) :: Bool) -> _lhsIo_splitsems {-# INLINE rule390 #-} rule390 = \ ((_lhsIo_strictwrap) :: Bool) -> _lhsIo_strictwrap {-# INLINE rule391 #-} rule391 = \ ((_lhsIo_traces) :: Bool) -> _lhsIo_traces {-# INLINE rule392 #-} rule392 = \ ((_lhsIo_unbox) :: Bool) -> _lhsIo_unbox {-# INLINE rule393 #-} rule393 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule394 #-} rule394 = \ ((_lhsIparamMap) :: ParamMap) -> _lhsIparamMap {-# INLINE rule395 #-} rule395 = \ ((_lhsIprefix) :: String) -> _lhsIprefix {-# INLINE rule396 #-} rule396 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# INLINE rule397 #-} rule397 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule398 #-} rule398 = \ ((_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule399 #-} rule399 = \ ((_lhsIo_case) :: Bool) -> _lhsIo_case {-# INLINE rule400 #-} rule400 = \ ((_lhsIo_cata) :: Bool) -> _lhsIo_cata {-# INLINE rule401 #-} rule401 = \ ((_lhsIo_costcentre) :: Bool) -> _lhsIo_costcentre {-# INLINE rule402 #-} rule402 = \ ((_lhsIo_data) :: Maybe Bool) -> _lhsIo_data {-# INLINE rule403 #-} rule403 = \ ((_lhsIo_linePragmas) :: Bool) -> _lhsIo_linePragmas {-# INLINE rule404 #-} rule404 = \ ((_lhsIo_monadic) :: Bool) -> _lhsIo_monadic {-# INLINE rule405 #-} rule405 = \ ((_lhsIo_newtypes) :: Bool) -> _lhsIo_newtypes {-# INLINE rule406 #-} rule406 = \ ((_lhsIo_pretty) :: Bool) -> _lhsIo_pretty {-# INLINE rule407 #-} rule407 = \ ((_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# INLINE rule408 #-} rule408 = \ ((_lhsIo_sem) :: Bool) -> _lhsIo_sem {-# INLINE rule409 #-} rule409 = \ ((_lhsIo_sig) :: Bool) -> _lhsIo_sig {-# INLINE rule410 #-} rule410 = \ ((_lhsIo_splitsems) :: Bool) -> _lhsIo_splitsems {-# INLINE rule411 #-} rule411 = \ ((_lhsIo_strictwrap) :: Bool) -> _lhsIo_strictwrap {-# INLINE rule412 #-} rule412 = \ ((_lhsIo_traces) :: Bool) -> _lhsIo_traces {-# INLINE rule413 #-} rule413 = \ ((_lhsIo_unbox) :: Bool) -> _lhsIo_unbox {-# INLINE rule414 #-} rule414 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule415 #-} rule415 = \ ((_lhsIparamMap) :: ParamMap) -> _lhsIparamMap {-# INLINE rule416 #-} rule416 = \ ((_lhsIprefix) :: String) -> _lhsIprefix {-# INLINE rule417 #-} rule417 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# NOINLINE sem_CSegments_Nil #-} sem_CSegments_Nil :: T_CSegments sem_CSegments_Nil = T_CSegments (return st26) where {-# NOINLINE st26 #-} st26 = let v25 :: T_CSegments_v25 v25 = \ (T_CSegments_vIn25 _lhsIinh _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIsyn) -> ( let _lhsOisNil :: Bool _lhsOisNil = rule418 () _lhsOcomments :: [String] _lhsOcomments = rule419 () _lhsOsemDom :: [Decl] _lhsOsemDom = rule420 () _lhsOsemDomUnfoldGath :: Map (NontermIdent, Int) ([String], Code.Type) _lhsOsemDomUnfoldGath = rule421 () _lhsOwrapDecls :: Decls _lhsOwrapDecls = rule422 () __result_ = T_CSegments_vOut25 _lhsOcomments _lhsOisNil _lhsOsemDom _lhsOsemDomUnfoldGath _lhsOwrapDecls in __result_ ) in C_CSegments_s26 v25 {-# INLINE rule418 #-} {-# LINE 302 "./src-ag/GenerateCode.ag" #-} rule418 = \ (_ :: ()) -> {-# LINE 302 "./src-ag/GenerateCode.ag" #-} True {-# LINE 3100 "dist/build/GenerateCode.hs"#-} {-# INLINE rule419 #-} rule419 = \ (_ :: ()) -> [] {-# INLINE rule420 #-} rule420 = \ (_ :: ()) -> [] {-# INLINE rule421 #-} rule421 = \ (_ :: ()) -> Map.empty {-# INLINE rule422 #-} rule422 = \ (_ :: ()) -> [] -- CVisit ------------------------------------------------------ -- wrapper data Inh_CVisit = Inh_CVisit { allNts_Inh_CVisit :: (Set NontermIdent), allPragmas_Inh_CVisit :: (PragmaMap), aroundMap_Inh_CVisit :: (Set Identifier), children_Inh_CVisit :: ([(Identifier,Type, ChildKind)]), con_Inh_CVisit :: (ConstructorIdent), contextMap_Inh_CVisit :: (ContextMap), decls_Inh_CVisit :: (Decls), inh_Inh_CVisit :: (Attributes), instVisitNrs_Inh_CVisit :: (Map Identifier Int), isLast_Inh_CVisit :: (Bool), mergeMap_Inh_CVisit :: (Map Identifier (Identifier, [Identifier])), nextIntra_Inh_CVisit :: (Exprs), nextIntraVars_Inh_CVisit :: (Set String), nr_Inh_CVisit :: (Int), nt_Inh_CVisit :: (NontermIdent), o_case_Inh_CVisit :: (Bool), o_cata_Inh_CVisit :: (Bool), o_costcentre_Inh_CVisit :: (Bool), o_data_Inh_CVisit :: (Maybe Bool), o_linePragmas_Inh_CVisit :: (Bool), o_monadic_Inh_CVisit :: (Bool), o_newtypes_Inh_CVisit :: (Bool), o_pretty_Inh_CVisit :: (Bool), o_rename_Inh_CVisit :: (Bool), o_sem_Inh_CVisit :: (Bool), o_sig_Inh_CVisit :: (Bool), o_splitsems_Inh_CVisit :: (Bool), o_strictwrap_Inh_CVisit :: (Bool), o_traces_Inh_CVisit :: (Bool), o_unbox_Inh_CVisit :: (Bool), options_Inh_CVisit :: (Options), paramInstMap_Inh_CVisit :: (Map Identifier (NontermIdent, [String])), paramMap_Inh_CVisit :: (ParamMap), prefix_Inh_CVisit :: (String), quantMap_Inh_CVisit :: (QuantMap), syn_Inh_CVisit :: (Attributes), terminals_Inh_CVisit :: ([Identifier]), unfoldSemDom_Inh_CVisit :: (NontermIdent -> Int -> [String] -> Code.Type), visitedSet_Inh_CVisit :: (Set Identifier), with_sig_Inh_CVisit :: (Bool), wrappers_Inh_CVisit :: (Set NontermIdent) } data Syn_CVisit = Syn_CVisit { comments_Syn_CVisit :: ([String]), decls_Syn_CVisit :: (Decls), gatherInstVisitNrs_Syn_CVisit :: (Map Identifier Int), intra_Syn_CVisit :: (Exprs), intraVars_Syn_CVisit :: (Set String), semNames_Syn_CVisit :: ([String]), visitedSet_Syn_CVisit :: (Set Identifier) } {-# INLINABLE wrap_CVisit #-} wrap_CVisit :: T_CVisit -> Inh_CVisit -> (Syn_CVisit ) wrap_CVisit (T_CVisit act) (Inh_CVisit _lhsIallNts _lhsIallPragmas _lhsIaroundMap _lhsIchildren _lhsIcon _lhsIcontextMap _lhsIdecls _lhsIinh _lhsIinstVisitNrs _lhsIisLast _lhsImergeMap _lhsInextIntra _lhsInextIntraVars _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamInstMap _lhsIparamMap _lhsIprefix _lhsIquantMap _lhsIsyn _lhsIterminals _lhsIunfoldSemDom _lhsIvisitedSet _lhsIwith_sig _lhsIwrappers) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_CVisit_vIn28 _lhsIallNts _lhsIallPragmas _lhsIaroundMap _lhsIchildren _lhsIcon _lhsIcontextMap _lhsIdecls _lhsIinh _lhsIinstVisitNrs _lhsIisLast _lhsImergeMap _lhsInextIntra _lhsInextIntraVars _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamInstMap _lhsIparamMap _lhsIprefix _lhsIquantMap _lhsIsyn _lhsIterminals _lhsIunfoldSemDom _lhsIvisitedSet _lhsIwith_sig _lhsIwrappers (T_CVisit_vOut28 _lhsOcomments _lhsOdecls _lhsOgatherInstVisitNrs _lhsOintra _lhsOintraVars _lhsOsemNames _lhsOvisitedSet) <- return (inv_CVisit_s29 sem arg) return (Syn_CVisit _lhsOcomments _lhsOdecls _lhsOgatherInstVisitNrs _lhsOintra _lhsOintraVars _lhsOsemNames _lhsOvisitedSet) ) -- cata {-# INLINE sem_CVisit #-} sem_CVisit :: CVisit -> T_CVisit sem_CVisit ( CVisit inh_ syn_ vss_ intra_ ordered_ ) = sem_CVisit_CVisit inh_ syn_ ( sem_Sequence vss_ ) ( sem_Sequence intra_ ) ordered_ -- semantic domain newtype T_CVisit = T_CVisit { attach_T_CVisit :: Identity (T_CVisit_s29 ) } newtype T_CVisit_s29 = C_CVisit_s29 { inv_CVisit_s29 :: (T_CVisit_v28 ) } data T_CVisit_s30 = C_CVisit_s30 type T_CVisit_v28 = (T_CVisit_vIn28 ) -> (T_CVisit_vOut28 ) data T_CVisit_vIn28 = T_CVisit_vIn28 (Set NontermIdent) (PragmaMap) (Set Identifier) ([(Identifier,Type, ChildKind)]) (ConstructorIdent) (ContextMap) (Decls) (Attributes) (Map Identifier Int) (Bool) (Map Identifier (Identifier, [Identifier])) (Exprs) (Set String) (Int) (NontermIdent) (Bool) (Bool) (Bool) (Maybe Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Options) (Map Identifier (NontermIdent, [String])) (ParamMap) (String) (QuantMap) (Attributes) ([Identifier]) (NontermIdent -> Int -> [String] -> Code.Type) (Set Identifier) (Bool) (Set NontermIdent) data T_CVisit_vOut28 = T_CVisit_vOut28 ([String]) (Decls) (Map Identifier Int) (Exprs) (Set String) ([String]) (Set Identifier) {-# NOINLINE sem_CVisit_CVisit #-} sem_CVisit_CVisit :: (Attributes) -> (Attributes) -> T_Sequence -> T_Sequence -> (Bool) -> T_CVisit sem_CVisit_CVisit arg_inh_ arg_syn_ arg_vss_ arg_intra_ arg_ordered_ = T_CVisit (return st29) where {-# NOINLINE st29 #-} st29 = let v28 :: T_CVisit_v28 v28 = \ (T_CVisit_vIn28 _lhsIallNts _lhsIallPragmas _lhsIaroundMap _lhsIchildren _lhsIcon _lhsIcontextMap _lhsIdecls _lhsIinh _lhsIinstVisitNrs _lhsIisLast _lhsImergeMap _lhsInextIntra _lhsInextIntraVars _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamInstMap _lhsIparamMap _lhsIprefix _lhsIquantMap _lhsIsyn _lhsIterminals _lhsIunfoldSemDom _lhsIvisitedSet _lhsIwith_sig _lhsIwrappers) -> ( let _vssX47 = Control.Monad.Identity.runIdentity (attach_T_Sequence (arg_vss_)) _intraX47 = Control.Monad.Identity.runIdentity (attach_T_Sequence (arg_intra_)) (T_Sequence_vOut46 _vssIallTpsFound _vssIblockDecls _vssIcomments _vssIdecls _vssIdeclsAbove _vssIdefinedInsts _vssIexprs _vssItSigs _vssItps _vssIusedVars _vssIvisitedSet) = inv_Sequence_s47 _vssX47 (T_Sequence_vIn46 _vssOallNts _vssOaroundMap _vssOchildren _vssOcon _vssOdeclsAbove _vssOinh _vssOinstVisitNrs _vssOlastExpr _vssOmergeMap _vssOnr _vssOnt _vssOo_case _vssOo_cata _vssOo_costcentre _vssOo_data _vssOo_linePragmas _vssOo_monadic _vssOo_newtypes _vssOo_pretty _vssOo_rename _vssOo_sem _vssOo_sig _vssOo_splitsems _vssOo_strictwrap _vssOo_traces _vssOo_unbox _vssOoptions _vssOparamInstMap _vssOparamMap _vssOprefix _vssOsyn _vssOterminals _vssOunfoldSemDom _vssOvisitedSet _vssOwhat) (T_Sequence_vOut46 _intraIallTpsFound _intraIblockDecls _intraIcomments _intraIdecls _intraIdeclsAbove _intraIdefinedInsts _intraIexprs _intraItSigs _intraItps _intraIusedVars _intraIvisitedSet) = inv_Sequence_s47 _intraX47 (T_Sequence_vIn46 _intraOallNts _intraOaroundMap _intraOchildren _intraOcon _intraOdeclsAbove _intraOinh _intraOinstVisitNrs _intraOlastExpr _intraOmergeMap _intraOnr _intraOnt _intraOo_case _intraOo_cata _intraOo_costcentre _intraOo_data _intraOo_linePragmas _intraOo_monadic _intraOo_newtypes _intraOo_pretty _intraOo_rename _intraOo_sem _intraOo_sig _intraOo_splitsems _intraOo_strictwrap _intraOo_traces _intraOo_unbox _intraOoptions _intraOparamInstMap _intraOparamMap _intraOprefix _intraOsyn _intraOterminals _intraOunfoldSemDom _intraOvisitedSet _intraOwhat) _lhsOintra :: Exprs _lhsOintra = rule423 _intraIexprs _lhsOintraVars :: Set String _lhsOintraVars = rule424 _intraIusedVars (_higherOrderChildren,_firstOrderChildren) = rule425 _lhsIchildren _firstOrderOrig = rule426 _firstOrderChildren _funcname = rule427 _lhsIcon _lhsInr _lhsInt _lhsIprefix _nextVisitName = rule428 _lhsIisLast _lhsInr _lhsInt _lhsIprefix _nextVisitDecl = rule429 _lhsIcon _lhsIdecls _lhsIisLast _lhsInextIntraVars _lhsInr _lhsInt _lhsIprefix _nextVisitName _isOneVisit = rule430 _lhsIisLast _lhsInr _hasWrappers = rule431 _lhsInt _lhsIwrappers _refDecls = rule432 _hasWrappers _isOneVisit _lhsInt _lhsIoptions arg_syn_ _decls = rule433 _nextVisitDecl _refDecls _typeSigs _vssIdecls _vssOlastExpr = rule434 _lhsIo_unbox _nextVisitName arg_inh_ arg_syn_ _intraOlastExpr = rule435 () _lastExprVars = rule436 _nextVisitName arg_syn_ (_blockFunDecls,_blockFirstFunCall) = rule437 _funcname _lastExprVars _nextVisitDecl _o_case _vssIblockDecls _costCentreDescr = rule438 _lhsIcon _lhsInr _lhsInt _addCostCentre = rule439 _costCentreDescr _lhsIo_costcentre _params = rule440 _lhsInt _lhsIparamMap _semFun = rule441 _addCostCentre _blockFirstFunCall _decls _declsType _firstOrderOrig _funcname _lhsInr _lhsInt _lhsIo_newtypes _lhsIo_unbox _lhsIunfoldSemDom _nextVisitName _o_splitsems _params arg_inh_ arg_ordered_ arg_syn_ _tsig = rule442 _funcname _semType _semType = rule443 _firstOrderOrig _lhsIcontextMap _lhsInr _lhsInt _lhsIquantMap _params _lhsOdecls :: Decls _lhsOdecls = rule444 _blockFunDecls _lhsIwith_sig _o_splitsems _semFun _tsig arg_ordered_ _typeSigs = rule445 _lhsIo_sig _o_case _vssItSigs _o_do = rule446 _lhsIo_monadic arg_ordered_ _o_case = rule447 _lhsIallPragmas _lhsIcon _lhsInt _lhsIo_case _o_do arg_ordered_ _declsType = rule448 _o_case _o_do _o_splitsems = rule449 _lhsIo_splitsems arg_ordered_ _lhsOgatherInstVisitNrs :: Map Identifier Int _lhsOgatherInstVisitNrs = rule450 _lhsInr _vssIdefinedInsts _vssOdeclsAbove = rule451 () _intraOdeclsAbove = rule452 () _lhsOcomments :: [String] _lhsOcomments = rule453 _intraIcomments _lhsInr _vssIcomments _vssOwhat = rule454 () _intraOwhat = rule455 () _lhsOsemNames :: [String] _lhsOsemNames = rule456 _funcname _lhsOvisitedSet :: Set Identifier _lhsOvisitedSet = rule457 _intraIvisitedSet _vssOallNts = rule458 _lhsIallNts _vssOaroundMap = rule459 _lhsIaroundMap _vssOchildren = rule460 _lhsIchildren _vssOcon = rule461 _lhsIcon _vssOinh = rule462 _lhsIinh _vssOinstVisitNrs = rule463 _lhsIinstVisitNrs _vssOmergeMap = rule464 _lhsImergeMap _vssOnr = rule465 _lhsInr _vssOnt = rule466 _lhsInt _vssOo_case = rule467 _o_case _vssOo_cata = rule468 _lhsIo_cata _vssOo_costcentre = rule469 _lhsIo_costcentre _vssOo_data = rule470 _lhsIo_data _vssOo_linePragmas = rule471 _lhsIo_linePragmas _vssOo_monadic = rule472 _lhsIo_monadic _vssOo_newtypes = rule473 _lhsIo_newtypes _vssOo_pretty = rule474 _lhsIo_pretty _vssOo_rename = rule475 _lhsIo_rename _vssOo_sem = rule476 _lhsIo_sem _vssOo_sig = rule477 _lhsIo_sig _vssOo_splitsems = rule478 _o_splitsems _vssOo_strictwrap = rule479 _lhsIo_strictwrap _vssOo_traces = rule480 _lhsIo_traces _vssOo_unbox = rule481 _lhsIo_unbox _vssOoptions = rule482 _lhsIoptions _vssOparamInstMap = rule483 _lhsIparamInstMap _vssOparamMap = rule484 _lhsIparamMap _vssOprefix = rule485 _lhsIprefix _vssOsyn = rule486 _lhsIsyn _vssOterminals = rule487 _lhsIterminals _vssOunfoldSemDom = rule488 _lhsIunfoldSemDom _vssOvisitedSet = rule489 _lhsIvisitedSet _intraOallNts = rule490 _lhsIallNts _intraOaroundMap = rule491 _lhsIaroundMap _intraOchildren = rule492 _lhsIchildren _intraOcon = rule493 _lhsIcon _intraOinh = rule494 _lhsIinh _intraOinstVisitNrs = rule495 _lhsIinstVisitNrs _intraOmergeMap = rule496 _lhsImergeMap _intraOnr = rule497 _lhsInr _intraOnt = rule498 _lhsInt _intraOo_case = rule499 _o_case _intraOo_cata = rule500 _lhsIo_cata _intraOo_costcentre = rule501 _lhsIo_costcentre _intraOo_data = rule502 _lhsIo_data _intraOo_linePragmas = rule503 _lhsIo_linePragmas _intraOo_monadic = rule504 _lhsIo_monadic _intraOo_newtypes = rule505 _lhsIo_newtypes _intraOo_pretty = rule506 _lhsIo_pretty _intraOo_rename = rule507 _lhsIo_rename _intraOo_sem = rule508 _lhsIo_sem _intraOo_sig = rule509 _lhsIo_sig _intraOo_splitsems = rule510 _o_splitsems _intraOo_strictwrap = rule511 _lhsIo_strictwrap _intraOo_traces = rule512 _lhsIo_traces _intraOo_unbox = rule513 _lhsIo_unbox _intraOoptions = rule514 _lhsIoptions _intraOparamInstMap = rule515 _lhsIparamInstMap _intraOparamMap = rule516 _lhsIparamMap _intraOprefix = rule517 _lhsIprefix _intraOsyn = rule518 _lhsIsyn _intraOterminals = rule519 _lhsIterminals _intraOunfoldSemDom = rule520 _lhsIunfoldSemDom _intraOvisitedSet = rule521 _vssIvisitedSet __result_ = T_CVisit_vOut28 _lhsOcomments _lhsOdecls _lhsOgatherInstVisitNrs _lhsOintra _lhsOintraVars _lhsOsemNames _lhsOvisitedSet in __result_ ) in C_CVisit_s29 v28 {-# INLINE rule423 #-} {-# LINE 311 "./src-ag/GenerateCode.ag" #-} rule423 = \ ((_intraIexprs) :: Exprs) -> {-# LINE 311 "./src-ag/GenerateCode.ag" #-} _intraIexprs {-# LINE 3269 "dist/build/GenerateCode.hs"#-} {-# INLINE rule424 #-} {-# LINE 312 "./src-ag/GenerateCode.ag" #-} rule424 = \ ((_intraIusedVars) :: Set String) -> {-# LINE 312 "./src-ag/GenerateCode.ag" #-} _intraIusedVars {-# LINE 3275 "dist/build/GenerateCode.hs"#-} {-# INLINE rule425 #-} {-# LINE 442 "./src-ag/GenerateCode.ag" #-} rule425 = \ ((_lhsIchildren) :: [(Identifier,Type, ChildKind)]) -> {-# LINE 442 "./src-ag/GenerateCode.ag" #-} partition (\(_,_,virt) -> isHigherOrder virt) _lhsIchildren {-# LINE 3281 "dist/build/GenerateCode.hs"#-} {-# INLINE rule426 #-} {-# LINE 443 "./src-ag/GenerateCode.ag" #-} rule426 = \ _firstOrderChildren -> {-# LINE 443 "./src-ag/GenerateCode.ag" #-} map pickOrigType _firstOrderChildren {-# LINE 3287 "dist/build/GenerateCode.hs"#-} {-# INLINE rule427 #-} {-# LINE 444 "./src-ag/GenerateCode.ag" #-} rule427 = \ ((_lhsIcon) :: ConstructorIdent) ((_lhsInr) :: Int) ((_lhsInt) :: NontermIdent) ((_lhsIprefix) :: String) -> {-# LINE 444 "./src-ag/GenerateCode.ag" #-} seqSemname _lhsIprefix _lhsInt _lhsIcon _lhsInr {-# LINE 3293 "dist/build/GenerateCode.hs"#-} {-# INLINE rule428 #-} {-# LINE 445 "./src-ag/GenerateCode.ag" #-} rule428 = \ ((_lhsIisLast) :: Bool) ((_lhsInr) :: Int) ((_lhsInt) :: NontermIdent) ((_lhsIprefix) :: String) -> {-# LINE 445 "./src-ag/GenerateCode.ag" #-} if _lhsIisLast then [] else [visitname _lhsIprefix _lhsInt (_lhsInr+1)] {-# LINE 3299 "dist/build/GenerateCode.hs"#-} {-# INLINE rule429 #-} {-# LINE 446 "./src-ag/GenerateCode.ag" #-} rule429 = \ ((_lhsIcon) :: ConstructorIdent) ((_lhsIdecls) :: Decls) ((_lhsIisLast) :: Bool) ((_lhsInextIntraVars) :: Set String) ((_lhsInr) :: Int) ((_lhsInt) :: NontermIdent) ((_lhsIprefix) :: String) _nextVisitName -> {-# LINE 446 "./src-ag/GenerateCode.ag" #-} let lhs = TupleLhs _nextVisitName rhs = Let _lhsIdecls (SimpleExpr fun) fun = seqSemname _lhsIprefix _lhsInt _lhsIcon (_lhsInr+1) in if _lhsIisLast then [] else [Decl lhs rhs (Set.fromList _nextVisitName) _lhsInextIntraVars] {-# LINE 3310 "dist/build/GenerateCode.hs"#-} {-# INLINE rule430 #-} {-# LINE 453 "./src-ag/GenerateCode.ag" #-} rule430 = \ ((_lhsIisLast) :: Bool) ((_lhsInr) :: Int) -> {-# LINE 453 "./src-ag/GenerateCode.ag" #-} _lhsIisLast && _lhsInr == 0 {-# LINE 3316 "dist/build/GenerateCode.hs"#-} {-# INLINE rule431 #-} {-# LINE 454 "./src-ag/GenerateCode.ag" #-} rule431 = \ ((_lhsInt) :: NontermIdent) ((_lhsIwrappers) :: Set NontermIdent) -> {-# LINE 454 "./src-ag/GenerateCode.ag" #-} _lhsInt `Set.member` _lhsIwrappers {-# LINE 3322 "dist/build/GenerateCode.hs"#-} {-# INLINE rule432 #-} {-# LINE 455 "./src-ag/GenerateCode.ag" #-} rule432 = \ _hasWrappers _isOneVisit ((_lhsInt) :: NontermIdent) ((_lhsIoptions) :: Options) syn_ -> {-# LINE 455 "./src-ag/GenerateCode.ag" #-} if _isOneVisit && _hasWrappers && reference _lhsIoptions then let synAttrs = Map.toList syn_ synNT = "Syn" ++ "_" ++ getName _lhsInt synVars = [ SimpleExpr (attrname False _LHS a) | (a,_) <- synAttrs ] rhs = App synNT synVars lhs = Fun "___node" [] in [Decl lhs rhs Set.empty Set.empty] else [] {-# LINE 3335 "dist/build/GenerateCode.hs"#-} {-# INLINE rule433 #-} {-# LINE 463 "./src-ag/GenerateCode.ag" #-} rule433 = \ _nextVisitDecl _refDecls _typeSigs ((_vssIdecls) :: Decls) -> {-# LINE 463 "./src-ag/GenerateCode.ag" #-} _typeSigs ++ _vssIdecls ++ _nextVisitDecl ++ _refDecls {-# LINE 3341 "dist/build/GenerateCode.hs"#-} {-# INLINE rule434 #-} {-# LINE 464 "./src-ag/GenerateCode.ag" #-} rule434 = \ ((_lhsIo_unbox) :: Bool) _nextVisitName inh_ syn_ -> {-# LINE 464 "./src-ag/GenerateCode.ag" #-} mkTupleExpr _lhsIo_unbox (null $ Map.keys inh_) $ map (SimpleExpr . lhsname False) (Map.keys syn_) ++ map SimpleExpr _nextVisitName {-# LINE 3347 "dist/build/GenerateCode.hs"#-} {-# INLINE rule435 #-} {-# LINE 465 "./src-ag/GenerateCode.ag" #-} rule435 = \ (_ :: ()) -> {-# LINE 465 "./src-ag/GenerateCode.ag" #-} error "lastExpr: not used here" {-# LINE 3353 "dist/build/GenerateCode.hs"#-} {-# INLINE rule436 #-} {-# LINE 466 "./src-ag/GenerateCode.ag" #-} rule436 = \ _nextVisitName syn_ -> {-# LINE 466 "./src-ag/GenerateCode.ag" #-} map (lhsname False) (Map.keys syn_) ++ _nextVisitName {-# LINE 3359 "dist/build/GenerateCode.hs"#-} {-# INLINE rule437 #-} {-# LINE 467 "./src-ag/GenerateCode.ag" #-} rule437 = \ _funcname _lastExprVars _nextVisitDecl _o_case ((_vssIblockDecls) :: DeclBlocks) -> {-# LINE 467 "./src-ag/GenerateCode.ag" #-} mkPartitionedFunction _funcname _o_case _nextVisitDecl _lastExprVars _vssIblockDecls {-# LINE 3365 "dist/build/GenerateCode.hs"#-} {-# INLINE rule438 #-} {-# LINE 469 "./src-ag/GenerateCode.ag" #-} rule438 = \ ((_lhsIcon) :: ConstructorIdent) ((_lhsInr) :: Int) ((_lhsInt) :: NontermIdent) -> {-# LINE 469 "./src-ag/GenerateCode.ag" #-} "b" ++ ":" ++ show _lhsInt ++ ":" ++ show _lhsIcon ++ ":" ++ show _lhsInr {-# LINE 3371 "dist/build/GenerateCode.hs"#-} {-# INLINE rule439 #-} {-# LINE 470 "./src-ag/GenerateCode.ag" #-} rule439 = \ _costCentreDescr ((_lhsIo_costcentre) :: Bool) -> {-# LINE 470 "./src-ag/GenerateCode.ag" #-} \v -> if _lhsIo_costcentre then PragmaExpr True False ("SCC \"" ++ _costCentreDescr ++ "\"") v else v {-# LINE 3379 "dist/build/GenerateCode.hs"#-} {-# INLINE rule440 #-} {-# LINE 474 "./src-ag/GenerateCode.ag" #-} rule440 = \ ((_lhsInt) :: NontermIdent) ((_lhsIparamMap) :: ParamMap) -> {-# LINE 474 "./src-ag/GenerateCode.ag" #-} map getName $ Map.findWithDefault [] _lhsInt _lhsIparamMap {-# LINE 3385 "dist/build/GenerateCode.hs"#-} {-# INLINE rule441 #-} {-# LINE 475 "./src-ag/GenerateCode.ag" #-} rule441 = \ _addCostCentre _blockFirstFunCall _decls _declsType _firstOrderOrig _funcname ((_lhsInr) :: Int) ((_lhsInt) :: NontermIdent) ((_lhsIo_newtypes) :: Bool) ((_lhsIo_unbox) :: Bool) ((_lhsIunfoldSemDom) :: NontermIdent -> Int -> [String] -> Code.Type) _nextVisitName _o_splitsems _params inh_ ordered_ syn_ -> {-# LINE 475 "./src-ag/GenerateCode.ag" #-} let lhs = Fun _funcname lhs_args lhs_args = if _lhsInr == 0 then map field _firstOrderOrig else [] field (name,NT tp tps _,_) = let unwrap | _lhsIo_newtypes = \x -> App (sdtype tp) [x] | otherwise = id addType expr | null tps = expr | otherwise = TypedExpr expr (_lhsIunfoldSemDom tp 0 tps) in unwrap $ addType $ SimpleExpr $ funname name 0 field (name,tp,_) = let expr = SimpleExpr (funname name 0) in if null _params then expr else TypedExpr expr (idEvalType $ typeToCodeType (Just _lhsInt) _params $ removeDeforested tp) mbEvalTp | null _params = const Nothing | otherwise = Just . idEvalType rhs = wrap . mkSemFun _lhsInt _lhsInr [mkLambdaArg (lhsname True nm) (mbEvalTp $ typeToCodeType (Just _lhsInt) _params $ removeDeforested tp) | (nm,tp) <- Map.assocs inh_] $ _addCostCentre $ if ordered_ && _o_splitsems then _blockFirstFunCall else mkDecls _declsType _decls . ResultExpr (typeName _lhsInt _lhsInr) . mkTupleExpr _lhsIo_unbox (null $ Map.keys inh_) $ map (SimpleExpr . lhsname False) (Map.keys syn_) ++ map SimpleExpr _nextVisitName wrap = if _lhsIo_newtypes then \x -> App (typeName _lhsInt _lhsInr) [x] else id in Decl lhs rhs Set.empty Set.empty {-# LINE 3416 "dist/build/GenerateCode.hs"#-} {-# INLINE rule442 #-} {-# LINE 506 "./src-ag/GenerateCode.ag" #-} rule442 = \ _funcname _semType -> {-# LINE 506 "./src-ag/GenerateCode.ag" #-} TSig _funcname _semType {-# LINE 3422 "dist/build/GenerateCode.hs"#-} {-# INLINE rule443 #-} {-# LINE 507 "./src-ag/GenerateCode.ag" #-} rule443 = \ _firstOrderOrig ((_lhsIcontextMap) :: ContextMap) ((_lhsInr) :: Int) ((_lhsInt) :: NontermIdent) ((_lhsIquantMap) :: QuantMap) _params -> {-# LINE 507 "./src-ag/GenerateCode.ag" #-} 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 _params = id | otherwise = idEvalType in appQuant _lhsIquantMap _lhsInt $ appContext _lhsIcontextMap _lhsInt $ evalTp $ if _lhsInr == 0 then foldr argType (typeAppStrs (sdtype _lhsInt ) _params ) (map (\(_,t,_) -> t) _firstOrderOrig ) else foldr argType (typeAppStrs (typeName _lhsInt _lhsInr) _params ) [] {-# LINE 3437 "dist/build/GenerateCode.hs"#-} {-# INLINE rule444 #-} {-# LINE 518 "./src-ag/GenerateCode.ag" #-} rule444 = \ _blockFunDecls ((_lhsIwith_sig) :: Bool) _o_splitsems _semFun _tsig ordered_ -> {-# LINE 518 "./src-ag/GenerateCode.ag" #-} ( if _lhsIwith_sig then [_tsig, _semFun] else [_semFun] ) ++ ( if ordered_ && _o_splitsems then _blockFunDecls else [] ) {-# LINE 3450 "dist/build/GenerateCode.hs"#-} {-# INLINE rule445 #-} {-# LINE 526 "./src-ag/GenerateCode.ag" #-} rule445 = \ ((_lhsIo_sig) :: Bool) _o_case ((_vssItSigs) :: [Decl]) -> {-# LINE 526 "./src-ag/GenerateCode.ag" #-} if _lhsIo_sig && not _o_case then _vssItSigs else [] {-# LINE 3458 "dist/build/GenerateCode.hs"#-} {-# INLINE rule446 #-} {-# LINE 529 "./src-ag/GenerateCode.ag" #-} rule446 = \ ((_lhsIo_monadic) :: Bool) ordered_ -> {-# LINE 529 "./src-ag/GenerateCode.ag" #-} ordered_ && _lhsIo_monadic {-# LINE 3464 "dist/build/GenerateCode.hs"#-} {-# INLINE rule447 #-} {-# LINE 530 "./src-ag/GenerateCode.ag" #-} rule447 = \ ((_lhsIallPragmas) :: PragmaMap) ((_lhsIcon) :: ConstructorIdent) ((_lhsInt) :: NontermIdent) ((_lhsIo_case) :: Bool) _o_do ordered_ -> {-# LINE 530 "./src-ag/GenerateCode.ag" #-} not _o_do && _lhsIo_case && ordered_ && not (hasPragma _lhsIallPragmas _lhsInt _lhsIcon _NOCASE) {-# LINE 3470 "dist/build/GenerateCode.hs"#-} {-# INLINE rule448 #-} {-# LINE 531 "./src-ag/GenerateCode.ag" #-} rule448 = \ _o_case _o_do -> {-# LINE 531 "./src-ag/GenerateCode.ag" #-} if _o_do then DeclsDo else if _o_case then DeclsCase else DeclsLet {-# LINE 3480 "dist/build/GenerateCode.hs"#-} {-# INLINE rule449 #-} {-# LINE 536 "./src-ag/GenerateCode.ag" #-} rule449 = \ ((_lhsIo_splitsems) :: Bool) ordered_ -> {-# LINE 536 "./src-ag/GenerateCode.ag" #-} ordered_ && _lhsIo_splitsems {-# LINE 3486 "dist/build/GenerateCode.hs"#-} {-# INLINE rule450 #-} {-# LINE 570 "./src-ag/GenerateCode.ag" #-} rule450 = \ ((_lhsInr) :: Int) ((_vssIdefinedInsts) :: [Identifier]) -> {-# LINE 570 "./src-ag/GenerateCode.ag" #-} Map.fromList [(i,_lhsInr) | i <- _vssIdefinedInsts] {-# LINE 3492 "dist/build/GenerateCode.hs"#-} {-# INLINE rule451 #-} {-# LINE 613 "./src-ag/GenerateCode.ag" #-} rule451 = \ (_ :: ()) -> {-# LINE 613 "./src-ag/GenerateCode.ag" #-} [] {-# LINE 3498 "dist/build/GenerateCode.hs"#-} {-# INLINE rule452 #-} {-# LINE 614 "./src-ag/GenerateCode.ag" #-} rule452 = \ (_ :: ()) -> {-# LINE 614 "./src-ag/GenerateCode.ag" #-} error "declsAbove: not used here" {-# LINE 3504 "dist/build/GenerateCode.hs"#-} {-# INLINE rule453 #-} {-# LINE 897 "./src-ag/GenerateCode.ag" #-} rule453 = \ ((_intraIcomments) :: [String]) ((_lhsInr) :: Int) ((_vssIcomments) :: [String]) -> {-# LINE 897 "./src-ag/GenerateCode.ag" #-} let body = map ind (_vssIcomments ++ _intraIcomments) in if null body then [] else ("visit " ++ show _lhsInr ++ ":") : body {-# LINE 3513 "dist/build/GenerateCode.hs"#-} {-# INLINE rule454 #-} {-# LINE 901 "./src-ag/GenerateCode.ag" #-} rule454 = \ (_ :: ()) -> {-# LINE 901 "./src-ag/GenerateCode.ag" #-} "local" {-# LINE 3519 "dist/build/GenerateCode.hs"#-} {-# INLINE rule455 #-} {-# LINE 902 "./src-ag/GenerateCode.ag" #-} rule455 = \ (_ :: ()) -> {-# LINE 902 "./src-ag/GenerateCode.ag" #-} "intra" {-# LINE 3525 "dist/build/GenerateCode.hs"#-} {-# INLINE rule456 #-} {-# LINE 1164 "./src-ag/GenerateCode.ag" #-} rule456 = \ _funcname -> {-# LINE 1164 "./src-ag/GenerateCode.ag" #-} [_funcname ] {-# LINE 3531 "dist/build/GenerateCode.hs"#-} {-# INLINE rule457 #-} rule457 = \ ((_intraIvisitedSet) :: Set Identifier) -> _intraIvisitedSet {-# INLINE rule458 #-} rule458 = \ ((_lhsIallNts) :: Set NontermIdent) -> _lhsIallNts {-# INLINE rule459 #-} rule459 = \ ((_lhsIaroundMap) :: Set Identifier) -> _lhsIaroundMap {-# INLINE rule460 #-} rule460 = \ ((_lhsIchildren) :: [(Identifier,Type, ChildKind)]) -> _lhsIchildren {-# INLINE rule461 #-} rule461 = \ ((_lhsIcon) :: ConstructorIdent) -> _lhsIcon {-# INLINE rule462 #-} rule462 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule463 #-} rule463 = \ ((_lhsIinstVisitNrs) :: Map Identifier Int) -> _lhsIinstVisitNrs {-# INLINE rule464 #-} rule464 = \ ((_lhsImergeMap) :: Map Identifier (Identifier, [Identifier])) -> _lhsImergeMap {-# INLINE rule465 #-} rule465 = \ ((_lhsInr) :: Int) -> _lhsInr {-# INLINE rule466 #-} rule466 = \ ((_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule467 #-} rule467 = \ _o_case -> _o_case {-# INLINE rule468 #-} rule468 = \ ((_lhsIo_cata) :: Bool) -> _lhsIo_cata {-# INLINE rule469 #-} rule469 = \ ((_lhsIo_costcentre) :: Bool) -> _lhsIo_costcentre {-# INLINE rule470 #-} rule470 = \ ((_lhsIo_data) :: Maybe Bool) -> _lhsIo_data {-# INLINE rule471 #-} rule471 = \ ((_lhsIo_linePragmas) :: Bool) -> _lhsIo_linePragmas {-# INLINE rule472 #-} rule472 = \ ((_lhsIo_monadic) :: Bool) -> _lhsIo_monadic {-# INLINE rule473 #-} rule473 = \ ((_lhsIo_newtypes) :: Bool) -> _lhsIo_newtypes {-# INLINE rule474 #-} rule474 = \ ((_lhsIo_pretty) :: Bool) -> _lhsIo_pretty {-# INLINE rule475 #-} rule475 = \ ((_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# INLINE rule476 #-} rule476 = \ ((_lhsIo_sem) :: Bool) -> _lhsIo_sem {-# INLINE rule477 #-} rule477 = \ ((_lhsIo_sig) :: Bool) -> _lhsIo_sig {-# INLINE rule478 #-} rule478 = \ _o_splitsems -> _o_splitsems {-# INLINE rule479 #-} rule479 = \ ((_lhsIo_strictwrap) :: Bool) -> _lhsIo_strictwrap {-# INLINE rule480 #-} rule480 = \ ((_lhsIo_traces) :: Bool) -> _lhsIo_traces {-# INLINE rule481 #-} rule481 = \ ((_lhsIo_unbox) :: Bool) -> _lhsIo_unbox {-# INLINE rule482 #-} rule482 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule483 #-} rule483 = \ ((_lhsIparamInstMap) :: Map Identifier (NontermIdent, [String])) -> _lhsIparamInstMap {-# INLINE rule484 #-} rule484 = \ ((_lhsIparamMap) :: ParamMap) -> _lhsIparamMap {-# INLINE rule485 #-} rule485 = \ ((_lhsIprefix) :: String) -> _lhsIprefix {-# INLINE rule486 #-} rule486 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# INLINE rule487 #-} rule487 = \ ((_lhsIterminals) :: [Identifier]) -> _lhsIterminals {-# INLINE rule488 #-} rule488 = \ ((_lhsIunfoldSemDom) :: NontermIdent -> Int -> [String] -> Code.Type) -> _lhsIunfoldSemDom {-# INLINE rule489 #-} rule489 = \ ((_lhsIvisitedSet) :: Set Identifier) -> _lhsIvisitedSet {-# INLINE rule490 #-} rule490 = \ ((_lhsIallNts) :: Set NontermIdent) -> _lhsIallNts {-# INLINE rule491 #-} rule491 = \ ((_lhsIaroundMap) :: Set Identifier) -> _lhsIaroundMap {-# INLINE rule492 #-} rule492 = \ ((_lhsIchildren) :: [(Identifier,Type, ChildKind)]) -> _lhsIchildren {-# INLINE rule493 #-} rule493 = \ ((_lhsIcon) :: ConstructorIdent) -> _lhsIcon {-# INLINE rule494 #-} rule494 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule495 #-} rule495 = \ ((_lhsIinstVisitNrs) :: Map Identifier Int) -> _lhsIinstVisitNrs {-# INLINE rule496 #-} rule496 = \ ((_lhsImergeMap) :: Map Identifier (Identifier, [Identifier])) -> _lhsImergeMap {-# INLINE rule497 #-} rule497 = \ ((_lhsInr) :: Int) -> _lhsInr {-# INLINE rule498 #-} rule498 = \ ((_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule499 #-} rule499 = \ _o_case -> _o_case {-# INLINE rule500 #-} rule500 = \ ((_lhsIo_cata) :: Bool) -> _lhsIo_cata {-# INLINE rule501 #-} rule501 = \ ((_lhsIo_costcentre) :: Bool) -> _lhsIo_costcentre {-# INLINE rule502 #-} rule502 = \ ((_lhsIo_data) :: Maybe Bool) -> _lhsIo_data {-# INLINE rule503 #-} rule503 = \ ((_lhsIo_linePragmas) :: Bool) -> _lhsIo_linePragmas {-# INLINE rule504 #-} rule504 = \ ((_lhsIo_monadic) :: Bool) -> _lhsIo_monadic {-# INLINE rule505 #-} rule505 = \ ((_lhsIo_newtypes) :: Bool) -> _lhsIo_newtypes {-# INLINE rule506 #-} rule506 = \ ((_lhsIo_pretty) :: Bool) -> _lhsIo_pretty {-# INLINE rule507 #-} rule507 = \ ((_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# INLINE rule508 #-} rule508 = \ ((_lhsIo_sem) :: Bool) -> _lhsIo_sem {-# INLINE rule509 #-} rule509 = \ ((_lhsIo_sig) :: Bool) -> _lhsIo_sig {-# INLINE rule510 #-} rule510 = \ _o_splitsems -> _o_splitsems {-# INLINE rule511 #-} rule511 = \ ((_lhsIo_strictwrap) :: Bool) -> _lhsIo_strictwrap {-# INLINE rule512 #-} rule512 = \ ((_lhsIo_traces) :: Bool) -> _lhsIo_traces {-# INLINE rule513 #-} rule513 = \ ((_lhsIo_unbox) :: Bool) -> _lhsIo_unbox {-# INLINE rule514 #-} rule514 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule515 #-} rule515 = \ ((_lhsIparamInstMap) :: Map Identifier (NontermIdent, [String])) -> _lhsIparamInstMap {-# INLINE rule516 #-} rule516 = \ ((_lhsIparamMap) :: ParamMap) -> _lhsIparamMap {-# INLINE rule517 #-} rule517 = \ ((_lhsIprefix) :: String) -> _lhsIprefix {-# INLINE rule518 #-} rule518 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# INLINE rule519 #-} rule519 = \ ((_lhsIterminals) :: [Identifier]) -> _lhsIterminals {-# INLINE rule520 #-} rule520 = \ ((_lhsIunfoldSemDom) :: NontermIdent -> Int -> [String] -> Code.Type) -> _lhsIunfoldSemDom {-# INLINE rule521 #-} rule521 = \ ((_vssIvisitedSet) :: Set Identifier) -> _vssIvisitedSet -- CVisits ----------------------------------------------------- -- wrapper data Inh_CVisits = Inh_CVisits { allNts_Inh_CVisits :: (Set NontermIdent), allPragmas_Inh_CVisits :: (PragmaMap), aroundMap_Inh_CVisits :: (Set Identifier), children_Inh_CVisits :: ([(Identifier,Type, ChildKind)]), con_Inh_CVisits :: (ConstructorIdent), contextMap_Inh_CVisits :: (ContextMap), inh_Inh_CVisits :: (Attributes), instVisitNrs_Inh_CVisits :: (Map Identifier Int), mergeMap_Inh_CVisits :: (Map Identifier (Identifier, [Identifier])), nr_Inh_CVisits :: (Int), nt_Inh_CVisits :: (NontermIdent), o_case_Inh_CVisits :: (Bool), o_cata_Inh_CVisits :: (Bool), o_costcentre_Inh_CVisits :: (Bool), o_data_Inh_CVisits :: (Maybe Bool), o_linePragmas_Inh_CVisits :: (Bool), o_monadic_Inh_CVisits :: (Bool), o_newtypes_Inh_CVisits :: (Bool), o_pretty_Inh_CVisits :: (Bool), o_rename_Inh_CVisits :: (Bool), o_sem_Inh_CVisits :: (Bool), o_sig_Inh_CVisits :: (Bool), o_splitsems_Inh_CVisits :: (Bool), o_strictwrap_Inh_CVisits :: (Bool), o_traces_Inh_CVisits :: (Bool), o_unbox_Inh_CVisits :: (Bool), options_Inh_CVisits :: (Options), paramInstMap_Inh_CVisits :: (Map Identifier (NontermIdent, [String])), paramMap_Inh_CVisits :: (ParamMap), prefix_Inh_CVisits :: (String), quantMap_Inh_CVisits :: (QuantMap), syn_Inh_CVisits :: (Attributes), terminals_Inh_CVisits :: ([Identifier]), unfoldSemDom_Inh_CVisits :: (NontermIdent -> Int -> [String] -> Code.Type), visitedSet_Inh_CVisits :: (Set Identifier), with_sig_Inh_CVisits :: (Bool), wrappers_Inh_CVisits :: (Set NontermIdent) } data Syn_CVisits = Syn_CVisits { comments_Syn_CVisits :: ([String]), decls_Syn_CVisits :: (Decls), gatherInstVisitNrs_Syn_CVisits :: (Map Identifier Int), intra_Syn_CVisits :: (Exprs), intraVars_Syn_CVisits :: (Set String), isNil_Syn_CVisits :: (Bool), semNames_Syn_CVisits :: ([String]), visitedSet_Syn_CVisits :: (Set Identifier) } {-# INLINABLE wrap_CVisits #-} wrap_CVisits :: T_CVisits -> Inh_CVisits -> (Syn_CVisits ) wrap_CVisits (T_CVisits act) (Inh_CVisits _lhsIallNts _lhsIallPragmas _lhsIaroundMap _lhsIchildren _lhsIcon _lhsIcontextMap _lhsIinh _lhsIinstVisitNrs _lhsImergeMap _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamInstMap _lhsIparamMap _lhsIprefix _lhsIquantMap _lhsIsyn _lhsIterminals _lhsIunfoldSemDom _lhsIvisitedSet _lhsIwith_sig _lhsIwrappers) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_CVisits_vIn31 _lhsIallNts _lhsIallPragmas _lhsIaroundMap _lhsIchildren _lhsIcon _lhsIcontextMap _lhsIinh _lhsIinstVisitNrs _lhsImergeMap _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamInstMap _lhsIparamMap _lhsIprefix _lhsIquantMap _lhsIsyn _lhsIterminals _lhsIunfoldSemDom _lhsIvisitedSet _lhsIwith_sig _lhsIwrappers (T_CVisits_vOut31 _lhsOcomments _lhsOdecls _lhsOgatherInstVisitNrs _lhsOintra _lhsOintraVars _lhsOisNil _lhsOsemNames _lhsOvisitedSet) <- return (inv_CVisits_s32 sem arg) return (Syn_CVisits _lhsOcomments _lhsOdecls _lhsOgatherInstVisitNrs _lhsOintra _lhsOintraVars _lhsOisNil _lhsOsemNames _lhsOvisitedSet) ) -- cata {-# NOINLINE sem_CVisits #-} sem_CVisits :: CVisits -> T_CVisits sem_CVisits list = Prelude.foldr sem_CVisits_Cons sem_CVisits_Nil (Prelude.map sem_CVisit list) -- semantic domain newtype T_CVisits = T_CVisits { attach_T_CVisits :: Identity (T_CVisits_s32 ) } newtype T_CVisits_s32 = C_CVisits_s32 { inv_CVisits_s32 :: (T_CVisits_v31 ) } data T_CVisits_s33 = C_CVisits_s33 type T_CVisits_v31 = (T_CVisits_vIn31 ) -> (T_CVisits_vOut31 ) data T_CVisits_vIn31 = T_CVisits_vIn31 (Set NontermIdent) (PragmaMap) (Set Identifier) ([(Identifier,Type, ChildKind)]) (ConstructorIdent) (ContextMap) (Attributes) (Map Identifier Int) (Map Identifier (Identifier, [Identifier])) (Int) (NontermIdent) (Bool) (Bool) (Bool) (Maybe Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Options) (Map Identifier (NontermIdent, [String])) (ParamMap) (String) (QuantMap) (Attributes) ([Identifier]) (NontermIdent -> Int -> [String] -> Code.Type) (Set Identifier) (Bool) (Set NontermIdent) data T_CVisits_vOut31 = T_CVisits_vOut31 ([String]) (Decls) (Map Identifier Int) (Exprs) (Set String) (Bool) ([String]) (Set Identifier) {-# NOINLINE sem_CVisits_Cons #-} sem_CVisits_Cons :: T_CVisit -> T_CVisits -> T_CVisits sem_CVisits_Cons arg_hd_ arg_tl_ = T_CVisits (return st32) where {-# NOINLINE st32 #-} st32 = let v31 :: T_CVisits_v31 v31 = \ (T_CVisits_vIn31 _lhsIallNts _lhsIallPragmas _lhsIaroundMap _lhsIchildren _lhsIcon _lhsIcontextMap _lhsIinh _lhsIinstVisitNrs _lhsImergeMap _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamInstMap _lhsIparamMap _lhsIprefix _lhsIquantMap _lhsIsyn _lhsIterminals _lhsIunfoldSemDom _lhsIvisitedSet _lhsIwith_sig _lhsIwrappers) -> ( let _hdX29 = Control.Monad.Identity.runIdentity (attach_T_CVisit (arg_hd_)) _tlX32 = Control.Monad.Identity.runIdentity (attach_T_CVisits (arg_tl_)) (T_CVisit_vOut28 _hdIcomments _hdIdecls _hdIgatherInstVisitNrs _hdIintra _hdIintraVars _hdIsemNames _hdIvisitedSet) = inv_CVisit_s29 _hdX29 (T_CVisit_vIn28 _hdOallNts _hdOallPragmas _hdOaroundMap _hdOchildren _hdOcon _hdOcontextMap _hdOdecls _hdOinh _hdOinstVisitNrs _hdOisLast _hdOmergeMap _hdOnextIntra _hdOnextIntraVars _hdOnr _hdOnt _hdOo_case _hdOo_cata _hdOo_costcentre _hdOo_data _hdOo_linePragmas _hdOo_monadic _hdOo_newtypes _hdOo_pretty _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_splitsems _hdOo_strictwrap _hdOo_traces _hdOo_unbox _hdOoptions _hdOparamInstMap _hdOparamMap _hdOprefix _hdOquantMap _hdOsyn _hdOterminals _hdOunfoldSemDom _hdOvisitedSet _hdOwith_sig _hdOwrappers) (T_CVisits_vOut31 _tlIcomments _tlIdecls _tlIgatherInstVisitNrs _tlIintra _tlIintraVars _tlIisNil _tlIsemNames _tlIvisitedSet) = inv_CVisits_s32 _tlX32 (T_CVisits_vIn31 _tlOallNts _tlOallPragmas _tlOaroundMap _tlOchildren _tlOcon _tlOcontextMap _tlOinh _tlOinstVisitNrs _tlOmergeMap _tlOnr _tlOnt _tlOo_case _tlOo_cata _tlOo_costcentre _tlOo_data _tlOo_linePragmas _tlOo_monadic _tlOo_newtypes _tlOo_pretty _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_splitsems _tlOo_strictwrap _tlOo_traces _tlOo_unbox _tlOoptions _tlOparamInstMap _tlOparamMap _tlOprefix _tlOquantMap _tlOsyn _tlOterminals _tlOunfoldSemDom _tlOvisitedSet _tlOwith_sig _tlOwrappers) _tlOnr = rule522 _lhsInr _lhsOisNil :: Bool _lhsOisNil = rule523 () _hdOisLast = rule524 _tlIisNil _hdOnextIntra = rule525 _tlIintra _hdOnextIntraVars = rule526 _tlIintraVars _lhsOintra :: Exprs _lhsOintra = rule527 _hdIintra _lhsOintraVars :: Set String _lhsOintraVars = rule528 _hdIintraVars _lhsOdecls :: Decls _lhsOdecls = rule529 _hdIdecls _hdOdecls = rule530 _tlIdecls _lhsOcomments :: [String] _lhsOcomments = rule531 _hdIcomments _tlIcomments _lhsOgatherInstVisitNrs :: Map Identifier Int _lhsOgatherInstVisitNrs = rule532 _hdIgatherInstVisitNrs _tlIgatherInstVisitNrs _lhsOsemNames :: [String] _lhsOsemNames = rule533 _hdIsemNames _tlIsemNames _lhsOvisitedSet :: Set Identifier _lhsOvisitedSet = rule534 _tlIvisitedSet _hdOallNts = rule535 _lhsIallNts _hdOallPragmas = rule536 _lhsIallPragmas _hdOaroundMap = rule537 _lhsIaroundMap _hdOchildren = rule538 _lhsIchildren _hdOcon = rule539 _lhsIcon _hdOcontextMap = rule540 _lhsIcontextMap _hdOinh = rule541 _lhsIinh _hdOinstVisitNrs = rule542 _lhsIinstVisitNrs _hdOmergeMap = rule543 _lhsImergeMap _hdOnr = rule544 _lhsInr _hdOnt = rule545 _lhsInt _hdOo_case = rule546 _lhsIo_case _hdOo_cata = rule547 _lhsIo_cata _hdOo_costcentre = rule548 _lhsIo_costcentre _hdOo_data = rule549 _lhsIo_data _hdOo_linePragmas = rule550 _lhsIo_linePragmas _hdOo_monadic = rule551 _lhsIo_monadic _hdOo_newtypes = rule552 _lhsIo_newtypes _hdOo_pretty = rule553 _lhsIo_pretty _hdOo_rename = rule554 _lhsIo_rename _hdOo_sem = rule555 _lhsIo_sem _hdOo_sig = rule556 _lhsIo_sig _hdOo_splitsems = rule557 _lhsIo_splitsems _hdOo_strictwrap = rule558 _lhsIo_strictwrap _hdOo_traces = rule559 _lhsIo_traces _hdOo_unbox = rule560 _lhsIo_unbox _hdOoptions = rule561 _lhsIoptions _hdOparamInstMap = rule562 _lhsIparamInstMap _hdOparamMap = rule563 _lhsIparamMap _hdOprefix = rule564 _lhsIprefix _hdOquantMap = rule565 _lhsIquantMap _hdOsyn = rule566 _lhsIsyn _hdOterminals = rule567 _lhsIterminals _hdOunfoldSemDom = rule568 _lhsIunfoldSemDom _hdOvisitedSet = rule569 _lhsIvisitedSet _hdOwith_sig = rule570 _lhsIwith_sig _hdOwrappers = rule571 _lhsIwrappers _tlOallNts = rule572 _lhsIallNts _tlOallPragmas = rule573 _lhsIallPragmas _tlOaroundMap = rule574 _lhsIaroundMap _tlOchildren = rule575 _lhsIchildren _tlOcon = rule576 _lhsIcon _tlOcontextMap = rule577 _lhsIcontextMap _tlOinh = rule578 _lhsIinh _tlOinstVisitNrs = rule579 _lhsIinstVisitNrs _tlOmergeMap = rule580 _lhsImergeMap _tlOnt = rule581 _lhsInt _tlOo_case = rule582 _lhsIo_case _tlOo_cata = rule583 _lhsIo_cata _tlOo_costcentre = rule584 _lhsIo_costcentre _tlOo_data = rule585 _lhsIo_data _tlOo_linePragmas = rule586 _lhsIo_linePragmas _tlOo_monadic = rule587 _lhsIo_monadic _tlOo_newtypes = rule588 _lhsIo_newtypes _tlOo_pretty = rule589 _lhsIo_pretty _tlOo_rename = rule590 _lhsIo_rename _tlOo_sem = rule591 _lhsIo_sem _tlOo_sig = rule592 _lhsIo_sig _tlOo_splitsems = rule593 _lhsIo_splitsems _tlOo_strictwrap = rule594 _lhsIo_strictwrap _tlOo_traces = rule595 _lhsIo_traces _tlOo_unbox = rule596 _lhsIo_unbox _tlOoptions = rule597 _lhsIoptions _tlOparamInstMap = rule598 _lhsIparamInstMap _tlOparamMap = rule599 _lhsIparamMap _tlOprefix = rule600 _lhsIprefix _tlOquantMap = rule601 _lhsIquantMap _tlOsyn = rule602 _lhsIsyn _tlOterminals = rule603 _lhsIterminals _tlOunfoldSemDom = rule604 _lhsIunfoldSemDom _tlOvisitedSet = rule605 _hdIvisitedSet _tlOwith_sig = rule606 _lhsIwith_sig _tlOwrappers = rule607 _lhsIwrappers __result_ = T_CVisits_vOut31 _lhsOcomments _lhsOdecls _lhsOgatherInstVisitNrs _lhsOintra _lhsOintraVars _lhsOisNil _lhsOsemNames _lhsOvisitedSet in __result_ ) in C_CVisits_s32 v31 {-# INLINE rule522 #-} {-# LINE 283 "./src-ag/GenerateCode.ag" #-} rule522 = \ ((_lhsInr) :: Int) -> {-# LINE 283 "./src-ag/GenerateCode.ag" #-} _lhsInr + 1 {-# LINE 3871 "dist/build/GenerateCode.hs"#-} {-# INLINE rule523 #-} {-# LINE 296 "./src-ag/GenerateCode.ag" #-} rule523 = \ (_ :: ()) -> {-# LINE 296 "./src-ag/GenerateCode.ag" #-} False {-# LINE 3877 "dist/build/GenerateCode.hs"#-} {-# INLINE rule524 #-} {-# LINE 297 "./src-ag/GenerateCode.ag" #-} rule524 = \ ((_tlIisNil) :: Bool) -> {-# LINE 297 "./src-ag/GenerateCode.ag" #-} _tlIisNil {-# LINE 3883 "dist/build/GenerateCode.hs"#-} {-# INLINE rule525 #-} {-# LINE 314 "./src-ag/GenerateCode.ag" #-} rule525 = \ ((_tlIintra) :: Exprs) -> {-# LINE 314 "./src-ag/GenerateCode.ag" #-} _tlIintra {-# LINE 3889 "dist/build/GenerateCode.hs"#-} {-# INLINE rule526 #-} {-# LINE 315 "./src-ag/GenerateCode.ag" #-} rule526 = \ ((_tlIintraVars) :: Set String) -> {-# LINE 315 "./src-ag/GenerateCode.ag" #-} _tlIintraVars {-# LINE 3895 "dist/build/GenerateCode.hs"#-} {-# INLINE rule527 #-} {-# LINE 316 "./src-ag/GenerateCode.ag" #-} rule527 = \ ((_hdIintra) :: Exprs) -> {-# LINE 316 "./src-ag/GenerateCode.ag" #-} _hdIintra {-# LINE 3901 "dist/build/GenerateCode.hs"#-} {-# INLINE rule528 #-} {-# LINE 317 "./src-ag/GenerateCode.ag" #-} rule528 = \ ((_hdIintraVars) :: Set String) -> {-# LINE 317 "./src-ag/GenerateCode.ag" #-} _hdIintraVars {-# LINE 3907 "dist/build/GenerateCode.hs"#-} {-# INLINE rule529 #-} {-# LINE 432 "./src-ag/GenerateCode.ag" #-} rule529 = \ ((_hdIdecls) :: Decls) -> {-# LINE 432 "./src-ag/GenerateCode.ag" #-} _hdIdecls {-# LINE 3913 "dist/build/GenerateCode.hs"#-} {-# INLINE rule530 #-} {-# LINE 433 "./src-ag/GenerateCode.ag" #-} rule530 = \ ((_tlIdecls) :: Decls) -> {-# LINE 433 "./src-ag/GenerateCode.ag" #-} _tlIdecls {-# LINE 3919 "dist/build/GenerateCode.hs"#-} {-# INLINE rule531 #-} rule531 = \ ((_hdIcomments) :: [String]) ((_tlIcomments) :: [String]) -> _hdIcomments ++ _tlIcomments {-# INLINE rule532 #-} rule532 = \ ((_hdIgatherInstVisitNrs) :: Map Identifier Int) ((_tlIgatherInstVisitNrs) :: Map Identifier Int) -> _hdIgatherInstVisitNrs `Map.union` _tlIgatherInstVisitNrs {-# INLINE rule533 #-} rule533 = \ ((_hdIsemNames) :: [String]) ((_tlIsemNames) :: [String]) -> _hdIsemNames ++ _tlIsemNames {-# INLINE rule534 #-} rule534 = \ ((_tlIvisitedSet) :: Set Identifier) -> _tlIvisitedSet {-# INLINE rule535 #-} rule535 = \ ((_lhsIallNts) :: Set NontermIdent) -> _lhsIallNts {-# INLINE rule536 #-} rule536 = \ ((_lhsIallPragmas) :: PragmaMap) -> _lhsIallPragmas {-# INLINE rule537 #-} rule537 = \ ((_lhsIaroundMap) :: Set Identifier) -> _lhsIaroundMap {-# INLINE rule538 #-} rule538 = \ ((_lhsIchildren) :: [(Identifier,Type, ChildKind)]) -> _lhsIchildren {-# INLINE rule539 #-} rule539 = \ ((_lhsIcon) :: ConstructorIdent) -> _lhsIcon {-# INLINE rule540 #-} rule540 = \ ((_lhsIcontextMap) :: ContextMap) -> _lhsIcontextMap {-# INLINE rule541 #-} rule541 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule542 #-} rule542 = \ ((_lhsIinstVisitNrs) :: Map Identifier Int) -> _lhsIinstVisitNrs {-# INLINE rule543 #-} rule543 = \ ((_lhsImergeMap) :: Map Identifier (Identifier, [Identifier])) -> _lhsImergeMap {-# INLINE rule544 #-} rule544 = \ ((_lhsInr) :: Int) -> _lhsInr {-# INLINE rule545 #-} rule545 = \ ((_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule546 #-} rule546 = \ ((_lhsIo_case) :: Bool) -> _lhsIo_case {-# INLINE rule547 #-} rule547 = \ ((_lhsIo_cata) :: Bool) -> _lhsIo_cata {-# INLINE rule548 #-} rule548 = \ ((_lhsIo_costcentre) :: Bool) -> _lhsIo_costcentre {-# INLINE rule549 #-} rule549 = \ ((_lhsIo_data) :: Maybe Bool) -> _lhsIo_data {-# INLINE rule550 #-} rule550 = \ ((_lhsIo_linePragmas) :: Bool) -> _lhsIo_linePragmas {-# INLINE rule551 #-} rule551 = \ ((_lhsIo_monadic) :: Bool) -> _lhsIo_monadic {-# INLINE rule552 #-} rule552 = \ ((_lhsIo_newtypes) :: Bool) -> _lhsIo_newtypes {-# INLINE rule553 #-} rule553 = \ ((_lhsIo_pretty) :: Bool) -> _lhsIo_pretty {-# INLINE rule554 #-} rule554 = \ ((_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# INLINE rule555 #-} rule555 = \ ((_lhsIo_sem) :: Bool) -> _lhsIo_sem {-# INLINE rule556 #-} rule556 = \ ((_lhsIo_sig) :: Bool) -> _lhsIo_sig {-# INLINE rule557 #-} rule557 = \ ((_lhsIo_splitsems) :: Bool) -> _lhsIo_splitsems {-# INLINE rule558 #-} rule558 = \ ((_lhsIo_strictwrap) :: Bool) -> _lhsIo_strictwrap {-# INLINE rule559 #-} rule559 = \ ((_lhsIo_traces) :: Bool) -> _lhsIo_traces {-# INLINE rule560 #-} rule560 = \ ((_lhsIo_unbox) :: Bool) -> _lhsIo_unbox {-# INLINE rule561 #-} rule561 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule562 #-} rule562 = \ ((_lhsIparamInstMap) :: Map Identifier (NontermIdent, [String])) -> _lhsIparamInstMap {-# INLINE rule563 #-} rule563 = \ ((_lhsIparamMap) :: ParamMap) -> _lhsIparamMap {-# INLINE rule564 #-} rule564 = \ ((_lhsIprefix) :: String) -> _lhsIprefix {-# INLINE rule565 #-} rule565 = \ ((_lhsIquantMap) :: QuantMap) -> _lhsIquantMap {-# INLINE rule566 #-} rule566 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# INLINE rule567 #-} rule567 = \ ((_lhsIterminals) :: [Identifier]) -> _lhsIterminals {-# INLINE rule568 #-} rule568 = \ ((_lhsIunfoldSemDom) :: NontermIdent -> Int -> [String] -> Code.Type) -> _lhsIunfoldSemDom {-# INLINE rule569 #-} rule569 = \ ((_lhsIvisitedSet) :: Set Identifier) -> _lhsIvisitedSet {-# INLINE rule570 #-} rule570 = \ ((_lhsIwith_sig) :: Bool) -> _lhsIwith_sig {-# INLINE rule571 #-} rule571 = \ ((_lhsIwrappers) :: Set NontermIdent) -> _lhsIwrappers {-# INLINE rule572 #-} rule572 = \ ((_lhsIallNts) :: Set NontermIdent) -> _lhsIallNts {-# INLINE rule573 #-} rule573 = \ ((_lhsIallPragmas) :: PragmaMap) -> _lhsIallPragmas {-# INLINE rule574 #-} rule574 = \ ((_lhsIaroundMap) :: Set Identifier) -> _lhsIaroundMap {-# INLINE rule575 #-} rule575 = \ ((_lhsIchildren) :: [(Identifier,Type, ChildKind)]) -> _lhsIchildren {-# INLINE rule576 #-} rule576 = \ ((_lhsIcon) :: ConstructorIdent) -> _lhsIcon {-# INLINE rule577 #-} rule577 = \ ((_lhsIcontextMap) :: ContextMap) -> _lhsIcontextMap {-# INLINE rule578 #-} rule578 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule579 #-} rule579 = \ ((_lhsIinstVisitNrs) :: Map Identifier Int) -> _lhsIinstVisitNrs {-# INLINE rule580 #-} rule580 = \ ((_lhsImergeMap) :: Map Identifier (Identifier, [Identifier])) -> _lhsImergeMap {-# INLINE rule581 #-} rule581 = \ ((_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule582 #-} rule582 = \ ((_lhsIo_case) :: Bool) -> _lhsIo_case {-# INLINE rule583 #-} rule583 = \ ((_lhsIo_cata) :: Bool) -> _lhsIo_cata {-# INLINE rule584 #-} rule584 = \ ((_lhsIo_costcentre) :: Bool) -> _lhsIo_costcentre {-# INLINE rule585 #-} rule585 = \ ((_lhsIo_data) :: Maybe Bool) -> _lhsIo_data {-# INLINE rule586 #-} rule586 = \ ((_lhsIo_linePragmas) :: Bool) -> _lhsIo_linePragmas {-# INLINE rule587 #-} rule587 = \ ((_lhsIo_monadic) :: Bool) -> _lhsIo_monadic {-# INLINE rule588 #-} rule588 = \ ((_lhsIo_newtypes) :: Bool) -> _lhsIo_newtypes {-# INLINE rule589 #-} rule589 = \ ((_lhsIo_pretty) :: Bool) -> _lhsIo_pretty {-# INLINE rule590 #-} rule590 = \ ((_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# INLINE rule591 #-} rule591 = \ ((_lhsIo_sem) :: Bool) -> _lhsIo_sem {-# INLINE rule592 #-} rule592 = \ ((_lhsIo_sig) :: Bool) -> _lhsIo_sig {-# INLINE rule593 #-} rule593 = \ ((_lhsIo_splitsems) :: Bool) -> _lhsIo_splitsems {-# INLINE rule594 #-} rule594 = \ ((_lhsIo_strictwrap) :: Bool) -> _lhsIo_strictwrap {-# INLINE rule595 #-} rule595 = \ ((_lhsIo_traces) :: Bool) -> _lhsIo_traces {-# INLINE rule596 #-} rule596 = \ ((_lhsIo_unbox) :: Bool) -> _lhsIo_unbox {-# INLINE rule597 #-} rule597 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule598 #-} rule598 = \ ((_lhsIparamInstMap) :: Map Identifier (NontermIdent, [String])) -> _lhsIparamInstMap {-# INLINE rule599 #-} rule599 = \ ((_lhsIparamMap) :: ParamMap) -> _lhsIparamMap {-# INLINE rule600 #-} rule600 = \ ((_lhsIprefix) :: String) -> _lhsIprefix {-# INLINE rule601 #-} rule601 = \ ((_lhsIquantMap) :: QuantMap) -> _lhsIquantMap {-# INLINE rule602 #-} rule602 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# INLINE rule603 #-} rule603 = \ ((_lhsIterminals) :: [Identifier]) -> _lhsIterminals {-# INLINE rule604 #-} rule604 = \ ((_lhsIunfoldSemDom) :: NontermIdent -> Int -> [String] -> Code.Type) -> _lhsIunfoldSemDom {-# INLINE rule605 #-} rule605 = \ ((_hdIvisitedSet) :: Set Identifier) -> _hdIvisitedSet {-# INLINE rule606 #-} rule606 = \ ((_lhsIwith_sig) :: Bool) -> _lhsIwith_sig {-# INLINE rule607 #-} rule607 = \ ((_lhsIwrappers) :: Set NontermIdent) -> _lhsIwrappers {-# NOINLINE sem_CVisits_Nil #-} sem_CVisits_Nil :: T_CVisits sem_CVisits_Nil = T_CVisits (return st32) where {-# NOINLINE st32 #-} st32 = let v31 :: T_CVisits_v31 v31 = \ (T_CVisits_vIn31 _lhsIallNts _lhsIallPragmas _lhsIaroundMap _lhsIchildren _lhsIcon _lhsIcontextMap _lhsIinh _lhsIinstVisitNrs _lhsImergeMap _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamInstMap _lhsIparamMap _lhsIprefix _lhsIquantMap _lhsIsyn _lhsIterminals _lhsIunfoldSemDom _lhsIvisitedSet _lhsIwith_sig _lhsIwrappers) -> ( let _lhsOisNil :: Bool _lhsOisNil = rule608 () _lhsOintra :: Exprs _lhsOintra = rule609 () _lhsOintraVars :: Set String _lhsOintraVars = rule610 () _lhsOdecls :: Decls _lhsOdecls = rule611 () _lhsOcomments :: [String] _lhsOcomments = rule612 () _lhsOgatherInstVisitNrs :: Map Identifier Int _lhsOgatherInstVisitNrs = rule613 () _lhsOsemNames :: [String] _lhsOsemNames = rule614 () _lhsOvisitedSet :: Set Identifier _lhsOvisitedSet = rule615 _lhsIvisitedSet __result_ = T_CVisits_vOut31 _lhsOcomments _lhsOdecls _lhsOgatherInstVisitNrs _lhsOintra _lhsOintraVars _lhsOisNil _lhsOsemNames _lhsOvisitedSet in __result_ ) in C_CVisits_s32 v31 {-# INLINE rule608 #-} {-# LINE 298 "./src-ag/GenerateCode.ag" #-} rule608 = \ (_ :: ()) -> {-# LINE 298 "./src-ag/GenerateCode.ag" #-} True {-# LINE 4182 "dist/build/GenerateCode.hs"#-} {-# INLINE rule609 #-} {-# LINE 318 "./src-ag/GenerateCode.ag" #-} rule609 = \ (_ :: ()) -> {-# LINE 318 "./src-ag/GenerateCode.ag" #-} [] {-# LINE 4188 "dist/build/GenerateCode.hs"#-} {-# INLINE rule610 #-} {-# LINE 319 "./src-ag/GenerateCode.ag" #-} rule610 = \ (_ :: ()) -> {-# LINE 319 "./src-ag/GenerateCode.ag" #-} Set.empty {-# LINE 4194 "dist/build/GenerateCode.hs"#-} {-# INLINE rule611 #-} {-# LINE 431 "./src-ag/GenerateCode.ag" #-} rule611 = \ (_ :: ()) -> {-# LINE 431 "./src-ag/GenerateCode.ag" #-} [] {-# LINE 4200 "dist/build/GenerateCode.hs"#-} {-# INLINE rule612 #-} rule612 = \ (_ :: ()) -> [] {-# INLINE rule613 #-} rule613 = \ (_ :: ()) -> Map.empty {-# INLINE rule614 #-} rule614 = \ (_ :: ()) -> [] {-# INLINE rule615 #-} rule615 = \ ((_lhsIvisitedSet) :: Set Identifier) -> _lhsIvisitedSet -- DeclBlocks -------------------------------------------------- -- wrapper data Inh_DeclBlocks = Inh_DeclBlocks { blockNr_Inh_DeclBlocks :: (Int), lastExprVars_Inh_DeclBlocks :: ([String]), nextVisitDecls_Inh_DeclBlocks :: ([Decl]), optCase_Inh_DeclBlocks :: (Bool), prefix_Inh_DeclBlocks :: (String) } data Syn_DeclBlocks = Syn_DeclBlocks { callExpr_Syn_DeclBlocks :: (Expr), decls_Syn_DeclBlocks :: ([Decl]), freeVars_Syn_DeclBlocks :: ([String]) } {-# INLINABLE wrap_DeclBlocks #-} wrap_DeclBlocks :: T_DeclBlocks -> Inh_DeclBlocks -> (Syn_DeclBlocks ) wrap_DeclBlocks (T_DeclBlocks act) (Inh_DeclBlocks _lhsIblockNr _lhsIlastExprVars _lhsInextVisitDecls _lhsIoptCase _lhsIprefix) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_DeclBlocks_vIn34 _lhsIblockNr _lhsIlastExprVars _lhsInextVisitDecls _lhsIoptCase _lhsIprefix (T_DeclBlocks_vOut34 _lhsOcallExpr _lhsOdecls _lhsOfreeVars) <- return (inv_DeclBlocks_s35 sem arg) return (Syn_DeclBlocks _lhsOcallExpr _lhsOdecls _lhsOfreeVars) ) -- cata {-# NOINLINE sem_DeclBlocks #-} sem_DeclBlocks :: DeclBlocks -> T_DeclBlocks sem_DeclBlocks ( DeclBlock defs_ visit_ next_ ) = sem_DeclBlocks_DeclBlock defs_ visit_ ( sem_DeclBlocks next_ ) sem_DeclBlocks ( DeclTerminator defs_ result_ ) = sem_DeclBlocks_DeclTerminator defs_ result_ -- semantic domain newtype T_DeclBlocks = T_DeclBlocks { attach_T_DeclBlocks :: Identity (T_DeclBlocks_s35 ) } newtype T_DeclBlocks_s35 = C_DeclBlocks_s35 { inv_DeclBlocks_s35 :: (T_DeclBlocks_v34 ) } data T_DeclBlocks_s36 = C_DeclBlocks_s36 type T_DeclBlocks_v34 = (T_DeclBlocks_vIn34 ) -> (T_DeclBlocks_vOut34 ) data T_DeclBlocks_vIn34 = T_DeclBlocks_vIn34 (Int) ([String]) ([Decl]) (Bool) (String) data T_DeclBlocks_vOut34 = T_DeclBlocks_vOut34 (Expr) ([Decl]) ([String]) {-# NOINLINE sem_DeclBlocks_DeclBlock #-} sem_DeclBlocks_DeclBlock :: ([Decl]) -> (Decl) -> T_DeclBlocks -> T_DeclBlocks sem_DeclBlocks_DeclBlock arg_defs_ arg_visit_ arg_next_ = T_DeclBlocks (return st35) where {-# NOINLINE st35 #-} st35 = let v34 :: T_DeclBlocks_v34 v34 = \ (T_DeclBlocks_vIn34 _lhsIblockNr _lhsIlastExprVars _lhsInextVisitDecls _lhsIoptCase _lhsIprefix) -> ( let _nextX35 = Control.Monad.Identity.runIdentity (attach_T_DeclBlocks (arg_next_)) (T_DeclBlocks_vOut34 _nextIcallExpr _nextIdecls _nextIfreeVars) = inv_DeclBlocks_s35 _nextX35 (T_DeclBlocks_vIn34 _nextOblockNr _nextOlastExprVars _nextOnextVisitDecls _nextOoptCase _nextOprefix) _nextOblockNr = rule616 _lhsIblockNr _lambdaName = rule617 _lhsIblockNr _lhsIprefix _pragmaDecl = rule618 _lambdaName _lhsOcallExpr :: Expr _lhsOcallExpr = rule619 _freeVars _lambdaName _freeVars = rule620 _nextIfreeVars arg_defs_ arg_visit_ _decl = rule621 _freeVars _lambdaName _lhsIoptCase _nextIcallExpr arg_defs_ arg_visit_ _lhsOdecls :: [Decl] _lhsOdecls = rule622 _decl _lhsIblockNr _nextIdecls _pragmaDecl _lhsOfreeVars :: [String] _lhsOfreeVars = rule623 _freeVars _nextOlastExprVars = rule624 _lhsIlastExprVars _nextOnextVisitDecls = rule625 _lhsInextVisitDecls _nextOoptCase = rule626 _lhsIoptCase _nextOprefix = rule627 _lhsIprefix __result_ = T_DeclBlocks_vOut34 _lhsOcallExpr _lhsOdecls _lhsOfreeVars in __result_ ) in C_DeclBlocks_s35 v34 {-# INLINE rule616 #-} {-# LINE 664 "./src-ag/GenerateCode.ag" #-} rule616 = \ ((_lhsIblockNr) :: Int) -> {-# LINE 664 "./src-ag/GenerateCode.ag" #-} _lhsIblockNr + 1 {-# LINE 4277 "dist/build/GenerateCode.hs"#-} {-# INLINE rule617 #-} {-# LINE 669 "./src-ag/GenerateCode.ag" #-} rule617 = \ ((_lhsIblockNr) :: Int) ((_lhsIprefix) :: String) -> {-# LINE 669 "./src-ag/GenerateCode.ag" #-} _lhsIprefix ++ "_block" ++ show _lhsIblockNr {-# LINE 4283 "dist/build/GenerateCode.hs"#-} {-# INLINE rule618 #-} {-# LINE 670 "./src-ag/GenerateCode.ag" #-} rule618 = \ _lambdaName -> {-# LINE 670 "./src-ag/GenerateCode.ag" #-} PragmaDecl ("NOINLINE " ++ _lambdaName ) {-# LINE 4289 "dist/build/GenerateCode.hs"#-} {-# INLINE rule619 #-} {-# LINE 671 "./src-ag/GenerateCode.ag" #-} rule619 = \ _freeVars _lambdaName -> {-# LINE 671 "./src-ag/GenerateCode.ag" #-} App _lambdaName (map SimpleExpr _freeVars ) {-# LINE 4295 "dist/build/GenerateCode.hs"#-} {-# INLINE rule620 #-} {-# LINE 675 "./src-ag/GenerateCode.ag" #-} rule620 = \ ((_nextIfreeVars) :: [String]) defs_ visit_ -> {-# LINE 675 "./src-ag/GenerateCode.ag" #-} freevars _nextIfreeVars (visit_ : defs_) {-# LINE 4301 "dist/build/GenerateCode.hs"#-} {-# INLINE rule621 #-} {-# LINE 682 "./src-ag/GenerateCode.ag" #-} rule621 = \ _freeVars _lambdaName ((_lhsIoptCase) :: Bool) ((_nextIcallExpr) :: Expr) defs_ visit_ -> {-# LINE 682 "./src-ag/GenerateCode.ag" #-} mkBlockLambda _lhsIoptCase _lambdaName _freeVars (defs_ ++ [visit_]) _nextIcallExpr {-# LINE 4307 "dist/build/GenerateCode.hs"#-} {-# INLINE rule622 #-} {-# LINE 683 "./src-ag/GenerateCode.ag" #-} rule622 = \ _decl ((_lhsIblockNr) :: Int) ((_nextIdecls) :: [Decl]) _pragmaDecl -> {-# LINE 683 "./src-ag/GenerateCode.ag" #-} (if _lhsIblockNr > 1 then [_pragmaDecl ] else []) ++ [_decl ] ++ _nextIdecls {-# LINE 4313 "dist/build/GenerateCode.hs"#-} {-# INLINE rule623 #-} rule623 = \ _freeVars -> _freeVars {-# INLINE rule624 #-} rule624 = \ ((_lhsIlastExprVars) :: [String]) -> _lhsIlastExprVars {-# INLINE rule625 #-} rule625 = \ ((_lhsInextVisitDecls) :: [Decl]) -> _lhsInextVisitDecls {-# INLINE rule626 #-} rule626 = \ ((_lhsIoptCase) :: Bool) -> _lhsIoptCase {-# INLINE rule627 #-} rule627 = \ ((_lhsIprefix) :: String) -> _lhsIprefix {-# NOINLINE sem_DeclBlocks_DeclTerminator #-} sem_DeclBlocks_DeclTerminator :: ([Decl]) -> (Expr) -> T_DeclBlocks sem_DeclBlocks_DeclTerminator arg_defs_ arg_result_ = T_DeclBlocks (return st35) where {-# NOINLINE st35 #-} st35 = let v34 :: T_DeclBlocks_v34 v34 = \ (T_DeclBlocks_vIn34 _lhsIblockNr _lhsIlastExprVars _lhsInextVisitDecls _lhsIoptCase _lhsIprefix) -> ( let _lambdaName = rule628 _lhsIblockNr _lhsIprefix _pragmaDecl = rule629 _lambdaName _lhsOcallExpr :: Expr _lhsOcallExpr = rule630 _freeVars _lambdaName _freeVars = rule631 _lhsIlastExprVars _lhsInextVisitDecls arg_defs_ _lhsOdecls :: [Decl] _lhsOdecls = rule632 _freeVars _lambdaName _lhsInextVisitDecls _lhsIoptCase arg_defs_ arg_result_ _lhsOfreeVars :: [String] _lhsOfreeVars = rule633 _freeVars __result_ = T_DeclBlocks_vOut34 _lhsOcallExpr _lhsOdecls _lhsOfreeVars in __result_ ) in C_DeclBlocks_s35 v34 {-# INLINE rule628 #-} {-# LINE 669 "./src-ag/GenerateCode.ag" #-} rule628 = \ ((_lhsIblockNr) :: Int) ((_lhsIprefix) :: String) -> {-# LINE 669 "./src-ag/GenerateCode.ag" #-} _lhsIprefix ++ "_block" ++ show _lhsIblockNr {-# LINE 4353 "dist/build/GenerateCode.hs"#-} {-# INLINE rule629 #-} {-# LINE 670 "./src-ag/GenerateCode.ag" #-} rule629 = \ _lambdaName -> {-# LINE 670 "./src-ag/GenerateCode.ag" #-} PragmaDecl ("NOINLINE " ++ _lambdaName ) {-# LINE 4359 "dist/build/GenerateCode.hs"#-} {-# INLINE rule630 #-} {-# LINE 671 "./src-ag/GenerateCode.ag" #-} rule630 = \ _freeVars _lambdaName -> {-# LINE 671 "./src-ag/GenerateCode.ag" #-} App _lambdaName (map SimpleExpr _freeVars ) {-# LINE 4365 "dist/build/GenerateCode.hs"#-} {-# INLINE rule631 #-} {-# LINE 673 "./src-ag/GenerateCode.ag" #-} rule631 = \ ((_lhsIlastExprVars) :: [String]) ((_lhsInextVisitDecls) :: [Decl]) defs_ -> {-# LINE 673 "./src-ag/GenerateCode.ag" #-} freevars _lhsIlastExprVars (defs_ ++ _lhsInextVisitDecls) {-# LINE 4371 "dist/build/GenerateCode.hs"#-} {-# INLINE rule632 #-} {-# LINE 680 "./src-ag/GenerateCode.ag" #-} rule632 = \ _freeVars _lambdaName ((_lhsInextVisitDecls) :: [Decl]) ((_lhsIoptCase) :: Bool) defs_ result_ -> {-# LINE 680 "./src-ag/GenerateCode.ag" #-} [ mkBlockLambda _lhsIoptCase _lambdaName _freeVars (defs_ ++ _lhsInextVisitDecls) result_ ] {-# LINE 4377 "dist/build/GenerateCode.hs"#-} {-# INLINE rule633 #-} rule633 = \ _freeVars -> _freeVars -- DeclBlocksRoot ---------------------------------------------- -- wrapper data Inh_DeclBlocksRoot = Inh_DeclBlocksRoot { lastExprVars_Inh_DeclBlocksRoot :: ([String]), nextVisitDecls_Inh_DeclBlocksRoot :: ([Decl]), optCase_Inh_DeclBlocksRoot :: (Bool), prefix_Inh_DeclBlocksRoot :: (String) } data Syn_DeclBlocksRoot = Syn_DeclBlocksRoot { firstCall_Syn_DeclBlocksRoot :: (Expr), lambdas_Syn_DeclBlocksRoot :: ([Decl]) } {-# INLINABLE wrap_DeclBlocksRoot #-} wrap_DeclBlocksRoot :: T_DeclBlocksRoot -> Inh_DeclBlocksRoot -> (Syn_DeclBlocksRoot ) wrap_DeclBlocksRoot (T_DeclBlocksRoot act) (Inh_DeclBlocksRoot _lhsIlastExprVars _lhsInextVisitDecls _lhsIoptCase _lhsIprefix) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_DeclBlocksRoot_vIn37 _lhsIlastExprVars _lhsInextVisitDecls _lhsIoptCase _lhsIprefix (T_DeclBlocksRoot_vOut37 _lhsOfirstCall _lhsOlambdas) <- return (inv_DeclBlocksRoot_s38 sem arg) return (Syn_DeclBlocksRoot _lhsOfirstCall _lhsOlambdas) ) -- cata {-# INLINE sem_DeclBlocksRoot #-} sem_DeclBlocksRoot :: DeclBlocksRoot -> T_DeclBlocksRoot sem_DeclBlocksRoot ( DeclBlocksRoot blocks_ ) = sem_DeclBlocksRoot_DeclBlocksRoot ( sem_DeclBlocks blocks_ ) -- semantic domain newtype T_DeclBlocksRoot = T_DeclBlocksRoot { attach_T_DeclBlocksRoot :: Identity (T_DeclBlocksRoot_s38 ) } newtype T_DeclBlocksRoot_s38 = C_DeclBlocksRoot_s38 { inv_DeclBlocksRoot_s38 :: (T_DeclBlocksRoot_v37 ) } data T_DeclBlocksRoot_s39 = C_DeclBlocksRoot_s39 type T_DeclBlocksRoot_v37 = (T_DeclBlocksRoot_vIn37 ) -> (T_DeclBlocksRoot_vOut37 ) data T_DeclBlocksRoot_vIn37 = T_DeclBlocksRoot_vIn37 ([String]) ([Decl]) (Bool) (String) data T_DeclBlocksRoot_vOut37 = T_DeclBlocksRoot_vOut37 (Expr) ([Decl]) {-# NOINLINE sem_DeclBlocksRoot_DeclBlocksRoot #-} sem_DeclBlocksRoot_DeclBlocksRoot :: T_DeclBlocks -> T_DeclBlocksRoot sem_DeclBlocksRoot_DeclBlocksRoot arg_blocks_ = T_DeclBlocksRoot (return st38) where {-# NOINLINE st38 #-} st38 = let v37 :: T_DeclBlocksRoot_v37 v37 = \ (T_DeclBlocksRoot_vIn37 _lhsIlastExprVars _lhsInextVisitDecls _lhsIoptCase _lhsIprefix) -> ( let _blocksX35 = Control.Monad.Identity.runIdentity (attach_T_DeclBlocks (arg_blocks_)) (T_DeclBlocks_vOut34 _blocksIcallExpr _blocksIdecls _blocksIfreeVars) = inv_DeclBlocks_s35 _blocksX35 (T_DeclBlocks_vIn34 _blocksOblockNr _blocksOlastExprVars _blocksOnextVisitDecls _blocksOoptCase _blocksOprefix) _lhsOlambdas :: [Decl] _lhsOlambdas = rule634 _blocksIdecls _lhsOfirstCall :: Expr _lhsOfirstCall = rule635 _blocksIcallExpr _blocksOblockNr = rule636 () _blocksOlastExprVars = rule637 _lhsIlastExprVars _blocksOnextVisitDecls = rule638 _lhsInextVisitDecls _blocksOoptCase = rule639 _lhsIoptCase _blocksOprefix = rule640 _lhsIprefix __result_ = T_DeclBlocksRoot_vOut37 _lhsOfirstCall _lhsOlambdas in __result_ ) in C_DeclBlocksRoot_s38 v37 {-# INLINE rule634 #-} {-# LINE 655 "./src-ag/GenerateCode.ag" #-} rule634 = \ ((_blocksIdecls) :: [Decl]) -> {-# LINE 655 "./src-ag/GenerateCode.ag" #-} _blocksIdecls {-# LINE 4438 "dist/build/GenerateCode.hs"#-} {-# INLINE rule635 #-} {-# LINE 656 "./src-ag/GenerateCode.ag" #-} rule635 = \ ((_blocksIcallExpr) :: Expr) -> {-# LINE 656 "./src-ag/GenerateCode.ag" #-} _blocksIcallExpr {-# LINE 4444 "dist/build/GenerateCode.hs"#-} {-# INLINE rule636 #-} {-# LINE 661 "./src-ag/GenerateCode.ag" #-} rule636 = \ (_ :: ()) -> {-# LINE 661 "./src-ag/GenerateCode.ag" #-} 1 {-# LINE 4450 "dist/build/GenerateCode.hs"#-} {-# INLINE rule637 #-} rule637 = \ ((_lhsIlastExprVars) :: [String]) -> _lhsIlastExprVars {-# INLINE rule638 #-} rule638 = \ ((_lhsInextVisitDecls) :: [Decl]) -> _lhsInextVisitDecls {-# INLINE rule639 #-} rule639 = \ ((_lhsIoptCase) :: Bool) -> _lhsIoptCase {-# INLINE rule640 #-} rule640 = \ ((_lhsIprefix) :: String) -> _lhsIprefix -- Pattern ----------------------------------------------------- -- wrapper data Inh_Pattern = Inh_Pattern { } data Syn_Pattern = Syn_Pattern { copy_Syn_Pattern :: (Pattern), definedInsts_Syn_Pattern :: ([Identifier]), patternAttributes_Syn_Pattern :: ([(Identifier, Identifier)]) } {-# INLINABLE wrap_Pattern #-} wrap_Pattern :: T_Pattern -> Inh_Pattern -> (Syn_Pattern ) wrap_Pattern (T_Pattern act) (Inh_Pattern ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Pattern_vIn40 (T_Pattern_vOut40 _lhsOcopy _lhsOdefinedInsts _lhsOpatternAttributes) <- return (inv_Pattern_s41 sem arg) return (Syn_Pattern _lhsOcopy _lhsOdefinedInsts _lhsOpatternAttributes) ) -- cata {-# NOINLINE sem_Pattern #-} sem_Pattern :: Pattern -> T_Pattern sem_Pattern ( Constr name_ pats_ ) = sem_Pattern_Constr name_ ( sem_Patterns pats_ ) sem_Pattern ( Product pos_ pats_ ) = sem_Pattern_Product pos_ ( sem_Patterns pats_ ) sem_Pattern ( Alias field_ attr_ pat_ ) = sem_Pattern_Alias field_ attr_ ( sem_Pattern pat_ ) sem_Pattern ( Irrefutable pat_ ) = sem_Pattern_Irrefutable ( sem_Pattern pat_ ) sem_Pattern ( Underscore pos_ ) = sem_Pattern_Underscore pos_ -- semantic domain newtype T_Pattern = T_Pattern { attach_T_Pattern :: Identity (T_Pattern_s41 ) } newtype T_Pattern_s41 = C_Pattern_s41 { inv_Pattern_s41 :: (T_Pattern_v40 ) } data T_Pattern_s42 = C_Pattern_s42 type T_Pattern_v40 = (T_Pattern_vIn40 ) -> (T_Pattern_vOut40 ) data T_Pattern_vIn40 = T_Pattern_vIn40 data T_Pattern_vOut40 = T_Pattern_vOut40 (Pattern) ([Identifier]) ([(Identifier, Identifier)]) {-# NOINLINE sem_Pattern_Constr #-} sem_Pattern_Constr :: (ConstructorIdent) -> T_Patterns -> T_Pattern sem_Pattern_Constr arg_name_ arg_pats_ = T_Pattern (return st41) where {-# NOINLINE st41 #-} st41 = let v40 :: T_Pattern_v40 v40 = \ (T_Pattern_vIn40 ) -> ( let _patsX44 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) (T_Patterns_vOut43 _patsIcopy _patsIdefinedInsts _patsIpatternAttributes) = inv_Patterns_s44 _patsX44 (T_Patterns_vIn43 ) _lhsOdefinedInsts :: [Identifier] _lhsOdefinedInsts = rule641 _patsIdefinedInsts _lhsOpatternAttributes :: [(Identifier, Identifier)] _lhsOpatternAttributes = rule642 _patsIpatternAttributes _copy = rule643 _patsIcopy arg_name_ _lhsOcopy :: Pattern _lhsOcopy = rule644 _copy __result_ = T_Pattern_vOut40 _lhsOcopy _lhsOdefinedInsts _lhsOpatternAttributes in __result_ ) in C_Pattern_s41 v40 {-# INLINE rule641 #-} rule641 = \ ((_patsIdefinedInsts) :: [Identifier]) -> _patsIdefinedInsts {-# INLINE rule642 #-} rule642 = \ ((_patsIpatternAttributes) :: [(Identifier, Identifier)]) -> _patsIpatternAttributes {-# INLINE rule643 #-} rule643 = \ ((_patsIcopy) :: Patterns) name_ -> Constr name_ _patsIcopy {-# INLINE rule644 #-} rule644 = \ _copy -> _copy {-# NOINLINE sem_Pattern_Product #-} sem_Pattern_Product :: (Pos) -> T_Patterns -> T_Pattern sem_Pattern_Product arg_pos_ arg_pats_ = T_Pattern (return st41) where {-# NOINLINE st41 #-} st41 = let v40 :: T_Pattern_v40 v40 = \ (T_Pattern_vIn40 ) -> ( let _patsX44 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) (T_Patterns_vOut43 _patsIcopy _patsIdefinedInsts _patsIpatternAttributes) = inv_Patterns_s44 _patsX44 (T_Patterns_vIn43 ) _lhsOdefinedInsts :: [Identifier] _lhsOdefinedInsts = rule645 _patsIdefinedInsts _lhsOpatternAttributes :: [(Identifier, Identifier)] _lhsOpatternAttributes = rule646 _patsIpatternAttributes _copy = rule647 _patsIcopy arg_pos_ _lhsOcopy :: Pattern _lhsOcopy = rule648 _copy __result_ = T_Pattern_vOut40 _lhsOcopy _lhsOdefinedInsts _lhsOpatternAttributes in __result_ ) in C_Pattern_s41 v40 {-# INLINE rule645 #-} rule645 = \ ((_patsIdefinedInsts) :: [Identifier]) -> _patsIdefinedInsts {-# INLINE rule646 #-} rule646 = \ ((_patsIpatternAttributes) :: [(Identifier, Identifier)]) -> _patsIpatternAttributes {-# INLINE rule647 #-} rule647 = \ ((_patsIcopy) :: Patterns) pos_ -> Product pos_ _patsIcopy {-# INLINE rule648 #-} rule648 = \ _copy -> _copy {-# NOINLINE sem_Pattern_Alias #-} sem_Pattern_Alias :: (Identifier) -> (Identifier) -> T_Pattern -> T_Pattern sem_Pattern_Alias arg_field_ arg_attr_ arg_pat_ = T_Pattern (return st41) where {-# NOINLINE st41 #-} st41 = let v40 :: T_Pattern_v40 v40 = \ (T_Pattern_vIn40 ) -> ( let _patX41 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) (T_Pattern_vOut40 _patIcopy _patIdefinedInsts _patIpatternAttributes) = inv_Pattern_s41 _patX41 (T_Pattern_vIn40 ) _lhsOdefinedInsts :: [Identifier] _lhsOdefinedInsts = rule649 _patIdefinedInsts arg_attr_ arg_field_ _lhsOpatternAttributes :: [(Identifier, Identifier)] _lhsOpatternAttributes = rule650 _patIpatternAttributes arg_attr_ arg_field_ _copy = rule651 _patIcopy arg_attr_ arg_field_ _lhsOcopy :: Pattern _lhsOcopy = rule652 _copy __result_ = T_Pattern_vOut40 _lhsOcopy _lhsOdefinedInsts _lhsOpatternAttributes in __result_ ) in C_Pattern_s41 v40 {-# INLINE rule649 #-} {-# LINE 264 "./src-ag/GenerateCode.ag" #-} rule649 = \ ((_patIdefinedInsts) :: [Identifier]) attr_ field_ -> {-# LINE 264 "./src-ag/GenerateCode.ag" #-} (if field_ == _INST then [attr_] else []) ++ _patIdefinedInsts {-# LINE 4584 "dist/build/GenerateCode.hs"#-} {-# INLINE rule650 #-} {-# LINE 272 "./src-ag/GenerateCode.ag" #-} rule650 = \ ((_patIpatternAttributes) :: [(Identifier, Identifier)]) attr_ field_ -> {-# LINE 272 "./src-ag/GenerateCode.ag" #-} (field_,attr_) : _patIpatternAttributes {-# LINE 4590 "dist/build/GenerateCode.hs"#-} {-# INLINE rule651 #-} rule651 = \ ((_patIcopy) :: Pattern) attr_ field_ -> Alias field_ attr_ _patIcopy {-# INLINE rule652 #-} rule652 = \ _copy -> _copy {-# NOINLINE sem_Pattern_Irrefutable #-} sem_Pattern_Irrefutable :: T_Pattern -> T_Pattern sem_Pattern_Irrefutable arg_pat_ = T_Pattern (return st41) where {-# NOINLINE st41 #-} st41 = let v40 :: T_Pattern_v40 v40 = \ (T_Pattern_vIn40 ) -> ( let _patX41 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) (T_Pattern_vOut40 _patIcopy _patIdefinedInsts _patIpatternAttributes) = inv_Pattern_s41 _patX41 (T_Pattern_vIn40 ) _lhsOdefinedInsts :: [Identifier] _lhsOdefinedInsts = rule653 _patIdefinedInsts _lhsOpatternAttributes :: [(Identifier, Identifier)] _lhsOpatternAttributes = rule654 _patIpatternAttributes _copy = rule655 _patIcopy _lhsOcopy :: Pattern _lhsOcopy = rule656 _copy __result_ = T_Pattern_vOut40 _lhsOcopy _lhsOdefinedInsts _lhsOpatternAttributes in __result_ ) in C_Pattern_s41 v40 {-# INLINE rule653 #-} rule653 = \ ((_patIdefinedInsts) :: [Identifier]) -> _patIdefinedInsts {-# INLINE rule654 #-} rule654 = \ ((_patIpatternAttributes) :: [(Identifier, Identifier)]) -> _patIpatternAttributes {-# INLINE rule655 #-} rule655 = \ ((_patIcopy) :: Pattern) -> Irrefutable _patIcopy {-# INLINE rule656 #-} rule656 = \ _copy -> _copy {-# NOINLINE sem_Pattern_Underscore #-} sem_Pattern_Underscore :: (Pos) -> T_Pattern sem_Pattern_Underscore arg_pos_ = T_Pattern (return st41) where {-# NOINLINE st41 #-} st41 = let v40 :: T_Pattern_v40 v40 = \ (T_Pattern_vIn40 ) -> ( let _lhsOdefinedInsts :: [Identifier] _lhsOdefinedInsts = rule657 () _lhsOpatternAttributes :: [(Identifier, Identifier)] _lhsOpatternAttributes = rule658 () _copy = rule659 arg_pos_ _lhsOcopy :: Pattern _lhsOcopy = rule660 _copy __result_ = T_Pattern_vOut40 _lhsOcopy _lhsOdefinedInsts _lhsOpatternAttributes in __result_ ) in C_Pattern_s41 v40 {-# INLINE rule657 #-} rule657 = \ (_ :: ()) -> [] {-# INLINE rule658 #-} rule658 = \ (_ :: ()) -> [] {-# INLINE rule659 #-} rule659 = \ pos_ -> Underscore pos_ {-# INLINE rule660 #-} rule660 = \ _copy -> _copy -- Patterns ---------------------------------------------------- -- wrapper data Inh_Patterns = Inh_Patterns { } data Syn_Patterns = Syn_Patterns { copy_Syn_Patterns :: (Patterns), definedInsts_Syn_Patterns :: ([Identifier]), patternAttributes_Syn_Patterns :: ([(Identifier, Identifier)]) } {-# INLINABLE wrap_Patterns #-} wrap_Patterns :: T_Patterns -> Inh_Patterns -> (Syn_Patterns ) wrap_Patterns (T_Patterns act) (Inh_Patterns ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Patterns_vIn43 (T_Patterns_vOut43 _lhsOcopy _lhsOdefinedInsts _lhsOpatternAttributes) <- return (inv_Patterns_s44 sem arg) return (Syn_Patterns _lhsOcopy _lhsOdefinedInsts _lhsOpatternAttributes) ) -- cata {-# NOINLINE sem_Patterns #-} sem_Patterns :: Patterns -> T_Patterns sem_Patterns list = Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list) -- semantic domain newtype T_Patterns = T_Patterns { attach_T_Patterns :: Identity (T_Patterns_s44 ) } newtype T_Patterns_s44 = C_Patterns_s44 { inv_Patterns_s44 :: (T_Patterns_v43 ) } data T_Patterns_s45 = C_Patterns_s45 type T_Patterns_v43 = (T_Patterns_vIn43 ) -> (T_Patterns_vOut43 ) data T_Patterns_vIn43 = T_Patterns_vIn43 data T_Patterns_vOut43 = T_Patterns_vOut43 (Patterns) ([Identifier]) ([(Identifier, Identifier)]) {-# NOINLINE sem_Patterns_Cons #-} sem_Patterns_Cons :: T_Pattern -> T_Patterns -> T_Patterns sem_Patterns_Cons arg_hd_ arg_tl_ = T_Patterns (return st44) where {-# NOINLINE st44 #-} st44 = let v43 :: T_Patterns_v43 v43 = \ (T_Patterns_vIn43 ) -> ( let _hdX41 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_hd_)) _tlX44 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_tl_)) (T_Pattern_vOut40 _hdIcopy _hdIdefinedInsts _hdIpatternAttributes) = inv_Pattern_s41 _hdX41 (T_Pattern_vIn40 ) (T_Patterns_vOut43 _tlIcopy _tlIdefinedInsts _tlIpatternAttributes) = inv_Patterns_s44 _tlX44 (T_Patterns_vIn43 ) _lhsOdefinedInsts :: [Identifier] _lhsOdefinedInsts = rule661 _hdIdefinedInsts _tlIdefinedInsts _lhsOpatternAttributes :: [(Identifier, Identifier)] _lhsOpatternAttributes = rule662 _hdIpatternAttributes _tlIpatternAttributes _copy = rule663 _hdIcopy _tlIcopy _lhsOcopy :: Patterns _lhsOcopy = rule664 _copy __result_ = T_Patterns_vOut43 _lhsOcopy _lhsOdefinedInsts _lhsOpatternAttributes in __result_ ) in C_Patterns_s44 v43 {-# INLINE rule661 #-} rule661 = \ ((_hdIdefinedInsts) :: [Identifier]) ((_tlIdefinedInsts) :: [Identifier]) -> _hdIdefinedInsts ++ _tlIdefinedInsts {-# INLINE rule662 #-} rule662 = \ ((_hdIpatternAttributes) :: [(Identifier, Identifier)]) ((_tlIpatternAttributes) :: [(Identifier, Identifier)]) -> _hdIpatternAttributes ++ _tlIpatternAttributes {-# INLINE rule663 #-} rule663 = \ ((_hdIcopy) :: Pattern) ((_tlIcopy) :: Patterns) -> (:) _hdIcopy _tlIcopy {-# INLINE rule664 #-} rule664 = \ _copy -> _copy {-# NOINLINE sem_Patterns_Nil #-} sem_Patterns_Nil :: T_Patterns sem_Patterns_Nil = T_Patterns (return st44) where {-# NOINLINE st44 #-} st44 = let v43 :: T_Patterns_v43 v43 = \ (T_Patterns_vIn43 ) -> ( let _lhsOdefinedInsts :: [Identifier] _lhsOdefinedInsts = rule665 () _lhsOpatternAttributes :: [(Identifier, Identifier)] _lhsOpatternAttributes = rule666 () _copy = rule667 () _lhsOcopy :: Patterns _lhsOcopy = rule668 _copy __result_ = T_Patterns_vOut43 _lhsOcopy _lhsOdefinedInsts _lhsOpatternAttributes in __result_ ) in C_Patterns_s44 v43 {-# INLINE rule665 #-} rule665 = \ (_ :: ()) -> [] {-# INLINE rule666 #-} rule666 = \ (_ :: ()) -> [] {-# INLINE rule667 #-} rule667 = \ (_ :: ()) -> [] {-# INLINE rule668 #-} rule668 = \ _copy -> _copy -- Sequence ---------------------------------------------------- -- wrapper data Inh_Sequence = Inh_Sequence { allNts_Inh_Sequence :: (Set NontermIdent), aroundMap_Inh_Sequence :: (Set Identifier), children_Inh_Sequence :: ([(Identifier,Type,ChildKind)]), con_Inh_Sequence :: (ConstructorIdent), declsAbove_Inh_Sequence :: ([Decl]), inh_Inh_Sequence :: (Attributes), instVisitNrs_Inh_Sequence :: (Map Identifier Int), lastExpr_Inh_Sequence :: (Expr), mergeMap_Inh_Sequence :: (Map Identifier (Identifier, [Identifier])), nr_Inh_Sequence :: (Int), nt_Inh_Sequence :: (NontermIdent), o_case_Inh_Sequence :: (Bool), o_cata_Inh_Sequence :: (Bool), o_costcentre_Inh_Sequence :: (Bool), o_data_Inh_Sequence :: (Maybe Bool), o_linePragmas_Inh_Sequence :: (Bool), o_monadic_Inh_Sequence :: (Bool), o_newtypes_Inh_Sequence :: (Bool), o_pretty_Inh_Sequence :: (Bool), o_rename_Inh_Sequence :: (Bool), o_sem_Inh_Sequence :: (Bool), o_sig_Inh_Sequence :: (Bool), o_splitsems_Inh_Sequence :: (Bool), o_strictwrap_Inh_Sequence :: (Bool), o_traces_Inh_Sequence :: (Bool), o_unbox_Inh_Sequence :: (Bool), options_Inh_Sequence :: (Options), paramInstMap_Inh_Sequence :: (Map Identifier (NontermIdent, [String])), paramMap_Inh_Sequence :: (ParamMap), prefix_Inh_Sequence :: (String), syn_Inh_Sequence :: (Attributes), terminals_Inh_Sequence :: ([Identifier]), unfoldSemDom_Inh_Sequence :: (NontermIdent -> Int -> [String] -> Code.Type), visitedSet_Inh_Sequence :: (Set Identifier), what_Inh_Sequence :: (String) } data Syn_Sequence = Syn_Sequence { allTpsFound_Syn_Sequence :: (Bool), blockDecls_Syn_Sequence :: (DeclBlocks), comments_Syn_Sequence :: ([String]), decls_Syn_Sequence :: (Decls), declsAbove_Syn_Sequence :: ([Decl]), definedInsts_Syn_Sequence :: ([Identifier]), exprs_Syn_Sequence :: (Exprs), tSigs_Syn_Sequence :: ([Decl]), tps_Syn_Sequence :: ([Type]), usedVars_Syn_Sequence :: (Set String), visitedSet_Syn_Sequence :: (Set Identifier) } {-# INLINABLE wrap_Sequence #-} wrap_Sequence :: T_Sequence -> Inh_Sequence -> (Syn_Sequence ) wrap_Sequence (T_Sequence act) (Inh_Sequence _lhsIallNts _lhsIaroundMap _lhsIchildren _lhsIcon _lhsIdeclsAbove _lhsIinh _lhsIinstVisitNrs _lhsIlastExpr _lhsImergeMap _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamInstMap _lhsIparamMap _lhsIprefix _lhsIsyn _lhsIterminals _lhsIunfoldSemDom _lhsIvisitedSet _lhsIwhat) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Sequence_vIn46 _lhsIallNts _lhsIaroundMap _lhsIchildren _lhsIcon _lhsIdeclsAbove _lhsIinh _lhsIinstVisitNrs _lhsIlastExpr _lhsImergeMap _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamInstMap _lhsIparamMap _lhsIprefix _lhsIsyn _lhsIterminals _lhsIunfoldSemDom _lhsIvisitedSet _lhsIwhat (T_Sequence_vOut46 _lhsOallTpsFound _lhsOblockDecls _lhsOcomments _lhsOdecls _lhsOdeclsAbove _lhsOdefinedInsts _lhsOexprs _lhsOtSigs _lhsOtps _lhsOusedVars _lhsOvisitedSet) <- return (inv_Sequence_s47 sem arg) return (Syn_Sequence _lhsOallTpsFound _lhsOblockDecls _lhsOcomments _lhsOdecls _lhsOdeclsAbove _lhsOdefinedInsts _lhsOexprs _lhsOtSigs _lhsOtps _lhsOusedVars _lhsOvisitedSet) ) -- cata {-# NOINLINE sem_Sequence #-} sem_Sequence :: Sequence -> T_Sequence sem_Sequence list = Prelude.foldr sem_Sequence_Cons sem_Sequence_Nil (Prelude.map sem_CRule list) -- semantic domain newtype T_Sequence = T_Sequence { attach_T_Sequence :: Identity (T_Sequence_s47 ) } newtype T_Sequence_s47 = C_Sequence_s47 { inv_Sequence_s47 :: (T_Sequence_v46 ) } data T_Sequence_s48 = C_Sequence_s48 type T_Sequence_v46 = (T_Sequence_vIn46 ) -> (T_Sequence_vOut46 ) data T_Sequence_vIn46 = T_Sequence_vIn46 (Set NontermIdent) (Set Identifier) ([(Identifier,Type,ChildKind)]) (ConstructorIdent) ([Decl]) (Attributes) (Map Identifier Int) (Expr) (Map Identifier (Identifier, [Identifier])) (Int) (NontermIdent) (Bool) (Bool) (Bool) (Maybe Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Options) (Map Identifier (NontermIdent, [String])) (ParamMap) (String) (Attributes) ([Identifier]) (NontermIdent -> Int -> [String] -> Code.Type) (Set Identifier) (String) data T_Sequence_vOut46 = T_Sequence_vOut46 (Bool) (DeclBlocks) ([String]) (Decls) ([Decl]) ([Identifier]) (Exprs) ([Decl]) ([Type]) (Set String) (Set Identifier) {-# NOINLINE sem_Sequence_Cons #-} sem_Sequence_Cons :: T_CRule -> T_Sequence -> T_Sequence sem_Sequence_Cons arg_hd_ arg_tl_ = T_Sequence (return st47) where {-# NOINLINE st47 #-} st47 = let v46 :: T_Sequence_v46 v46 = \ (T_Sequence_vIn46 _lhsIallNts _lhsIaroundMap _lhsIchildren _lhsIcon _lhsIdeclsAbove _lhsIinh _lhsIinstVisitNrs _lhsIlastExpr _lhsImergeMap _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamInstMap _lhsIparamMap _lhsIprefix _lhsIsyn _lhsIterminals _lhsIunfoldSemDom _lhsIvisitedSet _lhsIwhat) -> ( let _hdX20 = Control.Monad.Identity.runIdentity (attach_T_CRule (arg_hd_)) _tlX47 = Control.Monad.Identity.runIdentity (attach_T_Sequence (arg_tl_)) (T_CRule_vOut19 _hdIallTpsFound _hdIbldBlocksFun _hdIcomments _hdIdecls _hdIdeclsAbove _hdIdefinedInsts _hdIexprs _hdItSigs _hdItps _hdIusedVars _hdIvisitedSet) = inv_CRule_s20 _hdX20 (T_CRule_vIn19 _hdOallNts _hdOaroundMap _hdOchildren _hdOcon _hdOdeclsAbove _hdOinh _hdOinstVisitNrs _hdOmergeMap _hdOnr _hdOnt _hdOo_case _hdOo_cata _hdOo_costcentre _hdOo_data _hdOo_linePragmas _hdOo_monadic _hdOo_newtypes _hdOo_pretty _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_splitsems _hdOo_strictwrap _hdOo_traces _hdOo_unbox _hdOoptions _hdOparamInstMap _hdOparamMap _hdOprefix _hdOsyn _hdOterminals _hdOunfoldSemDom _hdOvisitedSet _hdOwhat) (T_Sequence_vOut46 _tlIallTpsFound _tlIblockDecls _tlIcomments _tlIdecls _tlIdeclsAbove _tlIdefinedInsts _tlIexprs _tlItSigs _tlItps _tlIusedVars _tlIvisitedSet) = inv_Sequence_s47 _tlX47 (T_Sequence_vIn46 _tlOallNts _tlOaroundMap _tlOchildren _tlOcon _tlOdeclsAbove _tlOinh _tlOinstVisitNrs _tlOlastExpr _tlOmergeMap _tlOnr _tlOnt _tlOo_case _tlOo_cata _tlOo_costcentre _tlOo_data _tlOo_linePragmas _tlOo_monadic _tlOo_newtypes _tlOo_pretty _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_splitsems _tlOo_strictwrap _tlOo_traces _tlOo_unbox _tlOoptions _tlOparamInstMap _tlOparamMap _tlOprefix _tlOsyn _tlOterminals _tlOunfoldSemDom _tlOvisitedSet _tlOwhat) _lhsOblockDecls :: DeclBlocks _lhsOblockDecls = rule669 _hdIbldBlocksFun _tlIblockDecls _lhsOallTpsFound :: Bool _lhsOallTpsFound = rule670 _hdIallTpsFound _tlIallTpsFound _lhsOcomments :: [String] _lhsOcomments = rule671 _hdIcomments _tlIcomments _lhsOdecls :: Decls _lhsOdecls = rule672 _hdIdecls _tlIdecls _lhsOdefinedInsts :: [Identifier] _lhsOdefinedInsts = rule673 _hdIdefinedInsts _tlIdefinedInsts _lhsOexprs :: Exprs _lhsOexprs = rule674 _hdIexprs _tlIexprs _lhsOtSigs :: [Decl] _lhsOtSigs = rule675 _hdItSigs _tlItSigs _lhsOtps :: [Type] _lhsOtps = rule676 _hdItps _tlItps _lhsOusedVars :: Set String _lhsOusedVars = rule677 _hdIusedVars _tlIusedVars _lhsOdeclsAbove :: [Decl] _lhsOdeclsAbove = rule678 _tlIdeclsAbove _lhsOvisitedSet :: Set Identifier _lhsOvisitedSet = rule679 _tlIvisitedSet _hdOallNts = rule680 _lhsIallNts _hdOaroundMap = rule681 _lhsIaroundMap _hdOchildren = rule682 _lhsIchildren _hdOcon = rule683 _lhsIcon _hdOdeclsAbove = rule684 _lhsIdeclsAbove _hdOinh = rule685 _lhsIinh _hdOinstVisitNrs = rule686 _lhsIinstVisitNrs _hdOmergeMap = rule687 _lhsImergeMap _hdOnr = rule688 _lhsInr _hdOnt = rule689 _lhsInt _hdOo_case = rule690 _lhsIo_case _hdOo_cata = rule691 _lhsIo_cata _hdOo_costcentre = rule692 _lhsIo_costcentre _hdOo_data = rule693 _lhsIo_data _hdOo_linePragmas = rule694 _lhsIo_linePragmas _hdOo_monadic = rule695 _lhsIo_monadic _hdOo_newtypes = rule696 _lhsIo_newtypes _hdOo_pretty = rule697 _lhsIo_pretty _hdOo_rename = rule698 _lhsIo_rename _hdOo_sem = rule699 _lhsIo_sem _hdOo_sig = rule700 _lhsIo_sig _hdOo_splitsems = rule701 _lhsIo_splitsems _hdOo_strictwrap = rule702 _lhsIo_strictwrap _hdOo_traces = rule703 _lhsIo_traces _hdOo_unbox = rule704 _lhsIo_unbox _hdOoptions = rule705 _lhsIoptions _hdOparamInstMap = rule706 _lhsIparamInstMap _hdOparamMap = rule707 _lhsIparamMap _hdOprefix = rule708 _lhsIprefix _hdOsyn = rule709 _lhsIsyn _hdOterminals = rule710 _lhsIterminals _hdOunfoldSemDom = rule711 _lhsIunfoldSemDom _hdOvisitedSet = rule712 _lhsIvisitedSet _hdOwhat = rule713 _lhsIwhat _tlOallNts = rule714 _lhsIallNts _tlOaroundMap = rule715 _lhsIaroundMap _tlOchildren = rule716 _lhsIchildren _tlOcon = rule717 _lhsIcon _tlOdeclsAbove = rule718 _hdIdeclsAbove _tlOinh = rule719 _lhsIinh _tlOinstVisitNrs = rule720 _lhsIinstVisitNrs _tlOlastExpr = rule721 _lhsIlastExpr _tlOmergeMap = rule722 _lhsImergeMap _tlOnr = rule723 _lhsInr _tlOnt = rule724 _lhsInt _tlOo_case = rule725 _lhsIo_case _tlOo_cata = rule726 _lhsIo_cata _tlOo_costcentre = rule727 _lhsIo_costcentre _tlOo_data = rule728 _lhsIo_data _tlOo_linePragmas = rule729 _lhsIo_linePragmas _tlOo_monadic = rule730 _lhsIo_monadic _tlOo_newtypes = rule731 _lhsIo_newtypes _tlOo_pretty = rule732 _lhsIo_pretty _tlOo_rename = rule733 _lhsIo_rename _tlOo_sem = rule734 _lhsIo_sem _tlOo_sig = rule735 _lhsIo_sig _tlOo_splitsems = rule736 _lhsIo_splitsems _tlOo_strictwrap = rule737 _lhsIo_strictwrap _tlOo_traces = rule738 _lhsIo_traces _tlOo_unbox = rule739 _lhsIo_unbox _tlOoptions = rule740 _lhsIoptions _tlOparamInstMap = rule741 _lhsIparamInstMap _tlOparamMap = rule742 _lhsIparamMap _tlOprefix = rule743 _lhsIprefix _tlOsyn = rule744 _lhsIsyn _tlOterminals = rule745 _lhsIterminals _tlOunfoldSemDom = rule746 _lhsIunfoldSemDom _tlOvisitedSet = rule747 _hdIvisitedSet _tlOwhat = rule748 _lhsIwhat __result_ = T_Sequence_vOut46 _lhsOallTpsFound _lhsOblockDecls _lhsOcomments _lhsOdecls _lhsOdeclsAbove _lhsOdefinedInsts _lhsOexprs _lhsOtSigs _lhsOtps _lhsOusedVars _lhsOvisitedSet in __result_ ) in C_Sequence_s47 v46 {-# INLINE rule669 #-} {-# LINE 624 "./src-ag/GenerateCode.ag" #-} rule669 = \ ((_hdIbldBlocksFun) :: DeclBlocks -> DeclBlocks) ((_tlIblockDecls) :: DeclBlocks) -> {-# LINE 624 "./src-ag/GenerateCode.ag" #-} _hdIbldBlocksFun _tlIblockDecls {-# LINE 4891 "dist/build/GenerateCode.hs"#-} {-# INLINE rule670 #-} rule670 = \ ((_hdIallTpsFound) :: Bool) ((_tlIallTpsFound) :: Bool) -> _hdIallTpsFound && _tlIallTpsFound {-# INLINE rule671 #-} rule671 = \ ((_hdIcomments) :: [String]) ((_tlIcomments) :: [String]) -> _hdIcomments ++ _tlIcomments {-# INLINE rule672 #-} rule672 = \ ((_hdIdecls) :: Decls) ((_tlIdecls) :: Decls) -> _hdIdecls ++ _tlIdecls {-# INLINE rule673 #-} rule673 = \ ((_hdIdefinedInsts) :: [Identifier]) ((_tlIdefinedInsts) :: [Identifier]) -> _hdIdefinedInsts ++ _tlIdefinedInsts {-# INLINE rule674 #-} rule674 = \ ((_hdIexprs) :: Exprs) ((_tlIexprs) :: Exprs) -> _hdIexprs ++ _tlIexprs {-# INLINE rule675 #-} rule675 = \ ((_hdItSigs) :: [Decl]) ((_tlItSigs) :: [Decl]) -> _hdItSigs ++ _tlItSigs {-# INLINE rule676 #-} rule676 = \ ((_hdItps) :: [Type]) ((_tlItps) :: [Type]) -> _hdItps ++ _tlItps {-# INLINE rule677 #-} rule677 = \ ((_hdIusedVars) :: Set String) ((_tlIusedVars) :: Set String) -> _hdIusedVars `Set.union` _tlIusedVars {-# INLINE rule678 #-} rule678 = \ ((_tlIdeclsAbove) :: [Decl]) -> _tlIdeclsAbove {-# INLINE rule679 #-} rule679 = \ ((_tlIvisitedSet) :: Set Identifier) -> _tlIvisitedSet {-# INLINE rule680 #-} rule680 = \ ((_lhsIallNts) :: Set NontermIdent) -> _lhsIallNts {-# INLINE rule681 #-} rule681 = \ ((_lhsIaroundMap) :: Set Identifier) -> _lhsIaroundMap {-# INLINE rule682 #-} rule682 = \ ((_lhsIchildren) :: [(Identifier,Type,ChildKind)]) -> _lhsIchildren {-# INLINE rule683 #-} rule683 = \ ((_lhsIcon) :: ConstructorIdent) -> _lhsIcon {-# INLINE rule684 #-} rule684 = \ ((_lhsIdeclsAbove) :: [Decl]) -> _lhsIdeclsAbove {-# INLINE rule685 #-} rule685 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule686 #-} rule686 = \ ((_lhsIinstVisitNrs) :: Map Identifier Int) -> _lhsIinstVisitNrs {-# INLINE rule687 #-} rule687 = \ ((_lhsImergeMap) :: Map Identifier (Identifier, [Identifier])) -> _lhsImergeMap {-# INLINE rule688 #-} rule688 = \ ((_lhsInr) :: Int) -> _lhsInr {-# INLINE rule689 #-} rule689 = \ ((_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule690 #-} rule690 = \ ((_lhsIo_case) :: Bool) -> _lhsIo_case {-# INLINE rule691 #-} rule691 = \ ((_lhsIo_cata) :: Bool) -> _lhsIo_cata {-# INLINE rule692 #-} rule692 = \ ((_lhsIo_costcentre) :: Bool) -> _lhsIo_costcentre {-# INLINE rule693 #-} rule693 = \ ((_lhsIo_data) :: Maybe Bool) -> _lhsIo_data {-# INLINE rule694 #-} rule694 = \ ((_lhsIo_linePragmas) :: Bool) -> _lhsIo_linePragmas {-# INLINE rule695 #-} rule695 = \ ((_lhsIo_monadic) :: Bool) -> _lhsIo_monadic {-# INLINE rule696 #-} rule696 = \ ((_lhsIo_newtypes) :: Bool) -> _lhsIo_newtypes {-# INLINE rule697 #-} rule697 = \ ((_lhsIo_pretty) :: Bool) -> _lhsIo_pretty {-# INLINE rule698 #-} rule698 = \ ((_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# INLINE rule699 #-} rule699 = \ ((_lhsIo_sem) :: Bool) -> _lhsIo_sem {-# INLINE rule700 #-} rule700 = \ ((_lhsIo_sig) :: Bool) -> _lhsIo_sig {-# INLINE rule701 #-} rule701 = \ ((_lhsIo_splitsems) :: Bool) -> _lhsIo_splitsems {-# INLINE rule702 #-} rule702 = \ ((_lhsIo_strictwrap) :: Bool) -> _lhsIo_strictwrap {-# INLINE rule703 #-} rule703 = \ ((_lhsIo_traces) :: Bool) -> _lhsIo_traces {-# INLINE rule704 #-} rule704 = \ ((_lhsIo_unbox) :: Bool) -> _lhsIo_unbox {-# INLINE rule705 #-} rule705 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule706 #-} rule706 = \ ((_lhsIparamInstMap) :: Map Identifier (NontermIdent, [String])) -> _lhsIparamInstMap {-# INLINE rule707 #-} rule707 = \ ((_lhsIparamMap) :: ParamMap) -> _lhsIparamMap {-# INLINE rule708 #-} rule708 = \ ((_lhsIprefix) :: String) -> _lhsIprefix {-# INLINE rule709 #-} rule709 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# INLINE rule710 #-} rule710 = \ ((_lhsIterminals) :: [Identifier]) -> _lhsIterminals {-# INLINE rule711 #-} rule711 = \ ((_lhsIunfoldSemDom) :: NontermIdent -> Int -> [String] -> Code.Type) -> _lhsIunfoldSemDom {-# INLINE rule712 #-} rule712 = \ ((_lhsIvisitedSet) :: Set Identifier) -> _lhsIvisitedSet {-# INLINE rule713 #-} rule713 = \ ((_lhsIwhat) :: String) -> _lhsIwhat {-# INLINE rule714 #-} rule714 = \ ((_lhsIallNts) :: Set NontermIdent) -> _lhsIallNts {-# INLINE rule715 #-} rule715 = \ ((_lhsIaroundMap) :: Set Identifier) -> _lhsIaroundMap {-# INLINE rule716 #-} rule716 = \ ((_lhsIchildren) :: [(Identifier,Type,ChildKind)]) -> _lhsIchildren {-# INLINE rule717 #-} rule717 = \ ((_lhsIcon) :: ConstructorIdent) -> _lhsIcon {-# INLINE rule718 #-} rule718 = \ ((_hdIdeclsAbove) :: [Decl]) -> _hdIdeclsAbove {-# INLINE rule719 #-} rule719 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule720 #-} rule720 = \ ((_lhsIinstVisitNrs) :: Map Identifier Int) -> _lhsIinstVisitNrs {-# INLINE rule721 #-} rule721 = \ ((_lhsIlastExpr) :: Expr) -> _lhsIlastExpr {-# INLINE rule722 #-} rule722 = \ ((_lhsImergeMap) :: Map Identifier (Identifier, [Identifier])) -> _lhsImergeMap {-# INLINE rule723 #-} rule723 = \ ((_lhsInr) :: Int) -> _lhsInr {-# INLINE rule724 #-} rule724 = \ ((_lhsInt) :: NontermIdent) -> _lhsInt {-# INLINE rule725 #-} rule725 = \ ((_lhsIo_case) :: Bool) -> _lhsIo_case {-# INLINE rule726 #-} rule726 = \ ((_lhsIo_cata) :: Bool) -> _lhsIo_cata {-# INLINE rule727 #-} rule727 = \ ((_lhsIo_costcentre) :: Bool) -> _lhsIo_costcentre {-# INLINE rule728 #-} rule728 = \ ((_lhsIo_data) :: Maybe Bool) -> _lhsIo_data {-# INLINE rule729 #-} rule729 = \ ((_lhsIo_linePragmas) :: Bool) -> _lhsIo_linePragmas {-# INLINE rule730 #-} rule730 = \ ((_lhsIo_monadic) :: Bool) -> _lhsIo_monadic {-# INLINE rule731 #-} rule731 = \ ((_lhsIo_newtypes) :: Bool) -> _lhsIo_newtypes {-# INLINE rule732 #-} rule732 = \ ((_lhsIo_pretty) :: Bool) -> _lhsIo_pretty {-# INLINE rule733 #-} rule733 = \ ((_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# INLINE rule734 #-} rule734 = \ ((_lhsIo_sem) :: Bool) -> _lhsIo_sem {-# INLINE rule735 #-} rule735 = \ ((_lhsIo_sig) :: Bool) -> _lhsIo_sig {-# INLINE rule736 #-} rule736 = \ ((_lhsIo_splitsems) :: Bool) -> _lhsIo_splitsems {-# INLINE rule737 #-} rule737 = \ ((_lhsIo_strictwrap) :: Bool) -> _lhsIo_strictwrap {-# INLINE rule738 #-} rule738 = \ ((_lhsIo_traces) :: Bool) -> _lhsIo_traces {-# INLINE rule739 #-} rule739 = \ ((_lhsIo_unbox) :: Bool) -> _lhsIo_unbox {-# INLINE rule740 #-} rule740 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule741 #-} rule741 = \ ((_lhsIparamInstMap) :: Map Identifier (NontermIdent, [String])) -> _lhsIparamInstMap {-# INLINE rule742 #-} rule742 = \ ((_lhsIparamMap) :: ParamMap) -> _lhsIparamMap {-# INLINE rule743 #-} rule743 = \ ((_lhsIprefix) :: String) -> _lhsIprefix {-# INLINE rule744 #-} rule744 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# INLINE rule745 #-} rule745 = \ ((_lhsIterminals) :: [Identifier]) -> _lhsIterminals {-# INLINE rule746 #-} rule746 = \ ((_lhsIunfoldSemDom) :: NontermIdent -> Int -> [String] -> Code.Type) -> _lhsIunfoldSemDom {-# INLINE rule747 #-} rule747 = \ ((_hdIvisitedSet) :: Set Identifier) -> _hdIvisitedSet {-# INLINE rule748 #-} rule748 = \ ((_lhsIwhat) :: String) -> _lhsIwhat {-# NOINLINE sem_Sequence_Nil #-} sem_Sequence_Nil :: T_Sequence sem_Sequence_Nil = T_Sequence (return st47) where {-# NOINLINE st47 #-} st47 = let v46 :: T_Sequence_v46 v46 = \ (T_Sequence_vIn46 _lhsIallNts _lhsIaroundMap _lhsIchildren _lhsIcon _lhsIdeclsAbove _lhsIinh _lhsIinstVisitNrs _lhsIlastExpr _lhsImergeMap _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamInstMap _lhsIparamMap _lhsIprefix _lhsIsyn _lhsIterminals _lhsIunfoldSemDom _lhsIvisitedSet _lhsIwhat) -> ( let _lhsOblockDecls :: DeclBlocks _lhsOblockDecls = rule749 _lhsIdeclsAbove _lhsIlastExpr _lhsOallTpsFound :: Bool _lhsOallTpsFound = rule750 () _lhsOcomments :: [String] _lhsOcomments = rule751 () _lhsOdecls :: Decls _lhsOdecls = rule752 () _lhsOdefinedInsts :: [Identifier] _lhsOdefinedInsts = rule753 () _lhsOexprs :: Exprs _lhsOexprs = rule754 () _lhsOtSigs :: [Decl] _lhsOtSigs = rule755 () _lhsOtps :: [Type] _lhsOtps = rule756 () _lhsOusedVars :: Set String _lhsOusedVars = rule757 () _lhsOdeclsAbove :: [Decl] _lhsOdeclsAbove = rule758 _lhsIdeclsAbove _lhsOvisitedSet :: Set Identifier _lhsOvisitedSet = rule759 _lhsIvisitedSet __result_ = T_Sequence_vOut46 _lhsOallTpsFound _lhsOblockDecls _lhsOcomments _lhsOdecls _lhsOdeclsAbove _lhsOdefinedInsts _lhsOexprs _lhsOtSigs _lhsOtps _lhsOusedVars _lhsOvisitedSet in __result_ ) in C_Sequence_s47 v46 {-# INLINE rule749 #-} {-# LINE 626 "./src-ag/GenerateCode.ag" #-} rule749 = \ ((_lhsIdeclsAbove) :: [Decl]) ((_lhsIlastExpr) :: Expr) -> {-# LINE 626 "./src-ag/GenerateCode.ag" #-} DeclTerminator _lhsIdeclsAbove _lhsIlastExpr {-# LINE 5166 "dist/build/GenerateCode.hs"#-} {-# INLINE rule750 #-} rule750 = \ (_ :: ()) -> True {-# INLINE rule751 #-} rule751 = \ (_ :: ()) -> [] {-# INLINE rule752 #-} rule752 = \ (_ :: ()) -> [] {-# INLINE rule753 #-} rule753 = \ (_ :: ()) -> [] {-# INLINE rule754 #-} rule754 = \ (_ :: ()) -> [] {-# INLINE rule755 #-} rule755 = \ (_ :: ()) -> [] {-# INLINE rule756 #-} rule756 = \ (_ :: ()) -> [] {-# INLINE rule757 #-} rule757 = \ (_ :: ()) -> Set.empty {-# INLINE rule758 #-} rule758 = \ ((_lhsIdeclsAbove) :: [Decl]) -> _lhsIdeclsAbove {-# INLINE rule759 #-} rule759 = \ ((_lhsIvisitedSet) :: Set Identifier) -> _lhsIvisitedSet uuagc-0.9.42.3/src-generated/HsToken.hs000644 000765 000024 00000003435 12127045231 021505 0ustar00jeroenbransenstaff000000 000000 -- UUAGC 0.9.42.3 (src-ag/HsToken.ag) module HsToken where {-# LINE 2 "./src-ag/HsToken.ag" #-} import CommonTypes import UU.Scanner.Position(Pos) {-# LINE 10 "dist/build/HsToken.hs" #-} -- HsToken ----------------------------------------------------- {- alternatives: alternative AGLocal: child var : {Identifier} child pos : {Pos} child rdesc : {Maybe String} alternative AGField: child field : {Identifier} child attr : {Identifier} child pos : {Pos} child rdesc : {Maybe String} alternative HsToken: child value : {String} child pos : {Pos} alternative CharToken: child value : {String} child pos : {Pos} alternative StrToken: child value : {String} child pos : {Pos} alternative Err: child mesg : {String} child pos : {Pos} -} data HsToken = AGLocal (Identifier) (Pos) ((Maybe String)) | AGField (Identifier) (Identifier) (Pos) ((Maybe String)) | HsToken (String) (Pos) | CharToken (String) (Pos) | StrToken (String) (Pos) | Err (String) (Pos) deriving ( Show) -- HsTokens ---------------------------------------------------- {- alternatives: alternative Cons: child hd : HsToken child tl : HsTokens alternative Nil: -} type HsTokens = [HsToken] -- HsTokensRoot ------------------------------------------------ {- alternatives: alternative HsTokensRoot: child tokens : HsTokens -} data HsTokensRoot = HsTokensRoot (HsTokens)uuagc-0.9.42.3/src-generated/Interfaces.hs000644 000765 000024 00000002666 12127045231 022222 0ustar00jeroenbransenstaff000000 000000 -- UUAGC 0.9.42.3 (src-ag/Interfaces.ag) module Interfaces where {-# LINE 2 "./src-ag/Interfaces.ag" #-} import CommonTypes import SequentialTypes {-# LINE 10 "dist/build/Interfaces.hs" #-} -- IRoot ------------------------------------------------------- {- alternatives: alternative IRoot: child inters : Interfaces -} data IRoot = IRoot (Interfaces) -- Interface --------------------------------------------------- {- alternatives: alternative Interface: child nt : {NontermIdent} child cons : {[ConstructorIdent]} child seg : Segments -} data Interface = Interface (NontermIdent) (([ConstructorIdent])) (Segments) -- Interfaces -------------------------------------------------- {- alternatives: alternative Cons: child hd : Interface child tl : Interfaces alternative Nil: -} type Interfaces = [Interface] -- Segment ----------------------------------------------------- {- alternatives: alternative Segment: child inh : {[Vertex]} child syn : {[Vertex]} -} data Segment = Segment (([Vertex])) (([Vertex])) -- Segments ---------------------------------------------------- {- alternatives: alternative Cons: child hd : Segment child tl : Segments alternative Nil: -} type Segments = [Segment]uuagc-0.9.42.3/src-generated/InterfacesRules.hs000644 000765 000024 00000175451 12127045231 023240 0ustar00jeroenbransenstaff000000 000000 {-# LANGUAGE Rank2Types, GADTs #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} module InterfacesRules where {-# LINE 2 "./src-ag/Interfaces.ag" #-} import CommonTypes import SequentialTypes {-# LINE 11 "dist/build/InterfacesRules.hs" #-} {-# LINE 10 "./src-ag/InterfacesRules.lag" #-} 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) {-# LINE 29 "dist/build/InterfacesRules.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 53 "./src-ag/InterfacesRules.lag" #-} type VisitSS = [Vertex] {-# LINE 35 "dist/build/InterfacesRules.hs" #-} {-# LINE 88 "./src-ag/InterfacesRules.lag" #-} gather :: Info -> [Vertex] -> [[Vertex]] gather info = eqClasses comp where comp a b = isEqualField (ruleTable info ! a) (ruleTable info ! b) {-# LINE 42 "dist/build/InterfacesRules.hs" #-} {-# LINE 129 "./src-ag/InterfacesRules.lag" #-} -- 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) {-# LINE 53 "dist/build/InterfacesRules.hs" #-} {-# LINE 152 "./src-ag/InterfacesRules.lag" #-} ed :: Vertex -> ([Vertex], [Vertex]) -> [(Vertex, Vertex)] ed v (inh,syn) = map (\i -> (i,v)) inh ++ map (\s -> (v,s)) syn {-# LINE 59 "dist/build/InterfacesRules.hs" #-} {-# LINE 240 "./src-ag/InterfacesRules.lag" #-} 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 {-# LINE 71 "dist/build/InterfacesRules.hs" #-} {-# LINE 323 "./src-ag/InterfacesRules.lag" #-} type IntraVisit = [Vertex] {-# LINE 76 "dist/build/InterfacesRules.hs" #-} {-# LINE 345 "./src-ag/InterfacesRules.lag" #-} swap :: (a,b) -> (b,a) swap (a,b) = (b,a) {-# LINE 82 "dist/build/InterfacesRules.hs" #-} {-# LINE 420 "./src-ag/InterfacesRules.lag" #-} 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 {-# LINE 93 "dist/build/InterfacesRules.hs" #-} -- IRoot ------------------------------------------------------- -- wrapper data Inh_IRoot = Inh_IRoot { dpr_Inh_IRoot :: !([Edge]), info_Inh_IRoot :: !(Info), tdp_Inh_IRoot :: !(Graph) } data Syn_IRoot = Syn_IRoot { edp_Syn_IRoot :: !([Edge]), inters_Syn_IRoot :: !(CInterfaceMap), visits_Syn_IRoot :: !(CVisitsMap) } {-# INLINABLE wrap_IRoot #-} wrap_IRoot :: T_IRoot -> Inh_IRoot -> (Syn_IRoot ) wrap_IRoot !(T_IRoot act) !(Inh_IRoot _lhsIdpr _lhsIinfo _lhsItdp) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_IRoot_vIn1 _lhsIdpr _lhsIinfo _lhsItdp !(T_IRoot_vOut1 _lhsOedp _lhsOinters _lhsOvisits) <- return (inv_IRoot_s2 sem arg) return (Syn_IRoot _lhsOedp _lhsOinters _lhsOvisits) ) -- cata {-# INLINE sem_IRoot #-} sem_IRoot :: IRoot -> T_IRoot sem_IRoot ( IRoot inters_ ) = sem_IRoot_IRoot ( sem_Interfaces inters_ ) -- semantic domain newtype T_IRoot = T_IRoot { attach_T_IRoot :: Identity (T_IRoot_s2 ) } newtype T_IRoot_s2 = C_IRoot_s2 { inv_IRoot_s2 :: (T_IRoot_v1 ) } data T_IRoot_s3 = C_IRoot_s3 type T_IRoot_v1 = (T_IRoot_vIn1 ) -> (T_IRoot_vOut1 ) data T_IRoot_vIn1 = T_IRoot_vIn1 ([Edge]) (Info) (Graph) data T_IRoot_vOut1 = T_IRoot_vOut1 ([Edge]) (CInterfaceMap) (CVisitsMap) {-# NOINLINE sem_IRoot_IRoot #-} sem_IRoot_IRoot :: T_Interfaces -> T_IRoot sem_IRoot_IRoot arg_inters_ = T_IRoot (return st2) where {-# NOINLINE st2 #-} !st2 = let v1 :: T_IRoot_v1 v1 = \ !(T_IRoot_vIn1 _lhsIdpr _lhsIinfo _lhsItdp) -> ( let _intersX8 = Control.Monad.Identity.runIdentity (attach_T_Interfaces (arg_inters_)) (T_Interfaces_vOut7 _intersIdescr _intersIedp _intersIfirstvisitvertices _intersIinters _intersInewedges _intersIv _intersIvisits) = inv_Interfaces_s8 _intersX8 (T_Interfaces_vIn7 _intersOallInters _intersOddp _intersOinfo _intersOprev _intersOv _intersOvisitDescr _intersOvssGraph) _newedges = rule0 _intersInewedges _visitssGraph = rule1 _intersIv _lhsItdp _newedges _intersOv = rule2 _lhsItdp _intersOvisitDescr = rule3 _descr _descr = rule4 _intersIdescr _intersOvssGraph = rule5 _visitssGraph _intersOprev = rule6 _intersIfirstvisitvertices _lhsIinfo _intersOddp = rule7 _intersIv _lhsIdpr _newedges _intersOallInters = rule8 _intersIinters _lhsOedp :: [Edge] _lhsOedp = rule9 _intersIedp _lhsOinters :: CInterfaceMap _lhsOinters = rule10 _intersIinters _lhsOvisits :: CVisitsMap _lhsOvisits = rule11 _intersIvisits _intersOinfo = rule12 _lhsIinfo !__result_ = T_IRoot_vOut1 _lhsOedp _lhsOinters _lhsOvisits in __result_ ) in C_IRoot_s2 v1 {-# INLINE rule0 #-} {-# LINE 66 "./src-ag/InterfacesRules.lag" #-} rule0 = \ ((_intersInewedges) :: Seq Edge ) -> {-# LINE 66 "./src-ag/InterfacesRules.lag" #-} toList _intersInewedges {-# LINE 157 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule1 #-} {-# LINE 67 "./src-ag/InterfacesRules.lag" #-} rule1 = \ ((_intersIv) :: Vertex) ((_lhsItdp) :: Graph) _newedges -> {-# LINE 67 "./src-ag/InterfacesRules.lag" #-} let graph = buildG (0,_intersIv-1) es es = _newedges ++ edges _lhsItdp in transposeG graph {-# LINE 165 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule2 #-} {-# LINE 80 "./src-ag/InterfacesRules.lag" #-} rule2 = \ ((_lhsItdp) :: Graph) -> {-# LINE 80 "./src-ag/InterfacesRules.lag" #-} snd (bounds _lhsItdp) + 1 {-# LINE 171 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule3 #-} {-# LINE 122 "./src-ag/InterfacesRules.lag" #-} rule3 = \ _descr -> {-# LINE 122 "./src-ag/InterfacesRules.lag" #-} Map.fromList _descr {-# LINE 177 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule4 #-} {-# LINE 142 "./src-ag/InterfacesRules.lag" #-} rule4 = \ ((_intersIdescr) :: Seq (Vertex,ChildVisit)) -> {-# LINE 142 "./src-ag/InterfacesRules.lag" #-} toList _intersIdescr {-# LINE 183 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule5 #-} {-# LINE 214 "./src-ag/InterfacesRules.lag" #-} rule5 = \ _visitssGraph -> {-# LINE 214 "./src-ag/InterfacesRules.lag" #-} _visitssGraph {-# LINE 189 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule6 #-} {-# LINE 260 "./src-ag/InterfacesRules.lag" #-} rule6 = \ ((_intersIfirstvisitvertices) :: [Vertex]) ((_lhsIinfo) :: Info) -> {-# LINE 260 "./src-ag/InterfacesRules.lag" #-} let terminals = [ v | (v,cr) <- assocs (ruleTable _lhsIinfo), not (getHasCode cr), isLocal cr ] in _intersIfirstvisitvertices ++ terminals {-# LINE 196 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule7 #-} {-# LINE 343 "./src-ag/InterfacesRules.lag" #-} rule7 = \ ((_intersIv) :: Vertex) ((_lhsIdpr) :: [Edge]) _newedges -> {-# LINE 343 "./src-ag/InterfacesRules.lag" #-} buildG (0,_intersIv-1) (map swap (_lhsIdpr ++ _newedges)) {-# LINE 202 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule8 #-} {-# LINE 381 "./src-ag/InterfacesRules.lag" #-} rule8 = \ ((_intersIinters) :: CInterfaceMap) -> {-# LINE 381 "./src-ag/InterfacesRules.lag" #-} _intersIinters {-# LINE 208 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule9 #-} {-# LINE 443 "./src-ag/InterfacesRules.lag" #-} rule9 = \ ((_intersIedp) :: Seq Edge) -> {-# LINE 443 "./src-ag/InterfacesRules.lag" #-} toList _intersIedp {-# LINE 214 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule10 #-} rule10 = \ ((_intersIinters) :: CInterfaceMap) -> _intersIinters {-# INLINE rule11 #-} rule11 = \ ((_intersIvisits) :: CVisitsMap) -> _intersIvisits {-# INLINE rule12 #-} rule12 = \ ((_lhsIinfo) :: Info) -> _lhsIinfo -- Interface --------------------------------------------------- -- wrapper data Inh_Interface = Inh_Interface { allInters_Inh_Interface :: !(CInterfaceMap), ddp_Inh_Interface :: !(Graph), info_Inh_Interface :: !(Info), prev_Inh_Interface :: !([Vertex]), v_Inh_Interface :: !(Vertex), visitDescr_Inh_Interface :: !(Map Vertex ChildVisit), vssGraph_Inh_Interface :: !(Graph) } data Syn_Interface = Syn_Interface { descr_Syn_Interface :: !(Seq (Vertex,ChildVisit)), edp_Syn_Interface :: !(Seq Edge), firstvisitvertices_Syn_Interface :: !([Vertex]), inter_Syn_Interface :: !(CInterface), newedges_Syn_Interface :: !(Seq Edge ), nt_Syn_Interface :: !(NontermIdent), v_Syn_Interface :: !(Vertex), visits_Syn_Interface :: !(Map ConstructorIdent CVisits) } {-# INLINABLE wrap_Interface #-} wrap_Interface :: T_Interface -> Inh_Interface -> (Syn_Interface ) wrap_Interface !(T_Interface act) !(Inh_Interface _lhsIallInters _lhsIddp _lhsIinfo _lhsIprev _lhsIv _lhsIvisitDescr _lhsIvssGraph) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Interface_vIn4 _lhsIallInters _lhsIddp _lhsIinfo _lhsIprev _lhsIv _lhsIvisitDescr _lhsIvssGraph !(T_Interface_vOut4 _lhsOdescr _lhsOedp _lhsOfirstvisitvertices _lhsOinter _lhsOnewedges _lhsOnt _lhsOv _lhsOvisits) <- return (inv_Interface_s5 sem arg) return (Syn_Interface _lhsOdescr _lhsOedp _lhsOfirstvisitvertices _lhsOinter _lhsOnewedges _lhsOnt _lhsOv _lhsOvisits) ) -- cata {-# INLINE sem_Interface #-} sem_Interface :: Interface -> T_Interface sem_Interface ( Interface !nt_ !cons_ seg_ ) = sem_Interface_Interface nt_ cons_ ( sem_Segments seg_ ) -- semantic domain newtype T_Interface = T_Interface { attach_T_Interface :: Identity (T_Interface_s5 ) } newtype T_Interface_s5 = C_Interface_s5 { inv_Interface_s5 :: (T_Interface_v4 ) } data T_Interface_s6 = C_Interface_s6 type T_Interface_v4 = (T_Interface_vIn4 ) -> (T_Interface_vOut4 ) data T_Interface_vIn4 = T_Interface_vIn4 (CInterfaceMap) (Graph) (Info) ([Vertex]) (Vertex) (Map Vertex ChildVisit) (Graph) data T_Interface_vOut4 = T_Interface_vOut4 (Seq (Vertex,ChildVisit)) (Seq Edge) ([Vertex]) (CInterface) (Seq Edge ) (NontermIdent) (Vertex) (Map ConstructorIdent CVisits) {-# NOINLINE sem_Interface_Interface #-} sem_Interface_Interface :: (NontermIdent) -> ([ConstructorIdent]) -> T_Segments -> T_Interface sem_Interface_Interface !arg_nt_ !arg_cons_ arg_seg_ = T_Interface (return st5) where {-# NOINLINE st5 #-} !st5 = let v4 :: T_Interface_v4 v4 = \ !(T_Interface_vIn4 _lhsIallInters _lhsIddp _lhsIinfo _lhsIprev _lhsIv _lhsIvisitDescr _lhsIvssGraph) -> ( let _segX14 = Control.Monad.Identity.runIdentity (attach_T_Segments (arg_seg_)) (T_Segments_vOut13 _segIcvisits _segIdescr _segIedp _segIfirstInh _segIgroups _segIhdIntravisits _segInewedges _segInewvertices _segIprev _segIsegs _segIv) = inv_Segments_s14 _segX14 (T_Segments_vIn13 _segOallInters _segOcons _segOddp _segOfromLhs _segOinfo _segOisFirst _segOn _segOprev _segOv _segOvisitDescr _segOvssGraph) _segOv = rule13 _lhsIv _v = rule14 _segInewvertices _segIv _lhsOv :: Vertex _lhsOv = rule15 _v _firstvisitvertices = rule16 _segIv _v _newedges = rule17 _firstvisitvertices _segInewvertices _lhsOnewedges :: Seq Edge _lhsOnewedges = rule18 _newedges _segInewedges _look :: Vertex -> CRule _look = rule19 _lhsIinfo _descr = rule20 _firstvisitvertices _look _segIgroups _lhsOdescr :: Seq (Vertex,ChildVisit) _lhsOdescr = rule21 _descr _segIdescr _segOn = rule22 () _segOcons = rule23 arg_cons_ _segOisFirst = rule24 () _segOfromLhs = rule25 _lhsIprev _lhsOnt :: NontermIdent _lhsOnt = rule26 arg_nt_ _lhsOinter :: CInterface _lhsOinter = rule27 _segIsegs _lhsOvisits :: Map ConstructorIdent CVisits _lhsOvisits = rule28 _segIcvisits arg_cons_ _lhsOedp :: Seq Edge _lhsOedp = rule29 _segIedp _lhsOfirstvisitvertices :: [Vertex] _lhsOfirstvisitvertices = rule30 _firstvisitvertices _segOallInters = rule31 _lhsIallInters _segOddp = rule32 _lhsIddp _segOinfo = rule33 _lhsIinfo _segOprev = rule34 _lhsIprev _segOvisitDescr = rule35 _lhsIvisitDescr _segOvssGraph = rule36 _lhsIvssGraph !__result_ = T_Interface_vOut4 _lhsOdescr _lhsOedp _lhsOfirstvisitvertices _lhsOinter _lhsOnewedges _lhsOnt _lhsOv _lhsOvisits in __result_ ) in C_Interface_s5 v4 {-# INLINE rule13 #-} {-# LINE 183 "./src-ag/InterfacesRules.lag" #-} rule13 = \ ((_lhsIv) :: Vertex) -> {-# LINE 183 "./src-ag/InterfacesRules.lag" #-} _lhsIv {-# LINE 305 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule14 #-} {-# LINE 184 "./src-ag/InterfacesRules.lag" #-} rule14 = \ ((_segInewvertices) :: [Vertex]) ((_segIv) :: Vertex) -> {-# LINE 184 "./src-ag/InterfacesRules.lag" #-} _segIv + length _segInewvertices {-# LINE 311 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule15 #-} {-# LINE 185 "./src-ag/InterfacesRules.lag" #-} rule15 = \ _v -> {-# LINE 185 "./src-ag/InterfacesRules.lag" #-} _v {-# LINE 317 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule16 #-} {-# LINE 186 "./src-ag/InterfacesRules.lag" #-} rule16 = \ ((_segIv) :: Vertex) _v -> {-# LINE 186 "./src-ag/InterfacesRules.lag" #-} [_segIv .. _v-1] {-# LINE 323 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule17 #-} {-# LINE 187 "./src-ag/InterfacesRules.lag" #-} rule17 = \ _firstvisitvertices ((_segInewvertices) :: [Vertex]) -> {-# LINE 187 "./src-ag/InterfacesRules.lag" #-} zip _firstvisitvertices _segInewvertices {-# LINE 329 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule18 #-} {-# LINE 188 "./src-ag/InterfacesRules.lag" #-} rule18 = \ _newedges ((_segInewedges) :: Seq Edge ) -> {-# LINE 188 "./src-ag/InterfacesRules.lag" #-} _segInewedges Seq.>< Seq.fromList _newedges {-# LINE 335 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule19 #-} {-# LINE 191 "./src-ag/InterfacesRules.lag" #-} rule19 = \ ((_lhsIinfo) :: Info) -> {-# LINE 191 "./src-ag/InterfacesRules.lag" #-} \a -> ruleTable _lhsIinfo ! a {-# LINE 341 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule20 #-} {-# LINE 192 "./src-ag/InterfacesRules.lag" #-} rule20 = \ _firstvisitvertices ((_look) :: Vertex -> CRule) ((_segIgroups) :: [([Vertex],[Vertex])]) -> {-# LINE 192 "./src-ag/InterfacesRules.lag" #-} zipWith (cv _look (-1)) _firstvisitvertices _segIgroups {-# LINE 347 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule21 #-} {-# LINE 193 "./src-ag/InterfacesRules.lag" #-} rule21 = \ _descr ((_segIdescr) :: Seq (Vertex,ChildVisit)) -> {-# LINE 193 "./src-ag/InterfacesRules.lag" #-} _segIdescr Seq.>< Seq.fromList _descr {-# LINE 353 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule22 #-} {-# LINE 201 "./src-ag/InterfacesRules.lag" #-} rule22 = \ (_ :: ()) -> {-# LINE 201 "./src-ag/InterfacesRules.lag" #-} 0 {-# LINE 359 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule23 #-} {-# LINE 233 "./src-ag/InterfacesRules.lag" #-} rule23 = \ cons_ -> {-# LINE 233 "./src-ag/InterfacesRules.lag" #-} cons_ {-# LINE 365 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule24 #-} {-# LINE 314 "./src-ag/InterfacesRules.lag" #-} rule24 = \ (_ :: ()) -> {-# LINE 314 "./src-ag/InterfacesRules.lag" #-} True {-# LINE 371 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule25 #-} {-# LINE 352 "./src-ag/InterfacesRules.lag" #-} rule25 = \ ((_lhsIprev) :: [Vertex]) -> {-# LINE 352 "./src-ag/InterfacesRules.lag" #-} _lhsIprev {-# LINE 377 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule26 #-} {-# LINE 392 "./src-ag/InterfacesRules.lag" #-} rule26 = \ nt_ -> {-# LINE 392 "./src-ag/InterfacesRules.lag" #-} nt_ {-# LINE 383 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule27 #-} {-# LINE 396 "./src-ag/InterfacesRules.lag" #-} rule27 = \ ((_segIsegs) :: CSegments) -> {-# LINE 396 "./src-ag/InterfacesRules.lag" #-} CInterface _segIsegs {-# LINE 389 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule28 #-} {-# LINE 397 "./src-ag/InterfacesRules.lag" #-} rule28 = \ ((_segIcvisits) :: [[CVisit]]) cons_ -> {-# LINE 397 "./src-ag/InterfacesRules.lag" #-} Map.fromList (zip cons_ (transpose _segIcvisits)) {-# LINE 395 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule29 #-} rule29 = \ ((_segIedp) :: Seq Edge) -> _segIedp {-# INLINE rule30 #-} rule30 = \ _firstvisitvertices -> _firstvisitvertices {-# INLINE rule31 #-} rule31 = \ ((_lhsIallInters) :: CInterfaceMap) -> _lhsIallInters {-# INLINE rule32 #-} rule32 = \ ((_lhsIddp) :: Graph) -> _lhsIddp {-# INLINE rule33 #-} rule33 = \ ((_lhsIinfo) :: Info) -> _lhsIinfo {-# INLINE rule34 #-} rule34 = \ ((_lhsIprev) :: [Vertex]) -> _lhsIprev {-# INLINE rule35 #-} rule35 = \ ((_lhsIvisitDescr) :: Map Vertex ChildVisit) -> _lhsIvisitDescr {-# INLINE rule36 #-} rule36 = \ ((_lhsIvssGraph) :: Graph) -> _lhsIvssGraph -- Interfaces -------------------------------------------------- -- wrapper data Inh_Interfaces = Inh_Interfaces { allInters_Inh_Interfaces :: !(CInterfaceMap), ddp_Inh_Interfaces :: !(Graph), info_Inh_Interfaces :: !(Info), prev_Inh_Interfaces :: !([Vertex]), v_Inh_Interfaces :: !(Vertex), visitDescr_Inh_Interfaces :: !(Map Vertex ChildVisit), vssGraph_Inh_Interfaces :: !(Graph) } data Syn_Interfaces = Syn_Interfaces { descr_Syn_Interfaces :: !(Seq (Vertex,ChildVisit)), edp_Syn_Interfaces :: !(Seq Edge), firstvisitvertices_Syn_Interfaces :: !([Vertex]), inters_Syn_Interfaces :: !(CInterfaceMap), newedges_Syn_Interfaces :: !(Seq Edge ), v_Syn_Interfaces :: !(Vertex), visits_Syn_Interfaces :: !(CVisitsMap) } {-# INLINABLE wrap_Interfaces #-} wrap_Interfaces :: T_Interfaces -> Inh_Interfaces -> (Syn_Interfaces ) wrap_Interfaces !(T_Interfaces act) !(Inh_Interfaces _lhsIallInters _lhsIddp _lhsIinfo _lhsIprev _lhsIv _lhsIvisitDescr _lhsIvssGraph) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Interfaces_vIn7 _lhsIallInters _lhsIddp _lhsIinfo _lhsIprev _lhsIv _lhsIvisitDescr _lhsIvssGraph !(T_Interfaces_vOut7 _lhsOdescr _lhsOedp _lhsOfirstvisitvertices _lhsOinters _lhsOnewedges _lhsOv _lhsOvisits) <- return (inv_Interfaces_s8 sem arg) return (Syn_Interfaces _lhsOdescr _lhsOedp _lhsOfirstvisitvertices _lhsOinters _lhsOnewedges _lhsOv _lhsOvisits) ) -- cata {-# NOINLINE sem_Interfaces #-} sem_Interfaces :: Interfaces -> T_Interfaces sem_Interfaces list = Prelude.foldr sem_Interfaces_Cons sem_Interfaces_Nil (Prelude.map sem_Interface list) -- semantic domain newtype T_Interfaces = T_Interfaces { attach_T_Interfaces :: Identity (T_Interfaces_s8 ) } newtype T_Interfaces_s8 = C_Interfaces_s8 { inv_Interfaces_s8 :: (T_Interfaces_v7 ) } data T_Interfaces_s9 = C_Interfaces_s9 type T_Interfaces_v7 = (T_Interfaces_vIn7 ) -> (T_Interfaces_vOut7 ) data T_Interfaces_vIn7 = T_Interfaces_vIn7 (CInterfaceMap) (Graph) (Info) ([Vertex]) (Vertex) (Map Vertex ChildVisit) (Graph) data T_Interfaces_vOut7 = T_Interfaces_vOut7 (Seq (Vertex,ChildVisit)) (Seq Edge) ([Vertex]) (CInterfaceMap) (Seq Edge ) (Vertex) (CVisitsMap) {-# NOINLINE sem_Interfaces_Cons #-} sem_Interfaces_Cons :: T_Interface -> T_Interfaces -> T_Interfaces sem_Interfaces_Cons arg_hd_ arg_tl_ = T_Interfaces (return st8) where {-# NOINLINE st8 #-} !st8 = let v7 :: T_Interfaces_v7 v7 = \ !(T_Interfaces_vIn7 _lhsIallInters _lhsIddp _lhsIinfo _lhsIprev _lhsIv _lhsIvisitDescr _lhsIvssGraph) -> ( let _hdX5 = Control.Monad.Identity.runIdentity (attach_T_Interface (arg_hd_)) _tlX8 = Control.Monad.Identity.runIdentity (attach_T_Interfaces (arg_tl_)) (T_Interface_vOut4 _hdIdescr _hdIedp _hdIfirstvisitvertices _hdIinter _hdInewedges _hdInt _hdIv _hdIvisits) = inv_Interface_s5 _hdX5 (T_Interface_vIn4 _hdOallInters _hdOddp _hdOinfo _hdOprev _hdOv _hdOvisitDescr _hdOvssGraph) (T_Interfaces_vOut7 _tlIdescr _tlIedp _tlIfirstvisitvertices _tlIinters _tlInewedges _tlIv _tlIvisits) = inv_Interfaces_s8 _tlX8 (T_Interfaces_vIn7 _tlOallInters _tlOddp _tlOinfo _tlOprev _tlOv _tlOvisitDescr _tlOvssGraph) _lhsOinters :: CInterfaceMap _lhsOinters = rule37 _hdIinter _hdInt _tlIinters _lhsOvisits :: CVisitsMap _lhsOvisits = rule38 _hdInt _hdIvisits _tlIvisits _lhsOdescr :: Seq (Vertex,ChildVisit) _lhsOdescr = rule39 _hdIdescr _tlIdescr _lhsOedp :: Seq Edge _lhsOedp = rule40 _hdIedp _tlIedp _lhsOfirstvisitvertices :: [Vertex] _lhsOfirstvisitvertices = rule41 _hdIfirstvisitvertices _tlIfirstvisitvertices _lhsOnewedges :: Seq Edge _lhsOnewedges = rule42 _hdInewedges _tlInewedges _lhsOv :: Vertex _lhsOv = rule43 _tlIv _hdOallInters = rule44 _lhsIallInters _hdOddp = rule45 _lhsIddp _hdOinfo = rule46 _lhsIinfo _hdOprev = rule47 _lhsIprev _hdOv = rule48 _lhsIv _hdOvisitDescr = rule49 _lhsIvisitDescr _hdOvssGraph = rule50 _lhsIvssGraph _tlOallInters = rule51 _lhsIallInters _tlOddp = rule52 _lhsIddp _tlOinfo = rule53 _lhsIinfo _tlOprev = rule54 _lhsIprev _tlOv = rule55 _hdIv _tlOvisitDescr = rule56 _lhsIvisitDescr _tlOvssGraph = rule57 _lhsIvssGraph !__result_ = T_Interfaces_vOut7 _lhsOdescr _lhsOedp _lhsOfirstvisitvertices _lhsOinters _lhsOnewedges _lhsOv _lhsOvisits in __result_ ) in C_Interfaces_s8 v7 {-# INLINE rule37 #-} {-# LINE 386 "./src-ag/InterfacesRules.lag" #-} rule37 = \ ((_hdIinter) :: CInterface) ((_hdInt) :: NontermIdent) ((_tlIinters) :: CInterfaceMap) -> {-# LINE 386 "./src-ag/InterfacesRules.lag" #-} Map.insert _hdInt _hdIinter _tlIinters {-# LINE 498 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule38 #-} {-# LINE 387 "./src-ag/InterfacesRules.lag" #-} rule38 = \ ((_hdInt) :: NontermIdent) ((_hdIvisits) :: Map ConstructorIdent CVisits) ((_tlIvisits) :: CVisitsMap) -> {-# LINE 387 "./src-ag/InterfacesRules.lag" #-} Map.insert _hdInt _hdIvisits _tlIvisits {-# LINE 504 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule39 #-} rule39 = \ ((_hdIdescr) :: Seq (Vertex,ChildVisit)) ((_tlIdescr) :: Seq (Vertex,ChildVisit)) -> _hdIdescr Seq.>< _tlIdescr {-# INLINE rule40 #-} rule40 = \ ((_hdIedp) :: Seq Edge) ((_tlIedp) :: Seq Edge) -> _hdIedp Seq.>< _tlIedp {-# INLINE rule41 #-} rule41 = \ ((_hdIfirstvisitvertices) :: [Vertex]) ((_tlIfirstvisitvertices) :: [Vertex]) -> _hdIfirstvisitvertices ++ _tlIfirstvisitvertices {-# INLINE rule42 #-} rule42 = \ ((_hdInewedges) :: Seq Edge ) ((_tlInewedges) :: Seq Edge ) -> _hdInewedges Seq.>< _tlInewedges {-# INLINE rule43 #-} rule43 = \ ((_tlIv) :: Vertex) -> _tlIv {-# INLINE rule44 #-} rule44 = \ ((_lhsIallInters) :: CInterfaceMap) -> _lhsIallInters {-# INLINE rule45 #-} rule45 = \ ((_lhsIddp) :: Graph) -> _lhsIddp {-# INLINE rule46 #-} rule46 = \ ((_lhsIinfo) :: Info) -> _lhsIinfo {-# INLINE rule47 #-} rule47 = \ ((_lhsIprev) :: [Vertex]) -> _lhsIprev {-# INLINE rule48 #-} rule48 = \ ((_lhsIv) :: Vertex) -> _lhsIv {-# INLINE rule49 #-} rule49 = \ ((_lhsIvisitDescr) :: Map Vertex ChildVisit) -> _lhsIvisitDescr {-# INLINE rule50 #-} rule50 = \ ((_lhsIvssGraph) :: Graph) -> _lhsIvssGraph {-# INLINE rule51 #-} rule51 = \ ((_lhsIallInters) :: CInterfaceMap) -> _lhsIallInters {-# INLINE rule52 #-} rule52 = \ ((_lhsIddp) :: Graph) -> _lhsIddp {-# INLINE rule53 #-} rule53 = \ ((_lhsIinfo) :: Info) -> _lhsIinfo {-# INLINE rule54 #-} rule54 = \ ((_lhsIprev) :: [Vertex]) -> _lhsIprev {-# INLINE rule55 #-} rule55 = \ ((_hdIv) :: Vertex) -> _hdIv {-# INLINE rule56 #-} rule56 = \ ((_lhsIvisitDescr) :: Map Vertex ChildVisit) -> _lhsIvisitDescr {-# INLINE rule57 #-} rule57 = \ ((_lhsIvssGraph) :: Graph) -> _lhsIvssGraph {-# NOINLINE sem_Interfaces_Nil #-} sem_Interfaces_Nil :: T_Interfaces sem_Interfaces_Nil = T_Interfaces (return st8) where {-# NOINLINE st8 #-} !st8 = let v7 :: T_Interfaces_v7 v7 = \ !(T_Interfaces_vIn7 _lhsIallInters _lhsIddp _lhsIinfo _lhsIprev _lhsIv _lhsIvisitDescr _lhsIvssGraph) -> ( let _lhsOinters :: CInterfaceMap _lhsOinters = rule58 () _lhsOvisits :: CVisitsMap _lhsOvisits = rule59 () _lhsOdescr :: Seq (Vertex,ChildVisit) _lhsOdescr = rule60 () _lhsOedp :: Seq Edge _lhsOedp = rule61 () _lhsOfirstvisitvertices :: [Vertex] _lhsOfirstvisitvertices = rule62 () _lhsOnewedges :: Seq Edge _lhsOnewedges = rule63 () _lhsOv :: Vertex _lhsOv = rule64 _lhsIv !__result_ = T_Interfaces_vOut7 _lhsOdescr _lhsOedp _lhsOfirstvisitvertices _lhsOinters _lhsOnewedges _lhsOv _lhsOvisits in __result_ ) in C_Interfaces_s8 v7 {-# INLINE rule58 #-} {-# LINE 388 "./src-ag/InterfacesRules.lag" #-} rule58 = \ (_ :: ()) -> {-# LINE 388 "./src-ag/InterfacesRules.lag" #-} Map.empty {-# LINE 591 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule59 #-} {-# LINE 389 "./src-ag/InterfacesRules.lag" #-} rule59 = \ (_ :: ()) -> {-# LINE 389 "./src-ag/InterfacesRules.lag" #-} Map.empty {-# LINE 597 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule60 #-} rule60 = \ (_ :: ()) -> Seq.empty {-# INLINE rule61 #-} rule61 = \ (_ :: ()) -> Seq.empty {-# INLINE rule62 #-} rule62 = \ (_ :: ()) -> [] {-# INLINE rule63 #-} rule63 = \ (_ :: ()) -> Seq.empty {-# INLINE rule64 #-} rule64 = \ ((_lhsIv) :: Vertex) -> _lhsIv -- Segment ----------------------------------------------------- -- wrapper data Inh_Segment = Inh_Segment { allInters_Inh_Segment :: !(CInterfaceMap), cons_Inh_Segment :: !([ConstructorIdent]), ddp_Inh_Segment :: !(Graph), fromLhs_Inh_Segment :: !([Vertex]), info_Inh_Segment :: !(Info), isFirst_Inh_Segment :: !(Bool), n_Inh_Segment :: !(Int), nextInh_Inh_Segment :: !([Vertex]), nextIntravisits_Inh_Segment :: !([IntraVisit]), nextNewvertices_Inh_Segment :: !([Vertex]), prev_Inh_Segment :: !([Vertex]), v_Inh_Segment :: !(Vertex), visitDescr_Inh_Segment :: !(Map Vertex ChildVisit), vssGraph_Inh_Segment :: !(Graph) } data Syn_Segment = Syn_Segment { cvisits_Syn_Segment :: !([CVisit]), descr_Syn_Segment :: !(Seq (Vertex,ChildVisit)), edp_Syn_Segment :: !(Seq Edge), groups_Syn_Segment :: !([([Vertex],[Vertex])]), inh_Syn_Segment :: !([Vertex]), intravisits_Syn_Segment :: !([IntraVisit]), newedges_Syn_Segment :: !(Seq Edge ), newvertices_Syn_Segment :: !([Vertex]), prev_Syn_Segment :: !([Vertex]), seg_Syn_Segment :: !(CSegment), v_Syn_Segment :: !(Vertex), visitss_Syn_Segment :: !([VisitSS]) } {-# INLINABLE wrap_Segment #-} wrap_Segment :: T_Segment -> Inh_Segment -> (Syn_Segment ) wrap_Segment !(T_Segment act) !(Inh_Segment _lhsIallInters _lhsIcons _lhsIddp _lhsIfromLhs _lhsIinfo _lhsIisFirst _lhsIn _lhsInextInh _lhsInextIntravisits _lhsInextNewvertices _lhsIprev _lhsIv _lhsIvisitDescr _lhsIvssGraph) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Segment_vIn10 _lhsIallInters _lhsIcons _lhsIddp _lhsIfromLhs _lhsIinfo _lhsIisFirst _lhsIn _lhsInextInh _lhsInextIntravisits _lhsInextNewvertices _lhsIprev _lhsIv _lhsIvisitDescr _lhsIvssGraph !(T_Segment_vOut10 _lhsOcvisits _lhsOdescr _lhsOedp _lhsOgroups _lhsOinh _lhsOintravisits _lhsOnewedges _lhsOnewvertices _lhsOprev _lhsOseg _lhsOv _lhsOvisitss) <- return (inv_Segment_s11 sem arg) return (Syn_Segment _lhsOcvisits _lhsOdescr _lhsOedp _lhsOgroups _lhsOinh _lhsOintravisits _lhsOnewedges _lhsOnewvertices _lhsOprev _lhsOseg _lhsOv _lhsOvisitss) ) -- cata {-# INLINE sem_Segment #-} sem_Segment :: Segment -> T_Segment sem_Segment ( Segment !inh_ !syn_ ) = sem_Segment_Segment inh_ syn_ -- semantic domain newtype T_Segment = T_Segment { attach_T_Segment :: Identity (T_Segment_s11 ) } newtype T_Segment_s11 = C_Segment_s11 { inv_Segment_s11 :: (T_Segment_v10 ) } data T_Segment_s12 = C_Segment_s12 type T_Segment_v10 = (T_Segment_vIn10 ) -> (T_Segment_vOut10 ) data T_Segment_vIn10 = T_Segment_vIn10 (CInterfaceMap) ([ConstructorIdent]) (Graph) ([Vertex]) (Info) (Bool) (Int) ([Vertex]) ([IntraVisit]) ([Vertex]) ([Vertex]) (Vertex) (Map Vertex ChildVisit) (Graph) data T_Segment_vOut10 = T_Segment_vOut10 ([CVisit]) (Seq (Vertex,ChildVisit)) (Seq Edge) ([([Vertex],[Vertex])]) ([Vertex]) ([IntraVisit]) (Seq Edge ) ([Vertex]) ([Vertex]) (CSegment) (Vertex) ([VisitSS]) {-# NOINLINE sem_Segment_Segment #-} sem_Segment_Segment :: ([Vertex]) -> ([Vertex]) -> T_Segment sem_Segment_Segment !arg_inh_ !arg_syn_ = T_Segment (return st11) where {-# NOINLINE st11 #-} !st11 = let v10 :: T_Segment_v10 v10 = \ !(T_Segment_vIn10 _lhsIallInters _lhsIcons _lhsIddp _lhsIfromLhs _lhsIinfo _lhsIisFirst _lhsIn _lhsInextInh _lhsInextIntravisits _lhsInextNewvertices _lhsIprev _lhsIv _lhsIvisitDescr _lhsIvssGraph) -> ( let _look :: Vertex -> CRule _look = rule65 _lhsIinfo _occurAs :: (CRule -> Bool) -> [Vertex] -> [Vertex] _occurAs = rule66 _lhsIinfo _look _groups :: [([Vertex],[Vertex])] _groups = rule67 _lhsIinfo _look _occurAs arg_inh_ arg_syn_ _v :: Int _v = rule68 _groups _lhsIv _newvertices = rule69 _lhsIv _v _lhsOdescr :: Seq (Vertex,ChildVisit) _lhsOdescr = rule70 _groups _lhsIn _look _newvertices _attredges = rule71 _groups _newvertices _visitedges = rule72 _lhsInextNewvertices _newvertices _lhsOnewedges :: Seq Edge _lhsOnewedges = rule73 _attredges _visitedges _synOccur = rule74 _lhsIinfo _occurAs arg_syn_ _vss = rule75 _lhsIcons _lhsIinfo _lhsIvssGraph _synOccur arg_syn_ _visitss' = rule76 _lhsIprev _vss _defined = rule77 _lhsIvisitDescr _visitss _lhsOprev :: [Vertex] _lhsOprev = rule78 _defined _lhsIprev _visitss :: [[Vertex]] _visitss = rule79 _lhsIinfo _visitss' _fromLhs = rule80 _lhsIfromLhs _occurAs arg_inh_ _computed = rule81 _lhsIinfo _lhsIvisitDescr _visitss _intravisits = rule82 _iv _lhsInextIntravisits _visitss _iv = rule83 _computed _fromLhs _lhsIddp _lhsOseg :: CSegment _lhsOseg = rule84 _inhmap _lhsIprev _lhsIvisitDescr _lhsIvssGraph _synmap _inhmap :: Map Identifier Type _synmap :: Map Identifier Type (_inhmap,_synmap) = rule85 _lhsIinfo arg_inh_ arg_syn_ _lhsOcvisits :: [CVisit] _lhsOcvisits = rule86 _inhmap _intravisits _lhsIallInters _lhsIinfo _lhsIvisitDescr _synmap _visitss _lhsOedp :: Seq Edge _lhsOedp = rule87 _lhsInextInh arg_inh_ arg_syn_ _lhsOinh :: [Vertex] _lhsOinh = rule88 arg_inh_ _lhsOgroups :: [([Vertex],[Vertex])] _lhsOgroups = rule89 _groups _lhsOintravisits :: [IntraVisit] _lhsOintravisits = rule90 _intravisits _lhsOnewvertices :: [Vertex] _lhsOnewvertices = rule91 _newvertices _lhsOv :: Vertex _lhsOv = rule92 _v _lhsOvisitss :: [VisitSS] _lhsOvisitss = rule93 _visitss !__result_ = T_Segment_vOut10 _lhsOcvisits _lhsOdescr _lhsOedp _lhsOgroups _lhsOinh _lhsOintravisits _lhsOnewedges _lhsOnewvertices _lhsOprev _lhsOseg _lhsOv _lhsOvisitss in __result_ ) in C_Segment_s11 v10 {-# INLINE rule65 #-} {-# LINE 101 "./src-ag/InterfacesRules.lag" #-} rule65 = \ ((_lhsIinfo) :: Info) -> {-# LINE 101 "./src-ag/InterfacesRules.lag" #-} \a -> ruleTable _lhsIinfo ! a {-# LINE 707 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule66 #-} {-# LINE 104 "./src-ag/InterfacesRules.lag" #-} rule66 = \ ((_lhsIinfo) :: Info) ((_look) :: Vertex -> CRule) -> {-# LINE 104 "./src-ag/InterfacesRules.lag" #-} \p us -> [ a | u <- us , a <- tdsToTdp _lhsIinfo ! u , p (_look a)] {-# LINE 715 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule67 #-} {-# LINE 108 "./src-ag/InterfacesRules.lag" #-} rule67 = \ ((_lhsIinfo) :: Info) ((_look) :: Vertex -> CRule) ((_occurAs) :: (CRule -> Bool) -> [Vertex] -> [Vertex]) inh_ syn_ -> {-# LINE 108 "./src-ag/InterfacesRules.lag" #-} let group as = gather _lhsIinfo (_occurAs isRhs as) in map (partition (isInh . _look)) (group (inh_ ++ syn_)) {-# LINE 722 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule68 #-} {-# LINE 111 "./src-ag/InterfacesRules.lag" #-} rule68 = \ ((_groups) :: [([Vertex],[Vertex])]) ((_lhsIv) :: Vertex) -> {-# LINE 111 "./src-ag/InterfacesRules.lag" #-} _lhsIv + length _groups {-# LINE 728 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule69 #-} {-# LINE 112 "./src-ag/InterfacesRules.lag" #-} rule69 = \ ((_lhsIv) :: Vertex) ((_v) :: Int) -> {-# LINE 112 "./src-ag/InterfacesRules.lag" #-} [_lhsIv .. _v -1] {-# LINE 734 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule70 #-} {-# LINE 127 "./src-ag/InterfacesRules.lag" #-} rule70 = \ ((_groups) :: [([Vertex],[Vertex])]) ((_lhsIn) :: Int) ((_look) :: Vertex -> CRule) _newvertices -> {-# LINE 127 "./src-ag/InterfacesRules.lag" #-} Seq.fromList $ zipWith (cv _look _lhsIn) _newvertices _groups {-# LINE 740 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule71 #-} {-# LINE 150 "./src-ag/InterfacesRules.lag" #-} rule71 = \ ((_groups) :: [([Vertex],[Vertex])]) _newvertices -> {-# LINE 150 "./src-ag/InterfacesRules.lag" #-} concat (zipWith ed _newvertices _groups) {-# LINE 746 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule72 #-} {-# LINE 170 "./src-ag/InterfacesRules.lag" #-} rule72 = \ ((_lhsInextNewvertices) :: [Vertex]) _newvertices -> {-# LINE 170 "./src-ag/InterfacesRules.lag" #-} zip _newvertices _lhsInextNewvertices {-# LINE 752 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule73 #-} {-# LINE 171 "./src-ag/InterfacesRules.lag" #-} rule73 = \ _attredges _visitedges -> {-# LINE 171 "./src-ag/InterfacesRules.lag" #-} Seq.fromList _attredges Seq.>< Seq.fromList _visitedges {-# LINE 758 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule74 #-} {-# LINE 225 "./src-ag/InterfacesRules.lag" #-} rule74 = \ ((_lhsIinfo) :: Info) ((_occurAs) :: (CRule -> Bool) -> [Vertex] -> [Vertex]) syn_ -> {-# LINE 225 "./src-ag/InterfacesRules.lag" #-} gather _lhsIinfo (_occurAs isLhs syn_) {-# LINE 764 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule75 #-} {-# LINE 226 "./src-ag/InterfacesRules.lag" #-} rule75 = \ ((_lhsIcons) :: [ConstructorIdent]) ((_lhsIinfo) :: Info) ((_lhsIvssGraph) :: Graph) _synOccur syn_ -> {-# LINE 226 "./src-ag/InterfacesRules.lag" #-} let hasCode' v | inRange (bounds (ruleTable _lhsIinfo)) v = getHasCode (ruleTable _lhsIinfo ! v) | otherwise = True in if null syn_ then replicate (length _lhsIcons) [] else map (filter hasCode' . topSort' _lhsIvssGraph) _synOccur {-# LINE 774 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule76 #-} {-# LINE 270 "./src-ag/InterfacesRules.lag" #-} rule76 = \ ((_lhsIprev) :: [Vertex]) _vss -> {-# LINE 270 "./src-ag/InterfacesRules.lag" #-} map (\\ _lhsIprev) _vss {-# LINE 780 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule77 #-} {-# LINE 271 "./src-ag/InterfacesRules.lag" #-} rule77 = \ ((_lhsIvisitDescr) :: Map Vertex ChildVisit) ((_visitss) :: [[Vertex]]) -> {-# LINE 271 "./src-ag/InterfacesRules.lag" #-} let defines v = case Map.lookup v _lhsIvisitDescr of Nothing -> [v] Just (ChildVisit _ _ _ inh _) -> v:inh in concatMap (concatMap defines) _visitss {-# LINE 789 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule78 #-} {-# LINE 275 "./src-ag/InterfacesRules.lag" #-} rule78 = \ _defined ((_lhsIprev) :: [Vertex]) -> {-# LINE 275 "./src-ag/InterfacesRules.lag" #-} _lhsIprev ++ _defined {-# LINE 795 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule79 #-} {-# LINE 284 "./src-ag/InterfacesRules.lag" #-} rule79 = \ ((_lhsIinfo) :: Info) _visitss' -> {-# LINE 284 "./src-ag/InterfacesRules.lag" #-} 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 _lhsIinfo in map (rem' []) _visitss' {-# LINE 816 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule80 #-} {-# LINE 357 "./src-ag/InterfacesRules.lag" #-} rule80 = \ ((_lhsIfromLhs) :: [Vertex]) ((_occurAs) :: (CRule -> Bool) -> [Vertex] -> [Vertex]) inh_ -> {-# LINE 357 "./src-ag/InterfacesRules.lag" #-} _occurAs isLhs inh_ ++ _lhsIfromLhs {-# LINE 822 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule81 #-} {-# LINE 358 "./src-ag/InterfacesRules.lag" #-} rule81 = \ ((_lhsIinfo) :: Info) ((_lhsIvisitDescr) :: Map Vertex ChildVisit) ((_visitss) :: [[Vertex]]) -> {-# LINE 358 "./src-ag/InterfacesRules.lag" #-} let computes v = case Map.lookup v _lhsIvisitDescr of Nothing -> Map.keys (getDefines (ruleTable _lhsIinfo ! v)) Just (ChildVisit _ _ _ _ syn) -> v:syn in concatMap (concatMap computes) _visitss {-# LINE 831 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule82 #-} {-# LINE 362 "./src-ag/InterfacesRules.lag" #-} rule82 = \ _iv ((_lhsInextIntravisits) :: [IntraVisit]) ((_visitss) :: [[Vertex]]) -> {-# LINE 362 "./src-ag/InterfacesRules.lag" #-} zipWith _iv _visitss _lhsInextIntravisits {-# LINE 837 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule83 #-} {-# LINE 363 "./src-ag/InterfacesRules.lag" #-} rule83 = \ _computed _fromLhs ((_lhsIddp) :: Graph) -> {-# LINE 363 "./src-ag/InterfacesRules.lag" #-} \vs next -> let needed = concatMap (_lhsIddp !) vs in nub (needed ++ next) \\ (_fromLhs ++ _computed) {-# LINE 845 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule84 #-} {-# LINE 406 "./src-ag/InterfacesRules.lag" #-} rule84 = \ ((_inhmap) :: Map Identifier Type) ((_lhsIprev) :: [Vertex]) ((_lhsIvisitDescr) :: Map Vertex ChildVisit) ((_lhsIvssGraph) :: Graph) ((_synmap) :: Map Identifier Type) -> {-# LINE 406 "./src-ag/InterfacesRules.lag" #-} if False then undefined _lhsIvssGraph _lhsIvisitDescr _lhsIprev else CSegment _inhmap _synmap {-# LINE 851 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule85 #-} {-# LINE 410 "./src-ag/InterfacesRules.lag" #-} rule85 = \ ((_lhsIinfo) :: Info) inh_ syn_ -> {-# LINE 410 "./src-ag/InterfacesRules.lag" #-} let makemap = Map.fromList . map findType findType v = getNtaNameType (attrTable _lhsIinfo ! v) in (makemap inh_,makemap syn_) {-# LINE 859 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule86 #-} {-# LINE 413 "./src-ag/InterfacesRules.lag" #-} rule86 = \ ((_inhmap) :: Map Identifier Type) _intravisits ((_lhsIallInters) :: CInterfaceMap) ((_lhsIinfo) :: Info) ((_lhsIvisitDescr) :: Map Vertex ChildVisit) ((_synmap) :: Map Identifier Type) ((_visitss) :: [[Vertex]]) -> {-# LINE 413 "./src-ag/InterfacesRules.lag" #-} let mkVisit vss intra = CVisit _inhmap _synmap (mkSequence vss) (mkSequence intra) True mkSequence = map mkRule mkRule v = case Map.lookup v _lhsIvisitDescr of Nothing -> ruleTable _lhsIinfo ! v Just (ChildVisit name nt n _ _) -> ccv name nt n _lhsIallInters in zipWith mkVisit _visitss _intravisits {-# LINE 870 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule87 #-} {-# LINE 440 "./src-ag/InterfacesRules.lag" #-} rule87 = \ ((_lhsInextInh) :: [Vertex]) inh_ syn_ -> {-# LINE 440 "./src-ag/InterfacesRules.lag" #-} Seq.fromList [(i,s) | i <- inh_, s <- syn_] Seq.>< Seq.fromList [(s,i) | s <- syn_, i <- _lhsInextInh ] {-# LINE 877 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule88 #-} {-# LINE 445 "./src-ag/InterfacesRules.lag" #-} rule88 = \ inh_ -> {-# LINE 445 "./src-ag/InterfacesRules.lag" #-} inh_ {-# LINE 883 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule89 #-} rule89 = \ ((_groups) :: [([Vertex],[Vertex])]) -> _groups {-# INLINE rule90 #-} rule90 = \ _intravisits -> _intravisits {-# INLINE rule91 #-} rule91 = \ _newvertices -> _newvertices {-# INLINE rule92 #-} rule92 = \ ((_v) :: Int) -> _v {-# INLINE rule93 #-} rule93 = \ ((_visitss) :: [[Vertex]]) -> _visitss -- Segments ---------------------------------------------------- -- wrapper data Inh_Segments = Inh_Segments { allInters_Inh_Segments :: !(CInterfaceMap), cons_Inh_Segments :: !([ConstructorIdent]), ddp_Inh_Segments :: !(Graph), fromLhs_Inh_Segments :: !([Vertex]), info_Inh_Segments :: !(Info), isFirst_Inh_Segments :: !(Bool), n_Inh_Segments :: !(Int), prev_Inh_Segments :: !([Vertex]), v_Inh_Segments :: !(Vertex), visitDescr_Inh_Segments :: !(Map Vertex ChildVisit), vssGraph_Inh_Segments :: !(Graph) } data Syn_Segments = Syn_Segments { cvisits_Syn_Segments :: !([[CVisit]]), descr_Syn_Segments :: !(Seq (Vertex,ChildVisit)), edp_Syn_Segments :: !(Seq Edge), firstInh_Syn_Segments :: !([Vertex]), groups_Syn_Segments :: !([([Vertex],[Vertex])]), hdIntravisits_Syn_Segments :: !([IntraVisit]), newedges_Syn_Segments :: !(Seq Edge ), newvertices_Syn_Segments :: !([Vertex]), prev_Syn_Segments :: !([Vertex]), segs_Syn_Segments :: !(CSegments), v_Syn_Segments :: !(Vertex) } {-# INLINABLE wrap_Segments #-} wrap_Segments :: T_Segments -> Inh_Segments -> (Syn_Segments ) wrap_Segments !(T_Segments act) !(Inh_Segments _lhsIallInters _lhsIcons _lhsIddp _lhsIfromLhs _lhsIinfo _lhsIisFirst _lhsIn _lhsIprev _lhsIv _lhsIvisitDescr _lhsIvssGraph) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Segments_vIn13 _lhsIallInters _lhsIcons _lhsIddp _lhsIfromLhs _lhsIinfo _lhsIisFirst _lhsIn _lhsIprev _lhsIv _lhsIvisitDescr _lhsIvssGraph !(T_Segments_vOut13 _lhsOcvisits _lhsOdescr _lhsOedp _lhsOfirstInh _lhsOgroups _lhsOhdIntravisits _lhsOnewedges _lhsOnewvertices _lhsOprev _lhsOsegs _lhsOv) <- return (inv_Segments_s14 sem arg) return (Syn_Segments _lhsOcvisits _lhsOdescr _lhsOedp _lhsOfirstInh _lhsOgroups _lhsOhdIntravisits _lhsOnewedges _lhsOnewvertices _lhsOprev _lhsOsegs _lhsOv) ) -- cata {-# NOINLINE sem_Segments #-} sem_Segments :: Segments -> T_Segments sem_Segments list = Prelude.foldr sem_Segments_Cons sem_Segments_Nil (Prelude.map sem_Segment list) -- semantic domain newtype T_Segments = T_Segments { attach_T_Segments :: Identity (T_Segments_s14 ) } newtype T_Segments_s14 = C_Segments_s14 { inv_Segments_s14 :: (T_Segments_v13 ) } data T_Segments_s15 = C_Segments_s15 type T_Segments_v13 = (T_Segments_vIn13 ) -> (T_Segments_vOut13 ) data T_Segments_vIn13 = T_Segments_vIn13 (CInterfaceMap) ([ConstructorIdent]) (Graph) ([Vertex]) (Info) (Bool) (Int) ([Vertex]) (Vertex) (Map Vertex ChildVisit) (Graph) data T_Segments_vOut13 = T_Segments_vOut13 ([[CVisit]]) (Seq (Vertex,ChildVisit)) (Seq Edge) ([Vertex]) ([([Vertex],[Vertex])]) ([IntraVisit]) (Seq Edge ) ([Vertex]) ([Vertex]) (CSegments) (Vertex) {-# NOINLINE sem_Segments_Cons #-} sem_Segments_Cons :: T_Segment -> T_Segments -> T_Segments sem_Segments_Cons arg_hd_ arg_tl_ = T_Segments (return st14) where {-# NOINLINE st14 #-} !st14 = let v13 :: T_Segments_v13 v13 = \ !(T_Segments_vIn13 _lhsIallInters _lhsIcons _lhsIddp _lhsIfromLhs _lhsIinfo _lhsIisFirst _lhsIn _lhsIprev _lhsIv _lhsIvisitDescr _lhsIvssGraph) -> ( let _hdX11 = Control.Monad.Identity.runIdentity (attach_T_Segment (arg_hd_)) _tlX14 = Control.Monad.Identity.runIdentity (attach_T_Segments (arg_tl_)) (T_Segment_vOut10 _hdIcvisits _hdIdescr _hdIedp _hdIgroups _hdIinh _hdIintravisits _hdInewedges _hdInewvertices _hdIprev _hdIseg _hdIv _hdIvisitss) = inv_Segment_s11 _hdX11 (T_Segment_vIn10 _hdOallInters _hdOcons _hdOddp _hdOfromLhs _hdOinfo _hdOisFirst _hdOn _hdOnextInh _hdOnextIntravisits _hdOnextNewvertices _hdOprev _hdOv _hdOvisitDescr _hdOvssGraph) (T_Segments_vOut13 _tlIcvisits _tlIdescr _tlIedp _tlIfirstInh _tlIgroups _tlIhdIntravisits _tlInewedges _tlInewvertices _tlIprev _tlIsegs _tlIv) = inv_Segments_s14 _tlX14 (T_Segments_vIn13 _tlOallInters _tlOcons _tlOddp _tlOfromLhs _tlOinfo _tlOisFirst _tlOn _tlOprev _tlOv _tlOvisitDescr _tlOvssGraph) _hdOnextNewvertices = rule94 _tlInewvertices _lhsOnewvertices :: [Vertex] _lhsOnewvertices = rule95 _hdInewvertices _lhsOgroups :: [([Vertex],[Vertex])] _lhsOgroups = rule96 _hdIgroups _tlOn = rule97 _lhsIn _tlOisFirst = rule98 () _hdOnextIntravisits = rule99 _tlIhdIntravisits _lhsOhdIntravisits :: [IntraVisit] _lhsOhdIntravisits = rule100 _hdIintravisits _hdOfromLhs = rule101 _lhsIfromLhs _tlOfromLhs = rule102 () _lhsOsegs :: CSegments _lhsOsegs = rule103 _hdIseg _tlIsegs _hdOnextInh = rule104 _tlIfirstInh _lhsOfirstInh :: [Vertex] _lhsOfirstInh = rule105 _hdIinh _lhsOcvisits :: [[CVisit]] _lhsOcvisits = rule106 _hdIcvisits _tlIcvisits _lhsOdescr :: Seq (Vertex,ChildVisit) _lhsOdescr = rule107 _hdIdescr _tlIdescr _lhsOedp :: Seq Edge _lhsOedp = rule108 _hdIedp _tlIedp _lhsOnewedges :: Seq Edge _lhsOnewedges = rule109 _hdInewedges _tlInewedges _lhsOprev :: [Vertex] _lhsOprev = rule110 _tlIprev _lhsOv :: Vertex _lhsOv = rule111 _tlIv _hdOallInters = rule112 _lhsIallInters _hdOcons = rule113 _lhsIcons _hdOddp = rule114 _lhsIddp _hdOinfo = rule115 _lhsIinfo _hdOisFirst = rule116 _lhsIisFirst _hdOn = rule117 _lhsIn _hdOprev = rule118 _lhsIprev _hdOv = rule119 _lhsIv _hdOvisitDescr = rule120 _lhsIvisitDescr _hdOvssGraph = rule121 _lhsIvssGraph _tlOallInters = rule122 _lhsIallInters _tlOcons = rule123 _lhsIcons _tlOddp = rule124 _lhsIddp _tlOinfo = rule125 _lhsIinfo _tlOprev = rule126 _hdIprev _tlOv = rule127 _hdIv _tlOvisitDescr = rule128 _lhsIvisitDescr _tlOvssGraph = rule129 _lhsIvssGraph !__result_ = T_Segments_vOut13 _lhsOcvisits _lhsOdescr _lhsOedp _lhsOfirstInh _lhsOgroups _lhsOhdIntravisits _lhsOnewedges _lhsOnewvertices _lhsOprev _lhsOsegs _lhsOv in __result_ ) in C_Segments_s14 v13 {-# INLINE rule94 #-} {-# LINE 165 "./src-ag/InterfacesRules.lag" #-} rule94 = \ ((_tlInewvertices) :: [Vertex]) -> {-# LINE 165 "./src-ag/InterfacesRules.lag" #-} _tlInewvertices {-# LINE 996 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule95 #-} {-# LINE 166 "./src-ag/InterfacesRules.lag" #-} rule95 = \ ((_hdInewvertices) :: [Vertex]) -> {-# LINE 166 "./src-ag/InterfacesRules.lag" #-} _hdInewvertices {-# LINE 1002 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule96 #-} {-# LINE 180 "./src-ag/InterfacesRules.lag" #-} rule96 = \ ((_hdIgroups) :: [([Vertex],[Vertex])]) -> {-# LINE 180 "./src-ag/InterfacesRules.lag" #-} _hdIgroups {-# LINE 1008 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule97 #-} {-# LINE 203 "./src-ag/InterfacesRules.lag" #-} rule97 = \ ((_lhsIn) :: Int) -> {-# LINE 203 "./src-ag/InterfacesRules.lag" #-} _lhsIn + 1 {-# LINE 1014 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule98 #-} {-# LINE 316 "./src-ag/InterfacesRules.lag" #-} rule98 = \ (_ :: ()) -> {-# LINE 316 "./src-ag/InterfacesRules.lag" #-} False {-# LINE 1020 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule99 #-} {-# LINE 329 "./src-ag/InterfacesRules.lag" #-} rule99 = \ ((_tlIhdIntravisits) :: [IntraVisit]) -> {-# LINE 329 "./src-ag/InterfacesRules.lag" #-} _tlIhdIntravisits {-# LINE 1026 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule100 #-} {-# LINE 330 "./src-ag/InterfacesRules.lag" #-} rule100 = \ ((_hdIintravisits) :: [IntraVisit]) -> {-# LINE 330 "./src-ag/InterfacesRules.lag" #-} _hdIintravisits {-# LINE 1032 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule101 #-} {-# LINE 354 "./src-ag/InterfacesRules.lag" #-} rule101 = \ ((_lhsIfromLhs) :: [Vertex]) -> {-# LINE 354 "./src-ag/InterfacesRules.lag" #-} _lhsIfromLhs {-# LINE 1038 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule102 #-} {-# LINE 355 "./src-ag/InterfacesRules.lag" #-} rule102 = \ (_ :: ()) -> {-# LINE 355 "./src-ag/InterfacesRules.lag" #-} [] {-# LINE 1044 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule103 #-} {-# LINE 401 "./src-ag/InterfacesRules.lag" #-} rule103 = \ ((_hdIseg) :: CSegment) ((_tlIsegs) :: CSegments) -> {-# LINE 401 "./src-ag/InterfacesRules.lag" #-} _hdIseg : _tlIsegs {-# LINE 1050 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule104 #-} {-# LINE 447 "./src-ag/InterfacesRules.lag" #-} rule104 = \ ((_tlIfirstInh) :: [Vertex]) -> {-# LINE 447 "./src-ag/InterfacesRules.lag" #-} _tlIfirstInh {-# LINE 1056 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule105 #-} {-# LINE 448 "./src-ag/InterfacesRules.lag" #-} rule105 = \ ((_hdIinh) :: [Vertex]) -> {-# LINE 448 "./src-ag/InterfacesRules.lag" #-} _hdIinh {-# LINE 1062 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule106 #-} rule106 = \ ((_hdIcvisits) :: [CVisit]) ((_tlIcvisits) :: [[CVisit]]) -> _hdIcvisits : _tlIcvisits {-# INLINE rule107 #-} rule107 = \ ((_hdIdescr) :: Seq (Vertex,ChildVisit)) ((_tlIdescr) :: Seq (Vertex,ChildVisit)) -> _hdIdescr Seq.>< _tlIdescr {-# INLINE rule108 #-} rule108 = \ ((_hdIedp) :: Seq Edge) ((_tlIedp) :: Seq Edge) -> _hdIedp Seq.>< _tlIedp {-# INLINE rule109 #-} rule109 = \ ((_hdInewedges) :: Seq Edge ) ((_tlInewedges) :: Seq Edge ) -> _hdInewedges Seq.>< _tlInewedges {-# INLINE rule110 #-} rule110 = \ ((_tlIprev) :: [Vertex]) -> _tlIprev {-# INLINE rule111 #-} rule111 = \ ((_tlIv) :: Vertex) -> _tlIv {-# INLINE rule112 #-} rule112 = \ ((_lhsIallInters) :: CInterfaceMap) -> _lhsIallInters {-# INLINE rule113 #-} rule113 = \ ((_lhsIcons) :: [ConstructorIdent]) -> _lhsIcons {-# INLINE rule114 #-} rule114 = \ ((_lhsIddp) :: Graph) -> _lhsIddp {-# INLINE rule115 #-} rule115 = \ ((_lhsIinfo) :: Info) -> _lhsIinfo {-# INLINE rule116 #-} rule116 = \ ((_lhsIisFirst) :: Bool) -> _lhsIisFirst {-# INLINE rule117 #-} rule117 = \ ((_lhsIn) :: Int) -> _lhsIn {-# INLINE rule118 #-} rule118 = \ ((_lhsIprev) :: [Vertex]) -> _lhsIprev {-# INLINE rule119 #-} rule119 = \ ((_lhsIv) :: Vertex) -> _lhsIv {-# INLINE rule120 #-} rule120 = \ ((_lhsIvisitDescr) :: Map Vertex ChildVisit) -> _lhsIvisitDescr {-# INLINE rule121 #-} rule121 = \ ((_lhsIvssGraph) :: Graph) -> _lhsIvssGraph {-# INLINE rule122 #-} rule122 = \ ((_lhsIallInters) :: CInterfaceMap) -> _lhsIallInters {-# INLINE rule123 #-} rule123 = \ ((_lhsIcons) :: [ConstructorIdent]) -> _lhsIcons {-# INLINE rule124 #-} rule124 = \ ((_lhsIddp) :: Graph) -> _lhsIddp {-# INLINE rule125 #-} rule125 = \ ((_lhsIinfo) :: Info) -> _lhsIinfo {-# INLINE rule126 #-} rule126 = \ ((_hdIprev) :: [Vertex]) -> _hdIprev {-# INLINE rule127 #-} rule127 = \ ((_hdIv) :: Vertex) -> _hdIv {-# INLINE rule128 #-} rule128 = \ ((_lhsIvisitDescr) :: Map Vertex ChildVisit) -> _lhsIvisitDescr {-# INLINE rule129 #-} rule129 = \ ((_lhsIvssGraph) :: Graph) -> _lhsIvssGraph {-# NOINLINE sem_Segments_Nil #-} sem_Segments_Nil :: T_Segments sem_Segments_Nil = T_Segments (return st14) where {-# NOINLINE st14 #-} !st14 = let v13 :: T_Segments_v13 v13 = \ !(T_Segments_vIn13 _lhsIallInters _lhsIcons _lhsIddp _lhsIfromLhs _lhsIinfo _lhsIisFirst _lhsIn _lhsIprev _lhsIv _lhsIvisitDescr _lhsIvssGraph) -> ( let _lhsOnewvertices :: [Vertex] _lhsOnewvertices = rule130 () _lhsOgroups :: [([Vertex],[Vertex])] _lhsOgroups = rule131 () _lhsOhdIntravisits :: [IntraVisit] _lhsOhdIntravisits = rule132 () _lhsOsegs :: CSegments _lhsOsegs = rule133 () _lhsOfirstInh :: [Vertex] _lhsOfirstInh = rule134 () _lhsOcvisits :: [[CVisit]] _lhsOcvisits = rule135 () _lhsOdescr :: Seq (Vertex,ChildVisit) _lhsOdescr = rule136 () _lhsOedp :: Seq Edge _lhsOedp = rule137 () _lhsOnewedges :: Seq Edge _lhsOnewedges = rule138 () _lhsOprev :: [Vertex] _lhsOprev = rule139 _lhsIprev _lhsOv :: Vertex _lhsOv = rule140 _lhsIv !__result_ = T_Segments_vOut13 _lhsOcvisits _lhsOdescr _lhsOedp _lhsOfirstInh _lhsOgroups _lhsOhdIntravisits _lhsOnewedges _lhsOnewvertices _lhsOprev _lhsOsegs _lhsOv in __result_ ) in C_Segments_s14 v13 {-# INLINE rule130 #-} {-# LINE 167 "./src-ag/InterfacesRules.lag" #-} rule130 = \ (_ :: ()) -> {-# LINE 167 "./src-ag/InterfacesRules.lag" #-} [] {-# LINE 1172 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule131 #-} {-# LINE 181 "./src-ag/InterfacesRules.lag" #-} rule131 = \ (_ :: ()) -> {-# LINE 181 "./src-ag/InterfacesRules.lag" #-} [] {-# LINE 1178 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule132 #-} {-# LINE 331 "./src-ag/InterfacesRules.lag" #-} rule132 = \ (_ :: ()) -> {-# LINE 331 "./src-ag/InterfacesRules.lag" #-} repeat [] {-# LINE 1184 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule133 #-} {-# LINE 402 "./src-ag/InterfacesRules.lag" #-} rule133 = \ (_ :: ()) -> {-# LINE 402 "./src-ag/InterfacesRules.lag" #-} [] {-# LINE 1190 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule134 #-} {-# LINE 449 "./src-ag/InterfacesRules.lag" #-} rule134 = \ (_ :: ()) -> {-# LINE 449 "./src-ag/InterfacesRules.lag" #-} [] {-# LINE 1196 "dist/build/InterfacesRules.hs"#-} {-# INLINE rule135 #-} rule135 = \ (_ :: ()) -> [] {-# INLINE rule136 #-} rule136 = \ (_ :: ()) -> Seq.empty {-# INLINE rule137 #-} rule137 = \ (_ :: ()) -> Seq.empty {-# INLINE rule138 #-} rule138 = \ (_ :: ()) -> Seq.empty {-# INLINE rule139 #-} rule139 = \ ((_lhsIprev) :: [Vertex]) -> _lhsIprev {-# INLINE rule140 #-} rule140 = \ ((_lhsIv) :: Vertex) -> _lhsIv uuagc-0.9.42.3/src-generated/KWOrder.hs000644 000765 000024 00000353723 12127045231 021457 0ustar00jeroenbransenstaff000000 000000 {-# LANGUAGE Rank2Types, GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} module KWOrder where {-# LINE 2 "./src-ag/AbstractSyntax.ag" #-} -- 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 {-# LINE 16 "dist/build/KWOrder.hs" #-} {-# LINE 2 "./src-ag/HsToken.ag" #-} import CommonTypes import UU.Scanner.Position(Pos) {-# LINE 22 "dist/build/KWOrder.hs" #-} {-# LINE 2 "./src-ag/Expression.ag" #-} import UU.Scanner.Position(Pos) import HsToken {-# LINE 28 "dist/build/KWOrder.hs" #-} {-# LINE 2 "./src-ag/Patterns.ag" #-} -- Patterns.ag imports import UU.Scanner.Position(Pos) import CommonTypes (ConstructorIdent,Identifier) {-# LINE 35 "dist/build/KWOrder.hs" #-} {-# LINE 8 "./src-ag/KWOrder.ag" #-} 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) {-# LINE 58 "dist/build/KWOrder.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 275 "./src-ag/KWOrder.ag" #-} -- 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 {-# LINE 78 "dist/build/KWOrder.hs" #-} -- Child ------------------------------------------------------- -- wrapper data Inh_Child = Inh_Child { aroundMap_Inh_Child :: (Map Identifier [Expression]), inhMap_Inh_Child :: (Map Identifier Attributes), mergeMap_Inh_Child :: (Map Identifier (Identifier, [Identifier], Expression)), mergedChildren_Inh_Child :: (Set Identifier), options_Inh_Child :: (Options), synMap_Inh_Child :: (Map Identifier Attributes) } data Syn_Child = Syn_Child { echilds_Syn_Child :: (EChild), edges_Syn_Child :: (Set.Set Edge), nontnames_Syn_Child :: ([(Identifier, Identifier)]), refHoNts_Syn_Child :: (Set NontermIdent), refNts_Syn_Child :: (Set NontermIdent), vertices_Syn_Child :: (Set.Set Vertex) } {-# INLINABLE wrap_Child #-} wrap_Child :: T_Child -> Inh_Child -> (Syn_Child ) wrap_Child (T_Child act) (Inh_Child _lhsIaroundMap _lhsIinhMap _lhsImergeMap _lhsImergedChildren _lhsIoptions _lhsIsynMap) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Child_vIn1 _lhsIaroundMap _lhsIinhMap _lhsImergeMap _lhsImergedChildren _lhsIoptions _lhsIsynMap (T_Child_vOut1 _lhsOechilds _lhsOedges _lhsOnontnames _lhsOrefHoNts _lhsOrefNts _lhsOvertices) <- return (inv_Child_s2 sem arg) return (Syn_Child _lhsOechilds _lhsOedges _lhsOnontnames _lhsOrefHoNts _lhsOrefNts _lhsOvertices) ) -- cata {-# INLINE sem_Child #-} sem_Child :: Child -> T_Child sem_Child ( Child name_ tp_ kind_ ) = sem_Child_Child name_ tp_ kind_ -- semantic domain newtype T_Child = T_Child { attach_T_Child :: Identity (T_Child_s2 ) } newtype T_Child_s2 = C_Child_s2 { inv_Child_s2 :: (T_Child_v1 ) } data T_Child_s3 = C_Child_s3 type T_Child_v1 = (T_Child_vIn1 ) -> (T_Child_vOut1 ) data T_Child_vIn1 = T_Child_vIn1 (Map Identifier [Expression]) (Map Identifier Attributes) (Map Identifier (Identifier, [Identifier], Expression)) (Set Identifier) (Options) (Map Identifier Attributes) data T_Child_vOut1 = T_Child_vOut1 (EChild) (Set.Set Edge) ([(Identifier, Identifier)]) (Set NontermIdent) (Set NontermIdent) (Set.Set Vertex) {-# NOINLINE sem_Child_Child #-} sem_Child_Child :: (Identifier) -> (Type) -> (ChildKind) -> T_Child sem_Child_Child arg_name_ arg_tp_ arg_kind_ = T_Child (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Child_v1 v1 = \ (T_Child_vIn1 _lhsIaroundMap _lhsIinhMap _lhsImergeMap _lhsImergedChildren _lhsIoptions _lhsIsynMap) -> ( let _chnt = rule0 arg_name_ arg_tp_ _inh = rule1 _chnt _lhsIinhMap _syn = rule2 _chnt _lhsIsynMap _refNts = rule3 arg_tp_ _refHoNts = rule4 _isHigherOrder _refNts _isHigherOrder = rule5 arg_kind_ _hasArounds = rule6 _lhsIaroundMap arg_name_ _merges = rule7 _lhsImergeMap arg_name_ _isMerged = rule8 _lhsImergedChildren arg_name_ _lhsOechilds :: EChild _lhsOechilds = rule9 _hasArounds _isMerged _merges arg_kind_ arg_name_ arg_tp_ _vertex = rule10 arg_name_ _synvertices = rule11 _syn arg_name_ _inhvertices = rule12 _inh arg_name_ _lhsOvertices :: Set.Set Vertex _lhsOvertices = rule13 _inhvertices _synvertices _vertex arg_tp_ _childIsDeforested = rule14 arg_tp_ _higherOrderEdges = rule15 _childIsDeforested _lhsIoptions _vertex arg_kind_ _aroundEdges = rule16 _hasArounds _vertex arg_name_ _edgesout = rule17 _higherOrderEdges _edgesin = rule18 _synvertices _vertex _lhsOedges :: Set.Set Edge _lhsOedges = rule19 _edgesin _edgesout _lhsOnontnames :: [(Identifier, Identifier)] _lhsOnontnames = rule20 arg_name_ arg_tp_ _lhsOrefHoNts :: Set NontermIdent _lhsOrefHoNts = rule21 _refHoNts _lhsOrefNts :: Set NontermIdent _lhsOrefNts = rule22 _refNts __result_ = T_Child_vOut1 _lhsOechilds _lhsOedges _lhsOnontnames _lhsOrefHoNts _lhsOrefNts _lhsOvertices in __result_ ) in C_Child_s2 v1 {-# INLINE rule0 #-} {-# LINE 19 "./src-ag/DistChildAttr.ag" #-} rule0 = \ name_ tp_ -> {-# LINE 19 "./src-ag/DistChildAttr.ag" #-} case tp_ of NT nt _ _ -> nt Self -> error ("The type of child " ++ show name_ ++ " should not be a Self type.") Haskell t -> identifier "" {-# LINE 156 "dist/build/KWOrder.hs"#-} {-# INLINE rule1 #-} {-# LINE 23 "./src-ag/DistChildAttr.ag" #-} rule1 = \ _chnt ((_lhsIinhMap) :: Map Identifier Attributes) -> {-# LINE 23 "./src-ag/DistChildAttr.ag" #-} Map.findWithDefault Map.empty _chnt _lhsIinhMap {-# LINE 162 "dist/build/KWOrder.hs"#-} {-# INLINE rule2 #-} {-# LINE 24 "./src-ag/DistChildAttr.ag" #-} rule2 = \ _chnt ((_lhsIsynMap) :: Map Identifier Attributes) -> {-# LINE 24 "./src-ag/DistChildAttr.ag" #-} Map.findWithDefault Map.empty _chnt _lhsIsynMap {-# LINE 168 "dist/build/KWOrder.hs"#-} {-# INLINE rule3 #-} {-# LINE 74 "./src-ag/KWOrder.ag" #-} rule3 = \ tp_ -> {-# LINE 74 "./src-ag/KWOrder.ag" #-} case tp_ of NT nt _ _ -> Set.singleton nt _ -> mempty {-# LINE 176 "dist/build/KWOrder.hs"#-} {-# INLINE rule4 #-} {-# LINE 77 "./src-ag/KWOrder.ag" #-} rule4 = \ _isHigherOrder _refNts -> {-# LINE 77 "./src-ag/KWOrder.ag" #-} if _isHigherOrder then _refNts else mempty {-# LINE 182 "dist/build/KWOrder.hs"#-} {-# INLINE rule5 #-} {-# LINE 78 "./src-ag/KWOrder.ag" #-} rule5 = \ kind_ -> {-# LINE 78 "./src-ag/KWOrder.ag" #-} case kind_ of ChildSyntax -> False _ -> True {-# LINE 190 "dist/build/KWOrder.hs"#-} {-# INLINE rule6 #-} {-# LINE 108 "./src-ag/KWOrder.ag" #-} rule6 = \ ((_lhsIaroundMap) :: Map Identifier [Expression]) name_ -> {-# LINE 108 "./src-ag/KWOrder.ag" #-} case Map.lookup name_ _lhsIaroundMap of Nothing -> False Just as -> not (null as) {-# LINE 198 "dist/build/KWOrder.hs"#-} {-# INLINE rule7 #-} {-# LINE 136 "./src-ag/KWOrder.ag" #-} rule7 = \ ((_lhsImergeMap) :: Map Identifier (Identifier, [Identifier], Expression)) name_ -> {-# LINE 136 "./src-ag/KWOrder.ag" #-} maybe Nothing (\(_,ms,_) -> Just ms) $ Map.lookup name_ _lhsImergeMap {-# LINE 204 "dist/build/KWOrder.hs"#-} {-# INLINE rule8 #-} {-# LINE 137 "./src-ag/KWOrder.ag" #-} rule8 = \ ((_lhsImergedChildren) :: Set Identifier) name_ -> {-# LINE 137 "./src-ag/KWOrder.ag" #-} name_ `Set.member` _lhsImergedChildren {-# LINE 210 "dist/build/KWOrder.hs"#-} {-# INLINE rule9 #-} {-# LINE 178 "./src-ag/KWOrder.ag" #-} rule9 = \ _hasArounds _isMerged _merges kind_ name_ tp_ -> {-# LINE 178 "./src-ag/KWOrder.ag" #-} case tp_ of NT _ _ _ -> EChild name_ tp_ kind_ _hasArounds _merges _isMerged _ -> ETerm name_ tp_ {-# LINE 218 "dist/build/KWOrder.hs"#-} {-# INLINE rule10 #-} {-# LINE 215 "./src-ag/KWOrder.ag" #-} rule10 = \ name_ -> {-# LINE 215 "./src-ag/KWOrder.ag" #-} VChild name_ {-# LINE 224 "dist/build/KWOrder.hs"#-} {-# INLINE rule11 #-} {-# LINE 216 "./src-ag/KWOrder.ag" #-} rule11 = \ _syn name_ -> {-# LINE 216 "./src-ag/KWOrder.ag" #-} map (VAttr Syn name_) . Map.keys $ _syn {-# LINE 230 "dist/build/KWOrder.hs"#-} {-# INLINE rule12 #-} {-# LINE 217 "./src-ag/KWOrder.ag" #-} rule12 = \ _inh name_ -> {-# LINE 217 "./src-ag/KWOrder.ag" #-} map (VAttr Inh name_) . Map.keys $ _inh {-# LINE 236 "dist/build/KWOrder.hs"#-} {-# INLINE rule13 #-} {-# LINE 218 "./src-ag/KWOrder.ag" #-} rule13 = \ _inhvertices _synvertices _vertex tp_ -> {-# LINE 218 "./src-ag/KWOrder.ag" #-} case tp_ of NT _ _ _ -> Set.insert _vertex $ Set.fromList (_synvertices ++ _inhvertices ) _ -> Set.empty {-# LINE 244 "dist/build/KWOrder.hs"#-} {-# INLINE rule14 #-} {-# LINE 248 "./src-ag/KWOrder.ag" #-} rule14 = \ tp_ -> {-# LINE 248 "./src-ag/KWOrder.ag" #-} case tp_ of NT _ _ defor -> defor _ -> False {-# LINE 252 "dist/build/KWOrder.hs"#-} {-# INLINE rule15 #-} {-# LINE 251 "./src-ag/KWOrder.ag" #-} rule15 = \ _childIsDeforested ((_lhsIoptions) :: Options) _vertex kind_ -> {-# LINE 251 "./src-ag/KWOrder.ag" #-} case kind_ of ChildAttr | lateHigherOrderBinding _lhsIoptions && not _childIsDeforested -> [(_vertex , VAttr Inh _LHS idLateBindingAttr)] _ -> [] {-# LINE 261 "dist/build/KWOrder.hs"#-} {-# INLINE rule16 #-} {-# LINE 255 "./src-ag/KWOrder.ag" #-} rule16 = \ _hasArounds _vertex name_ -> {-# LINE 255 "./src-ag/KWOrder.ag" #-} if _hasArounds then [(_vertex , VAttr Syn _LOC (Ident (getName name_ ++ "_around") (getPos name_)))] else [] {-# LINE 269 "dist/build/KWOrder.hs"#-} {-# INLINE rule17 #-} {-# LINE 261 "./src-ag/KWOrder.ag" #-} rule17 = \ _higherOrderEdges -> {-# LINE 261 "./src-ag/KWOrder.ag" #-} _higherOrderEdges {-# LINE 275 "dist/build/KWOrder.hs"#-} {-# INLINE rule18 #-} {-# LINE 262 "./src-ag/KWOrder.ag" #-} rule18 = \ _synvertices _vertex -> {-# LINE 262 "./src-ag/KWOrder.ag" #-} map (flip (,) _vertex ) _synvertices {-# LINE 281 "dist/build/KWOrder.hs"#-} {-# INLINE rule19 #-} {-# LINE 263 "./src-ag/KWOrder.ag" #-} rule19 = \ _edgesin _edgesout -> {-# LINE 263 "./src-ag/KWOrder.ag" #-} Set.fromList (_edgesout ++ _edgesin ) {-# LINE 287 "dist/build/KWOrder.hs"#-} {-# INLINE rule20 #-} {-# LINE 301 "./src-ag/KWOrder.ag" #-} rule20 = \ name_ tp_ -> {-# LINE 301 "./src-ag/KWOrder.ag" #-} case tp_ of NT nont _ _ -> [(name_, nont)] _ -> [] {-# LINE 295 "dist/build/KWOrder.hs"#-} {-# INLINE rule21 #-} rule21 = \ _refHoNts -> _refHoNts {-# INLINE rule22 #-} rule22 = \ _refNts -> _refNts -- Children ---------------------------------------------------- -- wrapper data Inh_Children = Inh_Children { aroundMap_Inh_Children :: (Map Identifier [Expression]), inhMap_Inh_Children :: (Map Identifier Attributes), mergeMap_Inh_Children :: (Map Identifier (Identifier, [Identifier], Expression)), mergedChildren_Inh_Children :: (Set Identifier), options_Inh_Children :: (Options), synMap_Inh_Children :: (Map Identifier Attributes) } data Syn_Children = Syn_Children { echilds_Syn_Children :: (EChildren), edges_Syn_Children :: (Set.Set Edge), nontnames_Syn_Children :: ([(Identifier, Identifier)]), refHoNts_Syn_Children :: (Set NontermIdent), refNts_Syn_Children :: (Set NontermIdent), vertices_Syn_Children :: (Set.Set Vertex) } {-# INLINABLE wrap_Children #-} wrap_Children :: T_Children -> Inh_Children -> (Syn_Children ) wrap_Children (T_Children act) (Inh_Children _lhsIaroundMap _lhsIinhMap _lhsImergeMap _lhsImergedChildren _lhsIoptions _lhsIsynMap) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Children_vIn4 _lhsIaroundMap _lhsIinhMap _lhsImergeMap _lhsImergedChildren _lhsIoptions _lhsIsynMap (T_Children_vOut4 _lhsOechilds _lhsOedges _lhsOnontnames _lhsOrefHoNts _lhsOrefNts _lhsOvertices) <- return (inv_Children_s5 sem arg) return (Syn_Children _lhsOechilds _lhsOedges _lhsOnontnames _lhsOrefHoNts _lhsOrefNts _lhsOvertices) ) -- cata {-# NOINLINE sem_Children #-} sem_Children :: Children -> T_Children sem_Children list = Prelude.foldr sem_Children_Cons sem_Children_Nil (Prelude.map sem_Child list) -- semantic domain newtype T_Children = T_Children { attach_T_Children :: Identity (T_Children_s5 ) } newtype T_Children_s5 = C_Children_s5 { inv_Children_s5 :: (T_Children_v4 ) } data T_Children_s6 = C_Children_s6 type T_Children_v4 = (T_Children_vIn4 ) -> (T_Children_vOut4 ) data T_Children_vIn4 = T_Children_vIn4 (Map Identifier [Expression]) (Map Identifier Attributes) (Map Identifier (Identifier, [Identifier], Expression)) (Set Identifier) (Options) (Map Identifier Attributes) data T_Children_vOut4 = T_Children_vOut4 (EChildren) (Set.Set Edge) ([(Identifier, Identifier)]) (Set NontermIdent) (Set NontermIdent) (Set.Set Vertex) {-# NOINLINE sem_Children_Cons #-} sem_Children_Cons :: T_Child -> T_Children -> T_Children sem_Children_Cons arg_hd_ arg_tl_ = T_Children (return st5) where {-# NOINLINE st5 #-} st5 = let v4 :: T_Children_v4 v4 = \ (T_Children_vIn4 _lhsIaroundMap _lhsIinhMap _lhsImergeMap _lhsImergedChildren _lhsIoptions _lhsIsynMap) -> ( let _hdX2 = Control.Monad.Identity.runIdentity (attach_T_Child (arg_hd_)) _tlX5 = Control.Monad.Identity.runIdentity (attach_T_Children (arg_tl_)) (T_Child_vOut1 _hdIechilds _hdIedges _hdInontnames _hdIrefHoNts _hdIrefNts _hdIvertices) = inv_Child_s2 _hdX2 (T_Child_vIn1 _hdOaroundMap _hdOinhMap _hdOmergeMap _hdOmergedChildren _hdOoptions _hdOsynMap) (T_Children_vOut4 _tlIechilds _tlIedges _tlInontnames _tlIrefHoNts _tlIrefNts _tlIvertices) = inv_Children_s5 _tlX5 (T_Children_vIn4 _tlOaroundMap _tlOinhMap _tlOmergeMap _tlOmergedChildren _tlOoptions _tlOsynMap) _lhsOechilds :: EChildren _lhsOechilds = rule23 _hdIechilds _tlIechilds _lhsOedges :: Set.Set Edge _lhsOedges = rule24 _hdIedges _tlIedges _lhsOnontnames :: [(Identifier, Identifier)] _lhsOnontnames = rule25 _hdInontnames _tlInontnames _lhsOrefHoNts :: Set NontermIdent _lhsOrefHoNts = rule26 _hdIrefHoNts _tlIrefHoNts _lhsOrefNts :: Set NontermIdent _lhsOrefNts = rule27 _hdIrefNts _tlIrefNts _lhsOvertices :: Set.Set Vertex _lhsOvertices = rule28 _hdIvertices _tlIvertices _hdOaroundMap = rule29 _lhsIaroundMap _hdOinhMap = rule30 _lhsIinhMap _hdOmergeMap = rule31 _lhsImergeMap _hdOmergedChildren = rule32 _lhsImergedChildren _hdOoptions = rule33 _lhsIoptions _hdOsynMap = rule34 _lhsIsynMap _tlOaroundMap = rule35 _lhsIaroundMap _tlOinhMap = rule36 _lhsIinhMap _tlOmergeMap = rule37 _lhsImergeMap _tlOmergedChildren = rule38 _lhsImergedChildren _tlOoptions = rule39 _lhsIoptions _tlOsynMap = rule40 _lhsIsynMap __result_ = T_Children_vOut4 _lhsOechilds _lhsOedges _lhsOnontnames _lhsOrefHoNts _lhsOrefNts _lhsOvertices in __result_ ) in C_Children_s5 v4 {-# INLINE rule23 #-} rule23 = \ ((_hdIechilds) :: EChild) ((_tlIechilds) :: EChildren) -> _hdIechilds : _tlIechilds {-# INLINE rule24 #-} rule24 = \ ((_hdIedges) :: Set.Set Edge) ((_tlIedges) :: Set.Set Edge) -> _hdIedges `Set.union` _tlIedges {-# INLINE rule25 #-} rule25 = \ ((_hdInontnames) :: [(Identifier, Identifier)]) ((_tlInontnames) :: [(Identifier, Identifier)]) -> _hdInontnames ++ _tlInontnames {-# INLINE rule26 #-} rule26 = \ ((_hdIrefHoNts) :: Set NontermIdent) ((_tlIrefHoNts) :: Set NontermIdent) -> _hdIrefHoNts `mappend` _tlIrefHoNts {-# INLINE rule27 #-} rule27 = \ ((_hdIrefNts) :: Set NontermIdent) ((_tlIrefNts) :: Set NontermIdent) -> _hdIrefNts `mappend` _tlIrefNts {-# INLINE rule28 #-} rule28 = \ ((_hdIvertices) :: Set.Set Vertex) ((_tlIvertices) :: Set.Set Vertex) -> _hdIvertices `Set.union` _tlIvertices {-# INLINE rule29 #-} rule29 = \ ((_lhsIaroundMap) :: Map Identifier [Expression]) -> _lhsIaroundMap {-# INLINE rule30 #-} rule30 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule31 #-} rule31 = \ ((_lhsImergeMap) :: Map Identifier (Identifier, [Identifier], Expression)) -> _lhsImergeMap {-# INLINE rule32 #-} rule32 = \ ((_lhsImergedChildren) :: Set Identifier) -> _lhsImergedChildren {-# INLINE rule33 #-} rule33 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule34 #-} rule34 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# INLINE rule35 #-} rule35 = \ ((_lhsIaroundMap) :: Map Identifier [Expression]) -> _lhsIaroundMap {-# INLINE rule36 #-} rule36 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule37 #-} rule37 = \ ((_lhsImergeMap) :: Map Identifier (Identifier, [Identifier], Expression)) -> _lhsImergeMap {-# INLINE rule38 #-} rule38 = \ ((_lhsImergedChildren) :: Set Identifier) -> _lhsImergedChildren {-# INLINE rule39 #-} rule39 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule40 #-} rule40 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# NOINLINE sem_Children_Nil #-} sem_Children_Nil :: T_Children sem_Children_Nil = T_Children (return st5) where {-# NOINLINE st5 #-} st5 = let v4 :: T_Children_v4 v4 = \ (T_Children_vIn4 _lhsIaroundMap _lhsIinhMap _lhsImergeMap _lhsImergedChildren _lhsIoptions _lhsIsynMap) -> ( let _lhsOechilds :: EChildren _lhsOechilds = rule41 () _lhsOedges :: Set.Set Edge _lhsOedges = rule42 () _lhsOnontnames :: [(Identifier, Identifier)] _lhsOnontnames = rule43 () _lhsOrefHoNts :: Set NontermIdent _lhsOrefHoNts = rule44 () _lhsOrefNts :: Set NontermIdent _lhsOrefNts = rule45 () _lhsOvertices :: Set.Set Vertex _lhsOvertices = rule46 () __result_ = T_Children_vOut4 _lhsOechilds _lhsOedges _lhsOnontnames _lhsOrefHoNts _lhsOrefNts _lhsOvertices in __result_ ) in C_Children_s5 v4 {-# INLINE rule41 #-} rule41 = \ (_ :: ()) -> [] {-# INLINE rule42 #-} rule42 = \ (_ :: ()) -> Set.empty {-# INLINE rule43 #-} rule43 = \ (_ :: ()) -> [] {-# INLINE rule44 #-} rule44 = \ (_ :: ()) -> mempty {-# INLINE rule45 #-} rule45 = \ (_ :: ()) -> mempty {-# INLINE rule46 #-} rule46 = \ (_ :: ()) -> Set.empty -- Expression -------------------------------------------------- -- wrapper data Inh_Expression = Inh_Expression { } data Syn_Expression = Syn_Expression { copy_Syn_Expression :: (Expression), vertices_Syn_Expression :: (Set.Set Vertex) } {-# INLINABLE wrap_Expression #-} wrap_Expression :: T_Expression -> Inh_Expression -> (Syn_Expression ) wrap_Expression (T_Expression act) (Inh_Expression ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Expression_vIn7 (T_Expression_vOut7 _lhsOcopy _lhsOvertices) <- return (inv_Expression_s8 sem arg) return (Syn_Expression _lhsOcopy _lhsOvertices) ) -- cata {-# INLINE sem_Expression #-} sem_Expression :: Expression -> T_Expression sem_Expression ( Expression pos_ tks_ ) = sem_Expression_Expression pos_ tks_ -- semantic domain newtype T_Expression = T_Expression { attach_T_Expression :: Identity (T_Expression_s8 ) } newtype T_Expression_s8 = C_Expression_s8 { inv_Expression_s8 :: (T_Expression_v7 ) } data T_Expression_s9 = C_Expression_s9 type T_Expression_v7 = (T_Expression_vIn7 ) -> (T_Expression_vOut7 ) data T_Expression_vIn7 = T_Expression_vIn7 data T_Expression_vOut7 = T_Expression_vOut7 (Expression) (Set.Set Vertex) {-# NOINLINE sem_Expression_Expression #-} sem_Expression_Expression :: (Pos) -> ([HsToken]) -> T_Expression sem_Expression_Expression arg_pos_ arg_tks_ = T_Expression (return st8) where {-# NOINLINE st8 #-} st8 = let v7 :: T_Expression_v7 v7 = \ (T_Expression_vIn7 ) -> ( let _lhsOvertices :: Set.Set Vertex _lhsOvertices = rule47 arg_tks_ _copy = rule48 arg_pos_ arg_tks_ _lhsOcopy :: Expression _lhsOcopy = rule49 _copy __result_ = T_Expression_vOut7 _lhsOcopy _lhsOvertices in __result_ ) in C_Expression_s8 v7 {-# INLINE rule47 #-} {-# LINE 200 "./src-ag/KWOrder.ag" #-} rule47 = \ tks_ -> {-# LINE 200 "./src-ag/KWOrder.ag" #-} Set.unions $ map (\tok -> vertices_Syn_HsToken (wrap_HsToken (sem_HsToken tok) Inh_HsToken)) tks_ {-# LINE 517 "dist/build/KWOrder.hs"#-} {-# INLINE rule48 #-} rule48 = \ pos_ tks_ -> Expression pos_ tks_ {-# INLINE rule49 #-} rule49 = \ _copy -> _copy -- Grammar ----------------------------------------------------- -- wrapper data Inh_Grammar = Inh_Grammar { options_Inh_Grammar :: (Options) } data Syn_Grammar = Syn_Grammar { depgraphs_Syn_Grammar :: (PP_Doc), errors_Syn_Grammar :: (Seq Error), inhmap_Syn_Grammar :: (Map.Map NontermIdent Attributes), localSigMap_Syn_Grammar :: (Map.Map NontermIdent (Map.Map ConstructorIdent (Map.Map Identifier Type))), output_Syn_Grammar :: (ExecutionPlan), synmap_Syn_Grammar :: (Map.Map NontermIdent Attributes), visitgraph_Syn_Grammar :: (PP_Doc) } {-# INLINABLE wrap_Grammar #-} wrap_Grammar :: T_Grammar -> Inh_Grammar -> (Syn_Grammar ) wrap_Grammar (T_Grammar act) (Inh_Grammar _lhsIoptions) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Grammar_vIn10 _lhsIoptions (T_Grammar_vOut10 _lhsOdepgraphs _lhsOerrors _lhsOinhmap _lhsOlocalSigMap _lhsOoutput _lhsOsynmap _lhsOvisitgraph) <- return (inv_Grammar_s11 sem arg) return (Syn_Grammar _lhsOdepgraphs _lhsOerrors _lhsOinhmap _lhsOlocalSigMap _lhsOoutput _lhsOsynmap _lhsOvisitgraph) ) -- cata {-# INLINE sem_Grammar #-} sem_Grammar :: Grammar -> T_Grammar sem_Grammar ( Grammar typeSyns_ useMap_ derivings_ wrappers_ nonts_ pragmas_ manualAttrOrderMap_ paramMap_ contextMap_ quantMap_ uniqueMap_ augmentsMap_ aroundsMap_ mergeMap_ ) = sem_Grammar_Grammar typeSyns_ useMap_ derivings_ wrappers_ ( sem_Nonterminals nonts_ ) pragmas_ manualAttrOrderMap_ paramMap_ contextMap_ quantMap_ uniqueMap_ augmentsMap_ aroundsMap_ mergeMap_ -- semantic domain newtype T_Grammar = T_Grammar { attach_T_Grammar :: Identity (T_Grammar_s11 ) } newtype T_Grammar_s11 = C_Grammar_s11 { inv_Grammar_s11 :: (T_Grammar_v10 ) } data T_Grammar_s12 = C_Grammar_s12 type T_Grammar_v10 = (T_Grammar_vIn10 ) -> (T_Grammar_vOut10 ) data T_Grammar_vIn10 = T_Grammar_vIn10 (Options) data T_Grammar_vOut10 = T_Grammar_vOut10 (PP_Doc) (Seq Error) (Map.Map NontermIdent Attributes) (Map.Map NontermIdent (Map.Map ConstructorIdent (Map.Map Identifier Type))) (ExecutionPlan) (Map.Map NontermIdent Attributes) (PP_Doc) {-# NOINLINE sem_Grammar_Grammar #-} sem_Grammar_Grammar :: (TypeSyns) -> (UseMap) -> (Derivings) -> (Set NontermIdent) -> T_Nonterminals -> (PragmaMap) -> (AttrOrderMap) -> (ParamMap) -> (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)))) -> T_Grammar sem_Grammar_Grammar arg_typeSyns_ _ arg_derivings_ arg_wrappers_ arg_nonts_ _ arg_manualAttrOrderMap_ _ arg_contextMap_ _ _ _ arg_aroundsMap_ arg_mergeMap_ = T_Grammar (return st11) where {-# NOINLINE st11 #-} st11 = let v10 :: T_Grammar_v10 v10 = \ (T_Grammar_vIn10 _lhsIoptions) -> ( let _nontsX26 = Control.Monad.Identity.runIdentity (attach_T_Nonterminals (arg_nonts_)) (T_Nonterminals_vOut25 _nontsIdepinfo _nontsIinhMap' _nontsIinhmap _nontsIlocalSigMap _nontsIntDeps _nontsIntHoDeps _nontsIrulenumber _nontsIsynMap' _nontsIsynmap) = inv_Nonterminals_s26 _nontsX26 (T_Nonterminals_vIn25 _nontsOaroundMap _nontsOclassContexts _nontsOclosedHoNtDeps _nontsOclosedHoNtRevDeps _nontsOclosedNtDeps _nontsOinhMap _nontsOmanualDeps _nontsOmergeMap _nontsOoptions _nontsOrulenumber _nontsOsynMap) _nontsOinhMap = rule50 _nontsIinhMap' _nontsOsynMap = rule51 _nontsIsynMap' _nontsOrulenumber = rule52 () _closedNtDeps = rule53 _nontsIntDeps _closedHoNtDeps = rule54 _nontsIntHoDeps _closedHoNtRevDeps = rule55 _closedHoNtDeps _nontsOaroundMap = rule56 arg_aroundsMap_ _nontsOmergeMap = rule57 arg_mergeMap_ _nontsOclassContexts = rule58 arg_contextMap_ _nontsOmanualDeps = rule59 arg_manualAttrOrderMap_ _lhsOoutput :: ExecutionPlan _lhsOdepgraphs :: PP_Doc _lhsOvisitgraph :: PP_Doc _lhsOerrors :: Seq Error (_lhsOoutput,_lhsOdepgraphs,_lhsOvisitgraph,_lhsOerrors) = rule60 _lhsIoptions _nontsIdepinfo arg_derivings_ arg_typeSyns_ arg_wrappers_ _lhsOinhmap :: Map.Map NontermIdent Attributes _lhsOinhmap = rule61 _nontsIinhmap _lhsOlocalSigMap :: Map.Map NontermIdent (Map.Map ConstructorIdent (Map.Map Identifier Type)) _lhsOlocalSigMap = rule62 _nontsIlocalSigMap _lhsOsynmap :: Map.Map NontermIdent Attributes _lhsOsynmap = rule63 _nontsIsynmap _nontsOclosedHoNtDeps = rule64 _closedHoNtDeps _nontsOclosedHoNtRevDeps = rule65 _closedHoNtRevDeps _nontsOclosedNtDeps = rule66 _closedNtDeps _nontsOoptions = rule67 _lhsIoptions __result_ = T_Grammar_vOut10 _lhsOdepgraphs _lhsOerrors _lhsOinhmap _lhsOlocalSigMap _lhsOoutput _lhsOsynmap _lhsOvisitgraph in __result_ ) in C_Grammar_s11 v10 {-# INLINE rule50 #-} {-# LINE 15 "./src-ag/DistChildAttr.ag" #-} rule50 = \ ((_nontsIinhMap') :: Map Identifier Attributes) -> {-# LINE 15 "./src-ag/DistChildAttr.ag" #-} _nontsIinhMap' {-# LINE 597 "dist/build/KWOrder.hs"#-} {-# INLINE rule51 #-} {-# LINE 16 "./src-ag/DistChildAttr.ag" #-} rule51 = \ ((_nontsIsynMap') :: Map Identifier Attributes) -> {-# LINE 16 "./src-ag/DistChildAttr.ag" #-} _nontsIsynMap' {-# LINE 603 "dist/build/KWOrder.hs"#-} {-# INLINE rule52 #-} {-# LINE 44 "./src-ag/KWOrder.ag" #-} rule52 = \ (_ :: ()) -> {-# LINE 44 "./src-ag/KWOrder.ag" #-} 0 {-# LINE 609 "dist/build/KWOrder.hs"#-} {-# INLINE rule53 #-} {-# LINE 83 "./src-ag/KWOrder.ag" #-} rule53 = \ ((_nontsIntDeps) :: Map NontermIdent (Set NontermIdent)) -> {-# LINE 83 "./src-ag/KWOrder.ag" #-} closeMap _nontsIntDeps {-# LINE 615 "dist/build/KWOrder.hs"#-} {-# INLINE rule54 #-} {-# LINE 84 "./src-ag/KWOrder.ag" #-} rule54 = \ ((_nontsIntHoDeps) :: Map NontermIdent (Set NontermIdent)) -> {-# LINE 84 "./src-ag/KWOrder.ag" #-} closeMap _nontsIntHoDeps {-# LINE 621 "dist/build/KWOrder.hs"#-} {-# INLINE rule55 #-} {-# LINE 85 "./src-ag/KWOrder.ag" #-} rule55 = \ _closedHoNtDeps -> {-# LINE 85 "./src-ag/KWOrder.ag" #-} revDeps _closedHoNtDeps {-# LINE 627 "dist/build/KWOrder.hs"#-} {-# INLINE rule56 #-} {-# LINE 105 "./src-ag/KWOrder.ag" #-} rule56 = \ aroundsMap_ -> {-# LINE 105 "./src-ag/KWOrder.ag" #-} aroundsMap_ {-# LINE 633 "dist/build/KWOrder.hs"#-} {-# INLINE rule57 #-} {-# LINE 130 "./src-ag/KWOrder.ag" #-} rule57 = \ mergeMap_ -> {-# LINE 130 "./src-ag/KWOrder.ag" #-} mergeMap_ {-# LINE 639 "dist/build/KWOrder.hs"#-} {-# INLINE rule58 #-} {-# LINE 146 "./src-ag/KWOrder.ag" #-} rule58 = \ contextMap_ -> {-# LINE 146 "./src-ag/KWOrder.ag" #-} contextMap_ {-# LINE 645 "dist/build/KWOrder.hs"#-} {-# INLINE rule59 #-} {-# LINE 269 "./src-ag/KWOrder.ag" #-} rule59 = \ manualAttrOrderMap_ -> {-# LINE 269 "./src-ag/KWOrder.ag" #-} manualAttrOrderMap_ {-# LINE 651 "dist/build/KWOrder.hs"#-} {-# INLINE rule60 #-} {-# LINE 360 "./src-ag/KWOrder.ag" #-} rule60 = \ ((_lhsIoptions) :: Options) ((_nontsIdepinfo) :: [NontDependencyInformation]) derivings_ typeSyns_ wrappers_ -> {-# LINE 360 "./src-ag/KWOrder.ag" #-} let lazyPlan = kennedyWarrenLazy _lhsIoptions wrappers_ _nontsIdepinfo typeSyns_ derivings_ in if visit _lhsIoptions && withCycle _lhsIoptions then case kennedyWarrenOrder _lhsIoptions wrappers_ _nontsIdepinfo 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) {-# LINE 662 "dist/build/KWOrder.hs"#-} {-# INLINE rule61 #-} rule61 = \ ((_nontsIinhmap) :: Map.Map NontermIdent Attributes) -> _nontsIinhmap {-# INLINE rule62 #-} rule62 = \ ((_nontsIlocalSigMap) :: Map.Map NontermIdent (Map.Map ConstructorIdent (Map.Map Identifier Type))) -> _nontsIlocalSigMap {-# INLINE rule63 #-} rule63 = \ ((_nontsIsynmap) :: Map.Map NontermIdent Attributes) -> _nontsIsynmap {-# INLINE rule64 #-} rule64 = \ _closedHoNtDeps -> _closedHoNtDeps {-# INLINE rule65 #-} rule65 = \ _closedHoNtRevDeps -> _closedHoNtRevDeps {-# INLINE rule66 #-} rule66 = \ _closedNtDeps -> _closedNtDeps {-# INLINE rule67 #-} rule67 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions -- HsToken ----------------------------------------------------- -- wrapper data Inh_HsToken = Inh_HsToken { } data Syn_HsToken = Syn_HsToken { vertices_Syn_HsToken :: (Set.Set Vertex) } {-# INLINABLE wrap_HsToken #-} wrap_HsToken :: T_HsToken -> Inh_HsToken -> (Syn_HsToken ) wrap_HsToken (T_HsToken act) (Inh_HsToken ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_HsToken_vIn13 (T_HsToken_vOut13 _lhsOvertices) <- return (inv_HsToken_s14 sem arg) return (Syn_HsToken _lhsOvertices) ) -- cata {-# NOINLINE sem_HsToken #-} sem_HsToken :: HsToken -> T_HsToken sem_HsToken ( AGLocal var_ pos_ rdesc_ ) = sem_HsToken_AGLocal var_ pos_ rdesc_ sem_HsToken ( AGField field_ attr_ pos_ rdesc_ ) = sem_HsToken_AGField field_ attr_ pos_ rdesc_ sem_HsToken ( HsToken value_ pos_ ) = sem_HsToken_HsToken value_ pos_ sem_HsToken ( CharToken value_ pos_ ) = sem_HsToken_CharToken value_ pos_ sem_HsToken ( StrToken value_ pos_ ) = sem_HsToken_StrToken value_ pos_ sem_HsToken ( Err mesg_ pos_ ) = sem_HsToken_Err mesg_ pos_ -- semantic domain newtype T_HsToken = T_HsToken { attach_T_HsToken :: Identity (T_HsToken_s14 ) } newtype T_HsToken_s14 = C_HsToken_s14 { inv_HsToken_s14 :: (T_HsToken_v13 ) } data T_HsToken_s15 = C_HsToken_s15 type T_HsToken_v13 = (T_HsToken_vIn13 ) -> (T_HsToken_vOut13 ) data T_HsToken_vIn13 = T_HsToken_vIn13 data T_HsToken_vOut13 = T_HsToken_vOut13 (Set.Set Vertex) {-# NOINLINE sem_HsToken_AGLocal #-} sem_HsToken_AGLocal :: (Identifier) -> (Pos) -> (Maybe String) -> T_HsToken sem_HsToken_AGLocal arg_var_ _ _ = T_HsToken (return st14) where {-# NOINLINE st14 #-} st14 = let v13 :: T_HsToken_v13 v13 = \ (T_HsToken_vIn13 ) -> ( let _lhsOvertices :: Set.Set Vertex _lhsOvertices = rule68 arg_var_ __result_ = T_HsToken_vOut13 _lhsOvertices in __result_ ) in C_HsToken_s14 v13 {-# INLINE rule68 #-} {-# LINE 193 "./src-ag/KWOrder.ag" #-} rule68 = \ var_ -> {-# LINE 193 "./src-ag/KWOrder.ag" #-} Set.singleton $ VChild var_ {-# LINE 737 "dist/build/KWOrder.hs"#-} {-# NOINLINE sem_HsToken_AGField #-} sem_HsToken_AGField :: (Identifier) -> (Identifier) -> (Pos) -> (Maybe String) -> T_HsToken sem_HsToken_AGField arg_field_ arg_attr_ _ _ = T_HsToken (return st14) where {-# NOINLINE st14 #-} st14 = let v13 :: T_HsToken_v13 v13 = \ (T_HsToken_vIn13 ) -> ( let _lhsOvertices :: Set.Set Vertex _lhsOvertices = rule69 arg_attr_ arg_field_ __result_ = T_HsToken_vOut13 _lhsOvertices in __result_ ) in C_HsToken_s14 v13 {-# INLINE rule69 #-} {-# LINE 194 "./src-ag/KWOrder.ag" #-} rule69 = \ attr_ field_ -> {-# LINE 194 "./src-ag/KWOrder.ag" #-} Set.singleton $ VAttr (if field_ == _LHS then Inh else if field_ == _LOC then Loc else Syn) field_ attr_ {-# LINE 757 "dist/build/KWOrder.hs"#-} {-# NOINLINE sem_HsToken_HsToken #-} sem_HsToken_HsToken :: (String) -> (Pos) -> T_HsToken sem_HsToken_HsToken _ _ = T_HsToken (return st14) where {-# NOINLINE st14 #-} st14 = let v13 :: T_HsToken_v13 v13 = \ (T_HsToken_vIn13 ) -> ( let _lhsOvertices :: Set.Set Vertex _lhsOvertices = rule70 () __result_ = T_HsToken_vOut13 _lhsOvertices in __result_ ) in C_HsToken_s14 v13 {-# INLINE rule70 #-} rule70 = \ (_ :: ()) -> Set.empty {-# NOINLINE sem_HsToken_CharToken #-} sem_HsToken_CharToken :: (String) -> (Pos) -> T_HsToken sem_HsToken_CharToken _ _ = T_HsToken (return st14) where {-# NOINLINE st14 #-} st14 = let v13 :: T_HsToken_v13 v13 = \ (T_HsToken_vIn13 ) -> ( let _lhsOvertices :: Set.Set Vertex _lhsOvertices = rule71 () __result_ = T_HsToken_vOut13 _lhsOvertices in __result_ ) in C_HsToken_s14 v13 {-# INLINE rule71 #-} rule71 = \ (_ :: ()) -> Set.empty {-# NOINLINE sem_HsToken_StrToken #-} sem_HsToken_StrToken :: (String) -> (Pos) -> T_HsToken sem_HsToken_StrToken _ _ = T_HsToken (return st14) where {-# NOINLINE st14 #-} st14 = let v13 :: T_HsToken_v13 v13 = \ (T_HsToken_vIn13 ) -> ( let _lhsOvertices :: Set.Set Vertex _lhsOvertices = rule72 () __result_ = T_HsToken_vOut13 _lhsOvertices in __result_ ) in C_HsToken_s14 v13 {-# INLINE rule72 #-} rule72 = \ (_ :: ()) -> Set.empty {-# NOINLINE sem_HsToken_Err #-} sem_HsToken_Err :: (String) -> (Pos) -> T_HsToken sem_HsToken_Err _ _ = T_HsToken (return st14) where {-# NOINLINE st14 #-} st14 = let v13 :: T_HsToken_v13 v13 = \ (T_HsToken_vIn13 ) -> ( let _lhsOvertices :: Set.Set Vertex _lhsOvertices = rule73 () __result_ = T_HsToken_vOut13 _lhsOvertices in __result_ ) in C_HsToken_s14 v13 {-# INLINE rule73 #-} rule73 = \ (_ :: ()) -> Set.empty -- HsTokens ---------------------------------------------------- -- wrapper data Inh_HsTokens = Inh_HsTokens { } data Syn_HsTokens = Syn_HsTokens { } {-# INLINABLE wrap_HsTokens #-} wrap_HsTokens :: T_HsTokens -> Inh_HsTokens -> (Syn_HsTokens ) wrap_HsTokens (T_HsTokens act) (Inh_HsTokens ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_HsTokens_vIn16 (T_HsTokens_vOut16 ) <- return (inv_HsTokens_s17 sem arg) return (Syn_HsTokens ) ) -- cata {-# NOINLINE sem_HsTokens #-} sem_HsTokens :: HsTokens -> T_HsTokens sem_HsTokens list = Prelude.foldr sem_HsTokens_Cons sem_HsTokens_Nil (Prelude.map sem_HsToken list) -- semantic domain newtype T_HsTokens = T_HsTokens { attach_T_HsTokens :: Identity (T_HsTokens_s17 ) } newtype T_HsTokens_s17 = C_HsTokens_s17 { inv_HsTokens_s17 :: (T_HsTokens_v16 ) } data T_HsTokens_s18 = C_HsTokens_s18 type T_HsTokens_v16 = (T_HsTokens_vIn16 ) -> (T_HsTokens_vOut16 ) data T_HsTokens_vIn16 = T_HsTokens_vIn16 data T_HsTokens_vOut16 = T_HsTokens_vOut16 {-# NOINLINE sem_HsTokens_Cons #-} sem_HsTokens_Cons :: T_HsToken -> T_HsTokens -> T_HsTokens sem_HsTokens_Cons arg_hd_ arg_tl_ = T_HsTokens (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_HsTokens_v16 v16 = \ (T_HsTokens_vIn16 ) -> ( let _hdX14 = Control.Monad.Identity.runIdentity (attach_T_HsToken (arg_hd_)) _tlX17 = Control.Monad.Identity.runIdentity (attach_T_HsTokens (arg_tl_)) (T_HsToken_vOut13 _hdIvertices) = inv_HsToken_s14 _hdX14 (T_HsToken_vIn13 ) (T_HsTokens_vOut16 ) = inv_HsTokens_s17 _tlX17 (T_HsTokens_vIn16 ) __result_ = T_HsTokens_vOut16 in __result_ ) in C_HsTokens_s17 v16 {-# NOINLINE sem_HsTokens_Nil #-} sem_HsTokens_Nil :: T_HsTokens sem_HsTokens_Nil = T_HsTokens (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_HsTokens_v16 v16 = \ (T_HsTokens_vIn16 ) -> ( let __result_ = T_HsTokens_vOut16 in __result_ ) in C_HsTokens_s17 v16 -- HsTokensRoot ------------------------------------------------ -- wrapper data Inh_HsTokensRoot = Inh_HsTokensRoot { } data Syn_HsTokensRoot = Syn_HsTokensRoot { } {-# INLINABLE wrap_HsTokensRoot #-} wrap_HsTokensRoot :: T_HsTokensRoot -> Inh_HsTokensRoot -> (Syn_HsTokensRoot ) wrap_HsTokensRoot (T_HsTokensRoot act) (Inh_HsTokensRoot ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_HsTokensRoot_vIn19 (T_HsTokensRoot_vOut19 ) <- return (inv_HsTokensRoot_s20 sem arg) return (Syn_HsTokensRoot ) ) -- cata {-# INLINE sem_HsTokensRoot #-} sem_HsTokensRoot :: HsTokensRoot -> T_HsTokensRoot sem_HsTokensRoot ( HsTokensRoot tokens_ ) = sem_HsTokensRoot_HsTokensRoot ( sem_HsTokens tokens_ ) -- semantic domain newtype T_HsTokensRoot = T_HsTokensRoot { attach_T_HsTokensRoot :: Identity (T_HsTokensRoot_s20 ) } newtype T_HsTokensRoot_s20 = C_HsTokensRoot_s20 { inv_HsTokensRoot_s20 :: (T_HsTokensRoot_v19 ) } data T_HsTokensRoot_s21 = C_HsTokensRoot_s21 type T_HsTokensRoot_v19 = (T_HsTokensRoot_vIn19 ) -> (T_HsTokensRoot_vOut19 ) data T_HsTokensRoot_vIn19 = T_HsTokensRoot_vIn19 data T_HsTokensRoot_vOut19 = T_HsTokensRoot_vOut19 {-# NOINLINE sem_HsTokensRoot_HsTokensRoot #-} sem_HsTokensRoot_HsTokensRoot :: T_HsTokens -> T_HsTokensRoot sem_HsTokensRoot_HsTokensRoot arg_tokens_ = T_HsTokensRoot (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_HsTokensRoot_v19 v19 = \ (T_HsTokensRoot_vIn19 ) -> ( let _tokensX17 = Control.Monad.Identity.runIdentity (attach_T_HsTokens (arg_tokens_)) (T_HsTokens_vOut16 ) = inv_HsTokens_s17 _tokensX17 (T_HsTokens_vIn16 ) __result_ = T_HsTokensRoot_vOut19 in __result_ ) in C_HsTokensRoot_s20 v19 -- Nonterminal ------------------------------------------------- -- wrapper data Inh_Nonterminal = Inh_Nonterminal { aroundMap_Inh_Nonterminal :: (Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))), classContexts_Inh_Nonterminal :: (ContextMap), closedHoNtDeps_Inh_Nonterminal :: (Map NontermIdent (Set NontermIdent)), closedHoNtRevDeps_Inh_Nonterminal :: (Map NontermIdent (Set NontermIdent)), closedNtDeps_Inh_Nonterminal :: (Map NontermIdent (Set NontermIdent)), inhMap_Inh_Nonterminal :: (Map Identifier Attributes), manualDeps_Inh_Nonterminal :: (AttrOrderMap), mergeMap_Inh_Nonterminal :: (Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression)))), options_Inh_Nonterminal :: (Options), rulenumber_Inh_Nonterminal :: (Int), synMap_Inh_Nonterminal :: (Map Identifier Attributes) } data Syn_Nonterminal = Syn_Nonterminal { depinfo_Syn_Nonterminal :: (NontDependencyInformation), inhMap'_Syn_Nonterminal :: (Map Identifier Attributes), inhmap_Syn_Nonterminal :: (Map.Map NontermIdent Attributes), localSigMap_Syn_Nonterminal :: (Map.Map NontermIdent (Map.Map ConstructorIdent (Map.Map Identifier Type))), ntDeps_Syn_Nonterminal :: (Map NontermIdent (Set NontermIdent)), ntHoDeps_Syn_Nonterminal :: (Map NontermIdent (Set NontermIdent)), rulenumber_Syn_Nonterminal :: (Int), synMap'_Syn_Nonterminal :: (Map Identifier Attributes), synmap_Syn_Nonterminal :: (Map.Map NontermIdent Attributes) } {-# INLINABLE wrap_Nonterminal #-} wrap_Nonterminal :: T_Nonterminal -> Inh_Nonterminal -> (Syn_Nonterminal ) wrap_Nonterminal (T_Nonterminal act) (Inh_Nonterminal _lhsIaroundMap _lhsIclassContexts _lhsIclosedHoNtDeps _lhsIclosedHoNtRevDeps _lhsIclosedNtDeps _lhsIinhMap _lhsImanualDeps _lhsImergeMap _lhsIoptions _lhsIrulenumber _lhsIsynMap) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Nonterminal_vIn22 _lhsIaroundMap _lhsIclassContexts _lhsIclosedHoNtDeps _lhsIclosedHoNtRevDeps _lhsIclosedNtDeps _lhsIinhMap _lhsImanualDeps _lhsImergeMap _lhsIoptions _lhsIrulenumber _lhsIsynMap (T_Nonterminal_vOut22 _lhsOdepinfo _lhsOinhMap' _lhsOinhmap _lhsOlocalSigMap _lhsOntDeps _lhsOntHoDeps _lhsOrulenumber _lhsOsynMap' _lhsOsynmap) <- return (inv_Nonterminal_s23 sem arg) return (Syn_Nonterminal _lhsOdepinfo _lhsOinhMap' _lhsOinhmap _lhsOlocalSigMap _lhsOntDeps _lhsOntHoDeps _lhsOrulenumber _lhsOsynMap' _lhsOsynmap) ) -- cata {-# INLINE sem_Nonterminal #-} sem_Nonterminal :: Nonterminal -> T_Nonterminal sem_Nonterminal ( Nonterminal nt_ params_ inh_ syn_ prods_ ) = sem_Nonterminal_Nonterminal nt_ params_ inh_ syn_ ( sem_Productions prods_ ) -- semantic domain newtype T_Nonterminal = T_Nonterminal { attach_T_Nonterminal :: Identity (T_Nonterminal_s23 ) } newtype T_Nonterminal_s23 = C_Nonterminal_s23 { inv_Nonterminal_s23 :: (T_Nonterminal_v22 ) } data T_Nonterminal_s24 = C_Nonterminal_s24 type T_Nonterminal_v22 = (T_Nonterminal_vIn22 ) -> (T_Nonterminal_vOut22 ) data T_Nonterminal_vIn22 = T_Nonterminal_vIn22 (Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) (ContextMap) (Map NontermIdent (Set NontermIdent)) (Map NontermIdent (Set NontermIdent)) (Map NontermIdent (Set NontermIdent)) (Map Identifier Attributes) (AttrOrderMap) (Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression)))) (Options) (Int) (Map Identifier Attributes) data T_Nonterminal_vOut22 = T_Nonterminal_vOut22 (NontDependencyInformation) (Map Identifier Attributes) (Map.Map NontermIdent Attributes) (Map.Map NontermIdent (Map.Map ConstructorIdent (Map.Map Identifier Type))) (Map NontermIdent (Set NontermIdent)) (Map NontermIdent (Set NontermIdent)) (Int) (Map Identifier Attributes) (Map.Map NontermIdent Attributes) {-# NOINLINE sem_Nonterminal_Nonterminal #-} sem_Nonterminal_Nonterminal :: (NontermIdent) -> ([Identifier]) -> (Attributes) -> (Attributes) -> T_Productions -> T_Nonterminal sem_Nonterminal_Nonterminal arg_nt_ arg_params_ arg_inh_ arg_syn_ arg_prods_ = T_Nonterminal (return st23) where {-# NOINLINE st23 #-} st23 = let v22 :: T_Nonterminal_v22 v22 = \ (T_Nonterminal_vIn22 _lhsIaroundMap _lhsIclassContexts _lhsIclosedHoNtDeps _lhsIclosedHoNtRevDeps _lhsIclosedNtDeps _lhsIinhMap _lhsImanualDeps _lhsImergeMap _lhsIoptions _lhsIrulenumber _lhsIsynMap) -> ( let _prodsX38 = Control.Monad.Identity.runIdentity (attach_T_Productions (arg_prods_)) (T_Productions_vOut37 _prodsIdepgraph _prodsIlocalSigMap _prodsIrefHoNts _prodsIrefNts _prodsIrulenumber) = inv_Productions_s38 _prodsX38 (T_Productions_vIn37 _prodsOaroundMap _prodsOinhMap _prodsOmanualDeps _prodsOmergeMap _prodsOoptions _prodsOrulenumber _prodsOsynMap) _lhsOinhMap' :: Map Identifier Attributes _lhsOinhMap' = rule74 arg_inh_ arg_nt_ _lhsOsynMap' :: Map Identifier Attributes _lhsOsynMap' = rule75 arg_nt_ arg_syn_ _lhsOntDeps :: Map NontermIdent (Set NontermIdent) _lhsOntDeps = rule76 _prodsIrefNts arg_nt_ _lhsOntHoDeps :: Map NontermIdent (Set NontermIdent) _lhsOntHoDeps = rule77 _prodsIrefHoNts arg_nt_ _closedNtDeps = rule78 _lhsIclosedNtDeps arg_nt_ _closedHoNtDeps = rule79 _lhsIclosedHoNtDeps arg_nt_ _closedHoNtRevDeps = rule80 _lhsIclosedHoNtRevDeps arg_nt_ _recursive = rule81 _closedNtDeps arg_nt_ _nontrivAcyc = rule82 _closedHoNtDeps arg_nt_ _hoInfo = rule83 _closedHoNtDeps _closedHoNtRevDeps _nontrivAcyc _aroundMap = rule84 _lhsIaroundMap arg_nt_ _mergeMap = rule85 _lhsImergeMap arg_nt_ _classContexts = rule86 _lhsIclassContexts arg_nt_ _prodsOmanualDeps = rule87 _lhsImanualDeps arg_nt_ _synvertices = rule88 arg_nt_ arg_syn_ _inhvertices = rule89 arg_inh_ arg_nt_ _vertices = rule90 _inhvertices _synvertices _nontgraph = rule91 _vertices _lhsOdepinfo :: NontDependencyInformation _lhsOdepinfo = rule92 _classContexts _hoInfo _nontgraph _prodsIdepgraph _recursive arg_inh_ arg_nt_ arg_params_ arg_syn_ _lhsOinhmap :: Map.Map NontermIdent Attributes _lhsOinhmap = rule93 arg_inh_ arg_nt_ _lhsOsynmap :: Map.Map NontermIdent Attributes _lhsOsynmap = rule94 arg_nt_ arg_syn_ _lhsOlocalSigMap :: Map.Map NontermIdent (Map.Map ConstructorIdent (Map.Map Identifier Type)) _lhsOlocalSigMap = rule95 _prodsIlocalSigMap arg_nt_ _lhsOrulenumber :: Int _lhsOrulenumber = rule96 _prodsIrulenumber _prodsOaroundMap = rule97 _aroundMap _prodsOinhMap = rule98 _lhsIinhMap _prodsOmergeMap = rule99 _mergeMap _prodsOoptions = rule100 _lhsIoptions _prodsOrulenumber = rule101 _lhsIrulenumber _prodsOsynMap = rule102 _lhsIsynMap __result_ = T_Nonterminal_vOut22 _lhsOdepinfo _lhsOinhMap' _lhsOinhmap _lhsOlocalSigMap _lhsOntDeps _lhsOntHoDeps _lhsOrulenumber _lhsOsynMap' _lhsOsynmap in __result_ ) in C_Nonterminal_s23 v22 {-# INLINE rule74 #-} {-# LINE 7 "./src-ag/DistChildAttr.ag" #-} rule74 = \ inh_ nt_ -> {-# LINE 7 "./src-ag/DistChildAttr.ag" #-} Map.singleton nt_ inh_ {-# LINE 1002 "dist/build/KWOrder.hs"#-} {-# INLINE rule75 #-} {-# LINE 8 "./src-ag/DistChildAttr.ag" #-} rule75 = \ nt_ syn_ -> {-# LINE 8 "./src-ag/DistChildAttr.ag" #-} Map.singleton nt_ syn_ {-# LINE 1008 "dist/build/KWOrder.hs"#-} {-# INLINE rule76 #-} {-# LINE 59 "./src-ag/KWOrder.ag" #-} rule76 = \ ((_prodsIrefNts) :: Set NontermIdent) nt_ -> {-# LINE 59 "./src-ag/KWOrder.ag" #-} Map.singleton nt_ _prodsIrefNts {-# LINE 1014 "dist/build/KWOrder.hs"#-} {-# INLINE rule77 #-} {-# LINE 60 "./src-ag/KWOrder.ag" #-} rule77 = \ ((_prodsIrefHoNts) :: Set NontermIdent) nt_ -> {-# LINE 60 "./src-ag/KWOrder.ag" #-} Map.singleton nt_ _prodsIrefHoNts {-# LINE 1020 "dist/build/KWOrder.hs"#-} {-# INLINE rule78 #-} {-# LINE 62 "./src-ag/KWOrder.ag" #-} rule78 = \ ((_lhsIclosedNtDeps) :: Map NontermIdent (Set NontermIdent)) nt_ -> {-# LINE 62 "./src-ag/KWOrder.ag" #-} Map.findWithDefault Set.empty nt_ _lhsIclosedNtDeps {-# LINE 1026 "dist/build/KWOrder.hs"#-} {-# INLINE rule79 #-} {-# LINE 63 "./src-ag/KWOrder.ag" #-} rule79 = \ ((_lhsIclosedHoNtDeps) :: Map NontermIdent (Set NontermIdent)) nt_ -> {-# LINE 63 "./src-ag/KWOrder.ag" #-} Map.findWithDefault Set.empty nt_ _lhsIclosedHoNtDeps {-# LINE 1032 "dist/build/KWOrder.hs"#-} {-# INLINE rule80 #-} {-# LINE 64 "./src-ag/KWOrder.ag" #-} rule80 = \ ((_lhsIclosedHoNtRevDeps) :: Map NontermIdent (Set NontermIdent)) nt_ -> {-# LINE 64 "./src-ag/KWOrder.ag" #-} Map.findWithDefault Set.empty nt_ _lhsIclosedHoNtRevDeps {-# LINE 1038 "dist/build/KWOrder.hs"#-} {-# INLINE rule81 #-} {-# LINE 66 "./src-ag/KWOrder.ag" #-} rule81 = \ _closedNtDeps nt_ -> {-# LINE 66 "./src-ag/KWOrder.ag" #-} nt_ `Set.member` _closedNtDeps {-# LINE 1044 "dist/build/KWOrder.hs"#-} {-# INLINE rule82 #-} {-# LINE 67 "./src-ag/KWOrder.ag" #-} rule82 = \ _closedHoNtDeps nt_ -> {-# LINE 67 "./src-ag/KWOrder.ag" #-} nt_ `Set.member` _closedHoNtDeps {-# LINE 1050 "dist/build/KWOrder.hs"#-} {-# INLINE rule83 #-} {-# LINE 68 "./src-ag/KWOrder.ag" #-} rule83 = \ _closedHoNtDeps _closedHoNtRevDeps _nontrivAcyc -> {-# LINE 68 "./src-ag/KWOrder.ag" #-} HigherOrderInfo { hoNtDeps = _closedHoNtDeps , hoNtRevDeps = _closedHoNtRevDeps , hoAcyclic = _nontrivAcyc } {-# LINE 1059 "dist/build/KWOrder.hs"#-} {-# INLINE rule84 #-} {-# LINE 101 "./src-ag/KWOrder.ag" #-} rule84 = \ ((_lhsIaroundMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) nt_ -> {-# LINE 101 "./src-ag/KWOrder.ag" #-} Map.findWithDefault Map.empty nt_ _lhsIaroundMap {-# LINE 1065 "dist/build/KWOrder.hs"#-} {-# INLINE rule85 #-} {-# LINE 126 "./src-ag/KWOrder.ag" #-} rule85 = \ ((_lhsImergeMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression)))) nt_ -> {-# LINE 126 "./src-ag/KWOrder.ag" #-} Map.findWithDefault Map.empty nt_ _lhsImergeMap {-# LINE 1071 "dist/build/KWOrder.hs"#-} {-# INLINE rule86 #-} {-# LINE 149 "./src-ag/KWOrder.ag" #-} rule86 = \ ((_lhsIclassContexts) :: ContextMap) nt_ -> {-# LINE 149 "./src-ag/KWOrder.ag" #-} Map.findWithDefault [] nt_ _lhsIclassContexts {-# LINE 1077 "dist/build/KWOrder.hs"#-} {-# INLINE rule87 #-} {-# LINE 270 "./src-ag/KWOrder.ag" #-} rule87 = \ ((_lhsImanualDeps) :: AttrOrderMap) nt_ -> {-# LINE 270 "./src-ag/KWOrder.ag" #-} Map.findWithDefault Map.empty nt_ _lhsImanualDeps {-# LINE 1083 "dist/build/KWOrder.hs"#-} {-# INLINE rule88 #-} {-# LINE 325 "./src-ag/KWOrder.ag" #-} rule88 = \ nt_ syn_ -> {-# LINE 325 "./src-ag/KWOrder.ag" #-} map (VAttr Syn nt_) . Map.keys $ syn_ {-# LINE 1089 "dist/build/KWOrder.hs"#-} {-# INLINE rule89 #-} {-# LINE 326 "./src-ag/KWOrder.ag" #-} rule89 = \ inh_ nt_ -> {-# LINE 326 "./src-ag/KWOrder.ag" #-} map (VAttr Inh nt_) . Map.keys $ inh_ {-# LINE 1095 "dist/build/KWOrder.hs"#-} {-# INLINE rule90 #-} {-# LINE 327 "./src-ag/KWOrder.ag" #-} rule90 = \ _inhvertices _synvertices -> {-# LINE 327 "./src-ag/KWOrder.ag" #-} _synvertices ++ _inhvertices {-# LINE 1101 "dist/build/KWOrder.hs"#-} {-# INLINE rule91 #-} {-# LINE 331 "./src-ag/KWOrder.ag" #-} rule91 = \ _vertices -> {-# LINE 331 "./src-ag/KWOrder.ag" #-} NontDependencyGraph { ndgVertices = _vertices , ndgEdges = [] } {-# LINE 1108 "dist/build/KWOrder.hs"#-} {-# INLINE rule92 #-} {-# LINE 339 "./src-ag/KWOrder.ag" #-} rule92 = \ _classContexts _hoInfo _nontgraph ((_prodsIdepgraph) :: [ProdDependencyGraph]) _recursive inh_ nt_ params_ syn_ -> {-# LINE 339 "./src-ag/KWOrder.ag" #-} NontDependencyInformation { ndiNonterminal = nt_ , ndiParams = params_ , ndiInh = Map.keys inh_ , ndiSyn = Map.keys syn_ , ndiDepGraph = _nontgraph , ndiProds = _prodsIdepgraph , ndiRecursive = _recursive , ndiHoInfo = _hoInfo , ndiClassCtxs = _classContexts } {-# LINE 1123 "dist/build/KWOrder.hs"#-} {-# INLINE rule93 #-} {-# LINE 377 "./src-ag/KWOrder.ag" #-} rule93 = \ inh_ nt_ -> {-# LINE 377 "./src-ag/KWOrder.ag" #-} Map.singleton nt_ inh_ {-# LINE 1129 "dist/build/KWOrder.hs"#-} {-# INLINE rule94 #-} {-# LINE 378 "./src-ag/KWOrder.ag" #-} rule94 = \ nt_ syn_ -> {-# LINE 378 "./src-ag/KWOrder.ag" #-} Map.singleton nt_ syn_ {-# LINE 1135 "dist/build/KWOrder.hs"#-} {-# INLINE rule95 #-} {-# LINE 387 "./src-ag/KWOrder.ag" #-} rule95 = \ ((_prodsIlocalSigMap) :: Map.Map ConstructorIdent (Map.Map Identifier Type)) nt_ -> {-# LINE 387 "./src-ag/KWOrder.ag" #-} Map.singleton nt_ _prodsIlocalSigMap {-# LINE 1141 "dist/build/KWOrder.hs"#-} {-# INLINE rule96 #-} rule96 = \ ((_prodsIrulenumber) :: Int) -> _prodsIrulenumber {-# INLINE rule97 #-} rule97 = \ _aroundMap -> _aroundMap {-# INLINE rule98 #-} rule98 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule99 #-} rule99 = \ _mergeMap -> _mergeMap {-# INLINE rule100 #-} rule100 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule101 #-} rule101 = \ ((_lhsIrulenumber) :: Int) -> _lhsIrulenumber {-# INLINE rule102 #-} rule102 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap -- Nonterminals ------------------------------------------------ -- wrapper data Inh_Nonterminals = Inh_Nonterminals { aroundMap_Inh_Nonterminals :: (Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))), classContexts_Inh_Nonterminals :: (ContextMap), closedHoNtDeps_Inh_Nonterminals :: (Map NontermIdent (Set NontermIdent)), closedHoNtRevDeps_Inh_Nonterminals :: (Map NontermIdent (Set NontermIdent)), closedNtDeps_Inh_Nonterminals :: (Map NontermIdent (Set NontermIdent)), inhMap_Inh_Nonterminals :: (Map Identifier Attributes), manualDeps_Inh_Nonterminals :: (AttrOrderMap), mergeMap_Inh_Nonterminals :: (Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression)))), options_Inh_Nonterminals :: (Options), rulenumber_Inh_Nonterminals :: (Int), synMap_Inh_Nonterminals :: (Map Identifier Attributes) } data Syn_Nonterminals = Syn_Nonterminals { depinfo_Syn_Nonterminals :: ([NontDependencyInformation]), inhMap'_Syn_Nonterminals :: (Map Identifier Attributes), inhmap_Syn_Nonterminals :: (Map.Map NontermIdent Attributes), localSigMap_Syn_Nonterminals :: (Map.Map NontermIdent (Map.Map ConstructorIdent (Map.Map Identifier Type))), ntDeps_Syn_Nonterminals :: (Map NontermIdent (Set NontermIdent)), ntHoDeps_Syn_Nonterminals :: (Map NontermIdent (Set NontermIdent)), rulenumber_Syn_Nonterminals :: (Int), synMap'_Syn_Nonterminals :: (Map Identifier Attributes), synmap_Syn_Nonterminals :: (Map.Map NontermIdent Attributes) } {-# INLINABLE wrap_Nonterminals #-} wrap_Nonterminals :: T_Nonterminals -> Inh_Nonterminals -> (Syn_Nonterminals ) wrap_Nonterminals (T_Nonterminals act) (Inh_Nonterminals _lhsIaroundMap _lhsIclassContexts _lhsIclosedHoNtDeps _lhsIclosedHoNtRevDeps _lhsIclosedNtDeps _lhsIinhMap _lhsImanualDeps _lhsImergeMap _lhsIoptions _lhsIrulenumber _lhsIsynMap) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Nonterminals_vIn25 _lhsIaroundMap _lhsIclassContexts _lhsIclosedHoNtDeps _lhsIclosedHoNtRevDeps _lhsIclosedNtDeps _lhsIinhMap _lhsImanualDeps _lhsImergeMap _lhsIoptions _lhsIrulenumber _lhsIsynMap (T_Nonterminals_vOut25 _lhsOdepinfo _lhsOinhMap' _lhsOinhmap _lhsOlocalSigMap _lhsOntDeps _lhsOntHoDeps _lhsOrulenumber _lhsOsynMap' _lhsOsynmap) <- return (inv_Nonterminals_s26 sem arg) return (Syn_Nonterminals _lhsOdepinfo _lhsOinhMap' _lhsOinhmap _lhsOlocalSigMap _lhsOntDeps _lhsOntHoDeps _lhsOrulenumber _lhsOsynMap' _lhsOsynmap) ) -- cata {-# NOINLINE sem_Nonterminals #-} sem_Nonterminals :: Nonterminals -> T_Nonterminals sem_Nonterminals list = Prelude.foldr sem_Nonterminals_Cons sem_Nonterminals_Nil (Prelude.map sem_Nonterminal list) -- semantic domain newtype T_Nonterminals = T_Nonterminals { attach_T_Nonterminals :: Identity (T_Nonterminals_s26 ) } newtype T_Nonterminals_s26 = C_Nonterminals_s26 { inv_Nonterminals_s26 :: (T_Nonterminals_v25 ) } data T_Nonterminals_s27 = C_Nonterminals_s27 type T_Nonterminals_v25 = (T_Nonterminals_vIn25 ) -> (T_Nonterminals_vOut25 ) data T_Nonterminals_vIn25 = T_Nonterminals_vIn25 (Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) (ContextMap) (Map NontermIdent (Set NontermIdent)) (Map NontermIdent (Set NontermIdent)) (Map NontermIdent (Set NontermIdent)) (Map Identifier Attributes) (AttrOrderMap) (Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression)))) (Options) (Int) (Map Identifier Attributes) data T_Nonterminals_vOut25 = T_Nonterminals_vOut25 ([NontDependencyInformation]) (Map Identifier Attributes) (Map.Map NontermIdent Attributes) (Map.Map NontermIdent (Map.Map ConstructorIdent (Map.Map Identifier Type))) (Map NontermIdent (Set NontermIdent)) (Map NontermIdent (Set NontermIdent)) (Int) (Map Identifier Attributes) (Map.Map NontermIdent Attributes) {-# NOINLINE sem_Nonterminals_Cons #-} sem_Nonterminals_Cons :: T_Nonterminal -> T_Nonterminals -> T_Nonterminals sem_Nonterminals_Cons arg_hd_ arg_tl_ = T_Nonterminals (return st26) where {-# NOINLINE st26 #-} st26 = let v25 :: T_Nonterminals_v25 v25 = \ (T_Nonterminals_vIn25 _lhsIaroundMap _lhsIclassContexts _lhsIclosedHoNtDeps _lhsIclosedHoNtRevDeps _lhsIclosedNtDeps _lhsIinhMap _lhsImanualDeps _lhsImergeMap _lhsIoptions _lhsIrulenumber _lhsIsynMap) -> ( let _hdX23 = Control.Monad.Identity.runIdentity (attach_T_Nonterminal (arg_hd_)) _tlX26 = Control.Monad.Identity.runIdentity (attach_T_Nonterminals (arg_tl_)) (T_Nonterminal_vOut22 _hdIdepinfo _hdIinhMap' _hdIinhmap _hdIlocalSigMap _hdIntDeps _hdIntHoDeps _hdIrulenumber _hdIsynMap' _hdIsynmap) = inv_Nonterminal_s23 _hdX23 (T_Nonterminal_vIn22 _hdOaroundMap _hdOclassContexts _hdOclosedHoNtDeps _hdOclosedHoNtRevDeps _hdOclosedNtDeps _hdOinhMap _hdOmanualDeps _hdOmergeMap _hdOoptions _hdOrulenumber _hdOsynMap) (T_Nonterminals_vOut25 _tlIdepinfo _tlIinhMap' _tlIinhmap _tlIlocalSigMap _tlIntDeps _tlIntHoDeps _tlIrulenumber _tlIsynMap' _tlIsynmap) = inv_Nonterminals_s26 _tlX26 (T_Nonterminals_vIn25 _tlOaroundMap _tlOclassContexts _tlOclosedHoNtDeps _tlOclosedHoNtRevDeps _tlOclosedNtDeps _tlOinhMap _tlOmanualDeps _tlOmergeMap _tlOoptions _tlOrulenumber _tlOsynMap) _lhsOdepinfo :: [NontDependencyInformation] _lhsOdepinfo = rule103 _hdIdepinfo _tlIdepinfo _lhsOinhMap' :: Map Identifier Attributes _lhsOinhMap' = rule104 _hdIinhMap' _tlIinhMap' _lhsOinhmap :: Map.Map NontermIdent Attributes _lhsOinhmap = rule105 _hdIinhmap _tlIinhmap _lhsOlocalSigMap :: Map.Map NontermIdent (Map.Map ConstructorIdent (Map.Map Identifier Type)) _lhsOlocalSigMap = rule106 _hdIlocalSigMap _tlIlocalSigMap _lhsOntDeps :: Map NontermIdent (Set NontermIdent) _lhsOntDeps = rule107 _hdIntDeps _tlIntDeps _lhsOntHoDeps :: Map NontermIdent (Set NontermIdent) _lhsOntHoDeps = rule108 _hdIntHoDeps _tlIntHoDeps _lhsOsynMap' :: Map Identifier Attributes _lhsOsynMap' = rule109 _hdIsynMap' _tlIsynMap' _lhsOsynmap :: Map.Map NontermIdent Attributes _lhsOsynmap = rule110 _hdIsynmap _tlIsynmap _lhsOrulenumber :: Int _lhsOrulenumber = rule111 _tlIrulenumber _hdOaroundMap = rule112 _lhsIaroundMap _hdOclassContexts = rule113 _lhsIclassContexts _hdOclosedHoNtDeps = rule114 _lhsIclosedHoNtDeps _hdOclosedHoNtRevDeps = rule115 _lhsIclosedHoNtRevDeps _hdOclosedNtDeps = rule116 _lhsIclosedNtDeps _hdOinhMap = rule117 _lhsIinhMap _hdOmanualDeps = rule118 _lhsImanualDeps _hdOmergeMap = rule119 _lhsImergeMap _hdOoptions = rule120 _lhsIoptions _hdOrulenumber = rule121 _lhsIrulenumber _hdOsynMap = rule122 _lhsIsynMap _tlOaroundMap = rule123 _lhsIaroundMap _tlOclassContexts = rule124 _lhsIclassContexts _tlOclosedHoNtDeps = rule125 _lhsIclosedHoNtDeps _tlOclosedHoNtRevDeps = rule126 _lhsIclosedHoNtRevDeps _tlOclosedNtDeps = rule127 _lhsIclosedNtDeps _tlOinhMap = rule128 _lhsIinhMap _tlOmanualDeps = rule129 _lhsImanualDeps _tlOmergeMap = rule130 _lhsImergeMap _tlOoptions = rule131 _lhsIoptions _tlOrulenumber = rule132 _hdIrulenumber _tlOsynMap = rule133 _lhsIsynMap __result_ = T_Nonterminals_vOut25 _lhsOdepinfo _lhsOinhMap' _lhsOinhmap _lhsOlocalSigMap _lhsOntDeps _lhsOntHoDeps _lhsOrulenumber _lhsOsynMap' _lhsOsynmap in __result_ ) in C_Nonterminals_s26 v25 {-# INLINE rule103 #-} rule103 = \ ((_hdIdepinfo) :: NontDependencyInformation) ((_tlIdepinfo) :: [NontDependencyInformation]) -> _hdIdepinfo : _tlIdepinfo {-# INLINE rule104 #-} rule104 = \ ((_hdIinhMap') :: Map Identifier Attributes) ((_tlIinhMap') :: Map Identifier Attributes) -> _hdIinhMap' `Map.union` _tlIinhMap' {-# INLINE rule105 #-} rule105 = \ ((_hdIinhmap) :: Map.Map NontermIdent Attributes) ((_tlIinhmap) :: Map.Map NontermIdent Attributes) -> _hdIinhmap `Map.union` _tlIinhmap {-# INLINE rule106 #-} rule106 = \ ((_hdIlocalSigMap) :: Map.Map NontermIdent (Map.Map ConstructorIdent (Map.Map Identifier Type))) ((_tlIlocalSigMap) :: Map.Map NontermIdent (Map.Map ConstructorIdent (Map.Map Identifier Type))) -> _hdIlocalSigMap `Map.union` _tlIlocalSigMap {-# INLINE rule107 #-} rule107 = \ ((_hdIntDeps) :: Map NontermIdent (Set NontermIdent)) ((_tlIntDeps) :: Map NontermIdent (Set NontermIdent)) -> _hdIntDeps `mappend` _tlIntDeps {-# INLINE rule108 #-} rule108 = \ ((_hdIntHoDeps) :: Map NontermIdent (Set NontermIdent)) ((_tlIntHoDeps) :: Map NontermIdent (Set NontermIdent)) -> _hdIntHoDeps `mappend` _tlIntHoDeps {-# INLINE rule109 #-} rule109 = \ ((_hdIsynMap') :: Map Identifier Attributes) ((_tlIsynMap') :: Map Identifier Attributes) -> _hdIsynMap' `Map.union` _tlIsynMap' {-# INLINE rule110 #-} rule110 = \ ((_hdIsynmap) :: Map.Map NontermIdent Attributes) ((_tlIsynmap) :: Map.Map NontermIdent Attributes) -> _hdIsynmap `Map.union` _tlIsynmap {-# INLINE rule111 #-} rule111 = \ ((_tlIrulenumber) :: Int) -> _tlIrulenumber {-# INLINE rule112 #-} rule112 = \ ((_lhsIaroundMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) -> _lhsIaroundMap {-# INLINE rule113 #-} rule113 = \ ((_lhsIclassContexts) :: ContextMap) -> _lhsIclassContexts {-# INLINE rule114 #-} rule114 = \ ((_lhsIclosedHoNtDeps) :: Map NontermIdent (Set NontermIdent)) -> _lhsIclosedHoNtDeps {-# INLINE rule115 #-} rule115 = \ ((_lhsIclosedHoNtRevDeps) :: Map NontermIdent (Set NontermIdent)) -> _lhsIclosedHoNtRevDeps {-# INLINE rule116 #-} rule116 = \ ((_lhsIclosedNtDeps) :: Map NontermIdent (Set NontermIdent)) -> _lhsIclosedNtDeps {-# INLINE rule117 #-} rule117 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule118 #-} rule118 = \ ((_lhsImanualDeps) :: AttrOrderMap) -> _lhsImanualDeps {-# INLINE rule119 #-} rule119 = \ ((_lhsImergeMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression)))) -> _lhsImergeMap {-# INLINE rule120 #-} rule120 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule121 #-} rule121 = \ ((_lhsIrulenumber) :: Int) -> _lhsIrulenumber {-# INLINE rule122 #-} rule122 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# INLINE rule123 #-} rule123 = \ ((_lhsIaroundMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) -> _lhsIaroundMap {-# INLINE rule124 #-} rule124 = \ ((_lhsIclassContexts) :: ContextMap) -> _lhsIclassContexts {-# INLINE rule125 #-} rule125 = \ ((_lhsIclosedHoNtDeps) :: Map NontermIdent (Set NontermIdent)) -> _lhsIclosedHoNtDeps {-# INLINE rule126 #-} rule126 = \ ((_lhsIclosedHoNtRevDeps) :: Map NontermIdent (Set NontermIdent)) -> _lhsIclosedHoNtRevDeps {-# INLINE rule127 #-} rule127 = \ ((_lhsIclosedNtDeps) :: Map NontermIdent (Set NontermIdent)) -> _lhsIclosedNtDeps {-# INLINE rule128 #-} rule128 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule129 #-} rule129 = \ ((_lhsImanualDeps) :: AttrOrderMap) -> _lhsImanualDeps {-# INLINE rule130 #-} rule130 = \ ((_lhsImergeMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression)))) -> _lhsImergeMap {-# INLINE rule131 #-} rule131 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule132 #-} rule132 = \ ((_hdIrulenumber) :: Int) -> _hdIrulenumber {-# INLINE rule133 #-} rule133 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# NOINLINE sem_Nonterminals_Nil #-} sem_Nonterminals_Nil :: T_Nonterminals sem_Nonterminals_Nil = T_Nonterminals (return st26) where {-# NOINLINE st26 #-} st26 = let v25 :: T_Nonterminals_v25 v25 = \ (T_Nonterminals_vIn25 _lhsIaroundMap _lhsIclassContexts _lhsIclosedHoNtDeps _lhsIclosedHoNtRevDeps _lhsIclosedNtDeps _lhsIinhMap _lhsImanualDeps _lhsImergeMap _lhsIoptions _lhsIrulenumber _lhsIsynMap) -> ( let _lhsOdepinfo :: [NontDependencyInformation] _lhsOdepinfo = rule134 () _lhsOinhMap' :: Map Identifier Attributes _lhsOinhMap' = rule135 () _lhsOinhmap :: Map.Map NontermIdent Attributes _lhsOinhmap = rule136 () _lhsOlocalSigMap :: Map.Map NontermIdent (Map.Map ConstructorIdent (Map.Map Identifier Type)) _lhsOlocalSigMap = rule137 () _lhsOntDeps :: Map NontermIdent (Set NontermIdent) _lhsOntDeps = rule138 () _lhsOntHoDeps :: Map NontermIdent (Set NontermIdent) _lhsOntHoDeps = rule139 () _lhsOsynMap' :: Map Identifier Attributes _lhsOsynMap' = rule140 () _lhsOsynmap :: Map.Map NontermIdent Attributes _lhsOsynmap = rule141 () _lhsOrulenumber :: Int _lhsOrulenumber = rule142 _lhsIrulenumber __result_ = T_Nonterminals_vOut25 _lhsOdepinfo _lhsOinhMap' _lhsOinhmap _lhsOlocalSigMap _lhsOntDeps _lhsOntHoDeps _lhsOrulenumber _lhsOsynMap' _lhsOsynmap in __result_ ) in C_Nonterminals_s26 v25 {-# INLINE rule134 #-} rule134 = \ (_ :: ()) -> [] {-# INLINE rule135 #-} rule135 = \ (_ :: ()) -> Map.empty {-# INLINE rule136 #-} rule136 = \ (_ :: ()) -> Map.empty {-# INLINE rule137 #-} rule137 = \ (_ :: ()) -> Map.empty {-# INLINE rule138 #-} rule138 = \ (_ :: ()) -> mempty {-# INLINE rule139 #-} rule139 = \ (_ :: ()) -> mempty {-# INLINE rule140 #-} rule140 = \ (_ :: ()) -> Map.empty {-# INLINE rule141 #-} rule141 = \ (_ :: ()) -> Map.empty {-# INLINE rule142 #-} rule142 = \ ((_lhsIrulenumber) :: Int) -> _lhsIrulenumber -- Pattern ----------------------------------------------------- -- wrapper data Inh_Pattern = Inh_Pattern { } data Syn_Pattern = Syn_Pattern { copy_Syn_Pattern :: (Pattern), vertices_Syn_Pattern :: (Set.Set Vertex) } {-# INLINABLE wrap_Pattern #-} wrap_Pattern :: T_Pattern -> Inh_Pattern -> (Syn_Pattern ) wrap_Pattern (T_Pattern act) (Inh_Pattern ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Pattern_vIn28 (T_Pattern_vOut28 _lhsOcopy _lhsOvertices) <- return (inv_Pattern_s29 sem arg) return (Syn_Pattern _lhsOcopy _lhsOvertices) ) -- cata {-# NOINLINE sem_Pattern #-} sem_Pattern :: Pattern -> T_Pattern sem_Pattern ( Constr name_ pats_ ) = sem_Pattern_Constr name_ ( sem_Patterns pats_ ) sem_Pattern ( Product pos_ pats_ ) = sem_Pattern_Product pos_ ( sem_Patterns pats_ ) sem_Pattern ( Alias field_ attr_ pat_ ) = sem_Pattern_Alias field_ attr_ ( sem_Pattern pat_ ) sem_Pattern ( Irrefutable pat_ ) = sem_Pattern_Irrefutable ( sem_Pattern pat_ ) sem_Pattern ( Underscore pos_ ) = sem_Pattern_Underscore pos_ -- semantic domain newtype T_Pattern = T_Pattern { attach_T_Pattern :: Identity (T_Pattern_s29 ) } newtype T_Pattern_s29 = C_Pattern_s29 { inv_Pattern_s29 :: (T_Pattern_v28 ) } data T_Pattern_s30 = C_Pattern_s30 type T_Pattern_v28 = (T_Pattern_vIn28 ) -> (T_Pattern_vOut28 ) data T_Pattern_vIn28 = T_Pattern_vIn28 data T_Pattern_vOut28 = T_Pattern_vOut28 (Pattern) (Set.Set Vertex) {-# NOINLINE sem_Pattern_Constr #-} sem_Pattern_Constr :: (ConstructorIdent) -> T_Patterns -> T_Pattern sem_Pattern_Constr arg_name_ arg_pats_ = T_Pattern (return st29) where {-# NOINLINE st29 #-} st29 = let v28 :: T_Pattern_v28 v28 = \ (T_Pattern_vIn28 ) -> ( let _patsX32 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) (T_Patterns_vOut31 _patsIcopy _patsIvertices) = inv_Patterns_s32 _patsX32 (T_Patterns_vIn31 ) _lhsOvertices :: Set.Set Vertex _lhsOvertices = rule143 _patsIvertices _copy = rule144 _patsIcopy arg_name_ _lhsOcopy :: Pattern _lhsOcopy = rule145 _copy __result_ = T_Pattern_vOut28 _lhsOcopy _lhsOvertices in __result_ ) in C_Pattern_s29 v28 {-# INLINE rule143 #-} rule143 = \ ((_patsIvertices) :: Set.Set Vertex) -> _patsIvertices {-# INLINE rule144 #-} rule144 = \ ((_patsIcopy) :: Patterns) name_ -> Constr name_ _patsIcopy {-# INLINE rule145 #-} rule145 = \ _copy -> _copy {-# NOINLINE sem_Pattern_Product #-} sem_Pattern_Product :: (Pos) -> T_Patterns -> T_Pattern sem_Pattern_Product arg_pos_ arg_pats_ = T_Pattern (return st29) where {-# NOINLINE st29 #-} st29 = let v28 :: T_Pattern_v28 v28 = \ (T_Pattern_vIn28 ) -> ( let _patsX32 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) (T_Patterns_vOut31 _patsIcopy _patsIvertices) = inv_Patterns_s32 _patsX32 (T_Patterns_vIn31 ) _lhsOvertices :: Set.Set Vertex _lhsOvertices = rule146 _patsIvertices _copy = rule147 _patsIcopy arg_pos_ _lhsOcopy :: Pattern _lhsOcopy = rule148 _copy __result_ = T_Pattern_vOut28 _lhsOcopy _lhsOvertices in __result_ ) in C_Pattern_s29 v28 {-# INLINE rule146 #-} rule146 = \ ((_patsIvertices) :: Set.Set Vertex) -> _patsIvertices {-# INLINE rule147 #-} rule147 = \ ((_patsIcopy) :: Patterns) pos_ -> Product pos_ _patsIcopy {-# INLINE rule148 #-} rule148 = \ _copy -> _copy {-# NOINLINE sem_Pattern_Alias #-} sem_Pattern_Alias :: (Identifier) -> (Identifier) -> T_Pattern -> T_Pattern sem_Pattern_Alias arg_field_ arg_attr_ arg_pat_ = T_Pattern (return st29) where {-# NOINLINE st29 #-} st29 = let v28 :: T_Pattern_v28 v28 = \ (T_Pattern_vIn28 ) -> ( let _patX29 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) (T_Pattern_vOut28 _patIcopy _patIvertices) = inv_Pattern_s29 _patX29 (T_Pattern_vIn28 ) _vertex = rule149 arg_attr_ arg_field_ _lhsOvertices :: Set.Set Vertex _lhsOvertices = rule150 _patIvertices _vertex _copy = rule151 _patIcopy arg_attr_ arg_field_ _lhsOcopy :: Pattern _lhsOcopy = rule152 _copy __result_ = T_Pattern_vOut28 _lhsOcopy _lhsOvertices in __result_ ) in C_Pattern_s29 v28 {-# INLINE rule149 #-} {-# LINE 205 "./src-ag/KWOrder.ag" #-} rule149 = \ attr_ field_ -> {-# LINE 205 "./src-ag/KWOrder.ag" #-} if field_ == _INST then VChild attr_ else VAttr (if field_ == _LHS then Syn else if field_ == _LOC then Loc else Inh) field_ attr_ {-# LINE 1509 "dist/build/KWOrder.hs"#-} {-# INLINE rule150 #-} {-# LINE 209 "./src-ag/KWOrder.ag" #-} rule150 = \ ((_patIvertices) :: Set.Set Vertex) _vertex -> {-# LINE 209 "./src-ag/KWOrder.ag" #-} Set.insert _vertex _patIvertices {-# LINE 1515 "dist/build/KWOrder.hs"#-} {-# INLINE rule151 #-} rule151 = \ ((_patIcopy) :: Pattern) attr_ field_ -> Alias field_ attr_ _patIcopy {-# INLINE rule152 #-} rule152 = \ _copy -> _copy {-# NOINLINE sem_Pattern_Irrefutable #-} sem_Pattern_Irrefutable :: T_Pattern -> T_Pattern sem_Pattern_Irrefutable arg_pat_ = T_Pattern (return st29) where {-# NOINLINE st29 #-} st29 = let v28 :: T_Pattern_v28 v28 = \ (T_Pattern_vIn28 ) -> ( let _patX29 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) (T_Pattern_vOut28 _patIcopy _patIvertices) = inv_Pattern_s29 _patX29 (T_Pattern_vIn28 ) _lhsOvertices :: Set.Set Vertex _lhsOvertices = rule153 _patIvertices _copy = rule154 _patIcopy _lhsOcopy :: Pattern _lhsOcopy = rule155 _copy __result_ = T_Pattern_vOut28 _lhsOcopy _lhsOvertices in __result_ ) in C_Pattern_s29 v28 {-# INLINE rule153 #-} rule153 = \ ((_patIvertices) :: Set.Set Vertex) -> _patIvertices {-# INLINE rule154 #-} rule154 = \ ((_patIcopy) :: Pattern) -> Irrefutable _patIcopy {-# INLINE rule155 #-} rule155 = \ _copy -> _copy {-# NOINLINE sem_Pattern_Underscore #-} sem_Pattern_Underscore :: (Pos) -> T_Pattern sem_Pattern_Underscore arg_pos_ = T_Pattern (return st29) where {-# NOINLINE st29 #-} st29 = let v28 :: T_Pattern_v28 v28 = \ (T_Pattern_vIn28 ) -> ( let _lhsOvertices :: Set.Set Vertex _lhsOvertices = rule156 () _copy = rule157 arg_pos_ _lhsOcopy :: Pattern _lhsOcopy = rule158 _copy __result_ = T_Pattern_vOut28 _lhsOcopy _lhsOvertices in __result_ ) in C_Pattern_s29 v28 {-# INLINE rule156 #-} rule156 = \ (_ :: ()) -> Set.empty {-# INLINE rule157 #-} rule157 = \ pos_ -> Underscore pos_ {-# INLINE rule158 #-} rule158 = \ _copy -> _copy -- Patterns ---------------------------------------------------- -- wrapper data Inh_Patterns = Inh_Patterns { } data Syn_Patterns = Syn_Patterns { copy_Syn_Patterns :: (Patterns), vertices_Syn_Patterns :: (Set.Set Vertex) } {-# INLINABLE wrap_Patterns #-} wrap_Patterns :: T_Patterns -> Inh_Patterns -> (Syn_Patterns ) wrap_Patterns (T_Patterns act) (Inh_Patterns ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Patterns_vIn31 (T_Patterns_vOut31 _lhsOcopy _lhsOvertices) <- return (inv_Patterns_s32 sem arg) return (Syn_Patterns _lhsOcopy _lhsOvertices) ) -- cata {-# NOINLINE sem_Patterns #-} sem_Patterns :: Patterns -> T_Patterns sem_Patterns list = Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list) -- semantic domain newtype T_Patterns = T_Patterns { attach_T_Patterns :: Identity (T_Patterns_s32 ) } newtype T_Patterns_s32 = C_Patterns_s32 { inv_Patterns_s32 :: (T_Patterns_v31 ) } data T_Patterns_s33 = C_Patterns_s33 type T_Patterns_v31 = (T_Patterns_vIn31 ) -> (T_Patterns_vOut31 ) data T_Patterns_vIn31 = T_Patterns_vIn31 data T_Patterns_vOut31 = T_Patterns_vOut31 (Patterns) (Set.Set Vertex) {-# NOINLINE sem_Patterns_Cons #-} sem_Patterns_Cons :: T_Pattern -> T_Patterns -> T_Patterns sem_Patterns_Cons arg_hd_ arg_tl_ = T_Patterns (return st32) where {-# NOINLINE st32 #-} st32 = let v31 :: T_Patterns_v31 v31 = \ (T_Patterns_vIn31 ) -> ( let _hdX29 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_hd_)) _tlX32 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_tl_)) (T_Pattern_vOut28 _hdIcopy _hdIvertices) = inv_Pattern_s29 _hdX29 (T_Pattern_vIn28 ) (T_Patterns_vOut31 _tlIcopy _tlIvertices) = inv_Patterns_s32 _tlX32 (T_Patterns_vIn31 ) _lhsOvertices :: Set.Set Vertex _lhsOvertices = rule159 _hdIvertices _tlIvertices _copy = rule160 _hdIcopy _tlIcopy _lhsOcopy :: Patterns _lhsOcopy = rule161 _copy __result_ = T_Patterns_vOut31 _lhsOcopy _lhsOvertices in __result_ ) in C_Patterns_s32 v31 {-# INLINE rule159 #-} rule159 = \ ((_hdIvertices) :: Set.Set Vertex) ((_tlIvertices) :: Set.Set Vertex) -> _hdIvertices `Set.union` _tlIvertices {-# INLINE rule160 #-} rule160 = \ ((_hdIcopy) :: Pattern) ((_tlIcopy) :: Patterns) -> (:) _hdIcopy _tlIcopy {-# INLINE rule161 #-} rule161 = \ _copy -> _copy {-# NOINLINE sem_Patterns_Nil #-} sem_Patterns_Nil :: T_Patterns sem_Patterns_Nil = T_Patterns (return st32) where {-# NOINLINE st32 #-} st32 = let v31 :: T_Patterns_v31 v31 = \ (T_Patterns_vIn31 ) -> ( let _lhsOvertices :: Set.Set Vertex _lhsOvertices = rule162 () _copy = rule163 () _lhsOcopy :: Patterns _lhsOcopy = rule164 _copy __result_ = T_Patterns_vOut31 _lhsOcopy _lhsOvertices in __result_ ) in C_Patterns_s32 v31 {-# INLINE rule162 #-} rule162 = \ (_ :: ()) -> Set.empty {-# INLINE rule163 #-} rule163 = \ (_ :: ()) -> [] {-# INLINE rule164 #-} rule164 = \ _copy -> _copy -- Production -------------------------------------------------- -- wrapper data Inh_Production = Inh_Production { aroundMap_Inh_Production :: (Map ConstructorIdent (Map Identifier [Expression])), inhMap_Inh_Production :: (Map Identifier Attributes), manualDeps_Inh_Production :: (Map ConstructorIdent (Set Dependency)), mergeMap_Inh_Production :: (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression))), options_Inh_Production :: (Options), rulenumber_Inh_Production :: (Int), synMap_Inh_Production :: (Map Identifier Attributes) } data Syn_Production = Syn_Production { depgraph_Syn_Production :: (ProdDependencyGraph), localSigMap_Syn_Production :: (Map.Map ConstructorIdent (Map.Map Identifier Type)), refHoNts_Syn_Production :: (Set NontermIdent), refNts_Syn_Production :: (Set NontermIdent), rulenumber_Syn_Production :: (Int) } {-# INLINABLE wrap_Production #-} wrap_Production :: T_Production -> Inh_Production -> (Syn_Production ) wrap_Production (T_Production act) (Inh_Production _lhsIaroundMap _lhsIinhMap _lhsImanualDeps _lhsImergeMap _lhsIoptions _lhsIrulenumber _lhsIsynMap) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Production_vIn34 _lhsIaroundMap _lhsIinhMap _lhsImanualDeps _lhsImergeMap _lhsIoptions _lhsIrulenumber _lhsIsynMap (T_Production_vOut34 _lhsOdepgraph _lhsOlocalSigMap _lhsOrefHoNts _lhsOrefNts _lhsOrulenumber) <- return (inv_Production_s35 sem arg) return (Syn_Production _lhsOdepgraph _lhsOlocalSigMap _lhsOrefHoNts _lhsOrefNts _lhsOrulenumber) ) -- cata {-# INLINE sem_Production #-} sem_Production :: Production -> T_Production sem_Production ( Production con_ params_ constraints_ children_ rules_ typeSigs_ macro_ ) = sem_Production_Production con_ params_ constraints_ ( sem_Children children_ ) ( sem_Rules rules_ ) ( sem_TypeSigs typeSigs_ ) macro_ -- semantic domain newtype T_Production = T_Production { attach_T_Production :: Identity (T_Production_s35 ) } newtype T_Production_s35 = C_Production_s35 { inv_Production_s35 :: (T_Production_v34 ) } data T_Production_s36 = C_Production_s36 type T_Production_v34 = (T_Production_vIn34 ) -> (T_Production_vOut34 ) data T_Production_vIn34 = T_Production_vIn34 (Map ConstructorIdent (Map Identifier [Expression])) (Map Identifier Attributes) (Map ConstructorIdent (Set Dependency)) (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression))) (Options) (Int) (Map Identifier Attributes) data T_Production_vOut34 = T_Production_vOut34 (ProdDependencyGraph) (Map.Map ConstructorIdent (Map.Map Identifier Type)) (Set NontermIdent) (Set NontermIdent) (Int) {-# NOINLINE sem_Production_Production #-} sem_Production_Production :: (ConstructorIdent) -> ([Identifier]) -> ([Type]) -> T_Children -> T_Rules -> T_TypeSigs -> (MaybeMacro) -> T_Production sem_Production_Production arg_con_ arg_params_ arg_constraints_ arg_children_ arg_rules_ arg_typeSigs_ _ = T_Production (return st35) where {-# NOINLINE st35 #-} st35 = let v34 :: T_Production_v34 v34 = \ (T_Production_vIn34 _lhsIaroundMap _lhsIinhMap _lhsImanualDeps _lhsImergeMap _lhsIoptions _lhsIrulenumber _lhsIsynMap) -> ( let _childrenX5 = Control.Monad.Identity.runIdentity (attach_T_Children (arg_children_)) _rulesX44 = Control.Monad.Identity.runIdentity (attach_T_Rules (arg_rules_)) _typeSigsX50 = Control.Monad.Identity.runIdentity (attach_T_TypeSigs (arg_typeSigs_)) (T_Children_vOut4 _childrenIechilds _childrenIedges _childrenInontnames _childrenIrefHoNts _childrenIrefNts _childrenIvertices) = inv_Children_s5 _childrenX5 (T_Children_vIn4 _childrenOaroundMap _childrenOinhMap _childrenOmergeMap _childrenOmergedChildren _childrenOoptions _childrenOsynMap) (T_Rules_vOut43 _rulesIedges _rulesIerules _rulesIrulenumber _rulesIvertices) = inv_Rules_s44 _rulesX44 (T_Rules_vIn43 _rulesOrulenumber) (T_TypeSigs_vOut49 _typeSigsIlocalSigMap) = inv_TypeSigs_s50 _typeSigsX50 (T_TypeSigs_vIn49 ) _aroundMap = rule165 _lhsIaroundMap arg_con_ _mergeMap = rule166 _lhsImergeMap arg_con_ _mergedChildren = rule167 _mergeMap _vertices = rule168 _childrenIvertices _rulesIvertices _manualDeps = rule169 _lhsImanualDeps arg_con_ _manualEdges = rule170 _manualDeps _edges = rule171 _childrenIedges _rulesIedges _lhsOdepgraph :: ProdDependencyGraph _lhsOdepgraph = rule172 _childrenIechilds _childrenInontnames _edges _rulesIerules _vertices arg_con_ arg_constraints_ arg_params_ _lhsOlocalSigMap :: Map.Map ConstructorIdent (Map.Map Identifier Type) _lhsOlocalSigMap = rule173 _typeSigsIlocalSigMap arg_con_ _lhsOrefHoNts :: Set NontermIdent _lhsOrefHoNts = rule174 _childrenIrefHoNts _lhsOrefNts :: Set NontermIdent _lhsOrefNts = rule175 _childrenIrefNts _lhsOrulenumber :: Int _lhsOrulenumber = rule176 _rulesIrulenumber _childrenOaroundMap = rule177 _aroundMap _childrenOinhMap = rule178 _lhsIinhMap _childrenOmergeMap = rule179 _mergeMap _childrenOmergedChildren = rule180 _mergedChildren _childrenOoptions = rule181 _lhsIoptions _childrenOsynMap = rule182 _lhsIsynMap _rulesOrulenumber = rule183 _lhsIrulenumber __result_ = T_Production_vOut34 _lhsOdepgraph _lhsOlocalSigMap _lhsOrefHoNts _lhsOrefNts _lhsOrulenumber in __result_ ) in C_Production_s35 v34 {-# INLINE rule165 #-} {-# LINE 102 "./src-ag/KWOrder.ag" #-} rule165 = \ ((_lhsIaroundMap) :: Map ConstructorIdent (Map Identifier [Expression])) con_ -> {-# LINE 102 "./src-ag/KWOrder.ag" #-} Map.findWithDefault Map.empty con_ _lhsIaroundMap {-# LINE 1731 "dist/build/KWOrder.hs"#-} {-# INLINE rule166 #-} {-# LINE 127 "./src-ag/KWOrder.ag" #-} rule166 = \ ((_lhsImergeMap) :: Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression))) con_ -> {-# LINE 127 "./src-ag/KWOrder.ag" #-} Map.findWithDefault Map.empty con_ _lhsImergeMap {-# LINE 1737 "dist/build/KWOrder.hs"#-} {-# INLINE rule167 #-} {-# LINE 133 "./src-ag/KWOrder.ag" #-} rule167 = \ _mergeMap -> {-# LINE 133 "./src-ag/KWOrder.ag" #-} Set.unions [ Set.fromList ms | (_,ms,_) <- Map.elems _mergeMap ] {-# LINE 1743 "dist/build/KWOrder.hs"#-} {-# INLINE rule168 #-} {-# LINE 229 "./src-ag/KWOrder.ag" #-} rule168 = \ ((_childrenIvertices) :: Set.Set Vertex) ((_rulesIvertices) :: Set.Set Vertex) -> {-# LINE 229 "./src-ag/KWOrder.ag" #-} _rulesIvertices `Set.union` _childrenIvertices {-# LINE 1749 "dist/build/KWOrder.hs"#-} {-# INLINE rule169 #-} {-# LINE 272 "./src-ag/KWOrder.ag" #-} rule169 = \ ((_lhsImanualDeps) :: Map ConstructorIdent (Set Dependency)) con_ -> {-# LINE 272 "./src-ag/KWOrder.ag" #-} Map.findWithDefault Set.empty con_ _lhsImanualDeps {-# LINE 1755 "dist/build/KWOrder.hs"#-} {-# INLINE rule170 #-} {-# LINE 273 "./src-ag/KWOrder.ag" #-} rule170 = \ _manualDeps -> {-# LINE 273 "./src-ag/KWOrder.ag" #-} Set.map depToEdge _manualDeps {-# LINE 1761 "dist/build/KWOrder.hs"#-} {-# INLINE rule171 #-} {-# LINE 295 "./src-ag/KWOrder.ag" #-} rule171 = \ ((_childrenIedges) :: Set.Set Edge) ((_rulesIedges) :: Set.Set Edge) -> {-# LINE 295 "./src-ag/KWOrder.ag" #-} _rulesIedges `Set.union` _childrenIedges {-# LINE 1767 "dist/build/KWOrder.hs"#-} {-# INLINE rule172 #-} {-# LINE 310 "./src-ag/KWOrder.ag" #-} rule172 = \ ((_childrenIechilds) :: EChildren) ((_childrenInontnames) :: [(Identifier, Identifier)]) _edges ((_rulesIerules) :: ERules) _vertices con_ constraints_ params_ -> {-# LINE 310 "./src-ag/KWOrder.ag" #-} ProdDependencyGraph { pdgVertices = Set.toList _vertices , pdgEdges = Set.toList _edges , pdgRules = _rulesIerules , pdgChilds = _childrenIechilds , pdgProduction = con_ , pdgChildMap = _childrenInontnames , pdgConstraints = constraints_ , pdgParams = params_ } {-# LINE 1780 "dist/build/KWOrder.hs"#-} {-# INLINE rule173 #-} {-# LINE 388 "./src-ag/KWOrder.ag" #-} rule173 = \ ((_typeSigsIlocalSigMap) :: Map Identifier Type) con_ -> {-# LINE 388 "./src-ag/KWOrder.ag" #-} Map.singleton con_ _typeSigsIlocalSigMap {-# LINE 1786 "dist/build/KWOrder.hs"#-} {-# INLINE rule174 #-} rule174 = \ ((_childrenIrefHoNts) :: Set NontermIdent) -> _childrenIrefHoNts {-# INLINE rule175 #-} rule175 = \ ((_childrenIrefNts) :: Set NontermIdent) -> _childrenIrefNts {-# INLINE rule176 #-} rule176 = \ ((_rulesIrulenumber) :: Int) -> _rulesIrulenumber {-# INLINE rule177 #-} rule177 = \ _aroundMap -> _aroundMap {-# INLINE rule178 #-} rule178 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule179 #-} rule179 = \ _mergeMap -> _mergeMap {-# INLINE rule180 #-} rule180 = \ _mergedChildren -> _mergedChildren {-# INLINE rule181 #-} rule181 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule182 #-} rule182 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# INLINE rule183 #-} rule183 = \ ((_lhsIrulenumber) :: Int) -> _lhsIrulenumber -- Productions ------------------------------------------------- -- wrapper data Inh_Productions = Inh_Productions { aroundMap_Inh_Productions :: (Map ConstructorIdent (Map Identifier [Expression])), inhMap_Inh_Productions :: (Map Identifier Attributes), manualDeps_Inh_Productions :: (Map ConstructorIdent (Set Dependency)), mergeMap_Inh_Productions :: (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression))), options_Inh_Productions :: (Options), rulenumber_Inh_Productions :: (Int), synMap_Inh_Productions :: (Map Identifier Attributes) } data Syn_Productions = Syn_Productions { depgraph_Syn_Productions :: ([ProdDependencyGraph]), localSigMap_Syn_Productions :: (Map.Map ConstructorIdent (Map.Map Identifier Type)), refHoNts_Syn_Productions :: (Set NontermIdent), refNts_Syn_Productions :: (Set NontermIdent), rulenumber_Syn_Productions :: (Int) } {-# INLINABLE wrap_Productions #-} wrap_Productions :: T_Productions -> Inh_Productions -> (Syn_Productions ) wrap_Productions (T_Productions act) (Inh_Productions _lhsIaroundMap _lhsIinhMap _lhsImanualDeps _lhsImergeMap _lhsIoptions _lhsIrulenumber _lhsIsynMap) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Productions_vIn37 _lhsIaroundMap _lhsIinhMap _lhsImanualDeps _lhsImergeMap _lhsIoptions _lhsIrulenumber _lhsIsynMap (T_Productions_vOut37 _lhsOdepgraph _lhsOlocalSigMap _lhsOrefHoNts _lhsOrefNts _lhsOrulenumber) <- return (inv_Productions_s38 sem arg) return (Syn_Productions _lhsOdepgraph _lhsOlocalSigMap _lhsOrefHoNts _lhsOrefNts _lhsOrulenumber) ) -- cata {-# NOINLINE sem_Productions #-} sem_Productions :: Productions -> T_Productions sem_Productions list = Prelude.foldr sem_Productions_Cons sem_Productions_Nil (Prelude.map sem_Production list) -- semantic domain newtype T_Productions = T_Productions { attach_T_Productions :: Identity (T_Productions_s38 ) } newtype T_Productions_s38 = C_Productions_s38 { inv_Productions_s38 :: (T_Productions_v37 ) } data T_Productions_s39 = C_Productions_s39 type T_Productions_v37 = (T_Productions_vIn37 ) -> (T_Productions_vOut37 ) data T_Productions_vIn37 = T_Productions_vIn37 (Map ConstructorIdent (Map Identifier [Expression])) (Map Identifier Attributes) (Map ConstructorIdent (Set Dependency)) (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression))) (Options) (Int) (Map Identifier Attributes) data T_Productions_vOut37 = T_Productions_vOut37 ([ProdDependencyGraph]) (Map.Map ConstructorIdent (Map.Map Identifier Type)) (Set NontermIdent) (Set NontermIdent) (Int) {-# NOINLINE sem_Productions_Cons #-} sem_Productions_Cons :: T_Production -> T_Productions -> T_Productions sem_Productions_Cons arg_hd_ arg_tl_ = T_Productions (return st38) where {-# NOINLINE st38 #-} st38 = let v37 :: T_Productions_v37 v37 = \ (T_Productions_vIn37 _lhsIaroundMap _lhsIinhMap _lhsImanualDeps _lhsImergeMap _lhsIoptions _lhsIrulenumber _lhsIsynMap) -> ( let _hdX35 = Control.Monad.Identity.runIdentity (attach_T_Production (arg_hd_)) _tlX38 = Control.Monad.Identity.runIdentity (attach_T_Productions (arg_tl_)) (T_Production_vOut34 _hdIdepgraph _hdIlocalSigMap _hdIrefHoNts _hdIrefNts _hdIrulenumber) = inv_Production_s35 _hdX35 (T_Production_vIn34 _hdOaroundMap _hdOinhMap _hdOmanualDeps _hdOmergeMap _hdOoptions _hdOrulenumber _hdOsynMap) (T_Productions_vOut37 _tlIdepgraph _tlIlocalSigMap _tlIrefHoNts _tlIrefNts _tlIrulenumber) = inv_Productions_s38 _tlX38 (T_Productions_vIn37 _tlOaroundMap _tlOinhMap _tlOmanualDeps _tlOmergeMap _tlOoptions _tlOrulenumber _tlOsynMap) _lhsOdepgraph :: [ProdDependencyGraph] _lhsOdepgraph = rule184 _hdIdepgraph _tlIdepgraph _lhsOlocalSigMap :: Map.Map ConstructorIdent (Map.Map Identifier Type) _lhsOlocalSigMap = rule185 _hdIlocalSigMap _tlIlocalSigMap _lhsOrefHoNts :: Set NontermIdent _lhsOrefHoNts = rule186 _hdIrefHoNts _tlIrefHoNts _lhsOrefNts :: Set NontermIdent _lhsOrefNts = rule187 _hdIrefNts _tlIrefNts _lhsOrulenumber :: Int _lhsOrulenumber = rule188 _tlIrulenumber _hdOaroundMap = rule189 _lhsIaroundMap _hdOinhMap = rule190 _lhsIinhMap _hdOmanualDeps = rule191 _lhsImanualDeps _hdOmergeMap = rule192 _lhsImergeMap _hdOoptions = rule193 _lhsIoptions _hdOrulenumber = rule194 _lhsIrulenumber _hdOsynMap = rule195 _lhsIsynMap _tlOaroundMap = rule196 _lhsIaroundMap _tlOinhMap = rule197 _lhsIinhMap _tlOmanualDeps = rule198 _lhsImanualDeps _tlOmergeMap = rule199 _lhsImergeMap _tlOoptions = rule200 _lhsIoptions _tlOrulenumber = rule201 _hdIrulenumber _tlOsynMap = rule202 _lhsIsynMap __result_ = T_Productions_vOut37 _lhsOdepgraph _lhsOlocalSigMap _lhsOrefHoNts _lhsOrefNts _lhsOrulenumber in __result_ ) in C_Productions_s38 v37 {-# INLINE rule184 #-} rule184 = \ ((_hdIdepgraph) :: ProdDependencyGraph) ((_tlIdepgraph) :: [ProdDependencyGraph]) -> _hdIdepgraph : _tlIdepgraph {-# INLINE rule185 #-} rule185 = \ ((_hdIlocalSigMap) :: Map.Map ConstructorIdent (Map.Map Identifier Type)) ((_tlIlocalSigMap) :: Map.Map ConstructorIdent (Map.Map Identifier Type)) -> _hdIlocalSigMap `Map.union` _tlIlocalSigMap {-# INLINE rule186 #-} rule186 = \ ((_hdIrefHoNts) :: Set NontermIdent) ((_tlIrefHoNts) :: Set NontermIdent) -> _hdIrefHoNts `mappend` _tlIrefHoNts {-# INLINE rule187 #-} rule187 = \ ((_hdIrefNts) :: Set NontermIdent) ((_tlIrefNts) :: Set NontermIdent) -> _hdIrefNts `mappend` _tlIrefNts {-# INLINE rule188 #-} rule188 = \ ((_tlIrulenumber) :: Int) -> _tlIrulenumber {-# INLINE rule189 #-} rule189 = \ ((_lhsIaroundMap) :: Map ConstructorIdent (Map Identifier [Expression])) -> _lhsIaroundMap {-# INLINE rule190 #-} rule190 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule191 #-} rule191 = \ ((_lhsImanualDeps) :: Map ConstructorIdent (Set Dependency)) -> _lhsImanualDeps {-# INLINE rule192 #-} rule192 = \ ((_lhsImergeMap) :: Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression))) -> _lhsImergeMap {-# INLINE rule193 #-} rule193 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule194 #-} rule194 = \ ((_lhsIrulenumber) :: Int) -> _lhsIrulenumber {-# INLINE rule195 #-} rule195 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# INLINE rule196 #-} rule196 = \ ((_lhsIaroundMap) :: Map ConstructorIdent (Map Identifier [Expression])) -> _lhsIaroundMap {-# INLINE rule197 #-} rule197 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule198 #-} rule198 = \ ((_lhsImanualDeps) :: Map ConstructorIdent (Set Dependency)) -> _lhsImanualDeps {-# INLINE rule199 #-} rule199 = \ ((_lhsImergeMap) :: Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression))) -> _lhsImergeMap {-# INLINE rule200 #-} rule200 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule201 #-} rule201 = \ ((_hdIrulenumber) :: Int) -> _hdIrulenumber {-# INLINE rule202 #-} rule202 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# NOINLINE sem_Productions_Nil #-} sem_Productions_Nil :: T_Productions sem_Productions_Nil = T_Productions (return st38) where {-# NOINLINE st38 #-} st38 = let v37 :: T_Productions_v37 v37 = \ (T_Productions_vIn37 _lhsIaroundMap _lhsIinhMap _lhsImanualDeps _lhsImergeMap _lhsIoptions _lhsIrulenumber _lhsIsynMap) -> ( let _lhsOdepgraph :: [ProdDependencyGraph] _lhsOdepgraph = rule203 () _lhsOlocalSigMap :: Map.Map ConstructorIdent (Map.Map Identifier Type) _lhsOlocalSigMap = rule204 () _lhsOrefHoNts :: Set NontermIdent _lhsOrefHoNts = rule205 () _lhsOrefNts :: Set NontermIdent _lhsOrefNts = rule206 () _lhsOrulenumber :: Int _lhsOrulenumber = rule207 _lhsIrulenumber __result_ = T_Productions_vOut37 _lhsOdepgraph _lhsOlocalSigMap _lhsOrefHoNts _lhsOrefNts _lhsOrulenumber in __result_ ) in C_Productions_s38 v37 {-# INLINE rule203 #-} rule203 = \ (_ :: ()) -> [] {-# INLINE rule204 #-} rule204 = \ (_ :: ()) -> Map.empty {-# INLINE rule205 #-} rule205 = \ (_ :: ()) -> mempty {-# INLINE rule206 #-} rule206 = \ (_ :: ()) -> mempty {-# INLINE rule207 #-} rule207 = \ ((_lhsIrulenumber) :: Int) -> _lhsIrulenumber -- Rule -------------------------------------------------------- -- wrapper data Inh_Rule = Inh_Rule { rulenumber_Inh_Rule :: (Int) } data Syn_Rule = Syn_Rule { edges_Syn_Rule :: (Set.Set Edge), erules_Syn_Rule :: (ERule), rulenumber_Syn_Rule :: (Int), vertices_Syn_Rule :: (Set.Set Vertex) } {-# INLINABLE wrap_Rule #-} wrap_Rule :: T_Rule -> Inh_Rule -> (Syn_Rule ) wrap_Rule (T_Rule act) (Inh_Rule _lhsIrulenumber) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Rule_vIn40 _lhsIrulenumber (T_Rule_vOut40 _lhsOedges _lhsOerules _lhsOrulenumber _lhsOvertices) <- return (inv_Rule_s41 sem arg) return (Syn_Rule _lhsOedges _lhsOerules _lhsOrulenumber _lhsOvertices) ) -- cata {-# INLINE sem_Rule #-} sem_Rule :: Rule -> T_Rule sem_Rule ( Rule mbName_ pattern_ rhs_ owrt_ origin_ explicit_ pure_ identity_ mbError_ eager_ ) = sem_Rule_Rule mbName_ ( sem_Pattern pattern_ ) ( sem_Expression rhs_ ) owrt_ origin_ explicit_ pure_ identity_ mbError_ eager_ -- semantic domain newtype T_Rule = T_Rule { attach_T_Rule :: Identity (T_Rule_s41 ) } newtype T_Rule_s41 = C_Rule_s41 { inv_Rule_s41 :: (T_Rule_v40 ) } data T_Rule_s42 = C_Rule_s42 type T_Rule_v40 = (T_Rule_vIn40 ) -> (T_Rule_vOut40 ) data T_Rule_vIn40 = T_Rule_vIn40 (Int) data T_Rule_vOut40 = T_Rule_vOut40 (Set.Set Edge) (ERule) (Int) (Set.Set Vertex) {-# NOINLINE sem_Rule_Rule #-} sem_Rule_Rule :: (Maybe Identifier) -> T_Pattern -> T_Expression -> (Bool) -> (String) -> (Bool) -> (Bool) -> (Bool) -> (Maybe Error) -> (Bool) -> T_Rule sem_Rule_Rule arg_mbName_ arg_pattern_ arg_rhs_ arg_owrt_ arg_origin_ arg_explicit_ arg_pure_ _ arg_mbError_ _ = T_Rule (return st41) where {-# NOINLINE st41 #-} st41 = let v40 :: T_Rule_v40 v40 = \ (T_Rule_vIn40 _lhsIrulenumber) -> ( let _patternX29 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pattern_)) _rhsX8 = Control.Monad.Identity.runIdentity (attach_T_Expression (arg_rhs_)) (T_Pattern_vOut28 _patternIcopy _patternIvertices) = inv_Pattern_s29 _patternX29 (T_Pattern_vIn28 ) (T_Expression_vOut7 _rhsIcopy _rhsIvertices) = inv_Expression_s8 _rhsX8 (T_Expression_vIn7 ) _lhsOrulenumber :: Int _lhsOrulenumber = rule208 _lhsIrulenumber _rulename = rule209 _lhsIrulenumber arg_mbName_ _lhsOerules :: ERule _lhsOerules = rule210 _patternIcopy _rhsIcopy _rulename arg_explicit_ arg_mbError_ arg_origin_ arg_owrt_ arg_pure_ _vertex = rule211 _rulename _lhsOvertices :: Set.Set Vertex _lhsOvertices = rule212 _patternIvertices _rhsIvertices _vertex _edgesout = rule213 _rhsIvertices _vertex _edgesin = rule214 _patternIvertices _vertex _lhsOedges :: Set.Set Edge _lhsOedges = rule215 _edgesin _edgesout __result_ = T_Rule_vOut40 _lhsOedges _lhsOerules _lhsOrulenumber _lhsOvertices in __result_ ) in C_Rule_s41 v40 {-# INLINE rule208 #-} {-# LINE 47 "./src-ag/KWOrder.ag" #-} rule208 = \ ((_lhsIrulenumber) :: Int) -> {-# LINE 47 "./src-ag/KWOrder.ag" #-} _lhsIrulenumber + 1 {-# LINE 2040 "dist/build/KWOrder.hs"#-} {-# INLINE rule209 #-} {-# LINE 48 "./src-ag/KWOrder.ag" #-} rule209 = \ ((_lhsIrulenumber) :: Int) mbName_ -> {-# LINE 48 "./src-ag/KWOrder.ag" #-} maybe (identifier $ "rule" ++ show _lhsIrulenumber) id mbName_ {-# LINE 2046 "dist/build/KWOrder.hs"#-} {-# INLINE rule210 #-} {-# LINE 160 "./src-ag/KWOrder.ag" #-} rule210 = \ ((_patternIcopy) :: Pattern) ((_rhsIcopy) :: Expression) _rulename explicit_ mbError_ origin_ owrt_ pure_ -> {-# LINE 160 "./src-ag/KWOrder.ag" #-} ERule _rulename _patternIcopy _rhsIcopy owrt_ origin_ explicit_ pure_ mbError_ {-# LINE 2059 "dist/build/KWOrder.hs"#-} {-# INLINE rule211 #-} {-# LINE 224 "./src-ag/KWOrder.ag" #-} rule211 = \ _rulename -> {-# LINE 224 "./src-ag/KWOrder.ag" #-} VRule _rulename {-# LINE 2065 "dist/build/KWOrder.hs"#-} {-# INLINE rule212 #-} {-# LINE 225 "./src-ag/KWOrder.ag" #-} rule212 = \ ((_patternIvertices) :: Set.Set Vertex) ((_rhsIvertices) :: Set.Set Vertex) _vertex -> {-# LINE 225 "./src-ag/KWOrder.ag" #-} Set.insert _vertex $ _patternIvertices `Set.union` _rhsIvertices {-# LINE 2071 "dist/build/KWOrder.hs"#-} {-# INLINE rule213 #-} {-# LINE 237 "./src-ag/KWOrder.ag" #-} rule213 = \ ((_rhsIvertices) :: Set.Set Vertex) _vertex -> {-# LINE 237 "./src-ag/KWOrder.ag" #-} map ((,) _vertex ) (Set.toList _rhsIvertices) {-# LINE 2077 "dist/build/KWOrder.hs"#-} {-# INLINE rule214 #-} {-# LINE 238 "./src-ag/KWOrder.ag" #-} rule214 = \ ((_patternIvertices) :: Set.Set Vertex) _vertex -> {-# LINE 238 "./src-ag/KWOrder.ag" #-} map (flip (,) _vertex ) (Set.toList _patternIvertices) {-# LINE 2083 "dist/build/KWOrder.hs"#-} {-# INLINE rule215 #-} {-# LINE 239 "./src-ag/KWOrder.ag" #-} rule215 = \ _edgesin _edgesout -> {-# LINE 239 "./src-ag/KWOrder.ag" #-} Set.fromList $ _edgesout ++ _edgesin {-# LINE 2089 "dist/build/KWOrder.hs"#-} -- Rules ------------------------------------------------------- -- wrapper data Inh_Rules = Inh_Rules { rulenumber_Inh_Rules :: (Int) } data Syn_Rules = Syn_Rules { edges_Syn_Rules :: (Set.Set Edge), erules_Syn_Rules :: (ERules), rulenumber_Syn_Rules :: (Int), vertices_Syn_Rules :: (Set.Set Vertex) } {-# INLINABLE wrap_Rules #-} wrap_Rules :: T_Rules -> Inh_Rules -> (Syn_Rules ) wrap_Rules (T_Rules act) (Inh_Rules _lhsIrulenumber) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Rules_vIn43 _lhsIrulenumber (T_Rules_vOut43 _lhsOedges _lhsOerules _lhsOrulenumber _lhsOvertices) <- return (inv_Rules_s44 sem arg) return (Syn_Rules _lhsOedges _lhsOerules _lhsOrulenumber _lhsOvertices) ) -- cata {-# NOINLINE sem_Rules #-} sem_Rules :: Rules -> T_Rules sem_Rules list = Prelude.foldr sem_Rules_Cons sem_Rules_Nil (Prelude.map sem_Rule list) -- semantic domain newtype T_Rules = T_Rules { attach_T_Rules :: Identity (T_Rules_s44 ) } newtype T_Rules_s44 = C_Rules_s44 { inv_Rules_s44 :: (T_Rules_v43 ) } data T_Rules_s45 = C_Rules_s45 type T_Rules_v43 = (T_Rules_vIn43 ) -> (T_Rules_vOut43 ) data T_Rules_vIn43 = T_Rules_vIn43 (Int) data T_Rules_vOut43 = T_Rules_vOut43 (Set.Set Edge) (ERules) (Int) (Set.Set Vertex) {-# NOINLINE sem_Rules_Cons #-} sem_Rules_Cons :: T_Rule -> T_Rules -> T_Rules sem_Rules_Cons arg_hd_ arg_tl_ = T_Rules (return st44) where {-# NOINLINE st44 #-} st44 = let v43 :: T_Rules_v43 v43 = \ (T_Rules_vIn43 _lhsIrulenumber) -> ( let _hdX41 = Control.Monad.Identity.runIdentity (attach_T_Rule (arg_hd_)) _tlX44 = Control.Monad.Identity.runIdentity (attach_T_Rules (arg_tl_)) (T_Rule_vOut40 _hdIedges _hdIerules _hdIrulenumber _hdIvertices) = inv_Rule_s41 _hdX41 (T_Rule_vIn40 _hdOrulenumber) (T_Rules_vOut43 _tlIedges _tlIerules _tlIrulenumber _tlIvertices) = inv_Rules_s44 _tlX44 (T_Rules_vIn43 _tlOrulenumber) _lhsOedges :: Set.Set Edge _lhsOedges = rule216 _hdIedges _tlIedges _lhsOerules :: ERules _lhsOerules = rule217 _hdIerules _tlIerules _lhsOvertices :: Set.Set Vertex _lhsOvertices = rule218 _hdIvertices _tlIvertices _lhsOrulenumber :: Int _lhsOrulenumber = rule219 _tlIrulenumber _hdOrulenumber = rule220 _lhsIrulenumber _tlOrulenumber = rule221 _hdIrulenumber __result_ = T_Rules_vOut43 _lhsOedges _lhsOerules _lhsOrulenumber _lhsOvertices in __result_ ) in C_Rules_s44 v43 {-# INLINE rule216 #-} rule216 = \ ((_hdIedges) :: Set.Set Edge) ((_tlIedges) :: Set.Set Edge) -> _hdIedges `Set.union` _tlIedges {-# INLINE rule217 #-} rule217 = \ ((_hdIerules) :: ERule) ((_tlIerules) :: ERules) -> _hdIerules : _tlIerules {-# INLINE rule218 #-} rule218 = \ ((_hdIvertices) :: Set.Set Vertex) ((_tlIvertices) :: Set.Set Vertex) -> _hdIvertices `Set.union` _tlIvertices {-# INLINE rule219 #-} rule219 = \ ((_tlIrulenumber) :: Int) -> _tlIrulenumber {-# INLINE rule220 #-} rule220 = \ ((_lhsIrulenumber) :: Int) -> _lhsIrulenumber {-# INLINE rule221 #-} rule221 = \ ((_hdIrulenumber) :: Int) -> _hdIrulenumber {-# NOINLINE sem_Rules_Nil #-} sem_Rules_Nil :: T_Rules sem_Rules_Nil = T_Rules (return st44) where {-# NOINLINE st44 #-} st44 = let v43 :: T_Rules_v43 v43 = \ (T_Rules_vIn43 _lhsIrulenumber) -> ( let _lhsOedges :: Set.Set Edge _lhsOedges = rule222 () _lhsOerules :: ERules _lhsOerules = rule223 () _lhsOvertices :: Set.Set Vertex _lhsOvertices = rule224 () _lhsOrulenumber :: Int _lhsOrulenumber = rule225 _lhsIrulenumber __result_ = T_Rules_vOut43 _lhsOedges _lhsOerules _lhsOrulenumber _lhsOvertices in __result_ ) in C_Rules_s44 v43 {-# INLINE rule222 #-} rule222 = \ (_ :: ()) -> Set.empty {-# INLINE rule223 #-} rule223 = \ (_ :: ()) -> [] {-# INLINE rule224 #-} rule224 = \ (_ :: ()) -> Set.empty {-# INLINE rule225 #-} rule225 = \ ((_lhsIrulenumber) :: Int) -> _lhsIrulenumber -- TypeSig ----------------------------------------------------- -- wrapper data Inh_TypeSig = Inh_TypeSig { } data Syn_TypeSig = Syn_TypeSig { localSigMap_Syn_TypeSig :: (Map Identifier Type) } {-# INLINABLE wrap_TypeSig #-} wrap_TypeSig :: T_TypeSig -> Inh_TypeSig -> (Syn_TypeSig ) wrap_TypeSig (T_TypeSig act) (Inh_TypeSig ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_TypeSig_vIn46 (T_TypeSig_vOut46 _lhsOlocalSigMap) <- return (inv_TypeSig_s47 sem arg) return (Syn_TypeSig _lhsOlocalSigMap) ) -- cata {-# INLINE sem_TypeSig #-} sem_TypeSig :: TypeSig -> T_TypeSig sem_TypeSig ( TypeSig name_ tp_ ) = sem_TypeSig_TypeSig name_ tp_ -- semantic domain newtype T_TypeSig = T_TypeSig { attach_T_TypeSig :: Identity (T_TypeSig_s47 ) } newtype T_TypeSig_s47 = C_TypeSig_s47 { inv_TypeSig_s47 :: (T_TypeSig_v46 ) } data T_TypeSig_s48 = C_TypeSig_s48 type T_TypeSig_v46 = (T_TypeSig_vIn46 ) -> (T_TypeSig_vOut46 ) data T_TypeSig_vIn46 = T_TypeSig_vIn46 data T_TypeSig_vOut46 = T_TypeSig_vOut46 (Map Identifier Type) {-# NOINLINE sem_TypeSig_TypeSig #-} sem_TypeSig_TypeSig :: (Identifier) -> (Type) -> T_TypeSig sem_TypeSig_TypeSig arg_name_ arg_tp_ = T_TypeSig (return st47) where {-# NOINLINE st47 #-} st47 = let v46 :: T_TypeSig_v46 v46 = \ (T_TypeSig_vIn46 ) -> ( let _lhsOlocalSigMap :: Map Identifier Type _lhsOlocalSigMap = rule226 arg_name_ arg_tp_ __result_ = T_TypeSig_vOut46 _lhsOlocalSigMap in __result_ ) in C_TypeSig_s47 v46 {-# INLINE rule226 #-} {-# LINE 389 "./src-ag/KWOrder.ag" #-} rule226 = \ name_ tp_ -> {-# LINE 389 "./src-ag/KWOrder.ag" #-} Map.singleton name_ tp_ {-# LINE 2241 "dist/build/KWOrder.hs"#-} -- TypeSigs ---------------------------------------------------- -- wrapper data Inh_TypeSigs = Inh_TypeSigs { } data Syn_TypeSigs = Syn_TypeSigs { localSigMap_Syn_TypeSigs :: (Map Identifier Type) } {-# INLINABLE wrap_TypeSigs #-} wrap_TypeSigs :: T_TypeSigs -> Inh_TypeSigs -> (Syn_TypeSigs ) wrap_TypeSigs (T_TypeSigs act) (Inh_TypeSigs ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_TypeSigs_vIn49 (T_TypeSigs_vOut49 _lhsOlocalSigMap) <- return (inv_TypeSigs_s50 sem arg) return (Syn_TypeSigs _lhsOlocalSigMap) ) -- cata {-# NOINLINE sem_TypeSigs #-} sem_TypeSigs :: TypeSigs -> T_TypeSigs sem_TypeSigs list = Prelude.foldr sem_TypeSigs_Cons sem_TypeSigs_Nil (Prelude.map sem_TypeSig list) -- semantic domain newtype T_TypeSigs = T_TypeSigs { attach_T_TypeSigs :: Identity (T_TypeSigs_s50 ) } newtype T_TypeSigs_s50 = C_TypeSigs_s50 { inv_TypeSigs_s50 :: (T_TypeSigs_v49 ) } data T_TypeSigs_s51 = C_TypeSigs_s51 type T_TypeSigs_v49 = (T_TypeSigs_vIn49 ) -> (T_TypeSigs_vOut49 ) data T_TypeSigs_vIn49 = T_TypeSigs_vIn49 data T_TypeSigs_vOut49 = T_TypeSigs_vOut49 (Map Identifier Type) {-# NOINLINE sem_TypeSigs_Cons #-} sem_TypeSigs_Cons :: T_TypeSig -> T_TypeSigs -> T_TypeSigs sem_TypeSigs_Cons arg_hd_ arg_tl_ = T_TypeSigs (return st50) where {-# NOINLINE st50 #-} st50 = let v49 :: T_TypeSigs_v49 v49 = \ (T_TypeSigs_vIn49 ) -> ( let _hdX47 = Control.Monad.Identity.runIdentity (attach_T_TypeSig (arg_hd_)) _tlX50 = Control.Monad.Identity.runIdentity (attach_T_TypeSigs (arg_tl_)) (T_TypeSig_vOut46 _hdIlocalSigMap) = inv_TypeSig_s47 _hdX47 (T_TypeSig_vIn46 ) (T_TypeSigs_vOut49 _tlIlocalSigMap) = inv_TypeSigs_s50 _tlX50 (T_TypeSigs_vIn49 ) _lhsOlocalSigMap :: Map Identifier Type _lhsOlocalSigMap = rule227 _hdIlocalSigMap _tlIlocalSigMap __result_ = T_TypeSigs_vOut49 _lhsOlocalSigMap in __result_ ) in C_TypeSigs_s50 v49 {-# INLINE rule227 #-} rule227 = \ ((_hdIlocalSigMap) :: Map Identifier Type) ((_tlIlocalSigMap) :: Map Identifier Type) -> _hdIlocalSigMap `Map.union` _tlIlocalSigMap {-# NOINLINE sem_TypeSigs_Nil #-} sem_TypeSigs_Nil :: T_TypeSigs sem_TypeSigs_Nil = T_TypeSigs (return st50) where {-# NOINLINE st50 #-} st50 = let v49 :: T_TypeSigs_v49 v49 = \ (T_TypeSigs_vIn49 ) -> ( let _lhsOlocalSigMap :: Map Identifier Type _lhsOlocalSigMap = rule228 () __result_ = T_TypeSigs_vOut49 _lhsOlocalSigMap in __result_ ) in C_TypeSigs_s50 v49 {-# INLINE rule228 #-} rule228 = \ (_ :: ()) -> Map.empty uuagc-0.9.42.3/src-generated/Macro.hs000644 000765 000024 00000003050 12127045231 021164 0ustar00jeroenbransenstaff000000 000000 -- UUAGC 0.9.42.3 (src-ag/Macro.ag) module Macro where {-# LINE 4 "./src-ag/Macro.ag" #-} import CommonTypes {-# LINE 9 "dist/build/Macro.hs" #-} -- Macro ------------------------------------------------------- {- alternatives: alternative Macro: child con : {ConstructorIdent} child children : MacroChildren alternative None: -} data Macro = Macro (ConstructorIdent) (MacroChildren) | None deriving ( Show) -- MacroChild -------------------------------------------------- {- alternatives: alternative RuleChild: child name : {Identifier} child macro : Macro alternative ChildChild: child name : {Identifier} child child : {Identifier} alternative ValueChild: child name : {Identifier} child value : {String} -} data MacroChild = RuleChild (Identifier) (Macro) | ChildChild (Identifier) (Identifier) | ValueChild (Identifier) (String) deriving ( Show) -- MacroChildren ----------------------------------------------- {- alternatives: alternative Cons: child hd : MacroChild child tl : MacroChildren alternative Nil: -} type MacroChildren = [MacroChild] -- MaybeMacro -------------------------------------------------- {- alternatives: alternative Just: child just : Macro alternative Nothing: -} type MaybeMacro = Maybe Macrouuagc-0.9.42.3/src-generated/Order.hs000644 000765 000024 00000616620 12127045231 021213 0ustar00jeroenbransenstaff000000 000000 {-# LANGUAGE Rank2Types, GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} module Order where {-# LINE 2 "./src-ag/Patterns.ag" #-} -- Patterns.ag imports import UU.Scanner.Position(Pos) import CommonTypes (ConstructorIdent,Identifier) {-# LINE 11 "dist/build/Order.hs" #-} {-# LINE 2 "./src-ag/Expression.ag" #-} import UU.Scanner.Position(Pos) import HsToken {-# LINE 17 "dist/build/Order.hs" #-} {-# LINE 2 "./src-ag/AbstractSyntax.ag" #-} -- 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 {-# LINE 29 "dist/build/Order.hs" #-} {-# LINE 10 "./src-ag/Order.ag" #-} -- 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 HsTokenScanner(lexTokens) 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 {-# LINE 67 "dist/build/Order.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 47 "./src-ag/Order.ag" #-} -- 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 {-# LINE 80 "dist/build/Order.hs" #-} {-# LINE 72 "./src-ag/Order.ag" #-} startsWith :: String -> String -> Bool startsWith k h = k == take (length k) h {-# LINE 86 "dist/build/Order.hs" #-} {-# LINE 139 "./src-ag/Order.ag" #-} getNtName :: Type -> NontermIdent getNtName (NT nt _ _) = nt getNtName _ = nullIdent {-# LINE 93 "dist/build/Order.hs" #-} {-# LINE 167 "./src-ag/Order.ag" #-} data AltAttr = AltAttr Identifier Identifier Bool deriving (Eq, Ord, Show) {-# LINE 99 "dist/build/Order.hs" #-} {-# LINE 237 "./src-ag/Order.ag" #-} 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))) ++ ")" )) {-# LINE 110 "dist/build/Order.hs" #-} {-# LINE 688 "./src-ag/Order.ag" #-} 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 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) {-# LINE 230 "dist/build/Order.hs" #-} -- Child ------------------------------------------------------- -- wrapper data Inh_Child = Inh_Child { allfields_Inh_Child :: ([(Identifier,Type,ChildKind)]), allnts_Inh_Child :: ([Identifier]), attrs_Inh_Child :: ([(Identifier,Identifier)]), con_Inh_Child :: (Identifier), inh_Inh_Child :: (Attributes), inhMap_Inh_Child :: (Map Identifier Attributes), mergeMap_Inh_Child :: (Map Identifier (Identifier,[Identifier])), nt_Inh_Child :: (Identifier), o_unbox_Inh_Child :: (Bool), syn_Inh_Child :: (Attributes), synMap_Inh_Child :: (Map Identifier Attributes) } data Syn_Child = Syn_Child { attributes_Syn_Child :: ([(Identifier,Attributes,Attributes)]), collectChildrenInhs_Syn_Child :: (Map Identifier Attributes ), collectChildrenSyns_Syn_Child :: (Map Identifier Attributes ), errors_Syn_Child :: (Seq Error), field_Syn_Child :: ((Identifier,Type,ChildKind)), gathAltAttrs_Syn_Child :: ([AltAttr]), gathRules_Syn_Child :: (Seq CRule), inhs_Syn_Child :: (Seq (Identifier,Attributes)), nts_Syn_Child :: (Seq (Identifier,NontermIdent)), singlevisits_Syn_Child :: ([CRule]), terminals_Syn_Child :: ([Identifier]) } {-# INLINABLE wrap_Child #-} wrap_Child :: T_Child -> Inh_Child -> (Syn_Child ) wrap_Child (T_Child act) (Inh_Child _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIo_unbox _lhsIsyn _lhsIsynMap) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Child_vIn1 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIo_unbox _lhsIsyn _lhsIsynMap (T_Child_vOut1 _lhsOattributes _lhsOcollectChildrenInhs _lhsOcollectChildrenSyns _lhsOerrors _lhsOfield _lhsOgathAltAttrs _lhsOgathRules _lhsOinhs _lhsOnts _lhsOsinglevisits _lhsOterminals) <- return (inv_Child_s2 sem arg) return (Syn_Child _lhsOattributes _lhsOcollectChildrenInhs _lhsOcollectChildrenSyns _lhsOerrors _lhsOfield _lhsOgathAltAttrs _lhsOgathRules _lhsOinhs _lhsOnts _lhsOsinglevisits _lhsOterminals) ) -- cata {-# INLINE sem_Child #-} sem_Child :: Child -> T_Child sem_Child ( Child name_ tp_ kind_ ) = sem_Child_Child name_ tp_ kind_ -- semantic domain newtype T_Child = T_Child { attach_T_Child :: Identity (T_Child_s2 ) } newtype T_Child_s2 = C_Child_s2 { inv_Child_s2 :: (T_Child_v1 ) } data T_Child_s3 = C_Child_s3 type T_Child_v1 = (T_Child_vIn1 ) -> (T_Child_vOut1 ) data T_Child_vIn1 = T_Child_vIn1 ([(Identifier,Type,ChildKind)]) ([Identifier]) ([(Identifier,Identifier)]) (Identifier) (Attributes) (Map Identifier Attributes) (Map Identifier (Identifier,[Identifier])) (Identifier) (Bool) (Attributes) (Map Identifier Attributes) data T_Child_vOut1 = T_Child_vOut1 ([(Identifier,Attributes,Attributes)]) (Map Identifier Attributes ) (Map Identifier Attributes ) (Seq Error) ((Identifier,Type,ChildKind)) ([AltAttr]) (Seq CRule) (Seq (Identifier,Attributes)) (Seq (Identifier,NontermIdent)) ([CRule]) ([Identifier]) {-# NOINLINE sem_Child_Child #-} sem_Child_Child :: (Identifier) -> (Type) -> (ChildKind) -> T_Child sem_Child_Child arg_name_ arg_tp_ arg_kind_ = T_Child (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Child_v1 v1 = \ (T_Child_vIn1 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIo_unbox _lhsIsyn _lhsIsynMap) -> ( let _chnt = rule0 arg_name_ arg_tp_ _inh = rule1 _chnt _lhsIinhMap _syn = rule2 _chnt _lhsIsynMap _maptolocal = rule3 _syn arg_tp_ _lhsOgathAltAttrs :: [AltAttr] _lhsOgathAltAttrs = rule4 _maptolocal _syn arg_name_ _lhsOnts :: Seq (Identifier,NontermIdent) _lhsOnts = rule5 arg_name_ arg_tp_ _lhsOinhs :: Seq (Identifier,Attributes) _lhsOinhs = rule6 _inh arg_name_ _gathRules = rule7 _lhsIcon _lhsInt _maptolocal _syn arg_name_ arg_tp_ _lhsOcollectChildrenSyns :: Map Identifier Attributes _lhsOcollectChildrenSyns = rule8 _syn arg_name_ _lhsOcollectChildrenInhs :: Map Identifier Attributes _lhsOcollectChildrenInhs = rule9 _inh arg_name_ _lhsOsinglevisits :: [CRule] _lhsOsinglevisits = rule10 _inh _maptolocal _syn arg_name_ arg_tp_ _lhsOterminals :: [Identifier] _lhsOterminals = rule11 _maptolocal arg_name_ _lhsOattributes :: [(Identifier,Attributes,Attributes)] _lhsOattributes = rule12 _inh _syn arg_name_ _lhsOfield :: (Identifier,Type,ChildKind) _lhsOfield = rule13 arg_kind_ arg_name_ arg_tp_ _lhsOerrors :: Seq Error _lhsOerrors = rule14 () _lhsOgathRules :: Seq CRule _lhsOgathRules = rule15 _gathRules __result_ = T_Child_vOut1 _lhsOattributes _lhsOcollectChildrenInhs _lhsOcollectChildrenSyns _lhsOerrors _lhsOfield _lhsOgathAltAttrs _lhsOgathRules _lhsOinhs _lhsOnts _lhsOsinglevisits _lhsOterminals in __result_ ) in C_Child_s2 v1 {-# INLINE rule0 #-} {-# LINE 19 "./src-ag/DistChildAttr.ag" #-} rule0 = \ name_ tp_ -> {-# LINE 19 "./src-ag/DistChildAttr.ag" #-} case tp_ of NT nt _ _ -> nt Self -> error ("The type of child " ++ show name_ ++ " should not be a Self type.") Haskell t -> identifier "" {-# LINE 306 "dist/build/Order.hs"#-} {-# INLINE rule1 #-} {-# LINE 23 "./src-ag/DistChildAttr.ag" #-} rule1 = \ _chnt ((_lhsIinhMap) :: Map Identifier Attributes) -> {-# LINE 23 "./src-ag/DistChildAttr.ag" #-} Map.findWithDefault Map.empty _chnt _lhsIinhMap {-# LINE 312 "dist/build/Order.hs"#-} {-# INLINE rule2 #-} {-# LINE 24 "./src-ag/DistChildAttr.ag" #-} rule2 = \ _chnt ((_lhsIsynMap) :: Map Identifier Attributes) -> {-# LINE 24 "./src-ag/DistChildAttr.ag" #-} Map.findWithDefault Map.empty _chnt _lhsIsynMap {-# LINE 318 "dist/build/Order.hs"#-} {-# INLINE rule3 #-} {-# LINE 178 "./src-ag/Order.ag" #-} rule3 = \ _syn tp_ -> {-# LINE 178 "./src-ag/Order.ag" #-} case tp_ of NT nt _ _ -> Map.null _syn _ -> True {-# LINE 326 "dist/build/Order.hs"#-} {-# INLINE rule4 #-} {-# LINE 181 "./src-ag/Order.ag" #-} rule4 = \ _maptolocal _syn name_ -> {-# LINE 181 "./src-ag/Order.ag" #-} if _maptolocal then [ AltAttr _LOC name_ True ] else [ AltAttr name_ syn True | syn <- Map.keys _syn ] {-# LINE 334 "dist/build/Order.hs"#-} {-# INLINE rule5 #-} {-# LINE 196 "./src-ag/Order.ag" #-} rule5 = \ name_ tp_ -> {-# LINE 196 "./src-ag/Order.ag" #-} Seq.singleton (name_,getNtName tp_) {-# LINE 340 "dist/build/Order.hs"#-} {-# INLINE rule6 #-} {-# LINE 197 "./src-ag/Order.ag" #-} rule6 = \ _inh name_ -> {-# LINE 197 "./src-ag/Order.ag" #-} Seq.singleton (name_,_inh ) {-# LINE 346 "dist/build/Order.hs"#-} {-# INLINE rule7 #-} {-# LINE 213 "./src-ag/Order.ag" #-} rule7 = \ ((_lhsIcon) :: Identifier) ((_lhsInt) :: Identifier) _maptolocal _syn name_ tp_ -> {-# LINE 213 "./src-ag/Order.ag" #-} if _maptolocal then Seq.singleton (cRuleTerminal name_ _lhsInt _lhsIcon tp_) else Seq.fromList [ cRuleRhsSyn syn _lhsInt _lhsIcon tp name_ (getNtName tp_) | (syn,tp) <- Map.assocs _syn ] {-# LINE 354 "dist/build/Order.hs"#-} {-# INLINE rule8 #-} {-# LINE 345 "./src-ag/Order.ag" #-} rule8 = \ _syn name_ -> {-# LINE 345 "./src-ag/Order.ag" #-} Map.singleton name_ _syn {-# LINE 360 "dist/build/Order.hs"#-} {-# INLINE rule9 #-} {-# LINE 346 "./src-ag/Order.ag" #-} rule9 = \ _inh name_ -> {-# LINE 346 "./src-ag/Order.ag" #-} Map.singleton name_ _inh {-# LINE 366 "dist/build/Order.hs"#-} {-# INLINE rule10 #-} {-# LINE 614 "./src-ag/Order.ag" #-} rule10 = \ _inh _maptolocal _syn name_ tp_ -> {-# LINE 614 "./src-ag/Order.ag" #-} if _maptolocal then [] else [CChildVisit name_ (getNtName tp_) 0 _inh _syn True] {-# LINE 374 "dist/build/Order.hs"#-} {-# INLINE rule11 #-} {-# LINE 639 "./src-ag/Order.ag" #-} rule11 = \ _maptolocal name_ -> {-# LINE 639 "./src-ag/Order.ag" #-} if _maptolocal then [name_] else [] {-# LINE 382 "dist/build/Order.hs"#-} {-# INLINE rule12 #-} {-# LINE 668 "./src-ag/Order.ag" #-} rule12 = \ _inh _syn name_ -> {-# LINE 668 "./src-ag/Order.ag" #-} [(name_, _inh , _syn )] {-# LINE 388 "dist/build/Order.hs"#-} {-# INLINE rule13 #-} {-# LINE 672 "./src-ag/Order.ag" #-} rule13 = \ kind_ name_ tp_ -> {-# LINE 672 "./src-ag/Order.ag" #-} (name_, tp_, kind_) {-# LINE 394 "dist/build/Order.hs"#-} {-# INLINE rule14 #-} rule14 = \ (_ :: ()) -> Seq.empty {-# INLINE rule15 #-} rule15 = \ _gathRules -> _gathRules -- Children ---------------------------------------------------- -- wrapper data Inh_Children = Inh_Children { allfields_Inh_Children :: ([(Identifier,Type,ChildKind)]), allnts_Inh_Children :: ([Identifier]), attrs_Inh_Children :: ([(Identifier,Identifier)]), con_Inh_Children :: (Identifier), inh_Inh_Children :: (Attributes), inhMap_Inh_Children :: (Map Identifier Attributes), mergeMap_Inh_Children :: (Map Identifier (Identifier,[Identifier])), nt_Inh_Children :: (Identifier), o_unbox_Inh_Children :: (Bool), syn_Inh_Children :: (Attributes), synMap_Inh_Children :: (Map Identifier Attributes) } data Syn_Children = Syn_Children { attributes_Syn_Children :: ([(Identifier,Attributes,Attributes)]), collectChildrenInhs_Syn_Children :: (Map Identifier Attributes ), collectChildrenSyns_Syn_Children :: (Map Identifier Attributes ), errors_Syn_Children :: (Seq Error), fields_Syn_Children :: ([(Identifier,Type,ChildKind)]), gathAltAttrs_Syn_Children :: ([AltAttr]), gathRules_Syn_Children :: (Seq CRule), inhs_Syn_Children :: (Seq (Identifier,Attributes)), nts_Syn_Children :: (Seq (Identifier,NontermIdent)), singlevisits_Syn_Children :: ([CRule]), terminals_Syn_Children :: ([Identifier]) } {-# INLINABLE wrap_Children #-} wrap_Children :: T_Children -> Inh_Children -> (Syn_Children ) wrap_Children (T_Children act) (Inh_Children _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIo_unbox _lhsIsyn _lhsIsynMap) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Children_vIn4 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIo_unbox _lhsIsyn _lhsIsynMap (T_Children_vOut4 _lhsOattributes _lhsOcollectChildrenInhs _lhsOcollectChildrenSyns _lhsOerrors _lhsOfields _lhsOgathAltAttrs _lhsOgathRules _lhsOinhs _lhsOnts _lhsOsinglevisits _lhsOterminals) <- return (inv_Children_s5 sem arg) return (Syn_Children _lhsOattributes _lhsOcollectChildrenInhs _lhsOcollectChildrenSyns _lhsOerrors _lhsOfields _lhsOgathAltAttrs _lhsOgathRules _lhsOinhs _lhsOnts _lhsOsinglevisits _lhsOterminals) ) -- cata {-# NOINLINE sem_Children #-} sem_Children :: Children -> T_Children sem_Children list = Prelude.foldr sem_Children_Cons sem_Children_Nil (Prelude.map sem_Child list) -- semantic domain newtype T_Children = T_Children { attach_T_Children :: Identity (T_Children_s5 ) } newtype T_Children_s5 = C_Children_s5 { inv_Children_s5 :: (T_Children_v4 ) } data T_Children_s6 = C_Children_s6 type T_Children_v4 = (T_Children_vIn4 ) -> (T_Children_vOut4 ) data T_Children_vIn4 = T_Children_vIn4 ([(Identifier,Type,ChildKind)]) ([Identifier]) ([(Identifier,Identifier)]) (Identifier) (Attributes) (Map Identifier Attributes) (Map Identifier (Identifier,[Identifier])) (Identifier) (Bool) (Attributes) (Map Identifier Attributes) data T_Children_vOut4 = T_Children_vOut4 ([(Identifier,Attributes,Attributes)]) (Map Identifier Attributes ) (Map Identifier Attributes ) (Seq Error) ([(Identifier,Type,ChildKind)]) ([AltAttr]) (Seq CRule) (Seq (Identifier,Attributes)) (Seq (Identifier,NontermIdent)) ([CRule]) ([Identifier]) {-# NOINLINE sem_Children_Cons #-} sem_Children_Cons :: T_Child -> T_Children -> T_Children sem_Children_Cons arg_hd_ arg_tl_ = T_Children (return st5) where {-# NOINLINE st5 #-} st5 = let v4 :: T_Children_v4 v4 = \ (T_Children_vIn4 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIo_unbox _lhsIsyn _lhsIsynMap) -> ( let _hdX2 = Control.Monad.Identity.runIdentity (attach_T_Child (arg_hd_)) _tlX5 = Control.Monad.Identity.runIdentity (attach_T_Children (arg_tl_)) (T_Child_vOut1 _hdIattributes _hdIcollectChildrenInhs _hdIcollectChildrenSyns _hdIerrors _hdIfield _hdIgathAltAttrs _hdIgathRules _hdIinhs _hdInts _hdIsinglevisits _hdIterminals) = inv_Child_s2 _hdX2 (T_Child_vIn1 _hdOallfields _hdOallnts _hdOattrs _hdOcon _hdOinh _hdOinhMap _hdOmergeMap _hdOnt _hdOo_unbox _hdOsyn _hdOsynMap) (T_Children_vOut4 _tlIattributes _tlIcollectChildrenInhs _tlIcollectChildrenSyns _tlIerrors _tlIfields _tlIgathAltAttrs _tlIgathRules _tlIinhs _tlInts _tlIsinglevisits _tlIterminals) = inv_Children_s5 _tlX5 (T_Children_vIn4 _tlOallfields _tlOallnts _tlOattrs _tlOcon _tlOinh _tlOinhMap _tlOmergeMap _tlOnt _tlOo_unbox _tlOsyn _tlOsynMap) _lhsOfields :: [(Identifier,Type,ChildKind)] _lhsOfields = rule16 _hdIfield _tlIfields _lhsOattributes :: [(Identifier,Attributes,Attributes)] _lhsOattributes = rule17 _hdIattributes _tlIattributes _lhsOcollectChildrenInhs :: Map Identifier Attributes _lhsOcollectChildrenInhs = rule18 _hdIcollectChildrenInhs _tlIcollectChildrenInhs _lhsOcollectChildrenSyns :: Map Identifier Attributes _lhsOcollectChildrenSyns = rule19 _hdIcollectChildrenSyns _tlIcollectChildrenSyns _lhsOerrors :: Seq Error _lhsOerrors = rule20 _hdIerrors _tlIerrors _lhsOgathAltAttrs :: [AltAttr] _lhsOgathAltAttrs = rule21 _hdIgathAltAttrs _tlIgathAltAttrs _lhsOgathRules :: Seq CRule _lhsOgathRules = rule22 _hdIgathRules _tlIgathRules _lhsOinhs :: Seq (Identifier,Attributes) _lhsOinhs = rule23 _hdIinhs _tlIinhs _lhsOnts :: Seq (Identifier,NontermIdent) _lhsOnts = rule24 _hdInts _tlInts _lhsOsinglevisits :: [CRule] _lhsOsinglevisits = rule25 _hdIsinglevisits _tlIsinglevisits _lhsOterminals :: [Identifier] _lhsOterminals = rule26 _hdIterminals _tlIterminals _hdOallfields = rule27 _lhsIallfields _hdOallnts = rule28 _lhsIallnts _hdOattrs = rule29 _lhsIattrs _hdOcon = rule30 _lhsIcon _hdOinh = rule31 _lhsIinh _hdOinhMap = rule32 _lhsIinhMap _hdOmergeMap = rule33 _lhsImergeMap _hdOnt = rule34 _lhsInt _hdOo_unbox = rule35 _lhsIo_unbox _hdOsyn = rule36 _lhsIsyn _hdOsynMap = rule37 _lhsIsynMap _tlOallfields = rule38 _lhsIallfields _tlOallnts = rule39 _lhsIallnts _tlOattrs = rule40 _lhsIattrs _tlOcon = rule41 _lhsIcon _tlOinh = rule42 _lhsIinh _tlOinhMap = rule43 _lhsIinhMap _tlOmergeMap = rule44 _lhsImergeMap _tlOnt = rule45 _lhsInt _tlOo_unbox = rule46 _lhsIo_unbox _tlOsyn = rule47 _lhsIsyn _tlOsynMap = rule48 _lhsIsynMap __result_ = T_Children_vOut4 _lhsOattributes _lhsOcollectChildrenInhs _lhsOcollectChildrenSyns _lhsOerrors _lhsOfields _lhsOgathAltAttrs _lhsOgathRules _lhsOinhs _lhsOnts _lhsOsinglevisits _lhsOterminals in __result_ ) in C_Children_s5 v4 {-# INLINE rule16 #-} {-# LINE 675 "./src-ag/Order.ag" #-} rule16 = \ ((_hdIfield) :: (Identifier,Type,ChildKind)) ((_tlIfields) :: [(Identifier,Type,ChildKind)]) -> {-# LINE 675 "./src-ag/Order.ag" #-} _hdIfield : _tlIfields {-# LINE 495 "dist/build/Order.hs"#-} {-# INLINE rule17 #-} rule17 = \ ((_hdIattributes) :: [(Identifier,Attributes,Attributes)]) ((_tlIattributes) :: [(Identifier,Attributes,Attributes)]) -> _hdIattributes ++ _tlIattributes {-# INLINE rule18 #-} rule18 = \ ((_hdIcollectChildrenInhs) :: Map Identifier Attributes ) ((_tlIcollectChildrenInhs) :: Map Identifier Attributes ) -> _hdIcollectChildrenInhs `Map.union` _tlIcollectChildrenInhs {-# INLINE rule19 #-} rule19 = \ ((_hdIcollectChildrenSyns) :: Map Identifier Attributes ) ((_tlIcollectChildrenSyns) :: Map Identifier Attributes ) -> _hdIcollectChildrenSyns `Map.union` _tlIcollectChildrenSyns {-# INLINE rule20 #-} rule20 = \ ((_hdIerrors) :: Seq Error) ((_tlIerrors) :: Seq Error) -> _hdIerrors Seq.>< _tlIerrors {-# INLINE rule21 #-} rule21 = \ ((_hdIgathAltAttrs) :: [AltAttr]) ((_tlIgathAltAttrs) :: [AltAttr]) -> _hdIgathAltAttrs ++ _tlIgathAltAttrs {-# INLINE rule22 #-} rule22 = \ ((_hdIgathRules) :: Seq CRule) ((_tlIgathRules) :: Seq CRule) -> _hdIgathRules Seq.>< _tlIgathRules {-# INLINE rule23 #-} rule23 = \ ((_hdIinhs) :: Seq (Identifier,Attributes)) ((_tlIinhs) :: Seq (Identifier,Attributes)) -> _hdIinhs Seq.>< _tlIinhs {-# INLINE rule24 #-} rule24 = \ ((_hdInts) :: Seq (Identifier,NontermIdent)) ((_tlInts) :: Seq (Identifier,NontermIdent)) -> _hdInts Seq.>< _tlInts {-# INLINE rule25 #-} rule25 = \ ((_hdIsinglevisits) :: [CRule]) ((_tlIsinglevisits) :: [CRule]) -> _hdIsinglevisits ++ _tlIsinglevisits {-# INLINE rule26 #-} rule26 = \ ((_hdIterminals) :: [Identifier]) ((_tlIterminals) :: [Identifier]) -> _hdIterminals ++ _tlIterminals {-# INLINE rule27 #-} rule27 = \ ((_lhsIallfields) :: [(Identifier,Type,ChildKind)]) -> _lhsIallfields {-# INLINE rule28 #-} rule28 = \ ((_lhsIallnts) :: [Identifier]) -> _lhsIallnts {-# INLINE rule29 #-} rule29 = \ ((_lhsIattrs) :: [(Identifier,Identifier)]) -> _lhsIattrs {-# INLINE rule30 #-} rule30 = \ ((_lhsIcon) :: Identifier) -> _lhsIcon {-# INLINE rule31 #-} rule31 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule32 #-} rule32 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule33 #-} rule33 = \ ((_lhsImergeMap) :: Map Identifier (Identifier,[Identifier])) -> _lhsImergeMap {-# INLINE rule34 #-} rule34 = \ ((_lhsInt) :: Identifier) -> _lhsInt {-# INLINE rule35 #-} rule35 = \ ((_lhsIo_unbox) :: Bool) -> _lhsIo_unbox {-# INLINE rule36 #-} rule36 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# INLINE rule37 #-} rule37 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# INLINE rule38 #-} rule38 = \ ((_lhsIallfields) :: [(Identifier,Type,ChildKind)]) -> _lhsIallfields {-# INLINE rule39 #-} rule39 = \ ((_lhsIallnts) :: [Identifier]) -> _lhsIallnts {-# INLINE rule40 #-} rule40 = \ ((_lhsIattrs) :: [(Identifier,Identifier)]) -> _lhsIattrs {-# INLINE rule41 #-} rule41 = \ ((_lhsIcon) :: Identifier) -> _lhsIcon {-# INLINE rule42 #-} rule42 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule43 #-} rule43 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule44 #-} rule44 = \ ((_lhsImergeMap) :: Map Identifier (Identifier,[Identifier])) -> _lhsImergeMap {-# INLINE rule45 #-} rule45 = \ ((_lhsInt) :: Identifier) -> _lhsInt {-# INLINE rule46 #-} rule46 = \ ((_lhsIo_unbox) :: Bool) -> _lhsIo_unbox {-# INLINE rule47 #-} rule47 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# INLINE rule48 #-} rule48 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# NOINLINE sem_Children_Nil #-} sem_Children_Nil :: T_Children sem_Children_Nil = T_Children (return st5) where {-# NOINLINE st5 #-} st5 = let v4 :: T_Children_v4 v4 = \ (T_Children_vIn4 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIo_unbox _lhsIsyn _lhsIsynMap) -> ( let _lhsOfields :: [(Identifier,Type,ChildKind)] _lhsOfields = rule49 () _lhsOattributes :: [(Identifier,Attributes,Attributes)] _lhsOattributes = rule50 () _lhsOcollectChildrenInhs :: Map Identifier Attributes _lhsOcollectChildrenInhs = rule51 () _lhsOcollectChildrenSyns :: Map Identifier Attributes _lhsOcollectChildrenSyns = rule52 () _lhsOerrors :: Seq Error _lhsOerrors = rule53 () _lhsOgathAltAttrs :: [AltAttr] _lhsOgathAltAttrs = rule54 () _lhsOgathRules :: Seq CRule _lhsOgathRules = rule55 () _lhsOinhs :: Seq (Identifier,Attributes) _lhsOinhs = rule56 () _lhsOnts :: Seq (Identifier,NontermIdent) _lhsOnts = rule57 () _lhsOsinglevisits :: [CRule] _lhsOsinglevisits = rule58 () _lhsOterminals :: [Identifier] _lhsOterminals = rule59 () __result_ = T_Children_vOut4 _lhsOattributes _lhsOcollectChildrenInhs _lhsOcollectChildrenSyns _lhsOerrors _lhsOfields _lhsOgathAltAttrs _lhsOgathRules _lhsOinhs _lhsOnts _lhsOsinglevisits _lhsOterminals in __result_ ) in C_Children_s5 v4 {-# INLINE rule49 #-} {-# LINE 676 "./src-ag/Order.ag" #-} rule49 = \ (_ :: ()) -> {-# LINE 676 "./src-ag/Order.ag" #-} [] {-# LINE 629 "dist/build/Order.hs"#-} {-# INLINE rule50 #-} rule50 = \ (_ :: ()) -> [] {-# INLINE rule51 #-} rule51 = \ (_ :: ()) -> Map.empty {-# INLINE rule52 #-} rule52 = \ (_ :: ()) -> Map.empty {-# INLINE rule53 #-} rule53 = \ (_ :: ()) -> Seq.empty {-# INLINE rule54 #-} rule54 = \ (_ :: ()) -> [] {-# INLINE rule55 #-} rule55 = \ (_ :: ()) -> Seq.empty {-# INLINE rule56 #-} rule56 = \ (_ :: ()) -> Seq.empty {-# INLINE rule57 #-} rule57 = \ (_ :: ()) -> Seq.empty {-# INLINE rule58 #-} rule58 = \ (_ :: ()) -> [] {-# INLINE rule59 #-} rule59 = \ (_ :: ()) -> [] -- Expression -------------------------------------------------- -- wrapper data Inh_Expression = Inh_Expression { allfields_Inh_Expression :: ([(Identifier,Type,ChildKind)]), allnts_Inh_Expression :: ([Identifier]), attrs_Inh_Expression :: ([(Identifier,Identifier)]), con_Inh_Expression :: (Identifier), mergeMap_Inh_Expression :: (Map Identifier (Identifier,[Identifier])), nt_Inh_Expression :: (Identifier) } data Syn_Expression = Syn_Expression { allRhsVars_Syn_Expression :: (Set (Identifier,Identifier)), copy_Syn_Expression :: (Expression), errors_Syn_Expression :: (Seq Error), textLines_Syn_Expression :: ([String]), usedAttrs_Syn_Expression :: ([(Identifier,Identifier)]), usedFields_Syn_Expression :: ([Identifier]), usedLocals_Syn_Expression :: ([Identifier]) } {-# INLINABLE wrap_Expression #-} wrap_Expression :: T_Expression -> Inh_Expression -> (Syn_Expression ) wrap_Expression (T_Expression act) (Inh_Expression _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsImergeMap _lhsInt) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Expression_vIn7 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsImergeMap _lhsInt (T_Expression_vOut7 _lhsOallRhsVars _lhsOcopy _lhsOerrors _lhsOtextLines _lhsOusedAttrs _lhsOusedFields _lhsOusedLocals) <- return (inv_Expression_s8 sem arg) return (Syn_Expression _lhsOallRhsVars _lhsOcopy _lhsOerrors _lhsOtextLines _lhsOusedAttrs _lhsOusedFields _lhsOusedLocals) ) -- cata {-# INLINE sem_Expression #-} sem_Expression :: Expression -> T_Expression sem_Expression ( Expression pos_ tks_ ) = sem_Expression_Expression pos_ tks_ -- semantic domain newtype T_Expression = T_Expression { attach_T_Expression :: Identity (T_Expression_s8 ) } newtype T_Expression_s8 = C_Expression_s8 { inv_Expression_s8 :: (T_Expression_v7 ) } data T_Expression_s9 = C_Expression_s9 type T_Expression_v7 = (T_Expression_vIn7 ) -> (T_Expression_vOut7 ) data T_Expression_vIn7 = T_Expression_vIn7 ([(Identifier,Type,ChildKind)]) ([Identifier]) ([(Identifier,Identifier)]) (Identifier) (Map Identifier (Identifier,[Identifier])) (Identifier) data T_Expression_vOut7 = T_Expression_vOut7 (Set (Identifier,Identifier)) (Expression) (Seq Error) ([String]) ([(Identifier,Identifier)]) ([Identifier]) ([Identifier]) {-# NOINLINE sem_Expression_Expression #-} sem_Expression_Expression :: (Pos) -> ([HsToken]) -> T_Expression sem_Expression_Expression arg_pos_ arg_tks_ = T_Expression (return st8) where {-# NOINLINE st8 #-} st8 = let v7 :: T_Expression_v7 v7 = \ (T_Expression_vIn7 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsImergeMap _lhsInt) -> ( let (_textLines,_usedAttrs,_usedLocals,_usedFields) = rule60 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsImergeMap _lhsInt arg_tks_ _lhsOerrors :: Seq Error _lhsOerrors = rule61 () _lhsOallRhsVars :: Set (Identifier,Identifier) _lhsOallRhsVars = rule62 _usedAttrs _usedFields _usedLocals _copy = rule63 arg_pos_ arg_tks_ _lhsOcopy :: Expression _lhsOcopy = rule64 _copy _lhsOtextLines :: [String] _lhsOtextLines = rule65 _textLines _lhsOusedAttrs :: [(Identifier,Identifier)] _lhsOusedAttrs = rule66 _usedAttrs _lhsOusedFields :: [Identifier] _lhsOusedFields = rule67 _usedFields _lhsOusedLocals :: [Identifier] _lhsOusedLocals = rule68 _usedLocals __result_ = T_Expression_vOut7 _lhsOallRhsVars _lhsOcopy _lhsOerrors _lhsOtextLines _lhsOusedAttrs _lhsOusedFields _lhsOusedLocals in __result_ ) in C_Expression_s8 v7 {-# INLINE rule60 #-} {-# LINE 466 "./src-ag/Order.ag" #-} rule60 = \ ((_lhsIallfields) :: [(Identifier,Type,ChildKind)]) ((_lhsIallnts) :: [Identifier]) ((_lhsIattrs) :: [(Identifier,Identifier)]) ((_lhsIcon) :: Identifier) ((_lhsImergeMap) :: Map Identifier (Identifier,[Identifier])) ((_lhsInt) :: Identifier) tks_ -> {-# LINE 466 "./src-ag/Order.ag" #-} let mergedChildren = [ x | (_,xs) <- Map.elems _lhsImergeMap, x <- xs ] attrsIn = filter (\(fld,_) -> not (fld `elem` mergedChildren)) _lhsIattrs inherited = Inh_HsTokensRoot { attrs_Inh_HsTokensRoot = attrsIn , con_Inh_HsTokensRoot = _lhsIcon , allfields_Inh_HsTokensRoot = _lhsIallfields , allnts_Inh_HsTokensRoot = _lhsIallnts , nt_Inh_HsTokensRoot = _lhsInt } 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 _lhsImergeMap, isJust mbMerged , let (Just (_, srcs)) = mbMerged, src <- srcs ] usedAttrs' = usedAttrs ++ extraAttrs in (textLines,usedAttrs',usedLocals,usedFields) {-# LINE 742 "dist/build/Order.hs"#-} {-# INLINE rule61 #-} {-# LINE 488 "./src-ag/Order.ag" #-} rule61 = \ (_ :: ()) -> {-# LINE 488 "./src-ag/Order.ag" #-} Seq.empty {-# LINE 748 "dist/build/Order.hs"#-} {-# INLINE rule62 #-} {-# LINE 489 "./src-ag/Order.ag" #-} rule62 = \ _usedAttrs _usedFields _usedLocals -> {-# LINE 489 "./src-ag/Order.ag" #-} Set.fromList _usedAttrs `Set.union` Set.fromList [ (_LOC, l) | l <- _usedLocals ] `Set.union` Set.fromList [ (_FIELD, fld) | fld <- _usedFields ] {-# LINE 758 "dist/build/Order.hs"#-} {-# INLINE rule63 #-} rule63 = \ pos_ tks_ -> Expression pos_ tks_ {-# INLINE rule64 #-} rule64 = \ _copy -> _copy {-# INLINE rule65 #-} rule65 = \ _textLines -> _textLines {-# INLINE rule66 #-} rule66 = \ _usedAttrs -> _usedAttrs {-# INLINE rule67 #-} rule67 = \ _usedFields -> _usedFields {-# INLINE rule68 #-} rule68 = \ _usedLocals -> _usedLocals -- Grammar ----------------------------------------------------- -- wrapper data Inh_Grammar = Inh_Grammar { options_Inh_Grammar :: (Options) } data Syn_Grammar = Syn_Grammar { errors_Syn_Grammar :: (Seq Error), nAutoRules_Syn_Grammar :: (Int), nExplicitRules_Syn_Grammar :: (Int), output_Syn_Grammar :: (CGrammar) } {-# INLINABLE wrap_Grammar #-} wrap_Grammar :: T_Grammar -> Inh_Grammar -> (Syn_Grammar ) wrap_Grammar (T_Grammar act) (Inh_Grammar _lhsIoptions) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Grammar_vIn10 _lhsIoptions (T_Grammar_vOut10 _lhsOerrors _lhsOnAutoRules _lhsOnExplicitRules _lhsOoutput) <- return (inv_Grammar_s11 sem arg) return (Syn_Grammar _lhsOerrors _lhsOnAutoRules _lhsOnExplicitRules _lhsOoutput) ) -- cata {-# INLINE sem_Grammar #-} sem_Grammar :: Grammar -> T_Grammar sem_Grammar ( Grammar typeSyns_ useMap_ derivings_ wrappers_ nonts_ pragmas_ manualAttrOrderMap_ paramMap_ contextMap_ quantMap_ uniqueMap_ augmentsMap_ aroundsMap_ mergeMap_ ) = sem_Grammar_Grammar typeSyns_ useMap_ derivings_ wrappers_ ( sem_Nonterminals nonts_ ) pragmas_ manualAttrOrderMap_ paramMap_ contextMap_ quantMap_ uniqueMap_ augmentsMap_ aroundsMap_ mergeMap_ -- semantic domain newtype T_Grammar = T_Grammar { attach_T_Grammar :: Identity (T_Grammar_s11 ) } newtype T_Grammar_s11 = C_Grammar_s11 { inv_Grammar_s11 :: (T_Grammar_v10 ) } data T_Grammar_s12 = C_Grammar_s12 type T_Grammar_v10 = (T_Grammar_vIn10 ) -> (T_Grammar_vOut10 ) data T_Grammar_vIn10 = T_Grammar_vIn10 (Options) data T_Grammar_vOut10 = T_Grammar_vOut10 (Seq Error) (Int) (Int) (CGrammar) {-# NOINLINE sem_Grammar_Grammar #-} sem_Grammar_Grammar :: (TypeSyns) -> (UseMap) -> (Derivings) -> (Set NontermIdent) -> T_Nonterminals -> (PragmaMap) -> (AttrOrderMap) -> (ParamMap) -> (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)))) -> T_Grammar sem_Grammar_Grammar arg_typeSyns_ _ arg_derivings_ arg_wrappers_ arg_nonts_ arg_pragmas_ arg_manualAttrOrderMap_ arg_paramMap_ arg_contextMap_ arg_quantMap_ _ _ arg_aroundsMap_ arg_mergeMap_ = T_Grammar (return st11) where {-# NOINLINE st11 #-} st11 = let v10 :: T_Grammar_v10 v10 = \ (T_Grammar_vIn10 _lhsIoptions) -> ( let _nontsX17 = Control.Monad.Identity.runIdentity (attach_T_Nonterminals (arg_nonts_)) (T_Nonterminals_vOut16 _nontsIacount _nontsIadditionalDep _nontsIaranges _nontsIaroundDep _nontsIcNonterminals _nontsIdirectDep _nontsIerrors _nontsIinhMap' _nontsIinstDep _nontsImergeDep _nontsInAutoRules _nontsInExplicitRules _nontsInonts _nontsIntattrs _nontsIrules _nontsIsynMap' _nontsIvcount) = inv_Nonterminals_s17 _nontsX17 (T_Nonterminals_vIn16 _nontsOacount _nontsOallnts _nontsOaroundMap _nontsOcInterfaceMap _nontsOcVisitsMap _nontsOinhMap _nontsOmanualAttrDepMap _nontsOmergeMap _nontsOo_case _nontsOo_cata _nontsOo_data _nontsOo_dovisit _nontsOo_newtypes _nontsOo_rename _nontsOo_sem _nontsOo_sig _nontsOo_unbox _nontsOo_wantvisit _nontsOprefix _nontsOsynMap _nontsOvcount) _nontsOinhMap = rule69 _nontsIinhMap' _nontsOsynMap = rule70 _nontsIsynMap' _o_dovisit = rule71 _cyclesErrors _lhsIoptions _nontsOo_cata = rule72 _lhsIoptions _nontsOo_data = rule73 _lhsIoptions _nontsOo_sig = rule74 _lhsIoptions _nontsOo_sem = rule75 _lhsIoptions _nontsOo_rename = rule76 _lhsIoptions _nontsOo_newtypes = rule77 _lhsIoptions _nontsOo_wantvisit = rule78 _lhsIoptions _nontsOo_unbox = rule79 _lhsIoptions _nontsOo_case = rule80 _lhsIoptions _nontsOprefix = rule81 _lhsIoptions _nontsOvcount = rule82 () _nontsOmanualAttrDepMap = rule83 arg_manualAttrOrderMap_ _nontsOaroundMap = rule84 arg_aroundsMap_ _nontsOacount = rule85 () _ruleTable = rule86 _nontsIrules _nontsIvcount _attrTable = rule87 _nontsIacount _nontsIntattrs _attrVertex = rule88 _nontsIntattrs _tdpToTds = rule89 _attrVertex _nontsIrules _tdsToTdp = rule90 _tdpToTds _directDep = rule91 _nontsIadditionalDep _nontsIdirectDep _instDep = rule92 _nontsIinstDep _aroundDep = rule93 _nontsIaroundDep _mergeDep = rule94 _nontsImergeDep _info = rule95 _attrTable _nontsIacount _nontsIaranges _nontsInonts _nontsIvcount _ruleTable _tdpToTds _tdsToTdp arg_wrappers_ (_cInterfaceMap,_cVisitsMap,_cyclesErrors) = rule96 _aroundDep _attrTable _directDep _info _instDep _lhsIoptions _mergeDep _ruleTable _lhsOerrors :: Seq Error _lhsOerrors = rule97 _cyclesErrors _lhsIoptions _nontsIerrors _lhsOoutput :: CGrammar _lhsOoutput = rule98 _aroundMap _mergeMap _nontsIcNonterminals _o_dovisit arg_contextMap_ arg_derivings_ arg_paramMap_ arg_pragmas_ arg_quantMap_ arg_typeSyns_ arg_wrappers_ _aroundMap = rule99 arg_aroundsMap_ _mergeMap = rule100 arg_mergeMap_ _nontsOallnts = rule101 _nontsInonts _lhsOnAutoRules :: Int _lhsOnAutoRules = rule102 _nontsInAutoRules _lhsOnExplicitRules :: Int _lhsOnExplicitRules = rule103 _nontsInExplicitRules _nontsOcInterfaceMap = rule104 _cInterfaceMap _nontsOcVisitsMap = rule105 _cVisitsMap _nontsOmergeMap = rule106 _mergeMap _nontsOo_dovisit = rule107 _o_dovisit __result_ = T_Grammar_vOut10 _lhsOerrors _lhsOnAutoRules _lhsOnExplicitRules _lhsOoutput in __result_ ) in C_Grammar_s11 v10 {-# INLINE rule69 #-} {-# LINE 15 "./src-ag/DistChildAttr.ag" #-} rule69 = \ ((_nontsIinhMap') :: Map Identifier Attributes) -> {-# LINE 15 "./src-ag/DistChildAttr.ag" #-} _nontsIinhMap' {-# LINE 868 "dist/build/Order.hs"#-} {-# INLINE rule70 #-} {-# LINE 16 "./src-ag/DistChildAttr.ag" #-} rule70 = \ ((_nontsIsynMap') :: Map Identifier Attributes) -> {-# LINE 16 "./src-ag/DistChildAttr.ag" #-} _nontsIsynMap' {-# LINE 874 "dist/build/Order.hs"#-} {-# INLINE rule71 #-} {-# LINE 124 "./src-ag/Order.ag" #-} rule71 = \ _cyclesErrors ((_lhsIoptions) :: Options) -> {-# LINE 124 "./src-ag/Order.ag" #-} visit _lhsIoptions && null _cyclesErrors {-# LINE 880 "dist/build/Order.hs"#-} {-# INLINE rule72 #-} {-# LINE 125 "./src-ag/Order.ag" #-} rule72 = \ ((_lhsIoptions) :: Options) -> {-# LINE 125 "./src-ag/Order.ag" #-} folds _lhsIoptions {-# LINE 886 "dist/build/Order.hs"#-} {-# INLINE rule73 #-} {-# LINE 126 "./src-ag/Order.ag" #-} rule73 = \ ((_lhsIoptions) :: Options) -> {-# LINE 126 "./src-ag/Order.ag" #-} dataTypes _lhsIoptions {-# LINE 892 "dist/build/Order.hs"#-} {-# INLINE rule74 #-} {-# LINE 127 "./src-ag/Order.ag" #-} rule74 = \ ((_lhsIoptions) :: Options) -> {-# LINE 127 "./src-ag/Order.ag" #-} typeSigs _lhsIoptions {-# LINE 898 "dist/build/Order.hs"#-} {-# INLINE rule75 #-} {-# LINE 128 "./src-ag/Order.ag" #-} rule75 = \ ((_lhsIoptions) :: Options) -> {-# LINE 128 "./src-ag/Order.ag" #-} semfuns _lhsIoptions {-# LINE 904 "dist/build/Order.hs"#-} {-# INLINE rule76 #-} {-# LINE 129 "./src-ag/Order.ag" #-} rule76 = \ ((_lhsIoptions) :: Options) -> {-# LINE 129 "./src-ag/Order.ag" #-} rename _lhsIoptions {-# LINE 910 "dist/build/Order.hs"#-} {-# INLINE rule77 #-} {-# LINE 130 "./src-ag/Order.ag" #-} rule77 = \ ((_lhsIoptions) :: Options) -> {-# LINE 130 "./src-ag/Order.ag" #-} newtypes _lhsIoptions {-# LINE 916 "dist/build/Order.hs"#-} {-# INLINE rule78 #-} {-# LINE 131 "./src-ag/Order.ag" #-} rule78 = \ ((_lhsIoptions) :: Options) -> {-# LINE 131 "./src-ag/Order.ag" #-} visit _lhsIoptions {-# LINE 922 "dist/build/Order.hs"#-} {-# INLINE rule79 #-} {-# LINE 132 "./src-ag/Order.ag" #-} rule79 = \ ((_lhsIoptions) :: Options) -> {-# LINE 132 "./src-ag/Order.ag" #-} unbox _lhsIoptions {-# LINE 928 "dist/build/Order.hs"#-} {-# INLINE rule80 #-} {-# LINE 133 "./src-ag/Order.ag" #-} rule80 = \ ((_lhsIoptions) :: Options) -> {-# LINE 133 "./src-ag/Order.ag" #-} cases _lhsIoptions {-# LINE 934 "dist/build/Order.hs"#-} {-# INLINE rule81 #-} {-# LINE 134 "./src-ag/Order.ag" #-} rule81 = \ ((_lhsIoptions) :: Options) -> {-# LINE 134 "./src-ag/Order.ag" #-} prefix _lhsIoptions {-# LINE 940 "dist/build/Order.hs"#-} {-# INLINE rule82 #-} {-# LINE 260 "./src-ag/Order.ag" #-} rule82 = \ (_ :: ()) -> {-# LINE 260 "./src-ag/Order.ag" #-} 0 {-# LINE 946 "dist/build/Order.hs"#-} {-# INLINE rule83 #-} {-# LINE 286 "./src-ag/Order.ag" #-} rule83 = \ manualAttrOrderMap_ -> {-# LINE 286 "./src-ag/Order.ag" #-} manualAttrOrderMap_ {-# LINE 952 "dist/build/Order.hs"#-} {-# INLINE rule84 #-} {-# LINE 415 "./src-ag/Order.ag" #-} rule84 = \ aroundsMap_ -> {-# LINE 415 "./src-ag/Order.ag" #-} aroundsMap_ {-# LINE 958 "dist/build/Order.hs"#-} {-# INLINE rule85 #-} {-# LINE 504 "./src-ag/Order.ag" #-} rule85 = \ (_ :: ()) -> {-# LINE 504 "./src-ag/Order.ag" #-} 0 {-# LINE 964 "dist/build/Order.hs"#-} {-# INLINE rule86 #-} {-# LINE 542 "./src-ag/Order.ag" #-} rule86 = \ ((_nontsIrules) :: Seq (Vertex,CRule)) ((_nontsIvcount) :: Int) -> {-# LINE 542 "./src-ag/Order.ag" #-} Array.array (0,_nontsIvcount-1) (toList _nontsIrules) {-# LINE 970 "dist/build/Order.hs"#-} {-# INLINE rule87 #-} {-# LINE 543 "./src-ag/Order.ag" #-} rule87 = \ ((_nontsIacount) :: Int) ((_nontsIntattrs) :: Seq (Vertex,NTAttr)) -> {-# LINE 543 "./src-ag/Order.ag" #-} Array.array (0,_nontsIacount-1) (toList _nontsIntattrs) {-# LINE 976 "dist/build/Order.hs"#-} {-# INLINE rule88 #-} {-# LINE 544 "./src-ag/Order.ag" #-} rule88 = \ ((_nontsIntattrs) :: Seq (Vertex,NTAttr)) -> {-# LINE 544 "./src-ag/Order.ag" #-} Map.fromList (map swap (toList _nontsIntattrs)) {-# LINE 982 "dist/build/Order.hs"#-} {-# INLINE rule89 #-} {-# LINE 545 "./src-ag/Order.ag" #-} rule89 = \ _attrVertex ((_nontsIrules) :: Seq (Vertex,CRule)) -> {-# LINE 545 "./src-ag/Order.ag" #-} [ (s, maybe (-1) (\v -> findWithErr1 "Grammar.tdpToTds" v _attrVertex) (ntattr cr)) | (s,cr) <- toList _nontsIrules] {-# LINE 989 "dist/build/Order.hs"#-} {-# INLINE rule90 #-} {-# LINE 547 "./src-ag/Order.ag" #-} rule90 = \ _tdpToTds -> {-# LINE 547 "./src-ag/Order.ag" #-} 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) {-# LINE 998 "dist/build/Order.hs"#-} {-# INLINE rule91 #-} {-# LINE 551 "./src-ag/Order.ag" #-} rule91 = \ ((_nontsIadditionalDep) :: Seq Edge) ((_nontsIdirectDep) :: Seq Edge) -> {-# LINE 551 "./src-ag/Order.ag" #-} toList (_nontsIdirectDep Seq.>< _nontsIadditionalDep) {-# LINE 1004 "dist/build/Order.hs"#-} {-# INLINE rule92 #-} {-# LINE 552 "./src-ag/Order.ag" #-} rule92 = \ ((_nontsIinstDep) :: Seq Edge) -> {-# LINE 552 "./src-ag/Order.ag" #-} toList _nontsIinstDep {-# LINE 1010 "dist/build/Order.hs"#-} {-# INLINE rule93 #-} {-# LINE 553 "./src-ag/Order.ag" #-} rule93 = \ ((_nontsIaroundDep) :: Seq Edge) -> {-# LINE 553 "./src-ag/Order.ag" #-} toList _nontsIaroundDep {-# LINE 1016 "dist/build/Order.hs"#-} {-# INLINE rule94 #-} {-# LINE 554 "./src-ag/Order.ag" #-} rule94 = \ ((_nontsImergeDep) :: Seq Edge) -> {-# LINE 554 "./src-ag/Order.ag" #-} toList _nontsImergeDep {-# LINE 1022 "dist/build/Order.hs"#-} {-# INLINE rule95 #-} {-# LINE 555 "./src-ag/Order.ag" #-} rule95 = \ _attrTable ((_nontsIacount) :: Int) ((_nontsIaranges) :: Seq (Int,Int,Int)) ((_nontsInonts) :: [(NontermIdent,[ConstructorIdent])]) ((_nontsIvcount) :: Int) _ruleTable _tdpToTds _tdsToTdp wrappers_ -> {-# LINE 555 "./src-ag/Order.ag" #-} let def [] = -1 def (v:vs) = v in Info { tdsToTdp = Array.array (0,_nontsIacount-1) _tdsToTdp , tdpToTds = Array.array (0,_nontsIvcount-1) _tdpToTds , attrTable = _attrTable , ruleTable = _ruleTable , lmh = toList _nontsIaranges , nonts = _nontsInonts , wraps = wrappers_ } {-# LINE 1037 "dist/build/Order.hs"#-} {-# INLINE rule96 #-} {-# LINE 567 "./src-ag/Order.ag" #-} rule96 = \ _aroundDep _attrTable _directDep _info _instDep ((_lhsIoptions) :: Options) _mergeDep _ruleTable -> {-# LINE 567 "./src-ag/Order.ag" #-} case computeSequential _info _directDep (_instDep ++ _aroundDep ++ _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 _lhsIoptions)) 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 _lhsIoptions)) 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 _lhsIoptions) errs ) InducedCycle cim errs -> ( cim , error "No visit sub-sequences for AG with induced cycles" , inducedCycleErrs _attrTable _ruleTable cim errs ) {-# LINE 1063 "dist/build/Order.hs"#-} {-# INLINE rule97 #-} {-# LINE 588 "./src-ag/Order.ag" #-} rule97 = \ _cyclesErrors ((_lhsIoptions) :: Options) ((_nontsIerrors) :: Seq Error) -> {-# LINE 588 "./src-ag/Order.ag" #-} (if withCycle _lhsIoptions then Seq.fromList _cyclesErrors else Seq.empty) Seq.>< _nontsIerrors {-# LINE 1070 "dist/build/Order.hs"#-} {-# INLINE rule98 #-} {-# LINE 620 "./src-ag/Order.ag" #-} rule98 = \ _aroundMap _mergeMap ((_nontsIcNonterminals) :: CNonterminals) _o_dovisit contextMap_ derivings_ paramMap_ pragmas_ quantMap_ typeSyns_ wrappers_ -> {-# LINE 620 "./src-ag/Order.ag" #-} CGrammar typeSyns_ derivings_ wrappers_ _nontsIcNonterminals pragmas_ paramMap_ contextMap_ quantMap_ _aroundMap _mergeMap _o_dovisit {-# LINE 1076 "dist/build/Order.hs"#-} {-# INLINE rule99 #-} {-# LINE 633 "./src-ag/Order.ag" #-} rule99 = \ aroundsMap_ -> {-# LINE 633 "./src-ag/Order.ag" #-} Map.map (Map.map Map.keysSet) aroundsMap_ {-# LINE 1082 "dist/build/Order.hs"#-} {-# INLINE rule100 #-} {-# LINE 634 "./src-ag/Order.ag" #-} rule100 = \ mergeMap_ -> {-# LINE 634 "./src-ag/Order.ag" #-} Map.map (Map.map (Map.map (\(nt,srcs,_) -> (nt,srcs)))) mergeMap_ {-# LINE 1088 "dist/build/Order.hs"#-} {-# INLINE rule101 #-} {-# LINE 651 "./src-ag/Order.ag" #-} rule101 = \ ((_nontsInonts) :: [(NontermIdent,[ConstructorIdent])]) -> {-# LINE 651 "./src-ag/Order.ag" #-} map fst (_nontsInonts) {-# LINE 1094 "dist/build/Order.hs"#-} {-# INLINE rule102 #-} rule102 = \ ((_nontsInAutoRules) :: Int) -> _nontsInAutoRules {-# INLINE rule103 #-} rule103 = \ ((_nontsInExplicitRules) :: Int) -> _nontsInExplicitRules {-# INLINE rule104 #-} rule104 = \ _cInterfaceMap -> _cInterfaceMap {-# INLINE rule105 #-} rule105 = \ _cVisitsMap -> _cVisitsMap {-# INLINE rule106 #-} rule106 = \ _mergeMap -> _mergeMap {-# INLINE rule107 #-} rule107 = \ _o_dovisit -> _o_dovisit -- Nonterminal ------------------------------------------------- -- wrapper data Inh_Nonterminal = Inh_Nonterminal { acount_Inh_Nonterminal :: (Int), allnts_Inh_Nonterminal :: ([Identifier]), aroundMap_Inh_Nonterminal :: (Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))), cInterfaceMap_Inh_Nonterminal :: (CInterfaceMap), cVisitsMap_Inh_Nonterminal :: (CVisitsMap), inhMap_Inh_Nonterminal :: (Map Identifier Attributes), manualAttrDepMap_Inh_Nonterminal :: (AttrOrderMap), mergeMap_Inh_Nonterminal :: (Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))), o_case_Inh_Nonterminal :: (Bool), o_cata_Inh_Nonterminal :: (Bool), o_data_Inh_Nonterminal :: (Bool), o_dovisit_Inh_Nonterminal :: (Bool), o_newtypes_Inh_Nonterminal :: (Bool), o_rename_Inh_Nonterminal :: (Bool), o_sem_Inh_Nonterminal :: (Bool), o_sig_Inh_Nonterminal :: (Bool), o_unbox_Inh_Nonterminal :: (Bool), o_wantvisit_Inh_Nonterminal :: (Bool), prefix_Inh_Nonterminal :: (String), synMap_Inh_Nonterminal :: (Map Identifier Attributes), vcount_Inh_Nonterminal :: (Int) } data Syn_Nonterminal = Syn_Nonterminal { acount_Syn_Nonterminal :: (Int), additionalDep_Syn_Nonterminal :: (Seq Edge), aranges_Syn_Nonterminal :: (Seq (Int,Int,Int)), aroundDep_Syn_Nonterminal :: (Seq Edge), cNonterminal_Syn_Nonterminal :: (CNonterminal), directDep_Syn_Nonterminal :: (Seq Edge), errors_Syn_Nonterminal :: (Seq Error), inhMap'_Syn_Nonterminal :: (Map Identifier Attributes), instDep_Syn_Nonterminal :: (Seq Edge), mergeDep_Syn_Nonterminal :: (Seq Edge), nAutoRules_Syn_Nonterminal :: (Int), nExplicitRules_Syn_Nonterminal :: (Int), nonts_Syn_Nonterminal :: ([(NontermIdent,[ConstructorIdent])]), ntattrs_Syn_Nonterminal :: (Seq (Vertex,NTAttr)), rules_Syn_Nonterminal :: (Seq (Vertex,CRule)), synMap'_Syn_Nonterminal :: (Map Identifier Attributes), vcount_Syn_Nonterminal :: (Int) } {-# INLINABLE wrap_Nonterminal #-} wrap_Nonterminal :: T_Nonterminal -> Inh_Nonterminal -> (Syn_Nonterminal ) wrap_Nonterminal (T_Nonterminal act) (Inh_Nonterminal _lhsIacount _lhsIallnts _lhsIaroundMap _lhsIcInterfaceMap _lhsIcVisitsMap _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsIo_case _lhsIo_cata _lhsIo_data _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIsynMap _lhsIvcount) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Nonterminal_vIn13 _lhsIacount _lhsIallnts _lhsIaroundMap _lhsIcInterfaceMap _lhsIcVisitsMap _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsIo_case _lhsIo_cata _lhsIo_data _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIsynMap _lhsIvcount (T_Nonterminal_vOut13 _lhsOacount _lhsOadditionalDep _lhsOaranges _lhsOaroundDep _lhsOcNonterminal _lhsOdirectDep _lhsOerrors _lhsOinhMap' _lhsOinstDep _lhsOmergeDep _lhsOnAutoRules _lhsOnExplicitRules _lhsOnonts _lhsOntattrs _lhsOrules _lhsOsynMap' _lhsOvcount) <- return (inv_Nonterminal_s14 sem arg) return (Syn_Nonterminal _lhsOacount _lhsOadditionalDep _lhsOaranges _lhsOaroundDep _lhsOcNonterminal _lhsOdirectDep _lhsOerrors _lhsOinhMap' _lhsOinstDep _lhsOmergeDep _lhsOnAutoRules _lhsOnExplicitRules _lhsOnonts _lhsOntattrs _lhsOrules _lhsOsynMap' _lhsOvcount) ) -- cata {-# INLINE sem_Nonterminal #-} sem_Nonterminal :: Nonterminal -> T_Nonterminal sem_Nonterminal ( Nonterminal nt_ params_ inh_ syn_ prods_ ) = sem_Nonterminal_Nonterminal nt_ params_ inh_ syn_ ( sem_Productions prods_ ) -- semantic domain newtype T_Nonterminal = T_Nonterminal { attach_T_Nonterminal :: Identity (T_Nonterminal_s14 ) } newtype T_Nonterminal_s14 = C_Nonterminal_s14 { inv_Nonterminal_s14 :: (T_Nonterminal_v13 ) } data T_Nonterminal_s15 = C_Nonterminal_s15 type T_Nonterminal_v13 = (T_Nonterminal_vIn13 ) -> (T_Nonterminal_vOut13 ) data T_Nonterminal_vIn13 = T_Nonterminal_vIn13 (Int) ([Identifier]) (Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) (CInterfaceMap) (CVisitsMap) (Map Identifier Attributes) (AttrOrderMap) (Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (String) (Map Identifier Attributes) (Int) data T_Nonterminal_vOut13 = T_Nonterminal_vOut13 (Int) (Seq Edge) (Seq (Int,Int,Int)) (Seq Edge) (CNonterminal) (Seq Edge) (Seq Error) (Map Identifier Attributes) (Seq Edge) (Seq Edge) (Int) (Int) ([(NontermIdent,[ConstructorIdent])]) (Seq (Vertex,NTAttr)) (Seq (Vertex,CRule)) (Map Identifier Attributes) (Int) {-# NOINLINE sem_Nonterminal_Nonterminal #-} sem_Nonterminal_Nonterminal :: (NontermIdent) -> ([Identifier]) -> (Attributes) -> (Attributes) -> T_Productions -> T_Nonterminal sem_Nonterminal_Nonterminal arg_nt_ arg_params_ arg_inh_ arg_syn_ arg_prods_ = T_Nonterminal (return st14) where {-# NOINLINE st14 #-} st14 = let v13 :: T_Nonterminal_v13 v13 = \ (T_Nonterminal_vIn13 _lhsIacount _lhsIallnts _lhsIaroundMap _lhsIcInterfaceMap _lhsIcVisitsMap _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsIo_case _lhsIo_cata _lhsIo_data _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIsynMap _lhsIvcount) -> ( let _prodsX29 = Control.Monad.Identity.runIdentity (attach_T_Productions (arg_prods_)) (T_Productions_vOut28 _prodsIadditionalDep _prodsIaroundDep _prodsIcProductions _prodsIcons _prodsIdirectDep _prodsIerrors _prodsIinstDep _prodsImergeDep _prodsInAutoRules _prodsInExplicitRules _prodsIrules _prodsIvcount) = inv_Productions_s29 _prodsX29 (T_Productions_vIn28 _prodsOallnts _prodsOaroundMap _prodsOcVisitsMap _prodsOinh _prodsOinhMap _prodsOmanualAttrDepMap _prodsOmergeMap _prodsOnt _prodsOo_case _prodsOo_cata _prodsOo_dovisit _prodsOo_newtypes _prodsOo_rename _prodsOo_sem _prodsOo_sig _prodsOo_unbox _prodsOo_wantvisit _prodsOprefix _prodsOsyn _prodsOsynMap _prodsOvcount) _lhsOinhMap' :: Map Identifier Attributes _lhsOinhMap' = rule108 arg_inh_ arg_nt_ _lhsOsynMap' :: Map Identifier Attributes _lhsOsynMap' = rule109 arg_nt_ arg_syn_ _prodsOnt = rule110 arg_nt_ _prodsOinh = rule111 arg_inh_ _prodsOsyn = rule112 arg_syn_ _mergeMap = rule113 _lhsImergeMap arg_nt_ _aroundMap = rule114 _lhsIaroundMap arg_nt_ _ntattrs = rule115 arg_inh_ arg_nt_ arg_syn_ _lhsOntattrs :: Seq (Vertex,NTAttr) _lhsOntattrs = rule116 _lhsIacount _ntattrs _lhsOacount :: Int _lhsOacount = rule117 _lhsIacount arg_inh_ arg_syn_ _lhsOaranges :: Seq (Int,Int,Int) _lhsOaranges = rule118 _lhsIacount arg_inh_ arg_syn_ _lhsOnonts :: [(NontermIdent,[ConstructorIdent])] _lhsOnonts = rule119 _prodsIcons arg_nt_ _cInter = rule120 _lhsIcInterfaceMap _lhsIo_dovisit arg_inh_ arg_nt_ arg_syn_ _lhsOcNonterminal :: CNonterminal _lhsOcNonterminal = rule121 _cInter _prodsIcProductions arg_inh_ arg_nt_ arg_params_ arg_syn_ _lhsOadditionalDep :: Seq Edge _lhsOadditionalDep = rule122 _prodsIadditionalDep _lhsOaroundDep :: Seq Edge _lhsOaroundDep = rule123 _prodsIaroundDep _lhsOdirectDep :: Seq Edge _lhsOdirectDep = rule124 _prodsIdirectDep _lhsOerrors :: Seq Error _lhsOerrors = rule125 _prodsIerrors _lhsOinstDep :: Seq Edge _lhsOinstDep = rule126 _prodsIinstDep _lhsOmergeDep :: Seq Edge _lhsOmergeDep = rule127 _prodsImergeDep _lhsOnAutoRules :: Int _lhsOnAutoRules = rule128 _prodsInAutoRules _lhsOnExplicitRules :: Int _lhsOnExplicitRules = rule129 _prodsInExplicitRules _lhsOrules :: Seq (Vertex,CRule) _lhsOrules = rule130 _prodsIrules _lhsOvcount :: Int _lhsOvcount = rule131 _prodsIvcount _prodsOallnts = rule132 _lhsIallnts _prodsOaroundMap = rule133 _aroundMap _prodsOcVisitsMap = rule134 _lhsIcVisitsMap _prodsOinhMap = rule135 _lhsIinhMap _prodsOmanualAttrDepMap = rule136 _lhsImanualAttrDepMap _prodsOmergeMap = rule137 _mergeMap _prodsOo_case = rule138 _lhsIo_case _prodsOo_cata = rule139 _lhsIo_cata _prodsOo_dovisit = rule140 _lhsIo_dovisit _prodsOo_newtypes = rule141 _lhsIo_newtypes _prodsOo_rename = rule142 _lhsIo_rename _prodsOo_sem = rule143 _lhsIo_sem _prodsOo_sig = rule144 _lhsIo_sig _prodsOo_unbox = rule145 _lhsIo_unbox _prodsOo_wantvisit = rule146 _lhsIo_wantvisit _prodsOprefix = rule147 _lhsIprefix _prodsOsynMap = rule148 _lhsIsynMap _prodsOvcount = rule149 _lhsIvcount __result_ = T_Nonterminal_vOut13 _lhsOacount _lhsOadditionalDep _lhsOaranges _lhsOaroundDep _lhsOcNonterminal _lhsOdirectDep _lhsOerrors _lhsOinhMap' _lhsOinstDep _lhsOmergeDep _lhsOnAutoRules _lhsOnExplicitRules _lhsOnonts _lhsOntattrs _lhsOrules _lhsOsynMap' _lhsOvcount in __result_ ) in C_Nonterminal_s14 v13 {-# INLINE rule108 #-} {-# LINE 7 "./src-ag/DistChildAttr.ag" #-} rule108 = \ inh_ nt_ -> {-# LINE 7 "./src-ag/DistChildAttr.ag" #-} Map.singleton nt_ inh_ {-# LINE 1220 "dist/build/Order.hs"#-} {-# INLINE rule109 #-} {-# LINE 8 "./src-ag/DistChildAttr.ag" #-} rule109 = \ nt_ syn_ -> {-# LINE 8 "./src-ag/DistChildAttr.ag" #-} Map.singleton nt_ syn_ {-# LINE 1226 "dist/build/Order.hs"#-} {-# INLINE rule110 #-} {-# LINE 98 "./src-ag/Order.ag" #-} rule110 = \ nt_ -> {-# LINE 98 "./src-ag/Order.ag" #-} nt_ {-# LINE 1232 "dist/build/Order.hs"#-} {-# INLINE rule111 #-} {-# LINE 101 "./src-ag/Order.ag" #-} rule111 = \ inh_ -> {-# LINE 101 "./src-ag/Order.ag" #-} inh_ {-# LINE 1238 "dist/build/Order.hs"#-} {-# INLINE rule112 #-} {-# LINE 102 "./src-ag/Order.ag" #-} rule112 = \ syn_ -> {-# LINE 102 "./src-ag/Order.ag" #-} syn_ {-# LINE 1244 "dist/build/Order.hs"#-} {-# INLINE rule113 #-} {-# LINE 358 "./src-ag/Order.ag" #-} rule113 = \ ((_lhsImergeMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))) nt_ -> {-# LINE 358 "./src-ag/Order.ag" #-} Map.findWithDefault Map.empty nt_ _lhsImergeMap {-# LINE 1250 "dist/build/Order.hs"#-} {-# INLINE rule114 #-} {-# LINE 411 "./src-ag/Order.ag" #-} rule114 = \ ((_lhsIaroundMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) nt_ -> {-# LINE 411 "./src-ag/Order.ag" #-} Map.findWithDefault Map.empty nt_ _lhsIaroundMap {-# LINE 1256 "dist/build/Order.hs"#-} {-# INLINE rule115 #-} {-# LINE 507 "./src-ag/Order.ag" #-} rule115 = \ inh_ nt_ syn_ -> {-# LINE 507 "./src-ag/Order.ag" #-} [ NTAInh nt_ inh tp | (inh,tp) <- Map.assocs inh_ ] ++ [NTASyn nt_ syn tp | (syn,tp) <- Map.assocs syn_ ] {-# LINE 1263 "dist/build/Order.hs"#-} {-# INLINE rule116 #-} {-# LINE 509 "./src-ag/Order.ag" #-} rule116 = \ ((_lhsIacount) :: Int) _ntattrs -> {-# LINE 509 "./src-ag/Order.ag" #-} Seq.fromList (zip [_lhsIacount ..] _ntattrs) {-# LINE 1269 "dist/build/Order.hs"#-} {-# INLINE rule117 #-} {-# LINE 510 "./src-ag/Order.ag" #-} rule117 = \ ((_lhsIacount) :: Int) inh_ syn_ -> {-# LINE 510 "./src-ag/Order.ag" #-} _lhsIacount + Map.size inh_ + Map.size syn_ {-# LINE 1275 "dist/build/Order.hs"#-} {-# INLINE rule118 #-} {-# LINE 511 "./src-ag/Order.ag" #-} rule118 = \ ((_lhsIacount) :: Int) inh_ syn_ -> {-# LINE 511 "./src-ag/Order.ag" #-} Seq.singleton (_lhsIacount ,_lhsIacount + Map.size inh_ ,_lhsIacount + Map.size syn_ + Map.size inh_ - 1) {-# LINE 1284 "dist/build/Order.hs"#-} {-# INLINE rule119 #-} {-# LINE 520 "./src-ag/Order.ag" #-} rule119 = \ ((_prodsIcons) :: [ConstructorIdent]) nt_ -> {-# LINE 520 "./src-ag/Order.ag" #-} [(nt_,_prodsIcons)] {-# LINE 1290 "dist/build/Order.hs"#-} {-# INLINE rule120 #-} {-# LINE 597 "./src-ag/Order.ag" #-} rule120 = \ ((_lhsIcInterfaceMap) :: CInterfaceMap) ((_lhsIo_dovisit) :: Bool) inh_ nt_ syn_ -> {-# LINE 597 "./src-ag/Order.ag" #-} if _lhsIo_dovisit then findWithErr1 "Nonterminal.cInter" nt_ _lhsIcInterfaceMap else CInterface [CSegment inh_ syn_] {-# LINE 1298 "dist/build/Order.hs"#-} {-# INLINE rule121 #-} {-# LINE 625 "./src-ag/Order.ag" #-} rule121 = \ _cInter ((_prodsIcProductions) :: CProductions) inh_ nt_ params_ syn_ -> {-# LINE 625 "./src-ag/Order.ag" #-} CNonterminal nt_ params_ inh_ syn_ _prodsIcProductions _cInter {-# LINE 1304 "dist/build/Order.hs"#-} {-# INLINE rule122 #-} rule122 = \ ((_prodsIadditionalDep) :: Seq Edge) -> _prodsIadditionalDep {-# INLINE rule123 #-} rule123 = \ ((_prodsIaroundDep) :: Seq Edge) -> _prodsIaroundDep {-# INLINE rule124 #-} rule124 = \ ((_prodsIdirectDep) :: Seq Edge) -> _prodsIdirectDep {-# INLINE rule125 #-} rule125 = \ ((_prodsIerrors) :: Seq Error) -> _prodsIerrors {-# INLINE rule126 #-} rule126 = \ ((_prodsIinstDep) :: Seq Edge) -> _prodsIinstDep {-# INLINE rule127 #-} rule127 = \ ((_prodsImergeDep) :: Seq Edge) -> _prodsImergeDep {-# INLINE rule128 #-} rule128 = \ ((_prodsInAutoRules) :: Int) -> _prodsInAutoRules {-# INLINE rule129 #-} rule129 = \ ((_prodsInExplicitRules) :: Int) -> _prodsInExplicitRules {-# INLINE rule130 #-} rule130 = \ ((_prodsIrules) :: Seq (Vertex,CRule)) -> _prodsIrules {-# INLINE rule131 #-} rule131 = \ ((_prodsIvcount) :: Int) -> _prodsIvcount {-# INLINE rule132 #-} rule132 = \ ((_lhsIallnts) :: [Identifier]) -> _lhsIallnts {-# INLINE rule133 #-} rule133 = \ _aroundMap -> _aroundMap {-# INLINE rule134 #-} rule134 = \ ((_lhsIcVisitsMap) :: CVisitsMap) -> _lhsIcVisitsMap {-# INLINE rule135 #-} rule135 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule136 #-} rule136 = \ ((_lhsImanualAttrDepMap) :: AttrOrderMap) -> _lhsImanualAttrDepMap {-# INLINE rule137 #-} rule137 = \ _mergeMap -> _mergeMap {-# INLINE rule138 #-} rule138 = \ ((_lhsIo_case) :: Bool) -> _lhsIo_case {-# INLINE rule139 #-} rule139 = \ ((_lhsIo_cata) :: Bool) -> _lhsIo_cata {-# INLINE rule140 #-} rule140 = \ ((_lhsIo_dovisit) :: Bool) -> _lhsIo_dovisit {-# INLINE rule141 #-} rule141 = \ ((_lhsIo_newtypes) :: Bool) -> _lhsIo_newtypes {-# INLINE rule142 #-} rule142 = \ ((_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# INLINE rule143 #-} rule143 = \ ((_lhsIo_sem) :: Bool) -> _lhsIo_sem {-# INLINE rule144 #-} rule144 = \ ((_lhsIo_sig) :: Bool) -> _lhsIo_sig {-# INLINE rule145 #-} rule145 = \ ((_lhsIo_unbox) :: Bool) -> _lhsIo_unbox {-# INLINE rule146 #-} rule146 = \ ((_lhsIo_wantvisit) :: Bool) -> _lhsIo_wantvisit {-# INLINE rule147 #-} rule147 = \ ((_lhsIprefix) :: String) -> _lhsIprefix {-# INLINE rule148 #-} rule148 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# INLINE rule149 #-} rule149 = \ ((_lhsIvcount) :: Int) -> _lhsIvcount -- Nonterminals ------------------------------------------------ -- wrapper data Inh_Nonterminals = Inh_Nonterminals { acount_Inh_Nonterminals :: (Int), allnts_Inh_Nonterminals :: ([Identifier]), aroundMap_Inh_Nonterminals :: (Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))), cInterfaceMap_Inh_Nonterminals :: (CInterfaceMap), cVisitsMap_Inh_Nonterminals :: (CVisitsMap), inhMap_Inh_Nonterminals :: (Map Identifier Attributes), manualAttrDepMap_Inh_Nonterminals :: (AttrOrderMap), mergeMap_Inh_Nonterminals :: (Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))), o_case_Inh_Nonterminals :: (Bool), o_cata_Inh_Nonterminals :: (Bool), o_data_Inh_Nonterminals :: (Bool), o_dovisit_Inh_Nonterminals :: (Bool), o_newtypes_Inh_Nonterminals :: (Bool), o_rename_Inh_Nonterminals :: (Bool), o_sem_Inh_Nonterminals :: (Bool), o_sig_Inh_Nonterminals :: (Bool), o_unbox_Inh_Nonterminals :: (Bool), o_wantvisit_Inh_Nonterminals :: (Bool), prefix_Inh_Nonterminals :: (String), synMap_Inh_Nonterminals :: (Map Identifier Attributes), vcount_Inh_Nonterminals :: (Int) } data Syn_Nonterminals = Syn_Nonterminals { acount_Syn_Nonterminals :: (Int), additionalDep_Syn_Nonterminals :: (Seq Edge), aranges_Syn_Nonterminals :: (Seq (Int,Int,Int)), aroundDep_Syn_Nonterminals :: (Seq Edge), cNonterminals_Syn_Nonterminals :: (CNonterminals), directDep_Syn_Nonterminals :: (Seq Edge), errors_Syn_Nonterminals :: (Seq Error), inhMap'_Syn_Nonterminals :: (Map Identifier Attributes), instDep_Syn_Nonterminals :: (Seq Edge), mergeDep_Syn_Nonterminals :: (Seq Edge), nAutoRules_Syn_Nonterminals :: (Int), nExplicitRules_Syn_Nonterminals :: (Int), nonts_Syn_Nonterminals :: ([(NontermIdent,[ConstructorIdent])]), ntattrs_Syn_Nonterminals :: (Seq (Vertex,NTAttr)), rules_Syn_Nonterminals :: (Seq (Vertex,CRule)), synMap'_Syn_Nonterminals :: (Map Identifier Attributes), vcount_Syn_Nonterminals :: (Int) } {-# INLINABLE wrap_Nonterminals #-} wrap_Nonterminals :: T_Nonterminals -> Inh_Nonterminals -> (Syn_Nonterminals ) wrap_Nonterminals (T_Nonterminals act) (Inh_Nonterminals _lhsIacount _lhsIallnts _lhsIaroundMap _lhsIcInterfaceMap _lhsIcVisitsMap _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsIo_case _lhsIo_cata _lhsIo_data _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIsynMap _lhsIvcount) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Nonterminals_vIn16 _lhsIacount _lhsIallnts _lhsIaroundMap _lhsIcInterfaceMap _lhsIcVisitsMap _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsIo_case _lhsIo_cata _lhsIo_data _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIsynMap _lhsIvcount (T_Nonterminals_vOut16 _lhsOacount _lhsOadditionalDep _lhsOaranges _lhsOaroundDep _lhsOcNonterminals _lhsOdirectDep _lhsOerrors _lhsOinhMap' _lhsOinstDep _lhsOmergeDep _lhsOnAutoRules _lhsOnExplicitRules _lhsOnonts _lhsOntattrs _lhsOrules _lhsOsynMap' _lhsOvcount) <- return (inv_Nonterminals_s17 sem arg) return (Syn_Nonterminals _lhsOacount _lhsOadditionalDep _lhsOaranges _lhsOaroundDep _lhsOcNonterminals _lhsOdirectDep _lhsOerrors _lhsOinhMap' _lhsOinstDep _lhsOmergeDep _lhsOnAutoRules _lhsOnExplicitRules _lhsOnonts _lhsOntattrs _lhsOrules _lhsOsynMap' _lhsOvcount) ) -- cata {-# NOINLINE sem_Nonterminals #-} sem_Nonterminals :: Nonterminals -> T_Nonterminals sem_Nonterminals list = Prelude.foldr sem_Nonterminals_Cons sem_Nonterminals_Nil (Prelude.map sem_Nonterminal list) -- semantic domain newtype T_Nonterminals = T_Nonterminals { attach_T_Nonterminals :: Identity (T_Nonterminals_s17 ) } newtype T_Nonterminals_s17 = C_Nonterminals_s17 { inv_Nonterminals_s17 :: (T_Nonterminals_v16 ) } data T_Nonterminals_s18 = C_Nonterminals_s18 type T_Nonterminals_v16 = (T_Nonterminals_vIn16 ) -> (T_Nonterminals_vOut16 ) data T_Nonterminals_vIn16 = T_Nonterminals_vIn16 (Int) ([Identifier]) (Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) (CInterfaceMap) (CVisitsMap) (Map Identifier Attributes) (AttrOrderMap) (Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (String) (Map Identifier Attributes) (Int) data T_Nonterminals_vOut16 = T_Nonterminals_vOut16 (Int) (Seq Edge) (Seq (Int,Int,Int)) (Seq Edge) (CNonterminals) (Seq Edge) (Seq Error) (Map Identifier Attributes) (Seq Edge) (Seq Edge) (Int) (Int) ([(NontermIdent,[ConstructorIdent])]) (Seq (Vertex,NTAttr)) (Seq (Vertex,CRule)) (Map Identifier Attributes) (Int) {-# NOINLINE sem_Nonterminals_Cons #-} sem_Nonterminals_Cons :: T_Nonterminal -> T_Nonterminals -> T_Nonterminals sem_Nonterminals_Cons arg_hd_ arg_tl_ = T_Nonterminals (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_Nonterminals_v16 v16 = \ (T_Nonterminals_vIn16 _lhsIacount _lhsIallnts _lhsIaroundMap _lhsIcInterfaceMap _lhsIcVisitsMap _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsIo_case _lhsIo_cata _lhsIo_data _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIsynMap _lhsIvcount) -> ( let _hdX14 = Control.Monad.Identity.runIdentity (attach_T_Nonterminal (arg_hd_)) _tlX17 = Control.Monad.Identity.runIdentity (attach_T_Nonterminals (arg_tl_)) (T_Nonterminal_vOut13 _hdIacount _hdIadditionalDep _hdIaranges _hdIaroundDep _hdIcNonterminal _hdIdirectDep _hdIerrors _hdIinhMap' _hdIinstDep _hdImergeDep _hdInAutoRules _hdInExplicitRules _hdInonts _hdIntattrs _hdIrules _hdIsynMap' _hdIvcount) = inv_Nonterminal_s14 _hdX14 (T_Nonterminal_vIn13 _hdOacount _hdOallnts _hdOaroundMap _hdOcInterfaceMap _hdOcVisitsMap _hdOinhMap _hdOmanualAttrDepMap _hdOmergeMap _hdOo_case _hdOo_cata _hdOo_data _hdOo_dovisit _hdOo_newtypes _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_unbox _hdOo_wantvisit _hdOprefix _hdOsynMap _hdOvcount) (T_Nonterminals_vOut16 _tlIacount _tlIadditionalDep _tlIaranges _tlIaroundDep _tlIcNonterminals _tlIdirectDep _tlIerrors _tlIinhMap' _tlIinstDep _tlImergeDep _tlInAutoRules _tlInExplicitRules _tlInonts _tlIntattrs _tlIrules _tlIsynMap' _tlIvcount) = inv_Nonterminals_s17 _tlX17 (T_Nonterminals_vIn16 _tlOacount _tlOallnts _tlOaroundMap _tlOcInterfaceMap _tlOcVisitsMap _tlOinhMap _tlOmanualAttrDepMap _tlOmergeMap _tlOo_case _tlOo_cata _tlOo_data _tlOo_dovisit _tlOo_newtypes _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_unbox _tlOo_wantvisit _tlOprefix _tlOsynMap _tlOvcount) _lhsOcNonterminals :: CNonterminals _lhsOcNonterminals = rule150 _hdIcNonterminal _tlIcNonterminals _lhsOadditionalDep :: Seq Edge _lhsOadditionalDep = rule151 _hdIadditionalDep _tlIadditionalDep _lhsOaranges :: Seq (Int,Int,Int) _lhsOaranges = rule152 _hdIaranges _tlIaranges _lhsOaroundDep :: Seq Edge _lhsOaroundDep = rule153 _hdIaroundDep _tlIaroundDep _lhsOdirectDep :: Seq Edge _lhsOdirectDep = rule154 _hdIdirectDep _tlIdirectDep _lhsOerrors :: Seq Error _lhsOerrors = rule155 _hdIerrors _tlIerrors _lhsOinhMap' :: Map Identifier Attributes _lhsOinhMap' = rule156 _hdIinhMap' _tlIinhMap' _lhsOinstDep :: Seq Edge _lhsOinstDep = rule157 _hdIinstDep _tlIinstDep _lhsOmergeDep :: Seq Edge _lhsOmergeDep = rule158 _hdImergeDep _tlImergeDep _lhsOnAutoRules :: Int _lhsOnAutoRules = rule159 _hdInAutoRules _tlInAutoRules _lhsOnExplicitRules :: Int _lhsOnExplicitRules = rule160 _hdInExplicitRules _tlInExplicitRules _lhsOnonts :: [(NontermIdent,[ConstructorIdent])] _lhsOnonts = rule161 _hdInonts _tlInonts _lhsOntattrs :: Seq (Vertex,NTAttr) _lhsOntattrs = rule162 _hdIntattrs _tlIntattrs _lhsOrules :: Seq (Vertex,CRule) _lhsOrules = rule163 _hdIrules _tlIrules _lhsOsynMap' :: Map Identifier Attributes _lhsOsynMap' = rule164 _hdIsynMap' _tlIsynMap' _lhsOacount :: Int _lhsOacount = rule165 _tlIacount _lhsOvcount :: Int _lhsOvcount = rule166 _tlIvcount _hdOacount = rule167 _lhsIacount _hdOallnts = rule168 _lhsIallnts _hdOaroundMap = rule169 _lhsIaroundMap _hdOcInterfaceMap = rule170 _lhsIcInterfaceMap _hdOcVisitsMap = rule171 _lhsIcVisitsMap _hdOinhMap = rule172 _lhsIinhMap _hdOmanualAttrDepMap = rule173 _lhsImanualAttrDepMap _hdOmergeMap = rule174 _lhsImergeMap _hdOo_case = rule175 _lhsIo_case _hdOo_cata = rule176 _lhsIo_cata _hdOo_data = rule177 _lhsIo_data _hdOo_dovisit = rule178 _lhsIo_dovisit _hdOo_newtypes = rule179 _lhsIo_newtypes _hdOo_rename = rule180 _lhsIo_rename _hdOo_sem = rule181 _lhsIo_sem _hdOo_sig = rule182 _lhsIo_sig _hdOo_unbox = rule183 _lhsIo_unbox _hdOo_wantvisit = rule184 _lhsIo_wantvisit _hdOprefix = rule185 _lhsIprefix _hdOsynMap = rule186 _lhsIsynMap _hdOvcount = rule187 _lhsIvcount _tlOacount = rule188 _hdIacount _tlOallnts = rule189 _lhsIallnts _tlOaroundMap = rule190 _lhsIaroundMap _tlOcInterfaceMap = rule191 _lhsIcInterfaceMap _tlOcVisitsMap = rule192 _lhsIcVisitsMap _tlOinhMap = rule193 _lhsIinhMap _tlOmanualAttrDepMap = rule194 _lhsImanualAttrDepMap _tlOmergeMap = rule195 _lhsImergeMap _tlOo_case = rule196 _lhsIo_case _tlOo_cata = rule197 _lhsIo_cata _tlOo_data = rule198 _lhsIo_data _tlOo_dovisit = rule199 _lhsIo_dovisit _tlOo_newtypes = rule200 _lhsIo_newtypes _tlOo_rename = rule201 _lhsIo_rename _tlOo_sem = rule202 _lhsIo_sem _tlOo_sig = rule203 _lhsIo_sig _tlOo_unbox = rule204 _lhsIo_unbox _tlOo_wantvisit = rule205 _lhsIo_wantvisit _tlOprefix = rule206 _lhsIprefix _tlOsynMap = rule207 _lhsIsynMap _tlOvcount = rule208 _hdIvcount __result_ = T_Nonterminals_vOut16 _lhsOacount _lhsOadditionalDep _lhsOaranges _lhsOaroundDep _lhsOcNonterminals _lhsOdirectDep _lhsOerrors _lhsOinhMap' _lhsOinstDep _lhsOmergeDep _lhsOnAutoRules _lhsOnExplicitRules _lhsOnonts _lhsOntattrs _lhsOrules _lhsOsynMap' _lhsOvcount in __result_ ) in C_Nonterminals_s17 v16 {-# INLINE rule150 #-} {-# LINE 622 "./src-ag/Order.ag" #-} rule150 = \ ((_hdIcNonterminal) :: CNonterminal) ((_tlIcNonterminals) :: CNonterminals) -> {-# LINE 622 "./src-ag/Order.ag" #-} _hdIcNonterminal : _tlIcNonterminals {-# LINE 1515 "dist/build/Order.hs"#-} {-# INLINE rule151 #-} rule151 = \ ((_hdIadditionalDep) :: Seq Edge) ((_tlIadditionalDep) :: Seq Edge) -> _hdIadditionalDep Seq.>< _tlIadditionalDep {-# INLINE rule152 #-} rule152 = \ ((_hdIaranges) :: Seq (Int,Int,Int)) ((_tlIaranges) :: Seq (Int,Int,Int)) -> _hdIaranges Seq.>< _tlIaranges {-# INLINE rule153 #-} rule153 = \ ((_hdIaroundDep) :: Seq Edge) ((_tlIaroundDep) :: Seq Edge) -> _hdIaroundDep Seq.>< _tlIaroundDep {-# INLINE rule154 #-} rule154 = \ ((_hdIdirectDep) :: Seq Edge) ((_tlIdirectDep) :: Seq Edge) -> _hdIdirectDep Seq.>< _tlIdirectDep {-# INLINE rule155 #-} rule155 = \ ((_hdIerrors) :: Seq Error) ((_tlIerrors) :: Seq Error) -> _hdIerrors Seq.>< _tlIerrors {-# INLINE rule156 #-} rule156 = \ ((_hdIinhMap') :: Map Identifier Attributes) ((_tlIinhMap') :: Map Identifier Attributes) -> _hdIinhMap' `Map.union` _tlIinhMap' {-# INLINE rule157 #-} rule157 = \ ((_hdIinstDep) :: Seq Edge) ((_tlIinstDep) :: Seq Edge) -> _hdIinstDep Seq.>< _tlIinstDep {-# INLINE rule158 #-} rule158 = \ ((_hdImergeDep) :: Seq Edge) ((_tlImergeDep) :: Seq Edge) -> _hdImergeDep Seq.>< _tlImergeDep {-# INLINE rule159 #-} rule159 = \ ((_hdInAutoRules) :: Int) ((_tlInAutoRules) :: Int) -> _hdInAutoRules + _tlInAutoRules {-# INLINE rule160 #-} rule160 = \ ((_hdInExplicitRules) :: Int) ((_tlInExplicitRules) :: Int) -> _hdInExplicitRules + _tlInExplicitRules {-# INLINE rule161 #-} rule161 = \ ((_hdInonts) :: [(NontermIdent,[ConstructorIdent])]) ((_tlInonts) :: [(NontermIdent,[ConstructorIdent])]) -> _hdInonts ++ _tlInonts {-# INLINE rule162 #-} rule162 = \ ((_hdIntattrs) :: Seq (Vertex,NTAttr)) ((_tlIntattrs) :: Seq (Vertex,NTAttr)) -> _hdIntattrs Seq.>< _tlIntattrs {-# INLINE rule163 #-} rule163 = \ ((_hdIrules) :: Seq (Vertex,CRule)) ((_tlIrules) :: Seq (Vertex,CRule)) -> _hdIrules Seq.>< _tlIrules {-# INLINE rule164 #-} rule164 = \ ((_hdIsynMap') :: Map Identifier Attributes) ((_tlIsynMap') :: Map Identifier Attributes) -> _hdIsynMap' `Map.union` _tlIsynMap' {-# INLINE rule165 #-} rule165 = \ ((_tlIacount) :: Int) -> _tlIacount {-# INLINE rule166 #-} rule166 = \ ((_tlIvcount) :: Int) -> _tlIvcount {-# INLINE rule167 #-} rule167 = \ ((_lhsIacount) :: Int) -> _lhsIacount {-# INLINE rule168 #-} rule168 = \ ((_lhsIallnts) :: [Identifier]) -> _lhsIallnts {-# INLINE rule169 #-} rule169 = \ ((_lhsIaroundMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) -> _lhsIaroundMap {-# INLINE rule170 #-} rule170 = \ ((_lhsIcInterfaceMap) :: CInterfaceMap) -> _lhsIcInterfaceMap {-# INLINE rule171 #-} rule171 = \ ((_lhsIcVisitsMap) :: CVisitsMap) -> _lhsIcVisitsMap {-# INLINE rule172 #-} rule172 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule173 #-} rule173 = \ ((_lhsImanualAttrDepMap) :: AttrOrderMap) -> _lhsImanualAttrDepMap {-# INLINE rule174 #-} rule174 = \ ((_lhsImergeMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))) -> _lhsImergeMap {-# INLINE rule175 #-} rule175 = \ ((_lhsIo_case) :: Bool) -> _lhsIo_case {-# INLINE rule176 #-} rule176 = \ ((_lhsIo_cata) :: Bool) -> _lhsIo_cata {-# INLINE rule177 #-} rule177 = \ ((_lhsIo_data) :: Bool) -> _lhsIo_data {-# INLINE rule178 #-} rule178 = \ ((_lhsIo_dovisit) :: Bool) -> _lhsIo_dovisit {-# INLINE rule179 #-} rule179 = \ ((_lhsIo_newtypes) :: Bool) -> _lhsIo_newtypes {-# INLINE rule180 #-} rule180 = \ ((_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# INLINE rule181 #-} rule181 = \ ((_lhsIo_sem) :: Bool) -> _lhsIo_sem {-# INLINE rule182 #-} rule182 = \ ((_lhsIo_sig) :: Bool) -> _lhsIo_sig {-# INLINE rule183 #-} rule183 = \ ((_lhsIo_unbox) :: Bool) -> _lhsIo_unbox {-# INLINE rule184 #-} rule184 = \ ((_lhsIo_wantvisit) :: Bool) -> _lhsIo_wantvisit {-# INLINE rule185 #-} rule185 = \ ((_lhsIprefix) :: String) -> _lhsIprefix {-# INLINE rule186 #-} rule186 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# INLINE rule187 #-} rule187 = \ ((_lhsIvcount) :: Int) -> _lhsIvcount {-# INLINE rule188 #-} rule188 = \ ((_hdIacount) :: Int) -> _hdIacount {-# INLINE rule189 #-} rule189 = \ ((_lhsIallnts) :: [Identifier]) -> _lhsIallnts {-# INLINE rule190 #-} rule190 = \ ((_lhsIaroundMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) -> _lhsIaroundMap {-# INLINE rule191 #-} rule191 = \ ((_lhsIcInterfaceMap) :: CInterfaceMap) -> _lhsIcInterfaceMap {-# INLINE rule192 #-} rule192 = \ ((_lhsIcVisitsMap) :: CVisitsMap) -> _lhsIcVisitsMap {-# INLINE rule193 #-} rule193 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule194 #-} rule194 = \ ((_lhsImanualAttrDepMap) :: AttrOrderMap) -> _lhsImanualAttrDepMap {-# INLINE rule195 #-} rule195 = \ ((_lhsImergeMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))) -> _lhsImergeMap {-# INLINE rule196 #-} rule196 = \ ((_lhsIo_case) :: Bool) -> _lhsIo_case {-# INLINE rule197 #-} rule197 = \ ((_lhsIo_cata) :: Bool) -> _lhsIo_cata {-# INLINE rule198 #-} rule198 = \ ((_lhsIo_data) :: Bool) -> _lhsIo_data {-# INLINE rule199 #-} rule199 = \ ((_lhsIo_dovisit) :: Bool) -> _lhsIo_dovisit {-# INLINE rule200 #-} rule200 = \ ((_lhsIo_newtypes) :: Bool) -> _lhsIo_newtypes {-# INLINE rule201 #-} rule201 = \ ((_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# INLINE rule202 #-} rule202 = \ ((_lhsIo_sem) :: Bool) -> _lhsIo_sem {-# INLINE rule203 #-} rule203 = \ ((_lhsIo_sig) :: Bool) -> _lhsIo_sig {-# INLINE rule204 #-} rule204 = \ ((_lhsIo_unbox) :: Bool) -> _lhsIo_unbox {-# INLINE rule205 #-} rule205 = \ ((_lhsIo_wantvisit) :: Bool) -> _lhsIo_wantvisit {-# INLINE rule206 #-} rule206 = \ ((_lhsIprefix) :: String) -> _lhsIprefix {-# INLINE rule207 #-} rule207 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# INLINE rule208 #-} rule208 = \ ((_hdIvcount) :: Int) -> _hdIvcount {-# NOINLINE sem_Nonterminals_Nil #-} sem_Nonterminals_Nil :: T_Nonterminals sem_Nonterminals_Nil = T_Nonterminals (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_Nonterminals_v16 v16 = \ (T_Nonterminals_vIn16 _lhsIacount _lhsIallnts _lhsIaroundMap _lhsIcInterfaceMap _lhsIcVisitsMap _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsIo_case _lhsIo_cata _lhsIo_data _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIsynMap _lhsIvcount) -> ( let _lhsOcNonterminals :: CNonterminals _lhsOcNonterminals = rule209 () _lhsOadditionalDep :: Seq Edge _lhsOadditionalDep = rule210 () _lhsOaranges :: Seq (Int,Int,Int) _lhsOaranges = rule211 () _lhsOaroundDep :: Seq Edge _lhsOaroundDep = rule212 () _lhsOdirectDep :: Seq Edge _lhsOdirectDep = rule213 () _lhsOerrors :: Seq Error _lhsOerrors = rule214 () _lhsOinhMap' :: Map Identifier Attributes _lhsOinhMap' = rule215 () _lhsOinstDep :: Seq Edge _lhsOinstDep = rule216 () _lhsOmergeDep :: Seq Edge _lhsOmergeDep = rule217 () _lhsOnAutoRules :: Int _lhsOnAutoRules = rule218 () _lhsOnExplicitRules :: Int _lhsOnExplicitRules = rule219 () _lhsOnonts :: [(NontermIdent,[ConstructorIdent])] _lhsOnonts = rule220 () _lhsOntattrs :: Seq (Vertex,NTAttr) _lhsOntattrs = rule221 () _lhsOrules :: Seq (Vertex,CRule) _lhsOrules = rule222 () _lhsOsynMap' :: Map Identifier Attributes _lhsOsynMap' = rule223 () _lhsOacount :: Int _lhsOacount = rule224 _lhsIacount _lhsOvcount :: Int _lhsOvcount = rule225 _lhsIvcount __result_ = T_Nonterminals_vOut16 _lhsOacount _lhsOadditionalDep _lhsOaranges _lhsOaroundDep _lhsOcNonterminals _lhsOdirectDep _lhsOerrors _lhsOinhMap' _lhsOinstDep _lhsOmergeDep _lhsOnAutoRules _lhsOnExplicitRules _lhsOnonts _lhsOntattrs _lhsOrules _lhsOsynMap' _lhsOvcount in __result_ ) in C_Nonterminals_s17 v16 {-# INLINE rule209 #-} {-# LINE 623 "./src-ag/Order.ag" #-} rule209 = \ (_ :: ()) -> {-# LINE 623 "./src-ag/Order.ag" #-} [] {-# LINE 1739 "dist/build/Order.hs"#-} {-# INLINE rule210 #-} rule210 = \ (_ :: ()) -> Seq.empty {-# INLINE rule211 #-} rule211 = \ (_ :: ()) -> Seq.empty {-# INLINE rule212 #-} rule212 = \ (_ :: ()) -> Seq.empty {-# INLINE rule213 #-} rule213 = \ (_ :: ()) -> Seq.empty {-# INLINE rule214 #-} rule214 = \ (_ :: ()) -> Seq.empty {-# INLINE rule215 #-} rule215 = \ (_ :: ()) -> Map.empty {-# INLINE rule216 #-} rule216 = \ (_ :: ()) -> Seq.empty {-# INLINE rule217 #-} rule217 = \ (_ :: ()) -> Seq.empty {-# INLINE rule218 #-} rule218 = \ (_ :: ()) -> 0 {-# INLINE rule219 #-} rule219 = \ (_ :: ()) -> 0 {-# INLINE rule220 #-} rule220 = \ (_ :: ()) -> [] {-# INLINE rule221 #-} rule221 = \ (_ :: ()) -> Seq.empty {-# INLINE rule222 #-} rule222 = \ (_ :: ()) -> Seq.empty {-# INLINE rule223 #-} rule223 = \ (_ :: ()) -> Map.empty {-# INLINE rule224 #-} rule224 = \ ((_lhsIacount) :: Int) -> _lhsIacount {-# INLINE rule225 #-} rule225 = \ ((_lhsIvcount) :: Int) -> _lhsIvcount -- Pattern ----------------------------------------------------- -- wrapper data Inh_Pattern = Inh_Pattern { allTypeSigs_Inh_Pattern :: (Map Identifier Type), altAttrs_Inh_Pattern :: (Map AltAttr Vertex), con_Inh_Pattern :: (Identifier), inh_Inh_Pattern :: (Attributes), nt_Inh_Pattern :: (Identifier), syn_Inh_Pattern :: (Attributes) } data Syn_Pattern = Syn_Pattern { copy_Syn_Pattern :: (Pattern), errors_Syn_Pattern :: (Seq Error), gathAltAttrs_Syn_Pattern :: ([AltAttr]), instVars_Syn_Pattern :: ([Identifier]), locVars_Syn_Pattern :: ([Identifier]), patternAttrs_Syn_Pattern :: ([(Identifier,Identifier,Bool)]) } {-# INLINABLE wrap_Pattern #-} wrap_Pattern :: T_Pattern -> Inh_Pattern -> (Syn_Pattern ) wrap_Pattern (T_Pattern act) (Inh_Pattern _lhsIallTypeSigs _lhsIaltAttrs _lhsIcon _lhsIinh _lhsInt _lhsIsyn) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Pattern_vIn19 _lhsIallTypeSigs _lhsIaltAttrs _lhsIcon _lhsIinh _lhsInt _lhsIsyn (T_Pattern_vOut19 _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOlocVars _lhsOpatternAttrs) <- return (inv_Pattern_s20 sem arg) return (Syn_Pattern _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOlocVars _lhsOpatternAttrs) ) -- cata {-# NOINLINE sem_Pattern #-} sem_Pattern :: Pattern -> T_Pattern sem_Pattern ( Constr name_ pats_ ) = sem_Pattern_Constr name_ ( sem_Patterns pats_ ) sem_Pattern ( Product pos_ pats_ ) = sem_Pattern_Product pos_ ( sem_Patterns pats_ ) sem_Pattern ( Alias field_ attr_ pat_ ) = sem_Pattern_Alias field_ attr_ ( sem_Pattern pat_ ) sem_Pattern ( Irrefutable pat_ ) = sem_Pattern_Irrefutable ( sem_Pattern pat_ ) sem_Pattern ( Underscore pos_ ) = sem_Pattern_Underscore pos_ -- semantic domain newtype T_Pattern = T_Pattern { attach_T_Pattern :: Identity (T_Pattern_s20 ) } newtype T_Pattern_s20 = C_Pattern_s20 { inv_Pattern_s20 :: (T_Pattern_v19 ) } data T_Pattern_s21 = C_Pattern_s21 type T_Pattern_v19 = (T_Pattern_vIn19 ) -> (T_Pattern_vOut19 ) data T_Pattern_vIn19 = T_Pattern_vIn19 (Map Identifier Type) (Map AltAttr Vertex) (Identifier) (Attributes) (Identifier) (Attributes) data T_Pattern_vOut19 = T_Pattern_vOut19 (Pattern) (Seq Error) ([AltAttr]) ([Identifier]) ([Identifier]) ([(Identifier,Identifier,Bool)]) {-# NOINLINE sem_Pattern_Constr #-} sem_Pattern_Constr :: (ConstructorIdent) -> T_Patterns -> T_Pattern sem_Pattern_Constr arg_name_ arg_pats_ = T_Pattern (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_Pattern_v19 v19 = \ (T_Pattern_vIn19 _lhsIallTypeSigs _lhsIaltAttrs _lhsIcon _lhsIinh _lhsInt _lhsIsyn) -> ( let _patsX23 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) (T_Patterns_vOut22 _patsIcopy _patsIerrors _patsIgathAltAttrs _patsIinstVars _patsIlocVars _patsIpatternAttrs) = inv_Patterns_s23 _patsX23 (T_Patterns_vIn22 _patsOallTypeSigs _patsOaltAttrs _patsOcon _patsOinh _patsOnt _patsOsyn) _lhsOerrors :: Seq Error _lhsOerrors = rule226 _patsIerrors _lhsOgathAltAttrs :: [AltAttr] _lhsOgathAltAttrs = rule227 _patsIgathAltAttrs _lhsOinstVars :: [Identifier] _lhsOinstVars = rule228 _patsIinstVars _lhsOlocVars :: [Identifier] _lhsOlocVars = rule229 _patsIlocVars _lhsOpatternAttrs :: [(Identifier,Identifier,Bool)] _lhsOpatternAttrs = rule230 _patsIpatternAttrs _copy = rule231 _patsIcopy arg_name_ _lhsOcopy :: Pattern _lhsOcopy = rule232 _copy _patsOallTypeSigs = rule233 _lhsIallTypeSigs _patsOaltAttrs = rule234 _lhsIaltAttrs _patsOcon = rule235 _lhsIcon _patsOinh = rule236 _lhsIinh _patsOnt = rule237 _lhsInt _patsOsyn = rule238 _lhsIsyn __result_ = T_Pattern_vOut19 _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOlocVars _lhsOpatternAttrs in __result_ ) in C_Pattern_s20 v19 {-# INLINE rule226 #-} rule226 = \ ((_patsIerrors) :: Seq Error) -> _patsIerrors {-# INLINE rule227 #-} rule227 = \ ((_patsIgathAltAttrs) :: [AltAttr]) -> _patsIgathAltAttrs {-# INLINE rule228 #-} rule228 = \ ((_patsIinstVars) :: [Identifier]) -> _patsIinstVars {-# INLINE rule229 #-} rule229 = \ ((_patsIlocVars) :: [Identifier]) -> _patsIlocVars {-# INLINE rule230 #-} rule230 = \ ((_patsIpatternAttrs) :: [(Identifier,Identifier,Bool)]) -> _patsIpatternAttrs {-# INLINE rule231 #-} rule231 = \ ((_patsIcopy) :: Patterns) name_ -> Constr name_ _patsIcopy {-# INLINE rule232 #-} rule232 = \ _copy -> _copy {-# INLINE rule233 #-} rule233 = \ ((_lhsIallTypeSigs) :: Map Identifier Type) -> _lhsIallTypeSigs {-# INLINE rule234 #-} rule234 = \ ((_lhsIaltAttrs) :: Map AltAttr Vertex) -> _lhsIaltAttrs {-# INLINE rule235 #-} rule235 = \ ((_lhsIcon) :: Identifier) -> _lhsIcon {-# INLINE rule236 #-} rule236 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule237 #-} rule237 = \ ((_lhsInt) :: Identifier) -> _lhsInt {-# INLINE rule238 #-} rule238 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# NOINLINE sem_Pattern_Product #-} sem_Pattern_Product :: (Pos) -> T_Patterns -> T_Pattern sem_Pattern_Product arg_pos_ arg_pats_ = T_Pattern (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_Pattern_v19 v19 = \ (T_Pattern_vIn19 _lhsIallTypeSigs _lhsIaltAttrs _lhsIcon _lhsIinh _lhsInt _lhsIsyn) -> ( let _patsX23 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) (T_Patterns_vOut22 _patsIcopy _patsIerrors _patsIgathAltAttrs _patsIinstVars _patsIlocVars _patsIpatternAttrs) = inv_Patterns_s23 _patsX23 (T_Patterns_vIn22 _patsOallTypeSigs _patsOaltAttrs _patsOcon _patsOinh _patsOnt _patsOsyn) _lhsOerrors :: Seq Error _lhsOerrors = rule239 _patsIerrors _lhsOgathAltAttrs :: [AltAttr] _lhsOgathAltAttrs = rule240 _patsIgathAltAttrs _lhsOinstVars :: [Identifier] _lhsOinstVars = rule241 _patsIinstVars _lhsOlocVars :: [Identifier] _lhsOlocVars = rule242 _patsIlocVars _lhsOpatternAttrs :: [(Identifier,Identifier,Bool)] _lhsOpatternAttrs = rule243 _patsIpatternAttrs _copy = rule244 _patsIcopy arg_pos_ _lhsOcopy :: Pattern _lhsOcopy = rule245 _copy _patsOallTypeSigs = rule246 _lhsIallTypeSigs _patsOaltAttrs = rule247 _lhsIaltAttrs _patsOcon = rule248 _lhsIcon _patsOinh = rule249 _lhsIinh _patsOnt = rule250 _lhsInt _patsOsyn = rule251 _lhsIsyn __result_ = T_Pattern_vOut19 _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOlocVars _lhsOpatternAttrs in __result_ ) in C_Pattern_s20 v19 {-# INLINE rule239 #-} rule239 = \ ((_patsIerrors) :: Seq Error) -> _patsIerrors {-# INLINE rule240 #-} rule240 = \ ((_patsIgathAltAttrs) :: [AltAttr]) -> _patsIgathAltAttrs {-# INLINE rule241 #-} rule241 = \ ((_patsIinstVars) :: [Identifier]) -> _patsIinstVars {-# INLINE rule242 #-} rule242 = \ ((_patsIlocVars) :: [Identifier]) -> _patsIlocVars {-# INLINE rule243 #-} rule243 = \ ((_patsIpatternAttrs) :: [(Identifier,Identifier,Bool)]) -> _patsIpatternAttrs {-# INLINE rule244 #-} rule244 = \ ((_patsIcopy) :: Patterns) pos_ -> Product pos_ _patsIcopy {-# INLINE rule245 #-} rule245 = \ _copy -> _copy {-# INLINE rule246 #-} rule246 = \ ((_lhsIallTypeSigs) :: Map Identifier Type) -> _lhsIallTypeSigs {-# INLINE rule247 #-} rule247 = \ ((_lhsIaltAttrs) :: Map AltAttr Vertex) -> _lhsIaltAttrs {-# INLINE rule248 #-} rule248 = \ ((_lhsIcon) :: Identifier) -> _lhsIcon {-# INLINE rule249 #-} rule249 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule250 #-} rule250 = \ ((_lhsInt) :: Identifier) -> _lhsInt {-# INLINE rule251 #-} rule251 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# NOINLINE sem_Pattern_Alias #-} sem_Pattern_Alias :: (Identifier) -> (Identifier) -> T_Pattern -> T_Pattern sem_Pattern_Alias arg_field_ arg_attr_ arg_pat_ = T_Pattern (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_Pattern_v19 v19 = \ (T_Pattern_vIn19 _lhsIallTypeSigs _lhsIaltAttrs _lhsIcon _lhsIinh _lhsInt _lhsIsyn) -> ( let _patX20 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) (T_Pattern_vOut19 _patIcopy _patIerrors _patIgathAltAttrs _patIinstVars _patIlocVars _patIpatternAttrs) = inv_Pattern_s20 _patX20 (T_Pattern_vIn19 _patOallTypeSigs _patOaltAttrs _patOcon _patOinh _patOnt _patOsyn) _lhsOgathAltAttrs :: [AltAttr] _lhsOgathAltAttrs = rule252 arg_attr_ arg_field_ _lhsOpatternAttrs :: [(Identifier,Identifier,Bool)] _lhsOpatternAttrs = rule253 arg_attr_ arg_field_ _lhsOlocVars :: [Identifier] _lhsOlocVars = rule254 arg_attr_ arg_field_ _lhsOinstVars :: [Identifier] _lhsOinstVars = rule255 arg_attr_ arg_field_ _lhsOerrors :: Seq Error _lhsOerrors = rule256 _patIerrors _copy = rule257 _patIcopy arg_attr_ arg_field_ _lhsOcopy :: Pattern _lhsOcopy = rule258 _copy _patOallTypeSigs = rule259 _lhsIallTypeSigs _patOaltAttrs = rule260 _lhsIaltAttrs _patOcon = rule261 _lhsIcon _patOinh = rule262 _lhsIinh _patOnt = rule263 _lhsInt _patOsyn = rule264 _lhsIsyn __result_ = T_Pattern_vOut19 _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOlocVars _lhsOpatternAttrs in __result_ ) in C_Pattern_s20 v19 {-# INLINE rule252 #-} {-# LINE 185 "./src-ag/Order.ag" #-} rule252 = \ attr_ field_ -> {-# LINE 185 "./src-ag/Order.ag" #-} [AltAttr field_ attr_ (field_ == _LOC || field_ == _INST)] {-# LINE 1999 "dist/build/Order.hs"#-} {-# INLINE rule253 #-} {-# LINE 251 "./src-ag/Order.ag" #-} rule253 = \ attr_ field_ -> {-# LINE 251 "./src-ag/Order.ag" #-} [(field_,attr_,(field_ == _LOC || field_ == _INST))] {-# LINE 2005 "dist/build/Order.hs"#-} {-# INLINE rule254 #-} {-# LINE 681 "./src-ag/Order.ag" #-} rule254 = \ attr_ field_ -> {-# LINE 681 "./src-ag/Order.ag" #-} if field_ == _LOC then [attr_] else [] {-# LINE 2013 "dist/build/Order.hs"#-} {-# INLINE rule255 #-} {-# LINE 684 "./src-ag/Order.ag" #-} rule255 = \ attr_ field_ -> {-# LINE 684 "./src-ag/Order.ag" #-} if field_ == _INST then [attr_] else [] {-# LINE 2021 "dist/build/Order.hs"#-} {-# INLINE rule256 #-} rule256 = \ ((_patIerrors) :: Seq Error) -> _patIerrors {-# INLINE rule257 #-} rule257 = \ ((_patIcopy) :: Pattern) attr_ field_ -> Alias field_ attr_ _patIcopy {-# INLINE rule258 #-} rule258 = \ _copy -> _copy {-# INLINE rule259 #-} rule259 = \ ((_lhsIallTypeSigs) :: Map Identifier Type) -> _lhsIallTypeSigs {-# INLINE rule260 #-} rule260 = \ ((_lhsIaltAttrs) :: Map AltAttr Vertex) -> _lhsIaltAttrs {-# INLINE rule261 #-} rule261 = \ ((_lhsIcon) :: Identifier) -> _lhsIcon {-# INLINE rule262 #-} rule262 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule263 #-} rule263 = \ ((_lhsInt) :: Identifier) -> _lhsInt {-# INLINE rule264 #-} rule264 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# NOINLINE sem_Pattern_Irrefutable #-} sem_Pattern_Irrefutable :: T_Pattern -> T_Pattern sem_Pattern_Irrefutable arg_pat_ = T_Pattern (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_Pattern_v19 v19 = \ (T_Pattern_vIn19 _lhsIallTypeSigs _lhsIaltAttrs _lhsIcon _lhsIinh _lhsInt _lhsIsyn) -> ( let _patX20 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) (T_Pattern_vOut19 _patIcopy _patIerrors _patIgathAltAttrs _patIinstVars _patIlocVars _patIpatternAttrs) = inv_Pattern_s20 _patX20 (T_Pattern_vIn19 _patOallTypeSigs _patOaltAttrs _patOcon _patOinh _patOnt _patOsyn) _lhsOerrors :: Seq Error _lhsOerrors = rule265 _patIerrors _lhsOgathAltAttrs :: [AltAttr] _lhsOgathAltAttrs = rule266 _patIgathAltAttrs _lhsOinstVars :: [Identifier] _lhsOinstVars = rule267 _patIinstVars _lhsOlocVars :: [Identifier] _lhsOlocVars = rule268 _patIlocVars _lhsOpatternAttrs :: [(Identifier,Identifier,Bool)] _lhsOpatternAttrs = rule269 _patIpatternAttrs _copy = rule270 _patIcopy _lhsOcopy :: Pattern _lhsOcopy = rule271 _copy _patOallTypeSigs = rule272 _lhsIallTypeSigs _patOaltAttrs = rule273 _lhsIaltAttrs _patOcon = rule274 _lhsIcon _patOinh = rule275 _lhsIinh _patOnt = rule276 _lhsInt _patOsyn = rule277 _lhsIsyn __result_ = T_Pattern_vOut19 _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOlocVars _lhsOpatternAttrs in __result_ ) in C_Pattern_s20 v19 {-# INLINE rule265 #-} rule265 = \ ((_patIerrors) :: Seq Error) -> _patIerrors {-# INLINE rule266 #-} rule266 = \ ((_patIgathAltAttrs) :: [AltAttr]) -> _patIgathAltAttrs {-# INLINE rule267 #-} rule267 = \ ((_patIinstVars) :: [Identifier]) -> _patIinstVars {-# INLINE rule268 #-} rule268 = \ ((_patIlocVars) :: [Identifier]) -> _patIlocVars {-# INLINE rule269 #-} rule269 = \ ((_patIpatternAttrs) :: [(Identifier,Identifier,Bool)]) -> _patIpatternAttrs {-# INLINE rule270 #-} rule270 = \ ((_patIcopy) :: Pattern) -> Irrefutable _patIcopy {-# INLINE rule271 #-} rule271 = \ _copy -> _copy {-# INLINE rule272 #-} rule272 = \ ((_lhsIallTypeSigs) :: Map Identifier Type) -> _lhsIallTypeSigs {-# INLINE rule273 #-} rule273 = \ ((_lhsIaltAttrs) :: Map AltAttr Vertex) -> _lhsIaltAttrs {-# INLINE rule274 #-} rule274 = \ ((_lhsIcon) :: Identifier) -> _lhsIcon {-# INLINE rule275 #-} rule275 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule276 #-} rule276 = \ ((_lhsInt) :: Identifier) -> _lhsInt {-# INLINE rule277 #-} rule277 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# NOINLINE sem_Pattern_Underscore #-} sem_Pattern_Underscore :: (Pos) -> T_Pattern sem_Pattern_Underscore arg_pos_ = T_Pattern (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_Pattern_v19 v19 = \ (T_Pattern_vIn19 _lhsIallTypeSigs _lhsIaltAttrs _lhsIcon _lhsIinh _lhsInt _lhsIsyn) -> ( let _lhsOerrors :: Seq Error _lhsOerrors = rule278 () _lhsOgathAltAttrs :: [AltAttr] _lhsOgathAltAttrs = rule279 () _lhsOinstVars :: [Identifier] _lhsOinstVars = rule280 () _lhsOlocVars :: [Identifier] _lhsOlocVars = rule281 () _lhsOpatternAttrs :: [(Identifier,Identifier,Bool)] _lhsOpatternAttrs = rule282 () _copy = rule283 arg_pos_ _lhsOcopy :: Pattern _lhsOcopy = rule284 _copy __result_ = T_Pattern_vOut19 _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOlocVars _lhsOpatternAttrs in __result_ ) in C_Pattern_s20 v19 {-# INLINE rule278 #-} rule278 = \ (_ :: ()) -> Seq.empty {-# INLINE rule279 #-} rule279 = \ (_ :: ()) -> [] {-# INLINE rule280 #-} rule280 = \ (_ :: ()) -> [] {-# INLINE rule281 #-} rule281 = \ (_ :: ()) -> [] {-# INLINE rule282 #-} rule282 = \ (_ :: ()) -> [] {-# INLINE rule283 #-} rule283 = \ pos_ -> Underscore pos_ {-# INLINE rule284 #-} rule284 = \ _copy -> _copy -- Patterns ---------------------------------------------------- -- wrapper data Inh_Patterns = Inh_Patterns { allTypeSigs_Inh_Patterns :: (Map Identifier Type), altAttrs_Inh_Patterns :: (Map AltAttr Vertex), con_Inh_Patterns :: (Identifier), inh_Inh_Patterns :: (Attributes), nt_Inh_Patterns :: (Identifier), syn_Inh_Patterns :: (Attributes) } data Syn_Patterns = Syn_Patterns { copy_Syn_Patterns :: (Patterns), errors_Syn_Patterns :: (Seq Error), gathAltAttrs_Syn_Patterns :: ([AltAttr]), instVars_Syn_Patterns :: ([Identifier]), locVars_Syn_Patterns :: ([Identifier]), patternAttrs_Syn_Patterns :: ([(Identifier,Identifier,Bool)]) } {-# INLINABLE wrap_Patterns #-} wrap_Patterns :: T_Patterns -> Inh_Patterns -> (Syn_Patterns ) wrap_Patterns (T_Patterns act) (Inh_Patterns _lhsIallTypeSigs _lhsIaltAttrs _lhsIcon _lhsIinh _lhsInt _lhsIsyn) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Patterns_vIn22 _lhsIallTypeSigs _lhsIaltAttrs _lhsIcon _lhsIinh _lhsInt _lhsIsyn (T_Patterns_vOut22 _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOlocVars _lhsOpatternAttrs) <- return (inv_Patterns_s23 sem arg) return (Syn_Patterns _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOlocVars _lhsOpatternAttrs) ) -- cata {-# NOINLINE sem_Patterns #-} sem_Patterns :: Patterns -> T_Patterns sem_Patterns list = Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list) -- semantic domain newtype T_Patterns = T_Patterns { attach_T_Patterns :: Identity (T_Patterns_s23 ) } newtype T_Patterns_s23 = C_Patterns_s23 { inv_Patterns_s23 :: (T_Patterns_v22 ) } data T_Patterns_s24 = C_Patterns_s24 type T_Patterns_v22 = (T_Patterns_vIn22 ) -> (T_Patterns_vOut22 ) data T_Patterns_vIn22 = T_Patterns_vIn22 (Map Identifier Type) (Map AltAttr Vertex) (Identifier) (Attributes) (Identifier) (Attributes) data T_Patterns_vOut22 = T_Patterns_vOut22 (Patterns) (Seq Error) ([AltAttr]) ([Identifier]) ([Identifier]) ([(Identifier,Identifier,Bool)]) {-# NOINLINE sem_Patterns_Cons #-} sem_Patterns_Cons :: T_Pattern -> T_Patterns -> T_Patterns sem_Patterns_Cons arg_hd_ arg_tl_ = T_Patterns (return st23) where {-# NOINLINE st23 #-} st23 = let v22 :: T_Patterns_v22 v22 = \ (T_Patterns_vIn22 _lhsIallTypeSigs _lhsIaltAttrs _lhsIcon _lhsIinh _lhsInt _lhsIsyn) -> ( let _hdX20 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_hd_)) _tlX23 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_tl_)) (T_Pattern_vOut19 _hdIcopy _hdIerrors _hdIgathAltAttrs _hdIinstVars _hdIlocVars _hdIpatternAttrs) = inv_Pattern_s20 _hdX20 (T_Pattern_vIn19 _hdOallTypeSigs _hdOaltAttrs _hdOcon _hdOinh _hdOnt _hdOsyn) (T_Patterns_vOut22 _tlIcopy _tlIerrors _tlIgathAltAttrs _tlIinstVars _tlIlocVars _tlIpatternAttrs) = inv_Patterns_s23 _tlX23 (T_Patterns_vIn22 _tlOallTypeSigs _tlOaltAttrs _tlOcon _tlOinh _tlOnt _tlOsyn) _lhsOerrors :: Seq Error _lhsOerrors = rule285 _hdIerrors _tlIerrors _lhsOgathAltAttrs :: [AltAttr] _lhsOgathAltAttrs = rule286 _hdIgathAltAttrs _tlIgathAltAttrs _lhsOinstVars :: [Identifier] _lhsOinstVars = rule287 _hdIinstVars _tlIinstVars _lhsOlocVars :: [Identifier] _lhsOlocVars = rule288 _hdIlocVars _tlIlocVars _lhsOpatternAttrs :: [(Identifier,Identifier,Bool)] _lhsOpatternAttrs = rule289 _hdIpatternAttrs _tlIpatternAttrs _copy = rule290 _hdIcopy _tlIcopy _lhsOcopy :: Patterns _lhsOcopy = rule291 _copy _hdOallTypeSigs = rule292 _lhsIallTypeSigs _hdOaltAttrs = rule293 _lhsIaltAttrs _hdOcon = rule294 _lhsIcon _hdOinh = rule295 _lhsIinh _hdOnt = rule296 _lhsInt _hdOsyn = rule297 _lhsIsyn _tlOallTypeSigs = rule298 _lhsIallTypeSigs _tlOaltAttrs = rule299 _lhsIaltAttrs _tlOcon = rule300 _lhsIcon _tlOinh = rule301 _lhsIinh _tlOnt = rule302 _lhsInt _tlOsyn = rule303 _lhsIsyn __result_ = T_Patterns_vOut22 _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOlocVars _lhsOpatternAttrs in __result_ ) in C_Patterns_s23 v22 {-# INLINE rule285 #-} rule285 = \ ((_hdIerrors) :: Seq Error) ((_tlIerrors) :: Seq Error) -> _hdIerrors Seq.>< _tlIerrors {-# INLINE rule286 #-} rule286 = \ ((_hdIgathAltAttrs) :: [AltAttr]) ((_tlIgathAltAttrs) :: [AltAttr]) -> _hdIgathAltAttrs ++ _tlIgathAltAttrs {-# INLINE rule287 #-} rule287 = \ ((_hdIinstVars) :: [Identifier]) ((_tlIinstVars) :: [Identifier]) -> _hdIinstVars ++ _tlIinstVars {-# INLINE rule288 #-} rule288 = \ ((_hdIlocVars) :: [Identifier]) ((_tlIlocVars) :: [Identifier]) -> _hdIlocVars ++ _tlIlocVars {-# INLINE rule289 #-} rule289 = \ ((_hdIpatternAttrs) :: [(Identifier,Identifier,Bool)]) ((_tlIpatternAttrs) :: [(Identifier,Identifier,Bool)]) -> _hdIpatternAttrs ++ _tlIpatternAttrs {-# INLINE rule290 #-} rule290 = \ ((_hdIcopy) :: Pattern) ((_tlIcopy) :: Patterns) -> (:) _hdIcopy _tlIcopy {-# INLINE rule291 #-} rule291 = \ _copy -> _copy {-# INLINE rule292 #-} rule292 = \ ((_lhsIallTypeSigs) :: Map Identifier Type) -> _lhsIallTypeSigs {-# INLINE rule293 #-} rule293 = \ ((_lhsIaltAttrs) :: Map AltAttr Vertex) -> _lhsIaltAttrs {-# INLINE rule294 #-} rule294 = \ ((_lhsIcon) :: Identifier) -> _lhsIcon {-# INLINE rule295 #-} rule295 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule296 #-} rule296 = \ ((_lhsInt) :: Identifier) -> _lhsInt {-# INLINE rule297 #-} rule297 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# INLINE rule298 #-} rule298 = \ ((_lhsIallTypeSigs) :: Map Identifier Type) -> _lhsIallTypeSigs {-# INLINE rule299 #-} rule299 = \ ((_lhsIaltAttrs) :: Map AltAttr Vertex) -> _lhsIaltAttrs {-# INLINE rule300 #-} rule300 = \ ((_lhsIcon) :: Identifier) -> _lhsIcon {-# INLINE rule301 #-} rule301 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule302 #-} rule302 = \ ((_lhsInt) :: Identifier) -> _lhsInt {-# INLINE rule303 #-} rule303 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# NOINLINE sem_Patterns_Nil #-} sem_Patterns_Nil :: T_Patterns sem_Patterns_Nil = T_Patterns (return st23) where {-# NOINLINE st23 #-} st23 = let v22 :: T_Patterns_v22 v22 = \ (T_Patterns_vIn22 _lhsIallTypeSigs _lhsIaltAttrs _lhsIcon _lhsIinh _lhsInt _lhsIsyn) -> ( let _lhsOerrors :: Seq Error _lhsOerrors = rule304 () _lhsOgathAltAttrs :: [AltAttr] _lhsOgathAltAttrs = rule305 () _lhsOinstVars :: [Identifier] _lhsOinstVars = rule306 () _lhsOlocVars :: [Identifier] _lhsOlocVars = rule307 () _lhsOpatternAttrs :: [(Identifier,Identifier,Bool)] _lhsOpatternAttrs = rule308 () _copy = rule309 () _lhsOcopy :: Patterns _lhsOcopy = rule310 _copy __result_ = T_Patterns_vOut22 _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOlocVars _lhsOpatternAttrs in __result_ ) in C_Patterns_s23 v22 {-# INLINE rule304 #-} rule304 = \ (_ :: ()) -> Seq.empty {-# INLINE rule305 #-} rule305 = \ (_ :: ()) -> [] {-# INLINE rule306 #-} rule306 = \ (_ :: ()) -> [] {-# INLINE rule307 #-} rule307 = \ (_ :: ()) -> [] {-# INLINE rule308 #-} rule308 = \ (_ :: ()) -> [] {-# INLINE rule309 #-} rule309 = \ (_ :: ()) -> [] {-# INLINE rule310 #-} rule310 = \ _copy -> _copy -- Production -------------------------------------------------- -- wrapper data Inh_Production = Inh_Production { allnts_Inh_Production :: ([Identifier]), aroundMap_Inh_Production :: (Map ConstructorIdent (Map Identifier [Expression])), cVisitsMap_Inh_Production :: (CVisitsMap), inh_Inh_Production :: (Attributes), inhMap_Inh_Production :: (Map Identifier Attributes), manualAttrDepMap_Inh_Production :: (AttrOrderMap), mergeMap_Inh_Production :: (Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))), nt_Inh_Production :: (Identifier), o_case_Inh_Production :: (Bool), o_cata_Inh_Production :: (Bool), o_dovisit_Inh_Production :: (Bool), o_newtypes_Inh_Production :: (Bool), o_rename_Inh_Production :: (Bool), o_sem_Inh_Production :: (Bool), o_sig_Inh_Production :: (Bool), o_unbox_Inh_Production :: (Bool), o_wantvisit_Inh_Production :: (Bool), prefix_Inh_Production :: (String), syn_Inh_Production :: (Attributes), synMap_Inh_Production :: (Map Identifier Attributes), vcount_Inh_Production :: (Int) } data Syn_Production = Syn_Production { additionalDep_Syn_Production :: (Seq Edge), aroundDep_Syn_Production :: (Seq Edge), cProduction_Syn_Production :: (CProduction), cons_Syn_Production :: ([ConstructorIdent]), directDep_Syn_Production :: (Seq Edge), errors_Syn_Production :: (Seq Error), instDep_Syn_Production :: (Seq Edge), mergeDep_Syn_Production :: (Seq Edge), nAutoRules_Syn_Production :: (Int), nExplicitRules_Syn_Production :: (Int), rules_Syn_Production :: (Seq (Vertex,CRule)), vcount_Syn_Production :: (Int) } {-# INLINABLE wrap_Production #-} wrap_Production :: T_Production -> Inh_Production -> (Syn_Production ) wrap_Production (T_Production act) (Inh_Production _lhsIallnts _lhsIaroundMap _lhsIcVisitsMap _lhsIinh _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIsynMap _lhsIvcount) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Production_vIn25 _lhsIallnts _lhsIaroundMap _lhsIcVisitsMap _lhsIinh _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIsynMap _lhsIvcount (T_Production_vOut25 _lhsOadditionalDep _lhsOaroundDep _lhsOcProduction _lhsOcons _lhsOdirectDep _lhsOerrors _lhsOinstDep _lhsOmergeDep _lhsOnAutoRules _lhsOnExplicitRules _lhsOrules _lhsOvcount) <- return (inv_Production_s26 sem arg) return (Syn_Production _lhsOadditionalDep _lhsOaroundDep _lhsOcProduction _lhsOcons _lhsOdirectDep _lhsOerrors _lhsOinstDep _lhsOmergeDep _lhsOnAutoRules _lhsOnExplicitRules _lhsOrules _lhsOvcount) ) -- cata {-# INLINE sem_Production #-} sem_Production :: Production -> T_Production sem_Production ( Production con_ params_ constraints_ children_ rules_ typeSigs_ macro_ ) = sem_Production_Production con_ params_ constraints_ ( sem_Children children_ ) ( sem_Rules rules_ ) ( sem_TypeSigs typeSigs_ ) macro_ -- semantic domain newtype T_Production = T_Production { attach_T_Production :: Identity (T_Production_s26 ) } newtype T_Production_s26 = C_Production_s26 { inv_Production_s26 :: (T_Production_v25 ) } data T_Production_s27 = C_Production_s27 type T_Production_v25 = (T_Production_vIn25 ) -> (T_Production_vOut25 ) data T_Production_vIn25 = T_Production_vIn25 ([Identifier]) (Map ConstructorIdent (Map Identifier [Expression])) (CVisitsMap) (Attributes) (Map Identifier Attributes) (AttrOrderMap) (Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))) (Identifier) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (String) (Attributes) (Map Identifier Attributes) (Int) data T_Production_vOut25 = T_Production_vOut25 (Seq Edge) (Seq Edge) (CProduction) ([ConstructorIdent]) (Seq Edge) (Seq Error) (Seq Edge) (Seq Edge) (Int) (Int) (Seq (Vertex,CRule)) (Int) {-# NOINLINE sem_Production_Production #-} sem_Production_Production :: (ConstructorIdent) -> ([Identifier]) -> ([Type]) -> T_Children -> T_Rules -> T_TypeSigs -> (MaybeMacro) -> T_Production sem_Production_Production arg_con_ _ _ arg_children_ arg_rules_ arg_typeSigs_ _ = T_Production (return st26) where {-# NOINLINE st26 #-} st26 = let v25 :: T_Production_v25 v25 = \ (T_Production_vIn25 _lhsIallnts _lhsIaroundMap _lhsIcVisitsMap _lhsIinh _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIsynMap _lhsIvcount) -> ( let _childrenX5 = Control.Monad.Identity.runIdentity (attach_T_Children (arg_children_)) _rulesX35 = Control.Monad.Identity.runIdentity (attach_T_Rules (arg_rules_)) _typeSigsX41 = Control.Monad.Identity.runIdentity (attach_T_TypeSigs (arg_typeSigs_)) (T_Children_vOut4 _childrenIattributes _childrenIcollectChildrenInhs _childrenIcollectChildrenSyns _childrenIerrors _childrenIfields _childrenIgathAltAttrs _childrenIgathRules _childrenIinhs _childrenInts _childrenIsinglevisits _childrenIterminals) = inv_Children_s5 _childrenX5 (T_Children_vIn4 _childrenOallfields _childrenOallnts _childrenOattrs _childrenOcon _childrenOinh _childrenOinhMap _childrenOmergeMap _childrenOnt _childrenOo_unbox _childrenOsyn _childrenOsynMap) (T_Rules_vOut34 _rulesIdirectDep _rulesIerrors _rulesIgathAltAttrs _rulesIgathRules _rulesIinstDep _rulesIinstVars _rulesIlocVars _rulesInAutoRules _rulesInExplicitRules) = inv_Rules_s35 _rulesX35 (T_Rules_vIn34 _rulesOallTypeSigs _rulesOallfields _rulesOallnts _rulesOaltAttrs _rulesOattrs _rulesOchildInhs _rulesOchildNts _rulesOcon _rulesOinh _rulesOinhsOfChildren _rulesOmergeMap _rulesOnt _rulesOo_case _rulesOo_cata _rulesOo_dovisit _rulesOo_newtypes _rulesOo_rename _rulesOo_sem _rulesOo_sig _rulesOo_wantvisit _rulesOprefix _rulesOsyn _rulesOsynsOfChildren) (T_TypeSigs_vOut40 _typeSigsItypeSigs) = inv_TypeSigs_s41 _typeSigsX41 (T_TypeSigs_vIn40 _typeSigsOtypeSigs) _childrenOcon = rule311 arg_con_ _rulesOcon = rule312 arg_con_ _gathAltAttrs = rule313 _childrenIgathAltAttrs _lhsIinh _rulesIgathAltAttrs _altAttrs = rule314 _gathAltAttrs _lhsIvcount _rulesOchildNts = rule315 _childrenInts _rulesOchildInhs = rule316 _childrenIinhs _inhRules = rule317 _lhsIinh _lhsInt arg_con_ _gathRules = rule318 _childrenIgathRules _inhRules _rulesIgathRules _lhsOrules :: Seq (Vertex,CRule) _lhsOrules = rule319 _gathRules _lhsIvcount _lhsOvcount :: Int _lhsOvcount = rule320 _gathRules _lhsIvcount _manualDeps = rule321 _lhsImanualAttrDepMap _lhsInt arg_con_ _lhsOadditionalDep :: Seq Edge _lhsOadditionalDep = rule322 _altAttrs _manualDeps _rulesOsynsOfChildren = rule323 _childrenIcollectChildrenSyns _rulesOinhsOfChildren = rule324 _childrenIcollectChildrenInhs _mergeMap = rule325 _lhsImergeMap arg_con_ _lhsOmergeDep :: Seq Edge _lhsOmergeDep = rule326 _mergeDep1 _mergeDep2 _mergeDep1 = rule327 _altAttrs _childrenIcollectChildrenSyns _mergeMap _mergeDep2 = rule328 _altAttrs _childrenIcollectChildrenSyns _mergeMap _aroundMap = rule329 _lhsIaroundMap arg_con_ _aroundDep1 = rule330 _altAttrs _aroundMap _childrenIcollectChildrenSyns _aroundDep2 = rule331 _altAttrs _aroundMap _childrenIcollectChildrenInhs _lhsOaroundDep :: Seq Edge _lhsOaroundDep = rule332 _aroundDep1 _aroundDep2 _lhsOcons :: [ConstructorIdent] _lhsOcons = rule333 arg_con_ _typeSigsOtypeSigs = rule334 () _rulesOallTypeSigs = rule335 _typeSigsItypeSigs _cVisits = rule336 _childrenIsinglevisits _gathRules _lhsIcVisitsMap _lhsIinh _lhsInt _lhsIo_dovisit _lhsIsyn arg_con_ _lhsOcProduction :: CProduction _lhsOcProduction = rule337 _cVisits _childrenIfields _childrenIterminals arg_con_ _allfields = rule338 _childrenIfields _attrs = rule339 _childrenIattributes _inhnames _rulesIinstVars _rulesIlocVars _inhnames = rule340 _lhsIinh _synnames = rule341 _lhsIsyn _lhsOdirectDep :: Seq Edge _lhsOdirectDep = rule342 _rulesIdirectDep _lhsOerrors :: Seq Error _lhsOerrors = rule343 _childrenIerrors _rulesIerrors _lhsOinstDep :: Seq Edge _lhsOinstDep = rule344 _rulesIinstDep _lhsOnAutoRules :: Int _lhsOnAutoRules = rule345 _rulesInAutoRules _lhsOnExplicitRules :: Int _lhsOnExplicitRules = rule346 _rulesInExplicitRules _childrenOallfields = rule347 _allfields _childrenOallnts = rule348 _lhsIallnts _childrenOattrs = rule349 _attrs _childrenOinh = rule350 _lhsIinh _childrenOinhMap = rule351 _lhsIinhMap _childrenOmergeMap = rule352 _mergeMap _childrenOnt = rule353 _lhsInt _childrenOo_unbox = rule354 _lhsIo_unbox _childrenOsyn = rule355 _lhsIsyn _childrenOsynMap = rule356 _lhsIsynMap _rulesOallfields = rule357 _allfields _rulesOallnts = rule358 _lhsIallnts _rulesOaltAttrs = rule359 _altAttrs _rulesOattrs = rule360 _attrs _rulesOinh = rule361 _lhsIinh _rulesOmergeMap = rule362 _mergeMap _rulesOnt = rule363 _lhsInt _rulesOo_case = rule364 _lhsIo_case _rulesOo_cata = rule365 _lhsIo_cata _rulesOo_dovisit = rule366 _lhsIo_dovisit _rulesOo_newtypes = rule367 _lhsIo_newtypes _rulesOo_rename = rule368 _lhsIo_rename _rulesOo_sem = rule369 _lhsIo_sem _rulesOo_sig = rule370 _lhsIo_sig _rulesOo_wantvisit = rule371 _lhsIo_wantvisit _rulesOprefix = rule372 _lhsIprefix _rulesOsyn = rule373 _lhsIsyn __result_ = T_Production_vOut25 _lhsOadditionalDep _lhsOaroundDep _lhsOcProduction _lhsOcons _lhsOdirectDep _lhsOerrors _lhsOinstDep _lhsOmergeDep _lhsOnAutoRules _lhsOnExplicitRules _lhsOrules _lhsOvcount in __result_ ) in C_Production_s26 v25 {-# INLINE rule311 #-} {-# LINE 94 "./src-ag/Order.ag" #-} rule311 = \ con_ -> {-# LINE 94 "./src-ag/Order.ag" #-} con_ {-# LINE 2461 "dist/build/Order.hs"#-} {-# INLINE rule312 #-} {-# LINE 96 "./src-ag/Order.ag" #-} rule312 = \ con_ -> {-# LINE 96 "./src-ag/Order.ag" #-} con_ {-# LINE 2467 "dist/build/Order.hs"#-} {-# INLINE rule313 #-} {-# LINE 173 "./src-ag/Order.ag" #-} rule313 = \ ((_childrenIgathAltAttrs) :: [AltAttr]) ((_lhsIinh) :: Attributes) ((_rulesIgathAltAttrs) :: [AltAttr]) -> {-# LINE 173 "./src-ag/Order.ag" #-} [ AltAttr _LHS inh True | inh <- Map.keys _lhsIinh ] ++ _childrenIgathAltAttrs ++ _rulesIgathAltAttrs {-# LINE 2475 "dist/build/Order.hs"#-} {-# INLINE rule314 #-} {-# LINE 189 "./src-ag/Order.ag" #-} rule314 = \ _gathAltAttrs ((_lhsIvcount) :: Int) -> {-# LINE 189 "./src-ag/Order.ag" #-} Map.fromList (zip _gathAltAttrs [_lhsIvcount..]) {-# LINE 2481 "dist/build/Order.hs"#-} {-# INLINE rule315 #-} {-# LINE 202 "./src-ag/Order.ag" #-} rule315 = \ ((_childrenInts) :: Seq (Identifier,NontermIdent)) -> {-# LINE 202 "./src-ag/Order.ag" #-} Map.fromList (toList _childrenInts) {-# LINE 2487 "dist/build/Order.hs"#-} {-# INLINE rule316 #-} {-# LINE 203 "./src-ag/Order.ag" #-} rule316 = \ ((_childrenIinhs) :: Seq (Identifier,Attributes)) -> {-# LINE 203 "./src-ag/Order.ag" #-} Map.fromList (toList _childrenIinhs) {-# LINE 2493 "dist/build/Order.hs"#-} {-# INLINE rule317 #-} {-# LINE 209 "./src-ag/Order.ag" #-} rule317 = \ ((_lhsIinh) :: Attributes) ((_lhsInt) :: Identifier) con_ -> {-# LINE 209 "./src-ag/Order.ag" #-} [ cRuleLhsInh inh _lhsInt con_ tp | (inh,tp) <- Map.assocs _lhsIinh ] {-# LINE 2499 "dist/build/Order.hs"#-} {-# INLINE rule318 #-} {-# LINE 210 "./src-ag/Order.ag" #-} rule318 = \ ((_childrenIgathRules) :: Seq CRule) _inhRules ((_rulesIgathRules) :: Seq CRule) -> {-# LINE 210 "./src-ag/Order.ag" #-} _inhRules ++ toList (_childrenIgathRules Seq.>< _rulesIgathRules) {-# LINE 2505 "dist/build/Order.hs"#-} {-# INLINE rule319 #-} {-# LINE 262 "./src-ag/Order.ag" #-} rule319 = \ _gathRules ((_lhsIvcount) :: Int) -> {-# LINE 262 "./src-ag/Order.ag" #-} Seq.fromList (zip [_lhsIvcount..] _gathRules) {-# LINE 2511 "dist/build/Order.hs"#-} {-# INLINE rule320 #-} {-# LINE 263 "./src-ag/Order.ag" #-} rule320 = \ _gathRules ((_lhsIvcount) :: Int) -> {-# LINE 263 "./src-ag/Order.ag" #-} _lhsIvcount + length _gathRules {-# LINE 2517 "dist/build/Order.hs"#-} {-# INLINE rule321 #-} {-# LINE 291 "./src-ag/Order.ag" #-} rule321 = \ ((_lhsImanualAttrDepMap) :: AttrOrderMap) ((_lhsInt) :: Identifier) con_ -> {-# LINE 291 "./src-ag/Order.ag" #-} Set.toList $ Map.findWithDefault Set.empty con_ $ Map.findWithDefault Map.empty _lhsInt _lhsImanualAttrDepMap {-# LINE 2523 "dist/build/Order.hs"#-} {-# INLINE rule322 #-} {-# LINE 294 "./src-ag/Order.ag" #-} rule322 = \ _altAttrs _manualDeps -> {-# LINE 294 "./src-ag/Order.ag" #-} Seq.fromList [ (vertex True occA, vertex False occB) | Dependency occA occB <- _manualDeps , let vertex inout (OccAttr child nm) | child == _LOC = findWithErr2 (AltAttr _LOC nm True) _altAttrs | otherwise = findWithErr2 (AltAttr child nm inout) _altAttrs vertex _ (OccRule nm) = findWithErr2 (AltAttr _LOC (Ident ("_rule_" ++ show nm) (getPos nm)) True) _altAttrs ] {-# LINE 2536 "dist/build/Order.hs"#-} {-# INLINE rule323 #-} {-# LINE 340 "./src-ag/Order.ag" #-} rule323 = \ ((_childrenIcollectChildrenSyns) :: Map Identifier Attributes ) -> {-# LINE 340 "./src-ag/Order.ag" #-} _childrenIcollectChildrenSyns {-# LINE 2542 "dist/build/Order.hs"#-} {-# INLINE rule324 #-} {-# LINE 341 "./src-ag/Order.ag" #-} rule324 = \ ((_childrenIcollectChildrenInhs) :: Map Identifier Attributes ) -> {-# LINE 341 "./src-ag/Order.ag" #-} _childrenIcollectChildrenInhs {-# LINE 2548 "dist/build/Order.hs"#-} {-# INLINE rule325 #-} {-# LINE 359 "./src-ag/Order.ag" #-} rule325 = \ ((_lhsImergeMap) :: Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))) con_ -> {-# LINE 359 "./src-ag/Order.ag" #-} Map.findWithDefault Map.empty con_ _lhsImergeMap {-# LINE 2554 "dist/build/Order.hs"#-} {-# INLINE rule326 #-} {-# LINE 370 "./src-ag/Order.ag" #-} rule326 = \ _mergeDep1 _mergeDep2 -> {-# LINE 370 "./src-ag/Order.ag" #-} _mergeDep1 Seq.>< _mergeDep2 {-# LINE 2560 "dist/build/Order.hs"#-} {-# INLINE rule327 #-} {-# LINE 372 "./src-ag/Order.ag" #-} rule327 = \ _altAttrs ((_childrenIcollectChildrenSyns) :: Map Identifier Attributes ) _mergeMap -> {-# LINE 372 "./src-ag/Order.ag" #-} Seq.fromList $ [ (childVert, synVert) | childNm <- Map.keys _mergeMap , synNm <- Map.keys (findWithErr2 childNm _childrenIcollectChildrenSyns) , let childNm' = Ident (show childNm ++ "_merge") (getPos childNm) childAttr = AltAttr _LOC childNm' True synAttr = AltAttr childNm synNm True childVert = findWithErr2 childAttr _altAttrs synVert = findWithErr2 synAttr _altAttrs ] {-# LINE 2575 "dist/build/Order.hs"#-} {-# INLINE rule328 #-} {-# LINE 383 "./src-ag/Order.ag" #-} rule328 = \ _altAttrs ((_childrenIcollectChildrenSyns) :: Map Identifier Attributes ) _mergeMap -> {-# LINE 383 "./src-ag/Order.ag" #-} Seq.fromList $ [ (mergedVert, sourceVert) | (childNm, (_,cs)) <- Map.assocs _mergeMap , c <- cs , synNm <- Map.keys (findWithErr2 childNm _childrenIcollectChildrenSyns) , let sourceAttr = AltAttr childNm synNm True mergedAttr = AltAttr c synNm True sourceVert = findWithErr2 sourceAttr _altAttrs mergedVert = findWithErr2 mergedAttr _altAttrs ] {-# LINE 2590 "dist/build/Order.hs"#-} {-# INLINE rule329 #-} {-# LINE 412 "./src-ag/Order.ag" #-} rule329 = \ ((_lhsIaroundMap) :: Map ConstructorIdent (Map Identifier [Expression])) con_ -> {-# LINE 412 "./src-ag/Order.ag" #-} Map.findWithDefault Map.empty con_ _lhsIaroundMap {-# LINE 2596 "dist/build/Order.hs"#-} {-# INLINE rule330 #-} {-# LINE 420 "./src-ag/Order.ag" #-} rule330 = \ _altAttrs _aroundMap ((_childrenIcollectChildrenSyns) :: Map Identifier Attributes ) -> {-# LINE 420 "./src-ag/Order.ag" #-} Seq.fromList $ [ (childVert, synVert) | childNm <- Map.keys _aroundMap , synNm <- Map.keys (findWithErr2 childNm _childrenIcollectChildrenSyns) , let childNm' = Ident (show childNm ++ "_around") (getPos childNm) childAttr = AltAttr _LOC childNm' True synAttr = AltAttr childNm synNm True childVert = findWithErr2 childAttr _altAttrs synVert = findWithErr2 synAttr _altAttrs ] {-# LINE 2611 "dist/build/Order.hs"#-} {-# INLINE rule331 #-} {-# LINE 431 "./src-ag/Order.ag" #-} rule331 = \ _altAttrs _aroundMap ((_childrenIcollectChildrenInhs) :: Map Identifier Attributes ) -> {-# LINE 431 "./src-ag/Order.ag" #-} Seq.fromList $ [ (childVert, inhVert) | childNm <- Map.keys _aroundMap , inhNm <- Map.keys (findWithErr2 childNm _childrenIcollectChildrenInhs) , let childNm' = Ident (show childNm ++ "_around") (getPos childNm) childAttr = AltAttr _LOC childNm' True inhAttr = AltAttr childNm inhNm False childVert = findWithErr2 childAttr _altAttrs inhVert = findWithErr2 inhAttr _altAttrs ] {-# LINE 2626 "dist/build/Order.hs"#-} {-# INLINE rule332 #-} {-# LINE 441 "./src-ag/Order.ag" #-} rule332 = \ _aroundDep1 _aroundDep2 -> {-# LINE 441 "./src-ag/Order.ag" #-} _aroundDep1 Seq.>< _aroundDep2 {-# LINE 2632 "dist/build/Order.hs"#-} {-# INLINE rule333 #-} {-# LINE 523 "./src-ag/Order.ag" #-} rule333 = \ con_ -> {-# LINE 523 "./src-ag/Order.ag" #-} [con_] {-# LINE 2638 "dist/build/Order.hs"#-} {-# INLINE rule334 #-} {-# LINE 530 "./src-ag/Order.ag" #-} rule334 = \ (_ :: ()) -> {-# LINE 530 "./src-ag/Order.ag" #-} Map.empty {-# LINE 2644 "dist/build/Order.hs"#-} {-# INLINE rule335 #-} {-# LINE 536 "./src-ag/Order.ag" #-} rule335 = \ ((_typeSigsItypeSigs) :: Map Identifier Type) -> {-# LINE 536 "./src-ag/Order.ag" #-} _typeSigsItypeSigs {-# LINE 2650 "dist/build/Order.hs"#-} {-# INLINE rule336 #-} {-# LINE 604 "./src-ag/Order.ag" #-} rule336 = \ ((_childrenIsinglevisits) :: [CRule]) _gathRules ((_lhsIcVisitsMap) :: CVisitsMap) ((_lhsIinh) :: Attributes) ((_lhsInt) :: Identifier) ((_lhsIo_dovisit) :: Bool) ((_lhsIsyn) :: Attributes) con_ -> {-# LINE 604 "./src-ag/Order.ag" #-} if _lhsIo_dovisit then let prodsVisitsMap = findWithErr1 "Production.cVisits.nt" _lhsInt _lhsIcVisitsMap visits = findWithErr1 "Production.cVisits.con" con_ prodsVisitsMap in visits else let vss = nubBy eqCRuleDefines _gathRules ++ _childrenIsinglevisits in [CVisit _lhsIinh _lhsIsyn vss [] False] {-# LINE 2661 "dist/build/Order.hs"#-} {-# INLINE rule337 #-} {-# LINE 630 "./src-ag/Order.ag" #-} rule337 = \ _cVisits ((_childrenIfields) :: [(Identifier,Type,ChildKind)]) ((_childrenIterminals) :: [Identifier]) con_ -> {-# LINE 630 "./src-ag/Order.ag" #-} CProduction con_ _cVisits _childrenIfields _childrenIterminals {-# LINE 2667 "dist/build/Order.hs"#-} {-# INLINE rule338 #-} {-# LINE 658 "./src-ag/Order.ag" #-} rule338 = \ ((_childrenIfields) :: [(Identifier,Type,ChildKind)]) -> {-# LINE 658 "./src-ag/Order.ag" #-} _childrenIfields {-# LINE 2673 "dist/build/Order.hs"#-} {-# INLINE rule339 #-} {-# LINE 659 "./src-ag/Order.ag" #-} rule339 = \ ((_childrenIattributes) :: [(Identifier,Attributes,Attributes)]) _inhnames ((_rulesIinstVars) :: [Identifier]) ((_rulesIlocVars) :: [Identifier]) -> {-# LINE 659 "./src-ag/Order.ag" #-} map ((,) _LOC) _rulesIlocVars ++ map ((,) _INST) _rulesIinstVars ++ map ((,) _LHS) _inhnames ++ concat [map ((,) nm) (Map.keys as) | (nm,_,as) <- _childrenIattributes] {-# LINE 2682 "dist/build/Order.hs"#-} {-# INLINE rule340 #-} {-# LINE 663 "./src-ag/Order.ag" #-} rule340 = \ ((_lhsIinh) :: Attributes) -> {-# LINE 663 "./src-ag/Order.ag" #-} Map.keys _lhsIinh {-# LINE 2688 "dist/build/Order.hs"#-} {-# INLINE rule341 #-} {-# LINE 664 "./src-ag/Order.ag" #-} rule341 = \ ((_lhsIsyn) :: Attributes) -> {-# LINE 664 "./src-ag/Order.ag" #-} Map.keys _lhsIsyn {-# LINE 2694 "dist/build/Order.hs"#-} {-# INLINE rule342 #-} rule342 = \ ((_rulesIdirectDep) :: Seq Edge) -> _rulesIdirectDep {-# INLINE rule343 #-} rule343 = \ ((_childrenIerrors) :: Seq Error) ((_rulesIerrors) :: Seq Error) -> _childrenIerrors Seq.>< _rulesIerrors {-# INLINE rule344 #-} rule344 = \ ((_rulesIinstDep) :: Seq Edge) -> _rulesIinstDep {-# INLINE rule345 #-} rule345 = \ ((_rulesInAutoRules) :: Int) -> _rulesInAutoRules {-# INLINE rule346 #-} rule346 = \ ((_rulesInExplicitRules) :: Int) -> _rulesInExplicitRules {-# INLINE rule347 #-} rule347 = \ _allfields -> _allfields {-# INLINE rule348 #-} rule348 = \ ((_lhsIallnts) :: [Identifier]) -> _lhsIallnts {-# INLINE rule349 #-} rule349 = \ _attrs -> _attrs {-# INLINE rule350 #-} rule350 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule351 #-} rule351 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule352 #-} rule352 = \ _mergeMap -> _mergeMap {-# INLINE rule353 #-} rule353 = \ ((_lhsInt) :: Identifier) -> _lhsInt {-# INLINE rule354 #-} rule354 = \ ((_lhsIo_unbox) :: Bool) -> _lhsIo_unbox {-# INLINE rule355 #-} rule355 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# INLINE rule356 #-} rule356 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# INLINE rule357 #-} rule357 = \ _allfields -> _allfields {-# INLINE rule358 #-} rule358 = \ ((_lhsIallnts) :: [Identifier]) -> _lhsIallnts {-# INLINE rule359 #-} rule359 = \ _altAttrs -> _altAttrs {-# INLINE rule360 #-} rule360 = \ _attrs -> _attrs {-# INLINE rule361 #-} rule361 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule362 #-} rule362 = \ _mergeMap -> _mergeMap {-# INLINE rule363 #-} rule363 = \ ((_lhsInt) :: Identifier) -> _lhsInt {-# INLINE rule364 #-} rule364 = \ ((_lhsIo_case) :: Bool) -> _lhsIo_case {-# INLINE rule365 #-} rule365 = \ ((_lhsIo_cata) :: Bool) -> _lhsIo_cata {-# INLINE rule366 #-} rule366 = \ ((_lhsIo_dovisit) :: Bool) -> _lhsIo_dovisit {-# INLINE rule367 #-} rule367 = \ ((_lhsIo_newtypes) :: Bool) -> _lhsIo_newtypes {-# INLINE rule368 #-} rule368 = \ ((_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# INLINE rule369 #-} rule369 = \ ((_lhsIo_sem) :: Bool) -> _lhsIo_sem {-# INLINE rule370 #-} rule370 = \ ((_lhsIo_sig) :: Bool) -> _lhsIo_sig {-# INLINE rule371 #-} rule371 = \ ((_lhsIo_wantvisit) :: Bool) -> _lhsIo_wantvisit {-# INLINE rule372 #-} rule372 = \ ((_lhsIprefix) :: String) -> _lhsIprefix {-# INLINE rule373 #-} rule373 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn -- Productions ------------------------------------------------- -- wrapper data Inh_Productions = Inh_Productions { allnts_Inh_Productions :: ([Identifier]), aroundMap_Inh_Productions :: (Map ConstructorIdent (Map Identifier [Expression])), cVisitsMap_Inh_Productions :: (CVisitsMap), inh_Inh_Productions :: (Attributes), inhMap_Inh_Productions :: (Map Identifier Attributes), manualAttrDepMap_Inh_Productions :: (AttrOrderMap), mergeMap_Inh_Productions :: (Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))), nt_Inh_Productions :: (Identifier), o_case_Inh_Productions :: (Bool), o_cata_Inh_Productions :: (Bool), o_dovisit_Inh_Productions :: (Bool), o_newtypes_Inh_Productions :: (Bool), o_rename_Inh_Productions :: (Bool), o_sem_Inh_Productions :: (Bool), o_sig_Inh_Productions :: (Bool), o_unbox_Inh_Productions :: (Bool), o_wantvisit_Inh_Productions :: (Bool), prefix_Inh_Productions :: (String), syn_Inh_Productions :: (Attributes), synMap_Inh_Productions :: (Map Identifier Attributes), vcount_Inh_Productions :: (Int) } data Syn_Productions = Syn_Productions { additionalDep_Syn_Productions :: (Seq Edge), aroundDep_Syn_Productions :: (Seq Edge), cProductions_Syn_Productions :: (CProductions), cons_Syn_Productions :: ([ConstructorIdent]), directDep_Syn_Productions :: (Seq Edge), errors_Syn_Productions :: (Seq Error), instDep_Syn_Productions :: (Seq Edge), mergeDep_Syn_Productions :: (Seq Edge), nAutoRules_Syn_Productions :: (Int), nExplicitRules_Syn_Productions :: (Int), rules_Syn_Productions :: (Seq (Vertex,CRule)), vcount_Syn_Productions :: (Int) } {-# INLINABLE wrap_Productions #-} wrap_Productions :: T_Productions -> Inh_Productions -> (Syn_Productions ) wrap_Productions (T_Productions act) (Inh_Productions _lhsIallnts _lhsIaroundMap _lhsIcVisitsMap _lhsIinh _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIsynMap _lhsIvcount) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Productions_vIn28 _lhsIallnts _lhsIaroundMap _lhsIcVisitsMap _lhsIinh _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIsynMap _lhsIvcount (T_Productions_vOut28 _lhsOadditionalDep _lhsOaroundDep _lhsOcProductions _lhsOcons _lhsOdirectDep _lhsOerrors _lhsOinstDep _lhsOmergeDep _lhsOnAutoRules _lhsOnExplicitRules _lhsOrules _lhsOvcount) <- return (inv_Productions_s29 sem arg) return (Syn_Productions _lhsOadditionalDep _lhsOaroundDep _lhsOcProductions _lhsOcons _lhsOdirectDep _lhsOerrors _lhsOinstDep _lhsOmergeDep _lhsOnAutoRules _lhsOnExplicitRules _lhsOrules _lhsOvcount) ) -- cata {-# NOINLINE sem_Productions #-} sem_Productions :: Productions -> T_Productions sem_Productions list = Prelude.foldr sem_Productions_Cons sem_Productions_Nil (Prelude.map sem_Production list) -- semantic domain newtype T_Productions = T_Productions { attach_T_Productions :: Identity (T_Productions_s29 ) } newtype T_Productions_s29 = C_Productions_s29 { inv_Productions_s29 :: (T_Productions_v28 ) } data T_Productions_s30 = C_Productions_s30 type T_Productions_v28 = (T_Productions_vIn28 ) -> (T_Productions_vOut28 ) data T_Productions_vIn28 = T_Productions_vIn28 ([Identifier]) (Map ConstructorIdent (Map Identifier [Expression])) (CVisitsMap) (Attributes) (Map Identifier Attributes) (AttrOrderMap) (Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))) (Identifier) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (String) (Attributes) (Map Identifier Attributes) (Int) data T_Productions_vOut28 = T_Productions_vOut28 (Seq Edge) (Seq Edge) (CProductions) ([ConstructorIdent]) (Seq Edge) (Seq Error) (Seq Edge) (Seq Edge) (Int) (Int) (Seq (Vertex,CRule)) (Int) {-# NOINLINE sem_Productions_Cons #-} sem_Productions_Cons :: T_Production -> T_Productions -> T_Productions sem_Productions_Cons arg_hd_ arg_tl_ = T_Productions (return st29) where {-# NOINLINE st29 #-} st29 = let v28 :: T_Productions_v28 v28 = \ (T_Productions_vIn28 _lhsIallnts _lhsIaroundMap _lhsIcVisitsMap _lhsIinh _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIsynMap _lhsIvcount) -> ( let _hdX26 = Control.Monad.Identity.runIdentity (attach_T_Production (arg_hd_)) _tlX29 = Control.Monad.Identity.runIdentity (attach_T_Productions (arg_tl_)) (T_Production_vOut25 _hdIadditionalDep _hdIaroundDep _hdIcProduction _hdIcons _hdIdirectDep _hdIerrors _hdIinstDep _hdImergeDep _hdInAutoRules _hdInExplicitRules _hdIrules _hdIvcount) = inv_Production_s26 _hdX26 (T_Production_vIn25 _hdOallnts _hdOaroundMap _hdOcVisitsMap _hdOinh _hdOinhMap _hdOmanualAttrDepMap _hdOmergeMap _hdOnt _hdOo_case _hdOo_cata _hdOo_dovisit _hdOo_newtypes _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_unbox _hdOo_wantvisit _hdOprefix _hdOsyn _hdOsynMap _hdOvcount) (T_Productions_vOut28 _tlIadditionalDep _tlIaroundDep _tlIcProductions _tlIcons _tlIdirectDep _tlIerrors _tlIinstDep _tlImergeDep _tlInAutoRules _tlInExplicitRules _tlIrules _tlIvcount) = inv_Productions_s29 _tlX29 (T_Productions_vIn28 _tlOallnts _tlOaroundMap _tlOcVisitsMap _tlOinh _tlOinhMap _tlOmanualAttrDepMap _tlOmergeMap _tlOnt _tlOo_case _tlOo_cata _tlOo_dovisit _tlOo_newtypes _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_unbox _tlOo_wantvisit _tlOprefix _tlOsyn _tlOsynMap _tlOvcount) _lhsOcProductions :: CProductions _lhsOcProductions = rule374 _hdIcProduction _tlIcProductions _lhsOadditionalDep :: Seq Edge _lhsOadditionalDep = rule375 _hdIadditionalDep _tlIadditionalDep _lhsOaroundDep :: Seq Edge _lhsOaroundDep = rule376 _hdIaroundDep _tlIaroundDep _lhsOcons :: [ConstructorIdent] _lhsOcons = rule377 _hdIcons _tlIcons _lhsOdirectDep :: Seq Edge _lhsOdirectDep = rule378 _hdIdirectDep _tlIdirectDep _lhsOerrors :: Seq Error _lhsOerrors = rule379 _hdIerrors _tlIerrors _lhsOinstDep :: Seq Edge _lhsOinstDep = rule380 _hdIinstDep _tlIinstDep _lhsOmergeDep :: Seq Edge _lhsOmergeDep = rule381 _hdImergeDep _tlImergeDep _lhsOnAutoRules :: Int _lhsOnAutoRules = rule382 _hdInAutoRules _tlInAutoRules _lhsOnExplicitRules :: Int _lhsOnExplicitRules = rule383 _hdInExplicitRules _tlInExplicitRules _lhsOrules :: Seq (Vertex,CRule) _lhsOrules = rule384 _hdIrules _tlIrules _lhsOvcount :: Int _lhsOvcount = rule385 _tlIvcount _hdOallnts = rule386 _lhsIallnts _hdOaroundMap = rule387 _lhsIaroundMap _hdOcVisitsMap = rule388 _lhsIcVisitsMap _hdOinh = rule389 _lhsIinh _hdOinhMap = rule390 _lhsIinhMap _hdOmanualAttrDepMap = rule391 _lhsImanualAttrDepMap _hdOmergeMap = rule392 _lhsImergeMap _hdOnt = rule393 _lhsInt _hdOo_case = rule394 _lhsIo_case _hdOo_cata = rule395 _lhsIo_cata _hdOo_dovisit = rule396 _lhsIo_dovisit _hdOo_newtypes = rule397 _lhsIo_newtypes _hdOo_rename = rule398 _lhsIo_rename _hdOo_sem = rule399 _lhsIo_sem _hdOo_sig = rule400 _lhsIo_sig _hdOo_unbox = rule401 _lhsIo_unbox _hdOo_wantvisit = rule402 _lhsIo_wantvisit _hdOprefix = rule403 _lhsIprefix _hdOsyn = rule404 _lhsIsyn _hdOsynMap = rule405 _lhsIsynMap _hdOvcount = rule406 _lhsIvcount _tlOallnts = rule407 _lhsIallnts _tlOaroundMap = rule408 _lhsIaroundMap _tlOcVisitsMap = rule409 _lhsIcVisitsMap _tlOinh = rule410 _lhsIinh _tlOinhMap = rule411 _lhsIinhMap _tlOmanualAttrDepMap = rule412 _lhsImanualAttrDepMap _tlOmergeMap = rule413 _lhsImergeMap _tlOnt = rule414 _lhsInt _tlOo_case = rule415 _lhsIo_case _tlOo_cata = rule416 _lhsIo_cata _tlOo_dovisit = rule417 _lhsIo_dovisit _tlOo_newtypes = rule418 _lhsIo_newtypes _tlOo_rename = rule419 _lhsIo_rename _tlOo_sem = rule420 _lhsIo_sem _tlOo_sig = rule421 _lhsIo_sig _tlOo_unbox = rule422 _lhsIo_unbox _tlOo_wantvisit = rule423 _lhsIo_wantvisit _tlOprefix = rule424 _lhsIprefix _tlOsyn = rule425 _lhsIsyn _tlOsynMap = rule426 _lhsIsynMap _tlOvcount = rule427 _hdIvcount __result_ = T_Productions_vOut28 _lhsOadditionalDep _lhsOaroundDep _lhsOcProductions _lhsOcons _lhsOdirectDep _lhsOerrors _lhsOinstDep _lhsOmergeDep _lhsOnAutoRules _lhsOnExplicitRules _lhsOrules _lhsOvcount in __result_ ) in C_Productions_s29 v28 {-# INLINE rule374 #-} {-# LINE 627 "./src-ag/Order.ag" #-} rule374 = \ ((_hdIcProduction) :: CProduction) ((_tlIcProductions) :: CProductions) -> {-# LINE 627 "./src-ag/Order.ag" #-} _hdIcProduction : _tlIcProductions {-# LINE 2907 "dist/build/Order.hs"#-} {-# INLINE rule375 #-} rule375 = \ ((_hdIadditionalDep) :: Seq Edge) ((_tlIadditionalDep) :: Seq Edge) -> _hdIadditionalDep Seq.>< _tlIadditionalDep {-# INLINE rule376 #-} rule376 = \ ((_hdIaroundDep) :: Seq Edge) ((_tlIaroundDep) :: Seq Edge) -> _hdIaroundDep Seq.>< _tlIaroundDep {-# INLINE rule377 #-} rule377 = \ ((_hdIcons) :: [ConstructorIdent]) ((_tlIcons) :: [ConstructorIdent]) -> _hdIcons ++ _tlIcons {-# INLINE rule378 #-} rule378 = \ ((_hdIdirectDep) :: Seq Edge) ((_tlIdirectDep) :: Seq Edge) -> _hdIdirectDep Seq.>< _tlIdirectDep {-# INLINE rule379 #-} rule379 = \ ((_hdIerrors) :: Seq Error) ((_tlIerrors) :: Seq Error) -> _hdIerrors Seq.>< _tlIerrors {-# INLINE rule380 #-} rule380 = \ ((_hdIinstDep) :: Seq Edge) ((_tlIinstDep) :: Seq Edge) -> _hdIinstDep Seq.>< _tlIinstDep {-# INLINE rule381 #-} rule381 = \ ((_hdImergeDep) :: Seq Edge) ((_tlImergeDep) :: Seq Edge) -> _hdImergeDep Seq.>< _tlImergeDep {-# INLINE rule382 #-} rule382 = \ ((_hdInAutoRules) :: Int) ((_tlInAutoRules) :: Int) -> _hdInAutoRules + _tlInAutoRules {-# INLINE rule383 #-} rule383 = \ ((_hdInExplicitRules) :: Int) ((_tlInExplicitRules) :: Int) -> _hdInExplicitRules + _tlInExplicitRules {-# INLINE rule384 #-} rule384 = \ ((_hdIrules) :: Seq (Vertex,CRule)) ((_tlIrules) :: Seq (Vertex,CRule)) -> _hdIrules Seq.>< _tlIrules {-# INLINE rule385 #-} rule385 = \ ((_tlIvcount) :: Int) -> _tlIvcount {-# INLINE rule386 #-} rule386 = \ ((_lhsIallnts) :: [Identifier]) -> _lhsIallnts {-# INLINE rule387 #-} rule387 = \ ((_lhsIaroundMap) :: Map ConstructorIdent (Map Identifier [Expression])) -> _lhsIaroundMap {-# INLINE rule388 #-} rule388 = \ ((_lhsIcVisitsMap) :: CVisitsMap) -> _lhsIcVisitsMap {-# INLINE rule389 #-} rule389 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule390 #-} rule390 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule391 #-} rule391 = \ ((_lhsImanualAttrDepMap) :: AttrOrderMap) -> _lhsImanualAttrDepMap {-# INLINE rule392 #-} rule392 = \ ((_lhsImergeMap) :: Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))) -> _lhsImergeMap {-# INLINE rule393 #-} rule393 = \ ((_lhsInt) :: Identifier) -> _lhsInt {-# INLINE rule394 #-} rule394 = \ ((_lhsIo_case) :: Bool) -> _lhsIo_case {-# INLINE rule395 #-} rule395 = \ ((_lhsIo_cata) :: Bool) -> _lhsIo_cata {-# INLINE rule396 #-} rule396 = \ ((_lhsIo_dovisit) :: Bool) -> _lhsIo_dovisit {-# INLINE rule397 #-} rule397 = \ ((_lhsIo_newtypes) :: Bool) -> _lhsIo_newtypes {-# INLINE rule398 #-} rule398 = \ ((_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# INLINE rule399 #-} rule399 = \ ((_lhsIo_sem) :: Bool) -> _lhsIo_sem {-# INLINE rule400 #-} rule400 = \ ((_lhsIo_sig) :: Bool) -> _lhsIo_sig {-# INLINE rule401 #-} rule401 = \ ((_lhsIo_unbox) :: Bool) -> _lhsIo_unbox {-# INLINE rule402 #-} rule402 = \ ((_lhsIo_wantvisit) :: Bool) -> _lhsIo_wantvisit {-# INLINE rule403 #-} rule403 = \ ((_lhsIprefix) :: String) -> _lhsIprefix {-# INLINE rule404 #-} rule404 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# INLINE rule405 #-} rule405 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# INLINE rule406 #-} rule406 = \ ((_lhsIvcount) :: Int) -> _lhsIvcount {-# INLINE rule407 #-} rule407 = \ ((_lhsIallnts) :: [Identifier]) -> _lhsIallnts {-# INLINE rule408 #-} rule408 = \ ((_lhsIaroundMap) :: Map ConstructorIdent (Map Identifier [Expression])) -> _lhsIaroundMap {-# INLINE rule409 #-} rule409 = \ ((_lhsIcVisitsMap) :: CVisitsMap) -> _lhsIcVisitsMap {-# INLINE rule410 #-} rule410 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule411 #-} rule411 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule412 #-} rule412 = \ ((_lhsImanualAttrDepMap) :: AttrOrderMap) -> _lhsImanualAttrDepMap {-# INLINE rule413 #-} rule413 = \ ((_lhsImergeMap) :: Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))) -> _lhsImergeMap {-# INLINE rule414 #-} rule414 = \ ((_lhsInt) :: Identifier) -> _lhsInt {-# INLINE rule415 #-} rule415 = \ ((_lhsIo_case) :: Bool) -> _lhsIo_case {-# INLINE rule416 #-} rule416 = \ ((_lhsIo_cata) :: Bool) -> _lhsIo_cata {-# INLINE rule417 #-} rule417 = \ ((_lhsIo_dovisit) :: Bool) -> _lhsIo_dovisit {-# INLINE rule418 #-} rule418 = \ ((_lhsIo_newtypes) :: Bool) -> _lhsIo_newtypes {-# INLINE rule419 #-} rule419 = \ ((_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# INLINE rule420 #-} rule420 = \ ((_lhsIo_sem) :: Bool) -> _lhsIo_sem {-# INLINE rule421 #-} rule421 = \ ((_lhsIo_sig) :: Bool) -> _lhsIo_sig {-# INLINE rule422 #-} rule422 = \ ((_lhsIo_unbox) :: Bool) -> _lhsIo_unbox {-# INLINE rule423 #-} rule423 = \ ((_lhsIo_wantvisit) :: Bool) -> _lhsIo_wantvisit {-# INLINE rule424 #-} rule424 = \ ((_lhsIprefix) :: String) -> _lhsIprefix {-# INLINE rule425 #-} rule425 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# INLINE rule426 #-} rule426 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# INLINE rule427 #-} rule427 = \ ((_hdIvcount) :: Int) -> _hdIvcount {-# NOINLINE sem_Productions_Nil #-} sem_Productions_Nil :: T_Productions sem_Productions_Nil = T_Productions (return st29) where {-# NOINLINE st29 #-} st29 = let v28 :: T_Productions_v28 v28 = \ (T_Productions_vIn28 _lhsIallnts _lhsIaroundMap _lhsIcVisitsMap _lhsIinh _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIsynMap _lhsIvcount) -> ( let _lhsOcProductions :: CProductions _lhsOcProductions = rule428 () _lhsOadditionalDep :: Seq Edge _lhsOadditionalDep = rule429 () _lhsOaroundDep :: Seq Edge _lhsOaroundDep = rule430 () _lhsOcons :: [ConstructorIdent] _lhsOcons = rule431 () _lhsOdirectDep :: Seq Edge _lhsOdirectDep = rule432 () _lhsOerrors :: Seq Error _lhsOerrors = rule433 () _lhsOinstDep :: Seq Edge _lhsOinstDep = rule434 () _lhsOmergeDep :: Seq Edge _lhsOmergeDep = rule435 () _lhsOnAutoRules :: Int _lhsOnAutoRules = rule436 () _lhsOnExplicitRules :: Int _lhsOnExplicitRules = rule437 () _lhsOrules :: Seq (Vertex,CRule) _lhsOrules = rule438 () _lhsOvcount :: Int _lhsOvcount = rule439 _lhsIvcount __result_ = T_Productions_vOut28 _lhsOadditionalDep _lhsOaroundDep _lhsOcProductions _lhsOcons _lhsOdirectDep _lhsOerrors _lhsOinstDep _lhsOmergeDep _lhsOnAutoRules _lhsOnExplicitRules _lhsOrules _lhsOvcount in __result_ ) in C_Productions_s29 v28 {-# INLINE rule428 #-} {-# LINE 628 "./src-ag/Order.ag" #-} rule428 = \ (_ :: ()) -> {-# LINE 628 "./src-ag/Order.ag" #-} [] {-# LINE 3106 "dist/build/Order.hs"#-} {-# INLINE rule429 #-} rule429 = \ (_ :: ()) -> Seq.empty {-# INLINE rule430 #-} rule430 = \ (_ :: ()) -> Seq.empty {-# INLINE rule431 #-} rule431 = \ (_ :: ()) -> [] {-# INLINE rule432 #-} rule432 = \ (_ :: ()) -> Seq.empty {-# INLINE rule433 #-} rule433 = \ (_ :: ()) -> Seq.empty {-# INLINE rule434 #-} rule434 = \ (_ :: ()) -> Seq.empty {-# INLINE rule435 #-} rule435 = \ (_ :: ()) -> Seq.empty {-# INLINE rule436 #-} rule436 = \ (_ :: ()) -> 0 {-# INLINE rule437 #-} rule437 = \ (_ :: ()) -> 0 {-# INLINE rule438 #-} rule438 = \ (_ :: ()) -> Seq.empty {-# INLINE rule439 #-} rule439 = \ ((_lhsIvcount) :: Int) -> _lhsIvcount -- Rule -------------------------------------------------------- -- wrapper data Inh_Rule = Inh_Rule { allTypeSigs_Inh_Rule :: (Map Identifier Type), allfields_Inh_Rule :: ([(Identifier,Type,ChildKind)]), allnts_Inh_Rule :: ([Identifier]), altAttrs_Inh_Rule :: (Map AltAttr Vertex), attrs_Inh_Rule :: ([(Identifier,Identifier)]), childInhs_Inh_Rule :: (Map Identifier Attributes), childNts_Inh_Rule :: (Map Identifier NontermIdent), con_Inh_Rule :: (Identifier), inh_Inh_Rule :: (Attributes), inhsOfChildren_Inh_Rule :: (Map Identifier Attributes), mergeMap_Inh_Rule :: (Map Identifier (Identifier,[Identifier])), nt_Inh_Rule :: (Identifier), o_case_Inh_Rule :: (Bool), o_cata_Inh_Rule :: (Bool), o_dovisit_Inh_Rule :: (Bool), o_newtypes_Inh_Rule :: (Bool), o_rename_Inh_Rule :: (Bool), o_sem_Inh_Rule :: (Bool), o_sig_Inh_Rule :: (Bool), o_wantvisit_Inh_Rule :: (Bool), prefix_Inh_Rule :: (String), syn_Inh_Rule :: (Attributes), synsOfChildren_Inh_Rule :: (Map Identifier Attributes) } data Syn_Rule = Syn_Rule { directDep_Syn_Rule :: (Seq Edge), errors_Syn_Rule :: (Seq Error), gathAltAttrs_Syn_Rule :: ([AltAttr]), gathRules_Syn_Rule :: (Seq CRule), instDep_Syn_Rule :: (Seq Edge), instVars_Syn_Rule :: ([Identifier]), locVars_Syn_Rule :: ([Identifier]), nAutoRules_Syn_Rule :: (Int), nExplicitRules_Syn_Rule :: (Int) } {-# INLINABLE wrap_Rule #-} wrap_Rule :: T_Rule -> Inh_Rule -> (Syn_Rule ) wrap_Rule (T_Rule act) (Inh_Rule _lhsIallTypeSigs _lhsIallfields _lhsIallnts _lhsIaltAttrs _lhsIattrs _lhsIchildInhs _lhsIchildNts _lhsIcon _lhsIinh _lhsIinhsOfChildren _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIsynsOfChildren) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Rule_vIn31 _lhsIallTypeSigs _lhsIallfields _lhsIallnts _lhsIaltAttrs _lhsIattrs _lhsIchildInhs _lhsIchildNts _lhsIcon _lhsIinh _lhsIinhsOfChildren _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIsynsOfChildren (T_Rule_vOut31 _lhsOdirectDep _lhsOerrors _lhsOgathAltAttrs _lhsOgathRules _lhsOinstDep _lhsOinstVars _lhsOlocVars _lhsOnAutoRules _lhsOnExplicitRules) <- return (inv_Rule_s32 sem arg) return (Syn_Rule _lhsOdirectDep _lhsOerrors _lhsOgathAltAttrs _lhsOgathRules _lhsOinstDep _lhsOinstVars _lhsOlocVars _lhsOnAutoRules _lhsOnExplicitRules) ) -- cata {-# INLINE sem_Rule #-} sem_Rule :: Rule -> T_Rule sem_Rule ( Rule mbName_ pattern_ rhs_ owrt_ origin_ explicit_ pure_ identity_ mbError_ eager_ ) = sem_Rule_Rule mbName_ ( sem_Pattern pattern_ ) ( sem_Expression rhs_ ) owrt_ origin_ explicit_ pure_ identity_ mbError_ eager_ -- semantic domain newtype T_Rule = T_Rule { attach_T_Rule :: Identity (T_Rule_s32 ) } newtype T_Rule_s32 = C_Rule_s32 { inv_Rule_s32 :: (T_Rule_v31 ) } data T_Rule_s33 = C_Rule_s33 type T_Rule_v31 = (T_Rule_vIn31 ) -> (T_Rule_vOut31 ) data T_Rule_vIn31 = T_Rule_vIn31 (Map Identifier Type) ([(Identifier,Type,ChildKind)]) ([Identifier]) (Map AltAttr Vertex) ([(Identifier,Identifier)]) (Map Identifier Attributes) (Map Identifier NontermIdent) (Identifier) (Attributes) (Map Identifier Attributes) (Map Identifier (Identifier,[Identifier])) (Identifier) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (String) (Attributes) (Map Identifier Attributes) data T_Rule_vOut31 = T_Rule_vOut31 (Seq Edge) (Seq Error) ([AltAttr]) (Seq CRule) (Seq Edge) ([Identifier]) ([Identifier]) (Int) (Int) {-# NOINLINE sem_Rule_Rule #-} sem_Rule_Rule :: (Maybe Identifier) -> T_Pattern -> T_Expression -> (Bool) -> (String) -> (Bool) -> (Bool) -> (Bool) -> (Maybe Error) -> (Bool) -> T_Rule sem_Rule_Rule arg_mbName_ arg_pattern_ arg_rhs_ arg_owrt_ arg_origin_ arg_explicit_ _ _ _ _ = T_Rule (return st32) where {-# NOINLINE st32 #-} st32 = let v31 :: T_Rule_v31 v31 = \ (T_Rule_vIn31 _lhsIallTypeSigs _lhsIallfields _lhsIallnts _lhsIaltAttrs _lhsIattrs _lhsIchildInhs _lhsIchildNts _lhsIcon _lhsIinh _lhsIinhsOfChildren _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIsynsOfChildren) -> ( let _patternX20 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pattern_)) _rhsX8 = Control.Monad.Identity.runIdentity (attach_T_Expression (arg_rhs_)) (T_Pattern_vOut19 _patternIcopy _patternIerrors _patternIgathAltAttrs _patternIinstVars _patternIlocVars _patternIpatternAttrs) = inv_Pattern_s20 _patternX20 (T_Pattern_vIn19 _patternOallTypeSigs _patternOaltAttrs _patternOcon _patternOinh _patternOnt _patternOsyn) (T_Expression_vOut7 _rhsIallRhsVars _rhsIcopy _rhsIerrors _rhsItextLines _rhsIusedAttrs _rhsIusedFields _rhsIusedLocals) = inv_Expression_s8 _rhsX8 (T_Expression_vIn7 _rhsOallfields _rhsOallnts _rhsOattrs _rhsOcon _rhsOmergeMap _rhsOnt) _lhsOnExplicitRules :: Int _lhsOnExplicitRules = rule440 arg_explicit_ _lhsOnAutoRules :: Int _lhsOnAutoRules = rule441 arg_origin_ _defines = rule442 _lhsIallTypeSigs _lhsIaltAttrs _lhsIchildInhs _lhsIsyn _patternIpatternAttrs _gathRules = rule443 _defines _lhsIchildNts _lhsIcon _lhsInt _patternIcopy _rhsIallRhsVars _rhsItextLines arg_explicit_ arg_mbName_ arg_origin_ arg_owrt_ _lhsOdirectDep :: Seq Edge _lhsOdirectDep = rule444 _defines _lhsIaltAttrs _rhsIusedAttrs _rhsIusedFields _rhsIusedLocals _instDep1 = rule445 _defines _lhsIaltAttrs _lhsIsynsOfChildren _instDep2 = rule446 _defines _lhsIaltAttrs _lhsIinhsOfChildren _lhsOinstDep :: Seq Edge _lhsOinstDep = rule447 _instDep1 _instDep2 _lhsOerrors :: Seq Error _lhsOerrors = rule448 _patternIerrors _rhsIerrors _lhsOgathAltAttrs :: [AltAttr] _lhsOgathAltAttrs = rule449 _patternIgathAltAttrs _lhsOgathRules :: Seq CRule _lhsOgathRules = rule450 _gathRules _lhsOinstVars :: [Identifier] _lhsOinstVars = rule451 _patternIinstVars _lhsOlocVars :: [Identifier] _lhsOlocVars = rule452 _patternIlocVars _patternOallTypeSigs = rule453 _lhsIallTypeSigs _patternOaltAttrs = rule454 _lhsIaltAttrs _patternOcon = rule455 _lhsIcon _patternOinh = rule456 _lhsIinh _patternOnt = rule457 _lhsInt _patternOsyn = rule458 _lhsIsyn _rhsOallfields = rule459 _lhsIallfields _rhsOallnts = rule460 _lhsIallnts _rhsOattrs = rule461 _lhsIattrs _rhsOcon = rule462 _lhsIcon _rhsOmergeMap = rule463 _lhsImergeMap _rhsOnt = rule464 _lhsInt __result_ = T_Rule_vOut31 _lhsOdirectDep _lhsOerrors _lhsOgathAltAttrs _lhsOgathRules _lhsOinstDep _lhsOinstVars _lhsOlocVars _lhsOnAutoRules _lhsOnExplicitRules in __result_ ) in C_Rule_s32 v31 {-# INLINE rule440 #-} {-# LINE 65 "./src-ag/Order.ag" #-} rule440 = \ explicit_ -> {-# LINE 65 "./src-ag/Order.ag" #-} if explicit_ then 1 else 0 {-# LINE 3226 "dist/build/Order.hs"#-} {-# INLINE rule441 #-} {-# LINE 68 "./src-ag/Order.ag" #-} rule441 = \ origin_ -> {-# LINE 68 "./src-ag/Order.ag" #-} if startsWith "use rule" origin_ || startsWith "copy rule" origin_ then 1 else 0 {-# LINE 3234 "dist/build/Order.hs"#-} {-# INLINE rule442 #-} {-# LINE 218 "./src-ag/Order.ag" #-} rule442 = \ ((_lhsIallTypeSigs) :: Map Identifier Type) ((_lhsIaltAttrs) :: Map AltAttr Vertex) ((_lhsIchildInhs) :: Map Identifier Attributes) ((_lhsIsyn) :: Attributes) ((_patternIpatternAttrs) :: [(Identifier,Identifier,Bool)]) -> {-# LINE 218 "./src-ag/Order.ag" #-} let tp field attr | field == _LOC || field == _INST = Map.lookup attr _lhsIallTypeSigs | field == _LHS = Map.lookup attr _lhsIsyn | otherwise = Map.lookup attr (findWithErr1 "Rule.defines.tp" field _lhsIchildInhs) typ :: Pattern -> Maybe Type typ (Alias field attr _) = tp field attr typ (Underscore _) = Nothing typ _ = Nothing in Map.fromList [ (findWithErr1 "Rule.defines" aa _lhsIaltAttrs, (field,attr,(tp field attr))) | (field,attr,isLocalOrInst) <- _patternIpatternAttrs , let aa = AltAttr field attr isLocalOrInst ] {-# LINE 3251 "dist/build/Order.hs"#-} {-# INLINE rule443 #-} {-# LINE 232 "./src-ag/Order.ag" #-} rule443 = \ _defines ((_lhsIchildNts) :: Map Identifier NontermIdent) ((_lhsIcon) :: Identifier) ((_lhsInt) :: Identifier) ((_patternIcopy) :: Pattern) ((_rhsIallRhsVars) :: Set (Identifier,Identifier)) ((_rhsItextLines) :: [String]) explicit_ mbName_ origin_ owrt_ -> {-# LINE 232 "./src-ag/Order.ag" #-} let childnt field = Map.lookup field _lhsIchildNts in Seq.fromList [ CRule attr False True _lhsInt _lhsIcon field (childnt field) tp _patternIcopy _rhsItextLines _defines owrt_ origin_ _rhsIallRhsVars explicit_ mbName_ | (field,attr,tp) <- Map.elems _defines ] {-# LINE 3260 "dist/build/Order.hs"#-} {-# INLINE rule444 #-} {-# LINE 271 "./src-ag/Order.ag" #-} rule444 = \ _defines ((_lhsIaltAttrs) :: Map AltAttr Vertex) ((_rhsIusedAttrs) :: [(Identifier,Identifier)]) ((_rhsIusedFields) :: [Identifier]) ((_rhsIusedLocals) :: [Identifier]) -> {-# LINE 271 "./src-ag/Order.ag" #-} let defined = Map.keys _defines used = [ Map.lookup (AltAttr field attr True) _lhsIaltAttrs | (field,attr) <- _rhsIusedAttrs] ++ [ Map.lookup (AltAttr _LOC attr True) _lhsIaltAttrs | attr <- _rhsIusedLocals ++ _rhsIusedFields ] in Seq.fromList [ (x,y) | Just x <- used, y <- defined ] {-# LINE 3269 "dist/build/Order.hs"#-} {-# INLINE rule445 #-} {-# LINE 315 "./src-ag/Order.ag" #-} rule445 = \ _defines ((_lhsIaltAttrs) :: Map AltAttr Vertex) ((_lhsIsynsOfChildren) :: Map Identifier Attributes) -> {-# LINE 315 "./src-ag/Order.ag" #-} Seq.fromList $ [ (instVert, synVert) | (field,instNm,_) <- Map.elems _defines , field == _INST , synNm <- Map.keys (findWithErr2 instNm _lhsIsynsOfChildren) , let instAttr = AltAttr _INST instNm True synAttr = AltAttr instNm synNm True instVert = findWithErr2 instAttr _lhsIaltAttrs synVert = findWithErr2 synAttr _lhsIaltAttrs ] {-# LINE 3284 "dist/build/Order.hs"#-} {-# INLINE rule446 #-} {-# LINE 326 "./src-ag/Order.ag" #-} rule446 = \ _defines ((_lhsIaltAttrs) :: Map AltAttr Vertex) ((_lhsIinhsOfChildren) :: Map Identifier Attributes) -> {-# LINE 326 "./src-ag/Order.ag" #-} Seq.fromList $ [ (instVert, inhVert) | (field,instNm,_) <- Map.elems _defines , field == _INST , inhNm <- Map.keys (findWithErr2 instNm _lhsIinhsOfChildren) , let instAttr = AltAttr _INST instNm True inhAttr = AltAttr instNm inhNm False instVert = findWithErr2 instAttr _lhsIaltAttrs inhVert = findWithErr2 inhAttr _lhsIaltAttrs ] {-# LINE 3299 "dist/build/Order.hs"#-} {-# INLINE rule447 #-} {-# LINE 336 "./src-ag/Order.ag" #-} rule447 = \ _instDep1 _instDep2 -> {-# LINE 336 "./src-ag/Order.ag" #-} _instDep1 Seq.>< _instDep2 {-# LINE 3305 "dist/build/Order.hs"#-} {-# INLINE rule448 #-} rule448 = \ ((_patternIerrors) :: Seq Error) ((_rhsIerrors) :: Seq Error) -> _patternIerrors Seq.>< _rhsIerrors {-# INLINE rule449 #-} rule449 = \ ((_patternIgathAltAttrs) :: [AltAttr]) -> _patternIgathAltAttrs {-# INLINE rule450 #-} rule450 = \ _gathRules -> _gathRules {-# INLINE rule451 #-} rule451 = \ ((_patternIinstVars) :: [Identifier]) -> _patternIinstVars {-# INLINE rule452 #-} rule452 = \ ((_patternIlocVars) :: [Identifier]) -> _patternIlocVars {-# INLINE rule453 #-} rule453 = \ ((_lhsIallTypeSigs) :: Map Identifier Type) -> _lhsIallTypeSigs {-# INLINE rule454 #-} rule454 = \ ((_lhsIaltAttrs) :: Map AltAttr Vertex) -> _lhsIaltAttrs {-# INLINE rule455 #-} rule455 = \ ((_lhsIcon) :: Identifier) -> _lhsIcon {-# INLINE rule456 #-} rule456 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule457 #-} rule457 = \ ((_lhsInt) :: Identifier) -> _lhsInt {-# INLINE rule458 #-} rule458 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# INLINE rule459 #-} rule459 = \ ((_lhsIallfields) :: [(Identifier,Type,ChildKind)]) -> _lhsIallfields {-# INLINE rule460 #-} rule460 = \ ((_lhsIallnts) :: [Identifier]) -> _lhsIallnts {-# INLINE rule461 #-} rule461 = \ ((_lhsIattrs) :: [(Identifier,Identifier)]) -> _lhsIattrs {-# INLINE rule462 #-} rule462 = \ ((_lhsIcon) :: Identifier) -> _lhsIcon {-# INLINE rule463 #-} rule463 = \ ((_lhsImergeMap) :: Map Identifier (Identifier,[Identifier])) -> _lhsImergeMap {-# INLINE rule464 #-} rule464 = \ ((_lhsInt) :: Identifier) -> _lhsInt -- Rules ------------------------------------------------------- -- wrapper data Inh_Rules = Inh_Rules { allTypeSigs_Inh_Rules :: (Map Identifier Type), allfields_Inh_Rules :: ([(Identifier,Type,ChildKind)]), allnts_Inh_Rules :: ([Identifier]), altAttrs_Inh_Rules :: (Map AltAttr Vertex), attrs_Inh_Rules :: ([(Identifier,Identifier)]), childInhs_Inh_Rules :: (Map Identifier Attributes), childNts_Inh_Rules :: (Map Identifier NontermIdent), con_Inh_Rules :: (Identifier), inh_Inh_Rules :: (Attributes), inhsOfChildren_Inh_Rules :: (Map Identifier Attributes), mergeMap_Inh_Rules :: (Map Identifier (Identifier,[Identifier])), nt_Inh_Rules :: (Identifier), o_case_Inh_Rules :: (Bool), o_cata_Inh_Rules :: (Bool), o_dovisit_Inh_Rules :: (Bool), o_newtypes_Inh_Rules :: (Bool), o_rename_Inh_Rules :: (Bool), o_sem_Inh_Rules :: (Bool), o_sig_Inh_Rules :: (Bool), o_wantvisit_Inh_Rules :: (Bool), prefix_Inh_Rules :: (String), syn_Inh_Rules :: (Attributes), synsOfChildren_Inh_Rules :: (Map Identifier Attributes) } data Syn_Rules = Syn_Rules { directDep_Syn_Rules :: (Seq Edge), errors_Syn_Rules :: (Seq Error), gathAltAttrs_Syn_Rules :: ([AltAttr]), gathRules_Syn_Rules :: (Seq CRule), instDep_Syn_Rules :: (Seq Edge), instVars_Syn_Rules :: ([Identifier]), locVars_Syn_Rules :: ([Identifier]), nAutoRules_Syn_Rules :: (Int), nExplicitRules_Syn_Rules :: (Int) } {-# INLINABLE wrap_Rules #-} wrap_Rules :: T_Rules -> Inh_Rules -> (Syn_Rules ) wrap_Rules (T_Rules act) (Inh_Rules _lhsIallTypeSigs _lhsIallfields _lhsIallnts _lhsIaltAttrs _lhsIattrs _lhsIchildInhs _lhsIchildNts _lhsIcon _lhsIinh _lhsIinhsOfChildren _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIsynsOfChildren) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Rules_vIn34 _lhsIallTypeSigs _lhsIallfields _lhsIallnts _lhsIaltAttrs _lhsIattrs _lhsIchildInhs _lhsIchildNts _lhsIcon _lhsIinh _lhsIinhsOfChildren _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIsynsOfChildren (T_Rules_vOut34 _lhsOdirectDep _lhsOerrors _lhsOgathAltAttrs _lhsOgathRules _lhsOinstDep _lhsOinstVars _lhsOlocVars _lhsOnAutoRules _lhsOnExplicitRules) <- return (inv_Rules_s35 sem arg) return (Syn_Rules _lhsOdirectDep _lhsOerrors _lhsOgathAltAttrs _lhsOgathRules _lhsOinstDep _lhsOinstVars _lhsOlocVars _lhsOnAutoRules _lhsOnExplicitRules) ) -- cata {-# NOINLINE sem_Rules #-} sem_Rules :: Rules -> T_Rules sem_Rules list = Prelude.foldr sem_Rules_Cons sem_Rules_Nil (Prelude.map sem_Rule list) -- semantic domain newtype T_Rules = T_Rules { attach_T_Rules :: Identity (T_Rules_s35 ) } newtype T_Rules_s35 = C_Rules_s35 { inv_Rules_s35 :: (T_Rules_v34 ) } data T_Rules_s36 = C_Rules_s36 type T_Rules_v34 = (T_Rules_vIn34 ) -> (T_Rules_vOut34 ) data T_Rules_vIn34 = T_Rules_vIn34 (Map Identifier Type) ([(Identifier,Type,ChildKind)]) ([Identifier]) (Map AltAttr Vertex) ([(Identifier,Identifier)]) (Map Identifier Attributes) (Map Identifier NontermIdent) (Identifier) (Attributes) (Map Identifier Attributes) (Map Identifier (Identifier,[Identifier])) (Identifier) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (String) (Attributes) (Map Identifier Attributes) data T_Rules_vOut34 = T_Rules_vOut34 (Seq Edge) (Seq Error) ([AltAttr]) (Seq CRule) (Seq Edge) ([Identifier]) ([Identifier]) (Int) (Int) {-# NOINLINE sem_Rules_Cons #-} sem_Rules_Cons :: T_Rule -> T_Rules -> T_Rules sem_Rules_Cons arg_hd_ arg_tl_ = T_Rules (return st35) where {-# NOINLINE st35 #-} st35 = let v34 :: T_Rules_v34 v34 = \ (T_Rules_vIn34 _lhsIallTypeSigs _lhsIallfields _lhsIallnts _lhsIaltAttrs _lhsIattrs _lhsIchildInhs _lhsIchildNts _lhsIcon _lhsIinh _lhsIinhsOfChildren _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIsynsOfChildren) -> ( let _hdX32 = Control.Monad.Identity.runIdentity (attach_T_Rule (arg_hd_)) _tlX35 = Control.Monad.Identity.runIdentity (attach_T_Rules (arg_tl_)) (T_Rule_vOut31 _hdIdirectDep _hdIerrors _hdIgathAltAttrs _hdIgathRules _hdIinstDep _hdIinstVars _hdIlocVars _hdInAutoRules _hdInExplicitRules) = inv_Rule_s32 _hdX32 (T_Rule_vIn31 _hdOallTypeSigs _hdOallfields _hdOallnts _hdOaltAttrs _hdOattrs _hdOchildInhs _hdOchildNts _hdOcon _hdOinh _hdOinhsOfChildren _hdOmergeMap _hdOnt _hdOo_case _hdOo_cata _hdOo_dovisit _hdOo_newtypes _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_wantvisit _hdOprefix _hdOsyn _hdOsynsOfChildren) (T_Rules_vOut34 _tlIdirectDep _tlIerrors _tlIgathAltAttrs _tlIgathRules _tlIinstDep _tlIinstVars _tlIlocVars _tlInAutoRules _tlInExplicitRules) = inv_Rules_s35 _tlX35 (T_Rules_vIn34 _tlOallTypeSigs _tlOallfields _tlOallnts _tlOaltAttrs _tlOattrs _tlOchildInhs _tlOchildNts _tlOcon _tlOinh _tlOinhsOfChildren _tlOmergeMap _tlOnt _tlOo_case _tlOo_cata _tlOo_dovisit _tlOo_newtypes _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_wantvisit _tlOprefix _tlOsyn _tlOsynsOfChildren) _lhsOdirectDep :: Seq Edge _lhsOdirectDep = rule465 _hdIdirectDep _tlIdirectDep _lhsOerrors :: Seq Error _lhsOerrors = rule466 _hdIerrors _tlIerrors _lhsOgathAltAttrs :: [AltAttr] _lhsOgathAltAttrs = rule467 _hdIgathAltAttrs _tlIgathAltAttrs _lhsOgathRules :: Seq CRule _lhsOgathRules = rule468 _hdIgathRules _tlIgathRules _lhsOinstDep :: Seq Edge _lhsOinstDep = rule469 _hdIinstDep _tlIinstDep _lhsOinstVars :: [Identifier] _lhsOinstVars = rule470 _hdIinstVars _tlIinstVars _lhsOlocVars :: [Identifier] _lhsOlocVars = rule471 _hdIlocVars _tlIlocVars _lhsOnAutoRules :: Int _lhsOnAutoRules = rule472 _hdInAutoRules _tlInAutoRules _lhsOnExplicitRules :: Int _lhsOnExplicitRules = rule473 _hdInExplicitRules _tlInExplicitRules _hdOallTypeSigs = rule474 _lhsIallTypeSigs _hdOallfields = rule475 _lhsIallfields _hdOallnts = rule476 _lhsIallnts _hdOaltAttrs = rule477 _lhsIaltAttrs _hdOattrs = rule478 _lhsIattrs _hdOchildInhs = rule479 _lhsIchildInhs _hdOchildNts = rule480 _lhsIchildNts _hdOcon = rule481 _lhsIcon _hdOinh = rule482 _lhsIinh _hdOinhsOfChildren = rule483 _lhsIinhsOfChildren _hdOmergeMap = rule484 _lhsImergeMap _hdOnt = rule485 _lhsInt _hdOo_case = rule486 _lhsIo_case _hdOo_cata = rule487 _lhsIo_cata _hdOo_dovisit = rule488 _lhsIo_dovisit _hdOo_newtypes = rule489 _lhsIo_newtypes _hdOo_rename = rule490 _lhsIo_rename _hdOo_sem = rule491 _lhsIo_sem _hdOo_sig = rule492 _lhsIo_sig _hdOo_wantvisit = rule493 _lhsIo_wantvisit _hdOprefix = rule494 _lhsIprefix _hdOsyn = rule495 _lhsIsyn _hdOsynsOfChildren = rule496 _lhsIsynsOfChildren _tlOallTypeSigs = rule497 _lhsIallTypeSigs _tlOallfields = rule498 _lhsIallfields _tlOallnts = rule499 _lhsIallnts _tlOaltAttrs = rule500 _lhsIaltAttrs _tlOattrs = rule501 _lhsIattrs _tlOchildInhs = rule502 _lhsIchildInhs _tlOchildNts = rule503 _lhsIchildNts _tlOcon = rule504 _lhsIcon _tlOinh = rule505 _lhsIinh _tlOinhsOfChildren = rule506 _lhsIinhsOfChildren _tlOmergeMap = rule507 _lhsImergeMap _tlOnt = rule508 _lhsInt _tlOo_case = rule509 _lhsIo_case _tlOo_cata = rule510 _lhsIo_cata _tlOo_dovisit = rule511 _lhsIo_dovisit _tlOo_newtypes = rule512 _lhsIo_newtypes _tlOo_rename = rule513 _lhsIo_rename _tlOo_sem = rule514 _lhsIo_sem _tlOo_sig = rule515 _lhsIo_sig _tlOo_wantvisit = rule516 _lhsIo_wantvisit _tlOprefix = rule517 _lhsIprefix _tlOsyn = rule518 _lhsIsyn _tlOsynsOfChildren = rule519 _lhsIsynsOfChildren __result_ = T_Rules_vOut34 _lhsOdirectDep _lhsOerrors _lhsOgathAltAttrs _lhsOgathRules _lhsOinstDep _lhsOinstVars _lhsOlocVars _lhsOnAutoRules _lhsOnExplicitRules in __result_ ) in C_Rules_s35 v34 {-# INLINE rule465 #-} rule465 = \ ((_hdIdirectDep) :: Seq Edge) ((_tlIdirectDep) :: Seq Edge) -> _hdIdirectDep Seq.>< _tlIdirectDep {-# INLINE rule466 #-} rule466 = \ ((_hdIerrors) :: Seq Error) ((_tlIerrors) :: Seq Error) -> _hdIerrors Seq.>< _tlIerrors {-# INLINE rule467 #-} rule467 = \ ((_hdIgathAltAttrs) :: [AltAttr]) ((_tlIgathAltAttrs) :: [AltAttr]) -> _hdIgathAltAttrs ++ _tlIgathAltAttrs {-# INLINE rule468 #-} rule468 = \ ((_hdIgathRules) :: Seq CRule) ((_tlIgathRules) :: Seq CRule) -> _hdIgathRules Seq.>< _tlIgathRules {-# INLINE rule469 #-} rule469 = \ ((_hdIinstDep) :: Seq Edge) ((_tlIinstDep) :: Seq Edge) -> _hdIinstDep Seq.>< _tlIinstDep {-# INLINE rule470 #-} rule470 = \ ((_hdIinstVars) :: [Identifier]) ((_tlIinstVars) :: [Identifier]) -> _hdIinstVars ++ _tlIinstVars {-# INLINE rule471 #-} rule471 = \ ((_hdIlocVars) :: [Identifier]) ((_tlIlocVars) :: [Identifier]) -> _hdIlocVars ++ _tlIlocVars {-# INLINE rule472 #-} rule472 = \ ((_hdInAutoRules) :: Int) ((_tlInAutoRules) :: Int) -> _hdInAutoRules + _tlInAutoRules {-# INLINE rule473 #-} rule473 = \ ((_hdInExplicitRules) :: Int) ((_tlInExplicitRules) :: Int) -> _hdInExplicitRules + _tlInExplicitRules {-# INLINE rule474 #-} rule474 = \ ((_lhsIallTypeSigs) :: Map Identifier Type) -> _lhsIallTypeSigs {-# INLINE rule475 #-} rule475 = \ ((_lhsIallfields) :: [(Identifier,Type,ChildKind)]) -> _lhsIallfields {-# INLINE rule476 #-} rule476 = \ ((_lhsIallnts) :: [Identifier]) -> _lhsIallnts {-# INLINE rule477 #-} rule477 = \ ((_lhsIaltAttrs) :: Map AltAttr Vertex) -> _lhsIaltAttrs {-# INLINE rule478 #-} rule478 = \ ((_lhsIattrs) :: [(Identifier,Identifier)]) -> _lhsIattrs {-# INLINE rule479 #-} rule479 = \ ((_lhsIchildInhs) :: Map Identifier Attributes) -> _lhsIchildInhs {-# INLINE rule480 #-} rule480 = \ ((_lhsIchildNts) :: Map Identifier NontermIdent) -> _lhsIchildNts {-# INLINE rule481 #-} rule481 = \ ((_lhsIcon) :: Identifier) -> _lhsIcon {-# INLINE rule482 #-} rule482 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule483 #-} rule483 = \ ((_lhsIinhsOfChildren) :: Map Identifier Attributes) -> _lhsIinhsOfChildren {-# INLINE rule484 #-} rule484 = \ ((_lhsImergeMap) :: Map Identifier (Identifier,[Identifier])) -> _lhsImergeMap {-# INLINE rule485 #-} rule485 = \ ((_lhsInt) :: Identifier) -> _lhsInt {-# INLINE rule486 #-} rule486 = \ ((_lhsIo_case) :: Bool) -> _lhsIo_case {-# INLINE rule487 #-} rule487 = \ ((_lhsIo_cata) :: Bool) -> _lhsIo_cata {-# INLINE rule488 #-} rule488 = \ ((_lhsIo_dovisit) :: Bool) -> _lhsIo_dovisit {-# INLINE rule489 #-} rule489 = \ ((_lhsIo_newtypes) :: Bool) -> _lhsIo_newtypes {-# INLINE rule490 #-} rule490 = \ ((_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# INLINE rule491 #-} rule491 = \ ((_lhsIo_sem) :: Bool) -> _lhsIo_sem {-# INLINE rule492 #-} rule492 = \ ((_lhsIo_sig) :: Bool) -> _lhsIo_sig {-# INLINE rule493 #-} rule493 = \ ((_lhsIo_wantvisit) :: Bool) -> _lhsIo_wantvisit {-# INLINE rule494 #-} rule494 = \ ((_lhsIprefix) :: String) -> _lhsIprefix {-# INLINE rule495 #-} rule495 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# INLINE rule496 #-} rule496 = \ ((_lhsIsynsOfChildren) :: Map Identifier Attributes) -> _lhsIsynsOfChildren {-# INLINE rule497 #-} rule497 = \ ((_lhsIallTypeSigs) :: Map Identifier Type) -> _lhsIallTypeSigs {-# INLINE rule498 #-} rule498 = \ ((_lhsIallfields) :: [(Identifier,Type,ChildKind)]) -> _lhsIallfields {-# INLINE rule499 #-} rule499 = \ ((_lhsIallnts) :: [Identifier]) -> _lhsIallnts {-# INLINE rule500 #-} rule500 = \ ((_lhsIaltAttrs) :: Map AltAttr Vertex) -> _lhsIaltAttrs {-# INLINE rule501 #-} rule501 = \ ((_lhsIattrs) :: [(Identifier,Identifier)]) -> _lhsIattrs {-# INLINE rule502 #-} rule502 = \ ((_lhsIchildInhs) :: Map Identifier Attributes) -> _lhsIchildInhs {-# INLINE rule503 #-} rule503 = \ ((_lhsIchildNts) :: Map Identifier NontermIdent) -> _lhsIchildNts {-# INLINE rule504 #-} rule504 = \ ((_lhsIcon) :: Identifier) -> _lhsIcon {-# INLINE rule505 #-} rule505 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule506 #-} rule506 = \ ((_lhsIinhsOfChildren) :: Map Identifier Attributes) -> _lhsIinhsOfChildren {-# INLINE rule507 #-} rule507 = \ ((_lhsImergeMap) :: Map Identifier (Identifier,[Identifier])) -> _lhsImergeMap {-# INLINE rule508 #-} rule508 = \ ((_lhsInt) :: Identifier) -> _lhsInt {-# INLINE rule509 #-} rule509 = \ ((_lhsIo_case) :: Bool) -> _lhsIo_case {-# INLINE rule510 #-} rule510 = \ ((_lhsIo_cata) :: Bool) -> _lhsIo_cata {-# INLINE rule511 #-} rule511 = \ ((_lhsIo_dovisit) :: Bool) -> _lhsIo_dovisit {-# INLINE rule512 #-} rule512 = \ ((_lhsIo_newtypes) :: Bool) -> _lhsIo_newtypes {-# INLINE rule513 #-} rule513 = \ ((_lhsIo_rename) :: Bool) -> _lhsIo_rename {-# INLINE rule514 #-} rule514 = \ ((_lhsIo_sem) :: Bool) -> _lhsIo_sem {-# INLINE rule515 #-} rule515 = \ ((_lhsIo_sig) :: Bool) -> _lhsIo_sig {-# INLINE rule516 #-} rule516 = \ ((_lhsIo_wantvisit) :: Bool) -> _lhsIo_wantvisit {-# INLINE rule517 #-} rule517 = \ ((_lhsIprefix) :: String) -> _lhsIprefix {-# INLINE rule518 #-} rule518 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# INLINE rule519 #-} rule519 = \ ((_lhsIsynsOfChildren) :: Map Identifier Attributes) -> _lhsIsynsOfChildren {-# NOINLINE sem_Rules_Nil #-} sem_Rules_Nil :: T_Rules sem_Rules_Nil = T_Rules (return st35) where {-# NOINLINE st35 #-} st35 = let v34 :: T_Rules_v34 v34 = \ (T_Rules_vIn34 _lhsIallTypeSigs _lhsIallfields _lhsIallnts _lhsIaltAttrs _lhsIattrs _lhsIchildInhs _lhsIchildNts _lhsIcon _lhsIinh _lhsIinhsOfChildren _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_wantvisit _lhsIprefix _lhsIsyn _lhsIsynsOfChildren) -> ( let _lhsOdirectDep :: Seq Edge _lhsOdirectDep = rule520 () _lhsOerrors :: Seq Error _lhsOerrors = rule521 () _lhsOgathAltAttrs :: [AltAttr] _lhsOgathAltAttrs = rule522 () _lhsOgathRules :: Seq CRule _lhsOgathRules = rule523 () _lhsOinstDep :: Seq Edge _lhsOinstDep = rule524 () _lhsOinstVars :: [Identifier] _lhsOinstVars = rule525 () _lhsOlocVars :: [Identifier] _lhsOlocVars = rule526 () _lhsOnAutoRules :: Int _lhsOnAutoRules = rule527 () _lhsOnExplicitRules :: Int _lhsOnExplicitRules = rule528 () __result_ = T_Rules_vOut34 _lhsOdirectDep _lhsOerrors _lhsOgathAltAttrs _lhsOgathRules _lhsOinstDep _lhsOinstVars _lhsOlocVars _lhsOnAutoRules _lhsOnExplicitRules in __result_ ) in C_Rules_s35 v34 {-# INLINE rule520 #-} rule520 = \ (_ :: ()) -> Seq.empty {-# INLINE rule521 #-} rule521 = \ (_ :: ()) -> Seq.empty {-# INLINE rule522 #-} rule522 = \ (_ :: ()) -> [] {-# INLINE rule523 #-} rule523 = \ (_ :: ()) -> Seq.empty {-# INLINE rule524 #-} rule524 = \ (_ :: ()) -> Seq.empty {-# INLINE rule525 #-} rule525 = \ (_ :: ()) -> [] {-# INLINE rule526 #-} rule526 = \ (_ :: ()) -> [] {-# INLINE rule527 #-} rule527 = \ (_ :: ()) -> 0 {-# INLINE rule528 #-} rule528 = \ (_ :: ()) -> 0 -- TypeSig ----------------------------------------------------- -- wrapper data Inh_TypeSig = Inh_TypeSig { typeSigs_Inh_TypeSig :: (Map Identifier Type) } data Syn_TypeSig = Syn_TypeSig { typeSigs_Syn_TypeSig :: (Map Identifier Type) } {-# INLINABLE wrap_TypeSig #-} wrap_TypeSig :: T_TypeSig -> Inh_TypeSig -> (Syn_TypeSig ) wrap_TypeSig (T_TypeSig act) (Inh_TypeSig _lhsItypeSigs) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_TypeSig_vIn37 _lhsItypeSigs (T_TypeSig_vOut37 _lhsOtypeSigs) <- return (inv_TypeSig_s38 sem arg) return (Syn_TypeSig _lhsOtypeSigs) ) -- cata {-# INLINE sem_TypeSig #-} sem_TypeSig :: TypeSig -> T_TypeSig sem_TypeSig ( TypeSig name_ tp_ ) = sem_TypeSig_TypeSig name_ tp_ -- semantic domain newtype T_TypeSig = T_TypeSig { attach_T_TypeSig :: Identity (T_TypeSig_s38 ) } newtype T_TypeSig_s38 = C_TypeSig_s38 { inv_TypeSig_s38 :: (T_TypeSig_v37 ) } data T_TypeSig_s39 = C_TypeSig_s39 type T_TypeSig_v37 = (T_TypeSig_vIn37 ) -> (T_TypeSig_vOut37 ) data T_TypeSig_vIn37 = T_TypeSig_vIn37 (Map Identifier Type) data T_TypeSig_vOut37 = T_TypeSig_vOut37 (Map Identifier Type) {-# NOINLINE sem_TypeSig_TypeSig #-} sem_TypeSig_TypeSig :: (Identifier) -> (Type) -> T_TypeSig sem_TypeSig_TypeSig arg_name_ arg_tp_ = T_TypeSig (return st38) where {-# NOINLINE st38 #-} st38 = let v37 :: T_TypeSig_v37 v37 = \ (T_TypeSig_vIn37 _lhsItypeSigs) -> ( let _lhsOtypeSigs :: Map Identifier Type _lhsOtypeSigs = rule529 _lhsItypeSigs arg_name_ arg_tp_ __result_ = T_TypeSig_vOut37 _lhsOtypeSigs in __result_ ) in C_TypeSig_s38 v37 {-# INLINE rule529 #-} {-# LINE 532 "./src-ag/Order.ag" #-} rule529 = \ ((_lhsItypeSigs) :: Map Identifier Type) name_ tp_ -> {-# LINE 532 "./src-ag/Order.ag" #-} Map.insert name_ tp_ _lhsItypeSigs {-# LINE 3734 "dist/build/Order.hs"#-} -- TypeSigs ---------------------------------------------------- -- wrapper data Inh_TypeSigs = Inh_TypeSigs { typeSigs_Inh_TypeSigs :: (Map Identifier Type) } data Syn_TypeSigs = Syn_TypeSigs { typeSigs_Syn_TypeSigs :: (Map Identifier Type) } {-# INLINABLE wrap_TypeSigs #-} wrap_TypeSigs :: T_TypeSigs -> Inh_TypeSigs -> (Syn_TypeSigs ) wrap_TypeSigs (T_TypeSigs act) (Inh_TypeSigs _lhsItypeSigs) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_TypeSigs_vIn40 _lhsItypeSigs (T_TypeSigs_vOut40 _lhsOtypeSigs) <- return (inv_TypeSigs_s41 sem arg) return (Syn_TypeSigs _lhsOtypeSigs) ) -- cata {-# NOINLINE sem_TypeSigs #-} sem_TypeSigs :: TypeSigs -> T_TypeSigs sem_TypeSigs list = Prelude.foldr sem_TypeSigs_Cons sem_TypeSigs_Nil (Prelude.map sem_TypeSig list) -- semantic domain newtype T_TypeSigs = T_TypeSigs { attach_T_TypeSigs :: Identity (T_TypeSigs_s41 ) } newtype T_TypeSigs_s41 = C_TypeSigs_s41 { inv_TypeSigs_s41 :: (T_TypeSigs_v40 ) } data T_TypeSigs_s42 = C_TypeSigs_s42 type T_TypeSigs_v40 = (T_TypeSigs_vIn40 ) -> (T_TypeSigs_vOut40 ) data T_TypeSigs_vIn40 = T_TypeSigs_vIn40 (Map Identifier Type) data T_TypeSigs_vOut40 = T_TypeSigs_vOut40 (Map Identifier Type) {-# NOINLINE sem_TypeSigs_Cons #-} sem_TypeSigs_Cons :: T_TypeSig -> T_TypeSigs -> T_TypeSigs sem_TypeSigs_Cons arg_hd_ arg_tl_ = T_TypeSigs (return st41) where {-# NOINLINE st41 #-} st41 = let v40 :: T_TypeSigs_v40 v40 = \ (T_TypeSigs_vIn40 _lhsItypeSigs) -> ( let _hdX38 = Control.Monad.Identity.runIdentity (attach_T_TypeSig (arg_hd_)) _tlX41 = Control.Monad.Identity.runIdentity (attach_T_TypeSigs (arg_tl_)) (T_TypeSig_vOut37 _hdItypeSigs) = inv_TypeSig_s38 _hdX38 (T_TypeSig_vIn37 _hdOtypeSigs) (T_TypeSigs_vOut40 _tlItypeSigs) = inv_TypeSigs_s41 _tlX41 (T_TypeSigs_vIn40 _tlOtypeSigs) _lhsOtypeSigs :: Map Identifier Type _lhsOtypeSigs = rule530 _tlItypeSigs _hdOtypeSigs = rule531 _lhsItypeSigs _tlOtypeSigs = rule532 _hdItypeSigs __result_ = T_TypeSigs_vOut40 _lhsOtypeSigs in __result_ ) in C_TypeSigs_s41 v40 {-# INLINE rule530 #-} rule530 = \ ((_tlItypeSigs) :: Map Identifier Type) -> _tlItypeSigs {-# INLINE rule531 #-} rule531 = \ ((_lhsItypeSigs) :: Map Identifier Type) -> _lhsItypeSigs {-# INLINE rule532 #-} rule532 = \ ((_hdItypeSigs) :: Map Identifier Type) -> _hdItypeSigs {-# NOINLINE sem_TypeSigs_Nil #-} sem_TypeSigs_Nil :: T_TypeSigs sem_TypeSigs_Nil = T_TypeSigs (return st41) where {-# NOINLINE st41 #-} st41 = let v40 :: T_TypeSigs_v40 v40 = \ (T_TypeSigs_vIn40 _lhsItypeSigs) -> ( let _lhsOtypeSigs :: Map Identifier Type _lhsOtypeSigs = rule533 _lhsItypeSigs __result_ = T_TypeSigs_vOut40 _lhsOtypeSigs in __result_ ) in C_TypeSigs_s41 v40 {-# INLINE rule533 #-} rule533 = \ ((_lhsItypeSigs) :: Map Identifier Type) -> _lhsItypeSigs uuagc-0.9.42.3/src-generated/Patterns.hs000644 000765 000024 00000003525 12127045231 021732 0ustar00jeroenbransenstaff000000 000000 -- UUAGC 0.9.42.3 (src-ag/Patterns.ag) module Patterns where {-# LINE 2 "./src-ag/Patterns.ag" #-} -- Patterns.ag imports import UU.Scanner.Position(Pos) import CommonTypes (ConstructorIdent,Identifier) {-# LINE 11 "dist/build/Patterns.hs" #-} -- Pattern ----------------------------------------------------- {- visit 0: synthesized attribute: copy : Pattern alternatives: alternative Constr: child name : {ConstructorIdent} child pats : Patterns visit 0: local copy : _ alternative Product: child pos : {Pos} child pats : Patterns visit 0: local copy : _ alternative Alias: child field : {Identifier} child attr : {Identifier} child pat : Pattern visit 0: local copy : _ alternative Irrefutable: child pat : Pattern visit 0: local copy : _ alternative Underscore: child pos : {Pos} visit 0: local copy : _ -} data Pattern = Constr (ConstructorIdent) (Patterns) | Product (Pos) (Patterns) | Alias (Identifier) (Identifier) (Pattern) | Irrefutable (Pattern) | Underscore (Pos) deriving ( Show) -- Patterns ---------------------------------------------------- {- visit 0: synthesized attribute: copy : Patterns alternatives: alternative Cons: child hd : Pattern child tl : Patterns visit 0: local copy : _ alternative Nil: visit 0: local copy : _ -} type Patterns = [Pattern]uuagc-0.9.42.3/src-generated/PrintCode.hs000644 000765 000024 00000566631 12127045231 022035 0ustar00jeroenbransenstaff000000 000000 {-# LANGUAGE Rank2Types, GADTs #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} module PrintCode where {-# LINE 2 "./src-ag/Code.ag" #-} import Patterns import Data.Set(Set) import qualified Data.Set as Set import Data.Map(Map) import qualified Data.Map as Map {-# LINE 14 "dist/build/PrintCode.hs" #-} {-# LINE 2 "./src-ag/Patterns.ag" #-} -- Patterns.ag imports import UU.Scanner.Position(Pos) import CommonTypes (ConstructorIdent,Identifier) {-# LINE 21 "dist/build/PrintCode.hs" #-} {-# LINE 10 "./src-ag/PrintCode.ag" #-} 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(..)) {-# LINE 35 "dist/build/PrintCode.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 144 "./src-ag/Code.ag" #-} -- 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 {-# LINE 55 "dist/build/PrintCode.hs" #-} {-# LINE 23 "./src-ag/PrintCode.ag" #-} type PP_Docs = [PP_Doc] {-# LINE 60 "dist/build/PrintCode.hs" #-} {-# LINE 27 "./src-ag/PrintCode.ag" #-} 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 {-# LINE 73 "dist/build/PrintCode.hs" #-} {-# LINE 299 "./src-ag/PrintCode.ag" #-} 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 {-# LINE 88 "dist/build/PrintCode.hs" #-} {-# LINE 400 "./src-ag/PrintCode.ag" #-} locname' :: Identifier -> [Char] locname' n = "_loc_" ++ getName n {-# LINE 94 "dist/build/PrintCode.hs" #-} {-# LINE 475 "./src-ag/PrintCode.ag" #-} renderDocs :: [PP_Doc] -> String renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) "" {-# LINE 100 "dist/build/PrintCode.hs" #-} {-# LINE 523 "./src-ag/PrintCode.ag" #-} 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 {-# LINE 117 "dist/build/PrintCode.hs" #-} -- CaseAlt ----------------------------------------------------- -- wrapper data Inh_CaseAlt = Inh_CaseAlt { nested_Inh_CaseAlt :: !(Bool), options_Inh_CaseAlt :: !(Options), outputfile_Inh_CaseAlt :: !(String) } data Syn_CaseAlt = Syn_CaseAlt { pps_Syn_CaseAlt :: !(PP_Docs) } {-# INLINABLE wrap_CaseAlt #-} wrap_CaseAlt :: T_CaseAlt -> Inh_CaseAlt -> (Syn_CaseAlt ) wrap_CaseAlt !(T_CaseAlt act) !(Inh_CaseAlt _lhsInested _lhsIoptions _lhsIoutputfile) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_CaseAlt_vIn1 _lhsInested _lhsIoptions _lhsIoutputfile !(T_CaseAlt_vOut1 _lhsOpps) <- return (inv_CaseAlt_s2 sem arg) return (Syn_CaseAlt _lhsOpps) ) -- cata {-# NOINLINE sem_CaseAlt #-} sem_CaseAlt :: CaseAlt -> T_CaseAlt sem_CaseAlt ( CaseAlt left_ expr_ ) = sem_CaseAlt_CaseAlt ( sem_Lhs left_ ) ( sem_Expr expr_ ) -- semantic domain newtype T_CaseAlt = T_CaseAlt { attach_T_CaseAlt :: Identity (T_CaseAlt_s2 ) } newtype T_CaseAlt_s2 = C_CaseAlt_s2 { inv_CaseAlt_s2 :: (T_CaseAlt_v1 ) } data T_CaseAlt_s3 = C_CaseAlt_s3 type T_CaseAlt_v1 = (T_CaseAlt_vIn1 ) -> (T_CaseAlt_vOut1 ) data T_CaseAlt_vIn1 = T_CaseAlt_vIn1 (Bool) (Options) (String) data T_CaseAlt_vOut1 = T_CaseAlt_vOut1 (PP_Docs) {-# NOINLINE sem_CaseAlt_CaseAlt #-} sem_CaseAlt_CaseAlt :: T_Lhs -> T_Expr -> T_CaseAlt sem_CaseAlt_CaseAlt arg_left_ arg_expr_ = T_CaseAlt (return st2) where {-# NOINLINE st2 #-} !st2 = let v1 :: T_CaseAlt_v1 v1 = \ !(T_CaseAlt_vIn1 _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _leftX32 = Control.Monad.Identity.runIdentity (attach_T_Lhs (arg_left_)) _exprX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_expr_)) (T_Lhs_vOut31 _leftIpp) = inv_Lhs_s32 _leftX32 (T_Lhs_vIn31 _leftOisDeclOfLet _leftOnested _leftOoptions _leftOoutputfile) (T_Expr_vOut25 _exprIpp) = inv_Expr_s26 _exprX26 (T_Expr_vIn25 _exprOnested _exprOoptions _exprOoutputfile) _lhsOpps :: PP_Docs _lhsOpps = rule0 _exprIpp _leftIpp _leftOisDeclOfLet = rule1 () _leftOnested = rule2 _lhsInested _leftOoptions = rule3 _lhsIoptions _leftOoutputfile = rule4 _lhsIoutputfile _exprOnested = rule5 _lhsInested _exprOoptions = rule6 _lhsIoptions _exprOoutputfile = rule7 _lhsIoutputfile !__result_ = T_CaseAlt_vOut1 _lhsOpps in __result_ ) in C_CaseAlt_s2 v1 {-# INLINE rule0 #-} {-# LINE 218 "./src-ag/PrintCode.ag" #-} rule0 = \ ((_exprIpp) :: PP_Doc) ((_leftIpp) :: PP_Doc) -> {-# LINE 218 "./src-ag/PrintCode.ag" #-} ["{" >#< _leftIpp >#< "->", _exprIpp >#< "}"] {-# LINE 176 "dist/build/PrintCode.hs"#-} {-# INLINE rule1 #-} {-# LINE 424 "./src-ag/PrintCode.ag" #-} rule1 = \ (_ :: ()) -> {-# LINE 424 "./src-ag/PrintCode.ag" #-} False {-# LINE 182 "dist/build/PrintCode.hs"#-} {-# INLINE rule2 #-} rule2 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule3 #-} rule3 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule4 #-} rule4 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# INLINE rule5 #-} rule5 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule6 #-} rule6 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule7 #-} rule7 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile -- CaseAlts ---------------------------------------------------- -- wrapper data Inh_CaseAlts = Inh_CaseAlts { nested_Inh_CaseAlts :: !(Bool), options_Inh_CaseAlts :: !(Options), outputfile_Inh_CaseAlts :: !(String) } data Syn_CaseAlts = Syn_CaseAlts { pps_Syn_CaseAlts :: !(PP_Docs) } {-# INLINABLE wrap_CaseAlts #-} wrap_CaseAlts :: T_CaseAlts -> Inh_CaseAlts -> (Syn_CaseAlts ) wrap_CaseAlts !(T_CaseAlts act) !(Inh_CaseAlts _lhsInested _lhsIoptions _lhsIoutputfile) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_CaseAlts_vIn4 _lhsInested _lhsIoptions _lhsIoutputfile !(T_CaseAlts_vOut4 _lhsOpps) <- return (inv_CaseAlts_s5 sem arg) return (Syn_CaseAlts _lhsOpps) ) -- cata {-# NOINLINE sem_CaseAlts #-} sem_CaseAlts :: CaseAlts -> T_CaseAlts sem_CaseAlts list = Prelude.foldr sem_CaseAlts_Cons sem_CaseAlts_Nil (Prelude.map sem_CaseAlt list) -- semantic domain newtype T_CaseAlts = T_CaseAlts { attach_T_CaseAlts :: Identity (T_CaseAlts_s5 ) } newtype T_CaseAlts_s5 = C_CaseAlts_s5 { inv_CaseAlts_s5 :: (T_CaseAlts_v4 ) } data T_CaseAlts_s6 = C_CaseAlts_s6 type T_CaseAlts_v4 = (T_CaseAlts_vIn4 ) -> (T_CaseAlts_vOut4 ) data T_CaseAlts_vIn4 = T_CaseAlts_vIn4 (Bool) (Options) (String) data T_CaseAlts_vOut4 = T_CaseAlts_vOut4 (PP_Docs) {-# NOINLINE sem_CaseAlts_Cons #-} sem_CaseAlts_Cons :: T_CaseAlt -> T_CaseAlts -> T_CaseAlts sem_CaseAlts_Cons arg_hd_ arg_tl_ = T_CaseAlts (return st5) where {-# NOINLINE st5 #-} !st5 = let v4 :: T_CaseAlts_v4 v4 = \ !(T_CaseAlts_vIn4 _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _hdX2 = Control.Monad.Identity.runIdentity (attach_T_CaseAlt (arg_hd_)) _tlX5 = Control.Monad.Identity.runIdentity (attach_T_CaseAlts (arg_tl_)) (T_CaseAlt_vOut1 _hdIpps) = inv_CaseAlt_s2 _hdX2 (T_CaseAlt_vIn1 _hdOnested _hdOoptions _hdOoutputfile) (T_CaseAlts_vOut4 _tlIpps) = inv_CaseAlts_s5 _tlX5 (T_CaseAlts_vIn4 _tlOnested _tlOoptions _tlOoutputfile) _lhsOpps :: PP_Docs _lhsOpps = rule8 _hdIpps _tlIpps _hdOnested = rule9 _lhsInested _hdOoptions = rule10 _lhsIoptions _hdOoutputfile = rule11 _lhsIoutputfile _tlOnested = rule12 _lhsInested _tlOoptions = rule13 _lhsIoptions _tlOoutputfile = rule14 _lhsIoutputfile !__result_ = T_CaseAlts_vOut4 _lhsOpps in __result_ ) in C_CaseAlts_s5 v4 {-# INLINE rule8 #-} {-# LINE 68 "./src-ag/PrintCode.ag" #-} rule8 = \ ((_hdIpps) :: PP_Docs) ((_tlIpps) :: PP_Docs) -> {-# LINE 68 "./src-ag/PrintCode.ag" #-} _hdIpps ++ _tlIpps {-# LINE 259 "dist/build/PrintCode.hs"#-} {-# INLINE rule9 #-} rule9 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule10 #-} rule10 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule11 #-} rule11 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# INLINE rule12 #-} rule12 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule13 #-} rule13 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule14 #-} rule14 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# NOINLINE sem_CaseAlts_Nil #-} sem_CaseAlts_Nil :: T_CaseAlts sem_CaseAlts_Nil = T_CaseAlts (return st5) where {-# NOINLINE st5 #-} !st5 = let v4 :: T_CaseAlts_v4 v4 = \ !(T_CaseAlts_vIn4 _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _lhsOpps :: PP_Docs _lhsOpps = rule15 () !__result_ = T_CaseAlts_vOut4 _lhsOpps in __result_ ) in C_CaseAlts_s5 v4 {-# INLINE rule15 #-} {-# LINE 69 "./src-ag/PrintCode.ag" #-} rule15 = \ (_ :: ()) -> {-# LINE 69 "./src-ag/PrintCode.ag" #-} [] {-# LINE 295 "dist/build/PrintCode.hs"#-} -- Chunk ------------------------------------------------------- -- wrapper data Inh_Chunk = Inh_Chunk { importBlocks_Inh_Chunk :: !(PP_Doc), isDeclOfLet_Inh_Chunk :: !(Bool), mainFile_Inh_Chunk :: !(String), mainName_Inh_Chunk :: !(String), moduleHeader_Inh_Chunk :: !(String -> String -> String -> Bool -> String), nested_Inh_Chunk :: !(Bool), options_Inh_Chunk :: !(Options), optionsLine_Inh_Chunk :: !(String), pragmaBlocks_Inh_Chunk :: !(String), textBlockMap_Inh_Chunk :: !(Map BlockInfo PP_Doc), textBlocks_Inh_Chunk :: !(PP_Doc) } data Syn_Chunk = Syn_Chunk { appendCommon_Syn_Chunk :: !([[PP_Doc]]), appendMain_Syn_Chunk :: !([[PP_Doc]]), genSems_Syn_Chunk :: !(IO ()), imports_Syn_Chunk :: !([String]), pps_Syn_Chunk :: !(PP_Docs) } {-# INLINABLE wrap_Chunk #-} wrap_Chunk :: T_Chunk -> Inh_Chunk -> (Syn_Chunk ) wrap_Chunk !(T_Chunk act) !(Inh_Chunk _lhsIimportBlocks _lhsIisDeclOfLet _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInested _lhsIoptions _lhsIoptionsLine _lhsIpragmaBlocks _lhsItextBlockMap _lhsItextBlocks) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Chunk_vIn7 _lhsIimportBlocks _lhsIisDeclOfLet _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInested _lhsIoptions _lhsIoptionsLine _lhsIpragmaBlocks _lhsItextBlockMap _lhsItextBlocks !(T_Chunk_vOut7 _lhsOappendCommon _lhsOappendMain _lhsOgenSems _lhsOimports _lhsOpps) <- return (inv_Chunk_s8 sem arg) return (Syn_Chunk _lhsOappendCommon _lhsOappendMain _lhsOgenSems _lhsOimports _lhsOpps) ) -- cata {-# INLINE sem_Chunk #-} sem_Chunk :: Chunk -> T_Chunk sem_Chunk ( Chunk !name_ comment_ info_ dataDef_ cataFun_ semDom_ semWrapper_ semFunctions_ !semNames_ ) = sem_Chunk_Chunk name_ ( sem_Decl comment_ ) ( sem_Decls info_ ) ( sem_Decls dataDef_ ) ( sem_Decls cataFun_ ) ( sem_Decls semDom_ ) ( sem_Decls semWrapper_ ) ( sem_Decls semFunctions_ ) semNames_ -- semantic domain newtype T_Chunk = T_Chunk { attach_T_Chunk :: Identity (T_Chunk_s8 ) } newtype T_Chunk_s8 = C_Chunk_s8 { inv_Chunk_s8 :: (T_Chunk_v7 ) } data T_Chunk_s9 = C_Chunk_s9 type T_Chunk_v7 = (T_Chunk_vIn7 ) -> (T_Chunk_vOut7 ) data T_Chunk_vIn7 = T_Chunk_vIn7 (PP_Doc) (Bool) (String) (String) (String -> String -> String -> Bool -> String) (Bool) (Options) (String) (String) (Map BlockInfo PP_Doc) (PP_Doc) data T_Chunk_vOut7 = T_Chunk_vOut7 ([[PP_Doc]]) ([[PP_Doc]]) (IO ()) ([String]) (PP_Docs) {-# NOINLINE sem_Chunk_Chunk #-} sem_Chunk_Chunk :: (String) -> T_Decl -> T_Decls -> T_Decls -> T_Decls -> T_Decls -> T_Decls -> T_Decls -> ([String]) -> T_Chunk sem_Chunk_Chunk !arg_name_ arg_comment_ arg_info_ arg_dataDef_ arg_cataFun_ arg_semDom_ arg_semWrapper_ arg_semFunctions_ !arg_semNames_ = T_Chunk (return st8) where {-# NOINLINE st8 #-} !st8 = let v7 :: T_Chunk_v7 v7 = \ !(T_Chunk_vIn7 _lhsIimportBlocks _lhsIisDeclOfLet _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInested _lhsIoptions _lhsIoptionsLine _lhsIpragmaBlocks _lhsItextBlockMap _lhsItextBlocks) -> ( let _commentX20 = Control.Monad.Identity.runIdentity (attach_T_Decl (arg_comment_)) _infoX23 = Control.Monad.Identity.runIdentity (attach_T_Decls (arg_info_)) _dataDefX23 = Control.Monad.Identity.runIdentity (attach_T_Decls (arg_dataDef_)) _cataFunX23 = Control.Monad.Identity.runIdentity (attach_T_Decls (arg_cataFun_)) _semDomX23 = Control.Monad.Identity.runIdentity (attach_T_Decls (arg_semDom_)) _semWrapperX23 = Control.Monad.Identity.runIdentity (attach_T_Decls (arg_semWrapper_)) _semFunctionsX23 = Control.Monad.Identity.runIdentity (attach_T_Decls (arg_semFunctions_)) (T_Decl_vOut19 _commentIpp) = inv_Decl_s20 _commentX20 (T_Decl_vIn19 _commentOisDeclOfLet _commentOnested _commentOoptions _commentOoutputfile) (T_Decls_vOut22 _infoIpps) = inv_Decls_s23 _infoX23 (T_Decls_vIn22 _infoOisDeclOfLet _infoOnested _infoOoptions _infoOoutputfile) (T_Decls_vOut22 _dataDefIpps) = inv_Decls_s23 _dataDefX23 (T_Decls_vIn22 _dataDefOisDeclOfLet _dataDefOnested _dataDefOoptions _dataDefOoutputfile) (T_Decls_vOut22 _cataFunIpps) = inv_Decls_s23 _cataFunX23 (T_Decls_vIn22 _cataFunOisDeclOfLet _cataFunOnested _cataFunOoptions _cataFunOoutputfile) (T_Decls_vOut22 _semDomIpps) = inv_Decls_s23 _semDomX23 (T_Decls_vIn22 _semDomOisDeclOfLet _semDomOnested _semDomOoptions _semDomOoutputfile) (T_Decls_vOut22 _semWrapperIpps) = inv_Decls_s23 _semWrapperX23 (T_Decls_vIn22 _semWrapperOisDeclOfLet _semWrapperOnested _semWrapperOoptions _semWrapperOoutputfile) (T_Decls_vOut22 _semFunctionsIpps) = inv_Decls_s23 _semFunctionsX23 (T_Decls_vIn22 _semFunctionsOisDeclOfLet _semFunctionsOnested _semFunctionsOoptions _semFunctionsOoutputfile) _outputfile = rule16 _lhsImainFile _lhsIoptions arg_name_ _lhsOpps :: PP_Docs _lhsOpps = rule17 _cataFunIpps _commentIpp _dataDefIpps _infoIpps _lhsItextBlockMap _semDomIpps _semFunctionsIpps _semWrapperIpps arg_name_ _lhsOimports :: [String] _lhsOimports = rule18 _lhsImainName arg_name_ _lhsOappendCommon :: [[PP_Doc]] _lhsOappendCommon = rule19 _commentIpp _dataDefIpps _lhsIoptions _semDomIpps _semWrapperIpps _lhsOappendMain :: [[PP_Doc]] _lhsOappendMain = rule20 _cataFunIpps _commentIpp _lhsIoptions _semWrapperIpps _lhsOgenSems :: IO () _lhsOgenSems = rule21 _commentIpp _exports _infoIpps _lhsImainName _lhsImoduleHeader _lhsIoptionsLine _lhsIpragmaBlocks _lhsItextBlockMap _outputfile _semFunctionsIpps arg_name_ _exports = rule22 arg_semNames_ _commentOisDeclOfLet = rule23 _lhsIisDeclOfLet _commentOnested = rule24 _lhsInested _commentOoptions = rule25 _lhsIoptions _commentOoutputfile = rule26 _outputfile _infoOisDeclOfLet = rule27 _lhsIisDeclOfLet _infoOnested = rule28 _lhsInested _infoOoptions = rule29 _lhsIoptions _infoOoutputfile = rule30 _outputfile _dataDefOisDeclOfLet = rule31 _lhsIisDeclOfLet _dataDefOnested = rule32 _lhsInested _dataDefOoptions = rule33 _lhsIoptions _dataDefOoutputfile = rule34 _outputfile _cataFunOisDeclOfLet = rule35 _lhsIisDeclOfLet _cataFunOnested = rule36 _lhsInested _cataFunOoptions = rule37 _lhsIoptions _cataFunOoutputfile = rule38 _outputfile _semDomOisDeclOfLet = rule39 _lhsIisDeclOfLet _semDomOnested = rule40 _lhsInested _semDomOoptions = rule41 _lhsIoptions _semDomOoutputfile = rule42 _outputfile _semWrapperOisDeclOfLet = rule43 _lhsIisDeclOfLet _semWrapperOnested = rule44 _lhsInested _semWrapperOoptions = rule45 _lhsIoptions _semWrapperOoutputfile = rule46 _outputfile _semFunctionsOisDeclOfLet = rule47 _lhsIisDeclOfLet _semFunctionsOnested = rule48 _lhsInested _semFunctionsOoptions = rule49 _lhsIoptions _semFunctionsOoutputfile = rule50 _outputfile !__result_ = T_Chunk_vOut7 _lhsOappendCommon _lhsOappendMain _lhsOgenSems _lhsOimports _lhsOpps in __result_ ) in C_Chunk_s8 v7 {-# INLINE rule16 #-} {-# LINE 43 "./src-ag/PrintCode.ag" #-} rule16 = \ ((_lhsImainFile) :: String) ((_lhsIoptions) :: Options) name_ -> {-# LINE 43 "./src-ag/PrintCode.ag" #-} if sepSemMods _lhsIoptions then replaceBaseName _lhsImainFile (takeBaseName _lhsImainFile ++ "_" ++ name_) else _lhsImainFile {-# LINE 398 "dist/build/PrintCode.hs"#-} {-# INLINE rule17 #-} {-# LINE 96 "./src-ag/PrintCode.ag" #-} rule17 = \ ((_cataFunIpps) :: PP_Docs) ((_commentIpp) :: PP_Doc) ((_dataDefIpps) :: PP_Docs) ((_infoIpps) :: PP_Docs) ((_lhsItextBlockMap) :: Map BlockInfo PP_Doc) ((_semDomIpps) :: PP_Docs) ((_semFunctionsIpps) :: PP_Docs) ((_semWrapperIpps) :: PP_Docs) name_ -> {-# LINE 96 "./src-ag/PrintCode.ag" #-} _commentIpp : _infoIpps ++ _dataDefIpps ++ _cataFunIpps ++ _semDomIpps ++ _semWrapperIpps ++ _semFunctionsIpps ++ [Map.findWithDefault empty (BlockOther, Just $ identifier name_) _lhsItextBlockMap] {-# LINE 411 "dist/build/PrintCode.hs"#-} {-# INLINE rule18 #-} {-# LINE 483 "./src-ag/PrintCode.ag" #-} rule18 = \ ((_lhsImainName) :: String) name_ -> {-# LINE 483 "./src-ag/PrintCode.ag" #-} ["import " ++ _lhsImainName ++ "_" ++ name_ ++ "\n"] {-# LINE 417 "dist/build/PrintCode.hs"#-} {-# INLINE rule19 #-} {-# LINE 490 "./src-ag/PrintCode.ag" #-} rule19 = \ ((_commentIpp) :: PP_Doc) ((_dataDefIpps) :: PP_Docs) ((_lhsIoptions) :: Options) ((_semDomIpps) :: PP_Docs) ((_semWrapperIpps) :: PP_Docs) -> {-# LINE 490 "./src-ag/PrintCode.ag" #-} [ [_commentIpp] , _dataDefIpps , _semDomIpps , if reference _lhsIoptions then _semWrapperIpps else [] ] {-# LINE 427 "dist/build/PrintCode.hs"#-} {-# INLINE rule20 #-} {-# LINE 496 "./src-ag/PrintCode.ag" #-} rule20 = \ ((_cataFunIpps) :: PP_Docs) ((_commentIpp) :: PP_Doc) ((_lhsIoptions) :: Options) ((_semWrapperIpps) :: PP_Docs) -> {-# LINE 496 "./src-ag/PrintCode.ag" #-} [ [_commentIpp] , _cataFunIpps , if reference _lhsIoptions then [] else _semWrapperIpps ] {-# LINE 436 "dist/build/PrintCode.hs"#-} {-# INLINE rule21 #-} {-# LINE 506 "./src-ag/PrintCode.ag" #-} rule21 = \ ((_commentIpp) :: PP_Doc) _exports ((_infoIpps) :: PP_Docs) ((_lhsImainName) :: String) ((_lhsImoduleHeader) :: String -> String -> String -> Bool -> String) ((_lhsIoptionsLine) :: String) ((_lhsIpragmaBlocks) :: String) ((_lhsItextBlockMap) :: Map BlockInfo PP_Doc) _outputfile ((_semFunctionsIpps) :: PP_Docs) name_ -> {-# LINE 506 "./src-ag/PrintCode.ag" #-} writeModule _outputfile [ pp $ _lhsIpragmaBlocks , pp $ Map.findWithDefault empty (BlockPragma, Just $ identifier name_) _lhsItextBlockMap , pp $ _lhsIoptionsLine , pp $ _lhsImoduleHeader _lhsImainName ("_" ++ name_) _exports True , pp $ ("import " ++ _lhsImainName ++ "_common\n") , pp $ Map.findWithDefault empty (BlockImport, Just $ identifier name_) _lhsItextBlockMap , _commentIpp , vlist_sep "" _infoIpps , vlist_sep "" _semFunctionsIpps , Map.findWithDefault empty (BlockOther, Just $ identifier name_) _lhsItextBlockMap ] {-# LINE 453 "dist/build/PrintCode.hs"#-} {-# INLINE rule22 #-} {-# LINE 521 "./src-ag/PrintCode.ag" #-} rule22 = \ semNames_ -> {-# LINE 521 "./src-ag/PrintCode.ag" #-} concat $ intersperse "," semNames_ {-# LINE 459 "dist/build/PrintCode.hs"#-} {-# INLINE rule23 #-} rule23 = \ ((_lhsIisDeclOfLet) :: Bool) -> _lhsIisDeclOfLet {-# INLINE rule24 #-} rule24 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule25 #-} rule25 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule26 #-} rule26 = \ _outputfile -> _outputfile {-# INLINE rule27 #-} rule27 = \ ((_lhsIisDeclOfLet) :: Bool) -> _lhsIisDeclOfLet {-# INLINE rule28 #-} rule28 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule29 #-} rule29 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule30 #-} rule30 = \ _outputfile -> _outputfile {-# INLINE rule31 #-} rule31 = \ ((_lhsIisDeclOfLet) :: Bool) -> _lhsIisDeclOfLet {-# INLINE rule32 #-} rule32 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule33 #-} rule33 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule34 #-} rule34 = \ _outputfile -> _outputfile {-# INLINE rule35 #-} rule35 = \ ((_lhsIisDeclOfLet) :: Bool) -> _lhsIisDeclOfLet {-# INLINE rule36 #-} rule36 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule37 #-} rule37 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule38 #-} rule38 = \ _outputfile -> _outputfile {-# INLINE rule39 #-} rule39 = \ ((_lhsIisDeclOfLet) :: Bool) -> _lhsIisDeclOfLet {-# INLINE rule40 #-} rule40 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule41 #-} rule41 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule42 #-} rule42 = \ _outputfile -> _outputfile {-# INLINE rule43 #-} rule43 = \ ((_lhsIisDeclOfLet) :: Bool) -> _lhsIisDeclOfLet {-# INLINE rule44 #-} rule44 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule45 #-} rule45 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule46 #-} rule46 = \ _outputfile -> _outputfile {-# INLINE rule47 #-} rule47 = \ ((_lhsIisDeclOfLet) :: Bool) -> _lhsIisDeclOfLet {-# INLINE rule48 #-} rule48 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule49 #-} rule49 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule50 #-} rule50 = \ _outputfile -> _outputfile -- Chunks ------------------------------------------------------ -- wrapper data Inh_Chunks = Inh_Chunks { importBlocks_Inh_Chunks :: !(PP_Doc), isDeclOfLet_Inh_Chunks :: !(Bool), mainFile_Inh_Chunks :: !(String), mainName_Inh_Chunks :: !(String), moduleHeader_Inh_Chunks :: !(String -> String -> String -> Bool -> String), nested_Inh_Chunks :: !(Bool), options_Inh_Chunks :: !(Options), optionsLine_Inh_Chunks :: !(String), pragmaBlocks_Inh_Chunks :: !(String), textBlockMap_Inh_Chunks :: !(Map BlockInfo PP_Doc), textBlocks_Inh_Chunks :: !(PP_Doc) } data Syn_Chunks = Syn_Chunks { appendCommon_Syn_Chunks :: !([[PP_Doc]]), appendMain_Syn_Chunks :: !([[PP_Doc]]), genSems_Syn_Chunks :: !(IO ()), imports_Syn_Chunks :: !([String]), pps_Syn_Chunks :: !(PP_Docs) } {-# INLINABLE wrap_Chunks #-} wrap_Chunks :: T_Chunks -> Inh_Chunks -> (Syn_Chunks ) wrap_Chunks !(T_Chunks act) !(Inh_Chunks _lhsIimportBlocks _lhsIisDeclOfLet _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInested _lhsIoptions _lhsIoptionsLine _lhsIpragmaBlocks _lhsItextBlockMap _lhsItextBlocks) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Chunks_vIn10 _lhsIimportBlocks _lhsIisDeclOfLet _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInested _lhsIoptions _lhsIoptionsLine _lhsIpragmaBlocks _lhsItextBlockMap _lhsItextBlocks !(T_Chunks_vOut10 _lhsOappendCommon _lhsOappendMain _lhsOgenSems _lhsOimports _lhsOpps) <- return (inv_Chunks_s11 sem arg) return (Syn_Chunks _lhsOappendCommon _lhsOappendMain _lhsOgenSems _lhsOimports _lhsOpps) ) -- cata {-# NOINLINE sem_Chunks #-} sem_Chunks :: Chunks -> T_Chunks sem_Chunks list = Prelude.foldr sem_Chunks_Cons sem_Chunks_Nil (Prelude.map sem_Chunk list) -- semantic domain newtype T_Chunks = T_Chunks { attach_T_Chunks :: Identity (T_Chunks_s11 ) } newtype T_Chunks_s11 = C_Chunks_s11 { inv_Chunks_s11 :: (T_Chunks_v10 ) } data T_Chunks_s12 = C_Chunks_s12 type T_Chunks_v10 = (T_Chunks_vIn10 ) -> (T_Chunks_vOut10 ) data T_Chunks_vIn10 = T_Chunks_vIn10 (PP_Doc) (Bool) (String) (String) (String -> String -> String -> Bool -> String) (Bool) (Options) (String) (String) (Map BlockInfo PP_Doc) (PP_Doc) data T_Chunks_vOut10 = T_Chunks_vOut10 ([[PP_Doc]]) ([[PP_Doc]]) (IO ()) ([String]) (PP_Docs) {-# NOINLINE sem_Chunks_Cons #-} sem_Chunks_Cons :: T_Chunk -> T_Chunks -> T_Chunks sem_Chunks_Cons arg_hd_ arg_tl_ = T_Chunks (return st11) where {-# NOINLINE st11 #-} !st11 = let v10 :: T_Chunks_v10 v10 = \ !(T_Chunks_vIn10 _lhsIimportBlocks _lhsIisDeclOfLet _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInested _lhsIoptions _lhsIoptionsLine _lhsIpragmaBlocks _lhsItextBlockMap _lhsItextBlocks) -> ( let _hdX8 = Control.Monad.Identity.runIdentity (attach_T_Chunk (arg_hd_)) _tlX11 = Control.Monad.Identity.runIdentity (attach_T_Chunks (arg_tl_)) (T_Chunk_vOut7 _hdIappendCommon _hdIappendMain _hdIgenSems _hdIimports _hdIpps) = inv_Chunk_s8 _hdX8 (T_Chunk_vIn7 _hdOimportBlocks _hdOisDeclOfLet _hdOmainFile _hdOmainName _hdOmoduleHeader _hdOnested _hdOoptions _hdOoptionsLine _hdOpragmaBlocks _hdOtextBlockMap _hdOtextBlocks) (T_Chunks_vOut10 _tlIappendCommon _tlIappendMain _tlIgenSems _tlIimports _tlIpps) = inv_Chunks_s11 _tlX11 (T_Chunks_vIn10 _tlOimportBlocks _tlOisDeclOfLet _tlOmainFile _tlOmainName _tlOmoduleHeader _tlOnested _tlOoptions _tlOoptionsLine _tlOpragmaBlocks _tlOtextBlockMap _tlOtextBlocks) _lhsOpps :: PP_Docs _lhsOpps = rule51 _hdIpps _tlIpps _lhsOappendCommon :: [[PP_Doc]] _lhsOappendCommon = rule52 _hdIappendCommon _tlIappendCommon _lhsOappendMain :: [[PP_Doc]] _lhsOappendMain = rule53 _hdIappendMain _tlIappendMain _lhsOgenSems :: IO () _lhsOgenSems = rule54 _hdIgenSems _tlIgenSems _lhsOimports :: [String] _lhsOimports = rule55 _hdIimports _tlIimports _hdOimportBlocks = rule56 _lhsIimportBlocks _hdOisDeclOfLet = rule57 _lhsIisDeclOfLet _hdOmainFile = rule58 _lhsImainFile _hdOmainName = rule59 _lhsImainName _hdOmoduleHeader = rule60 _lhsImoduleHeader _hdOnested = rule61 _lhsInested _hdOoptions = rule62 _lhsIoptions _hdOoptionsLine = rule63 _lhsIoptionsLine _hdOpragmaBlocks = rule64 _lhsIpragmaBlocks _hdOtextBlockMap = rule65 _lhsItextBlockMap _hdOtextBlocks = rule66 _lhsItextBlocks _tlOimportBlocks = rule67 _lhsIimportBlocks _tlOisDeclOfLet = rule68 _lhsIisDeclOfLet _tlOmainFile = rule69 _lhsImainFile _tlOmainName = rule70 _lhsImainName _tlOmoduleHeader = rule71 _lhsImoduleHeader _tlOnested = rule72 _lhsInested _tlOoptions = rule73 _lhsIoptions _tlOoptionsLine = rule74 _lhsIoptionsLine _tlOpragmaBlocks = rule75 _lhsIpragmaBlocks _tlOtextBlockMap = rule76 _lhsItextBlockMap _tlOtextBlocks = rule77 _lhsItextBlocks !__result_ = T_Chunks_vOut10 _lhsOappendCommon _lhsOappendMain _lhsOgenSems _lhsOimports _lhsOpps in __result_ ) in C_Chunks_s11 v10 {-# INLINE rule51 #-} {-# LINE 88 "./src-ag/PrintCode.ag" #-} rule51 = \ ((_hdIpps) :: PP_Docs) ((_tlIpps) :: PP_Docs) -> {-# LINE 88 "./src-ag/PrintCode.ag" #-} _hdIpps ++ _tlIpps {-# LINE 626 "dist/build/PrintCode.hs"#-} {-# INLINE rule52 #-} rule52 = \ ((_hdIappendCommon) :: [[PP_Doc]]) ((_tlIappendCommon) :: [[PP_Doc]]) -> _hdIappendCommon ++ _tlIappendCommon {-# INLINE rule53 #-} rule53 = \ ((_hdIappendMain) :: [[PP_Doc]]) ((_tlIappendMain) :: [[PP_Doc]]) -> _hdIappendMain ++ _tlIappendMain {-# INLINE rule54 #-} rule54 = \ ((_hdIgenSems) :: IO ()) ((_tlIgenSems) :: IO ()) -> _hdIgenSems >> _tlIgenSems {-# INLINE rule55 #-} rule55 = \ ((_hdIimports) :: [String]) ((_tlIimports) :: [String]) -> _hdIimports ++ _tlIimports {-# INLINE rule56 #-} rule56 = \ ((_lhsIimportBlocks) :: PP_Doc) -> _lhsIimportBlocks {-# INLINE rule57 #-} rule57 = \ ((_lhsIisDeclOfLet) :: Bool) -> _lhsIisDeclOfLet {-# INLINE rule58 #-} rule58 = \ ((_lhsImainFile) :: String) -> _lhsImainFile {-# INLINE rule59 #-} rule59 = \ ((_lhsImainName) :: String) -> _lhsImainName {-# INLINE rule60 #-} rule60 = \ ((_lhsImoduleHeader) :: String -> String -> String -> Bool -> String) -> _lhsImoduleHeader {-# INLINE rule61 #-} rule61 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule62 #-} rule62 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule63 #-} rule63 = \ ((_lhsIoptionsLine) :: String) -> _lhsIoptionsLine {-# INLINE rule64 #-} rule64 = \ ((_lhsIpragmaBlocks) :: String) -> _lhsIpragmaBlocks {-# INLINE rule65 #-} rule65 = \ ((_lhsItextBlockMap) :: Map BlockInfo PP_Doc) -> _lhsItextBlockMap {-# INLINE rule66 #-} rule66 = \ ((_lhsItextBlocks) :: PP_Doc) -> _lhsItextBlocks {-# INLINE rule67 #-} rule67 = \ ((_lhsIimportBlocks) :: PP_Doc) -> _lhsIimportBlocks {-# INLINE rule68 #-} rule68 = \ ((_lhsIisDeclOfLet) :: Bool) -> _lhsIisDeclOfLet {-# INLINE rule69 #-} rule69 = \ ((_lhsImainFile) :: String) -> _lhsImainFile {-# INLINE rule70 #-} rule70 = \ ((_lhsImainName) :: String) -> _lhsImainName {-# INLINE rule71 #-} rule71 = \ ((_lhsImoduleHeader) :: String -> String -> String -> Bool -> String) -> _lhsImoduleHeader {-# INLINE rule72 #-} rule72 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule73 #-} rule73 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule74 #-} rule74 = \ ((_lhsIoptionsLine) :: String) -> _lhsIoptionsLine {-# INLINE rule75 #-} rule75 = \ ((_lhsIpragmaBlocks) :: String) -> _lhsIpragmaBlocks {-# INLINE rule76 #-} rule76 = \ ((_lhsItextBlockMap) :: Map BlockInfo PP_Doc) -> _lhsItextBlockMap {-# INLINE rule77 #-} rule77 = \ ((_lhsItextBlocks) :: PP_Doc) -> _lhsItextBlocks {-# NOINLINE sem_Chunks_Nil #-} sem_Chunks_Nil :: T_Chunks sem_Chunks_Nil = T_Chunks (return st11) where {-# NOINLINE st11 #-} !st11 = let v10 :: T_Chunks_v10 v10 = \ !(T_Chunks_vIn10 _lhsIimportBlocks _lhsIisDeclOfLet _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsInested _lhsIoptions _lhsIoptionsLine _lhsIpragmaBlocks _lhsItextBlockMap _lhsItextBlocks) -> ( let _lhsOpps :: PP_Docs _lhsOpps = rule78 () _lhsOappendCommon :: [[PP_Doc]] _lhsOappendCommon = rule79 () _lhsOappendMain :: [[PP_Doc]] _lhsOappendMain = rule80 () _lhsOgenSems :: IO () _lhsOgenSems = rule81 () _lhsOimports :: [String] _lhsOimports = rule82 () !__result_ = T_Chunks_vOut10 _lhsOappendCommon _lhsOappendMain _lhsOgenSems _lhsOimports _lhsOpps in __result_ ) in C_Chunks_s11 v10 {-# INLINE rule78 #-} {-# LINE 89 "./src-ag/PrintCode.ag" #-} rule78 = \ (_ :: ()) -> {-# LINE 89 "./src-ag/PrintCode.ag" #-} [] {-# LINE 730 "dist/build/PrintCode.hs"#-} {-# INLINE rule79 #-} rule79 = \ (_ :: ()) -> [] {-# INLINE rule80 #-} rule80 = \ (_ :: ()) -> [] {-# INLINE rule81 #-} rule81 = \ (_ :: ()) -> return () {-# INLINE rule82 #-} rule82 = \ (_ :: ()) -> [] -- DataAlt ----------------------------------------------------- -- wrapper data Inh_DataAlt = Inh_DataAlt { nested_Inh_DataAlt :: !(Bool), strictPre_Inh_DataAlt :: !(PP_Doc) } data Syn_DataAlt = Syn_DataAlt { pp_Syn_DataAlt :: !(PP_Doc) } {-# INLINABLE wrap_DataAlt #-} wrap_DataAlt :: T_DataAlt -> Inh_DataAlt -> (Syn_DataAlt ) wrap_DataAlt !(T_DataAlt act) !(Inh_DataAlt _lhsInested _lhsIstrictPre) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_DataAlt_vIn13 _lhsInested _lhsIstrictPre !(T_DataAlt_vOut13 _lhsOpp) <- return (inv_DataAlt_s14 sem arg) return (Syn_DataAlt _lhsOpp) ) -- cata {-# NOINLINE sem_DataAlt #-} sem_DataAlt :: DataAlt -> T_DataAlt sem_DataAlt ( DataAlt !name_ args_ ) = sem_DataAlt_DataAlt name_ ( sem_Types args_ ) sem_DataAlt ( Record !name_ args_ ) = sem_DataAlt_Record name_ ( sem_NamedTypes args_ ) -- semantic domain newtype T_DataAlt = T_DataAlt { attach_T_DataAlt :: Identity (T_DataAlt_s14 ) } newtype T_DataAlt_s14 = C_DataAlt_s14 { inv_DataAlt_s14 :: (T_DataAlt_v13 ) } data T_DataAlt_s15 = C_DataAlt_s15 type T_DataAlt_v13 = (T_DataAlt_vIn13 ) -> (T_DataAlt_vOut13 ) data T_DataAlt_vIn13 = T_DataAlt_vIn13 (Bool) (PP_Doc) data T_DataAlt_vOut13 = T_DataAlt_vOut13 (PP_Doc) {-# NOINLINE sem_DataAlt_DataAlt #-} sem_DataAlt_DataAlt :: (String) -> T_Types -> T_DataAlt sem_DataAlt_DataAlt !arg_name_ arg_args_ = T_DataAlt (return st14) where {-# NOINLINE st14 #-} !st14 = let v13 :: T_DataAlt_v13 v13 = \ !(T_DataAlt_vIn13 _lhsInested _lhsIstrictPre) -> ( let _argsX53 = Control.Monad.Identity.runIdentity (attach_T_Types (arg_args_)) (T_Types_vOut52 _argsIpps) = inv_Types_s53 _argsX53 (T_Types_vIn52 _argsOnested) _lhsOpp :: PP_Doc _lhsOpp = rule83 _argsIpps _lhsIstrictPre arg_name_ _argsOnested = rule84 _lhsInested !__result_ = T_DataAlt_vOut13 _lhsOpp in __result_ ) in C_DataAlt_s14 v13 {-# INLINE rule83 #-} {-# LINE 221 "./src-ag/PrintCode.ag" #-} rule83 = \ ((_argsIpps) :: PP_Docs) ((_lhsIstrictPre) :: PP_Doc) name_ -> {-# LINE 221 "./src-ag/PrintCode.ag" #-} name_ >#< hv_sp (map ((_lhsIstrictPre >|<) . pp_parens) _argsIpps) {-# LINE 795 "dist/build/PrintCode.hs"#-} {-# INLINE rule84 #-} rule84 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# NOINLINE sem_DataAlt_Record #-} sem_DataAlt_Record :: (String) -> T_NamedTypes -> T_DataAlt sem_DataAlt_Record !arg_name_ arg_args_ = T_DataAlt (return st14) where {-# NOINLINE st14 #-} !st14 = let v13 :: T_DataAlt_v13 v13 = \ !(T_DataAlt_vIn13 _lhsInested _lhsIstrictPre) -> ( let _argsX38 = Control.Monad.Identity.runIdentity (attach_T_NamedTypes (arg_args_)) (T_NamedTypes_vOut37 _argsIpps) = inv_NamedTypes_s38 _argsX38 (T_NamedTypes_vIn37 _argsOnested) _lhsOpp :: PP_Doc _lhsOpp = rule85 _argsIpps arg_name_ _argsOnested = rule86 _lhsInested !__result_ = T_DataAlt_vOut13 _lhsOpp in __result_ ) in C_DataAlt_s14 v13 {-# INLINE rule85 #-} {-# LINE 222 "./src-ag/PrintCode.ag" #-} rule85 = \ ((_argsIpps) :: PP_Docs) name_ -> {-# LINE 222 "./src-ag/PrintCode.ag" #-} name_ >#< pp_block "{" "}" "," _argsIpps {-# LINE 819 "dist/build/PrintCode.hs"#-} {-# INLINE rule86 #-} rule86 = \ ((_lhsInested) :: Bool) -> _lhsInested -- DataAlts ---------------------------------------------------- -- wrapper data Inh_DataAlts = Inh_DataAlts { nested_Inh_DataAlts :: !(Bool), strictPre_Inh_DataAlts :: !(PP_Doc) } data Syn_DataAlts = Syn_DataAlts { pps_Syn_DataAlts :: !(PP_Docs) } {-# INLINABLE wrap_DataAlts #-} wrap_DataAlts :: T_DataAlts -> Inh_DataAlts -> (Syn_DataAlts ) wrap_DataAlts !(T_DataAlts act) !(Inh_DataAlts _lhsInested _lhsIstrictPre) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_DataAlts_vIn16 _lhsInested _lhsIstrictPre !(T_DataAlts_vOut16 _lhsOpps) <- return (inv_DataAlts_s17 sem arg) return (Syn_DataAlts _lhsOpps) ) -- cata {-# NOINLINE sem_DataAlts #-} sem_DataAlts :: DataAlts -> T_DataAlts sem_DataAlts list = Prelude.foldr sem_DataAlts_Cons sem_DataAlts_Nil (Prelude.map sem_DataAlt list) -- semantic domain newtype T_DataAlts = T_DataAlts { attach_T_DataAlts :: Identity (T_DataAlts_s17 ) } newtype T_DataAlts_s17 = C_DataAlts_s17 { inv_DataAlts_s17 :: (T_DataAlts_v16 ) } data T_DataAlts_s18 = C_DataAlts_s18 type T_DataAlts_v16 = (T_DataAlts_vIn16 ) -> (T_DataAlts_vOut16 ) data T_DataAlts_vIn16 = T_DataAlts_vIn16 (Bool) (PP_Doc) data T_DataAlts_vOut16 = T_DataAlts_vOut16 (PP_Docs) {-# NOINLINE sem_DataAlts_Cons #-} sem_DataAlts_Cons :: T_DataAlt -> T_DataAlts -> T_DataAlts sem_DataAlts_Cons arg_hd_ arg_tl_ = T_DataAlts (return st17) where {-# NOINLINE st17 #-} !st17 = let v16 :: T_DataAlts_v16 v16 = \ !(T_DataAlts_vIn16 _lhsInested _lhsIstrictPre) -> ( let _hdX14 = Control.Monad.Identity.runIdentity (attach_T_DataAlt (arg_hd_)) _tlX17 = Control.Monad.Identity.runIdentity (attach_T_DataAlts (arg_tl_)) (T_DataAlt_vOut13 _hdIpp) = inv_DataAlt_s14 _hdX14 (T_DataAlt_vIn13 _hdOnested _hdOstrictPre) (T_DataAlts_vOut16 _tlIpps) = inv_DataAlts_s17 _tlX17 (T_DataAlts_vIn16 _tlOnested _tlOstrictPre) _lhsOpps :: PP_Docs _lhsOpps = rule87 _hdIpp _tlIpps _hdOnested = rule88 _lhsInested _hdOstrictPre = rule89 _lhsIstrictPre _tlOnested = rule90 _lhsInested _tlOstrictPre = rule91 _lhsIstrictPre !__result_ = T_DataAlts_vOut16 _lhsOpps in __result_ ) in C_DataAlts_s17 v16 {-# INLINE rule87 #-} {-# LINE 72 "./src-ag/PrintCode.ag" #-} rule87 = \ ((_hdIpp) :: PP_Doc) ((_tlIpps) :: PP_Docs) -> {-# LINE 72 "./src-ag/PrintCode.ag" #-} _hdIpp : _tlIpps {-# LINE 879 "dist/build/PrintCode.hs"#-} {-# INLINE rule88 #-} rule88 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule89 #-} rule89 = \ ((_lhsIstrictPre) :: PP_Doc) -> _lhsIstrictPre {-# INLINE rule90 #-} rule90 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule91 #-} rule91 = \ ((_lhsIstrictPre) :: PP_Doc) -> _lhsIstrictPre {-# NOINLINE sem_DataAlts_Nil #-} sem_DataAlts_Nil :: T_DataAlts sem_DataAlts_Nil = T_DataAlts (return st17) where {-# NOINLINE st17 #-} !st17 = let v16 :: T_DataAlts_v16 v16 = \ !(T_DataAlts_vIn16 _lhsInested _lhsIstrictPre) -> ( let _lhsOpps :: PP_Docs _lhsOpps = rule92 () !__result_ = T_DataAlts_vOut16 _lhsOpps in __result_ ) in C_DataAlts_s17 v16 {-# INLINE rule92 #-} {-# LINE 73 "./src-ag/PrintCode.ag" #-} rule92 = \ (_ :: ()) -> {-# LINE 73 "./src-ag/PrintCode.ag" #-} [] {-# LINE 909 "dist/build/PrintCode.hs"#-} -- Decl -------------------------------------------------------- -- wrapper data Inh_Decl = Inh_Decl { isDeclOfLet_Inh_Decl :: !(Bool), nested_Inh_Decl :: !(Bool), options_Inh_Decl :: !(Options), outputfile_Inh_Decl :: !(String) } data Syn_Decl = Syn_Decl { pp_Syn_Decl :: !(PP_Doc) } {-# INLINABLE wrap_Decl #-} wrap_Decl :: T_Decl -> Inh_Decl -> (Syn_Decl ) wrap_Decl !(T_Decl act) !(Inh_Decl _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Decl_vIn19 _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile !(T_Decl_vOut19 _lhsOpp) <- return (inv_Decl_s20 sem arg) return (Syn_Decl _lhsOpp) ) -- cata {-# NOINLINE sem_Decl #-} sem_Decl :: Decl -> T_Decl sem_Decl ( Decl left_ rhs_ !binds_ !uses_ ) = sem_Decl_Decl ( sem_Lhs left_ ) ( sem_Expr rhs_ ) binds_ uses_ sem_Decl ( Bind left_ rhs_ ) = sem_Decl_Bind ( sem_Lhs left_ ) ( sem_Expr rhs_ ) sem_Decl ( BindLet left_ rhs_ ) = sem_Decl_BindLet ( sem_Lhs left_ ) ( sem_Expr rhs_ ) sem_Decl ( Data !name_ !params_ alts_ !strict_ !derivings_ ) = sem_Decl_Data name_ params_ ( sem_DataAlts alts_ ) strict_ derivings_ sem_Decl ( NewType !name_ !params_ !con_ tp_ ) = sem_Decl_NewType name_ params_ con_ ( sem_Type tp_ ) sem_Decl ( Type !name_ !params_ tp_ ) = sem_Decl_Type name_ params_ ( sem_Type tp_ ) sem_Decl ( TSig !name_ tp_ ) = sem_Decl_TSig name_ ( sem_Type tp_ ) sem_Decl ( Comment !txt_ ) = sem_Decl_Comment txt_ sem_Decl ( PragmaDecl !txt_ ) = sem_Decl_PragmaDecl txt_ sem_Decl ( Resume !monadic_ !nt_ left_ rhs_ ) = sem_Decl_Resume monadic_ nt_ ( sem_Lhs left_ ) ( sem_Expr rhs_ ) sem_Decl ( EvalDecl !nt_ left_ rhs_ ) = sem_Decl_EvalDecl nt_ ( sem_Lhs left_ ) ( sem_Expr rhs_ ) -- semantic domain newtype T_Decl = T_Decl { attach_T_Decl :: Identity (T_Decl_s20 ) } newtype T_Decl_s20 = C_Decl_s20 { inv_Decl_s20 :: (T_Decl_v19 ) } data T_Decl_s21 = C_Decl_s21 type T_Decl_v19 = (T_Decl_vIn19 ) -> (T_Decl_vOut19 ) data T_Decl_vIn19 = T_Decl_vIn19 (Bool) (Bool) (Options) (String) data T_Decl_vOut19 = T_Decl_vOut19 (PP_Doc) {-# NOINLINE sem_Decl_Decl #-} sem_Decl_Decl :: T_Lhs -> T_Expr -> (Set String) -> (Set String) -> T_Decl sem_Decl_Decl arg_left_ arg_rhs_ _ _ = T_Decl (return st20) where {-# NOINLINE st20 #-} !st20 = let v19 :: T_Decl_v19 v19 = \ !(T_Decl_vIn19 _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _leftX32 = Control.Monad.Identity.runIdentity (attach_T_Lhs (arg_left_)) _rhsX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_rhs_)) (T_Lhs_vOut31 _leftIpp) = inv_Lhs_s32 _leftX32 (T_Lhs_vIn31 _leftOisDeclOfLet _leftOnested _leftOoptions _leftOoutputfile) (T_Expr_vOut25 _rhsIpp) = inv_Expr_s26 _rhsX26 (T_Expr_vIn25 _rhsOnested _rhsOoptions _rhsOoutputfile) _lhsOpp :: PP_Doc _lhsOpp = rule93 _leftIpp _rhsIpp _leftOisDeclOfLet = rule94 _lhsIisDeclOfLet _leftOnested = rule95 _lhsInested _leftOoptions = rule96 _lhsIoptions _leftOoutputfile = rule97 _lhsIoutputfile _rhsOnested = rule98 _lhsInested _rhsOoptions = rule99 _lhsIoptions _rhsOoutputfile = rule100 _lhsIoutputfile !__result_ = T_Decl_vOut19 _lhsOpp in __result_ ) in C_Decl_s20 v19 {-# INLINE rule93 #-} {-# LINE 106 "./src-ag/PrintCode.ag" #-} rule93 = \ ((_leftIpp) :: PP_Doc) ((_rhsIpp) :: PP_Doc) -> {-# LINE 106 "./src-ag/PrintCode.ag" #-} _leftIpp >#< "=" >-< indent 4 _rhsIpp {-# LINE 980 "dist/build/PrintCode.hs"#-} {-# INLINE rule94 #-} rule94 = \ ((_lhsIisDeclOfLet) :: Bool) -> _lhsIisDeclOfLet {-# INLINE rule95 #-} rule95 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule96 #-} rule96 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule97 #-} rule97 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# INLINE rule98 #-} rule98 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule99 #-} rule99 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule100 #-} rule100 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# NOINLINE sem_Decl_Bind #-} sem_Decl_Bind :: T_Lhs -> T_Expr -> T_Decl sem_Decl_Bind arg_left_ arg_rhs_ = T_Decl (return st20) where {-# NOINLINE st20 #-} !st20 = let v19 :: T_Decl_v19 v19 = \ !(T_Decl_vIn19 _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _leftX32 = Control.Monad.Identity.runIdentity (attach_T_Lhs (arg_left_)) _rhsX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_rhs_)) (T_Lhs_vOut31 _leftIpp) = inv_Lhs_s32 _leftX32 (T_Lhs_vIn31 _leftOisDeclOfLet _leftOnested _leftOoptions _leftOoutputfile) (T_Expr_vOut25 _rhsIpp) = inv_Expr_s26 _rhsX26 (T_Expr_vIn25 _rhsOnested _rhsOoptions _rhsOoutputfile) _lhsOpp :: PP_Doc _lhsOpp = rule101 _leftIpp _rhsIpp _leftOisDeclOfLet = rule102 _lhsIisDeclOfLet _leftOnested = rule103 _lhsInested _leftOoptions = rule104 _lhsIoptions _leftOoutputfile = rule105 _lhsIoutputfile _rhsOnested = rule106 _lhsInested _rhsOoptions = rule107 _lhsIoptions _rhsOoutputfile = rule108 _lhsIoutputfile !__result_ = T_Decl_vOut19 _lhsOpp in __result_ ) in C_Decl_s20 v19 {-# INLINE rule101 #-} {-# LINE 108 "./src-ag/PrintCode.ag" #-} rule101 = \ ((_leftIpp) :: PP_Doc) ((_rhsIpp) :: PP_Doc) -> {-# LINE 108 "./src-ag/PrintCode.ag" #-} _leftIpp >#< "<-" >#< _rhsIpp {-# LINE 1030 "dist/build/PrintCode.hs"#-} {-# INLINE rule102 #-} rule102 = \ ((_lhsIisDeclOfLet) :: Bool) -> _lhsIisDeclOfLet {-# INLINE rule103 #-} rule103 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule104 #-} rule104 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule105 #-} rule105 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# INLINE rule106 #-} rule106 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule107 #-} rule107 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule108 #-} rule108 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# NOINLINE sem_Decl_BindLet #-} sem_Decl_BindLet :: T_Lhs -> T_Expr -> T_Decl sem_Decl_BindLet arg_left_ arg_rhs_ = T_Decl (return st20) where {-# NOINLINE st20 #-} !st20 = let v19 :: T_Decl_v19 v19 = \ !(T_Decl_vIn19 _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _leftX32 = Control.Monad.Identity.runIdentity (attach_T_Lhs (arg_left_)) _rhsX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_rhs_)) (T_Lhs_vOut31 _leftIpp) = inv_Lhs_s32 _leftX32 (T_Lhs_vIn31 _leftOisDeclOfLet _leftOnested _leftOoptions _leftOoutputfile) (T_Expr_vOut25 _rhsIpp) = inv_Expr_s26 _rhsX26 (T_Expr_vIn25 _rhsOnested _rhsOoptions _rhsOoutputfile) _lhsOpp :: PP_Doc _lhsOpp = rule109 _leftIpp _rhsIpp _leftOisDeclOfLet = rule110 _lhsIisDeclOfLet _leftOnested = rule111 _lhsInested _leftOoptions = rule112 _lhsIoptions _leftOoutputfile = rule113 _lhsIoutputfile _rhsOnested = rule114 _lhsInested _rhsOoptions = rule115 _lhsIoptions _rhsOoutputfile = rule116 _lhsIoutputfile !__result_ = T_Decl_vOut19 _lhsOpp in __result_ ) in C_Decl_s20 v19 {-# INLINE rule109 #-} {-# LINE 109 "./src-ag/PrintCode.ag" #-} rule109 = \ ((_leftIpp) :: PP_Doc) ((_rhsIpp) :: PP_Doc) -> {-# LINE 109 "./src-ag/PrintCode.ag" #-} "let" >#< _leftIpp >#< "=" >#< _rhsIpp {-# LINE 1080 "dist/build/PrintCode.hs"#-} {-# INLINE rule110 #-} rule110 = \ ((_lhsIisDeclOfLet) :: Bool) -> _lhsIisDeclOfLet {-# INLINE rule111 #-} rule111 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule112 #-} rule112 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule113 #-} rule113 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# INLINE rule114 #-} rule114 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule115 #-} rule115 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule116 #-} rule116 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# NOINLINE sem_Decl_Data #-} sem_Decl_Data :: (String) -> ([String]) -> T_DataAlts -> (Bool) -> ([String]) -> T_Decl sem_Decl_Data !arg_name_ !arg_params_ arg_alts_ !arg_strict_ !arg_derivings_ = T_Decl (return st20) where {-# NOINLINE st20 #-} !st20 = let v19 :: T_Decl_v19 v19 = \ !(T_Decl_vIn19 _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _altsX17 = Control.Monad.Identity.runIdentity (attach_T_DataAlts (arg_alts_)) (T_DataAlts_vOut16 _altsIpps) = inv_DataAlts_s17 _altsX17 (T_DataAlts_vIn16 _altsOnested _altsOstrictPre) _lhsOpp :: PP_Doc _lhsOpp = rule117 _altsIpps arg_derivings_ arg_name_ arg_params_ _altsOstrictPre = rule118 arg_strict_ _altsOnested = rule119 _lhsInested !__result_ = T_Decl_vOut19 _lhsOpp in __result_ ) in C_Decl_s20 v19 {-# INLINE rule117 #-} {-# LINE 110 "./src-ag/PrintCode.ag" #-} rule117 = \ ((_altsIpps) :: PP_Docs) derivings_ name_ params_ -> {-# LINE 110 "./src-ag/PrintCode.ag" #-} "data" >#< hv_sp (name_ : params_) >#< ( case _altsIpps of [] -> empty (x:xs) -> "=" >#< x >-< vlist (map ("|" >#<) xs) >-< if null derivings_ then empty else "deriving" >#< ppTuple False (map text derivings_) ) {-# LINE 1131 "dist/build/PrintCode.hs"#-} {-# INLINE rule118 #-} {-# LINE 321 "./src-ag/PrintCode.ag" #-} rule118 = \ strict_ -> {-# LINE 321 "./src-ag/PrintCode.ag" #-} if strict_ then pp "!" else empty {-# LINE 1137 "dist/build/PrintCode.hs"#-} {-# INLINE rule119 #-} rule119 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# NOINLINE sem_Decl_NewType #-} sem_Decl_NewType :: (String) -> ([String]) -> (String) -> T_Type -> T_Decl sem_Decl_NewType !arg_name_ !arg_params_ !arg_con_ arg_tp_ = T_Decl (return st20) where {-# NOINLINE st20 #-} !st20 = let v19 :: T_Decl_v19 v19 = \ !(T_Decl_vIn19 _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _tpX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_tp_)) (T_Type_vOut49 _tpIpp _tpIprec) = inv_Type_s50 _tpX50 (T_Type_vIn49 _tpOnested) _lhsOpp :: PP_Doc _lhsOpp = rule120 _tpIpp arg_con_ arg_name_ arg_params_ _tpOnested = rule121 _lhsInested !__result_ = T_Decl_vOut19 _lhsOpp in __result_ ) in C_Decl_s20 v19 {-# INLINE rule120 #-} {-# LINE 119 "./src-ag/PrintCode.ag" #-} rule120 = \ ((_tpIpp) :: PP_Doc) con_ name_ params_ -> {-# LINE 119 "./src-ag/PrintCode.ag" #-} "newtype" >#< hv_sp (name_ : params_) >#< "=" >#< con_ >#< pp_parens _tpIpp {-# LINE 1161 "dist/build/PrintCode.hs"#-} {-# INLINE rule121 #-} rule121 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# NOINLINE sem_Decl_Type #-} sem_Decl_Type :: (String) -> ([String]) -> T_Type -> T_Decl sem_Decl_Type !arg_name_ !arg_params_ arg_tp_ = T_Decl (return st20) where {-# NOINLINE st20 #-} !st20 = let v19 :: T_Decl_v19 v19 = \ !(T_Decl_vIn19 _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _tpX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_tp_)) (T_Type_vOut49 _tpIpp _tpIprec) = inv_Type_s50 _tpX50 (T_Type_vIn49 _tpOnested) _lhsOpp :: PP_Doc _lhsOpp = rule122 _tpIpp arg_name_ arg_params_ _tpOnested = rule123 _lhsInested !__result_ = T_Decl_vOut19 _lhsOpp in __result_ ) in C_Decl_s20 v19 {-# INLINE rule122 #-} {-# LINE 120 "./src-ag/PrintCode.ag" #-} rule122 = \ ((_tpIpp) :: PP_Doc) name_ params_ -> {-# LINE 120 "./src-ag/PrintCode.ag" #-} "type" >#< hv_sp (name_ : params_) >#< "=" >#< _tpIpp {-# LINE 1185 "dist/build/PrintCode.hs"#-} {-# INLINE rule123 #-} rule123 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# NOINLINE sem_Decl_TSig #-} sem_Decl_TSig :: (String) -> T_Type -> T_Decl sem_Decl_TSig !arg_name_ arg_tp_ = T_Decl (return st20) where {-# NOINLINE st20 #-} !st20 = let v19 :: T_Decl_v19 v19 = \ !(T_Decl_vIn19 _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _tpX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_tp_)) (T_Type_vOut49 _tpIpp _tpIprec) = inv_Type_s50 _tpX50 (T_Type_vIn49 _tpOnested) _lhsOpp :: PP_Doc _lhsOpp = rule124 _tpIpp arg_name_ _tpOnested = rule125 _lhsInested !__result_ = T_Decl_vOut19 _lhsOpp in __result_ ) in C_Decl_s20 v19 {-# INLINE rule124 #-} {-# LINE 121 "./src-ag/PrintCode.ag" #-} rule124 = \ ((_tpIpp) :: PP_Doc) name_ -> {-# LINE 121 "./src-ag/PrintCode.ag" #-} name_ >#< "::" >#< _tpIpp {-# LINE 1209 "dist/build/PrintCode.hs"#-} {-# INLINE rule125 #-} rule125 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# NOINLINE sem_Decl_Comment #-} sem_Decl_Comment :: (String) -> T_Decl sem_Decl_Comment !arg_txt_ = T_Decl (return st20) where {-# NOINLINE st20 #-} !st20 = let v19 :: T_Decl_v19 v19 = \ !(T_Decl_vIn19 _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule126 arg_txt_ !__result_ = T_Decl_vOut19 _lhsOpp in __result_ ) in C_Decl_s20 v19 {-# INLINE rule126 #-} {-# LINE 122 "./src-ag/PrintCode.ag" #-} rule126 = \ txt_ -> {-# LINE 122 "./src-ag/PrintCode.ag" #-} if '\n' `elem` txt_ then "{-" >-< vlist (lines txt_) >-< "-}" else "--" >#< txt_ {-# LINE 1232 "dist/build/PrintCode.hs"#-} {-# NOINLINE sem_Decl_PragmaDecl #-} sem_Decl_PragmaDecl :: (String) -> T_Decl sem_Decl_PragmaDecl !arg_txt_ = T_Decl (return st20) where {-# NOINLINE st20 #-} !st20 = let v19 :: T_Decl_v19 v19 = \ !(T_Decl_vIn19 _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule127 arg_txt_ !__result_ = T_Decl_vOut19 _lhsOpp in __result_ ) in C_Decl_s20 v19 {-# INLINE rule127 #-} {-# LINE 125 "./src-ag/PrintCode.ag" #-} rule127 = \ txt_ -> {-# LINE 125 "./src-ag/PrintCode.ag" #-} "{-#" >#< text txt_ >#< "#-}" {-# LINE 1250 "dist/build/PrintCode.hs"#-} {-# NOINLINE sem_Decl_Resume #-} sem_Decl_Resume :: (Bool) -> (String) -> T_Lhs -> T_Expr -> T_Decl sem_Decl_Resume !arg_monadic_ _ arg_left_ arg_rhs_ = T_Decl (return st20) where {-# NOINLINE st20 #-} !st20 = let v19 :: T_Decl_v19 v19 = \ !(T_Decl_vIn19 _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _leftX32 = Control.Monad.Identity.runIdentity (attach_T_Lhs (arg_left_)) _rhsX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_rhs_)) (T_Lhs_vOut31 _leftIpp) = inv_Lhs_s32 _leftX32 (T_Lhs_vIn31 _leftOisDeclOfLet _leftOnested _leftOoptions _leftOoutputfile) (T_Expr_vOut25 _rhsIpp) = inv_Expr_s26 _rhsX26 (T_Expr_vIn25 _rhsOnested _rhsOoptions _rhsOoutputfile) _lhsOpp :: PP_Doc _lhsOpp = rule128 _leftIpp _rhsIpp arg_monadic_ _leftOisDeclOfLet = rule129 _lhsIisDeclOfLet _leftOnested = rule130 _lhsInested _leftOoptions = rule131 _lhsIoptions _leftOoutputfile = rule132 _lhsIoutputfile _rhsOnested = rule133 _lhsInested _rhsOoptions = rule134 _lhsIoptions _rhsOoutputfile = rule135 _lhsIoutputfile !__result_ = T_Decl_vOut19 _lhsOpp in __result_ ) in C_Decl_s20 v19 {-# INLINE rule128 #-} {-# LINE 126 "./src-ag/PrintCode.ag" #-} rule128 = \ ((_leftIpp) :: PP_Doc) ((_rhsIpp) :: PP_Doc) monadic_ -> {-# LINE 126 "./src-ag/PrintCode.ag" #-} if monadic_ then _leftIpp >#< "<-" >#< _rhsIpp else _leftIpp >#< "=" >-< indent 4 _rhsIpp {-# LINE 1281 "dist/build/PrintCode.hs"#-} {-# INLINE rule129 #-} rule129 = \ ((_lhsIisDeclOfLet) :: Bool) -> _lhsIisDeclOfLet {-# INLINE rule130 #-} rule130 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule131 #-} rule131 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule132 #-} rule132 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# INLINE rule133 #-} rule133 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule134 #-} rule134 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule135 #-} rule135 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# NOINLINE sem_Decl_EvalDecl #-} sem_Decl_EvalDecl :: (String) -> T_Lhs -> T_Expr -> T_Decl sem_Decl_EvalDecl !arg_nt_ arg_left_ arg_rhs_ = T_Decl (return st20) where {-# NOINLINE st20 #-} !st20 = let v19 :: T_Decl_v19 v19 = \ !(T_Decl_vIn19 _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _leftX32 = Control.Monad.Identity.runIdentity (attach_T_Lhs (arg_left_)) _rhsX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_rhs_)) (T_Lhs_vOut31 _leftIpp) = inv_Lhs_s32 _leftX32 (T_Lhs_vIn31 _leftOisDeclOfLet _leftOnested _leftOoptions _leftOoutputfile) (T_Expr_vOut25 _rhsIpp) = inv_Expr_s26 _rhsX26 (T_Expr_vIn25 _rhsOnested _rhsOoptions _rhsOoutputfile) _strat = rule136 _lhsIoptions _lhsOpp :: PP_Doc _lhsOpp = rule137 _leftIpp _lhsIoptions _rhsIpp _strat arg_nt_ _leftOisDeclOfLet = rule138 _lhsIisDeclOfLet _leftOnested = rule139 _lhsInested _leftOoptions = rule140 _lhsIoptions _leftOoutputfile = rule141 _lhsIoutputfile _rhsOnested = rule142 _lhsInested _rhsOoptions = rule143 _lhsIoptions _rhsOoutputfile = rule144 _lhsIoutputfile !__result_ = T_Decl_vOut19 _lhsOpp in __result_ ) in C_Decl_s20 v19 {-# INLINE rule136 #-} {-# LINE 129 "./src-ag/PrintCode.ag" #-} rule136 = \ ((_lhsIoptions) :: Options) -> {-# LINE 129 "./src-ag/PrintCode.ag" #-} if breadthFirstStrict _lhsIoptions then "stepwiseEval" else "lazyEval" {-# LINE 1334 "dist/build/PrintCode.hs"#-} {-# INLINE rule137 #-} {-# LINE 132 "./src-ag/PrintCode.ag" #-} rule137 = \ ((_leftIpp) :: PP_Doc) ((_lhsIoptions) :: Options) ((_rhsIpp) :: PP_Doc) _strat nt_ -> {-# LINE 132 "./src-ag/PrintCode.ag" #-} if breadthFirst _lhsIoptions then _leftIpp >#< "=" >#< "case" >#< _strat >#< pp_parens _rhsIpp >#< "of" >-< indent 4 ( pp_parens (nt_ >|< "_Syn" >#< "_val") >#< "-> _val" ) else _leftIpp >#< "=" >#< _rhsIpp {-# LINE 1345 "dist/build/PrintCode.hs"#-} {-# INLINE rule138 #-} rule138 = \ ((_lhsIisDeclOfLet) :: Bool) -> _lhsIisDeclOfLet {-# INLINE rule139 #-} rule139 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule140 #-} rule140 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule141 #-} rule141 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# INLINE rule142 #-} rule142 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule143 #-} rule143 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule144 #-} rule144 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile -- Decls ------------------------------------------------------- -- wrapper data Inh_Decls = Inh_Decls { isDeclOfLet_Inh_Decls :: !(Bool), nested_Inh_Decls :: !(Bool), options_Inh_Decls :: !(Options), outputfile_Inh_Decls :: !(String) } data Syn_Decls = Syn_Decls { pps_Syn_Decls :: !(PP_Docs) } {-# INLINABLE wrap_Decls #-} wrap_Decls :: T_Decls -> Inh_Decls -> (Syn_Decls ) wrap_Decls !(T_Decls act) !(Inh_Decls _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Decls_vIn22 _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile !(T_Decls_vOut22 _lhsOpps) <- return (inv_Decls_s23 sem arg) return (Syn_Decls _lhsOpps) ) -- cata {-# NOINLINE sem_Decls #-} sem_Decls :: Decls -> T_Decls sem_Decls list = Prelude.foldr sem_Decls_Cons sem_Decls_Nil (Prelude.map sem_Decl list) -- semantic domain newtype T_Decls = T_Decls { attach_T_Decls :: Identity (T_Decls_s23 ) } newtype T_Decls_s23 = C_Decls_s23 { inv_Decls_s23 :: (T_Decls_v22 ) } data T_Decls_s24 = C_Decls_s24 type T_Decls_v22 = (T_Decls_vIn22 ) -> (T_Decls_vOut22 ) data T_Decls_vIn22 = T_Decls_vIn22 (Bool) (Bool) (Options) (String) data T_Decls_vOut22 = T_Decls_vOut22 (PP_Docs) {-# NOINLINE sem_Decls_Cons #-} sem_Decls_Cons :: T_Decl -> T_Decls -> T_Decls sem_Decls_Cons arg_hd_ arg_tl_ = T_Decls (return st23) where {-# NOINLINE st23 #-} !st23 = let v22 :: T_Decls_v22 v22 = \ !(T_Decls_vIn22 _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _hdX20 = Control.Monad.Identity.runIdentity (attach_T_Decl (arg_hd_)) _tlX23 = Control.Monad.Identity.runIdentity (attach_T_Decls (arg_tl_)) (T_Decl_vOut19 _hdIpp) = inv_Decl_s20 _hdX20 (T_Decl_vIn19 _hdOisDeclOfLet _hdOnested _hdOoptions _hdOoutputfile) (T_Decls_vOut22 _tlIpps) = inv_Decls_s23 _tlX23 (T_Decls_vIn22 _tlOisDeclOfLet _tlOnested _tlOoptions _tlOoutputfile) _lhsOpps :: PP_Docs _lhsOpps = rule145 _hdIpp _tlIpps _hdOisDeclOfLet = rule146 _lhsIisDeclOfLet _hdOnested = rule147 _lhsInested _hdOoptions = rule148 _lhsIoptions _hdOoutputfile = rule149 _lhsIoutputfile _tlOisDeclOfLet = rule150 _lhsIisDeclOfLet _tlOnested = rule151 _lhsInested _tlOoptions = rule152 _lhsIoptions _tlOoutputfile = rule153 _lhsIoutputfile !__result_ = T_Decls_vOut22 _lhsOpps in __result_ ) in C_Decls_s23 v22 {-# INLINE rule145 #-} {-# LINE 84 "./src-ag/PrintCode.ag" #-} rule145 = \ ((_hdIpp) :: PP_Doc) ((_tlIpps) :: PP_Docs) -> {-# LINE 84 "./src-ag/PrintCode.ag" #-} _hdIpp : _tlIpps {-# LINE 1427 "dist/build/PrintCode.hs"#-} {-# INLINE rule146 #-} rule146 = \ ((_lhsIisDeclOfLet) :: Bool) -> _lhsIisDeclOfLet {-# INLINE rule147 #-} rule147 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule148 #-} rule148 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule149 #-} rule149 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# INLINE rule150 #-} rule150 = \ ((_lhsIisDeclOfLet) :: Bool) -> _lhsIisDeclOfLet {-# INLINE rule151 #-} rule151 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule152 #-} rule152 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule153 #-} rule153 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# NOINLINE sem_Decls_Nil #-} sem_Decls_Nil :: T_Decls sem_Decls_Nil = T_Decls (return st23) where {-# NOINLINE st23 #-} !st23 = let v22 :: T_Decls_v22 v22 = \ !(T_Decls_vIn22 _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _lhsOpps :: PP_Docs _lhsOpps = rule154 () !__result_ = T_Decls_vOut22 _lhsOpps in __result_ ) in C_Decls_s23 v22 {-# INLINE rule154 #-} {-# LINE 85 "./src-ag/PrintCode.ag" #-} rule154 = \ (_ :: ()) -> {-# LINE 85 "./src-ag/PrintCode.ag" #-} [] {-# LINE 1469 "dist/build/PrintCode.hs"#-} -- Expr -------------------------------------------------------- -- wrapper data Inh_Expr = Inh_Expr { nested_Inh_Expr :: !(Bool), options_Inh_Expr :: !(Options), outputfile_Inh_Expr :: !(String) } data Syn_Expr = Syn_Expr { pp_Syn_Expr :: !(PP_Doc) } {-# INLINABLE wrap_Expr #-} wrap_Expr :: T_Expr -> Inh_Expr -> (Syn_Expr ) wrap_Expr !(T_Expr act) !(Inh_Expr _lhsInested _lhsIoptions _lhsIoutputfile) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Expr_vIn25 _lhsInested _lhsIoptions _lhsIoutputfile !(T_Expr_vOut25 _lhsOpp) <- return (inv_Expr_s26 sem arg) return (Syn_Expr _lhsOpp) ) -- cata {-# NOINLINE sem_Expr #-} sem_Expr :: Expr -> T_Expr sem_Expr ( Let decls_ body_ ) = sem_Expr_Let ( sem_Decls decls_ ) ( sem_Expr body_ ) sem_Expr ( Case expr_ alts_ ) = sem_Expr_Case ( sem_Expr expr_ ) ( sem_CaseAlts alts_ ) sem_Expr ( Do stmts_ body_ ) = sem_Expr_Do ( sem_Decls stmts_ ) ( sem_Expr body_ ) sem_Expr ( Lambda args_ body_ ) = sem_Expr_Lambda ( sem_Exprs args_ ) ( sem_Expr body_ ) sem_Expr ( TupleExpr exprs_ ) = sem_Expr_TupleExpr ( sem_Exprs exprs_ ) sem_Expr ( UnboxedTupleExpr exprs_ ) = sem_Expr_UnboxedTupleExpr ( sem_Exprs exprs_ ) sem_Expr ( App !name_ args_ ) = sem_Expr_App name_ ( sem_Exprs args_ ) sem_Expr ( SimpleExpr !txt_ ) = sem_Expr_SimpleExpr txt_ sem_Expr ( TextExpr !lns_ ) = sem_Expr_TextExpr lns_ sem_Expr ( Trace !txt_ expr_ ) = sem_Expr_Trace txt_ ( sem_Expr expr_ ) sem_Expr ( PragmaExpr !onLeftSide_ !onNewLine_ !txt_ expr_ ) = sem_Expr_PragmaExpr onLeftSide_ onNewLine_ txt_ ( sem_Expr expr_ ) sem_Expr ( LineExpr expr_ ) = sem_Expr_LineExpr ( sem_Expr expr_ ) sem_Expr ( TypedExpr expr_ tp_ ) = sem_Expr_TypedExpr ( sem_Expr expr_ ) ( sem_Type tp_ ) sem_Expr ( ResultExpr !nt_ expr_ ) = sem_Expr_ResultExpr nt_ ( sem_Expr expr_ ) sem_Expr ( InvokeExpr !nt_ expr_ args_ ) = sem_Expr_InvokeExpr nt_ ( sem_Expr expr_ ) ( sem_Exprs args_ ) sem_Expr ( ResumeExpr !nt_ expr_ left_ rhs_ ) = sem_Expr_ResumeExpr nt_ ( sem_Expr expr_ ) ( sem_Lhs left_ ) ( sem_Expr rhs_ ) sem_Expr ( SemFun !nt_ args_ body_ ) = sem_Expr_SemFun nt_ ( sem_Exprs args_ ) ( sem_Expr body_ ) -- semantic domain newtype T_Expr = T_Expr { attach_T_Expr :: Identity (T_Expr_s26 ) } newtype T_Expr_s26 = C_Expr_s26 { inv_Expr_s26 :: (T_Expr_v25 ) } data T_Expr_s27 = C_Expr_s27 type T_Expr_v25 = (T_Expr_vIn25 ) -> (T_Expr_vOut25 ) data T_Expr_vIn25 = T_Expr_vIn25 (Bool) (Options) (String) data T_Expr_vOut25 = T_Expr_vOut25 (PP_Doc) {-# NOINLINE sem_Expr_Let #-} sem_Expr_Let :: T_Decls -> T_Expr -> T_Expr sem_Expr_Let arg_decls_ arg_body_ = T_Expr (return st26) where {-# NOINLINE st26 #-} !st26 = let v25 :: T_Expr_v25 v25 = \ !(T_Expr_vIn25 _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _declsX23 = Control.Monad.Identity.runIdentity (attach_T_Decls (arg_decls_)) _bodyX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_body_)) (T_Decls_vOut22 _declsIpps) = inv_Decls_s23 _declsX23 (T_Decls_vIn22 _declsOisDeclOfLet _declsOnested _declsOoptions _declsOoutputfile) (T_Expr_vOut25 _bodyIpp) = inv_Expr_s26 _bodyX26 (T_Expr_vIn25 _bodyOnested _bodyOoptions _bodyOoutputfile) _lhsOpp :: PP_Doc _lhsOpp = rule155 _bodyIpp _declsIpps _declsOisDeclOfLet = rule156 () _declsOnested = rule157 _lhsInested _declsOoptions = rule158 _lhsIoptions _declsOoutputfile = rule159 _lhsIoutputfile _bodyOnested = rule160 _lhsInested _bodyOoptions = rule161 _lhsIoptions _bodyOoutputfile = rule162 _lhsIoutputfile !__result_ = T_Expr_vOut25 _lhsOpp in __result_ ) in C_Expr_s26 v25 {-# INLINE rule155 #-} {-# LINE 140 "./src-ag/PrintCode.ag" #-} rule155 = \ ((_bodyIpp) :: PP_Doc) ((_declsIpps) :: PP_Docs) -> {-# LINE 140 "./src-ag/PrintCode.ag" #-} pp_parens ( "let" >#< (vlist _declsIpps) >-< "in " >#< _bodyIpp ) {-# LINE 1547 "dist/build/PrintCode.hs"#-} {-# INLINE rule156 #-} {-# LINE 416 "./src-ag/PrintCode.ag" #-} rule156 = \ (_ :: ()) -> {-# LINE 416 "./src-ag/PrintCode.ag" #-} True {-# LINE 1553 "dist/build/PrintCode.hs"#-} {-# INLINE rule157 #-} rule157 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule158 #-} rule158 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule159 #-} rule159 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# INLINE rule160 #-} rule160 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule161 #-} rule161 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule162 #-} rule162 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# NOINLINE sem_Expr_Case #-} sem_Expr_Case :: T_Expr -> T_CaseAlts -> T_Expr sem_Expr_Case arg_expr_ arg_alts_ = T_Expr (return st26) where {-# NOINLINE st26 #-} !st26 = let v25 :: T_Expr_v25 v25 = \ !(T_Expr_vIn25 _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _exprX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_expr_)) _altsX5 = Control.Monad.Identity.runIdentity (attach_T_CaseAlts (arg_alts_)) (T_Expr_vOut25 _exprIpp) = inv_Expr_s26 _exprX26 (T_Expr_vIn25 _exprOnested _exprOoptions _exprOoutputfile) (T_CaseAlts_vOut4 _altsIpps) = inv_CaseAlts_s5 _altsX5 (T_CaseAlts_vIn4 _altsOnested _altsOoptions _altsOoutputfile) _lhsOpp :: PP_Doc _lhsOpp = rule163 _altsIpps _exprIpp _exprOnested = rule164 _lhsInested _exprOoptions = rule165 _lhsIoptions _exprOoutputfile = rule166 _lhsIoutputfile _altsOnested = rule167 _lhsInested _altsOoptions = rule168 _lhsIoptions _altsOoutputfile = rule169 _lhsIoutputfile !__result_ = T_Expr_vOut25 _lhsOpp in __result_ ) in C_Expr_s26 v25 {-# INLINE rule163 #-} {-# LINE 143 "./src-ag/PrintCode.ag" #-} rule163 = \ ((_altsIpps) :: PP_Docs) ((_exprIpp) :: PP_Doc) -> {-# LINE 143 "./src-ag/PrintCode.ag" #-} pp_parens ( "case" >#< pp_parens _exprIpp >#< "of" >-< (vlist _altsIpps) ) {-# LINE 1601 "dist/build/PrintCode.hs"#-} {-# INLINE rule164 #-} rule164 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule165 #-} rule165 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule166 #-} rule166 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# INLINE rule167 #-} rule167 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule168 #-} rule168 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule169 #-} rule169 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# NOINLINE sem_Expr_Do #-} sem_Expr_Do :: T_Decls -> T_Expr -> T_Expr sem_Expr_Do arg_stmts_ arg_body_ = T_Expr (return st26) where {-# NOINLINE st26 #-} !st26 = let v25 :: T_Expr_v25 v25 = \ !(T_Expr_vIn25 _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _stmtsX23 = Control.Monad.Identity.runIdentity (attach_T_Decls (arg_stmts_)) _bodyX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_body_)) (T_Decls_vOut22 _stmtsIpps) = inv_Decls_s23 _stmtsX23 (T_Decls_vIn22 _stmtsOisDeclOfLet _stmtsOnested _stmtsOoptions _stmtsOoutputfile) (T_Expr_vOut25 _bodyIpp) = inv_Expr_s26 _bodyX26 (T_Expr_vIn25 _bodyOnested _bodyOoptions _bodyOoutputfile) _lhsOpp :: PP_Doc _lhsOpp = rule170 _bodyIpp _stmtsIpps _stmtsOisDeclOfLet = rule171 () _stmtsOnested = rule172 _lhsInested _stmtsOoptions = rule173 _lhsIoptions _stmtsOoutputfile = rule174 _lhsIoutputfile _bodyOnested = rule175 _lhsInested _bodyOoptions = rule176 _lhsIoptions _bodyOoutputfile = rule177 _lhsIoutputfile !__result_ = T_Expr_vOut25 _lhsOpp in __result_ ) in C_Expr_s26 v25 {-# INLINE rule170 #-} {-# LINE 146 "./src-ag/PrintCode.ag" #-} rule170 = \ ((_bodyIpp) :: PP_Doc) ((_stmtsIpps) :: PP_Docs) -> {-# LINE 146 "./src-ag/PrintCode.ag" #-} pp_parens ( "do" >#< ( vlist _stmtsIpps >-< ("return" >#< _bodyIpp)) ) {-# LINE 1650 "dist/build/PrintCode.hs"#-} {-# INLINE rule171 #-} {-# LINE 418 "./src-ag/PrintCode.ag" #-} rule171 = \ (_ :: ()) -> {-# LINE 418 "./src-ag/PrintCode.ag" #-} False {-# LINE 1656 "dist/build/PrintCode.hs"#-} {-# INLINE rule172 #-} rule172 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule173 #-} rule173 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule174 #-} rule174 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# INLINE rule175 #-} rule175 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule176 #-} rule176 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule177 #-} rule177 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# NOINLINE sem_Expr_Lambda #-} sem_Expr_Lambda :: T_Exprs -> T_Expr -> T_Expr sem_Expr_Lambda arg_args_ arg_body_ = T_Expr (return st26) where {-# NOINLINE st26 #-} !st26 = let v25 :: T_Expr_v25 v25 = \ !(T_Expr_vIn25 _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _argsX29 = Control.Monad.Identity.runIdentity (attach_T_Exprs (arg_args_)) _bodyX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_body_)) (T_Exprs_vOut28 _argsIpps) = inv_Exprs_s29 _argsX29 (T_Exprs_vIn28 _argsOnested _argsOoptions _argsOoutputfile) (T_Expr_vOut25 _bodyIpp) = inv_Expr_s26 _bodyX26 (T_Expr_vIn25 _bodyOnested _bodyOoptions _bodyOoutputfile) _strictParams = rule178 _argsIpps _lhsIoptions _addBang = rule179 _lhsIoptions _lhsOpp :: PP_Doc _lhsOpp = rule180 _addBang _argsIpps _bodyIpp _strictParams _argsOnested = rule181 _lhsInested _argsOoptions = rule182 _lhsIoptions _argsOoutputfile = rule183 _lhsIoutputfile _bodyOnested = rule184 _lhsInested _bodyOoptions = rule185 _lhsIoptions _bodyOoutputfile = rule186 _lhsIoutputfile !__result_ = T_Expr_vOut25 _lhsOpp in __result_ ) in C_Expr_s26 v25 {-# INLINE rule178 #-} {-# LINE 149 "./src-ag/PrintCode.ag" #-} rule178 = \ ((_argsIpps) :: PP_Docs) ((_lhsIoptions) :: Options) -> {-# LINE 149 "./src-ag/PrintCode.ag" #-} if strictSems _lhsIoptions then _argsIpps else [] {-# LINE 1706 "dist/build/PrintCode.hs"#-} {-# INLINE rule179 #-} {-# LINE 152 "./src-ag/PrintCode.ag" #-} rule179 = \ ((_lhsIoptions) :: Options) -> {-# LINE 152 "./src-ag/PrintCode.ag" #-} if bangpats _lhsIoptions then \p -> pp_parens ("!" >|< p) else id {-# LINE 1714 "dist/build/PrintCode.hs"#-} {-# INLINE rule180 #-} {-# LINE 155 "./src-ag/PrintCode.ag" #-} rule180 = \ _addBang ((_argsIpps) :: PP_Docs) ((_bodyIpp) :: PP_Doc) _strictParams -> {-# LINE 155 "./src-ag/PrintCode.ag" #-} pp_parens ( "\\" >#< (vlist (map _addBang _argsIpps)) >#< "->" >-< indent 4 (_strictParams `ppMultiSeqV` _bodyIpp) ) {-# LINE 1722 "dist/build/PrintCode.hs"#-} {-# INLINE rule181 #-} rule181 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule182 #-} rule182 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule183 #-} rule183 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# INLINE rule184 #-} rule184 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule185 #-} rule185 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule186 #-} rule186 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# NOINLINE sem_Expr_TupleExpr #-} sem_Expr_TupleExpr :: T_Exprs -> T_Expr sem_Expr_TupleExpr arg_exprs_ = T_Expr (return st26) where {-# NOINLINE st26 #-} !st26 = let v25 :: T_Expr_v25 v25 = \ !(T_Expr_vIn25 _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _exprsX29 = Control.Monad.Identity.runIdentity (attach_T_Exprs (arg_exprs_)) (T_Exprs_vOut28 _exprsIpps) = inv_Exprs_s29 _exprsX29 (T_Exprs_vIn28 _exprsOnested _exprsOoptions _exprsOoutputfile) _lhsOpp :: PP_Doc _lhsOpp = rule187 _exprsIpps _lhsInested _exprsOnested = rule188 _lhsInested _exprsOoptions = rule189 _lhsIoptions _exprsOoutputfile = rule190 _lhsIoutputfile !__result_ = T_Expr_vOut25 _lhsOpp in __result_ ) in C_Expr_s26 v25 {-# INLINE rule187 #-} {-# LINE 158 "./src-ag/PrintCode.ag" #-} rule187 = \ ((_exprsIpps) :: PP_Docs) ((_lhsInested) :: Bool) -> {-# LINE 158 "./src-ag/PrintCode.ag" #-} ppTuple _lhsInested _exprsIpps {-# LINE 1763 "dist/build/PrintCode.hs"#-} {-# INLINE rule188 #-} rule188 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule189 #-} rule189 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule190 #-} rule190 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# NOINLINE sem_Expr_UnboxedTupleExpr #-} sem_Expr_UnboxedTupleExpr :: T_Exprs -> T_Expr sem_Expr_UnboxedTupleExpr arg_exprs_ = T_Expr (return st26) where {-# NOINLINE st26 #-} !st26 = let v25 :: T_Expr_v25 v25 = \ !(T_Expr_vIn25 _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _exprsX29 = Control.Monad.Identity.runIdentity (attach_T_Exprs (arg_exprs_)) (T_Exprs_vOut28 _exprsIpps) = inv_Exprs_s29 _exprsX29 (T_Exprs_vIn28 _exprsOnested _exprsOoptions _exprsOoutputfile) _lhsOpp :: PP_Doc _lhsOpp = rule191 _exprsIpps _lhsInested _exprsOnested = rule192 _lhsInested _exprsOoptions = rule193 _lhsIoptions _exprsOoutputfile = rule194 _lhsIoutputfile !__result_ = T_Expr_vOut25 _lhsOpp in __result_ ) in C_Expr_s26 v25 {-# INLINE rule191 #-} {-# LINE 159 "./src-ag/PrintCode.ag" #-} rule191 = \ ((_exprsIpps) :: PP_Docs) ((_lhsInested) :: Bool) -> {-# LINE 159 "./src-ag/PrintCode.ag" #-} ppUnboxedTuple _lhsInested _exprsIpps {-# LINE 1795 "dist/build/PrintCode.hs"#-} {-# INLINE rule192 #-} rule192 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule193 #-} rule193 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule194 #-} rule194 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# NOINLINE sem_Expr_App #-} sem_Expr_App :: (String) -> T_Exprs -> T_Expr sem_Expr_App !arg_name_ arg_args_ = T_Expr (return st26) where {-# NOINLINE st26 #-} !st26 = let v25 :: T_Expr_v25 v25 = \ !(T_Expr_vIn25 _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _argsX29 = Control.Monad.Identity.runIdentity (attach_T_Exprs (arg_args_)) (T_Exprs_vOut28 _argsIpps) = inv_Exprs_s29 _argsX29 (T_Exprs_vIn28 _argsOnested _argsOoptions _argsOoutputfile) _lhsOpp :: PP_Doc _lhsOpp = rule195 _argsIpps arg_name_ _argsOnested = rule196 _lhsInested _argsOoptions = rule197 _lhsIoptions _argsOoutputfile = rule198 _lhsIoutputfile !__result_ = T_Expr_vOut25 _lhsOpp in __result_ ) in C_Expr_s26 v25 {-# INLINE rule195 #-} {-# LINE 160 "./src-ag/PrintCode.ag" #-} rule195 = \ ((_argsIpps) :: PP_Docs) name_ -> {-# LINE 160 "./src-ag/PrintCode.ag" #-} pp_parens $ name_ >#< hv_sp _argsIpps {-# LINE 1827 "dist/build/PrintCode.hs"#-} {-# INLINE rule196 #-} rule196 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule197 #-} rule197 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule198 #-} rule198 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# NOINLINE sem_Expr_SimpleExpr #-} sem_Expr_SimpleExpr :: (String) -> T_Expr sem_Expr_SimpleExpr !arg_txt_ = T_Expr (return st26) where {-# NOINLINE st26 #-} !st26 = let v25 :: T_Expr_v25 v25 = \ !(T_Expr_vIn25 _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule199 arg_txt_ !__result_ = T_Expr_vOut25 _lhsOpp in __result_ ) in C_Expr_s26 v25 {-# INLINE rule199 #-} {-# LINE 161 "./src-ag/PrintCode.ag" #-} rule199 = \ txt_ -> {-# LINE 161 "./src-ag/PrintCode.ag" #-} text txt_ {-# LINE 1854 "dist/build/PrintCode.hs"#-} {-# NOINLINE sem_Expr_TextExpr #-} sem_Expr_TextExpr :: ([String]) -> T_Expr sem_Expr_TextExpr !arg_lns_ = T_Expr (return st26) where {-# NOINLINE st26 #-} !st26 = let v25 :: T_Expr_v25 v25 = \ !(T_Expr_vIn25 _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule200 arg_lns_ !__result_ = T_Expr_vOut25 _lhsOpp in __result_ ) in C_Expr_s26 v25 {-# INLINE rule200 #-} {-# LINE 162 "./src-ag/PrintCode.ag" #-} rule200 = \ lns_ -> {-# LINE 162 "./src-ag/PrintCode.ag" #-} vlist (map text lns_) {-# LINE 1872 "dist/build/PrintCode.hs"#-} {-# NOINLINE sem_Expr_Trace #-} sem_Expr_Trace :: (String) -> T_Expr -> T_Expr sem_Expr_Trace !arg_txt_ arg_expr_ = T_Expr (return st26) where {-# NOINLINE st26 #-} !st26 = let v25 :: T_Expr_v25 v25 = \ !(T_Expr_vIn25 _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _exprX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_expr_)) (T_Expr_vOut25 _exprIpp) = inv_Expr_s26 _exprX26 (T_Expr_vIn25 _exprOnested _exprOoptions _exprOoutputfile) _lhsOpp :: PP_Doc _lhsOpp = rule201 _exprIpp arg_txt_ _exprOnested = rule202 _lhsInested _exprOoptions = rule203 _lhsIoptions _exprOoutputfile = rule204 _lhsIoutputfile !__result_ = T_Expr_vOut25 _lhsOpp in __result_ ) in C_Expr_s26 v25 {-# INLINE rule201 #-} {-# LINE 163 "./src-ag/PrintCode.ag" #-} rule201 = \ ((_exprIpp) :: PP_Doc) txt_ -> {-# LINE 163 "./src-ag/PrintCode.ag" #-} "trace" >#< ( pp_parens ("\"" >|< text txt_ >|< "\"") >-< pp_parens _exprIpp ) {-# LINE 1897 "dist/build/PrintCode.hs"#-} {-# INLINE rule202 #-} rule202 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule203 #-} rule203 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule204 #-} rule204 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# NOINLINE sem_Expr_PragmaExpr #-} sem_Expr_PragmaExpr :: (Bool) -> (Bool) -> (String) -> T_Expr -> T_Expr sem_Expr_PragmaExpr !arg_onLeftSide_ !arg_onNewLine_ !arg_txt_ arg_expr_ = T_Expr (return st26) where {-# NOINLINE st26 #-} !st26 = let v25 :: T_Expr_v25 v25 = \ !(T_Expr_vIn25 _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _exprX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_expr_)) (T_Expr_vOut25 _exprIpp) = inv_Expr_s26 _exprX26 (T_Expr_vIn25 _exprOnested _exprOoptions _exprOoutputfile) _lhsOpp :: PP_Doc _lhsOpp = rule205 _exprIpp arg_onLeftSide_ arg_onNewLine_ arg_txt_ _exprOnested = rule206 _lhsInested _exprOoptions = rule207 _lhsIoptions _exprOoutputfile = rule208 _lhsIoutputfile !__result_ = T_Expr_vOut25 _lhsOpp in __result_ ) in C_Expr_s26 v25 {-# INLINE rule205 #-} {-# LINE 166 "./src-ag/PrintCode.ag" #-} rule205 = \ ((_exprIpp) :: PP_Doc) onLeftSide_ onNewLine_ txt_ -> {-# LINE 166 "./src-ag/PrintCode.ag" #-} 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` _exprIpp `rightOp` pragmaDoc) {-# LINE 1939 "dist/build/PrintCode.hs"#-} {-# INLINE rule206 #-} rule206 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule207 #-} rule207 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule208 #-} rule208 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# NOINLINE sem_Expr_LineExpr #-} sem_Expr_LineExpr :: T_Expr -> T_Expr sem_Expr_LineExpr arg_expr_ = T_Expr (return st26) where {-# NOINLINE st26 #-} !st26 = let v25 :: T_Expr_v25 v25 = \ !(T_Expr_vIn25 _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _exprX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_expr_)) (T_Expr_vOut25 _exprIpp) = inv_Expr_s26 _exprX26 (T_Expr_vIn25 _exprOnested _exprOoptions _exprOoutputfile) _lhsOpp :: PP_Doc _lhsOpp = rule209 _exprIpp _lhsIoutputfile _exprOnested = rule210 _lhsInested _exprOoptions = rule211 _lhsIoptions _exprOoutputfile = rule212 _lhsIoutputfile !__result_ = T_Expr_vOut25 _lhsOpp in __result_ ) in C_Expr_s26 v25 {-# INLINE rule209 #-} {-# LINE 177 "./src-ag/PrintCode.ag" #-} rule209 = \ ((_exprIpp) :: PP_Doc) ((_lhsIoutputfile) :: String) -> {-# LINE 177 "./src-ag/PrintCode.ag" #-} _exprIpp >-< "{-# LINE" >#< ppWithLineNr (\n -> pp $ show $ n + 1) >#< show _lhsIoutputfile >#< "#-}" >-< "" {-# LINE 1972 "dist/build/PrintCode.hs"#-} {-# INLINE rule210 #-} rule210 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule211 #-} rule211 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule212 #-} rule212 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# NOINLINE sem_Expr_TypedExpr #-} sem_Expr_TypedExpr :: T_Expr -> T_Type -> T_Expr sem_Expr_TypedExpr arg_expr_ arg_tp_ = T_Expr (return st26) where {-# NOINLINE st26 #-} !st26 = let v25 :: T_Expr_v25 v25 = \ !(T_Expr_vIn25 _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _exprX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_expr_)) _tpX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_tp_)) (T_Expr_vOut25 _exprIpp) = inv_Expr_s26 _exprX26 (T_Expr_vIn25 _exprOnested _exprOoptions _exprOoutputfile) (T_Type_vOut49 _tpIpp _tpIprec) = inv_Type_s50 _tpX50 (T_Type_vIn49 _tpOnested) _lhsOpp :: PP_Doc _lhsOpp = rule213 _exprIpp _tpIpp _exprOnested = rule214 _lhsInested _exprOoptions = rule215 _lhsIoptions _exprOoutputfile = rule216 _lhsIoutputfile _tpOnested = rule217 _lhsInested !__result_ = T_Expr_vOut25 _lhsOpp in __result_ ) in C_Expr_s26 v25 {-# INLINE rule213 #-} {-# LINE 179 "./src-ag/PrintCode.ag" #-} rule213 = \ ((_exprIpp) :: PP_Doc) ((_tpIpp) :: PP_Doc) -> {-# LINE 179 "./src-ag/PrintCode.ag" #-} pp_parens (_exprIpp >#< "::" >#< _tpIpp) {-# LINE 2007 "dist/build/PrintCode.hs"#-} {-# INLINE rule214 #-} rule214 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule215 #-} rule215 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule216 #-} rule216 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# INLINE rule217 #-} rule217 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# NOINLINE sem_Expr_ResultExpr #-} sem_Expr_ResultExpr :: (String) -> T_Expr -> T_Expr sem_Expr_ResultExpr !arg_nt_ arg_expr_ = T_Expr (return st26) where {-# NOINLINE st26 #-} !st26 = let v25 :: T_Expr_v25 v25 = \ !(T_Expr_vIn25 _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _exprX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_expr_)) (T_Expr_vOut25 _exprIpp) = inv_Expr_s26 _exprX26 (T_Expr_vIn25 _exprOnested _exprOoptions _exprOoutputfile) _lhsOpp :: PP_Doc _lhsOpp = rule218 _exprIpp _lhsIoptions arg_nt_ _exprOnested = rule219 _lhsInested _exprOoptions = rule220 _lhsIoptions _exprOoutputfile = rule221 _lhsIoutputfile !__result_ = T_Expr_vOut25 _lhsOpp in __result_ ) in C_Expr_s26 v25 {-# INLINE rule218 #-} {-# LINE 180 "./src-ag/PrintCode.ag" #-} rule218 = \ ((_exprIpp) :: PP_Doc) ((_lhsIoptions) :: Options) nt_ -> {-# LINE 180 "./src-ag/PrintCode.ag" #-} if breadthFirst _lhsIoptions then "final" >#< pp_parens (nt_ >|< "_Syn" >#< pp_parens _exprIpp) else _exprIpp {-# LINE 2045 "dist/build/PrintCode.hs"#-} {-# INLINE rule219 #-} rule219 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule220 #-} rule220 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule221 #-} rule221 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# NOINLINE sem_Expr_InvokeExpr #-} sem_Expr_InvokeExpr :: (String) -> T_Expr -> T_Exprs -> T_Expr sem_Expr_InvokeExpr !arg_nt_ arg_expr_ arg_args_ = T_Expr (return st26) where {-# NOINLINE st26 #-} !st26 = let v25 :: T_Expr_v25 v25 = \ !(T_Expr_vIn25 _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _exprX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_expr_)) _argsX29 = Control.Monad.Identity.runIdentity (attach_T_Exprs (arg_args_)) (T_Expr_vOut25 _exprIpp) = inv_Expr_s26 _exprX26 (T_Expr_vIn25 _exprOnested _exprOoptions _exprOoutputfile) (T_Exprs_vOut28 _argsIpps) = inv_Exprs_s29 _argsX29 (T_Exprs_vIn28 _argsOnested _argsOoptions _argsOoutputfile) _lhsOpp :: PP_Doc _lhsOpp = rule222 _argsIpps _exprIpp _lhsIoptions arg_nt_ _exprOnested = rule223 _lhsInested _exprOoptions = rule224 _lhsIoptions _exprOoutputfile = rule225 _lhsIoutputfile _argsOnested = rule226 _lhsInested _argsOoptions = rule227 _lhsIoptions _argsOoutputfile = rule228 _lhsIoutputfile !__result_ = T_Expr_vOut25 _lhsOpp in __result_ ) in C_Expr_s26 v25 {-# INLINE rule222 #-} {-# LINE 184 "./src-ag/PrintCode.ag" #-} rule222 = \ ((_argsIpps) :: PP_Docs) ((_exprIpp) :: PP_Doc) ((_lhsIoptions) :: Options) nt_ -> {-# LINE 184 "./src-ag/PrintCode.ag" #-} if breadthFirst _lhsIoptions then "invoke" >#< pp_parens _exprIpp >#< pp_parens ( nt_ >|< "_Inh" >#< pp_parens (ppTuple False _argsIpps)) else _exprIpp >#< hv_sp _argsIpps {-# LINE 2085 "dist/build/PrintCode.hs"#-} {-# INLINE rule223 #-} rule223 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule224 #-} rule224 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule225 #-} rule225 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# INLINE rule226 #-} rule226 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule227 #-} rule227 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule228 #-} rule228 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# NOINLINE sem_Expr_ResumeExpr #-} sem_Expr_ResumeExpr :: (String) -> T_Expr -> T_Lhs -> T_Expr -> T_Expr sem_Expr_ResumeExpr !arg_nt_ arg_expr_ arg_left_ arg_rhs_ = T_Expr (return st26) where {-# NOINLINE st26 #-} !st26 = let v25 :: T_Expr_v25 v25 = \ !(T_Expr_vIn25 _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _exprX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_expr_)) _leftX32 = Control.Monad.Identity.runIdentity (attach_T_Lhs (arg_left_)) _rhsX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_rhs_)) (T_Expr_vOut25 _exprIpp) = inv_Expr_s26 _exprX26 (T_Expr_vIn25 _exprOnested _exprOoptions _exprOoutputfile) (T_Lhs_vOut31 _leftIpp) = inv_Lhs_s32 _leftX32 (T_Lhs_vIn31 _leftOisDeclOfLet _leftOnested _leftOoptions _leftOoutputfile) (T_Expr_vOut25 _rhsIpp) = inv_Expr_s26 _rhsX26 (T_Expr_vIn25 _rhsOnested _rhsOoptions _rhsOoutputfile) _lhsOpp :: PP_Doc _lhsOpp = rule229 _exprIpp _leftIpp _lhsIoptions _rhsIpp arg_nt_ _leftOisDeclOfLet = rule230 () _exprOnested = rule231 _lhsInested _exprOoptions = rule232 _lhsIoptions _exprOoutputfile = rule233 _lhsIoutputfile _leftOnested = rule234 _lhsInested _leftOoptions = rule235 _lhsIoptions _leftOoutputfile = rule236 _lhsIoutputfile _rhsOnested = rule237 _lhsInested _rhsOoptions = rule238 _lhsIoptions _rhsOoutputfile = rule239 _lhsIoutputfile !__result_ = T_Expr_vOut25 _lhsOpp in __result_ ) in C_Expr_s26 v25 {-# INLINE rule229 #-} {-# LINE 188 "./src-ag/PrintCode.ag" #-} rule229 = \ ((_exprIpp) :: PP_Doc) ((_leftIpp) :: PP_Doc) ((_lhsIoptions) :: Options) ((_rhsIpp) :: PP_Doc) nt_ -> {-# LINE 188 "./src-ag/PrintCode.ag" #-} if breadthFirst _lhsIoptions then pp_parens ("resume" >#< pp_parens _exprIpp >-< indent 2 (pp_parens ( "\\" >|< pp_parens ("~" >|< pp_parens (nt_ >|< "_Syn" >#< "_inh_arg")) >#< "->" >-< indent 2 ( "let" >#< _leftIpp >#< "= _inh_arg" >-< indent 2 ("in" >#< _rhsIpp) )))) else pp_parens ( "case" >#< pp_parens _exprIpp >#< "of" >-< ("{" >#< _leftIpp >#< "->") >-< indent 4 (_rhsIpp >#< "}") ) {-# LINE 2148 "dist/build/PrintCode.hs"#-} {-# INLINE rule230 #-} {-# LINE 420 "./src-ag/PrintCode.ag" #-} rule230 = \ (_ :: ()) -> {-# LINE 420 "./src-ag/PrintCode.ag" #-} False {-# LINE 2154 "dist/build/PrintCode.hs"#-} {-# INLINE rule231 #-} rule231 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule232 #-} rule232 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule233 #-} rule233 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# INLINE rule234 #-} rule234 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule235 #-} rule235 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule236 #-} rule236 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# INLINE rule237 #-} rule237 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule238 #-} rule238 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule239 #-} rule239 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# NOINLINE sem_Expr_SemFun #-} sem_Expr_SemFun :: (String) -> T_Exprs -> T_Expr -> T_Expr sem_Expr_SemFun !arg_nt_ arg_args_ arg_body_ = T_Expr (return st26) where {-# NOINLINE st26 #-} !st26 = let v25 :: T_Expr_v25 v25 = \ !(T_Expr_vIn25 _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _argsX29 = Control.Monad.Identity.runIdentity (attach_T_Exprs (arg_args_)) _bodyX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_body_)) (T_Exprs_vOut28 _argsIpps) = inv_Exprs_s29 _argsX29 (T_Exprs_vIn28 _argsOnested _argsOoptions _argsOoutputfile) (T_Expr_vOut25 _bodyIpp) = inv_Expr_s26 _bodyX26 (T_Expr_vIn25 _bodyOnested _bodyOoptions _bodyOoutputfile) _strictParams = rule240 _argsIpps _lhsIoptions _addBang = rule241 _lhsIoptions _lhsOpp :: PP_Doc _lhsOpp = rule242 _addBang _argsIpps _bodyIpp _lhsIoptions _strictParams arg_nt_ _argsOnested = rule243 _lhsInested _argsOoptions = rule244 _lhsIoptions _argsOoutputfile = rule245 _lhsIoutputfile _bodyOnested = rule246 _lhsInested _bodyOoptions = rule247 _lhsIoptions _bodyOoutputfile = rule248 _lhsIoutputfile !__result_ = T_Expr_vOut25 _lhsOpp in __result_ ) in C_Expr_s26 v25 {-# INLINE rule240 #-} {-# LINE 200 "./src-ag/PrintCode.ag" #-} rule240 = \ ((_argsIpps) :: PP_Docs) ((_lhsIoptions) :: Options) -> {-# LINE 200 "./src-ag/PrintCode.ag" #-} if strictSems _lhsIoptions then _argsIpps else [] {-# LINE 2213 "dist/build/PrintCode.hs"#-} {-# INLINE rule241 #-} {-# LINE 203 "./src-ag/PrintCode.ag" #-} rule241 = \ ((_lhsIoptions) :: Options) -> {-# LINE 203 "./src-ag/PrintCode.ag" #-} if bangpats _lhsIoptions then \p -> pp_parens ("!" >|< p) else id {-# LINE 2221 "dist/build/PrintCode.hs"#-} {-# INLINE rule242 #-} {-# LINE 206 "./src-ag/PrintCode.ag" #-} rule242 = \ _addBang ((_argsIpps) :: PP_Docs) ((_bodyIpp) :: PP_Doc) ((_lhsIoptions) :: Options) _strictParams nt_ -> {-# LINE 206 "./src-ag/PrintCode.ag" #-} if breadthFirst _lhsIoptions then "Child" >#< pp_parens ( "\\" >|< pp_parens (nt_ >|< "_Inh" >#< ppTuple False (map _addBang _argsIpps)) >#< "->" >-< indent 2 (_strictParams `ppMultiSeqV` _bodyIpp)) else if null _argsIpps then _bodyIpp else pp_parens ( "\\" >#< (vlist (map _addBang _argsIpps)) >#< "->" >-< indent 4 (_strictParams `ppMultiSeqV` _bodyIpp) ) {-# LINE 2236 "dist/build/PrintCode.hs"#-} {-# INLINE rule243 #-} rule243 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule244 #-} rule244 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule245 #-} rule245 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# INLINE rule246 #-} rule246 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule247 #-} rule247 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule248 #-} rule248 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile -- Exprs ------------------------------------------------------- -- wrapper data Inh_Exprs = Inh_Exprs { nested_Inh_Exprs :: !(Bool), options_Inh_Exprs :: !(Options), outputfile_Inh_Exprs :: !(String) } data Syn_Exprs = Syn_Exprs { pps_Syn_Exprs :: !(PP_Docs) } {-# INLINABLE wrap_Exprs #-} wrap_Exprs :: T_Exprs -> Inh_Exprs -> (Syn_Exprs ) wrap_Exprs !(T_Exprs act) !(Inh_Exprs _lhsInested _lhsIoptions _lhsIoutputfile) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Exprs_vIn28 _lhsInested _lhsIoptions _lhsIoutputfile !(T_Exprs_vOut28 _lhsOpps) <- return (inv_Exprs_s29 sem arg) return (Syn_Exprs _lhsOpps) ) -- cata {-# NOINLINE sem_Exprs #-} sem_Exprs :: Exprs -> T_Exprs sem_Exprs list = Prelude.foldr sem_Exprs_Cons sem_Exprs_Nil (Prelude.map sem_Expr list) -- semantic domain newtype T_Exprs = T_Exprs { attach_T_Exprs :: Identity (T_Exprs_s29 ) } newtype T_Exprs_s29 = C_Exprs_s29 { inv_Exprs_s29 :: (T_Exprs_v28 ) } data T_Exprs_s30 = C_Exprs_s30 type T_Exprs_v28 = (T_Exprs_vIn28 ) -> (T_Exprs_vOut28 ) data T_Exprs_vIn28 = T_Exprs_vIn28 (Bool) (Options) (String) data T_Exprs_vOut28 = T_Exprs_vOut28 (PP_Docs) {-# NOINLINE sem_Exprs_Cons #-} sem_Exprs_Cons :: T_Expr -> T_Exprs -> T_Exprs sem_Exprs_Cons arg_hd_ arg_tl_ = T_Exprs (return st29) where {-# NOINLINE st29 #-} !st29 = let v28 :: T_Exprs_v28 v28 = \ !(T_Exprs_vIn28 _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _hdX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_hd_)) _tlX29 = Control.Monad.Identity.runIdentity (attach_T_Exprs (arg_tl_)) (T_Expr_vOut25 _hdIpp) = inv_Expr_s26 _hdX26 (T_Expr_vIn25 _hdOnested _hdOoptions _hdOoutputfile) (T_Exprs_vOut28 _tlIpps) = inv_Exprs_s29 _tlX29 (T_Exprs_vIn28 _tlOnested _tlOoptions _tlOoutputfile) _lhsOpps :: PP_Docs _lhsOpps = rule249 _hdIpp _tlIpps _hdOnested = rule250 _lhsInested _hdOoptions = rule251 _lhsIoptions _hdOoutputfile = rule252 _lhsIoutputfile _tlOnested = rule253 _lhsInested _tlOoptions = rule254 _lhsIoptions _tlOoutputfile = rule255 _lhsIoutputfile !__result_ = T_Exprs_vOut28 _lhsOpps in __result_ ) in C_Exprs_s29 v28 {-# INLINE rule249 #-} {-# LINE 64 "./src-ag/PrintCode.ag" #-} rule249 = \ ((_hdIpp) :: PP_Doc) ((_tlIpps) :: PP_Docs) -> {-# LINE 64 "./src-ag/PrintCode.ag" #-} _hdIpp : _tlIpps {-# LINE 2313 "dist/build/PrintCode.hs"#-} {-# INLINE rule250 #-} rule250 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule251 #-} rule251 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule252 #-} rule252 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# INLINE rule253 #-} rule253 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule254 #-} rule254 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule255 #-} rule255 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# NOINLINE sem_Exprs_Nil #-} sem_Exprs_Nil :: T_Exprs sem_Exprs_Nil = T_Exprs (return st29) where {-# NOINLINE st29 #-} !st29 = let v28 :: T_Exprs_v28 v28 = \ !(T_Exprs_vIn28 _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _lhsOpps :: PP_Docs _lhsOpps = rule256 () !__result_ = T_Exprs_vOut28 _lhsOpps in __result_ ) in C_Exprs_s29 v28 {-# INLINE rule256 #-} {-# LINE 65 "./src-ag/PrintCode.ag" #-} rule256 = \ (_ :: ()) -> {-# LINE 65 "./src-ag/PrintCode.ag" #-} [] {-# LINE 2349 "dist/build/PrintCode.hs"#-} -- Lhs --------------------------------------------------------- -- wrapper data Inh_Lhs = Inh_Lhs { isDeclOfLet_Inh_Lhs :: !(Bool), nested_Inh_Lhs :: !(Bool), options_Inh_Lhs :: !(Options), outputfile_Inh_Lhs :: !(String) } data Syn_Lhs = Syn_Lhs { pp_Syn_Lhs :: !(PP_Doc) } {-# INLINABLE wrap_Lhs #-} wrap_Lhs :: T_Lhs -> Inh_Lhs -> (Syn_Lhs ) wrap_Lhs !(T_Lhs act) !(Inh_Lhs _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Lhs_vIn31 _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile !(T_Lhs_vOut31 _lhsOpp) <- return (inv_Lhs_s32 sem arg) return (Syn_Lhs _lhsOpp) ) -- cata {-# NOINLINE sem_Lhs #-} sem_Lhs :: Lhs -> T_Lhs sem_Lhs ( Pattern3 pat3_ ) = sem_Lhs_Pattern3 ( sem_Pattern pat3_ ) sem_Lhs ( Pattern3SM pat3_ ) = sem_Lhs_Pattern3SM ( sem_Pattern pat3_ ) sem_Lhs ( TupleLhs !comps_ ) = sem_Lhs_TupleLhs comps_ sem_Lhs ( UnboxedTupleLhs !comps_ ) = sem_Lhs_UnboxedTupleLhs comps_ sem_Lhs ( Fun !name_ args_ ) = sem_Lhs_Fun name_ ( sem_Exprs args_ ) sem_Lhs ( Unwrap !name_ sub_ ) = sem_Lhs_Unwrap name_ ( sem_Lhs sub_ ) -- semantic domain newtype T_Lhs = T_Lhs { attach_T_Lhs :: Identity (T_Lhs_s32 ) } newtype T_Lhs_s32 = C_Lhs_s32 { inv_Lhs_s32 :: (T_Lhs_v31 ) } data T_Lhs_s33 = C_Lhs_s33 type T_Lhs_v31 = (T_Lhs_vIn31 ) -> (T_Lhs_vOut31 ) data T_Lhs_vIn31 = T_Lhs_vIn31 (Bool) (Bool) (Options) (String) data T_Lhs_vOut31 = T_Lhs_vOut31 (PP_Doc) {-# NOINLINE sem_Lhs_Pattern3 #-} sem_Lhs_Pattern3 :: T_Pattern -> T_Lhs sem_Lhs_Pattern3 arg_pat3_ = T_Lhs (return st32) where {-# NOINLINE st32 #-} !st32 = let v31 :: T_Lhs_v31 v31 = \ !(T_Lhs_vIn31 _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _pat3X41 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat3_)) (T_Pattern_vOut40 _pat3Icopy _pat3IisUnderscore _pat3Ipp _pat3Ipp' _pat3IstrictVars) = inv_Pattern_s41 _pat3X41 (T_Pattern_vIn40 _pat3ObelowIrrefutable _pat3OisDeclOfLet _pat3Ooptions) _addStrictGuard = rule257 _hasStrictVars _lhsIoptions _strictGuard _strictGuard = rule258 _pat3IstrictVars _hasStrictVars = rule259 _pat3IstrictVars _lhsOpp :: PP_Doc _lhsOpp = rule260 _addStrictGuard _pat3Ipp _pat3ObelowIrrefutable = rule261 () _pat3OisDeclOfLet = rule262 _lhsIisDeclOfLet _pat3Ooptions = rule263 _lhsIoptions !__result_ = T_Lhs_vOut31 _lhsOpp in __result_ ) in C_Lhs_s32 v31 {-# INLINE rule257 #-} {-# LINE 231 "./src-ag/PrintCode.ag" #-} rule257 = \ _hasStrictVars ((_lhsIoptions) :: Options) _strictGuard -> {-# LINE 231 "./src-ag/PrintCode.ag" #-} if strictCases _lhsIoptions && _hasStrictVars then \v -> v >#< "|" >#< _strictGuard else id {-# LINE 2411 "dist/build/PrintCode.hs"#-} {-# INLINE rule258 #-} {-# LINE 233 "./src-ag/PrintCode.ag" #-} rule258 = \ ((_pat3IstrictVars) :: [PP_Doc]) -> {-# LINE 233 "./src-ag/PrintCode.ag" #-} _pat3IstrictVars `ppMultiSeqH` (pp "True") {-# LINE 2417 "dist/build/PrintCode.hs"#-} {-# INLINE rule259 #-} {-# LINE 234 "./src-ag/PrintCode.ag" #-} rule259 = \ ((_pat3IstrictVars) :: [PP_Doc]) -> {-# LINE 234 "./src-ag/PrintCode.ag" #-} not (null _pat3IstrictVars) {-# LINE 2423 "dist/build/PrintCode.hs"#-} {-# INLINE rule260 #-} {-# LINE 251 "./src-ag/PrintCode.ag" #-} rule260 = \ _addStrictGuard ((_pat3Ipp) :: PP_Doc) -> {-# LINE 251 "./src-ag/PrintCode.ag" #-} _addStrictGuard _pat3Ipp {-# LINE 2429 "dist/build/PrintCode.hs"#-} {-# INLINE rule261 #-} {-# LINE 381 "./src-ag/PrintCode.ag" #-} rule261 = \ (_ :: ()) -> {-# LINE 381 "./src-ag/PrintCode.ag" #-} False {-# LINE 2435 "dist/build/PrintCode.hs"#-} {-# INLINE rule262 #-} rule262 = \ ((_lhsIisDeclOfLet) :: Bool) -> _lhsIisDeclOfLet {-# INLINE rule263 #-} rule263 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Lhs_Pattern3SM #-} sem_Lhs_Pattern3SM :: T_Pattern -> T_Lhs sem_Lhs_Pattern3SM arg_pat3_ = T_Lhs (return st32) where {-# NOINLINE st32 #-} !st32 = let v31 :: T_Lhs_v31 v31 = \ !(T_Lhs_vIn31 _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _pat3X41 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat3_)) (T_Pattern_vOut40 _pat3Icopy _pat3IisUnderscore _pat3Ipp _pat3Ipp' _pat3IstrictVars) = inv_Pattern_s41 _pat3X41 (T_Pattern_vIn40 _pat3ObelowIrrefutable _pat3OisDeclOfLet _pat3Ooptions) _lhsOpp :: PP_Doc _lhsOpp = rule264 _pat3Ipp' _pat3ObelowIrrefutable = rule265 () _pat3OisDeclOfLet = rule266 _lhsIisDeclOfLet _pat3Ooptions = rule267 _lhsIoptions !__result_ = T_Lhs_vOut31 _lhsOpp in __result_ ) in C_Lhs_s32 v31 {-# INLINE rule264 #-} {-# LINE 252 "./src-ag/PrintCode.ag" #-} rule264 = \ ((_pat3Ipp') :: PP_Doc) -> {-# LINE 252 "./src-ag/PrintCode.ag" #-} _pat3Ipp' {-# LINE 2464 "dist/build/PrintCode.hs"#-} {-# INLINE rule265 #-} {-# LINE 381 "./src-ag/PrintCode.ag" #-} rule265 = \ (_ :: ()) -> {-# LINE 381 "./src-ag/PrintCode.ag" #-} False {-# LINE 2470 "dist/build/PrintCode.hs"#-} {-# INLINE rule266 #-} rule266 = \ ((_lhsIisDeclOfLet) :: Bool) -> _lhsIisDeclOfLet {-# INLINE rule267 #-} rule267 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Lhs_TupleLhs #-} sem_Lhs_TupleLhs :: ([String]) -> T_Lhs sem_Lhs_TupleLhs !arg_comps_ = T_Lhs (return st32) where {-# NOINLINE st32 #-} !st32 = let v31 :: T_Lhs_v31 v31 = \ !(T_Lhs_vIn31 _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _addStrictGuard = rule268 _hasStrictVars _lhsIoptions _strictGuard _strictGuard = rule269 _lhsIisDeclOfLet _lhsIoptions arg_comps_ _hasStrictVars = rule270 arg_comps_ _addBang = rule271 _lhsIoptions _lhsOpp :: PP_Doc _lhsOpp = rule272 _addBang _addStrictGuard _lhsInested arg_comps_ !__result_ = T_Lhs_vOut31 _lhsOpp in __result_ ) in C_Lhs_s32 v31 {-# INLINE rule268 #-} {-# LINE 231 "./src-ag/PrintCode.ag" #-} rule268 = \ _hasStrictVars ((_lhsIoptions) :: Options) _strictGuard -> {-# LINE 231 "./src-ag/PrintCode.ag" #-} if strictCases _lhsIoptions && _hasStrictVars then \v -> v >#< "|" >#< _strictGuard else id {-# LINE 2498 "dist/build/PrintCode.hs"#-} {-# INLINE rule269 #-} {-# LINE 236 "./src-ag/PrintCode.ag" #-} rule269 = \ ((_lhsIisDeclOfLet) :: Bool) ((_lhsIoptions) :: Options) comps_ -> {-# LINE 236 "./src-ag/PrintCode.ag" #-} if stricterCases _lhsIoptions && not _lhsIisDeclOfLet then map text comps_ `ppMultiSeqH` (pp "True") else pp "True" {-# LINE 2506 "dist/build/PrintCode.hs"#-} {-# INLINE rule270 #-} {-# LINE 239 "./src-ag/PrintCode.ag" #-} rule270 = \ comps_ -> {-# LINE 239 "./src-ag/PrintCode.ag" #-} not (null comps_) {-# LINE 2512 "dist/build/PrintCode.hs"#-} {-# INLINE rule271 #-} {-# LINE 247 "./src-ag/PrintCode.ag" #-} rule271 = \ ((_lhsIoptions) :: Options) -> {-# LINE 247 "./src-ag/PrintCode.ag" #-} if bangpats _lhsIoptions then \p -> "!" >|< p else id {-# LINE 2520 "dist/build/PrintCode.hs"#-} {-# INLINE rule272 #-} {-# LINE 253 "./src-ag/PrintCode.ag" #-} rule272 = \ _addBang _addStrictGuard ((_lhsInested) :: Bool) comps_ -> {-# LINE 253 "./src-ag/PrintCode.ag" #-} _addStrictGuard $ ppTuple _lhsInested (map (_addBang . text) comps_) {-# LINE 2526 "dist/build/PrintCode.hs"#-} {-# NOINLINE sem_Lhs_UnboxedTupleLhs #-} sem_Lhs_UnboxedTupleLhs :: ([String]) -> T_Lhs sem_Lhs_UnboxedTupleLhs !arg_comps_ = T_Lhs (return st32) where {-# NOINLINE st32 #-} !st32 = let v31 :: T_Lhs_v31 v31 = \ !(T_Lhs_vIn31 _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _addStrictGuard = rule273 _hasStrictVars _lhsIoptions _strictGuard _strictGuard = rule274 _lhsIisDeclOfLet _lhsIoptions arg_comps_ _hasStrictVars = rule275 arg_comps_ _addBang = rule276 _lhsIoptions _lhsOpp :: PP_Doc _lhsOpp = rule277 _addBang _addStrictGuard _lhsInested arg_comps_ !__result_ = T_Lhs_vOut31 _lhsOpp in __result_ ) in C_Lhs_s32 v31 {-# INLINE rule273 #-} {-# LINE 231 "./src-ag/PrintCode.ag" #-} rule273 = \ _hasStrictVars ((_lhsIoptions) :: Options) _strictGuard -> {-# LINE 231 "./src-ag/PrintCode.ag" #-} if strictCases _lhsIoptions && _hasStrictVars then \v -> v >#< "|" >#< _strictGuard else id {-# LINE 2548 "dist/build/PrintCode.hs"#-} {-# INLINE rule274 #-} {-# LINE 236 "./src-ag/PrintCode.ag" #-} rule274 = \ ((_lhsIisDeclOfLet) :: Bool) ((_lhsIoptions) :: Options) comps_ -> {-# LINE 236 "./src-ag/PrintCode.ag" #-} if stricterCases _lhsIoptions && not _lhsIisDeclOfLet then map text comps_ `ppMultiSeqH` (pp "True") else pp "True" {-# LINE 2556 "dist/build/PrintCode.hs"#-} {-# INLINE rule275 #-} {-# LINE 239 "./src-ag/PrintCode.ag" #-} rule275 = \ comps_ -> {-# LINE 239 "./src-ag/PrintCode.ag" #-} not (null comps_) {-# LINE 2562 "dist/build/PrintCode.hs"#-} {-# INLINE rule276 #-} {-# LINE 247 "./src-ag/PrintCode.ag" #-} rule276 = \ ((_lhsIoptions) :: Options) -> {-# LINE 247 "./src-ag/PrintCode.ag" #-} if bangpats _lhsIoptions then \p -> "!" >|< p else id {-# LINE 2570 "dist/build/PrintCode.hs"#-} {-# INLINE rule277 #-} {-# LINE 254 "./src-ag/PrintCode.ag" #-} rule277 = \ _addBang _addStrictGuard ((_lhsInested) :: Bool) comps_ -> {-# LINE 254 "./src-ag/PrintCode.ag" #-} _addStrictGuard $ ppUnboxedTuple _lhsInested (map (_addBang . text) comps_) {-# LINE 2576 "dist/build/PrintCode.hs"#-} {-# NOINLINE sem_Lhs_Fun #-} sem_Lhs_Fun :: (String) -> T_Exprs -> T_Lhs sem_Lhs_Fun !arg_name_ arg_args_ = T_Lhs (return st32) where {-# NOINLINE st32 #-} !st32 = let v31 :: T_Lhs_v31 v31 = \ !(T_Lhs_vIn31 _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _argsX29 = Control.Monad.Identity.runIdentity (attach_T_Exprs (arg_args_)) (T_Exprs_vOut28 _argsIpps) = inv_Exprs_s29 _argsX29 (T_Exprs_vIn28 _argsOnested _argsOoptions _argsOoutputfile) _addStrictGuard = rule278 _hasStrictVars _lhsIoptions _strictGuard _hasStrictVars = rule279 _argsIpps _strictGuard = rule280 _argsIpps _addBang = rule281 _lhsIoptions _lhsOpp :: PP_Doc _lhsOpp = rule282 _addBang _addStrictGuard _argsIpps arg_name_ _argsOnested = rule283 _lhsInested _argsOoptions = rule284 _lhsIoptions _argsOoutputfile = rule285 _lhsIoutputfile !__result_ = T_Lhs_vOut31 _lhsOpp in __result_ ) in C_Lhs_s32 v31 {-# INLINE rule278 #-} {-# LINE 242 "./src-ag/PrintCode.ag" #-} rule278 = \ _hasStrictVars ((_lhsIoptions) :: Options) _strictGuard -> {-# LINE 242 "./src-ag/PrintCode.ag" #-} if strictSems _lhsIoptions && _hasStrictVars then \v -> v >#< "|" >#< _strictGuard else id {-# LINE 2603 "dist/build/PrintCode.hs"#-} {-# INLINE rule279 #-} {-# LINE 243 "./src-ag/PrintCode.ag" #-} rule279 = \ ((_argsIpps) :: PP_Docs) -> {-# LINE 243 "./src-ag/PrintCode.ag" #-} not (null _argsIpps) {-# LINE 2609 "dist/build/PrintCode.hs"#-} {-# INLINE rule280 #-} {-# LINE 244 "./src-ag/PrintCode.ag" #-} rule280 = \ ((_argsIpps) :: PP_Docs) -> {-# LINE 244 "./src-ag/PrintCode.ag" #-} _argsIpps `ppMultiSeqH` (pp "True") {-# LINE 2615 "dist/build/PrintCode.hs"#-} {-# INLINE rule281 #-} {-# LINE 247 "./src-ag/PrintCode.ag" #-} rule281 = \ ((_lhsIoptions) :: Options) -> {-# LINE 247 "./src-ag/PrintCode.ag" #-} if bangpats _lhsIoptions then \p -> "!" >|< p else id {-# LINE 2623 "dist/build/PrintCode.hs"#-} {-# INLINE rule282 #-} {-# LINE 255 "./src-ag/PrintCode.ag" #-} rule282 = \ _addBang _addStrictGuard ((_argsIpps) :: PP_Docs) name_ -> {-# LINE 255 "./src-ag/PrintCode.ag" #-} _addStrictGuard (name_ >#< hv_sp (map _addBang _argsIpps)) {-# LINE 2629 "dist/build/PrintCode.hs"#-} {-# INLINE rule283 #-} rule283 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule284 #-} rule284 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule285 #-} rule285 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile {-# NOINLINE sem_Lhs_Unwrap #-} sem_Lhs_Unwrap :: (String) -> T_Lhs -> T_Lhs sem_Lhs_Unwrap !arg_name_ arg_sub_ = T_Lhs (return st32) where {-# NOINLINE st32 #-} !st32 = let v31 :: T_Lhs_v31 v31 = \ !(T_Lhs_vIn31 _lhsIisDeclOfLet _lhsInested _lhsIoptions _lhsIoutputfile) -> ( let _subX32 = Control.Monad.Identity.runIdentity (attach_T_Lhs (arg_sub_)) (T_Lhs_vOut31 _subIpp) = inv_Lhs_s32 _subX32 (T_Lhs_vIn31 _subOisDeclOfLet _subOnested _subOoptions _subOoutputfile) _lhsOpp :: PP_Doc _lhsOpp = rule286 _subIpp arg_name_ _subOisDeclOfLet = rule287 _lhsIisDeclOfLet _subOnested = rule288 _lhsInested _subOoptions = rule289 _lhsIoptions _subOoutputfile = rule290 _lhsIoutputfile !__result_ = T_Lhs_vOut31 _lhsOpp in __result_ ) in C_Lhs_s32 v31 {-# INLINE rule286 #-} {-# LINE 256 "./src-ag/PrintCode.ag" #-} rule286 = \ ((_subIpp) :: PP_Doc) name_ -> {-# LINE 256 "./src-ag/PrintCode.ag" #-} pp_parens (name_ >#< _subIpp) {-# LINE 2662 "dist/build/PrintCode.hs"#-} {-# INLINE rule287 #-} rule287 = \ ((_lhsIisDeclOfLet) :: Bool) -> _lhsIisDeclOfLet {-# INLINE rule288 #-} rule288 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule289 #-} rule289 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule290 #-} rule290 = \ ((_lhsIoutputfile) :: String) -> _lhsIoutputfile -- NamedType --------------------------------------------------- -- wrapper data Inh_NamedType = Inh_NamedType { nested_Inh_NamedType :: !(Bool) } data Syn_NamedType = Syn_NamedType { pp_Syn_NamedType :: !(PP_Doc) } {-# INLINABLE wrap_NamedType #-} wrap_NamedType :: T_NamedType -> Inh_NamedType -> (Syn_NamedType ) wrap_NamedType !(T_NamedType act) !(Inh_NamedType _lhsInested) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_NamedType_vIn34 _lhsInested !(T_NamedType_vOut34 _lhsOpp) <- return (inv_NamedType_s35 sem arg) return (Syn_NamedType _lhsOpp) ) -- cata {-# INLINE sem_NamedType #-} sem_NamedType :: NamedType -> T_NamedType sem_NamedType ( Named !strict_ !name_ tp_ ) = sem_NamedType_Named strict_ name_ ( sem_Type tp_ ) -- semantic domain newtype T_NamedType = T_NamedType { attach_T_NamedType :: Identity (T_NamedType_s35 ) } newtype T_NamedType_s35 = C_NamedType_s35 { inv_NamedType_s35 :: (T_NamedType_v34 ) } data T_NamedType_s36 = C_NamedType_s36 type T_NamedType_v34 = (T_NamedType_vIn34 ) -> (T_NamedType_vOut34 ) data T_NamedType_vIn34 = T_NamedType_vIn34 (Bool) data T_NamedType_vOut34 = T_NamedType_vOut34 (PP_Doc) {-# NOINLINE sem_NamedType_Named #-} sem_NamedType_Named :: (Bool) -> (String) -> T_Type -> T_NamedType sem_NamedType_Named !arg_strict_ !arg_name_ arg_tp_ = T_NamedType (return st35) where {-# NOINLINE st35 #-} !st35 = let v34 :: T_NamedType_v34 v34 = \ !(T_NamedType_vIn34 _lhsInested) -> ( let _tpX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_tp_)) (T_Type_vOut49 _tpIpp _tpIprec) = inv_Type_s50 _tpX50 (T_Type_vIn49 _tpOnested) _lhsOpp :: PP_Doc _lhsOpp = rule291 _tpIpp arg_name_ arg_strict_ _tpOnested = rule292 _lhsInested !__result_ = T_NamedType_vOut34 _lhsOpp in __result_ ) in C_NamedType_s35 v34 {-# INLINE rule291 #-} {-# LINE 225 "./src-ag/PrintCode.ag" #-} rule291 = \ ((_tpIpp) :: PP_Doc) name_ strict_ -> {-# LINE 225 "./src-ag/PrintCode.ag" #-} if strict_ then name_ >#< "::" >#< "!" >|< pp_parens _tpIpp else name_ >#< "::" >#< _tpIpp {-# LINE 2728 "dist/build/PrintCode.hs"#-} {-# INLINE rule292 #-} rule292 = \ ((_lhsInested) :: Bool) -> _lhsInested -- NamedTypes -------------------------------------------------- -- wrapper data Inh_NamedTypes = Inh_NamedTypes { nested_Inh_NamedTypes :: !(Bool) } data Syn_NamedTypes = Syn_NamedTypes { pps_Syn_NamedTypes :: !(PP_Docs) } {-# INLINABLE wrap_NamedTypes #-} wrap_NamedTypes :: T_NamedTypes -> Inh_NamedTypes -> (Syn_NamedTypes ) wrap_NamedTypes !(T_NamedTypes act) !(Inh_NamedTypes _lhsInested) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_NamedTypes_vIn37 _lhsInested !(T_NamedTypes_vOut37 _lhsOpps) <- return (inv_NamedTypes_s38 sem arg) return (Syn_NamedTypes _lhsOpps) ) -- cata {-# NOINLINE sem_NamedTypes #-} sem_NamedTypes :: NamedTypes -> T_NamedTypes sem_NamedTypes list = Prelude.foldr sem_NamedTypes_Cons sem_NamedTypes_Nil (Prelude.map sem_NamedType list) -- semantic domain newtype T_NamedTypes = T_NamedTypes { attach_T_NamedTypes :: Identity (T_NamedTypes_s38 ) } newtype T_NamedTypes_s38 = C_NamedTypes_s38 { inv_NamedTypes_s38 :: (T_NamedTypes_v37 ) } data T_NamedTypes_s39 = C_NamedTypes_s39 type T_NamedTypes_v37 = (T_NamedTypes_vIn37 ) -> (T_NamedTypes_vOut37 ) data T_NamedTypes_vIn37 = T_NamedTypes_vIn37 (Bool) data T_NamedTypes_vOut37 = T_NamedTypes_vOut37 (PP_Docs) {-# NOINLINE sem_NamedTypes_Cons #-} sem_NamedTypes_Cons :: T_NamedType -> T_NamedTypes -> T_NamedTypes sem_NamedTypes_Cons arg_hd_ arg_tl_ = T_NamedTypes (return st38) where {-# NOINLINE st38 #-} !st38 = let v37 :: T_NamedTypes_v37 v37 = \ !(T_NamedTypes_vIn37 _lhsInested) -> ( let _hdX35 = Control.Monad.Identity.runIdentity (attach_T_NamedType (arg_hd_)) _tlX38 = Control.Monad.Identity.runIdentity (attach_T_NamedTypes (arg_tl_)) (T_NamedType_vOut34 _hdIpp) = inv_NamedType_s35 _hdX35 (T_NamedType_vIn34 _hdOnested) (T_NamedTypes_vOut37 _tlIpps) = inv_NamedTypes_s38 _tlX38 (T_NamedTypes_vIn37 _tlOnested) _lhsOpps :: PP_Docs _lhsOpps = rule293 _hdIpp _tlIpps _hdOnested = rule294 _lhsInested _tlOnested = rule295 _lhsInested !__result_ = T_NamedTypes_vOut37 _lhsOpps in __result_ ) in C_NamedTypes_s38 v37 {-# INLINE rule293 #-} {-# LINE 80 "./src-ag/PrintCode.ag" #-} rule293 = \ ((_hdIpp) :: PP_Doc) ((_tlIpps) :: PP_Docs) -> {-# LINE 80 "./src-ag/PrintCode.ag" #-} _hdIpp : _tlIpps {-# LINE 2786 "dist/build/PrintCode.hs"#-} {-# INLINE rule294 #-} rule294 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule295 #-} rule295 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# NOINLINE sem_NamedTypes_Nil #-} sem_NamedTypes_Nil :: T_NamedTypes sem_NamedTypes_Nil = T_NamedTypes (return st38) where {-# NOINLINE st38 #-} !st38 = let v37 :: T_NamedTypes_v37 v37 = \ !(T_NamedTypes_vIn37 _lhsInested) -> ( let _lhsOpps :: PP_Docs _lhsOpps = rule296 () !__result_ = T_NamedTypes_vOut37 _lhsOpps in __result_ ) in C_NamedTypes_s38 v37 {-# INLINE rule296 #-} {-# LINE 81 "./src-ag/PrintCode.ag" #-} rule296 = \ (_ :: ()) -> {-# LINE 81 "./src-ag/PrintCode.ag" #-} [] {-# LINE 2810 "dist/build/PrintCode.hs"#-} -- Pattern ----------------------------------------------------- -- wrapper data Inh_Pattern = Inh_Pattern { belowIrrefutable_Inh_Pattern :: !(Bool), isDeclOfLet_Inh_Pattern :: !(Bool), options_Inh_Pattern :: !(Options) } data Syn_Pattern = Syn_Pattern { copy_Syn_Pattern :: !(Pattern), isUnderscore_Syn_Pattern :: !(Bool), pp_Syn_Pattern :: !(PP_Doc), pp'_Syn_Pattern :: !(PP_Doc), strictVars_Syn_Pattern :: !([PP_Doc]) } {-# INLINABLE wrap_Pattern #-} wrap_Pattern :: T_Pattern -> Inh_Pattern -> (Syn_Pattern ) wrap_Pattern !(T_Pattern act) !(Inh_Pattern _lhsIbelowIrrefutable _lhsIisDeclOfLet _lhsIoptions) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Pattern_vIn40 _lhsIbelowIrrefutable _lhsIisDeclOfLet _lhsIoptions !(T_Pattern_vOut40 _lhsOcopy _lhsOisUnderscore _lhsOpp _lhsOpp' _lhsOstrictVars) <- return (inv_Pattern_s41 sem arg) return (Syn_Pattern _lhsOcopy _lhsOisUnderscore _lhsOpp _lhsOpp' _lhsOstrictVars) ) -- cata {-# NOINLINE sem_Pattern #-} sem_Pattern :: Pattern -> T_Pattern sem_Pattern ( Constr !name_ pats_ ) = sem_Pattern_Constr name_ ( sem_Patterns pats_ ) sem_Pattern ( Product !pos_ pats_ ) = sem_Pattern_Product pos_ ( sem_Patterns pats_ ) sem_Pattern ( Alias !field_ !attr_ pat_ ) = sem_Pattern_Alias field_ attr_ ( sem_Pattern pat_ ) sem_Pattern ( Irrefutable pat_ ) = sem_Pattern_Irrefutable ( sem_Pattern pat_ ) sem_Pattern ( Underscore !pos_ ) = sem_Pattern_Underscore pos_ -- semantic domain newtype T_Pattern = T_Pattern { attach_T_Pattern :: Identity (T_Pattern_s41 ) } newtype T_Pattern_s41 = C_Pattern_s41 { inv_Pattern_s41 :: (T_Pattern_v40 ) } data T_Pattern_s42 = C_Pattern_s42 type T_Pattern_v40 = (T_Pattern_vIn40 ) -> (T_Pattern_vOut40 ) data T_Pattern_vIn40 = T_Pattern_vIn40 (Bool) (Bool) (Options) data T_Pattern_vOut40 = T_Pattern_vOut40 (Pattern) (Bool) (PP_Doc) (PP_Doc) ([PP_Doc]) {-# NOINLINE sem_Pattern_Constr #-} sem_Pattern_Constr :: (ConstructorIdent) -> T_Patterns -> T_Pattern sem_Pattern_Constr !arg_name_ arg_pats_ = T_Pattern (return st41) where {-# NOINLINE st41 #-} !st41 = let v40 :: T_Pattern_v40 v40 = \ !(T_Pattern_vIn40 _lhsIbelowIrrefutable _lhsIisDeclOfLet _lhsIoptions) -> ( let _patsX44 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) (T_Patterns_vOut43 _patsIcopy _patsIpps _patsIpps' _patsIstrictVars) = inv_Patterns_s44 _patsX44 (T_Patterns_vIn43 _patsObelowIrrefutable _patsOisDeclOfLet _patsOoptions) _addBang = rule297 _lhsIbelowIrrefutable _lhsIisDeclOfLet _lhsIoptions _lhsOpp :: PP_Doc _lhsOpp = rule298 _addBang _patsIpps arg_name_ _lhsOisUnderscore :: Bool _lhsOisUnderscore = rule299 () _lhsOpp' :: PP_Doc _lhsOpp' = rule300 _patsIpps' arg_name_ _lhsOstrictVars :: [PP_Doc] _lhsOstrictVars = rule301 _patsIstrictVars _copy = rule302 _patsIcopy arg_name_ _lhsOcopy :: Pattern _lhsOcopy = rule303 _copy _patsObelowIrrefutable = rule304 _lhsIbelowIrrefutable _patsOisDeclOfLet = rule305 _lhsIisDeclOfLet _patsOoptions = rule306 _lhsIoptions !__result_ = T_Pattern_vOut40 _lhsOcopy _lhsOisUnderscore _lhsOpp _lhsOpp' _lhsOstrictVars in __result_ ) in C_Pattern_s41 v40 {-# INLINE rule297 #-} {-# LINE 353 "./src-ag/PrintCode.ag" #-} rule297 = \ ((_lhsIbelowIrrefutable) :: Bool) ((_lhsIisDeclOfLet) :: Bool) ((_lhsIoptions) :: Options) -> {-# LINE 353 "./src-ag/PrintCode.ag" #-} if bangpats _lhsIoptions && not _lhsIisDeclOfLet && not _lhsIbelowIrrefutable then \p -> "!" >|< p else id {-# LINE 2880 "dist/build/PrintCode.hs"#-} {-# INLINE rule298 #-} {-# LINE 358 "./src-ag/PrintCode.ag" #-} rule298 = \ _addBang ((_patsIpps) :: [PP_Doc]) name_ -> {-# LINE 358 "./src-ag/PrintCode.ag" #-} _addBang $ pp_parens $ name_ >#< hv_sp _patsIpps {-# LINE 2886 "dist/build/PrintCode.hs"#-} {-# INLINE rule299 #-} {-# LINE 369 "./src-ag/PrintCode.ag" #-} rule299 = \ (_ :: ()) -> {-# LINE 369 "./src-ag/PrintCode.ag" #-} False {-# LINE 2892 "dist/build/PrintCode.hs"#-} {-# INLINE rule300 #-} {-# LINE 392 "./src-ag/PrintCode.ag" #-} rule300 = \ ((_patsIpps') :: [PP_Doc]) name_ -> {-# LINE 392 "./src-ag/PrintCode.ag" #-} pp_parens $ name_ >#< hv_sp (map pp_parens _patsIpps') {-# LINE 2898 "dist/build/PrintCode.hs"#-} {-# INLINE rule301 #-} rule301 = \ ((_patsIstrictVars) :: [PP_Doc]) -> _patsIstrictVars {-# INLINE rule302 #-} rule302 = \ ((_patsIcopy) :: Patterns) name_ -> Constr name_ _patsIcopy {-# INLINE rule303 #-} rule303 = \ _copy -> _copy {-# INLINE rule304 #-} rule304 = \ ((_lhsIbelowIrrefutable) :: Bool) -> _lhsIbelowIrrefutable {-# INLINE rule305 #-} rule305 = \ ((_lhsIisDeclOfLet) :: Bool) -> _lhsIisDeclOfLet {-# INLINE rule306 #-} rule306 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Pattern_Product #-} sem_Pattern_Product :: (Pos) -> T_Patterns -> T_Pattern sem_Pattern_Product !arg_pos_ arg_pats_ = T_Pattern (return st41) where {-# NOINLINE st41 #-} !st41 = let v40 :: T_Pattern_v40 v40 = \ !(T_Pattern_vIn40 _lhsIbelowIrrefutable _lhsIisDeclOfLet _lhsIoptions) -> ( let _patsX44 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) (T_Patterns_vOut43 _patsIcopy _patsIpps _patsIpps' _patsIstrictVars) = inv_Patterns_s44 _patsX44 (T_Patterns_vIn43 _patsObelowIrrefutable _patsOisDeclOfLet _patsOoptions) _addBang = rule307 _lhsIbelowIrrefutable _lhsIisDeclOfLet _lhsIoptions _lhsOpp :: PP_Doc _lhsOpp = rule308 _addBang _patsIpps _lhsOisUnderscore :: Bool _lhsOisUnderscore = rule309 () _lhsOpp' :: PP_Doc _lhsOpp' = rule310 _patsIpps' _lhsOstrictVars :: [PP_Doc] _lhsOstrictVars = rule311 _patsIstrictVars _copy = rule312 _patsIcopy arg_pos_ _lhsOcopy :: Pattern _lhsOcopy = rule313 _copy _patsObelowIrrefutable = rule314 _lhsIbelowIrrefutable _patsOisDeclOfLet = rule315 _lhsIisDeclOfLet _patsOoptions = rule316 _lhsIoptions !__result_ = T_Pattern_vOut40 _lhsOcopy _lhsOisUnderscore _lhsOpp _lhsOpp' _lhsOstrictVars in __result_ ) in C_Pattern_s41 v40 {-# INLINE rule307 #-} {-# LINE 353 "./src-ag/PrintCode.ag" #-} rule307 = \ ((_lhsIbelowIrrefutable) :: Bool) ((_lhsIisDeclOfLet) :: Bool) ((_lhsIoptions) :: Options) -> {-# LINE 353 "./src-ag/PrintCode.ag" #-} if bangpats _lhsIoptions && not _lhsIisDeclOfLet && not _lhsIbelowIrrefutable then \p -> "!" >|< p else id {-# LINE 2951 "dist/build/PrintCode.hs"#-} {-# INLINE rule308 #-} {-# LINE 359 "./src-ag/PrintCode.ag" #-} rule308 = \ _addBang ((_patsIpps) :: [PP_Doc]) -> {-# LINE 359 "./src-ag/PrintCode.ag" #-} _addBang $ pp_block "(" ")" "," _patsIpps {-# LINE 2957 "dist/build/PrintCode.hs"#-} {-# INLINE rule309 #-} {-# LINE 370 "./src-ag/PrintCode.ag" #-} rule309 = \ (_ :: ()) -> {-# LINE 370 "./src-ag/PrintCode.ag" #-} False {-# LINE 2963 "dist/build/PrintCode.hs"#-} {-# INLINE rule310 #-} {-# LINE 393 "./src-ag/PrintCode.ag" #-} rule310 = \ ((_patsIpps') :: [PP_Doc]) -> {-# LINE 393 "./src-ag/PrintCode.ag" #-} pp_block "(" ")" "," _patsIpps' {-# LINE 2969 "dist/build/PrintCode.hs"#-} {-# INLINE rule311 #-} rule311 = \ ((_patsIstrictVars) :: [PP_Doc]) -> _patsIstrictVars {-# INLINE rule312 #-} rule312 = \ ((_patsIcopy) :: Patterns) pos_ -> Product pos_ _patsIcopy {-# INLINE rule313 #-} rule313 = \ _copy -> _copy {-# INLINE rule314 #-} rule314 = \ ((_lhsIbelowIrrefutable) :: Bool) -> _lhsIbelowIrrefutable {-# INLINE rule315 #-} rule315 = \ ((_lhsIisDeclOfLet) :: Bool) -> _lhsIisDeclOfLet {-# INLINE rule316 #-} rule316 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Pattern_Alias #-} sem_Pattern_Alias :: (Identifier) -> (Identifier) -> T_Pattern -> T_Pattern sem_Pattern_Alias !arg_field_ !arg_attr_ arg_pat_ = T_Pattern (return st41) where {-# NOINLINE st41 #-} !st41 = let v40 :: T_Pattern_v40 v40 = \ !(T_Pattern_vIn40 _lhsIbelowIrrefutable _lhsIisDeclOfLet _lhsIoptions) -> ( let _patX41 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) (T_Pattern_vOut40 _patIcopy _patIisUnderscore _patIpp _patIpp' _patIstrictVars) = inv_Pattern_s41 _patX41 (T_Pattern_vIn40 _patObelowIrrefutable _patOisDeclOfLet _patOoptions) _strictVar = rule317 _lhsIisDeclOfLet _lhsIoptions _ppVar _strictPatVars = rule318 _lhsIisDeclOfLet _lhsIoptions _patIstrictVars _lhsOstrictVars :: [PP_Doc] _lhsOstrictVars = rule319 _strictPatVars _strictVar _addBang = rule320 _lhsIbelowIrrefutable _lhsIisDeclOfLet _lhsIoptions _ppVar = rule321 arg_attr_ arg_field_ _ppVarBang = rule322 _addBang _ppVar _lhsOpp :: PP_Doc _lhsOpp = rule323 _patIisUnderscore _patIpp _ppVarBang _lhsOisUnderscore :: Bool _lhsOisUnderscore = rule324 () _lhsOpp' :: PP_Doc _lhsOpp' = rule325 _patIpp' arg_attr_ arg_field_ _copy = rule326 _patIcopy arg_attr_ arg_field_ _lhsOcopy :: Pattern _lhsOcopy = rule327 _copy _patObelowIrrefutable = rule328 _lhsIbelowIrrefutable _patOisDeclOfLet = rule329 _lhsIisDeclOfLet _patOoptions = rule330 _lhsIoptions !__result_ = T_Pattern_vOut40 _lhsOcopy _lhsOisUnderscore _lhsOpp _lhsOpp' _lhsOstrictVars in __result_ ) in C_Pattern_s41 v40 {-# INLINE rule317 #-} {-# LINE 331 "./src-ag/PrintCode.ag" #-} rule317 = \ ((_lhsIisDeclOfLet) :: Bool) ((_lhsIoptions) :: Options) _ppVar -> {-# LINE 331 "./src-ag/PrintCode.ag" #-} if strictCases _lhsIoptions && not _lhsIisDeclOfLet then [_ppVar ] else [] {-# LINE 3026 "dist/build/PrintCode.hs"#-} {-# INLINE rule318 #-} {-# LINE 335 "./src-ag/PrintCode.ag" #-} rule318 = \ ((_lhsIisDeclOfLet) :: Bool) ((_lhsIoptions) :: Options) ((_patIstrictVars) :: [PP_Doc]) -> {-# LINE 335 "./src-ag/PrintCode.ag" #-} if stricterCases _lhsIoptions && not _lhsIisDeclOfLet then _patIstrictVars else [] {-# LINE 3034 "dist/build/PrintCode.hs"#-} {-# INLINE rule319 #-} {-# LINE 339 "./src-ag/PrintCode.ag" #-} rule319 = \ _strictPatVars _strictVar -> {-# LINE 339 "./src-ag/PrintCode.ag" #-} _strictVar ++ _strictPatVars {-# LINE 3040 "dist/build/PrintCode.hs"#-} {-# INLINE rule320 #-} {-# LINE 353 "./src-ag/PrintCode.ag" #-} rule320 = \ ((_lhsIbelowIrrefutable) :: Bool) ((_lhsIisDeclOfLet) :: Bool) ((_lhsIoptions) :: Options) -> {-# LINE 353 "./src-ag/PrintCode.ag" #-} if bangpats _lhsIoptions && not _lhsIisDeclOfLet && not _lhsIbelowIrrefutable then \p -> "!" >|< p else id {-# LINE 3048 "dist/build/PrintCode.hs"#-} {-# INLINE rule321 #-} {-# LINE 360 "./src-ag/PrintCode.ag" #-} rule321 = \ attr_ field_ -> {-# LINE 360 "./src-ag/PrintCode.ag" #-} pp (attrname False field_ attr_) {-# LINE 3054 "dist/build/PrintCode.hs"#-} {-# INLINE rule322 #-} {-# LINE 361 "./src-ag/PrintCode.ag" #-} rule322 = \ _addBang _ppVar -> {-# LINE 361 "./src-ag/PrintCode.ag" #-} _addBang $ _ppVar {-# LINE 3060 "dist/build/PrintCode.hs"#-} {-# INLINE rule323 #-} {-# LINE 362 "./src-ag/PrintCode.ag" #-} rule323 = \ ((_patIisUnderscore) :: Bool) ((_patIpp) :: PP_Doc) _ppVarBang -> {-# LINE 362 "./src-ag/PrintCode.ag" #-} if _patIisUnderscore then _ppVarBang else _ppVarBang >|< "@" >|< _patIpp {-# LINE 3068 "dist/build/PrintCode.hs"#-} {-# INLINE rule324 #-} {-# LINE 371 "./src-ag/PrintCode.ag" #-} rule324 = \ (_ :: ()) -> {-# LINE 371 "./src-ag/PrintCode.ag" #-} False {-# LINE 3074 "dist/build/PrintCode.hs"#-} {-# INLINE rule325 #-} {-# LINE 394 "./src-ag/PrintCode.ag" #-} rule325 = \ ((_patIpp') :: PP_Doc) attr_ field_ -> {-# LINE 394 "./src-ag/PrintCode.ag" #-} let attribute | field_ == _LOC || field_ == nullIdent = locname' attr_ | otherwise = attrname False field_ attr_ in attribute >|< "@" >|< _patIpp' {-# LINE 3082 "dist/build/PrintCode.hs"#-} {-# INLINE rule326 #-} rule326 = \ ((_patIcopy) :: Pattern) attr_ field_ -> Alias field_ attr_ _patIcopy {-# INLINE rule327 #-} rule327 = \ _copy -> _copy {-# INLINE rule328 #-} rule328 = \ ((_lhsIbelowIrrefutable) :: Bool) -> _lhsIbelowIrrefutable {-# INLINE rule329 #-} rule329 = \ ((_lhsIisDeclOfLet) :: Bool) -> _lhsIisDeclOfLet {-# INLINE rule330 #-} rule330 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Pattern_Irrefutable #-} sem_Pattern_Irrefutable :: T_Pattern -> T_Pattern sem_Pattern_Irrefutable arg_pat_ = T_Pattern (return st41) where {-# NOINLINE st41 #-} !st41 = let v40 :: T_Pattern_v40 v40 = \ !(T_Pattern_vIn40 _lhsIbelowIrrefutable _lhsIisDeclOfLet _lhsIoptions) -> ( let _patX41 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) (T_Pattern_vOut40 _patIcopy _patIisUnderscore _patIpp _patIpp' _patIstrictVars) = inv_Pattern_s41 _patX41 (T_Pattern_vIn40 _patObelowIrrefutable _patOisDeclOfLet _patOoptions) _lhsOstrictVars :: [PP_Doc] _lhsOstrictVars = rule331 () _lhsOpp :: PP_Doc _lhsOpp = rule332 _patIpp _patObelowIrrefutable = rule333 () _lhsOpp' :: PP_Doc _lhsOpp' = rule334 _patIpp _copy = rule335 _patIcopy _lhsOcopy :: Pattern _lhsOcopy = rule336 _copy _lhsOisUnderscore :: Bool _lhsOisUnderscore = rule337 _patIisUnderscore _patOisDeclOfLet = rule338 _lhsIisDeclOfLet _patOoptions = rule339 _lhsIoptions !__result_ = T_Pattern_vOut40 _lhsOcopy _lhsOisUnderscore _lhsOpp _lhsOpp' _lhsOstrictVars in __result_ ) in C_Pattern_s41 v40 {-# INLINE rule331 #-} {-# LINE 341 "./src-ag/PrintCode.ag" #-} rule331 = \ (_ :: ()) -> {-# LINE 341 "./src-ag/PrintCode.ag" #-} [] {-# LINE 3129 "dist/build/PrintCode.hs"#-} {-# INLINE rule332 #-} {-# LINE 365 "./src-ag/PrintCode.ag" #-} rule332 = \ ((_patIpp) :: PP_Doc) -> {-# LINE 365 "./src-ag/PrintCode.ag" #-} text "~" >|< pp_parens _patIpp {-# LINE 3135 "dist/build/PrintCode.hs"#-} {-# INLINE rule333 #-} {-# LINE 377 "./src-ag/PrintCode.ag" #-} rule333 = \ (_ :: ()) -> {-# LINE 377 "./src-ag/PrintCode.ag" #-} True {-# LINE 3141 "dist/build/PrintCode.hs"#-} {-# INLINE rule334 #-} {-# LINE 397 "./src-ag/PrintCode.ag" #-} rule334 = \ ((_patIpp) :: PP_Doc) -> {-# LINE 397 "./src-ag/PrintCode.ag" #-} text "~" >|< pp_parens _patIpp {-# LINE 3147 "dist/build/PrintCode.hs"#-} {-# INLINE rule335 #-} rule335 = \ ((_patIcopy) :: Pattern) -> Irrefutable _patIcopy {-# INLINE rule336 #-} rule336 = \ _copy -> _copy {-# INLINE rule337 #-} rule337 = \ ((_patIisUnderscore) :: Bool) -> _patIisUnderscore {-# INLINE rule338 #-} rule338 = \ ((_lhsIisDeclOfLet) :: Bool) -> _lhsIisDeclOfLet {-# INLINE rule339 #-} rule339 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Pattern_Underscore #-} sem_Pattern_Underscore :: (Pos) -> T_Pattern sem_Pattern_Underscore !arg_pos_ = T_Pattern (return st41) where {-# NOINLINE st41 #-} !st41 = let v40 :: T_Pattern_v40 v40 = \ !(T_Pattern_vIn40 _lhsIbelowIrrefutable _lhsIisDeclOfLet _lhsIoptions) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule340 () _lhsOisUnderscore :: Bool _lhsOisUnderscore = rule341 () _lhsOpp' :: PP_Doc _lhsOpp' = rule342 () _lhsOstrictVars :: [PP_Doc] _lhsOstrictVars = rule343 () _copy = rule344 arg_pos_ _lhsOcopy :: Pattern _lhsOcopy = rule345 _copy !__result_ = T_Pattern_vOut40 _lhsOcopy _lhsOisUnderscore _lhsOpp _lhsOpp' _lhsOstrictVars in __result_ ) in C_Pattern_s41 v40 {-# INLINE rule340 #-} {-# LINE 366 "./src-ag/PrintCode.ag" #-} rule340 = \ (_ :: ()) -> {-# LINE 366 "./src-ag/PrintCode.ag" #-} text "_" {-# LINE 3189 "dist/build/PrintCode.hs"#-} {-# INLINE rule341 #-} {-# LINE 372 "./src-ag/PrintCode.ag" #-} rule341 = \ (_ :: ()) -> {-# LINE 372 "./src-ag/PrintCode.ag" #-} True {-# LINE 3195 "dist/build/PrintCode.hs"#-} {-# INLINE rule342 #-} {-# LINE 398 "./src-ag/PrintCode.ag" #-} rule342 = \ (_ :: ()) -> {-# LINE 398 "./src-ag/PrintCode.ag" #-} text "_" {-# LINE 3201 "dist/build/PrintCode.hs"#-} {-# INLINE rule343 #-} rule343 = \ (_ :: ()) -> [] {-# INLINE rule344 #-} rule344 = \ pos_ -> Underscore pos_ {-# INLINE rule345 #-} rule345 = \ _copy -> _copy -- Patterns ---------------------------------------------------- -- wrapper data Inh_Patterns = Inh_Patterns { belowIrrefutable_Inh_Patterns :: !(Bool), isDeclOfLet_Inh_Patterns :: !(Bool), options_Inh_Patterns :: !(Options) } data Syn_Patterns = Syn_Patterns { copy_Syn_Patterns :: !(Patterns), pps_Syn_Patterns :: !([PP_Doc]), pps'_Syn_Patterns :: !([PP_Doc]), strictVars_Syn_Patterns :: !([PP_Doc]) } {-# INLINABLE wrap_Patterns #-} wrap_Patterns :: T_Patterns -> Inh_Patterns -> (Syn_Patterns ) wrap_Patterns !(T_Patterns act) !(Inh_Patterns _lhsIbelowIrrefutable _lhsIisDeclOfLet _lhsIoptions) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Patterns_vIn43 _lhsIbelowIrrefutable _lhsIisDeclOfLet _lhsIoptions !(T_Patterns_vOut43 _lhsOcopy _lhsOpps _lhsOpps' _lhsOstrictVars) <- return (inv_Patterns_s44 sem arg) return (Syn_Patterns _lhsOcopy _lhsOpps _lhsOpps' _lhsOstrictVars) ) -- cata {-# NOINLINE sem_Patterns #-} sem_Patterns :: Patterns -> T_Patterns sem_Patterns list = Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list) -- semantic domain newtype T_Patterns = T_Patterns { attach_T_Patterns :: Identity (T_Patterns_s44 ) } newtype T_Patterns_s44 = C_Patterns_s44 { inv_Patterns_s44 :: (T_Patterns_v43 ) } data T_Patterns_s45 = C_Patterns_s45 type T_Patterns_v43 = (T_Patterns_vIn43 ) -> (T_Patterns_vOut43 ) data T_Patterns_vIn43 = T_Patterns_vIn43 (Bool) (Bool) (Options) data T_Patterns_vOut43 = T_Patterns_vOut43 (Patterns) ([PP_Doc]) ([PP_Doc]) ([PP_Doc]) {-# NOINLINE sem_Patterns_Cons #-} sem_Patterns_Cons :: T_Pattern -> T_Patterns -> T_Patterns sem_Patterns_Cons arg_hd_ arg_tl_ = T_Patterns (return st44) where {-# NOINLINE st44 #-} !st44 = let v43 :: T_Patterns_v43 v43 = \ !(T_Patterns_vIn43 _lhsIbelowIrrefutable _lhsIisDeclOfLet _lhsIoptions) -> ( let _hdX41 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_hd_)) _tlX44 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_tl_)) (T_Pattern_vOut40 _hdIcopy _hdIisUnderscore _hdIpp _hdIpp' _hdIstrictVars) = inv_Pattern_s41 _hdX41 (T_Pattern_vIn40 _hdObelowIrrefutable _hdOisDeclOfLet _hdOoptions) (T_Patterns_vOut43 _tlIcopy _tlIpps _tlIpps' _tlIstrictVars) = inv_Patterns_s44 _tlX44 (T_Patterns_vIn43 _tlObelowIrrefutable _tlOisDeclOfLet _tlOoptions) _lhsOpps :: [PP_Doc] _lhsOpps = rule346 _hdIpp _tlIpps _lhsOpps' :: [PP_Doc] _lhsOpps' = rule347 _hdIpp' _tlIpps' _lhsOstrictVars :: [PP_Doc] _lhsOstrictVars = rule348 _hdIstrictVars _tlIstrictVars _copy = rule349 _hdIcopy _tlIcopy _lhsOcopy :: Patterns _lhsOcopy = rule350 _copy _hdObelowIrrefutable = rule351 _lhsIbelowIrrefutable _hdOisDeclOfLet = rule352 _lhsIisDeclOfLet _hdOoptions = rule353 _lhsIoptions _tlObelowIrrefutable = rule354 _lhsIbelowIrrefutable _tlOisDeclOfLet = rule355 _lhsIisDeclOfLet _tlOoptions = rule356 _lhsIoptions !__result_ = T_Patterns_vOut43 _lhsOcopy _lhsOpps _lhsOpps' _lhsOstrictVars in __result_ ) in C_Patterns_s44 v43 {-# INLINE rule346 #-} {-# LINE 348 "./src-ag/PrintCode.ag" #-} rule346 = \ ((_hdIpp) :: PP_Doc) ((_tlIpps) :: [PP_Doc]) -> {-# LINE 348 "./src-ag/PrintCode.ag" #-} _hdIpp : _tlIpps {-# LINE 3276 "dist/build/PrintCode.hs"#-} {-# INLINE rule347 #-} {-# LINE 388 "./src-ag/PrintCode.ag" #-} rule347 = \ ((_hdIpp') :: PP_Doc) ((_tlIpps') :: [PP_Doc]) -> {-# LINE 388 "./src-ag/PrintCode.ag" #-} _hdIpp' : _tlIpps' {-# LINE 3282 "dist/build/PrintCode.hs"#-} {-# INLINE rule348 #-} rule348 = \ ((_hdIstrictVars) :: [PP_Doc]) ((_tlIstrictVars) :: [PP_Doc]) -> _hdIstrictVars ++ _tlIstrictVars {-# INLINE rule349 #-} rule349 = \ ((_hdIcopy) :: Pattern) ((_tlIcopy) :: Patterns) -> (:) _hdIcopy _tlIcopy {-# INLINE rule350 #-} rule350 = \ _copy -> _copy {-# INLINE rule351 #-} rule351 = \ ((_lhsIbelowIrrefutable) :: Bool) -> _lhsIbelowIrrefutable {-# INLINE rule352 #-} rule352 = \ ((_lhsIisDeclOfLet) :: Bool) -> _lhsIisDeclOfLet {-# INLINE rule353 #-} rule353 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule354 #-} rule354 = \ ((_lhsIbelowIrrefutable) :: Bool) -> _lhsIbelowIrrefutable {-# INLINE rule355 #-} rule355 = \ ((_lhsIisDeclOfLet) :: Bool) -> _lhsIisDeclOfLet {-# INLINE rule356 #-} rule356 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Patterns_Nil #-} sem_Patterns_Nil :: T_Patterns sem_Patterns_Nil = T_Patterns (return st44) where {-# NOINLINE st44 #-} !st44 = let v43 :: T_Patterns_v43 v43 = \ !(T_Patterns_vIn43 _lhsIbelowIrrefutable _lhsIisDeclOfLet _lhsIoptions) -> ( let _lhsOpps :: [PP_Doc] _lhsOpps = rule357 () _lhsOpps' :: [PP_Doc] _lhsOpps' = rule358 () _lhsOstrictVars :: [PP_Doc] _lhsOstrictVars = rule359 () _copy = rule360 () _lhsOcopy :: Patterns _lhsOcopy = rule361 _copy !__result_ = T_Patterns_vOut43 _lhsOcopy _lhsOpps _lhsOpps' _lhsOstrictVars in __result_ ) in C_Patterns_s44 v43 {-# INLINE rule357 #-} {-# LINE 349 "./src-ag/PrintCode.ag" #-} rule357 = \ (_ :: ()) -> {-# LINE 349 "./src-ag/PrintCode.ag" #-} [] {-# LINE 3334 "dist/build/PrintCode.hs"#-} {-# INLINE rule358 #-} {-# LINE 389 "./src-ag/PrintCode.ag" #-} rule358 = \ (_ :: ()) -> {-# LINE 389 "./src-ag/PrintCode.ag" #-} [] {-# LINE 3340 "dist/build/PrintCode.hs"#-} {-# INLINE rule359 #-} rule359 = \ (_ :: ()) -> [] {-# INLINE rule360 #-} rule360 = \ (_ :: ()) -> [] {-# INLINE rule361 #-} rule361 = \ _copy -> _copy -- Program ----------------------------------------------------- -- wrapper data Inh_Program = Inh_Program { importBlocks_Inh_Program :: !(PP_Doc), mainBlocksDoc_Inh_Program :: !(PP_Doc), mainFile_Inh_Program :: !(String), mainName_Inh_Program :: !(String), moduleHeader_Inh_Program :: !(String -> String -> String -> Bool -> String), options_Inh_Program :: !(Options), optionsLine_Inh_Program :: !(String), pragmaBlocks_Inh_Program :: !(String), textBlockMap_Inh_Program :: !(Map BlockInfo PP_Doc), textBlocks_Inh_Program :: !(PP_Doc) } data Syn_Program = Syn_Program { genIO_Syn_Program :: !(IO ()), output_Syn_Program :: !(PP_Docs) } {-# INLINABLE wrap_Program #-} wrap_Program :: T_Program -> Inh_Program -> (Syn_Program ) wrap_Program !(T_Program act) !(Inh_Program _lhsIimportBlocks _lhsImainBlocksDoc _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsIoptions _lhsIoptionsLine _lhsIpragmaBlocks _lhsItextBlockMap _lhsItextBlocks) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Program_vIn46 _lhsIimportBlocks _lhsImainBlocksDoc _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsIoptions _lhsIoptionsLine _lhsIpragmaBlocks _lhsItextBlockMap _lhsItextBlocks !(T_Program_vOut46 _lhsOgenIO _lhsOoutput) <- return (inv_Program_s47 sem arg) return (Syn_Program _lhsOgenIO _lhsOoutput) ) -- cata {-# INLINE sem_Program #-} sem_Program :: Program -> T_Program sem_Program ( Program chunks_ !ordered_ ) = sem_Program_Program ( sem_Chunks chunks_ ) ordered_ -- semantic domain newtype T_Program = T_Program { attach_T_Program :: Identity (T_Program_s47 ) } newtype T_Program_s47 = C_Program_s47 { inv_Program_s47 :: (T_Program_v46 ) } data T_Program_s48 = C_Program_s48 type T_Program_v46 = (T_Program_vIn46 ) -> (T_Program_vOut46 ) data T_Program_vIn46 = T_Program_vIn46 (PP_Doc) (PP_Doc) (String) (String) (String -> String -> String -> Bool -> String) (Options) (String) (String) (Map BlockInfo PP_Doc) (PP_Doc) data T_Program_vOut46 = T_Program_vOut46 (IO ()) (PP_Docs) {-# NOINLINE sem_Program_Program #-} sem_Program_Program :: T_Chunks -> (Bool) -> T_Program sem_Program_Program arg_chunks_ !arg_ordered_ = T_Program (return st47) where {-# NOINLINE st47 #-} !st47 = let v46 :: T_Program_v46 v46 = \ !(T_Program_vIn46 _lhsIimportBlocks _lhsImainBlocksDoc _lhsImainFile _lhsImainName _lhsImoduleHeader _lhsIoptions _lhsIoptionsLine _lhsIpragmaBlocks _lhsItextBlockMap _lhsItextBlocks) -> ( let _chunksX11 = Control.Monad.Identity.runIdentity (attach_T_Chunks (arg_chunks_)) (T_Chunks_vOut10 _chunksIappendCommon _chunksIappendMain _chunksIgenSems _chunksIimports _chunksIpps) = inv_Chunks_s11 _chunksX11 (T_Chunks_vIn10 _chunksOimportBlocks _chunksOisDeclOfLet _chunksOmainFile _chunksOmainName _chunksOmoduleHeader _chunksOnested _chunksOoptions _chunksOoptionsLine _chunksOpragmaBlocks _chunksOtextBlockMap _chunksOtextBlocks) _options = rule362 _lhsIoptions arg_ordered_ _chunksOnested = rule363 _lhsIoptions _lhsOoutput :: PP_Docs _lhsOoutput = rule364 _chunksIpps _chunksOisDeclOfLet = rule365 () _mainModuleFile = rule366 _lhsImainFile _genMainModule = rule367 _chunksIappendMain _chunksIimports _lhsImainBlocksDoc _lhsImainName _lhsImoduleHeader _lhsIoptionsLine _lhsIpragmaBlocks _mainModuleFile _commonFile = rule368 _lhsImainFile _genCommonModule = rule369 _chunksIappendCommon _commonFile _lhsIimportBlocks _lhsImainName _lhsImoduleHeader _lhsIoptionsLine _lhsIpragmaBlocks _lhsItextBlocks _lhsOgenIO :: IO () _lhsOgenIO = rule370 _chunksIgenSems _genCommonModule _genMainModule _chunksOimportBlocks = rule371 _lhsIimportBlocks _chunksOmainFile = rule372 _lhsImainFile _chunksOmainName = rule373 _lhsImainName _chunksOmoduleHeader = rule374 _lhsImoduleHeader _chunksOoptions = rule375 _options _chunksOoptionsLine = rule376 _lhsIoptionsLine _chunksOpragmaBlocks = rule377 _lhsIpragmaBlocks _chunksOtextBlockMap = rule378 _lhsItextBlockMap _chunksOtextBlocks = rule379 _lhsItextBlocks !__result_ = T_Program_vOut46 _lhsOgenIO _lhsOoutput in __result_ ) in C_Program_s47 v46 {-# INLINE rule362 #-} {-# LINE 58 "./src-ag/PrintCode.ag" #-} rule362 = \ ((_lhsIoptions) :: Options) ordered_ -> {-# LINE 58 "./src-ag/PrintCode.ag" #-} _lhsIoptions { breadthFirst = breadthFirst _lhsIoptions && visit _lhsIoptions && cases _lhsIoptions && ordered_ } {-# LINE 3418 "dist/build/PrintCode.hs"#-} {-# INLINE rule363 #-} {-# LINE 61 "./src-ag/PrintCode.ag" #-} rule363 = \ ((_lhsIoptions) :: Options) -> {-# LINE 61 "./src-ag/PrintCode.ag" #-} nest _lhsIoptions {-# LINE 3424 "dist/build/PrintCode.hs"#-} {-# INLINE rule364 #-} {-# LINE 93 "./src-ag/PrintCode.ag" #-} rule364 = \ ((_chunksIpps) :: PP_Docs) -> {-# LINE 93 "./src-ag/PrintCode.ag" #-} _chunksIpps {-# LINE 3430 "dist/build/PrintCode.hs"#-} {-# INLINE rule365 #-} {-# LINE 412 "./src-ag/PrintCode.ag" #-} rule365 = \ (_ :: ()) -> {-# LINE 412 "./src-ag/PrintCode.ag" #-} False {-# LINE 3436 "dist/build/PrintCode.hs"#-} {-# INLINE rule366 #-} {-# LINE 446 "./src-ag/PrintCode.ag" #-} rule366 = \ ((_lhsImainFile) :: String) -> {-# LINE 446 "./src-ag/PrintCode.ag" #-} _lhsImainFile {-# LINE 3442 "dist/build/PrintCode.hs"#-} {-# INLINE rule367 #-} {-# LINE 448 "./src-ag/PrintCode.ag" #-} rule367 = \ ((_chunksIappendMain) :: [[PP_Doc]]) ((_chunksIimports) :: [String]) ((_lhsImainBlocksDoc) :: PP_Doc) ((_lhsImainName) :: String) ((_lhsImoduleHeader) :: String -> String -> String -> Bool -> String) ((_lhsIoptionsLine) :: String) ((_lhsIpragmaBlocks) :: String) _mainModuleFile -> {-# LINE 448 "./src-ag/PrintCode.ag" #-} writeModule _mainModuleFile ( [ pp $ _lhsIpragmaBlocks , pp $ _lhsIoptionsLine , pp $ _lhsImoduleHeader _lhsImainName "" "" False , pp $ ("import " ++ _lhsImainName ++ "_common\n") ] ++ map pp _chunksIimports ++ map vlist _chunksIappendMain ++ [_lhsImainBlocksDoc] ) {-# LINE 3457 "dist/build/PrintCode.hs"#-} {-# INLINE rule368 #-} {-# LINE 459 "./src-ag/PrintCode.ag" #-} rule368 = \ ((_lhsImainFile) :: String) -> {-# LINE 459 "./src-ag/PrintCode.ag" #-} replaceBaseName _lhsImainFile (takeBaseName _lhsImainFile ++ "_common") {-# LINE 3463 "dist/build/PrintCode.hs"#-} {-# INLINE rule369 #-} {-# LINE 461 "./src-ag/PrintCode.ag" #-} rule369 = \ ((_chunksIappendCommon) :: [[PP_Doc]]) _commonFile ((_lhsIimportBlocks) :: PP_Doc) ((_lhsImainName) :: String) ((_lhsImoduleHeader) :: String -> String -> String -> Bool -> String) ((_lhsIoptionsLine) :: String) ((_lhsIpragmaBlocks) :: String) ((_lhsItextBlocks) :: PP_Doc) -> {-# LINE 461 "./src-ag/PrintCode.ag" #-} writeModule _commonFile ( [ pp $ _lhsIpragmaBlocks , pp $ _lhsIoptionsLine , pp $ _lhsImoduleHeader _lhsImainName "_common" "" True , _lhsIimportBlocks , _lhsItextBlocks ] ++ map vlist _chunksIappendCommon ) {-# LINE 3477 "dist/build/PrintCode.hs"#-} {-# INLINE rule370 #-} {-# LINE 471 "./src-ag/PrintCode.ag" #-} rule370 = \ ((_chunksIgenSems) :: IO ()) _genCommonModule _genMainModule -> {-# LINE 471 "./src-ag/PrintCode.ag" #-} do _genMainModule _genCommonModule _chunksIgenSems {-# LINE 3485 "dist/build/PrintCode.hs"#-} {-# INLINE rule371 #-} rule371 = \ ((_lhsIimportBlocks) :: PP_Doc) -> _lhsIimportBlocks {-# INLINE rule372 #-} rule372 = \ ((_lhsImainFile) :: String) -> _lhsImainFile {-# INLINE rule373 #-} rule373 = \ ((_lhsImainName) :: String) -> _lhsImainName {-# INLINE rule374 #-} rule374 = \ ((_lhsImoduleHeader) :: String -> String -> String -> Bool -> String) -> _lhsImoduleHeader {-# INLINE rule375 #-} rule375 = \ _options -> _options {-# INLINE rule376 #-} rule376 = \ ((_lhsIoptionsLine) :: String) -> _lhsIoptionsLine {-# INLINE rule377 #-} rule377 = \ ((_lhsIpragmaBlocks) :: String) -> _lhsIpragmaBlocks {-# INLINE rule378 #-} rule378 = \ ((_lhsItextBlockMap) :: Map BlockInfo PP_Doc) -> _lhsItextBlockMap {-# INLINE rule379 #-} rule379 = \ ((_lhsItextBlocks) :: PP_Doc) -> _lhsItextBlocks -- Type -------------------------------------------------------- -- wrapper data Inh_Type = Inh_Type { nested_Inh_Type :: !(Bool) } data Syn_Type = Syn_Type { pp_Syn_Type :: !(PP_Doc), prec_Syn_Type :: !(Int) } {-# INLINABLE wrap_Type #-} wrap_Type :: T_Type -> Inh_Type -> (Syn_Type ) wrap_Type !(T_Type act) !(Inh_Type _lhsInested) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Type_vIn49 _lhsInested !(T_Type_vOut49 _lhsOpp _lhsOprec) <- return (inv_Type_s50 sem arg) return (Syn_Type _lhsOpp _lhsOprec) ) -- cata {-# NOINLINE sem_Type #-} sem_Type :: Type -> T_Type sem_Type ( Arr left_ right_ ) = sem_Type_Arr ( sem_Type left_ ) ( sem_Type right_ ) sem_Type ( CtxApp !left_ right_ ) = sem_Type_CtxApp left_ ( sem_Type right_ ) sem_Type ( QuantApp !left_ right_ ) = sem_Type_QuantApp left_ ( sem_Type right_ ) sem_Type ( TypeApp func_ args_ ) = sem_Type_TypeApp ( sem_Type func_ ) ( sem_Types args_ ) sem_Type ( TupleType tps_ ) = sem_Type_TupleType ( sem_Types tps_ ) sem_Type ( UnboxedTupleType tps_ ) = sem_Type_UnboxedTupleType ( sem_Types tps_ ) sem_Type ( List tp_ ) = sem_Type_List ( sem_Type tp_ ) sem_Type ( SimpleType !txt_ ) = sem_Type_SimpleType txt_ sem_Type ( NontermType !name_ !params_ !deforested_ ) = sem_Type_NontermType name_ params_ deforested_ sem_Type ( TMaybe tp_ ) = sem_Type_TMaybe ( sem_Type tp_ ) sem_Type ( TEither left_ right_ ) = sem_Type_TEither ( sem_Type left_ ) ( sem_Type right_ ) sem_Type ( TMap key_ value_ ) = sem_Type_TMap ( sem_Type key_ ) ( sem_Type value_ ) sem_Type ( TIntMap value_ ) = sem_Type_TIntMap ( sem_Type value_ ) -- semantic domain newtype T_Type = T_Type { attach_T_Type :: Identity (T_Type_s50 ) } newtype T_Type_s50 = C_Type_s50 { inv_Type_s50 :: (T_Type_v49 ) } data T_Type_s51 = C_Type_s51 type T_Type_v49 = (T_Type_vIn49 ) -> (T_Type_vOut49 ) data T_Type_vIn49 = T_Type_vIn49 (Bool) data T_Type_vOut49 = T_Type_vOut49 (PP_Doc) (Int) {-# NOINLINE sem_Type_Arr #-} sem_Type_Arr :: T_Type -> T_Type -> T_Type sem_Type_Arr arg_left_ arg_right_ = T_Type (return st50) where {-# NOINLINE st50 #-} !st50 = let v49 :: T_Type_v49 v49 = \ !(T_Type_vIn49 _lhsInested) -> ( let _leftX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_left_)) _rightX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_right_)) (T_Type_vOut49 _leftIpp _leftIprec) = inv_Type_s50 _leftX50 (T_Type_vIn49 _leftOnested) (T_Type_vOut49 _rightIpp _rightIprec) = inv_Type_s50 _rightX50 (T_Type_vIn49 _rightOnested) _lhsOprec :: Int _lhsOprec = rule380 () _lhsOpp :: PP_Doc _lhsOpp = rule381 _l _r _l = rule382 _leftIpp _leftIprec _r = rule383 _rightIpp _rightIprec _leftOnested = rule384 _lhsInested _rightOnested = rule385 _lhsInested !__result_ = T_Type_vOut49 _lhsOpp _lhsOprec in __result_ ) in C_Type_s50 v49 {-# INLINE rule380 #-} {-# LINE 259 "./src-ag/PrintCode.ag" #-} rule380 = \ (_ :: ()) -> {-# LINE 259 "./src-ag/PrintCode.ag" #-} 2 {-# LINE 3583 "dist/build/PrintCode.hs"#-} {-# INLINE rule381 #-} {-# LINE 260 "./src-ag/PrintCode.ag" #-} rule381 = \ _l _r -> {-# LINE 260 "./src-ag/PrintCode.ag" #-} _l >#< "->" >-< _r {-# LINE 3589 "dist/build/PrintCode.hs"#-} {-# INLINE rule382 #-} {-# LINE 261 "./src-ag/PrintCode.ag" #-} rule382 = \ ((_leftIpp) :: PP_Doc) ((_leftIprec) :: Int) -> {-# LINE 261 "./src-ag/PrintCode.ag" #-} if _leftIprec <= 2 then pp_parens _leftIpp else _leftIpp {-# LINE 3595 "dist/build/PrintCode.hs"#-} {-# INLINE rule383 #-} {-# LINE 262 "./src-ag/PrintCode.ag" #-} rule383 = \ ((_rightIpp) :: PP_Doc) ((_rightIprec) :: Int) -> {-# LINE 262 "./src-ag/PrintCode.ag" #-} if _rightIprec < 2 then pp_parens _rightIpp else _rightIpp {-# LINE 3601 "dist/build/PrintCode.hs"#-} {-# INLINE rule384 #-} rule384 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule385 #-} rule385 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# NOINLINE sem_Type_CtxApp #-} sem_Type_CtxApp :: ([(String, [String])]) -> T_Type -> T_Type sem_Type_CtxApp !arg_left_ arg_right_ = T_Type (return st50) where {-# NOINLINE st50 #-} !st50 = let v49 :: T_Type_v49 v49 = \ !(T_Type_vIn49 _lhsInested) -> ( let _rightX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_right_)) (T_Type_vOut49 _rightIpp _rightIprec) = inv_Type_s50 _rightX50 (T_Type_vIn49 _rightOnested) _lhsOpp :: PP_Doc _lhsOpp = rule386 _rightIpp arg_left_ _lhsOprec :: Int _lhsOprec = rule387 _rightIprec _rightOnested = rule388 _lhsInested !__result_ = T_Type_vOut49 _lhsOpp _lhsOprec in __result_ ) in C_Type_s50 v49 {-# INLINE rule386 #-} {-# LINE 268 "./src-ag/PrintCode.ag" #-} rule386 = \ ((_rightIpp) :: PP_Doc) left_ -> {-# LINE 268 "./src-ag/PrintCode.ag" #-} (pp_block "(" ")" "," $ map (\(n,ns) -> hv_sp $ map pp (n:ns)) left_) >#< "=>" >#< _rightIpp {-# LINE 3630 "dist/build/PrintCode.hs"#-} {-# INLINE rule387 #-} rule387 = \ ((_rightIprec) :: Int) -> _rightIprec {-# INLINE rule388 #-} rule388 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# NOINLINE sem_Type_QuantApp #-} sem_Type_QuantApp :: (String) -> T_Type -> T_Type sem_Type_QuantApp !arg_left_ arg_right_ = T_Type (return st50) where {-# NOINLINE st50 #-} !st50 = let v49 :: T_Type_v49 v49 = \ !(T_Type_vIn49 _lhsInested) -> ( let _rightX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_right_)) (T_Type_vOut49 _rightIpp _rightIprec) = inv_Type_s50 _rightX50 (T_Type_vIn49 _rightOnested) _lhsOpp :: PP_Doc _lhsOpp = rule389 _rightIpp arg_left_ _lhsOprec :: Int _lhsOprec = rule390 _rightIprec _rightOnested = rule391 _lhsInested !__result_ = T_Type_vOut49 _lhsOpp _lhsOprec in __result_ ) in C_Type_s50 v49 {-# INLINE rule389 #-} {-# LINE 270 "./src-ag/PrintCode.ag" #-} rule389 = \ ((_rightIpp) :: PP_Doc) left_ -> {-# LINE 270 "./src-ag/PrintCode.ag" #-} left_ >#< _rightIpp {-# LINE 3659 "dist/build/PrintCode.hs"#-} {-# INLINE rule390 #-} rule390 = \ ((_rightIprec) :: Int) -> _rightIprec {-# INLINE rule391 #-} rule391 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# NOINLINE sem_Type_TypeApp #-} sem_Type_TypeApp :: T_Type -> T_Types -> T_Type sem_Type_TypeApp arg_func_ arg_args_ = T_Type (return st50) where {-# NOINLINE st50 #-} !st50 = let v49 :: T_Type_v49 v49 = \ !(T_Type_vIn49 _lhsInested) -> ( let _funcX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_func_)) _argsX53 = Control.Monad.Identity.runIdentity (attach_T_Types (arg_args_)) (T_Type_vOut49 _funcIpp _funcIprec) = inv_Type_s50 _funcX50 (T_Type_vIn49 _funcOnested) (T_Types_vOut52 _argsIpps) = inv_Types_s53 _argsX53 (T_Types_vIn52 _argsOnested) _lhsOpp :: PP_Doc _lhsOpp = rule392 _argsIpps _funcIpp _lhsOprec :: Int _lhsOprec = rule393 _funcIprec _funcOnested = rule394 _lhsInested _argsOnested = rule395 _lhsInested !__result_ = T_Type_vOut49 _lhsOpp _lhsOprec in __result_ ) in C_Type_s50 v49 {-# INLINE rule392 #-} {-# LINE 265 "./src-ag/PrintCode.ag" #-} rule392 = \ ((_argsIpps) :: PP_Docs) ((_funcIpp) :: PP_Doc) -> {-# LINE 265 "./src-ag/PrintCode.ag" #-} hv_sp (_funcIpp : _argsIpps) {-# LINE 3691 "dist/build/PrintCode.hs"#-} {-# INLINE rule393 #-} rule393 = \ ((_funcIprec) :: Int) -> _funcIprec {-# INLINE rule394 #-} rule394 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule395 #-} rule395 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# NOINLINE sem_Type_TupleType #-} sem_Type_TupleType :: T_Types -> T_Type sem_Type_TupleType arg_tps_ = T_Type (return st50) where {-# NOINLINE st50 #-} !st50 = let v49 :: T_Type_v49 v49 = \ !(T_Type_vIn49 _lhsInested) -> ( let _tpsX53 = Control.Monad.Identity.runIdentity (attach_T_Types (arg_tps_)) (T_Types_vOut52 _tpsIpps) = inv_Types_s53 _tpsX53 (T_Types_vIn52 _tpsOnested) _lhsOprec :: Int _lhsOprec = rule396 () _lhsOpp :: PP_Doc _lhsOpp = rule397 _lhsInested _tpsIpps _tpsOnested = rule398 _lhsInested !__result_ = T_Type_vOut49 _lhsOpp _lhsOprec in __result_ ) in C_Type_s50 v49 {-# INLINE rule396 #-} {-# LINE 272 "./src-ag/PrintCode.ag" #-} rule396 = \ (_ :: ()) -> {-# LINE 272 "./src-ag/PrintCode.ag" #-} 5 {-# LINE 3723 "dist/build/PrintCode.hs"#-} {-# INLINE rule397 #-} {-# LINE 273 "./src-ag/PrintCode.ag" #-} rule397 = \ ((_lhsInested) :: Bool) ((_tpsIpps) :: PP_Docs) -> {-# LINE 273 "./src-ag/PrintCode.ag" #-} ppTuple _lhsInested _tpsIpps {-# LINE 3729 "dist/build/PrintCode.hs"#-} {-# INLINE rule398 #-} rule398 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# NOINLINE sem_Type_UnboxedTupleType #-} sem_Type_UnboxedTupleType :: T_Types -> T_Type sem_Type_UnboxedTupleType arg_tps_ = T_Type (return st50) where {-# NOINLINE st50 #-} !st50 = let v49 :: T_Type_v49 v49 = \ !(T_Type_vIn49 _lhsInested) -> ( let _tpsX53 = Control.Monad.Identity.runIdentity (attach_T_Types (arg_tps_)) (T_Types_vOut52 _tpsIpps) = inv_Types_s53 _tpsX53 (T_Types_vIn52 _tpsOnested) _lhsOprec :: Int _lhsOprec = rule399 () _lhsOpp :: PP_Doc _lhsOpp = rule400 _lhsInested _tpsIpps _tpsOnested = rule401 _lhsInested !__result_ = T_Type_vOut49 _lhsOpp _lhsOprec in __result_ ) in C_Type_s50 v49 {-# INLINE rule399 #-} {-# LINE 275 "./src-ag/PrintCode.ag" #-} rule399 = \ (_ :: ()) -> {-# LINE 275 "./src-ag/PrintCode.ag" #-} 5 {-# LINE 3755 "dist/build/PrintCode.hs"#-} {-# INLINE rule400 #-} {-# LINE 276 "./src-ag/PrintCode.ag" #-} rule400 = \ ((_lhsInested) :: Bool) ((_tpsIpps) :: PP_Docs) -> {-# LINE 276 "./src-ag/PrintCode.ag" #-} ppUnboxedTuple _lhsInested _tpsIpps {-# LINE 3761 "dist/build/PrintCode.hs"#-} {-# INLINE rule401 #-} rule401 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# NOINLINE sem_Type_List #-} sem_Type_List :: T_Type -> T_Type sem_Type_List arg_tp_ = T_Type (return st50) where {-# NOINLINE st50 #-} !st50 = let v49 :: T_Type_v49 v49 = \ !(T_Type_vIn49 _lhsInested) -> ( let _tpX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_tp_)) (T_Type_vOut49 _tpIpp _tpIprec) = inv_Type_s50 _tpX50 (T_Type_vIn49 _tpOnested) _lhsOprec :: Int _lhsOprec = rule402 () _lhsOpp :: PP_Doc _lhsOpp = rule403 _tpIpp _tpOnested = rule404 _lhsInested !__result_ = T_Type_vOut49 _lhsOpp _lhsOprec in __result_ ) in C_Type_s50 v49 {-# INLINE rule402 #-} {-# LINE 278 "./src-ag/PrintCode.ag" #-} rule402 = \ (_ :: ()) -> {-# LINE 278 "./src-ag/PrintCode.ag" #-} 5 {-# LINE 3787 "dist/build/PrintCode.hs"#-} {-# INLINE rule403 #-} {-# LINE 279 "./src-ag/PrintCode.ag" #-} rule403 = \ ((_tpIpp) :: PP_Doc) -> {-# LINE 279 "./src-ag/PrintCode.ag" #-} "[" >|< _tpIpp >|< "]" {-# LINE 3793 "dist/build/PrintCode.hs"#-} {-# INLINE rule404 #-} rule404 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# NOINLINE sem_Type_SimpleType #-} sem_Type_SimpleType :: (String) -> T_Type sem_Type_SimpleType !arg_txt_ = T_Type (return st50) where {-# NOINLINE st50 #-} !st50 = let v49 :: T_Type_v49 v49 = \ !(T_Type_vIn49 _lhsInested) -> ( let _lhsOprec :: Int _lhsOprec = rule405 () _lhsOpp :: PP_Doc _lhsOpp = rule406 arg_txt_ !__result_ = T_Type_vOut49 _lhsOpp _lhsOprec in __result_ ) in C_Type_s50 v49 {-# INLINE rule405 #-} {-# LINE 281 "./src-ag/PrintCode.ag" #-} rule405 = \ (_ :: ()) -> {-# LINE 281 "./src-ag/PrintCode.ag" #-} 5 {-# LINE 3816 "dist/build/PrintCode.hs"#-} {-# INLINE rule406 #-} {-# LINE 282 "./src-ag/PrintCode.ag" #-} rule406 = \ txt_ -> {-# LINE 282 "./src-ag/PrintCode.ag" #-} if reallySimple txt_ then text txt_ else pp_parens (text txt_) {-# LINE 3822 "dist/build/PrintCode.hs"#-} {-# NOINLINE sem_Type_NontermType #-} sem_Type_NontermType :: (String) -> ([String]) -> (Bool) -> T_Type sem_Type_NontermType !arg_name_ !arg_params_ !arg_deforested_ = T_Type (return st50) where {-# NOINLINE st50 #-} !st50 = let v49 :: T_Type_v49 v49 = \ !(T_Type_vIn49 _lhsInested) -> ( let _lhsOprec :: Int _lhsOprec = rule407 () _lhsOpp :: PP_Doc _lhsOpp = rule408 _prefix arg_name_ arg_params_ _prefix = rule409 arg_deforested_ !__result_ = T_Type_vOut49 _lhsOpp _lhsOprec in __result_ ) in C_Type_s50 v49 {-# INLINE rule407 #-} {-# LINE 284 "./src-ag/PrintCode.ag" #-} rule407 = \ (_ :: ()) -> {-# LINE 284 "./src-ag/PrintCode.ag" #-} 5 {-# LINE 3843 "dist/build/PrintCode.hs"#-} {-# INLINE rule408 #-} {-# LINE 285 "./src-ag/PrintCode.ag" #-} rule408 = \ _prefix name_ params_ -> {-# LINE 285 "./src-ag/PrintCode.ag" #-} _prefix >|< text name_ >#< hv_sp params_ {-# LINE 3849 "dist/build/PrintCode.hs"#-} {-# INLINE rule409 #-} {-# LINE 286 "./src-ag/PrintCode.ag" #-} rule409 = \ deforested_ -> {-# LINE 286 "./src-ag/PrintCode.ag" #-} if deforested_ then text "T_" else empty {-# LINE 3857 "dist/build/PrintCode.hs"#-} {-# NOINLINE sem_Type_TMaybe #-} sem_Type_TMaybe :: T_Type -> T_Type sem_Type_TMaybe arg_tp_ = T_Type (return st50) where {-# NOINLINE st50 #-} !st50 = let v49 :: T_Type_v49 v49 = \ !(T_Type_vIn49 _lhsInested) -> ( let _tpX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_tp_)) (T_Type_vOut49 _tpIpp _tpIprec) = inv_Type_s50 _tpX50 (T_Type_vIn49 _tpOnested) _lhsOprec :: Int _lhsOprec = rule410 () _lhsOpp :: PP_Doc _lhsOpp = rule411 _tpIpp _tpOnested = rule412 _lhsInested !__result_ = T_Type_vOut49 _lhsOpp _lhsOprec in __result_ ) in C_Type_s50 v49 {-# INLINE rule410 #-} {-# LINE 289 "./src-ag/PrintCode.ag" #-} rule410 = \ (_ :: ()) -> {-# LINE 289 "./src-ag/PrintCode.ag" #-} 5 {-# LINE 3880 "dist/build/PrintCode.hs"#-} {-# INLINE rule411 #-} {-# LINE 290 "./src-ag/PrintCode.ag" #-} rule411 = \ ((_tpIpp) :: PP_Doc) -> {-# LINE 290 "./src-ag/PrintCode.ag" #-} text "Maybe" >#< _tpIpp {-# LINE 3886 "dist/build/PrintCode.hs"#-} {-# INLINE rule412 #-} rule412 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# NOINLINE sem_Type_TEither #-} sem_Type_TEither :: T_Type -> T_Type -> T_Type sem_Type_TEither arg_left_ arg_right_ = T_Type (return st50) where {-# NOINLINE st50 #-} !st50 = let v49 :: T_Type_v49 v49 = \ !(T_Type_vIn49 _lhsInested) -> ( let _leftX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_left_)) _rightX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_right_)) (T_Type_vOut49 _leftIpp _leftIprec) = inv_Type_s50 _leftX50 (T_Type_vIn49 _leftOnested) (T_Type_vOut49 _rightIpp _rightIprec) = inv_Type_s50 _rightX50 (T_Type_vIn49 _rightOnested) _lhsOprec :: Int _lhsOprec = rule413 () _lhsOpp :: PP_Doc _lhsOpp = rule414 _leftIpp _rightIpp _leftOnested = rule415 _lhsInested _rightOnested = rule416 _lhsInested !__result_ = T_Type_vOut49 _lhsOpp _lhsOprec in __result_ ) in C_Type_s50 v49 {-# INLINE rule413 #-} {-# LINE 291 "./src-ag/PrintCode.ag" #-} rule413 = \ (_ :: ()) -> {-# LINE 291 "./src-ag/PrintCode.ag" #-} 5 {-# LINE 3915 "dist/build/PrintCode.hs"#-} {-# INLINE rule414 #-} {-# LINE 292 "./src-ag/PrintCode.ag" #-} rule414 = \ ((_leftIpp) :: PP_Doc) ((_rightIpp) :: PP_Doc) -> {-# LINE 292 "./src-ag/PrintCode.ag" #-} text "Either" >#< pp_parens _leftIpp >#< pp_parens _rightIpp {-# LINE 3921 "dist/build/PrintCode.hs"#-} {-# INLINE rule415 #-} rule415 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule416 #-} rule416 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# NOINLINE sem_Type_TMap #-} sem_Type_TMap :: T_Type -> T_Type -> T_Type sem_Type_TMap arg_key_ arg_value_ = T_Type (return st50) where {-# NOINLINE st50 #-} !st50 = let v49 :: T_Type_v49 v49 = \ !(T_Type_vIn49 _lhsInested) -> ( let _keyX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_key_)) _valueX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_value_)) (T_Type_vOut49 _keyIpp _keyIprec) = inv_Type_s50 _keyX50 (T_Type_vIn49 _keyOnested) (T_Type_vOut49 _valueIpp _valueIprec) = inv_Type_s50 _valueX50 (T_Type_vIn49 _valueOnested) _lhsOprec :: Int _lhsOprec = rule417 () _lhsOpp :: PP_Doc _lhsOpp = rule418 _keyIpp _valueIpp _keyOnested = rule419 _lhsInested _valueOnested = rule420 _lhsInested !__result_ = T_Type_vOut49 _lhsOpp _lhsOprec in __result_ ) in C_Type_s50 v49 {-# INLINE rule417 #-} {-# LINE 293 "./src-ag/PrintCode.ag" #-} rule417 = \ (_ :: ()) -> {-# LINE 293 "./src-ag/PrintCode.ag" #-} 5 {-# LINE 3953 "dist/build/PrintCode.hs"#-} {-# INLINE rule418 #-} {-# LINE 294 "./src-ag/PrintCode.ag" #-} rule418 = \ ((_keyIpp) :: PP_Doc) ((_valueIpp) :: PP_Doc) -> {-# LINE 294 "./src-ag/PrintCode.ag" #-} text "Data.Map.Map" >#< pp_parens _keyIpp >#< pp_parens _valueIpp {-# LINE 3959 "dist/build/PrintCode.hs"#-} {-# INLINE rule419 #-} rule419 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule420 #-} rule420 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# NOINLINE sem_Type_TIntMap #-} sem_Type_TIntMap :: T_Type -> T_Type sem_Type_TIntMap arg_value_ = T_Type (return st50) where {-# NOINLINE st50 #-} !st50 = let v49 :: T_Type_v49 v49 = \ !(T_Type_vIn49 _lhsInested) -> ( let _valueX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_value_)) (T_Type_vOut49 _valueIpp _valueIprec) = inv_Type_s50 _valueX50 (T_Type_vIn49 _valueOnested) _lhsOprec :: Int _lhsOprec = rule421 () _lhsOpp :: PP_Doc _lhsOpp = rule422 _valueIpp _valueOnested = rule423 _lhsInested !__result_ = T_Type_vOut49 _lhsOpp _lhsOprec in __result_ ) in C_Type_s50 v49 {-# INLINE rule421 #-} {-# LINE 295 "./src-ag/PrintCode.ag" #-} rule421 = \ (_ :: ()) -> {-# LINE 295 "./src-ag/PrintCode.ag" #-} 5 {-# LINE 3988 "dist/build/PrintCode.hs"#-} {-# INLINE rule422 #-} {-# LINE 296 "./src-ag/PrintCode.ag" #-} rule422 = \ ((_valueIpp) :: PP_Doc) -> {-# LINE 296 "./src-ag/PrintCode.ag" #-} text "Data.IntMap.IntMap" >#< pp_parens _valueIpp {-# LINE 3994 "dist/build/PrintCode.hs"#-} {-# INLINE rule423 #-} rule423 = \ ((_lhsInested) :: Bool) -> _lhsInested -- Types ------------------------------------------------------- -- wrapper data Inh_Types = Inh_Types { nested_Inh_Types :: !(Bool) } data Syn_Types = Syn_Types { pps_Syn_Types :: !(PP_Docs) } {-# INLINABLE wrap_Types #-} wrap_Types :: T_Types -> Inh_Types -> (Syn_Types ) wrap_Types !(T_Types act) !(Inh_Types _lhsInested) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Types_vIn52 _lhsInested !(T_Types_vOut52 _lhsOpps) <- return (inv_Types_s53 sem arg) return (Syn_Types _lhsOpps) ) -- cata {-# NOINLINE sem_Types #-} sem_Types :: Types -> T_Types sem_Types list = Prelude.foldr sem_Types_Cons sem_Types_Nil (Prelude.map sem_Type list) -- semantic domain newtype T_Types = T_Types { attach_T_Types :: Identity (T_Types_s53 ) } newtype T_Types_s53 = C_Types_s53 { inv_Types_s53 :: (T_Types_v52 ) } data T_Types_s54 = C_Types_s54 type T_Types_v52 = (T_Types_vIn52 ) -> (T_Types_vOut52 ) data T_Types_vIn52 = T_Types_vIn52 (Bool) data T_Types_vOut52 = T_Types_vOut52 (PP_Docs) {-# NOINLINE sem_Types_Cons #-} sem_Types_Cons :: T_Type -> T_Types -> T_Types sem_Types_Cons arg_hd_ arg_tl_ = T_Types (return st53) where {-# NOINLINE st53 #-} !st53 = let v52 :: T_Types_v52 v52 = \ !(T_Types_vIn52 _lhsInested) -> ( let _hdX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_hd_)) _tlX53 = Control.Monad.Identity.runIdentity (attach_T_Types (arg_tl_)) (T_Type_vOut49 _hdIpp _hdIprec) = inv_Type_s50 _hdX50 (T_Type_vIn49 _hdOnested) (T_Types_vOut52 _tlIpps) = inv_Types_s53 _tlX53 (T_Types_vIn52 _tlOnested) _lhsOpps :: PP_Docs _lhsOpps = rule424 _hdIpp _tlIpps _hdOnested = rule425 _lhsInested _tlOnested = rule426 _lhsInested !__result_ = T_Types_vOut52 _lhsOpps in __result_ ) in C_Types_s53 v52 {-# INLINE rule424 #-} {-# LINE 76 "./src-ag/PrintCode.ag" #-} rule424 = \ ((_hdIpp) :: PP_Doc) ((_tlIpps) :: PP_Docs) -> {-# LINE 76 "./src-ag/PrintCode.ag" #-} _hdIpp : _tlIpps {-# LINE 4052 "dist/build/PrintCode.hs"#-} {-# INLINE rule425 #-} rule425 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# INLINE rule426 #-} rule426 = \ ((_lhsInested) :: Bool) -> _lhsInested {-# NOINLINE sem_Types_Nil #-} sem_Types_Nil :: T_Types sem_Types_Nil = T_Types (return st53) where {-# NOINLINE st53 #-} !st53 = let v52 :: T_Types_v52 v52 = \ !(T_Types_vIn52 _lhsInested) -> ( let _lhsOpps :: PP_Docs _lhsOpps = rule427 () !__result_ = T_Types_vOut52 _lhsOpps in __result_ ) in C_Types_s53 v52 {-# INLINE rule427 #-} {-# LINE 77 "./src-ag/PrintCode.ag" #-} rule427 = \ (_ :: ()) -> {-# LINE 77 "./src-ag/PrintCode.ag" #-} [] {-# LINE 4076 "dist/build/PrintCode.hs"#-} uuagc-0.9.42.3/src-generated/PrintErrorMessages.hs000644 000765 000024 00000265437 12127045231 023744 0ustar00jeroenbransenstaff000000 000000 {-# LANGUAGE Rank2Types, GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} module PrintErrorMessages where {-# LINE 2 "./src-ag/ErrorMessages.ag" #-} import UU.Scanner.Position(Pos) import Pretty import CodeSyntax import CommonTypes {-# LINE 12 "dist/build/PrintErrorMessages.hs" #-} {-# LINE 4 "./src-ag/PrintErrorMessages.ag" #-} import UU.Scanner.Position(Pos(..), noPos) import ErrorMessages import Data.List(mapAccumL) import GrammarInfo import qualified Control.Monad.Error.Class as Err {-# LINE 21 "dist/build/PrintErrorMessages.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 13 "./src-ag/PrintErrorMessages.ag" #-} instance Err.Error Error where noMsg = Err.strMsg "error" strMsg = CustomError False noPos . pp {-# LINE 29 "dist/build/PrintErrorMessages.hs" #-} {-# LINE 20 "./src-ag/PrintErrorMessages.ag" #-} 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 ] {-# LINE 73 "dist/build/PrintErrorMessages.hs" #-} {-# LINE 548 "./src-ag/PrintErrorMessages.ag" #-} toWidth :: Int -> String -> String toWidth n xs | k 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 {-# LINE 119 "dist/build/PrintErrorMessages.hs" #-} {-# LINE 594 "./src-ag/PrintErrorMessages.ag" #-} 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] {-# LINE 183 "dist/build/PrintErrorMessages.hs" #-} -- Error ------------------------------------------------------- -- wrapper data Inh_Error = Inh_Error { options_Inh_Error :: (Options), verbose_Inh_Error :: (Bool) } data Syn_Error = Syn_Error { me_Syn_Error :: (Error), pp_Syn_Error :: (PP_Doc) } {-# INLINABLE wrap_Error #-} wrap_Error :: T_Error -> Inh_Error -> (Syn_Error ) wrap_Error (T_Error act) (Inh_Error _lhsIoptions _lhsIverbose) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Error_vIn1 _lhsIoptions _lhsIverbose (T_Error_vOut1 _lhsOme _lhsOpp) <- return (inv_Error_s2 sem arg) return (Syn_Error _lhsOme _lhsOpp) ) -- cata {-# NOINLINE sem_Error #-} sem_Error :: Error -> T_Error sem_Error ( ParserError pos_ problem_ action_ ) = sem_Error_ParserError pos_ problem_ action_ sem_Error ( HsParseError pos_ msg_ ) = sem_Error_HsParseError pos_ msg_ sem_Error ( DupAlt nt_ con_ occ1_ ) = sem_Error_DupAlt nt_ con_ occ1_ sem_Error ( DupSynonym nt_ occ1_ ) = sem_Error_DupSynonym nt_ occ1_ sem_Error ( DupSet name_ occ1_ ) = sem_Error_DupSet name_ occ1_ sem_Error ( DupInhAttr nt_ attr_ occ1_ ) = sem_Error_DupInhAttr nt_ attr_ occ1_ sem_Error ( DupSynAttr nt_ attr_ occ1_ ) = sem_Error_DupSynAttr nt_ attr_ occ1_ sem_Error ( DupChild nt_ con_ name_ occ1_ ) = sem_Error_DupChild nt_ con_ name_ occ1_ sem_Error ( DupRule nt_ con_ field_ attr_ occ1_ ) = sem_Error_DupRule nt_ con_ field_ attr_ occ1_ sem_Error ( DupRuleName nt_ con_ nm_ ) = sem_Error_DupRuleName nt_ con_ nm_ sem_Error ( DupSig nt_ con_ attr_ ) = sem_Error_DupSig nt_ con_ attr_ sem_Error ( UndefNont nt_ ) = sem_Error_UndefNont nt_ sem_Error ( UndefAlt nt_ con_ ) = sem_Error_UndefAlt nt_ con_ sem_Error ( UndefChild nt_ con_ name_ ) = sem_Error_UndefChild nt_ con_ name_ sem_Error ( MissingRule nt_ con_ field_ attr_ ) = sem_Error_MissingRule nt_ con_ field_ attr_ sem_Error ( MissingNamedRule nt_ con_ name_ ) = sem_Error_MissingNamedRule nt_ con_ name_ sem_Error ( SuperfluousRule nt_ con_ field_ attr_ ) = sem_Error_SuperfluousRule nt_ con_ field_ attr_ sem_Error ( UndefLocal nt_ con_ var_ ) = sem_Error_UndefLocal nt_ con_ var_ sem_Error ( ChildAsLocal nt_ con_ var_ ) = sem_Error_ChildAsLocal nt_ con_ var_ sem_Error ( UndefAttr nt_ con_ field_ attr_ isOut_ ) = sem_Error_UndefAttr nt_ con_ field_ attr_ isOut_ sem_Error ( Cyclic nt_ mbCon_ verts_ ) = sem_Error_Cyclic nt_ mbCon_ verts_ sem_Error ( CyclicSet name_ ) = sem_Error_CyclicSet name_ sem_Error ( CustomError isWarning_ pos_ mesg_ ) = sem_Error_CustomError isWarning_ pos_ mesg_ sem_Error ( LocalCirc nt_ con_ attr_ o_visit_ path_ ) = sem_Error_LocalCirc nt_ con_ attr_ o_visit_ path_ sem_Error ( InstCirc nt_ con_ attr_ o_visit_ path_ ) = sem_Error_InstCirc nt_ con_ attr_ o_visit_ path_ sem_Error ( DirectCirc nt_ o_visit_ cyclic_ ) = sem_Error_DirectCirc nt_ o_visit_ cyclic_ sem_Error ( InducedCirc nt_ cinter_ cyclic_ ) = sem_Error_InducedCirc nt_ cinter_ cyclic_ sem_Error ( MissingTypeSig nt_ con_ attr_ ) = sem_Error_MissingTypeSig nt_ con_ attr_ sem_Error ( MissingInstSig nt_ con_ attr_ ) = sem_Error_MissingInstSig nt_ con_ attr_ sem_Error ( DupUnique nt_ con_ attr_ ) = sem_Error_DupUnique nt_ con_ attr_ sem_Error ( MissingUnique nt_ attr_ ) = sem_Error_MissingUnique nt_ attr_ sem_Error ( MissingSyn nt_ attr_ ) = sem_Error_MissingSyn nt_ attr_ sem_Error ( IncompatibleVisitKind child_ vis_ from_ to_ ) = sem_Error_IncompatibleVisitKind child_ vis_ from_ to_ sem_Error ( IncompatibleRuleKind rule_ kind_ ) = sem_Error_IncompatibleRuleKind rule_ kind_ sem_Error ( IncompatibleAttachKind child_ kind_ ) = sem_Error_IncompatibleAttachKind child_ kind_ -- semantic domain newtype T_Error = T_Error { attach_T_Error :: Identity (T_Error_s2 ) } newtype T_Error_s2 = C_Error_s2 { inv_Error_s2 :: (T_Error_v1 ) } data T_Error_s3 = C_Error_s3 type T_Error_v1 = (T_Error_vIn1 ) -> (T_Error_vOut1 ) data T_Error_vIn1 = T_Error_vIn1 (Options) (Bool) data T_Error_vOut1 = T_Error_vOut1 (Error) (PP_Doc) {-# NOINLINE sem_Error_ParserError #-} sem_Error_ParserError :: (Pos) -> (String) -> (String) -> T_Error sem_Error_ParserError arg_pos_ arg_problem_ arg_action_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule0 _lhsIoptions _lhsIverbose _me arg_action_ arg_pos_ arg_problem_ _me = rule1 arg_action_ arg_pos_ arg_problem_ _lhsOme :: Error _lhsOme = rule2 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule0 #-} {-# LINE 87 "./src-ag/PrintErrorMessages.ag" #-} rule0 = \ ((_lhsIoptions) :: Options) ((_lhsIverbose) :: Bool) _me action_ pos_ problem_ -> {-# LINE 87 "./src-ag/PrintErrorMessages.ag" #-} let mesg = text ("parser expecting " ++ problem_) pat = text "" help = text "" act = text action_ in ppError (isError _lhsIoptions _me) pos_ mesg pat help act _lhsIverbose {-# LINE 272 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule1 #-} rule1 = \ action_ pos_ problem_ -> ParserError pos_ problem_ action_ {-# INLINE rule2 #-} rule2 = \ _me -> _me {-# NOINLINE sem_Error_HsParseError #-} sem_Error_HsParseError :: (Pos) -> (String) -> T_Error sem_Error_HsParseError arg_pos_ arg_msg_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule3 _lhsIverbose arg_msg_ arg_pos_ _me = rule4 arg_msg_ arg_pos_ _lhsOme :: Error _lhsOme = rule5 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule3 #-} {-# LINE 93 "./src-ag/PrintErrorMessages.ag" #-} rule3 = \ ((_lhsIverbose) :: Bool) msg_ pos_ -> {-# LINE 93 "./src-ag/PrintErrorMessages.ag" #-} ppError True pos_ (text msg_) (text "") (text "") (text "Correct the syntax of the Haskell code.") _lhsIverbose {-# LINE 299 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule4 #-} rule4 = \ msg_ pos_ -> HsParseError pos_ msg_ {-# INLINE rule5 #-} rule5 = \ _me -> _me {-# NOINLINE sem_Error_DupAlt #-} sem_Error_DupAlt :: (NontermIdent) -> (ConstructorIdent) -> (ConstructorIdent) -> T_Error sem_Error_DupAlt arg_nt_ arg_con_ arg_occ1_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule6 _lhsIoptions _lhsIverbose _me arg_con_ arg_nt_ arg_occ1_ _me = rule7 arg_con_ arg_nt_ arg_occ1_ _lhsOme :: Error _lhsOme = rule8 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule6 #-} {-# LINE 95 "./src-ag/PrintErrorMessages.ag" #-} rule6 = \ ((_lhsIoptions) :: Options) ((_lhsIverbose) :: Bool) _me con_ nt_ occ1_ -> {-# LINE 95 "./src-ag/PrintErrorMessages.ag" #-} 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 _lhsIoptions _me) (getPos con_) mesg pat help act _lhsIverbose {-# LINE 343 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule7 #-} rule7 = \ con_ nt_ occ1_ -> DupAlt nt_ con_ occ1_ {-# INLINE rule8 #-} rule8 = \ _me -> _me {-# NOINLINE sem_Error_DupSynonym #-} sem_Error_DupSynonym :: (NontermIdent) -> (NontermIdent) -> T_Error sem_Error_DupSynonym arg_nt_ arg_occ1_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule9 _lhsIoptions _lhsIverbose _me arg_nt_ arg_occ1_ _me = rule10 arg_nt_ arg_occ1_ _lhsOme :: Error _lhsOme = rule11 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule9 #-} {-# LINE 117 "./src-ag/PrintErrorMessages.ag" #-} rule9 = \ ((_lhsIoptions) :: Options) ((_lhsIverbose) :: Bool) _me nt_ occ1_ -> {-# LINE 117 "./src-ag/PrintErrorMessages.ag" #-} 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 _lhsIoptions _me) (getPos nt_) mesg pat help act _lhsIverbose {-# LINE 385 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule10 #-} rule10 = \ nt_ occ1_ -> DupSynonym nt_ occ1_ {-# INLINE rule11 #-} rule11 = \ _me -> _me {-# NOINLINE sem_Error_DupSet #-} sem_Error_DupSet :: (NontermIdent) -> (NontermIdent) -> T_Error sem_Error_DupSet arg_name_ arg_occ1_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule12 _lhsIoptions _lhsIverbose _me arg_name_ arg_occ1_ _me = rule13 arg_name_ arg_occ1_ _lhsOme :: Error _lhsOme = rule14 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule12 #-} {-# LINE 134 "./src-ag/PrintErrorMessages.ag" #-} rule12 = \ ((_lhsIoptions) :: Options) ((_lhsIverbose) :: Bool) _me name_ occ1_ -> {-# LINE 134 "./src-ag/PrintErrorMessages.ag" #-} 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 _lhsIoptions _me) (getPos name_) mesg pat help act _lhsIverbose {-# LINE 426 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule13 #-} rule13 = \ name_ occ1_ -> DupSet name_ occ1_ {-# INLINE rule14 #-} rule14 = \ _me -> _me {-# NOINLINE sem_Error_DupInhAttr #-} sem_Error_DupInhAttr :: (NontermIdent) -> (Identifier) -> (Identifier) -> T_Error sem_Error_DupInhAttr arg_nt_ arg_attr_ arg_occ1_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule15 _lhsIoptions _lhsIverbose _me arg_attr_ arg_nt_ arg_occ1_ _me = rule16 arg_attr_ arg_nt_ arg_occ1_ _lhsOme :: Error _lhsOme = rule17 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule15 #-} {-# LINE 150 "./src-ag/PrintErrorMessages.ag" #-} rule15 = \ ((_lhsIoptions) :: Options) ((_lhsIverbose) :: Bool) _me attr_ nt_ occ1_ -> {-# LINE 150 "./src-ag/PrintErrorMessages.ag" #-} 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 _lhsIoptions _me) (getPos attr_) mesg pat help act _lhsIverbose {-# LINE 468 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule16 #-} rule16 = \ attr_ nt_ occ1_ -> DupInhAttr nt_ attr_ occ1_ {-# INLINE rule17 #-} rule17 = \ _me -> _me {-# NOINLINE sem_Error_DupSynAttr #-} sem_Error_DupSynAttr :: (NontermIdent) -> (Identifier) -> (Identifier) -> T_Error sem_Error_DupSynAttr arg_nt_ arg_attr_ arg_occ1_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule18 _lhsIoptions _lhsIverbose _me arg_attr_ arg_nt_ arg_occ1_ _me = rule19 arg_attr_ arg_nt_ arg_occ1_ _lhsOme :: Error _lhsOme = rule20 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule18 #-} {-# LINE 169 "./src-ag/PrintErrorMessages.ag" #-} rule18 = \ ((_lhsIoptions) :: Options) ((_lhsIverbose) :: Bool) _me attr_ nt_ occ1_ -> {-# LINE 169 "./src-ag/PrintErrorMessages.ag" #-} 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 _lhsIoptions _me) (getPos attr_) mesg pat help act _lhsIverbose {-# LINE 510 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule19 #-} rule19 = \ attr_ nt_ occ1_ -> DupSynAttr nt_ attr_ occ1_ {-# INLINE rule20 #-} rule20 = \ _me -> _me {-# NOINLINE sem_Error_DupChild #-} sem_Error_DupChild :: (NontermIdent) -> (ConstructorIdent) -> (Identifier) -> (Identifier) -> T_Error sem_Error_DupChild arg_nt_ arg_con_ arg_name_ arg_occ1_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule21 _lhsIoptions _lhsIverbose _me arg_con_ arg_name_ arg_nt_ arg_occ1_ _me = rule22 arg_con_ arg_name_ arg_nt_ arg_occ1_ _lhsOme :: Error _lhsOme = rule23 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule21 #-} {-# LINE 188 "./src-ag/PrintErrorMessages.ag" #-} rule21 = \ ((_lhsIoptions) :: Options) ((_lhsIverbose) :: Bool) _me con_ name_ nt_ occ1_ -> {-# LINE 188 "./src-ag/PrintErrorMessages.ag" #-} 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 _lhsIoptions _me) (getPos name_) mesg pat help act _lhsIverbose {-# LINE 553 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule22 #-} rule22 = \ con_ name_ nt_ occ1_ -> DupChild nt_ con_ name_ occ1_ {-# INLINE rule23 #-} rule23 = \ _me -> _me {-# NOINLINE sem_Error_DupRule #-} sem_Error_DupRule :: (NontermIdent) -> (ConstructorIdent) -> (Identifier) -> (Identifier) -> (Identifier) -> T_Error sem_Error_DupRule arg_nt_ arg_con_ arg_field_ arg_attr_ arg_occ1_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule24 _lhsIoptions _lhsIverbose _me arg_attr_ arg_con_ arg_field_ arg_nt_ arg_occ1_ _me = rule25 arg_attr_ arg_con_ arg_field_ arg_nt_ arg_occ1_ _lhsOme :: Error _lhsOme = rule26 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule24 #-} {-# LINE 208 "./src-ag/PrintErrorMessages.ag" #-} rule24 = \ ((_lhsIoptions) :: Options) ((_lhsIverbose) :: Bool) _me attr_ con_ field_ nt_ occ1_ -> {-# LINE 208 "./src-ag/PrintErrorMessages.ag" #-} 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 _lhsIoptions _me) (getPos attr_) mesg pat help act _lhsIverbose {-# LINE 594 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule25 #-} rule25 = \ attr_ con_ field_ nt_ occ1_ -> DupRule nt_ con_ field_ attr_ occ1_ {-# INLINE rule26 #-} rule26 = \ _me -> _me {-# NOINLINE sem_Error_DupRuleName #-} sem_Error_DupRuleName :: (NontermIdent) -> (ConstructorIdent) -> (Identifier) -> T_Error sem_Error_DupRuleName arg_nt_ arg_con_ arg_nm_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule27 _lhsIoptions _lhsIverbose _me arg_con_ arg_nm_ arg_nt_ _me = rule28 arg_con_ arg_nm_ arg_nt_ _lhsOme :: Error _lhsOme = rule29 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule27 #-} {-# LINE 226 "./src-ag/PrintErrorMessages.ag" #-} rule27 = \ ((_lhsIoptions) :: Options) ((_lhsIverbose) :: Bool) _me con_ nm_ nt_ -> {-# LINE 226 "./src-ag/PrintErrorMessages.ag" #-} 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 _lhsIoptions _me) (getPos nm_) mesg pat help act _lhsIverbose {-# LINE 632 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule28 #-} rule28 = \ con_ nm_ nt_ -> DupRuleName nt_ con_ nm_ {-# INLINE rule29 #-} rule29 = \ _me -> _me {-# NOINLINE sem_Error_DupSig #-} sem_Error_DupSig :: (NontermIdent) -> (ConstructorIdent) -> (Identifier) -> T_Error sem_Error_DupSig arg_nt_ arg_con_ arg_attr_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule30 _lhsIoptions _lhsIverbose _me arg_attr_ arg_con_ arg_nt_ _me = rule31 arg_attr_ arg_con_ arg_nt_ _lhsOme :: Error _lhsOme = rule32 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule30 #-} {-# LINE 241 "./src-ag/PrintErrorMessages.ag" #-} rule30 = \ ((_lhsIoptions) :: Options) ((_lhsIverbose) :: Bool) _me attr_ con_ nt_ -> {-# LINE 241 "./src-ag/PrintErrorMessages.ag" #-} 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 _lhsIoptions _me) (getPos attr_) mesg pat help act _lhsIverbose {-# LINE 672 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule31 #-} rule31 = \ attr_ con_ nt_ -> DupSig nt_ con_ attr_ {-# INLINE rule32 #-} rule32 = \ _me -> _me {-# NOINLINE sem_Error_UndefNont #-} sem_Error_UndefNont :: (NontermIdent) -> T_Error sem_Error_UndefNont arg_nt_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule33 _lhsIoptions _lhsIverbose _me arg_nt_ _me = rule34 arg_nt_ _lhsOme :: Error _lhsOme = rule35 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule33 #-} {-# LINE 258 "./src-ag/PrintErrorMessages.ag" #-} rule33 = \ ((_lhsIoptions) :: Options) ((_lhsIverbose) :: Bool) _me nt_ -> {-# LINE 258 "./src-ag/PrintErrorMessages.ag" #-} 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 _lhsIoptions _me) (getPos nt_) mesg pat help act _lhsIverbose {-# LINE 706 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule34 #-} rule34 = \ nt_ -> UndefNont nt_ {-# INLINE rule35 #-} rule35 = \ _me -> _me {-# NOINLINE sem_Error_UndefAlt #-} sem_Error_UndefAlt :: (NontermIdent) -> (ConstructorIdent) -> T_Error sem_Error_UndefAlt arg_nt_ arg_con_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule36 _lhsIoptions _lhsIverbose _me arg_con_ arg_nt_ _me = rule37 arg_con_ arg_nt_ _lhsOme :: Error _lhsOme = rule38 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule36 #-} {-# LINE 268 "./src-ag/PrintErrorMessages.ag" #-} rule36 = \ ((_lhsIoptions) :: Options) ((_lhsIverbose) :: Bool) _me con_ nt_ -> {-# LINE 268 "./src-ag/PrintErrorMessages.ag" #-} 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 _lhsIoptions _me) (getPos con_) mesg pat help act _lhsIverbose {-# LINE 742 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule37 #-} rule37 = \ con_ nt_ -> UndefAlt nt_ con_ {-# INLINE rule38 #-} rule38 = \ _me -> _me {-# NOINLINE sem_Error_UndefChild #-} sem_Error_UndefChild :: (NontermIdent) -> (ConstructorIdent) -> (Identifier) -> T_Error sem_Error_UndefChild arg_nt_ arg_con_ arg_name_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule39 _lhsIoptions _lhsIverbose _me arg_con_ arg_name_ arg_nt_ _me = rule40 arg_con_ arg_name_ arg_nt_ _lhsOme :: Error _lhsOme = rule41 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule39 #-} {-# LINE 280 "./src-ag/PrintErrorMessages.ag" #-} rule39 = \ ((_lhsIoptions) :: Options) ((_lhsIverbose) :: Bool) _me con_ name_ nt_ -> {-# LINE 280 "./src-ag/PrintErrorMessages.ag" #-} 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 "") >#< "= ...") 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 _lhsIoptions _me) (getPos name_) mesg pat help act _lhsIverbose {-# LINE 781 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule40 #-} rule40 = \ con_ name_ nt_ -> UndefChild nt_ con_ name_ {-# INLINE rule41 #-} rule41 = \ _me -> _me {-# NOINLINE sem_Error_MissingRule #-} sem_Error_MissingRule :: (NontermIdent) -> (ConstructorIdent) -> (Identifier) -> (Identifier) -> T_Error sem_Error_MissingRule arg_nt_ arg_con_ arg_field_ arg_attr_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule42 _lhsIoptions _lhsIverbose _me arg_attr_ arg_con_ arg_field_ arg_nt_ _me = rule43 arg_attr_ arg_con_ arg_field_ arg_nt_ _lhsOme :: Error _lhsOme = rule44 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule42 #-} {-# LINE 295 "./src-ag/PrintErrorMessages.ag" #-} rule42 = \ ((_lhsIoptions) :: Options) ((_lhsIverbose) :: Bool) _me attr_ con_ field_ nt_ -> {-# LINE 295 "./src-ag/PrintErrorMessages.ag" #-} 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 _lhsIoptions _me) (getPos attr_) mesg pat help act _lhsIverbose {-# LINE 818 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule43 #-} rule43 = \ attr_ con_ field_ nt_ -> MissingRule nt_ con_ field_ attr_ {-# INLINE rule44 #-} rule44 = \ _me -> _me {-# NOINLINE sem_Error_MissingNamedRule #-} sem_Error_MissingNamedRule :: (NontermIdent) -> (Identifier) -> (Identifier) -> T_Error sem_Error_MissingNamedRule arg_nt_ arg_con_ arg_name_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule45 _lhsIoptions _lhsIverbose _me arg_con_ arg_name_ arg_nt_ _me = rule46 arg_con_ arg_name_ arg_nt_ _lhsOme :: Error _lhsOme = rule47 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule45 #-} {-# LINE 308 "./src-ag/PrintErrorMessages.ag" #-} rule45 = \ ((_lhsIoptions) :: Options) ((_lhsIverbose) :: Bool) _me con_ name_ nt_ -> {-# LINE 308 "./src-ag/PrintErrorMessages.ag" #-} 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 _lhsIoptions _me) (getPos name_) mesg pat help act _lhsIverbose {-# LINE 854 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule46 #-} rule46 = \ con_ name_ nt_ -> MissingNamedRule nt_ con_ name_ {-# INLINE rule47 #-} rule47 = \ _me -> _me {-# NOINLINE sem_Error_SuperfluousRule #-} sem_Error_SuperfluousRule :: (NontermIdent) -> (ConstructorIdent) -> (Identifier) -> (Identifier) -> T_Error sem_Error_SuperfluousRule arg_nt_ arg_con_ arg_field_ arg_attr_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule48 _lhsIoptions _lhsIverbose _me arg_attr_ arg_con_ arg_field_ arg_nt_ _me = rule49 arg_attr_ arg_con_ arg_field_ arg_nt_ _lhsOme :: Error _lhsOme = rule50 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule48 #-} {-# LINE 320 "./src-ag/PrintErrorMessages.ag" #-} rule48 = \ ((_lhsIoptions) :: Options) ((_lhsIverbose) :: Bool) _me attr_ con_ field_ nt_ -> {-# LINE 320 "./src-ag/PrintErrorMessages.ag" #-} 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 _lhsIoptions _me) (getPos attr_) mesg pat help act _lhsIverbose {-# LINE 891 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule49 #-} rule49 = \ attr_ con_ field_ nt_ -> SuperfluousRule nt_ con_ field_ attr_ {-# INLINE rule50 #-} rule50 = \ _me -> _me {-# NOINLINE sem_Error_UndefLocal #-} sem_Error_UndefLocal :: (NontermIdent) -> (ConstructorIdent) -> (Identifier) -> T_Error sem_Error_UndefLocal arg_nt_ arg_con_ arg_var_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule51 _lhsIoptions _lhsIverbose _me arg_con_ arg_nt_ arg_var_ _me = rule52 arg_con_ arg_nt_ arg_var_ _lhsOme :: Error _lhsOme = rule53 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule51 #-} {-# LINE 334 "./src-ag/PrintErrorMessages.ag" #-} rule51 = \ ((_lhsIoptions) :: Options) ((_lhsIverbose) :: Bool) _me con_ nt_ var_ -> {-# LINE 334 "./src-ag/PrintErrorMessages.ag" #-} 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_ >#< ". = " >#< "..." >#< "@" >|< 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 _lhsIoptions _me) (getPos var_) mesg pat help act _lhsIverbose {-# LINE 930 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule52 #-} rule52 = \ con_ nt_ var_ -> UndefLocal nt_ con_ var_ {-# INLINE rule53 #-} rule53 = \ _me -> _me {-# NOINLINE sem_Error_ChildAsLocal #-} sem_Error_ChildAsLocal :: (NontermIdent) -> (ConstructorIdent) -> (Identifier) -> T_Error sem_Error_ChildAsLocal arg_nt_ arg_con_ arg_var_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule54 _lhsIoptions _lhsIverbose _me arg_con_ arg_nt_ arg_var_ _me = rule55 arg_con_ arg_nt_ arg_var_ _lhsOme :: Error _lhsOme = rule56 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule54 #-} {-# LINE 349 "./src-ag/PrintErrorMessages.ag" #-} rule54 = \ ((_lhsIoptions) :: Options) ((_lhsIverbose) :: Bool) _me con_ nt_ var_ -> {-# LINE 349 "./src-ag/PrintErrorMessages.ag" #-} 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 _lhsIoptions _me) (getPos var_) mesg pat help act _lhsIverbose {-# LINE 968 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule55 #-} rule55 = \ con_ nt_ var_ -> ChildAsLocal nt_ con_ var_ {-# INLINE rule56 #-} rule56 = \ _me -> _me {-# NOINLINE sem_Error_UndefAttr #-} sem_Error_UndefAttr :: (NontermIdent) -> (ConstructorIdent) -> (Identifier) -> (Identifier) -> (Bool) -> T_Error sem_Error_UndefAttr arg_nt_ arg_con_ arg_field_ arg_attr_ arg_isOut_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule57 _lhsIoptions _lhsIverbose _me arg_attr_ arg_con_ arg_field_ arg_isOut_ arg_nt_ _me = rule58 arg_attr_ arg_con_ arg_field_ arg_isOut_ arg_nt_ _lhsOme :: Error _lhsOme = rule59 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule57 #-} {-# LINE 363 "./src-ag/PrintErrorMessages.ag" #-} rule57 = \ ((_lhsIoptions) :: Options) ((_lhsIverbose) :: Bool) _me attr_ con_ field_ isOut_ nt_ -> {-# LINE 363 "./src-ag/PrintErrorMessages.ag" #-} 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_ >#< ". = " >#< "..." >#< 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 _lhsIoptions _me) (getPos attr_) mesg pat help act _lhsIverbose {-# LINE 1011 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule58 #-} rule58 = \ attr_ con_ field_ isOut_ nt_ -> UndefAttr nt_ con_ field_ attr_ isOut_ {-# INLINE rule59 #-} rule59 = \ _me -> _me {-# NOINLINE sem_Error_Cyclic #-} sem_Error_Cyclic :: (NontermIdent) -> (Maybe ConstructorIdent) -> ([String]) -> T_Error sem_Error_Cyclic arg_nt_ arg_mbCon_ arg_verts_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule60 _lhsIoptions _me arg_mbCon_ arg_nt_ arg_verts_ _me = rule61 arg_mbCon_ arg_nt_ arg_verts_ _lhsOme :: Error _lhsOme = rule62 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule60 #-} {-# LINE 391 "./src-ag/PrintErrorMessages.ag" #-} rule60 = \ ((_lhsIoptions) :: Options) _me mbCon_ nt_ verts_ -> {-# LINE 391 "./src-ag/PrintErrorMessages.ag" #-} 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 _lhsIoptions _me) pos mesg pat help act False {-# LINE 1051 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule61 #-} rule61 = \ mbCon_ nt_ verts_ -> Cyclic nt_ mbCon_ verts_ {-# INLINE rule62 #-} rule62 = \ _me -> _me {-# NOINLINE sem_Error_CyclicSet #-} sem_Error_CyclicSet :: (Identifier) -> T_Error sem_Error_CyclicSet arg_name_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule63 _lhsIoptions _lhsIverbose _me arg_name_ _me = rule64 arg_name_ _lhsOme :: Error _lhsOme = rule65 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule63 #-} {-# LINE 382 "./src-ag/PrintErrorMessages.ag" #-} rule63 = \ ((_lhsIoptions) :: Options) ((_lhsIverbose) :: Bool) _me name_ -> {-# LINE 382 "./src-ag/PrintErrorMessages.ag" #-} 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 _lhsIoptions _me) (getPos name_) mesg pat help act _lhsIverbose {-# LINE 1085 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule64 #-} rule64 = \ name_ -> CyclicSet name_ {-# INLINE rule65 #-} rule65 = \ _me -> _me {-# NOINLINE sem_Error_CustomError #-} sem_Error_CustomError :: (Bool) -> (Pos) -> (PP_Doc) -> T_Error sem_Error_CustomError arg_isWarning_ arg_pos_ arg_mesg_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule66 _lhsIoptions _me arg_mesg_ arg_pos_ _me = rule67 arg_isWarning_ arg_mesg_ arg_pos_ _lhsOme :: Error _lhsOme = rule68 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule66 #-} {-# LINE 406 "./src-ag/PrintErrorMessages.ag" #-} rule66 = \ ((_lhsIoptions) :: Options) _me mesg_ pos_ -> {-# LINE 406 "./src-ag/PrintErrorMessages.ag" #-} let pat = text "unknown" help = wfill ["not available."] act = wfill ["unknown"] in ppError (isError _lhsIoptions _me) pos_ mesg_ pat help act False {-# LINE 1115 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule67 #-} rule67 = \ isWarning_ mesg_ pos_ -> CustomError isWarning_ pos_ mesg_ {-# INLINE rule68 #-} rule68 = \ _me -> _me {-# NOINLINE sem_Error_LocalCirc #-} sem_Error_LocalCirc :: (NontermIdent) -> (ConstructorIdent) -> (Identifier) -> (Bool) -> ([String]) -> T_Error sem_Error_LocalCirc arg_nt_ arg_con_ arg_attr_ arg_o_visit_ arg_path_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule69 _lhsIoptions _lhsIverbose _me arg_attr_ arg_con_ arg_nt_ arg_o_visit_ arg_path_ _me = rule70 arg_attr_ arg_con_ arg_nt_ arg_o_visit_ arg_path_ _lhsOme :: Error _lhsOme = rule71 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule69 #-} {-# LINE 411 "./src-ag/PrintErrorMessages.ag" #-} rule69 = \ ((_lhsIoptions) :: Options) ((_lhsIverbose) :: Bool) _me attr_ con_ nt_ o_visit_ path_ -> {-# LINE 411 "./src-ag/PrintErrorMessages.ag" #-} 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 _lhsIoptions _me) (getPos (attr_)) mesg pat help act _lhsIverbose {-# LINE 1152 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule70 #-} rule70 = \ attr_ con_ nt_ o_visit_ path_ -> LocalCirc nt_ con_ attr_ o_visit_ path_ {-# INLINE rule71 #-} rule71 = \ _me -> _me {-# NOINLINE sem_Error_InstCirc #-} sem_Error_InstCirc :: (NontermIdent) -> (ConstructorIdent) -> (Identifier) -> (Bool) -> ([String]) -> T_Error sem_Error_InstCirc arg_nt_ arg_con_ arg_attr_ arg_o_visit_ arg_path_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule72 _lhsIoptions _lhsIverbose _me arg_attr_ arg_con_ arg_nt_ arg_o_visit_ arg_path_ _me = rule73 arg_attr_ arg_con_ arg_nt_ arg_o_visit_ arg_path_ _lhsOme :: Error _lhsOme = rule74 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule72 #-} {-# LINE 423 "./src-ag/PrintErrorMessages.ag" #-} rule72 = \ ((_lhsIoptions) :: Options) ((_lhsIverbose) :: Bool) _me attr_ con_ nt_ o_visit_ path_ -> {-# LINE 423 "./src-ag/PrintErrorMessages.ag" #-} 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." >#< "...") 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 _lhsIoptions _me) (getPos (attr_)) mesg pat help act _lhsIverbose {-# LINE 1189 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule73 #-} rule73 = \ attr_ con_ nt_ o_visit_ path_ -> InstCirc nt_ con_ attr_ o_visit_ path_ {-# INLINE rule74 #-} rule74 = \ _me -> _me {-# NOINLINE sem_Error_DirectCirc #-} sem_Error_DirectCirc :: (NontermIdent) -> (Bool) -> ([((Identifier,Identifier),[String],[String])]) -> T_Error sem_Error_DirectCirc arg_nt_ arg_o_visit_ arg_cyclic_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule75 _lhsIoptions _lhsIverbose _me arg_cyclic_ arg_nt_ arg_o_visit_ _me = rule76 arg_cyclic_ arg_nt_ arg_o_visit_ _lhsOme :: Error _lhsOme = rule77 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule75 #-} {-# LINE 435 "./src-ag/PrintErrorMessages.ag" #-} rule75 = \ ((_lhsIoptions) :: Options) ((_lhsIverbose) :: Bool) _me cyclic_ nt_ o_visit_ -> {-# LINE 435 "./src-ag/PrintErrorMessages.ag" #-} 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 _lhsIoptions _me) noPos mesg pat help act _lhsIverbose {-# LINE 1222 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule76 #-} rule76 = \ cyclic_ nt_ o_visit_ -> DirectCirc nt_ o_visit_ cyclic_ {-# INLINE rule77 #-} rule77 = \ _me -> _me {-# NOINLINE sem_Error_InducedCirc #-} sem_Error_InducedCirc :: (NontermIdent) -> (CInterface) -> ([((Identifier,Identifier),[String],[String])]) -> T_Error sem_Error_InducedCirc arg_nt_ arg_cinter_ arg_cyclic_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule78 _lhsIoptions _lhsIverbose _me arg_cinter_ arg_cyclic_ arg_nt_ _me = rule79 arg_cinter_ arg_cyclic_ arg_nt_ _lhsOme :: Error _lhsOme = rule80 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule78 #-} {-# LINE 443 "./src-ag/PrintErrorMessages.ag" #-} rule78 = \ ((_lhsIoptions) :: Options) ((_lhsIverbose) :: Bool) _me cinter_ cyclic_ nt_ -> {-# LINE 443 "./src-ag/PrintErrorMessages.ag" #-} 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 _lhsIoptions _me) noPos mesg pat help act _lhsIverbose {-# LINE 1256 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule79 #-} rule79 = \ cinter_ cyclic_ nt_ -> InducedCirc nt_ cinter_ cyclic_ {-# INLINE rule80 #-} rule80 = \ _me -> _me {-# NOINLINE sem_Error_MissingTypeSig #-} sem_Error_MissingTypeSig :: (NontermIdent) -> (ConstructorIdent) -> (Identifier) -> T_Error sem_Error_MissingTypeSig arg_nt_ arg_con_ arg_attr_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule81 _lhsIoptions _lhsIverbose _me arg_attr_ arg_con_ arg_nt_ _me = rule82 arg_attr_ arg_con_ arg_nt_ _lhsOme :: Error _lhsOme = rule83 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule81 #-} {-# LINE 452 "./src-ag/PrintErrorMessages.ag" #-} rule81 = \ ((_lhsIoptions) :: Options) ((_lhsIverbose) :: Bool) _me attr_ con_ nt_ -> {-# LINE 452 "./src-ag/PrintErrorMessages.ag" #-} 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 _lhsIoptions _me) (getPos attr_) mesg pat help act _lhsIverbose {-# LINE 1295 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule82 #-} rule82 = \ attr_ con_ nt_ -> MissingTypeSig nt_ con_ attr_ {-# INLINE rule83 #-} rule83 = \ _me -> _me {-# NOINLINE sem_Error_MissingInstSig #-} sem_Error_MissingInstSig :: (NontermIdent) -> (ConstructorIdent) -> (Identifier) -> T_Error sem_Error_MissingInstSig arg_nt_ arg_con_ arg_attr_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule84 _lhsIoptions _lhsIverbose _me arg_attr_ arg_con_ arg_nt_ _me = rule85 arg_attr_ arg_con_ arg_nt_ _lhsOme :: Error _lhsOme = rule86 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule84 #-} {-# LINE 466 "./src-ag/PrintErrorMessages.ag" #-} rule84 = \ ((_lhsIoptions) :: Options) ((_lhsIverbose) :: Bool) _me attr_ con_ nt_ -> {-# LINE 466 "./src-ag/PrintErrorMessages.ag" #-} 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 _lhsIoptions _me) (getPos attr_) mesg pat help act _lhsIverbose {-# LINE 1334 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule85 #-} rule85 = \ attr_ con_ nt_ -> MissingInstSig nt_ con_ attr_ {-# INLINE rule86 #-} rule86 = \ _me -> _me {-# NOINLINE sem_Error_DupUnique #-} sem_Error_DupUnique :: (NontermIdent) -> (ConstructorIdent) -> (Identifier) -> T_Error sem_Error_DupUnique arg_nt_ arg_con_ arg_attr_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule87 _lhsIoptions _lhsIverbose _me arg_attr_ arg_con_ arg_nt_ _me = rule88 arg_attr_ arg_con_ arg_nt_ _lhsOme :: Error _lhsOme = rule89 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule87 #-} {-# LINE 496 "./src-ag/PrintErrorMessages.ag" #-} rule87 = \ ((_lhsIoptions) :: Options) ((_lhsIverbose) :: Bool) _me attr_ con_ nt_ -> {-# LINE 496 "./src-ag/PrintErrorMessages.ag" #-} 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 _lhsIoptions _me) (getPos attr_) mesg pat help act _lhsIverbose {-# LINE 1374 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule88 #-} rule88 = \ attr_ con_ nt_ -> DupUnique nt_ con_ attr_ {-# INLINE rule89 #-} rule89 = \ _me -> _me {-# NOINLINE sem_Error_MissingUnique #-} sem_Error_MissingUnique :: (NontermIdent) -> (Identifier) -> T_Error sem_Error_MissingUnique arg_nt_ arg_attr_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule90 _lhsIoptions _lhsIverbose _me arg_attr_ arg_nt_ _me = rule91 arg_attr_ arg_nt_ _lhsOme :: Error _lhsOme = rule92 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule90 #-} {-# LINE 480 "./src-ag/PrintErrorMessages.ag" #-} rule90 = \ ((_lhsIoptions) :: Options) ((_lhsIverbose) :: Bool) _me attr_ nt_ -> {-# LINE 480 "./src-ag/PrintErrorMessages.ag" #-} 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 _lhsIoptions _me) (getPos attr_) mesg pat help act _lhsIverbose {-# LINE 1414 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule91 #-} rule91 = \ attr_ nt_ -> MissingUnique nt_ attr_ {-# INLINE rule92 #-} rule92 = \ _me -> _me {-# NOINLINE sem_Error_MissingSyn #-} sem_Error_MissingSyn :: (NontermIdent) -> (Identifier) -> T_Error sem_Error_MissingSyn arg_nt_ arg_attr_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule93 _lhsIoptions _lhsIverbose _me arg_attr_ arg_nt_ _me = rule94 arg_attr_ arg_nt_ _lhsOme :: Error _lhsOme = rule95 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule93 #-} {-# LINE 513 "./src-ag/PrintErrorMessages.ag" #-} rule93 = \ ((_lhsIoptions) :: Options) ((_lhsIverbose) :: Bool) _me attr_ nt_ -> {-# LINE 513 "./src-ag/PrintErrorMessages.ag" #-} 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 _lhsIoptions _me) (getPos attr_) mesg pat help act _lhsIverbose {-# LINE 1454 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule94 #-} rule94 = \ attr_ nt_ -> MissingSyn nt_ attr_ {-# INLINE rule95 #-} rule95 = \ _me -> _me {-# NOINLINE sem_Error_IncompatibleVisitKind #-} sem_Error_IncompatibleVisitKind :: (Identifier) -> (VisitIdentifier) -> (VisitKind) -> (VisitKind) -> T_Error sem_Error_IncompatibleVisitKind arg_child_ arg_vis_ arg_from_ arg_to_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule96 _lhsIoptions _lhsIverbose _me arg_child_ arg_from_ arg_to_ arg_vis_ _me = rule97 arg_child_ arg_from_ arg_to_ arg_vis_ _lhsOme :: Error _lhsOme = rule98 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule96 #-} {-# LINE 529 "./src-ag/PrintErrorMessages.ag" #-} rule96 = \ ((_lhsIoptions) :: Options) ((_lhsIverbose) :: Bool) _me child_ from_ to_ vis_ -> {-# LINE 529 "./src-ag/PrintErrorMessages.ag" #-} 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 _lhsIoptions _me) (getPos child_) mesg pat help act _lhsIverbose {-# LINE 1485 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule97 #-} rule97 = \ child_ from_ to_ vis_ -> IncompatibleVisitKind child_ vis_ from_ to_ {-# INLINE rule98 #-} rule98 = \ _me -> _me {-# NOINLINE sem_Error_IncompatibleRuleKind #-} sem_Error_IncompatibleRuleKind :: (Identifier) -> (VisitKind) -> T_Error sem_Error_IncompatibleRuleKind arg_rule_ arg_kind_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule99 _lhsIoptions _lhsIverbose _me arg_kind_ arg_rule_ _me = rule100 arg_kind_ arg_rule_ _lhsOme :: Error _lhsOme = rule101 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule99 #-} {-# LINE 535 "./src-ag/PrintErrorMessages.ag" #-} rule99 = \ ((_lhsIoptions) :: Options) ((_lhsIverbose) :: Bool) _me kind_ rule_ -> {-# LINE 535 "./src-ag/PrintErrorMessages.ag" #-} 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 _lhsIoptions _me) (getPos rule_) mesg pat help act _lhsIverbose {-# LINE 1516 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule100 #-} rule100 = \ kind_ rule_ -> IncompatibleRuleKind rule_ kind_ {-# INLINE rule101 #-} rule101 = \ _me -> _me {-# NOINLINE sem_Error_IncompatibleAttachKind #-} sem_Error_IncompatibleAttachKind :: (Identifier) -> (VisitKind) -> T_Error sem_Error_IncompatibleAttachKind arg_child_ arg_kind_ = T_Error (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Error_v1 v1 = \ (T_Error_vIn1 _lhsIoptions _lhsIverbose) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule102 _lhsIoptions _lhsIverbose _me arg_child_ arg_kind_ _me = rule103 arg_child_ arg_kind_ _lhsOme :: Error _lhsOme = rule104 _me __result_ = T_Error_vOut1 _lhsOme _lhsOpp in __result_ ) in C_Error_s2 v1 {-# INLINE rule102 #-} {-# LINE 542 "./src-ag/PrintErrorMessages.ag" #-} rule102 = \ ((_lhsIoptions) :: Options) ((_lhsIverbose) :: Bool) _me child_ kind_ -> {-# LINE 542 "./src-ag/PrintErrorMessages.ag" #-} 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 _lhsIoptions _me) (getPos child_) mesg pat help act _lhsIverbose {-# LINE 1547 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule103 #-} rule103 = \ child_ kind_ -> IncompatibleAttachKind child_ kind_ {-# INLINE rule104 #-} rule104 = \ _me -> _me -- Errors ------------------------------------------------------ -- wrapper data Inh_Errors = Inh_Errors { dups_Inh_Errors :: ([String]), options_Inh_Errors :: (Options) } data Syn_Errors = Syn_Errors { pp_Syn_Errors :: (PP_Doc) } {-# INLINABLE wrap_Errors #-} wrap_Errors :: T_Errors -> Inh_Errors -> (Syn_Errors ) wrap_Errors (T_Errors act) (Inh_Errors _lhsIdups _lhsIoptions) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Errors_vIn4 _lhsIdups _lhsIoptions (T_Errors_vOut4 _lhsOpp) <- return (inv_Errors_s5 sem arg) return (Syn_Errors _lhsOpp) ) -- cata {-# NOINLINE sem_Errors #-} sem_Errors :: Errors -> T_Errors sem_Errors list = Prelude.foldr sem_Errors_Cons sem_Errors_Nil (Prelude.map sem_Error list) -- semantic domain newtype T_Errors = T_Errors { attach_T_Errors :: Identity (T_Errors_s5 ) } newtype T_Errors_s5 = C_Errors_s5 { inv_Errors_s5 :: (T_Errors_v4 ) } data T_Errors_s6 = C_Errors_s6 type T_Errors_v4 = (T_Errors_vIn4 ) -> (T_Errors_vOut4 ) data T_Errors_vIn4 = T_Errors_vIn4 ([String]) (Options) data T_Errors_vOut4 = T_Errors_vOut4 (PP_Doc) {-# NOINLINE sem_Errors_Cons #-} sem_Errors_Cons :: T_Error -> T_Errors -> T_Errors sem_Errors_Cons arg_hd_ arg_tl_ = T_Errors (return st5) where {-# NOINLINE st5 #-} st5 = let v4 :: T_Errors_v4 v4 = \ (T_Errors_vIn4 _lhsIdups _lhsIoptions) -> ( let _hdX2 = Control.Monad.Identity.runIdentity (attach_T_Error (arg_hd_)) _tlX5 = Control.Monad.Identity.runIdentity (attach_T_Errors (arg_tl_)) (T_Error_vOut1 _hdIme _hdIpp) = inv_Error_s2 _hdX2 (T_Error_vIn1 _hdOoptions _hdOverbose) (T_Errors_vOut4 _tlIpp) = inv_Errors_s5 _tlX5 (T_Errors_vIn4 _tlOdups _tlOoptions) _verbose = rule105 _lhsIoptions _str = rule106 _hdIpp _lhsOpp :: PP_Doc _lhsOpp = rule107 _hdIpp _lhsIdups _str _tlIpp _tlOdups = rule108 _lhsIdups _str _hdOoptions = rule109 _lhsIoptions _hdOverbose = rule110 _verbose _tlOoptions = rule111 _lhsIoptions __result_ = T_Errors_vOut4 _lhsOpp in __result_ ) in C_Errors_s5 v4 {-# INLINE rule105 #-} {-# LINE 76 "./src-ag/PrintErrorMessages.ag" #-} rule105 = \ ((_lhsIoptions) :: Options) -> {-# LINE 76 "./src-ag/PrintErrorMessages.ag" #-} verbose _lhsIoptions {-# LINE 1612 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule106 #-} {-# LINE 77 "./src-ag/PrintErrorMessages.ag" #-} rule106 = \ ((_hdIpp) :: PP_Doc) -> {-# LINE 77 "./src-ag/PrintErrorMessages.ag" #-} disp _hdIpp 5000 "" {-# LINE 1618 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule107 #-} {-# LINE 79 "./src-ag/PrintErrorMessages.ag" #-} rule107 = \ ((_hdIpp) :: PP_Doc) ((_lhsIdups) :: [String]) _str ((_tlIpp) :: PP_Doc) -> {-# LINE 79 "./src-ag/PrintErrorMessages.ag" #-} if _str `elem` _lhsIdups then _tlIpp else _hdIpp >-< _tlIpp {-# LINE 1626 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule108 #-} {-# LINE 82 "./src-ag/PrintErrorMessages.ag" #-} rule108 = \ ((_lhsIdups) :: [String]) _str -> {-# LINE 82 "./src-ag/PrintErrorMessages.ag" #-} _str : _lhsIdups {-# LINE 1632 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule109 #-} rule109 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule110 #-} rule110 = \ _verbose -> _verbose {-# INLINE rule111 #-} rule111 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Errors_Nil #-} sem_Errors_Nil :: T_Errors sem_Errors_Nil = T_Errors (return st5) where {-# NOINLINE st5 #-} st5 = let v4 :: T_Errors_v4 v4 = \ (T_Errors_vIn4 _lhsIdups _lhsIoptions) -> ( let _verbose = rule112 _lhsIoptions _lhsOpp :: PP_Doc _lhsOpp = rule113 () __result_ = T_Errors_vOut4 _lhsOpp in __result_ ) in C_Errors_s5 v4 {-# INLINE rule112 #-} {-# LINE 76 "./src-ag/PrintErrorMessages.ag" #-} rule112 = \ ((_lhsIoptions) :: Options) -> {-# LINE 76 "./src-ag/PrintErrorMessages.ag" #-} verbose _lhsIoptions {-# LINE 1660 "dist/build/PrintErrorMessages.hs"#-} {-# INLINE rule113 #-} {-# LINE 83 "./src-ag/PrintErrorMessages.ag" #-} rule113 = \ (_ :: ()) -> {-# LINE 83 "./src-ag/PrintErrorMessages.ag" #-} text "" {-# LINE 1666 "dist/build/PrintErrorMessages.hs"#-} uuagc-0.9.42.3/src-generated/PrintOcamlCode.hs000644 000765 000024 00000343003 12127045231 022773 0ustar00jeroenbransenstaff000000 000000 {-# LANGUAGE Rank2Types, GADTs #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} module PrintOcamlCode where {-# LINE 2 "./src-ag/Code.ag" #-} import Patterns import Data.Set(Set) import qualified Data.Set as Set import Data.Map(Map) import qualified Data.Map as Map {-# LINE 14 "dist/build/PrintOcamlCode.hs" #-} {-# LINE 2 "./src-ag/Patterns.ag" #-} -- Patterns.ag imports import UU.Scanner.Position(Pos) import CommonTypes (ConstructorIdent,Identifier) {-# LINE 21 "dist/build/PrintOcamlCode.hs" #-} {-# LINE 10 "./src-ag/PrintOcamlCode.ag" #-} 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) {-# LINE 32 "dist/build/PrintOcamlCode.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 144 "./src-ag/Code.ag" #-} -- 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 {-# LINE 52 "dist/build/PrintOcamlCode.hs" #-} {-# LINE 21 "./src-ag/PrintOcamlCode.ag" #-} 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 {-# LINE 71 "dist/build/PrintOcamlCode.hs" #-} {-# LINE 175 "./src-ag/PrintOcamlCode.ag" #-} toOcamlTC :: String -> String toOcamlTC (c:cs) = toLower c : cs toOcamlTC xs = xs {-# LINE 78 "dist/build/PrintOcamlCode.hs" #-} -- CaseAlt ----------------------------------------------------- -- wrapper data Inh_CaseAlt = Inh_CaseAlt { options_Inh_CaseAlt :: !(Options) } data Syn_CaseAlt = Syn_CaseAlt { pp_Syn_CaseAlt :: !(PP_Doc) } {-# INLINABLE wrap_CaseAlt #-} wrap_CaseAlt :: T_CaseAlt -> Inh_CaseAlt -> (Syn_CaseAlt ) wrap_CaseAlt !(T_CaseAlt act) !(Inh_CaseAlt _lhsIoptions) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_CaseAlt_vIn1 _lhsIoptions !(T_CaseAlt_vOut1 _lhsOpp) <- return (inv_CaseAlt_s2 sem arg) return (Syn_CaseAlt _lhsOpp) ) -- cata {-# NOINLINE sem_CaseAlt #-} sem_CaseAlt :: CaseAlt -> T_CaseAlt sem_CaseAlt ( CaseAlt left_ expr_ ) = sem_CaseAlt_CaseAlt ( sem_Lhs left_ ) ( sem_Expr expr_ ) -- semantic domain newtype T_CaseAlt = T_CaseAlt { attach_T_CaseAlt :: Identity (T_CaseAlt_s2 ) } newtype T_CaseAlt_s2 = C_CaseAlt_s2 { inv_CaseAlt_s2 :: (T_CaseAlt_v1 ) } data T_CaseAlt_s3 = C_CaseAlt_s3 type T_CaseAlt_v1 = (T_CaseAlt_vIn1 ) -> (T_CaseAlt_vOut1 ) data T_CaseAlt_vIn1 = T_CaseAlt_vIn1 (Options) data T_CaseAlt_vOut1 = T_CaseAlt_vOut1 (PP_Doc) {-# NOINLINE sem_CaseAlt_CaseAlt #-} sem_CaseAlt_CaseAlt :: T_Lhs -> T_Expr -> T_CaseAlt sem_CaseAlt_CaseAlt arg_left_ arg_expr_ = T_CaseAlt (return st2) where {-# NOINLINE st2 #-} !st2 = let v1 :: T_CaseAlt_v1 v1 = \ !(T_CaseAlt_vIn1 _lhsIoptions) -> ( let _leftX32 = Control.Monad.Identity.runIdentity (attach_T_Lhs (arg_left_)) _exprX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_expr_)) (T_Lhs_vOut31 _leftIpp) = inv_Lhs_s32 _leftX32 (T_Lhs_vIn31 _leftOoptions) (T_Expr_vOut25 _exprIpp) = inv_Expr_s26 _exprX26 (T_Expr_vIn25 _exprOoptions) _lhsOpp :: PP_Doc _lhsOpp = rule0 _exprIpp _leftIpp _leftOoptions = rule1 _lhsIoptions _exprOoptions = rule2 _lhsIoptions !__result_ = T_CaseAlt_vOut1 _lhsOpp in __result_ ) in C_CaseAlt_s2 v1 {-# INLINE rule0 #-} {-# LINE 182 "./src-ag/PrintOcamlCode.ag" #-} rule0 = \ ((_exprIpp) :: PP_Doc) ((_leftIpp) :: PP_Doc) -> {-# LINE 182 "./src-ag/PrintOcamlCode.ag" #-} _leftIpp >#< "->" >#< _exprIpp {-# LINE 132 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule1 #-} rule1 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule2 #-} rule2 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions -- CaseAlts ---------------------------------------------------- -- wrapper data Inh_CaseAlts = Inh_CaseAlts { options_Inh_CaseAlts :: !(Options) } data Syn_CaseAlts = Syn_CaseAlts { pps_Syn_CaseAlts :: !(PP_Docs) } {-# INLINABLE wrap_CaseAlts #-} wrap_CaseAlts :: T_CaseAlts -> Inh_CaseAlts -> (Syn_CaseAlts ) wrap_CaseAlts !(T_CaseAlts act) !(Inh_CaseAlts _lhsIoptions) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_CaseAlts_vIn4 _lhsIoptions !(T_CaseAlts_vOut4 _lhsOpps) <- return (inv_CaseAlts_s5 sem arg) return (Syn_CaseAlts _lhsOpps) ) -- cata {-# NOINLINE sem_CaseAlts #-} sem_CaseAlts :: CaseAlts -> T_CaseAlts sem_CaseAlts list = Prelude.foldr sem_CaseAlts_Cons sem_CaseAlts_Nil (Prelude.map sem_CaseAlt list) -- semantic domain newtype T_CaseAlts = T_CaseAlts { attach_T_CaseAlts :: Identity (T_CaseAlts_s5 ) } newtype T_CaseAlts_s5 = C_CaseAlts_s5 { inv_CaseAlts_s5 :: (T_CaseAlts_v4 ) } data T_CaseAlts_s6 = C_CaseAlts_s6 type T_CaseAlts_v4 = (T_CaseAlts_vIn4 ) -> (T_CaseAlts_vOut4 ) data T_CaseAlts_vIn4 = T_CaseAlts_vIn4 (Options) data T_CaseAlts_vOut4 = T_CaseAlts_vOut4 (PP_Docs) {-# NOINLINE sem_CaseAlts_Cons #-} sem_CaseAlts_Cons :: T_CaseAlt -> T_CaseAlts -> T_CaseAlts sem_CaseAlts_Cons arg_hd_ arg_tl_ = T_CaseAlts (return st5) where {-# NOINLINE st5 #-} !st5 = let v4 :: T_CaseAlts_v4 v4 = \ !(T_CaseAlts_vIn4 _lhsIoptions) -> ( let _hdX2 = Control.Monad.Identity.runIdentity (attach_T_CaseAlt (arg_hd_)) _tlX5 = Control.Monad.Identity.runIdentity (attach_T_CaseAlts (arg_tl_)) (T_CaseAlt_vOut1 _hdIpp) = inv_CaseAlt_s2 _hdX2 (T_CaseAlt_vIn1 _hdOoptions) (T_CaseAlts_vOut4 _tlIpps) = inv_CaseAlts_s5 _tlX5 (T_CaseAlts_vIn4 _tlOoptions) _lhsOpps :: PP_Docs _lhsOpps = rule3 _hdIpp _tlIpps _hdOoptions = rule4 _lhsIoptions _tlOoptions = rule5 _lhsIoptions !__result_ = T_CaseAlts_vOut4 _lhsOpps in __result_ ) in C_CaseAlts_s5 v4 {-# INLINE rule3 #-} {-# LINE 65 "./src-ag/PrintOcamlCode.ag" #-} rule3 = \ ((_hdIpp) :: PP_Doc) ((_tlIpps) :: PP_Docs) -> {-# LINE 65 "./src-ag/PrintOcamlCode.ag" #-} _hdIpp : _tlIpps {-# LINE 193 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule4 #-} rule4 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule5 #-} rule5 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_CaseAlts_Nil #-} sem_CaseAlts_Nil :: T_CaseAlts sem_CaseAlts_Nil = T_CaseAlts (return st5) where {-# NOINLINE st5 #-} !st5 = let v4 :: T_CaseAlts_v4 v4 = \ !(T_CaseAlts_vIn4 _lhsIoptions) -> ( let _lhsOpps :: PP_Docs _lhsOpps = rule6 () !__result_ = T_CaseAlts_vOut4 _lhsOpps in __result_ ) in C_CaseAlts_s5 v4 {-# INLINE rule6 #-} {-# LINE 66 "./src-ag/PrintOcamlCode.ag" #-} rule6 = \ (_ :: ()) -> {-# LINE 66 "./src-ag/PrintOcamlCode.ag" #-} [] {-# LINE 217 "dist/build/PrintOcamlCode.hs"#-} -- Chunk ------------------------------------------------------- -- wrapper data Inh_Chunk = Inh_Chunk { isToplevel_Inh_Chunk :: !(Bool), options_Inh_Chunk :: !(Options), textBlockMap_Inh_Chunk :: !(Map BlockInfo PP_Doc) } data Syn_Chunk = Syn_Chunk { pps_Syn_Chunk :: !(PP_Docs) } {-# INLINABLE wrap_Chunk #-} wrap_Chunk :: T_Chunk -> Inh_Chunk -> (Syn_Chunk ) wrap_Chunk !(T_Chunk act) !(Inh_Chunk _lhsIisToplevel _lhsIoptions _lhsItextBlockMap) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Chunk_vIn7 _lhsIisToplevel _lhsIoptions _lhsItextBlockMap !(T_Chunk_vOut7 _lhsOpps) <- return (inv_Chunk_s8 sem arg) return (Syn_Chunk _lhsOpps) ) -- cata {-# INLINE sem_Chunk #-} sem_Chunk :: Chunk -> T_Chunk sem_Chunk ( Chunk !name_ comment_ info_ dataDef_ cataFun_ semDom_ semWrapper_ semFunctions_ !semNames_ ) = sem_Chunk_Chunk name_ ( sem_Decl comment_ ) ( sem_Decls info_ ) ( sem_Decls dataDef_ ) ( sem_Decls cataFun_ ) ( sem_Decls semDom_ ) ( sem_Decls semWrapper_ ) ( sem_Decls semFunctions_ ) semNames_ -- semantic domain newtype T_Chunk = T_Chunk { attach_T_Chunk :: Identity (T_Chunk_s8 ) } newtype T_Chunk_s8 = C_Chunk_s8 { inv_Chunk_s8 :: (T_Chunk_v7 ) } data T_Chunk_s9 = C_Chunk_s9 type T_Chunk_v7 = (T_Chunk_vIn7 ) -> (T_Chunk_vOut7 ) data T_Chunk_vIn7 = T_Chunk_vIn7 (Bool) (Options) (Map BlockInfo PP_Doc) data T_Chunk_vOut7 = T_Chunk_vOut7 (PP_Docs) {-# NOINLINE sem_Chunk_Chunk #-} sem_Chunk_Chunk :: (String) -> T_Decl -> T_Decls -> T_Decls -> T_Decls -> T_Decls -> T_Decls -> T_Decls -> ([String]) -> T_Chunk sem_Chunk_Chunk !arg_name_ arg_comment_ arg_info_ arg_dataDef_ arg_cataFun_ arg_semDom_ arg_semWrapper_ arg_semFunctions_ _ = T_Chunk (return st8) where {-# NOINLINE st8 #-} !st8 = let v7 :: T_Chunk_v7 v7 = \ !(T_Chunk_vIn7 _lhsIisToplevel _lhsIoptions _lhsItextBlockMap) -> ( let _commentX20 = Control.Monad.Identity.runIdentity (attach_T_Decl (arg_comment_)) _infoX23 = Control.Monad.Identity.runIdentity (attach_T_Decls (arg_info_)) _dataDefX23 = Control.Monad.Identity.runIdentity (attach_T_Decls (arg_dataDef_)) _cataFunX23 = Control.Monad.Identity.runIdentity (attach_T_Decls (arg_cataFun_)) _semDomX23 = Control.Monad.Identity.runIdentity (attach_T_Decls (arg_semDom_)) _semWrapperX23 = Control.Monad.Identity.runIdentity (attach_T_Decls (arg_semWrapper_)) _semFunctionsX23 = Control.Monad.Identity.runIdentity (attach_T_Decls (arg_semFunctions_)) (T_Decl_vOut19 _commentIpp) = inv_Decl_s20 _commentX20 (T_Decl_vIn19 _commentOisToplevel _commentOoptions) (T_Decls_vOut22 _infoIpps) = inv_Decls_s23 _infoX23 (T_Decls_vIn22 _infoOisToplevel _infoOoptions) (T_Decls_vOut22 _dataDefIpps) = inv_Decls_s23 _dataDefX23 (T_Decls_vIn22 _dataDefOisToplevel _dataDefOoptions) (T_Decls_vOut22 _cataFunIpps) = inv_Decls_s23 _cataFunX23 (T_Decls_vIn22 _cataFunOisToplevel _cataFunOoptions) (T_Decls_vOut22 _semDomIpps) = inv_Decls_s23 _semDomX23 (T_Decls_vIn22 _semDomOisToplevel _semDomOoptions) (T_Decls_vOut22 _semWrapperIpps) = inv_Decls_s23 _semWrapperX23 (T_Decls_vIn22 _semWrapperOisToplevel _semWrapperOoptions) (T_Decls_vOut22 _semFunctionsIpps) = inv_Decls_s23 _semFunctionsX23 (T_Decls_vIn22 _semFunctionsOisToplevel _semFunctionsOoptions) _lhsOpps :: PP_Docs _lhsOpps = rule7 _cataFunIpps _commentIpp _dataDefIpps _infoIpps _lhsItextBlockMap _semDomIpps _semFunctionsIpps _semWrapperIpps arg_name_ _commentOisToplevel = rule8 _lhsIisToplevel _commentOoptions = rule9 _lhsIoptions _infoOisToplevel = rule10 _lhsIisToplevel _infoOoptions = rule11 _lhsIoptions _dataDefOisToplevel = rule12 _lhsIisToplevel _dataDefOoptions = rule13 _lhsIoptions _cataFunOisToplevel = rule14 _lhsIisToplevel _cataFunOoptions = rule15 _lhsIoptions _semDomOisToplevel = rule16 _lhsIisToplevel _semDomOoptions = rule17 _lhsIoptions _semWrapperOisToplevel = rule18 _lhsIisToplevel _semWrapperOoptions = rule19 _lhsIoptions _semFunctionsOisToplevel = rule20 _lhsIisToplevel _semFunctionsOoptions = rule21 _lhsIoptions !__result_ = T_Chunk_vOut7 _lhsOpps in __result_ ) in C_Chunk_s8 v7 {-# INLINE rule7 #-} {-# LINE 97 "./src-ag/PrintOcamlCode.ag" #-} rule7 = \ ((_cataFunIpps) :: PP_Docs) ((_commentIpp) :: PP_Doc) ((_dataDefIpps) :: PP_Docs) ((_infoIpps) :: PP_Docs) ((_lhsItextBlockMap) :: Map BlockInfo PP_Doc) ((_semDomIpps) :: PP_Docs) ((_semFunctionsIpps) :: PP_Docs) ((_semWrapperIpps) :: PP_Docs) name_ -> {-# LINE 97 "./src-ag/PrintOcamlCode.ag" #-} _commentIpp : _infoIpps ++ _dataDefIpps ++ _semDomIpps ++ _semFunctionsIpps ++ _semWrapperIpps ++ _cataFunIpps ++ [Map.findWithDefault empty (BlockOther, Just $ identifier name_) _lhsItextBlockMap] {-# LINE 301 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule8 #-} rule8 = \ ((_lhsIisToplevel) :: Bool) -> _lhsIisToplevel {-# INLINE rule9 #-} rule9 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule10 #-} rule10 = \ ((_lhsIisToplevel) :: Bool) -> _lhsIisToplevel {-# INLINE rule11 #-} rule11 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule12 #-} rule12 = \ ((_lhsIisToplevel) :: Bool) -> _lhsIisToplevel {-# INLINE rule13 #-} rule13 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule14 #-} rule14 = \ ((_lhsIisToplevel) :: Bool) -> _lhsIisToplevel {-# INLINE rule15 #-} rule15 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule16 #-} rule16 = \ ((_lhsIisToplevel) :: Bool) -> _lhsIisToplevel {-# INLINE rule17 #-} rule17 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule18 #-} rule18 = \ ((_lhsIisToplevel) :: Bool) -> _lhsIisToplevel {-# INLINE rule19 #-} rule19 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule20 #-} rule20 = \ ((_lhsIisToplevel) :: Bool) -> _lhsIisToplevel {-# INLINE rule21 #-} rule21 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions -- Chunks ------------------------------------------------------ -- wrapper data Inh_Chunks = Inh_Chunks { isToplevel_Inh_Chunks :: !(Bool), options_Inh_Chunks :: !(Options), textBlockMap_Inh_Chunks :: !(Map BlockInfo PP_Doc) } data Syn_Chunks = Syn_Chunks { pps_Syn_Chunks :: !(PP_Docs) } {-# INLINABLE wrap_Chunks #-} wrap_Chunks :: T_Chunks -> Inh_Chunks -> (Syn_Chunks ) wrap_Chunks !(T_Chunks act) !(Inh_Chunks _lhsIisToplevel _lhsIoptions _lhsItextBlockMap) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Chunks_vIn10 _lhsIisToplevel _lhsIoptions _lhsItextBlockMap !(T_Chunks_vOut10 _lhsOpps) <- return (inv_Chunks_s11 sem arg) return (Syn_Chunks _lhsOpps) ) -- cata {-# NOINLINE sem_Chunks #-} sem_Chunks :: Chunks -> T_Chunks sem_Chunks list = Prelude.foldr sem_Chunks_Cons sem_Chunks_Nil (Prelude.map sem_Chunk list) -- semantic domain newtype T_Chunks = T_Chunks { attach_T_Chunks :: Identity (T_Chunks_s11 ) } newtype T_Chunks_s11 = C_Chunks_s11 { inv_Chunks_s11 :: (T_Chunks_v10 ) } data T_Chunks_s12 = C_Chunks_s12 type T_Chunks_v10 = (T_Chunks_vIn10 ) -> (T_Chunks_vOut10 ) data T_Chunks_vIn10 = T_Chunks_vIn10 (Bool) (Options) (Map BlockInfo PP_Doc) data T_Chunks_vOut10 = T_Chunks_vOut10 (PP_Docs) {-# NOINLINE sem_Chunks_Cons #-} sem_Chunks_Cons :: T_Chunk -> T_Chunks -> T_Chunks sem_Chunks_Cons arg_hd_ arg_tl_ = T_Chunks (return st11) where {-# NOINLINE st11 #-} !st11 = let v10 :: T_Chunks_v10 v10 = \ !(T_Chunks_vIn10 _lhsIisToplevel _lhsIoptions _lhsItextBlockMap) -> ( let _hdX8 = Control.Monad.Identity.runIdentity (attach_T_Chunk (arg_hd_)) _tlX11 = Control.Monad.Identity.runIdentity (attach_T_Chunks (arg_tl_)) (T_Chunk_vOut7 _hdIpps) = inv_Chunk_s8 _hdX8 (T_Chunk_vIn7 _hdOisToplevel _hdOoptions _hdOtextBlockMap) (T_Chunks_vOut10 _tlIpps) = inv_Chunks_s11 _tlX11 (T_Chunks_vIn10 _tlOisToplevel _tlOoptions _tlOtextBlockMap) _lhsOpps :: PP_Docs _lhsOpps = rule22 _hdIpps _tlIpps _hdOisToplevel = rule23 _lhsIisToplevel _hdOoptions = rule24 _lhsIoptions _hdOtextBlockMap = rule25 _lhsItextBlockMap _tlOisToplevel = rule26 _lhsIisToplevel _tlOoptions = rule27 _lhsIoptions _tlOtextBlockMap = rule28 _lhsItextBlockMap !__result_ = T_Chunks_vOut10 _lhsOpps in __result_ ) in C_Chunks_s11 v10 {-# INLINE rule22 #-} {-# LINE 85 "./src-ag/PrintOcamlCode.ag" #-} rule22 = \ ((_hdIpps) :: PP_Docs) ((_tlIpps) :: PP_Docs) -> {-# LINE 85 "./src-ag/PrintOcamlCode.ag" #-} _hdIpps ++ _tlIpps {-# LINE 402 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule23 #-} rule23 = \ ((_lhsIisToplevel) :: Bool) -> _lhsIisToplevel {-# INLINE rule24 #-} rule24 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule25 #-} rule25 = \ ((_lhsItextBlockMap) :: Map BlockInfo PP_Doc) -> _lhsItextBlockMap {-# INLINE rule26 #-} rule26 = \ ((_lhsIisToplevel) :: Bool) -> _lhsIisToplevel {-# INLINE rule27 #-} rule27 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule28 #-} rule28 = \ ((_lhsItextBlockMap) :: Map BlockInfo PP_Doc) -> _lhsItextBlockMap {-# NOINLINE sem_Chunks_Nil #-} sem_Chunks_Nil :: T_Chunks sem_Chunks_Nil = T_Chunks (return st11) where {-# NOINLINE st11 #-} !st11 = let v10 :: T_Chunks_v10 v10 = \ !(T_Chunks_vIn10 _lhsIisToplevel _lhsIoptions _lhsItextBlockMap) -> ( let _lhsOpps :: PP_Docs _lhsOpps = rule29 () !__result_ = T_Chunks_vOut10 _lhsOpps in __result_ ) in C_Chunks_s11 v10 {-# INLINE rule29 #-} {-# LINE 86 "./src-ag/PrintOcamlCode.ag" #-} rule29 = \ (_ :: ()) -> {-# LINE 86 "./src-ag/PrintOcamlCode.ag" #-} [] {-# LINE 438 "dist/build/PrintOcamlCode.hs"#-} -- DataAlt ----------------------------------------------------- -- wrapper data Inh_DataAlt = Inh_DataAlt { } data Syn_DataAlt = Syn_DataAlt { pp_Syn_DataAlt :: !(PP_Doc) } {-# INLINABLE wrap_DataAlt #-} wrap_DataAlt :: T_DataAlt -> Inh_DataAlt -> (Syn_DataAlt ) wrap_DataAlt !(T_DataAlt act) !(Inh_DataAlt ) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_DataAlt_vIn13 !(T_DataAlt_vOut13 _lhsOpp) <- return (inv_DataAlt_s14 sem arg) return (Syn_DataAlt _lhsOpp) ) -- cata {-# NOINLINE sem_DataAlt #-} sem_DataAlt :: DataAlt -> T_DataAlt sem_DataAlt ( DataAlt !name_ args_ ) = sem_DataAlt_DataAlt name_ ( sem_Types args_ ) sem_DataAlt ( Record !name_ args_ ) = sem_DataAlt_Record name_ ( sem_NamedTypes args_ ) -- semantic domain newtype T_DataAlt = T_DataAlt { attach_T_DataAlt :: Identity (T_DataAlt_s14 ) } newtype T_DataAlt_s14 = C_DataAlt_s14 { inv_DataAlt_s14 :: (T_DataAlt_v13 ) } data T_DataAlt_s15 = C_DataAlt_s15 type T_DataAlt_v13 = (T_DataAlt_vIn13 ) -> (T_DataAlt_vOut13 ) data T_DataAlt_vIn13 = T_DataAlt_vIn13 data T_DataAlt_vOut13 = T_DataAlt_vOut13 (PP_Doc) {-# NOINLINE sem_DataAlt_DataAlt #-} sem_DataAlt_DataAlt :: (String) -> T_Types -> T_DataAlt sem_DataAlt_DataAlt !arg_name_ arg_args_ = T_DataAlt (return st14) where {-# NOINLINE st14 #-} !st14 = let v13 :: T_DataAlt_v13 v13 = \ !(T_DataAlt_vIn13 ) -> ( let _argsX53 = Control.Monad.Identity.runIdentity (attach_T_Types (arg_args_)) (T_Types_vOut52 _argsIpps) = inv_Types_s53 _argsX53 (T_Types_vIn52 ) _lhsOpp :: PP_Doc _lhsOpp = rule30 _argsIpps arg_name_ !__result_ = T_DataAlt_vOut13 _lhsOpp in __result_ ) in C_DataAlt_s14 v13 {-# INLINE rule30 #-} {-# LINE 185 "./src-ag/PrintOcamlCode.ag" #-} rule30 = \ ((_argsIpps) :: PP_Docs) name_ -> {-# LINE 185 "./src-ag/PrintOcamlCode.ag" #-} name_ >#< "of" >#< pp_block "" "" " * " (map pp_parens _argsIpps) {-# LINE 490 "dist/build/PrintOcamlCode.hs"#-} {-# NOINLINE sem_DataAlt_Record #-} sem_DataAlt_Record :: (String) -> T_NamedTypes -> T_DataAlt sem_DataAlt_Record _ arg_args_ = T_DataAlt (return st14) where {-# NOINLINE st14 #-} !st14 = let v13 :: T_DataAlt_v13 v13 = \ !(T_DataAlt_vIn13 ) -> ( let _argsX38 = Control.Monad.Identity.runIdentity (attach_T_NamedTypes (arg_args_)) (T_NamedTypes_vOut37 _argsIpps) = inv_NamedTypes_s38 _argsX38 (T_NamedTypes_vIn37 ) _lhsOpp :: PP_Doc _lhsOpp = rule31 _argsIpps !__result_ = T_DataAlt_vOut13 _lhsOpp in __result_ ) in C_DataAlt_s14 v13 {-# INLINE rule31 #-} {-# LINE 186 "./src-ag/PrintOcamlCode.ag" #-} rule31 = \ ((_argsIpps) :: PP_Docs) -> {-# LINE 186 "./src-ag/PrintOcamlCode.ag" #-} pp_block "{" "}" ";" _argsIpps {-# LINE 510 "dist/build/PrintOcamlCode.hs"#-} -- DataAlts ---------------------------------------------------- -- wrapper data Inh_DataAlts = Inh_DataAlts { } data Syn_DataAlts = Syn_DataAlts { pps_Syn_DataAlts :: !(PP_Docs) } {-# INLINABLE wrap_DataAlts #-} wrap_DataAlts :: T_DataAlts -> Inh_DataAlts -> (Syn_DataAlts ) wrap_DataAlts !(T_DataAlts act) !(Inh_DataAlts ) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_DataAlts_vIn16 !(T_DataAlts_vOut16 _lhsOpps) <- return (inv_DataAlts_s17 sem arg) return (Syn_DataAlts _lhsOpps) ) -- cata {-# NOINLINE sem_DataAlts #-} sem_DataAlts :: DataAlts -> T_DataAlts sem_DataAlts list = Prelude.foldr sem_DataAlts_Cons sem_DataAlts_Nil (Prelude.map sem_DataAlt list) -- semantic domain newtype T_DataAlts = T_DataAlts { attach_T_DataAlts :: Identity (T_DataAlts_s17 ) } newtype T_DataAlts_s17 = C_DataAlts_s17 { inv_DataAlts_s17 :: (T_DataAlts_v16 ) } data T_DataAlts_s18 = C_DataAlts_s18 type T_DataAlts_v16 = (T_DataAlts_vIn16 ) -> (T_DataAlts_vOut16 ) data T_DataAlts_vIn16 = T_DataAlts_vIn16 data T_DataAlts_vOut16 = T_DataAlts_vOut16 (PP_Docs) {-# NOINLINE sem_DataAlts_Cons #-} sem_DataAlts_Cons :: T_DataAlt -> T_DataAlts -> T_DataAlts sem_DataAlts_Cons arg_hd_ arg_tl_ = T_DataAlts (return st17) where {-# NOINLINE st17 #-} !st17 = let v16 :: T_DataAlts_v16 v16 = \ !(T_DataAlts_vIn16 ) -> ( let _hdX14 = Control.Monad.Identity.runIdentity (attach_T_DataAlt (arg_hd_)) _tlX17 = Control.Monad.Identity.runIdentity (attach_T_DataAlts (arg_tl_)) (T_DataAlt_vOut13 _hdIpp) = inv_DataAlt_s14 _hdX14 (T_DataAlt_vIn13 ) (T_DataAlts_vOut16 _tlIpps) = inv_DataAlts_s17 _tlX17 (T_DataAlts_vIn16 ) _lhsOpps :: PP_Docs _lhsOpps = rule32 _hdIpp _tlIpps !__result_ = T_DataAlts_vOut16 _lhsOpps in __result_ ) in C_DataAlts_s17 v16 {-# INLINE rule32 #-} {-# LINE 69 "./src-ag/PrintOcamlCode.ag" #-} rule32 = \ ((_hdIpp) :: PP_Doc) ((_tlIpps) :: PP_Docs) -> {-# LINE 69 "./src-ag/PrintOcamlCode.ag" #-} _hdIpp : _tlIpps {-# LINE 563 "dist/build/PrintOcamlCode.hs"#-} {-# NOINLINE sem_DataAlts_Nil #-} sem_DataAlts_Nil :: T_DataAlts sem_DataAlts_Nil = T_DataAlts (return st17) where {-# NOINLINE st17 #-} !st17 = let v16 :: T_DataAlts_v16 v16 = \ !(T_DataAlts_vIn16 ) -> ( let _lhsOpps :: PP_Docs _lhsOpps = rule33 () !__result_ = T_DataAlts_vOut16 _lhsOpps in __result_ ) in C_DataAlts_s17 v16 {-# INLINE rule33 #-} {-# LINE 70 "./src-ag/PrintOcamlCode.ag" #-} rule33 = \ (_ :: ()) -> {-# LINE 70 "./src-ag/PrintOcamlCode.ag" #-} [] {-# LINE 581 "dist/build/PrintOcamlCode.hs"#-} -- Decl -------------------------------------------------------- -- wrapper data Inh_Decl = Inh_Decl { isToplevel_Inh_Decl :: !(Bool), options_Inh_Decl :: !(Options) } data Syn_Decl = Syn_Decl { pp_Syn_Decl :: !(PP_Doc) } {-# INLINABLE wrap_Decl #-} wrap_Decl :: T_Decl -> Inh_Decl -> (Syn_Decl ) wrap_Decl !(T_Decl act) !(Inh_Decl _lhsIisToplevel _lhsIoptions) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Decl_vIn19 _lhsIisToplevel _lhsIoptions !(T_Decl_vOut19 _lhsOpp) <- return (inv_Decl_s20 sem arg) return (Syn_Decl _lhsOpp) ) -- cata {-# NOINLINE sem_Decl #-} sem_Decl :: Decl -> T_Decl sem_Decl ( Decl left_ rhs_ !binds_ !uses_ ) = sem_Decl_Decl ( sem_Lhs left_ ) ( sem_Expr rhs_ ) binds_ uses_ sem_Decl ( Bind left_ rhs_ ) = sem_Decl_Bind ( sem_Lhs left_ ) ( sem_Expr rhs_ ) sem_Decl ( BindLet left_ rhs_ ) = sem_Decl_BindLet ( sem_Lhs left_ ) ( sem_Expr rhs_ ) sem_Decl ( Data !name_ !params_ alts_ !strict_ !derivings_ ) = sem_Decl_Data name_ params_ ( sem_DataAlts alts_ ) strict_ derivings_ sem_Decl ( NewType !name_ !params_ !con_ tp_ ) = sem_Decl_NewType name_ params_ con_ ( sem_Type tp_ ) sem_Decl ( Type !name_ !params_ tp_ ) = sem_Decl_Type name_ params_ ( sem_Type tp_ ) sem_Decl ( TSig !name_ tp_ ) = sem_Decl_TSig name_ ( sem_Type tp_ ) sem_Decl ( Comment !txt_ ) = sem_Decl_Comment txt_ sem_Decl ( PragmaDecl !txt_ ) = sem_Decl_PragmaDecl txt_ sem_Decl ( Resume !monadic_ !nt_ left_ rhs_ ) = sem_Decl_Resume monadic_ nt_ ( sem_Lhs left_ ) ( sem_Expr rhs_ ) sem_Decl ( EvalDecl !nt_ left_ rhs_ ) = sem_Decl_EvalDecl nt_ ( sem_Lhs left_ ) ( sem_Expr rhs_ ) -- semantic domain newtype T_Decl = T_Decl { attach_T_Decl :: Identity (T_Decl_s20 ) } newtype T_Decl_s20 = C_Decl_s20 { inv_Decl_s20 :: (T_Decl_v19 ) } data T_Decl_s21 = C_Decl_s21 type T_Decl_v19 = (T_Decl_vIn19 ) -> (T_Decl_vOut19 ) data T_Decl_vIn19 = T_Decl_vIn19 (Bool) (Options) data T_Decl_vOut19 = T_Decl_vOut19 (PP_Doc) {-# NOINLINE sem_Decl_Decl #-} sem_Decl_Decl :: T_Lhs -> T_Expr -> (Set String) -> (Set String) -> T_Decl sem_Decl_Decl arg_left_ arg_rhs_ _ _ = T_Decl (return st20) where {-# NOINLINE st20 #-} !st20 = let v19 :: T_Decl_v19 v19 = \ !(T_Decl_vIn19 _lhsIisToplevel _lhsIoptions) -> ( let _leftX32 = Control.Monad.Identity.runIdentity (attach_T_Lhs (arg_left_)) _rhsX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_rhs_)) (T_Lhs_vOut31 _leftIpp) = inv_Lhs_s32 _leftX32 (T_Lhs_vIn31 _leftOoptions) (T_Expr_vOut25 _rhsIpp) = inv_Expr_s26 _rhsX26 (T_Expr_vIn25 _rhsOoptions) _lhsOpp :: PP_Doc _lhsOpp = rule34 _leftIpp _lhsIisToplevel _rhsIpp _leftOoptions = rule35 _lhsIoptions _rhsOoptions = rule36 _lhsIoptions !__result_ = T_Decl_vOut19 _lhsOpp in __result_ ) in C_Decl_s20 v19 {-# INLINE rule34 #-} {-# LINE 107 "./src-ag/PrintOcamlCode.ag" #-} rule34 = \ ((_leftIpp) :: PP_Doc) ((_lhsIisToplevel) :: Bool) ((_rhsIpp) :: PP_Doc) -> {-# LINE 107 "./src-ag/PrintOcamlCode.ag" #-} if _lhsIisToplevel then "let" >#< _leftIpp >#< "=" >-< indent 4 _rhsIpp >#< ";;" else "let" >#< _leftIpp >#< "=" >-< indent 4 _rhsIpp >#< "in" {-# LINE 650 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule35 #-} rule35 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule36 #-} rule36 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Decl_Bind #-} sem_Decl_Bind :: T_Lhs -> T_Expr -> T_Decl sem_Decl_Bind arg_left_ arg_rhs_ = T_Decl (return st20) where {-# NOINLINE st20 #-} !st20 = let v19 :: T_Decl_v19 v19 = \ !(T_Decl_vIn19 _lhsIisToplevel _lhsIoptions) -> ( let _leftX32 = Control.Monad.Identity.runIdentity (attach_T_Lhs (arg_left_)) _rhsX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_rhs_)) (T_Lhs_vOut31 _leftIpp) = inv_Lhs_s32 _leftX32 (T_Lhs_vIn31 _leftOoptions) (T_Expr_vOut25 _rhsIpp) = inv_Expr_s26 _rhsX26 (T_Expr_vIn25 _rhsOoptions) _lhsOpp :: PP_Doc _lhsOpp = rule37 () _leftOoptions = rule38 _lhsIoptions _rhsOoptions = rule39 _lhsIoptions !__result_ = T_Decl_vOut19 _lhsOpp in __result_ ) in C_Decl_s20 v19 {-# INLINE rule37 #-} {-# LINE 112 "./src-ag/PrintOcamlCode.ag" #-} rule37 = \ (_ :: ()) -> {-# LINE 112 "./src-ag/PrintOcamlCode.ag" #-} error "pp of Decl.Bind not supported" {-# LINE 680 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule38 #-} rule38 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule39 #-} rule39 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Decl_BindLet #-} sem_Decl_BindLet :: T_Lhs -> T_Expr -> T_Decl sem_Decl_BindLet arg_left_ arg_rhs_ = T_Decl (return st20) where {-# NOINLINE st20 #-} !st20 = let v19 :: T_Decl_v19 v19 = \ !(T_Decl_vIn19 _lhsIisToplevel _lhsIoptions) -> ( let _leftX32 = Control.Monad.Identity.runIdentity (attach_T_Lhs (arg_left_)) _rhsX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_rhs_)) (T_Lhs_vOut31 _leftIpp) = inv_Lhs_s32 _leftX32 (T_Lhs_vIn31 _leftOoptions) (T_Expr_vOut25 _rhsIpp) = inv_Expr_s26 _rhsX26 (T_Expr_vIn25 _rhsOoptions) _lhsOpp :: PP_Doc _lhsOpp = rule40 () _leftOoptions = rule41 _lhsIoptions _rhsOoptions = rule42 _lhsIoptions !__result_ = T_Decl_vOut19 _lhsOpp in __result_ ) in C_Decl_s20 v19 {-# INLINE rule40 #-} {-# LINE 113 "./src-ag/PrintOcamlCode.ag" #-} rule40 = \ (_ :: ()) -> {-# LINE 113 "./src-ag/PrintOcamlCode.ag" #-} error "pp of Decl.BindLet not supported" {-# LINE 710 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule41 #-} rule41 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule42 #-} rule42 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Decl_Data #-} sem_Decl_Data :: (String) -> ([String]) -> T_DataAlts -> (Bool) -> ([String]) -> T_Decl sem_Decl_Data !arg_name_ !arg_params_ arg_alts_ _ _ = T_Decl (return st20) where {-# NOINLINE st20 #-} !st20 = let v19 :: T_Decl_v19 v19 = \ !(T_Decl_vIn19 _lhsIisToplevel _lhsIoptions) -> ( let _altsX17 = Control.Monad.Identity.runIdentity (attach_T_DataAlts (arg_alts_)) (T_DataAlts_vOut16 _altsIpps) = inv_DataAlts_s17 _altsX17 (T_DataAlts_vIn16 ) _lhsOpp :: PP_Doc _lhsOpp = rule43 _altsIpps arg_name_ arg_params_ !__result_ = T_Decl_vOut19 _lhsOpp in __result_ ) in C_Decl_s20 v19 {-# INLINE rule43 #-} {-# LINE 114 "./src-ag/PrintOcamlCode.ag" #-} rule43 = \ ((_altsIpps) :: PP_Docs) name_ params_ -> {-# LINE 114 "./src-ag/PrintOcamlCode.ag" #-} "type" >#< hv_sp (map (\p -> "'" >|< p) params_ ++ [text $ toOcamlTC name_]) >#< ( case _altsIpps of [] -> empty (x:xs) -> "=" >#< x >-< vlist (map ("|" >#<) xs) ) >#< ";;" {-# LINE 742 "dist/build/PrintOcamlCode.hs"#-} {-# NOINLINE sem_Decl_NewType #-} sem_Decl_NewType :: (String) -> ([String]) -> (String) -> T_Type -> T_Decl sem_Decl_NewType _ _ _ arg_tp_ = T_Decl (return st20) where {-# NOINLINE st20 #-} !st20 = let v19 :: T_Decl_v19 v19 = \ !(T_Decl_vIn19 _lhsIisToplevel _lhsIoptions) -> ( let _tpX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_tp_)) (T_Type_vOut49 _tpIpp) = inv_Type_s50 _tpX50 (T_Type_vIn49 ) _lhsOpp :: PP_Doc _lhsOpp = rule44 () !__result_ = T_Decl_vOut19 _lhsOpp in __result_ ) in C_Decl_s20 v19 {-# INLINE rule44 #-} {-# LINE 121 "./src-ag/PrintOcamlCode.ag" #-} rule44 = \ (_ :: ()) -> {-# LINE 121 "./src-ag/PrintOcamlCode.ag" #-} error "pp of Decl.NewType not supported" {-# LINE 762 "dist/build/PrintOcamlCode.hs"#-} {-# NOINLINE sem_Decl_Type #-} sem_Decl_Type :: (String) -> ([String]) -> T_Type -> T_Decl sem_Decl_Type !arg_name_ !arg_params_ arg_tp_ = T_Decl (return st20) where {-# NOINLINE st20 #-} !st20 = let v19 :: T_Decl_v19 v19 = \ !(T_Decl_vIn19 _lhsIisToplevel _lhsIoptions) -> ( let _tpX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_tp_)) (T_Type_vOut49 _tpIpp) = inv_Type_s50 _tpX50 (T_Type_vIn49 ) _lhsOpp :: PP_Doc _lhsOpp = rule45 _tpIpp arg_name_ arg_params_ !__result_ = T_Decl_vOut19 _lhsOpp in __result_ ) in C_Decl_s20 v19 {-# INLINE rule45 #-} {-# LINE 122 "./src-ag/PrintOcamlCode.ag" #-} rule45 = \ ((_tpIpp) :: PP_Doc) name_ params_ -> {-# LINE 122 "./src-ag/PrintOcamlCode.ag" #-} "type" >#< hv_sp (map (\p -> "'" >|< p) params_ ++ [text $ toOcamlTC name_]) >#< "=" >#< _tpIpp >#< ";;" {-# LINE 782 "dist/build/PrintOcamlCode.hs"#-} {-# NOINLINE sem_Decl_TSig #-} sem_Decl_TSig :: (String) -> T_Type -> T_Decl sem_Decl_TSig !arg_name_ arg_tp_ = T_Decl (return st20) where {-# NOINLINE st20 #-} !st20 = let v19 :: T_Decl_v19 v19 = \ !(T_Decl_vIn19 _lhsIisToplevel _lhsIoptions) -> ( let _tpX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_tp_)) (T_Type_vOut49 _tpIpp) = inv_Type_s50 _tpX50 (T_Type_vIn49 ) _lhsOpp :: PP_Doc _lhsOpp = rule46 _tpIpp arg_name_ !__result_ = T_Decl_vOut19 _lhsOpp in __result_ ) in C_Decl_s20 v19 {-# INLINE rule46 #-} {-# LINE 123 "./src-ag/PrintOcamlCode.ag" #-} rule46 = \ ((_tpIpp) :: PP_Doc) name_ -> {-# LINE 123 "./src-ag/PrintOcamlCode.ag" #-} "(*" >#< name_ >#< ":" >#< _tpIpp >#< "*)" {-# LINE 802 "dist/build/PrintOcamlCode.hs"#-} {-# NOINLINE sem_Decl_Comment #-} sem_Decl_Comment :: (String) -> T_Decl sem_Decl_Comment !arg_txt_ = T_Decl (return st20) where {-# NOINLINE st20 #-} !st20 = let v19 :: T_Decl_v19 v19 = \ !(T_Decl_vIn19 _lhsIisToplevel _lhsIoptions) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule47 arg_txt_ !__result_ = T_Decl_vOut19 _lhsOpp in __result_ ) in C_Decl_s20 v19 {-# INLINE rule47 #-} {-# LINE 124 "./src-ag/PrintOcamlCode.ag" #-} rule47 = \ txt_ -> {-# LINE 124 "./src-ag/PrintOcamlCode.ag" #-} if '\n' `elem` txt_ then "(* " >-< vlist (lines txt_) >-< "*)" else "(*" >#< txt_ >#< "*)" {-# LINE 822 "dist/build/PrintOcamlCode.hs"#-} {-# NOINLINE sem_Decl_PragmaDecl #-} sem_Decl_PragmaDecl :: (String) -> T_Decl sem_Decl_PragmaDecl _ = T_Decl (return st20) where {-# NOINLINE st20 #-} !st20 = let v19 :: T_Decl_v19 v19 = \ !(T_Decl_vIn19 _lhsIisToplevel _lhsIoptions) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule48 () !__result_ = T_Decl_vOut19 _lhsOpp in __result_ ) in C_Decl_s20 v19 {-# INLINE rule48 #-} {-# LINE 127 "./src-ag/PrintOcamlCode.ag" #-} rule48 = \ (_ :: ()) -> {-# LINE 127 "./src-ag/PrintOcamlCode.ag" #-} error "pp of Decl.PragmaDecl not supported" {-# LINE 840 "dist/build/PrintOcamlCode.hs"#-} {-# NOINLINE sem_Decl_Resume #-} sem_Decl_Resume :: (Bool) -> (String) -> T_Lhs -> T_Expr -> T_Decl sem_Decl_Resume _ _ arg_left_ arg_rhs_ = T_Decl (return st20) where {-# NOINLINE st20 #-} !st20 = let v19 :: T_Decl_v19 v19 = \ !(T_Decl_vIn19 _lhsIisToplevel _lhsIoptions) -> ( let _leftX32 = Control.Monad.Identity.runIdentity (attach_T_Lhs (arg_left_)) _rhsX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_rhs_)) (T_Lhs_vOut31 _leftIpp) = inv_Lhs_s32 _leftX32 (T_Lhs_vIn31 _leftOoptions) (T_Expr_vOut25 _rhsIpp) = inv_Expr_s26 _rhsX26 (T_Expr_vIn25 _rhsOoptions) _lhsOpp :: PP_Doc _lhsOpp = rule49 _rhsIpp _leftOoptions = rule50 _lhsIoptions _rhsOoptions = rule51 _lhsIoptions !__result_ = T_Decl_vOut19 _lhsOpp in __result_ ) in C_Decl_s20 v19 {-# INLINE rule49 #-} rule49 = \ ((_rhsIpp) :: PP_Doc) -> _rhsIpp {-# INLINE rule50 #-} rule50 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule51 #-} rule51 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Decl_EvalDecl #-} sem_Decl_EvalDecl :: (String) -> T_Lhs -> T_Expr -> T_Decl sem_Decl_EvalDecl _ arg_left_ arg_rhs_ = T_Decl (return st20) where {-# NOINLINE st20 #-} !st20 = let v19 :: T_Decl_v19 v19 = \ !(T_Decl_vIn19 _lhsIisToplevel _lhsIoptions) -> ( let _leftX32 = Control.Monad.Identity.runIdentity (attach_T_Lhs (arg_left_)) _rhsX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_rhs_)) (T_Lhs_vOut31 _leftIpp) = inv_Lhs_s32 _leftX32 (T_Lhs_vIn31 _leftOoptions) (T_Expr_vOut25 _rhsIpp) = inv_Expr_s26 _rhsX26 (T_Expr_vIn25 _rhsOoptions) _lhsOpp :: PP_Doc _lhsOpp = rule52 _rhsIpp _leftOoptions = rule53 _lhsIoptions _rhsOoptions = rule54 _lhsIoptions !__result_ = T_Decl_vOut19 _lhsOpp in __result_ ) in C_Decl_s20 v19 {-# INLINE rule52 #-} rule52 = \ ((_rhsIpp) :: PP_Doc) -> _rhsIpp {-# INLINE rule53 #-} rule53 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule54 #-} rule54 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions -- Decls ------------------------------------------------------- -- wrapper data Inh_Decls = Inh_Decls { isToplevel_Inh_Decls :: !(Bool), options_Inh_Decls :: !(Options) } data Syn_Decls = Syn_Decls { pps_Syn_Decls :: !(PP_Docs) } {-# INLINABLE wrap_Decls #-} wrap_Decls :: T_Decls -> Inh_Decls -> (Syn_Decls ) wrap_Decls !(T_Decls act) !(Inh_Decls _lhsIisToplevel _lhsIoptions) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Decls_vIn22 _lhsIisToplevel _lhsIoptions !(T_Decls_vOut22 _lhsOpps) <- return (inv_Decls_s23 sem arg) return (Syn_Decls _lhsOpps) ) -- cata {-# NOINLINE sem_Decls #-} sem_Decls :: Decls -> T_Decls sem_Decls list = Prelude.foldr sem_Decls_Cons sem_Decls_Nil (Prelude.map sem_Decl list) -- semantic domain newtype T_Decls = T_Decls { attach_T_Decls :: Identity (T_Decls_s23 ) } newtype T_Decls_s23 = C_Decls_s23 { inv_Decls_s23 :: (T_Decls_v22 ) } data T_Decls_s24 = C_Decls_s24 type T_Decls_v22 = (T_Decls_vIn22 ) -> (T_Decls_vOut22 ) data T_Decls_vIn22 = T_Decls_vIn22 (Bool) (Options) data T_Decls_vOut22 = T_Decls_vOut22 (PP_Docs) {-# NOINLINE sem_Decls_Cons #-} sem_Decls_Cons :: T_Decl -> T_Decls -> T_Decls sem_Decls_Cons arg_hd_ arg_tl_ = T_Decls (return st23) where {-# NOINLINE st23 #-} !st23 = let v22 :: T_Decls_v22 v22 = \ !(T_Decls_vIn22 _lhsIisToplevel _lhsIoptions) -> ( let _hdX20 = Control.Monad.Identity.runIdentity (attach_T_Decl (arg_hd_)) _tlX23 = Control.Monad.Identity.runIdentity (attach_T_Decls (arg_tl_)) (T_Decl_vOut19 _hdIpp) = inv_Decl_s20 _hdX20 (T_Decl_vIn19 _hdOisToplevel _hdOoptions) (T_Decls_vOut22 _tlIpps) = inv_Decls_s23 _tlX23 (T_Decls_vIn22 _tlOisToplevel _tlOoptions) _lhsOpps :: PP_Docs _lhsOpps = rule55 _hdIpp _tlIpps _hdOisToplevel = rule56 _lhsIisToplevel _hdOoptions = rule57 _lhsIoptions _tlOisToplevel = rule58 _lhsIisToplevel _tlOoptions = rule59 _lhsIoptions !__result_ = T_Decls_vOut22 _lhsOpps in __result_ ) in C_Decls_s23 v22 {-# INLINE rule55 #-} {-# LINE 81 "./src-ag/PrintOcamlCode.ag" #-} rule55 = \ ((_hdIpp) :: PP_Doc) ((_tlIpps) :: PP_Docs) -> {-# LINE 81 "./src-ag/PrintOcamlCode.ag" #-} _hdIpp : _tlIpps {-# LINE 951 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule56 #-} rule56 = \ ((_lhsIisToplevel) :: Bool) -> _lhsIisToplevel {-# INLINE rule57 #-} rule57 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule58 #-} rule58 = \ ((_lhsIisToplevel) :: Bool) -> _lhsIisToplevel {-# INLINE rule59 #-} rule59 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Decls_Nil #-} sem_Decls_Nil :: T_Decls sem_Decls_Nil = T_Decls (return st23) where {-# NOINLINE st23 #-} !st23 = let v22 :: T_Decls_v22 v22 = \ !(T_Decls_vIn22 _lhsIisToplevel _lhsIoptions) -> ( let _lhsOpps :: PP_Docs _lhsOpps = rule60 () !__result_ = T_Decls_vOut22 _lhsOpps in __result_ ) in C_Decls_s23 v22 {-# INLINE rule60 #-} {-# LINE 82 "./src-ag/PrintOcamlCode.ag" #-} rule60 = \ (_ :: ()) -> {-# LINE 82 "./src-ag/PrintOcamlCode.ag" #-} [] {-# LINE 981 "dist/build/PrintOcamlCode.hs"#-} -- Expr -------------------------------------------------------- -- wrapper data Inh_Expr = Inh_Expr { options_Inh_Expr :: !(Options) } data Syn_Expr = Syn_Expr { pp_Syn_Expr :: !(PP_Doc) } {-# INLINABLE wrap_Expr #-} wrap_Expr :: T_Expr -> Inh_Expr -> (Syn_Expr ) wrap_Expr !(T_Expr act) !(Inh_Expr _lhsIoptions) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Expr_vIn25 _lhsIoptions !(T_Expr_vOut25 _lhsOpp) <- return (inv_Expr_s26 sem arg) return (Syn_Expr _lhsOpp) ) -- cata {-# NOINLINE sem_Expr #-} sem_Expr :: Expr -> T_Expr sem_Expr ( Let decls_ body_ ) = sem_Expr_Let ( sem_Decls decls_ ) ( sem_Expr body_ ) sem_Expr ( Case expr_ alts_ ) = sem_Expr_Case ( sem_Expr expr_ ) ( sem_CaseAlts alts_ ) sem_Expr ( Do stmts_ body_ ) = sem_Expr_Do ( sem_Decls stmts_ ) ( sem_Expr body_ ) sem_Expr ( Lambda args_ body_ ) = sem_Expr_Lambda ( sem_Exprs args_ ) ( sem_Expr body_ ) sem_Expr ( TupleExpr exprs_ ) = sem_Expr_TupleExpr ( sem_Exprs exprs_ ) sem_Expr ( UnboxedTupleExpr exprs_ ) = sem_Expr_UnboxedTupleExpr ( sem_Exprs exprs_ ) sem_Expr ( App !name_ args_ ) = sem_Expr_App name_ ( sem_Exprs args_ ) sem_Expr ( SimpleExpr !txt_ ) = sem_Expr_SimpleExpr txt_ sem_Expr ( TextExpr !lns_ ) = sem_Expr_TextExpr lns_ sem_Expr ( Trace !txt_ expr_ ) = sem_Expr_Trace txt_ ( sem_Expr expr_ ) sem_Expr ( PragmaExpr !onLeftSide_ !onNewLine_ !txt_ expr_ ) = sem_Expr_PragmaExpr onLeftSide_ onNewLine_ txt_ ( sem_Expr expr_ ) sem_Expr ( LineExpr expr_ ) = sem_Expr_LineExpr ( sem_Expr expr_ ) sem_Expr ( TypedExpr expr_ tp_ ) = sem_Expr_TypedExpr ( sem_Expr expr_ ) ( sem_Type tp_ ) sem_Expr ( ResultExpr !nt_ expr_ ) = sem_Expr_ResultExpr nt_ ( sem_Expr expr_ ) sem_Expr ( InvokeExpr !nt_ expr_ args_ ) = sem_Expr_InvokeExpr nt_ ( sem_Expr expr_ ) ( sem_Exprs args_ ) sem_Expr ( ResumeExpr !nt_ expr_ left_ rhs_ ) = sem_Expr_ResumeExpr nt_ ( sem_Expr expr_ ) ( sem_Lhs left_ ) ( sem_Expr rhs_ ) sem_Expr ( SemFun !nt_ args_ body_ ) = sem_Expr_SemFun nt_ ( sem_Exprs args_ ) ( sem_Expr body_ ) -- semantic domain newtype T_Expr = T_Expr { attach_T_Expr :: Identity (T_Expr_s26 ) } newtype T_Expr_s26 = C_Expr_s26 { inv_Expr_s26 :: (T_Expr_v25 ) } data T_Expr_s27 = C_Expr_s27 type T_Expr_v25 = (T_Expr_vIn25 ) -> (T_Expr_vOut25 ) data T_Expr_vIn25 = T_Expr_vIn25 (Options) data T_Expr_vOut25 = T_Expr_vOut25 (PP_Doc) {-# NOINLINE sem_Expr_Let #-} sem_Expr_Let :: T_Decls -> T_Expr -> T_Expr sem_Expr_Let arg_decls_ arg_body_ = T_Expr (return st26) where {-# NOINLINE st26 #-} !st26 = let v25 :: T_Expr_v25 v25 = \ !(T_Expr_vIn25 _lhsIoptions) -> ( let _declsX23 = Control.Monad.Identity.runIdentity (attach_T_Decls (arg_decls_)) _bodyX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_body_)) (T_Decls_vOut22 _declsIpps) = inv_Decls_s23 _declsX23 (T_Decls_vIn22 _declsOisToplevel _declsOoptions) (T_Expr_vOut25 _bodyIpp) = inv_Expr_s26 _bodyX26 (T_Expr_vIn25 _bodyOoptions) _lhsOpp :: PP_Doc _lhsOpp = rule61 _bodyIpp _declsIpps _declsOisToplevel = rule62 () _declsOoptions = rule63 _lhsIoptions _bodyOoptions = rule64 _lhsIoptions !__result_ = T_Expr_vOut25 _lhsOpp in __result_ ) in C_Expr_s26 v25 {-# INLINE rule61 #-} {-# LINE 131 "./src-ag/PrintOcamlCode.ag" #-} rule61 = \ ((_bodyIpp) :: PP_Doc) ((_declsIpps) :: PP_Docs) -> {-# LINE 131 "./src-ag/PrintOcamlCode.ag" #-} pp_parens $ vlist (_declsIpps ++ [_bodyIpp]) {-# LINE 1053 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule62 #-} {-# LINE 218 "./src-ag/PrintOcamlCode.ag" #-} rule62 = \ (_ :: ()) -> {-# LINE 218 "./src-ag/PrintOcamlCode.ag" #-} False {-# LINE 1059 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule63 #-} rule63 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule64 #-} rule64 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Expr_Case #-} sem_Expr_Case :: T_Expr -> T_CaseAlts -> T_Expr sem_Expr_Case arg_expr_ arg_alts_ = T_Expr (return st26) where {-# NOINLINE st26 #-} !st26 = let v25 :: T_Expr_v25 v25 = \ !(T_Expr_vIn25 _lhsIoptions) -> ( let _exprX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_expr_)) _altsX5 = Control.Monad.Identity.runIdentity (attach_T_CaseAlts (arg_alts_)) (T_Expr_vOut25 _exprIpp) = inv_Expr_s26 _exprX26 (T_Expr_vIn25 _exprOoptions) (T_CaseAlts_vOut4 _altsIpps) = inv_CaseAlts_s5 _altsX5 (T_CaseAlts_vIn4 _altsOoptions) _lhsOpp :: PP_Doc _lhsOpp = rule65 _altsIpps _exprIpp _exprOoptions = rule66 _lhsIoptions _altsOoptions = rule67 _lhsIoptions !__result_ = T_Expr_vOut25 _lhsOpp in __result_ ) in C_Expr_s26 v25 {-# INLINE rule65 #-} {-# LINE 132 "./src-ag/PrintOcamlCode.ag" #-} rule65 = \ ((_altsIpps) :: PP_Docs) ((_exprIpp) :: PP_Doc) -> {-# LINE 132 "./src-ag/PrintOcamlCode.ag" #-} pp_parens ( "match" >#< _exprIpp >#< "with" >-< indent 2 ( case _altsIpps of [] -> empty (x:xs) -> " " >#< x >-< vlist (map ("|" >#<) xs) ) ) {-# LINE 1095 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule66 #-} rule66 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule67 #-} rule67 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Expr_Do #-} sem_Expr_Do :: T_Decls -> T_Expr -> T_Expr sem_Expr_Do arg_stmts_ arg_body_ = T_Expr (return st26) where {-# NOINLINE st26 #-} !st26 = let v25 :: T_Expr_v25 v25 = \ !(T_Expr_vIn25 _lhsIoptions) -> ( let _stmtsX23 = Control.Monad.Identity.runIdentity (attach_T_Decls (arg_stmts_)) _bodyX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_body_)) (T_Decls_vOut22 _stmtsIpps) = inv_Decls_s23 _stmtsX23 (T_Decls_vIn22 _stmtsOisToplevel _stmtsOoptions) (T_Expr_vOut25 _bodyIpp) = inv_Expr_s26 _bodyX26 (T_Expr_vIn25 _bodyOoptions) _lhsOpp :: PP_Doc _lhsOpp = rule68 () _stmtsOisToplevel = rule69 () _stmtsOoptions = rule70 _lhsIoptions _bodyOoptions = rule71 _lhsIoptions !__result_ = T_Expr_vOut25 _lhsOpp in __result_ ) in C_Expr_s26 v25 {-# INLINE rule68 #-} {-# LINE 139 "./src-ag/PrintOcamlCode.ag" #-} rule68 = \ (_ :: ()) -> {-# LINE 139 "./src-ag/PrintOcamlCode.ag" #-} error "pp of Expr.Do not supported" {-# LINE 1126 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule69 #-} {-# LINE 220 "./src-ag/PrintOcamlCode.ag" #-} rule69 = \ (_ :: ()) -> {-# LINE 220 "./src-ag/PrintOcamlCode.ag" #-} False {-# LINE 1132 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule70 #-} rule70 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule71 #-} rule71 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Expr_Lambda #-} sem_Expr_Lambda :: T_Exprs -> T_Expr -> T_Expr sem_Expr_Lambda arg_args_ arg_body_ = T_Expr (return st26) where {-# NOINLINE st26 #-} !st26 = let v25 :: T_Expr_v25 v25 = \ !(T_Expr_vIn25 _lhsIoptions) -> ( let _argsX29 = Control.Monad.Identity.runIdentity (attach_T_Exprs (arg_args_)) _bodyX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_body_)) (T_Exprs_vOut28 _argsIpps) = inv_Exprs_s29 _argsX29 (T_Exprs_vIn28 _argsOoptions) (T_Expr_vOut25 _bodyIpp) = inv_Expr_s26 _bodyX26 (T_Expr_vIn25 _bodyOoptions) _lhsOpp :: PP_Doc _lhsOpp = rule72 _argsIpps _bodyIpp _argsOoptions = rule73 _lhsIoptions _bodyOoptions = rule74 _lhsIoptions !__result_ = T_Expr_vOut25 _lhsOpp in __result_ ) in C_Expr_s26 v25 {-# INLINE rule72 #-} {-# LINE 140 "./src-ag/PrintOcamlCode.ag" #-} rule72 = \ ((_argsIpps) :: PP_Docs) ((_bodyIpp) :: PP_Doc) -> {-# LINE 140 "./src-ag/PrintOcamlCode.ag" #-} pp_parens ( pp "fun" >#< hv_sp _argsIpps >#< "->" >-< indent 2 _bodyIpp ) {-# LINE 1163 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule73 #-} rule73 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule74 #-} rule74 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Expr_TupleExpr #-} sem_Expr_TupleExpr :: T_Exprs -> T_Expr sem_Expr_TupleExpr arg_exprs_ = T_Expr (return st26) where {-# NOINLINE st26 #-} !st26 = let v25 :: T_Expr_v25 v25 = \ !(T_Expr_vIn25 _lhsIoptions) -> ( let _exprsX29 = Control.Monad.Identity.runIdentity (attach_T_Exprs (arg_exprs_)) (T_Exprs_vOut28 _exprsIpps) = inv_Exprs_s29 _exprsX29 (T_Exprs_vIn28 _exprsOoptions) _lhsOpp :: PP_Doc _lhsOpp = rule75 _exprsIpps _exprsOoptions = rule76 _lhsIoptions !__result_ = T_Expr_vOut25 _lhsOpp in __result_ ) in C_Expr_s26 v25 {-# INLINE rule75 #-} {-# LINE 142 "./src-ag/PrintOcamlCode.ag" #-} rule75 = \ ((_exprsIpps) :: PP_Docs) -> {-# LINE 142 "./src-ag/PrintOcamlCode.ag" #-} ppTuple False _exprsIpps {-# LINE 1190 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule76 #-} rule76 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Expr_UnboxedTupleExpr #-} sem_Expr_UnboxedTupleExpr :: T_Exprs -> T_Expr sem_Expr_UnboxedTupleExpr arg_exprs_ = T_Expr (return st26) where {-# NOINLINE st26 #-} !st26 = let v25 :: T_Expr_v25 v25 = \ !(T_Expr_vIn25 _lhsIoptions) -> ( let _exprsX29 = Control.Monad.Identity.runIdentity (attach_T_Exprs (arg_exprs_)) (T_Exprs_vOut28 _exprsIpps) = inv_Exprs_s29 _exprsX29 (T_Exprs_vIn28 _exprsOoptions) _lhsOpp :: PP_Doc _lhsOpp = rule77 () _exprsOoptions = rule78 _lhsIoptions !__result_ = T_Expr_vOut25 _lhsOpp in __result_ ) in C_Expr_s26 v25 {-# INLINE rule77 #-} {-# LINE 143 "./src-ag/PrintOcamlCode.ag" #-} rule77 = \ (_ :: ()) -> {-# LINE 143 "./src-ag/PrintOcamlCode.ag" #-} error "pp of Expr.UnboxedTupleExpr not supported" {-# LINE 1214 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule78 #-} rule78 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Expr_App #-} sem_Expr_App :: (String) -> T_Exprs -> T_Expr sem_Expr_App !arg_name_ arg_args_ = T_Expr (return st26) where {-# NOINLINE st26 #-} !st26 = let v25 :: T_Expr_v25 v25 = \ !(T_Expr_vIn25 _lhsIoptions) -> ( let _argsX29 = Control.Monad.Identity.runIdentity (attach_T_Exprs (arg_args_)) (T_Exprs_vOut28 _argsIpps) = inv_Exprs_s29 _argsX29 (T_Exprs_vIn28 _argsOoptions) _lhsOpp :: PP_Doc _lhsOpp = rule79 _argsIpps arg_name_ _argsOoptions = rule80 _lhsIoptions !__result_ = T_Expr_vOut25 _lhsOpp in __result_ ) in C_Expr_s26 v25 {-# INLINE rule79 #-} {-# LINE 144 "./src-ag/PrintOcamlCode.ag" #-} rule79 = \ ((_argsIpps) :: PP_Docs) name_ -> {-# LINE 144 "./src-ag/PrintOcamlCode.ag" #-} pp_parens $ name_ >#< hv_sp _argsIpps {-# LINE 1238 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule80 #-} rule80 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Expr_SimpleExpr #-} sem_Expr_SimpleExpr :: (String) -> T_Expr sem_Expr_SimpleExpr !arg_txt_ = T_Expr (return st26) where {-# NOINLINE st26 #-} !st26 = let v25 :: T_Expr_v25 v25 = \ !(T_Expr_vIn25 _lhsIoptions) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule81 arg_txt_ !__result_ = T_Expr_vOut25 _lhsOpp in __result_ ) in C_Expr_s26 v25 {-# INLINE rule81 #-} {-# LINE 145 "./src-ag/PrintOcamlCode.ag" #-} rule81 = \ txt_ -> {-# LINE 145 "./src-ag/PrintOcamlCode.ag" #-} text txt_ {-# LINE 1259 "dist/build/PrintOcamlCode.hs"#-} {-# NOINLINE sem_Expr_TextExpr #-} sem_Expr_TextExpr :: ([String]) -> T_Expr sem_Expr_TextExpr !arg_lns_ = T_Expr (return st26) where {-# NOINLINE st26 #-} !st26 = let v25 :: T_Expr_v25 v25 = \ !(T_Expr_vIn25 _lhsIoptions) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule82 arg_lns_ !__result_ = T_Expr_vOut25 _lhsOpp in __result_ ) in C_Expr_s26 v25 {-# INLINE rule82 #-} {-# LINE 146 "./src-ag/PrintOcamlCode.ag" #-} rule82 = \ lns_ -> {-# LINE 146 "./src-ag/PrintOcamlCode.ag" #-} vlist (map text lns_) {-# LINE 1277 "dist/build/PrintOcamlCode.hs"#-} {-# NOINLINE sem_Expr_Trace #-} sem_Expr_Trace :: (String) -> T_Expr -> T_Expr sem_Expr_Trace _ arg_expr_ = T_Expr (return st26) where {-# NOINLINE st26 #-} !st26 = let v25 :: T_Expr_v25 v25 = \ !(T_Expr_vIn25 _lhsIoptions) -> ( let _exprX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_expr_)) (T_Expr_vOut25 _exprIpp) = inv_Expr_s26 _exprX26 (T_Expr_vIn25 _exprOoptions) _lhsOpp :: PP_Doc _lhsOpp = rule83 _exprIpp _exprOoptions = rule84 _lhsIoptions !__result_ = T_Expr_vOut25 _lhsOpp in __result_ ) in C_Expr_s26 v25 {-# INLINE rule83 #-} {-# LINE 147 "./src-ag/PrintOcamlCode.ag" #-} rule83 = \ ((_exprIpp) :: PP_Doc) -> {-# LINE 147 "./src-ag/PrintOcamlCode.ag" #-} _exprIpp {-# LINE 1298 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule84 #-} rule84 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Expr_PragmaExpr #-} sem_Expr_PragmaExpr :: (Bool) -> (Bool) -> (String) -> T_Expr -> T_Expr sem_Expr_PragmaExpr _ _ _ arg_expr_ = T_Expr (return st26) where {-# NOINLINE st26 #-} !st26 = let v25 :: T_Expr_v25 v25 = \ !(T_Expr_vIn25 _lhsIoptions) -> ( let _exprX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_expr_)) (T_Expr_vOut25 _exprIpp) = inv_Expr_s26 _exprX26 (T_Expr_vIn25 _exprOoptions) _lhsOpp :: PP_Doc _lhsOpp = rule85 _exprIpp _exprOoptions = rule86 _lhsIoptions !__result_ = T_Expr_vOut25 _lhsOpp in __result_ ) in C_Expr_s26 v25 {-# INLINE rule85 #-} {-# LINE 148 "./src-ag/PrintOcamlCode.ag" #-} rule85 = \ ((_exprIpp) :: PP_Doc) -> {-# LINE 148 "./src-ag/PrintOcamlCode.ag" #-} _exprIpp {-# LINE 1322 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule86 #-} rule86 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Expr_LineExpr #-} sem_Expr_LineExpr :: T_Expr -> T_Expr sem_Expr_LineExpr arg_expr_ = T_Expr (return st26) where {-# NOINLINE st26 #-} !st26 = let v25 :: T_Expr_v25 v25 = \ !(T_Expr_vIn25 _lhsIoptions) -> ( let _exprX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_expr_)) (T_Expr_vOut25 _exprIpp) = inv_Expr_s26 _exprX26 (T_Expr_vIn25 _exprOoptions) _lhsOpp :: PP_Doc _lhsOpp = rule87 _exprIpp _exprOoptions = rule88 _lhsIoptions !__result_ = T_Expr_vOut25 _lhsOpp in __result_ ) in C_Expr_s26 v25 {-# INLINE rule87 #-} {-# LINE 149 "./src-ag/PrintOcamlCode.ag" #-} rule87 = \ ((_exprIpp) :: PP_Doc) -> {-# LINE 149 "./src-ag/PrintOcamlCode.ag" #-} _exprIpp {-# LINE 1346 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule88 #-} rule88 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Expr_TypedExpr #-} sem_Expr_TypedExpr :: T_Expr -> T_Type -> T_Expr sem_Expr_TypedExpr arg_expr_ arg_tp_ = T_Expr (return st26) where {-# NOINLINE st26 #-} !st26 = let v25 :: T_Expr_v25 v25 = \ !(T_Expr_vIn25 _lhsIoptions) -> ( let _exprX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_expr_)) _tpX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_tp_)) (T_Expr_vOut25 _exprIpp) = inv_Expr_s26 _exprX26 (T_Expr_vIn25 _exprOoptions) (T_Type_vOut49 _tpIpp) = inv_Type_s50 _tpX50 (T_Type_vIn49 ) _lhsOpp :: PP_Doc _lhsOpp = rule89 _exprIpp _exprOoptions = rule90 _lhsIoptions !__result_ = T_Expr_vOut25 _lhsOpp in __result_ ) in C_Expr_s26 v25 {-# INLINE rule89 #-} {-# LINE 150 "./src-ag/PrintOcamlCode.ag" #-} rule89 = \ ((_exprIpp) :: PP_Doc) -> {-# LINE 150 "./src-ag/PrintOcamlCode.ag" #-} _exprIpp {-# LINE 1372 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule90 #-} rule90 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Expr_ResultExpr #-} sem_Expr_ResultExpr :: (String) -> T_Expr -> T_Expr sem_Expr_ResultExpr _ arg_expr_ = T_Expr (return st26) where {-# NOINLINE st26 #-} !st26 = let v25 :: T_Expr_v25 v25 = \ !(T_Expr_vIn25 _lhsIoptions) -> ( let _exprX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_expr_)) (T_Expr_vOut25 _exprIpp) = inv_Expr_s26 _exprX26 (T_Expr_vIn25 _exprOoptions) _lhsOpp :: PP_Doc _lhsOpp = rule91 _exprIpp _exprOoptions = rule92 _lhsIoptions !__result_ = T_Expr_vOut25 _lhsOpp in __result_ ) in C_Expr_s26 v25 {-# INLINE rule91 #-} rule91 = \ ((_exprIpp) :: PP_Doc) -> _exprIpp {-# INLINE rule92 #-} rule92 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Expr_InvokeExpr #-} sem_Expr_InvokeExpr :: (String) -> T_Expr -> T_Exprs -> T_Expr sem_Expr_InvokeExpr _ arg_expr_ arg_args_ = T_Expr (return st26) where {-# NOINLINE st26 #-} !st26 = let v25 :: T_Expr_v25 v25 = \ !(T_Expr_vIn25 _lhsIoptions) -> ( let _exprX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_expr_)) _argsX29 = Control.Monad.Identity.runIdentity (attach_T_Exprs (arg_args_)) (T_Expr_vOut25 _exprIpp) = inv_Expr_s26 _exprX26 (T_Expr_vIn25 _exprOoptions) (T_Exprs_vOut28 _argsIpps) = inv_Exprs_s29 _argsX29 (T_Exprs_vIn28 _argsOoptions) _lhsOpp :: PP_Doc _lhsOpp = rule93 _exprIpp _exprOoptions = rule94 _lhsIoptions _argsOoptions = rule95 _lhsIoptions !__result_ = T_Expr_vOut25 _lhsOpp in __result_ ) in C_Expr_s26 v25 {-# INLINE rule93 #-} rule93 = \ ((_exprIpp) :: PP_Doc) -> _exprIpp {-# INLINE rule94 #-} rule94 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule95 #-} rule95 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Expr_ResumeExpr #-} sem_Expr_ResumeExpr :: (String) -> T_Expr -> T_Lhs -> T_Expr -> T_Expr sem_Expr_ResumeExpr _ arg_expr_ arg_left_ arg_rhs_ = T_Expr (return st26) where {-# NOINLINE st26 #-} !st26 = let v25 :: T_Expr_v25 v25 = \ !(T_Expr_vIn25 _lhsIoptions) -> ( let _exprX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_expr_)) _leftX32 = Control.Monad.Identity.runIdentity (attach_T_Lhs (arg_left_)) _rhsX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_rhs_)) (T_Expr_vOut25 _exprIpp) = inv_Expr_s26 _exprX26 (T_Expr_vIn25 _exprOoptions) (T_Lhs_vOut31 _leftIpp) = inv_Lhs_s32 _leftX32 (T_Lhs_vIn31 _leftOoptions) (T_Expr_vOut25 _rhsIpp) = inv_Expr_s26 _rhsX26 (T_Expr_vIn25 _rhsOoptions) _lhsOpp :: PP_Doc _lhsOpp = rule96 _rhsIpp _exprOoptions = rule97 _lhsIoptions _leftOoptions = rule98 _lhsIoptions _rhsOoptions = rule99 _lhsIoptions !__result_ = T_Expr_vOut25 _lhsOpp in __result_ ) in C_Expr_s26 v25 {-# INLINE rule96 #-} rule96 = \ ((_rhsIpp) :: PP_Doc) -> _rhsIpp {-# INLINE rule97 #-} rule97 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule98 #-} rule98 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule99 #-} rule99 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Expr_SemFun #-} sem_Expr_SemFun :: (String) -> T_Exprs -> T_Expr -> T_Expr sem_Expr_SemFun _ arg_args_ arg_body_ = T_Expr (return st26) where {-# NOINLINE st26 #-} !st26 = let v25 :: T_Expr_v25 v25 = \ !(T_Expr_vIn25 _lhsIoptions) -> ( let _argsX29 = Control.Monad.Identity.runIdentity (attach_T_Exprs (arg_args_)) _bodyX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_body_)) (T_Exprs_vOut28 _argsIpps) = inv_Exprs_s29 _argsX29 (T_Exprs_vIn28 _argsOoptions) (T_Expr_vOut25 _bodyIpp) = inv_Expr_s26 _bodyX26 (T_Expr_vIn25 _bodyOoptions) _lhsOpp :: PP_Doc _lhsOpp = rule100 _bodyIpp _argsOoptions = rule101 _lhsIoptions _bodyOoptions = rule102 _lhsIoptions !__result_ = T_Expr_vOut25 _lhsOpp in __result_ ) in C_Expr_s26 v25 {-# INLINE rule100 #-} rule100 = \ ((_bodyIpp) :: PP_Doc) -> _bodyIpp {-# INLINE rule101 #-} rule101 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule102 #-} rule102 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions -- Exprs ------------------------------------------------------- -- wrapper data Inh_Exprs = Inh_Exprs { options_Inh_Exprs :: !(Options) } data Syn_Exprs = Syn_Exprs { pps_Syn_Exprs :: !(PP_Docs) } {-# INLINABLE wrap_Exprs #-} wrap_Exprs :: T_Exprs -> Inh_Exprs -> (Syn_Exprs ) wrap_Exprs !(T_Exprs act) !(Inh_Exprs _lhsIoptions) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Exprs_vIn28 _lhsIoptions !(T_Exprs_vOut28 _lhsOpps) <- return (inv_Exprs_s29 sem arg) return (Syn_Exprs _lhsOpps) ) -- cata {-# NOINLINE sem_Exprs #-} sem_Exprs :: Exprs -> T_Exprs sem_Exprs list = Prelude.foldr sem_Exprs_Cons sem_Exprs_Nil (Prelude.map sem_Expr list) -- semantic domain newtype T_Exprs = T_Exprs { attach_T_Exprs :: Identity (T_Exprs_s29 ) } newtype T_Exprs_s29 = C_Exprs_s29 { inv_Exprs_s29 :: (T_Exprs_v28 ) } data T_Exprs_s30 = C_Exprs_s30 type T_Exprs_v28 = (T_Exprs_vIn28 ) -> (T_Exprs_vOut28 ) data T_Exprs_vIn28 = T_Exprs_vIn28 (Options) data T_Exprs_vOut28 = T_Exprs_vOut28 (PP_Docs) {-# NOINLINE sem_Exprs_Cons #-} sem_Exprs_Cons :: T_Expr -> T_Exprs -> T_Exprs sem_Exprs_Cons arg_hd_ arg_tl_ = T_Exprs (return st29) where {-# NOINLINE st29 #-} !st29 = let v28 :: T_Exprs_v28 v28 = \ !(T_Exprs_vIn28 _lhsIoptions) -> ( let _hdX26 = Control.Monad.Identity.runIdentity (attach_T_Expr (arg_hd_)) _tlX29 = Control.Monad.Identity.runIdentity (attach_T_Exprs (arg_tl_)) (T_Expr_vOut25 _hdIpp) = inv_Expr_s26 _hdX26 (T_Expr_vIn25 _hdOoptions) (T_Exprs_vOut28 _tlIpps) = inv_Exprs_s29 _tlX29 (T_Exprs_vIn28 _tlOoptions) _lhsOpps :: PP_Docs _lhsOpps = rule103 _hdIpp _tlIpps _hdOoptions = rule104 _lhsIoptions _tlOoptions = rule105 _lhsIoptions !__result_ = T_Exprs_vOut28 _lhsOpps in __result_ ) in C_Exprs_s29 v28 {-# INLINE rule103 #-} {-# LINE 61 "./src-ag/PrintOcamlCode.ag" #-} rule103 = \ ((_hdIpp) :: PP_Doc) ((_tlIpps) :: PP_Docs) -> {-# LINE 61 "./src-ag/PrintOcamlCode.ag" #-} _hdIpp : _tlIpps {-# LINE 1538 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule104 #-} rule104 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule105 #-} rule105 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Exprs_Nil #-} sem_Exprs_Nil :: T_Exprs sem_Exprs_Nil = T_Exprs (return st29) where {-# NOINLINE st29 #-} !st29 = let v28 :: T_Exprs_v28 v28 = \ !(T_Exprs_vIn28 _lhsIoptions) -> ( let _lhsOpps :: PP_Docs _lhsOpps = rule106 () !__result_ = T_Exprs_vOut28 _lhsOpps in __result_ ) in C_Exprs_s29 v28 {-# INLINE rule106 #-} {-# LINE 62 "./src-ag/PrintOcamlCode.ag" #-} rule106 = \ (_ :: ()) -> {-# LINE 62 "./src-ag/PrintOcamlCode.ag" #-} [] {-# LINE 1562 "dist/build/PrintOcamlCode.hs"#-} -- Lhs --------------------------------------------------------- -- wrapper data Inh_Lhs = Inh_Lhs { options_Inh_Lhs :: !(Options) } data Syn_Lhs = Syn_Lhs { pp_Syn_Lhs :: !(PP_Doc) } {-# INLINABLE wrap_Lhs #-} wrap_Lhs :: T_Lhs -> Inh_Lhs -> (Syn_Lhs ) wrap_Lhs !(T_Lhs act) !(Inh_Lhs _lhsIoptions) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Lhs_vIn31 _lhsIoptions !(T_Lhs_vOut31 _lhsOpp) <- return (inv_Lhs_s32 sem arg) return (Syn_Lhs _lhsOpp) ) -- cata {-# NOINLINE sem_Lhs #-} sem_Lhs :: Lhs -> T_Lhs sem_Lhs ( Pattern3 pat3_ ) = sem_Lhs_Pattern3 ( sem_Pattern pat3_ ) sem_Lhs ( Pattern3SM pat3_ ) = sem_Lhs_Pattern3SM ( sem_Pattern pat3_ ) sem_Lhs ( TupleLhs !comps_ ) = sem_Lhs_TupleLhs comps_ sem_Lhs ( UnboxedTupleLhs !comps_ ) = sem_Lhs_UnboxedTupleLhs comps_ sem_Lhs ( Fun !name_ args_ ) = sem_Lhs_Fun name_ ( sem_Exprs args_ ) sem_Lhs ( Unwrap !name_ sub_ ) = sem_Lhs_Unwrap name_ ( sem_Lhs sub_ ) -- semantic domain newtype T_Lhs = T_Lhs { attach_T_Lhs :: Identity (T_Lhs_s32 ) } newtype T_Lhs_s32 = C_Lhs_s32 { inv_Lhs_s32 :: (T_Lhs_v31 ) } data T_Lhs_s33 = C_Lhs_s33 type T_Lhs_v31 = (T_Lhs_vIn31 ) -> (T_Lhs_vOut31 ) data T_Lhs_vIn31 = T_Lhs_vIn31 (Options) data T_Lhs_vOut31 = T_Lhs_vOut31 (PP_Doc) {-# NOINLINE sem_Lhs_Pattern3 #-} sem_Lhs_Pattern3 :: T_Pattern -> T_Lhs sem_Lhs_Pattern3 arg_pat3_ = T_Lhs (return st32) where {-# NOINLINE st32 #-} !st32 = let v31 :: T_Lhs_v31 v31 = \ !(T_Lhs_vIn31 _lhsIoptions) -> ( let _pat3X41 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat3_)) (T_Pattern_vOut40 _pat3Icopy _pat3IisUnderscore _pat3Ipp) = inv_Pattern_s41 _pat3X41 (T_Pattern_vIn40 _pat3Ooptions) _lhsOpp :: PP_Doc _lhsOpp = rule107 _pat3Ipp _pat3Ooptions = rule108 _lhsIoptions !__result_ = T_Lhs_vOut31 _lhsOpp in __result_ ) in C_Lhs_s32 v31 {-# INLINE rule107 #-} {-# LINE 153 "./src-ag/PrintOcamlCode.ag" #-} rule107 = \ ((_pat3Ipp) :: PP_Doc) -> {-# LINE 153 "./src-ag/PrintOcamlCode.ag" #-} _pat3Ipp {-# LINE 1619 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule108 #-} rule108 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Lhs_Pattern3SM #-} sem_Lhs_Pattern3SM :: T_Pattern -> T_Lhs sem_Lhs_Pattern3SM arg_pat3_ = T_Lhs (return st32) where {-# NOINLINE st32 #-} !st32 = let v31 :: T_Lhs_v31 v31 = \ !(T_Lhs_vIn31 _lhsIoptions) -> ( let _pat3X41 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat3_)) (T_Pattern_vOut40 _pat3Icopy _pat3IisUnderscore _pat3Ipp) = inv_Pattern_s41 _pat3X41 (T_Pattern_vIn40 _pat3Ooptions) _lhsOpp :: PP_Doc _lhsOpp = rule109 () _pat3Ooptions = rule110 _lhsIoptions !__result_ = T_Lhs_vOut31 _lhsOpp in __result_ ) in C_Lhs_s32 v31 {-# INLINE rule109 #-} {-# LINE 154 "./src-ag/PrintOcamlCode.ag" #-} rule109 = \ (_ :: ()) -> {-# LINE 154 "./src-ag/PrintOcamlCode.ag" #-} error "pp of Lhs.Pattern3SM not supported" {-# LINE 1643 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule110 #-} rule110 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Lhs_TupleLhs #-} sem_Lhs_TupleLhs :: ([String]) -> T_Lhs sem_Lhs_TupleLhs !arg_comps_ = T_Lhs (return st32) where {-# NOINLINE st32 #-} !st32 = let v31 :: T_Lhs_v31 v31 = \ !(T_Lhs_vIn31 _lhsIoptions) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule111 arg_comps_ !__result_ = T_Lhs_vOut31 _lhsOpp in __result_ ) in C_Lhs_s32 v31 {-# INLINE rule111 #-} {-# LINE 155 "./src-ag/PrintOcamlCode.ag" #-} rule111 = \ comps_ -> {-# LINE 155 "./src-ag/PrintOcamlCode.ag" #-} ppTuple False (map text comps_) {-# LINE 1664 "dist/build/PrintOcamlCode.hs"#-} {-# NOINLINE sem_Lhs_UnboxedTupleLhs #-} sem_Lhs_UnboxedTupleLhs :: ([String]) -> T_Lhs sem_Lhs_UnboxedTupleLhs _ = T_Lhs (return st32) where {-# NOINLINE st32 #-} !st32 = let v31 :: T_Lhs_v31 v31 = \ !(T_Lhs_vIn31 _lhsIoptions) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule112 () !__result_ = T_Lhs_vOut31 _lhsOpp in __result_ ) in C_Lhs_s32 v31 {-# INLINE rule112 #-} {-# LINE 156 "./src-ag/PrintOcamlCode.ag" #-} rule112 = \ (_ :: ()) -> {-# LINE 156 "./src-ag/PrintOcamlCode.ag" #-} error "pp of Lhs.UnboxedTupleLhs not supported" {-# LINE 1682 "dist/build/PrintOcamlCode.hs"#-} {-# NOINLINE sem_Lhs_Fun #-} sem_Lhs_Fun :: (String) -> T_Exprs -> T_Lhs sem_Lhs_Fun !arg_name_ arg_args_ = T_Lhs (return st32) where {-# NOINLINE st32 #-} !st32 = let v31 :: T_Lhs_v31 v31 = \ !(T_Lhs_vIn31 _lhsIoptions) -> ( let _argsX29 = Control.Monad.Identity.runIdentity (attach_T_Exprs (arg_args_)) (T_Exprs_vOut28 _argsIpps) = inv_Exprs_s29 _argsX29 (T_Exprs_vIn28 _argsOoptions) _lhsOpp :: PP_Doc _lhsOpp = rule113 _argsIpps arg_name_ _argsOoptions = rule114 _lhsIoptions !__result_ = T_Lhs_vOut31 _lhsOpp in __result_ ) in C_Lhs_s32 v31 {-# INLINE rule113 #-} {-# LINE 157 "./src-ag/PrintOcamlCode.ag" #-} rule113 = \ ((_argsIpps) :: PP_Docs) name_ -> {-# LINE 157 "./src-ag/PrintOcamlCode.ag" #-} name_ >#< hv_sp _argsIpps {-# LINE 1703 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule114 #-} rule114 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Lhs_Unwrap #-} sem_Lhs_Unwrap :: (String) -> T_Lhs -> T_Lhs sem_Lhs_Unwrap !arg_name_ arg_sub_ = T_Lhs (return st32) where {-# NOINLINE st32 #-} !st32 = let v31 :: T_Lhs_v31 v31 = \ !(T_Lhs_vIn31 _lhsIoptions) -> ( let _subX32 = Control.Monad.Identity.runIdentity (attach_T_Lhs (arg_sub_)) (T_Lhs_vOut31 _subIpp) = inv_Lhs_s32 _subX32 (T_Lhs_vIn31 _subOoptions) _lhsOpp :: PP_Doc _lhsOpp = rule115 _subIpp arg_name_ _subOoptions = rule116 _lhsIoptions !__result_ = T_Lhs_vOut31 _lhsOpp in __result_ ) in C_Lhs_s32 v31 {-# INLINE rule115 #-} {-# LINE 158 "./src-ag/PrintOcamlCode.ag" #-} rule115 = \ ((_subIpp) :: PP_Doc) name_ -> {-# LINE 158 "./src-ag/PrintOcamlCode.ag" #-} pp_parens (name_ >#< _subIpp) {-# LINE 1727 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule116 #-} rule116 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions -- NamedType --------------------------------------------------- -- wrapper data Inh_NamedType = Inh_NamedType { } data Syn_NamedType = Syn_NamedType { pp_Syn_NamedType :: !(PP_Doc) } {-# INLINABLE wrap_NamedType #-} wrap_NamedType :: T_NamedType -> Inh_NamedType -> (Syn_NamedType ) wrap_NamedType !(T_NamedType act) !(Inh_NamedType ) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_NamedType_vIn34 !(T_NamedType_vOut34 _lhsOpp) <- return (inv_NamedType_s35 sem arg) return (Syn_NamedType _lhsOpp) ) -- cata {-# INLINE sem_NamedType #-} sem_NamedType :: NamedType -> T_NamedType sem_NamedType ( Named !strict_ !name_ tp_ ) = sem_NamedType_Named strict_ name_ ( sem_Type tp_ ) -- semantic domain newtype T_NamedType = T_NamedType { attach_T_NamedType :: Identity (T_NamedType_s35 ) } newtype T_NamedType_s35 = C_NamedType_s35 { inv_NamedType_s35 :: (T_NamedType_v34 ) } data T_NamedType_s36 = C_NamedType_s36 type T_NamedType_v34 = (T_NamedType_vIn34 ) -> (T_NamedType_vOut34 ) data T_NamedType_vIn34 = T_NamedType_vIn34 data T_NamedType_vOut34 = T_NamedType_vOut34 (PP_Doc) {-# NOINLINE sem_NamedType_Named #-} sem_NamedType_Named :: (Bool) -> (String) -> T_Type -> T_NamedType sem_NamedType_Named _ !arg_name_ arg_tp_ = T_NamedType (return st35) where {-# NOINLINE st35 #-} !st35 = let v34 :: T_NamedType_v34 v34 = \ !(T_NamedType_vIn34 ) -> ( let _tpX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_tp_)) (T_Type_vOut49 _tpIpp) = inv_Type_s50 _tpX50 (T_Type_vIn49 ) _lhsOpp :: PP_Doc _lhsOpp = rule117 _tpIpp arg_name_ !__result_ = T_NamedType_vOut34 _lhsOpp in __result_ ) in C_NamedType_s35 v34 {-# INLINE rule117 #-} {-# LINE 189 "./src-ag/PrintOcamlCode.ag" #-} rule117 = \ ((_tpIpp) :: PP_Doc) name_ -> {-# LINE 189 "./src-ag/PrintOcamlCode.ag" #-} name_ >#< ":" >#< _tpIpp {-# LINE 1781 "dist/build/PrintOcamlCode.hs"#-} -- NamedTypes -------------------------------------------------- -- wrapper data Inh_NamedTypes = Inh_NamedTypes { } data Syn_NamedTypes = Syn_NamedTypes { pps_Syn_NamedTypes :: !(PP_Docs) } {-# INLINABLE wrap_NamedTypes #-} wrap_NamedTypes :: T_NamedTypes -> Inh_NamedTypes -> (Syn_NamedTypes ) wrap_NamedTypes !(T_NamedTypes act) !(Inh_NamedTypes ) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_NamedTypes_vIn37 !(T_NamedTypes_vOut37 _lhsOpps) <- return (inv_NamedTypes_s38 sem arg) return (Syn_NamedTypes _lhsOpps) ) -- cata {-# NOINLINE sem_NamedTypes #-} sem_NamedTypes :: NamedTypes -> T_NamedTypes sem_NamedTypes list = Prelude.foldr sem_NamedTypes_Cons sem_NamedTypes_Nil (Prelude.map sem_NamedType list) -- semantic domain newtype T_NamedTypes = T_NamedTypes { attach_T_NamedTypes :: Identity (T_NamedTypes_s38 ) } newtype T_NamedTypes_s38 = C_NamedTypes_s38 { inv_NamedTypes_s38 :: (T_NamedTypes_v37 ) } data T_NamedTypes_s39 = C_NamedTypes_s39 type T_NamedTypes_v37 = (T_NamedTypes_vIn37 ) -> (T_NamedTypes_vOut37 ) data T_NamedTypes_vIn37 = T_NamedTypes_vIn37 data T_NamedTypes_vOut37 = T_NamedTypes_vOut37 (PP_Docs) {-# NOINLINE sem_NamedTypes_Cons #-} sem_NamedTypes_Cons :: T_NamedType -> T_NamedTypes -> T_NamedTypes sem_NamedTypes_Cons arg_hd_ arg_tl_ = T_NamedTypes (return st38) where {-# NOINLINE st38 #-} !st38 = let v37 :: T_NamedTypes_v37 v37 = \ !(T_NamedTypes_vIn37 ) -> ( let _hdX35 = Control.Monad.Identity.runIdentity (attach_T_NamedType (arg_hd_)) _tlX38 = Control.Monad.Identity.runIdentity (attach_T_NamedTypes (arg_tl_)) (T_NamedType_vOut34 _hdIpp) = inv_NamedType_s35 _hdX35 (T_NamedType_vIn34 ) (T_NamedTypes_vOut37 _tlIpps) = inv_NamedTypes_s38 _tlX38 (T_NamedTypes_vIn37 ) _lhsOpps :: PP_Docs _lhsOpps = rule118 _hdIpp _tlIpps !__result_ = T_NamedTypes_vOut37 _lhsOpps in __result_ ) in C_NamedTypes_s38 v37 {-# INLINE rule118 #-} {-# LINE 77 "./src-ag/PrintOcamlCode.ag" #-} rule118 = \ ((_hdIpp) :: PP_Doc) ((_tlIpps) :: PP_Docs) -> {-# LINE 77 "./src-ag/PrintOcamlCode.ag" #-} _hdIpp : _tlIpps {-# LINE 1834 "dist/build/PrintOcamlCode.hs"#-} {-# NOINLINE sem_NamedTypes_Nil #-} sem_NamedTypes_Nil :: T_NamedTypes sem_NamedTypes_Nil = T_NamedTypes (return st38) where {-# NOINLINE st38 #-} !st38 = let v37 :: T_NamedTypes_v37 v37 = \ !(T_NamedTypes_vIn37 ) -> ( let _lhsOpps :: PP_Docs _lhsOpps = rule119 () !__result_ = T_NamedTypes_vOut37 _lhsOpps in __result_ ) in C_NamedTypes_s38 v37 {-# INLINE rule119 #-} {-# LINE 78 "./src-ag/PrintOcamlCode.ag" #-} rule119 = \ (_ :: ()) -> {-# LINE 78 "./src-ag/PrintOcamlCode.ag" #-} [] {-# LINE 1852 "dist/build/PrintOcamlCode.hs"#-} -- Pattern ----------------------------------------------------- -- wrapper data Inh_Pattern = Inh_Pattern { options_Inh_Pattern :: !(Options) } data Syn_Pattern = Syn_Pattern { copy_Syn_Pattern :: !(Pattern), isUnderscore_Syn_Pattern :: !(Bool), pp_Syn_Pattern :: !(PP_Doc) } {-# INLINABLE wrap_Pattern #-} wrap_Pattern :: T_Pattern -> Inh_Pattern -> (Syn_Pattern ) wrap_Pattern !(T_Pattern act) !(Inh_Pattern _lhsIoptions) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Pattern_vIn40 _lhsIoptions !(T_Pattern_vOut40 _lhsOcopy _lhsOisUnderscore _lhsOpp) <- return (inv_Pattern_s41 sem arg) return (Syn_Pattern _lhsOcopy _lhsOisUnderscore _lhsOpp) ) -- cata {-# NOINLINE sem_Pattern #-} sem_Pattern :: Pattern -> T_Pattern sem_Pattern ( Constr !name_ pats_ ) = sem_Pattern_Constr name_ ( sem_Patterns pats_ ) sem_Pattern ( Product !pos_ pats_ ) = sem_Pattern_Product pos_ ( sem_Patterns pats_ ) sem_Pattern ( Alias !field_ !attr_ pat_ ) = sem_Pattern_Alias field_ attr_ ( sem_Pattern pat_ ) sem_Pattern ( Irrefutable pat_ ) = sem_Pattern_Irrefutable ( sem_Pattern pat_ ) sem_Pattern ( Underscore !pos_ ) = sem_Pattern_Underscore pos_ -- semantic domain newtype T_Pattern = T_Pattern { attach_T_Pattern :: Identity (T_Pattern_s41 ) } newtype T_Pattern_s41 = C_Pattern_s41 { inv_Pattern_s41 :: (T_Pattern_v40 ) } data T_Pattern_s42 = C_Pattern_s42 type T_Pattern_v40 = (T_Pattern_vIn40 ) -> (T_Pattern_vOut40 ) data T_Pattern_vIn40 = T_Pattern_vIn40 (Options) data T_Pattern_vOut40 = T_Pattern_vOut40 (Pattern) (Bool) (PP_Doc) {-# NOINLINE sem_Pattern_Constr #-} sem_Pattern_Constr :: (ConstructorIdent) -> T_Patterns -> T_Pattern sem_Pattern_Constr !arg_name_ arg_pats_ = T_Pattern (return st41) where {-# NOINLINE st41 #-} !st41 = let v40 :: T_Pattern_v40 v40 = \ !(T_Pattern_vIn40 _lhsIoptions) -> ( let _patsX44 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) (T_Patterns_vOut43 _patsIcopy _patsIpps) = inv_Patterns_s44 _patsX44 (T_Patterns_vIn43 _patsOoptions) _lhsOpp :: PP_Doc _lhsOpp = rule120 _patsIpps arg_name_ _lhsOisUnderscore :: Bool _lhsOisUnderscore = rule121 () _copy = rule122 _patsIcopy arg_name_ _lhsOcopy :: Pattern _lhsOcopy = rule123 _copy _patsOoptions = rule124 _lhsIoptions !__result_ = T_Pattern_vOut40 _lhsOcopy _lhsOisUnderscore _lhsOpp in __result_ ) in C_Pattern_s41 v40 {-# INLINE rule120 #-} {-# LINE 192 "./src-ag/PrintOcamlCode.ag" #-} rule120 = \ ((_patsIpps) :: PP_Docs) name_ -> {-# LINE 192 "./src-ag/PrintOcamlCode.ag" #-} pp_parens $ name_ >#< hv_sp _patsIpps {-# LINE 1913 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule121 #-} {-# LINE 202 "./src-ag/PrintOcamlCode.ag" #-} rule121 = \ (_ :: ()) -> {-# LINE 202 "./src-ag/PrintOcamlCode.ag" #-} False {-# LINE 1919 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule122 #-} rule122 = \ ((_patsIcopy) :: Patterns) name_ -> Constr name_ _patsIcopy {-# INLINE rule123 #-} rule123 = \ _copy -> _copy {-# INLINE rule124 #-} rule124 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Pattern_Product #-} sem_Pattern_Product :: (Pos) -> T_Patterns -> T_Pattern sem_Pattern_Product !arg_pos_ arg_pats_ = T_Pattern (return st41) where {-# NOINLINE st41 #-} !st41 = let v40 :: T_Pattern_v40 v40 = \ !(T_Pattern_vIn40 _lhsIoptions) -> ( let _patsX44 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) (T_Patterns_vOut43 _patsIcopy _patsIpps) = inv_Patterns_s44 _patsX44 (T_Patterns_vIn43 _patsOoptions) _lhsOpp :: PP_Doc _lhsOpp = rule125 _patsIpps _lhsOisUnderscore :: Bool _lhsOisUnderscore = rule126 () _copy = rule127 _patsIcopy arg_pos_ _lhsOcopy :: Pattern _lhsOcopy = rule128 _copy _patsOoptions = rule129 _lhsIoptions !__result_ = T_Pattern_vOut40 _lhsOcopy _lhsOisUnderscore _lhsOpp in __result_ ) in C_Pattern_s41 v40 {-# INLINE rule125 #-} {-# LINE 193 "./src-ag/PrintOcamlCode.ag" #-} rule125 = \ ((_patsIpps) :: PP_Docs) -> {-# LINE 193 "./src-ag/PrintOcamlCode.ag" #-} pp_block "(" ")" "," _patsIpps {-# LINE 1954 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule126 #-} {-# LINE 203 "./src-ag/PrintOcamlCode.ag" #-} rule126 = \ (_ :: ()) -> {-# LINE 203 "./src-ag/PrintOcamlCode.ag" #-} False {-# LINE 1960 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule127 #-} rule127 = \ ((_patsIcopy) :: Patterns) pos_ -> Product pos_ _patsIcopy {-# INLINE rule128 #-} rule128 = \ _copy -> _copy {-# INLINE rule129 #-} rule129 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Pattern_Alias #-} sem_Pattern_Alias :: (Identifier) -> (Identifier) -> T_Pattern -> T_Pattern sem_Pattern_Alias !arg_field_ !arg_attr_ arg_pat_ = T_Pattern (return st41) where {-# NOINLINE st41 #-} !st41 = let v40 :: T_Pattern_v40 v40 = \ !(T_Pattern_vIn40 _lhsIoptions) -> ( let _patX41 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) (T_Pattern_vOut40 _patIcopy _patIisUnderscore _patIpp) = inv_Pattern_s41 _patX41 (T_Pattern_vIn40 _patOoptions) _lhsOpp :: PP_Doc _lhsOpp = rule130 _patIisUnderscore arg_attr_ arg_field_ _lhsOisUnderscore :: Bool _lhsOisUnderscore = rule131 () _copy = rule132 _patIcopy arg_attr_ arg_field_ _lhsOcopy :: Pattern _lhsOcopy = rule133 _copy _patOoptions = rule134 _lhsIoptions !__result_ = T_Pattern_vOut40 _lhsOcopy _lhsOisUnderscore _lhsOpp in __result_ ) in C_Pattern_s41 v40 {-# INLINE rule130 #-} {-# LINE 195 "./src-ag/PrintOcamlCode.ag" #-} rule130 = \ ((_patIisUnderscore) :: Bool) attr_ field_ -> {-# LINE 195 "./src-ag/PrintOcamlCode.ag" #-} if _patIisUnderscore then pp (attrname False field_ attr_) else error "pp of Pattern.Alias is only supported in the form (x@_)" {-# LINE 1997 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule131 #-} {-# LINE 204 "./src-ag/PrintOcamlCode.ag" #-} rule131 = \ (_ :: ()) -> {-# LINE 204 "./src-ag/PrintOcamlCode.ag" #-} False {-# LINE 2003 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule132 #-} rule132 = \ ((_patIcopy) :: Pattern) attr_ field_ -> Alias field_ attr_ _patIcopy {-# INLINE rule133 #-} rule133 = \ _copy -> _copy {-# INLINE rule134 #-} rule134 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Pattern_Irrefutable #-} sem_Pattern_Irrefutable :: T_Pattern -> T_Pattern sem_Pattern_Irrefutable arg_pat_ = T_Pattern (return st41) where {-# NOINLINE st41 #-} !st41 = let v40 :: T_Pattern_v40 v40 = \ !(T_Pattern_vIn40 _lhsIoptions) -> ( let _patX41 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) (T_Pattern_vOut40 _patIcopy _patIisUnderscore _patIpp) = inv_Pattern_s41 _patX41 (T_Pattern_vIn40 _patOoptions) _lhsOpp :: PP_Doc _lhsOpp = rule135 () _copy = rule136 _patIcopy _lhsOcopy :: Pattern _lhsOcopy = rule137 _copy _lhsOisUnderscore :: Bool _lhsOisUnderscore = rule138 _patIisUnderscore _patOoptions = rule139 _lhsIoptions !__result_ = T_Pattern_vOut40 _lhsOcopy _lhsOisUnderscore _lhsOpp in __result_ ) in C_Pattern_s41 v40 {-# INLINE rule135 #-} {-# LINE 198 "./src-ag/PrintOcamlCode.ag" #-} rule135 = \ (_ :: ()) -> {-# LINE 198 "./src-ag/PrintOcamlCode.ag" #-} error "pp of Pattern.Irrefutable not supported" {-# LINE 2038 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule136 #-} rule136 = \ ((_patIcopy) :: Pattern) -> Irrefutable _patIcopy {-# INLINE rule137 #-} rule137 = \ _copy -> _copy {-# INLINE rule138 #-} rule138 = \ ((_patIisUnderscore) :: Bool) -> _patIisUnderscore {-# INLINE rule139 #-} rule139 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Pattern_Underscore #-} sem_Pattern_Underscore :: (Pos) -> T_Pattern sem_Pattern_Underscore !arg_pos_ = T_Pattern (return st41) where {-# NOINLINE st41 #-} !st41 = let v40 :: T_Pattern_v40 v40 = \ !(T_Pattern_vIn40 _lhsIoptions) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule140 () _lhsOisUnderscore :: Bool _lhsOisUnderscore = rule141 () _copy = rule142 arg_pos_ _lhsOcopy :: Pattern _lhsOcopy = rule143 _copy !__result_ = T_Pattern_vOut40 _lhsOcopy _lhsOisUnderscore _lhsOpp in __result_ ) in C_Pattern_s41 v40 {-# INLINE rule140 #-} {-# LINE 199 "./src-ag/PrintOcamlCode.ag" #-} rule140 = \ (_ :: ()) -> {-# LINE 199 "./src-ag/PrintOcamlCode.ag" #-} text "_" {-# LINE 2073 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule141 #-} {-# LINE 205 "./src-ag/PrintOcamlCode.ag" #-} rule141 = \ (_ :: ()) -> {-# LINE 205 "./src-ag/PrintOcamlCode.ag" #-} True {-# LINE 2079 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule142 #-} rule142 = \ pos_ -> Underscore pos_ {-# INLINE rule143 #-} rule143 = \ _copy -> _copy -- Patterns ---------------------------------------------------- -- wrapper data Inh_Patterns = Inh_Patterns { options_Inh_Patterns :: !(Options) } data Syn_Patterns = Syn_Patterns { copy_Syn_Patterns :: !(Patterns), pps_Syn_Patterns :: !(PP_Docs) } {-# INLINABLE wrap_Patterns #-} wrap_Patterns :: T_Patterns -> Inh_Patterns -> (Syn_Patterns ) wrap_Patterns !(T_Patterns act) !(Inh_Patterns _lhsIoptions) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Patterns_vIn43 _lhsIoptions !(T_Patterns_vOut43 _lhsOcopy _lhsOpps) <- return (inv_Patterns_s44 sem arg) return (Syn_Patterns _lhsOcopy _lhsOpps) ) -- cata {-# NOINLINE sem_Patterns #-} sem_Patterns :: Patterns -> T_Patterns sem_Patterns list = Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list) -- semantic domain newtype T_Patterns = T_Patterns { attach_T_Patterns :: Identity (T_Patterns_s44 ) } newtype T_Patterns_s44 = C_Patterns_s44 { inv_Patterns_s44 :: (T_Patterns_v43 ) } data T_Patterns_s45 = C_Patterns_s45 type T_Patterns_v43 = (T_Patterns_vIn43 ) -> (T_Patterns_vOut43 ) data T_Patterns_vIn43 = T_Patterns_vIn43 (Options) data T_Patterns_vOut43 = T_Patterns_vOut43 (Patterns) (PP_Docs) {-# NOINLINE sem_Patterns_Cons #-} sem_Patterns_Cons :: T_Pattern -> T_Patterns -> T_Patterns sem_Patterns_Cons arg_hd_ arg_tl_ = T_Patterns (return st44) where {-# NOINLINE st44 #-} !st44 = let v43 :: T_Patterns_v43 v43 = \ !(T_Patterns_vIn43 _lhsIoptions) -> ( let _hdX41 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_hd_)) _tlX44 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_tl_)) (T_Pattern_vOut40 _hdIcopy _hdIisUnderscore _hdIpp) = inv_Pattern_s41 _hdX41 (T_Pattern_vIn40 _hdOoptions) (T_Patterns_vOut43 _tlIcopy _tlIpps) = inv_Patterns_s44 _tlX44 (T_Patterns_vIn43 _tlOoptions) _lhsOpps :: PP_Docs _lhsOpps = rule144 _hdIpp _tlIpps _copy = rule145 _hdIcopy _tlIcopy _lhsOcopy :: Patterns _lhsOcopy = rule146 _copy _hdOoptions = rule147 _lhsIoptions _tlOoptions = rule148 _lhsIoptions !__result_ = T_Patterns_vOut43 _lhsOcopy _lhsOpps in __result_ ) in C_Patterns_s44 v43 {-# INLINE rule144 #-} {-# LINE 89 "./src-ag/PrintOcamlCode.ag" #-} rule144 = \ ((_hdIpp) :: PP_Doc) ((_tlIpps) :: PP_Docs) -> {-# LINE 89 "./src-ag/PrintOcamlCode.ag" #-} _hdIpp : _tlIpps {-# LINE 2143 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule145 #-} rule145 = \ ((_hdIcopy) :: Pattern) ((_tlIcopy) :: Patterns) -> (:) _hdIcopy _tlIcopy {-# INLINE rule146 #-} rule146 = \ _copy -> _copy {-# INLINE rule147 #-} rule147 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule148 #-} rule148 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Patterns_Nil #-} sem_Patterns_Nil :: T_Patterns sem_Patterns_Nil = T_Patterns (return st44) where {-# NOINLINE st44 #-} !st44 = let v43 :: T_Patterns_v43 v43 = \ !(T_Patterns_vIn43 _lhsIoptions) -> ( let _lhsOpps :: PP_Docs _lhsOpps = rule149 () _copy = rule150 () _lhsOcopy :: Patterns _lhsOcopy = rule151 _copy !__result_ = T_Patterns_vOut43 _lhsOcopy _lhsOpps in __result_ ) in C_Patterns_s44 v43 {-# INLINE rule149 #-} {-# LINE 90 "./src-ag/PrintOcamlCode.ag" #-} rule149 = \ (_ :: ()) -> {-# LINE 90 "./src-ag/PrintOcamlCode.ag" #-} [] {-# LINE 2176 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule150 #-} rule150 = \ (_ :: ()) -> [] {-# INLINE rule151 #-} rule151 = \ _copy -> _copy -- Program ----------------------------------------------------- -- wrapper data Inh_Program = Inh_Program { options_Inh_Program :: !(Options), textBlockMap_Inh_Program :: !(Map BlockInfo PP_Doc) } data Syn_Program = Syn_Program { output_Syn_Program :: !(PP_Docs) } {-# INLINABLE wrap_Program #-} wrap_Program :: T_Program -> Inh_Program -> (Syn_Program ) wrap_Program !(T_Program act) !(Inh_Program _lhsIoptions _lhsItextBlockMap) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Program_vIn46 _lhsIoptions _lhsItextBlockMap !(T_Program_vOut46 _lhsOoutput) <- return (inv_Program_s47 sem arg) return (Syn_Program _lhsOoutput) ) -- cata {-# INLINE sem_Program #-} sem_Program :: Program -> T_Program sem_Program ( Program chunks_ !ordered_ ) = sem_Program_Program ( sem_Chunks chunks_ ) ordered_ -- semantic domain newtype T_Program = T_Program { attach_T_Program :: Identity (T_Program_s47 ) } newtype T_Program_s47 = C_Program_s47 { inv_Program_s47 :: (T_Program_v46 ) } data T_Program_s48 = C_Program_s48 type T_Program_v46 = (T_Program_vIn46 ) -> (T_Program_vOut46 ) data T_Program_vIn46 = T_Program_vIn46 (Options) (Map BlockInfo PP_Doc) data T_Program_vOut46 = T_Program_vOut46 (PP_Docs) {-# NOINLINE sem_Program_Program #-} sem_Program_Program :: T_Chunks -> (Bool) -> T_Program sem_Program_Program arg_chunks_ _ = T_Program (return st47) where {-# NOINLINE st47 #-} !st47 = let v46 :: T_Program_v46 v46 = \ !(T_Program_vIn46 _lhsIoptions _lhsItextBlockMap) -> ( let _chunksX11 = Control.Monad.Identity.runIdentity (attach_T_Chunks (arg_chunks_)) (T_Chunks_vOut10 _chunksIpps) = inv_Chunks_s11 _chunksX11 (T_Chunks_vIn10 _chunksOisToplevel _chunksOoptions _chunksOtextBlockMap) _lhsOoutput :: PP_Docs _lhsOoutput = rule152 _chunksIpps _chunksOisToplevel = rule153 () _chunksOoptions = rule154 _lhsIoptions _chunksOtextBlockMap = rule155 _lhsItextBlockMap !__result_ = T_Program_vOut46 _lhsOoutput in __result_ ) in C_Program_s47 v46 {-# INLINE rule152 #-} {-# LINE 58 "./src-ag/PrintOcamlCode.ag" #-} rule152 = \ ((_chunksIpps) :: PP_Docs) -> {-# LINE 58 "./src-ag/PrintOcamlCode.ag" #-} _chunksIpps {-# LINE 2236 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule153 #-} {-# LINE 214 "./src-ag/PrintOcamlCode.ag" #-} rule153 = \ (_ :: ()) -> {-# LINE 214 "./src-ag/PrintOcamlCode.ag" #-} True {-# LINE 2242 "dist/build/PrintOcamlCode.hs"#-} {-# INLINE rule154 #-} rule154 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule155 #-} rule155 = \ ((_lhsItextBlockMap) :: Map BlockInfo PP_Doc) -> _lhsItextBlockMap -- Type -------------------------------------------------------- -- wrapper data Inh_Type = Inh_Type { } data Syn_Type = Syn_Type { pp_Syn_Type :: !(PP_Doc) } {-# INLINABLE wrap_Type #-} wrap_Type :: T_Type -> Inh_Type -> (Syn_Type ) wrap_Type !(T_Type act) !(Inh_Type ) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Type_vIn49 !(T_Type_vOut49 _lhsOpp) <- return (inv_Type_s50 sem arg) return (Syn_Type _lhsOpp) ) -- cata {-# NOINLINE sem_Type #-} sem_Type :: Type -> T_Type sem_Type ( Arr left_ right_ ) = sem_Type_Arr ( sem_Type left_ ) ( sem_Type right_ ) sem_Type ( CtxApp !left_ right_ ) = sem_Type_CtxApp left_ ( sem_Type right_ ) sem_Type ( QuantApp !left_ right_ ) = sem_Type_QuantApp left_ ( sem_Type right_ ) sem_Type ( TypeApp func_ args_ ) = sem_Type_TypeApp ( sem_Type func_ ) ( sem_Types args_ ) sem_Type ( TupleType tps_ ) = sem_Type_TupleType ( sem_Types tps_ ) sem_Type ( UnboxedTupleType tps_ ) = sem_Type_UnboxedTupleType ( sem_Types tps_ ) sem_Type ( List tp_ ) = sem_Type_List ( sem_Type tp_ ) sem_Type ( SimpleType !txt_ ) = sem_Type_SimpleType txt_ sem_Type ( NontermType !name_ !params_ !deforested_ ) = sem_Type_NontermType name_ params_ deforested_ sem_Type ( TMaybe tp_ ) = sem_Type_TMaybe ( sem_Type tp_ ) sem_Type ( TEither left_ right_ ) = sem_Type_TEither ( sem_Type left_ ) ( sem_Type right_ ) sem_Type ( TMap key_ value_ ) = sem_Type_TMap ( sem_Type key_ ) ( sem_Type value_ ) sem_Type ( TIntMap value_ ) = sem_Type_TIntMap ( sem_Type value_ ) -- semantic domain newtype T_Type = T_Type { attach_T_Type :: Identity (T_Type_s50 ) } newtype T_Type_s50 = C_Type_s50 { inv_Type_s50 :: (T_Type_v49 ) } data T_Type_s51 = C_Type_s51 type T_Type_v49 = (T_Type_vIn49 ) -> (T_Type_vOut49 ) data T_Type_vIn49 = T_Type_vIn49 data T_Type_vOut49 = T_Type_vOut49 (PP_Doc) {-# NOINLINE sem_Type_Arr #-} sem_Type_Arr :: T_Type -> T_Type -> T_Type sem_Type_Arr arg_left_ arg_right_ = T_Type (return st50) where {-# NOINLINE st50 #-} !st50 = let v49 :: T_Type_v49 v49 = \ !(T_Type_vIn49 ) -> ( let _leftX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_left_)) _rightX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_right_)) (T_Type_vOut49 _leftIpp) = inv_Type_s50 _leftX50 (T_Type_vIn49 ) (T_Type_vOut49 _rightIpp) = inv_Type_s50 _rightX50 (T_Type_vIn49 ) _lhsOpp :: PP_Doc _lhsOpp = rule156 _leftIpp _rightIpp !__result_ = T_Type_vOut49 _lhsOpp in __result_ ) in C_Type_s50 v49 {-# INLINE rule156 #-} {-# LINE 161 "./src-ag/PrintOcamlCode.ag" #-} rule156 = \ ((_leftIpp) :: PP_Doc) ((_rightIpp) :: PP_Doc) -> {-# LINE 161 "./src-ag/PrintOcamlCode.ag" #-} pp_parens (_leftIpp >#< "->" >#< _rightIpp) {-# LINE 2313 "dist/build/PrintOcamlCode.hs"#-} {-# NOINLINE sem_Type_CtxApp #-} sem_Type_CtxApp :: ([(String, [String])]) -> T_Type -> T_Type sem_Type_CtxApp _ arg_right_ = T_Type (return st50) where {-# NOINLINE st50 #-} !st50 = let v49 :: T_Type_v49 v49 = \ !(T_Type_vIn49 ) -> ( let _rightX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_right_)) (T_Type_vOut49 _rightIpp) = inv_Type_s50 _rightX50 (T_Type_vIn49 ) _lhsOpp :: PP_Doc _lhsOpp = rule157 () !__result_ = T_Type_vOut49 _lhsOpp in __result_ ) in C_Type_s50 v49 {-# INLINE rule157 #-} {-# LINE 162 "./src-ag/PrintOcamlCode.ag" #-} rule157 = \ (_ :: ()) -> {-# LINE 162 "./src-ag/PrintOcamlCode.ag" #-} error "pp of Type.CtxApp not supported" {-# LINE 2333 "dist/build/PrintOcamlCode.hs"#-} {-# NOINLINE sem_Type_QuantApp #-} sem_Type_QuantApp :: (String) -> T_Type -> T_Type sem_Type_QuantApp _ arg_right_ = T_Type (return st50) where {-# NOINLINE st50 #-} !st50 = let v49 :: T_Type_v49 v49 = \ !(T_Type_vIn49 ) -> ( let _rightX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_right_)) (T_Type_vOut49 _rightIpp) = inv_Type_s50 _rightX50 (T_Type_vIn49 ) _lhsOpp :: PP_Doc _lhsOpp = rule158 _rightIpp !__result_ = T_Type_vOut49 _lhsOpp in __result_ ) in C_Type_s50 v49 {-# INLINE rule158 #-} rule158 = \ ((_rightIpp) :: PP_Doc) -> _rightIpp {-# NOINLINE sem_Type_TypeApp #-} sem_Type_TypeApp :: T_Type -> T_Types -> T_Type sem_Type_TypeApp arg_func_ arg_args_ = T_Type (return st50) where {-# NOINLINE st50 #-} !st50 = let v49 :: T_Type_v49 v49 = \ !(T_Type_vIn49 ) -> ( let _funcX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_func_)) _argsX53 = Control.Monad.Identity.runIdentity (attach_T_Types (arg_args_)) (T_Type_vOut49 _funcIpp) = inv_Type_s50 _funcX50 (T_Type_vIn49 ) (T_Types_vOut52 _argsIpps) = inv_Types_s53 _argsX53 (T_Types_vIn52 ) _lhsOpp :: PP_Doc _lhsOpp = rule159 _argsIpps _funcIpp !__result_ = T_Type_vOut49 _lhsOpp in __result_ ) in C_Type_s50 v49 {-# INLINE rule159 #-} {-# LINE 163 "./src-ag/PrintOcamlCode.ag" #-} rule159 = \ ((_argsIpps) :: PP_Docs) ((_funcIpp) :: PP_Doc) -> {-# LINE 163 "./src-ag/PrintOcamlCode.ag" #-} pp_parens (hv_sp (_argsIpps ++ [_funcIpp])) {-# LINE 2372 "dist/build/PrintOcamlCode.hs"#-} {-# NOINLINE sem_Type_TupleType #-} sem_Type_TupleType :: T_Types -> T_Type sem_Type_TupleType arg_tps_ = T_Type (return st50) where {-# NOINLINE st50 #-} !st50 = let v49 :: T_Type_v49 v49 = \ !(T_Type_vIn49 ) -> ( let _tpsX53 = Control.Monad.Identity.runIdentity (attach_T_Types (arg_tps_)) (T_Types_vOut52 _tpsIpps) = inv_Types_s53 _tpsX53 (T_Types_vIn52 ) _lhsOpp :: PP_Doc _lhsOpp = rule160 _tpsIpps !__result_ = T_Type_vOut49 _lhsOpp in __result_ ) in C_Type_s50 v49 {-# INLINE rule160 #-} {-# LINE 164 "./src-ag/PrintOcamlCode.ag" #-} rule160 = \ ((_tpsIpps) :: PP_Docs) -> {-# LINE 164 "./src-ag/PrintOcamlCode.ag" #-} pp_block "(" ")" "," _tpsIpps {-# LINE 2392 "dist/build/PrintOcamlCode.hs"#-} {-# NOINLINE sem_Type_UnboxedTupleType #-} sem_Type_UnboxedTupleType :: T_Types -> T_Type sem_Type_UnboxedTupleType arg_tps_ = T_Type (return st50) where {-# NOINLINE st50 #-} !st50 = let v49 :: T_Type_v49 v49 = \ !(T_Type_vIn49 ) -> ( let _tpsX53 = Control.Monad.Identity.runIdentity (attach_T_Types (arg_tps_)) (T_Types_vOut52 _tpsIpps) = inv_Types_s53 _tpsX53 (T_Types_vIn52 ) _lhsOpp :: PP_Doc _lhsOpp = rule161 () !__result_ = T_Type_vOut49 _lhsOpp in __result_ ) in C_Type_s50 v49 {-# INLINE rule161 #-} {-# LINE 166 "./src-ag/PrintOcamlCode.ag" #-} rule161 = \ (_ :: ()) -> {-# LINE 166 "./src-ag/PrintOcamlCode.ag" #-} error "pp of Type.UnboxedTupleType is not supported" {-# LINE 2412 "dist/build/PrintOcamlCode.hs"#-} {-# NOINLINE sem_Type_List #-} sem_Type_List :: T_Type -> T_Type sem_Type_List arg_tp_ = T_Type (return st50) where {-# NOINLINE st50 #-} !st50 = let v49 :: T_Type_v49 v49 = \ !(T_Type_vIn49 ) -> ( let _tpX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_tp_)) (T_Type_vOut49 _tpIpp) = inv_Type_s50 _tpX50 (T_Type_vIn49 ) _lhsOpp :: PP_Doc _lhsOpp = rule162 _tpIpp !__result_ = T_Type_vOut49 _lhsOpp in __result_ ) in C_Type_s50 v49 {-# INLINE rule162 #-} {-# LINE 167 "./src-ag/PrintOcamlCode.ag" #-} rule162 = \ ((_tpIpp) :: PP_Doc) -> {-# LINE 167 "./src-ag/PrintOcamlCode.ag" #-} _tpIpp >#< "list" {-# LINE 2432 "dist/build/PrintOcamlCode.hs"#-} {-# NOINLINE sem_Type_SimpleType #-} sem_Type_SimpleType :: (String) -> T_Type sem_Type_SimpleType !arg_txt_ = T_Type (return st50) where {-# NOINLINE st50 #-} !st50 = let v49 :: T_Type_v49 v49 = \ !(T_Type_vIn49 ) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule163 arg_txt_ !__result_ = T_Type_vOut49 _lhsOpp in __result_ ) in C_Type_s50 v49 {-# INLINE rule163 #-} {-# LINE 168 "./src-ag/PrintOcamlCode.ag" #-} rule163 = \ txt_ -> {-# LINE 168 "./src-ag/PrintOcamlCode.ag" #-} text txt_ {-# LINE 2450 "dist/build/PrintOcamlCode.hs"#-} {-# NOINLINE sem_Type_NontermType #-} sem_Type_NontermType :: (String) -> ([String]) -> (Bool) -> T_Type sem_Type_NontermType !arg_name_ !arg_params_ _ = T_Type (return st50) where {-# NOINLINE st50 #-} !st50 = let v49 :: T_Type_v49 v49 = \ !(T_Type_vIn49 ) -> ( let _lhsOpp :: PP_Doc _lhsOpp = rule164 arg_name_ arg_params_ !__result_ = T_Type_vOut49 _lhsOpp in __result_ ) in C_Type_s50 v49 {-# INLINE rule164 #-} {-# LINE 169 "./src-ag/PrintOcamlCode.ag" #-} rule164 = \ name_ params_ -> {-# LINE 169 "./src-ag/PrintOcamlCode.ag" #-} pp_block "(" ")" " " (map text params_ ++ [text $ toOcamlTC name_]) {-# LINE 2468 "dist/build/PrintOcamlCode.hs"#-} {-# NOINLINE sem_Type_TMaybe #-} sem_Type_TMaybe :: T_Type -> T_Type sem_Type_TMaybe arg_tp_ = T_Type (return st50) where {-# NOINLINE st50 #-} !st50 = let v49 :: T_Type_v49 v49 = \ !(T_Type_vIn49 ) -> ( let _tpX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_tp_)) (T_Type_vOut49 _tpIpp) = inv_Type_s50 _tpX50 (T_Type_vIn49 ) _lhsOpp :: PP_Doc _lhsOpp = rule165 _tpIpp !__result_ = T_Type_vOut49 _lhsOpp in __result_ ) in C_Type_s50 v49 {-# INLINE rule165 #-} {-# LINE 170 "./src-ag/PrintOcamlCode.ag" #-} rule165 = \ ((_tpIpp) :: PP_Doc) -> {-# LINE 170 "./src-ag/PrintOcamlCode.ag" #-} _tpIpp >#< "opt" {-# LINE 2488 "dist/build/PrintOcamlCode.hs"#-} {-# NOINLINE sem_Type_TEither #-} sem_Type_TEither :: T_Type -> T_Type -> T_Type sem_Type_TEither arg_left_ arg_right_ = T_Type (return st50) where {-# NOINLINE st50 #-} !st50 = let v49 :: T_Type_v49 v49 = \ !(T_Type_vIn49 ) -> ( let _leftX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_left_)) _rightX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_right_)) (T_Type_vOut49 _leftIpp) = inv_Type_s50 _leftX50 (T_Type_vIn49 ) (T_Type_vOut49 _rightIpp) = inv_Type_s50 _rightX50 (T_Type_vIn49 ) _lhsOpp :: PP_Doc _lhsOpp = rule166 () !__result_ = T_Type_vOut49 _lhsOpp in __result_ ) in C_Type_s50 v49 {-# INLINE rule166 #-} {-# LINE 171 "./src-ag/PrintOcamlCode.ag" #-} rule166 = \ (_ :: ()) -> {-# LINE 171 "./src-ag/PrintOcamlCode.ag" #-} error "pp of Type.TEither is not supported" {-# LINE 2510 "dist/build/PrintOcamlCode.hs"#-} {-# NOINLINE sem_Type_TMap #-} sem_Type_TMap :: T_Type -> T_Type -> T_Type sem_Type_TMap arg_key_ arg_value_ = T_Type (return st50) where {-# NOINLINE st50 #-} !st50 = let v49 :: T_Type_v49 v49 = \ !(T_Type_vIn49 ) -> ( let _keyX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_key_)) _valueX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_value_)) (T_Type_vOut49 _keyIpp) = inv_Type_s50 _keyX50 (T_Type_vIn49 ) (T_Type_vOut49 _valueIpp) = inv_Type_s50 _valueX50 (T_Type_vIn49 ) _lhsOpp :: PP_Doc _lhsOpp = rule167 () !__result_ = T_Type_vOut49 _lhsOpp in __result_ ) in C_Type_s50 v49 {-# INLINE rule167 #-} {-# LINE 172 "./src-ag/PrintOcamlCode.ag" #-} rule167 = \ (_ :: ()) -> {-# LINE 172 "./src-ag/PrintOcamlCode.ag" #-} error "pp of Type.TMap is not supported" {-# LINE 2532 "dist/build/PrintOcamlCode.hs"#-} {-# NOINLINE sem_Type_TIntMap #-} sem_Type_TIntMap :: T_Type -> T_Type sem_Type_TIntMap arg_value_ = T_Type (return st50) where {-# NOINLINE st50 #-} !st50 = let v49 :: T_Type_v49 v49 = \ !(T_Type_vIn49 ) -> ( let _valueX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_value_)) (T_Type_vOut49 _valueIpp) = inv_Type_s50 _valueX50 (T_Type_vIn49 ) _lhsOpp :: PP_Doc _lhsOpp = rule168 () !__result_ = T_Type_vOut49 _lhsOpp in __result_ ) in C_Type_s50 v49 {-# INLINE rule168 #-} {-# LINE 173 "./src-ag/PrintOcamlCode.ag" #-} rule168 = \ (_ :: ()) -> {-# LINE 173 "./src-ag/PrintOcamlCode.ag" #-} error "pp of Type.TIntMap is not supported" {-# LINE 2552 "dist/build/PrintOcamlCode.hs"#-} -- Types ------------------------------------------------------- -- wrapper data Inh_Types = Inh_Types { } data Syn_Types = Syn_Types { pps_Syn_Types :: !(PP_Docs) } {-# INLINABLE wrap_Types #-} wrap_Types :: T_Types -> Inh_Types -> (Syn_Types ) wrap_Types !(T_Types act) !(Inh_Types ) = Control.Monad.Identity.runIdentity ( do !sem <- act let arg = T_Types_vIn52 !(T_Types_vOut52 _lhsOpps) <- return (inv_Types_s53 sem arg) return (Syn_Types _lhsOpps) ) -- cata {-# NOINLINE sem_Types #-} sem_Types :: Types -> T_Types sem_Types list = Prelude.foldr sem_Types_Cons sem_Types_Nil (Prelude.map sem_Type list) -- semantic domain newtype T_Types = T_Types { attach_T_Types :: Identity (T_Types_s53 ) } newtype T_Types_s53 = C_Types_s53 { inv_Types_s53 :: (T_Types_v52 ) } data T_Types_s54 = C_Types_s54 type T_Types_v52 = (T_Types_vIn52 ) -> (T_Types_vOut52 ) data T_Types_vIn52 = T_Types_vIn52 data T_Types_vOut52 = T_Types_vOut52 (PP_Docs) {-# NOINLINE sem_Types_Cons #-} sem_Types_Cons :: T_Type -> T_Types -> T_Types sem_Types_Cons arg_hd_ arg_tl_ = T_Types (return st53) where {-# NOINLINE st53 #-} !st53 = let v52 :: T_Types_v52 v52 = \ !(T_Types_vIn52 ) -> ( let _hdX50 = Control.Monad.Identity.runIdentity (attach_T_Type (arg_hd_)) _tlX53 = Control.Monad.Identity.runIdentity (attach_T_Types (arg_tl_)) (T_Type_vOut49 _hdIpp) = inv_Type_s50 _hdX50 (T_Type_vIn49 ) (T_Types_vOut52 _tlIpps) = inv_Types_s53 _tlX53 (T_Types_vIn52 ) _lhsOpps :: PP_Docs _lhsOpps = rule169 _hdIpp _tlIpps !__result_ = T_Types_vOut52 _lhsOpps in __result_ ) in C_Types_s53 v52 {-# INLINE rule169 #-} {-# LINE 73 "./src-ag/PrintOcamlCode.ag" #-} rule169 = \ ((_hdIpp) :: PP_Doc) ((_tlIpps) :: PP_Docs) -> {-# LINE 73 "./src-ag/PrintOcamlCode.ag" #-} _hdIpp : _tlIpps {-# LINE 2605 "dist/build/PrintOcamlCode.hs"#-} {-# NOINLINE sem_Types_Nil #-} sem_Types_Nil :: T_Types sem_Types_Nil = T_Types (return st53) where {-# NOINLINE st53 #-} !st53 = let v52 :: T_Types_v52 v52 = \ !(T_Types_vIn52 ) -> ( let _lhsOpps :: PP_Docs _lhsOpps = rule170 () !__result_ = T_Types_vOut52 _lhsOpps in __result_ ) in C_Types_s53 v52 {-# INLINE rule170 #-} {-# LINE 74 "./src-ag/PrintOcamlCode.ag" #-} rule170 = \ (_ :: ()) -> {-# LINE 74 "./src-ag/PrintOcamlCode.ag" #-} [] {-# LINE 2623 "dist/build/PrintOcamlCode.hs"#-} uuagc-0.9.42.3/src-generated/PrintVisitCode.hs000644 000765 000024 00000117601 12127045231 023041 0ustar00jeroenbransenstaff000000 000000 {-# LANGUAGE Rank2Types, GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} module PrintVisitCode where {-# LINE 2 "./src-ag/CodeSyntax.ag" #-} import Patterns import CommonTypes import Data.Map(Map) import Data.Set(Set) {-# LINE 12 "dist/build/PrintVisitCode.hs" #-} {-# LINE 2 "./src-ag/Patterns.ag" #-} -- Patterns.ag imports import UU.Scanner.Position(Pos) import CommonTypes (ConstructorIdent,Identifier) {-# LINE 19 "dist/build/PrintVisitCode.hs" #-} {-# LINE 2 "./src-ag/DeclBlocks.ag" #-} import Code (Decl,Expr) {-# LINE 24 "dist/build/PrintVisitCode.hs" #-} {-# LINE 10 "./src-ag/PrintVisitCode.ag" #-} 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) {-# LINE 47 "dist/build/PrintVisitCode.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 32 "./src-ag/PrintVisitCode.ag" #-} 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 {-# LINE 63 "dist/build/PrintVisitCode.hs" #-} -- CGrammar ---------------------------------------------------- -- wrapper data Inh_CGrammar = Inh_CGrammar { options_Inh_CGrammar :: (Options) } data Syn_CGrammar = Syn_CGrammar { output_Syn_CGrammar :: (PP_Docs) } {-# INLINABLE wrap_CGrammar #-} wrap_CGrammar :: T_CGrammar -> Inh_CGrammar -> (Syn_CGrammar ) wrap_CGrammar (T_CGrammar act) (Inh_CGrammar _lhsIoptions) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_CGrammar_vIn1 _lhsIoptions (T_CGrammar_vOut1 _lhsOoutput) <- return (inv_CGrammar_s2 sem arg) return (Syn_CGrammar _lhsOoutput) ) -- cata {-# INLINE sem_CGrammar #-} sem_CGrammar :: CGrammar -> T_CGrammar sem_CGrammar ( CGrammar typeSyns_ derivings_ wrappers_ nonts_ pragmas_ paramMap_ contextMap_ quantMap_ aroundsMap_ mergeMap_ multivisit_ ) = sem_CGrammar_CGrammar typeSyns_ derivings_ wrappers_ ( sem_CNonterminals nonts_ ) pragmas_ paramMap_ contextMap_ quantMap_ aroundsMap_ mergeMap_ multivisit_ -- semantic domain newtype T_CGrammar = T_CGrammar { attach_T_CGrammar :: Identity (T_CGrammar_s2 ) } newtype T_CGrammar_s2 = C_CGrammar_s2 { inv_CGrammar_s2 :: (T_CGrammar_v1 ) } data T_CGrammar_s3 = C_CGrammar_s3 type T_CGrammar_v1 = (T_CGrammar_vIn1 ) -> (T_CGrammar_vOut1 ) data T_CGrammar_vIn1 = T_CGrammar_vIn1 (Options) data T_CGrammar_vOut1 = T_CGrammar_vOut1 (PP_Docs) {-# NOINLINE sem_CGrammar_CGrammar #-} sem_CGrammar_CGrammar :: (TypeSyns) -> (Derivings) -> (Set NontermIdent) -> T_CNonterminals -> (PragmaMap) -> (ParamMap) -> (ContextMap) -> (QuantMap) -> (Map NontermIdent (Map ConstructorIdent (Set Identifier))) -> (Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))) -> (Bool) -> T_CGrammar sem_CGrammar_CGrammar _ _ _ arg_nonts_ _ _ _ _ _ _ _ = T_CGrammar (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_CGrammar_v1 v1 = \ (T_CGrammar_vIn1 _lhsIoptions) -> ( let _nontsX11 = Control.Monad.Identity.runIdentity (attach_T_CNonterminals (arg_nonts_)) (T_CNonterminals_vOut10 ) = inv_CNonterminals_s11 _nontsX11 (T_CNonterminals_vIn10 ) _lhsOoutput :: PP_Docs _lhsOoutput = rule0 () __result_ = T_CGrammar_vOut1 _lhsOoutput in __result_ ) in C_CGrammar_s2 v1 {-# INLINE rule0 #-} {-# LINE 53 "./src-ag/PrintVisitCode.ag" #-} rule0 = \ (_ :: ()) -> {-# LINE 53 "./src-ag/PrintVisitCode.ag" #-} [] {-# LINE 113 "dist/build/PrintVisitCode.hs"#-} -- CInterface -------------------------------------------------- -- wrapper data Inh_CInterface = Inh_CInterface { } data Syn_CInterface = Syn_CInterface { } {-# INLINABLE wrap_CInterface #-} wrap_CInterface :: T_CInterface -> Inh_CInterface -> (Syn_CInterface ) wrap_CInterface (T_CInterface act) (Inh_CInterface ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_CInterface_vIn4 (T_CInterface_vOut4 ) <- return (inv_CInterface_s5 sem arg) return (Syn_CInterface ) ) -- cata {-# INLINE sem_CInterface #-} sem_CInterface :: CInterface -> T_CInterface sem_CInterface ( CInterface seg_ ) = sem_CInterface_CInterface ( sem_CSegments seg_ ) -- semantic domain newtype T_CInterface = T_CInterface { attach_T_CInterface :: Identity (T_CInterface_s5 ) } newtype T_CInterface_s5 = C_CInterface_s5 { inv_CInterface_s5 :: (T_CInterface_v4 ) } data T_CInterface_s6 = C_CInterface_s6 type T_CInterface_v4 = (T_CInterface_vIn4 ) -> (T_CInterface_vOut4 ) data T_CInterface_vIn4 = T_CInterface_vIn4 data T_CInterface_vOut4 = T_CInterface_vOut4 {-# NOINLINE sem_CInterface_CInterface #-} sem_CInterface_CInterface :: T_CSegments -> T_CInterface sem_CInterface_CInterface arg_seg_ = T_CInterface (return st5) where {-# NOINLINE st5 #-} st5 = let v4 :: T_CInterface_v4 v4 = \ (T_CInterface_vIn4 ) -> ( let _segX26 = Control.Monad.Identity.runIdentity (attach_T_CSegments (arg_seg_)) (T_CSegments_vOut25 ) = inv_CSegments_s26 _segX26 (T_CSegments_vIn25 ) __result_ = T_CInterface_vOut4 in __result_ ) in C_CInterface_s5 v4 -- CNonterminal ------------------------------------------------ -- wrapper data Inh_CNonterminal = Inh_CNonterminal { } data Syn_CNonterminal = Syn_CNonterminal { } {-# INLINABLE wrap_CNonterminal #-} wrap_CNonterminal :: T_CNonterminal -> Inh_CNonterminal -> (Syn_CNonterminal ) wrap_CNonterminal (T_CNonterminal act) (Inh_CNonterminal ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_CNonterminal_vIn7 (T_CNonterminal_vOut7 ) <- return (inv_CNonterminal_s8 sem arg) return (Syn_CNonterminal ) ) -- cata {-# INLINE sem_CNonterminal #-} sem_CNonterminal :: CNonterminal -> T_CNonterminal sem_CNonterminal ( CNonterminal nt_ params_ inh_ syn_ prods_ inter_ ) = sem_CNonterminal_CNonterminal nt_ params_ inh_ syn_ ( sem_CProductions prods_ ) ( sem_CInterface inter_ ) -- semantic domain newtype T_CNonterminal = T_CNonterminal { attach_T_CNonterminal :: Identity (T_CNonterminal_s8 ) } newtype T_CNonterminal_s8 = C_CNonterminal_s8 { inv_CNonterminal_s8 :: (T_CNonterminal_v7 ) } data T_CNonterminal_s9 = C_CNonterminal_s9 type T_CNonterminal_v7 = (T_CNonterminal_vIn7 ) -> (T_CNonterminal_vOut7 ) data T_CNonterminal_vIn7 = T_CNonterminal_vIn7 data T_CNonterminal_vOut7 = T_CNonterminal_vOut7 {-# NOINLINE sem_CNonterminal_CNonterminal #-} sem_CNonterminal_CNonterminal :: (NontermIdent) -> ([Identifier]) -> (Attributes) -> (Attributes) -> T_CProductions -> T_CInterface -> T_CNonterminal sem_CNonterminal_CNonterminal _ _ _ _ arg_prods_ arg_inter_ = T_CNonterminal (return st8) where {-# NOINLINE st8 #-} st8 = let v7 :: T_CNonterminal_v7 v7 = \ (T_CNonterminal_vIn7 ) -> ( let _prodsX17 = Control.Monad.Identity.runIdentity (attach_T_CProductions (arg_prods_)) _interX5 = Control.Monad.Identity.runIdentity (attach_T_CInterface (arg_inter_)) (T_CProductions_vOut16 ) = inv_CProductions_s17 _prodsX17 (T_CProductions_vIn16 ) (T_CInterface_vOut4 ) = inv_CInterface_s5 _interX5 (T_CInterface_vIn4 ) __result_ = T_CNonterminal_vOut7 in __result_ ) in C_CNonterminal_s8 v7 -- CNonterminals ----------------------------------------------- -- wrapper data Inh_CNonterminals = Inh_CNonterminals { } data Syn_CNonterminals = Syn_CNonterminals { } {-# INLINABLE wrap_CNonterminals #-} wrap_CNonterminals :: T_CNonterminals -> Inh_CNonterminals -> (Syn_CNonterminals ) wrap_CNonterminals (T_CNonterminals act) (Inh_CNonterminals ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_CNonterminals_vIn10 (T_CNonterminals_vOut10 ) <- return (inv_CNonterminals_s11 sem arg) return (Syn_CNonterminals ) ) -- cata {-# NOINLINE sem_CNonterminals #-} sem_CNonterminals :: CNonterminals -> T_CNonterminals sem_CNonterminals list = Prelude.foldr sem_CNonterminals_Cons sem_CNonterminals_Nil (Prelude.map sem_CNonterminal list) -- semantic domain newtype T_CNonterminals = T_CNonterminals { attach_T_CNonterminals :: Identity (T_CNonterminals_s11 ) } newtype T_CNonterminals_s11 = C_CNonterminals_s11 { inv_CNonterminals_s11 :: (T_CNonterminals_v10 ) } data T_CNonterminals_s12 = C_CNonterminals_s12 type T_CNonterminals_v10 = (T_CNonterminals_vIn10 ) -> (T_CNonterminals_vOut10 ) data T_CNonterminals_vIn10 = T_CNonterminals_vIn10 data T_CNonterminals_vOut10 = T_CNonterminals_vOut10 {-# NOINLINE sem_CNonterminals_Cons #-} sem_CNonterminals_Cons :: T_CNonterminal -> T_CNonterminals -> T_CNonterminals sem_CNonterminals_Cons arg_hd_ arg_tl_ = T_CNonterminals (return st11) where {-# NOINLINE st11 #-} st11 = let v10 :: T_CNonterminals_v10 v10 = \ (T_CNonterminals_vIn10 ) -> ( let _hdX8 = Control.Monad.Identity.runIdentity (attach_T_CNonterminal (arg_hd_)) _tlX11 = Control.Monad.Identity.runIdentity (attach_T_CNonterminals (arg_tl_)) (T_CNonterminal_vOut7 ) = inv_CNonterminal_s8 _hdX8 (T_CNonterminal_vIn7 ) (T_CNonterminals_vOut10 ) = inv_CNonterminals_s11 _tlX11 (T_CNonterminals_vIn10 ) __result_ = T_CNonterminals_vOut10 in __result_ ) in C_CNonterminals_s11 v10 {-# NOINLINE sem_CNonterminals_Nil #-} sem_CNonterminals_Nil :: T_CNonterminals sem_CNonterminals_Nil = T_CNonterminals (return st11) where {-# NOINLINE st11 #-} st11 = let v10 :: T_CNonterminals_v10 v10 = \ (T_CNonterminals_vIn10 ) -> ( let __result_ = T_CNonterminals_vOut10 in __result_ ) in C_CNonterminals_s11 v10 -- CProduction ------------------------------------------------- -- wrapper data Inh_CProduction = Inh_CProduction { } data Syn_CProduction = Syn_CProduction { } {-# INLINABLE wrap_CProduction #-} wrap_CProduction :: T_CProduction -> Inh_CProduction -> (Syn_CProduction ) wrap_CProduction (T_CProduction act) (Inh_CProduction ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_CProduction_vIn13 (T_CProduction_vOut13 ) <- return (inv_CProduction_s14 sem arg) return (Syn_CProduction ) ) -- cata {-# INLINE sem_CProduction #-} sem_CProduction :: CProduction -> T_CProduction sem_CProduction ( CProduction con_ visits_ children_ terminals_ ) = sem_CProduction_CProduction con_ ( sem_CVisits visits_ ) children_ terminals_ -- semantic domain newtype T_CProduction = T_CProduction { attach_T_CProduction :: Identity (T_CProduction_s14 ) } newtype T_CProduction_s14 = C_CProduction_s14 { inv_CProduction_s14 :: (T_CProduction_v13 ) } data T_CProduction_s15 = C_CProduction_s15 type T_CProduction_v13 = (T_CProduction_vIn13 ) -> (T_CProduction_vOut13 ) data T_CProduction_vIn13 = T_CProduction_vIn13 data T_CProduction_vOut13 = T_CProduction_vOut13 {-# NOINLINE sem_CProduction_CProduction #-} sem_CProduction_CProduction :: (ConstructorIdent) -> T_CVisits -> ([(Identifier,Type,ChildKind)]) -> ([Identifier]) -> T_CProduction sem_CProduction_CProduction _ arg_visits_ _ _ = T_CProduction (return st14) where {-# NOINLINE st14 #-} st14 = let v13 :: T_CProduction_v13 v13 = \ (T_CProduction_vIn13 ) -> ( let _visitsX32 = Control.Monad.Identity.runIdentity (attach_T_CVisits (arg_visits_)) (T_CVisits_vOut31 ) = inv_CVisits_s32 _visitsX32 (T_CVisits_vIn31 ) __result_ = T_CProduction_vOut13 in __result_ ) in C_CProduction_s14 v13 -- CProductions ------------------------------------------------ -- wrapper data Inh_CProductions = Inh_CProductions { } data Syn_CProductions = Syn_CProductions { } {-# INLINABLE wrap_CProductions #-} wrap_CProductions :: T_CProductions -> Inh_CProductions -> (Syn_CProductions ) wrap_CProductions (T_CProductions act) (Inh_CProductions ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_CProductions_vIn16 (T_CProductions_vOut16 ) <- return (inv_CProductions_s17 sem arg) return (Syn_CProductions ) ) -- cata {-# NOINLINE sem_CProductions #-} sem_CProductions :: CProductions -> T_CProductions sem_CProductions list = Prelude.foldr sem_CProductions_Cons sem_CProductions_Nil (Prelude.map sem_CProduction list) -- semantic domain newtype T_CProductions = T_CProductions { attach_T_CProductions :: Identity (T_CProductions_s17 ) } newtype T_CProductions_s17 = C_CProductions_s17 { inv_CProductions_s17 :: (T_CProductions_v16 ) } data T_CProductions_s18 = C_CProductions_s18 type T_CProductions_v16 = (T_CProductions_vIn16 ) -> (T_CProductions_vOut16 ) data T_CProductions_vIn16 = T_CProductions_vIn16 data T_CProductions_vOut16 = T_CProductions_vOut16 {-# NOINLINE sem_CProductions_Cons #-} sem_CProductions_Cons :: T_CProduction -> T_CProductions -> T_CProductions sem_CProductions_Cons arg_hd_ arg_tl_ = T_CProductions (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_CProductions_v16 v16 = \ (T_CProductions_vIn16 ) -> ( let _hdX14 = Control.Monad.Identity.runIdentity (attach_T_CProduction (arg_hd_)) _tlX17 = Control.Monad.Identity.runIdentity (attach_T_CProductions (arg_tl_)) (T_CProduction_vOut13 ) = inv_CProduction_s14 _hdX14 (T_CProduction_vIn13 ) (T_CProductions_vOut16 ) = inv_CProductions_s17 _tlX17 (T_CProductions_vIn16 ) __result_ = T_CProductions_vOut16 in __result_ ) in C_CProductions_s17 v16 {-# NOINLINE sem_CProductions_Nil #-} sem_CProductions_Nil :: T_CProductions sem_CProductions_Nil = T_CProductions (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_CProductions_v16 v16 = \ (T_CProductions_vIn16 ) -> ( let __result_ = T_CProductions_vOut16 in __result_ ) in C_CProductions_s17 v16 -- CRule ------------------------------------------------------- -- wrapper data Inh_CRule = Inh_CRule { } data Syn_CRule = Syn_CRule { } {-# INLINABLE wrap_CRule #-} wrap_CRule :: T_CRule -> Inh_CRule -> (Syn_CRule ) wrap_CRule (T_CRule act) (Inh_CRule ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_CRule_vIn19 (T_CRule_vOut19 ) <- return (inv_CRule_s20 sem arg) return (Syn_CRule ) ) -- cata {-# NOINLINE sem_CRule #-} sem_CRule :: CRule -> T_CRule sem_CRule ( CRule name_ isIn_ hasCode_ nt_ con_ field_ childnt_ tp_ pattern_ rhs_ defines_ owrt_ origin_ uses_ explicit_ mbNamed_ ) = sem_CRule_CRule name_ isIn_ hasCode_ nt_ con_ field_ childnt_ tp_ ( sem_Pattern pattern_ ) rhs_ defines_ owrt_ origin_ uses_ explicit_ mbNamed_ sem_CRule ( CChildVisit name_ nt_ nr_ inh_ syn_ isLast_ ) = sem_CRule_CChildVisit name_ nt_ nr_ inh_ syn_ isLast_ -- semantic domain newtype T_CRule = T_CRule { attach_T_CRule :: Identity (T_CRule_s20 ) } newtype T_CRule_s20 = C_CRule_s20 { inv_CRule_s20 :: (T_CRule_v19 ) } data T_CRule_s21 = C_CRule_s21 type T_CRule_v19 = (T_CRule_vIn19 ) -> (T_CRule_vOut19 ) data T_CRule_vIn19 = T_CRule_vIn19 data T_CRule_vOut19 = T_CRule_vOut19 {-# NOINLINE sem_CRule_CRule #-} sem_CRule_CRule :: (Identifier) -> (Bool) -> (Bool) -> (NontermIdent) -> (ConstructorIdent) -> (Identifier) -> (Maybe NontermIdent) -> (Maybe Type) -> T_Pattern -> ([String]) -> (Map Int (Identifier,Identifier,Maybe Type)) -> (Bool) -> (String) -> (Set (Identifier, Identifier)) -> (Bool) -> (Maybe Identifier) -> T_CRule sem_CRule_CRule _ _ _ _ _ _ _ _ arg_pattern_ _ _ _ _ _ _ _ = T_CRule (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_CRule_v19 v19 = \ (T_CRule_vIn19 ) -> ( let _patternX41 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pattern_)) (T_Pattern_vOut40 _patternIcopy) = inv_Pattern_s41 _patternX41 (T_Pattern_vIn40 ) __result_ = T_CRule_vOut19 in __result_ ) in C_CRule_s20 v19 {-# NOINLINE sem_CRule_CChildVisit #-} sem_CRule_CChildVisit :: (Identifier) -> (NontermIdent) -> (Int) -> (Attributes) -> (Attributes) -> (Bool) -> T_CRule sem_CRule_CChildVisit _ _ _ _ _ _ = T_CRule (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_CRule_v19 v19 = \ (T_CRule_vIn19 ) -> ( let __result_ = T_CRule_vOut19 in __result_ ) in C_CRule_s20 v19 -- CSegment ---------------------------------------------------- -- wrapper data Inh_CSegment = Inh_CSegment { } data Syn_CSegment = Syn_CSegment { } {-# INLINABLE wrap_CSegment #-} wrap_CSegment :: T_CSegment -> Inh_CSegment -> (Syn_CSegment ) wrap_CSegment (T_CSegment act) (Inh_CSegment ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_CSegment_vIn22 (T_CSegment_vOut22 ) <- return (inv_CSegment_s23 sem arg) return (Syn_CSegment ) ) -- cata {-# INLINE sem_CSegment #-} sem_CSegment :: CSegment -> T_CSegment sem_CSegment ( CSegment inh_ syn_ ) = sem_CSegment_CSegment inh_ syn_ -- semantic domain newtype T_CSegment = T_CSegment { attach_T_CSegment :: Identity (T_CSegment_s23 ) } newtype T_CSegment_s23 = C_CSegment_s23 { inv_CSegment_s23 :: (T_CSegment_v22 ) } data T_CSegment_s24 = C_CSegment_s24 type T_CSegment_v22 = (T_CSegment_vIn22 ) -> (T_CSegment_vOut22 ) data T_CSegment_vIn22 = T_CSegment_vIn22 data T_CSegment_vOut22 = T_CSegment_vOut22 {-# NOINLINE sem_CSegment_CSegment #-} sem_CSegment_CSegment :: (Attributes) -> (Attributes) -> T_CSegment sem_CSegment_CSegment _ _ = T_CSegment (return st23) where {-# NOINLINE st23 #-} st23 = let v22 :: T_CSegment_v22 v22 = \ (T_CSegment_vIn22 ) -> ( let __result_ = T_CSegment_vOut22 in __result_ ) in C_CSegment_s23 v22 -- CSegments --------------------------------------------------- -- wrapper data Inh_CSegments = Inh_CSegments { } data Syn_CSegments = Syn_CSegments { } {-# INLINABLE wrap_CSegments #-} wrap_CSegments :: T_CSegments -> Inh_CSegments -> (Syn_CSegments ) wrap_CSegments (T_CSegments act) (Inh_CSegments ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_CSegments_vIn25 (T_CSegments_vOut25 ) <- return (inv_CSegments_s26 sem arg) return (Syn_CSegments ) ) -- cata {-# NOINLINE sem_CSegments #-} sem_CSegments :: CSegments -> T_CSegments sem_CSegments list = Prelude.foldr sem_CSegments_Cons sem_CSegments_Nil (Prelude.map sem_CSegment list) -- semantic domain newtype T_CSegments = T_CSegments { attach_T_CSegments :: Identity (T_CSegments_s26 ) } newtype T_CSegments_s26 = C_CSegments_s26 { inv_CSegments_s26 :: (T_CSegments_v25 ) } data T_CSegments_s27 = C_CSegments_s27 type T_CSegments_v25 = (T_CSegments_vIn25 ) -> (T_CSegments_vOut25 ) data T_CSegments_vIn25 = T_CSegments_vIn25 data T_CSegments_vOut25 = T_CSegments_vOut25 {-# NOINLINE sem_CSegments_Cons #-} sem_CSegments_Cons :: T_CSegment -> T_CSegments -> T_CSegments sem_CSegments_Cons arg_hd_ arg_tl_ = T_CSegments (return st26) where {-# NOINLINE st26 #-} st26 = let v25 :: T_CSegments_v25 v25 = \ (T_CSegments_vIn25 ) -> ( let _hdX23 = Control.Monad.Identity.runIdentity (attach_T_CSegment (arg_hd_)) _tlX26 = Control.Monad.Identity.runIdentity (attach_T_CSegments (arg_tl_)) (T_CSegment_vOut22 ) = inv_CSegment_s23 _hdX23 (T_CSegment_vIn22 ) (T_CSegments_vOut25 ) = inv_CSegments_s26 _tlX26 (T_CSegments_vIn25 ) __result_ = T_CSegments_vOut25 in __result_ ) in C_CSegments_s26 v25 {-# NOINLINE sem_CSegments_Nil #-} sem_CSegments_Nil :: T_CSegments sem_CSegments_Nil = T_CSegments (return st26) where {-# NOINLINE st26 #-} st26 = let v25 :: T_CSegments_v25 v25 = \ (T_CSegments_vIn25 ) -> ( let __result_ = T_CSegments_vOut25 in __result_ ) in C_CSegments_s26 v25 -- CVisit ------------------------------------------------------ -- wrapper data Inh_CVisit = Inh_CVisit { } data Syn_CVisit = Syn_CVisit { } {-# INLINABLE wrap_CVisit #-} wrap_CVisit :: T_CVisit -> Inh_CVisit -> (Syn_CVisit ) wrap_CVisit (T_CVisit act) (Inh_CVisit ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_CVisit_vIn28 (T_CVisit_vOut28 ) <- return (inv_CVisit_s29 sem arg) return (Syn_CVisit ) ) -- cata {-# INLINE sem_CVisit #-} sem_CVisit :: CVisit -> T_CVisit sem_CVisit ( CVisit inh_ syn_ vss_ intra_ ordered_ ) = sem_CVisit_CVisit inh_ syn_ ( sem_Sequence vss_ ) ( sem_Sequence intra_ ) ordered_ -- semantic domain newtype T_CVisit = T_CVisit { attach_T_CVisit :: Identity (T_CVisit_s29 ) } newtype T_CVisit_s29 = C_CVisit_s29 { inv_CVisit_s29 :: (T_CVisit_v28 ) } data T_CVisit_s30 = C_CVisit_s30 type T_CVisit_v28 = (T_CVisit_vIn28 ) -> (T_CVisit_vOut28 ) data T_CVisit_vIn28 = T_CVisit_vIn28 data T_CVisit_vOut28 = T_CVisit_vOut28 {-# NOINLINE sem_CVisit_CVisit #-} sem_CVisit_CVisit :: (Attributes) -> (Attributes) -> T_Sequence -> T_Sequence -> (Bool) -> T_CVisit sem_CVisit_CVisit _ _ arg_vss_ arg_intra_ _ = T_CVisit (return st29) where {-# NOINLINE st29 #-} st29 = let v28 :: T_CVisit_v28 v28 = \ (T_CVisit_vIn28 ) -> ( let _vssX47 = Control.Monad.Identity.runIdentity (attach_T_Sequence (arg_vss_)) _intraX47 = Control.Monad.Identity.runIdentity (attach_T_Sequence (arg_intra_)) (T_Sequence_vOut46 ) = inv_Sequence_s47 _vssX47 (T_Sequence_vIn46 ) (T_Sequence_vOut46 ) = inv_Sequence_s47 _intraX47 (T_Sequence_vIn46 ) __result_ = T_CVisit_vOut28 in __result_ ) in C_CVisit_s29 v28 -- CVisits ----------------------------------------------------- -- wrapper data Inh_CVisits = Inh_CVisits { } data Syn_CVisits = Syn_CVisits { } {-# INLINABLE wrap_CVisits #-} wrap_CVisits :: T_CVisits -> Inh_CVisits -> (Syn_CVisits ) wrap_CVisits (T_CVisits act) (Inh_CVisits ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_CVisits_vIn31 (T_CVisits_vOut31 ) <- return (inv_CVisits_s32 sem arg) return (Syn_CVisits ) ) -- cata {-# NOINLINE sem_CVisits #-} sem_CVisits :: CVisits -> T_CVisits sem_CVisits list = Prelude.foldr sem_CVisits_Cons sem_CVisits_Nil (Prelude.map sem_CVisit list) -- semantic domain newtype T_CVisits = T_CVisits { attach_T_CVisits :: Identity (T_CVisits_s32 ) } newtype T_CVisits_s32 = C_CVisits_s32 { inv_CVisits_s32 :: (T_CVisits_v31 ) } data T_CVisits_s33 = C_CVisits_s33 type T_CVisits_v31 = (T_CVisits_vIn31 ) -> (T_CVisits_vOut31 ) data T_CVisits_vIn31 = T_CVisits_vIn31 data T_CVisits_vOut31 = T_CVisits_vOut31 {-# NOINLINE sem_CVisits_Cons #-} sem_CVisits_Cons :: T_CVisit -> T_CVisits -> T_CVisits sem_CVisits_Cons arg_hd_ arg_tl_ = T_CVisits (return st32) where {-# NOINLINE st32 #-} st32 = let v31 :: T_CVisits_v31 v31 = \ (T_CVisits_vIn31 ) -> ( let _hdX29 = Control.Monad.Identity.runIdentity (attach_T_CVisit (arg_hd_)) _tlX32 = Control.Monad.Identity.runIdentity (attach_T_CVisits (arg_tl_)) (T_CVisit_vOut28 ) = inv_CVisit_s29 _hdX29 (T_CVisit_vIn28 ) (T_CVisits_vOut31 ) = inv_CVisits_s32 _tlX32 (T_CVisits_vIn31 ) __result_ = T_CVisits_vOut31 in __result_ ) in C_CVisits_s32 v31 {-# NOINLINE sem_CVisits_Nil #-} sem_CVisits_Nil :: T_CVisits sem_CVisits_Nil = T_CVisits (return st32) where {-# NOINLINE st32 #-} st32 = let v31 :: T_CVisits_v31 v31 = \ (T_CVisits_vIn31 ) -> ( let __result_ = T_CVisits_vOut31 in __result_ ) in C_CVisits_s32 v31 -- DeclBlocks -------------------------------------------------- -- wrapper data Inh_DeclBlocks = Inh_DeclBlocks { } data Syn_DeclBlocks = Syn_DeclBlocks { } {-# INLINABLE wrap_DeclBlocks #-} wrap_DeclBlocks :: T_DeclBlocks -> Inh_DeclBlocks -> (Syn_DeclBlocks ) wrap_DeclBlocks (T_DeclBlocks act) (Inh_DeclBlocks ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_DeclBlocks_vIn34 (T_DeclBlocks_vOut34 ) <- return (inv_DeclBlocks_s35 sem arg) return (Syn_DeclBlocks ) ) -- cata {-# NOINLINE sem_DeclBlocks #-} sem_DeclBlocks :: DeclBlocks -> T_DeclBlocks sem_DeclBlocks ( DeclBlock defs_ visit_ next_ ) = sem_DeclBlocks_DeclBlock defs_ visit_ ( sem_DeclBlocks next_ ) sem_DeclBlocks ( DeclTerminator defs_ result_ ) = sem_DeclBlocks_DeclTerminator defs_ result_ -- semantic domain newtype T_DeclBlocks = T_DeclBlocks { attach_T_DeclBlocks :: Identity (T_DeclBlocks_s35 ) } newtype T_DeclBlocks_s35 = C_DeclBlocks_s35 { inv_DeclBlocks_s35 :: (T_DeclBlocks_v34 ) } data T_DeclBlocks_s36 = C_DeclBlocks_s36 type T_DeclBlocks_v34 = (T_DeclBlocks_vIn34 ) -> (T_DeclBlocks_vOut34 ) data T_DeclBlocks_vIn34 = T_DeclBlocks_vIn34 data T_DeclBlocks_vOut34 = T_DeclBlocks_vOut34 {-# NOINLINE sem_DeclBlocks_DeclBlock #-} sem_DeclBlocks_DeclBlock :: ([Decl]) -> (Decl) -> T_DeclBlocks -> T_DeclBlocks sem_DeclBlocks_DeclBlock _ _ arg_next_ = T_DeclBlocks (return st35) where {-# NOINLINE st35 #-} st35 = let v34 :: T_DeclBlocks_v34 v34 = \ (T_DeclBlocks_vIn34 ) -> ( let _nextX35 = Control.Monad.Identity.runIdentity (attach_T_DeclBlocks (arg_next_)) (T_DeclBlocks_vOut34 ) = inv_DeclBlocks_s35 _nextX35 (T_DeclBlocks_vIn34 ) __result_ = T_DeclBlocks_vOut34 in __result_ ) in C_DeclBlocks_s35 v34 {-# NOINLINE sem_DeclBlocks_DeclTerminator #-} sem_DeclBlocks_DeclTerminator :: ([Decl]) -> (Expr) -> T_DeclBlocks sem_DeclBlocks_DeclTerminator _ _ = T_DeclBlocks (return st35) where {-# NOINLINE st35 #-} st35 = let v34 :: T_DeclBlocks_v34 v34 = \ (T_DeclBlocks_vIn34 ) -> ( let __result_ = T_DeclBlocks_vOut34 in __result_ ) in C_DeclBlocks_s35 v34 -- DeclBlocksRoot ---------------------------------------------- -- wrapper data Inh_DeclBlocksRoot = Inh_DeclBlocksRoot { } data Syn_DeclBlocksRoot = Syn_DeclBlocksRoot { } {-# INLINABLE wrap_DeclBlocksRoot #-} wrap_DeclBlocksRoot :: T_DeclBlocksRoot -> Inh_DeclBlocksRoot -> (Syn_DeclBlocksRoot ) wrap_DeclBlocksRoot (T_DeclBlocksRoot act) (Inh_DeclBlocksRoot ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_DeclBlocksRoot_vIn37 (T_DeclBlocksRoot_vOut37 ) <- return (inv_DeclBlocksRoot_s38 sem arg) return (Syn_DeclBlocksRoot ) ) -- cata {-# INLINE sem_DeclBlocksRoot #-} sem_DeclBlocksRoot :: DeclBlocksRoot -> T_DeclBlocksRoot sem_DeclBlocksRoot ( DeclBlocksRoot blocks_ ) = sem_DeclBlocksRoot_DeclBlocksRoot ( sem_DeclBlocks blocks_ ) -- semantic domain newtype T_DeclBlocksRoot = T_DeclBlocksRoot { attach_T_DeclBlocksRoot :: Identity (T_DeclBlocksRoot_s38 ) } newtype T_DeclBlocksRoot_s38 = C_DeclBlocksRoot_s38 { inv_DeclBlocksRoot_s38 :: (T_DeclBlocksRoot_v37 ) } data T_DeclBlocksRoot_s39 = C_DeclBlocksRoot_s39 type T_DeclBlocksRoot_v37 = (T_DeclBlocksRoot_vIn37 ) -> (T_DeclBlocksRoot_vOut37 ) data T_DeclBlocksRoot_vIn37 = T_DeclBlocksRoot_vIn37 data T_DeclBlocksRoot_vOut37 = T_DeclBlocksRoot_vOut37 {-# NOINLINE sem_DeclBlocksRoot_DeclBlocksRoot #-} sem_DeclBlocksRoot_DeclBlocksRoot :: T_DeclBlocks -> T_DeclBlocksRoot sem_DeclBlocksRoot_DeclBlocksRoot arg_blocks_ = T_DeclBlocksRoot (return st38) where {-# NOINLINE st38 #-} st38 = let v37 :: T_DeclBlocksRoot_v37 v37 = \ (T_DeclBlocksRoot_vIn37 ) -> ( let _blocksX35 = Control.Monad.Identity.runIdentity (attach_T_DeclBlocks (arg_blocks_)) (T_DeclBlocks_vOut34 ) = inv_DeclBlocks_s35 _blocksX35 (T_DeclBlocks_vIn34 ) __result_ = T_DeclBlocksRoot_vOut37 in __result_ ) in C_DeclBlocksRoot_s38 v37 -- Pattern ----------------------------------------------------- -- wrapper data Inh_Pattern = Inh_Pattern { } data Syn_Pattern = Syn_Pattern { copy_Syn_Pattern :: (Pattern) } {-# INLINABLE wrap_Pattern #-} wrap_Pattern :: T_Pattern -> Inh_Pattern -> (Syn_Pattern ) wrap_Pattern (T_Pattern act) (Inh_Pattern ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Pattern_vIn40 (T_Pattern_vOut40 _lhsOcopy) <- return (inv_Pattern_s41 sem arg) return (Syn_Pattern _lhsOcopy) ) -- cata {-# NOINLINE sem_Pattern #-} sem_Pattern :: Pattern -> T_Pattern sem_Pattern ( Constr name_ pats_ ) = sem_Pattern_Constr name_ ( sem_Patterns pats_ ) sem_Pattern ( Product pos_ pats_ ) = sem_Pattern_Product pos_ ( sem_Patterns pats_ ) sem_Pattern ( Alias field_ attr_ pat_ ) = sem_Pattern_Alias field_ attr_ ( sem_Pattern pat_ ) sem_Pattern ( Irrefutable pat_ ) = sem_Pattern_Irrefutable ( sem_Pattern pat_ ) sem_Pattern ( Underscore pos_ ) = sem_Pattern_Underscore pos_ -- semantic domain newtype T_Pattern = T_Pattern { attach_T_Pattern :: Identity (T_Pattern_s41 ) } newtype T_Pattern_s41 = C_Pattern_s41 { inv_Pattern_s41 :: (T_Pattern_v40 ) } data T_Pattern_s42 = C_Pattern_s42 type T_Pattern_v40 = (T_Pattern_vIn40 ) -> (T_Pattern_vOut40 ) data T_Pattern_vIn40 = T_Pattern_vIn40 data T_Pattern_vOut40 = T_Pattern_vOut40 (Pattern) {-# NOINLINE sem_Pattern_Constr #-} sem_Pattern_Constr :: (ConstructorIdent) -> T_Patterns -> T_Pattern sem_Pattern_Constr arg_name_ arg_pats_ = T_Pattern (return st41) where {-# NOINLINE st41 #-} st41 = let v40 :: T_Pattern_v40 v40 = \ (T_Pattern_vIn40 ) -> ( let _patsX44 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) (T_Patterns_vOut43 _patsIcopy) = inv_Patterns_s44 _patsX44 (T_Patterns_vIn43 ) _copy = rule1 _patsIcopy arg_name_ _lhsOcopy :: Pattern _lhsOcopy = rule2 _copy __result_ = T_Pattern_vOut40 _lhsOcopy in __result_ ) in C_Pattern_s41 v40 {-# INLINE rule1 #-} rule1 = \ ((_patsIcopy) :: Patterns) name_ -> Constr name_ _patsIcopy {-# INLINE rule2 #-} rule2 = \ _copy -> _copy {-# NOINLINE sem_Pattern_Product #-} sem_Pattern_Product :: (Pos) -> T_Patterns -> T_Pattern sem_Pattern_Product arg_pos_ arg_pats_ = T_Pattern (return st41) where {-# NOINLINE st41 #-} st41 = let v40 :: T_Pattern_v40 v40 = \ (T_Pattern_vIn40 ) -> ( let _patsX44 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) (T_Patterns_vOut43 _patsIcopy) = inv_Patterns_s44 _patsX44 (T_Patterns_vIn43 ) _copy = rule3 _patsIcopy arg_pos_ _lhsOcopy :: Pattern _lhsOcopy = rule4 _copy __result_ = T_Pattern_vOut40 _lhsOcopy in __result_ ) in C_Pattern_s41 v40 {-# INLINE rule3 #-} rule3 = \ ((_patsIcopy) :: Patterns) pos_ -> Product pos_ _patsIcopy {-# INLINE rule4 #-} rule4 = \ _copy -> _copy {-# NOINLINE sem_Pattern_Alias #-} sem_Pattern_Alias :: (Identifier) -> (Identifier) -> T_Pattern -> T_Pattern sem_Pattern_Alias arg_field_ arg_attr_ arg_pat_ = T_Pattern (return st41) where {-# NOINLINE st41 #-} st41 = let v40 :: T_Pattern_v40 v40 = \ (T_Pattern_vIn40 ) -> ( let _patX41 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) (T_Pattern_vOut40 _patIcopy) = inv_Pattern_s41 _patX41 (T_Pattern_vIn40 ) _copy = rule5 _patIcopy arg_attr_ arg_field_ _lhsOcopy :: Pattern _lhsOcopy = rule6 _copy __result_ = T_Pattern_vOut40 _lhsOcopy in __result_ ) in C_Pattern_s41 v40 {-# INLINE rule5 #-} rule5 = \ ((_patIcopy) :: Pattern) attr_ field_ -> Alias field_ attr_ _patIcopy {-# INLINE rule6 #-} rule6 = \ _copy -> _copy {-# NOINLINE sem_Pattern_Irrefutable #-} sem_Pattern_Irrefutable :: T_Pattern -> T_Pattern sem_Pattern_Irrefutable arg_pat_ = T_Pattern (return st41) where {-# NOINLINE st41 #-} st41 = let v40 :: T_Pattern_v40 v40 = \ (T_Pattern_vIn40 ) -> ( let _patX41 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) (T_Pattern_vOut40 _patIcopy) = inv_Pattern_s41 _patX41 (T_Pattern_vIn40 ) _copy = rule7 _patIcopy _lhsOcopy :: Pattern _lhsOcopy = rule8 _copy __result_ = T_Pattern_vOut40 _lhsOcopy in __result_ ) in C_Pattern_s41 v40 {-# INLINE rule7 #-} rule7 = \ ((_patIcopy) :: Pattern) -> Irrefutable _patIcopy {-# INLINE rule8 #-} rule8 = \ _copy -> _copy {-# NOINLINE sem_Pattern_Underscore #-} sem_Pattern_Underscore :: (Pos) -> T_Pattern sem_Pattern_Underscore arg_pos_ = T_Pattern (return st41) where {-# NOINLINE st41 #-} st41 = let v40 :: T_Pattern_v40 v40 = \ (T_Pattern_vIn40 ) -> ( let _copy = rule9 arg_pos_ _lhsOcopy :: Pattern _lhsOcopy = rule10 _copy __result_ = T_Pattern_vOut40 _lhsOcopy in __result_ ) in C_Pattern_s41 v40 {-# INLINE rule9 #-} rule9 = \ pos_ -> Underscore pos_ {-# INLINE rule10 #-} rule10 = \ _copy -> _copy -- Patterns ---------------------------------------------------- -- wrapper data Inh_Patterns = Inh_Patterns { } data Syn_Patterns = Syn_Patterns { copy_Syn_Patterns :: (Patterns) } {-# INLINABLE wrap_Patterns #-} wrap_Patterns :: T_Patterns -> Inh_Patterns -> (Syn_Patterns ) wrap_Patterns (T_Patterns act) (Inh_Patterns ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Patterns_vIn43 (T_Patterns_vOut43 _lhsOcopy) <- return (inv_Patterns_s44 sem arg) return (Syn_Patterns _lhsOcopy) ) -- cata {-# NOINLINE sem_Patterns #-} sem_Patterns :: Patterns -> T_Patterns sem_Patterns list = Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list) -- semantic domain newtype T_Patterns = T_Patterns { attach_T_Patterns :: Identity (T_Patterns_s44 ) } newtype T_Patterns_s44 = C_Patterns_s44 { inv_Patterns_s44 :: (T_Patterns_v43 ) } data T_Patterns_s45 = C_Patterns_s45 type T_Patterns_v43 = (T_Patterns_vIn43 ) -> (T_Patterns_vOut43 ) data T_Patterns_vIn43 = T_Patterns_vIn43 data T_Patterns_vOut43 = T_Patterns_vOut43 (Patterns) {-# NOINLINE sem_Patterns_Cons #-} sem_Patterns_Cons :: T_Pattern -> T_Patterns -> T_Patterns sem_Patterns_Cons arg_hd_ arg_tl_ = T_Patterns (return st44) where {-# NOINLINE st44 #-} st44 = let v43 :: T_Patterns_v43 v43 = \ (T_Patterns_vIn43 ) -> ( let _hdX41 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_hd_)) _tlX44 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_tl_)) (T_Pattern_vOut40 _hdIcopy) = inv_Pattern_s41 _hdX41 (T_Pattern_vIn40 ) (T_Patterns_vOut43 _tlIcopy) = inv_Patterns_s44 _tlX44 (T_Patterns_vIn43 ) _copy = rule11 _hdIcopy _tlIcopy _lhsOcopy :: Patterns _lhsOcopy = rule12 _copy __result_ = T_Patterns_vOut43 _lhsOcopy in __result_ ) in C_Patterns_s44 v43 {-# INLINE rule11 #-} rule11 = \ ((_hdIcopy) :: Pattern) ((_tlIcopy) :: Patterns) -> (:) _hdIcopy _tlIcopy {-# INLINE rule12 #-} rule12 = \ _copy -> _copy {-# NOINLINE sem_Patterns_Nil #-} sem_Patterns_Nil :: T_Patterns sem_Patterns_Nil = T_Patterns (return st44) where {-# NOINLINE st44 #-} st44 = let v43 :: T_Patterns_v43 v43 = \ (T_Patterns_vIn43 ) -> ( let _copy = rule13 () _lhsOcopy :: Patterns _lhsOcopy = rule14 _copy __result_ = T_Patterns_vOut43 _lhsOcopy in __result_ ) in C_Patterns_s44 v43 {-# INLINE rule13 #-} rule13 = \ (_ :: ()) -> [] {-# INLINE rule14 #-} rule14 = \ _copy -> _copy -- Sequence ---------------------------------------------------- -- wrapper data Inh_Sequence = Inh_Sequence { } data Syn_Sequence = Syn_Sequence { } {-# INLINABLE wrap_Sequence #-} wrap_Sequence :: T_Sequence -> Inh_Sequence -> (Syn_Sequence ) wrap_Sequence (T_Sequence act) (Inh_Sequence ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Sequence_vIn46 (T_Sequence_vOut46 ) <- return (inv_Sequence_s47 sem arg) return (Syn_Sequence ) ) -- cata {-# NOINLINE sem_Sequence #-} sem_Sequence :: Sequence -> T_Sequence sem_Sequence list = Prelude.foldr sem_Sequence_Cons sem_Sequence_Nil (Prelude.map sem_CRule list) -- semantic domain newtype T_Sequence = T_Sequence { attach_T_Sequence :: Identity (T_Sequence_s47 ) } newtype T_Sequence_s47 = C_Sequence_s47 { inv_Sequence_s47 :: (T_Sequence_v46 ) } data T_Sequence_s48 = C_Sequence_s48 type T_Sequence_v46 = (T_Sequence_vIn46 ) -> (T_Sequence_vOut46 ) data T_Sequence_vIn46 = T_Sequence_vIn46 data T_Sequence_vOut46 = T_Sequence_vOut46 {-# NOINLINE sem_Sequence_Cons #-} sem_Sequence_Cons :: T_CRule -> T_Sequence -> T_Sequence sem_Sequence_Cons arg_hd_ arg_tl_ = T_Sequence (return st47) where {-# NOINLINE st47 #-} st47 = let v46 :: T_Sequence_v46 v46 = \ (T_Sequence_vIn46 ) -> ( let _hdX20 = Control.Monad.Identity.runIdentity (attach_T_CRule (arg_hd_)) _tlX47 = Control.Monad.Identity.runIdentity (attach_T_Sequence (arg_tl_)) (T_CRule_vOut19 ) = inv_CRule_s20 _hdX20 (T_CRule_vIn19 ) (T_Sequence_vOut46 ) = inv_Sequence_s47 _tlX47 (T_Sequence_vIn46 ) __result_ = T_Sequence_vOut46 in __result_ ) in C_Sequence_s47 v46 {-# NOINLINE sem_Sequence_Nil #-} sem_Sequence_Nil :: T_Sequence sem_Sequence_Nil = T_Sequence (return st47) where {-# NOINLINE st47 #-} st47 = let v46 :: T_Sequence_v46 v46 = \ (T_Sequence_vIn46 ) -> ( let __result_ = T_Sequence_vOut46 in __result_ ) in C_Sequence_s47 v46 uuagc-0.9.42.3/src-generated/ResolveLocals.hs000644 000765 000024 00000273632 12127045231 022717 0ustar00jeroenbransenstaff000000 000000 {-# LANGUAGE Rank2Types, GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} module ResolveLocals where {-# LINE 2 "./src-ag/AbstractSyntax.ag" #-} -- 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 {-# LINE 16 "dist/build/ResolveLocals.hs" #-} {-# LINE 2 "./src-ag/Patterns.ag" #-} -- Patterns.ag imports import UU.Scanner.Position(Pos) import CommonTypes (ConstructorIdent,Identifier) {-# LINE 23 "dist/build/ResolveLocals.hs" #-} {-# LINE 2 "./src-ag/Expression.ag" #-} import UU.Scanner.Position(Pos) import HsToken {-# LINE 29 "dist/build/ResolveLocals.hs" #-} {-# LINE 15 "./src-ag/ResolveLocals.ag" #-} 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 HsTokenScanner(lexTokens) import SemHsTokens(sem_HsTokensRoot,wrap_HsTokensRoot, Syn_HsTokensRoot(..),Inh_HsTokensRoot(..)) import Data.Maybe {-# LINE 48 "dist/build/ResolveLocals.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity -- Child ------------------------------------------------------- -- wrapper data Inh_Child = Inh_Child { allfields_Inh_Child :: ([(Identifier,Type,ChildKind)]), allnts_Inh_Child :: ([Identifier]), attrs_Inh_Child :: ([(Identifier,Identifier)]), con_Inh_Child :: (Identifier), inh_Inh_Child :: (Attributes), inhMap_Inh_Child :: (Map Identifier Attributes), mergeMap_Inh_Child :: (Map Identifier (Identifier,[Identifier])), nt_Inh_Child :: (Identifier), syn_Inh_Child :: (Attributes), synMap_Inh_Child :: (Map Identifier Attributes) } data Syn_Child = Syn_Child { attributes_Syn_Child :: ([(Identifier,Attributes,Attributes)]), field_Syn_Child :: ((Identifier,Type,ChildKind)), output_Syn_Child :: (Child) } {-# INLINABLE wrap_Child #-} wrap_Child :: T_Child -> Inh_Child -> (Syn_Child ) wrap_Child (T_Child act) (Inh_Child _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIsyn _lhsIsynMap) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Child_vIn1 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIsyn _lhsIsynMap (T_Child_vOut1 _lhsOattributes _lhsOfield _lhsOoutput) <- return (inv_Child_s2 sem arg) return (Syn_Child _lhsOattributes _lhsOfield _lhsOoutput) ) -- cata {-# INLINE sem_Child #-} sem_Child :: Child -> T_Child sem_Child ( Child name_ tp_ kind_ ) = sem_Child_Child name_ tp_ kind_ -- semantic domain newtype T_Child = T_Child { attach_T_Child :: Identity (T_Child_s2 ) } newtype T_Child_s2 = C_Child_s2 { inv_Child_s2 :: (T_Child_v1 ) } data T_Child_s3 = C_Child_s3 type T_Child_v1 = (T_Child_vIn1 ) -> (T_Child_vOut1 ) data T_Child_vIn1 = T_Child_vIn1 ([(Identifier,Type,ChildKind)]) ([Identifier]) ([(Identifier,Identifier)]) (Identifier) (Attributes) (Map Identifier Attributes) (Map Identifier (Identifier,[Identifier])) (Identifier) (Attributes) (Map Identifier Attributes) data T_Child_vOut1 = T_Child_vOut1 ([(Identifier,Attributes,Attributes)]) ((Identifier,Type,ChildKind)) (Child) {-# NOINLINE sem_Child_Child #-} sem_Child_Child :: (Identifier) -> (Type) -> (ChildKind) -> T_Child sem_Child_Child arg_name_ arg_tp_ arg_kind_ = T_Child (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Child_v1 v1 = \ (T_Child_vIn1 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIsyn _lhsIsynMap) -> ( let _chnt = rule0 arg_name_ arg_tp_ _inh = rule1 _chnt _lhsIinhMap _syn = rule2 _chnt _lhsIsynMap _lhsOattributes :: [(Identifier,Attributes,Attributes)] _lhsOattributes = rule3 _inh _syn arg_name_ _lhsOfield :: (Identifier,Type,ChildKind) _lhsOfield = rule4 arg_kind_ arg_name_ arg_tp_ _output = rule5 arg_kind_ arg_name_ arg_tp_ _lhsOoutput :: Child _lhsOoutput = rule6 _output __result_ = T_Child_vOut1 _lhsOattributes _lhsOfield _lhsOoutput in __result_ ) in C_Child_s2 v1 {-# INLINE rule0 #-} {-# LINE 19 "./src-ag/DistChildAttr.ag" #-} rule0 = \ name_ tp_ -> {-# LINE 19 "./src-ag/DistChildAttr.ag" #-} case tp_ of NT nt _ _ -> nt Self -> error ("The type of child " ++ show name_ ++ " should not be a Self type.") Haskell t -> identifier "" {-# LINE 109 "dist/build/ResolveLocals.hs"#-} {-# INLINE rule1 #-} {-# LINE 23 "./src-ag/DistChildAttr.ag" #-} rule1 = \ _chnt ((_lhsIinhMap) :: Map Identifier Attributes) -> {-# LINE 23 "./src-ag/DistChildAttr.ag" #-} Map.findWithDefault Map.empty _chnt _lhsIinhMap {-# LINE 115 "dist/build/ResolveLocals.hs"#-} {-# INLINE rule2 #-} {-# LINE 24 "./src-ag/DistChildAttr.ag" #-} rule2 = \ _chnt ((_lhsIsynMap) :: Map Identifier Attributes) -> {-# LINE 24 "./src-ag/DistChildAttr.ag" #-} Map.findWithDefault Map.empty _chnt _lhsIsynMap {-# LINE 121 "dist/build/ResolveLocals.hs"#-} {-# INLINE rule3 #-} {-# LINE 84 "./src-ag/ResolveLocals.ag" #-} rule3 = \ _inh _syn name_ -> {-# LINE 84 "./src-ag/ResolveLocals.ag" #-} [(name_, _inh , _syn )] {-# LINE 127 "dist/build/ResolveLocals.hs"#-} {-# INLINE rule4 #-} {-# LINE 87 "./src-ag/ResolveLocals.ag" #-} rule4 = \ kind_ name_ tp_ -> {-# LINE 87 "./src-ag/ResolveLocals.ag" #-} (name_, tp_, kind_) {-# LINE 133 "dist/build/ResolveLocals.hs"#-} {-# INLINE rule5 #-} rule5 = \ kind_ name_ tp_ -> Child name_ tp_ kind_ {-# INLINE rule6 #-} rule6 = \ _output -> _output -- Children ---------------------------------------------------- -- wrapper data Inh_Children = Inh_Children { allfields_Inh_Children :: ([(Identifier,Type,ChildKind)]), allnts_Inh_Children :: ([Identifier]), attrs_Inh_Children :: ([(Identifier,Identifier)]), con_Inh_Children :: (Identifier), inh_Inh_Children :: (Attributes), inhMap_Inh_Children :: (Map Identifier Attributes), mergeMap_Inh_Children :: (Map Identifier (Identifier,[Identifier])), nt_Inh_Children :: (Identifier), syn_Inh_Children :: (Attributes), synMap_Inh_Children :: (Map Identifier Attributes) } data Syn_Children = Syn_Children { attributes_Syn_Children :: ([(Identifier,Attributes,Attributes)]), fields_Syn_Children :: ([(Identifier,Type,ChildKind)]), output_Syn_Children :: (Children) } {-# INLINABLE wrap_Children #-} wrap_Children :: T_Children -> Inh_Children -> (Syn_Children ) wrap_Children (T_Children act) (Inh_Children _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIsyn _lhsIsynMap) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Children_vIn4 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIsyn _lhsIsynMap (T_Children_vOut4 _lhsOattributes _lhsOfields _lhsOoutput) <- return (inv_Children_s5 sem arg) return (Syn_Children _lhsOattributes _lhsOfields _lhsOoutput) ) -- cata {-# NOINLINE sem_Children #-} sem_Children :: Children -> T_Children sem_Children list = Prelude.foldr sem_Children_Cons sem_Children_Nil (Prelude.map sem_Child list) -- semantic domain newtype T_Children = T_Children { attach_T_Children :: Identity (T_Children_s5 ) } newtype T_Children_s5 = C_Children_s5 { inv_Children_s5 :: (T_Children_v4 ) } data T_Children_s6 = C_Children_s6 type T_Children_v4 = (T_Children_vIn4 ) -> (T_Children_vOut4 ) data T_Children_vIn4 = T_Children_vIn4 ([(Identifier,Type,ChildKind)]) ([Identifier]) ([(Identifier,Identifier)]) (Identifier) (Attributes) (Map Identifier Attributes) (Map Identifier (Identifier,[Identifier])) (Identifier) (Attributes) (Map Identifier Attributes) data T_Children_vOut4 = T_Children_vOut4 ([(Identifier,Attributes,Attributes)]) ([(Identifier,Type,ChildKind)]) (Children) {-# NOINLINE sem_Children_Cons #-} sem_Children_Cons :: T_Child -> T_Children -> T_Children sem_Children_Cons arg_hd_ arg_tl_ = T_Children (return st5) where {-# NOINLINE st5 #-} st5 = let v4 :: T_Children_v4 v4 = \ (T_Children_vIn4 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIsyn _lhsIsynMap) -> ( let _hdX2 = Control.Monad.Identity.runIdentity (attach_T_Child (arg_hd_)) _tlX5 = Control.Monad.Identity.runIdentity (attach_T_Children (arg_tl_)) (T_Child_vOut1 _hdIattributes _hdIfield _hdIoutput) = inv_Child_s2 _hdX2 (T_Child_vIn1 _hdOallfields _hdOallnts _hdOattrs _hdOcon _hdOinh _hdOinhMap _hdOmergeMap _hdOnt _hdOsyn _hdOsynMap) (T_Children_vOut4 _tlIattributes _tlIfields _tlIoutput) = inv_Children_s5 _tlX5 (T_Children_vIn4 _tlOallfields _tlOallnts _tlOattrs _tlOcon _tlOinh _tlOinhMap _tlOmergeMap _tlOnt _tlOsyn _tlOsynMap) _lhsOfields :: [(Identifier,Type,ChildKind)] _lhsOfields = rule7 _hdIfield _tlIfields _lhsOattributes :: [(Identifier,Attributes,Attributes)] _lhsOattributes = rule8 _hdIattributes _tlIattributes _output = rule9 _hdIoutput _tlIoutput _lhsOoutput :: Children _lhsOoutput = rule10 _output _hdOallfields = rule11 _lhsIallfields _hdOallnts = rule12 _lhsIallnts _hdOattrs = rule13 _lhsIattrs _hdOcon = rule14 _lhsIcon _hdOinh = rule15 _lhsIinh _hdOinhMap = rule16 _lhsIinhMap _hdOmergeMap = rule17 _lhsImergeMap _hdOnt = rule18 _lhsInt _hdOsyn = rule19 _lhsIsyn _hdOsynMap = rule20 _lhsIsynMap _tlOallfields = rule21 _lhsIallfields _tlOallnts = rule22 _lhsIallnts _tlOattrs = rule23 _lhsIattrs _tlOcon = rule24 _lhsIcon _tlOinh = rule25 _lhsIinh _tlOinhMap = rule26 _lhsIinhMap _tlOmergeMap = rule27 _lhsImergeMap _tlOnt = rule28 _lhsInt _tlOsyn = rule29 _lhsIsyn _tlOsynMap = rule30 _lhsIsynMap __result_ = T_Children_vOut4 _lhsOattributes _lhsOfields _lhsOoutput in __result_ ) in C_Children_s5 v4 {-# INLINE rule7 #-} {-# LINE 90 "./src-ag/ResolveLocals.ag" #-} rule7 = \ ((_hdIfield) :: (Identifier,Type,ChildKind)) ((_tlIfields) :: [(Identifier,Type,ChildKind)]) -> {-# LINE 90 "./src-ag/ResolveLocals.ag" #-} _hdIfield : _tlIfields {-# LINE 217 "dist/build/ResolveLocals.hs"#-} {-# INLINE rule8 #-} rule8 = \ ((_hdIattributes) :: [(Identifier,Attributes,Attributes)]) ((_tlIattributes) :: [(Identifier,Attributes,Attributes)]) -> _hdIattributes ++ _tlIattributes {-# INLINE rule9 #-} rule9 = \ ((_hdIoutput) :: Child) ((_tlIoutput) :: Children) -> (:) _hdIoutput _tlIoutput {-# INLINE rule10 #-} rule10 = \ _output -> _output {-# INLINE rule11 #-} rule11 = \ ((_lhsIallfields) :: [(Identifier,Type,ChildKind)]) -> _lhsIallfields {-# INLINE rule12 #-} rule12 = \ ((_lhsIallnts) :: [Identifier]) -> _lhsIallnts {-# INLINE rule13 #-} rule13 = \ ((_lhsIattrs) :: [(Identifier,Identifier)]) -> _lhsIattrs {-# INLINE rule14 #-} rule14 = \ ((_lhsIcon) :: Identifier) -> _lhsIcon {-# INLINE rule15 #-} rule15 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule16 #-} rule16 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule17 #-} rule17 = \ ((_lhsImergeMap) :: Map Identifier (Identifier,[Identifier])) -> _lhsImergeMap {-# INLINE rule18 #-} rule18 = \ ((_lhsInt) :: Identifier) -> _lhsInt {-# INLINE rule19 #-} rule19 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# INLINE rule20 #-} rule20 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# INLINE rule21 #-} rule21 = \ ((_lhsIallfields) :: [(Identifier,Type,ChildKind)]) -> _lhsIallfields {-# INLINE rule22 #-} rule22 = \ ((_lhsIallnts) :: [Identifier]) -> _lhsIallnts {-# INLINE rule23 #-} rule23 = \ ((_lhsIattrs) :: [(Identifier,Identifier)]) -> _lhsIattrs {-# INLINE rule24 #-} rule24 = \ ((_lhsIcon) :: Identifier) -> _lhsIcon {-# INLINE rule25 #-} rule25 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule26 #-} rule26 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule27 #-} rule27 = \ ((_lhsImergeMap) :: Map Identifier (Identifier,[Identifier])) -> _lhsImergeMap {-# INLINE rule28 #-} rule28 = \ ((_lhsInt) :: Identifier) -> _lhsInt {-# INLINE rule29 #-} rule29 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# INLINE rule30 #-} rule30 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# NOINLINE sem_Children_Nil #-} sem_Children_Nil :: T_Children sem_Children_Nil = T_Children (return st5) where {-# NOINLINE st5 #-} st5 = let v4 :: T_Children_v4 v4 = \ (T_Children_vIn4 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIsyn _lhsIsynMap) -> ( let _lhsOfields :: [(Identifier,Type,ChildKind)] _lhsOfields = rule31 () _lhsOattributes :: [(Identifier,Attributes,Attributes)] _lhsOattributes = rule32 () _output = rule33 () _lhsOoutput :: Children _lhsOoutput = rule34 _output __result_ = T_Children_vOut4 _lhsOattributes _lhsOfields _lhsOoutput in __result_ ) in C_Children_s5 v4 {-# INLINE rule31 #-} {-# LINE 91 "./src-ag/ResolveLocals.ag" #-} rule31 = \ (_ :: ()) -> {-# LINE 91 "./src-ag/ResolveLocals.ag" #-} [] {-# LINE 309 "dist/build/ResolveLocals.hs"#-} {-# INLINE rule32 #-} rule32 = \ (_ :: ()) -> [] {-# INLINE rule33 #-} rule33 = \ (_ :: ()) -> [] {-# INLINE rule34 #-} rule34 = \ _output -> _output -- Expression -------------------------------------------------- -- wrapper data Inh_Expression = Inh_Expression { allfields_Inh_Expression :: ([(Identifier,Type,ChildKind)]), allnts_Inh_Expression :: ([Identifier]), attrs_Inh_Expression :: ([(Identifier,Identifier)]), con_Inh_Expression :: (Identifier), mergeMap_Inh_Expression :: (Map Identifier (Identifier,[Identifier])), nt_Inh_Expression :: (Identifier), options_Inh_Expression :: (Options) } data Syn_Expression = Syn_Expression { errors_Syn_Expression :: (Seq Error), output_Syn_Expression :: (Expression) } {-# INLINABLE wrap_Expression #-} wrap_Expression :: T_Expression -> Inh_Expression -> (Syn_Expression ) wrap_Expression (T_Expression act) (Inh_Expression _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsImergeMap _lhsInt _lhsIoptions) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Expression_vIn7 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsImergeMap _lhsInt _lhsIoptions (T_Expression_vOut7 _lhsOerrors _lhsOoutput) <- return (inv_Expression_s8 sem arg) return (Syn_Expression _lhsOerrors _lhsOoutput) ) -- cata {-# INLINE sem_Expression #-} sem_Expression :: Expression -> T_Expression sem_Expression ( Expression pos_ tks_ ) = sem_Expression_Expression pos_ tks_ -- semantic domain newtype T_Expression = T_Expression { attach_T_Expression :: Identity (T_Expression_s8 ) } newtype T_Expression_s8 = C_Expression_s8 { inv_Expression_s8 :: (T_Expression_v7 ) } data T_Expression_s9 = C_Expression_s9 type T_Expression_v7 = (T_Expression_vIn7 ) -> (T_Expression_vOut7 ) data T_Expression_vIn7 = T_Expression_vIn7 ([(Identifier,Type,ChildKind)]) ([Identifier]) ([(Identifier,Identifier)]) (Identifier) (Map Identifier (Identifier,[Identifier])) (Identifier) (Options) data T_Expression_vOut7 = T_Expression_vOut7 (Seq Error) (Expression) {-# NOINLINE sem_Expression_Expression #-} sem_Expression_Expression :: (Pos) -> ([HsToken]) -> T_Expression sem_Expression_Expression arg_pos_ arg_tks_ = T_Expression (return st8) where {-# NOINLINE st8 #-} st8 = let v7 :: T_Expression_v7 v7 = \ (T_Expression_vIn7 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsImergeMap _lhsInt _lhsIoptions) -> ( let (_errors,_newTks) = rule35 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsImergeMap _lhsInt arg_tks_ _lhsOoutput :: Expression _lhsOoutput = rule36 _newTks arg_pos_ _lhsOerrors :: Seq Error _lhsOerrors = rule37 _errors _output = rule38 arg_pos_ arg_tks_ __result_ = T_Expression_vOut7 _lhsOerrors _lhsOoutput in __result_ ) in C_Expression_s8 v7 {-# INLINE rule35 #-} {-# LINE 146 "./src-ag/ResolveLocals.ag" #-} rule35 = \ ((_lhsIallfields) :: [(Identifier,Type,ChildKind)]) ((_lhsIallnts) :: [Identifier]) ((_lhsIattrs) :: [(Identifier,Identifier)]) ((_lhsIcon) :: Identifier) ((_lhsImergeMap) :: Map Identifier (Identifier,[Identifier])) ((_lhsInt) :: Identifier) tks_ -> {-# LINE 146 "./src-ag/ResolveLocals.ag" #-} let mergedChildren = [ x | (_,xs) <- Map.elems _lhsImergeMap, x <- xs ] attrsIn = filter (\(fld,_) -> not (fld `elem` mergedChildren)) _lhsIattrs inherited = Inh_HsTokensRoot { attrs_Inh_HsTokensRoot = attrsIn , con_Inh_HsTokensRoot = _lhsIcon , allfields_Inh_HsTokensRoot = _lhsIallfields , allnts_Inh_HsTokensRoot = _lhsIallnts , nt_Inh_HsTokensRoot = _lhsInt } synthesized = wrap_HsTokensRoot (sem_HsTokensRoot (HsTokensRoot tks_)) inherited in (errors_Syn_HsTokensRoot synthesized, output_Syn_HsTokensRoot synthesized) {-# LINE 381 "dist/build/ResolveLocals.hs"#-} {-# INLINE rule36 #-} {-# LINE 157 "./src-ag/ResolveLocals.ag" #-} rule36 = \ _newTks pos_ -> {-# LINE 157 "./src-ag/ResolveLocals.ag" #-} Expression pos_ _newTks {-# LINE 387 "dist/build/ResolveLocals.hs"#-} {-# INLINE rule37 #-} rule37 = \ _errors -> _errors {-# INLINE rule38 #-} rule38 = \ pos_ tks_ -> Expression pos_ tks_ -- Grammar ----------------------------------------------------- -- wrapper data Inh_Grammar = Inh_Grammar { options_Inh_Grammar :: (Options) } data Syn_Grammar = Syn_Grammar { errors_Syn_Grammar :: (Seq Error), output_Syn_Grammar :: (Grammar) } {-# INLINABLE wrap_Grammar #-} wrap_Grammar :: T_Grammar -> Inh_Grammar -> (Syn_Grammar ) wrap_Grammar (T_Grammar act) (Inh_Grammar _lhsIoptions) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Grammar_vIn10 _lhsIoptions (T_Grammar_vOut10 _lhsOerrors _lhsOoutput) <- return (inv_Grammar_s11 sem arg) return (Syn_Grammar _lhsOerrors _lhsOoutput) ) -- cata {-# INLINE sem_Grammar #-} sem_Grammar :: Grammar -> T_Grammar sem_Grammar ( Grammar typeSyns_ useMap_ derivings_ wrappers_ nonts_ pragmas_ manualAttrOrderMap_ paramMap_ contextMap_ quantMap_ uniqueMap_ augmentsMap_ aroundsMap_ mergeMap_ ) = sem_Grammar_Grammar typeSyns_ useMap_ derivings_ wrappers_ ( sem_Nonterminals nonts_ ) pragmas_ manualAttrOrderMap_ paramMap_ contextMap_ quantMap_ uniqueMap_ augmentsMap_ aroundsMap_ mergeMap_ -- semantic domain newtype T_Grammar = T_Grammar { attach_T_Grammar :: Identity (T_Grammar_s11 ) } newtype T_Grammar_s11 = C_Grammar_s11 { inv_Grammar_s11 :: (T_Grammar_v10 ) } data T_Grammar_s12 = C_Grammar_s12 type T_Grammar_v10 = (T_Grammar_vIn10 ) -> (T_Grammar_vOut10 ) data T_Grammar_vIn10 = T_Grammar_vIn10 (Options) data T_Grammar_vOut10 = T_Grammar_vOut10 (Seq Error) (Grammar) {-# NOINLINE sem_Grammar_Grammar #-} sem_Grammar_Grammar :: (TypeSyns) -> (UseMap) -> (Derivings) -> (Set NontermIdent) -> T_Nonterminals -> (PragmaMap) -> (AttrOrderMap) -> (ParamMap) -> (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)))) -> T_Grammar sem_Grammar_Grammar arg_typeSyns_ arg_useMap_ arg_derivings_ arg_wrappers_ arg_nonts_ arg_pragmas_ arg_manualAttrOrderMap_ arg_paramMap_ arg_contextMap_ arg_quantMap_ arg_uniqueMap_ arg_augmentsMap_ arg_aroundsMap_ arg_mergeMap_ = T_Grammar (return st11) where {-# NOINLINE st11 #-} st11 = let v10 :: T_Grammar_v10 v10 = \ (T_Grammar_vIn10 _lhsIoptions) -> ( let _nontsX17 = Control.Monad.Identity.runIdentity (attach_T_Nonterminals (arg_nonts_)) (T_Nonterminals_vOut16 _nontsIerrors _nontsIinhMap' _nontsInonts _nontsIoutput _nontsIsynMap') = inv_Nonterminals_s17 _nontsX17 (T_Nonterminals_vIn16 _nontsOallnts _nontsOinhMap _nontsOmergeMap _nontsOoptions _nontsOsynMap) _nontsOinhMap = rule39 _nontsIinhMap' _nontsOsynMap = rule40 _nontsIsynMap' _nontsOallnts = rule41 _nontsInonts _nontsOmergeMap = rule42 arg_mergeMap_ _lhsOerrors :: Seq Error _lhsOerrors = rule43 _nontsIerrors _output = rule44 _nontsIoutput arg_aroundsMap_ arg_augmentsMap_ arg_contextMap_ arg_derivings_ arg_manualAttrOrderMap_ arg_mergeMap_ arg_paramMap_ arg_pragmas_ arg_quantMap_ arg_typeSyns_ arg_uniqueMap_ arg_useMap_ arg_wrappers_ _lhsOoutput :: Grammar _lhsOoutput = rule45 _output _nontsOoptions = rule46 _lhsIoptions __result_ = T_Grammar_vOut10 _lhsOerrors _lhsOoutput in __result_ ) in C_Grammar_s11 v10 {-# INLINE rule39 #-} {-# LINE 15 "./src-ag/DistChildAttr.ag" #-} rule39 = \ ((_nontsIinhMap') :: Map Identifier Attributes) -> {-# LINE 15 "./src-ag/DistChildAttr.ag" #-} _nontsIinhMap' {-# LINE 452 "dist/build/ResolveLocals.hs"#-} {-# INLINE rule40 #-} {-# LINE 16 "./src-ag/DistChildAttr.ag" #-} rule40 = \ ((_nontsIsynMap') :: Map Identifier Attributes) -> {-# LINE 16 "./src-ag/DistChildAttr.ag" #-} _nontsIsynMap' {-# LINE 458 "dist/build/ResolveLocals.hs"#-} {-# INLINE rule41 #-} {-# LINE 60 "./src-ag/ResolveLocals.ag" #-} rule41 = \ ((_nontsInonts) :: [(NontermIdent,[ConstructorIdent])]) -> {-# LINE 60 "./src-ag/ResolveLocals.ag" #-} map fst (_nontsInonts) {-# LINE 464 "dist/build/ResolveLocals.hs"#-} {-# INLINE rule42 #-} {-# LINE 120 "./src-ag/ResolveLocals.ag" #-} rule42 = \ mergeMap_ -> {-# LINE 120 "./src-ag/ResolveLocals.ag" #-} Map.map (Map.map (Map.map (\(nt,srcs,_) -> (nt,srcs)))) mergeMap_ {-# LINE 470 "dist/build/ResolveLocals.hs"#-} {-# INLINE rule43 #-} rule43 = \ ((_nontsIerrors) :: Seq Error) -> _nontsIerrors {-# INLINE rule44 #-} rule44 = \ ((_nontsIoutput) :: Nonterminals) aroundsMap_ augmentsMap_ contextMap_ derivings_ manualAttrOrderMap_ mergeMap_ paramMap_ pragmas_ quantMap_ typeSyns_ uniqueMap_ useMap_ wrappers_ -> Grammar typeSyns_ useMap_ derivings_ wrappers_ _nontsIoutput pragmas_ manualAttrOrderMap_ paramMap_ contextMap_ quantMap_ uniqueMap_ augmentsMap_ aroundsMap_ mergeMap_ {-# INLINE rule45 #-} rule45 = \ _output -> _output {-# INLINE rule46 #-} rule46 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions -- Nonterminal ------------------------------------------------- -- wrapper data Inh_Nonterminal = Inh_Nonterminal { allnts_Inh_Nonterminal :: ([Identifier]), inhMap_Inh_Nonterminal :: (Map Identifier Attributes), mergeMap_Inh_Nonterminal :: (Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))), options_Inh_Nonterminal :: (Options), synMap_Inh_Nonterminal :: (Map Identifier Attributes) } data Syn_Nonterminal = Syn_Nonterminal { errors_Syn_Nonterminal :: (Seq Error), inhMap'_Syn_Nonterminal :: (Map Identifier Attributes), nonts_Syn_Nonterminal :: ([(NontermIdent,[ConstructorIdent])]), output_Syn_Nonterminal :: (Nonterminal), synMap'_Syn_Nonterminal :: (Map Identifier Attributes) } {-# INLINABLE wrap_Nonterminal #-} wrap_Nonterminal :: T_Nonterminal -> Inh_Nonterminal -> (Syn_Nonterminal ) wrap_Nonterminal (T_Nonterminal act) (Inh_Nonterminal _lhsIallnts _lhsIinhMap _lhsImergeMap _lhsIoptions _lhsIsynMap) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Nonterminal_vIn13 _lhsIallnts _lhsIinhMap _lhsImergeMap _lhsIoptions _lhsIsynMap (T_Nonterminal_vOut13 _lhsOerrors _lhsOinhMap' _lhsOnonts _lhsOoutput _lhsOsynMap') <- return (inv_Nonterminal_s14 sem arg) return (Syn_Nonterminal _lhsOerrors _lhsOinhMap' _lhsOnonts _lhsOoutput _lhsOsynMap') ) -- cata {-# INLINE sem_Nonterminal #-} sem_Nonterminal :: Nonterminal -> T_Nonterminal sem_Nonterminal ( Nonterminal nt_ params_ inh_ syn_ prods_ ) = sem_Nonterminal_Nonterminal nt_ params_ inh_ syn_ ( sem_Productions prods_ ) -- semantic domain newtype T_Nonterminal = T_Nonterminal { attach_T_Nonterminal :: Identity (T_Nonterminal_s14 ) } newtype T_Nonterminal_s14 = C_Nonterminal_s14 { inv_Nonterminal_s14 :: (T_Nonterminal_v13 ) } data T_Nonterminal_s15 = C_Nonterminal_s15 type T_Nonterminal_v13 = (T_Nonterminal_vIn13 ) -> (T_Nonterminal_vOut13 ) data T_Nonterminal_vIn13 = T_Nonterminal_vIn13 ([Identifier]) (Map Identifier Attributes) (Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))) (Options) (Map Identifier Attributes) data T_Nonterminal_vOut13 = T_Nonterminal_vOut13 (Seq Error) (Map Identifier Attributes) ([(NontermIdent,[ConstructorIdent])]) (Nonterminal) (Map Identifier Attributes) {-# NOINLINE sem_Nonterminal_Nonterminal #-} sem_Nonterminal_Nonterminal :: (NontermIdent) -> ([Identifier]) -> (Attributes) -> (Attributes) -> T_Productions -> T_Nonterminal sem_Nonterminal_Nonterminal arg_nt_ arg_params_ arg_inh_ arg_syn_ arg_prods_ = T_Nonterminal (return st14) where {-# NOINLINE st14 #-} st14 = let v13 :: T_Nonterminal_v13 v13 = \ (T_Nonterminal_vIn13 _lhsIallnts _lhsIinhMap _lhsImergeMap _lhsIoptions _lhsIsynMap) -> ( let _prodsX29 = Control.Monad.Identity.runIdentity (attach_T_Productions (arg_prods_)) (T_Productions_vOut28 _prodsIcons _prodsIerrors _prodsIoutput) = inv_Productions_s29 _prodsX29 (T_Productions_vIn28 _prodsOallnts _prodsOinh _prodsOinhMap _prodsOmergeMap _prodsOnt _prodsOoptions _prodsOsyn _prodsOsynMap) _lhsOinhMap' :: Map Identifier Attributes _lhsOinhMap' = rule47 arg_inh_ arg_nt_ _lhsOsynMap' :: Map Identifier Attributes _lhsOsynMap' = rule48 arg_nt_ arg_syn_ _lhsOnonts :: [(NontermIdent,[ConstructorIdent])] _lhsOnonts = rule49 _prodsIcons arg_nt_ _prodsOnt = rule50 arg_nt_ _prodsOinh = rule51 arg_inh_ _prodsOsyn = rule52 arg_syn_ _mergeMap = rule53 _lhsImergeMap arg_nt_ _lhsOerrors :: Seq Error _lhsOerrors = rule54 _prodsIerrors _output = rule55 _prodsIoutput arg_inh_ arg_nt_ arg_params_ arg_syn_ _lhsOoutput :: Nonterminal _lhsOoutput = rule56 _output _prodsOallnts = rule57 _lhsIallnts _prodsOinhMap = rule58 _lhsIinhMap _prodsOmergeMap = rule59 _mergeMap _prodsOoptions = rule60 _lhsIoptions _prodsOsynMap = rule61 _lhsIsynMap __result_ = T_Nonterminal_vOut13 _lhsOerrors _lhsOinhMap' _lhsOnonts _lhsOoutput _lhsOsynMap' in __result_ ) in C_Nonterminal_s14 v13 {-# INLINE rule47 #-} {-# LINE 7 "./src-ag/DistChildAttr.ag" #-} rule47 = \ inh_ nt_ -> {-# LINE 7 "./src-ag/DistChildAttr.ag" #-} Map.singleton nt_ inh_ {-# LINE 551 "dist/build/ResolveLocals.hs"#-} {-# INLINE rule48 #-} {-# LINE 8 "./src-ag/DistChildAttr.ag" #-} rule48 = \ nt_ syn_ -> {-# LINE 8 "./src-ag/DistChildAttr.ag" #-} Map.singleton nt_ syn_ {-# LINE 557 "dist/build/ResolveLocals.hs"#-} {-# INLINE rule49 #-} {-# LINE 64 "./src-ag/ResolveLocals.ag" #-} rule49 = \ ((_prodsIcons) :: [ConstructorIdent]) nt_ -> {-# LINE 64 "./src-ag/ResolveLocals.ag" #-} [(nt_,_prodsIcons)] {-# LINE 563 "dist/build/ResolveLocals.hs"#-} {-# INLINE rule50 #-} {-# LINE 112 "./src-ag/ResolveLocals.ag" #-} rule50 = \ nt_ -> {-# LINE 112 "./src-ag/ResolveLocals.ag" #-} nt_ {-# LINE 569 "dist/build/ResolveLocals.hs"#-} {-# INLINE rule51 #-} {-# LINE 115 "./src-ag/ResolveLocals.ag" #-} rule51 = \ inh_ -> {-# LINE 115 "./src-ag/ResolveLocals.ag" #-} inh_ {-# LINE 575 "dist/build/ResolveLocals.hs"#-} {-# INLINE rule52 #-} {-# LINE 116 "./src-ag/ResolveLocals.ag" #-} rule52 = \ syn_ -> {-# LINE 116 "./src-ag/ResolveLocals.ag" #-} syn_ {-# LINE 581 "dist/build/ResolveLocals.hs"#-} {-# INLINE rule53 #-} {-# LINE 128 "./src-ag/ResolveLocals.ag" #-} rule53 = \ ((_lhsImergeMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))) nt_ -> {-# LINE 128 "./src-ag/ResolveLocals.ag" #-} Map.findWithDefault Map.empty nt_ _lhsImergeMap {-# LINE 587 "dist/build/ResolveLocals.hs"#-} {-# INLINE rule54 #-} rule54 = \ ((_prodsIerrors) :: Seq Error) -> _prodsIerrors {-# INLINE rule55 #-} rule55 = \ ((_prodsIoutput) :: Productions) inh_ nt_ params_ syn_ -> Nonterminal nt_ params_ inh_ syn_ _prodsIoutput {-# INLINE rule56 #-} rule56 = \ _output -> _output {-# INLINE rule57 #-} rule57 = \ ((_lhsIallnts) :: [Identifier]) -> _lhsIallnts {-# INLINE rule58 #-} rule58 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule59 #-} rule59 = \ _mergeMap -> _mergeMap {-# INLINE rule60 #-} rule60 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule61 #-} rule61 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap -- Nonterminals ------------------------------------------------ -- wrapper data Inh_Nonterminals = Inh_Nonterminals { allnts_Inh_Nonterminals :: ([Identifier]), inhMap_Inh_Nonterminals :: (Map Identifier Attributes), mergeMap_Inh_Nonterminals :: (Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))), options_Inh_Nonterminals :: (Options), synMap_Inh_Nonterminals :: (Map Identifier Attributes) } data Syn_Nonterminals = Syn_Nonterminals { errors_Syn_Nonterminals :: (Seq Error), inhMap'_Syn_Nonterminals :: (Map Identifier Attributes), nonts_Syn_Nonterminals :: ([(NontermIdent,[ConstructorIdent])]), output_Syn_Nonterminals :: (Nonterminals), synMap'_Syn_Nonterminals :: (Map Identifier Attributes) } {-# INLINABLE wrap_Nonterminals #-} wrap_Nonterminals :: T_Nonterminals -> Inh_Nonterminals -> (Syn_Nonterminals ) wrap_Nonterminals (T_Nonterminals act) (Inh_Nonterminals _lhsIallnts _lhsIinhMap _lhsImergeMap _lhsIoptions _lhsIsynMap) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Nonterminals_vIn16 _lhsIallnts _lhsIinhMap _lhsImergeMap _lhsIoptions _lhsIsynMap (T_Nonterminals_vOut16 _lhsOerrors _lhsOinhMap' _lhsOnonts _lhsOoutput _lhsOsynMap') <- return (inv_Nonterminals_s17 sem arg) return (Syn_Nonterminals _lhsOerrors _lhsOinhMap' _lhsOnonts _lhsOoutput _lhsOsynMap') ) -- cata {-# NOINLINE sem_Nonterminals #-} sem_Nonterminals :: Nonterminals -> T_Nonterminals sem_Nonterminals list = Prelude.foldr sem_Nonterminals_Cons sem_Nonterminals_Nil (Prelude.map sem_Nonterminal list) -- semantic domain newtype T_Nonterminals = T_Nonterminals { attach_T_Nonterminals :: Identity (T_Nonterminals_s17 ) } newtype T_Nonterminals_s17 = C_Nonterminals_s17 { inv_Nonterminals_s17 :: (T_Nonterminals_v16 ) } data T_Nonterminals_s18 = C_Nonterminals_s18 type T_Nonterminals_v16 = (T_Nonterminals_vIn16 ) -> (T_Nonterminals_vOut16 ) data T_Nonterminals_vIn16 = T_Nonterminals_vIn16 ([Identifier]) (Map Identifier Attributes) (Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))) (Options) (Map Identifier Attributes) data T_Nonterminals_vOut16 = T_Nonterminals_vOut16 (Seq Error) (Map Identifier Attributes) ([(NontermIdent,[ConstructorIdent])]) (Nonterminals) (Map Identifier Attributes) {-# NOINLINE sem_Nonterminals_Cons #-} sem_Nonterminals_Cons :: T_Nonterminal -> T_Nonterminals -> T_Nonterminals sem_Nonterminals_Cons arg_hd_ arg_tl_ = T_Nonterminals (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_Nonterminals_v16 v16 = \ (T_Nonterminals_vIn16 _lhsIallnts _lhsIinhMap _lhsImergeMap _lhsIoptions _lhsIsynMap) -> ( let _hdX14 = Control.Monad.Identity.runIdentity (attach_T_Nonterminal (arg_hd_)) _tlX17 = Control.Monad.Identity.runIdentity (attach_T_Nonterminals (arg_tl_)) (T_Nonterminal_vOut13 _hdIerrors _hdIinhMap' _hdInonts _hdIoutput _hdIsynMap') = inv_Nonterminal_s14 _hdX14 (T_Nonterminal_vIn13 _hdOallnts _hdOinhMap _hdOmergeMap _hdOoptions _hdOsynMap) (T_Nonterminals_vOut16 _tlIerrors _tlIinhMap' _tlInonts _tlIoutput _tlIsynMap') = inv_Nonterminals_s17 _tlX17 (T_Nonterminals_vIn16 _tlOallnts _tlOinhMap _tlOmergeMap _tlOoptions _tlOsynMap) _lhsOerrors :: Seq Error _lhsOerrors = rule62 _hdIerrors _tlIerrors _lhsOinhMap' :: Map Identifier Attributes _lhsOinhMap' = rule63 _hdIinhMap' _tlIinhMap' _lhsOnonts :: [(NontermIdent,[ConstructorIdent])] _lhsOnonts = rule64 _hdInonts _tlInonts _lhsOsynMap' :: Map Identifier Attributes _lhsOsynMap' = rule65 _hdIsynMap' _tlIsynMap' _output = rule66 _hdIoutput _tlIoutput _lhsOoutput :: Nonterminals _lhsOoutput = rule67 _output _hdOallnts = rule68 _lhsIallnts _hdOinhMap = rule69 _lhsIinhMap _hdOmergeMap = rule70 _lhsImergeMap _hdOoptions = rule71 _lhsIoptions _hdOsynMap = rule72 _lhsIsynMap _tlOallnts = rule73 _lhsIallnts _tlOinhMap = rule74 _lhsIinhMap _tlOmergeMap = rule75 _lhsImergeMap _tlOoptions = rule76 _lhsIoptions _tlOsynMap = rule77 _lhsIsynMap __result_ = T_Nonterminals_vOut16 _lhsOerrors _lhsOinhMap' _lhsOnonts _lhsOoutput _lhsOsynMap' in __result_ ) in C_Nonterminals_s17 v16 {-# INLINE rule62 #-} rule62 = \ ((_hdIerrors) :: Seq Error) ((_tlIerrors) :: Seq Error) -> _hdIerrors Seq.>< _tlIerrors {-# INLINE rule63 #-} rule63 = \ ((_hdIinhMap') :: Map Identifier Attributes) ((_tlIinhMap') :: Map Identifier Attributes) -> _hdIinhMap' `Map.union` _tlIinhMap' {-# INLINE rule64 #-} rule64 = \ ((_hdInonts) :: [(NontermIdent,[ConstructorIdent])]) ((_tlInonts) :: [(NontermIdent,[ConstructorIdent])]) -> _hdInonts ++ _tlInonts {-# INLINE rule65 #-} rule65 = \ ((_hdIsynMap') :: Map Identifier Attributes) ((_tlIsynMap') :: Map Identifier Attributes) -> _hdIsynMap' `Map.union` _tlIsynMap' {-# INLINE rule66 #-} rule66 = \ ((_hdIoutput) :: Nonterminal) ((_tlIoutput) :: Nonterminals) -> (:) _hdIoutput _tlIoutput {-# INLINE rule67 #-} rule67 = \ _output -> _output {-# INLINE rule68 #-} rule68 = \ ((_lhsIallnts) :: [Identifier]) -> _lhsIallnts {-# INLINE rule69 #-} rule69 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule70 #-} rule70 = \ ((_lhsImergeMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))) -> _lhsImergeMap {-# INLINE rule71 #-} rule71 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule72 #-} rule72 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# INLINE rule73 #-} rule73 = \ ((_lhsIallnts) :: [Identifier]) -> _lhsIallnts {-# INLINE rule74 #-} rule74 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule75 #-} rule75 = \ ((_lhsImergeMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))) -> _lhsImergeMap {-# INLINE rule76 #-} rule76 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule77 #-} rule77 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# NOINLINE sem_Nonterminals_Nil #-} sem_Nonterminals_Nil :: T_Nonterminals sem_Nonterminals_Nil = T_Nonterminals (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_Nonterminals_v16 v16 = \ (T_Nonterminals_vIn16 _lhsIallnts _lhsIinhMap _lhsImergeMap _lhsIoptions _lhsIsynMap) -> ( let _lhsOerrors :: Seq Error _lhsOerrors = rule78 () _lhsOinhMap' :: Map Identifier Attributes _lhsOinhMap' = rule79 () _lhsOnonts :: [(NontermIdent,[ConstructorIdent])] _lhsOnonts = rule80 () _lhsOsynMap' :: Map Identifier Attributes _lhsOsynMap' = rule81 () _output = rule82 () _lhsOoutput :: Nonterminals _lhsOoutput = rule83 _output __result_ = T_Nonterminals_vOut16 _lhsOerrors _lhsOinhMap' _lhsOnonts _lhsOoutput _lhsOsynMap' in __result_ ) in C_Nonterminals_s17 v16 {-# INLINE rule78 #-} rule78 = \ (_ :: ()) -> Seq.empty {-# INLINE rule79 #-} rule79 = \ (_ :: ()) -> Map.empty {-# INLINE rule80 #-} rule80 = \ (_ :: ()) -> [] {-# INLINE rule81 #-} rule81 = \ (_ :: ()) -> Map.empty {-# INLINE rule82 #-} rule82 = \ (_ :: ()) -> [] {-# INLINE rule83 #-} rule83 = \ _output -> _output -- Pattern ----------------------------------------------------- -- wrapper data Inh_Pattern = Inh_Pattern { con_Inh_Pattern :: (Identifier), inh_Inh_Pattern :: (Attributes), nt_Inh_Pattern :: (Identifier), syn_Inh_Pattern :: (Attributes) } data Syn_Pattern = Syn_Pattern { copy_Syn_Pattern :: (Pattern), errors_Syn_Pattern :: (Seq Error), instVars_Syn_Pattern :: ([Identifier]), locVars_Syn_Pattern :: ([Identifier]), output_Syn_Pattern :: (Pattern) } {-# INLINABLE wrap_Pattern #-} wrap_Pattern :: T_Pattern -> Inh_Pattern -> (Syn_Pattern ) wrap_Pattern (T_Pattern act) (Inh_Pattern _lhsIcon _lhsIinh _lhsInt _lhsIsyn) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Pattern_vIn19 _lhsIcon _lhsIinh _lhsInt _lhsIsyn (T_Pattern_vOut19 _lhsOcopy _lhsOerrors _lhsOinstVars _lhsOlocVars _lhsOoutput) <- return (inv_Pattern_s20 sem arg) return (Syn_Pattern _lhsOcopy _lhsOerrors _lhsOinstVars _lhsOlocVars _lhsOoutput) ) -- cata {-# NOINLINE sem_Pattern #-} sem_Pattern :: Pattern -> T_Pattern sem_Pattern ( Constr name_ pats_ ) = sem_Pattern_Constr name_ ( sem_Patterns pats_ ) sem_Pattern ( Product pos_ pats_ ) = sem_Pattern_Product pos_ ( sem_Patterns pats_ ) sem_Pattern ( Alias field_ attr_ pat_ ) = sem_Pattern_Alias field_ attr_ ( sem_Pattern pat_ ) sem_Pattern ( Irrefutable pat_ ) = sem_Pattern_Irrefutable ( sem_Pattern pat_ ) sem_Pattern ( Underscore pos_ ) = sem_Pattern_Underscore pos_ -- semantic domain newtype T_Pattern = T_Pattern { attach_T_Pattern :: Identity (T_Pattern_s20 ) } newtype T_Pattern_s20 = C_Pattern_s20 { inv_Pattern_s20 :: (T_Pattern_v19 ) } data T_Pattern_s21 = C_Pattern_s21 type T_Pattern_v19 = (T_Pattern_vIn19 ) -> (T_Pattern_vOut19 ) data T_Pattern_vIn19 = T_Pattern_vIn19 (Identifier) (Attributes) (Identifier) (Attributes) data T_Pattern_vOut19 = T_Pattern_vOut19 (Pattern) (Seq Error) ([Identifier]) ([Identifier]) (Pattern) {-# NOINLINE sem_Pattern_Constr #-} sem_Pattern_Constr :: (ConstructorIdent) -> T_Patterns -> T_Pattern sem_Pattern_Constr arg_name_ arg_pats_ = T_Pattern (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_Pattern_v19 v19 = \ (T_Pattern_vIn19 _lhsIcon _lhsIinh _lhsInt _lhsIsyn) -> ( let _patsX23 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) (T_Patterns_vOut22 _patsIcopy _patsIerrors _patsIinstVars _patsIlocVars _patsIoutput) = inv_Patterns_s23 _patsX23 (T_Patterns_vIn22 _patsOcon _patsOinh _patsOnt _patsOsyn) _lhsOerrors :: Seq Error _lhsOerrors = rule84 _patsIerrors _lhsOinstVars :: [Identifier] _lhsOinstVars = rule85 _patsIinstVars _lhsOlocVars :: [Identifier] _lhsOlocVars = rule86 _patsIlocVars _copy = rule87 _patsIcopy arg_name_ _output = rule88 _patsIoutput arg_name_ _lhsOcopy :: Pattern _lhsOcopy = rule89 _copy _lhsOoutput :: Pattern _lhsOoutput = rule90 _output _patsOcon = rule91 _lhsIcon _patsOinh = rule92 _lhsIinh _patsOnt = rule93 _lhsInt _patsOsyn = rule94 _lhsIsyn __result_ = T_Pattern_vOut19 _lhsOcopy _lhsOerrors _lhsOinstVars _lhsOlocVars _lhsOoutput in __result_ ) in C_Pattern_s20 v19 {-# INLINE rule84 #-} rule84 = \ ((_patsIerrors) :: Seq Error) -> _patsIerrors {-# INLINE rule85 #-} rule85 = \ ((_patsIinstVars) :: [Identifier]) -> _patsIinstVars {-# INLINE rule86 #-} rule86 = \ ((_patsIlocVars) :: [Identifier]) -> _patsIlocVars {-# INLINE rule87 #-} rule87 = \ ((_patsIcopy) :: Patterns) name_ -> Constr name_ _patsIcopy {-# INLINE rule88 #-} rule88 = \ ((_patsIoutput) :: Patterns) name_ -> Constr name_ _patsIoutput {-# INLINE rule89 #-} rule89 = \ _copy -> _copy {-# INLINE rule90 #-} rule90 = \ _output -> _output {-# INLINE rule91 #-} rule91 = \ ((_lhsIcon) :: Identifier) -> _lhsIcon {-# INLINE rule92 #-} rule92 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule93 #-} rule93 = \ ((_lhsInt) :: Identifier) -> _lhsInt {-# INLINE rule94 #-} rule94 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# NOINLINE sem_Pattern_Product #-} sem_Pattern_Product :: (Pos) -> T_Patterns -> T_Pattern sem_Pattern_Product arg_pos_ arg_pats_ = T_Pattern (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_Pattern_v19 v19 = \ (T_Pattern_vIn19 _lhsIcon _lhsIinh _lhsInt _lhsIsyn) -> ( let _patsX23 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) (T_Patterns_vOut22 _patsIcopy _patsIerrors _patsIinstVars _patsIlocVars _patsIoutput) = inv_Patterns_s23 _patsX23 (T_Patterns_vIn22 _patsOcon _patsOinh _patsOnt _patsOsyn) _lhsOerrors :: Seq Error _lhsOerrors = rule95 _patsIerrors _lhsOinstVars :: [Identifier] _lhsOinstVars = rule96 _patsIinstVars _lhsOlocVars :: [Identifier] _lhsOlocVars = rule97 _patsIlocVars _copy = rule98 _patsIcopy arg_pos_ _output = rule99 _patsIoutput arg_pos_ _lhsOcopy :: Pattern _lhsOcopy = rule100 _copy _lhsOoutput :: Pattern _lhsOoutput = rule101 _output _patsOcon = rule102 _lhsIcon _patsOinh = rule103 _lhsIinh _patsOnt = rule104 _lhsInt _patsOsyn = rule105 _lhsIsyn __result_ = T_Pattern_vOut19 _lhsOcopy _lhsOerrors _lhsOinstVars _lhsOlocVars _lhsOoutput in __result_ ) in C_Pattern_s20 v19 {-# INLINE rule95 #-} rule95 = \ ((_patsIerrors) :: Seq Error) -> _patsIerrors {-# INLINE rule96 #-} rule96 = \ ((_patsIinstVars) :: [Identifier]) -> _patsIinstVars {-# INLINE rule97 #-} rule97 = \ ((_patsIlocVars) :: [Identifier]) -> _patsIlocVars {-# INLINE rule98 #-} rule98 = \ ((_patsIcopy) :: Patterns) pos_ -> Product pos_ _patsIcopy {-# INLINE rule99 #-} rule99 = \ ((_patsIoutput) :: Patterns) pos_ -> Product pos_ _patsIoutput {-# INLINE rule100 #-} rule100 = \ _copy -> _copy {-# INLINE rule101 #-} rule101 = \ _output -> _output {-# INLINE rule102 #-} rule102 = \ ((_lhsIcon) :: Identifier) -> _lhsIcon {-# INLINE rule103 #-} rule103 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule104 #-} rule104 = \ ((_lhsInt) :: Identifier) -> _lhsInt {-# INLINE rule105 #-} rule105 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# NOINLINE sem_Pattern_Alias #-} sem_Pattern_Alias :: (Identifier) -> (Identifier) -> T_Pattern -> T_Pattern sem_Pattern_Alias arg_field_ arg_attr_ arg_pat_ = T_Pattern (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_Pattern_v19 v19 = \ (T_Pattern_vIn19 _lhsIcon _lhsIinh _lhsInt _lhsIsyn) -> ( let _patX20 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) (T_Pattern_vOut19 _patIcopy _patIerrors _patIinstVars _patIlocVars _patIoutput) = inv_Pattern_s20 _patX20 (T_Pattern_vIn19 _patOcon _patOinh _patOnt _patOsyn) _lhsOlocVars :: [Identifier] _lhsOlocVars = rule106 arg_attr_ arg_field_ _lhsOinstVars :: [Identifier] _lhsOinstVars = rule107 arg_attr_ arg_field_ _lhsOerrors :: Seq Error _lhsOerrors = rule108 _patIerrors _copy = rule109 _patIcopy arg_attr_ arg_field_ _output = rule110 _patIoutput arg_attr_ arg_field_ _lhsOcopy :: Pattern _lhsOcopy = rule111 _copy _lhsOoutput :: Pattern _lhsOoutput = rule112 _output _patOcon = rule113 _lhsIcon _patOinh = rule114 _lhsIinh _patOnt = rule115 _lhsInt _patOsyn = rule116 _lhsIsyn __result_ = T_Pattern_vOut19 _lhsOcopy _lhsOerrors _lhsOinstVars _lhsOlocVars _lhsOoutput in __result_ ) in C_Pattern_s20 v19 {-# INLINE rule106 #-} {-# LINE 96 "./src-ag/ResolveLocals.ag" #-} rule106 = \ attr_ field_ -> {-# LINE 96 "./src-ag/ResolveLocals.ag" #-} if field_ == _LOC then [attr_] else [] {-# LINE 957 "dist/build/ResolveLocals.hs"#-} {-# INLINE rule107 #-} {-# LINE 99 "./src-ag/ResolveLocals.ag" #-} rule107 = \ attr_ field_ -> {-# LINE 99 "./src-ag/ResolveLocals.ag" #-} if field_ == _INST then [attr_] else [] {-# LINE 965 "dist/build/ResolveLocals.hs"#-} {-# INLINE rule108 #-} rule108 = \ ((_patIerrors) :: Seq Error) -> _patIerrors {-# INLINE rule109 #-} rule109 = \ ((_patIcopy) :: Pattern) attr_ field_ -> Alias field_ attr_ _patIcopy {-# INLINE rule110 #-} rule110 = \ ((_patIoutput) :: Pattern) attr_ field_ -> Alias field_ attr_ _patIoutput {-# INLINE rule111 #-} rule111 = \ _copy -> _copy {-# INLINE rule112 #-} rule112 = \ _output -> _output {-# INLINE rule113 #-} rule113 = \ ((_lhsIcon) :: Identifier) -> _lhsIcon {-# INLINE rule114 #-} rule114 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule115 #-} rule115 = \ ((_lhsInt) :: Identifier) -> _lhsInt {-# INLINE rule116 #-} rule116 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# NOINLINE sem_Pattern_Irrefutable #-} sem_Pattern_Irrefutable :: T_Pattern -> T_Pattern sem_Pattern_Irrefutable arg_pat_ = T_Pattern (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_Pattern_v19 v19 = \ (T_Pattern_vIn19 _lhsIcon _lhsIinh _lhsInt _lhsIsyn) -> ( let _patX20 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) (T_Pattern_vOut19 _patIcopy _patIerrors _patIinstVars _patIlocVars _patIoutput) = inv_Pattern_s20 _patX20 (T_Pattern_vIn19 _patOcon _patOinh _patOnt _patOsyn) _lhsOerrors :: Seq Error _lhsOerrors = rule117 _patIerrors _lhsOinstVars :: [Identifier] _lhsOinstVars = rule118 _patIinstVars _lhsOlocVars :: [Identifier] _lhsOlocVars = rule119 _patIlocVars _copy = rule120 _patIcopy _output = rule121 _patIoutput _lhsOcopy :: Pattern _lhsOcopy = rule122 _copy _lhsOoutput :: Pattern _lhsOoutput = rule123 _output _patOcon = rule124 _lhsIcon _patOinh = rule125 _lhsIinh _patOnt = rule126 _lhsInt _patOsyn = rule127 _lhsIsyn __result_ = T_Pattern_vOut19 _lhsOcopy _lhsOerrors _lhsOinstVars _lhsOlocVars _lhsOoutput in __result_ ) in C_Pattern_s20 v19 {-# INLINE rule117 #-} rule117 = \ ((_patIerrors) :: Seq Error) -> _patIerrors {-# INLINE rule118 #-} rule118 = \ ((_patIinstVars) :: [Identifier]) -> _patIinstVars {-# INLINE rule119 #-} rule119 = \ ((_patIlocVars) :: [Identifier]) -> _patIlocVars {-# INLINE rule120 #-} rule120 = \ ((_patIcopy) :: Pattern) -> Irrefutable _patIcopy {-# INLINE rule121 #-} rule121 = \ ((_patIoutput) :: Pattern) -> Irrefutable _patIoutput {-# INLINE rule122 #-} rule122 = \ _copy -> _copy {-# INLINE rule123 #-} rule123 = \ _output -> _output {-# INLINE rule124 #-} rule124 = \ ((_lhsIcon) :: Identifier) -> _lhsIcon {-# INLINE rule125 #-} rule125 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule126 #-} rule126 = \ ((_lhsInt) :: Identifier) -> _lhsInt {-# INLINE rule127 #-} rule127 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# NOINLINE sem_Pattern_Underscore #-} sem_Pattern_Underscore :: (Pos) -> T_Pattern sem_Pattern_Underscore arg_pos_ = T_Pattern (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_Pattern_v19 v19 = \ (T_Pattern_vIn19 _lhsIcon _lhsIinh _lhsInt _lhsIsyn) -> ( let _lhsOerrors :: Seq Error _lhsOerrors = rule128 () _lhsOinstVars :: [Identifier] _lhsOinstVars = rule129 () _lhsOlocVars :: [Identifier] _lhsOlocVars = rule130 () _copy = rule131 arg_pos_ _output = rule132 arg_pos_ _lhsOcopy :: Pattern _lhsOcopy = rule133 _copy _lhsOoutput :: Pattern _lhsOoutput = rule134 _output __result_ = T_Pattern_vOut19 _lhsOcopy _lhsOerrors _lhsOinstVars _lhsOlocVars _lhsOoutput in __result_ ) in C_Pattern_s20 v19 {-# INLINE rule128 #-} rule128 = \ (_ :: ()) -> Seq.empty {-# INLINE rule129 #-} rule129 = \ (_ :: ()) -> [] {-# INLINE rule130 #-} rule130 = \ (_ :: ()) -> [] {-# INLINE rule131 #-} rule131 = \ pos_ -> Underscore pos_ {-# INLINE rule132 #-} rule132 = \ pos_ -> Underscore pos_ {-# INLINE rule133 #-} rule133 = \ _copy -> _copy {-# INLINE rule134 #-} rule134 = \ _output -> _output -- Patterns ---------------------------------------------------- -- wrapper data Inh_Patterns = Inh_Patterns { con_Inh_Patterns :: (Identifier), inh_Inh_Patterns :: (Attributes), nt_Inh_Patterns :: (Identifier), syn_Inh_Patterns :: (Attributes) } data Syn_Patterns = Syn_Patterns { copy_Syn_Patterns :: (Patterns), errors_Syn_Patterns :: (Seq Error), instVars_Syn_Patterns :: ([Identifier]), locVars_Syn_Patterns :: ([Identifier]), output_Syn_Patterns :: (Patterns) } {-# INLINABLE wrap_Patterns #-} wrap_Patterns :: T_Patterns -> Inh_Patterns -> (Syn_Patterns ) wrap_Patterns (T_Patterns act) (Inh_Patterns _lhsIcon _lhsIinh _lhsInt _lhsIsyn) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Patterns_vIn22 _lhsIcon _lhsIinh _lhsInt _lhsIsyn (T_Patterns_vOut22 _lhsOcopy _lhsOerrors _lhsOinstVars _lhsOlocVars _lhsOoutput) <- return (inv_Patterns_s23 sem arg) return (Syn_Patterns _lhsOcopy _lhsOerrors _lhsOinstVars _lhsOlocVars _lhsOoutput) ) -- cata {-# NOINLINE sem_Patterns #-} sem_Patterns :: Patterns -> T_Patterns sem_Patterns list = Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list) -- semantic domain newtype T_Patterns = T_Patterns { attach_T_Patterns :: Identity (T_Patterns_s23 ) } newtype T_Patterns_s23 = C_Patterns_s23 { inv_Patterns_s23 :: (T_Patterns_v22 ) } data T_Patterns_s24 = C_Patterns_s24 type T_Patterns_v22 = (T_Patterns_vIn22 ) -> (T_Patterns_vOut22 ) data T_Patterns_vIn22 = T_Patterns_vIn22 (Identifier) (Attributes) (Identifier) (Attributes) data T_Patterns_vOut22 = T_Patterns_vOut22 (Patterns) (Seq Error) ([Identifier]) ([Identifier]) (Patterns) {-# NOINLINE sem_Patterns_Cons #-} sem_Patterns_Cons :: T_Pattern -> T_Patterns -> T_Patterns sem_Patterns_Cons arg_hd_ arg_tl_ = T_Patterns (return st23) where {-# NOINLINE st23 #-} st23 = let v22 :: T_Patterns_v22 v22 = \ (T_Patterns_vIn22 _lhsIcon _lhsIinh _lhsInt _lhsIsyn) -> ( let _hdX20 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_hd_)) _tlX23 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_tl_)) (T_Pattern_vOut19 _hdIcopy _hdIerrors _hdIinstVars _hdIlocVars _hdIoutput) = inv_Pattern_s20 _hdX20 (T_Pattern_vIn19 _hdOcon _hdOinh _hdOnt _hdOsyn) (T_Patterns_vOut22 _tlIcopy _tlIerrors _tlIinstVars _tlIlocVars _tlIoutput) = inv_Patterns_s23 _tlX23 (T_Patterns_vIn22 _tlOcon _tlOinh _tlOnt _tlOsyn) _lhsOerrors :: Seq Error _lhsOerrors = rule135 _hdIerrors _tlIerrors _lhsOinstVars :: [Identifier] _lhsOinstVars = rule136 _hdIinstVars _tlIinstVars _lhsOlocVars :: [Identifier] _lhsOlocVars = rule137 _hdIlocVars _tlIlocVars _copy = rule138 _hdIcopy _tlIcopy _output = rule139 _hdIoutput _tlIoutput _lhsOcopy :: Patterns _lhsOcopy = rule140 _copy _lhsOoutput :: Patterns _lhsOoutput = rule141 _output _hdOcon = rule142 _lhsIcon _hdOinh = rule143 _lhsIinh _hdOnt = rule144 _lhsInt _hdOsyn = rule145 _lhsIsyn _tlOcon = rule146 _lhsIcon _tlOinh = rule147 _lhsIinh _tlOnt = rule148 _lhsInt _tlOsyn = rule149 _lhsIsyn __result_ = T_Patterns_vOut22 _lhsOcopy _lhsOerrors _lhsOinstVars _lhsOlocVars _lhsOoutput in __result_ ) in C_Patterns_s23 v22 {-# INLINE rule135 #-} rule135 = \ ((_hdIerrors) :: Seq Error) ((_tlIerrors) :: Seq Error) -> _hdIerrors Seq.>< _tlIerrors {-# INLINE rule136 #-} rule136 = \ ((_hdIinstVars) :: [Identifier]) ((_tlIinstVars) :: [Identifier]) -> _hdIinstVars ++ _tlIinstVars {-# INLINE rule137 #-} rule137 = \ ((_hdIlocVars) :: [Identifier]) ((_tlIlocVars) :: [Identifier]) -> _hdIlocVars ++ _tlIlocVars {-# INLINE rule138 #-} rule138 = \ ((_hdIcopy) :: Pattern) ((_tlIcopy) :: Patterns) -> (:) _hdIcopy _tlIcopy {-# INLINE rule139 #-} rule139 = \ ((_hdIoutput) :: Pattern) ((_tlIoutput) :: Patterns) -> (:) _hdIoutput _tlIoutput {-# INLINE rule140 #-} rule140 = \ _copy -> _copy {-# INLINE rule141 #-} rule141 = \ _output -> _output {-# INLINE rule142 #-} rule142 = \ ((_lhsIcon) :: Identifier) -> _lhsIcon {-# INLINE rule143 #-} rule143 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule144 #-} rule144 = \ ((_lhsInt) :: Identifier) -> _lhsInt {-# INLINE rule145 #-} rule145 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# INLINE rule146 #-} rule146 = \ ((_lhsIcon) :: Identifier) -> _lhsIcon {-# INLINE rule147 #-} rule147 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule148 #-} rule148 = \ ((_lhsInt) :: Identifier) -> _lhsInt {-# INLINE rule149 #-} rule149 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# NOINLINE sem_Patterns_Nil #-} sem_Patterns_Nil :: T_Patterns sem_Patterns_Nil = T_Patterns (return st23) where {-# NOINLINE st23 #-} st23 = let v22 :: T_Patterns_v22 v22 = \ (T_Patterns_vIn22 _lhsIcon _lhsIinh _lhsInt _lhsIsyn) -> ( let _lhsOerrors :: Seq Error _lhsOerrors = rule150 () _lhsOinstVars :: [Identifier] _lhsOinstVars = rule151 () _lhsOlocVars :: [Identifier] _lhsOlocVars = rule152 () _copy = rule153 () _output = rule154 () _lhsOcopy :: Patterns _lhsOcopy = rule155 _copy _lhsOoutput :: Patterns _lhsOoutput = rule156 _output __result_ = T_Patterns_vOut22 _lhsOcopy _lhsOerrors _lhsOinstVars _lhsOlocVars _lhsOoutput in __result_ ) in C_Patterns_s23 v22 {-# INLINE rule150 #-} rule150 = \ (_ :: ()) -> Seq.empty {-# INLINE rule151 #-} rule151 = \ (_ :: ()) -> [] {-# INLINE rule152 #-} rule152 = \ (_ :: ()) -> [] {-# INLINE rule153 #-} rule153 = \ (_ :: ()) -> [] {-# INLINE rule154 #-} rule154 = \ (_ :: ()) -> [] {-# INLINE rule155 #-} rule155 = \ _copy -> _copy {-# INLINE rule156 #-} rule156 = \ _output -> _output -- Production -------------------------------------------------- -- wrapper data Inh_Production = Inh_Production { allnts_Inh_Production :: ([Identifier]), inh_Inh_Production :: (Attributes), inhMap_Inh_Production :: (Map Identifier Attributes), mergeMap_Inh_Production :: (Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))), nt_Inh_Production :: (Identifier), options_Inh_Production :: (Options), syn_Inh_Production :: (Attributes), synMap_Inh_Production :: (Map Identifier Attributes) } data Syn_Production = Syn_Production { cons_Syn_Production :: ([ConstructorIdent]), errors_Syn_Production :: (Seq Error), output_Syn_Production :: (Production) } {-# INLINABLE wrap_Production #-} wrap_Production :: T_Production -> Inh_Production -> (Syn_Production ) wrap_Production (T_Production act) (Inh_Production _lhsIallnts _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIoptions _lhsIsyn _lhsIsynMap) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Production_vIn25 _lhsIallnts _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIoptions _lhsIsyn _lhsIsynMap (T_Production_vOut25 _lhsOcons _lhsOerrors _lhsOoutput) <- return (inv_Production_s26 sem arg) return (Syn_Production _lhsOcons _lhsOerrors _lhsOoutput) ) -- cata {-# INLINE sem_Production #-} sem_Production :: Production -> T_Production sem_Production ( Production con_ params_ constraints_ children_ rules_ typeSigs_ macro_ ) = sem_Production_Production con_ params_ constraints_ ( sem_Children children_ ) ( sem_Rules rules_ ) ( sem_TypeSigs typeSigs_ ) macro_ -- semantic domain newtype T_Production = T_Production { attach_T_Production :: Identity (T_Production_s26 ) } newtype T_Production_s26 = C_Production_s26 { inv_Production_s26 :: (T_Production_v25 ) } data T_Production_s27 = C_Production_s27 type T_Production_v25 = (T_Production_vIn25 ) -> (T_Production_vOut25 ) data T_Production_vIn25 = T_Production_vIn25 ([Identifier]) (Attributes) (Map Identifier Attributes) (Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))) (Identifier) (Options) (Attributes) (Map Identifier Attributes) data T_Production_vOut25 = T_Production_vOut25 ([ConstructorIdent]) (Seq Error) (Production) {-# NOINLINE sem_Production_Production #-} sem_Production_Production :: (ConstructorIdent) -> ([Identifier]) -> ([Type]) -> T_Children -> T_Rules -> T_TypeSigs -> (MaybeMacro) -> T_Production sem_Production_Production arg_con_ arg_params_ arg_constraints_ arg_children_ arg_rules_ arg_typeSigs_ arg_macro_ = T_Production (return st26) where {-# NOINLINE st26 #-} st26 = let v25 :: T_Production_v25 v25 = \ (T_Production_vIn25 _lhsIallnts _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIoptions _lhsIsyn _lhsIsynMap) -> ( let _childrenX5 = Control.Monad.Identity.runIdentity (attach_T_Children (arg_children_)) _rulesX35 = Control.Monad.Identity.runIdentity (attach_T_Rules (arg_rules_)) _typeSigsX41 = Control.Monad.Identity.runIdentity (attach_T_TypeSigs (arg_typeSigs_)) (T_Children_vOut4 _childrenIattributes _childrenIfields _childrenIoutput) = inv_Children_s5 _childrenX5 (T_Children_vIn4 _childrenOallfields _childrenOallnts _childrenOattrs _childrenOcon _childrenOinh _childrenOinhMap _childrenOmergeMap _childrenOnt _childrenOsyn _childrenOsynMap) (T_Rules_vOut34 _rulesIerrors _rulesIinstVars _rulesIlocVars _rulesIoutput) = inv_Rules_s35 _rulesX35 (T_Rules_vIn34 _rulesOallfields _rulesOallnts _rulesOattrs _rulesOcon _rulesOinh _rulesOmergeMap _rulesOnt _rulesOoptions _rulesOsyn) (T_TypeSigs_vOut40 _typeSigsIoutput) = inv_TypeSigs_s41 _typeSigsX41 (T_TypeSigs_vIn40 ) _lhsOcons :: [ConstructorIdent] _lhsOcons = rule157 arg_con_ _allfields = rule158 _childrenIfields _attrs = rule159 _childrenIattributes _inhnames _rulesIinstVars _rulesIlocVars _inhnames = rule160 _lhsIinh _synnames = rule161 _lhsIsyn _childrenOcon = rule162 arg_con_ _rulesOcon = rule163 arg_con_ _mergeMap = rule164 _lhsImergeMap arg_con_ _lhsOerrors :: Seq Error _lhsOerrors = rule165 _rulesIerrors _output = rule166 _childrenIoutput _rulesIoutput _typeSigsIoutput arg_con_ arg_constraints_ arg_macro_ arg_params_ _lhsOoutput :: Production _lhsOoutput = rule167 _output _childrenOallfields = rule168 _allfields _childrenOallnts = rule169 _lhsIallnts _childrenOattrs = rule170 _attrs _childrenOinh = rule171 _lhsIinh _childrenOinhMap = rule172 _lhsIinhMap _childrenOmergeMap = rule173 _mergeMap _childrenOnt = rule174 _lhsInt _childrenOsyn = rule175 _lhsIsyn _childrenOsynMap = rule176 _lhsIsynMap _rulesOallfields = rule177 _allfields _rulesOallnts = rule178 _lhsIallnts _rulesOattrs = rule179 _attrs _rulesOinh = rule180 _lhsIinh _rulesOmergeMap = rule181 _mergeMap _rulesOnt = rule182 _lhsInt _rulesOoptions = rule183 _lhsIoptions _rulesOsyn = rule184 _lhsIsyn __result_ = T_Production_vOut25 _lhsOcons _lhsOerrors _lhsOoutput in __result_ ) in C_Production_s26 v25 {-# INLINE rule157 #-} {-# LINE 67 "./src-ag/ResolveLocals.ag" #-} rule157 = \ con_ -> {-# LINE 67 "./src-ag/ResolveLocals.ag" #-} [con_] {-# LINE 1333 "dist/build/ResolveLocals.hs"#-} {-# INLINE rule158 #-} {-# LINE 74 "./src-ag/ResolveLocals.ag" #-} rule158 = \ ((_childrenIfields) :: [(Identifier,Type,ChildKind)]) -> {-# LINE 74 "./src-ag/ResolveLocals.ag" #-} _childrenIfields {-# LINE 1339 "dist/build/ResolveLocals.hs"#-} {-# INLINE rule159 #-} {-# LINE 75 "./src-ag/ResolveLocals.ag" #-} rule159 = \ ((_childrenIattributes) :: [(Identifier,Attributes,Attributes)]) _inhnames ((_rulesIinstVars) :: [Identifier]) ((_rulesIlocVars) :: [Identifier]) -> {-# LINE 75 "./src-ag/ResolveLocals.ag" #-} map ((,) _LOC) _rulesIlocVars ++ map ((,) _INST) _rulesIinstVars ++ map ((,) _LHS) _inhnames ++ concat [map ((,) nm) (Map.keys as) | (nm,_,as) <- _childrenIattributes] {-# LINE 1348 "dist/build/ResolveLocals.hs"#-} {-# INLINE rule160 #-} {-# LINE 79 "./src-ag/ResolveLocals.ag" #-} rule160 = \ ((_lhsIinh) :: Attributes) -> {-# LINE 79 "./src-ag/ResolveLocals.ag" #-} Map.keys _lhsIinh {-# LINE 1354 "dist/build/ResolveLocals.hs"#-} {-# INLINE rule161 #-} {-# LINE 80 "./src-ag/ResolveLocals.ag" #-} rule161 = \ ((_lhsIsyn) :: Attributes) -> {-# LINE 80 "./src-ag/ResolveLocals.ag" #-} Map.keys _lhsIsyn {-# LINE 1360 "dist/build/ResolveLocals.hs"#-} {-# INLINE rule162 #-} {-# LINE 108 "./src-ag/ResolveLocals.ag" #-} rule162 = \ con_ -> {-# LINE 108 "./src-ag/ResolveLocals.ag" #-} con_ {-# LINE 1366 "dist/build/ResolveLocals.hs"#-} {-# INLINE rule163 #-} {-# LINE 110 "./src-ag/ResolveLocals.ag" #-} rule163 = \ con_ -> {-# LINE 110 "./src-ag/ResolveLocals.ag" #-} con_ {-# LINE 1372 "dist/build/ResolveLocals.hs"#-} {-# INLINE rule164 #-} {-# LINE 129 "./src-ag/ResolveLocals.ag" #-} rule164 = \ ((_lhsImergeMap) :: Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))) con_ -> {-# LINE 129 "./src-ag/ResolveLocals.ag" #-} Map.findWithDefault Map.empty con_ _lhsImergeMap {-# LINE 1378 "dist/build/ResolveLocals.hs"#-} {-# INLINE rule165 #-} rule165 = \ ((_rulesIerrors) :: Seq Error) -> _rulesIerrors {-# INLINE rule166 #-} rule166 = \ ((_childrenIoutput) :: Children) ((_rulesIoutput) :: Rules) ((_typeSigsIoutput) :: TypeSigs) con_ constraints_ macro_ params_ -> Production con_ params_ constraints_ _childrenIoutput _rulesIoutput _typeSigsIoutput macro_ {-# INLINE rule167 #-} rule167 = \ _output -> _output {-# INLINE rule168 #-} rule168 = \ _allfields -> _allfields {-# INLINE rule169 #-} rule169 = \ ((_lhsIallnts) :: [Identifier]) -> _lhsIallnts {-# INLINE rule170 #-} rule170 = \ _attrs -> _attrs {-# INLINE rule171 #-} rule171 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule172 #-} rule172 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule173 #-} rule173 = \ _mergeMap -> _mergeMap {-# INLINE rule174 #-} rule174 = \ ((_lhsInt) :: Identifier) -> _lhsInt {-# INLINE rule175 #-} rule175 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# INLINE rule176 #-} rule176 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# INLINE rule177 #-} rule177 = \ _allfields -> _allfields {-# INLINE rule178 #-} rule178 = \ ((_lhsIallnts) :: [Identifier]) -> _lhsIallnts {-# INLINE rule179 #-} rule179 = \ _attrs -> _attrs {-# INLINE rule180 #-} rule180 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule181 #-} rule181 = \ _mergeMap -> _mergeMap {-# INLINE rule182 #-} rule182 = \ ((_lhsInt) :: Identifier) -> _lhsInt {-# INLINE rule183 #-} rule183 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule184 #-} rule184 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn -- Productions ------------------------------------------------- -- wrapper data Inh_Productions = Inh_Productions { allnts_Inh_Productions :: ([Identifier]), inh_Inh_Productions :: (Attributes), inhMap_Inh_Productions :: (Map Identifier Attributes), mergeMap_Inh_Productions :: (Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))), nt_Inh_Productions :: (Identifier), options_Inh_Productions :: (Options), syn_Inh_Productions :: (Attributes), synMap_Inh_Productions :: (Map Identifier Attributes) } data Syn_Productions = Syn_Productions { cons_Syn_Productions :: ([ConstructorIdent]), errors_Syn_Productions :: (Seq Error), output_Syn_Productions :: (Productions) } {-# INLINABLE wrap_Productions #-} wrap_Productions :: T_Productions -> Inh_Productions -> (Syn_Productions ) wrap_Productions (T_Productions act) (Inh_Productions _lhsIallnts _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIoptions _lhsIsyn _lhsIsynMap) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Productions_vIn28 _lhsIallnts _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIoptions _lhsIsyn _lhsIsynMap (T_Productions_vOut28 _lhsOcons _lhsOerrors _lhsOoutput) <- return (inv_Productions_s29 sem arg) return (Syn_Productions _lhsOcons _lhsOerrors _lhsOoutput) ) -- cata {-# NOINLINE sem_Productions #-} sem_Productions :: Productions -> T_Productions sem_Productions list = Prelude.foldr sem_Productions_Cons sem_Productions_Nil (Prelude.map sem_Production list) -- semantic domain newtype T_Productions = T_Productions { attach_T_Productions :: Identity (T_Productions_s29 ) } newtype T_Productions_s29 = C_Productions_s29 { inv_Productions_s29 :: (T_Productions_v28 ) } data T_Productions_s30 = C_Productions_s30 type T_Productions_v28 = (T_Productions_vIn28 ) -> (T_Productions_vOut28 ) data T_Productions_vIn28 = T_Productions_vIn28 ([Identifier]) (Attributes) (Map Identifier Attributes) (Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))) (Identifier) (Options) (Attributes) (Map Identifier Attributes) data T_Productions_vOut28 = T_Productions_vOut28 ([ConstructorIdent]) (Seq Error) (Productions) {-# NOINLINE sem_Productions_Cons #-} sem_Productions_Cons :: T_Production -> T_Productions -> T_Productions sem_Productions_Cons arg_hd_ arg_tl_ = T_Productions (return st29) where {-# NOINLINE st29 #-} st29 = let v28 :: T_Productions_v28 v28 = \ (T_Productions_vIn28 _lhsIallnts _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIoptions _lhsIsyn _lhsIsynMap) -> ( let _hdX26 = Control.Monad.Identity.runIdentity (attach_T_Production (arg_hd_)) _tlX29 = Control.Monad.Identity.runIdentity (attach_T_Productions (arg_tl_)) (T_Production_vOut25 _hdIcons _hdIerrors _hdIoutput) = inv_Production_s26 _hdX26 (T_Production_vIn25 _hdOallnts _hdOinh _hdOinhMap _hdOmergeMap _hdOnt _hdOoptions _hdOsyn _hdOsynMap) (T_Productions_vOut28 _tlIcons _tlIerrors _tlIoutput) = inv_Productions_s29 _tlX29 (T_Productions_vIn28 _tlOallnts _tlOinh _tlOinhMap _tlOmergeMap _tlOnt _tlOoptions _tlOsyn _tlOsynMap) _lhsOcons :: [ConstructorIdent] _lhsOcons = rule185 _hdIcons _tlIcons _lhsOerrors :: Seq Error _lhsOerrors = rule186 _hdIerrors _tlIerrors _output = rule187 _hdIoutput _tlIoutput _lhsOoutput :: Productions _lhsOoutput = rule188 _output _hdOallnts = rule189 _lhsIallnts _hdOinh = rule190 _lhsIinh _hdOinhMap = rule191 _lhsIinhMap _hdOmergeMap = rule192 _lhsImergeMap _hdOnt = rule193 _lhsInt _hdOoptions = rule194 _lhsIoptions _hdOsyn = rule195 _lhsIsyn _hdOsynMap = rule196 _lhsIsynMap _tlOallnts = rule197 _lhsIallnts _tlOinh = rule198 _lhsIinh _tlOinhMap = rule199 _lhsIinhMap _tlOmergeMap = rule200 _lhsImergeMap _tlOnt = rule201 _lhsInt _tlOoptions = rule202 _lhsIoptions _tlOsyn = rule203 _lhsIsyn _tlOsynMap = rule204 _lhsIsynMap __result_ = T_Productions_vOut28 _lhsOcons _lhsOerrors _lhsOoutput in __result_ ) in C_Productions_s29 v28 {-# INLINE rule185 #-} rule185 = \ ((_hdIcons) :: [ConstructorIdent]) ((_tlIcons) :: [ConstructorIdent]) -> _hdIcons ++ _tlIcons {-# INLINE rule186 #-} rule186 = \ ((_hdIerrors) :: Seq Error) ((_tlIerrors) :: Seq Error) -> _hdIerrors Seq.>< _tlIerrors {-# INLINE rule187 #-} rule187 = \ ((_hdIoutput) :: Production) ((_tlIoutput) :: Productions) -> (:) _hdIoutput _tlIoutput {-# INLINE rule188 #-} rule188 = \ _output -> _output {-# INLINE rule189 #-} rule189 = \ ((_lhsIallnts) :: [Identifier]) -> _lhsIallnts {-# INLINE rule190 #-} rule190 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule191 #-} rule191 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule192 #-} rule192 = \ ((_lhsImergeMap) :: Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))) -> _lhsImergeMap {-# INLINE rule193 #-} rule193 = \ ((_lhsInt) :: Identifier) -> _lhsInt {-# INLINE rule194 #-} rule194 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule195 #-} rule195 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# INLINE rule196 #-} rule196 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# INLINE rule197 #-} rule197 = \ ((_lhsIallnts) :: [Identifier]) -> _lhsIallnts {-# INLINE rule198 #-} rule198 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule199 #-} rule199 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule200 #-} rule200 = \ ((_lhsImergeMap) :: Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))) -> _lhsImergeMap {-# INLINE rule201 #-} rule201 = \ ((_lhsInt) :: Identifier) -> _lhsInt {-# INLINE rule202 #-} rule202 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule203 #-} rule203 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# INLINE rule204 #-} rule204 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# NOINLINE sem_Productions_Nil #-} sem_Productions_Nil :: T_Productions sem_Productions_Nil = T_Productions (return st29) where {-# NOINLINE st29 #-} st29 = let v28 :: T_Productions_v28 v28 = \ (T_Productions_vIn28 _lhsIallnts _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIoptions _lhsIsyn _lhsIsynMap) -> ( let _lhsOcons :: [ConstructorIdent] _lhsOcons = rule205 () _lhsOerrors :: Seq Error _lhsOerrors = rule206 () _output = rule207 () _lhsOoutput :: Productions _lhsOoutput = rule208 _output __result_ = T_Productions_vOut28 _lhsOcons _lhsOerrors _lhsOoutput in __result_ ) in C_Productions_s29 v28 {-# INLINE rule205 #-} rule205 = \ (_ :: ()) -> [] {-# INLINE rule206 #-} rule206 = \ (_ :: ()) -> Seq.empty {-# INLINE rule207 #-} rule207 = \ (_ :: ()) -> [] {-# INLINE rule208 #-} rule208 = \ _output -> _output -- Rule -------------------------------------------------------- -- wrapper data Inh_Rule = Inh_Rule { allfields_Inh_Rule :: ([(Identifier,Type,ChildKind)]), allnts_Inh_Rule :: ([Identifier]), attrs_Inh_Rule :: ([(Identifier,Identifier)]), con_Inh_Rule :: (Identifier), inh_Inh_Rule :: (Attributes), mergeMap_Inh_Rule :: (Map Identifier (Identifier,[Identifier])), nt_Inh_Rule :: (Identifier), options_Inh_Rule :: (Options), syn_Inh_Rule :: (Attributes) } data Syn_Rule = Syn_Rule { errors_Syn_Rule :: (Seq Error), instVars_Syn_Rule :: ([Identifier]), locVars_Syn_Rule :: ([Identifier]), output_Syn_Rule :: (Rule) } {-# INLINABLE wrap_Rule #-} wrap_Rule :: T_Rule -> Inh_Rule -> (Syn_Rule ) wrap_Rule (T_Rule act) (Inh_Rule _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsImergeMap _lhsInt _lhsIoptions _lhsIsyn) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Rule_vIn31 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsImergeMap _lhsInt _lhsIoptions _lhsIsyn (T_Rule_vOut31 _lhsOerrors _lhsOinstVars _lhsOlocVars _lhsOoutput) <- return (inv_Rule_s32 sem arg) return (Syn_Rule _lhsOerrors _lhsOinstVars _lhsOlocVars _lhsOoutput) ) -- cata {-# INLINE sem_Rule #-} sem_Rule :: Rule -> T_Rule sem_Rule ( Rule mbName_ pattern_ rhs_ owrt_ origin_ explicit_ pure_ identity_ mbError_ eager_ ) = sem_Rule_Rule mbName_ ( sem_Pattern pattern_ ) ( sem_Expression rhs_ ) owrt_ origin_ explicit_ pure_ identity_ mbError_ eager_ -- semantic domain newtype T_Rule = T_Rule { attach_T_Rule :: Identity (T_Rule_s32 ) } newtype T_Rule_s32 = C_Rule_s32 { inv_Rule_s32 :: (T_Rule_v31 ) } data T_Rule_s33 = C_Rule_s33 type T_Rule_v31 = (T_Rule_vIn31 ) -> (T_Rule_vOut31 ) data T_Rule_vIn31 = T_Rule_vIn31 ([(Identifier,Type,ChildKind)]) ([Identifier]) ([(Identifier,Identifier)]) (Identifier) (Attributes) (Map Identifier (Identifier,[Identifier])) (Identifier) (Options) (Attributes) data T_Rule_vOut31 = T_Rule_vOut31 (Seq Error) ([Identifier]) ([Identifier]) (Rule) {-# NOINLINE sem_Rule_Rule #-} sem_Rule_Rule :: (Maybe Identifier) -> T_Pattern -> T_Expression -> (Bool) -> (String) -> (Bool) -> (Bool) -> (Bool) -> (Maybe Error) -> (Bool) -> T_Rule sem_Rule_Rule arg_mbName_ arg_pattern_ arg_rhs_ arg_owrt_ arg_origin_ arg_explicit_ arg_pure_ arg_identity_ arg_mbError_ arg_eager_ = T_Rule (return st32) where {-# NOINLINE st32 #-} st32 = let v31 :: T_Rule_v31 v31 = \ (T_Rule_vIn31 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsImergeMap _lhsInt _lhsIoptions _lhsIsyn) -> ( let _patternX20 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pattern_)) _rhsX8 = Control.Monad.Identity.runIdentity (attach_T_Expression (arg_rhs_)) (T_Pattern_vOut19 _patternIcopy _patternIerrors _patternIinstVars _patternIlocVars _patternIoutput) = inv_Pattern_s20 _patternX20 (T_Pattern_vIn19 _patternOcon _patternOinh _patternOnt _patternOsyn) (T_Expression_vOut7 _rhsIerrors _rhsIoutput) = inv_Expression_s8 _rhsX8 (T_Expression_vIn7 _rhsOallfields _rhsOallnts _rhsOattrs _rhsOcon _rhsOmergeMap _rhsOnt _rhsOoptions) _lhsOerrors :: Seq Error _lhsOerrors = rule209 _patternIerrors _rhsIerrors _lhsOinstVars :: [Identifier] _lhsOinstVars = rule210 _patternIinstVars _lhsOlocVars :: [Identifier] _lhsOlocVars = rule211 _patternIlocVars _output = rule212 _patternIoutput _rhsIoutput arg_eager_ arg_explicit_ arg_identity_ arg_mbError_ arg_mbName_ arg_origin_ arg_owrt_ arg_pure_ _lhsOoutput :: Rule _lhsOoutput = rule213 _output _patternOcon = rule214 _lhsIcon _patternOinh = rule215 _lhsIinh _patternOnt = rule216 _lhsInt _patternOsyn = rule217 _lhsIsyn _rhsOallfields = rule218 _lhsIallfields _rhsOallnts = rule219 _lhsIallnts _rhsOattrs = rule220 _lhsIattrs _rhsOcon = rule221 _lhsIcon _rhsOmergeMap = rule222 _lhsImergeMap _rhsOnt = rule223 _lhsInt _rhsOoptions = rule224 _lhsIoptions __result_ = T_Rule_vOut31 _lhsOerrors _lhsOinstVars _lhsOlocVars _lhsOoutput in __result_ ) in C_Rule_s32 v31 {-# INLINE rule209 #-} rule209 = \ ((_patternIerrors) :: Seq Error) ((_rhsIerrors) :: Seq Error) -> _patternIerrors Seq.>< _rhsIerrors {-# INLINE rule210 #-} rule210 = \ ((_patternIinstVars) :: [Identifier]) -> _patternIinstVars {-# INLINE rule211 #-} rule211 = \ ((_patternIlocVars) :: [Identifier]) -> _patternIlocVars {-# INLINE rule212 #-} rule212 = \ ((_patternIoutput) :: Pattern) ((_rhsIoutput) :: Expression) eager_ explicit_ identity_ mbError_ mbName_ origin_ owrt_ pure_ -> Rule mbName_ _patternIoutput _rhsIoutput owrt_ origin_ explicit_ pure_ identity_ mbError_ eager_ {-# INLINE rule213 #-} rule213 = \ _output -> _output {-# INLINE rule214 #-} rule214 = \ ((_lhsIcon) :: Identifier) -> _lhsIcon {-# INLINE rule215 #-} rule215 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule216 #-} rule216 = \ ((_lhsInt) :: Identifier) -> _lhsInt {-# INLINE rule217 #-} rule217 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# INLINE rule218 #-} rule218 = \ ((_lhsIallfields) :: [(Identifier,Type,ChildKind)]) -> _lhsIallfields {-# INLINE rule219 #-} rule219 = \ ((_lhsIallnts) :: [Identifier]) -> _lhsIallnts {-# INLINE rule220 #-} rule220 = \ ((_lhsIattrs) :: [(Identifier,Identifier)]) -> _lhsIattrs {-# INLINE rule221 #-} rule221 = \ ((_lhsIcon) :: Identifier) -> _lhsIcon {-# INLINE rule222 #-} rule222 = \ ((_lhsImergeMap) :: Map Identifier (Identifier,[Identifier])) -> _lhsImergeMap {-# INLINE rule223 #-} rule223 = \ ((_lhsInt) :: Identifier) -> _lhsInt {-# INLINE rule224 #-} rule224 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions -- Rules ------------------------------------------------------- -- wrapper data Inh_Rules = Inh_Rules { allfields_Inh_Rules :: ([(Identifier,Type,ChildKind)]), allnts_Inh_Rules :: ([Identifier]), attrs_Inh_Rules :: ([(Identifier,Identifier)]), con_Inh_Rules :: (Identifier), inh_Inh_Rules :: (Attributes), mergeMap_Inh_Rules :: (Map Identifier (Identifier,[Identifier])), nt_Inh_Rules :: (Identifier), options_Inh_Rules :: (Options), syn_Inh_Rules :: (Attributes) } data Syn_Rules = Syn_Rules { errors_Syn_Rules :: (Seq Error), instVars_Syn_Rules :: ([Identifier]), locVars_Syn_Rules :: ([Identifier]), output_Syn_Rules :: (Rules) } {-# INLINABLE wrap_Rules #-} wrap_Rules :: T_Rules -> Inh_Rules -> (Syn_Rules ) wrap_Rules (T_Rules act) (Inh_Rules _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsImergeMap _lhsInt _lhsIoptions _lhsIsyn) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Rules_vIn34 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsImergeMap _lhsInt _lhsIoptions _lhsIsyn (T_Rules_vOut34 _lhsOerrors _lhsOinstVars _lhsOlocVars _lhsOoutput) <- return (inv_Rules_s35 sem arg) return (Syn_Rules _lhsOerrors _lhsOinstVars _lhsOlocVars _lhsOoutput) ) -- cata {-# NOINLINE sem_Rules #-} sem_Rules :: Rules -> T_Rules sem_Rules list = Prelude.foldr sem_Rules_Cons sem_Rules_Nil (Prelude.map sem_Rule list) -- semantic domain newtype T_Rules = T_Rules { attach_T_Rules :: Identity (T_Rules_s35 ) } newtype T_Rules_s35 = C_Rules_s35 { inv_Rules_s35 :: (T_Rules_v34 ) } data T_Rules_s36 = C_Rules_s36 type T_Rules_v34 = (T_Rules_vIn34 ) -> (T_Rules_vOut34 ) data T_Rules_vIn34 = T_Rules_vIn34 ([(Identifier,Type,ChildKind)]) ([Identifier]) ([(Identifier,Identifier)]) (Identifier) (Attributes) (Map Identifier (Identifier,[Identifier])) (Identifier) (Options) (Attributes) data T_Rules_vOut34 = T_Rules_vOut34 (Seq Error) ([Identifier]) ([Identifier]) (Rules) {-# NOINLINE sem_Rules_Cons #-} sem_Rules_Cons :: T_Rule -> T_Rules -> T_Rules sem_Rules_Cons arg_hd_ arg_tl_ = T_Rules (return st35) where {-# NOINLINE st35 #-} st35 = let v34 :: T_Rules_v34 v34 = \ (T_Rules_vIn34 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsImergeMap _lhsInt _lhsIoptions _lhsIsyn) -> ( let _hdX32 = Control.Monad.Identity.runIdentity (attach_T_Rule (arg_hd_)) _tlX35 = Control.Monad.Identity.runIdentity (attach_T_Rules (arg_tl_)) (T_Rule_vOut31 _hdIerrors _hdIinstVars _hdIlocVars _hdIoutput) = inv_Rule_s32 _hdX32 (T_Rule_vIn31 _hdOallfields _hdOallnts _hdOattrs _hdOcon _hdOinh _hdOmergeMap _hdOnt _hdOoptions _hdOsyn) (T_Rules_vOut34 _tlIerrors _tlIinstVars _tlIlocVars _tlIoutput) = inv_Rules_s35 _tlX35 (T_Rules_vIn34 _tlOallfields _tlOallnts _tlOattrs _tlOcon _tlOinh _tlOmergeMap _tlOnt _tlOoptions _tlOsyn) _lhsOerrors :: Seq Error _lhsOerrors = rule225 _hdIerrors _tlIerrors _lhsOinstVars :: [Identifier] _lhsOinstVars = rule226 _hdIinstVars _tlIinstVars _lhsOlocVars :: [Identifier] _lhsOlocVars = rule227 _hdIlocVars _tlIlocVars _output = rule228 _hdIoutput _tlIoutput _lhsOoutput :: Rules _lhsOoutput = rule229 _output _hdOallfields = rule230 _lhsIallfields _hdOallnts = rule231 _lhsIallnts _hdOattrs = rule232 _lhsIattrs _hdOcon = rule233 _lhsIcon _hdOinh = rule234 _lhsIinh _hdOmergeMap = rule235 _lhsImergeMap _hdOnt = rule236 _lhsInt _hdOoptions = rule237 _lhsIoptions _hdOsyn = rule238 _lhsIsyn _tlOallfields = rule239 _lhsIallfields _tlOallnts = rule240 _lhsIallnts _tlOattrs = rule241 _lhsIattrs _tlOcon = rule242 _lhsIcon _tlOinh = rule243 _lhsIinh _tlOmergeMap = rule244 _lhsImergeMap _tlOnt = rule245 _lhsInt _tlOoptions = rule246 _lhsIoptions _tlOsyn = rule247 _lhsIsyn __result_ = T_Rules_vOut34 _lhsOerrors _lhsOinstVars _lhsOlocVars _lhsOoutput in __result_ ) in C_Rules_s35 v34 {-# INLINE rule225 #-} rule225 = \ ((_hdIerrors) :: Seq Error) ((_tlIerrors) :: Seq Error) -> _hdIerrors Seq.>< _tlIerrors {-# INLINE rule226 #-} rule226 = \ ((_hdIinstVars) :: [Identifier]) ((_tlIinstVars) :: [Identifier]) -> _hdIinstVars ++ _tlIinstVars {-# INLINE rule227 #-} rule227 = \ ((_hdIlocVars) :: [Identifier]) ((_tlIlocVars) :: [Identifier]) -> _hdIlocVars ++ _tlIlocVars {-# INLINE rule228 #-} rule228 = \ ((_hdIoutput) :: Rule) ((_tlIoutput) :: Rules) -> (:) _hdIoutput _tlIoutput {-# INLINE rule229 #-} rule229 = \ _output -> _output {-# INLINE rule230 #-} rule230 = \ ((_lhsIallfields) :: [(Identifier,Type,ChildKind)]) -> _lhsIallfields {-# INLINE rule231 #-} rule231 = \ ((_lhsIallnts) :: [Identifier]) -> _lhsIallnts {-# INLINE rule232 #-} rule232 = \ ((_lhsIattrs) :: [(Identifier,Identifier)]) -> _lhsIattrs {-# INLINE rule233 #-} rule233 = \ ((_lhsIcon) :: Identifier) -> _lhsIcon {-# INLINE rule234 #-} rule234 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule235 #-} rule235 = \ ((_lhsImergeMap) :: Map Identifier (Identifier,[Identifier])) -> _lhsImergeMap {-# INLINE rule236 #-} rule236 = \ ((_lhsInt) :: Identifier) -> _lhsInt {-# INLINE rule237 #-} rule237 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule238 #-} rule238 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# INLINE rule239 #-} rule239 = \ ((_lhsIallfields) :: [(Identifier,Type,ChildKind)]) -> _lhsIallfields {-# INLINE rule240 #-} rule240 = \ ((_lhsIallnts) :: [Identifier]) -> _lhsIallnts {-# INLINE rule241 #-} rule241 = \ ((_lhsIattrs) :: [(Identifier,Identifier)]) -> _lhsIattrs {-# INLINE rule242 #-} rule242 = \ ((_lhsIcon) :: Identifier) -> _lhsIcon {-# INLINE rule243 #-} rule243 = \ ((_lhsIinh) :: Attributes) -> _lhsIinh {-# INLINE rule244 #-} rule244 = \ ((_lhsImergeMap) :: Map Identifier (Identifier,[Identifier])) -> _lhsImergeMap {-# INLINE rule245 #-} rule245 = \ ((_lhsInt) :: Identifier) -> _lhsInt {-# INLINE rule246 #-} rule246 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule247 #-} rule247 = \ ((_lhsIsyn) :: Attributes) -> _lhsIsyn {-# NOINLINE sem_Rules_Nil #-} sem_Rules_Nil :: T_Rules sem_Rules_Nil = T_Rules (return st35) where {-# NOINLINE st35 #-} st35 = let v34 :: T_Rules_v34 v34 = \ (T_Rules_vIn34 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsImergeMap _lhsInt _lhsIoptions _lhsIsyn) -> ( let _lhsOerrors :: Seq Error _lhsOerrors = rule248 () _lhsOinstVars :: [Identifier] _lhsOinstVars = rule249 () _lhsOlocVars :: [Identifier] _lhsOlocVars = rule250 () _output = rule251 () _lhsOoutput :: Rules _lhsOoutput = rule252 _output __result_ = T_Rules_vOut34 _lhsOerrors _lhsOinstVars _lhsOlocVars _lhsOoutput in __result_ ) in C_Rules_s35 v34 {-# INLINE rule248 #-} rule248 = \ (_ :: ()) -> Seq.empty {-# INLINE rule249 #-} rule249 = \ (_ :: ()) -> [] {-# INLINE rule250 #-} rule250 = \ (_ :: ()) -> [] {-# INLINE rule251 #-} rule251 = \ (_ :: ()) -> [] {-# INLINE rule252 #-} rule252 = \ _output -> _output -- TypeSig ----------------------------------------------------- -- wrapper data Inh_TypeSig = Inh_TypeSig { } data Syn_TypeSig = Syn_TypeSig { output_Syn_TypeSig :: (TypeSig) } {-# INLINABLE wrap_TypeSig #-} wrap_TypeSig :: T_TypeSig -> Inh_TypeSig -> (Syn_TypeSig ) wrap_TypeSig (T_TypeSig act) (Inh_TypeSig ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_TypeSig_vIn37 (T_TypeSig_vOut37 _lhsOoutput) <- return (inv_TypeSig_s38 sem arg) return (Syn_TypeSig _lhsOoutput) ) -- cata {-# INLINE sem_TypeSig #-} sem_TypeSig :: TypeSig -> T_TypeSig sem_TypeSig ( TypeSig name_ tp_ ) = sem_TypeSig_TypeSig name_ tp_ -- semantic domain newtype T_TypeSig = T_TypeSig { attach_T_TypeSig :: Identity (T_TypeSig_s38 ) } newtype T_TypeSig_s38 = C_TypeSig_s38 { inv_TypeSig_s38 :: (T_TypeSig_v37 ) } data T_TypeSig_s39 = C_TypeSig_s39 type T_TypeSig_v37 = (T_TypeSig_vIn37 ) -> (T_TypeSig_vOut37 ) data T_TypeSig_vIn37 = T_TypeSig_vIn37 data T_TypeSig_vOut37 = T_TypeSig_vOut37 (TypeSig) {-# NOINLINE sem_TypeSig_TypeSig #-} sem_TypeSig_TypeSig :: (Identifier) -> (Type) -> T_TypeSig sem_TypeSig_TypeSig arg_name_ arg_tp_ = T_TypeSig (return st38) where {-# NOINLINE st38 #-} st38 = let v37 :: T_TypeSig_v37 v37 = \ (T_TypeSig_vIn37 ) -> ( let _output = rule253 arg_name_ arg_tp_ _lhsOoutput :: TypeSig _lhsOoutput = rule254 _output __result_ = T_TypeSig_vOut37 _lhsOoutput in __result_ ) in C_TypeSig_s38 v37 {-# INLINE rule253 #-} rule253 = \ name_ tp_ -> TypeSig name_ tp_ {-# INLINE rule254 #-} rule254 = \ _output -> _output -- TypeSigs ---------------------------------------------------- -- wrapper data Inh_TypeSigs = Inh_TypeSigs { } data Syn_TypeSigs = Syn_TypeSigs { output_Syn_TypeSigs :: (TypeSigs) } {-# INLINABLE wrap_TypeSigs #-} wrap_TypeSigs :: T_TypeSigs -> Inh_TypeSigs -> (Syn_TypeSigs ) wrap_TypeSigs (T_TypeSigs act) (Inh_TypeSigs ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_TypeSigs_vIn40 (T_TypeSigs_vOut40 _lhsOoutput) <- return (inv_TypeSigs_s41 sem arg) return (Syn_TypeSigs _lhsOoutput) ) -- cata {-# NOINLINE sem_TypeSigs #-} sem_TypeSigs :: TypeSigs -> T_TypeSigs sem_TypeSigs list = Prelude.foldr sem_TypeSigs_Cons sem_TypeSigs_Nil (Prelude.map sem_TypeSig list) -- semantic domain newtype T_TypeSigs = T_TypeSigs { attach_T_TypeSigs :: Identity (T_TypeSigs_s41 ) } newtype T_TypeSigs_s41 = C_TypeSigs_s41 { inv_TypeSigs_s41 :: (T_TypeSigs_v40 ) } data T_TypeSigs_s42 = C_TypeSigs_s42 type T_TypeSigs_v40 = (T_TypeSigs_vIn40 ) -> (T_TypeSigs_vOut40 ) data T_TypeSigs_vIn40 = T_TypeSigs_vIn40 data T_TypeSigs_vOut40 = T_TypeSigs_vOut40 (TypeSigs) {-# NOINLINE sem_TypeSigs_Cons #-} sem_TypeSigs_Cons :: T_TypeSig -> T_TypeSigs -> T_TypeSigs sem_TypeSigs_Cons arg_hd_ arg_tl_ = T_TypeSigs (return st41) where {-# NOINLINE st41 #-} st41 = let v40 :: T_TypeSigs_v40 v40 = \ (T_TypeSigs_vIn40 ) -> ( let _hdX38 = Control.Monad.Identity.runIdentity (attach_T_TypeSig (arg_hd_)) _tlX41 = Control.Monad.Identity.runIdentity (attach_T_TypeSigs (arg_tl_)) (T_TypeSig_vOut37 _hdIoutput) = inv_TypeSig_s38 _hdX38 (T_TypeSig_vIn37 ) (T_TypeSigs_vOut40 _tlIoutput) = inv_TypeSigs_s41 _tlX41 (T_TypeSigs_vIn40 ) _output = rule255 _hdIoutput _tlIoutput _lhsOoutput :: TypeSigs _lhsOoutput = rule256 _output __result_ = T_TypeSigs_vOut40 _lhsOoutput in __result_ ) in C_TypeSigs_s41 v40 {-# INLINE rule255 #-} rule255 = \ ((_hdIoutput) :: TypeSig) ((_tlIoutput) :: TypeSigs) -> (:) _hdIoutput _tlIoutput {-# INLINE rule256 #-} rule256 = \ _output -> _output {-# NOINLINE sem_TypeSigs_Nil #-} sem_TypeSigs_Nil :: T_TypeSigs sem_TypeSigs_Nil = T_TypeSigs (return st41) where {-# NOINLINE st41 #-} st41 = let v40 :: T_TypeSigs_v40 v40 = \ (T_TypeSigs_vIn40 ) -> ( let _output = rule257 () _lhsOoutput :: TypeSigs _lhsOoutput = rule258 _output __result_ = T_TypeSigs_vOut40 _lhsOoutput in __result_ ) in C_TypeSigs_s41 v40 {-# INLINE rule257 #-} rule257 = \ (_ :: ()) -> [] {-# INLINE rule258 #-} rule258 = \ _output -> _output uuagc-0.9.42.3/src-generated/SemHsTokens.hs000644 000765 000024 00000076117 12127045231 022344 0ustar00jeroenbransenstaff000000 000000 {-# LANGUAGE Rank2Types, GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} module SemHsTokens where {-# LINE 2 "./src-ag/HsToken.ag" #-} import CommonTypes import UU.Scanner.Position(Pos) {-# LINE 10 "dist/build/SemHsTokens.hs" #-} {-# LINE 4 "./src-ag/SemHsTokens.ag" #-} import qualified Data.Sequence as Seq import Data.Sequence(Seq,empty,singleton,(><)) import Data.Foldable(toList) import Pretty import TokenDef import HsToken import ErrorMessages {-# LINE 22 "dist/build/SemHsTokens.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 57 "./src-ag/SemHsTokens.ag" #-} isNTname allnts (Just (NT nt _ _)) = nt `elem` allnts isNTname allnts _ = False {-# LINE 29 "dist/build/SemHsTokens.hs" #-} -- HsToken ----------------------------------------------------- -- wrapper data Inh_HsToken = Inh_HsToken { allfields_Inh_HsToken :: ([(Identifier,Type,ChildKind)]), allnts_Inh_HsToken :: ([Identifier]), attrs_Inh_HsToken :: ([(Identifier,Identifier)]), con_Inh_HsToken :: (Identifier), fieldnames_Inh_HsToken :: ([Identifier]), nt_Inh_HsToken :: (Identifier) } data Syn_HsToken = Syn_HsToken { errors_Syn_HsToken :: (Seq Error), output_Syn_HsToken :: (HsToken), tok_Syn_HsToken :: ((Pos,String)), usedAttrs_Syn_HsToken :: ([(Identifier,Identifier)]), usedFields_Syn_HsToken :: (Seq Identifier), usedLocals_Syn_HsToken :: ([Identifier]) } {-# INLINABLE wrap_HsToken #-} wrap_HsToken :: T_HsToken -> Inh_HsToken -> (Syn_HsToken ) wrap_HsToken (T_HsToken act) (Inh_HsToken _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIfieldnames _lhsInt) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_HsToken_vIn1 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIfieldnames _lhsInt (T_HsToken_vOut1 _lhsOerrors _lhsOoutput _lhsOtok _lhsOusedAttrs _lhsOusedFields _lhsOusedLocals) <- return (inv_HsToken_s2 sem arg) return (Syn_HsToken _lhsOerrors _lhsOoutput _lhsOtok _lhsOusedAttrs _lhsOusedFields _lhsOusedLocals) ) -- cata {-# NOINLINE sem_HsToken #-} sem_HsToken :: HsToken -> T_HsToken sem_HsToken ( AGLocal var_ pos_ rdesc_ ) = sem_HsToken_AGLocal var_ pos_ rdesc_ sem_HsToken ( AGField field_ attr_ pos_ rdesc_ ) = sem_HsToken_AGField field_ attr_ pos_ rdesc_ sem_HsToken ( HsToken value_ pos_ ) = sem_HsToken_HsToken value_ pos_ sem_HsToken ( CharToken value_ pos_ ) = sem_HsToken_CharToken value_ pos_ sem_HsToken ( StrToken value_ pos_ ) = sem_HsToken_StrToken value_ pos_ sem_HsToken ( Err mesg_ pos_ ) = sem_HsToken_Err mesg_ pos_ -- semantic domain newtype T_HsToken = T_HsToken { attach_T_HsToken :: Identity (T_HsToken_s2 ) } newtype T_HsToken_s2 = C_HsToken_s2 { inv_HsToken_s2 :: (T_HsToken_v1 ) } data T_HsToken_s3 = C_HsToken_s3 type T_HsToken_v1 = (T_HsToken_vIn1 ) -> (T_HsToken_vOut1 ) data T_HsToken_vIn1 = T_HsToken_vIn1 ([(Identifier,Type,ChildKind)]) ([Identifier]) ([(Identifier,Identifier)]) (Identifier) ([Identifier]) (Identifier) data T_HsToken_vOut1 = T_HsToken_vOut1 (Seq Error) (HsToken) ((Pos,String)) ([(Identifier,Identifier)]) (Seq Identifier) ([Identifier]) {-# NOINLINE sem_HsToken_AGLocal #-} sem_HsToken_AGLocal :: (Identifier) -> (Pos) -> (Maybe String) -> T_HsToken sem_HsToken_AGLocal arg_var_ arg_pos_ arg_rdesc_ = T_HsToken (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_HsToken_v1 v1 = \ (T_HsToken_vIn1 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIfieldnames _lhsInt) -> ( let _tkAsLocal = rule0 arg_pos_ arg_rdesc_ arg_var_ _tkAsField = rule1 arg_pos_ arg_rdesc_ arg_var_ (_errors,_output,_tok,_usedLocals) = rule2 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIfieldnames _lhsInt _tkAsField _tkAsLocal arg_pos_ arg_var_ _lhsOusedFields :: Seq Identifier _lhsOusedFields = rule3 _lhsIfieldnames arg_var_ _lhsOerrors :: Seq Error _lhsOerrors = rule4 _errors _lhsOusedAttrs :: [(Identifier,Identifier)] _lhsOusedAttrs = rule5 () _lhsOusedLocals :: [Identifier] _lhsOusedLocals = rule6 _usedLocals _lhsOoutput :: HsToken _lhsOoutput = rule7 _output _lhsOtok :: (Pos,String) _lhsOtok = rule8 _tok __result_ = T_HsToken_vOut1 _lhsOerrors _lhsOoutput _lhsOtok _lhsOusedAttrs _lhsOusedFields _lhsOusedLocals in __result_ ) in C_HsToken_s2 v1 {-# INLINE rule0 #-} {-# LINE 65 "./src-ag/SemHsTokens.ag" #-} rule0 = \ pos_ rdesc_ var_ -> {-# LINE 65 "./src-ag/SemHsTokens.ag" #-} AGLocal var_ pos_ rdesc_ {-# LINE 95 "dist/build/SemHsTokens.hs"#-} {-# INLINE rule1 #-} {-# LINE 66 "./src-ag/SemHsTokens.ag" #-} rule1 = \ pos_ rdesc_ var_ -> {-# LINE 66 "./src-ag/SemHsTokens.ag" #-} AGField _LOC var_ pos_ rdesc_ {-# LINE 101 "dist/build/SemHsTokens.hs"#-} {-# INLINE rule2 #-} {-# LINE 68 "./src-ag/SemHsTokens.ag" #-} rule2 = \ ((_lhsIallfields) :: [(Identifier,Type,ChildKind)]) ((_lhsIallnts) :: [Identifier]) ((_lhsIattrs) :: [(Identifier,Identifier)]) ((_lhsIcon) :: Identifier) ((_lhsIfieldnames) :: [Identifier]) ((_lhsInt) :: Identifier) _tkAsField _tkAsLocal pos_ var_ -> {-# LINE 68 "./src-ag/SemHsTokens.ag" #-} if var_ `elem` _lhsIfieldnames then if isNTname _lhsIallnts (lookup var_ (map (\(n,t,_) -> (n,t)) _lhsIallfields)) then (Seq.singleton(ChildAsLocal _lhsInt _lhsIcon var_), _tkAsLocal ,(pos_,fieldname var_), [] ) else (Seq.empty, _tkAsLocal , (pos_,fieldname var_), [] ) else if (_LOC,var_) `elem` _lhsIattrs then (Seq.empty , _tkAsField , (pos_,locname var_), [var_]) else (Seq.singleton(UndefLocal _lhsInt _lhsIcon var_), _tkAsField , (pos_,locname var_), [] ) {-# LINE 113 "dist/build/SemHsTokens.hs"#-} {-# INLINE rule3 #-} {-# LINE 103 "./src-ag/SemHsTokens.ag" #-} rule3 = \ ((_lhsIfieldnames) :: [Identifier]) var_ -> {-# LINE 103 "./src-ag/SemHsTokens.ag" #-} if var_ `elem` _lhsIfieldnames then Seq.singleton var_ else Seq.empty {-# LINE 121 "dist/build/SemHsTokens.hs"#-} {-# INLINE rule4 #-} rule4 = \ _errors -> _errors {-# INLINE rule5 #-} rule5 = \ (_ :: ()) -> [] {-# INLINE rule6 #-} rule6 = \ _usedLocals -> _usedLocals {-# INLINE rule7 #-} rule7 = \ _output -> _output {-# INLINE rule8 #-} rule8 = \ _tok -> _tok {-# NOINLINE sem_HsToken_AGField #-} sem_HsToken_AGField :: (Identifier) -> (Identifier) -> (Pos) -> (Maybe String) -> T_HsToken sem_HsToken_AGField arg_field_ arg_attr_ arg_pos_ arg_rdesc_ = T_HsToken (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_HsToken_v1 v1 = \ (T_HsToken_vIn1 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIfieldnames _lhsInt) -> ( let _lhsOerrors :: Seq Error _lhsOerrors = rule9 _lhsIattrs _lhsIcon _lhsIfieldnames _lhsInt arg_attr_ arg_field_ _lhsOusedAttrs :: [(Identifier,Identifier)] _lhsOusedLocals :: [Identifier] (_lhsOusedAttrs,_lhsOusedLocals) = rule10 arg_attr_ arg_field_ _addTrace = rule11 arg_attr_ arg_field_ arg_rdesc_ _lhsOtok :: (Pos,String) _lhsOtok = rule12 _addTrace arg_attr_ arg_field_ arg_pos_ _lhsOusedFields :: Seq Identifier _lhsOusedFields = rule13 () _output = rule14 arg_attr_ arg_field_ arg_pos_ arg_rdesc_ _lhsOoutput :: HsToken _lhsOoutput = rule15 _output __result_ = T_HsToken_vOut1 _lhsOerrors _lhsOoutput _lhsOtok _lhsOusedAttrs _lhsOusedFields _lhsOusedLocals in __result_ ) in C_HsToken_s2 v1 {-# INLINE rule9 #-} {-# LINE 77 "./src-ag/SemHsTokens.ag" #-} rule9 = \ ((_lhsIattrs) :: [(Identifier,Identifier)]) ((_lhsIcon) :: Identifier) ((_lhsIfieldnames) :: [Identifier]) ((_lhsInt) :: Identifier) attr_ field_ -> {-# LINE 77 "./src-ag/SemHsTokens.ag" #-} if (field_,attr_) `elem` _lhsIattrs then Seq.empty else if not(field_ `elem` (_LHS : _LOC: _lhsIfieldnames)) then Seq.singleton (UndefChild _lhsInt _lhsIcon field_) else Seq.singleton (UndefAttr _lhsInt _lhsIcon field_ attr_ False) {-# LINE 169 "dist/build/SemHsTokens.hs"#-} {-# INLINE rule10 #-} {-# LINE 92 "./src-ag/SemHsTokens.ag" #-} rule10 = \ attr_ field_ -> {-# LINE 92 "./src-ag/SemHsTokens.ag" #-} if field_ == _LOC then ([], [attr_]) else ([(field_,attr_)], []) {-# LINE 177 "dist/build/SemHsTokens.hs"#-} {-# INLINE rule11 #-} {-# LINE 122 "./src-ag/SemHsTokens.ag" #-} rule11 = \ attr_ field_ rdesc_ -> {-# LINE 122 "./src-ag/SemHsTokens.ag" #-} case rdesc_ of Just d -> \x -> "(trace " ++ show (d ++ " -> " ++ show field_ ++ "." ++ show attr_) ++ " (" ++ x ++ "))" Nothing -> id {-# LINE 185 "dist/build/SemHsTokens.hs"#-} {-# INLINE rule12 #-} {-# LINE 125 "./src-ag/SemHsTokens.ag" #-} rule12 = \ _addTrace attr_ field_ pos_ -> {-# LINE 125 "./src-ag/SemHsTokens.ag" #-} (pos_, _addTrace $ attrname True field_ attr_) {-# LINE 191 "dist/build/SemHsTokens.hs"#-} {-# INLINE rule13 #-} rule13 = \ (_ :: ()) -> Seq.empty {-# INLINE rule14 #-} rule14 = \ attr_ field_ pos_ rdesc_ -> AGField field_ attr_ pos_ rdesc_ {-# INLINE rule15 #-} rule15 = \ _output -> _output {-# NOINLINE sem_HsToken_HsToken #-} sem_HsToken_HsToken :: (String) -> (Pos) -> T_HsToken sem_HsToken_HsToken arg_value_ arg_pos_ = T_HsToken (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_HsToken_v1 v1 = \ (T_HsToken_vIn1 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIfieldnames _lhsInt) -> ( let _lhsOtok :: (Pos,String) _lhsOtok = rule16 arg_pos_ arg_value_ _lhsOerrors :: Seq Error _lhsOerrors = rule17 () _lhsOusedAttrs :: [(Identifier,Identifier)] _lhsOusedAttrs = rule18 () _lhsOusedFields :: Seq Identifier _lhsOusedFields = rule19 () _lhsOusedLocals :: [Identifier] _lhsOusedLocals = rule20 () _output = rule21 arg_pos_ arg_value_ _lhsOoutput :: HsToken _lhsOoutput = rule22 _output __result_ = T_HsToken_vOut1 _lhsOerrors _lhsOoutput _lhsOtok _lhsOusedAttrs _lhsOusedFields _lhsOusedLocals in __result_ ) in C_HsToken_s2 v1 {-# INLINE rule16 #-} {-# LINE 127 "./src-ag/SemHsTokens.ag" #-} rule16 = \ pos_ value_ -> {-# LINE 127 "./src-ag/SemHsTokens.ag" #-} (pos_, value_) {-# LINE 229 "dist/build/SemHsTokens.hs"#-} {-# INLINE rule17 #-} rule17 = \ (_ :: ()) -> Seq.empty {-# INLINE rule18 #-} rule18 = \ (_ :: ()) -> [] {-# INLINE rule19 #-} rule19 = \ (_ :: ()) -> Seq.empty {-# INLINE rule20 #-} rule20 = \ (_ :: ()) -> [] {-# INLINE rule21 #-} rule21 = \ pos_ value_ -> HsToken value_ pos_ {-# INLINE rule22 #-} rule22 = \ _output -> _output {-# NOINLINE sem_HsToken_CharToken #-} sem_HsToken_CharToken :: (String) -> (Pos) -> T_HsToken sem_HsToken_CharToken arg_value_ arg_pos_ = T_HsToken (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_HsToken_v1 v1 = \ (T_HsToken_vIn1 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIfieldnames _lhsInt) -> ( let _lhsOtok :: (Pos,String) _lhsOtok = rule23 arg_pos_ arg_value_ _lhsOerrors :: Seq Error _lhsOerrors = rule24 () _lhsOusedAttrs :: [(Identifier,Identifier)] _lhsOusedAttrs = rule25 () _lhsOusedFields :: Seq Identifier _lhsOusedFields = rule26 () _lhsOusedLocals :: [Identifier] _lhsOusedLocals = rule27 () _output = rule28 arg_pos_ arg_value_ _lhsOoutput :: HsToken _lhsOoutput = rule29 _output __result_ = T_HsToken_vOut1 _lhsOerrors _lhsOoutput _lhsOtok _lhsOusedAttrs _lhsOusedFields _lhsOusedLocals in __result_ ) in C_HsToken_s2 v1 {-# INLINE rule23 #-} {-# LINE 129 "./src-ag/SemHsTokens.ag" #-} rule23 = \ pos_ value_ -> {-# LINE 129 "./src-ag/SemHsTokens.ag" #-} (pos_, if null value_ then "" else showCharShort (head value_) ) {-# LINE 279 "dist/build/SemHsTokens.hs"#-} {-# INLINE rule24 #-} rule24 = \ (_ :: ()) -> Seq.empty {-# INLINE rule25 #-} rule25 = \ (_ :: ()) -> [] {-# INLINE rule26 #-} rule26 = \ (_ :: ()) -> Seq.empty {-# INLINE rule27 #-} rule27 = \ (_ :: ()) -> [] {-# INLINE rule28 #-} rule28 = \ pos_ value_ -> CharToken value_ pos_ {-# INLINE rule29 #-} rule29 = \ _output -> _output {-# NOINLINE sem_HsToken_StrToken #-} sem_HsToken_StrToken :: (String) -> (Pos) -> T_HsToken sem_HsToken_StrToken arg_value_ arg_pos_ = T_HsToken (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_HsToken_v1 v1 = \ (T_HsToken_vIn1 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIfieldnames _lhsInt) -> ( let _lhsOtok :: (Pos,String) _lhsOtok = rule30 arg_pos_ arg_value_ _lhsOerrors :: Seq Error _lhsOerrors = rule31 () _lhsOusedAttrs :: [(Identifier,Identifier)] _lhsOusedAttrs = rule32 () _lhsOusedFields :: Seq Identifier _lhsOusedFields = rule33 () _lhsOusedLocals :: [Identifier] _lhsOusedLocals = rule34 () _output = rule35 arg_pos_ arg_value_ _lhsOoutput :: HsToken _lhsOoutput = rule36 _output __result_ = T_HsToken_vOut1 _lhsOerrors _lhsOoutput _lhsOtok _lhsOusedAttrs _lhsOusedFields _lhsOusedLocals in __result_ ) in C_HsToken_s2 v1 {-# INLINE rule30 #-} {-# LINE 134 "./src-ag/SemHsTokens.ag" #-} rule30 = \ pos_ value_ -> {-# LINE 134 "./src-ag/SemHsTokens.ag" #-} (pos_, showStrShort value_) {-# LINE 326 "dist/build/SemHsTokens.hs"#-} {-# INLINE rule31 #-} rule31 = \ (_ :: ()) -> Seq.empty {-# INLINE rule32 #-} rule32 = \ (_ :: ()) -> [] {-# INLINE rule33 #-} rule33 = \ (_ :: ()) -> Seq.empty {-# INLINE rule34 #-} rule34 = \ (_ :: ()) -> [] {-# INLINE rule35 #-} rule35 = \ pos_ value_ -> StrToken value_ pos_ {-# INLINE rule36 #-} rule36 = \ _output -> _output {-# NOINLINE sem_HsToken_Err #-} sem_HsToken_Err :: (String) -> (Pos) -> T_HsToken sem_HsToken_Err arg_mesg_ arg_pos_ = T_HsToken (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_HsToken_v1 v1 = \ (T_HsToken_vIn1 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIfieldnames _lhsInt) -> ( let _lhsOerrors :: Seq Error _lhsOerrors = rule37 arg_mesg_ arg_pos_ _lhsOtok :: (Pos,String) _lhsOtok = rule38 arg_pos_ _lhsOusedAttrs :: [(Identifier,Identifier)] _lhsOusedAttrs = rule39 () _lhsOusedFields :: Seq Identifier _lhsOusedFields = rule40 () _lhsOusedLocals :: [Identifier] _lhsOusedLocals = rule41 () _output = rule42 arg_mesg_ arg_pos_ _lhsOoutput :: HsToken _lhsOoutput = rule43 _output __result_ = T_HsToken_vOut1 _lhsOerrors _lhsOoutput _lhsOtok _lhsOusedAttrs _lhsOusedFields _lhsOusedLocals in __result_ ) in C_HsToken_s2 v1 {-# INLINE rule37 #-} {-# LINE 50 "./src-ag/SemHsTokens.ag" #-} rule37 = \ mesg_ pos_ -> {-# LINE 50 "./src-ag/SemHsTokens.ag" #-} let m = text mesg_ in Seq.singleton (CustomError False pos_ m) {-# LINE 374 "dist/build/SemHsTokens.hs"#-} {-# INLINE rule38 #-} {-# LINE 135 "./src-ag/SemHsTokens.ag" #-} rule38 = \ pos_ -> {-# LINE 135 "./src-ag/SemHsTokens.ag" #-} (pos_, "") {-# LINE 380 "dist/build/SemHsTokens.hs"#-} {-# INLINE rule39 #-} rule39 = \ (_ :: ()) -> [] {-# INLINE rule40 #-} rule40 = \ (_ :: ()) -> Seq.empty {-# INLINE rule41 #-} rule41 = \ (_ :: ()) -> [] {-# INLINE rule42 #-} rule42 = \ mesg_ pos_ -> Err mesg_ pos_ {-# INLINE rule43 #-} rule43 = \ _output -> _output -- HsTokens ---------------------------------------------------- -- wrapper data Inh_HsTokens = Inh_HsTokens { allfields_Inh_HsTokens :: ([(Identifier,Type,ChildKind)]), allnts_Inh_HsTokens :: ([Identifier]), attrs_Inh_HsTokens :: ([(Identifier,Identifier)]), con_Inh_HsTokens :: (Identifier), fieldnames_Inh_HsTokens :: ([Identifier]), nt_Inh_HsTokens :: (Identifier) } data Syn_HsTokens = Syn_HsTokens { errors_Syn_HsTokens :: (Seq Error), output_Syn_HsTokens :: (HsTokens), tks_Syn_HsTokens :: ([(Pos,String)]), usedAttrs_Syn_HsTokens :: ([(Identifier,Identifier)]), usedFields_Syn_HsTokens :: (Seq Identifier), usedLocals_Syn_HsTokens :: ([Identifier]) } {-# INLINABLE wrap_HsTokens #-} wrap_HsTokens :: T_HsTokens -> Inh_HsTokens -> (Syn_HsTokens ) wrap_HsTokens (T_HsTokens act) (Inh_HsTokens _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIfieldnames _lhsInt) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_HsTokens_vIn4 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIfieldnames _lhsInt (T_HsTokens_vOut4 _lhsOerrors _lhsOoutput _lhsOtks _lhsOusedAttrs _lhsOusedFields _lhsOusedLocals) <- return (inv_HsTokens_s5 sem arg) return (Syn_HsTokens _lhsOerrors _lhsOoutput _lhsOtks _lhsOusedAttrs _lhsOusedFields _lhsOusedLocals) ) -- cata {-# NOINLINE sem_HsTokens #-} sem_HsTokens :: HsTokens -> T_HsTokens sem_HsTokens list = Prelude.foldr sem_HsTokens_Cons sem_HsTokens_Nil (Prelude.map sem_HsToken list) -- semantic domain newtype T_HsTokens = T_HsTokens { attach_T_HsTokens :: Identity (T_HsTokens_s5 ) } newtype T_HsTokens_s5 = C_HsTokens_s5 { inv_HsTokens_s5 :: (T_HsTokens_v4 ) } data T_HsTokens_s6 = C_HsTokens_s6 type T_HsTokens_v4 = (T_HsTokens_vIn4 ) -> (T_HsTokens_vOut4 ) data T_HsTokens_vIn4 = T_HsTokens_vIn4 ([(Identifier,Type,ChildKind)]) ([Identifier]) ([(Identifier,Identifier)]) (Identifier) ([Identifier]) (Identifier) data T_HsTokens_vOut4 = T_HsTokens_vOut4 (Seq Error) (HsTokens) ([(Pos,String)]) ([(Identifier,Identifier)]) (Seq Identifier) ([Identifier]) {-# NOINLINE sem_HsTokens_Cons #-} sem_HsTokens_Cons :: T_HsToken -> T_HsTokens -> T_HsTokens sem_HsTokens_Cons arg_hd_ arg_tl_ = T_HsTokens (return st5) where {-# NOINLINE st5 #-} st5 = let v4 :: T_HsTokens_v4 v4 = \ (T_HsTokens_vIn4 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIfieldnames _lhsInt) -> ( let _hdX2 = Control.Monad.Identity.runIdentity (attach_T_HsToken (arg_hd_)) _tlX5 = Control.Monad.Identity.runIdentity (attach_T_HsTokens (arg_tl_)) (T_HsToken_vOut1 _hdIerrors _hdIoutput _hdItok _hdIusedAttrs _hdIusedFields _hdIusedLocals) = inv_HsToken_s2 _hdX2 (T_HsToken_vIn1 _hdOallfields _hdOallnts _hdOattrs _hdOcon _hdOfieldnames _hdOnt) (T_HsTokens_vOut4 _tlIerrors _tlIoutput _tlItks _tlIusedAttrs _tlIusedFields _tlIusedLocals) = inv_HsTokens_s5 _tlX5 (T_HsTokens_vIn4 _tlOallfields _tlOallnts _tlOattrs _tlOcon _tlOfieldnames _tlOnt) _lhsOtks :: [(Pos,String)] _lhsOtks = rule44 _hdItok _tlItks _lhsOerrors :: Seq Error _lhsOerrors = rule45 _hdIerrors _tlIerrors _lhsOusedAttrs :: [(Identifier,Identifier)] _lhsOusedAttrs = rule46 _hdIusedAttrs _tlIusedAttrs _lhsOusedFields :: Seq Identifier _lhsOusedFields = rule47 _hdIusedFields _tlIusedFields _lhsOusedLocals :: [Identifier] _lhsOusedLocals = rule48 _hdIusedLocals _tlIusedLocals _output = rule49 _hdIoutput _tlIoutput _lhsOoutput :: HsTokens _lhsOoutput = rule50 _output _hdOallfields = rule51 _lhsIallfields _hdOallnts = rule52 _lhsIallnts _hdOattrs = rule53 _lhsIattrs _hdOcon = rule54 _lhsIcon _hdOfieldnames = rule55 _lhsIfieldnames _hdOnt = rule56 _lhsInt _tlOallfields = rule57 _lhsIallfields _tlOallnts = rule58 _lhsIallnts _tlOattrs = rule59 _lhsIattrs _tlOcon = rule60 _lhsIcon _tlOfieldnames = rule61 _lhsIfieldnames _tlOnt = rule62 _lhsInt __result_ = T_HsTokens_vOut4 _lhsOerrors _lhsOoutput _lhsOtks _lhsOusedAttrs _lhsOusedFields _lhsOusedLocals in __result_ ) in C_HsTokens_s5 v4 {-# INLINE rule44 #-} {-# LINE 117 "./src-ag/SemHsTokens.ag" #-} rule44 = \ ((_hdItok) :: (Pos,String)) ((_tlItks) :: [(Pos,String)]) -> {-# LINE 117 "./src-ag/SemHsTokens.ag" #-} _hdItok : _tlItks {-# LINE 471 "dist/build/SemHsTokens.hs"#-} {-# INLINE rule45 #-} rule45 = \ ((_hdIerrors) :: Seq Error) ((_tlIerrors) :: Seq Error) -> _hdIerrors Seq.>< _tlIerrors {-# INLINE rule46 #-} rule46 = \ ((_hdIusedAttrs) :: [(Identifier,Identifier)]) ((_tlIusedAttrs) :: [(Identifier,Identifier)]) -> _hdIusedAttrs ++ _tlIusedAttrs {-# INLINE rule47 #-} rule47 = \ ((_hdIusedFields) :: Seq Identifier) ((_tlIusedFields) :: Seq Identifier) -> _hdIusedFields Seq.>< _tlIusedFields {-# INLINE rule48 #-} rule48 = \ ((_hdIusedLocals) :: [Identifier]) ((_tlIusedLocals) :: [Identifier]) -> _hdIusedLocals ++ _tlIusedLocals {-# INLINE rule49 #-} rule49 = \ ((_hdIoutput) :: HsToken) ((_tlIoutput) :: HsTokens) -> (:) _hdIoutput _tlIoutput {-# INLINE rule50 #-} rule50 = \ _output -> _output {-# INLINE rule51 #-} rule51 = \ ((_lhsIallfields) :: [(Identifier,Type,ChildKind)]) -> _lhsIallfields {-# INLINE rule52 #-} rule52 = \ ((_lhsIallnts) :: [Identifier]) -> _lhsIallnts {-# INLINE rule53 #-} rule53 = \ ((_lhsIattrs) :: [(Identifier,Identifier)]) -> _lhsIattrs {-# INLINE rule54 #-} rule54 = \ ((_lhsIcon) :: Identifier) -> _lhsIcon {-# INLINE rule55 #-} rule55 = \ ((_lhsIfieldnames) :: [Identifier]) -> _lhsIfieldnames {-# INLINE rule56 #-} rule56 = \ ((_lhsInt) :: Identifier) -> _lhsInt {-# INLINE rule57 #-} rule57 = \ ((_lhsIallfields) :: [(Identifier,Type,ChildKind)]) -> _lhsIallfields {-# INLINE rule58 #-} rule58 = \ ((_lhsIallnts) :: [Identifier]) -> _lhsIallnts {-# INLINE rule59 #-} rule59 = \ ((_lhsIattrs) :: [(Identifier,Identifier)]) -> _lhsIattrs {-# INLINE rule60 #-} rule60 = \ ((_lhsIcon) :: Identifier) -> _lhsIcon {-# INLINE rule61 #-} rule61 = \ ((_lhsIfieldnames) :: [Identifier]) -> _lhsIfieldnames {-# INLINE rule62 #-} rule62 = \ ((_lhsInt) :: Identifier) -> _lhsInt {-# NOINLINE sem_HsTokens_Nil #-} sem_HsTokens_Nil :: T_HsTokens sem_HsTokens_Nil = T_HsTokens (return st5) where {-# NOINLINE st5 #-} st5 = let v4 :: T_HsTokens_v4 v4 = \ (T_HsTokens_vIn4 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIfieldnames _lhsInt) -> ( let _lhsOtks :: [(Pos,String)] _lhsOtks = rule63 () _lhsOerrors :: Seq Error _lhsOerrors = rule64 () _lhsOusedAttrs :: [(Identifier,Identifier)] _lhsOusedAttrs = rule65 () _lhsOusedFields :: Seq Identifier _lhsOusedFields = rule66 () _lhsOusedLocals :: [Identifier] _lhsOusedLocals = rule67 () _output = rule68 () _lhsOoutput :: HsTokens _lhsOoutput = rule69 _output __result_ = T_HsTokens_vOut4 _lhsOerrors _lhsOoutput _lhsOtks _lhsOusedAttrs _lhsOusedFields _lhsOusedLocals in __result_ ) in C_HsTokens_s5 v4 {-# INLINE rule63 #-} {-# LINE 118 "./src-ag/SemHsTokens.ag" #-} rule63 = \ (_ :: ()) -> {-# LINE 118 "./src-ag/SemHsTokens.ag" #-} [] {-# LINE 554 "dist/build/SemHsTokens.hs"#-} {-# INLINE rule64 #-} rule64 = \ (_ :: ()) -> Seq.empty {-# INLINE rule65 #-} rule65 = \ (_ :: ()) -> [] {-# INLINE rule66 #-} rule66 = \ (_ :: ()) -> Seq.empty {-# INLINE rule67 #-} rule67 = \ (_ :: ()) -> [] {-# INLINE rule68 #-} rule68 = \ (_ :: ()) -> [] {-# INLINE rule69 #-} rule69 = \ _output -> _output -- HsTokensRoot ------------------------------------------------ -- wrapper data Inh_HsTokensRoot = Inh_HsTokensRoot { allfields_Inh_HsTokensRoot :: ([(Identifier,Type,ChildKind)]), allnts_Inh_HsTokensRoot :: ([Identifier]), attrs_Inh_HsTokensRoot :: ([(Identifier,Identifier)]), con_Inh_HsTokensRoot :: (Identifier), nt_Inh_HsTokensRoot :: (Identifier) } data Syn_HsTokensRoot = Syn_HsTokensRoot { errors_Syn_HsTokensRoot :: (Seq Error), output_Syn_HsTokensRoot :: ([HsToken]), textLines_Syn_HsTokensRoot :: ([String]), usedAttrs_Syn_HsTokensRoot :: ([(Identifier,Identifier)]), usedFields_Syn_HsTokensRoot :: ([Identifier]), usedLocals_Syn_HsTokensRoot :: ([Identifier]) } {-# INLINABLE wrap_HsTokensRoot #-} wrap_HsTokensRoot :: T_HsTokensRoot -> Inh_HsTokensRoot -> (Syn_HsTokensRoot ) wrap_HsTokensRoot (T_HsTokensRoot act) (Inh_HsTokensRoot _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsInt) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_HsTokensRoot_vIn7 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsInt (T_HsTokensRoot_vOut7 _lhsOerrors _lhsOoutput _lhsOtextLines _lhsOusedAttrs _lhsOusedFields _lhsOusedLocals) <- return (inv_HsTokensRoot_s8 sem arg) return (Syn_HsTokensRoot _lhsOerrors _lhsOoutput _lhsOtextLines _lhsOusedAttrs _lhsOusedFields _lhsOusedLocals) ) -- cata {-# INLINE sem_HsTokensRoot #-} sem_HsTokensRoot :: HsTokensRoot -> T_HsTokensRoot sem_HsTokensRoot ( HsTokensRoot tokens_ ) = sem_HsTokensRoot_HsTokensRoot ( sem_HsTokens tokens_ ) -- semantic domain newtype T_HsTokensRoot = T_HsTokensRoot { attach_T_HsTokensRoot :: Identity (T_HsTokensRoot_s8 ) } newtype T_HsTokensRoot_s8 = C_HsTokensRoot_s8 { inv_HsTokensRoot_s8 :: (T_HsTokensRoot_v7 ) } data T_HsTokensRoot_s9 = C_HsTokensRoot_s9 type T_HsTokensRoot_v7 = (T_HsTokensRoot_vIn7 ) -> (T_HsTokensRoot_vOut7 ) data T_HsTokensRoot_vIn7 = T_HsTokensRoot_vIn7 ([(Identifier,Type,ChildKind)]) ([Identifier]) ([(Identifier,Identifier)]) (Identifier) (Identifier) data T_HsTokensRoot_vOut7 = T_HsTokensRoot_vOut7 (Seq Error) ([HsToken]) ([String]) ([(Identifier,Identifier)]) ([Identifier]) ([Identifier]) {-# NOINLINE sem_HsTokensRoot_HsTokensRoot #-} sem_HsTokensRoot_HsTokensRoot :: T_HsTokens -> T_HsTokensRoot sem_HsTokensRoot_HsTokensRoot arg_tokens_ = T_HsTokensRoot (return st8) where {-# NOINLINE st8 #-} st8 = let v7 :: T_HsTokensRoot_v7 v7 = \ (T_HsTokensRoot_vIn7 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsInt) -> ( let _tokensX5 = Control.Monad.Identity.runIdentity (attach_T_HsTokens (arg_tokens_)) (T_HsTokens_vOut4 _tokensIerrors _tokensIoutput _tokensItks _tokensIusedAttrs _tokensIusedFields _tokensIusedLocals) = inv_HsTokens_s5 _tokensX5 (T_HsTokens_vIn4 _tokensOallfields _tokensOallnts _tokensOattrs _tokensOcon _tokensOfieldnames _tokensOnt) _tokensOfieldnames = rule70 _lhsIallfields _lhsOusedFields :: [Identifier] _lhsOusedFields = rule71 _tokensIusedFields _lhsOtextLines :: [String] _lhsOtextLines = rule72 _tokensItks _lhsOerrors :: Seq Error _lhsOerrors = rule73 _tokensIerrors _lhsOoutput :: [HsToken] _lhsOoutput = rule74 _tokensIoutput _lhsOusedAttrs :: [(Identifier,Identifier)] _lhsOusedAttrs = rule75 _tokensIusedAttrs _lhsOusedLocals :: [Identifier] _lhsOusedLocals = rule76 _tokensIusedLocals _tokensOallfields = rule77 _lhsIallfields _tokensOallnts = rule78 _lhsIallnts _tokensOattrs = rule79 _lhsIattrs _tokensOcon = rule80 _lhsIcon _tokensOnt = rule81 _lhsInt __result_ = T_HsTokensRoot_vOut7 _lhsOerrors _lhsOoutput _lhsOtextLines _lhsOusedAttrs _lhsOusedFields _lhsOusedLocals in __result_ ) in C_HsTokensRoot_s8 v7 {-# INLINE rule70 #-} {-# LINE 38 "./src-ag/SemHsTokens.ag" #-} rule70 = \ ((_lhsIallfields) :: [(Identifier,Type,ChildKind)]) -> {-# LINE 38 "./src-ag/SemHsTokens.ag" #-} map (\(n,_,_) -> n) _lhsIallfields {-# LINE 639 "dist/build/SemHsTokens.hs"#-} {-# INLINE rule71 #-} {-# LINE 107 "./src-ag/SemHsTokens.ag" #-} rule71 = \ ((_tokensIusedFields) :: Seq Identifier) -> {-# LINE 107 "./src-ag/SemHsTokens.ag" #-} toList _tokensIusedFields {-# LINE 645 "dist/build/SemHsTokens.hs"#-} {-# INLINE rule72 #-} {-# LINE 114 "./src-ag/SemHsTokens.ag" #-} rule72 = \ ((_tokensItks) :: [(Pos,String)]) -> {-# LINE 114 "./src-ag/SemHsTokens.ag" #-} showTokens _tokensItks {-# LINE 651 "dist/build/SemHsTokens.hs"#-} {-# INLINE rule73 #-} rule73 = \ ((_tokensIerrors) :: Seq Error) -> _tokensIerrors {-# INLINE rule74 #-} rule74 = \ ((_tokensIoutput) :: HsTokens) -> _tokensIoutput {-# INLINE rule75 #-} rule75 = \ ((_tokensIusedAttrs) :: [(Identifier,Identifier)]) -> _tokensIusedAttrs {-# INLINE rule76 #-} rule76 = \ ((_tokensIusedLocals) :: [Identifier]) -> _tokensIusedLocals {-# INLINE rule77 #-} rule77 = \ ((_lhsIallfields) :: [(Identifier,Type,ChildKind)]) -> _lhsIallfields {-# INLINE rule78 #-} rule78 = \ ((_lhsIallnts) :: [Identifier]) -> _lhsIallnts {-# INLINE rule79 #-} rule79 = \ ((_lhsIattrs) :: [(Identifier,Identifier)]) -> _lhsIattrs {-# INLINE rule80 #-} rule80 = \ ((_lhsIcon) :: Identifier) -> _lhsIcon {-# INLINE rule81 #-} rule81 = \ ((_lhsInt) :: Identifier) -> _lhsInt uuagc-0.9.42.3/src-generated/TfmToVisage.hs000644 000765 000024 00000165332 12127045231 022327 0ustar00jeroenbransenstaff000000 000000 {-# LANGUAGE Rank2Types, GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} module TfmToVisage where {-# LINE 2 "./src-ag/AbstractSyntax.ag" #-} -- 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 {-# LINE 16 "dist/build/TfmToVisage.hs" #-} {-# LINE 2 "./src-ag/Patterns.ag" #-} -- Patterns.ag imports import UU.Scanner.Position(Pos) import CommonTypes (ConstructorIdent,Identifier) {-# LINE 23 "dist/build/TfmToVisage.hs" #-} {-# LINE 2 "./src-ag/Expression.ag" #-} import UU.Scanner.Position(Pos) import HsToken {-# LINE 29 "dist/build/TfmToVisage.hs" #-} {-# LINE 9 "./src-ag/TfmToVisage.ag" #-} import AbstractSyntax import VisagePatterns import VisageSyntax import qualified Data.Map as Map import Data.Map (Map) {-# LINE 38 "dist/build/TfmToVisage.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 17 "./src-ag/TfmToVisage.ag" #-} -- 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 -} {-# LINE 96 "dist/build/TfmToVisage.hs" #-} -- Child ------------------------------------------------------- -- wrapper data Inh_Child = Inh_Child { inhMap_Inh_Child :: (Map Identifier Attributes), rulemap_Inh_Child :: (VisageRuleMap), synMap_Inh_Child :: (Map Identifier Attributes) } data Syn_Child = Syn_Child { vchild_Syn_Child :: (VisageChild) } {-# INLINABLE wrap_Child #-} wrap_Child :: T_Child -> Inh_Child -> (Syn_Child ) wrap_Child (T_Child act) (Inh_Child _lhsIinhMap _lhsIrulemap _lhsIsynMap) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Child_vIn1 _lhsIinhMap _lhsIrulemap _lhsIsynMap (T_Child_vOut1 _lhsOvchild) <- return (inv_Child_s2 sem arg) return (Syn_Child _lhsOvchild) ) -- cata {-# INLINE sem_Child #-} sem_Child :: Child -> T_Child sem_Child ( Child name_ tp_ kind_ ) = sem_Child_Child name_ tp_ kind_ -- semantic domain newtype T_Child = T_Child { attach_T_Child :: Identity (T_Child_s2 ) } newtype T_Child_s2 = C_Child_s2 { inv_Child_s2 :: (T_Child_v1 ) } data T_Child_s3 = C_Child_s3 type T_Child_v1 = (T_Child_vIn1 ) -> (T_Child_vOut1 ) data T_Child_vIn1 = T_Child_vIn1 (Map Identifier Attributes) (VisageRuleMap) (Map Identifier Attributes) data T_Child_vOut1 = T_Child_vOut1 (VisageChild) {-# NOINLINE sem_Child_Child #-} sem_Child_Child :: (Identifier) -> (Type) -> (ChildKind) -> T_Child sem_Child_Child arg_name_ arg_tp_ _ = T_Child (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Child_v1 v1 = \ (T_Child_vIn1 _lhsIinhMap _lhsIrulemap _lhsIsynMap) -> ( let _chnt = rule0 arg_name_ arg_tp_ _inh = rule1 _chnt _lhsIinhMap _syn = rule2 _chnt _lhsIsynMap _lhsOvchild :: VisageChild _lhsOvchild = rule3 _inh _lhsIrulemap _syn arg_name_ arg_tp_ __result_ = T_Child_vOut1 _lhsOvchild in __result_ ) in C_Child_s2 v1 {-# INLINE rule0 #-} {-# LINE 19 "./src-ag/DistChildAttr.ag" #-} rule0 = \ name_ tp_ -> {-# LINE 19 "./src-ag/DistChildAttr.ag" #-} case tp_ of NT nt _ _ -> nt Self -> error ("The type of child " ++ show name_ ++ " should not be a Self type.") Haskell t -> identifier "" {-# LINE 150 "dist/build/TfmToVisage.hs"#-} {-# INLINE rule1 #-} {-# LINE 23 "./src-ag/DistChildAttr.ag" #-} rule1 = \ _chnt ((_lhsIinhMap) :: Map Identifier Attributes) -> {-# LINE 23 "./src-ag/DistChildAttr.ag" #-} Map.findWithDefault Map.empty _chnt _lhsIinhMap {-# LINE 156 "dist/build/TfmToVisage.hs"#-} {-# INLINE rule2 #-} {-# LINE 24 "./src-ag/DistChildAttr.ag" #-} rule2 = \ _chnt ((_lhsIsynMap) :: Map Identifier Attributes) -> {-# LINE 24 "./src-ag/DistChildAttr.ag" #-} Map.findWithDefault Map.empty _chnt _lhsIsynMap {-# LINE 162 "dist/build/TfmToVisage.hs"#-} {-# INLINE rule3 #-} {-# LINE 121 "./src-ag/TfmToVisage.ag" #-} rule3 = \ _inh ((_lhsIrulemap) :: VisageRuleMap) _syn name_ tp_ -> {-# LINE 121 "./src-ag/TfmToVisage.ag" #-} VChild name_ tp_ _inh _syn (getForField (getName name_) _lhsIrulemap) {-# LINE 168 "dist/build/TfmToVisage.hs"#-} -- Children ---------------------------------------------------- -- wrapper data Inh_Children = Inh_Children { inhMap_Inh_Children :: (Map Identifier Attributes), rulemap_Inh_Children :: (VisageRuleMap), synMap_Inh_Children :: (Map Identifier Attributes) } data Syn_Children = Syn_Children { vchildren_Syn_Children :: ([VisageChild]) } {-# INLINABLE wrap_Children #-} wrap_Children :: T_Children -> Inh_Children -> (Syn_Children ) wrap_Children (T_Children act) (Inh_Children _lhsIinhMap _lhsIrulemap _lhsIsynMap) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Children_vIn4 _lhsIinhMap _lhsIrulemap _lhsIsynMap (T_Children_vOut4 _lhsOvchildren) <- return (inv_Children_s5 sem arg) return (Syn_Children _lhsOvchildren) ) -- cata {-# NOINLINE sem_Children #-} sem_Children :: Children -> T_Children sem_Children list = Prelude.foldr sem_Children_Cons sem_Children_Nil (Prelude.map sem_Child list) -- semantic domain newtype T_Children = T_Children { attach_T_Children :: Identity (T_Children_s5 ) } newtype T_Children_s5 = C_Children_s5 { inv_Children_s5 :: (T_Children_v4 ) } data T_Children_s6 = C_Children_s6 type T_Children_v4 = (T_Children_vIn4 ) -> (T_Children_vOut4 ) data T_Children_vIn4 = T_Children_vIn4 (Map Identifier Attributes) (VisageRuleMap) (Map Identifier Attributes) data T_Children_vOut4 = T_Children_vOut4 ([VisageChild]) {-# NOINLINE sem_Children_Cons #-} sem_Children_Cons :: T_Child -> T_Children -> T_Children sem_Children_Cons arg_hd_ arg_tl_ = T_Children (return st5) where {-# NOINLINE st5 #-} st5 = let v4 :: T_Children_v4 v4 = \ (T_Children_vIn4 _lhsIinhMap _lhsIrulemap _lhsIsynMap) -> ( let _hdX2 = Control.Monad.Identity.runIdentity (attach_T_Child (arg_hd_)) _tlX5 = Control.Monad.Identity.runIdentity (attach_T_Children (arg_tl_)) (T_Child_vOut1 _hdIvchild) = inv_Child_s2 _hdX2 (T_Child_vIn1 _hdOinhMap _hdOrulemap _hdOsynMap) (T_Children_vOut4 _tlIvchildren) = inv_Children_s5 _tlX5 (T_Children_vIn4 _tlOinhMap _tlOrulemap _tlOsynMap) _lhsOvchildren :: [VisageChild] _lhsOvchildren = rule4 _hdIvchild _tlIvchildren _hdOinhMap = rule5 _lhsIinhMap _hdOrulemap = rule6 _lhsIrulemap _hdOsynMap = rule7 _lhsIsynMap _tlOinhMap = rule8 _lhsIinhMap _tlOrulemap = rule9 _lhsIrulemap _tlOsynMap = rule10 _lhsIsynMap __result_ = T_Children_vOut4 _lhsOvchildren in __result_ ) in C_Children_s5 v4 {-# INLINE rule4 #-} {-# LINE 117 "./src-ag/TfmToVisage.ag" #-} rule4 = \ ((_hdIvchild) :: VisageChild) ((_tlIvchildren) :: [VisageChild]) -> {-# LINE 117 "./src-ag/TfmToVisage.ag" #-} _hdIvchild : _tlIvchildren {-# LINE 227 "dist/build/TfmToVisage.hs"#-} {-# INLINE rule5 #-} rule5 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule6 #-} rule6 = \ ((_lhsIrulemap) :: VisageRuleMap) -> _lhsIrulemap {-# INLINE rule7 #-} rule7 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# INLINE rule8 #-} rule8 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule9 #-} rule9 = \ ((_lhsIrulemap) :: VisageRuleMap) -> _lhsIrulemap {-# INLINE rule10 #-} rule10 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# NOINLINE sem_Children_Nil #-} sem_Children_Nil :: T_Children sem_Children_Nil = T_Children (return st5) where {-# NOINLINE st5 #-} st5 = let v4 :: T_Children_v4 v4 = \ (T_Children_vIn4 _lhsIinhMap _lhsIrulemap _lhsIsynMap) -> ( let _lhsOvchildren :: [VisageChild] _lhsOvchildren = rule11 () __result_ = T_Children_vOut4 _lhsOvchildren in __result_ ) in C_Children_s5 v4 {-# INLINE rule11 #-} {-# LINE 118 "./src-ag/TfmToVisage.ag" #-} rule11 = \ (_ :: ()) -> {-# LINE 118 "./src-ag/TfmToVisage.ag" #-} [] {-# LINE 263 "dist/build/TfmToVisage.hs"#-} -- Expression -------------------------------------------------- -- wrapper data Inh_Expression = Inh_Expression { } data Syn_Expression = Syn_Expression { self_Syn_Expression :: (Expression) } {-# INLINABLE wrap_Expression #-} wrap_Expression :: T_Expression -> Inh_Expression -> (Syn_Expression ) wrap_Expression (T_Expression act) (Inh_Expression ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Expression_vIn7 (T_Expression_vOut7 _lhsOself) <- return (inv_Expression_s8 sem arg) return (Syn_Expression _lhsOself) ) -- cata {-# INLINE sem_Expression #-} sem_Expression :: Expression -> T_Expression sem_Expression ( Expression pos_ tks_ ) = sem_Expression_Expression pos_ tks_ -- semantic domain newtype T_Expression = T_Expression { attach_T_Expression :: Identity (T_Expression_s8 ) } newtype T_Expression_s8 = C_Expression_s8 { inv_Expression_s8 :: (T_Expression_v7 ) } data T_Expression_s9 = C_Expression_s9 type T_Expression_v7 = (T_Expression_vIn7 ) -> (T_Expression_vOut7 ) data T_Expression_vIn7 = T_Expression_vIn7 data T_Expression_vOut7 = T_Expression_vOut7 (Expression) {-# NOINLINE sem_Expression_Expression #-} sem_Expression_Expression :: (Pos) -> ([HsToken]) -> T_Expression sem_Expression_Expression arg_pos_ arg_tks_ = T_Expression (return st8) where {-# NOINLINE st8 #-} st8 = let v7 :: T_Expression_v7 v7 = \ (T_Expression_vIn7 ) -> ( let _self = rule12 arg_pos_ arg_tks_ _lhsOself :: Expression _lhsOself = rule13 _self __result_ = T_Expression_vOut7 _lhsOself in __result_ ) in C_Expression_s8 v7 {-# INLINE rule12 #-} rule12 = \ pos_ tks_ -> Expression pos_ tks_ {-# INLINE rule13 #-} rule13 = \ _self -> _self -- Grammar ----------------------------------------------------- -- wrapper data Inh_Grammar = Inh_Grammar { } data Syn_Grammar = Syn_Grammar { visage_Syn_Grammar :: (VisageGrammar) } {-# INLINABLE wrap_Grammar #-} wrap_Grammar :: T_Grammar -> Inh_Grammar -> (Syn_Grammar ) wrap_Grammar (T_Grammar act) (Inh_Grammar ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Grammar_vIn10 (T_Grammar_vOut10 _lhsOvisage) <- return (inv_Grammar_s11 sem arg) return (Syn_Grammar _lhsOvisage) ) -- cata {-# INLINE sem_Grammar #-} sem_Grammar :: Grammar -> T_Grammar sem_Grammar ( Grammar typeSyns_ useMap_ derivings_ wrappers_ nonts_ pragmas_ manualAttrOrderMap_ paramMap_ contextMap_ quantMap_ uniqueMap_ augmentsMap_ aroundsMap_ mergeMap_ ) = sem_Grammar_Grammar typeSyns_ useMap_ derivings_ wrappers_ ( sem_Nonterminals nonts_ ) pragmas_ manualAttrOrderMap_ paramMap_ contextMap_ quantMap_ uniqueMap_ augmentsMap_ aroundsMap_ mergeMap_ -- semantic domain newtype T_Grammar = T_Grammar { attach_T_Grammar :: Identity (T_Grammar_s11 ) } newtype T_Grammar_s11 = C_Grammar_s11 { inv_Grammar_s11 :: (T_Grammar_v10 ) } data T_Grammar_s12 = C_Grammar_s12 type T_Grammar_v10 = (T_Grammar_vIn10 ) -> (T_Grammar_vOut10 ) data T_Grammar_vIn10 = T_Grammar_vIn10 data T_Grammar_vOut10 = T_Grammar_vOut10 (VisageGrammar) {-# NOINLINE sem_Grammar_Grammar #-} sem_Grammar_Grammar :: (TypeSyns) -> (UseMap) -> (Derivings) -> (Set NontermIdent) -> T_Nonterminals -> (PragmaMap) -> (AttrOrderMap) -> (ParamMap) -> (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)))) -> T_Grammar sem_Grammar_Grammar _ _ _ _ arg_nonts_ _ _ _ _ _ _ _ _ _ = T_Grammar (return st11) where {-# NOINLINE st11 #-} st11 = let v10 :: T_Grammar_v10 v10 = \ (T_Grammar_vIn10 ) -> ( let _nontsX17 = Control.Monad.Identity.runIdentity (attach_T_Nonterminals (arg_nonts_)) (T_Nonterminals_vOut16 _nontsIinhMap' _nontsIsynMap' _nontsIvnonts) = inv_Nonterminals_s17 _nontsX17 (T_Nonterminals_vIn16 _nontsOinhMap _nontsOsynMap) _nontsOinhMap = rule14 _nontsIinhMap' _nontsOsynMap = rule15 _nontsIsynMap' _lhsOvisage :: VisageGrammar _lhsOvisage = rule16 _nontsIvnonts __result_ = T_Grammar_vOut10 _lhsOvisage in __result_ ) in C_Grammar_s11 v10 {-# INLINE rule14 #-} {-# LINE 15 "./src-ag/DistChildAttr.ag" #-} rule14 = \ ((_nontsIinhMap') :: Map Identifier Attributes) -> {-# LINE 15 "./src-ag/DistChildAttr.ag" #-} _nontsIinhMap' {-# LINE 366 "dist/build/TfmToVisage.hs"#-} {-# INLINE rule15 #-} {-# LINE 16 "./src-ag/DistChildAttr.ag" #-} rule15 = \ ((_nontsIsynMap') :: Map Identifier Attributes) -> {-# LINE 16 "./src-ag/DistChildAttr.ag" #-} _nontsIsynMap' {-# LINE 372 "dist/build/TfmToVisage.hs"#-} {-# INLINE rule16 #-} {-# LINE 90 "./src-ag/TfmToVisage.ag" #-} rule16 = \ ((_nontsIvnonts) :: [VisageNonterminal]) -> {-# LINE 90 "./src-ag/TfmToVisage.ag" #-} VGrammar _nontsIvnonts {-# LINE 378 "dist/build/TfmToVisage.hs"#-} -- Nonterminal ------------------------------------------------- -- wrapper data Inh_Nonterminal = Inh_Nonterminal { inhMap_Inh_Nonterminal :: (Map Identifier Attributes), synMap_Inh_Nonterminal :: (Map Identifier Attributes) } data Syn_Nonterminal = Syn_Nonterminal { inhMap'_Syn_Nonterminal :: (Map Identifier Attributes), synMap'_Syn_Nonterminal :: (Map Identifier Attributes), vnont_Syn_Nonterminal :: (VisageNonterminal) } {-# INLINABLE wrap_Nonterminal #-} wrap_Nonterminal :: T_Nonterminal -> Inh_Nonterminal -> (Syn_Nonterminal ) wrap_Nonterminal (T_Nonterminal act) (Inh_Nonterminal _lhsIinhMap _lhsIsynMap) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Nonterminal_vIn13 _lhsIinhMap _lhsIsynMap (T_Nonterminal_vOut13 _lhsOinhMap' _lhsOsynMap' _lhsOvnont) <- return (inv_Nonterminal_s14 sem arg) return (Syn_Nonterminal _lhsOinhMap' _lhsOsynMap' _lhsOvnont) ) -- cata {-# INLINE sem_Nonterminal #-} sem_Nonterminal :: Nonterminal -> T_Nonterminal sem_Nonterminal ( Nonterminal nt_ params_ inh_ syn_ prods_ ) = sem_Nonterminal_Nonterminal nt_ params_ inh_ syn_ ( sem_Productions prods_ ) -- semantic domain newtype T_Nonterminal = T_Nonterminal { attach_T_Nonterminal :: Identity (T_Nonterminal_s14 ) } newtype T_Nonterminal_s14 = C_Nonterminal_s14 { inv_Nonterminal_s14 :: (T_Nonterminal_v13 ) } data T_Nonterminal_s15 = C_Nonterminal_s15 type T_Nonterminal_v13 = (T_Nonterminal_vIn13 ) -> (T_Nonterminal_vOut13 ) data T_Nonterminal_vIn13 = T_Nonterminal_vIn13 (Map Identifier Attributes) (Map Identifier Attributes) data T_Nonterminal_vOut13 = T_Nonterminal_vOut13 (Map Identifier Attributes) (Map Identifier Attributes) (VisageNonterminal) {-# NOINLINE sem_Nonterminal_Nonterminal #-} sem_Nonterminal_Nonterminal :: (NontermIdent) -> ([Identifier]) -> (Attributes) -> (Attributes) -> T_Productions -> T_Nonterminal sem_Nonterminal_Nonterminal arg_nt_ _ arg_inh_ arg_syn_ arg_prods_ = T_Nonterminal (return st14) where {-# NOINLINE st14 #-} st14 = let v13 :: T_Nonterminal_v13 v13 = \ (T_Nonterminal_vIn13 _lhsIinhMap _lhsIsynMap) -> ( let _prodsX29 = Control.Monad.Identity.runIdentity (attach_T_Productions (arg_prods_)) (T_Productions_vOut28 _prodsIvprods) = inv_Productions_s29 _prodsX29 (T_Productions_vIn28 _prodsOinhMap _prodsOsynMap) _lhsOinhMap' :: Map Identifier Attributes _lhsOinhMap' = rule17 arg_inh_ arg_nt_ _lhsOsynMap' :: Map Identifier Attributes _lhsOsynMap' = rule18 arg_nt_ arg_syn_ _lhsOvnont :: VisageNonterminal _lhsOvnont = rule19 _prodsIvprods arg_inh_ arg_nt_ arg_syn_ _prodsOinhMap = rule20 _lhsIinhMap _prodsOsynMap = rule21 _lhsIsynMap __result_ = T_Nonterminal_vOut13 _lhsOinhMap' _lhsOsynMap' _lhsOvnont in __result_ ) in C_Nonterminal_s14 v13 {-# INLINE rule17 #-} {-# LINE 7 "./src-ag/DistChildAttr.ag" #-} rule17 = \ inh_ nt_ -> {-# LINE 7 "./src-ag/DistChildAttr.ag" #-} Map.singleton nt_ inh_ {-# LINE 435 "dist/build/TfmToVisage.hs"#-} {-# INLINE rule18 #-} {-# LINE 8 "./src-ag/DistChildAttr.ag" #-} rule18 = \ nt_ syn_ -> {-# LINE 8 "./src-ag/DistChildAttr.ag" #-} Map.singleton nt_ syn_ {-# LINE 441 "dist/build/TfmToVisage.hs"#-} {-# INLINE rule19 #-} {-# LINE 100 "./src-ag/TfmToVisage.ag" #-} rule19 = \ ((_prodsIvprods) :: [VisageProduction]) inh_ nt_ syn_ -> {-# LINE 100 "./src-ag/TfmToVisage.ag" #-} VNonterminal nt_ inh_ syn_ _prodsIvprods {-# LINE 447 "dist/build/TfmToVisage.hs"#-} {-# INLINE rule20 #-} rule20 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule21 #-} rule21 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap -- Nonterminals ------------------------------------------------ -- wrapper data Inh_Nonterminals = Inh_Nonterminals { inhMap_Inh_Nonterminals :: (Map Identifier Attributes), synMap_Inh_Nonterminals :: (Map Identifier Attributes) } data Syn_Nonterminals = Syn_Nonterminals { inhMap'_Syn_Nonterminals :: (Map Identifier Attributes), synMap'_Syn_Nonterminals :: (Map Identifier Attributes), vnonts_Syn_Nonterminals :: ([VisageNonterminal]) } {-# INLINABLE wrap_Nonterminals #-} wrap_Nonterminals :: T_Nonterminals -> Inh_Nonterminals -> (Syn_Nonterminals ) wrap_Nonterminals (T_Nonterminals act) (Inh_Nonterminals _lhsIinhMap _lhsIsynMap) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Nonterminals_vIn16 _lhsIinhMap _lhsIsynMap (T_Nonterminals_vOut16 _lhsOinhMap' _lhsOsynMap' _lhsOvnonts) <- return (inv_Nonterminals_s17 sem arg) return (Syn_Nonterminals _lhsOinhMap' _lhsOsynMap' _lhsOvnonts) ) -- cata {-# NOINLINE sem_Nonterminals #-} sem_Nonterminals :: Nonterminals -> T_Nonterminals sem_Nonterminals list = Prelude.foldr sem_Nonterminals_Cons sem_Nonterminals_Nil (Prelude.map sem_Nonterminal list) -- semantic domain newtype T_Nonterminals = T_Nonterminals { attach_T_Nonterminals :: Identity (T_Nonterminals_s17 ) } newtype T_Nonterminals_s17 = C_Nonterminals_s17 { inv_Nonterminals_s17 :: (T_Nonterminals_v16 ) } data T_Nonterminals_s18 = C_Nonterminals_s18 type T_Nonterminals_v16 = (T_Nonterminals_vIn16 ) -> (T_Nonterminals_vOut16 ) data T_Nonterminals_vIn16 = T_Nonterminals_vIn16 (Map Identifier Attributes) (Map Identifier Attributes) data T_Nonterminals_vOut16 = T_Nonterminals_vOut16 (Map Identifier Attributes) (Map Identifier Attributes) ([VisageNonterminal]) {-# NOINLINE sem_Nonterminals_Cons #-} sem_Nonterminals_Cons :: T_Nonterminal -> T_Nonterminals -> T_Nonterminals sem_Nonterminals_Cons arg_hd_ arg_tl_ = T_Nonterminals (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_Nonterminals_v16 v16 = \ (T_Nonterminals_vIn16 _lhsIinhMap _lhsIsynMap) -> ( let _hdX14 = Control.Monad.Identity.runIdentity (attach_T_Nonterminal (arg_hd_)) _tlX17 = Control.Monad.Identity.runIdentity (attach_T_Nonterminals (arg_tl_)) (T_Nonterminal_vOut13 _hdIinhMap' _hdIsynMap' _hdIvnont) = inv_Nonterminal_s14 _hdX14 (T_Nonterminal_vIn13 _hdOinhMap _hdOsynMap) (T_Nonterminals_vOut16 _tlIinhMap' _tlIsynMap' _tlIvnonts) = inv_Nonterminals_s17 _tlX17 (T_Nonterminals_vIn16 _tlOinhMap _tlOsynMap) _lhsOvnonts :: [VisageNonterminal] _lhsOvnonts = rule22 _hdIvnont _tlIvnonts _lhsOinhMap' :: Map Identifier Attributes _lhsOinhMap' = rule23 _hdIinhMap' _tlIinhMap' _lhsOsynMap' :: Map Identifier Attributes _lhsOsynMap' = rule24 _hdIsynMap' _tlIsynMap' _hdOinhMap = rule25 _lhsIinhMap _hdOsynMap = rule26 _lhsIsynMap _tlOinhMap = rule27 _lhsIinhMap _tlOsynMap = rule28 _lhsIsynMap __result_ = T_Nonterminals_vOut16 _lhsOinhMap' _lhsOsynMap' _lhsOvnonts in __result_ ) in C_Nonterminals_s17 v16 {-# INLINE rule22 #-} {-# LINE 94 "./src-ag/TfmToVisage.ag" #-} rule22 = \ ((_hdIvnont) :: VisageNonterminal) ((_tlIvnonts) :: [VisageNonterminal]) -> {-# LINE 94 "./src-ag/TfmToVisage.ag" #-} _hdIvnont : _tlIvnonts {-# LINE 514 "dist/build/TfmToVisage.hs"#-} {-# INLINE rule23 #-} rule23 = \ ((_hdIinhMap') :: Map Identifier Attributes) ((_tlIinhMap') :: Map Identifier Attributes) -> _hdIinhMap' `Map.union` _tlIinhMap' {-# INLINE rule24 #-} rule24 = \ ((_hdIsynMap') :: Map Identifier Attributes) ((_tlIsynMap') :: Map Identifier Attributes) -> _hdIsynMap' `Map.union` _tlIsynMap' {-# INLINE rule25 #-} rule25 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule26 #-} rule26 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# INLINE rule27 #-} rule27 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule28 #-} rule28 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# NOINLINE sem_Nonterminals_Nil #-} sem_Nonterminals_Nil :: T_Nonterminals sem_Nonterminals_Nil = T_Nonterminals (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_Nonterminals_v16 v16 = \ (T_Nonterminals_vIn16 _lhsIinhMap _lhsIsynMap) -> ( let _lhsOvnonts :: [VisageNonterminal] _lhsOvnonts = rule29 () _lhsOinhMap' :: Map Identifier Attributes _lhsOinhMap' = rule30 () _lhsOsynMap' :: Map Identifier Attributes _lhsOsynMap' = rule31 () __result_ = T_Nonterminals_vOut16 _lhsOinhMap' _lhsOsynMap' _lhsOvnonts in __result_ ) in C_Nonterminals_s17 v16 {-# INLINE rule29 #-} {-# LINE 96 "./src-ag/TfmToVisage.ag" #-} rule29 = \ (_ :: ()) -> {-# LINE 96 "./src-ag/TfmToVisage.ag" #-} [] {-# LINE 554 "dist/build/TfmToVisage.hs"#-} {-# INLINE rule30 #-} rule30 = \ (_ :: ()) -> Map.empty {-# INLINE rule31 #-} rule31 = \ (_ :: ()) -> Map.empty -- Pattern ----------------------------------------------------- -- wrapper data Inh_Pattern = Inh_Pattern { } data Syn_Pattern = Syn_Pattern { copy_Syn_Pattern :: (Pattern), fieldattrs_Syn_Pattern :: ( [(Identifier,Identifier)] ), self_Syn_Pattern :: (Pattern), vpat_Syn_Pattern :: (VisagePattern) } {-# INLINABLE wrap_Pattern #-} wrap_Pattern :: T_Pattern -> Inh_Pattern -> (Syn_Pattern ) wrap_Pattern (T_Pattern act) (Inh_Pattern ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Pattern_vIn19 (T_Pattern_vOut19 _lhsOcopy _lhsOfieldattrs _lhsOself _lhsOvpat) <- return (inv_Pattern_s20 sem arg) return (Syn_Pattern _lhsOcopy _lhsOfieldattrs _lhsOself _lhsOvpat) ) -- cata {-# NOINLINE sem_Pattern #-} sem_Pattern :: Pattern -> T_Pattern sem_Pattern ( Constr name_ pats_ ) = sem_Pattern_Constr name_ ( sem_Patterns pats_ ) sem_Pattern ( Product pos_ pats_ ) = sem_Pattern_Product pos_ ( sem_Patterns pats_ ) sem_Pattern ( Alias field_ attr_ pat_ ) = sem_Pattern_Alias field_ attr_ ( sem_Pattern pat_ ) sem_Pattern ( Irrefutable pat_ ) = sem_Pattern_Irrefutable ( sem_Pattern pat_ ) sem_Pattern ( Underscore pos_ ) = sem_Pattern_Underscore pos_ -- semantic domain newtype T_Pattern = T_Pattern { attach_T_Pattern :: Identity (T_Pattern_s20 ) } newtype T_Pattern_s20 = C_Pattern_s20 { inv_Pattern_s20 :: (T_Pattern_v19 ) } data T_Pattern_s21 = C_Pattern_s21 type T_Pattern_v19 = (T_Pattern_vIn19 ) -> (T_Pattern_vOut19 ) data T_Pattern_vIn19 = T_Pattern_vIn19 data T_Pattern_vOut19 = T_Pattern_vOut19 (Pattern) ( [(Identifier,Identifier)] ) (Pattern) (VisagePattern) {-# NOINLINE sem_Pattern_Constr #-} sem_Pattern_Constr :: (ConstructorIdent) -> T_Patterns -> T_Pattern sem_Pattern_Constr arg_name_ arg_pats_ = T_Pattern (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_Pattern_v19 v19 = \ (T_Pattern_vIn19 ) -> ( let _patsX23 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) (T_Patterns_vOut22 _patsIcopy _patsIfieldattrs _patsIself _patsIvpats) = inv_Patterns_s23 _patsX23 (T_Patterns_vIn22 ) _lhsOvpat :: VisagePattern _lhsOvpat = rule32 _patsIvpats arg_name_ _lhsOfieldattrs :: [(Identifier,Identifier)] _lhsOfieldattrs = rule33 _patsIfieldattrs _copy = rule34 _patsIcopy arg_name_ _self = rule35 _patsIself arg_name_ _lhsOcopy :: Pattern _lhsOcopy = rule36 _copy _lhsOself :: Pattern _lhsOself = rule37 _self __result_ = T_Pattern_vOut19 _lhsOcopy _lhsOfieldattrs _lhsOself _lhsOvpat in __result_ ) in C_Pattern_s20 v19 {-# INLINE rule32 #-} {-# LINE 136 "./src-ag/TfmToVisage.ag" #-} rule32 = \ ((_patsIvpats) :: [VisagePattern]) name_ -> {-# LINE 136 "./src-ag/TfmToVisage.ag" #-} VConstr name_ _patsIvpats {-# LINE 623 "dist/build/TfmToVisage.hs"#-} {-# INLINE rule33 #-} rule33 = \ ((_patsIfieldattrs) :: [(Identifier,Identifier)] ) -> _patsIfieldattrs {-# INLINE rule34 #-} rule34 = \ ((_patsIcopy) :: Patterns) name_ -> Constr name_ _patsIcopy {-# INLINE rule35 #-} rule35 = \ ((_patsIself) :: Patterns) name_ -> Constr name_ _patsIself {-# INLINE rule36 #-} rule36 = \ _copy -> _copy {-# INLINE rule37 #-} rule37 = \ _self -> _self {-# NOINLINE sem_Pattern_Product #-} sem_Pattern_Product :: (Pos) -> T_Patterns -> T_Pattern sem_Pattern_Product arg_pos_ arg_pats_ = T_Pattern (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_Pattern_v19 v19 = \ (T_Pattern_vIn19 ) -> ( let _patsX23 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) (T_Patterns_vOut22 _patsIcopy _patsIfieldattrs _patsIself _patsIvpats) = inv_Patterns_s23 _patsX23 (T_Patterns_vIn22 ) _lhsOvpat :: VisagePattern _lhsOvpat = rule38 _patsIvpats arg_pos_ _lhsOfieldattrs :: [(Identifier,Identifier)] _lhsOfieldattrs = rule39 _patsIfieldattrs _copy = rule40 _patsIcopy arg_pos_ _self = rule41 _patsIself arg_pos_ _lhsOcopy :: Pattern _lhsOcopy = rule42 _copy _lhsOself :: Pattern _lhsOself = rule43 _self __result_ = T_Pattern_vOut19 _lhsOcopy _lhsOfieldattrs _lhsOself _lhsOvpat in __result_ ) in C_Pattern_s20 v19 {-# INLINE rule38 #-} {-# LINE 137 "./src-ag/TfmToVisage.ag" #-} rule38 = \ ((_patsIvpats) :: [VisagePattern]) pos_ -> {-# LINE 137 "./src-ag/TfmToVisage.ag" #-} VProduct pos_ _patsIvpats {-# LINE 666 "dist/build/TfmToVisage.hs"#-} {-# INLINE rule39 #-} rule39 = \ ((_patsIfieldattrs) :: [(Identifier,Identifier)] ) -> _patsIfieldattrs {-# INLINE rule40 #-} rule40 = \ ((_patsIcopy) :: Patterns) pos_ -> Product pos_ _patsIcopy {-# INLINE rule41 #-} rule41 = \ ((_patsIself) :: Patterns) pos_ -> Product pos_ _patsIself {-# INLINE rule42 #-} rule42 = \ _copy -> _copy {-# INLINE rule43 #-} rule43 = \ _self -> _self {-# NOINLINE sem_Pattern_Alias #-} sem_Pattern_Alias :: (Identifier) -> (Identifier) -> T_Pattern -> T_Pattern sem_Pattern_Alias arg_field_ arg_attr_ arg_pat_ = T_Pattern (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_Pattern_v19 v19 = \ (T_Pattern_vIn19 ) -> ( let _patX20 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) (T_Pattern_vOut19 _patIcopy _patIfieldattrs _patIself _patIvpat) = inv_Pattern_s20 _patX20 (T_Pattern_vIn19 ) _lhsOvpat :: VisagePattern _lhsOvpat = rule44 _patIvpat _self arg_attr_ arg_field_ _lhsOfieldattrs :: [(Identifier,Identifier)] _lhsOfieldattrs = rule45 arg_attr_ arg_field_ _copy = rule46 _patIcopy arg_attr_ arg_field_ _self = rule47 _patIself arg_attr_ arg_field_ _lhsOcopy :: Pattern _lhsOcopy = rule48 _copy _lhsOself :: Pattern _lhsOself = rule49 _self __result_ = T_Pattern_vOut19 _lhsOcopy _lhsOfieldattrs _lhsOself _lhsOvpat in __result_ ) in C_Pattern_s20 v19 {-# INLINE rule44 #-} {-# LINE 138 "./src-ag/TfmToVisage.ag" #-} rule44 = \ ((_patIvpat) :: VisagePattern) _self attr_ field_ -> {-# LINE 138 "./src-ag/TfmToVisage.ag" #-} if (isVar _self) then VVar field_ attr_ else VAlias field_ attr_ _patIvpat {-# LINE 711 "dist/build/TfmToVisage.hs"#-} {-# INLINE rule45 #-} {-# LINE 147 "./src-ag/TfmToVisage.ag" #-} rule45 = \ attr_ field_ -> {-# LINE 147 "./src-ag/TfmToVisage.ag" #-} [(field_, attr_)] {-# LINE 717 "dist/build/TfmToVisage.hs"#-} {-# INLINE rule46 #-} rule46 = \ ((_patIcopy) :: Pattern) attr_ field_ -> Alias field_ attr_ _patIcopy {-# INLINE rule47 #-} rule47 = \ ((_patIself) :: Pattern) attr_ field_ -> Alias field_ attr_ _patIself {-# INLINE rule48 #-} rule48 = \ _copy -> _copy {-# INLINE rule49 #-} rule49 = \ _self -> _self {-# NOINLINE sem_Pattern_Irrefutable #-} sem_Pattern_Irrefutable :: T_Pattern -> T_Pattern sem_Pattern_Irrefutable arg_pat_ = T_Pattern (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_Pattern_v19 v19 = \ (T_Pattern_vIn19 ) -> ( let _patX20 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) (T_Pattern_vOut19 _patIcopy _patIfieldattrs _patIself _patIvpat) = inv_Pattern_s20 _patX20 (T_Pattern_vIn19 ) _lhsOfieldattrs :: [(Identifier,Identifier)] _lhsOfieldattrs = rule50 _patIfieldattrs _copy = rule51 _patIcopy _self = rule52 _patIself _lhsOcopy :: Pattern _lhsOcopy = rule53 _copy _lhsOself :: Pattern _lhsOself = rule54 _self _lhsOvpat :: VisagePattern _lhsOvpat = rule55 _patIvpat __result_ = T_Pattern_vOut19 _lhsOcopy _lhsOfieldattrs _lhsOself _lhsOvpat in __result_ ) in C_Pattern_s20 v19 {-# INLINE rule50 #-} rule50 = \ ((_patIfieldattrs) :: [(Identifier,Identifier)] ) -> _patIfieldattrs {-# INLINE rule51 #-} rule51 = \ ((_patIcopy) :: Pattern) -> Irrefutable _patIcopy {-# INLINE rule52 #-} rule52 = \ ((_patIself) :: Pattern) -> Irrefutable _patIself {-# INLINE rule53 #-} rule53 = \ _copy -> _copy {-# INLINE rule54 #-} rule54 = \ _self -> _self {-# INLINE rule55 #-} rule55 = \ ((_patIvpat) :: VisagePattern) -> _patIvpat {-# NOINLINE sem_Pattern_Underscore #-} sem_Pattern_Underscore :: (Pos) -> T_Pattern sem_Pattern_Underscore arg_pos_ = T_Pattern (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_Pattern_v19 v19 = \ (T_Pattern_vIn19 ) -> ( let _lhsOvpat :: VisagePattern _lhsOvpat = rule56 arg_pos_ _lhsOfieldattrs :: [(Identifier,Identifier)] _lhsOfieldattrs = rule57 () _copy = rule58 arg_pos_ _self = rule59 arg_pos_ _lhsOcopy :: Pattern _lhsOcopy = rule60 _copy _lhsOself :: Pattern _lhsOself = rule61 _self __result_ = T_Pattern_vOut19 _lhsOcopy _lhsOfieldattrs _lhsOself _lhsOvpat in __result_ ) in C_Pattern_s20 v19 {-# INLINE rule56 #-} {-# LINE 141 "./src-ag/TfmToVisage.ag" #-} rule56 = \ pos_ -> {-# LINE 141 "./src-ag/TfmToVisage.ag" #-} VUnderscore pos_ {-# LINE 795 "dist/build/TfmToVisage.hs"#-} {-# INLINE rule57 #-} rule57 = \ (_ :: ()) -> [] {-# INLINE rule58 #-} rule58 = \ pos_ -> Underscore pos_ {-# INLINE rule59 #-} rule59 = \ pos_ -> Underscore pos_ {-# INLINE rule60 #-} rule60 = \ _copy -> _copy {-# INLINE rule61 #-} rule61 = \ _self -> _self -- Patterns ---------------------------------------------------- -- wrapper data Inh_Patterns = Inh_Patterns { } data Syn_Patterns = Syn_Patterns { copy_Syn_Patterns :: (Patterns), fieldattrs_Syn_Patterns :: ( [(Identifier,Identifier)] ), self_Syn_Patterns :: (Patterns), vpats_Syn_Patterns :: ([VisagePattern]) } {-# INLINABLE wrap_Patterns #-} wrap_Patterns :: T_Patterns -> Inh_Patterns -> (Syn_Patterns ) wrap_Patterns (T_Patterns act) (Inh_Patterns ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Patterns_vIn22 (T_Patterns_vOut22 _lhsOcopy _lhsOfieldattrs _lhsOself _lhsOvpats) <- return (inv_Patterns_s23 sem arg) return (Syn_Patterns _lhsOcopy _lhsOfieldattrs _lhsOself _lhsOvpats) ) -- cata {-# NOINLINE sem_Patterns #-} sem_Patterns :: Patterns -> T_Patterns sem_Patterns list = Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list) -- semantic domain newtype T_Patterns = T_Patterns { attach_T_Patterns :: Identity (T_Patterns_s23 ) } newtype T_Patterns_s23 = C_Patterns_s23 { inv_Patterns_s23 :: (T_Patterns_v22 ) } data T_Patterns_s24 = C_Patterns_s24 type T_Patterns_v22 = (T_Patterns_vIn22 ) -> (T_Patterns_vOut22 ) data T_Patterns_vIn22 = T_Patterns_vIn22 data T_Patterns_vOut22 = T_Patterns_vOut22 (Patterns) ( [(Identifier,Identifier)] ) (Patterns) ([VisagePattern]) {-# NOINLINE sem_Patterns_Cons #-} sem_Patterns_Cons :: T_Pattern -> T_Patterns -> T_Patterns sem_Patterns_Cons arg_hd_ arg_tl_ = T_Patterns (return st23) where {-# NOINLINE st23 #-} st23 = let v22 :: T_Patterns_v22 v22 = \ (T_Patterns_vIn22 ) -> ( let _hdX20 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_hd_)) _tlX23 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_tl_)) (T_Pattern_vOut19 _hdIcopy _hdIfieldattrs _hdIself _hdIvpat) = inv_Pattern_s20 _hdX20 (T_Pattern_vIn19 ) (T_Patterns_vOut22 _tlIcopy _tlIfieldattrs _tlIself _tlIvpats) = inv_Patterns_s23 _tlX23 (T_Patterns_vIn22 ) _lhsOvpats :: [VisagePattern] _lhsOvpats = rule62 _hdIvpat _tlIvpats _lhsOfieldattrs :: [(Identifier,Identifier)] _lhsOfieldattrs = rule63 _hdIfieldattrs _tlIfieldattrs _copy = rule64 _hdIcopy _tlIcopy _self = rule65 _hdIself _tlIself _lhsOcopy :: Patterns _lhsOcopy = rule66 _copy _lhsOself :: Patterns _lhsOself = rule67 _self __result_ = T_Patterns_vOut22 _lhsOcopy _lhsOfieldattrs _lhsOself _lhsOvpats in __result_ ) in C_Patterns_s23 v22 {-# INLINE rule62 #-} {-# LINE 132 "./src-ag/TfmToVisage.ag" #-} rule62 = \ ((_hdIvpat) :: VisagePattern) ((_tlIvpats) :: [VisagePattern]) -> {-# LINE 132 "./src-ag/TfmToVisage.ag" #-} _hdIvpat : _tlIvpats {-# LINE 871 "dist/build/TfmToVisage.hs"#-} {-# INLINE rule63 #-} rule63 = \ ((_hdIfieldattrs) :: [(Identifier,Identifier)] ) ((_tlIfieldattrs) :: [(Identifier,Identifier)] ) -> _hdIfieldattrs ++ _tlIfieldattrs {-# INLINE rule64 #-} rule64 = \ ((_hdIcopy) :: Pattern) ((_tlIcopy) :: Patterns) -> (:) _hdIcopy _tlIcopy {-# INLINE rule65 #-} rule65 = \ ((_hdIself) :: Pattern) ((_tlIself) :: Patterns) -> (:) _hdIself _tlIself {-# INLINE rule66 #-} rule66 = \ _copy -> _copy {-# INLINE rule67 #-} rule67 = \ _self -> _self {-# NOINLINE sem_Patterns_Nil #-} sem_Patterns_Nil :: T_Patterns sem_Patterns_Nil = T_Patterns (return st23) where {-# NOINLINE st23 #-} st23 = let v22 :: T_Patterns_v22 v22 = \ (T_Patterns_vIn22 ) -> ( let _lhsOvpats :: [VisagePattern] _lhsOvpats = rule68 () _lhsOfieldattrs :: [(Identifier,Identifier)] _lhsOfieldattrs = rule69 () _copy = rule70 () _self = rule71 () _lhsOcopy :: Patterns _lhsOcopy = rule72 _copy _lhsOself :: Patterns _lhsOself = rule73 _self __result_ = T_Patterns_vOut22 _lhsOcopy _lhsOfieldattrs _lhsOself _lhsOvpats in __result_ ) in C_Patterns_s23 v22 {-# INLINE rule68 #-} {-# LINE 133 "./src-ag/TfmToVisage.ag" #-} rule68 = \ (_ :: ()) -> {-# LINE 133 "./src-ag/TfmToVisage.ag" #-} [] {-# LINE 912 "dist/build/TfmToVisage.hs"#-} {-# INLINE rule69 #-} rule69 = \ (_ :: ()) -> [] {-# INLINE rule70 #-} rule70 = \ (_ :: ()) -> [] {-# INLINE rule71 #-} rule71 = \ (_ :: ()) -> [] {-# INLINE rule72 #-} rule72 = \ _copy -> _copy {-# INLINE rule73 #-} rule73 = \ _self -> _self -- Production -------------------------------------------------- -- wrapper data Inh_Production = Inh_Production { inhMap_Inh_Production :: (Map Identifier Attributes), synMap_Inh_Production :: (Map Identifier Attributes) } data Syn_Production = Syn_Production { vprod_Syn_Production :: (VisageProduction) } {-# INLINABLE wrap_Production #-} wrap_Production :: T_Production -> Inh_Production -> (Syn_Production ) wrap_Production (T_Production act) (Inh_Production _lhsIinhMap _lhsIsynMap) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Production_vIn25 _lhsIinhMap _lhsIsynMap (T_Production_vOut25 _lhsOvprod) <- return (inv_Production_s26 sem arg) return (Syn_Production _lhsOvprod) ) -- cata {-# INLINE sem_Production #-} sem_Production :: Production -> T_Production sem_Production ( Production con_ params_ constraints_ children_ rules_ typeSigs_ macro_ ) = sem_Production_Production con_ params_ constraints_ ( sem_Children children_ ) ( sem_Rules rules_ ) ( sem_TypeSigs typeSigs_ ) macro_ -- semantic domain newtype T_Production = T_Production { attach_T_Production :: Identity (T_Production_s26 ) } newtype T_Production_s26 = C_Production_s26 { inv_Production_s26 :: (T_Production_v25 ) } data T_Production_s27 = C_Production_s27 type T_Production_v25 = (T_Production_vIn25 ) -> (T_Production_vOut25 ) data T_Production_vIn25 = T_Production_vIn25 (Map Identifier Attributes) (Map Identifier Attributes) data T_Production_vOut25 = T_Production_vOut25 (VisageProduction) {-# NOINLINE sem_Production_Production #-} sem_Production_Production :: (ConstructorIdent) -> ([Identifier]) -> ([Type]) -> T_Children -> T_Rules -> T_TypeSigs -> (MaybeMacro) -> T_Production sem_Production_Production arg_con_ _ _ arg_children_ arg_rules_ arg_typeSigs_ _ = T_Production (return st26) where {-# NOINLINE st26 #-} st26 = let v25 :: T_Production_v25 v25 = \ (T_Production_vIn25 _lhsIinhMap _lhsIsynMap) -> ( let _childrenX5 = Control.Monad.Identity.runIdentity (attach_T_Children (arg_children_)) _rulesX35 = Control.Monad.Identity.runIdentity (attach_T_Rules (arg_rules_)) _typeSigsX41 = Control.Monad.Identity.runIdentity (attach_T_TypeSigs (arg_typeSigs_)) (T_Children_vOut4 _childrenIvchildren) = inv_Children_s5 _childrenX5 (T_Children_vIn4 _childrenOinhMap _childrenOrulemap _childrenOsynMap) (T_Rules_vOut34 _rulesIvrules) = inv_Rules_s35 _rulesX35 (T_Rules_vIn34 ) (T_TypeSigs_vOut40 ) = inv_TypeSigs_s41 _typeSigsX41 (T_TypeSigs_vIn40 ) _lhsOvprod :: VisageProduction _lhsOvprod = rule74 _childrenIvchildren _lhsrules _locrules arg_con_ _splitVRules = rule75 _rulesIvrules _locrules = rule76 _splitVRules _lhsrules = rule77 _splitVRules _childrenOrulemap = rule78 _splitVRules _childrenOinhMap = rule79 _lhsIinhMap _childrenOsynMap = rule80 _lhsIsynMap __result_ = T_Production_vOut25 _lhsOvprod in __result_ ) in C_Production_s26 v25 {-# INLINE rule74 #-} {-# LINE 110 "./src-ag/TfmToVisage.ag" #-} rule74 = \ ((_childrenIvchildren) :: [VisageChild]) _lhsrules _locrules con_ -> {-# LINE 110 "./src-ag/TfmToVisage.ag" #-} VProduction con_ _childrenIvchildren _lhsrules _locrules {-# LINE 988 "dist/build/TfmToVisage.hs"#-} {-# INLINE rule75 #-} {-# LINE 111 "./src-ag/TfmToVisage.ag" #-} rule75 = \ ((_rulesIvrules) :: [VisageRule]) -> {-# LINE 111 "./src-ag/TfmToVisage.ag" #-} splitVRules _rulesIvrules {-# LINE 994 "dist/build/TfmToVisage.hs"#-} {-# INLINE rule76 #-} {-# LINE 112 "./src-ag/TfmToVisage.ag" #-} rule76 = \ _splitVRules -> {-# LINE 112 "./src-ag/TfmToVisage.ag" #-} getForField "loc" _splitVRules {-# LINE 1000 "dist/build/TfmToVisage.hs"#-} {-# INLINE rule77 #-} {-# LINE 113 "./src-ag/TfmToVisage.ag" #-} rule77 = \ _splitVRules -> {-# LINE 113 "./src-ag/TfmToVisage.ag" #-} getForField "lhs" _splitVRules {-# LINE 1006 "dist/build/TfmToVisage.hs"#-} {-# INLINE rule78 #-} {-# LINE 114 "./src-ag/TfmToVisage.ag" #-} rule78 = \ _splitVRules -> {-# LINE 114 "./src-ag/TfmToVisage.ag" #-} _splitVRules {-# LINE 1012 "dist/build/TfmToVisage.hs"#-} {-# INLINE rule79 #-} rule79 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule80 #-} rule80 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap -- Productions ------------------------------------------------- -- wrapper data Inh_Productions = Inh_Productions { inhMap_Inh_Productions :: (Map Identifier Attributes), synMap_Inh_Productions :: (Map Identifier Attributes) } data Syn_Productions = Syn_Productions { vprods_Syn_Productions :: ([VisageProduction]) } {-# INLINABLE wrap_Productions #-} wrap_Productions :: T_Productions -> Inh_Productions -> (Syn_Productions ) wrap_Productions (T_Productions act) (Inh_Productions _lhsIinhMap _lhsIsynMap) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Productions_vIn28 _lhsIinhMap _lhsIsynMap (T_Productions_vOut28 _lhsOvprods) <- return (inv_Productions_s29 sem arg) return (Syn_Productions _lhsOvprods) ) -- cata {-# NOINLINE sem_Productions #-} sem_Productions :: Productions -> T_Productions sem_Productions list = Prelude.foldr sem_Productions_Cons sem_Productions_Nil (Prelude.map sem_Production list) -- semantic domain newtype T_Productions = T_Productions { attach_T_Productions :: Identity (T_Productions_s29 ) } newtype T_Productions_s29 = C_Productions_s29 { inv_Productions_s29 :: (T_Productions_v28 ) } data T_Productions_s30 = C_Productions_s30 type T_Productions_v28 = (T_Productions_vIn28 ) -> (T_Productions_vOut28 ) data T_Productions_vIn28 = T_Productions_vIn28 (Map Identifier Attributes) (Map Identifier Attributes) data T_Productions_vOut28 = T_Productions_vOut28 ([VisageProduction]) {-# NOINLINE sem_Productions_Cons #-} sem_Productions_Cons :: T_Production -> T_Productions -> T_Productions sem_Productions_Cons arg_hd_ arg_tl_ = T_Productions (return st29) where {-# NOINLINE st29 #-} st29 = let v28 :: T_Productions_v28 v28 = \ (T_Productions_vIn28 _lhsIinhMap _lhsIsynMap) -> ( let _hdX26 = Control.Monad.Identity.runIdentity (attach_T_Production (arg_hd_)) _tlX29 = Control.Monad.Identity.runIdentity (attach_T_Productions (arg_tl_)) (T_Production_vOut25 _hdIvprod) = inv_Production_s26 _hdX26 (T_Production_vIn25 _hdOinhMap _hdOsynMap) (T_Productions_vOut28 _tlIvprods) = inv_Productions_s29 _tlX29 (T_Productions_vIn28 _tlOinhMap _tlOsynMap) _lhsOvprods :: [VisageProduction] _lhsOvprods = rule81 _hdIvprod _tlIvprods _hdOinhMap = rule82 _lhsIinhMap _hdOsynMap = rule83 _lhsIsynMap _tlOinhMap = rule84 _lhsIinhMap _tlOsynMap = rule85 _lhsIsynMap __result_ = T_Productions_vOut28 _lhsOvprods in __result_ ) in C_Productions_s29 v28 {-# INLINE rule81 #-} {-# LINE 104 "./src-ag/TfmToVisage.ag" #-} rule81 = \ ((_hdIvprod) :: VisageProduction) ((_tlIvprods) :: [VisageProduction]) -> {-# LINE 104 "./src-ag/TfmToVisage.ag" #-} _hdIvprod : _tlIvprods {-# LINE 1075 "dist/build/TfmToVisage.hs"#-} {-# INLINE rule82 #-} rule82 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule83 #-} rule83 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# INLINE rule84 #-} rule84 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> _lhsIinhMap {-# INLINE rule85 #-} rule85 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> _lhsIsynMap {-# NOINLINE sem_Productions_Nil #-} sem_Productions_Nil :: T_Productions sem_Productions_Nil = T_Productions (return st29) where {-# NOINLINE st29 #-} st29 = let v28 :: T_Productions_v28 v28 = \ (T_Productions_vIn28 _lhsIinhMap _lhsIsynMap) -> ( let _lhsOvprods :: [VisageProduction] _lhsOvprods = rule86 () __result_ = T_Productions_vOut28 _lhsOvprods in __result_ ) in C_Productions_s29 v28 {-# INLINE rule86 #-} {-# LINE 106 "./src-ag/TfmToVisage.ag" #-} rule86 = \ (_ :: ()) -> {-# LINE 106 "./src-ag/TfmToVisage.ag" #-} [] {-# LINE 1105 "dist/build/TfmToVisage.hs"#-} -- Rule -------------------------------------------------------- -- wrapper data Inh_Rule = Inh_Rule { } data Syn_Rule = Syn_Rule { vrule_Syn_Rule :: (VisageRule) } {-# INLINABLE wrap_Rule #-} wrap_Rule :: T_Rule -> Inh_Rule -> (Syn_Rule ) wrap_Rule (T_Rule act) (Inh_Rule ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Rule_vIn31 (T_Rule_vOut31 _lhsOvrule) <- return (inv_Rule_s32 sem arg) return (Syn_Rule _lhsOvrule) ) -- cata {-# INLINE sem_Rule #-} sem_Rule :: Rule -> T_Rule sem_Rule ( Rule mbName_ pattern_ rhs_ owrt_ origin_ explicit_ pure_ identity_ mbError_ eager_ ) = sem_Rule_Rule mbName_ ( sem_Pattern pattern_ ) ( sem_Expression rhs_ ) owrt_ origin_ explicit_ pure_ identity_ mbError_ eager_ -- semantic domain newtype T_Rule = T_Rule { attach_T_Rule :: Identity (T_Rule_s32 ) } newtype T_Rule_s32 = C_Rule_s32 { inv_Rule_s32 :: (T_Rule_v31 ) } data T_Rule_s33 = C_Rule_s33 type T_Rule_v31 = (T_Rule_vIn31 ) -> (T_Rule_vOut31 ) data T_Rule_vIn31 = T_Rule_vIn31 data T_Rule_vOut31 = T_Rule_vOut31 (VisageRule) {-# NOINLINE sem_Rule_Rule #-} sem_Rule_Rule :: (Maybe Identifier) -> T_Pattern -> T_Expression -> (Bool) -> (String) -> (Bool) -> (Bool) -> (Bool) -> (Maybe Error) -> (Bool) -> T_Rule sem_Rule_Rule _ arg_pattern_ arg_rhs_ arg_owrt_ _ _ _ _ _ _ = T_Rule (return st32) where {-# NOINLINE st32 #-} st32 = let v31 :: T_Rule_v31 v31 = \ (T_Rule_vIn31 ) -> ( let _patternX20 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pattern_)) _rhsX8 = Control.Monad.Identity.runIdentity (attach_T_Expression (arg_rhs_)) (T_Pattern_vOut19 _patternIcopy _patternIfieldattrs _patternIself _patternIvpat) = inv_Pattern_s20 _patternX20 (T_Pattern_vIn19 ) (T_Expression_vOut7 _rhsIself) = inv_Expression_s8 _rhsX8 (T_Expression_vIn7 ) _lhsOvrule :: VisageRule _lhsOvrule = rule87 _patternIfieldattrs _patternIvpat _rhsIself arg_owrt_ __result_ = T_Rule_vOut31 _lhsOvrule in __result_ ) in C_Rule_s32 v31 {-# INLINE rule87 #-} {-# LINE 129 "./src-ag/TfmToVisage.ag" #-} rule87 = \ ((_patternIfieldattrs) :: [(Identifier,Identifier)] ) ((_patternIvpat) :: VisagePattern) ((_rhsIself) :: Expression) owrt_ -> {-# LINE 129 "./src-ag/TfmToVisage.ag" #-} VRule _patternIfieldattrs undefined _patternIvpat _rhsIself owrt_ {-# LINE 1158 "dist/build/TfmToVisage.hs"#-} -- Rules ------------------------------------------------------- -- wrapper data Inh_Rules = Inh_Rules { } data Syn_Rules = Syn_Rules { vrules_Syn_Rules :: ([VisageRule]) } {-# INLINABLE wrap_Rules #-} wrap_Rules :: T_Rules -> Inh_Rules -> (Syn_Rules ) wrap_Rules (T_Rules act) (Inh_Rules ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Rules_vIn34 (T_Rules_vOut34 _lhsOvrules) <- return (inv_Rules_s35 sem arg) return (Syn_Rules _lhsOvrules) ) -- cata {-# NOINLINE sem_Rules #-} sem_Rules :: Rules -> T_Rules sem_Rules list = Prelude.foldr sem_Rules_Cons sem_Rules_Nil (Prelude.map sem_Rule list) -- semantic domain newtype T_Rules = T_Rules { attach_T_Rules :: Identity (T_Rules_s35 ) } newtype T_Rules_s35 = C_Rules_s35 { inv_Rules_s35 :: (T_Rules_v34 ) } data T_Rules_s36 = C_Rules_s36 type T_Rules_v34 = (T_Rules_vIn34 ) -> (T_Rules_vOut34 ) data T_Rules_vIn34 = T_Rules_vIn34 data T_Rules_vOut34 = T_Rules_vOut34 ([VisageRule]) {-# NOINLINE sem_Rules_Cons #-} sem_Rules_Cons :: T_Rule -> T_Rules -> T_Rules sem_Rules_Cons arg_hd_ arg_tl_ = T_Rules (return st35) where {-# NOINLINE st35 #-} st35 = let v34 :: T_Rules_v34 v34 = \ (T_Rules_vIn34 ) -> ( let _hdX32 = Control.Monad.Identity.runIdentity (attach_T_Rule (arg_hd_)) _tlX35 = Control.Monad.Identity.runIdentity (attach_T_Rules (arg_tl_)) (T_Rule_vOut31 _hdIvrule) = inv_Rule_s32 _hdX32 (T_Rule_vIn31 ) (T_Rules_vOut34 _tlIvrules) = inv_Rules_s35 _tlX35 (T_Rules_vIn34 ) _lhsOvrules :: [VisageRule] _lhsOvrules = rule88 _hdIvrule _tlIvrules __result_ = T_Rules_vOut34 _lhsOvrules in __result_ ) in C_Rules_s35 v34 {-# INLINE rule88 #-} {-# LINE 124 "./src-ag/TfmToVisage.ag" #-} rule88 = \ ((_hdIvrule) :: VisageRule) ((_tlIvrules) :: [VisageRule]) -> {-# LINE 124 "./src-ag/TfmToVisage.ag" #-} _hdIvrule : _tlIvrules {-# LINE 1211 "dist/build/TfmToVisage.hs"#-} {-# NOINLINE sem_Rules_Nil #-} sem_Rules_Nil :: T_Rules sem_Rules_Nil = T_Rules (return st35) where {-# NOINLINE st35 #-} st35 = let v34 :: T_Rules_v34 v34 = \ (T_Rules_vIn34 ) -> ( let _lhsOvrules :: [VisageRule] _lhsOvrules = rule89 () __result_ = T_Rules_vOut34 _lhsOvrules in __result_ ) in C_Rules_s35 v34 {-# INLINE rule89 #-} {-# LINE 125 "./src-ag/TfmToVisage.ag" #-} rule89 = \ (_ :: ()) -> {-# LINE 125 "./src-ag/TfmToVisage.ag" #-} [] {-# LINE 1229 "dist/build/TfmToVisage.hs"#-} -- TypeSig ----------------------------------------------------- -- wrapper data Inh_TypeSig = Inh_TypeSig { } data Syn_TypeSig = Syn_TypeSig { } {-# INLINABLE wrap_TypeSig #-} wrap_TypeSig :: T_TypeSig -> Inh_TypeSig -> (Syn_TypeSig ) wrap_TypeSig (T_TypeSig act) (Inh_TypeSig ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_TypeSig_vIn37 (T_TypeSig_vOut37 ) <- return (inv_TypeSig_s38 sem arg) return (Syn_TypeSig ) ) -- cata {-# INLINE sem_TypeSig #-} sem_TypeSig :: TypeSig -> T_TypeSig sem_TypeSig ( TypeSig name_ tp_ ) = sem_TypeSig_TypeSig name_ tp_ -- semantic domain newtype T_TypeSig = T_TypeSig { attach_T_TypeSig :: Identity (T_TypeSig_s38 ) } newtype T_TypeSig_s38 = C_TypeSig_s38 { inv_TypeSig_s38 :: (T_TypeSig_v37 ) } data T_TypeSig_s39 = C_TypeSig_s39 type T_TypeSig_v37 = (T_TypeSig_vIn37 ) -> (T_TypeSig_vOut37 ) data T_TypeSig_vIn37 = T_TypeSig_vIn37 data T_TypeSig_vOut37 = T_TypeSig_vOut37 {-# NOINLINE sem_TypeSig_TypeSig #-} sem_TypeSig_TypeSig :: (Identifier) -> (Type) -> T_TypeSig sem_TypeSig_TypeSig _ _ = T_TypeSig (return st38) where {-# NOINLINE st38 #-} st38 = let v37 :: T_TypeSig_v37 v37 = \ (T_TypeSig_vIn37 ) -> ( let __result_ = T_TypeSig_vOut37 in __result_ ) in C_TypeSig_s38 v37 -- TypeSigs ---------------------------------------------------- -- wrapper data Inh_TypeSigs = Inh_TypeSigs { } data Syn_TypeSigs = Syn_TypeSigs { } {-# INLINABLE wrap_TypeSigs #-} wrap_TypeSigs :: T_TypeSigs -> Inh_TypeSigs -> (Syn_TypeSigs ) wrap_TypeSigs (T_TypeSigs act) (Inh_TypeSigs ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_TypeSigs_vIn40 (T_TypeSigs_vOut40 ) <- return (inv_TypeSigs_s41 sem arg) return (Syn_TypeSigs ) ) -- cata {-# NOINLINE sem_TypeSigs #-} sem_TypeSigs :: TypeSigs -> T_TypeSigs sem_TypeSigs list = Prelude.foldr sem_TypeSigs_Cons sem_TypeSigs_Nil (Prelude.map sem_TypeSig list) -- semantic domain newtype T_TypeSigs = T_TypeSigs { attach_T_TypeSigs :: Identity (T_TypeSigs_s41 ) } newtype T_TypeSigs_s41 = C_TypeSigs_s41 { inv_TypeSigs_s41 :: (T_TypeSigs_v40 ) } data T_TypeSigs_s42 = C_TypeSigs_s42 type T_TypeSigs_v40 = (T_TypeSigs_vIn40 ) -> (T_TypeSigs_vOut40 ) data T_TypeSigs_vIn40 = T_TypeSigs_vIn40 data T_TypeSigs_vOut40 = T_TypeSigs_vOut40 {-# NOINLINE sem_TypeSigs_Cons #-} sem_TypeSigs_Cons :: T_TypeSig -> T_TypeSigs -> T_TypeSigs sem_TypeSigs_Cons arg_hd_ arg_tl_ = T_TypeSigs (return st41) where {-# NOINLINE st41 #-} st41 = let v40 :: T_TypeSigs_v40 v40 = \ (T_TypeSigs_vIn40 ) -> ( let _hdX38 = Control.Monad.Identity.runIdentity (attach_T_TypeSig (arg_hd_)) _tlX41 = Control.Monad.Identity.runIdentity (attach_T_TypeSigs (arg_tl_)) (T_TypeSig_vOut37 ) = inv_TypeSig_s38 _hdX38 (T_TypeSig_vIn37 ) (T_TypeSigs_vOut40 ) = inv_TypeSigs_s41 _tlX41 (T_TypeSigs_vIn40 ) __result_ = T_TypeSigs_vOut40 in __result_ ) in C_TypeSigs_s41 v40 {-# NOINLINE sem_TypeSigs_Nil #-} sem_TypeSigs_Nil :: T_TypeSigs sem_TypeSigs_Nil = T_TypeSigs (return st41) where {-# NOINLINE st41 #-} st41 = let v40 :: T_TypeSigs_v40 v40 = \ (T_TypeSigs_vIn40 ) -> ( let __result_ = T_TypeSigs_vOut40 in __result_ ) in C_TypeSigs_s41 v40 uuagc-0.9.42.3/src-generated/Transform.hs000644 000765 000024 00001201267 12127045231 022111 0ustar00jeroenbransenstaff000000 000000 {-# LANGUAGE Rank2Types, GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} module Transform where {-# LINE 2 "./src-ag/ConcreteSyntax.ag" #-} import UU.Scanner.Position (Pos) import Patterns (Pattern) import Expression (Expression) import CommonTypes import Macro --marcos {-# LINE 13 "dist/build/Transform.hs" #-} {-# LINE 2 "./src-ag/Patterns.ag" #-} -- Patterns.ag imports import UU.Scanner.Position(Pos) import CommonTypes (ConstructorIdent,Identifier) {-# LINE 20 "dist/build/Transform.hs" #-} {-# LINE 8 "./src-ag/Transform.ag" #-} 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 {-# LINE 43 "dist/build/Transform.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 104 "./src-ag/Transform.ag" #-} type DefinedSets = Map Identifier (Set NontermIdent) {-# LINE 48 "dist/build/Transform.hs" #-} {-# LINE 124 "./src-ag/Transform.ag" #-} type FieldMap = [(Identifier, Type)] {-# LINE 52 "dist/build/Transform.hs" #-} {-# LINE 125 "./src-ag/Transform.ag" #-} type DataTypes = Map.Map NontermIdent (Map.Map ConstructorIdent FieldMap) {-# LINE 56 "dist/build/Transform.hs" #-} {-# LINE 148 "./src-ag/Transform.ag" #-} type AttrName = (Identifier,Identifier) {-# LINE 60 "dist/build/Transform.hs" #-} {-# LINE 149 "./src-ag/Transform.ag" #-} type RuleInfo = (Maybe Identifier, [AttrName]->Pattern, Expression, [AttrName], Bool, String, Bool, Bool) {-# LINE 64 "dist/build/Transform.hs" #-} {-# LINE 150 "./src-ag/Transform.ag" #-} type SigInfo = (Identifier,Type) {-# LINE 68 "dist/build/Transform.hs" #-} {-# LINE 151 "./src-ag/Transform.ag" #-} type UniqueInfo = (Identifier,Identifier) {-# LINE 72 "dist/build/Transform.hs" #-} {-# LINE 152 "./src-ag/Transform.ag" #-} type AugmentInfo = (Identifier,Expression) {-# LINE 76 "dist/build/Transform.hs" #-} {-# LINE 153 "./src-ag/Transform.ag" #-} type AroundInfo = (Identifier,Expression) {-# LINE 80 "dist/build/Transform.hs" #-} {-# LINE 154 "./src-ag/Transform.ag" #-} type MergeInfo = (Identifier, Identifier, [Identifier], Expression) {-# LINE 84 "dist/build/Transform.hs" #-} {-# LINE 203 "./src-ag/Transform.ag" #-} 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 {-# LINE 116 "dist/build/Transform.hs" #-} {-# LINE 354 "./src-ag/Transform.ag" #-} 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 (++)) {-# LINE 273 "dist/build/Transform.hs" #-} {-# LINE 511 "./src-ag/Transform.ag" #-} 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 " )" {-# LINE 313 "dist/build/Transform.hs" #-} {-# LINE 747 "./src-ag/Transform.ag" #-} 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 {-# LINE 338 "dist/build/Transform.hs" #-} {-# LINE 873 "./src-ag/Transform.ag" #-} 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 == '_' {-# LINE 349 "dist/build/Transform.hs" #-} {-# LINE 899 "./src-ag/Transform.ag" #-} 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) {-# LINE 358 "dist/build/Transform.hs" #-} {-# LINE 931 "./src-ag/Transform.ag" #-} 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) {-# LINE 367 "dist/build/Transform.hs" #-} {-# LINE 957 "./src-ag/Transform.ag" #-} mergeParams :: ParamMap -> ParamMap -> ParamMap mergeParams = Map.unionWith (++) {-# LINE 373 "dist/build/Transform.hs" #-} {-# LINE 980 "./src-ag/Transform.ag" #-} mergeCtx :: ContextMap -> ContextMap -> ContextMap mergeCtx = Map.unionWith nubconcat where nubconcat a b = nub (a ++ b) {-# LINE 381 "dist/build/Transform.hs" #-} {-# LINE 999 "./src-ag/Transform.ag" #-} mergeQuant :: QuantMap -> QuantMap -> QuantMap mergeQuant = Map.unionWith (++) {-# LINE 387 "dist/build/Transform.hs" #-} {-# LINE 1010 "./src-ag/Transform.ag" #-} mergeDerivings :: Derivings -> Derivings -> Derivings mergeDerivings m1 m2 = foldr (\(n,cs) m -> Map.insertWith Set.union n cs m) m2 (Map.toList m1) {-# LINE 393 "dist/build/Transform.hs" #-} {-# LINE 1022 "./src-ag/Transform.ag" #-} 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 {-# LINE 400 "dist/build/Transform.hs" #-} {-# LINE 1065 "./src-ag/Transform.ag" #-} 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) {-# LINE 411 "dist/build/Transform.hs" #-} {-# LINE 1077 "./src-ag/Transform.ag" #-} 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 {-# LINE 418 "dist/build/Transform.hs" #-} {-# LINE 1215 "./src-ag/Transform.ag" #-} -- We want the last Just in the list flipmplus = flip mplus {-# LINE 424 "dist/build/Transform.hs" #-} {-# LINE 1223 "./src-ag/Transform.ag" #-} makeType :: Set NontermIdent -> Type -> Type makeType nts tp@(NT x _ _) | Set.member x nts = tp | otherwise = Haskell (typeToHaskellString Nothing [] tp) makeType _ tp = tp {-# LINE 432 "dist/build/Transform.hs" #-} {-# LINE 1229 "./src-ag/Transform.ag" #-} 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 {-# LINE 504 "dist/build/Transform.hs" #-} {-# LINE 1300 "./src-ag/Transform.ag" #-} 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 (++) {-# LINE 512 "dist/build/Transform.hs" #-} -- AG ---------------------------------------------------------- -- wrapper data Inh_AG = Inh_AG { options_Inh_AG :: (Options) } data Syn_AG = Syn_AG { agi_Syn_AG :: ((Set NontermIdent, DataTypes, Map NontermIdent (Attributes, Attributes))), blocks_Syn_AG :: (Blocks), errors_Syn_AG :: (Seq Error), moduleDecl_Syn_AG :: (Maybe (String,String,String)), output_Syn_AG :: (Grammar), pragmas_Syn_AG :: (Options -> Options) } {-# INLINABLE wrap_AG #-} wrap_AG :: T_AG -> Inh_AG -> (Syn_AG ) wrap_AG (T_AG act) (Inh_AG _lhsIoptions) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_AG_vIn1 _lhsIoptions (T_AG_vOut1 _lhsOagi _lhsOblocks _lhsOerrors _lhsOmoduleDecl _lhsOoutput _lhsOpragmas) <- return (inv_AG_s2 sem arg) return (Syn_AG _lhsOagi _lhsOblocks _lhsOerrors _lhsOmoduleDecl _lhsOoutput _lhsOpragmas) ) -- cata {-# INLINE sem_AG #-} sem_AG :: AG -> T_AG sem_AG ( AG elems_ ) = sem_AG_AG ( sem_Elems elems_ ) -- semantic domain newtype T_AG = T_AG { attach_T_AG :: Identity (T_AG_s2 ) } newtype T_AG_s2 = C_AG_s2 { inv_AG_s2 :: (T_AG_v1 ) } data T_AG_s3 = C_AG_s3 type T_AG_v1 = (T_AG_vIn1 ) -> (T_AG_vOut1 ) data T_AG_vIn1 = T_AG_vIn1 (Options) data T_AG_vOut1 = T_AG_vOut1 ((Set NontermIdent, DataTypes, Map NontermIdent (Attributes, Attributes))) (Blocks) (Seq Error) (Maybe (String,String,String)) (Grammar) (Options -> Options) {-# NOINLINE sem_AG_AG #-} sem_AG_AG :: T_Elems -> T_AG sem_AG_AG arg_elems_ = T_AG (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_AG_v1 v1 = \ (T_AG_vIn1 _lhsIoptions) -> ( let _elemsX20 = Control.Monad.Identity.runIdentity (attach_T_Elems (arg_elems_)) (T_Elems_vOut19 _elemsIattrDecls _elemsIattrOrderCollect _elemsIattrs _elemsIblocks _elemsIcollectedArounds _elemsIcollectedAugments _elemsIcollectedConParams _elemsIcollectedConstraints _elemsIcollectedConstructorsMap _elemsIcollectedFields _elemsIcollectedInsts _elemsIcollectedMacros _elemsIcollectedMerges _elemsIcollectedNames _elemsIcollectedRules _elemsIcollectedSetNames _elemsIcollectedSigs _elemsIcollectedUniques _elemsIctxCollect _elemsIdefSets _elemsIderivings _elemsIerrors _elemsImoduleDecl _elemsIparamsCollect _elemsIpragmas _elemsIquantCollect _elemsIsemPragmasCollect _elemsItypeSyns _elemsIuseMap _elemsIwrappers) = inv_Elems_s20 _elemsX20 (T_Elems_vIn19 _elemsOallAttrDecls _elemsOallAttrs _elemsOallConstructors _elemsOallFields _elemsOallNonterminals _elemsOattrDecls _elemsOattrs _elemsOdefSets _elemsOdefinedSets _elemsOoptions) _lhsOoutput :: Grammar _lhsOoutput = rule0 _allAttrDecls _allConParams _allConstraints _allFields _allMacros _allNonterminals _checkedArounds _checkedAugments _checkedInsts _checkedMerges _checkedRules _checkedSigs _checkedUniques _elemsIattrOrderCollect _elemsIctxCollect _elemsIderivings _elemsIparamsCollect _elemsIquantCollect _elemsIsemPragmasCollect _elemsItypeSyns _elemsIuseMap _elemsIwrappers _lhsIoptions _prodOrder _prodOrder = rule1 _elemsIcollectedFields _allFields = rule2 _elemsIcollectedFields _allConstraints = rule3 _elemsIcollectedConstraints _allConParams = rule4 _elemsIcollectedConParams _allConstrs = rule5 _elemsIcollectedFields _allRules = rule6 _elemsIcollectedRules _allSigs = rule7 _allAttrDecls _elemsIcollectedSigs _elemsIcollectedUniques _allInsts = rule8 _elemsIcollectedInsts _allUniques = rule9 _elemsIcollectedUniques _allAugments = rule10 _elemsIcollectedAugments _allArounds = rule11 _elemsIcollectedArounds _allMerges = rule12 _elemsIcollectedMerges _augmentSigs = rule13 _allAugments _allRulesErrs = rule14 _allAttrDecls _allFields _allInsts _allMerges _allRules _allSigs _allNamesErrs = rule15 _allRules _allSigsErrs = rule16 _allSigs _allInstsErrs = rule17 _allFields _allInsts _allNonterminals _allSigs _allUniquesErrs = rule18 _allAttrDecls _allUniques _allAugmentErrs = rule19 _allAttrDecls _allAugments _allAroundsErrs = rule20 _allArounds _allFields _allMergesErrs = rule21 _allFields _allInsts _allMerges _allNonterminals _checkedRulesPre = rule22 _allRulesErrs _checkedSigs = rule23 _allSigsErrs _augmentSigs _checkedInsts = rule24 _allInstsErrs _checkedUniques = rule25 _allUniquesErrs _checkedAugments = rule26 _allAugmentErrs _checkedArounds = rule27 _allAroundsErrs _checkedRules = rule28 _allAttrDecls _allFields _allRules _checkedInsts _checkedRulesPre _checkedUniques _lhsIoptions _checkedMerges = rule29 _allMergesErrs _errs1 = rule30 _elemsItypeSyns _errs2 = rule31 _allFields _errs3 = rule32 () _errs4 = rule33 _allRulesErrs _errs5 = rule34 _allSigsErrs _errs6 = rule35 _allInstsErrs _errs7 = rule36 _allUniquesErrs _errs8 = rule37 _allAugmentErrs _errs9 = rule38 _allAroundsErrs _errs10 = rule39 _allNamesErrs _errs11 = rule40 _allMergesErrs _lhsOerrors :: Seq Error _lhsOerrors = rule41 _elemsIerrors _errs1 _errs10 _errs11 _errs2 _errs3 _errs4 _errs5 _errs6 _errs7 _errs8 _errs9 _allNonterminals = rule42 _elemsIcollectedNames _elemsIcollectedSetNames _elemsOallConstructors = rule43 _elemsIcollectedConstructorsMap _elemsOdefSets = rule44 _allNonterminals _elemsOdefinedSets = rule45 _elemsIdefSets _elemsOattrDecls = rule46 () _allAttrDecls = rule47 _allNonterminals _elemsIattrDecls _lhsIoptions _allMacros = rule48 _elemsIcollectedMacros _lhsOagi :: (Set NontermIdent, DataTypes, Map NontermIdent (Attributes, Attributes)) _lhsOagi = rule49 _allAttrs _allFields _allNonterminals _allAttrs = rule50 _allNonterminals _elemsIattrs _lhsIoptions _elemsOattrs = rule51 () _lhsOblocks :: Blocks _lhsOblocks = rule52 _elemsIblocks _lhsOmoduleDecl :: Maybe (String,String,String) _lhsOmoduleDecl = rule53 _elemsImoduleDecl _lhsOpragmas :: Options -> Options _lhsOpragmas = rule54 _elemsIpragmas _elemsOallAttrDecls = rule55 _allAttrDecls _elemsOallAttrs = rule56 _allAttrs _elemsOallFields = rule57 _allFields _elemsOallNonterminals = rule58 _allNonterminals _elemsOoptions = rule59 _lhsIoptions __result_ = T_AG_vOut1 _lhsOagi _lhsOblocks _lhsOerrors _lhsOmoduleDecl _lhsOoutput _lhsOpragmas in __result_ ) in C_AG_s2 v1 {-# INLINE rule0 #-} {-# LINE 50 "./src-ag/Transform.ag" #-} rule0 = \ _allAttrDecls _allConParams _allConstraints _allFields _allMacros _allNonterminals _checkedArounds _checkedAugments _checkedInsts _checkedMerges _checkedRules _checkedSigs _checkedUniques ((_elemsIattrOrderCollect) :: AttrOrderMap) ((_elemsIctxCollect) :: ContextMap) ((_elemsIderivings) :: Derivings) ((_elemsIparamsCollect) :: ParamMap) ((_elemsIquantCollect) :: QuantMap) ((_elemsIsemPragmasCollect) :: PragmaMap) ((_elemsItypeSyns) :: TypeSyns) ((_elemsIuseMap) :: Map NontermIdent (Map Identifier (String,String,String))) ((_elemsIwrappers) :: Set NontermIdent) ((_lhsIoptions) :: Options) _prodOrder -> {-# LINE 50 "./src-ag/Transform.ag" #-} constructGrammar _allNonterminals _elemsIparamsCollect _allConParams _allFields _prodOrder _allConstraints _allAttrDecls _elemsIuseMap _elemsIderivings (if wrappers _lhsIoptions then _allNonterminals else _elemsIwrappers) _checkedRules _checkedSigs _checkedInsts _elemsItypeSyns _elemsIsemPragmasCollect _elemsIattrOrderCollect _elemsIctxCollect _elemsIquantCollect _checkedUniques _checkedAugments _checkedArounds _checkedMerges _allMacros {-# LINE 648 "dist/build/Transform.hs"#-} {-# INLINE rule1 #-} {-# LINE 258 "./src-ag/Transform.ag" #-} rule1 = \ ((_elemsIcollectedFields) :: [(NontermIdent, ConstructorIdent, FieldMap)]) -> {-# LINE 258 "./src-ag/Transform.ag" #-} 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 _elemsIcollectedFields {-# LINE 658 "dist/build/Transform.hs"#-} {-# INLINE rule2 #-} {-# LINE 263 "./src-ag/Transform.ag" #-} rule2 = \ ((_elemsIcollectedFields) :: [(NontermIdent, ConstructorIdent, FieldMap)]) -> {-# LINE 263 "./src-ag/Transform.ag" #-} let f (nt,con,fm) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con fm) in foldr f (Map.empty) _elemsIcollectedFields {-# LINE 665 "dist/build/Transform.hs"#-} {-# INLINE rule3 #-} {-# LINE 266 "./src-ag/Transform.ag" #-} rule3 = \ ((_elemsIcollectedConstraints) :: [(NontermIdent, ConstructorIdent, [Type])]) -> {-# LINE 266 "./src-ag/Transform.ag" #-} let f (nt,con,fm) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con fm) in foldr f (Map.empty) _elemsIcollectedConstraints {-# LINE 672 "dist/build/Transform.hs"#-} {-# INLINE rule4 #-} {-# LINE 269 "./src-ag/Transform.ag" #-} rule4 = \ ((_elemsIcollectedConParams) :: [(NontermIdent, ConstructorIdent, Set Identifier)]) -> {-# LINE 269 "./src-ag/Transform.ag" #-} let f (nt,con,fm) = Map.insertWith (Map.unionWith Set.union) nt (Map.singleton con fm) in foldr f (Map.empty) _elemsIcollectedConParams {-# LINE 679 "dist/build/Transform.hs"#-} {-# INLINE rule5 #-} {-# LINE 272 "./src-ag/Transform.ag" #-} rule5 = \ ((_elemsIcollectedFields) :: [(NontermIdent, ConstructorIdent, FieldMap)]) -> {-# LINE 272 "./src-ag/Transform.ag" #-} let f (nt,con,_) = Map.insertWith (++) nt [con] in foldr f (Map.empty) _elemsIcollectedFields {-# LINE 686 "dist/build/Transform.hs"#-} {-# INLINE rule6 #-} {-# LINE 275 "./src-ag/Transform.ag" #-} rule6 = \ ((_elemsIcollectedRules) :: [ (NontermIdent, ConstructorIdent, RuleInfo)]) -> {-# LINE 275 "./src-ag/Transform.ag" #-} let f (nt,con,r) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con [r]) in foldr f (Map.empty) _elemsIcollectedRules {-# LINE 693 "dist/build/Transform.hs"#-} {-# INLINE rule7 #-} {-# LINE 278 "./src-ag/Transform.ag" #-} rule7 = \ _allAttrDecls ((_elemsIcollectedSigs) :: [ (NontermIdent, ConstructorIdent, SigInfo) ]) ((_elemsIcollectedUniques) :: [ (NontermIdent, ConstructorIdent, [UniqueInfo]) ]) -> {-# LINE 278 "./src-ag/Transform.ag" #-} let f (nt,con,t) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con [t]) typeof nt r = Map.findWithDefault (Haskell "") r $ fst $ Map.findWithDefault (Map.empty,Map.empty) nt _allAttrDecls in foldr f (Map.empty) ( _elemsIcollectedSigs ++ [ (nt, con, (ident,typeof nt ref)) | (nt, con, us) <- _elemsIcollectedUniques, (ident,ref) <- us ] ) {-# LINE 703 "dist/build/Transform.hs"#-} {-# INLINE rule8 #-} {-# LINE 284 "./src-ag/Transform.ag" #-} rule8 = \ ((_elemsIcollectedInsts) :: [ (NontermIdent, ConstructorIdent, [Identifier]) ]) -> {-# LINE 284 "./src-ag/Transform.ag" #-} let f (nt,con,is) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con is) in foldr f (Map.empty) _elemsIcollectedInsts {-# LINE 710 "dist/build/Transform.hs"#-} {-# INLINE rule9 #-} {-# LINE 287 "./src-ag/Transform.ag" #-} rule9 = \ ((_elemsIcollectedUniques) :: [ (NontermIdent, ConstructorIdent, [UniqueInfo]) ]) -> {-# LINE 287 "./src-ag/Transform.ag" #-} let f (nt,con,us) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con us) in foldr f (Map.empty) _elemsIcollectedUniques {-# LINE 717 "dist/build/Transform.hs"#-} {-# INLINE rule10 #-} {-# LINE 289 "./src-ag/Transform.ag" #-} rule10 = \ ((_elemsIcollectedAugments) :: [ (NontermIdent, ConstructorIdent, [AugmentInfo]) ]) -> {-# LINE 289 "./src-ag/Transform.ag" #-} let f (nt,con,as) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con as) in foldr f Map.empty _elemsIcollectedAugments {-# LINE 724 "dist/build/Transform.hs"#-} {-# INLINE rule11 #-} {-# LINE 291 "./src-ag/Transform.ag" #-} rule11 = \ ((_elemsIcollectedArounds) :: [ (NontermIdent, ConstructorIdent, [AroundInfo]) ]) -> {-# LINE 291 "./src-ag/Transform.ag" #-} let f (nt,con,as) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con as) in foldr f Map.empty _elemsIcollectedArounds {-# LINE 731 "dist/build/Transform.hs"#-} {-# INLINE rule12 #-} {-# LINE 293 "./src-ag/Transform.ag" #-} rule12 = \ ((_elemsIcollectedMerges) :: [ (NontermIdent, ConstructorIdent, [MergeInfo]) ]) -> {-# LINE 293 "./src-ag/Transform.ag" #-} let f (nt,con,as) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con as) in foldr f Map.empty _elemsIcollectedMerges {-# LINE 738 "dist/build/Transform.hs"#-} {-# INLINE rule13 #-} {-# LINE 296 "./src-ag/Transform.ag" #-} rule13 = \ _allAugments -> {-# LINE 296 "./src-ag/Transform.ag" #-} let gen _ = [] in Map.map (Map.map gen) _allAugments {-# LINE 745 "dist/build/Transform.hs"#-} {-# INLINE rule14 #-} {-# LINE 299 "./src-ag/Transform.ag" #-} rule14 = \ _allAttrDecls _allFields _allInsts _allMerges _allRules _allSigs -> {-# LINE 299 "./src-ag/Transform.ag" #-} Map.mapWithKey (Map.mapWithKey . (checkRules _allAttrDecls _allFields _allInsts _allSigs _allMerges )) _allRules {-# LINE 751 "dist/build/Transform.hs"#-} {-# INLINE rule15 #-} {-# LINE 300 "./src-ag/Transform.ag" #-} rule15 = \ _allRules -> {-# LINE 300 "./src-ag/Transform.ag" #-} Map.mapWithKey (Map.mapWithKey . checkRuleNames) _allRules {-# LINE 757 "dist/build/Transform.hs"#-} {-# INLINE rule16 #-} {-# LINE 301 "./src-ag/Transform.ag" #-} rule16 = \ _allSigs -> {-# LINE 301 "./src-ag/Transform.ag" #-} Map.mapWithKey (Map.mapWithKey . (checkSigs )) _allSigs {-# LINE 763 "dist/build/Transform.hs"#-} {-# INLINE rule17 #-} {-# LINE 302 "./src-ag/Transform.ag" #-} rule17 = \ _allFields _allInsts _allNonterminals _allSigs -> {-# LINE 302 "./src-ag/Transform.ag" #-} Map.mapWithKey (Map.mapWithKey . (checkInsts _allNonterminals _allSigs _allFields )) _allInsts {-# LINE 769 "dist/build/Transform.hs"#-} {-# INLINE rule18 #-} {-# LINE 303 "./src-ag/Transform.ag" #-} rule18 = \ _allAttrDecls _allUniques -> {-# LINE 303 "./src-ag/Transform.ag" #-} Map.mapWithKey (Map.mapWithKey . (checkUniques _allAttrDecls )) _allUniques {-# LINE 775 "dist/build/Transform.hs"#-} {-# INLINE rule19 #-} {-# LINE 304 "./src-ag/Transform.ag" #-} rule19 = \ _allAttrDecls _allAugments -> {-# LINE 304 "./src-ag/Transform.ag" #-} Map.mapWithKey (Map.mapWithKey . (checkAugments _allAttrDecls )) _allAugments {-# LINE 781 "dist/build/Transform.hs"#-} {-# INLINE rule20 #-} {-# LINE 305 "./src-ag/Transform.ag" #-} rule20 = \ _allArounds _allFields -> {-# LINE 305 "./src-ag/Transform.ag" #-} Map.mapWithKey (Map.mapWithKey . (checkArounds _allFields )) _allArounds {-# LINE 787 "dist/build/Transform.hs"#-} {-# INLINE rule21 #-} {-# LINE 306 "./src-ag/Transform.ag" #-} rule21 = \ _allFields _allInsts _allMerges _allNonterminals -> {-# LINE 306 "./src-ag/Transform.ag" #-} Map.mapWithKey (Map.mapWithKey . (checkMerges _allNonterminals _allInsts _allFields )) _allMerges {-# LINE 793 "dist/build/Transform.hs"#-} {-# INLINE rule22 #-} {-# LINE 308 "./src-ag/Transform.ag" #-} rule22 = \ _allRulesErrs -> {-# LINE 308 "./src-ag/Transform.ag" #-} Map.map (Map.map fst) _allRulesErrs {-# LINE 799 "dist/build/Transform.hs"#-} {-# INLINE rule23 #-} {-# LINE 309 "./src-ag/Transform.ag" #-} rule23 = \ _allSigsErrs _augmentSigs -> {-# LINE 309 "./src-ag/Transform.ag" #-} Map.map (Map.map fst) _allSigsErrs `unionunionplusplus` _augmentSigs {-# LINE 805 "dist/build/Transform.hs"#-} {-# INLINE rule24 #-} {-# LINE 310 "./src-ag/Transform.ag" #-} rule24 = \ _allInstsErrs -> {-# LINE 310 "./src-ag/Transform.ag" #-} Map.map (Map.map fst) _allInstsErrs {-# LINE 811 "dist/build/Transform.hs"#-} {-# INLINE rule25 #-} {-# LINE 311 "./src-ag/Transform.ag" #-} rule25 = \ _allUniquesErrs -> {-# LINE 311 "./src-ag/Transform.ag" #-} Map.map (Map.map fst) _allUniquesErrs {-# LINE 817 "dist/build/Transform.hs"#-} {-# INLINE rule26 #-} {-# LINE 312 "./src-ag/Transform.ag" #-} rule26 = \ _allAugmentErrs -> {-# LINE 312 "./src-ag/Transform.ag" #-} Map.map (Map.map fst) _allAugmentErrs {-# LINE 823 "dist/build/Transform.hs"#-} {-# INLINE rule27 #-} {-# LINE 313 "./src-ag/Transform.ag" #-} rule27 = \ _allAroundsErrs -> {-# LINE 313 "./src-ag/Transform.ag" #-} Map.map (Map.map fst) _allAroundsErrs {-# LINE 829 "dist/build/Transform.hs"#-} {-# INLINE rule28 #-} {-# LINE 314 "./src-ag/Transform.ag" #-} rule28 = \ _allAttrDecls _allFields _allRules _checkedInsts _checkedRulesPre _checkedUniques ((_lhsIoptions) :: Options) -> {-# LINE 314 "./src-ag/Transform.ag" #-} Map.unionWith (Map.unionWith (++)) _checkedRulesPre (Map.mapWithKey (Map.mapWithKey . (mkUniqueRules _lhsIoptions _allRules _allFields _checkedInsts _allAttrDecls )) _checkedUniques ) {-# LINE 835 "dist/build/Transform.hs"#-} {-# INLINE rule29 #-} {-# LINE 315 "./src-ag/Transform.ag" #-} rule29 = \ _allMergesErrs -> {-# LINE 315 "./src-ag/Transform.ag" #-} Map.map (Map.map fst) _allMergesErrs {-# LINE 841 "dist/build/Transform.hs"#-} {-# INLINE rule30 #-} {-# LINE 317 "./src-ag/Transform.ag" #-} rule30 = \ ((_elemsItypeSyns) :: TypeSyns) -> {-# LINE 317 "./src-ag/Transform.ag" #-} let f = checkForDuplicates (DupSynonym) in Seq.fromList . f . map fst $ _elemsItypeSyns {-# LINE 848 "dist/build/Transform.hs"#-} {-# INLINE rule31 #-} {-# LINE 320 "./src-ag/Transform.ag" #-} rule31 = \ _allFields -> {-# LINE 320 "./src-ag/Transform.ag" #-} 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 {-# LINE 856 "dist/build/Transform.hs"#-} {-# INLINE rule32 #-} {-# LINE 324 "./src-ag/Transform.ag" #-} rule32 = \ (_ :: ()) -> {-# LINE 324 "./src-ag/Transform.ag" #-} let in Seq.empty {-# LINE 863 "dist/build/Transform.hs"#-} {-# INLINE rule33 #-} {-# 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 {-# LINE 870 "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 {-# LINE 877 "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 {-# LINE 884 "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 {-# LINE 891 "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 {-# LINE 898 "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 {-# LINE 905 "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 {-# LINE 912 "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 {-# LINE 919 "dist/build/Transform.hs"#-} {-# INLINE rule41 #-} {-# LINE 352 "./src-ag/Transform.ag" #-} rule41 = \ ((_elemsIerrors) :: Seq Error) _errs1 _errs10 _errs11 _errs2 _errs3 _errs4 _errs5 _errs6 _errs7 _errs8 _errs9 -> {-# LINE 352 "./src-ag/Transform.ag" #-} _elemsIerrors >< _errs1 >< _errs2 >< _errs3 >< _errs4 >< _errs5 >< _errs6 >< _errs7 >< _errs8 >< _errs9 >< _errs10 >< _errs11 {-# LINE 925 "dist/build/Transform.hs"#-} {-# INLINE rule42 #-} {-# LINE 606 "./src-ag/Transform.ag" #-} rule42 = \ ((_elemsIcollectedNames) :: Set Identifier) ((_elemsIcollectedSetNames) :: Set Identifier) -> {-# LINE 606 "./src-ag/Transform.ag" #-} _elemsIcollectedNames `Set.difference` _elemsIcollectedSetNames {-# LINE 931 "dist/build/Transform.hs"#-} {-# INLINE rule43 #-} {-# LINE 626 "./src-ag/Transform.ag" #-} rule43 = \ ((_elemsIcollectedConstructorsMap) :: Map NontermIdent (Set ConstructorIdent)) -> {-# LINE 626 "./src-ag/Transform.ag" #-} _elemsIcollectedConstructorsMap {-# LINE 937 "dist/build/Transform.hs"#-} {-# INLINE rule44 #-} {-# LINE 709 "./src-ag/Transform.ag" #-} rule44 = \ _allNonterminals -> {-# LINE 709 "./src-ag/Transform.ag" #-} Map.fromList (map (\x->(x,(Set.singleton x, Set.empty))) (Set.toList _allNonterminals )) {-# LINE 943 "dist/build/Transform.hs"#-} {-# INLINE rule45 #-} {-# LINE 710 "./src-ag/Transform.ag" #-} rule45 = \ ((_elemsIdefSets) :: Map Identifier (Set NontermIdent,Set Identifier)) -> {-# LINE 710 "./src-ag/Transform.ag" #-} Map.map fst _elemsIdefSets {-# LINE 949 "dist/build/Transform.hs"#-} {-# INLINE rule46 #-} {-# LINE 1029 "./src-ag/Transform.ag" #-} rule46 = \ (_ :: ()) -> {-# LINE 1029 "./src-ag/Transform.ag" #-} Map.empty {-# LINE 955 "dist/build/Transform.hs"#-} {-# INLINE rule47 #-} {-# LINE 1085 "./src-ag/Transform.ag" #-} rule47 = \ _allNonterminals ((_elemsIattrDecls) :: Map NontermIdent (Attributes, Attributes)) ((_lhsIoptions) :: Options) -> {-# LINE 1085 "./src-ag/Transform.ag" #-} if withSelf _lhsIoptions then foldr addSelf _elemsIattrDecls (Set.toList _allNonterminals ) else _elemsIattrDecls {-# LINE 963 "dist/build/Transform.hs"#-} {-# INLINE rule48 #-} {-# LINE 1327 "./src-ag/Transform.ag" #-} rule48 = \ ((_elemsIcollectedMacros) :: [(NontermIdent, ConstructorIdent, MaybeMacro)]) -> {-# LINE 1327 "./src-ag/Transform.ag" #-} let f (nt,con,m) = Map.insertWith (Map.union) nt (Map.singleton con m) in foldr f (Map.empty) _elemsIcollectedMacros {-# LINE 970 "dist/build/Transform.hs"#-} {-# INLINE rule49 #-} {-# LINE 1340 "./src-ag/Transform.ag" #-} rule49 = \ _allAttrs _allFields _allNonterminals -> {-# LINE 1340 "./src-ag/Transform.ag" #-} (_allNonterminals ,_allFields ,_allAttrs ) {-# LINE 976 "dist/build/Transform.hs"#-} {-# INLINE rule50 #-} {-# LINE 1342 "./src-ag/Transform.ag" #-} rule50 = \ _allNonterminals ((_elemsIattrs) :: Map NontermIdent (Attributes, Attributes)) ((_lhsIoptions) :: Options) -> {-# LINE 1342 "./src-ag/Transform.ag" #-} if withSelf _lhsIoptions then foldr addSelf _elemsIattrs (Set.toList _allNonterminals ) else _elemsIattrs {-# LINE 984 "dist/build/Transform.hs"#-} {-# INLINE rule51 #-} {-# LINE 1350 "./src-ag/Transform.ag" #-} rule51 = \ (_ :: ()) -> {-# LINE 1350 "./src-ag/Transform.ag" #-} Map.empty {-# LINE 990 "dist/build/Transform.hs"#-} {-# INLINE rule52 #-} rule52 = \ ((_elemsIblocks) :: Blocks) -> _elemsIblocks {-# INLINE rule53 #-} rule53 = \ ((_elemsImoduleDecl) :: Maybe (String,String,String)) -> _elemsImoduleDecl {-# INLINE rule54 #-} rule54 = \ ((_elemsIpragmas) :: Options -> Options) -> _elemsIpragmas {-# INLINE rule55 #-} rule55 = \ _allAttrDecls -> _allAttrDecls {-# INLINE rule56 #-} rule56 = \ _allAttrs -> _allAttrs {-# INLINE rule57 #-} rule57 = \ _allFields -> _allFields {-# INLINE rule58 #-} rule58 = \ _allNonterminals -> _allNonterminals {-# INLINE rule59 #-} rule59 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions -- Alt --------------------------------------------------------- -- wrapper data Inh_Alt = Inh_Alt { allConstructors_Inh_Alt :: (Map NontermIdent (Set ConstructorIdent)), allNonterminals_Inh_Alt :: (Set NontermIdent), nts_Inh_Alt :: (Set NontermIdent) } data Syn_Alt = Syn_Alt { collectedConParams_Syn_Alt :: ([(NontermIdent, ConstructorIdent, Set Identifier)]), collectedConstraints_Syn_Alt :: ([(NontermIdent, ConstructorIdent, [Type])]), collectedConstructorNames_Syn_Alt :: (Set ConstructorIdent), collectedFields_Syn_Alt :: ([(NontermIdent, ConstructorIdent, FieldMap)]), collectedMacros_Syn_Alt :: ([(NontermIdent, ConstructorIdent, MaybeMacro)]) } {-# INLINABLE wrap_Alt #-} wrap_Alt :: T_Alt -> Inh_Alt -> (Syn_Alt ) wrap_Alt (T_Alt act) (Inh_Alt _lhsIallConstructors _lhsIallNonterminals _lhsInts) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Alt_vIn4 _lhsIallConstructors _lhsIallNonterminals _lhsInts (T_Alt_vOut4 _lhsOcollectedConParams _lhsOcollectedConstraints _lhsOcollectedConstructorNames _lhsOcollectedFields _lhsOcollectedMacros) <- return (inv_Alt_s5 sem arg) return (Syn_Alt _lhsOcollectedConParams _lhsOcollectedConstraints _lhsOcollectedConstructorNames _lhsOcollectedFields _lhsOcollectedMacros) ) -- cata {-# INLINE sem_Alt #-} sem_Alt :: Alt -> T_Alt sem_Alt ( Alt pos_ names_ tyvars_ fields_ macro_ ) = sem_Alt_Alt pos_ ( sem_ConstructorSet names_ ) tyvars_ ( sem_Fields fields_ ) macro_ -- semantic domain newtype T_Alt = T_Alt { attach_T_Alt :: Identity (T_Alt_s5 ) } newtype T_Alt_s5 = C_Alt_s5 { inv_Alt_s5 :: (T_Alt_v4 ) } data T_Alt_s6 = C_Alt_s6 type T_Alt_v4 = (T_Alt_vIn4 ) -> (T_Alt_vOut4 ) data T_Alt_vIn4 = T_Alt_vIn4 (Map NontermIdent (Set ConstructorIdent)) (Set NontermIdent) (Set NontermIdent) data T_Alt_vOut4 = T_Alt_vOut4 ([(NontermIdent, ConstructorIdent, Set Identifier)]) ([(NontermIdent, ConstructorIdent, [Type])]) (Set ConstructorIdent) ([(NontermIdent, ConstructorIdent, FieldMap)]) ([(NontermIdent, ConstructorIdent, MaybeMacro)]) {-# NOINLINE sem_Alt_Alt #-} sem_Alt_Alt :: (Pos) -> T_ConstructorSet -> ([Identifier]) -> T_Fields -> (MaybeMacro) -> T_Alt sem_Alt_Alt _ arg_names_ arg_tyvars_ arg_fields_ arg_macro_ = T_Alt (return st5) where {-# NOINLINE st5 #-} st5 = let v4 :: T_Alt_v4 v4 = \ (T_Alt_vIn4 _lhsIallConstructors _lhsIallNonterminals _lhsInts) -> ( let _namesX14 = Control.Monad.Identity.runIdentity (attach_T_ConstructorSet (arg_names_)) _fieldsX26 = Control.Monad.Identity.runIdentity (attach_T_Fields (arg_fields_)) (T_ConstructorSet_vOut13 _namesIcollectedConstructorNames _namesIconstructors _namesIerrors) = inv_ConstructorSet_s14 _namesX14 (T_ConstructorSet_vIn13 ) (T_Fields_vOut25 _fieldsIcollectedConstraints _fieldsIcollectedFields) = inv_Fields_s26 _fieldsX26 (T_Fields_vIn25 _fieldsOallNonterminals) _lhsOcollectedFields :: [(NontermIdent, ConstructorIdent, FieldMap)] _lhsOcollectedFields = rule60 _fieldsIcollectedFields _lhsIallConstructors _lhsInts _namesIconstructors _lhsOcollectedConstraints :: [(NontermIdent, ConstructorIdent, [Type])] _lhsOcollectedConstraints = rule61 _fieldsIcollectedConstraints _lhsIallConstructors _lhsInts _namesIconstructors _lhsOcollectedConParams :: [(NontermIdent, ConstructorIdent, Set Identifier)] _lhsOcollectedConParams = rule62 _lhsIallConstructors _lhsInts _namesIconstructors arg_tyvars_ _lhsOcollectedMacros :: [(NontermIdent, ConstructorIdent, MaybeMacro)] _lhsOcollectedMacros = rule63 _lhsIallConstructors _lhsInts _namesIconstructors arg_macro_ _lhsOcollectedConstructorNames :: Set ConstructorIdent _lhsOcollectedConstructorNames = rule64 _namesIcollectedConstructorNames _fieldsOallNonterminals = rule65 _lhsIallNonterminals __result_ = T_Alt_vOut4 _lhsOcollectedConParams _lhsOcollectedConstraints _lhsOcollectedConstructorNames _lhsOcollectedFields _lhsOcollectedMacros in __result_ ) in C_Alt_s5 v4 {-# INLINE rule60 #-} {-# LINE 240 "./src-ag/Transform.ag" #-} rule60 = \ ((_fieldsIcollectedFields) :: [(Identifier, Type)]) ((_lhsIallConstructors) :: Map NontermIdent (Set ConstructorIdent)) ((_lhsInts) :: Set NontermIdent) ((_namesIconstructors) :: (Set ConstructorIdent->Set ConstructorIdent)) -> {-# LINE 240 "./src-ag/Transform.ag" #-} [ (nt, con, _fieldsIcollectedFields) | nt <- Set.toList _lhsInts , con <- Set.toList (_namesIconstructors (Map.findWithDefault Set.empty nt _lhsIallConstructors)) ] {-# LINE 1079 "dist/build/Transform.hs"#-} {-# INLINE rule61 #-} {-# LINE 244 "./src-ag/Transform.ag" #-} rule61 = \ ((_fieldsIcollectedConstraints) :: [Type]) ((_lhsIallConstructors) :: Map NontermIdent (Set ConstructorIdent)) ((_lhsInts) :: Set NontermIdent) ((_namesIconstructors) :: (Set ConstructorIdent->Set ConstructorIdent)) -> {-# LINE 244 "./src-ag/Transform.ag" #-} [ (nt, con, _fieldsIcollectedConstraints) | nt <- Set.toList _lhsInts , con <- Set.toList (_namesIconstructors (Map.findWithDefault Set.empty nt _lhsIallConstructors)) ] {-# LINE 1088 "dist/build/Transform.hs"#-} {-# INLINE rule62 #-} {-# LINE 248 "./src-ag/Transform.ag" #-} rule62 = \ ((_lhsIallConstructors) :: Map NontermIdent (Set ConstructorIdent)) ((_lhsInts) :: Set NontermIdent) ((_namesIconstructors) :: (Set ConstructorIdent->Set ConstructorIdent)) tyvars_ -> {-# LINE 248 "./src-ag/Transform.ag" #-} [ (nt, con, Set.fromList tyvars_) | nt <- Set.toList _lhsInts , con <- Set.toList (_namesIconstructors (Map.findWithDefault Set.empty nt _lhsIallConstructors)) ] {-# LINE 1097 "dist/build/Transform.hs"#-} {-# INLINE rule63 #-} {-# LINE 1318 "./src-ag/Transform.ag" #-} rule63 = \ ((_lhsIallConstructors) :: Map NontermIdent (Set ConstructorIdent)) ((_lhsInts) :: Set NontermIdent) ((_namesIconstructors) :: (Set ConstructorIdent->Set ConstructorIdent)) macro_ -> {-# LINE 1318 "./src-ag/Transform.ag" #-} [ (nt, con, macro_) | nt <- Set.toList _lhsInts , con <- Set.toList (_namesIconstructors (Map.findWithDefault Set.empty nt _lhsIallConstructors)) ] {-# LINE 1106 "dist/build/Transform.hs"#-} {-# INLINE rule64 #-} rule64 = \ ((_namesIcollectedConstructorNames) :: Set ConstructorIdent) -> _namesIcollectedConstructorNames {-# INLINE rule65 #-} rule65 = \ ((_lhsIallNonterminals) :: Set NontermIdent) -> _lhsIallNonterminals -- Alts -------------------------------------------------------- -- wrapper data Inh_Alts = Inh_Alts { allConstructors_Inh_Alts :: (Map NontermIdent (Set ConstructorIdent)), allNonterminals_Inh_Alts :: (Set NontermIdent), nts_Inh_Alts :: (Set NontermIdent) } data Syn_Alts = Syn_Alts { collectedConParams_Syn_Alts :: ([(NontermIdent, ConstructorIdent, Set Identifier)]), collectedConstraints_Syn_Alts :: ([(NontermIdent, ConstructorIdent, [Type])]), collectedConstructorNames_Syn_Alts :: (Set ConstructorIdent), collectedFields_Syn_Alts :: ([(NontermIdent, ConstructorIdent, FieldMap)]), collectedMacros_Syn_Alts :: ([(NontermIdent, ConstructorIdent, MaybeMacro)]) } {-# INLINABLE wrap_Alts #-} wrap_Alts :: T_Alts -> Inh_Alts -> (Syn_Alts ) wrap_Alts (T_Alts act) (Inh_Alts _lhsIallConstructors _lhsIallNonterminals _lhsInts) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Alts_vIn7 _lhsIallConstructors _lhsIallNonterminals _lhsInts (T_Alts_vOut7 _lhsOcollectedConParams _lhsOcollectedConstraints _lhsOcollectedConstructorNames _lhsOcollectedFields _lhsOcollectedMacros) <- return (inv_Alts_s8 sem arg) return (Syn_Alts _lhsOcollectedConParams _lhsOcollectedConstraints _lhsOcollectedConstructorNames _lhsOcollectedFields _lhsOcollectedMacros) ) -- cata {-# NOINLINE sem_Alts #-} sem_Alts :: Alts -> T_Alts sem_Alts list = Prelude.foldr sem_Alts_Cons sem_Alts_Nil (Prelude.map sem_Alt list) -- semantic domain newtype T_Alts = T_Alts { attach_T_Alts :: Identity (T_Alts_s8 ) } newtype T_Alts_s8 = C_Alts_s8 { inv_Alts_s8 :: (T_Alts_v7 ) } data T_Alts_s9 = C_Alts_s9 type T_Alts_v7 = (T_Alts_vIn7 ) -> (T_Alts_vOut7 ) data T_Alts_vIn7 = T_Alts_vIn7 (Map NontermIdent (Set ConstructorIdent)) (Set NontermIdent) (Set NontermIdent) data T_Alts_vOut7 = T_Alts_vOut7 ([(NontermIdent, ConstructorIdent, Set Identifier)]) ([(NontermIdent, ConstructorIdent, [Type])]) (Set ConstructorIdent) ([(NontermIdent, ConstructorIdent, FieldMap)]) ([(NontermIdent, ConstructorIdent, MaybeMacro)]) {-# NOINLINE sem_Alts_Cons #-} sem_Alts_Cons :: T_Alt -> T_Alts -> T_Alts sem_Alts_Cons arg_hd_ arg_tl_ = T_Alts (return st8) where {-# NOINLINE st8 #-} st8 = let v7 :: T_Alts_v7 v7 = \ (T_Alts_vIn7 _lhsIallConstructors _lhsIallNonterminals _lhsInts) -> ( let _hdX5 = Control.Monad.Identity.runIdentity (attach_T_Alt (arg_hd_)) _tlX8 = Control.Monad.Identity.runIdentity (attach_T_Alts (arg_tl_)) (T_Alt_vOut4 _hdIcollectedConParams _hdIcollectedConstraints _hdIcollectedConstructorNames _hdIcollectedFields _hdIcollectedMacros) = inv_Alt_s5 _hdX5 (T_Alt_vIn4 _hdOallConstructors _hdOallNonterminals _hdOnts) (T_Alts_vOut7 _tlIcollectedConParams _tlIcollectedConstraints _tlIcollectedConstructorNames _tlIcollectedFields _tlIcollectedMacros) = inv_Alts_s8 _tlX8 (T_Alts_vIn7 _tlOallConstructors _tlOallNonterminals _tlOnts) _lhsOcollectedConParams :: [(NontermIdent, ConstructorIdent, Set Identifier)] _lhsOcollectedConParams = rule66 _hdIcollectedConParams _tlIcollectedConParams _lhsOcollectedConstraints :: [(NontermIdent, ConstructorIdent, [Type])] _lhsOcollectedConstraints = rule67 _hdIcollectedConstraints _tlIcollectedConstraints _lhsOcollectedConstructorNames :: Set ConstructorIdent _lhsOcollectedConstructorNames = rule68 _hdIcollectedConstructorNames _tlIcollectedConstructorNames _lhsOcollectedFields :: [(NontermIdent, ConstructorIdent, FieldMap)] _lhsOcollectedFields = rule69 _hdIcollectedFields _tlIcollectedFields _lhsOcollectedMacros :: [(NontermIdent, ConstructorIdent, MaybeMacro)] _lhsOcollectedMacros = rule70 _hdIcollectedMacros _tlIcollectedMacros _hdOallConstructors = rule71 _lhsIallConstructors _hdOallNonterminals = rule72 _lhsIallNonterminals _hdOnts = rule73 _lhsInts _tlOallConstructors = rule74 _lhsIallConstructors _tlOallNonterminals = rule75 _lhsIallNonterminals _tlOnts = rule76 _lhsInts __result_ = T_Alts_vOut7 _lhsOcollectedConParams _lhsOcollectedConstraints _lhsOcollectedConstructorNames _lhsOcollectedFields _lhsOcollectedMacros in __result_ ) in C_Alts_s8 v7 {-# INLINE rule66 #-} rule66 = \ ((_hdIcollectedConParams) :: [(NontermIdent, ConstructorIdent, Set Identifier)]) ((_tlIcollectedConParams) :: [(NontermIdent, ConstructorIdent, Set Identifier)]) -> _hdIcollectedConParams ++ _tlIcollectedConParams {-# INLINE rule67 #-} rule67 = \ ((_hdIcollectedConstraints) :: [(NontermIdent, ConstructorIdent, [Type])]) ((_tlIcollectedConstraints) :: [(NontermIdent, ConstructorIdent, [Type])]) -> _hdIcollectedConstraints ++ _tlIcollectedConstraints {-# INLINE rule68 #-} rule68 = \ ((_hdIcollectedConstructorNames) :: Set ConstructorIdent) ((_tlIcollectedConstructorNames) :: Set ConstructorIdent) -> _hdIcollectedConstructorNames `Set.union` _tlIcollectedConstructorNames {-# INLINE rule69 #-} rule69 = \ ((_hdIcollectedFields) :: [(NontermIdent, ConstructorIdent, FieldMap)]) ((_tlIcollectedFields) :: [(NontermIdent, ConstructorIdent, FieldMap)]) -> _hdIcollectedFields ++ _tlIcollectedFields {-# INLINE rule70 #-} rule70 = \ ((_hdIcollectedMacros) :: [(NontermIdent, ConstructorIdent, MaybeMacro)]) ((_tlIcollectedMacros) :: [(NontermIdent, ConstructorIdent, MaybeMacro)]) -> _hdIcollectedMacros ++ _tlIcollectedMacros {-# INLINE rule71 #-} rule71 = \ ((_lhsIallConstructors) :: Map NontermIdent (Set ConstructorIdent)) -> _lhsIallConstructors {-# INLINE rule72 #-} rule72 = \ ((_lhsIallNonterminals) :: Set NontermIdent) -> _lhsIallNonterminals {-# INLINE rule73 #-} rule73 = \ ((_lhsInts) :: Set NontermIdent) -> _lhsInts {-# INLINE rule74 #-} rule74 = \ ((_lhsIallConstructors) :: Map NontermIdent (Set ConstructorIdent)) -> _lhsIallConstructors {-# INLINE rule75 #-} rule75 = \ ((_lhsIallNonterminals) :: Set NontermIdent) -> _lhsIallNonterminals {-# INLINE rule76 #-} rule76 = \ ((_lhsInts) :: Set NontermIdent) -> _lhsInts {-# NOINLINE sem_Alts_Nil #-} sem_Alts_Nil :: T_Alts sem_Alts_Nil = T_Alts (return st8) where {-# NOINLINE st8 #-} st8 = let v7 :: T_Alts_v7 v7 = \ (T_Alts_vIn7 _lhsIallConstructors _lhsIallNonterminals _lhsInts) -> ( let _lhsOcollectedConParams :: [(NontermIdent, ConstructorIdent, Set Identifier)] _lhsOcollectedConParams = rule77 () _lhsOcollectedConstraints :: [(NontermIdent, ConstructorIdent, [Type])] _lhsOcollectedConstraints = rule78 () _lhsOcollectedConstructorNames :: Set ConstructorIdent _lhsOcollectedConstructorNames = rule79 () _lhsOcollectedFields :: [(NontermIdent, ConstructorIdent, FieldMap)] _lhsOcollectedFields = rule80 () _lhsOcollectedMacros :: [(NontermIdent, ConstructorIdent, MaybeMacro)] _lhsOcollectedMacros = rule81 () __result_ = T_Alts_vOut7 _lhsOcollectedConParams _lhsOcollectedConstraints _lhsOcollectedConstructorNames _lhsOcollectedFields _lhsOcollectedMacros in __result_ ) in C_Alts_s8 v7 {-# INLINE rule77 #-} rule77 = \ (_ :: ()) -> [] {-# INLINE rule78 #-} rule78 = \ (_ :: ()) -> [] {-# INLINE rule79 #-} rule79 = \ (_ :: ()) -> Set.empty {-# INLINE rule80 #-} rule80 = \ (_ :: ()) -> [] {-# INLINE rule81 #-} rule81 = \ (_ :: ()) -> [] -- Attrs ------------------------------------------------------- -- wrapper data Inh_Attrs = Inh_Attrs { allFields_Inh_Attrs :: (DataTypes), allNonterminals_Inh_Attrs :: (Set NontermIdent), attrDecls_Inh_Attrs :: (Map NontermIdent (Attributes, Attributes)), attrs_Inh_Attrs :: (Map NontermIdent (Attributes, Attributes)), nts_Inh_Attrs :: (Set NontermIdent), options_Inh_Attrs :: (Options) } data Syn_Attrs = Syn_Attrs { attrDecls_Syn_Attrs :: (Map NontermIdent (Attributes, Attributes)), attrs_Syn_Attrs :: (Map NontermIdent (Attributes, Attributes)), errors_Syn_Attrs :: (Seq Error), useMap_Syn_Attrs :: (Map NontermIdent (Map Identifier (String,String,String))) } {-# INLINABLE wrap_Attrs #-} wrap_Attrs :: T_Attrs -> Inh_Attrs -> (Syn_Attrs ) wrap_Attrs (T_Attrs act) (Inh_Attrs _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsIattrs _lhsInts _lhsIoptions) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Attrs_vIn10 _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsIattrs _lhsInts _lhsIoptions (T_Attrs_vOut10 _lhsOattrDecls _lhsOattrs _lhsOerrors _lhsOuseMap) <- return (inv_Attrs_s11 sem arg) return (Syn_Attrs _lhsOattrDecls _lhsOattrs _lhsOerrors _lhsOuseMap) ) -- cata {-# INLINE sem_Attrs #-} sem_Attrs :: Attrs -> T_Attrs sem_Attrs ( Attrs pos_ inh_ chn_ syn_ ) = sem_Attrs_Attrs pos_ inh_ chn_ syn_ -- semantic domain newtype T_Attrs = T_Attrs { attach_T_Attrs :: Identity (T_Attrs_s11 ) } newtype T_Attrs_s11 = C_Attrs_s11 { inv_Attrs_s11 :: (T_Attrs_v10 ) } data T_Attrs_s12 = C_Attrs_s12 type T_Attrs_v10 = (T_Attrs_vIn10 ) -> (T_Attrs_vOut10 ) data T_Attrs_vIn10 = T_Attrs_vIn10 (DataTypes) (Set NontermIdent) (Map NontermIdent (Attributes, Attributes)) (Map NontermIdent (Attributes, Attributes)) (Set NontermIdent) (Options) data T_Attrs_vOut10 = T_Attrs_vOut10 (Map NontermIdent (Attributes, Attributes)) (Map NontermIdent (Attributes, Attributes)) (Seq Error) (Map NontermIdent (Map Identifier (String,String,String))) {-# NOINLINE sem_Attrs_Attrs #-} sem_Attrs_Attrs :: (Pos) -> (AttrNames) -> (AttrNames) -> (AttrNames) -> T_Attrs sem_Attrs_Attrs _ arg_inh_ arg_chn_ arg_syn_ = T_Attrs (return st11) where {-# NOINLINE st11 #-} st11 = let v10 :: T_Attrs_v10 v10 = \ (T_Attrs_vIn10 _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsIattrs _lhsInts _lhsIoptions) -> ( let (_attrDecls,_errors) = rule82 _inherited _lhsIallFields _lhsIattrDecls _lhsInts _synthesized (_inherited,_synthesized,_useMap) = rule83 _lhsIallNonterminals arg_chn_ arg_inh_ arg_syn_ _lhsOuseMap :: Map NontermIdent (Map Identifier (String,String,String)) _lhsOuseMap = rule84 _lhsInts _useMap _errors1 = rule85 _lhsIoptions arg_chn_ arg_inh_ arg_syn_ _lhsOerrors :: Seq Error _lhsOerrors = rule86 _errors _errors1 _lhsOattrs :: Map NontermIdent (Attributes, Attributes) _lhsOattrs = rule87 _inherited _lhsIattrs _lhsInts _synthesized _lhsOattrDecls :: Map NontermIdent (Attributes, Attributes) _lhsOattrDecls = rule88 _attrDecls __result_ = T_Attrs_vOut10 _lhsOattrDecls _lhsOattrs _lhsOerrors _lhsOuseMap in __result_ ) in C_Attrs_s11 v10 {-# INLINE rule82 #-} {-# LINE 1038 "./src-ag/Transform.ag" #-} rule82 = \ _inherited ((_lhsIallFields) :: DataTypes) ((_lhsIattrDecls) :: Map NontermIdent (Attributes, Attributes)) ((_lhsInts) :: Set NontermIdent) _synthesized -> {-# LINE 1038 "./src-ag/Transform.ag" #-} checkAttrs _lhsIallFields (Set.toList _lhsInts) _inherited _synthesized _lhsIattrDecls {-# LINE 1299 "dist/build/Transform.hs"#-} {-# INLINE rule83 #-} {-# LINE 1040 "./src-ag/Transform.ag" #-} rule83 = \ ((_lhsIallNonterminals) :: Set NontermIdent) chn_ inh_ syn_ -> {-# LINE 1040 "./src-ag/Transform.ag" #-} let splitAttrs xs = unzip [ ((n,makeType _lhsIallNonterminals 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))) {-# LINE 1312 "dist/build/Transform.hs"#-} {-# INLINE rule84 #-} {-# LINE 1048 "./src-ag/Transform.ag" #-} rule84 = \ ((_lhsInts) :: Set NontermIdent) _useMap -> {-# LINE 1048 "./src-ag/Transform.ag" #-} Map.fromList (zip (Set.toList _lhsInts) (repeat _useMap)) {-# LINE 1318 "dist/build/Transform.hs"#-} {-# INLINE rule85 #-} {-# LINE 1050 "./src-ag/Transform.ag" #-} rule85 = \ ((_lhsIoptions) :: Options) chn_ inh_ syn_ -> {-# LINE 1050 "./src-ag/Transform.ag" #-} if checkParseTy _lhsIoptions 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 {-# LINE 1335 "dist/build/Transform.hs"#-} {-# INLINE rule86 #-} {-# LINE 1062 "./src-ag/Transform.ag" #-} rule86 = \ _errors _errors1 -> {-# LINE 1062 "./src-ag/Transform.ag" #-} _errors Seq.>< _errors1 {-# LINE 1341 "dist/build/Transform.hs"#-} {-# INLINE rule87 #-} {-# LINE 1354 "./src-ag/Transform.ag" #-} rule87 = \ _inherited ((_lhsIattrs) :: Map NontermIdent (Attributes, Attributes)) ((_lhsInts) :: Set NontermIdent) _synthesized -> {-# LINE 1354 "./src-ag/Transform.ag" #-} 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 _lhsIattrs (Set.toList _lhsInts) {-# LINE 1351 "dist/build/Transform.hs"#-} {-# INLINE rule88 #-} rule88 = \ _attrDecls -> _attrDecls -- ConstructorSet ---------------------------------------------- -- wrapper data Inh_ConstructorSet = Inh_ConstructorSet { } data Syn_ConstructorSet = Syn_ConstructorSet { collectedConstructorNames_Syn_ConstructorSet :: (Set ConstructorIdent), constructors_Syn_ConstructorSet :: ((Set ConstructorIdent->Set ConstructorIdent)), errors_Syn_ConstructorSet :: (Seq Error) } {-# INLINABLE wrap_ConstructorSet #-} wrap_ConstructorSet :: T_ConstructorSet -> Inh_ConstructorSet -> (Syn_ConstructorSet ) wrap_ConstructorSet (T_ConstructorSet act) (Inh_ConstructorSet ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_ConstructorSet_vIn13 (T_ConstructorSet_vOut13 _lhsOcollectedConstructorNames _lhsOconstructors _lhsOerrors) <- return (inv_ConstructorSet_s14 sem arg) return (Syn_ConstructorSet _lhsOcollectedConstructorNames _lhsOconstructors _lhsOerrors) ) -- cata {-# NOINLINE sem_ConstructorSet #-} sem_ConstructorSet :: ConstructorSet -> T_ConstructorSet sem_ConstructorSet ( CName name_ ) = sem_ConstructorSet_CName name_ sem_ConstructorSet ( CUnion set1_ set2_ ) = sem_ConstructorSet_CUnion ( sem_ConstructorSet set1_ ) ( sem_ConstructorSet set2_ ) sem_ConstructorSet ( CDifference set1_ set2_ ) = sem_ConstructorSet_CDifference ( sem_ConstructorSet set1_ ) ( sem_ConstructorSet set2_ ) sem_ConstructorSet ( CAll ) = sem_ConstructorSet_CAll -- semantic domain newtype T_ConstructorSet = T_ConstructorSet { attach_T_ConstructorSet :: Identity (T_ConstructorSet_s14 ) } newtype T_ConstructorSet_s14 = C_ConstructorSet_s14 { inv_ConstructorSet_s14 :: (T_ConstructorSet_v13 ) } data T_ConstructorSet_s15 = C_ConstructorSet_s15 type T_ConstructorSet_v13 = (T_ConstructorSet_vIn13 ) -> (T_ConstructorSet_vOut13 ) data T_ConstructorSet_vIn13 = T_ConstructorSet_vIn13 data T_ConstructorSet_vOut13 = T_ConstructorSet_vOut13 (Set ConstructorIdent) ((Set ConstructorIdent->Set ConstructorIdent)) (Seq Error) {-# NOINLINE sem_ConstructorSet_CName #-} sem_ConstructorSet_CName :: (ConstructorIdent) -> T_ConstructorSet sem_ConstructorSet_CName arg_name_ = T_ConstructorSet (return st14) where {-# NOINLINE st14 #-} st14 = let v13 :: T_ConstructorSet_v13 v13 = \ (T_ConstructorSet_vIn13 ) -> ( let _lhsOcollectedConstructorNames :: Set ConstructorIdent _lhsOcollectedConstructorNames = rule89 arg_name_ _lhsOconstructors :: (Set ConstructorIdent->Set ConstructorIdent) _lhsOconstructors = rule90 arg_name_ _lhsOerrors :: Seq Error _lhsOerrors = rule91 () __result_ = T_ConstructorSet_vOut13 _lhsOcollectedConstructorNames _lhsOconstructors _lhsOerrors in __result_ ) in C_ConstructorSet_s14 v13 {-# INLINE rule89 #-} {-# LINE 614 "./src-ag/Transform.ag" #-} rule89 = \ name_ -> {-# LINE 614 "./src-ag/Transform.ag" #-} Set.singleton name_ {-# LINE 1410 "dist/build/Transform.hs"#-} {-# INLINE rule90 #-} {-# LINE 777 "./src-ag/Transform.ag" #-} rule90 = \ name_ -> {-# LINE 777 "./src-ag/Transform.ag" #-} \_ -> Set.singleton name_ {-# LINE 1416 "dist/build/Transform.hs"#-} {-# INLINE rule91 #-} rule91 = \ (_ :: ()) -> Seq.empty {-# NOINLINE sem_ConstructorSet_CUnion #-} sem_ConstructorSet_CUnion :: T_ConstructorSet -> T_ConstructorSet -> T_ConstructorSet sem_ConstructorSet_CUnion arg_set1_ arg_set2_ = T_ConstructorSet (return st14) where {-# NOINLINE st14 #-} st14 = let v13 :: T_ConstructorSet_v13 v13 = \ (T_ConstructorSet_vIn13 ) -> ( let _set1X14 = Control.Monad.Identity.runIdentity (attach_T_ConstructorSet (arg_set1_)) _set2X14 = Control.Monad.Identity.runIdentity (attach_T_ConstructorSet (arg_set2_)) (T_ConstructorSet_vOut13 _set1IcollectedConstructorNames _set1Iconstructors _set1Ierrors) = inv_ConstructorSet_s14 _set1X14 (T_ConstructorSet_vIn13 ) (T_ConstructorSet_vOut13 _set2IcollectedConstructorNames _set2Iconstructors _set2Ierrors) = inv_ConstructorSet_s14 _set2X14 (T_ConstructorSet_vIn13 ) _lhsOconstructors :: (Set ConstructorIdent->Set ConstructorIdent) _lhsOconstructors = rule92 _set1Iconstructors _set2Iconstructors _lhsOcollectedConstructorNames :: Set ConstructorIdent _lhsOcollectedConstructorNames = rule93 _set1IcollectedConstructorNames _set2IcollectedConstructorNames _lhsOerrors :: Seq Error _lhsOerrors = rule94 _set1Ierrors _set2Ierrors __result_ = T_ConstructorSet_vOut13 _lhsOcollectedConstructorNames _lhsOconstructors _lhsOerrors in __result_ ) in C_ConstructorSet_s14 v13 {-# INLINE rule92 #-} {-# LINE 778 "./src-ag/Transform.ag" #-} rule92 = \ ((_set1Iconstructors) :: (Set ConstructorIdent->Set ConstructorIdent)) ((_set2Iconstructors) :: (Set ConstructorIdent->Set ConstructorIdent)) -> {-# LINE 778 "./src-ag/Transform.ag" #-} \ds -> _set1Iconstructors ds `Set.union` _set2Iconstructors ds {-# LINE 1445 "dist/build/Transform.hs"#-} {-# INLINE rule93 #-} rule93 = \ ((_set1IcollectedConstructorNames) :: Set ConstructorIdent) ((_set2IcollectedConstructorNames) :: Set ConstructorIdent) -> _set1IcollectedConstructorNames `Set.union` _set2IcollectedConstructorNames {-# INLINE rule94 #-} rule94 = \ ((_set1Ierrors) :: Seq Error) ((_set2Ierrors) :: Seq Error) -> _set1Ierrors Seq.>< _set2Ierrors {-# NOINLINE sem_ConstructorSet_CDifference #-} sem_ConstructorSet_CDifference :: T_ConstructorSet -> T_ConstructorSet -> T_ConstructorSet sem_ConstructorSet_CDifference arg_set1_ arg_set2_ = T_ConstructorSet (return st14) where {-# NOINLINE st14 #-} st14 = let v13 :: T_ConstructorSet_v13 v13 = \ (T_ConstructorSet_vIn13 ) -> ( let _set1X14 = Control.Monad.Identity.runIdentity (attach_T_ConstructorSet (arg_set1_)) _set2X14 = Control.Monad.Identity.runIdentity (attach_T_ConstructorSet (arg_set2_)) (T_ConstructorSet_vOut13 _set1IcollectedConstructorNames _set1Iconstructors _set1Ierrors) = inv_ConstructorSet_s14 _set1X14 (T_ConstructorSet_vIn13 ) (T_ConstructorSet_vOut13 _set2IcollectedConstructorNames _set2Iconstructors _set2Ierrors) = inv_ConstructorSet_s14 _set2X14 (T_ConstructorSet_vIn13 ) _lhsOconstructors :: (Set ConstructorIdent->Set ConstructorIdent) _lhsOconstructors = rule95 _set1Iconstructors _set2Iconstructors _lhsOcollectedConstructorNames :: Set ConstructorIdent _lhsOcollectedConstructorNames = rule96 _set1IcollectedConstructorNames _set2IcollectedConstructorNames _lhsOerrors :: Seq Error _lhsOerrors = rule97 _set1Ierrors _set2Ierrors __result_ = T_ConstructorSet_vOut13 _lhsOcollectedConstructorNames _lhsOconstructors _lhsOerrors in __result_ ) in C_ConstructorSet_s14 v13 {-# INLINE rule95 #-} {-# LINE 779 "./src-ag/Transform.ag" #-} rule95 = \ ((_set1Iconstructors) :: (Set ConstructorIdent->Set ConstructorIdent)) ((_set2Iconstructors) :: (Set ConstructorIdent->Set ConstructorIdent)) -> {-# LINE 779 "./src-ag/Transform.ag" #-} \ds -> _set1Iconstructors ds `Set.difference` _set2Iconstructors ds {-# LINE 1477 "dist/build/Transform.hs"#-} {-# INLINE rule96 #-} rule96 = \ ((_set1IcollectedConstructorNames) :: Set ConstructorIdent) ((_set2IcollectedConstructorNames) :: Set ConstructorIdent) -> _set1IcollectedConstructorNames `Set.union` _set2IcollectedConstructorNames {-# INLINE rule97 #-} rule97 = \ ((_set1Ierrors) :: Seq Error) ((_set2Ierrors) :: Seq Error) -> _set1Ierrors Seq.>< _set2Ierrors {-# NOINLINE sem_ConstructorSet_CAll #-} sem_ConstructorSet_CAll :: T_ConstructorSet sem_ConstructorSet_CAll = T_ConstructorSet (return st14) where {-# NOINLINE st14 #-} st14 = let v13 :: T_ConstructorSet_v13 v13 = \ (T_ConstructorSet_vIn13 ) -> ( let _lhsOconstructors :: (Set ConstructorIdent->Set ConstructorIdent) _lhsOconstructors = rule98 () _lhsOcollectedConstructorNames :: Set ConstructorIdent _lhsOcollectedConstructorNames = rule99 () _lhsOerrors :: Seq Error _lhsOerrors = rule100 () __result_ = T_ConstructorSet_vOut13 _lhsOcollectedConstructorNames _lhsOconstructors _lhsOerrors in __result_ ) in C_ConstructorSet_s14 v13 {-# INLINE rule98 #-} {-# LINE 780 "./src-ag/Transform.ag" #-} rule98 = \ (_ :: ()) -> {-# LINE 780 "./src-ag/Transform.ag" #-} \ds -> ds {-# LINE 1505 "dist/build/Transform.hs"#-} {-# INLINE rule99 #-} rule99 = \ (_ :: ()) -> Set.empty {-# INLINE rule100 #-} rule100 = \ (_ :: ()) -> Seq.empty -- Elem -------------------------------------------------------- -- wrapper data Inh_Elem = Inh_Elem { allAttrDecls_Inh_Elem :: (Map NontermIdent (Attributes, Attributes)), allAttrs_Inh_Elem :: (Map NontermIdent (Attributes, Attributes)), allConstructors_Inh_Elem :: (Map NontermIdent (Set ConstructorIdent)), allFields_Inh_Elem :: (DataTypes), allNonterminals_Inh_Elem :: (Set NontermIdent), attrDecls_Inh_Elem :: (Map NontermIdent (Attributes, Attributes)), attrs_Inh_Elem :: (Map NontermIdent (Attributes, Attributes)), defSets_Inh_Elem :: (Map Identifier (Set NontermIdent,Set Identifier)), definedSets_Inh_Elem :: (DefinedSets), options_Inh_Elem :: (Options) } data Syn_Elem = Syn_Elem { attrDecls_Syn_Elem :: (Map NontermIdent (Attributes, Attributes)), attrOrderCollect_Syn_Elem :: (AttrOrderMap), attrs_Syn_Elem :: (Map NontermIdent (Attributes, Attributes)), blocks_Syn_Elem :: (Blocks), collectedArounds_Syn_Elem :: ([ (NontermIdent, ConstructorIdent, [AroundInfo]) ]), collectedAugments_Syn_Elem :: ([ (NontermIdent, ConstructorIdent, [AugmentInfo]) ]), collectedConParams_Syn_Elem :: ([(NontermIdent, ConstructorIdent, Set Identifier)]), collectedConstraints_Syn_Elem :: ([(NontermIdent, ConstructorIdent, [Type])]), collectedConstructorsMap_Syn_Elem :: (Map NontermIdent (Set ConstructorIdent)), collectedFields_Syn_Elem :: ([(NontermIdent, ConstructorIdent, FieldMap)]), collectedInsts_Syn_Elem :: ([ (NontermIdent, ConstructorIdent, [Identifier]) ]), collectedMacros_Syn_Elem :: ([(NontermIdent, ConstructorIdent, MaybeMacro)]), collectedMerges_Syn_Elem :: ([ (NontermIdent, ConstructorIdent, [MergeInfo]) ]), collectedNames_Syn_Elem :: (Set Identifier), collectedRules_Syn_Elem :: ([ (NontermIdent, ConstructorIdent, RuleInfo)]), collectedSetNames_Syn_Elem :: (Set Identifier), collectedSigs_Syn_Elem :: ([ (NontermIdent, ConstructorIdent, SigInfo) ]), collectedUniques_Syn_Elem :: ([ (NontermIdent, ConstructorIdent, [UniqueInfo]) ]), ctxCollect_Syn_Elem :: (ContextMap), defSets_Syn_Elem :: (Map Identifier (Set NontermIdent,Set Identifier)), derivings_Syn_Elem :: (Derivings), errors_Syn_Elem :: (Seq Error), moduleDecl_Syn_Elem :: (Maybe (String,String,String)), paramsCollect_Syn_Elem :: (ParamMap), pragmas_Syn_Elem :: (Options -> Options), quantCollect_Syn_Elem :: (QuantMap), semPragmasCollect_Syn_Elem :: (PragmaMap), typeSyns_Syn_Elem :: (TypeSyns), useMap_Syn_Elem :: (Map NontermIdent (Map Identifier (String,String,String))), wrappers_Syn_Elem :: (Set NontermIdent) } {-# INLINABLE wrap_Elem #-} wrap_Elem :: T_Elem -> Inh_Elem -> (Syn_Elem ) wrap_Elem (T_Elem act) (Inh_Elem _lhsIallAttrDecls _lhsIallAttrs _lhsIallConstructors _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsIattrs _lhsIdefSets _lhsIdefinedSets _lhsIoptions) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Elem_vIn16 _lhsIallAttrDecls _lhsIallAttrs _lhsIallConstructors _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsIattrs _lhsIdefSets _lhsIdefinedSets _lhsIoptions (T_Elem_vOut16 _lhsOattrDecls _lhsOattrOrderCollect _lhsOattrs _lhsOblocks _lhsOcollectedArounds _lhsOcollectedAugments _lhsOcollectedConParams _lhsOcollectedConstraints _lhsOcollectedConstructorsMap _lhsOcollectedFields _lhsOcollectedInsts _lhsOcollectedMacros _lhsOcollectedMerges _lhsOcollectedNames _lhsOcollectedRules _lhsOcollectedSetNames _lhsOcollectedSigs _lhsOcollectedUniques _lhsOctxCollect _lhsOdefSets _lhsOderivings _lhsOerrors _lhsOmoduleDecl _lhsOparamsCollect _lhsOpragmas _lhsOquantCollect _lhsOsemPragmasCollect _lhsOtypeSyns _lhsOuseMap _lhsOwrappers) <- return (inv_Elem_s17 sem arg) return (Syn_Elem _lhsOattrDecls _lhsOattrOrderCollect _lhsOattrs _lhsOblocks _lhsOcollectedArounds _lhsOcollectedAugments _lhsOcollectedConParams _lhsOcollectedConstraints _lhsOcollectedConstructorsMap _lhsOcollectedFields _lhsOcollectedInsts _lhsOcollectedMacros _lhsOcollectedMerges _lhsOcollectedNames _lhsOcollectedRules _lhsOcollectedSetNames _lhsOcollectedSigs _lhsOcollectedUniques _lhsOctxCollect _lhsOdefSets _lhsOderivings _lhsOerrors _lhsOmoduleDecl _lhsOparamsCollect _lhsOpragmas _lhsOquantCollect _lhsOsemPragmasCollect _lhsOtypeSyns _lhsOuseMap _lhsOwrappers) ) -- cata {-# NOINLINE sem_Elem #-} sem_Elem :: Elem -> T_Elem sem_Elem ( Data pos_ ctx_ names_ params_ attrs_ alts_ ext_ ) = sem_Elem_Data pos_ ctx_ ( sem_NontSet names_ ) params_ ( sem_Attrs attrs_ ) ( sem_Alts alts_ ) ext_ sem_Elem ( Type pos_ ctx_ name_ params_ type_ ) = sem_Elem_Type pos_ ctx_ name_ params_ type_ sem_Elem ( Attr pos_ ctx_ names_ quants_ attrs_ ) = sem_Elem_Attr pos_ ctx_ ( sem_NontSet names_ ) quants_ ( sem_Attrs attrs_ ) sem_Elem ( Sem pos_ ctx_ names_ attrs_ quants_ alts_ ) = sem_Elem_Sem pos_ ctx_ ( sem_NontSet names_ ) ( sem_Attrs attrs_ ) quants_ ( sem_SemAlts alts_ ) sem_Elem ( Txt pos_ kind_ mbNt_ lines_ ) = sem_Elem_Txt pos_ kind_ mbNt_ lines_ sem_Elem ( Set pos_ name_ merge_ set_ ) = sem_Elem_Set pos_ name_ merge_ ( sem_NontSet set_ ) sem_Elem ( Deriving pos_ set_ classes_ ) = sem_Elem_Deriving pos_ ( sem_NontSet set_ ) classes_ sem_Elem ( Wrapper pos_ set_ ) = sem_Elem_Wrapper pos_ ( sem_NontSet set_ ) sem_Elem ( Nocatas pos_ set_ ) = sem_Elem_Nocatas pos_ ( sem_NontSet set_ ) sem_Elem ( Pragma pos_ names_ ) = sem_Elem_Pragma pos_ names_ sem_Elem ( Module pos_ name_ exports_ imports_ ) = sem_Elem_Module pos_ name_ exports_ imports_ -- semantic domain newtype T_Elem = T_Elem { attach_T_Elem :: Identity (T_Elem_s17 ) } newtype T_Elem_s17 = C_Elem_s17 { inv_Elem_s17 :: (T_Elem_v16 ) } data T_Elem_s18 = C_Elem_s18 type T_Elem_v16 = (T_Elem_vIn16 ) -> (T_Elem_vOut16 ) data T_Elem_vIn16 = T_Elem_vIn16 (Map NontermIdent (Attributes, Attributes)) (Map NontermIdent (Attributes, Attributes)) (Map NontermIdent (Set ConstructorIdent)) (DataTypes) (Set NontermIdent) (Map NontermIdent (Attributes, Attributes)) (Map NontermIdent (Attributes, Attributes)) (Map Identifier (Set NontermIdent,Set Identifier)) (DefinedSets) (Options) data T_Elem_vOut16 = T_Elem_vOut16 (Map NontermIdent (Attributes, Attributes)) (AttrOrderMap) (Map NontermIdent (Attributes, Attributes)) (Blocks) ([ (NontermIdent, ConstructorIdent, [AroundInfo]) ]) ([ (NontermIdent, ConstructorIdent, [AugmentInfo]) ]) ([(NontermIdent, ConstructorIdent, Set Identifier)]) ([(NontermIdent, ConstructorIdent, [Type])]) (Map NontermIdent (Set ConstructorIdent)) ([(NontermIdent, ConstructorIdent, FieldMap)]) ([ (NontermIdent, ConstructorIdent, [Identifier]) ]) ([(NontermIdent, ConstructorIdent, MaybeMacro)]) ([ (NontermIdent, ConstructorIdent, [MergeInfo]) ]) (Set Identifier) ([ (NontermIdent, ConstructorIdent, RuleInfo)]) (Set Identifier) ([ (NontermIdent, ConstructorIdent, SigInfo) ]) ([ (NontermIdent, ConstructorIdent, [UniqueInfo]) ]) (ContextMap) (Map Identifier (Set NontermIdent,Set Identifier)) (Derivings) (Seq Error) (Maybe (String,String,String)) (ParamMap) (Options -> Options) (QuantMap) (PragmaMap) (TypeSyns) (Map NontermIdent (Map Identifier (String,String,String))) (Set NontermIdent) {-# NOINLINE sem_Elem_Data #-} sem_Elem_Data :: (Pos) -> (ClassContext) -> T_NontSet -> ([Identifier]) -> T_Attrs -> T_Alts -> (Bool) -> T_Elem sem_Elem_Data _ arg_ctx_ arg_names_ arg_params_ arg_attrs_ arg_alts_ _ = T_Elem (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_Elem_v16 v16 = \ (T_Elem_vIn16 _lhsIallAttrDecls _lhsIallAttrs _lhsIallConstructors _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsIattrs _lhsIdefSets _lhsIdefinedSets _lhsIoptions) -> ( let _namesX29 = Control.Monad.Identity.runIdentity (attach_T_NontSet (arg_names_)) _attrsX11 = Control.Monad.Identity.runIdentity (attach_T_Attrs (arg_attrs_)) _altsX8 = Control.Monad.Identity.runIdentity (attach_T_Alts (arg_alts_)) (T_NontSet_vOut28 _namesIcollectedNames _namesIerrors _namesInontSet) = inv_NontSet_s29 _namesX29 (T_NontSet_vIn28 _namesOallFields _namesOallNonterminals _namesOdefinedSets) (T_Attrs_vOut10 _attrsIattrDecls _attrsIattrs _attrsIerrors _attrsIuseMap) = inv_Attrs_s11 _attrsX11 (T_Attrs_vIn10 _attrsOallFields _attrsOallNonterminals _attrsOattrDecls _attrsOattrs _attrsOnts _attrsOoptions) (T_Alts_vOut7 _altsIcollectedConParams _altsIcollectedConstraints _altsIcollectedConstructorNames _altsIcollectedFields _altsIcollectedMacros) = inv_Alts_s8 _altsX8 (T_Alts_vIn7 _altsOallConstructors _altsOallNonterminals _altsOnts) _altsOnts = rule101 _namesInontSet _lhsOcollectedConstructorsMap :: Map NontermIdent (Set ConstructorIdent) _lhsOcollectedConstructorsMap = rule102 _altsIcollectedConstructorNames _namesInontSet _lhsOparamsCollect :: ParamMap _lhsOparamsCollect = rule103 _namesInontSet arg_params_ _lhsOctxCollect :: ContextMap _lhsOctxCollect = rule104 _namesInontSet arg_ctx_ _attrsOnts = rule105 _namesInontSet _lhsOattrOrderCollect :: AttrOrderMap _lhsOattrOrderCollect = rule106 () _lhsOblocks :: Blocks _lhsOblocks = rule107 () _lhsOcollectedArounds :: [ (NontermIdent, ConstructorIdent, [AroundInfo]) ] _lhsOcollectedArounds = rule108 () _lhsOcollectedAugments :: [ (NontermIdent, ConstructorIdent, [AugmentInfo]) ] _lhsOcollectedAugments = rule109 () _lhsOcollectedConParams :: [(NontermIdent, ConstructorIdent, Set Identifier)] _lhsOcollectedConParams = rule110 _altsIcollectedConParams _lhsOcollectedConstraints :: [(NontermIdent, ConstructorIdent, [Type])] _lhsOcollectedConstraints = rule111 _altsIcollectedConstraints _lhsOcollectedFields :: [(NontermIdent, ConstructorIdent, FieldMap)] _lhsOcollectedFields = rule112 _altsIcollectedFields _lhsOcollectedInsts :: [ (NontermIdent, ConstructorIdent, [Identifier]) ] _lhsOcollectedInsts = rule113 () _lhsOcollectedMacros :: [(NontermIdent, ConstructorIdent, MaybeMacro)] _lhsOcollectedMacros = rule114 _altsIcollectedMacros _lhsOcollectedMerges :: [ (NontermIdent, ConstructorIdent, [MergeInfo]) ] _lhsOcollectedMerges = rule115 () _lhsOcollectedNames :: Set Identifier _lhsOcollectedNames = rule116 _namesIcollectedNames _lhsOcollectedRules :: [ (NontermIdent, ConstructorIdent, RuleInfo)] _lhsOcollectedRules = rule117 () _lhsOcollectedSetNames :: Set Identifier _lhsOcollectedSetNames = rule118 () _lhsOcollectedSigs :: [ (NontermIdent, ConstructorIdent, SigInfo) ] _lhsOcollectedSigs = rule119 () _lhsOcollectedUniques :: [ (NontermIdent, ConstructorIdent, [UniqueInfo]) ] _lhsOcollectedUniques = rule120 () _lhsOderivings :: Derivings _lhsOderivings = rule121 () _lhsOerrors :: Seq Error _lhsOerrors = rule122 _attrsIerrors _namesIerrors _lhsOmoduleDecl :: Maybe (String,String,String) _lhsOmoduleDecl = rule123 () _lhsOpragmas :: Options -> Options _lhsOpragmas = rule124 () _lhsOquantCollect :: QuantMap _lhsOquantCollect = rule125 () _lhsOsemPragmasCollect :: PragmaMap _lhsOsemPragmasCollect = rule126 () _lhsOtypeSyns :: TypeSyns _lhsOtypeSyns = rule127 () _lhsOuseMap :: Map NontermIdent (Map Identifier (String,String,String)) _lhsOuseMap = rule128 _attrsIuseMap _lhsOwrappers :: Set NontermIdent _lhsOwrappers = rule129 () _lhsOattrDecls :: Map NontermIdent (Attributes, Attributes) _lhsOattrDecls = rule130 _attrsIattrDecls _lhsOattrs :: Map NontermIdent (Attributes, Attributes) _lhsOattrs = rule131 _attrsIattrs _lhsOdefSets :: Map Identifier (Set NontermIdent,Set Identifier) _lhsOdefSets = rule132 _lhsIdefSets _namesOallFields = rule133 _lhsIallFields _namesOallNonterminals = rule134 _lhsIallNonterminals _namesOdefinedSets = rule135 _lhsIdefinedSets _attrsOallFields = rule136 _lhsIallFields _attrsOallNonterminals = rule137 _lhsIallNonterminals _attrsOattrDecls = rule138 _lhsIattrDecls _attrsOattrs = rule139 _lhsIattrs _attrsOoptions = rule140 _lhsIoptions _altsOallConstructors = rule141 _lhsIallConstructors _altsOallNonterminals = rule142 _lhsIallNonterminals __result_ = T_Elem_vOut16 _lhsOattrDecls _lhsOattrOrderCollect _lhsOattrs _lhsOblocks _lhsOcollectedArounds _lhsOcollectedAugments _lhsOcollectedConParams _lhsOcollectedConstraints _lhsOcollectedConstructorsMap _lhsOcollectedFields _lhsOcollectedInsts _lhsOcollectedMacros _lhsOcollectedMerges _lhsOcollectedNames _lhsOcollectedRules _lhsOcollectedSetNames _lhsOcollectedSigs _lhsOcollectedUniques _lhsOctxCollect _lhsOdefSets _lhsOderivings _lhsOerrors _lhsOmoduleDecl _lhsOparamsCollect _lhsOpragmas _lhsOquantCollect _lhsOsemPragmasCollect _lhsOtypeSyns _lhsOuseMap _lhsOwrappers in __result_ ) in C_Elem_s17 v16 {-# INLINE rule101 #-} {-# LINE 176 "./src-ag/Transform.ag" #-} rule101 = \ ((_namesInontSet) :: Set NontermIdent) -> {-# LINE 176 "./src-ag/Transform.ag" #-} _namesInontSet {-# LINE 1646 "dist/build/Transform.hs"#-} {-# INLINE rule102 #-} {-# LINE 620 "./src-ag/Transform.ag" #-} rule102 = \ ((_altsIcollectedConstructorNames) :: Set ConstructorIdent) ((_namesInontSet) :: Set NontermIdent) -> {-# LINE 620 "./src-ag/Transform.ag" #-} Map.fromList [ (n, _altsIcollectedConstructorNames) | n <- Set.toList _namesInontSet ] {-# LINE 1655 "dist/build/Transform.hs"#-} {-# INLINE rule103 #-} {-# LINE 947 "./src-ag/Transform.ag" #-} rule103 = \ ((_namesInontSet) :: Set NontermIdent) params_ -> {-# LINE 947 "./src-ag/Transform.ag" #-} if null params_ then Map.empty else Map.fromList [(nt, params_) | nt <- Set.toList _namesInontSet] {-# LINE 1663 "dist/build/Transform.hs"#-} {-# INLINE rule104 #-} {-# LINE 970 "./src-ag/Transform.ag" #-} rule104 = \ ((_namesInontSet) :: Set NontermIdent) ctx_ -> {-# LINE 970 "./src-ag/Transform.ag" #-} if null ctx_ then Map.empty else Map.fromList [(nt, ctx_) | nt <- Set.toList _namesInontSet] {-# LINE 1671 "dist/build/Transform.hs"#-} {-# INLINE rule105 #-} {-# LINE 1032 "./src-ag/Transform.ag" #-} rule105 = \ ((_namesInontSet) :: Set NontermIdent) -> {-# LINE 1032 "./src-ag/Transform.ag" #-} _namesInontSet {-# LINE 1677 "dist/build/Transform.hs"#-} {-# INLINE rule106 #-} rule106 = \ (_ :: ()) -> Map.empty {-# INLINE rule107 #-} rule107 = \ (_ :: ()) -> Map.empty {-# INLINE rule108 #-} rule108 = \ (_ :: ()) -> [] {-# INLINE rule109 #-} rule109 = \ (_ :: ()) -> [] {-# INLINE rule110 #-} rule110 = \ ((_altsIcollectedConParams) :: [(NontermIdent, ConstructorIdent, Set Identifier)]) -> _altsIcollectedConParams {-# INLINE rule111 #-} rule111 = \ ((_altsIcollectedConstraints) :: [(NontermIdent, ConstructorIdent, [Type])]) -> _altsIcollectedConstraints {-# INLINE rule112 #-} rule112 = \ ((_altsIcollectedFields) :: [(NontermIdent, ConstructorIdent, FieldMap)]) -> _altsIcollectedFields {-# INLINE rule113 #-} rule113 = \ (_ :: ()) -> [] {-# INLINE rule114 #-} rule114 = \ ((_altsIcollectedMacros) :: [(NontermIdent, ConstructorIdent, MaybeMacro)]) -> _altsIcollectedMacros {-# INLINE rule115 #-} rule115 = \ (_ :: ()) -> [] {-# INLINE rule116 #-} rule116 = \ ((_namesIcollectedNames) :: Set Identifier) -> _namesIcollectedNames {-# INLINE rule117 #-} rule117 = \ (_ :: ()) -> [] {-# INLINE rule118 #-} rule118 = \ (_ :: ()) -> Set.empty {-# INLINE rule119 #-} rule119 = \ (_ :: ()) -> [] {-# INLINE rule120 #-} rule120 = \ (_ :: ()) -> [] {-# INLINE rule121 #-} rule121 = \ (_ :: ()) -> Map.empty {-# INLINE rule122 #-} rule122 = \ ((_attrsIerrors) :: Seq Error) ((_namesIerrors) :: Seq Error) -> _namesIerrors Seq.>< _attrsIerrors {-# INLINE rule123 #-} rule123 = \ (_ :: ()) -> mzero {-# INLINE rule124 #-} rule124 = \ (_ :: ()) -> id {-# INLINE rule125 #-} rule125 = \ (_ :: ()) -> Map.empty {-# INLINE rule126 #-} rule126 = \ (_ :: ()) -> Map.empty {-# INLINE rule127 #-} rule127 = \ (_ :: ()) -> [] {-# INLINE rule128 #-} rule128 = \ ((_attrsIuseMap) :: Map NontermIdent (Map Identifier (String,String,String))) -> _attrsIuseMap {-# INLINE rule129 #-} rule129 = \ (_ :: ()) -> Set.empty {-# INLINE rule130 #-} rule130 = \ ((_attrsIattrDecls) :: Map NontermIdent (Attributes, Attributes)) -> _attrsIattrDecls {-# INLINE rule131 #-} rule131 = \ ((_attrsIattrs) :: Map NontermIdent (Attributes, Attributes)) -> _attrsIattrs {-# INLINE rule132 #-} rule132 = \ ((_lhsIdefSets) :: Map Identifier (Set NontermIdent,Set Identifier)) -> _lhsIdefSets {-# INLINE rule133 #-} rule133 = \ ((_lhsIallFields) :: DataTypes) -> _lhsIallFields {-# INLINE rule134 #-} rule134 = \ ((_lhsIallNonterminals) :: Set NontermIdent) -> _lhsIallNonterminals {-# INLINE rule135 #-} rule135 = \ ((_lhsIdefinedSets) :: DefinedSets) -> _lhsIdefinedSets {-# INLINE rule136 #-} rule136 = \ ((_lhsIallFields) :: DataTypes) -> _lhsIallFields {-# INLINE rule137 #-} rule137 = \ ((_lhsIallNonterminals) :: Set NontermIdent) -> _lhsIallNonterminals {-# INLINE rule138 #-} rule138 = \ ((_lhsIattrDecls) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIattrDecls {-# INLINE rule139 #-} rule139 = \ ((_lhsIattrs) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIattrs {-# INLINE rule140 #-} rule140 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule141 #-} rule141 = \ ((_lhsIallConstructors) :: Map NontermIdent (Set ConstructorIdent)) -> _lhsIallConstructors {-# INLINE rule142 #-} rule142 = \ ((_lhsIallNonterminals) :: Set NontermIdent) -> _lhsIallNonterminals {-# NOINLINE sem_Elem_Type #-} sem_Elem_Type :: (Pos) -> (ClassContext) -> (NontermIdent) -> ([Identifier]) -> (ComplexType) -> T_Elem sem_Elem_Type arg_pos_ arg_ctx_ arg_name_ arg_params_ arg_type_ = T_Elem (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_Elem_v16 v16 = \ (T_Elem_vIn16 _lhsIallAttrDecls _lhsIallAttrs _lhsIallConstructors _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsIattrs _lhsIdefSets _lhsIdefinedSets _lhsIoptions) -> ( let _lhsOcollectedFields :: [(NontermIdent, ConstructorIdent, FieldMap)] _lhsOcollectedFields = rule143 _expanded arg_name_ _lhsOcollectedNames :: Set Identifier _lhsOcollectedNames = rule144 arg_name_ _expanded = rule145 _argType arg_name_ arg_params_ arg_pos_ _argType = rule146 _lhsIallNonterminals arg_type_ _lhsOtypeSyns :: TypeSyns _lhsOtypeSyns = rule147 _argType arg_name_ _lhsOparamsCollect :: ParamMap _lhsOparamsCollect = rule148 arg_name_ arg_params_ _lhsOctxCollect :: ContextMap _lhsOctxCollect = rule149 arg_ctx_ arg_name_ _lhsOattrOrderCollect :: AttrOrderMap _lhsOattrOrderCollect = rule150 () _lhsOblocks :: Blocks _lhsOblocks = rule151 () _lhsOcollectedArounds :: [ (NontermIdent, ConstructorIdent, [AroundInfo]) ] _lhsOcollectedArounds = rule152 () _lhsOcollectedAugments :: [ (NontermIdent, ConstructorIdent, [AugmentInfo]) ] _lhsOcollectedAugments = rule153 () _lhsOcollectedConParams :: [(NontermIdent, ConstructorIdent, Set Identifier)] _lhsOcollectedConParams = rule154 () _lhsOcollectedConstraints :: [(NontermIdent, ConstructorIdent, [Type])] _lhsOcollectedConstraints = rule155 () _lhsOcollectedConstructorsMap :: Map NontermIdent (Set ConstructorIdent) _lhsOcollectedConstructorsMap = rule156 () _lhsOcollectedInsts :: [ (NontermIdent, ConstructorIdent, [Identifier]) ] _lhsOcollectedInsts = rule157 () _lhsOcollectedMacros :: [(NontermIdent, ConstructorIdent, MaybeMacro)] _lhsOcollectedMacros = rule158 () _lhsOcollectedMerges :: [ (NontermIdent, ConstructorIdent, [MergeInfo]) ] _lhsOcollectedMerges = rule159 () _lhsOcollectedRules :: [ (NontermIdent, ConstructorIdent, RuleInfo)] _lhsOcollectedRules = rule160 () _lhsOcollectedSetNames :: Set Identifier _lhsOcollectedSetNames = rule161 () _lhsOcollectedSigs :: [ (NontermIdent, ConstructorIdent, SigInfo) ] _lhsOcollectedSigs = rule162 () _lhsOcollectedUniques :: [ (NontermIdent, ConstructorIdent, [UniqueInfo]) ] _lhsOcollectedUniques = rule163 () _lhsOderivings :: Derivings _lhsOderivings = rule164 () _lhsOerrors :: Seq Error _lhsOerrors = rule165 () _lhsOmoduleDecl :: Maybe (String,String,String) _lhsOmoduleDecl = rule166 () _lhsOpragmas :: Options -> Options _lhsOpragmas = rule167 () _lhsOquantCollect :: QuantMap _lhsOquantCollect = rule168 () _lhsOsemPragmasCollect :: PragmaMap _lhsOsemPragmasCollect = rule169 () _lhsOuseMap :: Map NontermIdent (Map Identifier (String,String,String)) _lhsOuseMap = rule170 () _lhsOwrappers :: Set NontermIdent _lhsOwrappers = rule171 () _lhsOattrDecls :: Map NontermIdent (Attributes, Attributes) _lhsOattrDecls = rule172 _lhsIattrDecls _lhsOattrs :: Map NontermIdent (Attributes, Attributes) _lhsOattrs = rule173 _lhsIattrs _lhsOdefSets :: Map Identifier (Set NontermIdent,Set Identifier) _lhsOdefSets = rule174 _lhsIdefSets __result_ = T_Elem_vOut16 _lhsOattrDecls _lhsOattrOrderCollect _lhsOattrs _lhsOblocks _lhsOcollectedArounds _lhsOcollectedAugments _lhsOcollectedConParams _lhsOcollectedConstraints _lhsOcollectedConstructorsMap _lhsOcollectedFields _lhsOcollectedInsts _lhsOcollectedMacros _lhsOcollectedMerges _lhsOcollectedNames _lhsOcollectedRules _lhsOcollectedSetNames _lhsOcollectedSigs _lhsOcollectedUniques _lhsOctxCollect _lhsOdefSets _lhsOderivings _lhsOerrors _lhsOmoduleDecl _lhsOparamsCollect _lhsOpragmas _lhsOquantCollect _lhsOsemPragmasCollect _lhsOtypeSyns _lhsOuseMap _lhsOwrappers in __result_ ) in C_Elem_s17 v16 {-# INLINE rule143 #-} {-# LINE 254 "./src-ag/Transform.ag" #-} rule143 = \ _expanded name_ -> {-# LINE 254 "./src-ag/Transform.ag" #-} map (\(x,y)->(name_, x, y)) _expanded {-# LINE 1866 "dist/build/Transform.hs"#-} {-# INLINE rule144 #-} {-# LINE 600 "./src-ag/Transform.ag" #-} rule144 = \ name_ -> {-# LINE 600 "./src-ag/Transform.ag" #-} Set.singleton name_ {-# LINE 1872 "dist/build/Transform.hs"#-} {-# INLINE rule145 #-} {-# LINE 654 "./src-ag/Transform.ag" #-} rule145 = \ _argType name_ params_ pos_ -> {-# LINE 654 "./src-ag/Transform.ag" #-} 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)] {-# LINE 1914 "dist/build/Transform.hs"#-} {-# INLINE rule146 #-} {-# LINE 691 "./src-ag/Transform.ag" #-} rule146 = \ ((_lhsIallNonterminals) :: Set NontermIdent) type_ -> {-# LINE 691 "./src-ag/Transform.ag" #-} case type_ of Maybe tp -> Maybe ( makeType _lhsIallNonterminals tp) Either tp1 tp2 -> Either ( makeType _lhsIallNonterminals tp1) (makeType _lhsIallNonterminals tp2) List tp -> List ( makeType _lhsIallNonterminals tp) Tuple xs -> Tuple [(f,makeType _lhsIallNonterminals tp) | (f,tp) <- xs] Map tp1 tp2 -> Map ( makeType _lhsIallNonterminals tp1) (makeType _lhsIallNonterminals tp2) IntMap tp -> IntMap ( makeType _lhsIallNonterminals tp) OrdSet tp -> OrdSet ( makeType _lhsIallNonterminals tp) IntSet -> IntSet {-# LINE 1928 "dist/build/Transform.hs"#-} {-# INLINE rule147 #-} {-# LINE 700 "./src-ag/Transform.ag" #-} rule147 = \ _argType name_ -> {-# LINE 700 "./src-ag/Transform.ag" #-} [(name_,_argType)] {-# LINE 1934 "dist/build/Transform.hs"#-} {-# INLINE rule148 #-} {-# LINE 953 "./src-ag/Transform.ag" #-} rule148 = \ name_ params_ -> {-# LINE 953 "./src-ag/Transform.ag" #-} if null params_ then Map.empty else Map.singleton name_ params_ {-# LINE 1942 "dist/build/Transform.hs"#-} {-# INLINE rule149 #-} {-# LINE 976 "./src-ag/Transform.ag" #-} rule149 = \ ctx_ name_ -> {-# LINE 976 "./src-ag/Transform.ag" #-} if null ctx_ then Map.empty else Map.singleton name_ ctx_ {-# LINE 1950 "dist/build/Transform.hs"#-} {-# INLINE rule150 #-} rule150 = \ (_ :: ()) -> Map.empty {-# INLINE rule151 #-} rule151 = \ (_ :: ()) -> Map.empty {-# INLINE rule152 #-} rule152 = \ (_ :: ()) -> [] {-# INLINE rule153 #-} rule153 = \ (_ :: ()) -> [] {-# INLINE rule154 #-} rule154 = \ (_ :: ()) -> [] {-# INLINE rule155 #-} rule155 = \ (_ :: ()) -> [] {-# INLINE rule156 #-} rule156 = \ (_ :: ()) -> Map.empty {-# INLINE rule157 #-} rule157 = \ (_ :: ()) -> [] {-# INLINE rule158 #-} rule158 = \ (_ :: ()) -> [] {-# INLINE rule159 #-} rule159 = \ (_ :: ()) -> [] {-# INLINE rule160 #-} rule160 = \ (_ :: ()) -> [] {-# INLINE rule161 #-} rule161 = \ (_ :: ()) -> Set.empty {-# INLINE rule162 #-} rule162 = \ (_ :: ()) -> [] {-# INLINE rule163 #-} rule163 = \ (_ :: ()) -> [] {-# INLINE rule164 #-} rule164 = \ (_ :: ()) -> Map.empty {-# INLINE rule165 #-} rule165 = \ (_ :: ()) -> Seq.empty {-# INLINE rule166 #-} rule166 = \ (_ :: ()) -> mzero {-# INLINE rule167 #-} rule167 = \ (_ :: ()) -> id {-# INLINE rule168 #-} rule168 = \ (_ :: ()) -> Map.empty {-# INLINE rule169 #-} rule169 = \ (_ :: ()) -> Map.empty {-# INLINE rule170 #-} rule170 = \ (_ :: ()) -> Map.empty {-# INLINE rule171 #-} rule171 = \ (_ :: ()) -> Set.empty {-# INLINE rule172 #-} rule172 = \ ((_lhsIattrDecls) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIattrDecls {-# INLINE rule173 #-} rule173 = \ ((_lhsIattrs) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIattrs {-# INLINE rule174 #-} rule174 = \ ((_lhsIdefSets) :: Map Identifier (Set NontermIdent,Set Identifier)) -> _lhsIdefSets {-# NOINLINE sem_Elem_Attr #-} sem_Elem_Attr :: (Pos) -> (ClassContext) -> T_NontSet -> ([String]) -> T_Attrs -> T_Elem sem_Elem_Attr _ arg_ctx_ arg_names_ arg_quants_ arg_attrs_ = T_Elem (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_Elem_v16 v16 = \ (T_Elem_vIn16 _lhsIallAttrDecls _lhsIallAttrs _lhsIallConstructors _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsIattrs _lhsIdefSets _lhsIdefinedSets _lhsIoptions) -> ( let _namesX29 = Control.Monad.Identity.runIdentity (attach_T_NontSet (arg_names_)) _attrsX11 = Control.Monad.Identity.runIdentity (attach_T_Attrs (arg_attrs_)) (T_NontSet_vOut28 _namesIcollectedNames _namesIerrors _namesInontSet) = inv_NontSet_s29 _namesX29 (T_NontSet_vIn28 _namesOallFields _namesOallNonterminals _namesOdefinedSets) (T_Attrs_vOut10 _attrsIattrDecls _attrsIattrs _attrsIerrors _attrsIuseMap) = inv_Attrs_s11 _attrsX11 (T_Attrs_vIn10 _attrsOallFields _attrsOallNonterminals _attrsOattrDecls _attrsOattrs _attrsOnts _attrsOoptions) _lhsOctxCollect :: ContextMap _lhsOctxCollect = rule175 _namesInontSet arg_ctx_ _lhsOquantCollect :: QuantMap _lhsOquantCollect = rule176 _namesInontSet arg_quants_ _attrsOnts = rule177 _namesInontSet _lhsOattrOrderCollect :: AttrOrderMap _lhsOattrOrderCollect = rule178 () _lhsOblocks :: Blocks _lhsOblocks = rule179 () _lhsOcollectedArounds :: [ (NontermIdent, ConstructorIdent, [AroundInfo]) ] _lhsOcollectedArounds = rule180 () _lhsOcollectedAugments :: [ (NontermIdent, ConstructorIdent, [AugmentInfo]) ] _lhsOcollectedAugments = rule181 () _lhsOcollectedConParams :: [(NontermIdent, ConstructorIdent, Set Identifier)] _lhsOcollectedConParams = rule182 () _lhsOcollectedConstraints :: [(NontermIdent, ConstructorIdent, [Type])] _lhsOcollectedConstraints = rule183 () _lhsOcollectedConstructorsMap :: Map NontermIdent (Set ConstructorIdent) _lhsOcollectedConstructorsMap = rule184 () _lhsOcollectedFields :: [(NontermIdent, ConstructorIdent, FieldMap)] _lhsOcollectedFields = rule185 () _lhsOcollectedInsts :: [ (NontermIdent, ConstructorIdent, [Identifier]) ] _lhsOcollectedInsts = rule186 () _lhsOcollectedMacros :: [(NontermIdent, ConstructorIdent, MaybeMacro)] _lhsOcollectedMacros = rule187 () _lhsOcollectedMerges :: [ (NontermIdent, ConstructorIdent, [MergeInfo]) ] _lhsOcollectedMerges = rule188 () _lhsOcollectedNames :: Set Identifier _lhsOcollectedNames = rule189 _namesIcollectedNames _lhsOcollectedRules :: [ (NontermIdent, ConstructorIdent, RuleInfo)] _lhsOcollectedRules = rule190 () _lhsOcollectedSetNames :: Set Identifier _lhsOcollectedSetNames = rule191 () _lhsOcollectedSigs :: [ (NontermIdent, ConstructorIdent, SigInfo) ] _lhsOcollectedSigs = rule192 () _lhsOcollectedUniques :: [ (NontermIdent, ConstructorIdent, [UniqueInfo]) ] _lhsOcollectedUniques = rule193 () _lhsOderivings :: Derivings _lhsOderivings = rule194 () _lhsOerrors :: Seq Error _lhsOerrors = rule195 _attrsIerrors _namesIerrors _lhsOmoduleDecl :: Maybe (String,String,String) _lhsOmoduleDecl = rule196 () _lhsOparamsCollect :: ParamMap _lhsOparamsCollect = rule197 () _lhsOpragmas :: Options -> Options _lhsOpragmas = rule198 () _lhsOsemPragmasCollect :: PragmaMap _lhsOsemPragmasCollect = rule199 () _lhsOtypeSyns :: TypeSyns _lhsOtypeSyns = rule200 () _lhsOuseMap :: Map NontermIdent (Map Identifier (String,String,String)) _lhsOuseMap = rule201 _attrsIuseMap _lhsOwrappers :: Set NontermIdent _lhsOwrappers = rule202 () _lhsOattrDecls :: Map NontermIdent (Attributes, Attributes) _lhsOattrDecls = rule203 _attrsIattrDecls _lhsOattrs :: Map NontermIdent (Attributes, Attributes) _lhsOattrs = rule204 _attrsIattrs _lhsOdefSets :: Map Identifier (Set NontermIdent,Set Identifier) _lhsOdefSets = rule205 _lhsIdefSets _namesOallFields = rule206 _lhsIallFields _namesOallNonterminals = rule207 _lhsIallNonterminals _namesOdefinedSets = rule208 _lhsIdefinedSets _attrsOallFields = rule209 _lhsIallFields _attrsOallNonterminals = rule210 _lhsIallNonterminals _attrsOattrDecls = rule211 _lhsIattrDecls _attrsOattrs = rule212 _lhsIattrs _attrsOoptions = rule213 _lhsIoptions __result_ = T_Elem_vOut16 _lhsOattrDecls _lhsOattrOrderCollect _lhsOattrs _lhsOblocks _lhsOcollectedArounds _lhsOcollectedAugments _lhsOcollectedConParams _lhsOcollectedConstraints _lhsOcollectedConstructorsMap _lhsOcollectedFields _lhsOcollectedInsts _lhsOcollectedMacros _lhsOcollectedMerges _lhsOcollectedNames _lhsOcollectedRules _lhsOcollectedSetNames _lhsOcollectedSigs _lhsOcollectedUniques _lhsOctxCollect _lhsOdefSets _lhsOderivings _lhsOerrors _lhsOmoduleDecl _lhsOparamsCollect _lhsOpragmas _lhsOquantCollect _lhsOsemPragmasCollect _lhsOtypeSyns _lhsOuseMap _lhsOwrappers in __result_ ) in C_Elem_s17 v16 {-# INLINE rule175 #-} {-# LINE 970 "./src-ag/Transform.ag" #-} rule175 = \ ((_namesInontSet) :: Set NontermIdent) ctx_ -> {-# LINE 970 "./src-ag/Transform.ag" #-} if null ctx_ then Map.empty else Map.fromList [(nt, ctx_) | nt <- Set.toList _namesInontSet] {-# LINE 2116 "dist/build/Transform.hs"#-} {-# INLINE rule176 #-} {-# LINE 995 "./src-ag/Transform.ag" #-} rule176 = \ ((_namesInontSet) :: Set NontermIdent) quants_ -> {-# LINE 995 "./src-ag/Transform.ag" #-} if null quants_ then Map.empty else Map.fromList [(nt, quants_) | nt <- Set.toList _namesInontSet] {-# LINE 2124 "dist/build/Transform.hs"#-} {-# INLINE rule177 #-} {-# LINE 1033 "./src-ag/Transform.ag" #-} rule177 = \ ((_namesInontSet) :: Set NontermIdent) -> {-# LINE 1033 "./src-ag/Transform.ag" #-} _namesInontSet {-# LINE 2130 "dist/build/Transform.hs"#-} {-# INLINE rule178 #-} rule178 = \ (_ :: ()) -> Map.empty {-# INLINE rule179 #-} rule179 = \ (_ :: ()) -> Map.empty {-# INLINE rule180 #-} rule180 = \ (_ :: ()) -> [] {-# INLINE rule181 #-} rule181 = \ (_ :: ()) -> [] {-# INLINE rule182 #-} rule182 = \ (_ :: ()) -> [] {-# INLINE rule183 #-} rule183 = \ (_ :: ()) -> [] {-# INLINE rule184 #-} rule184 = \ (_ :: ()) -> Map.empty {-# INLINE rule185 #-} rule185 = \ (_ :: ()) -> [] {-# INLINE rule186 #-} rule186 = \ (_ :: ()) -> [] {-# INLINE rule187 #-} rule187 = \ (_ :: ()) -> [] {-# INLINE rule188 #-} rule188 = \ (_ :: ()) -> [] {-# INLINE rule189 #-} rule189 = \ ((_namesIcollectedNames) :: Set Identifier) -> _namesIcollectedNames {-# INLINE rule190 #-} rule190 = \ (_ :: ()) -> [] {-# INLINE rule191 #-} rule191 = \ (_ :: ()) -> Set.empty {-# INLINE rule192 #-} rule192 = \ (_ :: ()) -> [] {-# INLINE rule193 #-} rule193 = \ (_ :: ()) -> [] {-# INLINE rule194 #-} rule194 = \ (_ :: ()) -> Map.empty {-# INLINE rule195 #-} rule195 = \ ((_attrsIerrors) :: Seq Error) ((_namesIerrors) :: Seq Error) -> _namesIerrors Seq.>< _attrsIerrors {-# INLINE rule196 #-} rule196 = \ (_ :: ()) -> mzero {-# INLINE rule197 #-} rule197 = \ (_ :: ()) -> Map.empty {-# INLINE rule198 #-} rule198 = \ (_ :: ()) -> id {-# INLINE rule199 #-} rule199 = \ (_ :: ()) -> Map.empty {-# INLINE rule200 #-} rule200 = \ (_ :: ()) -> [] {-# INLINE rule201 #-} rule201 = \ ((_attrsIuseMap) :: Map NontermIdent (Map Identifier (String,String,String))) -> _attrsIuseMap {-# INLINE rule202 #-} rule202 = \ (_ :: ()) -> Set.empty {-# INLINE rule203 #-} rule203 = \ ((_attrsIattrDecls) :: Map NontermIdent (Attributes, Attributes)) -> _attrsIattrDecls {-# INLINE rule204 #-} rule204 = \ ((_attrsIattrs) :: Map NontermIdent (Attributes, Attributes)) -> _attrsIattrs {-# INLINE rule205 #-} rule205 = \ ((_lhsIdefSets) :: Map Identifier (Set NontermIdent,Set Identifier)) -> _lhsIdefSets {-# INLINE rule206 #-} rule206 = \ ((_lhsIallFields) :: DataTypes) -> _lhsIallFields {-# INLINE rule207 #-} rule207 = \ ((_lhsIallNonterminals) :: Set NontermIdent) -> _lhsIallNonterminals {-# INLINE rule208 #-} rule208 = \ ((_lhsIdefinedSets) :: DefinedSets) -> _lhsIdefinedSets {-# INLINE rule209 #-} rule209 = \ ((_lhsIallFields) :: DataTypes) -> _lhsIallFields {-# INLINE rule210 #-} rule210 = \ ((_lhsIallNonterminals) :: Set NontermIdent) -> _lhsIallNonterminals {-# INLINE rule211 #-} rule211 = \ ((_lhsIattrDecls) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIattrDecls {-# INLINE rule212 #-} rule212 = \ ((_lhsIattrs) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIattrs {-# INLINE rule213 #-} rule213 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Elem_Sem #-} sem_Elem_Sem :: (Pos) -> (ClassContext) -> T_NontSet -> T_Attrs -> ([String]) -> T_SemAlts -> T_Elem sem_Elem_Sem _ arg_ctx_ arg_names_ arg_attrs_ arg_quants_ arg_alts_ = T_Elem (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_Elem_v16 v16 = \ (T_Elem_vIn16 _lhsIallAttrDecls _lhsIallAttrs _lhsIallConstructors _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsIattrs _lhsIdefSets _lhsIdefinedSets _lhsIoptions) -> ( let _namesX29 = Control.Monad.Identity.runIdentity (attach_T_NontSet (arg_names_)) _attrsX11 = Control.Monad.Identity.runIdentity (attach_T_Attrs (arg_attrs_)) _altsX41 = Control.Monad.Identity.runIdentity (attach_T_SemAlts (arg_alts_)) (T_NontSet_vOut28 _namesIcollectedNames _namesIerrors _namesInontSet) = inv_NontSet_s29 _namesX29 (T_NontSet_vIn28 _namesOallFields _namesOallNonterminals _namesOdefinedSets) (T_Attrs_vOut10 _attrsIattrDecls _attrsIattrs _attrsIerrors _attrsIuseMap) = inv_Attrs_s11 _attrsX11 (T_Attrs_vIn10 _attrsOallFields _attrsOallNonterminals _attrsOattrDecls _attrsOattrs _attrsOnts _attrsOoptions) (T_SemAlts_vOut40 _altsIattrOrderCollect _altsIcollectedArounds _altsIcollectedAugments _altsIcollectedInsts _altsIcollectedMerges _altsIcollectedRules _altsIcollectedSigs _altsIcollectedUniques _altsIerrors _altsIsemPragmasCollect) = inv_SemAlts_s41 _altsX41 (T_SemAlts_vIn40 _altsOallAttrDecls _altsOallAttrs _altsOallFields _altsOnts _altsOoptions) _altsOnts = rule214 _namesInontSet _lhsOctxCollect :: ContextMap _lhsOctxCollect = rule215 _namesInontSet arg_ctx_ _lhsOquantCollect :: QuantMap _lhsOquantCollect = rule216 _namesInontSet arg_quants_ _attrsOnts = rule217 _namesInontSet _lhsOattrOrderCollect :: AttrOrderMap _lhsOattrOrderCollect = rule218 _altsIattrOrderCollect _lhsOblocks :: Blocks _lhsOblocks = rule219 () _lhsOcollectedArounds :: [ (NontermIdent, ConstructorIdent, [AroundInfo]) ] _lhsOcollectedArounds = rule220 _altsIcollectedArounds _lhsOcollectedAugments :: [ (NontermIdent, ConstructorIdent, [AugmentInfo]) ] _lhsOcollectedAugments = rule221 _altsIcollectedAugments _lhsOcollectedConParams :: [(NontermIdent, ConstructorIdent, Set Identifier)] _lhsOcollectedConParams = rule222 () _lhsOcollectedConstraints :: [(NontermIdent, ConstructorIdent, [Type])] _lhsOcollectedConstraints = rule223 () _lhsOcollectedConstructorsMap :: Map NontermIdent (Set ConstructorIdent) _lhsOcollectedConstructorsMap = rule224 () _lhsOcollectedFields :: [(NontermIdent, ConstructorIdent, FieldMap)] _lhsOcollectedFields = rule225 () _lhsOcollectedInsts :: [ (NontermIdent, ConstructorIdent, [Identifier]) ] _lhsOcollectedInsts = rule226 _altsIcollectedInsts _lhsOcollectedMacros :: [(NontermIdent, ConstructorIdent, MaybeMacro)] _lhsOcollectedMacros = rule227 () _lhsOcollectedMerges :: [ (NontermIdent, ConstructorIdent, [MergeInfo]) ] _lhsOcollectedMerges = rule228 _altsIcollectedMerges _lhsOcollectedNames :: Set Identifier _lhsOcollectedNames = rule229 _namesIcollectedNames _lhsOcollectedRules :: [ (NontermIdent, ConstructorIdent, RuleInfo)] _lhsOcollectedRules = rule230 _altsIcollectedRules _lhsOcollectedSetNames :: Set Identifier _lhsOcollectedSetNames = rule231 () _lhsOcollectedSigs :: [ (NontermIdent, ConstructorIdent, SigInfo) ] _lhsOcollectedSigs = rule232 _altsIcollectedSigs _lhsOcollectedUniques :: [ (NontermIdent, ConstructorIdent, [UniqueInfo]) ] _lhsOcollectedUniques = rule233 _altsIcollectedUniques _lhsOderivings :: Derivings _lhsOderivings = rule234 () _lhsOerrors :: Seq Error _lhsOerrors = rule235 _altsIerrors _attrsIerrors _namesIerrors _lhsOmoduleDecl :: Maybe (String,String,String) _lhsOmoduleDecl = rule236 () _lhsOparamsCollect :: ParamMap _lhsOparamsCollect = rule237 () _lhsOpragmas :: Options -> Options _lhsOpragmas = rule238 () _lhsOsemPragmasCollect :: PragmaMap _lhsOsemPragmasCollect = rule239 _altsIsemPragmasCollect _lhsOtypeSyns :: TypeSyns _lhsOtypeSyns = rule240 () _lhsOuseMap :: Map NontermIdent (Map Identifier (String,String,String)) _lhsOuseMap = rule241 _attrsIuseMap _lhsOwrappers :: Set NontermIdent _lhsOwrappers = rule242 () _lhsOattrDecls :: Map NontermIdent (Attributes, Attributes) _lhsOattrDecls = rule243 _attrsIattrDecls _lhsOattrs :: Map NontermIdent (Attributes, Attributes) _lhsOattrs = rule244 _attrsIattrs _lhsOdefSets :: Map Identifier (Set NontermIdent,Set Identifier) _lhsOdefSets = rule245 _lhsIdefSets _namesOallFields = rule246 _lhsIallFields _namesOallNonterminals = rule247 _lhsIallNonterminals _namesOdefinedSets = rule248 _lhsIdefinedSets _attrsOallFields = rule249 _lhsIallFields _attrsOallNonterminals = rule250 _lhsIallNonterminals _attrsOattrDecls = rule251 _lhsIattrDecls _attrsOattrs = rule252 _lhsIattrs _attrsOoptions = rule253 _lhsIoptions _altsOallAttrDecls = rule254 _lhsIallAttrDecls _altsOallAttrs = rule255 _lhsIallAttrs _altsOallFields = rule256 _lhsIallFields _altsOoptions = rule257 _lhsIoptions __result_ = T_Elem_vOut16 _lhsOattrDecls _lhsOattrOrderCollect _lhsOattrs _lhsOblocks _lhsOcollectedArounds _lhsOcollectedAugments _lhsOcollectedConParams _lhsOcollectedConstraints _lhsOcollectedConstructorsMap _lhsOcollectedFields _lhsOcollectedInsts _lhsOcollectedMacros _lhsOcollectedMerges _lhsOcollectedNames _lhsOcollectedRules _lhsOcollectedSetNames _lhsOcollectedSigs _lhsOcollectedUniques _lhsOctxCollect _lhsOdefSets _lhsOderivings _lhsOerrors _lhsOmoduleDecl _lhsOparamsCollect _lhsOpragmas _lhsOquantCollect _lhsOsemPragmasCollect _lhsOtypeSyns _lhsOuseMap _lhsOwrappers in __result_ ) in C_Elem_s17 v16 {-# INLINE rule214 #-} {-# LINE 177 "./src-ag/Transform.ag" #-} rule214 = \ ((_namesInontSet) :: Set NontermIdent) -> {-# LINE 177 "./src-ag/Transform.ag" #-} _namesInontSet {-# LINE 2334 "dist/build/Transform.hs"#-} {-# INLINE rule215 #-} {-# LINE 970 "./src-ag/Transform.ag" #-} rule215 = \ ((_namesInontSet) :: Set NontermIdent) ctx_ -> {-# LINE 970 "./src-ag/Transform.ag" #-} if null ctx_ then Map.empty else Map.fromList [(nt, ctx_) | nt <- Set.toList _namesInontSet] {-# LINE 2342 "dist/build/Transform.hs"#-} {-# INLINE rule216 #-} {-# LINE 995 "./src-ag/Transform.ag" #-} rule216 = \ ((_namesInontSet) :: Set NontermIdent) quants_ -> {-# LINE 995 "./src-ag/Transform.ag" #-} if null quants_ then Map.empty else Map.fromList [(nt, quants_) | nt <- Set.toList _namesInontSet] {-# LINE 2350 "dist/build/Transform.hs"#-} {-# INLINE rule217 #-} {-# LINE 1034 "./src-ag/Transform.ag" #-} rule217 = \ ((_namesInontSet) :: Set NontermIdent) -> {-# LINE 1034 "./src-ag/Transform.ag" #-} _namesInontSet {-# LINE 2356 "dist/build/Transform.hs"#-} {-# INLINE rule218 #-} rule218 = \ ((_altsIattrOrderCollect) :: AttrOrderMap) -> _altsIattrOrderCollect {-# INLINE rule219 #-} rule219 = \ (_ :: ()) -> Map.empty {-# INLINE rule220 #-} rule220 = \ ((_altsIcollectedArounds) :: [ (NontermIdent, ConstructorIdent, [AroundInfo]) ]) -> _altsIcollectedArounds {-# INLINE rule221 #-} rule221 = \ ((_altsIcollectedAugments) :: [ (NontermIdent, ConstructorIdent, [AugmentInfo]) ]) -> _altsIcollectedAugments {-# INLINE rule222 #-} rule222 = \ (_ :: ()) -> [] {-# INLINE rule223 #-} rule223 = \ (_ :: ()) -> [] {-# INLINE rule224 #-} rule224 = \ (_ :: ()) -> Map.empty {-# INLINE rule225 #-} rule225 = \ (_ :: ()) -> [] {-# INLINE rule226 #-} rule226 = \ ((_altsIcollectedInsts) :: [ (NontermIdent, ConstructorIdent, [Identifier]) ]) -> _altsIcollectedInsts {-# INLINE rule227 #-} rule227 = \ (_ :: ()) -> [] {-# INLINE rule228 #-} rule228 = \ ((_altsIcollectedMerges) :: [ (NontermIdent, ConstructorIdent, [MergeInfo]) ]) -> _altsIcollectedMerges {-# INLINE rule229 #-} rule229 = \ ((_namesIcollectedNames) :: Set Identifier) -> _namesIcollectedNames {-# INLINE rule230 #-} rule230 = \ ((_altsIcollectedRules) :: [ (NontermIdent, ConstructorIdent, RuleInfo)]) -> _altsIcollectedRules {-# INLINE rule231 #-} rule231 = \ (_ :: ()) -> Set.empty {-# INLINE rule232 #-} rule232 = \ ((_altsIcollectedSigs) :: [ (NontermIdent, ConstructorIdent, SigInfo) ]) -> _altsIcollectedSigs {-# INLINE rule233 #-} rule233 = \ ((_altsIcollectedUniques) :: [ (NontermIdent, ConstructorIdent, [UniqueInfo]) ]) -> _altsIcollectedUniques {-# INLINE rule234 #-} rule234 = \ (_ :: ()) -> Map.empty {-# INLINE rule235 #-} rule235 = \ ((_altsIerrors) :: Seq Error) ((_attrsIerrors) :: Seq Error) ((_namesIerrors) :: Seq Error) -> _namesIerrors Seq.>< _attrsIerrors Seq.>< _altsIerrors {-# INLINE rule236 #-} rule236 = \ (_ :: ()) -> mzero {-# INLINE rule237 #-} rule237 = \ (_ :: ()) -> Map.empty {-# INLINE rule238 #-} rule238 = \ (_ :: ()) -> id {-# INLINE rule239 #-} rule239 = \ ((_altsIsemPragmasCollect) :: PragmaMap) -> _altsIsemPragmasCollect {-# INLINE rule240 #-} rule240 = \ (_ :: ()) -> [] {-# INLINE rule241 #-} rule241 = \ ((_attrsIuseMap) :: Map NontermIdent (Map Identifier (String,String,String))) -> _attrsIuseMap {-# INLINE rule242 #-} rule242 = \ (_ :: ()) -> Set.empty {-# INLINE rule243 #-} rule243 = \ ((_attrsIattrDecls) :: Map NontermIdent (Attributes, Attributes)) -> _attrsIattrDecls {-# INLINE rule244 #-} rule244 = \ ((_attrsIattrs) :: Map NontermIdent (Attributes, Attributes)) -> _attrsIattrs {-# INLINE rule245 #-} rule245 = \ ((_lhsIdefSets) :: Map Identifier (Set NontermIdent,Set Identifier)) -> _lhsIdefSets {-# INLINE rule246 #-} rule246 = \ ((_lhsIallFields) :: DataTypes) -> _lhsIallFields {-# INLINE rule247 #-} rule247 = \ ((_lhsIallNonterminals) :: Set NontermIdent) -> _lhsIallNonterminals {-# INLINE rule248 #-} rule248 = \ ((_lhsIdefinedSets) :: DefinedSets) -> _lhsIdefinedSets {-# INLINE rule249 #-} rule249 = \ ((_lhsIallFields) :: DataTypes) -> _lhsIallFields {-# INLINE rule250 #-} rule250 = \ ((_lhsIallNonterminals) :: Set NontermIdent) -> _lhsIallNonterminals {-# INLINE rule251 #-} rule251 = \ ((_lhsIattrDecls) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIattrDecls {-# INLINE rule252 #-} rule252 = \ ((_lhsIattrs) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIattrs {-# INLINE rule253 #-} rule253 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule254 #-} rule254 = \ ((_lhsIallAttrDecls) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIallAttrDecls {-# INLINE rule255 #-} rule255 = \ ((_lhsIallAttrs) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIallAttrs {-# INLINE rule256 #-} rule256 = \ ((_lhsIallFields) :: DataTypes) -> _lhsIallFields {-# INLINE rule257 #-} rule257 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Elem_Txt #-} sem_Elem_Txt :: (Pos) -> (BlockKind) -> (Maybe NontermIdent) -> ([String]) -> T_Elem sem_Elem_Txt arg_pos_ arg_kind_ arg_mbNt_ arg_lines_ = T_Elem (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_Elem_v16 v16 = \ (T_Elem_vIn16 _lhsIallAttrDecls _lhsIallAttrs _lhsIallConstructors _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsIattrs _lhsIdefSets _lhsIdefinedSets _lhsIoptions) -> ( let _blockInfo = rule258 arg_kind_ arg_mbNt_ _blockValue = rule259 arg_lines_ arg_pos_ _lhsOblocks :: Blocks _lhsOblocks = rule260 _blockInfo _blockValue _lhsOerrors :: Seq Error _lhsOerrors = rule261 _lhsIoptions arg_lines_ arg_pos_ _lhsOattrOrderCollect :: AttrOrderMap _lhsOattrOrderCollect = rule262 () _lhsOcollectedArounds :: [ (NontermIdent, ConstructorIdent, [AroundInfo]) ] _lhsOcollectedArounds = rule263 () _lhsOcollectedAugments :: [ (NontermIdent, ConstructorIdent, [AugmentInfo]) ] _lhsOcollectedAugments = rule264 () _lhsOcollectedConParams :: [(NontermIdent, ConstructorIdent, Set Identifier)] _lhsOcollectedConParams = rule265 () _lhsOcollectedConstraints :: [(NontermIdent, ConstructorIdent, [Type])] _lhsOcollectedConstraints = rule266 () _lhsOcollectedConstructorsMap :: Map NontermIdent (Set ConstructorIdent) _lhsOcollectedConstructorsMap = rule267 () _lhsOcollectedFields :: [(NontermIdent, ConstructorIdent, FieldMap)] _lhsOcollectedFields = rule268 () _lhsOcollectedInsts :: [ (NontermIdent, ConstructorIdent, [Identifier]) ] _lhsOcollectedInsts = rule269 () _lhsOcollectedMacros :: [(NontermIdent, ConstructorIdent, MaybeMacro)] _lhsOcollectedMacros = rule270 () _lhsOcollectedMerges :: [ (NontermIdent, ConstructorIdent, [MergeInfo]) ] _lhsOcollectedMerges = rule271 () _lhsOcollectedNames :: Set Identifier _lhsOcollectedNames = rule272 () _lhsOcollectedRules :: [ (NontermIdent, ConstructorIdent, RuleInfo)] _lhsOcollectedRules = rule273 () _lhsOcollectedSetNames :: Set Identifier _lhsOcollectedSetNames = rule274 () _lhsOcollectedSigs :: [ (NontermIdent, ConstructorIdent, SigInfo) ] _lhsOcollectedSigs = rule275 () _lhsOcollectedUniques :: [ (NontermIdent, ConstructorIdent, [UniqueInfo]) ] _lhsOcollectedUniques = rule276 () _lhsOctxCollect :: ContextMap _lhsOctxCollect = rule277 () _lhsOderivings :: Derivings _lhsOderivings = rule278 () _lhsOmoduleDecl :: Maybe (String,String,String) _lhsOmoduleDecl = rule279 () _lhsOparamsCollect :: ParamMap _lhsOparamsCollect = rule280 () _lhsOpragmas :: Options -> Options _lhsOpragmas = rule281 () _lhsOquantCollect :: QuantMap _lhsOquantCollect = rule282 () _lhsOsemPragmasCollect :: PragmaMap _lhsOsemPragmasCollect = rule283 () _lhsOtypeSyns :: TypeSyns _lhsOtypeSyns = rule284 () _lhsOuseMap :: Map NontermIdent (Map Identifier (String,String,String)) _lhsOuseMap = rule285 () _lhsOwrappers :: Set NontermIdent _lhsOwrappers = rule286 () _lhsOattrDecls :: Map NontermIdent (Attributes, Attributes) _lhsOattrDecls = rule287 _lhsIattrDecls _lhsOattrs :: Map NontermIdent (Attributes, Attributes) _lhsOattrs = rule288 _lhsIattrs _lhsOdefSets :: Map Identifier (Set NontermIdent,Set Identifier) _lhsOdefSets = rule289 _lhsIdefSets __result_ = T_Elem_vOut16 _lhsOattrDecls _lhsOattrOrderCollect _lhsOattrs _lhsOblocks _lhsOcollectedArounds _lhsOcollectedAugments _lhsOcollectedConParams _lhsOcollectedConstraints _lhsOcollectedConstructorsMap _lhsOcollectedFields _lhsOcollectedInsts _lhsOcollectedMacros _lhsOcollectedMerges _lhsOcollectedNames _lhsOcollectedRules _lhsOcollectedSetNames _lhsOcollectedSigs _lhsOcollectedUniques _lhsOctxCollect _lhsOdefSets _lhsOderivings _lhsOerrors _lhsOmoduleDecl _lhsOparamsCollect _lhsOpragmas _lhsOquantCollect _lhsOsemPragmasCollect _lhsOtypeSyns _lhsOuseMap _lhsOwrappers in __result_ ) in C_Elem_s17 v16 {-# INLINE rule258 #-} {-# LINE 186 "./src-ag/Transform.ag" #-} rule258 = \ kind_ mbNt_ -> {-# LINE 186 "./src-ag/Transform.ag" #-} ( kind_ , mbNt_ ) {-# LINE 2556 "dist/build/Transform.hs"#-} {-# INLINE rule259 #-} {-# LINE 189 "./src-ag/Transform.ag" #-} rule259 = \ lines_ pos_ -> {-# LINE 189 "./src-ag/Transform.ag" #-} [(lines_, pos_)] {-# LINE 2562 "dist/build/Transform.hs"#-} {-# INLINE rule260 #-} {-# LINE 190 "./src-ag/Transform.ag" #-} rule260 = \ _blockInfo _blockValue -> {-# LINE 190 "./src-ag/Transform.ag" #-} Map.singleton _blockInfo _blockValue {-# LINE 2568 "dist/build/Transform.hs"#-} {-# INLINE rule261 #-} {-# LINE 191 "./src-ag/Transform.ag" #-} rule261 = \ ((_lhsIoptions) :: Options) lines_ pos_ -> {-# LINE 191 "./src-ag/Transform.ag" #-} if checkParseBlock _lhsIoptions then let ex = Expression pos_ tks tks = [tk] tk = HsToken (unlines lines_) pos_ in Seq.fromList $ checkBlock $ ex else Seq.empty {-# LINE 2579 "dist/build/Transform.hs"#-} {-# INLINE rule262 #-} rule262 = \ (_ :: ()) -> Map.empty {-# INLINE rule263 #-} rule263 = \ (_ :: ()) -> [] {-# INLINE rule264 #-} rule264 = \ (_ :: ()) -> [] {-# INLINE rule265 #-} rule265 = \ (_ :: ()) -> [] {-# INLINE rule266 #-} rule266 = \ (_ :: ()) -> [] {-# INLINE rule267 #-} rule267 = \ (_ :: ()) -> Map.empty {-# INLINE rule268 #-} rule268 = \ (_ :: ()) -> [] {-# INLINE rule269 #-} rule269 = \ (_ :: ()) -> [] {-# INLINE rule270 #-} rule270 = \ (_ :: ()) -> [] {-# INLINE rule271 #-} rule271 = \ (_ :: ()) -> [] {-# INLINE rule272 #-} rule272 = \ (_ :: ()) -> Set.empty {-# INLINE rule273 #-} rule273 = \ (_ :: ()) -> [] {-# INLINE rule274 #-} rule274 = \ (_ :: ()) -> Set.empty {-# INLINE rule275 #-} rule275 = \ (_ :: ()) -> [] {-# INLINE rule276 #-} rule276 = \ (_ :: ()) -> [] {-# INLINE rule277 #-} rule277 = \ (_ :: ()) -> Map.empty {-# INLINE rule278 #-} rule278 = \ (_ :: ()) -> Map.empty {-# INLINE rule279 #-} rule279 = \ (_ :: ()) -> mzero {-# INLINE rule280 #-} rule280 = \ (_ :: ()) -> Map.empty {-# INLINE rule281 #-} rule281 = \ (_ :: ()) -> id {-# INLINE rule282 #-} rule282 = \ (_ :: ()) -> Map.empty {-# INLINE rule283 #-} rule283 = \ (_ :: ()) -> Map.empty {-# INLINE rule284 #-} rule284 = \ (_ :: ()) -> [] {-# INLINE rule285 #-} rule285 = \ (_ :: ()) -> Map.empty {-# INLINE rule286 #-} rule286 = \ (_ :: ()) -> Set.empty {-# INLINE rule287 #-} rule287 = \ ((_lhsIattrDecls) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIattrDecls {-# INLINE rule288 #-} rule288 = \ ((_lhsIattrs) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIattrs {-# INLINE rule289 #-} rule289 = \ ((_lhsIdefSets) :: Map Identifier (Set NontermIdent,Set Identifier)) -> _lhsIdefSets {-# NOINLINE sem_Elem_Set #-} sem_Elem_Set :: (Pos) -> (NontermIdent) -> (Bool) -> T_NontSet -> T_Elem sem_Elem_Set _ arg_name_ arg_merge_ arg_set_ = T_Elem (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_Elem_v16 v16 = \ (T_Elem_vIn16 _lhsIallAttrDecls _lhsIallAttrs _lhsIallConstructors _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsIattrs _lhsIdefSets _lhsIdefinedSets _lhsIoptions) -> ( let _setX29 = Control.Monad.Identity.runIdentity (attach_T_NontSet (arg_set_)) (T_NontSet_vOut28 _setIcollectedNames _setIerrors _setInontSet) = inv_NontSet_s29 _setX29 (T_NontSet_vIn28 _setOallFields _setOallNonterminals _setOdefinedSets) _lhsOcollectedSetNames :: Set Identifier _lhsOcollectedSetNames = rule290 arg_name_ (_defSets2,_errs) = rule291 _lhsIallNonterminals _lhsIdefSets _setIcollectedNames _setInontSet arg_merge_ arg_name_ _lhsOdefSets :: Map Identifier (Set NontermIdent,Set Identifier) _lhsOdefSets = rule292 _defSets2 _lhsOerrors :: Seq Error _lhsOerrors = rule293 _errs _setIerrors _lhsOattrOrderCollect :: AttrOrderMap _lhsOattrOrderCollect = rule294 () _lhsOblocks :: Blocks _lhsOblocks = rule295 () _lhsOcollectedArounds :: [ (NontermIdent, ConstructorIdent, [AroundInfo]) ] _lhsOcollectedArounds = rule296 () _lhsOcollectedAugments :: [ (NontermIdent, ConstructorIdent, [AugmentInfo]) ] _lhsOcollectedAugments = rule297 () _lhsOcollectedConParams :: [(NontermIdent, ConstructorIdent, Set Identifier)] _lhsOcollectedConParams = rule298 () _lhsOcollectedConstraints :: [(NontermIdent, ConstructorIdent, [Type])] _lhsOcollectedConstraints = rule299 () _lhsOcollectedConstructorsMap :: Map NontermIdent (Set ConstructorIdent) _lhsOcollectedConstructorsMap = rule300 () _lhsOcollectedFields :: [(NontermIdent, ConstructorIdent, FieldMap)] _lhsOcollectedFields = rule301 () _lhsOcollectedInsts :: [ (NontermIdent, ConstructorIdent, [Identifier]) ] _lhsOcollectedInsts = rule302 () _lhsOcollectedMacros :: [(NontermIdent, ConstructorIdent, MaybeMacro)] _lhsOcollectedMacros = rule303 () _lhsOcollectedMerges :: [ (NontermIdent, ConstructorIdent, [MergeInfo]) ] _lhsOcollectedMerges = rule304 () _lhsOcollectedNames :: Set Identifier _lhsOcollectedNames = rule305 _setIcollectedNames _lhsOcollectedRules :: [ (NontermIdent, ConstructorIdent, RuleInfo)] _lhsOcollectedRules = rule306 () _lhsOcollectedSigs :: [ (NontermIdent, ConstructorIdent, SigInfo) ] _lhsOcollectedSigs = rule307 () _lhsOcollectedUniques :: [ (NontermIdent, ConstructorIdent, [UniqueInfo]) ] _lhsOcollectedUniques = rule308 () _lhsOctxCollect :: ContextMap _lhsOctxCollect = rule309 () _lhsOderivings :: Derivings _lhsOderivings = rule310 () _lhsOmoduleDecl :: Maybe (String,String,String) _lhsOmoduleDecl = rule311 () _lhsOparamsCollect :: ParamMap _lhsOparamsCollect = rule312 () _lhsOpragmas :: Options -> Options _lhsOpragmas = rule313 () _lhsOquantCollect :: QuantMap _lhsOquantCollect = rule314 () _lhsOsemPragmasCollect :: PragmaMap _lhsOsemPragmasCollect = rule315 () _lhsOtypeSyns :: TypeSyns _lhsOtypeSyns = rule316 () _lhsOuseMap :: Map NontermIdent (Map Identifier (String,String,String)) _lhsOuseMap = rule317 () _lhsOwrappers :: Set NontermIdent _lhsOwrappers = rule318 () _lhsOattrDecls :: Map NontermIdent (Attributes, Attributes) _lhsOattrDecls = rule319 _lhsIattrDecls _lhsOattrs :: Map NontermIdent (Attributes, Attributes) _lhsOattrs = rule320 _lhsIattrs _setOallFields = rule321 _lhsIallFields _setOallNonterminals = rule322 _lhsIallNonterminals _setOdefinedSets = rule323 _lhsIdefinedSets __result_ = T_Elem_vOut16 _lhsOattrDecls _lhsOattrOrderCollect _lhsOattrs _lhsOblocks _lhsOcollectedArounds _lhsOcollectedAugments _lhsOcollectedConParams _lhsOcollectedConstraints _lhsOcollectedConstructorsMap _lhsOcollectedFields _lhsOcollectedInsts _lhsOcollectedMacros _lhsOcollectedMerges _lhsOcollectedNames _lhsOcollectedRules _lhsOcollectedSetNames _lhsOcollectedSigs _lhsOcollectedUniques _lhsOctxCollect _lhsOdefSets _lhsOderivings _lhsOerrors _lhsOmoduleDecl _lhsOparamsCollect _lhsOpragmas _lhsOquantCollect _lhsOsemPragmasCollect _lhsOtypeSyns _lhsOuseMap _lhsOwrappers in __result_ ) in C_Elem_s17 v16 {-# INLINE rule290 #-} {-# LINE 597 "./src-ag/Transform.ag" #-} rule290 = \ name_ -> {-# LINE 597 "./src-ag/Transform.ag" #-} Set.singleton name_ {-# LINE 2745 "dist/build/Transform.hs"#-} {-# INLINE rule291 #-} {-# LINE 714 "./src-ag/Transform.ag" #-} rule291 = \ ((_lhsIallNonterminals) :: Set NontermIdent) ((_lhsIdefSets) :: Map Identifier (Set NontermIdent,Set Identifier)) ((_setIcollectedNames) :: Set Identifier) ((_setInontSet) :: Set NontermIdent) merge_ name_ -> {-# LINE 714 "./src-ag/Transform.ag" #-} let allUsedNames = Set.unions [ maybe (Set.singleton n) snd (Map.lookup n _lhsIdefSets) | n <- Set.toList _setIcollectedNames ] (nontSet,e1) | Set.member name_ allUsedNames = (Set.empty, Seq.singleton(CyclicSet name_)) | otherwise = (_setInontSet, 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_ _lhsIallNonterminals || not merge_ then checkDuplicate DupSet name_ toAdd _lhsIdefSets else (Map.insertWith un name_ toAdd _lhsIdefSets, Seq.empty) in (res, e1 Seq.>< e2) {-# LINE 2764 "dist/build/Transform.hs"#-} {-# INLINE rule292 #-} {-# LINE 728 "./src-ag/Transform.ag" #-} rule292 = \ _defSets2 -> {-# LINE 728 "./src-ag/Transform.ag" #-} _defSets2 {-# LINE 2770 "dist/build/Transform.hs"#-} {-# INLINE rule293 #-} {-# LINE 729 "./src-ag/Transform.ag" #-} rule293 = \ _errs ((_setIerrors) :: Seq Error) -> {-# LINE 729 "./src-ag/Transform.ag" #-} _errs >< _setIerrors {-# LINE 2776 "dist/build/Transform.hs"#-} {-# INLINE rule294 #-} rule294 = \ (_ :: ()) -> Map.empty {-# INLINE rule295 #-} rule295 = \ (_ :: ()) -> Map.empty {-# INLINE rule296 #-} rule296 = \ (_ :: ()) -> [] {-# INLINE rule297 #-} rule297 = \ (_ :: ()) -> [] {-# INLINE rule298 #-} rule298 = \ (_ :: ()) -> [] {-# INLINE rule299 #-} rule299 = \ (_ :: ()) -> [] {-# INLINE rule300 #-} rule300 = \ (_ :: ()) -> Map.empty {-# INLINE rule301 #-} rule301 = \ (_ :: ()) -> [] {-# INLINE rule302 #-} rule302 = \ (_ :: ()) -> [] {-# INLINE rule303 #-} rule303 = \ (_ :: ()) -> [] {-# INLINE rule304 #-} rule304 = \ (_ :: ()) -> [] {-# INLINE rule305 #-} rule305 = \ ((_setIcollectedNames) :: Set Identifier) -> _setIcollectedNames {-# INLINE rule306 #-} rule306 = \ (_ :: ()) -> [] {-# INLINE rule307 #-} rule307 = \ (_ :: ()) -> [] {-# INLINE rule308 #-} rule308 = \ (_ :: ()) -> [] {-# INLINE rule309 #-} rule309 = \ (_ :: ()) -> Map.empty {-# INLINE rule310 #-} rule310 = \ (_ :: ()) -> Map.empty {-# INLINE rule311 #-} rule311 = \ (_ :: ()) -> mzero {-# INLINE rule312 #-} rule312 = \ (_ :: ()) -> Map.empty {-# INLINE rule313 #-} rule313 = \ (_ :: ()) -> id {-# INLINE rule314 #-} rule314 = \ (_ :: ()) -> Map.empty {-# INLINE rule315 #-} rule315 = \ (_ :: ()) -> Map.empty {-# INLINE rule316 #-} rule316 = \ (_ :: ()) -> [] {-# INLINE rule317 #-} rule317 = \ (_ :: ()) -> Map.empty {-# INLINE rule318 #-} rule318 = \ (_ :: ()) -> Set.empty {-# INLINE rule319 #-} rule319 = \ ((_lhsIattrDecls) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIattrDecls {-# INLINE rule320 #-} rule320 = \ ((_lhsIattrs) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIattrs {-# INLINE rule321 #-} rule321 = \ ((_lhsIallFields) :: DataTypes) -> _lhsIallFields {-# INLINE rule322 #-} rule322 = \ ((_lhsIallNonterminals) :: Set NontermIdent) -> _lhsIallNonterminals {-# INLINE rule323 #-} rule323 = \ ((_lhsIdefinedSets) :: DefinedSets) -> _lhsIdefinedSets {-# NOINLINE sem_Elem_Deriving #-} sem_Elem_Deriving :: (Pos) -> T_NontSet -> ([NontermIdent]) -> T_Elem sem_Elem_Deriving _ arg_set_ arg_classes_ = T_Elem (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_Elem_v16 v16 = \ (T_Elem_vIn16 _lhsIallAttrDecls _lhsIallAttrs _lhsIallConstructors _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsIattrs _lhsIdefSets _lhsIdefinedSets _lhsIoptions) -> ( let _setX29 = Control.Monad.Identity.runIdentity (attach_T_NontSet (arg_set_)) (T_NontSet_vOut28 _setIcollectedNames _setIerrors _setInontSet) = inv_NontSet_s29 _setX29 (T_NontSet_vIn28 _setOallFields _setOallNonterminals _setOdefinedSets) _lhsOderivings :: Derivings _lhsOderivings = rule324 _setInontSet arg_classes_ _lhsOattrOrderCollect :: AttrOrderMap _lhsOattrOrderCollect = rule325 () _lhsOblocks :: Blocks _lhsOblocks = rule326 () _lhsOcollectedArounds :: [ (NontermIdent, ConstructorIdent, [AroundInfo]) ] _lhsOcollectedArounds = rule327 () _lhsOcollectedAugments :: [ (NontermIdent, ConstructorIdent, [AugmentInfo]) ] _lhsOcollectedAugments = rule328 () _lhsOcollectedConParams :: [(NontermIdent, ConstructorIdent, Set Identifier)] _lhsOcollectedConParams = rule329 () _lhsOcollectedConstraints :: [(NontermIdent, ConstructorIdent, [Type])] _lhsOcollectedConstraints = rule330 () _lhsOcollectedConstructorsMap :: Map NontermIdent (Set ConstructorIdent) _lhsOcollectedConstructorsMap = rule331 () _lhsOcollectedFields :: [(NontermIdent, ConstructorIdent, FieldMap)] _lhsOcollectedFields = rule332 () _lhsOcollectedInsts :: [ (NontermIdent, ConstructorIdent, [Identifier]) ] _lhsOcollectedInsts = rule333 () _lhsOcollectedMacros :: [(NontermIdent, ConstructorIdent, MaybeMacro)] _lhsOcollectedMacros = rule334 () _lhsOcollectedMerges :: [ (NontermIdent, ConstructorIdent, [MergeInfo]) ] _lhsOcollectedMerges = rule335 () _lhsOcollectedNames :: Set Identifier _lhsOcollectedNames = rule336 _setIcollectedNames _lhsOcollectedRules :: [ (NontermIdent, ConstructorIdent, RuleInfo)] _lhsOcollectedRules = rule337 () _lhsOcollectedSetNames :: Set Identifier _lhsOcollectedSetNames = rule338 () _lhsOcollectedSigs :: [ (NontermIdent, ConstructorIdent, SigInfo) ] _lhsOcollectedSigs = rule339 () _lhsOcollectedUniques :: [ (NontermIdent, ConstructorIdent, [UniqueInfo]) ] _lhsOcollectedUniques = rule340 () _lhsOctxCollect :: ContextMap _lhsOctxCollect = rule341 () _lhsOerrors :: Seq Error _lhsOerrors = rule342 _setIerrors _lhsOmoduleDecl :: Maybe (String,String,String) _lhsOmoduleDecl = rule343 () _lhsOparamsCollect :: ParamMap _lhsOparamsCollect = rule344 () _lhsOpragmas :: Options -> Options _lhsOpragmas = rule345 () _lhsOquantCollect :: QuantMap _lhsOquantCollect = rule346 () _lhsOsemPragmasCollect :: PragmaMap _lhsOsemPragmasCollect = rule347 () _lhsOtypeSyns :: TypeSyns _lhsOtypeSyns = rule348 () _lhsOuseMap :: Map NontermIdent (Map Identifier (String,String,String)) _lhsOuseMap = rule349 () _lhsOwrappers :: Set NontermIdent _lhsOwrappers = rule350 () _lhsOattrDecls :: Map NontermIdent (Attributes, Attributes) _lhsOattrDecls = rule351 _lhsIattrDecls _lhsOattrs :: Map NontermIdent (Attributes, Attributes) _lhsOattrs = rule352 _lhsIattrs _lhsOdefSets :: Map Identifier (Set NontermIdent,Set Identifier) _lhsOdefSets = rule353 _lhsIdefSets _setOallFields = rule354 _lhsIallFields _setOallNonterminals = rule355 _lhsIallNonterminals _setOdefinedSets = rule356 _lhsIdefinedSets __result_ = T_Elem_vOut16 _lhsOattrDecls _lhsOattrOrderCollect _lhsOattrs _lhsOblocks _lhsOcollectedArounds _lhsOcollectedAugments _lhsOcollectedConParams _lhsOcollectedConstraints _lhsOcollectedConstructorsMap _lhsOcollectedFields _lhsOcollectedInsts _lhsOcollectedMacros _lhsOcollectedMerges _lhsOcollectedNames _lhsOcollectedRules _lhsOcollectedSetNames _lhsOcollectedSigs _lhsOcollectedUniques _lhsOctxCollect _lhsOdefSets _lhsOderivings _lhsOerrors _lhsOmoduleDecl _lhsOparamsCollect _lhsOpragmas _lhsOquantCollect _lhsOsemPragmasCollect _lhsOtypeSyns _lhsOuseMap _lhsOwrappers in __result_ ) in C_Elem_s17 v16 {-# INLINE rule324 #-} {-# LINE 1016 "./src-ag/Transform.ag" #-} rule324 = \ ((_setInontSet) :: Set NontermIdent) classes_ -> {-# LINE 1016 "./src-ag/Transform.ag" #-} Map.fromList [(nt,Set.fromList classes_) | nt <- Set.toList _setInontSet] {-# LINE 2947 "dist/build/Transform.hs"#-} {-# INLINE rule325 #-} rule325 = \ (_ :: ()) -> Map.empty {-# INLINE rule326 #-} rule326 = \ (_ :: ()) -> Map.empty {-# INLINE rule327 #-} rule327 = \ (_ :: ()) -> [] {-# INLINE rule328 #-} rule328 = \ (_ :: ()) -> [] {-# INLINE rule329 #-} rule329 = \ (_ :: ()) -> [] {-# INLINE rule330 #-} rule330 = \ (_ :: ()) -> [] {-# INLINE rule331 #-} rule331 = \ (_ :: ()) -> Map.empty {-# INLINE rule332 #-} rule332 = \ (_ :: ()) -> [] {-# INLINE rule333 #-} rule333 = \ (_ :: ()) -> [] {-# INLINE rule334 #-} rule334 = \ (_ :: ()) -> [] {-# INLINE rule335 #-} rule335 = \ (_ :: ()) -> [] {-# INLINE rule336 #-} rule336 = \ ((_setIcollectedNames) :: Set Identifier) -> _setIcollectedNames {-# INLINE rule337 #-} rule337 = \ (_ :: ()) -> [] {-# INLINE rule338 #-} rule338 = \ (_ :: ()) -> Set.empty {-# INLINE rule339 #-} rule339 = \ (_ :: ()) -> [] {-# INLINE rule340 #-} rule340 = \ (_ :: ()) -> [] {-# INLINE rule341 #-} rule341 = \ (_ :: ()) -> Map.empty {-# INLINE rule342 #-} rule342 = \ ((_setIerrors) :: Seq Error) -> _setIerrors {-# INLINE rule343 #-} rule343 = \ (_ :: ()) -> mzero {-# INLINE rule344 #-} rule344 = \ (_ :: ()) -> Map.empty {-# INLINE rule345 #-} rule345 = \ (_ :: ()) -> id {-# INLINE rule346 #-} rule346 = \ (_ :: ()) -> Map.empty {-# INLINE rule347 #-} rule347 = \ (_ :: ()) -> Map.empty {-# INLINE rule348 #-} rule348 = \ (_ :: ()) -> [] {-# INLINE rule349 #-} rule349 = \ (_ :: ()) -> Map.empty {-# INLINE rule350 #-} rule350 = \ (_ :: ()) -> Set.empty {-# INLINE rule351 #-} rule351 = \ ((_lhsIattrDecls) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIattrDecls {-# INLINE rule352 #-} rule352 = \ ((_lhsIattrs) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIattrs {-# INLINE rule353 #-} rule353 = \ ((_lhsIdefSets) :: Map Identifier (Set NontermIdent,Set Identifier)) -> _lhsIdefSets {-# INLINE rule354 #-} rule354 = \ ((_lhsIallFields) :: DataTypes) -> _lhsIallFields {-# INLINE rule355 #-} rule355 = \ ((_lhsIallNonterminals) :: Set NontermIdent) -> _lhsIallNonterminals {-# INLINE rule356 #-} rule356 = \ ((_lhsIdefinedSets) :: DefinedSets) -> _lhsIdefinedSets {-# NOINLINE sem_Elem_Wrapper #-} sem_Elem_Wrapper :: (Pos) -> T_NontSet -> T_Elem sem_Elem_Wrapper _ arg_set_ = T_Elem (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_Elem_v16 v16 = \ (T_Elem_vIn16 _lhsIallAttrDecls _lhsIallAttrs _lhsIallConstructors _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsIattrs _lhsIdefSets _lhsIdefinedSets _lhsIoptions) -> ( let _setX29 = Control.Monad.Identity.runIdentity (attach_T_NontSet (arg_set_)) (T_NontSet_vOut28 _setIcollectedNames _setIerrors _setInontSet) = inv_NontSet_s29 _setX29 (T_NontSet_vIn28 _setOallFields _setOallNonterminals _setOdefinedSets) _lhsOwrappers :: Set NontermIdent _lhsOwrappers = rule357 _setInontSet _lhsOattrOrderCollect :: AttrOrderMap _lhsOattrOrderCollect = rule358 () _lhsOblocks :: Blocks _lhsOblocks = rule359 () _lhsOcollectedArounds :: [ (NontermIdent, ConstructorIdent, [AroundInfo]) ] _lhsOcollectedArounds = rule360 () _lhsOcollectedAugments :: [ (NontermIdent, ConstructorIdent, [AugmentInfo]) ] _lhsOcollectedAugments = rule361 () _lhsOcollectedConParams :: [(NontermIdent, ConstructorIdent, Set Identifier)] _lhsOcollectedConParams = rule362 () _lhsOcollectedConstraints :: [(NontermIdent, ConstructorIdent, [Type])] _lhsOcollectedConstraints = rule363 () _lhsOcollectedConstructorsMap :: Map NontermIdent (Set ConstructorIdent) _lhsOcollectedConstructorsMap = rule364 () _lhsOcollectedFields :: [(NontermIdent, ConstructorIdent, FieldMap)] _lhsOcollectedFields = rule365 () _lhsOcollectedInsts :: [ (NontermIdent, ConstructorIdent, [Identifier]) ] _lhsOcollectedInsts = rule366 () _lhsOcollectedMacros :: [(NontermIdent, ConstructorIdent, MaybeMacro)] _lhsOcollectedMacros = rule367 () _lhsOcollectedMerges :: [ (NontermIdent, ConstructorIdent, [MergeInfo]) ] _lhsOcollectedMerges = rule368 () _lhsOcollectedNames :: Set Identifier _lhsOcollectedNames = rule369 _setIcollectedNames _lhsOcollectedRules :: [ (NontermIdent, ConstructorIdent, RuleInfo)] _lhsOcollectedRules = rule370 () _lhsOcollectedSetNames :: Set Identifier _lhsOcollectedSetNames = rule371 () _lhsOcollectedSigs :: [ (NontermIdent, ConstructorIdent, SigInfo) ] _lhsOcollectedSigs = rule372 () _lhsOcollectedUniques :: [ (NontermIdent, ConstructorIdent, [UniqueInfo]) ] _lhsOcollectedUniques = rule373 () _lhsOctxCollect :: ContextMap _lhsOctxCollect = rule374 () _lhsOderivings :: Derivings _lhsOderivings = rule375 () _lhsOerrors :: Seq Error _lhsOerrors = rule376 _setIerrors _lhsOmoduleDecl :: Maybe (String,String,String) _lhsOmoduleDecl = rule377 () _lhsOparamsCollect :: ParamMap _lhsOparamsCollect = rule378 () _lhsOpragmas :: Options -> Options _lhsOpragmas = rule379 () _lhsOquantCollect :: QuantMap _lhsOquantCollect = rule380 () _lhsOsemPragmasCollect :: PragmaMap _lhsOsemPragmasCollect = rule381 () _lhsOtypeSyns :: TypeSyns _lhsOtypeSyns = rule382 () _lhsOuseMap :: Map NontermIdent (Map Identifier (String,String,String)) _lhsOuseMap = rule383 () _lhsOattrDecls :: Map NontermIdent (Attributes, Attributes) _lhsOattrDecls = rule384 _lhsIattrDecls _lhsOattrs :: Map NontermIdent (Attributes, Attributes) _lhsOattrs = rule385 _lhsIattrs _lhsOdefSets :: Map Identifier (Set NontermIdent,Set Identifier) _lhsOdefSets = rule386 _lhsIdefSets _setOallFields = rule387 _lhsIallFields _setOallNonterminals = rule388 _lhsIallNonterminals _setOdefinedSets = rule389 _lhsIdefinedSets __result_ = T_Elem_vOut16 _lhsOattrDecls _lhsOattrOrderCollect _lhsOattrs _lhsOblocks _lhsOcollectedArounds _lhsOcollectedAugments _lhsOcollectedConParams _lhsOcollectedConstraints _lhsOcollectedConstructorsMap _lhsOcollectedFields _lhsOcollectedInsts _lhsOcollectedMacros _lhsOcollectedMerges _lhsOcollectedNames _lhsOcollectedRules _lhsOcollectedSetNames _lhsOcollectedSigs _lhsOcollectedUniques _lhsOctxCollect _lhsOdefSets _lhsOderivings _lhsOerrors _lhsOmoduleDecl _lhsOparamsCollect _lhsOpragmas _lhsOquantCollect _lhsOsemPragmasCollect _lhsOtypeSyns _lhsOuseMap _lhsOwrappers in __result_ ) in C_Elem_s17 v16 {-# INLINE rule357 #-} {-# LINE 789 "./src-ag/Transform.ag" #-} rule357 = \ ((_setInontSet) :: Set NontermIdent) -> {-# LINE 789 "./src-ag/Transform.ag" #-} _setInontSet {-# LINE 3124 "dist/build/Transform.hs"#-} {-# INLINE rule358 #-} rule358 = \ (_ :: ()) -> Map.empty {-# INLINE rule359 #-} rule359 = \ (_ :: ()) -> Map.empty {-# INLINE rule360 #-} rule360 = \ (_ :: ()) -> [] {-# INLINE rule361 #-} rule361 = \ (_ :: ()) -> [] {-# INLINE rule362 #-} rule362 = \ (_ :: ()) -> [] {-# INLINE rule363 #-} rule363 = \ (_ :: ()) -> [] {-# INLINE rule364 #-} rule364 = \ (_ :: ()) -> Map.empty {-# INLINE rule365 #-} rule365 = \ (_ :: ()) -> [] {-# INLINE rule366 #-} rule366 = \ (_ :: ()) -> [] {-# INLINE rule367 #-} rule367 = \ (_ :: ()) -> [] {-# INLINE rule368 #-} rule368 = \ (_ :: ()) -> [] {-# INLINE rule369 #-} rule369 = \ ((_setIcollectedNames) :: Set Identifier) -> _setIcollectedNames {-# INLINE rule370 #-} rule370 = \ (_ :: ()) -> [] {-# INLINE rule371 #-} rule371 = \ (_ :: ()) -> Set.empty {-# INLINE rule372 #-} rule372 = \ (_ :: ()) -> [] {-# INLINE rule373 #-} rule373 = \ (_ :: ()) -> [] {-# INLINE rule374 #-} rule374 = \ (_ :: ()) -> Map.empty {-# INLINE rule375 #-} rule375 = \ (_ :: ()) -> Map.empty {-# INLINE rule376 #-} rule376 = \ ((_setIerrors) :: Seq Error) -> _setIerrors {-# INLINE rule377 #-} rule377 = \ (_ :: ()) -> mzero {-# INLINE rule378 #-} rule378 = \ (_ :: ()) -> Map.empty {-# INLINE rule379 #-} rule379 = \ (_ :: ()) -> id {-# INLINE rule380 #-} rule380 = \ (_ :: ()) -> Map.empty {-# INLINE rule381 #-} rule381 = \ (_ :: ()) -> Map.empty {-# INLINE rule382 #-} rule382 = \ (_ :: ()) -> [] {-# INLINE rule383 #-} rule383 = \ (_ :: ()) -> Map.empty {-# INLINE rule384 #-} rule384 = \ ((_lhsIattrDecls) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIattrDecls {-# INLINE rule385 #-} rule385 = \ ((_lhsIattrs) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIattrs {-# INLINE rule386 #-} rule386 = \ ((_lhsIdefSets) :: Map Identifier (Set NontermIdent,Set Identifier)) -> _lhsIdefSets {-# INLINE rule387 #-} rule387 = \ ((_lhsIallFields) :: DataTypes) -> _lhsIallFields {-# INLINE rule388 #-} rule388 = \ ((_lhsIallNonterminals) :: Set NontermIdent) -> _lhsIallNonterminals {-# INLINE rule389 #-} rule389 = \ ((_lhsIdefinedSets) :: DefinedSets) -> _lhsIdefinedSets {-# NOINLINE sem_Elem_Nocatas #-} sem_Elem_Nocatas :: (Pos) -> T_NontSet -> T_Elem sem_Elem_Nocatas _ arg_set_ = T_Elem (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_Elem_v16 v16 = \ (T_Elem_vIn16 _lhsIallAttrDecls _lhsIallAttrs _lhsIallConstructors _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsIattrs _lhsIdefSets _lhsIdefinedSets _lhsIoptions) -> ( let _setX29 = Control.Monad.Identity.runIdentity (attach_T_NontSet (arg_set_)) (T_NontSet_vOut28 _setIcollectedNames _setIerrors _setInontSet) = inv_NontSet_s29 _setX29 (T_NontSet_vIn28 _setOallFields _setOallNonterminals _setOdefinedSets) _lhsOpragmas :: Options -> Options _lhsOpragmas = rule390 _setInontSet _lhsOattrOrderCollect :: AttrOrderMap _lhsOattrOrderCollect = rule391 () _lhsOblocks :: Blocks _lhsOblocks = rule392 () _lhsOcollectedArounds :: [ (NontermIdent, ConstructorIdent, [AroundInfo]) ] _lhsOcollectedArounds = rule393 () _lhsOcollectedAugments :: [ (NontermIdent, ConstructorIdent, [AugmentInfo]) ] _lhsOcollectedAugments = rule394 () _lhsOcollectedConParams :: [(NontermIdent, ConstructorIdent, Set Identifier)] _lhsOcollectedConParams = rule395 () _lhsOcollectedConstraints :: [(NontermIdent, ConstructorIdent, [Type])] _lhsOcollectedConstraints = rule396 () _lhsOcollectedConstructorsMap :: Map NontermIdent (Set ConstructorIdent) _lhsOcollectedConstructorsMap = rule397 () _lhsOcollectedFields :: [(NontermIdent, ConstructorIdent, FieldMap)] _lhsOcollectedFields = rule398 () _lhsOcollectedInsts :: [ (NontermIdent, ConstructorIdent, [Identifier]) ] _lhsOcollectedInsts = rule399 () _lhsOcollectedMacros :: [(NontermIdent, ConstructorIdent, MaybeMacro)] _lhsOcollectedMacros = rule400 () _lhsOcollectedMerges :: [ (NontermIdent, ConstructorIdent, [MergeInfo]) ] _lhsOcollectedMerges = rule401 () _lhsOcollectedNames :: Set Identifier _lhsOcollectedNames = rule402 _setIcollectedNames _lhsOcollectedRules :: [ (NontermIdent, ConstructorIdent, RuleInfo)] _lhsOcollectedRules = rule403 () _lhsOcollectedSetNames :: Set Identifier _lhsOcollectedSetNames = rule404 () _lhsOcollectedSigs :: [ (NontermIdent, ConstructorIdent, SigInfo) ] _lhsOcollectedSigs = rule405 () _lhsOcollectedUniques :: [ (NontermIdent, ConstructorIdent, [UniqueInfo]) ] _lhsOcollectedUniques = rule406 () _lhsOctxCollect :: ContextMap _lhsOctxCollect = rule407 () _lhsOderivings :: Derivings _lhsOderivings = rule408 () _lhsOerrors :: Seq Error _lhsOerrors = rule409 _setIerrors _lhsOmoduleDecl :: Maybe (String,String,String) _lhsOmoduleDecl = rule410 () _lhsOparamsCollect :: ParamMap _lhsOparamsCollect = rule411 () _lhsOquantCollect :: QuantMap _lhsOquantCollect = rule412 () _lhsOsemPragmasCollect :: PragmaMap _lhsOsemPragmasCollect = rule413 () _lhsOtypeSyns :: TypeSyns _lhsOtypeSyns = rule414 () _lhsOuseMap :: Map NontermIdent (Map Identifier (String,String,String)) _lhsOuseMap = rule415 () _lhsOwrappers :: Set NontermIdent _lhsOwrappers = rule416 () _lhsOattrDecls :: Map NontermIdent (Attributes, Attributes) _lhsOattrDecls = rule417 _lhsIattrDecls _lhsOattrs :: Map NontermIdent (Attributes, Attributes) _lhsOattrs = rule418 _lhsIattrs _lhsOdefSets :: Map Identifier (Set NontermIdent,Set Identifier) _lhsOdefSets = rule419 _lhsIdefSets _setOallFields = rule420 _lhsIallFields _setOallNonterminals = rule421 _lhsIallNonterminals _setOdefinedSets = rule422 _lhsIdefinedSets __result_ = T_Elem_vOut16 _lhsOattrDecls _lhsOattrOrderCollect _lhsOattrs _lhsOblocks _lhsOcollectedArounds _lhsOcollectedAugments _lhsOcollectedConParams _lhsOcollectedConstraints _lhsOcollectedConstructorsMap _lhsOcollectedFields _lhsOcollectedInsts _lhsOcollectedMacros _lhsOcollectedMerges _lhsOcollectedNames _lhsOcollectedRules _lhsOcollectedSetNames _lhsOcollectedSigs _lhsOcollectedUniques _lhsOctxCollect _lhsOdefSets _lhsOderivings _lhsOerrors _lhsOmoduleDecl _lhsOparamsCollect _lhsOpragmas _lhsOquantCollect _lhsOsemPragmasCollect _lhsOtypeSyns _lhsOuseMap _lhsOwrappers in __result_ ) in C_Elem_s17 v16 {-# INLINE rule390 #-} {-# LINE 796 "./src-ag/Transform.ag" #-} rule390 = \ ((_setInontSet) :: Set NontermIdent) -> {-# LINE 796 "./src-ag/Transform.ag" #-} \o -> o { nocatas = _setInontSet `Set.union` nocatas o } {-# LINE 3301 "dist/build/Transform.hs"#-} {-# INLINE rule391 #-} rule391 = \ (_ :: ()) -> Map.empty {-# INLINE rule392 #-} rule392 = \ (_ :: ()) -> Map.empty {-# INLINE rule393 #-} rule393 = \ (_ :: ()) -> [] {-# INLINE rule394 #-} rule394 = \ (_ :: ()) -> [] {-# INLINE rule395 #-} rule395 = \ (_ :: ()) -> [] {-# INLINE rule396 #-} rule396 = \ (_ :: ()) -> [] {-# INLINE rule397 #-} rule397 = \ (_ :: ()) -> Map.empty {-# INLINE rule398 #-} rule398 = \ (_ :: ()) -> [] {-# INLINE rule399 #-} rule399 = \ (_ :: ()) -> [] {-# INLINE rule400 #-} rule400 = \ (_ :: ()) -> [] {-# INLINE rule401 #-} rule401 = \ (_ :: ()) -> [] {-# INLINE rule402 #-} rule402 = \ ((_setIcollectedNames) :: Set Identifier) -> _setIcollectedNames {-# INLINE rule403 #-} rule403 = \ (_ :: ()) -> [] {-# INLINE rule404 #-} rule404 = \ (_ :: ()) -> Set.empty {-# INLINE rule405 #-} rule405 = \ (_ :: ()) -> [] {-# INLINE rule406 #-} rule406 = \ (_ :: ()) -> [] {-# INLINE rule407 #-} rule407 = \ (_ :: ()) -> Map.empty {-# INLINE rule408 #-} rule408 = \ (_ :: ()) -> Map.empty {-# INLINE rule409 #-} rule409 = \ ((_setIerrors) :: Seq Error) -> _setIerrors {-# INLINE rule410 #-} rule410 = \ (_ :: ()) -> mzero {-# INLINE rule411 #-} rule411 = \ (_ :: ()) -> Map.empty {-# INLINE rule412 #-} rule412 = \ (_ :: ()) -> Map.empty {-# INLINE rule413 #-} rule413 = \ (_ :: ()) -> Map.empty {-# INLINE rule414 #-} rule414 = \ (_ :: ()) -> [] {-# INLINE rule415 #-} rule415 = \ (_ :: ()) -> Map.empty {-# INLINE rule416 #-} rule416 = \ (_ :: ()) -> Set.empty {-# INLINE rule417 #-} rule417 = \ ((_lhsIattrDecls) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIattrDecls {-# INLINE rule418 #-} rule418 = \ ((_lhsIattrs) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIattrs {-# INLINE rule419 #-} rule419 = \ ((_lhsIdefSets) :: Map Identifier (Set NontermIdent,Set Identifier)) -> _lhsIdefSets {-# INLINE rule420 #-} rule420 = \ ((_lhsIallFields) :: DataTypes) -> _lhsIallFields {-# INLINE rule421 #-} rule421 = \ ((_lhsIallNonterminals) :: Set NontermIdent) -> _lhsIallNonterminals {-# INLINE rule422 #-} rule422 = \ ((_lhsIdefinedSets) :: DefinedSets) -> _lhsIdefinedSets {-# NOINLINE sem_Elem_Pragma #-} sem_Elem_Pragma :: (Pos) -> ([NontermIdent]) -> T_Elem sem_Elem_Pragma _ arg_names_ = T_Elem (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_Elem_v16 v16 = \ (T_Elem_vIn16 _lhsIallAttrDecls _lhsIallAttrs _lhsIallConstructors _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsIattrs _lhsIdefSets _lhsIdefinedSets _lhsIoptions) -> ( let _lhsOpragmas :: Options -> Options _lhsOpragmas = rule423 arg_names_ _lhsOattrOrderCollect :: AttrOrderMap _lhsOattrOrderCollect = rule424 () _lhsOblocks :: Blocks _lhsOblocks = rule425 () _lhsOcollectedArounds :: [ (NontermIdent, ConstructorIdent, [AroundInfo]) ] _lhsOcollectedArounds = rule426 () _lhsOcollectedAugments :: [ (NontermIdent, ConstructorIdent, [AugmentInfo]) ] _lhsOcollectedAugments = rule427 () _lhsOcollectedConParams :: [(NontermIdent, ConstructorIdent, Set Identifier)] _lhsOcollectedConParams = rule428 () _lhsOcollectedConstraints :: [(NontermIdent, ConstructorIdent, [Type])] _lhsOcollectedConstraints = rule429 () _lhsOcollectedConstructorsMap :: Map NontermIdent (Set ConstructorIdent) _lhsOcollectedConstructorsMap = rule430 () _lhsOcollectedFields :: [(NontermIdent, ConstructorIdent, FieldMap)] _lhsOcollectedFields = rule431 () _lhsOcollectedInsts :: [ (NontermIdent, ConstructorIdent, [Identifier]) ] _lhsOcollectedInsts = rule432 () _lhsOcollectedMacros :: [(NontermIdent, ConstructorIdent, MaybeMacro)] _lhsOcollectedMacros = rule433 () _lhsOcollectedMerges :: [ (NontermIdent, ConstructorIdent, [MergeInfo]) ] _lhsOcollectedMerges = rule434 () _lhsOcollectedNames :: Set Identifier _lhsOcollectedNames = rule435 () _lhsOcollectedRules :: [ (NontermIdent, ConstructorIdent, RuleInfo)] _lhsOcollectedRules = rule436 () _lhsOcollectedSetNames :: Set Identifier _lhsOcollectedSetNames = rule437 () _lhsOcollectedSigs :: [ (NontermIdent, ConstructorIdent, SigInfo) ] _lhsOcollectedSigs = rule438 () _lhsOcollectedUniques :: [ (NontermIdent, ConstructorIdent, [UniqueInfo]) ] _lhsOcollectedUniques = rule439 () _lhsOctxCollect :: ContextMap _lhsOctxCollect = rule440 () _lhsOderivings :: Derivings _lhsOderivings = rule441 () _lhsOerrors :: Seq Error _lhsOerrors = rule442 () _lhsOmoduleDecl :: Maybe (String,String,String) _lhsOmoduleDecl = rule443 () _lhsOparamsCollect :: ParamMap _lhsOparamsCollect = rule444 () _lhsOquantCollect :: QuantMap _lhsOquantCollect = rule445 () _lhsOsemPragmasCollect :: PragmaMap _lhsOsemPragmasCollect = rule446 () _lhsOtypeSyns :: TypeSyns _lhsOtypeSyns = rule447 () _lhsOuseMap :: Map NontermIdent (Map Identifier (String,String,String)) _lhsOuseMap = rule448 () _lhsOwrappers :: Set NontermIdent _lhsOwrappers = rule449 () _lhsOattrDecls :: Map NontermIdent (Attributes, Attributes) _lhsOattrDecls = rule450 _lhsIattrDecls _lhsOattrs :: Map NontermIdent (Attributes, Attributes) _lhsOattrs = rule451 _lhsIattrs _lhsOdefSets :: Map Identifier (Set NontermIdent,Set Identifier) _lhsOdefSets = rule452 _lhsIdefSets __result_ = T_Elem_vOut16 _lhsOattrDecls _lhsOattrOrderCollect _lhsOattrs _lhsOblocks _lhsOcollectedArounds _lhsOcollectedAugments _lhsOcollectedConParams _lhsOcollectedConstraints _lhsOcollectedConstructorsMap _lhsOcollectedFields _lhsOcollectedInsts _lhsOcollectedMacros _lhsOcollectedMerges _lhsOcollectedNames _lhsOcollectedRules _lhsOcollectedSetNames _lhsOcollectedSigs _lhsOcollectedUniques _lhsOctxCollect _lhsOdefSets _lhsOderivings _lhsOerrors _lhsOmoduleDecl _lhsOparamsCollect _lhsOpragmas _lhsOquantCollect _lhsOsemPragmasCollect _lhsOtypeSyns _lhsOuseMap _lhsOwrappers in __result_ ) in C_Elem_s17 v16 {-# INLINE rule423 #-} {-# LINE 805 "./src-ag/Transform.ag" #-} rule423 = \ names_ -> {-# LINE 805 "./src-ag/Transform.ag" #-} 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 } "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 } "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 s -> trace ("uuagc: ignoring unknown pragma: " ++ s) o in \o -> foldr mk o names_ {-# LINE 3537 "dist/build/Transform.hs"#-} {-# INLINE rule424 #-} rule424 = \ (_ :: ()) -> Map.empty {-# INLINE rule425 #-} rule425 = \ (_ :: ()) -> Map.empty {-# INLINE rule426 #-} rule426 = \ (_ :: ()) -> [] {-# INLINE rule427 #-} rule427 = \ (_ :: ()) -> [] {-# INLINE rule428 #-} rule428 = \ (_ :: ()) -> [] {-# INLINE rule429 #-} rule429 = \ (_ :: ()) -> [] {-# INLINE rule430 #-} rule430 = \ (_ :: ()) -> Map.empty {-# INLINE rule431 #-} rule431 = \ (_ :: ()) -> [] {-# INLINE rule432 #-} rule432 = \ (_ :: ()) -> [] {-# INLINE rule433 #-} rule433 = \ (_ :: ()) -> [] {-# INLINE rule434 #-} rule434 = \ (_ :: ()) -> [] {-# INLINE rule435 #-} rule435 = \ (_ :: ()) -> Set.empty {-# INLINE rule436 #-} rule436 = \ (_ :: ()) -> [] {-# INLINE rule437 #-} rule437 = \ (_ :: ()) -> Set.empty {-# INLINE rule438 #-} rule438 = \ (_ :: ()) -> [] {-# INLINE rule439 #-} rule439 = \ (_ :: ()) -> [] {-# INLINE rule440 #-} rule440 = \ (_ :: ()) -> Map.empty {-# INLINE rule441 #-} rule441 = \ (_ :: ()) -> Map.empty {-# INLINE rule442 #-} rule442 = \ (_ :: ()) -> Seq.empty {-# INLINE rule443 #-} rule443 = \ (_ :: ()) -> mzero {-# INLINE rule444 #-} rule444 = \ (_ :: ()) -> Map.empty {-# INLINE rule445 #-} rule445 = \ (_ :: ()) -> Map.empty {-# INLINE rule446 #-} rule446 = \ (_ :: ()) -> Map.empty {-# INLINE rule447 #-} rule447 = \ (_ :: ()) -> [] {-# INLINE rule448 #-} rule448 = \ (_ :: ()) -> Map.empty {-# INLINE rule449 #-} rule449 = \ (_ :: ()) -> Set.empty {-# INLINE rule450 #-} rule450 = \ ((_lhsIattrDecls) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIattrDecls {-# INLINE rule451 #-} rule451 = \ ((_lhsIattrs) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIattrs {-# INLINE rule452 #-} rule452 = \ ((_lhsIdefSets) :: Map Identifier (Set NontermIdent,Set Identifier)) -> _lhsIdefSets {-# NOINLINE sem_Elem_Module #-} sem_Elem_Module :: (Pos) -> (String) -> (String) -> (String) -> T_Elem sem_Elem_Module _ arg_name_ arg_exports_ arg_imports_ = T_Elem (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_Elem_v16 v16 = \ (T_Elem_vIn16 _lhsIallAttrDecls _lhsIallAttrs _lhsIallConstructors _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsIattrs _lhsIdefSets _lhsIdefinedSets _lhsIoptions) -> ( let _lhsOmoduleDecl :: Maybe (String,String,String) _lhsOmoduleDecl = rule453 arg_exports_ arg_imports_ arg_name_ _lhsOattrOrderCollect :: AttrOrderMap _lhsOattrOrderCollect = rule454 () _lhsOblocks :: Blocks _lhsOblocks = rule455 () _lhsOcollectedArounds :: [ (NontermIdent, ConstructorIdent, [AroundInfo]) ] _lhsOcollectedArounds = rule456 () _lhsOcollectedAugments :: [ (NontermIdent, ConstructorIdent, [AugmentInfo]) ] _lhsOcollectedAugments = rule457 () _lhsOcollectedConParams :: [(NontermIdent, ConstructorIdent, Set Identifier)] _lhsOcollectedConParams = rule458 () _lhsOcollectedConstraints :: [(NontermIdent, ConstructorIdent, [Type])] _lhsOcollectedConstraints = rule459 () _lhsOcollectedConstructorsMap :: Map NontermIdent (Set ConstructorIdent) _lhsOcollectedConstructorsMap = rule460 () _lhsOcollectedFields :: [(NontermIdent, ConstructorIdent, FieldMap)] _lhsOcollectedFields = rule461 () _lhsOcollectedInsts :: [ (NontermIdent, ConstructorIdent, [Identifier]) ] _lhsOcollectedInsts = rule462 () _lhsOcollectedMacros :: [(NontermIdent, ConstructorIdent, MaybeMacro)] _lhsOcollectedMacros = rule463 () _lhsOcollectedMerges :: [ (NontermIdent, ConstructorIdent, [MergeInfo]) ] _lhsOcollectedMerges = rule464 () _lhsOcollectedNames :: Set Identifier _lhsOcollectedNames = rule465 () _lhsOcollectedRules :: [ (NontermIdent, ConstructorIdent, RuleInfo)] _lhsOcollectedRules = rule466 () _lhsOcollectedSetNames :: Set Identifier _lhsOcollectedSetNames = rule467 () _lhsOcollectedSigs :: [ (NontermIdent, ConstructorIdent, SigInfo) ] _lhsOcollectedSigs = rule468 () _lhsOcollectedUniques :: [ (NontermIdent, ConstructorIdent, [UniqueInfo]) ] _lhsOcollectedUniques = rule469 () _lhsOctxCollect :: ContextMap _lhsOctxCollect = rule470 () _lhsOderivings :: Derivings _lhsOderivings = rule471 () _lhsOerrors :: Seq Error _lhsOerrors = rule472 () _lhsOparamsCollect :: ParamMap _lhsOparamsCollect = rule473 () _lhsOpragmas :: Options -> Options _lhsOpragmas = rule474 () _lhsOquantCollect :: QuantMap _lhsOquantCollect = rule475 () _lhsOsemPragmasCollect :: PragmaMap _lhsOsemPragmasCollect = rule476 () _lhsOtypeSyns :: TypeSyns _lhsOtypeSyns = rule477 () _lhsOuseMap :: Map NontermIdent (Map Identifier (String,String,String)) _lhsOuseMap = rule478 () _lhsOwrappers :: Set NontermIdent _lhsOwrappers = rule479 () _lhsOattrDecls :: Map NontermIdent (Attributes, Attributes) _lhsOattrDecls = rule480 _lhsIattrDecls _lhsOattrs :: Map NontermIdent (Attributes, Attributes) _lhsOattrs = rule481 _lhsIattrs _lhsOdefSets :: Map Identifier (Set NontermIdent,Set Identifier) _lhsOdefSets = rule482 _lhsIdefSets __result_ = T_Elem_vOut16 _lhsOattrDecls _lhsOattrOrderCollect _lhsOattrs _lhsOblocks _lhsOcollectedArounds _lhsOcollectedAugments _lhsOcollectedConParams _lhsOcollectedConstraints _lhsOcollectedConstructorsMap _lhsOcollectedFields _lhsOcollectedInsts _lhsOcollectedMacros _lhsOcollectedMerges _lhsOcollectedNames _lhsOcollectedRules _lhsOcollectedSetNames _lhsOcollectedSigs _lhsOcollectedUniques _lhsOctxCollect _lhsOdefSets _lhsOderivings _lhsOerrors _lhsOmoduleDecl _lhsOparamsCollect _lhsOpragmas _lhsOquantCollect _lhsOsemPragmasCollect _lhsOtypeSyns _lhsOuseMap _lhsOwrappers in __result_ ) in C_Elem_s17 v16 {-# INLINE rule453 #-} {-# LINE 1213 "./src-ag/Transform.ag" #-} rule453 = \ exports_ imports_ name_ -> {-# LINE 1213 "./src-ag/Transform.ag" #-} Just (name_, exports_, imports_) {-# LINE 3700 "dist/build/Transform.hs"#-} {-# INLINE rule454 #-} rule454 = \ (_ :: ()) -> Map.empty {-# INLINE rule455 #-} rule455 = \ (_ :: ()) -> Map.empty {-# INLINE rule456 #-} rule456 = \ (_ :: ()) -> [] {-# INLINE rule457 #-} rule457 = \ (_ :: ()) -> [] {-# INLINE rule458 #-} rule458 = \ (_ :: ()) -> [] {-# INLINE rule459 #-} rule459 = \ (_ :: ()) -> [] {-# INLINE rule460 #-} rule460 = \ (_ :: ()) -> Map.empty {-# INLINE rule461 #-} rule461 = \ (_ :: ()) -> [] {-# INLINE rule462 #-} rule462 = \ (_ :: ()) -> [] {-# INLINE rule463 #-} rule463 = \ (_ :: ()) -> [] {-# INLINE rule464 #-} rule464 = \ (_ :: ()) -> [] {-# INLINE rule465 #-} rule465 = \ (_ :: ()) -> Set.empty {-# INLINE rule466 #-} rule466 = \ (_ :: ()) -> [] {-# INLINE rule467 #-} rule467 = \ (_ :: ()) -> Set.empty {-# INLINE rule468 #-} rule468 = \ (_ :: ()) -> [] {-# INLINE rule469 #-} rule469 = \ (_ :: ()) -> [] {-# INLINE rule470 #-} rule470 = \ (_ :: ()) -> Map.empty {-# INLINE rule471 #-} rule471 = \ (_ :: ()) -> Map.empty {-# INLINE rule472 #-} rule472 = \ (_ :: ()) -> Seq.empty {-# INLINE rule473 #-} rule473 = \ (_ :: ()) -> Map.empty {-# INLINE rule474 #-} rule474 = \ (_ :: ()) -> id {-# INLINE rule475 #-} rule475 = \ (_ :: ()) -> Map.empty {-# INLINE rule476 #-} rule476 = \ (_ :: ()) -> Map.empty {-# INLINE rule477 #-} rule477 = \ (_ :: ()) -> [] {-# INLINE rule478 #-} rule478 = \ (_ :: ()) -> Map.empty {-# INLINE rule479 #-} rule479 = \ (_ :: ()) -> Set.empty {-# INLINE rule480 #-} rule480 = \ ((_lhsIattrDecls) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIattrDecls {-# INLINE rule481 #-} rule481 = \ ((_lhsIattrs) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIattrs {-# INLINE rule482 #-} rule482 = \ ((_lhsIdefSets) :: Map Identifier (Set NontermIdent,Set Identifier)) -> _lhsIdefSets -- Elems ------------------------------------------------------- -- wrapper data Inh_Elems = Inh_Elems { allAttrDecls_Inh_Elems :: (Map NontermIdent (Attributes, Attributes)), allAttrs_Inh_Elems :: (Map NontermIdent (Attributes, Attributes)), allConstructors_Inh_Elems :: (Map NontermIdent (Set ConstructorIdent)), allFields_Inh_Elems :: (DataTypes), allNonterminals_Inh_Elems :: (Set NontermIdent), attrDecls_Inh_Elems :: (Map NontermIdent (Attributes, Attributes)), attrs_Inh_Elems :: (Map NontermIdent (Attributes, Attributes)), defSets_Inh_Elems :: (Map Identifier (Set NontermIdent,Set Identifier)), definedSets_Inh_Elems :: (DefinedSets), options_Inh_Elems :: (Options) } data Syn_Elems = Syn_Elems { attrDecls_Syn_Elems :: (Map NontermIdent (Attributes, Attributes)), attrOrderCollect_Syn_Elems :: (AttrOrderMap), attrs_Syn_Elems :: (Map NontermIdent (Attributes, Attributes)), blocks_Syn_Elems :: (Blocks), collectedArounds_Syn_Elems :: ([ (NontermIdent, ConstructorIdent, [AroundInfo]) ]), collectedAugments_Syn_Elems :: ([ (NontermIdent, ConstructorIdent, [AugmentInfo]) ]), collectedConParams_Syn_Elems :: ([(NontermIdent, ConstructorIdent, Set Identifier)]), collectedConstraints_Syn_Elems :: ([(NontermIdent, ConstructorIdent, [Type])]), collectedConstructorsMap_Syn_Elems :: (Map NontermIdent (Set ConstructorIdent)), collectedFields_Syn_Elems :: ([(NontermIdent, ConstructorIdent, FieldMap)]), collectedInsts_Syn_Elems :: ([ (NontermIdent, ConstructorIdent, [Identifier]) ]), collectedMacros_Syn_Elems :: ([(NontermIdent, ConstructorIdent, MaybeMacro)]), collectedMerges_Syn_Elems :: ([ (NontermIdent, ConstructorIdent, [MergeInfo]) ]), collectedNames_Syn_Elems :: (Set Identifier), collectedRules_Syn_Elems :: ([ (NontermIdent, ConstructorIdent, RuleInfo)]), collectedSetNames_Syn_Elems :: (Set Identifier), collectedSigs_Syn_Elems :: ([ (NontermIdent, ConstructorIdent, SigInfo) ]), collectedUniques_Syn_Elems :: ([ (NontermIdent, ConstructorIdent, [UniqueInfo]) ]), ctxCollect_Syn_Elems :: (ContextMap), defSets_Syn_Elems :: (Map Identifier (Set NontermIdent,Set Identifier)), derivings_Syn_Elems :: (Derivings), errors_Syn_Elems :: (Seq Error), moduleDecl_Syn_Elems :: (Maybe (String,String,String)), paramsCollect_Syn_Elems :: (ParamMap), pragmas_Syn_Elems :: (Options -> Options), quantCollect_Syn_Elems :: (QuantMap), semPragmasCollect_Syn_Elems :: (PragmaMap), typeSyns_Syn_Elems :: (TypeSyns), useMap_Syn_Elems :: (Map NontermIdent (Map Identifier (String,String,String))), wrappers_Syn_Elems :: (Set NontermIdent) } {-# INLINABLE wrap_Elems #-} wrap_Elems :: T_Elems -> Inh_Elems -> (Syn_Elems ) wrap_Elems (T_Elems act) (Inh_Elems _lhsIallAttrDecls _lhsIallAttrs _lhsIallConstructors _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsIattrs _lhsIdefSets _lhsIdefinedSets _lhsIoptions) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Elems_vIn19 _lhsIallAttrDecls _lhsIallAttrs _lhsIallConstructors _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsIattrs _lhsIdefSets _lhsIdefinedSets _lhsIoptions (T_Elems_vOut19 _lhsOattrDecls _lhsOattrOrderCollect _lhsOattrs _lhsOblocks _lhsOcollectedArounds _lhsOcollectedAugments _lhsOcollectedConParams _lhsOcollectedConstraints _lhsOcollectedConstructorsMap _lhsOcollectedFields _lhsOcollectedInsts _lhsOcollectedMacros _lhsOcollectedMerges _lhsOcollectedNames _lhsOcollectedRules _lhsOcollectedSetNames _lhsOcollectedSigs _lhsOcollectedUniques _lhsOctxCollect _lhsOdefSets _lhsOderivings _lhsOerrors _lhsOmoduleDecl _lhsOparamsCollect _lhsOpragmas _lhsOquantCollect _lhsOsemPragmasCollect _lhsOtypeSyns _lhsOuseMap _lhsOwrappers) <- return (inv_Elems_s20 sem arg) return (Syn_Elems _lhsOattrDecls _lhsOattrOrderCollect _lhsOattrs _lhsOblocks _lhsOcollectedArounds _lhsOcollectedAugments _lhsOcollectedConParams _lhsOcollectedConstraints _lhsOcollectedConstructorsMap _lhsOcollectedFields _lhsOcollectedInsts _lhsOcollectedMacros _lhsOcollectedMerges _lhsOcollectedNames _lhsOcollectedRules _lhsOcollectedSetNames _lhsOcollectedSigs _lhsOcollectedUniques _lhsOctxCollect _lhsOdefSets _lhsOderivings _lhsOerrors _lhsOmoduleDecl _lhsOparamsCollect _lhsOpragmas _lhsOquantCollect _lhsOsemPragmasCollect _lhsOtypeSyns _lhsOuseMap _lhsOwrappers) ) -- cata {-# NOINLINE sem_Elems #-} sem_Elems :: Elems -> T_Elems sem_Elems list = Prelude.foldr sem_Elems_Cons sem_Elems_Nil (Prelude.map sem_Elem list) -- semantic domain newtype T_Elems = T_Elems { attach_T_Elems :: Identity (T_Elems_s20 ) } newtype T_Elems_s20 = C_Elems_s20 { inv_Elems_s20 :: (T_Elems_v19 ) } data T_Elems_s21 = C_Elems_s21 type T_Elems_v19 = (T_Elems_vIn19 ) -> (T_Elems_vOut19 ) data T_Elems_vIn19 = T_Elems_vIn19 (Map NontermIdent (Attributes, Attributes)) (Map NontermIdent (Attributes, Attributes)) (Map NontermIdent (Set ConstructorIdent)) (DataTypes) (Set NontermIdent) (Map NontermIdent (Attributes, Attributes)) (Map NontermIdent (Attributes, Attributes)) (Map Identifier (Set NontermIdent,Set Identifier)) (DefinedSets) (Options) data T_Elems_vOut19 = T_Elems_vOut19 (Map NontermIdent (Attributes, Attributes)) (AttrOrderMap) (Map NontermIdent (Attributes, Attributes)) (Blocks) ([ (NontermIdent, ConstructorIdent, [AroundInfo]) ]) ([ (NontermIdent, ConstructorIdent, [AugmentInfo]) ]) ([(NontermIdent, ConstructorIdent, Set Identifier)]) ([(NontermIdent, ConstructorIdent, [Type])]) (Map NontermIdent (Set ConstructorIdent)) ([(NontermIdent, ConstructorIdent, FieldMap)]) ([ (NontermIdent, ConstructorIdent, [Identifier]) ]) ([(NontermIdent, ConstructorIdent, MaybeMacro)]) ([ (NontermIdent, ConstructorIdent, [MergeInfo]) ]) (Set Identifier) ([ (NontermIdent, ConstructorIdent, RuleInfo)]) (Set Identifier) ([ (NontermIdent, ConstructorIdent, SigInfo) ]) ([ (NontermIdent, ConstructorIdent, [UniqueInfo]) ]) (ContextMap) (Map Identifier (Set NontermIdent,Set Identifier)) (Derivings) (Seq Error) (Maybe (String,String,String)) (ParamMap) (Options -> Options) (QuantMap) (PragmaMap) (TypeSyns) (Map NontermIdent (Map Identifier (String,String,String))) (Set NontermIdent) {-# NOINLINE sem_Elems_Cons #-} sem_Elems_Cons :: T_Elem -> T_Elems -> T_Elems sem_Elems_Cons arg_hd_ arg_tl_ = T_Elems (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_Elems_v19 v19 = \ (T_Elems_vIn19 _lhsIallAttrDecls _lhsIallAttrs _lhsIallConstructors _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsIattrs _lhsIdefSets _lhsIdefinedSets _lhsIoptions) -> ( let _hdX17 = Control.Monad.Identity.runIdentity (attach_T_Elem (arg_hd_)) _tlX20 = Control.Monad.Identity.runIdentity (attach_T_Elems (arg_tl_)) (T_Elem_vOut16 _hdIattrDecls _hdIattrOrderCollect _hdIattrs _hdIblocks _hdIcollectedArounds _hdIcollectedAugments _hdIcollectedConParams _hdIcollectedConstraints _hdIcollectedConstructorsMap _hdIcollectedFields _hdIcollectedInsts _hdIcollectedMacros _hdIcollectedMerges _hdIcollectedNames _hdIcollectedRules _hdIcollectedSetNames _hdIcollectedSigs _hdIcollectedUniques _hdIctxCollect _hdIdefSets _hdIderivings _hdIerrors _hdImoduleDecl _hdIparamsCollect _hdIpragmas _hdIquantCollect _hdIsemPragmasCollect _hdItypeSyns _hdIuseMap _hdIwrappers) = inv_Elem_s17 _hdX17 (T_Elem_vIn16 _hdOallAttrDecls _hdOallAttrs _hdOallConstructors _hdOallFields _hdOallNonterminals _hdOattrDecls _hdOattrs _hdOdefSets _hdOdefinedSets _hdOoptions) (T_Elems_vOut19 _tlIattrDecls _tlIattrOrderCollect _tlIattrs _tlIblocks _tlIcollectedArounds _tlIcollectedAugments _tlIcollectedConParams _tlIcollectedConstraints _tlIcollectedConstructorsMap _tlIcollectedFields _tlIcollectedInsts _tlIcollectedMacros _tlIcollectedMerges _tlIcollectedNames _tlIcollectedRules _tlIcollectedSetNames _tlIcollectedSigs _tlIcollectedUniques _tlIctxCollect _tlIdefSets _tlIderivings _tlIerrors _tlImoduleDecl _tlIparamsCollect _tlIpragmas _tlIquantCollect _tlIsemPragmasCollect _tlItypeSyns _tlIuseMap _tlIwrappers) = inv_Elems_s20 _tlX20 (T_Elems_vIn19 _tlOallAttrDecls _tlOallAttrs _tlOallConstructors _tlOallFields _tlOallNonterminals _tlOattrDecls _tlOattrs _tlOdefSets _tlOdefinedSets _tlOoptions) _lhsOattrOrderCollect :: AttrOrderMap _lhsOattrOrderCollect = rule483 _hdIattrOrderCollect _tlIattrOrderCollect _lhsOblocks :: Blocks _lhsOblocks = rule484 _hdIblocks _tlIblocks _lhsOcollectedArounds :: [ (NontermIdent, ConstructorIdent, [AroundInfo]) ] _lhsOcollectedArounds = rule485 _hdIcollectedArounds _tlIcollectedArounds _lhsOcollectedAugments :: [ (NontermIdent, ConstructorIdent, [AugmentInfo]) ] _lhsOcollectedAugments = rule486 _hdIcollectedAugments _tlIcollectedAugments _lhsOcollectedConParams :: [(NontermIdent, ConstructorIdent, Set Identifier)] _lhsOcollectedConParams = rule487 _hdIcollectedConParams _tlIcollectedConParams _lhsOcollectedConstraints :: [(NontermIdent, ConstructorIdent, [Type])] _lhsOcollectedConstraints = rule488 _hdIcollectedConstraints _tlIcollectedConstraints _lhsOcollectedConstructorsMap :: Map NontermIdent (Set ConstructorIdent) _lhsOcollectedConstructorsMap = rule489 _hdIcollectedConstructorsMap _tlIcollectedConstructorsMap _lhsOcollectedFields :: [(NontermIdent, ConstructorIdent, FieldMap)] _lhsOcollectedFields = rule490 _hdIcollectedFields _tlIcollectedFields _lhsOcollectedInsts :: [ (NontermIdent, ConstructorIdent, [Identifier]) ] _lhsOcollectedInsts = rule491 _hdIcollectedInsts _tlIcollectedInsts _lhsOcollectedMacros :: [(NontermIdent, ConstructorIdent, MaybeMacro)] _lhsOcollectedMacros = rule492 _hdIcollectedMacros _tlIcollectedMacros _lhsOcollectedMerges :: [ (NontermIdent, ConstructorIdent, [MergeInfo]) ] _lhsOcollectedMerges = rule493 _hdIcollectedMerges _tlIcollectedMerges _lhsOcollectedNames :: Set Identifier _lhsOcollectedNames = rule494 _hdIcollectedNames _tlIcollectedNames _lhsOcollectedRules :: [ (NontermIdent, ConstructorIdent, RuleInfo)] _lhsOcollectedRules = rule495 _hdIcollectedRules _tlIcollectedRules _lhsOcollectedSetNames :: Set Identifier _lhsOcollectedSetNames = rule496 _hdIcollectedSetNames _tlIcollectedSetNames _lhsOcollectedSigs :: [ (NontermIdent, ConstructorIdent, SigInfo) ] _lhsOcollectedSigs = rule497 _hdIcollectedSigs _tlIcollectedSigs _lhsOcollectedUniques :: [ (NontermIdent, ConstructorIdent, [UniqueInfo]) ] _lhsOcollectedUniques = rule498 _hdIcollectedUniques _tlIcollectedUniques _lhsOctxCollect :: ContextMap _lhsOctxCollect = rule499 _hdIctxCollect _tlIctxCollect _lhsOderivings :: Derivings _lhsOderivings = rule500 _hdIderivings _tlIderivings _lhsOerrors :: Seq Error _lhsOerrors = rule501 _hdIerrors _tlIerrors _lhsOmoduleDecl :: Maybe (String,String,String) _lhsOmoduleDecl = rule502 _hdImoduleDecl _tlImoduleDecl _lhsOparamsCollect :: ParamMap _lhsOparamsCollect = rule503 _hdIparamsCollect _tlIparamsCollect _lhsOpragmas :: Options -> Options _lhsOpragmas = rule504 _hdIpragmas _tlIpragmas _lhsOquantCollect :: QuantMap _lhsOquantCollect = rule505 _hdIquantCollect _tlIquantCollect _lhsOsemPragmasCollect :: PragmaMap _lhsOsemPragmasCollect = rule506 _hdIsemPragmasCollect _tlIsemPragmasCollect _lhsOtypeSyns :: TypeSyns _lhsOtypeSyns = rule507 _hdItypeSyns _tlItypeSyns _lhsOuseMap :: Map NontermIdent (Map Identifier (String,String,String)) _lhsOuseMap = rule508 _hdIuseMap _tlIuseMap _lhsOwrappers :: Set NontermIdent _lhsOwrappers = rule509 _hdIwrappers _tlIwrappers _lhsOattrDecls :: Map NontermIdent (Attributes, Attributes) _lhsOattrDecls = rule510 _tlIattrDecls _lhsOattrs :: Map NontermIdent (Attributes, Attributes) _lhsOattrs = rule511 _tlIattrs _lhsOdefSets :: Map Identifier (Set NontermIdent,Set Identifier) _lhsOdefSets = rule512 _tlIdefSets _hdOallAttrDecls = rule513 _lhsIallAttrDecls _hdOallAttrs = rule514 _lhsIallAttrs _hdOallConstructors = rule515 _lhsIallConstructors _hdOallFields = rule516 _lhsIallFields _hdOallNonterminals = rule517 _lhsIallNonterminals _hdOattrDecls = rule518 _lhsIattrDecls _hdOattrs = rule519 _lhsIattrs _hdOdefSets = rule520 _lhsIdefSets _hdOdefinedSets = rule521 _lhsIdefinedSets _hdOoptions = rule522 _lhsIoptions _tlOallAttrDecls = rule523 _lhsIallAttrDecls _tlOallAttrs = rule524 _lhsIallAttrs _tlOallConstructors = rule525 _lhsIallConstructors _tlOallFields = rule526 _lhsIallFields _tlOallNonterminals = rule527 _lhsIallNonterminals _tlOattrDecls = rule528 _hdIattrDecls _tlOattrs = rule529 _hdIattrs _tlOdefSets = rule530 _hdIdefSets _tlOdefinedSets = rule531 _lhsIdefinedSets _tlOoptions = rule532 _lhsIoptions __result_ = T_Elems_vOut19 _lhsOattrDecls _lhsOattrOrderCollect _lhsOattrs _lhsOblocks _lhsOcollectedArounds _lhsOcollectedAugments _lhsOcollectedConParams _lhsOcollectedConstraints _lhsOcollectedConstructorsMap _lhsOcollectedFields _lhsOcollectedInsts _lhsOcollectedMacros _lhsOcollectedMerges _lhsOcollectedNames _lhsOcollectedRules _lhsOcollectedSetNames _lhsOcollectedSigs _lhsOcollectedUniques _lhsOctxCollect _lhsOdefSets _lhsOderivings _lhsOerrors _lhsOmoduleDecl _lhsOparamsCollect _lhsOpragmas _lhsOquantCollect _lhsOsemPragmasCollect _lhsOtypeSyns _lhsOuseMap _lhsOwrappers in __result_ ) in C_Elems_s20 v19 {-# INLINE rule483 #-} rule483 = \ ((_hdIattrOrderCollect) :: AttrOrderMap) ((_tlIattrOrderCollect) :: AttrOrderMap) -> _hdIattrOrderCollect `orderMapUnion` _tlIattrOrderCollect {-# INLINE rule484 #-} rule484 = \ ((_hdIblocks) :: Blocks) ((_tlIblocks) :: Blocks) -> _hdIblocks `mapUnionWithPlusPlus` _tlIblocks {-# INLINE rule485 #-} rule485 = \ ((_hdIcollectedArounds) :: [ (NontermIdent, ConstructorIdent, [AroundInfo]) ]) ((_tlIcollectedArounds) :: [ (NontermIdent, ConstructorIdent, [AroundInfo]) ]) -> _hdIcollectedArounds ++ _tlIcollectedArounds {-# INLINE rule486 #-} rule486 = \ ((_hdIcollectedAugments) :: [ (NontermIdent, ConstructorIdent, [AugmentInfo]) ]) ((_tlIcollectedAugments) :: [ (NontermIdent, ConstructorIdent, [AugmentInfo]) ]) -> _hdIcollectedAugments ++ _tlIcollectedAugments {-# INLINE rule487 #-} rule487 = \ ((_hdIcollectedConParams) :: [(NontermIdent, ConstructorIdent, Set Identifier)]) ((_tlIcollectedConParams) :: [(NontermIdent, ConstructorIdent, Set Identifier)]) -> _hdIcollectedConParams ++ _tlIcollectedConParams {-# INLINE rule488 #-} rule488 = \ ((_hdIcollectedConstraints) :: [(NontermIdent, ConstructorIdent, [Type])]) ((_tlIcollectedConstraints) :: [(NontermIdent, ConstructorIdent, [Type])]) -> _hdIcollectedConstraints ++ _tlIcollectedConstraints {-# INLINE rule489 #-} rule489 = \ ((_hdIcollectedConstructorsMap) :: Map NontermIdent (Set ConstructorIdent)) ((_tlIcollectedConstructorsMap) :: Map NontermIdent (Set ConstructorIdent)) -> _hdIcollectedConstructorsMap `mapUnionWithSetUnion` _tlIcollectedConstructorsMap {-# INLINE rule490 #-} rule490 = \ ((_hdIcollectedFields) :: [(NontermIdent, ConstructorIdent, FieldMap)]) ((_tlIcollectedFields) :: [(NontermIdent, ConstructorIdent, FieldMap)]) -> _hdIcollectedFields ++ _tlIcollectedFields {-# INLINE rule491 #-} rule491 = \ ((_hdIcollectedInsts) :: [ (NontermIdent, ConstructorIdent, [Identifier]) ]) ((_tlIcollectedInsts) :: [ (NontermIdent, ConstructorIdent, [Identifier]) ]) -> _hdIcollectedInsts ++ _tlIcollectedInsts {-# INLINE rule492 #-} rule492 = \ ((_hdIcollectedMacros) :: [(NontermIdent, ConstructorIdent, MaybeMacro)]) ((_tlIcollectedMacros) :: [(NontermIdent, ConstructorIdent, MaybeMacro)]) -> _hdIcollectedMacros ++ _tlIcollectedMacros {-# INLINE rule493 #-} rule493 = \ ((_hdIcollectedMerges) :: [ (NontermIdent, ConstructorIdent, [MergeInfo]) ]) ((_tlIcollectedMerges) :: [ (NontermIdent, ConstructorIdent, [MergeInfo]) ]) -> _hdIcollectedMerges ++ _tlIcollectedMerges {-# INLINE rule494 #-} rule494 = \ ((_hdIcollectedNames) :: Set Identifier) ((_tlIcollectedNames) :: Set Identifier) -> _hdIcollectedNames `Set.union` _tlIcollectedNames {-# INLINE rule495 #-} rule495 = \ ((_hdIcollectedRules) :: [ (NontermIdent, ConstructorIdent, RuleInfo)]) ((_tlIcollectedRules) :: [ (NontermIdent, ConstructorIdent, RuleInfo)]) -> _hdIcollectedRules ++ _tlIcollectedRules {-# INLINE rule496 #-} rule496 = \ ((_hdIcollectedSetNames) :: Set Identifier) ((_tlIcollectedSetNames) :: Set Identifier) -> _hdIcollectedSetNames `Set.union` _tlIcollectedSetNames {-# INLINE rule497 #-} rule497 = \ ((_hdIcollectedSigs) :: [ (NontermIdent, ConstructorIdent, SigInfo) ]) ((_tlIcollectedSigs) :: [ (NontermIdent, ConstructorIdent, SigInfo) ]) -> _hdIcollectedSigs ++ _tlIcollectedSigs {-# INLINE rule498 #-} rule498 = \ ((_hdIcollectedUniques) :: [ (NontermIdent, ConstructorIdent, [UniqueInfo]) ]) ((_tlIcollectedUniques) :: [ (NontermIdent, ConstructorIdent, [UniqueInfo]) ]) -> _hdIcollectedUniques ++ _tlIcollectedUniques {-# INLINE rule499 #-} rule499 = \ ((_hdIctxCollect) :: ContextMap) ((_tlIctxCollect) :: ContextMap) -> _hdIctxCollect `mergeCtx` _tlIctxCollect {-# INLINE rule500 #-} rule500 = \ ((_hdIderivings) :: Derivings) ((_tlIderivings) :: Derivings) -> _hdIderivings `mergeDerivings` _tlIderivings {-# INLINE rule501 #-} rule501 = \ ((_hdIerrors) :: Seq Error) ((_tlIerrors) :: Seq Error) -> _hdIerrors Seq.>< _tlIerrors {-# INLINE rule502 #-} rule502 = \ ((_hdImoduleDecl) :: Maybe (String,String,String)) ((_tlImoduleDecl) :: Maybe (String,String,String)) -> _hdImoduleDecl `flipmplus` _tlImoduleDecl {-# INLINE rule503 #-} rule503 = \ ((_hdIparamsCollect) :: ParamMap) ((_tlIparamsCollect) :: ParamMap) -> _hdIparamsCollect `mergeParams` _tlIparamsCollect {-# INLINE rule504 #-} rule504 = \ ((_hdIpragmas) :: Options -> Options) ((_tlIpragmas) :: Options -> Options) -> _hdIpragmas . _tlIpragmas {-# INLINE rule505 #-} rule505 = \ ((_hdIquantCollect) :: QuantMap) ((_tlIquantCollect) :: QuantMap) -> _hdIquantCollect `mergeQuant` _tlIquantCollect {-# INLINE rule506 #-} rule506 = \ ((_hdIsemPragmasCollect) :: PragmaMap) ((_tlIsemPragmasCollect) :: PragmaMap) -> _hdIsemPragmasCollect `pragmaMapUnion` _tlIsemPragmasCollect {-# INLINE rule507 #-} rule507 = \ ((_hdItypeSyns) :: TypeSyns) ((_tlItypeSyns) :: TypeSyns) -> _hdItypeSyns ++ _tlItypeSyns {-# INLINE rule508 #-} rule508 = \ ((_hdIuseMap) :: Map NontermIdent (Map Identifier (String,String,String))) ((_tlIuseMap) :: Map NontermIdent (Map Identifier (String,String,String))) -> _hdIuseMap `merge` _tlIuseMap {-# INLINE rule509 #-} rule509 = \ ((_hdIwrappers) :: Set NontermIdent) ((_tlIwrappers) :: Set NontermIdent) -> _hdIwrappers `Set.union` _tlIwrappers {-# INLINE rule510 #-} rule510 = \ ((_tlIattrDecls) :: Map NontermIdent (Attributes, Attributes)) -> _tlIattrDecls {-# INLINE rule511 #-} rule511 = \ ((_tlIattrs) :: Map NontermIdent (Attributes, Attributes)) -> _tlIattrs {-# INLINE rule512 #-} rule512 = \ ((_tlIdefSets) :: Map Identifier (Set NontermIdent,Set Identifier)) -> _tlIdefSets {-# INLINE rule513 #-} rule513 = \ ((_lhsIallAttrDecls) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIallAttrDecls {-# INLINE rule514 #-} rule514 = \ ((_lhsIallAttrs) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIallAttrs {-# INLINE rule515 #-} rule515 = \ ((_lhsIallConstructors) :: Map NontermIdent (Set ConstructorIdent)) -> _lhsIallConstructors {-# INLINE rule516 #-} rule516 = \ ((_lhsIallFields) :: DataTypes) -> _lhsIallFields {-# INLINE rule517 #-} rule517 = \ ((_lhsIallNonterminals) :: Set NontermIdent) -> _lhsIallNonterminals {-# INLINE rule518 #-} rule518 = \ ((_lhsIattrDecls) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIattrDecls {-# INLINE rule519 #-} rule519 = \ ((_lhsIattrs) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIattrs {-# INLINE rule520 #-} rule520 = \ ((_lhsIdefSets) :: Map Identifier (Set NontermIdent,Set Identifier)) -> _lhsIdefSets {-# INLINE rule521 #-} rule521 = \ ((_lhsIdefinedSets) :: DefinedSets) -> _lhsIdefinedSets {-# INLINE rule522 #-} rule522 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule523 #-} rule523 = \ ((_lhsIallAttrDecls) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIallAttrDecls {-# INLINE rule524 #-} rule524 = \ ((_lhsIallAttrs) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIallAttrs {-# INLINE rule525 #-} rule525 = \ ((_lhsIallConstructors) :: Map NontermIdent (Set ConstructorIdent)) -> _lhsIallConstructors {-# INLINE rule526 #-} rule526 = \ ((_lhsIallFields) :: DataTypes) -> _lhsIallFields {-# INLINE rule527 #-} rule527 = \ ((_lhsIallNonterminals) :: Set NontermIdent) -> _lhsIallNonterminals {-# INLINE rule528 #-} rule528 = \ ((_hdIattrDecls) :: Map NontermIdent (Attributes, Attributes)) -> _hdIattrDecls {-# INLINE rule529 #-} rule529 = \ ((_hdIattrs) :: Map NontermIdent (Attributes, Attributes)) -> _hdIattrs {-# INLINE rule530 #-} rule530 = \ ((_hdIdefSets) :: Map Identifier (Set NontermIdent,Set Identifier)) -> _hdIdefSets {-# INLINE rule531 #-} rule531 = \ ((_lhsIdefinedSets) :: DefinedSets) -> _lhsIdefinedSets {-# INLINE rule532 #-} rule532 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_Elems_Nil #-} sem_Elems_Nil :: T_Elems sem_Elems_Nil = T_Elems (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_Elems_v19 v19 = \ (T_Elems_vIn19 _lhsIallAttrDecls _lhsIallAttrs _lhsIallConstructors _lhsIallFields _lhsIallNonterminals _lhsIattrDecls _lhsIattrs _lhsIdefSets _lhsIdefinedSets _lhsIoptions) -> ( let _lhsOattrOrderCollect :: AttrOrderMap _lhsOattrOrderCollect = rule533 () _lhsOblocks :: Blocks _lhsOblocks = rule534 () _lhsOcollectedArounds :: [ (NontermIdent, ConstructorIdent, [AroundInfo]) ] _lhsOcollectedArounds = rule535 () _lhsOcollectedAugments :: [ (NontermIdent, ConstructorIdent, [AugmentInfo]) ] _lhsOcollectedAugments = rule536 () _lhsOcollectedConParams :: [(NontermIdent, ConstructorIdent, Set Identifier)] _lhsOcollectedConParams = rule537 () _lhsOcollectedConstraints :: [(NontermIdent, ConstructorIdent, [Type])] _lhsOcollectedConstraints = rule538 () _lhsOcollectedConstructorsMap :: Map NontermIdent (Set ConstructorIdent) _lhsOcollectedConstructorsMap = rule539 () _lhsOcollectedFields :: [(NontermIdent, ConstructorIdent, FieldMap)] _lhsOcollectedFields = rule540 () _lhsOcollectedInsts :: [ (NontermIdent, ConstructorIdent, [Identifier]) ] _lhsOcollectedInsts = rule541 () _lhsOcollectedMacros :: [(NontermIdent, ConstructorIdent, MaybeMacro)] _lhsOcollectedMacros = rule542 () _lhsOcollectedMerges :: [ (NontermIdent, ConstructorIdent, [MergeInfo]) ] _lhsOcollectedMerges = rule543 () _lhsOcollectedNames :: Set Identifier _lhsOcollectedNames = rule544 () _lhsOcollectedRules :: [ (NontermIdent, ConstructorIdent, RuleInfo)] _lhsOcollectedRules = rule545 () _lhsOcollectedSetNames :: Set Identifier _lhsOcollectedSetNames = rule546 () _lhsOcollectedSigs :: [ (NontermIdent, ConstructorIdent, SigInfo) ] _lhsOcollectedSigs = rule547 () _lhsOcollectedUniques :: [ (NontermIdent, ConstructorIdent, [UniqueInfo]) ] _lhsOcollectedUniques = rule548 () _lhsOctxCollect :: ContextMap _lhsOctxCollect = rule549 () _lhsOderivings :: Derivings _lhsOderivings = rule550 () _lhsOerrors :: Seq Error _lhsOerrors = rule551 () _lhsOmoduleDecl :: Maybe (String,String,String) _lhsOmoduleDecl = rule552 () _lhsOparamsCollect :: ParamMap _lhsOparamsCollect = rule553 () _lhsOpragmas :: Options -> Options _lhsOpragmas = rule554 () _lhsOquantCollect :: QuantMap _lhsOquantCollect = rule555 () _lhsOsemPragmasCollect :: PragmaMap _lhsOsemPragmasCollect = rule556 () _lhsOtypeSyns :: TypeSyns _lhsOtypeSyns = rule557 () _lhsOuseMap :: Map NontermIdent (Map Identifier (String,String,String)) _lhsOuseMap = rule558 () _lhsOwrappers :: Set NontermIdent _lhsOwrappers = rule559 () _lhsOattrDecls :: Map NontermIdent (Attributes, Attributes) _lhsOattrDecls = rule560 _lhsIattrDecls _lhsOattrs :: Map NontermIdent (Attributes, Attributes) _lhsOattrs = rule561 _lhsIattrs _lhsOdefSets :: Map Identifier (Set NontermIdent,Set Identifier) _lhsOdefSets = rule562 _lhsIdefSets __result_ = T_Elems_vOut19 _lhsOattrDecls _lhsOattrOrderCollect _lhsOattrs _lhsOblocks _lhsOcollectedArounds _lhsOcollectedAugments _lhsOcollectedConParams _lhsOcollectedConstraints _lhsOcollectedConstructorsMap _lhsOcollectedFields _lhsOcollectedInsts _lhsOcollectedMacros _lhsOcollectedMerges _lhsOcollectedNames _lhsOcollectedRules _lhsOcollectedSetNames _lhsOcollectedSigs _lhsOcollectedUniques _lhsOctxCollect _lhsOdefSets _lhsOderivings _lhsOerrors _lhsOmoduleDecl _lhsOparamsCollect _lhsOpragmas _lhsOquantCollect _lhsOsemPragmasCollect _lhsOtypeSyns _lhsOuseMap _lhsOwrappers in __result_ ) in C_Elems_s20 v19 {-# INLINE rule533 #-} rule533 = \ (_ :: ()) -> Map.empty {-# INLINE rule534 #-} rule534 = \ (_ :: ()) -> Map.empty {-# INLINE rule535 #-} rule535 = \ (_ :: ()) -> [] {-# INLINE rule536 #-} rule536 = \ (_ :: ()) -> [] {-# INLINE rule537 #-} rule537 = \ (_ :: ()) -> [] {-# INLINE rule538 #-} rule538 = \ (_ :: ()) -> [] {-# INLINE rule539 #-} rule539 = \ (_ :: ()) -> Map.empty {-# INLINE rule540 #-} rule540 = \ (_ :: ()) -> [] {-# INLINE rule541 #-} rule541 = \ (_ :: ()) -> [] {-# INLINE rule542 #-} rule542 = \ (_ :: ()) -> [] {-# INLINE rule543 #-} rule543 = \ (_ :: ()) -> [] {-# INLINE rule544 #-} rule544 = \ (_ :: ()) -> Set.empty {-# INLINE rule545 #-} rule545 = \ (_ :: ()) -> [] {-# INLINE rule546 #-} rule546 = \ (_ :: ()) -> Set.empty {-# INLINE rule547 #-} rule547 = \ (_ :: ()) -> [] {-# INLINE rule548 #-} rule548 = \ (_ :: ()) -> [] {-# INLINE rule549 #-} rule549 = \ (_ :: ()) -> Map.empty {-# INLINE rule550 #-} rule550 = \ (_ :: ()) -> Map.empty {-# INLINE rule551 #-} rule551 = \ (_ :: ()) -> Seq.empty {-# INLINE rule552 #-} rule552 = \ (_ :: ()) -> mzero {-# INLINE rule553 #-} rule553 = \ (_ :: ()) -> Map.empty {-# INLINE rule554 #-} rule554 = \ (_ :: ()) -> id {-# INLINE rule555 #-} rule555 = \ (_ :: ()) -> Map.empty {-# INLINE rule556 #-} rule556 = \ (_ :: ()) -> Map.empty {-# INLINE rule557 #-} rule557 = \ (_ :: ()) -> [] {-# INLINE rule558 #-} rule558 = \ (_ :: ()) -> Map.empty {-# INLINE rule559 #-} rule559 = \ (_ :: ()) -> Set.empty {-# INLINE rule560 #-} rule560 = \ ((_lhsIattrDecls) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIattrDecls {-# INLINE rule561 #-} rule561 = \ ((_lhsIattrs) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIattrs {-# INLINE rule562 #-} rule562 = \ ((_lhsIdefSets) :: Map Identifier (Set NontermIdent,Set Identifier)) -> _lhsIdefSets -- Field ------------------------------------------------------- -- wrapper data Inh_Field = Inh_Field { allNonterminals_Inh_Field :: (Set NontermIdent) } data Syn_Field = Syn_Field { collectedConstraints_Syn_Field :: ([Type]), collectedFields_Syn_Field :: ([(Identifier, Type)]) } {-# INLINABLE wrap_Field #-} wrap_Field :: T_Field -> Inh_Field -> (Syn_Field ) wrap_Field (T_Field act) (Inh_Field _lhsIallNonterminals) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Field_vIn22 _lhsIallNonterminals (T_Field_vOut22 _lhsOcollectedConstraints _lhsOcollectedFields) <- return (inv_Field_s23 sem arg) return (Syn_Field _lhsOcollectedConstraints _lhsOcollectedFields) ) -- cata {-# NOINLINE sem_Field #-} sem_Field :: Field -> T_Field sem_Field ( FChild name_ tp_ ) = sem_Field_FChild name_ tp_ sem_Field ( FCtx tps_ ) = sem_Field_FCtx tps_ -- semantic domain newtype T_Field = T_Field { attach_T_Field :: Identity (T_Field_s23 ) } newtype T_Field_s23 = C_Field_s23 { inv_Field_s23 :: (T_Field_v22 ) } data T_Field_s24 = C_Field_s24 type T_Field_v22 = (T_Field_vIn22 ) -> (T_Field_vOut22 ) data T_Field_vIn22 = T_Field_vIn22 (Set NontermIdent) data T_Field_vOut22 = T_Field_vOut22 ([Type]) ([(Identifier, Type)]) {-# NOINLINE sem_Field_FChild #-} sem_Field_FChild :: (Identifier) -> (Type) -> T_Field sem_Field_FChild arg_name_ arg_tp_ = T_Field (return st23) where {-# NOINLINE st23 #-} st23 = let v22 :: T_Field_v22 v22 = \ (T_Field_vIn22 _lhsIallNonterminals) -> ( let _lhsOcollectedFields :: [(Identifier, Type)] _lhsOcollectedFields = rule563 _lhsIallNonterminals arg_name_ arg_tp_ _lhsOcollectedConstraints :: [Type] _lhsOcollectedConstraints = rule564 () __result_ = T_Field_vOut22 _lhsOcollectedConstraints _lhsOcollectedFields in __result_ ) in C_Field_s23 v22 {-# INLINE rule563 #-} {-# LINE 579 "./src-ag/Transform.ag" #-} rule563 = \ ((_lhsIallNonterminals) :: Set NontermIdent) name_ tp_ -> {-# LINE 579 "./src-ag/Transform.ag" #-} [(name_, makeType _lhsIallNonterminals tp_)] {-# LINE 4274 "dist/build/Transform.hs"#-} {-# INLINE rule564 #-} rule564 = \ (_ :: ()) -> [] {-# NOINLINE sem_Field_FCtx #-} sem_Field_FCtx :: ([Type]) -> T_Field sem_Field_FCtx arg_tps_ = T_Field (return st23) where {-# NOINLINE st23 #-} st23 = let v22 :: T_Field_v22 v22 = \ (T_Field_vIn22 _lhsIallNonterminals) -> ( let _lhsOcollectedConstraints :: [Type] _lhsOcollectedConstraints = rule565 arg_tps_ _lhsOcollectedFields :: [(Identifier, Type)] _lhsOcollectedFields = rule566 () __result_ = T_Field_vOut22 _lhsOcollectedConstraints _lhsOcollectedFields in __result_ ) in C_Field_s23 v22 {-# INLINE rule565 #-} {-# LINE 588 "./src-ag/Transform.ag" #-} rule565 = \ tps_ -> {-# LINE 588 "./src-ag/Transform.ag" #-} tps_ {-# LINE 4297 "dist/build/Transform.hs"#-} {-# INLINE rule566 #-} rule566 = \ (_ :: ()) -> [] -- Fields ------------------------------------------------------ -- wrapper data Inh_Fields = Inh_Fields { allNonterminals_Inh_Fields :: (Set NontermIdent) } data Syn_Fields = Syn_Fields { collectedConstraints_Syn_Fields :: ([Type]), collectedFields_Syn_Fields :: ([(Identifier, Type)]) } {-# INLINABLE wrap_Fields #-} wrap_Fields :: T_Fields -> Inh_Fields -> (Syn_Fields ) wrap_Fields (T_Fields act) (Inh_Fields _lhsIallNonterminals) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Fields_vIn25 _lhsIallNonterminals (T_Fields_vOut25 _lhsOcollectedConstraints _lhsOcollectedFields) <- return (inv_Fields_s26 sem arg) return (Syn_Fields _lhsOcollectedConstraints _lhsOcollectedFields) ) -- cata {-# NOINLINE sem_Fields #-} sem_Fields :: Fields -> T_Fields sem_Fields list = Prelude.foldr sem_Fields_Cons sem_Fields_Nil (Prelude.map sem_Field list) -- semantic domain newtype T_Fields = T_Fields { attach_T_Fields :: Identity (T_Fields_s26 ) } newtype T_Fields_s26 = C_Fields_s26 { inv_Fields_s26 :: (T_Fields_v25 ) } data T_Fields_s27 = C_Fields_s27 type T_Fields_v25 = (T_Fields_vIn25 ) -> (T_Fields_vOut25 ) data T_Fields_vIn25 = T_Fields_vIn25 (Set NontermIdent) data T_Fields_vOut25 = T_Fields_vOut25 ([Type]) ([(Identifier, Type)]) {-# NOINLINE sem_Fields_Cons #-} sem_Fields_Cons :: T_Field -> T_Fields -> T_Fields sem_Fields_Cons arg_hd_ arg_tl_ = T_Fields (return st26) where {-# NOINLINE st26 #-} st26 = let v25 :: T_Fields_v25 v25 = \ (T_Fields_vIn25 _lhsIallNonterminals) -> ( let _hdX23 = Control.Monad.Identity.runIdentity (attach_T_Field (arg_hd_)) _tlX26 = Control.Monad.Identity.runIdentity (attach_T_Fields (arg_tl_)) (T_Field_vOut22 _hdIcollectedConstraints _hdIcollectedFields) = inv_Field_s23 _hdX23 (T_Field_vIn22 _hdOallNonterminals) (T_Fields_vOut25 _tlIcollectedConstraints _tlIcollectedFields) = inv_Fields_s26 _tlX26 (T_Fields_vIn25 _tlOallNonterminals) _lhsOcollectedConstraints :: [Type] _lhsOcollectedConstraints = rule567 _hdIcollectedConstraints _tlIcollectedConstraints _lhsOcollectedFields :: [(Identifier, Type)] _lhsOcollectedFields = rule568 _hdIcollectedFields _tlIcollectedFields _hdOallNonterminals = rule569 _lhsIallNonterminals _tlOallNonterminals = rule570 _lhsIallNonterminals __result_ = T_Fields_vOut25 _lhsOcollectedConstraints _lhsOcollectedFields in __result_ ) in C_Fields_s26 v25 {-# INLINE rule567 #-} rule567 = \ ((_hdIcollectedConstraints) :: [Type]) ((_tlIcollectedConstraints) :: [Type]) -> _hdIcollectedConstraints ++ _tlIcollectedConstraints {-# INLINE rule568 #-} rule568 = \ ((_hdIcollectedFields) :: [(Identifier, Type)]) ((_tlIcollectedFields) :: [(Identifier, Type)]) -> _hdIcollectedFields ++ _tlIcollectedFields {-# INLINE rule569 #-} rule569 = \ ((_lhsIallNonterminals) :: Set NontermIdent) -> _lhsIallNonterminals {-# INLINE rule570 #-} rule570 = \ ((_lhsIallNonterminals) :: Set NontermIdent) -> _lhsIallNonterminals {-# NOINLINE sem_Fields_Nil #-} sem_Fields_Nil :: T_Fields sem_Fields_Nil = T_Fields (return st26) where {-# NOINLINE st26 #-} st26 = let v25 :: T_Fields_v25 v25 = \ (T_Fields_vIn25 _lhsIallNonterminals) -> ( let _lhsOcollectedConstraints :: [Type] _lhsOcollectedConstraints = rule571 () _lhsOcollectedFields :: [(Identifier, Type)] _lhsOcollectedFields = rule572 () __result_ = T_Fields_vOut25 _lhsOcollectedConstraints _lhsOcollectedFields in __result_ ) in C_Fields_s26 v25 {-# INLINE rule571 #-} rule571 = \ (_ :: ()) -> [] {-# INLINE rule572 #-} rule572 = \ (_ :: ()) -> [] -- NontSet ----------------------------------------------------- -- wrapper data Inh_NontSet = Inh_NontSet { allFields_Inh_NontSet :: (DataTypes), allNonterminals_Inh_NontSet :: (Set NontermIdent), definedSets_Inh_NontSet :: (DefinedSets) } data Syn_NontSet = Syn_NontSet { collectedNames_Syn_NontSet :: (Set Identifier), errors_Syn_NontSet :: (Seq Error), nontSet_Syn_NontSet :: (Set NontermIdent) } {-# INLINABLE wrap_NontSet #-} wrap_NontSet :: T_NontSet -> Inh_NontSet -> (Syn_NontSet ) wrap_NontSet (T_NontSet act) (Inh_NontSet _lhsIallFields _lhsIallNonterminals _lhsIdefinedSets) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_NontSet_vIn28 _lhsIallFields _lhsIallNonterminals _lhsIdefinedSets (T_NontSet_vOut28 _lhsOcollectedNames _lhsOerrors _lhsOnontSet) <- return (inv_NontSet_s29 sem arg) return (Syn_NontSet _lhsOcollectedNames _lhsOerrors _lhsOnontSet) ) -- cata {-# NOINLINE sem_NontSet #-} sem_NontSet :: NontSet -> T_NontSet sem_NontSet ( NamedSet name_ ) = sem_NontSet_NamedSet name_ sem_NontSet ( All ) = sem_NontSet_All sem_NontSet ( Union set1_ set2_ ) = sem_NontSet_Union ( sem_NontSet set1_ ) ( sem_NontSet set2_ ) sem_NontSet ( Intersect set1_ set2_ ) = sem_NontSet_Intersect ( sem_NontSet set1_ ) ( sem_NontSet set2_ ) sem_NontSet ( Difference set1_ set2_ ) = sem_NontSet_Difference ( sem_NontSet set1_ ) ( sem_NontSet set2_ ) sem_NontSet ( Path from_ to_ ) = sem_NontSet_Path from_ to_ -- semantic domain newtype T_NontSet = T_NontSet { attach_T_NontSet :: Identity (T_NontSet_s29 ) } newtype T_NontSet_s29 = C_NontSet_s29 { inv_NontSet_s29 :: (T_NontSet_v28 ) } data T_NontSet_s30 = C_NontSet_s30 type T_NontSet_v28 = (T_NontSet_vIn28 ) -> (T_NontSet_vOut28 ) data T_NontSet_vIn28 = T_NontSet_vIn28 (DataTypes) (Set NontermIdent) (DefinedSets) data T_NontSet_vOut28 = T_NontSet_vOut28 (Set Identifier) (Seq Error) (Set NontermIdent) {-# NOINLINE sem_NontSet_NamedSet #-} sem_NontSet_NamedSet :: (NontermIdent) -> T_NontSet sem_NontSet_NamedSet arg_name_ = T_NontSet (return st29) where {-# NOINLINE st29 #-} st29 = let v28 :: T_NontSet_v28 v28 = \ (T_NontSet_vIn28 _lhsIallFields _lhsIallNonterminals _lhsIdefinedSets) -> ( let _lhsOcollectedNames :: Set Identifier _lhsOcollectedNames = rule573 arg_name_ (_nontSet,_errors) = rule574 _lhsIdefinedSets arg_name_ _lhsOerrors :: Seq Error _lhsOerrors = rule575 _errors _lhsOnontSet :: Set NontermIdent _lhsOnontSet = rule576 _nontSet __result_ = T_NontSet_vOut28 _lhsOcollectedNames _lhsOerrors _lhsOnontSet in __result_ ) in C_NontSet_s29 v28 {-# INLINE rule573 #-} {-# LINE 603 "./src-ag/Transform.ag" #-} rule573 = \ name_ -> {-# LINE 603 "./src-ag/Transform.ag" #-} Set.singleton name_ {-# LINE 4442 "dist/build/Transform.hs"#-} {-# INLINE rule574 #-} {-# LINE 733 "./src-ag/Transform.ag" #-} rule574 = \ ((_lhsIdefinedSets) :: DefinedSets) name_ -> {-# LINE 733 "./src-ag/Transform.ag" #-} case Map.lookup name_ _lhsIdefinedSets of Nothing -> (Set.empty, Seq.singleton (UndefNont name_)) Just set -> (set, Seq.empty) {-# LINE 4450 "dist/build/Transform.hs"#-} {-# INLINE rule575 #-} rule575 = \ _errors -> _errors {-# INLINE rule576 #-} rule576 = \ _nontSet -> _nontSet {-# NOINLINE sem_NontSet_All #-} sem_NontSet_All :: T_NontSet sem_NontSet_All = T_NontSet (return st29) where {-# NOINLINE st29 #-} st29 = let v28 :: T_NontSet_v28 v28 = \ (T_NontSet_vIn28 _lhsIallFields _lhsIallNonterminals _lhsIdefinedSets) -> ( let _lhsOnontSet :: Set NontermIdent _lhsOnontSet = rule577 _lhsIallNonterminals _lhsOcollectedNames :: Set Identifier _lhsOcollectedNames = rule578 () _lhsOerrors :: Seq Error _lhsOerrors = rule579 () __result_ = T_NontSet_vOut28 _lhsOcollectedNames _lhsOerrors _lhsOnontSet in __result_ ) in C_NontSet_s29 v28 {-# INLINE rule577 #-} {-# LINE 732 "./src-ag/Transform.ag" #-} rule577 = \ ((_lhsIallNonterminals) :: Set NontermIdent) -> {-# LINE 732 "./src-ag/Transform.ag" #-} _lhsIallNonterminals {-# LINE 4478 "dist/build/Transform.hs"#-} {-# INLINE rule578 #-} rule578 = \ (_ :: ()) -> Set.empty {-# INLINE rule579 #-} rule579 = \ (_ :: ()) -> Seq.empty {-# NOINLINE sem_NontSet_Union #-} sem_NontSet_Union :: T_NontSet -> T_NontSet -> T_NontSet sem_NontSet_Union arg_set1_ arg_set2_ = T_NontSet (return st29) where {-# NOINLINE st29 #-} st29 = let v28 :: T_NontSet_v28 v28 = \ (T_NontSet_vIn28 _lhsIallFields _lhsIallNonterminals _lhsIdefinedSets) -> ( let _set1X29 = Control.Monad.Identity.runIdentity (attach_T_NontSet (arg_set1_)) _set2X29 = Control.Monad.Identity.runIdentity (attach_T_NontSet (arg_set2_)) (T_NontSet_vOut28 _set1IcollectedNames _set1Ierrors _set1InontSet) = inv_NontSet_s29 _set1X29 (T_NontSet_vIn28 _set1OallFields _set1OallNonterminals _set1OdefinedSets) (T_NontSet_vOut28 _set2IcollectedNames _set2Ierrors _set2InontSet) = inv_NontSet_s29 _set2X29 (T_NontSet_vIn28 _set2OallFields _set2OallNonterminals _set2OdefinedSets) _lhsOnontSet :: Set NontermIdent _lhsOnontSet = rule580 _set1InontSet _set2InontSet _lhsOcollectedNames :: Set Identifier _lhsOcollectedNames = rule581 _set1IcollectedNames _set2IcollectedNames _lhsOerrors :: Seq Error _lhsOerrors = rule582 _set1Ierrors _set2Ierrors _set1OallFields = rule583 _lhsIallFields _set1OallNonterminals = rule584 _lhsIallNonterminals _set1OdefinedSets = rule585 _lhsIdefinedSets _set2OallFields = rule586 _lhsIallFields _set2OallNonterminals = rule587 _lhsIallNonterminals _set2OdefinedSets = rule588 _lhsIdefinedSets __result_ = T_NontSet_vOut28 _lhsOcollectedNames _lhsOerrors _lhsOnontSet in __result_ ) in C_NontSet_s29 v28 {-# INLINE rule580 #-} {-# LINE 736 "./src-ag/Transform.ag" #-} rule580 = \ ((_set1InontSet) :: Set NontermIdent) ((_set2InontSet) :: Set NontermIdent) -> {-# LINE 736 "./src-ag/Transform.ag" #-} Set.union _set1InontSet _set2InontSet {-# LINE 4516 "dist/build/Transform.hs"#-} {-# INLINE rule581 #-} rule581 = \ ((_set1IcollectedNames) :: Set Identifier) ((_set2IcollectedNames) :: Set Identifier) -> _set1IcollectedNames `Set.union` _set2IcollectedNames {-# INLINE rule582 #-} rule582 = \ ((_set1Ierrors) :: Seq Error) ((_set2Ierrors) :: Seq Error) -> _set1Ierrors Seq.>< _set2Ierrors {-# INLINE rule583 #-} rule583 = \ ((_lhsIallFields) :: DataTypes) -> _lhsIallFields {-# INLINE rule584 #-} rule584 = \ ((_lhsIallNonterminals) :: Set NontermIdent) -> _lhsIallNonterminals {-# INLINE rule585 #-} rule585 = \ ((_lhsIdefinedSets) :: DefinedSets) -> _lhsIdefinedSets {-# INLINE rule586 #-} rule586 = \ ((_lhsIallFields) :: DataTypes) -> _lhsIallFields {-# INLINE rule587 #-} rule587 = \ ((_lhsIallNonterminals) :: Set NontermIdent) -> _lhsIallNonterminals {-# INLINE rule588 #-} rule588 = \ ((_lhsIdefinedSets) :: DefinedSets) -> _lhsIdefinedSets {-# NOINLINE sem_NontSet_Intersect #-} sem_NontSet_Intersect :: T_NontSet -> T_NontSet -> T_NontSet sem_NontSet_Intersect arg_set1_ arg_set2_ = T_NontSet (return st29) where {-# NOINLINE st29 #-} st29 = let v28 :: T_NontSet_v28 v28 = \ (T_NontSet_vIn28 _lhsIallFields _lhsIallNonterminals _lhsIdefinedSets) -> ( let _set1X29 = Control.Monad.Identity.runIdentity (attach_T_NontSet (arg_set1_)) _set2X29 = Control.Monad.Identity.runIdentity (attach_T_NontSet (arg_set2_)) (T_NontSet_vOut28 _set1IcollectedNames _set1Ierrors _set1InontSet) = inv_NontSet_s29 _set1X29 (T_NontSet_vIn28 _set1OallFields _set1OallNonterminals _set1OdefinedSets) (T_NontSet_vOut28 _set2IcollectedNames _set2Ierrors _set2InontSet) = inv_NontSet_s29 _set2X29 (T_NontSet_vIn28 _set2OallFields _set2OallNonterminals _set2OdefinedSets) _lhsOnontSet :: Set NontermIdent _lhsOnontSet = rule589 _set1InontSet _set2InontSet _lhsOcollectedNames :: Set Identifier _lhsOcollectedNames = rule590 _set1IcollectedNames _set2IcollectedNames _lhsOerrors :: Seq Error _lhsOerrors = rule591 _set1Ierrors _set2Ierrors _set1OallFields = rule592 _lhsIallFields _set1OallNonterminals = rule593 _lhsIallNonterminals _set1OdefinedSets = rule594 _lhsIdefinedSets _set2OallFields = rule595 _lhsIallFields _set2OallNonterminals = rule596 _lhsIallNonterminals _set2OdefinedSets = rule597 _lhsIdefinedSets __result_ = T_NontSet_vOut28 _lhsOcollectedNames _lhsOerrors _lhsOnontSet in __result_ ) in C_NontSet_s29 v28 {-# INLINE rule589 #-} {-# LINE 737 "./src-ag/Transform.ag" #-} rule589 = \ ((_set1InontSet) :: Set NontermIdent) ((_set2InontSet) :: Set NontermIdent) -> {-# LINE 737 "./src-ag/Transform.ag" #-} Set.intersection _set1InontSet _set2InontSet {-# LINE 4572 "dist/build/Transform.hs"#-} {-# INLINE rule590 #-} rule590 = \ ((_set1IcollectedNames) :: Set Identifier) ((_set2IcollectedNames) :: Set Identifier) -> _set1IcollectedNames `Set.union` _set2IcollectedNames {-# INLINE rule591 #-} rule591 = \ ((_set1Ierrors) :: Seq Error) ((_set2Ierrors) :: Seq Error) -> _set1Ierrors Seq.>< _set2Ierrors {-# INLINE rule592 #-} rule592 = \ ((_lhsIallFields) :: DataTypes) -> _lhsIallFields {-# INLINE rule593 #-} rule593 = \ ((_lhsIallNonterminals) :: Set NontermIdent) -> _lhsIallNonterminals {-# INLINE rule594 #-} rule594 = \ ((_lhsIdefinedSets) :: DefinedSets) -> _lhsIdefinedSets {-# INLINE rule595 #-} rule595 = \ ((_lhsIallFields) :: DataTypes) -> _lhsIallFields {-# INLINE rule596 #-} rule596 = \ ((_lhsIallNonterminals) :: Set NontermIdent) -> _lhsIallNonterminals {-# INLINE rule597 #-} rule597 = \ ((_lhsIdefinedSets) :: DefinedSets) -> _lhsIdefinedSets {-# NOINLINE sem_NontSet_Difference #-} sem_NontSet_Difference :: T_NontSet -> T_NontSet -> T_NontSet sem_NontSet_Difference arg_set1_ arg_set2_ = T_NontSet (return st29) where {-# NOINLINE st29 #-} st29 = let v28 :: T_NontSet_v28 v28 = \ (T_NontSet_vIn28 _lhsIallFields _lhsIallNonterminals _lhsIdefinedSets) -> ( let _set1X29 = Control.Monad.Identity.runIdentity (attach_T_NontSet (arg_set1_)) _set2X29 = Control.Monad.Identity.runIdentity (attach_T_NontSet (arg_set2_)) (T_NontSet_vOut28 _set1IcollectedNames _set1Ierrors _set1InontSet) = inv_NontSet_s29 _set1X29 (T_NontSet_vIn28 _set1OallFields _set1OallNonterminals _set1OdefinedSets) (T_NontSet_vOut28 _set2IcollectedNames _set2Ierrors _set2InontSet) = inv_NontSet_s29 _set2X29 (T_NontSet_vIn28 _set2OallFields _set2OallNonterminals _set2OdefinedSets) _lhsOnontSet :: Set NontermIdent _lhsOnontSet = rule598 _set1InontSet _set2InontSet _lhsOcollectedNames :: Set Identifier _lhsOcollectedNames = rule599 _set1IcollectedNames _set2IcollectedNames _lhsOerrors :: Seq Error _lhsOerrors = rule600 _set1Ierrors _set2Ierrors _set1OallFields = rule601 _lhsIallFields _set1OallNonterminals = rule602 _lhsIallNonterminals _set1OdefinedSets = rule603 _lhsIdefinedSets _set2OallFields = rule604 _lhsIallFields _set2OallNonterminals = rule605 _lhsIallNonterminals _set2OdefinedSets = rule606 _lhsIdefinedSets __result_ = T_NontSet_vOut28 _lhsOcollectedNames _lhsOerrors _lhsOnontSet in __result_ ) in C_NontSet_s29 v28 {-# INLINE rule598 #-} {-# LINE 738 "./src-ag/Transform.ag" #-} rule598 = \ ((_set1InontSet) :: Set NontermIdent) ((_set2InontSet) :: Set NontermIdent) -> {-# LINE 738 "./src-ag/Transform.ag" #-} Set.difference _set1InontSet _set2InontSet {-# LINE 4628 "dist/build/Transform.hs"#-} {-# INLINE rule599 #-} rule599 = \ ((_set1IcollectedNames) :: Set Identifier) ((_set2IcollectedNames) :: Set Identifier) -> _set1IcollectedNames `Set.union` _set2IcollectedNames {-# INLINE rule600 #-} rule600 = \ ((_set1Ierrors) :: Seq Error) ((_set2Ierrors) :: Seq Error) -> _set1Ierrors Seq.>< _set2Ierrors {-# INLINE rule601 #-} rule601 = \ ((_lhsIallFields) :: DataTypes) -> _lhsIallFields {-# INLINE rule602 #-} rule602 = \ ((_lhsIallNonterminals) :: Set NontermIdent) -> _lhsIallNonterminals {-# INLINE rule603 #-} rule603 = \ ((_lhsIdefinedSets) :: DefinedSets) -> _lhsIdefinedSets {-# INLINE rule604 #-} rule604 = \ ((_lhsIallFields) :: DataTypes) -> _lhsIallFields {-# INLINE rule605 #-} rule605 = \ ((_lhsIallNonterminals) :: Set NontermIdent) -> _lhsIallNonterminals {-# INLINE rule606 #-} rule606 = \ ((_lhsIdefinedSets) :: DefinedSets) -> _lhsIdefinedSets {-# NOINLINE sem_NontSet_Path #-} sem_NontSet_Path :: (NontermIdent) -> (NontermIdent) -> T_NontSet sem_NontSet_Path arg_from_ arg_to_ = T_NontSet (return st29) where {-# NOINLINE st29 #-} st29 = let v28 :: T_NontSet_v28 v28 = \ (T_NontSet_vIn28 _lhsIallFields _lhsIallNonterminals _lhsIdefinedSets) -> ( let _lhsOnontSet :: Set NontermIdent _lhsOnontSet = rule607 _lhsIallFields arg_from_ arg_to_ _lhsOerrors :: Seq Error _lhsOerrors = rule608 _lhsIallNonterminals arg_from_ arg_to_ _lhsOcollectedNames :: Set Identifier _lhsOcollectedNames = rule609 () __result_ = T_NontSet_vOut28 _lhsOcollectedNames _lhsOerrors _lhsOnontSet in __result_ ) in C_NontSet_s29 v28 {-# INLINE rule607 #-} {-# LINE 739 "./src-ag/Transform.ag" #-} rule607 = \ ((_lhsIallFields) :: DataTypes) from_ to_ -> {-# LINE 739 "./src-ag/Transform.ag" #-} let table = flattenDatas _lhsIallFields in path table from_ to_ {-# LINE 4675 "dist/build/Transform.hs"#-} {-# INLINE rule608 #-} {-# LINE 741 "./src-ag/Transform.ag" #-} rule608 = \ ((_lhsIallNonterminals) :: Set NontermIdent) from_ to_ -> {-# LINE 741 "./src-ag/Transform.ag" #-} let check name | Set.member name _lhsIallNonterminals = Seq.empty | otherwise = Seq.singleton (UndefNont name) in check from_ >< check to_ {-# LINE 4684 "dist/build/Transform.hs"#-} {-# INLINE rule609 #-} rule609 = \ (_ :: ()) -> Set.empty -- Pattern ----------------------------------------------------- -- wrapper data Inh_Pattern = Inh_Pattern { } data Syn_Pattern = Syn_Pattern { copy_Syn_Pattern :: (Pattern), definedAttrs_Syn_Pattern :: ([AttrName]), definedInsts_Syn_Pattern :: ([Identifier]), patunder_Syn_Pattern :: ([AttrName]->Pattern), stpos_Syn_Pattern :: (Pos) } {-# INLINABLE wrap_Pattern #-} wrap_Pattern :: T_Pattern -> Inh_Pattern -> (Syn_Pattern ) wrap_Pattern (T_Pattern act) (Inh_Pattern ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Pattern_vIn31 (T_Pattern_vOut31 _lhsOcopy _lhsOdefinedAttrs _lhsOdefinedInsts _lhsOpatunder _lhsOstpos) <- return (inv_Pattern_s32 sem arg) return (Syn_Pattern _lhsOcopy _lhsOdefinedAttrs _lhsOdefinedInsts _lhsOpatunder _lhsOstpos) ) -- cata {-# NOINLINE sem_Pattern #-} sem_Pattern :: Pattern -> T_Pattern sem_Pattern ( Constr name_ pats_ ) = sem_Pattern_Constr name_ ( sem_Patterns pats_ ) sem_Pattern ( Product pos_ pats_ ) = sem_Pattern_Product pos_ ( sem_Patterns pats_ ) sem_Pattern ( Alias field_ attr_ pat_ ) = sem_Pattern_Alias field_ attr_ ( sem_Pattern pat_ ) sem_Pattern ( Irrefutable pat_ ) = sem_Pattern_Irrefutable ( sem_Pattern pat_ ) sem_Pattern ( Underscore pos_ ) = sem_Pattern_Underscore pos_ -- semantic domain newtype T_Pattern = T_Pattern { attach_T_Pattern :: Identity (T_Pattern_s32 ) } newtype T_Pattern_s32 = C_Pattern_s32 { inv_Pattern_s32 :: (T_Pattern_v31 ) } data T_Pattern_s33 = C_Pattern_s33 type T_Pattern_v31 = (T_Pattern_vIn31 ) -> (T_Pattern_vOut31 ) data T_Pattern_vIn31 = T_Pattern_vIn31 data T_Pattern_vOut31 = T_Pattern_vOut31 (Pattern) ([AttrName]) ([Identifier]) ([AttrName]->Pattern) (Pos) {-# NOINLINE sem_Pattern_Constr #-} sem_Pattern_Constr :: (ConstructorIdent) -> T_Patterns -> T_Pattern sem_Pattern_Constr arg_name_ arg_pats_ = T_Pattern (return st32) where {-# NOINLINE st32 #-} st32 = let v31 :: T_Pattern_v31 v31 = \ (T_Pattern_vIn31 ) -> ( let _patsX35 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) (T_Patterns_vOut34 _patsIcopy _patsIdefinedAttrs _patsIdefinedInsts _patsIpatunder) = inv_Patterns_s35 _patsX35 (T_Patterns_vIn34 ) _lhsOpatunder :: [AttrName]->Pattern _lhsOpatunder = rule610 _patsIpatunder arg_name_ _lhsOstpos :: Pos _lhsOstpos = rule611 arg_name_ _lhsOdefinedAttrs :: [AttrName] _lhsOdefinedAttrs = rule612 _patsIdefinedAttrs _lhsOdefinedInsts :: [Identifier] _lhsOdefinedInsts = rule613 _patsIdefinedInsts _copy = rule614 _patsIcopy arg_name_ _lhsOcopy :: Pattern _lhsOcopy = rule615 _copy __result_ = T_Pattern_vOut31 _lhsOcopy _lhsOdefinedAttrs _lhsOdefinedInsts _lhsOpatunder _lhsOstpos in __result_ ) in C_Pattern_s32 v31 {-# INLINE rule610 #-} {-# LINE 1189 "./src-ag/Transform.ag" #-} rule610 = \ ((_patsIpatunder) :: [AttrName]->Patterns) name_ -> {-# LINE 1189 "./src-ag/Transform.ag" #-} \us -> Constr name_ (_patsIpatunder us) {-# LINE 4751 "dist/build/Transform.hs"#-} {-# INLINE rule611 #-} {-# LINE 1200 "./src-ag/Transform.ag" #-} rule611 = \ name_ -> {-# LINE 1200 "./src-ag/Transform.ag" #-} getPos name_ {-# LINE 4757 "dist/build/Transform.hs"#-} {-# INLINE rule612 #-} rule612 = \ ((_patsIdefinedAttrs) :: [AttrName]) -> _patsIdefinedAttrs {-# INLINE rule613 #-} rule613 = \ ((_patsIdefinedInsts) :: [Identifier]) -> _patsIdefinedInsts {-# INLINE rule614 #-} rule614 = \ ((_patsIcopy) :: Patterns) name_ -> Constr name_ _patsIcopy {-# INLINE rule615 #-} rule615 = \ _copy -> _copy {-# NOINLINE sem_Pattern_Product #-} sem_Pattern_Product :: (Pos) -> T_Patterns -> T_Pattern sem_Pattern_Product arg_pos_ arg_pats_ = T_Pattern (return st32) where {-# NOINLINE st32 #-} st32 = let v31 :: T_Pattern_v31 v31 = \ (T_Pattern_vIn31 ) -> ( let _patsX35 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) (T_Patterns_vOut34 _patsIcopy _patsIdefinedAttrs _patsIdefinedInsts _patsIpatunder) = inv_Patterns_s35 _patsX35 (T_Patterns_vIn34 ) _lhsOpatunder :: [AttrName]->Pattern _lhsOpatunder = rule616 _patsIpatunder arg_pos_ _lhsOstpos :: Pos _lhsOstpos = rule617 arg_pos_ _lhsOdefinedAttrs :: [AttrName] _lhsOdefinedAttrs = rule618 _patsIdefinedAttrs _lhsOdefinedInsts :: [Identifier] _lhsOdefinedInsts = rule619 _patsIdefinedInsts _copy = rule620 _patsIcopy arg_pos_ _lhsOcopy :: Pattern _lhsOcopy = rule621 _copy __result_ = T_Pattern_vOut31 _lhsOcopy _lhsOdefinedAttrs _lhsOdefinedInsts _lhsOpatunder _lhsOstpos in __result_ ) in C_Pattern_s32 v31 {-# INLINE rule616 #-} {-# LINE 1190 "./src-ag/Transform.ag" #-} rule616 = \ ((_patsIpatunder) :: [AttrName]->Patterns) pos_ -> {-# LINE 1190 "./src-ag/Transform.ag" #-} \us -> Product pos_ (_patsIpatunder us) {-# LINE 4798 "dist/build/Transform.hs"#-} {-# INLINE rule617 #-} {-# LINE 1201 "./src-ag/Transform.ag" #-} rule617 = \ pos_ -> {-# LINE 1201 "./src-ag/Transform.ag" #-} pos_ {-# LINE 4804 "dist/build/Transform.hs"#-} {-# INLINE rule618 #-} rule618 = \ ((_patsIdefinedAttrs) :: [AttrName]) -> _patsIdefinedAttrs {-# INLINE rule619 #-} rule619 = \ ((_patsIdefinedInsts) :: [Identifier]) -> _patsIdefinedInsts {-# INLINE rule620 #-} rule620 = \ ((_patsIcopy) :: Patterns) pos_ -> Product pos_ _patsIcopy {-# INLINE rule621 #-} rule621 = \ _copy -> _copy {-# NOINLINE sem_Pattern_Alias #-} sem_Pattern_Alias :: (Identifier) -> (Identifier) -> T_Pattern -> T_Pattern sem_Pattern_Alias arg_field_ arg_attr_ arg_pat_ = T_Pattern (return st32) where {-# NOINLINE st32 #-} st32 = let v31 :: T_Pattern_v31 v31 = \ (T_Pattern_vIn31 ) -> ( let _patX32 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) (T_Pattern_vOut31 _patIcopy _patIdefinedAttrs _patIdefinedInsts _patIpatunder _patIstpos) = inv_Pattern_s32 _patX32 (T_Pattern_vIn31 ) _lhsOdefinedAttrs :: [AttrName] _lhsOdefinedAttrs = rule622 _patIdefinedAttrs arg_attr_ arg_field_ _lhsOpatunder :: [AttrName]->Pattern _lhsOpatunder = rule623 _copy arg_attr_ arg_field_ _lhsOdefinedInsts :: [Identifier] _lhsOdefinedInsts = rule624 _patIdefinedInsts arg_attr_ arg_field_ _lhsOstpos :: Pos _lhsOstpos = rule625 arg_field_ _copy = rule626 _patIcopy arg_attr_ arg_field_ _lhsOcopy :: Pattern _lhsOcopy = rule627 _copy __result_ = T_Pattern_vOut31 _lhsOcopy _lhsOdefinedAttrs _lhsOdefinedInsts _lhsOpatunder _lhsOstpos in __result_ ) in C_Pattern_s32 v31 {-# INLINE rule622 #-} {-# LINE 1185 "./src-ag/Transform.ag" #-} rule622 = \ ((_patIdefinedAttrs) :: [AttrName]) attr_ field_ -> {-# LINE 1185 "./src-ag/Transform.ag" #-} (field_, attr_) : _patIdefinedAttrs {-# LINE 4845 "dist/build/Transform.hs"#-} {-# INLINE rule623 #-} {-# LINE 1186 "./src-ag/Transform.ag" #-} rule623 = \ _copy attr_ field_ -> {-# LINE 1186 "./src-ag/Transform.ag" #-} \us -> if ((field_,attr_) `elem` us) then Underscore noPos else _copy {-# LINE 4851 "dist/build/Transform.hs"#-} {-# INLINE rule624 #-} {-# LINE 1187 "./src-ag/Transform.ag" #-} rule624 = \ ((_patIdefinedInsts) :: [Identifier]) attr_ field_ -> {-# LINE 1187 "./src-ag/Transform.ag" #-} (if field_ == _INST then [attr_] else []) ++ _patIdefinedInsts {-# LINE 4857 "dist/build/Transform.hs"#-} {-# INLINE rule625 #-} {-# LINE 1202 "./src-ag/Transform.ag" #-} rule625 = \ field_ -> {-# LINE 1202 "./src-ag/Transform.ag" #-} getPos field_ {-# LINE 4863 "dist/build/Transform.hs"#-} {-# INLINE rule626 #-} rule626 = \ ((_patIcopy) :: Pattern) attr_ field_ -> Alias field_ attr_ _patIcopy {-# INLINE rule627 #-} rule627 = \ _copy -> _copy {-# NOINLINE sem_Pattern_Irrefutable #-} sem_Pattern_Irrefutable :: T_Pattern -> T_Pattern sem_Pattern_Irrefutable arg_pat_ = T_Pattern (return st32) where {-# NOINLINE st32 #-} st32 = let v31 :: T_Pattern_v31 v31 = \ (T_Pattern_vIn31 ) -> ( let _patX32 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) (T_Pattern_vOut31 _patIcopy _patIdefinedAttrs _patIdefinedInsts _patIpatunder _patIstpos) = inv_Pattern_s32 _patX32 (T_Pattern_vIn31 ) _lhsOpatunder :: [AttrName]->Pattern _lhsOpatunder = rule628 _patIpatunder _lhsOdefinedAttrs :: [AttrName] _lhsOdefinedAttrs = rule629 _patIdefinedAttrs _lhsOdefinedInsts :: [Identifier] _lhsOdefinedInsts = rule630 _patIdefinedInsts _copy = rule631 _patIcopy _lhsOcopy :: Pattern _lhsOcopy = rule632 _copy _lhsOstpos :: Pos _lhsOstpos = rule633 _patIstpos __result_ = T_Pattern_vOut31 _lhsOcopy _lhsOdefinedAttrs _lhsOdefinedInsts _lhsOpatunder _lhsOstpos in __result_ ) in C_Pattern_s32 v31 {-# INLINE rule628 #-} {-# LINE 1191 "./src-ag/Transform.ag" #-} rule628 = \ ((_patIpatunder) :: [AttrName]->Pattern) -> {-# LINE 1191 "./src-ag/Transform.ag" #-} \us -> Irrefutable (_patIpatunder us) {-# LINE 4898 "dist/build/Transform.hs"#-} {-# INLINE rule629 #-} rule629 = \ ((_patIdefinedAttrs) :: [AttrName]) -> _patIdefinedAttrs {-# INLINE rule630 #-} rule630 = \ ((_patIdefinedInsts) :: [Identifier]) -> _patIdefinedInsts {-# INLINE rule631 #-} rule631 = \ ((_patIcopy) :: Pattern) -> Irrefutable _patIcopy {-# INLINE rule632 #-} rule632 = \ _copy -> _copy {-# INLINE rule633 #-} rule633 = \ ((_patIstpos) :: Pos) -> _patIstpos {-# NOINLINE sem_Pattern_Underscore #-} sem_Pattern_Underscore :: (Pos) -> T_Pattern sem_Pattern_Underscore arg_pos_ = T_Pattern (return st32) where {-# NOINLINE st32 #-} st32 = let v31 :: T_Pattern_v31 v31 = \ (T_Pattern_vIn31 ) -> ( let _lhsOpatunder :: [AttrName]->Pattern _lhsOpatunder = rule634 _copy _lhsOstpos :: Pos _lhsOstpos = rule635 arg_pos_ _lhsOdefinedAttrs :: [AttrName] _lhsOdefinedAttrs = rule636 () _lhsOdefinedInsts :: [Identifier] _lhsOdefinedInsts = rule637 () _copy = rule638 arg_pos_ _lhsOcopy :: Pattern _lhsOcopy = rule639 _copy __result_ = T_Pattern_vOut31 _lhsOcopy _lhsOdefinedAttrs _lhsOdefinedInsts _lhsOpatunder _lhsOstpos in __result_ ) in C_Pattern_s32 v31 {-# INLINE rule634 #-} {-# LINE 1188 "./src-ag/Transform.ag" #-} rule634 = \ _copy -> {-# LINE 1188 "./src-ag/Transform.ag" #-} \_ -> _copy {-# LINE 4940 "dist/build/Transform.hs"#-} {-# INLINE rule635 #-} {-# LINE 1203 "./src-ag/Transform.ag" #-} rule635 = \ pos_ -> {-# LINE 1203 "./src-ag/Transform.ag" #-} pos_ {-# LINE 4946 "dist/build/Transform.hs"#-} {-# INLINE rule636 #-} rule636 = \ (_ :: ()) -> [] {-# INLINE rule637 #-} rule637 = \ (_ :: ()) -> [] {-# INLINE rule638 #-} rule638 = \ pos_ -> Underscore pos_ {-# INLINE rule639 #-} rule639 = \ _copy -> _copy -- Patterns ---------------------------------------------------- -- wrapper data Inh_Patterns = Inh_Patterns { } data Syn_Patterns = Syn_Patterns { copy_Syn_Patterns :: (Patterns), definedAttrs_Syn_Patterns :: ([AttrName]), definedInsts_Syn_Patterns :: ([Identifier]), patunder_Syn_Patterns :: ([AttrName]->Patterns) } {-# INLINABLE wrap_Patterns #-} wrap_Patterns :: T_Patterns -> Inh_Patterns -> (Syn_Patterns ) wrap_Patterns (T_Patterns act) (Inh_Patterns ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Patterns_vIn34 (T_Patterns_vOut34 _lhsOcopy _lhsOdefinedAttrs _lhsOdefinedInsts _lhsOpatunder) <- return (inv_Patterns_s35 sem arg) return (Syn_Patterns _lhsOcopy _lhsOdefinedAttrs _lhsOdefinedInsts _lhsOpatunder) ) -- cata {-# NOINLINE sem_Patterns #-} sem_Patterns :: Patterns -> T_Patterns sem_Patterns list = Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list) -- semantic domain newtype T_Patterns = T_Patterns { attach_T_Patterns :: Identity (T_Patterns_s35 ) } newtype T_Patterns_s35 = C_Patterns_s35 { inv_Patterns_s35 :: (T_Patterns_v34 ) } data T_Patterns_s36 = C_Patterns_s36 type T_Patterns_v34 = (T_Patterns_vIn34 ) -> (T_Patterns_vOut34 ) data T_Patterns_vIn34 = T_Patterns_vIn34 data T_Patterns_vOut34 = T_Patterns_vOut34 (Patterns) ([AttrName]) ([Identifier]) ([AttrName]->Patterns) {-# NOINLINE sem_Patterns_Cons #-} sem_Patterns_Cons :: T_Pattern -> T_Patterns -> T_Patterns sem_Patterns_Cons arg_hd_ arg_tl_ = T_Patterns (return st35) where {-# NOINLINE st35 #-} st35 = let v34 :: T_Patterns_v34 v34 = \ (T_Patterns_vIn34 ) -> ( let _hdX32 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_hd_)) _tlX35 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_tl_)) (T_Pattern_vOut31 _hdIcopy _hdIdefinedAttrs _hdIdefinedInsts _hdIpatunder _hdIstpos) = inv_Pattern_s32 _hdX32 (T_Pattern_vIn31 ) (T_Patterns_vOut34 _tlIcopy _tlIdefinedAttrs _tlIdefinedInsts _tlIpatunder) = inv_Patterns_s35 _tlX35 (T_Patterns_vIn34 ) _lhsOpatunder :: [AttrName]->Patterns _lhsOpatunder = rule640 _hdIpatunder _tlIpatunder _lhsOdefinedAttrs :: [AttrName] _lhsOdefinedAttrs = rule641 _hdIdefinedAttrs _tlIdefinedAttrs _lhsOdefinedInsts :: [Identifier] _lhsOdefinedInsts = rule642 _hdIdefinedInsts _tlIdefinedInsts _copy = rule643 _hdIcopy _tlIcopy _lhsOcopy :: Patterns _lhsOcopy = rule644 _copy __result_ = T_Patterns_vOut34 _lhsOcopy _lhsOdefinedAttrs _lhsOdefinedInsts _lhsOpatunder in __result_ ) in C_Patterns_s35 v34 {-# INLINE rule640 #-} {-# LINE 1195 "./src-ag/Transform.ag" #-} rule640 = \ ((_hdIpatunder) :: [AttrName]->Pattern) ((_tlIpatunder) :: [AttrName]->Patterns) -> {-# LINE 1195 "./src-ag/Transform.ag" #-} \us -> (_hdIpatunder us) : (_tlIpatunder us) {-# LINE 5018 "dist/build/Transform.hs"#-} {-# INLINE rule641 #-} rule641 = \ ((_hdIdefinedAttrs) :: [AttrName]) ((_tlIdefinedAttrs) :: [AttrName]) -> _hdIdefinedAttrs ++ _tlIdefinedAttrs {-# INLINE rule642 #-} rule642 = \ ((_hdIdefinedInsts) :: [Identifier]) ((_tlIdefinedInsts) :: [Identifier]) -> _hdIdefinedInsts ++ _tlIdefinedInsts {-# INLINE rule643 #-} rule643 = \ ((_hdIcopy) :: Pattern) ((_tlIcopy) :: Patterns) -> (:) _hdIcopy _tlIcopy {-# INLINE rule644 #-} rule644 = \ _copy -> _copy {-# NOINLINE sem_Patterns_Nil #-} sem_Patterns_Nil :: T_Patterns sem_Patterns_Nil = T_Patterns (return st35) where {-# NOINLINE st35 #-} st35 = let v34 :: T_Patterns_v34 v34 = \ (T_Patterns_vIn34 ) -> ( let _lhsOpatunder :: [AttrName]->Patterns _lhsOpatunder = rule645 () _lhsOdefinedAttrs :: [AttrName] _lhsOdefinedAttrs = rule646 () _lhsOdefinedInsts :: [Identifier] _lhsOdefinedInsts = rule647 () _copy = rule648 () _lhsOcopy :: Patterns _lhsOcopy = rule649 _copy __result_ = T_Patterns_vOut34 _lhsOcopy _lhsOdefinedAttrs _lhsOdefinedInsts _lhsOpatunder in __result_ ) in C_Patterns_s35 v34 {-# INLINE rule645 #-} {-# LINE 1194 "./src-ag/Transform.ag" #-} rule645 = \ (_ :: ()) -> {-# LINE 1194 "./src-ag/Transform.ag" #-} \_ -> [] {-# LINE 5055 "dist/build/Transform.hs"#-} {-# INLINE rule646 #-} rule646 = \ (_ :: ()) -> [] {-# INLINE rule647 #-} rule647 = \ (_ :: ()) -> [] {-# INLINE rule648 #-} rule648 = \ (_ :: ()) -> [] {-# INLINE rule649 #-} rule649 = \ _copy -> _copy -- SemAlt ------------------------------------------------------ -- wrapper data Inh_SemAlt = Inh_SemAlt { allAttrDecls_Inh_SemAlt :: (Map NontermIdent (Attributes, Attributes)), allAttrs_Inh_SemAlt :: (Map NontermIdent (Attributes, Attributes)), allFields_Inh_SemAlt :: (DataTypes), nts_Inh_SemAlt :: (Set NontermIdent), options_Inh_SemAlt :: (Options) } data Syn_SemAlt = Syn_SemAlt { attrOrderCollect_Syn_SemAlt :: (AttrOrderMap), collectedArounds_Syn_SemAlt :: ([ (NontermIdent, ConstructorIdent, [AroundInfo]) ]), collectedAugments_Syn_SemAlt :: ([ (NontermIdent, ConstructorIdent, [AugmentInfo]) ]), collectedInsts_Syn_SemAlt :: ([ (NontermIdent, ConstructorIdent, [Identifier]) ]), collectedMerges_Syn_SemAlt :: ([ (NontermIdent, ConstructorIdent, [MergeInfo]) ]), collectedRules_Syn_SemAlt :: ([ (NontermIdent, ConstructorIdent, RuleInfo)]), collectedSigs_Syn_SemAlt :: ([ (NontermIdent, ConstructorIdent, SigInfo) ]), collectedUniques_Syn_SemAlt :: ([ (NontermIdent, ConstructorIdent, [UniqueInfo]) ]), errors_Syn_SemAlt :: (Seq Error), semPragmasCollect_Syn_SemAlt :: (PragmaMap) } {-# INLINABLE wrap_SemAlt #-} wrap_SemAlt :: T_SemAlt -> Inh_SemAlt -> (Syn_SemAlt ) wrap_SemAlt (T_SemAlt act) (Inh_SemAlt _lhsIallAttrDecls _lhsIallAttrs _lhsIallFields _lhsInts _lhsIoptions) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_SemAlt_vIn37 _lhsIallAttrDecls _lhsIallAttrs _lhsIallFields _lhsInts _lhsIoptions (T_SemAlt_vOut37 _lhsOattrOrderCollect _lhsOcollectedArounds _lhsOcollectedAugments _lhsOcollectedInsts _lhsOcollectedMerges _lhsOcollectedRules _lhsOcollectedSigs _lhsOcollectedUniques _lhsOerrors _lhsOsemPragmasCollect) <- return (inv_SemAlt_s38 sem arg) return (Syn_SemAlt _lhsOattrOrderCollect _lhsOcollectedArounds _lhsOcollectedAugments _lhsOcollectedInsts _lhsOcollectedMerges _lhsOcollectedRules _lhsOcollectedSigs _lhsOcollectedUniques _lhsOerrors _lhsOsemPragmasCollect) ) -- cata {-# INLINE sem_SemAlt #-} sem_SemAlt :: SemAlt -> T_SemAlt sem_SemAlt ( SemAlt pos_ constructorSet_ rules_ ) = sem_SemAlt_SemAlt pos_ ( sem_ConstructorSet constructorSet_ ) ( sem_SemDefs rules_ ) -- semantic domain newtype T_SemAlt = T_SemAlt { attach_T_SemAlt :: Identity (T_SemAlt_s38 ) } newtype T_SemAlt_s38 = C_SemAlt_s38 { inv_SemAlt_s38 :: (T_SemAlt_v37 ) } data T_SemAlt_s39 = C_SemAlt_s39 type T_SemAlt_v37 = (T_SemAlt_vIn37 ) -> (T_SemAlt_vOut37 ) data T_SemAlt_vIn37 = T_SemAlt_vIn37 (Map NontermIdent (Attributes, Attributes)) (Map NontermIdent (Attributes, Attributes)) (DataTypes) (Set NontermIdent) (Options) data T_SemAlt_vOut37 = T_SemAlt_vOut37 (AttrOrderMap) ([ (NontermIdent, ConstructorIdent, [AroundInfo]) ]) ([ (NontermIdent, ConstructorIdent, [AugmentInfo]) ]) ([ (NontermIdent, ConstructorIdent, [Identifier]) ]) ([ (NontermIdent, ConstructorIdent, [MergeInfo]) ]) ([ (NontermIdent, ConstructorIdent, RuleInfo)]) ([ (NontermIdent, ConstructorIdent, SigInfo) ]) ([ (NontermIdent, ConstructorIdent, [UniqueInfo]) ]) (Seq Error) (PragmaMap) {-# NOINLINE sem_SemAlt_SemAlt #-} sem_SemAlt_SemAlt :: (Pos) -> T_ConstructorSet -> T_SemDefs -> T_SemAlt sem_SemAlt_SemAlt _ arg_constructorSet_ arg_rules_ = T_SemAlt (return st38) where {-# NOINLINE st38 #-} st38 = let v37 :: T_SemAlt_v37 v37 = \ (T_SemAlt_vIn37 _lhsIallAttrDecls _lhsIallAttrs _lhsIallFields _lhsInts _lhsIoptions) -> ( let _constructorSetX14 = Control.Monad.Identity.runIdentity (attach_T_ConstructorSet (arg_constructorSet_)) _rulesX47 = Control.Monad.Identity.runIdentity (attach_T_SemDefs (arg_rules_)) (T_ConstructorSet_vOut13 _constructorSetIcollectedConstructorNames _constructorSetIconstructors _constructorSetIerrors) = inv_ConstructorSet_s14 _constructorSetX14 (T_ConstructorSet_vIn13 ) (T_SemDefs_vOut46 _rulesIaroundInfos _rulesIaugmentInfos _rulesIdefinedInsts _rulesIerrors _rulesImergeInfos _rulesIorderDepsCollect _rulesIpragmaNamesCollect _rulesIruleInfos _rulesIsigInfos _rulesIuniqueInfos) = inv_SemDefs_s47 _rulesX47 (T_SemDefs_vIn46 _rulesOoptions) _pragmaNames = rule650 _rulesIpragmaNamesCollect _lhsOsemPragmasCollect :: PragmaMap _lhsOsemPragmasCollect = rule651 _coninfo _pragmaNames _attrOrders = rule652 _coninfo _rulesIorderDepsCollect _lhsOattrOrderCollect :: AttrOrderMap _lhsOattrOrderCollect = rule653 _attrOrders _coninfo = rule654 _constructorSetIconstructors _lhsIallFields _lhsInts _lhsOerrors :: Seq Error _lhsOerrors = rule655 _coninfo _rulesIerrors _lhsOcollectedRules :: [ (NontermIdent, ConstructorIdent, RuleInfo)] _lhsOcollectedRules = rule656 _coninfo _rulesIruleInfos _lhsOcollectedSigs :: [ (NontermIdent, ConstructorIdent, SigInfo) ] _lhsOcollectedSigs = rule657 _coninfo _rulesIsigInfos _lhsOcollectedInsts :: [ (NontermIdent, ConstructorIdent, [Identifier]) ] _lhsOcollectedInsts = rule658 _coninfo _rulesIdefinedInsts _lhsOcollectedUniques :: [ (NontermIdent, ConstructorIdent, [UniqueInfo]) ] _lhsOcollectedUniques = rule659 _coninfo _rulesIuniqueInfos _lhsOcollectedAugments :: [ (NontermIdent, ConstructorIdent, [AugmentInfo]) ] _lhsOcollectedAugments = rule660 _coninfo _rulesIaugmentInfos _lhsOcollectedArounds :: [ (NontermIdent, ConstructorIdent, [AroundInfo]) ] _lhsOcollectedArounds = rule661 _coninfo _rulesIaroundInfos _lhsOcollectedMerges :: [ (NontermIdent, ConstructorIdent, [MergeInfo]) ] _lhsOcollectedMerges = rule662 _coninfo _rulesImergeInfos _rulesOoptions = rule663 _lhsIoptions __result_ = T_SemAlt_vOut37 _lhsOattrOrderCollect _lhsOcollectedArounds _lhsOcollectedAugments _lhsOcollectedInsts _lhsOcollectedMerges _lhsOcollectedRules _lhsOcollectedSigs _lhsOcollectedUniques _lhsOerrors _lhsOsemPragmasCollect in __result_ ) in C_SemAlt_s38 v37 {-# INLINE rule650 #-} {-# LINE 887 "./src-ag/Transform.ag" #-} rule650 = \ ((_rulesIpragmaNamesCollect) :: [Identifier]) -> {-# LINE 887 "./src-ag/Transform.ag" #-} Set.fromList _rulesIpragmaNamesCollect {-# LINE 5142 "dist/build/Transform.hs"#-} {-# INLINE rule651 #-} {-# LINE 888 "./src-ag/Transform.ag" #-} rule651 = \ _coninfo _pragmaNames -> {-# LINE 888 "./src-ag/Transform.ag" #-} foldr pragmaMapUnion Map.empty [ pragmaMapSingle nt con _pragmaNames | (nt, conset, _) <- _coninfo , con <- Set.toList conset ] {-# LINE 5151 "dist/build/Transform.hs"#-} {-# INLINE rule652 #-} {-# LINE 917 "./src-ag/Transform.ag" #-} rule652 = \ _coninfo ((_rulesIorderDepsCollect) :: Set Dependency) -> {-# LINE 917 "./src-ag/Transform.ag" #-} [ orderMapSingle nt con _rulesIorderDepsCollect | (nt, conset, _) <- _coninfo , con <- Set.toList conset ] {-# LINE 5160 "dist/build/Transform.hs"#-} {-# INLINE rule653 #-} {-# LINE 922 "./src-ag/Transform.ag" #-} rule653 = \ _attrOrders -> {-# LINE 922 "./src-ag/Transform.ag" #-} foldr orderMapUnion Map.empty _attrOrders {-# LINE 5166 "dist/build/Transform.hs"#-} {-# INLINE rule654 #-} {-# LINE 1104 "./src-ag/Transform.ag" #-} rule654 = \ ((_constructorSetIconstructors) :: (Set ConstructorIdent->Set ConstructorIdent)) ((_lhsIallFields) :: DataTypes) ((_lhsInts) :: Set NontermIdent) -> {-# LINE 1104 "./src-ag/Transform.ag" #-} [ (nt, conset, conkeys) | nt <- Set.toList _lhsInts , let conmap = Map.findWithDefault Map.empty nt _lhsIallFields , let conkeys = Set.fromList (Map.keys conmap) , let conset = _constructorSetIconstructors conkeys ] {-# LINE 5177 "dist/build/Transform.hs"#-} {-# INLINE rule655 #-} {-# LINE 1111 "./src-ag/Transform.ag" #-} rule655 = \ _coninfo ((_rulesIerrors) :: Seq Error) -> {-# LINE 1111 "./src-ag/Transform.ag" #-} Seq.fromList [ UndefAlt nt con | (nt, conset, conkeys) <- _coninfo , con <- Set.toList (Set.difference conset conkeys) ] Seq.>< _rulesIerrors {-# LINE 5188 "dist/build/Transform.hs"#-} {-# INLINE rule656 #-} {-# LINE 1118 "./src-ag/Transform.ag" #-} rule656 = \ _coninfo ((_rulesIruleInfos) :: [RuleInfo]) -> {-# LINE 1118 "./src-ag/Transform.ag" #-} [ (nt,con,r) | (nt, conset, _) <- _coninfo , con <- Set.toList conset , r <- _rulesIruleInfos ] {-# LINE 5198 "dist/build/Transform.hs"#-} {-# INLINE rule657 #-} {-# LINE 1124 "./src-ag/Transform.ag" #-} rule657 = \ _coninfo ((_rulesIsigInfos) :: [SigInfo]) -> {-# LINE 1124 "./src-ag/Transform.ag" #-} [ (nt,con,ts) | (nt, conset, _) <- _coninfo , con <- Set.toList conset , ts <- _rulesIsigInfos ] {-# LINE 5208 "dist/build/Transform.hs"#-} {-# INLINE rule658 #-} {-# LINE 1131 "./src-ag/Transform.ag" #-} rule658 = \ _coninfo ((_rulesIdefinedInsts) :: [Identifier]) -> {-# LINE 1131 "./src-ag/Transform.ag" #-} [ (nt,con,_rulesIdefinedInsts) | (nt, conset, _) <- _coninfo , con <- Set.toList conset ] {-# LINE 5217 "dist/build/Transform.hs"#-} {-# INLINE rule659 #-} {-# LINE 1137 "./src-ag/Transform.ag" #-} rule659 = \ _coninfo ((_rulesIuniqueInfos) :: [UniqueInfo]) -> {-# LINE 1137 "./src-ag/Transform.ag" #-} [ (nt,con,_rulesIuniqueInfos) | (nt, conset, _) <- _coninfo , con <- Set.toList conset ] {-# LINE 5226 "dist/build/Transform.hs"#-} {-# INLINE rule660 #-} {-# LINE 1143 "./src-ag/Transform.ag" #-} rule660 = \ _coninfo ((_rulesIaugmentInfos) :: [AugmentInfo]) -> {-# LINE 1143 "./src-ag/Transform.ag" #-} [ (nt, con, _rulesIaugmentInfos) | (nt, conset, _) <- _coninfo , con <- Set.toList conset ] {-# LINE 5235 "dist/build/Transform.hs"#-} {-# INLINE rule661 #-} {-# LINE 1149 "./src-ag/Transform.ag" #-} rule661 = \ _coninfo ((_rulesIaroundInfos) :: [AroundInfo]) -> {-# LINE 1149 "./src-ag/Transform.ag" #-} [ (nt, con, _rulesIaroundInfos) | (nt, conset, _) <- _coninfo , con <- Set.toList conset ] {-# LINE 5244 "dist/build/Transform.hs"#-} {-# INLINE rule662 #-} {-# LINE 1155 "./src-ag/Transform.ag" #-} rule662 = \ _coninfo ((_rulesImergeInfos) :: [MergeInfo]) -> {-# LINE 1155 "./src-ag/Transform.ag" #-} [ (nt, con, _rulesImergeInfos) | (nt, conset, _) <- _coninfo , con <- Set.toList conset ] {-# LINE 5253 "dist/build/Transform.hs"#-} {-# INLINE rule663 #-} rule663 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions -- SemAlts ----------------------------------------------------- -- wrapper data Inh_SemAlts = Inh_SemAlts { allAttrDecls_Inh_SemAlts :: (Map NontermIdent (Attributes, Attributes)), allAttrs_Inh_SemAlts :: (Map NontermIdent (Attributes, Attributes)), allFields_Inh_SemAlts :: (DataTypes), nts_Inh_SemAlts :: (Set NontermIdent), options_Inh_SemAlts :: (Options) } data Syn_SemAlts = Syn_SemAlts { attrOrderCollect_Syn_SemAlts :: (AttrOrderMap), collectedArounds_Syn_SemAlts :: ([ (NontermIdent, ConstructorIdent, [AroundInfo]) ]), collectedAugments_Syn_SemAlts :: ([ (NontermIdent, ConstructorIdent, [AugmentInfo]) ]), collectedInsts_Syn_SemAlts :: ([ (NontermIdent, ConstructorIdent, [Identifier]) ]), collectedMerges_Syn_SemAlts :: ([ (NontermIdent, ConstructorIdent, [MergeInfo]) ]), collectedRules_Syn_SemAlts :: ([ (NontermIdent, ConstructorIdent, RuleInfo)]), collectedSigs_Syn_SemAlts :: ([ (NontermIdent, ConstructorIdent, SigInfo) ]), collectedUniques_Syn_SemAlts :: ([ (NontermIdent, ConstructorIdent, [UniqueInfo]) ]), errors_Syn_SemAlts :: (Seq Error), semPragmasCollect_Syn_SemAlts :: (PragmaMap) } {-# INLINABLE wrap_SemAlts #-} wrap_SemAlts :: T_SemAlts -> Inh_SemAlts -> (Syn_SemAlts ) wrap_SemAlts (T_SemAlts act) (Inh_SemAlts _lhsIallAttrDecls _lhsIallAttrs _lhsIallFields _lhsInts _lhsIoptions) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_SemAlts_vIn40 _lhsIallAttrDecls _lhsIallAttrs _lhsIallFields _lhsInts _lhsIoptions (T_SemAlts_vOut40 _lhsOattrOrderCollect _lhsOcollectedArounds _lhsOcollectedAugments _lhsOcollectedInsts _lhsOcollectedMerges _lhsOcollectedRules _lhsOcollectedSigs _lhsOcollectedUniques _lhsOerrors _lhsOsemPragmasCollect) <- return (inv_SemAlts_s41 sem arg) return (Syn_SemAlts _lhsOattrOrderCollect _lhsOcollectedArounds _lhsOcollectedAugments _lhsOcollectedInsts _lhsOcollectedMerges _lhsOcollectedRules _lhsOcollectedSigs _lhsOcollectedUniques _lhsOerrors _lhsOsemPragmasCollect) ) -- cata {-# NOINLINE sem_SemAlts #-} sem_SemAlts :: SemAlts -> T_SemAlts sem_SemAlts list = Prelude.foldr sem_SemAlts_Cons sem_SemAlts_Nil (Prelude.map sem_SemAlt list) -- semantic domain newtype T_SemAlts = T_SemAlts { attach_T_SemAlts :: Identity (T_SemAlts_s41 ) } newtype T_SemAlts_s41 = C_SemAlts_s41 { inv_SemAlts_s41 :: (T_SemAlts_v40 ) } data T_SemAlts_s42 = C_SemAlts_s42 type T_SemAlts_v40 = (T_SemAlts_vIn40 ) -> (T_SemAlts_vOut40 ) data T_SemAlts_vIn40 = T_SemAlts_vIn40 (Map NontermIdent (Attributes, Attributes)) (Map NontermIdent (Attributes, Attributes)) (DataTypes) (Set NontermIdent) (Options) data T_SemAlts_vOut40 = T_SemAlts_vOut40 (AttrOrderMap) ([ (NontermIdent, ConstructorIdent, [AroundInfo]) ]) ([ (NontermIdent, ConstructorIdent, [AugmentInfo]) ]) ([ (NontermIdent, ConstructorIdent, [Identifier]) ]) ([ (NontermIdent, ConstructorIdent, [MergeInfo]) ]) ([ (NontermIdent, ConstructorIdent, RuleInfo)]) ([ (NontermIdent, ConstructorIdent, SigInfo) ]) ([ (NontermIdent, ConstructorIdent, [UniqueInfo]) ]) (Seq Error) (PragmaMap) {-# NOINLINE sem_SemAlts_Cons #-} sem_SemAlts_Cons :: T_SemAlt -> T_SemAlts -> T_SemAlts sem_SemAlts_Cons arg_hd_ arg_tl_ = T_SemAlts (return st41) where {-# NOINLINE st41 #-} st41 = let v40 :: T_SemAlts_v40 v40 = \ (T_SemAlts_vIn40 _lhsIallAttrDecls _lhsIallAttrs _lhsIallFields _lhsInts _lhsIoptions) -> ( let _hdX38 = Control.Monad.Identity.runIdentity (attach_T_SemAlt (arg_hd_)) _tlX41 = Control.Monad.Identity.runIdentity (attach_T_SemAlts (arg_tl_)) (T_SemAlt_vOut37 _hdIattrOrderCollect _hdIcollectedArounds _hdIcollectedAugments _hdIcollectedInsts _hdIcollectedMerges _hdIcollectedRules _hdIcollectedSigs _hdIcollectedUniques _hdIerrors _hdIsemPragmasCollect) = inv_SemAlt_s38 _hdX38 (T_SemAlt_vIn37 _hdOallAttrDecls _hdOallAttrs _hdOallFields _hdOnts _hdOoptions) (T_SemAlts_vOut40 _tlIattrOrderCollect _tlIcollectedArounds _tlIcollectedAugments _tlIcollectedInsts _tlIcollectedMerges _tlIcollectedRules _tlIcollectedSigs _tlIcollectedUniques _tlIerrors _tlIsemPragmasCollect) = inv_SemAlts_s41 _tlX41 (T_SemAlts_vIn40 _tlOallAttrDecls _tlOallAttrs _tlOallFields _tlOnts _tlOoptions) _lhsOattrOrderCollect :: AttrOrderMap _lhsOattrOrderCollect = rule664 _hdIattrOrderCollect _tlIattrOrderCollect _lhsOcollectedArounds :: [ (NontermIdent, ConstructorIdent, [AroundInfo]) ] _lhsOcollectedArounds = rule665 _hdIcollectedArounds _tlIcollectedArounds _lhsOcollectedAugments :: [ (NontermIdent, ConstructorIdent, [AugmentInfo]) ] _lhsOcollectedAugments = rule666 _hdIcollectedAugments _tlIcollectedAugments _lhsOcollectedInsts :: [ (NontermIdent, ConstructorIdent, [Identifier]) ] _lhsOcollectedInsts = rule667 _hdIcollectedInsts _tlIcollectedInsts _lhsOcollectedMerges :: [ (NontermIdent, ConstructorIdent, [MergeInfo]) ] _lhsOcollectedMerges = rule668 _hdIcollectedMerges _tlIcollectedMerges _lhsOcollectedRules :: [ (NontermIdent, ConstructorIdent, RuleInfo)] _lhsOcollectedRules = rule669 _hdIcollectedRules _tlIcollectedRules _lhsOcollectedSigs :: [ (NontermIdent, ConstructorIdent, SigInfo) ] _lhsOcollectedSigs = rule670 _hdIcollectedSigs _tlIcollectedSigs _lhsOcollectedUniques :: [ (NontermIdent, ConstructorIdent, [UniqueInfo]) ] _lhsOcollectedUniques = rule671 _hdIcollectedUniques _tlIcollectedUniques _lhsOerrors :: Seq Error _lhsOerrors = rule672 _hdIerrors _tlIerrors _lhsOsemPragmasCollect :: PragmaMap _lhsOsemPragmasCollect = rule673 _hdIsemPragmasCollect _tlIsemPragmasCollect _hdOallAttrDecls = rule674 _lhsIallAttrDecls _hdOallAttrs = rule675 _lhsIallAttrs _hdOallFields = rule676 _lhsIallFields _hdOnts = rule677 _lhsInts _hdOoptions = rule678 _lhsIoptions _tlOallAttrDecls = rule679 _lhsIallAttrDecls _tlOallAttrs = rule680 _lhsIallAttrs _tlOallFields = rule681 _lhsIallFields _tlOnts = rule682 _lhsInts _tlOoptions = rule683 _lhsIoptions __result_ = T_SemAlts_vOut40 _lhsOattrOrderCollect _lhsOcollectedArounds _lhsOcollectedAugments _lhsOcollectedInsts _lhsOcollectedMerges _lhsOcollectedRules _lhsOcollectedSigs _lhsOcollectedUniques _lhsOerrors _lhsOsemPragmasCollect in __result_ ) in C_SemAlts_s41 v40 {-# INLINE rule664 #-} rule664 = \ ((_hdIattrOrderCollect) :: AttrOrderMap) ((_tlIattrOrderCollect) :: AttrOrderMap) -> _hdIattrOrderCollect `orderMapUnion` _tlIattrOrderCollect {-# INLINE rule665 #-} rule665 = \ ((_hdIcollectedArounds) :: [ (NontermIdent, ConstructorIdent, [AroundInfo]) ]) ((_tlIcollectedArounds) :: [ (NontermIdent, ConstructorIdent, [AroundInfo]) ]) -> _hdIcollectedArounds ++ _tlIcollectedArounds {-# INLINE rule666 #-} rule666 = \ ((_hdIcollectedAugments) :: [ (NontermIdent, ConstructorIdent, [AugmentInfo]) ]) ((_tlIcollectedAugments) :: [ (NontermIdent, ConstructorIdent, [AugmentInfo]) ]) -> _hdIcollectedAugments ++ _tlIcollectedAugments {-# INLINE rule667 #-} rule667 = \ ((_hdIcollectedInsts) :: [ (NontermIdent, ConstructorIdent, [Identifier]) ]) ((_tlIcollectedInsts) :: [ (NontermIdent, ConstructorIdent, [Identifier]) ]) -> _hdIcollectedInsts ++ _tlIcollectedInsts {-# INLINE rule668 #-} rule668 = \ ((_hdIcollectedMerges) :: [ (NontermIdent, ConstructorIdent, [MergeInfo]) ]) ((_tlIcollectedMerges) :: [ (NontermIdent, ConstructorIdent, [MergeInfo]) ]) -> _hdIcollectedMerges ++ _tlIcollectedMerges {-# INLINE rule669 #-} rule669 = \ ((_hdIcollectedRules) :: [ (NontermIdent, ConstructorIdent, RuleInfo)]) ((_tlIcollectedRules) :: [ (NontermIdent, ConstructorIdent, RuleInfo)]) -> _hdIcollectedRules ++ _tlIcollectedRules {-# INLINE rule670 #-} rule670 = \ ((_hdIcollectedSigs) :: [ (NontermIdent, ConstructorIdent, SigInfo) ]) ((_tlIcollectedSigs) :: [ (NontermIdent, ConstructorIdent, SigInfo) ]) -> _hdIcollectedSigs ++ _tlIcollectedSigs {-# INLINE rule671 #-} rule671 = \ ((_hdIcollectedUniques) :: [ (NontermIdent, ConstructorIdent, [UniqueInfo]) ]) ((_tlIcollectedUniques) :: [ (NontermIdent, ConstructorIdent, [UniqueInfo]) ]) -> _hdIcollectedUniques ++ _tlIcollectedUniques {-# INLINE rule672 #-} rule672 = \ ((_hdIerrors) :: Seq Error) ((_tlIerrors) :: Seq Error) -> _hdIerrors Seq.>< _tlIerrors {-# INLINE rule673 #-} rule673 = \ ((_hdIsemPragmasCollect) :: PragmaMap) ((_tlIsemPragmasCollect) :: PragmaMap) -> _hdIsemPragmasCollect `pragmaMapUnion` _tlIsemPragmasCollect {-# INLINE rule674 #-} rule674 = \ ((_lhsIallAttrDecls) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIallAttrDecls {-# INLINE rule675 #-} rule675 = \ ((_lhsIallAttrs) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIallAttrs {-# INLINE rule676 #-} rule676 = \ ((_lhsIallFields) :: DataTypes) -> _lhsIallFields {-# INLINE rule677 #-} rule677 = \ ((_lhsInts) :: Set NontermIdent) -> _lhsInts {-# INLINE rule678 #-} rule678 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule679 #-} rule679 = \ ((_lhsIallAttrDecls) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIallAttrDecls {-# INLINE rule680 #-} rule680 = \ ((_lhsIallAttrs) :: Map NontermIdent (Attributes, Attributes)) -> _lhsIallAttrs {-# INLINE rule681 #-} rule681 = \ ((_lhsIallFields) :: DataTypes) -> _lhsIallFields {-# INLINE rule682 #-} rule682 = \ ((_lhsInts) :: Set NontermIdent) -> _lhsInts {-# INLINE rule683 #-} rule683 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_SemAlts_Nil #-} sem_SemAlts_Nil :: T_SemAlts sem_SemAlts_Nil = T_SemAlts (return st41) where {-# NOINLINE st41 #-} st41 = let v40 :: T_SemAlts_v40 v40 = \ (T_SemAlts_vIn40 _lhsIallAttrDecls _lhsIallAttrs _lhsIallFields _lhsInts _lhsIoptions) -> ( let _lhsOattrOrderCollect :: AttrOrderMap _lhsOattrOrderCollect = rule684 () _lhsOcollectedArounds :: [ (NontermIdent, ConstructorIdent, [AroundInfo]) ] _lhsOcollectedArounds = rule685 () _lhsOcollectedAugments :: [ (NontermIdent, ConstructorIdent, [AugmentInfo]) ] _lhsOcollectedAugments = rule686 () _lhsOcollectedInsts :: [ (NontermIdent, ConstructorIdent, [Identifier]) ] _lhsOcollectedInsts = rule687 () _lhsOcollectedMerges :: [ (NontermIdent, ConstructorIdent, [MergeInfo]) ] _lhsOcollectedMerges = rule688 () _lhsOcollectedRules :: [ (NontermIdent, ConstructorIdent, RuleInfo)] _lhsOcollectedRules = rule689 () _lhsOcollectedSigs :: [ (NontermIdent, ConstructorIdent, SigInfo) ] _lhsOcollectedSigs = rule690 () _lhsOcollectedUniques :: [ (NontermIdent, ConstructorIdent, [UniqueInfo]) ] _lhsOcollectedUniques = rule691 () _lhsOerrors :: Seq Error _lhsOerrors = rule692 () _lhsOsemPragmasCollect :: PragmaMap _lhsOsemPragmasCollect = rule693 () __result_ = T_SemAlts_vOut40 _lhsOattrOrderCollect _lhsOcollectedArounds _lhsOcollectedAugments _lhsOcollectedInsts _lhsOcollectedMerges _lhsOcollectedRules _lhsOcollectedSigs _lhsOcollectedUniques _lhsOerrors _lhsOsemPragmasCollect in __result_ ) in C_SemAlts_s41 v40 {-# INLINE rule684 #-} rule684 = \ (_ :: ()) -> Map.empty {-# INLINE rule685 #-} rule685 = \ (_ :: ()) -> [] {-# INLINE rule686 #-} rule686 = \ (_ :: ()) -> [] {-# INLINE rule687 #-} rule687 = \ (_ :: ()) -> [] {-# INLINE rule688 #-} rule688 = \ (_ :: ()) -> [] {-# INLINE rule689 #-} rule689 = \ (_ :: ()) -> [] {-# INLINE rule690 #-} rule690 = \ (_ :: ()) -> [] {-# INLINE rule691 #-} rule691 = \ (_ :: ()) -> [] {-# INLINE rule692 #-} rule692 = \ (_ :: ()) -> Seq.empty {-# INLINE rule693 #-} rule693 = \ (_ :: ()) -> Map.empty -- SemDef ------------------------------------------------------ -- wrapper data Inh_SemDef = Inh_SemDef { options_Inh_SemDef :: (Options) } data Syn_SemDef = Syn_SemDef { aroundInfos_Syn_SemDef :: ([AroundInfo]), augmentInfos_Syn_SemDef :: ([AugmentInfo]), definedInsts_Syn_SemDef :: ([Identifier]), errors_Syn_SemDef :: (Seq Error), mergeInfos_Syn_SemDef :: ([MergeInfo]), orderDepsCollect_Syn_SemDef :: (Set Dependency), pragmaNamesCollect_Syn_SemDef :: ([Identifier]), ruleInfos_Syn_SemDef :: ([RuleInfo]), sigInfos_Syn_SemDef :: ([SigInfo]), uniqueInfos_Syn_SemDef :: ([UniqueInfo]) } {-# INLINABLE wrap_SemDef #-} wrap_SemDef :: T_SemDef -> Inh_SemDef -> (Syn_SemDef ) wrap_SemDef (T_SemDef act) (Inh_SemDef _lhsIoptions) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_SemDef_vIn43 _lhsIoptions (T_SemDef_vOut43 _lhsOaroundInfos _lhsOaugmentInfos _lhsOdefinedInsts _lhsOerrors _lhsOmergeInfos _lhsOorderDepsCollect _lhsOpragmaNamesCollect _lhsOruleInfos _lhsOsigInfos _lhsOuniqueInfos) <- return (inv_SemDef_s44 sem arg) return (Syn_SemDef _lhsOaroundInfos _lhsOaugmentInfos _lhsOdefinedInsts _lhsOerrors _lhsOmergeInfos _lhsOorderDepsCollect _lhsOpragmaNamesCollect _lhsOruleInfos _lhsOsigInfos _lhsOuniqueInfos) ) -- cata {-# NOINLINE sem_SemDef #-} sem_SemDef :: SemDef -> T_SemDef sem_SemDef ( Def pos_ mbName_ pattern_ rhs_ owrt_ pure_ eager_ ) = sem_SemDef_Def pos_ mbName_ ( sem_Pattern pattern_ ) rhs_ owrt_ pure_ eager_ sem_SemDef ( TypeDef pos_ ident_ tp_ ) = sem_SemDef_TypeDef pos_ ident_ tp_ sem_SemDef ( UniqueDef ident_ ref_ ) = sem_SemDef_UniqueDef ident_ ref_ sem_SemDef ( AugmentDef ident_ rhs_ ) = sem_SemDef_AugmentDef ident_ rhs_ sem_SemDef ( AroundDef ident_ rhs_ ) = sem_SemDef_AroundDef ident_ rhs_ sem_SemDef ( MergeDef target_ nt_ sources_ rhs_ ) = sem_SemDef_MergeDef target_ nt_ sources_ rhs_ sem_SemDef ( SemPragma names_ ) = sem_SemDef_SemPragma names_ sem_SemDef ( AttrOrderBefore before_ after_ ) = sem_SemDef_AttrOrderBefore before_ after_ -- semantic domain newtype T_SemDef = T_SemDef { attach_T_SemDef :: Identity (T_SemDef_s44 ) } newtype T_SemDef_s44 = C_SemDef_s44 { inv_SemDef_s44 :: (T_SemDef_v43 ) } data T_SemDef_s45 = C_SemDef_s45 type T_SemDef_v43 = (T_SemDef_vIn43 ) -> (T_SemDef_vOut43 ) data T_SemDef_vIn43 = T_SemDef_vIn43 (Options) data T_SemDef_vOut43 = T_SemDef_vOut43 ([AroundInfo]) ([AugmentInfo]) ([Identifier]) (Seq Error) ([MergeInfo]) (Set Dependency) ([Identifier]) ([RuleInfo]) ([SigInfo]) ([UniqueInfo]) {-# NOINLINE sem_SemDef_Def #-} sem_SemDef_Def :: (Pos) -> (Maybe Identifier) -> T_Pattern -> (Expression) -> (Bool) -> (Bool) -> (Bool) -> T_SemDef sem_SemDef_Def _ arg_mbName_ arg_pattern_ arg_rhs_ arg_owrt_ arg_pure_ arg_eager_ = T_SemDef (return st44) where {-# NOINLINE st44 #-} st44 = let v43 :: T_SemDef_v43 v43 = \ (T_SemDef_vIn43 _lhsIoptions) -> ( let _patternX32 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pattern_)) (T_Pattern_vOut31 _patternIcopy _patternIdefinedAttrs _patternIdefinedInsts _patternIpatunder _patternIstpos) = inv_Pattern_s32 _patternX32 (T_Pattern_vIn31 ) _lhsOerrors :: Seq Error _lhsOerrors = rule694 _lhsIoptions arg_rhs_ _lhsOruleInfos :: [RuleInfo] _lhsOruleInfos = rule695 _patternIdefinedAttrs _patternIpatunder _patternIstpos arg_eager_ arg_mbName_ arg_owrt_ arg_pure_ arg_rhs_ _lhsOaroundInfos :: [AroundInfo] _lhsOaroundInfos = rule696 () _lhsOaugmentInfos :: [AugmentInfo] _lhsOaugmentInfos = rule697 () _lhsOdefinedInsts :: [Identifier] _lhsOdefinedInsts = rule698 _patternIdefinedInsts _lhsOmergeInfos :: [MergeInfo] _lhsOmergeInfos = rule699 () _lhsOorderDepsCollect :: Set Dependency _lhsOorderDepsCollect = rule700 () _lhsOpragmaNamesCollect :: [Identifier] _lhsOpragmaNamesCollect = rule701 () _lhsOsigInfos :: [SigInfo] _lhsOsigInfos = rule702 () _lhsOuniqueInfos :: [UniqueInfo] _lhsOuniqueInfos = rule703 () __result_ = T_SemDef_vOut43 _lhsOaroundInfos _lhsOaugmentInfos _lhsOdefinedInsts _lhsOerrors _lhsOmergeInfos _lhsOorderDepsCollect _lhsOpragmaNamesCollect _lhsOruleInfos _lhsOsigInfos _lhsOuniqueInfos in __result_ ) in C_SemDef_s44 v43 {-# INLINE rule694 #-} {-# LINE 556 "./src-ag/Transform.ag" #-} rule694 = \ ((_lhsIoptions) :: Options) rhs_ -> {-# LINE 556 "./src-ag/Transform.ag" #-} if checkParseRhs _lhsIoptions then Seq.fromList $ checkRhs rhs_ else Seq.empty {-# LINE 5529 "dist/build/Transform.hs"#-} {-# INLINE rule695 #-} {-# LINE 1161 "./src-ag/Transform.ag" #-} rule695 = \ ((_patternIdefinedAttrs) :: [AttrName]) ((_patternIpatunder) :: [AttrName]->Pattern) ((_patternIstpos) :: Pos) eager_ mbName_ owrt_ pure_ rhs_ -> {-# LINE 1161 "./src-ag/Transform.ag" #-} [ (mbName_, _patternIpatunder, rhs_, _patternIdefinedAttrs, owrt_, show _patternIstpos, pure_, eager_) ] {-# LINE 5535 "dist/build/Transform.hs"#-} {-# INLINE rule696 #-} rule696 = \ (_ :: ()) -> [] {-# INLINE rule697 #-} rule697 = \ (_ :: ()) -> [] {-# INLINE rule698 #-} rule698 = \ ((_patternIdefinedInsts) :: [Identifier]) -> _patternIdefinedInsts {-# INLINE rule699 #-} rule699 = \ (_ :: ()) -> [] {-# INLINE rule700 #-} rule700 = \ (_ :: ()) -> Set.empty {-# INLINE rule701 #-} rule701 = \ (_ :: ()) -> [] {-# INLINE rule702 #-} rule702 = \ (_ :: ()) -> [] {-# INLINE rule703 #-} rule703 = \ (_ :: ()) -> [] {-# NOINLINE sem_SemDef_TypeDef #-} sem_SemDef_TypeDef :: (Pos) -> (Identifier) -> (Type) -> T_SemDef sem_SemDef_TypeDef arg_pos_ arg_ident_ arg_tp_ = T_SemDef (return st44) where {-# NOINLINE st44 #-} st44 = let v43 :: T_SemDef_v43 v43 = \ (T_SemDef_vIn43 _lhsIoptions) -> ( let _lhsOerrors :: Seq Error _lhsOerrors = rule704 _lhsIoptions arg_pos_ arg_tp_ _lhsOsigInfos :: [SigInfo] _lhsOsigInfos = rule705 arg_ident_ arg_tp_ _lhsOaroundInfos :: [AroundInfo] _lhsOaroundInfos = rule706 () _lhsOaugmentInfos :: [AugmentInfo] _lhsOaugmentInfos = rule707 () _lhsOdefinedInsts :: [Identifier] _lhsOdefinedInsts = rule708 () _lhsOmergeInfos :: [MergeInfo] _lhsOmergeInfos = rule709 () _lhsOorderDepsCollect :: Set Dependency _lhsOorderDepsCollect = rule710 () _lhsOpragmaNamesCollect :: [Identifier] _lhsOpragmaNamesCollect = rule711 () _lhsOruleInfos :: [RuleInfo] _lhsOruleInfos = rule712 () _lhsOuniqueInfos :: [UniqueInfo] _lhsOuniqueInfos = rule713 () __result_ = T_SemDef_vOut43 _lhsOaroundInfos _lhsOaugmentInfos _lhsOdefinedInsts _lhsOerrors _lhsOmergeInfos _lhsOorderDepsCollect _lhsOpragmaNamesCollect _lhsOruleInfos _lhsOsigInfos _lhsOuniqueInfos in __result_ ) in C_SemDef_s44 v43 {-# INLINE rule704 #-} {-# LINE 563 "./src-ag/Transform.ag" #-} rule704 = \ ((_lhsIoptions) :: Options) pos_ tp_ -> {-# LINE 563 "./src-ag/Transform.ag" #-} if checkParseTy _lhsIoptions 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 {-# LINE 5602 "dist/build/Transform.hs"#-} {-# INLINE rule705 #-} {-# LINE 1164 "./src-ag/Transform.ag" #-} rule705 = \ ident_ tp_ -> {-# LINE 1164 "./src-ag/Transform.ag" #-} [ (ident_, tp_) ] {-# LINE 5608 "dist/build/Transform.hs"#-} {-# INLINE rule706 #-} rule706 = \ (_ :: ()) -> [] {-# INLINE rule707 #-} rule707 = \ (_ :: ()) -> [] {-# INLINE rule708 #-} rule708 = \ (_ :: ()) -> [] {-# INLINE rule709 #-} rule709 = \ (_ :: ()) -> [] {-# INLINE rule710 #-} rule710 = \ (_ :: ()) -> Set.empty {-# INLINE rule711 #-} rule711 = \ (_ :: ()) -> [] {-# INLINE rule712 #-} rule712 = \ (_ :: ()) -> [] {-# INLINE rule713 #-} rule713 = \ (_ :: ()) -> [] {-# NOINLINE sem_SemDef_UniqueDef #-} sem_SemDef_UniqueDef :: (Identifier) -> (Identifier) -> T_SemDef sem_SemDef_UniqueDef arg_ident_ arg_ref_ = T_SemDef (return st44) where {-# NOINLINE st44 #-} st44 = let v43 :: T_SemDef_v43 v43 = \ (T_SemDef_vIn43 _lhsIoptions) -> ( let _lhsOuniqueInfos :: [UniqueInfo] _lhsOuniqueInfos = rule714 arg_ident_ arg_ref_ _lhsOaroundInfos :: [AroundInfo] _lhsOaroundInfos = rule715 () _lhsOaugmentInfos :: [AugmentInfo] _lhsOaugmentInfos = rule716 () _lhsOdefinedInsts :: [Identifier] _lhsOdefinedInsts = rule717 () _lhsOerrors :: Seq Error _lhsOerrors = rule718 () _lhsOmergeInfos :: [MergeInfo] _lhsOmergeInfos = rule719 () _lhsOorderDepsCollect :: Set Dependency _lhsOorderDepsCollect = rule720 () _lhsOpragmaNamesCollect :: [Identifier] _lhsOpragmaNamesCollect = rule721 () _lhsOruleInfos :: [RuleInfo] _lhsOruleInfos = rule722 () _lhsOsigInfos :: [SigInfo] _lhsOsigInfos = rule723 () __result_ = T_SemDef_vOut43 _lhsOaroundInfos _lhsOaugmentInfos _lhsOdefinedInsts _lhsOerrors _lhsOmergeInfos _lhsOorderDepsCollect _lhsOpragmaNamesCollect _lhsOruleInfos _lhsOsigInfos _lhsOuniqueInfos in __result_ ) in C_SemDef_s44 v43 {-# INLINE rule714 #-} {-# LINE 1167 "./src-ag/Transform.ag" #-} rule714 = \ ident_ ref_ -> {-# LINE 1167 "./src-ag/Transform.ag" #-} [ (ident_, ref_) ] {-# LINE 5668 "dist/build/Transform.hs"#-} {-# INLINE rule715 #-} rule715 = \ (_ :: ()) -> [] {-# INLINE rule716 #-} rule716 = \ (_ :: ()) -> [] {-# INLINE rule717 #-} rule717 = \ (_ :: ()) -> [] {-# INLINE rule718 #-} rule718 = \ (_ :: ()) -> Seq.empty {-# INLINE rule719 #-} rule719 = \ (_ :: ()) -> [] {-# INLINE rule720 #-} rule720 = \ (_ :: ()) -> Set.empty {-# INLINE rule721 #-} rule721 = \ (_ :: ()) -> [] {-# INLINE rule722 #-} rule722 = \ (_ :: ()) -> [] {-# INLINE rule723 #-} rule723 = \ (_ :: ()) -> [] {-# NOINLINE sem_SemDef_AugmentDef #-} sem_SemDef_AugmentDef :: (Identifier) -> (Expression) -> T_SemDef sem_SemDef_AugmentDef arg_ident_ arg_rhs_ = T_SemDef (return st44) where {-# NOINLINE st44 #-} st44 = let v43 :: T_SemDef_v43 v43 = \ (T_SemDef_vIn43 _lhsIoptions) -> ( let _lhsOaugmentInfos :: [AugmentInfo] _lhsOaugmentInfos = rule724 arg_ident_ arg_rhs_ _lhsOaroundInfos :: [AroundInfo] _lhsOaroundInfos = rule725 () _lhsOdefinedInsts :: [Identifier] _lhsOdefinedInsts = rule726 () _lhsOerrors :: Seq Error _lhsOerrors = rule727 () _lhsOmergeInfos :: [MergeInfo] _lhsOmergeInfos = rule728 () _lhsOorderDepsCollect :: Set Dependency _lhsOorderDepsCollect = rule729 () _lhsOpragmaNamesCollect :: [Identifier] _lhsOpragmaNamesCollect = rule730 () _lhsOruleInfos :: [RuleInfo] _lhsOruleInfos = rule731 () _lhsOsigInfos :: [SigInfo] _lhsOsigInfos = rule732 () _lhsOuniqueInfos :: [UniqueInfo] _lhsOuniqueInfos = rule733 () __result_ = T_SemDef_vOut43 _lhsOaroundInfos _lhsOaugmentInfos _lhsOdefinedInsts _lhsOerrors _lhsOmergeInfos _lhsOorderDepsCollect _lhsOpragmaNamesCollect _lhsOruleInfos _lhsOsigInfos _lhsOuniqueInfos in __result_ ) in C_SemDef_s44 v43 {-# INLINE rule724 #-} {-# LINE 1170 "./src-ag/Transform.ag" #-} rule724 = \ ident_ rhs_ -> {-# LINE 1170 "./src-ag/Transform.ag" #-} [ (ident_, rhs_) ] {-# LINE 5731 "dist/build/Transform.hs"#-} {-# INLINE rule725 #-} rule725 = \ (_ :: ()) -> [] {-# INLINE rule726 #-} rule726 = \ (_ :: ()) -> [] {-# INLINE rule727 #-} rule727 = \ (_ :: ()) -> Seq.empty {-# INLINE rule728 #-} rule728 = \ (_ :: ()) -> [] {-# INLINE rule729 #-} rule729 = \ (_ :: ()) -> Set.empty {-# INLINE rule730 #-} rule730 = \ (_ :: ()) -> [] {-# INLINE rule731 #-} rule731 = \ (_ :: ()) -> [] {-# INLINE rule732 #-} rule732 = \ (_ :: ()) -> [] {-# INLINE rule733 #-} rule733 = \ (_ :: ()) -> [] {-# NOINLINE sem_SemDef_AroundDef #-} sem_SemDef_AroundDef :: (Identifier) -> (Expression) -> T_SemDef sem_SemDef_AroundDef arg_ident_ arg_rhs_ = T_SemDef (return st44) where {-# NOINLINE st44 #-} st44 = let v43 :: T_SemDef_v43 v43 = \ (T_SemDef_vIn43 _lhsIoptions) -> ( let _lhsOaroundInfos :: [AroundInfo] _lhsOaroundInfos = rule734 arg_ident_ arg_rhs_ _lhsOaugmentInfos :: [AugmentInfo] _lhsOaugmentInfos = rule735 () _lhsOdefinedInsts :: [Identifier] _lhsOdefinedInsts = rule736 () _lhsOerrors :: Seq Error _lhsOerrors = rule737 () _lhsOmergeInfos :: [MergeInfo] _lhsOmergeInfos = rule738 () _lhsOorderDepsCollect :: Set Dependency _lhsOorderDepsCollect = rule739 () _lhsOpragmaNamesCollect :: [Identifier] _lhsOpragmaNamesCollect = rule740 () _lhsOruleInfos :: [RuleInfo] _lhsOruleInfos = rule741 () _lhsOsigInfos :: [SigInfo] _lhsOsigInfos = rule742 () _lhsOuniqueInfos :: [UniqueInfo] _lhsOuniqueInfos = rule743 () __result_ = T_SemDef_vOut43 _lhsOaroundInfos _lhsOaugmentInfos _lhsOdefinedInsts _lhsOerrors _lhsOmergeInfos _lhsOorderDepsCollect _lhsOpragmaNamesCollect _lhsOruleInfos _lhsOsigInfos _lhsOuniqueInfos in __result_ ) in C_SemDef_s44 v43 {-# INLINE rule734 #-} {-# LINE 1173 "./src-ag/Transform.ag" #-} rule734 = \ ident_ rhs_ -> {-# LINE 1173 "./src-ag/Transform.ag" #-} [ (ident_, rhs_) ] {-# LINE 5794 "dist/build/Transform.hs"#-} {-# INLINE rule735 #-} rule735 = \ (_ :: ()) -> [] {-# INLINE rule736 #-} rule736 = \ (_ :: ()) -> [] {-# INLINE rule737 #-} rule737 = \ (_ :: ()) -> Seq.empty {-# INLINE rule738 #-} rule738 = \ (_ :: ()) -> [] {-# INLINE rule739 #-} rule739 = \ (_ :: ()) -> Set.empty {-# INLINE rule740 #-} rule740 = \ (_ :: ()) -> [] {-# INLINE rule741 #-} rule741 = \ (_ :: ()) -> [] {-# INLINE rule742 #-} rule742 = \ (_ :: ()) -> [] {-# INLINE rule743 #-} rule743 = \ (_ :: ()) -> [] {-# NOINLINE sem_SemDef_MergeDef #-} sem_SemDef_MergeDef :: (Identifier) -> (Identifier) -> ([Identifier]) -> (Expression) -> T_SemDef sem_SemDef_MergeDef arg_target_ arg_nt_ arg_sources_ arg_rhs_ = T_SemDef (return st44) where {-# NOINLINE st44 #-} st44 = let v43 :: T_SemDef_v43 v43 = \ (T_SemDef_vIn43 _lhsIoptions) -> ( let _lhsOerrors :: Seq Error _lhsOerrors = rule744 _lhsIoptions arg_rhs_ _lhsOmergeInfos :: [MergeInfo] _lhsOmergeInfos = rule745 arg_nt_ arg_rhs_ arg_sources_ arg_target_ _lhsOaroundInfos :: [AroundInfo] _lhsOaroundInfos = rule746 () _lhsOaugmentInfos :: [AugmentInfo] _lhsOaugmentInfos = rule747 () _lhsOdefinedInsts :: [Identifier] _lhsOdefinedInsts = rule748 () _lhsOorderDepsCollect :: Set Dependency _lhsOorderDepsCollect = rule749 () _lhsOpragmaNamesCollect :: [Identifier] _lhsOpragmaNamesCollect = rule750 () _lhsOruleInfos :: [RuleInfo] _lhsOruleInfos = rule751 () _lhsOsigInfos :: [SigInfo] _lhsOsigInfos = rule752 () _lhsOuniqueInfos :: [UniqueInfo] _lhsOuniqueInfos = rule753 () __result_ = T_SemDef_vOut43 _lhsOaroundInfos _lhsOaugmentInfos _lhsOdefinedInsts _lhsOerrors _lhsOmergeInfos _lhsOorderDepsCollect _lhsOpragmaNamesCollect _lhsOruleInfos _lhsOsigInfos _lhsOuniqueInfos in __result_ ) in C_SemDef_s44 v43 {-# INLINE rule744 #-} {-# LINE 556 "./src-ag/Transform.ag" #-} rule744 = \ ((_lhsIoptions) :: Options) rhs_ -> {-# LINE 556 "./src-ag/Transform.ag" #-} if checkParseRhs _lhsIoptions then Seq.fromList $ checkRhs rhs_ else Seq.empty {-# LINE 5859 "dist/build/Transform.hs"#-} {-# INLINE rule745 #-} {-# LINE 1176 "./src-ag/Transform.ag" #-} rule745 = \ nt_ rhs_ sources_ target_ -> {-# LINE 1176 "./src-ag/Transform.ag" #-} [ (target_, nt_, sources_, rhs_) ] {-# LINE 5865 "dist/build/Transform.hs"#-} {-# INLINE rule746 #-} rule746 = \ (_ :: ()) -> [] {-# INLINE rule747 #-} rule747 = \ (_ :: ()) -> [] {-# INLINE rule748 #-} rule748 = \ (_ :: ()) -> [] {-# INLINE rule749 #-} rule749 = \ (_ :: ()) -> Set.empty {-# INLINE rule750 #-} rule750 = \ (_ :: ()) -> [] {-# INLINE rule751 #-} rule751 = \ (_ :: ()) -> [] {-# INLINE rule752 #-} rule752 = \ (_ :: ()) -> [] {-# INLINE rule753 #-} rule753 = \ (_ :: ()) -> [] {-# NOINLINE sem_SemDef_SemPragma #-} sem_SemDef_SemPragma :: ([NontermIdent]) -> T_SemDef sem_SemDef_SemPragma arg_names_ = T_SemDef (return st44) where {-# NOINLINE st44 #-} st44 = let v43 :: T_SemDef_v43 v43 = \ (T_SemDef_vIn43 _lhsIoptions) -> ( let _lhsOpragmaNamesCollect :: [Identifier] _lhsOpragmaNamesCollect = rule754 arg_names_ _lhsOaroundInfos :: [AroundInfo] _lhsOaroundInfos = rule755 () _lhsOaugmentInfos :: [AugmentInfo] _lhsOaugmentInfos = rule756 () _lhsOdefinedInsts :: [Identifier] _lhsOdefinedInsts = rule757 () _lhsOerrors :: Seq Error _lhsOerrors = rule758 () _lhsOmergeInfos :: [MergeInfo] _lhsOmergeInfos = rule759 () _lhsOorderDepsCollect :: Set Dependency _lhsOorderDepsCollect = rule760 () _lhsOruleInfos :: [RuleInfo] _lhsOruleInfos = rule761 () _lhsOsigInfos :: [SigInfo] _lhsOsigInfos = rule762 () _lhsOuniqueInfos :: [UniqueInfo] _lhsOuniqueInfos = rule763 () __result_ = T_SemDef_vOut43 _lhsOaroundInfos _lhsOaugmentInfos _lhsOdefinedInsts _lhsOerrors _lhsOmergeInfos _lhsOorderDepsCollect _lhsOpragmaNamesCollect _lhsOruleInfos _lhsOsigInfos _lhsOuniqueInfos in __result_ ) in C_SemDef_s44 v43 {-# INLINE rule754 #-} {-# LINE 897 "./src-ag/Transform.ag" #-} rule754 = \ names_ -> {-# LINE 897 "./src-ag/Transform.ag" #-} names_ {-# LINE 5925 "dist/build/Transform.hs"#-} {-# INLINE rule755 #-} rule755 = \ (_ :: ()) -> [] {-# INLINE rule756 #-} rule756 = \ (_ :: ()) -> [] {-# INLINE rule757 #-} rule757 = \ (_ :: ()) -> [] {-# INLINE rule758 #-} rule758 = \ (_ :: ()) -> Seq.empty {-# INLINE rule759 #-} rule759 = \ (_ :: ()) -> [] {-# INLINE rule760 #-} rule760 = \ (_ :: ()) -> Set.empty {-# INLINE rule761 #-} rule761 = \ (_ :: ()) -> [] {-# INLINE rule762 #-} rule762 = \ (_ :: ()) -> [] {-# INLINE rule763 #-} rule763 = \ (_ :: ()) -> [] {-# NOINLINE sem_SemDef_AttrOrderBefore #-} sem_SemDef_AttrOrderBefore :: ([Occurrence]) -> ([Occurrence]) -> T_SemDef sem_SemDef_AttrOrderBefore arg_before_ arg_after_ = T_SemDef (return st44) where {-# NOINLINE st44 #-} st44 = let v43 :: T_SemDef_v43 v43 = \ (T_SemDef_vIn43 _lhsIoptions) -> ( let _dependency = rule764 arg_after_ arg_before_ _lhsOorderDepsCollect :: Set Dependency _lhsOorderDepsCollect = rule765 _dependency _lhsOaroundInfos :: [AroundInfo] _lhsOaroundInfos = rule766 () _lhsOaugmentInfos :: [AugmentInfo] _lhsOaugmentInfos = rule767 () _lhsOdefinedInsts :: [Identifier] _lhsOdefinedInsts = rule768 () _lhsOerrors :: Seq Error _lhsOerrors = rule769 () _lhsOmergeInfos :: [MergeInfo] _lhsOmergeInfos = rule770 () _lhsOpragmaNamesCollect :: [Identifier] _lhsOpragmaNamesCollect = rule771 () _lhsOruleInfos :: [RuleInfo] _lhsOruleInfos = rule772 () _lhsOsigInfos :: [SigInfo] _lhsOsigInfos = rule773 () _lhsOuniqueInfos :: [UniqueInfo] _lhsOuniqueInfos = rule774 () __result_ = T_SemDef_vOut43 _lhsOaroundInfos _lhsOaugmentInfos _lhsOdefinedInsts _lhsOerrors _lhsOmergeInfos _lhsOorderDepsCollect _lhsOpragmaNamesCollect _lhsOruleInfos _lhsOsigInfos _lhsOuniqueInfos in __result_ ) in C_SemDef_s44 v43 {-# INLINE rule764 #-} {-# LINE 928 "./src-ag/Transform.ag" #-} rule764 = \ after_ before_ -> {-# LINE 928 "./src-ag/Transform.ag" #-} [ Dependency b a | b <- before_, a <- after_ ] {-# LINE 5989 "dist/build/Transform.hs"#-} {-# INLINE rule765 #-} {-# LINE 929 "./src-ag/Transform.ag" #-} rule765 = \ _dependency -> {-# LINE 929 "./src-ag/Transform.ag" #-} Set.fromList _dependency {-# LINE 5995 "dist/build/Transform.hs"#-} {-# INLINE rule766 #-} rule766 = \ (_ :: ()) -> [] {-# INLINE rule767 #-} rule767 = \ (_ :: ()) -> [] {-# INLINE rule768 #-} rule768 = \ (_ :: ()) -> [] {-# INLINE rule769 #-} rule769 = \ (_ :: ()) -> Seq.empty {-# INLINE rule770 #-} rule770 = \ (_ :: ()) -> [] {-# INLINE rule771 #-} rule771 = \ (_ :: ()) -> [] {-# INLINE rule772 #-} rule772 = \ (_ :: ()) -> [] {-# INLINE rule773 #-} rule773 = \ (_ :: ()) -> [] {-# INLINE rule774 #-} rule774 = \ (_ :: ()) -> [] -- SemDefs ----------------------------------------------------- -- wrapper data Inh_SemDefs = Inh_SemDefs { options_Inh_SemDefs :: (Options) } data Syn_SemDefs = Syn_SemDefs { aroundInfos_Syn_SemDefs :: ([AroundInfo]), augmentInfos_Syn_SemDefs :: ([AugmentInfo]), definedInsts_Syn_SemDefs :: ([Identifier]), errors_Syn_SemDefs :: (Seq Error), mergeInfos_Syn_SemDefs :: ([MergeInfo]), orderDepsCollect_Syn_SemDefs :: (Set Dependency), pragmaNamesCollect_Syn_SemDefs :: ([Identifier]), ruleInfos_Syn_SemDefs :: ([RuleInfo]), sigInfos_Syn_SemDefs :: ([SigInfo]), uniqueInfos_Syn_SemDefs :: ([UniqueInfo]) } {-# INLINABLE wrap_SemDefs #-} wrap_SemDefs :: T_SemDefs -> Inh_SemDefs -> (Syn_SemDefs ) wrap_SemDefs (T_SemDefs act) (Inh_SemDefs _lhsIoptions) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_SemDefs_vIn46 _lhsIoptions (T_SemDefs_vOut46 _lhsOaroundInfos _lhsOaugmentInfos _lhsOdefinedInsts _lhsOerrors _lhsOmergeInfos _lhsOorderDepsCollect _lhsOpragmaNamesCollect _lhsOruleInfos _lhsOsigInfos _lhsOuniqueInfos) <- return (inv_SemDefs_s47 sem arg) return (Syn_SemDefs _lhsOaroundInfos _lhsOaugmentInfos _lhsOdefinedInsts _lhsOerrors _lhsOmergeInfos _lhsOorderDepsCollect _lhsOpragmaNamesCollect _lhsOruleInfos _lhsOsigInfos _lhsOuniqueInfos) ) -- cata {-# NOINLINE sem_SemDefs #-} sem_SemDefs :: SemDefs -> T_SemDefs sem_SemDefs list = Prelude.foldr sem_SemDefs_Cons sem_SemDefs_Nil (Prelude.map sem_SemDef list) -- semantic domain newtype T_SemDefs = T_SemDefs { attach_T_SemDefs :: Identity (T_SemDefs_s47 ) } newtype T_SemDefs_s47 = C_SemDefs_s47 { inv_SemDefs_s47 :: (T_SemDefs_v46 ) } data T_SemDefs_s48 = C_SemDefs_s48 type T_SemDefs_v46 = (T_SemDefs_vIn46 ) -> (T_SemDefs_vOut46 ) data T_SemDefs_vIn46 = T_SemDefs_vIn46 (Options) data T_SemDefs_vOut46 = T_SemDefs_vOut46 ([AroundInfo]) ([AugmentInfo]) ([Identifier]) (Seq Error) ([MergeInfo]) (Set Dependency) ([Identifier]) ([RuleInfo]) ([SigInfo]) ([UniqueInfo]) {-# NOINLINE sem_SemDefs_Cons #-} sem_SemDefs_Cons :: T_SemDef -> T_SemDefs -> T_SemDefs sem_SemDefs_Cons arg_hd_ arg_tl_ = T_SemDefs (return st47) where {-# NOINLINE st47 #-} st47 = let v46 :: T_SemDefs_v46 v46 = \ (T_SemDefs_vIn46 _lhsIoptions) -> ( let _hdX44 = Control.Monad.Identity.runIdentity (attach_T_SemDef (arg_hd_)) _tlX47 = Control.Monad.Identity.runIdentity (attach_T_SemDefs (arg_tl_)) (T_SemDef_vOut43 _hdIaroundInfos _hdIaugmentInfos _hdIdefinedInsts _hdIerrors _hdImergeInfos _hdIorderDepsCollect _hdIpragmaNamesCollect _hdIruleInfos _hdIsigInfos _hdIuniqueInfos) = inv_SemDef_s44 _hdX44 (T_SemDef_vIn43 _hdOoptions) (T_SemDefs_vOut46 _tlIaroundInfos _tlIaugmentInfos _tlIdefinedInsts _tlIerrors _tlImergeInfos _tlIorderDepsCollect _tlIpragmaNamesCollect _tlIruleInfos _tlIsigInfos _tlIuniqueInfos) = inv_SemDefs_s47 _tlX47 (T_SemDefs_vIn46 _tlOoptions) _lhsOaroundInfos :: [AroundInfo] _lhsOaroundInfos = rule775 _hdIaroundInfos _tlIaroundInfos _lhsOaugmentInfos :: [AugmentInfo] _lhsOaugmentInfos = rule776 _hdIaugmentInfos _tlIaugmentInfos _lhsOdefinedInsts :: [Identifier] _lhsOdefinedInsts = rule777 _hdIdefinedInsts _tlIdefinedInsts _lhsOerrors :: Seq Error _lhsOerrors = rule778 _hdIerrors _tlIerrors _lhsOmergeInfos :: [MergeInfo] _lhsOmergeInfos = rule779 _hdImergeInfos _tlImergeInfos _lhsOorderDepsCollect :: Set Dependency _lhsOorderDepsCollect = rule780 _hdIorderDepsCollect _tlIorderDepsCollect _lhsOpragmaNamesCollect :: [Identifier] _lhsOpragmaNamesCollect = rule781 _hdIpragmaNamesCollect _tlIpragmaNamesCollect _lhsOruleInfos :: [RuleInfo] _lhsOruleInfos = rule782 _hdIruleInfos _tlIruleInfos _lhsOsigInfos :: [SigInfo] _lhsOsigInfos = rule783 _hdIsigInfos _tlIsigInfos _lhsOuniqueInfos :: [UniqueInfo] _lhsOuniqueInfos = rule784 _hdIuniqueInfos _tlIuniqueInfos _hdOoptions = rule785 _lhsIoptions _tlOoptions = rule786 _lhsIoptions __result_ = T_SemDefs_vOut46 _lhsOaroundInfos _lhsOaugmentInfos _lhsOdefinedInsts _lhsOerrors _lhsOmergeInfos _lhsOorderDepsCollect _lhsOpragmaNamesCollect _lhsOruleInfos _lhsOsigInfos _lhsOuniqueInfos in __result_ ) in C_SemDefs_s47 v46 {-# INLINE rule775 #-} rule775 = \ ((_hdIaroundInfos) :: [AroundInfo]) ((_tlIaroundInfos) :: [AroundInfo]) -> _hdIaroundInfos ++ _tlIaroundInfos {-# INLINE rule776 #-} rule776 = \ ((_hdIaugmentInfos) :: [AugmentInfo]) ((_tlIaugmentInfos) :: [AugmentInfo]) -> _hdIaugmentInfos ++ _tlIaugmentInfos {-# INLINE rule777 #-} rule777 = \ ((_hdIdefinedInsts) :: [Identifier]) ((_tlIdefinedInsts) :: [Identifier]) -> _hdIdefinedInsts ++ _tlIdefinedInsts {-# INLINE rule778 #-} rule778 = \ ((_hdIerrors) :: Seq Error) ((_tlIerrors) :: Seq Error) -> _hdIerrors Seq.>< _tlIerrors {-# INLINE rule779 #-} rule779 = \ ((_hdImergeInfos) :: [MergeInfo]) ((_tlImergeInfos) :: [MergeInfo]) -> _hdImergeInfos ++ _tlImergeInfos {-# INLINE rule780 #-} rule780 = \ ((_hdIorderDepsCollect) :: Set Dependency) ((_tlIorderDepsCollect) :: Set Dependency) -> _hdIorderDepsCollect `Set.union` _tlIorderDepsCollect {-# INLINE rule781 #-} rule781 = \ ((_hdIpragmaNamesCollect) :: [Identifier]) ((_tlIpragmaNamesCollect) :: [Identifier]) -> _hdIpragmaNamesCollect ++ _tlIpragmaNamesCollect {-# INLINE rule782 #-} rule782 = \ ((_hdIruleInfos) :: [RuleInfo]) ((_tlIruleInfos) :: [RuleInfo]) -> _hdIruleInfos ++ _tlIruleInfos {-# INLINE rule783 #-} rule783 = \ ((_hdIsigInfos) :: [SigInfo]) ((_tlIsigInfos) :: [SigInfo]) -> _hdIsigInfos ++ _tlIsigInfos {-# INLINE rule784 #-} rule784 = \ ((_hdIuniqueInfos) :: [UniqueInfo]) ((_tlIuniqueInfos) :: [UniqueInfo]) -> _hdIuniqueInfos ++ _tlIuniqueInfos {-# INLINE rule785 #-} rule785 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# INLINE rule786 #-} rule786 = \ ((_lhsIoptions) :: Options) -> _lhsIoptions {-# NOINLINE sem_SemDefs_Nil #-} sem_SemDefs_Nil :: T_SemDefs sem_SemDefs_Nil = T_SemDefs (return st47) where {-# NOINLINE st47 #-} st47 = let v46 :: T_SemDefs_v46 v46 = \ (T_SemDefs_vIn46 _lhsIoptions) -> ( let _lhsOaroundInfos :: [AroundInfo] _lhsOaroundInfos = rule787 () _lhsOaugmentInfos :: [AugmentInfo] _lhsOaugmentInfos = rule788 () _lhsOdefinedInsts :: [Identifier] _lhsOdefinedInsts = rule789 () _lhsOerrors :: Seq Error _lhsOerrors = rule790 () _lhsOmergeInfos :: [MergeInfo] _lhsOmergeInfos = rule791 () _lhsOorderDepsCollect :: Set Dependency _lhsOorderDepsCollect = rule792 () _lhsOpragmaNamesCollect :: [Identifier] _lhsOpragmaNamesCollect = rule793 () _lhsOruleInfos :: [RuleInfo] _lhsOruleInfos = rule794 () _lhsOsigInfos :: [SigInfo] _lhsOsigInfos = rule795 () _lhsOuniqueInfos :: [UniqueInfo] _lhsOuniqueInfos = rule796 () __result_ = T_SemDefs_vOut46 _lhsOaroundInfos _lhsOaugmentInfos _lhsOdefinedInsts _lhsOerrors _lhsOmergeInfos _lhsOorderDepsCollect _lhsOpragmaNamesCollect _lhsOruleInfos _lhsOsigInfos _lhsOuniqueInfos in __result_ ) in C_SemDefs_s47 v46 {-# INLINE rule787 #-} rule787 = \ (_ :: ()) -> [] {-# INLINE rule788 #-} rule788 = \ (_ :: ()) -> [] {-# INLINE rule789 #-} rule789 = \ (_ :: ()) -> [] {-# INLINE rule790 #-} rule790 = \ (_ :: ()) -> Seq.empty {-# INLINE rule791 #-} rule791 = \ (_ :: ()) -> [] {-# INLINE rule792 #-} rule792 = \ (_ :: ()) -> Set.empty {-# INLINE rule793 #-} rule793 = \ (_ :: ()) -> [] {-# INLINE rule794 #-} rule794 = \ (_ :: ()) -> [] {-# INLINE rule795 #-} rule795 = \ (_ :: ()) -> [] {-# INLINE rule796 #-} rule796 = \ (_ :: ()) -> [] uuagc-0.9.42.3/src-generated/Visage.hs000644 000765 000024 00000130446 12127045231 021353 0ustar00jeroenbransenstaff000000 000000 {-# LANGUAGE Rank2Types, GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} module Visage where {-# LINE 2 "./src-ag/VisageSyntax.ag" #-} import CommonTypes import UU.Pretty import AbstractSyntax import VisagePatterns import Expression {-# LINE 13 "dist/build/Visage.hs" #-} {-# LINE 2 "./src-ag/VisagePatterns.ag" #-} import UU.Scanner.Position(Pos) import CommonTypes {-# LINE 19 "dist/build/Visage.hs" #-} {-# LINE 2 "./src-ag/Expression.ag" #-} import UU.Scanner.Position(Pos) import HsToken {-# LINE 25 "dist/build/Visage.hs" #-} {-# LINE 6 "./src-ag/Visage.ag" #-} 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 {-# LINE 39 "dist/build/Visage.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 19 "./src-ag/Visage.ag" #-} 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 {-# LINE 67 "dist/build/Visage.hs" #-} -- Expression -------------------------------------------------- -- wrapper data Inh_Expression = Inh_Expression { } data Syn_Expression = Syn_Expression { aterm_Syn_Expression :: (ATerm) } {-# INLINABLE wrap_Expression #-} wrap_Expression :: T_Expression -> Inh_Expression -> (Syn_Expression ) wrap_Expression (T_Expression act) (Inh_Expression ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_Expression_vIn1 (T_Expression_vOut1 _lhsOaterm) <- return (inv_Expression_s2 sem arg) return (Syn_Expression _lhsOaterm) ) -- cata {-# INLINE sem_Expression #-} sem_Expression :: Expression -> T_Expression sem_Expression ( Expression pos_ tks_ ) = sem_Expression_Expression pos_ tks_ -- semantic domain newtype T_Expression = T_Expression { attach_T_Expression :: Identity (T_Expression_s2 ) } newtype T_Expression_s2 = C_Expression_s2 { inv_Expression_s2 :: (T_Expression_v1 ) } data T_Expression_s3 = C_Expression_s3 type T_Expression_v1 = (T_Expression_vIn1 ) -> (T_Expression_vOut1 ) data T_Expression_vIn1 = T_Expression_vIn1 data T_Expression_vOut1 = T_Expression_vOut1 (ATerm) {-# NOINLINE sem_Expression_Expression #-} sem_Expression_Expression :: (Pos) -> ([HsToken]) -> T_Expression sem_Expression_Expression arg_pos_ arg_tks_ = T_Expression (return st2) where {-# NOINLINE st2 #-} st2 = let v1 :: T_Expression_v1 v1 = \ (T_Expression_vIn1 ) -> ( let _lhsOaterm :: ATerm _lhsOaterm = rule0 arg_pos_ arg_tks_ __result_ = T_Expression_vOut1 _lhsOaterm in __result_ ) in C_Expression_s2 v1 {-# INLINE rule0 #-} {-# LINE 103 "./src-ag/Visage.ag" #-} rule0 = \ pos_ tks_ -> {-# LINE 103 "./src-ag/Visage.ag" #-} AAppl "Expression" [AString (sQ (showAGPos pos_)), AString (sQ (unlines . showTokens . tokensToStrings $ tks_))] {-# LINE 115 "dist/build/Visage.hs"#-} -- VisageChild ------------------------------------------------- -- wrapper data Inh_VisageChild = Inh_VisageChild { } data Syn_VisageChild = Syn_VisageChild { aterm_Syn_VisageChild :: (ATerm) } {-# INLINABLE wrap_VisageChild #-} wrap_VisageChild :: T_VisageChild -> Inh_VisageChild -> (Syn_VisageChild ) wrap_VisageChild (T_VisageChild act) (Inh_VisageChild ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_VisageChild_vIn4 (T_VisageChild_vOut4 _lhsOaterm) <- return (inv_VisageChild_s5 sem arg) return (Syn_VisageChild _lhsOaterm) ) -- cata {-# INLINE sem_VisageChild #-} sem_VisageChild :: VisageChild -> T_VisageChild sem_VisageChild ( VChild name_ tp_ inh_ syn_ rules_ ) = sem_VisageChild_VChild name_ tp_ inh_ syn_ ( sem_VisageRules rules_ ) -- semantic domain newtype T_VisageChild = T_VisageChild { attach_T_VisageChild :: Identity (T_VisageChild_s5 ) } newtype T_VisageChild_s5 = C_VisageChild_s5 { inv_VisageChild_s5 :: (T_VisageChild_v4 ) } data T_VisageChild_s6 = C_VisageChild_s6 type T_VisageChild_v4 = (T_VisageChild_vIn4 ) -> (T_VisageChild_vOut4 ) data T_VisageChild_vIn4 = T_VisageChild_vIn4 data T_VisageChild_vOut4 = T_VisageChild_vOut4 (ATerm) {-# NOINLINE sem_VisageChild_VChild #-} sem_VisageChild_VChild :: (Identifier) -> (Type) -> (Attributes) -> (Attributes) -> T_VisageRules -> T_VisageChild sem_VisageChild_VChild arg_name_ arg_tp_ arg_inh_ arg_syn_ arg_rules_ = T_VisageChild (return st5) where {-# NOINLINE st5 #-} st5 = let v4 :: T_VisageChild_v4 v4 = \ (T_VisageChild_vIn4 ) -> ( let _rulesX35 = Control.Monad.Identity.runIdentity (attach_T_VisageRules (arg_rules_)) (T_VisageRules_vOut34 _rulesIaterms) = inv_VisageRules_s35 _rulesX35 (T_VisageRules_vIn34 _rulesOisLoc) _lhsOaterm :: ATerm _lhsOaterm = rule1 _rulesIaterms arg_inh_ arg_name_ arg_syn_ arg_tp_ _rulesOisLoc = rule2 () __result_ = T_VisageChild_vOut4 _lhsOaterm in __result_ ) in C_VisageChild_s5 v4 {-# INLINE rule1 #-} {-# LINE 85 "./src-ag/Visage.ag" #-} rule1 = \ ((_rulesIaterms) :: [ATerm]) inh_ name_ syn_ tp_ -> {-# LINE 85 "./src-ag/Visage.ag" #-} AAppl "Child" [AString (sQ (getName name_)), AString (sQ (show tp_)), AString (sQ (showMap inh_)), AString (sQ (showMap syn_)), AAppl "Rules" _rulesIaterms] {-# LINE 170 "dist/build/Visage.hs"#-} {-# INLINE rule2 #-} {-# LINE 89 "./src-ag/Visage.ag" #-} rule2 = \ (_ :: ()) -> {-# LINE 89 "./src-ag/Visage.ag" #-} False {-# LINE 176 "dist/build/Visage.hs"#-} -- VisageChildren ---------------------------------------------- -- wrapper data Inh_VisageChildren = Inh_VisageChildren { } data Syn_VisageChildren = Syn_VisageChildren { aterms_Syn_VisageChildren :: ([ATerm]) } {-# INLINABLE wrap_VisageChildren #-} wrap_VisageChildren :: T_VisageChildren -> Inh_VisageChildren -> (Syn_VisageChildren ) wrap_VisageChildren (T_VisageChildren act) (Inh_VisageChildren ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_VisageChildren_vIn7 (T_VisageChildren_vOut7 _lhsOaterms) <- return (inv_VisageChildren_s8 sem arg) return (Syn_VisageChildren _lhsOaterms) ) -- cata {-# NOINLINE sem_VisageChildren #-} sem_VisageChildren :: VisageChildren -> T_VisageChildren sem_VisageChildren list = Prelude.foldr sem_VisageChildren_Cons sem_VisageChildren_Nil (Prelude.map sem_VisageChild list) -- semantic domain newtype T_VisageChildren = T_VisageChildren { attach_T_VisageChildren :: Identity (T_VisageChildren_s8 ) } newtype T_VisageChildren_s8 = C_VisageChildren_s8 { inv_VisageChildren_s8 :: (T_VisageChildren_v7 ) } data T_VisageChildren_s9 = C_VisageChildren_s9 type T_VisageChildren_v7 = (T_VisageChildren_vIn7 ) -> (T_VisageChildren_vOut7 ) data T_VisageChildren_vIn7 = T_VisageChildren_vIn7 data T_VisageChildren_vOut7 = T_VisageChildren_vOut7 ([ATerm]) {-# NOINLINE sem_VisageChildren_Cons #-} sem_VisageChildren_Cons :: T_VisageChild -> T_VisageChildren -> T_VisageChildren sem_VisageChildren_Cons arg_hd_ arg_tl_ = T_VisageChildren (return st8) where {-# NOINLINE st8 #-} st8 = let v7 :: T_VisageChildren_v7 v7 = \ (T_VisageChildren_vIn7 ) -> ( let _hdX5 = Control.Monad.Identity.runIdentity (attach_T_VisageChild (arg_hd_)) _tlX8 = Control.Monad.Identity.runIdentity (attach_T_VisageChildren (arg_tl_)) (T_VisageChild_vOut4 _hdIaterm) = inv_VisageChild_s5 _hdX5 (T_VisageChild_vIn4 ) (T_VisageChildren_vOut7 _tlIaterms) = inv_VisageChildren_s8 _tlX8 (T_VisageChildren_vIn7 ) _lhsOaterms :: [ATerm] _lhsOaterms = rule3 _hdIaterm _tlIaterms __result_ = T_VisageChildren_vOut7 _lhsOaterms in __result_ ) in C_VisageChildren_s8 v7 {-# INLINE rule3 #-} {-# LINE 80 "./src-ag/Visage.ag" #-} rule3 = \ ((_hdIaterm) :: ATerm) ((_tlIaterms) :: [ATerm]) -> {-# LINE 80 "./src-ag/Visage.ag" #-} _hdIaterm : _tlIaterms {-# LINE 229 "dist/build/Visage.hs"#-} {-# NOINLINE sem_VisageChildren_Nil #-} sem_VisageChildren_Nil :: T_VisageChildren sem_VisageChildren_Nil = T_VisageChildren (return st8) where {-# NOINLINE st8 #-} st8 = let v7 :: T_VisageChildren_v7 v7 = \ (T_VisageChildren_vIn7 ) -> ( let _lhsOaterms :: [ATerm] _lhsOaterms = rule4 () __result_ = T_VisageChildren_vOut7 _lhsOaterms in __result_ ) in C_VisageChildren_s8 v7 {-# INLINE rule4 #-} {-# LINE 81 "./src-ag/Visage.ag" #-} rule4 = \ (_ :: ()) -> {-# LINE 81 "./src-ag/Visage.ag" #-} [] {-# LINE 247 "dist/build/Visage.hs"#-} -- VisageGrammar ----------------------------------------------- -- wrapper data Inh_VisageGrammar = Inh_VisageGrammar { } data Syn_VisageGrammar = Syn_VisageGrammar { aterm_Syn_VisageGrammar :: (ATerm) } {-# INLINABLE wrap_VisageGrammar #-} wrap_VisageGrammar :: T_VisageGrammar -> Inh_VisageGrammar -> (Syn_VisageGrammar ) wrap_VisageGrammar (T_VisageGrammar act) (Inh_VisageGrammar ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_VisageGrammar_vIn10 (T_VisageGrammar_vOut10 _lhsOaterm) <- return (inv_VisageGrammar_s11 sem arg) return (Syn_VisageGrammar _lhsOaterm) ) -- cata {-# INLINE sem_VisageGrammar #-} sem_VisageGrammar :: VisageGrammar -> T_VisageGrammar sem_VisageGrammar ( VGrammar nonts_ ) = sem_VisageGrammar_VGrammar ( sem_VisageNonterminals nonts_ ) -- semantic domain newtype T_VisageGrammar = T_VisageGrammar { attach_T_VisageGrammar :: Identity (T_VisageGrammar_s11 ) } newtype T_VisageGrammar_s11 = C_VisageGrammar_s11 { inv_VisageGrammar_s11 :: (T_VisageGrammar_v10 ) } data T_VisageGrammar_s12 = C_VisageGrammar_s12 type T_VisageGrammar_v10 = (T_VisageGrammar_vIn10 ) -> (T_VisageGrammar_vOut10 ) data T_VisageGrammar_vIn10 = T_VisageGrammar_vIn10 data T_VisageGrammar_vOut10 = T_VisageGrammar_vOut10 (ATerm) {-# NOINLINE sem_VisageGrammar_VGrammar #-} sem_VisageGrammar_VGrammar :: T_VisageNonterminals -> T_VisageGrammar sem_VisageGrammar_VGrammar arg_nonts_ = T_VisageGrammar (return st11) where {-# NOINLINE st11 #-} st11 = let v10 :: T_VisageGrammar_v10 v10 = \ (T_VisageGrammar_vIn10 ) -> ( let _nontsX17 = Control.Monad.Identity.runIdentity (attach_T_VisageNonterminals (arg_nonts_)) (T_VisageNonterminals_vOut16 _nontsIaterms) = inv_VisageNonterminals_s17 _nontsX17 (T_VisageNonterminals_vIn16 ) _lhsOaterm :: ATerm _lhsOaterm = rule5 _nontsIaterms __result_ = T_VisageGrammar_vOut10 _lhsOaterm in __result_ ) in C_VisageGrammar_s11 v10 {-# INLINE rule5 #-} {-# LINE 54 "./src-ag/Visage.ag" #-} rule5 = \ ((_nontsIaterms) :: [ATerm]) -> {-# LINE 54 "./src-ag/Visage.ag" #-} AAppl "Productions" _nontsIaterms {-# LINE 298 "dist/build/Visage.hs"#-} -- VisageNonterminal ------------------------------------------- -- wrapper data Inh_VisageNonterminal = Inh_VisageNonterminal { } data Syn_VisageNonterminal = Syn_VisageNonterminal { aterm_Syn_VisageNonterminal :: (ATerm) } {-# INLINABLE wrap_VisageNonterminal #-} wrap_VisageNonterminal :: T_VisageNonterminal -> Inh_VisageNonterminal -> (Syn_VisageNonterminal ) wrap_VisageNonterminal (T_VisageNonterminal act) (Inh_VisageNonterminal ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_VisageNonterminal_vIn13 (T_VisageNonterminal_vOut13 _lhsOaterm) <- return (inv_VisageNonterminal_s14 sem arg) return (Syn_VisageNonterminal _lhsOaterm) ) -- cata {-# INLINE sem_VisageNonterminal #-} sem_VisageNonterminal :: VisageNonterminal -> T_VisageNonterminal sem_VisageNonterminal ( VNonterminal nt_ inh_ syn_ alts_ ) = sem_VisageNonterminal_VNonterminal nt_ inh_ syn_ ( sem_VisageProductions alts_ ) -- semantic domain newtype T_VisageNonterminal = T_VisageNonterminal { attach_T_VisageNonterminal :: Identity (T_VisageNonterminal_s14 ) } newtype T_VisageNonterminal_s14 = C_VisageNonterminal_s14 { inv_VisageNonterminal_s14 :: (T_VisageNonterminal_v13 ) } data T_VisageNonterminal_s15 = C_VisageNonterminal_s15 type T_VisageNonterminal_v13 = (T_VisageNonterminal_vIn13 ) -> (T_VisageNonterminal_vOut13 ) data T_VisageNonterminal_vIn13 = T_VisageNonterminal_vIn13 data T_VisageNonterminal_vOut13 = T_VisageNonterminal_vOut13 (ATerm) {-# NOINLINE sem_VisageNonterminal_VNonterminal #-} sem_VisageNonterminal_VNonterminal :: (NontermIdent) -> (Attributes) -> (Attributes) -> T_VisageProductions -> T_VisageNonterminal sem_VisageNonterminal_VNonterminal arg_nt_ arg_inh_ arg_syn_ arg_alts_ = T_VisageNonterminal (return st14) where {-# NOINLINE st14 #-} st14 = let v13 :: T_VisageNonterminal_v13 v13 = \ (T_VisageNonterminal_vIn13 ) -> ( let _altsX29 = Control.Monad.Identity.runIdentity (attach_T_VisageProductions (arg_alts_)) (T_VisageProductions_vOut28 _altsIaterms) = inv_VisageProductions_s29 _altsX29 (T_VisageProductions_vIn28 ) _lhsOaterm :: ATerm _lhsOaterm = rule6 _altsIaterms arg_inh_ arg_nt_ arg_syn_ __result_ = T_VisageNonterminal_vOut13 _lhsOaterm in __result_ ) in C_VisageNonterminal_s14 v13 {-# INLINE rule6 #-} {-# LINE 63 "./src-ag/Visage.ag" #-} rule6 = \ ((_altsIaterms) :: [ATerm]) inh_ nt_ syn_ -> {-# LINE 63 "./src-ag/Visage.ag" #-} AAppl "Production" [AString (sQ (getName nt_)), AString (sQ(showMap inh_)), AString (sQ(showMap syn_)), AAppl "Alternatives" _altsIaterms] {-# LINE 350 "dist/build/Visage.hs"#-} -- VisageNonterminals ------------------------------------------ -- wrapper data Inh_VisageNonterminals = Inh_VisageNonterminals { } data Syn_VisageNonterminals = Syn_VisageNonterminals { aterms_Syn_VisageNonterminals :: ([ATerm]) } {-# INLINABLE wrap_VisageNonterminals #-} wrap_VisageNonterminals :: T_VisageNonterminals -> Inh_VisageNonterminals -> (Syn_VisageNonterminals ) wrap_VisageNonterminals (T_VisageNonterminals act) (Inh_VisageNonterminals ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_VisageNonterminals_vIn16 (T_VisageNonterminals_vOut16 _lhsOaterms) <- return (inv_VisageNonterminals_s17 sem arg) return (Syn_VisageNonterminals _lhsOaterms) ) -- cata {-# NOINLINE sem_VisageNonterminals #-} sem_VisageNonterminals :: VisageNonterminals -> T_VisageNonterminals sem_VisageNonterminals list = Prelude.foldr sem_VisageNonterminals_Cons sem_VisageNonterminals_Nil (Prelude.map sem_VisageNonterminal list) -- semantic domain newtype T_VisageNonterminals = T_VisageNonterminals { attach_T_VisageNonterminals :: Identity (T_VisageNonterminals_s17 ) } newtype T_VisageNonterminals_s17 = C_VisageNonterminals_s17 { inv_VisageNonterminals_s17 :: (T_VisageNonterminals_v16 ) } data T_VisageNonterminals_s18 = C_VisageNonterminals_s18 type T_VisageNonterminals_v16 = (T_VisageNonterminals_vIn16 ) -> (T_VisageNonterminals_vOut16 ) data T_VisageNonterminals_vIn16 = T_VisageNonterminals_vIn16 data T_VisageNonterminals_vOut16 = T_VisageNonterminals_vOut16 ([ATerm]) {-# NOINLINE sem_VisageNonterminals_Cons #-} sem_VisageNonterminals_Cons :: T_VisageNonterminal -> T_VisageNonterminals -> T_VisageNonterminals sem_VisageNonterminals_Cons arg_hd_ arg_tl_ = T_VisageNonterminals (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_VisageNonterminals_v16 v16 = \ (T_VisageNonterminals_vIn16 ) -> ( let _hdX14 = Control.Monad.Identity.runIdentity (attach_T_VisageNonterminal (arg_hd_)) _tlX17 = Control.Monad.Identity.runIdentity (attach_T_VisageNonterminals (arg_tl_)) (T_VisageNonterminal_vOut13 _hdIaterm) = inv_VisageNonterminal_s14 _hdX14 (T_VisageNonterminal_vIn13 ) (T_VisageNonterminals_vOut16 _tlIaterms) = inv_VisageNonterminals_s17 _tlX17 (T_VisageNonterminals_vIn16 ) _lhsOaterms :: [ATerm] _lhsOaterms = rule7 _hdIaterm _tlIaterms __result_ = T_VisageNonterminals_vOut16 _lhsOaterms in __result_ ) in C_VisageNonterminals_s17 v16 {-# INLINE rule7 #-} {-# LINE 58 "./src-ag/Visage.ag" #-} rule7 = \ ((_hdIaterm) :: ATerm) ((_tlIaterms) :: [ATerm]) -> {-# LINE 58 "./src-ag/Visage.ag" #-} _hdIaterm : _tlIaterms {-# LINE 403 "dist/build/Visage.hs"#-} {-# NOINLINE sem_VisageNonterminals_Nil #-} sem_VisageNonterminals_Nil :: T_VisageNonterminals sem_VisageNonterminals_Nil = T_VisageNonterminals (return st17) where {-# NOINLINE st17 #-} st17 = let v16 :: T_VisageNonterminals_v16 v16 = \ (T_VisageNonterminals_vIn16 ) -> ( let _lhsOaterms :: [ATerm] _lhsOaterms = rule8 () __result_ = T_VisageNonterminals_vOut16 _lhsOaterms in __result_ ) in C_VisageNonterminals_s17 v16 {-# INLINE rule8 #-} {-# LINE 59 "./src-ag/Visage.ag" #-} rule8 = \ (_ :: ()) -> {-# LINE 59 "./src-ag/Visage.ag" #-} [] {-# LINE 421 "dist/build/Visage.hs"#-} -- VisagePattern ----------------------------------------------- -- wrapper data Inh_VisagePattern = Inh_VisagePattern { } data Syn_VisagePattern = Syn_VisagePattern { aterm_Syn_VisagePattern :: (ATerm) } {-# INLINABLE wrap_VisagePattern #-} wrap_VisagePattern :: T_VisagePattern -> Inh_VisagePattern -> (Syn_VisagePattern ) wrap_VisagePattern (T_VisagePattern act) (Inh_VisagePattern ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_VisagePattern_vIn19 (T_VisagePattern_vOut19 _lhsOaterm) <- return (inv_VisagePattern_s20 sem arg) return (Syn_VisagePattern _lhsOaterm) ) -- cata {-# NOINLINE sem_VisagePattern #-} sem_VisagePattern :: VisagePattern -> T_VisagePattern sem_VisagePattern ( VConstr name_ pats_ ) = sem_VisagePattern_VConstr name_ ( sem_VisagePatterns pats_ ) sem_VisagePattern ( VProduct pos_ pats_ ) = sem_VisagePattern_VProduct pos_ ( sem_VisagePatterns pats_ ) sem_VisagePattern ( VVar field_ attr_ ) = sem_VisagePattern_VVar field_ attr_ sem_VisagePattern ( VAlias field_ attr_ pat_ ) = sem_VisagePattern_VAlias field_ attr_ ( sem_VisagePattern pat_ ) sem_VisagePattern ( VUnderscore pos_ ) = sem_VisagePattern_VUnderscore pos_ -- semantic domain newtype T_VisagePattern = T_VisagePattern { attach_T_VisagePattern :: Identity (T_VisagePattern_s20 ) } newtype T_VisagePattern_s20 = C_VisagePattern_s20 { inv_VisagePattern_s20 :: (T_VisagePattern_v19 ) } data T_VisagePattern_s21 = C_VisagePattern_s21 type T_VisagePattern_v19 = (T_VisagePattern_vIn19 ) -> (T_VisagePattern_vOut19 ) data T_VisagePattern_vIn19 = T_VisagePattern_vIn19 data T_VisagePattern_vOut19 = T_VisagePattern_vOut19 (ATerm) {-# NOINLINE sem_VisagePattern_VConstr #-} sem_VisagePattern_VConstr :: (ConstructorIdent) -> T_VisagePatterns -> T_VisagePattern sem_VisagePattern_VConstr arg_name_ arg_pats_ = T_VisagePattern (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_VisagePattern_v19 v19 = \ (T_VisagePattern_vIn19 ) -> ( let _patsX23 = Control.Monad.Identity.runIdentity (attach_T_VisagePatterns (arg_pats_)) (T_VisagePatterns_vOut22 _patsIaterms) = inv_VisagePatterns_s23 _patsX23 (T_VisagePatterns_vIn22 ) _lhsOaterm :: ATerm _lhsOaterm = rule9 _patsIaterms arg_name_ __result_ = T_VisagePattern_vOut19 _lhsOaterm in __result_ ) in C_VisagePattern_s20 v19 {-# INLINE rule9 #-} {-# LINE 112 "./src-ag/Visage.ag" #-} rule9 = \ ((_patsIaterms) :: [ATerm]) name_ -> {-# LINE 112 "./src-ag/Visage.ag" #-} AAppl "Pattern" [AAppl "Constr" [AString (sQ (showAGPos (getPos name_))), AString (sQ (getName name_)), AAppl "Patterns" _patsIaterms]] {-# LINE 478 "dist/build/Visage.hs"#-} {-# NOINLINE sem_VisagePattern_VProduct #-} sem_VisagePattern_VProduct :: (Pos) -> T_VisagePatterns -> T_VisagePattern sem_VisagePattern_VProduct arg_pos_ arg_pats_ = T_VisagePattern (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_VisagePattern_v19 v19 = \ (T_VisagePattern_vIn19 ) -> ( let _patsX23 = Control.Monad.Identity.runIdentity (attach_T_VisagePatterns (arg_pats_)) (T_VisagePatterns_vOut22 _patsIaterms) = inv_VisagePatterns_s23 _patsX23 (T_VisagePatterns_vIn22 ) _lhsOaterm :: ATerm _lhsOaterm = rule10 _patsIaterms arg_pos_ __result_ = T_VisagePattern_vOut19 _lhsOaterm in __result_ ) in C_VisagePattern_s20 v19 {-# INLINE rule10 #-} {-# LINE 115 "./src-ag/Visage.ag" #-} rule10 = \ ((_patsIaterms) :: [ATerm]) pos_ -> {-# LINE 115 "./src-ag/Visage.ag" #-} AAppl "Pattern" [AAppl "Product" [AString (sQ (showAGPos pos_)), AAppl "Patterns" _patsIaterms]] {-# LINE 499 "dist/build/Visage.hs"#-} {-# NOINLINE sem_VisagePattern_VVar #-} sem_VisagePattern_VVar :: (Identifier) -> (Identifier) -> T_VisagePattern sem_VisagePattern_VVar arg_field_ arg_attr_ = T_VisagePattern (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_VisagePattern_v19 v19 = \ (T_VisagePattern_vIn19 ) -> ( let _lhsOaterm :: ATerm _lhsOaterm = rule11 arg_attr_ arg_field_ __result_ = T_VisagePattern_vOut19 _lhsOaterm in __result_ ) in C_VisagePattern_s20 v19 {-# INLINE rule11 #-} {-# LINE 117 "./src-ag/Visage.ag" #-} rule11 = \ attr_ field_ -> {-# LINE 117 "./src-ag/Visage.ag" #-} AAppl "Pattern" [AAppl "Var" [AString (sQ (showAGPos (getPos field_))), AString (sQ (getName field_ ++ "." ++ getName attr_))]] {-# LINE 518 "dist/build/Visage.hs"#-} {-# NOINLINE sem_VisagePattern_VAlias #-} sem_VisagePattern_VAlias :: (Identifier) -> (Identifier) -> T_VisagePattern -> T_VisagePattern sem_VisagePattern_VAlias arg_field_ arg_attr_ arg_pat_ = T_VisagePattern (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_VisagePattern_v19 v19 = \ (T_VisagePattern_vIn19 ) -> ( let _patX20 = Control.Monad.Identity.runIdentity (attach_T_VisagePattern (arg_pat_)) (T_VisagePattern_vOut19 _patIaterm) = inv_VisagePattern_s20 _patX20 (T_VisagePattern_vIn19 ) _lhsOaterm :: ATerm _lhsOaterm = rule12 _patIaterm arg_attr_ arg_field_ __result_ = T_VisagePattern_vOut19 _lhsOaterm in __result_ ) in C_VisagePattern_s20 v19 {-# INLINE rule12 #-} {-# LINE 119 "./src-ag/Visage.ag" #-} rule12 = \ ((_patIaterm) :: ATerm) attr_ field_ -> {-# LINE 119 "./src-ag/Visage.ag" #-} AAppl "Pattern" [AAppl "Alias" [AString (sQ (showAGPos (getPos field_))), AString (sQ (getName field_ ++ "." ++ getName attr_)), _patIaterm]] {-# LINE 539 "dist/build/Visage.hs"#-} {-# NOINLINE sem_VisagePattern_VUnderscore #-} sem_VisagePattern_VUnderscore :: (Pos) -> T_VisagePattern sem_VisagePattern_VUnderscore arg_pos_ = T_VisagePattern (return st20) where {-# NOINLINE st20 #-} st20 = let v19 :: T_VisagePattern_v19 v19 = \ (T_VisagePattern_vIn19 ) -> ( let _lhsOaterm :: ATerm _lhsOaterm = rule13 arg_pos_ __result_ = T_VisagePattern_vOut19 _lhsOaterm in __result_ ) in C_VisagePattern_s20 v19 {-# INLINE rule13 #-} {-# LINE 121 "./src-ag/Visage.ag" #-} rule13 = \ pos_ -> {-# LINE 121 "./src-ag/Visage.ag" #-} AAppl "Pattern" [AAppl "Underscore" [AString (sQ (showAGPos pos_))]] {-# LINE 557 "dist/build/Visage.hs"#-} -- VisagePatterns ---------------------------------------------- -- wrapper data Inh_VisagePatterns = Inh_VisagePatterns { } data Syn_VisagePatterns = Syn_VisagePatterns { aterms_Syn_VisagePatterns :: ([ATerm]) } {-# INLINABLE wrap_VisagePatterns #-} wrap_VisagePatterns :: T_VisagePatterns -> Inh_VisagePatterns -> (Syn_VisagePatterns ) wrap_VisagePatterns (T_VisagePatterns act) (Inh_VisagePatterns ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_VisagePatterns_vIn22 (T_VisagePatterns_vOut22 _lhsOaterms) <- return (inv_VisagePatterns_s23 sem arg) return (Syn_VisagePatterns _lhsOaterms) ) -- cata {-# NOINLINE sem_VisagePatterns #-} sem_VisagePatterns :: VisagePatterns -> T_VisagePatterns sem_VisagePatterns list = Prelude.foldr sem_VisagePatterns_Cons sem_VisagePatterns_Nil (Prelude.map sem_VisagePattern list) -- semantic domain newtype T_VisagePatterns = T_VisagePatterns { attach_T_VisagePatterns :: Identity (T_VisagePatterns_s23 ) } newtype T_VisagePatterns_s23 = C_VisagePatterns_s23 { inv_VisagePatterns_s23 :: (T_VisagePatterns_v22 ) } data T_VisagePatterns_s24 = C_VisagePatterns_s24 type T_VisagePatterns_v22 = (T_VisagePatterns_vIn22 ) -> (T_VisagePatterns_vOut22 ) data T_VisagePatterns_vIn22 = T_VisagePatterns_vIn22 data T_VisagePatterns_vOut22 = T_VisagePatterns_vOut22 ([ATerm]) {-# NOINLINE sem_VisagePatterns_Cons #-} sem_VisagePatterns_Cons :: T_VisagePattern -> T_VisagePatterns -> T_VisagePatterns sem_VisagePatterns_Cons arg_hd_ arg_tl_ = T_VisagePatterns (return st23) where {-# NOINLINE st23 #-} st23 = let v22 :: T_VisagePatterns_v22 v22 = \ (T_VisagePatterns_vIn22 ) -> ( let _hdX20 = Control.Monad.Identity.runIdentity (attach_T_VisagePattern (arg_hd_)) _tlX23 = Control.Monad.Identity.runIdentity (attach_T_VisagePatterns (arg_tl_)) (T_VisagePattern_vOut19 _hdIaterm) = inv_VisagePattern_s20 _hdX20 (T_VisagePattern_vIn19 ) (T_VisagePatterns_vOut22 _tlIaterms) = inv_VisagePatterns_s23 _tlX23 (T_VisagePatterns_vIn22 ) _lhsOaterms :: [ATerm] _lhsOaterms = rule14 _hdIaterm _tlIaterms __result_ = T_VisagePatterns_vOut22 _lhsOaterms in __result_ ) in C_VisagePatterns_s23 v22 {-# INLINE rule14 #-} {-# LINE 107 "./src-ag/Visage.ag" #-} rule14 = \ ((_hdIaterm) :: ATerm) ((_tlIaterms) :: [ATerm]) -> {-# LINE 107 "./src-ag/Visage.ag" #-} _hdIaterm : _tlIaterms {-# LINE 610 "dist/build/Visage.hs"#-} {-# NOINLINE sem_VisagePatterns_Nil #-} sem_VisagePatterns_Nil :: T_VisagePatterns sem_VisagePatterns_Nil = T_VisagePatterns (return st23) where {-# NOINLINE st23 #-} st23 = let v22 :: T_VisagePatterns_v22 v22 = \ (T_VisagePatterns_vIn22 ) -> ( let _lhsOaterms :: [ATerm] _lhsOaterms = rule15 () __result_ = T_VisagePatterns_vOut22 _lhsOaterms in __result_ ) in C_VisagePatterns_s23 v22 {-# INLINE rule15 #-} {-# LINE 108 "./src-ag/Visage.ag" #-} rule15 = \ (_ :: ()) -> {-# LINE 108 "./src-ag/Visage.ag" #-} [] {-# LINE 628 "dist/build/Visage.hs"#-} -- VisageProduction -------------------------------------------- -- wrapper data Inh_VisageProduction = Inh_VisageProduction { } data Syn_VisageProduction = Syn_VisageProduction { aterm_Syn_VisageProduction :: (ATerm) } {-# INLINABLE wrap_VisageProduction #-} wrap_VisageProduction :: T_VisageProduction -> Inh_VisageProduction -> (Syn_VisageProduction ) wrap_VisageProduction (T_VisageProduction act) (Inh_VisageProduction ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_VisageProduction_vIn25 (T_VisageProduction_vOut25 _lhsOaterm) <- return (inv_VisageProduction_s26 sem arg) return (Syn_VisageProduction _lhsOaterm) ) -- cata {-# INLINE sem_VisageProduction #-} sem_VisageProduction :: VisageProduction -> T_VisageProduction sem_VisageProduction ( VProduction con_ children_ rules_ locrules_ ) = sem_VisageProduction_VProduction con_ ( sem_VisageChildren children_ ) ( sem_VisageRules rules_ ) ( sem_VisageRules locrules_ ) -- semantic domain newtype T_VisageProduction = T_VisageProduction { attach_T_VisageProduction :: Identity (T_VisageProduction_s26 ) } newtype T_VisageProduction_s26 = C_VisageProduction_s26 { inv_VisageProduction_s26 :: (T_VisageProduction_v25 ) } data T_VisageProduction_s27 = C_VisageProduction_s27 type T_VisageProduction_v25 = (T_VisageProduction_vIn25 ) -> (T_VisageProduction_vOut25 ) data T_VisageProduction_vIn25 = T_VisageProduction_vIn25 data T_VisageProduction_vOut25 = T_VisageProduction_vOut25 (ATerm) {-# NOINLINE sem_VisageProduction_VProduction #-} sem_VisageProduction_VProduction :: (ConstructorIdent) -> T_VisageChildren -> T_VisageRules -> T_VisageRules -> T_VisageProduction sem_VisageProduction_VProduction arg_con_ arg_children_ arg_rules_ arg_locrules_ = T_VisageProduction (return st26) where {-# NOINLINE st26 #-} st26 = let v25 :: T_VisageProduction_v25 v25 = \ (T_VisageProduction_vIn25 ) -> ( let _childrenX8 = Control.Monad.Identity.runIdentity (attach_T_VisageChildren (arg_children_)) _rulesX35 = Control.Monad.Identity.runIdentity (attach_T_VisageRules (arg_rules_)) _locrulesX35 = Control.Monad.Identity.runIdentity (attach_T_VisageRules (arg_locrules_)) (T_VisageChildren_vOut7 _childrenIaterms) = inv_VisageChildren_s8 _childrenX8 (T_VisageChildren_vIn7 ) (T_VisageRules_vOut34 _rulesIaterms) = inv_VisageRules_s35 _rulesX35 (T_VisageRules_vIn34 _rulesOisLoc) (T_VisageRules_vOut34 _locrulesIaterms) = inv_VisageRules_s35 _locrulesX35 (T_VisageRules_vIn34 _locrulesOisLoc) _lhsOaterm :: ATerm _lhsOaterm = rule16 _childrenIaterms _locrulesIaterms _rulesIaterms arg_con_ _locrulesOisLoc = rule17 () _rulesOisLoc = rule18 () __result_ = T_VisageProduction_vOut25 _lhsOaterm in __result_ ) in C_VisageProduction_s26 v25 {-# INLINE rule16 #-} {-# LINE 73 "./src-ag/Visage.ag" #-} rule16 = \ ((_childrenIaterms) :: [ATerm]) ((_locrulesIaterms) :: [ATerm]) ((_rulesIaterms) :: [ATerm]) con_ -> {-# LINE 73 "./src-ag/Visage.ag" #-} AAppl "Alternative" [AString (sQ (getName con_)), AAppl "Children" _childrenIaterms, AAppl "Rules" _rulesIaterms, AAppl "LocRules" _locrulesIaterms] {-# LINE 687 "dist/build/Visage.hs"#-} {-# INLINE rule17 #-} {-# LINE 76 "./src-ag/Visage.ag" #-} rule17 = \ (_ :: ()) -> {-# LINE 76 "./src-ag/Visage.ag" #-} True {-# LINE 693 "dist/build/Visage.hs"#-} {-# INLINE rule18 #-} {-# LINE 77 "./src-ag/Visage.ag" #-} rule18 = \ (_ :: ()) -> {-# LINE 77 "./src-ag/Visage.ag" #-} False {-# LINE 699 "dist/build/Visage.hs"#-} -- VisageProductions ------------------------------------------- -- wrapper data Inh_VisageProductions = Inh_VisageProductions { } data Syn_VisageProductions = Syn_VisageProductions { aterms_Syn_VisageProductions :: ([ATerm]) } {-# INLINABLE wrap_VisageProductions #-} wrap_VisageProductions :: T_VisageProductions -> Inh_VisageProductions -> (Syn_VisageProductions ) wrap_VisageProductions (T_VisageProductions act) (Inh_VisageProductions ) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_VisageProductions_vIn28 (T_VisageProductions_vOut28 _lhsOaterms) <- return (inv_VisageProductions_s29 sem arg) return (Syn_VisageProductions _lhsOaterms) ) -- cata {-# NOINLINE sem_VisageProductions #-} sem_VisageProductions :: VisageProductions -> T_VisageProductions sem_VisageProductions list = Prelude.foldr sem_VisageProductions_Cons sem_VisageProductions_Nil (Prelude.map sem_VisageProduction list) -- semantic domain newtype T_VisageProductions = T_VisageProductions { attach_T_VisageProductions :: Identity (T_VisageProductions_s29 ) } newtype T_VisageProductions_s29 = C_VisageProductions_s29 { inv_VisageProductions_s29 :: (T_VisageProductions_v28 ) } data T_VisageProductions_s30 = C_VisageProductions_s30 type T_VisageProductions_v28 = (T_VisageProductions_vIn28 ) -> (T_VisageProductions_vOut28 ) data T_VisageProductions_vIn28 = T_VisageProductions_vIn28 data T_VisageProductions_vOut28 = T_VisageProductions_vOut28 ([ATerm]) {-# NOINLINE sem_VisageProductions_Cons #-} sem_VisageProductions_Cons :: T_VisageProduction -> T_VisageProductions -> T_VisageProductions sem_VisageProductions_Cons arg_hd_ arg_tl_ = T_VisageProductions (return st29) where {-# NOINLINE st29 #-} st29 = let v28 :: T_VisageProductions_v28 v28 = \ (T_VisageProductions_vIn28 ) -> ( let _hdX26 = Control.Monad.Identity.runIdentity (attach_T_VisageProduction (arg_hd_)) _tlX29 = Control.Monad.Identity.runIdentity (attach_T_VisageProductions (arg_tl_)) (T_VisageProduction_vOut25 _hdIaterm) = inv_VisageProduction_s26 _hdX26 (T_VisageProduction_vIn25 ) (T_VisageProductions_vOut28 _tlIaterms) = inv_VisageProductions_s29 _tlX29 (T_VisageProductions_vIn28 ) _lhsOaterms :: [ATerm] _lhsOaterms = rule19 _hdIaterm _tlIaterms __result_ = T_VisageProductions_vOut28 _lhsOaterms in __result_ ) in C_VisageProductions_s29 v28 {-# INLINE rule19 #-} {-# LINE 68 "./src-ag/Visage.ag" #-} rule19 = \ ((_hdIaterm) :: ATerm) ((_tlIaterms) :: [ATerm]) -> {-# LINE 68 "./src-ag/Visage.ag" #-} _hdIaterm : _tlIaterms {-# LINE 752 "dist/build/Visage.hs"#-} {-# NOINLINE sem_VisageProductions_Nil #-} sem_VisageProductions_Nil :: T_VisageProductions sem_VisageProductions_Nil = T_VisageProductions (return st29) where {-# NOINLINE st29 #-} st29 = let v28 :: T_VisageProductions_v28 v28 = \ (T_VisageProductions_vIn28 ) -> ( let _lhsOaterms :: [ATerm] _lhsOaterms = rule20 () __result_ = T_VisageProductions_vOut28 _lhsOaterms in __result_ ) in C_VisageProductions_s29 v28 {-# INLINE rule20 #-} {-# LINE 69 "./src-ag/Visage.ag" #-} rule20 = \ (_ :: ()) -> {-# LINE 69 "./src-ag/Visage.ag" #-} [] {-# LINE 770 "dist/build/Visage.hs"#-} -- VisageRule -------------------------------------------------- -- wrapper data Inh_VisageRule = Inh_VisageRule { isLoc_Inh_VisageRule :: (Bool) } data Syn_VisageRule = Syn_VisageRule { aterm_Syn_VisageRule :: (ATerm) } {-# INLINABLE wrap_VisageRule #-} wrap_VisageRule :: T_VisageRule -> Inh_VisageRule -> (Syn_VisageRule ) wrap_VisageRule (T_VisageRule act) (Inh_VisageRule _lhsIisLoc) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_VisageRule_vIn31 _lhsIisLoc (T_VisageRule_vOut31 _lhsOaterm) <- return (inv_VisageRule_s32 sem arg) return (Syn_VisageRule _lhsOaterm) ) -- cata {-# INLINE sem_VisageRule #-} sem_VisageRule :: VisageRule -> T_VisageRule sem_VisageRule ( VRule fieldattrs_ attr_ pat_ rhs_ owrt_ ) = sem_VisageRule_VRule fieldattrs_ attr_ ( sem_VisagePattern pat_ ) ( sem_Expression rhs_ ) owrt_ -- semantic domain newtype T_VisageRule = T_VisageRule { attach_T_VisageRule :: Identity (T_VisageRule_s32 ) } newtype T_VisageRule_s32 = C_VisageRule_s32 { inv_VisageRule_s32 :: (T_VisageRule_v31 ) } data T_VisageRule_s33 = C_VisageRule_s33 type T_VisageRule_v31 = (T_VisageRule_vIn31 ) -> (T_VisageRule_vOut31 ) data T_VisageRule_vIn31 = T_VisageRule_vIn31 (Bool) data T_VisageRule_vOut31 = T_VisageRule_vOut31 (ATerm) {-# NOINLINE sem_VisageRule_VRule #-} sem_VisageRule_VRule :: ([(Identifier,Identifier)]) -> (Identifier) -> T_VisagePattern -> T_Expression -> (Bool) -> T_VisageRule sem_VisageRule_VRule _ arg_attr_ arg_pat_ arg_rhs_ arg_owrt_ = T_VisageRule (return st32) where {-# NOINLINE st32 #-} st32 = let v31 :: T_VisageRule_v31 v31 = \ (T_VisageRule_vIn31 _lhsIisLoc) -> ( let _patX20 = Control.Monad.Identity.runIdentity (attach_T_VisagePattern (arg_pat_)) _rhsX2 = Control.Monad.Identity.runIdentity (attach_T_Expression (arg_rhs_)) (T_VisagePattern_vOut19 _patIaterm) = inv_VisagePattern_s20 _patX20 (T_VisagePattern_vIn19 ) (T_Expression_vOut1 _rhsIaterm) = inv_Expression_s2 _rhsX2 (T_Expression_vIn1 ) _lhsOaterm :: ATerm _lhsOaterm = rule21 _lhsIisLoc _patIaterm _rhsIaterm arg_attr_ arg_owrt_ __result_ = T_VisageRule_vOut31 _lhsOaterm in __result_ ) in C_VisageRule_s32 v31 {-# INLINE rule21 #-} {-# LINE 97 "./src-ag/Visage.ag" #-} rule21 = \ ((_lhsIisLoc) :: Bool) ((_patIaterm) :: ATerm) ((_rhsIaterm) :: ATerm) attr_ owrt_ -> {-# LINE 97 "./src-ag/Visage.ag" #-} AAppl (if _lhsIisLoc then "LocRule" else "Rule") ([AString (sQ (getName attr_)), _patIaterm, _rhsIaterm] ++ if _lhsIisLoc then [AString (sQ (show owrt_))] else []) {-# LINE 824 "dist/build/Visage.hs"#-} -- VisageRules ------------------------------------------------- -- wrapper data Inh_VisageRules = Inh_VisageRules { isLoc_Inh_VisageRules :: (Bool) } data Syn_VisageRules = Syn_VisageRules { aterms_Syn_VisageRules :: ([ATerm]) } {-# INLINABLE wrap_VisageRules #-} wrap_VisageRules :: T_VisageRules -> Inh_VisageRules -> (Syn_VisageRules ) wrap_VisageRules (T_VisageRules act) (Inh_VisageRules _lhsIisLoc) = Control.Monad.Identity.runIdentity ( do sem <- act let arg = T_VisageRules_vIn34 _lhsIisLoc (T_VisageRules_vOut34 _lhsOaterms) <- return (inv_VisageRules_s35 sem arg) return (Syn_VisageRules _lhsOaterms) ) -- cata {-# NOINLINE sem_VisageRules #-} sem_VisageRules :: VisageRules -> T_VisageRules sem_VisageRules list = Prelude.foldr sem_VisageRules_Cons sem_VisageRules_Nil (Prelude.map sem_VisageRule list) -- semantic domain newtype T_VisageRules = T_VisageRules { attach_T_VisageRules :: Identity (T_VisageRules_s35 ) } newtype T_VisageRules_s35 = C_VisageRules_s35 { inv_VisageRules_s35 :: (T_VisageRules_v34 ) } data T_VisageRules_s36 = C_VisageRules_s36 type T_VisageRules_v34 = (T_VisageRules_vIn34 ) -> (T_VisageRules_vOut34 ) data T_VisageRules_vIn34 = T_VisageRules_vIn34 (Bool) data T_VisageRules_vOut34 = T_VisageRules_vOut34 ([ATerm]) {-# NOINLINE sem_VisageRules_Cons #-} sem_VisageRules_Cons :: T_VisageRule -> T_VisageRules -> T_VisageRules sem_VisageRules_Cons arg_hd_ arg_tl_ = T_VisageRules (return st35) where {-# NOINLINE st35 #-} st35 = let v34 :: T_VisageRules_v34 v34 = \ (T_VisageRules_vIn34 _lhsIisLoc) -> ( let _hdX32 = Control.Monad.Identity.runIdentity (attach_T_VisageRule (arg_hd_)) _tlX35 = Control.Monad.Identity.runIdentity (attach_T_VisageRules (arg_tl_)) (T_VisageRule_vOut31 _hdIaterm) = inv_VisageRule_s32 _hdX32 (T_VisageRule_vIn31 _hdOisLoc) (T_VisageRules_vOut34 _tlIaterms) = inv_VisageRules_s35 _tlX35 (T_VisageRules_vIn34 _tlOisLoc) _lhsOaterms :: [ATerm] _lhsOaterms = rule22 _hdIaterm _tlIaterms _hdOisLoc = rule23 _lhsIisLoc _tlOisLoc = rule24 _lhsIisLoc __result_ = T_VisageRules_vOut34 _lhsOaterms in __result_ ) in C_VisageRules_s35 v34 {-# INLINE rule22 #-} {-# LINE 92 "./src-ag/Visage.ag" #-} rule22 = \ ((_hdIaterm) :: ATerm) ((_tlIaterms) :: [ATerm]) -> {-# LINE 92 "./src-ag/Visage.ag" #-} _hdIaterm : _tlIaterms {-# LINE 879 "dist/build/Visage.hs"#-} {-# INLINE rule23 #-} rule23 = \ ((_lhsIisLoc) :: Bool) -> _lhsIisLoc {-# INLINE rule24 #-} rule24 = \ ((_lhsIisLoc) :: Bool) -> _lhsIisLoc {-# NOINLINE sem_VisageRules_Nil #-} sem_VisageRules_Nil :: T_VisageRules sem_VisageRules_Nil = T_VisageRules (return st35) where {-# NOINLINE st35 #-} st35 = let v34 :: T_VisageRules_v34 v34 = \ (T_VisageRules_vIn34 _lhsIisLoc) -> ( let _lhsOaterms :: [ATerm] _lhsOaterms = rule25 () __result_ = T_VisageRules_vOut34 _lhsOaterms in __result_ ) in C_VisageRules_s35 v34 {-# INLINE rule25 #-} {-# LINE 93 "./src-ag/Visage.ag" #-} rule25 = \ (_ :: ()) -> {-# LINE 93 "./src-ag/Visage.ag" #-} [] {-# LINE 903 "dist/build/Visage.hs"#-} uuagc-0.9.42.3/src-generated/VisagePatterns.hs000644 000765 000024 00000002636 12127045231 023073 0ustar00jeroenbransenstaff000000 000000 -- UUAGC 0.9.42.3 (src-ag/VisagePatterns.ag) module VisagePatterns where {-# LINE 2 "./src-ag/VisagePatterns.ag" #-} import UU.Scanner.Position(Pos) import CommonTypes {-# LINE 10 "dist/build/VisagePatterns.hs" #-} -- VisagePattern ----------------------------------------------- {- alternatives: alternative VConstr: child name : {ConstructorIdent} child pats : VisagePatterns alternative VProduct: child pos : {Pos} child pats : VisagePatterns alternative VVar: child field : {Identifier} child attr : {Identifier} alternative VAlias: child field : {Identifier} child attr : {Identifier} child pat : VisagePattern alternative VUnderscore: child pos : {Pos} -} data VisagePattern = VConstr (ConstructorIdent) (VisagePatterns) | VProduct (Pos) (VisagePatterns) | VVar (Identifier) (Identifier) | VAlias (Identifier) (Identifier) (VisagePattern) | VUnderscore (Pos) -- VisagePatterns ---------------------------------------------- {- alternatives: alternative Cons: child hd : VisagePattern child tl : VisagePatterns alternative Nil: -} type VisagePatterns = [VisagePattern]uuagc-0.9.42.3/src-generated/VisageSyntax.hs000644 000765 000024 00000006256 12127045231 022563 0ustar00jeroenbransenstaff000000 000000 -- UUAGC 0.9.42.3 (src-ag/VisageSyntax.ag) module VisageSyntax where {-# LINE 2 "./src-ag/VisageSyntax.ag" #-} import CommonTypes import UU.Pretty import AbstractSyntax import VisagePatterns import Expression {-# LINE 13 "dist/build/VisageSyntax.hs" #-} -- VisageChild ------------------------------------------------- {- alternatives: alternative VChild: child name : {Identifier} child tp : {Type} child inh : {Attributes} child syn : {Attributes} child rules : VisageRules -} data VisageChild = VChild (Identifier) (Type) (Attributes) (Attributes) (VisageRules) -- VisageChildren ---------------------------------------------- {- alternatives: alternative Cons: child hd : VisageChild child tl : VisageChildren alternative Nil: -} type VisageChildren = [VisageChild] -- VisageGrammar ----------------------------------------------- {- alternatives: alternative VGrammar: child nonts : VisageNonterminals -} data VisageGrammar = VGrammar (VisageNonterminals) -- VisageNonterminal ------------------------------------------- {- alternatives: alternative VNonterminal: child nt : {NontermIdent} child inh : {Attributes} child syn : {Attributes} child alts : VisageProductions -} data VisageNonterminal = VNonterminal (NontermIdent) (Attributes) (Attributes) (VisageProductions) -- VisageNonterminals ------------------------------------------ {- alternatives: alternative Cons: child hd : VisageNonterminal child tl : VisageNonterminals alternative Nil: -} type VisageNonterminals = [VisageNonterminal] -- VisageProduction -------------------------------------------- {- alternatives: alternative VProduction: child con : {ConstructorIdent} child children : VisageChildren child rules : VisageRules child locrules : VisageRules -} data VisageProduction = VProduction (ConstructorIdent) (VisageChildren) (VisageRules) (VisageRules) -- VisageProductions ------------------------------------------- {- alternatives: alternative Cons: child hd : VisageProduction child tl : VisageProductions alternative Nil: -} type VisageProductions = [VisageProduction] -- VisageRule -------------------------------------------------- {- alternatives: alternative VRule: child fieldattrs : {[(Identifier,Identifier)]} child attr : {Identifier} child pat : {VisagePattern} child rhs : {Expression} child owrt : {Bool} -} data VisageRule = VRule (([(Identifier,Identifier)])) (Identifier) (VisagePattern) (Expression) (Bool) -- VisageRules ------------------------------------------------- {- alternatives: alternative Cons: child hd : VisageRule child tl : VisageRules alternative Nil: -} type VisageRules = [VisageRule]uuagc-0.9.42.3/src-ag/AbstractSyntax.ag000644 000765 000024 00000006360 12127045231 021512 0ustar00jeroenbransenstaff000000 000000 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 uuagc-0.9.42.3/src-ag/AbstractSyntaxDump.ag000644 000765 000024 00000005615 12127045231 022342 0ustar00jeroenbransenstaff000000 000000 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 = [] uuagc-0.9.42.3/src-ag/AG2AspectAG.ag000644 000765 000024 00000126175 12127045231 020470 0ustar00jeroenbransenstaff000000 000000 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)" } uuagc-0.9.42.3/src-ag/Code.ag000644 000765 000024 00000015614 12127045231 017414 0ustar00jeroenbransenstaff000000 000000 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 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 } uuagc-0.9.42.3/src-ag/CodeSyntax.ag000644 000765 000024 00000006760 12127045231 020625 0ustar00jeroenbransenstaff000000 000000 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 uuagc-0.9.42.3/src-ag/CodeSyntaxDump.ag000644 000765 000024 00000010000 12127045231 021431 0ustar00jeroenbransenstaff000000 000000 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 "" 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 = [] uuagc-0.9.42.3/src-ag/ConcreteSyntax.ag000644 000765 000024 00000010632 12127045231 021506 0ustar00jeroenbransenstaff000000 000000 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} 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} uuagc-0.9.42.3/src-ag/DeclBlocks.ag000644 000765 000024 00000000412 12127045231 020535 0ustar00jeroenbransenstaff000000 000000 imports { import Code (Decl,Expr) } DATA DeclBlocksRoot | DeclBlocksRoot blocks : DeclBlocks DATA DeclBlocks | DeclBlock defs : {[Decl]} visit : {Decl} next : DeclBlocks | DeclTerminator defs : {[Decl]} result : {Expr} uuagc-0.9.42.3/src-ag/DefaultRules.ag000644 000765 000024 00000100624 12127045231 021135 0ustar00jeroenbransenstaff000000 000000 -- 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} | | ] 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 buildConExpr ocaml typeSyns rename nt con1 fs | nt `elem` map fst typeSyns = if ocaml then synonymMl else synonymHs | otherwise = normalExpr where con = getName con1 tup = " " ++ buildTuple fs args = " " ++ unwords fs normalExpr = 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 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 nt con fld a = "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 :: Set Identifier -> [(Identifier,Attributes)] -> (Identifier,(String,String,String)) -> Rule useRule 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 noPos e | otherwise = lexTokens 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 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 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 noPos $ -- building a string and lexing it again is not so nice... but practical here constructor [childSelf attr nm tp | (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) @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> [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 "_around" and 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: "_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 ] uuagc-0.9.42.3/src-ag/Desugar.ag000644 000765 000024 00000031131 12127045231 020124 0ustar00jeroenbransenstaff000000 000000 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 "" (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 "" (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 uuagc-0.9.42.3/src-ag/DistChildAttr.ag000644 000765 000024 00000002132 12127045231 021233 0ustar00jeroenbransenstaff000000 000000 ------------------------------------------------------------------------------- -- Map of all inherited and synthesized attributes per nonterminal ------------------------------------------------------------------------------- ATTR Nonterminals Nonterminal [ || inhMap', synMap' USE {`Map.union`} {Map.empty} : {Map Identifier Attributes} ] SEM Nonterminal | Nonterminal lhs.inhMap' = Map.singleton @nt @inh lhs.synMap' = Map.singleton @nt @syn ATTR Nonterminals Nonterminal Productions Production Children Child [ inhMap, synMap : {Map Identifier Attributes} | | ] SEM Grammar | Grammar nonts.inhMap = @nonts.inhMap' nonts.synMap = @nonts.synMap' SEM Child | Child loc.chnt = case @tp of NT nt _ _ -> nt Self -> error ("The type of child " ++ show @name ++ " should not be a Self type.") Haskell t -> identifier "" -- should be ignored because the child is a terminal loc.inh = Map.findWithDefault Map.empty @loc.chnt @lhs.inhMap loc.syn = Map.findWithDefault Map.empty @loc.chnt @lhs.synMap uuagc-0.9.42.3/src-ag/ErrorMessages.ag000644 000765 000024 00000013165 12127045231 021322 0ustar00jeroenbransenstaff000000 000000 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} uuagc-0.9.42.3/src-ag/ExecutionPlan.ag000644 000765 000024 00000007145 12127045231 021320 0ustar00jeroenbransenstaff000000 000000 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 : {Maybe VisitIdentifier} nextVisits : {Map StateIdentifier StateCtx} -- info about the next visits from a given state prevVisits : {Map StateIdentifier StateCtx} -- info about the previous visits to a given state prods : EProductions recursive : {Bool} hoInfo : {HigherOrderInfo} DATA EProduction | EProduction con : {ConstructorIdent} 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 _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} uuagc-0.9.42.3/src-ag/ExecutionPlan2Caml.ag000644 000765 000024 00000205723 12127045231 022201 0ustar00jeroenbransenstaff000000 000000 -- 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 Pattern Patterns EChildren EChild Visits Visit VisitSteps VisitStep [ options : {Options} | | ] ATTR EProductions EProduction [ rename : {Bool} | | ] SEM ENonterminal | ENonterminal prods.rename = rename @lhs.options ------------------------------------------------------------------------------- -- Context info (nonterminal ident, constructor ident, nonterm params, etc.) ------------------------------------------------------------------------------- ATTR Visit Visits EProduction EProductions EChildren EChild ERules ERule [ nt : NontermIdent | | ] SEM ENonterminal | ENonterminal prods.nt = @nt ATTR EChildren EChild ERules ERule Visits Visit [ con : ConstructorIdent | | ] SEM EProduction | EProduction children.con = @con rules.con = @con visits.con = @con ATTR EProductions EProduction Visits Visit [ params : {[Identifier]} | | ] SEM ENonterminal | ENonterminal prods.params = @params ------------------------------------------------------------------------------- -- 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 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 True idLateBindingAttr >#< "=" >#< lateBindingFieldNm @lhs.mainName >#< "in" else empty ) -- initial attribute for late binding >-< @loc.wrapperBody loc.wrapperBody = case @initialv of Nothing -> text "{ }" -- case where there are no inherited or synthesized attributes Just initv -> 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 False i | (i,_) <- @loc.wr_syns ] bld = ppRecordVal [ i >|< "_syn_" >|< @nt >#< "=" >#< lhsname 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 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 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 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 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 @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 True idLateBindingAttr) (Just $ AttrInh _LHS idLateBindingAttr) ) $ ( if @hasAround then Map.insert (locname (@name) ++ "_around") Nothing else id ) $ Map.empty ChildReplace _ -> Map.singleton (instname @name) Nothing -- uses the transformation function ChildSyntax -> Map.empty ) else Left $ IncompatibleAttachKind @name kind loc.nt = extractNonterminal @tp { stname :: Identifier -> Int -> String stname child st = "_" ++ getName child ++ "X" ++ show st -- should actually return some conversion info compatibleAttach :: VisitKind -> NontermIdent -> Options -> Bool compatibleAttach _ _ _ = True } -- 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 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 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 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 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) Inh_HsToken)) @tks lhs.semfunc = vlist $ showTokens $ map (\tok -> tok_Syn_HsToken (wrap_HsToken (sem_HsToken tok) Inh_HsToken)) @tks -- child visit map ATTR Visit Visits EProduction EProductions ENonterminal ENonterminals [ allchildvisit : {Map VisitIdentifier (Identifier -> 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 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 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 False i, Just (AttrSyn _LHS i)) | i <- Set.elems @syn ] in mp1 `Map.union` mp2 loc.inhVarNms = Set.map (lhsname True) @inh loc.defs = @steps.defs `Set.union` @loc.inhVarNms `Set.union` @lhs.terminaldefs loc.defsAsMap = Map.fromList [ (a, Nothing) | a <- Set.elems @loc.defs ] ATTR ERule ERules [ | | ruledefs USE {`uwSetUnion`} {Map.empty} : {Map Identifier (Set String)} ruleuses USE {`uwMapUnion`} {Map.empty} : {Map Identifier (Map String (Maybe NonLocalAttr))} ] ATTR Visit Visits VisitSteps VisitStep [ ruledefs : {Map Identifier (Set String)} ruleuses : {Map Identifier (Map String (Maybe NonLocalAttr))} | | ] SEM ERule | ERule lhs.ruledefs = Map.singleton @name @pattern.attrs lhs.ruleuses = Map.singleton @name @rhs.attrs SEM EProduction | EProduction visits.ruledefs = @rules.ruledefs visits.ruleuses = @rules.ruleuses ATTR Visit Visits EProduction EProductions ENonterminal ENonterminals [ | | visitdefs USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (Set Identifier)} visituses USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (Set Identifier)} ] SEM Visit | Visit lhs.visitdefs = Map.singleton @ident @syn lhs.visituses = Map.singleton @ident @inh ATTR Visit Visits VisitSteps VisitStep EProduction EProductions ENonterminal ENonterminals [ avisitdefs : {Map VisitIdentifier (Set Identifier)} avisituses : {Map VisitIdentifier (Set Identifier)} | | ] SEM ExecutionPlan | ExecutionPlan nonts.avisitdefs = @nonts.visitdefs nonts.avisituses = @nonts.visituses ATTR VisitSteps VisitStep [ | | defs USE {`Set.union`} {Set.empty} : {Set String} uses USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ] SEM VisitStep | Sem lhs.defs = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruledefs lhs.uses = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruleuses | ChildVisit lhs.defs = Set.insert (stname @child @to) $ maybe (error "Visit not found") (Set.map $ attrname True @child) $ Map.lookup @visit @lhs.avisitdefs lhs.uses = let convert attrs = Map.fromList [ (attrname False @child attr, Just $ mkNonLocalAttr True @child attr) | attr <- Set.elems attrs ] in Map.insert (stname @child @from) Nothing $ convert $ maybe (error "Visit not found") id $ Map.lookup @visit @lhs.avisituses ------------------------------------------------------------------------------- -- Identification of lazy intra defs within a production -- -- These identifiers will not be marked as strict in rules and state closures ------------------------------------------------------------------------------- ATTR Visits Visit VisitSteps VisitStep [ | | lazyIntras USE {`Set.union`} {Set.empty} : {Set String} ] ATTR ERules ERule [ lazyIntras : {Set String} | | ] SEM Visit | Visit loc.lazyIntrasInh = case @kind of VisitPure False -> @loc.inhVarNms `Set.union` @steps.defs _ -> Set.empty lhs.lazyIntras = @loc.lazyIntrasInh `Set.union` @steps.lazyIntras SEM VisitStep | PureGroup lhs.lazyIntras = if @ordered then @steps.lazyIntras else @steps.defs SEM EProduction | EProduction loc.lazyIntras = @visits.lazyIntras ------------------------------------------------------------------------------- -- Pretty printing of haskell code ------------------------------------------------------------------------------- -- 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 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 uuagc-0.9.42.3/src-ag/ExecutionPlan2Hs.ag000644 000765 000024 00000271431 12127045231 021676 0ustar00jeroenbransenstaff000000 000000 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 Pattern Patterns EChildren EChild Visits Visit VisitSteps VisitStep [ options : {Options} | | ] ATTR EProductions EProduction [ rename : {Bool} | | ] SEM ENonterminal | ENonterminal prods.rename = rename @lhs.options ------------------------------------------------------------------------------- -- Context info (nonterminal ident, constructor ident, nonterm params, etc.) ------------------------------------------------------------------------------- ATTR Visit Visits EProduction EProductions EChildren EChild ERules ERule [ nt : NontermIdent | | ] SEM ENonterminal | ENonterminal prods.nt = @nt ATTR EChildren EChild ERules ERule Visits Visit [ con : ConstructorIdent | | ] SEM EProduction | EProduction children.con = @con rules.con = @con visits.con = @con ATTR EProductions EProduction Visits Visit [ params : {[Identifier]} | | ] SEM ENonterminal | ENonterminal prods.params = @params ATTR EProductions EProduction [ classCtxs : ClassContext | | ] SEM ENonterminal | ENonterminal prods.classCtxs = @classCtxs ------------------------------------------------------------------------------- -- Default output ------------------------------------------------------------------------------- ATTR ExecutionPlan [ | | output : {PP_Doc} ] SEM ExecutionPlan | ExecutionPlan lhs.output = @nonts.output >-< @loc.commonExtra >-< @loc.wrappersExtra ATTR ENonterminal ENonterminals [ wrappers : {Set NontermIdent} | | output USE {>-<} {empty} : {PP_Doc} ] SEM ExecutionPlan | ExecutionPlan nonts.wrappers = @wrappers SEM ENonterminal | ENonterminal lhs.output = ("-- " ++ getName @nt ++ " " ++ replicate (60 - length (getName @nt)) '-') >-< (if dataTypes @lhs.options then "-- data" >-< @loc.datatype >-< "" else empty) >-< (if @loc.hasWrapper then "-- wrapper" >-< @loc.wr_inh >-< @loc.wr_syn >-< @loc.wrapper >-< "" else empty) >-< (if folds @lhs.options then "-- cata" >-< @loc.sem_nt >-< "" else empty) >-< (if semfuns @lhs.options then "-- semantic domain" >-< @loc.t_init >-< @loc.t_states >-< @loc.k_states >-< @prods.t_visits >-< @prods.sem_prod >-< "" else empty) loc.hasWrapper = @nt `Set.member` @lhs.wrappers ------------------------------------------------------------------------------- -- Nonterminal datatype ------------------------------------------------------------------------------- ATTR ENonterminal ENonterminals [ typeSyns : {TypeSyns} derivings : {Derivings} | | ] SEM ExecutionPlan | ExecutionPlan nonts.typeSyns = @typeSyns nonts.derivings = @derivings SEM ENonterminal | ENonterminal loc.classPP = ppClasses $ classCtxsToDocs @classCtxs loc.aliasPre = "type" >#< @loc.classPP >#< @nt >#< @loc.t_params >#< "=" loc.datatype = case lookup @nt @lhs.typeSyns of Nothing -> "data" >#< @loc.classPP >#< @nt >#< @loc.t_params >-< ( if null @prods.datatype then empty else indent 2 $ vlist $ ( ("=" >#< head @prods.datatype) : (map ("|" >#<) $ tail @prods.datatype)) ) >-< indent 2 @loc.derivings Just (List t) -> @loc.aliasPre >#< "[" >#< show t >#< "]" Just (Maybe t) -> @loc.aliasPre >#< "Maybe" >#< show t Just (Tuple ts) -> @loc.aliasPre >#< pp_parens (ppCommas $ map (show . snd) ts) Just (Either l r) -> @loc.aliasPre >#< "Either" >#< show l >#< show r Just (Map k v) -> @loc.aliasPre >#< "Data.Map" >#< pp_parens (show k) >#< show v Just (IntMap t) -> @loc.aliasPre >#< "Data.IntMap.IntMap" >#< show t Just (OrdSet t) -> @loc.aliasPre >#< "Data.Set.Set" >#< show t Just IntSet -> @loc.aliasPre >#< "Data.IntSet.IntSet" -- Just x -> error $ "Type " ++ show x ++ " is not supported" loc.derivings = case Map.lookup @nt @lhs.derivings of Nothing -> empty Just s -> if Set.null s then empty else "deriving" >#< (pp_parens $ ppCommas $ map pp $ Set.toList s) { classCtxsToDocs :: ClassContext -> [PP_Doc] classCtxsToDocs = map toDoc where toDoc (ident,args) = (ident >#< ppSpaced (map pp_parens args)) classConstrsToDocs :: [Type] -> [PP_Doc] classConstrsToDocs = map ppTp ppClasses :: [PP_Doc] -> PP_Doc ppClasses [] = empty ppClasses xs = pp_block "(" ")" "," xs >#< "=>" ppQuants :: [Identifier] -> PP_Doc ppQuants [] = empty ppQuants ps = "forall" >#< ppSpaced ps >#< "." } ATTR EProduction [ | | datatype : {PP_Doc} ] ATTR EProductions [ | | datatype USE {:} {[]} : {[PP_Doc]} ] -- we generate the data type in the type-class style instead of the GADT style -- the GADT extension may be required if equality constraints are used SEM EProduction | EProduction lhs.datatype = @loc.quantPP1 >#< @loc.classPP1 >#< conname @lhs.rename @lhs.nt @con >#< ppConFields (dataRecords @lhs.options) @children.datatype loc.classPP1 = ppClasses (classConstrsToDocs @constraints) loc.quantPP1 = ppQuants @params { -- first parameter indicates: generate a record or not ppConFields :: Bool -> [PP_Doc] -> PP_Doc ppConFields True flds = ppListSep "{" "}" ", " flds ppConFields False flds = ppSpaced flds } ATTR EChild [ | | datatype : {PP_Doc} ] ATTR EChildren [ | | datatype USE {:} {[]} : {[PP_Doc]} ] -- Note: the child may be a higher-order attribute, and its semantics may be deforested SEM EChild | EChild ETerm loc.tpDoc = @loc.addStrict $ pp_parens $ ppTp $ removeDeforested @tp loc.strNm = recordFieldname @lhs.nt @lhs.con @name loc.field = if dataRecords @lhs.options then @loc.strNm >#< "::" >#< @loc.tpDoc else @loc.tpDoc loc.addStrict = \x -> if strictData @lhs.options then "!" >|< x else x | EChild lhs.datatype = case @kind of ChildAttr -> empty -- higher order attributes are not part of the data type _ -> @loc.field | ETerm lhs.datatype = @loc.field { ppTp :: Type -> PP_Doc ppTp = 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 True . fst) @loc.wr_inhs loc.inhlist1 = map (lhsname True . fst) @loc.wr_inhs1 loc.synlist = map (lhsname False . fst) @loc.wr_syns loc.wrapname = "wrap_" ++ show @nt loc.inhname = "Inh_" ++ show @nt loc.synname = "Syn_" ++ show @nt loc.firstVisitInfo = Map.findWithDefault ManyVis @initial @nextVisits loc.wrapper = @loc.wrapPragma >-< (@loc.wrapname >#< "::" >#< @loc.quantPP >#< @loc.classPP >#< @loc.t_type >#< @loc.t_params >#< "->" >#< @loc.inhname >#< @loc.t_params >#< "->" >#< ( if monadicWrappers @lhs.options then ppMonadType @lhs.options else empty) >#< pp_parens (@loc.synname >#< @loc.t_params)) >-< (@loc.wrapname >#< (@loc.addbang $ pp_parens (@loc.t_type >#< pp "act")) >#< (@loc.addbang $ pp_parens (@loc.inhname >#< (ppSpaced $ map (@loc.addbangWrap . pp) @loc.inhlist)) >#< "=")) >-< indent 3 (case @initialv of -- case where there are no inherited or synthesized attributes Nothing -> @loc.synname >#< " { }" Just initv -> let inCon = conNmTVisitIn @nt initv outCon = conNmTVisitOut @nt initv pat = @loc.addbang $ pp_parens $ pat0 pat0 = outCon >#< ppSpaced @loc.synlist -- should be an "end" state, thus no continuation expected here arg = inCon >#< ppSpaced @loc.inhlist1 ind = case @loc.firstVisitInfo of NoneVis -> error "wrapper: initial state should have a next visit but it has none" OneVis _ -> empty ManyVis -> @loc.k_type >|< "_v" >|< initv extra = if dummyTokenVisit @lhs.options then pp $ dummyArg @lhs.options True else empty convert = case Map.lookup initv @lhs.allVisitKinds of Just kind -> case kind of VisitPure _ -> text "return" VisitMonadic -> empty unMonad | monadicWrappers @lhs.options = empty | otherwise = unMon @lhs.options in unMonad >#< "(" >-< indent 2 ( "do" >#< ( @loc.addbang (pp "sem") >#< "<-" >#< "act" -- run the per-node monadic code to get the initial state (of the root) >-< "let" >#< @loc.addbangWrap (pp "arg") >#< "=" >#< arg >-< pat >#< "<-" >#< convert >#< pp_parens ("inv_" >|< @nt >|< "_s" >|< @initial >#< "sem" >#< ind >#< "arg" >#< extra) -- invoke initial state (of the root) >-< "return" >#< pp_parens (@loc.synname >#< ppSpaced @loc.synlist) ) ) >-< ")" ) >-< if lateHigherOrderBinding @lhs.options then indent 2 ("where" >#< lhsname True idLateBindingAttr >#< "=" >#< lateBindingFieldNm @lhs.mainName) else empty loc.wrapPragma = if parallelInvoke @lhs.options && not (monadicWrappers @lhs.options) then ppNoInline @loc.wrapname -- required for the use of unsafePerformIO in case of the IO monad else if noInlinePragmas @lhs.options then empty else ppInlinable @loc.wrapname -- ensure that the wrapper is exposed as inlinable ------------------------------------------------------------------------------- -- Collection of NT / Production sem funs references ------------------------------------------------------------------------------- ATTR ENonterminals ENonterminal EProductions EProduction [ | | semFunBndDefs, semFunBndTps USE {Seq.><} {Seq.empty} : {Seq PP_Doc} ] SEM ENonterminal | ENonterminal lhs.semFunBndDefs = @loc.semFunBndDef Seq.<| @prods.semFunBndDefs lhs.semFunBndTps = @loc.semFunBndTp Seq.<| @prods.semFunBndTps loc.semFunBndDef = @loc.semFunBndNm >#< "=" >#< @loc.semname loc.semFunBndTp = @loc.semFunBndNm >#< "::" >#< @loc.sem_tp loc.semFunBndNm = lateSemNtLabel @nt SEM EProduction | EProduction lhs.semFunBndDefs = Seq.singleton @loc.semFunBndDef lhs.semFunBndTps = Seq.singleton @loc.semFunBndTp loc.semFunBndDef = @loc.semFunBndNm >#< "=" >#< @loc.semname loc.semFunBndTp = @loc.semFunBndNm >#< "::" >#< @loc.sem_tp loc.semFunBndNm = lateSemConLabel @lhs.nt @con -- Generate a dictionary that contains the semantics of all semantic functions SEM ExecutionPlan | ExecutionPlan loc.wrappersExtra = if 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 True _LHS arg) $ Set.toList @inh loc.inhargs = \chn -> ppSpaced $ map (attrname False chn) $ Set.toList @inh loc.synargs = ppSpaced $ map (\arg -> attrname False _LHS arg) $ Set.toList @syn loc.nextargsMp = maybe Map.empty id $ Map.lookup @to @lhs.allintramap loc.nextargs = ppSpaced $ Map.keys $ @loc.nextargsMp loc.nextst = "st" >|< @to >#< @loc.nextargs >#< dummyArg @lhs.options (Map.null @loc.nextargsMp) loc.resultval = @loc.nameTOut_visit >#< @loc.synargs >#< @loc.nextStRef (loc.nextStBuild, loc.nextStRef) = case @loc.nextVisitInfo of NoneVis -> (empty, empty) _ -> (@loc.addbang (pp nextStName) >#< "=" >#< @loc.nextst, pp nextStName) { resultValName :: String resultValName = "__result_" nextStName :: String nextStName = "__st_" } -- Propagate the visit kind to the steps ATTR VisitStep VisitSteps [ kind : VisitKind | | ] SEM Visit | Visit steps.kind = @kind -- the steps in this group should be executed in a pure fashion SEM VisitStep | PureGroup steps.kind = VisitPure @ordered ATTR Visits Visit VisitStep VisitSteps [ mrules : {Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)} | | ] ATTR VisitStep VisitSteps [ | | sem_steps USE {>-<} {empty} : {PP_Doc} ] SEM VisitStep | Sem loc.ruleItf = Map.findWithDefault (error $ "Rule " ++ show @name ++ " not found") @name @lhs.mrules (lhs.errors, loc.sem_steps) = case @loc.ruleItf @lhs.kind @lhs.fmtMode of Left e -> (Seq.singleton e, empty) Right stmt -> (Seq.empty, stmt) | ChildIntro loc.attachItf = Map.findWithDefault (error $ "Child " ++ show @child ++ " not found") @child @lhs.childintros (lhs.errors,lhs.sem_steps,lhs.defs,lhs.uses) = case @loc.attachItf @lhs.kind @lhs.fmtMode of Left e -> (Seq.singleton e, empty, Set.empty, Map.empty) Right (code, defs, uses) -> (Seq.empty, code, defs, uses) | ChildVisit loc.visitItf = Map.findWithDefault (error $ "Visit " ++ show @visit ++ " not found") @visit @lhs.allchildvisit (lhs.errors, loc.patPP, loc.exprPP) = case @loc.visitItf @child @lhs.kind of Left e -> (Seq.singleton e, empty, empty) Right (pat,expr) -> (Seq.empty, pat, expr) loc.useParallel = @lhs.useParallel && not @lhs.isLast lhs.sem_steps = if @loc.useParallel -- assumes to be in a monadic do-expression then @loc.addbang ("sync_" >|< @lhs.index) >#< "<- newEmptyMVar" >-< "forkIO" >#< pp_parens (@loc.convToMonad >#< pp_parens @loc.exprPP >#< ">>= \\" >#< @loc.addbang (pp parResultName) >#< " -> putMVar sync_" >|< @lhs.index >#< parResultName) -- parResultName is guaranteed to be evaluated else let decl = case @lhs.kind of VisitPure _ -> @loc.patPP >#< "=" >#< @loc.exprPP VisitMonadic -> @loc.patPP >#< "<-" >#< @loc.exprPP in fmtDecl False @lhs.fmtMode decl loc.convToMonad = case @loc.callKind of VisitPure _ -> text "return" VisitMonadic -> empty loc.callKind = Map.findWithDefault (error "visit kind should be in the map") @visit @lhs.allVisitKinds | Sim lhs.sem_steps = @steps.sem_steps >-< @steps.sync_steps | PureGroup lhs.sem_steps = case @lhs.fmtMode of FormatDo -> "let" >#< @steps.sem_steps -- formatted as a let-block (not a line-let) _ -> @steps.sem_steps ATTR VisitSteps VisitStep [ | | sync_steps USE {>-<} {empty} : {PP_Doc} ] SEM VisitStep | ChildVisit lhs.sync_steps = if @loc.useParallel then @loc.patPP >#< "<-" >#< "takeMVar sync_" >|< @lhs.index else empty -- The fmtMode indicates in what kind of expression (do/let/line-lets) we are printing -- declarations, because that determines how we need to wrap declarations -- Invariant: @lhs.kind == VisitMonadic ---> @lhs.fmtMode == FormatDo ATTR VisitSteps VisitStep [ fmtMode : FormatMode | | ] SEM Visit | Visit steps.fmtMode = case @kind of VisitPure False -> FormatLetDecl VisitPure True -> FormatLetLine VisitMonadic -> FormatDo SEM VisitStep | PureGroup steps.fmtMode = case @lhs.fmtMode of FormatDo -> FormatLetDecl mode -> mode { parResultName :: String parResultName = "__outcome_" fmtDecl :: PP a => Bool -> FormatMode -> a -> PP_Doc fmtDecl declPure fmt decl = case fmt of FormatLetDecl -> pp decl FormatLetLine -> "let" >#< decl >#< "in" FormatDo | declPure -> "let" >#< decl | otherwise -> pp decl } -- -- Some properties of VisitStep(s) -- -- 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 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 @name >|< "_around" else empty loc.introcode = \kind fmtMode -> let pat = text $ stname @name @loc.initSt patStrict = @loc.addbang pat attach = "attach_T_" >|< @loc.nt >#< pp_parens (@loc.aroundcode >#< @loc.valcode) runAttach = unMon @lhs.options >#< pp_parens attach decl = case kind of VisitPure False -> pat >#< "=" >#< runAttach VisitPure True -> patStrict >#< "=" >#< runAttach VisitMonadic -> patStrict >#< "<-" >#< attach in if compatibleAttach kind @loc.nt @lhs.options then Right ( fmtDecl False fmtMode decl , Set.singleton (stname @name @loc.initSt) -- variables defined by the child intro , case @kind of -- variables used by the child introduction ChildAttr -> Map.insert (instname @name) Nothing $ -- the sem attr ( if @loc.isDefor || not (lateHigherOrderBinding @lhs.options) then id -- the sem dictionary attr is not used else Map.insert (lhsname True idLateBindingAttr) (Just $ AttrInh _LHS idLateBindingAttr) ) $ ( if @hasAround then Map.insert (locname (@name) ++ "_around") Nothing else id ) $ Map.empty ChildReplace _ -> Map.singleton (instname @name) Nothing -- uses the transformation function ChildSyntax -> Map.empty ) else Left $ IncompatibleAttachKind @name kind loc.nt = extractNonterminal @tp { stname :: Identifier -> Int -> String stname child st = "_" ++ getName child ++ "X" ++ show st -- should actually return some conversion info compatibleAttach :: VisitKind -> NontermIdent -> Options -> Bool compatibleAttach _ _ _ = True unMon :: Options -> PP_Doc unMon options | parallelInvoke options = text "System.IO.Unsafe.unsafePerformIO" -- IO monad | otherwise = text "Control.Monad.Identity.runIdentity" -- identity monad } -- rules ATTR ERules ERule [ | | sem_rules USE {>-<} {empty} : {PP_Doc} mrules USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)} ] SEM ERule | ERule lhs.sem_rules = if @loc.used == 0 then empty else @loc.rulePragma >-< @loc.rulecode loc.rulecode = ( if @loc.genpragma then @loc.pragma -- this additional pragma *may* help to give some AG source location in the presence of -- type errors in the rule. It will definitely not be precise, and may take some additional -- source space, but let's see if it's worth it in practice. else empty ) >-< @loc.lambda >#< @loc.scc >-< indent ((column @rhs.pos - 2) `max` 2) ( if @loc.genpragma then @loc.pragma >-< @rhs.semfunc >-< @loc.endpragma else @rhs.semfunc ) loc.rulePragma = ( let reallyInlineStr = "INLINE" reallyNoInlineStr = "NOINLINE" in if noInlinePragmas @lhs.options then empty else if @loc.used == 1 then ppPragmaBinding reallyInlineStr @name -- always inline if used exactly once else if helpInlining @lhs.options then if not @explicit && @loc.used <= reallyOftenUsedThreshold then ppPragmaBinding "INLINE[1]" @name -- inline if copy rule else if @loc.used > ruleInlineThresholdSoft && @explicit -- noinline if it passes the threshold and is not a copy rule then if @loc.used > ruleInlineThresholdHard then ppPragmaBinding reallyNoInlineStr @name -- used too often: force ghc not to inline it else if aggressiveInlinePragmas @lhs.options then ppPragmaBinding "NOINLINE[2]" @name -- allow inlining but only late in the process else ppNoInline @name else if aggressiveInlinePragmas @lhs.options then ppPragmaBinding "NOINLINE[1]" @name -- otherwise, let GHC decide (but do other inlining first) else ppNoInline @name else if not @explicit || @loc.used <= ruleInlineThresholdSoft then ppPragmaBinding "NOINLINE[1]" @name -- otherwise, let GHC decide (but do other inlining first) else ppNoInline @name ) loc.scc = if genCostCentres @lhs.options && @explicit && @pure && not (noPerRuleCostCentres @lhs.options) then ppCostCentre (@name >|< "_" >|< line @rhs.pos >|< "_" >|< @lhs.nt >|< "_" >|< @lhs.con) else empty loc.pragma = "{-# LINE" >#< show (line @rhs.pos) >#< show (file @rhs.pos) >#< "#-}" loc.endpragma = ppWithLineNr (\ln -> "{-# LINE " ++ show (ln+1) ++ " " ++ show @lhs.mainFile ++ "#-}") loc.genpragma = genLinePragmas @lhs.options && @explicit && @loc.haspos loc.haspos = line @rhs.pos > 0 && column @rhs.pos >= 0 && not (null (file @rhs.pos)) -- we generate a simple pattern binding because of overloading-resolving during the type inference process. -- The types of the rules are not generalized (nor do we want that - rules are used in a single typing-context). -- If overloading is resolved separately, it may not be clear which dictionaries to use. For that all rules have -- to be considered together, which is done when we use simple pattern bindings with a lambda expression instead -- of a function definition. -- Note: we also ensure that all rules are lambda expressions, so that they are not made part of any closures -- but are lambda-lifted instead. loc.lambda = @name >#< "=" >#< "\\" >#< @loc.argPats >#< dummyPat @lhs.options (Map.null @rhs.attrs) >#< "->" loc.argPats = ppSpaced [ let match | str `Set.member` @lhs.lazyIntras = pp str | otherwise = @loc.addbang1 (pp str) in case mbAttr of Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) -> case Map.lookup nm @lhs.localAttrTypes of Just tp -> pp_parens (pp_parens match >#< "::" >#< ppTp tp) Nothing -> match Just attr | not (noPerRuleTypeSigs @lhs.options) -> case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @lhs.childTypes of Just tpDoc -> pp_parens (pp_parens match >#< "::" >#< tpDoc) Nothing -> match _ -> match | (str,mbAttr) <- Map.assocs @rhs.attrs ] loc.argExprs = ppSpaced [ 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 False @field @attr loc.patExpr = if @pat.isUnderscore then @loc.varPat else @loc.varPat >|< "@" >|< @pat.sem_lhs lhs.sem_lhs = @loc.addbang1 @loc.patExpr | Product lhs.sem_lhs = @loc.addbang1 $ pp_block "(" ")" "," @pats.sem_lhs | Constr lhs.sem_lhs = @loc.addbang1 $ pp_parens $ @name >#< hv_sp @pats.sem_lhs | Underscore lhs.sem_lhs = text "_" | Irrefutable lhs.sem_lhs = text "~" >|< pp_parens @pat.sem_lhs -- Check if a pattern is just an underscore ATTR Pattern [ | | isUnderscore:{Bool}] SEM Pattern | Constr lhs.isUnderscore = False | Product lhs.isUnderscore = False | Alias lhs.isUnderscore = False | Underscore lhs.isUnderscore = True -- Collect the attributes defined by a pattern ATTR Pattern Patterns [ | | attrs USE {`Set.union`} {Set.empty} : {Set String} ] SEM Pattern | Alias lhs.attrs = Set.insert (attrname False @field @attr) @pat.attrs -- 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 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 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) Inh_HsToken)) @tks lhs.semfunc = vlist $ showTokens $ map (\tok -> tok_Syn_HsToken (wrap_HsToken (sem_HsToken tok) Inh_HsToken)) @tks -- child visit map ATTR Visit Visits EProduction EProductions ENonterminal ENonterminals [ allchildvisit : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} | | childvisit USE {`Map.union`} {Map.empty} : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} ] ATTR VisitSteps VisitStep [ allchildvisit : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} | | ] SEM ExecutionPlan | ExecutionPlan nonts.allchildvisit = @nonts.childvisit SEM Visit | Visit loc.prevVisitInfo = Map.findWithDefault ManyVis @from @lhs.nextVisits lhs.childvisit = Map.singleton @ident @loc.invokecode loc.invokecode = \chn kind -> -- "chn" is the name of the child at the place of invocation, and "kind" the kind of the calling visit if kind `compatibleKind` @kind then Right $ let pat | isLazyKind @kind = pat0 | otherwise = @loc.addbang pat0 pat0 = pp_parens pat1 pat1 = @loc.nameTOut_visit >#< (ppSpaced $ map (attrname True chn) $ Set.toList @syn) >#< cont cont = case @loc.nextVisitInfo of NoneVis -> empty _ -> ch1 ch0 = text $ stname chn @from ch1 = text $ stname chn @to expr = case (kind, @kind) of (VisitPure _, VisitPure _) -> expr0 (VisitPure _, VisitMonadic) -> unMon @lhs.options >#< expr0 (VisitMonadic, VisitPure _) -> "return" >#< expr0 (VisitMonadic, VisitMonadic) -> expr0 expr0 = case @loc.prevVisitInfo of NoneVis -> error "error: invocation of a visit from a state that has no next visits" OneVis _ -> "inv_" >|< @lhs.nt >|< "_s" >|< @from >#< ch0 >#< args ManyVis -> "inv_" >|< @lhs.nt >|< "_s" >|< @from >#< ch0 >#< "K_" >|< @lhs.nt >|< "_v" >|< @ident >#< args args = pp_parens args0 >#< args1 args0 = @loc.nameTIn_visit >#< @loc.inhargs chn args1 | dummyTokenVisit @lhs.options = pp $ dummyArg @lhs.options True | otherwise = empty in (pat, expr) -- pretty print of the pattern and the expression part else Left $ IncompatibleVisitKind chn @ident kind @kind { -- a `compatibleKind` b means: can kind b be invoked from a compatibleKind :: VisitKind -> VisitKind -> Bool compatibleKind _ _ = True compatibleRule :: VisitKind -> Bool -> Bool compatibleRule (VisitPure _) False = False compatibleRule _ _ = True } ------------------------------------------------------------------------------- -- Properties of rules ------------------------------------------------------------------------------- -- Construct an environment that counts how often certain rules are used ATTR Visits Visit VisitSteps VisitStep [ | | ruleUsage USE {`unionWithSum`} {Map.empty} : {Map Identifier Int} ] ATTR ERules ERule [ usageInfo : {Map Identifier Int} | | ] SEM EProduction | EProduction rules.usageInfo = @visits.ruleUsage SEM VisitStep | Sem lhs.ruleUsage = Map.singleton @name 1 SEM ERule | ERule loc.used = Map.findWithDefault 0 @name @lhs.usageInfo { unionWithSum = Map.unionWith (+) } -- Collect in what visit-kinds a rule is used ATTR Visits Visit VisitSteps VisitStep [ | | ruleKinds USE {`unionWithMappend`} {Map.empty} : {Map Identifier (Set VisitKind)} ] SEM VisitStep | Sem lhs.ruleKinds = Map.singleton @name (Set.singleton @lhs.kind) ATTR ERules ERule [ ruleKinds : {Map Identifier (Set VisitKind)} | | ] SEM EProduction | EProduction rules.ruleKinds = @visits.ruleKinds SEM ERule | ERule loc.kinds = Map.findWithDefault Set.empty @name @lhs.ruleKinds loc.anyLazyKind = Set.fold (\k r -> isLazyKind k || r) False @loc.kinds ATTR Pattern Patterns [ anyLazyKind : Bool | | ] ------------------------------------------------------------------------------- -- Intra attributes ------------------------------------------------------------------------------- { uwSetUnion :: (Ord a, Ord b) => Map a (Set b) -> Map a (Set b) -> Map a (Set b) uwSetUnion = Map.unionWith Set.union uwMapUnion :: (Ord a, Ord b) => Map a (Map b c) -> Map a (Map b c) -> Map a (Map b c) uwMapUnion = Map.unionWith Map.union } ATTR Visit Visits [ allintramap : {Map StateIdentifier (Map String (Maybe NonLocalAttr))} | | intramap USE {`uwMapUnion`} {Map.empty} : {Map StateIdentifier (Map String (Maybe NonLocalAttr))} ] ATTR Visit Visits [ terminaldefs : {Set String} | | ] ATTR EChild EChildren [ | | terminaldefs USE {`Set.union`} {Set.empty} : {Set String} ] SEM EChild | ETerm lhs.terminaldefs = Set.singleton $ 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 False i, Just (AttrSyn _LHS i)) | i <- Set.elems @syn ] in mp1 `Map.union` mp2 loc.inhVarNms = Set.map (lhsname True) @inh loc.defs = @steps.defs `Set.union` @loc.inhVarNms `Set.union` @lhs.terminaldefs loc.defsAsMap = Map.fromList [ (a, Nothing) | a <- Set.elems @loc.defs ] ATTR ERule ERules [ | | ruledefs USE {`uwSetUnion`} {Map.empty} : {Map Identifier (Set String)} ruleuses USE {`uwMapUnion`} {Map.empty} : {Map Identifier (Map String (Maybe NonLocalAttr))} ] ATTR Visit Visits VisitSteps VisitStep [ ruledefs : {Map Identifier (Set String)} ruleuses : {Map Identifier (Map String (Maybe NonLocalAttr))} | | ] SEM ERule | ERule lhs.ruledefs = Map.singleton @name @pattern.attrs lhs.ruleuses = Map.singleton @name @rhs.attrs SEM EProduction | EProduction visits.ruledefs = @rules.ruledefs visits.ruleuses = @rules.ruleuses ATTR Visit Visits EProduction EProductions ENonterminal ENonterminals [ | | visitdefs USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (Set Identifier)} visituses USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (Set Identifier)} ] SEM Visit | Visit lhs.visitdefs = Map.singleton @ident @syn lhs.visituses = Map.singleton @ident @inh ATTR Visit Visits VisitSteps VisitStep EProduction EProductions ENonterminal ENonterminals [ avisitdefs : {Map VisitIdentifier (Set Identifier)} avisituses : {Map VisitIdentifier (Set Identifier)} | | ] SEM ExecutionPlan | ExecutionPlan nonts.avisitdefs = @nonts.visitdefs nonts.avisituses = @nonts.visituses ATTR VisitSteps VisitStep [ | | defs USE {`Set.union`} {Set.empty} : {Set String} uses USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ] SEM VisitStep | Sem lhs.defs = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruledefs lhs.uses = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruleuses | ChildVisit lhs.defs = Set.insert (stname @child @to) $ maybe (error "Visit not found") (Set.map $ attrname True @child) $ Map.lookup @visit @lhs.avisitdefs lhs.uses = let convert attrs = Map.fromList [ (attrname False @child attr, Just $ mkNonLocalAttr True @child attr) | attr <- Set.elems attrs ] in Map.insert (stname @child @from) Nothing $ convert $ maybe (error "Visit not found") id $ Map.lookup @visit @lhs.avisituses ------------------------------------------------------------------------------- -- Identification of lazy intra defs within a production -- -- These identifiers will not be marked as strict in rules and state closures ------------------------------------------------------------------------------- ATTR Visits Visit VisitSteps VisitStep [ | | lazyIntras USE {`Set.union`} {Set.empty} : {Set String} ] ATTR ERules ERule [ lazyIntras : {Set String} | | ] SEM Visit | Visit loc.lazyIntrasInh = case @kind of VisitPure False -> @loc.inhVarNms `Set.union` @steps.defs _ -> Set.empty lhs.lazyIntras = @loc.lazyIntrasInh `Set.union` @steps.lazyIntras SEM VisitStep | PureGroup lhs.lazyIntras = if @ordered then @steps.lazyIntras else @steps.defs SEM EProduction | EProduction loc.lazyIntras = @visits.lazyIntras ------------------------------------------------------------------------------- -- Pretty printing of haskell code ------------------------------------------------------------------------------- SEM HsTokens [ || tks : {[(Pos,String)]} ] | Cons lhs.tks = @hd.tok : @tl.tks | Nil lhs.tks = [] SEM HsToken | AGLocal loc.tok = (@pos,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 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 ] } uuagc-0.9.42.3/src-ag/Expression.ag000644 000765 000024 00000000250 12127045231 020667 0ustar00jeroenbransenstaff000000 000000 imports { import UU.Scanner.Position(Pos) import HsToken } DATA Expression | Expression pos:{Pos} tks:{[HsToken]} SET AllExpression = Expression uuagc-0.9.42.3/src-ag/GenerateCode.ag000644 000765 000024 00000172157 12127045231 021075 0ustar00jeroenbransenstaff000000 000000 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 : 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 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 $ nontermArgs tp, not (null tps) ] { -- remove possible @v references in the types of a data type. cleanupArg :: String -> String cleanupArg s = case idEvalType (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 True _INST inst instSemFieldName = attrname 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 False fld nm | (fld,nm,_) <- Map.elems @defines]) (Set.fromList [attrname 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 True @name) (Map.keys @syn) ++ if @isLast then [] else [unwrap ++ funname @name (@nr+1)] rhsVars = map (attrname False @name) (Map.keys @inh) unwrap = if @lhs.o_newtypes then typeName @nt (@nr + 1) ++ " " else "" tuple | isMerging = TupleLhs [locname @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 @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 True c) (Map.keys @syn) ++ if @isLast then [] else [unwrap ++ funname c (@nr+1)] rhsVars' = [ locname c' ++ "_comp" | c' <- cs ] fun' = locname 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 @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 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 tp else evalType replace tp | CChildVisit loc.mkTp = @loc.evalTp . typeToCodeType (Just @nt) @loc.orgParams loc.definedTps = [ TSig (attrname True @name a) (@mkTp tp) | (a,tp) <- Map.toList @syn ] loc.nextTp = typeName @nt (@nr+1) lhs.tSigs = (if @isLast then id else (TSig (funname @name (@nr+1)) (TypeApp (SimpleType @nextTp) (map SimpleType @loc.instParams)) :)) @definedTps 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 @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 False _LHS a) | (a,_) <- synAttrs ] rhs = App synNT synVars lhs = Fun "___node" [] in [Decl lhs rhs Set.empty Set.empty] else [] loc.decls = @typeSigs ++ @vss.decls ++ @nextVisitDecl ++ @loc.refDecls vss.lastExpr = mkTupleExpr @lhs.o_unbox (null $ Map.keys @inh) $ map (SimpleExpr . lhsname False) (Map.keys @syn) ++ map SimpleExpr @nextVisitName intra.lastExpr = error "lastExpr: not used here" loc.lastExprVars = map (lhsname False) (Map.keys @syn) ++ @loc.nextVisitName (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 $ typeToCodeType (Just @lhs.nt) @loc.params $ removeDeforested tp) mbEvalTp | null @loc.params = const Nothing | otherwise = Just . idEvalType rhs = wrap . mkSemFun @lhs.nt @lhs.nr [mkLambdaArg (lhsname True nm) (mbEvalTp $ typeToCodeType (Just @lhs.nt) @loc.params $ 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 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 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 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 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 :: (String -> String) -> Code.Type -> Code.Type evalType 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 (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) _ -> t replaceTok t = case t of AGLocal v p _ -> HsToken (replf $ getName v) p _ -> t idEvalType :: Code.Type -> Code.Type idEvalType = evalType id } ------------------------------------------------------------------------------- -- Wrapper functions ------------------------------------------------------------------------------- SEM CNonterminal | CNonterminal loc.semWrapper = let params' = map getName @params inhAttrs = Map.toList @inh synAttrs = Map.toList @syn inhVars = [ SimpleExpr (attrname True _LHS a) | (a,_) <- inhAttrs ] synVars = [ SimpleExpr (attrname 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 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 False) (Map.keys @syn) ++ if @lhs.isLast then [] else [unwrap ++ sem (@lhs.nr+1)] rhsVars = map (lhsname 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 ] tp' -> error $ show tp' ++ " not supported" in Code.Type (getName @nt) params' (idEvalType 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 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] _ -> error "TODO" 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 $ 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 nm)] argument (nm, _,_) = SimpleExpr (locname 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] uuagc-0.9.42.3/src-ag/HsToken.ag000644 000765 000024 00000001615 12127045231 020111 0ustar00jeroenbransenstaff000000 000000 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 uuagc-0.9.42.3/src-ag/Interfaces.ag000644 000765 000024 00000000604 12127045231 020616 0ustar00jeroenbransenstaff000000 000000 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]} uuagc-0.9.42.3/src-ag/InterfacesRules.lag000644 000765 000024 00000040714 12127045231 022013 0ustar00jeroenbransenstaff000000 000000 \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} uuagc-0.9.42.3/src-ag/KWOrder.ag000644 000765 000024 00000042421 12127045231 020053 0ustar00jeroenbransenstaff000000 000000 INCLUDE "AbstractSyntax.ag" INCLUDE "HsToken.ag" INCLUDE "Expression.ag" INCLUDE "Patterns.ag" INCLUDE "DistChildAttr.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) } ------------------------------------------------------------------------------- -- Distributing options ------------------------------------------------------------------------------- ATTR Grammar Nonterminals Nonterminal Productions Production Children Child [ options : {Options} | | ] ------------------------------------------------------------------------------- -- Give unique names to rules ------------------------------------------------------------------------------- ATTR Nonterminal Nonterminals Production Productions Rule Rules [ | rulenumber : Int | ] SEM Grammar | Grammar nonts.rulenumber = 0 SEM Rule | Rule lhs.rulenumber = @lhs.rulenumber + 1 loc.rulename = maybe (identifier $ "rule" ++ show @lhs.rulenumber) id @mbName ------------------------------------------------------------------------------- -- Find out which nonterminals are recursive ------------------------------------------------------------------------------- ATTR Nonterminals Nonterminal [ | | ntDeps, ntHoDeps USE {`mappend`} {mempty} : {Map NontermIdent (Set NontermIdent)} ] ATTR Nonterminals Nonterminal [ closedNtDeps, closedHoNtDeps, closedHoNtRevDeps : {Map NontermIdent (Set NontermIdent)} | | ] ATTR Productions Production Children Child [ | | refNts, refHoNts USE {`mappend`} {mempty} : {Set NontermIdent} ] SEM Nonterminal | Nonterminal lhs.ntDeps = Map.singleton @nt @prods.refNts lhs.ntHoDeps = Map.singleton @nt @prods.refHoNts loc.closedNtDeps = Map.findWithDefault Set.empty @nt @lhs.closedNtDeps loc.closedHoNtDeps = Map.findWithDefault Set.empty @nt @lhs.closedHoNtDeps loc.closedHoNtRevDeps = Map.findWithDefault Set.empty @nt @lhs.closedHoNtRevDeps loc.recursive = @nt `Set.member` @loc.closedNtDeps loc.nontrivAcyc = @nt `Set.member` @loc.closedHoNtDeps loc.hoInfo = HigherOrderInfo { hoNtDeps = @loc.closedHoNtDeps , hoNtRevDeps = @loc.closedHoNtRevDeps , hoAcyclic = @loc.nontrivAcyc } SEM Child | Child loc.refNts = case @tp of NT nt _ _ -> Set.singleton nt _ -> mempty loc.refHoNts = if @loc.isHigherOrder then @loc.refNts else mempty loc.isHigherOrder = case @kind of ChildSyntax -> False _ -> True SEM Grammar | Grammar loc.closedNtDeps = closeMap @nonts.ntDeps loc.closedHoNtDeps = closeMap @nonts.ntHoDeps loc.closedHoNtRevDeps = revDeps @loc.closedHoNtDeps ------------------------------------------------------------------------------- -- Determine which children have an around-rule ------------------------------------------------------------------------------- -- Propagate the around-map downward ATTR Nonterminals Nonterminal [ aroundMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} || ] ATTR Productions Production [ aroundMap : {Map ConstructorIdent (Map Identifier [Expression])} || ] ATTR Children Child [ aroundMap : {Map Identifier [Expression]} | | ] SEM Nonterminal | Nonterminal loc.aroundMap = Map.findWithDefault Map.empty @nt @lhs.aroundMap SEM Production | Production loc.aroundMap = Map.findWithDefault Map.empty @con @lhs.aroundMap SEM Grammar | Grammar nonts.aroundMap = @aroundsMap SEM Child | Child loc.hasArounds = case Map.lookup @name @lhs.aroundMap of Nothing -> False Just as -> not (null as) ------------------------------------------------------------------------------- -- Determine which children are used by merges ------------------------------------------------------------------------------- -- Propagate the around-map downward ATTR Nonterminals Nonterminal [ mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression)))} || ] ATTR Productions Production [ mergeMap : {Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression))} || ] ATTR Children Child [ mergeMap : {Map Identifier (Identifier, [Identifier], Expression)} mergedChildren : {Set Identifier} | | ] SEM Nonterminal | Nonterminal loc.mergeMap = Map.findWithDefault Map.empty @nt @lhs.mergeMap SEM Production | Production loc.mergeMap = Map.findWithDefault Map.empty @con @lhs.mergeMap SEM Grammar | Grammar nonts.mergeMap = @mergeMap SEM Production | Production loc.mergedChildren = Set.unions [ Set.fromList ms | (_,ms,_) <- Map.elems @loc.mergeMap ] SEM Child | Child loc.merges = maybe Nothing (\(_,ms,_) -> Just ms) $ Map.lookup @name @lhs.mergeMap loc.isMerged = @name `Set.member` @lhs.mergedChildren ------------------------------------------------------------------------------- -- Distribute the ContextMap to nonterminals ------------------------------------------------------------------------------- ATTR Nonterminals Nonterminal [ classContexts : ContextMap | | ] SEM Grammar | Grammar nonts.classContexts = @contextMap SEM Nonterminal | Nonterminal loc.classContexts = Map.findWithDefault [] @nt @lhs.classContexts ------------------------------------------------------------------------------- -- Gather all rules per production for the execution plan ------------------------------------------------------------------------------- ATTR Expression [ | | copy : SELF ] ATTR Rule [ | | erules : ERule ] ATTR Rules [ | | erules USE {:} {[]} : ERules ] SEM Rule | Rule lhs.erules = ERule @loc.rulename @pattern.copy @rhs.copy @owrt @origin @explicit @pure @mbError ------------------------------------------------------------------------------- -- Gather all childs per production for the execution plan ------------------------------------------------------------------------------- ATTR Child [ | | echilds : EChild ] ATTR Children [ | | echilds USE {:} {[]} : EChildren ] SEM Child | Child lhs.echilds = case @tp of NT _ _ _ -> EChild @name @tp @kind @loc.hasArounds @loc.merges @loc.isMerged _ -> ETerm @name @tp ------------------------------------------------------------------------------- -- 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) ------------------------------------------------------------------------------- -- Output nonterminal type mappings ------------------------------------------------------------------------------- ATTR Grammar Nonterminals [ | | inhmap USE {`Map.union`} {Map.empty} : {Map.Map NontermIdent Attributes} synmap USE {`Map.union`} {Map.empty} : {Map.Map NontermIdent Attributes} ] ATTR Nonterminal [ | | inhmap : {Map.Map NontermIdent Attributes} synmap : {Map.Map NontermIdent Attributes} ] SEM Nonterminal | Nonterminal lhs.inhmap = Map.singleton @nt @inh lhs.synmap = Map.singleton @nt @syn ------------------------------------------------------------------------------- -- Output nonterminal type mappings ------------------------------------------------------------------------------- ATTR Grammar Nonterminals Nonterminal [ | | localSigMap USE {`Map.union`} {Map.empty} : {Map.Map NontermIdent (Map.Map ConstructorIdent (Map.Map Identifier Type))} ] ATTR Productions Production [ | | localSigMap USE {`Map.union`} {Map.empty} : {Map.Map ConstructorIdent (Map.Map Identifier Type)} ] ATTR TypeSigs TypeSig [ | | localSigMap USE {`Map.union`} {Map.empty} : {Map Identifier Type} ] SEM Nonterminal | Nonterminal lhs.localSigMap = Map.singleton @nt @prods.localSigMap SEM Production | Production lhs.localSigMap = Map.singleton @con @typeSigs.localSigMap SEM TypeSig | TypeSig lhs.localSigMap = Map.singleton @name @tp uuagc-0.9.42.3/src-ag/Macro.ag000644 000765 000024 00000001172 12127045231 017575 0ustar00jeroenbransenstaff000000 000000 --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 uuagc-0.9.42.3/src-ag/Order.ag000644 000765 000024 00000110441 12127045231 017607 0ustar00jeroenbransenstaff000000 000000 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 HsTokenScanner(lexTokens) 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 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)]} || 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 } 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 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) } uuagc-0.9.42.3/src-ag/Patterns.ag000644 000765 000024 00000001244 12127045231 020334 0ustar00jeroenbransenstaff000000 000000 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 uuagc-0.9.42.3/src-ag/PrintCode.ag000644 000765 000024 00000051207 12127045231 020427 0ustar00jeroenbransenstaff000000 000000 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" >#< @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 { 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 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 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 } uuagc-0.9.42.3/src-ag/PrintErrorMessages.ag000644 000765 000024 00000125625 12127045231 022344 0ustar00jeroenbransenstaff000000 000000 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 "") >#< "= ...") 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 >#< ". = " >#< "..." >#< "@" >|< 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 >#< ". = " >#< "..." >#< 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." >#< "...") 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 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] } uuagc-0.9.42.3/src-ag/PrintOcamlCode.ag000644 000765 000024 00000016777 12127045231 021420 0ustar00jeroenbransenstaff000000 000000 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" { 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 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 uuagc-0.9.42.3/src-ag/PrintVisitCode.ag000644 000765 000024 00000002050 12127045231 021436 0ustar00jeroenbransenstaff000000 000000 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 = [] uuagc-0.9.42.3/src-ag/ResolveLocals.ag000644 000765 000024 00000013175 12127045231 021317 0ustar00jeroenbransenstaff000000 000000 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 HsTokenScanner(lexTokens) 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 } synthesized = wrap_HsTokensRoot (sem_HsTokensRoot (HsTokensRoot @tks)) inherited in (errors_Syn_HsTokensRoot synthesized, output_Syn_HsTokensRoot synthesized) lhs.output = Expression @pos @loc.newTksuuagc-0.9.42.3/src-ag/SemHsTokens.ag000644 000765 000024 00000013055 12127045231 020742 0ustar00jeroenbransenstaff000000 000000 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)]} || ] 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 @var), [@var]) else (Seq.singleton(UndefLocal @lhs.nt @lhs.con @var), @loc.tkAsField, (@pos,locname @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 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 ] uuagc-0.9.42.3/src-ag/TfmToVisage.ag000644 000765 000024 00000011127 12127045231 020725 0ustar00jeroenbransenstaff000000 000000 -- !!!! 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)] uuagc-0.9.42.3/src-ag/Transform.ag000644 000765 000024 00000207635 12127045231 020523 0ustar00jeroenbransenstaff000000 000000 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 "") 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 = [ ] 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 = [ ] is translated into: DATA | Cons hd: tl: | 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 } "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 } "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 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 [ | | 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) uuagc-0.9.42.3/src-ag/Visage.ag000644 000765 000024 00000010617 12127045231 017756 0ustar00jeroenbransenstaff000000 000000 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))]] uuagc-0.9.42.3/src-ag/VisagePatterns.ag000644 000765 000024 00000001256 12127045231 021476 0ustar00jeroenbransenstaff000000 000000 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} uuagc-0.9.42.3/src-ag/VisageSyntax.ag000644 000765 000024 00000002644 12127045231 021166 0ustar00jeroenbransenstaff000000 000000 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} uuagc-0.9.42.3/src/Ag.hs000644 000765 000024 00000072722 12127045231 016532 0ustar00jeroenbransenstaff000000 000000 -- Todo: we should make a nicer pipeline. Perhaps use Atze's "compile run" combinators. module Ag (uuagcLib, uuagcExe,compile) where import System.Environment (getArgs, getProgName) import System.Console.GetOpt (usageInfo) import Data.List (partition) import Control.Monad (zipWithM_) import Data.Maybe import System.FilePath import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.Sequence as Seq ((><),null) import Data.Foldable(toList) import Pretty import PPUtil import UU.Parsing (Message(..), Action(..)) import UU.Scanner.Position (Pos, line, file) import UU.Scanner.Token (Token) import qualified Transform as Pass1 (sem_AG , wrap_AG , Syn_AG (..), Inh_AG (..)) import qualified Desugar as Pass1a (sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) import qualified DefaultRules as Pass2 (sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) import qualified ResolveLocals as Pass2a (sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) import qualified Order as Pass3 (sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) import qualified KWOrder as Pass3a (sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) import qualified GenerateCode as Pass4 (sem_CGrammar, wrap_CGrammar, Syn_CGrammar(..), Inh_CGrammar(..)) import qualified PrintVisitCode as Pass4a (sem_CGrammar, wrap_CGrammar, Syn_CGrammar(..), Inh_CGrammar(..)) import qualified ExecutionPlan2Hs as Pass4b (sem_ExecutionPlan, wrap_ExecutionPlan, Syn_ExecutionPlan(..), Inh_ExecutionPlan(..), warrenFlagsPP) import qualified ExecutionPlan2Caml as Pass4c (sem_ExecutionPlan, wrap_ExecutionPlan, Syn_ExecutionPlan(..), Inh_ExecutionPlan(..)) import qualified PrintCode as Pass5 (sem_Program, wrap_Program, Syn_Program (..), Inh_Program (..)) import qualified PrintOcamlCode as Pass5a (sem_Program, wrap_Program, Syn_Program (..), Inh_Program (..)) import qualified PrintErrorMessages as PrErr (sem_Errors , wrap_Errors , Syn_Errors (..), Inh_Errors (..), isError) import qualified TfmToVisage as PassV (sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) import qualified AbstractSyntaxDump as GrammarDump (sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) import qualified CodeSyntaxDump as CGrammarDump (sem_CGrammar, wrap_CGrammar, Syn_CGrammar (..), Inh_CGrammar (..)) import qualified Visage as VisageDump (sem_VisageGrammar, wrap_VisageGrammar, Syn_VisageGrammar(..), Inh_VisageGrammar(..)) import qualified AG2AspectAG as AspectAGDump (pragmaAspectAG, sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) --marcos import Options import Version (banner) import Parser (parseAG, depsAG, parseAGI) import ErrorMessages (Error(ParserError)) import CommonTypes import ATermWrite -- Library version import System.Exit (ExitCode(..), exitWith) uuagcLib :: [String] -> FilePath -> IO (ExitCode, [FilePath]) uuagcLib args fileP = do let (flags,_,errs) = getOptions args if showVersion flags || showHelp flags then do putStrLn "Cannot display help or version in library mode." return (ExitFailure 1, []) else if (not.null) errs then do putStrLn "One or more errors occured:" mapM_ putStrLn errs return (ExitFailure 2, []) else if genFileDeps flags then do deps <- getDeps flags [fileP] return (ExitSuccess, deps) else do compile flags fileP (head $ outputFiles flags++repeat "") return (ExitSuccess, []) -- Executable version uuagcExe :: IO () uuagcExe = do args <- getArgs progName <- getProgName let usageheader = "Usage info:\n " ++ progName ++ " options file ...\n\nList of options:" (flags,files,errs) = getOptions args if showVersion flags then putStrLn banner else if showHelp flags then putStrLn (usageInfo usageheader options) else if null files || (not.null) errs then do mapM_ putStrLn (usageInfo usageheader options : errs) exitWith (ExitFailure 2) else if genFileDeps flags then reportDeps flags files else zipWithM_ (compile flags) files (outputFiles flags++repeat "") compile :: Options -> FilePath -> FilePath -> IO () compile flags input output = do (output0,parseErrors) <- parseAG flags (searchPath flags) input irrefutableMap <- readIrrefutableMap flags let printStr = outputStr flags failWith = failWithCode flags inputfile = maybe input id (mainFilename flags) let output1 = Pass1.wrap_AG (Pass1.sem_AG output0 ) Pass1.Inh_AG {Pass1.options_Inh_AG = flags} flags' = condDisableOptimizations (Pass1.pragmas_Syn_AG output1 flags) grammar1 = Pass1.output_Syn_AG output1 output1a = Pass1a.wrap_Grammar (Pass1a.sem_Grammar grammar1 ) Pass1a.Inh_Grammar {Pass1a.options_Inh_Grammar = flags', Pass1a.forcedIrrefutables_Inh_Grammar = irrefutableMap, Pass1a.mainName_Inh_Grammar = mainName } grammar1a =Pass1a.output_Syn_Grammar output1a output2 = Pass2.wrap_Grammar (Pass2.sem_Grammar grammar1a ) Pass2.Inh_Grammar {Pass2.options_Inh_Grammar = flags'} grammar2 = Pass2.output_Syn_Grammar output2 outputV = PassV.wrap_Grammar (PassV.sem_Grammar grammar2 ) PassV.Inh_Grammar {} grammarV = PassV.visage_Syn_Grammar outputV output2a = Pass2a.wrap_Grammar (Pass2a.sem_Grammar grammar2 ) Pass2a.Inh_Grammar {Pass2a.options_Inh_Grammar = flags'} grammar2a = Pass2a.output_Syn_Grammar output2a output3 = Pass3.wrap_Grammar (Pass3.sem_Grammar grammar2a ) Pass3.Inh_Grammar {Pass3.options_Inh_Grammar = flags'} grammar3 = Pass3.output_Syn_Grammar output3 output3a = Pass3a.wrap_Grammar (Pass3a.sem_Grammar grammar2a ) Pass3a.Inh_Grammar {Pass3a.options_Inh_Grammar = flags'} grammar3a = Pass3a.output_Syn_Grammar output3a output4 = Pass4.wrap_CGrammar (Pass4.sem_CGrammar(Pass3.output_Syn_Grammar output3)) Pass4.Inh_CGrammar {Pass4.options_Inh_CGrammar = flags'} output4a = Pass4a.wrap_CGrammar (Pass4a.sem_CGrammar(Pass3.output_Syn_Grammar output3)) Pass4a.Inh_CGrammar {Pass4a.options_Inh_CGrammar = flags'} output4b = Pass4b.wrap_ExecutionPlan (Pass4b.sem_ExecutionPlan grammar3a) Pass4b.Inh_ExecutionPlan {Pass4b.options_Inh_ExecutionPlan = flags', Pass4b.inhmap_Inh_ExecutionPlan = Pass3a.inhmap_Syn_Grammar output3a, Pass4b.synmap_Inh_ExecutionPlan = Pass3a.synmap_Syn_Grammar output3a, Pass4b.pragmaBlocks_Inh_ExecutionPlan = pragmaBlocksTxt, Pass4b.importBlocks_Inh_ExecutionPlan = importBlocksTxt, Pass4b.textBlocks_Inh_ExecutionPlan = textBlocksDoc, Pass4b.moduleHeader_Inh_ExecutionPlan = mkModuleHeader $ Pass1.moduleDecl_Syn_AG output1, Pass4b.mainName_Inh_ExecutionPlan = mkMainName mainName $ Pass1.moduleDecl_Syn_AG output1, Pass4b.mainFile_Inh_ExecutionPlan = mainFile, Pass4b.textBlockMap_Inh_ExecutionPlan = textBlockMap, Pass4b.mainBlocksDoc_Inh_ExecutionPlan = mainBlocksDoc,Pass4b.localAttrTypes_Inh_ExecutionPlan = Pass3a.localSigMap_Syn_Grammar output3a} output4c = Pass4c.wrap_ExecutionPlan (Pass4c.sem_ExecutionPlan grammar3a) Pass4c.Inh_ExecutionPlan {Pass4c.options_Inh_ExecutionPlan = flags', Pass4c.inhmap_Inh_ExecutionPlan = Pass3a.inhmap_Syn_Grammar output3a, Pass4c.synmap_Inh_ExecutionPlan = Pass3a.synmap_Syn_Grammar output3a, Pass4c.mainName_Inh_ExecutionPlan = mkMainName mainName $ Pass1.moduleDecl_Syn_AG output1, Pass4c.mainFile_Inh_ExecutionPlan = mainFile, Pass4c.localAttrTypes_Inh_ExecutionPlan = Pass3a.localSigMap_Syn_Grammar output3a} output5 = Pass5.wrap_Program (Pass5.sem_Program (Pass4.output_Syn_CGrammar output4)) Pass5.Inh_Program {Pass5.options_Inh_Program = flags', Pass5.pragmaBlocks_Inh_Program = pragmaBlocksTxt, Pass5.importBlocks_Inh_Program = importBlocksTxt, Pass5.textBlocks_Inh_Program = textBlocksDoc, Pass5.textBlockMap_Inh_Program = textBlockMap, Pass5.mainBlocksDoc_Inh_Program = mainBlocksDoc, Pass5.optionsLine_Inh_Program = optionsLine, Pass5.mainFile_Inh_Program = mainFile, Pass5.moduleHeader_Inh_Program = mkModuleHeader $ Pass1.moduleDecl_Syn_AG output1, Pass5.mainName_Inh_Program = mkMainName mainName $ Pass1.moduleDecl_Syn_AG output1} output5a = Pass5a.wrap_Program (Pass5a.sem_Program (Pass4.output_Syn_CGrammar output4)) Pass5a.Inh_Program { Pass5a.options_Inh_Program = flags', Pass5a.textBlockMap_Inh_Program = textBlockMap } output6 = PrErr.wrap_Errors (PrErr.sem_Errors errorsToReport) PrErr.Inh_Errors {PrErr.options_Inh_Errors = flags', PrErr.dups_Inh_Errors = [] } dump1 = GrammarDump.wrap_Grammar (GrammarDump.sem_Grammar grammar1 ) GrammarDump.Inh_Grammar dump2 = GrammarDump.wrap_Grammar (GrammarDump.sem_Grammar grammar2 ) GrammarDump.Inh_Grammar dump3 = CGrammarDump.wrap_CGrammar (CGrammarDump.sem_CGrammar grammar3 ) CGrammarDump.Inh_CGrammar outputVisage = VisageDump.wrap_VisageGrammar (VisageDump.sem_VisageGrammar grammarV) VisageDump.Inh_VisageGrammar aterm = VisageDump.aterm_Syn_VisageGrammar outputVisage parseErrorList = map message2error (parseErrors) mainErrors = toList ( Pass1.errors_Syn_AG output1 Seq.>< Pass1a.errors_Syn_Grammar output1a Seq.>< Pass2.errors_Syn_Grammar output2 Seq.>< Pass2a.errors_Syn_Grammar output2a) furtherErrors = if kennedyWarren flags' then let errs3a = Pass3a.errors_Syn_Grammar output3a in if Seq.null errs3a then if ocaml flags' then toList ( Pass4c.errors_Syn_ExecutionPlan output4c ) else toList ( Pass4b.errors_Syn_ExecutionPlan output4b ) else toList errs3a else toList ( Pass3.errors_Syn_Grammar output3 Seq.>< Pass4.errors_Syn_CGrammar output4) errorList = if null parseErrorList then mainErrors ++ if null (filter (PrErr.isError flags') mainErrors) then furtherErrors else [] else [head parseErrorList] fatalErrorList = filter (PrErr.isError flags') errorList allErrors = if wignore flags' then fatalErrorList else errorsToFront flags' errorList errorsToReport = take (wmaxerrs flags') allErrors errorsToStopOn = if werrors flags' then errorList else fatalErrorList blocks1 = (Pass1.blocks_Syn_AG output1) {-SM `Map.unionWith (++)` (Pass3.blocks_Syn_Grammar output3)-} (pragmaBlocks, blocks2) = Map.partitionWithKey (\(k, at) _->k==BlockPragma && at == Nothing) blocks1 (importBlocks, textBlocks) = Map.partitionWithKey (\(k, at) _->k==BlockImport && at == Nothing) blocks2 importBlocksTxt = vlist_sep "" . map addLocationPragma . concat . Map.elems $ importBlocks textBlocksDoc = vlist_sep "" . map addLocationPragma . Map.findWithDefault [] (BlockOther, Nothing) $ textBlocks mainBlocksDoc = vlist_sep "" . map addLocationPragma . Map.findWithDefault [] (BlockMain, Nothing) $ textBlocks dataBlocksDoc = vlist_sep "" . map addLocationPragma . Map.findWithDefault [] (BlockData, Nothing) $ textBlocks recBlocksDoc = vlist_sep "" . map addLocationPragma . Map.findWithDefault [] (BlockRec, Nothing) $ textBlocks pragmaBlocksTxt = unlines . concat . map fst . concat . Map.elems $ pragmaBlocks textBlockMap = Map.map (vlist_sep "" . map addLocationPragma) . Map.filterWithKey (\(_, at) _ -> at /= Nothing) $ textBlocks outputfile = if null output then outputFile flags' inputfile else output mainFile | null output = outputFile flags' inputfile | otherwise = output mainName = dropExtension $ takeFileName inputfile addLocationPragma :: ([String], Pos) -> PP_Doc addLocationPragma (strs, p) | genLinePragmas flags' = ppLinePragma flags' (line p) (file p) >-< vlist (map pp strs) >-< ppWithLineNr (\l -> ppLinePragma flags' (l+1) outputfile) | otherwise = vlist (map pp strs) optionsGHC = option (unbox flags') "-fglasgow-exts" ++ option (bangpats flags') "-XBangPatterns" option True s = [s] option False _ = [] optionsLine | null optionsGHC = "" | otherwise = "{-# OPTIONS_GHC " ++ unwords optionsGHC ++ " #-}" nrOfErrorsToReport = length $ filter (PrErr.isError flags') errorsToReport nrOfWarningsToReport = length $ filter (not.(PrErr.isError flags')) errorsToReport totalNrOfErrors = length $ filter (PrErr.isError flags') allErrors totalNrOfWarnings = length $ filter (not.(PrErr.isError flags')) allErrors additionalErrors = totalNrOfErrors - nrOfErrorsToReport additionalWarnings = totalNrOfWarnings - nrOfWarningsToReport pluralS n = if n == 1 then "" else "s" (outAgi, ext) <- --marcos if genAspectAG flags' then parseAGI flags (searchPath flags) (agiFile input) else return (undefined, undefined) let ext' = case ext of Nothing -> Nothing Just e -> Just (remAgi e) outAgi1 = Pass1.wrap_AG (Pass1.sem_AG outAgi ) Pass1.Inh_AG {Pass1.options_Inh_AG = flags'} agi = Pass1.agi_Syn_AG outAgi1 aspectAG = AspectAGDump.wrap_Grammar (AspectAGDump.sem_Grammar grammar2 ) AspectAGDump.Inh_Grammar { AspectAGDump.options_Inh_Grammar = flags' , AspectAGDump.agi_Inh_Grammar = agi , AspectAGDump.ext_Inh_Grammar = ext' } --marcos printStr . formatErrors $ PrErr.pp_Syn_Errors output6 if additionalErrors > 0 then printStr $ "\nPlus " ++ show additionalErrors ++ " more error" ++ pluralS additionalErrors ++ if additionalWarnings > 0 then " and " ++ show additionalWarnings ++ " more warning" ++ pluralS additionalWarnings ++ ".\n" else ".\n" else if additionalWarnings > 0 then printStr $ "\nPlus " ++ show additionalWarnings ++ " more warning" ++ pluralS additionalWarnings ++ ".\n" else return () if not (null errorsToStopOn) -- note: this may already run quite a part of the compilation... then failWith 1 else do if genvisage flags' then writeFile (outputfile++".visage") (writeATerm aterm) else return () if genAttributeList flags' then writeAttributeList (outputfile++".attrs") (Pass1a.allAttributes_Syn_Grammar output1a) else return () if sepSemMods flags' then do -- alternative module gen if kennedyWarren flags' then if ocaml flags' then error "sepsemmods is not implemented for the ocaml output generation" else Pass4b.genIO_Syn_ExecutionPlan output4b else Pass5.genIO_Syn_Program output5 if not (null errorsToStopOn) then failWith 1 else return () else do -- conventional module gen let doc | visitorsOutput flags' = vlist [ pp_braces importBlocksTxt , pp_braces textBlocksDoc , vlist $ Pass4a.output_Syn_CGrammar output4a ] -- marcos AspectAG gen | genAspectAG flags' = vlist [ AspectAGDump.pragmaAspectAG , pp optionsLine , pp pragmaBlocksTxt , pp $ take 70 ("-- UUAGC2AspectAG " ++ drop 50 banner ++ " (" ++ input) ++ ")" , pp $ if isNothing $ Pass1.moduleDecl_Syn_AG output1 then moduleHeader flags' mainName ext' else mkModuleHeader (Pass1.moduleDecl_Syn_AG output1) mainName "" "" False , pp importBlocksTxt , AspectAGDump.imp_Syn_Grammar aspectAG , pp "\n\n{-- AspectAG Code --}\n\n" , AspectAGDump.pp_Syn_Grammar aspectAG , dataBlocksDoc , mainBlocksDoc , textBlocksDoc , if dumpgrammar flags' then vlist [ pp "{- Dump of AGI" , pp (show agi) , pp "-}" , pp "{- Dump of grammar with default rules" , GrammarDump.pp_Syn_Grammar dump2 , pp "-}" ] else empty] | kennedyWarren flags' = if ocaml flags' then vlist [ text "(* generated by UUAG from" >#< mainFile >#< "*)" , pp pragmaBlocksTxt , text "(* module imports *)" , pp importBlocksTxt , Pass4c.modules_Syn_ExecutionPlan output4c , text "" , text "(* generated data types *)" , text "module Data__ = struct" , indent 2 $ vlist [ text "type __generated_by_uuagc__ = Generated_by_uuagc__" , Pass4c.datas_Syn_ExecutionPlan output4c ] , text "end" , text "open Data__" , text "" , text "(* embedded data types *)" , dataBlocksDoc , text "" , text "(* embedded utilty functions *)" , textBlocksDoc , text "(* generated evaluationcode *)" , text "module Code__ = struct" , indent 2 $ vlist [ text "let rec __generated_by_uuagc__ = Generated_by_uuagc__" , Pass4c.code_Syn_ExecutionPlan output4c , recBlocksDoc ] , text "end" , text "open Code__" , text "" , text "(* main code *)" , mainBlocksDoc ] else vlist [ Pass4b.warrenFlagsPP flags' , pp pragmaBlocksTxt , pp $ if isNothing $ Pass1.moduleDecl_Syn_AG output1 then moduleHeader flags' mainName Nothing else mkModuleHeader (Pass1.moduleDecl_Syn_AG output1) mainName "" "" False , pp importBlocksTxt , ( if tupleAsDummyToken flags' then empty else pp "import GHC.Prim" -- need it to pass State# ) , if parallelInvoke flags' then vlist [ pp $ "import qualified System.IO.Unsafe(unsafePerformIO)" , pp $ "import System.IO(IO)" , pp $ "import Control.Concurrent(newEmptyMVar,forkIO,putMVar,takeMVar)"] else vlist [ pp $ "import Control.Monad.Identity (Identity)" , pp $ "import qualified Control.Monad.Identity" ] , dataBlocksDoc , mainBlocksDoc , textBlocksDoc , recBlocksDoc --, pp $ "{-" --, Pass3a.depgraphs_Syn_Grammar output3a --, Pass3a.visitgraph_Syn_Grammar output3a --, pp $ "-}" , Pass4b.output_Syn_ExecutionPlan output4b , if dumpgrammar flags' then vlist [ pp "{- Dump of grammar with default rules" , GrammarDump.pp_Syn_Grammar dump2 , pp "-}" ] else empty] | otherwise = vlist [ vlist ( if not (ocaml flags') then [ pp optionsLine , pp pragmaBlocksTxt , pp $ take 70 ("-- UUAGC " ++ drop 50 banner ++ " (" ++ input) ++ ")" , pp $ if isNothing $ Pass1.moduleDecl_Syn_AG output1 then moduleHeader flags' mainName Nothing else mkModuleHeader (Pass1.moduleDecl_Syn_AG output1) mainName "" "" False ] else [] ) , pp importBlocksTxt , dataBlocksDoc , mainBlocksDoc , textBlocksDoc , vlist $ if not (ocaml flags') then Pass5.output_Syn_Program output5 else Pass5a.output_Syn_Program output5a , if dumpgrammar flags' then vlist [ pp "{- Dump of grammar without default rules" , GrammarDump.pp_Syn_Grammar dump1 , pp "-}" , pp "{- Dump of grammar with default rules" , GrammarDump.pp_Syn_Grammar dump2 , pp "-}" ] else empty , if dumpcgrammar flags' then vlist [ pp "{- Dump of cgrammar" , CGrammarDump.pp_Syn_CGrammar dump3 , pp "-}" ] else empty ] let docTxt = disp doc 50000 "" writeFile outputfile docTxt -- HACK: write statistics let nAuto = Pass3.nAutoRules_Syn_Grammar output3 nExpl = Pass3.nExplicitRules_Syn_Grammar output3 line' = inputfile ++ "," ++ show nAuto ++ "," ++ show nExpl ++ "\r\n" case statsFile flags' of Nothing -> return () Just f -> appendFile f line' if not (null errorsToStopOn) then failWith 1 else return () formatErrors :: PP_Doc -> String formatErrors doc = disp doc 5000 "" message2error :: Message Token Pos -> Error message2error (Msg expect pos action) = ParserError pos (show expect) actionString where actionString = case action of Insert s -> "inserting: " ++ show s Delete s -> "deleting: " ++ show s Other ms -> ms errorsToFront :: Options -> [Error] -> [Error] errorsToFront flags mesgs = errs ++ warnings where (errs,warnings) = partition (PrErr.isError flags) mesgs moduleHeader :: Options -> String -> Maybe String -> String moduleHeader flags input export = case moduleName flags of Name nm -> genMod nm Default -> genMod (defaultModuleName input) NoName -> "" where genMod x = "module " ++ x ++ genExp export x ++ " where" genExp Nothing _ = "" genExp (Just e) x = "(module " ++ x ++ ", module " ++ e ++ ")" --marcos agiFile :: String -> String agiFile name = replaceExtension name "agi" remAgi :: String -> String remAgi = dropExtension outputFile :: Options -> String -> String outputFile opts name | ocaml opts = replaceExtension name "ml" | otherwise = replaceExtension name "hs" defaultModuleName :: String -> String defaultModuleName = dropExtension mkMainName :: String -> Maybe (String, String,String) -> String mkMainName defaultName Nothing = defaultName mkMainName _ (Just (name, _, _)) = name mkModuleHeader :: Maybe (String,String,String) -> String -> String -> String -> Bool -> String mkModuleHeader Nothing defaultName suffix _ _ = "module " ++ defaultName ++ suffix ++ " where" mkModuleHeader (Just (name, exports, imports)) _ suffix addExports replaceExports = "module " ++ name ++ suffix ++ ex ++ " where\n" ++ imports ++ "\n" where ex = if null exports || (replaceExports && null addExports) then "" else if null addExports then "(" ++ exports ++ ")" else if replaceExports then "(" ++ addExports ++ ")" else "(" ++ exports ++ "," ++ addExports ++ ")" reportDeps :: Options -> [String] -> IO () reportDeps flags files = do deps <- getDeps flags files mapM_ putStrLn deps getDeps :: Options -> [String] -> IO [String] getDeps flags files = do results <- mapM (depsAG flags (searchPath flags)) files let (fs, mesgs) = foldr comb ([],[]) results let errs = take (min 1 (wmaxerrs flags)) (map message2error mesgs) let ppErrs = PrErr.wrap_Errors (PrErr.sem_Errors errs) PrErr.Inh_Errors {PrErr.options_Inh_Errors = flags, PrErr.dups_Inh_Errors = []} if null errs then return fs else do putStr . formatErrors $ PrErr.pp_Syn_Errors ppErrs failWithCode flags 1 return [] where comb :: ([a],[b]) -> ([a], [b]) -> ([a], [b]) comb (fs, mesgs) (fsr, mesgsr) = (fs ++ fsr, mesgs ++ mesgsr) writeAttributeList :: String -> AttrMap -> IO () writeAttributeList fileP mp = writeFile fileP s where s = show $ map (\(x,y) -> (show x, y)) $ Map.toList $ Map.map (map (\(x,y) -> (show x, y)) . Map.toList . Map.map (map (\(x,y) -> (show x, show y)) . Set.toList)) $ mp readIrrefutableMap :: Options -> IO AttrMap readIrrefutableMap flags = case forceIrrefutables flags of Just fileP -> do s <- readFile fileP seq (length s) (return ()) let lists :: [(String,[(String,[(String, String)])])] lists = read s return $ Map.fromList [ (identifier n, Map.fromList [(identifier c, Set.fromList [ (identifier fld, identifier attr) | (fld,attr) <- ss ]) | (c,ss) <- cs ]) | (n,cs) <- lists ] Nothing -> return Map.empty uuagc-0.9.42.3/src/ATermAbstractSyntax.hs000644 000765 000024 00000001263 12127045231 022076 0ustar00jeroenbransenstaff000000 000000 {----------------------------------------------------------------------------- Haskell ATerm Library Joost Visser CWI, Amsterdam This module is part of the ATerm library for Haskell. It defines the abstract syntax of ATerms as a Haskell datatype. ------------------------------------------------------------------------------} module ATermAbstractSyntax where -- Abstract syntax ----------------------------------------------------------- data ATerm = AAppl String [ATerm] | AList [ATerm] | AInt Integer | AString String deriving (Read,Show,Eq,Ord) ------------------------------------------------------------------------------ uuagc-0.9.42.3/src/ATermWrite.hs000644 000765 000024 00000001757 12127045231 020226 0ustar00jeroenbransenstaff000000 000000 module ATermWrite where import ATermAbstractSyntax import Data.List (intersperse) writeATerm :: ATerm -> String writeATerm t = writeAT 0 t writeAT :: Int -> ATerm -> String writeAT n (AAppl c ts) = (if (n > 0) then "\n" else "") ++ replicate n ' ' ++ writeATermAux c (map (writeAT (n+2)) ts) writeAT n (AList ts) = bracket (commaSep (map (writeAT n) ts)) writeAT _ (AInt i) = show i writeAT _ (AString s) = quote s writeATermAux :: [Char] -> [[Char]] -> [Char] writeATermAux c [] = c++(parenthesise "") writeATermAux c ts = c++(parenthesise (commaSep ts)) commaSep :: [[Char]] -> [Char] commaSep strs = concat (intersperse "," strs) bracket :: [Char] -> [Char] bracket str = "["++str++"]" parenthesise :: [Char] -> [Char] parenthesise str = "("++str++")" quote :: [Char] -> [Char] quote str = "\""++str++"\""uuagc-0.9.42.3/src/CommonTypes.hs000644 000765 000024 00000023051 12127045231 020447 0ustar00jeroenbransenstaff000000 000000 module CommonTypes (module Options, module CommonTypes) where import Options import UU.Scanner.Position(Pos) import qualified Data.Map as Map import Data.Map(Map) import Data.Set(Set) import qualified Data.Set as Set import Data.Monoid(mappend,Monoid) import Data.Char import Pretty type Blocks = Map BlockInfo [([String], Pos)] type BlockInfo = (BlockKind, Maybe NontermIdent) data BlockKind = BlockImport | BlockPragma | BlockMain | BlockData | BlockRec | BlockOther deriving (Eq, Ord, Show) instance PP Identifier where pp = text . getName data Type = Haskell String | NT Identifier [String] Bool -- True: deforested nonterminal, False: nonterminal type | Self -- reference to the enclosing nonterminal type deriving (Eq) data ComplexType = List Type | Tuple [(Identifier, Type)] | Maybe Type | Either Type Type | Map Type Type | IntMap Type | OrdSet Type | IntSet instance Show ComplexType where show (List t ) = "[" ++ show t ++ "]" show (Tuple ts) = "(" ++ showList [ show n ++ ": " ++ show t | (n,t) <- ts ] "" ++ ")" show (Maybe t ) = "Maybe " ++ show t show (Either t1 t2) = "Either " ++ show t1 ++ " " ++ show t2 show (Map t1 t2) = "Map " ++ show t1 ++ " " ++ show t2 show (IntMap t1) = "IntMap " ++ show t1 show (OrdSet t1) = "Set" ++ show t1 show IntSet = "IntSet" instance Show Type where show = typeToHaskellString Nothing [] type Attributes = Map Identifier Type type TypeSyns = [(NontermIdent,ComplexType)] type ParamMap = Map NontermIdent [Identifier] type AttrNames = [(Identifier,Type,(String,String,String))] type UseMap = Map NontermIdent (Map Identifier (String,String,String)) type PragmaMap = Map NontermIdent (Map ConstructorIdent (Set Identifier)) type AttrMap = Map NontermIdent (Map ConstructorIdent (Set (Identifier,Identifier))) type UniqueMap = Map NontermIdent (Map ConstructorIdent (Map Identifier Identifier)) type Derivings = Map NontermIdent (Set Identifier) type ClassContext = [(Identifier, [String])] type ContextMap = Map NontermIdent ClassContext type QuantMap = Map NontermIdent [String] type Strings = [String] type ConstructorIdent = Identifier type AttrOrderMap = Map NontermIdent (Map ConstructorIdent (Set Dependency)) type VisitIdentifier = Int type StateIdentifier = Int data Dependency = Dependency Occurrence Occurrence deriving (Eq,Ord,Show) data Occurrence = OccAttr Identifier Identifier | OccRule Identifier deriving (Eq,Ord,Show) type AttrEnv = ( [Identifier] , [(Identifier,Identifier)] ) nullIdent, _LHS, _SELF, _LOC, _INST, _INST', _FIELD, _FIRST, _LAST :: Identifier nullIdent = identifier "" _LHS = identifier "lhs" _SELF = identifier "SELF" _LOC = identifier "loc" _INST = identifier "inst" _INST' = identifier "inst'" _FIELD = identifier "field" _FIRST = identifier "first__" _LAST = identifier "last__" idLateBindingAttr :: Identifier idLateBindingAttr = identifier "lateSemDict" lateBindingTypeNm :: String -> String lateBindingTypeNm modNm = "Late_" ++ modNm ++ "_" lateBindingFieldNm :: String -> String lateBindingFieldNm modNm = "late_" ++ modNm ++ "_" lateBindingType :: String -> Type lateBindingType modNm = Haskell (lateBindingTypeNm modNm) lateSemNtLabel :: NontermIdent -> String lateSemNtLabel nt = "mk_" ++ getName nt lateSemConLabel :: NontermIdent -> ConstructorIdent -> String lateSemConLabel nt con = "mk_" ++ getName nt ++ "_" ++ getName con sdtype :: NontermIdent -> String sdtype nt = "T_"++getName nt mkNtType :: Identifier -> [String] -> Type mkNtType nt args | take 2 (getName nt) == "T_" = let nt' = Ident (drop 2 (getName nt)) (getPos nt) in NT nt' args True | otherwise = NT nt args False cataname :: String -> Identifier -> String cataname pre name = pre++getName name conname :: Bool -> NontermIdent -> ConstructorIdent -> String conname ren nt con | ren = capitalize (getName nt) ++ "_" ++ getName con | otherwise = getName con capitalize :: String -> String capitalize [] = [] capitalize (c:cs) = toUpper c : cs semname :: String -> NontermIdent -> ConstructorIdent -> String semname pre nt con = pre ++ (getName nt ++ "_" ++ getName con) recordFieldname :: NontermIdent -> ConstructorIdent -> Identifier -> String recordFieldname nt con nm = getName nm ++ "_" ++ getName nt ++ "_" ++ getName con lhsname :: Bool -> Identifier -> String lhsname isIn = attrname isIn _LHS attrname :: Bool -> Identifier -> Identifier -> String attrname isIn field attr | field == _LOC = locname attr | field == _INST = instname attr | field == _INST' = inst'name attr | field == _FIELD = fieldname attr | otherwise = let direction | isIn = "I" | otherwise = "O" in '_' : getName field ++ direction ++ getName attr locname, instname, inst'name, fieldname :: Identifier -> String locname v = '_' : getName v instname v = getName v ++ "_val_" inst'name v = getName v ++ "_inst_" fieldname v = getName v++"_" typeToAGString :: Type -> String typeToAGString tp = case tp of Haskell t -> t NT nt tps for -> formatNonterminalToHaskell for (getName nt) (map (\s -> "{" ++ s ++ "}") tps) Self -> error "Self type is not allowed here." removeDeforested :: Type -> Type removeDeforested (NT nt args _) = NT nt args False removeDeforested tp = tp forceDeforested :: Type -> Type forceDeforested (NT nt args _) = NT nt args True forceDeforested tp = tp typeToHaskellString :: Maybe NontermIdent -> [String] -> Type -> String typeToHaskellString mbNt params tp = case tp of Haskell t -> filter (/= '@') t -- Apparently haskell types can contain @ to refer to -- a type parameter, removing @ makes it backwards compatible NT nt tps for | nt == _SELF -> formatNonterminalToHaskell for (maybe "?SELF?" getName mbNt) params | otherwise -> formatNonterminalToHaskell for (getName nt) tps Self -> maybe "?SELF?" getName mbNt formatNonterminalToHaskell :: Bool -> String -> [String] -> String formatNonterminalToHaskell for nt tps = unwords ((pref ++ nt) : tps) where pref | for = "T_" | otherwise = "" ind :: String -> String ind s = replicate 3 ' ' ++ s _NOCASE :: Identifier _NOCASE = identifier "nocase" hasPragma :: PragmaMap -> NontermIdent -> ConstructorIdent -> Identifier -> Bool hasPragma mp nt con nm = nm `Set.member` Map.findWithDefault Set.empty con (Map.findWithDefault Map.empty nt mp) isNonterminal :: Type -> Bool isNonterminal (NT _ _ _) = True isNonterminal _ = False isSELFNonterminal :: Type -> Bool -- isSELFNonterminal (NT nt _ _) | nt == _SELF = True isSELFNonterminal Self = True isSELFNonterminal _ = False extractNonterminal :: Type -> NontermIdent extractNonterminal (NT n _ _) = n extractNonterminal _ = error "Must be NT" nontermArgs :: Type -> [String] nontermArgs tp = case tp of NT _ args _ -> args _ -> [] deforestedNt :: Identifier -> Maybe Identifier deforestedNt nm | take 2 (getName nm) == "T_" = Just (Ident (drop 2 (getName nm)) (getPos nm)) | otherwise = Nothing data StateCtx = NoneVis | OneVis !Int | ManyVis deriving (Eq, Show, Ord) data ChildKind = ChildSyntax -- This child is defined by syntax | ChildAttr -- This child is defined by an attribute | ChildReplace Type -- This child replaces a child with type Type deriving (Eq, Show) -- Given a map that represents a relation, returns the transitive closure of this relation closeMap :: Ord a => Map a (Set a) -> Map a (Set a) closeMap mp0 = close (Map.keysSet mp0) mp0 where rev = revDeps mp0 close todo mp0' = case Set.minView todo of Nothing -> mp0' Just (k, todo1) -> let find x = Map.findWithDefault Set.empty x mp0' vals0 = find k valsL = Set.toList vals0 vals1 = foldr Set.union vals0 $ map find valsL in if Set.size vals0 == Set.size vals1 then close todo1 mp0' -- note: monotonically increasing set else let mp1 = Map.insert k vals1 mp0' refs = Map.findWithDefault Set.empty k rev todo2 = Set.union refs todo1 in close todo2 mp1 revDeps :: Ord a => Map a (Set a) -> Map a (Set a) revDeps mp = Map.fromListWith Set.union [ (a,Set.singleton k) | (k,s) <- Map.assocs mp, a <- Set.toList s ] data HigherOrderInfo = HigherOrderInfo { hoNtDeps :: Set NontermIdent , hoNtRevDeps :: Set NontermIdent , hoAcyclic :: Bool } data VisitKind = VisitPure Bool -- ordered or not | VisitMonadic deriving (Eq,Ord) isLazyKind :: VisitKind -> Bool isLazyKind (VisitPure False) = True isLazyKind _ = False instance Show VisitKind where show (VisitPure False) = "Lazy" show (VisitPure True) = "Ordered" show VisitMonadic = "Monadic" unionWithMappend :: (Monoid a, Ord k) => Map k a -> Map k a -> Map k a unionWithMappend = Map.unionWith mappend data FormatMode = FormatDo | FormatLetDecl | FormatLetLine deriving (Eq, Ord, Show) uuagc-0.9.42.3/src/GrammarInfo.hs000644 000765 000024 00000004140 12127045231 020372 0ustar00jeroenbransenstaff000000 000000 module GrammarInfo where import SequentialTypes import CodeSyntax import Data.Map(Map) import qualified Data.Map as Map import Data.Set(Set) import qualified Data.Set as Set import CommonTypes import Data.List(intersect,(\\)) type LMH = (Vertex,Vertex,Vertex) data Info = Info { tdpToTds :: Table Vertex , tdsToTdp :: Table [Vertex] , attrTable :: Table NTAttr , ruleTable :: Table CRule , lmh :: [LMH] , nonts :: [(NontermIdent,[ConstructorIdent])] , wraps :: Set NontermIdent } deriving Show instance Show CRule where show (CRule name _ _ nt con field childnt _ _ rhs _ _ _ uses _ _) = "CRule " ++ show name ++ " nt: " ++ show nt ++ " con: " ++ show con ++ " field: " ++ show field ++ " childnt: " ++ show childnt ++ " rhs: " ++ concat rhs ++ " uses: " ++ show [ attrname True fld nm | (fld,nm) <- Set.toList uses ] show _ = error "Only CRule is supported" type CInterfaceMap = Map NontermIdent CInterface type CVisitsMap = Map NontermIdent (Map ConstructorIdent CVisits) data CycleStatus = CycleFree CInterfaceMap CVisitsMap | LocalCycle [Route] | InstCycle [Route] | DirectCycle [EdgeRoutes] | InducedCycle CInterfaceMap [EdgeRoutes] showsSegment :: CSegment -> [String] showsSegment (CSegment inh syn) = let syn' = map toString (Map.toList syn) inh' = map toString (Map.toList inh) toString (a,t) = (getName a, case t of (NT nt tps _) -> getName nt ++ " " ++ unwords tps; Haskell t' -> t'; Self -> error "Self type not supported.") chnn = inh' `intersect` syn' inhn = inh' \\ chnn synn = syn' \\ chnn disp _ [] = [] disp name as = (name ++ if length as == 1 then " attribute:" else " attributes:") : map (\(x,y) -> ind x ++ replicate ((20 - length x) `max` 0) ' ' ++ " : " ++ y) as in disp "inherited" inhn ++ disp "chained" chnn ++ disp "synthesized" synn uuagc-0.9.42.3/src/HsTokenScanner.hs000644 000765 000024 00000016174 12127045231 021067 0ustar00jeroenbransenstaff000000 000000 module HsTokenScanner where import HsToken import UU.Scanner.Position import Data.List(sort) import UU.Util.BinaryTrees import CommonTypes import Data.Maybe import Data.Char isAGesc :: Char -> Bool isAGesc c = c == '@' lexTokens :: Pos -> String -> [HsToken] lexTokens = scanTokens keywordstxt keywordsops specialchars opchars where keywordstxt = [] keywordsops = [".","=", ":=", ":","|","@"] specialchars = ";()[],_{}`" opchars = "!#$%&*+./<=>?@\\^|-~:" scanTokens :: [String] -> [String] -> String -> String -> Pos -> String -> [HsToken] scanTokens keywordstxt keywordsops specchars opchars pos input = doScan pos input where locatein :: Ord a => [a] -> a -> Bool locatein es = isJust . btLocateIn compare (tab2tree (sort es)) iskw = locatein keywordstxt isop = locatein keywordsops isSymb = locatein specchars isOpsym = locatein opchars isIdStart c = isLower c || c == '_' isIdChar c = isAlphaNum c || c == '\'' || c == '_' scanIdent p s = let (name,rest) = span isIdChar s in (name,advc (length name) p,rest) doScan _ [] = [] doScan p (c:s) | isSpace c = let (sp,next) = span isSpace s in doScan (foldl (flip updPos) p (c:sp)) next doScan p (c:d:s) | isAGesc c && isIdStart d = let (fld,p2,rest) = scanIdent (advc 2 p) s field = d:fld in case rest of ('.':r:rs) | isIdStart r -> let (at,p3,rest2) = scanIdent (advc 2 p2) rs attr = r : at in AGField (Ident field p) (Ident attr p) p Nothing : doScan p3 rest2 _ -> AGLocal (Ident field p) p Nothing : doScan p2 rest doScan p ('-':'-':s) = doScan p (dropWhile (/= '\n') s) doScan p ('{':'-':s) = advc' 2 p (lexNest doScan) s -- } doScan p ('"':ss) = let (s,swidth,rest) = scanString ss in if null rest || head rest /= '"' then Err "Unterminated string literal" p : advc' swidth p doScan rest else StrToken s p : advc' (swidth+2) p doScan (tail rest) doScan p ('\'':ss) = let (mc,cwidth,rest) = scanChar ss in case mc of Nothing -> Err "Error in character literal" p : advc' cwidth p doScan rest Just c -> if null rest || head rest /= '\'' then Err "Unterminated character literal" p : advc' (cwidth+1) p doScan rest else CharToken [c] p : advc' (cwidth+2) p doScan (tail rest) doScan p cs@(c:s) | isIdStart c || isUpper c = let (name', p', s') = scanIdent (advc 1 p) s name = c:name' tok = if iskw name then HsToken name p -- keyword else if null name' && isSymb c then HsToken [c] p -- '_' else HsToken name p -- varid / conid in tok : doScan p' s' | isOpsym c = let (name, s') = span isOpsym cs tok | isop name = HsToken name p | otherwise = HsToken name p in tok : doScan (foldl (flip updPos) p name) s' | isDigit c = let (base,digs,width,s') = getNumber cs number = case base of 8 -> "0o"++digs 10 -> digs 16 -> "0x"++digs _ -> error $ "Base " ++ show base ++ " is not supported." in HsToken number p : advc' width p doScan s' | isSymb c = HsToken [c] p : advc' 1 p doScan s | otherwise = Err ("Unexpected character " ++ show c) p : updPos' c p doScan s lexNest :: (Pos -> String -> [HsToken]) -> Pos -> String -> [HsToken] lexNest cont pos inp = lexNest' cont pos inp where lexNest' c p ('{':'-':s) = lexNest' (lexNest' c) (advc 2 p) s lexNest' c p ('-':'}':s) = c (advc 2 p) s lexNest' c p (x:s) = lexNest' c (updPos x p) s lexNest' _ _ [] = [Err "Unterminated nested comment" pos] scanString :: String -> (String, Int, String) scanString [] = ("",0,[]) scanString ('\\':'&':xs) = let (str,w,r) = scanString xs in (str,w+2,r) scanString ('\'':xs) = let (str,w,r) = scanString xs in ('\'': str,w+1,r) scanString xs = let (ch,cw,cr) = getchar xs (str,w,r) = scanString cr -- str' = maybe "" (:str) ch in maybe ("",0,xs) (\c -> (c:str,cw+w,r)) ch scanChar :: String -> (Maybe Char, Int, String) scanChar ('"' :xs) = (Just '"',1,xs) scanChar xs = getchar xs getchar :: String -> (Maybe Char, Int, String) getchar [] = (Nothing,0,[]) getchar s@('\n':_ ) = (Nothing,0,s ) getchar s@('\t':_ ) = (Nothing,0,s) getchar s@('\'':_ ) = (Nothing,0,s) getchar s@('"' :_ ) = (Nothing,0,s) getchar ('\\':xs) = let (c,l,r) = getEscChar xs in (c,l+1,r) getchar (x:xs) = (Just x,1,xs) getEscChar :: String -> (Maybe Char, Int, String) getEscChar [] = (Nothing,0,[]) getEscChar s@(x:xs) | isDigit x = let (base,n,len,rest) = getNumber s val = readn base n in if val >= 0 && val <= 255 then (Just (chr val),len, rest) else (Nothing,1,rest) | otherwise = case x `lookup` cntrChars of Nothing -> (Nothing,0,s) Just c -> (Just c,1,xs) where cntrChars = [('a','\a'),('b','\b'),('f','\f'),('n','\n'),('r','\r'),('t','\t') ,('v','\v'),('\\','\\'),('"','\"'),('\'','\'')] readn :: Int -> String -> Int readn base n = foldl (\r x -> value x + base * r) 0 n getNumber :: String -> (Int,String,Int,String) getNumber [] = error "Empty string" getNumber cs@(c:s) | c /= '0' = num10 | null s = const0 | hs == 'x' || hs == 'X' = num16 | hs == 'o' || hs == 'O' = num8 | otherwise = num10 where (hs:ts) = s const0 = (10, "0",1,s) num10 = let (n,r) = span isDigit cs in (10,n,length n,r) num16 = readNum isHexaDigit ts 16 num8 = readNum isOctalDigit ts 8 readNum p ts' tk = let (n,rs) = span p ts' in if null n then const0 else (tk, n, 2+length n,rs) isHexaDigit :: Char -> Bool isHexaDigit d = isDigit d || (d >= 'A' && d <= 'F') || (d >= 'a' && d <= 'f') isOctalDigit :: Char -> Bool isOctalDigit d = d >= '0' && d <= '7' value :: Char -> Int value c | isDigit c = ord c - ord '0' | isUpper c = ord c - ord 'A' + 10 | isLower c = ord c - ord 'a' + 10 value _ = error "Not a valid value" uuagc-0.9.42.3/src/KennedyWarren.hs000644 000765 000024 00000111524 12127045231 020751 0ustar00jeroenbransenstaff000000 000000 module KennedyWarren where import Prelude hiding (init, succ) import CommonTypes import Pretty import Knuth1 import ExecutionPlan import Debug.Trace import Control.Monad.ST import Control.Monad.State import Control.Monad.Error import Data.STRef import Data.Maybe import Data.List (intersperse, groupBy, partition, sortBy) import Data.Ord import qualified ErrorMessages as Err import PrintErrorMessages () import Data.Set (Set) import qualified Data.Set as Set import Data.Map (Map) import qualified Data.Map as Map import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet -- lazy version (does not return errors) -- FIXME: construct map from nonterminal to intial visit (or state?) and use it in the generation of invokes kennedyWarrenLazy :: Options -> Set NontermIdent -> [NontDependencyInformation] -> TypeSyns -> Derivings -> ExecutionPlan kennedyWarrenLazy _ wr ndis typesyns derivings = plan where plan = ExecutionPlan nonts typesyns wr derivings nonts = zipWith mkNont ndis nontIds nontIds = enumFromThen 1 4 initvMap = Map.fromList $ zipWith (\ndi initv -> (ndiNonterminal ndi, initv)) ndis nontIds mkNont ndi initv = nont where nont = ENonterminal (ndiNonterminal ndi) (ndiParams ndi) (ndiClassCtxs ndi) initst (Just initv) nextMap prevMap prods (ndiRecursive ndi) (ndiHoInfo ndi) initst = initv + 1 finals = initv + 2 nextMap = Map.fromList [(initst, OneVis initv), (finals, NoneVis)] prevMap = Map.fromList [(initst, NoneVis), (finals, OneVis initv)] prods = map mkProd (ndiProds ndi) mkProd pdi = prod where prod = EProduction (pdgProduction pdi) (pdgParams pdi) (pdgConstraints pdi) (pdgRules pdi) (pdgChilds pdi) visits visits = [vis] vis = Visit initv initst finals inh syn steps kind inh = Set.fromList $ ndiInh ndi syn = Set.fromList $ ndiSyn ndi kind = VisitPure False steps = childSteps ++ invokeSteps ++ ruleSteps childSteps = [ ChildIntro nm | EChild nm _ _ _ _ _ <- pdgChilds pdi ] invokeSteps = [ ChildVisit nm nt v | EChild nm tp _ _ _ _ <- pdgChilds pdi , let nt = extractNonterminal tp v = Map.findWithDefault (error "child not in initv-map") nt initvMap ] ruleSteps = [ Sem nm | (ERule nm _ _ _ _ _ _ _) <- pdgRules pdi ] -- ordered version (may return errors) kennedyWarrenOrder :: Options -> Set NontermIdent -> [NontDependencyInformation] -> TypeSyns -> Derivings -> Either Err.Error (ExecutionPlan, PP_Doc, PP_Doc) kennedyWarrenOrder opts wr ndis typesyns derivings = runST $ runErrorT $ do indi <- lift $ mapM mkNontDependencyInformationM ndis lift $ knuth1 indi -- Check all graphs for cyclicity, transitive closure and consistency -- traceST $ "Checking graphs..." forM_ indi $ \ndi -> do let nont = ndiNonterminal . ndimOrig $ ndi let g = ndgmDepGraph . ndimDepGraph $ ndi -- Topological sort --tsedg <- graphTopSort g -- Cyclicity check ntCycVerts <- lift $ graphCyclicVerticesExt g when (not $ null ntCycVerts) $ do throwError $ Err.Cyclic nont Nothing (map show ntCycVerts) -- let msg = "Nonterminal graph " ++ show nont ++ " is cylic!" -- fail msg -- Transtive closure check trc <- lift $ graphIsTRC g when (not trc) $ do let msg = "Nonterminal graph " ++ show nont ++ " is not transitively closed!" fail msg -- Consistency check cons <- lift $ graphCheckConsistency g when (not cons) $ do let msg = "Nonterminal graph " ++ show nont ++ " is not consistent!" fail msg -- Loop trough all productions forM_ (ndimProds ndi) $ \prod -> do let pr = pdgProduction $ pdgmOrig prod let g' = pdgmDepGraph $ prod -- Topsort --addTopSortEdges tsedg prod -- Check for cyclicity pdCycVerts <- lift $ graphCyclicVerticesExt g' when (not $ null pdCycVerts) $ do throwError $ Err.Cyclic nont (Just pr) (map show pdCycVerts) -- let msg = "Production graph " ++ show pr ++ " of nonterminal " -- ++ show nont ++ " is cylic!" -- fail msg -- Transtive closure check trc' <- lift $ graphIsTRC g' when (not trc') $ do lift $ traceST $ "Production graph " ++ show pr ++ " of nonterminal " ++ show nont ++ " is not transitively closed!" fail "Production graph is not transitively closed." -- Check consistency consistent <- lift $ graphCheckConsistency g' when (not consistent) $ do let msg = "Production graph " ++ show pr ++ " of nonterminal " ++ show nont ++ " is not consistent!" fail msg -- reachable when everything is ok lift $ do -- Create non-transitive closed graph for efficiency indi' <- undoTransitiveClosure indi -- Graphviz output of dependency graphs gvs <- mapM toGVNontDependencyInfo indi' -- Doing kennedywarren (ret, visitg) <- runVG $ do -- traceVG $ "Running kennedy-warren..." initvs <- kennedyWarrenVisitM wr indi' -- Print some debug info nodes <- gets vgNodeNum edges <- gets vgEdgeNum when (not $ beQuiet opts) $ do traceVG $ "Number of nodes = " ++ show nodes traceVG $ "Number of edges = " ++ show edges -- Generate execution plan ex <- kennedyWarrenExecutionPlan opts indi' initvs wr typesyns derivings -- Get visit graph visitg <- toGVVisitGraph return (ex,visitg) -- Return the result return (ret, vlist gvs, visitg) ------------------------------------------------------------------------------- -- Debugging functionality ------------------------------------------------------------------------------- -- | 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 toGVVertex l (VChild c) = return $ (text $ "child_" ++ show c) >#< if l 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 -- | Pretty print an edge in GraphViz format toGVEdge :: Edge -> ST s PP_Doc toGVEdge (v1, v2) = do r1 <- toGVVertex False v1 r2 <- toGVVertex False v2 return $ r1 >|< text "->" >#< r2 -- | Pretty print a NontDependencyInformation in GraphViz format toGVNontDependencyInfo :: NontDependencyInformationM s -> ST s PP_Doc toGVNontDependencyInfo ndi = do dg <- return $ ndgmDepGraph . ndimDepGraph $ ndi verts <- graphVertices dg edges <- graphEdges dg vtexts <- mapM (toGVVertex True) verts etexts <- mapM toGVEdge edges ptexts <- mapM toGVProdDependencyGraph (ndimProds ndi) return $ (text ("digraph ndg_" ++ show (ndiNonterminal $ ndimOrig ndi) ++ " {") >-< vlist vtexts >-< vlist etexts >-< text "}" >-< text "" -- empty line >-< vlist ptexts) -- | Pretty print a ProdDependencyGraph in GraphViz format toGVProdDependencyGraph :: ProdDependencyGraphM s -> ST s PP_Doc toGVProdDependencyGraph pdg = do dg <- return $ pdgmDepGraph pdg verts <- graphVertices dg edges <- graphEdges dg vtexts <- mapM (toGVVertex True) verts etexts <- mapM toGVEdge edges return $ (text ("digraph pdg_" ++ show (pdgProduction $ pdgmOrig pdg) ++ " {") >-< (vlist vtexts) >-< (vlist etexts) >-< text ("info [shape=box,label=\"" ++ show (pdgChildMap $ pdgmOrig pdg) ++ "\"];") >-< text "}" >-< text "") toGVVisitGraph :: VG s PP_Doc toGVVisitGraph = do ndis <- gets vgNDI noded <- forM (IntMap.toList ndis) $ \(n,rndi) -> do ndi <- vgInST $ readSTRef rndi return $ "node_" >|< n >#< "[label=\"" >|< ndiNonterminal (ndimOrig ndi) >|< "_" >|< n >|< "\"];" edges <- gets vgEdges edged <- forM (IntMap.toList edges) $ \(edg,(VGNode from,VGNode to)) -> do inh <- getInherited (VGEdge edg) syn <- getSynthesized (VGEdge edg) return $ "node_" >|< from >#< "-> node_" >|< to >#< "[label=\"visit v" >|< edg >|< "\\ninh:" >#< (concat $ intersperse ", " $ map show $ Set.toList inh) >|< "\\nsyn: " >|< (concat $ intersperse ", " $ map show $ Set.toList syn) >|< "\"];" return $ "digraph visitgraph { " >-< vlist noded >-< vlist edged >-< "}" ------------------------------------------------------------------------------- -- Kennedy-Warren in monadic style ------------------------------------------------------------------------------- {- runVG :: VG s a -> ST s a insertInitialNode :: NontDependencyInformationM s -> VG s VGNode createPending :: VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge selectPending :: VG s VGEdge getInherited :: VGEdge -> VG s (Set Identifier) getSynthesized :: VGEdge -> VG s (Set Identifier) markFinal :: VGEdge -> VG s () getProductions :: VGEdge -> VG s [VGProd] onMarkedDepGraph :: (ProdDependencyGraphM s -> ST s a) -> VGProd -> VG s a isDepGraphVertexFinal :: VGProd -> Vertex -> VG s Bool setDepGraphVerticesFinal :: VGProd -> [Vertex] -> VG s () getChildState :: VGProd -> Identifier -> VG s VGNode addChildVisit :: VGProd -> Identifier -> VGEdge -> VG s VisitStep addVisitStep :: VGProd -> VisitStep -> VG s () repeatM :: VG s () -> VG s () -} newtype VGNode = VGNode Int deriving (Show,Eq,Ord) newtype VGEdge = VGEdge Int deriving (Show,Eq,Ord) newtype VGProd = VGProd (VGEdge,Int) deriving (Show,Eq,Ord) data VGState s = VGState { vgNodeNum :: Int , vgEdgeNum :: Int -- Node maps , vgOutgoing :: IntMap (STRef s (Set VGEdge)) , vgIncoming :: IntMap (Maybe VGEdge) , vgNDI :: IntMap (STRef s (NontDependencyInformationM s)) , vgInhSynNode :: Map (Identifier, Set Identifier, Set Identifier) VGNode , vgNodeInhSyn :: IntMap (Set Identifier, Set Identifier) , vgInitial :: Map Identifier VGNode -- Edge maps , vgEdges :: IntMap (VGNode, VGNode) , vgEdgesR :: Map (VGNode,VGNode) VGEdge , vgInherited :: IntMap (Set Identifier) , vgSynthesized :: IntMap (Set Identifier) , vgPending :: IntSet , vgChildVisits :: IntMap (STRef s (Map (Identifier,Int) [VGNode])) -- Final vertices in production graphs , vgFinalVertices :: IntMap (STRef s (Set (Vertex,Int))) -- Construction of execution plan (Nonterminal,Production,Visit) , vgProdVisits :: Map (Identifier,Identifier,VGEdge) (STRef s [VisitStep]) } type VG s a = ErrorT String (StateT (VGState s) (ST s)) a ------------------------------------------------------------ --- Public functions --- ------------------------------------------------------------ -- | Run the VG monad in the ST monad runVG :: VG s a -> ST s a runVG vg = do (Right a,_) <- runStateT (runErrorT vg) vgEmptyState return a -- | Insert an initial node for this nonterminal into the visit graph insertInitialNode :: NontDependencyInformationM s -> VG s VGNode insertInitialNode ndi = do rndi <- vgInST $ newSTRef ndi (VGNode node) <- vgCreateNode rndi Set.empty Set.empty initial <- gets vgInitial incoming <- gets vgIncoming modify $ \st -> st { vgInitial = Map.insert (ndiNonterminal $ ndimOrig ndi) (VGNode node) initial , vgIncoming = IntMap.insert node Nothing incoming } return (VGNode node) -- | Create a pending edge from this node with a set of inherited and synthesized attributes createPending :: VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge createPending vgn@(VGNode n) inh syn = do -- Check if target node already exists ninhsyn <- gets vgNodeInhSyn let (pinh,psyn) = imLookup n ninhsyn let ninh = Set.union pinh inh let nsyn = Set.union psyn syn mndi <- gets vgNDI let rndi = imLookup n mndi ndi <- vgInST $ readSTRef rndi inhsynn <- gets vgInhSynNode case Map.lookup (ndiNonterminal $ ndimOrig ndi, ninh, nsyn) inhsynn of Just tn -> do when (tn == vgn) $ do traceVG $ "Source and target nodes are the same!" traceVG $ "Maybe there is a wrapper with no inherited or synthesized attributes." traceVG $ "Inh: " ++ show inh traceVG $ "Syn: " ++ show syn traceVG $ "PInh: " ++ show pinh traceVG $ "PSyn: " ++ show psyn -- tn is target node, now check if edge exists and create if not edgesr <- gets vgEdgesR case Map.lookup (vgn,tn) edgesr of Just e -> return e Nothing -> vgCreatePendingEdge vgn tn inh syn Nothing -> do -- target node does not exist, create it and then create the new edge tn <- vgCreateNode rndi ninh nsyn vgCreatePendingEdge vgn tn inh syn -- | Return an arbitrary pending edge of which the from node is ready selectPending :: VG s VGEdge selectPending = do pending <- gets vgPending incoming <- gets vgIncoming edges <- gets vgEdges let readyPend = filter (\p -> let (VGNode fr,_) = imLookup p edges in isJust $ IntMap.lookup fr incoming) $ IntSet.toList pending guard $ not $ null readyPend return $ VGEdge $ head $ readyPend -- | Get the inherited attributes of an edge getInherited :: VGEdge -> VG s (Set Identifier) getInherited (VGEdge edg) = do inhs <- gets vgInherited return $ imLookup edg inhs -- | Get the synthesized attributes of an edge getSynthesized :: VGEdge -> VG s (Set Identifier) getSynthesized (VGEdge edg) = do syns <- gets vgSynthesized return $ imLookup edg syns -- | Mark an edge as final markFinal :: VGEdge -> VG s () markFinal vgedg@(VGEdge edg) = do incoming <- gets vgIncoming edges <- gets vgEdges pending <- gets vgPending let (_,VGNode to) = imLookup edg edges modify $ \st -> st { vgIncoming = IntMap.insert to (Just vgedg) incoming , vgPending = IntSet.delete edg pending } -- | Get all productions for an edge getProductions :: VGEdge -> VG s [VGProd] getProductions vedg@(VGEdge edg) = do edges <- gets vgEdges let (VGNode fr,_) = imLookup edg edges ndis <- gets vgNDI let rndi = imLookup fr ndis ndi <- vgInST $ readSTRef rndi return $ map (\x -> VGProd (vedg,x)) [0..(length $ ndimProds ndi)-1] -- | Execute a function on the dependency graph for this production onMarkedDepGraph :: (ProdDependencyGraphM s -> ST s a) -> VGProd -> VG s a onMarkedDepGraph f (VGProd (VGEdge edg, n)) = do edges <- gets vgEdges let (VGNode fr,_) = imLookup edg edges ndis <- gets vgNDI let rndi = imLookup fr ndis ndi <- vgInST $ readSTRef rndi vgInST $ f $ (ndimProds ndi) !! n -- not efficient, but lists are usually short -- | Check whether this vertex has been marked as final isDepGraphVertexFinal :: VGProd -> Vertex -> VG s Bool isDepGraphVertexFinal (VGProd (VGEdge edg, p)) v = do edges <- gets vgEdges let (from,_) = imLookup edg edges vgDepGraphVertexFinal from p v -- | Mark these vertices final in this production setDepGraphVerticesFinal :: VGProd -> [Vertex] -> VG s () setDepGraphVerticesFinal (VGProd (VGEdge edg, p)) vs = do edges <- gets vgEdges let (_,VGNode to) = imLookup edg edges finalv <- gets vgFinalVertices let rfinalv = imLookup to finalv vgInST $ modifySTRef rfinalv $ Set.union (Set.fromList $ map (\v -> (v,p)) vs) -- | Add a child visit to this production and return the step for the execution plan addChildVisit :: VGProd -> Identifier -> VGEdge -> VG s VisitStep addChildVisit (VGProd (VGEdge edg, p)) ide (VGEdge vs) = do edges <- gets vgEdges 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] ndis <- gets vgNDI let rndi = imLookup from ndis ndi <- vgInST $ readSTRef rndi let nt = ndiNonterminal $ ndimOrig ndi return $ ChildVisit ide nt vs -- | Add a step to the execution plan of this visit addVisitStep :: VGProd -> VisitStep -> VG s () addVisitStep (VGProd (VGEdge edg, p)) st = do edges <- gets vgEdges let (VGNode fr,_) = imLookup edg edges ndis <- gets vgNDI let rndi = imLookup fr ndis ndi <- vgInST $ readSTRef rndi prodvs <- gets vgProdVisits let nont = ndiNonterminal $ ndimOrig ndi let prod = pdgProduction $ pdgmOrig $ ndimProds ndi !! p let Just rprodv = Map.lookup (nont, prod, VGEdge edg) prodvs vgInST $ modifySTRef rprodv (++ [st]) -- | Get the state of a child in a certain production getChildState :: VGProd -> Identifier -> VG s VGNode getChildState (VGProd (VGEdge edg,p)) ide = do childvs <- gets vgChildVisits let rchildv = imLookup edg childvs childv <- vgInST $ readSTRef rchildv case Map.lookup (ide,p) childv of Just (n:_) -> return n _ -> do -- Look for previous edge edges <- gets vgEdges let (VGNode from,_) = imLookup edg edges incoming <- gets vgIncoming case IntMap.lookup from incoming of Just (Just iedg) -> getChildState (VGProd (iedg,p)) ide Just Nothing -> do -- Lookup initial state ndis <- gets vgNDI let rndi = imLookup from ndis ndi <- vgInST $ readSTRef rndi let Just nt = lookup ide $ pdgChildMap $ pdgmOrig $ (ndimProds ndi) !! p vgFindInitial nt Nothing -> error "getChildState" -- | Repeat action untill mzero is encountered repeatM :: VG s () -> VG s () repeatM m = catchError (m >> repeatM m) (const $ return ()) ------------------------------------------------------------ --- Internal functions --- ------------------------------------------------------------ -- | Execute a ST action inside the VG monad vgInST :: ST s a -> VG s a vgInST = lift . lift vgEmptyState :: VGState s vgEmptyState = VGState { vgNodeNum = 0 , vgEdgeNum = 0 , vgOutgoing = IntMap.empty , vgIncoming = IntMap.empty , vgNDI = IntMap.empty , vgInhSynNode = Map.empty , vgNodeInhSyn = IntMap.empty , vgInitial = Map.empty , vgEdges = IntMap.empty , vgEdgesR = Map.empty , vgInherited = IntMap.empty , vgSynthesized = IntMap.empty , vgPending = IntSet.empty , vgChildVisits = IntMap.empty , vgFinalVertices = IntMap.empty , vgProdVisits = Map.empty } -- | Create a new node vgCreateNode :: STRef s (NontDependencyInformationM s) -> Set Identifier -> Set Identifier -> VG s VGNode vgCreateNode rndi inh syn = do num <- gets vgNodeNum outgoing <- gets vgOutgoing inhsyn <- gets vgInhSynNode ninhsyn <- gets vgNodeInhSyn ndi <- gets vgNDI finalv <- gets vgFinalVertices rout <- vgInST $ newSTRef Set.empty rfinalv <- vgInST $ newSTRef Set.empty nndi <- vgInST $ readSTRef rndi modify $ \st -> st { vgNodeNum = num + 1 , vgOutgoing = IntMap.insert num rout outgoing , vgInhSynNode = Map.insert (ndiNonterminal $ ndimOrig nndi,inh,syn) (VGNode num) inhsyn , vgNodeInhSyn = IntMap.insert num (inh,syn) ninhsyn , vgNDI = IntMap.insert num rndi ndi , vgFinalVertices = IntMap.insert num rfinalv finalv } return $ VGNode num -- | Create a new pending edge vgCreatePendingEdge :: VGNode -> VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge vgCreatePendingEdge vgn1@(VGNode n1) vgn2 inh syn = do num <- gets vgEdgeNum edges <- gets vgEdges edgesr <- gets vgEdgesR inhs <- gets vgInherited syns <- gets vgSynthesized outgoing <- gets vgOutgoing pend <- gets vgPending childv <- gets vgChildVisits rchildv <- vgInST $ newSTRef Map.empty let outr = imLookup n1 outgoing let ret = VGEdge num vgInST $ modifySTRef outr (Set.insert ret) modify $ \st -> st { vgEdgeNum = num + 1 , vgEdges = IntMap.insert num (vgn1,vgn2) edges , vgEdgesR = Map.insert (vgn1,vgn2) ret edgesr , vgPending = IntSet.insert num pend , vgInherited = IntMap.insert num inh inhs , vgSynthesized = IntMap.insert num syn syns , vgChildVisits = IntMap.insert num rchildv childv } -- Add prod visits (for constructing an execution plan) ndis <- gets vgNDI let rndi = imLookup n1 ndis ndi <- vgInST $ readSTRef rndi prodv <- gets vgProdVisits refs <- forM (ndimProds ndi) $ \prod -> do rprod <- vgInST $ newSTRef [] return ((ndiNonterminal $ ndimOrig ndi, pdgProduction $ pdgmOrig prod, ret),rprod) modify $ \st -> st { vgProdVisits = Map.union (Map.fromList refs) prodv } return $ ret -- | Check whether a vertex is marked final on this node in this production vgDepGraphVertexFinal :: VGNode -> Int -> Vertex -> VG s Bool vgDepGraphVertexFinal (VGNode n) p v = do finalv <- gets vgFinalVertices let rfinalv = imLookup n finalv curset <- vgInST $ readSTRef rfinalv if Set.member (v,p) curset then return True else do incoming <- gets vgIncoming case IntMap.lookup n incoming of Just (Just (VGEdge edg)) -> do edges <- gets vgEdges let (fr,_) = imLookup edg edges vgDepGraphVertexFinal fr p v Just Nothing -> return False Nothing -> error "This can never happen" -- | Find the initial node for a nonterminal vgFindInitial :: Identifier -> VG s VGNode vgFindInitial nt = do initial <- gets vgInitial let Just r = Map.lookup nt initial return r -- | Always succeeding IntMap lookup imLookup :: Int -> IntMap a -> a imLookup k m = let Just r = IntMap.lookup k m in r -- | Trace inside the vg monad traceVG :: String -> VG s () traceVG s = trace s (return ()) ------------------------------------------------------------ --- The kennedy warren algorithm --- ------------------------------------------------------------ {- runVG :: VG s a -> ST s a insertInitialNode :: NontDependencyInformationM s -> VG s VGNode createPending :: VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge selectPending :: VG s VGEdge getInherited :: VGEdge -> VG s (Set Identifier) getSynthesized :: VGEdge -> VG s (Set Identifier) markFinal :: VGEdge -> VG s () getProductions :: VGEdge -> VG s [VGProd] onMarkedDepGraph :: (ProdDependencyGraphM s -> ST s a) -> VGProd -> VG s a isDepGraphVertexFinal :: VGProd -> Vertex -> VG s Bool setDepGraphVerticesFinal :: VGProd -> [Vertex] -> VG s () getChildState :: VGProd -> Identifier -> VG s VGNode addChildVisit :: VGProd -> Identifier -> VGEdge -> VG s VisitStep addVisitStep :: VGProd -> VisitStep -> VG s () repeatM :: VG s () -> VG s () -} kennedyWarrenVisitM :: Set NontermIdent -> [NontDependencyInformationM s] -> VG s [Maybe Int] kennedyWarrenVisitM wr ndis = do -- Create initial nodes and edges (edges only for wrapper nodes) initvs <- forM ndis $ \ndi -> do nd <- insertInitialNode ndi let inh = Set.fromList $ ndiInh $ ndimOrig ndi let syn = Set.fromList $ ndiSyn $ ndimOrig ndi if (Set.member (ndiNonterminal $ ndimOrig $ ndi) wr) && (not (Set.null inh) || not (Set.null syn)) then do VGEdge initv <- createPending nd inh syn return $ Just initv else return Nothing -- Handle all pending edges while there are any repeatM $ do pend <- selectPending prods <- getProductions pend inhs <- getInherited pend syns <- getSynthesized pend -- Handle each production for this edge forM_ prods $ \prod -> do -- Mark all inherited attributes as final setDepGraphVerticesFinal prod (map createLhsInh . Set.toList $ inhs) -- Find depth of all synthesized child visits (vis,_) <- foldM (foldChildVisits prod) ([],0) (map createLhsSyn . Set.toList $ syns) -- Mark them as final setDepGraphVerticesFinal prod (map fst vis) -- Change the inherited child visits vis2 <- correctInhChilds prod vis -- Add all synthesized attributes that are also ready but are not needed extravis <- extraChildSyn prod vis2 setDepGraphVerticesFinal prod (map fst extravis) -- Group by visit number and do visit for every num let gvis = groupSortBy (comparing snd) $ vis2 ++ extravis forM_ gvis $ \vis3 -> do -- Split child visits from rules let (chattrs, rules) = partition isChildAttr $ map fst vis3 -- Evaluate all rules forM_ (reverse $ rules) $ \rule -> case rule of VRule r -> addVisitStep prod $ Sem r VChild c -> addVisitStep prod $ ChildIntro c _ -> return () -- Now group by child, and do a visit for each child let chs = groupSortBy (comparing getAttrChildName) $ chattrs chvs <- forM chs $ \childvs -> do -- childs :: [Vertex] let cinhs = map getAttrName $ filter isChildInh childvs let csyns = map getAttrName $ filter isChildSyn childvs let cname = getAttrChildName $ head childvs -- Insert a new pending edge for this visit curstate <- getChildState prod cname target <- createPending curstate (Set.fromList cinhs) (Set.fromList csyns) addChildVisit prod cname target -- Add child visits as simultanuous step when (not $ null chvs) $ if (length chvs == 1) then addVisitStep prod $ head chvs else addVisitStep prod $ Sim chvs -- Mark this edge as final markFinal pend -- We are done -- traceVG "Done." return initvs -- | groupBy that groups all equal (according to the function) elements instead of consequtive equal elements groupSortBy :: (a -> a -> Ordering) -> [a] -> [[a]] groupSortBy f = groupBy (\x y -> f x y == EQ) . sortBy f type ChildVisits = [(Vertex,Int)] -- | Helper function for folding over child visits foldChildVisits :: VGProd -> (ChildVisits, Int) -> Vertex -> VG s (ChildVisits, Int) foldChildVisits prod (vis,i) v = do (nvis,ni) <- findChildVisits prod v vis return (nvis, ni `max` i) -- | Recursively find all visits to childs findChildVisits :: VGProd -> Vertex -> ChildVisits -> VG s (ChildVisits, Int) findChildVisits prod v vis = do case lookup v vis of Just i -> return (vis,i) Nothing -> do final <- isDepGraphVertexFinal prod v if final then return (vis,0) else do succs <- onMarkedDepGraph (liftM Set.toList . flip graphSuccessors v . pdgmDepGraph) prod (nvis,ni) <- foldM (foldChildVisits prod) (vis,0) succs if isChildSyn v then return ((v,ni + 1) : nvis, ni + 1) else return ((v,ni) : nvis, ni) -- | Correct inherited child visits after foldChildVisits correctInhChilds :: VGProd -> ChildVisits -> VG s ChildVisits correctInhChilds prod vis = forM vis $ \(v,i) -> do if isChildInh v then do preds <- onMarkedDepGraph (liftM Set.toList . flip graphPredecessors v . pdgmDepGraph) prod let ni = foldl min 99999999 $ mapMaybe (`lookup` vis) preds return (v,ni) else if not $ isChildSyn v then do succs <- onMarkedDepGraph (liftM Set.toList . flip graphSuccessors v . pdgmDepGraph) prod let ni = foldl max (-1) $ mapMaybe (`lookup` vis) succs return (v,ni+1) else return (v,i) -- | Synthesized attributes that can also be evaluated extraChildSyn :: VGProd -> ChildVisits -> VG s ChildVisits extraChildSyn prod vis = do allpreds <- forM vis $ \(v,_) -> do if isChildInh v then do preds <- onMarkedDepGraph (liftM Set.toList . flip graphPredecessors v . pdgmDepGraph) prod return $ Set.fromList $ filter isChildSyn preds else return Set.empty lextravis <- forM (Set.toList $ Set.unions allpreds) $ \v -> do ready <- isReadyVertex prod vis v return $ maybe Nothing (\i -> Just (v,i)) ready return $ catMaybes lextravis -- | Check if a vertex can be marked final in this step (and is not final yet) and return the visit num isReadyVertex :: VGProd -> ChildVisits -> Vertex -> VG s (Maybe Int) isReadyVertex prod vis v = do final <- isDepGraphVertexFinal prod v if v `elem` (map fst vis) || final then return Nothing else do succ <- onMarkedDepGraph (flip graphSuccessors v . pdgmDepGraph) prod rd <- mapM (\x -> do case lookup x vis of Just i -> return $ Just i Nothing -> do fin <- isDepGraphVertexFinal prod x return $ if fin then Just 1 else Nothing) (Set.toList succ) if all isJust rd then return $ Just $ foldl1 max $ catMaybes rd else return $ Nothing -- | Check if this vertex is a synthesized attribute of a child isChildSyn :: Vertex -> Bool isChildSyn v = isChildAttr v && getAttrType v == Syn -- | Check if this vertex is an inherited attribute of a child isChildInh :: Vertex -> Bool isChildInh v = isChildAttr v && getAttrType v == Inh -- | Check if this vertex is an attribute of a child isChildAttr :: Vertex -> Bool isChildAttr v = isVertexAttr v && getAttrChildName v /= _LHS && getAttrType v /= Loc -- | Create lhs.inh vertex createLhsInh :: Identifier -> Vertex createLhsInh = VAttr Inh _LHS -- | Create lhs.inh vertex createLhsSyn :: Identifier -> Vertex createLhsSyn = VAttr Syn _LHS ------------------------------------------------------------ --- Construction of the execution plan --- ------------------------------------------------------------ kennedyWarrenExecutionPlan :: Options -> [NontDependencyInformationM s] -> [Maybe Int] -> Set NontermIdent -> TypeSyns -> Derivings -> VG s ExecutionPlan kennedyWarrenExecutionPlan opts ndis initvs wr typesyns derivings = do -- Loop over all nonterminals nonts <- forM (zip ndis initvs) $ \(ndi, initv) -> do -- Loop over all productions of this nonterminal prods <- forM (ndimProds ndi) $ \prod -> do -- Construct the visits for this production let inont = ndiNonterminal $ ndimOrig ndi let iprod = pdgProduction $ pdgmOrig prod prodvs <- gets vgProdVisits let thisvisits = filter (\((int,ipr,_),_) -> int == inont && ipr == iprod) $ Map.toList prodvs visits <- forM thisvisits $ \((_,_,vgedg@(VGEdge edg)),rprodvs) -> do edges <- gets vgEdges let (VGNode fr, VGNode to) = imLookup edg edges steps <- vgInST $ readSTRef rprodvs inh <- getInherited vgedg syn <- getSynthesized vgedg let kind | monadic opts = VisitMonadic | otherwise = VisitPure True return $ Visit edg fr to inh syn steps kind -- Return execution plan for this production return $ EProduction (pdgProduction $ pdgmOrig prod) (pdgParams $ pdgmOrig prod) (pdgConstraints $ pdgmOrig prod) (pdgRules $ pdgmOrig prod) (pdgChilds $ pdgmOrig prod) visits -- Find initial state for this nonterminal VGNode init <- vgFindInitial $ ndiNonterminal $ ndimOrig ndi -- Construct an environment that specifies the next visit of the states that have exactly one nextMap <- mkNextMap init prevMap <- mkPrevMap init -- Return execution plan for this nonterminal return $ ENonterminal (ndiNonterminal $ ndimOrig ndi) (ndiParams $ ndimOrig ndi) (ndiClassCtxs $ ndimOrig ndi) init initv nextMap prevMap prods (ndiRecursive $ ndimOrig ndi) (ndiHoInfo $ ndimOrig ndi) -- Return complete execution plan return $ ExecutionPlan nonts typesyns wr derivings ------------------------------------------------------------ --- Construction of the single-exit states map --- ------------------------------------------------------------ -- depth-first traversal over the graph that starts at 'init' and maintains a state 'a' -- the function 'f' can inspect the prev/next edges per state exploreGraph :: (VGNode -> Set VGEdge -> Set VGEdge -> a -> VG s a) -> VGNode -> a -> VG s a exploreGraph f (VGNode init) a0 = do exploredRef <- vgInST $ newSTRef IntSet.empty pendingRef <- vgInST $ newSTRef [init] resRef <- vgInST $ newSTRef a0 outgoingMap <- gets vgOutgoing edgesInfo <- gets vgEdges let explore = do pending <- vgInST $ readSTRef pendingRef case pending of [] -> return () (p:ps) -> do vgInST $ writeSTRef pendingRef ps explored <- vgInST $ readSTRef exploredRef if IntSet.member p explored then return () else do vgInST $ writeSTRef exploredRef (IntSet.insert p explored) case IntMap.lookup p outgoingMap of Nothing -> return () Just outRef -> case IntMap.lookup p outgoingMap of Nothing -> return () Just inRef -> do outSet <- vgInST $ readSTRef outRef inSet <- vgInST $ readSTRef inRef sol0 <- vgInST $ readSTRef resRef sol1 <- f (VGNode p) inSet outSet sol0 vgInST $ writeSTRef resRef sol1 forM_ (Set.elems outSet) $ \(VGEdge edge) -> case IntMap.lookup edge edgesInfo of Nothing -> return () Just (_,VGNode to) -> vgInST $ modifySTRef pendingRef (to :) explore explore vgInST $ readSTRef resRef mkNextMap :: Int -> VG s (Map Int StateCtx) mkNextMap start = exploreGraph f (VGNode start) Map.empty where f (VGNode nd) _ edges = updateCountMap nd edges mkPrevMap :: Int -> VG s (Map Int StateCtx) mkPrevMap start = exploreGraph f (VGNode start) Map.empty where f (VGNode nd) edges _ = updateCountMap nd edges updateCountMap :: Int -> Set VGEdge -> Map Int StateCtx -> VG s (Map Int StateCtx) updateCountMap nd edges mp = return $ Map.insert nd v mp where s = Set.size edges v | s == 0 = NoneVis | s == 1 = let [VGEdge v'] = Set.elems edges in OneVis v' | otherwise = ManyVis uuagc-0.9.42.3/src/Knuth1.hs000644 000765 000024 00000074337 12127045231 017361 0ustar00jeroenbransenstaff000000 000000 module Knuth1 where import Pretty import ExecutionPlan import CommonTypes import Control.Monad import Control.Monad.ST import Data.Maybe import Data.List import Data.STRef import Debug.Trace import Data.Array (Array) import qualified Data.Array as Array import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set -- | Trace a message in the ST monad traceST :: String -> ST s () traceST s = trace s (return ()) ------------------------------------------------------------------------------- -- Dependency graph representation ------------------------------------------------------------------------------- -- Vertices data AttrType = Inh | Syn | Loc deriving (Eq, Ord, Show) data Vertex = VAttr AttrType Identifier Identifier | VChild Identifier | VRule Identifier deriving (Eq, Ord) instance Show Vertex where show (VAttr ty ch at) = show ty ++ " @" ++ show ch ++ "." ++ show at show (VChild ch) = "Child " ++ show ch show (VRule ru) = "Rule " ++ show ru -- | Check if a vertex is an attribute isVertexAttr :: Vertex -> Bool isVertexAttr (VAttr _ _ _) = True isVertexAttr _ = False -- | Get the child name of an attribute getAttrChildName :: Vertex -> Identifier getAttrChildName (VAttr _ n _) = n -- | Set the child name of an attribute setAttrChildName :: Vertex -> Identifier -> Vertex setAttrChildName (VAttr t _ a) n = VAttr t n a -- | Get the type of an attribute getAttrType :: Vertex -> AttrType getAttrType (VAttr t _ _) = t -- | Get the name of an attribute getAttrName :: Vertex -> Identifier getAttrName (VAttr _ _ a) = a -- Edges type Edge = (Vertex, Vertex) -- Internal representation of a vertex type IVertex = Int type IEdge = (IVertex, IVertex) -- Representation of the graph data DependencyGraph s = DependencyGraph { vertexIMap :: Map Vertex IVertex , vertexOMap :: Array IVertex Vertex , successors :: Array IVertex (STRef s (Set IVertex)) , predecessors :: Array IVertex (STRef s (Set IVertex)) } ------------------------------------------------------------------------------- -- Dependency graph fuctions ------------------------------------------------------------------------------- -- | Construct a dependency graph graphConstruct :: [Vertex] -> ST s (DependencyGraph s) graphConstruct vs = do let nv = length vs let ivs = [0..nv-1] let ivb = (0,nv-1) let vimap = Map.fromList (zip vs ivs) let vomap = Array.array ivb (zip ivs vs) succs <- replicateM nv (newSTRef Set.empty) preds <- replicateM nv (newSTRef Set.empty) let su = Array.array ivb (zip ivs succs) let pr = Array.array ivb (zip ivs preds) let graph = DependencyGraph { vertexIMap = vimap , vertexOMap = vomap , successors = su , predecessors = pr } return graph -- | Construct a transitivelly closed graph graphConstructTRC :: [Vertex] -> [Edge] -> ST s (DependencyGraph s) graphConstructTRC vs es = do g <- graphConstruct vs -- Insert all initial edges graphInsertEdgesTRC g es return g -- | Return all successors of a vertex graphSuccessors :: DependencyGraph s -> Vertex -> ST s (Set Vertex) graphSuccessors g v = do sucs <- readSTRef $ (successors g) Array.! (graphGetIVertex g v) return $ Set.map (graphGetVertex g) sucs -- | Return all predecessors of a vertex graphPredecessors :: DependencyGraph s -> Vertex -> ST s (Set Vertex) graphPredecessors g v = do sucs <- readSTRef $ (predecessors g) Array.! (graphGetIVertex g v) return $ Set.map (graphGetVertex g) sucs -- | Check if the graph contains an edge graphContainsEdge :: DependencyGraph s -> Edge -> ST s Bool graphContainsEdge g (v1,v2) = do let iv1 = graphGetIVertex g v1 let iv2 = graphGetIVertex g v2 sucs <- readSTRef $ (successors g) Array.! iv1 return $ iv2 `Set.member` sucs -- | Insert an edge in the graph graphInsert :: DependencyGraph s -> Edge -> ST s () graphInsert g (v1,v2) = do let iv1 = graphGetIVertex g v1 let iv2 = graphGetIVertex g v2 -- Add v2 to the successors of v1 and v1 to predecessors of v2 modifySTRef ((successors g) Array.! iv1) $ Set.insert iv2 modifySTRef ((predecessors g) Array.! iv2) $ Set.insert iv1 -- | Insert an edge in a transtive closed graph and return all other edges that were -- added due to transtivity graphInsertTRC :: DependencyGraph s -> Edge -> ST s [(IVertex, Set IVertex)] graphInsertTRC g (v1,v2) = do let iv1 = graphGetIVertex g v1 let iv2 = graphGetIVertex g v2 -- Read predecessors of v1 and successors of v2 pred1 <- readSTRef $ (predecessors g) Array.! iv1 succ2 <- readSTRef $ (successors g) Array.! iv2 -- First insert all edges from v1 let rsucc1 = (successors g) Array.! iv1 succ1 <- readSTRef rsucc1 let add1 = succ2 `Set.difference` succ1 modifySTRef rsucc1 (Set.union add1 . Set.insert iv2) -- All edges to v2 let rpred2 = (predecessors g) Array.! iv2 modifySTRef rpred2 (Set.union pred1 . Set.insert iv1) -- Connect every predecessor of v1 to every successor of v2 sucl <- forM (Set.toList pred1) $ \pred -> do -- Connect pred to v2 and all successors of v2 let rsucc = (successors g) Array.! pred csucc <- readSTRef rsucc let cadd = (Set.insert iv2 succ2) `Set.difference` csucc modifySTRef rsucc (Set.union cadd) return (pred, cadd) -- Connect every successor of v2 to every predecessor of v1 forM_ (Set.toList succ2) $ \succ -> do -- Connect succ to v1 and all predecessors of v1 let rpred = (predecessors g) Array.! succ cpred <- readSTRef rpred let cadd = (Set.insert iv1 pred1) `Set.difference` cpred modifySTRef rpred (Set.union cadd) -- Create return return $ (iv1,add1) : sucl -- | Return all vertices of the graph graphVertices :: DependencyGraph s -> ST s [Vertex] graphVertices = return . Array.elems . vertexOMap -- | Return all edges of the graph graphEdges :: DependencyGraph s -> ST s [Edge] graphEdges g = do let vs = Array.indices $ vertexOMap g perv <- forM vs $ \v -> do let rv = graphGetVertex g v sucs <- readSTRef $ (successors g) Array.! v let sucl = Set.toList sucs return $ map ((,) rv . graphGetVertex g) sucl return $ concat perv -- | Insert a list of edges in the graph graphInsertEdges :: DependencyGraph s -> [Edge] -> ST s () graphInsertEdges g ed = mapM_ (graphInsert g) ed -- | Insert a list of edges in the graph and return all other edges that -- were added due to transitivity graphInsertEdgesTRC :: DependencyGraph s -> [Edge] -> ST s [Edge] graphInsertEdgesTRC g ed = do -- rets :: [[(IVertex, Set IVertex)]] rets <- mapM (graphInsertTRC g) ed -- Combine all successor sets let f :: (IVertex, (Set IVertex)) -> [(IVertex, IVertex)] f (v,s) = map ((,) v) (Set.toList s) let comb :: [(IVertex, IVertex)] comb = concatMap (concatMap f) rets -- Construct edges from this return $ map (graphGetEdge g) $ comb -- | Check whether the graph is cyclic graphIsCyclic :: DependencyGraph s -> ST s Bool graphIsCyclic g = do s <- graphCyclicVertices g return $ not $ Set.null s graphCyclicVertices :: DependencyGraph s -> ST s (Set IVertex) graphCyclicVertices g = do vs <- return $ Array.indices $ vertexOMap g sets <- forM vs $ \v -> do sucs <- readSTRef $ (successors g) Array.! v let res | v `Set.member` sucs = Set.singleton v | otherwise = Set.empty return res return (Set.unions sets) graphCyclicVerticesExt :: DependencyGraph s -> ST s [Vertex] graphCyclicVerticesExt g = (map (graphGetVertex g) . Set.elems) `fmap` graphCyclicVertices g -- | Get internal representation of a vertex graphGetIVertex :: DependencyGraph s -> Vertex -> IVertex graphGetIVertex g v = vertexIMap g Map.! v -- | Get external representation of a vertex graphGetVertex :: DependencyGraph s -> IVertex -> Vertex graphGetVertex g v = vertexOMap g Array.! v -- | Get external representation of an edge graphGetEdge :: DependencyGraph s -> IEdge -> Edge graphGetEdge g (v1,v2) = (graphGetVertex g v1, graphGetVertex g v2) -- | Check if the graph is transitively closed graphIsTRC :: DependencyGraph s -> ST s Bool graphIsTRC g = do let vs = Array.indices $ vertexOMap g bs <- forM vs $ \v -> do succs <- readSTRef $ (successors g) Array.! v bs2 <- forM (Set.toList succs) $ \v2 -> do succs2 <- readSTRef $ (successors g) Array.! v2 return $ succs2 `Set.isSubsetOf` succs return $ and bs2 return $ and bs -- | Check consistency of the graph (successor and predecessor sets) graphCheckConsistency :: DependencyGraph s -> ST s Bool graphCheckConsistency g = do let vs = Array.indices $ vertexOMap g ret <- forM vs $ \v -> do -- V must appear in every predecessor set of its successors succs <- readSTRef $ (successors g) Array.! v r1 <- forM (Set.toList succs) $ \succ -> do preds2 <- readSTRef $ (predecessors g) Array.! succ return (v `Set.member` preds2) -- V must appear in every successor set of its predecessors preds <- readSTRef $ (predecessors g) Array.! v r2 <- forM (Set.toList preds) $ \pred -> do succs2 <- readSTRef $ (successors g) Array.! pred return (v `Set.member` succs2) return $ and $ r1 ++ r2 return $ and $ ret -- | Add edges to the graph so that it is topologically sorted (this will not work if graph is cyclic) graphTopSort :: DependencyGraph s -> ST s [Edge] graphTopSort g = do let vs = Array.indices $ vertexOMap g order <- foldM (graphTopSort' g) [] vs mb <- forM (zip order (tail order)) $ \(v1,v2) -> do let edg = graphGetEdge g (v2,v1) -- order is actually reverse order ce <- graphContainsEdge g edg if ce then return Nothing else do graphInsert g edg return $ Just edg return $ catMaybes mb -- | Helper function for graphTopSort graphTopSort' :: DependencyGraph s -> [IVertex] -> IVertex -> ST s [IVertex] graphTopSort' g prev cur | cur `elem` prev = return prev | otherwise = do pred <- readSTRef $ (predecessors g) Array.! cur order <- foldM (graphTopSort' g) prev $ Set.toList pred return $ cur : order ------------------------------------------------------------------------------- -- Dependency graph information wrappers ------------------------------------------------------------------------------- -- | Special wrapper for nonterminal dependency graphs (so that we can easily add other meta-information) data NontDependencyGraph = NontDependencyGraph { ndgVertices :: [Vertex] , ndgEdges :: [Edge] } -- | Special wrapper for production dependency graphs, including mapping between child names and nonterminals data ProdDependencyGraph = ProdDependencyGraph { pdgVertices :: [Vertex] , pdgEdges :: [Edge] , pdgRules :: ERules , pdgChilds :: EChildren , pdgProduction :: Identifier , pdgChildMap :: [(Identifier, Identifier)] , pdgConstraints :: [Type] , pdgParams :: [Identifier] } -- | Represent all information from the dependency graphs for a nonterminal data NontDependencyInformation = NontDependencyInformation { ndiNonterminal :: Identifier , ndiParams :: [Identifier] , ndiInh :: [Identifier] , ndiSyn :: [Identifier] , ndiDepGraph :: NontDependencyGraph , ndiProds :: [ProdDependencyGraph] , ndiRecursive :: Bool , ndiHoInfo :: HigherOrderInfo , ndiClassCtxs :: ClassContext } --- Monadic versions of these records, for use with the ST monad -- | Monadic wrapper of NontDependencyGraph data NontDependencyGraphM s = NontDependencyGraphM { ndgmDepGraph :: DependencyGraph s , ndgmOrig :: NontDependencyGraph } -- | Monadic wrapper of ProdDependencyGraph data ProdDependencyGraphM s = ProdDependencyGraphM { pdgmDepGraph :: DependencyGraph s , pdgmOrig :: ProdDependencyGraph } -- | Monadic wrapper of NontDependencyInformation data NontDependencyInformationM s = NontDependencyInformationM { ndimOrig :: NontDependencyInformation , ndimDepGraph :: NontDependencyGraphM s , ndimProds :: [ProdDependencyGraphM s] } -- | Convert a NontDependencyGraph to the corresponding monadic version mkNontDependencyGraphM :: NontDependencyGraph -> ST s (NontDependencyGraphM s) mkNontDependencyGraphM ndg = do g <- graphConstructTRC (ndgVertices ndg) (ndgEdges ndg) return $ NontDependencyGraphM { ndgmDepGraph = g , ndgmOrig = ndg } -- | Convert a ProdDependencyGraph to the corresponding monadic version mkProdDependencyGraphM :: Bool -> ProdDependencyGraph -> ST s (ProdDependencyGraphM s) mkProdDependencyGraphM trc pdg = do g <- if trc then graphConstructTRC (pdgVertices pdg) (pdgEdges pdg) else do g <- graphConstruct (pdgVertices pdg) mapM_ (graphInsert g) (pdgEdges pdg) return g return $ ProdDependencyGraphM { pdgmDepGraph = g , pdgmOrig = pdg } -- | Convert a NontDependencyInformation to the corresponding monadic version mkNontDependencyInformationM :: NontDependencyInformation -> ST s (NontDependencyInformationM s) mkNontDependencyInformationM ndi = do dg <- mkNontDependencyGraphM (ndiDepGraph ndi) prods <- mapM (mkProdDependencyGraphM True) (ndiProds ndi) return $ NontDependencyInformationM { ndimOrig = ndi , ndimDepGraph = dg , ndimProds = prods } -- | Construct the production graphs from the transitivelly closed graphs undoTransitiveClosure :: [NontDependencyInformationM s] -> ST s [NontDependencyInformationM s] undoTransitiveClosure ndis = do edgesl <- mapM (\ndi -> graphEdges (ndgmDepGraph $ ndimDepGraph ndi)) ndis let edges = concat edgesl forM ndis $ \ndi -> do prods <- mapM (mkProdDependencyGraphM False) (ndiProds $ ndimOrig ndi) forM_ (zip prods (ndimProds ndi)) $ \(nprod,oprod) -> do -- All possible edges let possa = do (v1,v2) <- edges -- Take a child of this nonterminal type guard $ isVertexAttr v1 guard $ isVertexAttr v2 let tp = getAttrChildName v1 (ch,chtp) <- pdgChildMap $ pdgmOrig nprod guard $ tp == chtp -- Construct edge as it should be in the production graph let nv1 = setAttrChildName v1 ch let nv2 = setAttrChildName v2 ch return (nv1, nv2) toadd <- filterM (graphContainsEdge (pdgmDepGraph oprod)) possa graphInsertEdges (pdgmDepGraph nprod) toadd return $ NontDependencyInformationM { ndimOrig = ndimOrig ndi , ndimDepGraph = ndimDepGraph ndi , ndimProds = prods } ------------------------------------------------------------------------------- -- Knuth-1 algorithm ------------------------------------------------------------------------------- -- | Combine the dependency and nonterminal graphs using Knuth-1 -- this function assumes that the nonterminal graphs initially contains no edges knuth1 :: [NontDependencyInformationM s] -> ST s () knuth1 ndis = do -- Create initial list of pending edges for each ndi per production (initially all prod edges) -- pndis :: [([[Edge]], NontDependencyInformation)] pndis <- forM ndis $ \ndi -> do ipend <- mapM (graphEdges . pdgmDepGraph) . ndimProds $ ndi return (ipend, ndi) knuth1' pndis -- | Helper function for |knuth1| which repeats the process until we are done knuth1' :: [([[Edge]], NontDependencyInformationM s)] -> ST s () knuth1' ndis = do -- Add edges from the production graphs to the nonterminal graph -- ndis' :: [[Edge]] ndis' <- mapM addProdNont ndis -- List of all newly added edges -- ntedge :: [Edge] let pntedge = concat ndis' -- Add backedges --bedges <- addBackEdges ndis -- All added nonterminal edges let ntedge = pntedge -- ++ bedges if null ntedge -- When no new edges have been added we are done then return () else do -- Otherwise, the next step is to add edges from nonterminal to production graphs -- ndis'' :: [[[Edge]]] ndis'' <- mapM (\(_,x) -> addNontProd True (ntedge, x)) ndis -- List of new states (production edges + dependency graphs) -- nndis' :: [([[Edge]], NontDependencyInformation)] nndis' <- zipWithM (\(_,ndi) me -> return (me, ndi)) ndis ndis'' if any (not . null) ndis'' -- We have added some edges, so continue the process then knuth1' nndis' -- No new edges added, we are done else return () -- | Add pending edges from the production graphs to the nonterminal graph -- and return the list of newly added nonterminal edges addProdNont :: ([[Edge]], NontDependencyInformationM s) -> ST s [Edge] addProdNont (pending, ndi) = do -- Unwrapping of the records let nontDepGraph = ndimDepGraph ndi let nontGraph = ndgmDepGraph nontDepGraph -- nub the list because multiple productions can result in the same new edges let possa = nub $ do (v1,v2) <- concat pending -- Take only edges from syn.lhs to inh.lhs guard $ isVertexAttr v1 guard $ getAttrChildName v1 == _LHS guard $ getAttrType v1 == Syn guard $ isVertexAttr v2 guard $ getAttrChildName v2 == _LHS guard $ getAttrType v2 == Inh -- Construct edge as it should be in nonterminal graph let nv1 = setAttrChildName v1 (ndiNonterminal $ ndimOrig ndi) let nv2 = setAttrChildName v2 (ndiNonterminal $ ndimOrig ndi) return (nv1, nv2) -- Edges that are not in the nonterminal graph yet toadd <- filterM (\e -> return not `ap` graphContainsEdge nontGraph e) possa -- Check whether new edges are to be added and return the added edges when (not $ null toadd) $ do graphInsertEdgesTRC nontGraph toadd return () return toadd -- | Add edges from the nonterminal graphs to the production graphs -- and return the list of newly added production edges and the updated graph addNontProd :: Bool -> ([Edge], NontDependencyInformationM s) -> ST s [[Edge]] addNontProd trc (pending, ndi) = do -- Just call the helper function for each nonterminal mapM (addNontProd' trc pending) (ndimProds ndi) -- | Helper function for |addNontProd| for a single production addNontProd' :: Bool -> [Edge] -> ProdDependencyGraphM s -> ST s [Edge] addNontProd' trc pend pdg = do -- Unwrapping of the records prodGraph <- return $ pdgmDepGraph pdg -- Construct all possible new edges let possa = do (v1,v2) <- pend -- Take a child of this nonterminal type guard $ isVertexAttr v1 guard $ isVertexAttr v2 let tp = getAttrChildName v1 (ch,chtp) <- pdgChildMap $ pdgmOrig pdg guard $ tp == chtp -- Construct edge as it should be in the production graph let nv1 = setAttrChildName v1 ch let nv2 = setAttrChildName v2 ch return (nv1, nv2) -- Edges that are not in the production graph yet toadd <- filterM (\e -> return not `ap` graphContainsEdge prodGraph e) possa -- Check whether new edges are to be added and return the result if null toadd then return [] else do -- Insert all edges and return transitive edges that are added in this process ret <- if trc then graphInsertEdgesTRC prodGraph toadd else do mapM_ (graphInsert prodGraph) toadd return [] -- Debug output --mapM_ (\edge -> traceST $ "Adding production edge " ++ show edge) toadd return ret -- | Add the "back edges" to the nonterminal graphs for creating a global ordering addBackEdges :: [([[Edge]], NontDependencyInformationM s)] -> ST s [Edge] addBackEdges ndis = do -- gather all backedges lBackEdges <- forM ndis $ \(aedg,ndi) -> do -- For every production bs <- forM (zip aedg (ndimProds ndi)) $ \(edg,prod) -> do -- Filter out the backedges return $ do (v1,v2) <- edg -- Backedges are from inh.ch to syn.ch guard $ isVertexAttr v1 guard $ getAttrChildName v1 /= _LHS guard $ getAttrType v1 == Inh guard $ isVertexAttr v2 guard $ getAttrChildName v2 /= _LHS guard $ getAttrType v2 == Syn guard $ getAttrChildName v1 == getAttrChildName v2 -- Find the correct child name (ch,chtp) <- pdgChildMap $ pdgmOrig prod let tp = getAttrChildName v1 guard $ tp == ch -- Construct the edge as it should be in the nonterminal graph let nv1 = setAttrChildName v1 chtp let nv2 = setAttrChildName v2 chtp return (nv1, nv2) return $ foldl' union [] bs -- Concatenate all lists of backedges let backedges = foldl' union [] lBackEdges -- Add backedges to every nonterminal graph ret <- forM ndis $ \(_,ndi) -> do -- Find the backedges for this nonterminal let nont = ndiNonterminal . ndimOrig $ ndi let thisbe = filter ((==) nont . getAttrChildName . fst) backedges -- Add them to the graph graphInsertEdgesTRC (ndgmDepGraph . ndimDepGraph $ ndi) thisbe return $ backedges ++ concat ret -- | Add all resulting edges from a topsort on the nonterminal graph to the production graph -- this will ignore edges that will make the graph cyclic addTopSortEdges :: [Edge] -> ProdDependencyGraphM s -> ST s () addTopSortEdges pend pdg = do -- Unwrapping of the records prodGraph <- return $ pdgmDepGraph pdg -- Construct all possible new edges let possa = do (v1,v2) <- pend -- Take a child of this nonterminal type guard $ isVertexAttr v1 guard $ isVertexAttr v2 let tp = getAttrChildName v1 (ch,chtp) <- pdgChildMap $ pdgmOrig pdg guard $ tp == chtp -- Construct edge as it should be in the production graph let nv1 = setAttrChildName v1 ch let nv2 = setAttrChildName v2 ch return (nv1, nv2) -- Edges that are not in the production graph yet forM_ possa $ \(v1,v2) -> do e1 <- graphContainsEdge prodGraph (v1,v2) e2 <- graphContainsEdge prodGraph (v2,v1) when (not $ e1 || e2) $ do graphInsertTRC prodGraph (v1,v2) return () uuagc-0.9.42.3/src/Parser.hs000644 000765 000024 00000061210 12127045231 017425 0ustar00jeroenbransenstaff000000 000000 module Parser where import Data.Maybe import UU.Parsing import UU.Parsing.Machine(RealParser(..),RealRecogn(..),anaDynE,mkPR) import ConcreteSyntax import CommonTypes import Patterns import UU.Pretty(text,PP_Doc,empty,(>-<)) import TokenDef import Data.List (intersperse) import Data.Char import Scanner (Input(..),scanLit,input) import Data.List import Expression import Macro --marcos import UU.Scanner.Token import UU.Scanner.TokenParser import UU.Scanner.GenToken import UU.Scanner.GenTokenOrd import UU.Scanner.GenTokenParser import UU.Scanner.Position import UU.Scanner.TokenShow() import System.Directory import System.FilePath import HsTokenScanner import Options import Scanner(lowercaseKeywords) type AGParser = AnaParser Input Pair Token Pos pIdentifier, pIdentifierU, pIdentifierExcl :: AGParser Identifier pIdentifierU = uncurry Ident <$> pConidPos -- Jeroen (3-10-2012): for some reason using pKeywordAsIdent -- drastically slows down parsing of some of my AG files, as -- in: I thought there was some infinite loop in there, but I -- guess that eventually it could have given an answer. So -- probably this does generate a lot of ambiguity. pIdentifier = pIdentifierExcl -- <|> pKeywordAsIdent pIdentifierExcl = uncurry Ident <$> pVaridPos -- see Scanner.lowercaseKeywords for the list of keywords that may -- be used as an identifier. To prevent ambiguities, it's probably -- sufficient when the keyword is always followed by a token that -- can never follow an identifier for any possible prefix. pKeywordAsIdent :: AGParser Identifier pKeywordAsIdent = pAny (\nm -> Ident nm <$> pKeyPos nm) lowercaseKeywords parseAG :: Options -> [FilePath] -> String -> IO (AG,[Message Token Pos]) parseAG opts searchPath file = do (es,_,_,_,mesg) <- parseFile False opts searchPath file return (AG es, mesg) --marcos parseAGI :: Options -> [FilePath] -> String -> IO (AG, Maybe String) parseAGI opts searchPath file = do (es,_,_,ext,_) <- parseFile True opts searchPath file return (AG es, ext) depsAG :: Options -> [FilePath] -> String -> IO ([String], [Message Token Pos]) depsAG opts searchPath file = do (_,_,fs,_,mesgs) <- parseFile False opts searchPath file return (tail fs, mesgs) -- first file is always the file itself -- marcos: added the parameter 'agi' and the 'ext' part parseFile :: Bool -> Options -> [FilePath] -> String -> IO ([Elem],[String],[String], Maybe String,[Message Token Pos ]) parseFile agi opts searchPath filename = do file <- resolveFile opts searchPath filename txt <- readFile file let searchPath' = takeDirectory file : searchPath -- search first relative to the including file litMode = ".lag" `isSuffixOf` file (files,text) = if litMode then scanLit txt else ([],txt) tokens = input opts (initPos file) text steps = parse (pElemsFiles agi) tokens stop (_,fs,_,_,_) = null fs cont (es,fs,allfs,ext,msg) = do res <- mapM (parseFile agi opts searchPath') fs let (ess,fss,allfss,_, msgs) = unzip5 res return (concat ess ++ es, concat fss, allfs ++ concat allfss, ext, msg ++ concat msgs) let (Pair (es,fls,ext) _ ,mesg) = evalStepsMessages steps loopp stop cont (es,files ++ fls,[file], ext,mesg) where -- -- Option dependent AG Parsers inlined here -- to have access to the opts -- while retaining sharing -- pElemsFiles :: Bool -> AGParser ([Elem],[String],Maybe String) pElemsFiles agi = pFoldr (($),([],[],Nothing)) pElem' where pElem' = addElem <$> pElem <|> pINCLUDE *> (addInc <$> pStringPos) <|> pEXTENDS *> (addExt <$> pStringPos) addElem e (es,fs,ext) = (e:es, fs, ext) addInc (fn,_) (es,fs,ext) | noIncludes opts = (es, fs, ext) -- skip includes | otherwise = (es,fn:fs, ext) addExt (fn,_) (es,fs,ext) | noIncludes opts = (es, fs, ext) -- skip includes | otherwise = if agi then (es,fs, Just fn) else (es,fn:fs, ext) --marcos pCodescrapL = (\(ValToken _ str pos) -> (str, pos))<$> parseScrapL "a code block" parseScrapL :: AGParser Token parseScrapL = let p acc = (\k (Input pos str next) -> let (sc,rest) = case next of Just (t@(ValToken TkTextln _ _), rs) -> (t,rs) _ -> let (tok,p2,inp2) = codescrapL pos str in (tok, input opts p2 inp2) steps = k ( rest) in (val (acc sc) steps) ) in anaDynE (mkPR (P (p ), R (p (const id)))) pElems :: AGParser Elems pElems = pList_ng pElem pComplexType = List <$> pBracks pTypeEncapsulated <|> Maybe <$ pMAYBE <*> pType <|> Either <$ pEITHER <*> pType <*> pType <|> Map <$ pMAP <*> pTypePrimitive <*> pType <|> IntMap <$ pINTMAP <*> pType <|> OrdSet <$ pSET <*> pType <|> IntSet <$ pINTSET <|> tuple <$> pParens (pListSep pComma field) where field = (,) <$> ((Just <$> pIdentifier <* pTypeColon) `opt` Nothing) <*> pTypeEncapsulated tuple xs = Tuple [(fromMaybe (Ident ("x"++show n) noPos) f, t) | (n,(f,t)) <- zip [1..] xs ] pOptClassContext' :: AGParser ClassContext pOptClassContext' | ocaml opts = pSucceed [] | otherwise = pOptClassContext pTyVars :: AGParser [Identifier] pTyVars | ocaml opts = return <$> pTypeVar <|> pSucceed [] <|> pParens (pListSep pComma pTypeVar) | otherwise = pList pIdentifier pElem :: AGParser Elem pElem = Data <$> (pDATA <|> pTYPE) <*> pOptClassContext' <*> pNontSet <*> pTyVars <*> pOptAttrs <*> pAlts <*> pSucceed False <|> Attr <$> pATTR <*> pOptClassContext' <*> pNontSet <*> pOptQuantifiers <*> pAttrs <|> Type <$> pTYPE <*> pOptClassContext' <*> pTypeCon <*> pTyVars <* pEquals <*> pComplexType <|> Sem <$> pSEM <*> pOptClassContext' <*> pNontSet <*> pOptAttrs <*> pOptQuantifiers <*> pSemAlts <|> Set <$> pSET <*> pTypeCon <*> ( False <$ pEquals <|> True <$ pColon ) <*> pNontSet <|> Deriving <$> pDERIVING <*> pNontSet <* pColon <*> pListSep pComma pIdentifierU <|> Wrapper <$> pWRAPPER <*> pNontSet <|> Nocatas <$> pNOCATAS <*> pNontSet <|> Pragma <$> pPRAGMA <*> pList1 pIdentifier <|> Module <$> pMODULE <*> pCodescrap' <*> pCodescrap' <*> pCodescrap' <|> codeBlock <$> pBlockKind <*> ((Just <$ pATTACH <*> pTypeCon) <|> pSucceed Nothing) <*> pCodeBlock "a statement" where codeBlock knd mbNt (txt,pos) = Txt pos knd mbNt (lines txt) pBlockKind :: AGParser BlockKind pBlockKind = BlockPragma <$ pOPTPRAGMAS <|> BlockImport <$ pIMPORTS <|> BlockMain <$ pTOPLEVEL -- block is moved to the toplevel ("main") module when "sepsemmods" is used <|> BlockData <$ pDATABLOCK <|> BlockRec <$ pRECBLOCK <|> pSucceed BlockOther pAttrs :: AGParser Attrs pAttrs = Attrs <$> pOBrackPos <*> (concat <$> pList pInhAttrNames "inherited attribute declarations") <* pBar <*> (concat <$> pList pAttrNames "chained attribute declarations" ) <* pBar <*> (concat <$> pList pAttrNames "synthesised attribute declarations" ) <* pCBrack <|> (\ds -> Attrs (fst $ head ds) [n | (_,(nms,_,_)) <- ds, n <- nms] [n | (_,(_,nms,_)) <- ds, n <- nms] [n | (_,(_,_,nms)) <- ds, n <- nms]) <$> pList1 pSingleAttrDefs pSingleAttrDefs :: AGParser (Pos, (AttrNames, AttrNames, AttrNames)) pSingleAttrDefs = (\p is -> (p, (is,[],[]))) <$> pINH <*> pList1Sep pComma pSingleInhAttrDef <|> (\p is -> (p, ([],[],is))) <$> pSYN <*> pList1Sep pComma pSingleSynAttrDef <|> (\p is -> (p, ([],is,[]))) <$> pCHN <*> pList1Sep pComma pSingleChnAttrDef pSingleInhAttrDef :: AGParser (Identifier,Type,(String,String,String)) pSingleInhAttrDef = (\v tp -> (v,tp,("","",""))) <$> pAttrIdentifier <* pTypeColon <*> pTypeOrSelf "inh attribute declaration" pSingleSynAttrDef :: AGParser (Identifier,Type,(String,String,String)) pSingleSynAttrDef = (\v u tp -> (v,tp,u)) <$> pAttrIdentifier <*> pUse <* pTypeColon <*> pTypeOrSelf "syn attribute declaration" pSingleChnAttrDef :: AGParser (Identifier,Type,(String,String,String)) pSingleChnAttrDef = (\v tp -> (v,tp,("","",""))) <$> pAttrIdentifier <* pTypeColon <*> pTypeOrSelf "chn attribute declaration" pOptAttrs :: AGParser Attrs pOptAttrs = pAttrs `opt` Attrs noPos [] [] [] pInhAttrNames :: AGParser AttrNames pInhAttrNames = (\vs tp -> map (\v -> (v,tp,("","",""))) vs) <$> pAttrIdentifiers <* pTypeColon <*> pTypeOrSelf "attribute declarations" pAttrNames :: AGParser AttrNames pAttrNames = (\vs use tp -> map (\v -> (v,tp,use)) vs) <$> pAttrIdentifiers <*> pUse <* pTypeColon <*> pTypeOrSelf "attribute declarations" pAlt :: AGParser Alt pAlt = (Alt <$> pBar <*> pSimpleConstructorSet <*> (pList1_ng pTypeVar <* pDot <|> pSucceed []) <*> pFields <*> pMaybeMacro "a datatype alternative") pAlts :: AGParser Alts pAlts = pList_ng pAlt "datatype alternatives" pFields :: AGParser Fields pFields = concat <$> pList_ng pField "fields" pField :: AGParser Fields pField = (\nms tp -> map (\nm -> FChild nm tp) nms) <$> pAttrIdentifiers <* pTypeColon <*> pType <|> (\s -> [FChild (Ident (mklower $ getName s) (getPos s)) (NT s [] False)]) <$> pIdentifierU <|> (\t -> [FCtx [t]]) <$ pSmallerEqual <*> pTypePrimitive pSemAlt :: AGParser SemAlt pSemAlt = SemAlt <$> pBar <*> pConstructorSet <*> pSemDefs "SEM alternative" pSemAlts :: AGParser SemAlts pSemAlts = pList pSemAlt "SEM alternatives" pSemDef :: AGParser [SemDef] pSemDef = (\x y fs -> map (\f -> f x y) fs) <$> pMaybeRuleName <*> pFieldIdentifier <*> pList1 pAttrDef <|> pLOC *> pList1 pLocDecl <|> pINST *> pList1 pInstDecl <|> pSEMPRAGMA *> pList1 (SemPragma <$> pNames) <|> (\n e -> [AugmentDef n e]) <$ pAugmentToken <*> pAttrIdentifier <* pAssign <*> pExpr <|> (\n e -> [AroundDef n e]) <$ pAROUND <*> pAttrIdentifier <* pAssign <*> pExpr <|> (\a b -> [AttrOrderBefore a [b]]) <$> pList1 pAttrOrIdent <* pSmaller <*> pAttrOrIdent <|> (\sources target nt expr -> [MergeDef target nt sources expr]) <$ pMERGE <*> (pList1_ng pIdentifier <* pAS <|> pSucceed []) <*> pIdentifier <* pTypeColon <*> pIdentifierU <* pAssign <*> pExpr <|> (\mbNm pat (owrt,pos,pur,eager) exp -> [Def pos mbNm (pat ()) exp owrt pur eager]) <$> pMaybeRuleName <*> pPattern (const <$> pAttr) <*> pRuleSym <*> pExpr pMaybeRuleName :: AGParser (Maybe Identifier) pMaybeRuleName = (Just <$> pIdentifier <* pColon "rule name") <|> pSucceed Nothing pAttrDef :: AGParser (Maybe Identifier -> Identifier -> SemDef) pAttrDef = (\pat (owrt,pos,pur,eager) exp mbNm fld -> Def pos mbNm (pat fld) exp owrt pur eager) <$ pDot <*> pattern <*> pRuleSym <*> pExpr where pattern = pPattern pVar <|> (\ir a fld -> ir $ Alias fld a (Underscore noPos)) <$> ((Irrefutable <$ pTilde) `opt` id) <*> pAttrIdentifier pLocDecl :: AGParser SemDef pLocDecl = pDot <**> (pIdentifier <**> (pTypeColon <**> ( (\(tp,pos) _ ident _ -> TypeDef pos ident tp) <$> pLocType <|> (\ref _ ident _ -> UniqueDef ident ref) <$ pUNIQUEREF <*> pIdentifier ))) pLocType :: AGParser (Type, Pos) pLocType = (\u -> (Haskell $ getName u, getPos u)) <$> pTypeCon <|> (\(s,p) -> (Haskell s,p)) <$> pCodescrap "a type" pInstDecl :: AGParser SemDef pInstDecl = (\ident tp -> TypeDef (getPos ident) ident tp) <$ pDot <*> pIdentifier <* pTypeColon <*> pTypeNt pSemDefs :: AGParser SemDefs pSemDefs = concat <$> pList_ng pSemDef "attribute rules" pExpr :: AGParser Expression pExpr = (\(str,pos) -> Expression pos (lexTokens pos str)) <$> pCodescrapL "an expression" pTypeColon :: AGParser Pos pTypeColon = if doubleColons opts then pDoubleColon else pColon --marcos pMaybeMacro :: AGParser MaybeMacro pMaybeMacro = Just <$ pDoubleArrow <*> pMacro <|> pSucceed Nothing pMacro :: AGParser Macro pMacro = Macro <$> pIdentifierU <*> pList1 pMacroChild "macro" pMacroChild :: AGParser MacroChild pMacroChild = (pIdentifier <* pEquals) <**> (flip RuleChild <$> pMacro <|> flip ChildChild <$> pIdentifier <|> flip ValueChild <$> pCodescrap' ) pTypeNt :: AGParser Type pTypeNt = ((\nt -> mkNtType nt []) <$> pTypeCon "nonterminal name (no brackets)") <|> (pParens (mkNtType <$> pTypeCon <*> pList pTypeHaskellAnyAsString) "nonterminal name with parameters (using parenthesis)") pTypeCon :: AGParser Identifier pTypeCon | ocaml opts = pIdentifierExcl | otherwise = pIdentifierU pTypeVar :: AGParser Identifier pTypeVar | ocaml opts = (\(nm, pos) -> Ident nm pos) <$> pTextnmPos | otherwise = pIdentifier pTypeHaskellAnyAsString :: AGParser String pTypeHaskellAnyAsString = getName <$> pTypeVar <|> getName <$> pTypeCon <|> pCodescrap' "a type" -- if the type is within some kind of parentheses or brackets (then we allow lowercase identifiers as well) pTypeEncapsulated :: AGParser Type pTypeEncapsulated = pParens pTypeEncapsulated <|> mkNtType <$> pTypeCon <*> pList pTypeHaskellAnyAsString <|> (Haskell . getName) <$> pTypeVar <|> pTypePrimitive pTypePrimitive :: AGParser Type pTypePrimitive = Haskell <$> pCodescrap' "a type" pType :: AGParser Type pType = pTypeNt <|> pTypePrimitive pTypeOrSelf :: AGParser Type pTypeOrSelf = pType <|> Self <$ pSELF pOptClassContext :: AGParser ClassContext pOptClassContext = pClassContext <* pDoubleArrow <|> pSucceed [] pClassContext :: AGParser ClassContext pClassContext = pListSep pComma ((,) <$> pIdentifierU <*> pList pTypeHaskellAnyAsString) pNontSet = set0 where set0 = pChainr (Intersect <$ pIntersect) set1 set1 = pChainl (Difference <$ pMinus) set2 set2 = pChainr (pSucceed Union) set3 set3 = pTypeCon <**> opt (flip Path <$ pArrow <*> pTypeCon) NamedSet <|> All <$ pStar <|> pParens set0 -- -- End of AG Parser -- resolveFile :: Options -> [FilePath] -> FilePath -> IO FilePath resolveFile opts path fname = search (path ++ ["."]) where search (p:ps) = do let filename = joinPath [p, fname] fExists <- doesFileExist filename if fExists then return filename else do let filename' = joinPath [p, replaceExtension fname "ag"] fExists' <- doesFileExist filename' if fExists' then return filename' else search ps search [] = do outputStr opts ("File: " ++ show fname ++ " not found in search path: " ++ show (concat (intersperse ";" (path ++ ["."]))) ++ "\n") failWithCode opts 1 return (error "resolveFile: file not found") evalStepsMessages :: (Eq s, Show s, Show p) => Steps a s p -> (a,[Message s p]) evalStepsMessages steps = case steps of OkVal v rest -> let (arg,ms) = evalStepsMessages rest in (v arg,ms) Ok rest -> evalStepsMessages rest Cost _ rest -> evalStepsMessages rest StRepair _ msg rest -> let (v,ms) = evalStepsMessages rest in (v, msg:ms) Best _ rest _ -> evalStepsMessages rest NoMoreSteps v -> (v,[]) loopp ::(a->Bool) -> (a->IO a) -> a -> IO a loopp pred cont x | pred x = return x | otherwise = do x' <- cont x loopp pred cont x' codescrapL p [] = (valueToken TkTextln "" p,p,[]) codescrapL p (x:xs) | isSpace x = (updPos' x p) codescrapL xs | otherwise = let refcol = column p (p',sc,rest) = scrapL refcol p (x:xs) in (valueToken TkTextln sc p,p',rest) scrapL ref p (x:xs) | isSpace x || column p >= ref = let (p'',sc,inp) = updPos' x p (scrapL ref) xs in (p'',x:sc,inp) | otherwise =(p,[],x:xs) scrapL ref p [] = (p,[],[]) pNames :: AGParser [Identifier] pNames = pIdentifiers -- Insertion is expensive for pCodeBlock in order to prevent infinite inserts. pCodeBlock :: AGParser (String,Pos) pCodeBlock = pCostValToken 90 TkTextln "" "a code block" pOptQuantifiers :: AGParser [String] pOptQuantifiers = (return <$ pDoubleColon <*> pCodescrap') `opt` [] pIdentifiers :: AGParser [Identifier] pIdentifiers = pList1Sep pComma pIdentifier "lowercase identifiers" pAttrIdentifier :: AGParser Identifier pAttrIdentifier = pIdentifier <|> (\pos -> Ident "imports" pos) <$> pIMPORTS <|> (\pos -> Ident "toplevel" pos) <$> pTOPLEVEL pAttrIdentifiers :: AGParser [Identifier] pAttrIdentifiers = pList1Sep pComma pAttrIdentifier "lowercase identifiers" pUse :: AGParser (String,String,String) pUse = ( (\u x y->(x,y,show u)) <$> pUSE <*> pCodescrap' <*> pCodescrap') `opt` ("","","") "USE declaration" mklower :: String -> String mklower (x:xs) = toLower x : xs mklower [] = [] pSimpleConstructorSet :: AGParser ConstructorSet pSimpleConstructorSet = CName <$> pIdentifierU <|> CAll <$ pStar <|> pParens pConstructorSet pConstructorSet :: AGParser ConstructorSet pConstructorSet = pChainl (CDifference <$ pMinus) term2 where term2 = pChainr (pSucceed CUnion) term1 term1 = CName <$> pIdentifierU <|> CAll <$ pStar pFieldIdentifier :: AGParser Identifier pFieldIdentifier = pIdentifier <|> Ident "lhs" <$> pLHS <|> Ident "loc" <$> pLOC <|> Ident "inst" <$> pINST pAugmentToken :: AGParser () pAugmentToken = () <$ (pAUGMENT <|> pPlus) pAttr = (,) <$> pFieldIdentifier <* pDot <*> pAttrIdentifier pAttrOrIdent = OccAttr <$> pFieldIdentifier <* pDot <*> pAttrIdentifier <|> OccRule <$> pIdentifier nl2sp :: Char -> Char nl2sp '\n' = ' ' nl2sp '\r' = ' ' nl2sp x = x pVar :: AGParser (Identifier -> (Identifier, Identifier)) pVar = (\att fld -> (fld,att)) <$> pAttrIdentifier pAssign :: AGParser Bool pAssign = False <$ pReserved "=" <|> True <$ pReserved ":=" pRuleSym :: AGParser (Bool, Pos, Bool, Bool) pRuleSym = (\p -> (False, p, True, False)) <$> pReserved "=" <|> (\p -> (True, p, True, False)) <$> pReserved ":=" <|> (\p -> (False, p, True, False)) <$> pReserved "<-" <|> (\p -> (False, p, True, True)) <$> pReserved "<<-" pPattern :: AGParser (a -> (Identifier,Identifier)) -> AGParser (a -> Pattern) pPattern pvar = pPattern2 where pPattern0 = (\i pats a -> Constr i (map ($ a) pats)) <$> pIdentifierU <*> pList pPattern1 <|> pPattern1 "a pattern" pPattern1 = pvariable <|> pPattern2 pvariable = (\ir var pat a -> case var a of (fld,att) -> ir $ Alias fld att (pat a)) <$> ((Irrefutable <$ pTilde) `opt` id) <*> pvar <*> ((pAt *> pPattern1) `opt` const (Underscore noPos)) pPattern2 = (mkTuple <$> pOParenPos <*> pListSep pComma pPattern0 <* pCParen ) <|> (const . Underscore) <$> pUScore "a pattern" where mkTuple _ [x] a = x a mkTuple p xs a = Product p (map ($ a) xs) pCostSym' c t = pCostSym c t t pCodescrap' :: AGParser String pCodescrap' = fst <$> pCodescrap pCodescrap :: AGParser (String,Pos) pCodescrap = pCodeBlock pSEM, pATTR, pDATA, pUSE, pLOC,pINCLUDE, pTYPE, pEquals, pColonEquals, pTilde, pEXTENDS, --marcos pBar, pColon, pLHS,pINST,pSET,pDERIVING,pMinus,pIntersect,pDoubleArrow,pArrow, pDot, pUScore, pEXT,pAt,pStar, pSmaller, pWRAPPER, pNOCATAS, pPRAGMA, pMAYBE, pEITHER, pMAP, pINTMAP, pMODULE, pATTACH, pUNIQUEREF, pINH, pSYN, pAUGMENT, pPlus, pAROUND, pSEMPRAGMA, pMERGE, pAS, pSELF, pIMPORTS, pOPTPRAGMAS, pSmallerEqual, pINTSET, pDATABLOCK, pRECBLOCK :: AGParser Pos pSET = pCostReserved 90 "SET" "SET" pDERIVING = pCostReserved 90 "DERIVING" "DERIVING" pWRAPPER = pCostReserved 90 "WRAPPER" "WRAPPER" pNOCATAS = pCostReserved 90 "NOCATAS" "NOCATAS" pPRAGMA = pCostReserved 90 "PRAGMA" "PRAGMA" pSEMPRAGMA = pCostReserved 90 "SEMPRAGMA" "SEMPRAGMA" pATTACH = pCostReserved 90 "ATTACH" "ATTACH" pDATA = pCostReserved 90 "DATA" "DATA" pEXT = pCostReserved 90 "EXT" "EXT" pATTR = pCostReserved 90 "ATTR" "ATTR" pSEM = pCostReserved 90 "SEM" "SEM" pINCLUDE = pCostReserved 90 "INCLUDE" "INCLUDE" pEXTENDS = pCostReserved 90 "EXTENDS" "EXTENDS" --marcos pTYPE = pCostReserved 90 "TYPE" "TYPE" pINH = pCostReserved 90 "INH" "INH" pSYN = pCostReserved 90 "SYN" "SYN" pCHN = pCostReserved 90 "CHN" "CHN" pMAYBE = pCostReserved 5 "MAYBE" "MAYBE" pEITHER = pCostReserved 5 "EITHER" "EITHER" pMAP = pCostReserved 5 "MAP" "MAP" pINTMAP = pCostReserved 5 "INTMAP" "INTMAP" pINTSET = pCostReserved 5 "INTSET" "INTSET" pUSE = pCostReserved 5 "USE" "USE" pLOC = pCostReserved 5 "loc" "loc" pLHS = pCostReserved 5 "lhs" "loc" pINST = pCostReserved 5 "inst" "inst" pAt = pCostReserved 5 "@" "@" pDot = pCostReserved 5 "." "." pUScore = pCostReserved 5 "_" "_" pColon = pCostReserved 5 ":" ":" pDoubleColon = pCostReserved 5 "::" "::" pEquals = pCostReserved 5 "=" "=" pColonEquals = pCostReserved 5 ":=" ":=" pTilde = pCostReserved 5 "~" "~" pPlus = pCostReserved 5 "+" "+" pBar = pCostReserved 5 "|" "|" pIntersect = pCostReserved 5 "/\\" "/\\" pMinus = pCostReserved 5 "-" "-" pDoubleArrow = pCostReserved 5 "=>" "=>" pSmallerEqual= pCostReserved 5 "<=" "<=" pArrow = pCostReserved 5 "->" "->" pStar = pCostReserved 5 "*" "*" pSmaller = pCostReserved 5 "<" "<" pMODULE = pCostReserved 5 "MODULE" "MODULE" pUNIQUEREF = pCostReserved 5 "UNIQUEREF" "UNIQUEREF" pAUGMENT = pCostReserved 5 "AUGMENT" "AUGMENT" pAROUND = pCostReserved 5 "AROUND" "AROUND" pMERGE = pCostReserved 5 "MERGE" "MERGE" pAS = pCostReserved 5 "AS" "AS" pSELF = pCostReserved 5 "SELF" "SELF" pIMPORTS = pCostReserved 5 "imports" "imports" pOPTPRAGMAS = pCostReserved 5 "optpragmas" "optpragmas" pTOPLEVEL = pCostReserved 5 "toplevel" "toplevel" pDATABLOCK = pCostReserved 5 "datablock" "datadecl block" pRECBLOCK = pCostReserved 5 "recblock" "recursive block" uuagc-0.9.42.3/src/PPUtil.hs000644 000765 000024 00000003341 12127045231 017347 0ustar00jeroenbransenstaff000000 000000 module PPUtil where -- -- Some additional pretty-print functions -- for pretty-printing abstract syntax trees. -- import Data.List import qualified Data.Map as Map import Pretty import Options ppListSep :: (PP s, PP c, PP o, PP a) => o -> c -> s -> [a] -> PP_Doc ppListSep o c s pps = o >|< hlist (intersperse (pp s) (map pp pps)) >|< c ppSpaced :: PP a => [a] -> PP_Doc ppSpaced = ppListSep "" "" " " ppCommas :: PP a => [a] -> PP_Doc ppCommas = ppListSep "" "" ", " ppVList :: PP a => [a] -> PP_Doc ppVList [] = "[" >#< "]" ppVList (x:xs) = vlist (("[" >#< pp x) : (map (\y -> "," >#< pp y) xs)) >#< "]" ppMap :: (Show a, Show b) => Map.Map a b -> PP_Doc ppMap m = ppVList [ ppF (show k) $ ppShow v | (k,v) <- Map.toList m ] ppAssocL :: (Show a, Show b) => [(a,b)] -> PP_Doc ppAssocL m = ppVList [ ppF (show k) $ ppShow v | (k,v) <- m ] ppF :: String -> PP_Doc -> PP_Doc ppF s x = s >|< ":" >#< x ppNest :: PP a => [a] -> [PP_Doc] -> [PP_Doc] -> PP_Doc ppNest nms attrs ps = ppNestInfo {- defaultEHCOpts -} nms attrs ps [] ppNestInfo :: PP a => {- EHCOpts -> -} [a] -> [PP_Doc] -> [PP_Doc] -> [(String,PP_Doc)] -> PP_Doc ppNestInfo {- opts -} nms attrs ps infos = ppListSep "" "" "_" nms >#< ( (if null attrs then empty else ppSpaced attrs) >-< (if False {- ehcOptDebug opts -} then vlist (map (\(i,p) -> pp i >|< ":" >#< p) infos) else empty) ) >-< indent 2 (vlist ps) ppNm :: String -> PP_Doc ppNm = text . show ppShow :: Show x => x -> PP_Doc ppShow x = pp $ show x mkInfo1 :: String -> PP_Doc -> (String,PP_Doc) mkInfo1 = (,) ppLinePragma :: Options -> Int -> String -> PP_Doc ppLinePragma opts ln fl | ocaml opts = "#" >#< show ln >#< show fl | otherwise = "{-# LINE" >#< show ln >#< show fl >#< "#-}" uuagc-0.9.42.3/src/Pretty.hs000644 000765 000024 00000011715 12127045231 017465 0ustar00jeroenbransenstaff000000 000000 ------------------------------------------------------------------------- -- Subset of UU.Pretty, based on very simple pretty printing -- Extended with line-nr tracking ------------------------------------------------------------------------- module Pretty ( PP_Doc, PP(..) , disp , (>|<), (>-<) , (>#<) , ppWithLineNr , hlist, vlist, hv , fill , indent , pp_block , vlist_sep , pp_parens , pp_braces , hv_sp , empty, empty1, text , isEmpty ) where import Data.List(intersperse) ------------------------------------------------------------------------- -- Doc structure ------------------------------------------------------------------------- data Doc = Emp | Emp1 | Str !String -- basic string | Hor Doc !Doc -- horizontal positioning | Ver Doc !Doc -- vertical positioning | Ind !Int Doc -- indent | Line (Int -> Doc) -- line nr type PP_Doc = Doc ------------------------------------------------------------------------- -- Basic combinators ------------------------------------------------------------------------- infixr 3 >|<, >#< infixr 2 >-< (>|<) :: (PP a, PP b) => a -> b -> PP_Doc l >|< r = pp l `Hor` pp r (>-<) :: (PP a, PP b) => a -> b -> PP_Doc l >-< r | isEmpty a = b | isEmpty b = a | otherwise = a `Ver` b where a = pp l b = pp r (>#<) :: (PP a, PP b) => a -> b -> PP_Doc l >#< r | isEmpty a = b | isEmpty b = a | otherwise = a >|< " " >|< b where a = pp l b = pp r indent :: PP a => Int -> a -> PP_Doc indent i d = Ind i $ pp d text :: String -> PP_Doc text s = let ls = lines s ls' | null ls = [""] | otherwise = ls in vlist (map Str ls') empty :: PP_Doc empty = Emp -- empty1 is not a zero for >#< empty1 :: PP_Doc empty1 = Emp1 ppWithLineNr :: PP a => (Int -> a) -> PP_Doc ppWithLineNr f = Line (pp . f) ------------------------------------------------------------------------- -- Derived combinators ------------------------------------------------------------------------- hlist, vlist :: PP a => [a] -> PP_Doc vlist [] = empty vlist as = foldr (>-<) empty as hlist [] = empty hlist as = foldr (>|<) empty as hv :: PP a => [a] -> PP_Doc hv = vlist hv_sp :: PP a => [a] -> PP_Doc hv_sp = foldr (>#<) empty fill :: PP a => [a] -> PP_Doc fill = hlist pp_block:: (PP a, PP b, PP c) => a -> b -> c -> [PP_Doc] -> PP_Doc pp_block o c s as = pp o >|< hlist (intersperse (pp s) as) >|< pp c pp_parens :: PP a => a -> PP_Doc pp_parens p = '(' >|< p >|< ')' pp_braces :: PP a => a -> PP_Doc pp_braces p = '{' >-< p >-< '}' vlist_sep :: (PP a, PP b) => a -> [b] -> PP_Doc vlist_sep sep lst = vlist (intersperse (pp sep) (map pp lst)) ------------------------------------------------------------------------- -- PP class ------------------------------------------------------------------------- class Show a => PP a where pp :: a -> PP_Doc pp = text . show ppList :: [a] -> PP_Doc ppList as = hlist as instance PP Doc where pp = id instance PP Char where pp c = text [c] ppList = text instance PP a => PP [a] where pp = ppList instance Show Doc where show p = disp p 200 "" instance PP Int where pp = text . show instance PP Float where pp = text . show ------------------------------------------------------------------------- -- Observation ------------------------------------------------------------------------- isEmpty :: PP_Doc -> Bool isEmpty Emp = True isEmpty Emp1 = False isEmpty (Ver d1 d2) = isEmpty d1 && isEmpty d2 isEmpty (Hor d1 d2) = isEmpty d1 && isEmpty d2 isEmpty (Ind _ d ) = isEmpty d isEmpty _ = False ------------------------------------------------------------------------- -- Rendering ------------------------------------------------------------------------- disp :: PP_Doc -> Int -> ShowS disp d0 _ s0 = r where (r,_,_) = put 0 1 d0 s0 put p l d s = case d of Emp -> (s,p,l) Emp1 -> (s,p,l) Str s' -> (s' ++ s,p + length s',l) Ind i d1 -> (ind ++ r',p', l') where (r',p',l') = put (p+i) l d1 s ind = replicate i ' ' Hor d1 d2 -> (r1,p2,l2) where (r1,p1,l1) = put p l d1 r2 (r2,p2,l2) = put p1 l1 d2 s Ver d1 d2 | isEmpty d1 -> put p l d2 s Ver d1 d2 | isEmpty d2 -> put p l d1 s Ver d1 d2 -> (r1,p2,l2) where (r1,_ ,l1) = put p l d1 $ "\n" ++ ind ++ r2 (r2,p2,l2) = put p (l1+1) d2 s ind = replicate p ' ' Line f -> (r',p',l') where (r',p',l') = put p l (f l) s uuagc-0.9.42.3/src/RhsCheck.hs000644 000765 000024 00000004320 12127045231 017662 0ustar00jeroenbransenstaff000000 000000 module RhsCheck(checkRhs,checkBlock,checkTy) where import Language.Haskell.Exts (parseExpWithMode, parseModuleWithMode, parseTypeWithMode, srcLine, srcColumn, srcFilename, baseFixities, glasgowExts, ParseMode (..), defaultParseMode, ParseResult (..), Extension (..)) import ErrorMessages import Expression import HsToken import UU.Scanner.Position checkRhs,checkBlock,checkTy :: Expression -> Errors checkRhs = check parseExpWithMode checkBlock = check parseModuleWithMode checkTy = check parseTypeWithMode check :: (ParseMode -> String -> ParseResult a) -> Expression -> Errors check p (Expression pos tks) = case res of ParseOk _ -> [] ParseFailed loc msg -> let pos' = Pos (srcLine loc + line pos - 1) (srcColumn loc) (srcFilename loc) in [HsParseError pos' msg] where pos0 = Pos (line pos) 1 (file pos) str = toString pos0 tks res = p mode str bf = case baseFixities of [] -> Nothing xs -> Just xs mode = defaultParseMode { parseFilename = file pos, ignoreLanguagePragmas = False, extensions = exts , ignoreLinePragmas = False, fixities = bf } exts :: [Extension] exts = glasgowExts toString :: Pos -> HsTokens -> String toString _ [] = "" toString cPos (tk:tks) = move ++ current ++ next where tkPos = getPos tk move = addSpacing (line tkPos - line cPos) (column cPos) (column tkPos) current = fmt tk nPos = upd tkPos current next = toString nPos tks getPos :: HsToken -> Pos getPos (AGLocal _ pos _) = pos getPos (AGField _ _ pos _) = pos getPos (HsToken _ pos) = pos getPos (CharToken _ pos) = pos getPos (StrToken _ pos) = pos getPos (Err _ pos) = pos fmt :: HsToken -> String fmt (AGLocal var _ _) = "_" ++ show var fmt (AGField field attr _ _) = "_" ++ show field ++ "_" ++ show attr fmt (HsToken val _) = val fmt (CharToken val _) = show val fmt (StrToken val _) = show val fmt (Err val _) = val upd :: Pos -> String -> Pos upd p s = foldl adv p s addSpacing :: Int -> Int -> Int -> String addSpacing l c1 c2 = replicate l '\n' ++ replicate c ' ' where c | l == 0 = c2 - c1 | otherwise = c2 - 1 uuagc-0.9.42.3/src/Scanner.hs000644 000765 000024 00000025606 12127045231 017573 0ustar00jeroenbransenstaff000000 000000 {-# LANGUAGE MagicHash, UnboxedTuples, FlexibleInstances #-} module Scanner where import GHC.Prim import TokenDef import UU.Scanner.Position import UU.Scanner.Token import UU.Parsing(InputState(..),Either'(..)) import Data.Maybe import Data.List import Data.Char import UU.Scanner.GenToken import Options (Options (..)) data Input = Input !Pos String (Maybe (Token, Input)) instance InputState Input Token Pos where splitStateE input@(Input _ _ next) = case next of Nothing -> Right' input Just (s, rest) -> Left' s rest splitState (Input _ _ next) = case next of Nothing -> error "splitState on empty input" Just (s, rest) -> (# s, rest #) getPosition (Input pos _ next) = case next of Just (s,_) -> position s Nothing -> pos -- end of file input :: Options -> Pos -> String -> Input input opts pos inp = Input pos inp (case scan opts pos inp of Nothing -> Nothing Just (s,p,r) -> Just (s, input opts p r) ) type Lexer s = Pos -> String -> Maybe (s,Pos,String) scan :: Options -> Lexer Token scan opts p0 | column p0 == 1 = scanBeginOfLine p0 | otherwise = scan p0 where keywords' = if lcKeywords opts then map (map toLower) keywords else keywords mkKeyword s | s `elem` lowercaseKeywords = s | otherwise = map toUpper s scan :: Lexer Token scan p [] = Nothing scan p ('-':'-':xs) | null xs || not (head xs `elem` "<>!?#@:%$^&") = let (com,rest) = span (/= '\n') xs in advc' (2+length com) p scan rest scan p ('{':'-':xs) = advc' 2 p (ncomment scan) xs scan p ('{' :xs) = advc' 1 p codescrap xs scan p ('\CR':xs) = case xs of '\LF':ys -> newl' p scanBeginOfLine ys --ms newline _ -> newl' p scanBeginOfLine xs --mac newline scan p ('\LF':xs) = newl' p scanBeginOfLine xs --unix newline scan p (x:xs) | isSpace x = updPos' x p scan xs scan p xs = Just (scan' xs) where scan' ('.' :rs) = (reserved "." p, advc 1 p, rs) scan' ('@' :rs) = (reserved "@" p, advc 1 p, rs) scan' (',' :rs) = (reserved "," p, advc 1 p, rs) scan' ('_' :rs) = (reserved "_" p, advc 1 p, rs) scan' ('~' :rs) = (reserved "~" p, advc 1 p, rs) scan' ('+' :rs) = (reserved "+" p, advc 1 p, rs) scan' ('<' : '-' : rs) = (reserved "<-" p, advc 2 p, rs) scan' ('<' : '=' : rs) = (reserved "<=" p, advc 2 p, rs) scan' ('<' : '<' : '-' : rs) = (reserved "<<-" p, advc 3 p, rs) scan' ('<' :rs) = (reserved "<" p, advc 1 p, rs) scan' ('[' :rs) = (reserved "[" p, advc 1 p, rs) scan' (']' :rs) = (reserved "]" p, advc 1 p, rs) scan' ('(' :rs) = (reserved "(" p, advc 1 p, rs) scan' (')' :rs) = (reserved ")" p, advc 1 p, rs) -- scan' ('{' :rs) = (OBrace p, advc 1 p, rs) -- scan' ('}' :rs) = (CBrace p, advc 1 p, rs) scan' ('\"' :rs) = let isOk c = c /= '"' && c /= '\n' (str,rest) = span isOk rs in if null rest || head rest /= '"' then (errToken "unterminated string literal" p , advc (1+length str) p,rest) else (valueToken TkString str p, advc (2+length str) p, tail rest) scan' ('=' : '>' : rs) = (reserved "=>" p, advc 2 p, rs) scan' ('=' :rs) = (reserved "=" p, advc 1 p, rs) scan' (':':'=':rs) = (reserved ":=" p, advc 2 p, rs) scan' (':':':':rs) {- | doubleColons opts -} = (reserved "::" p, advc 1 p, rs) -- recognize double colons too scan' (':' :rs) = (reserved ":" p, advc 1 p, rs) scan' ('|' :rs) = (reserved "|" p, advc 1 p, rs) scan' ('/':'\\':rs) = (reserved "/\\" p, advc 2 p, rs) scan' ('-':'>' :rs) = (reserved "->" p, advc 2 p, rs) scan' ('-' :rs) = (reserved "-" p, advc 1 p, rs) scan' ('*' :rs) = (reserved "*" p, advc 1 p, rs) scan' ('\'' :rs) | ocaml opts = -- note: ocaml type variables are encoded as 'TkTextnm' tokens let (var,rest) = ident rs str = '\'' : var in (valueToken TkTextnm str p, advc (length str) p, rest) scan' (x:rs) | isLower x = let (var,rest) = ident rs str = (x:var) tok | str `elem` keywords' = reserved (mkKeyword str) | otherwise = valueToken TkVarid str in (tok p, advc (length var+1) p, rest) | isUpper x = let (var,rest) = ident rs str = (x:var) tok | str `elem` keywords' = reserved (mkKeyword str) | otherwise = valueToken TkConid str in (tok p, advc (length var+1) p,rest) | otherwise = (errToken ("unexpected character " ++ show x) p, advc 1 p, rs) scanBeginOfLine :: Lexer Token scanBeginOfLine p ('{' : '-' : ' ' : 'L' : 'I' : 'N' : 'E' : ' ' : xs) | isOkBegin rs && isOkEnd rs' = scan (advc (8 + length r + 2 + length s + 4) p') (drop 4 rs') | otherwise = Just (errToken ("Invalid LINE pragma: " ++ show r) p, advc 8 p, xs) where (r,rs) = span isDigit xs (s, rs') = span (/= '"') (drop 2 rs) p' = Pos (read r - 1) (column p) s -- LINE pragma indicates the line number of the /next/ line! isOkBegin (' ' : '"' : _) = True isOkBegin _ = False isOkEnd ('"' : ' ' : '-' : '}' : _) = True isOkEnd _ = False scanBeginOfLine p xs = scan p xs ident = span isValid where isValid x = isAlphaNum x || x == '_' || x == '\'' lowercaseKeywords = ["loc","lhs", "inst", "optpragmas", "imports", "toplevel", "datablock", "recblock"] keywords = lowercaseKeywords ++ [ "DATA", "EXT", "ATTR", "SEM","TYPE", "USE", "INCLUDE" , "EXTENDS" -- marcos , "SET","DERIVING","FOR", "WRAPPER", "NOCATAS", "MAYBE", "EITHER", "MAP", "INTMAP" , "PRAGMA", "SEMPRAGMA", "MODULE", "ATTACH", "UNIQUEREF", "INH", "SYN", "CHN" , "AUGMENT", "AROUND", "MERGE", "AS", "SELF", "INTSET" ] ncomment c p ('-':'}':xs) = advc' 2 p c xs ncomment c p ('{':'-':xs) = advc' 2 p (ncomment (ncomment c)) xs ncomment c p (x:xs) = updPos' x p (ncomment c) xs ncomment c p [] = Just (errToken "unterminated nested comment" p, p,[]) codescrap p xs = let (p2,xs2,sc) = codescrap' 1 p xs in case xs2 of ('}':rest) -> Just (valueToken TkTextln sc p,advc 1 p2,rest) _ -> Just (errToken "unterminated codescrap" p,p2,xs2) codescrap' d p [] = (p,[],[]) {- codescrap' d p ('{':'{':xs) = let (p2,xs2,sc) = advc' 2 p (codescrap' d) xs in (p2,xs2,'{':' ':sc) codescrap' d p ('}':'}':xs) = let (p2,xs2,sc) = advc' 2 p (codescrap' d) xs in (p2,xs2,'}':' ':sc) -} codescrap' d p ('{':xs) = let (p2,xs2,sc) = advc' 1 p (codescrap' (d+1)) xs in (p2,xs2,'{' : sc) codescrap' d p ('}':xs) | d == 1 = (p,'}':xs,[]) | otherwise = let (p2,xs2,sc) = advc' 1 p (codescrap' (d-1)) xs in (p2,xs2,'}' : sc) codescrap' d p (x :xs) = let (p2,xs2,sc) = updPos' x p (codescrap' d) xs in (p2,xs2,x:sc) --Literate Mode scanLit xs = (fs, foldr insNL (const "") codeLns 1) where insNL (n,line) r = \n1 -> replicate (n-n1) '\n' ++ line ++ r n (fs,codeLns,_) = getBlocks ([1..] `zip` toLines xs) getBlocks [] = ([],[],[]) getBlocks xs = let (files1,txt1,r1) = getBlock xs (files2,txt2,r2) = getBlocks r1 in (files1++files2, txt1++txt2, r2) getBlock = getLines . dropWhile comment getLines [] = ([],[],[]) getLines ((n,l):ls) | "\\begin{code}" `isPrefixOf` l = let (lns,rest) = codelines ls in ([],lns,rest) | "\\begin{Code}" `isPrefixOf` l = let (lns,rest) = codeLines ls in ([],lns,rest) | "\\IN{" `isPrefixOf` l = let name = getName l in ([name],[],ls) | otherwise = getBlock ls comment = not . ("\\" `isPrefixOf`) .snd toLines :: String -> [String] toLines "" = [] toLines s = let (l,s') = breakLine s in l : toLines s' breakLine xs = case xs of '\CR' : ys -> case ys of '\LF' : zs -> ([],zs) _ -> ([],ys) '\LF' : ys -> ([], ys) x : ys -> let (l,s) = breakLine ys in (x:l,s) [] -> ([],[]) codelines [] = error "Unterminated literate code block" codelines ((n,l):ls) | "\\end{code}" `isPrefixOf` l = ([],ls) | otherwise = let (lns,r) = codelines ls in ((n,l):lns,r) codeLines [] = error "Unterminated literate Code block" codeLines ((n,l):ls) | "\\end{Code}" `isPrefixOf` l = ([],ls) | otherwise = let (lns,r) = codeLines ls in ((n,l):lns,r) getName l = case r of ('}':_) -> nm _ -> error $ "missing '}' in \\IN" where (nm,r) = span (/='}') (drop 4 l) uuagc-0.9.42.3/src/SequentialComputation.lhs000644 000765 000024 00000042120 12127045231 022701 0ustar00jeroenbransenstaff000000 000000 \begin{code} module SequentialComputation (computeSequential,Vertex,Edge,Table) where import SequentialTypes import InterfacesRules import CodeSyntax import GrammarInfo import Control.Monad(when,unless) import Control.Monad.ST(ST, runST) import Data.Array(Array,(!),bounds) import Data.Array.ST(STArray, newArray, readArray, writeArray, freeze) import Data.Maybe(isJust,fromJust) import Data.List(partition,(\\)) import qualified Data.Set as Set import qualified Data.Map as Map \end{code} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Collecting information} In the Data.Graph library, a graph is represented as |Array Vertex [Vertex]|, mapping each vertex to a list of adjacent vertices. A |Vertex| is simply encoded by an |Int|. So to test whether an edge |(x,y)| belongs to |g| we can evaluate |y `elem` g!x| For more efficiency, we use Maps instead of lists. Sets would also have done, but we also want to each edge to have a path as a witness. Moreover, as we will mostly be adding edges to the graph, we use a mutable array. If we want to use any of the library functions, we can convert our representation by |fmap Map.keys . freeze|. \begin{code} type Graph = Array Vertex [Vertex] type MGraph = Array Vertex (Map.Map Vertex Path) type MMGraph s = STArray s Vertex (Map.Map Vertex Path) singleStep :: (Vertex->Vertex->PathStep) -> Edge -> EdgePath singleStep f e@(s,t) = (e, [f s t]) \end{code} We can add an edge to a graph, or remove it. These functions return whether they did something (resp. addition or removal) or not. hasEdge only checks whether a graph contains an edge or not. \begin{code} addEdge :: MMGraph s -> EdgePath -> ST s Bool addEdge graph ((s,t),p) = do m <- readArray graph s let b = not (Map.member t m) when b (writeArray graph s (Map.insert t p m)) return b hasEdge :: MMGraph s -> EdgePath -> ST s Bool hasEdge graph ((s,t),_) = do m <- readArray graph s return (Map.member t m) \end{code} The first step is to assign a number to all attributes, and a different one to all attribute occurrences. We create an array mapping the numbers to the information about the attribute occurrences (|ruleTable|), so we can look up this information in $O(1)$ time. We also build mappings from attributes to their occurrences (|tdsToTdp|) and vice versa (|tdpToTds|). |LMH| indicates the division of the attributes - an element |(l,m,h) `elem` LMH| means that vertices |i, l <= i <= h| are attributes of the same nonterminal, with vertices |j, l <= j < m| being inherited and |k, m <= k <= h| being synthesized attributes. See the |SequentialTypes.Info| and |SequentialTypes.LMH| Then we collect the direct dependencies, using the integer representations. This list of tuples (edges in the dependency graph) all information that is collected is passed to a function that will compute the interfaces and visit sub-sequences. We cannot do this computation in AG, because mutable arrays require the ST monad, which cannot be used inside AG. Now we can build a graph for attributes, and a graph for ao's, and add the direct dependencies to the ao graph. Like Pennings we will call the attribte graph Tds (transitive dependencies of symbols), and the ao-graph Tdp (transitive dependencies of productions). Unlike him, we will have only one Tds and one Tdp graph. In |STGraph|, we can lookup outgoing edges in |O(1)| time, but looking up incoming edges will take |O(e)| time, where |e| is the number of edges in the graph. As we will be doing this quite often it is worthwhile to keep both Tdp and its transposed version. The computation will involve both Tds and Tdp. It treats specially. TODO elaborate on that. \begin{code} type Tdp s = (MMGraph s, MMGraph s) type Tds s = MMGraph s type Comp s = (Tds s, Tdp s) \end{code} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Generating IDS} As we insert edges into Tdp we keep it transitively closed, so every time we add the edge $(s,t)$ to V, we also add the edges $\{ (r,t) || (r,s) \in V \}$ and $\{ (s,u) || (t,u) \in V \}$. \begin{code} insertTdp :: Info -> Comp s -> EdgePath -> ST s () insertTdp info comp@(_,(tdpN,tdpT)) e@((s,t),ee) -- how to insert an edge (s,t): = do b <- hasEdge tdpN e -- if it's not yet present unless b (do rs <- readArray tdpT s -- find all sources r for an edge to s us <- readArray tdpN t -- find all targets u for an edge from t let edges = e :[ ((r,t),er++ee ) | (r,er) <- Map.toList rs ] ++ [ ((s,u), ee++eu) | (u,eu) <- Map.toList us ] ++ [ ((r,u),er++ee++eu) | (r,er) <- Map.toList rs, (u,eu) <- Map.toList us ] mapM_ (addTdpEdge info comp) edges -- and add all of them, without having to bother about transitive closure anymore ) \end{code} Edges in |Tdp| can induce edges in |Tds|, so whenever we add an edge, we also add the induced edge if necessary \begin{code} addTdpEdge :: Info -> Comp s -> EdgePath -> ST s () -- how to add an edge (s,t) when not having to bother about the transitive closure: addTdpEdge info comp@(_,(tdpN,tdpT)) e@((s,t),ee) = do b <- addEdge tdpN e -- add it to the normal graph when b -- if it was a new edge (do addEdge tdpT ((t,s),ee) -- also add it to the transposed graph let u = tdpToTds info ! s -- find the corresponding attributes... v = tdpToTds info ! t nonlocal = u /= -1 && v /= -1 equalfield = isEqualField (ruleTable info ! s) (ruleTable info ! t) when (nonlocal && equalfield) -- ...and when necessary... (insertTds info comp ((u,v),ee)) -- ...insert it to the Tds graph ) \end{code} Inserting edges into |Tds| will insert edges between the occurrences of the attributes into |Tdp|. \begin{code} insertTds :: Info -> Comp s -> EdgePath -> ST s () insertTds info comp@(tds,_) e@((u,v),ee) = do b <- addEdge tds e when b (mapM_ (insertTdp info comp) [ ( (s,t), [AttrStep u v] ) | s <- tdsToTdp info ! u , not (getIsIn (ruleTable info ! s)) -- inherited at LHS, or synthesized at RHS , t <- tdsToTdp info ! v , getIsIn (ruleTable info ! t) -- synthesized at LHS, or inherited at RHS , isEqualField (ruleTable info ! s) (ruleTable info ! t) ] ) \end{code} If we add the direct dependencies to the Tdp graph in the way above, the Tds graph is filled with IDS. Below is a way to only build up the Tdp graph, without reflect the changes in the Tds graph. \begin{code} simpleInsert :: Tdp s -> EdgePath -> ST s () simpleInsert tdp@(tdpN,tdpT) e@((s,t),ee) = do b <- hasEdge tdpT ((t,s),undefined) unless b (do rs <- readArray tdpT s us <- readArray tdpN t let edges = e :[ ((r,t),er++ee ) | (r,er) <- Map.toList rs ] ++ [ ((s,u), ee++eu) | (u,eu) <- Map.toList us ] ++ [ ((r,u),er++ee++eu) | (r,er) <- Map.toList rs, (u,eu) <- Map.toList us ] mapM_ (addSimpleEdge tdp) edges ) addSimpleEdge :: Tdp s -> EdgePath -> ST s () addSimpleEdge (tdpN,tdpT) e@((s,t),ee) = do b <- addEdge tdpN e when b (do addEdge tdpT ((t,s),ee) return () ) \end{code} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Interfaces} In absence of cycles we can find the interfaces. We only take attributes that are used. When an attribute has no incoming edges it can be computed. As the emphasis is on incoming edges, we will work with the transposed Tds graph. The funtion |used| indicates which vertices are included in the interfaces. See modules Interfaces and InterfacesRules for more information. %format sem_IRoot_IRoot = "sem_{IRoot}" %format sem_Interface_Interface = "sem_{Interface}" %format sem_Interfaces_Cons = ":_{Interfaces}" %format sem_Interfaces_Nil = "[]_{Interfaces}" %format sem_Segments_Cons = ":_{Segments}" %format sem_Segments_Nil = "[]_{Segments}" \begin{code} makeInterfaces :: Info -> Graph -> T_IRoot makeInterfaces info tds = let interslist = reverse . makeInterface tds [] mkSegments = foldr (sem_Segments_Cons . uncurry sem_Segment_Segment) sem_Segments_Nil . interslist mkInter ((nt,cons),lmh) = sem_Interface_Interface nt cons (mkSegments lmh) inters = foldr (sem_Interfaces_Cons . mkInter) sem_Interfaces_Nil (zip (nonts info) (lmh info)) in sem_IRoot_IRoot inters \end{code} The sinks of a graph are those vertices that have no outgoing edges. We define a function that determines whether a vertex is a sink if a set |del| of vertices had been removed from the graph. This means that the attribute can be computed if all attributes in |del| have been computed. \begin{code} isSink :: Graph -> [Vertex] -> Vertex -> Bool isSink graph del v = null (graph ! v \\ del) \end{code} Now we can make interfaces by taking inherited sinks and synthesized sinks alternatively. If there are no synthesized attributes at all, generate an interface with one visit computing nothing. \begin{code} makeInterface :: Graph -> [Vertex] -> LMH -> [([Vertex],[Vertex])] makeInterface tds del (l,m,h) | m > h = [([],[])] | otherwise = let syn = filter (isSink tds del) ([m..h] \\ del) del' = del ++ syn inh = filter (isSink tds del') ([l..(m-1)] \\ del') del'' = del' ++ inh rest = makeInterface tds del'' (l,m,h) in if null inh && null syn then [] else (inh,syn) : rest \end{code} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Detecting of cycles} We only want to return s2i edges. \begin{code} findCycles :: Info -> MGraph -> [EdgePaths] findCycles info tds = [ ((u,v),p1,p2) | (l,m,h) <- lmh info -- for every nonterminal: [l..m-1] are inherited, [m..h] are synthesized , v <- [m..h] -- for every synthesized attribute , (u,p1) <- Map.toList (tds ! v) -- find dependent attributes... , l <= u, u < m -- ...that are inherited... , let mbp2 = Map.lookup v (tds ! u) -- ...and have a cycle back , isJust mbp2 , let p2 = fromJust mbp2 ] findLocCycles :: MGraph -> [EdgePath] findLocCycles tdp = let (low, high) = bounds tdp in [ ((u,u),p) | u <- [low..high] , (v,p) <- Map.toList (tdp ! u) , v==u ] findInstCycles :: [Edge] -> MGraph -> [EdgePath] findInstCycles instToSynEdges tdp = [ ((i,s), fromJust mbp) | (i, s) <- instToSynEdges , let mbp = Map.lookup i (tdp ! s) , isJust mbp ] \end{code} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Tying it together} \begin{code} generateVisits :: Info -> MGraph -> MGraph -> [Edge] -> (CInterfaceMap, CVisitsMap, [Edge]) generateVisits info tds tdp dpr = let inters = makeInterfaces info (fmap Map.keys tds) inhs = Inh_IRoot{ info_Inh_IRoot = info , tdp_Inh_IRoot = fmap Map.keys tdp , dpr_Inh_IRoot = dpr } iroot = wrap_IRoot inters inhs in (inters_Syn_IRoot iroot, visits_Syn_IRoot iroot, edp_Syn_IRoot iroot) reportLocalCycle :: MGraph -> [EdgePath] -> [[Vertex]] reportLocalCycle tds cyc = fst (foldr f ([],Set.empty) (map (edgePathToEdgeRoute tds) cyc)) where f ((x,_),p) res@(paths,syms) | Set.member x syms = res -- don't report a cyclic vertex if it appears on a path of an earlier reported one | otherwise = (p:paths, Set.union syms (Set.fromList p)) reportCycle :: Info -> MGraph -> [EdgePaths] -> [EdgeRoutes] reportCycle info tds cyc = fst (foldr f ([],Set.empty) (map (edgePathsToEdgeRoutes tds) cyc)) where f epp@((x,y),p1,p2) res@(paths,syms) | Set.member x syms && Set.member y syms = res -- don't report mutually dependent vertices if both appear on paths reported earlier | otherwise = (epp:paths, Set.union syms (Set.fromList (map tdp2tds (p1++p2)))) tdp2tds (-2) = -2 tdp2tds v = tdpToTds info ! v edgePathsToEdgeRoutes :: MGraph -> EdgePaths -> EdgeRoutes edgePathsToEdgeRoutes tds (e,p1,p2) = ( e, pathToRoute tds p1, pathToRoute tds p2 ) edgePathToEdgeRoute :: MGraph -> EdgePath -> EdgeRoute edgePathToEdgeRoute tds (e,p) = ( e, pathToRoute tds p ) pathToRoute :: MGraph -> Path -> Route pathToRoute tds p = convertPath (expandAll p) where expandAll :: Path -> Path expandAll p | hasAttrStep p = expandAll (expandOne p) | otherwise = p expandOne :: Path -> Path expandOne p = shortcut (concatMap expandStep p) expandStep :: PathStep -> Path expandStep (AttrStep u v) = fromJust (Map.lookup v (tds!u)) expandStep x = [x] convertPath :: Path -> Route convertPath p = concatMap convertStep p convertStep :: PathStep -> Route convertStep (AtOcStep s t) = [s,t] convertStep (AttrIndu s t) = [-2,-2] hasAttrStep :: Path -> Bool hasAttrStep [] = False hasAttrStep (AttrStep _ _ : _ ) = True hasAttrStep (_ : xs) = hasAttrStep xs shortcut :: Eq a => [a] -> [a] shortcut [] = [] shortcut (x:xs) = x : shortcut (removeBefore x xs) removeBefore :: Eq a => a -> [a] -> [a] removeBefore x ys = reverse (takeWhile (/=x) (reverse ys)) isLocLoc :: Table CRule -> EdgePath -> Bool isLocLoc rt ((s,t),_) = isLocal (rt ! s) && isLocal (rt ! t) -- || (isInst (rt ! s) && isInst (rt ! t)) computeSequential :: Info -> [Edge] -> [Edge] -> CycleStatus computeSequential info dpr instToSynEdges = runST (do let bigBounds = bounds (tdpToTds info) smallBounds = bounds (tdsToTdp info) (ll,es) = partition (isLocLoc (ruleTable info)) (map (singleStep AtOcStep) (dpr ++ instToSynEdges)) tds <- newArray smallBounds Map.empty tdpN <- newArray bigBounds Map.empty tdpT <- newArray bigBounds Map.empty let tdp = (tdpN,tdpT) comp = (tds,tdp) mapM_ (simpleInsert tdp) ll -- insert the local dependencies tdp1 <- freeze tdpN let cyc1 = findLocCycles tdp1 if not (null cyc1) -- are they cyclic? then do return (LocalCycle (reportLocalCycle undefined cyc1)) -- then report an error. else do mapM_ (insertTdp info comp) es -- insert the other dependencies tds2 <- freeze tds let cyc2 = findCycles info tds2 if not (null cyc2) -- are they cyclic? then do return (DirectCycle (reportCycle info tds2 cyc2)) -- then report an error. else do tdp2 <- freeze tdpN let cyc4 = findInstCycles instToSynEdges tdp2 if not (null cyc4) then do return (InstCycle (reportLocalCycle tds2 cyc4)) -- then report an error. else do let (cim,cvm,edp) = generateVisits info tds2 tdp2 dpr mapM_ (insertTds info comp) (map (singleStep AttrIndu) edp) -- insert dependencies induced by visit scheduling tds3 <- freeze tds let cyc3 = findCycles info tds3 if not (null cyc3) -- are they cyclic? then return (InducedCycle cim (reportCycle info tds3 cyc3)) -- then report an error. else do tdp3 <- freeze tdpN let cyc5 = findInstCycles instToSynEdges tdp3 if not (null cyc5) then do return (InstCycle (reportLocalCycle tds3 cyc5)) -- then report an error. else do return (CycleFree cim cvm) -- otherwise we succeed. ) \end{code} \end{document} uuagc-0.9.42.3/src/SequentialTypes.hs000644 000765 000024 00000016224 12127045231 021335 0ustar00jeroenbransenstaff000000 000000 module SequentialTypes where import CodeSyntax import CommonTypes import Data.Array(Array) import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import Data.Maybe(fromJust) import Data.List(partition) type Vertex = Int data PathStep = AttrStep Vertex Vertex | AtOcStep Vertex Vertex | AttrIndu Vertex Vertex deriving (Show, Eq) type Path = [PathStep] type Route = [Vertex] type Edge = (Int,Int) type EdgePath = (Edge,Path) type EdgePaths = (Edge,Path,Path) type EdgeRoute = (Edge,Route) type EdgeRoutes= (Edge,Route,Route) type Table a = Array Vertex a data ChildVisit = ChildVisit Identifier Identifier Int [Vertex] [Vertex] deriving (Eq,Show) -- field, rhs nt, visit nr., inh, syn data NTAttr = NTAInh NontermIdent Identifier Type -- nt, attribute, type | NTASyn NontermIdent Identifier Type -- nt, attribute, type deriving Show getNtaNameType :: NTAttr -> (Identifier, Type) getNtaNameType (NTAInh _ name tp) = (name,tp) getNtaNameType (NTASyn _ name tp) = (name,tp) getAttr :: CRule -> Identifier getAttr (CRule name _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) = name getAttr _ = error "Only defined for CRule" getIsIn :: CRule -> Bool getIsIn (CRule _ ii _ _ _ _ _ _ _ _ _ _ _ _ _ _) = ii getIsIn _ = error "Only defined for CRule" getHasCode :: CRule -> Bool getHasCode (CRule _ _ hc _ _ _ _ _ _ _ _ _ _ _ _ _) = hc getHasCode _ = error "Only defined for CRule" getLhsNt :: CRule -> NontermIdent getLhsNt (CRule _ _ _ nt _ _ _ _ _ _ _ _ _ _ _ _) = nt getLhsNt _ = error "Only defined for CRule" getCon :: CRule -> ConstructorIdent getCon (CRule _ _ _ _ con _ _ _ _ _ _ _ _ _ _ _) = con getCon _ = error "Only defined for CRule" getField :: CRule -> Identifier getField (CRule _ _ _ _ _ field _ _ _ _ _ _ _ _ _ _) = field getField _ = error "Only defined for CRule" getRhsNt :: CRule -> Maybe NontermIdent getRhsNt (CRule _ _ _ _ _ _ childnt _ _ _ _ _ _ _ _ _) = childnt getRhsNt _ = error "Only defined for CRule" getType :: CRule -> Maybe Type getType (CRule _ _ _ _ _ _ _ tp _ _ _ _ _ _ _ _) = tp getType _ = error "Only defined for CRule" getDefines :: CRule -> Map Int (Identifier, Identifier, Maybe Type) getDefines (CRule _ _ _ _ _ _ _ _ _ _ defines _ _ _ _ _) = defines getDefines _ = error "Only defined for CRule" getUses :: CRule -> Set (Identifier, Identifier) getUses (CRule _ _ _ _ _ _ _ _ _ _ _ _ _ uses _ _) = uses getUses _ = error "Only defined for CRule" getExplicit :: CRule -> Bool getExplicit (CRule _ _ _ _ _ _ _ _ _ _ _ _ _ _ expl _) = expl getExplicit _ = error "Only defined for CRule" isLocal, isInst, isLhs, isRhs, isSyn, isInh, hasCode :: CRule -> Bool isLocal = (_LOC==) . getField isInst = (_INST==) . getField isLhs = (_LHS==) . getField isRhs cr = not (isLhs cr || isLocal cr) isSyn cr | isLocal cr = False | getIsIn cr = isRhs cr | otherwise = isLhs cr isInh = not . isSyn hasCode cr = isLocal cr || (isLhs cr && isInh cr) || (isRhs cr && isSyn cr) isEqualField, isDifferentField, isEqualCon, isRhsOfSameCon :: CRule -> CRule -> Bool isEqualField a b = isEqualCon a b && getField a == getField b isDifferentField a b = isEqualCon a b && getField a /= getField b isEqualCon a b = getLhsNt a == getLhsNt b && getCon a == getCon b isRhsOfSameCon a b = isEqualCon a b && isRhs a && isRhs b isSynAttr, isInhAttr :: NTAttr -> Bool isSynAttr (NTAInh _ _ _) = False isSynAttr (NTASyn _ _ _) = True isInhAttr = not . isSynAttr ntattr :: CRule -> Maybe NTAttr ntattr cr | isLocal cr = Nothing | isInst cr = Nothing -- an inst definition is just considered as a local attribute definition | otherwise = let at = if isSyn cr then NTASyn else NTAInh getNt cr' = if isRhs cr' then fromJust (getRhsNt cr') else getLhsNt cr' in Just (at (getNt cr) (getAttr cr) (fromJust (getType cr))) cRuleLhsInh :: Identifier -> NontermIdent -> ConstructorIdent -> Type -> CRule cRuleLhsInh attr nt con tp = CRule attr True False nt con _LHS Nothing (Just tp) (error "cRuleLhsInh") [] Map.empty False "" Set.empty False Nothing cRuleTerminal :: Identifier -> NontermIdent -> ConstructorIdent -> Type -> CRule cRuleTerminal attr nt con tp = CRule attr True False nt con _LOC Nothing (Just tp) (error ("cRuleTerminal: " ++ show (attr, nt, con, tp))) [] Map.empty False "" Set.empty False Nothing cRuleRhsSyn :: Identifier -> NontermIdent -> ConstructorIdent -> Type -> Identifier -> NontermIdent -> CRule cRuleRhsSyn attr nt con tp field childnt = CRule attr True False nt con field (Just childnt) (Just tp) (error ("cRuleRhsSyn: " ++ show (attr, nt, con, tp, field))) [] Map.empty False "" Set.empty False Nothing defaultRule :: Identifier -> NontermIdent -> ConstructorIdent -> Identifier -> CRule defaultRule attr nt con field = CRule attr (er 1) (er 2) nt con field (er 3) (er 4) (er 5) (er 6) (er 7) (er 8) (er 9) (er 10) False Nothing where er :: Int -> a er i = error ("Default rule has no code " ++ show i) instance Eq CRule where a == b = getAttr a == getAttr b && isEqualField a b instance Ord CRule where compare a b = compare (getLhsNt a) (getLhsNt b) >/< compare (getCon a) (getCon b) >/< compare (getField a) (getField b) >/< compare (getAttr a) (getAttr b) instance Eq NTAttr where (NTAInh _ _ _) == (NTASyn _ _ _) = False (NTASyn _ _ _) == (NTAInh _ _ _) = False (NTAInh nt name _) == (NTAInh nt' name' _) = nt == nt' && name == name' (NTASyn nt name _) == (NTASyn nt' name' _) = nt == nt' && name == name' instance Ord NTAttr where compare (NTAInh _ _ _) (NTASyn _ _ _) = LT compare (NTASyn _ _ _) (NTAInh _ _ _) = GT compare (NTAInh nt name _) (NTAInh nt' name' _) = compare nt nt' >/< compare name name' compare (NTASyn nt name _) (NTASyn nt' name' _) = compare nt nt' >/< compare name name' eqCRuleDefines :: CRule -> CRule -> Bool eqCRuleDefines a b = Map.keys (getDefines a) == Map.keys (getDefines b) (>/<) :: Ordering -> Ordering -> Ordering EQ >/< b = b a >/< _ = a eqClasses :: (a -> a -> Bool) -> [a] -> [[a]] eqClasses _ [] = [] eqClasses p (a:as) = let (isA,rest) = partition (p a) as in (a:isA):eqClasses p rest lhsshow :: NTAttr -> String lhsshow (NTAInh _ attr _) = lhsname True attr lhsshow (NTASyn _ attr _) = lhsname False attr rhsshow :: Identifier -> NTAttr -> String rhsshow field (NTAInh _ attr _) = attrname False field attr rhsshow field (NTASyn _ attr _) = attrname True field attr prettyCRule :: CRule -> String prettyCRule cr = let descr | isLocal cr = "local attribute " ++ show (getAttr cr) | otherwise = (if isSyn cr then "synthesized " else "inherited ") ++ "attribute " ++ (if isRhs cr then show (getField cr) ++ "." else "") ++ (if isLhs cr then "lhs." else "") ++ (show (getAttr cr)) in show (getLhsNt cr) ++ "." ++ show (getCon cr) ++ ", " ++ descr uuagc-0.9.42.3/src/TokenDef.hs000644 000765 000024 00000005761 12127045231 017701 0ustar00jeroenbransenstaff000000 000000 {-# LANGUAGE MagicHash, UnboxedTuples, FlexibleInstances #-} module TokenDef where import UU.Scanner.Token import UU.Scanner.GenToken import UU.Scanner.Position import UU.Parsing.MachineInterface(Symbol(..)) import Data.Char(isPrint,ord) import HsToken import CommonTypes instance Symbol Token where deleteCost (Reserved key _) = case key of "DATA" -> 7# "EXT" -> 7# "ATTR" -> 7# "SEM" -> 7# "USE" -> 7# "INCLUDE" -> 7# _ -> 5# deleteCost (ValToken v _ _) = case v of TkError -> 0# _ -> 5# tokensToStrings :: [HsToken] -> [(Pos,String)] tokensToStrings = map tokenToString tokenToString :: HsToken -> (Pos, String) tokenToString tk = case tk of AGLocal var pos _ -> (pos, "@" ++ getName var) AGField field attr pos _ -> (pos, "@" ++ getName field ++ "." ++ getName attr) HsToken value pos -> (pos, value) CharToken value pos -> (pos, show value) StrToken value pos -> (pos, show value) Err mesg pos -> (pos, " ***" ++ mesg ++ "*** ") showTokens :: [(Pos,String)] -> [String] showTokens [] = [] showTokens xs = map showLine . shiftLeft . getLines $ xs getLines :: [(Pos, a)] -> [[(Pos, a)]] getLines [] = [] getLines ((p,t):xs) = let (txs,rest) = span sameLine xs sameLine (q,_) = line p == line q in ((p,t):txs) : getLines rest shiftLeft :: [[(Pos, a)]] -> [[(Pos, a)]] shiftLeft lns = let sh = let m = minimum . checkEmpty . filter (>=1) . map (column.fst.head) $ lns checkEmpty [] = [1] checkEmpty x = x in if m >= 1 then m-1 else 0 shift (p,t) = (if column p >= 1 then case p of (Pos l c f) -> Pos l (c - sh) f else p, t) in map (map shift) lns showLine :: [(Pos, [Char])] -> [Char] showLine ts = let f (p,t) r = let ct = column p in \c -> spaces (ct-c) ++ t ++ r (length t+ct) spaces x | x < 0 = "" | otherwise = replicate x ' ' in foldr f (const "") ts 1 showStrShort :: String -> String showStrShort xs = "\"" ++ concatMap f xs ++ "\"" where f '"' = "\\\"" f x = showCharShort' x showCharShort :: Char -> String showCharShort '\'' = "'" ++ "\\'" ++ "'" showCharShort c = "'" ++ showCharShort' c ++ "'" showCharShort' :: Char -> String showCharShort' '\a' = "\\a" showCharShort' '\b' = "\\b" showCharShort' '\t' = "\\t" showCharShort' '\n' = "\\n" showCharShort' '\r' = "\\r" showCharShort' '\f' = "\\f" showCharShort' '\v' = "\\v" showCharShort' '\\' = "\\\\" showCharShort' x | isPrint x = [x] | otherwise = '\\' : show (ord x) uuagc-0.9.42.3/src/UU/000755 000765 000024 00000000000 12127045231 016166 5ustar00jeroenbransenstaff000000 000000 uuagc-0.9.42.3/src/UU/UUAGC/000755 000765 000024 00000000000 12127045231 017032 5ustar00jeroenbransenstaff000000 000000 uuagc-0.9.42.3/src/UU/UUAGC.hs000644 000765 000024 00000000422 12127045231 017364 0ustar00jeroenbransenstaff000000 000000 module UU.UUAGC (uuagc, uuagcMain, compile, module Options) where import Ag (uuagcLib, uuagcExe, compile) import Options import System.Exit (ExitCode(..)) uuagc :: [String] -> FilePath -> IO (ExitCode, [FilePath]) uuagc = uuagcLib uuagcMain :: IO () uuagcMain = uuagcExeuuagc-0.9.42.3/src/UU/UUAGC/Version.hs000644 000765 000024 00000000146 12127045231 021014 0ustar00jeroenbransenstaff000000 000000 -- | Get current version of UUAGC module UU.UUAGC.Version(version) where import Paths_uuagc(version) uuagc-0.9.42.3/dist/build/000755 000765 000024 00000000000 12127045231 017110 5ustar00jeroenbransenstaff000000 000000