uuagc-cabal 1.1.0.0 → 1.2.0.0
raw patch · 9 files changed
+1101/−1100 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 +553/−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 +289/−289
- uuagc-cabal.cabal +28/−27
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,553 @@-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 [] ["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
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,289 @@-{-# LANGUAGE CPP #-}-module Distribution.Simple.UUAGC.UUAGC(uuagcUserHook,- uuagcUserHook',- uuagc,- uuagcLibUserHook,- uuagcFromString- ) where--import Distribution.Simple.BuildPaths (autogenModulesDir)-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 + +{-# 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) + }
uuagc-cabal.cabal view
@@ -1,27 +1,28 @@-cabal-version: >=1.8-build-type: Simple-name: uuagc-cabal-version: 1.1.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- 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.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