summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorbjorn <bjorn@bringert.net>2008-05-28 15:10:36 +0000
committerbjorn <bjorn@bringert.net>2008-05-28 15:10:36 +0000
commit3fd1f5652a3af22e90a040a821d244a91a3553a0 (patch)
tree15225df670e1fb1c55f4a9eb1ca45eae7952061f
parent1bc74749aa7a9ec6ecfced68c0cdf38f43c7f9ef (diff)
Switch to new options handling.
This changes lots of stuff, let me know if it broke anything. Comments: - We use a local hacked version of GetOpt that allows long forms of commands to start with a single dash. This breaks other parts of GetOpt. For example, arguments to short options now require a =, and does not allo pace after the option character. - The new command parsing is currently only used for the program command line, pragmas and the arguments for the 'i' shell command. - I made a quick hack for the options for showTerm, which currently makes it impossible to use the print style flags for cc. This will be replaced by a facility for parsing command-specific options. - The verbosity handling is broken in some places. I will fix that in a later patch.
Diffstat
-rw-r--r--src-3.0/GF.hs28
-rw-r--r--src-3.0/GF/Command/Commands.hs2
-rw-r--r--src-3.0/GF/Compile.hs81
-rw-r--r--src-3.0/GF/Compile/BackOpt.hs50
-rw-r--r--src-3.0/GF/Compile/GetGrammar.hs18
-rw-r--r--src-3.0/GF/Compile/GrammarToGFCC.hs21
-rw-r--r--src-3.0/GF/Compile/Optimize.hs31
-rw-r--r--src-3.0/GF/Compile/ReadFiles.hs20
-rw-r--r--src-3.0/GF/Compile/Rebuild.hs3
-rw-r--r--src-3.0/GF/GFCC/OptimizeGFCC.hs10
-rw-r--r--src-3.0/GF/GFCC/PrintGFCC.hs13
-rw-r--r--src-3.0/GF/Grammar/API.hs21
-rw-r--r--src-3.0/GF/Grammar/PrGrammar.hs2
-rw-r--r--src-3.0/GF/Infra/GetOpt.hs381
-rw-r--r--src-3.0/GF/Infra/Modules.hs16
-rw-r--r--src-3.0/GF/Infra/Option.hs797
-rw-r--r--src-3.0/GF/Infra/UseIO.hs27
-rw-r--r--src-3.0/GF/Source/GrammarToSource.hs10
-rw-r--r--src-3.0/GF/Source/SourceToGrammar.hs32
-rw-r--r--src-3.0/GFC.hs80
-rw-r--r--src-3.0/GFI.hs37
21 files changed, 1060 insertions, 620 deletions
diff --git a/src-3.0/GF.hs b/src-3.0/GF.hs
index 038d034d6..b3c971096 100644
--- a/src-3.0/GF.hs
+++ b/src-3.0/GF.hs
@@ -2,12 +2,30 @@ module Main where
import GFC
import GFI
+import GF.Data.ErrM
+import GF.Infra.Option
+import GF.Infra.UseIO
+import Paths_gf
+import Data.Version
import System.Environment (getArgs)
+import System.Exit
+import System.IO
main :: IO ()
-main = do
- args <- getArgs
- case args of
- "--batch":args -> mainGFC args
- _ -> mainGFI args
+main =
+ do args <- getArgs
+ case parseOptions args of
+ Ok (opts,files) -> mainOpts opts files
+ Bad err -> do hPutStrLn stderr err
+ hPutStrLn stderr "You may want to try --help."
+ exitFailure
+
+mainOpts :: Options -> [FilePath] -> IO ()
+mainOpts opts files =
+ case flag optMode opts of
+ ModeVersion -> putStrLn $ "Grammatical Framework (GF) version " ++ showVersion version
+ ModeHelp -> putStrLn helpMessage
+ ModeInteractive -> mainGFI opts files
+ ModeCompiler -> dieIOE (mainGFC opts files)
+
diff --git a/src-3.0/GF/Command/Commands.hs b/src-3.0/GF/Command/Commands.hs
index ef10220a8..8068d6c0e 100644
--- a/src-3.0/GF/Command/Commands.hs
+++ b/src-3.0/GF/Command/Commands.hs
@@ -156,5 +156,5 @@ allCommands mgr = Map.fromAscList [
prGrammar opts = case valIdOpts "printer" "" opts of
"cats" -> unwords $ categories mgr
- v -> prGFCC v gr
+ v -> prGFCC (read v) gr
diff --git a/src-3.0/GF/Compile.hs b/src-3.0/GF/Compile.hs
index 7e1ce0356..72b13998e 100644
--- a/src-3.0/GF/Compile.hs
+++ b/src-3.0/GF/Compile.hs
@@ -1,4 +1,4 @@
-module GF.Compile (batchCompile, compileToGFCC) where
+module GF.Compile (batchCompile, link, compileToGFCC) where
-- the main compiler passes
import GF.Compile.GetGrammar
@@ -44,25 +44,34 @@ compileToGFCC :: Options -> [FilePath] -> IOE GFCC
compileToGFCC opts fs =
do gr <- batchCompile opts fs
let name = justModuleName (last fs)
- gc1 <- putPointE opts "linking ... " $
- let (abs,gc0) = mkCanon2gfcc opts name gr
+ link opts name gr
+
+link :: Options -> String -> SourceGrammar -> IOE GFCC
+link opts cnc gr =
+ do gc1 <- putPointE opts "linking ... " $
+ let (abs,gc0) = mkCanon2gfcc opts cnc gr
in ioeIO $ checkGFCCio gc0
- let opt = if oElem (iOpt "noopt") opts then id else optGFCC
- par = if oElem (iOpt "noparse") opts then id else addParsers
- return (par (opt gc1))
+ return $ buildParser opts $ optimize opts gc1
+
+optimize :: Options -> GFCC -> GFCC
+optimize opts = cse . suf
+ where os = moduleFlag optOptimizations opts
+ cse = if OptCSE `elem` os then cseOptimize else id
+ suf = if OptStem `elem` os then suffixOptimize else id
+buildParser :: Options -> GFCC -> GFCC
+buildParser opts =
+ if moduleFlag optBuildParser opts then id else addParsers
batchCompile :: Options -> [FilePath] -> IOE SourceGrammar
batchCompile opts files = do
- (_,gr,_) <- foldM (compileModule defOpts) emptyCompileEnv files
+ (_,gr,_) <- foldM (compileModule opts) emptyCompileEnv files
return gr
- where
- defOpts = addOptions opts (options [emitCode])
-- to output an intermediate stage
-intermOut :: Options -> Option -> String -> IOE ()
-intermOut opts opt s = if oElem opt opts then
- ioeIO (putStrLn ("\n\n--#" +++ prOpt opt) >> putStrLn s)
+intermOut :: Options -> Dump -> String -> IOE ()
+intermOut opts d s = if dump opts d then
+ ioeIO (putStrLn ("\n\n--#" +++ show d) >> putStrLn s)
else return ()
@@ -74,38 +83,31 @@ type CompileEnv = (Int,SourceGrammar,ModEnv)
-- As for path: if it is read from file, the file path is prepended to each name.
-- If from command line, it is used as it is.
-compileModule :: Options -> CompileEnv -> FilePath -> IOE CompileEnv
+compileModule :: Options -- ^ Options from program command line and shell command.
+ -> CompileEnv -> FilePath -> IOE CompileEnv
compileModule opts1 env file = do
- opts0 <- ioeIO $ getOptionsFromFile file
- let useFileOpt = maybe False (const True) $ getOptVal opts0 pathList
- let useLineOpt = maybe False (const True) $ getOptVal opts1 pathList
- let opts = addOptions opts1 opts0
- let fpath = dropFileName file
- ps0 <- ioeIO $ pathListOpts opts fpath
-
- let ps1 = if (useFileOpt && not useLineOpt)
- then (ps0 ++ map (combine fpath) ps0)
- else ps0
- ps <- ioeIO $ extendPathEnv ps1
- let ioeIOIf = if oElem beVerbose opts then ioeIO else (const (return ()))
- ioeIOIf $ putStrLn $ "module search path:" +++ show ps ----
+ opts0 <- getOptionsFromFile file
+ let opts = addOptions opts0 opts1
+ let fdir = dropFileName file
+ let ps0 = moduleFlag optLibraryPath opts
+ ps2 <- ioeIO $ extendPathEnv $ fdir : ps0
+ let ps = ps2 ++ map (fdir </>) ps0
+ ioeIO $ putIfVerb opts $ "module search path:" +++ show ps ----
let (_,sgr,rfs) = env
- let file' = if useFileOpt then takeFileName file else file -- to find file itself
- files <- getAllFiles opts ps rfs file'
- ioeIOIf $ putStrLn $ "files to read:" +++ show files ----
+ files <- getAllFiles opts ps rfs file
+ ioeIO $ putIfVerb opts $ "files to read:" +++ show files ----
let names = map justModuleName files
- ioeIOIf $ putStrLn $ "modules to include:" +++ show names ----
+ ioeIO $ putIfVerb opts $ "modules to include:" +++ show names ----
foldM (compileOne opts) (0,sgr,rfs) files
-
compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv
compileOne opts env@(_,srcgr,_) file = do
let putp s = putPointE opts s
let putpp = putPointEsil opts
let putpOpt v m act
- | oElem beVerbose opts = putp v act
- | oElem beSilent opts = putpp v act
+ | beVerbose opts = putp v act
+ | beSilent opts = putpp v act
| otherwise = ioeIO (putStrFlush m) >> act
let gf = takeExtensions file
@@ -155,25 +157,25 @@ compileSourceModule opts env@(k,gr,_) mo@(i,mi) = do
mos = modules gr
mo1 <- ioeErr $ rebuildModule mos mo
- intermOut opts (iOpt "show_rebuild") (prModule mo1)
+ intermOut opts DumpRebuild (prModule mo1)
mo1b <- ioeErr $ extendModule mos mo1
- intermOut opts (iOpt "show_extend") (prModule mo1b)
+ intermOut opts DumpExtend (prModule mo1b)
case mo1b of
(_,ModMod n) | not (isCompleteModule n) -> do
return (k,mo1b) -- refresh would fail, since not renamed
_ -> do
mo2:_ <- putpp " renaming " $ ioeErr $ renameModule mos mo1b
- intermOut opts (iOpt "show_rename") (prModule mo2)
+ intermOut opts DumpRename (prModule mo2)
(mo3:_,warnings) <- putpp " type checking" $ ioeErr $ showCheckModule mos mo2
if null warnings then return () else putp warnings $ return ()
- intermOut opts (iOpt "show_typecheck") (prModule mo3)
+ intermOut opts DumpTypeCheck (prModule mo3)
(k',mo3r:_) <- putpp " refreshing " $ ioeErr $ refreshModule (k,mos) mo3
- intermOut opts (iOpt "show_refresh") (prModule mo3r)
+ intermOut opts DumpRefresh (prModule mo3r)
let eenv = () --- emptyEEnv
(mo4,eenv') <-
@@ -197,9 +199,6 @@ generateModuleCode opts file minfo = do
-- auxiliaries
-pathListOpts :: Options -> FileName -> IO [InitPath]
-pathListOpts opts file = return $ maybe [file] splitInModuleSearchPath $ getOptVal opts pathList
-
reverseModules (MGrammar ms) = MGrammar $ reverse ms
emptyCompileEnv :: CompileEnv
diff --git a/src-3.0/GF/Compile/BackOpt.hs b/src-3.0/GF/Compile/BackOpt.hs
index 0f74bbf92..0043d02d8 100644
--- a/src-3.0/GF/Compile/BackOpt.hs
+++ b/src-3.0/GF/Compile/BackOpt.hs
@@ -15,10 +15,11 @@
-- following advice of Josef Svenningsson
-----------------------------------------------------------------------------
-module GF.Compile.BackOpt (shareModule, OptSpec, shareOpt, paramOpt, valOpt, allOpt) where
+module GF.Compile.BackOpt (shareModule, OptSpec) where
import GF.Grammar.Grammar
import GF.Infra.Ident
+import GF.Infra.Option
import qualified GF.Grammar.Macros as C
import GF.Grammar.PrGrammar (prt)
import GF.Data.Operations
@@ -26,25 +27,7 @@ import Data.List
import qualified GF.Infra.Modules as M
import qualified Data.ByteString.Char8 as BS
-type OptSpec = [Integer] ---
-
-doOptFactor :: OptSpec -> Bool
-doOptFactor opt = elem 2 opt
-
-doOptValues :: OptSpec -> Bool
-doOptValues opt = elem 3 opt
-
-shareOpt :: OptSpec
-shareOpt = []
-
-paramOpt :: OptSpec
-paramOpt = [2]
-
-valOpt :: OptSpec
-valOpt = [3]
-
-allOpt :: OptSpec
-allOpt = [2,3]
+type OptSpec = [Optimization]
shareModule :: OptSpec -> (Ident, SourceModInfo) -> (Ident, SourceModInfo)
shareModule opt (i,m) = case m of
@@ -59,31 +42,8 @@ shareInfo _ i = i
-- the function putting together optimizations
shareOptim :: OptSpec -> Ident -> Term -> Term
-shareOptim opt c
- | doOptFactor opt && doOptValues opt = values . factor c 0
- | doOptFactor opt = share . factor c 0
- | doOptValues opt = values
- | otherwise = share
-
--- we need no counter to create new variable names, since variables are
--- local to tables (only true in GFC) ---
-
-share :: Term -> Term
-share t = case t of
- T ty@(TComp _) cs -> shareT ty [(p, share v) | (p, v) <- cs]
- _ -> C.composSafeOp share t
-
- where
- shareT ty = finalize ty . groupC . sortC
-
- sortC :: [(Patt,Term)] -> [(Patt,Term)]
- sortC = sortBy $ \a b -> compare (snd a) (snd b)
-
- groupC :: [(Patt,Term)] -> [[(Patt,Term)]]
- groupC = groupBy $ \a b -> snd a == snd b
-
- finalize :: TInfo -> [[(Patt,Term)]] -> Term
- finalize ty css = TSh ty [(map fst ps, t) | ps@((_,t):_) <- css]
+shareOptim opt c = (if OptValues `elem` opt then values else id)
+ . (if OptParametrize `elem` opt then factor c 0 else id)
-- do even more: factor parametric branches
diff --git a/src-3.0/GF/Compile/GetGrammar.hs b/src-3.0/GF/Compile/GetGrammar.hs
index 4637da09a..a8eb8b749 100644
--- a/src-3.0/GF/Compile/GetGrammar.hs
+++ b/src-3.0/GF/Compile/GetGrammar.hs
@@ -39,15 +39,17 @@ import System.Cmd (system)
getSourceModule :: Options -> FilePath -> IOE SourceModule
getSourceModule opts file0 = do
- file <- case getOptVal opts usePreprocessor of
- Just p -> do
- let tmp = "_gf_preproc.tmp"
- cmd = p +++ file0 ++ ">" ++ tmp
- ioeIO $ system cmd
- -- ioeIO $ putStrLn $ "preproc" +++ cmd
- return tmp
- _ -> return file0
+ file <- foldM runPreprocessor file0 (moduleFlag optPreprocessors opts)
string <- readFileIOE file
let tokens = myLexer string
mo1 <- ioeErr $ pModDef tokens
ioeErr $ transModDef mo1
+
+-- FIXME: should use System.IO.openTempFile
+runPreprocessor :: FilePath -> String -> IOE FilePath
+runPreprocessor file0 p =
+ do let tmp = "_gf_preproc.tmp"
+ cmd = p +++ file0 ++ ">" ++ tmp
+ ioeIO $ system cmd
+ -- ioeIO $ putStrLn $ "preproc" +++ cmd
+ return tmp
diff --git a/src-3.0/GF/Compile/GrammarToGFCC.hs b/src-3.0/GF/Compile/GrammarToGFCC.hs
index c54e45c9d..4877ff556 100644
--- a/src-3.0/GF/Compile/GrammarToGFCC.hs
+++ b/src-3.0/GF/Compile/GrammarToGFCC.hs
@@ -61,16 +61,15 @@ addParsers gfcc = gfcc { D.concretes = Map.map conv (D.concretes gfcc) }
canon2gfcc :: Options -> (Ident -> Ident -> C.Term) -> SourceGrammar -> D.GFCC
canon2gfcc opts pars cgr@(M.MGrammar ((a,M.ModMod abm):cms)) =
- (if (oElem (iOpt "show_canon") opts) then trace (prGrammar cgr) else id) $
+ (if dump opts DumpCanon then trace (prGrammar cgr) else id) $
D.GFCC an cns gflags abs cncs
where
-- abstract
an = (i2i a)
cns = map (i2i . fst) cms
abs = D.Abstr aflags funs cats catfuns
- gflags = Map.fromList [(mkCId fg,x) | Just x <- [getOptVal opts (aOpt fg)]]
- where fg = "firstlang"
- aflags = Map.fromList [(mkCId f,x) | Opt (f,[x]) <- M.flags abm]
+ gflags = Map.empty
+ aflags = Map.fromList [(mkCId f,x) | (f,x) <- moduleOptionsGFO (M.flags abm)]
mkDef pty = case pty of
Yes t -> mkExp t
_ -> CM.primNotion
@@ -90,9 +89,9 @@ canon2gfcc opts pars cgr@(M.MGrammar ((a,M.ModMod abm):cms)) =
(lang,D.Concr flags lins opers lincats lindefs printnames params fcfg)
where
js = tree2list (M.jments mo)
- flags = Map.fromList [(mkCId f,x) | Opt (f,[x]) <- M.flags mo]
+ flags = Map.fromList [(mkCId f,x) | (f,x) <- moduleOptionsGFO (M.flags mo)]
opers = Map.fromAscList [] -- opers will be created as optimization
- utf = if elem (Opt ("coding",["utf8"])) (M.flags mo)
+ utf = if moduleFlag optEncoding (moduleOptions (M.flags mo)) == UTF_8
then D.convertStringsInTerm decodeUTF8 else id
lins = Map.fromAscList
[(i2i f, utf (mkTerm tr)) | (f,CncFun _ (Yes tr) _) <- js]
@@ -227,14 +226,15 @@ reorder abs cg = M.MGrammar $
predefADefs ++ Look.allOrigInfos cg abs
predefADefs =
[(c, AbsCat (Yes []) Nope) | c <- [cFloat,cInt,cString]]
- aflags = nubFlags $
- concat [M.flags mo | (_,mo) <- M.allModMod cg, M.isModAbs mo]
+ aflags =
+ concatModuleOptions [M.flags mo | (_,mo) <- M.allModMod cg, M.isModAbs mo]
cncs = sortIds [(lang, concr lang) | lang <- M.allConcretes cg abs]
- concr la = (nubFlags flags,
+ concr la = (flags,
sortIds (predefCDefs ++ jments)) where
jments = Look.allOrigInfos cg la
- flags = concat [M.flags mo |
+ flags = concatModuleOptions
+ [M.flags mo |
(i,mo) <- mos, M.isModCnc mo,
Just r <- [lookup i (M.allExtendSpecs cg la)]]
@@ -242,7 +242,6 @@ reorder abs cg = M.MGrammar $
[(c, CncCat (Yes GM.defLinType) Nope Nope) | c <- [cInt,cFloat,cString]]
sortIds = sortBy (\ (f,_) (g,_) -> compare f g)
- nubFlags = nubBy (\ (Opt (f,_)) (Opt (g,_)) -> f == g)
-- one grammar per language - needed for symtab generation
diff --git a/src-3.0/GF/Compile/Optimize.hs b/src-3.0/GF/Compile/Optimize.hs
index 6da561029..6dd4c9af6 100644
--- a/src-3.0/GF/Compile/Optimize.hs
+++ b/src-3.0/GF/Compile/Optimize.hs
@@ -43,9 +43,6 @@ import Debug.Trace
prtIf :: (Print a) => Bool -> a -> a
prtIf b t = if b then trace (" " ++ prt t) t else t
--- experimental evaluation, option to import
-oEval = iOpt "eval"
-
-- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005.
type EEnv = () --- not used
@@ -55,28 +52,21 @@ optimizeModule :: Options -> ([(Ident,SourceModInfo)],EEnv) ->
(Ident,SourceModInfo) -> Err ((Ident,SourceModInfo),EEnv)
optimizeModule opts mse@(ms,eenv) mo@(_,mi) = case mi of
ModMod m0@(Module mt st fs me ops js) |
- st == MSComplete && isModRes m0 && not (oElem oEval oopts)-> do
+ st == MSComplete && isModRes m0 -> do
(mo1,_) <- evalModule oopts mse mo
- let
- mo2 = case optim of
- "parametrize" -> shareModule paramOpt mo1 -- parametrization and sharing
- "values" -> shareModule valOpt mo1 -- tables as courses-of-values
- "share" -> shareModule shareOpt mo1 -- sharing of branches
- "all" -> shareModule allOpt mo1 -- first parametrize then values
- "none" -> mo1 -- no optimization
- _ -> mo1 -- none; default for src
+ let mo2 = shareModule optim mo1
return (mo2,eenv)
_ -> evalModule oopts mse mo
where
- oopts = addOptions opts (iOpts (flagsModule mo))
- optim = maybe "all" id $ getOptVal oopts useOptimizer
+ oopts = addOptions opts (moduleOptions (flagsModule mo))
+ optim = moduleFlag optOptimizations oopts
evalModule :: Options -> ([(Ident,SourceModInfo)],EEnv) -> (Ident,SourceModInfo) ->
Err ((Ident,SourceModInfo),EEnv)
evalModule oopts (ms,eenv) mo@(name,mod) = case mod of
ModMod m0@(Module mt st fs me ops js) | st == MSComplete -> case mt of
- _ | isModRes m0 && not (oElem oEval oopts) -> do
+ _ | isModRes m0 -> do
let deps = allOperDependencies name js
ids <- topoSortOpers deps
MGrammar (mod' : _) <- foldM evalOp gr ids
@@ -112,17 +102,15 @@ evalResInfo oopts gr (c,info) = case info of
where
comp = if optres then computeConcrete gr else computeConcreteRec gr
eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":")
- optim = maybe "all" id $ getOptVal oopts useOptimizer
- optres = case optim of
- "noexpand" -> False
- _ -> True
+ optim = moduleFlag optOptimizations oopts
+ optres = OptExpand `elem` optim
evalCncInfo ::
Options -> SourceGrammar -> Ident -> Ident -> (Ident,Info) -> Err (Ident,Info)
evalCncInfo opts gr cnc abs (c,info) = do
- seq (prtIf (oElem beVerbose opts) c) $ return ()
+ seq (prtIf (beVerbose opts) c) $ return ()
errIn ("optimizing" +++ prt c) $ case info of
@@ -143,7 +131,7 @@ evalCncInfo opts gr cnc abs (c,info) = do
CncFun (mt@(Just (_,ty@(cont,val)))) pde ppr ->
eIn ("linearization in type" +++ prt (mkProd (cont,val,[])) ++++ "of function") $ do
pde' <- case pde of
- Yes de | notNewEval -> do
+ Yes de -> do
liftM yes $ pEval ty de
_ -> return pde
@@ -154,7 +142,6 @@ evalCncInfo opts gr cnc abs (c,info) = do
where
pEval = partEval opts gr
eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":")
- notNewEval = not (oElem oEval opts)
-- | the main function for compiling linearizations
partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Err Term
diff --git a/src-3.0/GF/Compile/ReadFiles.hs b/src-3.0/GF/Compile/ReadFiles.hs
index f1f94c105..cd2faec15 100644
--- a/src-3.0/GF/Compile/ReadFiles.hs
+++ b/src-3.0/GF/Compile/ReadFiles.hs
@@ -19,8 +19,9 @@
-----------------------------------------------------------------------------
module GF.Compile.ReadFiles
- ( getAllFiles,ModName,ModEnv,getOptionsFromFile,importsOfModule,
- gfoFile,gfFile,isGFO ) where
+ ( getAllFiles,ModName,ModEnv,importsOfModule,
+ gfoFile,gfFile,isGFO,
+ getOptionsFromFile) where
import GF.Infra.UseIO
import GF.Infra.Option
@@ -48,9 +49,7 @@ getAllFiles :: Options -> [InitPath] -> ModEnv -> FileName -> IOE [FullPath]
getAllFiles opts ps env file = do
-- read module headers from all files recursively
ds <- liftM reverse $ get [] [] (justModuleName file)
- if oElem beVerbose opts
- then ioeIO $ putStrLn $ "all modules:" +++ show [name | (name,_,_,_,_) <- ds]
- else return ()
+ ioeIO $ putIfVerb opts $ "all modules:" +++ show [name | (name,_,_,_,_) <- ds]
return $ paths ds
where
-- construct list of paths to read
@@ -135,8 +134,8 @@ selectFormat opts mtenv mtgf mtgfo =
(_,_, Nothing) -> (CSRead,Nothing) -- source does not exist
_ -> (CSComp,Nothing)
where
- fromComp = oElem isCompiled opts -- i -gfo
- fromSrc = oElem fromSource opts
+ fromComp = flag optRecomp opts == NeverRecomp
+ fromSrc = flag optRecomp opts == AlwaysRecomp
-- internal module dep information
@@ -188,8 +187,9 @@ importsOfModule (MModule _ typ body) = modType typ (modBody body [])
-- | options can be passed to the compiler by comments in @--#@, in the main file
-getOptionsFromFile :: FilePath -> IO Options
+getOptionsFromFile :: FilePath -> IOE Options
getOptionsFromFile file = do
- s <- readFileIfStrict file
+ s <- ioeIO $ readFileIfStrict file
let ls = filter (BS.isPrefixOf (BS.pack "--#")) $ BS.lines s
- return $ fst $ getOptions "-" $ map (BS.unpack . BS.unwords . BS.words . BS.drop 3) ls
+ fs = map (BS.unpack . BS.unwords . BS.words . BS.drop 3) ls
+ ioeErr $ liftM moduleOptions $ parseModuleOptions fs
diff --git a/src-3.0/GF/Compile/Rebuild.hs b/src-3.0/GF/Compile/Rebuild.hs
index 152983b96..b24373ba4 100644
--- a/src-3.0/GF/Compile/Rebuild.hs
+++ b/src-3.0/GF/Compile/Rebuild.hs
@@ -23,6 +23,7 @@ import GF.Grammar.Macros
import GF.Infra.Ident
import GF.Infra.Modules
+import GF.Infra.Option
import GF.Data.Operations
import Data.List (nub)
@@ -76,7 +77,7 @@ rebuildModule ms mo@(i,mi) = do
++ [oSimple i | i <- map snd insts] ----
--- check if me is incomplete
- let fs1 = fs_ ++ fs -- new flags have priority
+ let fs1 = addModuleOptions fs fs_ -- new flags have priority
let js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c]
let js1 = buildTree (tree2list js_ ++ js0)
return $ ModMod $ Module mt0 stat' fs1 me ops1 js1
diff --git a/src-3.0/GF/GFCC/OptimizeGFCC.hs b/src-3.0/GF/GFCC/OptimizeGFCC.hs
index 59fb93ffd..7fc227c66 100644
--- a/src-3.0/GF/GFCC/OptimizeGFCC.hs
+++ b/src-3.0/GF/GFCC/OptimizeGFCC.hs
@@ -13,7 +13,10 @@ import qualified Data.Map as Map
-- suffix analysis followed by common subexpression elimination
optGFCC :: GFCC -> GFCC
-optGFCC gfcc = gfcc {
+optGFCC = cseOptimize . suffixOptimize
+
+suffixOptimize :: GFCC -> GFCC
+suffixOptimize gfcc = gfcc {
concretes = Map.map opt (concretes gfcc)
}
where
@@ -23,6 +26,11 @@ optGFCC gfcc = gfcc {
printnames = Map.map optTerm (printnames cnc)
}
+cseOptimize :: GFCC -> GFCC
+cseOptimize gfcc = gfcc {
+ concretes = Map.map subex (concretes gfcc)
+ }
+
-- analyse word form lists into prefix + suffixes
-- suffix sets can later be shared by subex elim
diff --git a/src-3.0/GF/GFCC/PrintGFCC.hs b/src-3.0/GF/GFCC/PrintGFCC.hs
index aea34fb68..6eee6f112 100644
--- a/src-3.0/GF/GFCC/PrintGFCC.hs
+++ b/src-3.0/GF/GFCC/PrintGFCC.hs
@@ -5,16 +5,17 @@ import GF.GFCC.Raw.ConvertGFCC (fromGFCC)
import GF.GFCC.Raw.PrintGFCCRaw (printTree)
import GF.GFCC.GFCCtoHaskell
import GF.GFCC.GFCCtoJS
+import GF.Infra.Option
import GF.Text.UTF8
-- top-level access to code generation
-prGFCC :: String -> GFCC -> String
-prGFCC printer gr = case printer of
- "haskell" -> grammar2haskell gr
- "haskell_gadt" -> grammar2haskellGADT gr
- "js" -> gfcc2js gr
- _ -> printGFCC gr
+prGFCC :: OutputFormat -> GFCC -> String
+prGFCC fmt gr = case fmt of
+ FmtGFCC -> printGFCC gr
+ FmtJavaScript -> gfcc2js gr
+ FmtHaskell -> grammar2haskell gr
+ FmtHaskellGADT -> grammar2haskellGADT gr
printGFCC :: GFCC -> String
printGFCC = encodeUTF8 . printTree . fromGFCC
diff --git a/src-3.0/GF/Grammar/API.hs b/src-3.0/GF/Grammar/API.hs
index bfbfb3d14..6d14fbf3c 100644
--- a/src-3.0/GF/Grammar/API.hs
+++ b/src-3.0/GF/Grammar/API.hs
@@ -5,7 +5,8 @@ module GF.Grammar.API (
prTerm,
checkTerm,
computeTerm,
- showTerm
+ showTerm,
+ TermPrintStyle(..)
) where
import GF.Source.ParGF
@@ -52,9 +53,15 @@ checkTermAny gr m t = do
computeTerm :: Grammar -> Term -> Err Term
computeTerm = computeConcrete
-showTerm :: Options -> Term -> String
-showTerm opts t
- | oElem (iOpt "table") opts = unlines [p +++ s | (p,s) <- prTermTabular t]
- | oElem (iOpt "all") opts = unlines [ s | (p,s) <- prTermTabular t]
- | oElem (iOpt "unqual") opts = prt_ t
- | otherwise = prt t
+showTerm :: TermPrintStyle -> Term -> String
+showTerm style t =
+ case style of
+ TermPrintTable -> unlines [p +++ s | (p,s) <- prTermTabular t]
+ TermPrintAll -> unlines [ s | (p,s) <- prTermTabular t]
+ TermPrintUnqual -> prt_ t
+ TermPrintDefault -> prt t
+
+
+data TermPrintStyle = TermPrintTable | TermPrintAll | TermPrintUnqual | TermPrintDefault
+ deriving (Show,Eq)
+
diff --git a/src-3.0/GF/Grammar/PrGrammar.hs b/src-3.0/GF/Grammar/PrGrammar.hs
index f605a8de7..9867aaef5 100644
--- a/src-3.0/GF/Grammar/PrGrammar.hs
+++ b/src-3.0/GF/Grammar/PrGrammar.hs
@@ -233,7 +233,7 @@ prExp e = case e of
-- | option @-strip@ strips qualifications
prTermOpt :: Options -> Term -> String
-prTermOpt opts = if oElem nostripQualif opts then prt else prExp
+prTermOpt opts = if PrinterStrip `elem` flag optPrinter opts then prt else prExp
-- | to get rid of brackets in the editor
prRefinement :: Term -> String
diff --git a/src-3.0/GF/Infra/GetOpt.hs b/src-3.0/GF/Infra/GetOpt.hs
new file mode 100644
index 000000000..ede561c90
--- /dev/null
+++ b/src-3.0/GF/Infra/GetOpt.hs
@@ -0,0 +1,381 @@
+-- This is a version of System.Console.GetOpt which has been hacked to
+-- support long options with a single dash. Since we don't want the annoying
+-- clash with short options that start with the same character as a long
+-- one, we don't allow short options to be given together (e.g. -zxf),
+-- nor do we allow options to be given as any unique prefix.
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : System.Console.GetOpt
+-- Copyright : (c) Sven Panne 2002-2005
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : portable
+--
+-- This library provides facilities for parsing the command-line options
+-- in a standalone program. It is essentially a Haskell port of the GNU
+-- @getopt@ library.
+--
+-----------------------------------------------------------------------------
+
+{-
+Sven Panne <Sven.Panne@informatik.uni-muenchen.de> Oct. 1996 (small
+changes Dec. 1997)
+
+Two rather obscure features are missing: The Bash 2.0 non-option hack
+(if you don't already know it, you probably don't want to hear about
+it...) and the recognition of long options with a single dash
+(e.g. '-help' is recognised as '--help', as long as there is no short
+option 'h').
+
+Other differences between GNU's getopt and this implementation:
+
+* To enforce a coherent description of options and arguments, there
+ are explanation fields in the option/argument descriptor.
+
+* Error messages are now more informative, but no longer POSIX
+ compliant... :-(
+
+And a final Haskell advertisement: The GNU C implementation uses well
+over 1100 lines, we need only 195 here, including a 46 line example!
+:-)
+-}
+
+--module System.Console.GetOpt (
+module GF.Infra.GetOpt (
+ -- * GetOpt
+ getOpt, getOpt',
+ usageInfo,
+ ArgOrder(..),
+ OptDescr(..),
+ ArgDescr(..),
+
+ -- * Examples
+
+ -- |To hopefully illuminate the role of the different data structures,
+ -- here are the command-line options for a (very simple) compiler,
+ -- done in two different ways.
+ -- The difference arises because the type of 'getOpt' is
+ -- parameterized by the type of values derived from flags.
+
+ -- ** Interpreting flags as concrete values
+ -- $example1
+
+ -- ** Interpreting flags as transformations of an options record
+ -- $example2
+) where
+
+import Prelude -- necessary to get dependencies right
+
+import Data.List ( isPrefixOf, find )
+
+-- |What to do with options following non-options
+data ArgOrder a
+ = RequireOrder -- ^ no option processing after first non-option
+ | Permute -- ^ freely intersperse options and non-options
+ | ReturnInOrder (String -> a) -- ^ wrap non-options into options
+
+{-|
+Each 'OptDescr' describes a single option.
+
+The arguments to 'Option' are:
+
+* list of short option characters
+
+* list of long option strings (without \"--\")
+
+* argument descriptor
+
+* explanation of option for user
+-}
+data OptDescr a = -- description of a single options:
+ Option [Char] -- list of short option characters
+ [String] -- list of long option strings (without "--")
+ (ArgDescr a) -- argument descriptor
+ String -- explanation of option for user
+
+-- |Describes whether an option takes an argument or not, and if so
+-- how the argument is injected into a value of type @a@.
+data ArgDescr a
+ = NoArg a -- ^ no argument expected
+ | ReqArg (String -> a) String -- ^ option requires argument
+ | OptArg (Maybe String -> a) String -- ^ optional argument
+
+data OptKind a -- kind of cmd line arg (internal use only):
+ = Opt a -- an option
+ | UnreqOpt String -- an un-recognized option
+ | NonOpt String -- a non-option
+ | EndOfOpts -- end-of-options marker (i.e. "--")
+ | OptErr String -- something went wrong...
+
+-- | Return a string describing the usage of a command, derived from
+-- the header (first argument) and the options described by the
+-- second argument.
+usageInfo :: String -- header
+ -> [OptDescr a] -- option descriptors
+ -> String -- nicely formatted decription of options
+usageInfo header optDescr = unlines (header:table)
+ where (ss,ls,ds) = (unzip3 . concatMap fmtOpt) optDescr
+ table = zipWith3 paste (sameLen ss) (sameLen ls) ds
+ paste x y z = " " ++ x ++ " " ++ y ++ " " ++ z
+ sameLen xs = flushLeft ((maximum . map length) xs) xs
+ flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ]
+
+fmtOpt :: OptDescr a -> [(String,String,String)]
+fmtOpt (Option sos los ad descr) =
+ case lines descr of
+ [] -> [(sosFmt,losFmt,"")]
+ (d:ds) -> (sosFmt,losFmt,d) : [ ("","",d') | d' <- ds ]
+ where sepBy _ [] = ""
+ sepBy _ [x] = x
+ sepBy ch (x:xs) = x ++ ch:' ':sepBy ch xs
+ sosFmt = sepBy ',' (map (fmtShort ad) sos)
+ losFmt = sepBy ',' (map (fmtLong ad) los)
+
+fmtShort :: ArgDescr a -> Char -> String
+fmtShort (NoArg _ ) so = "-" ++ [so]
+fmtShort (ReqArg _ ad) so = "-" ++ [so] ++ " " ++ ad
+fmtShort (OptArg _ ad) so = "-" ++ [so] ++ "[" ++ ad ++ "]"
+
+fmtLong :: ArgDescr a -> String -> String
+fmtLong (NoArg _ ) lo = "--" ++ lo
+fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad
+fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]"
+
+{-|
+Process the command-line, and return the list of values that matched
+(and those that didn\'t). The arguments are:
+
+* The order requirements (see 'ArgOrder')
+
+* The option descriptions (see 'OptDescr')
+
+* The actual command line arguments (presumably got from
+ 'System.Environment.getArgs').
+
+'getOpt' returns a triple consisting of the option arguments, a list
+of non-options, and a list of error messages.
+-}
+getOpt :: ArgOrder a -- non-option handling
+ -> [OptDescr a] -- option descriptors
+ -> [String] -- the command-line arguments
+ -> ([a],[String],[String]) -- (options,non-options,error messages)
+getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us)
+ where (os,xs,us,es) = getOpt' ordering optDescr args
+
+{-|
+This is almost the same as 'getOpt', but returns a quadruple
+consisting of the option arguments, a list of non-options, a list of
+unrecognized options, and a list of error messages.
+-}
+getOpt' :: ArgOrder a -- non-option handling
+ -> [OptDescr a] -- option descriptors
+ -> [String] -- the command-line arguments
+ -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages)
+getOpt' _ _ [] = ([],[],[],[])
+getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering
+ where procNextOpt (Opt o) _ = (o:os,xs,us,es)
+ procNextOpt (UnreqOpt u) _ = (os,xs,u:us,es)
+ procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[],[])
+ procNextOpt (NonOpt x) Permute = (os,x:xs,us,es)
+ procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,us,es)
+ procNextOpt EndOfOpts RequireOrder = ([],rest,[],[])
+ procNextOpt EndOfOpts Permute = ([],rest,[],[])
+ procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[],[])
+ procNextOpt (OptErr e) _ = (os,xs,us,e:es)
+
+ (opt,rest) = getNext arg args optDescr
+ (os,xs,us,es) = getOpt' ordering optDescr rest
+
+-- take a look at the next cmd line arg and decide what to do with it
+getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
+getNext ('-':'-':[]) rest _ = (EndOfOpts,rest)
+getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr
+getNext ('-' :xs) rest optDescr = longOpt xs rest optDescr
+getNext a rest _ = (NonOpt a,rest)
+
+-- handle long option
+longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
+longOpt ls rs optDescr = long ads arg rs
+ where (opt,arg) = break (=='=') ls
+ options = [ o | o@(Option ss xs _ _) <- optDescr
+ , opt `elem` map (:[]) ss || opt `elem` xs ]
+ ads = [ ad | Option _ _ ad _ <- options ]
+ optStr = ("--"++opt)
+
+ long (_:_:_) _ rest = (errAmbig options optStr,rest)
+ long [NoArg a ] [] rest = (Opt a,rest)
+ long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest)
+ long [ReqArg _ d] [] [] = (errReq d optStr,[])
+ long [ReqArg f _] [] (r:rest) = (Opt (f r),rest)
+ long [ReqArg f _] ('=':xs) rest = (Opt (f xs),rest)
+ long [OptArg f _] [] rest = (Opt (f Nothing),rest)
+ long [OptArg f _] ('=':xs) rest = (Opt (f (Just xs)),rest)
+ long _ _ rest = (UnreqOpt ("--"++ls),rest)
+
+
+-- miscellaneous error formatting
+
+errAmbig :: [OptDescr a] -> String -> OptKind a
+errAmbig ods optStr = OptErr (usageInfo header ods)
+ where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:"
+
+errReq :: String -> String -> OptKind a
+errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n")
+
+errUnrec :: String -> String
+errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n"
+
+errNoArg :: String -> OptKind a
+errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n")
+
+{-
+-----------------------------------------------------------------------------------------
+-- and here a small and hopefully enlightening example:
+
+data Flag = Verbose | Version | Name String | Output String | Arg String deriving Show
+
+options :: [OptDescr Flag]
+options =
+ [Option ['v'] ["verbose"] (NoArg Verbose) "verbosely list files",
+ Option ['V','?'] ["version","release"] (NoArg Version) "show version info",
+ Option ['o'] ["output"] (OptArg out "FILE") "use FILE for dump",
+ Option ['n'] ["name"] (ReqArg Name "USER") "only dump USER's files"]
+
+out :: Maybe String -> Flag
+out Nothing = Output "stdout"
+out (Just o) = Output o
+
+test :: ArgOrder Flag -> [String] -> String
+test order cmdline = case getOpt order options cmdline of
+ (o,n,[] ) -> "options=" ++ show o ++ " args=" ++ show n ++ "\n"
+ (_,_,errs) -> concat errs ++ usageInfo header options
+ where header = "Usage: foobar [OPTION...] files..."
+
+-- example runs:
+-- putStr (test RequireOrder ["foo","-v"])
+-- ==> options=[] args=["foo", "-v"]
+-- putStr (test Permute ["foo","-v"])
+-- ==> options=[Verbose] args=["foo"]
+-- putStr (test (ReturnInOrder Arg) ["foo","-v"])
+-- ==> options=[Arg "foo", Verbose] args=[]
+-- putStr (test Permute ["foo","--","-v"])
+-- ==> options=[] args=["foo", "-v"]
+-- putStr (test Permute ["-?o","--name","bar","--na=baz"])
+-- ==> options=[Version, Output "stdout", Name "bar", Name "baz"] args=[]
+-- putStr (test Permute ["--ver","foo"])
+-- ==> option `--ver' is ambiguous; could be one of:
+-- -v --verbose verbosely list files
+-- -V, -? --version, --release show version info
+-- Usage: foobar [OPTION...] files...
+-- -v --verbose verbosely list files
+-- -V, -? --version, --release show version info
+-- -o[FILE] --output[=FILE] use FILE for dump
+-- -n USER --name=USER only dump USER's files
+-----------------------------------------------------------------------------------------
+-}
+
+{- $example1
+
+A simple choice for the type associated with flags is to define a type
+@Flag@ as an algebraic type representing the possible flags and their
+arguments:
+
+> module Opts1 where
+>
+> import System.Console.GetOpt
+> import Data.Maybe ( fromMaybe )
+>
+> data Flag
+> = Verbose | Version
+> | Input String | Output String | LibDir String
+> deriving Show
+>
+> options :: [OptDescr Flag]
+> options =
+> [ Option ['v'] ["verbose"] (NoArg Verbose) "chatty output on stderr"
+> , Option ['V','?'] ["version"] (NoArg Version) "show version number"
+> , Option ['o'] ["output"] (OptArg outp "FILE") "output FILE"
+> , Option ['c'] [] (OptArg inp "FILE") "input FILE"
+> , Option ['L'] ["libdir"] (ReqArg LibDir "DIR") "library directory"
+> ]
+>
+> inp,outp :: Maybe String -> Flag
+> outp = Output . fromMaybe "stdout"
+> inp = Input . fromMaybe "stdin"
+>
+> compilerOpts :: [String] -> IO ([Flag], [String])
+> compilerOpts argv =
+> case getOpt Permute options argv of
+> (o,n,[] ) -> return (o,n)
+> (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
+> where header = "Usage: ic [OPTION...] files..."
+
+Then the rest of the program will use the constructed list of flags
+to determine it\'s behaviour.
+
+-}
+
+{- $example2
+
+A different approach is to group the option values in a record of type
+@Options@, and have each flag yield a function of type
+@Options -> Options@ transforming this record.
+
+> module Opts2 where
+>
+> import System.Console.GetOpt
+> import Data.Maybe ( fromMaybe )
+>
+> data Options = Options
+> { optVerbose :: Bool
+> , optShowVersion :: Bool
+> , optOutput :: Maybe FilePath
+> , optInput :: Maybe FilePath
+> , optLibDirs :: [FilePath]
+> } deriving Show
+>
+> defaultOptions = Options
+> { optVerbose = False
+> , optShowVersion = False
+> , optOutput = Nothing
+> , optInput = Nothing
+> , optLibDirs = []
+> }
+>
+> options :: [OptDescr (Options -> Options)]
+> options =
+> [ Option ['v'] ["verbose"]
+> (NoArg (\ opts -> opts { optVerbose = True }))
+> "chatty output on stderr"
+> , Option ['V','?'] ["version"]
+> (NoArg (\ opts -> opts { optShowVersion = True }))
+> "show version number"
+> , Option ['o'] ["output"]
+> (OptArg ((\ f opts -> opts { optOutput = Just f }) . fromMaybe "output")
+> "FILE")
+> "output FILE"
+> , Option ['c'] []
+> (OptArg ((\ f opts -> opts { optInput = Just f }) . fromMaybe "input")
+> "FILE")
+> "input FILE"
+> , Option ['L'] ["libdir"]
+> (ReqArg (\ d opts -> opts { optLibDirs = optLibDirs opts ++ [d] }) "DIR")
+> "library directory"
+> ]
+>
+> compilerOpts :: [String] -> IO (Options, [String])
+> compilerOpts argv =
+> case getOpt Permute options argv of
+> (o,n,[] ) -> return (foldl (flip id) defaultOptions o, n)
+> (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
+> where header = "Usage: ic [OPTION...] files..."
+
+Similarly, each flag could yield a monadic function transforming a record,
+of type @Options -> IO Options@ (or any other monad), allowing option
+processing to perform actions of the chosen monad, e.g. printing help or
+version messages, checking that file arguments exist, etc.
+
+-}
diff --git a/src-3.0/GF/Infra/Modules.hs b/src-3.0/GF/Infra/Modules.hs
index 17a304a6f..8f9edbc68 100644
--- a/src-3.0/GF/Infra/Modules.hs
+++ b/src-3.0/GF/Infra/Modules.hs
@@ -65,7 +65,7 @@ data ModInfo i a =
data Module i a = Module {
mtype :: ModuleType i ,
mstatus :: ModuleStatus ,
- flags :: [Option] ,
+ flags :: ModuleOptions,
extend :: [(i,MInclude i)],
opens :: [OpenSpec i] ,
jments :: BinTree i a
@@ -126,16 +126,16 @@ addOpenQualif :: i -> i -> Module i t -> Module i t
addOpenQualif i j (Module mt ms fs me ops js) =
Module mt ms fs me (oQualif i j : ops) js
-addFlag :: Option -> Module i t -> Module i t
-addFlag f mo = mo {flags = f : flags mo}
+addFlag :: ModuleOptions -> Module i t -> Module i t
+addFlag f mo = mo {flags = addModuleOptions (flags mo) f}
-flagsModule :: (i,ModInfo i a) -> [Option]
+flagsModule :: (i,ModInfo i a) -> ModuleOptions
flagsModule (_,mi) = case mi of
ModMod m -> flags m
- _ -> []
+ _ -> noModuleOptions
-allFlags :: MGrammar i a -> [Option]
-allFlags gr = concat $ map flags $ [m | (_, ModMod m) <- modules gr]
+allFlags :: MGrammar i a -> ModuleOptions
+allFlags gr = concatModuleOptions $ map flags $ [m | (_, ModMod m) <- modules gr]
mapModules :: (Module i a -> Module i a)
-> MGrammar i a -> MGrammar i a
@@ -267,7 +267,7 @@ emptyModInfo :: ModInfo i a
emptyModInfo = ModMod emptyModule
emptyModule :: Module i a
-emptyModule = Module MTResource MSComplete [] [] [] emptyBinTree
+emptyModule = Module MTResource MSComplete noModuleOptions [] [] emptyBinTree
-- | we store the module type with the identifier
data IdentM i = IdentM {
diff --git a/src-3.0/GF/Infra/Option.hs b/src-3.0/GF/Infra/Option.hs
index a44cd9db8..dc795e597 100644
--- a/src-3.0/GF/Infra/Option.hs
+++ b/src-3.0/GF/Infra/Option.hs
@@ -1,375 +1,464 @@
-----------------------------------------------------------------------
--- |
--- Module : Option
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/11/14 16:03:41 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.34 $
---
--- Options and flags used in GF shell commands and files.
---
--- The types 'Option' and 'Options' should be kept abstract, but:
---
--- - The constructor 'Opt' is used in "ShellCommands" and "GrammarToSource"
---
--- - The constructor 'Opts' us udes in "API", "Shell" and "ShellCommands"
------------------------------------------------------------------------------
-
-module GF.Infra.Option where
-
-import Data.List (partition)
-import Data.Char (isDigit)
-
--- * all kinds of options, to be kept abstract
-
-newtype Option = Opt (String,[String]) deriving (Eq,Show,Read)
-newtype Options = Opts [Option] deriving (Eq,Show,Read)
+module GF.Infra.Option
+ (
+ -- * Option types
+ Options, ModuleOptions,
+ Flags(..), ModuleFlags(..),
+ Mode(..), Phase(..), Encoding(..), OutputFormat(..), Optimization(..),
+ Dump(..), Printer(..), Recomp(..),
+ -- * Option parsing
+ parseOptions, parseModuleOptions,
+ -- * Option pretty-printing
+ moduleOptionsGFO,
+ -- * Option manipulation
+ addOptions, concatOptions, noOptions,
+ moduleOptions,
+ addModuleOptions, concatModuleOptions, noModuleOptions,
+ helpMessage,
+ -- * Checking options
+ flag, moduleFlag,
+ -- * Convenience methods for checking options
+ beVerbose, beSilent,
+ 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
+
+
+
+
+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 | ModeCompiler
+ 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 | FmtJavaScript | FmtHaskell | FmtHaskellGADT
+ deriving (Eq,Ord)
+
+data Optimization = OptStem | OptCSE | OptExpand | OptParametrize | OptValues
+ deriving (Show,Eq,Ord)
+
+data Warning = WarnMissingLincat
+ deriving (Show,Eq,Ord)
+
+data Dump = 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 ModuleFlags = ModuleFlags {
+ optName :: Maybe String,
+ optAbsName :: Maybe String,
+ optCncName :: Maybe String,
+ optResName :: Maybe String,
+ optPreprocessors :: [String],
+ optEncoding :: Encoding,
+ optOptimizations :: [Optimization],
+ optLibraryPath :: [FilePath],
+ optStartCat :: Maybe String,
+ optSpeechLanguage :: Maybe String,
+ optLexer :: Maybe String,
+ optUnlexer :: Maybe String,
+ optBuildParser :: Bool,
+ optWarnings :: [Warning],
+ optDump :: [Dump]
+ }
+ deriving (Show)
+
+data Flags = Flags {
+ optMode :: Mode,
+ optStopAfterPhase :: Phase,
+ optVerbosity :: Int,
+ optShowCPUTime :: Bool,
+ optEmitGFO :: Bool,
+ optGFODir :: FilePath,
+ optOutputFormats :: [OutputFormat],
+ optOutputFile :: Maybe FilePath,
+ optOutputDir :: Maybe FilePath,
+ optRecomp :: Recomp,
+ optPrinter :: [Printer],
+ optProb :: Bool,
+ optRetainResource :: Bool,
+ optModuleFlags :: ModuleFlags
+ }
+ deriving (Show)
+
+newtype Options = Options (Flags -> Flags)
+
+instance Show Options where
+ show (Options o) = show (o defaultFlags)
+
+newtype ModuleOptions = ModuleOptions (ModuleFlags -> ModuleFlags)
+
+-- Option parsing
+
+parseOptions :: [String] -> 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] -> Err ModuleOptions
+parseModuleOptions args
+ | not (null errs) = errors errs
+ | not (null files) = errors $ map ("Non-option among module options: " ++) files
+ | otherwise = liftM concatModuleOptions $ sequence flags
+ where (flags, files, errs) = getOpt RequireOrder moduleOptDescr args
+
+-- Showing options
+
+-- | Pretty-print the module options that are preserved in .gfo files.
+moduleOptionsGFO :: ModuleOptions -> [(String,String)]
+moduleOptionsGFO (ModuleOptions o) =
+ maybe [] (\l -> [("language",l)]) (optSpeechLanguage mfs)
+ where mfs = o defaultModuleFlags
+
+
+-- Option manipulation
noOptions :: Options
-noOptions = Opts []
-
--- | simple option -o
-iOpt :: String -> Option
-iOpt o = Opt (o,[])
-
--- | option with argument -o=a
-aOpt :: String -> String -> Option
-aOpt o a = Opt (o,[a])
-
-iOpts :: [Option] -> Options
-iOpts = Opts
-
--- | value of option argument
-oArg :: String -> String
-oArg s = s
-
-oElem :: Option -> Options -> Bool
-oElem o (Opts os) = elem o os
-
-eqOpt :: String -> Option -> Bool
-eqOpt s (Opt (o, [])) = s == o
-eqOpt s _ = False
-
-type OptFun = String -> Option
-type OptFunId = String
-
-getOptVal :: Options -> OptFun -> Maybe String
-getOptVal (Opts os) fopt =
- case [a | opt@(Opt (o,[a])) <- os, opt == fopt a] of
- a:_ -> Just a
- _ -> Nothing
+noOptions = Options id
-isSetFlag :: Options -> OptFun -> Bool
-isSetFlag (Opts os) fopt =
- case [a | opt@(Opt (o,[a])) <- os, opt == fopt a] of
- a:_ -> True
- _ -> False
-
-getOptInt :: Options -> OptFun -> Maybe Int
-getOptInt opts f = do
- s <- getOptVal opts f
- if (not (null s) && all isDigit s) then return (read s) else Nothing
-
-optIntOrAll :: Options -> OptFun -> [a] -> [a]
-optIntOrAll opts f = case getOptInt opts f of
- Just i -> take i
- _ -> id
-
-optIntOrN :: Options -> OptFun -> Int -> Int
-optIntOrN opts f n = case getOptInt opts f of
- Just i -> i
- _ -> n
-
-optIntOrOne :: Options -> OptFun -> Int
-optIntOrOne opts f = optIntOrN opts f 1
-
-changeOptVal :: Options -> OptFun -> String -> Options
-changeOptVal os f x =
- addOption (f x) $ maybe os (\y -> removeOption (f y) os) $ getOptVal os f
-
-addOption :: Option -> Options -> Options
-addOption o (Opts os) = iOpts (o:os)
-
-addOptions :: Options -> Options -> Options
-addOptions (Opts os) os0 = foldr addOption os0 os
+addOptions :: Options -- ^ Existing options.
+ -> Options -- ^ Options to add (these take preference).
+ -> Options
+addOptions (Options o1) (Options o2) = Options (o2 . o1)
concatOptions :: [Options] -> Options
concatOptions = foldr addOptions noOptions
-removeOption :: Option -> Options -> Options
-removeOption o (Opts os) = iOpts (filter (/=o) os)
-
-removeOptions :: Options -> Options -> Options
-removeOptions (Opts os) os0 = foldr removeOption os0 os
+moduleOptions :: ModuleOptions -> Options
+moduleOptions (ModuleOptions f) = Options (\o -> o { optModuleFlags = f (optModuleFlags o) })
-options :: [Option] -> Options
-options = foldr addOption noOptions
+addModuleOptions :: ModuleOptions -- ^ Existing options.
+ -> ModuleOptions -- ^ Options to add (these take preference).
+ -> ModuleOptions
+addModuleOptions (ModuleOptions o1) (ModuleOptions o2) = ModuleOptions (o2 . o1)
-unionOptions :: Options -> Options -> Options
-unionOptions (Opts os) (Opts os') = Opts (os ++ os')
+concatModuleOptions :: [ModuleOptions] -> ModuleOptions
+concatModuleOptions = foldr addModuleOptions noModuleOptions
--- * parsing options, with prefix pre (e.g. \"-\")
+noModuleOptions :: ModuleOptions
+noModuleOptions = ModuleOptions id
-getOptions :: String -> [String] -> (Options, [String])
-getOptions pre inp = let
- (os,rest) = span (isOption pre) inp -- options before args
- in
- (Opts (map (pOption pre) os), rest)
+flag :: (Flags -> a) -> Options -> a
+flag f (Options o) = f (o defaultFlags)
-pOption :: String -> String -> Option
-pOption pre s = case span (/= '=') (drop (length pre) s) of
- (f,_:a) -> aOpt f a
- (o,[]) -> iOpt o
+moduleFlag :: (ModuleFlags -> a) -> Options -> a
+moduleFlag f = flag (f . optModuleFlags)
-isOption :: String -> String -> Bool
-isOption pre = (==pre) . take (length pre)
--- * printing options, without prefix
-
-prOpt :: Option -> String
-prOpt (Opt (s,[])) = s
-prOpt (Opt (s,xs)) = s ++ "=" ++ concat xs
-
-prOpts :: Options -> String
-prOpts (Opts os) = unwords $ map prOpt os
-
--- * a suggestion for option names
+{-
--- ** parsing
+parseModuleFlags :: Options -> [(String,Maybe String)] -> Err ModuleOptions
+parseModuleFlags opts flags =
+ mapM (uncurry (findFlag moduleOptDescr)) flags >>= foldM (flip ($)) (optModuleOptions opts)
+
+findFlag :: Monad m => [OptDescr a] -> String -> Maybe String -> m a
+findFlag opts n mv =
+ case filter (`flagMatches` n) opts of
+ [] -> fail $ "Unknown option: " ++ n
+ [opt] -> flagValue opt n mv
+ _ -> fail $ n ++ " matches multiple options."
+
+flagMatches :: OptDescr a -> String -> Bool
+flagMatches (Option cs ss _ _) n = n `elem` (map (:[]) cs ++ ss)
+
+flagValue :: Monad m => OptDescr a -> String -> Maybe String -> m a
+flagValue (Option _ _ arg _) n mv =
+ case (arg, mv) of
+ (NoArg x, Nothing) -> return x
+ (NoArg _, Just _ ) -> fail $ "Option " ++ n ++ " does not take a value."
+ (ReqArg _ _, Nothing) -> fail $ "Option " ++ n ++ " requires a value."
+ (ReqArg f _, Just x ) -> return (f x)
+ (OptArg f _, mx ) -> return (f mx)
-strictParse, forgiveParse, ignoreParse, literalParse, rawParse, firstParse :: Option
--- | parse as term instead of string
-dontParse :: Option
+-}
-strictParse = iOpt "strict"
-forgiveParse = iOpt "n"
-ignoreParse = iOpt "ign"
-literalParse = iOpt "lit"
-rawParse = iOpt "raw"
-firstParse = iOpt "1"
-dontParse = iOpt "read"
+-- Default options
+
+defaultModuleFlags :: ModuleFlags
+defaultModuleFlags = ModuleFlags {
+ optName = Nothing,
+ optAbsName = Nothing,
+ optCncName = Nothing,
+ optResName = Nothing,
+ optPreprocessors = [],
+ optEncoding = ISO_8859_1,
+ optOptimizations = [OptStem,OptCSE,OptExpand,OptParametrize,OptValues],
+ optLibraryPath = [],
+ optStartCat = Nothing,
+ optSpeechLanguage = Nothing,
+ optLexer = Nothing,
+ optUnlexer = Nothing,
+ optBuildParser = True,
+ optWarnings = [],
+ optDump = []
+ }
+
+defaultFlags :: Flags
+defaultFlags = Flags {
+ optMode = ModeInteractive,
+ optStopAfterPhase = Compile,
+ optVerbosity = 1,
+ optShowCPUTime = False,
+ optEmitGFO = True,
+ optGFODir = ".",
+ optOutputFormats = [FmtGFCC],
+ optOutputFile = Nothing,
+ optOutputDir = Nothing,
+ optRecomp = RecompIfNewer,
+ optPrinter = [],
+ optProb = False,
+ optRetainResource = False,
+ optModuleFlags = defaultModuleFlags
+ }
+
+-- Option descriptions
+
+moduleOptDescr :: [OptDescr (Err ModuleOptions)]
+moduleOptDescr =
+ [
+ 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 [] ["parser"] (onOff parser True) "Build parser (default on).",
+ 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).",
+ dumpOption "rebuild" DumpRebuild,
+ dumpOption "extend" DumpExtend,
+ dumpOption "rename" DumpRename,
+ dumpOption "tc" DumpTypeCheck,
+ dumpOption "refresh" DumpRefresh,
+ dumpOption "opt" DumpOptimize,
+ dumpOption "canon" DumpCanon
+ ]
+ where
+ 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
+ parser x = set $ \o -> o { optBuildParser = x }
+ 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 $ \o -> o { optOptimizations = (if b then (x:) else delete x) (optOptimizations o) }
+
+ dumpOption s d = Option [] ["dump-"++s] (NoArg (set $ \o -> o { optDump = d:optDump o})) ("Dump output of the " ++ s ++ " phase.")
+
+ set = return . ModuleOptions
+
+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 3.",
+ 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 ['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 (phase Link)) "Build .gfcc file and other output files.",
+ 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 ['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 (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."
+ ] ++ map (fmap (liftM moduleOptions)) moduleOptDescr
+ 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 = 3 }
+ Just v -> case reads v of
+ [(i,"")] | i >= 0 -> set $ \o -> o { optVerbosity = i }
+ _ -> fail $ "Bad verbosity: " ++ show v
+ cpu x = set $ \o -> o { optShowCPUTime = x }
+ emitGFO x = set $ \o -> o { optEmitGFO = x }
+ gfoDir x = set $ \o -> o { optGFODir = x }
+ outFmt x = readOutputFormat x >>= \f ->
+ set $ \o -> o { optOutputFormats = optOutputFormats o ++ [f] }
+ outFile x = set $ \o -> o { optOutputFile = Just x }
+ outDir x = set $ \o -> o { optOutputDir = 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 }
+
+ set = return . Options
+
+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", FmtJavaScript),
+ ("haskell", FmtHaskell),
+ ("haskell_gadt", FmtHaskellGADT)]
+
+instance Show OutputFormat where
+ show = lookupShow outputFormats
+
+instance Read OutputFormat where
+ readsPrec = lookupReadsPrec outputFormats
+
+optimizationPackages :: [(String,[Optimization])]
+optimizationPackages =
+ [("all_subs", [OptStem,OptCSE,OptExpand,OptParametrize,OptValues]), -- deprecated
+ ("all", [OptStem,OptCSE,OptExpand,OptParametrize,OptValues]),
+ ("values", [OptStem,OptCSE,OptExpand,OptValues]),
+ ("parametrize", [OptStem,OptCSE,OptExpand,OptParametrize]),
+ ("none", [OptStem,OptCSE,OptExpand]),
+ ("noexpand", [OptStem,OptCSE])]
+
+encodings :: [(String,Encoding)]
+encodings =
+ [("utf8", UTF_8),
+ ("latin1", ISO_8859_1)]
+
+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
+--
-newParser, newerParser, newCParser, newMParser :: Option
-newParser = iOpt "new"
-newerParser = iOpt "newer"
-newCParser = iOpt "cfg"
-newMParser = iOpt "mcfg"
-newFParser = iOpt "fcfg"
+beVerbose :: Options -> Bool
+beVerbose = flag ((>= 3) . optVerbosity)
-{-
-useParserMCFG, useParserMCFGviaCFG, useParserCFG, useParserCF :: Option
+beSilent :: Options -> Bool
+beSilent = flag ((<= 0) . optVerbosity)
-useParserMCFG = iOpt "mcfg"
-useParserMCFGviaCFG = iOpt "mcfg-via-cfg"
-useParserCFG = iOpt "cfg"
-useParserCF = iOpt "cf"
--}
+dump :: Options -> Dump -> Bool
+dump opts d = moduleFlag ((d `elem`) . optDump) opts
--- ** grammar formats
-
-showAbstr, showXML, showOld, showLatex, showFullForm,
- showEBNF, showCF, showWords, showOpts,
- isCompiled, isHaskell, noCompOpers, retainOpers,
- noCF, checkCirc, noCheckCirc, lexerByNeed, useUTF8id :: Option
-defaultGrOpts :: [Option]
-
-showAbstr = iOpt "abs"
-showXML = iOpt "xml"
-showOld = iOpt "old"
-showLatex = iOpt "latex"
-showFullForm = iOpt "fullform"
-showEBNF = iOpt "ebnf"
-showCF = iOpt "cf"
-showWords = iOpt "ws"
-showOpts = iOpt "opts"
--- showOptim = iOpt "opt"
-isCompiled = iOpt "gfc"
-isHaskell = iOpt "gfhs"
-noCompOpers = iOpt "nocomp"
-retainOpers = iOpt "retain"
-defaultGrOpts = []
-noCF = iOpt "nocf"
-checkCirc = iOpt "nocirc"
-noCheckCirc = iOpt "nocheckcirc"
-lexerByNeed = iOpt "cflexer"
-useUTF8id = iOpt "utf8id"
-elimSubs = iOpt "subs"
-
--- ** linearization
-
-allLin, firstLin, distinctLin, dontLin,
- showRecord, showStruct, xmlLin, latexLin,
- tableLin, useUTF8, showLang, withMetas :: Option
-defaultLinOpts :: [Option]
-
-allLin = iOpt "all"
-firstLin = iOpt "one"
-distinctLin = iOpt "nub"
-dontLin = iOpt "show"
-showRecord = iOpt "record"
-showStruct = iOpt "structured"
-xmlLin = showXML
-latexLin = showLatex
-tableLin = iOpt "table"
-defaultLinOpts = [firstLin]
-useUTF8 = iOpt "utf8"
-showLang = iOpt "lang"
-showDefs = iOpt "defs"
-withMetas = iOpt "metas"
-
--- ** other
-
-beVerbose, showInfo, beSilent, emitCode, getHelp,
- doMake, doBatch, notEmitCode, makeMulti, beShort,
- wholeGrammar, makeFudget, byLines, byWords, analMorpho,
- doTrace, noCPU, doCompute, optimizeCanon, optimizeValues,
- stripQualif, nostripQualif, showAll, fromSource :: Option
-
-beVerbose = iOpt "v"
-invertGrep = iOpt "v" --- same letter in unix
-showInfo = iOpt "i"
-beSilent = iOpt "s"
-emitCode = iOpt "o"
-getHelp = iOpt "help"
-doMake = iOpt "make"
-doBatch = iOpt "batch"
-notEmitCode = iOpt "noemit"
-makeMulti = iOpt "multi"
-beShort = iOpt "short"
-wholeGrammar = iOpt "w"
-makeFudget = iOpt "f"
-byLines = iOpt "lines"
-byWords = iOpt "words"
-analMorpho = iOpt "morpho"
-doTrace = iOpt "tr"
-noCPU = iOpt "nocpu"
-doCompute = iOpt "c"
-optimizeCanon = iOpt "opt"
-optimizeValues = iOpt "val"
-stripQualif = iOpt "strip"
-nostripQualif = iOpt "nostrip"
-showAll = iOpt "all"
-showFields = iOpt "fields"
-showMulti = iOpt "multi"
-fromSource = iOpt "src"
-makeConcrete = iOpt "examples"
-fromExamples = iOpt "ex"
-openEditor = iOpt "edit"
-getTrees = iOpt "trees"
-
--- ** mainly for stand-alone
-
-useUnicode, optCompute, optCheck, optParaphrase, forJava :: Option
-
-useUnicode = iOpt "unicode"
-optCompute = iOpt "compute"
-optCheck = iOpt "typecheck"
-optParaphrase = iOpt "paraphrase"
-forJava = iOpt "java"
-
--- ** for edit session
-
-allLangs, absView :: Option
-
-allLangs = iOpt "All"
-absView = iOpt "Abs"
-
--- ** options that take arguments
-
-useTokenizer, useUntokenizer, useParser, withFun,
- useLanguage, useResource, speechLanguage, useFont,
- grammarFormat, grammarPrinter, filterString, termCommand,
- transferFun, forForms, menuDisplay, sizeDisplay, typeDisplay,
- noDepTypes, extractGr, pathList, uniCoding :: String -> Option
--- | used on command line
-firstCat :: String -> Option
--- | used in grammar, to avoid clash w res word
-gStartCat :: String -> Option
-
-useTokenizer = aOpt "lexer"
-useUntokenizer = aOpt "unlexer"
-useParser = aOpt "parser"
--- useStrategy = aOpt "strategy" -- parsing strategy
-withFun = aOpt "fun"
-firstCat = aOpt "cat"
-gStartCat = aOpt "startcat"
-useLanguage = aOpt "lang"
-useResource = aOpt "res"
-speechLanguage = aOpt "language"
-useFont = aOpt "font"
-grammarFormat = aOpt "format"
-grammarPrinter = aOpt "printer"
-filterString = aOpt "filter"
-termCommand = aOpt "transform"
-transferFun = aOpt "transfer"
-forForms = aOpt "forms"
-menuDisplay = aOpt "menu"
-sizeDisplay = aOpt "size"
-typeDisplay = aOpt "types"
-noDepTypes = aOpt "nodeptypes"
-extractGr = aOpt "extract"
-pathList = aOpt "path"
-uniCoding = aOpt "coding"
-probFile = aOpt "probs"
-noparseFile = aOpt "noparse"
-usePreprocessor = aOpt "preproc"
-
--- peb 16/3-05:
-gfcConversion :: String -> Option
-gfcConversion = aOpt "conversion"
-
-useName, useAbsName, useCncName, useResName,
- useFile, useOptimizer :: String -> Option
-
-useName = aOpt "name"
-useAbsName = aOpt "abs"
-useCncName = aOpt "cnc"
-useResName = aOpt "res"
-useFile = aOpt "file"
-useOptimizer = aOpt "optimize"
-
-markLin :: String -> Option
-markOptXML, markOptJava, markOptStruct, markOptFocus :: String
-
-markLin = aOpt "mark"
-markOptXML = oArg "xml"
-markOptJava = oArg "java"
-markOptStruct = oArg "struct"
-markOptFocus = oArg "focus"
-
-
--- ** refinement order
-
-nextRefine :: String -> Option
-firstRefine, lastRefine :: String
-
-nextRefine = aOpt "nextrefine"
-firstRefine = oArg "first"
-lastRefine = oArg "last"
-
--- ** Boolean flags
-
-flagYes, flagNo :: String
-
-flagYes = oArg "yes"
-flagNo = oArg "no"
-
--- ** integer flags
-
-flagDepth, flagAlts, flagLength, flagNumber, flagRawtrees :: String -> Option
-
-flagDepth = aOpt "depth"
-flagAlts = aOpt "alts"
-flagLength = aOpt "length"
-flagNumber = aOpt "number"
-flagRawtrees = aOpt "rawtrees"
-
-caseYesNo :: Options -> OptFun -> Maybe Bool
-caseYesNo opts f = do
- v <- getOptVal opts f
- if v == flagYes then return True
- else if v == flagNo then return False
- else Nothing
diff --git a/src-3.0/GF/Infra/UseIO.hs b/src-3.0/GF/Infra/UseIO.hs
index ee66ddcff..dcc0c62ca 100644
--- a/src-3.0/GF/Infra/UseIO.hs
+++ b/src-3.0/GF/Infra/UseIO.hs
@@ -24,6 +24,7 @@ import System.FilePath
import System.IO
import System.IO.Error
import System.Environment
+import System.Exit
import System.CPUTime
import Control.Monad
import Control.Exception(evaluate)
@@ -39,20 +40,16 @@ putShow' f = putStrLn . show . length . show . f
putIfVerb :: Options -> String -> IO ()
putIfVerb opts msg =
- if oElem beVerbose opts
+ if beVerbose opts
then putStrLn msg
else return ()
putIfVerbW :: Options -> String -> IO ()
putIfVerbW opts msg =
- if oElem beVerbose opts
+ if beVerbose opts
then putStr (' ' : msg)
else return ()
--- | obsolete with IOE monad
-errIO :: a -> Err a -> IO a
-errIO = errOptIO noOptions
-
errOptIO :: Options -> a -> Err a -> IO a
errOptIO os e m = case m of
Ok x -> return x
@@ -235,6 +232,13 @@ foldIOE f s xs = case xs of
Ok v -> foldIOE f v xx
Bad m -> return $ (s, Just m)
+dieIOE :: IOE a -> IO a
+dieIOE x = appIOE x >>= err die return
+
+die :: String -> IO a
+die s = do hPutStrLn stderr s
+ exitFailure
+
putStrLnE :: String -> IOE ()
putStrLnE = ioeIO . putStrLnFlush
@@ -243,28 +247,27 @@ putStrE = ioeIO . putStrFlush
-- this is more verbose
putPointE :: Options -> String -> IOE a -> IOE a
-putPointE = putPointEgen (oElem beSilent)
+putPointE = putPointEgen beSilent
-- this is less verbose
putPointEsil :: Options -> String -> IOE a -> IOE a
-putPointEsil = putPointEgen (not . oElem beVerbose)
+putPointEsil = putPointEgen (not . beVerbose)
putPointEgen :: (Options -> Bool) -> Options -> String -> IOE a -> IOE a
putPointEgen cond opts msg act = do
- let ve x = if cond opts then return () else x
- ve $ ioeIO $ putStrFlush msg
+ when (cond opts) $ ioeIO $ putStrFlush msg
t1 <- ioeIO $ getCPUTime
a <- act >>= ioeIO . evaluate
t2 <- ioeIO $ getCPUTime
- ve $ ioeIO $ putStrLnFlush (' ' : show ((t2 - t1) `div` 1000000000) ++ " msec")
+ when (flag optShowCPUTime opts) $ ioeIO $ putStrLnFlush (' ' : show ((t2 - t1) `div` 1000000000) ++ " msec")
return a
-- | forces verbosity
putPointEVerb :: Options -> String -> IOE a -> IOE a
-putPointEVerb opts = putPointE (addOption beVerbose opts)
+putPointEVerb = putPointEgen (const False)
-- ((do {s <- readFile f; return (return s)}) )
readFileIOE :: FilePath -> IOE BS.ByteString
diff --git a/src-3.0/GF/Source/GrammarToSource.hs b/src-3.0/GF/Source/GrammarToSource.hs
index 6926ec202..75446a6e4 100644
--- a/src-3.0/GF/Source/GrammarToSource.hs
+++ b/src-3.0/GF/Source/GrammarToSource.hs
@@ -51,7 +51,7 @@ trModule (i,mo) = case mo of
body = P.MBody
(trExtends (extend m))
(mkOpens (map trOpen (opens m)))
- (mkTopDefs (concatMap trAnyDef (tree2list (jments m)) ++ map trFlag (flags m)))
+ (mkTopDefs (concatMap trAnyDef (tree2list (jments m)) ++ trFlags (flags m)))
trExtends :: [(Ident,MInclude Ident)] -> P.Extend
trExtends [] = P.NoExt
@@ -130,11 +130,11 @@ trPerh p = case p of
May b -> P.EIndir $ tri b
_ -> P.EMeta ---
+trFlags :: ModuleOptions -> [P.TopDef]
+trFlags = map trFlag . moduleOptionsGFO
-trFlag :: Option -> P.TopDef
-trFlag o = case o of
- Opt (f,[x]) -> P.DefFlag [P.FlagDef (tri $ identC (BS.pack f)) (tri $ identC (BS.pack x))]
- _ -> P.DefFlag [] --- warning?
+trFlag :: (String,String) -> P.TopDef
+trFlag (f,x) = P.DefFlag [P.FlagDef (tri $ identC (BS.pack f)) (tri $ identC (BS.pack x))]
trt :: Term -> P.Exp
trt trm = case trm of
diff --git a/src-3.0/GF/Source/SourceToGrammar.hs b/src-3.0/GF/Source/SourceToGrammar.hs
index f27c096c6..2ab1d58ac 100644
--- a/src-3.0/GF/Source/SourceToGrammar.hs
+++ b/src-3.0/GF/Source/SourceToGrammar.hs
@@ -107,14 +107,14 @@ transModDef x = case x of
opens' <- transOpens opens
defs0 <- mapM trDef $ getTopDefs defs
defs' <- U.buildAnyTree [d | Left ds <- defs0, d <- ds]
- flags' <- return [f | Right fs <- defs0, f <- fs]
+ flags' <- return $ concatModuleOptions [o | Right o <- defs0]
return (id',GM.ModMod (GM.Module mtyp' mstat' flags' extends' opens' defs'))
MReuse _ -> do
- return (id', GM.ModMod (GM.Module mtyp' mstat' [] [] [] emptyBinTree))
+ return (id', GM.ModMod (GM.Module mtyp' mstat' noModuleOptions [] [] emptyBinTree))
MUnion imps -> do
imps' <- mapM transIncluded imps
return (id',
- GM.ModMod (GM.Module (GM.MTUnion mtyp' imps') mstat' [] [] [] emptyBinTree))
+ GM.ModMod (GM.Module (GM.MTUnion mtyp' imps') mstat' noModuleOptions [] [] emptyBinTree))
MWith m insts -> mkBody xx $ MWithEBody [] m insts NoOpens []
MWithBody m insts opens defs -> mkBody xx $ MWithEBody [] m insts opens defs
@@ -126,7 +126,7 @@ transModDef x = case x of
opens' <- transOpens opens
defs0 <- mapM trDef $ getTopDefs defs
defs' <- U.buildAnyTree [d | Left ds <- defs0, d <- ds]
- flags' <- return [f | Right fs <- defs0, f <- fs]
+ flags' <- return $ concatModuleOptions [o | Right o <- defs0]
return (id',
GM.ModWith (GM.Module mtyp' mstat' flags' extends' opens' defs') m' insts')
@@ -215,7 +215,7 @@ transIncludedExt x = case x of
ISome i ids -> liftM2 (,) (transIdent i) (liftM GM.MIOnly $ mapM transIdent ids)
IMinus i ids -> liftM2 (,) (transIdent i) (liftM GM.MIExcept $ mapM transIdent ids)
-transAbsDef :: TopDef -> Err (Either [(Ident, G.Info)] [GO.Option])
+transAbsDef :: TopDef -> Err (Either [(Ident, G.Info)] GO.ModuleOptions)
transAbsDef x = case x of
DefCat catdefs -> liftM (Left . concat) $ mapM transCatDef catdefs
DefFun fundefs -> do
@@ -240,7 +240,7 @@ transAbsDef x = case x of
DefTrans defs -> do
defs' <- liftM concat $ mapM getDefsGen defs
returnl [(c, G.AbsTrans f) | (c,(_,Yes f)) <- defs']
- DefFlag defs -> liftM Right $ mapM transFlagDef defs
+ DefFlag defs -> liftM (Right . concatModuleOptions) $ mapM transFlagDef defs
_ -> Bad $ "illegal definition in abstract module:" ++++ printTree x
where
-- to get data constructors as terms
@@ -253,9 +253,9 @@ transAbsDef x = case x of
returnl :: a -> Err (Either a b)
returnl = return . Left
-transFlagDef :: FlagDef -> Err GO.Option
+transFlagDef :: FlagDef -> Err GO.ModuleOptions
transFlagDef x = case x of
- FlagDef f x -> return $ GO.Opt (prPIdent f,[prPIdent x])
+ FlagDef f x -> parseModuleOptions ["--" ++ prPIdent f ++ "=" ++ prPIdent x]
where
prPIdent (PIdent (_,c)) = BS.unpack c
@@ -306,7 +306,7 @@ transDataDef x = case x of
DataId id -> liftM G.Cn $ transIdent id
DataQId id0 id -> liftM2 G.QC (transIdent id0) (transIdent id)
-transResDef :: TopDef -> Err (Either [(Ident, G.Info)] [GO.Option])
+transResDef :: TopDef -> Err (Either [(Ident, G.Info)] GO.ModuleOptions)
transResDef x = case x of
DefPar pardefs -> do
pardefs' <- mapM transParDef pardefs
@@ -332,7 +332,7 @@ transResDef x = case x of
defs' <- liftM concat $ mapM getDefs defs
returnl [(f, G.ResOper pt pe) | (f,(pt,pe)) <- defs']
- DefFlag defs -> liftM Right $ mapM transFlagDef defs
+ DefFlag defs -> liftM (Right . concatModuleOptions) $ mapM transFlagDef defs
_ -> Bad $ "illegal definition form in resource" +++ printTree x
where
mkOverload (c,j) = case j of
@@ -354,7 +354,7 @@ transParDef x = case x of
ParDefAbs id -> liftM2 (,) (transIdent id) (return [])
_ -> Bad $ "illegal definition in resource:" ++++ printTree x
-transCncDef :: TopDef -> Err (Either [(Ident, G.Info)] [GO.Option])
+transCncDef :: TopDef -> Err (Either [(Ident, G.Info)] GO.ModuleOptions)
transCncDef x = case x of
DefLincat defs -> do
defs' <- liftM concat $ mapM transPrintDef defs
@@ -374,7 +374,7 @@ transCncDef x = case x of
DefPrintOld defs -> do --- a guess, for backward compatibility
defs' <- liftM concat $ mapM transPrintDef defs
returnl [(f, G.CncFun Nothing nope (yes e)) | (f,e) <- defs']
- DefFlag defs -> liftM Right $ mapM transFlagDef defs
+ DefFlag defs -> liftM (Right . concatModuleOptions) $ mapM transFlagDef defs
DefPattern defs -> do
defs' <- liftM concat $ mapM getDefs defs
let defs2 = [(f, termInPattern t) | (f,(_,Yes t)) <- defs']
@@ -700,10 +700,10 @@ transOldGrammar opts name0 x = case x of
ne = NoExt
q = CMCompl
- name = maybe name0 (++ ".gf") $ getOptVal opts useName
- absName = identPI $ maybe topic id $ getOptVal opts useAbsName
- resName = identPI $ maybe ("Res" ++ lang) id $ getOptVal opts useResName
- cncName = identPI $ maybe lang id $ getOptVal opts useCncName
+ name = maybe name0 (++ ".gf") $ moduleFlag optName opts
+ absName = identPI $ maybe topic id $ moduleFlag optAbsName opts
+ resName = identPI $ maybe ("Res" ++ lang) id $ moduleFlag optResName opts
+ cncName = identPI $ maybe lang id $ moduleFlag optCncName opts
identPI s = PIdent ((0,0),BS.pack s)
diff --git a/src-3.0/GFC.hs b/src-3.0/GFC.hs
index 12c6e8681..09d01f615 100644
--- a/src-3.0/GFC.hs
+++ b/src-3.0/GFC.hs
@@ -12,56 +12,40 @@ import GF.Infra.Option
import GF.GFCC.API
import GF.Data.ErrM
+import Data.Maybe
import System.FilePath
-mainGFC :: [String] -> IO ()
-mainGFC xx = do
- let (opts,fs) = getOptions "-" xx
- case opts of
- _ | oElem (iOpt "help") opts -> putStrLn usageMsg
- _ | oElem (iOpt "-make") opts -> do
- gfcc <- appIOE (compileToGFCC opts fs) >>= err fail return
- let gfccFile = targetNameGFCC opts (absname gfcc)
- outputFile gfccFile (printGFCC gfcc)
- mapM_ (alsoPrint opts gfcc) printOptions
- -- gfc -o target.gfcc source_1.gfcc ... source_n.gfcc
- _ | all ((==".gfcc") . takeExtensions) fs -> do
- gfccs <- mapM file2gfcc fs
- let gfcc = foldl1 unionGFCC gfccs
- let gfccFile = targetNameGFCC opts (absname gfcc)
- outputFile gfccFile (printGFCC gfcc)
- mapM_ (alsoPrint opts gfcc) printOptions
-
- _ -> do
- appIOE (mapM_ (batchCompile opts) (map return fs)) >>= err fail return
- putStrLn "Done."
-
-targetName :: Options -> CId -> String
-targetName opts abs = case getOptVal opts (aOpt "target") of
- Just n -> n
- _ -> prCId abs
-
-targetNameGFCC :: Options -> CId -> FilePath
-targetNameGFCC opts abs = targetName opts abs ++ ".gfcc"
-
----- TODO: nicer and richer print options
-
-alsoPrint opts gr (opt,name) = do
- if oElem (iOpt opt) opts
- then outputFile name (prGFCC opt gr)
- else return ()
-
-outputFile :: FilePath -> String -> IO ()
-outputFile outfile output =
+mainGFC :: Options -> [FilePath] -> IOE ()
+mainGFC opts fs =
+ do gr <- batchCompile opts fs
+ let cnc = justModuleName (last fs)
+ if flag optStopAfterPhase opts == Compile
+ then return ()
+ else do gfcc <- link opts cnc gr
+ writeOutputs opts gfcc
+
+writeOutputs :: Options -> GFCC -> IOE ()
+writeOutputs opts gfcc = mapM_ (\fmt -> writeOutput opts fmt gfcc) (flag optOutputFormats opts)
+
+writeOutput :: Options -> OutputFormat-> GFCC -> IOE ()
+writeOutput opts fmt gfcc =
+ do let path = outputFilePath opts fmt (prCId (absname gfcc))
+ s = prGFCC fmt gfcc
+ writeOutputFile path s
+
+outputFilePath :: Options -> OutputFormat -> String -> FilePath
+outputFilePath opts fmt name0 = addDir name <.> fmtExtension fmt
+ where name = fromMaybe name0 (moduleFlag optName opts)
+ addDir = maybe id (</>) (flag optOutputDir opts)
+
+fmtExtension :: OutputFormat -> String
+fmtExtension FmtGFCC = "gfcc"
+fmtExtension FmtJavaScript = "js"
+fmtExtension FmtHaskell = "hs"
+fmtExtension FmtHaskellGADT = "hs"
+
+writeOutputFile :: FilePath -> String -> IOE ()
+writeOutputFile outfile output = ioeIO $
do writeFile outfile output
putStrLn $ "wrote file " ++ outfile
-
-printOptions = [
- ("haskell","GSyntax.hs"),
- ("haskell_gadt","GSyntax.hs"),
- ("js","grammar.js")
- ]
-
-usageMsg =
- "usage: gfc (-h | --make (-noopt) (-noparse) (-target=PREFIX) (-js | -haskell | -haskell_gadt)) (-src) FILES"
diff --git a/src-3.0/GFI.hs b/src-3.0/GFI.hs
index 5769d0550..97af0b3a4 100644
--- a/src-3.0/GFI.hs
+++ b/src-3.0/GFI.hs
@@ -3,12 +3,12 @@ module GFI (mainGFI) where
import GF.Command.Interpreter
import GF.Command.Importing
import GF.Command.Commands
+import GF.Data.ErrM
import GF.GFCC.API
-
import GF.Grammar.API -- for cc command
import GF.Infra.UseIO
-import GF.Infra.Option ---- Haskell's option lib
+import GF.Infra.Option
import GF.System.Readline (fetchCommand)
import System.CPUTime
@@ -17,10 +17,10 @@ import Data.Version
import Paths_gf
-mainGFI :: [String] -> IO ()
-mainGFI xx = do
+mainGFI :: Options -> [FilePath] -> IO ()
+mainGFI opts files = do
putStrLn welcome
- env <- importInEnv emptyMultiGrammar xx
+ env <- importInEnv emptyMultiGrammar opts files
loop (GFEnv emptyGrammar env [] 0)
return ()
@@ -31,25 +31,26 @@ loop gfenv0 = do
s <- fetchCommand (prompt env)
let gfenv = gfenv0 {history = s : history gfenv0}
case words s of
-
-- special commands, requiring source grammar in env
"cc":ws -> do
- let (opts,term) = getOptions "-" ws
+ -- FIXME: add options parsing for cc arguments
+ let (opts,term) = (TermPrintDefault, ws)
let t = pTerm (unwords term) >>= checkTerm sgr >>= computeTerm sgr
err putStrLn (putStrLn . showTerm opts) t ---- make pipable
loopNewCPU gfenv
-
"i":args -> do
- let (opts,files) = getOptions "-" args
- case opts of
- _ | oElem (iOpt "retain") opts -> do
- src <- importSource sgr opts files
- loopNewCPU $ gfenv {sourcegrammar = src}
+ case parseOptions args of
+ Ok (opts,files)
+ | flag optRetainResource opts ->
+ do src <- importSource sgr opts files
+ loopNewCPU $ gfenv {sourcegrammar = src}
+ | otherwise ->
+ do env1 <- importInEnv (multigrammar env) opts files
+ loopNewCPU $ gfenv {commandenv = env1}
+ Bad err -> do putStrLn $ "Command parse error: " ++ err
+ loopNewCPU gfenv
-- other special commands, working on GFEnv
- _ -> do
- env1 <- importInEnv (multigrammar env) args
- loopNewCPU $ gfenv {commandenv = env1}
"e":_ -> loopNewCPU $ gfenv {commandenv=env{multigrammar=emptyMultiGrammar}}
"ph":_ -> mapM_ putStrLn (reverse (history gfenv0)) >> loopNewCPU gfenv
"q":_ -> putStrLn "See you." >> return gfenv
@@ -64,8 +65,8 @@ loopNewCPU gfenv = do
putStrLn (show ((cpu' - cputime gfenv) `div` 1000000000) ++ " msec")
loop $ gfenv {cputime = cpu'}
-importInEnv mgr0 xx = do
- let (opts,files) = getOptions "-" xx
+importInEnv :: MultiGrammar -> Options -> [FilePath] -> IO CommandEnv
+importInEnv mgr0 opts files = do
mgr1 <- case files of
[] -> return mgr0
_ -> importGrammar mgr0 opts files
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-21 10:38:24 +0000