diff --git a/LICENSE b/LICENSE --- 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 --- 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 --- 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 --- a/src-options/Options.hs +++ b/src-options/Options.hs @@ -1,553 +1,557 @@ -module Options where - -import System.Console.GetOpt -import Data.Set(Set) -import UU.Scanner.Position(Pos,noPos) -import Data.List(intercalate) -import qualified Data.Set as Set -import System.IO -import System.Exit - --- From CommonTypes -data Identifier = Ident { getName::String, getPos::Pos } -type NontermIdent = Identifier -identifier :: String -> Identifier -identifier x = Ident x noPos - -instance Eq Identifier where - Ident x _ == Ident y _ = x == y - -instance Ord Identifier where - compare (Ident x _) (Ident y _) = compare x y - -instance Show Identifier where - show ident = getName ident - --- Make options serializable -data MyOptDescr = MyOpt [Char] [String] (ArgDescr (Options -> Options)) (Options -> String -> [String]) String - -fromMyOpt :: MyOptDescr -> OptDescr (Options -> Options) -fromMyOpt (MyOpt sh ln desc _ s) = Option sh ln desc s - -noOpt :: Options -> String -> [String] -noOpt _ _ = [] - -boolOpt :: (Options -> Bool) -> Options -> String -> [String] -boolOpt get opt strArg = let oldVal = get noOptions - newVal = get opt - in if oldVal /= newVal - then [strArg] - else [] - -stringOpt :: (Options -> String) -> Options -> String -> [String] -stringOpt get opt strArg = let oldVal = get noOptions - newVal = get opt - in if oldVal /= newVal - then [strArg, newVal] - else [] - -mbStringOpt :: (Options -> Maybe String) -> Options -> String -> [String] -mbStringOpt get opts nm = maybe [] (\s -> [nm++"="++s]) (get opts) - -serializeOption :: Options -> MyOptDescr -> [String] -serializeOption opt (MyOpt sh ln _ get _) = get opt strArg - where - strArg = if null sh - then '-' : '-' : head ln - else '-' : head sh : [] - --- All options -allOptions :: [MyOptDescr] -allOptions = - [ MyOpt ['m'] [] (NoArg (moduleOpt Nothing)) noOpt "generate default module header" - , MyOpt [] ["module"] (OptArg moduleOpt "name") moduleOptGet "generate module header, specify module name" - , MyOpt ['d'] ["data"] (NoArg dataOpt) (boolOpt dataTypes) "generate data type definition" - , MyOpt [] ["datarecords"] (NoArg dataRecOpt) (boolOpt dataRecords) "generate record data types" - , MyOpt [] ["strictdata"] (NoArg strictDataOpt) (boolOpt strictData) "generate strict data fields (when data is generated)" - , MyOpt [] ["strictwrap"] (NoArg strictWrapOpt) (boolOpt strictWrap) "generate strict wrap fields for WRAPPER generated data" - , MyOpt ['c'] ["catas"] (NoArg cataOpt) (boolOpt folds) "generate catamorphisms" - , MyOpt ['f'] ["semfuns"] (NoArg semfunsOpt) (boolOpt semfuns) "generate semantic functions" - , MyOpt ['s'] ["signatures"] (NoArg signaturesOpt) (boolOpt typeSigs) "generate signatures for semantic functions" - , MyOpt [] ["newtypes"] (NoArg newtypesOpt) (boolOpt newtypes) "use newtypes instead of type synonyms" - , MyOpt ['p'] ["pretty"] (NoArg prettyOpt) (boolOpt attrInfo) "generate pretty printed list of attributes" - , MyOpt ['w'] ["wrappers"] (NoArg wrappersOpt) (boolOpt wrappers) "generate wappers for semantic domains" - , MyOpt ['r'] ["rename"] (NoArg renameOpt) (boolOpt rename) "rename data constructors" - , MyOpt [] ["modcopy"] (NoArg modcopyOpt) (boolOpt modcopy) "use modified copy rule" - , MyOpt [] ["nest"] (NoArg nestOpt) (boolOpt nest) "use nested tuples" - , MyOpt [] ["syntaxmacro"] (NoArg smacroOpt) (boolOpt smacro) "experimental: generate syntax macro code (using knit catas)" - , MyOpt ['o'] ["output"] (ReqArg outputOpt "file") outputOptGet "specify output file" - , MyOpt ['v'] ["verbose"] (NoArg verboseOpt) (boolOpt verbose) "verbose error message format" - , MyOpt ['h','?'] ["help"] (NoArg helpOpt) (boolOpt showHelp) "get (this) usage information" - , MyOpt ['a'] ["all"] (NoArg allOpt) noOpt ("do everything (-" ++ allc ++ ")") - , MyOpt ['P'] [""] (ReqArg searchPathOpt "search path") searchPathOptGet ("specify seach path") - , MyOpt [] ["prefix"] (ReqArg prefixOpt "prefix") (stringOpt prefix) "set prefix for semantic functions" - , MyOpt [] ["self"] (NoArg selfOpt) (boolOpt withSelf) "generate self attribute" - , MyOpt [] ["cycle"] (NoArg cycleOpt) (boolOpt withCycle) "check for cyclic definitions" - , MyOpt [] ["version"] (NoArg versionOpt) (boolOpt showVersion) "get version information" - , MyOpt ['O'] ["optimize"] (NoArg optimizeOpt) noOpt "optimize generated code (--visit --case)" - , MyOpt [] ["visit"] (NoArg visitOpt) (boolOpt visit) "try generating visit functions" - , MyOpt [] ["loag"] (OptArg loagOpt "Bool") (boolOpt loag) "recognises all linear ordered attribute grammars by generting a SAT problem, uses --verbose to print out numbers of clauses and variables" - , MyOpt [] ["aoag"] (NoArg aoagOpt) (boolOpt aoag) "recognises all linear ordered attribute grammars by finding fake dependencies, uses --verbose to print out the selected fake dependencies" - , MyOpt [] ["seq"] (NoArg seqOpt) (boolOpt withSeq) "force evaluation using function seq (visit functions only)" - , MyOpt [] ["unbox"] (NoArg unboxOpt) (boolOpt unbox) "use unboxed tuples" - , MyOpt [] ["bangpats"] (NoArg bangpatsOpt) (boolOpt bangpats) "use bang patterns (visit functions only)" - , MyOpt [] ["case"] (NoArg casesOpt) (boolOpt cases) "Use nested cases instead of let (visit functions only)" - , MyOpt [] ["strictcase"] (NoArg strictCasesOpt) (boolOpt strictCases) "Force evaluation of the scrutinee of cases (in generated code, visit functions only)" - , MyOpt [] ["strictercase"] (NoArg stricterCasesOpt) (boolOpt stricterCases) "Force evaluation of all variables bound by a case statement (in generated code)" - , MyOpt [] ["strictsem"] (NoArg strictSemOpt) (boolOpt strictSems) "Force evaluation of sem-function arguments (in generated code)" - , MyOpt [] ["localcps"] (NoArg localCpsOpt) (boolOpt localCps) "Apply a local CPS transformation (in generated code, visit functions only)" - , MyOpt [] ["splitsems"] (NoArg splitSemsOpt) (boolOpt splitSems) "Split semantic functions into smaller pieces" - , MyOpt [] ["Werrors"] (NoArg werrorsOpt) (boolOpt werrors) "Turn warnings into fatal errors" - , MyOpt [] ["Wignore"] (NoArg wignoreOpt) (boolOpt wignore) "Ignore warnings" - , MyOpt [] ["Wmax"] (ReqArg wmaxErrsOpt "") 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 "") wmaxErrsOptGet "Sets the maximum number of errors that are reported" + , MyOpt [] ["dumpgrammar"] (NoArg dumpgrammarOpt) (boolOpt dumpgrammar) "Dump internal grammar representation (in generated code)" + , MyOpt [] ["dumpcgrammar"] (NoArg dumpcgrammarOpt) (boolOpt dumpcgrammar)"Dump internal cgrammar representation (in generated code)" + , MyOpt [] ["gentraces"] (NoArg genTracesOpt) (boolOpt genTraces) "Generate trace expressions (in generated code)" + , MyOpt [] ["genusetraces"] (NoArg genUseTracesOpt) (boolOpt genUseTraces)"Generate trace expressions at attribute use sites (in generated code)" + , MyOpt [] ["gencostcentres"] (NoArg genCostCentresOpt) (boolOpt genCostCentres) "Generate cost centre pragmas (in generated code)" + , MyOpt [] ["genlinepragmas"] (NoArg genLinePragmasOpt) (boolOpt genLinePragmas) "Generate GHC LINE pragmas (in generated code)" + , MyOpt [] ["sepsemmods"] (NoArg sepSemModsOpt) (boolOpt sepSemMods) "Generate separate modules for semantic functions (in generated code)" + , MyOpt ['M'] ["genfiledeps"] (NoArg genFileDepsOpt) (boolOpt genFileDeps) "Generate a list of dependencies on the input AG files" + , MyOpt [] ["genvisage"] (NoArg genVisageOpt) (boolOpt genvisage) "Generate output for the AG visualizer Visage" + , MyOpt [] ["genmirage"] (NoArg genMirageOpt) (boolOpt genmirage) "Generate output for the AG visualizer Mirage" + , MyOpt [] ["aspectag"] (NoArg genAspectAGOpt) (boolOpt genAspectAG) "Generate AspectAG file" + , MyOpt [] ["nogroup"] (ReqArg noGroupOpt "attributes") noGroupOptGet "specify the attributes that won't be grouped in AspectAG" + , MyOpt [] ["extends"] (ReqArg extendsOpt "module") (mbStringOpt extends) "specify a module to be extended" + , MyOpt [] ["genattrlist"] (NoArg genAttrListOpt) (boolOpt genAttributeList) "Generate a list of all explicitly defined attributes (outside irrefutable patterns)" + , MyOpt [] ["forceirrefutable"] (OptArg forceIrrefutableOpt "file") (mbStringOpt forceIrrefutables) "Force a set of explicitly defined attributes to be irrefutable, specify file containing the attribute set" + , MyOpt [] ["uniquedispenser"] (ReqArg uniqueDispenserOpt "name") (stringOpt uniqueDispenser) "The Haskell function to call in the generated code" + , MyOpt [] ["lckeywords"] (NoArg lcKeywordsOpt) (boolOpt lcKeywords) "Use lowercase keywords (sem, attr) instead of the uppercase ones (SEM, ATTR)" + , MyOpt [] ["doublecolons"] (NoArg doubleColonsOpt) (boolOpt doubleColons)"Use double colons for type signatures instead of single colons" + , MyOpt ['H'] ["haskellsyntax"] (NoArg haskellSyntaxOpt) noOpt "Use Haskell like syntax (equivalent to --lckeywords and --doublecolons --genlinepragmas)" + , MyOpt [] ["reference"] (NoArg referenceOpt) (boolOpt reference) "Use reference attributes" + , MyOpt [] ["monadic"] (NoArg monadicOpt) (boolOpt monadic) "Experimental: generate monadic code" + , MyOpt [] ["ocaml"] (NoArg ocamlOpt) (boolOpt ocaml) "Generate Ocaml code" + , MyOpt [] ["cleanlang"] (NoArg cleanOpt) (boolOpt clean) "Generate Clean code" + , MyOpt [] ["breadthfirst"] (NoArg breadthfirstOpt) (boolOpt breadthFirst)"Experimental: generate breadth-first code" + , MyOpt [] ["breadthfirst-strict"] (NoArg breadthfirstStrictOpt) (boolOpt breadthFirstStrict) "Experimental: outermost breadth-first evaluator is strict instead of lazy" + , MyOpt [] ["visitcode"] (NoArg visitorsOutputOpt) (boolOpt visitorsOutput) "Experimental: generate visitors code" + , MyOpt [] ["kennedywarren"] (NoArg kennedyWarrenOpt) (boolOpt kennedyWarren) "Use Kennedy-Warren's algorithm for ordering" + , MyOpt [] ["statistics"] (ReqArg statisticsOpt "FILE to append to") (mbStringOpt statsFile) "Append statistics to FILE" + , MyOpt [] ["checkParseRhs"] (NoArg parseHsRhsOpt) (boolOpt checkParseRhs) "Parse RHS of rules with Haskell parser" + , MyOpt [] ["checkParseTys"] (NoArg parseHsTpOpt) (boolOpt checkParseTy) "Parse types of attrs with Haskell parser" + , MyOpt [] ["checkParseBlocks"] (NoArg parseHsBlockOpt) (boolOpt checkParseBlock) "Parse blocks with Haskell parser" + , MyOpt [] ["checkParseHaskell"] (NoArg parseHsOpt) noOpt "Parse Haskell code (recognizer)" + , MyOpt [] ["nocatas"] (ReqArg nocatasOpt "list of nonterms") nocatasOptGet "Nonterminals not to generate catas for" + , MyOpt [] ["nooptimize"] (NoArg noOptimizeOpt) (boolOpt noOptimizations) "Disable optimizations" + , MyOpt [] ["parallel"] (NoArg parallelOpt) (boolOpt parallelInvoke) "Generate a parallel evaluator (if possible)" + , MyOpt [] ["monadicwrapper"] (NoArg monadicWrappersOpt) (boolOpt monadicWrappers) "Generate monadic wrappers" + , MyOpt [] ["helpinlining"] (NoArg helpInliningOpt) (boolOpt helpInlining) "Generate inline directives for GHC" + , MyOpt [] ["dummytokenvisit"] (NoArg dummyTokenVisitOpt) (boolOpt dummyTokenVisit) "Add an additional dummy parameter to visit functions" + , MyOpt [] ["tupleasdummytoken"] (NoArg tupleAsDummyTokenOpt) (boolOpt tupleAsDummyToken) "Use conventional tuples as dummy parameter instead of a RealWorld state token" + , MyOpt [] ["stateasdummytoken"] (NoArg stateAsDummyTokenOpt) noOpt "Use RealWorld state token as dummy parameter instead of conventional tuples (default)" + , MyOpt [] ["strictdummytoken"] (NoArg strictDummyTokenOpt) (boolOpt strictDummyToken) "Strictify the dummy token that makes states and rules functions" + , MyOpt [] ["noperruletypesigs"] (NoArg noPerRuleTypeSigsOpt) (boolOpt noPerRuleTypeSigs) "Do not generate type sigs for attrs passed to rules" + , MyOpt [] ["noperstatetypesigs"] (NoArg noPerStateTypeSigsOpt) (boolOpt noPerStateTypeSigs) "Do not generate type sigs for attrs saved in node states" + , MyOpt [] ["noeagerblackholing"] (NoArg noEagerBlackholingOpt) (boolOpt noEagerBlackholing) "Do not automatically add the eager blackholing feature for parallel programs" + , MyOpt [] ["noperrulecostcentres"] (NoArg noPerRuleCostCentresOpt) (boolOpt noPerRuleCostCentres) "Do not generate cost centres for rules" + , MyOpt [] ["nopervisitcostcentres"] (NoArg noPerVisitCostCentresOpt) (boolOpt noPerVisitCostCentres) "Do not generate cost centres for visits" + , MyOpt [] ["noinlinepragmas"] (NoArg noInlinePragmasOpt) (boolOpt noInlinePragmas) "Definitely not generate inline directives" + , MyOpt [] ["aggressiveinlinepragmas"] (NoArg aggressiveInlinePragmasOpt) (boolOpt aggressiveInlinePragmas) "Generate more aggressive inline directives" + , MyOpt [] ["latehigherorderbinding"] (NoArg lateHigherOrderBindingOpt) (boolOpt lateHigherOrderBinding) "Generate an attribute and wrapper for late binding of higher-order attributes" + , MyOpt [] ["noincludes"] (NoArg noIncludesOpt) (boolOpt noIncludes) "Ignore include directives in .ag files" + , MyOpt [] ["quiet"] (NoArg beQuietOpt) (boolOpt beQuiet) "Dont print some compilation information" + ] + +-- For compatibility +options :: [OptDescr (Options -> Options)] +options = map fromMyOpt allOptions + +allc :: String +allc = "dcfsprm" + +data ModuleHeader = NoName + | Name String + | Default deriving (Eq, Show) + +data Options = Options{ moduleName :: ModuleHeader + , dataTypes :: Bool + , dataRecords :: Bool + , strictData :: Bool + , strictWrap :: Bool + , folds :: Bool + , semfuns :: Bool + , typeSigs :: Bool + , attrInfo :: Bool + , rename :: Bool + , wrappers :: Bool + , modcopy :: Bool + , newtypes :: Bool + , nest :: Bool + , smacro :: Bool + , outputFiles :: [String] + , searchPath :: [String] + , verbose :: Bool + , prefix :: String + , withSelf :: Bool + , withCycle :: Bool + , showHelp :: Bool + , showVersion :: Bool + , visit :: Bool + , loag :: Bool + , minvisits :: Bool + , aoag :: Bool + , withSeq :: Bool + , unbox :: Bool + , bangpats :: Bool + , cases :: Bool + , strictCases :: Bool + , stricterCases :: Bool + , strictSems :: Bool + , localCps :: Bool + , splitSems :: Bool + , werrors :: Bool + , wignore :: Bool + , wmaxerrs :: Int + , dumpgrammar :: Bool + , dumpcgrammar :: Bool + , sepSemMods :: Bool + , allowSepSemMods :: Bool + , genFileDeps :: Bool + , genLinePragmas :: Bool + , genvisage :: Bool + , genmirage :: Bool + , genAspectAG :: Bool + , noGroup :: [String] + , extends :: Maybe String + , genAttributeList :: Bool + , forceIrrefutables :: Maybe String + , uniqueDispenser :: String + , lcKeywords :: Bool + , doubleColons :: Bool + , monadic :: Bool + , ocaml :: Bool + , clean :: Bool + , visitorsOutput :: Bool + , statsFile :: Maybe String + , breadthFirst :: Bool + , breadthFirstStrict :: Bool + , checkParseRhs :: Bool + , checkParseTy :: Bool + , checkParseBlock :: Bool + , nocatas :: Set NontermIdent + , noOptimizations :: Bool + , reference :: Bool + , noIncludes :: Bool + , outputStr :: String -> IO () + , failWithCode :: Int -> IO () + , mainFilename :: Maybe String + , beQuiet :: Bool + + -- KW code path + , kennedyWarren :: Bool + , parallelInvoke :: Bool + , tupleAsDummyToken :: Bool -- use the empty tuple as dummy token instead of State# RealWorld (Lambda State Hack GHC?) + , dummyTokenVisit :: Bool -- add a dummy argument/pass dummy extra token to visits (should not really have an effect ... Lambda State Hack GHC?) + , strictDummyToken :: Bool -- make the dummy token strict (to prevent its removal -- should not really have an effect) + , noPerRuleTypeSigs :: Bool -- do not print type signatures for attributes of rules + , noPerStateTypeSigs :: Bool -- do not print type signatures for attributes contained in the state + , noEagerBlackholing :: Bool -- disable the use of eager black holing in the parallel evaluator code + , lateHigherOrderBinding :: Bool -- generate code to allow late binding of higher-order children semantics + , monadicWrappers :: Bool + + -- tracing + , genTraces :: Bool + , genUseTraces :: Bool + , genCostCentres :: Bool + , noPerRuleCostCentres :: Bool + , noPerVisitCostCentres :: Bool + + -- inline pragma generation + , helpInlining :: Bool + , noInlinePragmas :: Bool + , aggressiveInlinePragmas :: Bool + } -- deriving (Eq, Show) + +noOptions :: Options +noOptions = Options { moduleName = NoName + , dataTypes = False + , dataRecords = False + , strictData = False + , strictWrap = False + , folds = False + , semfuns = False + , typeSigs = False + , attrInfo = False + , rename = False + , wrappers = False + , modcopy = False + , newtypes = False + , nest = False + , smacro = False + , outputFiles = [] + , searchPath = [] + , verbose = False + , showHelp = False + , showVersion = False + , prefix = "sem_" + , withSelf = False + , withCycle = False + , visit = False + , loag = False + , minvisits = False + , aoag = False + , withSeq = False + , unbox = False + , bangpats = False + , cases = False + , strictCases = False + , stricterCases = False + , strictSems = False + , localCps = False + , splitSems = False + , werrors = False + , wignore = False + , wmaxerrs = 99999 + , dumpgrammar = False + , dumpcgrammar = False + , sepSemMods = False + , allowSepSemMods = True + , genFileDeps = False + , genLinePragmas = False + , genvisage = False + , genmirage = False + , genAspectAG = False + , noGroup = [] + , extends = Nothing + , genAttributeList = False + , forceIrrefutables = Nothing + , uniqueDispenser = "nextUnique" + , lcKeywords = False + , doubleColons = False + , monadic = False + , ocaml = False + , clean = False + , visitorsOutput = False + , statsFile = Nothing + , breadthFirst = False + , breadthFirstStrict = False + , checkParseRhs = False + , checkParseTy = False + , checkParseBlock = False + , nocatas = Set.empty + , noOptimizations = False + , reference = False + , noIncludes = False + , outputStr = hPutStr stderr + , failWithCode = exitWith . ExitFailure + , mainFilename = Nothing + , beQuiet = False + + -- defaults for the KW-code path + , kennedyWarren = False + , parallelInvoke = False + , tupleAsDummyToken = True + , dummyTokenVisit = False + , strictDummyToken = False + , noPerRuleTypeSigs = False + , noPerStateTypeSigs = False + , noEagerBlackholing = False + , lateHigherOrderBinding = False + , monadicWrappers = False + + -- defaults for tracing + , genTraces = False + , genUseTraces = False + , genCostCentres = False + , noPerRuleCostCentres = False + , noPerVisitCostCentres = False + + -- defaults for inline pragma generation + , helpInlining = False + , noInlinePragmas = False + , aggressiveInlinePragmas = False + } + +loagOpt :: (Maybe String) -> Options -> Options +loagOpt mstr opts = + case mstr of + Nothing -> opts' + Just "0" -> opts' + Just _ -> opts' {minvisits = True} + + where opts'=opts{loag = True, visit = True} + +aoagOpt :: Options -> Options +aoagOpt opts = + opts{loag = True, visit = True, aoag = True} + +--Options -> String -> [String] +moduleOpt :: Maybe String -> Options -> Options +moduleOpt nm opts = opts{moduleName = maybe Default Name nm} +moduleOptGet :: Options -> String -> [String] +moduleOptGet opts nm = case moduleName opts of + NoName -> [] + Name s -> [nm++"="++s] + Default -> [nm] + +dataOpt, dataRecOpt, strictDataOpt, strictWrapOpt, cataOpt, semfunsOpt, signaturesOpt, prettyOpt,renameOpt, wrappersOpt, modcopyOpt, newtypesOpt, nestOpt, smacroOpt, verboseOpt, helpOpt, versionOpt, selfOpt, cycleOpt, visitOpt, seqOpt, unboxOpt, bangpatsOpt, casesOpt, strictCasesOpt, stricterCasesOpt, strictSemOpt, localCpsOpt, splitSemsOpt, werrorsOpt, wignoreOpt, dumpgrammarOpt, dumpcgrammarOpt, genTracesOpt, genUseTracesOpt, genCostCentresOpt, sepSemModsOpt, genFileDepsOpt, genLinePragmasOpt, genVisageOpt, genMirageOpt, genAspectAGOpt, dummyTokenVisitOpt, tupleAsDummyTokenOpt, stateAsDummyTokenOpt, strictDummyTokenOpt, noPerRuleTypeSigsOpt, noPerStateTypeSigsOpt, noEagerBlackholingOpt, noPerRuleCostCentresOpt, noPerVisitCostCentresOpt, helpInliningOpt, noInlinePragmasOpt, aggressiveInlinePragmasOpt, lateHigherOrderBindingOpt, monadicWrappersOpt, referenceOpt, genAttrListOpt, lcKeywordsOpt, doubleColonsOpt, haskellSyntaxOpt, monadicOpt, parallelOpt, ocamlOpt, cleanOpt, visitorsOutputOpt, breadthfirstOpt, breadthfirstStrictOpt, parseHsRhsOpt, parseHsTpOpt, parseHsBlockOpt, parseHsOpt, kennedyWarrenOpt, noOptimizeOpt, allOpt, optimizeOpt, noIncludesOpt, beQuietOpt, condDisableOptimizations :: Options -> Options + +dataOpt opts = opts{dataTypes = True} +dataRecOpt opts = opts{dataRecords = True} +strictDataOpt opts = opts{strictData = True} +strictWrapOpt opts = opts{strictWrap = True} +cataOpt opts = opts{folds = True} +semfunsOpt opts = opts{semfuns = True} +signaturesOpt opts = opts{typeSigs = True} +prettyOpt opts = opts{attrInfo = True} +renameOpt opts = opts{rename = True} +wrappersOpt opts = opts{wrappers = True} +modcopyOpt opts = opts{modcopy = True} +newtypesOpt opts = opts{newtypes = True} +nestOpt opts = opts{nest = True} +smacroOpt opts = opts{smacro = True} +verboseOpt opts = opts{verbose = True} +helpOpt opts = opts{showHelp = True} +versionOpt opts = opts{showVersion = True} +prefixOpt :: String -> Options -> Options +prefixOpt pre opts = opts{prefix = pre } +selfOpt opts = opts{withSelf = True} +cycleOpt opts = opts{withCycle = True} +visitOpt opts = opts{visit = True, withCycle = True} +seqOpt opts = opts{withSeq = True} +unboxOpt opts = opts{unbox = True} +bangpatsOpt opts = opts{bangpats = True} +casesOpt opts = opts{cases = True} +strictCasesOpt opts = opts{strictCases = True} +stricterCasesOpt opts = opts{strictCases = True, stricterCases = True} +strictSemOpt opts = opts{strictSems = True} +localCpsOpt opts = opts{localCps = True} +splitSemsOpt opts = opts{splitSems = True} +werrorsOpt opts = opts{werrors = True} +wignoreOpt opts = opts{wignore = True} +wmaxErrsOpt :: String -> Options -> Options +wmaxErrsOpt n opts = opts{wmaxerrs = read n} +wmaxErrsOptGet :: Options -> String -> [String] +wmaxErrsOptGet opts nm = if wmaxerrs opts /= wmaxerrs noOptions + then [nm,show (wmaxerrs opts)] + else [] +dumpgrammarOpt opts = opts{dumpgrammar = True} +dumpcgrammarOpt opts = opts{dumpcgrammar = True} +genTracesOpt opts = opts{genTraces = True} +genUseTracesOpt opts = opts{genUseTraces = True} +genCostCentresOpt opts = opts{genCostCentres = True} +sepSemModsOpt opts = opts{sepSemMods = allowSepSemMods opts} +genFileDepsOpt opts = opts{genFileDeps = True} +genLinePragmasOpt opts = opts{genLinePragmas = True} +genVisageOpt opts = opts{genvisage = True } +genMirageOpt opts = opts{genmirage = True } +genAspectAGOpt opts = opts{genAspectAG = True} + +dummyTokenVisitOpt opts = opts { dummyTokenVisit = True } +tupleAsDummyTokenOpt opts = opts { tupleAsDummyToken = True } +stateAsDummyTokenOpt opts = opts { tupleAsDummyToken = False } +strictDummyTokenOpt opts = opts { strictDummyToken = True } +noPerRuleTypeSigsOpt opts = opts { noPerRuleTypeSigs = True } +noPerStateTypeSigsOpt opts = opts { noPerStateTypeSigs = True } +noEagerBlackholingOpt opts = opts { noEagerBlackholing = True } +noPerRuleCostCentresOpt opts = opts { noPerRuleCostCentres = True } +noPerVisitCostCentresOpt opts = opts { noPerVisitCostCentres = True } +helpInliningOpt opts = opts { helpInlining = True } +noInlinePragmasOpt opts = opts { noInlinePragmas = True } +aggressiveInlinePragmasOpt opts = opts { aggressiveInlinePragmas = True } +lateHigherOrderBindingOpt opts = opts { lateHigherOrderBinding = True } +monadicWrappersOpt opts = opts { monadicWrappers = True } +referenceOpt opts = opts { reference = True } + +noGroupOpt :: String -> Options -> Options +noGroupOpt att opts = opts{noGroup = wordsBy (== ':') att ++ noGroup opts} +noGroupOptGet :: Options -> String -> [String] +noGroupOptGet opts nm = if null (noGroup opts) + then [] + else [nm, intercalate ":" (noGroup opts)] +extendsOpt :: String -> Options -> Options +extendsOpt m opts = opts{extends = Just m } + +genAttrListOpt opts = opts { genAttributeList = True } +forceIrrefutableOpt :: Maybe String -> Options -> Options +forceIrrefutableOpt mbNm opts = opts { forceIrrefutables = mbNm } +uniqueDispenserOpt :: String -> Options -> Options +uniqueDispenserOpt nm opts = opts { uniqueDispenser = nm } +lcKeywordsOpt opts = opts { lcKeywords = True } +doubleColonsOpt opts = opts { doubleColons = True } +haskellSyntaxOpt = lcKeywordsOpt . doubleColonsOpt . genLinePragmasOpt +monadicOpt opts = opts { monadic = True } +parallelOpt opts = opts { parallelInvoke = True } +ocamlOpt opts = opts { ocaml = True, kennedyWarren = True, withCycle = True, visit = True } +cleanOpt opts = opts { clean = True } --TODO: More? +visitorsOutputOpt opts = opts { visitorsOutput = True } +statisticsOpt :: String -> Options -> Options +statisticsOpt nm opts = opts { statsFile = Just nm } +breadthfirstOpt opts = opts { breadthFirst = True } +breadthfirstStrictOpt opts = opts { breadthFirstStrict = True } +parseHsRhsOpt opts = opts { checkParseRhs = True } +parseHsTpOpt opts = opts { checkParseTy = True } +parseHsBlockOpt opts = opts { checkParseBlock = True } +parseHsOpt = parseHsRhsOpt . parseHsTpOpt . parseHsBlockOpt +kennedyWarrenOpt opts = opts { kennedyWarren = True } +noOptimizeOpt opts = opts { noOptimizations = True } +nocatasOpt :: String -> Options -> Options +nocatasOpt str opts = opts { nocatas = set `Set.union` nocatas opts } where + set = Set.fromList ids + ids = map identifier lst + lst = wordsBy (== ',') str +nocatasOptGet :: Options -> String -> [String] +nocatasOptGet opts nm = if Set.null (nocatas opts) + then [] + else [nm,intercalate "," . map getName . Set.toList . nocatas $ opts] +outputOpt :: String -> Options -> Options +outputOpt file opts = opts{outputFiles = file : outputFiles opts} +outputOptGet :: Options -> String -> [String] +outputOptGet opts nm = concat [ [nm, file] | file <- outputFiles opts] +searchPathOpt :: String -> Options -> Options +searchPathOpt path opts = opts{searchPath = wordsBy (\x -> x == ';' || x == ':') path ++ searchPath opts} +searchPathOptGet :: Options -> String -> [String] +searchPathOptGet opts nm = if null (searchPath opts) + then [] + else [nm, intercalate ":" (searchPath opts)] +allOpt = moduleOpt Nothing . dataOpt . cataOpt . semfunsOpt . signaturesOpt . prettyOpt . renameOpt . dataRecOpt +optimizeOpt = visitOpt . casesOpt +noIncludesOpt opts = opts { noIncludes = True } +beQuietOpt opts = opts { beQuiet = True } + +condDisableOptimizations opts + | noOptimizations opts = + opts { strictData = False + , strictWrap = False + , withSeq = False + , unbox = False + , bangpats = False + , cases = False + , strictCases = False + , stricterCases = False + , strictSems = False + , localCps = False + , splitSems = False + , breadthFirstStrict = False + } + | otherwise = opts + +-- | Inverse of intercalate +wordsBy :: (Char -> Bool) -> String -> [String] +wordsBy p = f + where + f s = let (x,xs) = break p s + in if null x then [] else x : f (drop 1 xs) + +-- | Use all parsed options to generate real options +constructOptions :: [Options -> Options] -> Options +constructOptions = foldl (flip ($)) noOptions + +-- | Create Options type from string arguments +getOptions :: [String] -> (Options,[String],[String]) +getOptions args = let (flags,files,errors) = getOpt Permute options args + appliedOpts = constructOptions flags + finOpts = condDisableOptimizations appliedOpts + in (finOpts,files,errors) + +-- | Convert options back to commandline string +optionsToString :: Options -> [String] +optionsToString opt = concatMap (serializeOption opt) allOptions + +-- | Combine 2 sets of options +combineOptions :: Options -> Options -> Options +combineOptions o1 o2 = let str1 = optionsToString o1 + str2 = optionsToString o2 + (opt,_,_) = getOptions (str1 ++ str2) + in opt diff --git a/src/Distribution/Simple/UUAGC.hs b/src/Distribution/Simple/UUAGC.hs --- 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 --- 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 --- 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 --- a/src/Distribution/Simple/UUAGC/UUAGC.hs +++ b/src/Distribution/Simple/UUAGC/UUAGC.hs @@ -1,289 +1,311 @@ -{-# LANGUAGE CPP #-} -module Distribution.Simple.UUAGC.UUAGC(uuagcUserHook, - uuagcUserHook', - uuagc, - uuagcLibUserHook, - uuagcFromString - ) where - --- import Distribution.Simple.BuildPaths (autogenComponentModulesDir) -import Debug.Trace -import Distribution.Simple -import Distribution.Simple.PreProcess -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Utils -import Distribution.Simple.Setup -import Distribution.PackageDescription hiding (Flag) -import Distribution.Simple.UUAGC.AbsSyn( AGFileOption(..) - , AGFileOptions - , AGOptionsClass(..) - , lookupFileOptions - , fileClasses - ) -import Distribution.Simple.UUAGC.Parser -import Options hiding (verbose) -import Distribution.Verbosity -import System.Process( readProcessWithExitCode ) -import System.Directory(getModificationTime - ,doesFileExist - ,removeFile) -import System.FilePath(pathSeparators, - (), - takeFileName, - normalise, - joinPath, - dropFileName, - addExtension, - dropExtension, - replaceExtension, - splitDirectories) - -import System.Exit (ExitCode(..)) -import System.IO( openFile, IOMode(..), - hFileSize, - hSetFileSize, - hClose, - hGetContents, - hFlush, - Handle(..), stderr, hPutStr, hPutStrLn) -import System.Exit(exitFailure) -import Control.Exception (throwIO) -import Control.Monad (liftM, when, guard, forM_, forM) -import Control.Arrow ((&&&), second) -import Data.Maybe (maybeToList) -import Data.Either (partitionEithers) -import Data.List (nub,intersperse) -import Data.Map (Map) -import qualified Data.Map as Map - -{-# DEPRECATED uuagcUserHook, uuagcUserHook', uuagc "Use uuagcLibUserHook instead" #-} - --- | 'uuagc' returns the name of the uuagc compiler -uuagcn = "uuagc" - --- | 'defUUAGCOptions' returns the default names of the uuagc options -defUUAGCOptions :: String -defUUAGCOptions = "uuagc_options" - --- | File used to store de classes defined in the cabal file. -agClassesFile :: String -agClassesFile = "ag_file_options" - --- | The prefix used for the cabal file optionsw -agModule :: String -agModule = "x-agmodule" - --- | The prefix used for the cabal file options used for defining classes -agClass :: String -agClass = "x-agclass" - --- | Deprecated userhook -uuagcUserHook :: UserHooks -uuagcUserHook = uuagcUserHook' uuagcn - --- | Deprecated userhook -uuagcUserHook' :: String -> UserHooks -uuagcUserHook' uuagcPath = uuagcLibUserHook (uuagcFromString uuagcPath) - --- | Create uuagc function using shell (old method) -uuagcFromString :: String -> [String] -> FilePath -> IO (ExitCode, [FilePath]) -uuagcFromString uuagcPath args file = do - (ec,out,err) <- readProcessWithExitCode uuagcPath (args ++ [file]) "" - case ec of - ExitSuccess -> - do hPutStr stderr err - return (ExitSuccess, words out) - (ExitFailure exc) -> - do hPutStrLn stderr (uuagcPath ++ ": " ++ show exc) - hPutStr stderr out - hPutStr stderr err - return (ExitFailure exc, []) - --- | Main hook, argument should be uuagc function -uuagcLibUserHook :: ([String] -> FilePath -> IO (ExitCode, [FilePath])) -> UserHooks -uuagcLibUserHook uuagc = hooks where - hooks = simpleUserHooks { hookedPreProcessors = ("ag", ag):("lag",ag):knownSuffixHandlers - , buildHook = uuagcBuildHook uuagc --- , sDistHook = uuagcSDistHook uuagc - } - ag = uuagc' uuagc - -originalPreBuild = preBuild simpleUserHooks -originalBuildHook = buildHook simpleUserHooks ---originalSDistHook = sDistHook simpleUserHooks - -putErrorInfo :: Handle -> IO () -putErrorInfo h = hGetContents h >>= hPutStr stderr - --- | 'updateAGFile' search into the uuagc options file for a list of all --- AG Files and theirs file dependencies in order to see if the latters --- are more updated that the formers, and if this is the case to --- update the AG File -updateAGFile :: ([String] -> FilePath -> IO (ExitCode, [FilePath])) - -> Map FilePath (Options, Maybe (FilePath, [String])) - -> (FilePath, (Options, Maybe (FilePath, [String]))) - -> IO () -updateAGFile _ _ (_,(_,Nothing)) = return () -updateAGFile uuagc newOptions (file,(opts,Just (gen,sp))) = do - hasGen <- doesFileExist gen - when hasGen $ do - (ec, files) <- uuagc (optionsToString $ opts { genFileDeps = True, searchPath = sp }) file - case ec of - ExitSuccess -> do - let newOpts :: Options - newOpts = maybe noOptions fst $ Map.lookup file newOptions - optRebuild = optionsToString newOpts /= optionsToString opts - modRebuild <- - if null files - then return False - else do - flsmt <- mapM getModificationTime files - let maxModified = maximum flsmt - fmt <- getModificationTime gen - return $ maxModified > fmt - -- When some dependency is newer or options have changed, we should regenerate - when (optRebuild || modRebuild) $ removeFile gen - ex@(ExitFailure _) -> throwIO ex - -getAGFileOptions :: [(String, String)] -> IO AGFileOptions -getAGFileOptions extra = do - cabalOpts <- mapM (parseOptionAG . snd) $ filter ((== agModule) . fst) extra - usesOptionsFile <- doesFileExist defUUAGCOptions - if usesOptionsFile - then do r <- parserAG' defUUAGCOptions - case r of - Left e -> dieNoVerbosity (show e) - Right a -> return $ cabalOpts ++ a - else return cabalOpts - -getAGClasses :: [(String, String)] -> IO [AGOptionsClass] -getAGClasses = mapM (parseClassAG . snd) . filter ((== agClass) . fst) - -writeFileOptions :: FilePath -> Map FilePath (Options, Maybe (FilePath,[String])) -> IO () -writeFileOptions classesPath opts = do - hClasses <- openFile classesPath WriteMode - hPutStr hClasses $ show $ Map.map (\(opt,gen) -> (optionsToString opt, gen)) opts - hFlush hClasses - hClose hClasses - -readFileOptions :: FilePath -> IO (Map FilePath (Options, Maybe (FilePath,[String]))) -readFileOptions classesPath = do - isFile <- doesFileExist classesPath - if isFile - then do hClasses <- openFile classesPath ReadMode - sClasses <- hGetContents hClasses - classes <- readIO sClasses :: IO (Map FilePath ([String], Maybe (FilePath,[String]))) - hClose hClasses - return $ Map.map (\(opt,gen) -> let (opt',_,_) = getOptions opt in (opt', gen)) classes - else return Map.empty - -getOptionsFromClass :: [(String, Options)] -> AGFileOption -> ([String], Options) -getOptionsFromClass classes fOpt = - second (foldl combineOptions (opts fOpt)) - . partitionEithers $ do - fClass <- fileClasses fOpt - case fClass `lookup` classes of - Just x -> return $ Right x - Nothing -> return $ Left $ "Warning: The class " - ++ show fClass - ++ " is not defined." - --- uuagcSDistHook :: ([String] -> FilePath -> IO (ExitCode, [FilePath])) --- -> PackageDescription --- -> Maybe LocalBuildInfo --- -> UserHooks --- -> SDistFlags --- -> IO () --- uuagcSDistHook uuagc pd mbLbi uh df = do --- {- --- case mbLbi of --- Nothing -> warn normal "sdist: the local buildinfo was not present. Skipping AG initialization. Dist may fail." --- Just lbi -> let classesPath = buildDir lbi agClassesFile --- in commonHook uuagc classesPath pd lbi (sDistVerbosity df) --- originalSDistHook pd mbLbi uh df --- -} --- originalSDistHook pd mbLbi (uh { hookedPreProcessors = ("ag", nouuagc):("lag",nouuagc):knownSuffixHandlers }) df -- bypass preprocessors - -uuagcBuildHook - :: ([String] -> FilePath -> IO (ExitCode, [FilePath])) - -> PackageDescription - -> LocalBuildInfo - -> UserHooks - -> BuildFlags - -> IO () -uuagcBuildHook uuagc pd lbi uh bf = do - let classesPath = buildDir lbi agClassesFile - commonHook uuagc classesPath pd lbi (buildVerbosity bf) - originalBuildHook pd lbi uh bf - -commonHook :: ([String] -> FilePath -> IO (ExitCode, [FilePath])) - -> FilePath - -> PackageDescription - -> LocalBuildInfo - -> Flag Verbosity - -> IO () -commonHook uuagc classesPath pd lbi fl = do - let verbosity = fromFlagOrDefault normal fl - info verbosity $ "commonHook: Assuming AG classesPath: " ++ classesPath - createDirectoryIfMissingVerbose verbosity True (buildDir lbi) - -- Read already existing options - -- Map FilePath (Options, Maybe (FilePath,[String])) - oldOptions <- readFileOptions classesPath - -- Read options from cabal and settings file - let lib = library pd - exes = executables pd - bis = map libBuildInfo (maybeToList lib) ++ map buildInfo exes - classes <- map (className &&& opts') `fmap` (getAGClasses . customFieldsPD $ pd) - configOptions <- getAGFileOptions (bis >>= customFieldsBI) - -- Construct new options map - newOptionsL <- forM configOptions (\ opt -> - let (notFound, opts) = getOptionsFromClass classes $ opt - file = normalise $ filename opt - gen = maybe Nothing snd $ Map.lookup file oldOptions - in do info verbosity $ "options for " ++ file ++ ": " ++ unwords (optionsToString opts) - forM_ notFound (hPutStrLn stderr) - return (file, (opts, gen))) - let newOptions = Map.fromList newOptionsL - writeFileOptions classesPath newOptions - -- Check if files should be regenerated - mapM_ (updateAGFile uuagc newOptions) $ Map.toList oldOptions - -getAGFileList :: AGFileOptions -> [FilePath] -getAGFileList = map (normalise . filename) - -uuagc :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -uuagc = uuagc' (uuagcFromString uuagcn) - -uuagc' :: ([String] -> FilePath -> IO (ExitCode, [FilePath])) - -> BuildInfo - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> PreProcessor -uuagc' uuagc build lbi _ = - PreProcessor { - platformIndependent = True, - runPreProcessor = mkSimplePreProcessor $ \ inFile outFile verbosity -> - do notice verbosity $ "[UUAGC] processing: " ++ inFile ++ " generating: " ++ outFile - let classesPath = buildDir lbi agClassesFile - info verbosity $ "uuagc-preprocessor: Assuming AG classesPath: " ++ classesPath - fileOpts <- readFileOptions classesPath - opts <- case Map.lookup inFile fileOpts of - Nothing -> do warn verbosity $ "No options found for " ++ inFile - return noOptions - Just (opt,gen) -> return opt - let search = dropFileName inFile - options = opts { searchPath = search : hsSourceDirs build ++ searchPath opts - , outputFiles = outFile : (outputFiles opts) } - (eCode,_) <- uuagc (optionsToString options) inFile - case eCode of - ExitSuccess -> writeFileOptions classesPath (Map.insert inFile (opts, Just (outFile, searchPath options)) fileOpts) - ex@(ExitFailure _) -> throwIO ex - } - -nouuagc :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -nouuagc build lbi _ = - PreProcessor { - platformIndependent = True, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do - info verbosity ("skipping: " ++ outFile) - } +{-# LANGUAGE CPP #-} +module Distribution.Simple.UUAGC.UUAGC(uuagcUserHook, + uuagcUserHook', + uuagc, + uuagcLibUserHook, + uuagcFromString + ) where + +-- import Distribution.Simple.BuildPaths (autogenComponentModulesDir) +import Debug.Trace +import Distribution.Simple +import Distribution.Simple.PreProcess +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Utils +import Distribution.Simple.Setup +import Distribution.PackageDescription hiding (Flag) +import Distribution.Simple.UUAGC.AbsSyn( AGFileOption(..) + , AGFileOptions + , AGOptionsClass(..) + , lookupFileOptions + , fileClasses + ) +import Distribution.Simple.UUAGC.Parser +import Options hiding (verbose) +import Distribution.Verbosity +import System.Process( readProcessWithExitCode ) +import System.Directory(getModificationTime + ,doesFileExist + ,removeFile) +import System.FilePath(pathSeparators, + (), + takeFileName, + normalise, + joinPath, + dropFileName, + addExtension, + dropExtension, + replaceExtension, + splitDirectories) + +import System.Exit (ExitCode(..)) +import System.IO( openFile, IOMode(..), + hFileSize, + hSetFileSize, + hClose, + hGetContents, + hFlush, + Handle(..), stderr, hPutStr, hPutStrLn) +import System.Exit(exitFailure) +import Control.Exception (throwIO) +import Control.Monad (liftM, when, guard, forM_, forM) +import Control.Arrow ((&&&), second) +import Data.Maybe (maybeToList) +import Data.Either (partitionEithers) +import Data.List (nub,intersperse) +import Data.Map (Map) +import qualified Data.Map as Map + +#if MIN_VERSION_Cabal(3,6,0) +import Distribution.Utils.Path (getSymbolicPath, PackageDir, SourceDir, SymbolicPath) +#endif + +{-# DEPRECATED uuagcUserHook, uuagcUserHook', uuagc "Use uuagcLibUserHook instead" #-} + +-- | 'uuagc' returns the name of the uuagc compiler +uuagcn = "uuagc" + +-- | 'defUUAGCOptions' returns the default names of the uuagc options +defUUAGCOptions :: String +defUUAGCOptions = "uuagc_options" + +-- | File used to store de classes defined in the cabal file. +agClassesFile :: String +agClassesFile = "ag_file_options" + +-- | The prefix used for the cabal file optionsw +agModule :: String +agModule = "x-agmodule" + +-- | The prefix used for the cabal file options used for defining classes +agClass :: String +agClass = "x-agclass" + +-- | Deprecated userhook +uuagcUserHook :: UserHooks +uuagcUserHook = uuagcUserHook' uuagcn + +-- | Deprecated userhook +uuagcUserHook' :: String -> UserHooks +uuagcUserHook' uuagcPath = uuagcLibUserHook (uuagcFromString uuagcPath) + +-- | Create uuagc function using shell (old method) +uuagcFromString :: String -> [String] -> FilePath -> IO (ExitCode, [FilePath]) +uuagcFromString uuagcPath args file = do + (ec,out,err) <- readProcessWithExitCode uuagcPath (args ++ [file]) "" + case ec of + ExitSuccess -> + do hPutStr stderr err + return (ExitSuccess, words out) + (ExitFailure exc) -> + do hPutStrLn stderr (uuagcPath ++ ": " ++ show exc) + hPutStr stderr out + hPutStr stderr err + return (ExitFailure exc, []) + +-- | Main hook, argument should be uuagc function +uuagcLibUserHook :: ([String] -> FilePath -> IO (ExitCode, [FilePath])) -> UserHooks +uuagcLibUserHook uuagc = hooks where + hooks = simpleUserHooks { hookedPreProcessors = ("ag", ag):("lag",ag):knownSuffixHandlers + , buildHook = uuagcBuildHook uuagc +-- , sDistHook = uuagcSDistHook uuagc + } + ag = uuagc' uuagc + +originalPreBuild = preBuild simpleUserHooks +originalBuildHook = buildHook simpleUserHooks +--originalSDistHook = sDistHook simpleUserHooks + +putErrorInfo :: Handle -> IO () +putErrorInfo h = hGetContents h >>= hPutStr stderr + +-- | 'updateAGFile' search into the uuagc options file for a list of all +-- AG Files and theirs file dependencies in order to see if the latters +-- are more updated that the formers, and if this is the case to +-- update the AG File +updateAGFile :: ([String] -> FilePath -> IO (ExitCode, [FilePath])) + -> Map FilePath (Options, Maybe (FilePath, [String])) + -> (FilePath, (Options, Maybe (FilePath, [String]))) + -> IO () +updateAGFile _ _ (_,(_,Nothing)) = return () +updateAGFile uuagc newOptions (file,(opts,Just (gen,sp))) = do + hasGen <- doesFileExist gen + when hasGen $ do + (ec, files) <- uuagc (optionsToString $ opts { genFileDeps = True, searchPath = sp }) file + case ec of + ExitSuccess -> do + let newOpts :: Options + newOpts = maybe noOptions fst $ Map.lookup file newOptions + optRebuild = optionsToString newOpts /= optionsToString opts + modRebuild <- + if null files + then return False + else do + flsmt <- mapM getModificationTime files + let maxModified = maximum flsmt + fmt <- getModificationTime gen + return $ maxModified > fmt + -- When some dependency is newer or options have changed, we should regenerate + when (optRebuild || modRebuild) $ removeFile gen + ex@(ExitFailure _) -> throwIO ex + +getAGFileOptions :: [(String, String)] -> IO AGFileOptions +getAGFileOptions extra = do + cabalOpts <- mapM (parseOptionAG . snd) $ filter ((== agModule) . fst) extra + usesOptionsFile <- doesFileExist defUUAGCOptions + if usesOptionsFile + then do r <- parserAG' defUUAGCOptions + case r of + Left e -> dieNoVerbosity (show e) + Right a -> return $ cabalOpts ++ a + else return cabalOpts + +getAGClasses :: [(String, String)] -> IO [AGOptionsClass] +getAGClasses = mapM (parseClassAG . snd) . filter ((== agClass) . fst) + +writeFileOptions :: FilePath -> Map FilePath (Options, Maybe (FilePath,[String])) -> IO () +writeFileOptions classesPath opts = do + hClasses <- openFile classesPath WriteMode + hPutStr hClasses $ show $ Map.map (\(opt,gen) -> (optionsToString opt, gen)) opts + hFlush hClasses + hClose hClasses + +readFileOptions :: FilePath -> IO (Map FilePath (Options, Maybe (FilePath,[String]))) +readFileOptions classesPath = do + isFile <- doesFileExist classesPath + if isFile + then do hClasses <- openFile classesPath ReadMode + sClasses <- hGetContents hClasses + classes <- readIO sClasses :: IO (Map FilePath ([String], Maybe (FilePath,[String]))) + hClose hClasses + return $ Map.map (\(opt,gen) -> let (opt',_,_) = getOptions opt in (opt', gen)) classes + else return Map.empty + +getOptionsFromClass :: [(String, Options)] -> AGFileOption -> ([String], Options) +getOptionsFromClass classes fOpt = + second (foldl combineOptions (opts fOpt)) + . partitionEithers $ do + fClass <- fileClasses fOpt + case fClass `lookup` classes of + Just x -> return $ Right x + Nothing -> return $ Left $ "Warning: The class " + ++ show fClass + ++ " is not defined." + +-- uuagcSDistHook :: ([String] -> FilePath -> IO (ExitCode, [FilePath])) +-- -> PackageDescription +-- -> Maybe LocalBuildInfo +-- -> UserHooks +-- -> SDistFlags +-- -> IO () +-- uuagcSDistHook uuagc pd mbLbi uh df = do +-- {- +-- case mbLbi of +-- Nothing -> warn normal "sdist: the local buildinfo was not present. Skipping AG initialization. Dist may fail." +-- Just lbi -> let classesPath = buildDir lbi agClassesFile +-- in commonHook uuagc classesPath pd lbi (sDistVerbosity df) +-- originalSDistHook pd mbLbi uh df +-- -} +-- originalSDistHook pd mbLbi (uh { hookedPreProcessors = ("ag", nouuagc):("lag",nouuagc):knownSuffixHandlers }) df -- bypass preprocessors + +uuagcBuildHook + :: ([String] -> FilePath -> IO (ExitCode, [FilePath])) + -> PackageDescription + -> LocalBuildInfo + -> UserHooks + -> BuildFlags + -> IO () +uuagcBuildHook uuagc pd lbi uh bf = do + let classesPath = buildDir lbi agClassesFile + commonHook uuagc classesPath pd lbi (buildVerbosity bf) + originalBuildHook pd lbi uh bf + +commonHook :: ([String] -> FilePath -> IO (ExitCode, [FilePath])) + -> FilePath + -> PackageDescription + -> LocalBuildInfo + -> Flag Verbosity + -> IO () +commonHook uuagc classesPath pd lbi fl = do + let verbosity = fromFlagOrDefault normal fl + info verbosity $ "commonHook: Assuming AG classesPath: " ++ classesPath + createDirectoryIfMissingVerbose verbosity True (buildDir lbi) + -- Read already existing options + -- Map FilePath (Options, Maybe (FilePath,[String])) + oldOptions <- readFileOptions classesPath + -- Read options from cabal and settings file + let lib = library pd + exes = executables pd + bis = map libBuildInfo (maybeToList lib) ++ map buildInfo exes + classes <- map (className &&& opts') `fmap` (getAGClasses . customFieldsPD $ pd) + configOptions <- getAGFileOptions (bis >>= customFieldsBI) + -- Construct new options map + newOptionsL <- forM configOptions (\ opt -> + let (notFound, opts) = getOptionsFromClass classes $ opt + file = normalise $ filename opt + gen = maybe Nothing snd $ Map.lookup file oldOptions + in do info verbosity $ "options for " ++ file ++ ": " ++ unwords (optionsToString opts) + forM_ notFound (hPutStrLn stderr) + return (file, (opts, gen))) + let newOptions = Map.fromList newOptionsL + writeFileOptions classesPath newOptions + -- Check if files should be regenerated + mapM_ (updateAGFile uuagc newOptions) $ Map.toList oldOptions + +getAGFileList :: AGFileOptions -> [FilePath] +getAGFileList = map (normalise . filename) + +uuagc :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor +uuagc = uuagc' (uuagcFromString uuagcn) + +uuagc' :: ([String] -> FilePath -> IO (ExitCode, [FilePath])) + -> BuildInfo + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> PreProcessor +uuagc' uuagc build lbi _ = + PreProcessor { +#if MIN_VERSION_Cabal(3,8,1) + -- The ppOrdering field was added in Cabal 3.8.1 (GHC 9.4) + ppOrdering = \_verbosity _files modules -> pure modules, +#endif + platformIndependent = True, + runPreProcessor = mkSimplePreProcessor $ \ inFile outFile verbosity -> + do notice verbosity $ "[UUAGC] processing: " ++ inFile ++ " generating: " ++ outFile + let classesPath = buildDir lbi agClassesFile + info verbosity $ "uuagc-preprocessor: Assuming AG classesPath: " ++ classesPath + fileOpts <- readFileOptions classesPath + opts <- case Map.lookup inFile fileOpts of + Nothing -> do warn verbosity $ "No options found for " ++ inFile + return noOptions + Just (opt,gen) -> return opt + let search = dropFileName inFile + options = opts { searchPath = search : hsSourceDirsFilePaths (hsSourceDirs build) ++ searchPath opts + , outputFiles = outFile : (outputFiles opts) } + (eCode,_) <- uuagc (optionsToString options) inFile + case eCode of + ExitSuccess -> writeFileOptions classesPath (Map.insert inFile (opts, Just (outFile, searchPath options)) fileOpts) + ex@(ExitFailure _) -> throwIO ex + } + +-- | In Cabal 3.6.0.0 (GHC 9.2) and up, 'BuildInfo' member 'hsSourceDirs' has type +-- '[SymbolicPath PackageDir SourceDir]', but in versions before that, it is [FilePath]. +#if MIN_VERSION_Cabal(3,6,0) +hsSourceDirsFilePaths :: [SymbolicPath PackageDir SourceDir] -> [FilePath] +hsSourceDirsFilePaths = map getSymbolicPath +#else +hsSourceDirsFilePaths :: [FilePath] -> [FilePath] +hsSourceDirsFilePaths = id +#endif + +nouuagc :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor +nouuagc build lbi _ = + PreProcessor { +#if MIN_VERSION_Cabal(3,8,1) + -- The ppOrdering field was added in Cabal 3.8.1 (GHC 9.4) + ppOrdering = \_verbosity _files modules -> pure modules, +#endif + platformIndependent = True, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do + info verbosity ("skipping: " ++ outFile) + } diff --git a/uuagc-cabal.cabal b/uuagc-cabal.cabal --- a/uuagc-cabal.cabal +++ b/uuagc-cabal.cabal @@ -1,28 +1,28 @@ -cabal-version: >=1.10 -build-type: Simple -name: uuagc-cabal -version: 1.2.0.0 -license: BSD3 -license-file: LICENSE -maintainer: Atze Dijkstra (atzedijkstra@gmail.com) -homepage: https://github.com/UU-ComputerScience/uuagc -synopsis: Cabal plugin for UUAGC -description: Cabal plugin for the Universiteit Utrecht Attribute Grammar System -category: Development -stability: Stable -copyright: Universiteit Utrecht -author: Software Technology at Universiteit Utrecht -bug-reports: https://github.com/UU-ComputerScience/uuagc/issues -tested-with: GHC >= 6.12 -extra-source-files: README - -library - build-depends: base >= 4, base < 5, Cabal >= 2, directory >= 1.0.1.1 - build-depends: process >= 1.0.1.3, containers >= 0.3, uulib >= 0.9.14, filepath >= 1.1.0.4, mtl >= 2.2.1 - hs-source-dirs: src, src-options - default-language: Haskell2010 - exposed-modules: Distribution.Simple.UUAGC - other-modules: Distribution.Simple.UUAGC.UUAGC, - Distribution.Simple.UUAGC.AbsSyn, - Distribution.Simple.UUAGC.Parser, - Options +cabal-version: >=1.10 +build-type: Simple +name: uuagc-cabal +version: 1.3.0.0 +license: BSD3 +license-file: LICENSE +maintainer: Atze Dijkstra (atzedijkstra@gmail.com) +homepage: https://github.com/UU-ComputerScience/uuagc +synopsis: Cabal plugin for UUAGC +description: Cabal plugin for the Universiteit Utrecht Attribute Grammar System +category: Development +stability: Stable +copyright: Universiteit Utrecht +author: Software Technology at Universiteit Utrecht +bug-reports: https://github.com/UU-ComputerScience/uuagc/issues +tested-with: GHC >= 6.12 +extra-source-files: README + +library + build-depends: base >= 4, base < 5, Cabal >= 2, directory >= 1.0.1.1 + build-depends: process >= 1.0.1.3, containers >= 0.3, uulib >= 0.9.14, filepath >= 1.1.0.4, mtl >= 2.2.1 + hs-source-dirs: src, src-options + default-language: Haskell2010 + exposed-modules: Distribution.Simple.UUAGC + other-modules: Distribution.Simple.UUAGC.UUAGC, + Distribution.Simple.UUAGC.AbsSyn, + Distribution.Simple.UUAGC.Parser, + Options