uuagc-cabal 1.2.0.0 → 1.3.0.0
raw patch · 9 files changed
+1127/−1101 lines, 9 filessetup-changedPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- LICENSE +23/−23
- README +36/−36
- Setup.hs +3/−3
- src-options/Options.hs +557/−553
- src/Distribution/Simple/UUAGC.hs +3/−3
- src/Distribution/Simple/UUAGC/AbsSyn.hs +18/−18
- src/Distribution/Simple/UUAGC/Parser.hs +148/−148
- src/Distribution/Simple/UUAGC/UUAGC.hs +311/−289
- uuagc-cabal.cabal +28/−28
LICENSE view
@@ -1,23 +1,23 @@-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. +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.
README view
@@ -1,36 +1,36 @@-This is a plugin for the UUAG system. - -To use UUAG in combination with Cabal, add a dependency on the packages: -uuagc -- installs the tool: uuagc -uuagc-cabal -- installs a cabal plugin that uses uuagc -Note that this package does not have a dependency on uuagc. You can use -this module without having uuagc installed. -(whether this is useful is a different question) - -Then write a custom Setup.hs: - --- -module Main where - -import Distribution.Simple -import Distribution.Simple.UUAGC (uuagcLibUserHook) -import UU.UUAGC (uuagc) - -main = defaultMainWithHooks (uuagcLibUserHook uuagc) --- - -Add extra-source-files: uuagc_options -The contents of this file are options per AG module, as specified -as follows. Write for each AG file: -* Two lines in a file uuagc_options in the root of the package: - -- - file: "src-ag/Desugar.ag" - options: module, pretty, catas, semfuns, signatures, genlinepragmas - -- - The options depend on what you actually want to compile. -* Add an extra source file to the AG file in the cabal file: - extra-source-files: src/MyProgram.ag -* Add the module to the modules list in the cabal file. - - -Originally written by Juan Cardona (or one of his students). +This is a plugin for the UUAG system.++To use UUAG in combination with Cabal, add a dependency on the packages:+uuagc -- installs the tool: uuagc+uuagc-cabal -- installs a cabal plugin that uses uuagc+Note that this package does not have a dependency on uuagc. You can use+this module without having uuagc installed.+(whether this is useful is a different question)++Then write a custom Setup.hs:++--+module Main where++import Distribution.Simple+import Distribution.Simple.UUAGC (uuagcLibUserHook)+import UU.UUAGC (uuagc)++main = defaultMainWithHooks (uuagcLibUserHook uuagc)+--++Add extra-source-files: uuagc_options+The contents of this file are options per AG module, as specified+as follows. Write for each AG file:+* Two lines in a file uuagc_options in the root of the package:+ --+ file: "src-ag/Desugar.ag"+ options: module, pretty, catas, semfuns, signatures, genlinepragmas+ --+ The options depend on what you actually want to compile.+* Add an extra source file to the AG file in the cabal file:+ extra-source-files: src/MyProgram.ag+* Add the module to the modules list in the cabal file.+++Originally written by Juan Cardona (or one of his students).
Setup.hs view
@@ -1,3 +1,3 @@-module Main where -import Distribution.Simple -main = defaultMain +module Main where+import Distribution.Simple+main = defaultMain
src-options/Options.hs view
@@ -1,553 +1,557 @@-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 [] ["loag"] (OptArg loagOpt "Bool") (boolOpt loag) "recognises all linear ordered attribute grammars by generting a SAT problem, uses --verbose to print out numbers of clauses and variables" - , MyOpt [] ["aoag"] (NoArg aoagOpt) (boolOpt aoag) "recognises all linear ordered attribute grammars by finding fake dependencies, uses --verbose to print out the selected fake dependencies" - , 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 "<max errs reported>") 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 [] ["cleanlang"] (NoArg cleanOpt) (boolOpt clean) "Generate Clean 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) "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 - , loag :: Bool - , minvisits :: Bool - , aoag :: 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 - , clean :: 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 - , loag = False - , minvisits = False - , aoag = 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 - , clean = 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 - } - -loagOpt :: (Maybe String) -> Options -> Options -loagOpt mstr opts = - case mstr of - Nothing -> opts' - Just "0" -> opts' - Just _ -> opts' {minvisits = True} - - where opts'=opts{loag = True, visit = True} - -aoagOpt :: Options -> Options -aoagOpt opts = - opts{loag = True, visit = True, aoag = True} - ---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, cleanOpt, 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 } -cleanOpt opts = opts { clean = True } --TODO: More? -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 opt +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 [] ["loag"] (OptArg loagOpt "Bool") (boolOpt loag) "recognises all linear ordered attribute grammars by generting a SAT problem, uses --verbose to print out numbers of clauses and variables"+ , MyOpt [] ["aoag"] (NoArg aoagOpt) (boolOpt aoag) "recognises all linear ordered attribute grammars by finding fake dependencies, uses --verbose to print out the selected fake dependencies"+ , 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 "<max errs reported>") 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 [] ["genmirage"] (NoArg genMirageOpt) (boolOpt genmirage) "Generate output for the AG visualizer Mirage"+ , 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 [] ["cleanlang"] (NoArg cleanOpt) (boolOpt clean) "Generate Clean 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) "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+ , loag :: Bool+ , minvisits :: Bool+ , aoag :: 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+ , genmirage :: Bool+ , genAspectAG :: Bool+ , noGroup :: [String]+ , extends :: Maybe String+ , genAttributeList :: Bool+ , forceIrrefutables :: Maybe String+ , uniqueDispenser :: String+ , lcKeywords :: Bool+ , doubleColons :: Bool+ , monadic :: Bool+ , ocaml :: Bool+ , clean :: 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+ , loag = False+ , minvisits = False+ , aoag = 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+ , genmirage = False+ , genAspectAG = False+ , noGroup = []+ , extends = Nothing+ , genAttributeList = False+ , forceIrrefutables = Nothing+ , uniqueDispenser = "nextUnique"+ , lcKeywords = False+ , doubleColons = False+ , monadic = False+ , ocaml = False+ , clean = 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+ }++loagOpt :: (Maybe String) -> Options -> Options+loagOpt mstr opts = + case mstr of+ Nothing -> opts'+ Just "0" -> opts'+ Just _ -> opts' {minvisits = True}++ where opts'=opts{loag = True, visit = True}++aoagOpt :: Options -> Options+aoagOpt opts = + opts{loag = True, visit = True, aoag = True}++--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, genMirageOpt, genAspectAGOpt, dummyTokenVisitOpt, tupleAsDummyTokenOpt, stateAsDummyTokenOpt, strictDummyTokenOpt, noPerRuleTypeSigsOpt, noPerStateTypeSigsOpt, noEagerBlackholingOpt, noPerRuleCostCentresOpt, noPerVisitCostCentresOpt, helpInliningOpt, noInlinePragmasOpt, aggressiveInlinePragmasOpt, lateHigherOrderBindingOpt, monadicWrappersOpt, referenceOpt, genAttrListOpt, lcKeywordsOpt, doubleColonsOpt, haskellSyntaxOpt, monadicOpt, parallelOpt, ocamlOpt, cleanOpt, 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 }+genMirageOpt opts = opts{genmirage = 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 }+cleanOpt opts = opts { clean = True } --TODO: More?+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 opt
src/Distribution/Simple/UUAGC.hs view
@@ -1,3 +1,3 @@-module Distribution.Simple.UUAGC(module Distribution.Simple.UUAGC.UUAGC) where - -import Distribution.Simple.UUAGC.UUAGC +module Distribution.Simple.UUAGC(module Distribution.Simple.UUAGC.UUAGC) where++import Distribution.Simple.UUAGC.UUAGC
src/Distribution/Simple/UUAGC/AbsSyn.hs view
@@ -1,18 +1,18 @@-module Distribution.Simple.UUAGC.AbsSyn where - -import Options -import System.FilePath(normalise) - -data AGFileOption = AGFileOption {filename :: String, - fileClasses :: [String], - opts :: Options} - -data AGOptionsClass = AGOptionsClass {className :: String, opts' :: Options} - -type AGFileOptions = [AGFileOption] - -lookupFileOptions :: FilePath -> AGFileOptions -> Options -lookupFileOptions s = foldl f noOptions - where f e (AGFileOption s' classes opt) - | s == (normalise s') = opt - | otherwise = e +module Distribution.Simple.UUAGC.AbsSyn where++import Options+import System.FilePath(normalise)++data AGFileOption = AGFileOption {filename :: String,+ fileClasses :: [String],+ opts :: Options}++data AGOptionsClass = AGOptionsClass {className :: String, opts' :: Options}++type AGFileOptions = [AGFileOption]++lookupFileOptions :: FilePath -> AGFileOptions -> Options+lookupFileOptions s = foldl f noOptions+ where f e (AGFileOption s' classes opt)+ | s == (normalise s') = opt+ | otherwise = e
src/Distribution/Simple/UUAGC/Parser.hs view
@@ -1,148 +1,148 @@-{-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Simple.UUAGC.Parser(parserAG, - parserAG', - scanner, - parseIOAction, - parseClassAG, - parseOptionAG) where - -import UU.Parsing -import UU.Scanner -import Distribution.Simple.UUAGC.AbsSyn -import Options -import System.Console.GetOpt -import System.IO.Unsafe(unsafeInterleaveIO) -import System.IO(hPutStr,stderr) -import Control.Monad.Error.Class - -data ParserError = DefParserError String - deriving (Show, Eq, Read) - -instance Error ParserError where - strMsg x = DefParserError x - -uFlags :: [String] -uFlags = concat [ filter (not . null) x | Option _ x _ _ <- options] - -kwtxt = uFlags ++ ["file", "options", "class", "with"] -kwotxt = ["=",":","..","."] -sctxt = "..," -octxt = "=:.," - -posTxt :: Pos -posTxt = Pos 0 0 "" - -puFlag :: OptDescr (Options -> Options) -> Parser Token (Options -> Options) -puFlag (Option _ [] _ _) = pFail -puFlag (Option _ kws (NoArg f) _) = pAny (\kw -> const f <$> pKey kw) kws -puFlag (Option _ kws (ReqArg f _) _) = pAny (\kw -> f <$ pKey kw <*> pString) kws -puFlag (Option _ kws (OptArg f _) _) = pAny (\kw -> const (f Nothing) <$> pKey kw - <|> f . Just <$ pKey kw <*> pString) kws - -pugFlags :: [Parser Token (Options -> Options)] -pugFlags = map puFlag options - -pAnyFlag = pAny id pugFlags - -pSep :: Parser Token String -pSep = pKey ":" <|> pKey "=" - -pFileClasses :: Parser Token [String] -pFileClasses = pKey "with" *> (pCommas pString) - <|> pSucceed [] - -pAGFileOption :: Parser Token AGFileOption -pAGFileOption = (\f cl opt -> AGFileOption f cl (constructOptions opt)) - <$> (pKey "file" *> pSep *> pString) - <*> pFileClasses - <*> (pKey "options" *> pSep *> pCommas pAnyFlag) - -pAGOptionsClass :: Parser Token AGOptionsClass -pAGOptionsClass = (\c opt -> AGOptionsClass c (constructOptions opt)) - <$> (pKey "class" *> pSep *> pString) - <*> (pKey "options" *> pSep *> pCommas pAnyFlag) - -pAGFileOptions :: Parser Token AGFileOptions -pAGFileOptions = pList pAGFileOption - -parserAG :: FilePath -> IO AGFileOptions -parserAG fp = do s <- readFile fp - parseIOAction action pAGFileOptions (scanner fp s) - -parserAG' :: FilePath -> IO (Either ParserError AGFileOptions) -parserAG' fp = do s <- readFile fp - let steps = parse pAGFileOptions (scanner fp s) - let (Pair res _, mesg) = evalStepsMessages steps - if null mesg - then return $ Right res - else do let err = foldr (++) [] $ map message2error mesg - return (Left $ DefParserError err) - -message2error :: Message Token (Maybe Token) -> String -message2error (Msg e p a) = "Expecting: " ++ (show e) ++ " at " ++ action - where action = case a of - Insert s -> " Inserting: " ++ (show s) - Delete s -> " Deleting: " ++ (show s) - Other s -> s - -liftParse p text = parseIOAction action p (scanner text text) - -parseOptionAG :: String -> IO AGFileOption -parseOptionAG = liftParse pAGFileOption - -parseClassAG :: String -> IO AGOptionsClass -parseClassAG = liftParse pAGOptionsClass - -scanner :: String -> String -> [Token] -scanner fn s = scan kwtxt kwotxt sctxt octxt (Pos 0 0 fn) s - -action :: (Eq s, Show s, Show p) => Message s p -> IO () -action m = hPutStr stderr (show m) - -test :: (Show a) => Parser Token a -> [Token] -> IO () -test p inp = do r <- parseIOAction action p inp - print r - -parseIOAction :: (Symbol s, InputState inp s p) - => (Message s p -> IO ()) - -> AnaParser inp Pair s p a - -> inp - -> IO a -parseIOAction showMessage p inp - = do (Pair v final) <- evalStepsIOAction showMessage (parse p inp) - final `seq` return v -- in order to force the trailing error messages to be printed - -evalStepsIOAction :: (Message s p -> IO ()) - -> Steps b s p - -> IO b -evalStepsIOAction showMessage = evalStepsIOAction' showMessage (-1) - - -evalStepsIOAction' :: (Message s p -> IO ()) - -> Int - -> Steps b s p - -> IO b -evalStepsIOAction' showMessage n (steps :: Steps b s p) = eval n steps - where eval :: Int -> Steps a s p -> IO a - eval 0 steps = return (evalSteps steps) - eval n steps = case steps of - OkVal v rest -> do arg <- unsafeInterleaveIO (eval n rest) - return (v arg) - Ok rest -> eval n rest - Cost _ rest -> eval n rest - StRepair _ msg rest -> do showMessage msg - eval (n-1) rest - Best _ rest _ -> eval n rest - NoMoreSteps v -> return v - - -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,[]) +{-# LANGUAGE ScopedTypeVariables #-}+module Distribution.Simple.UUAGC.Parser(parserAG,+ parserAG',+ scanner,+ parseIOAction,+ parseClassAG,+ parseOptionAG) where++import UU.Parsing+import UU.Scanner+import Distribution.Simple.UUAGC.AbsSyn+import Options+import System.Console.GetOpt+import System.IO.Unsafe(unsafeInterleaveIO)+import System.IO(hPutStr,stderr)+import Control.Monad.Error.Class++data ParserError = DefParserError String+ deriving (Show, Eq, Read)++instance Error ParserError where+ strMsg x = DefParserError x++uFlags :: [String]+uFlags = concat [ filter (not . null) x | Option _ x _ _ <- options]++kwtxt = uFlags ++ ["file", "options", "class", "with"]+kwotxt = ["=",":","..","."]+sctxt = "..,"+octxt = "=:.,"++posTxt :: Pos+posTxt = Pos 0 0 ""++puFlag :: OptDescr (Options -> Options) -> Parser Token (Options -> Options)+puFlag (Option _ [] _ _) = pFail+puFlag (Option _ kws (NoArg f) _) = pAny (\kw -> const f <$> pKey kw) kws+puFlag (Option _ kws (ReqArg f _) _) = pAny (\kw -> f <$ pKey kw <*> pString) kws+puFlag (Option _ kws (OptArg f _) _) = pAny (\kw -> const (f Nothing) <$> pKey kw+ <|> f . Just <$ pKey kw <*> pString) kws++pugFlags :: [Parser Token (Options -> Options)]+pugFlags = map puFlag options++pAnyFlag = pAny id pugFlags++pSep :: Parser Token String+pSep = pKey ":" <|> pKey "="++pFileClasses :: Parser Token [String]+pFileClasses = pKey "with" *> (pCommas pString)+ <|> pSucceed []++pAGFileOption :: Parser Token AGFileOption+pAGFileOption = (\f cl opt -> AGFileOption f cl (constructOptions opt))+ <$> (pKey "file" *> pSep *> pString)+ <*> pFileClasses+ <*> (pKey "options" *> pSep *> pCommas pAnyFlag)++pAGOptionsClass :: Parser Token AGOptionsClass+pAGOptionsClass = (\c opt -> AGOptionsClass c (constructOptions opt))+ <$> (pKey "class" *> pSep *> pString)+ <*> (pKey "options" *> pSep *> pCommas pAnyFlag)++pAGFileOptions :: Parser Token AGFileOptions+pAGFileOptions = pList pAGFileOption++parserAG :: FilePath -> IO AGFileOptions+parserAG fp = do s <- readFile fp+ parseIOAction action pAGFileOptions (scanner fp s)++parserAG' :: FilePath -> IO (Either ParserError AGFileOptions)+parserAG' fp = do s <- readFile fp+ let steps = parse pAGFileOptions (scanner fp s)+ let (Pair res _, mesg) = evalStepsMessages steps+ if null mesg+ then return $ Right res+ else do let err = foldr (++) [] $ map message2error mesg+ return (Left $ DefParserError err)++message2error :: Message Token (Maybe Token) -> String+message2error (Msg e p a) = "Expecting: " ++ (show e) ++ " at " ++ action+ where action = case a of+ Insert s -> " Inserting: " ++ (show s)+ Delete s -> " Deleting: " ++ (show s)+ Other s -> s++liftParse p text = parseIOAction action p (scanner text text)++parseOptionAG :: String -> IO AGFileOption+parseOptionAG = liftParse pAGFileOption++parseClassAG :: String -> IO AGOptionsClass+parseClassAG = liftParse pAGOptionsClass++scanner :: String -> String -> [Token]+scanner fn s = scan kwtxt kwotxt sctxt octxt (Pos 0 0 fn) s++action :: (Eq s, Show s, Show p) => Message s p -> IO ()+action m = hPutStr stderr (show m)++test :: (Show a) => Parser Token a -> [Token] -> IO ()+test p inp = do r <- parseIOAction action p inp+ print r++parseIOAction :: (Symbol s, InputState inp s p)+ => (Message s p -> IO ())+ -> AnaParser inp Pair s p a+ -> inp+ -> IO a+parseIOAction showMessage p inp+ = do (Pair v final) <- evalStepsIOAction showMessage (parse p inp)+ final `seq` return v -- in order to force the trailing error messages to be printed++evalStepsIOAction :: (Message s p -> IO ())+ -> Steps b s p+ -> IO b+evalStepsIOAction showMessage = evalStepsIOAction' showMessage (-1)+++evalStepsIOAction' :: (Message s p -> IO ())+ -> Int+ -> Steps b s p+ -> IO b+evalStepsIOAction' showMessage n (steps :: Steps b s p) = eval n steps+ where eval :: Int -> Steps a s p -> IO a+ eval 0 steps = return (evalSteps steps)+ eval n steps = case steps of+ OkVal v rest -> do arg <- unsafeInterleaveIO (eval n rest)+ return (v arg)+ Ok rest -> eval n rest+ Cost _ rest -> eval n rest+ StRepair _ msg rest -> do showMessage msg+ eval (n-1) rest+ Best _ rest _ -> eval n rest+ NoMoreSteps v -> return v+++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,[])
src/Distribution/Simple/UUAGC/UUAGC.hs view
@@ -1,289 +1,311 @@-{-# LANGUAGE CPP #-} -module Distribution.Simple.UUAGC.UUAGC(uuagcUserHook, - uuagcUserHook', - uuagc, - uuagcLibUserHook, - uuagcFromString - ) where - --- import Distribution.Simple.BuildPaths (autogenComponentModulesDir) -import Debug.Trace -import Distribution.Simple -import Distribution.Simple.PreProcess -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Utils -import Distribution.Simple.Setup -import Distribution.PackageDescription hiding (Flag) -import Distribution.Simple.UUAGC.AbsSyn( AGFileOption(..) - , AGFileOptions - , AGOptionsClass(..) - , lookupFileOptions - , fileClasses - ) -import Distribution.Simple.UUAGC.Parser -import Options hiding (verbose) -import Distribution.Verbosity -import System.Process( readProcessWithExitCode ) -import System.Directory(getModificationTime - ,doesFileExist - ,removeFile) -import System.FilePath(pathSeparators, - (</>), - takeFileName, - normalise, - joinPath, - dropFileName, - addExtension, - dropExtension, - replaceExtension, - splitDirectories) - -import System.Exit (ExitCode(..)) -import System.IO( openFile, IOMode(..), - hFileSize, - hSetFileSize, - hClose, - hGetContents, - hFlush, - Handle(..), stderr, hPutStr, hPutStrLn) -import System.Exit(exitFailure) -import Control.Exception (throwIO) -import Control.Monad (liftM, when, guard, forM_, forM) -import Control.Arrow ((&&&), second) -import Data.Maybe (maybeToList) -import Data.Either (partitionEithers) -import Data.List (nub,intersperse) -import Data.Map (Map) -import qualified Data.Map as Map - -{-# DEPRECATED uuagcUserHook, uuagcUserHook', uuagc "Use uuagcLibUserHook instead" #-} - --- | 'uuagc' returns the name of the uuagc compiler -uuagcn = "uuagc" - --- | 'defUUAGCOptions' returns the default names of the uuagc options -defUUAGCOptions :: String -defUUAGCOptions = "uuagc_options" - --- | File used to store de classes defined in the cabal file. -agClassesFile :: String -agClassesFile = "ag_file_options" - --- | The prefix used for the cabal file optionsw -agModule :: String -agModule = "x-agmodule" - --- | The prefix used for the cabal file options used for defining classes -agClass :: String -agClass = "x-agclass" - --- | Deprecated userhook -uuagcUserHook :: UserHooks -uuagcUserHook = uuagcUserHook' uuagcn - --- | Deprecated userhook -uuagcUserHook' :: String -> UserHooks -uuagcUserHook' uuagcPath = uuagcLibUserHook (uuagcFromString uuagcPath) - --- | Create uuagc function using shell (old method) -uuagcFromString :: String -> [String] -> FilePath -> IO (ExitCode, [FilePath]) -uuagcFromString uuagcPath args file = do - (ec,out,err) <- readProcessWithExitCode uuagcPath (args ++ [file]) "" - case ec of - ExitSuccess -> - do hPutStr stderr err - return (ExitSuccess, words out) - (ExitFailure exc) -> - do hPutStrLn stderr (uuagcPath ++ ": " ++ show exc) - hPutStr stderr out - hPutStr stderr err - return (ExitFailure exc, []) - --- | Main hook, argument should be uuagc function -uuagcLibUserHook :: ([String] -> FilePath -> IO (ExitCode, [FilePath])) -> UserHooks -uuagcLibUserHook uuagc = hooks where - hooks = simpleUserHooks { hookedPreProcessors = ("ag", ag):("lag",ag):knownSuffixHandlers - , buildHook = uuagcBuildHook uuagc --- , sDistHook = uuagcSDistHook uuagc - } - ag = uuagc' uuagc - -originalPreBuild = preBuild simpleUserHooks -originalBuildHook = buildHook simpleUserHooks ---originalSDistHook = sDistHook simpleUserHooks - -putErrorInfo :: Handle -> IO () -putErrorInfo h = hGetContents h >>= hPutStr stderr - --- | 'updateAGFile' search into the uuagc options file for a list of all --- AG Files and theirs file dependencies in order to see if the latters --- are more updated that the formers, and if this is the case to --- update the AG File -updateAGFile :: ([String] -> FilePath -> IO (ExitCode, [FilePath])) - -> Map FilePath (Options, Maybe (FilePath, [String])) - -> (FilePath, (Options, Maybe (FilePath, [String]))) - -> IO () -updateAGFile _ _ (_,(_,Nothing)) = return () -updateAGFile uuagc newOptions (file,(opts,Just (gen,sp))) = do - hasGen <- doesFileExist gen - when hasGen $ do - (ec, files) <- uuagc (optionsToString $ opts { genFileDeps = True, searchPath = sp }) file - case ec of - ExitSuccess -> do - let newOpts :: Options - newOpts = maybe noOptions fst $ Map.lookup file newOptions - optRebuild = optionsToString newOpts /= optionsToString opts - modRebuild <- - if null files - then return False - else do - flsmt <- mapM getModificationTime files - let maxModified = maximum flsmt - fmt <- getModificationTime gen - return $ maxModified > fmt - -- When some dependency is newer or options have changed, we should regenerate - when (optRebuild || modRebuild) $ removeFile gen - ex@(ExitFailure _) -> throwIO ex - -getAGFileOptions :: [(String, String)] -> IO AGFileOptions -getAGFileOptions extra = do - cabalOpts <- mapM (parseOptionAG . snd) $ filter ((== agModule) . fst) extra - usesOptionsFile <- doesFileExist defUUAGCOptions - if usesOptionsFile - then do r <- parserAG' defUUAGCOptions - case r of - Left e -> dieNoVerbosity (show e) - Right a -> return $ cabalOpts ++ a - else return cabalOpts - -getAGClasses :: [(String, String)] -> IO [AGOptionsClass] -getAGClasses = mapM (parseClassAG . snd) . filter ((== agClass) . fst) - -writeFileOptions :: FilePath -> Map FilePath (Options, Maybe (FilePath,[String])) -> IO () -writeFileOptions classesPath opts = do - hClasses <- openFile classesPath WriteMode - hPutStr hClasses $ show $ Map.map (\(opt,gen) -> (optionsToString opt, gen)) opts - hFlush hClasses - hClose hClasses - -readFileOptions :: FilePath -> IO (Map FilePath (Options, Maybe (FilePath,[String]))) -readFileOptions classesPath = do - isFile <- doesFileExist classesPath - if isFile - then do hClasses <- openFile classesPath ReadMode - sClasses <- hGetContents hClasses - classes <- readIO sClasses :: IO (Map FilePath ([String], Maybe (FilePath,[String]))) - hClose hClasses - return $ Map.map (\(opt,gen) -> let (opt',_,_) = getOptions opt in (opt', gen)) classes - else return Map.empty - -getOptionsFromClass :: [(String, Options)] -> AGFileOption -> ([String], Options) -getOptionsFromClass classes fOpt = - second (foldl combineOptions (opts fOpt)) - . partitionEithers $ do - fClass <- fileClasses fOpt - case fClass `lookup` classes of - Just x -> return $ Right x - Nothing -> return $ Left $ "Warning: The class " - ++ show fClass - ++ " is not defined." - --- uuagcSDistHook :: ([String] -> FilePath -> IO (ExitCode, [FilePath])) --- -> PackageDescription --- -> Maybe LocalBuildInfo --- -> UserHooks --- -> SDistFlags --- -> IO () --- uuagcSDistHook uuagc pd mbLbi uh df = do --- {- --- case mbLbi of --- Nothing -> warn normal "sdist: the local buildinfo was not present. Skipping AG initialization. Dist may fail." --- Just lbi -> let classesPath = buildDir lbi </> agClassesFile --- in commonHook uuagc classesPath pd lbi (sDistVerbosity df) --- originalSDistHook pd mbLbi uh df --- -} --- originalSDistHook pd mbLbi (uh { hookedPreProcessors = ("ag", nouuagc):("lag",nouuagc):knownSuffixHandlers }) df -- bypass preprocessors - -uuagcBuildHook - :: ([String] -> FilePath -> IO (ExitCode, [FilePath])) - -> PackageDescription - -> LocalBuildInfo - -> UserHooks - -> BuildFlags - -> IO () -uuagcBuildHook uuagc pd lbi uh bf = do - let classesPath = buildDir lbi </> agClassesFile - commonHook uuagc classesPath pd lbi (buildVerbosity bf) - originalBuildHook pd lbi uh bf - -commonHook :: ([String] -> FilePath -> IO (ExitCode, [FilePath])) - -> FilePath - -> PackageDescription - -> LocalBuildInfo - -> Flag Verbosity - -> IO () -commonHook uuagc classesPath pd lbi fl = do - let verbosity = fromFlagOrDefault normal fl - info verbosity $ "commonHook: Assuming AG classesPath: " ++ classesPath - createDirectoryIfMissingVerbose verbosity True (buildDir lbi) - -- Read already existing options - -- Map FilePath (Options, Maybe (FilePath,[String])) - oldOptions <- readFileOptions classesPath - -- Read options from cabal and settings file - let lib = library pd - exes = executables pd - bis = map libBuildInfo (maybeToList lib) ++ map buildInfo exes - classes <- map (className &&& opts') `fmap` (getAGClasses . customFieldsPD $ pd) - configOptions <- getAGFileOptions (bis >>= customFieldsBI) - -- Construct new options map - newOptionsL <- forM configOptions (\ opt -> - let (notFound, opts) = getOptionsFromClass classes $ opt - file = normalise $ filename opt - gen = maybe Nothing snd $ Map.lookup file oldOptions - in do info verbosity $ "options for " ++ file ++ ": " ++ unwords (optionsToString opts) - forM_ notFound (hPutStrLn stderr) - return (file, (opts, gen))) - let newOptions = Map.fromList newOptionsL - writeFileOptions classesPath newOptions - -- Check if files should be regenerated - mapM_ (updateAGFile uuagc newOptions) $ Map.toList oldOptions - -getAGFileList :: AGFileOptions -> [FilePath] -getAGFileList = map (normalise . filename) - -uuagc :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -uuagc = uuagc' (uuagcFromString uuagcn) - -uuagc' :: ([String] -> FilePath -> IO (ExitCode, [FilePath])) - -> BuildInfo - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> PreProcessor -uuagc' uuagc build lbi _ = - PreProcessor { - platformIndependent = True, - runPreProcessor = mkSimplePreProcessor $ \ inFile outFile verbosity -> - do notice verbosity $ "[UUAGC] processing: " ++ inFile ++ " generating: " ++ outFile - let classesPath = buildDir lbi </> agClassesFile - info verbosity $ "uuagc-preprocessor: Assuming AG classesPath: " ++ classesPath - fileOpts <- readFileOptions classesPath - opts <- case Map.lookup inFile fileOpts of - Nothing -> do warn verbosity $ "No options found for " ++ inFile - return noOptions - Just (opt,gen) -> return opt - let search = dropFileName inFile - options = opts { searchPath = search : hsSourceDirs build ++ searchPath opts - , outputFiles = outFile : (outputFiles opts) } - (eCode,_) <- uuagc (optionsToString options) inFile - case eCode of - ExitSuccess -> writeFileOptions classesPath (Map.insert inFile (opts, Just (outFile, searchPath options)) fileOpts) - ex@(ExitFailure _) -> throwIO ex - } - -nouuagc :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -nouuagc build lbi _ = - PreProcessor { - platformIndependent = True, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do - info verbosity ("skipping: " ++ outFile) - } +{-# LANGUAGE CPP #-}+module Distribution.Simple.UUAGC.UUAGC(uuagcUserHook,+ uuagcUserHook',+ uuagc,+ uuagcLibUserHook,+ uuagcFromString+ ) where++-- import Distribution.Simple.BuildPaths (autogenComponentModulesDir)+import Debug.Trace+import Distribution.Simple+import Distribution.Simple.PreProcess+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Utils+import Distribution.Simple.Setup+import Distribution.PackageDescription hiding (Flag)+import Distribution.Simple.UUAGC.AbsSyn( AGFileOption(..)+ , AGFileOptions+ , AGOptionsClass(..)+ , lookupFileOptions+ , fileClasses+ )+import Distribution.Simple.UUAGC.Parser+import Options hiding (verbose)+import Distribution.Verbosity+import System.Process( readProcessWithExitCode )+import System.Directory(getModificationTime+ ,doesFileExist+ ,removeFile)+import System.FilePath(pathSeparators,+ (</>),+ takeFileName,+ normalise,+ joinPath,+ dropFileName,+ addExtension,+ dropExtension,+ replaceExtension,+ splitDirectories)++import System.Exit (ExitCode(..))+import System.IO( openFile, IOMode(..),+ hFileSize,+ hSetFileSize,+ hClose,+ hGetContents,+ hFlush,+ Handle(..), stderr, hPutStr, hPutStrLn)+import System.Exit(exitFailure)+import Control.Exception (throwIO)+import Control.Monad (liftM, when, guard, forM_, forM)+import Control.Arrow ((&&&), second)+import Data.Maybe (maybeToList)+import Data.Either (partitionEithers)+import Data.List (nub,intersperse)+import Data.Map (Map)+import qualified Data.Map as Map++#if MIN_VERSION_Cabal(3,6,0)+import Distribution.Utils.Path (getSymbolicPath, PackageDir, SourceDir, SymbolicPath)+#endif++{-# DEPRECATED uuagcUserHook, uuagcUserHook', uuagc "Use uuagcLibUserHook instead" #-}++-- | 'uuagc' returns the name of the uuagc compiler+uuagcn = "uuagc"++-- | 'defUUAGCOptions' returns the default names of the uuagc options+defUUAGCOptions :: String+defUUAGCOptions = "uuagc_options"++-- | File used to store de classes defined in the cabal file.+agClassesFile :: String+agClassesFile = "ag_file_options"++-- | The prefix used for the cabal file optionsw+agModule :: String+agModule = "x-agmodule"++-- | The prefix used for the cabal file options used for defining classes+agClass :: String+agClass = "x-agclass"++-- | Deprecated userhook+uuagcUserHook :: UserHooks+uuagcUserHook = uuagcUserHook' uuagcn++-- | Deprecated userhook+uuagcUserHook' :: String -> UserHooks+uuagcUserHook' uuagcPath = uuagcLibUserHook (uuagcFromString uuagcPath)++-- | Create uuagc function using shell (old method)+uuagcFromString :: String -> [String] -> FilePath -> IO (ExitCode, [FilePath])+uuagcFromString uuagcPath args file = do+ (ec,out,err) <- readProcessWithExitCode uuagcPath (args ++ [file]) ""+ case ec of+ ExitSuccess ->+ do hPutStr stderr err+ return (ExitSuccess, words out)+ (ExitFailure exc) ->+ do hPutStrLn stderr (uuagcPath ++ ": " ++ show exc)+ hPutStr stderr out+ hPutStr stderr err+ return (ExitFailure exc, [])++-- | Main hook, argument should be uuagc function+uuagcLibUserHook :: ([String] -> FilePath -> IO (ExitCode, [FilePath])) -> UserHooks+uuagcLibUserHook uuagc = hooks where+ hooks = simpleUserHooks { hookedPreProcessors = ("ag", ag):("lag",ag):knownSuffixHandlers+ , buildHook = uuagcBuildHook uuagc+-- , sDistHook = uuagcSDistHook uuagc+ }+ ag = uuagc' uuagc++originalPreBuild = preBuild simpleUserHooks+originalBuildHook = buildHook simpleUserHooks+--originalSDistHook = sDistHook simpleUserHooks++putErrorInfo :: Handle -> IO ()+putErrorInfo h = hGetContents h >>= hPutStr stderr++-- | 'updateAGFile' search into the uuagc options file for a list of all+-- AG Files and theirs file dependencies in order to see if the latters+-- are more updated that the formers, and if this is the case to+-- update the AG File+updateAGFile :: ([String] -> FilePath -> IO (ExitCode, [FilePath]))+ -> Map FilePath (Options, Maybe (FilePath, [String]))+ -> (FilePath, (Options, Maybe (FilePath, [String])))+ -> IO ()+updateAGFile _ _ (_,(_,Nothing)) = return ()+updateAGFile uuagc newOptions (file,(opts,Just (gen,sp))) = do+ hasGen <- doesFileExist gen+ when hasGen $ do+ (ec, files) <- uuagc (optionsToString $ opts { genFileDeps = True, searchPath = sp }) file+ case ec of+ ExitSuccess -> do+ let newOpts :: Options+ newOpts = maybe noOptions fst $ Map.lookup file newOptions+ optRebuild = optionsToString newOpts /= optionsToString opts+ modRebuild <-+ if null files+ then return False+ else do+ flsmt <- mapM getModificationTime files+ let maxModified = maximum flsmt+ fmt <- getModificationTime gen+ return $ maxModified > fmt+ -- When some dependency is newer or options have changed, we should regenerate+ when (optRebuild || modRebuild) $ removeFile gen+ ex@(ExitFailure _) -> throwIO ex++getAGFileOptions :: [(String, String)] -> IO AGFileOptions+getAGFileOptions extra = do+ cabalOpts <- mapM (parseOptionAG . snd) $ filter ((== agModule) . fst) extra+ usesOptionsFile <- doesFileExist defUUAGCOptions+ if usesOptionsFile+ then do r <- parserAG' defUUAGCOptions+ case r of+ Left e -> dieNoVerbosity (show e)+ Right a -> return $ cabalOpts ++ a+ else return cabalOpts++getAGClasses :: [(String, String)] -> IO [AGOptionsClass]+getAGClasses = mapM (parseClassAG . snd) . filter ((== agClass) . fst)++writeFileOptions :: FilePath -> Map FilePath (Options, Maybe (FilePath,[String])) -> IO ()+writeFileOptions classesPath opts = do+ hClasses <- openFile classesPath WriteMode+ hPutStr hClasses $ show $ Map.map (\(opt,gen) -> (optionsToString opt, gen)) opts+ hFlush hClasses+ hClose hClasses++readFileOptions :: FilePath -> IO (Map FilePath (Options, Maybe (FilePath,[String])))+readFileOptions classesPath = do+ isFile <- doesFileExist classesPath+ if isFile+ then do hClasses <- openFile classesPath ReadMode+ sClasses <- hGetContents hClasses+ classes <- readIO sClasses :: IO (Map FilePath ([String], Maybe (FilePath,[String])))+ hClose hClasses+ return $ Map.map (\(opt,gen) -> let (opt',_,_) = getOptions opt in (opt', gen)) classes+ else return Map.empty++getOptionsFromClass :: [(String, Options)] -> AGFileOption -> ([String], Options)+getOptionsFromClass classes fOpt =+ second (foldl combineOptions (opts fOpt))+ . partitionEithers $ do+ fClass <- fileClasses fOpt+ case fClass `lookup` classes of+ Just x -> return $ Right x+ Nothing -> return $ Left $ "Warning: The class "+ ++ show fClass+ ++ " is not defined."++-- uuagcSDistHook :: ([String] -> FilePath -> IO (ExitCode, [FilePath]))+-- -> PackageDescription+-- -> Maybe LocalBuildInfo+-- -> UserHooks+-- -> SDistFlags+-- -> IO ()+-- uuagcSDistHook uuagc pd mbLbi uh df = do+-- {-+-- case mbLbi of+-- Nothing -> warn normal "sdist: the local buildinfo was not present. Skipping AG initialization. Dist may fail."+-- Just lbi -> let classesPath = buildDir lbi </> agClassesFile+-- in commonHook uuagc classesPath pd lbi (sDistVerbosity df)+-- originalSDistHook pd mbLbi uh df+-- -}+-- originalSDistHook pd mbLbi (uh { hookedPreProcessors = ("ag", nouuagc):("lag",nouuagc):knownSuffixHandlers }) df -- bypass preprocessors++uuagcBuildHook+ :: ([String] -> FilePath -> IO (ExitCode, [FilePath]))+ -> PackageDescription+ -> LocalBuildInfo+ -> UserHooks+ -> BuildFlags+ -> IO ()+uuagcBuildHook uuagc pd lbi uh bf = do+ let classesPath = buildDir lbi </> agClassesFile+ commonHook uuagc classesPath pd lbi (buildVerbosity bf)+ originalBuildHook pd lbi uh bf++commonHook :: ([String] -> FilePath -> IO (ExitCode, [FilePath]))+ -> FilePath+ -> PackageDescription+ -> LocalBuildInfo+ -> Flag Verbosity+ -> IO ()+commonHook uuagc classesPath pd lbi fl = do+ let verbosity = fromFlagOrDefault normal fl+ info verbosity $ "commonHook: Assuming AG classesPath: " ++ classesPath+ createDirectoryIfMissingVerbose verbosity True (buildDir lbi)+ -- Read already existing options+ -- Map FilePath (Options, Maybe (FilePath,[String]))+ oldOptions <- readFileOptions classesPath+ -- Read options from cabal and settings file+ let lib = library pd+ exes = executables pd+ bis = map libBuildInfo (maybeToList lib) ++ map buildInfo exes+ classes <- map (className &&& opts') `fmap` (getAGClasses . customFieldsPD $ pd)+ configOptions <- getAGFileOptions (bis >>= customFieldsBI)+ -- Construct new options map+ newOptionsL <- forM configOptions (\ opt ->+ let (notFound, opts) = getOptionsFromClass classes $ opt+ file = normalise $ filename opt+ gen = maybe Nothing snd $ Map.lookup file oldOptions+ in do info verbosity $ "options for " ++ file ++ ": " ++ unwords (optionsToString opts)+ forM_ notFound (hPutStrLn stderr)+ return (file, (opts, gen)))+ let newOptions = Map.fromList newOptionsL+ writeFileOptions classesPath newOptions+ -- Check if files should be regenerated+ mapM_ (updateAGFile uuagc newOptions) $ Map.toList oldOptions++getAGFileList :: AGFileOptions -> [FilePath]+getAGFileList = map (normalise . filename)++uuagc :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor+uuagc = uuagc' (uuagcFromString uuagcn)++uuagc' :: ([String] -> FilePath -> IO (ExitCode, [FilePath]))+ -> BuildInfo+ -> LocalBuildInfo+ -> ComponentLocalBuildInfo+ -> PreProcessor+uuagc' uuagc build lbi _ =+ PreProcessor {+#if MIN_VERSION_Cabal(3,8,1)+ -- The ppOrdering field was added in Cabal 3.8.1 (GHC 9.4)+ ppOrdering = \_verbosity _files modules -> pure modules,+#endif+ platformIndependent = True,+ runPreProcessor = mkSimplePreProcessor $ \ inFile outFile verbosity ->+ do notice verbosity $ "[UUAGC] processing: " ++ inFile ++ " generating: " ++ outFile+ let classesPath = buildDir lbi </> agClassesFile+ info verbosity $ "uuagc-preprocessor: Assuming AG classesPath: " ++ classesPath+ fileOpts <- readFileOptions classesPath+ opts <- case Map.lookup inFile fileOpts of+ Nothing -> do warn verbosity $ "No options found for " ++ inFile+ return noOptions+ Just (opt,gen) -> return opt+ let search = dropFileName inFile+ options = opts { searchPath = search : hsSourceDirsFilePaths (hsSourceDirs build) ++ searchPath opts+ , outputFiles = outFile : (outputFiles opts) }+ (eCode,_) <- uuagc (optionsToString options) inFile+ case eCode of+ ExitSuccess -> writeFileOptions classesPath (Map.insert inFile (opts, Just (outFile, searchPath options)) fileOpts)+ ex@(ExitFailure _) -> throwIO ex+ }++-- | In Cabal 3.6.0.0 (GHC 9.2) and up, 'BuildInfo' member 'hsSourceDirs' has type+-- '[SymbolicPath PackageDir SourceDir]', but in versions before that, it is [FilePath].+#if MIN_VERSION_Cabal(3,6,0)+hsSourceDirsFilePaths :: [SymbolicPath PackageDir SourceDir] -> [FilePath]+hsSourceDirsFilePaths = map getSymbolicPath+#else+hsSourceDirsFilePaths :: [FilePath] -> [FilePath]+hsSourceDirsFilePaths = id+#endif++nouuagc :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor+nouuagc build lbi _ =+ PreProcessor {+#if MIN_VERSION_Cabal(3,8,1)+ -- The ppOrdering field was added in Cabal 3.8.1 (GHC 9.4)+ ppOrdering = \_verbosity _files modules -> pure modules,+#endif+ platformIndependent = True,+ runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do+ info verbosity ("skipping: " ++ outFile)+ }
uuagc-cabal.cabal view
@@ -1,28 +1,28 @@-cabal-version: >=1.10 -build-type: Simple -name: uuagc-cabal -version: 1.2.0.0 -license: BSD3 -license-file: LICENSE -maintainer: Atze Dijkstra (atzedijkstra@gmail.com) -homepage: https://github.com/UU-ComputerScience/uuagc -synopsis: Cabal plugin for UUAGC -description: Cabal plugin for the Universiteit Utrecht Attribute Grammar System -category: Development -stability: Stable -copyright: Universiteit Utrecht -author: Software Technology at Universiteit Utrecht -bug-reports: https://github.com/UU-ComputerScience/uuagc/issues -tested-with: GHC >= 6.12 -extra-source-files: README - -library - build-depends: base >= 4, base < 5, Cabal >= 2, directory >= 1.0.1.1 - build-depends: process >= 1.0.1.3, containers >= 0.3, uulib >= 0.9.14, filepath >= 1.1.0.4, mtl >= 2.2.1 - hs-source-dirs: src, src-options - default-language: Haskell2010 - exposed-modules: Distribution.Simple.UUAGC - other-modules: Distribution.Simple.UUAGC.UUAGC, - Distribution.Simple.UUAGC.AbsSyn, - Distribution.Simple.UUAGC.Parser, - Options +cabal-version: >=1.10+build-type: Simple+name: uuagc-cabal+version: 1.3.0.0+license: BSD3+license-file: LICENSE+maintainer: Atze Dijkstra (atzedijkstra@gmail.com)+homepage: https://github.com/UU-ComputerScience/uuagc+synopsis: Cabal plugin for UUAGC+description: Cabal plugin for the Universiteit Utrecht Attribute Grammar System+category: Development+stability: Stable+copyright: Universiteit Utrecht+author: Software Technology at Universiteit Utrecht+bug-reports: https://github.com/UU-ComputerScience/uuagc/issues+tested-with: GHC >= 6.12+extra-source-files: README++library+ build-depends: base >= 4, base < 5, Cabal >= 2, directory >= 1.0.1.1+ build-depends: process >= 1.0.1.3, containers >= 0.3, uulib >= 0.9.14, filepath >= 1.1.0.4, mtl >= 2.2.1+ hs-source-dirs: src, src-options+ default-language: Haskell2010+ exposed-modules: Distribution.Simple.UUAGC+ other-modules: Distribution.Simple.UUAGC.UUAGC,+ Distribution.Simple.UUAGC.AbsSyn,+ Distribution.Simple.UUAGC.Parser,+ Options