Some work on gf3/gfc command-line options.

1 files changed, 269 insertions, 0 deletions

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