Some work on gf3/gfc command-line options.

1 files changed, 149 insertions, 71 deletions

diff --git a/src/GF/Devel/GFC/Options.hs b/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 = OptStem | OptCSE
+  deriving (Show,Eq,Ord)
+
+data Warning = WarnMissingLincat
+  deriving (Show,Eq,Ord)
 
-data Optimization = None
+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