summaryrefslogtreecommitdiff
path: root/src/GF/Infra/Option.hs
diff options
context:
space:
mode:
authorkrasimir <krasimir@chalmers.se>2009-12-13 18:50:29 +0000
committerkrasimir <krasimir@chalmers.se>2009-12-13 18:50:29 +0000
commitf85232947e74ee7ef8c7b0ad2338212e7e68f1be (patch)
tree667b886a5e3a4b026a63d4e3597f32497d824761 /src/GF/Infra/Option.hs
parentd88a865faff59c98fc91556ff8700b10ee5f2df8 (diff)
reorganize the directories under src, and rescue the JavaScript interpreter from deprecated
Diffstat (limited to 'src/GF/Infra/Option.hs')
-rw-r--r--src/GF/Infra/Option.hs609
1 files changed, 0 insertions, 609 deletions
diff --git a/src/GF/Infra/Option.hs b/src/GF/Infra/Option.hs
deleted file mode 100644
index dc15d1929..000000000
--- a/src/GF/Infra/Option.hs
+++ /dev/null
@@ -1,609 +0,0 @@
-module GF.Infra.Option
- (
- -- * Option types
- Options,
- Flags(..),
- Mode(..), Phase(..), Verbosity(..), Encoding(..), OutputFormat(..),
- SISRFormat(..), Optimization(..), CFGTransform(..), HaskellOption(..),
- Dump(..), Printer(..), Recomp(..), BuildParser(..),
- -- * Option parsing
- parseOptions, parseModuleOptions, fixRelativeLibPaths,
- -- * Option pretty-printing
- optionsGFO,
- optionsPGF,
- -- * Option manipulation
- addOptions, concatOptions, noOptions,
- modifyFlags,
- helpMessage,
- -- * Checking specific options
- flag, cfgTransform, haskellOption, readOutputFormat,
- isLexicalCat, encodings,
- -- * Setting specific options
- setOptimization, setCFGTransform,
- -- * Convenience methods for checking options
- verbAtLeast, dump
- ) where
-
-import Control.Monad
-import Data.Char (toLower)
-import Data.List
-import Data.Maybe
-import GF.Infra.GetOpt
---import System.Console.GetOpt
-import System.FilePath
-
-import GF.Data.ErrM
-
-import Data.Set (Set)
-import qualified Data.Set as Set
-
-
-
-
-usageHeader :: String
-usageHeader = unlines
- ["Usage: gfc [OPTIONS] [FILE [...]]",
- "",
- "How each FILE is handled depends on the file name suffix:",
- "",
- ".gf Normal or old GF source, will be compiled.",
- ".gfo Compiled GF source, will be loaded as is.",
- ".gfe Example-based GF source, will be converted to .gf and compiled.",
- ".ebnf Extended BNF format, will be converted to .gf and compiled.",
- ".cf Context-free (BNF) format, will be converted to .gf and compiled.",
- "",
- "If multiple FILES are given, they must be normal GF source, .gfo or .gfe files.",
- "For the other input formats, only one file can be given.",
- "",
- "Command-line options:"]
-
-
-helpMessage :: String
-helpMessage = usageInfo usageHeader optDescr
-
-
--- FIXME: do we really want multi-line errors?
-errors :: [String] -> Err a
-errors = fail . unlines
-
--- Types
-
-data Mode = ModeVersion | ModeHelp | ModeInteractive | ModeRun | ModeCompiler
- deriving (Show,Eq,Ord)
-
-data Verbosity = Quiet | Normal | Verbose | Debug
- deriving (Show,Eq,Ord,Enum,Bounded)
-
-data Phase = Preproc | Convert | Compile | Link
- deriving (Show,Eq,Ord)
-
-data Encoding = UTF_8 | ISO_8859_1 | CP_1250 | CP_1251 | CP_1252
- deriving (Eq,Ord)
-
-data OutputFormat = FmtPGFPretty
- | FmtPMCFGPretty
- | FmtJavaScript
- | FmtHaskell
- | FmtProlog
- | FmtProlog_Abs
- | FmtBNF
- | FmtEBNF
- | FmtRegular
- | FmtNoLR
- | FmtSRGS_XML
- | FmtSRGS_XML_NonRec
- | FmtSRGS_ABNF
- | FmtSRGS_ABNF_NonRec
- | FmtJSGF
- | FmtGSL
- | FmtVoiceXML
- | FmtSLF
- | FmtRegExp
- | FmtFA
- deriving (Eq,Ord)
-
-data SISRFormat =
- -- | SISR Working draft 1 April 2003
- -- <http://www.w3.org/TR/2003/WD-semantic-interpretation-20030401/>
- SISR_WD20030401
- | SISR_1_0
- deriving (Show,Eq,Ord)
-
-data Optimization = OptStem | OptCSE | OptExpand | OptParametrize
- deriving (Show,Eq,Ord)
-
-data CFGTransform = CFGNoLR
- | CFGRegular
- | CFGTopDownFilter
- | CFGBottomUpFilter
- | CFGStartCatOnly
- | CFGMergeIdentical
- | CFGRemoveCycles
- deriving (Show,Eq,Ord)
-
-data HaskellOption = HaskellNoPrefix | HaskellGADT | HaskellLexical
- deriving (Show,Eq,Ord)
-
-data Warning = WarnMissingLincat
- deriving (Show,Eq,Ord)
-
-data Dump = DumpSource | DumpRebuild | DumpExtend | DumpRename | DumpTypeCheck | DumpRefresh | DumpOptimize | DumpCanon
- deriving (Show,Eq,Ord)
-
--- | Pretty-printing options
-data Printer = PrinterStrip -- ^ Remove name qualifiers.
- deriving (Show,Eq,Ord)
-
-data Recomp = AlwaysRecomp | RecompIfNewer | NeverRecomp
- deriving (Show,Eq,Ord)
-
-data BuildParser = BuildParser | DontBuildParser | BuildParserOnDemand
- deriving (Show,Eq,Ord)
-
-data Flags = Flags {
- optMode :: Mode,
- optStopAfterPhase :: Phase,
- optVerbosity :: Verbosity,
- optProf :: Bool,
- optShowCPUTime :: Bool,
- optEmitGFO :: Bool,
- optOutputFormats :: [OutputFormat],
- optSISR :: Maybe SISRFormat,
- optHaskellOptions :: Set HaskellOption,
- optLexicalCats :: Set String,
- optGFODir :: Maybe FilePath,
- optOutputFile :: Maybe FilePath,
- optOutputDir :: Maybe FilePath,
- optGFLibPath :: Maybe FilePath,
- optRecomp :: Recomp,
- optPrinter :: [Printer],
- optProb :: Bool,
- optRetainResource :: Bool,
- optName :: Maybe String,
- optAbsName :: Maybe String,
- optCncName :: Maybe String,
- optResName :: Maybe String,
- optPreprocessors :: [String],
- optEncoding :: Encoding,
- optOptimizations :: Set Optimization,
- optCFGTransforms :: Set CFGTransform,
- optLibraryPath :: [FilePath],
- optStartCat :: Maybe String,
- optSpeechLanguage :: Maybe String,
- optLexer :: Maybe String,
- optUnlexer :: Maybe String,
- optErasing :: Bool,
- optBuildParser :: BuildParser,
- optWarnings :: [Warning],
- optDump :: [Dump]
- }
- deriving (Show)
-
-newtype Options = Options (Flags -> Flags)
-
-instance Show Options where
- show (Options o) = show (o defaultFlags)
-
--- Option parsing
-
-parseOptions :: [String] -- ^ list of string arguments
- -> Err (Options, [FilePath])
-parseOptions args
- | not (null errs) = errors errs
- | otherwise = do opts <- liftM concatOptions $ sequence optss
- return (opts, files)
- where
- (optss, files, errs) = getOpt RequireOrder optDescr args
-
-parseModuleOptions :: [String] -- ^ list of string arguments
- -> Err Options
-parseModuleOptions args = do
- (opts,nonopts) <- parseOptions args
- if null nonopts
- then return opts
- else errors $ map ("Non-option among module options: " ++) nonopts
-
-fixRelativeLibPaths curr_dir lib_dir (Options o) = Options (fixPathFlags . o)
- where
- fixPathFlags f@(Flags{optLibraryPath=path}) = f{optLibraryPath=concatMap (\dir -> [curr_dir </> dir, lib_dir </> dir]) path}
-
--- Showing options
-
--- | Pretty-print the options that are preserved in .gfo files.
-optionsGFO :: Options -> [(String,String)]
-optionsGFO opts = optionsPGF opts
- ++ [("coding", show (flag optEncoding opts))]
-
--- | Pretty-print the options that are preserved in .pgf files.
-optionsPGF :: Options -> [(String,String)]
-optionsPGF opts =
- maybe [] (\x -> [("language",x)]) (flag optSpeechLanguage opts)
- ++ maybe [] (\x -> [("startcat",x)]) (flag optStartCat opts)
- ++ (if flag optErasing opts then [("erasing","on")] else [])
- ++ (if flag optBuildParser opts == BuildParserOnDemand then [("parser","ondemand")] else [])
-
--- Option manipulation
-
-flag :: (Flags -> a) -> Options -> a
-flag f (Options o) = f (o defaultFlags)
-
-addOptions :: Options -> Options -> Options
-addOptions (Options o1) (Options o2) = Options (o2 . o1)
-
-noOptions :: Options
-noOptions = Options id
-
-concatOptions :: [Options] -> Options
-concatOptions = foldr addOptions noOptions
-
-modifyFlags :: (Flags -> Flags) -> Options
-modifyFlags = Options
-
--- Default options
-
-defaultFlags :: Flags
-defaultFlags = Flags {
- optMode = ModeInteractive,
- optStopAfterPhase = Compile,
- optVerbosity = Normal,
- optProf = False,
- optShowCPUTime = False,
- optEmitGFO = True,
- optOutputFormats = [],
- optSISR = Nothing,
- optHaskellOptions = Set.empty,
- optLexicalCats = Set.empty,
- optGFODir = Nothing,
- optOutputFile = Nothing,
- optOutputDir = Nothing,
- optGFLibPath = Nothing,
- optRecomp = RecompIfNewer,
- optPrinter = [],
- optProb = False,
- optRetainResource = False,
-
- optName = Nothing,
- optAbsName = Nothing,
- optCncName = Nothing,
- optResName = Nothing,
- optPreprocessors = [],
- optEncoding = ISO_8859_1,
- optOptimizations = Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize],
- optCFGTransforms = Set.fromList [CFGRemoveCycles, CFGBottomUpFilter,
- CFGTopDownFilter, CFGMergeIdentical],
- optLibraryPath = [],
- optStartCat = Nothing,
- optSpeechLanguage = Nothing,
- optLexer = Nothing,
- optUnlexer = Nothing,
- optErasing = True,
- optBuildParser = BuildParser,
- optWarnings = [],
- optDump = []
- }
-
--- Option descriptions
-
-optDescr :: [OptDescr (Err Options)]
-optDescr =
- [
- Option ['?','h'] ["help"] (NoArg (mode ModeHelp)) "Show help message.",
- Option ['V'] ["version"] (NoArg (mode ModeVersion)) "Display GF version number.",
- Option ['v'] ["verbose"] (OptArg verbosity "N") "Set verbosity (default 1). -v alone is the same as -v 2.",
- Option ['q','s'] ["quiet"] (NoArg (verbosity (Just "0"))) "Quiet, same as -v 0.",
- Option [] ["batch"] (NoArg (mode ModeCompiler)) "Run in batch compiler mode.",
- Option [] ["interactive"] (NoArg (mode ModeInteractive)) "Run in interactive mode (default).",
- Option [] ["run"] (NoArg (mode ModeRun)) "Run in interactive mode, showing output only (no other messages).",
- Option ['E'] [] (NoArg (phase Preproc)) "Stop after preprocessing (with --preproc).",
- Option ['C'] [] (NoArg (phase Convert)) "Stop after conversion to .gf.",
- Option ['c'] [] (NoArg (phase Compile)) "Stop after compiling to .gfo (default) .",
- Option [] ["make"] (NoArg (liftM2 addOptions (mode ModeCompiler) (phase Link))) "Build .pgf file and other output files and exit.",
- Option [] ["prof"] (NoArg (prof True)) "Dump profiling information when compiling to PMCFG",
- Option [] ["cpu"] (NoArg (cpu True)) "Show compilation CPU time statistics.",
- Option [] ["no-cpu"] (NoArg (cpu False)) "Don't show compilation CPU time statistics (default).",
- Option [] ["emit-gfo"] (NoArg (emitGFO True)) "Create .gfo files (default).",
- Option [] ["no-emit-gfo"] (NoArg (emitGFO False)) "Do not create .gfo files.",
- Option [] ["gfo-dir"] (ReqArg gfoDir "DIR") "Directory to put .gfo files in (default = '.').",
- Option ['f'] ["output-format"] (ReqArg outFmt "FMT")
- (unlines ["Output format. FMT can be one of:",
- "Multiple concrete: pgf (default), gar, js, prolog, ...",
- "Single concrete only: cf, bnf, lbnf, gsl, srgs_xml, srgs_abnf, ...",
- "Abstract only: haskell, prolog_abs, ..."]),
- Option [] ["sisr"] (ReqArg sisrFmt "FMT")
- (unlines ["Include SISR tags in generated speech recognition grammars.",
- "FMT can be one of: old, 1.0"]),
- Option [] ["haskell"] (ReqArg hsOption "OPTION")
- ("Turn on an optional feature when generating Haskell data types. OPTION = "
- ++ concat (intersperse " | " (map fst haskellOptionNames))),
- Option [] ["lexical"] (ReqArg lexicalCat "CAT[,CAT[...]]")
- "Treat CAT as a lexical category.",
- Option ['o'] ["output-file"] (ReqArg outFile "FILE")
- "Save output in FILE (default is out.X, where X depends on output format.",
- Option ['D'] ["output-dir"] (ReqArg outDir "DIR")
- "Save output files (other than .gfo files) in DIR.",
- Option [] ["gf-lib-path"] (ReqArg gfLibPath "DIR")
- "Overides the value of GF_LIB_PATH.",
- Option [] ["src","force-recomp"] (NoArg (recomp AlwaysRecomp))
- "Always recompile from source.",
- Option [] ["gfo","recomp-if-newer"] (NoArg (recomp RecompIfNewer))
- "(default) Recompile from source if the source is newer than the .gfo file.",
- Option [] ["gfo","no-recomp"] (NoArg (recomp NeverRecomp))
- "Never recompile from source, if there is already .gfo file.",
- Option [] ["strip"] (NoArg (printer PrinterStrip))
- "Remove name qualifiers when pretty-printing.",
- Option [] ["retain"] (NoArg (set $ \o -> o { optRetainResource = True })) "Retain opers.",
- Option [] ["prob"] (NoArg (prob True)) "Read probabilities from '--# prob' pragmas.",
- Option ['n'] ["name"] (ReqArg name "NAME")
- (unlines ["Use NAME as the name of the output. This is used in the output file names, ",
- "with suffixes depending on the formats, and, when relevant, ",
- "internally in the output."]),
- Option [] ["abs"] (ReqArg absName "NAME")
- ("Use NAME as the name of the abstract syntax module generated from "
- ++ "a grammar in GF 1 format."),
- Option [] ["cnc"] (ReqArg cncName "NAME")
- ("Use NAME as the name of the concrete syntax module generated from "
- ++ "a grammar in GF 1 format."),
- Option [] ["res"] (ReqArg resName "NAME")
- ("Use NAME as the name of the resource module generated from "
- ++ "a grammar in GF 1 format."),
- Option ['i'] [] (ReqArg addLibDir "DIR") "Add DIR to the library search path.",
- Option [] ["path"] (ReqArg setLibPath "DIR:DIR:...") "Set the library search path.",
- Option [] ["preproc"] (ReqArg preproc "CMD")
- (unlines ["Use CMD to preprocess input files.",
- "Multiple preprocessors can be used by giving this option multiple times."]),
- Option [] ["coding"] (ReqArg coding "ENCODING")
- ("Character encoding of the source grammar, ENCODING = "
- ++ concat (intersperse " | " (map fst encodings)) ++ "."),
- Option [] ["erasing"] (onOff erasing False) "Generate erasing grammar (default off).",
- Option [] ["parser"] (ReqArg buildParser "VALUE") "Build parser (default on). VALUE = on | off | ondemand",
- Option [] ["startcat"] (ReqArg startcat "CAT") "Grammar start category.",
- Option [] ["language"] (ReqArg language "LANG") "Set the speech language flag to LANG in the generated grammar.",
- Option [] ["lexer"] (ReqArg lexer "LEXER") "Use lexer LEXER.",
- Option [] ["unlexer"] (ReqArg unlexer "UNLEXER") "Use unlexer UNLEXER.",
- Option [] ["optimize"] (ReqArg optimize "OPT")
- "Select an optimization package. OPT = all | values | parametrize | none",
- Option [] ["stem"] (onOff (toggleOptimize OptStem) True) "Perform stem-suffix analysis (default on).",
- Option [] ["cse"] (onOff (toggleOptimize OptCSE) True) "Perform common sub-expression elimination (default on).",
- Option [] ["cfg"] (ReqArg cfgTransform "TRANS") "Enable or disable specific CFG transformations. TRANS = merge, no-merge, bottomup, no-bottomup, ...",
- dumpOption "source" DumpSource,
- dumpOption "rebuild" DumpRebuild,
- dumpOption "extend" DumpExtend,
- dumpOption "rename" DumpRename,
- dumpOption "tc" DumpTypeCheck,
- dumpOption "refresh" DumpRefresh,
- dumpOption "opt" DumpOptimize,
- dumpOption "canon" DumpCanon
-
- ]
- where phase x = set $ \o -> o { optStopAfterPhase = x }
- mode x = set $ \o -> o { optMode = x }
- verbosity mv = case mv of
- Nothing -> set $ \o -> o { optVerbosity = Verbose }
- Just v -> case readMaybe v >>= toEnumBounded of
- Just i -> set $ \o -> o { optVerbosity = i }
- Nothing -> fail $ "Bad verbosity: " ++ show v
- prof x = set $ \o -> o { optProf = x }
- cpu x = set $ \o -> o { optShowCPUTime = x }
- emitGFO x = set $ \o -> o { optEmitGFO = x }
- gfoDir x = set $ \o -> o { optGFODir = Just x }
- outFmt x = readOutputFormat x >>= \f ->
- set $ \o -> o { optOutputFormats = optOutputFormats o ++ [f] }
- sisrFmt x = case x of
- "old" -> set $ \o -> o { optSISR = Just SISR_WD20030401 }
- "1.0" -> set $ \o -> o { optSISR = Just SISR_1_0 }
- _ -> fail $ "Unknown SISR format: " ++ show x
- hsOption x = case lookup x haskellOptionNames of
- Just p -> set $ \o -> o { optHaskellOptions = Set.insert p (optHaskellOptions o) }
- Nothing -> fail $ "Unknown Haskell option: " ++ x
- ++ " Known: " ++ show (map fst haskellOptionNames)
- lexicalCat x = set $ \o -> o { optLexicalCats = foldr Set.insert (optLexicalCats o) (splitBy (==',') x) }
- outFile x = set $ \o -> o { optOutputFile = Just x }
- outDir x = set $ \o -> o { optOutputDir = Just x }
- gfLibPath x = set $ \o -> o { optGFLibPath = Just x }
- recomp x = set $ \o -> o { optRecomp = x }
- printer x = set $ \o -> o { optPrinter = x : optPrinter o }
- prob x = set $ \o -> o { optProb = x }
-
- name x = set $ \o -> o { optName = Just x }
- absName x = set $ \o -> o { optAbsName = Just x }
- cncName x = set $ \o -> o { optCncName = Just x }
- resName x = set $ \o -> o { optResName = Just x }
- addLibDir x = set $ \o -> o { optLibraryPath = x:optLibraryPath o }
- setLibPath x = set $ \o -> o { optLibraryPath = splitInModuleSearchPath x }
- preproc x = set $ \o -> o { optPreprocessors = optPreprocessors o ++ [x] }
- coding x = case lookup x encodings of
- Just c -> set $ \o -> o { optEncoding = c }
- Nothing -> fail $ "Unknown character encoding: " ++ x
- erasing x = set $ \o -> o { optErasing = x }
- buildParser x = do v <- case x of
- "on" -> return BuildParser
- "off" -> return DontBuildParser
- "ondemand" -> return BuildParserOnDemand
- set $ \o -> o { optBuildParser = v }
- startcat x = set $ \o -> o { optStartCat = Just x }
- language x = set $ \o -> o { optSpeechLanguage = Just x }
- lexer x = set $ \o -> o { optLexer = Just x }
- unlexer x = set $ \o -> o { optUnlexer = Just x }
-
- optimize x = case lookup x optimizationPackages of
- Just p -> set $ \o -> o { optOptimizations = p }
- Nothing -> fail $ "Unknown optimization package: " ++ x
-
- toggleOptimize x b = set $ setOptimization' x b
-
- cfgTransform x = let (x', b) = case x of
- 'n':'o':'-':rest -> (rest, False)
- _ -> (x, True)
- in case lookup x' cfgTransformNames of
- Just t -> set $ setCFGTransform' t b
- Nothing -> fail $ "Unknown CFG transformation: " ++ x'
- ++ " Known: " ++ show (map fst cfgTransformNames)
-
- dumpOption s d = Option [] ["dump-"++s] (NoArg (set $ \o -> o { optDump = d:optDump o})) ("Dump output of the " ++ s ++ " phase.")
-
- set = return . Options
-
-outputFormats :: [(String,OutputFormat)]
-outputFormats =
- [("pgf_pretty", FmtPGFPretty),
- ("pmcfg_pretty", FmtPMCFGPretty),
- ("js", FmtJavaScript),
- ("haskell", FmtHaskell),
- ("prolog", FmtProlog),
- ("prolog_abs", FmtProlog_Abs),
- ("bnf", FmtBNF),
- ("ebnf", FmtEBNF),
- ("regular", FmtRegular),
- ("nolr", FmtNoLR),
- ("srgs_xml", FmtSRGS_XML),
- ("srgs_xml_nonrec", FmtSRGS_XML_NonRec),
- ("srgs_abnf", FmtSRGS_ABNF),
- ("srgs_abnf_nonrec", FmtSRGS_ABNF_NonRec),
- ("jsgf", FmtJSGF),
- ("gsl", FmtGSL),
- ("vxml", FmtVoiceXML),
- ("slf", FmtSLF),
- ("regexp", FmtRegExp),
- ("fa", FmtFA)]
-
-instance Show OutputFormat where
- show = lookupShow outputFormats
-
-instance Read OutputFormat where
- readsPrec = lookupReadsPrec outputFormats
-
-optimizationPackages :: [(String, Set Optimization)]
-optimizationPackages =
- [("all", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
- ("values", Set.fromList [OptStem,OptCSE,OptExpand]),
- ("noexpand", Set.fromList [OptStem,OptCSE]),
-
- -- deprecated
- ("all_subs", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
- ("parametrize", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
- ("none", Set.fromList [OptStem,OptCSE,OptExpand])
- ]
-
-cfgTransformNames :: [(String, CFGTransform)]
-cfgTransformNames =
- [("nolr", CFGNoLR),
- ("regular", CFGRegular),
- ("topdown", CFGTopDownFilter),
- ("bottomup", CFGBottomUpFilter),
- ("startcatonly", CFGStartCatOnly),
- ("merge", CFGMergeIdentical),
- ("removecycles", CFGRemoveCycles)]
-
-haskellOptionNames :: [(String, HaskellOption)]
-haskellOptionNames =
- [("noprefix", HaskellNoPrefix),
- ("gadt", HaskellGADT),
- ("lexical", HaskellLexical)]
-
-encodings :: [(String,Encoding)]
-encodings =
- [("utf8", UTF_8),
- ("cp1250", CP_1250),
- ("cp1251", CP_1251),
- ("cp1252", CP_1252),
- ("latin1", ISO_8859_1)
- ]
-
-instance Show Encoding where
- show = lookupShow encodings
-
-lookupShow :: Eq a => [(String,a)] -> a -> String
-lookupShow xs z = fromMaybe "lookupShow" $ lookup z [(y,x) | (x,y) <- xs]
-
-lookupReadsPrec :: [(String,a)] -> Int -> ReadS a
-lookupReadsPrec xs _ s = [(z,rest) | (x,rest) <- lex s, (y,z) <- xs, y == x]
-
-onOff :: Monad m => (Bool -> m a) -> Bool -> ArgDescr (m a)
-onOff f def = OptArg g "[on,off]"
- where g ma = maybe (return def) readOnOff ma >>= f
- readOnOff x = case map toLower x of
- "on" -> return True
- "off" -> return False
- _ -> fail $ "Expected [on,off], got: " ++ show x
-
-readOutputFormat :: Monad m => String -> m OutputFormat
-readOutputFormat s =
- maybe (fail $ "Unknown output format: " ++ show s) return $ lookup s outputFormats
-
--- FIXME: this is a copy of the function in GF.Devel.UseIO.
-splitInModuleSearchPath :: String -> [FilePath]
-splitInModuleSearchPath s = case break isPathSep s of
- (f,_:cs) -> f : splitInModuleSearchPath cs
- (f,_) -> [f]
- where
- isPathSep :: Char -> Bool
- isPathSep c = c == ':' || c == ';'
-
---
--- * Convenience functions for checking options
---
-
-verbAtLeast :: Options -> Verbosity -> Bool
-verbAtLeast opts v = flag optVerbosity opts >= v
-
-dump :: Options -> Dump -> Bool
-dump opts d = flag ((d `elem`) . optDump) opts
-
-cfgTransform :: Options -> CFGTransform -> Bool
-cfgTransform opts t = Set.member t (flag optCFGTransforms opts)
-
-haskellOption :: Options -> HaskellOption -> Bool
-haskellOption opts o = Set.member o (flag optHaskellOptions opts)
-
-isLexicalCat :: Options -> String -> Bool
-isLexicalCat opts c = Set.member c (flag optLexicalCats opts)
-
---
--- * Convenience functions for setting options
---
-
-setOptimization :: Optimization -> Bool -> Options
-setOptimization o b = modifyFlags (setOptimization' o b)
-
-setOptimization' :: Optimization -> Bool -> Flags -> Flags
-setOptimization' o b f = f { optOptimizations = toggle o b (optOptimizations f)}
-
-setCFGTransform :: CFGTransform -> Bool -> Options
-setCFGTransform t b = modifyFlags (setCFGTransform' t b)
-
-setCFGTransform' :: CFGTransform -> Bool -> Flags -> Flags
-setCFGTransform' t b f = f { optCFGTransforms = toggle t b (optCFGTransforms f) }
-
-toggle :: Ord a => a -> Bool -> Set a -> Set a
-toggle o True = Set.insert o
-toggle o False = Set.delete o
-
---
--- * General utilities
---
-
-readMaybe :: Read a => String -> Maybe a
-readMaybe s = case reads s of
- [(x,"")] -> Just x
- _ -> Nothing
-
-toEnumBounded :: (Bounded a, Enum a, Ord a) => Int -> Maybe a
-toEnumBounded i = let mi = minBound
- ma = maxBound `asTypeOf` mi
- in if i >= fromEnum mi && i <= fromEnum ma
- then Just (toEnum i `asTypeOf` mi)
- else Nothing
-
-splitBy :: (a -> Bool) -> [a] -> [[a]]
-splitBy _ [] = []
-splitBy p s = case break p s of
- (l, _ : t@(_ : _)) -> l : splitBy p t
- (l, _) -> [l]
-
-instance Functor OptDescr where
- fmap f (Option cs ss d s) = Option cs ss (fmap f d) s
-
-instance Functor ArgDescr where
- fmap f (NoArg x) = NoArg (f x)
- fmap f (ReqArg g s) = ReqArg (f . g) s
- fmap f (OptArg g s) = OptArg (f . g) s