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 - 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)) + 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 + 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 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 + ( + -- * 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 -module GF.Infra.Option 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 Data.List (partition) -import Data.Char (isDigit) +import GF.Data.ErrM --- * 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) + + +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 [] +noOptions = Options id --- | 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 - -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) +moduleOptions :: ModuleOptions -> Options +moduleOptions (ModuleOptions f) = Options (\o -> o { optModuleFlags = f (optModuleFlags o) }) -removeOptions :: Options -> Options -> Options -removeOptions (Opts os) os0 = foldr removeOption os0 os +addModuleOptions :: ModuleOptions -- ^ Existing options. + -> ModuleOptions -- ^ Options to add (these take preference). + -> ModuleOptions +addModuleOptions (ModuleOptions o1) (ModuleOptions o2) = ModuleOptions (o2 . o1) -options :: [Option] -> Options -options = foldr addOption noOptions +concatModuleOptions :: [ModuleOptions] -> ModuleOptions +concatModuleOptions = foldr addModuleOptions noModuleOptions -unionOptions :: Options -> Options -> Options -unionOptions (Opts os) (Opts os') = Opts (os ++ os') +noModuleOptions :: ModuleOptions +noModuleOptions = ModuleOptions id --- * parsing options, with prefix pre (e.g. \"-\") +flag :: (Flags -> a) -> Options -> a +flag f (Options o) = f (o defaultFlags) -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) +moduleFlag :: (ModuleFlags -> a) -> Options -> a +moduleFlag f = flag (f . optModuleFlags) -pOption :: String -> String -> Option -pOption pre s = case span (/= '=') (drop (length pre) s) of - (f,_:a) -> aOpt f a - (o,[]) -> iOpt o - -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 - -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" - -newParser, newerParser, newCParser, newMParser :: Option -newParser = iOpt "new" -newerParser = iOpt "newer" -newCParser = iOpt "cfg" -newMParser = iOpt "mcfg" -newFParser = iOpt "fcfg" {- -useParserMCFG, useParserMCFGviaCFG, useParserCFG, useParserCF :: Option -useParserMCFG = iOpt "mcfg" -useParserMCFGviaCFG = iOpt "mcfg-via-cfg" -useParserCFG = iOpt "cfg" -useParserCF = iOpt "cf" +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) + -} --- ** grammar formats +-- Default options -showAbstr, showXML, showOld, showLatex, showFullForm, - showEBNF, showCF, showWords, showOpts, - isCompiled, isHaskell, noCompOpers, retainOpers, - noCF, checkCirc, noCheckCirc, lexerByNeed, useUTF8id :: Option -defaultGrOpts :: [Option] +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 = [] + } -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" +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 + } --- ** linearization +-- Option descriptions -allLin, firstLin, distinctLin, dontLin, - showRecord, showStruct, xmlLin, latexLin, - tableLin, useUTF8, showLang, withMetas :: Option -defaultLinOpts :: [Option] +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 } -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" + optimize x = case lookup x optimizationPackages of + Just p -> set $ \o -> o { optOptimizations = p } + Nothing -> fail $ "Unknown optimization package: " ++ x --- ** other + toggleOptimize x b = set $ \o -> o { optOptimizations = (if b then (x:) else delete x) (optOptimizations o) } -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 + dumpOption s d = Option [] ["dump-"++s] (NoArg (set $ \o -> o { optDump = d:optDump o})) ("Dump output of the " ++ s ++ " phase.") -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" + set = return . ModuleOptions --- ** mainly for stand-alone +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 } -useUnicode, optCompute, optCheck, optParaphrase, forJava :: Option + set = return . Options -useUnicode = iOpt "unicode" -optCompute = iOpt "compute" -optCheck = iOpt "typecheck" -optParaphrase = iOpt "paraphrase" -forJava = iOpt "java" +instance Functor OptDescr where + fmap f (Option cs ss d s) = Option cs ss (fmap f d) s --- ** for edit session +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 -allLangs, absView :: Option +outputFormats :: [(String,OutputFormat)] +outputFormats = + [("gfcc", FmtGFCC), + ("js", FmtJavaScript), + ("haskell", FmtHaskell), + ("haskell_gadt", FmtHaskellGADT)] -allLangs = iOpt "All" -absView = iOpt "Abs" +instance Show OutputFormat where + show = lookupShow outputFormats --- ** options that take arguments +instance Read OutputFormat where + readsPrec = lookupReadsPrec outputFormats -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 +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])] -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" +encodings :: [(String,Encoding)] +encodings = + [("utf8", UTF_8), + ("latin1", ISO_8859_1)] --- peb 16/3-05: -gfcConversion :: String -> Option -gfcConversion = aOpt "conversion" +lookupShow :: Eq a => [(String,a)] -> a -> String +lookupShow xs z = fromMaybe "lookupShow" $ lookup z [(y,x) | (x,y) <- xs] -useName, useAbsName, useCncName, useResName, - useFile, useOptimizer :: String -> Option +lookupReadsPrec :: [(String,a)] -> Int -> ReadS a +lookupReadsPrec xs _ s = [(z,rest) | (x,rest) <- lex s, (y,z) <- xs, y == x] -useName = aOpt "name" -useAbsName = aOpt "abs" -useCncName = aOpt "cnc" -useResName = aOpt "res" -useFile = aOpt "file" -useOptimizer = aOpt "optimize" +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 -markLin :: String -> Option -markOptXML, markOptJava, markOptStruct, markOptFocus :: String +readOutputFormat :: Monad m => String -> m OutputFormat +readOutputFormat s = + maybe (fail $ "Unknown output format: " ++ show s) return $ lookup s outputFormats -markLin = aOpt "mark" -markOptXML = oArg "xml" -markOptJava = oArg "java" -markOptStruct = oArg "struct" -markOptFocus = oArg "focus" +-- 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 +-- --- ** refinement order +beVerbose :: Options -> Bool +beVerbose = flag ((>= 3) . optVerbosity) -nextRefine :: String -> Option -firstRefine, lastRefine :: String +beSilent :: Options -> Bool +beSilent = flag ((<= 0) . optVerbosity) -nextRefine = aOpt "nextrefine" -firstRefine = oArg "first" -lastRefine = oArg "last" +dump :: Options -> Dump -> Bool +dump opts d = moduleFlag ((d `elem`) . optDump) opts --- ** 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." +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 -targetName :: Options -> CId -> String -targetName opts abs = case getOptVal opts (aOpt "target") of - Just n -> n - _ -> prCId abs +writeOutputs :: Options -> GFCC -> IOE () +writeOutputs opts gfcc = mapM_ (\fmt -> writeOutput opts fmt gfcc) (flag optOutputFormats opts) -targetNameGFCC :: Options -> CId -> FilePath -targetNameGFCC opts abs = targetName opts abs ++ ".gfcc" +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 ----- TODO: nicer and richer print options +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) -alsoPrint opts gr (opt,name) = do - if oElem (iOpt opt) opts - then outputFile name (prGFCC opt gr) - else return () +fmtExtension :: OutputFormat -> String +fmtExtension FmtGFCC = "gfcc" +fmtExtension FmtJavaScript = "js" +fmtExtension FmtHaskell = "hs" +fmtExtension FmtHaskellGADT = "hs" -outputFile :: FilePath -> String -> IO () -outputFile outfile output = +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