summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJeroenBransen <>2020-09-15 19:41:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2020-09-15 19:41:00 (GMT)
commit358ef3a588ebb7426d63c42a8b446e1b9dc8a615 (patch)
treee975c47808145444cabefca8e617cfa49d7e3633
parent60b0685f5d0bfaa87790406072f3a56ad3bbf58a (diff)
version 1.2.0.0HEAD1.2.0.0master
-rwxr-xr-x[-rw-r--r--]LICENSE46
-rwxr-xr-x[-rw-r--r--]README72
-rwxr-xr-x[-rw-r--r--]Setup.hs6
-rwxr-xr-x[-rw-r--r--]src-options/Options.hs1106
-rwxr-xr-x[-rw-r--r--]src/Distribution/Simple/UUAGC.hs6
-rwxr-xr-x[-rw-r--r--]src/Distribution/Simple/UUAGC/AbsSyn.hs36
-rwxr-xr-x[-rw-r--r--]src/Distribution/Simple/UUAGC/Parser.hs296
-rwxr-xr-x[-rw-r--r--]src/Distribution/Simple/UUAGC/UUAGC.hs578
-rwxr-xr-x[-rw-r--r--]uuagc-cabal.cabal55
9 files changed, 1101 insertions, 1100 deletions
diff --git a/LICENSE b/LICENSE
index aaacbdb..fb556dd 100644..100755
--- a/LICENSE
+++ b/LICENSE
@@ -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.
diff --git a/README b/README
index 4a7bb6f..d6cd009 100644..100755
--- a/README
+++ b/README
@@ -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).
diff --git a/Setup.hs b/Setup.hs
index e8efd11..0e2526f 100644..100755
--- a/Setup.hs
+++ b/Setup.hs
@@ -1,3 +1,3 @@
-module Main where
-import Distribution.Simple
-main = defaultMain
+module Main where
+import Distribution.Simple
+main = defaultMain
diff --git a/src-options/Options.hs b/src-options/Options.hs
index 719640d..6edd615 100644..100755
--- a/src-options/Options.hs
+++ b/src-options/Options.hs
@@ -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
diff --git a/src/Distribution/Simple/UUAGC.hs b/src/Distribution/Simple/UUAGC.hs
index be45ec6..4ce96a0 100644..100755
--- a/src/Distribution/Simple/UUAGC.hs
+++ b/src/Distribution/Simple/UUAGC.hs
@@ -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
diff --git a/src/Distribution/Simple/UUAGC/AbsSyn.hs b/src/Distribution/Simple/UUAGC/AbsSyn.hs
index a234079..7c82012 100644..100755
--- a/src/Distribution/Simple/UUAGC/AbsSyn.hs
+++ b/src/Distribution/Simple/UUAGC/AbsSyn.hs
@@ -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
diff --git a/src/Distribution/Simple/UUAGC/Parser.hs b/src/Distribution/Simple/UUAGC/Parser.hs
index e45b363..c82b750 100644..100755
--- a/src/Distribution/Simple/UUAGC/Parser.hs
+++ b/src/Distribution/Simple/UUAGC/Parser.hs
@@ -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,[])
diff --git a/src/Distribution/Simple/UUAGC/UUAGC.hs b/src/Distribution/Simple/UUAGC/UUAGC.hs
index 26075a1..16375e9 100644..100755
--- a/src/Distribution/Simple/UUAGC/UUAGC.hs
+++ b/src/Distribution/Simple/UUAGC/UUAGC.hs
@@ -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)
+ }
diff --git a/uuagc-cabal.cabal b/uuagc-cabal.cabal
index ac0fa88..d9abffb 100644..100755
--- a/uuagc-cabal.cabal
+++ b/uuagc-cabal.cabal
@@ -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