From b468482c3fc5406de4588463b10fb39e0c5e2528 Mon Sep 17 00:00:00 2001 From: bjorn Date: Tue, 19 Feb 2008 20:59:01 +0000 Subject: Some work on gf3/gfc command-line options. --- src/GF/Devel/GFC/Options.hs | 191 ------------------------------- src/GF/Devel/Options.hs | 269 ++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 269 insertions(+), 191 deletions(-) delete mode 100644 src/GF/Devel/GFC/Options.hs create mode 100644 src/GF/Devel/Options.hs (limited to 'src') diff --git a/src/GF/Devel/GFC/Options.hs b/src/GF/Devel/GFC/Options.hs deleted file mode 100644 index 3d8407cf2..000000000 --- a/src/GF/Devel/GFC/Options.hs +++ /dev/null @@ -1,191 +0,0 @@ -module GF.Devel.GFC.Options - ( - Err(..), -- FIXME: take from somewhere else - - Options(..), - Mode(..), Phase(..), OutputFormat(..), Optimization(..), - parseOptions, helpMessage - ) where - -import Control.Monad -import Data.Maybe -import System.Console.GetOpt -import System.FilePath - - - - - -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.", - ".gfc 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, .gfc or .gfe files.", - "For the other input formats, only one file can be given.", - "", - "Command-line options:"] - - -helpMessage :: String -helpMessage = usageInfo usageHeader optDescr - - -type ErrorMsg = String - -data Err a = Ok a | Errors [ErrorMsg] - deriving (Read, Show, Eq) - -instance Monad Err where - return = Ok - fail e = Errors [e] - Ok a >>= f = f a - Errors s >>= f = Errors s - -errors :: [ErrorMsg] -> Err a -errors = Errors - - -data Mode = Version | Help | Compiler - deriving (Show) - -data Phase = Preproc | Convert | Compile | Link - deriving (Show) - -data OutputFormat = FmtGFCC | FmtJS - deriving (Show) - -data Optimization = None - deriving (Show) - -data Options = Options { - optMode :: Mode, - optStopAfterPhase :: Phase, - optVerbosity :: Int, - optShowCPUTime :: Bool, - optEmitGFC :: Bool, - optGFCDir :: FilePath, - optOutputFormats :: [OutputFormat], - optOutputName :: Maybe String, - optOutputFile :: Maybe FilePath, - optOutputDir :: FilePath, - optLibraryPath :: [FilePath], - optForceRecomp :: Bool, - optPreprocessors :: [String], - optOptimization :: Optimization, - optProb :: Bool, - optStartCategory :: Maybe String, - optSpeechLanguage :: Maybe String - } - deriving (Show) - -defaultOptions :: Options -defaultOptions = Options { - optMode = Compiler, - optStopAfterPhase = Link, - optVerbosity = 1, - optShowCPUTime = False, - optEmitGFC = True, - optGFCDir = ".", - optOutputFormats = [FmtGFCC], - optOutputName = Nothing, - optOutputFile = Nothing, - optOutputDir = ".", - optLibraryPath = [], - optForceRecomp = False, - optPreprocessors = [], - optOptimization = None, - optProb = False, - optStartCategory = Nothing, - optSpeechLanguage = Nothing - } - - - -parseOptions :: [String] -> Err (Options, [FilePath]) -parseOptions args = do case errs of - [] -> do o <- foldM (\o f -> f o) defaultOptions opts - return (o, files) - _ -> errors errs - where (opts, files, errs) = getOpt RequireOrder optDescr args - -optDescr :: [OptDescr (Options -> Err Options)] -optDescr = - [ - 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 .gfc.", - Option ['V'] ["version"] (NoArg (mode Version)) "Display GF version number.", - Option ['?','h'] ["help"] (NoArg (mode Help)) "Show help message.", - Option ['v'] ["verbose"] (OptArg verbosity "N") "Set verbosity (default 1). -v alone is the same as -v 3.", - Option ['q'] ["quiet"] (NoArg (verbosity (Just "0"))) "Quiet, same as -v 0.", - 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-gfc"] (NoArg (emitGFC True)) "Create .gfc files (default).", - Option [] ["no-emit-gfc"] (NoArg (emitGFC False)) "Do not create .gfc files.", - Option [] ["gfc-dir"] (ReqArg gfcDir "DIR") "Directory to put .gfc files in (default = '.').", - Option ['f'] ["output-format"] (ReqArg outFmt "FMT") - (unlines ["Output format. FMT can be one of:", - "Multiple concrete: gfcc (default), gar, js, ...", - "Single concrete only: cf, bnf, lbnf, gsl, srgs_xml, srgs_abnf, ...", - "Abstract only: haskell, ..."]), - Option ['n'] ["output-name"] (ReqArg outName "NAME") - ("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 ['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 .gfc files) in DIR.", - Option ['i'] [] (ReqArg addLibDir "DIR") "Add DIR to the library search path.", - Option [] ["path"] (ReqArg setLibPath "DIR:DIR:...") "Set the library search path.", - Option [] ["src","force-recomp"] (NoArg (forceRecomp True)) - "Always recompile from source, i.e. disable recompilation checking.", - Option [] ["preproc"] (ReqArg preproc "CMD") - (unlines ["Use CMD to preprocess input files.", - "Multiple preprocessors can be used by giving this option multiple times."]), - Option ['O'] [] (OptArg optimize "OPT") - "Perform the named optimization. Just -O means FIXME.", - Option [] ["prob"] (NoArg (prob True)) "Read probabilities from '--# prob' pragmas.", - Option [] ["startcat"] (ReqArg startcat "CAT") "Use CAT as the start category in the generated grammar.", - Option [] ["language"] (ReqArg language "LANG") "Set the speech language flag to LANG in the generated grammar." - ] - where phase x o = return $ o { optStopAfterPhase = x } - mode x o = return $ o { optMode = x } - verbosity mv o = case mv of - Nothing -> return $ o { optVerbosity = 3 } - Just v -> case reads v of - [(i,"")] | i >= 0 -> return $ o { optVerbosity = i } - _ -> fail $ "Bad verbosity: " ++ show v - cpu x o = return $ o { optShowCPUTime = x } - emitGFC x o = return $ o { optEmitGFC = x } - gfcDir x o = return $ o { optGFCDir = x } - outFmt x o = readOutputFormat x >>= \f -> return $ o { optOutputFormats = optOutputFormats o ++ [f] } - outName x o = return $ o { optOutputName = Just x } - outFile x o = return $ o { optOutputFile = Just x } - outDir x o = return $ o { optOutputDir = x } - addLibDir x o = return $ o { optLibraryPath = x:optLibraryPath o } - setLibPath x o = return $ o { optLibraryPath = splitSearchPath x } - forceRecomp x o = return $ o { optForceRecomp = x } - preproc x o = return $ o { optPreprocessors = optPreprocessors o ++ [x] } - optimize x o = return $ o { optOptimization = None } - prob x o = return $ o { optProb = x } - startcat x o = return $ o { optStartCategory = Just x } - language x o = return $ o { optSpeechLanguage = Just x } - - -outputFormats :: [(String,OutputFormat)] -outputFormats = - [("gfcc", FmtGFCC), - ("js", FmtJS)] - -readOutputFormat :: Monad m => String -> m OutputFormat -readOutputFormat s = - maybe (fail $ "Unknown output format: " ++ show s) return $ lookup s outputFormats diff --git a/src/GF/Devel/Options.hs b/src/GF/Devel/Options.hs new file mode 100644 index 000000000..14b598225 --- /dev/null +++ b/src/GF/Devel/Options.hs @@ -0,0 +1,269 @@ +module GF.Devel.Options + ( + Err(..), -- FIXME: take from somewhere else + + Options(..), + Mode(..), Phase(..), OutputFormat(..), Optimization(..), + parseOptions, helpMessage + ) where + +import Control.Monad +import Data.Char (toLower) +import Data.List +import Data.Maybe +import System.Console.GetOpt +import System.FilePath + + + + + +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.", + ".gfc 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, .gfc or .gfe files.", + "For the other input formats, only one file can be given.", + "", + "Command-line options:"] + + +helpMessage :: String +helpMessage = usageInfo usageHeader optDescr + +-- Error monad + +type ErrorMsg = String + +data Err a = Ok a | Errors [ErrorMsg] + deriving (Read, Show, Eq) + +instance Monad Err where + return = Ok + fail e = Errors [e] + Ok a >>= f = f a + Errors s >>= f = Errors s + +errors :: [ErrorMsg] -> Err a +errors = Errors + +-- Types + +data Mode = Version | Help | Interactive | Compiler + deriving (Show,Eq,Ord) + +data Phase = Preproc | Convert | Compile | Link + deriving (Show,Eq,Ord) + +data Encoding = UTF_8 | ISO_8859_1 + deriving (Show,Eq,Ord) + +data OutputFormat = FmtGFCC | FmtJS + deriving (Show,Eq,Ord) + +data Optimization = OptStem | OptCSE + deriving (Show,Eq,Ord) + +data Warning = WarnMissingLincat + deriving (Show,Eq,Ord) + +data Dump = DumpRebuild | DumpExtend | DumpRename | DumpTypecheck | DumpRefresh | DumpOptimize | DumpCanon + deriving (Show,Eq,Ord) + +data ModuleOptions = ModuleOptions { + optPreprocessors :: [String], + optEncoding :: Encoding, + optOptimizations :: [Optimization], + optLibraryPath :: [FilePath], + optSpeechLanguage :: Maybe String, + optBuildParser :: Bool, + optWarnings :: [Warning], + optDump :: [Dump] + } + deriving (Show) + +data Options = Options { + optMode :: Mode, + optStopAfterPhase :: Phase, + optVerbosity :: Int, + optShowCPUTime :: Bool, + optEmitGFO :: Bool, + optGFODir :: FilePath, + optOutputFormats :: [OutputFormat], + optOutputName :: Maybe String, + optOutputFile :: Maybe FilePath, + optOutputDir :: FilePath, + optForceRecomp :: Bool, + optProb :: Bool, + optStartCategory :: Maybe String, + optModuleOptions :: ModuleOptions + } + deriving (Show) + +-- Option parsing + +parseOptions :: [String] -> Err (Options, [FilePath]) +parseOptions args = case errs of + [] -> do o <- foldM (\o f -> f o) defaultOptions opts + return (o, files) + _ -> errors errs + where (opts, files, errs) = getOpt RequireOrder optDescr args + +parseModuleFlags :: Options -> [(String,String)] -> Err ModuleOptions +parseModuleFlags opts flags = foldr setOpt (optModuleOptions opts) moduleOptDescr + where + setOpt (Option _ ss arg _) d + | null values = d + | otherwise = case arg of + NoArg a -> + ReqArg (String -> a) _ -> +OptArg (Maybe String -> a) String +last values + where values = [v | (k,v) <- flags, k `elem` ss ] + +-- Default options + +defaultModuleOptions :: ModuleOptions +defaultModuleOptions = ModuleOptions { + optPreprocessors = [], + optEncoding = ISO_8859_1, + optOptimizations = [OptStem,OptCSE], + optLibraryPath = [], + optSpeechLanguage = Nothing, + optBuildParser = True, + optWarnings = [], + optDump = [] + } + +defaultOptions :: Options +defaultOptions = Options { + optMode = Interactive, + optStopAfterPhase = Link, + optVerbosity = 1, + optShowCPUTime = False, + optEmitGFO = True, + optGFODir = ".", + optOutputFormats = [FmtGFCC], + optOutputName = Nothing, + optOutputFile = Nothing, + optOutputDir = ".", + optForceRecomp = False, + optProb = False, + optStartCategory = Nothing, + optModuleOptions = defaultModuleOptions + } + +-- Option descriptions + +moduleOptDescr :: [OptDescr (ModuleOptions -> Err ModuleOptions)] +moduleOptDescr = + [ + 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 [] ["stem"] (onOff (optimize OptStem) True) "Perform stem-suffix analysis (default on).", + Option [] ["cse"] (onOff (optimize OptCSE) True) "Perform common sub-expression elimination (default on).", + Option [] ["parser"] (onOff parser True) "Build parser (default on).", + Option [] ["language"] (ReqArg language "LANG") "Set the speech language flag to LANG in the generated grammar." + ] + where + addLibDir x o = return $ o { optLibraryPath = x:optLibraryPath o } + setLibPath x o = return $ o { optLibraryPath = splitSearchPath x } + preproc x o = return $ o { optPreprocessors = optPreprocessors o ++ [x] } + optimize x b o = return $ o { optOptimizations = (if b then (x:) else delete x) (optOptimizations o) } + parser x o = return $ o { optBuildParser = x } + language x o = return $ o { optSpeechLanguage = Just x } + +optDescr :: [OptDescr (Options -> Err Options)] +optDescr = + [ + 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.", + Option ['V'] ["version"] (NoArg (mode Version)) "Display GF version number.", + Option ['?','h'] ["help"] (NoArg (mode Help)) "Show help message.", + Option ['v'] ["verbose"] (OptArg verbosity "N") "Set verbosity (default 1). -v alone is the same as -v 3.", + Option ['q'] ["quiet"] (NoArg (verbosity (Just "0"))) "Quiet, same as -v 0.", + Option [] ["batch"] (NoArg (mode Compiler)) "Run in batch compiler mode.", + Option [] ["interactive"] (NoArg (mode Interactive)) "Run in interactive mode (default).", + 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: gfcc (default), gar, js, ...", + "Single concrete only: cf, bnf, lbnf, gsl, srgs_xml, srgs_abnf, ...", + "Abstract only: haskell, ..."]), + Option ['n'] ["output-name"] (ReqArg outName "NAME") + ("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 ['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 .gfc files) in DIR.", + Option [] ["src","force-recomp"] (NoArg (forceRecomp True)) + "Always recompile from source, i.e. disable recompilation checking.", + Option [] ["prob"] (NoArg (prob True)) "Read probabilities from '--# prob' pragmas.", + Option [] ["startcat"] (ReqArg startcat "CAT") "Use CAT as the start category in the generated grammar." + ] ++ map (fmap onModuleOptions) moduleOptDescr + where phase x o = return $ o { optStopAfterPhase = x } + mode x o = return $ o { optMode = x } + verbosity mv o = case mv of + Nothing -> return $ o { optVerbosity = 3 } + Just v -> case reads v of + [(i,"")] | i >= 0 -> return $ o { optVerbosity = i } + _ -> fail $ "Bad verbosity: " ++ show v + cpu x o = return $ o { optShowCPUTime = x } + emitGFO x o = return $ o { optEmitGFO = x } + gfoDir x o = return $ o { optGFODir = x } + outFmt x o = readOutputFormat x >>= \f -> + return $ o { optOutputFormats = optOutputFormats o ++ [f] } + outName x o = return $ o { optOutputName = Just x } + outFile x o = return $ o { optOutputFile = Just x } + outDir x o = return $ o { optOutputDir = x } + forceRecomp x o = return $ o { optForceRecomp = x } + prob x o = return $ o { optProb = x } + startcat x o = return $ o { optStartCategory = Just x } + +onModuleOptions :: Monad m => (ModuleOptions -> m ModuleOptions) -> Options -> m Options +onModuleOptions f o = do mo' <- f (optModuleOptions o) + return $ o { optModuleOptions = mo' } + +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 + +outputFormats :: [(String,OutputFormat)] +outputFormats = + [("gfcc", FmtGFCC), + ("js", FmtJS)] + +onOff :: Monad m => (Bool -> (a -> m a)) -> Bool -> ArgDescr (a -> m a) +onOff f def = OptArg g "[on,off]" + where g ma x = do b <- maybe (return def) readOnOff ma + f b x + 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 -- cgit v1.2.3