uuagc-cabal-1.0.4.0/0000755000000000000000000000000012060411152012174 5ustar0000000000000000uuagc-cabal-1.0.4.0/LICENSE0000644000000000000000000000270212060411152013202 0ustar0000000000000000All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the Universiteit Utrecht nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL UNIVERSITEIT UTRECHT BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. uuagc-cabal-1.0.4.0/README0000644000000000000000000000221412060411152013053 0ustar0000000000000000This 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 compiler = "uuagc" main = defaultMainWithHooks (uuagcUserHook' compiler) -- 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). uuagc-cabal-1.0.4.0/Setup.hs0000644000000000000000000000010012060411152013617 0ustar0000000000000000module Main where import Distribution.Simple main = defaultMain uuagc-cabal-1.0.4.0/uuagc-cabal.cabal0000644000000000000000000000175212060411152015331 0ustar0000000000000000cabal-version: >=1.8 build-type: Simple name: uuagc-cabal version: 1.0.4.0 license: BSD3 license-file: LICENSE maintainer: Jeroen Bransen homepage: http://www.cs.uu.nl/wiki/HUT/WebHome description: Cabal plugin for UUAGC synopsis: Cabal plugin for the Universiteit Utrecht Attribute Grammar System category: Development stability: Stable copyright: Universiteit Utrecht author: Software Technology at Universiteit Utrecht bug-reports: hut-developers@cs.uu.nl tested-with: GHC >= 6.12 extra-source-files: README library build-depends: base >= 4, base < 5, Cabal >= 1.8.0.6, 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.0.1.0 hs-source-dirs: src, src-options exposed-modules: Distribution.Simple.UUAGC other-modules: Distribution.Simple.UUAGC.UUAGC, Distribution.Simple.UUAGC.AbsSyn, Distribution.Simple.UUAGC.Parser, Options uuagc-cabal-1.0.4.0/src/0000755000000000000000000000000012060411152012763 5ustar0000000000000000uuagc-cabal-1.0.4.0/src/Distribution/0000755000000000000000000000000012060411152015442 5ustar0000000000000000uuagc-cabal-1.0.4.0/src/Distribution/Simple/0000755000000000000000000000000012060411152016673 5ustar0000000000000000uuagc-cabal-1.0.4.0/src/Distribution/Simple/UUAGC.hs0000644000000000000000000000016712060411152020077 0ustar0000000000000000module Distribution.Simple.UUAGC(module Distribution.Simple.UUAGC.UUAGC) where import Distribution.Simple.UUAGC.UUAGC uuagc-cabal-1.0.4.0/src/Distribution/Simple/UUAGC/0000755000000000000000000000000012060411152017537 5ustar0000000000000000uuagc-cabal-1.0.4.0/src/Distribution/Simple/UUAGC/AbsSyn.hs0000644000000000000000000000113312060411152021270 0ustar0000000000000000module 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 uuagc-cabal-1.0.4.0/src/Distribution/Simple/UUAGC/Parser.hs0000644000000000000000000001302712060411152021332 0ustar0000000000000000{-# 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 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,[]) uuagc-cabal-1.0.4.0/src/Distribution/Simple/UUAGC/UUAGC.hs0000644000000000000000000002777012060411152020754 0ustar0000000000000000{-# LANGUAGE CPP #-} module Distribution.Simple.UUAGC.UUAGC(uuagcUserHook, uuagcUserHook', uuagc, uuagcLibUserHook, uuagcFromString ) where import Distribution.Simple.BuildPaths (autogenModulesDir) import Debug.Trace import Distribution.Simple import Distribution.Simple.PreProcess import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Utils import Distribution.Simple.Setup import Distribution.PackageDescription hiding (Flag) import Distribution.Simple.UUAGC.AbsSyn( AGFileOption(..) , AGFileOptions , AGOptionsClass(..) , lookupFileOptions , fileClasses ) import Distribution.Simple.UUAGC.Parser import Options hiding (verbose) import Distribution.Verbosity import System.Process( CreateProcess(..), createProcess, CmdSpec(..) , StdStream(..), runProcess, waitForProcess , shell) 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 let argline = uuagcPath ++ concatMap (' ':) (args ++ [file]) (_, Just ppOutput, Just ppError, ph) <- createProcess (shell argline) { std_in = Inherit , std_out = CreatePipe , std_err = CreatePipe } ec <- waitForProcess ph case ec of ExitSuccess -> do putErrorInfo ppError fls <- processContent ppOutput return (ExitSuccess, fls) (ExitFailure exc) -> do hPutStrLn stderr (uuagcPath ++ ": " ++ show exc) putErrorInfo ppOutput putErrorInfo ppError 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 processContent :: Handle -> IO [String] processContent = liftM words . hGetContents 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 (ec, files) <- uuagc (optionsToString $ opts { genFileDeps = True, searchPath = sp }) file case ec of ExitSuccess -> do when ((not.null) files) $ do flsmt <- mapM getModificationTime files let maxModified = maximum flsmt fmt <- getModificationTime gen let newOpts :: Options newOpts = maybe noOptions fst $ Map.lookup file newOptions -- When some dependency is newer or options have changed, we should regenerate when (maxModified > fmt || optionsToString newOpts /= optionsToString opts) $ removeFile gen ex@(ExitFailure _) -> throwIO ex getAGFileOptions :: [(String, String)] -> IO AGFileOptions getAGFileOptions extra = do usesOptionsFile <- doesFileExist defUUAGCOptions if usesOptionsFile then do r <- parserAG' defUUAGCOptions case r of Left e -> print e >> exitFailure Right a -> return a else mapM (parseOptionAG . snd) $ filter ((== agModule) . fst) extra 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 -> PreProcessor uuagc = uuagc' (uuagcFromString uuagcn) uuagc' :: ([String] -> FilePath -> IO (ExitCode, [FilePath])) -> BuildInfo -> LocalBuildInfo -> PreProcessor uuagc' uuagc build lbi = PreProcessor { platformIndependent = True, runPreProcessor = mkSimplePreProcessor $ \ inFile outFile verbosity -> do putStrLn $ "[UUAGC] processing: " ++ inFile ++ " generating: " ++ outFile let classesPath = buildDir lbi agClassesFile info verbosity $ "uuagc-preprocessor: Assuming AG classesPath: " ++ classesPath fileOpts <- readFileOptions classesPath let opts = case Map.lookup inFile fileOpts of Nothing -> noOptions Just (opt,gen) -> opt 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 -> PreProcessor nouuagc build lbi = PreProcessor { platformIndependent = True, runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do info verbosity ("skipping: " ++ outFile) } uuagc-cabal-1.0.4.0/src-options/0000755000000000000000000000000012060411152014454 5ustar0000000000000000uuagc-cabal-1.0.4.0/src-options/Options.hs0000644000000000000000000010100612060411152016441 0ustar0000000000000000module Options where import System.Console.GetOpt import Data.Set(Set) import UU.Scanner.Position(Pos,noPos) import Data.List(intercalate) import qualified Data.Set as Set import System.IO import System.Exit -- From CommonTypes data Identifier = Ident { getName::String, getPos::Pos } type NontermIdent = Identifier identifier :: String -> Identifier identifier x = Ident x noPos instance Eq Identifier where Ident x _ == Ident y _ = x == y instance Ord Identifier where compare (Ident x _) (Ident y _) = compare x y instance Show Identifier where show ident = getName ident -- Make options serializable data MyOptDescr = MyOpt [Char] [String] (ArgDescr (Options -> Options)) (Options -> String -> [String]) String fromMyOpt :: MyOptDescr -> OptDescr (Options -> Options) fromMyOpt (MyOpt sh ln desc _ s) = Option sh ln desc s noOpt :: Options -> String -> [String] noOpt _ _ = [] boolOpt :: (Options -> Bool) -> Options -> String -> [String] boolOpt get opt strArg = let oldVal = get noOptions newVal = get opt in if oldVal /= newVal then [strArg] else [] stringOpt :: (Options -> String) -> Options -> String -> [String] stringOpt get opt strArg = let oldVal = get noOptions newVal = get opt in if oldVal /= newVal then [strArg, newVal] else [] mbStringOpt :: (Options -> Maybe String) -> Options -> String -> [String] mbStringOpt get opts nm = maybe [] (\s -> [nm++"="++s]) (get opts) serializeOption :: Options -> MyOptDescr -> [String] serializeOption opt (MyOpt sh ln _ get _) = get opt strArg where strArg = if null sh then '-' : '-' : head ln else '-' : head sh : [] -- All options allOptions :: [MyOptDescr] allOptions = [ MyOpt ['m'] [] (NoArg (moduleOpt Nothing)) noOpt "generate default module header" , MyOpt [] ["module"] (OptArg moduleOpt "name") moduleOptGet "generate module header, specify module name" , MyOpt ['d'] ["data"] (NoArg dataOpt) (boolOpt dataTypes) "generate data type definition" , MyOpt [] ["datarecords"] (NoArg dataRecOpt) (boolOpt dataRecords) "generate record data types" , MyOpt [] ["strictdata"] (NoArg strictDataOpt) (boolOpt strictData) "generate strict data fields (when data is generated)" , MyOpt [] ["strictwrap"] (NoArg strictWrapOpt) (boolOpt strictWrap) "generate strict wrap fields for WRAPPER generated data" , MyOpt ['c'] ["catas"] (NoArg cataOpt) (boolOpt folds) "generate catamorphisms" , MyOpt ['f'] ["semfuns"] (NoArg semfunsOpt) (boolOpt semfuns) "generate semantic functions" , MyOpt ['s'] ["signatures"] (NoArg signaturesOpt) (boolOpt typeSigs) "generate signatures for semantic functions" , MyOpt [] ["newtypes"] (NoArg newtypesOpt) (boolOpt newtypes) "use newtypes instead of type synonyms" , MyOpt ['p'] ["pretty"] (NoArg prettyOpt) (boolOpt attrInfo) "generate pretty printed list of attributes" , MyOpt ['w'] ["wrappers"] (NoArg wrappersOpt) (boolOpt wrappers) "generate wappers for semantic domains" , MyOpt ['r'] ["rename"] (NoArg renameOpt) (boolOpt rename) "rename data constructors" , MyOpt [] ["modcopy"] (NoArg modcopyOpt) (boolOpt modcopy) "use modified copy rule" , MyOpt [] ["nest"] (NoArg nestOpt) (boolOpt nest) "use nested tuples" , MyOpt [] ["syntaxmacro"] (NoArg smacroOpt) (boolOpt smacro) "experimental: generate syntax macro code (using knit catas)" , MyOpt ['o'] ["output"] (ReqArg outputOpt "file") outputOptGet "specify output file" , MyOpt ['v'] ["verbose"] (NoArg verboseOpt) (boolOpt verbose) "verbose error message format" , MyOpt ['h','?'] ["help"] (NoArg helpOpt) (boolOpt showHelp) "get (this) usage information" , MyOpt ['a'] ["all"] (NoArg allOpt) noOpt ("do everything (-" ++ allc ++ ")") , MyOpt ['P'] [""] (ReqArg searchPathOpt "search path") searchPathOptGet ("specify seach path") , MyOpt [] ["prefix"] (ReqArg prefixOpt "prefix") (stringOpt prefix) "set prefix for semantic functions" , MyOpt [] ["self"] (NoArg selfOpt) (boolOpt withSelf) "generate self attribute" , MyOpt [] ["cycle"] (NoArg cycleOpt) (boolOpt withCycle) "check for cyclic definitions" , MyOpt [] ["version"] (NoArg versionOpt) (boolOpt showVersion) "get version information" , MyOpt ['O'] ["optimize"] (NoArg optimizeOpt) noOpt "optimize generated code (--visit --case)" , MyOpt [] ["visit"] (NoArg visitOpt) (boolOpt visit) "try generating visit functions" , MyOpt [] ["seq"] (NoArg seqOpt) (boolOpt withSeq) "force evaluation using function seq (visit functions only)" , MyOpt [] ["unbox"] (NoArg unboxOpt) (boolOpt unbox) "use unboxed tuples" , MyOpt [] ["bangpats"] (NoArg bangpatsOpt) (boolOpt bangpats) "use bang patterns (visit functions only)" , MyOpt [] ["case"] (NoArg casesOpt) (boolOpt cases) "Use nested cases instead of let (visit functions only)" , MyOpt [] ["strictcase"] (NoArg strictCasesOpt) (boolOpt strictCases) "Force evaluation of the scrutinee of cases (in generated code, visit functions only)" , MyOpt [] ["strictercase"] (NoArg stricterCasesOpt) (boolOpt stricterCases) "Force evaluation of all variables bound by a case statement (in generated code)" , MyOpt [] ["strictsem"] (NoArg strictSemOpt) (boolOpt strictSems) "Force evaluation of sem-function arguments (in generated code)" , MyOpt [] ["localcps"] (NoArg localCpsOpt) (boolOpt localCps) "Apply a local CPS transformation (in generated code, visit functions only)" , MyOpt [] ["splitsems"] (NoArg splitSemsOpt) (boolOpt splitSems) "Split semantic functions into smaller pieces" , MyOpt [] ["Werrors"] (NoArg werrorsOpt) (boolOpt werrors) "Turn warnings into fatal errors" , MyOpt [] ["Wignore"] (NoArg wignoreOpt) (boolOpt wignore) "Ignore warnings" , MyOpt [] ["Wmax"] (ReqArg wmaxErrsOpt "") wmaxErrsOptGet "Sets the maximum number of errors that are reported" , MyOpt [] ["dumpgrammar"] (NoArg dumpgrammarOpt) (boolOpt dumpgrammar) "Dump internal grammar representation (in generated code)" , MyOpt [] ["dumpcgrammar"] (NoArg dumpcgrammarOpt) (boolOpt dumpcgrammar)"Dump internal cgrammar representation (in generated code)" , MyOpt [] ["gentraces"] (NoArg genTracesOpt) (boolOpt genTraces) "Generate trace expressions (in generated code)" , MyOpt [] ["genusetraces"] (NoArg genUseTracesOpt) (boolOpt genUseTraces)"Generate trace expressions at attribute use sites (in generated code)" , MyOpt [] ["gencostcentres"] (NoArg genCostCentresOpt) (boolOpt genCostCentres) "Generate cost centre pragmas (in generated code)" , MyOpt [] ["genlinepragmas"] (NoArg genLinePragmasOpt) (boolOpt genLinePragmas) "Generate GHC LINE pragmas (in generated code)" , MyOpt [] ["sepsemmods"] (NoArg sepSemModsOpt) (boolOpt sepSemMods) "Generate separate modules for semantic functions (in generated code)" , MyOpt ['M'] ["genfiledeps"] (NoArg genFileDepsOpt) (boolOpt genFileDeps) "Generate a list of dependencies on the input AG files" , MyOpt [] ["genvisage"] (NoArg genVisageOpt) (boolOpt genvisage) "Generate output for the AG visualizer Visage" , MyOpt [] ["aspectag"] (NoArg genAspectAGOpt) (boolOpt genAspectAG) "Generate AspectAG file" , MyOpt [] ["nogroup"] (ReqArg noGroupOpt "attributes") noGroupOptGet "specify the attributes that won't be grouped in AspectAG" , MyOpt [] ["extends"] (ReqArg extendsOpt "module") (mbStringOpt extends) "specify a module to be extended" , MyOpt [] ["genattrlist"] (NoArg genAttrListOpt) (boolOpt genAttributeList) "Generate a list of all explicitly defined attributes (outside irrefutable patterns)" , MyOpt [] ["forceirrefutable"] (OptArg forceIrrefutableOpt "file") (mbStringOpt forceIrrefutables) "Force a set of explicitly defined attributes to be irrefutable, specify file containing the attribute set" , MyOpt [] ["uniquedispenser"] (ReqArg uniqueDispenserOpt "name") (stringOpt uniqueDispenser) "The Haskell function to call in the generated code" , MyOpt [] ["lckeywords"] (NoArg lcKeywordsOpt) (boolOpt lcKeywords) "Use lowercase keywords (sem, attr) instead of the uppercase ones (SEM, ATTR)" , MyOpt [] ["doublecolons"] (NoArg doubleColonsOpt) (boolOpt doubleColons)"Use double colons for type signatures instead of single colons" , MyOpt ['H'] ["haskellsyntax"] (NoArg haskellSyntaxOpt) noOpt "Use Haskell like syntax (equivalent to --lckeywords and --doublecolons --genlinepragmas)" , MyOpt [] ["reference"] (NoArg referenceOpt) (boolOpt reference) "Use reference attributes" , MyOpt [] ["monadic"] (NoArg monadicOpt) (boolOpt monadic) "Experimental: generate monadic code" , MyOpt [] ["ocaml"] (NoArg ocamlOpt) (boolOpt ocaml) "Generate Ocaml code" , MyOpt [] ["breadthfirst"] (NoArg breadthfirstOpt) (boolOpt breadthFirst)"Experimental: generate breadth-first code" , MyOpt [] ["breadthfirst-strict"] (NoArg breadthfirstStrictOpt) (boolOpt breadthFirstStrict) "Experimental: outermost breadth-first evaluator is strict instead of lazy" , MyOpt [] ["visitcode"] (NoArg visitorsOutputOpt) (boolOpt visitorsOutput) "Experimental: generate visitors code" , MyOpt [] ["kennedywarren"] (NoArg kennedyWarrenOpt) (boolOpt kennedyWarren) "Experimental: use Kennedy-Warren's algorithm for ordering" , MyOpt [] ["statistics"] (ReqArg statisticsOpt "FILE to append to") (mbStringOpt statsFile) "Append statistics to FILE" , MyOpt [] ["checkParseRhs"] (NoArg parseHsRhsOpt) (boolOpt checkParseRhs) "Parse RHS of rules with Haskell parser" , MyOpt [] ["checkParseTys"] (NoArg parseHsTpOpt) (boolOpt checkParseTy) "Parse types of attrs with Haskell parser" , MyOpt [] ["checkParseBlocks"] (NoArg parseHsBlockOpt) (boolOpt checkParseBlock) "Parse blocks with Haskell parser" , MyOpt [] ["checkParseHaskell"] (NoArg parseHsOpt) noOpt "Parse Haskell code (recognizer)" , MyOpt [] ["nocatas"] (ReqArg nocatasOpt "list of nonterms") nocatasOptGet "Nonterminals not to generate catas for" , MyOpt [] ["nooptimize"] (NoArg noOptimizeOpt) (boolOpt noOptimizations) "Disable optimizations" , MyOpt [] ["parallel"] (NoArg parallelOpt) (boolOpt parallelInvoke) "Generate a parallel evaluator (if possible)" , MyOpt [] ["monadicwrapper"] (NoArg monadicWrappersOpt) (boolOpt monadicWrappers) "Generate monadic wrappers" , MyOpt [] ["helpinlining"] (NoArg helpInliningOpt) (boolOpt helpInlining) "Generate inline directives for GHC" , MyOpt [] ["dummytokenvisit"] (NoArg dummyTokenVisitOpt) (boolOpt dummyTokenVisit) "Add an additional dummy parameter to visit functions" , MyOpt [] ["tupleasdummytoken"] (NoArg tupleAsDummyTokenOpt) (boolOpt tupleAsDummyToken) "Use conventional tuples as dummy parameter instead of a RealWorld state token" , MyOpt [] ["stateasdummytoken"] (NoArg stateAsDummyTokenOpt) noOpt "Use RealWorld state token as dummy parameter instead of conventional tuples (default)" , MyOpt [] ["strictdummytoken"] (NoArg strictDummyTokenOpt) (boolOpt strictDummyToken) "Strictify the dummy token that makes states and rules functions" , MyOpt [] ["noperruletypesigs"] (NoArg noPerRuleTypeSigsOpt) (boolOpt noPerRuleTypeSigs) "Do not generate type sigs for attrs passed to rules" , MyOpt [] ["noperstatetypesigs"] (NoArg noPerStateTypeSigsOpt) (boolOpt noPerStateTypeSigs) "Do not generate type sigs for attrs saved in node states" , MyOpt [] ["noeagerblackholing"] (NoArg noEagerBlackholingOpt) (boolOpt noEagerBlackholing) "Do not automatically add the eager blackholing feature for parallel programs" , MyOpt [] ["noperrulecostcentres"] (NoArg noPerRuleCostCentresOpt) (boolOpt noPerRuleCostCentres) "Do not generate cost centres for rules" , MyOpt [] ["nopervisitcostcentres"] (NoArg noPerVisitCostCentresOpt) (boolOpt noPerVisitCostCentres) "Do not generate cost centres for visits" , MyOpt [] ["noinlinepragmas"] (NoArg noInlinePragmasOpt) (boolOpt noInlinePragmas) "Definitely not generate inline directives" , MyOpt [] ["aggressiveinlinepragmas"] (NoArg aggressiveInlinePragmasOpt) (boolOpt aggressiveInlinePragmas) "Generate more aggressive inline directives" , MyOpt [] ["latehigherorderbinding"] (NoArg lateHigherOrderBindingOpt) (boolOpt lateHigherOrderBinding) "Generate an attribute and wrapper for late binding of higher-order attributes" , MyOpt [] ["noincludes"] (NoArg noIncludesOpt) (boolOpt noIncludes) "Ignore include directives in .ag files" , MyOpt [] ["quiet"] (NoArg beQuietOpt) (boolOpt beQuiet) "Dont print some compilation information" ] -- For compatibility options :: [OptDescr (Options -> Options)] options = map fromMyOpt allOptions allc :: String allc = "dcfsprm" data ModuleHeader = NoName | Name String | Default deriving (Eq, Show) data Options = Options{ moduleName :: ModuleHeader , dataTypes :: Bool , dataRecords :: Bool , strictData :: Bool , strictWrap :: Bool , folds :: Bool , semfuns :: Bool , typeSigs :: Bool , attrInfo :: Bool , rename :: Bool , wrappers :: Bool , modcopy :: Bool , newtypes :: Bool , nest :: Bool , smacro :: Bool , outputFiles :: [String] , searchPath :: [String] , verbose :: Bool , prefix :: String , withSelf :: Bool , withCycle :: Bool , showHelp :: Bool , showVersion :: Bool , visit :: Bool , withSeq :: Bool , unbox :: Bool , bangpats :: Bool , cases :: Bool , strictCases :: Bool , stricterCases :: Bool , strictSems :: Bool , localCps :: Bool , splitSems :: Bool , werrors :: Bool , wignore :: Bool , wmaxerrs :: Int , dumpgrammar :: Bool , dumpcgrammar :: Bool , sepSemMods :: Bool , allowSepSemMods :: Bool , genFileDeps :: Bool , genLinePragmas :: Bool , genvisage :: Bool , genAspectAG :: Bool , noGroup :: [String] , extends :: Maybe String , genAttributeList :: Bool , forceIrrefutables :: Maybe String , uniqueDispenser :: String , lcKeywords :: Bool , doubleColons :: Bool , monadic :: Bool , ocaml :: Bool , visitorsOutput :: Bool , statsFile :: Maybe String , breadthFirst :: Bool , breadthFirstStrict :: Bool , checkParseRhs :: Bool , checkParseTy :: Bool , checkParseBlock :: Bool , nocatas :: Set NontermIdent , noOptimizations :: Bool , reference :: Bool , noIncludes :: Bool , outputStr :: String -> IO () , failWithCode :: Int -> IO () , mainFilename :: Maybe String , beQuiet :: Bool -- KW code path , kennedyWarren :: Bool , parallelInvoke :: Bool , tupleAsDummyToken :: Bool -- use the empty tuple as dummy token instead of State# RealWorld (Lambda State Hack GHC?) , dummyTokenVisit :: Bool -- add a dummy argument/pass dummy extra token to visits (should not really have an effect ... Lambda State Hack GHC?) , strictDummyToken :: Bool -- make the dummy token strict (to prevent its removal -- should not really have an effect) , noPerRuleTypeSigs :: Bool -- do not print type signatures for attributes of rules , noPerStateTypeSigs :: Bool -- do not print type signatures for attributes contained in the state , noEagerBlackholing :: Bool -- disable the use of eager black holing in the parallel evaluator code , lateHigherOrderBinding :: Bool -- generate code to allow late binding of higher-order children semantics , monadicWrappers :: Bool -- tracing , genTraces :: Bool , genUseTraces :: Bool , genCostCentres :: Bool , noPerRuleCostCentres :: Bool , noPerVisitCostCentres :: Bool -- inline pragma generation , helpInlining :: Bool , noInlinePragmas :: Bool , aggressiveInlinePragmas :: Bool } -- deriving (Eq, Show) noOptions :: Options noOptions = Options { moduleName = NoName , dataTypes = False , dataRecords = False , strictData = False , strictWrap = False , folds = False , semfuns = False , typeSigs = False , attrInfo = False , rename = False , wrappers = False , modcopy = False , newtypes = False , nest = False , smacro = False , outputFiles = [] , searchPath = [] , verbose = False , showHelp = False , showVersion = False , prefix = "sem_" , withSelf = False , withCycle = False , visit = False , withSeq = False , unbox = False , bangpats = False , cases = False , strictCases = False , stricterCases = False , strictSems = False , localCps = False , splitSems = False , werrors = False , wignore = False , wmaxerrs = 99999 , dumpgrammar = False , dumpcgrammar = False , sepSemMods = False , allowSepSemMods = True , genFileDeps = False , genLinePragmas = False , genvisage = False , genAspectAG = False , noGroup = [] , extends = Nothing , genAttributeList = False , forceIrrefutables = Nothing , uniqueDispenser = "nextUnique" , lcKeywords = False , doubleColons = False , monadic = False , ocaml = False , visitorsOutput = False , statsFile = Nothing , breadthFirst = False , breadthFirstStrict = False , checkParseRhs = False , checkParseTy = False , checkParseBlock = False , nocatas = Set.empty , noOptimizations = False , reference = False , noIncludes = False , outputStr = hPutStr stderr , failWithCode = exitWith . ExitFailure , mainFilename = Nothing , beQuiet = False -- defaults for the KW-code path , kennedyWarren = False , parallelInvoke = False , tupleAsDummyToken = True , dummyTokenVisit = False , strictDummyToken = False , noPerRuleTypeSigs = False , noPerStateTypeSigs = False , noEagerBlackholing = False , lateHigherOrderBinding = False , monadicWrappers = False -- defaults for tracing , genTraces = False , genUseTraces = False , genCostCentres = False , noPerRuleCostCentres = False , noPerVisitCostCentres = False -- defaults for inline pragma generation , helpInlining = False , noInlinePragmas = False , aggressiveInlinePragmas = False } --Options -> String -> [String] moduleOpt :: Maybe String -> Options -> Options moduleOpt nm opts = opts{moduleName = maybe Default Name nm} moduleOptGet :: Options -> String -> [String] moduleOptGet opts nm = case moduleName opts of NoName -> [] Name s -> [nm++"="++s] Default -> [nm] dataOpt, dataRecOpt, strictDataOpt, strictWrapOpt, cataOpt, semfunsOpt, signaturesOpt, prettyOpt,renameOpt, wrappersOpt, modcopyOpt, newtypesOpt, nestOpt, smacroOpt, verboseOpt, helpOpt, versionOpt, selfOpt, cycleOpt, visitOpt, seqOpt, unboxOpt, bangpatsOpt, casesOpt, strictCasesOpt, stricterCasesOpt, strictSemOpt, localCpsOpt, splitSemsOpt, werrorsOpt, wignoreOpt, dumpgrammarOpt, dumpcgrammarOpt, genTracesOpt, genUseTracesOpt, genCostCentresOpt, sepSemModsOpt, genFileDepsOpt, genLinePragmasOpt, genVisageOpt, genAspectAGOpt, dummyTokenVisitOpt, tupleAsDummyTokenOpt, stateAsDummyTokenOpt, strictDummyTokenOpt, noPerRuleTypeSigsOpt, noPerStateTypeSigsOpt, noEagerBlackholingOpt, noPerRuleCostCentresOpt, noPerVisitCostCentresOpt, helpInliningOpt, noInlinePragmasOpt, aggressiveInlinePragmasOpt, lateHigherOrderBindingOpt, monadicWrappersOpt, referenceOpt, genAttrListOpt, lcKeywordsOpt, doubleColonsOpt, haskellSyntaxOpt, monadicOpt, parallelOpt, ocamlOpt, visitorsOutputOpt, breadthfirstOpt, breadthfirstStrictOpt, parseHsRhsOpt, parseHsTpOpt, parseHsBlockOpt, parseHsOpt, kennedyWarrenOpt, noOptimizeOpt, allOpt, optimizeOpt, noIncludesOpt, beQuietOpt, condDisableOptimizations :: Options -> Options dataOpt opts = opts{dataTypes = True} dataRecOpt opts = opts{dataRecords = True} strictDataOpt opts = opts{strictData = True} strictWrapOpt opts = opts{strictWrap = True} cataOpt opts = opts{folds = True} semfunsOpt opts = opts{semfuns = True} signaturesOpt opts = opts{typeSigs = True} prettyOpt opts = opts{attrInfo = True} renameOpt opts = opts{rename = True} wrappersOpt opts = opts{wrappers = True} modcopyOpt opts = opts{modcopy = True} newtypesOpt opts = opts{newtypes = True} nestOpt opts = opts{nest = True} smacroOpt opts = opts{smacro = True} verboseOpt opts = opts{verbose = True} helpOpt opts = opts{showHelp = True} versionOpt opts = opts{showVersion = True} prefixOpt :: String -> Options -> Options prefixOpt pre opts = opts{prefix = pre } selfOpt opts = opts{withSelf = True} cycleOpt opts = opts{withCycle = True} visitOpt opts = opts{visit = True, withCycle = True} seqOpt opts = opts{withSeq = True} unboxOpt opts = opts{unbox = True} bangpatsOpt opts = opts{bangpats = True} casesOpt opts = opts{cases = True} strictCasesOpt opts = opts{strictCases = True} stricterCasesOpt opts = opts{strictCases = True, stricterCases = True} strictSemOpt opts = opts{strictSems = True} localCpsOpt opts = opts{localCps = True} splitSemsOpt opts = opts{splitSems = True} werrorsOpt opts = opts{werrors = True} wignoreOpt opts = opts{wignore = True} wmaxErrsOpt :: String -> Options -> Options wmaxErrsOpt n opts = opts{wmaxerrs = read n} wmaxErrsOptGet :: Options -> String -> [String] wmaxErrsOptGet opts nm = if wmaxerrs opts /= wmaxerrs noOptions then [nm,show (wmaxerrs opts)] else [] dumpgrammarOpt opts = opts{dumpgrammar = True} dumpcgrammarOpt opts = opts{dumpcgrammar = True} genTracesOpt opts = opts{genTraces = True} genUseTracesOpt opts = opts{genUseTraces = True} genCostCentresOpt opts = opts{genCostCentres = True} sepSemModsOpt opts = opts{sepSemMods = allowSepSemMods opts} genFileDepsOpt opts = opts{genFileDeps = True} genLinePragmasOpt opts = opts{genLinePragmas = True} genVisageOpt opts = opts{genvisage = True } genAspectAGOpt opts = opts{genAspectAG = True} dummyTokenVisitOpt opts = opts { dummyTokenVisit = True } tupleAsDummyTokenOpt opts = opts { tupleAsDummyToken = True } stateAsDummyTokenOpt opts = opts { tupleAsDummyToken = False } strictDummyTokenOpt opts = opts { strictDummyToken = True } noPerRuleTypeSigsOpt opts = opts { noPerRuleTypeSigs = True } noPerStateTypeSigsOpt opts = opts { noPerStateTypeSigs = True } noEagerBlackholingOpt opts = opts { noEagerBlackholing = True } noPerRuleCostCentresOpt opts = opts { noPerRuleCostCentres = True } noPerVisitCostCentresOpt opts = opts { noPerVisitCostCentres = True } helpInliningOpt opts = opts { helpInlining = True } noInlinePragmasOpt opts = opts { noInlinePragmas = True } aggressiveInlinePragmasOpt opts = opts { aggressiveInlinePragmas = True } lateHigherOrderBindingOpt opts = opts { lateHigherOrderBinding = True } monadicWrappersOpt opts = opts { monadicWrappers = True } referenceOpt opts = opts { reference = True } noGroupOpt :: String -> Options -> Options noGroupOpt att opts = opts{noGroup = wordsBy (== ':') att ++ noGroup opts} noGroupOptGet :: Options -> String -> [String] noGroupOptGet opts nm = if null (noGroup opts) then [] else [nm, intercalate ":" (noGroup opts)] extendsOpt :: String -> Options -> Options extendsOpt m opts = opts{extends = Just m } genAttrListOpt opts = opts { genAttributeList = True } forceIrrefutableOpt :: Maybe String -> Options -> Options forceIrrefutableOpt mbNm opts = opts { forceIrrefutables = mbNm } uniqueDispenserOpt :: String -> Options -> Options uniqueDispenserOpt nm opts = opts { uniqueDispenser = nm } lcKeywordsOpt opts = opts { lcKeywords = True } doubleColonsOpt opts = opts { doubleColons = True } haskellSyntaxOpt = lcKeywordsOpt . doubleColonsOpt . genLinePragmasOpt monadicOpt opts = opts { monadic = True } parallelOpt opts = opts { parallelInvoke = True } ocamlOpt opts = opts { ocaml = True, kennedyWarren = True, withCycle = True, visit = True } visitorsOutputOpt opts = opts { visitorsOutput = True } statisticsOpt :: String -> Options -> Options statisticsOpt nm opts = opts { statsFile = Just nm } breadthfirstOpt opts = opts { breadthFirst = True } breadthfirstStrictOpt opts = opts { breadthFirstStrict = True } parseHsRhsOpt opts = opts { checkParseRhs = True } parseHsTpOpt opts = opts { checkParseTy = True } parseHsBlockOpt opts = opts { checkParseBlock = True } parseHsOpt = parseHsRhsOpt . parseHsTpOpt . parseHsBlockOpt kennedyWarrenOpt opts = opts { kennedyWarren = True } noOptimizeOpt opts = opts { noOptimizations = True } nocatasOpt :: String -> Options -> Options nocatasOpt str opts = opts { nocatas = set `Set.union` nocatas opts } where set = Set.fromList ids ids = map identifier lst lst = wordsBy (== ',') str nocatasOptGet :: Options -> String -> [String] nocatasOptGet opts nm = if Set.null (nocatas opts) then [] else [nm,intercalate "," . map getName . Set.toList . nocatas $ opts] outputOpt :: String -> Options -> Options outputOpt file opts = opts{outputFiles = file : outputFiles opts} outputOptGet :: Options -> String -> [String] outputOptGet opts nm = concat [ [nm, file] | file <- outputFiles opts] searchPathOpt :: String -> Options -> Options searchPathOpt path opts = opts{searchPath = wordsBy (\x -> x == ';' || x == ':') path ++ searchPath opts} searchPathOptGet :: Options -> String -> [String] searchPathOptGet opts nm = if null (searchPath opts) then [] else [nm, intercalate ":" (searchPath opts)] allOpt = moduleOpt Nothing . dataOpt . cataOpt . semfunsOpt . signaturesOpt . prettyOpt . renameOpt . dataRecOpt optimizeOpt = visitOpt . casesOpt noIncludesOpt opts = opts { noIncludes = True } beQuietOpt opts = opts { beQuiet = True } condDisableOptimizations opts | noOptimizations opts = opts { strictData = False , strictWrap = False , withSeq = False , unbox = False , bangpats = False , cases = False , strictCases = False , stricterCases = False , strictSems = False , localCps = False , splitSems = False , breadthFirstStrict = False } | otherwise = opts -- | Inverse of intercalate wordsBy :: (Char -> Bool) -> String -> [String] wordsBy p = f where f s = let (x,xs) = break p s in if null x then [] else x : f (drop 1 xs) -- | Use all parsed options to generate real options constructOptions :: [Options -> Options] -> Options constructOptions = foldl (flip ($)) noOptions -- | Create Options type from string arguments getOptions :: [String] -> (Options,[String],[String]) getOptions args = let (flags,files,errors) = getOpt Permute options args appliedOpts = constructOptions flags finOpts = condDisableOptimizations appliedOpts in (finOpts,files,errors) -- | Convert options back to commandline string optionsToString :: Options -> [String] optionsToString opt = concatMap (serializeOption opt) allOptions -- | Combine 2 sets of options combineOptions :: Options -> Options -> Options combineOptions o1 o2 = let str1 = optionsToString o1 str2 = optionsToString o2 (opt,_,_) = getOptions (str1 ++ str2) in opt