From b468482c3fc5406de4588463b10fb39e0c5e2528 Mon Sep 17 00:00:00 2001 From: bjorn Date: Tue, 19 Feb 2008 20:59:01 +0000 Subject: [PATCH] Some work on gf3/gfc command-line options. --- src/GF/Devel/{GFC => }/Options.hs | 220 ++++++++++++++++++++---------- 1 file changed, 149 insertions(+), 71 deletions(-) rename src/GF/Devel/{GFC => }/Options.hs (51%) diff --git a/src/GF/Devel/GFC/Options.hs b/src/GF/Devel/Options.hs similarity index 51% rename from src/GF/Devel/GFC/Options.hs rename to src/GF/Devel/Options.hs index 3d8407cf2..14b598225 100644 --- a/src/GF/Devel/GFC/Options.hs +++ b/src/GF/Devel/Options.hs @@ -1,4 +1,4 @@ -module GF.Devel.GFC.Options +module GF.Devel.Options ( Err(..), -- FIXME: take from somewhere else @@ -8,6 +8,8 @@ module GF.Devel.GFC.Options ) where import Control.Monad +import Data.Char (toLower) +import Data.List import Data.Maybe import System.Console.GetOpt import System.FilePath @@ -37,6 +39,7 @@ usageHeader = unlines helpMessage :: String helpMessage = usageInfo usageHeader optDescr +-- Error monad type ErrorMsg = String @@ -52,85 +55,152 @@ instance Monad Err where errors :: [ErrorMsg] -> Err a errors = Errors +-- Types -data Mode = Version | Help | Compiler - deriving (Show) +data Mode = Version | Help | Interactive | Compiler + deriving (Show,Eq,Ord) data Phase = Preproc | Convert | Compile | Link - deriving (Show) + deriving (Show,Eq,Ord) + +data Encoding = UTF_8 | ISO_8859_1 + deriving (Show,Eq,Ord) data OutputFormat = FmtGFCC | FmtJS - deriving (Show) + deriving (Show,Eq,Ord) -data Optimization = None +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, - 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 - } + 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 = 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 - } + 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 - -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 +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 .gfc.", + 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-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 [] ["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, ...", @@ -144,19 +214,11 @@ optDescr = "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." - ] + 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 @@ -165,27 +227,43 @@ optDescr = [(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] } + 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 } - 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 } +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